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-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
])

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

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

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

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

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

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

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

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

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

@ -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, "<no header sample provided>")
-- | 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) =

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

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

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)
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',

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

@ -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
-- <http://www.w3.org/Protocols/rfc2616/rfc2616-sec4.html#sec4.2 RFC2616 Sec 4.2>)
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

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

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

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

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