2f9fb2b · typeable/servant

servant.cabal−1

compare with master

unifiedsplit

@@ -31,7 +31,6 @@ library

31 Servant.Docs

32 Servant.Server

33 Servant.Utils.BaseUrl

34− Servant.Utils.Client

35 Servant.Utils.Req

34 Servant.Utils.Req

36 Servant.Utils.Text

35 Servant.Utils.Text

37 build-depends:

36 build-depends:

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

@@ -14,7 +14,7 @@ import Servant.Client

14import Servant.Docs

15import Servant.Server

16import Servant.Utils.BaseUrl

17−import Servant.Utils.Client

17+import Servant.Utils.Req

18

19-- | Endpoint for DELETE requests.

20data Delete

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

@@ -15,7 +15,7 @@ import Servant.Client

15import Servant.Docs

16import Servant.Server

17import Servant.Utils.BaseUrl

18−import Servant.Utils.Client

18+import Servant.Utils.Req

19

20-- | Endpoint for simple GET requests. The server doesn't receive any arguments

21-- and serves the contained type as JSON.

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

@@ -15,7 +15,7 @@ import Servant.Client

15import Servant.Docs

16import Servant.Server

17import Servant.Utils.BaseUrl

18−import Servant.Utils.Client

18+import Servant.Utils.Req

19

20-- | Endpoint for POST requests. The type variable represents the type of the

21-- response body (not the request body, use 'Servant.API.RQBody.RQBody' for

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

@@ -15,7 +15,7 @@ import Servant.Client

15import Servant.Docs

16import Servant.Server

17import Servant.Utils.BaseUrl

18−import Servant.Utils.Client

18+import Servant.Utils.Req

19

20-- | Endpoint for PUT requests.

21data Put a

src/Servant/Utils/Client.hsdeleted−74

@@ -1,74 +0,0 @@

1−{-# LANGUAGE ScopedTypeVariables #-}

2−module Servant.Utils.Client where

3−

4−import Control.Applicative

5−import Control.Concurrent

6−import Control.Exception

7−import Control.Monad

8−import Control.Monad.IO.Class

9−import Control.Monad.Trans.Either

10−import Data.Aeson

11−import Data.Aeson.Parser

12−import Data.Aeson.Types

13−import Data.Attoparsec.ByteString

14−import Data.ByteString.Lazy

15−import Data.String.Conversions

16−import Network.HTTP.Client

17−import Network.HTTP.Types

18−import Servant.Utils.BaseUrl

19−import Servant.Utils.Req

20−import System.IO.Unsafe

21−

22−import qualified Network.HTTP.Client as Client

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−

33−performRequest :: FromJSON result =>

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

35−performRequest method req wantedStatus host = do

36− partialRequest <- liftIO $ reqToRequest req host

37−

38− let request = partialRequest { Client.method = method

39− }

40−

41− eResponse <- liftIO $ __withGlobalManager $ \ manager ->

42− catchStatusCodeException $

43− Client.httpLbs request manager

44− case eResponse of

45− Left status ->

46− left (requestString ++ " failed with status: " ++ showStatus status)

47−

48− Right response -> do

49− let status = Client.responseStatus response

50− when (statusCode status /= wantedStatus) $

51− left (requestString ++ " failed with status: " ++ showStatus status)

52− result <- either

53− (\ message -> left (requestString ++ " returned invalid json: " ++ message))

54− return

55− (decodeLenient (Client.responseBody response))

56− return result

57− where

58− requestString = "HTTP " ++ cs method ++ " request"

59− showStatus (Status code message) =

60− show code ++ " - " ++ cs message

61−

62−catchStatusCodeException :: IO a -> IO (Either Status a)

63−catchStatusCodeException action = catch (Right <$> action) $

64− \ e -> case e of

65− Client.StatusCodeException status _ _ ->

66− return $ Left status

67− e -> throwIO e

68−

69−-- | Like 'Data.Aeson.decode' but allows all JSON values instead of just

70−-- objects and arrays.

71−decodeLenient :: FromJSON a => ByteString -> Either String a

72−decodeLenient input = do

73− v :: Value <- parseOnly (Data.Aeson.Parser.value <* endOfInput) (cs input)

74− parseEither parseJSON v

src/Servant/Utils/Req.hs+72−3

@@ -1,14 +1,28 @@

1{-# LANGUAGE OverloadedStrings #-}

2+{-# LANGUAGE ScopedTypeVariables #-}

2module Servant.Utils.Req where

3module Servant.Utils.Req where

3

4

4−import Control.Monad.Catch

5+import Control.Applicative

6+import Control.Concurrent

7+import Control.Exception

8+import Control.Monad

9+import Control.Monad.Catch (MonadThrow)

10+import Control.Monad.IO.Class

11+import Control.Monad.Trans.Either

12+import Data.Aeson

13+import Data.Aeson.Parser

14+import Data.Aeson.Types

15+import Data.Attoparsec.ByteString

5import Data.ByteString.Lazy

16import Data.ByteString.Lazy

17+import Data.String.Conversions

6import Data.Text

18import Data.Text

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

19+import Network.HTTP.Client

8import Network.HTTP.Types

20import Network.HTTP.Types

9import Network.URI

21import Network.URI

10−

11import Servant.Utils.BaseUrl

22import Servant.Utils.BaseUrl

23+import System.IO.Unsafe

24+

25+import qualified Network.HTTP.Client as Client

12

26

13data Req = Req

27data Req = Req

14 { reqPath :: String

28 { reqPath :: String

@@ -50,3 +64,58 @@ reqToRequest req (BaseUrl scheme host port) = fmap (setrqb . setQS ) $ parseUrl

50

64

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

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

52 setQS = setQueryString $ queryTextToQuery (qs req)

66 setQS = setQueryString $ queryTextToQuery (qs req)

67+

68+

69+-- * performing requests

70+

71+{-# NOINLINE __manager #-}

72+__manager :: MVar Manager

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

74+

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

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

77+ result <- action manager

78+ return (manager, result)

79+

80+performRequest :: FromJSON result =>

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

82+performRequest method req wantedStatus host = do

83+ partialRequest <- liftIO $ reqToRequest req host

84+

85+ let request = partialRequest { Client.method = method

86+ }

87+

88+ eResponse <- liftIO $ __withGlobalManager $ \ manager ->

89+ catchStatusCodeException $

90+ Client.httpLbs request manager

91+ case eResponse of

92+ Left status ->

93+ left (requestString ++ " failed with status: " ++ showStatus status)

94+

95+ Right response -> do

96+ let status = Client.responseStatus response

97+ when (statusCode status /= wantedStatus) $

98+ left (requestString ++ " failed with status: " ++ showStatus status)

99+ result <- either

100+ (\ message -> left (requestString ++ " returned invalid json: " ++ message))

101+ return

102+ (decodeLenient (Client.responseBody response))

103+ return result

104+ where

105+ requestString = "HTTP " ++ cs method ++ " request"

106+ showStatus (Status code message) =

107+ show code ++ " - " ++ cs message

108+

109+catchStatusCodeException :: IO a -> IO (Either Status a)

110+catchStatusCodeException action = catch (Right <$> action) $

111+ \ e -> case e of

112+ Client.StatusCodeException status _ _ ->

113+ return $ Left status

114+ e -> throwIO e

115+

116+-- | Like 'Data.Aeson.decode' but allows all JSON values instead of just

117+-- objects and arrays.

118+decodeLenient :: FromJSON a => ByteString -> Either String a

119+decodeLenient input = do

120+ v :: Value <- parseOnly (Data.Aeson.Parser.value <* endOfInput) (cs input)

121+ parseEither parseJSON v