f0bca38 · typeable/servant

git.iko.soy/typeable/servant

implement BaseUrl to allow https for Clients

commitf0bca3852c1f8710b5f0bc50edd2010991f986ed authorSönke Hahn <soenke.hahn@zalora.com> dateWed 5 Nov 2014, 20:03 (12 years ago) parent11f8263

9 files changed+46−41

compare with master

unifiedsplit

example/greet.hs+4−5 servant.cabal+1−3 src/Servant/API/Delete.hs+1−2 src/Servant/API/Get.hs+1−2 src/Servant/API/Post.hs+1−2 src/Servant/API/Put.hs+1−2 src/Servant/Client.hs+20−7 src/Servant/Utils/Client.hs+1−2 test/Servant/ClientSpec.hs+16−16

example/greet.hs+4−5

@@ -15,7 +15,6 @@ import Data.Monoid

1515import Data.Proxy

1616import Data.Text

1717import GHC.Generics

18−import Network.URI

1918import Network.Wai

2019import Network.Wai.Handler.Warp

2120

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

7574clientApi :: Client TestApi

7675clientApi = client testApi

7776

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 ()

77+getGreet :: Text -> Maybe Bool -> BaseUrl -> EitherT String IO Greet

78+postGreet :: Greet -> BaseUrl -> EitherT String IO Greet

79+deleteGreet :: Text -> BaseUrl -> EitherT String IO ()

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

8281

8382-- Turn the server into a WAI app

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

9695main :: IO ()

9796main = do

9897 tid <- forkIO $ runTestServer 8001

99− let uri = mkHost "localhost" 8001

98+ let uri = BaseUrl Http "localhost" 8001

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

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

102101 let g = Greet "yo"

servant.cabal+1−3

@@ -43,7 +43,7 @@ library

4343 , split

4444 , http-client

4545 , http-types

46− , network-uri

46+ , network-uri >= 2.6

4747 , wai

4848 , warp

4949 , safe

@@ -70,7 +70,6 @@ executable greet

7070 , wai

7171 , either

7272 , text

73− , network-uri

7473

7574test-suite spec

7675 type: exitcode-stdio-1.0

@@ -90,7 +89,6 @@ test-suite spec

9089 , http-client

9190 , http-types

9291 , network >= 2.6

93− , network-uri >= 2.6

9492 , QuickCheck

9593 , servant

9694 , string-conversions

src/Servant/API/Delete.hs+1−2

@@ -9,7 +9,6 @@ import Data.Proxy

99import Data.String.Conversions

1010import Data.Typeable

1111import Network.HTTP.Types

12−import Network.URI

1312import Network.Wai

1413import Servant.Client

1514import Servant.Docs

@@ -36,7 +35,7 @@ instance HasServer Delete where

3635 | otherwise = respond $ failWith NotFound

3736

3837instance HasClient Delete where

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

38+ type Client Delete = BaseUrl -> EitherT String IO ()

4039

4140 clientWithRoute Proxy req host =

4241 performRequest methodDelete req 204 host

src/Servant/API/Get.hs+1−2

@@ -10,7 +10,6 @@ import Data.Proxy

1010import Data.String.Conversions

1111import Data.Typeable

1212import Network.HTTP.Types

13−import Network.URI

1413import Network.Wai

1514import Servant.Client

1615import Servant.Docs

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

3736 | otherwise = respond $ failWith NotFound

3837

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

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

39+ type Client (Get result) = BaseUrl -> EitherT String IO result

4140 clientWithRoute Proxy req host =

4241 performRequest methodGet req 200 host

4342

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

@@ -10,7 +10,6 @@ import Data.Proxy

1010import Data.String.Conversions

1111import Data.Typeable

1212import Network.HTTP.Types

13−import Network.URI

1413import Network.Wai

1514import Servant.Client

1615import Servant.Docs

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

3938 | otherwise = respond $ failWith NotFound

4039

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

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

41+ type Client (Post a) = BaseUrl -> EitherT String IO a

4342

4443 clientWithRoute Proxy req uri =

4544 performRequest methodPost req 201 uri

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

@@ -10,7 +10,6 @@ import Data.Proxy

1010import Data.String.Conversions

1111import Data.Typeable

1212import Network.HTTP.Types

13−import Network.URI

1413import Network.Wai

1514import Servant.Client

1615import Servant.Docs

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

3837 | otherwise = respond $ failWith NotFound

3938

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

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

40+ type Client (Put a) = BaseUrl -> EitherT String IO a

4241

4342 clientWithRoute Proxy req host =

4443 performRequest methodPut req 200 host

src/Servant/Client.hs+20−7

@@ -14,9 +14,16 @@ 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)

17+data Scheme = Http | Https

18+

19+data BaseUrl = BaseUrl {

20+ baseUrlScheme :: Scheme,

21+ baseUrlHost :: String,

22+ baseUrlPort :: Int

23+ }

24+

25+httpBaseUrl :: String -> BaseUrl

26+httpBaseUrl host = BaseUrl Http host 80

2027

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

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

@@ -50,11 +57,17 @@ appendToQueryString pname pvalue req =

5057setRQBody :: ByteString -> Req -> Req

5158setRQBody b req = req { reqBody = b }

5259

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

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

60+reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request

61+reqToRequest req (BaseUrl scheme host port) = fmap (setrqb . setQS ) $ parseUrl url

5562

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

57− , uriAuthority = Just host

63+ where url = show $ nullURI { uriScheme = case scheme of

64+ Http -> "http:"

65+ Https -> "https:"

66+ , uriAuthority = Just $

67+ URIAuth { uriUserInfo = ""

68+ , uriRegName = host

69+ , uriPort = ":" ++ show port

70+ }

5871 , uriPath = reqPath req

5972 }

6073

src/Servant/Utils/Client.hs+1−2

@@ -13,13 +13,12 @@ import Data.Attoparsec.ByteString

1313import Data.ByteString.Lazy

1414import Data.String.Conversions

1515import Network.HTTP.Types

16−import Network.URI

1716import Servant.Client

1817

1918import qualified Network.HTTP.Client as Client

2019

2120performRequest :: FromJSON result =>

22− Method -> Req -> Int -> URIAuth -> EitherT String IO result

21+ Method -> Req -> Int -> BaseUrl -> EitherT String IO result

2322performRequest method req wantedStatus host = do

2423 partialRequest <- liftIO $ reqToRequest req host

2524

test/Servant/ClientSpec.hs+16−16

@@ -13,7 +13,6 @@ import Data.Foldable (forM_)

1313import Data.Proxy

1414import Data.Typeable

1515import Network.Socket

16−import Network.URI

1716import Network.Wai

1817import Network.Wai.Handler.Warp

1918import Test.Hspec

@@ -56,17 +55,17 @@ server = serve api (

5655 :<|> \ a b c d -> return (a, b, c, d)

5756 )

5857

59−withServer :: (URIAuth -> IO a) -> IO a

60−withServer action = withWaiDaemon (return server) (action . mkHost "localhost")

58+withServer :: (BaseUrl -> IO a) -> IO a

59+withServer action = withWaiDaemon (return server) action

6160

62−getGet :: URIAuth -> EitherT String IO Person

63−getCapture :: String -> URIAuth -> EitherT String IO Person

64−getBody :: Person -> URIAuth -> EitherT String IO Person

65−getQueryParam :: Maybe String -> URIAuth -> EitherT String IO Person

66−getQueryParams :: [String] -> URIAuth -> EitherT String IO [Person]

67−getQueryFlag :: Bool -> URIAuth -> EitherT String IO Bool

61+getGet :: BaseUrl -> EitherT String IO Person

62+getCapture :: String -> BaseUrl -> EitherT String IO Person

63+getBody :: Person -> BaseUrl -> EitherT String IO Person

64+getQueryParam :: Maybe String -> BaseUrl -> EitherT String IO Person

65+getQueryParams :: [String] -> BaseUrl -> EitherT String IO [Person]

66+getQueryFlag :: Bool -> BaseUrl -> EitherT String IO Bool

6867getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]

69− -> URIAuth

68+ -> BaseUrl

7069 -> EitherT String IO (String, Maybe Int, Bool, [(String, [Rational])])

7170( getGet

7271 :<|> getCapture

@@ -119,8 +118,8 @@ spec = do

119118 test (WrappedApi api) =

120119 it (show (typeOf api)) $

121120 withWaiDaemon (return (serve api (left (500, "error message")))) $

122− \ (mkHost "localhost" -> host) -> do

123− let getResponse :: URIAuth -> EitherT String IO ()

121+ \ host -> do

122+ let getResponse :: BaseUrl -> EitherT String IO ()

124123 getResponse = client api

125124 Left result <- runEitherT (getResponse host)

126125 result `shouldContain` "error message"

@@ -133,17 +132,17 @@ spec = do

133132

134133data WrappedApi where

135134 WrappedApi :: (HasServer api, Server api ~ EitherT (Int, String) IO a,

136− HasClient api, Client api ~ (URIAuth -> EitherT String IO ()),

135+ HasClient api, Client api ~ (BaseUrl -> EitherT String IO ()),

137136 Typeable api) =>

138137 Proxy api -> WrappedApi

139138

140139

141140-- * utils

142141

143−withWaiDaemon :: IO Application -> (Port -> IO a) -> IO a

142+withWaiDaemon :: IO Application -> (BaseUrl -> IO a) -> IO a

144143withWaiDaemon mkApplication action = do

145144 application <- mkApplication

146− bracket (acquire application) free (\ (_, _, port) -> action port)

145+ bracket (acquire application) free (\ (_, _, baseUrl) -> action baseUrl)

147146 where

148147 acquire application = do

149148 (notifyStart, waitForStart) <- lvar

@@ -158,7 +157,8 @@ withWaiDaemon mkApplication action = do

158157 runSettingsSocket settings socket application)

159158 `finally` notifyKilled ()

160159 krakenPort <- waitForStart

161− return (thread, waitForKilled, krakenPort)

160+ let baseUrl = (httpBaseUrl "localhost"){baseUrlPort = krakenPort}

161+ return (thread, waitForKilled, baseUrl)

162162 free (thread, waitForKilled, _) = do

163163 killThread thread

164164 waitForKilled