{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Webby.Types where

-- We directly depend on unliftio-core's Control.Monad.IO.Unlift, so we can
-- deriving MonadUnliftIO via GeneralizedNewtypeDeriving. If we depend on the
-- exported class from unliftio's UnliftIO module, we have problem building with
-- stack and LTS 16.0. FIXME: fix this unliftio has the right dep.
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

-- | A data type to represent parts of the response constructed in the
-- handler when servicing a request.
data WyResp = WyResp
  { WyResp -> Status
wrStatus :: Status,
    WyResp -> ResponseHeaders
wrHeaders :: ResponseHeaders,
    WyResp -> Either StreamingBody Builder
wrRespData :: Either StreamingBody Bu.Builder,
    WyResp -> Bool
wrResponded :: Bool
  }

defaultWyResp :: WyResp
defaultWyResp :: WyResp
defaultWyResp = Status
-> ResponseHeaders
-> Either StreamingBody Builder
-> Bool
-> WyResp
WyResp Status
status200 [] (Builder -> Either StreamingBody Builder
forall a b. b -> Either a b
Right Builder
Bu.empty) Bool
False

data WebbyExceptionHandler env = forall e. Exception e => WebbyExceptionHandler (e -> (WebbyM env) ())

-- | The reader environment used by the web framework. It is
-- parameterized by the application's environment data type.
data WEnv env = WEnv
  { WEnv env -> MVar WyResp
weResp :: Conc.MVar WyResp,
    WEnv env -> Captures
weCaptures :: Captures,
    WEnv env -> Request
weRequest :: Request,
    WEnv env -> env
weAppEnv :: env,
    WEnv env -> Maybe (WebbyExceptionHandler env)
weExceptionHandler :: Maybe (WebbyExceptionHandler env)
  }

-- | The main monad transformer stack used in the web-framework.
--
-- The type of a handler for a request is @WebbyM appEnv ()@. The @appEnv@
-- parameter is used by the web application to store an (read-only) environment.
-- For e.g. it can be used to store a database connection pool.
newtype WebbyM appEnv a = WebbyM
  { WebbyM appEnv a
-> ReaderT appEnv (ReaderT (WEnv appEnv) (ResourceT IO)) a
unWebbyM :: ReaderT appEnv (ReaderT (WEnv appEnv) (ResourceT IO)) a
  }
  deriving newtype (a -> WebbyM appEnv b -> WebbyM appEnv a
(a -> b) -> WebbyM appEnv a -> WebbyM appEnv b
(forall a b. (a -> b) -> WebbyM appEnv a -> WebbyM appEnv b)
-> (forall a b. a -> WebbyM appEnv b -> WebbyM appEnv a)
-> Functor (WebbyM appEnv)
forall a b. a -> WebbyM appEnv b -> WebbyM appEnv a
forall a b. (a -> b) -> WebbyM appEnv a -> WebbyM appEnv b
forall appEnv a b. a -> WebbyM appEnv b -> WebbyM appEnv a
forall appEnv a b. (a -> b) -> WebbyM appEnv a -> WebbyM appEnv b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> WebbyM appEnv b -> WebbyM appEnv a
$c<$ :: forall appEnv a b. a -> WebbyM appEnv b -> WebbyM appEnv a
fmap :: (a -> b) -> WebbyM appEnv a -> WebbyM appEnv b
$cfmap :: forall appEnv a b. (a -> b) -> WebbyM appEnv a -> WebbyM appEnv b
Functor, Functor (WebbyM appEnv)
a -> WebbyM appEnv a
Functor (WebbyM appEnv)
-> (forall a. a -> WebbyM appEnv a)
-> (forall a b.
    WebbyM appEnv (a -> b) -> WebbyM appEnv a -> WebbyM appEnv b)
-> (forall a b c.
    (a -> b -> c)
    -> WebbyM appEnv a -> WebbyM appEnv b -> WebbyM appEnv c)
-> (forall a b.
    WebbyM appEnv a -> WebbyM appEnv b -> WebbyM appEnv b)
-> (forall a b.
    WebbyM appEnv a -> WebbyM appEnv b -> WebbyM appEnv a)
-> Applicative (WebbyM appEnv)
WebbyM appEnv a -> WebbyM appEnv b -> WebbyM appEnv b
WebbyM appEnv a -> WebbyM appEnv b -> WebbyM appEnv a
WebbyM appEnv (a -> b) -> WebbyM appEnv a -> WebbyM appEnv b
(a -> b -> c)
-> WebbyM appEnv a -> WebbyM appEnv b -> WebbyM appEnv c
forall appEnv. Functor (WebbyM appEnv)
forall a. a -> WebbyM appEnv a
forall appEnv a. a -> WebbyM appEnv a
forall a b. WebbyM appEnv a -> WebbyM appEnv b -> WebbyM appEnv a
forall a b. WebbyM appEnv a -> WebbyM appEnv b -> WebbyM appEnv b
forall a b.
WebbyM appEnv (a -> b) -> WebbyM appEnv a -> WebbyM appEnv b
forall appEnv a b.
WebbyM appEnv a -> WebbyM appEnv b -> WebbyM appEnv a
forall appEnv a b.
WebbyM appEnv a -> WebbyM appEnv b -> WebbyM appEnv b
forall appEnv a b.
WebbyM appEnv (a -> b) -> WebbyM appEnv a -> WebbyM appEnv b
forall a b c.
(a -> b -> c)
-> WebbyM appEnv a -> WebbyM appEnv b -> WebbyM appEnv c
forall appEnv a b c.
(a -> b -> c)
-> WebbyM appEnv a -> WebbyM appEnv b -> WebbyM appEnv c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: WebbyM appEnv a -> WebbyM appEnv b -> WebbyM appEnv a
$c<* :: forall appEnv a b.
WebbyM appEnv a -> WebbyM appEnv b -> WebbyM appEnv a
*> :: WebbyM appEnv a -> WebbyM appEnv b -> WebbyM appEnv b
$c*> :: forall appEnv a b.
WebbyM appEnv a -> WebbyM appEnv b -> WebbyM appEnv b
liftA2 :: (a -> b -> c)
-> WebbyM appEnv a -> WebbyM appEnv b -> WebbyM appEnv c
$cliftA2 :: forall appEnv a b c.
(a -> b -> c)
-> WebbyM appEnv a -> WebbyM appEnv b -> WebbyM appEnv c
<*> :: WebbyM appEnv (a -> b) -> WebbyM appEnv a -> WebbyM appEnv b
$c<*> :: forall appEnv a b.
WebbyM appEnv (a -> b) -> WebbyM appEnv a -> WebbyM appEnv b
pure :: a -> WebbyM appEnv a
$cpure :: forall appEnv a. a -> WebbyM appEnv a
$cp1Applicative :: forall appEnv. Functor (WebbyM appEnv)
Applicative, Applicative (WebbyM appEnv)
a -> WebbyM appEnv a
Applicative (WebbyM appEnv)
-> (forall a b.
    WebbyM appEnv a -> (a -> WebbyM appEnv b) -> WebbyM appEnv b)
-> (forall a b.
    WebbyM appEnv a -> WebbyM appEnv b -> WebbyM appEnv b)
-> (forall a. a -> WebbyM appEnv a)
-> Monad (WebbyM appEnv)
WebbyM appEnv a -> (a -> WebbyM appEnv b) -> WebbyM appEnv b
WebbyM appEnv a -> WebbyM appEnv b -> WebbyM appEnv b
forall appEnv. Applicative (WebbyM appEnv)
forall a. a -> WebbyM appEnv a
forall appEnv a. a -> WebbyM appEnv a
forall a b. WebbyM appEnv a -> WebbyM appEnv b -> WebbyM appEnv b
forall a b.
WebbyM appEnv a -> (a -> WebbyM appEnv b) -> WebbyM appEnv b
forall appEnv a b.
WebbyM appEnv a -> WebbyM appEnv b -> WebbyM appEnv b
forall appEnv a b.
WebbyM appEnv a -> (a -> WebbyM appEnv b) -> WebbyM appEnv b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> WebbyM appEnv a
$creturn :: forall appEnv a. a -> WebbyM appEnv a
>> :: WebbyM appEnv a -> WebbyM appEnv b -> WebbyM appEnv b
$c>> :: forall appEnv a b.
WebbyM appEnv a -> WebbyM appEnv b -> WebbyM appEnv b
>>= :: WebbyM appEnv a -> (a -> WebbyM appEnv b) -> WebbyM appEnv b
$c>>= :: forall appEnv a b.
WebbyM appEnv a -> (a -> WebbyM appEnv b) -> WebbyM appEnv b
$cp1Monad :: forall appEnv. Applicative (WebbyM appEnv)
Monad, Monad (WebbyM appEnv)
Monad (WebbyM appEnv)
-> (forall a. IO a -> WebbyM appEnv a) -> MonadIO (WebbyM appEnv)
IO a -> WebbyM appEnv a
forall appEnv. Monad (WebbyM appEnv)
forall a. IO a -> WebbyM appEnv a
forall appEnv a. IO a -> WebbyM appEnv a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> WebbyM appEnv a
$cliftIO :: forall appEnv a. IO a -> WebbyM appEnv a
$cp1MonadIO :: forall appEnv. Monad (WebbyM appEnv)
MonadIO, MonadReader appEnv, MonadIO (WebbyM appEnv)
MonadIO (WebbyM appEnv)
-> (forall b.
    ((forall a. WebbyM appEnv a -> IO a) -> IO b) -> WebbyM appEnv b)
-> MonadUnliftIO (WebbyM appEnv)
((forall a. WebbyM appEnv a -> IO a) -> IO b) -> WebbyM appEnv b
forall appEnv. MonadIO (WebbyM appEnv)
forall b.
((forall a. WebbyM appEnv a -> IO a) -> IO b) -> WebbyM appEnv b
forall appEnv b.
((forall a. WebbyM appEnv a -> IO a) -> IO b) -> WebbyM appEnv b
forall (m :: * -> *).
MonadIO m
-> (forall b. ((forall a. m a -> IO a) -> IO b) -> m b)
-> MonadUnliftIO m
withRunInIO :: ((forall a. WebbyM appEnv a -> IO a) -> IO b) -> WebbyM appEnv b
$cwithRunInIO :: forall appEnv b.
((forall a. WebbyM appEnv a -> IO a) -> IO b) -> WebbyM appEnv b
$cp1MonadUnliftIO :: forall appEnv. MonadIO (WebbyM appEnv)
Un.MonadUnliftIO)

runWebbyM :: WEnv w -> WebbyM w a -> IO a
runWebbyM :: WEnv w -> WebbyM w a -> IO a
runWebbyM WEnv w
env = ResourceT IO a -> IO a
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (ResourceT IO a -> IO a)
-> (WebbyM w a -> ResourceT IO a) -> WebbyM w a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReaderT (WEnv w) (ResourceT IO) a -> WEnv w -> ResourceT IO a)
-> WEnv w -> ReaderT (WEnv w) (ResourceT IO) a -> ResourceT IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT (WEnv w) (ResourceT IO) a -> WEnv w -> ResourceT IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT WEnv w
env (ReaderT (WEnv w) (ResourceT IO) a -> ResourceT IO a)
-> (WebbyM w a -> ReaderT (WEnv w) (ResourceT IO) a)
-> WebbyM w a
-> ResourceT IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReaderT w (ReaderT (WEnv w) (ResourceT IO)) a
 -> w -> ReaderT (WEnv w) (ResourceT IO) a)
-> w
-> ReaderT w (ReaderT (WEnv w) (ResourceT IO)) a
-> ReaderT (WEnv w) (ResourceT IO) a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT w (ReaderT (WEnv w) (ResourceT IO)) a
-> w -> ReaderT (WEnv w) (ResourceT IO) a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT w
appEnv (ReaderT w (ReaderT (WEnv w) (ResourceT IO)) a
 -> ReaderT (WEnv w) (ResourceT IO) a)
-> (WebbyM w a -> ReaderT w (ReaderT (WEnv w) (ResourceT IO)) a)
-> WebbyM w a
-> ReaderT (WEnv w) (ResourceT IO) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WebbyM w a -> ReaderT w (ReaderT (WEnv w) (ResourceT IO)) a
forall appEnv a.
WebbyM appEnv a
-> ReaderT appEnv (ReaderT (WEnv appEnv) (ResourceT IO)) a
unWebbyM
  where
    appEnv :: w
appEnv = WEnv w -> w
forall env. WEnv env -> env
weAppEnv WEnv w
env

-- | A route pattern represents logic to match a request to a handler.
data RoutePattern = RoutePattern Method [Text]
  deriving stock (RoutePattern -> RoutePattern -> Bool
(RoutePattern -> RoutePattern -> Bool)
-> (RoutePattern -> RoutePattern -> Bool) -> Eq RoutePattern
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RoutePattern -> RoutePattern -> Bool
$c/= :: RoutePattern -> RoutePattern -> Bool
== :: RoutePattern -> RoutePattern -> Bool
$c== :: RoutePattern -> RoutePattern -> Bool
Eq, Int -> RoutePattern -> ShowS
[RoutePattern] -> ShowS
RoutePattern -> String
(Int -> RoutePattern -> ShowS)
-> (RoutePattern -> String)
-> ([RoutePattern] -> ShowS)
-> Show RoutePattern
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RoutePattern] -> ShowS
$cshowList :: [RoutePattern] -> ShowS
show :: RoutePattern -> String
$cshow :: RoutePattern -> String
showsPrec :: Int -> RoutePattern -> ShowS
$cshowsPrec :: Int -> RoutePattern -> ShowS
Show)

-- | A route is a pair of a route pattern and a handler.
type Route env = (RoutePattern, WebbyM env ())

-- | Captures are simply extracted path elements in a HashMap
type Captures = H.HashMap Text Text

-- | Internal type used to terminate handler processing by throwing and
-- catching an exception.
data FinishThrown = FinishThrown
  deriving stock (Int -> FinishThrown -> ShowS
[FinishThrown] -> ShowS
FinishThrown -> String
(Int -> FinishThrown -> ShowS)
-> (FinishThrown -> String)
-> ([FinishThrown] -> ShowS)
-> Show FinishThrown
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FinishThrown] -> ShowS
$cshowList :: [FinishThrown] -> ShowS
show :: FinishThrown -> String
$cshow :: FinishThrown -> String
showsPrec :: Int -> FinishThrown -> ShowS
$cshowsPrec :: Int -> FinishThrown -> ShowS
Show)

instance U.Exception FinishThrown

-- | Various kinds of errors thrown by this library - these can be
-- caught by handler code.
data WebbyError
  = WebbyJSONParseError Text
  | WebbyParamParseError
      { WebbyError -> Text
wppeParamName :: Text,
        WebbyError -> Text
wppeErrMsg :: Text
      }
  | WebbyMissingCapture Text
  deriving stock (Int -> WebbyError -> ShowS
[WebbyError] -> ShowS
WebbyError -> String
(Int -> WebbyError -> ShowS)
-> (WebbyError -> String)
-> ([WebbyError] -> ShowS)
-> Show WebbyError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WebbyError] -> ShowS
$cshowList :: [WebbyError] -> ShowS
show :: WebbyError -> String
$cshow :: WebbyError -> String
showsPrec :: Int -> WebbyError -> ShowS
$cshowsPrec :: Int -> WebbyError -> ShowS
Show)

instance U.Exception WebbyError where
  displayException :: WebbyError -> String
displayException (WebbyParamParseError Text
pName Text
msg) =
    Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Format Text (Text -> Text -> Text) -> Text -> Text -> Text
forall a. Format Text a -> a
sformat (Format (Text -> Text -> Text) (Text -> Text -> Text)
"Param parse error: " Format (Text -> Text -> Text) (Text -> Text -> Text)
-> Format Text (Text -> Text -> Text)
-> Format Text (Text -> Text -> Text)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format (Text -> Text) (Text -> Text -> Text)
forall r. Format r (Text -> r)
st Format (Text -> Text) (Text -> Text -> Text)
-> Format Text (Text -> Text) -> Format Text (Text -> Text -> Text)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format (Text -> Text) (Text -> Text)
" " Format (Text -> Text) (Text -> Text)
-> Format Text (Text -> Text) -> Format Text (Text -> Text)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Text (Text -> Text)
forall r. Format r (Text -> r)
st) Text
pName Text
msg
  displayException (WebbyJSONParseError Text
_) = String
"Invalid JSON body"
  displayException (WebbyMissingCapture Text
capName) =
    Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Format Text (Text -> Text) -> Text -> Text
forall a. Format Text a -> a
sformat (Format Text (Text -> Text)
forall r. Format r (Text -> r)
st Format Text (Text -> Text)
-> Format Text Text -> Format Text (Text -> Text)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Text Text
" missing") Text
capName

-- | Holds web server configuration like API routes, handlers and an optional
-- exception handler
data WebbyServerConfig env = WebbyServerConfig
  { WebbyServerConfig env -> [Route env]
wscRoutes :: [Route env],
    WebbyServerConfig env -> Maybe (WebbyExceptionHandler env)
wscExceptionHandler :: Maybe (WebbyExceptionHandler env)
  }

-- | Default @WebbyServerConfig@ typically used in conjunction with 'setRoutes'
-- and 'setExceptionHandler'
defaultWebbyServerConfig :: WebbyServerConfig env
defaultWebbyServerConfig :: WebbyServerConfig env
defaultWebbyServerConfig =
  WebbyServerConfig :: forall env.
[Route env]
-> Maybe (WebbyExceptionHandler env) -> WebbyServerConfig env
WebbyServerConfig
    { wscRoutes :: [Route env]
wscRoutes = [],
      wscExceptionHandler :: Maybe (WebbyExceptionHandler env)
wscExceptionHandler = forall a. Maybe a
forall env. Maybe (WebbyExceptionHandler env)
Nothing :: Maybe (WebbyExceptionHandler env)
    }

-- | Sets API routes and their handlers of a 'WebbyServerConfig'
setRoutes ::
  [Route env] ->
  WebbyServerConfig env ->
  WebbyServerConfig env
setRoutes :: [Route env] -> WebbyServerConfig env -> WebbyServerConfig env
setRoutes [Route env]
routes WebbyServerConfig env
wsc =
  WebbyServerConfig env
wsc
    { wscRoutes :: [Route env]
wscRoutes = [Route env]
routes
    }

-- | Sets the exception handler of a 'WebbyServerConfig'
setExceptionHandler ::
  Exception e =>
  (e -> WebbyM env ()) ->
  WebbyServerConfig env ->
  WebbyServerConfig env
setExceptionHandler :: (e -> WebbyM env ())
-> WebbyServerConfig env -> WebbyServerConfig env
setExceptionHandler e -> WebbyM env ()
exceptionHandler WebbyServerConfig env
wsc =
  WebbyServerConfig :: forall env.
[Route env]
-> Maybe (WebbyExceptionHandler env) -> WebbyServerConfig env
WebbyServerConfig
    { wscRoutes :: [Route env]
wscRoutes = WebbyServerConfig env -> [Route env]
forall env. WebbyServerConfig env -> [Route env]
wscRoutes WebbyServerConfig env
wsc,
      wscExceptionHandler :: Maybe (WebbyExceptionHandler env)
wscExceptionHandler = WebbyExceptionHandler env -> Maybe (WebbyExceptionHandler env)
forall a. a -> Maybe a
Just (WebbyExceptionHandler env -> Maybe (WebbyExceptionHandler env))
-> WebbyExceptionHandler env -> Maybe (WebbyExceptionHandler env)
forall a b. (a -> b) -> a -> b
$ (e -> WebbyM env ()) -> WebbyExceptionHandler env
forall env e.
Exception e =>
(e -> WebbyM env ()) -> WebbyExceptionHandler env
WebbyExceptionHandler e -> WebbyM env ()
exceptionHandler
    }