module Hails.HttpServer.Types (
Request(..)
, getRequestBodyType, RequestBodyType(..)
, addRequestHeader, removeRequestHeader
, Response(..)
, module Network.HTTP.Types
, addResponseHeader, removeResponseHeader
, Application, RequestConfig(..)
, Middleware
) where
import qualified Data.List as List
import Data.Text (Text)
import Data.Typeable
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import Network.Socket (SockAddr)
import Network.HTTP.Types
import Network.Wai.Parse (RequestBodyType(..))
import Data.Time (UTCTime)
import LIO.DCLabel
data Request = Request {
requestMethod :: Method
, httpVersion :: HttpVersion
, rawPathInfo :: S.ByteString
, rawQueryString :: S.ByteString
, serverName :: S.ByteString
, requestHeaders :: RequestHeaders
, isSecure :: Bool
, remoteHost :: SockAddr
, pathInfo :: [Text]
, queryString :: Query
, requestBody :: L.ByteString
, requestTime :: UTCTime
} deriving (Show, Typeable)
getRequestBodyType :: Request -> Maybe RequestBodyType
getRequestBodyType req = do
ctype <- lookup "Content-Type" $ requestHeaders req
if urlenc `S.isPrefixOf` ctype
then Just UrlEncoded
else case boundary ctype of
Just x -> Just $ Multipart x
Nothing -> Nothing
where
urlenc = S8.pack "application/x-www-form-urlencoded"
formBound = S8.pack "multipart/form-data;"
bound' = "boundary="
boundary s =
if "multipart/form-data;" `S.isPrefixOf` s
then
let s' = S.dropWhile (== 32) $ S.drop (S.length formBound) s
in if bound' `S.isPrefixOf` s'
then Just $ S.drop (S.length bound') s'
else Nothing
else Nothing
addRequestHeader :: Request -> Header -> Request
addRequestHeader req hdr@(hname, _) = req { requestHeaders = hdr:headers }
where headers = List.filter ((/= hname) . fst) $ requestHeaders req
removeRequestHeader :: Request -> HeaderName -> Request
removeRequestHeader req hname = req { requestHeaders = headers }
where headers = List.filter ((/= hname) . fst) $ requestHeaders req
data Response = Response {
respStatus :: Status
, respHeaders :: ResponseHeaders
, respBody :: L.ByteString
} deriving (Show, Typeable)
addResponseHeader :: Response -> Header -> Response
addResponseHeader resp hdr@(hname, _) = resp { respHeaders = hdr:headers }
where headers = List.filter ((/= hname) . fst) $ respHeaders resp
removeResponseHeader :: Response -> HeaderName -> Response
removeResponseHeader resp hname = resp { respHeaders = headers }
where headers = List.filter ((/= hname) . fst) $ respHeaders resp
data RequestConfig = RequestConfig {
browserLabel :: DCLabel
, requestLabel :: DCLabel
, appPrivilege :: DCPriv
} deriving (Show, Typeable)
type Application = RequestConfig -> DCLabeled Request -> DC Response
type Middleware = Application -> Application