{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} module Webcrank.Internal.HandleRequest where import qualified Blaze.ByteString.Builder as BB import qualified Blaze.ByteString.Builder.Char.Utf8 as BB import Control.Applicative import Control.Lens import Control.Monad.Catch import Control.Monad.Reader import Control.Monad.RWS import Control.Monad.Trans.Maybe import qualified Data.ByteString.Lazy as LB import qualified Data.ByteString.Lazy.UTF8 as LB import Data.Foldable (traverse_) import Network.HTTP.Media import Network.HTTP.Types import Prelude import Webcrank.Internal.DecisionCore import Webcrank.Internal.Halt import Webcrank.Internal.Headers import Webcrank.Internal.Types import Webcrank.Internal.ReqData import Webcrank.Internal.ResourceData -- | Process a request according to the webmachine state diagram. Intended for -- use by server API providers. @run@ is a function which can run process to -- completion. -- -- @'Webcrank.ServerAPI.WebcrankT'@ is provided as a starting point. For the type -- -- @ -- type WaiCrank = ReaderT (Request, HTTPDate) (WebcrankT IO) -- @ -- -- an appropriate @run@ function would be -- -- @ -- run :: Resource WaiCrank -> Request -> HTTPDate -> WaiCrank a -> IO (a, ReqData, LogData) -- run resource req date wa = runReaderT (runWebcrankT wa (ResourceData api resource) newReqData) (req, date) -- @ handleRequest :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s, MonadCatch m, Functor n) => (forall a. m a -> n (a, ReqData, LogData)) -- ^ run -> n (Status, HeadersMap, Maybe Body) handleRequest run = run handler <&> finish where handler = (decisionCore <* callr'' finishRequest) `catch` handleError decisionCore = runHaltT (runFlowChart b13) >>= \case Left (Error s rs) -> s <$ prepError s rs Left (Halt s) -> s <$ prepResponse s Right s -> s <$ prepResponse s -- TODO log decision states finish (s, d, _) = (s, _reqDataRespHeaders d, _reqDataRespBody d) prepResponse :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s) => Status -> m () prepResponse s = case statusCode s of c | c >= 400 && c < 600 -> prepError s (LB.fromStrict $ statusMessage s) 304 -> do removeResponseHeader hContentType reqDataRespBody .= Nothing let header h rm = traverse_ (putResponseHeader h . renderHeader) =<< callr'' (runMaybeT . rm) header hETag generateETag header hExpires expires _ -> return () -- TODO make it customizable prepError :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s) => Status -> LB.ByteString -> m () prepError s r = assign reqDataRespBody . Just =<< encodeBody' =<< renderError s r handleError :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s) => SomeException -> m Status handleError = (internalServerError500 <$) . prepError internalServerError500 . LB.fromString . show renderError :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s) => Status -> LB.ByteString -> m Body renderError s reason = maybe (render s reason) return =<< use reqDataRespBody where render :: (Functor m, HasReqData s, HasResourceData r m, MonadReader r m, MonadState s m) => Status -> LB.ByteString -> m LB.ByteString render s reason = putResponseHeader hContentType "text/html" >> (errorBody s reason) errorBody :: (Functor m, HasResourceData r m, MonadReader r m) => Status -> LB.ByteString -> m LB.ByteString errorBody s reason = case statusCode s of 404 -> return "
" , reason , "