{-# LANGUAGE AllowAmbiguousTypes   #-}
{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE CPP                   #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveDataTypeable    #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE InstanceSigs          #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE PolyKinds             #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TupleSections         #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UndecidableInstances  #-}

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 BL
import           Data.Constraint (Constraint, Dict(..))
import           Data.Either
                 (partitionEithers)
import           Data.Maybe
                 (fromMaybe, isNothing, mapMaybe, maybeToList)
import           Data.String
                 (IsString (..))
import           Data.String.Conversions
                 (cs)
import           Data.Tagged
                 (Tagged (..), retag, untag)
import qualified Data.Text                                  as T
import           Data.Typeable
import           GHC.Generics
import           GHC.TypeLits
                 (KnownNat, KnownSymbol, TypeError, 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           Prelude ()
import           Prelude.Compat
import           Servant.API
                 ((:<|>) (..), (:>), Accept (..), BasicAuth, Capture',
                 CaptureAll, Description, EmptyAPI, Fragment,
                 FramingRender (..), FramingUnrender (..), FromSourceIO (..),
                 Header', If, IsSecure (..), NoContentVerb, QueryFlag,
                 QueryParam', QueryParams, 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.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           Data.Kind
                 (Type)

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           GHC.TypeLits
                 (ErrorMessage (..), TypeError)
import           Servant.API.TypeLevel
                 (AtLeastOneFragment, 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 :: * -> *) :: *

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

  -- | This is better than 'enter', as it's tailor made for 'HasServer'.
  hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
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) =
    forall {k} (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (forall {k} (t :: k). Proxy t
Proxy :: Proxy a) Proxy context
pc forall x. m x -> n x
nt ServerT a m
a forall a b. a -> b -> a :<|> b
:<|>
    forall {k} (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (forall {k} (t :: k). Proxy t
Proxy :: Proxy b) Proxy context
pc 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 :: * -> *) (n :: * -> *).
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 = forall {k} (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Proxy context
pc forall x. m x -> n x
nt forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (Capture' mods capture a :> 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 =
    forall env a.
[CaptureHint] -> Router' (Text, env) a -> Router' env a
CaptureRouter [CaptureHint
hint] forall a b. (a -> b) -> a -> b
$
        forall {k} (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (forall {k} (t :: k). Proxy t
Proxy :: Proxy api)
              Context context
context
              (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))
d forall a b. (a -> b) -> a -> b
$ \ Text
txt -> forall a. (Request -> DelayedIO a) -> DelayedIO a
withRequest forall a b. (a -> b) -> a -> b
$ \ Request
request ->
                case ( forall (b :: Bool). SBoolI b => SBool b
sbool :: SBool (FoldLenient mods)
                     , forall a. FromHttpApiData a => Text -> Either Text a
parseUrlPiece Text
txt :: Either T.Text a) of
                  (SBool (FoldLenient mods)
SFalse, Left Text
e) -> forall a. ServerError -> DelayedIO a
delayedFail forall a b. (a -> b) -> a -> b
$ ErrorFormatter
formatError TypeRep
rep Request
request forall a b. (a -> b) -> a -> b
$ forall a b. ConvertibleStrings a b => a -> b
cs Text
e
                  (SBool (FoldLenient mods)
SFalse, Right a
v) -> forall (m :: * -> *) a. Monad m => a -> m a
return a
v
                  (SBool (FoldLenient mods)
STrue, Either Text a
piece) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ConvertibleStrings a b => a -> b
cs) forall a b. b -> Either a b
Right) Either Text a
piece)
    where
      rep :: TypeRep
rep = forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy :: Proxy Capture')
      formatError :: ErrorFormatter
formatError = ErrorFormatters -> ErrorFormatter
urlParseErrorFormatter forall a b. (a -> b) -> a -> b
$ forall (context :: [*]) val.
HasContextEntry context val =>
Context context -> val
getContextEntry (forall (ctx :: [*]).
Context ctx -> Context (MkContextWithErrorFormatter ctx)
mkContextWithErrorFormatter Context context
context)
      hint :: CaptureHint
hint = Text -> TypeRep -> CaptureHint
CaptureHint (String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @capture) (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (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 :: * -> *) (n :: * -> *).
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 = forall {k} (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Proxy context
pc forall x. m x -> n x
nt forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (CaptureAll capture a :> 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 =
    forall env a.
[CaptureHint] -> Router' ([Text], env) a -> Router' env a
CaptureAllRouter [CaptureHint
hint] forall a b. (a -> b) -> a -> b
$
        forall {k} (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (forall {k} (t :: k). Proxy t
Proxy :: Proxy api)
              Context context
context
              (forall env a b captured.
Delayed env (a -> b)
-> (captured -> DelayedIO a) -> Delayed (captured, env) b
addCapture Delayed env (Server (CaptureAll capture a :> api))
d forall a b. (a -> b) -> a -> b
$ \ [Text]
txts -> forall a. (Request -> DelayedIO a) -> DelayedIO a
withRequest forall a b. (a -> b) -> a -> b
$ \ Request
request ->
                case forall (t :: * -> *) a.
(Traversable t, FromHttpApiData a) =>
t Text -> Either Text (t a)
parseUrlPieces [Text]
txts of
                   Left Text
e  -> forall a. ServerError -> DelayedIO a
delayedFail forall a b. (a -> b) -> a -> b
$ ErrorFormatter
formatError TypeRep
rep Request
request forall a b. (a -> b) -> a -> b
$ forall a b. ConvertibleStrings a b => a -> b
cs Text
e
                   Right [a]
v -> forall (m :: * -> *) a. Monad m => a -> m a
return [a]
v
              )
    where
      rep :: TypeRep
rep = forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy :: Proxy CaptureAll)
      formatError :: ErrorFormatter
formatError = ErrorFormatters -> ErrorFormatter
urlParseErrorFormatter forall a b. (a -> b) -> a -> b
$ forall (context :: [*]) val.
HasContextEntry context val =>
Context context -> val
getContextEntry (forall (ctx :: [*]).
Context ctx -> Context (MkContextWithErrorFormatter ctx)
mkContextWithErrorFormatter Context context
context)
      hint :: CaptureHint
hint = Text -> TypeRep -> CaptureHint
CaptureHint (String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @capture) (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (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 :: * -> *) (n :: * -> *).
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 = forall {k} (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (forall {k} (t :: k). Proxy t
Proxy @api) Proxy ctx
pc forall x. m x -> n x
nt forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (WithResource a :> 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 = forall {k} (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (forall {k} (t :: k). Proxy t
Proxy @api) Context ctx
context (Delayed env (Server (WithResource a :> api))
d 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 = forall a.
ReaderT Request (ResourceT (RouteResultT IO)) a -> DelayedIO a
DelayedIO forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadResource m =>
Acquire a -> m (ReleaseKey, a)
allocateAcquire (forall (context :: [*]) 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 forall a. Eq a => a -> a -> Bool
== ByteString
methodGet Bool -> Bool -> Bool
&& Request -> ByteString
requestMethod Request
request 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 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 = forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise                    = 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 :: [*]).
AllMime list =>
Proxy list -> AcceptHeader -> DelayedIO ()
acceptCheck Proxy list
proxy AcceptHeader
accH
  | forall (list :: [*]).
AllMime list =>
Proxy list -> AcceptHeader -> Bool
canHandleAcceptH Proxy list
proxy AcceptHeader
accH = forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise                   = 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 :: [*]) 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 = 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 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 forall env a. Delayed env a -> DelayedIO () -> Delayed env a
`addMethodCheck` ByteString -> Request -> DelayedIO ()
methodCheck ByteString
method Request
request
                               forall env a. Delayed env a -> DelayedIO () -> Delayed env a
`addAcceptCheck` forall (list :: [*]).
AllMime list =>
Proxy list -> AcceptHeader -> DelayedIO ()
acceptCheck Proxy ctypes
proxy AcceptHeader
accH
                       ) env
env Request
request RouteResult Response -> IO ResponseReceived
respond forall a b. (a -> b) -> a -> b
$ \ b
output -> do
               let ([(HeaderName, ByteString)]
headers, a
b) = b -> ([(HeaderName, ByteString)], a)
splitHeaders b
output
               case forall (list :: [*]) a.
AllCTRender list a =>
Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)
handleAcceptH Proxy ctypes
proxy AcceptHeader
accH a
b of
                 Maybe (ByteString, ByteString)
Nothing -> 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 forall a. a -> RouteResult a
Route forall a b. (a -> b) -> a -> b
$ Status -> [(HeaderName, ByteString)] -> ByteString -> Response
responseLBS Status
status ((HeaderName
hContentType, forall a b. ConvertibleStrings a b => a -> b
cs ByteString
contentT) 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 = 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 =
          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 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 forall a b. (a -> b) -> a -> b
$ \ b
_output ->
                      forall a. a -> RouteResult a
Route 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 :: * -> *) (n :: * -> *).
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 = forall x. m x -> n x
nt 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
_ = forall (ctypes :: [*]) a b env.
AllCTRender ctypes a =>
(b -> ([(HeaderName, ByteString)], a))
-> ByteString
-> Proxy ctypes
-> Status
-> Delayed env (Handler b)
-> Router env
methodRouter ([],) ByteString
method (forall {k} (t :: k). Proxy t
Proxy :: Proxy ctypes) Status
status
    where method :: ByteString
method = forall {k} (a :: k). ReflectMethod a => Proxy a -> ByteString
reflectMethod (forall {k} (t :: k). Proxy t
Proxy :: Proxy method)
          status :: Status
status = forall (a :: Nat) (proxy :: Nat -> *).
KnownNat a =>
proxy a -> Status
statusFromNat (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 :: * -> *) (n :: * -> *).
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 = forall x. m x -> n x
nt 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
_ = forall (ctypes :: [*]) 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 -> (forall ls. GetHeaders ls => ls -> [(HeaderName, ByteString)]
getHeaders Headers h a
x, forall (ls :: [*]) a. Headers ls a -> a
getResponse Headers h a
x)) ByteString
method (forall {k} (t :: k). Proxy t
Proxy :: Proxy ctypes) Status
status
    where method :: ByteString
method = forall {k} (a :: k). ReflectMethod a => Proxy a -> ByteString
reflectMethod (forall {k} (t :: k). Proxy t
Proxy :: Proxy method)
          status :: Status
status = forall (a :: Nat) (proxy :: Nat -> *).
KnownNat a =>
proxy a -> Status
statusFromNat (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 :: * -> *) (n :: * -> *).
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 = forall x. m x -> n x
nt 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
_ = forall env b.
ByteString -> Status -> Delayed env (Handler b) -> Router env
noContentRouter ByteString
method Status
status204
    where method :: ByteString
method = forall {k} (a :: k). ReflectMethod a => Proxy a -> ByteString
reflectMethod (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 :: * -> *) (n :: * -> *).
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 = forall x. m x -> n x
nt 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
_ = 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 (forall {k} (t :: k). Proxy t
Proxy :: Proxy framing) (forall {k} (t :: k). Proxy t
Proxy :: Proxy ctype)
      where method :: ByteString
method = forall {k} (a :: k). ReflectMethod a => Proxy a -> ByteString
reflectMethod (forall {k} (t :: k). Proxy t
Proxy :: Proxy method)
            status :: Status
status = forall (a :: Nat) (proxy :: Nat -> *).
KnownNat a =>
proxy a -> Status
statusFromNat (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 :: * -> *) (n :: * -> *).
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 = forall x. m x -> n x
nt 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
_ = 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 -> (forall ls. GetHeaders ls => ls -> [(HeaderName, ByteString)]
getHeaders Headers h a
x, forall (ls :: [*]) a. Headers ls a -> a
getResponse Headers h a
x)) ByteString
method Status
status (forall {k} (t :: k). Proxy t
Proxy :: Proxy framing) (forall {k} (t :: k). Proxy t
Proxy :: Proxy ctype)
      where method :: ByteString
method = forall {k} (a :: k). ReflectMethod a => Proxy a -> ByteString
reflectMethod (forall {k} (t :: k). Proxy t
Proxy :: Proxy method)
            status :: Status
status = forall (a :: Nat) (proxy :: Nat -> *).
KnownNat a =>
proxy a -> Status
statusFromNat (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 = forall env a. (env -> a) -> Router' env a
leafRouter 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 = forall a. Accept a => [a] -> ByteString -> Maybe a
NHM.matchAccept [forall {k} (ctype :: k). Accept ctype => Proxy ctype -> MediaType
contentType Proxy ctype
ctypeproxy] ByteString
accH
              accCheck :: DelayedIO ()
accCheck = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isNothing Maybe MediaType
cmediatype) forall a b. (a -> b) -> a -> b
$ forall a. ServerError -> DelayedIO a
delayedFail ServerError
err406
              contentHeader :: (HeaderName, ByteString)
contentHeader = (HeaderName
hContentType, forall h. RenderHeader h => h -> ByteString
NHM.renderHeader forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ Maybe MediaType
cmediatype)
          in 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 forall env a. Delayed env a -> DelayedIO () -> Delayed env a
`addMethodCheck` ByteString -> Request -> DelayedIO ()
methodCheck ByteString
method Request
request
                               forall env a. Delayed env a -> DelayedIO () -> Delayed env a
`addAcceptCheck` DelayedIO ()
accCheck
                       ) env
env Request
request RouteResult Response -> IO ResponseReceived
respond 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 = forall chunk a. ToSourceIO chunk a => a -> SourceIO chunk
toSourceIO a
fa
                    S.SourceT forall b. (StepT IO ByteString -> IO b) -> IO b
kStepLBS = forall {k} (strategy :: k) (m :: * -> *) a.
(FramingRender strategy, Monad m) =>
Proxy strategy
-> (a -> ByteString) -> SourceT m a -> SourceT m ByteString
framingRender Proxy framing
framingproxy (forall {k} (ctype :: k) a.
MimeRender ctype a =>
Proxy ctype -> a -> ByteString
mimeRender Proxy ctype
ctypeproxy :: chunk -> BL.ByteString) SourceIO chunk
sourceT
                in forall a. a -> RouteResult a
Route forall a b. (a -> b) -> a -> b
$ Status -> [(HeaderName, ByteString)] -> StreamingBody -> Response
responseStream Status
status ((HeaderName, ByteString)
contentHeader forall a. a -> [a] -> [a]
: [(HeaderName, ByteString)]
headers) 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)   = forall (m :: * -> *) 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 forall (m :: * -> *) 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

                    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 :: * -> *) (n :: * -> *).
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 = forall {k} (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Proxy context
pc forall x. m x -> n x
nt forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (Header' mods sym a :> 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 = forall {k} (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Context context
context forall a b. (a -> b) -> a -> b
$
      Delayed env (Server (Header' mods sym a :> api))
subserver forall env a b.
Delayed env (a -> b) -> DelayedIO a -> Delayed env b
`addHeaderCheck` 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 = forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy :: Proxy Header')
      formatError :: ErrorFormatter
formatError = ErrorFormatters -> ErrorFormatter
headerParseErrorFormatter forall a b. (a -> b) -> a -> b
$ forall (context :: [*]) val.
HasContextEntry context val =>
Context context -> val
getContextEntry (forall (ctx :: [*]).
Context ctx -> Context (MkContextWithErrorFormatter ctx)
mkContextWithErrorFormatter Context context
context)

      headerName :: IsString n => n
      headerName :: forall n. IsString n => n
headerName = forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (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 =
          forall (mods :: [*]) (m :: * -> *) 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 (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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. FromHttpApiData a => ByteString -> Either Text a
parseHeader forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup 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 = forall a. ServerError -> DelayedIO a
delayedFailFatal forall a b. (a -> b) -> a -> b
$ ErrorFormatter
formatError TypeRep
rep Request
req
            forall a b. (a -> b) -> a -> b
$ String
"Header " forall a. Semigroup a => a -> a -> a
<> forall n. IsString n => n
headerName 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 = forall a. ServerError -> DelayedIO a
delayedFailFatal forall a b. (a -> b) -> a -> b
$ ErrorFormatter
formatError TypeRep
rep Request
req
            forall a b. (a -> b) -> a -> b
$ forall a b. ConvertibleStrings a b => a -> b
cs forall a b. (a -> b) -> a -> b
$ Text
"Error parsing header "
                    forall a. Semigroup a => a -> a -> a
<> forall n. IsString n => n
headerName
                    forall a. Semigroup a => a -> a -> a
<> Text
" failed: " 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 :: * -> *) (n :: * -> *).
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 = forall {k} (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Proxy context
pc forall x. m x -> n x
nt forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (QueryParam' mods sym a :> 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Query
queryString
        paramname :: Text
paramname = forall a b. ConvertibleStrings a b => a -> b
cs forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy :: Proxy sym)

        rep :: TypeRep
rep = forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy :: Proxy QueryParam')
        formatError :: ErrorFormatter
formatError = ErrorFormatters -> ErrorFormatter
urlParseErrorFormatter forall a b. (a -> b) -> a -> b
$ forall (context :: [*]) val.
HasContextEntry context val =>
Context context -> val
getContextEntry (forall (ctx :: [*]).
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 =
            forall (mods :: [*]) (m :: * -> *) 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 (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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. FromHttpApiData a => Text -> Either Text a
parseQueryParam forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
paramname 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 = forall a. ServerError -> DelayedIO a
delayedFailFatal forall a b. (a -> b) -> a -> b
$ ErrorFormatter
formatError TypeRep
rep Request
req
              forall a b. (a -> b) -> a -> b
$ forall a b. ConvertibleStrings a b => a -> b
cs forall a b. (a -> b) -> a -> b
$ Text
"Query parameter " forall a. Semigroup a => a -> a -> a
<> Text
paramname 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 = forall a. ServerError -> DelayedIO a
delayedFailFatal forall a b. (a -> b) -> a -> b
$ ErrorFormatter
formatError TypeRep
rep Request
req
              forall a b. (a -> b) -> a -> b
$ forall a b. ConvertibleStrings a b => a -> b
cs forall a b. (a -> b) -> a -> b
$ Text
"Error parsing query parameter "
                      forall a. Semigroup a => a -> a -> a
<> Text
paramname forall a. Semigroup a => a -> a -> a
<> Text
" failed: " forall a. Semigroup a => a -> a -> a
<> Text
e

        delayed :: Delayed env (ServerT api Handler)
delayed = forall env a b.
Delayed env (a -> b) -> DelayedIO a -> Delayed env b
addParameterCheck Delayed env (Server (QueryParam' mods sym a :> api))
subserver forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Request -> DelayedIO a) -> DelayedIO a
withRequest 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 forall {k} (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (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 :: * -> *) (n :: * -> *).
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 = forall {k} (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Proxy context
pc forall x. m x -> n x
nt forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (QueryParams sym a :> 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 = forall {k} (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Context context
context forall a b. (a -> b) -> a -> b
$
      Delayed env (Server (QueryParams sym a :> api))
subserver forall env a b.
Delayed env (a -> b) -> DelayedIO a -> Delayed env b
`addParameterCheck` forall a. (Request -> DelayedIO a) -> DelayedIO a
withRequest Request -> DelayedIO [a]
paramsCheck
    where
      rep :: TypeRep
rep = forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy :: Proxy QueryParams)
      formatError :: ErrorFormatter
formatError = ErrorFormatters -> ErrorFormatter
urlParseErrorFormatter forall a b. (a -> b) -> a -> b
$ forall (context :: [*]) val.
HasContextEntry context val =>
Context context -> val
getContextEntry (forall (ctx :: [*]).
Context ctx -> Context (MkContextWithErrorFormatter ctx)
mkContextWithErrorFormatter Context context
context)

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

          looksLikeParam :: Text -> Bool
looksLikeParam Text
name = Text
name forall a. Eq a => a -> a -> Bool
== Text
paramname Bool -> Bool -> Bool
|| Text
name forall a. Eq a => a -> a -> Bool
== (Text
paramname 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 :: * -> *) (n :: * -> *).
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 = forall {k} (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Proxy context
pc forall x. m x -> n x
nt forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (QueryFlag sym :> 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Query
queryString
        param :: Request -> Bool
param Request
r = case 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) -> 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  forall {k} (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Context context
context (forall env a b.
Delayed env (a -> b) -> (Request -> a) -> Delayed env b
passToServer Delayed env (Server (QueryFlag sym :> api))
subserver Request -> Bool
param)
    where paramname :: Text
paramname = forall a b. ConvertibleStrings a b => a -> b
cs forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy :: Proxy sym)
          examine :: a -> Bool
examine a
v | a
v forall a. Eq a => a -> a -> Bool
== a
"true" Bool -> Bool -> Bool
|| a
v forall a. Eq a => a -> a -> Bool
== a
"1" Bool -> Bool -> Bool
|| a
v forall a. Eq a => a -> a -> Bool
== a
"" = Bool
True
                    | Bool
otherwise = Bool
False

-- | 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 :: * -> *) (n :: * -> *).
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
_ = 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 = forall env a. (env -> a) -> Router' env a
RawRouter forall a b. (a -> b) -> a -> b
$ \ env
env Request
request RouteResult Response -> IO ResponseReceived
respond -> forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT 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
     (Request
      -> (Response -> IO ResponseReceived) -> IO ResponseReceived))
r <- forall env a.
Delayed env a -> env -> Request -> ResourceT IO (RouteResult a)
runDelayed Delayed env (Server Raw)
rawApplication env
env Request
request
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall {k} {s :: k} {t} {a} {t}.
RouteResult (Tagged s (t -> (a -> t) -> t))
-> t -> (RouteResult a -> t) -> t
go RouteResult
  (Tagged
     Handler
     (Request
      -> (Response -> IO ResponseReceived) -> IO ResponseReceived))
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   -> forall {k} (s :: k) b. Tagged s b -> b
untag Tagged s (t -> (a -> t) -> t)
app t
request (RouteResult a -> t
respond forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> RouteResult a
Route)
            Fail ServerError
a      -> RouteResult a -> t
respond forall a b. (a -> b) -> a -> b
$ forall a. ServerError -> RouteResult a
Fail ServerError
a
            FailFatal ServerError
e -> RouteResult a -> t
respond forall a b. (a -> b) -> a -> b
$ 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 = forall env a. (env -> a) -> Router' env a
RawRouter forall a b. (a -> b) -> a -> b
$ \env
env Request
request RouteResult Response -> IO ResponseReceived
respond -> forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT forall a b. (a -> b) -> a -> b
$ do
    RouteResult
  (Request
   -> (Response -> IO ResponseReceived) -> Handler ResponseReceived)
routeResult <- 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' = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. RouteResult Response -> IO ResponseReceived
respond
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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   -> forall a. Handler a -> IO (Either ServerError a)
runHandler (Request
-> (Response -> IO ResponseReceived) -> Handler ResponseReceived
handler Request
request (RouteResult Response -> IO ResponseReceived
respond forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> RouteResult a
Route)) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
        \case
           Left ServerError
e -> RouteResult Response -> IO ResponseReceived
respond' forall a b. (a -> b) -> a -> b
$ forall a. ServerError -> RouteResult a
FailFatal ServerError
e
           Right ResponseReceived
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ResponseReceived
a
      Fail ServerError
e -> RouteResult Response -> IO ResponseReceived
respond' forall a b. (a -> b) -> a -> b
$ forall a. ServerError -> RouteResult a
Fail ServerError
e
      FailFatal ServerError
e -> RouteResult Response -> IO ResponseReceived
respond' forall a b. (a -> b) -> a -> b
$ forall a. ServerError -> RouteResult a
FailFatal ServerError
e

  hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
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 -> forall x. m x -> n x
f (ServerT RawM m
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 :: * -> *) (n :: * -> *).
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 = forall {k} (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Proxy context
pc forall x. m x -> n x
nt forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (ReqBody' mods list a :> 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
      = forall {k} (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Context context
context forall a b. (a -> b) -> a -> b
$
          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))
subserver DelayedIO (ByteString -> Either String a)
ctCheck (ByteString -> Either String a)
-> DelayedIO (If (FoldLenient mods) (Either String a) a)
bodyCheck
    where
      rep :: TypeRep
rep = forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy :: Proxy ReqBody')
      formatError :: ErrorFormatter
formatError = ErrorFormatters -> ErrorFormatter
bodyParserErrorFormatter forall a b. (a -> b) -> a -> b
$ forall (context :: [*]) val.
HasContextEntry context val =>
Context context -> val
getContextEntry (forall (ctx :: [*]).
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 = forall a. (Request -> DelayedIO a) -> DelayedIO a
withRequest 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 = forall a. a -> Maybe a -> a
fromMaybe ByteString
"application/octet-stream"
                         forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hContentType forall a b. (a -> b) -> a -> b
$ Request -> [(HeaderName, ByteString)]
requestHeaders Request
request
        case forall (list :: [*]) a.
AllCTUnrender list a =>
Proxy list -> ByteString -> Maybe (ByteString -> Either String a)
canHandleCTypeH (forall {k} (t :: k). Proxy t
Proxy :: Proxy list) (forall a b. ConvertibleStrings a b => a -> b
cs ByteString
contentTypeH) :: Maybe (BL.ByteString -> Either String a) of
          Maybe (ByteString -> Either String a)
Nothing -> forall a. ServerError -> DelayedIO a
delayedFail ServerError
err415
          Just ByteString -> Either String a
f  -> forall (m :: * -> *) 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 = forall a. (Request -> DelayedIO a) -> DelayedIO a
withRequest forall a b. (a -> b) -> a -> b
$ \ Request
request -> do
        Either String a
mrqbody <- ByteString -> Either String a
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Request -> IO ByteString
lazyRequestBody Request
request)
        case forall (b :: Bool). SBoolI b => SBool b
sbool :: SBool (FoldLenient mods) of
          SBool (FoldLenient mods)
STrue -> forall (m :: * -> *) a. Monad m => a -> m a
return Either String a
mrqbody
          SBool (FoldLenient mods)
SFalse -> case Either String a
mrqbody of
            Left String
e  -> forall a. ServerError -> DelayedIO a
delayedFailFatal forall a b. (a -> b) -> a -> b
$ ErrorFormatter
formatError TypeRep
rep Request
request String
e
            Right If (FoldLenient mods) (Either String a) a
v -> forall (m :: * -> *) 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 :: * -> *) (n :: * -> *).
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 = forall {k} (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Proxy context
pc forall x. m x -> n x
nt forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (StreamBody' mods framing ctype a :> 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 = forall {k} (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Context context
context forall a b. (a -> b) -> a -> b
$
        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))
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 = forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall a. (Request -> DelayedIO a) -> DelayedIO a
withRequest forall a b. (a -> b) -> a -> b
$ \Request
req -> do
            let mimeUnrender' :: ByteString -> Either String chunk
mimeUnrender'    = forall {k} (ctype :: k) a.
MimeUnrender ctype a =>
Proxy ctype -> ByteString -> Either String a
mimeUnrender (forall {k} (t :: k). Proxy t
Proxy :: Proxy ctype) :: BL.ByteString -> Either String chunk
            let framingUnrender' :: SourceIO ByteString -> SourceIO chunk
framingUnrender' = forall {k} (strategy :: k) (m :: * -> *) a.
(FramingUnrender strategy, Monad m) =>
Proxy strategy
-> (ByteString -> Either String a)
-> SourceT m ByteString
-> SourceT m a
framingUnrender (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 = forall (m :: * -> *) a.
Functor m =>
(a -> Bool) -> m a -> SourceT m a
S.fromAction ByteString -> Bool
B.null IO ByteString
body
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ SourceIO chunk -> IO a
fromRS 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 =
    forall env a. Text -> Router' env a -> Router' env a
pathRouter
      (forall a b. ConvertibleStrings a b => a -> b
cs (forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal Proxy path
proxyPath))
      (forall {k} (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Context context
context Delayed env (Server (path :> api))
subserver)
    where proxyPath :: Proxy path
proxyPath = forall {k} (t :: k). Proxy t
Proxy :: Proxy path
  hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
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 = forall {k} (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Proxy context
pc forall x. m x -> n x
nt 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 =
    forall {k} (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Context context
context (forall env a b.
Delayed env (a -> b) -> (Request -> a) -> Delayed env b
passToServer Delayed env (Server (RemoteHost :> api))
subserver Request -> SockAddr
remoteHost)
  hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
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 = forall {k} (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Proxy context
pc forall x. m x -> n x
nt forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (RemoteHost :> 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 =
    forall {k} (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Context context
context (forall env a b.
Delayed env (a -> b) -> (Request -> a) -> Delayed env b
passToServer Delayed env (Server (IsSecure :> 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 :: * -> *) (n :: * -> *).
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 = forall {k} (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Proxy context
pc forall x. m x -> n x
nt forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (IsSecure :> 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 =
    forall {k} (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Context context
context (forall env a b.
Delayed env (a -> b) -> (Request -> a) -> Delayed env b
passToServer Delayed env (Server (Vault :> api))
subserver Request -> Vault
vault)
  hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
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 = forall {k} (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Proxy context
pc forall x. m x -> n x
nt forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (Vault :> 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 =
    forall {k} (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Context context
context (forall env a b.
Delayed env (a -> b) -> (Request -> a) -> Delayed env b
passToServer Delayed env (Server (HttpVersion :> api))
subserver Request -> HttpVersion
httpVersion)
  hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
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 = forall {k} (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Proxy context
pc forall x. m x -> n x
nt forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (HttpVersion :> 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)
_ = forall {k} (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (forall {k} (t :: k). Proxy t
Proxy :: Proxy api)
  hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
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 = forall {k} (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Proxy ctx
pc forall x. m x -> n x
nt 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)
_ = forall {k} (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (forall {k} (t :: k). Proxy t
Proxy :: Proxy api)
  hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
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 = forall {k} (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Proxy ctx
pc forall x. m x -> n x
nt ServerT (Description desc :> api) m
s

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

-- | Server for `EmptyAPI`
emptyServer :: ServerT EmptyAPI m
emptyServer :: forall (m :: * -> *). ServerT EmptyAPI 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)
_ = forall env a.
Map Text (Router' env a) -> [env -> a] -> Router' env a
StaticRouter forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty

  hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
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
_ = forall {k1} {k2} (s :: k1) b (t :: k2). Tagged s b -> Tagged t b
retag

-- | 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 =
    forall {k} (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Context context
context (Delayed env (Server (BasicAuth realm usr :> api))
subserver 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 forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy :: Proxy realm)
       basicAuthContext :: BasicAuthCheck usr
basicAuthContext = forall (context :: [*]) val.
HasContextEntry context val =>
Context context -> val
getContextEntry Context context
context
       authCheck :: DelayedIO usr
authCheck = forall a. (Request -> DelayedIO a) -> DelayedIO a
withRequest forall a b. (a -> b) -> a -> b
$ \ Request
req -> forall usr.
Request -> ByteString -> BasicAuthCheck usr -> DelayedIO usr
runBasicAuth Request
req ByteString
realm BasicAuthCheck usr
basicAuthContext

  hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
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 = forall {k} (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Proxy context
pc forall x. m x -> n x
nt forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (BasicAuth realm usr :> api) m
s

-- * helpers

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

getAcceptHeader :: Request -> AcceptHeader
getAcceptHeader :: Request -> AcceptHeader
getAcceptHeader = ByteString -> AcceptHeader
AcceptHeader forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe ByteString
ct_wildcard forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hAccept 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 =
    forall {k} (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route Proxy subApi
subProxy Context subContext
subContext Delayed env (Server (WithNamedContext name subContext subApi))
delayed
    where
      subProxy :: Proxy subApi
      subProxy :: Proxy subApi
subProxy = forall {k} (t :: k). Proxy t
Proxy

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

  hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
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 = forall {k} (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (forall {k} (t :: k). Proxy t
Proxy :: Proxy subApi) (forall {k} (t :: k). Proxy t
Proxy :: Proxy subContext) forall x. m x -> n x
nt ServerT (WithNamedContext name subContext subApi) m
s

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

-- Erroring instance for 'HasServer' when a combinator is not fully applied
instance TypeError (PartialApplication 
#if __GLASGOW_HASKELL__ >= 904
                    @(Type -> [Type] -> Constraint) 
#endif
                    HasServer arr) => HasServer ((arr :: a -> b) :> sub) context
  where
    type ServerT (arr :> sub) _ = TypeError (PartialApplication (HasServer :: * -> [*] -> Constraint) arr)
    route :: forall env.
Proxy (arr :> sub)
-> Context context
-> Delayed env (Server (arr :> sub))
-> Router env
route = forall a. HasCallStack => String -> a
error String
"unreachable"
    hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
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
_ = 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))
_ = forall a. HasCallStack => String -> a
error String
"servant-server panic: impossible happened in HasServer (a -> b)"
    hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
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
_ = 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 
#if __GLASGOW_HASKELL__ >= 904
                                         @(Type -> [Type] -> Constraint) 
#endif
                                         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 (AtLeastOneFragment 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)
_ = forall {k} (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (forall {k} (t :: k). Proxy t
Proxy :: Proxy api)

  hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
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)
_ = forall {k} (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (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 :: * -> *)
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 :: * -> *) (m :: * -> *) 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 = 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 :: * -> *) (m :: * -> *).
GServer api m =>
Dict (GServerConstraints api m)
gServerProof @api @Handler of
      Dict (GServerConstraints api Handler)
Dict -> forall {k} (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (forall {k} (t :: k). Proxy t
Proxy @(ToServantApi api)) Context context
ctx (forall (routes :: * -> *) mode.
GenericServant routes mode =>
routes mode -> ToServant routes mode
toServant forall (f :: * -> *) 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 :: * -> *) (n :: * -> *).
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 :: * -> *) (m :: * -> *).
GServer api m =>
Dict (GServerConstraints api m)
gServerProof @api @m, forall (api :: * -> *) (m :: * -> *).
GServer api m =>
Dict (GServerConstraints api m)
gServerProof @api @n) of
      (Dict
  (GToServant (Rep (api (AsServerT m)))
   ~ ServerT (ToServantApi api) m,
   GServantProduct (Rep (api (AsServerT m))))
Dict, Dict
  (GToServant (Rep (api (AsServerT n)))
   ~ ServerT (ToServantApi api) n,
   GServantProduct (Rep (api (AsServerT n))))
Dict) ->
        forall (routes :: * -> *) mode.
GenericServant routes mode =>
ToServant routes mode -> routes mode
fromServant ServerT (ToServantApi api) n
servantSrvN
        where
          ServerT (ToServantApi api) m
servantSrvM :: ServerT (ToServantApi api) m =
            forall (routes :: * -> *) mode.
GenericServant routes mode =>
routes mode -> ToServant routes mode
toServant api (AsServerT m)
server
          ServerT (ToServantApi api) n
servantSrvN :: ServerT (ToServantApi api) n =
            forall {k} (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (forall {k} (t :: k). Proxy t
Proxy @(ToServantApi api)) Proxy context
pctx forall x. m x -> n x
nat ServerT (ToServantApi api) m
servantSrvM