module Hails.HttpServer (
module Hails.HttpServer.Types
, execHailsApplication
, sanitizeReqMiddleware
, browserLabelGuard
, guardSensitiveResp
, sanitizeResp
, catchAllExceptions
, module Network.HTTP.Types
) where
import qualified Data.List as List
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import Data.Conduit
import Data.Conduit.List
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Error.Class
import Control.Exception (fromException)
import Network.HTTP.Types
import qualified Network.Wai as W
import qualified Network.Wai.Application.Static as W
import Network.Wai.Middleware.MethodOverridePost
import LIO
import LIO.TCB
import LIO.DCLabel
import LIO.DCLabel.Privs.TCB
import LIO.Labeled.TCB
import Hails.HttpServer.Types
import System.IO
import Data.Time (getCurrentTime)
waiToHailsReq :: W.Request -> ResourceT IO Request
waiToHailsReq req = do
curTime <- liftIO getCurrentTime
body <- fmap L.fromChunks $ W.requestBody req $$ consume
return $ Request { requestMethod = W.requestMethod req
, httpVersion = W.httpVersion req
, rawPathInfo = W.rawPathInfo req
, rawQueryString = W.rawQueryString req
, serverName = W.serverName req
, serverPort = W.serverPort req
, requestHeaders = W.requestHeaders req
, isSecure = W.isSecure req
, remoteHost = W.remoteHost req
, pathInfo = W.pathInfo req
, queryString = W.queryString req
, requestBody = body
, requestTime = curTime }
sanitizeReqMiddleware :: W.Middleware
sanitizeReqMiddleware app req = app $ req { W.requestHeaders = headers }
where headers = List.filter ((/= "X-Hails-User") . fst) $ W.requestHeaders req
hailsToWaiResponse :: Response -> W.Response
hailsToWaiResponse (Response stat rhd body) = W.responseLBS stat rhd body
browserLabelGuard :: Middleware
browserLabelGuard hailsApp conf req = do
response <- hailsApp conf req
resultLabel <- getLabel
return $ if resultLabel `canFlowTo` (browserLabel conf)
then response
else Response status403 [] ""
guardSensitiveResp :: Middleware
guardSensitiveResp happ p req = do
response <- happ p req
resultLabel <- getLabel
return $ addResponseHeader response $
("X-Hails-Label", S8.pack $
if resultLabel `canFlowTo` dcPub
then "{\"isPublic\": true}"
else "{\"isPublic\": false, \"label\": [" ++ mkClientLabel resultLabel ++ "]}")
where mkClientLabel l = let s = dcSecrecy l
cs = toList s
in if s == dcFalse || length cs /= 1
then ""
else List.intercalate ", " $
List.map (show . S8.unpack . principalName) $
List.head cs
sanitizeResp :: Middleware
sanitizeResp hailsApp conf req = do
response <- hailsApp conf req
return $ foldr (\h r -> removeResponseHeader r h) response unsafeHeaders
where unsafeHeaders = ["Set-Cookie", "X-Hails-Label"]
secureApplication :: Middleware
secureApplication = browserLabelGuard
. sanitizeResp
. guardSensitiveResp
catchAllExceptions :: W.Middleware
catchAllExceptions app req = app req `catchError` (const $ return resp500)
where resp500 = W.responseLBS status500 [] "App threw an exception"
execHailsApplication :: W.Middleware -> Application -> W.Application
execHailsApplication authMiddleware app =
catchAllExceptions
. sanitizeReqMiddleware
. methodOverridePost
. authMiddleware
$ \req -> hailsApplicationToWai app req
hailsApplicationToWai :: Application -> W.Application
hailsApplicationToWai app0 req0 | isStatic req0 =
W.staticApp (W.defaultWebAppSettings "./") req0
| otherwise = do
hailsRequest <- waiToHailsReq req0
let conf = getRequestConf hailsRequest
result <- liftIO $ paranoidDC' conf $ do
let lreq = labelTCB (requestLabel conf) hailsRequest
app conf lreq
case result of
Right (response,_) -> return $ hailsToWaiResponse response
Left err -> do
liftIO $ hPutStrLn stderr $ "App threw exception: " ++ show err
return $ case fromException err of
Just (LabeledExceptionTCB l _) ->
if l `canFlowTo` (browserLabel conf)
then resp500 else resp403
_ -> resp500
where app = secureApplication app0
isStatic req = case W.pathInfo req of
("static":_) -> True
_ -> False
resp403 = W.responseLBS status403 [] ""
resp500 = W.responseLBS status500 [] ""
paranoidDC' conf act =
paranoidLIO act $ LIOState { lioLabel = dcPub
, lioClearance = browserLabel conf}
getRequestConf :: Request -> RequestConfig
getRequestConf req =
let headers = requestHeaders req
userName = toComponent `fmap` lookup "x-hails-user" headers
appName = '@' : (S8.unpack . S8.takeWhile (/= '.') $ serverName req)
appPriv = DCPrivTCB $ toComponent appName
in RequestConfig
{ browserLabel = maybe dcPub (\un -> dcLabel un anybody) userName
, requestLabel = maybe dcPub (\un -> dcLabel anybody un) userName
, appPrivilege = appPriv }