{-# 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 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 "404 Not Found

Not Found

The requested document was not found on this server.

webcrank web server

" 500 -> return $ mconcat [ "500 Internal Server Error

Internal Server Error

The server encountered an error while processing this request:

"
      , reason
      , "

webcrank web server

" ] 501 -> getRequestMethod' <&> \m -> mconcat [ "501 Not Implemented

Not Implemented

The server does not support the " , LB.fromStrict m , " method.

webmachine web server

" ] 503 -> return "503 Service Unavailable

Service Unavailable

The server is currently unable to handle the request due to a temporary overloading or maintenance of the server.

webcrank web server

" _ -> return $ BB.toLazyByteString $ mconcat [ BB.fromByteString "" , BB.fromShow $ statusCode s , BB.fromByteString " " , BB.fromByteString $ statusMessage s , BB.fromByteString "

" , BB.fromByteString $ statusMessage s , BB.fromByteString "

" , BB.fromLazyByteString reason , BB.fromByteString "

webcrank web server

" ]