commit d93e4620d472e40a6e2212081a02afee358516f6 Author: Alp Mestanogullari Date: Thu Nov 27 18:28:01 2014 +0100 first shot at splitting servant into servant, servant-client and servant-docs diff --git a/servant-client.cabal b/servant-client.cabal new file mode 100644 index 00000000..fdc4b2df --- /dev/null +++ b/servant-client.cabal @@ -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 diff --git a/src/Servant/Client.hs b/src/Servant/Client.hs new file mode 100644 index 00000000..87c9e1d4 --- /dev/null +++ b/src/Servant/Client.hs @@ -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) + diff --git a/src/Servant/Common/BaseUrl.hs b/src/Servant/Common/BaseUrl.hs new file mode 100644 index 00000000..eae87c42 --- /dev/null +++ b/src/Servant/Common/BaseUrl.hs @@ -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 diff --git a/src/Servant/Common/Req.hs b/src/Servant/Common/Req.hs new file mode 100644 index 00000000..62c469d8 --- /dev/null +++ b/src/Servant/Common/Req.hs @@ -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 diff --git a/test/Servant/ClientSpec.hs b/test/Servant/ClientSpec.hs new file mode 100644 index 00000000..c1a2c5d6 --- /dev/null +++ b/test/Servant/ClientSpec.hs @@ -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] diff --git a/test/Servant/Common/BaseUrlSpec.hs b/test/Servant/Common/BaseUrlSpec.hs new file mode 100644 index 00000000..5eef61dc --- /dev/null +++ b/test/Servant/Common/BaseUrlSpec.hs @@ -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) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 00000000..a824f8c3 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}