removed S.Utils.Client (and put the code into S.Client.Req)
This commit is contained in:
parent
bec10dd16a
commit
2f9fb2b713
7 changed files with 76 additions and 82 deletions
|
@ -31,7 +31,6 @@ library
|
||||||
Servant.Docs
|
Servant.Docs
|
||||||
Servant.Server
|
Servant.Server
|
||||||
Servant.Utils.BaseUrl
|
Servant.Utils.BaseUrl
|
||||||
Servant.Utils.Client
|
|
||||||
Servant.Utils.Req
|
Servant.Utils.Req
|
||||||
Servant.Utils.Text
|
Servant.Utils.Text
|
||||||
build-depends:
|
build-depends:
|
||||||
|
|
|
@ -14,7 +14,7 @@ import Servant.Client
|
||||||
import Servant.Docs
|
import Servant.Docs
|
||||||
import Servant.Server
|
import Servant.Server
|
||||||
import Servant.Utils.BaseUrl
|
import Servant.Utils.BaseUrl
|
||||||
import Servant.Utils.Client
|
import Servant.Utils.Req
|
||||||
|
|
||||||
-- | Endpoint for DELETE requests.
|
-- | Endpoint for DELETE requests.
|
||||||
data Delete
|
data Delete
|
||||||
|
|
|
@ -15,7 +15,7 @@ import Servant.Client
|
||||||
import Servant.Docs
|
import Servant.Docs
|
||||||
import Servant.Server
|
import Servant.Server
|
||||||
import Servant.Utils.BaseUrl
|
import Servant.Utils.BaseUrl
|
||||||
import Servant.Utils.Client
|
import Servant.Utils.Req
|
||||||
|
|
||||||
-- | Endpoint for simple GET requests. The server doesn't receive any arguments
|
-- | Endpoint for simple GET requests. The server doesn't receive any arguments
|
||||||
-- and serves the contained type as JSON.
|
-- and serves the contained type as JSON.
|
||||||
|
|
|
@ -15,7 +15,7 @@ import Servant.Client
|
||||||
import Servant.Docs
|
import Servant.Docs
|
||||||
import Servant.Server
|
import Servant.Server
|
||||||
import Servant.Utils.BaseUrl
|
import Servant.Utils.BaseUrl
|
||||||
import Servant.Utils.Client
|
import Servant.Utils.Req
|
||||||
|
|
||||||
-- | Endpoint for POST requests. The type variable represents the type of the
|
-- | Endpoint for POST requests. The type variable represents the type of the
|
||||||
-- response body (not the request body, use 'Servant.API.RQBody.RQBody' for
|
-- response body (not the request body, use 'Servant.API.RQBody.RQBody' for
|
||||||
|
|
|
@ -15,7 +15,7 @@ import Servant.Client
|
||||||
import Servant.Docs
|
import Servant.Docs
|
||||||
import Servant.Server
|
import Servant.Server
|
||||||
import Servant.Utils.BaseUrl
|
import Servant.Utils.BaseUrl
|
||||||
import Servant.Utils.Client
|
import Servant.Utils.Req
|
||||||
|
|
||||||
-- | Endpoint for PUT requests.
|
-- | Endpoint for PUT requests.
|
||||||
data Put a
|
data Put a
|
||||||
|
|
|
@ -1,74 +0,0 @@
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
|
||||||
module Servant.Utils.Client where
|
|
||||||
|
|
||||||
import Control.Applicative
|
|
||||||
import Control.Concurrent
|
|
||||||
import Control.Exception
|
|
||||||
import Control.Monad
|
|
||||||
import Control.Monad.IO.Class
|
|
||||||
import Control.Monad.Trans.Either
|
|
||||||
import Data.Aeson
|
|
||||||
import Data.Aeson.Parser
|
|
||||||
import Data.Aeson.Types
|
|
||||||
import Data.Attoparsec.ByteString
|
|
||||||
import Data.ByteString.Lazy
|
|
||||||
import Data.String.Conversions
|
|
||||||
import Network.HTTP.Client
|
|
||||||
import Network.HTTP.Types
|
|
||||||
import Servant.Utils.BaseUrl
|
|
||||||
import Servant.Utils.Req
|
|
||||||
import System.IO.Unsafe
|
|
||||||
|
|
||||||
import qualified Network.HTTP.Client as Client
|
|
||||||
|
|
||||||
{-# NOINLINE __manager #-}
|
|
||||||
__manager :: MVar Manager
|
|
||||||
__manager = unsafePerformIO (newManager defaultManagerSettings >>= newMVar)
|
|
||||||
|
|
||||||
__withGlobalManager :: (Manager -> IO a) -> IO a
|
|
||||||
__withGlobalManager action = modifyMVar __manager $ \ manager -> do
|
|
||||||
result <- action manager
|
|
||||||
return (manager, result)
|
|
||||||
|
|
||||||
performRequest :: FromJSON result =>
|
|
||||||
Method -> Req -> Int -> BaseUrl -> EitherT String IO result
|
|
||||||
performRequest method req wantedStatus host = do
|
|
||||||
partialRequest <- liftIO $ reqToRequest req host
|
|
||||||
|
|
||||||
let request = partialRequest { Client.method = method
|
|
||||||
}
|
|
||||||
|
|
||||||
eResponse <- liftIO $ __withGlobalManager $ \ manager ->
|
|
||||||
catchStatusCodeException $
|
|
||||||
Client.httpLbs request manager
|
|
||||||
case eResponse of
|
|
||||||
Left status ->
|
|
||||||
left (requestString ++ " failed with status: " ++ showStatus status)
|
|
||||||
|
|
||||||
Right response -> do
|
|
||||||
let status = Client.responseStatus response
|
|
||||||
when (statusCode status /= wantedStatus) $
|
|
||||||
left (requestString ++ " failed with status: " ++ showStatus status)
|
|
||||||
result <- either
|
|
||||||
(\ message -> left (requestString ++ " returned invalid json: " ++ message))
|
|
||||||
return
|
|
||||||
(decodeLenient (Client.responseBody response))
|
|
||||||
return result
|
|
||||||
where
|
|
||||||
requestString = "HTTP " ++ cs method ++ " request"
|
|
||||||
showStatus (Status code message) =
|
|
||||||
show code ++ " - " ++ cs message
|
|
||||||
|
|
||||||
catchStatusCodeException :: IO a -> IO (Either Status a)
|
|
||||||
catchStatusCodeException action = catch (Right <$> action) $
|
|
||||||
\ e -> case e of
|
|
||||||
Client.StatusCodeException status _ _ ->
|
|
||||||
return $ Left status
|
|
||||||
e -> throwIO e
|
|
||||||
|
|
||||||
-- | Like 'Data.Aeson.decode' but allows all JSON values instead of just
|
|
||||||
-- objects and arrays.
|
|
||||||
decodeLenient :: FromJSON a => ByteString -> Either String a
|
|
||||||
decodeLenient input = do
|
|
||||||
v :: Value <- parseOnly (Data.Aeson.Parser.value <* endOfInput) (cs input)
|
|
||||||
parseEither parseJSON v
|
|
|
@ -1,14 +1,28 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
module Servant.Utils.Req where
|
module Servant.Utils.Req where
|
||||||
|
|
||||||
import Control.Monad.Catch
|
import Control.Applicative
|
||||||
|
import Control.Concurrent
|
||||||
|
import Control.Exception
|
||||||
|
import Control.Monad
|
||||||
|
import Control.Monad.Catch (MonadThrow)
|
||||||
|
import Control.Monad.IO.Class
|
||||||
|
import Control.Monad.Trans.Either
|
||||||
|
import Data.Aeson
|
||||||
|
import Data.Aeson.Parser
|
||||||
|
import Data.Aeson.Types
|
||||||
|
import Data.Attoparsec.ByteString
|
||||||
import Data.ByteString.Lazy
|
import Data.ByteString.Lazy
|
||||||
|
import Data.String.Conversions
|
||||||
import Data.Text
|
import Data.Text
|
||||||
import Network.HTTP.Client hiding (Proxy)
|
import Network.HTTP.Client
|
||||||
import Network.HTTP.Types
|
import Network.HTTP.Types
|
||||||
import Network.URI
|
import Network.URI
|
||||||
|
|
||||||
import Servant.Utils.BaseUrl
|
import Servant.Utils.BaseUrl
|
||||||
|
import System.IO.Unsafe
|
||||||
|
|
||||||
|
import qualified Network.HTTP.Client as Client
|
||||||
|
|
||||||
data Req = Req
|
data Req = Req
|
||||||
{ reqPath :: String
|
{ reqPath :: String
|
||||||
|
@ -50,3 +64,58 @@ reqToRequest req (BaseUrl scheme host port) = fmap (setrqb . setQS ) $ parseUrl
|
||||||
|
|
||||||
setrqb r = r { requestBody = RequestBodyLBS (reqBody req) }
|
setrqb r = r { requestBody = RequestBodyLBS (reqBody req) }
|
||||||
setQS = setQueryString $ queryTextToQuery (qs req)
|
setQS = setQueryString $ queryTextToQuery (qs req)
|
||||||
|
|
||||||
|
|
||||||
|
-- * performing requests
|
||||||
|
|
||||||
|
{-# NOINLINE __manager #-}
|
||||||
|
__manager :: MVar Manager
|
||||||
|
__manager = unsafePerformIO (newManager defaultManagerSettings >>= newMVar)
|
||||||
|
|
||||||
|
__withGlobalManager :: (Manager -> IO a) -> IO a
|
||||||
|
__withGlobalManager action = modifyMVar __manager $ \ manager -> do
|
||||||
|
result <- action manager
|
||||||
|
return (manager, result)
|
||||||
|
|
||||||
|
performRequest :: FromJSON result =>
|
||||||
|
Method -> Req -> Int -> BaseUrl -> EitherT String IO result
|
||||||
|
performRequest method req wantedStatus host = do
|
||||||
|
partialRequest <- liftIO $ reqToRequest req host
|
||||||
|
|
||||||
|
let request = partialRequest { Client.method = method
|
||||||
|
}
|
||||||
|
|
||||||
|
eResponse <- liftIO $ __withGlobalManager $ \ manager ->
|
||||||
|
catchStatusCodeException $
|
||||||
|
Client.httpLbs request manager
|
||||||
|
case eResponse of
|
||||||
|
Left status ->
|
||||||
|
left (requestString ++ " failed with status: " ++ showStatus status)
|
||||||
|
|
||||||
|
Right response -> do
|
||||||
|
let status = Client.responseStatus response
|
||||||
|
when (statusCode status /= wantedStatus) $
|
||||||
|
left (requestString ++ " failed with status: " ++ showStatus status)
|
||||||
|
result <- either
|
||||||
|
(\ message -> left (requestString ++ " returned invalid json: " ++ message))
|
||||||
|
return
|
||||||
|
(decodeLenient (Client.responseBody response))
|
||||||
|
return result
|
||||||
|
where
|
||||||
|
requestString = "HTTP " ++ cs method ++ " request"
|
||||||
|
showStatus (Status code message) =
|
||||||
|
show code ++ " - " ++ cs message
|
||||||
|
|
||||||
|
catchStatusCodeException :: IO a -> IO (Either Status a)
|
||||||
|
catchStatusCodeException action = catch (Right <$> action) $
|
||||||
|
\ e -> case e of
|
||||||
|
Client.StatusCodeException status _ _ ->
|
||||||
|
return $ Left status
|
||||||
|
e -> throwIO e
|
||||||
|
|
||||||
|
-- | Like 'Data.Aeson.decode' but allows all JSON values instead of just
|
||||||
|
-- objects and arrays.
|
||||||
|
decodeLenient :: FromJSON a => ByteString -> Either String a
|
||||||
|
decodeLenient input = do
|
||||||
|
v :: Value <- parseOnly (Data.Aeson.Parser.value <* endOfInput) (cs input)
|
||||||
|
parseEither parseJSON v
|
||||||
|
|
Loading…
Reference in a new issue