Merge branch 'pr'

This commit is contained in:
Sönke Hahn 2016-04-01 18:46:15 +08:00
commit 2fb981f02a
5 changed files with 172 additions and 198 deletions

View file

@ -15,14 +15,13 @@ need to have some language extensions and imports:
module Client where
import Control.Monad.Trans.Except
import Control.Monad.Trans.Except (ExceptT, runExceptT)
import Data.Aeson
import Data.Proxy
import GHC.Generics
import Network.HTTP.Client (Manager, newManager, defaultManagerSettings)
import Servant.API
import Servant.Client
import System.IO.Unsafe
```
Also, we need examples for some domain specific data types:
@ -72,40 +71,34 @@ What we are going to get with **servant-client** here is 3 functions, one to que
``` haskell
position :: Int -- ^ value for "x"
-> Int -- ^ value for "y"
-> Manager -- ^ the HTTP client to use
-> BaseUrl -- ^ the URL at which the API can be found
-> ExceptT ServantError IO Position
hello :: Maybe String -- ^ an optional value for "name"
-> Manager -- ^ the HTTP client to use
-> BaseUrl -- ^ the URL at which the API can be found
-> ExceptT ServantError IO HelloMessage
marketing :: ClientInfo -- ^ value for the request body
-> Manager -- ^ the HTTP client to use
-> BaseUrl -- ^ the URL at which the API can be found
-> ExceptT ServantError IO Email
```
Each function makes available as an argument any value that the response may
depend on, as evidenced in the API type. How do we get these functions? By calling
the function `client`. It takes three arguments:
the function `client`. It takes one argument:
- a `Proxy` to your API,
- a `BaseUrl`, consisting of the protocol, the host, the port and an optional subpath --
this basically tells `client` where the service that you want to query is hosted,
- a `Manager`, (from [http-client](http://hackage.haskell.org/package/http-client))
which manages http connections.
``` haskell
api :: Proxy API
api = Proxy
{-# NOINLINE __manager #-}
__manager :: Manager
__manager = unsafePerformIO $ newManager defaultManagerSettings
position :<|> hello :<|> marketing =
client api (BaseUrl Http "localhost" 8081 "") __manager
position :<|> hello :<|> marketing = client api
```
(Yes, the usage of `unsafePerformIO` is very ugly, we know. Hopefully soon it'll
be possible to do without.)
As you can see in the code above, we just "pattern match our way" to these functions. If we try to derive less or more functions than there are endpoints in the API, we obviously get an error. The `BaseUrl` value there is just:
``` haskell ignore
@ -127,16 +120,17 @@ data BaseUrl = BaseUrl
That's it. Let's now write some code that uses our client functions.
``` haskell
queries :: ExceptT ServantError IO (Position, HelloMessage, Email)
queries = do
pos <- position 10 10
message <- hello (Just "servant")
em <- marketing (ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"])
queries :: Manager -> BaseUrl -> ExceptT ServantError IO (Position, HelloMessage, Email)
queries manager baseurl = do
pos <- position 10 10 manager baseurl
message <- hello (Just "servant") manager baseurl
em <- marketing (ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"]) manager baseurl
return (pos, message, em)
run :: IO ()
run = do
res <- runExceptT queries
manager <- newManager defaultManagerSettings
res <- runExceptT (queries manager (BaseUrl Http "localhost" 8081 ""))
case res of
Left err -> putStrLn $ "Error: " ++ show err
Right (pos, message, em) -> do

View file

@ -1,3 +1,6 @@
* `client` no longer takes `BaseUrl` and `Manager` arguments. Instead, each function returned by `client` requires these two arguments.
0.5
----

View file

@ -27,14 +27,13 @@ module Servant.Client
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Control.Monad.Trans.Except
import Data.ByteString.Lazy (ByteString)
import Data.List
import Data.Proxy
import Data.String.Conversions
import Data.Text (unpack)
import GHC.TypeLits
import Network.HTTP.Client (Response, Manager)
import Network.HTTP.Client (Manager, Response)
import Network.HTTP.Media
import qualified Network.HTTP.Types as H
import qualified Network.HTTP.Types.Header as HTTP
@ -54,19 +53,18 @@ import Servant.Common.Req
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
-- > getAllBooks :: ExceptT String IO [Book]
-- > postNewBook :: Book -> ExceptT String IO Book
-- > (getAllBooks :<|> postNewBook) = client myApi host manager
-- > where host = BaseUrl Http "localhost" 8080
client :: HasClient layout => Proxy layout -> BaseUrl -> Manager -> Client layout
client p baseurl = clientWithRoute p defReq baseurl
-- > getAllBooks :: Manager -> BaseUrl -> ClientM [Book]
-- > postNewBook :: Book -> Manager -> BaseUrl -> ClientM Book
-- > (getAllBooks :<|> postNewBook) = client myApi
client :: HasClient layout => Proxy layout -> Client layout
client p = clientWithRoute p defReq
-- | This class lets us define how each API combinator
-- influences the creation of an HTTP request. It's mostly
-- an internal class, you can just use 'client'.
class HasClient layout where
type Client layout :: *
clientWithRoute :: Proxy layout -> Req -> BaseUrl -> Manager -> Client layout
clientWithRoute :: Proxy layout -> Req -> Client layout
-- | A client querying function for @a ':<|>' b@ will actually hand you
@ -79,15 +77,14 @@ class HasClient layout where
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
-- > getAllBooks :: ExceptT String IO [Book]
-- > postNewBook :: Book -> ExceptT String IO Book
-- > (getAllBooks :<|> postNewBook) = client myApi host manager
-- > where host = BaseUrl Http "localhost" 8080
-- > getAllBooks :: Manager -> BaseUrl -> ClientM [Book]
-- > postNewBook :: Book -> Manager -> BaseUrl -> ClientM Book
-- > (getAllBooks :<|> postNewBook) = client myApi
instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
type Client (a :<|> b) = Client a :<|> Client b
clientWithRoute Proxy req baseurl manager =
clientWithRoute (Proxy :: Proxy a) req baseurl manager :<|>
clientWithRoute (Proxy :: Proxy b) req baseurl manager
clientWithRoute Proxy req =
clientWithRoute (Proxy :: Proxy a) req :<|>
clientWithRoute (Proxy :: Proxy b) req
-- | If you use a 'Capture' in one of your endpoints in your API,
-- the corresponding querying function will automatically take
@ -105,9 +102,8 @@ instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
-- > getBook :: Text -> ExceptT String IO Book
-- > getBook = client myApi host manager
-- > where host = BaseUrl Http "localhost" 8080
-- > getBook :: Text -> Manager -> BaseUrl -> ClientM Book
-- > getBook = client myApi
-- > -- then you can just use "getBook" to query that endpoint
instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout)
=> HasClient (Capture capture a :> sublayout) where
@ -115,11 +111,9 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout)
type Client (Capture capture a :> sublayout) =
a -> Client sublayout
clientWithRoute Proxy req baseurl manager val =
clientWithRoute Proxy req val =
clientWithRoute (Proxy :: Proxy sublayout)
(appendToPath p req)
baseurl
manager
where p = unpack (toUrlPiece val)
@ -127,16 +121,17 @@ instance OVERLAPPABLE_
-- Note [Non-Empty Content Types]
(MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
) => HasClient (Verb method status cts' a) where
type Client (Verb method status cts' a) = ExceptT ServantError IO a
clientWithRoute Proxy req baseurl manager =
snd <$> performRequestCT (Proxy :: Proxy ct) method req baseurl manager
type Client (Verb method status cts' a) = Manager -> BaseUrl -> ClientM a
clientWithRoute Proxy req manager baseurl =
snd <$> performRequestCT (Proxy :: Proxy ct) method req manager baseurl
where method = reflectMethod (Proxy :: Proxy method)
instance OVERLAPPING_
(ReflectMethod method) => HasClient (Verb method status cts NoContent) where
type Client (Verb method status cts NoContent) = ExceptT ServantError IO NoContent
clientWithRoute Proxy req baseurl manager =
performRequestNoBody method req baseurl manager >> return NoContent
type Client (Verb method status cts NoContent)
= Manager -> BaseUrl -> ClientM NoContent
clientWithRoute Proxy req manager baseurl =
performRequestNoBody method req manager baseurl >> return NoContent
where method = reflectMethod (Proxy :: Proxy method)
instance OVERLAPPING_
@ -144,10 +139,10 @@ instance OVERLAPPING_
( MimeUnrender ct a, BuildHeadersTo ls, ReflectMethod method, cts' ~ (ct ': cts)
) => HasClient (Verb method status cts' (Headers ls a)) where
type Client (Verb method status cts' (Headers ls a))
= ExceptT ServantError IO (Headers ls a)
clientWithRoute Proxy req baseurl manager = do
= Manager -> BaseUrl -> ClientM (Headers ls a)
clientWithRoute Proxy req manager baseurl = do
let method = reflectMethod (Proxy :: Proxy method)
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req baseurl manager
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req manager baseurl
return $ Headers { getResponse = resp
, getHeadersHList = buildHeadersTo hdrs
}
@ -156,10 +151,10 @@ instance OVERLAPPING_
( BuildHeadersTo ls, ReflectMethod method
) => HasClient (Verb method status cts (Headers ls NoContent)) where
type Client (Verb method status cts (Headers ls NoContent))
= ExceptT ServantError IO (Headers ls NoContent)
clientWithRoute Proxy req baseurl manager = do
= Manager -> BaseUrl -> ClientM (Headers ls NoContent)
clientWithRoute Proxy req manager baseurl = do
let method = reflectMethod (Proxy :: Proxy method)
hdrs <- performRequestNoBody method req baseurl manager
hdrs <- performRequestNoBody method req manager baseurl
return $ Headers { getResponse = NoContent
, getHeadersHList = buildHeadersTo hdrs
}
@ -186,9 +181,8 @@ instance OVERLAPPING_
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
-- > viewReferer :: Maybe Referer -> ExceptT String IO Book
-- > viewReferer = client myApi host
-- > where host = BaseUrl Http "localhost" 8080
-- > viewReferer :: Maybe Referer -> Manager -> BaseUrl -> ClientM Book
-- > viewReferer = client myApi
-- > -- then you can just use "viewRefer" to query that endpoint
-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments
instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)
@ -197,14 +191,12 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)
type Client (Header sym a :> sublayout) =
Maybe a -> Client sublayout
clientWithRoute Proxy req baseurl manager mval =
clientWithRoute Proxy req mval =
clientWithRoute (Proxy :: Proxy sublayout)
(maybe req
(\value -> Servant.Common.Req.addHeader hname value req)
mval
)
baseurl
manager
where hname = symbolVal (Proxy :: Proxy sym)
@ -239,9 +231,8 @@ instance HasClient sublayout
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
-- > getBooksBy :: Maybe Text -> ExceptT String IO [Book]
-- > getBooksBy = client myApi host
-- > where host = BaseUrl Http "localhost" 8080
-- > getBooksBy :: Maybe Text -> Manager -> BaseUrl -> ClientM [Book]
-- > getBooksBy = client myApi
-- > -- then you can just use "getBooksBy" to query that endpoint.
-- > -- 'getBooksBy Nothing' for all books
-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov
@ -252,14 +243,12 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)
Maybe a -> Client sublayout
-- if mparam = Nothing, we don't add it to the query string
clientWithRoute Proxy req baseurl manager mparam =
clientWithRoute Proxy req mparam =
clientWithRoute (Proxy :: Proxy sublayout)
(maybe req
(flip (appendToQueryString pname) req . Just)
mparamText
)
baseurl
manager
where pname = cs pname'
pname' = symbolVal (Proxy :: Proxy sym)
@ -286,9 +275,8 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
-- > getBooksBy :: [Text] -> ExceptT String IO [Book]
-- > getBooksBy = client myApi host
-- > where host = BaseUrl Http "localhost" 8080
-- > getBooksBy :: [Text] -> Manager -> BaseUrl -> ClientM [Book]
-- > getBooksBy = client myApi
-- > -- then you can just use "getBooksBy" to query that endpoint.
-- > -- 'getBooksBy []' for all books
-- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]'
@ -299,13 +287,12 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)
type Client (QueryParams sym a :> sublayout) =
[a] -> Client sublayout
clientWithRoute Proxy req baseurl manager paramlist =
clientWithRoute Proxy req paramlist =
clientWithRoute (Proxy :: Proxy sublayout)
(foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just))
req
paramlist'
)
baseurl manager
where pname = cs pname'
pname' = symbolVal (Proxy :: Proxy sym)
@ -327,9 +314,8 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
-- > getBooks :: Bool -> ExceptT String IO [Book]
-- > getBooks = client myApi host
-- > where host = BaseUrl Http "localhost" 8080
-- > getBooks :: Bool -> Manager -> BaseUrl -> ClientM [Book]
-- > getBooks = client myApi
-- > -- then you can just use "getBooks" to query that endpoint.
-- > -- 'getBooksBy False' for all books
-- > -- 'getBooksBy True' to only get _already published_ books
@ -339,13 +325,12 @@ instance (KnownSymbol sym, HasClient sublayout)
type Client (QueryFlag sym :> sublayout) =
Bool -> Client sublayout
clientWithRoute Proxy req baseurl manager flag =
clientWithRoute Proxy req flag =
clientWithRoute (Proxy :: Proxy sublayout)
(if flag
then appendToQueryString paramname Nothing req
else req
)
baseurl manager
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
@ -353,11 +338,12 @@ 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 -> ExceptT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], Response ByteString)
type Client Raw
= H.Method -> Manager -> BaseUrl -> ClientM (Int, ByteString, MediaType, [HTTP.Header], Response ByteString)
clientWithRoute :: Proxy Raw -> Req -> BaseUrl -> Manager -> Client Raw
clientWithRoute Proxy req baseurl manager httpMethod = do
performRequest httpMethod req baseurl manager
clientWithRoute :: Proxy Raw -> Req -> Client Raw
clientWithRoute Proxy req httpMethod = do
performRequest httpMethod req
-- | If you use a 'ReqBody' in one of your endpoints in your API,
-- the corresponding querying function will automatically take
@ -374,9 +360,8 @@ instance HasClient Raw where
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
-- > addBook :: Book -> ExceptT String IO Book
-- > addBook = client myApi host manager
-- > where host = BaseUrl Http "localhost" 8080
-- > addBook :: Book -> Manager -> BaseUrl -> ClientM Book
-- > addBook = client myApi
-- > -- then you can just use "addBook" to query that endpoint
instance (MimeRender ct a, HasClient sublayout)
=> HasClient (ReqBody (ct ': cts) a :> sublayout) where
@ -384,43 +369,41 @@ instance (MimeRender ct a, HasClient sublayout)
type Client (ReqBody (ct ': cts) a :> sublayout) =
a -> Client sublayout
clientWithRoute Proxy req baseurl manager body =
clientWithRoute Proxy req body =
clientWithRoute (Proxy :: Proxy sublayout)
(let ctProxy = Proxy :: Proxy ct
in setRQBody (mimeRender ctProxy body)
(contentType ctProxy)
req
)
baseurl manager
-- | Make the querying function append @path@ to the request path.
instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where
type Client (path :> sublayout) = Client sublayout
clientWithRoute Proxy req baseurl manager =
clientWithRoute Proxy req =
clientWithRoute (Proxy :: Proxy sublayout)
(appendToPath p req)
baseurl manager
where p = symbolVal (Proxy :: Proxy path)
instance HasClient api => HasClient (Vault :> api) where
type Client (Vault :> api) = Client api
clientWithRoute Proxy req baseurl manager =
clientWithRoute (Proxy :: Proxy api) req baseurl manager
clientWithRoute Proxy req =
clientWithRoute (Proxy :: Proxy api) req
instance HasClient api => HasClient (RemoteHost :> api) where
type Client (RemoteHost :> api) = Client api
clientWithRoute Proxy req baseurl manager =
clientWithRoute (Proxy :: Proxy api) req baseurl manager
clientWithRoute Proxy req =
clientWithRoute (Proxy :: Proxy api) req
instance HasClient api => HasClient (IsSecure :> api) where
type Client (IsSecure :> api) = Client api
clientWithRoute Proxy req baseurl manager =
clientWithRoute (Proxy :: Proxy api) req baseurl manager
clientWithRoute Proxy req =
clientWithRoute (Proxy :: Proxy api) req
instance HasClient subapi =>
HasClient (WithNamedContext name context subapi) where
@ -433,16 +416,16 @@ instance ( HasClient api
type Client (AuthProtect tag :> api)
= AuthenticateReq (AuthProtect tag) -> Client api
clientWithRoute Proxy req baseurl manager (AuthenticateReq (val,func)) =
clientWithRoute (Proxy :: Proxy api) (func val req) baseurl manager
clientWithRoute Proxy req (AuthenticateReq (val,func)) =
clientWithRoute (Proxy :: Proxy api) (func val req)
-- * Basic Authentication
instance HasClient api => HasClient (BasicAuth realm usr :> api) where
type Client (BasicAuth realm usr :> api) = BasicAuthData -> Client api
clientWithRoute Proxy req baseurl manager val =
clientWithRoute (Proxy :: Proxy api) (basicAuthReq val req) baseurl manager
clientWithRoute Proxy req val =
clientWithRoute (Proxy :: Proxy api) (basicAuthReq val req)
{- Note [Non-Empty Content Types]

View file

@ -123,11 +123,12 @@ reqToRequest req (BaseUrl reqScheme reqHost reqPort path) =
displayHttpRequest :: Method -> String
displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"
type ClientM = ExceptT ServantError IO
performRequest :: Method -> Req -> BaseUrl -> Manager
-> ExceptT ServantError IO ( Int, ByteString, MediaType
, [HTTP.Header], Response ByteString)
performRequest reqMethod req reqHost manager = do
performRequest :: Method -> Req -> Manager -> BaseUrl
-> ClientM ( Int, ByteString, MediaType
, [HTTP.Header], Response ByteString)
performRequest reqMethod req manager reqHost = do
partialRequest <- liftIO $ reqToRequest req reqHost
let request = partialRequest { Client.method = reqMethod
@ -155,21 +156,21 @@ performRequest reqMethod req reqHost manager = do
performRequestCT :: MimeUnrender ct result =>
Proxy ct -> Method -> Req -> BaseUrl -> Manager
-> ExceptT ServantError IO ([HTTP.Header], result)
performRequestCT ct reqMethod req reqHost manager = do
Proxy ct -> Method -> Req -> Manager -> BaseUrl
-> ClientM ([HTTP.Header], result)
performRequestCT ct reqMethod req manager reqHost = do
let acceptCT = contentType ct
(_status, respBody, respCT, hdrs, _response) <-
performRequest reqMethod (req { reqAccept = [acceptCT] }) reqHost manager
performRequest reqMethod (req { reqAccept = [acceptCT] }) manager reqHost
unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody
case mimeUnrender ct respBody of
Left err -> throwE $ DecodeFailure err respCT respBody
Right val -> return (hdrs, val)
performRequestNoBody :: Method -> Req -> BaseUrl -> Manager
-> ExceptT ServantError IO [HTTP.Header]
performRequestNoBody reqMethod req reqHost manager = do
(_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req reqHost manager
performRequestNoBody :: Method -> Req -> Manager -> BaseUrl
-> ClientM [HTTP.Header]
performRequestNoBody reqMethod req manager reqHost = do
(_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req manager reqHost
return hdrs
catchConnectionError :: IO a -> IO (Either ServantError a)

View file

@ -28,19 +28,18 @@ import Control.Applicative ((<$>))
import Control.Arrow (left)
import Control.Concurrent (forkIO, killThread, ThreadId)
import Control.Exception (bracket)
import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)
import Control.Monad.Trans.Except (ExceptT, throwE, runExceptT)
import Data.Aeson
import qualified Data.ByteString.Lazy as BS
import Data.Char (chr, isPrint)
import Data.Foldable (forM_)
import Data.Monoid hiding (getLast)
import Data.Proxy
import qualified Data.Text as T
import GHC.Generics (Generic)
import GHC.TypeLits
import qualified Network.HTTP.Client as C
import Network.HTTP.Media
import Network.HTTP.Types (Status (..), badRequest400,
methodGet, ok200, status400)
import qualified Network.HTTP.Types as HTTP
import Network.Socket
import Network.Wai (Application, Request,
requestHeaders, responseLBS)
@ -120,6 +119,34 @@ type Api =
api :: Proxy Api
api = Proxy
getGet :: C.Manager -> BaseUrl -> SCR.ClientM Person
getDeleteEmpty :: C.Manager -> BaseUrl -> SCR.ClientM NoContent
getCapture :: String -> C.Manager -> BaseUrl -> SCR.ClientM Person
getBody :: Person -> C.Manager -> BaseUrl -> SCR.ClientM Person
getQueryParam :: Maybe String -> C.Manager -> BaseUrl -> SCR.ClientM Person
getQueryParams :: [String] -> C.Manager -> BaseUrl -> SCR.ClientM [Person]
getQueryFlag :: Bool -> C.Manager -> BaseUrl -> SCR.ClientM Bool
getRawSuccess :: HTTP.Method -> C.Manager -> BaseUrl
-> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString)
getRawFailure :: HTTP.Method -> C.Manager -> BaseUrl
-> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString)
getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] -> C.Manager -> BaseUrl
-> SCR.ClientM (String, Maybe Int, Bool, [(String, [Rational])])
getRespHeaders :: C.Manager -> BaseUrl -> SCR.ClientM (Headers TestHeaders Bool)
getDeleteContentType :: C.Manager -> BaseUrl -> SCR.ClientM NoContent
getGet
:<|> getDeleteEmpty
:<|> getCapture
:<|> getBody
:<|> getQueryParam
:<|> getQueryParams
:<|> getQueryFlag
:<|> getRawSuccess
:<|> getRawFailure
:<|> getMultiple
:<|> getRespHeaders
:<|> getDeleteContentType = client api
server :: Application
server = serve api (
return alice
@ -132,8 +159,8 @@ server = serve api (
Nothing -> throwE $ ServantErr 400 "missing parameter" "" [])
:<|> (\ names -> return (zipWith Person names [0..]))
:<|> return
:<|> (\ _request respond -> respond $ responseLBS ok200 [] "rawSuccess")
:<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure")
:<|> (\ _request respond -> respond $ responseLBS HTTP.ok200 [] "rawSuccess")
:<|> (\ _request respond -> respond $ responseLBS HTTP.badRequest400 [] "rawFailure")
:<|> (\ a b c d -> return (a, b, c, d))
:<|> (return $ addHeader 1729 $ addHeader "eg2" True)
:<|> return NoContent
@ -149,9 +176,9 @@ failApi = Proxy
failServer :: Application
failServer = serve failApi (
(\ _request respond -> respond $ responseLBS ok200 [] "")
:<|> (\ _capture _request respond -> respond $ responseLBS ok200 [("content-type", "application/json")] "")
:<|> (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "")
(\ _request respond -> respond $ responseLBS HTTP.ok200 [] "")
:<|> (\ _capture _request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "application/json")] "")
:<|> (\_request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
)
-- * basic auth stuff
@ -208,76 +235,64 @@ sucessSpec :: Spec
sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
it "Servant.API.Get" $ \(_, baseUrl) -> do
let getGet = getNth (Proxy :: Proxy 0) $ client api baseUrl manager
(left show <$> runExceptT getGet) `shouldReturn` Right alice
(left show <$> runExceptT (getGet manager baseUrl)) `shouldReturn` Right alice
describe "Servant.API.Delete" $ do
it "allows empty content type" $ \(_, baseUrl) -> do
let getDeleteEmpty = getNth (Proxy :: Proxy 1) $ client api baseUrl manager
(left show <$> runExceptT getDeleteEmpty) `shouldReturn` Right NoContent
(left show <$> runExceptT (getDeleteEmpty manager baseUrl)) `shouldReturn` Right NoContent
it "allows content type" $ \(_, baseUrl) -> do
let getDeleteContentType = getLast $ client api baseUrl manager
(left show <$> runExceptT getDeleteContentType) `shouldReturn` Right NoContent
(left show <$> runExceptT (getDeleteContentType manager baseUrl)) `shouldReturn` Right NoContent
it "Servant.API.Capture" $ \(_, baseUrl) -> do
let getCapture = getNth (Proxy :: Proxy 2) $ client api baseUrl manager
(left show <$> runExceptT (getCapture "Paula")) `shouldReturn` Right (Person "Paula" 0)
(left show <$> runExceptT (getCapture "Paula" manager baseUrl)) `shouldReturn` Right (Person "Paula" 0)
it "Servant.API.ReqBody" $ \(_, baseUrl) -> do
let p = Person "Clara" 42
getBody = getNth (Proxy :: Proxy 3) $ client api baseUrl manager
(left show <$> runExceptT (getBody p)) `shouldReturn` Right p
(left show <$> runExceptT (getBody p manager baseUrl)) `shouldReturn` Right p
it "Servant.API.QueryParam" $ \(_, baseUrl) -> do
let getQueryParam = getNth (Proxy :: Proxy 4) $ client api baseUrl manager
left show <$> runExceptT (getQueryParam (Just "alice")) `shouldReturn` Right alice
Left FailureResponse{..} <- runExceptT (getQueryParam (Just "bob"))
responseStatus `shouldBe` Status 400 "bob not found"
left show <$> runExceptT (getQueryParam (Just "alice") manager baseUrl) `shouldReturn` Right alice
Left FailureResponse{..} <- runExceptT (getQueryParam (Just "bob") manager baseUrl)
responseStatus `shouldBe` HTTP.Status 400 "bob not found"
it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do
let getQueryParams = getNth (Proxy :: Proxy 5) $ client api baseUrl manager
(left show <$> runExceptT (getQueryParams [])) `shouldReturn` Right []
(left show <$> runExceptT (getQueryParams ["alice", "bob"]))
(left show <$> runExceptT (getQueryParams [] manager baseUrl)) `shouldReturn` Right []
(left show <$> runExceptT (getQueryParams ["alice", "bob"] manager baseUrl))
`shouldReturn` Right [Person "alice" 0, Person "bob" 1]
context "Servant.API.QueryParam.QueryFlag" $
forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do
let getQueryFlag = getNth (Proxy :: Proxy 6) $ client api baseUrl manager
(left show <$> runExceptT (getQueryFlag flag)) `shouldReturn` Right flag
(left show <$> runExceptT (getQueryFlag flag manager baseUrl)) `shouldReturn` Right flag
it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
let getRawSuccess = getNth (Proxy :: Proxy 7) $ client api baseUrl manager
res <- runExceptT (getRawSuccess methodGet)
res <- runExceptT (getRawSuccess HTTP.methodGet manager baseUrl)
case res of
Left e -> assertFailure $ show e
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
C.responseStatus response `shouldBe` HTTP.ok200
it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do
let getRawFailure = getNth (Proxy :: Proxy 8) $ client api baseUrl manager
res <- runExceptT (getRawFailure methodGet)
res <- runExceptT (getRawFailure HTTP.methodGet manager baseUrl)
case res of
Right _ -> assertFailure "expected Left, but got Right"
Left e -> do
Servant.Client.responseStatus e `shouldBe` status400
Servant.Client.responseStatus e `shouldBe` HTTP.status400
Servant.Client.responseBody e `shouldBe` "rawFailure"
it "Returns headers appropriately" $ \(_, baseUrl) -> do
let getRespHeaders = getNth (Proxy :: Proxy 10) $ client api baseUrl manager
res <- runExceptT getRespHeaders
res <- runExceptT (getRespHeaders manager baseUrl)
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" $ \(_, baseUrl) ->
let getMultiple = getNth (Proxy :: Proxy 9) $ client api baseUrl manager
in property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
ioProperty $ do
result <- left show <$> runExceptT (getMultiple cap num flag body)
result <- left show <$> runExceptT (getMultiple cap num flag body manager baseUrl)
return $
result === Right (cap, num, flag, body)
@ -289,10 +304,10 @@ wrappedApiSpec = describe "error status codes" $ do
let test :: (WrappedApi, String) -> Spec
test (WrappedApi api, desc) =
it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do
let getResponse :: ExceptT ServantError IO ()
getResponse = client api baseUrl manager
Left FailureResponse{..} <- runExceptT getResponse
responseStatus `shouldBe` (Status 500 "error message")
let getResponse :: C.Manager -> BaseUrl -> SCR.ClientM ()
getResponse = client api
Left FailureResponse{..} <- runExceptT (getResponse manager baseUrl)
responseStatus `shouldBe` (HTTP.Status 500 "error message")
in mapM_ test $
(WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :
(WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") :
@ -305,43 +320,43 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
context "client returns errors appropriately" $ do
it "reports FailureResponse" $ \(_, baseUrl) -> do
let (_ :<|> getDeleteEmpty :<|> _) = client api baseUrl manager
Left res <- runExceptT getDeleteEmpty
let (_ :<|> getDeleteEmpty :<|> _) = client api
Left res <- runExceptT (getDeleteEmpty manager baseUrl)
case res of
FailureResponse (Status 404 "Not Found") _ _ -> return ()
FailureResponse (HTTP.Status 404 "Not Found") _ _ -> return ()
_ -> fail $ "expected 404 response, but got " <> show res
it "reports DecodeFailure" $ \(_, baseUrl) -> do
let (_ :<|> _ :<|> getCapture :<|> _) = client api baseUrl manager
Left res <- runExceptT (getCapture "foo")
let (_ :<|> _ :<|> getCapture :<|> _) = client api
Left res <- runExceptT (getCapture "foo" manager baseUrl)
case res of
DecodeFailure _ ("application/json") _ -> return ()
_ -> fail $ "expected DecodeFailure, but got " <> show res
it "reports ConnectionError" $ \_ -> do
let (getGetWrongHost :<|> _) = client api (BaseUrl Http "127.0.0.1" 19872 "") manager
Left res <- runExceptT getGetWrongHost
let (getGetWrongHost :<|> _) = client api
Left res <- runExceptT (getGetWrongHost manager (BaseUrl Http "127.0.0.1" 19872 ""))
case res of
ConnectionError _ -> return ()
_ -> fail $ "expected ConnectionError, but got " <> show res
it "reports UnsupportedContentType" $ \(_, baseUrl) -> do
let (getGet :<|> _ ) = client api baseUrl manager
Left res <- runExceptT getGet
let (getGet :<|> _ ) = client api
Left res <- runExceptT (getGet manager baseUrl)
case res of
UnsupportedContentType ("application/octet-stream") _ -> return ()
_ -> fail $ "expected UnsupportedContentType, but got " <> show res
it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do
let (_ :<|> _ :<|> _ :<|> getBody :<|> _) = client api baseUrl manager
Left res <- runExceptT (getBody alice)
let (_ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
Left res <- runExceptT (getBody alice manager baseUrl)
case res of
InvalidContentTypeHeader "fooooo" _ -> return ()
_ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
data WrappedApi where
WrappedApi :: (HasServer (api :: *) '[], Server api ~ ExceptT ServantErr IO a,
HasClient api, Client api ~ ExceptT ServantError IO ()) =>
HasClient api, Client api ~ (C.Manager -> BaseUrl -> SCR.ClientM ())) =>
Proxy api -> WrappedApi
basicAuthSpec :: Spec
@ -349,34 +364,34 @@ basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ d
context "Authentication works when requests are properly authenticated" $ do
it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
let getBasic = client basicAuthAPI baseUrl manager
let getBasic = client basicAuthAPI
let basicAuthData = BasicAuthData "servant" "server"
(left show <$> runExceptT (getBasic basicAuthData)) `shouldReturn` Right alice
(left show <$> runExceptT (getBasic basicAuthData manager baseUrl)) `shouldReturn` Right alice
context "Authentication is rejected when requests are not authenticated properly" $ do
it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
let getBasic = client basicAuthAPI baseUrl manager
let getBasic = client basicAuthAPI
let basicAuthData = BasicAuthData "not" "password"
Left FailureResponse{..} <- runExceptT (getBasic basicAuthData)
responseStatus `shouldBe` Status 403 "Forbidden"
Left FailureResponse{..} <- runExceptT (getBasic basicAuthData manager baseUrl)
responseStatus `shouldBe` HTTP.Status 403 "Forbidden"
genAuthSpec :: Spec
genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do
context "Authentication works when requests are properly authenticated" $ do
it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
let getProtected = client genAuthAPI baseUrl manager
let getProtected = client genAuthAPI
let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "AuthHeader" ("cool" :: String) req)
(left show <$> runExceptT (getProtected authRequest)) `shouldReturn` Right alice
(left show <$> runExceptT (getProtected authRequest manager baseUrl)) `shouldReturn` Right alice
context "Authentication is rejected when requests are not authenticated properly" $ do
it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
let getProtected = client genAuthAPI baseUrl manager
let getProtected = client genAuthAPI
let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "Wrong" ("header" :: String) req)
Left FailureResponse{..} <- runExceptT (getProtected authRequest)
responseStatus `shouldBe` (Status 401 "Unauthorized")
Left FailureResponse{..} <- runExceptT (getProtected authRequest manager baseUrl)
responseStatus `shouldBe` (HTTP.Status 401 "Unauthorized")
-- * utils
@ -407,25 +422,3 @@ pathGen = fmap NonEmpty path
filter (not . (`elem` ("?%[]/#;" :: String))) $
filter isPrint $
map chr [0..127]
class GetNth (n :: Nat) a b | n a -> b where
getNth :: Proxy n -> a -> b
instance OVERLAPPING_
GetNth 0 (x :<|> y) x where
getNth _ (x :<|> _) = x
instance OVERLAPPING_
(GetNth (n - 1) x y) => GetNth n (a :<|> x) y where
getNth _ (_ :<|> x) = getNth (Proxy :: Proxy (n - 1)) x
class GetLast a b | a -> b where
getLast :: a -> b
instance OVERLAPPING_
(GetLast b c) => GetLast (a :<|> b) c where
getLast (_ :<|> b) = getLast b
instance OVERLAPPING_
GetLast a a where
getLast a = a