diff --git a/.gitignore b/.gitignore index 7d7195eb..3007a0c1 100644 --- a/.gitignore +++ b/.gitignore @@ -21,3 +21,4 @@ cabal.config *.prof *.aux *.hp +Setup diff --git a/scripts/shell.nix b/scripts/shell.nix index 5d77034a..61dda6c8 100644 --- a/scripts/shell.nix +++ b/scripts/shell.nix @@ -13,10 +13,8 @@ let modifiedHaskellPackages = haskellngPackages.override { ../servant-jquery {}) "--ghc-options=-Werror"; servant-docs = appendConfigureFlag (self.callPackage ../servant-docs {}) "--ghc-options=-Werror"; - servant-examples = appendConfigureFlag (self.callPackage ../servant-examples - {}) "--ghc-options=-Werror"; }; }; in modifiedHaskellPackages.ghcWithPackages ( p : with p ; [ - servant servant-server servant-client servant-jquery servant-docs servant-examples + servant servant-server servant-client servant-jquery servant-docs ]) diff --git a/scripts/start-sandbox.sh b/scripts/start-sandbox.sh new file mode 100755 index 00000000..7d042bd2 --- /dev/null +++ b/scripts/start-sandbox.sh @@ -0,0 +1,30 @@ +#!/bin/bash - +#=============================================================================== +# +# FILE: start-sandbox.sh +# +# USAGE: ./start-sandbox.sh +# +# DESCRIPTION: Create sandbox at top-level and add all packages as add-source +# +# REQUIREMENTS: bash >= 4 +#=============================================================================== + +set -o nounset +set -o errexit + +DIR=$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd ) +SOURCES_TXT="$( dirname $DIR)/sources.txt" +CABAL=${CABAL:-cabal} + +declare -a SOURCES +readarray -t SOURCES < "$SOURCES_TXT" + +prepare_sandbox () { + $CABAL sandbox init + for s in ${SOURCES[@]} ; do + (cd "$s" && $CABAL sandbox init --sandbox=../.cabal-sandbox && $CABAL sandbox add-source .) + done +} + +prepare_sandbox diff --git a/servant-blaze/LICENSE b/servant-blaze/LICENSE new file mode 100644 index 00000000..0b0a2174 --- /dev/null +++ b/servant-blaze/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015, Julian K. Arni + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Julian K. Arni nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/servant-blaze/Setup.hs b/servant-blaze/Setup.hs new file mode 100644 index 00000000..9a994af6 --- /dev/null +++ b/servant-blaze/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/servant-blaze/servant-blaze.cabal b/servant-blaze/servant-blaze.cabal new file mode 100644 index 00000000..0f42502e --- /dev/null +++ b/servant-blaze/servant-blaze.cabal @@ -0,0 +1,28 @@ +-- Initial servant-blaze.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: servant-blaze +version: 0.1.0.0 +synopsis: Blaze-html support for servant +-- description: +homepage: http://haskell-servant.github.io/ +license: BSD3 +license-file: LICENSE +author: Julian K. Arni +maintainer: jkarni@gmail.com +-- copyright: +category: Web +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + exposed-modules: Servant.HTML.Blaze + -- other-modules: + -- other-extensions: + build-depends: base >=4.7 && <5 + , servant + , http-media + , blaze-html + hs-source-dirs: src + default-language: Haskell2010 diff --git a/servant-blaze/src/Servant/HTML/Blaze.hs b/servant-blaze/src/Servant/HTML/Blaze.hs new file mode 100644 index 00000000..d13af84c --- /dev/null +++ b/servant-blaze/src/Servant/HTML/Blaze.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +#if !MIN_VERSION_base(4,8,0) +{-# LANGUAGE OverlappingInstances #-} +#endif + +-- | An @HTML@ empty data type with `MimeRender` instances for @blaze-html@'s +-- `ToMarkup` class and `Html` datatype. +-- You should only need to import this module for it's instances and the +-- `HTML` datatype.: +-- +-- >>> type Eg = Get '[HTML] a +-- +-- Will then check that @a@ has a `ToMarkup` instance, or is `Html`. +module Servant.HTML.Blaze where + +import Data.Typeable (Typeable) +import qualified Network.HTTP.Media as M +import Servant.API (Accept (..), MimeRender (..)) +import Text.Blaze.Html (Html, ToMarkup, toHtml) +import Text.Blaze.Html.Renderer.Utf8 (renderHtml) + +data HTML deriving Typeable + +-- | @text/plain;charset=utf-8@ +instance Accept HTML where + contentType _ = "text" M.// "html" M./: ("charset", "utf-8") + +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPABLE #-} +#endif + ToMarkup a => MimeRender HTML a where + mimeRender _ = renderHtml . toHtml + +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPING #-} +#endif + MimeRender HTML Html where + mimeRender _ = renderHtml + diff --git a/servant-client/CHANGELOG.md b/servant-client/CHANGELOG.md index 9e7f1090..814e20f9 100644 --- a/servant-client/CHANGELOG.md +++ b/servant-client/CHANGELOG.md @@ -7,7 +7,7 @@ * Make the clients for `Raw` endpoints return the whole `Response` value (to be able to access response headers for example) * Support for PATCH * Make () instances expect No Content status code, and not try to decode body. -* `Canonicalize` API types before generating client functions for them +* Add support for response headers 0.2.2 ----- diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index 8a187b0a..67b6c8de 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -16,11 +16,13 @@ module Servant.Client ( client , HasClient(..) - , Client , ServantError(..) , module Servant.Common.BaseUrl ) where +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif import Control.Monad import Control.Monad.Trans.Either import Data.ByteString.Lazy (ByteString) @@ -32,8 +34,8 @@ import GHC.TypeLits import Network.HTTP.Client (Response) import Network.HTTP.Media import qualified Network.HTTP.Types as H +import qualified Network.HTTP.Types.Header as HTTP import Servant.API -import Servant.API.ContentTypes import Servant.Common.BaseUrl import Servant.Common.Req @@ -50,17 +52,16 @@ import Servant.Common.Req -- > getAllBooks :: BaseUrl -> EitherT String IO [Book] -- > postNewBook :: Book -> BaseUrl -> EitherT String IO Book -- > (getAllBooks :<|> postNewBook) = client myApi -client :: HasClient (Canonicalize layout) => Proxy layout -> Client layout -client p = clientWithRoute (canonicalize p) defReq +client :: HasClient layout => Proxy layout -> Client layout +client p = clientWithRoute p defReq -- | This class lets us define how each API combinator -- influences the creation of an HTTP request. It's mostly -- an internal class, you can just use 'client'. class HasClient layout where - type Client' layout :: * - clientWithRoute :: Proxy layout -> Req -> Client' layout + type Client layout :: * + clientWithRoute :: Proxy layout -> Req -> Client layout -type Client layout = Client' (Canonicalize layout) -- | A client querying function for @a ':<|>' b@ will actually hand you -- one function for querying @a@ and another one for querying @b@, @@ -76,7 +77,7 @@ type Client layout = Client' (Canonicalize layout) -- > postNewBook :: Book -> BaseUrl -> EitherT String IO Book -- > (getAllBooks :<|> postNewBook) = client myApi instance (HasClient a, HasClient b) => HasClient (a :<|> b) where - type Client' (a :<|> b) = Client' a :<|> Client' b + type Client (a :<|> b) = Client a :<|> Client b clientWithRoute Proxy req = clientWithRoute (Proxy :: Proxy a) req :<|> clientWithRoute (Proxy :: Proxy b) req @@ -103,8 +104,8 @@ instance (HasClient a, HasClient b) => HasClient (a :<|> b) where instance (KnownSymbol capture, ToText a, HasClient sublayout) => HasClient (Capture capture a :> sublayout) where - type Client' (Capture capture a :> sublayout) = - a -> Client' sublayout + type Client (Capture capture a :> sublayout) = + a -> Client sublayout clientWithRoute Proxy req val = clientWithRoute (Proxy :: Proxy sublayout) $ @@ -117,7 +118,7 @@ instance (KnownSymbol capture, ToText a, HasClient sublayout) -- will just require an argument that specifies the scheme, host -- and port to send the request to. instance HasClient Delete where - type Client' Delete = BaseUrl -> EitherT ServantError IO () + type Client Delete = BaseUrl -> EitherT ServantError IO () clientWithRoute Proxy req host = void $ performRequest H.methodDelete req (`elem` [200, 202, 204]) host @@ -131,21 +132,36 @@ instance {-# OVERLAPPABLE #-} #endif (MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where - type Client' (Get (ct ': cts) result) = BaseUrl -> EitherT ServantError IO result + type Client (Get (ct ': cts) result) = BaseUrl -> EitherT ServantError IO result clientWithRoute Proxy req host = - performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203] host + snd <$> performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203] host -- | If you have a 'Get xs ()' endpoint, the client expects a 204 No Content --- HTTP header. +-- HTTP status. instance #if MIN_VERSION_base(4,8,0) {-# OVERLAPPING #-} #endif HasClient (Get (ct ': cts) ()) where - type Client' (Get (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO () + type Client (Get (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO () clientWithRoute Proxy req host = performRequestNoBody H.methodGet req [204] host +-- | If you have a 'Get xs (Headers ls x)' endpoint, the client expects the +-- corresponding headers. +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPING #-} +#endif + ( MimeUnrender ct a, BuildHeadersTo ls + ) => HasClient (Get (ct ': cts) (Headers ls a)) where + type Client (Get (ct ': cts) (Headers ls a)) = BaseUrl -> EitherT ServantError IO (Headers ls a) + clientWithRoute Proxy req host = do + (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203, 204] host + return $ Headers { getResponse = resp + , getHeadersHList = buildHeadersTo hdrs + } + -- | If you use a 'Header' in one of your endpoints in your API, -- the corresponding querying function will automatically take -- an additional argument of the type specified by your 'Header', @@ -174,8 +190,8 @@ instance instance (KnownSymbol sym, ToText a, HasClient sublayout) => HasClient (Header sym a :> sublayout) where - type Client' (Header sym a :> sublayout) = - Maybe a -> Client' sublayout + type Client (Header sym a :> sublayout) = + Maybe a -> Client sublayout clientWithRoute Proxy req mval = clientWithRoute (Proxy :: Proxy sublayout) $ @@ -192,10 +208,10 @@ instance {-# OVERLAPPABLE #-} #endif (MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where - type Client' (Post (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a + type Client (Post (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a clientWithRoute Proxy req uri = - performRequestCT (Proxy :: Proxy ct) H.methodPost req [200,201] uri + snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPost req [200,201] uri -- | If you have a 'Post xs ()' endpoint, the client expects a 204 No Content -- HTTP header. @@ -204,10 +220,25 @@ instance {-# OVERLAPPING #-} #endif HasClient (Post (ct ': cts) ()) where - type Client' (Post (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO () + type Client (Post (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO () clientWithRoute Proxy req host = void $ performRequestNoBody H.methodPost req [204] host +-- | If you have a 'Post xs (Headers ls x)' endpoint, the client expects the +-- corresponding headers. +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPING #-} +#endif + ( MimeUnrender ct a, BuildHeadersTo ls + ) => HasClient (Post (ct ': cts) (Headers ls a)) where + type Client (Post (ct ': cts) (Headers ls a)) = BaseUrl -> EitherT ServantError IO (Headers ls a) + clientWithRoute Proxy req host = do + (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPost req [200, 201] host + return $ Headers { getResponse = resp + , getHeadersHList = buildHeadersTo hdrs + } + -- | If you have a 'Put' endpoint in your API, the client -- side querying function that is created when calling 'client' -- will just require an argument that specifies the scheme, host @@ -217,10 +248,10 @@ instance {-# OVERLAPPABLE #-} #endif (MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where - type Client' (Put (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a + type Client (Put (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a clientWithRoute Proxy req host = - performRequestCT (Proxy :: Proxy ct) H.methodPut req [200,201] host + snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPut req [200,201] host -- | If you have a 'Put xs ()' endpoint, the client expects a 204 No Content -- HTTP header. @@ -229,10 +260,25 @@ instance {-# OVERLAPPING #-} #endif HasClient (Put (ct ': cts) ()) where - type Client' (Put (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO () + type Client (Put (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO () clientWithRoute Proxy req host = void $ performRequestNoBody H.methodPut req [204] host +-- | If you have a 'Put xs (Headers ls x)' endpoint, the client expects the +-- corresponding headers. +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPING #-} +#endif + ( MimeUnrender ct a, BuildHeadersTo ls + ) => HasClient (Put (ct ': cts) (Headers ls a)) where + type Client (Put (ct ': cts) (Headers ls a)) = BaseUrl -> EitherT ServantError IO (Headers ls a) + clientWithRoute Proxy req host = do + (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPut req [200, 201] host + return $ Headers { getResponse = resp + , getHeadersHList = buildHeadersTo hdrs + } + -- | If you have a 'Patch' endpoint in your API, the client -- side querying function that is created when calling 'client' -- will just require an argument that specifies the scheme, host @@ -242,10 +288,10 @@ instance {-# OVERLAPPABLE #-} #endif (MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where - type Client' (Patch (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a + type Client (Patch (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a clientWithRoute Proxy req host = - performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200,201] host + snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200,201] host -- | If you have a 'Patch xs ()' endpoint, the client expects a 204 No Content -- HTTP header. @@ -254,10 +300,25 @@ instance {-# OVERLAPPING #-} #endif HasClient (Patch (ct ': cts) ()) where - type Client' (Patch (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO () + type Client (Patch (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO () clientWithRoute Proxy req host = void $ performRequestNoBody H.methodPatch req [204] host +-- | If you have a 'Patch xs (Headers ls x)' endpoint, the client expects the +-- corresponding headers. +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPING #-} +#endif + ( MimeUnrender ct a, BuildHeadersTo ls + ) => HasClient (Patch (ct ': cts) (Headers ls a)) where + type Client (Patch (ct ': cts) (Headers ls a)) = BaseUrl -> EitherT ServantError IO (Headers ls a) + clientWithRoute Proxy req host = do + (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200, 201, 204] host + return $ Headers { getResponse = resp + , getHeadersHList = buildHeadersTo hdrs + } + -- | If you use a 'QueryParam' in one of your endpoints in your API, -- the corresponding querying function will automatically take -- an additional argument of the type specified by your 'QueryParam', @@ -286,8 +347,8 @@ instance instance (KnownSymbol sym, ToText a, HasClient sublayout) => HasClient (QueryParam sym a :> sublayout) where - type Client' (QueryParam sym a :> sublayout) = - Maybe a -> Client' sublayout + type Client (QueryParam sym a :> sublayout) = + Maybe a -> Client sublayout -- if mparam = Nothing, we don't add it to the query string clientWithRoute Proxy req mparam = @@ -328,8 +389,8 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout) instance (KnownSymbol sym, ToText a, HasClient sublayout) => HasClient (QueryParams sym a :> sublayout) where - type Client' (QueryParams sym a :> sublayout) = - [a] -> Client' sublayout + type Client (QueryParams sym a :> sublayout) = + [a] -> Client sublayout clientWithRoute Proxy req paramlist = clientWithRoute (Proxy :: Proxy sublayout) $ @@ -363,8 +424,8 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout) instance (KnownSymbol sym, HasClient sublayout) => HasClient (QueryFlag sym :> sublayout) where - type Client' (QueryFlag sym :> sublayout) = - Bool -> Client' sublayout + type Client (QueryFlag sym :> sublayout) = + Bool -> Client sublayout clientWithRoute Proxy req flag = clientWithRoute (Proxy :: Proxy sublayout) $ @@ -402,8 +463,8 @@ instance (KnownSymbol sym, HasClient sublayout) instance (KnownSymbol sym, ToText a, HasClient sublayout) => HasClient (MatrixParam sym a :> sublayout) where - type Client' (MatrixParam sym a :> sublayout) = - Maybe a -> Client' sublayout + type Client (MatrixParam sym a :> sublayout) = + Maybe a -> Client sublayout -- if mparam = Nothing, we don't add it to the query string clientWithRoute Proxy req mparam = @@ -443,8 +504,8 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout) instance (KnownSymbol sym, ToText a, HasClient sublayout) => HasClient (MatrixParams sym a :> sublayout) where - type Client' (MatrixParams sym a :> sublayout) = - [a] -> Client' sublayout + type Client (MatrixParams sym a :> sublayout) = + [a] -> Client sublayout clientWithRoute Proxy req paramlist = clientWithRoute (Proxy :: Proxy sublayout) $ @@ -478,8 +539,8 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout) instance (KnownSymbol sym, HasClient sublayout) => HasClient (MatrixFlag sym :> sublayout) where - type Client' (MatrixFlag sym :> sublayout) = - Bool -> Client' sublayout + type Client (MatrixFlag sym :> sublayout) = + Bool -> Client sublayout clientWithRoute Proxy req flag = clientWithRoute (Proxy :: Proxy sublayout) $ @@ -492,9 +553,9 @@ instance (KnownSymbol sym, HasClient sublayout) -- | Pick a 'Method' and specify where the server you want to query is. You get -- back the full `Response`. instance HasClient Raw where - type Client' Raw = H.Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, Response ByteString) + type Client Raw = H.Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], Response ByteString) - clientWithRoute :: Proxy Raw -> Req -> Client' Raw + clientWithRoute :: Proxy Raw -> Req -> Client Raw clientWithRoute Proxy req httpMethod host = do performRequest httpMethod req (const True) host @@ -519,8 +580,8 @@ instance HasClient Raw where instance (MimeRender ct a, HasClient sublayout) => HasClient (ReqBody (ct ': cts) a :> sublayout) where - type Client' (ReqBody (ct ': cts) a :> sublayout) = - a -> Client' sublayout + type Client (ReqBody (ct ': cts) a :> sublayout) = + a -> Client sublayout clientWithRoute Proxy req body = clientWithRoute (Proxy :: Proxy sublayout) $ do @@ -529,7 +590,7 @@ instance (MimeRender ct a, HasClient sublayout) -- | Make the querying function append @path@ to the request path. instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where - type Client' (path :> sublayout) = Client' sublayout + type Client (path :> sublayout) = Client sublayout clientWithRoute Proxy req = clientWithRoute (Proxy :: Proxy sublayout) $ diff --git a/servant-client/src/Servant/Common/Req.hs b/servant-client/src/Servant/Common/Req.hs index 12dd88d9..b726e7a9 100644 --- a/servant-client/src/Servant/Common/Req.hs +++ b/servant-client/src/Servant/Common/Req.hs @@ -22,6 +22,7 @@ import Network.HTTP.Client hiding (Proxy) import Network.HTTP.Client.TLS import Network.HTTP.Media import Network.HTTP.Types +import qualified Network.HTTP.Types.Header as HTTP import Network.URI import Servant.API.ContentTypes import Servant.Common.BaseUrl @@ -136,7 +137,9 @@ displayHttpRequest :: Method -> String displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request" -performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, Response ByteString) +performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl + -> EitherT ServantError IO ( Int, ByteString, MediaType + , [HTTP.Header], Response ByteString) performRequest reqMethod req isWantedStatus reqHost = do partialRequest <- liftIO $ reqToRequest req reqHost @@ -154,6 +157,7 @@ performRequest reqMethod req isWantedStatus reqHost = do Right response -> do let status = Client.responseStatus response body = Client.responseBody response + hrds = Client.responseHeaders response status_code = statusCode status ct <- case lookup "Content-Type" $ Client.responseHeaders response of Nothing -> pure $ "application"//"octet-stream" @@ -162,20 +166,19 @@ performRequest reqMethod req isWantedStatus reqHost = do Just t' -> pure t' unless (isWantedStatus status_code) $ left $ FailureResponse status ct body - return (status_code, body, ct, response) + return (status_code, body, ct, hrds, response) + performRequestCT :: MimeUnrender ct result => - Proxy ct -> Method -> Req -> [Int] -> BaseUrl -> EitherT ServantError IO result + Proxy ct -> Method -> Req -> [Int] -> BaseUrl -> EitherT ServantError IO ([HTTP.Header], result) performRequestCT ct reqMethod req wantedStatus reqHost = do let acceptCT = contentType ct - (_status, respBody, respCT, _response) <- + (_status, respBody, respCT, hrds, _response) <- performRequest reqMethod (req { reqAccept = [acceptCT] }) (`elem` wantedStatus) reqHost - unless (matches respCT (acceptCT)) $ - left $ UnsupportedContentType respCT respBody - either - (left . (\s -> DecodeFailure s respCT respBody)) - return - (mimeUnrender ct respBody) + unless (matches respCT (acceptCT)) $ left $ UnsupportedContentType respCT respBody + case mimeUnrender ct respBody of + Left err -> left $ DecodeFailure err respCT respBody + Right val -> return (hrds, val) performRequestNoBody :: Method -> Req -> [Int] -> BaseUrl -> EitherT ServantError IO () performRequestNoBody reqMethod req wantedStatus reqHost = do diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 2b22d46f..382b3c79 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -7,7 +7,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -fcontext-stack=25 #-} +{-# OPTIONS_GHC -fcontext-stack=100 #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Servant.ClientSpec where @@ -28,7 +28,8 @@ import qualified Data.Text as T import GHC.Generics import qualified Network.HTTP.Client as C import Network.HTTP.Media -import Network.HTTP.Types +import Network.HTTP.Types hiding (Header) +import qualified Network.HTTP.Types as HTTP import Network.Socket import Network.Wai hiding (Response) import Network.Wai.Handler.Warp @@ -74,6 +75,8 @@ instance Eq C.HttpException where alice :: Person alice = Person "Alice" 42 +type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String] + type Api = "get" :> Get '[JSON] Person :<|> "delete" :> Delete @@ -93,6 +96,7 @@ type Api = QueryFlag "third" :> ReqBody '[JSON] [(String, [Rational])] :> Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])]) + :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool) api :: Proxy Api api = Proxy @@ -104,19 +108,20 @@ server = serve api ( :<|> return :<|> (\ name -> case name of Just "alice" -> return alice - Just name -> left (400, name ++ " not found") - Nothing -> left (400, "missing parameter")) + Just name -> left $ ServantErr 400 (name ++ " not found") "" [] + Nothing -> left $ ServantErr 400 "missing parameter" "" []) :<|> (\ names -> return (zipWith Person names [0..])) :<|> return :<|> (\ name -> case name of Just "alice" -> return alice - Just name -> left (400, name ++ " not found") - Nothing -> left (400, "missing parameter")) + Just name -> left $ ServantErr 400 (name ++ " not found") "" [] + Nothing -> left $ ServantErr 400 "missing parameter" "" []) :<|> (\ names -> return (zipWith Person names [0..])) :<|> return :<|> (\ _request respond -> respond $ responseLBS ok200 [] "rawSuccess") :<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure") - :<|> \ a b c d -> return (a, b, c, d) + :<|> (\ a b c d -> return (a, b, c, d)) + :<|> (return $ addHeader 1729 $ addHeader "eg2" True) ) withServer :: (BaseUrl -> IO a) -> IO a @@ -132,11 +137,14 @@ getQueryFlag :: Bool -> BaseUrl -> EitherT ServantError IO Bool getMatrixParam :: Maybe String -> BaseUrl -> EitherT ServantError IO Person getMatrixParams :: [String] -> BaseUrl -> EitherT ServantError IO [Person] getMatrixFlag :: Bool -> BaseUrl -> EitherT ServantError IO Bool -getRawSuccess :: Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, C.Response ByteString) -getRawFailure :: Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, C.Response ByteString) +getRawSuccess :: Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, + MediaType, [HTTP.Header], C.Response ByteString) +getRawFailure :: Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, + MediaType, [HTTP.Header], C.Response ByteString) getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] -> BaseUrl -> EitherT ServantError IO (String, Maybe Int, Bool, [(String, [Rational])]) +getRespHeaders :: BaseUrl -> EitherT ServantError IO (Headers TestHeaders Bool) ( getGet :<|> getDelete :<|> getCapture @@ -149,7 +157,8 @@ getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] :<|> getMatrixFlag :<|> getRawSuccess :<|> getRawFailure - :<|> getMultiple) + :<|> getMultiple + :<|> getRespHeaders) = client api type FailApi = @@ -218,7 +227,7 @@ spec = do res <- runEitherT (getRawSuccess methodGet host) case res of Left e -> assertFailure $ show e - Right (code, body, ct, response) -> do + Right (code, body, ct, _, response) -> do (code, body, ct) `shouldBe` (200, "rawSuccess", "application"//"octet-stream") C.responseBody response `shouldBe` body C.responseStatus response `shouldBe` ok200 @@ -227,11 +236,17 @@ spec = do res <- runEitherT (getRawFailure methodGet host) case res of Left e -> assertFailure $ show e - Right (code, body, ct, response) -> do + Right (code, body, ct, _, response) -> do (code, body, ct) `shouldBe` (400, "rawFailure", "application"//"octet-stream") C.responseBody response `shouldBe` body C.responseStatus response `shouldBe` badRequest400 + it "Returns headers appropriately" $ withServer $ \ host -> do + res <- runEitherT (getRespHeaders host) + case res of + Left e -> assertFailure $ show e + Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")] + modifyMaxSuccess (const 20) $ do it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body -> @@ -246,7 +261,7 @@ spec = do let test :: (WrappedApi, String) -> Spec test (WrappedApi api, desc) = it desc $ - withWaiDaemon (return (serve api (left (500, "error message")))) $ + withWaiDaemon (return (serve api (left $ ServantErr 500 "error message" "" []))) $ \ host -> do let getResponse :: BaseUrl -> EitherT ServantError IO () getResponse = client api @@ -292,8 +307,8 @@ spec = do _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res data WrappedApi where - WrappedApi :: (HasServer (Canonicalize api), Server api ~ EitherT (Int, String) IO a, - HasClient (Canonicalize api), Client api ~ (BaseUrl -> EitherT ServantError IO ())) => + WrappedApi :: (HasServer api, Server api ~ EitherT ServantErr IO a, + HasClient api, Client api ~ (BaseUrl -> EitherT ServantError IO ())) => Proxy api -> WrappedApi diff --git a/servant-docs/CHANGELOG.md b/servant-docs/CHANGELOG.md index a0c1330b..94524a55 100644 --- a/servant-docs/CHANGELOG.md +++ b/servant-docs/CHANGELOG.md @@ -5,7 +5,9 @@ * Render endpoints in a canonical order (https://github.com/haskell-servant/servant-docs/pull/15) * Remove ToJSON superclass from ToSample * Split out Internal module -* `Canonicalize` API types before generating the docs for them +* Add support for response headers +* Allow `ToSample` to return a different type than it's arguments +* Add Proxy argument to `ToSample` 0.3 --- diff --git a/servant-docs/example/greet.hs b/servant-docs/example/greet.hs index fc649607..0a8cdb2b 100644 --- a/servant-docs/example/greet.hs +++ b/servant-docs/example/greet.hs @@ -53,14 +53,17 @@ instance ToParam (MatrixParam "lang" String) where "Get the greeting message selected language. Default is en." Normal -instance ToSample Greet where - toSample = Just $ Greet "Hello, haskeller!" +instance ToSample Greet Greet where + toSample _ = Just $ Greet "Hello, haskeller!" - toSamples = + toSamples _ = [ ("If you use ?capital=true", Greet "HELLO, HASKELLER") , ("If you use ?capital=false", Greet "Hello, haskeller") ] +instance ToSample Int Int where + toSample _ = Just 1729 + -- We define some introductory sections, these will appear at the top of the -- documentation. -- @@ -84,7 +87,7 @@ type TestApi = -- POST /greet with a Greet as JSON in the request body, -- returns a Greet as JSON - :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet + :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] (Headers '[Header "X-Example" Int] Greet) -- DELETE /greet/:greetid :<|> "greet" :> Capture "greetid" Text :> Delete diff --git a/servant-docs/servant-docs.cabal b/servant-docs/servant-docs.cabal index 693c97a5..5c1c8e7f 100644 --- a/servant-docs/servant-docs.cabal +++ b/servant-docs/servant-docs.cabal @@ -32,8 +32,11 @@ library build-depends: base >=4.7 && <5 , bytestring + , bytestring-conversion + , case-insensitive , hashable , http-media >= 0.6 + , http-types >= 0.7 , lens , servant >= 0.2.1 , string-conversions @@ -50,6 +53,7 @@ executable greet-docs build-depends: base , aeson + , bytestring-conversion , lens , servant , servant-docs diff --git a/servant-docs/src/Servant/Docs.hs b/servant-docs/src/Servant/Docs.hs index d2c4722e..706ede3e 100644 --- a/servant-docs/src/Servant/Docs.hs +++ b/servant-docs/src/Servant/Docs.hs @@ -77,10 +77,10 @@ -- > "Get the greeting message selected language. Default is en." -- > Normal -- > --- > instance ToSample Greet where --- > toSample = Just $ Greet "Hello, haskeller!" +-- > instance ToSample Greet Greet where +-- > toSample _ = Just $ Greet "Hello, haskeller!" -- > --- > toSamples = +-- > toSamples _ = -- > [ ("If you use ?capital=true", Greet "HELLO, HASKELLER") -- > , ("If you use ?capital=false", Greet "Hello, haskeller") -- > ] diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index 4422f710..35671592 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -1,17 +1,22 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +#if !MIN_VERSION_base(4,8,0) +{-# LANGUAGE OverlappingInstances #-} +#endif module Servant.Docs.Internal where #if !MIN_VERSION_base(4,8,0) @@ -19,6 +24,7 @@ import Control.Applicative #endif import Control.Lens import Data.ByteString.Lazy.Char8 (ByteString) +import qualified Data.CaseInsensitive as CI import Data.Hashable import Data.HashMap.Strict (HashMap) import Data.List @@ -26,6 +32,7 @@ import Data.Maybe import Data.Monoid import Data.Ord (comparing) import Data.Proxy +import Data.ByteString.Conversion (ToByteString, toByteString) import Data.String.Conversions import Data.Text (Text, pack, unpack) import GHC.Exts (Constraint) @@ -38,6 +45,7 @@ import Servant.Utils.Links import qualified Data.HashMap.Strict as HM import qualified Data.Text as T import qualified Network.HTTP.Media as M +import qualified Network.HTTP.Types as HTTP -- | Supported HTTP request methods data Method = DocDELETE -- ^ the DELETE method @@ -191,9 +199,10 @@ data ParamKind = Normal | List | Flag -- > λ> defResponse & respStatus .~ 204 & respBody .~ [("If everything goes well", "{ \"status\": \"ok\" }")] -- > Response {_respStatus = 204, _respTypes = [], _respBody = [("If everything goes well", "{ \"status\": \"ok\" }")]} data Response = Response - { _respStatus :: Int - , _respTypes :: [M.MediaType] - , _respBody :: [(Text, M.MediaType, ByteString)] + { _respStatus :: Int + , _respTypes :: [M.MediaType] + , _respBody :: [(Text, M.MediaType, ByteString)] + , _respHeaders :: [HTTP.Header] } deriving (Eq, Ord, Show) -- | Default response: status code 200, no response body. @@ -205,7 +214,12 @@ data Response = Response -- > λ> defResponse & respStatus .~ 204 & respBody .~ Just "[]" -- > Response {_respStatus = 204, _respBody = Just "[]"} defResponse :: Response -defResponse = Response 200 [] [] +defResponse = Response + { _respStatus = 200 + , _respTypes = [] + , _respBody = [] + , _respHeaders = [] + } -- | A datatype that represents everything that can happen -- at an endpoint, with its lenses: @@ -276,8 +290,8 @@ makeLenses ''Action -- | Generate the docs for a given API that implements 'HasDocs'. This is the -- default way to create documentation. -docs :: HasDocs (Canonicalize layout) => Proxy layout -> API -docs p = docsFor (canonicalize p) (defEndpoint, defAction) +docs :: HasDocs layout => Proxy layout -> API +docs p = docsFor p (defEndpoint, defAction) -- | Closed type family, check if endpoint is exactly within API. @@ -321,11 +335,7 @@ extraInfo p action = -- 'extraInfo'. -- -- If you only want to add an introduction, use 'docsWithIntros'. -docsWith :: HasDocs (Canonicalize layout) - => [DocIntro] - -> ExtraInfo layout - -> Proxy layout - -> API +docsWith :: HasDocs layout => [DocIntro] -> ExtraInfo layout -> Proxy layout -> API docsWith intros (ExtraInfo endpoints) p = docs p & apiIntros <>~ intros & apiEndpoints %~ HM.unionWith combineAction endpoints @@ -333,7 +343,7 @@ docsWith intros (ExtraInfo endpoints) p = -- | Generate the docs for a given API that implements 'HasDocs' with with any -- number of introduction(s) -docsWithIntros :: HasDocs (Canonicalize layout) => [DocIntro] -> Proxy layout -> API +docsWithIntros :: HasDocs layout => [DocIntro] -> Proxy layout -> API docsWithIntros intros = docsWith intros mempty -- | The class that abstracts away the impact of API combinators @@ -362,8 +372,8 @@ class HasDocs layout where -- > instance FromJSON Greet -- > instance ToJSON Greet -- > --- > instance ToSample Greet where --- > toSample = Just g +-- > instance ToSample Greet Greet where +-- > toSample _ = Just g -- > -- > where g = Greet "Hello, haskeller!" -- @@ -371,34 +381,53 @@ class HasDocs layout where -- 'toSample': it lets you specify different responses along with -- some context (as 'Text') that explains when you're supposed to -- get the corresponding response. -class ToSample a where +class ToSample a b | a -> b where {-# MINIMAL (toSample | toSamples) #-} - toSample :: Maybe a - toSample = snd <$> listToMaybe samples - where samples = toSamples :: [(Text, a)] + toSample :: Proxy a -> Maybe b + toSample _ = snd <$> listToMaybe samples + where samples = toSamples (Proxy :: Proxy a) - toSamples :: [(Text, a)] - toSamples = maybe [] (return . ("",)) s - where s = toSample :: Maybe a + toSamples :: Proxy a -> [(Text, b)] + toSamples _ = maybe [] (return . ("",)) s + where s = toSample (Proxy :: Proxy a) + +instance ToSample a b => ToSample (Headers ls a) b where + toSample _ = toSample (Proxy :: Proxy a) + toSamples _ = toSamples (Proxy :: Proxy a) + + +class AllHeaderSamples ls where + allHeaderToSample :: Proxy ls -> [HTTP.Header] + +instance AllHeaderSamples '[] where + allHeaderToSample _ = [] + +instance (ToByteString l, AllHeaderSamples ls, ToSample l l, KnownSymbol h) + => AllHeaderSamples (Header h l ': ls) where + allHeaderToSample _ = (mkHeader (toSample (Proxy :: Proxy l))) : + allHeaderToSample (Proxy :: Proxy ls) + where headerName = CI.mk . cs $ symbolVal (Proxy :: Proxy h) + mkHeader (Just x) = (headerName, cs $ toByteString x) + mkHeader Nothing = (headerName, "") -- | Synthesise a sample value of a type, encoded in the specified media types. sampleByteString - :: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a) + :: forall ctypes a b. (ToSample a b, IsNonEmpty ctypes, AllMimeRender ctypes b) => Proxy ctypes -> Proxy a -> [(M.MediaType, ByteString)] sampleByteString ctypes@Proxy Proxy = - maybe [] (allMimeRender ctypes) (toSample :: Maybe a) + maybe [] (allMimeRender ctypes) $ toSample (Proxy :: Proxy a) -- | Synthesise a list of sample values of a particular type, encoded in the -- specified media types. sampleByteStrings - :: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a) + :: forall ctypes a b. (ToSample a b, IsNonEmpty ctypes, AllMimeRender ctypes b) => Proxy ctypes -> Proxy a -> [(Text, M.MediaType, ByteString)] sampleByteStrings ctypes@Proxy Proxy = - let samples = toSamples :: [(Text, a)] + let samples = toSamples (Proxy :: Proxy a) enc (t, s) = uncurry (t,,) <$> allMimeRender ctypes s in concatMap enc samples @@ -580,6 +609,7 @@ markdown api = unlines $ "#### Response:" : "" : ("- Status code " ++ show (resp ^. respStatus)) : + ("- Headers: " ++ show (resp ^. respHeaders)) : "" : formatTypes (resp ^. respTypes) ++ bodies @@ -630,7 +660,11 @@ instance HasDocs Delete where action' = action & response.respBody .~ [] & response.respStatus .~ 204 -instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts) +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPABLe #-} +#endif + (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts) => HasDocs (Get cts a) where docsFor Proxy (endpoint, action) = single endpoint' action' @@ -641,6 +675,24 @@ instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts) t = Proxy :: Proxy cts p = Proxy :: Proxy a +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPING #-} +#endif + (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts + , AllHeaderSamples ls , GetHeaders (HList ls) ) + => HasDocs (Get cts (Headers ls a)) where + docsFor Proxy (endpoint, action) = + single endpoint' action' + + where hdrs = allHeaderToSample (Proxy :: Proxy ls) + endpoint' = endpoint & method .~ DocGET + action' = action & response.respBody .~ sampleByteStrings t p + & response.respTypes .~ supportedTypes t + & response.respHeaders .~ hdrs + t = Proxy :: Proxy cts + p = Proxy :: Proxy a + instance (KnownSymbol sym, HasDocs sublayout) => HasDocs (Header sym a :> sublayout) where docsFor Proxy (endpoint, action) = @@ -650,7 +702,11 @@ instance (KnownSymbol sym, HasDocs sublayout) action' = over headers (|> headername) action headername = pack $ symbolVal (Proxy :: Proxy sym) -instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts) +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPABLE #-} +#endif + (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts) => HasDocs (Post cts a) where docsFor Proxy (endpoint, action) = single endpoint' action' @@ -662,7 +718,30 @@ instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts) t = Proxy :: Proxy cts p = Proxy :: Proxy a -instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts) +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPING #-} +#endif + (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts + , AllHeaderSamples ls , GetHeaders (HList ls) ) + => HasDocs (Post cts (Headers ls a)) where + docsFor Proxy (endpoint, action) = + single endpoint' action' + + where hdrs = allHeaderToSample (Proxy :: Proxy ls) + endpoint' = endpoint & method .~ DocPOST + action' = action & response.respBody .~ sampleByteStrings t p + & response.respTypes .~ supportedTypes t + & response.respStatus .~ 201 + & response.respHeaders .~ hdrs + t = Proxy :: Proxy cts + p = Proxy :: Proxy a + +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPABLE #-} +#endif + (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts) => HasDocs (Put cts a) where docsFor Proxy (endpoint, action) = single endpoint' action' @@ -674,6 +753,25 @@ instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts) t = Proxy :: Proxy cts p = Proxy :: Proxy a +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPING #-} +#endif + (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts + , AllHeaderSamples ls , GetHeaders (HList ls) ) + => HasDocs (Put cts (Headers ls a)) where + docsFor Proxy (endpoint, action) = + single endpoint' action' + + where hdrs = allHeaderToSample (Proxy :: Proxy ls) + endpoint' = endpoint & method .~ DocPUT + action' = action & response.respBody .~ sampleByteStrings t p + & response.respTypes .~ supportedTypes t + & response.respStatus .~ 200 + & response.respHeaders .~ hdrs + t = Proxy :: Proxy cts + p = Proxy :: Proxy a + instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout) => HasDocs (QueryParam sym a :> sublayout) where @@ -756,7 +854,8 @@ instance HasDocs Raw where -- example data. However, there's no reason to believe that the instances of -- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that -- both are even defined) for any particular type. -instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout, SupportedTypes cts) +instance (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, HasDocs sublayout + , SupportedTypes cts) => HasDocs (ReqBody cts a :> sublayout) where docsFor Proxy (endpoint, action) = diff --git a/servant-docs/test/Servant/DocsSpec.hs b/servant-docs/test/Servant/DocsSpec.hs index 803823ba..8e6cb201 100644 --- a/servant-docs/test/Servant/DocsSpec.hs +++ b/servant-docs/test/Servant/DocsSpec.hs @@ -46,14 +46,14 @@ data Datatype1 = Datatype1 { dt1field1 :: String instance ToJSON Datatype1 -instance ToSample Datatype1 where - toSample = Just $ Datatype1 "field 1" 13 +instance ToSample Datatype1 Datatype1 where + toSample _ = Just $ Datatype1 "field 1" 13 -instance ToSample String where - toSample = Just "a string" +instance ToSample String String where + toSample _ = Just "a string" -instance ToSample Int where - toSample = Just 17 +instance ToSample Int Int where + toSample _ = Just 17 instance MimeRender PlainText Int where mimeRender _ = cs . show diff --git a/servant-examples/auth-combinator/auth-combinator.hs b/servant-examples/auth-combinator/auth-combinator.hs index 3277c97e..c6373fe1 100644 --- a/servant-examples/auth-combinator/auth-combinator.hs +++ b/servant-examples/auth-combinator/auth-combinator.hs @@ -26,7 +26,7 @@ isGoodCookie = return . (== "good password") data AuthProtected instance HasServer rest => HasServer (AuthProtected :> rest) where - type ServerT' (AuthProtected :> rest) m = ServerT' rest m + type ServerT (AuthProtected :> rest) m = ServerT rest m route Proxy a request respond = case lookup "Cookie" (requestHeaders request) of @@ -75,4 +75,4 @@ $ curl -H "Cookie: good password" http://localhost:8080/private [{"ssshhh":"this is a secret"}] $ curl -H "Cookie: bad password" http://localhost:8080/private Invalid cookie. --} \ No newline at end of file +-} diff --git a/servant-jquery/src/Servant/JQuery.hs b/servant-jquery/src/Servant/JQuery.hs index 4460e0e9..729a3fd9 100644 --- a/servant-jquery/src/Servant/JQuery.hs +++ b/servant-jquery/src/Servant/JQuery.hs @@ -26,8 +26,8 @@ import Data.Proxy import Servant.API import Servant.JQuery.Internal -jquery :: HasJQ (Canonicalize layout) => Proxy layout -> JQ layout -jquery p = jqueryFor (canonicalize p) defReq +jquery :: HasJQ layout => Proxy layout -> JQ layout +jquery p = jqueryFor p defReq -- js codegen generateJS :: AjaxReq -> String @@ -112,6 +112,5 @@ instance GenerateCode rest => GenerateCode (AjaxReq :<|> rest) where -- | Directly generate all the javascript functions for your API -- from a 'Proxy' for your API type. You can then write it to -- a file or integrate it in a page, for example. -jsForAPI :: (HasJQ (Canonicalize api), GenerateCode (JQ api)) - => Proxy api -> String +jsForAPI :: (HasJQ api, GenerateCode (JQ api)) => Proxy api -> String jsForAPI p = jsFor (jquery p) diff --git a/servant-jquery/src/Servant/JQuery/Internal.hs b/servant-jquery/src/Servant/JQuery/Internal.hs index 7cfb6b89..85896c2b 100644 --- a/servant-jquery/src/Servant/JQuery/Internal.hs +++ b/servant-jquery/src/Servant/JQuery/Internal.hs @@ -194,14 +194,12 @@ type family Elem (a :: *) (ls::[*]) :: Constraint where Elem a (b ': list) = Elem a list class HasJQ (layout :: *) where - type JQ' layout :: * - jqueryFor :: Proxy layout -> AjaxReq -> JQ' layout - -type JQ layout = JQ' (Canonicalize layout) + type JQ layout :: * + jqueryFor :: Proxy layout -> AjaxReq -> JQ layout instance (HasJQ a, HasJQ b) => HasJQ (a :<|> b) where - type JQ' (a :<|> b) = JQ' a :<|> JQ' b + type JQ (a :<|> b) = JQ a :<|> JQ b jqueryFor Proxy req = jqueryFor (Proxy :: Proxy a) req @@ -209,7 +207,7 @@ instance (HasJQ a, HasJQ b) instance (KnownSymbol sym, HasJQ sublayout) => HasJQ (Capture sym a :> sublayout) where - type JQ' (Capture sym a :> sublayout) = JQ' sublayout + type JQ (Capture sym a :> sublayout) = JQ sublayout jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $ @@ -218,14 +216,14 @@ instance (KnownSymbol sym, HasJQ sublayout) where str = symbolVal (Proxy :: Proxy sym) instance HasJQ Delete where - type JQ' Delete = AjaxReq + type JQ Delete = AjaxReq jqueryFor Proxy req = req & funcName %~ ("delete" <>) & reqMethod .~ "DELETE" instance Elem JSON list => HasJQ (Get list a) where - type JQ' (Get list a) = AjaxReq + type JQ (Get list a) = AjaxReq jqueryFor Proxy req = req & funcName %~ ("get" <>) @@ -233,7 +231,7 @@ instance Elem JSON list => HasJQ (Get list a) where instance (KnownSymbol sym, HasJQ sublayout) => HasJQ (Header sym a :> sublayout) where - type JQ' (Header sym a :> sublayout) = JQ' sublayout + type JQ (Header sym a :> sublayout) = JQ sublayout jqueryFor Proxy req = jqueryFor subP (req & reqHeaders <>~ [HeaderArg hname]) @@ -242,14 +240,14 @@ instance (KnownSymbol sym, HasJQ sublayout) subP = Proxy :: Proxy sublayout instance Elem JSON list => HasJQ (Post list a) where - type JQ' (Post list a) = AjaxReq + type JQ (Post list a) = AjaxReq jqueryFor Proxy req = req & funcName %~ ("post" <>) & reqMethod .~ "POST" instance Elem JSON list => HasJQ (Put list a) where - type JQ' (Put list a) = AjaxReq + type JQ (Put list a) = AjaxReq jqueryFor Proxy req = req & funcName %~ ("put" <>) @@ -257,7 +255,7 @@ instance Elem JSON list => HasJQ (Put list a) where instance (KnownSymbol sym, HasJQ sublayout) => HasJQ (QueryParam sym a :> sublayout) where - type JQ' (QueryParam sym a :> sublayout) = JQ' sublayout + type JQ (QueryParam sym a :> sublayout) = JQ sublayout jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $ @@ -267,7 +265,7 @@ instance (KnownSymbol sym, HasJQ sublayout) instance (KnownSymbol sym, HasJQ sublayout) => HasJQ (QueryParams sym a :> sublayout) where - type JQ' (QueryParams sym a :> sublayout) = JQ' sublayout + type JQ (QueryParams sym a :> sublayout) = JQ sublayout jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $ @@ -277,7 +275,7 @@ instance (KnownSymbol sym, HasJQ sublayout) instance (KnownSymbol sym, HasJQ sublayout) => HasJQ (QueryFlag sym :> sublayout) where - type JQ' (QueryFlag sym :> sublayout) = JQ' sublayout + type JQ (QueryFlag sym :> sublayout) = JQ sublayout jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $ @@ -287,7 +285,7 @@ instance (KnownSymbol sym, HasJQ sublayout) instance (KnownSymbol sym, HasJQ sublayout) => HasJQ (MatrixParam sym a :> sublayout) where - type JQ' (MatrixParam sym a :> sublayout) = JQ' sublayout + type JQ (MatrixParam sym a :> sublayout) = JQ sublayout jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $ @@ -298,7 +296,7 @@ instance (KnownSymbol sym, HasJQ sublayout) instance (KnownSymbol sym, HasJQ sublayout) => HasJQ (MatrixParams sym a :> sublayout) where - type JQ' (MatrixParams sym a :> sublayout) = JQ' sublayout + type JQ (MatrixParams sym a :> sublayout) = JQ sublayout jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $ @@ -308,7 +306,7 @@ instance (KnownSymbol sym, HasJQ sublayout) instance (KnownSymbol sym, HasJQ sublayout) => HasJQ (MatrixFlag sym :> sublayout) where - type JQ' (MatrixFlag sym :> sublayout) = JQ' sublayout + type JQ (MatrixFlag sym :> sublayout) = JQ sublayout jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $ @@ -317,14 +315,14 @@ instance (KnownSymbol sym, HasJQ sublayout) where str = symbolVal (Proxy :: Proxy sym) instance HasJQ Raw where - type JQ' Raw = Method -> AjaxReq + type JQ Raw = Method -> AjaxReq jqueryFor Proxy req method = req & funcName %~ ((toLower <$> method) <>) & reqMethod .~ method instance (Elem JSON list, HasJQ sublayout) => HasJQ (ReqBody list a :> sublayout) where - type JQ' (ReqBody list a :> sublayout) = JQ' sublayout + type JQ (ReqBody list a :> sublayout) = JQ sublayout jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $ @@ -332,7 +330,7 @@ instance (Elem JSON list, HasJQ sublayout) => HasJQ (ReqBody list a :> sublayout instance (KnownSymbol path, HasJQ sublayout) => HasJQ (path :> sublayout) where - type JQ' (path :> sublayout) = JQ' sublayout + type JQ (path :> sublayout) = JQ sublayout jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $ diff --git a/servant-jquery/test/Servant/JQuerySpec/CustomHeaders.hs b/servant-jquery/test/Servant/JQuerySpec/CustomHeaders.hs index 95cf4487..4480d44c 100644 --- a/servant-jquery/test/Servant/JQuerySpec/CustomHeaders.hs +++ b/servant-jquery/test/Servant/JQuerySpec/CustomHeaders.hs @@ -22,7 +22,7 @@ data Authorization (sym :: Symbol) a instance (KnownSymbol sym, HasJQ sublayout) => HasJQ (Authorization sym a :> sublayout) where - type JQ' (Authorization sym a :> sublayout) = JQ' sublayout + type JQ (Authorization sym a :> sublayout) = JQ sublayout jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $ req & reqHeaders <>~ [ ReplaceHeaderArg "Authorization" $ @@ -35,7 +35,7 @@ data MyLovelyHorse a instance (HasJQ sublayout) => HasJQ (MyLovelyHorse a :> sublayout) where - type JQ' (MyLovelyHorse a :> sublayout) = JQ' sublayout + type JQ (MyLovelyHorse a :> sublayout) = JQ sublayout jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $ req & reqHeaders <>~ [ ReplaceHeaderArg "X-MyLovelyHorse" tpl ] @@ -47,7 +47,7 @@ data WhatsForDinner a instance (HasJQ sublayout) => HasJQ (WhatsForDinner a :> sublayout) where - type JQ' (WhatsForDinner a :> sublayout) = JQ' sublayout + type JQ (WhatsForDinner a :> sublayout) = JQ sublayout jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $ req & reqHeaders <>~ [ ReplaceHeaderArg "X-WhatsForDinner" tpl ] diff --git a/servant-lucid/LICENSE b/servant-lucid/LICENSE new file mode 100644 index 00000000..0b0a2174 --- /dev/null +++ b/servant-lucid/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015, Julian K. Arni + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Julian K. Arni nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/servant-lucid/Setup.hs b/servant-lucid/Setup.hs new file mode 100644 index 00000000..9a994af6 --- /dev/null +++ b/servant-lucid/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/servant-lucid/servant-lucid.cabal b/servant-lucid/servant-lucid.cabal new file mode 100644 index 00000000..7088003d --- /dev/null +++ b/servant-lucid/servant-lucid.cabal @@ -0,0 +1,28 @@ +-- Initial servant-lucid.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: servant-lucid +version: 0.1.0.0 +synopsis: Servant support for lucid +-- description: +homepage: http://haskell-servant.github.io/ +license: BSD3 +license-file: LICENSE +author: Julian K. Arni +maintainer: jkarni@gmail.com +-- copyright: +category: Web +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + exposed-modules: Servant.HTML.Lucid + -- other-modules: + -- other-extensions: + build-depends: base >=4.7 && <5 + , http-media + , lucid + , servant + hs-source-dirs: src + default-language: Haskell2010 diff --git a/servant-lucid/src/Servant/HTML/Lucid.hs b/servant-lucid/src/Servant/HTML/Lucid.hs new file mode 100644 index 00000000..7fa39709 --- /dev/null +++ b/servant-lucid/src/Servant/HTML/Lucid.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +#if !MIN_VERSION_base(4,8,0) +{-# LANGUAGE OverlappingInstances #-} +#endif + +-- | An @HTML@ empty data type with `MimeRender` instances for @lucid@'s +-- `ToHtml` class and `Html` datatype. +-- You should only need to import this module for it's instances and the +-- `HTML` datatype.: +-- +-- >>> type Eg = Get '[HTML] a +-- +-- Will then check that @a@ has a `ToHtml` instance, or is `Html`. +module Servant.HTML.Lucid where + +import Data.Typeable (Typeable) +import Lucid (Html, ToHtml (..), renderBS) +import qualified Network.HTTP.Media as M +import Servant.API (Accept (..), MimeRender (..)) + +data HTML deriving Typeable + +-- | @text/plain;charset=utf-8@ +instance Accept HTML where + contentType _ = "text" M.// "html" M./: ("charset", "utf-8") + +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPABLE #-} +#endif + ToHtml a => MimeRender HTML a where + mimeRender _ = renderBS . toHtml + +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPING #-} +#endif + MimeRender HTML (Html a) where + mimeRender _ = renderBS diff --git a/servant-server/CHANGELOG.md b/servant-server/CHANGELOG.md index 161e66c2..0a75ffb0 100644 --- a/servant-server/CHANGELOG.md +++ b/servant-server/CHANGELOG.md @@ -5,9 +5,11 @@ * Support for `Accept`/`Content-type` headers and for the content-type aware combinators in *servant-0.3* * 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) -* Canonicalize API types before generating the handler types with `Server` * 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 ----- diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index a95abc05..330079a3 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -36,6 +36,8 @@ library Servant Servant.Server Servant.Server.Internal + Servant.Server.Internal.ServantErr + Servant.Server.Internal.Enter Servant.Utils.StaticFiles build-depends: base >= 4.7 && < 5 @@ -45,6 +47,8 @@ library , 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.2 && < 0.4 , split >= 0.2 && < 0.3 @@ -100,6 +104,18 @@ test-suite spec , 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/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index 5489de3d..6e28d99e 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} +{-# 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'. @@ -14,13 +15,73 @@ module Servant.Server , -- * Handlers for all standard combinators HasServer(..) , Server - , ServerT + + -- * Enter + -- $enterDoc + + -- ** 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.API (Canonicalize, canonicalize) -import Servant.Server.Internal +import Data.Proxy (Proxy) +import Network.Wai (Application) +import Servant.Server.Internal +import Servant.Server.Internal.Enter +import Servant.Server.Internal.ServantErr -- * Implementing Servers @@ -45,5 +106,30 @@ import Servant.Server.Internal -- > -- > main :: IO () -- > main = Network.Wai.Handler.Warp.run 8080 app -serve :: HasServer (Canonicalize layout) => Proxy layout -> Server layout -> Application -serve p server = toApplication (route (canonicalize p) server) +-- +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/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 942020a9..a712e757 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -38,7 +38,7 @@ import Network.Wai (Application, Request, Response, requestMethod, responseLBS, strictRequestBody) import Servant.API ((:<|>) (..), (:>), Capture, - Canonicalize, Delete, Get, Header, + Delete, Get, Header, MatrixFlag, MatrixParam, MatrixParams, Patch, Post, Put, QueryFlag, QueryParam, QueryParams, Raw, @@ -46,9 +46,12 @@ import Servant.API ((:<|>) (..), (:>), Capture, import Servant.API.ContentTypes (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..)) -import Servant.API.ResponseHeaders (Headers, getResponse, getHeaders) +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 @@ -174,13 +177,11 @@ processedPathInfo r = where pinfo = parsePathInfo r class HasServer layout where - type ServerT' layout (m :: * -> *) :: * + type ServerT layout (m :: * -> *) :: * - route :: Proxy layout -> Server' layout -> RoutingApplication + route :: Proxy layout -> Server layout -> RoutingApplication -type Server layout = Server' (Canonicalize layout) -type Server' layout = ServerT' layout (EitherT (Int, String) IO) -type ServerT layout m = ServerT' (Canonicalize layout) m +type Server layout = ServerT layout (EitherT ServantErr IO) -- * Instances @@ -197,7 +198,7 @@ type ServerT layout m = ServerT' (Canonicalize layout) m -- > postBook book = ... instance (HasServer a, HasServer b) => HasServer (a :<|> b) where - type ServerT' (a :<|> b) m = ServerT' a m :<|> ServerT' b m + type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m route Proxy (a :<|> b) request respond = route pa a request $ \mResponse -> @@ -231,8 +232,8 @@ captured _ = fromText instance (KnownSymbol capture, FromText a, HasServer sublayout) => HasServer (Capture capture a :> sublayout) where - type ServerT' (Capture capture a :> sublayout) m = - a -> ServerT' sublayout m + type ServerT (Capture capture a :> sublayout) m = + a -> ServerT sublayout m route Proxy subserver request respond = case processedPathInfo request of (first : rest) @@ -259,16 +260,14 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout) -- are not met. instance HasServer Delete where - type ServerT' Delete m = m () + type ServerT Delete m = m () 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) + Right () -> responseLBS status204 [] "" + Left err -> responseServantErr err | pathIsEmpty request && requestMethod request /= methodDelete = respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound @@ -292,7 +291,7 @@ instance #endif ( AllCTRender ctypes a ) => HasServer (Get ctypes a) where - type ServerT' (Get ctypes a) m = m a + type ServerT (Get ctypes a) m = m a route Proxy action request respond | pathIsEmpty request && requestMethod request == methodGet = do @@ -304,8 +303,7 @@ instance Nothing -> failWith UnsupportedMediaType Just (contentT, body) -> succeedWith $ responseLBS ok200 [ ("Content-Type" , cs contentT)] body - Left (status, message) -> succeedWith $ - responseLBS (mkStatus status (cs message)) [] (cs message) + Left err -> succeedWith $ responseServantErr err | pathIsEmpty request && requestMethod request /= methodGet = respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound @@ -317,15 +315,14 @@ instance #endif HasServer (Get ctypes ()) where - type ServerT' (Get ctypes ()) m = m () + 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 () -> responseLBS noContent204 [] "" - Left (status, message) -> - responseLBS (mkStatus status (cs message)) [] (cs message) + Left err -> responseServantErr err | pathIsEmpty request && requestMethod request /= methodGet = respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound @@ -335,9 +332,10 @@ instance #if MIN_VERSION_base(4,8,0) {-# OVERLAPPING #-} #endif - ( AllCTRender ctypes v ) => HasServer (Get ctypes (Headers h v)) where + ( 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) + type ServerT (Get ctypes (Headers h v)) m = m (Headers h v) route Proxy action request respond | pathIsEmpty request && requestMethod request == methodGet = do @@ -350,8 +348,7 @@ instance Nothing -> failWith UnsupportedMediaType Just (contentT, body) -> succeedWith $ responseLBS ok200 ( ("Content-Type" , cs contentT) : headers) body - Left (status, message) -> succeedWith $ - responseLBS (mkStatus status (cs message)) [] (cs message) + Left err -> succeedWith $ responseServantErr err | pathIsEmpty request && requestMethod request /= methodGet = respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound @@ -379,8 +376,8 @@ instance instance (KnownSymbol sym, FromText a, HasServer sublayout) => HasServer (Header sym a :> sublayout) where - type ServerT' (Header sym a :> sublayout) m = - Maybe a -> ServerT' sublayout m + 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) @@ -408,7 +405,7 @@ instance ( AllCTRender ctypes a ) => HasServer (Post ctypes a) where - type ServerT' (Post ctypes a) m = m a + type ServerT (Post ctypes a) m = m a route Proxy action request respond | pathIsEmpty request && requestMethod request == methodPost = do @@ -420,8 +417,7 @@ instance Nothing -> failWith UnsupportedMediaType Just (contentT, body) -> succeedWith $ responseLBS status201 [ ("Content-Type" , cs contentT)] body - Left (status, message) -> succeedWith $ - responseLBS (mkStatus status (cs message)) [] (cs message) + Left err -> succeedWith $ responseServantErr err | pathIsEmpty request && requestMethod request /= methodPost = respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound @@ -432,15 +428,14 @@ instance #endif HasServer (Post ctypes ()) where - type ServerT' (Post ctypes ()) m = m () + 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 () -> responseLBS noContent204 [] "" - Left (status, message) -> - responseLBS (mkStatus status (cs message)) [] (cs message) + Left err -> responseServantErr err | pathIsEmpty request && requestMethod request /= methodPost = respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound @@ -450,9 +445,10 @@ instance #if MIN_VERSION_base(4,8,0) {-# OVERLAPPING #-} #endif - ( AllCTRender ctypes v ) => HasServer (Post ctypes (Headers h v)) where + ( 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) + type ServerT (Post ctypes (Headers h v)) m = m (Headers h v) route Proxy action request respond | pathIsEmpty request && requestMethod request == methodPost = do @@ -465,8 +461,7 @@ instance Nothing -> failWith UnsupportedMediaType Just (contentT, body) -> succeedWith $ responseLBS status201 ( ("Content-Type" , cs contentT) : headers) body - Left (status, message) -> succeedWith $ - responseLBS (mkStatus status (cs message)) [] (cs message) + Left err -> succeedWith $ responseServantErr err | pathIsEmpty request && requestMethod request /= methodPost = respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound @@ -490,7 +485,7 @@ instance #endif ( AllCTRender ctypes a) => HasServer (Put ctypes a) where - type ServerT' (Put ctypes a) m = m a + type ServerT (Put ctypes a) m = m a route Proxy action request respond | pathIsEmpty request && requestMethod request == methodPut = do @@ -502,8 +497,7 @@ instance Nothing -> failWith UnsupportedMediaType Just (contentT, body) -> succeedWith $ responseLBS status200 [ ("Content-Type" , cs contentT)] body - Left (status, message) -> succeedWith $ - responseLBS (mkStatus status (cs message)) [] (cs message) + Left err -> succeedWith $ responseServantErr err | pathIsEmpty request && requestMethod request /= methodPut = respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound @@ -514,15 +508,14 @@ instance #endif HasServer (Put ctypes ()) where - type ServerT' (Put ctypes ()) m = m () + 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 (status, message) -> - responseLBS (mkStatus status (cs message)) [] (cs message) + Left err -> responseServantErr err | pathIsEmpty request && requestMethod request /= methodPut = respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound @@ -532,9 +525,10 @@ instance #if MIN_VERSION_base(4,8,0) {-# OVERLAPPING #-} #endif - ( AllCTRender ctypes v ) => HasServer (Put ctypes (Headers h v)) where + ( 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) + type ServerT (Put ctypes (Headers h v)) m = m (Headers h v) route Proxy action request respond | pathIsEmpty request && requestMethod request == methodPut = do @@ -547,8 +541,7 @@ instance Nothing -> failWith UnsupportedMediaType Just (contentT, body) -> succeedWith $ responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body - Left (status, message) -> succeedWith $ - responseLBS (mkStatus status (cs message)) [] (cs message) + Left err -> succeedWith $ responseServantErr err | pathIsEmpty request && requestMethod request /= methodPut = respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound @@ -570,7 +563,7 @@ instance #endif ( AllCTRender ctypes a) => HasServer (Patch ctypes a) where - type ServerT' (Patch ctypes a) m = m a + type ServerT (Patch ctypes a) m = m a route Proxy action request respond | pathIsEmpty request && requestMethod request == methodPatch = do @@ -582,8 +575,7 @@ instance Nothing -> failWith UnsupportedMediaType Just (contentT, body) -> succeedWith $ responseLBS status200 [ ("Content-Type" , cs contentT)] body - Left (status, message) -> succeedWith $ - responseLBS (mkStatus status (cs message)) [] (cs message) + Left err -> succeedWith $ responseServantErr err | pathIsEmpty request && requestMethod request /= methodPatch = respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound @@ -594,15 +586,14 @@ instance #endif HasServer (Patch ctypes ()) where - type ServerT' (Patch ctypes ()) m = m () + 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 () -> responseLBS noContent204 [] "" - Left (status, message) -> - responseLBS (mkStatus status (cs message)) [] (cs message) + Left err -> responseServantErr err | pathIsEmpty request && requestMethod request /= methodPatch = respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound @@ -612,9 +603,10 @@ instance #if MIN_VERSION_base(4,8,0) {-# OVERLAPPING #-} #endif - ( AllCTRender ctypes v ) => HasServer (Patch ctypes (Headers h v)) where + ( 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) + type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v) route Proxy action request respond | pathIsEmpty request && requestMethod request == methodPatch = do @@ -627,8 +619,7 @@ instance Nothing -> failWith UnsupportedMediaType Just (contentT, body) -> succeedWith $ responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body - Left (status, message) -> succeedWith $ - responseLBS (mkStatus status (cs message)) [] (cs message) + Left err -> succeedWith $ responseServantErr err | pathIsEmpty request && requestMethod request /= methodPatch = respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound @@ -657,8 +648,8 @@ instance instance (KnownSymbol sym, FromText a, HasServer sublayout) => HasServer (QueryParam sym a :> sublayout) where - type ServerT' (QueryParam sym a :> sublayout) m = - Maybe a -> ServerT' sublayout m + type ServerT (QueryParam sym a :> sublayout) m = + Maybe a -> ServerT sublayout m route Proxy subserver request respond = do let querytext = parseQueryText $ rawQueryString request @@ -695,8 +686,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout) instance (KnownSymbol sym, FromText a, HasServer sublayout) => HasServer (QueryParams sym a :> sublayout) where - type ServerT' (QueryParams sym a :> sublayout) m = - [a] -> ServerT' sublayout m + type ServerT (QueryParams sym a :> sublayout) m = + [a] -> ServerT sublayout m route Proxy subserver request respond = do let querytext = parseQueryText $ rawQueryString request @@ -728,8 +719,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout) instance (KnownSymbol sym, HasServer sublayout) => HasServer (QueryFlag sym :> sublayout) where - type ServerT' (QueryFlag sym :> sublayout) m = - Bool -> ServerT' sublayout m + type ServerT (QueryFlag sym :> sublayout) m = + Bool -> ServerT sublayout m route Proxy subserver request respond = do let querytext = parseQueryText $ rawQueryString request @@ -771,8 +762,8 @@ parseMatrixText = parseQueryText instance (KnownSymbol sym, FromText a, HasServer sublayout) => HasServer (MatrixParam sym a :> sublayout) where - type ServerT' (MatrixParam sym a :> sublayout) m = - Maybe a -> ServerT' sublayout m + type ServerT (MatrixParam sym a :> sublayout) m = + Maybe a -> ServerT sublayout m route Proxy subserver request respond = case parsePathInfo request of (first : _) @@ -809,8 +800,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout) instance (KnownSymbol sym, FromText a, HasServer sublayout) => HasServer (MatrixParams sym a :> sublayout) where - type ServerT' (MatrixParams sym a :> sublayout) m = - [a] -> ServerT' sublayout m + type ServerT (MatrixParams sym a :> sublayout) m = + [a] -> ServerT sublayout m route Proxy subserver request respond = case parsePathInfo request of (first : _) @@ -843,8 +834,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout) instance (KnownSymbol sym, HasServer sublayout) => HasServer (MatrixFlag sym :> sublayout) where - type ServerT' (MatrixFlag sym :> sublayout) m = - Bool -> ServerT' sublayout m + type ServerT (MatrixFlag sym :> sublayout) m = + Bool -> ServerT sublayout m route Proxy subserver request respond = case parsePathInfo request of (first : _) @@ -872,7 +863,7 @@ instance (KnownSymbol sym, HasServer sublayout) -- > server = serveDirectory "/var/www/images" instance HasServer Raw where - type ServerT' Raw m = Application + type ServerT Raw m = Application route Proxy rawApplication request respond = rawApplication request (respond . succeedWith) @@ -900,8 +891,8 @@ instance HasServer Raw where instance ( AllCTUnrender list a, HasServer sublayout ) => HasServer (ReqBody list a :> sublayout) where - type ServerT' (ReqBody list a :> sublayout) m = - a -> ServerT' sublayout m + type ServerT (ReqBody list a :> sublayout) m = + a -> ServerT sublayout m route Proxy subserver request respond = do -- See HTTP RFC 2616, section 7.2.1 @@ -921,7 +912,7 @@ instance ( AllCTUnrender list a, HasServer sublayout -- pass the rest of the request path to @sublayout@. instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where - type ServerT' (path :> sublayout) m = ServerT' sublayout m + type ServerT (path :> sublayout) m = ServerT sublayout m route Proxy subserver request respond = case processedPathInfo request of (first : rest) diff --git a/servant-server/src/Servant/Server/Internal/Enter.hs b/servant-server/src/Servant/Server/Internal/Enter.hs new file mode 100644 index 00000000..a8a904d6 --- /dev/null +++ b/servant-server/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/servant-server/src/Servant/Server/Internal/ServantErr.hs b/servant-server/src/Servant/Server/Internal/ServantErr.hs new file mode 100644 index 00000000..b29a0618 --- /dev/null +++ b/servant-server/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/servant-server/test/Doctests.hs b/servant-server/test/Doctests.hs new file mode 100644 index 00000000..c63a6d85 --- /dev/null +++ b/servant-server/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 + diff --git a/servant-server/test/Servant/Server/Internal/EnterSpec.hs b/servant-server/test/Servant/Server/Internal/EnterSpec.hs new file mode 100644 index 00000000..992e7bf4 --- /dev/null +++ b/servant-server/test/Servant/Server/Internal/EnterSpec.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +module Servant.Server.Internal.EnterSpec where + +import qualified Control.Category as C +import Control.Monad.Reader +import Control.Monad.Trans.Either +import Data.Proxy +import Servant.API +import Servant.Server + +import Test.Hspec (Spec, describe, it) +import Test.Hspec.Wai (get, matchStatus, post, + shouldRespondWith, with) + +spec :: Spec +spec = describe "module Servant.Server.Enter" $ do + enterSpec + +type ReaderAPI = "int" :> Get '[JSON] Int + :<|> "string" :> Post '[JSON] String + +type IdentityAPI = "bool" :> Get '[JSON] Bool + +type CombinedAPI = ReaderAPI :<|> IdentityAPI + +readerAPI :: Proxy ReaderAPI +readerAPI = Proxy + +combinedAPI :: Proxy CombinedAPI +combinedAPI = Proxy + +readerServer' :: ServerT ReaderAPI (Reader String) +readerServer' = return 1797 :<|> ask + +fReader :: Reader String :~> EitherT ServantErr IO +fReader = generalizeNat C.. (runReaderTNat "hi") + +readerServer :: Server ReaderAPI +readerServer = enter fReader readerServer' + +combinedReaderServer' :: ServerT CombinedAPI (Reader String) +combinedReaderServer' = readerServer' :<|> enter generalizeNat (return True) + +combinedReaderServer :: Server CombinedAPI +combinedReaderServer = enter fReader combinedReaderServer' + +enterSpec :: Spec +enterSpec = describe "Enter" $ do + with (return (serve readerAPI readerServer)) $ do + + it "allows running arbitrary monads" $ do + get "int" `shouldRespondWith` "1797" + post "string" "3" `shouldRespondWith` "\"hi\""{ matchStatus = 201 } + + with (return (serve combinedAPI combinedReaderServer)) $ do + it "allows combnation of enters" $ do + get "bool" `shouldRespondWith` "true" diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 58ef1244..be8f0665 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -35,13 +35,13 @@ import Test.Hspec.Wai (get, liftIO, matchHeaders, shouldRespondWith, with, (<:>)) import Servant.API ((:<|>) (..), (:>), - AddHeader (addHeader), Capture, + addHeader, Capture, Delete, Get, Header (..), Headers, JSON, MatrixFlag, MatrixParam, MatrixParams, Patch, PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw, ReqBody) -import Servant.Server (Server, serve) +import Servant.Server (Server, serve, ServantErr(..), err404) import Servant.Server.Internal (RouteMismatch (..)) @@ -96,11 +96,11 @@ spec = do type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal captureApi :: Proxy CaptureApi captureApi = Proxy -captureServer :: Integer -> EitherT (Int, String) IO Animal +captureServer :: Integer -> EitherT ServantErr IO Animal captureServer legs = case legs of 4 -> return jerry 2 -> return tweety - _ -> left (404, "not found") + _ -> left err404 captureSpec :: Spec captureSpec = do @@ -450,11 +450,11 @@ headerApi = Proxy headerSpec :: Spec headerSpec = describe "Servant.API.Header" $ do - let expectsInt :: Maybe Int -> EitherT (Int,String) IO () + let expectsInt :: Maybe Int -> EitherT ServantErr IO () expectsInt (Just x) = when (x /= 5) $ error "Expected 5" expectsInt Nothing = error "Expected an int" - let expectsString :: Maybe String -> EitherT (Int,String) IO () + let expectsString :: Maybe String -> EitherT ServantErr IO () expectsString (Just x) = when (x /= "more from you") $ error "Expected more from you" expectsString Nothing = error "Expected a string" diff --git a/servant/CHANGELOG.md b/servant/CHANGELOG.md index 146daee5..80c864f9 100644 --- a/servant/CHANGELOG.md +++ b/servant/CHANGELOG.md @@ -1,6 +1,5 @@ 0.3 --- -* Add a `Canonicalize` type family that distributes all `:>`s inside `:<|>`s to get to the canonical type of an API -- which is then used in all other packages to avoid weird handler types in *servant-server*. * Multiple content-type/accept support for all the relevant combinators * Provide *JSON*, *PlainText*, *OctetStream* and *FormUrlEncoded* content types out of the box * Type-safe link generation to API endpoints diff --git a/servant/shell.nix b/servant/shell.nix new file mode 100644 index 00000000..1dc98d67 --- /dev/null +++ b/servant/shell.nix @@ -0,0 +1,2 @@ +with (import {}).pkgs; +(haskellngPackages.callPackage ./. {}).env diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index da511752..034be7a2 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module Servant.API ( @@ -49,26 +49,21 @@ module Servant.API ( module Servant.Common.Text, -- | Classes and instances for types that can be converted to and from @Text@ - -- * Canonicalizing (flattening) API types - Canonicalize, - canonicalize, - -- * Utilities module Servant.Utils.Links, -- | Type-safe internal URIs ) where -import Data.Proxy (Proxy (..)) import Servant.API.Alternative ((:<|>) (..)) import Servant.API.Capture (Capture) -import Servant.API.ContentTypes (FormUrlEncoded, +import Servant.API.ContentTypes (Accept (..), FormUrlEncoded, FromFormUrlEncoded (..), JSON, MimeRender (..), MimeUnrender (..), OctetStream, PlainText, ToFormUrlEncoded (..)) import Servant.API.Delete (Delete) import Servant.API.Get (Get) -import Servant.API.Header (Header(..)) +import Servant.API.Header (Header (..)) import Servant.API.MatrixParam (MatrixFlag, MatrixParam, MatrixParams) import Servant.API.Patch (Patch) @@ -78,40 +73,13 @@ import Servant.API.QueryParam (QueryFlag, QueryParam, QueryParams) import Servant.API.Raw (Raw) import Servant.API.ReqBody (ReqBody) -import Servant.API.ResponseHeaders ( Headers, getHeaders, getResponse - , AddHeader(addHeader) ) +import Servant.API.ResponseHeaders (AddHeader (addHeader), + BuildHeadersTo (buildHeadersTo), + GetHeaders (getHeaders), + HList (..), Headers (..), + getHeadersHList, getResponse) import Servant.API.Sub ((:>)) import Servant.Common.Text (FromText (..), ToText (..)) import Servant.Utils.Links (HasLink (..), IsElem, IsElem', URI (..), safeLink) --- | Turn an API type into its canonical form. --- --- The canonical form of an API type is basically the all-flattened form --- of the original type. More formally, it takes a type as input and hands you --- back an /equivalent/ type formed of toplevel `:<|>`-separated chains of `:>`s, --- i.e with all `:>`s distributed inside the `:<|>`s. --- --- It basically turns: --- --- > "hello" :> (Get Hello :<|> ReqBody Hello :> Put Hello) --- --- into --- --- > ("hello" :> Get Hello) :<|> ("hello" :> ReqBody Hello :> Put Hello) --- --- i.e distributing all ':>'-separated bits into the subsequent ':<|>'s. -type family Canonicalize api :: * where - -- requires UndecidableInstances - Canonicalize (a :> (b :<|> c)) = a :> Canonicalize b :<|> a :> Canonicalize c - Canonicalize ((a :<|> b) :> c) = a :> Canonicalize c :<|> b :> Canonicalize c - Canonicalize (a :> b) = Redex b (Canonicalize b) a - Canonicalize (a :<|> b) = Canonicalize a :<|> Canonicalize b - Canonicalize a = a - -type family Redex a b c :: * where - Redex a a first = Canonicalize first :> a - Redex a b first = Canonicalize (first :> b) - -canonicalize :: Proxy layout -> Proxy (Canonicalize layout) -canonicalize Proxy = Proxy diff --git a/servant/src/Servant/API/Alternative.hs b/servant/src/Servant/API/Alternative.hs index 03d9dcc0..2ba5ecd9 100644 --- a/servant/src/Servant/API/Alternative.hs +++ b/servant/src/Servant/API/Alternative.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TypeOperators #-} +{-# OPTIONS_HADDOCK not-home #-} module Servant.API.Alternative ((:<|>)(..)) where #if !MIN_VERSION_base(4,8,0) diff --git a/servant/src/Servant/API/Capture.hs b/servant/src/Servant/API/Capture.hs index 26e56048..a40e0233 100644 --- a/servant/src/Servant/API/Capture.hs +++ b/servant/src/Servant/API/Capture.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PolyKinds #-} +{-# OPTIONS_HADDOCK not-home #-} module Servant.API.Capture (Capture) where import Data.Typeable (Typeable) diff --git a/servant/src/Servant/API/ContentTypes.hs b/servant/src/Servant/API/ContentTypes.hs index 45b7391c..384b3fe8 100644 --- a/servant/src/Servant/API/ContentTypes.hs +++ b/servant/src/Servant/API/ContentTypes.hs @@ -10,6 +10,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_HADDOCK not-home #-} -- | A collection of basic Content-Types (also known as Internet Media -- Types, or MIME types). Additionally, this module provides classes that diff --git a/servant/src/Servant/API/Delete.hs b/servant/src/Servant/API/Delete.hs index 5c0eb7b7..cca4ae37 100644 --- a/servant/src/Servant/API/Delete.hs +++ b/servant/src/Servant/API/Delete.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# OPTIONS_HADDOCK not-home #-} module Servant.API.Delete (Delete) where import Data.Typeable ( Typeable ) diff --git a/servant/src/Servant/API/Get.hs b/servant/src/Servant/API/Get.hs index bd4288df..073bfda6 100644 --- a/servant/src/Servant/API/Get.hs +++ b/servant/src/Servant/API/Get.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE KindSignatures #-} +{-# OPTIONS_HADDOCK not-home #-} module Servant.API.Get (Get) where import Data.Typeable (Typeable) diff --git a/servant/src/Servant/API/Header.hs b/servant/src/Servant/API/Header.hs index 2b3ff112..7d58d762 100644 --- a/servant/src/Servant/API/Header.hs +++ b/servant/src/Servant/API/Header.hs @@ -1,10 +1,13 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE PolyKinds #-} +{-# OPTIONS_HADDOCK not-home #-} module Servant.API.Header where -import Data.Typeable (Typeable) -import GHC.TypeLits (Symbol) +import Data.ByteString (ByteString) +import Data.Typeable (Typeable) +import GHC.TypeLits (Symbol) -- | Extract the given header's value as a value of type @a@. -- -- Example: @@ -14,7 +17,9 @@ import GHC.TypeLits (Symbol) -- >>> -- GET /view-my-referer -- >>> type MyApi = "view-my-referer" :> Header "from" Referer :> Get '[JSON] Referer data Header (sym :: Symbol) a = Header a - deriving Typeable + | MissingHeader + | UndecodableHeader ByteString + deriving (Typeable, Eq, Show, Functor) -- $setup -- >>> import Servant.API diff --git a/servant/src/Servant/API/MatrixParam.hs b/servant/src/Servant/API/MatrixParam.hs index 59c0d045..f91c4050 100644 --- a/servant/src/Servant/API/MatrixParam.hs +++ b/servant/src/Servant/API/MatrixParam.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PolyKinds #-} +{-# OPTIONS_HADDOCK not-home #-} module Servant.API.MatrixParam (MatrixFlag, MatrixParam, MatrixParams) where import Data.Typeable (Typeable) diff --git a/servant/src/Servant/API/Patch.hs b/servant/src/Servant/API/Patch.hs index 4a33f97a..715cf905 100644 --- a/servant/src/Servant/API/Patch.hs +++ b/servant/src/Servant/API/Patch.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE KindSignatures #-} +{-# OPTIONS_HADDOCK not-home #-} module Servant.API.Patch (Patch) where import Data.Typeable (Typeable) diff --git a/servant/src/Servant/API/Post.hs b/servant/src/Servant/API/Post.hs index 3b1a616d..72bc59cc 100644 --- a/servant/src/Servant/API/Post.hs +++ b/servant/src/Servant/API/Post.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE KindSignatures #-} +{-# OPTIONS_HADDOCK not-home #-} module Servant.API.Post (Post) where import Data.Typeable (Typeable) diff --git a/servant/src/Servant/API/Put.hs b/servant/src/Servant/API/Put.hs index 144a22fc..52bb81fa 100644 --- a/servant/src/Servant/API/Put.hs +++ b/servant/src/Servant/API/Put.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE KindSignatures #-} +{-# OPTIONS_HADDOCK not-home #-} module Servant.API.Put (Put) where import Data.Typeable ( Typeable ) diff --git a/servant/src/Servant/API/QueryParam.hs b/servant/src/Servant/API/QueryParam.hs index 14e8ce43..ca913e17 100644 --- a/servant/src/Servant/API/QueryParam.hs +++ b/servant/src/Servant/API/QueryParam.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE PolyKinds #-} +{-# OPTIONS_HADDOCK not-home #-} module Servant.API.QueryParam (QueryFlag, QueryParam, QueryParams) where import Data.Typeable (Typeable) diff --git a/servant/src/Servant/API/Raw.hs b/servant/src/Servant/API/Raw.hs index eeaec597..06f5bdb9 100644 --- a/servant/src/Servant/API/Raw.hs +++ b/servant/src/Servant/API/Raw.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# OPTIONS_HADDOCK not-home #-} module Servant.API.Raw where import Data.Typeable (Typeable) diff --git a/servant/src/Servant/API/ReqBody.hs b/servant/src/Servant/API/ReqBody.hs index 29e6f5f2..672af912 100644 --- a/servant/src/Servant/API/ReqBody.hs +++ b/servant/src/Servant/API/ReqBody.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PolyKinds #-} +{-# OPTIONS_HADDOCK not-home #-} module Servant.API.ReqBody where import Data.Typeable (Typeable) diff --git a/servant/src/Servant/API/ResponseHeaders.hs b/servant/src/Servant/API/ResponseHeaders.hs index 3503dd46..1fcbd035 100644 --- a/servant/src/Servant/API/ResponseHeaders.hs +++ b/servant/src/Servant/API/ResponseHeaders.hs @@ -9,11 +9,13 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} #if !MIN_VERSION_base(4,8,0) {-# LANGUAGE OverlappingInstances #-} #endif +{-# OPTIONS_HADDOCK not-home #-} -- | This module provides facilities for adding headers to a response. -- @@ -22,14 +24,20 @@ -- The value is added to the header specified by the type (@Location@ in the -- example above). module Servant.API.ResponseHeaders - ( Headers - , getResponse - , getHeaders + ( Headers(..) , AddHeader(addHeader) + , BuildHeadersTo(buildHeadersTo) + , GetHeaders(getHeaders) + , HeaderValMap + , HList(..) ) where -import Data.ByteString.Char8 (pack) -import Data.ByteString.Conversion (ToByteString, toByteString') +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif +import Data.ByteString.Char8 as BS (pack, unlines, init) +import Data.ByteString.Conversion (ToByteString, toByteString', + FromByteString, fromByteString) import qualified Data.CaseInsensitive as CI import Data.Proxy import GHC.TypeLits (KnownSymbol, symbolVal) @@ -41,27 +49,102 @@ import Servant.API.Header (Header (..)) -- Instead, use 'addHeader'. data Headers ls a = Headers { getResponse :: a -- ^ The underlying value of a 'Headers' - , getHeaders :: [HTTP.Header] - -- ^ The list of header values of a 'Headers'. - -- These are guaranteed to correspond with the - -- first type of @Headers@ if constructed with - -- 'addHeader'. - } deriving (Eq, Show, Functor) + , getHeadersHList :: HList ls + -- ^ HList of headers. + } deriving (Functor) --- We need all these fundeps to save type inference -class AddHeader h v orig new - | h v orig -> new, new -> h, new -> v, new -> orig where - addHeader :: v -> orig -> new +data HList a where + HNil :: HList '[] + HCons :: Header h x -> HList xs -> HList (Header h x ': xs) + +type family HeaderValMap (f :: * -> *) (xs :: [*]) where + HeaderValMap f '[] = '[] + HeaderValMap f (Header h x ': xs) = Header h (f x) ': (HeaderValMap f xs) + + +class BuildHeadersTo hs where + buildHeadersTo :: [HTTP.Header] -> HList hs + -- ^ Note: if there are multiple occurences of a header in the argument, + -- the values are interspersed with commas before deserialization (see + -- ) instance #if MIN_VERSION_base(4,8,0) {-# OVERLAPPING #-} #endif - ( KnownSymbol h, ToByteString v - ) => AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where - addHeader a (Headers resp heads) = Headers resp ((headerName, toByteString' a) : heads) - where - headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h) + BuildHeadersTo '[] where + buildHeadersTo _ = HNil + +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPABLE #-} +#endif + ( FromByteString v, BuildHeadersTo xs, KnownSymbol h, Contains h xs ~ 'False + ) => BuildHeadersTo ((Header h v) ': xs) where + buildHeadersTo headers = + let wantedHeader = CI.mk . pack $ symbolVal (Proxy :: Proxy h) + matching = snd <$> filter (\(h, _) -> h == wantedHeader) headers + in case matching of + [] -> MissingHeader `HCons` buildHeadersTo headers + xs -> case fromByteString (BS.init $ BS.unlines xs) of + Nothing -> UndecodableHeader (BS.init $ BS.unlines xs) + `HCons` buildHeadersTo headers + Just h -> Header h `HCons` buildHeadersTo headers + +-- * Getting + +class GetHeaders ls where + getHeaders :: ls -> [HTTP.Header] + +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPING #-} +#endif + GetHeaders (HList '[]) where + getHeaders _ = [] + +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPABLE #-} +#endif + ( KnownSymbol h, ToByteString x, GetHeaders (HList xs) + ) => GetHeaders (HList (Header h x ': xs)) where + getHeaders hdrs = case hdrs of + Header val `HCons` rest -> (headerName , toByteString' val):getHeaders rest + UndecodableHeader h `HCons` rest -> (headerName, h) : getHeaders rest + MissingHeader `HCons` rest -> getHeaders rest + where headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h) + +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPING #-} +#endif + GetHeaders (Headers '[] a) where + getHeaders _ = [] + +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPABLE #-} +#endif + ( KnownSymbol h, GetHeaders (HList rest), ToByteString v + ) => GetHeaders (Headers (Header h v ': rest) a) where + getHeaders hs = getHeaders $ getHeadersHList hs + +-- * Adding + +-- We need all these fundeps to save type inference +class AddHeader h v orig new + | h v orig -> new, new -> h, new -> v, new -> orig where + addHeader :: v -> orig -> new -- ^ N.B.: The same header can't be added multiple times + + +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPING #-} +#endif + ( KnownSymbol h, ToByteString v, Contains h (fst ': rest) ~ 'False + ) => AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where + addHeader a (Headers resp heads) = Headers resp (HCons (Header a) heads) instance #if MIN_VERSION_base(4,8,0) @@ -70,10 +153,12 @@ instance ( KnownSymbol h, ToByteString v , new ~ (Headers '[Header h v] a) ) => AddHeader h v a new where - addHeader a resp = Headers resp [(headerName, toByteString' a)] - where - headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h) + addHeader a resp = Headers resp (HCons (Header a) HNil) +type family Contains x xs where + Contains x ((Header x a) ': xs) = 'True + Contains x ((Header y a) ': xs) = Contains x xs + Contains x '[] = 'False -- $setup -- >>> import Servant.API diff --git a/servant/src/Servant/API/Sub.hs b/servant/src/Servant/API/Sub.hs index 48f570a7..43e1c698 100644 --- a/servant/src/Servant/API/Sub.hs +++ b/servant/src/Servant/API/Sub.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeOperators #-} +{-# OPTIONS_HADDOCK not-home #-} module Servant.API.Sub ((:>)) where import Data.Typeable (Typeable) diff --git a/servant/src/Servant/Utils/Links.hs b/servant/src/Servant/Utils/Links.hs index 6d8d7f93..b1df40c0 100644 --- a/servant/src/Servant/Utils/Links.hs +++ b/servant/src/Servant/Utils/Links.hs @@ -8,6 +8,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_HADDOCK not-home #-} -- | Type safe generation of internal links. -- diff --git a/sources.txt b/sources.txt index d12c1275..a36345e5 100644 --- a/sources.txt +++ b/sources.txt @@ -4,3 +4,5 @@ servant-docs servant-jquery servant-server servant-examples +servant-blaze +servant-lucid