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

import Control.Arrow (Arrow (..), ArrowChoice (..), ArrowPlus (..), ArrowZero (..))
import Control.Arrow.Operations (ArrowError (..))
import qualified Control.Category as Cat
import Data.ByteString (ByteString)
import Data.Either (fromRight)
import qualified Data.HashMap.Strict as HM
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 (..), toWaiResponse)
import WebGear.Core.Trait (Linked, linkzero)

{- | An arrow implementing a WebGear server.

 It can be thought of 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 {ServerHandler m a b
-> (a, RoutePath) -> m (Either RouteMismatch b, RoutePath)
unServerHandler :: (a, RoutePath) -> m (Either RouteMismatch b, RoutePath)}

instance Monad m => Cat.Category (ServerHandler m) where
  {-# INLINEABLE id #-}
  id :: ServerHandler m a a
id = ((a, RoutePath) -> m (Either RouteMismatch a, RoutePath))
-> ServerHandler m a a
forall (m :: * -> *) a b.
((a, RoutePath) -> m (Either RouteMismatch b, RoutePath))
-> ServerHandler m a b
ServerHandler (((a, RoutePath) -> m (Either RouteMismatch a, RoutePath))
 -> ServerHandler m a a)
-> ((a, RoutePath) -> m (Either RouteMismatch a, RoutePath))
-> ServerHandler m a a
forall a b. (a -> b) -> a -> b
$ \(a
a, RoutePath
s) -> (Either RouteMismatch a, RoutePath)
-> m (Either RouteMismatch a, RoutePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Either RouteMismatch a
forall a b. b -> Either a b
Right a
a, RoutePath
s)

  {-# INLINEABLE (.) #-}
  ServerHandler (b, RoutePath) -> m (Either RouteMismatch c, RoutePath)
f . :: ServerHandler m b c -> ServerHandler m a b -> ServerHandler m a c
. ServerHandler (a, RoutePath) -> m (Either RouteMismatch b, RoutePath)
g = ((a, RoutePath) -> m (Either RouteMismatch c, RoutePath))
-> ServerHandler m a c
forall (m :: * -> *) a b.
((a, RoutePath) -> m (Either RouteMismatch b, RoutePath))
-> ServerHandler m a b
ServerHandler (((a, RoutePath) -> m (Either RouteMismatch c, RoutePath))
 -> ServerHandler m a c)
-> ((a, RoutePath) -> m (Either RouteMismatch c, RoutePath))
-> ServerHandler m a c
forall a b. (a -> b) -> a -> b
$ \(a
a, RoutePath
s) ->
    (a, RoutePath) -> m (Either RouteMismatch b, RoutePath)
g (a
a, RoutePath
s) m (Either RouteMismatch b, RoutePath)
-> ((Either RouteMismatch b, RoutePath)
    -> m (Either RouteMismatch c, RoutePath))
-> m (Either RouteMismatch c, RoutePath)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      (Left RouteMismatch
e, RoutePath
s') -> (Either RouteMismatch c, RoutePath)
-> m (Either RouteMismatch c, RoutePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RouteMismatch -> Either RouteMismatch c
forall a b. a -> Either a b
Left RouteMismatch
e, RoutePath
s')
      (Right b
b, RoutePath
s') -> (b, RoutePath) -> m (Either RouteMismatch c, RoutePath)
f (b
b, RoutePath
s')

instance Monad m => Arrow (ServerHandler m) where
  arr :: (b -> c) -> ServerHandler m b c
arr b -> c
f = ((b, RoutePath) -> m (Either RouteMismatch c, RoutePath))
-> ServerHandler m b c
forall (m :: * -> *) a b.
((a, RoutePath) -> m (Either RouteMismatch b, RoutePath))
-> ServerHandler m a b
ServerHandler (\(b
a, RoutePath
s) -> (Either RouteMismatch c, RoutePath)
-> m (Either RouteMismatch c, RoutePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (c -> Either RouteMismatch c
forall a b. b -> Either a b
Right (b -> c
f b
a), RoutePath
s))

  {-# INLINEABLE first #-}
  first :: ServerHandler m b c -> ServerHandler m (b, d) (c, d)
first (ServerHandler (b, RoutePath) -> m (Either RouteMismatch c, RoutePath)
f) = (((b, d), RoutePath) -> m (Either RouteMismatch (c, d), RoutePath))
-> ServerHandler m (b, d) (c, d)
forall (m :: * -> *) a b.
((a, RoutePath) -> m (Either RouteMismatch b, RoutePath))
-> ServerHandler m a b
ServerHandler ((((b, d), RoutePath)
  -> m (Either RouteMismatch (c, d), RoutePath))
 -> ServerHandler m (b, d) (c, d))
-> (((b, d), RoutePath)
    -> m (Either RouteMismatch (c, d), RoutePath))
-> ServerHandler m (b, d) (c, d)
forall a b. (a -> b) -> a -> b
$ \((b
a, d
c), RoutePath
s) ->
    (b, RoutePath) -> m (Either RouteMismatch c, RoutePath)
f (b
a, RoutePath
s) m (Either RouteMismatch c, RoutePath)
-> ((Either RouteMismatch c, RoutePath)
    -> m (Either RouteMismatch (c, d), RoutePath))
-> m (Either RouteMismatch (c, d), RoutePath)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      (Left RouteMismatch
e, RoutePath
s') -> (Either RouteMismatch (c, d), RoutePath)
-> m (Either RouteMismatch (c, d), RoutePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RouteMismatch -> Either RouteMismatch (c, d)
forall a b. a -> Either a b
Left RouteMismatch
e, RoutePath
s')
      (Right c
b, RoutePath
s') -> (Either RouteMismatch (c, d), RoutePath)
-> m (Either RouteMismatch (c, d), RoutePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((c, d) -> Either RouteMismatch (c, d)
forall a b. b -> Either a b
Right (c
b, d
c), RoutePath
s')

  {-# INLINEABLE second #-}
  second :: ServerHandler m b c -> ServerHandler m (d, b) (d, c)
second (ServerHandler (b, RoutePath) -> m (Either RouteMismatch c, RoutePath)
f) = (((d, b), RoutePath) -> m (Either RouteMismatch (d, c), RoutePath))
-> ServerHandler m (d, b) (d, c)
forall (m :: * -> *) a b.
((a, RoutePath) -> m (Either RouteMismatch b, RoutePath))
-> ServerHandler m a b
ServerHandler ((((d, b), RoutePath)
  -> m (Either RouteMismatch (d, c), RoutePath))
 -> ServerHandler m (d, b) (d, c))
-> (((d, b), RoutePath)
    -> m (Either RouteMismatch (d, c), RoutePath))
-> ServerHandler m (d, b) (d, c)
forall a b. (a -> b) -> a -> b
$ \((d
c, b
a), RoutePath
s) ->
    (b, RoutePath) -> m (Either RouteMismatch c, RoutePath)
f (b
a, RoutePath
s) m (Either RouteMismatch c, RoutePath)
-> ((Either RouteMismatch c, RoutePath)
    -> m (Either RouteMismatch (d, c), RoutePath))
-> m (Either RouteMismatch (d, c), RoutePath)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      (Left RouteMismatch
e, RoutePath
s') -> (Either RouteMismatch (d, c), RoutePath)
-> m (Either RouteMismatch (d, c), RoutePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RouteMismatch -> Either RouteMismatch (d, c)
forall a b. a -> Either a b
Left RouteMismatch
e, RoutePath
s')
      (Right c
b, RoutePath
s') -> (Either RouteMismatch (d, c), RoutePath)
-> m (Either RouteMismatch (d, c), RoutePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((d, c) -> Either RouteMismatch (d, c)
forall a b. b -> Either a b
Right (d
c, c
b), RoutePath
s')

instance Monad m => ArrowZero (ServerHandler m) where
  {-# INLINEABLE zeroArrow #-}
  zeroArrow :: ServerHandler m b c
zeroArrow = ((b, RoutePath) -> m (Either RouteMismatch c, RoutePath))
-> ServerHandler m b c
forall (m :: * -> *) a b.
((a, RoutePath) -> m (Either RouteMismatch b, RoutePath))
-> ServerHandler m a b
ServerHandler (\(b
_a, RoutePath
s) -> (Either RouteMismatch c, RoutePath)
-> m (Either RouteMismatch c, RoutePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RouteMismatch -> Either RouteMismatch c
forall a b. a -> Either a b
Left RouteMismatch
forall a. Monoid a => a
mempty, RoutePath
s))

instance Monad m => ArrowPlus (ServerHandler m) where
  {-# INLINEABLE (<+>) #-}
  ServerHandler (b, RoutePath) -> m (Either RouteMismatch c, RoutePath)
f <+> :: ServerHandler m b c -> ServerHandler m b c -> ServerHandler m b c
<+> ServerHandler (b, RoutePath) -> m (Either RouteMismatch c, RoutePath)
g = ((b, RoutePath) -> m (Either RouteMismatch c, RoutePath))
-> ServerHandler m b c
forall (m :: * -> *) a b.
((a, RoutePath) -> m (Either RouteMismatch b, RoutePath))
-> ServerHandler m a b
ServerHandler (((b, RoutePath) -> m (Either RouteMismatch c, RoutePath))
 -> ServerHandler m b c)
-> ((b, RoutePath) -> m (Either RouteMismatch c, RoutePath))
-> ServerHandler m b c
forall a b. (a -> b) -> a -> b
$ \(b
a, RoutePath
s) ->
    (b, RoutePath) -> m (Either RouteMismatch c, RoutePath)
f (b
a, RoutePath
s) m (Either RouteMismatch c, RoutePath)
-> ((Either RouteMismatch c, RoutePath)
    -> m (Either RouteMismatch c, RoutePath))
-> m (Either RouteMismatch c, RoutePath)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      (Left RouteMismatch
_e, RoutePath
_s') -> (b, RoutePath) -> m (Either RouteMismatch c, RoutePath)
g (b
a, RoutePath
s)
      (Right c
b, RoutePath
s') -> (Either RouteMismatch c, RoutePath)
-> m (Either RouteMismatch c, RoutePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (c -> Either RouteMismatch c
forall a b. b -> Either a b
Right c
b, RoutePath
s')

instance Monad m => ArrowChoice (ServerHandler m) where
  {-# INLINEABLE left #-}
  left :: ServerHandler m b c -> ServerHandler m (Either b d) (Either c d)
left (ServerHandler (b, RoutePath) -> m (Either RouteMismatch c, RoutePath)
f) = ((Either b d, RoutePath)
 -> m (Either RouteMismatch (Either c d), RoutePath))
-> ServerHandler m (Either b d) (Either c d)
forall (m :: * -> *) a b.
((a, RoutePath) -> m (Either RouteMismatch b, RoutePath))
-> ServerHandler m a b
ServerHandler (((Either b d, RoutePath)
  -> m (Either RouteMismatch (Either c d), RoutePath))
 -> ServerHandler m (Either b d) (Either c d))
-> ((Either b d, RoutePath)
    -> m (Either RouteMismatch (Either c d), RoutePath))
-> ServerHandler m (Either b d) (Either c d)
forall a b. (a -> b) -> a -> b
$ \(Either b d
bd, RoutePath
s) ->
    case Either b d
bd of
      Right d
d -> (Either RouteMismatch (Either c d), RoutePath)
-> m (Either RouteMismatch (Either c d), RoutePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either c d -> Either RouteMismatch (Either c d)
forall a b. b -> Either a b
Right (d -> Either c d
forall a b. b -> Either a b
Right d
d), RoutePath
s)
      Left b
b ->
        (b, RoutePath) -> m (Either RouteMismatch c, RoutePath)
f (b
b, RoutePath
s) m (Either RouteMismatch c, RoutePath)
-> ((Either RouteMismatch c, RoutePath)
    -> m (Either RouteMismatch (Either c d), RoutePath))
-> m (Either RouteMismatch (Either c d), RoutePath)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          (Left RouteMismatch
e, RoutePath
s') -> (Either RouteMismatch (Either c d), RoutePath)
-> m (Either RouteMismatch (Either c d), RoutePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RouteMismatch -> Either RouteMismatch (Either c d)
forall a b. a -> Either a b
Left RouteMismatch
e, RoutePath
s')
          (Right c
c, RoutePath
s') -> (Either RouteMismatch (Either c d), RoutePath)
-> m (Either RouteMismatch (Either c d), RoutePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either c d -> Either RouteMismatch (Either c d)
forall a b. b -> Either a b
Right (c -> Either c d
forall a b. a -> Either a b
Left c
c), RoutePath
s')

  {-# INLINEABLE right #-}
  right :: ServerHandler m b c -> ServerHandler m (Either d b) (Either d c)
right (ServerHandler (b, RoutePath) -> m (Either RouteMismatch c, RoutePath)
f) = ((Either d b, RoutePath)
 -> m (Either RouteMismatch (Either d c), RoutePath))
-> ServerHandler m (Either d b) (Either d c)
forall (m :: * -> *) a b.
((a, RoutePath) -> m (Either RouteMismatch b, RoutePath))
-> ServerHandler m a b
ServerHandler (((Either d b, RoutePath)
  -> m (Either RouteMismatch (Either d c), RoutePath))
 -> ServerHandler m (Either d b) (Either d c))
-> ((Either d b, RoutePath)
    -> m (Either RouteMismatch (Either d c), RoutePath))
-> ServerHandler m (Either d b) (Either d c)
forall a b. (a -> b) -> a -> b
$ \(Either d b
db, RoutePath
s) ->
    case Either d b
db of
      Left d
d -> (Either RouteMismatch (Either d c), RoutePath)
-> m (Either RouteMismatch (Either d c), RoutePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either d c -> Either RouteMismatch (Either d c)
forall a b. b -> Either a b
Right (d -> Either d c
forall a b. a -> Either a b
Left d
d), RoutePath
s)
      Right b
b ->
        (b, RoutePath) -> m (Either RouteMismatch c, RoutePath)
f (b
b, RoutePath
s) m (Either RouteMismatch c, RoutePath)
-> ((Either RouteMismatch c, RoutePath)
    -> m (Either RouteMismatch (Either d c), RoutePath))
-> m (Either RouteMismatch (Either d c), RoutePath)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          (Left RouteMismatch
e, RoutePath
s') -> (Either RouteMismatch (Either d c), RoutePath)
-> m (Either RouteMismatch (Either d c), RoutePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RouteMismatch -> Either RouteMismatch (Either d c)
forall a b. a -> Either a b
Left RouteMismatch
e, RoutePath
s')
          (Right c
c, RoutePath
s') -> (Either RouteMismatch (Either d c), RoutePath)
-> m (Either RouteMismatch (Either d c), RoutePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either d c -> Either RouteMismatch (Either d c)
forall a b. b -> Either a b
Right (c -> Either d c
forall a b. b -> Either a b
Right c
c), RoutePath
s')

instance Monad m => ArrowError RouteMismatch (ServerHandler m) where
  {-# INLINEABLE raise #-}
  raise :: ServerHandler m RouteMismatch b
raise = ((RouteMismatch, RoutePath)
 -> m (Either RouteMismatch b, RoutePath))
-> ServerHandler m RouteMismatch b
forall (m :: * -> *) a b.
((a, RoutePath) -> m (Either RouteMismatch b, RoutePath))
-> ServerHandler m a b
ServerHandler (((RouteMismatch, RoutePath)
  -> m (Either RouteMismatch b, RoutePath))
 -> ServerHandler m RouteMismatch b)
-> ((RouteMismatch, RoutePath)
    -> m (Either RouteMismatch b, RoutePath))
-> ServerHandler m RouteMismatch b
forall a b. (a -> b) -> a -> b
$ \(RouteMismatch
e, RoutePath
s) -> (Either RouteMismatch b, RoutePath)
-> m (Either RouteMismatch b, RoutePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RouteMismatch -> Either RouteMismatch b
forall a b. a -> Either a b
Left RouteMismatch
e, RoutePath
s)

  {-# INLINEABLE handle #-}
  (ServerHandler (e, RoutePath) -> m (Either RouteMismatch b, RoutePath)
action) handle :: ServerHandler m e b
-> ServerHandler m (e, RouteMismatch) b -> ServerHandler m e b
`handle` (ServerHandler ((e, RouteMismatch), RoutePath)
-> m (Either RouteMismatch b, RoutePath)
errHandler) = ((e, RoutePath) -> m (Either RouteMismatch b, RoutePath))
-> ServerHandler m e b
forall (m :: * -> *) a b.
((a, RoutePath) -> m (Either RouteMismatch b, RoutePath))
-> ServerHandler m a b
ServerHandler (((e, RoutePath) -> m (Either RouteMismatch b, RoutePath))
 -> ServerHandler m e b)
-> ((e, RoutePath) -> m (Either RouteMismatch b, RoutePath))
-> ServerHandler m e b
forall a b. (a -> b) -> a -> b
$ \(e
a, RoutePath
s) ->
    (e, RoutePath) -> m (Either RouteMismatch b, RoutePath)
action (e
a, RoutePath
s) m (Either RouteMismatch b, RoutePath)
-> ((Either RouteMismatch b, RoutePath)
    -> m (Either RouteMismatch b, RoutePath))
-> m (Either RouteMismatch b, RoutePath)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      (Left RouteMismatch
e, RoutePath
s') -> ((e, RouteMismatch), RoutePath)
-> m (Either RouteMismatch b, RoutePath)
errHandler ((e
a, RouteMismatch
e), RoutePath
s')
      (Right b
b, RoutePath
s') -> (Either RouteMismatch b, RoutePath)
-> m (Either RouteMismatch b, RoutePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> Either RouteMismatch b
forall a b. b -> Either a b
Right b
b, RoutePath
s')

  {-# INLINEABLE tryInUnless #-}
  tryInUnless :: ServerHandler m e b
-> ServerHandler m (e, b) c
-> ServerHandler m (e, RouteMismatch) c
-> ServerHandler m e c
tryInUnless (ServerHandler (e, RoutePath) -> m (Either RouteMismatch b, RoutePath)
action) (ServerHandler ((e, b), RoutePath) -> m (Either RouteMismatch c, RoutePath)
resHandler) (ServerHandler ((e, RouteMismatch), RoutePath)
-> m (Either RouteMismatch c, RoutePath)
errHandler) =
    ((e, RoutePath) -> m (Either RouteMismatch c, RoutePath))
-> ServerHandler m e c
forall (m :: * -> *) a b.
((a, RoutePath) -> m (Either RouteMismatch b, RoutePath))
-> ServerHandler m a b
ServerHandler (((e, RoutePath) -> m (Either RouteMismatch c, RoutePath))
 -> ServerHandler m e c)
-> ((e, RoutePath) -> m (Either RouteMismatch c, RoutePath))
-> ServerHandler m e c
forall a b. (a -> b) -> a -> b
$ \(e
a, RoutePath
s) ->
      (e, RoutePath) -> m (Either RouteMismatch b, RoutePath)
action (e
a, RoutePath
s) m (Either RouteMismatch b, RoutePath)
-> ((Either RouteMismatch b, RoutePath)
    -> m (Either RouteMismatch c, RoutePath))
-> m (Either RouteMismatch c, RoutePath)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        (Left RouteMismatch
e, RoutePath
s') -> ((e, RouteMismatch), RoutePath)
-> m (Either RouteMismatch c, RoutePath)
errHandler ((e
a, RouteMismatch
e), RoutePath
s')
        (Right b
b, RoutePath
s') -> ((e, b), RoutePath) -> m (Either RouteMismatch c, RoutePath)
resHandler ((e
a, b
b), RoutePath
s')

instance Monad m => Handler (ServerHandler m) m where
  {-# INLINEABLE arrM #-}
  arrM :: (a -> m b) -> ServerHandler m a b
  arrM :: (a -> m b) -> ServerHandler m a b
arrM a -> m b
f = ((a, RoutePath) -> m (Either RouteMismatch b, RoutePath))
-> ServerHandler m a b
forall (m :: * -> *) a b.
((a, RoutePath) -> m (Either RouteMismatch b, RoutePath))
-> ServerHandler m a b
ServerHandler (((a, RoutePath) -> m (Either RouteMismatch b, RoutePath))
 -> ServerHandler m a b)
-> ((a, RoutePath) -> m (Either RouteMismatch b, RoutePath))
-> ServerHandler m a b
forall a b. (a -> b) -> a -> b
$ \(a
a, RoutePath
s) -> a -> m b
f a
a m b
-> (b -> m (Either RouteMismatch b, RoutePath))
-> m (Either RouteMismatch b, RoutePath)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \b
b -> (Either RouteMismatch b, RoutePath)
-> m (Either RouteMismatch b, RoutePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> Either RouteMismatch b
forall a b. b -> Either a b
Right b
b, RoutePath
s)

  {-# INLINEABLE consumeRoute #-}
  consumeRoute :: ServerHandler m RoutePath a -> ServerHandler m () a
  consumeRoute :: ServerHandler m RoutePath a -> ServerHandler m () a
consumeRoute (ServerHandler (RoutePath, RoutePath) -> m (Either RouteMismatch a, RoutePath)
h) = (((), RoutePath) -> m (Either RouteMismatch a, RoutePath))
-> ServerHandler m () a
forall (m :: * -> *) a b.
((a, RoutePath) -> m (Either RouteMismatch b, RoutePath))
-> ServerHandler m a b
ServerHandler ((((), RoutePath) -> m (Either RouteMismatch a, RoutePath))
 -> ServerHandler m () a)
-> (((), RoutePath) -> m (Either RouteMismatch a, RoutePath))
-> ServerHandler m () a
forall a b. (a -> b) -> a -> b
$
    \((), RoutePath
path) -> (RoutePath, RoutePath) -> m (Either RouteMismatch a, RoutePath)
h (RoutePath
path, [Text] -> RoutePath
RoutePath [])

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

  {-# INLINEABLE setSummary #-}
  setSummary :: Summary -> ServerHandler m a a
  setSummary :: Summary -> ServerHandler m a a
setSummary Summary
_ = ServerHandler m a a
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 :: ServerHandler m a b -> RoutePath -> a -> m (Either RouteMismatch b)
runServerHandler (ServerHandler (a, RoutePath) -> m (Either RouteMismatch b, RoutePath)
h) RoutePath
path a
a = (Either RouteMismatch b, RoutePath) -> Either RouteMismatch b
forall a b. (a, b) -> a
fst ((Either RouteMismatch b, RoutePath) -> Either RouteMismatch b)
-> m (Either RouteMismatch b, RoutePath)
-> m (Either RouteMismatch b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a, RoutePath) -> m (Either RouteMismatch b, RoutePath)
h (a
a, RoutePath
path)

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

    path :: RoutePath
    path :: RoutePath
path = [Text] -> RoutePath
RoutePath ([Text] -> RoutePath) -> [Text] -> 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 = Response -> Either RouteMismatch Response -> Response
forall b a. b -> Either a b -> b
fromRight (Status
-> HashMap HeaderName ByteString -> Maybe ByteString -> Response
Response Status
HTTP.notFound404 [] Maybe ByteString
forall a. Monoid a => a
mempty)

    addServerHeader :: Response -> Response
    addServerHeader :: Response -> Response
addServerHeader resp :: Response
resp@Response{Maybe ByteString
Status
HashMap HeaderName ByteString
responseStatus :: Response -> Status
responseHeaders :: Response -> HashMap HeaderName ByteString
responseBody :: Response -> Maybe ByteString
responseBody :: Maybe ByteString
responseHeaders :: HashMap HeaderName ByteString
responseStatus :: Status
..} = Response
resp{responseHeaders :: HashMap HeaderName ByteString
responseHeaders = HashMap HeaderName ByteString
responseHeaders HashMap HeaderName ByteString
-> HashMap HeaderName ByteString -> HashMap HeaderName ByteString
forall a. Semigroup a => a -> a -> a
<> HashMap HeaderName ByteString
webGearServerHeader}

{- | 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) (`Linked` '[] `Request`) `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 x. m x -> n x)
-> ServerHandler m a b -> ServerHandler n a b
transform forall x. m x -> n x
f (ServerHandler (a, RoutePath) -> m (Either RouteMismatch b, RoutePath)
g) =
  ((a, RoutePath) -> n (Either RouteMismatch b, RoutePath))
-> ServerHandler n a b
forall (m :: * -> *) a b.
((a, RoutePath) -> m (Either RouteMismatch b, RoutePath))
-> ServerHandler m a b
ServerHandler (((a, RoutePath) -> n (Either RouteMismatch b, RoutePath))
 -> ServerHandler n a b)
-> ((a, RoutePath) -> n (Either RouteMismatch b, RoutePath))
-> ServerHandler n a b
forall a b. (a -> b) -> a -> b
$ m (Either RouteMismatch b, RoutePath)
-> n (Either RouteMismatch b, RoutePath)
forall x. m x -> n x
f (m (Either RouteMismatch b, RoutePath)
 -> n (Either RouteMismatch b, RoutePath))
-> ((a, RoutePath) -> m (Either RouteMismatch b, RoutePath))
-> (a, RoutePath)
-> n (Either RouteMismatch b, RoutePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, RoutePath) -> m (Either RouteMismatch b, RoutePath)
g

webGearServerHeader :: HM.HashMap HTTP.HeaderName ByteString
webGearServerHeader :: HashMap HeaderName ByteString
webGearServerHeader = HeaderName -> ByteString -> HashMap HeaderName ByteString
forall k v. Hashable k => k -> v -> HashMap k v
HM.singleton HeaderName
HTTP.hServer (String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String
"WebGear/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Version -> String
showVersion Version
version)