module Network.Wai.Middleware.Routes.Handler
( HandlerM()
, runHandlerM
, request
, master
, header
, status
, raw
, json
, text
, html
, next
)
where
import Network.Wai (Request, Response, responseBuilder)
import Control.Monad (liftM)
import Control.Monad.State (StateT, get, put, modify, runStateT, MonadState, MonadIO, lift, MonadTrans)
import Network.Wai.Middleware.Routes.Routes (RequestData, Handler, waiReq, runNext)
import Network.Wai.Middleware.Routes.ContentTypes (contentType, typeHtml, typeJson, typePlain)
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.Text.Lazy (Text)
import qualified Data.Text.Lazy as T
import Data.Text.Lazy.Encoding (encodeUtf8)
import Blaze.ByteString.Builder (fromLazyByteString)
newtype HandlerMI master m a = H { extractH :: StateT (HandlerState master) m a }
deriving (Monad, MonadIO, Functor, MonadTrans, MonadState (HandlerState master))
type HandlerM master a = HandlerMI master IO a
data HandlerState master = HandlerState
{ getMaster :: master
, getRequestData :: RequestData
, respHeaders :: [(HeaderName, ByteString)]
, respStatus :: Status
, respBody :: BL.ByteString
, respResp :: Maybe Response
}
runHandlerM :: HandlerM master () -> Handler master
runHandlerM h m req = do
(_, state) <- runStateT (extractH h) (HandlerState m req [] status200 "" Nothing)
case respResp state of
Nothing -> return $ toResp state
Just resp -> return resp
toResp :: HandlerState master -> Response
toResp hs = responseBuilder (respStatus hs) (respHeaders hs) (fromLazyByteString $ respBody hs)
master :: HandlerM master master
master = liftM getMaster get
request :: HandlerM master Request
request = liftM (waiReq . getRequestData) get
header :: HeaderName -> ByteString -> HandlerM master ()
header h s = modify $ addHeader h s
where
addHeader :: HeaderName -> ByteString -> HandlerState master -> HandlerState master
addHeader h b s@(HandlerState {respHeaders=hs}) = s {respHeaders=(h,b):hs}
status :: Status -> HandlerM master ()
status s = modify $ setStatus s
where
setStatus :: Status -> HandlerState master -> HandlerState master
setStatus s st = st{respStatus=s}
raw :: BL.ByteString -> HandlerM master ()
raw s = modify $ setBody s
where
setBody :: BL.ByteString -> HandlerState master -> HandlerState master
setBody s st = st{respBody=s}
json :: ToJSON a => a -> HandlerM master ()
json a = do
header contentType typeJson
raw $ A.encode a
text :: Text -> HandlerM master ()
text t = do
header contentType typePlain
raw $ encodeUtf8 t
html :: BL.ByteString -> HandlerM master ()
html s = do
header contentType typeHtml
raw s
next :: HandlerM master ()
next = do
s <- get
resp <- lift $ runNext $ getRequestData s
modify $ setResp resp
where
setResp :: Response -> HandlerState master -> HandlerState master
setResp r st = st{respResp=Just r}