diff --git a/Network/Wreq.hs b/Network/Wreq.hs --- a/Network/Wreq.hs +++ b/Network/Wreq.hs @@ -63,9 +63,13 @@ -- ** Custom Method , customMethod , customMethodWith + , customHistoriedMethod + , customHistoriedMethodWith -- ** Custom Payload Method , customPayloadMethod , customPayloadMethodWith + , customHistoriedPayloadMethod + , customHistoriedPayloadMethodWith -- * Incremental consumption of responses -- ** GET , foldGet @@ -94,6 +98,7 @@ , oauth2Bearer , oauth2Token , awsAuth + , awsSessionTokenAuth -- ** Proxy settings , Proxy(Proxy) , Lens.proxy @@ -132,6 +137,10 @@ , Lens.Status , Lens.statusCode , Lens.statusMessage + , HistoriedResponse + , Lens.hrFinalRequest + , Lens.hrFinalResponse + , Lens.hrRedirects -- ** Link headers , Lens.Link , Lens.linkURL @@ -162,6 +171,7 @@ import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Text.Encoding (encodeUtf8) +import Network.HTTP.Client (HistoriedResponse) import Network.HTTP.Client.Internal (Proxy(..), Response) import Network.Wreq.Internal import Network.Wreq.Types (Options) @@ -336,6 +346,7 @@ -- | Issue a custom-method request -- -- Example: +-- -- @ -- 'customMethod' \"PATCH\" \"http:\/\/httpbin.org\/patch\" -- @ @@ -364,6 +375,33 @@ where methodBS = BC8.pack method + +-- | Issue a custom request method. Keep track of redirects and return the 'HistoriedResponse' +-- +-- Example: +-- +-- @ +-- 'customHistoriedMethod' \"GET\" \"http:\/\/httpbin.org\/redirect\/3\" +-- @ +-- +-- >>> r <- customHistoriedMethod "GET" "http://httpbin.org/redirect/3" +-- >>> length (r ^. hrRedirects) +-- 3 +-- +-- @since 0.5.2.0 +customHistoriedMethod :: String -> String -> IO (HistoriedResponse L.ByteString) +customHistoriedMethod method url = customHistoriedMethodWith method defaults url + +-- | Issue a custom request method request, using the supplied 'Options'. +-- Keep track of redirects and return the 'HistoriedResponse'. +-- +-- @since 0.5.2.0 +customHistoriedMethodWith :: String -> Options -> String -> IO (HistoriedResponse L.ByteString) +customHistoriedMethodWith method opts url = + runReadHistory =<< prepareMethod methodBS opts url + where + methodBS = BC8.pack method + -- | Issue a custom-method request with a payload customPayloadMethod :: Postable a => String -> String -> a -> IO (Response L.ByteString) @@ -380,6 +418,22 @@ where methodBS = BC8.pack method +-- | Issue a custom-method historied request with a payload +customHistoriedPayloadMethod :: Postable a => String -> String -> a + -> IO (HistoriedResponse L.ByteString) + +customHistoriedPayloadMethod method url payload = + customHistoriedPayloadMethodWith method defaults url payload + +-- | Issue a custom-method historied request with a paylod, using the supplied 'Options'. +customHistoriedPayloadMethodWith :: Postable a => String -> Options -> String -> a + -> IO (HistoriedResponse L.ByteString) + +customHistoriedPayloadMethodWith method opts url payload = + runReadHistory =<< preparePayloadMethod methodBS opts url payload + where + methodBS = BC8.pack method + foldGet :: (a -> S.ByteString -> IO a) -> a -> String -> IO a foldGet f z url = foldGetWith defaults f z url @@ -430,7 +484,8 @@ asJSON resp = do let contentType = fst . S.break (==59) . fromMaybe "unknown" . lookup "Content-Type" . HTTP.responseHeaders $ resp - unless ("application/json" `S.isPrefixOf` contentType) $ + unless ("application/json" `S.isPrefixOf` contentType + || ("application/" `S.isPrefixOf` contentType && "+json" `S.isSuffixOf` contentType)) $ throwM . JSONError $ "content type of response is " ++ show contentType case Aeson.eitherDecode' (HTTP.responseBody resp) of Left err -> throwM (JSONError err) @@ -525,7 +580,25 @@ --'getWith' opts \"https:\/\/dynamodb.us-west-2.amazonaws.com\" -- @ awsAuth :: AWSAuthVersion -> S.ByteString -> S.ByteString -> Auth -awsAuth = AWSAuth +awsAuth version key secret = AWSAuth version key secret Nothing + +-- | AWS v4 request signature using a AWS STS Session Token. +-- +-- Example (note the use of TLS): +-- +-- @ +--let opts = 'defaults' +-- '&' 'Lens.auth' +-- '?~' 'awsAuth AWSv4' \"key\" \"secret\" \"stsSessionToken\" +--'getWith' opts \"https:\/\/dynamodb.us-west-2.amazonaws.com\" +-- @ +awsSessionTokenAuth :: AWSAuthVersion -- ^ Signature version (V4) + -> S.ByteString -- ^ AWS AccessKeyId + -> S.ByteString -- ^ AWS SecretAccessKey + -> S.ByteString -- ^ AWS STS SessionToken + -> Auth +awsSessionTokenAuth version key secret sessionToken = + AWSAuth version key secret (Just sessionToken) -- | Proxy configuration. -- diff --git a/Network/Wreq/Internal.hs b/Network/Wreq/Internal.hs --- a/Network/Wreq/Internal.hs +++ b/Network/Wreq/Internal.hs @@ -12,6 +12,7 @@ , prepareGet , preparePost , runRead + , runReadHistory , prepareHead , runIgnore , prepareOptions @@ -28,11 +29,11 @@ import Data.Monoid ((<>)) import Data.Text.Encoding (encodeUtf8) import Data.Version (showVersion) -import Network.HTTP.Client (BodyReader) +import Network.HTTP.Client (BodyReader, HistoriedResponse(..)) import Network.HTTP.Client.Internal (Proxy(..), Request, Response(..), addProxy) import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.Wreq.Internal.Lens (setHeader) -import Network.Wreq.Internal.Types (Mgr, Req(..), Run) +import Network.Wreq.Internal.Types (Mgr, Req(..), Run, RunHistory) import Network.Wreq.Types (Auth(..), Options(..), Postable(..), Putable(..)) import Prelude hiding (head) import qualified Data.ByteString as S @@ -88,6 +89,12 @@ chunks <- HTTP.brConsume (HTTP.responseBody resp) return resp { responseBody = L.fromChunks chunks } +readHistoriedResponse :: HistoriedResponse BodyReader -> IO (HistoriedResponse L.ByteString) +readHistoriedResponse resp = do + let finalResp = hrFinalResponse resp + chunks <- HTTP.brConsume (HTTP.responseBody finalResp) + return resp { hrFinalResponse = finalResp { responseBody = L.fromChunks chunks } } + foldResponseBody :: (a -> S.ByteString -> IO a) -> a -> Response BodyReader -> IO a foldResponseBody f z0 resp = go z0 @@ -105,6 +112,10 @@ run emgr act req = either (HTTP.newManager >=> go) go emgr where go mgr = HTTP.withResponse req mgr act +runHistory :: Mgr -> (HistoriedResponse BodyReader -> IO a) -> Request -> IO a +runHistory emgr act req = either (HTTP.newManager >=> go) go emgr + where go mgr = HTTP.withResponseHistory req mgr act + prepare :: (Request -> IO Request) -> Options -> String -> IO Request prepare modify opts url = do signRequest =<< modify =<< frob <$> HTTP.parseUrlThrow url @@ -119,7 +130,7 @@ signRequest :: Request -> IO Request signRequest = maybe return f $ auth opts where - f (AWSAuth versn key secret) = AWS.signRequest versn key secret + f (AWSAuth versn key secret _) = AWS.signRequest versn key secret f (OAuth1 consumerToken consumerSecret token secret) = OAuth1.signRequest consumerToken consumerSecret token secret f _ = return @@ -139,8 +150,9 @@ f (BasicAuth user pass) = HTTP.applyBasicAuth user pass f (OAuth2Bearer token) = setHeader "Authorization" ("Bearer " <> token) f (OAuth2Token token) = setHeader "Authorization" ("token " <> token) - -- for AWS request signature, see Internal/AWS - f (AWSAuth _ _ _) = id + -- for AWS request signature implementation, see Internal/AWS + f (AWSAuth _ _ _ mSessionToken) = + maybe id (setHeader "X-Amz-Security-Token") mSessionToken f (OAuth1 _ _ _ _) = id setProxy :: Options -> Request -> Request @@ -156,6 +168,9 @@ runRead :: Run L.ByteString runRead (Req mgr req) = run mgr readResponse req + +runReadHistory :: RunHistory L.ByteString +runReadHistory (Req mgr req) = runHistory mgr readHistoriedResponse req preparePost :: Postable a => Options -> String -> a -> IO Req preparePost opts url payload = Req (manager opts) <$> diff --git a/Network/Wreq/Internal/Lens.hs b/Network/Wreq/Internal/Lens.hs --- a/Network/Wreq/Internal/Lens.hs +++ b/Network/Wreq/Internal/Lens.hs @@ -13,6 +13,7 @@ , requestHeaders , requestBody , requestVersion + , requestManagerOverride , onRequestBodyException , proxy , hostAddress @@ -25,6 +26,7 @@ , seshCookies , seshManager , seshRun + , seshRunHistory -- * Useful functions , assoc , assoc2 diff --git a/Network/Wreq/Internal/Types.hs b/Network/Wreq/Internal/Types.hs --- a/Network/Wreq/Internal/Types.hs +++ b/Network/Wreq/Internal/Types.hs @@ -1,5 +1,5 @@ {-# LANGUAGE DeriveDataTypeable, DeriveFunctor, FlexibleInstances, GADTs, - OverloadedStrings, RankNTypes, RecordWildCards #-} + OverloadedStrings, RankNTypes, RecordWildCards, DefaultSignatures #-} -- | -- Module : Network.Wreq.Internal.Types @@ -38,6 +38,7 @@ -- * Sessions , Session(..) , Run + , RunHistory , Body(..) -- * Caches , CacheEntry(..) @@ -179,9 +180,9 @@ -- to be used only by GitHub). This is treated by whoever -- accepts it as the equivalent of a username and -- password. - | AWSAuth AWSAuthVersion S.ByteString S.ByteString + | AWSAuth AWSAuthVersion S.ByteString S.ByteString (Maybe S.ByteString) -- ^ Amazon Web Services request signing - -- AWSAuthVersion key secret + -- AWSAuthVersion key secret (optional: session-token) | OAuth1 S.ByteString S.ByteString S.ByteString S.ByteString -- ^ OAuth1 request signing -- OAuth1 consumerToken consumerSecret token secret @@ -209,6 +210,8 @@ -- | A type that can be converted into a POST request payload. class Postable a where postPayload :: a -> Request -> IO Request + default postPayload :: Putable a => a -> Request -> IO Request + postPayload = putPayload -- ^ Represent a value in the request body (and perhaps the -- headers) of a POST request. @@ -288,12 +291,15 @@ -- response. type Run body = Req -> IO (Response body) +type RunHistory body = Req -> IO (HTTP.HistoriedResponse body) + -- | A session that spans multiple requests. This is responsible for -- cookie management and TCP connection reuse. data Session = Session { seshCookies :: Maybe (IORef CookieJar) , seshManager :: Manager , seshRun :: Session -> Run Body -> Run Body + , seshRunHistory :: Session -> RunHistory Body -> RunHistory Body } instance Show Session where diff --git a/Network/Wreq/Lens.hs b/Network/Wreq/Lens.hs --- a/Network/Wreq/Lens.hs +++ b/Network/Wreq/Lens.hs @@ -78,6 +78,12 @@ , responseStatus , responseVersion + -- * HistoriedResponse + , HistoriedResponse + , hrFinalResponse + , hrFinalRequest + , hrRedirects + -- ** Status , Status , statusCode @@ -104,9 +110,10 @@ import Control.Lens (Fold, Lens, Lens', Traversal', folding) import Data.Attoparsec.ByteString (Parser, endOfInput, parseOnly) import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as L import Data.Text (Text) import Data.Time.Clock (UTCTime) -import Network.HTTP.Client (Cookie, CookieJar, Manager, ManagerSettings, Proxy) +import Network.HTTP.Client (Cookie, CookieJar, Request, Manager, ManagerSettings, Proxy, HistoriedResponse) import Network.HTTP.Client (RequestBody, Response) import Network.HTTP.Client.MultipartFormData (Part) import Network.HTTP.Types.Header (Header, HeaderName, ResponseHeaders) @@ -389,6 +396,18 @@ -- | A lens onto all cookies set in the response. responseCookieJar :: Lens' (Response body) CookieJar responseCookieJar = TH.responseCookieJar + +-- | A lens onto the final request of a historied response. +hrFinalRequest :: Lens' (HistoriedResponse body) Request +hrFinalRequest = TH.hrFinalRequest + +-- | A lens onto the final response of a historied response. +hrFinalResponse :: Lens' (HistoriedResponse body) (Response body) +hrFinalResponse = TH.hrFinalResponse + +-- | A lens onto the list of redirects of a historied response. +hrRedirects :: Lens' (HistoriedResponse body) [(Request, Response L.ByteString)] +hrRedirects = TH.hrRedirects -- | A lens onto the numeric identifier of an HTTP status. statusCode :: Lens' Status Int diff --git a/Network/Wreq/Lens/TH.hs b/Network/Wreq/Lens/TH.hs --- a/Network/Wreq/Lens/TH.hs +++ b/Network/Wreq/Lens/TH.hs @@ -45,6 +45,11 @@ , responseCookieJar , responseClose' + , HTTP.HistoriedResponse + , hrFinalResponse + , hrFinalRequest + , hrRedirects + , HTTP.Status , statusCode , statusMessage @@ -77,6 +82,7 @@ makeLensesWith (lensRules & lensField .~ fieldName toCamelCase) ''HTTP.Cookie makeLenses ''HTTP.Proxy makeLenses ''HTTP.Response +makeLenses ''HTTP.HistoriedResponse makeLenses ''HTTP.Status makeLenses ''Types.Link makeLenses ''Form.Part diff --git a/Network/Wreq/Session.hs b/Network/Wreq/Session.hs --- a/Network/Wreq/Session.hs +++ b/Network/Wreq/Session.hs @@ -39,16 +39,25 @@ -- Note the use of qualified import statements in the examples above, -- so that we can refer unambiguously to the 'Session'-specific -- implementation of HTTP GET. +-- +-- One 'Network.HTTP.Client.Manager' (possibly set with 'withSessionControl') is used for all +-- session requests. The manager settings in the 'Options' parameter +-- for the 'getWith', 'postWith' and similar functions is ignored. module Network.Wreq.Session ( -- * Session creation Session + , newSession + , newAPISession , withSession , withAPISession -- ** More control-oriented session creation + , newSessionControl , withSessionWith , withSessionControl + -- ** Get information about session state + , getSessionCookieJar -- * HTTP verbs , get , post @@ -66,16 +75,18 @@ , deleteWith , customMethodWith , customPayloadMethodWith + , customHistoriedMethodWith + , customHistoriedPayloadMethodWith -- * Extending a session , Lens.seshRun ) where -import Control.Lens ((&), (?~), (.~)) +import Control.Lens ((&), (.~)) import Data.Foldable (forM_) import Data.IORef (newIORef, readIORef, writeIORef) -import Network.Wreq (Options, Response) +import Network.Wreq (Options, Response, HistoriedResponse) import Network.Wreq.Internal -import Network.Wreq.Internal.Types (Body(..), Req(..), Session(..)) +import Network.Wreq.Internal.Types (Body(..), Req(..), Session(..), RunHistory) import Network.Wreq.Types (Postable, Putable, Run) import Prelude hiding (head) import qualified Data.ByteString.Char8 as BC8 @@ -90,21 +101,42 @@ -- This session manages cookies and uses default session manager -- configuration. withSession :: (Session -> IO a) -> IO a -withSession = withSessionWith defaultManagerSettings +withSession act = newSession >>= act +{-# DEPRECATED withSession "Use newSession instead." #-} +-- | Create a 'Session'. +-- +-- This session manages cookies and uses default session manager +-- configuration. +-- +-- @since 0.5.2.0 +newSession :: IO Session +newSession = newSessionControl (Just (HTTP.createCookieJar [])) defaultManagerSettings + -- | Create a session. -- -- This uses the default session manager settings, but does not manage -- cookies. It is intended for use with REST-like HTTP-based APIs, -- which typically do not use cookies. withAPISession :: (Session -> IO a) -> IO a -withAPISession = withSessionControl Nothing defaultManagerSettings +withAPISession act = newAPISession >>= act +{-# DEPRECATED withAPISession "Use newAPISession instead." #-} +-- | Create a session. +-- +-- This uses the default session manager settings, but does not manage +-- cookies. It is intended for use with REST-like HTTP-based APIs, +-- which typically do not use cookies. +-- +-- @since 0.5.2.0 +newAPISession :: IO Session +newAPISession = newSessionControl Nothing defaultManagerSettings + -- | Create a session, using the given manager settings. This session -- manages cookies. withSessionWith :: HTTP.ManagerSettings -> (Session -> IO a) -> IO a withSessionWith = withSessionControl (Just (HTTP.createCookieJar [])) -{-# DEPRECATED withSessionWith "Use withSessionControl instead." #-} +{-# DEPRECATED withSessionWith "Use newSessionControl instead." #-} -- | Create a session, using the given cookie jar and manager settings. withSessionControl :: Maybe HTTP.CookieJar @@ -113,13 +145,33 @@ -> HTTP.ManagerSettings -> (Session -> IO a) -> IO a withSessionControl mj settings act = do - mref <- maybe (return Nothing) (fmap Just . newIORef) mj - mgr <- HTTP.newManager settings - act Session { seshCookies = mref - , seshManager = mgr - , seshRun = runWith - } + sess <- newSessionControl mj settings + act sess +{-# DEPRECATED withSessionControl "Use newSessionControl instead." #-} +-- | Create a session, using the given cookie jar and manager settings. +-- +-- @since 0.5.2.0 +newSessionControl :: Maybe HTTP.CookieJar + -- ^ If 'Nothing' is specified, no cookie management + -- will be performed. + -> HTTP.ManagerSettings + -> IO Session +newSessionControl mj settings = do + mref <- maybe (return Nothing) (fmap Just . newIORef) mj + mgr <- HTTP.newManager settings + return Session { seshCookies = mref + , seshManager = mgr + , seshRun = runWith + , seshRunHistory = runWithHistory + } + +-- | Extract current 'Network.HTTP.Client.CookieJar' from a 'Session' +-- +-- @since 0.5.2.0 +getSessionCookieJar :: Session -> IO (Maybe HTTP.CookieJar) +getSessionCookieJar = traverse readIORef . seshCookies + -- | 'Session'-specific version of 'Network.Wreq.get'. get :: Session -> String -> IO (Response L.ByteString) get = getWith defaults @@ -181,6 +233,15 @@ where methodBS = BC8.pack method +-- | 'Session'-specific version of 'Network.Wreq.customHistoriedMethodWith'. +-- +-- @since 0.5.2.0 +customHistoriedMethodWith :: String -> Options -> Session -> String -> IO (HistoriedResponse L.ByteString) +customHistoriedMethodWith method opts sesh url = + runHistory stringHistory sesh =<< prepareMethod methodBS opts url + where + methodBS = BC8.pack method + -- | 'Session'-specific version of 'Network.Wreq.customPayloadMethodWith'. customPayloadMethodWith :: Postable a => String -> Options -> Session -> String -> a -> IO (Response L.ByteString) @@ -189,24 +250,47 @@ where methodBS = BC8.pack method -runWith :: Session -> Run Body -> Run Body -runWith Session{..} act (Req _ req) = do - req' <- case seshCookies of - Nothing -> return (req & Lens.cookieJar .~ Nothing) - Just ref -> (\s -> req & Lens.cookieJar ?~ s) `fmap` readIORef ref +-- | 'Session'-specific version of 'Network.Wreq.customHistoriedPayloadMethodWith'. +-- +-- @since 0.5.2.0 +customHistoriedPayloadMethodWith :: Postable a => String -> Options -> Session -> String -> a + -> IO (HistoriedResponse L.ByteString) +customHistoriedPayloadMethodWith method opts sesh url payload = + runHistory stringHistory sesh =<< preparePayloadMethod methodBS opts url payload + where + methodBS = BC8.pack method + + +runWithGeneric :: (resp -> Response b) -> Session -> (Req -> IO resp) -> Req -> IO resp +runWithGeneric extract Session{..} act (Req _ req) = do + req' <- (\c -> req & Lens.cookieJar .~ c) <$> traverse readIORef seshCookies resp <- act (Req (Right seshManager) req') forM_ seshCookies $ \ref -> - writeIORef ref (HTTP.responseCookieJar resp) + writeIORef ref (HTTP.responseCookieJar (extract resp)) return resp +runWith :: Session -> Run Body -> Run Body +runWith = runWithGeneric id + +runWithHistory :: Session -> RunHistory Body -> RunHistory Body +runWithHistory = runWithGeneric HTTP.hrFinalResponse + type Mapping a = (Body -> a, a -> Body, Run a) +type MappingHistory a = (Body -> a, a -> Body, RunHistory a) run :: Mapping a -> Session -> Run a run (to,from,act) sesh = fmap (fmap to) . seshRun sesh sesh (fmap (fmap from) . act) +runHistory :: MappingHistory a -> Session -> RunHistory a +runHistory (to,from,act) sesh = + fmap (fmap to) . seshRunHistory sesh sesh (fmap (fmap from) . act) + string :: Mapping L.ByteString string = (\(StringBody s) -> s, StringBody, runRead) +stringHistory :: MappingHistory L.ByteString +stringHistory = (\(StringBody s) -> s, StringBody, runReadHistory) + ignore :: Mapping () -ignore = (\_ -> (), const NoBody, runIgnore) +ignore = (const (), const NoBody, runIgnore) diff --git a/Network/Wreq/Types.hs b/Network/Wreq/Types.hs --- a/Network/Wreq/Types.hs +++ b/Network/Wreq/Types.hs @@ -41,7 +41,7 @@ import Data.Aeson (Value, encode) import Data.Int (Int8, Int16, Int32, Int64) import Data.Word (Word, Word8, Word16, Word32, Word64) -import Network.HTTP.Client (Request) +import Network.HTTP.Client (Request(method)) import Network.HTTP.Client.MultipartFormData (Part, formDataBody) import Network.Wreq.Internal.Types import qualified Data.ByteString as S @@ -53,37 +53,40 @@ import qualified Network.HTTP.Client as HTTP import qualified Network.Wreq.Internal.Lens as Lens -instance Postable Part where - postPayload a = postPayload [a] - -instance Postable [Part] where - postPayload = formDataBody - -instance Postable [(S.ByteString, S.ByteString)] where - postPayload ps req = return $ HTTP.urlEncodedBody ps req - -instance Postable (S.ByteString, S.ByteString) where - postPayload p = postPayload [p] - -instance Postable [FormParam] where - postPayload ps = postPayload (map f ps) - where f (a := b) = (a, renderFormValue b) +-- By default if the type is Putable, we use that as postPayload +instance Postable Part +instance Postable [Part] +instance Postable [(S.ByteString, S.ByteString)] +instance Postable (S.ByteString, S.ByteString) +instance Postable [FormParam] +instance Postable FormParam +instance Postable Payload +instance Postable S.ByteString +instance Postable L.ByteString +instance Postable Value -instance Postable FormParam where - postPayload p = postPayload [p] +instance Putable Part where + putPayload a = putPayload [a] -instance Postable Payload where - postPayload = putPayload +instance Putable [Part] where + putPayload p req = + -- According to doc, formDataBody changes the request type to POST which is wrong; change it back + (\r -> r{method=method req}) <$> formDataBody p req -instance Postable S.ByteString where - postPayload = putPayload +instance Putable [(S.ByteString, S.ByteString)] where + putPayload ps req = + -- According to doc, urlEncodedBody changes the request type to POST which is wrong; change it back + return $ HTTP.urlEncodedBody ps req {method=method req} -instance Postable L.ByteString where - postPayload = putPayload +instance Putable (S.ByteString, S.ByteString) where + putPayload p = putPayload [p] -instance Postable Value where - postPayload = putPayload +instance Putable [FormParam] where + putPayload ps = putPayload (map f ps) + where f (a := b) = (a, renderFormValue b) +instance Putable FormParam where + putPayload p = putPayload [p] instance Putable Payload where putPayload pl = diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,6 +1,33 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wall #-} module Main (main) where +#ifndef MIN_VERSION_cabal_doctest +#define MIN_VERSION_cabal_doctest(x,y,z) 0 +#endif + +#if MIN_VERSION_cabal_doctest(1,0,0) + +import Distribution.Extra.Doctest ( defaultMainWithDoctests ) +main :: IO () +main = defaultMainWithDoctests "doctests" + +#else + +#ifdef MIN_VERSION_Cabal +-- If the macro is defined, we have new cabal-install, +-- but for some reason we don't have cabal-doctest in package-db +-- +-- Probably we are running cabal sdist, when otherwise using new-build +-- workflow +#warning You are configuring this package without cabal-doctest installed. \ + The doctests test-suite will not work as a result. \ + To fix this, install cabal-doctest before configuring. +#endif + import Distribution.Simple main :: IO () main = defaultMain + +#endif diff --git a/TODO.md b/TODO.md --- a/TODO.md +++ b/TODO.md @@ -2,8 +2,6 @@ * More advanced tutorial-style documentation -* TLS server certificate verification - * An example that spiders a Haddock package's docs to validate its internal and external links diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,28 @@ -*- markdown -*- +2018-01-01 0.5.2.0 + +* Added some HistoriedResponse support + +* Deprecated withSession, added newSession (to be inline with upstream http-client) + +* Added same instances for Putable as for Postable (might be merged?) + +* Added getSessionCookieJar to get cookies from a Session + +* Fixed customPayloadMethod to follow the method (it was sometimes POST) + +2017-12-23 0.5.1.1 + +* Add awsSessionTokenAuth (in addition to the existing awsAuth) to + support AWS Session Token Service (AWS STS) credentials. These look + like regular AWS credentials but have an additional session token as + a 3rd element. This mechanism is needed to be able to (a) use EC2 + instance profiles, (b) make calls form AWS Lambda, (c) is useful for + delegated role access (assumeRole within and across accounts), and (d) + enables MFA-protected access scenarios. + See tests/AWS/IAM.hs for a test and simple example. + 2017-01-09 0.5.1.0 * Add Session-specific version of Network.Wreq.customPayloadMethodWith diff --git a/httpbin/HttpBin/Server.hs b/httpbin/HttpBin/Server.hs --- a/httpbin/HttpBin/Server.hs +++ b/httpbin/HttpBin/Server.hs @@ -141,9 +141,9 @@ params = Map.foldlWithKey' step Map.empty . rqQueryParams $ req wibble (k,v) = (decodeUtf8 (original k), decodeUtf8 v) - rqHeaders = headers req - hdrs = Map.fromList . map wibble . listHeaders $ rqHeaders - url = case getHeader "Host" rqHeaders of + rqHdrs = headers req + hdrs = Map.fromList . map wibble . listHeaders $ rqHdrs + url = case getHeader "Host" rqHdrs of Nothing -> [] Just host -> [("url", toJSON . decodeUtf8 $ "http://" <> host <> rqURI req)] diff --git a/tests/AWS.hs b/tests/AWS.hs --- a/tests/AWS.hs +++ b/tests/AWS.hs @@ -14,12 +14,9 @@ that you are familiar with AWS concepts and the charging model. ** ENABLING AWS TESTS ** -For now, enable AWS tests by setting the WREQ_AWS_ACCESS_KEY_ID -env variable per below. - -TODO| To enable AWS tests use the `-faws` flag as part of -TODO| $ cabal configure --enable-tests -faws ... -TODO| To capture code coverage information, add the `-fdeveloper` flag. +To enable AWS tests use the `-faws` flag as part of + $ cabal configure --enable-tests -faws ... +To capture code coverage information, add the `-fdeveloper` flag. ** REQUIRED CLIENT CONFIGURATION ** The tests require two environment variables: @@ -76,20 +73,6 @@ tests :: IO Test tests = do - -- TODO - use ... configure -faws ... in the future - -- but couldn't figure out (yet) how to get - -- a hold of the flag value in test code. - -- Workaround: for now, the presence of the - -- WREQ_AWS_ACCESS_KEY_ID - -- env variable enables the tests. - flag <- (getEnv "WREQ_AWS_ACCESS_KEY_ID" >> return True) `E.catch` - \(_::IOException) -> return False - tests0 flag - -tests0 :: Bool -> IO Test -tests0 False = - return $ testGroup "aws" [] -- skip AWS tests -tests0 True = do region <- env "us-west-2" "WREQ_AWS_REGION" key <- BS8.pack `fmap` getEnv "WREQ_AWS_ACCESS_KEY_ID" secret <- BS8.pack `fmap` getEnv "WREQ_AWS_SECRET_ACCESS_KEY" diff --git a/tests/AWS/IAM.hs b/tests/AWS/IAM.hs --- a/tests/AWS/IAM.hs +++ b/tests/AWS/IAM.hs @@ -1,19 +1,24 @@ -{-# LANGUAGE OverloadedLists, OverloadedStrings #-} +{-# LANGUAGE OverloadedLists, OverloadedStrings, DeriveGeneric #-} module AWS.IAM (tests) where import AWS.Aeson import Control.Concurrent (threadDelay) import Control.Lens hiding ((.=)) -import Data.Aeson.Encode (encode) -import Data.Aeson.Lens (key, _String, values) +import Data.Aeson (encode) +import Data.Aeson.Lens (key, _String, values, _Value) +import Data.Char (toUpper) import Data.IORef (IORef, readIORef, writeIORef) import Data.Text as T (Text, pack, unpack, split) +import Data.Text.Encoding (encodeUtf8) import Data.Text.Lazy as LT (toStrict) import Data.Text.Lazy.Encoding as E (decodeUtf8) +import GHC.Generics import Network.Wreq import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit (assertBool) +import qualified Data.Aeson as A +import qualified Data.Aeson.Types as DAT tests :: String -> String -> Options -> IORef String -> Test tests prefix region baseopts iamTestState = testGroup "iam" [ @@ -111,8 +116,20 @@ elem (prefix ++ roleName) arns' -- Security Token Service (STS) +data Cred = Cred { + accessKeyId :: T.Text, + secretAccessKey :: T.Text, + sessionToken :: T.Text, + expiration :: Int -- Unix epoch + } deriving (Generic, Show, Eq) + +instance A.FromJSON Cred where + parseJSON = DAT.genericParseJSON $ DAT.defaultOptions { + DAT.fieldLabelModifier = \(h:t) -> toUpper h:t + } + stsAssumeRole :: String -> String -> Options -> IORef String -> IO () -stsAssumeRole _prefix region baseopts iamTestState = do +stsAssumeRole prefix region baseopts iamTestState = do arn <- readIORef iamTestState let opts = baseopts & param "Action" .~ ["AssumeRole"] @@ -122,8 +139,48 @@ & param "RoleSessionName" .~ ["Bob"] & header "Accept" .~ ["application/json"] r <- getWith opts (stsUrl region) -- STS call (part of IAM service family) + let v = r ^? responseBody + . key "AssumeRoleResponse" + . key "AssumeRoleResult" + . key "Credentials" + . _Value assertBool "stsAssumeRole 200" $ r ^. responseStatus . statusCode == 200 assertBool "stsAssumeRole OK" $ r ^. responseStatus . statusMessage == "OK" + + -- Now, use the temporary credentials to call an AWS service + let cred = conv v :: Cred + let key' = encodeUtf8 $ accessKeyId cred + let secret' = encodeUtf8 $ secretAccessKey cred + let token' = encodeUtf8 $ sessionToken cred + let baseopts2 = defaults + & auth ?~ awsSessionTokenAuth AWSv4 key' secret' token' + let opts2 = baseopts2 + & param "Action" .~ ["ListRoles"] + & param "Version" .~ ["2010-05-08"] + & header "Accept" .~ ["application/json"] + r2 <- getWith opts2 (iamUrl region) + assertBool "listRoles 200" $ r2 ^. responseStatus . statusCode == 200 + assertBool "listRoles OK" $ r2 ^. responseStatus . statusMessage == "OK" + let arns = r2 ^.. responseBody . key "ListRolesResponse" . + key "ListRolesResult" . + key "Roles" . + values . + key "Arn" . _String + -- arns are of form: "arn:aws:iam:::role/ec2-role" + let arns' = map (T.unpack . last . T.split (=='/')) arns + assertBool "listRoles contains test role" $ + elem (prefix ++ roleName) arns' + + where + conv :: DAT.FromJSON a => Maybe DAT.Value -> a + conv v = case v of + Nothing -> error "1" + Just x -> + case A.fromJSON x of + A.Success r -> + r + A.Error e -> + error $ show e iamUrl :: String -> String iamUrl _ = diff --git a/tests/DocTests.hs b/tests/DocTests.hs deleted file mode 100644 --- a/tests/DocTests.hs +++ /dev/null @@ -1,47 +0,0 @@ --- I don't know who originally wrote this, but I picked it up from --- Edward Kmett's folds package, and subsequently modified it. - -module Main where - -import Build_doctest (deps) -import Control.Applicative ((<$>), (<*>)) -import Control.Monad (filterM) -import Data.List (isPrefixOf, isSuffixOf) -import System.Directory --- import System.Environment (getArgs) -import System.FilePath (()) -import Test.DocTest (doctest) - -main :: IO () -main = do - -- doctest chokes on the command line args that cabal test passes in - -- args <- getArgs - let args = [] - srcs <- getSources - dist <- getDistDir - doctest $ args ++ [ "-i." - , "-i" ++ dist ++ "/build/autogen" - , "-optP-include" - , "-optP" ++ dist ++ "/build/autogen/cabal_macros.h" - , "-hide-all-packages" - ] ++ map ("-package="++) deps ++ srcs - -getSources :: IO [FilePath] -getSources = filter (isSuffixOf ".hs") <$> go "Network" - where - go dir = do - (dirs, files) <- getFilesAndDirectories dir - (files ++) . concat <$> mapM go dirs - -getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) -getFilesAndDirectories dir = do - c <- map (dir ) . filter (`notElem` ["..", "."]) <$> - getDirectoryContents dir - (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c - -getDistDir :: IO FilePath -getDistDir = do - names <- getDirectoryContents "dist" - return $ case filter ("dist-sandbox-" `isPrefixOf`) names of - (d:_) -> "dist/" ++ d - _ -> "dist" diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs --- a/tests/UnitTests.hs +++ b/tests/UnitTests.hs @@ -12,7 +12,7 @@ import Control.Exception (Exception, throwIO) import Control.Lens ((^.), (^?), (.~), (?~), (&), iso, ix, Traversal') import Control.Monad (unless, void) -import Data.Aeson +import Data.Aeson hiding (Options) import Data.Aeson.Lens (key, AsValue, _Object) import Data.ByteString (ByteString) import Data.Char (toUpper) @@ -287,7 +287,8 @@ (r ^? responseCookie "x" . cookieValue) -cookieSession site = Session.withSession $ \s -> do +cookieSession site = do + s <- Session.newSession r0 <- Session.get s (site "/cookies/set?foo=bar") assertEqual "after set foo, foo set" (Just "bar") (r0 ^? responseCookie "foo" . cookieValue) @@ -366,7 +367,8 @@ -- Snap responds incorrectly to HEAD (by sending a response body), -- thereby killing http-client's ability to continue a session. -- https://github.com/snapframework/snap-core/issues/192 -snapHeadSessionBug site = Session.withSession $ \s -> do +snapHeadSessionBug site = do + s <- Session.newSession basicHead (session s) site -- will crash with (InvalidStatusLine "0") basicGet (session s) site @@ -402,8 +404,8 @@ testWith :: [Test] -> IO () testWith tests = do (tid, mserv) <- startServer - Session.withSession $ \s -> - flip E.finally (killThread tid) . + s <- Session.newSession + flip E.finally (killThread tid) . defaultMain $ tests <> [ testGroup "plain" $ httpbinTests basic , testGroup "session" $ httpbinTests (session s)] <> diff --git a/tests/doctests.hs b/tests/doctests.hs new file mode 100644 --- /dev/null +++ b/tests/doctests.hs @@ -0,0 +1,12 @@ +module Main where + +import Build_doctests (flags, pkgs, module_sources) +import Data.Foldable (traverse_) +import Test.DocTest (doctest) + +main :: IO () +main = do + traverse_ putStrLn args + doctest args + where + args = flags ++ pkgs ++ module_sources diff --git a/wreq.cabal b/wreq.cabal --- a/wreq.cabal +++ b/wreq.cabal @@ -1,5 +1,5 @@ name: wreq -version: 0.5.1.0 +version: 0.5.2.0 synopsis: An easy-to-use HTTP client library. description: . @@ -36,7 +36,7 @@ copyright: 2014 Bryan O'Sullivan category: Web build-type: Custom -cabal-version: >=1.10 +cabal-version: >=1.24 tested-with: GHC==8.2.1, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 extra-source-files: README.md @@ -48,6 +48,10 @@ www/*.md www/Makefile +custom-setup + setup-depends: + base, Cabal, cabal-doctest >=1.0.2 && <1.1 + -- disable doctests with -f-doctest flag doctest description: enable doctest tests @@ -118,7 +122,7 @@ time-locale-compat, template-haskell, text, - time, + time >= 1.5, unordered-containers -- A convenient server for testing locally, or if httpbin.org is down. @@ -207,14 +211,14 @@ vector, wreq -test-suite doctest +test-suite doctests type: exitcode-stdio-1.0 hs-source-dirs: tests - main-is: DocTests.hs + main-is: doctests.hs ghc-options: -Wall -fwarn-tabs -threaded if flag(developer) ghc-options: -Werror - default-language: Haskell98 + default-language: Haskell2010 if !flag(doctest) buildable: False