module Network.Wai.Middleware.Routes.Handler
( HandlerM()
, runHandlerM
, request
, routeAttrSet
, rootRouteAttrSet
, maybeRoute
, maybeRootRoute
, master
, header
, status
, file
, raw
, json
, plain
, html
, next
, rawBody
, jsonBody
)
where
import Network.Wai (Request, Response, responseFile, responseBuilder, pathInfo, queryString, requestBody)
import Network.Wai.Middleware.Routes.Routes (Env(..), RequestData, HandlerS, waiReq, currentRoute, runNext, ResponseHandler)
import Network.Wai.Middleware.Routes.Class (Route, RouteAttrs(..))
import Network.Wai.Middleware.Routes.ContentTypes (contentType, typeHtml, typeJson, typePlain)
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 Network.HTTP.Types.Header (HeaderName())
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.Lazy as T
import Data.Text.Lazy.Encoding (encodeUtf8)
import Data.Text.Encoding (decodeUtf8)
import Blaze.ByteString.Builder (fromLazyByteString)
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
, respBody :: BL.ByteString
, respResp :: Maybe ResponseHandler
, respFile :: Maybe FilePath
, getSub :: sub
, toMasterRoute :: Route sub -> Route master
}
runHandlerM :: HandlerM sub master () -> HandlerS sub master
runHandlerM h env req hh = do
(_, state) <- runStateT (extractH h) (HandlerState (envMaster env) req Nothing [] status200 "" Nothing Nothing (envSub env) (envToMaster env))
case respResp state of
Nothing -> hh $ toResp state
Just resp -> resp hh
toResp :: HandlerState sub master -> Response
toResp hs = case respFile hs of
Nothing -> responseBuilder (respStatus hs) (respHeaders hs) (fromLazyByteString $ respBody hs)
Just f -> responseFile (respStatus hs) (respHeaders hs) f Nothing
rawBody :: HandlerM master master BL.ByteString
rawBody = do
s <- get
case reqBody s of
Nothing -> do
chunker <- fmap requestBody request
consumedBody <- liftIO $ BL.fromChunks <$> unfoldWhileM (not . B.null) chunker
put s {reqBody = Just consumedBody}
return consumedBody
Just consumedBody -> return consumedBody
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
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
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 s = modify $ setBody s
where
setBody :: FilePath -> HandlerState sub master -> HandlerState sub master
setBody s st = st{respFile=Just s}
raw :: BL.ByteString -> HandlerM sub master ()
raw s = modify $ setBody s
where
setBody :: BL.ByteString -> HandlerState sub master -> HandlerState sub master
setBody s st = st{respBody=s}
json :: ToJSON a => a -> HandlerM sub master ()
json a = do
header contentType typeJson
raw $ A.encode a
plain :: Text -> HandlerM sub master ()
plain t = do
header contentType typePlain
raw $ encodeUtf8 t
html :: Text -> HandlerM sub master ()
html s = do
header contentType typeHtml
raw $ encodeUtf8 s
next :: HandlerM sub master ()
next = do
s <- get
let resp = runNext (getRequestData s)
modify $ setResp resp
where
setResp :: ResponseHandler -> HandlerState sub master -> HandlerState sub master
setResp r st = st{respResp=Just r}