@@ -1,14 +1,28 @@
11{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE ScopedTypeVariables #-}
23module Servant.Utils.Req where
34
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
516import Data.ByteString.Lazy
17+import Data.String.Conversions
618import Data.Text
7−import Network.HTTP.Client hiding (Proxy)
19+import Network.HTTP.Client
820import Network.HTTP.Types
921import Network.URI
10−
1122import Servant.Utils.BaseUrl
23+import System.IO.Unsafe
24+
25+import qualified Network.HTTP.Client as Client
1226
1327data Req = Req
1428 { reqPath :: String
@@ -50,3 +64,58 @@ reqToRequest req (BaseUrl scheme host port) = fmap (setrqb . setQS ) $ parseUrl
5064
5165 setrqb r = r { requestBody = RequestBodyLBS (reqBody req) }
5266 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