put Req in Servant.Utils.Req

This commit is contained in:
Sönke Hahn 2014-11-07 12:41:00 +08:00
parent 8e72c70767
commit bec10dd16a
8 changed files with 71 additions and 60 deletions

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

52
src/Servant/Utils/Req.hs Normal file
View file

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