{- |
 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 (..))
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)
-> Category (ServerHandler m)
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
$cid :: forall (m :: * -> *) a. Monad m => ServerHandler m a a
id :: forall a. ServerHandler m a a
$c. :: 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
Cat.Category
    , Category (ServerHandler m)
Category (ServerHandler m) =>
(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 b' c'.
    ServerHandler m b c
    -> ServerHandler m b' c' -> ServerHandler m (b, b') (c, c'))
-> (forall b c c'.
    ServerHandler m b c
    -> ServerHandler m b c' -> ServerHandler m b (c, c'))
-> Arrow (ServerHandler m)
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
$carr :: forall (m :: * -> *) b c.
Monad m =>
(b -> c) -> ServerHandler m b c
arr :: forall b c. (b -> c) -> ServerHandler m b c
$cfirst :: forall (m :: * -> *) b c d.
Monad m =>
ServerHandler m b c -> ServerHandler m (b, d) (c, d)
first :: forall b c d. ServerHandler m b c -> ServerHandler m (b, d) (c, d)
$csecond :: forall (m :: * -> *) b c d.
Monad m =>
ServerHandler m b c -> ServerHandler m (d, b) (d, c)
second :: forall b c d. ServerHandler m b c -> ServerHandler m (d, b) (d, 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 b c b' c'.
ServerHandler m b c
-> ServerHandler m b' c' -> ServerHandler m (b, 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 c'.
ServerHandler m b c
-> ServerHandler m b c' -> ServerHandler m b (c, c')
Arrow
    , Arrow (ServerHandler m)
Arrow (ServerHandler m) =>
(forall b c. ServerHandler m b c) -> ArrowZero (ServerHandler m)
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
$czeroArrow :: forall (m :: * -> *) b c. Monad m => ServerHandler m b c
zeroArrow :: forall b c. ServerHandler m b c
ArrowZero
    , ArrowZero (ServerHandler m)
ArrowZero (ServerHandler m) =>
(forall b c.
 ServerHandler m b c -> ServerHandler m b c -> ServerHandler m b c)
-> ArrowPlus (ServerHandler m)
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
$c<+> :: forall (m :: * -> *) b c.
Monad m =>
ServerHandler m b c -> ServerHandler m b c -> ServerHandler m b c
<+> :: forall b c.
ServerHandler m b c -> ServerHandler m b c -> ServerHandler m b c
ArrowPlus
    , Arrow (ServerHandler m)
Arrow (ServerHandler m) =>
(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 c b' c'.
    ServerHandler m b c
    -> ServerHandler m b' c'
    -> ServerHandler m (Either b b') (Either c c'))
-> (forall b d c.
    ServerHandler m b d
    -> ServerHandler m c d -> ServerHandler m (Either b c) d)
-> ArrowChoice (ServerHandler m)
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
$cleft :: forall (m :: * -> *) b c d.
Monad m =>
ServerHandler m b c -> ServerHandler m (Either b d) (Either c d)
left :: forall b c d.
ServerHandler m b c -> ServerHandler m (Either b d) (Either c d)
$cright :: forall (m :: * -> *) b c d.
Monad m =>
ServerHandler m b c -> ServerHandler m (Either d b) (Either d c)
right :: forall b c d.
ServerHandler m b c -> ServerHandler m (Either d b) (Either d 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')
+++ :: 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 d c.
Monad m =>
ServerHandler m b d
-> ServerHandler m c d -> ServerHandler m (Either b c) d
||| :: forall b d c.
ServerHandler m b d
-> ServerHandler m c d -> ServerHandler m (Either b 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 = (RouteMismatch -> StateT RoutePath (ExceptT RouteMismatch m) b)
-> ServerHandler m RouteMismatch b
forall (m :: * -> *) a b.
(a -> StateT RoutePath (ExceptT RouteMismatch m) b)
-> ServerHandler m a b
ServerHandler RouteMismatch -> StateT RoutePath (ExceptT RouteMismatch m) b
forall a.
RouteMismatch -> StateT RoutePath (ExceptT RouteMismatch m) a
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) =
    (a -> StateT RoutePath (ExceptT RouteMismatch m) b)
-> ServerHandler m a b
forall (m :: * -> *) a b.
(a -> StateT RoutePath (ExceptT RouteMismatch m) b)
-> ServerHandler m a b
ServerHandler ((a -> StateT RoutePath (ExceptT RouteMismatch m) b)
 -> ServerHandler m a b)
-> (a -> StateT RoutePath (ExceptT RouteMismatch m) b)
-> ServerHandler m a b
forall a b. (a -> b) -> a -> b
$ \a
a ->
      a -> StateT RoutePath (ExceptT RouteMismatch m) b
action a
a StateT RoutePath (ExceptT RouteMismatch m) b
-> (RouteMismatch -> StateT RoutePath (ExceptT RouteMismatch m) b)
-> StateT RoutePath (ExceptT RouteMismatch m) b
forall a.
StateT RoutePath (ExceptT RouteMismatch m) a
-> (RouteMismatch -> StateT RoutePath (ExceptT RouteMismatch m) a)
-> StateT RoutePath (ExceptT RouteMismatch m) 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) =
    (a -> StateT RoutePath (ExceptT RouteMismatch m) c)
-> ServerHandler m a c
forall (m :: * -> *) a b.
(a -> StateT RoutePath (ExceptT RouteMismatch m) b)
-> ServerHandler m a b
ServerHandler ((a -> StateT RoutePath (ExceptT RouteMismatch m) c)
 -> ServerHandler m a c)
-> (a -> StateT RoutePath (ExceptT RouteMismatch m) c)
-> ServerHandler m a c
forall a b. (a -> b) -> a -> b
$ \a
a ->
      a -> StateT RoutePath (ExceptT RouteMismatch m) c
f a
a StateT RoutePath (ExceptT RouteMismatch m) c
-> (RouteMismatch -> StateT RoutePath (ExceptT RouteMismatch m) c)
-> StateT RoutePath (ExceptT RouteMismatch m) c
forall a.
StateT RoutePath (ExceptT RouteMismatch m) a
-> (RouteMismatch -> StateT RoutePath (ExceptT RouteMismatch m) a)
-> StateT RoutePath (ExceptT RouteMismatch m) 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 = (a -> StateT RoutePath (ExceptT RouteMismatch m) b)
-> ServerHandler m a b
forall (m :: * -> *) a b.
(a -> StateT RoutePath (ExceptT RouteMismatch m) b)
-> ServerHandler m a b
ServerHandler ((a -> StateT RoutePath (ExceptT RouteMismatch m) b)
 -> ServerHandler m a b)
-> (a -> StateT RoutePath (ExceptT RouteMismatch m) b)
-> ServerHandler m a b
forall a b. (a -> b) -> a -> b
$ ExceptT RouteMismatch m b
-> StateT RoutePath (ExceptT RouteMismatch m) b
forall (m :: * -> *) a. Monad m => m a -> StateT RoutePath m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RouteMismatch m b
 -> StateT RoutePath (ExceptT RouteMismatch m) b)
-> (a -> ExceptT RouteMismatch m b)
-> a
-> StateT RoutePath (ExceptT RouteMismatch m) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m b -> ExceptT RouteMismatch m b
forall (m :: * -> *) a. Monad m => m a -> ExceptT RouteMismatch m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m b -> ExceptT RouteMismatch m b)
-> (a -> m b) -> a -> ExceptT RouteMismatch m b
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) =
    (() -> StateT RoutePath (ExceptT RouteMismatch m) a)
-> ServerHandler m () a
forall (m :: * -> *) a b.
(a -> StateT RoutePath (ExceptT RouteMismatch m) b)
-> ServerHandler m a b
ServerHandler ((() -> StateT RoutePath (ExceptT RouteMismatch m) a)
 -> ServerHandler m () a)
-> (() -> StateT RoutePath (ExceptT RouteMismatch m) a)
-> ServerHandler m () a
forall a b. (a -> b) -> a -> b
$
      \() -> do
        a
a <- StateT RoutePath (ExceptT RouteMismatch m) RoutePath
forall s (m :: * -> *). MonadState s m => m s
get StateT RoutePath (ExceptT RouteMismatch m) RoutePath
-> (RoutePath -> StateT RoutePath (ExceptT RouteMismatch m) a)
-> StateT RoutePath (ExceptT RouteMismatch m) a
forall a b.
StateT RoutePath (ExceptT RouteMismatch m) a
-> (a -> StateT RoutePath (ExceptT RouteMismatch m) b)
-> StateT RoutePath (ExceptT RouteMismatch m) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RoutePath -> StateT RoutePath (ExceptT RouteMismatch m) a
h
        RoutePath -> StateT RoutePath (ExceptT RouteMismatch m) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ([Text] -> RoutePath
RoutePath [])
        a -> StateT RoutePath (ExceptT RouteMismatch m) a
forall a. a -> StateT RoutePath (ExceptT RouteMismatch m) a
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
_ = ServerHandler m a a
forall a. ServerHandler m a a
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
_ = ServerHandler m a a
forall a. 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 :: 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 =
  ExceptT RouteMismatch m b -> m (Either RouteMismatch b)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT RouteMismatch m b -> m (Either RouteMismatch b))
-> ExceptT RouteMismatch m b -> m (Either RouteMismatch b)
forall a b. (a -> b) -> a -> b
$ StateT RoutePath (ExceptT RouteMismatch m) b
-> RoutePath -> ExceptT RouteMismatch m 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 =
  ServerHandler IO (With Request '[]) Response
-> RoutePath
-> With Request '[]
-> IO (Either RouteMismatch Response)
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
    IO (Either RouteMismatch Response)
-> (Either RouteMismatch Response -> IO ResponseReceived)
-> IO ResponseReceived
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Response -> IO ResponseReceived
processResponse
      (Response -> IO ResponseReceived)
-> (Either RouteMismatch Response -> Response)
-> Either RouteMismatch Response
-> IO ResponseReceived
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 :: Request `With` '[]
    request :: With Request '[]
request = Request -> With Request '[]
forall a. a -> With a '[]
wzero (Request -> With Request '[]) -> Request -> With 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 (Response -> Either RouteMismatch Response -> Response)
-> Response -> Either RouteMismatch Response -> Response
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ResponseBody -> Response
Response Status
HTTP.notFound404 [] (ResponseBody -> Response) -> ResponseBody -> Response
forall a b. (a -> b) -> a -> b
$ Builder -> ResponseBody
ResponseBodyBuilder Builder
forall a. Monoid a => a
mempty

    addServerHeader :: Response -> Response
    addServerHeader :: Response -> Response
addServerHeader = \case
      Response Status
status ResponseHeaders
hdrs ResponseBody
body -> Status -> ResponseHeaders -> ResponseBody -> Response
Response Status
status ((Header -> ResponseHeaders -> ResponseHeaders)
-> ResponseHeaders -> ResponseHeaders -> ResponseHeaders
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Header -> ResponseHeaders -> ResponseHeaders
insertServerHeader [] ResponseHeaders
hdrs) ResponseBody
body
      Response
resp -> Response
resp

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

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

    processResponse :: Response -> IO Wai.ResponseReceived
    processResponse :: Response -> IO ResponseReceived
processResponse Response
resp =
      case Response
resp of
        ResponseCont (Response -> IO ResponseReceived) -> IO ResponseReceived
f -> (Response -> IO ResponseReceived) -> IO ResponseReceived
f Response -> IO ResponseReceived
cont
        ResponseRaw IO ByteString -> (ByteString -> IO ()) -> IO ()
raw Response
fallback -> Response -> IO ResponseReceived
cont (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ (IO ByteString -> (ByteString -> IO ()) -> IO ())
-> Response -> Response
Wai.responseRaw IO ByteString -> (ByteString -> IO ()) -> IO ()
raw Response
fallback
        Response Status
status ResponseHeaders
hdrs ResponseBody
body ->
          Response -> IO ResponseReceived
cont (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$
            case ResponseBody
body of
              ResponseBodyFile [Char]
fpath Maybe FilePart
fpart -> Status -> ResponseHeaders -> [Char] -> Maybe FilePart -> Response
Wai.responseFile Status
status ResponseHeaders
hdrs [Char]
fpath Maybe FilePart
fpart
              ResponseBodyBuilder Builder
b -> Status -> ResponseHeaders -> Builder -> Response
Wai.responseBuilder Status
status ResponseHeaders
hdrs Builder
b
              ResponseBodyStream StreamingBody
sb -> Status -> ResponseHeaders -> StreamingBody -> Response
Wai.responseStream Status
status ResponseHeaders
hdrs StreamingBody
sb
{-# 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) =
  (a -> StateT RoutePath (ExceptT RouteMismatch n) b)
-> ServerHandler n a b
forall (m :: * -> *) a b.
(a -> StateT RoutePath (ExceptT RouteMismatch m) b)
-> ServerHandler m a b
ServerHandler ((a -> StateT RoutePath (ExceptT RouteMismatch n) b)
 -> ServerHandler n a b)
-> (a -> StateT RoutePath (ExceptT RouteMismatch n) b)
-> ServerHandler n a b
forall a b. (a -> b) -> a -> b
$ (ExceptT RouteMismatch m (b, RoutePath)
 -> ExceptT RouteMismatch n (b, RoutePath))
-> StateT RoutePath (ExceptT RouteMismatch m) b
-> StateT RoutePath (ExceptT RouteMismatch n) b
forall (m :: * -> *) a s (n :: * -> *) b.
(m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b
mapStateT ((m (Either RouteMismatch (b, RoutePath))
 -> n (Either RouteMismatch (b, RoutePath)))
-> ExceptT RouteMismatch m (b, RoutePath)
-> ExceptT RouteMismatch n (b, RoutePath)
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT m (Either RouteMismatch (b, RoutePath))
-> n (Either RouteMismatch (b, RoutePath))
forall x. m x -> n x
f) (StateT RoutePath (ExceptT RouteMismatch m) b
 -> StateT RoutePath (ExceptT RouteMismatch n) b)
-> (a -> StateT RoutePath (ExceptT RouteMismatch m) b)
-> a
-> StateT RoutePath (ExceptT RouteMismatch n) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> StateT RoutePath (ExceptT RouteMismatch m) b
g
{-# INLINE transform #-}