{-# 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 [] (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
  { forall env. WEnv env -> MVar WyResp
weResp :: Conc.MVar WyResp,
    forall env. WEnv env -> Captures
weCaptures :: Captures,
    forall env. WEnv env -> Request
weRequest :: Request,
    forall env. WEnv env -> env
weAppEnv :: env,
    forall 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
  { forall appEnv a.
WebbyM appEnv a
-> ReaderT appEnv (ReaderT (WEnv appEnv) (ResourceT IO)) a
unWebbyM :: ReaderT appEnv (ReaderT (WEnv appEnv) (ResourceT IO)) a
  }
  deriving newtype (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
<$ :: forall a b. a -> WebbyM appEnv b -> WebbyM appEnv a
$c<$ :: forall appEnv a b. a -> WebbyM appEnv b -> WebbyM appEnv a
fmap :: forall a b. (a -> b) -> WebbyM appEnv a -> WebbyM appEnv b
$cfmap :: forall appEnv a b. (a -> b) -> WebbyM appEnv a -> WebbyM appEnv b
Functor, 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
<* :: forall a b. WebbyM appEnv a -> WebbyM appEnv b -> WebbyM appEnv a
$c<* :: forall appEnv a b.
WebbyM appEnv a -> WebbyM appEnv b -> WebbyM appEnv a
*> :: forall a b. WebbyM appEnv a -> WebbyM appEnv b -> WebbyM appEnv b
$c*> :: forall appEnv a b.
WebbyM appEnv a -> WebbyM appEnv b -> WebbyM appEnv b
liftA2 :: forall a b c.
(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
<*> :: forall a b.
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 :: forall a. a -> WebbyM appEnv a
$cpure :: forall appEnv a. a -> WebbyM appEnv a
Applicative, 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 :: forall a. a -> WebbyM appEnv a
$creturn :: forall appEnv a. a -> WebbyM appEnv a
>> :: forall a b. WebbyM appEnv a -> WebbyM appEnv b -> WebbyM appEnv b
$c>> :: forall appEnv a b.
WebbyM appEnv a -> WebbyM appEnv b -> WebbyM appEnv b
>>= :: forall a 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
Monad, 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 :: forall a. IO a -> WebbyM appEnv a
$cliftIO :: forall appEnv a. IO a -> WebbyM appEnv a
MonadIO, MonadReader appEnv, 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 b.
((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
Un.MonadUnliftIO)

runWebbyM :: WEnv w -> WebbyM w a -> IO a
runWebbyM :: forall w a. WEnv w -> WebbyM w a -> IO a
runWebbyM WEnv w
env = forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT WEnv w
env forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT w
appEnv forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall appEnv a.
WebbyM appEnv a
-> ReaderT appEnv (ReaderT (WEnv appEnv) (ResourceT IO)) a
unWebbyM
  where
    appEnv :: w
appEnv = 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
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
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
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
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 forall a b. (a -> b) -> a -> b
$ forall a. Format Text a -> a
sformat (Format (Text -> Text -> Text) (Text -> Text -> Text)
"Param parse error: " forall r a r'. Format r a -> Format r' r -> Format r' a
% forall r. Format r (Text -> r)
st forall r a r'. Format r a -> Format r' r -> Format r' a
% Format (Text -> Text) (Text -> Text)
" " forall r a r'. Format r a -> Format r' r -> Format r' a
% 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 forall a b. (a -> b) -> a -> b
$ forall a. Format Text a -> a
sformat (forall r. Format r (Text -> r)
st 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
  { forall env. WebbyServerConfig env -> [Route env]
wscRoutes :: [Route env],
    forall env.
WebbyServerConfig env -> Maybe (WebbyExceptionHandler env)
wscExceptionHandler :: Maybe (WebbyExceptionHandler env)
  }

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

-- | Sets API routes and their handlers of a 'WebbyServerConfig'
setRoutes ::
  [Route env] ->
  WebbyServerConfig env ->
  WebbyServerConfig env
setRoutes :: forall env.
[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 :: forall e env.
Exception e =>
(e -> WebbyM env ())
-> WebbyServerConfig env -> WebbyServerConfig env
setExceptionHandler e -> WebbyM env ()
exceptionHandler WebbyServerConfig env
wsc =
  WebbyServerConfig
    { wscRoutes :: [Route env]
wscRoutes = forall env. WebbyServerConfig env -> [Route env]
wscRoutes WebbyServerConfig env
wsc,
      wscExceptionHandler :: Maybe (WebbyExceptionHandler env)
wscExceptionHandler = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall env e.
Exception e =>
(e -> WebbyM env ()) -> WebbyExceptionHandler env
WebbyExceptionHandler e -> WebbyM env ()
exceptionHandler
    }