module Network.Wai.Middleware.Routes.Handler
( HandlerM()
, runHandlerM
, request
, routeAttrSet
, rootRouteAttrSet
, maybeRoute
, maybeRootRoute
, master
, header
, status
, raw
, json
, text
, html
, next
)
where
import Network.Wai (Request, Response, responseBuilder, pathInfo, queryString)
import Control.Monad (liftM)
import Control.Monad.State (StateT, get, put, modify, runStateT, MonadState, MonadIO, lift, MonadTrans)
import Control.Applicative (Applicative)
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 Data.Maybe (maybe)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as BL
import Network.HTTP.Types.Header (HeaderName())
import Network.HTTP.Types.Status (Status(), status200)
import Data.Aeson (ToJSON)
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
, respHeaders :: [(HeaderName, ByteString)]
, respStatus :: Status
, respBody :: BL.ByteString
, respResp :: Maybe ResponseHandler
, 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 [] status200 "" Nothing (envSub env) (envToMaster env))
case respResp state of
Nothing -> hh $ toResp state
Just resp -> resp hh
toResp :: HandlerState sub master -> Response
toResp hs = responseBuilder (respStatus hs) (respHeaders hs) (fromLazyByteString $ respBody hs)
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}
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
text :: Text -> HandlerM sub master ()
text t = do
header contentType typePlain
raw $ encodeUtf8 t
html :: BL.ByteString -> HandlerM sub master ()
html s = do
header contentType typeHtml
raw 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}