f058a30 · typeable/servant

example/greet.hs+4−4

compare with master

unifiedsplit

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

75clientApi :: Client TestApi

76clientApi = client testApi

77

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

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

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

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

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

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

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

82

83-- Turn the server into a WAI app

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

96main :: IO ()

97main = do

98 tid <- forkIO $ runTestServer 8001

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

99+ let uri = mkHost "localhost" 8001

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

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

102 let g = Greet "yo"

servant.cabal+2

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

86 , hspec-wai

87 , http-client

88 , http-types

89+ , network >= 2.6

89 , network-uri >= 2.6

90 , network-uri >= 2.6

90 , servant

91 , servant

91 , string-conversions

92 , string-conversions

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

93 , transformers

94 , transformers

94 , wai

95 , wai

95 , wai-extra

96 , wai-extra

97+ , warp

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

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

36 | otherwise = respond $ failWith NotFound

37

38instance HasClient Delete where

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

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

40

41− clientWithRoute Proxy req uri = do

41+ clientWithRoute Proxy req host = do

42− partialRequest <- liftIO $ reqToRequest req uri

42+ partialRequest <- liftIO $ reqToRequest req host

43

44 let request = partialRequest { Client.method = methodDelete

45 }

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

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

37 | otherwise = respond $ failWith NotFound

38

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

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

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

41− clientWithRoute Proxy req uri = do

41+ clientWithRoute Proxy req host = do

42− innerRequest <- liftIO $ reqToRequest req uri

42+ innerRequest <- liftIO $ reqToRequest req host

43

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

45 Client.httpLbs innerRequest manager

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

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

39 | otherwise = respond $ failWith NotFound

40

41instance 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

43

44 clientWithRoute Proxy req uri = do

45 partialRequest <- liftIO $ reqToRequest req uri

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

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

38 | otherwise = respond $ failWith NotFound

39

40instance 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

42

43 clientWithRoute Proxy req uri = do

44 partialRequest <- liftIO $ reqToRequest req uri

src/Servant/Client.hs+10−4

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

14

15-- * Accessing APIs as a Client

16

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

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

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

20+

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

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

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

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

19client p = clientWithRoute p defReq

23client p = clientWithRoute p defReq

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

46setRQBody :: ByteString -> Req -> Req

50setRQBody :: ByteString -> Req -> Req

47setRQBody b req = req { reqBody = b }

51setRQBody b req = req { reqBody = b }

48

52

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

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

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

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

51

55

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

57+ , uriAuthority = Just host

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

58+ , uriPath = reqPath req

53− `relativeTo` uri

59+ }

54

60

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

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

56 setQS = setQueryString $ queryTextToQuery (qs req)

62 setQS = setQueryString $ queryTextToQuery (qs req)

test/Servant/ClientSpec.hsnew file+81

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

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE TypeOperators #-}

3+

4+module Servant.ClientSpec where

5+

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)