f0bca38 · servant · git.iko.soy

example/greet.hs+4−5

compare with master

unifiedsplit

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

15import Data.Proxy

16import Data.Text

17import GHC.Generics

18−import Network.URI

19import Network.Wai

18import Network.Wai

20import Network.Wai.Handler.Warp

19import Network.Wai.Handler.Warp

21

20

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

75clientApi :: Client TestApi

74clientApi :: Client TestApi

76clientApi = client testApi

75clientApi = client testApi

77

76

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

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

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

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

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

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

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

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

82

81

83-- Turn the server into a WAI app

82-- Turn the server into a WAI app

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

96main :: IO ()

95main :: IO ()

97main = do

96main = do

98 tid <- forkIO $ runTestServer 8001

97 tid <- forkIO $ runTestServer 8001

99− let uri = mkHost "localhost" 8001

98+ let uri = BaseUrl Http "localhost" 8001

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

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

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

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

102 let g = Greet "yo"

101 let g = Greet "yo"

servant.cabal+1−3

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

43 , split

44 , http-client

45 , http-types

46− , network-uri

46+ , network-uri >= 2.6

47 , wai

48 , warp

49 , safe

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

70 , wai

71 , either

72 , text

73− , network-uri

74

73

75test-suite spec

74test-suite spec

76 type: exitcode-stdio-1.0

75 type: exitcode-stdio-1.0

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

90 , http-client

89 , http-client

91 , http-types

90 , http-types

92 , network >= 2.6

91 , network >= 2.6

93− , network-uri >= 2.6

94 , QuickCheck

92 , QuickCheck

95 , servant

93 , servant

96 , string-conversions

94 , string-conversions

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

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

9import Data.String.Conversions

10import Data.Typeable

11import Network.HTTP.Types

12−import Network.URI

13import Network.Wai

12import Network.Wai

14import Servant.Client

13import Servant.Client

15import Servant.Docs

14import Servant.Docs

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

36 | otherwise = respond $ failWith NotFound

35 | otherwise = respond $ failWith NotFound

37

36

38instance HasClient Delete where

37instance HasClient Delete where

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

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

40

39

41 clientWithRoute Proxy req host =

40 clientWithRoute Proxy req host =

42 performRequest methodDelete req 204 host

41 performRequest methodDelete req 204 host

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

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

10import Data.String.Conversions

11import Data.Typeable

12import Network.HTTP.Types

13−import Network.URI

14import Network.Wai

13import Network.Wai

15import Servant.Client

14import Servant.Client

16import Servant.Docs

15import Servant.Docs

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

37 | otherwise = respond $ failWith NotFound

36 | otherwise = respond $ failWith NotFound

38

37

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

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

41 clientWithRoute Proxy req host =

40 clientWithRoute Proxy req host =

42 performRequest methodGet req 200 host

41 performRequest methodGet req 200 host

43

42

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

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

10import Data.String.Conversions

11import Data.Typeable

12import Network.HTTP.Types

13−import Network.URI

14import Network.Wai

13import Network.Wai

15import Servant.Client

14import Servant.Client

16import Servant.Docs

15import Servant.Docs

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

39 | otherwise = respond $ failWith NotFound

38 | otherwise = respond $ failWith NotFound

40

39

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

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

43

42

44 clientWithRoute Proxy req uri =

43 clientWithRoute Proxy req uri =

45 performRequest methodPost req 201 uri

44 performRequest methodPost req 201 uri

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

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

10import Data.String.Conversions

11import Data.Typeable

12import Network.HTTP.Types

13−import Network.URI

14import Network.Wai

13import Network.Wai

15import Servant.Client

14import Servant.Client

16import Servant.Docs

15import Servant.Docs

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

38 | otherwise = respond $ failWith NotFound

37 | otherwise = respond $ failWith NotFound

39

38

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

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

42

41

43 clientWithRoute Proxy req host =

42 clientWithRoute Proxy req host =

44 performRequest methodPut req 200 host

43 performRequest methodPut req 200 host

src/Servant/Client.hs+20−7

@@ -14,9 +14,16 @@ import System.IO.Unsafe

14

15-- * Accessing APIs as a Client

16

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

17+data Scheme = Http | Https

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

18+

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

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

20

27

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

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

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

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

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

50setRQBody :: ByteString -> Req -> Req

57setRQBody :: ByteString -> Req -> Req

51setRQBody b req = req { reqBody = b }

58setRQBody b req = req { reqBody = b }

52

59

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

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

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

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

55

62

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

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

64+ Http -> "http:"

65+ Https -> "https:"

57− , uriAuthority = Just host

66+ , uriAuthority = Just $

67+ URIAuth { uriUserInfo = ""

68+ , uriRegName = host

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

70+ }

58 , uriPath = reqPath req

71 , uriPath = reqPath req

59 }

72 }

60

73

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

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

13import Data.ByteString.Lazy

14import Data.String.Conversions

15import Network.HTTP.Types

16−import Network.URI

17import Servant.Client

16import Servant.Client

18

17

19import qualified Network.HTTP.Client as Client

18import qualified Network.HTTP.Client as Client

20

19

21performRequest :: FromJSON result =>

20performRequest :: FromJSON result =>

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

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

23performRequest method req wantedStatus host = do

22performRequest method req wantedStatus host = do

24 partialRequest <- liftIO $ reqToRequest req host

23 partialRequest <- liftIO $ reqToRequest req host

25

24

test/Servant/ClientSpec.hs+16−16

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

13import Data.Proxy

14import Data.Typeable

15import Network.Socket

16−import Network.URI

17import Network.Wai

16import Network.Wai

18import Network.Wai.Handler.Warp

17import Network.Wai.Handler.Warp

19import Test.Hspec

18import Test.Hspec

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

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

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

57 )

56 )

58

57

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

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

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

59+withServer action = withWaiDaemon (return server) action

61

60

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

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

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

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

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

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

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

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

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

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

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

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

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

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

69− -> URIAuth

68+ -> BaseUrl

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

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

71( getGet

70( getGet

72 :<|> getCapture

71 :<|> getCapture

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

119 test (WrappedApi api) =

118 test (WrappedApi api) =

120 it (show (typeOf api)) $

119 it (show (typeOf api)) $

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

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

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

121+ \ host -> do

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

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

124 getResponse = client api

123 getResponse = client api

125 Left result <- runEitherT (getResponse host)

124 Left result <- runEitherT (getResponse host)

126 result `shouldContain` "error message"

125 result `shouldContain` "error message"

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

133

132

134data WrappedApi where

133data WrappedApi where

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

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

137 Typeable api) =>

136 Typeable api) =>

138 Proxy api -> WrappedApi

137 Proxy api -> WrappedApi

139

138

140

139

141-- * utils

140-- * utils

142

141

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

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

144withWaiDaemon mkApplication action = do

143withWaiDaemon mkApplication action = do

145 application <- mkApplication

144 application <- mkApplication

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

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

147 where

146 where

148 acquire application = do

147 acquire application = do

149 (notifyStart, waitForStart) <- lvar

148 (notifyStart, waitForStart) <- lvar

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

158 runSettingsSocket settings socket application)

157 runSettingsSocket settings socket application)

159 `finally` notifyKilled ()

158 `finally` notifyKilled ()

160 krakenPort <- waitForStart

159 krakenPort <- waitForStart

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

161− return (thread, waitForKilled, krakenPort)

161+ return (thread, waitForKilled, baseUrl)

162 free (thread, waitForKilled, _) = do

163 killThread thread

164 waitForKilled