bec10dd · typeable/servant

servant.cabal+1

compare with master

unifiedsplit

@@ -32,6 +32,7 @@ library

32 Servant.Server

33 Servant.Utils.BaseUrl

34 Servant.Utils.Client

35+ Servant.Utils.Req

35 Servant.Utils.Text

36 Servant.Utils.Text

36 build-depends:

37 build-depends:

37 base >=4.7 && <5

38 base >=4.7 && <5

src/Servant/API/Capture.hs+1

@@ -14,6 +14,7 @@ import Servant.API.Sub

14import Servant.Client

15import Servant.Docs

16import Servant.Server

17+import Servant.Utils.Req

17import Servant.Utils.Text

18import Servant.Utils.Text

18

19

19-- * Captures

20-- * Captures

src/Servant/API/QueryParam.hs+1

@@ -18,6 +18,7 @@ import Servant.API.Sub

18import Servant.Client

19import Servant.Docs

20import Servant.Server

21+import Servant.Utils.Req

21import Servant.Utils.Text

22import Servant.Utils.Text

22

23

23-- * Single query string parameter lookup

24-- * Single query string parameter lookup

src/Servant/API/ReqBody.hs+1

@@ -13,6 +13,7 @@ import Servant.API.Sub

13import Servant.Client

14import Servant.Docs

15import Servant.Server

16+import Servant.Utils.Req

16

17

17-- * Request Body support

18-- * Request Body support

18data ReqBody a

19data ReqBody a

src/Servant/API/Sub.hs+1

@@ -11,6 +11,7 @@ import Network.Wai

11import Servant.Client

12import Servant.Docs

13import Servant.Server

14+import Servant.Utils.Req

14

15

15-- | The contained API (second argument) can be found under @("/" ++ path)@

16-- | The contained API (second argument) can be found under @("/" ++ path)@

16-- (path being the first argument).

17-- (path being the first argument).

src/Servant/Client.hs+1−59

@@ -2,17 +2,9 @@

2{-# LANGUAGE OverloadedStrings #-}

3module Servant.Client where

4

5−import Control.Concurrent

6−import Control.Monad.Catch

7−import Data.ByteString.Lazy

8import Data.Proxy

5import Data.Proxy

9−import Data.Text

10−import Network.HTTP.Client hiding (Proxy)

11−import Network.HTTP.Types

12−import Network.URI

13−import System.IO.Unsafe

14

6

15−import Servant.Utils.BaseUrl

7+import Servant.Utils.Req

16

8

17-- * Accessing APIs as a Client

9-- * Accessing APIs as a Client

18

10

@@ -23,53 +15,3 @@ client p = clientWithRoute p defReq

23class HasClient layout where

15class HasClient layout where

24 type Client layout :: *

16 type Client layout :: *

25 clientWithRoute :: Proxy layout -> Req -> Client layout

17 clientWithRoute :: Proxy layout -> Req -> Client layout

26−

27−data Req = Req

28− { reqPath :: String

29− , qs :: QueryText

30− , reqBody :: ByteString

31− }

32−

33−defReq :: Req

34−defReq = Req "" [] ""

35−

36−appendToPath :: String -> Req -> Req

37−appendToPath p req =

38− req { reqPath = reqPath req ++ "/" ++ p }

39−

40−appendToQueryString :: Text -- ^ param name

41− -> Maybe Text -- ^ param value

42− -> Req

43− -> Req

44−appendToQueryString pname pvalue req =

45− req { qs = qs req ++ [(pname, pvalue)]

46− }

47−

48−setRQBody :: ByteString -> Req -> Req

49−setRQBody b req = req { reqBody = b }

50−

51−reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request

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

53−

54− where url = show $ nullURI { uriScheme = case scheme of

55− Http -> "http:"

56− Https -> "https:"

57− , uriAuthority = Just $

58− URIAuth { uriUserInfo = ""

59− , uriRegName = host

60− , uriPort = ":" ++ show port

61− }

62− , uriPath = reqPath req

63− }

64−

65− setrqb r = r { requestBody = RequestBodyLBS (reqBody req) }

66− setQS = setQueryString $ queryTextToQuery (qs req)

67−

68−{-# NOINLINE __manager #-}

69−__manager :: MVar Manager

70−__manager = unsafePerformIO (newManager defaultManagerSettings >>= newMVar)

71−

72−__withGlobalManager :: (Manager -> IO a) -> IO a

73−__withGlobalManager action = modifyMVar __manager $ \ manager -> do

74− result <- action manager

75− return (manager, result)

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

@@ -2,6 +2,7 @@

2module Servant.Utils.Client where

3

4import Control.Applicative

5+import Control.Concurrent

5import Control.Exception

6import Control.Exception

6import Control.Monad

7import Control.Monad

7import Control.Monad.IO.Class

8import Control.Monad.IO.Class

@@ -12,12 +13,23 @@ import Data.Aeson.Types

12import Data.Attoparsec.ByteString

13import Data.Attoparsec.ByteString

13import Data.ByteString.Lazy

14import Data.ByteString.Lazy

14import Data.String.Conversions

15import Data.String.Conversions

16+import Network.HTTP.Client

15import Network.HTTP.Types

17import Network.HTTP.Types

16−import Servant.Client

17import Servant.Utils.BaseUrl

18import Servant.Utils.BaseUrl

19+import Servant.Utils.Req

20+import System.IO.Unsafe

18

21

19import qualified Network.HTTP.Client as Client

22import qualified Network.HTTP.Client as Client

20

23

24+{-# NOINLINE __manager #-}

25+__manager :: MVar Manager

26+__manager = unsafePerformIO (newManager defaultManagerSettings >>= newMVar)

27+

28+__withGlobalManager :: (Manager -> IO a) -> IO a

29+__withGlobalManager action = modifyMVar __manager $ \ manager -> do

30+ result <- action manager

31+ return (manager, result)

32+

21performRequest :: FromJSON result =>

33performRequest :: FromJSON result =>

22 Method -> Req -> Int -> BaseUrl -> EitherT String IO result

34 Method -> Req -> Int -> BaseUrl -> EitherT String IO result

23performRequest method req wantedStatus host = do

35performRequest method req wantedStatus host = do

src/Servant/Utils/Req.hsnew file+52

@@ -0,0 +1,52 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+module Servant.Utils.Req where

3+

4+import Control.Monad.Catch

5+import Data.ByteString.Lazy

6+import Data.Text

7+import Network.HTTP.Client hiding (Proxy)

8+import Network.HTTP.Types

9+import Network.URI

10+

11+import Servant.Utils.BaseUrl

12+

13+data Req = Req

14+ { reqPath :: String

15+ , qs :: QueryText

16+ , reqBody :: ByteString

17+ }

18+

19+defReq :: Req

20+defReq = Req "" [] ""

21+

22+appendToPath :: String -> Req -> Req

23+appendToPath p req =

24+ req { reqPath = reqPath req ++ "/" ++ p }

25+

26+appendToQueryString :: Text -- ^ param name

27+ -> Maybe Text -- ^ param value

28+ -> Req

29+ -> Req

30+appendToQueryString pname pvalue req =

31+ req { qs = qs req ++ [(pname, pvalue)]

32+ }

33+

34+setRQBody :: ByteString -> Req -> Req

35+setRQBody b req = req { reqBody = b }

36+

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

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

39+

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

41+ Http -> "http:"

42+ Https -> "https:"

43+ , uriAuthority = Just $

44+ URIAuth { uriUserInfo = ""

45+ , uriRegName = host

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

47+ }

48+ , uriPath = reqPath req

49+ }

50+

51+ setrqb r = r { requestBody = RequestBodyLBS (reqBody req) }

52+ setQS = setQueryString $ queryTextToQuery (qs req)