first shot at splitting servant into servant, servant-client and servant-docs

This commit is contained in:
Alp Mestanogullari 2014-11-27 18:28:01 +01:00
commit d93e4620d4
7 changed files with 839 additions and 0 deletions

59
servant-client.cabal Normal file
View file

@ -0,0 +1,59 @@
name: servant-client
version: 0.2
-- synopsis:
-- description:
license: BSD3
license-file: LICENSE
author: Alp Mestanogullari, Sönke Hahn, Julian K. Arni
maintainer: alpmestan@gmail.com
copyright: 2014 Zalora South East Asia Pte Ltd
category: Web
build-type: Simple
cabal-version: >=1.10
tested-with: GHC >= 7.8
library
exposed-modules:
Servant.Client
Servant.Common.BaseUrl
Servant.Common.Req
build-depends:
base >=4.7 && <5
, aeson
, attoparsec
, bytestring
, either
, exceptions
, http-client
, http-types
, network-uri >= 2.6
, safe
, servant
, string-conversions
, text
, transformers
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -O0 -Wall
test-suite spec
type: exitcode-stdio-1.0
ghc-options:
-Wall -fno-warn-name-shadowing -fno-warn-missing-signatures
default-language: Haskell2010
hs-source-dirs: test
main-is: Spec.hs
build-depends:
base == 4.*
, aeson
, bytestring
, deepseq
, either
, hspec == 2.*
, http-types
, network >= 2.6
, QuickCheck
, servant
, servant-client
, wai
, warp

305
src/Servant/Client.hs Normal file
View file

@ -0,0 +1,305 @@
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | This module provides 'client' which can automatically generate
-- querying functions for each endpoint just from the type representing your
-- API.
module Servant.Client
( client
, HasClient(..)
, module Servant.Common.BaseUrl
) where
import Control.Monad.Trans.Either
import Data.Aeson
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.Types
import Servant.API
import Servant.Common.BaseUrl
import Servant.Common.Req
import Servant.Common.Text
-- * Accessing APIs as a Client
-- | 'client' allows you to produce operations to query an API from a client.
--
-- > type MyApi = "books" :> Get [Book] -- GET /books
-- > :<|> "books" :> ReqBody Book :> Post Book -- POST /books
-- >
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
-- > getAllBooks :: BaseUrl -> EitherT String IO [Book]
-- > postNewBook :: Book -> BaseUrl -> EitherT String IO 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. Use 'client'
-- directly, this class implements the client-side
-- behavior of each combinator but you don't have to worry about it.
class HasClient layout where
type Client layout :: *
clientWithRoute :: Proxy layout -> Req -> Client layout
-- | A client querying function for @a ':<|>' b@ will actually hand you
-- one function for querying @a@ and another one for querying @b@,
-- stitching them together with ':<|>', which really is just like a pair.
--
-- > type MyApi = "books" :> Get [Book] -- GET /books
-- > :<|> "books" :> ReqBody Book :> Post Book -- POST /books
-- >
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
-- > getAllBooks :: BaseUrl -> EitherT String IO [Book]
-- > postNewBook :: Book -> BaseUrl -> EitherT String IO 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 =
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
-- an additional argument of the type specified by your 'Capture'.
-- That function will take care of inserting a textual representation
-- of this value at the right place in the request path.
--
-- You can control how values for this type are turned into
-- text by specifying a 'ToText' instance for your type.
--
-- Example:
--
-- > type MyApi = "books" :> Capture "isbn" Text :> Get Book
-- >
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
-- > getBook :: Text -> BaseUrl -> EitherT String IO Book
-- > getBook = client myApi
-- > -- then you can just use "getBook" to query that endpoint
instance (KnownSymbol capture, ToText a, HasClient sublayout)
=> HasClient (Capture capture a :> sublayout) where
type Client (Capture capture a :> sublayout) =
a -> Client sublayout
clientWithRoute Proxy req val =
clientWithRoute (Proxy :: Proxy sublayout) $
appendToPath p req
where p = unpack (toText val)
-- | If you have a 'Delete' endpoint in your API, the client
-- side querying function that is created when calling 'client'
-- will just require an argument that specifies the scheme, host
-- and port to send the request to.
instance HasClient Delete where
type Client Delete = BaseUrl -> EitherT String IO ()
clientWithRoute Proxy req host =
performRequestJSON methodDelete req 204 host
-- | If you have a 'Get' endpoint in your API, the client
-- side querying function that is created when calling 'client'
-- will just require an argument that specifies the scheme, host
-- and port to send the request to.
instance FromJSON result => HasClient (Get result) where
type Client (Get result) = BaseUrl -> EitherT String IO result
clientWithRoute Proxy req host =
performRequestJSON methodGet req 200 host
-- | If you have a 'Post' endpoint in your API, the client
-- side querying function that is created when calling 'client'
-- will just require an argument that specifies the scheme, host
-- and port to send the request to.
instance FromJSON a => HasClient (Post a) where
type Client (Post a) = BaseUrl -> EitherT String IO a
clientWithRoute Proxy req uri =
performRequestJSON methodPost req 201 uri
-- | If you have a 'Put' endpoint in your API, the client
-- side querying function that is created when calling 'client'
-- will just require an argument that specifies the scheme, host
-- and port to send the request to.
instance FromJSON a => HasClient (Put a) where
type Client (Put a) = BaseUrl -> EitherT String IO a
clientWithRoute Proxy req host =
performRequestJSON methodPut req 200 host
-- | If you use a 'QueryParam' in one of your endpoints in your API,
-- the corresponding querying function will automatically take
-- an additional argument of the type specified by your 'QueryParam',
-- enclosed in Maybe.
--
-- If you give Nothing, nothing will be added to the query string.
--
-- If you give a non-'Nothing' value, this function will take care
-- of inserting a textual representation of this value in the query string.
--
-- You can control how values for your type are turned into
-- text by specifying a 'ToText' instance for your type.
--
-- Example:
--
-- > type MyApi = "books" :> QueryParam "author" Text :> Get [Book]
-- >
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
-- > getBooksBy :: Maybe Text -> BaseUrl -> EitherT String IO [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
instance (KnownSymbol sym, ToText a, HasClient sublayout)
=> HasClient (QueryParam sym a :> sublayout) where
type Client (QueryParam sym a :> sublayout) =
Maybe a -> Client sublayout
-- if mparam = Nothing, we don't add it to the query string
clientWithRoute Proxy req mparam =
clientWithRoute (Proxy :: Proxy sublayout) $
appendToQueryString pname mparamText req
where pname = cs pname'
pname' = symbolVal (Proxy :: Proxy sym)
mparamText = fmap toText mparam
-- | If you use a 'QueryParams' in one of your endpoints in your API,
-- the corresponding querying function will automatically take
-- an additional argument, a list of values of the type specified
-- by your 'QueryParams'.
--
-- If you give an empty list, nothing will be added to the query string.
--
-- Otherwise, this function will take care
-- of inserting a textual representation of your values in the query string,
-- under the same query string parameter name.
--
-- You can control how values for your type are turned into
-- text by specifying a 'ToText' instance for your type.
--
-- Example:
--
-- > type MyApi = "books" :> QueryParams "authors" Text :> Get [Book]
-- >
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
-- > getBooksBy :: [Text] -> BaseUrl -> EitherT String IO [Book]
-- > getBooksBy = client myApi
-- > -- then you can just use "getBooksBy" to query that endpoint.
-- > -- 'getBooksBy []' for all books
-- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]'
-- > -- to get all books by Asimov and Heinlein
instance (KnownSymbol sym, ToText a, HasClient sublayout)
=> HasClient (QueryParams sym a :> sublayout) where
type Client (QueryParams sym a :> sublayout) =
[a] -> Client sublayout
clientWithRoute Proxy req paramlist =
clientWithRoute (Proxy :: Proxy sublayout) $
foldl' (\ value req' -> appendToQueryString pname req' value) req paramlist'
where pname = cs pname'
pname' = symbolVal (Proxy :: Proxy sym)
paramlist' = map (Just . toText) paramlist
-- | If you use a 'QueryFlag' in one of your endpoints in your API,
-- the corresponding querying function will automatically take
-- an additional 'Bool' argument.
--
-- If you give 'False', nothing will be added to the query string.
--
-- Otherwise, this function will insert a value-less query string
-- parameter under the name associated to your 'QueryFlag'.
--
-- Example:
--
-- > type MyApi = "books" :> QueryFlag "published" :> Get [Book]
-- >
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
-- > getBooks :: Bool -> BaseUrl -> EitherT String IO [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
instance (KnownSymbol sym, HasClient sublayout)
=> HasClient (QueryFlag sym :> sublayout) where
type Client (QueryFlag sym :> sublayout) =
Bool -> Client sublayout
clientWithRoute Proxy req flag =
clientWithRoute (Proxy :: Proxy sublayout) $
if flag
then appendToQueryString paramname Nothing req
else req
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
-- | Pick a 'Method' and specify where the server you want to query is. You get
-- back the status code and the response body as a 'ByteString'.
instance HasClient Raw where
type Client Raw = Method -> BaseUrl -> EitherT String IO (Int, ByteString)
clientWithRoute :: Proxy Raw -> Req -> Client Raw
clientWithRoute Proxy req httpMethod host =
performRequest httpMethod req (const True) host
-- | If you use a 'ReqBody' in one of your endpoints in your API,
-- the corresponding querying function will automatically take
-- an additional argument of the type specified by your 'ReqBody'.
-- That function will take care of encoding this argument as JSON and
-- of using it as the request body.
--
-- All you need is for your type to have a 'ToJSON' instance.
--
-- Example:
--
-- > type MyApi = "books" :> ReqBody Book :> Post Book
-- >
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
-- > addBook :: Book -> BaseUrl -> EitherT String IO Book
-- > addBook = client myApi
-- > -- then you can just use "addBook" to query that endpoint
instance (ToJSON a, HasClient sublayout)
=> HasClient (ReqBody a :> sublayout) where
type Client (ReqBody a :> sublayout) =
a -> Client sublayout
clientWithRoute Proxy req body =
clientWithRoute (Proxy :: Proxy sublayout) $
setRQBody (encode body) req
-- | 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 =
clientWithRoute (Proxy :: Proxy sublayout) $
appendToPath p req
where p = symbolVal (Proxy :: Proxy path)

View file

@ -0,0 +1,55 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ViewPatterns #-}
module Servant.Common.BaseUrl where
import Data.List
import GHC.Generics
import Network.URI
import Safe
import Text.Read
-- | URI scheme to use
data Scheme =
Http -- ^ http://
| Https -- ^ https://
deriving (Show, Eq, Ord, Generic)
-- | Simple data type to represent the target of HTTP requests
-- for servant's automatically-generated clients.
data BaseUrl = BaseUrl
{ baseUrlScheme :: Scheme -- ^ URI scheme to use
, baseUrlHost :: String -- ^ host (eg "haskell.org")
, baseUrlPort :: Int -- ^ port (eg 80)
} deriving (Show, Eq, Ord, Generic)
showBaseUrl :: BaseUrl -> String
showBaseUrl (BaseUrl urlscheme host port) =
schemeString ++ "//" ++ host ++ portString
where
schemeString = case urlscheme of
Http -> "http:"
Https -> "https:"
portString = case (urlscheme, port) of
(Http, 80) -> ""
(Https, 443) -> ""
_ -> ":" ++ show port
parseBaseUrl :: String -> Either String BaseUrl
parseBaseUrl s = case parseURI (removeTrailingSlash s) of
-- This is a rather hacky implementation and should be replaced with something
-- implemented in attoparsec (which is already a dependency anyhow (via aeson)).
Just (URI "http:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) "" "" "") ->
Right (BaseUrl Http host port)
Just (URI "http:" (Just (URIAuth "" host "")) "" "" "") ->
Right (BaseUrl Http host 80)
Just (URI "https:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) "" "" "") ->
Right (BaseUrl Https host port)
Just (URI "https:" (Just (URIAuth "" host "")) "" "" "") ->
Right (BaseUrl Https host 443)
_ -> if "://" `isInfixOf` s
then Left ("invalid base url: " ++ s)
else parseBaseUrl ("http://" ++ s)
where
removeTrailingSlash str = case lastMay str of
Just '/' -> init str
_ -> str

132
src/Servant/Common/Req.hs Normal file
View file

@ -0,0 +1,132 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Servant.Common.Req where
import Control.Applicative
import Control.Concurrent
import Control.Exception
import Control.Monad
import Control.Monad.Catch (MonadThrow)
import Control.Monad.IO.Class
import Control.Monad.Trans.Either
import Data.Aeson
import Data.Aeson.Parser
import Data.Aeson.Types
import Data.Attoparsec.ByteString
import Data.ByteString.Lazy
import Data.String.Conversions
import Data.Text
import Network.HTTP.Client
import Network.HTTP.Types
import Network.URI
import Servant.Common.BaseUrl
import System.IO.Unsafe
import qualified Network.HTTP.Client as Client
data Req = Req
{ reqPath :: String
, qs :: QueryText
, reqBody :: ByteString
}
defReq :: Req
defReq = Req "" [] ""
appendToPath :: String -> Req -> Req
appendToPath p req =
req { reqPath = reqPath req ++ "/" ++ p }
appendToQueryString :: Text -- ^ param name
-> Maybe Text -- ^ param value
-> Req
-> Req
appendToQueryString pname pvalue req =
req { qs = qs req ++ [(pname, pvalue)]
}
setRQBody :: ByteString -> Req -> Req
setRQBody b req = req { reqBody = b }
reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request
reqToRequest req (BaseUrl reqScheme reqHost reqPort) = fmap (setrqb . setQS ) $ parseUrl url
where url = show $ nullURI { uriScheme = case reqScheme of
Http -> "http:"
Https -> "https:"
, uriAuthority = Just $
URIAuth { uriUserInfo = ""
, uriRegName = reqHost
, uriPort = ":" ++ show reqPort
}
, uriPath = reqPath req
}
setrqb r = r { requestBody = RequestBodyLBS (reqBody req) }
setQS = setQueryString $ queryTextToQuery (qs req)
-- * performing requests
{-# NOINLINE __manager #-}
__manager :: MVar Manager
__manager = unsafePerformIO (newManager defaultManagerSettings >>= newMVar)
__withGlobalManager :: (Manager -> IO a) -> IO a
__withGlobalManager action = modifyMVar __manager $ \ manager -> do
result <- action manager
return (manager, result)
displayHttpRequest :: Method -> String
displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"
performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl -> EitherT String IO (Int, ByteString)
performRequest reqMethod req isWantedStatus reqHost = do
partialRequest <- liftIO $ reqToRequest req reqHost
let request = partialRequest { Client.method = reqMethod
, checkStatus = \ _status _headers _cookies -> Nothing
}
eResponse <- liftIO $ __withGlobalManager $ \ manager ->
catchStatusCodeException $
Client.httpLbs request manager
case eResponse of
Left status ->
left (displayHttpRequest reqMethod ++ " failed with status: " ++ showStatus status)
Right response -> do
let status = Client.responseStatus response
unless (isWantedStatus (statusCode status)) $
left (displayHttpRequest reqMethod ++ " failed with status: " ++ showStatus status)
return $ (statusCode status, Client.responseBody response)
where
showStatus (Status code message) =
show code ++ " - " ++ cs message
performRequestJSON :: FromJSON result =>
Method -> Req -> Int -> BaseUrl -> EitherT String IO result
performRequestJSON reqMethod req wantedStatus reqHost = do
(_status, respBody) <- performRequest reqMethod req (== wantedStatus) reqHost
either
(\ message -> left (displayHttpRequest reqMethod ++ " returned invalid json: " ++ message))
return
(decodeLenient respBody)
catchStatusCodeException :: IO a -> IO (Either Status a)
catchStatusCodeException action =
catch (Right <$> action) $ \e ->
case e of
Client.StatusCodeException status _ _ -> return $ Left status
exc -> throwIO exc
-- | Like 'Data.Aeson.decode' but allows all JSON values instead of just
-- objects and arrays.
decodeLenient :: FromJSON a => ByteString -> Either String a
decodeLenient input = do
v :: Value <- parseOnly (Data.Aeson.Parser.value <* endOfInput) (cs input)
parseEither parseJSON v

218
test/Servant/ClientSpec.hs Normal file
View file

@ -0,0 +1,218 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE OverloadedStrings #-}
module Servant.ClientSpec where
import Control.Concurrent
import Control.Exception
import Control.Monad.Trans.Either
import Data.Aeson
import Data.ByteString.Lazy (ByteString)
import Data.Char
import Data.Foldable (forM_)
import Data.Proxy
import Data.Typeable
import GHC.Generics
import Network.HTTP.Types
import Network.Socket
import Network.Wai
import Network.Wai.Handler.Warp
import Test.Hspec
import Test.Hspec.QuickCheck
import Test.QuickCheck
import Servant.API
import Servant.Client
import Servant.Server
-- * test data types
data Person = Person {
name :: String,
age :: Integer
}
deriving (Eq, Show, Generic)
instance ToJSON Person
instance FromJSON Person
alice :: Person
alice = Person "Alice" 42
type Api =
"get" :> Get Person
:<|> "capture" :> Capture "name" String :> Get Person
:<|> "body" :> ReqBody Person :> Post Person
:<|> "param" :> QueryParam "name" String :> Get Person
:<|> "params" :> QueryParams "names" String :> Get [Person]
:<|> "flag" :> QueryFlag "flag" :> Get Bool
:<|> "rawSuccess" :> Raw
:<|> "rawFailure" :> Raw
:<|> "multiple" :>
Capture "first" String :>
QueryParam "second" Int :>
QueryFlag "third" :>
ReqBody [(String, [Rational])] :>
Get (String, Maybe Int, Bool, [(String, [Rational])])
api :: Proxy Api
api = Proxy
server :: Application
server = serve api (
return alice
:<|> (\ name -> return $ Person name 0)
:<|> return
:<|> (\ name -> case name of
Just "alice" -> return alice
Just name -> left (400, name ++ " not found")
Nothing -> left (400, "missing parameter"))
:<|> (\ names -> return (zipWith Person names [0..]))
:<|> return
:<|> (\ _request respond -> respond $ responseLBS ok200 [] "rawSuccess")
:<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure")
:<|> \ a b c d -> return (a, b, c, d)
)
withServer :: (BaseUrl -> IO a) -> IO a
withServer action = withWaiDaemon (return server) action
getGet :: BaseUrl -> EitherT String IO Person
getCapture :: String -> BaseUrl -> EitherT String IO Person
getBody :: Person -> BaseUrl -> EitherT String IO Person
getQueryParam :: Maybe String -> BaseUrl -> EitherT String IO Person
getQueryParams :: [String] -> BaseUrl -> EitherT String IO [Person]
getQueryFlag :: Bool -> BaseUrl -> EitherT String IO Bool
getRawSuccess :: Method -> BaseUrl -> EitherT String IO (Int, ByteString)
getRawFailure :: Method -> BaseUrl -> EitherT String IO (Int, ByteString)
getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
-> BaseUrl
-> EitherT String IO (String, Maybe Int, Bool, [(String, [Rational])])
( getGet
:<|> getCapture
:<|> getBody
:<|> getQueryParam
:<|> getQueryParams
:<|> getQueryFlag
:<|> getRawSuccess
:<|> getRawFailure
:<|> getMultiple)
= client api
spec :: Spec
spec = do
it "Servant.API.Get" $ withServer $ \ host -> do
runEitherT (getGet host) `shouldReturn` Right alice
it "Servant.API.Capture" $ withServer $ \ host -> do
runEitherT (getCapture "Paula" host) `shouldReturn` Right (Person "Paula" 0)
it "Servant.API.ReqBody" $ withServer $ \ host -> do
let p = Person "Clara" 42
runEitherT (getBody p host) `shouldReturn` Right p
it "Servant.API.QueryParam" $ withServer $ \ host -> do
runEitherT (getQueryParam (Just "alice") host) `shouldReturn` Right alice
Left result <- runEitherT (getQueryParam (Just "bob") host)
result `shouldContain` "bob not found"
it "Servant.API.QueryParam.QueryParams" $ withServer $ \ host -> do
runEitherT (getQueryParams [] host) `shouldReturn` Right []
runEitherT (getQueryParams ["alice", "bob"] host)
`shouldReturn` Right [Person "alice" 0, Person "bob" 1]
context "Servant.API.QueryParam.QueryFlag" $
forM_ [False, True] $ \ flag ->
it (show flag) $ withServer $ \ host -> do
runEitherT (getQueryFlag flag host) `shouldReturn` Right flag
it "Servant.API.Raw on success" $ withServer $ \ host -> do
runEitherT (getRawSuccess methodGet host) `shouldReturn` Right (200, "rawSuccess")
it "Servant.API.Raw on failure" $ withServer $ \ host -> do
runEitherT (getRawFailure methodGet host) `shouldReturn` Right (400, "rawFailure")
modifyMaxSuccess (const 20) $ do
it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $
property $ forAllShrink pathGen shrink $ \ a -> \ b c d ->
ioProperty $ do
withServer $ \ host -> do
result <- runEitherT (getMultiple a b c d host)
return $
result === Right (a, b, c, d)
context "client correctly handles error status codes" $ do
let test :: WrappedApi -> Spec
test (WrappedApi api) =
it (show (typeOf api)) $
withWaiDaemon (return (serve api (left (500, "error message")))) $
\ host -> do
let getResponse :: BaseUrl -> EitherT String IO ()
getResponse = client api
Left result <- runEitherT (getResponse host)
result `shouldContain` "error message"
mapM_ test $
(WrappedApi (Proxy :: Proxy Delete)) :
(WrappedApi (Proxy :: Proxy (Get ()))) :
(WrappedApi (Proxy :: Proxy (Post ()))) :
(WrappedApi (Proxy :: Proxy (Put ()))) :
[]
data WrappedApi where
WrappedApi :: (HasServer api, Server api ~ EitherT (Int, String) IO a,
HasClient api, Client api ~ (BaseUrl -> EitherT String IO ()),
Typeable api) =>
Proxy api -> WrappedApi
-- * utils
withWaiDaemon :: IO Application -> (BaseUrl -> IO a) -> IO a
withWaiDaemon mkApplication action = do
application <- mkApplication
bracket (acquire application) free (\ (_, _, baseUrl) -> action baseUrl)
where
acquire application = do
(notifyStart, waitForStart) <- lvar
(notifyKilled, waitForKilled) <- lvar
thread <- forkIO $ (do
(krakenPort, socket) <- openTestSocket
let settings =
setPort krakenPort $ -- set here just for consistency, shouldn't be
-- used (it's set in the socket)
setBeforeMainLoop (notifyStart krakenPort)
defaultSettings
runSettingsSocket settings socket application)
`finally` notifyKilled ()
krakenPort <- waitForStart
let baseUrl = (BaseUrl Http "localhost" 80){baseUrlPort = krakenPort}
return (thread, waitForKilled, baseUrl)
free (thread, waitForKilled, _) = do
killThread thread
waitForKilled
lvar :: IO (a -> IO (), IO a)
lvar = do
mvar <- newEmptyMVar
let put = putMVar mvar
wait = readMVar mvar
return (put, wait)
openTestSocket :: IO (Port, Socket)
openTestSocket = do
s <- socket AF_INET Stream defaultProtocol
localhost <- inet_addr "127.0.0.1"
bind s (SockAddrInet aNY_PORT localhost)
listen s 1
port <- socketPort s
return (fromIntegral port, s)
pathGen :: Gen String
pathGen = listOf $ elements $
filter (not . (`elem` "?%[]/#")) $
filter isPrint $
map chr [0..127]

View file

@ -0,0 +1,69 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Servant.Common.BaseUrlSpec where
import Control.Applicative
import Control.DeepSeq
import Test.Hspec
import Test.QuickCheck
import Servant.Common.BaseUrl
spec :: Spec
spec = do
describe "showBaseUrl" $ do
it "shows a BaseUrl" $ do
showBaseUrl (BaseUrl Http "foo.com" 80) `shouldBe` "http://foo.com"
it "shows a https BaseUrl" $ do
showBaseUrl (BaseUrl Https "foo.com" 443) `shouldBe` "https://foo.com"
describe "httpBaseUrl" $ do
it "allows to construct default http BaseUrls" $ do
BaseUrl Http "bar" 80 `shouldBe` BaseUrl Http "bar" 80
describe "parseBaseUrl" $ do
it "is total" $ do
property $ \ string ->
deepseq (fmap show (parseBaseUrl string)) True
it "is the inverse of showBaseUrl" $ do
property $ \ baseUrl ->
counterexample (showBaseUrl baseUrl) $
parseBaseUrl (showBaseUrl baseUrl) ===
Right baseUrl
it "allows trailing slashes" $ do
parseBaseUrl "foo.com/" `shouldBe` Right (BaseUrl Http "foo.com" 80)
context "urls without scheme" $ do
it "assumes http" $ do
parseBaseUrl "foo.com" `shouldBe` Right (BaseUrl Http "foo.com" 80)
it "allows port numbers" $ do
parseBaseUrl "foo.com:8080" `shouldBe` Right (BaseUrl Http "foo.com" 8080)
it "rejects ftp urls" $ do
parseBaseUrl "ftp://foo.com" `shouldSatisfy` isLeft
instance Arbitrary BaseUrl where
arbitrary = BaseUrl <$>
elements [Http, Https] <*>
hostNameGen <*>
portGen
where
-- this does not perfectly mirror the url standard, but I hope it's good
-- enough.
hostNameGen = do
let letters = ['a' .. 'z'] ++ ['A' .. 'Z']
first <- elements letters
middle <- listOf1 $ elements (letters ++ ['0' .. '9'] ++ ['.', '-'])
last <- elements letters
return (first : middle ++ [last])
portGen = frequency $
(1, return 80) :
(1, return 443) :
(1, choose (1, 20000)) :
[]
isLeft :: Either a b -> Bool
isLeft = either (const True) (const False)

1
test/Spec.hs Normal file
View file

@ -0,0 +1 @@
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}