{- |
 Server implementation of WebGear handlers
-}
module WebGear.Server.Handler (
  ServerHandler (..),
  RoutePath (..),
  runServerHandler,
  toApplication,
  transform,
) where

import Control.Arrow (
  Arrow (..),
  ArrowChoice (..),
  ArrowPlus (..),
  ArrowZero (..),
  Kleisli (..),
 )
import Control.Arrow.Operations (ArrowError (..))
import qualified Control.Category as Cat
import Control.Monad.Except (
  ExceptT (..),
  MonadError (..),
  mapExceptT,
  runExceptT,
 )
import Control.Monad.State.Strict (
  MonadState (..),
  StateT (..),
  evalStateT,
  mapStateT,
 )
import Control.Monad.Trans (lift)
import Data.ByteString (ByteString)
import Data.Either (fromRight)
import Data.String (fromString)
import Data.Version (showVersion)
import qualified Network.HTTP.Types as HTTP
import qualified Network.Wai as Wai
import Paths_webgear_server (version)
import WebGear.Core.Handler (
  Description,
  Handler (..),
  RouteMismatch (..),
  RoutePath (..),
  Summary,
 )
import WebGear.Core.Request (Request (..))
import WebGear.Core.Response (Response (..), ResponseBody (..), toWaiResponse)
import WebGear.Core.Trait (With, wzero)

{- | An arrow implementing a WebGear server.

 A good first approximation is to consider ServerHandler to be
 equivalent to the function arrow @a -> m b@ where @m@ is a monad. It
 also supports routing and possibly failing the computation when the
 route does not match.
-}
newtype ServerHandler m a b = ServerHandler
  { forall (m :: * -> *) a b.
ServerHandler m a b
-> a -> StateT RoutePath (ExceptT RouteMismatch m) b
unServerHandler :: a -> StateT RoutePath (ExceptT RouteMismatch m) b
  }
  deriving
    ( forall a. ServerHandler m a a
forall b c a.
ServerHandler m b c -> ServerHandler m a b -> ServerHandler m a c
forall {k} (cat :: k -> k -> *).
(forall (a :: k). cat a a)
-> (forall (b :: k) (c :: k) (a :: k).
    cat b c -> cat a b -> cat a c)
-> Category cat
forall (m :: * -> *) a. Monad m => ServerHandler m a a
forall (m :: * -> *) b c a.
Monad m =>
ServerHandler m b c -> ServerHandler m a b -> ServerHandler m a c
. :: forall b c a.
ServerHandler m b c -> ServerHandler m a b -> ServerHandler m a c
$c. :: forall (m :: * -> *) b c a.
Monad m =>
ServerHandler m b c -> ServerHandler m a b -> ServerHandler m a c
id :: forall a. ServerHandler m a a
$cid :: forall (m :: * -> *) a. Monad m => ServerHandler m a a
Cat.Category
    , forall b c. (b -> c) -> ServerHandler m b c
forall b c d. ServerHandler m b c -> ServerHandler m (b, d) (c, d)
forall b c d. ServerHandler m b c -> ServerHandler m (d, b) (d, c)
forall b c c'.
ServerHandler m b c
-> ServerHandler m b c' -> ServerHandler m b (c, c')
forall b c b' c'.
ServerHandler m b c
-> ServerHandler m b' c' -> ServerHandler m (b, b') (c, c')
forall (m :: * -> *). Monad m => Category (ServerHandler m)
forall (m :: * -> *) b c.
Monad m =>
(b -> c) -> ServerHandler m b c
forall (m :: * -> *) b c d.
Monad m =>
ServerHandler m b c -> ServerHandler m (b, d) (c, d)
forall (m :: * -> *) b c d.
Monad m =>
ServerHandler m b c -> ServerHandler m (d, b) (d, c)
forall (m :: * -> *) b c c'.
Monad m =>
ServerHandler m b c
-> ServerHandler m b c' -> ServerHandler m b (c, c')
forall (m :: * -> *) b c b' c'.
Monad m =>
ServerHandler m b c
-> ServerHandler m b' c' -> ServerHandler m (b, b') (c, c')
forall (a :: * -> * -> *).
Category a
-> (forall b c. (b -> c) -> a b c)
-> (forall b c d. a b c -> a (b, d) (c, d))
-> (forall b c d. a b c -> a (d, b) (d, c))
-> (forall b c b' c'. a b c -> a b' c' -> a (b, b') (c, c'))
-> (forall b c c'. a b c -> a b c' -> a b (c, c'))
-> Arrow a
&&& :: forall b c c'.
ServerHandler m b c
-> ServerHandler m b c' -> ServerHandler m b (c, c')
$c&&& :: forall (m :: * -> *) b c c'.
Monad m =>
ServerHandler m b c
-> ServerHandler m b c' -> ServerHandler m b (c, c')
*** :: forall b c b' c'.
ServerHandler m b c
-> ServerHandler m b' c' -> ServerHandler m (b, b') (c, c')
$c*** :: forall (m :: * -> *) b c b' c'.
Monad m =>
ServerHandler m b c
-> ServerHandler m b' c' -> ServerHandler m (b, b') (c, c')
second :: forall b c d. ServerHandler m b c -> ServerHandler m (d, b) (d, c)
$csecond :: forall (m :: * -> *) b c d.
Monad m =>
ServerHandler m b c -> ServerHandler m (d, b) (d, c)
first :: forall b c d. ServerHandler m b c -> ServerHandler m (b, d) (c, d)
$cfirst :: forall (m :: * -> *) b c d.
Monad m =>
ServerHandler m b c -> ServerHandler m (b, d) (c, d)
arr :: forall b c. (b -> c) -> ServerHandler m b c
$carr :: forall (m :: * -> *) b c.
Monad m =>
(b -> c) -> ServerHandler m b c
Arrow
    , forall b c. ServerHandler m b c
forall (m :: * -> *). Monad m => Arrow (ServerHandler m)
forall (m :: * -> *) b c. Monad m => ServerHandler m b c
forall (a :: * -> * -> *).
Arrow a -> (forall b c. a b c) -> ArrowZero a
zeroArrow :: forall b c. ServerHandler m b c
$czeroArrow :: forall (m :: * -> *) b c. Monad m => ServerHandler m b c
ArrowZero
    , forall b c.
ServerHandler m b c -> ServerHandler m b c -> ServerHandler m b c
forall (m :: * -> *). Monad m => ArrowZero (ServerHandler m)
forall (m :: * -> *) b c.
Monad m =>
ServerHandler m b c -> ServerHandler m b c -> ServerHandler m b c
forall (a :: * -> * -> *).
ArrowZero a -> (forall b c. a b c -> a b c -> a b c) -> ArrowPlus a
<+> :: forall b c.
ServerHandler m b c -> ServerHandler m b c -> ServerHandler m b c
$c<+> :: forall (m :: * -> *) b c.
Monad m =>
ServerHandler m b c -> ServerHandler m b c -> ServerHandler m b c
ArrowPlus
    , forall b c d.
ServerHandler m b c -> ServerHandler m (Either b d) (Either c d)
forall b c d.
ServerHandler m b c -> ServerHandler m (Either d b) (Either d c)
forall b d c.
ServerHandler m b d
-> ServerHandler m c d -> ServerHandler m (Either b c) d
forall b c b' c'.
ServerHandler m b c
-> ServerHandler m b' c'
-> ServerHandler m (Either b b') (Either c c')
forall (m :: * -> *). Monad m => Arrow (ServerHandler m)
forall (m :: * -> *) b c d.
Monad m =>
ServerHandler m b c -> ServerHandler m (Either b d) (Either c d)
forall (m :: * -> *) b c d.
Monad m =>
ServerHandler m b c -> ServerHandler m (Either d b) (Either d c)
forall (m :: * -> *) b d c.
Monad m =>
ServerHandler m b d
-> ServerHandler m c d -> ServerHandler m (Either b c) d
forall (m :: * -> *) b c b' c'.
Monad m =>
ServerHandler m b c
-> ServerHandler m b' c'
-> ServerHandler m (Either b b') (Either c c')
forall (a :: * -> * -> *).
Arrow a
-> (forall b c d. a b c -> a (Either b d) (Either c d))
-> (forall b c d. a b c -> a (Either d b) (Either d c))
-> (forall b c b' c'.
    a b c -> a b' c' -> a (Either b b') (Either c c'))
-> (forall b d c. a b d -> a c d -> a (Either b c) d)
-> ArrowChoice a
||| :: forall b d c.
ServerHandler m b d
-> ServerHandler m c d -> ServerHandler m (Either b c) d
$c||| :: forall (m :: * -> *) b d c.
Monad m =>
ServerHandler m b d
-> ServerHandler m c d -> ServerHandler m (Either b c) d
+++ :: forall b c b' c'.
ServerHandler m b c
-> ServerHandler m b' c'
-> ServerHandler m (Either b b') (Either c c')
$c+++ :: forall (m :: * -> *) b c b' c'.
Monad m =>
ServerHandler m b c
-> ServerHandler m b' c'
-> ServerHandler m (Either b b') (Either c c')
right :: forall b c d.
ServerHandler m b c -> ServerHandler m (Either d b) (Either d c)
$cright :: forall (m :: * -> *) b c d.
Monad m =>
ServerHandler m b c -> ServerHandler m (Either d b) (Either d c)
left :: forall b c d.
ServerHandler m b c -> ServerHandler m (Either b d) (Either c d)
$cleft :: forall (m :: * -> *) b c d.
Monad m =>
ServerHandler m b c -> ServerHandler m (Either b d) (Either c d)
ArrowChoice
    )
    via Kleisli (StateT RoutePath (ExceptT RouteMismatch m))

instance (Monad m) => ArrowError RouteMismatch (ServerHandler m) where
  {-# INLINE raise #-}
  raise :: ServerHandler m RouteMismatch b
  raise :: forall b. ServerHandler m RouteMismatch b
raise = forall (m :: * -> *) a b.
(a -> StateT RoutePath (ExceptT RouteMismatch m) b)
-> ServerHandler m a b
ServerHandler forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError

  {-# INLINE handle #-}
  handle ::
    ServerHandler m a b ->
    ServerHandler m (a, RouteMismatch) b ->
    ServerHandler m a b
  (ServerHandler a -> StateT RoutePath (ExceptT RouteMismatch m) b
action) handle :: forall e b.
ServerHandler m e b
-> ServerHandler m (e, RouteMismatch) b -> ServerHandler m e b
`handle` (ServerHandler (a, RouteMismatch) -> StateT RoutePath (ExceptT RouteMismatch m) b
errHandler) =
    forall (m :: * -> *) a b.
(a -> StateT RoutePath (ExceptT RouteMismatch m) b)
-> ServerHandler m a b
ServerHandler forall a b. (a -> b) -> a -> b
$ \a
a ->
      a -> StateT RoutePath (ExceptT RouteMismatch m) b
action a
a forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \RouteMismatch
e -> (a, RouteMismatch) -> StateT RoutePath (ExceptT RouteMismatch m) b
errHandler (a
a, RouteMismatch
e)

  {-# INLINE tryInUnless #-}
  tryInUnless ::
    ServerHandler m a b ->
    ServerHandler m (a, b) c ->
    ServerHandler m (a, RouteMismatch) c ->
    ServerHandler m a c
  tryInUnless :: forall e b c.
ServerHandler m e b
-> ServerHandler m (e, b) c
-> ServerHandler m (e, RouteMismatch) c
-> ServerHandler m e c
tryInUnless (ServerHandler a -> StateT RoutePath (ExceptT RouteMismatch m) b
action) (ServerHandler (a, b) -> StateT RoutePath (ExceptT RouteMismatch m) c
resHandler) (ServerHandler (a, RouteMismatch) -> StateT RoutePath (ExceptT RouteMismatch m) c
errHandler) =
    forall (m :: * -> *) a b.
(a -> StateT RoutePath (ExceptT RouteMismatch m) b)
-> ServerHandler m a b
ServerHandler forall a b. (a -> b) -> a -> b
$ \a
a ->
      a -> StateT RoutePath (ExceptT RouteMismatch m) c
f a
a forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \RouteMismatch
e -> (a, RouteMismatch) -> StateT RoutePath (ExceptT RouteMismatch m) c
errHandler (a
a, RouteMismatch
e)
    where
      f :: a -> StateT RoutePath (ExceptT RouteMismatch m) c
f a
a = do
        b
b <- a -> StateT RoutePath (ExceptT RouteMismatch m) b
action a
a
        (a, b) -> StateT RoutePath (ExceptT RouteMismatch m) c
resHandler (a
a, b
b)

instance (Monad m) => Handler (ServerHandler m) m where
  {-# INLINE arrM #-}
  arrM :: (a -> m b) -> ServerHandler m a b
  arrM :: forall a b. (a -> m b) -> ServerHandler m a b
arrM a -> m b
f = forall (m :: * -> *) a b.
(a -> StateT RoutePath (ExceptT RouteMismatch m) b)
-> ServerHandler m a b
ServerHandler forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m b
f

  {-# INLINE consumeRoute #-}
  consumeRoute :: ServerHandler m RoutePath a -> ServerHandler m () a
  consumeRoute :: forall a. ServerHandler m RoutePath a -> ServerHandler m () a
consumeRoute (ServerHandler RoutePath -> StateT RoutePath (ExceptT RouteMismatch m) a
h) =
    forall (m :: * -> *) a b.
(a -> StateT RoutePath (ExceptT RouteMismatch m) b)
-> ServerHandler m a b
ServerHandler
      forall a b. (a -> b) -> a -> b
$ \() -> do
        a
a <- forall s (m :: * -> *). MonadState s m => m s
get forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RoutePath -> StateT RoutePath (ExceptT RouteMismatch m) a
h
        forall s (m :: * -> *). MonadState s m => s -> m ()
put ([Text] -> RoutePath
RoutePath [])
        forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

  {-# INLINE setDescription #-}
  setDescription :: Description -> ServerHandler m a a
  setDescription :: forall a. Description -> ServerHandler m a a
setDescription Description
_ = forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
Cat.id

  {-# INLINE setSummary #-}
  setSummary :: Summary -> ServerHandler m a a
  setSummary :: forall a. Summary -> ServerHandler m a a
setSummary Summary
_ = forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
Cat.id

-- | Run a ServerHandler to produce a result or a route mismatch error.
runServerHandler ::
  (Monad m) =>
  -- | The handler to run
  ServerHandler m a b ->
  -- | Path used for routing
  RoutePath ->
  -- | Input value to the arrow
  a ->
  -- | The result of the arrow
  m (Either RouteMismatch b)
runServerHandler :: forall (m :: * -> *) a b.
Monad m =>
ServerHandler m a b -> RoutePath -> a -> m (Either RouteMismatch b)
runServerHandler (ServerHandler a -> StateT RoutePath (ExceptT RouteMismatch m) b
h) RoutePath
path a
a =
  forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (a -> StateT RoutePath (ExceptT RouteMismatch m) b
h a
a) RoutePath
path
{-# INLINE runServerHandler #-}

-- | Convert a ServerHandler to a WAI application
toApplication :: ServerHandler IO (Request `With` '[]) Response -> Wai.Application
toApplication :: ServerHandler IO (With Request '[]) Response -> Application
toApplication ServerHandler IO (With Request '[]) Response
h Request
rqt Response -> IO ResponseReceived
cont =
  forall (m :: * -> *) a b.
Monad m =>
ServerHandler m a b -> RoutePath -> a -> m (Either RouteMismatch b)
runServerHandler ServerHandler IO (With Request '[]) Response
h RoutePath
path With Request '[]
request
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Response -> IO ResponseReceived
cont
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> Response
toWaiResponse
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> Response
addServerHeader
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either RouteMismatch Response -> Response
mkWebGearResponse
  where
    request :: Request `With` '[]
    request :: With Request '[]
request = forall a. a -> With a '[]
wzero forall a b. (a -> b) -> a -> b
$ Request -> Request
Request Request
rqt

    path :: RoutePath
    path :: RoutePath
path = [Text] -> RoutePath
RoutePath forall a b. (a -> b) -> a -> b
$ Request -> [Text]
Wai.pathInfo Request
rqt

    mkWebGearResponse :: Either RouteMismatch Response -> Response
    mkWebGearResponse :: Either RouteMismatch Response -> Response
mkWebGearResponse = forall b a. b -> Either a b -> b
fromRight forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ResponseBody -> Response
Response Status
HTTP.notFound404 [] forall a b. (a -> b) -> a -> b
$ Builder -> ResponseBody
ResponseBodyBuilder forall a. Monoid a => a
mempty

    addServerHeader :: Response -> Response
    addServerHeader :: Response -> Response
addServerHeader resp :: Response
resp@Response{ResponseHeaders
Status
ResponseBody
responseStatus :: Response -> Status
responseHeaders :: Response -> ResponseHeaders
responseBody :: Response -> ResponseBody
responseBody :: ResponseBody
responseHeaders :: ResponseHeaders
responseStatus :: Status
..} = Response
resp{responseHeaders :: ResponseHeaders
responseHeaders = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Header -> ResponseHeaders -> ResponseHeaders
insertServerHeader [] ResponseHeaders
responseHeaders}

    insertServerHeader :: HTTP.Header -> HTTP.ResponseHeaders -> HTTP.ResponseHeaders
    insertServerHeader :: Header -> ResponseHeaders -> ResponseHeaders
insertServerHeader hdr :: Header
hdr@(HeaderName
name, ByteString
_) ResponseHeaders
hdrs
      | HeaderName
name forall a. Eq a => a -> a -> Bool
== HeaderName
HTTP.hServer = (HeaderName
HTTP.hServer, ByteString
webGearServerHeader) forall a. a -> [a] -> [a]
: ResponseHeaders
hdrs
      | Bool
otherwise = Header
hdr forall a. a -> [a] -> [a]
: ResponseHeaders
hdrs

    webGearServerHeader :: ByteString
    webGearServerHeader :: ByteString
webGearServerHeader = forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ [Char]
"WebGear/" forall a. [a] -> [a] -> [a]
++ Version -> [Char]
showVersion Version
version
{-# INLINE toApplication #-}

{- | Transform a `ServerHandler` running in one monad to another monad.

 This is useful in cases where the server is running in a custom
 monad but you would like to convert it to a WAI application using
 `toApplication`.

 Example usage with a ReaderT monad stack:

@
 `toApplication` (transform f server)
   where
     server :: `ServerHandler` (ReaderT r IO) (`Request` \``With`\` '[]) `Response`
     server = ....

     f :: ReaderT r IO a -> IO a
     f action = runReaderT action r
@
-}
transform ::
  (forall x. m x -> n x) ->
  ServerHandler m a b ->
  ServerHandler n a b
transform :: forall (m :: * -> *) (n :: * -> *) a b.
(forall x. m x -> n x)
-> ServerHandler m a b -> ServerHandler n a b
transform forall x. m x -> n x
f (ServerHandler a -> StateT RoutePath (ExceptT RouteMismatch m) b
g) =
  forall (m :: * -> *) a b.
(a -> StateT RoutePath (ExceptT RouteMismatch m) b)
-> ServerHandler m a b
ServerHandler forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a s (n :: * -> *) b.
(m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b
mapStateT (forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT forall x. m x -> n x
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> StateT RoutePath (ExceptT RouteMismatch m) b
g
{-# INLINE transform #-}