{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ExistentialQuantification #-}
module Webby.Types where
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 env a = WebbyM
{ unWebbyM :: ReaderT (WEnv env) (ResourceT IO) a
}
deriving (Functor, Applicative, Monad, MonadIO, MonadReader (WEnv env))
instance U.MonadUnliftIO (WebbyM appData) where
askUnliftIO = WebbyM $ ReaderT $
\(w :: WEnv appData) -> U.withUnliftIO $
\u -> return $
U.UnliftIO (U.unliftIO u . flip runReaderT w . unWebbyM)
runWebbyM :: WEnv w -> WebbyM w a -> IO a
runWebbyM env = runResourceT . flip runReaderT env . unWebbyM
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
}