module Network.Wai.Middleware.Routes.Handler
( HandlerM()
, runHandlerM
, request
, reqHeader
, reqHeaders
, routeAttrSet
, rootRouteAttrSet
, maybeRoute
, maybeRootRoute
, showRouteMaster
, showRouteSub
, showRouteQueryMaster
, showRouteQuerySub
, readRouteMaster
, readRouteSub
, master
, sub
, rawBody
, jsonBody
, header
, status
, file
, filepart
, stream
, raw
, json
, plain
, html
, css
, javascript
, asContent
, next
, setCookie
, getCookie
, getCookies
)
where
import Network.Wai (Request, Response, responseFile, responseBuilder, responseStream, pathInfo, queryString, requestBody, StreamingBody, requestHeaders, FilePart)
#if MIN_VERSION_wai(3,0,1)
import Network.Wai (strictRequestBody)
#endif
import Network.Wai.Middleware.Routes.Routes (Env(..), RequestData, HandlerS, waiReq, currentRoute, runNext, ResponseHandler, showRoute, showRouteQuery, readRoute)
import Network.Wai.Middleware.Routes.Class (Route, RenderRoute, ParseRoute, RouteAttrs(..))
import Network.Wai.Middleware.Routes.ContentTypes (contentType, contentTypeFromFile, typeHtml, typeJson, typePlain, typeCss, typeJavascript)
import Control.Monad (liftM)
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)
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Blaze.ByteString.Builder (Builder, toByteString, fromLazyByteString)
import Network.HTTP.Types.Header (HeaderName(), RequestHeaders)
import Network.HTTP.Types.Status (Status(), status200)
import Data.Aeson (ToJSON, FromJSON, eitherDecode)
import qualified Data.Aeson as A
import Data.Set (Set)
import qualified Data.Set as S (empty, map)
import Data.Text.Lazy (Text)
import qualified Data.Text as TS (Text)
import qualified Data.Text.Lazy as T
import Data.Text.Lazy.Encoding (encodeUtf8)
import Data.Text.Encoding (decodeUtf8)
import Data.CaseInsensitive (CI, mk)
import Web.Cookie (Cookies, parseCookies, renderCookies, renderSetCookie, SetCookie(..))
import Data.Default.Class (def)
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 HandlerState sub master = HandlerState
{ getMaster :: master
, getRequestData :: RequestData sub
, reqBody :: Maybe BL.ByteString
, respHeaders :: [(HeaderName, ByteString)]
, respStatus :: Status
, respResp :: MkResponse
, respCookies :: [SetCookie]
, getSub :: sub
, toMasterRoute :: Route sub -> Route master
}
data MkResponse
= ResponseFile FilePath (Maybe FilePart)
| ResponseBuilder Builder
| ResponseStream StreamingBody
| ResponseNext
cookieHeaderName :: CI ByteString
cookieHeaderName = mk "Cookie"
cookieSetHeaderName :: CI ByteString
cookieSetHeaderName = mk "Set-Cookie"
runHandlerM :: HandlerM sub master () -> HandlerS sub master
runHandlerM h env req hh = do
(_, st) <- runStateT (extractH h) (HandlerState (envMaster env) req Nothing [] status200 ResponseNext [] (envSub env) (envToMaster env))
let cookieHeaders = map mkSetCookie (respCookies st)
let st' = st {respHeaders = cookieHeaders ++ (respHeaders st)}
mkResponse st' (respResp st')
where
mkSetCookie s = (cookieSetHeaderName, toByteString $ renderSetCookie s)
mkResponse st (ResponseFile path part) = hh $ responseFile (respStatus st) (respHeaders st) path part
mkResponse st (ResponseBuilder builder) = hh $ responseBuilder (respStatus st) (respHeaders st) builder
mkResponse st (ResponseStream streaming) = hh $ responseStream (respStatus st) (respHeaders st) streaming
mkResponse st ResponseNext = runNext (getRequestData st) hh
rawBody :: HandlerM master master BL.ByteString
rawBody = do
s <- get
case reqBody s of
Just consumedBody -> return consumedBody
Nothing -> do
req <- request
rbody <- liftIO $ readStrictRequestBody req
put s {reqBody = Just rbody}
return rbody
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 master master (Either String a)
jsonBody = liftM eitherDecode 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
reqHeader :: ByteString -> HandlerM sub master (Maybe ByteString)
reqHeader name = liftM (lookup $ mk name) reqHeaders
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 $ fmap (toMasterRoute s) $ currentRoute $ getRequestData s
showRouteMaster :: RenderRoute master => HandlerM sub master (Route master -> TS.Text)
showRouteMaster = return showRoute
showRouteSub :: RenderRoute master => HandlerM sub master (Route sub -> TS.Text)
showRouteSub = do
s <- get
return $ showRoute . toMasterRoute s
showRouteQueryMaster :: RenderRoute master => HandlerM sub master (Route master -> [(TS.Text,TS.Text)] -> TS.Text)
showRouteQueryMaster = return showRouteQuery
showRouteQuerySub :: RenderRoute master => HandlerM sub master (Route sub -> [(TS.Text,TS.Text)] -> TS.Text)
showRouteQuerySub = do
s <- get
return $ showRouteQuery . toMasterRoute s
readRouteMaster :: ParseRoute master => HandlerM sub master (TS.Text -> Maybe (Route master))
readRouteMaster = return readRoute
readRouteSub :: ParseRoute sub => HandlerM sub master (TS.Text -> Maybe (Route master))
readRouteSub = do
s <- get
return $ fmap (toMasterRoute s) . readRoute
routeAttrSet :: RouteAttrs sub => HandlerM sub master (Set Text)
routeAttrSet = liftM (S.map T.fromStrict . maybe S.empty routeAttrs . currentRoute . getRequestData) get
rootRouteAttrSet :: RouteAttrs master => HandlerM sub master (Set Text)
rootRouteAttrSet = do
s <- get
return $ S.map T.fromStrict $ 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 :: BL.ByteString -> HandlerM sub master ()
raw bs = modify addBody
where
addBody st = _setResp st $ ResponseBuilder (fromLazyByteString bs)
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
ResponseNext -> st{respResp=r}
_ -> st
json :: ToJSON a => a -> HandlerM sub master ()
json a = do
header contentType typeJson
raw $ A.encode a
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
setCookie :: SetCookie -> HandlerM sub master ()
setCookie s = modify setCookie
where
setCookie st = st {respCookies = s : respCookies st}
getCookies :: HandlerM sub master Cookies
getCookies = do
cookies <- reqHeader "Cookie"
return $ case cookies of
Nothing -> []
Just cookies' -> parseCookies cookies'
getCookie :: ByteString -> HandlerM sub master (Maybe ByteString)
getCookie name = do
cookies <- getCookies
return $ lookup name cookies