f058a30 · typeable/servant

git.iko.soy/typeable/servant

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

case)

commitf058a3051ab4b6514c14d6e90c0732dd4974af20 authorSönke Hahn <soenkehahn@gmail.com> dateThu 30 Oct 2014, 11:29 (12 years ago) parentdf12f9b

8 files changed+105−16

compare with master

unifiedsplit

example/greet.hs+4−4 servant.cabal+2 src/Servant/API/Delete.hs+3−3 src/Servant/API/Get.hs+3−3 src/Servant/API/Post.hs+1−1 src/Servant/API/Put.hs+1−1 src/Servant/Client.hs+10−4 test/Servant/ClientSpec.hs+81

example/greet.hs+4−4

@@ -75,9 +75,9 @@ server = hello :<|> greet :<|> delete

7575clientApi :: Client TestApi

7676clientApi = client testApi

7777

78−getGreet :: Text -> Maybe Bool -> URI -> EitherT String IO Greet

79−postGreet :: Greet -> URI -> EitherT String IO Greet

80−deleteGreet :: Text -> URI -> EitherT String IO ()

78+getGreet :: Text -> Maybe Bool -> URIAuth -> EitherT String IO Greet

79+postGreet :: Greet -> URIAuth -> EitherT String IO Greet

80+deleteGreet :: Text -> URIAuth -> EitherT String IO ()

8181getGreet :<|> postGreet :<|> deleteGreet = clientApi

8282

8383-- Turn the server into a WAI app

@@ -96,7 +96,7 @@ runTestServer port = run port test

9696main :: IO ()

9797main = do

9898 tid <- forkIO $ runTestServer 8001

99− let Just uri = parseURI "http://localhost:8001"

99+ let uri = mkHost "localhost" 8001

100100 print =<< runEitherT (getGreet "alp" (Just True) uri)

101101 print =<< runEitherT (getGreet "alp" (Just False) uri)

102102 let g = Greet "yo"

servant.cabal+2

@@ -86,6 +86,7 @@ test-suite spec

8686 , hspec-wai

8787 , http-client

8888 , http-types

89+ , network >= 2.6

8990 , network-uri >= 2.6

9091 , servant

9192 , string-conversions

@@ -93,3 +94,4 @@ test-suite spec

9394 , transformers

9495 , wai

9596 , wai-extra

97+ , warp

src/Servant/API/Delete.hs+3−3

@@ -36,10 +36,10 @@ instance HasServer Delete where

3636 | otherwise = respond $ failWith NotFound

3737

3838instance HasClient Delete where

39− type Client Delete = URI -> EitherT String IO ()

39+ type Client Delete = URIAuth -> EitherT String IO ()

4040

41− clientWithRoute Proxy req uri = do

42− partialRequest <- liftIO $ reqToRequest req uri

41+ clientWithRoute Proxy req host = do

42+ partialRequest <- liftIO $ reqToRequest req host

4343

4444 let request = partialRequest { Client.method = methodDelete

4545 }

src/Servant/API/Get.hs+3−3

@@ -37,9 +37,9 @@ instance ToJSON result => HasServer (Get result) where

3737 | otherwise = respond $ failWith NotFound

3838

3939instance FromJSON result => HasClient (Get result) where

40− type Client (Get result) = URI -> EitherT String IO result

41− clientWithRoute Proxy req uri = do

42− innerRequest <- liftIO $ reqToRequest req uri

40+ type Client (Get result) = URIAuth -> EitherT String IO result

41+ clientWithRoute Proxy req host = do

42+ innerRequest <- liftIO $ reqToRequest req host

4343

4444 innerResponse <- liftIO $ __withGlobalManager $ \ manager ->

4545 Client.httpLbs innerRequest manager

src/Servant/API/Post.hs+1−1

@@ -39,7 +39,7 @@ instance ToJSON a => HasServer (Post a) where

3939 | otherwise = respond $ failWith NotFound

4040

4141instance FromJSON a => HasClient (Post a) where

42− type Client (Post a) = URI -> EitherT String IO a

42+ type Client (Post a) = URIAuth -> EitherT String IO a

4343

4444 clientWithRoute Proxy req uri = do

4545 partialRequest <- liftIO $ reqToRequest req uri

src/Servant/API/Put.hs+1−1

@@ -38,7 +38,7 @@ instance ToJSON a => HasServer (Put a) where

3838 | otherwise = respond $ failWith NotFound

3939

4040instance FromJSON a => HasClient (Put a) where

41− type Client (Put a) = URI -> EitherT String IO a

41+ type Client (Put a) = URIAuth -> EitherT String IO a

4242

4343 clientWithRoute Proxy req uri = do

4444 partialRequest <- liftIO $ reqToRequest req uri

src/Servant/Client.hs+10−4

@@ -14,6 +14,10 @@ import System.IO.Unsafe

1414

1515-- * Accessing APIs as a Client

1616

17+-- | Convenience function for creating 'URIAuth's.

18+mkHost :: String -> Int -> URIAuth

19+mkHost hostName port = URIAuth "" hostName (":" ++ show port)

20+

1721-- | 'client' allows you to produce operations to query an API from a client.

1822client :: HasClient layout => Proxy layout -> Client layout

1923client p = clientWithRoute p defReq

@@ -46,11 +50,13 @@ appendToQueryString pname pvalue req =

4650setRQBody :: ByteString -> Req -> Req

4751setRQBody b req = req { reqBody = b }

4852

49−reqToRequest :: (Functor m, MonadThrow m) => Req -> URI -> m Request

50−reqToRequest req uri = fmap (setrqb . setQS ) $ parseUrl url

53+reqToRequest :: (Functor m, MonadThrow m) => Req -> URIAuth -> m Request

54+reqToRequest req host = fmap (setrqb . setQS ) $ parseUrl url

5155

52− where url = show $ nullURI { uriPath = reqPath req }

53− `relativeTo` uri

56+ where url = show $ nullURI { uriScheme = "http:"

57+ , uriAuthority = Just host

58+ , uriPath = reqPath req

59+ }

5460

5561 setrqb r = r { requestBody = RequestBodyLBS (reqBody req) }

5662 setQS = setQueryString $ queryTextToQuery (qs req)

test/Servant/ClientSpec.hsnew file+81

@@ -0,0 +1,81 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE TypeOperators #-}

4+module Servant.ClientSpec where

6+import Control.Concurrent

7+import Control.Exception

8+import Control.Monad.Trans.Either

9+import Data.Proxy

10+import Network.Socket

11+import Network.URI

12+import Network.Wai

13+import Network.Wai.Handler.Warp

14+import Test.Hspec

15+

16+import Servant.Client

17+import Servant.API.Sub

18+import Servant.API.Get

19+import Servant.Server

20+

21+import Servant.ServerSpec

22+

23+type Api =

24+ "a" :> Get Person

25+api :: Proxy Api

26+api = Proxy

27+

28+server :: Application

29+server = serve api (

30+ return alice

31+ )

32+

33+getA :: URIAuth -> EitherT String IO Person

34+getA = client api

35+

36+spec :: Spec

37+spec = do

38+ it "Servant.API.Get" $ withWaiDaemon (return server) $ \ port -> do

39+ runEitherT (getA (mkHost "localhost" port)) `shouldReturn` Right alice

40+

41+

42+-- * utils

43+

44+withWaiDaemon :: IO Application -> (Port -> IO a) -> IO a

45+withWaiDaemon mkApplication action = do

46+ application <- mkApplication

47+ bracket (acquire application) free (\ (_, _, port) -> action port)

48+ where

49+ acquire application = do

50+ (notifyStart, waitForStart) <- lvar

51+ (notifyKilled, waitForKilled) <- lvar

52+ thread <- forkIO $ (do

53+ (krakenPort, socket) <- openTestSocket

54+ let settings =

55+ setPort krakenPort $ -- set here just for consistency, shouldn't be

56+ -- used (it's set in the socket)

57+ setBeforeMainLoop (notifyStart krakenPort)

58+ defaultSettings

59+ runSettingsSocket settings socket application)

60+ `finally` notifyKilled ()

61+ krakenPort <- waitForStart

62+ return (thread, waitForKilled, krakenPort)

63+ free (thread, waitForKilled, _) = do

64+ killThread thread

65+ waitForKilled

66+

67+ lvar :: IO (a -> IO (), IO a)

68+ lvar = do

69+ mvar <- newEmptyMVar

70+ let put = putMVar mvar

71+ wait = readMVar mvar

72+ return (put, wait)

73+

74+openTestSocket :: IO (Port, Socket)

75+openTestSocket = do

76+ s <- socket AF_INET Stream defaultProtocol

77+ localhost <- inet_addr "127.0.0.1"

78+ bind s (SockAddrInet aNY_PORT localhost)

79+ listen s 1

80+ port <- socketPort s

81+ return (fromIntegral port, s)