2014-11-27 18:28:01 +01:00
|
|
|
{-# LANGUAGE GADTs #-}
|
|
|
|
{-# LANGUAGE DataKinds #-}
|
|
|
|
{-# LANGUAGE ViewPatterns #-}
|
|
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
|
|
{-# LANGUAGE TypeOperators #-}
|
2015-02-24 23:56:06 +01:00
|
|
|
{-# LANGUAGE RecordWildCards #-}
|
2014-11-27 18:28:01 +01:00
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
2015-01-01 23:43:29 +01:00
|
|
|
{-# OPTIONS_GHC -fcontext-stack=25 #-}
|
2014-11-27 18:28:01 +01:00
|
|
|
module Servant.ClientSpec where
|
|
|
|
|
2015-03-05 02:46:35 +01:00
|
|
|
import Control.Applicative
|
|
|
|
import qualified Control.Arrow as Arrow
|
2014-11-27 18:28:01 +01:00
|
|
|
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_)
|
2015-02-24 23:56:06 +01:00
|
|
|
import Data.Monoid
|
2014-11-27 18:28:01 +01:00
|
|
|
import Data.Proxy
|
2015-02-24 23:56:06 +01:00
|
|
|
import qualified Data.Text as T
|
2014-11-27 18:28:01 +01:00
|
|
|
import GHC.Generics
|
2015-02-17 00:32:15 +01:00
|
|
|
import Network.HTTP.Media
|
2014-11-27 18:28:01 +01:00
|
|
|
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
|
|
|
|
|
2015-02-24 23:56:06 +01:00
|
|
|
instance ToFormUrlEncoded Person where
|
|
|
|
toFormUrlEncoded Person{..} =
|
|
|
|
[("name", T.pack name), ("age", T.pack (show age))]
|
|
|
|
|
|
|
|
lookupEither :: (Show a, Eq a) => a -> [(a,b)] -> Either String b
|
|
|
|
lookupEither x xs = do
|
|
|
|
maybe (Left $ "could not find key " <> show x) return $ lookup x xs
|
|
|
|
|
|
|
|
instance FromFormUrlEncoded Person where
|
|
|
|
fromFormUrlEncoded xs = do
|
|
|
|
n <- lookupEither "name" xs
|
|
|
|
a <- lookupEither "age" xs
|
|
|
|
return $ Person (T.unpack n) (read $ T.unpack a)
|
|
|
|
|
|
|
|
|
2014-11-27 18:28:01 +01:00
|
|
|
alice :: Person
|
|
|
|
alice = Person "Alice" 42
|
|
|
|
|
|
|
|
type Api =
|
2015-02-17 07:17:10 +01:00
|
|
|
"get" :> Get '[JSON] Person
|
2015-02-01 23:33:05 +01:00
|
|
|
:<|> "delete" :> Delete
|
2015-02-24 23:56:06 +01:00
|
|
|
:<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person
|
|
|
|
:<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person
|
|
|
|
:<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person
|
2015-02-17 07:17:10 +01:00
|
|
|
:<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person]
|
|
|
|
:<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool
|
|
|
|
:<|> "matrixparam" :> MatrixParam "name" String :> Get '[JSON] Person
|
|
|
|
:<|> "matrixparams" :> MatrixParams "name" String :> Get '[JSON] [Person]
|
|
|
|
:<|> "matrixflag" :> MatrixFlag "flag" :> Get '[JSON] Bool
|
2014-11-27 18:28:01 +01:00
|
|
|
:<|> "rawSuccess" :> Raw
|
|
|
|
:<|> "rawFailure" :> Raw
|
|
|
|
:<|> "multiple" :>
|
|
|
|
Capture "first" String :>
|
|
|
|
QueryParam "second" Int :>
|
|
|
|
QueryFlag "third" :>
|
2015-02-17 07:17:10 +01:00
|
|
|
ReqBody '[JSON] [(String, [Rational])] :>
|
|
|
|
Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])
|
2014-11-27 18:28:01 +01:00
|
|
|
api :: Proxy Api
|
|
|
|
api = Proxy
|
|
|
|
|
|
|
|
server :: Application
|
|
|
|
server = serve api (
|
|
|
|
return alice
|
2015-02-01 23:33:05 +01:00
|
|
|
:<|> return ()
|
2014-11-27 18:28:01 +01:00
|
|
|
:<|> (\ 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
|
2015-01-01 23:43:29 +01:00
|
|
|
:<|> (\ 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
|
2014-11-27 18:28:01 +01:00
|
|
|
:<|> (\ _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
|
|
|
|
|
2015-03-05 02:46:35 +01:00
|
|
|
getGet :: BaseUrl -> EitherT ServantError IO Person
|
|
|
|
getDelete :: BaseUrl -> EitherT ServantError IO ()
|
|
|
|
getCapture :: String -> BaseUrl -> EitherT ServantError IO Person
|
|
|
|
getBody :: Person -> BaseUrl -> EitherT ServantError IO Person
|
|
|
|
getQueryParam :: Maybe String -> BaseUrl -> EitherT ServantError IO Person
|
|
|
|
getQueryParams :: [String] -> BaseUrl -> EitherT ServantError IO [Person]
|
|
|
|
getQueryFlag :: Bool -> BaseUrl -> EitherT ServantError IO Bool
|
|
|
|
getMatrixParam :: Maybe String -> BaseUrl -> EitherT ServantError IO Person
|
|
|
|
getMatrixParams :: [String] -> BaseUrl -> EitherT ServantError IO [Person]
|
|
|
|
getMatrixFlag :: Bool -> BaseUrl -> EitherT ServantError IO Bool
|
|
|
|
getRawSuccess :: Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType)
|
|
|
|
getRawFailure :: Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType)
|
2014-11-27 18:28:01 +01:00
|
|
|
getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
|
|
|
|
-> BaseUrl
|
2015-03-05 02:46:35 +01:00
|
|
|
-> EitherT ServantError IO (String, Maybe Int, Bool, [(String, [Rational])])
|
2014-11-27 18:28:01 +01:00
|
|
|
( getGet
|
2015-02-01 23:33:05 +01:00
|
|
|
:<|> getDelete
|
2014-11-27 18:28:01 +01:00
|
|
|
:<|> getCapture
|
|
|
|
:<|> getBody
|
|
|
|
:<|> getQueryParam
|
|
|
|
:<|> getQueryParams
|
|
|
|
:<|> getQueryFlag
|
2015-01-01 23:43:29 +01:00
|
|
|
:<|> getMatrixParam
|
|
|
|
:<|> getMatrixParams
|
|
|
|
:<|> getMatrixFlag
|
2014-11-27 18:28:01 +01:00
|
|
|
:<|> getRawSuccess
|
|
|
|
:<|> getRawFailure
|
|
|
|
:<|> getMultiple)
|
|
|
|
= client api
|
|
|
|
|
|
|
|
spec :: Spec
|
|
|
|
spec = do
|
|
|
|
it "Servant.API.Get" $ withServer $ \ host -> do
|
2015-03-05 02:46:35 +01:00
|
|
|
(Arrow.left show <$> runEitherT (getGet host)) `shouldReturn` Right alice
|
2014-11-27 18:28:01 +01:00
|
|
|
|
2015-02-01 23:33:05 +01:00
|
|
|
it "Servant.API.Delete" $ withServer $ \ host -> do
|
2015-03-05 02:46:35 +01:00
|
|
|
(Arrow.left show <$> runEitherT (getDelete host)) `shouldReturn` Right ()
|
2015-02-01 23:33:05 +01:00
|
|
|
|
2014-11-27 18:28:01 +01:00
|
|
|
it "Servant.API.Capture" $ withServer $ \ host -> do
|
2015-03-05 02:46:35 +01:00
|
|
|
(Arrow.left show <$> runEitherT (getCapture "Paula" host)) `shouldReturn` Right (Person "Paula" 0)
|
2014-11-27 18:28:01 +01:00
|
|
|
|
|
|
|
it "Servant.API.ReqBody" $ withServer $ \ host -> do
|
|
|
|
let p = Person "Clara" 42
|
2015-03-05 02:46:35 +01:00
|
|
|
(Arrow.left show <$> runEitherT (getBody p host)) `shouldReturn` Right p
|
2014-11-27 18:28:01 +01:00
|
|
|
|
|
|
|
it "Servant.API.QueryParam" $ withServer $ \ host -> do
|
2015-03-05 02:46:35 +01:00
|
|
|
(Arrow.left show <$> runEitherT (getQueryParam (Just "alice") host)) `shouldReturn` Right alice
|
|
|
|
Left (FailureResponse s _ _) <- runEitherT (getQueryParam (Just "bob") host)
|
|
|
|
statusCode s `shouldBe` 400
|
2014-11-27 18:28:01 +01:00
|
|
|
|
|
|
|
it "Servant.API.QueryParam.QueryParams" $ withServer $ \ host -> do
|
2015-03-05 02:46:35 +01:00
|
|
|
(Arrow.left show <$> runEitherT (getQueryParams [] host)) `shouldReturn` Right []
|
|
|
|
(Arrow.left show <$> runEitherT (getQueryParams ["alice", "bob"] host))
|
2014-11-27 18:28:01 +01:00
|
|
|
`shouldReturn` Right [Person "alice" 0, Person "bob" 1]
|
|
|
|
|
|
|
|
context "Servant.API.QueryParam.QueryFlag" $
|
|
|
|
forM_ [False, True] $ \ flag ->
|
|
|
|
it (show flag) $ withServer $ \ host -> do
|
2015-03-05 02:46:35 +01:00
|
|
|
(Arrow.left show <$> runEitherT (getQueryFlag flag host)) `shouldReturn` Right flag
|
2014-11-27 18:28:01 +01:00
|
|
|
|
2015-02-17 07:17:10 +01:00
|
|
|
{-
|
2015-01-01 23:43:29 +01:00
|
|
|
it "Servant.API.MatrixParam" $ withServer $ \ host -> do
|
|
|
|
runEitherT (getMatrixParam (Just "alice") host) `shouldReturn` Right alice
|
|
|
|
Left result <- runEitherT (getMatrixParam (Just "bob") host)
|
|
|
|
result `shouldContain` "bob not found"
|
|
|
|
|
|
|
|
it "Servant.API.MatrixParam.MatrixParams" $ withServer $ \ host -> do
|
|
|
|
runEitherT (getMatrixParams [] host) `shouldReturn` Right []
|
|
|
|
runEitherT (getMatrixParams ["alice", "bob"] host)
|
|
|
|
`shouldReturn` Right [Person "alice" 0, Person "bob" 1]
|
|
|
|
|
|
|
|
context "Servant.API.MatrixParam.MatrixFlag" $
|
|
|
|
forM_ [False, True] $ \ flag ->
|
|
|
|
it (show flag) $ withServer $ \ host -> do
|
|
|
|
runEitherT (getMatrixFlag flag host) `shouldReturn` Right flag
|
2015-02-17 07:17:10 +01:00
|
|
|
-}
|
2015-01-01 23:43:29 +01:00
|
|
|
|
2014-11-27 18:28:01 +01:00
|
|
|
it "Servant.API.Raw on success" $ withServer $ \ host -> do
|
2015-03-05 02:46:35 +01:00
|
|
|
(Arrow.left show <$> runEitherT (getRawSuccess methodGet host))
|
|
|
|
`shouldReturn` Right (200, "rawSuccess", "application"//"octet-stream")
|
2014-11-27 18:28:01 +01:00
|
|
|
|
|
|
|
it "Servant.API.Raw on failure" $ withServer $ \ host -> do
|
2015-03-05 02:46:35 +01:00
|
|
|
(Arrow.left show <$> runEitherT (getRawFailure methodGet host))
|
|
|
|
`shouldReturn` Right (400, "rawFailure", "application"//"octet-stream")
|
2014-11-27 18:28:01 +01:00
|
|
|
|
|
|
|
modifyMaxSuccess (const 20) $ do
|
|
|
|
it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $
|
2015-02-02 03:35:10 +01:00
|
|
|
property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
|
2014-11-27 18:28:01 +01:00
|
|
|
ioProperty $ do
|
|
|
|
withServer $ \ host -> do
|
2015-03-05 02:46:35 +01:00
|
|
|
result <- Arrow.left show <$> runEitherT (getMultiple cap num flag body host)
|
2014-11-27 18:28:01 +01:00
|
|
|
return $
|
2015-02-02 03:35:10 +01:00
|
|
|
result === Right (cap, num, flag, body)
|
2014-11-27 18:28:01 +01:00
|
|
|
|
|
|
|
|
|
|
|
context "client correctly handles error status codes" $ do
|
2015-02-17 07:17:10 +01:00
|
|
|
let test :: (WrappedApi, String) -> Spec
|
|
|
|
test (WrappedApi api, desc) =
|
|
|
|
it desc $
|
2014-11-27 18:28:01 +01:00
|
|
|
withWaiDaemon (return (serve api (left (500, "error message")))) $
|
|
|
|
\ host -> do
|
2015-03-05 02:46:35 +01:00
|
|
|
let getResponse :: BaseUrl -> EitherT ServantError IO ()
|
2014-11-27 18:28:01 +01:00
|
|
|
getResponse = client api
|
2015-03-05 02:46:35 +01:00
|
|
|
Left (FailureResponse status _ _) <- runEitherT (getResponse host)
|
|
|
|
status `shouldBe` (Status 500 "error message")
|
2014-11-27 18:28:01 +01:00
|
|
|
mapM_ test $
|
2015-02-17 07:17:10 +01:00
|
|
|
(WrappedApi (Proxy :: Proxy Delete), "Delete") :
|
|
|
|
(WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Delete") :
|
|
|
|
(WrappedApi (Proxy :: Proxy (Post '[JSON] ())), "Delete") :
|
|
|
|
(WrappedApi (Proxy :: Proxy (Put '[JSON] ())), "Delete") :
|
2014-11-27 18:28:01 +01:00
|
|
|
[]
|
|
|
|
|
|
|
|
data WrappedApi where
|
|
|
|
WrappedApi :: (HasServer api, Server api ~ EitherT (Int, String) IO a,
|
2015-03-05 02:46:35 +01:00
|
|
|
HasClient api, Client api ~ (BaseUrl -> EitherT ServantError IO ())) =>
|
2014-11-27 18:28:01 +01:00
|
|
|
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)
|
|
|
|
|
2015-02-02 03:35:10 +01:00
|
|
|
pathGen :: Gen (NonEmptyList Char)
|
|
|
|
pathGen = fmap NonEmpty path
|
|
|
|
where
|
|
|
|
path = listOf1 $ elements $
|
|
|
|
filter (not . (`elem` "?%[]/#;")) $
|
|
|
|
filter isPrint $
|
|
|
|
map chr [0..127]
|