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.Set as Set
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import Data.Conduit
import Data.Conduit.List hiding (head)
import Data.Monoid
import Control.Monad (liftM)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Error.Class
import Network.HTTP.Types
import Network.URI (isURI)
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 Hails.HttpServer.Types
import System.IO
import Data.Time (getCurrentTime)
waiToHailsReq :: W.Request -> 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
, requestHeaders = W.requestHeaders req
, isSecure = W.isSecure req
, remoteHost = W.remoteHost req
, serverName = sN
, pathInfo = W.pathInfo req
, queryString = W.queryString req
, requestBody = body
, requestTime = curTime }
where sN = case lookup "Host" $ W.requestHeaders req of
Just h -> h
_ -> error "requestToUri: missing Host header"
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 app config req = do
response <- (flip removeResponseHeader) csp `liftM` app config req
resultLabel <- getLabel
return $ if resultLabel `canFlowTo` dcPublic
then response
else addResponseHeader response $
( csp
, "default-src " <> headerVal resultLabel <> ";")
where csp = "Content-Security-Policy"
headerVal l =
let secrecy = dcSecrecy l
secrecySet = cToSet secrecy
uriList = Set.filter (isURI . S8.unpack) $
Set.map principalName $
dToSet $ head $ Set.elems secrecySet
in if secrecy == cFalse || Set.size secrecySet > 1
then "'self','unsafe-inline'"
else S8.unwords $
"'self'":"'unsafe-inline'":(Set.toList uriList)
sanitizeResp :: Middleware
sanitizeResp hailsApp conf req = do
response <- hailsApp conf req
return $ foldr (\h r -> removeResponseHeader r h) response unsafeHeaders
where unsafeHeaders = ["Set-Cookie"]
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, dcState) <- liftIO $ tryDCDef conf $ do
let lreq = LabeledTCB (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 $
if lioLabel dcState `canFlowTo` (browserLabel conf) then
resp500
else resp403
where app = secureApplication app0
isStatic req = case W.pathInfo req of
("static":_) -> True
_ -> False
resp403 = W.responseLBS status403 [] ""
resp500 = W.responseLBS status500 [] ""
tryDCDef conf act = tryDC $ do
putLIOStateTCB $ LIOState { lioLabel = dcPublic
, lioClearance = browserLabel conf}
act
getRequestConf :: Request -> RequestConfig
getRequestConf req =
let headers = requestHeaders req
muserName = principalBS `fmap` lookup "x-hails-user" headers
appName = "@" `S8.append` (S8.takeWhile (/= '.') $ serverName req)
appPriv = PrivTCB $ toCNF $ principalBS appName
in RequestConfig
{ browserLabel = maybe dcPublic (\userName -> userName %% True) muserName
, requestLabel = maybe dcPublic (\userName -> True %% userName) muserName
, appPrivilege = appPriv }