module 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, responseRaw, responseFile, responseBuilder, responseStream, queryString, StreamingBody, requestHeaders, FilePart)
#if MIN_VERSION_wai(3,0,1)
import Network.Wai (strictRequestBody, vault)
#endif
import Routes.Routes (Env(..), RequestData, HandlerS, waiReq, currentRoute, runNext, showRoute, showRouteQuery, readRoute, readQueryString)
import Routes.Class (Route, RenderRoute, ParseRoute, RouteAttrs(..))
import Routes.ContentTypes (acceptContentType, contentType, contentTypeFromFile, typeHtml, typeJson, typePlain, typeCss, typeJavascript, typeAll)
import Control.Monad (liftM, when)
import Control.Monad.State (StateT, get, put, modify, runStateT, MonadState, MonadIO, liftIO, MonadTrans)
import Control.Arrow ((***))
import Control.Applicative (Applicative, (<$>), (<*>))
import Data.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
#if MIN_VERSION_aeson(0,10,0)
#else
import qualified Data.Aeson.Encode as AE
#endif
import Data.Set (Set)
import qualified Data.Set as S (empty)
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Data.CaseInsensitive (CI, mk)
import Web.Cookie (CookiesText, parseCookiesText, renderSetCookie, SetCookie(..))
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 (decodeUtf8 *** decodeUtf8) params
files' = map (decodeUtf8 *** decodeFileInfo) 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 = app . waiReq
runHandlerM :: HandlerM sub master () -> HandlerS sub master
runHandlerM h env req hh = do
(_, st) <- runStateT (extractH h) (defaultHandlerState env req)
let respData = fromMaybe defaultResponse (respResp st)
let headers' = map mkSetCookie (respCookies st) ++ respHeaders st
case mkResponse (respStatus st) headers' respData of
Nothing -> runNext (getRequestData st) hh
Just resp ->
case respRaw st of
Nothing -> hh resp
Just rawHandler -> hh $ responseRaw rawHandler resp
where
mkSetCookie s = (cookieSetHeaderName, toByteString $ renderSetCookie s)
mkResponse rstatus headers (ResponseFile path part) = Just $ responseFile rstatus headers path part
mkResponse rstatus headers (ResponseBuilder builder) = Just $ responseBuilder rstatus headers builder
mkResponse rstatus headers (ResponseStream streaming) = Just $ responseStream rstatus headers streaming
mkResponse _ _ ResponseNext = Nothing
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 b = modify addHeader
where
addHeader :: HandlerState sub master -> HandlerState sub master
addHeader st@(HandlerState {respHeaders=hs}) = st {respHeaders=(h,b):hs}
status :: Status -> HandlerM sub master ()
status s = modify setStatus
where
setStatus :: HandlerState sub master -> HandlerState sub master
setStatus 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,10,0)
_encode = A.fromEncoding . A.toEncoding
#elif 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 s = do
header contentType ctype
raw $ encodeUtf8 s
content :: [ByteString] -> Text -> HandlerM sub master ()
content [] _ = return ()
content ctypes s = whenContent ctypes (asContent (head ctypes) s)
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