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)
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
runServerHandler ::
(Monad m) =>
ServerHandler m a b ->
RoutePath ->
a ->
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 #-}
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 ::
(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 #-}