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-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index 8a187b0a..60c578ac 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -21,6 +21,9 @@ module Servant.Client , 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,7 +35,9 @@ 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.ResponseHeaders import Servant.API.ContentTypes import Servant.Common.BaseUrl import Servant.Common.Req @@ -133,10 +138,10 @@ instance (MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where 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 #-} @@ -146,6 +151,21 @@ instance 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', @@ -195,7 +215,7 @@ instance 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. @@ -208,6 +228,21 @@ instance 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 @@ -220,7 +255,7 @@ instance 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. @@ -233,6 +268,21 @@ instance 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 @@ -245,7 +295,7 @@ instance 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. @@ -258,6 +308,21 @@ instance 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', @@ -492,7 +557,7 @@ 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 req httpMethod host = do diff --git a/servant-client/src/Servant/Common/Req.hs b/servant-client/src/Servant/Common/Req.hs index 12dd88d9..3b458155 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 + headers = 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, headers, 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, headers, _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 (headers, 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..4cd84df1 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 @@ -105,6 +109,7 @@ server = serve api ( :<|> (\ name -> case name of Just "alice" -> return alice Just name -> left (400, name ++ " not found") + Nothing -> left (400, "missing parameter")) :<|> (\ names -> return (zipWith Person names [0..])) :<|> return @@ -116,7 +121,8 @@ server = serve api ( :<|> 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 +138,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 +158,8 @@ getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] :<|> getMatrixFlag :<|> getRawSuccess :<|> getRawFailure - :<|> getMultiple) + :<|> getMultiple + :<|> getRespHeaders) = client api type FailApi = @@ -218,7 +228,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 +237,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 -> diff --git a/servant-docs/example/greet.hs b/servant-docs/example/greet.hs index fc649607..3e7422d3 100644 --- a/servant-docs/example/greet.hs +++ b/servant-docs/example/greet.hs @@ -8,6 +8,7 @@ import Control.Lens import Data.Aeson import Data.Proxy +import Data.ByteString.Conversion import Data.String.Conversions import Data.Text (Text) import GHC.Generics @@ -53,14 +54,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 +88,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/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index 4422f710..8f195a28 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) @@ -33,11 +40,13 @@ import GHC.Generics import GHC.TypeLits import Servant.API import Servant.API.ContentTypes +import Servant.API.ResponseHeaders 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 +200,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 +215,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: @@ -371,34 +386,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 +614,7 @@ markdown api = unlines $ "#### Response:" : "" : ("- Status code " ++ show (resp ^. respStatus)) : + ("- Headers: " ++ show (resp ^. respHeaders)) : "" : formatTypes (resp ^. respTypes) ++ bodies @@ -630,7 +665,7 @@ instance HasDocs Delete where action' = action & response.respBody .~ [] & response.respStatus .~ 204 -instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts) +instance (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts) => HasDocs (Get cts a) where docsFor Proxy (endpoint, action) = single endpoint' action' @@ -641,6 +676,20 @@ instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts) t = Proxy :: Proxy cts p = Proxy :: Proxy a +instance (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 +699,7 @@ 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 (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts) => HasDocs (Post cts a) where docsFor Proxy (endpoint, action) = single endpoint' action' @@ -662,7 +711,22 @@ 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 (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 (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts) => HasDocs (Put cts a) where docsFor Proxy (endpoint, action) = single endpoint' action' @@ -674,6 +738,21 @@ instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts) t = Proxy :: Proxy cts p = Proxy :: Proxy a +instance (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 +835,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-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 942020a9..8db3fb92 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -46,7 +46,8 @@ 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) data ReqBodyState = Uncalled @@ -335,7 +336,8 @@ 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) @@ -450,7 +452,8 @@ 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) @@ -532,7 +535,8 @@ 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) @@ -612,7 +616,8 @@ 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) diff --git a/servant/Setup b/servant/Setup new file mode 100755 index 00000000..7e7b3990 Binary files /dev/null and b/servant/Setup differ 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..1c701689 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -78,8 +78,9 @@ 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 (Headers, getHeaders, + getHeadersHList, getResponse, + buildHeadersTo, addHeader) import Servant.API.Sub ((:>)) import Servant.Common.Text (FromText (..), ToText (..)) import Servant.Utils.Links (HasLink (..), IsElem, IsElem', 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..26c83d4e 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,22 @@ -- The value is added to the header specified by the type (@Location@ in the -- example above). module Servant.API.ResponseHeaders - ( Headers + ( Headers(..) + , addHeader + , BuildHeadersTo(buildHeadersTo) + , GetHeaders(getHeaders) + , getHeadersHList , getResponse - , getHeaders - , AddHeader(addHeader) + , 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 +51,101 @@ 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 (Header val `HCons` rest) = (headerName , toByteString' val):getHeaders rest + where headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h) + getHeaders (UndecodableHeader h `HCons` rest) = (headerName, h) : 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 +154,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. --