{-# LANGUAGE ConstraintKinds     #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE TypeOperators       #-}

-- | This module lets you implement 'Server's for defined APIs. You'll
-- most likely just need 'serve'.
module Servant.Server
  ( -- * Run a wai application from an API
    serve
  , serveWithContext
  , serveWithContextT
  , ServerContext

  , -- * Construct a wai Application from an API
    toApplication

  , -- * Handlers for all standard combinators
    HasServer(..)
  , Server
  , EmptyServer
  , emptyServer
  , Handler (..)
  , runHandler

    -- * Debugging the server layout
  , layout
  , layoutWithContext

    -- * Enter / hoisting server
  , hoistServer

  -- ** Functions based on <https://hackage.haskell.org/package/mmorph mmorph>
  , tweakResponse

  -- * Context
  , Context(..)
  , HasContextEntry(getContextEntry)
  , type (.++)
  , (.++)
  -- ** NamedContext
  , NamedContext(..)
  , descendIntoNamedContext

  -- * Basic Authentication
  , BasicAuthCheck(BasicAuthCheck, unBasicAuthCheck)
  , BasicAuthResult(..)

  -- * General Authentication
  -- , AuthHandler(unAuthHandler)
  -- , AuthServerData
  -- , mkAuthHandler

    -- * Default error type
  , ServerError(..)
    -- ** 3XX
  , err300
  , err301
  , err302
  , err303
  , err304
  , err305
  , err307
    -- ** 4XX
  , err400
  , err401
  , err402
  , err403
  , err404
  , err405
  , err406
  , err407
  , err409
  , err410
  , err411
  , err412
  , err413
  , err414
  , err415
  , err416
  , err417
  , err418
  , err422
   -- ** 5XX
  , err500
  , err501
  , err502
  , err503
  , err504
  , err505

  -- * Formatting of errors from combinators
  --
  -- | You can configure how Servant will render errors that occur while parsing the request.

  , ErrorFormatter
  , NotFoundErrorFormatter
  , ErrorFormatters

  , bodyParserErrorFormatter
  , urlParseErrorFormatter
  , headerParseErrorFormatter
  , notFoundErrorFormatter

  , DefaultErrorFormatters
  , defaultErrorFormatters

  , getAcceptHeader

  -- * Re-exports
  , Application
  , Tagged (..)
  , module Servant.Server.UVerb

  ) where

import           Data.Proxy
                 (Proxy (..))
import           Data.Tagged
                 (Tagged (..))
import           Data.Text
                 (Text)
import           Network.Wai
                 (Application)
import           Servant.Server.Internal
import           Servant.Server.UVerb


-- * Implementing Servers

-- | Constraints that need to be satisfied on a context for it to be passed to 'serveWithContext'.
--
-- Typically, this will add default context entries to the context. You shouldn't typically
-- need to worry about these constraints, but if you write a helper function that wraps
-- 'serveWithContext', you might need to include this constraint.
type ServerContext context =
  ( HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters
  )

-- | 'serve' allows you to implement an API and produce a wai 'Application'.
--
-- Example:
--
-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
-- >         :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books
-- >
-- > server :: Server MyApi
-- > server = listAllBooks :<|> postBook
-- >   where listAllBooks = ...
-- >         postBook book = ...
-- >
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
-- > app :: Application
-- > app = serve myApi server
-- >
-- > main :: IO ()
-- > main = Network.Wai.Handler.Warp.run 8080 app
--
serve :: (HasServer api '[]) => Proxy api -> Server api -> Application
serve :: forall api.
HasServer api '[] =>
Proxy api -> Server api -> Application
serve Proxy api
p = Proxy api -> Context '[] -> ServerT api Handler -> Application
forall api (context :: [*]).
(HasServer api context, ServerContext context) =>
Proxy api -> Context context -> Server api -> Application
serveWithContext Proxy api
p Context '[]
EmptyContext

-- | Like 'serve', but allows you to pass custom context.
--
-- 'defaultErrorFormatters' will always be appended to the end of the passed context,
-- but if you pass your own formatter, it will override the default one.
serveWithContext :: ( HasServer api context
                    , ServerContext context
                    )
    => Proxy api -> Context context -> Server api -> Application
serveWithContext :: forall api (context :: [*]).
(HasServer api context, ServerContext context) =>
Proxy api -> Context context -> Server api -> Application
serveWithContext Proxy api
p Context context
context = Proxy api
-> Context context
-> (forall x. Handler x -> Handler x)
-> ServerT api Handler
-> Application
forall api (context :: [*]) (m :: * -> *).
(HasServer api context, ServerContext context) =>
Proxy api
-> Context context
-> (forall x. m x -> Handler x)
-> ServerT api m
-> Application
serveWithContextT Proxy api
p Context context
context Handler x -> Handler x
forall a. a -> a
forall x. Handler x -> Handler x
id

-- | A general 'serve' function that allows you to pass a custom context and hoisting function to
-- apply on all routes.
serveWithContextT ::
  forall api context m.
  (HasServer api context, ServerContext context) =>
  Proxy api -> Context context -> (forall x. m x -> Handler x) -> ServerT api m -> Application
serveWithContextT :: forall api (context :: [*]) (m :: * -> *).
(HasServer api context, ServerContext context) =>
Proxy api
-> Context context
-> (forall x. m x -> Handler x)
-> ServerT api m
-> Application
serveWithContextT Proxy api
p Context context
context forall x. m x -> Handler x
toHandler ServerT api m
server =
  RoutingApplication -> Application
toApplication (NotFoundErrorFormatter -> Router () -> RoutingApplication
runRouter NotFoundErrorFormatter
format404 (Proxy api
-> Context context -> Delayed () (Server api) -> Router ()
forall env.
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
p Context context
context (RouteResult (Server api) -> Delayed () (Server api)
forall a env. RouteResult a -> Delayed env a
emptyDelayed RouteResult (Server api)
router)))
  where
    router :: RouteResult (Server api)
router = Server api -> RouteResult (Server api)
forall a. a -> RouteResult a
Route (Server api -> RouteResult (Server api))
-> Server api -> RouteResult (Server api)
forall a b. (a -> b) -> a -> b
$ Proxy api
-> Proxy context
-> (forall x. m x -> Handler x)
-> ServerT api m
-> Server api
forall {k} (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall (m :: * -> *) (n :: * -> *).
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext Proxy api
p (Proxy context
forall {k} (t :: k). Proxy t
Proxy :: Proxy context) m x -> Handler x
forall x. m x -> Handler x
toHandler ServerT api m
server
    format404 :: NotFoundErrorFormatter
format404 = ErrorFormatters -> NotFoundErrorFormatter
notFoundErrorFormatter (ErrorFormatters -> NotFoundErrorFormatter)
-> (Context context -> ErrorFormatters)
-> Context context
-> NotFoundErrorFormatter
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context (context .++ '[ErrorFormatters]) -> ErrorFormatters
forall (context :: [*]) val.
HasContextEntry context val =>
Context context -> val
getContextEntry (Context (context .++ '[ErrorFormatters]) -> ErrorFormatters)
-> (Context context -> Context (context .++ '[ErrorFormatters]))
-> Context context
-> ErrorFormatters
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context context -> Context (context .++ '[ErrorFormatters])
forall (ctx :: [*]).
Context ctx -> Context (MkContextWithErrorFormatter ctx)
mkContextWithErrorFormatter (Context context -> NotFoundErrorFormatter)
-> Context context -> NotFoundErrorFormatter
forall a b. (a -> b) -> a -> b
$ Context context
context

-- | Hoist server implementation.
--
-- Sometimes our cherished `Handler` monad isn't quite the type you'd like for
-- your handlers. Maybe you want to thread some configuration in a @Reader@
-- monad. Or have your types ensure that your handlers don't do any IO. Use
-- `hoistServer` (a successor of now deprecated @enter@).
--
-- With `hoistServer`, you can provide a function,
-- to convert any number of endpoints from one type constructor to
-- another. For example
--
-- /Note:/ 'Server' 'Raw' can also be entered. It will be retagged.
--
-- >>> import Control.Monad.Reader
-- >>> type ReaderAPI = "ep1" :> Get '[JSON] Int :<|> "ep2" :> Get '[JSON] String :<|> Raw :<|> EmptyAPI
-- >>> let readerApi = Proxy :: Proxy ReaderAPI
-- >>> let readerServer = return 1797 :<|> ask :<|> Tagged (error "raw server") :<|> emptyServer :: ServerT ReaderAPI (Reader String)
-- >>> let nt x = return (runReader x "hi")
-- >>> let mainServer = hoistServer readerApi nt readerServer :: Server ReaderAPI
--
hoistServer :: (HasServer api '[]) => Proxy api
            -> (forall x. m x -> n x) -> ServerT api m -> ServerT api n
hoistServer :: forall api (m :: * -> *) (n :: * -> *).
HasServer api '[] =>
Proxy api
-> (forall x. m x -> n x) -> ServerT api m -> ServerT api n
hoistServer Proxy api
p = Proxy api
-> Proxy '[]
-> (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
forall (m :: * -> *) (n :: * -> *).
Proxy api
-> Proxy '[]
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext Proxy api
p (Proxy '[]
forall {k} (t :: k). Proxy t
Proxy :: Proxy '[])

-- | The function 'layout' produces a textual description of the internal
-- router layout for debugging purposes. Note that the router layout is
-- determined just by the API, not by the handlers.
--
-- Example:
--
-- For the following API
--
-- > type API =
-- >        "a" :> "d" :> Get '[JSON] NoContent
-- >   :<|> "b" :> Capture "x" Int :> Get '[JSON] Bool
-- >   :<|> "c" :> Put '[JSON] Bool
-- >   :<|> "a" :> "e" :> Get '[JSON] Int
-- >   :<|> "b" :> Capture "x" Int :> Put '[JSON] Bool
-- >   :<|> Raw
--
-- we get the following output:
--
-- > /
-- > ├─ a/
-- > │  ├─ d/
-- > │  │  └─•
-- > │  └─ e/
-- > │     └─•
-- > ├─ b/
-- > │  └─ <x::Int>/
-- > │     ├─•
-- > │     ┆
-- > │     └─•
-- > ├─ c/
-- > │  └─•
-- > ┆
-- > └─ <raw>
--
-- Explanation of symbols:
--
-- [@├@] Normal lines reflect static branching via a table.
--
-- [@a/@] Nodes reflect static path components.
--
-- [@─•@] Leaves reflect endpoints.
--
-- [@\<x::Int\>/@] This is a delayed capture of a single
-- path component named @x@, of expected type @Int@.
--
-- [@\<raw\>@] This is a part of the API we do not know anything about.
--
-- [@┆@] Dashed lines suggest a dynamic choice between the part above
-- and below. If there is a success for fatal failure in the first part,
-- that one takes precedence. If both parts fail, the \"better\" error
-- code will be returned.
--
layout :: (HasServer api '[]) => Proxy api -> Text
layout :: forall api. HasServer api '[] => Proxy api -> Text
layout Proxy api
p = Proxy api -> Context '[] -> Text
forall api (context :: [*]).
HasServer api context =>
Proxy api -> Context context -> Text
layoutWithContext Proxy api
p Context '[]
EmptyContext

-- | Variant of 'layout' that takes an additional 'Context'.
layoutWithContext :: (HasServer api context)
    => Proxy api -> Context context -> Text
layoutWithContext :: forall api (context :: [*]).
HasServer api context =>
Proxy api -> Context context -> Text
layoutWithContext Proxy api
p Context context
context =
  Router' Any RoutingApplication -> Text
forall env a. Router' env a -> Text
routerLayout (Proxy api
-> Context context
-> Delayed Any (Server api)
-> Router' Any RoutingApplication
forall env.
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
p Context context
context (RouteResult (Server api) -> Delayed Any (Server api)
forall a env. RouteResult a -> Delayed env a
emptyDelayed (ServerError -> RouteResult (Server api)
forall a. ServerError -> RouteResult a
FailFatal ServerError
err501)))

-- $setup
-- >>> :set -XDataKinds
-- >>> :set -XTypeOperators
-- >>> import Servant.API
-- >>> import Servant.Server