module Network.Wai.Middleware.Routes.Handler
( HandlerM()
, runHandlerM
, mountedAppHandler
, request
, isWebsocket
, reqHeader
, reqHeaders
, routeAttrSet
, rootRouteAttrSet
, maybeRoute
, maybeRootRoute
, showRouteMaster
, showRouteSub
, showRouteQueryMaster
, showRouteQuerySub
, readRouteMaster
, readRouteSub
, master
, sub
, rawBody
, textBody
, jsonBody
, header
, status
, file
, filepart
, stream
, raw
, rawBuilder
, json
, plain
, html
, css
, javascript
, content
, asContent
, whenContent
, next
, getParams
, getParam
, getQueryParams
, getQueryParam
, getPostParams
, getPostParam
, getFileParams
, getFileParam
, setCookie
, getCookie
, getCookies
, reqVault
, lookupVault
, updateVault
)
where
import Network.Wai (Application, Request, Response, responseRaw, responseFile, responseBuilder, responseStream, pathInfo, queryString, requestBody, StreamingBody, requestHeaders, FilePart)
#if MIN_VERSION_wai(3,0,1)
import Network.Wai (strictRequestBody, vault)
#endif
import Network.Wai.Middleware.Routes.Routes (Env(..), RequestData, HandlerS, waiReq, currentRoute, runNext, ResponseHandler, showRoute, showRouteQuery, readRoute, readQueryString)
import Network.Wai.Middleware.Routes.Class (Route, RenderRoute, ParseRoute, RouteAttrs(..))
import Network.Wai.Middleware.Routes.ContentTypes (acceptContentType, contentType, contentTypeFromFile, typeHtml, typeJson, typePlain, typeCss, typeJavascript, typeAll)
import Control.Monad (liftM, when)
import Control.Monad.Loops (unfoldWhileM)
import Control.Monad.State (StateT, get, put, modify, runStateT, MonadState, MonadIO, lift, liftIO, MonadTrans)
import Control.Applicative (Applicative, (<$>), (<*>))
import Data.Maybe (maybe, fromMaybe)
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Blaze.ByteString.Builder (Builder, toByteString, fromByteString)
import Network.HTTP.Types.Header (HeaderName(), RequestHeaders)
import Network.HTTP.Types.Status (Status(), status200)
import Data.Aeson (ToJSON, FromJSON, eitherDecodeStrict)
import qualified Data.Aeson as A
import qualified Data.Aeson.Encode as AE
import Data.Set (Set)
import qualified Data.Set as S (empty, map)
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Data.CaseInsensitive (CI, mk)
import Web.Cookie (CookiesText, parseCookiesText, renderSetCookie, SetCookie(..))
import Data.Default.Class (def)
import Data.List (intersect)
import qualified Data.Vault.Lazy as V
import qualified Network.Wai.Parse as P
newtype HandlerMI sub master m a = H { extractH :: StateT (HandlerState sub master) m a }
deriving (Applicative, Monad, MonadIO, Functor, MonadTrans, MonadState (HandlerState sub master))
type HandlerM sub master a = HandlerMI sub master IO a
data FileInfo = FileInfo
{ fileName :: Text
, fileContentType :: Text
, fileContent :: BL.ByteString
}
type PostParams = ([(Text, Text)], [(Text, FileInfo)])
_toPostParams :: ([P.Param], [P.File BL.ByteString]) -> PostParams
_toPostParams (params, files) = (params', files')
where
params' = map (\(k,v) -> (decodeUtf8 k, decodeUtf8 v)) params
files' = map (\(k,v) -> (decodeUtf8 k, decodeFileInfo v)) files
decodeFileInfo fi = FileInfo
{ fileName = decodeUtf8 $ P.fileName fi
, fileContentType = decodeUtf8 $ P.fileContentType fi
, fileContent = P.fileContent fi
}
type RespRawHandler = IO B.ByteString -> (B.ByteString -> IO ()) -> IO ()
data HandlerState sub master = HandlerState
{ getMaster :: master
, getRequestData :: RequestData sub
, reqBody :: Maybe ByteString
, respHeaders :: [(HeaderName, ByteString)]
, respStatus :: Status
, respResp :: Maybe MkResponse
, respRaw :: Maybe RespRawHandler
, respCookies :: [SetCookie]
, getSub :: sub
, toMasterRoute :: Route sub -> Route master
, postParams :: Maybe PostParams
, acceptCTypes :: Maybe [ByteString]
}
defaultHandlerState :: Env sub master -> RequestData sub -> HandlerState sub master
defaultHandlerState env req = HandlerState
{ getMaster = envMaster env
, getRequestData = req
, reqBody = Nothing
, respHeaders = []
, respStatus = status200
, respResp = Nothing
, respRaw = Nothing
, respCookies = []
, getSub = envSub env
, toMasterRoute = envToMaster env
, postParams = Nothing
, acceptCTypes = Nothing
}
data MkResponse
= ResponseFile FilePath (Maybe FilePart)
| ResponseBuilder Builder
| ResponseStream StreamingBody
| ResponseNext
defaultResponse :: MkResponse
defaultResponse = ResponseBuilder ""
cookieHeaderName :: CI ByteString
cookieHeaderName = mk "Cookie"
cookieSetHeaderName :: CI ByteString
cookieSetHeaderName = mk "Set-Cookie"
mountedAppHandler :: Application -> HandlerS sub master
mountedAppHandler app _env req hh = app (waiReq req) hh
runHandlerM :: HandlerM sub master () -> HandlerS sub master
runHandlerM h env req hh = do
(_, st) <- runStateT (extractH h) (defaultHandlerState env req)
case fromMaybe defaultResponse (respResp st) of
ResponseNext -> runNext (getRequestData st) hh
otherResponse -> do
let headers' = map mkSetCookie (respCookies st) ++ respHeaders st
let resp = mkResponse (respStatus st) headers' otherResponse
case respRaw st of
Nothing -> hh resp
Just rawHandler -> hh $ responseRaw rawHandler resp
where
mkSetCookie s = (cookieSetHeaderName, toByteString $ renderSetCookie s)
mkResponse status headers (ResponseFile path part) = responseFile status headers path part
mkResponse status headers (ResponseBuilder builder) = responseBuilder status headers builder
mkResponse status headers (ResponseStream streaming) = responseStream status headers streaming
rawBody :: HandlerM sub master ByteString
rawBody = do
s <- get
case reqBody s of
Just consumedBody -> return consumedBody
Nothing -> do
req <- request
rbody <- liftIO $ BL.toStrict <$> _readStrictRequestBody req
put s {reqBody = Just rbody}
return rbody
textBody :: HandlerM master master Text
textBody = liftM decodeUtf8 rawBody
_readStrictRequestBody :: Request -> IO BL.ByteString
_readStrictRequestBody =
#if MIN_VERSION_wai(3,0,1)
strictRequestBody
#else
BL.fromChunks <$> unfoldWhileM (not . B.null) . requestBody
#endif
jsonBody :: FromJSON a => HandlerM sub master (Either String a)
jsonBody = liftM eitherDecodeStrict rawBody
master :: HandlerM sub master master
master = liftM getMaster get
sub :: HandlerM sub master sub
sub = liftM getSub get
request :: HandlerM sub master Request
request = liftM (waiReq . getRequestData) get
isWebsocket :: HandlerM sub master Bool
isWebsocket = liftM (maybe False (== "websocket")) (_reqHeaderBS "upgrade")
reqHeader :: Text -> HandlerM sub master (Maybe Text)
reqHeader name = liftM (fmap decodeUtf8) (_reqHeaderBS nameText)
where
nameText = mk $ encodeUtf8 name
_reqHeaderBS :: CI ByteString -> HandlerM sub master (Maybe ByteString)
_reqHeaderBS name = liftM (lookup name) reqHeaders
reqVault :: HandlerM sub master V.Vault
reqVault = liftM vault request
lookupVault :: V.Key a -> HandlerM sub master (Maybe a)
lookupVault k = liftM (V.lookup k) reqVault
updateVault :: (V.Vault -> V.Vault) -> HandlerM sub master ()
updateVault f = modify $ \st ->
let rd = getRequestData st
r = waiReq rd
v = f $ vault r
in st { getRequestData = rd { waiReq = r { vault = v } } }
reqHeaders :: HandlerM sub master RequestHeaders
reqHeaders = liftM requestHeaders request
maybeRoute :: HandlerM sub master (Maybe (Route sub))
maybeRoute = liftM (currentRoute . getRequestData) get
maybeRootRoute :: HandlerM sub master (Maybe (Route master))
maybeRootRoute = do
s <- get
return $ toMasterRoute s <$> currentRoute (getRequestData s)
showRouteMaster :: RenderRoute master => HandlerM sub master (Route master -> Text)
showRouteMaster = return showRoute
showRouteSub :: RenderRoute master => HandlerM sub master (Route sub -> Text)
showRouteSub = do
s <- get
return $ showRoute . toMasterRoute s
showRouteQueryMaster :: RenderRoute master => HandlerM sub master (Route master -> [(Text,Text)] -> Text)
showRouteQueryMaster = return showRouteQuery
showRouteQuerySub :: RenderRoute master => HandlerM sub master (Route sub -> [(Text,Text)] -> Text)
showRouteQuerySub = do
s <- get
return $ showRouteQuery . toMasterRoute s
readRouteMaster :: ParseRoute master => HandlerM sub master (Text -> Maybe (Route master))
readRouteMaster = return readRoute
readRouteSub :: ParseRoute sub => HandlerM sub master (Text -> Maybe (Route master))
readRouteSub = do
s <- get
return $ (toMasterRoute s <$>) . readRoute
routeAttrSet :: RouteAttrs sub => HandlerM sub master (Set Text)
routeAttrSet = liftM (maybe S.empty routeAttrs . currentRoute . getRequestData) get
rootRouteAttrSet :: RouteAttrs master => HandlerM sub master (Set Text)
rootRouteAttrSet = do
s <- get
return $ maybe S.empty (routeAttrs . toMasterRoute s) $ currentRoute $ getRequestData s
header :: HeaderName -> ByteString -> HandlerM sub master ()
header h s = modify $ addHeader h s
where
addHeader :: HeaderName -> ByteString -> HandlerState sub master -> HandlerState sub master
addHeader h b s@(HandlerState {respHeaders=hs}) = s {respHeaders=(h,b):hs}
status :: Status -> HandlerM sub master ()
status s = modify $ setStatus s
where
setStatus :: Status -> HandlerState sub master -> HandlerState sub master
setStatus s st = st{respStatus=s}
file :: FilePath -> HandlerM sub master ()
file f = do
header contentType $ contentTypeFromFile f
modify addFile
where
addFile st = _setResp st $ ResponseFile f Nothing
filepart :: FilePath -> FilePart -> HandlerM sub master ()
filepart f part = do
header contentType $ contentTypeFromFile f
modify addFile
where
addFile st = _setResp st $ ResponseFile f (Just part)
stream :: StreamingBody -> HandlerM sub master ()
stream s = modify addStream
where
addStream st = _setResp st $ ResponseStream s
raw :: ByteString -> HandlerM sub master ()
raw = rawBuilder . fromByteString
rawBuilder :: Builder -> HandlerM sub master ()
rawBuilder b = modify addBody
where
addBody st = _setResp st $ ResponseBuilder b
next :: HandlerM sub master ()
next = modify rNext
where
rNext st = _setResp st ResponseNext
_setResp :: HandlerState sub master -> MkResponse -> HandlerState sub master
_setResp st r = case respResp st of
Nothing -> st{respResp=Just r}
_ -> st
json :: ToJSON a => a -> HandlerM sub master ()
json a = do
header contentType typeJson
rawBuilder $ _encode $ A.toJSON a
where
#if MIN_VERSION_aeson(0,9,0)
_encode = AE.encodeToBuilder
#else
_encode = AE.encodeToByteStringBuilder
#endif
plain :: Text -> HandlerM sub master ()
plain = asContent typePlain
html :: Text -> HandlerM sub master ()
html = asContent typeHtml
css :: Text -> HandlerM sub master ()
css = asContent typeCss
javascript :: Text -> HandlerM sub master ()
javascript = asContent typeJavascript
asContent :: ByteString -> Text -> HandlerM sub master ()
asContent ctype content = do
header contentType ctype
raw $ encodeUtf8 content
content :: [ByteString] -> Text -> HandlerM sub master ()
content [] _ = return ()
content ctypes content = whenContent ctypes (asContent (head ctypes) content)
whenContent :: [ByteString] -> HandlerM sub master () -> HandlerM sub master ()
whenContent ctypes respHandler = do
atypes <- acceptableContentTypes
let noAcceptList = not $ null atypes
let acceptableTypeFound = not $ null $ intersect (typeAll:ctypes) atypes
when (noAcceptList || acceptableTypeFound) respHandler
acceptableContentTypes :: HandlerM sub master [ByteString]
acceptableContentTypes = do
st <- get
maybe (getCTypes st) return (acceptCTypes st)
where
getCTypes st = do
h <- _reqHeaderBS acceptContentType
let parsedCTypes = maybe [] P.parseHttpAccept h
put st{acceptCTypes = Just parsedCTypes}
return parsedCTypes
setCookie :: SetCookie -> HandlerM sub master ()
setCookie s = modify setCookie
where
setCookie st = st {respCookies = s : respCookies st}
getCookies :: HandlerM sub master CookiesText
getCookies = do
cookies <- _reqHeaderBS cookieHeaderName
return $ case cookies of
Nothing -> []
Just cookies' -> parseCookiesText cookies'
getCookie :: Text -> HandlerM sub master (Maybe Text)
getCookie name = do
cookies <- getCookies
return $ lookup name cookies
_getCachedPostParams :: HandlerM sub master (Maybe PostParams)
_getCachedPostParams = postParams <$> get
_populatePostParams :: HandlerM sub master PostParams
_populatePostParams = do
st <- get
case postParams st of
Just params -> return params
Nothing -> do
req <- request
params <- case P.getRequestBodyType req of
Nothing -> return ([],[])
Just _ -> do
params <- liftIO $ P.parseRequestBody P.lbsBackEnd req
return $ _toPostParams params
put $ st{postParams=Just params}
return params
_getAllFileOrPostParams :: HandlerM sub master PostParams
_getAllFileOrPostParams = do
cachedPostParams <- _getCachedPostParams
case cachedPostParams of
Nothing -> _populatePostParams
Just params -> return params
getQueryParams :: HandlerM sub master [(Text,Text)]
getQueryParams = readQueryString . queryString <$> request
getQueryParam :: Text -> HandlerM sub master (Maybe Text)
getQueryParam name = lookup name <$> getQueryParams
getPostParams :: HandlerM sub master [(Text,Text)]
getPostParams = do
(params,_) <- _getAllFileOrPostParams
return params
getPostParam :: Text -> HandlerM sub master (Maybe Text)
getPostParam name = lookup name <$> getPostParams
getFileParams :: HandlerM sub master [(Text,FileInfo)]
getFileParams = do
(_,files) <- _getAllFileOrPostParams
return files
getFileParam :: Text -> HandlerM sub master (Maybe FileInfo)
getFileParam name = lookup name <$> getFileParams
getParams :: HandlerM sub master [(Text, Text)]
getParams = (++) <$> getQueryParams <*> getPostParams
getParam :: Text -> HandlerM sub master (Maybe Text)
getParam name = do
getLookup <- getQueryParam name
case getLookup of
Nothing -> getPostParam name
Just _ -> return $ getLookup