{-# language ConstraintKinds #-}
{-# language DataKinds #-}
{-# language DeriveGeneric #-}
{-# language FlexibleContexts #-}
{-# language FlexibleInstances #-}
{-# language GADTs #-}
{-# language MultiParamTypeClasses #-}
{-# language PolyKinds #-}
{-# language RankNTypes #-}
{-# language ScopedTypeVariables #-}
{-# language TypeApplications #-}
{-# language TypeFamilies #-}
{-# language TypeOperators #-}
{-# language UndecidableInstances #-}
module Mu.Servant.Server (
servantServerHandlers,
servantServerHandlersExtra,
toHandler,
packageAPI,
swagger,
ServantRoute(..),
DefaultServantContentTypes,
ServantContentTypes(..),
ServantStreamContentType(..),
StdMethod(..),
module Servant.API
) where
import Conduit
import Control.Concurrent
import Control.Concurrent.Async
import Control.Monad.Except
import Data.Aeson
import qualified Data.ByteString.Lazy.UTF8 as LB8
import Data.Conduit.Internal (ConduitT (..), Pipe (..))
import Data.Kind
import Data.Swagger (Swagger, ToSchema (..))
import GHC.Generics
import GHC.TypeLits
import GHC.Types (Any)
import Generics.Generic.Aeson
import Mu.Rpc
import Mu.Rpc.Annotations
import Mu.Schema
import Mu.Schema.Annotations
import Mu.Server
import Servant
import Servant.API
import Servant.Swagger
import Servant.Types.SourceT
toHandler :: ServerErrorIO a -> Handler a
toHandler :: ServerErrorIO a -> Handler a
toHandler = ExceptT ServerError IO a -> Handler a
forall a. ExceptT ServerError IO a -> Handler a
Handler (ExceptT ServerError IO a -> Handler a)
-> (ServerErrorIO a -> ExceptT ServerError IO a)
-> ServerErrorIO a
-> Handler a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ServerError -> ServerError)
-> ServerErrorIO a -> ExceptT ServerError IO a
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ServerError -> ServerError
convertServerError
convertServerError :: Mu.Server.ServerError -> Servant.ServerError
convertServerError :: ServerError -> ServerError
convertServerError (Mu.Server.ServerError code :: ServerErrorCode
code msg :: String
msg) = case ServerErrorCode
code of
Unknown -> ServerError
err502 {errBody :: ByteString
errBody = String -> ByteString
LB8.fromString String
msg}
Unavailable -> ServerError
err503 {errBody :: ByteString
errBody = String -> ByteString
LB8.fromString String
msg}
Unimplemented -> ServerError
err501 {errBody :: ByteString
errBody = String -> ByteString
LB8.fromString String
msg}
Unauthenticated -> ServerError
err401 {errBody :: ByteString
errBody = String -> ByteString
LB8.fromString String
msg}
Internal -> ServerError
err500 {errBody :: ByteString
errBody = String -> ByteString
LB8.fromString String
msg}
Invalid -> ServerError
err400 {errBody :: ByteString
errBody = String -> ByteString
LB8.fromString String
msg}
NotFound -> ServerError
err404 {errBody :: ByteString
errBody = String -> ByteString
LB8.fromString String
msg}
servantServerHandlers ::
forall pname m chn ss handlers.
( ServantServiceHandlers
('Package pname ss)
m
chn
ss
handlers
, ExtraFor ('Package pname ss) ~ EmptyAPI
)
=> (forall a. m a -> Handler a)
-> Mu.Server.ServerT chn () ('Package pname ss) m handlers
-> Servant.Server (PackageAPI ('Package pname ss) handlers)
servantServerHandlers :: (forall a. m a -> Handler a)
-> ServerT chn () ('Package pname ss) m handlers
-> Server (PackageAPI ('Package pname ss) handlers)
servantServerHandlers f :: forall a. m a -> Handler a
f (Services svcs :: ServicesT chn () s1 m handlers
svcs) =
Tagged Handler EmptyServer
forall (m :: * -> *). ServerT EmptyAPI m
emptyServer Tagged Handler EmptyServer
-> ServerT (ServicesAPI ('Package pname ss) ss handlers) Handler
-> Tagged Handler EmptyServer
:<|> ServerT (ServicesAPI ('Package pname ss) ss handlers) Handler
forall a b. a -> b -> a :<|> b
:<|> (forall a. m a -> Handler a)
-> Proxy ('Package pname ss)
-> ServicesT chn () s1 m handlers
-> Server (ServicesAPI ('Package pname ss) s1 handlers)
forall snm mnm anm (pkg :: Package snm mnm anm (TypeRef snm))
(m :: * -> *) (chn :: ServiceChain snm)
(ss :: [Service snm mnm anm (TypeRef snm)]) (hss :: [[*]]) info.
ServantServiceHandlers pkg m chn ss hss =>
(forall a. m a -> Handler a)
-> Proxy pkg
-> ServicesT chn info ss m hss
-> Server (ServicesAPI pkg ss hss)
servantServiceHandlers forall a. m a -> Handler a
f (Proxy ('Package pname ss)
forall k (t :: k). Proxy t
Proxy @('Package pname ss)) ServicesT chn () s1 m handlers
svcs
servantServerHandlersExtra ::
forall pname m chn ss handlers.
( ServantServiceHandlers
('Package pname ss)
m
chn
ss
handlers
)
=> (forall a. m a -> Handler a)
-> Server (ExtraFor ('Package pname ss))
-> Mu.Server.ServerT chn () ('Package pname ss) m handlers
-> Servant.Server (PackageAPI ('Package pname ss) handlers)
servantServerHandlersExtra :: (forall a. m a -> Handler a)
-> Server (ExtraFor ('Package pname ss))
-> ServerT chn () ('Package pname ss) m handlers
-> Server (PackageAPI ('Package pname ss) handlers)
servantServerHandlersExtra f :: forall a. m a -> Handler a
f extra :: Server (ExtraFor ('Package pname ss))
extra (Services svcs :: ServicesT chn () s1 m handlers
svcs) =
Server (ExtraFor ('Package pname ss))
ServerT
(WithAnnotatedPackageInstance
ServantRoute
('Package pname ss)
(UnwrapServantExtra
(FromMaybe
('ServantAdditional EmptyAPI)
(GetPackageAnnotationMay
(AnnotatedPackage ServantRoute ('Package pname ss))))))
Handler
extra ServerT
(WithAnnotatedPackageInstance
ServantRoute
('Package pname ss)
(UnwrapServantExtra
(FromMaybe
('ServantAdditional EmptyAPI)
(GetPackageAnnotationMay
(AnnotatedPackage ServantRoute ('Package pname ss))))))
Handler
-> ServerT (ServicesAPI ('Package pname ss) ss handlers) Handler
-> ServerT
(WithAnnotatedPackageInstance
ServantRoute
('Package pname ss)
(UnwrapServantExtra
(FromMaybe
('ServantAdditional EmptyAPI)
(GetPackageAnnotationMay
(AnnotatedPackage ServantRoute ('Package pname ss))))))
Handler
:<|> ServerT (ServicesAPI ('Package pname ss) ss handlers) Handler
forall a b. a -> b -> a :<|> b
:<|> (forall a. m a -> Handler a)
-> Proxy ('Package pname ss)
-> ServicesT chn () s1 m handlers
-> Server (ServicesAPI ('Package pname ss) s1 handlers)
forall snm mnm anm (pkg :: Package snm mnm anm (TypeRef snm))
(m :: * -> *) (chn :: ServiceChain snm)
(ss :: [Service snm mnm anm (TypeRef snm)]) (hss :: [[*]]) info.
ServantServiceHandlers pkg m chn ss hss =>
(forall a. m a -> Handler a)
-> Proxy pkg
-> ServicesT chn info ss m hss
-> Server (ServicesAPI pkg ss hss)
servantServiceHandlers forall a. m a -> Handler a
f (Proxy ('Package pname ss)
forall k (t :: k). Proxy t
Proxy @('Package pname ss)) ServicesT chn () s1 m handlers
svcs
swagger :: forall pname ss handlers chn m.
HasSwagger (ServicesAPI ('Package pname ss) ss handlers)
=> Mu.Server.ServerT chn () ('Package pname ss) m handlers
-> Swagger
swagger :: ServerT chn () ('Package pname ss) m handlers -> Swagger
swagger _ = Proxy (ServicesAPI ('Package pname ss) ss handlers) -> Swagger
forall k (api :: k). HasSwagger api => Proxy api -> Swagger
toSwagger (Proxy (ServicesAPI ('Package pname ss) ss handlers)
forall k (t :: k). Proxy t
Proxy @(ServicesAPI ('Package pname ss) ss handlers))
packageAPI :: Mu.Server.ServerT chn t pkg s handlers -> Proxy (PackageAPI pkg handlers)
packageAPI :: ServerT chn t pkg s handlers -> Proxy (PackageAPI pkg handlers)
packageAPI _ = Proxy (PackageAPI pkg handlers)
forall k (t :: k). Proxy t
Proxy
type family PackageAPI (pkg :: Package snm mnm anm (TypeRef snm)) handlers where
PackageAPI ('Package pnm ss) handlers = PackageAPI' (ExtraFor ('Package pnm ss)) ('Package pnm ss) handlers
type family PackageAPI' (extra :: Type) (pkg :: Package snm mnm anm (TypeRef snm)) handlers where
PackageAPI' extra ('Package pnm ss) handlers = extra :<|> ServicesAPI ('Package pnm ss) ss handlers
class
ServantServiceHandlers
(pkg :: Package snm mnm anm (TypeRef snm))
(m :: Type -> Type)
(chn :: ServiceChain snm)
(ss :: [Service snm mnm anm (TypeRef snm)])
(hss :: [[Type]]) where
type ServicesAPI pkg ss hss
servantServiceHandlers ::
(forall a. m a -> Handler a) ->
Proxy pkg ->
ServicesT chn info ss m hss ->
Servant.Server (ServicesAPI pkg ss hss)
instance ServantServiceHandlers pkg m chn '[] '[] where
type ServicesAPI pkg '[] '[] = EmptyAPI
servantServiceHandlers :: (forall a. m a -> Handler a)
-> Proxy pkg
-> ServicesT chn info '[] m '[]
-> Server (ServicesAPI pkg '[] '[])
servantServiceHandlers _ _ S0 = Server (ServicesAPI pkg '[] '[])
forall (m :: * -> *). ServerT EmptyAPI m
emptyServer
instance
( ServantMethodHandlers
pkg
sname
m
chn
(MappingRight chn sname)
methods
hs,
ServantServiceHandlers pkg m chn rest hss
) =>
ServantServiceHandlers pkg m chn ('Service sname methods ': rest) (hs ': hss)
where
type
ServicesAPI pkg ('Service sname methods ': rest) (hs ': hss) =
MethodsAPI pkg sname methods hs :<|> ServicesAPI pkg rest hss
servantServiceHandlers :: (forall a. m a -> Handler a)
-> Proxy pkg
-> ServicesT chn info ('Service sname methods : rest) m (hs : hss)
-> Server
(ServicesAPI pkg ('Service sname methods : rest) (hs : hss))
servantServiceHandlers f :: forall a. m a -> Handler a
f pkgP :: Proxy pkg
pkgP (ProperSvc svr :: HandlersT chn info (MappingRight chn sname) methods m hs1
svr :<&>: rest :: ServicesT chn info rest m hss
rest) =
(forall a. m a -> Handler a)
-> Proxy pkg
-> Proxy sname
-> HandlersT chn info (MappingRight chn sname) methods m hs1
-> Server (MethodsAPI pkg sname methods hs1)
forall anm snm (pkg :: Package Symbol Symbol anm (TypeRef Symbol))
(sname :: Symbol) (m :: * -> *) (chn :: ServiceChain snm) inh
(ms :: [Method snm Symbol anm (TypeRef snm)]) (hs :: [*]) info.
ServantMethodHandlers pkg sname m chn inh ms hs =>
(forall a. m a -> Handler a)
-> Proxy pkg
-> Proxy sname
-> HandlersT chn info inh ms m hs
-> Server (MethodsAPI pkg sname ms hs)
servantMethodHandlers forall a. m a -> Handler a
f Proxy pkg
pkgP (Proxy sname
forall k (t :: k). Proxy t
Proxy @sname) HandlersT chn info (MappingRight chn sname) methods m hs1
HandlersT chn info (MappingRight chn sname) methods m hs1
svr
ServerT (MethodsAPI pkg sname methods hs) Handler
-> ServerT (ServicesAPI pkg rest hss) Handler
-> ServerT (MethodsAPI pkg sname methods hs) Handler
:<|> ServerT (ServicesAPI pkg rest hss) Handler
forall a b. a -> b -> a :<|> b
:<|> (forall a. m a -> Handler a)
-> Proxy pkg
-> ServicesT chn info rest m hss
-> Server (ServicesAPI pkg rest hss)
forall snm mnm anm (pkg :: Package snm mnm anm (TypeRef snm))
(m :: * -> *) (chn :: ServiceChain snm)
(ss :: [Service snm mnm anm (TypeRef snm)]) (hss :: [[*]]) info.
ServantServiceHandlers pkg m chn ss hss =>
(forall a. m a -> Handler a)
-> Proxy pkg
-> ServicesT chn info ss m hss
-> Server (ServicesAPI pkg ss hss)
servantServiceHandlers forall a. m a -> Handler a
f Proxy pkg
pkgP ServicesT chn info rest m hss
rest
instance (TypeError ('Text "unions are not supported by Servant servers"))
=> ServantServiceHandlers pkg m chn ('OneOf sname methods ': rest) hs where
type ServicesAPI pkg ('OneOf sname methods ': rest) hs =
TypeError ('Text "unions are not supported by Servant servers")
servantServiceHandlers :: (forall a. m a -> Handler a)
-> Proxy pkg
-> ServicesT chn info ('OneOf sname methods : rest) m hs
-> Server (ServicesAPI pkg ('OneOf sname methods : rest) hs)
servantServiceHandlers _ = String
-> Proxy pkg
-> ServicesT chn info ('OneOf sname methods : rest) m hs
-> ServerT (TypeError ...) Handler
forall a. HasCallStack => String -> a
error "unions are not supported by Servant servers"
class
ServantMethodHandlers
(pkg :: Package Symbol Symbol anm (TypeRef Symbol))
(sname :: Symbol)
(m :: Type -> Type)
(chn :: ServiceChain snm)
(inh :: Type)
(ms :: [Method snm Symbol anm (TypeRef snm)])
(hs :: [Type]) where
type MethodsAPI pkg sname ms hs
servantMethodHandlers ::
(forall a. m a -> Handler a) ->
Proxy pkg ->
Proxy sname ->
HandlersT chn info inh ms m hs ->
Servant.Server (MethodsAPI pkg sname ms hs)
instance
ServantMethodHandlers pkg svc m chn inh '[] '[] where
type MethodsAPI _ _ '[] '[] = EmptyAPI
servantMethodHandlers :: (forall a. m a -> Handler a)
-> Proxy pkg
-> Proxy svc
-> HandlersT chn info inh '[] m '[]
-> Server (MethodsAPI pkg svc '[] '[])
servantMethodHandlers _ _ _ H0 = Server (MethodsAPI pkg svc '[] '[])
forall (m :: * -> *). ServerT EmptyAPI m
emptyServer
instance
( ServantMethodHandler httpMethod httpStatus m args ret h,
ServantMethodHandlers pkg sname m chn () rest hs,
HttpMethodFor pkg sname mname ~ httpMethod,
HttpStatusFor pkg sname mname ~ httpStatus,
Server (MethodAPI pkg sname ('Method mname args ret) h) ~ Server (HandlerAPI httpMethod httpStatus args ret h)
) =>
ServantMethodHandlers pkg sname m chn () ('Method mname args ret ': rest) (h ': hs)
where
type
MethodsAPI pkg sname ('Method mname args ret ': rest) (h ': hs) =
MethodAPI pkg sname ('Method mname args ret) h
:<|> MethodsAPI pkg sname rest hs
servantMethodHandlers :: (forall a. m a -> Handler a)
-> Proxy pkg
-> Proxy sname
-> HandlersT chn info () ('Method mname args ret : rest) m (h : hs)
-> Server
(MethodsAPI pkg sname ('Method mname args ret : rest) (h : hs))
servantMethodHandlers f :: forall a. m a -> Handler a
f pkgP :: Proxy pkg
pkgP snameP :: Proxy sname
snameP (Hmore _ _ h :: RpcInfo info -> () -> h
h rest :: HandlersT chn info () ms m hs1
rest) =
(forall a. m a -> Handler a)
-> Proxy httpMethod
-> Proxy httpStatus
-> Proxy args
-> Proxy ret
-> h
-> Server (HandlerAPI httpMethod httpStatus args ret h)
forall snm anm (httpMethod :: StdMethod) (httpStatus :: Nat)
(m :: * -> *) (args :: [Argument snm anm (TypeRef snm)])
(ret :: Return snm (TypeRef snm)) h.
ServantMethodHandler httpMethod httpStatus m args ret h =>
(forall a. m a -> Handler a)
-> Proxy httpMethod
-> Proxy httpStatus
-> Proxy args
-> Proxy ret
-> h
-> Server (HandlerAPI httpMethod httpStatus args ret h)
servantMethodHandler
forall a. m a -> Handler a
f
(Proxy httpMethod
forall k (t :: k). Proxy t
Proxy @httpMethod)
(Proxy httpStatus
forall k (t :: k). Proxy t
Proxy @httpStatus)
(Proxy args
forall k (t :: k). Proxy t
Proxy @args)
(Proxy ret
forall k (t :: k). Proxy t
Proxy @ret)
(RpcInfo info -> () -> h
h RpcInfo info
forall i. RpcInfo i
NoRpcInfo ())
Server (HandlerAPI httpMethod httpStatus args ret h)
-> ServerT (MethodsAPI pkg sname rest hs) Handler
-> Server (HandlerAPI httpMethod httpStatus args ret h)
:<|> ServerT (MethodsAPI pkg sname rest hs) Handler
forall a b. a -> b -> a :<|> b
:<|> (forall a. m a -> Handler a)
-> Proxy pkg
-> Proxy sname
-> HandlersT chn info () ms m hs1
-> Server (MethodsAPI pkg sname ms hs1)
forall anm snm (pkg :: Package Symbol Symbol anm (TypeRef Symbol))
(sname :: Symbol) (m :: * -> *) (chn :: ServiceChain snm) inh
(ms :: [Method snm Symbol anm (TypeRef snm)]) (hs :: [*]) info.
ServantMethodHandlers pkg sname m chn inh ms hs =>
(forall a. m a -> Handler a)
-> Proxy pkg
-> Proxy sname
-> HandlersT chn info inh ms m hs
-> Server (MethodsAPI pkg sname ms hs)
servantMethodHandlers forall a. m a -> Handler a
f Proxy pkg
pkgP Proxy sname
snameP HandlersT chn info () ms m hs1
rest
type family MethodAPI pkg sname method h where
MethodAPI pkg sname ('Method mname args ret) h =
PrefixRoute (RouteFor pkg sname mname)
( HandlerAPI
(HttpMethodFor pkg sname mname)
(HttpStatusFor pkg sname mname)
args
ret
h
)
class
ServantMethodHandler
(httpMethod :: StdMethod)
(httpStatus :: Nat)
(m :: Type -> Type)
(args :: [Argument snm anm (TypeRef snm)])
(ret :: Return snm (TypeRef snm))
(h :: Type) where
type
HandlerAPI
httpMethod
httpStatus
args
ret
h
servantMethodHandler ::
(forall a. m a -> Handler a) ->
Proxy httpMethod ->
Proxy httpStatus ->
Proxy args ->
Proxy ret ->
h ->
Servant.Server (HandlerAPI httpMethod httpStatus args ret h)
instance ServantMethodHandler httpMethod httpStatus m '[] 'RetNothing (m ()) where
type
HandlerAPI httpMethod httpStatus '[] 'RetNothing (m ()) =
Verb httpMethod httpStatus '[JSON] NoContent
servantMethodHandler :: (forall a. m a -> Handler a)
-> Proxy httpMethod
-> Proxy httpStatus
-> Proxy '[]
-> Proxy 'RetNothing
-> m ()
-> Server (HandlerAPI httpMethod httpStatus '[] 'RetNothing (m ()))
servantMethodHandler f :: forall a. m a -> Handler a
f _ _ _ _ = (() -> NoContent) -> Handler () -> Handler NoContent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (NoContent -> () -> NoContent
forall a b. a -> b -> a
const NoContent
NoContent) (Handler () -> Handler NoContent)
-> (m () -> Handler ()) -> m () -> Handler NoContent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m () -> Handler ()
forall a. m a -> Handler a
f
instance ServantMethodHandler httpMethod httpStatus m '[] ('RetSingle rref) (m r) where
type
HandlerAPI httpMethod httpStatus '[] ('RetSingle rref) (m r) =
Verb httpMethod httpStatus (UnaryContentTypesFor rref) r
servantMethodHandler :: (forall a. m a -> Handler a)
-> Proxy httpMethod
-> Proxy httpStatus
-> Proxy '[]
-> Proxy ('RetSingle rref)
-> m r
-> Server
(HandlerAPI httpMethod httpStatus '[] ('RetSingle rref) (m r))
servantMethodHandler f :: forall a. m a -> Handler a
f _ _ _ _ = m r
-> Server
(HandlerAPI httpMethod httpStatus '[] ('RetSingle rref) (m r))
forall a. m a -> Handler a
f
instance
(MonadServer m) =>
ServantMethodHandler httpMethod httpStatus m '[] ('RetStream rref) (ConduitT r Void m () -> m ())
where
type
HandlerAPI httpMethod httpStatus '[] ('RetStream rref) (ConduitT r Void m () -> m ()) =
Stream httpMethod httpStatus (StreamFramingFor rref) (StreamContentTypeFor rref) (SourceIO (StreamResult r))
servantMethodHandler :: (forall a. m a -> Handler a)
-> Proxy httpMethod
-> Proxy httpStatus
-> Proxy '[]
-> Proxy ('RetStream rref)
-> (ConduitT r Void m () -> m ())
-> Server
(HandlerAPI
httpMethod
httpStatus
'[]
('RetStream rref)
(ConduitT r Void m () -> m ()))
servantMethodHandler f :: forall a. m a -> Handler a
f _ _ _ _ = IO (SourceIO (StreamResult r))
-> Handler (SourceIO (StreamResult r))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (SourceIO (StreamResult r))
-> Handler (SourceIO (StreamResult r)))
-> ((ConduitT r Void m () -> m ())
-> IO (SourceIO (StreamResult r)))
-> (ConduitT r Void m () -> m ())
-> Handler (SourceIO (StreamResult r))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. m a -> Handler a)
-> (ConduitT r Void m () -> m ()) -> IO (SourceIO (StreamResult r))
forall r (m :: * -> *).
MonadServer m =>
(forall a. m a -> Handler a)
-> (ConduitT r Void m () -> m ()) -> IO (SourceIO (StreamResult r))
sinkToSource forall a. m a -> Handler a
f
data StreamResult a = Error String | Result a
deriving ((forall x. StreamResult a -> Rep (StreamResult a) x)
-> (forall x. Rep (StreamResult a) x -> StreamResult a)
-> Generic (StreamResult a)
forall x. Rep (StreamResult a) x -> StreamResult a
forall x. StreamResult a -> Rep (StreamResult a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (StreamResult a) x -> StreamResult a
forall a x. StreamResult a -> Rep (StreamResult a) x
$cto :: forall a x. Rep (StreamResult a) x -> StreamResult a
$cfrom :: forall a x. StreamResult a -> Rep (StreamResult a) x
Generic, Int -> StreamResult a -> ShowS
[StreamResult a] -> ShowS
StreamResult a -> String
(Int -> StreamResult a -> ShowS)
-> (StreamResult a -> String)
-> ([StreamResult a] -> ShowS)
-> Show (StreamResult a)
forall a. Show a => Int -> StreamResult a -> ShowS
forall a. Show a => [StreamResult a] -> ShowS
forall a. Show a => StreamResult a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StreamResult a] -> ShowS
$cshowList :: forall a. Show a => [StreamResult a] -> ShowS
show :: StreamResult a -> String
$cshow :: forall a. Show a => StreamResult a -> String
showsPrec :: Int -> StreamResult a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> StreamResult a -> ShowS
Show)
instance Data.Swagger.ToSchema a => Data.Swagger.ToSchema (StreamResult a)
instance ToJSON a => ToJSON (StreamResult a) where
toJSON :: StreamResult a -> Value
toJSON = StreamResult a -> Value
forall a.
(Generic a, GtoJson (Rep a), ConNames (Rep a), GIsEnum (Rep a)) =>
a -> Value
gtoJson
sinkToSource ::
forall r m.
(MonadServer m) =>
(forall a. m a -> Handler a) ->
(ConduitT r Void m () -> m ()) ->
IO (SourceIO (StreamResult r))
sinkToSource :: (forall a. m a -> Handler a)
-> (ConduitT r Void m () -> m ()) -> IO (SourceIO (StreamResult r))
sinkToSource f :: forall a. m a -> Handler a
f sink :: ConduitT r Void m () -> m ()
sink = do
MVar (Maybe r)
var <- IO (MVar (Maybe r))
forall a. IO (MVar a)
newEmptyMVar :: IO (MVar (Maybe r))
Async (Either ServerError ())
forwarder <- IO (Async (Either ServerError ()))
-> IO (Async (Either ServerError ()))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Async (Either ServerError ()))
-> IO (Async (Either ServerError ())))
-> IO (Async (Either ServerError ()))
-> IO (Async (Either ServerError ()))
forall a b. (a -> b) -> a -> b
$ IO (Either ServerError ()) -> IO (Async (Either ServerError ()))
forall a. IO a -> IO (Async a)
async (IO (Either ServerError ()) -> IO (Async (Either ServerError ())))
-> IO (Either ServerError ()) -> IO (Async (Either ServerError ()))
forall a b. (a -> b) -> a -> b
$ do
Either ServerError ()
e <- Handler () -> IO (Either ServerError ())
forall a. Handler a -> IO (Either ServerError a)
runHandler (Handler () -> IO (Either ServerError ()))
-> (ConduitT r Void m () -> Handler ())
-> ConduitT r Void m ()
-> IO (Either ServerError ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m () -> Handler ()
forall a. m a -> Handler a
f (m () -> Handler ())
-> (ConduitT r Void m () -> m ())
-> ConduitT r Void m ()
-> Handler ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConduitT r Void m () -> m ()
sink (ConduitT r Void m () -> IO (Either ServerError ()))
-> ConduitT r Void m () -> IO (Either ServerError ())
forall a b. (a -> b) -> a -> b
$ MVar (Maybe r) -> ConduitT r Void m ()
forall (m :: * -> *) r.
MonadServer m =>
MVar (Maybe r) -> ConduitT r Void m ()
toMVarConduit MVar (Maybe r)
var
MVar (Maybe r) -> Maybe r -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe r)
var Maybe r
forall a. Maybe a
Nothing
Either ServerError () -> IO (Either ServerError ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either ServerError ()
e
let step :: StepT IO (StreamResult r)
step :: StepT IO (StreamResult r)
step = IO (StepT IO (StreamResult r)) -> StepT IO (StreamResult r)
forall (m :: * -> *) a. m (StepT m a) -> StepT m a
Effect (IO (StepT IO (StreamResult r)) -> StepT IO (StreamResult r))
-> IO (StepT IO (StreamResult r)) -> StepT IO (StreamResult r)
forall a b. (a -> b) -> a -> b
$ do
Maybe r
nextOutput <- MVar (Maybe r) -> IO (Maybe r)
forall a. MVar a -> IO a
takeMVar MVar (Maybe r)
var
case Maybe r
nextOutput of
Just r :: r
r -> StepT IO (StreamResult r) -> IO (StepT IO (StreamResult r))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StepT IO (StreamResult r) -> IO (StepT IO (StreamResult r)))
-> StepT IO (StreamResult r) -> IO (StepT IO (StreamResult r))
forall a b. (a -> b) -> a -> b
$ StreamResult r
-> StepT IO (StreamResult r) -> StepT IO (StreamResult r)
forall (m :: * -> *) a. a -> StepT m a -> StepT m a
Yield (r -> StreamResult r
forall a. a -> StreamResult a
Result r
r) StepT IO (StreamResult r)
step
Nothing -> do
Either ServerError ()
res <- Async (Either ServerError ()) -> IO (Either ServerError ())
forall a. Async a -> IO a
wait Async (Either ServerError ())
forwarder
case Either ServerError ()
res of
Left err :: ServerError
err -> do
let streamErr :: String
streamErr = ByteString -> String
LB8.toString (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ServerError -> ByteString
errBody ServerError
err
StepT IO (StreamResult r) -> IO (StepT IO (StreamResult r))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StepT IO (StreamResult r) -> IO (StepT IO (StreamResult r)))
-> StepT IO (StreamResult r) -> IO (StepT IO (StreamResult r))
forall a b. (a -> b) -> a -> b
$ StreamResult r
-> StepT IO (StreamResult r) -> StepT IO (StreamResult r)
forall (m :: * -> *) a. a -> StepT m a -> StepT m a
Yield (String -> StreamResult r
forall a. String -> StreamResult a
Mu.Servant.Server.Error String
streamErr) StepT IO (StreamResult r)
forall (m :: * -> *) a. StepT m a
Stop
Right () -> StepT IO (StreamResult r) -> IO (StepT IO (StreamResult r))
forall (f :: * -> *) a. Applicative f => a -> f a
pure StepT IO (StreamResult r)
forall (m :: * -> *) a. StepT m a
Stop
SourceIO (StreamResult r) -> IO (SourceIO (StreamResult r))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SourceIO (StreamResult r) -> IO (SourceIO (StreamResult r)))
-> SourceIO (StreamResult r) -> IO (SourceIO (StreamResult r))
forall a b. (a -> b) -> a -> b
$ StepT IO (StreamResult r) -> SourceIO (StreamResult r)
forall (m :: * -> *) a. StepT m a -> SourceT m a
fromStepT StepT IO (StreamResult r)
step
toMVarConduit :: MonadServer m => MVar (Maybe r) -> ConduitT r Void m ()
toMVarConduit :: MVar (Maybe r) -> ConduitT r Void m ()
toMVarConduit var :: MVar (Maybe r)
var = do
Maybe r
x <- ConduitT r Void m (Maybe r)
forall (m :: * -> *) i. Monad m => Consumer i m (Maybe i)
await
case Maybe r
x of
Nothing -> () -> ConduitT r Void m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just _ -> do
IO () -> ConduitT r Void m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ConduitT r Void m ()) -> IO () -> ConduitT r Void m ()
forall a b. (a -> b) -> a -> b
$ MVar (Maybe r) -> Maybe r -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe r)
var Maybe r
x
MVar (Maybe r) -> ConduitT r Void m ()
forall (m :: * -> *) r.
MonadServer m =>
MVar (Maybe r) -> ConduitT r Void m ()
toMVarConduit MVar (Maybe r)
var
instance
(ServantMethodHandler httpMethod httpStatus m rest ret h) =>
ServantMethodHandler httpMethod httpStatus m ('ArgSingle anm aref ': rest) ret (t -> h)
where
type
HandlerAPI httpMethod httpStatus ('ArgSingle anm aref ': rest) ret (t -> h) =
ReqBody (UnaryContentTypesFor aref) t :> HandlerAPI httpMethod httpStatus rest ret h
servantMethodHandler :: (forall a. m a -> Handler a)
-> Proxy httpMethod
-> Proxy httpStatus
-> Proxy ('ArgSingle anm aref : rest)
-> Proxy ret
-> (t -> h)
-> Server
(HandlerAPI
httpMethod httpStatus ('ArgSingle anm aref : rest) ret (t -> h))
servantMethodHandler f :: forall a. m a -> Handler a
f mP :: Proxy httpMethod
mP sP :: Proxy httpStatus
sP _ retP :: Proxy ret
retP h :: t -> h
h t :: t
t =
(forall a. m a -> Handler a)
-> Proxy httpMethod
-> Proxy httpStatus
-> Proxy rest
-> Proxy ret
-> h
-> Server (HandlerAPI httpMethod httpStatus rest ret h)
forall snm anm (httpMethod :: StdMethod) (httpStatus :: Nat)
(m :: * -> *) (args :: [Argument snm anm (TypeRef snm)])
(ret :: Return snm (TypeRef snm)) h.
ServantMethodHandler httpMethod httpStatus m args ret h =>
(forall a. m a -> Handler a)
-> Proxy httpMethod
-> Proxy httpStatus
-> Proxy args
-> Proxy ret
-> h
-> Server (HandlerAPI httpMethod httpStatus args ret h)
servantMethodHandler forall a. m a -> Handler a
f Proxy httpMethod
mP Proxy httpStatus
sP (Proxy rest
forall k (t :: k). Proxy t
Proxy @rest) Proxy ret
retP (t -> h
h t
t)
instance
(MonadServer m, ServantMethodHandler httpMethod httpStatus m rest ret h) =>
ServantMethodHandler httpMethod httpStatus m ('ArgStream anm aref ': rest) ret (ConduitT () t m () -> h)
where
type
HandlerAPI httpMethod httpStatus ('ArgStream anm aref ': rest) ret (ConduitT () t m () -> h) =
StreamBody (StreamFramingFor aref) (StreamContentTypeFor aref) (SourceIO t)
:> HandlerAPI httpMethod httpStatus rest ret h
servantMethodHandler :: (forall a. m a -> Handler a)
-> Proxy httpMethod
-> Proxy httpStatus
-> Proxy ('ArgStream anm aref : rest)
-> Proxy ret
-> (ConduitT () t m () -> h)
-> Server
(HandlerAPI
httpMethod
httpStatus
('ArgStream anm aref : rest)
ret
(ConduitT () t m () -> h))
servantMethodHandler f :: forall a. m a -> Handler a
f mP :: Proxy httpMethod
mP sP :: Proxy httpStatus
sP _ retP :: Proxy ret
retP h :: ConduitT () t m () -> h
h =
(forall a. m a -> Handler a)
-> Proxy httpMethod
-> Proxy httpStatus
-> Proxy rest
-> Proxy ret
-> h
-> Server (HandlerAPI httpMethod httpStatus rest ret h)
forall snm anm (httpMethod :: StdMethod) (httpStatus :: Nat)
(m :: * -> *) (args :: [Argument snm anm (TypeRef snm)])
(ret :: Return snm (TypeRef snm)) h.
ServantMethodHandler httpMethod httpStatus m args ret h =>
(forall a. m a -> Handler a)
-> Proxy httpMethod
-> Proxy httpStatus
-> Proxy args
-> Proxy ret
-> h
-> Server (HandlerAPI httpMethod httpStatus args ret h)
servantMethodHandler forall a. m a -> Handler a
f Proxy httpMethod
mP Proxy httpStatus
sP (Proxy rest
forall k (t :: k). Proxy t
Proxy @rest) Proxy ret
retP (h -> Server (HandlerAPI httpMethod httpStatus rest ret h))
-> (SourceIO t -> h)
-> SourceIO t
-> Server (HandlerAPI httpMethod httpStatus rest ret h)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConduitT () t m () -> h
h (ConduitT () t m () -> h)
-> (SourceIO t -> ConduitT () t m ()) -> SourceIO t -> h
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceIO t -> ConduitT () t m ()
forall (m :: * -> *) t.
MonadServer m =>
SourceIO t -> ConduitT () t m ()
sourceToSource
sourceToSource :: (MonadServer m) => SourceIO t -> ConduitT () t m ()
sourceToSource :: SourceIO t -> ConduitT () t m ()
sourceToSource (SourceT src :: forall b. (StepT IO t -> IO b) -> IO b
src) = (forall b. (() -> Pipe () () t () m b) -> Pipe () () t () m b)
-> ConduitT () t m ()
forall i o (m :: * -> *) r.
(forall b. (r -> Pipe i i o () m b) -> Pipe i i o () m b)
-> ConduitT i o m r
ConduitT (m (Pipe () () t () m ()) -> Pipe () () t () m ()
forall l i o u (m :: * -> *) r.
m (Pipe l i o u m r) -> Pipe l i o u m r
PipeM (IO (Pipe () () t () m ()) -> m (Pipe () () t () m ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Pipe () () t () m ()) -> m (Pipe () () t () m ()))
-> IO (Pipe () () t () m ()) -> m (Pipe () () t () m ())
forall a b. (a -> b) -> a -> b
$ (StepT IO t -> IO (Pipe () () t () m ()))
-> IO (Pipe () () t () m ())
forall b. (StepT IO t -> IO b) -> IO b
src (Pipe () () t () m () -> IO (Pipe () () t () m ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pipe () () t () m () -> IO (Pipe () () t () m ()))
-> (StepT IO t -> Pipe () () t () m ())
-> StepT IO t
-> IO (Pipe () () t () m ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StepT IO t -> Pipe () () t () m ()
forall (m :: * -> *) t i u.
MonadServer m =>
StepT IO t -> Pipe i i t u m ()
go)) Pipe () () t () m ()
-> (() -> Pipe () () t () m b) -> Pipe () () t () m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=)
where
go :: (MonadServer m) => StepT IO t -> Pipe i i t u m ()
go :: StepT IO t -> Pipe i i t u m ()
go Stop = () -> Pipe i i t u m ()
forall l i o u (m :: * -> *) r. r -> Pipe l i o u m r
Done ()
go (Skip s :: StepT IO t
s) = StepT IO t -> Pipe i i t u m ()
forall (m :: * -> *) t i u.
MonadServer m =>
StepT IO t -> Pipe i i t u m ()
go StepT IO t
s
go (Yield t :: t
t s :: StepT IO t
s) = Pipe i i t u m () -> t -> Pipe i i t u m ()
forall l i o u (m :: * -> *) r.
Pipe l i o u m r -> o -> Pipe l i o u m r
HaveOutput (StepT IO t -> Pipe i i t u m ()
forall (m :: * -> *) t i u.
MonadServer m =>
StepT IO t -> Pipe i i t u m ()
go StepT IO t
s) t
t
go (Effect m :: IO (StepT IO t)
m) = m (Pipe i i t u m ()) -> Pipe i i t u m ()
forall l i o u (m :: * -> *) r.
m (Pipe l i o u m r) -> Pipe l i o u m r
PipeM (IO (Pipe i i t u m ()) -> m (Pipe i i t u m ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Pipe i i t u m ()) -> m (Pipe i i t u m ()))
-> IO (Pipe i i t u m ()) -> m (Pipe i i t u m ())
forall a b. (a -> b) -> a -> b
$ StepT IO t -> Pipe i i t u m ()
forall (m :: * -> *) t i u.
MonadServer m =>
StepT IO t -> Pipe i i t u m ()
go (StepT IO t -> Pipe i i t u m ())
-> IO (StepT IO t) -> IO (Pipe i i t u m ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (StepT IO t)
m)
go (Servant.Types.SourceT.Error msg :: String
msg) =
m (Pipe i i t u m ()) -> Pipe i i t u m ()
forall l i o u (m :: * -> *) r.
m (Pipe l i o u m r) -> Pipe l i o u m r
PipeM (ServerError -> m (Pipe i i t u m ())
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ServerError -> m (Pipe i i t u m ()))
-> ServerError -> m (Pipe i i t u m ())
forall a b. (a -> b) -> a -> b
$ ServerErrorCode -> String -> ServerError
Mu.Server.ServerError ServerErrorCode
Invalid ("error reading stream: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg))
data ServantRoute
= ServantAdditional Type
| ServantTopLevelRoute [Symbol]
| ServantRoute [Symbol] StdMethod Nat
type family Assert (err :: Constraint) (break :: k1) (a :: k2) :: k2 where
Assert _ '[ 'AnnSchema a, 'AnnSchema a ] _ = Any
Assert _ '[ 'AnnPackage a, 'AnnPackage a ] _ = Any
Assert _ _ a = a
type WithAnnotatedPackageInstance domain pkg a =
Assert (NoPackageAnnotations domain pkg) (AnnotatedPackage domain pkg) a
type WithAnnotatedSchemaInstance domain sch a =
Assert (NoSchemaAnnotations domain sch) (AnnotatedSchema domain sch) a
type family NoPackageAnnotations domain pkg :: Constraint where
NoPackageAnnotations domain ('Package ('Just pname) _)
= TypeError (
'Text "Missing required AnnotatedPackage " ':<>: 'ShowType domain ':<>: 'Text " type instance" ':$$:
'Text "for " ':<>: 'ShowType pname ':<>: 'Text " package"
)
NoPackageAnnotations domain pkg
= TypeError (
'Text "Missing required AnnotatedPackage " ':<>: 'ShowType domain ':<>: 'Text " type instance" ':$$:
'Text "for unnamed package: " ':$$: 'ShowType pkg
)
type family NoSchemaAnnotations domain sch :: Constraint where
NoSchemaAnnotations domain sch
= TypeError (
'Text "Missing required AnnotatedSchema " ':<>: 'ShowType domain ':<>: 'Text " type instance" ':$$:
'Text "for schema:" ':$$: 'ShowType sch
)
type family RouteFor (pkg :: Package snm mnm anm tyref) (s :: Symbol) (m :: Symbol) :: [Symbol] where
RouteFor pkg s m =
WithAnnotatedPackageInstance ServantRoute pkg (
Concat
(UnwrapServantRoute (FromMaybe ('ServantRoute '[s] Any Any) (GetServiceAnnotationMay (AnnotatedPackage ServantRoute pkg) s)))
(UnwrapServantRoute (FromMaybe ('ServantRoute '[m] Any Any) (GetMethodAnnotationMay (AnnotatedPackage ServantRoute pkg) s m)))
)
type family UnwrapServantRoute s where
UnwrapServantRoute ('ServantTopLevelRoute s) = s
UnwrapServantRoute ('ServantRoute s _ _) = s
type family (pkg :: Package snm mnm anm tyref) :: Type where
pkg =
WithAnnotatedPackageInstance ServantRoute pkg
(UnwrapServantExtra (FromMaybe ('ServantAdditional EmptyAPI) (GetPackageAnnotationMay (AnnotatedPackage ServantRoute pkg))))
type family s where
('ServantAdditional e) = e
type family FromMaybe (a :: k) (ma :: Maybe k) :: k where
FromMaybe a 'Nothing = a
FromMaybe _ ('Just a) = a
type family Concat (as :: [k]) (bs :: [k]) :: [k] where
Concat '[] bs = bs
Concat (a ': as) bs = a ': Concat as bs
type family PrefixRoute (prefix :: [Symbol]) route where
PrefixRoute '[] route = route
PrefixRoute (p ': rest) route = p :> PrefixRoute rest route
data ServantContentTypes
= ServantContentTypes
{ ServantContentTypes -> [*]
unary :: [Type]
, ServantContentTypes -> Maybe ServantStreamContentType
stream :: Maybe ServantStreamContentType
}
type DefaultServantContentTypes
= 'ServantContentTypes '[JSON] ('Just ('ServantStreamContentType NewlineFraming JSON))
data ServantStreamContentType
= ServantStreamContentType
{ ServantStreamContentType -> *
framing :: Type,
ServantStreamContentType -> *
streamContentType :: Type
}
type family HttpMethodFor pkg sname mname :: StdMethod where
HttpMethodFor pkg sname mname =
WithAnnotatedPackageInstance ServantRoute pkg (
UnwrapServantMethod (FromMaybe ('ServantRoute Any 'POST Any) (GetMethodAnnotationMay (AnnotatedPackage ServantRoute pkg) sname mname))
)
type family UnwrapServantMethod m where
UnwrapServantMethod ('ServantRoute _ m _) = m
type family HttpStatusFor pkg sname mname :: Nat where
HttpStatusFor pkg sname mname =
WithAnnotatedPackageInstance ServantRoute pkg (
UnwrapServantStatus (FromMaybe ('ServantRoute Any Any 200) (GetMethodAnnotationMay (AnnotatedPackage ServantRoute pkg) sname mname))
)
type family UnwrapServantStatus s where
UnwrapServantStatus ('ServantRoute _ _ s) = s
type family UnaryContentTypesFor (tyRef :: TypeRef sname) :: [Type] where
UnaryContentTypesFor ('SchemaRef schema typeName) =
WithAnnotatedSchemaInstance ServantContentTypes schema (
UnwrapServantUnaryContentType (GetTypeAnnotation (AnnotatedSchema ServantContentTypes schema) typeName)
)
type family UnwrapServantUnaryContentType (sctype :: ServantContentTypes) :: [Type] where
UnwrapServantUnaryContentType ('ServantContentTypes ctype stype) = ctype
type family StreamContentTypeFor (tyRef :: TypeRef sname) :: Type where
StreamContentTypeFor ('SchemaRef schema typeName) =
WithAnnotatedSchemaInstance ServantContentTypes schema (
StreamContentType (GetTypeAnnotation (AnnotatedSchema ServantContentTypes schema) typeName)
)
type family StreamContentType (sct :: ServantContentTypes) where
StreamContentType ('ServantContentTypes _ 'Nothing)
= TypeError ('Text "missing stream content type")
StreamContentType ('ServantContentTypes _ ('Just ('ServantStreamContentType _ ctype))) = ctype
type family StreamFramingFor (tyRef :: TypeRef sname) :: Type where
StreamFramingFor ('SchemaRef schema typeName) =
WithAnnotatedSchemaInstance ServantContentTypes schema (
StreamFraming (GetTypeAnnotation (AnnotatedSchema ServantContentTypes schema) typeName)
)
type family StreamFraming (sct :: ServantContentTypes) where
StreamFraming ('ServantContentTypes _ 'Nothing)
= TypeError ('Text "missing stream content type")
StreamFraming ('ServantContentTypes _ ('Just ('ServantStreamContentType framing _))) = framing