servant-client: support for ghcjs
This commit is contained in:
parent
14a8139cbe
commit
5c91864ee4
21 changed files with 739 additions and 165 deletions
2
.gitignore
vendored
2
.gitignore
vendored
|
@ -29,3 +29,5 @@ doc/_build
|
|||
doc/venv
|
||||
doc/tutorial/static/api.js
|
||||
doc/tutorial/static/jq.js
|
||||
servant-client/node_modules/
|
||||
servant-client/test/ghcjs/testServer/testServer
|
||||
|
|
|
@ -31,12 +31,22 @@ library
|
|||
Servant.Common.BaseUrl
|
||||
Servant.Common.BasicAuth
|
||||
Servant.Common.Req
|
||||
other-modules:
|
||||
Servant.Client.PerformRequest
|
||||
Servant.Client.PerformRequest.Base
|
||||
if impl(ghcjs)
|
||||
other-modules:
|
||||
Servant.Client.PerformRequest.GHCJS
|
||||
else
|
||||
other-modules:
|
||||
Servant.Client.PerformRequest.GHC
|
||||
build-depends:
|
||||
base >=4.7 && <5
|
||||
, aeson
|
||||
, attoparsec
|
||||
, base64-bytestring
|
||||
, bytestring
|
||||
, case-insensitive
|
||||
, exceptions
|
||||
, http-api-data >= 0.1 && < 0.3
|
||||
, http-client
|
||||
|
@ -50,6 +60,10 @@ library
|
|||
, text
|
||||
, transformers
|
||||
, transformers-compat
|
||||
if impl(ghcjs)
|
||||
build-depends:
|
||||
ghcjs-base
|
||||
, ghcjs-prim
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall
|
||||
|
@ -60,19 +74,31 @@ test-suite spec
|
|||
ghc-options:
|
||||
-Wall -fno-warn-name-shadowing -fno-warn-missing-signatures
|
||||
default-language: Haskell2010
|
||||
hs-source-dirs: test
|
||||
hs-source-dirs: test, src
|
||||
main-is: Spec.hs
|
||||
other-modules:
|
||||
Servant.ClientSpec
|
||||
, Servant.Client.PerformRequest.GHCJSSpec
|
||||
, Servant.Client.TestServer
|
||||
, Servant.Client.TestServer.Types
|
||||
, Servant.Common.BaseUrl
|
||||
, Servant.Common.BaseUrlSpec
|
||||
, Spec
|
||||
if impl(ghcjs)
|
||||
other-modules:
|
||||
Servant.Client.TestServer.GHCJS
|
||||
else
|
||||
other-modules:
|
||||
Servant.Client.TestServer.GHC
|
||||
build-depends:
|
||||
base == 4.*
|
||||
, transformers
|
||||
, transformers-compat
|
||||
, aeson
|
||||
, base64-bytestring
|
||||
, bytestring
|
||||
, deepseq
|
||||
, hspec == 2.*
|
||||
, hspec >= 2.2.1 && < 2.3
|
||||
, http-client
|
||||
, http-media
|
||||
, http-types
|
||||
|
@ -80,8 +106,20 @@ test-suite spec
|
|||
, network >= 2.6
|
||||
, QuickCheck >= 2.7
|
||||
, servant == 0.6.*
|
||||
, servant-client
|
||||
, servant-server == 0.6.*
|
||||
, text
|
||||
, wai
|
||||
, warp
|
||||
, mockery
|
||||
, safe
|
||||
, process
|
||||
, http-api-data
|
||||
, network-uri
|
||||
, exceptions
|
||||
, string-conversions
|
||||
if impl(ghcjs)
|
||||
build-depends:
|
||||
ghcjs-base
|
||||
, ghcjs-prim
|
||||
, case-insensitive
|
||||
include-dirs: include
|
||||
|
|
|
@ -42,6 +42,7 @@ import Servant.Client.Experimental.Auth
|
|||
import Servant.Common.BaseUrl
|
||||
import Servant.Common.BasicAuth
|
||||
import Servant.Common.Req
|
||||
import Servant.Client.PerformRequest (ServantError(..))
|
||||
|
||||
-- * Accessing APIs as a Client
|
||||
|
||||
|
|
13
servant-client/src/Servant/Client/PerformRequest.hs
Normal file
13
servant-client/src/Servant/Client/PerformRequest.hs
Normal file
|
@ -0,0 +1,13 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
|
||||
module Servant.Client.PerformRequest (
|
||||
ServantError(..),
|
||||
performHttpRequest,
|
||||
) where
|
||||
|
||||
import Servant.Client.PerformRequest.Base
|
||||
#ifdef __GHCJS__
|
||||
import Servant.Client.PerformRequest.GHCJS
|
||||
#else
|
||||
import Servant.Client.PerformRequest.GHC
|
||||
#endif
|
35
servant-client/src/Servant/Client/PerformRequest/Base.hs
Normal file
35
servant-client/src/Servant/Client/PerformRequest/Base.hs
Normal file
|
@ -0,0 +1,35 @@
|
|||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
|
||||
module Servant.Client.PerformRequest.Base where
|
||||
|
||||
import Control.Exception
|
||||
import Data.ByteString.Lazy
|
||||
import Data.Typeable
|
||||
import Network.HTTP.Media
|
||||
import Network.HTTP.Types
|
||||
|
||||
data ServantError
|
||||
= FailureResponse
|
||||
{ responseStatus :: Status
|
||||
, responseContentType :: MediaType
|
||||
, responseBody :: ByteString
|
||||
}
|
||||
| DecodeFailure
|
||||
{ decodeError :: String
|
||||
, responseContentType :: MediaType
|
||||
, responseBody :: ByteString
|
||||
}
|
||||
| UnsupportedContentType
|
||||
{ responseContentType :: MediaType
|
||||
, responseBody :: ByteString
|
||||
}
|
||||
| InvalidContentTypeHeader
|
||||
{ responseContentTypeHeader :: ByteString
|
||||
, responseBody :: ByteString
|
||||
}
|
||||
| ConnectionError
|
||||
{ connectionError :: SomeException
|
||||
}
|
||||
deriving (Show, Typeable)
|
||||
|
||||
instance Exception ServantError
|
29
servant-client/src/Servant/Client/PerformRequest/GHC.hs
Normal file
29
servant-client/src/Servant/Client/PerformRequest/GHC.hs
Normal file
|
@ -0,0 +1,29 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
||||
|
||||
module Servant.Client.PerformRequest.GHC (
|
||||
ServantError(..),
|
||||
performHttpRequest,
|
||||
) where
|
||||
|
||||
#if !MIN_VERSION_base(4,8,0)
|
||||
import Control.Applicative
|
||||
#endif
|
||||
import Control.Exception
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import Network.HTTP.Client
|
||||
|
||||
import Servant.Client.PerformRequest.Base
|
||||
|
||||
performHttpRequest :: Manager -> Request
|
||||
-> IO (Either ServantError (Response LBS.ByteString))
|
||||
performHttpRequest manager request =
|
||||
catchConnectionError $ httpLbs request manager
|
||||
|
||||
catchConnectionError :: IO a -> IO (Either ServantError a)
|
||||
catchConnectionError action =
|
||||
catch (Right <$> action) $ \e ->
|
||||
pure . Left . ConnectionError $ SomeException (e :: HttpException)
|
178
servant-client/src/Servant/Client/PerformRequest/GHCJS.hs
Normal file
178
servant-client/src/Servant/Client/PerformRequest/GHCJS.hs
Normal file
|
@ -0,0 +1,178 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
||||
|
||||
module Servant.Client.PerformRequest.GHCJS (
|
||||
ServantError(..),
|
||||
performHttpRequest,
|
||||
|
||||
-- exported for testing
|
||||
parseHeaders,
|
||||
) where
|
||||
|
||||
import Control.Arrow
|
||||
import Control.Concurrent
|
||||
import Control.Exception
|
||||
import Control.Monad
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import Data.CaseInsensitive
|
||||
import Data.Char
|
||||
import Data.String.Conversions
|
||||
import GHCJS.Foreign.Callback
|
||||
import GHCJS.Prim
|
||||
import Network.HTTP.Client
|
||||
import Network.HTTP.Client.Internal as HttpClient
|
||||
import Network.HTTP.Types
|
||||
|
||||
import Servant.Client.PerformRequest.Base
|
||||
|
||||
newtype JSXMLHttpRequest = JSXMLHttpRequest JSVal
|
||||
|
||||
newtype JSXMLHttpRequestClass = JSXMLHttpRequestClass JSVal
|
||||
|
||||
performHttpRequest :: Manager -> Request -> IO (Either ServantError (Response LBS.ByteString))
|
||||
performHttpRequest _ request = do
|
||||
xhr <- initXhr
|
||||
performXhr xhr request
|
||||
toResponse xhr
|
||||
|
||||
-- * initialization
|
||||
|
||||
initXhr :: IO JSXMLHttpRequest
|
||||
initXhr = do
|
||||
lib <- requireXMLHttpRequestClass
|
||||
newXMLHttpRequest lib
|
||||
|
||||
foreign import javascript unsafe
|
||||
-- branching between node (for testing) and browsers
|
||||
"(function () {if (typeof require !== 'undefined') { return require('xhr2'); } else { return XMLHttpRequest; };})()"
|
||||
requireXMLHttpRequestClass :: IO JSXMLHttpRequestClass
|
||||
|
||||
foreign import javascript unsafe "new $1()"
|
||||
newXMLHttpRequest :: JSXMLHttpRequestClass -> IO JSXMLHttpRequest
|
||||
|
||||
-- * performing requests
|
||||
|
||||
-- Performs the xhr and blocks until the response was received
|
||||
performXhr :: JSXMLHttpRequest -> Request -> IO ()
|
||||
performXhr xhr request = do
|
||||
waiter <- newEmptyMVar
|
||||
callback <- onReadyStateChange xhr $ do
|
||||
state <- readyState xhr
|
||||
case state of
|
||||
4 -> putMVar waiter ()
|
||||
_ -> return ()
|
||||
openXhr xhr (cs $ method request) (toUrl request) True
|
||||
setHeaders xhr (requestHeaders request)
|
||||
sendXhr xhr (toBody request)
|
||||
takeMVar waiter
|
||||
releaseCallback callback
|
||||
|
||||
onReadyStateChange :: JSXMLHttpRequest -> IO () -> IO (Callback (IO ()))
|
||||
onReadyStateChange xhr action = do
|
||||
callback <- asyncCallback action
|
||||
js_onReadyStateChange xhr callback
|
||||
return callback
|
||||
foreign import javascript safe "$1.onreadystatechange = $2;"
|
||||
js_onReadyStateChange :: JSXMLHttpRequest -> Callback (IO ()) -> IO ()
|
||||
|
||||
foreign import javascript unsafe "$1.readyState"
|
||||
readyState :: JSXMLHttpRequest -> IO Int
|
||||
|
||||
openXhr :: JSXMLHttpRequest -> String -> String -> Bool -> IO ()
|
||||
openXhr xhr method url async =
|
||||
js_openXhr xhr (toJSString method) (toJSString url) async
|
||||
foreign import javascript unsafe "$1.open($2, $3, $4)"
|
||||
js_openXhr :: JSXMLHttpRequest -> JSVal -> JSVal -> Bool -> IO ()
|
||||
|
||||
toUrl :: Request -> String
|
||||
toUrl request =
|
||||
let protocol = if secure request then "https" else "http"
|
||||
hostS = cs $ host request
|
||||
portS = show $ port request
|
||||
pathS = cs $ path request
|
||||
queryS = cs $ queryString request
|
||||
in protocol ++ "://" ++ hostS ++ ":" ++ portS ++ pathS ++ queryS
|
||||
|
||||
setHeaders :: JSXMLHttpRequest -> RequestHeaders -> IO ()
|
||||
setHeaders xhr headers = forM_ headers $ \ (key, value) ->
|
||||
js_setRequestHeader xhr (toJSString $ cs $ original key) (toJSString $ cs value)
|
||||
foreign import javascript unsafe "$1.setRequestHeader($2, $3)"
|
||||
js_setRequestHeader :: JSXMLHttpRequest -> JSVal -> JSVal -> IO ()
|
||||
|
||||
sendXhr :: JSXMLHttpRequest -> Maybe String -> IO ()
|
||||
sendXhr xhr Nothing = js_sendXhr xhr
|
||||
sendXhr xhr (Just body) =
|
||||
js_sendXhrWithBody xhr (toJSString body)
|
||||
foreign import javascript unsafe "$1.send()"
|
||||
js_sendXhr :: JSXMLHttpRequest -> IO ()
|
||||
foreign import javascript unsafe "$1.send($2)"
|
||||
js_sendXhrWithBody :: JSXMLHttpRequest -> JSVal -> IO ()
|
||||
|
||||
toBody :: Request -> Maybe String
|
||||
toBody request = case requestBody request of
|
||||
RequestBodyLBS "" -> Nothing
|
||||
RequestBodyLBS x -> Just $ cs x
|
||||
_ -> error "servant-client only uses RequestBodyLBS"
|
||||
|
||||
-- * inspecting the xhr response
|
||||
|
||||
-- This function is only supposed to handle 'ConnectionError's. Other
|
||||
-- 'ServantError's are created in Servant.Client.Req.
|
||||
toResponse :: JSXMLHttpRequest -> IO (Either ServantError (Response LBS.ByteString))
|
||||
toResponse xhr = do
|
||||
status <- getStatus xhr
|
||||
case status of
|
||||
0 -> return $ Left $ ConnectionError $ SomeException $ ErrorCall "connection error"
|
||||
_ -> do
|
||||
statusText <- cs <$> getStatusText xhr
|
||||
headers <- parseHeaders <$> getAllResponseHeaders xhr
|
||||
responseText <- cs <$> getResponseText xhr
|
||||
return $ Right $ Response {
|
||||
HttpClient.responseStatus = mkStatus status statusText,
|
||||
responseVersion = http11, -- this is made up
|
||||
responseHeaders = headers,
|
||||
HttpClient.responseBody = responseText,
|
||||
responseCookieJar = mempty,
|
||||
responseClose' = ResponseClose (return ())
|
||||
}
|
||||
|
||||
foreign import javascript unsafe "$1.status"
|
||||
getStatus :: JSXMLHttpRequest -> IO Int
|
||||
|
||||
getStatusText :: JSXMLHttpRequest -> IO String
|
||||
getStatusText = fmap fromJSString . js_statusText
|
||||
foreign import javascript unsafe "$1.statusText"
|
||||
js_statusText :: JSXMLHttpRequest -> IO JSVal
|
||||
|
||||
getAllResponseHeaders :: JSXMLHttpRequest -> IO String
|
||||
getAllResponseHeaders xhr =
|
||||
fromJSString <$> js_getAllResponseHeaders xhr
|
||||
foreign import javascript unsafe "$1.getAllResponseHeaders()"
|
||||
js_getAllResponseHeaders :: JSXMLHttpRequest -> IO JSVal
|
||||
|
||||
getResponseText :: JSXMLHttpRequest -> IO String
|
||||
getResponseText xhr = fromJSString <$> js_responseText xhr
|
||||
foreign import javascript unsafe "$1.responseText"
|
||||
js_responseText :: JSXMLHttpRequest -> IO JSVal
|
||||
|
||||
parseHeaders :: String -> ResponseHeaders
|
||||
parseHeaders s =
|
||||
fmap (first mk) $
|
||||
fmap (first strip . second strip) $
|
||||
fmap parseHeader $
|
||||
splitOn "\r\n" (cs s)
|
||||
where
|
||||
parseHeader :: BS.ByteString -> (BS.ByteString, BS.ByteString)
|
||||
parseHeader h = case BS.breakSubstring ":" (cs h) of
|
||||
(key, (BS.drop 1 -> value)) -> (key, value)
|
||||
|
||||
splitOn :: BS.ByteString -> BS.ByteString -> [BS.ByteString]
|
||||
splitOn separator input = case BS.breakSubstring separator input of
|
||||
(prefix, "") -> [prefix]
|
||||
(prefix, rest) -> prefix : splitOn separator (BS.drop (BS.length separator) rest)
|
||||
|
||||
strip :: BS.ByteString -> BS.ByteString
|
||||
strip = BS.dropWhile isSpace . BS.reverse . BS.dropWhile isSpace . BS.reverse
|
|
@ -18,44 +18,17 @@ import Data.String.Conversions
|
|||
import Data.Proxy
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding
|
||||
import Data.Typeable
|
||||
import Network.HTTP.Client hiding (Proxy, path)
|
||||
import Network.HTTP.Media
|
||||
import Network.HTTP.Types
|
||||
import qualified Network.HTTP.Types.Header as HTTP
|
||||
import qualified Network.HTTP.Types.Header as HTTP
|
||||
import Network.URI hiding (path)
|
||||
import Servant.API.ContentTypes
|
||||
import Servant.Client.PerformRequest
|
||||
import Servant.Common.BaseUrl
|
||||
|
||||
import qualified Network.HTTP.Client as Client
|
||||
|
||||
import Web.HttpApiData
|
||||
|
||||
data ServantError
|
||||
= FailureResponse
|
||||
{ responseStatus :: Status
|
||||
, responseContentType :: MediaType
|
||||
, responseBody :: ByteString
|
||||
}
|
||||
| DecodeFailure
|
||||
{ decodeError :: String
|
||||
, responseContentType :: MediaType
|
||||
, responseBody :: ByteString
|
||||
}
|
||||
| UnsupportedContentType
|
||||
{ responseContentType :: MediaType
|
||||
, responseBody :: ByteString
|
||||
}
|
||||
| InvalidContentTypeHeader
|
||||
{ responseContentTypeHeader :: ByteString
|
||||
, responseBody :: ByteString
|
||||
}
|
||||
| ConnectionError
|
||||
{ connectionError :: SomeException
|
||||
}
|
||||
deriving (Show, Typeable)
|
||||
|
||||
instance Exception ServantError
|
||||
import qualified Network.HTTP.Client as Client
|
||||
|
||||
data Req = Req
|
||||
{ reqPath :: String
|
||||
|
@ -135,7 +108,7 @@ performRequest reqMethod req manager reqHost = do
|
|||
, checkStatus = \ _status _headers _cookies -> Nothing
|
||||
}
|
||||
|
||||
eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request manager
|
||||
eResponse <- liftIO $ performHttpRequest manager request
|
||||
case eResponse of
|
||||
Left err ->
|
||||
throwE . ConnectionError $ SomeException err
|
||||
|
@ -172,8 +145,3 @@ performRequestNoBody :: Method -> Req -> Manager -> BaseUrl
|
|||
performRequestNoBody reqMethod req manager reqHost = do
|
||||
(_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req manager reqHost
|
||||
return hdrs
|
||||
|
||||
catchConnectionError :: IO a -> IO (Either ServantError a)
|
||||
catchConnectionError action =
|
||||
catch (Right <$> action) $ \e ->
|
||||
pure . Left . ConnectionError $ SomeException (e :: HttpException)
|
||||
|
|
|
@ -0,0 +1,29 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Servant.Client.PerformRequest.GHCJSSpec where
|
||||
|
||||
import Test.Hspec
|
||||
|
||||
#ifdef __GHCJS__
|
||||
|
||||
import Servant.Client.PerformRequest.GHCJS
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "parseHeaders" $ do
|
||||
it "parses single headers" $ do
|
||||
parseHeaders "key: value" `shouldBe` [("key", "value")]
|
||||
|
||||
it "parses multiple headers" $ do
|
||||
parseHeaders "foo: bar\r\nnext: yay" `shouldBe`
|
||||
[("foo", "bar"), ("next", "yay")]
|
||||
|
||||
it "handles colons in header values correctly" $ do
|
||||
parseHeaders "foo: bar:baz" `shouldBe` [("foo", "bar:baz")]
|
||||
|
||||
#else
|
||||
|
||||
spec :: Spec
|
||||
spec = return ()
|
||||
#endif
|
15
servant-client/test/Servant/Client/TestServer.hs
Normal file
15
servant-client/test/Servant/Client/TestServer.hs
Normal file
|
@ -0,0 +1,15 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
|
||||
module Servant.Client.TestServer (
|
||||
buildTestServer,
|
||||
TestServer(..),
|
||||
withServer,
|
||||
) where
|
||||
|
||||
#ifdef __GHCJS__
|
||||
import Servant.Client.TestServer.GHCJS
|
||||
#else
|
||||
import Servant.Client.TestServer.GHC
|
||||
#endif
|
||||
|
||||
import Servant.Client.TestServer.Types
|
39
servant-client/test/Servant/Client/TestServer/GHC.hs
Normal file
39
servant-client/test/Servant/Client/TestServer/GHC.hs
Normal file
|
@ -0,0 +1,39 @@
|
|||
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
||||
|
||||
module Servant.Client.TestServer.GHC where
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Exception
|
||||
import Network.Socket
|
||||
import Network.Wai
|
||||
import Network.Wai.Handler.Warp
|
||||
|
||||
import Servant.Common.BaseUrl
|
||||
import Servant.Client.TestServer.Types
|
||||
|
||||
buildTestServer :: IO ()
|
||||
buildTestServer = return ()
|
||||
|
||||
withServer :: TestServer -> (BaseUrl -> IO a) -> IO a
|
||||
withServer (TestServer _ app) action =
|
||||
bracket (startWaiApp app) endWaiApp $ \ (_, url) ->
|
||||
action url
|
||||
|
||||
startWaiApp :: Application -> IO (ThreadId, BaseUrl)
|
||||
startWaiApp app = do
|
||||
(port, socket) <- openTestSocket
|
||||
let settings = setPort port $ defaultSettings
|
||||
thread <- forkIO $ runSettingsSocket settings socket app
|
||||
return (thread, BaseUrl Http "localhost" port "")
|
||||
|
||||
endWaiApp :: (ThreadId, BaseUrl) -> IO ()
|
||||
endWaiApp (thread, _) = killThread thread
|
||||
|
||||
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)
|
34
servant-client/test/Servant/Client/TestServer/GHCJS.hs
Normal file
34
servant-client/test/Servant/Client/TestServer/GHCJS.hs
Normal file
|
@ -0,0 +1,34 @@
|
|||
|
||||
module Servant.Client.TestServer.GHCJS where
|
||||
|
||||
import Control.Exception
|
||||
import Safe
|
||||
import System.Exit
|
||||
import System.IO
|
||||
import System.Process
|
||||
|
||||
import Servant.Client.TestServer.Types
|
||||
import Servant.Common.BaseUrl
|
||||
|
||||
buildTestServer :: IO ()
|
||||
buildTestServer = do
|
||||
process <- spawnProcess "./test/ghcjs/build-test-server.sh" []
|
||||
ExitSuccess <- waitForProcess process
|
||||
return ()
|
||||
|
||||
withServer :: TestServer -> (BaseUrl -> IO a) -> IO a
|
||||
withServer (TestServer testServerName _) action = do
|
||||
bracket start stop $ \ (port, _) -> action (BaseUrl Http "localhost" port ("/" ++ testServerName))
|
||||
where
|
||||
start :: IO (Int, ProcessHandle)
|
||||
start = do
|
||||
(Nothing, Just stdout, Nothing, process) <- createProcess $ (proc "./test/ghcjs/testServer/testServer" []) {
|
||||
std_out = CreatePipe
|
||||
}
|
||||
line <- hGetLine stdout
|
||||
case readMay line :: Maybe Int of
|
||||
Nothing -> die ("unparseable port: " ++ show line)
|
||||
Just port -> return (port, process)
|
||||
stop (_, process) = do
|
||||
terminateProcess process
|
||||
waitForProcess process
|
10
servant-client/test/Servant/Client/TestServer/Types.hs
Normal file
10
servant-client/test/Servant/Client/TestServer/Types.hs
Normal file
|
@ -0,0 +1,10 @@
|
|||
|
||||
module Servant.Client.TestServer.Types where
|
||||
|
||||
import Network.Wai
|
||||
|
||||
data TestServer
|
||||
= TestServer {
|
||||
testServerName :: String,
|
||||
testServerApp :: Application
|
||||
}
|
|
@ -1,5 +1,4 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
|
@ -11,24 +10,19 @@
|
|||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# OPTIONS_GHC -fcontext-stack=100 #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
||||
|
||||
#include "overlapping-compat.h"
|
||||
module Servant.ClientSpec where
|
||||
|
||||
#if !MIN_VERSION_base(4,8,0)
|
||||
import Control.Applicative ((<$>))
|
||||
#endif
|
||||
import Control.Arrow (left)
|
||||
import Control.Concurrent (forkIO, killThread, ThreadId)
|
||||
import Control.Exception (bracket)
|
||||
import Control.Monad.Trans.Except (ExceptT, throwE, runExceptT)
|
||||
import Control.Monad.Trans.Except (runExceptT, throwE)
|
||||
import Data.Aeson
|
||||
import qualified Data.ByteString.Lazy as BS
|
||||
import Data.Char (chr, isPrint)
|
||||
|
@ -39,34 +33,74 @@ import qualified Data.Text as T
|
|||
import GHC.Generics (Generic)
|
||||
import qualified Network.HTTP.Client as C
|
||||
import Network.HTTP.Media
|
||||
import qualified Network.HTTP.Types as HTTP
|
||||
import Network.Socket
|
||||
import Network.Wai (Application, Request,
|
||||
requestHeaders, responseLBS)
|
||||
import Network.Wai.Handler.Warp
|
||||
import qualified Network.HTTP.Types as HTTP
|
||||
import Network.Wai (responseLBS)
|
||||
import qualified Network.Wai as Wai
|
||||
import System.Exit
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
import Test.HUnit
|
||||
import Test.Hspec
|
||||
import Test.Hspec.QuickCheck
|
||||
import Test.HUnit
|
||||
import Test.QuickCheck
|
||||
|
||||
import Servant.API
|
||||
import Servant.API.Internal.Test.ComprehensiveAPI
|
||||
import Servant.Client
|
||||
import Servant.Client.TestServer
|
||||
import qualified Servant.Common.Req as SCR
|
||||
import Servant.Server
|
||||
import Servant.Server.Experimental.Auth
|
||||
import qualified Servant.Common.Req as SCR
|
||||
|
||||
-- This declaration simply checks that all instances are in place.
|
||||
_ = client comprehensiveAPI
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "Servant.Client" $ do
|
||||
spec = do
|
||||
runIO buildTestServer
|
||||
describe "Servant.Client" $ do
|
||||
sucessSpec
|
||||
failSpec
|
||||
wrappedApiSpec
|
||||
basicAuthSpec
|
||||
genAuthSpec
|
||||
errorSpec
|
||||
|
||||
-- | Run a test-server (identified by name) while performing the given action.
|
||||
-- The provided 'BaseUrl' points to the running server.
|
||||
--
|
||||
-- Running the test-servers is done differently depending on the compiler
|
||||
-- (ghc or ghcjs).
|
||||
--
|
||||
-- With ghc it's somewhat straight-forward: a wai 'Application' is being started
|
||||
-- on a free port inside the same process using 'warp'.
|
||||
--
|
||||
-- When running the test-suite with ghcjs all the test-servers are compiled into
|
||||
-- a single external executable (with ghc and warp). This is done through
|
||||
-- 'buildTestServer' once at the start of the test-suite. This built executable
|
||||
-- will provide all the test-servers on a free port under a path that
|
||||
-- corresponds to the test-servers name, for example under
|
||||
-- 'http://localhost:82923/failServer'. 'withTestServer' will then
|
||||
-- start this executable as an external process while the given action is being
|
||||
-- executed and provide it with the correct BaseUrl.
|
||||
-- This rather cumbersome approach is taken because it's not easy to run a wai
|
||||
-- Application as a http server when using ghcjs.
|
||||
withTestServer :: String -> (BaseUrl -> IO a) -> IO a
|
||||
withTestServer name action = do
|
||||
server <- lookupTestServer name
|
||||
withServer server action
|
||||
|
||||
lookupTestServer :: String -> IO TestServer
|
||||
lookupTestServer name = case lookup name mapping of
|
||||
Nothing -> die ("test server not found: " ++ name)
|
||||
Just testServer -> return testServer
|
||||
where
|
||||
mapping :: [(String, TestServer)]
|
||||
mapping = map (\ server -> (testServerName server, server)) allTestServers
|
||||
|
||||
-- | All test-servers must be registered here.
|
||||
allTestServers :: [TestServer]
|
||||
allTestServers =
|
||||
server :
|
||||
errorServer :
|
||||
failServer :
|
||||
basicAuthServer :
|
||||
genAuthServer :
|
||||
[]
|
||||
|
||||
-- * test data types
|
||||
|
||||
|
@ -147,8 +181,8 @@ getGet
|
|||
:<|> getRespHeaders
|
||||
:<|> getDeleteContentType = client api
|
||||
|
||||
server :: Application
|
||||
server = serve api (
|
||||
server :: TestServer
|
||||
server = TestServer "server" $ serve api (
|
||||
return alice
|
||||
:<|> return NoContent
|
||||
:<|> (\ name -> return $ Person name 0)
|
||||
|
@ -166,19 +200,19 @@ server = serve api (
|
|||
:<|> return NoContent
|
||||
)
|
||||
|
||||
|
||||
type FailApi =
|
||||
"get" :> Raw
|
||||
:<|> "capture" :> Capture "name" String :> Raw
|
||||
:<|> "body" :> Raw
|
||||
|
||||
failApi :: Proxy FailApi
|
||||
failApi = Proxy
|
||||
|
||||
failServer :: Application
|
||||
failServer = serve failApi (
|
||||
failServer :: TestServer
|
||||
failServer = TestServer "failServer" $ serve failApi (
|
||||
(\ _request respond -> respond $ responseLBS HTTP.ok200 [] "")
|
||||
:<|> (\ _capture _request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "application/json")] "")
|
||||
:<|> (\_request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
|
||||
:<|> (\ _request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
|
||||
)
|
||||
|
||||
-- * basic auth stuff
|
||||
|
@ -200,8 +234,9 @@ basicAuthHandler =
|
|||
basicServerContext :: Context '[ BasicAuthCheck () ]
|
||||
basicServerContext = basicAuthHandler :. EmptyContext
|
||||
|
||||
basicAuthServer :: Application
|
||||
basicAuthServer = serveWithContext basicAuthAPI basicServerContext (const (return alice))
|
||||
basicAuthServer :: TestServer
|
||||
basicAuthServer = TestServer "basicAuthServer" $
|
||||
serveWithContext basicAuthAPI basicServerContext (const (return alice))
|
||||
|
||||
-- * general auth stuff
|
||||
|
||||
|
@ -214,58 +249,59 @@ genAuthAPI = Proxy
|
|||
type instance AuthServerData (AuthProtect "auth-tag") = ()
|
||||
type instance AuthClientData (AuthProtect "auth-tag") = ()
|
||||
|
||||
genAuthHandler :: AuthHandler Request ()
|
||||
genAuthHandler :: AuthHandler Wai.Request ()
|
||||
genAuthHandler =
|
||||
let handler req = case lookup "AuthHeader" (requestHeaders req) of
|
||||
let handler req = case lookup "AuthHeader" (Wai.requestHeaders req) of
|
||||
Nothing -> throwE (err401 { errBody = "Missing auth header" })
|
||||
Just _ -> return ()
|
||||
in mkAuthHandler handler
|
||||
|
||||
genAuthServerContext :: Context '[ AuthHandler Request () ]
|
||||
genAuthServerContext :: Context '[ AuthHandler Wai.Request () ]
|
||||
genAuthServerContext = genAuthHandler :. EmptyContext
|
||||
|
||||
genAuthServer :: Application
|
||||
genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice))
|
||||
genAuthServer :: TestServer
|
||||
genAuthServer = TestServer "genAuthServer" $
|
||||
serveWithContext genAuthAPI genAuthServerContext (const (return alice))
|
||||
|
||||
{-# NOINLINE manager #-}
|
||||
manager :: C.Manager
|
||||
manager = unsafePerformIO $ C.newManager C.defaultManagerSettings
|
||||
|
||||
sucessSpec :: Spec
|
||||
sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
|
||||
sucessSpec = around (withTestServer "server") $ do
|
||||
|
||||
it "Servant.API.Get" $ \(_, baseUrl) -> do
|
||||
it "Servant.API.Get" $ \baseUrl -> do
|
||||
(left show <$> runExceptT (getGet manager baseUrl)) `shouldReturn` Right alice
|
||||
|
||||
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
|
||||
|
||||
it "allows content type" $ \(_, baseUrl) -> do
|
||||
it "allows content type" $ \baseUrl -> do
|
||||
(left show <$> runExceptT (getDeleteContentType 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)
|
||||
|
||||
it "Servant.API.ReqBody" $ \(_, baseUrl) -> do
|
||||
it "Servant.API.ReqBody" $ \baseUrl -> do
|
||||
let p = Person "Clara" 42
|
||||
(left show <$> runExceptT (getBody p 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 FailureResponse{..} <- runExceptT (getQueryParam (Just "bob") manager baseUrl)
|
||||
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 <$> runExceptT (getQueryParams ["alice", "bob"] manager baseUrl))
|
||||
`shouldReturn` Right [Person "alice" 0, Person "bob" 1]
|
||||
|
||||
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
|
||||
|
||||
it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
|
||||
it "Servant.API.Raw on success" $ \baseUrl -> do
|
||||
res <- runExceptT (getRawSuccess HTTP.methodGet manager baseUrl)
|
||||
case res of
|
||||
Left e -> assertFailure $ show e
|
||||
|
@ -274,7 +310,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
|
|||
C.responseBody response `shouldBe` body
|
||||
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)
|
||||
case res of
|
||||
Right _ -> assertFailure "expected Left, but got Right"
|
||||
|
@ -282,51 +318,93 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
|
|||
Servant.Client.responseStatus e `shouldBe` HTTP.status400
|
||||
Servant.Client.responseBody e `shouldBe` "rawFailure"
|
||||
|
||||
it "Returns headers appropriately" $ \(_, baseUrl) -> do
|
||||
it "Returns headers appropriately" $ \baseUrl -> do
|
||||
res <- runExceptT (getRespHeaders manager baseUrl)
|
||||
case res of
|
||||
Left e -> assertFailure $ show e
|
||||
Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
|
||||
|
||||
modifyMaxSuccess (const 20) $ 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 ->
|
||||
ioProperty $ do
|
||||
result <- left show <$> runExceptT (getMultiple cap num flag body manager baseUrl)
|
||||
return $
|
||||
result === Right (cap, num, flag, body)
|
||||
|
||||
type ErrorApi =
|
||||
Delete '[JSON] () :<|>
|
||||
Get '[JSON] () :<|>
|
||||
Post '[JSON] () :<|>
|
||||
Put '[JSON] ()
|
||||
|
||||
wrappedApiSpec :: Spec
|
||||
wrappedApiSpec = describe "error status codes" $ do
|
||||
let serveW api = serve api $ throwE $ ServantErr 500 "error message" "" []
|
||||
context "are correctly handled by the client" $
|
||||
let test :: (WrappedApi, String) -> Spec
|
||||
test (WrappedApi api, desc) =
|
||||
it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do
|
||||
let getResponse :: C.Manager -> BaseUrl -> SCR.ClientM ()
|
||||
getResponse = client api
|
||||
Left FailureResponse{..} <- runExceptT (getResponse manager baseUrl)
|
||||
responseStatus `shouldBe` (HTTP.Status 500 "error message")
|
||||
in mapM_ test $
|
||||
(WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :
|
||||
(WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") :
|
||||
(WrappedApi (Proxy :: Proxy (Post '[JSON] ())), "Post") :
|
||||
(WrappedApi (Proxy :: Proxy (Put '[JSON] ())), "Put") :
|
||||
[]
|
||||
errorApi :: Proxy ErrorApi
|
||||
errorApi = Proxy
|
||||
|
||||
errorServer :: TestServer
|
||||
errorServer = TestServer "errorServer" $ serve errorApi $
|
||||
err :<|> err :<|> err :<|> err
|
||||
where
|
||||
err = throwE $ ServantErr 500 "error message" "" []
|
||||
|
||||
errorSpec :: Spec
|
||||
errorSpec =
|
||||
around (withTestServer "errorServer") $ do
|
||||
describe "error status codes" $
|
||||
it "reports error statuses correctly" $ \baseUrl -> do
|
||||
let delete :<|> get :<|> post :<|> put =
|
||||
client errorApi
|
||||
actions = map (\ f -> f manager baseUrl) [delete, get, post, put]
|
||||
forM_ actions $ \ clientAction -> do
|
||||
Left FailureResponse{..} <- runExceptT clientAction
|
||||
responseStatus `shouldBe` HTTP.Status 500 "error message"
|
||||
|
||||
basicAuthSpec :: Spec
|
||||
basicAuthSpec = around (withTestServer "basicAuthServer") $ do
|
||||
context "Authentication works when requests are properly authenticated" $ do
|
||||
|
||||
it "Authenticates a BasicAuth protected server appropriately" $ \baseUrl -> do
|
||||
let getBasic = client basicAuthAPI
|
||||
let basicAuthData = BasicAuthData "servant" "server"
|
||||
(left show <$> runExceptT (getBasic basicAuthData manager baseUrl)) `shouldReturn` Right alice
|
||||
|
||||
context "Authentication is rejected when requests are not authenticated properly" $ do
|
||||
|
||||
it "Authenticates a BasicAuth protected server appropriately" $ \baseUrl -> do
|
||||
let getBasic = client basicAuthAPI
|
||||
let basicAuthData = BasicAuthData "not" "password"
|
||||
Left FailureResponse{..} <- runExceptT (getBasic basicAuthData manager baseUrl)
|
||||
responseStatus `shouldBe` HTTP.Status 403 "Forbidden"
|
||||
|
||||
genAuthSpec :: Spec
|
||||
genAuthSpec = around (withTestServer "genAuthServer") $ do
|
||||
context "Authentication works when requests are properly authenticated" $ do
|
||||
|
||||
it "Authenticates a AuthProtect protected server appropriately" $ \baseUrl -> do
|
||||
let getProtected = client genAuthAPI
|
||||
let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "AuthHeader" ("cool" :: String) req)
|
||||
(left show <$> runExceptT (getProtected authRequest manager baseUrl)) `shouldReturn` Right alice
|
||||
|
||||
context "Authentication is rejected when requests are not authenticated properly" $ do
|
||||
|
||||
it "Authenticates a AuthProtect protected server appropriately" $ \baseUrl -> do
|
||||
let getProtected = client genAuthAPI
|
||||
let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "Wrong" ("header" :: String) req)
|
||||
Left FailureResponse{..} <- runExceptT (getProtected authRequest manager baseUrl)
|
||||
responseStatus `shouldBe` (HTTP.Status 401 "Unauthorized")
|
||||
|
||||
failSpec :: Spec
|
||||
failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
|
||||
failSpec = around (withTestServer "failServer") $ do
|
||||
|
||||
context "client returns errors appropriately" $ do
|
||||
it "reports FailureResponse" $ \(_, baseUrl) -> do
|
||||
it "reports FailureResponse" $ \baseUrl -> do
|
||||
let (_ :<|> getDeleteEmpty :<|> _) = client api
|
||||
Left res <- runExceptT (getDeleteEmpty manager baseUrl)
|
||||
case res of
|
||||
FailureResponse (HTTP.Status 404 "Not Found") _ _ -> return ()
|
||||
_ -> fail $ "expected 404 response, but got " <> show res
|
||||
|
||||
it "reports DecodeFailure" $ \(_, baseUrl) -> do
|
||||
it "reports DecodeFailure" $ \baseUrl -> do
|
||||
let (_ :<|> _ :<|> getCapture :<|> _) = client api
|
||||
Left res <- runExceptT (getCapture "foo" manager baseUrl)
|
||||
case res of
|
||||
|
@ -340,81 +418,23 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
|
|||
ConnectionError _ -> return ()
|
||||
_ -> fail $ "expected ConnectionError, but got " <> show res
|
||||
|
||||
it "reports UnsupportedContentType" $ \(_, baseUrl) -> do
|
||||
it "reports UnsupportedContentType" $ \baseUrl -> do
|
||||
let (getGet :<|> _ ) = client api
|
||||
Left res <- runExceptT (getGet manager baseUrl)
|
||||
case res of
|
||||
UnsupportedContentType ("application/octet-stream") _ -> return ()
|
||||
_ -> fail $ "expected UnsupportedContentType, but got " <> show res
|
||||
|
||||
it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do
|
||||
it "reports InvalidContentTypeHeader" $ \baseUrl -> do
|
||||
let (_ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
|
||||
Left res <- runExceptT (getBody alice manager baseUrl)
|
||||
case res of
|
||||
InvalidContentTypeHeader "fooooo" _ -> return ()
|
||||
_ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
|
||||
|
||||
data WrappedApi where
|
||||
WrappedApi :: (HasServer (api :: *) '[], Server api ~ ExceptT ServantErr IO a,
|
||||
HasClient api, Client api ~ (C.Manager -> BaseUrl -> SCR.ClientM ())) =>
|
||||
Proxy api -> WrappedApi
|
||||
|
||||
basicAuthSpec :: Spec
|
||||
basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ do
|
||||
context "Authentication works when requests are properly authenticated" $ do
|
||||
|
||||
it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
|
||||
let getBasic = client basicAuthAPI
|
||||
let basicAuthData = BasicAuthData "servant" "server"
|
||||
(left show <$> runExceptT (getBasic basicAuthData manager baseUrl)) `shouldReturn` Right alice
|
||||
|
||||
context "Authentication is rejected when requests are not authenticated properly" $ do
|
||||
|
||||
it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
|
||||
let getBasic = client basicAuthAPI
|
||||
let basicAuthData = BasicAuthData "not" "password"
|
||||
Left FailureResponse{..} <- runExceptT (getBasic basicAuthData manager baseUrl)
|
||||
responseStatus `shouldBe` HTTP.Status 403 "Forbidden"
|
||||
|
||||
genAuthSpec :: Spec
|
||||
genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do
|
||||
context "Authentication works when requests are properly authenticated" $ do
|
||||
|
||||
it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
|
||||
let getProtected = client genAuthAPI
|
||||
let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "AuthHeader" ("cool" :: String) req)
|
||||
(left show <$> runExceptT (getProtected authRequest manager baseUrl)) `shouldReturn` Right alice
|
||||
|
||||
context "Authentication is rejected when requests are not authenticated properly" $ do
|
||||
|
||||
it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
|
||||
let getProtected = client genAuthAPI
|
||||
let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "Wrong" ("header" :: String) req)
|
||||
Left FailureResponse{..} <- runExceptT (getProtected authRequest manager baseUrl)
|
||||
responseStatus `shouldBe` (HTTP.Status 401 "Unauthorized")
|
||||
|
||||
-- * utils
|
||||
|
||||
startWaiApp :: Application -> IO (ThreadId, BaseUrl)
|
||||
startWaiApp app = do
|
||||
(port, socket) <- openTestSocket
|
||||
let settings = setPort port $ defaultSettings
|
||||
thread <- forkIO $ runSettingsSocket settings socket app
|
||||
return (thread, BaseUrl Http "localhost" port "")
|
||||
|
||||
|
||||
endWaiApp :: (ThreadId, BaseUrl) -> IO ()
|
||||
endWaiApp (thread, _) = killThread thread
|
||||
|
||||
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 (NonEmptyList Char)
|
||||
pathGen = fmap NonEmpty path
|
||||
where
|
||||
|
|
10
servant-client/test/ghcjs/build-test-server.sh
Executable file
10
servant-client/test/ghcjs/build-test-server.sh
Executable file
|
@ -0,0 +1,10 @@
|
|||
#/usr/bin/env bash
|
||||
|
||||
set -o errexit
|
||||
|
||||
cd test/ghcjs/testServer
|
||||
|
||||
unset STACK_YAML
|
||||
stack setup
|
||||
stack build
|
||||
cp $(stack exec which testServer) .
|
14
servant-client/test/ghcjs/run-tests.sh
Executable file
14
servant-client/test/ghcjs/run-tests.sh
Executable file
|
@ -0,0 +1,14 @@
|
|||
#!/usr/bin/env bash
|
||||
|
||||
set -o errexit
|
||||
|
||||
loc=$(dirname $0)
|
||||
cd $loc
|
||||
|
||||
cd ../../
|
||||
|
||||
npm install xhr2
|
||||
|
||||
export STACK_YAML=test/ghcjs/stack-ghcjs.yaml
|
||||
stack setup
|
||||
stack test --fast
|
25
servant-client/test/ghcjs/stack-ghcjs.yaml
Normal file
25
servant-client/test/ghcjs/stack-ghcjs.yaml
Normal file
|
@ -0,0 +1,25 @@
|
|||
# This file was added for being able to test ghcjs support
|
||||
|
||||
packages:
|
||||
- location: ../../.
|
||||
- location: ../../../servant
|
||||
extra-dep: true
|
||||
- location: ../../../servant-server
|
||||
extra-dep: true
|
||||
|
||||
resolver: lts-5.11
|
||||
|
||||
compiler: ghcjs-0.2.0.20160315_ghc-7.10.2
|
||||
compiler-check: match-exact
|
||||
setup-info:
|
||||
ghcjs:
|
||||
source:
|
||||
ghcjs-0.2.0.20160315_ghc-7.10.2:
|
||||
url: "https://github.com/nrolland/ghcjs/releases/download/v.0.2.0.20160315/ghcjs-0.2.0.20160315.tar.gz"
|
||||
|
||||
extra-deps:
|
||||
- hspec-expectations-0.7.2
|
||||
- hspec-discover-2.2.1
|
||||
- http-api-data-0.1.1.1
|
||||
- hspec-2.2.1
|
||||
- hspec-core-2.2.1
|
35
servant-client/test/ghcjs/testServer/package.yaml
Normal file
35
servant-client/test/ghcjs/testServer/package.yaml
Normal file
|
@ -0,0 +1,35 @@
|
|||
name: testServer
|
||||
|
||||
executables:
|
||||
testServer:
|
||||
main: testServer.hs
|
||||
other-modules: []
|
||||
dependencies:
|
||||
- base
|
||||
- aeson
|
||||
- base64-bytestring
|
||||
- bytestring
|
||||
- exceptions
|
||||
- hspec
|
||||
- http-api-data
|
||||
- http-client
|
||||
- http-media
|
||||
- http-types
|
||||
- HUnit
|
||||
- network
|
||||
- network-uri
|
||||
- QuickCheck
|
||||
- safe
|
||||
- servant
|
||||
- servant-server
|
||||
- string-conversions
|
||||
- text
|
||||
- transformers
|
||||
- wai
|
||||
- warp
|
||||
source-dirs:
|
||||
- ./
|
||||
- ../../../test
|
||||
- ../../../src
|
||||
include-dirs:
|
||||
- ../../../include
|
10
servant-client/test/ghcjs/testServer/stack.yaml
Normal file
10
servant-client/test/ghcjs/testServer/stack.yaml
Normal file
|
@ -0,0 +1,10 @@
|
|||
flags: {}
|
||||
packages:
|
||||
- location: ./.
|
||||
- location: ../../../../
|
||||
subdirs:
|
||||
- servant
|
||||
- servant-client
|
||||
- servant-server
|
||||
extra-dep: true
|
||||
resolver: lts-5.15
|
41
servant-client/test/ghcjs/testServer/testServer.cabal
Normal file
41
servant-client/test/ghcjs/testServer/testServer.cabal
Normal file
|
@ -0,0 +1,41 @@
|
|||
-- This file has been generated from package.yaml by hpack version 0.13.0.
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
|
||||
name: testServer
|
||||
version: 0.0.0
|
||||
build-type: Simple
|
||||
cabal-version: >= 1.10
|
||||
|
||||
executable testServer
|
||||
main-is: testServer.hs
|
||||
hs-source-dirs:
|
||||
./
|
||||
, ../../../test
|
||||
, ../../../src
|
||||
include-dirs:
|
||||
../../../include
|
||||
build-depends:
|
||||
base
|
||||
, aeson
|
||||
, base64-bytestring
|
||||
, bytestring
|
||||
, exceptions
|
||||
, hspec
|
||||
, http-api-data
|
||||
, http-client
|
||||
, http-media
|
||||
, http-types
|
||||
, HUnit
|
||||
, network
|
||||
, network-uri
|
||||
, QuickCheck
|
||||
, safe
|
||||
, servant
|
||||
, servant-server
|
||||
, string-conversions
|
||||
, text
|
||||
, transformers
|
||||
, wai
|
||||
, warp
|
||||
default-language: Haskell2010
|
28
servant-client/test/ghcjs/testServer/testServer.hs
Normal file
28
servant-client/test/ghcjs/testServer/testServer.hs
Normal file
|
@ -0,0 +1,28 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
import Network.Wai.Handler.Warp
|
||||
import Servant
|
||||
import System.IO
|
||||
|
||||
import Servant.Client.TestServer.GHC
|
||||
import Servant.Client.TestServer.Types
|
||||
import Servant.ClientSpec
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
(port, socket) <- openTestSocket
|
||||
let settings =
|
||||
setPort port $
|
||||
setBeforeMainLoop (print port >> hFlush stdout) $
|
||||
defaultSettings
|
||||
runSettingsSocket settings socket $
|
||||
serve testServerApi $ \ testServerName request respond -> do
|
||||
app <- testServerApp <$> lookupTestServer testServerName
|
||||
app request respond
|
||||
|
||||
type TestServerApi =
|
||||
Capture "testServerName" String :> Raw
|
||||
|
||||
testServerApi :: Proxy TestServerApi
|
||||
testServerApi = Proxy
|
Loading…
Reference in a new issue