{-# 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  #-}

{-|
Description : Execute a Mu 'Server' using Servant

This module allows you to serve a Mu 'Server'
as an OpenAPI / Swagger / REST end-point.
In particular, it translates to the kind of
type-level APIs used by Servant.
-}
module Mu.Servant.Server (
  -- * Convert Mu to Servant
  servantServerHandlers,
  servantServerHandlersExtra,
  toHandler,
  packageAPI,
  swagger,
  -- * Required annotations
  ServantRoute(..),
  DefaultServantContentTypes,
  ServantContentTypes(..),
  ServantStreamContentType(..),
  -- Reexports
  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

-- | Reinterprets a Mu server action as a Servant handler.
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

-- | Translates a Mu `Mu.Server.ServerError` into a Servant `Servant.ServerError`.
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}

-- | Converts a Mu server into Servant server
--   by running all Mu handler actions in the `Handler` type.
--   This version assumes /no/ additional routes
--   in the Servant server when compared to Mu's.
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) -- ^ how to turn the inner Mu monad into 'Handler', use 'toHandler' (or a composition with it) in most cases
  -> Mu.Server.ServerT chn () ('Package pname ss) m handlers  -- ^ server to be converted
  -> 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

-- | Converts a Mu server into Servant server
--   by running all Mu handler actions in the `Handler` type.
--   This version should be used when additional
--   routes have been added in the Servant version.
servantServerHandlersExtra ::
  forall pname m chn ss handlers.
  ( ServantServiceHandlers
      ('Package pname ss)
      m
      chn
      ss
      handlers
  )
  => (forall a. m a -> Handler a) -- ^ how to turn the inner Mu monad into 'Handler', use 'toHandler' (or a composition with it) in most cases
  -> Server (ExtraFor ('Package pname ss)) -- ^ additional handler for the extra route
  -> Mu.Server.ServerT chn () ('Package pname ss) m handlers  -- ^ server to be converted
  -> 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

-- | Converts the information from a Mu server
--   into a 'Swagger' document.
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))

-- | Obtains a Servant API 'Proxy' value for use
--   with functions like 'serve' and 'layout'.
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 ()) =
      -- according to https://github.com/haskell-servant/servant/issues/683
      -- we always need a content type for NoContent
      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

-- | represents a single element that will be streamed from the server to the client. That element will either be a `Result` containing a return value, or an `Error` indicating that something went wrong. Without this wrapper, server streams that encountered an error after the response headers have been sent would simply terminate without communicating to the client that anything went wrong.
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

-- converts a conduit sink into a Servant SourceIO for interoperating with server streaming handlers
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
    -- signal that the conduit finished
    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
            -- waiting on this thread should get us sync and async exceptions
            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

-- converts a Servant SourceIO into a conduit for interoperating with client streaming handlers
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))

-- | ServantRoute represents the URL path components of a route. It is used as an `AnnotatedPackage` domain to override the default path for a `Method`. When used in an `AnnService`, the specified `TopLevelRoute` is used as a prefix for all `Method`s in that `Service`.
-- 1. List of components for the route,
-- 2. HTTP method which must be used,
-- 3. HTTP status code of a successful HTTP response from a specific `Method`. Use 200 for the usual status code.
data ServantRoute
  = ServantAdditional Type
  | ServantTopLevelRoute [Symbol]
  | ServantRoute [Symbol] StdMethod Nat

type family Assert (err :: Constraint) (break :: k1) (a :: k2) :: k2 where
  -- these cases exist to force evaluation of the "break" parameter when it either has kind [RpcAnnotation ...] or [Annotation ...]
  Assert _ '[ 'AnnSchema a, 'AnnSchema a ] _ = Any
  Assert _ '[ 'AnnPackage a, 'AnnPackage a ] _ = Any
  -- this case should be used whenever "break" is not stuck
  Assert _ _ a = a

-- a helper type synonym used to provide better errors when a required AnnotatedPackage instance doesn't exist
type WithAnnotatedPackageInstance domain pkg a =
  Assert (NoPackageAnnotations domain pkg) (AnnotatedPackage domain pkg) a

-- a helper type synonym used to provide better errors when a required AnnotatedSchema instance doesn't exist
type WithAnnotatedSchemaInstance domain sch a =
  Assert (NoSchemaAnnotations domain sch) (AnnotatedSchema domain sch) a


-- a helper type family for generating custom error messages about missing AnnotatedPackage instances
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
      )

-- a helper type family for generating custom error messages about missing AnnotatedSchema instances
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
      )

-- used to construct a route for a specific method m of service s in package pkg from the @AnnotatedPackage ServantRoute pkg@ instance, along with a custom error message
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 ExtraFor (pkg :: Package snm mnm anm tyref) :: Type where
  ExtraFor pkg =
    WithAnnotatedPackageInstance ServantRoute pkg
      (UnwrapServantExtra (FromMaybe ('ServantAdditional EmptyAPI) (GetPackageAnnotationMay (AnnotatedPackage ServantRoute pkg))))

type family UnwrapServantExtra s where
  UnwrapServantExtra ('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

-- | ServantContentTypes represents that acceptable content types that can be used when a message in encoded:
-- 1. in a unary (non-streaming) HTTP request\/response body,
-- 2. encoded in a streaming HTTP request\/response body.
-- It is used as an `AnnotatedSchema` domain.
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
      }

-- extracts a StdMethod from a ServantMethod annotation of a given method, defaulting to POST if such an annotation doesn't exist
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

-- extracts the HTTP status code from the ServantStatus annotation of a given method, or defaults to 200 if such an annotation doesn't exist
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

-- extracts a list of content types from a ServantUnaryContentTypes annotation of a given method
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

-- extracts a content type from a ServantStreamContentType annotation of a given method
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

-- extracts a framing from a ServantStreamContentType annotation of a given method
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