removed S.Utils.Client (and put the code into S.Client.Req)

This commit is contained in:
Sönke Hahn 2014-11-07 15:23:50 +08:00
parent bec10dd16a
commit 2f9fb2b713
7 changed files with 76 additions and 82 deletions

View file

@ -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:

View file

@ -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

View file

@ -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.

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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