2016-01-14 23:43:48 +01:00
|
|
|
{-# LANGUAGE ConstraintKinds #-}
|
2016-02-18 16:36:24 +01:00
|
|
|
{-# LANGUAGE DataKinds #-}
|
2015-05-03 01:28:13 +02:00
|
|
|
{-# LANGUAGE FlexibleContexts #-}
|
2014-12-10 16:10:57 +01:00
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
2015-05-03 01:28:13 +02:00
|
|
|
{-# LANGUAGE TypeFamilies #-}
|
2014-12-10 16:10:57 +01:00
|
|
|
|
|
|
|
-- | This module lets you implement 'Server's for defined APIs. You'll
|
|
|
|
-- most likely just need 'serve'.
|
|
|
|
module Servant.Server
|
2015-02-24 13:46:50 +01:00
|
|
|
( -- * Run a wai application from an API
|
2014-12-10 16:10:57 +01:00
|
|
|
serve
|
2016-02-28 23:23:32 +01:00
|
|
|
, serveWithContext
|
2014-12-10 16:10:57 +01:00
|
|
|
|
2015-02-24 13:46:50 +01:00
|
|
|
, -- * Construct a wai Application from an API
|
|
|
|
toApplication
|
|
|
|
|
2014-12-10 16:10:57 +01:00
|
|
|
, -- * Handlers for all standard combinators
|
|
|
|
HasServer(..)
|
2015-03-09 15:16:38 +01:00
|
|
|
, Server
|
2017-05-16 17:53:19 +02:00
|
|
|
, EmptyServer
|
2017-05-16 17:59:41 +02:00
|
|
|
, emptyServer
|
2017-01-16 10:44:25 +01:00
|
|
|
, Handler (..)
|
|
|
|
, runHandler
|
2015-05-02 04:38:53 +02:00
|
|
|
|
2016-04-07 13:45:15 +02:00
|
|
|
-- * Debugging the server layout
|
|
|
|
, layout
|
|
|
|
, layoutWithContext
|
|
|
|
|
2015-05-02 16:46:43 +02:00
|
|
|
-- * Enter
|
2015-05-03 01:28:13 +02:00
|
|
|
-- $enterDoc
|
|
|
|
|
|
|
|
-- ** Basic functions and datatypes
|
|
|
|
, enter
|
|
|
|
, (:~>)(..)
|
|
|
|
-- ** `Nat` utilities
|
|
|
|
, liftNat
|
|
|
|
, runReaderTNat
|
|
|
|
, evalStateTLNat
|
|
|
|
, evalStateTSNat
|
|
|
|
, logWriterTLNat
|
|
|
|
, logWriterTSNat
|
|
|
|
-- ** Functions based on <https://hackage.haskell.org/package/mmorph mmorph>
|
|
|
|
, hoistNat
|
|
|
|
, embedNat
|
|
|
|
, squashNat
|
|
|
|
, generalizeNat
|
2015-10-12 20:52:15 +02:00
|
|
|
, tweakResponse
|
2015-05-02 16:46:43 +02:00
|
|
|
|
2016-02-28 23:23:32 +01:00
|
|
|
-- * Context
|
|
|
|
, Context(..)
|
|
|
|
, HasContextEntry(getContextEntry)
|
|
|
|
-- ** NamedContext
|
|
|
|
, NamedContext(..)
|
|
|
|
, descendIntoNamedContext
|
2016-01-14 23:43:48 +01:00
|
|
|
|
2016-02-17 19:56:15 +01:00
|
|
|
-- * Basic Authentication
|
|
|
|
, BasicAuthCheck(BasicAuthCheck, unBasicAuthCheck)
|
|
|
|
, BasicAuthResult(..)
|
|
|
|
|
2016-02-17 21:21:57 +01:00
|
|
|
-- * General Authentication
|
2016-03-06 22:23:55 +01:00
|
|
|
-- , AuthHandler(unAuthHandler)
|
|
|
|
-- , AuthServerData
|
|
|
|
-- , mkAuthHandler
|
2016-02-17 21:21:57 +01:00
|
|
|
|
2015-05-02 04:38:53 +02:00
|
|
|
-- * Default error type
|
|
|
|
, ServantErr(..)
|
|
|
|
-- ** 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
|
2017-05-05 10:39:01 +02:00
|
|
|
, err418
|
|
|
|
, err422
|
2016-01-14 23:58:48 +01:00
|
|
|
-- ** 5XX
|
2015-05-02 04:38:53 +02:00
|
|
|
, err500
|
|
|
|
, err501
|
|
|
|
, err502
|
|
|
|
, err503
|
|
|
|
, err504
|
|
|
|
, err505
|
|
|
|
|
2016-05-10 15:40:05 +02:00
|
|
|
-- * Re-exports
|
|
|
|
, Application
|
2015-12-02 21:48:12 +01:00
|
|
|
, Tagged (..)
|
2016-05-10 15:40:05 +02:00
|
|
|
|
2014-12-10 16:10:57 +01:00
|
|
|
) where
|
|
|
|
|
2015-08-17 23:56:29 +02:00
|
|
|
import Data.Proxy (Proxy)
|
2015-12-02 21:48:12 +01:00
|
|
|
import Data.Tagged (Tagged (..))
|
2016-04-07 13:45:15 +02:00
|
|
|
import Data.Text (Text)
|
2015-08-17 23:56:29 +02:00
|
|
|
import Network.Wai (Application)
|
2015-05-03 01:28:13 +02:00
|
|
|
import Servant.Server.Internal
|
2016-04-21 13:31:51 +02:00
|
|
|
import Servant.Utils.Enter
|
2014-12-10 16:10:57 +01:00
|
|
|
|
2015-01-06 17:25:25 +01:00
|
|
|
|
2014-12-10 16:10:57 +01:00
|
|
|
-- * Implementing Servers
|
|
|
|
|
|
|
|
-- | 'serve' allows you to implement an API and produce a wai 'Application'.
|
|
|
|
--
|
|
|
|
-- Example:
|
|
|
|
--
|
2015-01-13 20:40:41 +01:00
|
|
|
-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
|
|
|
|
-- > :<|> "books" :> ReqBody Book :> Post '[JSON] Book -- POST /books
|
2014-12-10 16:10:57 +01:00
|
|
|
-- >
|
|
|
|
-- > server :: Server MyApi
|
|
|
|
-- > server = listAllBooks :<|> postBook
|
|
|
|
-- > where listAllBooks = ...
|
|
|
|
-- > postBook book = ...
|
|
|
|
-- >
|
2015-01-01 21:10:17 +01:00
|
|
|
-- > myApi :: Proxy MyApi
|
2015-01-06 17:25:25 +01:00
|
|
|
-- > myApi = Proxy
|
2015-01-01 21:10:17 +01:00
|
|
|
-- >
|
2014-12-10 16:10:57 +01:00
|
|
|
-- > app :: Application
|
2016-02-18 16:36:24 +01:00
|
|
|
-- > app = serve myApi server
|
2014-12-10 16:10:57 +01:00
|
|
|
-- >
|
|
|
|
-- > main :: IO ()
|
|
|
|
-- > main = Network.Wai.Handler.Warp.run 8080 app
|
2015-05-03 01:28:13 +02:00
|
|
|
--
|
2016-06-02 09:49:55 +02:00
|
|
|
serve :: (HasServer api '[]) => Proxy api -> Server api -> Application
|
2016-02-28 23:23:32 +01:00
|
|
|
serve p = serveWithContext p EmptyContext
|
2016-02-18 16:36:24 +01:00
|
|
|
|
2016-06-02 09:49:55 +02:00
|
|
|
serveWithContext :: (HasServer api context)
|
|
|
|
=> Proxy api -> Context context -> Server api -> Application
|
2016-04-09 15:42:57 +02:00
|
|
|
serveWithContext p context server =
|
|
|
|
toApplication (runRouter (route p context (emptyDelayed (Route server))))
|
2015-05-03 01:28:13 +02:00
|
|
|
|
2016-04-07 13:45:15 +02:00
|
|
|
-- | 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 =
|
2016-07-08 09:11:34 +02:00
|
|
|
-- > "a" :> "d" :> Get '[JSON] NoContent
|
2016-04-07 13:45:15 +02:00
|
|
|
-- > :<|> "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/
|
2016-04-09 15:42:57 +02:00
|
|
|
-- > │ └─ <capture>/
|
2016-04-07 13:45:15 +02:00
|
|
|
-- > │ ├─•
|
|
|
|
-- > │ ┆
|
|
|
|
-- > │ └─•
|
|
|
|
-- > ├─ c/
|
|
|
|
-- > │ └─•
|
|
|
|
-- > ┆
|
|
|
|
-- > └─ <raw>
|
|
|
|
--
|
|
|
|
-- Explanation of symbols:
|
|
|
|
--
|
|
|
|
-- [@├@] Normal lines reflect static branching via a table.
|
|
|
|
--
|
|
|
|
-- [@a/@] Nodes reflect static path components.
|
|
|
|
--
|
|
|
|
-- [@─•@] Leaves reflect endpoints.
|
|
|
|
--
|
2016-04-09 15:42:57 +02:00
|
|
|
-- [@\<capture\>/@] This is a delayed capture of a path component.
|
2016-04-07 13:45:15 +02:00
|
|
|
--
|
|
|
|
-- [@\<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.
|
|
|
|
--
|
2016-06-02 09:49:55 +02:00
|
|
|
layout :: (HasServer api '[]) => Proxy api -> Text
|
2016-04-07 13:45:15 +02:00
|
|
|
layout p = layoutWithContext p EmptyContext
|
|
|
|
|
|
|
|
-- | Variant of 'layout' that takes an additional 'Context'.
|
2016-06-02 09:49:55 +02:00
|
|
|
layoutWithContext :: (HasServer api context)
|
|
|
|
=> Proxy api -> Context context -> Text
|
2016-04-09 15:42:57 +02:00
|
|
|
layoutWithContext p context =
|
|
|
|
routerLayout (route p context (emptyDelayed (FailFatal err501)))
|
2015-05-03 01:28:13 +02:00
|
|
|
|
|
|
|
-- Documentation
|
|
|
|
|
|
|
|
-- $enterDoc
|
2015-09-12 14:11:24 +02:00
|
|
|
-- Sometimes our cherished `ExceptT` monad isn't quite the type you'd like for
|
2015-05-03 01:28:13 +02:00
|
|
|
-- 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. Enter
|
|
|
|
-- `enter`.
|
|
|
|
--
|
2017-04-28 13:31:57 +02:00
|
|
|
-- With `enter`, you can provide a function, wrapped in the `(:~>)` / `NT`
|
2015-05-03 01:28:13 +02:00
|
|
|
-- newtype, to convert any number of endpoints from one type constructor to
|
|
|
|
-- another. For example
|
|
|
|
--
|
2015-12-02 21:48:12 +01:00
|
|
|
-- /Note:/ 'Server' 'Raw' can also be entered. It will be retagged.
|
|
|
|
--
|
2015-05-03 01:28:13 +02:00
|
|
|
-- >>> import Control.Monad.Reader
|
|
|
|
-- >>> import qualified Control.Category as C
|
2017-05-17 07:12:23 +02:00
|
|
|
-- >>> type ReaderAPI = "ep1" :> Get '[JSON] Int :<|> "ep2" :> Get '[JSON] String :<|> Raw :<|> EmptyAPI
|
|
|
|
-- >>> let readerServer = return 1797 :<|> ask :<|> Tagged (error "raw server") :<|> emptyServer :: ServerT ReaderAPI (Reader String)
|
2017-04-28 13:31:57 +02:00
|
|
|
-- >>> let nt = generalizeNat C.. (runReaderTNat "hi") :: Reader String :~> Handler
|
|
|
|
-- >>> let mainServer = enter nt readerServer :: Server ReaderAPI
|
2015-05-03 01:28:13 +02:00
|
|
|
--
|
|
|
|
|
|
|
|
-- $setup
|
2017-05-15 14:52:22 +02:00
|
|
|
-- >>> :set -XDataKinds
|
|
|
|
-- >>> :set -XTypeOperators
|
2015-05-03 01:28:13 +02:00
|
|
|
-- >>> import Servant.API
|
|
|
|
-- >>> import Servant.Server
|