diff --git a/example/greet.hs b/example/greet.hs
index 0584c246..43a13fec 100644
--- a/example/greet.hs
+++ b/example/greet.hs
@@ -75,9 +75,9 @@ server = hello :<|> greet :<|> delete
clientApi :: Client TestApi
clientApi = client testApi
-getGreet :: Text -> Maybe Bool -> URI -> EitherT String IO Greet
-postGreet :: Greet -> URI -> EitherT String IO Greet
-deleteGreet :: Text -> URI -> EitherT String IO ()
+getGreet :: Text -> Maybe Bool -> URIAuth -> EitherT String IO Greet
+postGreet :: Greet -> URIAuth -> EitherT String IO Greet
+deleteGreet :: Text -> URIAuth -> EitherT String IO ()
getGreet :<|> postGreet :<|> deleteGreet = clientApi
-- Turn the server into a WAI app
@@ -96,7 +96,7 @@ runTestServer port = run port test
main :: IO ()
main = do
tid <- forkIO $ runTestServer 8001
- let Just uri = parseURI "http://localhost:8001"
+ let uri = mkHost "localhost" 8001
print =<< runEitherT (getGreet "alp" (Just True) uri)
print =<< runEitherT (getGreet "alp" (Just False) uri)
let g = Greet "yo"
diff --git a/servant.cabal b/servant.cabal
index 8edd6177..ed513c58 100644
--- a/servant.cabal
+++ b/servant.cabal
@@ -86,6 +86,7 @@ test-suite spec
, hspec-wai
, http-client
, http-types
+ , network >= 2.6
, network-uri >= 2.6
, servant
, string-conversions
@@ -93,3 +94,4 @@ test-suite spec
, transformers
, wai
, wai-extra
+ , warp
diff --git a/src/Servant/API/Delete.hs b/src/Servant/API/Delete.hs
index fb1a7982..356b5f7f 100644
--- a/src/Servant/API/Delete.hs
+++ b/src/Servant/API/Delete.hs
@@ -36,10 +36,10 @@ instance HasServer Delete where
| otherwise = respond $ failWith NotFound
instance HasClient Delete where
- type Client Delete = URI -> EitherT String IO ()
+ type Client Delete = URIAuth -> EitherT String IO ()
- clientWithRoute Proxy req uri = do
- partialRequest <- liftIO $ reqToRequest req uri
+ clientWithRoute Proxy req host = do
+ partialRequest <- liftIO $ reqToRequest req host
let request = partialRequest { Client.method = methodDelete
}
diff --git a/src/Servant/API/Get.hs b/src/Servant/API/Get.hs
index 0598b372..bc63f3e6 100644
--- a/src/Servant/API/Get.hs
+++ b/src/Servant/API/Get.hs
@@ -37,9 +37,9 @@ instance ToJSON result => HasServer (Get result) where
| otherwise = respond $ failWith NotFound
instance FromJSON result => HasClient (Get result) where
- type Client (Get result) = URI -> EitherT String IO result
- clientWithRoute Proxy req uri = do
- innerRequest <- liftIO $ reqToRequest req uri
+ type Client (Get result) = URIAuth -> EitherT String IO result
+ clientWithRoute Proxy req host = do
+ innerRequest <- liftIO $ reqToRequest req host
innerResponse <- liftIO $ __withGlobalManager $ \ manager ->
Client.httpLbs innerRequest manager
diff --git a/src/Servant/API/Post.hs b/src/Servant/API/Post.hs
index c4f0044c..bdb04e52 100644
--- a/src/Servant/API/Post.hs
+++ b/src/Servant/API/Post.hs
@@ -39,7 +39,7 @@ instance ToJSON a => HasServer (Post a) where
| otherwise = respond $ failWith NotFound
instance FromJSON a => HasClient (Post a) where
- type Client (Post a) = URI -> EitherT String IO a
+ type Client (Post a) = URIAuth -> EitherT String IO a
clientWithRoute Proxy req uri = do
partialRequest <- liftIO $ reqToRequest req uri
diff --git a/src/Servant/API/Put.hs b/src/Servant/API/Put.hs
index 3b2e2d51..0a10ae25 100644
--- a/src/Servant/API/Put.hs
+++ b/src/Servant/API/Put.hs
@@ -38,7 +38,7 @@ instance ToJSON a => HasServer (Put a) where
| otherwise = respond $ failWith NotFound
instance FromJSON a => HasClient (Put a) where
- type Client (Put a) = URI -> EitherT String IO a
+ type Client (Put a) = URIAuth -> EitherT String IO a
clientWithRoute Proxy req uri = do
partialRequest <- liftIO $ reqToRequest req uri
diff --git a/src/Servant/Client.hs b/src/Servant/Client.hs
index efd4aba7..efcfa4c4 100644
--- a/src/Servant/Client.hs
+++ b/src/Servant/Client.hs
@@ -14,6 +14,10 @@ import System.IO.Unsafe
-- * Accessing APIs as a Client
+-- | Convenience function for creating 'URIAuth's.
+mkHost :: String -> Int -> URIAuth
+mkHost hostName port = URIAuth "" hostName (":" ++ show port)
+
-- | 'client' allows you to produce operations to query an API from a client.
client :: HasClient layout => Proxy layout -> Client layout
client p = clientWithRoute p defReq
@@ -46,11 +50,13 @@ appendToQueryString pname pvalue req =
setRQBody :: ByteString -> Req -> Req
setRQBody b req = req { reqBody = b }
-reqToRequest :: (Functor m, MonadThrow m) => Req -> URI -> m Request
-reqToRequest req uri = fmap (setrqb . setQS ) $ parseUrl url
+reqToRequest :: (Functor m, MonadThrow m) => Req -> URIAuth -> m Request
+reqToRequest req host = fmap (setrqb . setQS ) $ parseUrl url
- where url = show $ nullURI { uriPath = reqPath req }
- `relativeTo` uri
+ where url = show $ nullURI { uriScheme = "http:"
+ , uriAuthority = Just host
+ , uriPath = reqPath req
+ }
setrqb r = r { requestBody = RequestBodyLBS (reqBody req) }
setQS = setQueryString $ queryTextToQuery (qs req)
diff --git a/test/Servant/ClientSpec.hs b/test/Servant/ClientSpec.hs
new file mode 100644
index 00000000..e36a4a39
--- /dev/null
+++ b/test/Servant/ClientSpec.hs
@@ -0,0 +1,81 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Servant.ClientSpec where
+
+import Control.Concurrent
+import Control.Exception
+import Control.Monad.Trans.Either
+import Data.Proxy
+import Network.Socket
+import Network.URI
+import Network.Wai
+import Network.Wai.Handler.Warp
+import Test.Hspec
+
+import Servant.Client
+import Servant.API.Sub
+import Servant.API.Get
+import Servant.Server
+
+import Servant.ServerSpec
+
+type Api =
+ "a" :> Get Person
+api :: Proxy Api
+api = Proxy
+
+server :: Application
+server = serve api (
+ return alice
+ )
+
+getA :: URIAuth -> EitherT String IO Person
+getA = client api
+
+spec :: Spec
+spec = do
+ it "Servant.API.Get" $ withWaiDaemon (return server) $ \ port -> do
+ runEitherT (getA (mkHost "localhost" port)) `shouldReturn` Right alice
+
+
+-- * utils
+
+withWaiDaemon :: IO Application -> (Port -> IO a) -> IO a
+withWaiDaemon mkApplication action = do
+ application <- mkApplication
+ bracket (acquire application) free (\ (_, _, port) -> action port)
+ where
+ acquire application = do
+ (notifyStart, waitForStart) <- lvar
+ (notifyKilled, waitForKilled) <- lvar
+ thread <- forkIO $ (do
+ (krakenPort, socket) <- openTestSocket
+ let settings =
+ setPort krakenPort $ -- set here just for consistency, shouldn't be
+ -- used (it's set in the socket)
+ setBeforeMainLoop (notifyStart krakenPort)
+ defaultSettings
+ runSettingsSocket settings socket application)
+ `finally` notifyKilled ()
+ krakenPort <- waitForStart
+ return (thread, waitForKilled, krakenPort)
+ free (thread, waitForKilled, _) = do
+ killThread thread
+ waitForKilled
+
+ lvar :: IO (a -> IO (), IO a)
+ lvar = do
+ mvar <- newEmptyMVar
+ let put = putMVar mvar
+ wait = readMVar mvar
+ return (put, wait)
+
+openTestSocket :: IO (Port, Socket)
+openTestSocket = do
+ s <- socket AF_INET Stream defaultProtocol
+ localhost <- inet_addr "127.0.0.1"
+ bind s (SockAddrInet aNY_PORT localhost)
+ listen s 1
+ port <- socketPort s
+ return (fromIntegral port, s)