From bec10dd16a58ecb17d13bd059307b86a4ddbee0c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Fri, 7 Nov 2014 12:41:00 +0800 Subject: [PATCH] put Req in Servant.Utils.Req --- servant.cabal | 1 + src/Servant/API/Capture.hs | 1 + src/Servant/API/QueryParam.hs | 1 + src/Servant/API/ReqBody.hs | 1 + src/Servant/API/Sub.hs | 1 + src/Servant/Client.hs | 60 +---------------------------------- src/Servant/Utils/Client.hs | 14 +++++++- src/Servant/Utils/Req.hs | 52 ++++++++++++++++++++++++++++++ 8 files changed, 71 insertions(+), 60 deletions(-) create mode 100644 src/Servant/Utils/Req.hs diff --git a/servant.cabal b/servant.cabal index ff5b1bda..dccc76df 100644 --- a/servant.cabal +++ b/servant.cabal @@ -32,6 +32,7 @@ library Servant.Server Servant.Utils.BaseUrl Servant.Utils.Client + Servant.Utils.Req Servant.Utils.Text build-depends: base >=4.7 && <5 diff --git a/src/Servant/API/Capture.hs b/src/Servant/API/Capture.hs index 428934f5..a0cc17fd 100644 --- a/src/Servant/API/Capture.hs +++ b/src/Servant/API/Capture.hs @@ -14,6 +14,7 @@ import Servant.API.Sub import Servant.Client import Servant.Docs import Servant.Server +import Servant.Utils.Req import Servant.Utils.Text -- * Captures diff --git a/src/Servant/API/QueryParam.hs b/src/Servant/API/QueryParam.hs index f78b79fe..f4a6882b 100644 --- a/src/Servant/API/QueryParam.hs +++ b/src/Servant/API/QueryParam.hs @@ -18,6 +18,7 @@ import Servant.API.Sub import Servant.Client import Servant.Docs import Servant.Server +import Servant.Utils.Req import Servant.Utils.Text -- * Single query string parameter lookup diff --git a/src/Servant/API/ReqBody.hs b/src/Servant/API/ReqBody.hs index 8cc1353f..b63152ab 100644 --- a/src/Servant/API/ReqBody.hs +++ b/src/Servant/API/ReqBody.hs @@ -13,6 +13,7 @@ import Servant.API.Sub import Servant.Client import Servant.Docs import Servant.Server +import Servant.Utils.Req -- * Request Body support data ReqBody a diff --git a/src/Servant/API/Sub.hs b/src/Servant/API/Sub.hs index 710728b3..581c5fdf 100644 --- a/src/Servant/API/Sub.hs +++ b/src/Servant/API/Sub.hs @@ -11,6 +11,7 @@ import Network.Wai import Servant.Client import Servant.Docs import Servant.Server +import Servant.Utils.Req -- | The contained API (second argument) can be found under @("/" ++ path)@ -- (path being the first argument). diff --git a/src/Servant/Client.hs b/src/Servant/Client.hs index acc7d301..a1a912c1 100644 --- a/src/Servant/Client.hs +++ b/src/Servant/Client.hs @@ -2,17 +2,9 @@ {-# LANGUAGE OverloadedStrings #-} module Servant.Client where -import Control.Concurrent -import Control.Monad.Catch -import Data.ByteString.Lazy import Data.Proxy -import Data.Text -import Network.HTTP.Client hiding (Proxy) -import Network.HTTP.Types -import Network.URI -import System.IO.Unsafe -import Servant.Utils.BaseUrl +import Servant.Utils.Req -- * Accessing APIs as a Client @@ -23,53 +15,3 @@ client p = clientWithRoute p defReq class HasClient layout where type Client layout :: * clientWithRoute :: Proxy layout -> Req -> Client layout - -data Req = Req - { reqPath :: String - , qs :: QueryText - , reqBody :: ByteString - } - -defReq :: Req -defReq = Req "" [] "" - -appendToPath :: String -> Req -> Req -appendToPath p req = - req { reqPath = reqPath req ++ "/" ++ p } - -appendToQueryString :: Text -- ^ param name - -> Maybe Text -- ^ param value - -> Req - -> Req -appendToQueryString pname pvalue req = - req { qs = qs req ++ [(pname, pvalue)] - } - -setRQBody :: ByteString -> Req -> Req -setRQBody b req = req { reqBody = b } - -reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request -reqToRequest req (BaseUrl scheme host port) = fmap (setrqb . setQS ) $ parseUrl url - - where url = show $ nullURI { uriScheme = case scheme of - Http -> "http:" - Https -> "https:" - , uriAuthority = Just $ - URIAuth { uriUserInfo = "" - , uriRegName = host - , uriPort = ":" ++ show port - } - , uriPath = reqPath req - } - - setrqb r = r { requestBody = RequestBodyLBS (reqBody req) } - setQS = setQueryString $ queryTextToQuery (qs req) - -{-# 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) diff --git a/src/Servant/Utils/Client.hs b/src/Servant/Utils/Client.hs index 7012e6f6..fdbb57dd 100644 --- a/src/Servant/Utils/Client.hs +++ b/src/Servant/Utils/Client.hs @@ -2,6 +2,7 @@ module Servant.Utils.Client where import Control.Applicative +import Control.Concurrent import Control.Exception import Control.Monad import Control.Monad.IO.Class @@ -12,12 +13,23 @@ 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.Client 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 diff --git a/src/Servant/Utils/Req.hs b/src/Servant/Utils/Req.hs new file mode 100644 index 00000000..f709b508 --- /dev/null +++ b/src/Servant/Utils/Req.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE OverloadedStrings #-} +module Servant.Utils.Req where + +import Control.Monad.Catch +import Data.ByteString.Lazy +import Data.Text +import Network.HTTP.Client hiding (Proxy) +import Network.HTTP.Types +import Network.URI + +import Servant.Utils.BaseUrl + +data Req = Req + { reqPath :: String + , qs :: QueryText + , reqBody :: ByteString + } + +defReq :: Req +defReq = Req "" [] "" + +appendToPath :: String -> Req -> Req +appendToPath p req = + req { reqPath = reqPath req ++ "/" ++ p } + +appendToQueryString :: Text -- ^ param name + -> Maybe Text -- ^ param value + -> Req + -> Req +appendToQueryString pname pvalue req = + req { qs = qs req ++ [(pname, pvalue)] + } + +setRQBody :: ByteString -> Req -> Req +setRQBody b req = req { reqBody = b } + +reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request +reqToRequest req (BaseUrl scheme host port) = fmap (setrqb . setQS ) $ parseUrl url + + where url = show $ nullURI { uriScheme = case scheme of + Http -> "http:" + Https -> "https:" + , uriAuthority = Just $ + URIAuth { uriUserInfo = "" + , uriRegName = host + , uriPort = ":" ++ show port + } + , uriPath = reqPath req + } + + setrqb r = r { requestBody = RequestBodyLBS (reqBody req) } + setQS = setQueryString $ queryTextToQuery (qs req)