{-# LANGUAGE AllowAmbiguousTypes   #-}
{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE CPP                   #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveDataTypeable    #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE InstanceSigs          #-}
{-# 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)
import           Control.Monad.Trans.Resource
                 (runResourceT)
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, 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, ReflectMethod (reflectMethod),
                 RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,
                 Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,
                 WithNamedContext, 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
  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 :: Proxy (a :<|> b)
-> Context context -> Delayed env (Server (a :<|> b)) -> Router env
route Proxy (a :<|> b)
Proxy Context context
context Delayed env (Server (a :<|> b))
server = Router env -> Router env -> Router env
forall env a. Router' env a -> Router' env a -> Router' env a
choice (Proxy a -> Context context -> Delayed env (Server a) -> Router env
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 ((\ (Server a
a :<|> ServerT b Handler
_) -> Server a
a) ((Server a :<|> ServerT b Handler) -> Server a)
-> Delayed env (Server a :<|> ServerT b Handler)
-> Delayed env (Server a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Delayed env (Server a :<|> ServerT b Handler)
Delayed env (Server (a :<|> b))
server))
                                      (Proxy b
-> Context context -> Delayed env (ServerT b Handler) -> Router env
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 ((\ (Server a
_ :<|> ServerT b Handler
b) -> ServerT b Handler
b) ((Server a :<|> ServerT b Handler) -> ServerT b Handler)
-> Delayed env (Server a :<|> ServerT b Handler)
-> Delayed env (ServerT b Handler)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Delayed env (Server a :<|> ServerT b Handler)
Delayed env (Server (a :<|> b))
server))
    where pa :: Proxy a
pa = Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a
          pb :: Proxy b
pb = Proxy b
forall k (t :: k). Proxy t
Proxy :: Proxy b

  -- | This is better than 'enter', as it's tailor made for 'HasServer'.
  hoistServerWithContext :: 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 (a :<|> b) =
    Proxy a
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT a m
-> ServerT a 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 (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a) Proxy context
pc forall x. m x -> n x
nt ServerT a m
a ServerT a n -> ServerT b n -> ServerT a n :<|> ServerT b n
forall a b. a -> b -> a :<|> b
:<|>
    Proxy b
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT b m
-> ServerT b n
forall k (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy b
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 :: Proxy (Capture' mods capture a :> api)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (Capture' mods capture a :> api) m
-> ServerT (Capture' mods capture a :> api) n
hoistServerWithContext Proxy (Capture' mods capture a :> api)
_ Proxy context
pc forall x. m x -> n x
nt ServerT (Capture' mods capture a :> api) m
s = Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall k (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy api
forall k (t :: k). Proxy t
Proxy :: Proxy api) Proxy context
pc forall x. m x -> n x
nt (ServerT api m -> ServerT api n)
-> (If (FoldLenient mods) (Either String a) a -> ServerT api m)
-> If (FoldLenient mods) (Either String a) a
-> ServerT api n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (Capture' mods capture a :> api) m
If (FoldLenient mods) (Either String a) a -> ServerT api m
s

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

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

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

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

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

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

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

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

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

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

noContentRouter :: Method
             -> Status
             -> Delayed env (Handler b)
             -> Router env
noContentRouter :: Method -> Status -> Delayed env (Handler b) -> Router env
noContentRouter Method
method Status
status Delayed env (Handler b)
action = (env -> RoutingApplication) -> Router env
forall env a. (env -> a) -> Router' env a
leafRouter env -> RoutingApplication
route'
  where
    route' :: env -> RoutingApplication
route' env
env Request
request RouteResult Response -> IO ResponseReceived
respond =
          Delayed env (Handler b)
-> env
-> Request
-> (RouteResult Response -> IO ResponseReceived)
-> (b -> RouteResult Response)
-> IO ResponseReceived
forall env a r.
Delayed env (Handler a)
-> env
-> Request
-> (RouteResult Response -> IO r)
-> (a -> RouteResult Response)
-> IO r
runAction (Delayed env (Handler b)
action Delayed env (Handler b) -> DelayedIO () -> Delayed env (Handler b)
forall env a. Delayed env a -> DelayedIO () -> Delayed env a
`addMethodCheck` Method -> Request -> DelayedIO ()
methodCheck Method
method Request
request)
                    env
env Request
request RouteResult Response -> IO ResponseReceived
respond ((b -> RouteResult Response) -> IO ResponseReceived)
-> (b -> RouteResult Response) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \ b
_output ->
                      Response -> RouteResult Response
forall a. a -> RouteResult a
Route (Response -> RouteResult Response)
-> Response -> RouteResult Response
forall a b. (a -> b) -> a -> b
$ Status -> [(HeaderName, Method)] -> 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 :: Proxy (Verb method status ctypes a)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (Verb method status ctypes a) m
-> ServerT (Verb method status ctypes a) n
hoistServerWithContext Proxy (Verb method status ctypes a)
_ Proxy context
_ forall x. m x -> n x
nt ServerT (Verb method status ctypes a) m
s = m a -> n a
forall x. m x -> n x
nt m a
ServerT (Verb method status ctypes a) m
s

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

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

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

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

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

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

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

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

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

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


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

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

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


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

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

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

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

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

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

      headerCheck :: Request -> DelayedIO (RequestArgument mods a)
      headerCheck :: Request
-> DelayedIO
     (If
        (FoldRequired mods)
        (If (FoldLenient mods) (Either Text a) a)
        (Maybe (If (FoldLenient mods) (Either Text a) a)))
headerCheck Request
req =
          Proxy mods
-> DelayedIO
     (If
        (FoldRequired mods)
        (If (FoldLenient mods) (Either Text a) a)
        (Maybe (If (FoldLenient mods) (Either Text a) a)))
-> (Text
    -> DelayedIO
         (If
            (FoldRequired mods)
            (If (FoldLenient mods) (Either Text a) a)
            (Maybe (If (FoldLenient mods) (Either Text a) a))))
-> Maybe (Either Text a)
-> DelayedIO
     (If
        (FoldRequired mods)
        (If (FoldLenient mods) (Either Text a) a)
        (Maybe (If (FoldLenient mods) (Either Text a) a)))
forall (mods :: [*]) (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 (Proxy mods
forall k (t :: k). Proxy t
Proxy :: Proxy mods) DelayedIO
  (If
     (FoldRequired mods)
     (If (FoldLenient mods) (Either Text a) a)
     (Maybe (If (FoldLenient mods) (Either Text a) a)))
errReq Text
-> DelayedIO
     (If
        (FoldRequired mods)
        (If (FoldLenient mods) (Either Text a) a)
        (Maybe (If (FoldLenient mods) (Either Text a) a)))
errSt Maybe (Either Text a)
mev
        where
          mev :: Maybe (Either T.Text a)
          mev :: Maybe (Either Text a)
mev = (Method -> Either Text a) -> Maybe Method -> Maybe (Either Text a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Method -> Either Text a
forall a. FromHttpApiData a => Method -> Either Text a
parseHeader (Maybe Method -> Maybe (Either Text a))
-> Maybe Method -> Maybe (Either Text a)
forall a b. (a -> b) -> a -> b
$ HeaderName -> [(HeaderName, Method)] -> Maybe Method
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
forall n. IsString n => n
headerName (Request -> [(HeaderName, Method)]
requestHeaders Request
req)

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

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

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

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

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

        rep :: TypeRep
rep = Proxy QueryParam' -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy QueryParam'
forall k (t :: k). Proxy t
Proxy :: Proxy QueryParam')
        formatError :: ErrorFormatter
formatError = ErrorFormatters -> ErrorFormatter
urlParseErrorFormatter (ErrorFormatters -> ErrorFormatter)
-> ErrorFormatters -> ErrorFormatter
forall a b. (a -> b) -> a -> b
$ Context (MkContextWithErrorFormatter context) -> ErrorFormatters
forall (context :: [*]) val.
HasContextEntry context val =>
Context context -> val
getContextEntry (Context context -> Context (MkContextWithErrorFormatter context)
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 =
            Proxy mods
-> DelayedIO
     (If
        (FoldRequired mods)
        (If (FoldLenient mods) (Either Text a) a)
        (Maybe (If (FoldLenient mods) (Either Text a) a)))
-> (Text
    -> DelayedIO
         (If
            (FoldRequired mods)
            (If (FoldLenient mods) (Either Text a) a)
            (Maybe (If (FoldLenient mods) (Either Text a) a))))
-> Maybe (Either Text a)
-> DelayedIO
     (If
        (FoldRequired mods)
        (If (FoldLenient mods) (Either Text a) a)
        (Maybe (If (FoldLenient mods) (Either Text a) a)))
forall (mods :: [*]) (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 (Proxy mods
forall k (t :: k). Proxy t
Proxy :: Proxy mods) DelayedIO
  (If
     (FoldRequired mods)
     (If (FoldLenient mods) (Either Text a) a)
     (Maybe (If (FoldLenient mods) (Either Text a) a)))
errReq Text
-> DelayedIO
     (If
        (FoldRequired mods)
        (If (FoldLenient mods) (Either Text a) a)
        (Maybe (If (FoldLenient mods) (Either Text a) a)))
errSt Maybe (Either Text a)
mev
          where
            mev :: Maybe (Either T.Text a)
            mev :: Maybe (Either Text a)
mev = (Text -> Either Text a) -> Maybe Text -> Maybe (Either Text a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Either Text a
forall a. FromHttpApiData a => Text -> Either Text a
parseQueryParam (Maybe Text -> Maybe (Either Text a))
-> Maybe Text -> Maybe (Either Text a)
forall a b. (a -> b) -> a -> b
$ Maybe (Maybe Text) -> Maybe Text
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe Text) -> Maybe Text)
-> Maybe (Maybe Text) -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text -> QueryText -> Maybe (Maybe Text)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
paramname (QueryText -> Maybe (Maybe Text))
-> QueryText -> Maybe (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Request -> QueryText
querytext Request
req

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  route :: Proxy Raw
-> Context context -> Delayed env (Server Raw) -> Router env
route Proxy Raw
Proxy Context context
_ Delayed env (Server Raw)
rawApplication = (env -> RoutingApplication) -> Router env
forall env a. (env -> a) -> Router' env a
RawRouter ((env -> RoutingApplication) -> Router env)
-> (env -> RoutingApplication) -> Router env
forall a b. (a -> b) -> a -> b
$ \ env
env Request
request RouteResult Response -> IO ResponseReceived
respond -> ResourceT IO ResponseReceived -> IO ResponseReceived
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (ResourceT IO ResponseReceived -> IO ResponseReceived)
-> ResourceT IO ResponseReceived -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ do
    -- note: a Raw application doesn't register any cleanup
    -- but for the sake of consistency, we nonetheless run
    -- the cleanup once its done
    RouteResult
  (Tagged
     Handler
     (Request
      -> (Response -> IO ResponseReceived) -> IO ResponseReceived))
r <- Delayed
  env
  (Tagged
     Handler
     (Request
      -> (Response -> IO ResponseReceived) -> IO ResponseReceived))
-> env
-> Request
-> ResourceT
     IO
     (RouteResult
        (Tagged
           Handler
           (Request
            -> (Response -> IO ResponseReceived) -> IO ResponseReceived)))
forall env a.
Delayed env a -> env -> Request -> ResourceT IO (RouteResult a)
runDelayed Delayed
  env
  (Tagged
     Handler
     (Request
      -> (Response -> IO ResponseReceived) -> IO ResponseReceived))
Delayed env (Server Raw)
rawApplication env
env Request
request
    IO ResponseReceived -> ResourceT IO ResponseReceived
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ResponseReceived -> ResourceT IO ResponseReceived)
-> IO ResponseReceived -> ResourceT IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ RouteResult
  (Tagged
     Handler
     (Request
      -> (Response -> IO ResponseReceived) -> IO ResponseReceived))
-> RoutingApplication
forall k (s :: k) t a p.
RouteResult (Tagged s (t -> (a -> p) -> p))
-> t -> (RouteResult a -> p) -> p
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 -> p) -> p))
-> t -> (RouteResult a -> p) -> p
go RouteResult (Tagged s (t -> (a -> p) -> p))
r t
request RouteResult a -> p
respond = case RouteResult (Tagged s (t -> (a -> p) -> p))
r of
            Route Tagged s (t -> (a -> p) -> p)
app   -> Tagged s (t -> (a -> p) -> p) -> t -> (a -> p) -> p
forall k (s :: k) b. Tagged s b -> b
untag Tagged s (t -> (a -> p) -> p)
app t
request (RouteResult a -> p
respond (RouteResult a -> p) -> (a -> RouteResult a) -> a -> p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> RouteResult a
forall a. a -> RouteResult a
Route)
            Fail ServerError
a      -> RouteResult a -> p
respond (RouteResult a -> p) -> RouteResult a -> p
forall a b. (a -> b) -> a -> b
$ ServerError -> RouteResult a
forall a. ServerError -> RouteResult a
Fail ServerError
a
            FailFatal ServerError
e -> RouteResult a -> p
respond (RouteResult a -> p) -> RouteResult a -> p
forall a b. (a -> b) -> a -> b
$ ServerError -> RouteResult a
forall a. ServerError -> RouteResult a
FailFatal ServerError
e

-- | 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 :: Proxy (ReqBody' mods list a :> api)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (ReqBody' mods list a :> api) m
-> ServerT (ReqBody' mods list a :> api) n
hoistServerWithContext Proxy (ReqBody' mods list a :> api)
_ Proxy context
pc forall x. m x -> n x
nt ServerT (ReqBody' mods list a :> api) m
s = Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall k (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy api
forall k (t :: k). Proxy t
Proxy :: Proxy api) Proxy context
pc forall x. m x -> n x
nt (ServerT api m -> ServerT api n)
-> (If (FoldLenient mods) (Either String a) a -> ServerT api m)
-> If (FoldLenient mods) (Either String a) a
-> ServerT api n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (ReqBody' mods list a :> api) m
If (FoldLenient mods) (Either String a) a -> ServerT api m
s

  route :: Proxy (ReqBody' mods list a :> api)
-> Context context
-> Delayed env (Server (ReqBody' mods list a :> api))
-> Router env
route Proxy (ReqBody' mods list a :> api)
Proxy Context context
context Delayed env (Server (ReqBody' mods list a :> api))
subserver
      = Proxy api
-> Context context -> Delayed env (Server api) -> Router env
forall k (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (Proxy api
forall k (t :: k). Proxy t
Proxy :: Proxy api) Context context
context (Delayed env (Server api) -> Router env)
-> Delayed env (Server api) -> Router env
forall a b. (a -> b) -> a -> b
$
          Delayed
  env (If (FoldLenient mods) (Either String a) a -> Server api)
-> DelayedIO (ByteString -> Either String a)
-> ((ByteString -> Either String a)
    -> DelayedIO (If (FoldLenient mods) (Either String a) a))
-> Delayed env (Server api)
forall env a b c.
Delayed env (a -> b)
-> DelayedIO c -> (c -> DelayedIO a) -> Delayed env b
addBodyCheck Delayed env (Server (ReqBody' mods list a :> api))
Delayed
  env (If (FoldLenient mods) (Either String a) a -> Server api)
subserver DelayedIO (ByteString -> Either String a)
ctCheck (ByteString -> Either String a)
-> DelayedIO (If (FoldLenient mods) (Either String a) a)
bodyCheck
    where
      rep :: TypeRep
rep = Proxy ReqBody' -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy ReqBody'
forall k (t :: k). Proxy t
Proxy :: Proxy ReqBody')
      formatError :: ErrorFormatter
formatError = ErrorFormatters -> ErrorFormatter
bodyParserErrorFormatter (ErrorFormatters -> ErrorFormatter)
-> ErrorFormatters -> ErrorFormatter
forall a b. (a -> b) -> a -> b
$ Context (MkContextWithErrorFormatter context) -> ErrorFormatters
forall (context :: [*]) val.
HasContextEntry context val =>
Context context -> val
getContextEntry (Context context -> Context (MkContextWithErrorFormatter context)
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 = (Request -> DelayedIO (ByteString -> Either String a))
-> DelayedIO (ByteString -> Either String a)
forall a. (Request -> DelayedIO a) -> DelayedIO a
withRequest ((Request -> DelayedIO (ByteString -> Either String a))
 -> DelayedIO (ByteString -> Either String a))
-> (Request -> DelayedIO (ByteString -> Either String a))
-> DelayedIO (ByteString -> Either String a)
forall a b. (a -> b) -> a -> b
$ \ Request
request -> do
        -- See HTTP RFC 2616, section 7.2.1
        -- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
        -- See also "W3C Internet Media Type registration, consistency of use"
        -- http://www.w3.org/2001/tag/2002/0129-mime
        let contentTypeH :: Method
contentTypeH = Method -> Maybe Method -> Method
forall a. a -> Maybe a -> a
fromMaybe Method
"application/octet-stream"
                         (Maybe Method -> Method) -> Maybe Method -> Method
forall a b. (a -> b) -> a -> b
$ HeaderName -> [(HeaderName, Method)] -> Maybe Method
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hContentType ([(HeaderName, Method)] -> Maybe Method)
-> [(HeaderName, Method)] -> Maybe Method
forall a b. (a -> b) -> a -> b
$ Request -> [(HeaderName, Method)]
requestHeaders Request
request
        case Proxy list -> ByteString -> Maybe (ByteString -> Either String a)
forall (list :: [*]) a.
AllCTUnrender list a =>
Proxy list -> ByteString -> Maybe (ByteString -> Either String a)
canHandleCTypeH (Proxy list
forall k (t :: k). Proxy t
Proxy :: Proxy list) (Method -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs Method
contentTypeH) :: Maybe (BL.ByteString -> Either String a) of
          Maybe (ByteString -> Either String a)
Nothing -> ServerError -> DelayedIO (ByteString -> Either String a)
forall a. ServerError -> DelayedIO a
delayedFail ServerError
err415
          Just ByteString -> Either String a
f  -> (ByteString -> Either String a)
-> DelayedIO (ByteString -> Either String a)
forall (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 = (Request -> DelayedIO (If (FoldLenient mods) (Either String a) a))
-> DelayedIO (If (FoldLenient mods) (Either String a) a)
forall a. (Request -> DelayedIO a) -> DelayedIO a
withRequest ((Request -> DelayedIO (If (FoldLenient mods) (Either String a) a))
 -> DelayedIO (If (FoldLenient mods) (Either String a) a))
-> (Request
    -> DelayedIO (If (FoldLenient mods) (Either String a) a))
-> DelayedIO (If (FoldLenient mods) (Either String a) a)
forall a b. (a -> b) -> a -> b
$ \ Request
request -> do
        Either String a
mrqbody <- ByteString -> Either String a
f (ByteString -> Either String a)
-> DelayedIO ByteString -> DelayedIO (Either String a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ByteString -> DelayedIO ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Request -> IO ByteString
lazyRequestBody Request
request)
        case SBool (FoldLenient mods)
forall (b :: Bool). SBoolI b => SBool b
sbool :: SBool (FoldLenient mods) of
          SBool (FoldLenient mods)
STrue -> Either String a -> DelayedIO (Either String a)
forall (m :: * -> *) a. Monad m => a -> m a
return Either String a
mrqbody
          SBool (FoldLenient mods)
SFalse -> case Either String a
mrqbody of
            Left e  -> ServerError
-> DelayedIO (If (FoldLenient mods) (Either String a) a)
forall a. ServerError -> DelayedIO a
delayedFailFatal (ServerError
 -> DelayedIO (If (FoldLenient mods) (Either String a) a))
-> ServerError
-> DelayedIO (If (FoldLenient mods) (Either String a) a)
forall a b. (a -> b) -> a -> b
$ ErrorFormatter
formatError TypeRep
rep Request
request String
e
            Right v -> If (FoldLenient mods) (Either String a) a
-> DelayedIO (If (FoldLenient mods) (Either String a) a)
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 :: Proxy (StreamBody' mods framing ctype a :> api)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (StreamBody' mods framing ctype a :> api) m
-> ServerT (StreamBody' mods framing ctype a :> api) n
hoistServerWithContext Proxy (StreamBody' mods framing ctype a :> api)
_ Proxy context
pc forall x. m x -> n x
nt ServerT (StreamBody' mods framing ctype a :> api) m
s = Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall k (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy api
forall k (t :: k). Proxy t
Proxy :: Proxy api) Proxy context
pc forall x. m x -> n x
nt (ServerT api m -> ServerT api n)
-> (a -> ServerT api m) -> a -> ServerT api n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (StreamBody' mods framing ctype a :> api) m
a -> ServerT api m
s

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

        bodyCheck :: (SourceIO chunk -> a) -> DelayedIO a
        bodyCheck :: (SourceIO chunk -> a) -> DelayedIO a
bodyCheck SourceIO chunk -> a
fromRS = (Request -> DelayedIO a) -> DelayedIO a
forall a. (Request -> DelayedIO a) -> DelayedIO a
withRequest ((Request -> DelayedIO a) -> DelayedIO a)
-> (Request -> DelayedIO a) -> DelayedIO a
forall a b. (a -> b) -> a -> b
$ \Request
req -> do
            let mimeUnrender' :: ByteString -> Either String chunk
mimeUnrender'    = Proxy ctype -> ByteString -> Either String chunk
forall k (ctype :: k) a.
MimeUnrender ctype a =>
Proxy ctype -> ByteString -> Either String a
mimeUnrender (Proxy ctype
forall k (t :: k). Proxy t
Proxy :: Proxy ctype) :: BL.ByteString -> Either String chunk
            let framingUnrender' :: SourceIO Method -> SourceIO chunk
framingUnrender' = Proxy framing
-> (ByteString -> Either String chunk)
-> SourceIO Method
-> SourceIO chunk
forall k (strategy :: k) (m :: * -> *) a.
(FramingUnrender strategy, Monad m) =>
Proxy strategy
-> (ByteString -> Either String a)
-> SourceT m Method
-> SourceT m a
framingUnrender (Proxy framing
forall k (t :: k). Proxy t
Proxy :: Proxy framing) ByteString -> Either String chunk
mimeUnrender' :: SourceIO B.ByteString ->  SourceIO chunk
            let body :: IO Method
body = Request -> IO Method
getRequestBodyChunk Request
req
            let rs :: SourceIO Method
rs = (Method -> Bool) -> IO Method -> SourceIO Method
forall (m :: * -> *) a.
Functor m =>
(a -> Bool) -> m a -> SourceT m a
S.fromAction Method -> Bool
B.null IO Method
body
            let rs' :: a
rs' = SourceIO chunk -> a
fromRS (SourceIO chunk -> a) -> SourceIO chunk -> a
forall a b. (a -> b) -> a -> b
$ SourceIO Method -> SourceIO chunk
framingUnrender' SourceIO Method
rs
            a -> DelayedIO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
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 :: Proxy (path :> api)
-> Context context
-> Delayed env (Server (path :> api))
-> Router env
route Proxy (path :> api)
Proxy Context context
context Delayed env (Server (path :> api))
subserver =
    Text -> Router env -> Router env
forall env a. Text -> Router' env a -> Router' env a
pathRouter
      (String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Proxy path -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal Proxy path
proxyPath))
      (Proxy api
-> Context context -> Delayed env (Server api) -> Router env
forall k (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (Proxy api
forall k (t :: k). Proxy t
Proxy :: Proxy api) Context context
context Delayed env (Server api)
Delayed env (Server (path :> api))
subserver)
    where proxyPath :: Proxy path
proxyPath = Proxy path
forall k (t :: k). Proxy t
Proxy :: Proxy path
  hoistServerWithContext :: Proxy (path :> api)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (path :> api) m
-> ServerT (path :> api) n
hoistServerWithContext Proxy (path :> api)
_ Proxy context
pc forall x. m x -> n x
nt ServerT (path :> api) m
s = Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall k (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy api
forall k (t :: k). Proxy t
Proxy :: Proxy api) Proxy context
pc forall x. m x -> n x
nt ServerT api m
ServerT (path :> api) m
s

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

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

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

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

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

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

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

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

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

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

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

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

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

-- | Singleton type representing a server that serves an empty API.
data EmptyServer = EmptyServer deriving (Typeable, EmptyServer -> EmptyServer -> Bool
(EmptyServer -> EmptyServer -> Bool)
-> (EmptyServer -> EmptyServer -> Bool) -> Eq EmptyServer
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EmptyServer -> EmptyServer -> Bool
$c/= :: EmptyServer -> EmptyServer -> Bool
== :: EmptyServer -> EmptyServer -> Bool
$c== :: EmptyServer -> EmptyServer -> Bool
Eq, Int -> EmptyServer -> String -> String
[EmptyServer] -> String -> String
EmptyServer -> String
(Int -> EmptyServer -> String -> String)
-> (EmptyServer -> String)
-> ([EmptyServer] -> String -> String)
-> Show EmptyServer
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [EmptyServer] -> String -> String
$cshowList :: [EmptyServer] -> String -> String
show :: EmptyServer -> String
$cshow :: EmptyServer -> String
showsPrec :: Int -> EmptyServer -> String -> String
$cshowsPrec :: Int -> EmptyServer -> String -> String
Show, EmptyServer
EmptyServer -> EmptyServer -> Bounded 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]
(EmptyServer -> EmptyServer)
-> (EmptyServer -> EmptyServer)
-> (Int -> EmptyServer)
-> (EmptyServer -> Int)
-> (EmptyServer -> [EmptyServer])
-> (EmptyServer -> EmptyServer -> [EmptyServer])
-> (EmptyServer -> EmptyServer -> [EmptyServer])
-> (EmptyServer -> EmptyServer -> EmptyServer -> [EmptyServer])
-> Enum EmptyServer
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
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 :: ServerT EmptyAPI m
emptyServer = EmptyServer -> Tagged m EmptyServer
forall k (s :: k) b. b -> Tagged s b
Tagged EmptyServer
EmptyServer

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

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

  hoistServerWithContext :: 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
_ = ServerT EmptyAPI m -> ServerT EmptyAPI n
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 :: Proxy (BasicAuth realm usr :> api)
-> Context context
-> Delayed env (Server (BasicAuth realm usr :> api))
-> Router env
route Proxy (BasicAuth realm usr :> api)
Proxy Context context
context Delayed env (Server (BasicAuth realm usr :> api))
subserver =
    Proxy api
-> Context context -> Delayed env (Server api) -> Router env
forall k (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (Proxy api
forall k (t :: k). Proxy t
Proxy :: Proxy api) Context context
context (Delayed env (Server (BasicAuth realm usr :> api))
Delayed env (usr -> Server api)
subserver Delayed env (usr -> Server api)
-> DelayedIO usr -> Delayed env (Server api)
forall env a b.
Delayed env (a -> b) -> DelayedIO a -> Delayed env b
`addAuthCheck` DelayedIO usr
authCheck)
    where
       realm :: Method
realm = String -> Method
BC8.pack (String -> Method) -> String -> Method
forall a b. (a -> b) -> a -> b
$ Proxy realm -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy realm
forall k (t :: k). Proxy t
Proxy :: Proxy realm)
       basicAuthContext :: BasicAuthCheck usr
basicAuthContext = Context context -> BasicAuthCheck usr
forall (context :: [*]) val.
HasContextEntry context val =>
Context context -> val
getContextEntry Context context
context
       authCheck :: DelayedIO usr
authCheck = (Request -> DelayedIO usr) -> DelayedIO usr
forall a. (Request -> DelayedIO a) -> DelayedIO a
withRequest ((Request -> DelayedIO usr) -> DelayedIO usr)
-> (Request -> DelayedIO usr) -> DelayedIO usr
forall a b. (a -> b) -> a -> b
$ \ Request
req -> Request -> Method -> BasicAuthCheck usr -> DelayedIO usr
forall usr.
Request -> Method -> BasicAuthCheck usr -> DelayedIO usr
runBasicAuth Request
req Method
realm BasicAuthCheck usr
basicAuthContext

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

-- * helpers

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

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

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

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

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

-- Erroring instance for 'HasServer' when a combinator is not fully applied
instance TypeError (PartialApplication 
#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 :: Proxy (arr :> sub)
-> Context context
-> Delayed env (Server (arr :> sub))
-> Router env
route = String
-> Proxy (arr :> sub)
-> Context context
-> Delayed env (TypeError ...)
-> Router env
forall a. HasCallStack => String -> a
error String
"unreachable"
    hoistServerWithContext :: Proxy (arr :> sub)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (arr :> sub) m
-> ServerT (arr :> sub) n
hoistServerWithContext Proxy (arr :> sub)
_ Proxy context
_ forall x. m x -> n x
_ ServerT (arr :> sub) m
_ = String -> (TypeError ...)
forall a. HasCallStack => String -> a
error String
"unreachable"

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

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

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

-- XXX: This omits the @context@ parameter, e.g.:
--
-- "There is no instance for HasServer (Bool :> …)". Do we care ?
instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub 
#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 :: Proxy (Fragment a1 :> api)
-> Context context
-> Delayed env (Server (Fragment a1 :> api))
-> Router env
route Proxy (Fragment a1 :> api)
_ = Proxy api
-> Context context -> Delayed env (Server api) -> Router env
forall k (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (Proxy api
forall k (t :: k). Proxy t
Proxy :: Proxy api)

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

-- $setup
-- >>> import Servant

-- | A type that specifies that an API record contains a server implementation.
data AsServerT (m :: * -> *)
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 = Dict (GServerConstraints api m)
forall (a :: Constraint). a => Dict a
Dict

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