From f058a3051ab4b6514c14d6e90c0732dd4974af20 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Thu, 30 Oct 2014 11:29:03 +0000 Subject: [PATCH] HasClient: changing URI to URIAuth (and adding the first client test case) --- example/greet.hs | 8 ++-- servant.cabal | 2 + src/Servant/API/Delete.hs | 6 +-- src/Servant/API/Get.hs | 6 +-- src/Servant/API/Post.hs | 2 +- src/Servant/API/Put.hs | 2 +- src/Servant/Client.hs | 14 +++++-- test/Servant/ClientSpec.hs | 81 ++++++++++++++++++++++++++++++++++++++ 8 files changed, 105 insertions(+), 16 deletions(-) create mode 100644 test/Servant/ClientSpec.hs 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)