{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Webby.Types where
import qualified Control.Monad.IO.Unlift as Un
import qualified Data.Binary.Builder as Bu
import qualified Data.HashMap.Strict as H
import qualified Data.Text as T
import qualified UnliftIO as U
import qualified UnliftIO.Concurrent as Conc
import Prelude
data WyResp = WyResp
{ wrStatus :: Status,
wrHeaders :: ResponseHeaders,
wrRespData :: Either StreamingBody Bu.Builder,
wrResponded :: Bool
}
defaultWyResp :: WyResp
defaultWyResp = WyResp status200 [] (Right Bu.empty) False
data WebbyExceptionHandler env = forall e. Exception e => WebbyExceptionHandler (e -> (WebbyM env) ())
data WEnv env = WEnv
{ weResp :: Conc.MVar WyResp,
weCaptures :: Captures,
weRequest :: Request,
weAppEnv :: env,
weExceptionHandler :: Maybe (WebbyExceptionHandler env)
}
newtype WebbyM appEnv a = WebbyM
{ unWebbyM :: ReaderT appEnv (ReaderT (WEnv appEnv) (ResourceT IO)) a
}
deriving (Functor, Applicative, Monad, MonadIO, MonadReader appEnv, Un.MonadUnliftIO)
runWebbyM :: WEnv w -> WebbyM w a -> IO a
runWebbyM env = runResourceT . flip runReaderT env . flip runReaderT appEnv . unWebbyM
where
appEnv = weAppEnv env
data RoutePattern = RoutePattern Method [Text]
deriving (Eq, Show)
type Route env = (RoutePattern, WebbyM env ())
type Captures = H.HashMap Text Text
data FinishThrown = FinishThrown
deriving (Show)
instance U.Exception FinishThrown
data WebbyError
= WebbyJSONParseError Text
| WebbyParamParseError
{ wppeParamName :: Text,
wppeErrMsg :: Text
}
| WebbyMissingCapture Text
deriving (Show)
instance U.Exception WebbyError where
displayException (WebbyParamParseError pName msg) =
T.unpack $ sformat ("Param parse error: " % st % " " % st) pName msg
displayException (WebbyJSONParseError _) = "Invalid JSON body"
displayException (WebbyMissingCapture capName) =
T.unpack $ sformat (st % " missing") capName
data WebbyServerConfig env = WebbyServerConfig
{ wscRoutes :: [Route env],
wscExceptionHandler :: Maybe (WebbyExceptionHandler env)
}
defaultWebbyServerConfig :: WebbyServerConfig env
defaultWebbyServerConfig =
WebbyServerConfig
{ wscRoutes = [],
wscExceptionHandler = Nothing :: Maybe (WebbyExceptionHandler env)
}
setRoutes ::
[Route env] ->
WebbyServerConfig env ->
WebbyServerConfig env
setRoutes routes wsc =
wsc
{ wscRoutes = routes
}
setExceptionHandler ::
Exception e =>
(e -> WebbyM env ()) ->
WebbyServerConfig env ->
WebbyServerConfig env
setExceptionHandler exceptionHandler wsc =
WebbyServerConfig
{ wscRoutes = wscRoutes wsc,
wscExceptionHandler = Just $ WebbyExceptionHandler exceptionHandler
}