HasClient: changing URI to URIAuth (and adding the first client test

case)

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"

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

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
                                  }

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

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

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

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)

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)