diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 ----- diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,7 +1,5 @@ # servant-server -[![Build Status](https://secure.travis-ci.org/haskell-servant/servant-server.svg)](http://travis-ci.org/haskell-servant/servant-server) - ![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png) 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) diff --git a/example/greet.hs b/example/greet.hs --- a/example/greet.hs +++ b/example/greet.hs @@ -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 diff --git a/servant-server.cabal b/servant-server.cabal --- a/servant-server.cabal +++ b/servant-server.cabal @@ -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 guide. + You can learn about the basics in + guide. . - 's a runnable example, with comments, that defines a dummy API and - implements a webserver that serves this API, using this package. + + is a runnable example, with comments, that defines a dummy API and implements + a webserver that serves this API, using this package. + . + 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 diff --git a/src/Servant.hs b/src/Servant.hs --- a/src/Servant.hs +++ b/src/Servant.hs @@ -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 diff --git a/src/Servant/Server.hs b/src/Servant/Server.hs --- a/src/Servant/Server.hs +++ b/src/Servant/Server.hs @@ -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 + , 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 diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -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 diff --git a/src/Servant/Server/Internal/Enter.hs b/src/Servant/Server/Internal/Enter.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Server/Internal/Enter.hs @@ -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) diff --git a/src/Servant/Server/Internal/ServantErr.hs b/src/Servant/Server/Internal/ServantErr.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Server/Internal/ServantErr.hs @@ -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 = [] + } diff --git a/src/Servant/Utils/StaticFiles.hs b/src/Servant/Utils/StaticFiles.hs --- a/src/Servant/Utils/StaticFiles.hs +++ b/src/Servant/Utils/StaticFiles.hs @@ -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. -- diff --git a/test/Doctests.hs b/test/Doctests.hs new file mode 100644 --- /dev/null +++ b/test/Doctests.hs @@ -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 +