module LIO.Web.Simple.TCB (
SimpleLIOApplication, SimpleLIOMiddleware
, run, runP
, browserLabelGuard
, removeRequestHeaders
, removeResponseHeaders
, lioGetTemplateTCB
) where
import safe Control.Monad
import Data.Text.Encoding
import safe Control.Applicative
import safe LIO
import safe LIO.Error
import LIO.TCB (ioTCB, getLIOStateTCB)
import safe qualified Data.List as List
import safe qualified Data.ByteString.Char8 as S8
import safe qualified Data.ByteString.Lazy.Char8 as L8
import safe Web.Simple
import safe Web.Simple.Controller.Trans
import safe Web.Simple.Templates.Language
import Network.HTTP.Types
import Network.Wai.Internal
import Network.Wai.Handler.Warp hiding (run)
import qualified Network.Wai.Handler.Warp as Warp
import safe System.FilePath
type SimpleLIOApplication p l = Priv p -> SimpleApplication (LIO l)
type SimpleLIOMiddleware p l = SimpleLIOApplication p l -> SimpleLIOApplication p l
run :: Label l => Port -> Middleware -> SimpleApplication (LIO l) -> LIO l ()
run port middleware app = runP port middleware noPrivs (const app)
runP :: (PrivDesc l p, Label l)
=> Port -> Middleware -> Priv p -> SimpleLIOApplication p l -> LIO l ()
runP port middleware priv app = do
state <- getLIOStateTCB
ioTCB $ Warp.run port $ middleware . filterFileResponses $
\req -> evalLIO (app priv req) state
filterFileResponses :: Middleware
filterFileResponses app req = do
resp <- app req
return $ case resp of
ResponseBuilder _ _ _ -> resp
_ -> serverError $ L8.pack "App should not read directly from files."
browserLabelGuard :: MonadLIO l m => l -> SimpleMiddleware m
browserLabelGuard browserLabel app req = do
resp <- app req
resultLabel <- liftLIO $ getLabel
return $ if resultLabel `canFlowTo` browserLabel
then resp
else forbidden
removeRequestHeaders :: Monad m => [HeaderName] -> SimpleMiddleware m
removeRequestHeaders headers app req = do
app $ foldr (\h r -> rmRequestHeader r h) req headers
where rmRequestHeader r h = r { requestHeaders = rm h (requestHeaders r) }
removeResponseHeaders :: Monad m => [HeaderName] -> SimpleMiddleware m
removeResponseHeaders headers app req = do
resp <- app req
return $ foldr (\h r -> rmResponseHeader r h) resp headers
rmResponseHeader :: Response -> HeaderName -> Response
rmResponseHeader (ResponseFile x hs y z) h = ResponseFile x hs' y z where hs' = rm h hs
rmResponseHeader (ResponseBuilder x hs y ) h = ResponseBuilder x hs' y where hs' = rm h hs
rmResponseHeader (ResponseSource x hs y ) h = ResponseSource x hs' y where hs' = rm h hs
rmResponseHeader (ResponseRaw x r ) h = ResponseRaw x (rmResponseHeader r h)
rm :: HeaderName -> [Header] -> [Header]
rm h = List.filter ((/= h) . fst)
lioGetTemplateTCB :: Label l => FilePath -> LIO l Template
lioGetTemplateTCB fp = do
fp' <- cleanUpPath fp
eres <- compileTemplate . decodeUtf8 <$> (ioTCB $ S8.readFile fp')
case eres of
Left str -> fail str
Right tmpl -> return tmpl
cleanUpPath :: Label l => FilePath -> LIO l FilePath
cleanUpPath path = withContext "cleanUpPath" $
doit . splitDirectories . normalise . stripSlash $ path
where doit [] = return []
doit ("..":_) = throwLIO $ userError "Path cannot contain .."
doit (_:"..":xs) = doit xs
doit (".":xs) = doit xs
doit (x:xs) = (x </>) `liftM` doit xs
stripSlash :: FilePath -> FilePath
stripSlash [] = []
stripSlash xx@(x:xs) | x == pathSeparator = stripSlash xs
| otherwise = xx