Merge branch 'pr'
This commit is contained in:
commit
2fb981f02a
5 changed files with 172 additions and 198 deletions
|
@ -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
|
||||
|
|
|
@ -1,3 +1,6 @@
|
|||
|
||||
* `client` no longer takes `BaseUrl` and `Manager` arguments. Instead, each function returned by `client` requires these two arguments.
|
||||
|
||||
0.5
|
||||
----
|
||||
|
||||
|
|
|
@ -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]
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Add table
Reference in a new issue