eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Headers for all

Browse source
This commit is contained in:
Julian K. Arni 2015-05-02 02:21:03 +01:00
parent 6253b8af1b
commit 5531ada22b
28 changed files with 412 additions and 99 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
scripts/shell.nix
View file

@ -13,10 +13,8 @@ let modifiedHaskellPackages = haskellngPackages.override {
../servant-jquery {}) "--ghc-options=-Werror"; ../servant-jquery {}) "--ghc-options=-Werror";
servant-docs = appendConfigureFlag (self.callPackage ../servant-docs servant-docs = appendConfigureFlag (self.callPackage ../servant-docs
{}) "--ghc-options=-Werror"; {}) "--ghc-options=-Werror";
servant-examples = appendConfigureFlag (self.callPackage ../servant-examples
{}) "--ghc-options=-Werror";
}; };
}; };
in modifiedHaskellPackages.ghcWithPackages ( p : with p ; [ 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
]) ])

30
scripts/start-sandbox.sh Executable file
View file

@ -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

77
servant-client/src/Servant/Client.hs
View file

@ -21,6 +21,9 @@ module Servant.Client
, module Servant.Common.BaseUrl , module Servant.Common.BaseUrl
) where ) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Control.Monad import Control.Monad
import Control.Monad.Trans.Either import Control.Monad.Trans.Either
import Data.ByteString.Lazy (ByteString) import Data.ByteString.Lazy (ByteString)
@ -32,7 +35,9 @@ import GHC.TypeLits
import Network.HTTP.Client (Response) import Network.HTTP.Client (Response)
import Network.HTTP.Media import Network.HTTP.Media
import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types as H
import qualified Network.HTTP.Types.Header as HTTP
import Servant.API import Servant.API
import Servant.API.ResponseHeaders
import Servant.API.ContentTypes import Servant.API.ContentTypes
import Servant.Common.BaseUrl import Servant.Common.BaseUrl
import Servant.Common.Req import Servant.Common.Req
@ -133,10 +138,10 @@ instance
(MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where (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 = 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 -- | If you have a 'Get xs ()' endpoint, the client expects a 204 No Content
-- HTTP header. -- HTTP status.
instance instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-} {-# OVERLAPPING #-}
@ -146,6 +151,21 @@ instance
clientWithRoute Proxy req host = clientWithRoute Proxy req host =
performRequestNoBody H.methodGet req [204] 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, -- | If you use a 'Header' in one of your endpoints in your API,
-- the corresponding querying function will automatically take -- the corresponding querying function will automatically take
-- an additional argument of the type specified by your 'Header', -- 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 type Client' (Post (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
clientWithRoute Proxy req uri = 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 -- | If you have a 'Post xs ()' endpoint, the client expects a 204 No Content
-- HTTP header. -- HTTP header.
@ -208,6 +228,21 @@ instance
clientWithRoute Proxy req host = clientWithRoute Proxy req host =
void $ performRequestNoBody H.methodPost req [204] 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 -- | If you have a 'Put' endpoint in your API, the client
-- side querying function that is created when calling 'client' -- side querying function that is created when calling 'client'
-- will just require an argument that specifies the scheme, host -- 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 type Client' (Put (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
clientWithRoute Proxy req host = 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 -- | If you have a 'Put xs ()' endpoint, the client expects a 204 No Content
-- HTTP header. -- HTTP header.
@ -233,6 +268,21 @@ instance
clientWithRoute Proxy req host = clientWithRoute Proxy req host =
void $ performRequestNoBody H.methodPut req [204] 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 -- | If you have a 'Patch' endpoint in your API, the client
-- side querying function that is created when calling 'client' -- side querying function that is created when calling 'client'
-- will just require an argument that specifies the scheme, host -- 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 type Client' (Patch (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
clientWithRoute Proxy req host = 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 -- | If you have a 'Patch xs ()' endpoint, the client expects a 204 No Content
-- HTTP header. -- HTTP header.
@ -258,6 +308,21 @@ instance
clientWithRoute Proxy req host = clientWithRoute Proxy req host =
void $ performRequestNoBody H.methodPatch req [204] 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, -- | If you use a 'QueryParam' in one of your endpoints in your API,
-- the corresponding querying function will automatically take -- the corresponding querying function will automatically take
-- an additional argument of the type specified by your 'QueryParam', -- 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 -- | Pick a 'Method' and specify where the server you want to query is. You get
-- back the full `Response`. -- back the full `Response`.
instance HasClient Raw where 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 clientWithRoute Proxy req httpMethod host = do

23
servant-client/src/Servant/Common/Req.hs
View file

@ -22,6 +22,7 @@ import Network.HTTP.Client hiding (Proxy)
import Network.HTTP.Client.TLS import Network.HTTP.Client.TLS
import Network.HTTP.Media import Network.HTTP.Media
import Network.HTTP.Types import Network.HTTP.Types
import qualified Network.HTTP.Types.Header as HTTP
import Network.URI import Network.URI
import Servant.API.ContentTypes import Servant.API.ContentTypes
import Servant.Common.BaseUrl import Servant.Common.BaseUrl
@ -136,7 +137,9 @@ displayHttpRequest :: Method -> String
displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request" 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 performRequest reqMethod req isWantedStatus reqHost = do
partialRequest <- liftIO $ reqToRequest req reqHost partialRequest <- liftIO $ reqToRequest req reqHost
@ -154,6 +157,7 @@ performRequest reqMethod req isWantedStatus reqHost = do
Right response -> do Right response -> do
let status = Client.responseStatus response let status = Client.responseStatus response
body = Client.responseBody response body = Client.responseBody response
headers = Client.responseHeaders response
status_code = statusCode status status_code = statusCode status
ct <- case lookup "Content-Type" $ Client.responseHeaders response of ct <- case lookup "Content-Type" $ Client.responseHeaders response of
Nothing -> pure $ "application"//"octet-stream" Nothing -> pure $ "application"//"octet-stream"
@ -162,20 +166,19 @@ performRequest reqMethod req isWantedStatus reqHost = do
Just t' -> pure t' Just t' -> pure t'
unless (isWantedStatus status_code) $ unless (isWantedStatus status_code) $
left $ FailureResponse status ct body left $ FailureResponse status ct body
return (status_code, body, ct, response) return (status_code, body, ct, headers, response)
performRequestCT :: MimeUnrender ct result => 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 performRequestCT ct reqMethod req wantedStatus reqHost = do
let acceptCT = contentType ct let acceptCT = contentType ct
(_status, respBody, respCT, _response) <- (_status, respBody, respCT, headers, _response) <-
performRequest reqMethod (req { reqAccept = [acceptCT] }) (`elem` wantedStatus) reqHost performRequest reqMethod (req { reqAccept = [acceptCT] }) (`elem` wantedStatus) reqHost
unless (matches respCT (acceptCT)) $ unless (matches respCT (acceptCT)) $ left $ UnsupportedContentType respCT respBody
left $ UnsupportedContentType respCT respBody case mimeUnrender ct respBody of
either Left err -> left $ DecodeFailure err respCT respBody
(left . (\s -> DecodeFailure s respCT respBody)) Right val -> return (headers, val)
return
(mimeUnrender ct respBody)
performRequestNoBody :: Method -> Req -> [Int] -> BaseUrl -> EitherT ServantError IO () performRequestNoBody :: Method -> Req -> [Int] -> BaseUrl -> EitherT ServantError IO ()
performRequestNoBody reqMethod req wantedStatus reqHost = do performRequestNoBody reqMethod req wantedStatus reqHost = do

32
servant-client/test/Servant/ClientSpec.hs
View file

@ -7,7 +7,7 @@
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fcontext-stack=25 #-} {-# OPTIONS_GHC -fcontext-stack=100 #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
module Servant.ClientSpec where module Servant.ClientSpec where
@ -28,7 +28,8 @@ import qualified Data.Text as T
import GHC.Generics import GHC.Generics
import qualified Network.HTTP.Client as C import qualified Network.HTTP.Client as C
import Network.HTTP.Media 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.Socket
import Network.Wai hiding (Response) import Network.Wai hiding (Response)
import Network.Wai.Handler.Warp import Network.Wai.Handler.Warp
@ -74,6 +75,8 @@ instance Eq C.HttpException where
alice :: Person alice :: Person
alice = Person "Alice" 42 alice = Person "Alice" 42
type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
type Api = type Api =
"get" :> Get '[JSON] Person "get" :> Get '[JSON] Person
:<|> "delete" :> Delete :<|> "delete" :> Delete
@ -93,6 +96,7 @@ type Api =
QueryFlag "third" :> QueryFlag "third" :>
ReqBody '[JSON] [(String, [Rational])] :> ReqBody '[JSON] [(String, [Rational])] :>
Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])]) Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])
:<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)
api :: Proxy Api api :: Proxy Api
api = Proxy api = Proxy
@ -105,6 +109,7 @@ server = serve api (
:<|> (\ name -> case name of :<|> (\ name -> case name of
Just "alice" -> return alice Just "alice" -> return alice
Just name -> left (400, name ++ " not found") Just name -> left (400, name ++ " not found")
Nothing -> left (400, "missing parameter")) Nothing -> left (400, "missing parameter"))
:<|> (\ names -> return (zipWith Person names [0..])) :<|> (\ names -> return (zipWith Person names [0..]))
:<|> return :<|> return
@ -116,7 +121,8 @@ server = serve api (
:<|> return :<|> return
:<|> (\ _request respond -> respond $ responseLBS ok200 [] "rawSuccess") :<|> (\ _request respond -> respond $ responseLBS ok200 [] "rawSuccess")
:<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure") :<|> (\ _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 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 getMatrixParam :: Maybe String -> BaseUrl -> EitherT ServantError IO Person
getMatrixParams :: [String] -> BaseUrl -> EitherT ServantError IO [Person] getMatrixParams :: [String] -> BaseUrl -> EitherT ServantError IO [Person]
getMatrixFlag :: Bool -> BaseUrl -> EitherT ServantError IO Bool getMatrixFlag :: Bool -> BaseUrl -> EitherT ServantError IO Bool
getRawSuccess :: Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, C.Response ByteString) getRawSuccess :: Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString,
getRawFailure :: Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, C.Response 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])] getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
-> BaseUrl -> BaseUrl
-> EitherT ServantError IO (String, Maybe Int, Bool, [(String, [Rational])]) -> EitherT ServantError IO (String, Maybe Int, Bool, [(String, [Rational])])
getRespHeaders :: BaseUrl -> EitherT ServantError IO (Headers TestHeaders Bool)
( getGet ( getGet
:<|> getDelete :<|> getDelete
:<|> getCapture :<|> getCapture
@ -149,7 +158,8 @@ getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
:<|> getMatrixFlag :<|> getMatrixFlag
:<|> getRawSuccess :<|> getRawSuccess
:<|> getRawFailure :<|> getRawFailure
:<|> getMultiple) :<|> getMultiple
:<|> getRespHeaders)
= client api = client api
type FailApi = type FailApi =
@ -218,7 +228,7 @@ spec = do
res <- runEitherT (getRawSuccess methodGet host) res <- runEitherT (getRawSuccess methodGet host)
case res of case res of
Left e -> assertFailure $ show e 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") (code, body, ct) `shouldBe` (200, "rawSuccess", "application"//"octet-stream")
C.responseBody response `shouldBe` body C.responseBody response `shouldBe` body
C.responseStatus response `shouldBe` ok200 C.responseStatus response `shouldBe` ok200
@ -227,11 +237,17 @@ spec = do
res <- runEitherT (getRawFailure methodGet host) res <- runEitherT (getRawFailure methodGet host)
case res of case res of
Left e -> assertFailure $ show e 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") (code, body, ct) `shouldBe` (400, "rawFailure", "application"//"octet-stream")
C.responseBody response `shouldBe` body C.responseBody response `shouldBe` body
C.responseStatus response `shouldBe` badRequest400 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 modifyMaxSuccess (const 20) $ do
it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $
property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body -> property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->

12
servant-docs/example/greet.hs
View file

@ -8,6 +8,7 @@
import Control.Lens import Control.Lens
import Data.Aeson import Data.Aeson
import Data.Proxy import Data.Proxy
import Data.ByteString.Conversion
import Data.String.Conversions import Data.String.Conversions
import Data.Text (Text) import Data.Text (Text)
import GHC.Generics import GHC.Generics
@ -53,14 +54,17 @@ instance ToParam (MatrixParam "lang" String) where
"Get the greeting message selected language. Default is en." "Get the greeting message selected language. Default is en."
Normal Normal
instance ToSample Greet where instance ToSample Greet Greet where
toSample = Just $ Greet "Hello, haskeller!" toSample _ = Just $ Greet "Hello, haskeller!"
toSamples = toSamples _ =
[ ("If you use ?capital=true", Greet "HELLO, HASKELLER") [ ("If you use ?capital=true", Greet "HELLO, HASKELLER")
, ("If you use ?capital=false", 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 -- We define some introductory sections, these will appear at the top of the
-- documentation. -- documentation.
-- --
@ -84,7 +88,7 @@ type TestApi =
-- POST /greet with a Greet as JSON in the request body, -- POST /greet with a Greet as JSON in the request body,
-- returns a Greet as JSON -- 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 -- DELETE /greet/:greetid
:<|> "greet" :> Capture "greetid" Text :> Delete :<|> "greet" :> Capture "greetid" Text :> Delete

4
servant-docs/servant-docs.cabal
View file

@ -32,8 +32,11 @@ library
build-depends: build-depends:
base >=4.7 && <5 base >=4.7 && <5
, bytestring , bytestring
, bytestring-conversion
, case-insensitive
, hashable , hashable
, http-media >= 0.6 , http-media >= 0.6
, http-types >= 0.7
, lens , lens
, servant >= 0.2.1 , servant >= 0.2.1
, string-conversions , string-conversions
@ -50,6 +53,7 @@ executable greet-docs
build-depends: build-depends:
base base
, aeson , aeson
, bytestring-conversion
, lens , lens
, servant , servant
, servant-docs , servant-docs

146
servant-docs/src/Servant/Docs/Internal.hs
View file

@ -1,17 +1,22 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TupleSections #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
#if !MIN_VERSION_base(4,8,0)
{-# LANGUAGE OverlappingInstances #-}
#endif
module Servant.Docs.Internal where module Servant.Docs.Internal where
#if !MIN_VERSION_base(4,8,0) #if !MIN_VERSION_base(4,8,0)
@ -19,6 +24,7 @@ import Control.Applicative
#endif #endif
import Control.Lens import Control.Lens
import Data.ByteString.Lazy.Char8 (ByteString) import Data.ByteString.Lazy.Char8 (ByteString)
import qualified Data.CaseInsensitive as CI
import Data.Hashable import Data.Hashable
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import Data.List import Data.List
@ -26,6 +32,7 @@ import Data.Maybe
import Data.Monoid import Data.Monoid
import Data.Ord (comparing) import Data.Ord (comparing)
import Data.Proxy import Data.Proxy
import Data.ByteString.Conversion (ToByteString, toByteString)
import Data.String.Conversions import Data.String.Conversions
import Data.Text (Text, pack, unpack) import Data.Text (Text, pack, unpack)
import GHC.Exts (Constraint) import GHC.Exts (Constraint)
@ -33,11 +40,13 @@ import GHC.Generics
import GHC.TypeLits import GHC.TypeLits
import Servant.API import Servant.API
import Servant.API.ContentTypes import Servant.API.ContentTypes
import Servant.API.ResponseHeaders
import Servant.Utils.Links import Servant.Utils.Links
import qualified Data.HashMap.Strict as HM import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T import qualified Data.Text as T
import qualified Network.HTTP.Media as M import qualified Network.HTTP.Media as M
import qualified Network.HTTP.Types as HTTP
-- | Supported HTTP request methods -- | Supported HTTP request methods
data Method = DocDELETE -- ^ the DELETE method 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\" }")] -- > λ> defResponse & respStatus .~ 204 & respBody .~ [("If everything goes well", "{ \"status\": \"ok\" }")]
-- > Response {_respStatus = 204, _respTypes = [], _respBody = [("If everything goes well", "{ \"status\": \"ok\" }")]} -- > Response {_respStatus = 204, _respTypes = [], _respBody = [("If everything goes well", "{ \"status\": \"ok\" }")]}
data Response = Response data Response = Response
{ _respStatus :: Int { _respStatus :: Int
, _respTypes :: [M.MediaType] , _respTypes :: [M.MediaType]
, _respBody :: [(Text, M.MediaType, ByteString)] , _respBody :: [(Text, M.MediaType, ByteString)]
, _respHeaders :: [HTTP.Header]
} deriving (Eq, Ord, Show) } deriving (Eq, Ord, Show)
-- | Default response: status code 200, no response body. -- | Default response: status code 200, no response body.
@ -205,7 +215,12 @@ data Response = Response
-- > λ> defResponse & respStatus .~ 204 & respBody .~ Just "[]" -- > λ> defResponse & respStatus .~ 204 & respBody .~ Just "[]"
-- > Response {_respStatus = 204, _respBody = Just "[]"} -- > Response {_respStatus = 204, _respBody = Just "[]"}
defResponse :: Response defResponse :: Response
defResponse = Response 200 [] [] defResponse = Response
{ _respStatus = 200
, _respTypes = []
, _respBody = []
, _respHeaders = []
}
-- | A datatype that represents everything that can happen -- | A datatype that represents everything that can happen
-- at an endpoint, with its lenses: -- at an endpoint, with its lenses:
@ -371,34 +386,53 @@ class HasDocs layout where
-- 'toSample': it lets you specify different responses along with -- 'toSample': it lets you specify different responses along with
-- some context (as 'Text') that explains when you're supposed to -- some context (as 'Text') that explains when you're supposed to
-- get the corresponding response. -- get the corresponding response.
class ToSample a where class ToSample a b | a -> b where
{-# MINIMAL (toSample | toSamples) #-} {-# MINIMAL (toSample | toSamples) #-}
toSample :: Maybe a toSample :: Proxy a -> Maybe b
toSample = snd <$> listToMaybe samples toSample _ = snd <$> listToMaybe samples
where samples = toSamples :: [(Text, a)] where samples = toSamples (Proxy :: Proxy a)
toSamples :: [(Text, a)] toSamples :: Proxy a -> [(Text, b)]
toSamples = maybe [] (return . ("",)) s toSamples _ = maybe [] (return . ("",)) s
where s = toSample :: Maybe a 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, "<no header sample provided>")
-- | Synthesise a sample value of a type, encoded in the specified media types. -- | Synthesise a sample value of a type, encoded in the specified media types.
sampleByteString 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 ctypes
-> Proxy a -> Proxy a
-> [(M.MediaType, ByteString)] -> [(M.MediaType, ByteString)]
sampleByteString ctypes@Proxy Proxy = 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 -- | Synthesise a list of sample values of a particular type, encoded in the
-- specified media types. -- specified media types.
sampleByteStrings 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 ctypes
-> Proxy a -> Proxy a
-> [(Text, M.MediaType, ByteString)] -> [(Text, M.MediaType, ByteString)]
sampleByteStrings ctypes@Proxy Proxy = sampleByteStrings ctypes@Proxy Proxy =
let samples = toSamples :: [(Text, a)] let samples = toSamples (Proxy :: Proxy a)
enc (t, s) = uncurry (t,,) <$> allMimeRender ctypes s enc (t, s) = uncurry (t,,) <$> allMimeRender ctypes s
in concatMap enc samples in concatMap enc samples
@ -580,6 +614,7 @@ markdown api = unlines $
"#### Response:" : "#### Response:" :
"" : "" :
("- Status code " ++ show (resp ^. respStatus)) : ("- Status code " ++ show (resp ^. respStatus)) :
("- Headers: " ++ show (resp ^. respHeaders)) :
"" : "" :
formatTypes (resp ^. respTypes) ++ formatTypes (resp ^. respTypes) ++
bodies bodies
@ -630,7 +665,7 @@ instance HasDocs Delete where
action' = action & response.respBody .~ [] action' = action & response.respBody .~ []
& response.respStatus .~ 204 & 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 => HasDocs (Get cts a) where
docsFor Proxy (endpoint, action) = docsFor Proxy (endpoint, action) =
single endpoint' action' single endpoint' action'
@ -641,6 +676,20 @@ instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
t = Proxy :: Proxy cts t = Proxy :: Proxy cts
p = Proxy :: Proxy a 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) instance (KnownSymbol sym, HasDocs sublayout)
=> HasDocs (Header sym a :> sublayout) where => HasDocs (Header sym a :> sublayout) where
docsFor Proxy (endpoint, action) = docsFor Proxy (endpoint, action) =
@ -650,7 +699,7 @@ instance (KnownSymbol sym, HasDocs sublayout)
action' = over headers (|> headername) action action' = over headers (|> headername) action
headername = pack $ symbolVal (Proxy :: Proxy sym) 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 => HasDocs (Post cts a) where
docsFor Proxy (endpoint, action) = docsFor Proxy (endpoint, action) =
single endpoint' action' single endpoint' action'
@ -662,7 +711,22 @@ instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
t = Proxy :: Proxy cts t = Proxy :: Proxy cts
p = Proxy :: Proxy a 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 => HasDocs (Put cts a) where
docsFor Proxy (endpoint, action) = docsFor Proxy (endpoint, action) =
single endpoint' action' single endpoint' action'
@ -674,6 +738,21 @@ instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
t = Proxy :: Proxy cts t = Proxy :: Proxy cts
p = Proxy :: Proxy a 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) instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout)
=> HasDocs (QueryParam sym a :> sublayout) where => 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 -- example data. However, there's no reason to believe that the instances of
-- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that -- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that
-- both are even defined) for any particular type. -- 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 => HasDocs (ReqBody cts a :> sublayout) where
docsFor Proxy (endpoint, action) = docsFor Proxy (endpoint, action) =

15
servant-server/src/Servant/Server/Internal.hs
View file

@ -46,7 +46,8 @@ import Servant.API ((:<|>) (..), (:>), Capture,
import Servant.API.ContentTypes (AcceptHeader (..), import Servant.API.ContentTypes (AcceptHeader (..),
AllCTRender (..), AllCTRender (..),
AllCTUnrender (..)) AllCTUnrender (..))
import Servant.API.ResponseHeaders (Headers, getResponse, getHeaders) import Servant.API.ResponseHeaders (Headers, getResponse, GetHeaders,
getHeaders)
import Servant.Common.Text (FromText, fromText) import Servant.Common.Text (FromText, fromText)
data ReqBodyState = Uncalled data ReqBodyState = Uncalled
@ -335,7 +336,8 @@ instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-} {-# OVERLAPPING #-}
#endif #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)
@ -450,7 +452,8 @@ instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-} {-# OVERLAPPING #-}
#endif #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)
@ -532,7 +535,8 @@ instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-} {-# OVERLAPPING #-}
#endif #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)
@ -612,7 +616,8 @@ instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-} {-# OVERLAPPING #-}
#endif #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)

BIN
servant/Setup Executable file
View file

Binary file not shown.

2
servant/shell.nix Normal file
View file

@ -0,0 +1,2 @@
with (import <nixpkgs> {}).pkgs;
(haskellngPackages.callPackage ./. {}).env

5
servant/src/Servant/API.hs
View file

@ -78,8 +78,9 @@ import Servant.API.QueryParam (QueryFlag, QueryParam,
QueryParams) QueryParams)
import Servant.API.Raw (Raw) import Servant.API.Raw (Raw)
import Servant.API.ReqBody (ReqBody) import Servant.API.ReqBody (ReqBody)
import Servant.API.ResponseHeaders ( Headers, getHeaders, getResponse import Servant.API.ResponseHeaders (Headers, getHeaders,
, AddHeader(addHeader) ) getHeadersHList, getResponse,
buildHeadersTo, addHeader)
import Servant.API.Sub ((:>)) import Servant.API.Sub ((:>))
import Servant.Common.Text (FromText (..), ToText (..)) import Servant.Common.Text (FromText (..), ToText (..))
import Servant.Utils.Links (HasLink (..), IsElem, IsElem', import Servant.Utils.Links (HasLink (..), IsElem, IsElem',

1
servant/src/Servant/API/Alternative.hs
View file

@ -1,6 +1,7 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Alternative ((:<|>)(..)) where module Servant.API.Alternative ((:<|>)(..)) where
#if !MIN_VERSION_base(4,8,0) #if !MIN_VERSION_base(4,8,0)

1
servant/src/Servant/API/Capture.hs
View file

@ -1,6 +1,7 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Capture (Capture) where module Servant.API.Capture (Capture) where
import Data.Typeable (Typeable) import Data.Typeable (Typeable)

1
servant/src/Servant/API/ContentTypes.hs
View file

@ -10,6 +10,7 @@
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_HADDOCK not-home #-}
-- | A collection of basic Content-Types (also known as Internet Media -- | A collection of basic Content-Types (also known as Internet Media
-- Types, or MIME types). Additionally, this module provides classes that -- Types, or MIME types). Additionally, this module provides classes that

1
servant/src/Servant/API/Delete.hs
View file

@ -1,4 +1,5 @@
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Delete (Delete) where module Servant.API.Delete (Delete) where
import Data.Typeable ( Typeable ) import Data.Typeable ( Typeable )

1
servant/src/Servant/API/Get.hs
View file

@ -1,6 +1,7 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE KindSignatures #-} {-# LANGUAGE KindSignatures #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Get (Get) where module Servant.API.Get (Get) where
import Data.Typeable (Typeable) import Data.Typeable (Typeable)

11
servant/src/Servant/API/Header.hs
View file

@ -1,10 +1,13 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Header where module Servant.API.Header where
import Data.Typeable (Typeable) import Data.ByteString (ByteString)
import GHC.TypeLits (Symbol) import Data.Typeable (Typeable)
import GHC.TypeLits (Symbol)
-- | Extract the given header's value as a value of type @a@. -- | Extract the given header's value as a value of type @a@.
-- --
-- Example: -- Example:
@ -14,7 +17,9 @@ import GHC.TypeLits (Symbol)
-- >>> -- GET /view-my-referer -- >>> -- GET /view-my-referer
-- >>> type MyApi = "view-my-referer" :> Header "from" Referer :> Get '[JSON] Referer -- >>> type MyApi = "view-my-referer" :> Header "from" Referer :> Get '[JSON] Referer
data Header (sym :: Symbol) a = Header a data Header (sym :: Symbol) a = Header a
deriving Typeable | MissingHeader
| UndecodableHeader ByteString
deriving (Typeable, Eq, Show, Functor)
-- $setup -- $setup
-- >>> import Servant.API -- >>> import Servant.API

1
servant/src/Servant/API/MatrixParam.hs
View file

@ -1,6 +1,7 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.MatrixParam (MatrixFlag, MatrixParam, MatrixParams) where module Servant.API.MatrixParam (MatrixFlag, MatrixParam, MatrixParams) where
import Data.Typeable (Typeable) import Data.Typeable (Typeable)

1
servant/src/Servant/API/Patch.hs
View file

@ -1,6 +1,7 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE KindSignatures #-} {-# LANGUAGE KindSignatures #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Patch (Patch) where module Servant.API.Patch (Patch) where
import Data.Typeable (Typeable) import Data.Typeable (Typeable)

1
servant/src/Servant/API/Post.hs
View file

@ -1,6 +1,7 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE KindSignatures #-} {-# LANGUAGE KindSignatures #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Post (Post) where module Servant.API.Post (Post) where
import Data.Typeable (Typeable) import Data.Typeable (Typeable)

5
servant/src/Servant/API/Put.hs
View file

@ -1,6 +1,7 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE KindSignatures #-} {-# LANGUAGE KindSignatures #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Put (Put) where module Servant.API.Put (Put) where
import Data.Typeable ( Typeable ) import Data.Typeable ( Typeable )

1
servant/src/Servant/API/QueryParam.hs
View file

@ -2,6 +2,7 @@
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.QueryParam (QueryFlag, QueryParam, QueryParams) where module Servant.API.QueryParam (QueryFlag, QueryParam, QueryParams) where
import Data.Typeable (Typeable) import Data.Typeable (Typeable)

1
servant/src/Servant/API/Raw.hs
View file

@ -1,4 +1,5 @@
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Raw where module Servant.API.Raw where
import Data.Typeable (Typeable) import Data.Typeable (Typeable)

1
servant/src/Servant/API/ReqBody.hs
View file

@ -1,6 +1,7 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.ReqBody where module Servant.API.ReqBody where
import Data.Typeable (Typeable) import Data.Typeable (Typeable)

132
servant/src/Servant/API/ResponseHeaders.hs
View file

@ -9,11 +9,13 @@
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
#if !MIN_VERSION_base(4,8,0) #if !MIN_VERSION_base(4,8,0)
{-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE OverlappingInstances #-}
#endif #endif
{-# OPTIONS_HADDOCK not-home #-}
-- | This module provides facilities for adding headers to a response. -- | 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 -- The value is added to the header specified by the type (@Location@ in the
-- example above). -- example above).
module Servant.API.ResponseHeaders module Servant.API.ResponseHeaders
( Headers ( Headers(..)
, addHeader
, BuildHeadersTo(buildHeadersTo)
, GetHeaders(getHeaders)
, getHeadersHList
, getResponse , getResponse
, getHeaders , HeaderValMap
, AddHeader(addHeader) , HList(..)
) where ) where
import Data.ByteString.Char8 (pack) #if !MIN_VERSION_base(4,8,0)
import Data.ByteString.Conversion (ToByteString, toByteString') 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 qualified Data.CaseInsensitive as CI
import Data.Proxy import Data.Proxy
import GHC.TypeLits (KnownSymbol, symbolVal) import GHC.TypeLits (KnownSymbol, symbolVal)
@ -41,27 +51,101 @@ import Servant.API.Header (Header (..))
-- Instead, use 'addHeader'. -- Instead, use 'addHeader'.
data Headers ls a = Headers { getResponse :: a data Headers ls a = Headers { getResponse :: a
-- ^ The underlying value of a 'Headers' -- ^ The underlying value of a 'Headers'
, getHeaders :: [HTTP.Header] , getHeadersHList :: HList ls
-- ^ The list of header values of a 'Headers'. -- ^ HList of headers.
-- These are guaranteed to correspond with the } deriving (Functor)
-- first type of @Headers@ if constructed with
-- 'addHeader'.
} deriving (Eq, Show, Functor)
-- We need all these fundeps to save type inference data HList a where
class AddHeader h v orig new HNil :: HList '[]
| h v orig -> new, new -> h, new -> v, new -> orig where HCons :: Header h x -> HList xs -> HList (Header h x ': xs)
addHeader :: v -> orig -> new
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
-- <http://www.w3.org/Protocols/rfc2616/rfc2616-sec4.html#sec4.2 RFC2616 Sec 4.2>)
instance instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-} {-# OVERLAPPING #-}
#endif #endif
( KnownSymbol h, ToByteString v BuildHeadersTo '[] where
) => AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where buildHeadersTo _ = HNil
addHeader a (Headers resp heads) = Headers resp ((headerName, toByteString' a) : heads)
where instance
headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h) #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 instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
@ -70,10 +154,12 @@ instance
( KnownSymbol h, ToByteString v ( KnownSymbol h, ToByteString v
, new ~ (Headers '[Header h v] a) , new ~ (Headers '[Header h v] a)
) => AddHeader h v a new where ) => AddHeader h v a new where
addHeader a resp = Headers resp [(headerName, toByteString' a)] addHeader a resp = Headers resp (HCons (Header a) HNil)
where
headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h)
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 -- $setup
-- >>> import Servant.API -- >>> import Servant.API

1
servant/src/Servant/API/Sub.hs
View file

@ -1,6 +1,7 @@
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Sub ((:>)) where module Servant.API.Sub ((:>)) where
import Data.Typeable (Typeable) import Data.Typeable (Typeable)

1
servant/src/Servant/Utils/Links.hs
View file

@ -8,6 +8,7 @@
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_HADDOCK not-home #-}
-- | Type safe generation of internal links. -- | Type safe generation of internal links.
-- --