eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Merge branch 'master' into servant-dates-new

Browse source 
# Conflicts:
#	servant/CHANGELOG.md
This commit is contained in:
Alex Mason 2016-09-12 11:27:05 +10:00
commit 5247980860
22 changed files with 130 additions and 519 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

27
doc/tutorial/Client.lhs
View file

@ -15,11 +15,10 @@ need to have some language extensions and imports:
module Client where module Client where
import Control.Monad.Trans.Except (ExceptT, runExceptT)
import Data.Aeson import Data.Aeson
import Data.Proxy import Data.Proxy
import GHC.Generics import GHC.Generics
import Network.HTTP.Client (Manager, newManager, defaultManagerSettings) import Network.HTTP.Client (newManager, defaultManagerSettings)
import Servant.API import Servant.API
import Servant.Client import Servant.Client
``` ```
@ -71,19 +70,13 @@ What we are going to get with **servant-client** here is 3 functions, one to que
``` haskell ``` haskell
position :: Int -- ^ value for "x" position :: Int -- ^ value for "x"
-> Int -- ^ value for "y" -> Int -- ^ value for "y"
-> Manager -- ^ the HTTP client to use -> ClientM Position
-> BaseUrl -- ^ the URL at which the API can be found
-> ExceptT ServantError IO Position
hello :: Maybe String -- ^ an optional value for "name" hello :: Maybe String -- ^ an optional value for "name"
-> Manager -- ^ the HTTP client to use -> ClientM HelloMessage
-> BaseUrl -- ^ the URL at which the API can be found
-> ExceptT ServantError IO HelloMessage
marketing :: ClientInfo -- ^ value for the request body marketing :: ClientInfo -- ^ value for the request body
-> Manager -- ^ the HTTP client to use -> ClientM Email
-> BaseUrl -- ^ the URL at which the API can be found
-> ExceptT ServantError IO Email
``` ```
Each function makes available as an argument any value that the response may Each function makes available as an argument any value that the response may
@ -120,17 +113,17 @@ data BaseUrl = BaseUrl
That's it. Let's now write some code that uses our client functions. That's it. Let's now write some code that uses our client functions.
``` haskell ``` haskell
queries :: Manager -> BaseUrl -> ExceptT ServantError IO (Position, HelloMessage, Email) queries :: ClientM (Position, HelloMessage, Email)
queries manager baseurl = do queries = do
pos <- position 10 10 manager baseurl pos <- position 10 10
message <- hello (Just "servant") manager baseurl message <- hello (Just "servant")
em <- marketing (ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"]) manager baseurl em <- marketing (ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"])
return (pos, message, em) return (pos, message, em)
run :: IO () run :: IO ()
run = do run = do
manager <- newManager defaultManagerSettings manager <- newManager defaultManagerSettings
res <- runExceptT (queries manager (BaseUrl Http "localhost" 8081 "")) res <- runClientM queries (ClientEnv manager (BaseUrl Http "localhost" 8081 ""))
case res of case res of
Left err -> putStrLn $ "Error: " ++ show err Left err -> putStrLn $ "Error: " ++ show err
Right (pos, message, em) -> do Right (pos, message, em) -> do

8
servant-client/CHANGELOG.md
View file

@ -1,3 +1,11 @@
0.8.1
-----
* BACKWARDS INCOMPATIBLE: `client` now returns a ClientM which is a Reader for
BasicEnv. BasicEnv comprises the HttpManager and BaseUrl that have had to be
passed to each method returned by `client`.
0.7.1 0.7.1
----- -----

1
servant-client/servant-client.cabal
View file

@ -53,6 +53,7 @@ library
, text >= 1.2 && < 1.3 , text >= 1.2 && < 1.3
, transformers >= 0.3 && < 0.6 , transformers >= 0.3 && < 0.6
, transformers-compat >= 0.4 && < 0.6 , transformers-compat >= 0.4 && < 0.6
, mtl
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall ghc-options: -Wall

30
servant-client/src/Servant/Client.hs
View file

@ -20,6 +20,8 @@ module Servant.Client
, client , client
, HasClient(..) , HasClient(..)
, ClientM , ClientM
, runClientM
, ClientEnv (ClientEnv)
, mkAuthenticateReq , mkAuthenticateReq
, ServantError(..) , ServantError(..)
, module Servant.Common.BaseUrl , module Servant.Common.BaseUrl
@ -34,7 +36,7 @@ import Data.Proxy
import Data.String.Conversions import Data.String.Conversions
import Data.Text (unpack) import Data.Text (unpack)
import GHC.TypeLits import GHC.TypeLits
import Network.HTTP.Client (Manager, Response) import Network.HTTP.Client (Response)
import Network.HTTP.Media import Network.HTTP.Media
import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types as H
import qualified Network.HTTP.Types.Header as HTTP import qualified Network.HTTP.Types.Header as HTTP
@ -154,17 +156,17 @@ instance OVERLAPPABLE_
-- Note [Non-Empty Content Types] -- Note [Non-Empty Content Types]
(MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts) (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
) => HasClient (Verb method status cts' a) where ) => HasClient (Verb method status cts' a) where
type Client (Verb method status cts' a) = Manager -> BaseUrl -> ClientM a type Client (Verb method status cts' a) = ClientM a
clientWithRoute Proxy req manager baseurl = clientWithRoute Proxy req = do
snd <$> performRequestCT (Proxy :: Proxy ct) method req manager baseurl snd <$> performRequestCT (Proxy :: Proxy ct) method req
where method = reflectMethod (Proxy :: Proxy method) where method = reflectMethod (Proxy :: Proxy method)
instance OVERLAPPING_ instance OVERLAPPING_
(ReflectMethod method) => HasClient (Verb method status cts NoContent) where (ReflectMethod method) => HasClient (Verb method status cts NoContent) where
type Client (Verb method status cts NoContent) type Client (Verb method status cts NoContent)
= Manager -> BaseUrl -> ClientM NoContent = ClientM NoContent
clientWithRoute Proxy req manager baseurl = clientWithRoute Proxy req = do
performRequestNoBody method req manager baseurl >> return NoContent performRequestNoBody method req >> return NoContent
where method = reflectMethod (Proxy :: Proxy method) where method = reflectMethod (Proxy :: Proxy method)
instance OVERLAPPING_ instance OVERLAPPING_
@ -172,10 +174,10 @@ instance OVERLAPPING_
( MimeUnrender ct a, BuildHeadersTo ls, ReflectMethod method, cts' ~ (ct ': cts) ( MimeUnrender ct a, BuildHeadersTo ls, ReflectMethod method, cts' ~ (ct ': cts)
) => HasClient (Verb method status cts' (Headers ls a)) where ) => HasClient (Verb method status cts' (Headers ls a)) where
type Client (Verb method status cts' (Headers ls a)) type Client (Verb method status cts' (Headers ls a))
= Manager -> BaseUrl -> ClientM (Headers ls a) = ClientM (Headers ls a)
clientWithRoute Proxy req manager baseurl = do clientWithRoute Proxy req = do
let method = reflectMethod (Proxy :: Proxy method) let method = reflectMethod (Proxy :: Proxy method)
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req manager baseurl (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req
return $ Headers { getResponse = resp return $ Headers { getResponse = resp
, getHeadersHList = buildHeadersTo hdrs , getHeadersHList = buildHeadersTo hdrs
} }
@ -184,10 +186,10 @@ instance OVERLAPPING_
( BuildHeadersTo ls, ReflectMethod method ( BuildHeadersTo ls, ReflectMethod method
) => HasClient (Verb method status cts (Headers ls NoContent)) where ) => HasClient (Verb method status cts (Headers ls NoContent)) where
type Client (Verb method status cts (Headers ls NoContent)) type Client (Verb method status cts (Headers ls NoContent))
= Manager -> BaseUrl -> ClientM (Headers ls NoContent) = ClientM (Headers ls NoContent)
clientWithRoute Proxy req manager baseurl = do clientWithRoute Proxy req = do
let method = reflectMethod (Proxy :: Proxy method) let method = reflectMethod (Proxy :: Proxy method)
hdrs <- performRequestNoBody method req manager baseurl hdrs <- performRequestNoBody method req
return $ Headers { getResponse = NoContent return $ Headers { getResponse = NoContent
, getHeadersHList = buildHeadersTo hdrs , getHeadersHList = buildHeadersTo hdrs
} }
@ -372,7 +374,7 @@ instance (KnownSymbol sym, HasClient api)
-- back the full `Response`. -- back the full `Response`.
instance HasClient Raw where instance HasClient Raw where
type Client Raw type Client Raw
= H.Method -> Manager -> BaseUrl -> ClientM (Int, ByteString, MediaType, [HTTP.Header], Response ByteString) = H.Method -> ClientM (Int, ByteString, MediaType, [HTTP.Header], Response ByteString)
clientWithRoute :: Proxy Raw -> Req -> Client Raw clientWithRoute :: Proxy Raw -> Req -> Client Raw
clientWithRoute Proxy req httpMethod = do clientWithRoute Proxy req httpMethod = do

69
servant-client/src/Servant/Common/Req.hs
View file

@ -1,7 +1,10 @@
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Servant.Common.Req where module Servant.Common.Req where
#if !MIN_VERSION_base(4,8,0) #if !MIN_VERSION_base(4,8,0)
@ -10,8 +13,18 @@ import Control.Applicative
import Control.Exception import Control.Exception
import Control.Monad import Control.Monad
import Control.Monad.Catch (MonadThrow) import Control.Monad.Catch (MonadThrow)
import Control.Monad.IO.Class
#if MIN_VERSION_mtl(2,2,0)
import Control.Monad.Except (MonadError(..))
#else
import Control.Monad.Error.Class (MonadError(..))
#endif
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
import GHC.Generics
import Control.Monad.IO.Class ()
import Control.Monad.Reader
import Data.ByteString.Lazy hiding (pack, filter, map, null, elem) import Data.ByteString.Lazy hiding (pack, filter, map, null, elem)
import Data.String import Data.String
import Data.String.Conversions import Data.String.Conversions
@ -19,9 +32,9 @@ import Data.Proxy
import Data.Text (Text) import Data.Text (Text)
import Data.Text.Encoding import Data.Text.Encoding
import Data.Typeable import Data.Typeable
import Network.HTTP.Client hiding (Proxy, path)
import Network.HTTP.Media import Network.HTTP.Media
import Network.HTTP.Types import Network.HTTP.Types
import Network.HTTP.Client hiding (Proxy, path)
import qualified Network.HTTP.Types.Header as HTTP import qualified Network.HTTP.Types.Header as HTTP
import Network.URI hiding (path) import Network.URI hiding (path)
import Servant.API.ContentTypes import Servant.API.ContentTypes
@ -149,20 +162,40 @@ parseRequest url = liftM disableStatusCheck (parseUrl url)
displayHttpRequest :: Method -> String displayHttpRequest :: Method -> String
displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request" displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"
type ClientM = ExceptT ServantError IO data ClientEnv
= ClientEnv
{ manager :: Manager
, baseUrl :: BaseUrl
}
performRequest :: Method -> Req -> Manager -> BaseUrl
-- | @ClientM@ is the monad in which client functions run. Contains the
-- 'Manager' and 'BaseUrl' used for requests in the reader environment.
newtype ClientM a = ClientM { runClientM' :: ReaderT ClientEnv (ExceptT ServantError IO) a }
deriving ( Functor, Applicative, Monad, MonadIO, Generic
, MonadReader ClientEnv
, MonadError ServantError
)
runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)
runClientM cm env = runExceptT $ (flip runReaderT env) $ runClientM' cm
performRequest :: Method -> Req
-> ClientM ( Int, ByteString, MediaType -> ClientM ( Int, ByteString, MediaType
, [HTTP.Header], Response ByteString) , [HTTP.Header], Response ByteString)
performRequest reqMethod req manager reqHost = do performRequest reqMethod req = do
m <- asks manager
reqHost <- asks baseUrl
partialRequest <- liftIO $ reqToRequest req reqHost partialRequest <- liftIO $ reqToRequest req reqHost
let request = partialRequest { Client.method = reqMethod } let request = partialRequest { Client.method = reqMethod }
eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request manager eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request m
case eResponse of case eResponse of
Left err -> Left err ->
throwE . ConnectionError $ SomeException err throwError . ConnectionError $ SomeException err
Right response -> do Right response -> do
let status = Client.responseStatus response let status = Client.responseStatus response
@ -172,28 +205,26 @@ performRequest reqMethod req manager reqHost = do
ct <- case lookup "Content-Type" $ Client.responseHeaders response of ct <- case lookup "Content-Type" $ Client.responseHeaders response of
Nothing -> pure $ "application"//"octet-stream" Nothing -> pure $ "application"//"octet-stream"
Just t -> case parseAccept t of Just t -> case parseAccept t of
Nothing -> throwE $ InvalidContentTypeHeader (cs t) body Nothing -> throwError $ InvalidContentTypeHeader (cs t) body
Just t' -> pure t' Just t' -> pure t'
unless (status_code >= 200 && status_code < 300) $ unless (status_code >= 200 && status_code < 300) $
throwE $ FailureResponse status ct body throwError $ FailureResponse status ct body
return (status_code, body, ct, hdrs, response) return (status_code, body, ct, hdrs, response)
performRequestCT :: MimeUnrender ct result => performRequestCT :: MimeUnrender ct result => Proxy ct -> Method -> Req
Proxy ct -> Method -> Req -> Manager -> BaseUrl
-> ClientM ([HTTP.Header], result) -> ClientM ([HTTP.Header], result)
performRequestCT ct reqMethod req manager reqHost = do performRequestCT ct reqMethod req = do
let acceptCT = contentType ct let acceptCT = contentType ct
(_status, respBody, respCT, hdrs, _response) <- (_status, respBody, respCT, hdrs, _response) <-
performRequest reqMethod (req { reqAccept = [acceptCT] }) manager reqHost performRequest reqMethod (req { reqAccept = [acceptCT] })
unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody unless (matches respCT (acceptCT)) $ throwError $ UnsupportedContentType respCT respBody
case mimeUnrender ct respBody of case mimeUnrender ct respBody of
Left err -> throwE $ DecodeFailure err respCT respBody Left err -> throwError $ DecodeFailure err respCT respBody
Right val -> return (hdrs, val) Right val -> return (hdrs, val)
performRequestNoBody :: Method -> Req -> Manager -> BaseUrl performRequestNoBody :: Method -> Req -> ClientM [HTTP.Header]
-> ClientM [HTTP.Header] performRequestNoBody reqMethod req = do
performRequestNoBody reqMethod req manager reqHost = do (_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req
(_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req manager reqHost
return hdrs return hdrs
catchConnectionError :: IO a -> IO (Either ServantError a) catchConnectionError :: IO a -> IO (Either ServantError a)

82
servant-client/test/Servant/ClientSpec.hs
View file

@ -32,7 +32,7 @@ import Control.Applicative ((<$>))
import Control.Arrow (left) import Control.Arrow (left)
import Control.Concurrent (forkIO, killThread, ThreadId) import Control.Concurrent (forkIO, killThread, ThreadId)
import Control.Exception (bracket) import Control.Exception (bracket)
import Control.Monad.Trans.Except (throwE, runExceptT) import Control.Monad.Trans.Except (throwE )
import Data.Aeson import Data.Aeson
import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy as BS
import Data.Char (chr, isPrint) import Data.Char (chr, isPrint)
@ -123,22 +123,22 @@ type Api =
api :: Proxy Api api :: Proxy Api
api = Proxy api = Proxy
getGet :: C.Manager -> BaseUrl -> SCR.ClientM Person getGet :: SCR.ClientM Person
getDeleteEmpty :: C.Manager -> BaseUrl -> SCR.ClientM NoContent getDeleteEmpty :: SCR.ClientM NoContent
getCapture :: String -> C.Manager -> BaseUrl -> SCR.ClientM Person getCapture :: String -> SCR.ClientM Person
getCaptureAll :: [String] -> C.Manager -> BaseUrl -> SCR.ClientM [Person] getCaptureAll :: [String] -> SCR.ClientM [Person]
getBody :: Person -> C.Manager -> BaseUrl -> SCR.ClientM Person getBody :: Person -> SCR.ClientM Person
getQueryParam :: Maybe String -> C.Manager -> BaseUrl -> SCR.ClientM Person getQueryParam :: Maybe String -> SCR.ClientM Person
getQueryParams :: [String] -> C.Manager -> BaseUrl -> SCR.ClientM [Person] getQueryParams :: [String] -> SCR.ClientM [Person]
getQueryFlag :: Bool -> C.Manager -> BaseUrl -> SCR.ClientM Bool getQueryFlag :: Bool -> SCR.ClientM Bool
getRawSuccess :: HTTP.Method -> C.Manager -> BaseUrl getRawSuccess :: HTTP.Method
-> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString) -> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString)
getRawFailure :: HTTP.Method -> C.Manager -> BaseUrl getRawFailure :: HTTP.Method
-> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString) -> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString)
getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] -> C.Manager -> BaseUrl getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
-> SCR.ClientM (String, Maybe Int, Bool, [(String, [Rational])]) -> SCR.ClientM (String, Maybe Int, Bool, [(String, [Rational])])
getRespHeaders :: C.Manager -> BaseUrl -> SCR.ClientM (Headers TestHeaders Bool) getRespHeaders :: SCR.ClientM (Headers TestHeaders Bool)
getDeleteContentType :: C.Manager -> BaseUrl -> SCR.ClientM NoContent getDeleteContentType :: SCR.ClientM NoContent
getGet getGet
:<|> getDeleteEmpty :<|> getDeleteEmpty
:<|> getCapture :<|> getCapture
@ -242,42 +242,42 @@ sucessSpec :: Spec
sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
it "Servant.API.Get" $ \(_, baseUrl) -> do it "Servant.API.Get" $ \(_, baseUrl) -> do
(left show <$> runExceptT (getGet manager baseUrl)) `shouldReturn` Right alice (left show <$> (runClientM getGet (ClientEnv manager baseUrl))) `shouldReturn` Right alice
describe "Servant.API.Delete" $ do describe "Servant.API.Delete" $ do
it "allows empty content type" $ \(_, baseUrl) -> do it "allows empty content type" $ \(_, baseUrl) -> do
(left show <$> runExceptT (getDeleteEmpty manager baseUrl)) `shouldReturn` Right NoContent (left show <$> (runClientM getDeleteEmpty (ClientEnv manager baseUrl))) `shouldReturn` Right NoContent
it "allows content type" $ \(_, baseUrl) -> do it "allows content type" $ \(_, baseUrl) -> do
(left show <$> runExceptT (getDeleteContentType manager baseUrl)) `shouldReturn` Right NoContent (left show <$> (runClientM getDeleteContentType (ClientEnv manager baseUrl))) `shouldReturn` Right NoContent
it "Servant.API.Capture" $ \(_, baseUrl) -> do it "Servant.API.Capture" $ \(_, baseUrl) -> do
(left show <$> runExceptT (getCapture "Paula" manager baseUrl)) `shouldReturn` Right (Person "Paula" 0) (left show <$> (runClientM (getCapture "Paula") (ClientEnv manager baseUrl))) `shouldReturn` Right (Person "Paula" 0)
it "Servant.API.CaptureAll" $ \(_, baseUrl) -> do it "Servant.API.CaptureAll" $ \(_, baseUrl) -> do
let expected = [(Person "Paula" 0), (Person "Peta" 1)] let expected = [(Person "Paula" 0), (Person "Peta" 1)]
(left show <$> runExceptT (getCaptureAll ["Paula", "Peta"] manager baseUrl)) `shouldReturn` Right expected (left show <$> (runClientM (getCaptureAll ["Paula", "Peta"]) (ClientEnv manager baseUrl))) `shouldReturn` Right expected
it "Servant.API.ReqBody" $ \(_, baseUrl) -> do it "Servant.API.ReqBody" $ \(_, baseUrl) -> do
let p = Person "Clara" 42 let p = Person "Clara" 42
(left show <$> runExceptT (getBody p manager baseUrl)) `shouldReturn` Right p (left show <$> runClientM (getBody p) (ClientEnv manager baseUrl)) `shouldReturn` Right p
it "Servant.API.QueryParam" $ \(_, baseUrl) -> do it "Servant.API.QueryParam" $ \(_, baseUrl) -> do
left show <$> runExceptT (getQueryParam (Just "alice") manager baseUrl) `shouldReturn` Right alice left show <$> runClientM (getQueryParam (Just "alice")) (ClientEnv manager baseUrl) `shouldReturn` Right alice
Left FailureResponse{..} <- runExceptT (getQueryParam (Just "bob") manager baseUrl) Left FailureResponse{..} <- runClientM (getQueryParam (Just "bob")) (ClientEnv manager baseUrl)
responseStatus `shouldBe` HTTP.Status 400 "bob not found" responseStatus `shouldBe` HTTP.Status 400 "bob not found"
it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do
(left show <$> runExceptT (getQueryParams [] manager baseUrl)) `shouldReturn` Right [] (left show <$> runClientM (getQueryParams []) (ClientEnv manager baseUrl)) `shouldReturn` Right []
(left show <$> runExceptT (getQueryParams ["alice", "bob"] manager baseUrl)) (left show <$> runClientM (getQueryParams ["alice", "bob"]) (ClientEnv manager baseUrl))
`shouldReturn` Right [Person "alice" 0, Person "bob" 1] `shouldReturn` Right [Person "alice" 0, Person "bob" 1]
context "Servant.API.QueryParam.QueryFlag" $ context "Servant.API.QueryParam.QueryFlag" $
forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do
(left show <$> runExceptT (getQueryFlag flag manager baseUrl)) `shouldReturn` Right flag (left show <$> runClientM (getQueryFlag flag) (ClientEnv manager baseUrl)) `shouldReturn` Right flag
it "Servant.API.Raw on success" $ \(_, baseUrl) -> do it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
res <- runExceptT (getRawSuccess HTTP.methodGet manager baseUrl) res <- runClientM (getRawSuccess HTTP.methodGet) (ClientEnv manager baseUrl)
case res of case res of
Left e -> assertFailure $ show e Left e -> assertFailure $ show e
Right (code, body, ct, _, response) -> do Right (code, body, ct, _, response) -> do
@ -286,7 +286,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
C.responseStatus response `shouldBe` HTTP.ok200 C.responseStatus response `shouldBe` HTTP.ok200
it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do
res <- runExceptT (getRawFailure HTTP.methodGet manager baseUrl) res <- runClientM (getRawFailure HTTP.methodGet) (ClientEnv manager baseUrl)
case res of case res of
Right _ -> assertFailure "expected Left, but got Right" Right _ -> assertFailure "expected Left, but got Right"
Left e -> do Left e -> do
@ -294,7 +294,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
Servant.Client.responseBody e `shouldBe` "rawFailure" Servant.Client.responseBody e `shouldBe` "rawFailure"
it "Returns headers appropriately" $ \(_, baseUrl) -> do it "Returns headers appropriately" $ \(_, baseUrl) -> do
res <- runExceptT (getRespHeaders manager baseUrl) res <- runClientM getRespHeaders (ClientEnv manager baseUrl)
case res of case res of
Left e -> assertFailure $ show e Left e -> assertFailure $ show e
Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")] Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
@ -303,7 +303,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) -> it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) ->
property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body -> property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
ioProperty $ do ioProperty $ do
result <- left show <$> runExceptT (getMultiple cap num flag body manager baseUrl) result <- left show <$> runClientM (getMultiple cap num flag body) (ClientEnv manager baseUrl)
return $ return $
result === Right (cap, num, flag, body) result === Right (cap, num, flag, body)
@ -315,9 +315,9 @@ wrappedApiSpec = describe "error status codes" $ do
let test :: (WrappedApi, String) -> Spec let test :: (WrappedApi, String) -> Spec
test (WrappedApi api, desc) = test (WrappedApi api, desc) =
it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do
let getResponse :: C.Manager -> BaseUrl -> SCR.ClientM () let getResponse :: SCR.ClientM ()
getResponse = client api getResponse = client api
Left FailureResponse{..} <- runExceptT (getResponse manager baseUrl) Left FailureResponse{..} <- runClientM getResponse (ClientEnv manager baseUrl)
responseStatus `shouldBe` (HTTP.Status 500 "error message") responseStatus `shouldBe` (HTTP.Status 500 "error message")
in mapM_ test $ in mapM_ test $
(WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") : (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :
@ -332,42 +332,42 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
context "client returns errors appropriately" $ do context "client returns errors appropriately" $ do
it "reports FailureResponse" $ \(_, baseUrl) -> do it "reports FailureResponse" $ \(_, baseUrl) -> do
let (_ :<|> getDeleteEmpty :<|> _) = client api let (_ :<|> getDeleteEmpty :<|> _) = client api
Left res <- runExceptT (getDeleteEmpty manager baseUrl) Left res <- runClientM getDeleteEmpty (ClientEnv manager baseUrl)
case res of case res of
FailureResponse (HTTP.Status 404 "Not Found") _ _ -> return () FailureResponse (HTTP.Status 404 "Not Found") _ _ -> return ()
_ -> fail $ "expected 404 response, but got " <> show res _ -> fail $ "expected 404 response, but got " <> show res
it "reports DecodeFailure" $ \(_, baseUrl) -> do it "reports DecodeFailure" $ \(_, baseUrl) -> do
let (_ :<|> _ :<|> getCapture :<|> _) = client api let (_ :<|> _ :<|> getCapture :<|> _) = client api
Left res <- runExceptT (getCapture "foo" manager baseUrl) Left res <- runClientM (getCapture "foo") (ClientEnv manager baseUrl)
case res of case res of
DecodeFailure _ ("application/json") _ -> return () DecodeFailure _ ("application/json") _ -> return ()
_ -> fail $ "expected DecodeFailure, but got " <> show res _ -> fail $ "expected DecodeFailure, but got " <> show res
it "reports ConnectionError" $ \_ -> do it "reports ConnectionError" $ \_ -> do
let (getGetWrongHost :<|> _) = client api let (getGetWrongHost :<|> _) = client api
Left res <- runExceptT (getGetWrongHost manager (BaseUrl Http "127.0.0.1" 19872 "")) Left res <- runClientM getGetWrongHost (ClientEnv manager (BaseUrl Http "127.0.0.1" 19872 ""))
case res of case res of
ConnectionError _ -> return () ConnectionError _ -> return ()
_ -> fail $ "expected ConnectionError, but got " <> show res _ -> fail $ "expected ConnectionError, but got " <> show res
it "reports UnsupportedContentType" $ \(_, baseUrl) -> do it "reports UnsupportedContentType" $ \(_, baseUrl) -> do
let (getGet :<|> _ ) = client api let (getGet :<|> _ ) = client api
Left res <- runExceptT (getGet manager baseUrl) Left res <- runClientM getGet (ClientEnv manager baseUrl)
case res of case res of
UnsupportedContentType ("application/octet-stream") _ -> return () UnsupportedContentType ("application/octet-stream") _ -> return ()
_ -> fail $ "expected UnsupportedContentType, but got " <> show res _ -> fail $ "expected UnsupportedContentType, but got " <> show res
it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do
let (_ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api let (_ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
Left res <- runExceptT (getBody alice manager baseUrl) Left res <- runClientM (getBody alice) (ClientEnv manager baseUrl)
case res of case res of
InvalidContentTypeHeader "fooooo" _ -> return () InvalidContentTypeHeader "fooooo" _ -> return ()
_ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
data WrappedApi where data WrappedApi where
WrappedApi :: (HasServer (api :: *) '[], Server api ~ Handler a, WrappedApi :: (HasServer (api :: *) '[], Server api ~ Handler a,
HasClient api, Client api ~ (C.Manager -> BaseUrl -> SCR.ClientM ())) => HasClient api, Client api ~ SCR.ClientM ()) =>
Proxy api -> WrappedApi Proxy api -> WrappedApi
basicAuthSpec :: Spec basicAuthSpec :: Spec
@ -377,14 +377,14 @@ basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ d
it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
let getBasic = client basicAuthAPI let getBasic = client basicAuthAPI
let basicAuthData = BasicAuthData "servant" "server" let basicAuthData = BasicAuthData "servant" "server"
(left show <$> runExceptT (getBasic basicAuthData manager baseUrl)) `shouldReturn` Right alice (left show <$> runClientM (getBasic basicAuthData) (ClientEnv manager baseUrl)) `shouldReturn` Right alice
context "Authentication is rejected when requests are not authenticated properly" $ do context "Authentication is rejected when requests are not authenticated properly" $ do
it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
let getBasic = client basicAuthAPI let getBasic = client basicAuthAPI
let basicAuthData = BasicAuthData "not" "password" let basicAuthData = BasicAuthData "not" "password"
Left FailureResponse{..} <- runExceptT (getBasic basicAuthData manager baseUrl) Left FailureResponse{..} <- runClientM (getBasic basicAuthData) (ClientEnv manager baseUrl)
responseStatus `shouldBe` HTTP.Status 403 "Forbidden" responseStatus `shouldBe` HTTP.Status 403 "Forbidden"
genAuthSpec :: Spec genAuthSpec :: Spec
@ -394,14 +394,14 @@ genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do
it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
let getProtected = client genAuthAPI let getProtected = client genAuthAPI
let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "AuthHeader" ("cool" :: String) req) let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "AuthHeader" ("cool" :: String) req)
(left show <$> runExceptT (getProtected authRequest manager baseUrl)) `shouldReturn` Right alice (left show <$> runClientM (getProtected authRequest) (ClientEnv manager baseUrl)) `shouldReturn` Right alice
context "Authentication is rejected when requests are not authenticated properly" $ do context "Authentication is rejected when requests are not authenticated properly" $ do
it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
let getProtected = client genAuthAPI let getProtected = client genAuthAPI
let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "Wrong" ("header" :: String) req) let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "Wrong" ("header" :: String) req)
Left FailureResponse{..} <- runExceptT (getProtected authRequest manager baseUrl) Left FailureResponse{..} <- runClientM (getProtected authRequest) (ClientEnv manager baseUrl)
responseStatus `shouldBe` (HTTP.Status 401 "Unauthorized") responseStatus `shouldBe` (HTTP.Status 401 "Unauthorized")
-- * utils -- * utils

1
servant-mock/.ghci
View file

@ -1 +0,0 @@
:set -Wall -itest -isrc -optP-include -optPdist/build/autogen/cabal_macros.h -Iinclude

30
servant-mock/LICENSE
View file

@ -1,30 +0,0 @@
Copyright (c) 2015-2016, Servant Contributors
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Alp Mestanogullari nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

2
servant-mock/Setup.hs
View file

@ -1,2 +0,0 @@
import Distribution.Simple
main = defaultMain

26
servant-mock/example/main.hs
View file

@ -1,26 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-unused-binds #-}
import Data.Aeson
import GHC.Generics
import Network.Wai.Handler.Warp
import Servant
import Servant.Mock
import Test.QuickCheck.Arbitrary
newtype User = User { username :: String }
deriving (Eq, Show, Arbitrary, Generic)
instance ToJSON User
type API = "user" :> Get '[JSON] User
api :: Proxy API
api = Proxy
main :: IO ()
main = run 8080 (serve api $ mock api Proxy)

8
servant-mock/include/overlapping-compat.h
View file

@ -1,8 +0,0 @@
#if __GLASGOW_HASKELL__ >= 710
#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
#define OVERLAPPING_ {-# OVERLAPPING #-}
#else
{-# LANGUAGE OverlappingInstances #-}
#define OVERLAPPABLE_
#define OVERLAPPING_
#endif

72
servant-mock/servant-mock.cabal
View file

@ -1,72 +0,0 @@
name: servant-mock
version: 0.8.1
synopsis: Derive a mock server for free from your servant API types
description:
Derive a mock server for free from your servant API types
.
See the @Servant.Mock@ module for the documentation and an example.
homepage: http://github.com/haskell-servant/servant
license: BSD3
license-file: LICENSE
author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com
copyright: 2015-2016 Servant Contributors
category: Web
build-type: Simple
extra-source-files: include/*.h
cabal-version: >=1.10
bug-reports: http://github.com/haskell-servant/servant/issues
source-repository head
type: git
location: http://github.com/haskell-servant/servant.git
flag example
description: Build the example too
default: True
library
exposed-modules:
Servant.Mock
build-depends:
base >=4.7 && <5,
bytestring >= 0.10 && <0.11,
http-types >= 0.8 && <0.10,
servant == 0.8.*,
servant-server == 0.8.*,
transformers >= 0.3 && <0.6,
QuickCheck >= 2.7 && <2.10,
wai >= 3.0 && <3.3
hs-source-dirs: src
default-language: Haskell2010
include-dirs: include
ghc-options: -Wall
executable mock-app
main-is: main.hs
hs-source-dirs: example
default-language: Haskell2010
build-depends: aeson, base, servant-mock, servant-server, QuickCheck, warp
if flag(example)
buildable: True
else
buildable: False
ghc-options: -Wall
test-suite spec
type: exitcode-stdio-1.0
ghc-options: -Wall
default-language: Haskell2010
hs-source-dirs: test
main-is: Spec.hs
other-modules:
Servant.MockSpec
build-depends:
base,
hspec,
hspec-wai,
QuickCheck,
servant,
servant-server,
servant-mock,
aeson,
wai

188
servant-mock/src/Servant/Mock.hs
View file

@ -1,188 +0,0 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
#include "overlapping-compat.h"
-- |
-- Module : Servant.Mock
-- Copyright : 2015 Alp Mestanogullari
-- License : BSD3
--
-- Maintainer : Alp Mestanogullari <alpmestan@gmail.com>
-- Stability : experimental
-- Portability : portable
--
-- Automatically derive a mock webserver that implements some API type,
-- just from the said API type's definition.
--
-- Using this module couldn't be simpler. Given some API type, like:
--
-- > type API = "user" :> Get '[JSON] User
--
-- that describes your web application, all you have to do is define
-- a 'Proxy' to it:
--
-- > myAPI :: Proxy API
-- > myAPI = Proxy
--
-- and call 'mock', which has the following type:
--
-- @
-- 'mock' :: 'HasMock' api context => 'Proxy' api -> 'Proxy' context -> 'Server' api
-- @
--
-- What this says is, given some API type @api@ that it knows it can
-- "mock", 'mock' hands you an implementation of the API type. It does so
-- by having each request handler generate a random value of the
-- appropriate type (@User@ in our case). All you need for this to work is
-- to provide 'Arbitrary' instances for the data types returned as response
-- bodies, hence appearing next to 'Delete', 'Get', 'Patch', 'Post' and 'Put'.
--
-- To put this all to work and run the mock server, just call 'serve' on the
-- result of 'mock' to get an 'Application' that you can then run with warp.
--
-- @
-- main :: IO ()
-- main = Network.Wai.Handler.Warp.run 8080 $
-- 'serve' myAPI ('mock' myAPI Proxy)
-- @
module Servant.Mock ( HasMock(..) ) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
import Control.Monad.IO.Class
import Data.ByteString.Lazy.Char8 (pack)
import Data.Proxy
import GHC.TypeLits
import Network.HTTP.Types.Status
import Network.Wai
import Servant
import Servant.API.ContentTypes
import Test.QuickCheck.Arbitrary (Arbitrary (..), vector)
import Test.QuickCheck.Gen (Gen, generate)
-- | 'HasMock' defines an interpretation of API types
-- than turns them into random-response-generating
-- request handlers, hence providing an instance for
-- all the combinators of the core /servant/ library.
class HasServer api context => HasMock api context where
-- | Calling this method creates request handlers of
-- the right type to implement the API described by
-- @api@ that just generate random response values of
-- the right type. E.g:
--
-- @
-- type API = "user" :> Get '[JSON] User
-- :<|> "book" :> Get '[JSON] Book
--
-- api :: Proxy API
-- api = Proxy
--
-- -- let's say we will start with the frontend,
-- -- and hence need a placeholder server
-- server :: Server API
-- server = mock api Proxy
-- @
--
-- What happens here is that @'Server' API@
-- actually "means" 2 request handlers, of the following types:
--
-- @
-- getUser :: Handler User
-- getBook :: Handler Book
-- @
--
-- So under the hood, 'mock' uses the 'IO' bit to generate
-- random values of type 'User' and 'Book' every time these
-- endpoints are requested.
mock :: Proxy api -> Proxy context -> Server api
instance (HasMock a context, HasMock b context) => HasMock (a :<|> b) context where
mock _ context = mock (Proxy :: Proxy a) context :<|> mock (Proxy :: Proxy b) context
instance (KnownSymbol path, HasMock rest context) => HasMock (path :> rest) context where
mock _ = mock (Proxy :: Proxy rest)
instance (KnownSymbol s, FromHttpApiData a, HasMock rest context) => HasMock (Capture s a :> rest) context where
mock _ context = \_ -> mock (Proxy :: Proxy rest) context
instance (KnownSymbol s, FromHttpApiData a, HasMock rest context) => HasMock (CaptureAll s a :> rest) context where
mock _ context = \_ -> mock (Proxy :: Proxy rest) context
instance (AllCTUnrender ctypes a, HasMock rest context) => HasMock (ReqBody ctypes a :> rest) context where
mock _ context = \_ -> mock (Proxy :: Proxy rest) context
instance HasMock rest context => HasMock (RemoteHost :> rest) context where
mock _ context = \_ -> mock (Proxy :: Proxy rest) context
instance HasMock rest context => HasMock (IsSecure :> rest) context where
mock _ context = \_ -> mock (Proxy :: Proxy rest) context
instance HasMock rest context => HasMock (Vault :> rest) context where
mock _ context = \_ -> mock (Proxy :: Proxy rest) context
instance HasMock rest context => HasMock (HttpVersion :> rest) context where
mock _ context = \_ -> mock (Proxy :: Proxy rest) context
instance (KnownSymbol s, FromHttpApiData a, HasMock rest context)
=> HasMock (QueryParam s a :> rest) context where
mock _ context = \_ -> mock (Proxy :: Proxy rest) context
instance (KnownSymbol s, FromHttpApiData a, HasMock rest context)
=> HasMock (QueryParams s a :> rest) context where
mock _ context = \_ -> mock (Proxy :: Proxy rest) context
instance (KnownSymbol s, HasMock rest context) => HasMock (QueryFlag s :> rest) context where
mock _ context = \_ -> mock (Proxy :: Proxy rest) context
instance (KnownSymbol h, FromHttpApiData a, HasMock rest context) => HasMock (Header h a :> rest) context where
mock _ context = \_ -> mock (Proxy :: Proxy rest) context
instance (Arbitrary a, KnownNat status, ReflectMethod method, AllCTRender ctypes a)
=> HasMock (Verb method status ctypes a) context where
mock _ _ = mockArbitrary
instance OVERLAPPING_
(GetHeaders (Headers headerTypes a), Arbitrary (HList headerTypes),
Arbitrary a, KnownNat status, ReflectMethod method, AllCTRender ctypes a)
=> HasMock (Verb method status ctypes (Headers headerTypes a)) context where
mock _ _ = mockArbitrary
instance HasMock Raw context where
mock _ _ = \_req respond -> do
bdy <- genBody
respond $ responseLBS status200 [] bdy
where genBody = pack <$> generate (vector 100 :: Gen [Char])
instance (HasContextEntry context (NamedContext name subContext), HasMock rest subContext) =>
HasMock (WithNamedContext name subContext rest) context where
mock _ _ = mock (Proxy :: Proxy rest) (Proxy :: Proxy subContext)
mockArbitrary :: (MonadIO m, Arbitrary a) => m a
mockArbitrary = liftIO (generate arbitrary)
-- utility instance
instance (Arbitrary (HList ls), Arbitrary a)
=> Arbitrary (Headers ls a) where
arbitrary = Headers <$> arbitrary <*> arbitrary
instance Arbitrary (HList '[]) where
arbitrary = pure HNil
instance (Arbitrary a, Arbitrary (HList hs))
=> Arbitrary (HList (Header h a ': hs)) where
arbitrary = HCons <$> fmap Header arbitrary <*> arbitrary
instance Arbitrary NoContent where
arbitrary = pure NoContent

86
servant-mock/test/Servant/MockSpec.hs
View file

@ -1,86 +0,0 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
module Servant.MockSpec where
import Data.Aeson as Aeson
import Data.Proxy
import GHC.Generics
import Network.Wai
import Servant.API
import Test.Hspec hiding (pending)
import Test.Hspec.Wai
import Test.QuickCheck
import Servant
import Servant.API.Internal.Test.ComprehensiveAPI
import Servant.Mock
-- This declaration simply checks that all instances are in place.
_ = mock comprehensiveAPI (Proxy :: Proxy '[NamedContext "foo" '[]])
data Body
= Body
| ArbitraryBody
deriving (Generic)
instance ToJSON Body
instance Arbitrary Body where
arbitrary = return ArbitraryBody
data TestHeader
= TestHeader
| ArbitraryHeader
deriving (Show)
instance ToHttpApiData TestHeader where
toHeader = toHeader . show
toUrlPiece = toUrlPiece . show
toQueryParam = toQueryParam . show
instance Arbitrary TestHeader where
arbitrary = return ArbitraryHeader
spec :: Spec
spec = do
describe "mock" $ do
context "Get" $ do
let api :: Proxy (Get '[JSON] Body)
api = Proxy
app = serve api (mock api Proxy)
with (return app) $ do
it "serves arbitrary response bodies" $ do
get "/" `shouldRespondWith` 200{
matchBody = Just $ Aeson.encode ArbitraryBody
}
context "response headers" $ do
let withHeader :: Proxy (Get '[JSON] (Headers '[Header "foo" TestHeader] Body))
withHeader = Proxy
withoutHeader :: Proxy (Get '[JSON] (Headers '[] Body))
withoutHeader = Proxy
toApp :: (HasMock api '[]) => Proxy api -> IO Application
toApp api = return $ serve api (mock api (Proxy :: Proxy '[]))
with (toApp withHeader) $ do
it "serves arbitrary response bodies" $ do
get "/" `shouldRespondWith` 200{
matchHeaders = return $ MatchHeader $ \ h ->
if h == [("Content-Type", "application/json"), ("foo", "ArbitraryHeader")]
then Nothing
else Just ("headers not correct\n")
}
with (toApp withoutHeader) $ do
it "works for no additional headers" $ do
get "/" `shouldRespondWith` 200{
matchHeaders = return $ MatchHeader $ \ h ->
if h == [("Content-Type", "application/json")]
then Nothing
else Just ("headers not correct\n")
}

1
servant-mock/test/Spec.hs
View file

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

5
servant-mock/tinc.yaml
View file

@ -1,5 +0,0 @@
dependencies:
- name: servant
path: ../servant
- name: servant-server
path: ../servant-server

1
servant/CHANGELOG.md
View file

@ -2,6 +2,7 @@ next
---- ----
* BACKWARDS INCOMPATIBLE replace use of `ToFromByteString` with `To/FromHttpApiData` for `GetHeaders/BuildHeadersTo` * BACKWARDS INCOMPATIBLE replace use of `ToFromByteString` with `To/FromHttpApiData` for `GetHeaders/BuildHeadersTo`
* Add Servant.API.Times for parsing times with a format specified in their type. * Add Servant.API.Times for parsing times with a format specified in their type.
* Added Eq, Show, Read, Generic and Ord instances to IsSecure
0.8.1 0.8.1
---- ----

4
servant/src/Servant/API/IsSecure.hs
View file

@ -1,10 +1,12 @@
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
module Servant.API.IsSecure module Servant.API.IsSecure
( -- $issecure ( -- $issecure
IsSecure(..) IsSecure(..)
) where ) where
import Data.Typeable import Data.Typeable
import GHC.Generics (Generic)
-- | Was this request made over an SSL connection? -- | Was this request made over an SSL connection?
-- --
@ -19,7 +21,7 @@ data IsSecure = Secure -- ^ the connection to the server
-- is secure (HTTPS) -- is secure (HTTPS)
| NotSecure -- ^ the connection to the server | NotSecure -- ^ the connection to the server
-- is not secure (HTTP) -- is not secure (HTTP)
deriving Typeable deriving (Eq, Show, Read, Generic, Ord, Typeable)
-- $issecure -- $issecure
-- --

1
sources.txt
View file

@ -4,4 +4,3 @@ servant-client
servant-docs servant-docs
servant-foreign servant-foreign
servant-js servant-js
servant-mock

5
stack-ghc-7.8.4.yaml
View file

@ -5,7 +5,6 @@ packages:
- servant-docs/ - servant-docs/
- servant-foreign/ - servant-foreign/
- servant-js/ - servant-js/
- servant-mock/
- servant-server/ - servant-server/
extra-deps: extra-deps:
- base-compat-0.9.1 - base-compat-0.9.1
@ -18,10 +17,6 @@ extra-deps:
- hspec-expectations-0.7.2 - hspec-expectations-0.7.2
- http-api-data-0.2.2 - http-api-data-0.2.2
- primitive-0.6.1.0 - primitive-0.6.1.0
- servant-0.7.1
- servant-client-0.7.1
- servant-docs-0.7.1
- servant-server-0.7.1
- should-not-typecheck-2.1.0 - should-not-typecheck-2.1.0
- time-locale-compat-0.1.1.1 - time-locale-compat-0.1.1.1
- wai-app-static-3.1.5 - wai-app-static-3.1.5

1
stack-ghc-8.0.1.yaml
View file

@ -5,7 +5,6 @@ packages:
- servant-docs/ - servant-docs/
- servant-foreign/ - servant-foreign/
- servant-js/ - servant-js/
- servant-mock/
- servant-server/ - servant-server/
extra-deps: [] extra-deps: []
flags: {} flags: {}

1
stack.yaml
View file

@ -5,7 +5,6 @@ packages:
- servant-docs/ - servant-docs/
- servant-foreign/ - servant-foreign/
- servant-js/ - servant-js/
- servant-mock/
- servant-server/ - servant-server/
- doc/tutorial - doc/tutorial
extra-deps: extra-deps: