git.iko.soy/servant
on master help sign in
first shot at splitting servant into servant, servant-client and servant-docs
d93e462Alp Mestanogullari
servant-client.cabalnew file+59
compare with master
unifiedsplit
@@ -0,0 +1,59 @@
1+name: servant-client
2+version: 0.2
3+-- synopsis:
4+-- description:
5+license: BSD3
6+license-file: LICENSE
7+author: Alp Mestanogullari, Sönke Hahn, Julian K. Arni
8+maintainer: alpmestan@gmail.com
9+copyright: 2014 Zalora South East Asia Pte Ltd
10+category: Web
11+build-type: Simple
12+cabal-version: >=1.10
13+tested-with: GHC >= 7.8
14+
15+library
16+ exposed-modules:
17+ Servant.Client
18+ Servant.Common.BaseUrl
19+ Servant.Common.Req
20+ build-depends:
21+ base >=4.7 && <5
22+ , aeson
23+ , attoparsec
24+ , bytestring
25+ , either
26+ , exceptions
27+ , http-client
28+ , http-types
29+ , network-uri >= 2.6
30+ , safe
31+ , servant
32+ , string-conversions
33+ , text
34+ , transformers
35+ hs-source-dirs: src
36+ default-language: Haskell2010
37+ ghc-options: -O0 -Wall
38+
39+test-suite spec
40+ type: exitcode-stdio-1.0
41+ ghc-options:
42+ -Wall -fno-warn-name-shadowing -fno-warn-missing-signatures
43+ default-language: Haskell2010
44+ hs-source-dirs: test
45+ main-is: Spec.hs
46+ build-depends:
47+ base == 4.*
48+ , aeson
49+ , bytestring
50+ , deepseq
51+ , either
52+ , hspec == 2.*
53+ , http-types
54+ , network >= 2.6
55+ , QuickCheck
56+ , servant
57+ , servant-client
58+ , wai
59+ , warp
src/Servant/Client.hsnew file+305
@@ -0,0 +1,305 @@
1+{-# LANGUAGE InstanceSigs #-}
2+{-# LANGUAGE TypeFamilies #-}
3+{-# LANGUAGE TypeOperators #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE OverloadedStrings #-}
6+{-# LANGUAGE ScopedTypeVariables #-}
7+-- | This module provides 'client' which can automatically generate
8+-- querying functions for each endpoint just from the type representing your
9+-- API.
10+module Servant.Client
11+ ( client
12+ , HasClient(..)
13+ , module Servant.Common.BaseUrl
14+ ) where
15+
16+import Control.Monad.Trans.Either
17+import Data.Aeson
18+import Data.ByteString.Lazy (ByteString)
19+import Data.List
20+import Data.Proxy
21+import Data.String.Conversions
22+import Data.Text (unpack)
23+import GHC.TypeLits
24+import Network.HTTP.Types
25+import Servant.API
26+import Servant.Common.BaseUrl
27+import Servant.Common.Req
28+import Servant.Common.Text
29+
30+-- * Accessing APIs as a Client
31+
32+-- | 'client' allows you to produce operations to query an API from a client.
33+--
34+-- > type MyApi = "books" :> Get [Book] -- GET /books
35+-- > :<|> "books" :> ReqBody Book :> Post Book -- POST /books
36+-- >
37+-- > myApi :: Proxy MyApi
38+-- > myApi = Proxy
39+-- >
40+-- > getAllBooks :: BaseUrl -> EitherT String IO [Book]
41+-- > postNewBook :: Book -> BaseUrl -> EitherT String IO Book
42+-- > (getAllBooks :<|> postNewBook) = client myApi
43+client :: HasClient layout => Proxy layout -> Client layout
44+client p = clientWithRoute p defReq
45+
46+-- | This class lets us define how each API combinator
47+-- influences the creation of an HTTP request. Use 'client'
48+-- directly, this class implements the client-side
49+-- behavior of each combinator but you don't have to worry about it.
50+class HasClient layout where
51+ type Client layout :: *
52+ clientWithRoute :: Proxy layout -> Req -> Client layout
53+
54+-- | A client querying function for @a ':<|>' b@ will actually hand you
55+-- one function for querying @a@ and another one for querying @b@,
56+-- stitching them together with ':<|>', which really is just like a pair.
57+--
58+-- > type MyApi = "books" :> Get [Book] -- GET /books
59+-- > :<|> "books" :> ReqBody Book :> Post Book -- POST /books
60+-- >
61+-- > myApi :: Proxy MyApi
62+-- > myApi = Proxy
63+-- >
64+-- > getAllBooks :: BaseUrl -> EitherT String IO [Book]
65+-- > postNewBook :: Book -> BaseUrl -> EitherT String IO Book
66+-- > (getAllBooks :<|> postNewBook) = client myApi
67+instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
68+ type Client (a :<|> b) = Client a :<|> Client b
69+ clientWithRoute Proxy req =
70+ clientWithRoute (Proxy :: Proxy a) req :<|>
71+ clientWithRoute (Proxy :: Proxy b) req
72+
73+-- | If you use a 'Capture' in one of your endpoints in your API,
74+-- the corresponding querying function will automatically take
75+-- an additional argument of the type specified by your 'Capture'.
76+-- That function will take care of inserting a textual representation
77+-- of this value at the right place in the request path.
78+--
79+-- You can control how values for this type are turned into
80+-- text by specifying a 'ToText' instance for your type.
81+--
82+-- Example:
83+--
84+-- > type MyApi = "books" :> Capture "isbn" Text :> Get Book
85+-- >
86+-- > myApi :: Proxy MyApi
87+-- > myApi = Proxy
88+-- >
89+-- > getBook :: Text -> BaseUrl -> EitherT String IO Book
90+-- > getBook = client myApi
91+-- > -- then you can just use "getBook" to query that endpoint
92+instance (KnownSymbol capture, ToText a, HasClient sublayout)
93+ => HasClient (Capture capture a :> sublayout) where
94+
95+ type Client (Capture capture a :> sublayout) =
96+ a -> Client sublayout
97+
98+ clientWithRoute Proxy req val =
99+ clientWithRoute (Proxy :: Proxy sublayout) $
100+ appendToPath p req
101+
102+ where p = unpack (toText val)
103+
104+-- | If you have a 'Delete' endpoint in your API, the client
105+-- side querying function that is created when calling 'client'
106+-- will just require an argument that specifies the scheme, host
107+-- and port to send the request to.
108+instance HasClient Delete where
109+ type Client Delete = BaseUrl -> EitherT String IO ()
110+
111+ clientWithRoute Proxy req host =
112+ performRequestJSON methodDelete req 204 host
113+
114+-- | If you have a 'Get' endpoint in your API, the client
115+-- side querying function that is created when calling 'client'
116+-- will just require an argument that specifies the scheme, host
117+-- and port to send the request to.
118+instance FromJSON result => HasClient (Get result) where
119+ type Client (Get result) = BaseUrl -> EitherT String IO result
120+ clientWithRoute Proxy req host =
121+ performRequestJSON methodGet req 200 host
122+
123+-- | If you have a 'Post' endpoint in your API, the client
124+-- side querying function that is created when calling 'client'
125+-- will just require an argument that specifies the scheme, host
126+-- and port to send the request to.
127+instance FromJSON a => HasClient (Post a) where
128+ type Client (Post a) = BaseUrl -> EitherT String IO a
129+
130+ clientWithRoute Proxy req uri =
131+ performRequestJSON methodPost req 201 uri
132+
133+-- | If you have a 'Put' endpoint in your API, the client
134+-- side querying function that is created when calling 'client'
135+-- will just require an argument that specifies the scheme, host
136+-- and port to send the request to.
137+instance FromJSON a => HasClient (Put a) where
138+ type Client (Put a) = BaseUrl -> EitherT String IO a
139+
140+ clientWithRoute Proxy req host =
141+ performRequestJSON methodPut req 200 host
142+
143+-- | If you use a 'QueryParam' in one of your endpoints in your API,
144+-- the corresponding querying function will automatically take
145+-- an additional argument of the type specified by your 'QueryParam',
146+-- enclosed in Maybe.
147+--
148+-- If you give Nothing, nothing will be added to the query string.
149+--
150+-- If you give a non-'Nothing' value, this function will take care
151+-- of inserting a textual representation of this value in the query string.
152+--
153+-- You can control how values for your type are turned into
154+-- text by specifying a 'ToText' instance for your type.
155+--
156+-- Example:
157+--
158+-- > type MyApi = "books" :> QueryParam "author" Text :> Get [Book]
159+-- >
160+-- > myApi :: Proxy MyApi
161+-- > myApi = Proxy
162+-- >
163+-- > getBooksBy :: Maybe Text -> BaseUrl -> EitherT String IO [Book]
164+-- > getBooksBy = client myApi
165+-- > -- then you can just use "getBooksBy" to query that endpoint.
166+-- > -- 'getBooksBy Nothing' for all books
167+-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov
168+instance (KnownSymbol sym, ToText a, HasClient sublayout)
169+ => HasClient (QueryParam sym a :> sublayout) where
170+
171+ type Client (QueryParam sym a :> sublayout) =
172+ Maybe a -> Client sublayout
173+
174+ -- if mparam = Nothing, we don't add it to the query string
175+ clientWithRoute Proxy req mparam =
176+ clientWithRoute (Proxy :: Proxy sublayout) $
177+ appendToQueryString pname mparamText req
178+
179+ where pname = cs pname'
180+ pname' = symbolVal (Proxy :: Proxy sym)
181+ mparamText = fmap toText mparam
182+
183+-- | If you use a 'QueryParams' in one of your endpoints in your API,
184+-- the corresponding querying function will automatically take
185+-- an additional argument, a list of values of the type specified
186+-- by your 'QueryParams'.
187+--
188+-- If you give an empty list, nothing will be added to the query string.
189+--
190+-- Otherwise, this function will take care
191+-- of inserting a textual representation of your values in the query string,
192+-- under the same query string parameter name.
193+--
194+-- You can control how values for your type are turned into
195+-- text by specifying a 'ToText' instance for your type.
196+--
197+-- Example:
198+--
199+-- > type MyApi = "books" :> QueryParams "authors" Text :> Get [Book]
200+-- >
201+-- > myApi :: Proxy MyApi
202+-- > myApi = Proxy
203+-- >
204+-- > getBooksBy :: [Text] -> BaseUrl -> EitherT String IO [Book]
205+-- > getBooksBy = client myApi
206+-- > -- then you can just use "getBooksBy" to query that endpoint.
207+-- > -- 'getBooksBy []' for all books
208+-- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]'
209+-- > -- to get all books by Asimov and Heinlein
210+instance (KnownSymbol sym, ToText a, HasClient sublayout)
211+ => HasClient (QueryParams sym a :> sublayout) where
212+
213+ type Client (QueryParams sym a :> sublayout) =
214+ [a] -> Client sublayout
215+
216+ clientWithRoute Proxy req paramlist =
217+ clientWithRoute (Proxy :: Proxy sublayout) $
218+ foldl' (\ value req' -> appendToQueryString pname req' value) req paramlist'
219+
220+ where pname = cs pname'
221+ pname' = symbolVal (Proxy :: Proxy sym)
222+ paramlist' = map (Just . toText) paramlist
223+
224+-- | If you use a 'QueryFlag' in one of your endpoints in your API,
225+-- the corresponding querying function will automatically take
226+-- an additional 'Bool' argument.
227+--
228+-- If you give 'False', nothing will be added to the query string.
229+--
230+-- Otherwise, this function will insert a value-less query string
231+-- parameter under the name associated to your 'QueryFlag'.
232+--
233+-- Example:
234+--
235+-- > type MyApi = "books" :> QueryFlag "published" :> Get [Book]
236+-- >
237+-- > myApi :: Proxy MyApi
238+-- > myApi = Proxy
239+-- >
240+-- > getBooks :: Bool -> BaseUrl -> EitherT String IO [Book]
241+-- > getBooks = client myApi
242+-- > -- then you can just use "getBooks" to query that endpoint.
243+-- > -- 'getBooksBy False' for all books
244+-- > -- 'getBooksBy True' to only get _already published_ books
245+instance (KnownSymbol sym, HasClient sublayout)
246+ => HasClient (QueryFlag sym :> sublayout) where
247+
248+ type Client (QueryFlag sym :> sublayout) =
249+ Bool -> Client sublayout
250+
251+ clientWithRoute Proxy req flag =
252+ clientWithRoute (Proxy :: Proxy sublayout) $
253+ if flag
254+ then appendToQueryString paramname Nothing req
255+ else req
256+
257+ where paramname = cs $ symbolVal (Proxy :: Proxy sym)
258+
259+-- | Pick a 'Method' and specify where the server you want to query is. You get
260+-- back the status code and the response body as a 'ByteString'.
261+instance HasClient Raw where
262+ type Client Raw = Method -> BaseUrl -> EitherT String IO (Int, ByteString)
263+
264+ clientWithRoute :: Proxy Raw -> Req -> Client Raw
265+ clientWithRoute Proxy req httpMethod host =
266+ performRequest httpMethod req (const True) host
267+
268+-- | If you use a 'ReqBody' in one of your endpoints in your API,
269+-- the corresponding querying function will automatically take
270+-- an additional argument of the type specified by your 'ReqBody'.
271+-- That function will take care of encoding this argument as JSON and
272+-- of using it as the request body.
273+--
274+-- All you need is for your type to have a 'ToJSON' instance.
275+--
276+-- Example:
277+--
278+-- > type MyApi = "books" :> ReqBody Book :> Post Book
279+-- >
280+-- > myApi :: Proxy MyApi
281+-- > myApi = Proxy
282+-- >
283+-- > addBook :: Book -> BaseUrl -> EitherT String IO Book
284+-- > addBook = client myApi
285+-- > -- then you can just use "addBook" to query that endpoint
286+instance (ToJSON a, HasClient sublayout)
287+ => HasClient (ReqBody a :> sublayout) where
288+
289+ type Client (ReqBody a :> sublayout) =
290+ a -> Client sublayout
291+
292+ clientWithRoute Proxy req body =
293+ clientWithRoute (Proxy :: Proxy sublayout) $
294+ setRQBody (encode body) req
295+
296+-- | Make the querying function append @path@ to the request path.
297+instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where
298+ type Client (path :> sublayout) = Client sublayout
299+
300+ clientWithRoute Proxy req =
301+ clientWithRoute (Proxy :: Proxy sublayout) $
302+ appendToPath p req
303+
304+ where p = symbolVal (Proxy :: Proxy path)
305+
src/Servant/Common/BaseUrl.hsnew file+55
@@ -0,0 +1,55 @@
1+{-# LANGUAGE DeriveGeneric #-}
2+{-# LANGUAGE ViewPatterns #-}
3+module Servant.Common.BaseUrl where
4+
5+import Data.List
6+import GHC.Generics
7+import Network.URI
8+import Safe
9+import Text.Read
10+
11+-- | URI scheme to use
12+data Scheme =
13+ Http -- ^ http://
14+ | Https -- ^ https://
15+ deriving (Show, Eq, Ord, Generic)
16+
17+-- | Simple data type to represent the target of HTTP requests
18+-- for servant's automatically-generated clients.
19+data BaseUrl = BaseUrl
20+ { baseUrlScheme :: Scheme -- ^ URI scheme to use
21+ , baseUrlHost :: String -- ^ host (eg "haskell.org")
22+ , baseUrlPort :: Int -- ^ port (eg 80)
23+ } deriving (Show, Eq, Ord, Generic)
24+
25+showBaseUrl :: BaseUrl -> String
26+showBaseUrl (BaseUrl urlscheme host port) =
27+ schemeString ++ "//" ++ host ++ portString
28+ where
29+ schemeString = case urlscheme of
30+ Http -> "http:"
31+ Https -> "https:"
32+ portString = case (urlscheme, port) of
33+ (Http, 80) -> ""
34+ (Https, 443) -> ""
35+ _ -> ":" ++ show port
36+
37+parseBaseUrl :: String -> Either String BaseUrl
38+parseBaseUrl s = case parseURI (removeTrailingSlash s) of
39+ -- This is a rather hacky implementation and should be replaced with something
40+ -- implemented in attoparsec (which is already a dependency anyhow (via aeson)).
41+ Just (URI "http:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) "" "" "") ->
42+ Right (BaseUrl Http host port)
43+ Just (URI "http:" (Just (URIAuth "" host "")) "" "" "") ->
44+ Right (BaseUrl Http host 80)
45+ Just (URI "https:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) "" "" "") ->
46+ Right (BaseUrl Https host port)
47+ Just (URI "https:" (Just (URIAuth "" host "")) "" "" "") ->
48+ Right (BaseUrl Https host 443)
49+ _ -> if "://" `isInfixOf` s
50+ then Left ("invalid base url: " ++ s)
51+ else parseBaseUrl ("http://" ++ s)
52+ where
53+ removeTrailingSlash str = case lastMay str of
54+ Just '/' -> init str
55+ _ -> str
src/Servant/Common/Req.hsnew file+132
@@ -0,0 +1,132 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE ScopedTypeVariables #-}
3+module Servant.Common.Req where
4+
5+import Control.Applicative
6+import Control.Concurrent
7+import Control.Exception
8+import Control.Monad
9+import Control.Monad.Catch (MonadThrow)
10+import Control.Monad.IO.Class
11+import Control.Monad.Trans.Either
12+import Data.Aeson
13+import Data.Aeson.Parser
14+import Data.Aeson.Types
15+import Data.Attoparsec.ByteString
16+import Data.ByteString.Lazy
17+import Data.String.Conversions
18+import Data.Text
19+import Network.HTTP.Client
20+import Network.HTTP.Types
21+import Network.URI
22+import Servant.Common.BaseUrl
23+import System.IO.Unsafe
24+
25+import qualified Network.HTTP.Client as Client
26+
27+data Req = Req
28+ { reqPath :: String
29+ , qs :: QueryText
30+ , reqBody :: ByteString
31+ }
32+
33+defReq :: Req
34+defReq = Req "" [] ""
35+
36+appendToPath :: String -> Req -> Req
37+appendToPath p req =
38+ req { reqPath = reqPath req ++ "/" ++ p }
39+
40+appendToQueryString :: Text -- ^ param name
41+ -> Maybe Text -- ^ param value
42+ -> Req
43+ -> Req
44+appendToQueryString pname pvalue req =
45+ req { qs = qs req ++ [(pname, pvalue)]
46+ }
47+
48+setRQBody :: ByteString -> Req -> Req
49+setRQBody b req = req { reqBody = b }
50+
51+reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request
52+reqToRequest req (BaseUrl reqScheme reqHost reqPort) = fmap (setrqb . setQS ) $ parseUrl url
53+
54+ where url = show $ nullURI { uriScheme = case reqScheme of
55+ Http -> "http:"
56+ Https -> "https:"
57+ , uriAuthority = Just $
58+ URIAuth { uriUserInfo = ""
59+ , uriRegName = reqHost
60+ , uriPort = ":" ++ show reqPort
61+ }
62+ , uriPath = reqPath req
63+ }
64+
65+ setrqb r = r { requestBody = RequestBodyLBS (reqBody req) }
66+ setQS = setQueryString $ queryTextToQuery (qs req)
67+
68+
69+-- * performing requests
70+
71+{-# NOINLINE __manager #-}
72+__manager :: MVar Manager
73+__manager = unsafePerformIO (newManager defaultManagerSettings >>= newMVar)
74+
75+__withGlobalManager :: (Manager -> IO a) -> IO a
76+__withGlobalManager action = modifyMVar __manager $ \ manager -> do
77+ result <- action manager
78+ return (manager, result)
79+
80+
81+displayHttpRequest :: Method -> String
82+displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"
83+
84+
85+performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl -> EitherT String IO (Int, ByteString)
86+performRequest reqMethod req isWantedStatus reqHost = do
87+ partialRequest <- liftIO $ reqToRequest req reqHost
88+
89+ let request = partialRequest { Client.method = reqMethod
90+ , checkStatus = \ _status _headers _cookies -> Nothing
91+ }
92+
93+ eResponse <- liftIO $ __withGlobalManager $ \ manager ->
94+ catchStatusCodeException $
95+ Client.httpLbs request manager
96+ case eResponse of
97+ Left status ->
98+ left (displayHttpRequest reqMethod ++ " failed with status: " ++ showStatus status)
99+
100+ Right response -> do
101+ let status = Client.responseStatus response
102+ unless (isWantedStatus (statusCode status)) $
103+ left (displayHttpRequest reqMethod ++ " failed with status: " ++ showStatus status)
104+ return $ (statusCode status, Client.responseBody response)
105+ where
106+ showStatus (Status code message) =
107+ show code ++ " - " ++ cs message
108+
109+
110+performRequestJSON :: FromJSON result =>
111+ Method -> Req -> Int -> BaseUrl -> EitherT String IO result
112+performRequestJSON reqMethod req wantedStatus reqHost = do
113+ (_status, respBody) <- performRequest reqMethod req (== wantedStatus) reqHost
114+ either
115+ (\ message -> left (displayHttpRequest reqMethod ++ " returned invalid json: " ++ message))
116+ return
117+ (decodeLenient respBody)
118+
119+
120+catchStatusCodeException :: IO a -> IO (Either Status a)
121+catchStatusCodeException action =
122+ catch (Right <$> action) $ \e ->
123+ case e of
124+ Client.StatusCodeException status _ _ -> return $ Left status
125+ exc -> throwIO exc
126+
127+-- | Like 'Data.Aeson.decode' but allows all JSON values instead of just
128+-- objects and arrays.
129+decodeLenient :: FromJSON a => ByteString -> Either String a
130+decodeLenient input = do
131+ v :: Value <- parseOnly (Data.Aeson.Parser.value <* endOfInput) (cs input)
132+ parseEither parseJSON v
test/Servant/ClientSpec.hsnew file+218
@@ -0,0 +1,218 @@
1+{-# LANGUAGE GADTs #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE ViewPatterns #-}
4+{-# LANGUAGE DeriveGeneric #-}
5+{-# LANGUAGE TypeOperators #-}
6+{-# LANGUAGE OverloadedStrings #-}
7+
8+module Servant.ClientSpec where
9+
10+import Control.Concurrent
11+import Control.Exception
12+import Control.Monad.Trans.Either
13+import Data.Aeson
14+import Data.ByteString.Lazy (ByteString)
15+import Data.Char
16+import Data.Foldable (forM_)
17+import Data.Proxy
18+import Data.Typeable
19+import GHC.Generics
20+import Network.HTTP.Types
21+import Network.Socket
22+import Network.Wai
23+import Network.Wai.Handler.Warp
24+import Test.Hspec
25+import Test.Hspec.QuickCheck
26+import Test.QuickCheck
27+
28+import Servant.API
29+import Servant.Client
30+import Servant.Server
31+
32+-- * test data types
33+
34+data Person = Person {
35+ name :: String,
36+ age :: Integer
37+ }
38+ deriving (Eq, Show, Generic)
39+
40+instance ToJSON Person
41+instance FromJSON Person
42+
43+alice :: Person
44+alice = Person "Alice" 42
45+
46+type Api =
47+ "get" :> Get Person
48+ :<|> "capture" :> Capture "name" String :> Get Person
49+ :<|> "body" :> ReqBody Person :> Post Person
50+ :<|> "param" :> QueryParam "name" String :> Get Person
51+ :<|> "params" :> QueryParams "names" String :> Get [Person]
52+ :<|> "flag" :> QueryFlag "flag" :> Get Bool
53+ :<|> "rawSuccess" :> Raw
54+ :<|> "rawFailure" :> Raw
55+ :<|> "multiple" :>
56+ Capture "first" String :>
57+ QueryParam "second" Int :>
58+ QueryFlag "third" :>
59+ ReqBody [(String, [Rational])] :>
60+ Get (String, Maybe Int, Bool, [(String, [Rational])])
61+api :: Proxy Api
62+api = Proxy
63+
64+server :: Application
65+server = serve api (
66+ return alice
67+ :<|> (\ name -> return $ Person name 0)
68+ :<|> return
69+ :<|> (\ name -> case name of
70+ Just "alice" -> return alice
71+ Just name -> left (400, name ++ " not found")
72+ Nothing -> left (400, "missing parameter"))
73+ :<|> (\ names -> return (zipWith Person names [0..]))
74+ :<|> return
75+ :<|> (\ _request respond -> respond $ responseLBS ok200 [] "rawSuccess")
76+ :<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure")
77+ :<|> \ a b c d -> return (a, b, c, d)
78+ )
79+
80+withServer :: (BaseUrl -> IO a) -> IO a
81+withServer action = withWaiDaemon (return server) action
82+
83+getGet :: BaseUrl -> EitherT String IO Person
84+getCapture :: String -> BaseUrl -> EitherT String IO Person
85+getBody :: Person -> BaseUrl -> EitherT String IO Person
86+getQueryParam :: Maybe String -> BaseUrl -> EitherT String IO Person
87+getQueryParams :: [String] -> BaseUrl -> EitherT String IO [Person]
88+getQueryFlag :: Bool -> BaseUrl -> EitherT String IO Bool
89+getRawSuccess :: Method -> BaseUrl -> EitherT String IO (Int, ByteString)
90+getRawFailure :: Method -> BaseUrl -> EitherT String IO (Int, ByteString)
91+getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
92+ -> BaseUrl
93+ -> EitherT String IO (String, Maybe Int, Bool, [(String, [Rational])])
94+( getGet
95+ :<|> getCapture
96+ :<|> getBody
97+ :<|> getQueryParam
98+ :<|> getQueryParams
99+ :<|> getQueryFlag
100+ :<|> getRawSuccess
101+ :<|> getRawFailure
102+ :<|> getMultiple)
103+ = client api
104+
105+spec :: Spec
106+spec = do
107+ it "Servant.API.Get" $ withServer $ \ host -> do
108+ runEitherT (getGet host) `shouldReturn` Right alice
109+
110+ it "Servant.API.Capture" $ withServer $ \ host -> do
111+ runEitherT (getCapture "Paula" host) `shouldReturn` Right (Person "Paula" 0)
112+
113+ it "Servant.API.ReqBody" $ withServer $ \ host -> do
114+ let p = Person "Clara" 42
115+ runEitherT (getBody p host) `shouldReturn` Right p
116+
117+ it "Servant.API.QueryParam" $ withServer $ \ host -> do
118+ runEitherT (getQueryParam (Just "alice") host) `shouldReturn` Right alice
119+ Left result <- runEitherT (getQueryParam (Just "bob") host)
120+ result `shouldContain` "bob not found"
121+
122+ it "Servant.API.QueryParam.QueryParams" $ withServer $ \ host -> do
123+ runEitherT (getQueryParams [] host) `shouldReturn` Right []
124+ runEitherT (getQueryParams ["alice", "bob"] host)
125+ `shouldReturn` Right [Person "alice" 0, Person "bob" 1]
126+
127+ context "Servant.API.QueryParam.QueryFlag" $
128+ forM_ [False, True] $ \ flag ->
129+ it (show flag) $ withServer $ \ host -> do
130+ runEitherT (getQueryFlag flag host) `shouldReturn` Right flag
131+
132+ it "Servant.API.Raw on success" $ withServer $ \ host -> do
133+ runEitherT (getRawSuccess methodGet host) `shouldReturn` Right (200, "rawSuccess")
134+
135+ it "Servant.API.Raw on failure" $ withServer $ \ host -> do
136+ runEitherT (getRawFailure methodGet host) `shouldReturn` Right (400, "rawFailure")
137+
138+ modifyMaxSuccess (const 20) $ do
139+ it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $
140+ property $ forAllShrink pathGen shrink $ \ a -> \ b c d ->
141+ ioProperty $ do
142+ withServer $ \ host -> do
143+ result <- runEitherT (getMultiple a b c d host)
144+ return $
145+ result === Right (a, b, c, d)
146+
147+
148+ context "client correctly handles error status codes" $ do
149+ let test :: WrappedApi -> Spec
150+ test (WrappedApi api) =
151+ it (show (typeOf api)) $
152+ withWaiDaemon (return (serve api (left (500, "error message")))) $
153+ \ host -> do
154+ let getResponse :: BaseUrl -> EitherT String IO ()
155+ getResponse = client api
156+ Left result <- runEitherT (getResponse host)
157+ result `shouldContain` "error message"
158+ mapM_ test $
159+ (WrappedApi (Proxy :: Proxy Delete)) :
160+ (WrappedApi (Proxy :: Proxy (Get ()))) :
161+ (WrappedApi (Proxy :: Proxy (Post ()))) :
162+ (WrappedApi (Proxy :: Proxy (Put ()))) :
163+ []
164+
165+data WrappedApi where
166+ WrappedApi :: (HasServer api, Server api ~ EitherT (Int, String) IO a,
167+ HasClient api, Client api ~ (BaseUrl -> EitherT String IO ()),
168+ Typeable api) =>
169+ Proxy api -> WrappedApi
170+
171+
172+-- * utils
173+
174+withWaiDaemon :: IO Application -> (BaseUrl -> IO a) -> IO a
175+withWaiDaemon mkApplication action = do
176+ application <- mkApplication
177+ bracket (acquire application) free (\ (_, _, baseUrl) -> action baseUrl)
178+ where
179+ acquire application = do
180+ (notifyStart, waitForStart) <- lvar
181+ (notifyKilled, waitForKilled) <- lvar
182+ thread <- forkIO $ (do
183+ (krakenPort, socket) <- openTestSocket
184+ let settings =
185+ setPort krakenPort $ -- set here just for consistency, shouldn't be
186+ -- used (it's set in the socket)
187+ setBeforeMainLoop (notifyStart krakenPort)
188+ defaultSettings
189+ runSettingsSocket settings socket application)
190+ `finally` notifyKilled ()
191+ krakenPort <- waitForStart
192+ let baseUrl = (BaseUrl Http "localhost" 80){baseUrlPort = krakenPort}
193+ return (thread, waitForKilled, baseUrl)
194+ free (thread, waitForKilled, _) = do
195+ killThread thread
196+ waitForKilled
197+
198+ lvar :: IO (a -> IO (), IO a)
199+ lvar = do
200+ mvar <- newEmptyMVar
201+ let put = putMVar mvar
202+ wait = readMVar mvar
203+ return (put, wait)
204+
205+openTestSocket :: IO (Port, Socket)
206+openTestSocket = do
207+ s <- socket AF_INET Stream defaultProtocol
208+ localhost <- inet_addr "127.0.0.1"
209+ bind s (SockAddrInet aNY_PORT localhost)
210+ listen s 1
211+ port <- socketPort s
212+ return (fromIntegral port, s)
213+
214+pathGen :: Gen String
215+pathGen = listOf $ elements $
216+ filter (not . (`elem` "?%[]/#")) $
217+ filter isPrint $
218+ map chr [0..127]
test/Servant/Common/BaseUrlSpec.hsnew file+69
@@ -0,0 +1,69 @@
1+{-# OPTIONS_GHC -fno-warn-orphans #-}
2+module Servant.Common.BaseUrlSpec where
3+
4+import Control.Applicative
5+import Control.DeepSeq
6+import Test.Hspec
7+import Test.QuickCheck
8+
9+import Servant.Common.BaseUrl
10+
11+spec :: Spec
12+spec = do
13+ describe "showBaseUrl" $ do
14+ it "shows a BaseUrl" $ do
15+ showBaseUrl (BaseUrl Http "foo.com" 80) `shouldBe` "http://foo.com"
16+
17+ it "shows a https BaseUrl" $ do
18+ showBaseUrl (BaseUrl Https "foo.com" 443) `shouldBe` "https://foo.com"
19+
20+ describe "httpBaseUrl" $ do
21+ it "allows to construct default http BaseUrls" $ do
22+ BaseUrl Http "bar" 80 `shouldBe` BaseUrl Http "bar" 80
23+
24+ describe "parseBaseUrl" $ do
25+ it "is total" $ do
26+ property $ \ string ->
27+ deepseq (fmap show (parseBaseUrl string)) True
28+
29+ it "is the inverse of showBaseUrl" $ do
30+ property $ \ baseUrl ->
31+ counterexample (showBaseUrl baseUrl) $
32+ parseBaseUrl (showBaseUrl baseUrl) ===
33+ Right baseUrl
34+
35+ it "allows trailing slashes" $ do
36+ parseBaseUrl "foo.com/" `shouldBe` Right (BaseUrl Http "foo.com" 80)
37+
38+ context "urls without scheme" $ do
39+ it "assumes http" $ do
40+ parseBaseUrl "foo.com" `shouldBe` Right (BaseUrl Http "foo.com" 80)
41+
42+ it "allows port numbers" $ do
43+ parseBaseUrl "foo.com:8080" `shouldBe` Right (BaseUrl Http "foo.com" 8080)
44+
45+ it "rejects ftp urls" $ do
46+ parseBaseUrl "ftp://foo.com" `shouldSatisfy` isLeft
47+
48+instance Arbitrary BaseUrl where
49+ arbitrary = BaseUrl <$>
50+ elements [Http, Https] <*>
51+ hostNameGen <*>
52+ portGen
53+ where
54+ -- this does not perfectly mirror the url standard, but I hope it's good
55+ -- enough.
56+ hostNameGen = do
57+ let letters = ['a' .. 'z'] ++ ['A' .. 'Z']
58+ first <- elements letters
59+ middle <- listOf1 $ elements (letters ++ ['0' .. '9'] ++ ['.', '-'])
60+ last <- elements letters
61+ return (first : middle ++ [last])
62+ portGen = frequency $
63+ (1, return 80) :
64+ (1, return 443) :
65+ (1, choose (1, 20000)) :
66+ []
67+
68+isLeft :: Either a b -> Bool
69+isLeft = either (const True) (const False)
test/Spec.hsnew file+1
@@ -0,0 +1 @@
1+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}