{-# LANGUAGE CPP                   #-}

module Servant.Server.Internal
  ( module Servant.Server.Internal
  , module Servant.Server.Internal.BasicAuth
  , module Servant.Server.Internal.Context
  , module Servant.Server.Internal.Delayed
  , module Servant.Server.Internal.DelayedIO
  , module Servant.Server.Internal.ErrorFormatter
  , module Servant.Server.Internal.Handler
  , module Servant.Server.Internal.Router
  , module Servant.Server.Internal.RouteResult
  , module Servant.Server.Internal.RoutingApplication
  , module Servant.Server.Internal.ServerError
  ) where

import           Control.Monad
                 (join, when)
import           Control.Monad.Trans
                 (liftIO, lift)
import           Control.Monad.Trans.Resource
                 (runResourceT, ReleaseKey)
import           Data.Acquire
import qualified Data.ByteString                            as B
import qualified Data.ByteString.Builder                    as BB
import qualified Data.ByteString.Char8                      as BC8
import qualified Data.ByteString.Lazy                       as BSL
import           Data.Constraint (Constraint, Dict(..))
import           Data.Either
                 (partitionEithers)
import           Data.Kind
                 (Type)
import           Data.Maybe
                 (fromMaybe, isNothing, mapMaybe, maybeToList)
import           Data.String
                 (IsString (..))
import           Data.Tagged
                 (Tagged (..), retag, untag)
import qualified Data.Text                                  as T
import           Data.Typeable
import           GHC.Generics
import           GHC.TypeLits (KnownNat, KnownSymbol, TypeError, ErrorMessage (..),  symbolVal)
import qualified Network.HTTP.Media                         as NHM
import           Network.HTTP.Types                         hiding
                 (Header, ResponseHeaders)
import           Network.Socket
                 (SockAddr)
import           Network.Wai
                 (Application, Request, Response, ResponseReceived, httpVersion, isSecure, lazyRequestBody,
                 queryString, remoteHost, getRequestBodyChunk, requestHeaders,
                 requestMethod, responseLBS, responseStream, vault)
import           Servant.API
                 ((:<|>) (..), (:>), Accept (..), BasicAuth, Capture',
                 CaptureAll, DeepQuery, Description, EmptyAPI, Fragment,
                 FramingRender (..), FramingUnrender (..), FromSourceIO (..),
                 Header', If, IsSecure (..), NoContentVerb, QueryFlag,
                 QueryParam', QueryParams, QueryString, Raw, RawM, ReflectMethod (reflectMethod),
                 RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,
                 Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,
                 WithNamedContext, WithResource, NamedRoutes)
import           Servant.API.Generic (GenericMode(..), ToServant, ToServantApi, GServantProduct, toServant, fromServant)
import           Servant.API.ContentTypes
                 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),
                 AllMime, MimeRender (..), MimeUnrender (..), NoContent,
                 canHandleAcceptH)
import           Servant.API.Modifiers
                 (FoldLenient, FoldRequired, RequestArgument,
                 unfoldRequestArgument)
import           Servant.API.QueryString (FromDeepQuery(..))
import           Servant.API.ResponseHeaders
                 (GetHeaders, Headers, getHeaders, getResponse)
import           Servant.API.Status
                 (statusFromNat)
import qualified Servant.Types.SourceT                      as S
import           Servant.API.TypeErrors
import           Web.HttpApiData
                 (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece,
                 parseUrlPieces)

import           Servant.Server.Internal.BasicAuth
import           Servant.Server.Internal.Context
import           Servant.Server.Internal.Delayed
import           Servant.Server.Internal.DelayedIO
import           Servant.Server.Internal.ErrorFormatter
import           Servant.Server.Internal.Handler
import           Servant.Server.Internal.Router
import           Servant.Server.Internal.RouteResult
import           Servant.Server.Internal.RoutingApplication
import           Servant.Server.Internal.ServerError

import           Servant.API.TypeLevel (AtMostOneFragment, FragmentUnique)

class HasServer api context where
  -- | The type of a server for this API, given a monad to run effects in.
  --
  -- Note that the result kind is @*@, so it is /not/ a monad transformer, unlike
  -- what the @T@ in the name might suggest.
  type ServerT api (m :: Type -> Type) :: Type

  route ::
       Proxy api
    -> Context context
    -> Delayed env (Server api)
    -> Router env

  hoistServerWithContext
      :: Proxy api
      -> Proxy context
      -> (forall x. m x -> n x)
      -> ServerT api m
      -> ServerT api n

type Server api = ServerT api Handler

-- * Instances

-- | A server for @a ':<|>' b@ first tries to match the request against the route
--   represented by @a@ and if it fails tries @b@. You must provide a request
--   handler for each route.
--
-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
-- >         :<|> "books" :> ReqBody Book :> Post '[JSON] Book -- POST /books
-- >
-- > server :: Server MyApi
-- > server = listAllBooks :<|> postBook
-- >   where listAllBooks = ...
-- >         postBook book = ...
instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) context where

  type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m

  route :: forall env.
Proxy (a :<|> b)
-> Context context -> Delayed env (Server (a :<|> b)) -> Router env
route Proxy (a :<|> b)
Proxy Context context
context Delayed env (Server (a :<|> b))
server = Router' env RoutingApplication
-> Router' env RoutingApplication -> Router' env RoutingApplication
forall env a. Router' env a -> Router' env a -> Router' env a
choice (Proxy a
-> Context context
-> Delayed env (Server a)
-> Router' env RoutingApplication
forall env.
Proxy a -> Context context -> Delayed env (Server a) -> Router env
forall {k} (api :: k) (context :: [Type]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route Proxy a
pa Context context
context ((\ (Server a
a :<|> ServerT b Handler
_) -> Server a
a) ((Server a :<|> ServerT b Handler) -> Server a)
-> Delayed env (Server a :<|> ServerT b Handler)
-> Delayed env (Server a)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Delayed env (Server a :<|> ServerT b Handler)
Delayed env (Server (a :<|> b))
server))
                                      (Proxy b
-> Context context
-> Delayed env (ServerT b Handler)
-> Router' env RoutingApplication
forall env.
Proxy b
-> Context context -> Delayed env (ServerT b Handler) -> Router env
forall {k} (api :: k) (context :: [Type]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route Proxy b
pb Context context
context ((\ (Server a
_ :<|> ServerT b Handler
b) -> ServerT b Handler
b) ((Server a :<|> ServerT b Handler) -> ServerT b Handler)
-> Delayed env (Server a :<|> ServerT b Handler)
-> Delayed env (ServerT b Handler)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Delayed env (Server a :<|> ServerT b Handler)
Delayed env (Server (a :<|> b))
server))
    where pa :: Proxy a
pa = Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a
          pb :: Proxy b
pb = Proxy b
forall {k} (t :: k). Proxy t
Proxy :: Proxy b

  -- | This is better than 'enter', as it's tailor made for 'HasServer'.
  hoistServerWithContext :: forall (m :: Type -> Type) (n :: Type -> Type).
Proxy (a :<|> b)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (a :<|> b) m
-> ServerT (a :<|> b) n
hoistServerWithContext Proxy (a :<|> b)
_ Proxy context
pc forall x. m x -> n x
nt (ServerT a m
a :<|> ServerT b m
b) =
    Proxy a
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT a m
-> ServerT a n
forall {k} (api :: k) (context :: [Type]) (m :: Type -> Type)
       (n :: Type -> Type).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall (m :: Type -> Type) (n :: Type -> Type).
Proxy a
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT a m
-> ServerT a n
hoistServerWithContext (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a) Proxy context
pc m x -> n x
forall x. m x -> n x
nt ServerT a m
a ServerT a n -> ServerT b n -> ServerT a n :<|> ServerT b n
forall a b. a -> b -> a :<|> b
:<|>
    Proxy b
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT b m
-> ServerT b n
forall {k} (api :: k) (context :: [Type]) (m :: Type -> Type)
       (n :: Type -> Type).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall (m :: Type -> Type) (n :: Type -> Type).
Proxy b
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT b m
-> ServerT b n
hoistServerWithContext (Proxy b
forall {k} (t :: k). Proxy t
Proxy :: Proxy b) Proxy context
pc m x -> n x
forall x. m x -> n x
nt ServerT b m
b

-- | If you use 'Capture' in one of the endpoints for your API,
-- this automatically requires your server-side handler to be a function
-- that takes an argument of the type specified by the 'Capture'.
-- This lets servant worry about getting it from the URL and turning
-- it into a value of the type you specify.
--
-- You can control how it'll be converted from 'Text' to your type
-- by simply providing an instance of 'FromHttpApiData' for your type.
--
-- Example:
--
-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book
-- >
-- > server :: Server MyApi
-- > server = getBook
-- >   where getBook :: Text -> Handler Book
-- >         getBook isbn = ...
instance (KnownSymbol capture, FromHttpApiData a, Typeable a
         , HasServer api context, SBoolI (FoldLenient mods)
         , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
         )
      => HasServer (Capture' mods capture a :> api) context where

  type ServerT (Capture' mods capture a :> api) m =
     If (FoldLenient mods) (Either String a) a -> ServerT api m

  hoistServerWithContext :: forall (m :: Type -> Type) (n :: Type -> Type).
Proxy (Capture' mods capture a :> api)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (Capture' mods capture a :> api) m
-> ServerT (Capture' mods capture a :> api) n
hoistServerWithContext Proxy (Capture' mods capture a :> api)
_ Proxy context
pc forall x. m x -> n x
nt ServerT (Capture' mods capture a :> api) m
s = Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall {k} (api :: k) (context :: [Type]) (m :: Type -> Type)
       (n :: Type -> Type).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall (m :: Type -> Type) (n :: Type -> Type).
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Proxy context
pc m x -> n x
forall x. m x -> n x
nt (ServerT api m -> ServerT api n)
-> (If (FoldLenient mods) (Either String a) a -> ServerT api m)
-> If (FoldLenient mods) (Either String a) a
-> ServerT api n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (Capture' mods capture a :> api) m
If (FoldLenient mods) (Either String a) a -> ServerT api m
s

  route :: forall env.
Proxy (Capture' mods capture a :> api)
-> Context context
-> Delayed env (Server (Capture' mods capture a :> api))
-> Router env
route Proxy (Capture' mods capture a :> api)
Proxy Context context
context Delayed env (Server (Capture' mods capture a :> api))
d =
    [CaptureHint]
-> Router' (Text, env) RoutingApplication
-> Router' env RoutingApplication
forall env a.
[CaptureHint] -> Router' (Text, env) a -> Router' env a
CaptureRouter [CaptureHint
hint] (Router' (Text, env) RoutingApplication
 -> Router' env RoutingApplication)
-> Router' (Text, env) RoutingApplication
-> Router' env RoutingApplication
forall a b. (a -> b) -> a -> b
$
        Proxy api
-> Context context
-> Delayed (Text, env) (Server api)
-> Router' (Text, env) RoutingApplication
forall env.
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
forall {k} (api :: k) (context :: [Type]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api)
              Context context
context
              (Delayed
  env (If (FoldLenient mods) (Either String a) a -> Server api)
-> (Text -> DelayedIO (If (FoldLenient mods) (Either String a) a))
-> Delayed (Text, env) (Server api)
forall env a b captured.
Delayed env (a -> b)
-> (captured -> DelayedIO a) -> Delayed (captured, env) b
addCapture Delayed env (Server (Capture' mods capture a :> api))
Delayed
  env (If (FoldLenient mods) (Either String a) a -> Server api)
d ((Text -> DelayedIO (If (FoldLenient mods) (Either String a) a))
 -> Delayed (Text, env) (Server api))
-> (Text -> DelayedIO (If (FoldLenient mods) (Either String a) a))
-> Delayed (Text, env) (Server api)
forall a b. (a -> b) -> a -> b
$ \ Text
txt -> (Request -> DelayedIO (If (FoldLenient mods) (Either String a) a))
-> DelayedIO (If (FoldLenient mods) (Either String a) a)
forall a. (Request -> DelayedIO a) -> DelayedIO a
withRequest ((Request -> DelayedIO (If (FoldLenient mods) (Either String a) a))
 -> DelayedIO (If (FoldLenient mods) (Either String a) a))
-> (Request
    -> DelayedIO (If (FoldLenient mods) (Either String a) a))
-> DelayedIO (If (FoldLenient mods) (Either String a) a)
forall a b. (a -> b) -> a -> b
$ \ Request
request ->
                case ( SBool (FoldLenient mods)
forall (b :: Bool). SBoolI b => SBool b
sbool :: SBool (FoldLenient mods)
                     , Text -> Either Text a
forall a. FromHttpApiData a => Text -> Either Text a
parseUrlPiece Text
txt :: Either T.Text a) of
                  (SBool (FoldLenient mods)
SFalse, Left Text
e) -> ServerError
-> DelayedIO (If (FoldLenient mods) (Either String a) a)
forall a. ServerError -> DelayedIO a
delayedFail (ServerError
 -> DelayedIO (If (FoldLenient mods) (Either String a) a))
-> ServerError
-> DelayedIO (If (FoldLenient mods) (Either String a) a)
forall a b. (a -> b) -> a -> b
$ ErrorFormatter
formatError TypeRep
rep Request
request (String -> ServerError) -> String -> ServerError
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
e
                  (SBool (FoldLenient mods)
SFalse, Right a
v) -> If (FoldLenient mods) (Either String a) a
-> DelayedIO (If (FoldLenient mods) (Either String a) a)
forall a. a -> DelayedIO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return a
If (FoldLenient mods) (Either String a) a
v
                  (SBool (FoldLenient mods)
STrue, Either Text a
piece) -> If (FoldLenient mods) (Either String a) a
-> DelayedIO (If (FoldLenient mods) (Either String a) a)
forall a. a -> DelayedIO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (If (FoldLenient mods) (Either String a) a
 -> DelayedIO (If (FoldLenient mods) (Either String a) a))
-> If (FoldLenient mods) (Either String a) a
-> DelayedIO (If (FoldLenient mods) (Either String a) a)
forall a b. (a -> b) -> a -> b
$ (Text -> If (FoldLenient mods) (Either String a) a)
-> (a -> If (FoldLenient mods) (Either String a) a)
-> Either Text a
-> If (FoldLenient mods) (Either String a) a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Either String a
String -> If (FoldLenient mods) (Either String a) a
forall a b. a -> Either a b
Left (String -> If (FoldLenient mods) (Either String a) a)
-> (Text -> String)
-> Text
-> If (FoldLenient mods) (Either String a) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) a -> Either String a
a -> If (FoldLenient mods) (Either String a) a
forall a b. b -> Either a b
Right Either Text a
piece)
    where
      rep :: TypeRep
rep = Proxy Capture' -> TypeRep
forall {k} (proxy :: k -> Type) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy Capture'
forall {k} (t :: k). Proxy t
Proxy :: Proxy Capture')
      formatError :: ErrorFormatter
formatError = ErrorFormatters -> ErrorFormatter
urlParseErrorFormatter (ErrorFormatters -> ErrorFormatter)
-> ErrorFormatters -> ErrorFormatter
forall a b. (a -> b) -> a -> b
$ Context (MkContextWithErrorFormatter context) -> ErrorFormatters
forall (context :: [Type]) val.
HasContextEntry context val =>
Context context -> val
getContextEntry (Context context -> Context (MkContextWithErrorFormatter context)
forall (ctx :: [Type]).
Context ctx -> Context (MkContextWithErrorFormatter ctx)
mkContextWithErrorFormatter Context context
context)
      hint :: CaptureHint
hint = Text -> TypeRep -> CaptureHint
CaptureHint (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy capture -> String
forall (n :: Symbol) (proxy :: Symbol -> Type).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy capture -> String) -> Proxy capture -> String
forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @capture) (Proxy a -> TypeRep
forall {k} (proxy :: k -> Type) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a))

-- | If you use 'CaptureAll' in one of the endpoints for your API,
-- this automatically requires your server-side handler to be a
-- function that takes an argument of a list of the type specified by
-- the 'CaptureAll'. This lets servant worry about getting values from
-- the URL and turning them into values of the type you specify.
--
-- You can control how they'll be converted from 'Text' to your type
-- by simply providing an instance of 'FromHttpApiData' for your type.
--
-- Example:
--
-- > type MyApi = "src" :> CaptureAll "segments" Text :> Get '[JSON] SourceFile
-- >
-- > server :: Server MyApi
-- > server = getSourceFile
-- >   where getSourceFile :: [Text] -> Handler Book
-- >         getSourceFile pathSegments = ...
instance (KnownSymbol capture, FromHttpApiData a, Typeable a
         , HasServer api context
         , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
         )
      => HasServer (CaptureAll capture a :> api) context where

  type ServerT (CaptureAll capture a :> api) m =
    [a] -> ServerT api m

  hoistServerWithContext :: forall (m :: Type -> Type) (n :: Type -> Type).
Proxy (CaptureAll capture a :> api)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (CaptureAll capture a :> api) m
-> ServerT (CaptureAll capture a :> api) n
hoistServerWithContext Proxy (CaptureAll capture a :> api)
_ Proxy context
pc forall x. m x -> n x
nt ServerT (CaptureAll capture a :> api) m
s = Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall {k} (api :: k) (context :: [Type]) (m :: Type -> Type)
       (n :: Type -> Type).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall (m :: Type -> Type) (n :: Type -> Type).
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Proxy context
pc m x -> n x
forall x. m x -> n x
nt (ServerT api m -> ServerT api n)
-> ([a] -> ServerT api m) -> [a] -> ServerT api n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (CaptureAll capture a :> api) m
[a] -> ServerT api m
s

  route :: forall env.
Proxy (CaptureAll capture a :> api)
-> Context context
-> Delayed env (Server (CaptureAll capture a :> api))
-> Router env
route Proxy (CaptureAll capture a :> api)
Proxy Context context
context Delayed env (Server (CaptureAll capture a :> api))
d =
    [CaptureHint]
-> Router' ([Text], env) RoutingApplication
-> Router' env RoutingApplication
forall env a.
[CaptureHint] -> Router' ([Text], env) a -> Router' env a
CaptureAllRouter [CaptureHint
hint] (Router' ([Text], env) RoutingApplication
 -> Router' env RoutingApplication)
-> Router' ([Text], env) RoutingApplication
-> Router' env RoutingApplication
forall a b. (a -> b) -> a -> b
$
        Proxy api
-> Context context
-> Delayed ([Text], env) (Server api)
-> Router' ([Text], env) RoutingApplication
forall env.
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
forall {k} (api :: k) (context :: [Type]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api)
              Context context
context
              (Delayed env ([a] -> Server api)
-> ([Text] -> DelayedIO [a]) -> Delayed ([Text], env) (Server api)
forall env a b captured.
Delayed env (a -> b)
-> (captured -> DelayedIO a) -> Delayed (captured, env) b
addCapture Delayed env (Server (CaptureAll capture a :> api))
Delayed env ([a] -> Server api)
d (([Text] -> DelayedIO [a]) -> Delayed ([Text], env) (Server api))
-> ([Text] -> DelayedIO [a]) -> Delayed ([Text], env) (Server api)
forall a b. (a -> b) -> a -> b
$ \ [Text]
txts -> (Request -> DelayedIO [a]) -> DelayedIO [a]
forall a. (Request -> DelayedIO a) -> DelayedIO a
withRequest ((Request -> DelayedIO [a]) -> DelayedIO [a])
-> (Request -> DelayedIO [a]) -> DelayedIO [a]
forall a b. (a -> b) -> a -> b
$ \ Request
request ->
                case [Text] -> Either Text [a]
forall (t :: Type -> Type) a.
(Traversable t, FromHttpApiData a) =>
t Text -> Either Text (t a)
parseUrlPieces [Text]
txts of
                   Left Text
e  -> ServerError -> DelayedIO [a]
forall a. ServerError -> DelayedIO a
delayedFail (ServerError -> DelayedIO [a]) -> ServerError -> DelayedIO [a]
forall a b. (a -> b) -> a -> b
$ ErrorFormatter
formatError TypeRep
rep Request
request (String -> ServerError) -> String -> ServerError
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
e
                   Right [a]
v -> [a] -> DelayedIO [a]
forall a. a -> DelayedIO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return [a]
v
              )
    where
      rep :: TypeRep
rep = Proxy CaptureAll -> TypeRep
forall {k} (proxy :: k -> Type) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy CaptureAll
forall {k} (t :: k). Proxy t
Proxy :: Proxy CaptureAll)
      formatError :: ErrorFormatter
formatError = ErrorFormatters -> ErrorFormatter
urlParseErrorFormatter (ErrorFormatters -> ErrorFormatter)
-> ErrorFormatters -> ErrorFormatter
forall a b. (a -> b) -> a -> b
$ Context (MkContextWithErrorFormatter context) -> ErrorFormatters
forall (context :: [Type]) val.
HasContextEntry context val =>
Context context -> val
getContextEntry (Context context -> Context (MkContextWithErrorFormatter context)
forall (ctx :: [Type]).
Context ctx -> Context (MkContextWithErrorFormatter ctx)
mkContextWithErrorFormatter Context context
context)
      hint :: CaptureHint
hint = Text -> TypeRep -> CaptureHint
CaptureHint (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy capture -> String
forall (n :: Symbol) (proxy :: Symbol -> Type).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy capture -> String) -> Proxy capture -> String
forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @capture) (Proxy [a] -> TypeRep
forall {k} (proxy :: k -> Type) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy [a]
forall {k} (t :: k). Proxy t
Proxy :: Proxy [a]))

-- | If you use 'WithResource' in one of the endpoints for your API Servant
-- will provide the handler for this endpoint an argument of the specified type.
-- The lifespan of this resource will be automatically managed by Servant. This
-- resource will be created before the handler starts and it will be destoyed
-- after it ends. A new resource is created for each request to the endpoint.

-- The creation and destruction are done using a 'Data.Acquire.Acquire'
-- provided via server 'Context'.
--
-- Example
--
-- > type MyApi = WithResource Handle :> "writeToFile" :> Post '[JSON] NoContent
-- >
-- > server :: Server MyApi
-- > server = writeToFile
-- >   where writeToFile :: (ReleaseKey, Handle) -> Handler NoContent
-- >         writeToFile (_, h) = hPutStrLn h "message"
--
-- In addition to the resource, the handler will also receive a 'ReleaseKey'
-- which can be used to deallocate the resource before the end of the request
-- if desired.

instance (HasServer api ctx, HasContextEntry ctx (Acquire a))
      => HasServer (WithResource a :> api) ctx where

  type ServerT (WithResource a :> api) m = (ReleaseKey, a) -> ServerT api m

  hoistServerWithContext :: forall (m :: Type -> Type) (n :: Type -> Type).
Proxy (WithResource a :> api)
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT (WithResource a :> api) m
-> ServerT (WithResource a :> api) n
hoistServerWithContext Proxy (WithResource a :> api)
_ Proxy ctx
pc forall x. m x -> n x
nt ServerT (WithResource a :> api) m
s = Proxy api
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall {k} (api :: k) (context :: [Type]) (m :: Type -> Type)
       (n :: Type -> Type).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall (m :: Type -> Type) (n :: Type -> Type).
Proxy api
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api) Proxy ctx
pc m x -> n x
forall x. m x -> n x
nt (ServerT api m -> ServerT api n)
-> ((ReleaseKey, a) -> ServerT api m)
-> (ReleaseKey, a)
-> ServerT api n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (WithResource a :> api) m
(ReleaseKey, a) -> ServerT api m
s

  route :: forall env.
Proxy (WithResource a :> api)
-> Context ctx
-> Delayed env (Server (WithResource a :> api))
-> Router env
route Proxy (WithResource a :> api)
Proxy Context ctx
context Delayed env (Server (WithResource a :> api))
d = Proxy api -> Context ctx -> Delayed env (Server api) -> Router env
forall env.
Proxy api -> Context ctx -> Delayed env (Server api) -> Router env
forall {k} (api :: k) (context :: [Type]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api) Context ctx
context (Delayed env (Server (WithResource a :> api))
Delayed env ((ReleaseKey, a) -> Server api)
d Delayed env ((ReleaseKey, a) -> Server api)
-> DelayedIO (ReleaseKey, a) -> Delayed env (Server api)
forall env a b.
Delayed env (a -> b) -> DelayedIO a -> Delayed env b
`addParameterCheck` DelayedIO (ReleaseKey, a)
allocateResource)
    where
      allocateResource :: DelayedIO (ReleaseKey, a)
      allocateResource :: DelayedIO (ReleaseKey, a)
allocateResource = ReaderT Request (ResourceT (RouteResultT IO)) (ReleaseKey, a)
-> DelayedIO (ReleaseKey, a)
forall a.
ReaderT Request (ResourceT (RouteResultT IO)) a -> DelayedIO a
DelayedIO (ReaderT Request (ResourceT (RouteResultT IO)) (ReleaseKey, a)
 -> DelayedIO (ReleaseKey, a))
-> ReaderT Request (ResourceT (RouteResultT IO)) (ReleaseKey, a)
-> DelayedIO (ReleaseKey, a)
forall a b. (a -> b) -> a -> b
$ ResourceT (RouteResultT IO) (ReleaseKey, a)
-> ReaderT Request (ResourceT (RouteResultT IO)) (ReleaseKey, a)
forall (m :: Type -> Type) a. Monad m => m a -> ReaderT Request m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ResourceT (RouteResultT IO) (ReleaseKey, a)
 -> ReaderT Request (ResourceT (RouteResultT IO)) (ReleaseKey, a))
-> ResourceT (RouteResultT IO) (ReleaseKey, a)
-> ReaderT Request (ResourceT (RouteResultT IO)) (ReleaseKey, a)
forall a b. (a -> b) -> a -> b
$ Acquire a -> ResourceT (RouteResultT IO) (ReleaseKey, a)
forall (m :: Type -> Type) a.
MonadResource m =>
Acquire a -> m (ReleaseKey, a)
allocateAcquire (Context ctx -> Acquire a
forall (context :: [Type]) val.
HasContextEntry context val =>
Context context -> val
getContextEntry Context ctx
context)



allowedMethodHead :: Method -> Request -> Bool
allowedMethodHead :: ByteString -> Request -> Bool
allowedMethodHead ByteString
method Request
request = ByteString
method ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
methodGet Bool -> Bool -> Bool
&& Request -> ByteString
requestMethod Request
request ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
methodHead

allowedMethod :: Method -> Request -> Bool
allowedMethod :: ByteString -> Request -> Bool
allowedMethod ByteString
method Request
request = ByteString -> Request -> Bool
allowedMethodHead ByteString
method Request
request Bool -> Bool -> Bool
|| Request -> ByteString
requestMethod Request
request ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
method

methodCheck :: Method -> Request -> DelayedIO ()
methodCheck :: ByteString -> Request -> DelayedIO ()
methodCheck ByteString
method Request
request
  | ByteString -> Request -> Bool
allowedMethod ByteString
method Request
request = () -> DelayedIO ()
forall a. a -> DelayedIO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
  | Bool
otherwise                    = ServerError -> DelayedIO ()
forall a. ServerError -> DelayedIO a
delayedFail ServerError
err405

-- This has switched between using 'Fail' and 'FailFatal' a number of
-- times. If the 'acceptCheck' is run after the body check (which would
-- be morally right), then we have to set this to 'FailFatal', because
-- the body check is not reversible, and therefore backtracking after the
-- body check is no longer an option. However, we now run the accept
-- check before the body check and can therefore afford to make it
-- recoverable.
acceptCheck :: (AllMime list) => Proxy list -> AcceptHeader -> DelayedIO ()
acceptCheck :: forall (list :: [Type]).
AllMime list =>
Proxy list -> AcceptHeader -> DelayedIO ()
acceptCheck Proxy list
proxy AcceptHeader
accH
  | Proxy list -> AcceptHeader -> Bool
forall (list :: [Type]).
AllMime list =>
Proxy list -> AcceptHeader -> Bool
canHandleAcceptH Proxy list
proxy AcceptHeader
accH = () -> DelayedIO ()
forall a. a -> DelayedIO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
  | Bool
otherwise                   = ServerError -> DelayedIO ()
forall a. ServerError -> DelayedIO a
delayedFail ServerError
err406

methodRouter :: (AllCTRender ctypes a)
             => (b -> ([(HeaderName, B.ByteString)], a))
             -> Method -> Proxy ctypes -> Status
             -> Delayed env (Handler b)
             -> Router env
methodRouter :: forall (ctypes :: [Type]) a b env.
AllCTRender ctypes a =>
(b -> ([(HeaderName, ByteString)], a))
-> ByteString
-> Proxy ctypes
-> Status
-> Delayed env (Handler b)
-> Router env
methodRouter b -> ([(HeaderName, ByteString)], a)
splitHeaders ByteString
method Proxy ctypes
proxy Status
status Delayed env (Handler b)
action = (env -> RoutingApplication) -> Router' env RoutingApplication
forall env a. (env -> a) -> Router' env a
leafRouter env -> RoutingApplication
route'
  where
    route' :: env -> RoutingApplication
route' env
env Request
request RouteResult Response -> IO ResponseReceived
respond =
          let accH :: AcceptHeader
accH = Request -> AcceptHeader
getAcceptHeader Request
request
          in Delayed env (Handler b)
-> env
-> Request
-> (RouteResult Response -> IO ResponseReceived)
-> (b -> RouteResult Response)
-> IO ResponseReceived
forall env a r.
Delayed env (Handler a)
-> env
-> Request
-> (RouteResult Response -> IO r)
-> (a -> RouteResult Response)
-> IO r
runAction (Delayed env (Handler b)
action Delayed env (Handler b) -> DelayedIO () -> Delayed env (Handler b)
forall env a. Delayed env a -> DelayedIO () -> Delayed env a
`addMethodCheck` ByteString -> Request -> DelayedIO ()
methodCheck ByteString
method Request
request
                               Delayed env (Handler b) -> DelayedIO () -> Delayed env (Handler b)
forall env a. Delayed env a -> DelayedIO () -> Delayed env a
`addAcceptCheck` Proxy ctypes -> AcceptHeader -> DelayedIO ()
forall (list :: [Type]).
AllMime list =>
Proxy list -> AcceptHeader -> DelayedIO ()
acceptCheck Proxy ctypes
proxy AcceptHeader
accH
                       ) env
env Request
request RouteResult Response -> IO ResponseReceived
respond ((b -> RouteResult Response) -> IO ResponseReceived)
-> (b -> RouteResult Response) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \ b
output -> do
               let ([(HeaderName, ByteString)]
headers, a
b) = b -> ([(HeaderName, ByteString)], a)
splitHeaders b
output
               case Proxy ctypes -> AcceptHeader -> a -> Maybe (ByteString, ByteString)
forall (list :: [Type]) a.
AllCTRender list a =>
Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)
handleAcceptH Proxy ctypes
proxy AcceptHeader
accH a
b of
                 Maybe (ByteString, ByteString)
Nothing -> ServerError -> RouteResult Response
forall a. ServerError -> RouteResult a
FailFatal ServerError
err406 -- this should not happen (checked before), so we make it fatal if it does
                 Just (ByteString
contentT, ByteString
body) ->
                      let bdy :: ByteString
bdy = if ByteString -> Request -> Bool
allowedMethodHead ByteString
method Request
request then ByteString
"" else ByteString
body
                      in Response -> RouteResult Response
forall a. a -> RouteResult a
Route (Response -> RouteResult Response)
-> Response -> RouteResult Response
forall a b. (a -> b) -> a -> b
$ Status -> [(HeaderName, ByteString)] -> ByteString -> Response
responseLBS Status
status ((HeaderName
hContentType, ByteString -> ByteString
BSL.toStrict ByteString
contentT) (HeaderName, ByteString)
-> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
forall a. a -> [a] -> [a]
: [(HeaderName, ByteString)]
headers) ByteString
bdy

noContentRouter :: Method
             -> Status
             -> Delayed env (Handler b)
             -> Router env
noContentRouter :: forall env b.
ByteString -> Status -> Delayed env (Handler b) -> Router env
noContentRouter ByteString
method Status
status Delayed env (Handler b)
action = (env -> RoutingApplication) -> Router' env RoutingApplication
forall env a. (env -> a) -> Router' env a
leafRouter env -> RoutingApplication
route'
  where
    route' :: env -> RoutingApplication
route' env
env Request
request RouteResult Response -> IO ResponseReceived
respond =
          Delayed env (Handler b)
-> env
-> Request
-> (RouteResult Response -> IO ResponseReceived)
-> (b -> RouteResult Response)
-> IO ResponseReceived
forall env a r.
Delayed env (Handler a)
-> env
-> Request
-> (RouteResult Response -> IO r)
-> (a -> RouteResult Response)
-> IO r
runAction (Delayed env (Handler b)
action Delayed env (Handler b) -> DelayedIO () -> Delayed env (Handler b)
forall env a. Delayed env a -> DelayedIO () -> Delayed env a
`addMethodCheck` ByteString -> Request -> DelayedIO ()
methodCheck ByteString
method Request
request)
                    env
env Request
request RouteResult Response -> IO ResponseReceived
respond ((b -> RouteResult Response) -> IO ResponseReceived)
-> (b -> RouteResult Response) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \ b
_output ->
                      Response -> RouteResult Response
forall a. a -> RouteResult a
Route (Response -> RouteResult Response)
-> Response -> RouteResult Response
forall a b. (a -> b) -> a -> b
$ Status -> [(HeaderName, ByteString)] -> ByteString -> Response
responseLBS Status
status [] ByteString
""

instance {-# OVERLAPPABLE #-}
         ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
         ) => HasServer (Verb method status ctypes a) context where

  type ServerT (Verb method status ctypes a) m = m a
  hoistServerWithContext :: forall (m :: Type -> Type) (n :: Type -> Type).
Proxy (Verb method status ctypes a)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (Verb method status ctypes a) m
-> ServerT (Verb method status ctypes a) n
hoistServerWithContext Proxy (Verb method status ctypes a)
_ Proxy context
_ forall x. m x -> n x
nt ServerT (Verb method status ctypes a) m
s = m a -> n a
forall x. m x -> n x
nt m a
ServerT (Verb method status ctypes a) m
s

  route :: forall env.
Proxy (Verb method status ctypes a)
-> Context context
-> Delayed env (Server (Verb method status ctypes a))
-> Router env
route Proxy (Verb method status ctypes a)
Proxy Context context
_ = (a -> ([(HeaderName, ByteString)], a))
-> ByteString
-> Proxy ctypes
-> Status
-> Delayed env (Handler a)
-> Router' env RoutingApplication
forall (ctypes :: [Type]) a b env.
AllCTRender ctypes a =>
(b -> ([(HeaderName, ByteString)], a))
-> ByteString
-> Proxy ctypes
-> Status
-> Delayed env (Handler b)
-> Router env
methodRouter ([],) ByteString
method (Proxy ctypes
forall {k} (t :: k). Proxy t
Proxy :: Proxy ctypes) Status
status
    where method :: ByteString
method = Proxy method -> ByteString
forall {k} (a :: k). ReflectMethod a => Proxy a -> ByteString
reflectMethod (Proxy method
forall {k} (t :: k). Proxy t
Proxy :: Proxy method)
          status :: Status
status = Proxy status -> Status
forall (a :: Nat) (proxy :: Nat -> Type).
KnownNat a =>
proxy a -> Status
statusFromNat (Proxy status
forall {k} (t :: k). Proxy t
Proxy :: Proxy status)

instance {-# OVERLAPPING #-}
         ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
         , GetHeaders (Headers h a)
         ) => HasServer (Verb method status ctypes (Headers h a)) context where

  type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a)
  hoistServerWithContext :: forall (m :: Type -> Type) (n :: Type -> Type).
Proxy (Verb method status ctypes (Headers h a))
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (Verb method status ctypes (Headers h a)) m
-> ServerT (Verb method status ctypes (Headers h a)) n
hoistServerWithContext Proxy (Verb method status ctypes (Headers h a))
_ Proxy context
_ forall x. m x -> n x
nt ServerT (Verb method status ctypes (Headers h a)) m
s = m (Headers h a) -> n (Headers h a)
forall x. m x -> n x
nt m (Headers h a)
ServerT (Verb method status ctypes (Headers h a)) m
s

  route :: forall env.
Proxy (Verb method status ctypes (Headers h a))
-> Context context
-> Delayed env (Server (Verb method status ctypes (Headers h a)))
-> Router env
route Proxy (Verb method status ctypes (Headers h a))
Proxy Context context
_ = (Headers h a -> ([(HeaderName, ByteString)], a))
-> ByteString
-> Proxy ctypes
-> Status
-> Delayed env (Handler (Headers h a))
-> Router' env RoutingApplication
forall (ctypes :: [Type]) a b env.
AllCTRender ctypes a =>
(b -> ([(HeaderName, ByteString)], a))
-> ByteString
-> Proxy ctypes
-> Status
-> Delayed env (Handler b)
-> Router env
methodRouter (\Headers h a
x -> (Headers h a -> [(HeaderName, ByteString)]
forall ls. GetHeaders ls => ls -> [(HeaderName, ByteString)]
getHeaders Headers h a
x, Headers h a -> a
forall (ls :: [Type]) a. Headers ls a -> a
getResponse Headers h a
x)) ByteString
method (Proxy ctypes
forall {k} (t :: k). Proxy t
Proxy :: Proxy ctypes) Status
status
    where method :: ByteString
method = Proxy method -> ByteString
forall {k} (a :: k). ReflectMethod a => Proxy a -> ByteString
reflectMethod (Proxy method
forall {k} (t :: k). Proxy t
Proxy :: Proxy method)
          status :: Status
status = Proxy status -> Status
forall (a :: Nat) (proxy :: Nat -> Type).
KnownNat a =>
proxy a -> Status
statusFromNat (Proxy status
forall {k} (t :: k). Proxy t
Proxy :: Proxy status)

instance (ReflectMethod method) =>
         HasServer (NoContentVerb method) context where

  type ServerT (NoContentVerb method) m = m NoContent
  hoistServerWithContext :: forall (m :: Type -> Type) (n :: Type -> Type).
Proxy (NoContentVerb method)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (NoContentVerb method) m
-> ServerT (NoContentVerb method) n
hoistServerWithContext Proxy (NoContentVerb method)
_ Proxy context
_ forall x. m x -> n x
nt ServerT (NoContentVerb method) m
s = m NoContent -> n NoContent
forall x. m x -> n x
nt m NoContent
ServerT (NoContentVerb method) m
s

  route :: forall env.
Proxy (NoContentVerb method)
-> Context context
-> Delayed env (Server (NoContentVerb method))
-> Router env
route Proxy (NoContentVerb method)
Proxy Context context
_ = ByteString
-> Status
-> Delayed env (Handler NoContent)
-> Router' env RoutingApplication
forall env b.
ByteString -> Status -> Delayed env (Handler b) -> Router env
noContentRouter ByteString
method Status
status204
    where method :: ByteString
method = Proxy method -> ByteString
forall {k} (a :: k). ReflectMethod a => Proxy a -> ByteString
reflectMethod (Proxy method
forall {k} (t :: k). Proxy t
Proxy :: Proxy method)

instance {-# OVERLAPPABLE #-}
         ( MimeRender ctype chunk, ReflectMethod method, KnownNat status,
           FramingRender framing, ToSourceIO chunk a
         ) => HasServer (Stream method status framing ctype a) context where

  type ServerT (Stream method status framing ctype a) m = m a
  hoistServerWithContext :: forall (m :: Type -> Type) (n :: Type -> Type).
Proxy (Stream method status framing ctype a)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (Stream method status framing ctype a) m
-> ServerT (Stream method status framing ctype a) n
hoistServerWithContext Proxy (Stream method status framing ctype a)
_ Proxy context
_ forall x. m x -> n x
nt ServerT (Stream method status framing ctype a) m
s = m a -> n a
forall x. m x -> n x
nt m a
ServerT (Stream method status framing ctype a) m
s

  route :: forall env.
Proxy (Stream method status framing ctype a)
-> Context context
-> Delayed env (Server (Stream method status framing ctype a))
-> Router env
route Proxy (Stream method status framing ctype a)
Proxy Context context
_ = (a -> ([(HeaderName, ByteString)], a))
-> ByteString
-> Status
-> Proxy framing
-> Proxy ctype
-> Delayed env (Handler a)
-> Router' env RoutingApplication
forall {k} {k} (ctype :: k) a c chunk env (framing :: k).
(MimeRender ctype chunk, FramingRender framing,
 ToSourceIO chunk a) =>
(c -> ([(HeaderName, ByteString)], a))
-> ByteString
-> Status
-> Proxy framing
-> Proxy ctype
-> Delayed env (Handler c)
-> Router env
streamRouter ([],) ByteString
method Status
status (Proxy framing
forall {k} (t :: k). Proxy t
Proxy :: Proxy framing) (Proxy ctype
forall {k} (t :: k). Proxy t
Proxy :: Proxy ctype)
      where method :: ByteString
method = Proxy method -> ByteString
forall {k} (a :: k). ReflectMethod a => Proxy a -> ByteString
reflectMethod (Proxy method
forall {k} (t :: k). Proxy t
Proxy :: Proxy method)
            status :: Status
status = Proxy status -> Status
forall (a :: Nat) (proxy :: Nat -> Type).
KnownNat a =>
proxy a -> Status
statusFromNat (Proxy status
forall {k} (t :: k). Proxy t
Proxy :: Proxy status)


instance {-# OVERLAPPING #-}
         ( MimeRender ctype chunk, ReflectMethod method, KnownNat status,
           FramingRender framing, ToSourceIO chunk a,
           GetHeaders (Headers h a)
         ) => HasServer (Stream method status framing ctype (Headers h a)) context where

  type ServerT (Stream method status framing ctype (Headers h a)) m = m (Headers h a)
  hoistServerWithContext :: forall (m :: Type -> Type) (n :: Type -> Type).
Proxy (Stream method status framing ctype (Headers h a))
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (Stream method status framing ctype (Headers h a)) m
-> ServerT (Stream method status framing ctype (Headers h a)) n
hoistServerWithContext Proxy (Stream method status framing ctype (Headers h a))
_ Proxy context
_ forall x. m x -> n x
nt ServerT (Stream method status framing ctype (Headers h a)) m
s = m (Headers h a) -> n (Headers h a)
forall x. m x -> n x
nt m (Headers h a)
ServerT (Stream method status framing ctype (Headers h a)) m
s

  route :: forall env.
Proxy (Stream method status framing ctype (Headers h a))
-> Context context
-> Delayed
     env (Server (Stream method status framing ctype (Headers h a)))
-> Router env
route Proxy (Stream method status framing ctype (Headers h a))
Proxy Context context
_ = (Headers h a -> ([(HeaderName, ByteString)], a))
-> ByteString
-> Status
-> Proxy framing
-> Proxy ctype
-> Delayed env (Handler (Headers h a))
-> Router' env RoutingApplication
forall {k} {k} (ctype :: k) a c chunk env (framing :: k).
(MimeRender ctype chunk, FramingRender framing,
 ToSourceIO chunk a) =>
(c -> ([(HeaderName, ByteString)], a))
-> ByteString
-> Status
-> Proxy framing
-> Proxy ctype
-> Delayed env (Handler c)
-> Router env
streamRouter (\Headers h a
x -> (Headers h a -> [(HeaderName, ByteString)]
forall ls. GetHeaders ls => ls -> [(HeaderName, ByteString)]
getHeaders Headers h a
x, Headers h a -> a
forall (ls :: [Type]) a. Headers ls a -> a
getResponse Headers h a
x)) ByteString
method Status
status (Proxy framing
forall {k} (t :: k). Proxy t
Proxy :: Proxy framing) (Proxy ctype
forall {k} (t :: k). Proxy t
Proxy :: Proxy ctype)
      where method :: ByteString
method = Proxy method -> ByteString
forall {k} (a :: k). ReflectMethod a => Proxy a -> ByteString
reflectMethod (Proxy method
forall {k} (t :: k). Proxy t
Proxy :: Proxy method)
            status :: Status
status = Proxy status -> Status
forall (a :: Nat) (proxy :: Nat -> Type).
KnownNat a =>
proxy a -> Status
statusFromNat (Proxy status
forall {k} (t :: k). Proxy t
Proxy :: Proxy status)


streamRouter :: forall ctype a c chunk env framing. (MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a) =>
                (c -> ([(HeaderName, B.ByteString)], a))
             -> Method
             -> Status
             -> Proxy framing
             -> Proxy ctype
             -> Delayed env (Handler c)
             -> Router env
streamRouter :: forall {k} {k} (ctype :: k) a c chunk env (framing :: k).
(MimeRender ctype chunk, FramingRender framing,
 ToSourceIO chunk a) =>
(c -> ([(HeaderName, ByteString)], a))
-> ByteString
-> Status
-> Proxy framing
-> Proxy ctype
-> Delayed env (Handler c)
-> Router env
streamRouter c -> ([(HeaderName, ByteString)], a)
splitHeaders ByteString
method Status
status Proxy framing
framingproxy Proxy ctype
ctypeproxy Delayed env (Handler c)
action = (env -> RoutingApplication) -> Router' env RoutingApplication
forall env a. (env -> a) -> Router' env a
leafRouter ((env -> RoutingApplication) -> Router' env RoutingApplication)
-> (env -> RoutingApplication) -> Router' env RoutingApplication
forall a b. (a -> b) -> a -> b
$ \env
env Request
request RouteResult Response -> IO ResponseReceived
respond ->
          let AcceptHeader ByteString
accH = Request -> AcceptHeader
getAcceptHeader Request
request
              cmediatype :: Maybe MediaType
cmediatype = [MediaType] -> ByteString -> Maybe MediaType
forall a. Accept a => [a] -> ByteString -> Maybe a
NHM.matchAccept [Proxy ctype -> MediaType
forall {k} (ctype :: k). Accept ctype => Proxy ctype -> MediaType
contentType Proxy ctype
ctypeproxy] ByteString
accH
              accCheck :: DelayedIO ()
accCheck = Bool -> DelayedIO () -> DelayedIO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Maybe MediaType -> Bool
forall a. Maybe a -> Bool
isNothing Maybe MediaType
cmediatype) (DelayedIO () -> DelayedIO ()) -> DelayedIO () -> DelayedIO ()
forall a b. (a -> b) -> a -> b
$ ServerError -> DelayedIO ()
forall a. ServerError -> DelayedIO a
delayedFail ServerError
err406
              contentHeader :: (HeaderName, ByteString)
contentHeader = (HeaderName
hContentType, [MediaType] -> ByteString
forall h. RenderHeader h => h -> ByteString
NHM.renderHeader ([MediaType] -> ByteString)
-> (Maybe MediaType -> [MediaType])
-> Maybe MediaType
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe MediaType -> [MediaType]
forall a. Maybe a -> [a]
maybeToList (Maybe MediaType -> ByteString) -> Maybe MediaType -> ByteString
forall a b. (a -> b) -> a -> b
$ Maybe MediaType
cmediatype)
          in Delayed env (Handler c)
-> env
-> Request
-> (RouteResult Response -> IO ResponseReceived)
-> (c -> RouteResult Response)
-> IO ResponseReceived
forall env a r.
Delayed env (Handler a)
-> env
-> Request
-> (RouteResult Response -> IO r)
-> (a -> RouteResult Response)
-> IO r
runAction (Delayed env (Handler c)
action Delayed env (Handler c) -> DelayedIO () -> Delayed env (Handler c)
forall env a. Delayed env a -> DelayedIO () -> Delayed env a
`addMethodCheck` ByteString -> Request -> DelayedIO ()
methodCheck ByteString
method Request
request
                               Delayed env (Handler c) -> DelayedIO () -> Delayed env (Handler c)
forall env a. Delayed env a -> DelayedIO () -> Delayed env a
`addAcceptCheck` DelayedIO ()
accCheck
                       ) env
env Request
request RouteResult Response -> IO ResponseReceived
respond ((c -> RouteResult Response) -> IO ResponseReceived)
-> (c -> RouteResult Response) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \ c
output ->
                let ([(HeaderName, ByteString)]
headers, a
fa) = c -> ([(HeaderName, ByteString)], a)
splitHeaders c
output
                    sourceT :: SourceIO chunk
sourceT = a -> SourceIO chunk
forall chunk a. ToSourceIO chunk a => a -> SourceIO chunk
toSourceIO a
fa
                    S.SourceT forall b. (StepT IO ByteString -> IO b) -> IO b
kStepLBS = Proxy framing
-> (chunk -> ByteString) -> SourceIO chunk -> SourceT IO ByteString
forall {k} (strategy :: k) (m :: Type -> Type) a.
(FramingRender strategy, Monad m) =>
Proxy strategy
-> (a -> ByteString) -> SourceT m a -> SourceT m ByteString
forall (m :: Type -> Type) a.
Monad m =>
Proxy framing
-> (a -> ByteString) -> SourceT m a -> SourceT m ByteString
framingRender Proxy framing
framingproxy (Proxy ctype -> chunk -> ByteString
forall {k} (ctype :: k) a.
MimeRender ctype a =>
Proxy ctype -> a -> ByteString
mimeRender Proxy ctype
ctypeproxy :: chunk -> BSL.ByteString) SourceIO chunk
sourceT
                in Response -> RouteResult Response
forall a. a -> RouteResult a
Route (Response -> RouteResult Response)
-> Response -> RouteResult Response
forall a b. (a -> b) -> a -> b
$ Status -> [(HeaderName, ByteString)] -> StreamingBody -> Response
responseStream Status
status ((HeaderName, ByteString)
contentHeader (HeaderName, ByteString)
-> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
forall a. a -> [a] -> [a]
: [(HeaderName, ByteString)]
headers) (StreamingBody -> Response) -> StreamingBody -> Response
forall a b. (a -> b) -> a -> b
$ \Builder -> IO ()
write IO ()
flush -> do
                    let loop :: StepT IO ByteString -> IO ()
loop StepT IO ByteString
S.Stop          = IO ()
flush
                        loop (S.Error String
err)   = String -> IO ()
forall a. String -> IO a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
err -- TODO: throw better error
                        loop (S.Skip StepT IO ByteString
s)      = StepT IO ByteString -> IO ()
loop StepT IO ByteString
s
                        loop (S.Effect IO (StepT IO ByteString)
ms)   = IO (StepT IO ByteString)
ms IO (StepT IO ByteString) -> (StepT IO ByteString -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= StepT IO ByteString -> IO ()
loop
                        loop (S.Yield ByteString
lbs StepT IO ByteString
s) = do
                            Builder -> IO ()
write (ByteString -> Builder
BB.lazyByteString ByteString
lbs)
                            IO ()
flush
                            StepT IO ByteString -> IO ()
loop StepT IO ByteString
s

                    (StepT IO ByteString -> IO ()) -> IO ()
forall b. (StepT IO ByteString -> IO b) -> IO b
kStepLBS StepT IO ByteString -> IO ()
loop

-- | If you use 'Header' in one of the endpoints for your API,
-- this automatically requires your server-side handler to be a function
-- that takes an argument of the type specified by 'Header'.
-- This lets servant worry about extracting it from the request and turning
-- it into a value of the type you specify.
--
-- All it asks is for a 'FromHttpApiData' instance.
--
-- Example:
--
-- > newtype Referer = Referer Text
-- >   deriving (Eq, Show, FromHttpApiData)
-- >
-- >            -- GET /view-my-referer
-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer
-- >
-- > server :: Server MyApi
-- > server = viewReferer
-- >   where viewReferer :: Referer -> Handler referer
-- >         viewReferer referer = return referer
instance
  (KnownSymbol sym, FromHttpApiData a, HasServer api context
  , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)
  , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
  )
  => HasServer (Header' mods sym a :> api) context where
------
  type ServerT (Header' mods sym a :> api) m =
    RequestArgument mods a -> ServerT api m

  hoistServerWithContext :: forall (m :: Type -> Type) (n :: Type -> Type).
Proxy (Header' mods sym a :> api)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (Header' mods sym a :> api) m
-> ServerT (Header' mods sym a :> api) n
hoistServerWithContext Proxy (Header' mods sym a :> api)
_ Proxy context
pc forall x. m x -> n x
nt ServerT (Header' mods sym a :> api) m
s = Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall {k} (api :: k) (context :: [Type]) (m :: Type -> Type)
       (n :: Type -> Type).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall (m :: Type -> Type) (n :: Type -> Type).
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Proxy context
pc m x -> n x
forall x. m x -> n x
nt (ServerT api m -> ServerT api n)
-> (If
      (FoldRequired mods)
      (If (FoldLenient mods) (Either Text a) a)
      (Maybe (If (FoldLenient mods) (Either Text a) a))
    -> ServerT api m)
-> If
     (FoldRequired mods)
     (If (FoldLenient mods) (Either Text a) a)
     (Maybe (If (FoldLenient mods) (Either Text a) a))
-> ServerT api n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (Header' mods sym a :> api) m
If
  (FoldRequired mods)
  (If (FoldLenient mods) (Either Text a) a)
  (Maybe (If (FoldLenient mods) (Either Text a) a))
-> ServerT api m
s

  route :: forall env.
Proxy (Header' mods sym a :> api)
-> Context context
-> Delayed env (Server (Header' mods sym a :> api))
-> Router env
route Proxy (Header' mods sym a :> api)
Proxy Context context
context Delayed env (Server (Header' mods sym a :> api))
subserver = Proxy api
-> Context context -> Delayed env (Server api) -> Router env
forall env.
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
forall {k} (api :: k) (context :: [Type]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Context context
context (Delayed env (Server api) -> Router env)
-> Delayed env (Server api) -> Router env
forall a b. (a -> b) -> a -> b
$
      Delayed env (Server (Header' mods sym a :> api))
Delayed
  env
  (If
     (FoldRequired mods)
     (If (FoldLenient mods) (Either Text a) a)
     (Maybe (If (FoldLenient mods) (Either Text a) a))
   -> Server api)
subserver Delayed
  env
  (If
     (FoldRequired mods)
     (If (FoldLenient mods) (Either Text a) a)
     (Maybe (If (FoldLenient mods) (Either Text a) a))
   -> Server api)
-> DelayedIO
     (If
        (FoldRequired mods)
        (If (FoldLenient mods) (Either Text a) a)
        (Maybe (If (FoldLenient mods) (Either Text a) a)))
-> Delayed env (Server api)
forall env a b.
Delayed env (a -> b) -> DelayedIO a -> Delayed env b
`addHeaderCheck` (Request
 -> DelayedIO
      (If
         (FoldRequired mods)
         (If (FoldLenient mods) (Either Text a) a)
         (Maybe (If (FoldLenient mods) (Either Text a) a))))
-> DelayedIO
     (If
        (FoldRequired mods)
        (If (FoldLenient mods) (Either Text a) a)
        (Maybe (If (FoldLenient mods) (Either Text a) a)))
forall a. (Request -> DelayedIO a) -> DelayedIO a
withRequest Request
-> DelayedIO
     (If
        (FoldRequired mods)
        (If (FoldLenient mods) (Either Text a) a)
        (Maybe (If (FoldLenient mods) (Either Text a) a)))
headerCheck
    where
      rep :: TypeRep
rep = Proxy Header' -> TypeRep
forall {k} (proxy :: k -> Type) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy Header'
forall {k} (t :: k). Proxy t
Proxy :: Proxy Header')
      formatError :: ErrorFormatter
formatError = ErrorFormatters -> ErrorFormatter
headerParseErrorFormatter (ErrorFormatters -> ErrorFormatter)
-> ErrorFormatters -> ErrorFormatter
forall a b. (a -> b) -> a -> b
$ Context (MkContextWithErrorFormatter context) -> ErrorFormatters
forall (context :: [Type]) val.
HasContextEntry context val =>
Context context -> val
getContextEntry (Context context -> Context (MkContextWithErrorFormatter context)
forall (ctx :: [Type]).
Context ctx -> Context (MkContextWithErrorFormatter ctx)
mkContextWithErrorFormatter Context context
context)

      headerName :: IsString n => n
      headerName :: forall n. IsString n => n
headerName = String -> n
forall a. IsString a => String -> a
fromString (String -> n) -> String -> n
forall a b. (a -> b) -> a -> b
$ Proxy sym -> String
forall (n :: Symbol) (proxy :: Symbol -> Type).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy sym
forall {k} (t :: k). Proxy t
Proxy :: Proxy sym)

      headerCheck :: Request -> DelayedIO (RequestArgument mods a)
      headerCheck :: Request
-> DelayedIO
     (If
        (FoldRequired mods)
        (If (FoldLenient mods) (Either Text a) a)
        (Maybe (If (FoldLenient mods) (Either Text a) a)))
headerCheck Request
req =
          Proxy mods
-> DelayedIO
     (If
        (FoldRequired mods)
        (If (FoldLenient mods) (Either Text a) a)
        (Maybe (If (FoldLenient mods) (Either Text a) a)))
-> (Text
    -> DelayedIO
         (If
            (FoldRequired mods)
            (If (FoldLenient mods) (Either Text a) a)
            (Maybe (If (FoldLenient mods) (Either Text a) a))))
-> Maybe (Either Text a)
-> DelayedIO
     (If
        (FoldRequired mods)
        (If (FoldLenient mods) (Either Text a) a)
        (Maybe (If (FoldLenient mods) (Either Text a) a)))
forall (mods :: [Type]) (m :: Type -> Type) a.
(Monad m, SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)) =>
Proxy mods
-> m (RequestArgument mods a)
-> (Text -> m (RequestArgument mods a))
-> Maybe (Either Text a)
-> m (RequestArgument mods a)
unfoldRequestArgument (Proxy mods
forall {k} (t :: k). Proxy t
Proxy :: Proxy mods) DelayedIO
  (If
     (FoldRequired mods)
     (If (FoldLenient mods) (Either Text a) a)
     (Maybe (If (FoldLenient mods) (Either Text a) a)))
errReq Text
-> DelayedIO
     (If
        (FoldRequired mods)
        (If (FoldLenient mods) (Either Text a) a)
        (Maybe (If (FoldLenient mods) (Either Text a) a)))
errSt Maybe (Either Text a)
mev
        where
          mev :: Maybe (Either T.Text a)
          mev :: Maybe (Either Text a)
mev = (ByteString -> Either Text a)
-> Maybe ByteString -> Maybe (Either Text a)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Either Text a
forall a. FromHttpApiData a => ByteString -> Either Text a
parseHeader (Maybe ByteString -> Maybe (Either Text a))
-> Maybe ByteString -> Maybe (Either Text a)
forall a b. (a -> b) -> a -> b
$ HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
forall n. IsString n => n
headerName (Request -> [(HeaderName, ByteString)]
requestHeaders Request
req)

          errReq :: DelayedIO
  (If
     (FoldRequired mods)
     (If (FoldLenient mods) (Either Text a) a)
     (Maybe (If (FoldLenient mods) (Either Text a) a)))
errReq = ServerError
-> DelayedIO
     (If
        (FoldRequired mods)
        (If (FoldLenient mods) (Either Text a) a)
        (Maybe (If (FoldLenient mods) (Either Text a) a)))
forall a. ServerError -> DelayedIO a
delayedFailFatal (ServerError
 -> DelayedIO
      (If
         (FoldRequired mods)
         (If (FoldLenient mods) (Either Text a) a)
         (Maybe (If (FoldLenient mods) (Either Text a) a))))
-> ServerError
-> DelayedIO
     (If
        (FoldRequired mods)
        (If (FoldLenient mods) (Either Text a) a)
        (Maybe (If (FoldLenient mods) (Either Text a) a)))
forall a b. (a -> b) -> a -> b
$ ErrorFormatter
formatError TypeRep
rep Request
req
            (String -> ServerError) -> String -> ServerError
forall a b. (a -> b) -> a -> b
$ String
"Header " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
forall n. IsString n => n
headerName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" is required"

          errSt :: Text
-> DelayedIO
     (If
        (FoldRequired mods)
        (If (FoldLenient mods) (Either Text a) a)
        (Maybe (If (FoldLenient mods) (Either Text a) a)))
errSt Text
e = ServerError
-> DelayedIO
     (If
        (FoldRequired mods)
        (If (FoldLenient mods) (Either Text a) a)
        (Maybe (If (FoldLenient mods) (Either Text a) a)))
forall a. ServerError -> DelayedIO a
delayedFailFatal (ServerError
 -> DelayedIO
      (If
         (FoldRequired mods)
         (If (FoldLenient mods) (Either Text a) a)
         (Maybe (If (FoldLenient mods) (Either Text a) a))))
-> ServerError
-> DelayedIO
     (If
        (FoldRequired mods)
        (If (FoldLenient mods) (Either Text a) a)
        (Maybe (If (FoldLenient mods) (Either Text a) a)))
forall a b. (a -> b) -> a -> b
$ ErrorFormatter
formatError TypeRep
rep Request
req
            (String -> ServerError) -> String -> ServerError
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
"Error parsing header "
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
forall n. IsString n => n
headerName
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" failed: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
e

-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
-- this automatically requires your server-side handler to be a function
-- that takes an argument of type @'Maybe' 'Text'@.
--
-- This lets servant worry about looking it up in the query string
-- and turning it into a value of the type you specify, enclosed
-- in 'Maybe', because it may not be there and servant would then
-- hand you 'Nothing'.
--
-- You can control how it'll be converted from 'Text' to your type
-- by simply providing an instance of 'FromHttpApiData' for your type.
--
-- Example:
--
-- > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book]
-- >
-- > server :: Server MyApi
-- > server = getBooksBy
-- >   where getBooksBy :: Maybe Text -> Handler [Book]
-- >         getBooksBy Nothing       = ...return all books...
-- >         getBooksBy (Just author) = ...return books by the given author...
instance
  ( KnownSymbol sym, FromHttpApiData a, HasServer api context
  , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)
  , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
  )
  => HasServer (QueryParam' mods sym a :> api) context where
------
  type ServerT (QueryParam' mods sym a :> api) m =
    RequestArgument mods a -> ServerT api m

  hoistServerWithContext :: forall (m :: Type -> Type) (n :: Type -> Type).
Proxy (QueryParam' mods sym a :> api)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (QueryParam' mods sym a :> api) m
-> ServerT (QueryParam' mods sym a :> api) n
hoistServerWithContext Proxy (QueryParam' mods sym a :> api)
_ Proxy context
pc forall x. m x -> n x
nt ServerT (QueryParam' mods sym a :> api) m
s = Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall {k} (api :: k) (context :: [Type]) (m :: Type -> Type)
       (n :: Type -> Type).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall (m :: Type -> Type) (n :: Type -> Type).
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Proxy context
pc m x -> n x
forall x. m x -> n x
nt (ServerT api m -> ServerT api n)
-> (If
      (FoldRequired mods)
      (If (FoldLenient mods) (Either Text a) a)
      (Maybe (If (FoldLenient mods) (Either Text a) a))
    -> ServerT api m)
-> If
     (FoldRequired mods)
     (If (FoldLenient mods) (Either Text a) a)
     (Maybe (If (FoldLenient mods) (Either Text a) a))
-> ServerT api n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (QueryParam' mods sym a :> api) m
If
  (FoldRequired mods)
  (If (FoldLenient mods) (Either Text a) a)
  (Maybe (If (FoldLenient mods) (Either Text a) a))
-> ServerT api m
s

  route :: forall env.
Proxy (QueryParam' mods sym a :> api)
-> Context context
-> Delayed env (Server (QueryParam' mods sym a :> api))
-> Router env
route Proxy (QueryParam' mods sym a :> api)
Proxy Context context
context Delayed env (Server (QueryParam' mods sym a :> api))
subserver =
    let querytext :: Request -> QueryText
querytext = Query -> QueryText
queryToQueryText (Query -> QueryText) -> (Request -> Query) -> Request -> QueryText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Query
queryString
        paramname :: Text
paramname = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy sym -> String
forall (n :: Symbol) (proxy :: Symbol -> Type).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy sym
forall {k} (t :: k). Proxy t
Proxy :: Proxy sym)

        rep :: TypeRep
rep = Proxy QueryParam' -> TypeRep
forall {k} (proxy :: k -> Type) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy QueryParam'
forall {k} (t :: k). Proxy t
Proxy :: Proxy QueryParam')
        formatError :: ErrorFormatter
formatError = ErrorFormatters -> ErrorFormatter
urlParseErrorFormatter (ErrorFormatters -> ErrorFormatter)
-> ErrorFormatters -> ErrorFormatter
forall a b. (a -> b) -> a -> b
$ Context (MkContextWithErrorFormatter context) -> ErrorFormatters
forall (context :: [Type]) val.
HasContextEntry context val =>
Context context -> val
getContextEntry (Context context -> Context (MkContextWithErrorFormatter context)
forall (ctx :: [Type]).
Context ctx -> Context (MkContextWithErrorFormatter ctx)
mkContextWithErrorFormatter Context context
context)

        parseParam :: Request -> DelayedIO (RequestArgument mods a)
        parseParam :: Request
-> DelayedIO
     (If
        (FoldRequired mods)
        (If (FoldLenient mods) (Either Text a) a)
        (Maybe (If (FoldLenient mods) (Either Text a) a)))
parseParam Request
req =
            Proxy mods
-> DelayedIO
     (If
        (FoldRequired mods)
        (If (FoldLenient mods) (Either Text a) a)
        (Maybe (If (FoldLenient mods) (Either Text a) a)))
-> (Text
    -> DelayedIO
         (If
            (FoldRequired mods)
            (If (FoldLenient mods) (Either Text a) a)
            (Maybe (If (FoldLenient mods) (Either Text a) a))))
-> Maybe (Either Text a)
-> DelayedIO
     (If
        (FoldRequired mods)
        (If (FoldLenient mods) (Either Text a) a)
        (Maybe (If (FoldLenient mods) (Either Text a) a)))
forall (mods :: [Type]) (m :: Type -> Type) a.
(Monad m, SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)) =>
Proxy mods
-> m (RequestArgument mods a)
-> (Text -> m (RequestArgument mods a))
-> Maybe (Either Text a)
-> m (RequestArgument mods a)
unfoldRequestArgument (Proxy mods
forall {k} (t :: k). Proxy t
Proxy :: Proxy mods) DelayedIO
  (If
     (FoldRequired mods)
     (If (FoldLenient mods) (Either Text a) a)
     (Maybe (If (FoldLenient mods) (Either Text a) a)))
errReq Text
-> DelayedIO
     (If
        (FoldRequired mods)
        (If (FoldLenient mods) (Either Text a) a)
        (Maybe (If (FoldLenient mods) (Either Text a) a)))
errSt Maybe (Either Text a)
mev
          where
            mev :: Maybe (Either T.Text a)
            mev :: Maybe (Either Text a)
mev = (Text -> Either Text a) -> Maybe Text -> Maybe (Either Text a)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Either Text a
forall a. FromHttpApiData a => Text -> Either Text a
parseQueryParam (Maybe Text -> Maybe (Either Text a))
-> Maybe Text -> Maybe (Either Text a)
forall a b. (a -> b) -> a -> b
$ Maybe (Maybe Text) -> Maybe Text
forall (m :: Type -> Type) a. Monad m => m (m a) -> m a
join (Maybe (Maybe Text) -> Maybe Text)
-> Maybe (Maybe Text) -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text -> QueryText -> Maybe (Maybe Text)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
paramname (QueryText -> Maybe (Maybe Text))
-> QueryText -> Maybe (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Request -> QueryText
querytext Request
req

            errReq :: DelayedIO
  (If
     (FoldRequired mods)
     (If (FoldLenient mods) (Either Text a) a)
     (Maybe (If (FoldLenient mods) (Either Text a) a)))
errReq = ServerError
-> DelayedIO
     (If
        (FoldRequired mods)
        (If (FoldLenient mods) (Either Text a) a)
        (Maybe (If (FoldLenient mods) (Either Text a) a)))
forall a. ServerError -> DelayedIO a
delayedFailFatal (ServerError
 -> DelayedIO
      (If
         (FoldRequired mods)
         (If (FoldLenient mods) (Either Text a) a)
         (Maybe (If (FoldLenient mods) (Either Text a) a))))
-> ServerError
-> DelayedIO
     (If
        (FoldRequired mods)
        (If (FoldLenient mods) (Either Text a) a)
        (Maybe (If (FoldLenient mods) (Either Text a) a)))
forall a b. (a -> b) -> a -> b
$ ErrorFormatter
formatError TypeRep
rep Request
req
              (String -> ServerError) -> String -> ServerError
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
"Query parameter " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
paramname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is required"

            errSt :: Text
-> DelayedIO
     (If
        (FoldRequired mods)
        (If (FoldLenient mods) (Either Text a) a)
        (Maybe (If (FoldLenient mods) (Either Text a) a)))
errSt Text
e = ServerError
-> DelayedIO
     (If
        (FoldRequired mods)
        (If (FoldLenient mods) (Either Text a) a)
        (Maybe (If (FoldLenient mods) (Either Text a) a)))
forall a. ServerError -> DelayedIO a
delayedFailFatal (ServerError
 -> DelayedIO
      (If
         (FoldRequired mods)
         (If (FoldLenient mods) (Either Text a) a)
         (Maybe (If (FoldLenient mods) (Either Text a) a))))
-> ServerError
-> DelayedIO
     (If
        (FoldRequired mods)
        (If (FoldLenient mods) (Either Text a) a)
        (Maybe (If (FoldLenient mods) (Either Text a) a)))
forall a b. (a -> b) -> a -> b
$ ErrorFormatter
formatError TypeRep
rep Request
req
              (String -> ServerError) -> String -> ServerError
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
"Error parsing query parameter "
                      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
paramname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" failed: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
e

        delayed :: Delayed env (ServerT api Handler)
delayed = Delayed
  env
  (If
     (FoldRequired mods)
     (If (FoldLenient mods) (Either Text a) a)
     (Maybe (If (FoldLenient mods) (Either Text a) a))
   -> ServerT api Handler)
-> DelayedIO
     (If
        (FoldRequired mods)
        (If (FoldLenient mods) (Either Text a) a)
        (Maybe (If (FoldLenient mods) (Either Text a) a)))
-> Delayed env (ServerT api Handler)
forall env a b.
Delayed env (a -> b) -> DelayedIO a -> Delayed env b
addParameterCheck Delayed env (Server (QueryParam' mods sym a :> api))
Delayed
  env
  (If
     (FoldRequired mods)
     (If (FoldLenient mods) (Either Text a) a)
     (Maybe (If (FoldLenient mods) (Either Text a) a))
   -> ServerT api Handler)
subserver (DelayedIO
   (If
      (FoldRequired mods)
      (If (FoldLenient mods) (Either Text a) a)
      (Maybe (If (FoldLenient mods) (Either Text a) a)))
 -> Delayed env (ServerT api Handler))
-> ((Request
     -> DelayedIO
          (If
             (FoldRequired mods)
             (If (FoldLenient mods) (Either Text a) a)
             (Maybe (If (FoldLenient mods) (Either Text a) a))))
    -> DelayedIO
         (If
            (FoldRequired mods)
            (If (FoldLenient mods) (Either Text a) a)
            (Maybe (If (FoldLenient mods) (Either Text a) a))))
-> (Request
    -> DelayedIO
         (If
            (FoldRequired mods)
            (If (FoldLenient mods) (Either Text a) a)
            (Maybe (If (FoldLenient mods) (Either Text a) a))))
-> Delayed env (ServerT api Handler)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Request
 -> DelayedIO
      (If
         (FoldRequired mods)
         (If (FoldLenient mods) (Either Text a) a)
         (Maybe (If (FoldLenient mods) (Either Text a) a))))
-> DelayedIO
     (If
        (FoldRequired mods)
        (If (FoldLenient mods) (Either Text a) a)
        (Maybe (If (FoldLenient mods) (Either Text a) a)))
forall a. (Request -> DelayedIO a) -> DelayedIO a
withRequest ((Request
  -> DelayedIO
       (If
          (FoldRequired mods)
          (If (FoldLenient mods) (Either Text a) a)
          (Maybe (If (FoldLenient mods) (Either Text a) a))))
 -> Delayed env (ServerT api Handler))
-> (Request
    -> DelayedIO
         (If
            (FoldRequired mods)
            (If (FoldLenient mods) (Either Text a) a)
            (Maybe (If (FoldLenient mods) (Either Text a) a))))
-> Delayed env (ServerT api Handler)
forall a b. (a -> b) -> a -> b
$ \Request
req ->
                    Request
-> DelayedIO
     (If
        (FoldRequired mods)
        (If (FoldLenient mods) (Either Text a) a)
        (Maybe (If (FoldLenient mods) (Either Text a) a)))
parseParam Request
req

    in Proxy api
-> Context context
-> Delayed env (ServerT api Handler)
-> Router env
forall env.
Proxy api
-> Context context
-> Delayed env (ServerT api Handler)
-> Router env
forall {k} (api :: k) (context :: [Type]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Context context
context Delayed env (ServerT api Handler)
delayed

-- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API,
-- this automatically requires your server-side handler to be a function
-- that takes an argument of type @['Text']@.
--
-- This lets servant worry about looking up 0 or more values in the query string
-- associated to @authors@ and turning each of them into a value of
-- the type you specify.
--
-- You can control how the individual values are converted from 'Text' to your type
-- by simply providing an instance of 'FromHttpApiData' for your type.
--
-- Example:
--
-- > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book]
-- >
-- > server :: Server MyApi
-- > server = getBooksBy
-- >   where getBooksBy :: [Text] -> Handler [Book]
-- >         getBooksBy authors = ...return all books by these authors...
instance (KnownSymbol sym, FromHttpApiData a, HasServer api context
         , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters)
      => HasServer (QueryParams sym a :> api) context where

  type ServerT (QueryParams sym a :> api) m =
    [a] -> ServerT api m

  hoistServerWithContext :: forall (m :: Type -> Type) (n :: Type -> Type).
Proxy (QueryParams sym a :> api)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (QueryParams sym a :> api) m
-> ServerT (QueryParams sym a :> api) n
hoistServerWithContext Proxy (QueryParams sym a :> api)
_ Proxy context
pc forall x. m x -> n x
nt ServerT (QueryParams sym a :> api) m
s = Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall {k} (api :: k) (context :: [Type]) (m :: Type -> Type)
       (n :: Type -> Type).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall (m :: Type -> Type) (n :: Type -> Type).
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Proxy context
pc m x -> n x
forall x. m x -> n x
nt (ServerT api m -> ServerT api n)
-> ([a] -> ServerT api m) -> [a] -> ServerT api n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (QueryParams sym a :> api) m
[a] -> ServerT api m
s

  route :: forall env.
Proxy (QueryParams sym a :> api)
-> Context context
-> Delayed env (Server (QueryParams sym a :> api))
-> Router env
route Proxy (QueryParams sym a :> api)
Proxy Context context
context Delayed env (Server (QueryParams sym a :> api))
subserver = Proxy api
-> Context context -> Delayed env (Server api) -> Router env
forall env.
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
forall {k} (api :: k) (context :: [Type]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Context context
context (Delayed env (Server api) -> Router env)
-> Delayed env (Server api) -> Router env
forall a b. (a -> b) -> a -> b
$
      Delayed env (Server (QueryParams sym a :> api))
Delayed env ([a] -> Server api)
subserver Delayed env ([a] -> Server api)
-> DelayedIO [a] -> Delayed env (Server api)
forall env a b.
Delayed env (a -> b) -> DelayedIO a -> Delayed env b
`addParameterCheck` (Request -> DelayedIO [a]) -> DelayedIO [a]
forall a. (Request -> DelayedIO a) -> DelayedIO a
withRequest Request -> DelayedIO [a]
paramsCheck
    where
      rep :: TypeRep
rep = Proxy QueryParams -> TypeRep
forall {k} (proxy :: k -> Type) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy QueryParams
forall {k} (t :: k). Proxy t
Proxy :: Proxy QueryParams)
      formatError :: ErrorFormatter
formatError = ErrorFormatters -> ErrorFormatter
urlParseErrorFormatter (ErrorFormatters -> ErrorFormatter)
-> ErrorFormatters -> ErrorFormatter
forall a b. (a -> b) -> a -> b
$ Context (MkContextWithErrorFormatter context) -> ErrorFormatters
forall (context :: [Type]) val.
HasContextEntry context val =>
Context context -> val
getContextEntry (Context context -> Context (MkContextWithErrorFormatter context)
forall (ctx :: [Type]).
Context ctx -> Context (MkContextWithErrorFormatter ctx)
mkContextWithErrorFormatter Context context
context)

      paramname :: Text
paramname = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy sym -> String
forall (n :: Symbol) (proxy :: Symbol -> Type).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy sym
forall {k} (t :: k). Proxy t
Proxy :: Proxy sym)
      paramsCheck :: Request -> DelayedIO [a]
paramsCheck Request
req =
          case [Either Text a] -> ([Text], [a])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either Text a] -> ([Text], [a]))
-> [Either Text a] -> ([Text], [a])
forall a b. (a -> b) -> a -> b
$ (Text -> Either Text a) -> [Text] -> [Either Text a]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Either Text a
forall a. FromHttpApiData a => Text -> Either Text a
parseQueryParam [Text]
params of
              ([], [a]
parsed) -> [a] -> DelayedIO [a]
forall a. a -> DelayedIO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return [a]
parsed
              ([Text]
errs, [a]
_)    -> ServerError -> DelayedIO [a]
forall a. ServerError -> DelayedIO a
delayedFailFatal (ServerError -> DelayedIO [a]) -> ServerError -> DelayedIO [a]
forall a b. (a -> b) -> a -> b
$ ErrorFormatter
formatError TypeRep
rep Request
req
                  (String -> ServerError) -> String -> ServerError
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
"Error parsing query parameter(s) "
                         Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
paramname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" failed: "
                         Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
errs
        where
          params :: [T.Text]
          params :: [Text]
params = ((Text, Maybe Text) -> Maybe Text) -> QueryText -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Text, Maybe Text) -> Maybe Text
forall a b. (a, b) -> b
snd
                 (QueryText -> [Text])
-> (Request -> QueryText) -> Request -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Maybe Text) -> Bool) -> QueryText -> QueryText
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Bool
looksLikeParam (Text -> Bool)
-> ((Text, Maybe Text) -> Text) -> (Text, Maybe Text) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Maybe Text) -> Text
forall a b. (a, b) -> a
fst)
                 (QueryText -> QueryText)
-> (Request -> QueryText) -> Request -> QueryText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Query -> QueryText
queryToQueryText
                 (Query -> QueryText) -> (Request -> Query) -> Request -> QueryText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Query
queryString
                 (Request -> [Text]) -> Request -> [Text]
forall a b. (a -> b) -> a -> b
$ Request
req

          looksLikeParam :: Text -> Bool
looksLikeParam Text
name = Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
paramname Bool -> Bool -> Bool
|| Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== (Text
paramname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"[]")

-- | If you use @'QueryFlag' "published"@ in one of the endpoints for your API,
-- this automatically requires your server-side handler to be a function
-- that takes an argument of type 'Bool'.
--
-- Example:
--
-- > type MyApi = "books" :> QueryFlag "published" :> Get '[JSON] [Book]
-- >
-- > server :: Server MyApi
-- > server = getBooks
-- >   where getBooks :: Bool -> Handler [Book]
-- >         getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument...
instance (KnownSymbol sym, HasServer api context)
      => HasServer (QueryFlag sym :> api) context where

  type ServerT (QueryFlag sym :> api) m =
    Bool -> ServerT api m

  hoistServerWithContext :: forall (m :: Type -> Type) (n :: Type -> Type).
Proxy (QueryFlag sym :> api)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (QueryFlag sym :> api) m
-> ServerT (QueryFlag sym :> api) n
hoistServerWithContext Proxy (QueryFlag sym :> api)
_ Proxy context
pc forall x. m x -> n x
nt ServerT (QueryFlag sym :> api) m
s = Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall {k} (api :: k) (context :: [Type]) (m :: Type -> Type)
       (n :: Type -> Type).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall (m :: Type -> Type) (n :: Type -> Type).
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Proxy context
pc m x -> n x
forall x. m x -> n x
nt (ServerT api m -> ServerT api n)
-> (Bool -> ServerT api m) -> Bool -> ServerT api n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (QueryFlag sym :> api) m
Bool -> ServerT api m
s

  route :: forall env.
Proxy (QueryFlag sym :> api)
-> Context context
-> Delayed env (Server (QueryFlag sym :> api))
-> Router env
route Proxy (QueryFlag sym :> api)
Proxy Context context
context Delayed env (Server (QueryFlag sym :> api))
subserver =
    let querytext :: Request -> QueryText
querytext = Query -> QueryText
queryToQueryText (Query -> QueryText) -> (Request -> Query) -> Request -> QueryText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Query
queryString
        param :: Request -> Bool
param Request
r = case Text -> QueryText -> Maybe (Maybe Text)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
paramname (Request -> QueryText
querytext Request
r) of
          Just Maybe Text
Nothing  -> Bool
True  -- param is there, with no value
          Just (Just Text
v) -> Text -> Bool
forall {a}. (Eq a, IsString a) => a -> Bool
examine Text
v -- param with a value
          Maybe (Maybe Text)
Nothing       -> Bool
False -- param not in the query string
    in  Proxy api
-> Context context -> Delayed env (Server api) -> Router env
forall env.
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
forall {k} (api :: k) (context :: [Type]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Context context
context (Delayed env (Bool -> Server api)
-> (Request -> Bool) -> Delayed env (Server api)
forall env a b.
Delayed env (a -> b) -> (Request -> a) -> Delayed env b
passToServer Delayed env (Server (QueryFlag sym :> api))
Delayed env (Bool -> Server api)
subserver Request -> Bool
param)
    where paramname :: Text
paramname = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy sym -> String
forall (n :: Symbol) (proxy :: Symbol -> Type).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy sym
forall {k} (t :: k). Proxy t
Proxy :: Proxy sym)
          examine :: a -> Bool
examine a
v | a
v a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
"true" Bool -> Bool -> Bool
|| a
v a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
"1" Bool -> Bool -> Bool
|| a
v a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
"" = Bool
True
                    | Bool
otherwise = Bool
False

-- | If you use @'QueryString'@ in one of the endpoints for your API,
-- this automatically requires your server-side handler to be a function
-- that takes an argument of type @Query@ (@[('ByteString', 'Maybe' 'ByteString')]@).
--
-- This lets you extract the whole query string. This is useful when the query string
-- can contain parameters with dynamic names, that you can't access with @'QueryParam'@.
--
-- Example:
--
-- > type MyApi = "books" :> QueryString :> Get '[JSON] [Book]
-- >
-- > server :: Server MyApi
-- > server = getBooksBy
-- >   where getBooksBy :: Query -> Handler [Book]
-- >         getBooksBy filters = ...filter books based on the dynamic filters provided...
instance
  ( HasServer api context
  )
  => HasServer (QueryString :> api) context where
------
  type ServerT (QueryString :> api) m =
    Query -> ServerT api m

  hoistServerWithContext :: forall (m :: Type -> Type) (n :: Type -> Type).
Proxy (QueryString :> api)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (QueryString :> api) m
-> ServerT (QueryString :> api) n
hoistServerWithContext Proxy (QueryString :> api)
_ Proxy context
pc forall x. m x -> n x
nt ServerT (QueryString :> api) m
s = Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall {k} (api :: k) (context :: [Type]) (m :: Type -> Type)
       (n :: Type -> Type).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall (m :: Type -> Type) (n :: Type -> Type).
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Proxy context
pc m x -> n x
forall x. m x -> n x
nt (ServerT api m -> ServerT api n)
-> (Query -> ServerT api m) -> Query -> ServerT api n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (QueryString :> api) m
Query -> ServerT api m
s

  route :: forall env.
Proxy (QueryString :> api)
-> Context context
-> Delayed env (Server (QueryString :> api))
-> Router env
route Proxy (QueryString :> api)
Proxy Context context
context Delayed env (Server (QueryString :> api))
subserver =
    Proxy api
-> Context context -> Delayed env (Server api) -> Router env
forall env.
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
forall {k} (api :: k) (context :: [Type]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Context context
context (Delayed env (Query -> Server api)
-> (Request -> Query) -> Delayed env (Server api)
forall env a b.
Delayed env (a -> b) -> (Request -> a) -> Delayed env b
passToServer Delayed env (Server (QueryString :> api))
Delayed env (Query -> Server api)
subserver Request -> Query
queryString)

-- | If you use @'DeepQuery' "symbol" a@ in one of the endpoints for your API,
-- this automatically requires your server-side handler to be a function
-- that takes an argument of type @a@.
--
-- This lets you extract an object from multiple parameters in the query string,
-- with its fields enclosed in brackets: `/books?filter[author][name]=value`. When
-- all the fields are known in advance, it can be done with @'QueryParam'@ (it can
-- still be tedious if you the object has many fields). When some fields are dynamic,
-- it cannot be done with @'QueryParam'.
--
-- The way the object is constructed from the extracted fields can be controlled by
-- providing an instance on @'FromDeepQuery'@
--
-- Example:
--
-- > type MyApi = "books" :> DeepQuery "filter" BookQuery :> Get '[JSON] [Book]
-- >
-- > server :: Server MyApi
-- > server = getBooksBy
-- >   where getBooksBy :: BookQuery -> Handler [Book]
-- >         getBooksBy query = ...filter books based on the dynamic filters provided...
instance
  ( KnownSymbol sym, FromDeepQuery a, HasServer api context
  , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
  )
  => HasServer (DeepQuery sym a :> api) context where
------
  type ServerT (DeepQuery sym a :> api) m =
    a -> ServerT api m

  hoistServerWithContext :: forall (m :: Type -> Type) (n :: Type -> Type).
Proxy (DeepQuery sym a :> api)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (DeepQuery sym a :> api) m
-> ServerT (DeepQuery sym a :> api) n
hoistServerWithContext Proxy (DeepQuery sym a :> api)
_ Proxy context
pc forall x. m x -> n x
nt ServerT (DeepQuery sym a :> api) m
s = Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall {k} (api :: k) (context :: [Type]) (m :: Type -> Type)
       (n :: Type -> Type).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall (m :: Type -> Type) (n :: Type -> Type).
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Proxy context
pc m x -> n x
forall x. m x -> n x
nt (ServerT api m -> ServerT api n)
-> (a -> ServerT api m) -> a -> ServerT api n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (DeepQuery sym a :> api) m
a -> ServerT api m
s

  route :: forall env.
Proxy (DeepQuery sym a :> api)
-> Context context
-> Delayed env (Server (DeepQuery sym a :> api))
-> Router env
route Proxy (DeepQuery sym a :> api)
Proxy Context context
context Delayed env (Server (DeepQuery sym a :> api))
subserver = Proxy api
-> Context context -> Delayed env (Server api) -> Router env
forall env.
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
forall {k} (api :: k) (context :: [Type]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Context context
context (Delayed env (Server api) -> Router env)
-> Delayed env (Server api) -> Router env
forall a b. (a -> b) -> a -> b
$
      Delayed env (Server (DeepQuery sym a :> api))
Delayed env (a -> Server api)
subserver Delayed env (a -> Server api)
-> DelayedIO a -> Delayed env (Server api)
forall env a b.
Delayed env (a -> b) -> DelayedIO a -> Delayed env b
`addParameterCheck` (Request -> DelayedIO a) -> DelayedIO a
forall a. (Request -> DelayedIO a) -> DelayedIO a
withRequest Request -> DelayedIO a
paramsCheck
    where
      rep :: TypeRep
rep = Proxy DeepQuery -> TypeRep
forall {k} (proxy :: k -> Type) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy DeepQuery
forall {k} (t :: k). Proxy t
Proxy :: Proxy DeepQuery)
      formatError :: ErrorFormatter
formatError = ErrorFormatters -> ErrorFormatter
urlParseErrorFormatter (ErrorFormatters -> ErrorFormatter)
-> ErrorFormatters -> ErrorFormatter
forall a b. (a -> b) -> a -> b
$ Context (MkContextWithErrorFormatter context) -> ErrorFormatters
forall (context :: [Type]) val.
HasContextEntry context val =>
Context context -> val
getContextEntry (Context context -> Context (MkContextWithErrorFormatter context)
forall (ctx :: [Type]).
Context ctx -> Context (MkContextWithErrorFormatter ctx)
mkContextWithErrorFormatter Context context
context)

      paramname :: Text
paramname = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy sym -> String
forall (n :: Symbol) (proxy :: Symbol -> Type).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy sym
forall {k} (t :: k). Proxy t
Proxy :: Proxy sym)
      paramsCheck :: Request -> DelayedIO a
paramsCheck Request
req =
        let relevantParams :: [(T.Text, Maybe T.Text)]
            relevantParams :: QueryText
relevantParams = ((Text, Maybe Text) -> Maybe (Text, Maybe Text))
-> QueryText -> QueryText
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Text, Maybe Text) -> Maybe (Text, Maybe Text)
isRelevantParam
                           (QueryText -> QueryText)
-> (Request -> QueryText) -> Request -> QueryText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Query -> QueryText
queryToQueryText
                           (Query -> QueryText) -> (Request -> Query) -> Request -> QueryText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Query
queryString
                           (Request -> QueryText) -> Request -> QueryText
forall a b. (a -> b) -> a -> b
$ Request
req
            isRelevantParam :: (Text, Maybe Text) -> Maybe (Text, Maybe Text)
isRelevantParam (Text
name, Maybe Text
value) = (, Maybe Text
value) (Text -> (Text, Maybe Text))
-> Maybe Text -> Maybe (Text, Maybe Text)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$>
              case Text -> Text -> Maybe Text
T.stripPrefix Text
paramname Text
name of
                Just Text
"" -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
""
                Just Text
x | Text
"[" Text -> Text -> Bool
`T.isPrefixOf` Text
x -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
x
                Maybe Text
_ -> Maybe Text
forall a. Maybe a
Nothing
         in case [([Text], Maybe Text)] -> Either String a
forall a.
FromDeepQuery a =>
[([Text], Maybe Text)] -> Either String a
fromDeepQuery ([([Text], Maybe Text)] -> Either String a)
-> Either String [([Text], Maybe Text)] -> Either String a
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< ((Text, Maybe Text) -> Either String ([Text], Maybe Text))
-> QueryText -> Either String [([Text], Maybe Text)]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Text, Maybe Text) -> Either String ([Text], Maybe Text)
parseDeepParam QueryText
relevantParams of
              Left String
e -> ServerError -> DelayedIO a
forall a. ServerError -> DelayedIO a
delayedFailFatal (ServerError -> DelayedIO a) -> ServerError -> DelayedIO a
forall a b. (a -> b) -> a -> b
$ ErrorFormatter
formatError TypeRep
rep Request
req
                          (String -> ServerError) -> String -> ServerError
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
"Error parsing deep query parameter(s) "
                                 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
paramname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
" failed: "
                                 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
e
              Right a
parsed -> a -> DelayedIO a
forall a. a -> DelayedIO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return a
parsed

parseDeepParam :: (T.Text, Maybe T.Text) -> Either String ([T.Text], Maybe T.Text)
parseDeepParam :: (Text, Maybe Text) -> Either String ([Text], Maybe Text)
parseDeepParam (Text
paramname, Maybe Text
value) =
  let parseParam :: Text -> Either String [Text]
parseParam Text
"" = [Text] -> Either String [Text]
forall a. a -> Either String a
forall (m :: Type -> Type) a. Monad m => a -> m a
return []
      parseParam Text
n = [Text] -> [Text]
forall a. [a] -> [a]
reverse ([Text] -> [Text]) -> Either String [Text] -> Either String [Text]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text] -> Text -> Either String [Text]
go [] Text
n
      go :: [Text] -> Text -> Either String [Text]
go [Text]
parsed Text
remaining = case Int -> Text -> Text
T.take Int
1 Text
remaining of
          Text
"[" -> case HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
"]" Text
remaining of
            (Text
_   , Text
"")  -> String -> Either String [Text]
forall a b. a -> Either a b
Left (String -> Either String [Text]) -> String -> Either String [Text]
forall a b. (a -> b) -> a -> b
$ String
"Error parsing deep param, missing closing ']': " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
remaining
            (Text
name, Text
"]") -> [Text] -> Either String [Text]
forall a. a -> Either String a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Text] -> Either String [Text]) -> [Text] -> Either String [Text]
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.drop Int
1 Text
name Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
parsed
            (Text
name, Text
remaining') -> case Int -> Text -> Text
T.take Int
2 Text
remaining' of
              Text
"][" -> [Text] -> Text -> Either String [Text]
go (Int -> Text -> Text
T.drop Int
1 Text
name Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
parsed) (Int -> Text -> Text
T.drop Int
1 Text
remaining')
              Text
_    -> String -> Either String [Text]
forall a b. a -> Either a b
Left (String -> Either String [Text]) -> String -> Either String [Text]
forall a b. (a -> b) -> a -> b
$ String
"Error parsing deep param, incorrect brackets: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
remaining
          Text
_   -> String -> Either String [Text]
forall a b. a -> Either a b
Left (String -> Either String [Text]) -> String -> Either String [Text]
forall a b. (a -> b) -> a -> b
$ String
"Error parsing deep param, missing opening '[': " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
remaining
   in (, Maybe Text
value) ([Text] -> ([Text], Maybe Text))
-> Either String [Text] -> Either String ([Text], Maybe Text)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Either String [Text]
parseParam Text
paramname

-- | Just pass the request to the underlying application and serve its response.
--
-- Example:
--
-- > type MyApi = "images" :> Raw
-- >
-- > server :: Server MyApi
-- > server = serveDirectory "/var/www/images"
instance HasServer Raw context where

  type ServerT Raw m = Tagged m Application

  hoistServerWithContext :: forall (m :: Type -> Type) (n :: Type -> Type).
Proxy Raw
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT Raw m
-> ServerT Raw n
hoistServerWithContext Proxy Raw
_ Proxy context
_ forall x. m x -> n x
_ = Tagged m Application -> Tagged n Application
ServerT Raw m -> ServerT Raw n
forall {k1} {k2} (s :: k1) b (t :: k2). Tagged s b -> Tagged t b
retag

  route :: forall env.
Proxy Raw
-> Context context -> Delayed env (Server Raw) -> Router env
route Proxy Raw
Proxy Context context
_ Delayed env (Server Raw)
rawApplication = (env -> RoutingApplication) -> Router' env RoutingApplication
forall env a. (env -> a) -> Router' env a
RawRouter ((env -> RoutingApplication) -> Router' env RoutingApplication)
-> (env -> RoutingApplication) -> Router' env RoutingApplication
forall a b. (a -> b) -> a -> b
$ \ env
env Request
request RouteResult Response -> IO ResponseReceived
respond -> ResourceT IO ResponseReceived -> IO ResponseReceived
forall (m :: Type -> Type) a.
MonadUnliftIO m =>
ResourceT m a -> m a
runResourceT (ResourceT IO ResponseReceived -> IO ResponseReceived)
-> ResourceT IO ResponseReceived -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ do
    -- note: a Raw application doesn't register any cleanup
    -- but for the sake of consistency, we nonetheless run
    -- the cleanup once its done
    RouteResult (Tagged Handler Application)
r <- Delayed env (Tagged Handler Application)
-> env
-> Request
-> ResourceT IO (RouteResult (Tagged Handler Application))
forall env a.
Delayed env a -> env -> Request -> ResourceT IO (RouteResult a)
runDelayed Delayed env (Tagged Handler Application)
Delayed env (Server Raw)
rawApplication env
env Request
request
    IO ResponseReceived -> ResourceT IO ResponseReceived
forall a. IO a -> ResourceT IO a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO ResponseReceived -> ResourceT IO ResponseReceived)
-> IO ResponseReceived -> ResourceT IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ RouteResult (Tagged Handler Application) -> RoutingApplication
forall {k} {s :: k} {t} {a} {t}.
RouteResult (Tagged s (t -> (a -> t) -> t))
-> t -> (RouteResult a -> t) -> t
go RouteResult (Tagged Handler Application)
r Request
request RouteResult Response -> IO ResponseReceived
respond

    where go :: RouteResult (Tagged s (t -> (a -> t) -> t))
-> t -> (RouteResult a -> t) -> t
go RouteResult (Tagged s (t -> (a -> t) -> t))
r t
request RouteResult a -> t
respond = case RouteResult (Tagged s (t -> (a -> t) -> t))
r of
            Route Tagged s (t -> (a -> t) -> t)
app   -> Tagged s (t -> (a -> t) -> t) -> t -> (a -> t) -> t
forall {k} (s :: k) b. Tagged s b -> b
untag Tagged s (t -> (a -> t) -> t)
app t
request (RouteResult a -> t
respond (RouteResult a -> t) -> (a -> RouteResult a) -> a -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> RouteResult a
forall a. a -> RouteResult a
Route)
            Fail ServerError
a      -> RouteResult a -> t
respond (RouteResult a -> t) -> RouteResult a -> t
forall a b. (a -> b) -> a -> b
$ ServerError -> RouteResult a
forall a. ServerError -> RouteResult a
Fail ServerError
a
            FailFatal ServerError
e -> RouteResult a -> t
respond (RouteResult a -> t) -> RouteResult a -> t
forall a b. (a -> b) -> a -> b
$ ServerError -> RouteResult a
forall a. ServerError -> RouteResult a
FailFatal ServerError
e

-- | Just pass the request to the underlying application and serve its response.
--
-- Example:
--
-- > type MyApi = "images" :> Raw
-- >
-- > server :: Server MyApi
-- > server = serveDirectory "/var/www/images"
instance HasServer RawM context where
  type ServerT RawM m = Request -> (Response -> IO ResponseReceived) -> m ResponseReceived

  route
    :: Proxy RawM
    -> Context context
    -> Delayed env (Request -> (Response -> IO ResponseReceived) -> Handler ResponseReceived) -> Router env
  route :: forall env.
Proxy RawM
-> Context context
-> Delayed
     env
     (Request
      -> (Response -> IO ResponseReceived) -> Handler ResponseReceived)
-> Router env
route Proxy RawM
_ Context context
_ Delayed
  env
  (Request
   -> (Response -> IO ResponseReceived) -> Handler ResponseReceived)
handleDelayed = (env -> RoutingApplication) -> Router' env RoutingApplication
forall env a. (env -> a) -> Router' env a
RawRouter ((env -> RoutingApplication) -> Router' env RoutingApplication)
-> (env -> RoutingApplication) -> Router' env RoutingApplication
forall a b. (a -> b) -> a -> b
$ \env
env Request
request RouteResult Response -> IO ResponseReceived
respond -> ResourceT IO ResponseReceived -> IO ResponseReceived
forall (m :: Type -> Type) a.
MonadUnliftIO m =>
ResourceT m a -> m a
runResourceT (ResourceT IO ResponseReceived -> IO ResponseReceived)
-> ResourceT IO ResponseReceived -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ do
    RouteResult
  (Request
   -> (Response -> IO ResponseReceived) -> Handler ResponseReceived)
routeResult <- Delayed
  env
  (Request
   -> (Response -> IO ResponseReceived) -> Handler ResponseReceived)
-> env
-> Request
-> ResourceT
     IO
     (RouteResult
        (Request
         -> (Response -> IO ResponseReceived) -> Handler ResponseReceived))
forall env a.
Delayed env a -> env -> Request -> ResourceT IO (RouteResult a)
runDelayed Delayed
  env
  (Request
   -> (Response -> IO ResponseReceived) -> Handler ResponseReceived)
handleDelayed env
env Request
request
    let respond' :: RouteResult Response -> IO ResponseReceived
respond' = IO ResponseReceived -> IO ResponseReceived
forall a. IO a -> IO a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO ResponseReceived -> IO ResponseReceived)
-> (RouteResult Response -> IO ResponseReceived)
-> RouteResult Response
-> IO ResponseReceived
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RouteResult Response -> IO ResponseReceived
respond
    IO ResponseReceived -> ResourceT IO ResponseReceived
forall a. IO a -> ResourceT IO a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO ResponseReceived -> ResourceT IO ResponseReceived)
-> IO ResponseReceived -> ResourceT IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ case RouteResult
  (Request
   -> (Response -> IO ResponseReceived) -> Handler ResponseReceived)
routeResult of
      Route Request
-> (Response -> IO ResponseReceived) -> Handler ResponseReceived
handler   -> Handler ResponseReceived
-> IO (Either ServerError ResponseReceived)
forall a. Handler a -> IO (Either ServerError a)
runHandler (Request
-> (Response -> IO ResponseReceived) -> Handler ResponseReceived
handler Request
request (RouteResult Response -> IO ResponseReceived
respond (RouteResult Response -> IO ResponseReceived)
-> (Response -> RouteResult Response)
-> Response
-> IO ResponseReceived
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> RouteResult Response
forall a. a -> RouteResult a
Route)) IO (Either ServerError ResponseReceived)
-> (Either ServerError ResponseReceived -> IO ResponseReceived)
-> IO ResponseReceived
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>=
        \case
           Left ServerError
e -> RouteResult Response -> IO ResponseReceived
respond' (RouteResult Response -> IO ResponseReceived)
-> RouteResult Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ ServerError -> RouteResult Response
forall a. ServerError -> RouteResult a
FailFatal ServerError
e
           Right ResponseReceived
a -> ResponseReceived -> IO ResponseReceived
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ResponseReceived
a
      Fail ServerError
e -> RouteResult Response -> IO ResponseReceived
respond' (RouteResult Response -> IO ResponseReceived)
-> RouteResult Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ ServerError -> RouteResult Response
forall a. ServerError -> RouteResult a
Fail ServerError
e
      FailFatal ServerError
e -> RouteResult Response -> IO ResponseReceived
respond' (RouteResult Response -> IO ResponseReceived)
-> RouteResult Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ ServerError -> RouteResult Response
forall a. ServerError -> RouteResult a
FailFatal ServerError
e

  hoistServerWithContext :: forall (m :: Type -> Type) (n :: Type -> Type).
Proxy RawM
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT RawM m
-> ServerT RawM n
hoistServerWithContext Proxy RawM
_ Proxy context
_ forall x. m x -> n x
f ServerT RawM m
srvM = \Request
req Response -> IO ResponseReceived
respond -> m ResponseReceived -> n ResponseReceived
forall x. m x -> n x
f (ServerT RawM m
Request -> (Response -> IO ResponseReceived) -> m ResponseReceived
srvM Request
req Response -> IO ResponseReceived
respond)


-- | If you use 'ReqBody' in one of the endpoints for your API,
-- this automatically requires your server-side handler to be a function
-- that takes an argument of the type specified by 'ReqBody'.
-- The @Content-Type@ header is inspected, and the list provided is used to
-- attempt deserialization. If the request does not have a @Content-Type@
-- header, it is treated as @application/octet-stream@ (as specified in
-- [RFC 7231 section 3.1.1.5](http://tools.ietf.org/html/rfc7231#section-3.1.1.5)).
-- This lets servant worry about extracting it from the request and turning
-- it into a value of the type you specify.
--
--
-- All it asks is for a 'FromJSON' instance.
--
-- Example:
--
-- > type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book
-- >
-- > server :: Server MyApi
-- > server = postBook
-- >   where postBook :: Book -> Handler Book
-- >         postBook book = ...insert into your db...
instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods)
         , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
         ) => HasServer (ReqBody' mods list a :> api) context where

  type ServerT (ReqBody' mods list a :> api) m =
    If (FoldLenient mods) (Either String a) a -> ServerT api m

  hoistServerWithContext :: forall (m :: Type -> Type) (n :: Type -> Type).
Proxy (ReqBody' mods list a :> api)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (ReqBody' mods list a :> api) m
-> ServerT (ReqBody' mods list a :> api) n
hoistServerWithContext Proxy (ReqBody' mods list a :> api)
_ Proxy context
pc forall x. m x -> n x
nt ServerT (ReqBody' mods list a :> api) m
s = Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall {k} (api :: k) (context :: [Type]) (m :: Type -> Type)
       (n :: Type -> Type).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall (m :: Type -> Type) (n :: Type -> Type).
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Proxy context
pc m x -> n x
forall x. m x -> n x
nt (ServerT api m -> ServerT api n)
-> (If (FoldLenient mods) (Either String a) a -> ServerT api m)
-> If (FoldLenient mods) (Either String a) a
-> ServerT api n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (ReqBody' mods list a :> api) m
If (FoldLenient mods) (Either String a) a -> ServerT api m
s

  route :: forall env.
Proxy (ReqBody' mods list a :> api)
-> Context context
-> Delayed env (Server (ReqBody' mods list a :> api))
-> Router env
route Proxy (ReqBody' mods list a :> api)
Proxy Context context
context Delayed env (Server (ReqBody' mods list a :> api))
subserver
      = Proxy api
-> Context context -> Delayed env (Server api) -> Router env
forall env.
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
forall {k} (api :: k) (context :: [Type]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Context context
context (Delayed env (Server api) -> Router env)
-> Delayed env (Server api) -> Router env
forall a b. (a -> b) -> a -> b
$
          Delayed
  env (If (FoldLenient mods) (Either String a) a -> Server api)
-> DelayedIO (ByteString -> Either String a)
-> ((ByteString -> Either String a)
    -> DelayedIO (If (FoldLenient mods) (Either String a) a))
-> Delayed env (Server api)
forall env a b c.
Delayed env (a -> b)
-> DelayedIO c -> (c -> DelayedIO a) -> Delayed env b
addBodyCheck Delayed env (Server (ReqBody' mods list a :> api))
Delayed
  env (If (FoldLenient mods) (Either String a) a -> Server api)
subserver DelayedIO (ByteString -> Either String a)
ctCheck (ByteString -> Either String a)
-> DelayedIO (If (FoldLenient mods) (Either String a) a)
bodyCheck
    where
      rep :: TypeRep
rep = Proxy ReqBody' -> TypeRep
forall {k} (proxy :: k -> Type) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy ReqBody'
forall {k} (t :: k). Proxy t
Proxy :: Proxy ReqBody')
      formatError :: ErrorFormatter
formatError = ErrorFormatters -> ErrorFormatter
bodyParserErrorFormatter (ErrorFormatters -> ErrorFormatter)
-> ErrorFormatters -> ErrorFormatter
forall a b. (a -> b) -> a -> b
$ Context (MkContextWithErrorFormatter context) -> ErrorFormatters
forall (context :: [Type]) val.
HasContextEntry context val =>
Context context -> val
getContextEntry (Context context -> Context (MkContextWithErrorFormatter context)
forall (ctx :: [Type]).
Context ctx -> Context (MkContextWithErrorFormatter ctx)
mkContextWithErrorFormatter Context context
context)

      -- Content-Type check, we only lookup we can try to parse the request body
      ctCheck :: DelayedIO (ByteString -> Either String a)
ctCheck = (Request -> DelayedIO (ByteString -> Either String a))
-> DelayedIO (ByteString -> Either String a)
forall a. (Request -> DelayedIO a) -> DelayedIO a
withRequest ((Request -> DelayedIO (ByteString -> Either String a))
 -> DelayedIO (ByteString -> Either String a))
-> (Request -> DelayedIO (ByteString -> Either String a))
-> DelayedIO (ByteString -> Either String a)
forall a b. (a -> b) -> a -> b
$ \ Request
request -> do
        -- See HTTP RFC 2616, section 7.2.1
        -- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
        -- See also "W3C Internet Media Type registration, consistency of use"
        -- http://www.w3.org/2001/tag/2002/0129-mime
        let contentTypeH :: ByteString
contentTypeH = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"application/octet-stream"
                         (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hContentType ([(HeaderName, ByteString)] -> Maybe ByteString)
-> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Request -> [(HeaderName, ByteString)]
requestHeaders Request
request
        case Proxy list -> ByteString -> Maybe (ByteString -> Either String a)
forall (list :: [Type]) a.
AllCTUnrender list a =>
Proxy list -> ByteString -> Maybe (ByteString -> Either String a)
canHandleCTypeH (Proxy list
forall {k} (t :: k). Proxy t
Proxy :: Proxy list) (ByteString -> ByteString
BSL.fromStrict ByteString
contentTypeH) :: Maybe (BSL.ByteString -> Either String a) of
          Maybe (ByteString -> Either String a)
Nothing -> ServerError -> DelayedIO (ByteString -> Either String a)
forall a. ServerError -> DelayedIO a
delayedFail ServerError
err415
          Just ByteString -> Either String a
f  -> (ByteString -> Either String a)
-> DelayedIO (ByteString -> Either String a)
forall a. a -> DelayedIO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ByteString -> Either String a
f

      -- Body check, we get a body parsing functions as the first argument.
      bodyCheck :: (ByteString -> Either String a)
-> DelayedIO (If (FoldLenient mods) (Either String a) a)
bodyCheck ByteString -> Either String a
f = (Request -> DelayedIO (If (FoldLenient mods) (Either String a) a))
-> DelayedIO (If (FoldLenient mods) (Either String a) a)
forall a. (Request -> DelayedIO a) -> DelayedIO a
withRequest ((Request -> DelayedIO (If (FoldLenient mods) (Either String a) a))
 -> DelayedIO (If (FoldLenient mods) (Either String a) a))
-> (Request
    -> DelayedIO (If (FoldLenient mods) (Either String a) a))
-> DelayedIO (If (FoldLenient mods) (Either String a) a)
forall a b. (a -> b) -> a -> b
$ \ Request
request -> do
        Either String a
mrqbody <- ByteString -> Either String a
f (ByteString -> Either String a)
-> DelayedIO ByteString -> DelayedIO (Either String a)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ByteString -> DelayedIO ByteString
forall a. IO a -> DelayedIO a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (Request -> IO ByteString
lazyRequestBody Request
request)
        case SBool (FoldLenient mods)
forall (b :: Bool). SBoolI b => SBool b
sbool :: SBool (FoldLenient mods) of
          SBool (FoldLenient mods)
STrue -> If (FoldLenient mods) (Either String a) a
-> DelayedIO (If (FoldLenient mods) (Either String a) a)
forall a. a -> DelayedIO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Either String a
If (FoldLenient mods) (Either String a) a
mrqbody
          SBool (FoldLenient mods)
SFalse -> case Either String a
mrqbody of
            Left String
e  -> ServerError
-> DelayedIO (If (FoldLenient mods) (Either String a) a)
forall a. ServerError -> DelayedIO a
delayedFailFatal (ServerError
 -> DelayedIO (If (FoldLenient mods) (Either String a) a))
-> ServerError
-> DelayedIO (If (FoldLenient mods) (Either String a) a)
forall a b. (a -> b) -> a -> b
$ ErrorFormatter
formatError TypeRep
rep Request
request String
e
            Right If (FoldLenient mods) (Either String a) a
v -> If (FoldLenient mods) (Either String a) a
-> DelayedIO (If (FoldLenient mods) (Either String a) a)
forall a. a -> DelayedIO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return If (FoldLenient mods) (Either String a) a
v

instance
    ( FramingUnrender framing, FromSourceIO chunk a, MimeUnrender ctype chunk
    , HasServer api context
    ) => HasServer (StreamBody' mods framing ctype a :> api) context
  where
    type ServerT (StreamBody' mods framing ctype a :> api) m = a -> ServerT api m

    hoistServerWithContext :: forall (m :: Type -> Type) (n :: Type -> Type).
Proxy (StreamBody' mods framing ctype a :> api)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (StreamBody' mods framing ctype a :> api) m
-> ServerT (StreamBody' mods framing ctype a :> api) n
hoistServerWithContext Proxy (StreamBody' mods framing ctype a :> api)
_ Proxy context
pc forall x. m x -> n x
nt ServerT (StreamBody' mods framing ctype a :> api) m
s = Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall {k} (api :: k) (context :: [Type]) (m :: Type -> Type)
       (n :: Type -> Type).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall (m :: Type -> Type) (n :: Type -> Type).
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Proxy context
pc m x -> n x
forall x. m x -> n x
nt (ServerT api m -> ServerT api n)
-> (a -> ServerT api m) -> a -> ServerT api n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (StreamBody' mods framing ctype a :> api) m
a -> ServerT api m
s

    route :: forall env.
Proxy (StreamBody' mods framing ctype a :> api)
-> Context context
-> Delayed env (Server (StreamBody' mods framing ctype a :> api))
-> Router env
route Proxy (StreamBody' mods framing ctype a :> api)
Proxy Context context
context Delayed env (Server (StreamBody' mods framing ctype a :> api))
subserver = Proxy api
-> Context context -> Delayed env (Server api) -> Router env
forall env.
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
forall {k} (api :: k) (context :: [Type]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Context context
context (Delayed env (Server api) -> Router env)
-> Delayed env (Server api) -> Router env
forall a b. (a -> b) -> a -> b
$
        Delayed env (a -> Server api)
-> DelayedIO (SourceIO chunk -> IO a)
-> ((SourceIO chunk -> IO a) -> DelayedIO a)
-> Delayed env (Server api)
forall env a b c.
Delayed env (a -> b)
-> DelayedIO c -> (c -> DelayedIO a) -> Delayed env b
addBodyCheck Delayed env (Server (StreamBody' mods framing ctype a :> api))
Delayed env (a -> Server api)
subserver DelayedIO (SourceIO chunk -> IO a)
ctCheck (SourceIO chunk -> IO a) -> DelayedIO a
bodyCheck
      where
        ctCheck :: DelayedIO (SourceIO chunk -> IO a)
        -- TODO: do content-type check
        ctCheck :: DelayedIO (SourceIO chunk -> IO a)
ctCheck = (SourceIO chunk -> IO a) -> DelayedIO (SourceIO chunk -> IO a)
forall a. a -> DelayedIO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return SourceIO chunk -> IO a
forall chunk a. FromSourceIO chunk a => SourceIO chunk -> IO a
fromSourceIO

        bodyCheck :: (SourceIO chunk -> IO a) -> DelayedIO a
        bodyCheck :: (SourceIO chunk -> IO a) -> DelayedIO a
bodyCheck SourceIO chunk -> IO a
fromRS = (Request -> DelayedIO a) -> DelayedIO a
forall a. (Request -> DelayedIO a) -> DelayedIO a
withRequest ((Request -> DelayedIO a) -> DelayedIO a)
-> (Request -> DelayedIO a) -> DelayedIO a
forall a b. (a -> b) -> a -> b
$ \Request
req -> do
            let mimeUnrender' :: ByteString -> Either String chunk
mimeUnrender'    = Proxy ctype -> ByteString -> Either String chunk
forall {k} (ctype :: k) a.
MimeUnrender ctype a =>
Proxy ctype -> ByteString -> Either String a
mimeUnrender (Proxy ctype
forall {k} (t :: k). Proxy t
Proxy :: Proxy ctype) :: BSL.ByteString -> Either String chunk
            let framingUnrender' :: SourceIO ByteString -> SourceIO chunk
framingUnrender' = Proxy framing
-> (ByteString -> Either String chunk)
-> SourceIO ByteString
-> SourceIO chunk
forall {k} (strategy :: k) (m :: Type -> Type) a.
(FramingUnrender strategy, Monad m) =>
Proxy strategy
-> (ByteString -> Either String a)
-> SourceT m ByteString
-> SourceT m a
forall (m :: Type -> Type) a.
Monad m =>
Proxy framing
-> (ByteString -> Either String a)
-> SourceT m ByteString
-> SourceT m a
framingUnrender (Proxy framing
forall {k} (t :: k). Proxy t
Proxy :: Proxy framing) ByteString -> Either String chunk
mimeUnrender' :: SourceIO B.ByteString ->  SourceIO chunk
            let body :: IO ByteString
body = Request -> IO ByteString
getRequestBodyChunk Request
req
            let rs :: SourceIO ByteString
rs = (ByteString -> Bool) -> IO ByteString -> SourceIO ByteString
forall (m :: Type -> Type) a.
Functor m =>
(a -> Bool) -> m a -> SourceT m a
S.fromAction ByteString -> Bool
B.null IO ByteString
body
            IO a -> DelayedIO a
forall a. IO a -> DelayedIO a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO a -> DelayedIO a) -> IO a -> DelayedIO a
forall a b. (a -> b) -> a -> b
$ SourceIO chunk -> IO a
fromRS (SourceIO chunk -> IO a) -> SourceIO chunk -> IO a
forall a b. (a -> b) -> a -> b
$ SourceIO ByteString -> SourceIO chunk
framingUnrender' SourceIO ByteString
rs

-- | Make sure the incoming request starts with @"/path"@, strip it and
-- pass the rest of the request path to @api@.
instance (KnownSymbol path, HasServer api context) => HasServer (path :> api) context where

  type ServerT (path :> api) m = ServerT api m

  route :: forall env.
Proxy (path :> api)
-> Context context
-> Delayed env (Server (path :> api))
-> Router env
route Proxy (path :> api)
Proxy Context context
context Delayed env (Server (path :> api))
subserver =
    Text
-> Router' env RoutingApplication -> Router' env RoutingApplication
forall env a. Text -> Router' env a -> Router' env a
pathRouter
      (String -> Text
T.pack (Proxy path -> String
forall (n :: Symbol) (proxy :: Symbol -> Type).
KnownSymbol n =>
proxy n -> String
symbolVal Proxy path
proxyPath))
      (Proxy api
-> Context context
-> Delayed env (Server api)
-> Router' env RoutingApplication
forall env.
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
forall {k} (api :: k) (context :: [Type]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Context context
context Delayed env (Server api)
Delayed env (Server (path :> api))
subserver)
    where proxyPath :: Proxy path
proxyPath = Proxy path
forall {k} (t :: k). Proxy t
Proxy :: Proxy path
  hoistServerWithContext :: forall (m :: Type -> Type) (n :: Type -> Type).
Proxy (path :> api)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (path :> api) m
-> ServerT (path :> api) n
hoistServerWithContext Proxy (path :> api)
_ Proxy context
pc forall x. m x -> n x
nt ServerT (path :> api) m
s = Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall {k} (api :: k) (context :: [Type]) (m :: Type -> Type)
       (n :: Type -> Type).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall (m :: Type -> Type) (n :: Type -> Type).
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Proxy context
pc m x -> n x
forall x. m x -> n x
nt ServerT api m
ServerT (path :> api) m
s

instance HasServer api context => HasServer (RemoteHost :> api) context where
  type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m

  route :: forall env.
Proxy (RemoteHost :> api)
-> Context context
-> Delayed env (Server (RemoteHost :> api))
-> Router env
route Proxy (RemoteHost :> api)
Proxy Context context
context Delayed env (Server (RemoteHost :> api))
subserver =
    Proxy api
-> Context context -> Delayed env (Server api) -> Router env
forall env.
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
forall {k} (api :: k) (context :: [Type]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Context context
context (Delayed env (SockAddr -> Server api)
-> (Request -> SockAddr) -> Delayed env (Server api)
forall env a b.
Delayed env (a -> b) -> (Request -> a) -> Delayed env b
passToServer Delayed env (Server (RemoteHost :> api))
Delayed env (SockAddr -> Server api)
subserver Request -> SockAddr
remoteHost)
  hoistServerWithContext :: forall (m :: Type -> Type) (n :: Type -> Type).
Proxy (RemoteHost :> api)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (RemoteHost :> api) m
-> ServerT (RemoteHost :> api) n
hoistServerWithContext Proxy (RemoteHost :> api)
_ Proxy context
pc forall x. m x -> n x
nt ServerT (RemoteHost :> api) m
s = Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall {k} (api :: k) (context :: [Type]) (m :: Type -> Type)
       (n :: Type -> Type).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall (m :: Type -> Type) (n :: Type -> Type).
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Proxy context
pc m x -> n x
forall x. m x -> n x
nt (ServerT api m -> ServerT api n)
-> (SockAddr -> ServerT api m) -> SockAddr -> ServerT api n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (RemoteHost :> api) m
SockAddr -> ServerT api m
s

instance HasServer api context => HasServer (IsSecure :> api) context where
  type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m

  route :: forall env.
Proxy (IsSecure :> api)
-> Context context
-> Delayed env (Server (IsSecure :> api))
-> Router env
route Proxy (IsSecure :> api)
Proxy Context context
context Delayed env (Server (IsSecure :> api))
subserver =
    Proxy api
-> Context context -> Delayed env (Server api) -> Router env
forall env.
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
forall {k} (api :: k) (context :: [Type]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Context context
context (Delayed env (IsSecure -> Server api)
-> (Request -> IsSecure) -> Delayed env (Server api)
forall env a b.
Delayed env (a -> b) -> (Request -> a) -> Delayed env b
passToServer Delayed env (Server (IsSecure :> api))
Delayed env (IsSecure -> Server api)
subserver Request -> IsSecure
secure)
    where secure :: Request -> IsSecure
secure Request
req = if Request -> Bool
isSecure Request
req then IsSecure
Secure else IsSecure
NotSecure

  hoistServerWithContext :: forall (m :: Type -> Type) (n :: Type -> Type).
Proxy (IsSecure :> api)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (IsSecure :> api) m
-> ServerT (IsSecure :> api) n
hoistServerWithContext Proxy (IsSecure :> api)
_ Proxy context
pc forall x. m x -> n x
nt ServerT (IsSecure :> api) m
s = Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall {k} (api :: k) (context :: [Type]) (m :: Type -> Type)
       (n :: Type -> Type).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall (m :: Type -> Type) (n :: Type -> Type).
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Proxy context
pc m x -> n x
forall x. m x -> n x
nt (ServerT api m -> ServerT api n)
-> (IsSecure -> ServerT api m) -> IsSecure -> ServerT api n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (IsSecure :> api) m
IsSecure -> ServerT api m
s

instance HasServer api context => HasServer (Vault :> api) context where
  type ServerT (Vault :> api) m = Vault -> ServerT api m

  route :: forall env.
Proxy (Vault :> api)
-> Context context
-> Delayed env (Server (Vault :> api))
-> Router env
route Proxy (Vault :> api)
Proxy Context context
context Delayed env (Server (Vault :> api))
subserver =
    Proxy api
-> Context context -> Delayed env (Server api) -> Router env
forall env.
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
forall {k} (api :: k) (context :: [Type]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Context context
context (Delayed env (Vault -> Server api)
-> (Request -> Vault) -> Delayed env (Server api)
forall env a b.
Delayed env (a -> b) -> (Request -> a) -> Delayed env b
passToServer Delayed env (Server (Vault :> api))
Delayed env (Vault -> Server api)
subserver Request -> Vault
vault)
  hoistServerWithContext :: forall (m :: Type -> Type) (n :: Type -> Type).
Proxy (Vault :> api)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (Vault :> api) m
-> ServerT (Vault :> api) n
hoistServerWithContext Proxy (Vault :> api)
_ Proxy context
pc forall x. m x -> n x
nt ServerT (Vault :> api) m
s = Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall {k} (api :: k) (context :: [Type]) (m :: Type -> Type)
       (n :: Type -> Type).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall (m :: Type -> Type) (n :: Type -> Type).
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Proxy context
pc m x -> n x
forall x. m x -> n x
nt (ServerT api m -> ServerT api n)
-> (Vault -> ServerT api m) -> Vault -> ServerT api n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (Vault :> api) m
Vault -> ServerT api m
s

instance HasServer api context => HasServer (HttpVersion :> api) context where
  type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m

  route :: forall env.
Proxy (HttpVersion :> api)
-> Context context
-> Delayed env (Server (HttpVersion :> api))
-> Router env
route Proxy (HttpVersion :> api)
Proxy Context context
context Delayed env (Server (HttpVersion :> api))
subserver =
    Proxy api
-> Context context -> Delayed env (Server api) -> Router env
forall env.
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
forall {k} (api :: k) (context :: [Type]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Context context
context (Delayed env (HttpVersion -> Server api)
-> (Request -> HttpVersion) -> Delayed env (Server api)
forall env a b.
Delayed env (a -> b) -> (Request -> a) -> Delayed env b
passToServer Delayed env (Server (HttpVersion :> api))
Delayed env (HttpVersion -> Server api)
subserver Request -> HttpVersion
httpVersion)
  hoistServerWithContext :: forall (m :: Type -> Type) (n :: Type -> Type).
Proxy (HttpVersion :> api)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (HttpVersion :> api) m
-> ServerT (HttpVersion :> api) n
hoistServerWithContext Proxy (HttpVersion :> api)
_ Proxy context
pc forall x. m x -> n x
nt ServerT (HttpVersion :> api) m
s = Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall {k} (api :: k) (context :: [Type]) (m :: Type -> Type)
       (n :: Type -> Type).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall (m :: Type -> Type) (n :: Type -> Type).
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Proxy context
pc m x -> n x
forall x. m x -> n x
nt (ServerT api m -> ServerT api n)
-> (HttpVersion -> ServerT api m) -> HttpVersion -> ServerT api n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (HttpVersion :> api) m
HttpVersion -> ServerT api m
s

-- | Ignore @'Summary'@ in server handlers.
instance HasServer api ctx => HasServer (Summary desc :> api) ctx where
  type ServerT (Summary desc :> api) m = ServerT api m

  route :: forall env.
Proxy (Summary desc :> api)
-> Context ctx
-> Delayed env (Server (Summary desc :> api))
-> Router env
route Proxy (Summary desc :> api)
_ = Proxy api
-> Context ctx
-> Delayed env (Server api)
-> Router' env RoutingApplication
forall env.
Proxy api -> Context ctx -> Delayed env (Server api) -> Router env
forall {k} (api :: k) (context :: [Type]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api)
  hoistServerWithContext :: forall (m :: Type -> Type) (n :: Type -> Type).
Proxy (Summary desc :> api)
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT (Summary desc :> api) m
-> ServerT (Summary desc :> api) n
hoistServerWithContext Proxy (Summary desc :> api)
_ Proxy ctx
pc forall x. m x -> n x
nt ServerT (Summary desc :> api) m
s = Proxy api
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall {k} (api :: k) (context :: [Type]) (m :: Type -> Type)
       (n :: Type -> Type).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall (m :: Type -> Type) (n :: Type -> Type).
Proxy api
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Proxy ctx
pc m x -> n x
forall x. m x -> n x
nt ServerT api m
ServerT (Summary desc :> api) m
s

-- | Ignore @'Description'@ in server handlers.
instance HasServer api ctx => HasServer (Description desc :> api) ctx where
  type ServerT (Description desc :> api) m = ServerT api m

  route :: forall env.
Proxy (Description desc :> api)
-> Context ctx
-> Delayed env (Server (Description desc :> api))
-> Router env
route Proxy (Description desc :> api)
_ = Proxy api
-> Context ctx
-> Delayed env (Server api)
-> Router' env RoutingApplication
forall env.
Proxy api -> Context ctx -> Delayed env (Server api) -> Router env
forall {k} (api :: k) (context :: [Type]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api)
  hoistServerWithContext :: forall (m :: Type -> Type) (n :: Type -> Type).
Proxy (Description desc :> api)
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT (Description desc :> api) m
-> ServerT (Description desc :> api) n
hoistServerWithContext Proxy (Description desc :> api)
_ Proxy ctx
pc forall x. m x -> n x
nt ServerT (Description desc :> api) m
s = Proxy api
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall {k} (api :: k) (context :: [Type]) (m :: Type -> Type)
       (n :: Type -> Type).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall (m :: Type -> Type) (n :: Type -> Type).
Proxy api
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Proxy ctx
pc m x -> n x
forall x. m x -> n x
nt ServerT api m
ServerT (Description desc :> api) m
s

-- | Singleton type representing a server that serves an empty API.
data EmptyServer = EmptyServer deriving (Typeable, EmptyServer -> EmptyServer -> Bool
(EmptyServer -> EmptyServer -> Bool)
-> (EmptyServer -> EmptyServer -> Bool) -> Eq EmptyServer
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EmptyServer -> EmptyServer -> Bool
== :: EmptyServer -> EmptyServer -> Bool
$c/= :: EmptyServer -> EmptyServer -> Bool
/= :: EmptyServer -> EmptyServer -> Bool
Eq, Int -> EmptyServer -> String -> String
[EmptyServer] -> String -> String
EmptyServer -> String
(Int -> EmptyServer -> String -> String)
-> (EmptyServer -> String)
-> ([EmptyServer] -> String -> String)
-> Show EmptyServer
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> EmptyServer -> String -> String
showsPrec :: Int -> EmptyServer -> String -> String
$cshow :: EmptyServer -> String
show :: EmptyServer -> String
$cshowList :: [EmptyServer] -> String -> String
showList :: [EmptyServer] -> String -> String
Show, EmptyServer
EmptyServer -> EmptyServer -> Bounded EmptyServer
forall a. a -> a -> Bounded a
$cminBound :: EmptyServer
minBound :: EmptyServer
$cmaxBound :: EmptyServer
maxBound :: EmptyServer
Bounded, Int -> EmptyServer
EmptyServer -> Int
EmptyServer -> [EmptyServer]
EmptyServer -> EmptyServer
EmptyServer -> EmptyServer -> [EmptyServer]
EmptyServer -> EmptyServer -> EmptyServer -> [EmptyServer]
(EmptyServer -> EmptyServer)
-> (EmptyServer -> EmptyServer)
-> (Int -> EmptyServer)
-> (EmptyServer -> Int)
-> (EmptyServer -> [EmptyServer])
-> (EmptyServer -> EmptyServer -> [EmptyServer])
-> (EmptyServer -> EmptyServer -> [EmptyServer])
-> (EmptyServer -> EmptyServer -> EmptyServer -> [EmptyServer])
-> Enum EmptyServer
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: EmptyServer -> EmptyServer
succ :: EmptyServer -> EmptyServer
$cpred :: EmptyServer -> EmptyServer
pred :: EmptyServer -> EmptyServer
$ctoEnum :: Int -> EmptyServer
toEnum :: Int -> EmptyServer
$cfromEnum :: EmptyServer -> Int
fromEnum :: EmptyServer -> Int
$cenumFrom :: EmptyServer -> [EmptyServer]
enumFrom :: EmptyServer -> [EmptyServer]
$cenumFromThen :: EmptyServer -> EmptyServer -> [EmptyServer]
enumFromThen :: EmptyServer -> EmptyServer -> [EmptyServer]
$cenumFromTo :: EmptyServer -> EmptyServer -> [EmptyServer]
enumFromTo :: EmptyServer -> EmptyServer -> [EmptyServer]
$cenumFromThenTo :: EmptyServer -> EmptyServer -> EmptyServer -> [EmptyServer]
enumFromThenTo :: EmptyServer -> EmptyServer -> EmptyServer -> [EmptyServer]
Enum)

-- | Server for `EmptyAPI`
emptyServer :: ServerT EmptyAPI m
emptyServer :: forall (m :: Type -> Type). ServerT EmptyAPI m
emptyServer = EmptyServer -> Tagged m EmptyServer
forall {k} (s :: k) b. b -> Tagged s b
Tagged EmptyServer
EmptyServer

-- | The server for an `EmptyAPI` is `emptyServer`.
--
-- > type MyApi = "nothing" :> EmptyApi
-- >
-- > server :: Server MyApi
-- > server = emptyServer
instance HasServer EmptyAPI context where
  type ServerT EmptyAPI m = Tagged m EmptyServer

  route :: forall env.
Proxy EmptyAPI
-> Context context -> Delayed env (Server EmptyAPI) -> Router env
route Proxy EmptyAPI
Proxy Context context
_ Delayed env (Server EmptyAPI)
_ = Map Text (Router' env RoutingApplication)
-> [env -> RoutingApplication] -> Router' env RoutingApplication
forall env a.
Map Text (Router' env a) -> [env -> a] -> Router' env a
StaticRouter Map Text (Router' env RoutingApplication)
forall a. Monoid a => a
mempty [env -> RoutingApplication]
forall a. Monoid a => a
mempty

  hoistServerWithContext :: forall (m :: Type -> Type) (n :: Type -> Type).
Proxy EmptyAPI
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT EmptyAPI m
-> ServerT EmptyAPI n
hoistServerWithContext Proxy EmptyAPI
_ Proxy context
_ forall x. m x -> n x
_ = Tagged m EmptyServer -> Tagged n EmptyServer
ServerT EmptyAPI m -> ServerT EmptyAPI n
forall {k1} {k2} (s :: k1) b (t :: k2). Tagged s b -> Tagged t b
retag

-- | Ignore @'EmptyAPI'@ as part of route in server handlers.
instance HasServer api context => HasServer (EmptyAPI :> api) context where
  type ServerT (EmptyAPI :> api) m = ServerT api m

  route :: forall env.
Proxy (EmptyAPI :> api)
-> Context context
-> Delayed env (Server (EmptyAPI :> api))
-> Router env
route Proxy (EmptyAPI :> api)
_ = Proxy api
-> Context context
-> Delayed env (Server api)
-> Router' env RoutingApplication
forall env.
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
forall {k} (api :: k) (context :: [Type]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api)
  hoistServerWithContext :: forall (m :: Type -> Type) (n :: Type -> Type).
Proxy (EmptyAPI :> api)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (EmptyAPI :> api) m
-> ServerT (EmptyAPI :> api) n
hoistServerWithContext Proxy (EmptyAPI :> api)
_ = Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall {k} (api :: k) (context :: [Type]) (m :: Type -> Type)
       (n :: Type -> Type).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall (m :: Type -> Type) (n :: Type -> Type).
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api)

-- | Basic Authentication
instance ( KnownSymbol realm
         , HasServer api context
         , HasContextEntry context (BasicAuthCheck usr)
         )
    => HasServer (BasicAuth realm usr :> api) context where

  type ServerT (BasicAuth realm usr :> api) m = usr -> ServerT api m

  route :: forall env.
Proxy (BasicAuth realm usr :> api)
-> Context context
-> Delayed env (Server (BasicAuth realm usr :> api))
-> Router env
route Proxy (BasicAuth realm usr :> api)
Proxy Context context
context Delayed env (Server (BasicAuth realm usr :> api))
subserver =
    Proxy api
-> Context context -> Delayed env (Server api) -> Router env
forall env.
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
forall {k} (api :: k) (context :: [Type]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Context context
context (Delayed env (Server (BasicAuth realm usr :> api))
Delayed env (usr -> Server api)
subserver Delayed env (usr -> Server api)
-> DelayedIO usr -> Delayed env (Server api)
forall env a b.
Delayed env (a -> b) -> DelayedIO a -> Delayed env b
`addAuthCheck` DelayedIO usr
authCheck)
    where
       realm :: ByteString
realm = String -> ByteString
BC8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Proxy realm -> String
forall (n :: Symbol) (proxy :: Symbol -> Type).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy realm
forall {k} (t :: k). Proxy t
Proxy :: Proxy realm)
       basicAuthContext :: BasicAuthCheck usr
basicAuthContext = Context context -> BasicAuthCheck usr
forall (context :: [Type]) val.
HasContextEntry context val =>
Context context -> val
getContextEntry Context context
context
       authCheck :: DelayedIO usr
authCheck = (Request -> DelayedIO usr) -> DelayedIO usr
forall a. (Request -> DelayedIO a) -> DelayedIO a
withRequest ((Request -> DelayedIO usr) -> DelayedIO usr)
-> (Request -> DelayedIO usr) -> DelayedIO usr
forall a b. (a -> b) -> a -> b
$ \ Request
req -> Request -> ByteString -> BasicAuthCheck usr -> DelayedIO usr
forall usr.
Request -> ByteString -> BasicAuthCheck usr -> DelayedIO usr
runBasicAuth Request
req ByteString
realm BasicAuthCheck usr
basicAuthContext

  hoistServerWithContext :: forall (m :: Type -> Type) (n :: Type -> Type).
Proxy (BasicAuth realm usr :> api)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (BasicAuth realm usr :> api) m
-> ServerT (BasicAuth realm usr :> api) n
hoistServerWithContext Proxy (BasicAuth realm usr :> api)
_ Proxy context
pc forall x. m x -> n x
nt ServerT (BasicAuth realm usr :> api) m
s = Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall {k} (api :: k) (context :: [Type]) (m :: Type -> Type)
       (n :: Type -> Type).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall (m :: Type -> Type) (n :: Type -> Type).
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Proxy context
pc m x -> n x
forall x. m x -> n x
nt (ServerT api m -> ServerT api n)
-> (usr -> ServerT api m) -> usr -> ServerT api n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (BasicAuth realm usr :> api) m
usr -> ServerT api m
s

-- * helpers

ct_wildcard :: B.ByteString
ct_wildcard :: ByteString
ct_wildcard = ByteString
"*" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"/" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"*"

getAcceptHeader :: Request -> AcceptHeader
getAcceptHeader :: Request -> AcceptHeader
getAcceptHeader = ByteString -> AcceptHeader
AcceptHeader (ByteString -> AcceptHeader)
-> (Request -> ByteString) -> Request -> AcceptHeader
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
ct_wildcard (Maybe ByteString -> ByteString)
-> (Request -> Maybe ByteString) -> Request -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hAccept ([(HeaderName, ByteString)] -> Maybe ByteString)
-> (Request -> [(HeaderName, ByteString)])
-> Request
-> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> [(HeaderName, ByteString)]
requestHeaders

-- * General Authentication


-- * contexts

instance (HasContextEntry context (NamedContext name subContext), HasServer subApi subContext)
  => HasServer (WithNamedContext name subContext subApi) context where

  type ServerT (WithNamedContext name subContext subApi) m =
    ServerT subApi m

  route :: forall env.
Proxy (WithNamedContext name subContext subApi)
-> Context context
-> Delayed env (Server (WithNamedContext name subContext subApi))
-> Router env
route Proxy (WithNamedContext name subContext subApi)
Proxy Context context
context Delayed env (Server (WithNamedContext name subContext subApi))
delayed =
    Proxy subApi
-> Context subContext -> Delayed env (Server subApi) -> Router env
forall env.
Proxy subApi
-> Context subContext -> Delayed env (Server subApi) -> Router env
forall {k} (api :: k) (context :: [Type]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route Proxy subApi
subProxy Context subContext
subContext Delayed env (Server subApi)
Delayed env (Server (WithNamedContext name subContext subApi))
delayed
    where
      subProxy :: Proxy subApi
      subProxy :: Proxy subApi
subProxy = Proxy subApi
forall {k} (t :: k). Proxy t
Proxy

      subContext :: Context subContext
      subContext :: Context subContext
subContext = Proxy name -> Context context -> Context subContext
forall (context :: [Type]) (name :: Symbol) (subContext :: [Type]).
HasContextEntry context (NamedContext name subContext) =>
Proxy name -> Context context -> Context subContext
descendIntoNamedContext (Proxy name
forall {k} (t :: k). Proxy t
Proxy :: Proxy name) Context context
context

  hoistServerWithContext :: forall (m :: Type -> Type) (n :: Type -> Type).
Proxy (WithNamedContext name subContext subApi)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (WithNamedContext name subContext subApi) m
-> ServerT (WithNamedContext name subContext subApi) n
hoistServerWithContext Proxy (WithNamedContext name subContext subApi)
_ Proxy context
_ forall x. m x -> n x
nt ServerT (WithNamedContext name subContext subApi) m
s = Proxy subApi
-> Proxy subContext
-> (forall x. m x -> n x)
-> ServerT subApi m
-> ServerT subApi n
forall {k} (api :: k) (context :: [Type]) (m :: Type -> Type)
       (n :: Type -> Type).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall (m :: Type -> Type) (n :: Type -> Type).
Proxy subApi
-> Proxy subContext
-> (forall x. m x -> n x)
-> ServerT subApi m
-> ServerT subApi n
hoistServerWithContext (Proxy subApi
forall {k} (t :: k). Proxy t
Proxy :: Proxy subApi) (Proxy subContext
forall {k} (t :: k). Proxy t
Proxy :: Proxy subContext) m x -> n x
forall x. m x -> n x
nt ServerT subApi m
ServerT (WithNamedContext name subContext subApi) m
s

-------------------------------------------------------------------------------
-- Custom type errors
-------------------------------------------------------------------------------

-- Erroring instance for 'HasServer' when a combinator is not fully applied
instance TypeError (PartialApplication

                    @(Type -> [Type] -> Constraint)

                    HasServer arr) => HasServer ((arr :: a -> b) :> sub) context
  where
    type ServerT (arr :> sub) _ = TypeError (PartialApplication (HasServer :: Type -> [Type] -> Constraint) arr)
    route :: forall env.
Proxy (arr :> sub)
-> Context context
-> Delayed env (Server (arr :> sub))
-> Router env
route = String
-> Proxy (arr :> sub)
-> Context context
-> Delayed env (TypeError ...)
-> Router' env RoutingApplication
forall a. HasCallStack => String -> a
error String
"unreachable"
    hoistServerWithContext :: forall (m :: Type -> Type) (n :: Type -> Type).
Proxy (arr :> sub)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (arr :> sub) m
-> ServerT (arr :> sub) n
hoistServerWithContext Proxy (arr :> sub)
_ Proxy context
_ forall x. m x -> n x
_ ServerT (arr :> sub) m
_ = String -> (TypeError ...)
forall a. HasCallStack => String -> a
error String
"unreachable"

-- | This instance prevents from accidentally using '->' instead of ':>'
--
-- >>> serve (Proxy :: Proxy (Capture "foo" Int -> Get '[JSON] Int)) (error "...")
-- ...
-- ...No instance HasServer (a -> b).
-- ...Maybe you have used '->' instead of ':>' between
-- ...Capture' '[] "foo" Int
-- ...and
-- ...Verb 'GET 200 '[JSON] Int
-- ...
--
-- >>> undefined :: Server (Capture "foo" Int -> Get '[JSON] Int)
-- ...
-- ...No instance HasServer (a -> b).
-- ...Maybe you have used '->' instead of ':>' between
-- ...Capture' '[] "foo" Int
-- ...and
-- ...Verb 'GET 200 '[JSON] Int
-- ...
--
instance TypeError (HasServerArrowTypeError a b) => HasServer (a -> b) context
  where
    type ServerT (a -> b) m = TypeError (HasServerArrowTypeError a b)
    route :: forall env.
Proxy (a -> b)
-> Context context -> Delayed env (Server (a -> b)) -> Router env
route Proxy (a -> b)
_ Context context
_ Delayed env (Server (a -> b))
_ = String -> Router env
forall a. HasCallStack => String -> a
error String
"servant-server panic: impossible happened in HasServer (a -> b)"
    hoistServerWithContext :: forall (m :: Type -> Type) (n :: Type -> Type).
Proxy (a -> b)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (a -> b) m
-> ServerT (a -> b) n
hoistServerWithContext Proxy (a -> b)
_ Proxy context
_ forall x. m x -> n x
_ = (TypeError ...) -> (TypeError ...)
ServerT (a -> b) m -> ServerT (a -> b) n
forall a. a -> a
id

type HasServerArrowTypeError a b =
    'Text "No instance HasServer (a -> b)."
    ':$$: 'Text "Maybe you have used '->' instead of ':>' between "
    ':$$: 'ShowType a
    ':$$: 'Text "and"
    ':$$: 'ShowType b

-- Erroring instances for 'HasServer' for unknown API combinators

-- XXX: This omits the @context@ parameter, e.g.:
--
-- "There is no instance for HasServer (Bool :> …)". Do we care ?
instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub

                                         @(Type -> [Type] -> Constraint)

                                         HasServer ty) => HasServer (ty :> sub) context

instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasServer api context)) => HasServer api context

-- | Ignore @'Fragment'@ in server handlers.
-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.
--
-- Example:
--
-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book]
-- >
-- > server :: Server MyApi
-- > server = getBooks
-- >   where getBooks :: Handler [Book]
-- >         getBooks = ...return all books...
instance (AtMostOneFragment api, FragmentUnique (Fragment a1 :> api), HasServer api context)
    => HasServer (Fragment a1 :> api) context where
  type ServerT (Fragment a1 :> api) m = ServerT api m

  route :: forall env.
Proxy (Fragment a1 :> api)
-> Context context
-> Delayed env (Server (Fragment a1 :> api))
-> Router env
route Proxy (Fragment a1 :> api)
_ = Proxy api
-> Context context
-> Delayed env (Server api)
-> Router' env RoutingApplication
forall env.
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
forall {k} (api :: k) (context :: [Type]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api)

  hoistServerWithContext :: forall (m :: Type -> Type) (n :: Type -> Type).
Proxy (Fragment a1 :> api)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (Fragment a1 :> api) m
-> ServerT (Fragment a1 :> api) n
hoistServerWithContext Proxy (Fragment a1 :> api)
_ = Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall {k} (api :: k) (context :: [Type]) (m :: Type -> Type)
       (n :: Type -> Type).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall (m :: Type -> Type) (n :: Type -> Type).
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api)

-- $setup
-- >>> import Servant

-- | A type that specifies that an API record contains a server implementation.
data AsServerT (m :: Type -> Type)
instance GenericMode (AsServerT m) where
    type AsServerT m :- api = ServerT api m

type AsServer = AsServerT Handler


-- | Set of constraints required to convert to / from vanilla server types.
type GServerConstraints api m =
  ( ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m
  , GServantProduct (Rep (api (AsServerT m)))
  )

-- | This class is a necessary evil: in the implementation of 'HasServer' for
--  @'NamedRoutes' api@, we essentially need the quantified constraint @forall
--  m. 'GServerConstraints' m@ to hold.
--
-- We cannot require do that directly as the definition of 'GServerConstraints'
-- contains type family applications ('Rep' and 'ServerT'). The trick is to hide
-- those type family applications behind a typeclass providing evidence for
-- @'GServerConstraints' api m@ in the form of a dictionary, and require that
-- @forall m. 'GServer' api m@ instead.
--
-- Users shouldn't have to worry about this class, as the only possible instance
-- is provided in this module for all record APIs.

class GServer (api :: Type -> Type) (m :: Type -> Type) where
  gServerProof :: Dict (GServerConstraints api m)

instance
  ( ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m
  , GServantProduct (Rep (api (AsServerT m)))
  ) => GServer api m where
  gServerProof :: Dict (GServerConstraints api m)
gServerProof = Dict (GServerConstraints api m)
Dict
  (ServerT (ToServantApi api) m ~ ServerT (ToServantApi api) m,
   GServantProduct (Rep (api (AsServerT m))))
forall (a :: Constraint). a => Dict a
Dict

instance
  ( HasServer (ToServantApi api) context
  , forall m. Generic (api (AsServerT m))
  , forall m. GServer api m
  , ErrorIfNoGeneric api
  ) => HasServer (NamedRoutes api) context where

  type ServerT (NamedRoutes api) m = api (AsServerT m)

  route
    :: Proxy (NamedRoutes api)
    -> Context context
    -> Delayed env (api (AsServerT Handler))
    -> Router env
  route :: forall env.
Proxy (NamedRoutes api)
-> Context context
-> Delayed env (api (AsServerT Handler))
-> Router env
route Proxy (NamedRoutes api)
_ Context context
ctx Delayed env (api (AsServerT Handler))
delayed =
    case forall (api :: Type -> Type) (m :: Type -> Type).
GServer api m =>
Dict (GServerConstraints api m)
gServerProof @api @Handler of
      Dict (GServerConstraints api Handler)
Dict -> Proxy (ToServantApi api)
-> Context context
-> Delayed env (ServerT (ToServantApi api) Handler)
-> Router env
forall env.
Proxy (ToServantApi api)
-> Context context
-> Delayed env (ServerT (ToServantApi api) Handler)
-> Router env
forall {k} (api :: k) (context :: [Type]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(ToServantApi api)) Context context
ctx (api (AsServerT Handler) -> ToServant api (AsServerT Handler)
api (AsServerT Handler) -> ServerT (ToServantApi api) Handler
forall {k} (routes :: k -> Type) (mode :: k).
GenericServant routes mode =>
routes mode -> ToServant routes mode
toServant (api (AsServerT Handler) -> ServerT (ToServantApi api) Handler)
-> Delayed env (api (AsServerT Handler))
-> Delayed env (ServerT (ToServantApi api) Handler)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Delayed env (api (AsServerT Handler))
delayed)

  hoistServerWithContext
    :: forall m n. Proxy (NamedRoutes api)
    -> Proxy context
    -> (forall x. m x -> n x)
    -> api (AsServerT m)
    -> api (AsServerT n)
  hoistServerWithContext :: forall (m :: Type -> Type) (n :: Type -> Type).
Proxy (NamedRoutes api)
-> Proxy context
-> (forall x. m x -> n x)
-> api (AsServerT m)
-> api (AsServerT n)
hoistServerWithContext Proxy (NamedRoutes api)
_ Proxy context
pctx forall x. m x -> n x
nat api (AsServerT m)
server =
    case (forall (api :: Type -> Type) (m :: Type -> Type).
GServer api m =>
Dict (GServerConstraints api m)
gServerProof @api @m, forall (api :: Type -> Type) (m :: Type -> Type).
GServer api m =>
Dict (GServerConstraints api m)
gServerProof @api @n) of
      (Dict (GServerConstraints api m)
Dict, Dict (GServerConstraints api n)
Dict) ->
        GToServant (Rep (api (AsServerT n))) -> api (AsServerT n)
forall {k} (routes :: k -> Type) (mode :: k).
GenericServant routes mode =>
ToServant routes mode -> routes mode
fromServant GToServant (Rep (api (AsServerT n)))
ServerT (ToServantApi api) n
servantSrvN
        where
          ServerT (ToServantApi api) m
servantSrvM :: ServerT (ToServantApi api) m =
            api (AsServerT m) -> GToServant (Rep (api (AsServerT m)))
forall {k} (routes :: k -> Type) (mode :: k).
GenericServant routes mode =>
routes mode -> ToServant routes mode
toServant api (AsServerT m)
server
          ServerT (ToServantApi api) n
servantSrvN :: ServerT (ToServantApi api) n =
            Proxy (ToServantApi api)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (ToServantApi api) m
-> ServerT (ToServantApi api) n
forall {k} (api :: k) (context :: [Type]) (m :: Type -> Type)
       (n :: Type -> Type).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall (m :: Type -> Type) (n :: Type -> Type).
Proxy (ToServantApi api)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (ToServantApi api) m
-> ServerT (ToServantApi api) n
hoistServerWithContext (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(ToServantApi api)) Proxy context
pctx m x -> n x
forall x. m x -> n x
nat ServerT (ToServantApi api) m
servantSrvM