servant-server 0.2.4 → 0.4.0
raw patch · 11 files changed
+982/−160 lines, 11 filesdep +bytestring-conversiondep +doctestdep +filemanipdep ~aesondep ~attoparsecdep ~base
Dependencies added: bytestring-conversion, doctest, filemanip, mmorph, mtl
Dependency ranges changed: aeson, attoparsec, base, bytestring, either, http-types, network-uri, safe, servant, split, string-conversions, system-filepath, text, transformers, wai, wai-app-static, warp
Files
- CHANGELOG.md +20/−2
- README.md +5/−6
- example/greet.hs +4/−4
- servant-server.cabal +44/−22
- src/Servant.hs +0/−2
- src/Servant/Server.hs +100/−8
- src/Servant/Server/Internal.hs +456/−115
- src/Servant/Server/Internal/Enter.hs +105/−0
- src/Servant/Server/Internal/ServantErr.hs +229/−0
- src/Servant/Utils/StaticFiles.hs +1/−1
- test/Doctests.hs +18/−0
CHANGELOG.md view
@@ -1,7 +1,25 @@-master-------+0.4+---+* `Delete` now is like `Get`, `Post`, `Put`, and `Patch` and returns a response body+* Add a `RouteMismatch` constructor for arbitrary HTTP response codes (https://github.com/haskell-servant/servant-server/pull/22)+* Add support for the `Patch` combinator+* Support for `Accept`/`Content-type` headers and for the content-type aware combinators in *servant-0.4*+* Export `toApplication` from `Servant.Server` (https://github.com/haskell-servant/servant-server/pull/29)+* Support other Monads than just `EitherT (Int, String) IO` (https://github.com/haskell-servant/servant-server/pull/21)+* Make methods return status code 204 if they return () (https://github.com/haskell-servant/servant-server/issues/28)+* Add server support for response headers+* Use `ServantErr` instead of `(Int,String)` in `EitherT` handlers+* Add `errXXX` functions for HTTP errors with sensible default reason strings+* Add `enter` function for applying natural transformations to handlers +0.2.4+----- * Added support for matrix parameters, see e.g. http://www.w3.org/DesignIssues/MatrixURIs.html+* Add support for serializing based on Accept header+ (https://github.com/haskell-servant/servant-server/issues/9)+* Ignore trailing slashes+ (https://github.com/haskell-servant/servant-server/issues/5)+ 0.2.3 -----
README.md view
@@ -1,7 +1,5 @@ # servant-server -[](http://travis-ci.org/haskell-servant/servant-server)-  This library lets you *implement* an HTTP server with handlers for each endpoint of a servant API, handling most of the boilerplate for you.@@ -12,7 +10,8 @@ ## Repositories and Haddocks -- The core [servant](http://github.com/haskell-servant) package - [docs](http://haskell-servant.github.io/servant/)-- (Haskell) client-side function generation with [servant-client](http://github.com/haskell-servant/servant-client) - [docs](http://haskell-servant.github.io/servant-client/)-- (Javascript) client-side function generation with [servant-jquery](http://github.com/haskell-servant/servant-jquery) - [docs](http://haskell-servant.github.io/servant-jquery/)-- API docs generation with [servant-docs](http://github.com/haskell-servant/servant-docs) - [docs](http://haskell-servant.github.io/servant-docs/)+- The core [servant](http://github.com/haskell-servant) package - [docs](http://hackage.haskell.org/package/servant)+- Implementing an HTTP server for a webservice API with [servant-server](http://github.com/haskell-servant/servant/tree/master/servant-server) - [docs](http://hackage.haskell.org/package/servant-server)+- (Haskell) client-side function generation with [servant-client](http://github.com/haskell-servant/servant/tree/master/servant-client) - [docs](http://hackage.haskell.org/package/servant-client)+- (Javascript) client-side function generation with [servant-jquery](http://github.com/haskell-servant/servant/tree/master/servant-jquery) - [docs](http://hackage.haskell.org/package/servant-jquery)+- API docs generation with [servant-docs](http://github.com/haskell-servant/servant/tree/master/servant-docs) - [docs](http://hackage.haskell.org/package/servant-docs)
example/greet.hs view
@@ -18,7 +18,7 @@ -- * Example -- | A greet message data type-newtype Greet = Greet { msg :: Text }+newtype Greet = Greet { _msg :: Text } deriving (Generic, Show) instance FromJSON Greet@@ -27,14 +27,14 @@ -- API specification type TestApi = -- GET /hello/:name?capital={true, false} returns a Greet as JSON- "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get Greet+ "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON] Greet -- POST /greet with a Greet as JSON in the request body, -- returns a Greet as JSON- :<|> "greet" :> ReqBody Greet :> Post Greet+ :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet -- DELETE /greet/:greetid- :<|> "greet" :> Capture "greetid" Text :> Delete+ :<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] () testApi :: Proxy TestApi testApi = Proxy
servant-server.cabal view
@@ -1,15 +1,19 @@ name: servant-server-version: 0.2.4+version: 0.4.0 synopsis: A family of combinators for defining webservices APIs and serving them description: A family of combinators for defining webservices APIs and serving them .- You can learn about the basics in <http://haskell-servant.github.io/getting-started/ the getting started> guide.+ You can learn about the basics in <http://haskell-servant.github.io/getting-started/ the getting started>+ guide. .- <https://github.com/haskell-servant/servant-server/blob/master/example/greet.hs Here>'s a runnable example, with comments, that defines a dummy API and- implements a webserver that serves this API, using this package.+ <https://github.com/haskell-servant/servant/blob/master/servant-server/example/greet.hs Here>+ is a runnable example, with comments, that defines a dummy API and implements+ a webserver that serves this API, using this package.+ .+ <https://github.com/haskell-servant/servant/blob/master/servant-server/CHANGELOG.md CHANGELOG> homepage: http://haskell-servant.github.io/-Bug-reports: http://github.com/haskell-servant/servant-server/issues+Bug-reports: http://github.com/haskell-servant/servant/issues license: BSD3 license-file: LICENSE author: Alp Mestanogullari, Sönke Hahn, Julian K. Arni@@ -26,30 +30,35 @@ type: git location: http://github.com/haskell-servant/servant-server.git + library exposed-modules: Servant Servant.Server Servant.Server.Internal+ Servant.Server.Internal.ServantErr+ Servant.Server.Internal.Enter Servant.Utils.StaticFiles build-depends:- base >=4.7 && <5- , aeson- , attoparsec- , bytestring- , either >= 4.3- , http-types- , network-uri >= 2.6- , safe- , servant >= 0.2.2- , split- , string-conversions- , system-filepath- , text- , transformers- , wai- , wai-app-static >= 3.0.0.6- , warp+ base >= 4.7 && < 5+ , aeson >= 0.7 && < 0.9+ , attoparsec >= 0.12 && < 0.13+ , bytestring >= 0.10 && < 0.11+ , either >= 4.3 && < 4.4+ , http-types >= 0.8 && < 0.9+ , network-uri >= 2.6 && < 2.7+ , mtl >= 2 && < 3+ , mmorph >= 1+ , safe >= 0.3 && < 0.4+ , servant == 0.4.*+ , split >= 0.2 && < 0.3+ , string-conversions >= 0.3 && < 0.4+ , system-filepath >= 0.4 && < 0.5+ , text >= 1.2 && < 1.3+ , transformers >= 0.3 && < 0.5+ , wai >= 3.0 && < 3.1+ , wai-app-static >= 3.0 && < 3.1+ , warp >= 3.0 && < 3.1 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall@@ -79,6 +88,7 @@ base == 4.* , aeson , bytestring+ , bytestring-conversion , directory , either , exceptions@@ -94,6 +104,18 @@ , temporary , text , transformers+ , mtl , wai , wai-extra , warp++test-suite doctests+ build-depends: base+ , servant+ , doctest+ , filemanip+ type: exitcode-stdio-1.0+ main-is: test/Doctests.hs+ buildable: True+ default-language: Haskell2010+ ghc-options: -threaded
src/Servant.hs view
@@ -8,7 +8,6 @@ -- | Using your types in request paths and query string parameters module Servant.Common.Text, -- | Utilities on top of the servant core- module Servant.QQ, module Servant.Utils.Links, module Servant.Utils.StaticFiles, -- | Useful re-exports@@ -19,6 +18,5 @@ import Servant.API import Servant.Common.Text import Servant.Server-import Servant.QQ import Servant.Utils.Links import Servant.Utils.StaticFiles
src/Servant/Server.hs view
@@ -1,30 +1,97 @@-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-} -- | This module lets you implement 'Server's for defined APIs. You'll -- most likely just need 'serve'. module Servant.Server- ( -- * Implementing an API+ ( -- * Run a wai application from an API serve + , -- * Construct a wai Application from an API+ toApplication+ , -- * Handlers for all standard combinators HasServer(..)- ) where+ , Server -import Data.Proxy (Proxy)-import Network.Wai (Application)+ -- * Enter+ -- $enterDoc -import Servant.Server.Internal+ -- ** Basic functions and datatypes+ , enter+ , (:~>)(..)+ -- ** `Nat` utilities+ , liftNat+ , runReaderTNat+ , evalStateTLNat+ , evalStateTSNat+ , logWriterTLNat+ , logWriterTSNat+#if MIN_VERSION_mtl(2,2,1)+ , fromExceptT+#endif+ -- ** Functions based on <https://hackage.haskell.org/package/mmorph mmorph>+ , hoistNat+ , embedNat+ , squashNat+ , generalizeNat + -- * 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+ -- * 5XX+ , err500+ , err501+ , err502+ , err503+ , err504+ , err505++ ) where++import Data.Proxy (Proxy)+import Network.Wai (Application)+import Servant.Server.Internal+import Servant.Server.Internal.Enter+import Servant.Server.Internal.ServantErr++ -- * Implementing Servers -- | 'serve' allows you to implement an API and produce a wai 'Application'. -- -- Example: ----- > type MyApi = "books" :> Get [Book] -- GET /books--- > :<|> "books" :> ReqBody Book :> Post Book -- POST /books+-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books+-- > :<|> "books" :> ReqBody Book :> Post '[JSON] Book -- POST /books -- > -- > server :: Server MyApi -- > server = listAllBooks :<|> postBook@@ -39,5 +106,30 @@ -- > -- > main :: IO () -- > main = Network.Wai.Handler.Warp.run 8080 app+-- serve :: HasServer layout => Proxy layout -> Server layout -> Application serve p server = toApplication (route p server)+++-- Documentation++-- $enterDoc+-- Sometimes our cherished `EitherT` 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. Enter+-- `enter`.+--+-- With `enter`, you can provide a function, wrapped in the `(:~>)` / `Nat`+-- newtype, to convert any number of endpoints from one type constructor to+-- another. For example+--+-- >>> import Control.Monad.Reader+-- >>> import qualified Control.Category as C+-- >>> type ReaderAPI = "ep1" :> Get '[JSON] Int :<|> "ep2" :> Get '[JSON] String+-- >>> let readerServer = return 1797 :<|> ask :: ServerT ReaderAPI (Reader String)+-- >>> let mainServer = enter (generalizeNat C.. (runReaderTNat "hi")) readerServer :: Server ReaderAPI+--++-- $setup+-- >>> import Servant.API+-- >>> import Servant.Server
src/Servant/Server/Internal.hs view
@@ -1,39 +1,62 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+#if !MIN_VERSION_base(4,8,0)+{-# LANGUAGE OverlappingInstances #-}+#endif+ module Servant.Server.Internal where -import Control.Applicative ((<$>))-import Control.Monad.Trans.Either (EitherT, runEitherT)-import Data.Aeson (ToJSON, FromJSON, encode, eitherDecode')-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL-import Data.IORef (newIORef, readIORef, writeIORef)-import Data.List (unfoldr)-import Data.Maybe (catMaybes)-import Data.Monoid (Monoid, mempty, mappend)-import Data.Proxy (Proxy(Proxy))-import Data.String (fromString)-import Data.String.Conversions (cs, (<>))-import Data.Text.Encoding (decodeUtf8, encodeUtf8)-import Data.Text (Text)-import qualified Data.Text as T-import GHC.TypeLits (KnownSymbol, symbolVal)-import Network.HTTP.Types hiding (Header)-import Network.Wai (Response, Request, ResponseReceived, Application, pathInfo, requestBody,- strictRequestBody, lazyRequestBody, requestHeaders, requestMethod,- rawQueryString, responseLBS)-import Servant.API (QueryParams, QueryParam, QueryFlag, MatrixParams, MatrixParam, MatrixFlag, ReqBody, Header, Capture, Get, Delete, Put, Post, Raw, (:>), (:<|>)(..))-import Servant.Common.Text (FromText, fromText)+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+import Data.Monoid (Monoid, mappend, mempty)+#endif+import Control.Monad.Trans.Either (EitherT, runEitherT)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import Data.IORef (newIORef, readIORef, writeIORef)+import Data.List (unfoldr)+import Data.Maybe (catMaybes, fromMaybe)+import Data.String (fromString)+import Data.String.Conversions (cs, (<>))+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import Data.Typeable+import GHC.TypeLits (KnownSymbol, symbolVal)+import Network.HTTP.Types hiding (Header, ResponseHeaders)+import Network.Wai (Application, Request, Response,+ ResponseReceived, lazyRequestBody,+ pathInfo, rawQueryString,+ requestBody, requestHeaders,+ requestMethod, responseLBS,+ strictRequestBody)+import Servant.API ((:<|>) (..), (:>), Capture,+ Delete, Get, Header,+ MatrixFlag, MatrixParam, MatrixParams,+ Patch, Post, Put, QueryFlag,+ QueryParam, QueryParams, Raw,+ ReqBody)+import Servant.API.ContentTypes (AcceptHeader (..),+ AllCTRender (..),+ AllCTUnrender (..))+import Servant.API.ResponseHeaders (Headers, getResponse, GetHeaders,+ getHeaders)+import Servant.Common.Text (FromText, fromText) +import Servant.Server.Internal.ServantErr+ data ReqBodyState = Uncalled | Called !B.ByteString | Done !B.ByteString + toApplication :: RoutingApplication -> Application toApplication ra request respond = do reqBodyRef <- newIORef Uncalled@@ -65,33 +88,34 @@ routingRespond (Left WrongMethod) = respond $ responseLBS methodNotAllowed405 [] "method not allowed" routingRespond (Left (InvalidBody err)) =- respond $ responseLBS badRequest400 [] $ fromString $ "Invalid JSON in request body: " ++ err+ respond $ responseLBS badRequest400 [] $ fromString $ "invalid request body: " ++ err+ routingRespond (Left UnsupportedMediaType) =+ respond $ responseLBS unsupportedMediaType415 [] "unsupported media type"+ routingRespond (Left (HttpError status body)) =+ respond $ responseLBS status [] $ fromMaybe (BL.fromStrict $ statusMessage status) body routingRespond (Right response) = respond response +-- Note that the ordering of the constructors has great significance! It+-- determines the Ord instance and, consequently, the monoid instance. -- * Route mismatch data RouteMismatch = NotFound -- ^ the usual "not found" error | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error+ | UnsupportedMediaType -- ^ request body has unsupported media type | InvalidBody String -- ^ an even more informative "your json request body wasn't valid" error- deriving (Eq, Show)+ | HttpError Status (Maybe BL.ByteString) -- ^ an even even more informative arbitrary HTTP response code error.+ deriving (Eq, Ord, Show) --- |--- @--- > mempty = NotFound--- >--- > NotFound `mappend` x = x--- > WrongMethod `mappend` InvalidBody s = InvalidBody s--- > WrongMethod `mappend` _ = WrongMethod--- > InvalidBody s `mappend` _ = InvalidBody s--- @ instance Monoid RouteMismatch where mempty = NotFound+ -- The following isn't great, since it picks @InvalidBody@ based on+ -- alphabetical ordering, but any choice would be arbitrary.+ --+ -- "As one judge said to the other, 'Be just and if you can't be just, be+ -- arbitrary'" -- William Burroughs+ mappend = max - NotFound `mappend` x = x- WrongMethod `mappend` InvalidBody s = InvalidBody s- WrongMethod `mappend` _ = WrongMethod- InvalidBody s `mappend` _ = InvalidBody s -- | A wrapper around @'Either' 'RouteMismatch' a@. newtype RouteResult a =@@ -153,10 +177,11 @@ where pinfo = parsePathInfo r class HasServer layout where- type Server layout :: *- route :: Proxy layout -> Server layout -> RoutingApplication+ type ServerT layout (m :: * -> *) :: * + route :: Proxy layout -> Server layout -> RoutingApplication +type Server layout = ServerT layout (EitherT ServantErr IO) -- * Instances @@ -164,17 +189,19 @@ -- represented by @a@ and if it fails tries @b@. You must provide a request -- handler for each route. ----- > type MyApi = "books" :> Get [Book] -- GET /books--- > :<|> "books" :> ReqBody Book :> Post Book -- POST /books+-- > 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, HasServer b) => HasServer (a :<|> b) where- type Server (a :<|> b) = Server a :<|> Server b++ type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m+ route Proxy (a :<|> b) request respond =- route pa a request $ \ mResponse ->+ route pa a request $ \mResponse -> if isMismatch mResponse then route pb b request $ \mResponse' -> respond (mResponse <> mResponse') else respond mResponse@@ -196,7 +223,7 @@ -- -- Example: ----- > type MyApi = "books" :> Capture "isbn" Text :> Get Book+-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book -- > -- > server :: Server MyApi -- > server = getBook@@ -205,8 +232,8 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout) => HasServer (Capture capture a :> sublayout) where - type Server (Capture capture a :> sublayout) =- a -> Server sublayout+ type ServerT (Capture capture a :> sublayout) m =+ a -> ServerT sublayout m route Proxy subserver request respond = case processedPathInfo request of (first : rest)@@ -218,8 +245,8 @@ _ -> respond $ failWith NotFound where captureProxy = Proxy :: Proxy (Capture capture a)- + -- | If you have a 'Delete' endpoint in your API, -- the handler for this endpoint is meant to delete -- a resource.@@ -231,21 +258,74 @@ -- to be returned. You can use 'Control.Monad.Trans.Either.left' to -- painlessly error out if the conditions for a successful deletion -- are not met.-instance HasServer Delete where- type Server Delete = EitherT (Int, String) IO ()+instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPABLE #-}+#endif+ ( AllCTRender ctypes a+ ) => HasServer (Delete ctypes a) where + type ServerT (Delete ctypes a) m = m a+ route Proxy action request respond | pathIsEmpty request && requestMethod request == methodDelete = do e <- runEitherT action- respond $ succeedWith $ case e of- Right () ->- responseLBS status204 [] ""- Left (status, message) ->- responseLBS (mkStatus status (cs message)) [] (cs message)+ respond $ case e of+ Right output -> do+ let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request+ case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of+ Nothing -> failWith UnsupportedMediaType+ Just (contentT, body) -> succeedWith $+ responseLBS status200 [ ("Content-Type" , cs contentT)] body+ Left err -> succeedWith $ responseServantErr err | pathIsEmpty request && requestMethod request /= methodDelete = respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound +instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPING #-}+#endif+ HasServer (Delete ctypes ()) where++ type ServerT (Delete ctypes ()) m = m ()++ route Proxy action request respond+ | pathIsEmpty request && requestMethod request == methodDelete = do+ e <- runEitherT action+ respond . succeedWith $ case e of+ Right () -> responseLBS noContent204 [] ""+ Left err -> responseServantErr err+ | pathIsEmpty request && requestMethod request /= methodDelete =+ respond $ failWith WrongMethod+ | otherwise = respond $ failWith NotFound++-- Add response headers+instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPING #-}+#endif+ ( GetHeaders (Headers h v), AllCTRender ctypes v+ ) => HasServer (Delete ctypes (Headers h v)) where++ type ServerT (Delete ctypes (Headers h v)) m = m (Headers h v)++ route Proxy action request respond+ | pathIsEmpty request && requestMethod request == methodDelete = do+ e <- runEitherT action+ respond $ case e of+ Right output -> do+ let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request+ headers = getHeaders output+ case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of+ Nothing -> failWith UnsupportedMediaType+ Just (contentT, body) -> succeedWith $+ responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body+ Left err -> succeedWith $ responseServantErr err+ | pathIsEmpty request && requestMethod request /= methodDelete =+ respond $ failWith WrongMethod+ | otherwise = respond $ failWith NotFound+ -- | When implementing the handler for a 'Get' endpoint, -- just like for 'Servant.API.Delete.Delete', 'Servant.API.Post.Post' -- and 'Servant.API.Put.Put', the handler code runs in the@@ -254,23 +334,79 @@ -- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left' -- to quickly fail if some conditions are not met. ----- If successfully returning a value, we just require that its type has--- a 'ToJSON' instance and servant takes care of encoding it for you,--- yielding status code 200 along the way.-instance ToJSON result => HasServer (Get result) where- type Server (Get result) = EitherT (Int, String) IO result+-- If successfully returning a value, we use the type-level list, combined+-- with the request's @Accept@ header, to encode the value for you+-- (returning a status code of 200). If there was no @Accept@ header or it+-- was @*\/\*@, we return encode using the first @Content-Type@ type on the+-- list.+instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPABLE #-}+#endif+ ( AllCTRender ctypes a ) => HasServer (Get ctypes a) where++ type ServerT (Get ctypes a) m = m a+ route Proxy action request respond | pathIsEmpty request && requestMethod request == methodGet = do e <- runEitherT action+ respond $ case e of+ Right output -> do+ let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request+ case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of+ Nothing -> failWith UnsupportedMediaType+ Just (contentT, body) -> succeedWith $+ responseLBS ok200 [ ("Content-Type" , cs contentT)] body+ Left err -> succeedWith $ responseServantErr err+ | pathIsEmpty request && requestMethod request /= methodGet =+ respond $ failWith WrongMethod+ | otherwise = respond $ failWith NotFound++-- '()' ==> 204 No Content+instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPING #-}+#endif+ HasServer (Get ctypes ()) where++ type ServerT (Get ctypes ()) m = m ()++ route Proxy action request respond+ | pathIsEmpty request && requestMethod request == methodGet = do+ e <- runEitherT action respond . succeedWith $ case e of- Right output ->- responseLBS ok200 [("Content-Type", "application/json")] (encode output)- Left (status, message) ->- responseLBS (mkStatus status (cs message)) [] (cs message)+ Right () -> responseLBS noContent204 [] ""+ Left err -> responseServantErr err | pathIsEmpty request && requestMethod request /= methodGet = respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound +-- Add response headers+instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPING #-}+#endif+ ( GetHeaders (Headers h v), AllCTRender ctypes v+ ) => HasServer (Get ctypes (Headers h v)) where++ type ServerT (Get ctypes (Headers h v)) m = m (Headers h v)++ route Proxy action request respond+ | pathIsEmpty request && requestMethod request == methodGet = do+ e <- runEitherT action+ respond $ case e of+ Right output -> do+ let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request+ headers = getHeaders output+ case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of+ Nothing -> failWith UnsupportedMediaType+ Just (contentT, body) -> succeedWith $+ responseLBS ok200 ( ("Content-Type" , cs contentT) : headers) body+ Left err -> succeedWith $ responseServantErr err+ | pathIsEmpty request && requestMethod request /= methodGet =+ respond $ failWith WrongMethod+ | otherwise = respond $ failWith NotFound+ -- | 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'.@@ -285,7 +421,7 @@ -- > deriving (Eq, Show, FromText, ToText) -- > -- > -- GET /view-my-referer--- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get Referer+-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer -- > -- > server :: Server MyApi -- > server = viewReferer@@ -294,8 +430,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout) => HasServer (Header sym a :> sublayout) where - type Server (Header sym a :> sublayout) =- Maybe a -> Server sublayout+ type ServerT (Header sym a :> sublayout) m =+ Maybe a -> ServerT sublayout m route Proxy subserver request respond = do let mheader = fromText . decodeUtf8 =<< lookup str (requestHeaders request)@@ -311,24 +447,79 @@ -- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left' -- to quickly fail if some conditions are not met. ----- If successfully returning a value, we just require that its type has--- a 'ToJSON' instance and servant takes care of encoding it for you,--- yielding status code 201 along the way.-instance ToJSON a => HasServer (Post a) where- type Server (Post a) = EitherT (Int, String) IO a+-- If successfully returning a value, we use the type-level list, combined+-- with the request's @Accept@ header, to encode the value for you+-- (returning a status code of 201). If there was no @Accept@ header or it+-- was @*\/\*@, we return encode using the first @Content-Type@ type on the+-- list.+instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPABLE #-}+#endif+ ( AllCTRender ctypes a+ ) => HasServer (Post ctypes a) where + type ServerT (Post ctypes a) m = m a+ route Proxy action request respond | pathIsEmpty request && requestMethod request == methodPost = do e <- runEitherT action+ respond $ case e of+ Right output -> do+ let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request+ case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of+ Nothing -> failWith UnsupportedMediaType+ Just (contentT, body) -> succeedWith $+ responseLBS status201 [ ("Content-Type" , cs contentT)] body+ Left err -> succeedWith $ responseServantErr err+ | pathIsEmpty request && requestMethod request /= methodPost =+ respond $ failWith WrongMethod+ | otherwise = respond $ failWith NotFound++instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPING #-}+#endif+ HasServer (Post ctypes ()) where++ type ServerT (Post ctypes ()) m = m ()++ route Proxy action request respond+ | pathIsEmpty request && requestMethod request == methodPost = do+ e <- runEitherT action respond . succeedWith $ case e of- Right out ->- responseLBS status201 [("Content-Type", "application/json")] (encode out)- Left (status, message) ->- responseLBS (mkStatus status (cs message)) [] (cs message)+ Right () -> responseLBS noContent204 [] ""+ Left err -> responseServantErr err | pathIsEmpty request && requestMethod request /= methodPost = respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound +-- Add response headers+instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPING #-}+#endif+ ( GetHeaders (Headers h v), AllCTRender ctypes v+ ) => HasServer (Post ctypes (Headers h v)) where++ type ServerT (Post ctypes (Headers h v)) m = m (Headers h v)++ route Proxy action request respond+ | pathIsEmpty request && requestMethod request == methodPost = do+ e <- runEitherT action+ respond $ case e of+ Right output -> do+ let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request+ headers = getHeaders output+ case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of+ Nothing -> failWith UnsupportedMediaType+ Just (contentT, body) -> succeedWith $+ responseLBS status201 ( ("Content-Type" , cs contentT) : headers) body+ Left err -> succeedWith $ responseServantErr err+ | pathIsEmpty request && requestMethod request /= methodPost =+ respond $ failWith WrongMethod+ | otherwise = respond $ failWith NotFound+ -- | When implementing the handler for a 'Put' endpoint, -- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get' -- and 'Servant.API.Post.Post', the handler code runs in the@@ -337,23 +528,154 @@ -- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left' -- to quickly fail if some conditions are not met. --+-- If successfully returning a value, we use the type-level list, combined+-- with the request's @Accept@ header, to encode the value for you+-- (returning a status code of 200). If there was no @Accept@ header or it+-- was @*\/\*@, we return encode using the first @Content-Type@ type on the+-- list.+instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPABLE #-}+#endif+ ( AllCTRender ctypes a) => HasServer (Put ctypes a) where++ type ServerT (Put ctypes a) m = m a++ route Proxy action request respond+ | pathIsEmpty request && requestMethod request == methodPut = do+ e <- runEitherT action+ respond $ case e of+ Right output -> do+ let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request+ case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of+ Nothing -> failWith UnsupportedMediaType+ Just (contentT, body) -> succeedWith $+ responseLBS status200 [ ("Content-Type" , cs contentT)] body+ Left err -> succeedWith $ responseServantErr err+ | pathIsEmpty request && requestMethod request /= methodPut =+ respond $ failWith WrongMethod+ | otherwise = respond $ failWith NotFound++instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPING #-}+#endif+ HasServer (Put ctypes ()) where++ type ServerT (Put ctypes ()) m = m ()++ route Proxy action request respond+ | pathIsEmpty request && requestMethod request == methodPut = do+ e <- runEitherT action+ respond . succeedWith $ case e of+ Right () -> responseLBS noContent204 [] ""+ Left err -> responseServantErr err+ | pathIsEmpty request && requestMethod request /= methodPut =+ respond $ failWith WrongMethod+ | otherwise = respond $ failWith NotFound++-- Add response headers+instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPING #-}+#endif+ ( GetHeaders (Headers h v), AllCTRender ctypes v+ ) => HasServer (Put ctypes (Headers h v)) where++ type ServerT (Put ctypes (Headers h v)) m = m (Headers h v)++ route Proxy action request respond+ | pathIsEmpty request && requestMethod request == methodPut = do+ e <- runEitherT action+ respond $ case e of+ Right output -> do+ let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request+ headers = getHeaders output+ case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of+ Nothing -> failWith UnsupportedMediaType+ Just (contentT, body) -> succeedWith $+ responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body+ Left err -> succeedWith $ responseServantErr err+ | pathIsEmpty request && requestMethod request /= methodPut =+ respond $ failWith WrongMethod+ | otherwise = respond $ failWith NotFound++-- | When implementing the handler for a 'Patch' endpoint,+-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'+-- and 'Servant.API.Put.Put', the handler code runs in the+-- @EitherT (Int, String) IO@ monad, where the 'Int' represents+-- the status code and the 'String' a message, returned in case of+-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'+-- to quickly fail if some conditions are not met.+-- -- If successfully returning a value, we just require that its type has -- a 'ToJSON' instance and servant takes care of encoding it for you, -- yielding status code 200 along the way.-instance ToJSON a => HasServer (Put a) where- type Server (Put a) = EitherT (Int, String) IO a+instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPABLE #-}+#endif+ ( AllCTRender ctypes a) => HasServer (Patch ctypes a) where + type ServerT (Patch ctypes a) m = m a+ route Proxy action request respond- | pathIsEmpty request && requestMethod request == methodPut = do+ | pathIsEmpty request && requestMethod request == methodPatch = do e <- runEitherT action+ respond $ case e of+ Right output -> do+ let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request+ case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of+ Nothing -> failWith UnsupportedMediaType+ Just (contentT, body) -> succeedWith $+ responseLBS status200 [ ("Content-Type" , cs contentT)] body+ Left err -> succeedWith $ responseServantErr err+ | pathIsEmpty request && requestMethod request /= methodPatch =+ respond $ failWith WrongMethod+ | otherwise = respond $ failWith NotFound++instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPING #-}+#endif+ HasServer (Patch ctypes ()) where++ type ServerT (Patch ctypes ()) m = m ()++ route Proxy action request respond+ | pathIsEmpty request && requestMethod request == methodPatch = do+ e <- runEitherT action respond . succeedWith $ case e of- Right out ->- responseLBS ok200 [("Content-Type", "application/json")] (encode out)- Left (status, message) ->- responseLBS (mkStatus status (cs message)) [] (cs message)- | pathIsEmpty request && requestMethod request /= methodPut =+ Right () -> responseLBS noContent204 [] ""+ Left err -> responseServantErr err+ | pathIsEmpty request && requestMethod request /= methodPatch = respond $ failWith WrongMethod+ | otherwise = respond $ failWith NotFound +-- Add response headers+instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPING #-}+#endif+ ( GetHeaders (Headers h v), AllCTRender ctypes v+ ) => HasServer (Patch ctypes (Headers h v)) where++ type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v)++ route Proxy action request respond+ | pathIsEmpty request && requestMethod request == methodPatch = do+ e <- runEitherT action+ respond $ case e of+ Right outpatch -> do+ let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request+ headers = getHeaders outpatch+ case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse outpatch) of+ Nothing -> failWith UnsupportedMediaType+ Just (contentT, body) -> succeedWith $+ responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body+ Left err -> succeedWith $ responseServantErr err+ | pathIsEmpty request && requestMethod request /= methodPatch =+ respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound -- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,@@ -370,7 +692,7 @@ -- -- Example: ----- > type MyApi = "books" :> QueryParam "author" Text :> Get [Book]+-- > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book] -- > -- > server :: Server MyApi -- > server = getBooksBy@@ -380,8 +702,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout) => HasServer (QueryParam sym a :> sublayout) where - type Server (QueryParam sym a :> sublayout) =- Maybe a -> Server sublayout+ type ServerT (QueryParam sym a :> sublayout) m =+ Maybe a -> ServerT sublayout m route Proxy subserver request respond = do let querytext = parseQueryText $ rawQueryString request@@ -409,7 +731,7 @@ -- -- Example: ----- > type MyApi = "books" :> QueryParams "authors" Text :> Get [Book]+-- > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book] -- > -- > server :: Server MyApi -- > server = getBooksBy@@ -418,8 +740,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout) => HasServer (QueryParams sym a :> sublayout) where - type Server (QueryParams sym a :> sublayout) =- [a] -> Server sublayout+ type ServerT (QueryParams sym a :> sublayout) m =+ [a] -> ServerT sublayout m route Proxy subserver request respond = do let querytext = parseQueryText $ rawQueryString request@@ -442,7 +764,7 @@ -- -- Example: ----- > type MyApi = "books" :> QueryFlag "published" :> Get [Book]+-- > type MyApi = "books" :> QueryFlag "published" :> Get '[JSON] [Book] -- > -- > server :: Server MyApi -- > server = getBooks@@ -451,8 +773,8 @@ instance (KnownSymbol sym, HasServer sublayout) => HasServer (QueryFlag sym :> sublayout) where - type Server (QueryFlag sym :> sublayout) =- Bool -> Server sublayout+ type ServerT (QueryFlag sym :> sublayout) m =+ Bool -> ServerT sublayout m route Proxy subserver request respond = do let querytext = parseQueryText $ rawQueryString request@@ -494,8 +816,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout) => HasServer (MatrixParam sym a :> sublayout) where - type Server (MatrixParam sym a :> sublayout) =- Maybe a -> Server sublayout+ type ServerT (MatrixParam sym a :> sublayout) m =+ Maybe a -> ServerT sublayout m route Proxy subserver request respond = case parsePathInfo request of (first : _)@@ -532,8 +854,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout) => HasServer (MatrixParams sym a :> sublayout) where - type Server (MatrixParams sym a :> sublayout) =- [a] -> Server sublayout+ type ServerT (MatrixParams sym a :> sublayout) m =+ [a] -> ServerT sublayout m route Proxy subserver request respond = case parsePathInfo request of (first : _)@@ -566,8 +888,8 @@ instance (KnownSymbol sym, HasServer sublayout) => HasServer (MatrixFlag sym :> sublayout) where - type Server (MatrixFlag sym :> sublayout) =- Bool -> Server sublayout+ type ServerT (MatrixFlag sym :> sublayout) m =+ Bool -> ServerT sublayout m route Proxy subserver request respond = case parsePathInfo request of (first : _)@@ -594,42 +916,58 @@ -- > server :: Server MyApi -- > server = serveDirectory "/var/www/images" instance HasServer Raw where- type Server Raw = Application++ type ServerT Raw m = Application+ route Proxy rawApplication request respond = rawApplication request (respond . succeedWith) -- | 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@. -- 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 Book :> Post Book+-- > type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- > -- > server :: Server MyApi -- > server = postBook -- > where postBook :: Book -> EitherT (Int, String) IO Book -- > postBook book = ...insert into your db...-instance (FromJSON a, HasServer sublayout)- => HasServer (ReqBody a :> sublayout) where+instance ( AllCTUnrender list a, HasServer sublayout+ ) => HasServer (ReqBody list a :> sublayout) where - type Server (ReqBody a :> sublayout) =- a -> Server sublayout+ type ServerT (ReqBody list a :> sublayout) m =+ a -> ServerT sublayout m route Proxy subserver request respond = do- mrqbody <- eitherDecode' <$> lazyRequestBody request+ -- 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 = fromMaybe "application/octet-stream"+ $ lookup hContentType $ requestHeaders request+ mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)+ <$> lazyRequestBody request case mrqbody of- Left e -> respond . failWith $ InvalidBody e- Right v -> route (Proxy :: Proxy sublayout) (subserver v) request respond+ Nothing -> respond . failWith $ UnsupportedMediaType+ Just (Left e) -> respond . failWith $ InvalidBody e+ Just (Right v) -> route (Proxy :: Proxy sublayout) (subserver v) request respond -- | Make sure the incoming request starts with @"/path"@, strip it and -- pass the rest of the request path to @sublayout@. instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where- type Server (path :> sublayout) = Server sublayout++ type ServerT (path :> sublayout) m = ServerT sublayout m+ route Proxy subserver request respond = case processedPathInfo request of (first : rest) | first == cs (symbolVal proxyPath)@@ -639,3 +977,6 @@ _ -> respond $ failWith NotFound where proxyPath = Proxy :: Proxy path++ct_wildcard :: B.ByteString+ct_wildcard = "*" <> "/" <> "*" -- Because CPP
+ src/Servant/Server/Internal/Enter.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+module Servant.Server.Internal.Enter where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif+import qualified Control.Category as C+#if MIN_VERSION_mtl(2,2,1)+import Control.Monad.Except+#endif+import Control.Monad.Identity+import Control.Monad.Morph+import Control.Monad.Reader+import qualified Control.Monad.State.Lazy as LState+import qualified Control.Monad.State.Strict as SState+#if MIN_VERSION_mtl(2,2,1)+import Control.Monad.Trans.Either+#endif+import qualified Control.Monad.Writer.Lazy as LWriter+import qualified Control.Monad.Writer.Strict as SWriter+import Data.Typeable+import Servant.API++class Enter typ arg ret | typ arg -> ret, typ ret -> arg where+ enter :: arg -> typ -> ret++-- ** Servant combinators+instance ( Enter typ1 arg1 ret1, Enter typ2 arg2 ret2+ , arg1 ~ arg2+ ) => Enter (typ1 :<|> typ2) arg1 (ret1 :<|> ret2) where+ enter e (a :<|> b) = enter e a :<|> enter e b++instance (Enter b arg ret) => Enter (a -> b) arg (a -> ret) where+ enter arg f a = enter arg (f a)++-- ** Useful instances++-- | A natural transformation from @m@ to @n@. Used to `enter` particular+-- datatypes.+newtype m :~> n = Nat { unNat :: forall a. m a -> n a} deriving Typeable++instance C.Category (:~>) where+ id = Nat id+ Nat f . Nat g = Nat (f . g)++instance Enter (m a) (m :~> n) (n a) where+ enter (Nat f) = f++-- | Like `lift`.+liftNat :: (Control.Monad.Morph.MonadTrans t, Monad m) => m :~> t m+liftNat = Nat Control.Monad.Morph.lift++runReaderTNat :: r -> (ReaderT r m :~> m)+runReaderTNat a = Nat (`runReaderT` a)++evalStateTLNat :: Monad m => s -> (LState.StateT s m :~> m)+evalStateTLNat a = Nat (`LState.evalStateT` a)++evalStateTSNat :: Monad m => s -> (SState.StateT s m :~> m)+evalStateTSNat a = Nat (`SState.evalStateT` a)++-- | Log the contents of `SWriter.WriterT` with the function provided as the+-- first argument, and return the value of the @WriterT@ computation+logWriterTSNat :: MonadIO m => (w -> IO ()) -> (SWriter.WriterT w m :~> m)+logWriterTSNat logger = Nat $ \x -> do+ (a, w) <- SWriter.runWriterT x+ liftIO $ logger w+ return a++-- | Like `logWriterTSNat`, but for strict @WriterT@.+logWriterTLNat :: MonadIO m => (w -> IO ()) -> (LWriter.WriterT w m :~> m)+logWriterTLNat logger = Nat $ \x -> do+ (a, w) <- LWriter.runWriterT x+ liftIO $ logger w+ return a++#if MIN_VERSION_mtl(2,2,1)+fromExceptT :: ExceptT e m :~> EitherT e m+fromExceptT = Nat $ \x -> EitherT $ runExceptT x+#endif++-- | Like @mmorph@'s `hoist`.+hoistNat :: (MFunctor t, Monad m) => (m :~> n) -> (t m :~> t n)+hoistNat (Nat n) = Nat $ hoist n++-- | Like @mmorph@'s `embed`.+embedNat :: (MMonad t, Monad n) => (m :~> t n) -> (t m :~> t n)+embedNat (Nat n) = Nat $ embed n++-- | Like @mmorph@'s `squash`.+squashNat :: (Monad m, MMonad t) => t (t m) :~> t m+squashNat = Nat squash++-- | Like @mmorph@'s `generalize`.+generalizeNat :: Applicative m => Identity :~> m+generalizeNat = Nat (pure . runIdentity)
+ src/Servant/Server/Internal/ServantErr.hs view
@@ -0,0 +1,229 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+module Servant.Server.Internal.ServantErr where++import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Network.HTTP.Types as HTTP+import Network.Wai (responseLBS, Response)++data ServantErr = ServantErr { errHTTPCode :: Int+ , errReasonPhrase :: String+ , errBody :: LBS.ByteString+ , errHeaders :: [HTTP.Header]+ } deriving (Show, Eq)++responseServantErr :: ServantErr -> Response+responseServantErr ServantErr{..} = responseLBS status errHeaders errBody+ where+ status = HTTP.mkStatus errHTTPCode (BS.pack errReasonPhrase)++err300 :: ServantErr+err300 = ServantErr { errHTTPCode = 300+ , errReasonPhrase = "Multiple Choices"+ , errBody = ""+ , errHeaders = []+ }++err301 :: ServantErr+err301 = ServantErr { errHTTPCode = 301+ , errReasonPhrase = "Moved Permanently"+ , errBody = ""+ , errHeaders = []+ }++err302 :: ServantErr+err302 = ServantErr { errHTTPCode = 302+ , errReasonPhrase = "Found"+ , errBody = ""+ , errHeaders = []+ }++err303 :: ServantErr+err303 = ServantErr { errHTTPCode = 303+ , errReasonPhrase = "See Other"+ , errBody = ""+ , errHeaders = []+ }++err304 :: ServantErr+err304 = ServantErr { errHTTPCode = 304+ , errReasonPhrase = "Not Modified"+ , errBody = ""+ , errHeaders = []+ }++err305 :: ServantErr+err305 = ServantErr { errHTTPCode = 305+ , errReasonPhrase = "Use Proxy"+ , errBody = ""+ , errHeaders = []+ }++err307 :: ServantErr+err307 = ServantErr { errHTTPCode = 307+ , errReasonPhrase = "Temporary Redirect"+ , errBody = ""+ , errHeaders = []+ }++err400 :: ServantErr+err400 = ServantErr { errHTTPCode = 400+ , errReasonPhrase = "Bad Request"+ , errBody = ""+ , errHeaders = []+ }++err401 :: ServantErr+err401 = ServantErr { errHTTPCode = 401+ , errReasonPhrase = "Unauthorized"+ , errBody = ""+ , errHeaders = []+ }++err402 :: ServantErr+err402 = ServantErr { errHTTPCode = 402+ , errReasonPhrase = "Payment Required"+ , errBody = ""+ , errHeaders = []+ }++err403 :: ServantErr+err403 = ServantErr { errHTTPCode = 403+ , errReasonPhrase = "Forbidden"+ , errBody = ""+ , errHeaders = []+ }++err404 :: ServantErr+err404 = ServantErr { errHTTPCode = 404+ , errReasonPhrase = "Not Found"+ , errBody = ""+ , errHeaders = []+ }++err405 :: ServantErr+err405 = ServantErr { errHTTPCode = 405+ , errReasonPhrase = "Method Not Allowed"+ , errBody = ""+ , errHeaders = []+ }++err406 :: ServantErr+err406 = ServantErr { errHTTPCode = 406+ , errReasonPhrase = "Not Acceptable"+ , errBody = ""+ , errHeaders = []+ }++err407 :: ServantErr+err407 = ServantErr { errHTTPCode = 407+ , errReasonPhrase = "Proxy Authentication Required"+ , errBody = ""+ , errHeaders = []+ }++err409 :: ServantErr+err409 = ServantErr { errHTTPCode = 409+ , errReasonPhrase = "Conflict"+ , errBody = ""+ , errHeaders = []+ }++err410 :: ServantErr+err410 = ServantErr { errHTTPCode = 410+ , errReasonPhrase = "Gone"+ , errBody = ""+ , errHeaders = []+ }++err411 :: ServantErr+err411 = ServantErr { errHTTPCode = 411+ , errReasonPhrase = "Length Required"+ , errBody = ""+ , errHeaders = []+ }++err412 :: ServantErr+err412 = ServantErr { errHTTPCode = 412+ , errReasonPhrase = "Precondition Failed"+ , errBody = ""+ , errHeaders = []+ }++err413 :: ServantErr+err413 = ServantErr { errHTTPCode = 413+ , errReasonPhrase = "Request Entity Too Large"+ , errBody = ""+ , errHeaders = []+ }++err414 :: ServantErr+err414 = ServantErr { errHTTPCode = 414+ , errReasonPhrase = "Request-URI Too Large"+ , errBody = ""+ , errHeaders = []+ }++err415 :: ServantErr+err415 = ServantErr { errHTTPCode = 415+ , errReasonPhrase = "Unsupported Media Type"+ , errBody = ""+ , errHeaders = []+ }++err416 :: ServantErr+err416 = ServantErr { errHTTPCode = 416+ , errReasonPhrase = "Request range not satisfiable"+ , errBody = ""+ , errHeaders = []+ }++err417 :: ServantErr+err417 = ServantErr { errHTTPCode = 417+ , errReasonPhrase = "Expectation Failed"+ , errBody = ""+ , errHeaders = []+ }++err500 :: ServantErr+err500 = ServantErr { errHTTPCode = 500+ , errReasonPhrase = "Internal Server Error"+ , errBody = ""+ , errHeaders = []+ }++err501 :: ServantErr+err501 = ServantErr { errHTTPCode = 501+ , errReasonPhrase = "Not Implemented"+ , errBody = ""+ , errHeaders = []+ }++err502 :: ServantErr+err502 = ServantErr { errHTTPCode = 502+ , errReasonPhrase = "Bad Gateway"+ , errBody = ""+ , errHeaders = []+ }++err503 :: ServantErr+err503 = ServantErr { errHTTPCode = 503+ , errReasonPhrase = "Service Unavailable"+ , errBody = ""+ , errHeaders = []+ }++err504 :: ServantErr+err504 = ServantErr { errHTTPCode = 504+ , errReasonPhrase = "Gateway Time-out"+ , errBody = ""+ , errHeaders = []+ }++err505 :: ServantErr+err505 = ServantErr { errHTTPCode = 505+ , errReasonPhrase = "HTTP Version not supported"+ , errBody = ""+ , errHeaders = []+ }
src/Servant/Utils/StaticFiles.hs view
@@ -9,7 +9,7 @@ import Filesystem.Path.CurrentOS (decodeString) import Network.Wai.Application.Static (staticApp, defaultFileServerSettings) import Servant.API.Raw (Raw)-import Servant.Server.Internal (Server)+import Servant.Server (Server) -- | Serve anything under the specified directory as a 'Raw' endpoint. --
+ test/Doctests.hs view
@@ -0,0 +1,18 @@+module Main where++import System.FilePath.Find+import Test.DocTest++main :: IO ()+main = do+ files <- find always (extension ==? ".hs") "src"+ doctest $ [ "-isrc"+ , "-optP-include"+ , "-optPdist/build/autogen/cabal_macros.h"+ , "-XOverloadedStrings"+ , "-XFlexibleInstances"+ , "-XMultiParamTypeClasses"+ , "-XDataKinds"+ , "-XTypeOperators"+ ] ++ files+