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

#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802
#define HAS_TYPE_ERROR
#endif

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.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.Either
                 (partitionEithers)
import           Data.Maybe
                 (fromMaybe, isNothing, mapMaybe, maybeToList)
import           Data.Semigroup
                 ((<>))
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.TypeLits
                 (KnownNat, KnownSymbol, natVal, 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,
                 rawQueryString, remoteHost, requestBody, requestHeaders,
                 requestMethod, responseLBS, responseStream, vault)
import           Prelude ()
import           Prelude.Compat
import           Servant.API
                 ((:<|>) (..), (:>), Accept (..), BasicAuth, Capture',
                 CaptureAll, Description, EmptyAPI, FramingRender (..),
                 FramingUnrender (..), FromSourceIO (..), Header', If,
                 IsSecure (..), QueryFlag, QueryParam', QueryParams, Raw,
                 ReflectMethod (reflectMethod), RemoteHost, ReqBody',
                 SBool (..), SBoolI (..), SourceIO, Stream, StreamBody',
                 Summary, ToSourceIO (..), Vault, Verb, WithNamedContext)
import           Servant.API.ContentTypes
                 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),
                 AllMime, MimeRender (..), MimeUnrender (..), canHandleAcceptH)
import           Servant.API.Modifiers
                 (FoldLenient, FoldRequired, RequestArgument,
                 unfoldRequestArgument)
import           Servant.API.ResponseHeaders
                 (GetHeaders, Headers, getHeaders, getResponse)
import qualified Servant.Types.SourceT                      as S
import           Web.HttpApiData
                 (FromHttpApiData, parseHeader, parseQueryParam,
                 parseUrlPieceMaybe, parseUrlPieces)

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

#ifdef HAS_TYPE_ERROR
import           GHC.TypeLits
                 (ErrorMessage (..), TypeError)
#endif

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 context :: Context context
context server :: 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 ((\ (a :: Server a
a :<|> _) -> 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 ((\ (_ :<|> b :: 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 _ pc :: Proxy context
pc nt :: 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, HasServer api context)
      => HasServer (Capture' mods capture a :> api) context where

  type ServerT (Capture' mods capture a :> api) m =
     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 _ pc :: Proxy context
pc nt :: forall x. m x -> n x
nt s :: 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)
-> (a -> ServerT api m) -> a -> ServerT api n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (Capture' mods capture a :> api) m
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 context :: Context context
context d :: Delayed env (Server (Capture' mods capture a :> api))
d =
    Router' (Text, env) RoutingApplication -> Router env
forall env a. Router' (Text, env) a -> Router' env a
CaptureRouter (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 (Capture' mods 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
$ \ txt :: Text
txt -> case Text -> Maybe a
forall a. FromHttpApiData a => Text -> Maybe a
parseUrlPieceMaybe Text
txt of
                 Nothing -> ServerError -> DelayedIO a
forall a. ServerError -> DelayedIO a
delayedFail ServerError
err400
                 Just v :: a
v  -> a -> DelayedIO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v
              )

-- | 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, HasServer api context)
      => 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 _ pc :: Proxy context
pc nt :: forall x. m x -> n x
nt s :: 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 context :: Context context
context d :: Delayed env (Server (CaptureAll capture a :> api))
d =
    Router' ([Text], env) RoutingApplication -> Router env
forall env a. Router' ([Text], env) a -> Router' env a
CaptureAllRouter (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
$ \ txts :: [Text]
txts -> case [Text] -> Either Text [a]
forall (t :: * -> *) a.
(Traversable t, FromHttpApiData a) =>
t Text -> Either Text (t a)
parseUrlPieces [Text]
txts of
                 Left _  -> ServerError -> DelayedIO [a]
forall a. ServerError -> DelayedIO a
delayedFail ServerError
err400
                 Right v :: [a]
v -> [a] -> DelayedIO [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
v
              )


allowedMethodHead :: Method -> Request -> Bool
allowedMethodHead :: Method -> Request -> Bool
allowedMethodHead method :: Method
method request :: 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
method request :: 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
method request :: 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 -> B.ByteString -> DelayedIO ()
acceptCheck :: Proxy list -> Method -> DelayedIO ()
acceptCheck proxy :: Proxy list
proxy accH :: Method
accH
  | Proxy list -> AcceptHeader -> Bool
forall (list :: [*]).
AllMime list =>
Proxy list -> AcceptHeader -> Bool
canHandleAcceptH Proxy list
proxy (Method -> AcceptHeader
AcceptHeader Method
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 splitHeaders :: b -> ([(HeaderName, Method)], a)
splitHeaders method :: Method
method proxy :: Proxy ctypes
proxy status :: Status
status action :: 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
env request :: Request
request respond :: RouteResult Response -> IO ResponseReceived
respond =
          let accH :: Method
accH = Method -> Maybe Method -> Method
forall a. a -> Maybe a -> a
fromMaybe Method
ct_wildcard (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
hAccept ([(HeaderName, Method)] -> Maybe Method)
-> [(HeaderName, Method)] -> Maybe Method
forall a b. (a -> b) -> a -> b
$ Request -> [(HeaderName, Method)]
requestHeaders 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 -> Method -> DelayedIO ()
forall (list :: [*]).
AllMime list =>
Proxy list -> Method -> DelayedIO ()
acceptCheck Proxy ctypes
proxy Method
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
$ \ output :: b
output -> do
               let (headers :: [(HeaderName, Method)]
headers, b :: 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 (Method -> AcceptHeader
AcceptHeader Method
accH) a
b of
                 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 (contentT :: ByteString
contentT, body :: ByteString
body) ->
                      let bdy :: ByteString
bdy = if Method -> Request -> Bool
allowedMethodHead Method
method Request
request then "" 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

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 _ _ nt :: forall x. m x -> n x
nt s :: 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 _ = (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 = Int -> Status
forall a. Enum a => Int -> a
toEnum (Int -> Status) -> (Integer -> Int) -> Integer -> Status
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Status) -> Integer -> Status
forall a b. (a -> b) -> a -> b
$ Proxy status -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (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 _ _ nt :: forall x. m x -> n x
nt s :: 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 _ = (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 (\x :: 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 = Int -> Status
forall a. Enum a => Int -> a
toEnum (Int -> Status) -> (Integer -> Int) -> Integer -> Status
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Status) -> Integer -> Status
forall a b. (a -> b) -> a -> b
$ Proxy status -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (Proxy status
forall k (t :: k). Proxy t
Proxy :: Proxy status)


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 _ _ nt :: forall x. m x -> n x
nt s :: 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 _ = (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 = Int -> Status
forall a. Enum a => Int -> a
toEnum (Int -> Status) -> (Integer -> Int) -> Integer -> Status
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Status) -> Integer -> Status
forall a b. (a -> b) -> a -> b
$ Proxy status -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (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 _ _ nt :: forall x. m x -> n x
nt s :: 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 _ = (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 (\x :: 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 = Int -> Status
forall a. Enum a => Int -> a
toEnum (Int -> Status) -> (Integer -> Int) -> Integer -> Status
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Status) -> Integer -> Status
forall a b. (a -> b) -> a -> b
$ Proxy status -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (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 splitHeaders :: c -> ([(HeaderName, Method)], a)
splitHeaders method :: Method
method status :: Status
status framingproxy :: Proxy framing
framingproxy ctypeproxy :: Proxy ctype
ctypeproxy action :: 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
env request :: Request
request respond :: RouteResult Response -> IO ResponseReceived
respond ->
          let accH :: Method
accH    = Method -> Maybe Method -> Method
forall a. a -> Maybe a -> a
fromMaybe Method
ct_wildcard (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
hAccept ([(HeaderName, Method)] -> Maybe Method)
-> [(HeaderName, Method)] -> Maybe Method
forall a b. (a -> b) -> a -> b
$ Request -> [(HeaderName, Method)]
requestHeaders 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
$ \ output :: c
output ->
                let (headers :: [(HeaderName, Method)]
headers, fa :: 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 kStepLBS :: 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
$ \write :: Builder -> IO ()
write flush :: IO ()
flush -> do
                    let loop :: StepT IO ByteString -> IO ()
loop S.Stop          = IO ()
flush
                        loop (S.Error err :: String
err)   = String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err -- TODO: throw better error
                        loop (S.Skip s :: StepT IO ByteString
s)      = StepT IO ByteString -> IO ()
loop StepT IO ByteString
s
                        loop (S.Effect ms :: 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 lbs :: ByteString
lbs s :: 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)
  )
  => 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 _ pc :: Proxy context
pc nt :: forall x. m x -> n x
nt s :: 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 context :: Context context
context subserver :: 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
      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 req :: 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)))
forall a. DelayedIO a
errReq Text
-> DelayedIO
     (If
        (FoldRequired mods)
        (If (FoldLenient mods) (Either Text a) a)
        (Maybe (If (FoldLenient mods) (Either Text a) a)))
forall a a.
(ConvertibleStrings a ByteString, Semigroup a, IsString a) =>
a -> DelayedIO 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 a
errReq = ServerError -> DelayedIO a
forall a. ServerError -> DelayedIO a
delayedFailFatal ServerError
err400
            { errBody :: ByteString
errBody = "Header " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
forall n. IsString n => n
headerName ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> " is required"
            }

          errSt :: a -> DelayedIO a
errSt e :: a
e = ServerError -> DelayedIO a
forall a. ServerError -> DelayedIO a
delayedFailFatal ServerError
err400
              { errBody :: ByteString
errBody = a -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (a -> ByteString) -> a -> ByteString
forall a b. (a -> b) -> a -> b
$ "Error parsing header "
                               a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
forall n. IsString n => n
headerName
                               a -> a -> a
forall a. Semigroup a => a -> a -> a
<> " failed: " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
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)
  )
  => 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 _ pc :: Proxy context
pc nt :: forall x. m x -> n x
nt s :: 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 context :: Context context
context subserver :: Delayed env (Server (QueryParam' mods sym a :> api))
subserver =
    let querytext :: Request -> QueryText
querytext req :: Request
req = Method -> QueryText
parseQueryText (Method -> QueryText) -> Method -> QueryText
forall a b. (a -> b) -> a -> b
$ Request -> Method
rawQueryString Request
req
        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)

        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 req :: 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
err400
              { errBody :: ByteString
errBody = Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ "Query parameter " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
paramname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " is required"
              }

            errSt :: Text
-> DelayedIO
     (If
        (FoldRequired mods)
        (If (FoldLenient mods) (Either Text a) a)
        (Maybe (If (FoldLenient mods) (Either Text a) a)))
errSt e :: 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
err400
              { errBody :: ByteString
errBody = Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ "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
<> " 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
$ \req :: 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)
      => 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 _ pc :: Proxy context
pc nt :: forall x. m x -> n x
nt s :: 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 context :: Context context
context subserver :: 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
      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 req :: 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
              ([], parsed :: [a]
parsed) -> [a] -> DelayedIO [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
parsed
              (errs :: [Text]
errs, _)    -> ServerError -> DelayedIO [a]
forall a. ServerError -> DelayedIO a
delayedFailFatal ServerError
err400
                  { errBody :: ByteString
errBody = Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ "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
<> " failed: "
                                   Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate ", " [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
. Method -> QueryText
parseQueryText
                 (Method -> QueryText)
-> (Request -> Method) -> Request -> QueryText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Method
rawQueryString
                 (Request -> [Text]) -> Request -> [Text]
forall a b. (a -> b) -> a -> b
$ Request
req

          looksLikeParam :: Text -> Bool
looksLikeParam name :: 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
<> "[]")

-- | 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 _ pc :: Proxy context
pc nt :: forall x. m x -> n x
nt s :: 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 context :: Context context
context subserver :: Delayed env (Server (QueryFlag sym :> api))
subserver =
    let querytext :: Request -> QueryText
querytext r :: Request
r = Method -> QueryText
parseQueryText (Method -> QueryText) -> Method -> QueryText
forall a b. (a -> b) -> a -> b
$ Request -> Method
rawQueryString Request
r
        param :: Request -> Bool
param r :: 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 Nothing  -> Bool
True  -- param is there, with no value
          Just (Just v :: Text
v) -> Text -> Bool
forall a. (Eq a, IsString a) => a -> Bool
examine Text
v -- param with a value
          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 v :: a
v | a
v a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== "true" Bool -> Bool -> Bool
|| a
v a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== "1" Bool -> Bool -> Bool
|| a
v a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== "" = 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 _ _ _ = 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 _ rawApplication :: 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
env request :: Request
request respond :: 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 r :: RouteResult (Tagged s (t -> (a -> p) -> p))
r request :: t
request respond :: RouteResult a -> p
respond = case RouteResult (Tagged s (t -> (a -> p) -> p))
r of
            Route app :: 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 a :: 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 e :: 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
-- <http://tools.ietf.org/html/rfc7231#section-3.1.1.5 RFC7231>.
-- 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)
         ) => 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 _ pc :: Proxy context
pc nt :: forall x. m x -> n x
nt s :: 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 context :: Context context
context subserver :: 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
      -- 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
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 "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
          Nothing -> ServerError -> DelayedIO (ByteString -> Either String a)
forall a. ServerError -> DelayedIO a
delayedFail ServerError
err415
          Just f :: 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 f :: 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
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
          STrue -> Either String a -> DelayedIO (Either String a)
forall (m :: * -> *) a. Monad m => a -> m a
return Either String a
mrqbody
          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
err400 { errBody :: ByteString
errBody = String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs 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 _ pc :: Proxy context
pc nt :: forall x. m x -> n x
nt s :: 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 context :: Context context
context subserver :: 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 fromRS :: 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
$ \req :: 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
requestBody 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 context :: Context context
context subserver :: 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 _ pc :: Proxy context
pc nt :: forall x. m x -> n x
nt s :: 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 context :: Context context
context subserver :: 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 _ pc :: Proxy context
pc nt :: forall x. m x -> n x
nt s :: 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 context :: Context context
context subserver :: 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 req :: 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 _ pc :: Proxy context
pc nt :: forall x. m x -> n x
nt s :: 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 context :: Context context
context subserver :: 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 _ pc :: Proxy context
pc nt :: forall x. m x -> n x
nt s :: 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 context :: Context context
context subserver :: 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 _ pc :: Proxy context
pc nt :: forall x. m x -> n x
nt s :: 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 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 _ pc :: Proxy ctx
pc nt :: forall x. m x -> n x
nt s :: 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 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 _ pc :: Proxy ctx
pc nt :: forall x. m x -> n x
nt s :: 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 -> ShowS
[EmptyServer] -> ShowS
EmptyServer -> String
(Int -> EmptyServer -> ShowS)
-> (EmptyServer -> String)
-> ([EmptyServer] -> ShowS)
-> Show EmptyServer
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EmptyServer] -> ShowS
$cshowList :: [EmptyServer] -> ShowS
show :: EmptyServer -> String
$cshow :: EmptyServer -> String
showsPrec :: Int -> EmptyServer -> ShowS
$cshowsPrec :: Int -> EmptyServer -> ShowS
Show, EmptyServer
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 `emptyAPIServer`.
--
-- > type MyApi = "nothing" :> EmptyApi
-- >
-- > server :: Server MyApi
-- > server = emptyAPIServer
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 _ _ = 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 _ _ _ = 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 context :: Context context
context subserver :: 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
$ \ req :: 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 _ pc :: Proxy context
pc nt :: forall x. m x -> n x
nt s :: 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
forall a. Semigroup a => a -> a -> a
<> "/" Method -> Method -> Method
forall a. Semigroup a => a -> a -> a
<> "*" -- Because CPP

-- * 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 context :: Context context
context delayed :: 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 _ _ nt :: forall x. m x -> n x
nt s :: 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

-------------------------------------------------------------------------------
-- TypeError helpers
-------------------------------------------------------------------------------

#ifdef HAS_TYPE_ERROR
-- | This instance catches mistakes when there are non-saturated
-- type applications on LHS of ':>'.
--
-- >>> serve (Proxy :: Proxy (Capture "foo" :> Get '[JSON] Int)) (error "...")
-- ...
-- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'.
-- ...Maybe you haven't applied enough arguments to
-- ...Capture' '[] "foo"
-- ...
--
-- >>> undefined :: Server (Capture "foo" :> Get '[JSON] Int)
-- ...
-- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'.
-- ...Maybe you haven't applied enough arguments to
-- ...Capture' '[] "foo"
-- ...
--
instance TypeError (HasServerArrowKindError arr) => HasServer ((arr :: k -> l) :> api) context
  where
    type ServerT (arr :> api) m = TypeError (HasServerArrowKindError arr)
    -- it doens't really matter what sub route we peak
    route :: Proxy (arr :> api)
-> Context context
-> Delayed env (Server (arr :> api))
-> Router env
route _ _ _ = String -> Router env
forall a. HasCallStack => String -> a
error "servant-server panic: impossible happened in HasServer (arr :> api)"
    hoistServerWithContext :: Proxy (arr :> api)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (arr :> api) m
-> ServerT (arr :> api) n
hoistServerWithContext _ _ _ = ServerT (arr :> api) m -> ServerT (arr :> api) n
forall a. a -> a
id

-- Cannot have TypeError here, otherwise use of this symbol will error :)
type HasServerArrowKindError arr =
    'Text "Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'."
    ':$$: 'Text "Maybe you haven't applied enough arguments to"
    ':$$: 'ShowType arr

-- | 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 _ _ _ = String -> Router env
forall a. HasCallStack => String -> a
error "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 _ _ _ = 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
#endif

-- $setup
-- >>> import Servant