module Network.Wai.Middleware.Routes.Handler
( HandlerM()
, runHandlerM
, request
, routeAttrSet
, rootRouteAttrSet
, maybeRoute
, maybeRootRoute
, master
, header
, status
, file
, stream
, raw
, json
, plain
, html
, css
, javascript
, asContent
, next
, rawBody
, jsonBody
)
where
import Network.Wai (Request, Response, responseFile, responseBuilder, responseStream, pathInfo, queryString, requestBody, StreamingBody)
#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)
import Network.Wai.Middleware.Routes.Class (Route, RouteAttrs(..))
import Network.Wai.Middleware.Routes.ContentTypes (contentType, 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 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
, respResp :: Maybe ResponseHandler
, getSub :: sub
, toMasterRoute :: Route sub -> Route master
}
runHandlerM :: HandlerM sub master () -> HandlerS sub master
runHandlerM h env req hh = do
(_, st) <- runStateT (extractH h) (HandlerState (envMaster env) req Nothing [] status200 Nothing (envSub env) (envToMaster env))
case respResp st of
Nothing -> runNext (getRequestData st) hh
Just resp -> resp hh
rawBody :: HandlerM master master BL.ByteString
rawBody = do
s <- get
case reqBody s of
Just consumedBody -> return consumedBody
Nothing -> do
#if MIN_VERSION_wai(3,0,1)
req <- request
rbody <- liftIO $ strictRequestBody req
put s {reqBody = Just rbody}
return rbody
#else
chunker <- fmap requestBody request
consumedBody <- liftIO $ BL.fromChunks <$> unfoldWhileM (not . B.null) chunker
put s {reqBody = Just consumedBody}
return consumedBody
#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
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 f = modify addFile
where
addFile st = setResp st $ responseFile (respStatus st) (respHeaders st) f Nothing
stream :: StreamingBody -> HandlerM sub master ()
stream s = modify addStream
where
addStream st = setResp st $ responseStream (respStatus st) (respHeaders st) s
raw :: BL.ByteString -> HandlerM sub master ()
raw bs = modify addBody
where
addBody st = setResp st $ responseBuilder (respStatus st) (respHeaders st) (fromLazyByteString bs)
next :: HandlerM sub master ()
next = do
respHandler <- fmap (runNext . getRequestData) get
modify $ setRespHandler respHandler
setResp :: HandlerState sub master -> Response -> HandlerState sub master
setResp st r = setRespHandler ($ r) st
setRespHandler :: ResponseHandler -> HandlerState sub master -> HandlerState sub master
setRespHandler r st = case respResp st of
Just _ -> st
Nothing -> st{respResp=Just r}
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