wreq 0.4.1.0 → 0.5.4.5
raw patch · 23 files changed
Files
- Network/Wreq.hs +106/−5
- Network/Wreq/Cache.hs +2/−2
- Network/Wreq/Internal.hs +42/−19
- Network/Wreq/Internal/AWS.hs +43/−20
- Network/Wreq/Internal/Lens.hs +3/−2
- Network/Wreq/Internal/Types.hs +27/−10
- Network/Wreq/Lens.hs +34/−19
- Network/Wreq/Lens/TH.hs +9/−3
- Network/Wreq/Session.hs +133/−24
- Network/Wreq/Types.hs +49/−27
- Setup.hs +25/−56
- TODO.md +0/−2
- changelog.md +93/−0
- examples/UploadPaste.hs +2/−1
- examples/wreq-examples.cabal +0/−5
- httpbin/HttpBin/Server.hs +8/−7
- tests/AWS.hs +3/−20
- tests/AWS/IAM.hs +61/−4
- tests/DocTests.hs +0/−47
- tests/UnitTests.hs +67/−41
- tests/doctests.hs +12/−0
- wreq.cabal +34/−33
- www/tutorial.md +22/−12
Network/Wreq.hs view
@@ -57,15 +57,22 @@ -- ** PUT , put , putWith+ -- ** PATCH+ , patch+ , patchWith -- ** DELETE , delete , deleteWith -- ** Custom Method , customMethod , customMethodWith+ , customHistoriedMethod+ , customHistoriedMethodWith -- ** Custom Payload Method , customPayloadMethod , customPayloadMethodWith+ , customHistoriedPayloadMethod+ , customHistoriedPayloadMethodWith -- * Incremental consumption of responses -- ** GET , foldGet@@ -82,7 +89,7 @@ , Lens.params , Lens.cookie , Lens.cookies- , Lens.checkStatus+ , Lens.checkResponse -- ** Authentication -- $auth@@ -94,6 +101,8 @@ , oauth2Bearer , oauth2Token , awsAuth+ , awsFullAuth+ , awsSessionTokenAuth -- ** Proxy settings , Proxy(Proxy) , Lens.proxy@@ -132,6 +141,10 @@ , Lens.Status , Lens.statusCode , Lens.statusMessage+ , HistoriedResponse+ , Lens.hrFinalRequest+ , Lens.hrFinalResponse+ , Lens.hrRedirects -- ** Link headers , Lens.Link , Lens.linkURL@@ -162,6 +175,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)@@ -192,7 +206,8 @@ get url = getWith defaults url withManager :: (Options -> IO a) -> IO a-withManager act = HTTP.withManager defaultManagerSettings $ \mgr ->+withManager act = do+ mgr <- HTTP.newManager defaultManagerSettings act defaults { Wreq.manager = Right mgr } -- | Issue a GET request, using the supplied 'Options'.@@ -279,6 +294,14 @@ putWith :: Putable a => Options -> String -> a -> IO (Response L.ByteString) putWith opts url payload = runRead =<< preparePut opts url payload +-- | Issue a PATCH request.+patch :: Patchable a => String -> a -> IO (Response L.ByteString)+patch url payload = patchWith defaults url payload++-- | Issue a PATCH request, using the supplied 'Options'.+patchWith :: Patchable a => Options -> String -> a -> IO (Response L.ByteString)+patchWith opts url payload = runRead =<< preparePatch opts url payload+ -- | Issue an OPTIONS request. -- -- Example:@@ -335,6 +358,7 @@ -- | Issue a custom-method request -- -- Example:+-- -- @ -- 'customMethod' \"PATCH\" \"http:\/\/httpbin.org\/patch\" -- @@@ -363,6 +387,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)@@ -373,12 +424,28 @@ -- | Issue a custom-method request with a payload, using the supplied 'Options'. customPayloadMethodWith :: Postable a => String -> Options -> String -> a -> IO (Response L.ByteString)- + customPayloadMethodWith method opts url payload = runRead =<< preparePayloadMethod methodBS opts url payload 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 @@ -429,7 +496,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)@@ -524,8 +592,37 @@ --'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)++-- | AWS v4 request signature.+--+-- Example (note the use of TLS):+--+-- @+--let opts = 'defaults' '&' 'Lens.auth' '?~' 'awsFullAuth' 'AWSv4' \"key\" \"secret\" (Just (\"service\", \"region\"))+--'getWith' opts \"https:\/\/dynamodb.us-west-2.amazonaws.com\"+-- @+awsFullAuth :: AWSAuthVersion -> S.ByteString -> S.ByteString -> Maybe S.ByteString -> Maybe (S.ByteString, S.ByteString) -> Auth+awsFullAuth = AWSFullAuth+ -- | Proxy configuration. -- -- Example:@@ -604,6 +701,10 @@ -- The \"magical\" type conversion on the right-hand side of ':=' -- above is due to the 'FormValue' class. This package provides -- sensible instances for the standard string and number types.+-- You may need to explicitly add types to the values (e.g. :: String)+-- in order to evade ambigous type errors.+--+-- >>> r <- post "http://httpbin.org/post" ["num" := (31337 :: Int), "str" := ("foo" :: String)] -- -- The 'Aeson.Value' type gives a JSON request body with a -- @Content-Type@ of @application/json@. Any instance of
Network/Wreq/Cache.hs view
@@ -22,7 +22,7 @@ import Data.Maybe (listToMaybe) import Data.Monoid (First(..), mconcat) import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime)-import Data.Time.Format (parseTime)+import Data.Time.Format (parseTimeM) import Data.Time.Locale.Compat (defaultTimeLocale) import Data.Typeable (Typeable) import GHC.Generics (Generic)@@ -150,4 +150,4 @@ , "%A, %d-%b-%y %H:%M:%S %Z" , "%a %b %e %H:%M:%S %Y" ]- where tryout fmt = First $ parseTime defaultTimeLocale fmt (B.unpack s)+ where tryout fmt = First $ parseTimeM True defaultTimeLocale fmt (B.unpack s)
Network/Wreq/Internal.hs view
@@ -12,10 +12,12 @@ , prepareGet , preparePost , runRead+ , runReadHistory , prepareHead , runIgnore , prepareOptions , preparePut+ , preparePatch , prepareDelete , prepareMethod , preparePayloadMethod@@ -24,15 +26,16 @@ import Control.Applicative ((<$>)) import Control.Arrow ((***)) import Control.Lens ((&), (.~), (%~))+import Control.Monad ((>=>)) 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.Types (Auth(..), Options(..), Postable(..), Putable(..))+import Network.Wreq.Internal.Types (Mgr, Req(..), Run, RunHistory)+import Network.Wreq.Types (Auth(..), Options(..), Postable(..), Patchable(..), Putable(..)) import Prelude hiding (head) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as Char8@@ -40,9 +43,9 @@ import qualified Network.HTTP.Client as HTTP import qualified Network.HTTP.Types as HTTP import qualified Network.Wreq.Internal.Lens as Lens-import qualified Network.Wreq.Internal.AWS as AWS (signRequest)+import qualified Network.Wreq.Internal.AWS as AWS (signRequest,signRequestFull) import qualified Network.Wreq.Internal.OAuth1 as OAuth1 (signRequest)-import qualified Network.Wreq.Lens as Lens hiding (checkStatus)+import qualified Network.Wreq.Lens as Lens hiding (checkResponse) -- This mess allows this module to continue to load during interactive -- development in ghci :-(@@ -66,7 +69,7 @@ , params = [] , redirects = 10 , cookies = Just (HTTP.createCookieJar [])- , checkStatus = Nothing+ , checkResponse = Nothing } where userAgent = "haskell wreq-" <> Char8.pack (showVersion version) @@ -87,6 +90,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@@ -101,24 +110,29 @@ request modify opts url act = run (manager opts) act =<< prepare modify opts url run :: Mgr -> (Response BodyReader -> IO a) -> Request -> IO a-run emgr act req = either (flip HTTP.withManager go) go emgr+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.parseUrl url+ signRequest =<< modify =<< frob <$> HTTP.parseUrlThrow url where frob req = req & Lens.requestHeaders %~ (headers opts ++) & setQuery opts & setAuth opts & setProxy opts- & setCheckStatus opts+ & setCheckResponse opts & setRedirects opts & Lens.cookieJar .~ cookies opts 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 (AWSFullAuth versn key secret _ serviceRegion) = AWS.signRequestFull versn key secret serviceRegion f (OAuth1 consumerToken consumerSecret token secret) = OAuth1.signRequest consumerToken consumerSecret token secret f _ = return @@ -138,17 +152,20 @@ 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 (AWSFullAuth _ _ _ mSessionToken _) =+ maybe id (setHeader "X-Amz-Security-Token") mSessionToken f (OAuth1 _ _ _ _) = id setProxy :: Options -> Request -> Request setProxy = maybe id f . proxy where f (Proxy host port) = addProxy host port -setCheckStatus :: Options -> Request -> Request-setCheckStatus = maybe id f . checkStatus- where f cs = ( & Lens.checkStatus .~ cs)+setCheckResponse :: Options -> Request -> Request+setCheckResponse = maybe id f . checkResponse+ where f cs = ( & Lens.checkResponse .~ cs) prepareGet :: Options -> String -> IO Req prepareGet opts url = Req (manager opts) <$> prepare return opts url@@ -156,9 +173,12 @@ 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) <$>- prepare (postPayload payload . (Lens.method .~ HTTP.methodPost)) opts url+ prepare (fmap (Lens.method .~ HTTP.methodPost) . postPayload payload) opts url prepareMethod :: HTTP.Method -> Options -> String -> IO Req prepareMethod method opts url = Req (manager opts) <$>@@ -166,9 +186,8 @@ preparePayloadMethod :: Postable a => HTTP.Method -> Options -> String -> a -> IO Req- preparePayloadMethod method opts url payload = Req (manager opts) <$>- prepare (postPayload payload . (Lens.method .~ method)) opts url+ prepare (fmap (Lens.method .~ method) . postPayload payload) opts url prepareHead :: Options -> String -> IO Req prepareHead = prepareMethod HTTP.methodHead@@ -181,7 +200,11 @@ preparePut :: Putable a => Options -> String -> a -> IO Req preparePut opts url payload = Req (manager opts) <$>- prepare (putPayload payload . (Lens.method .~ HTTP.methodPut)) opts url+ prepare (fmap (Lens.method .~ HTTP.methodPut) . putPayload payload) opts url++preparePatch :: Patchable a => Options -> String -> a -> IO Req+preparePatch opts url payload = Req (manager opts) <$>+ prepare (patchPayload payload . (Lens.method .~ HTTP.methodPatch)) opts url prepareDelete :: Options -> String -> IO Req prepareDelete = prepareMethod HTTP.methodDelete
Network/Wreq/Internal/AWS.hs view
@@ -3,14 +3,15 @@ module Network.Wreq.Internal.AWS (- signRequest+ signRequest,+ signRequestFull ) where import Control.Applicative ((<$>)) import Control.Lens ((%~), (^.), (&), to)-import Crypto.MAC (hmac, hmacGetDigest)+import Crypto.MAC.HMAC (HMAC (..), hmac, hmacGetDigest) import Data.ByteString.Base16 as HEX (encode)-import Data.Byteable (toBytes)+import Data.ByteArray (convert) import Data.Char (toLower) import Data.List (sort) import Data.Monoid ((<>))@@ -21,9 +22,9 @@ import Network.HTTP.Types (parseSimpleQuery, urlEncode) import Network.Wreq.Internal.Lens import Network.Wreq.Internal.Types (AWSAuthVersion(..))-import qualified Crypto.Hash as CT (HMAC, SHA256)-import qualified Crypto.Hash.SHA256 as SHA256 (hash, hashlazy)+import qualified Crypto.Hash as CT (Digest, SHA256, hash, hashlazy) import qualified Data.ByteString.Char8 as S+import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.CaseInsensitive as CI (original) import qualified Data.HashSet as HashSet import qualified Network.HTTP.Client as HTTP@@ -42,20 +43,36 @@ -- TODO: adjust when DELETE supports a body or PATCH is added signRequest :: AWSAuthVersion -> S.ByteString -> S.ByteString -> Request -> IO Request-signRequest AWSv4 = signRequestV4+signRequest AWSv4 aid key r = signRequestFull AWSv4 aid key Nothing r -signRequestV4 :: S.ByteString -> S.ByteString -> Request -> IO Request-signRequestV4 key secret request = do+hexSha256Hash :: S.ByteString -> S.ByteString+hexSha256Hash dta =+ let digest = CT.hash dta :: CT.Digest CT.SHA256+ in S.pack (show digest)++hexSha256HashLazy :: L.ByteString -> S.ByteString+hexSha256HashLazy dta =+ let digest = CT.hashlazy dta :: CT.Digest CT.SHA256+ in S.pack (show digest)+++signRequestFull :: AWSAuthVersion -> S.ByteString -> S.ByteString -> Maybe (S.ByteString, S.ByteString) -> Request -> IO Request+signRequestFull AWSv4 = signRequestV4++signRequestV4 :: S.ByteString -> S.ByteString -> Maybe (S.ByteString, S.ByteString) -> Request -> IO Request+signRequestV4 key secret serviceRegion request = do !ts <- timestamp -- YYYYMMDDT242424Z, UTC based let origHost = request ^. host -- potentially w/ runscope bucket runscopeBucketAuth = lookup "Runscope-Bucket-Auth" $ request ^. requestHeaders noRunscopeHost = removeRunscope origHost -- rm Runscope for signing- (service, region) = serviceAndRegion noRunscopeHost+ (service, region) = case serviceRegion of+ Nothing -> serviceAndRegion noRunscopeHost+ Just (a, b) -> (a, b) date = S.takeWhile (/= 'T') ts -- YYYYMMDD hashedPayload | request ^. method `elem` ["POST", "PUT"] = payloadHash req- | otherwise = HEX.encode $ SHA256.hash ""+ | otherwise = hexSha256Hash "" -- add common v4 signing headers, service specific headers, and -- drop tmp header and Runscope-Bucket-Auth header (if present). req = request & requestHeaders %~@@ -65,12 +82,13 @@ -- Runscope (correctly) doesn't send Bucket Auth header to AWS, -- remove it from the headers we sign. Adding back in at the end. . deleteKey "Runscope-Bucket-Auth"+ let encodePath p = S.intercalate "/" $ map (urlEncode False) $ S.split '/' p -- task 1 let hl = req ^. requestHeaders . to sort signedHeaders = S.intercalate ";" . map (lowerCI . fst) $ hl canonicalReq = S.intercalate "\n" [ req ^. method -- step 1- , req ^. path -- step 2+ , encodePath (req ^. path) -- step 2 , S.intercalate "&" -- step 3b, incl. sort -- urlEncode True (QS) to encode ':' and '/' (e.g. in AWS arns) . map (\(k,v) -> urlEncode True k <> "=" <> urlEncode True v)@@ -87,7 +105,7 @@ "AWS4-HMAC-SHA256" , ts , dateScope- , HEX.encode $ SHA256.hash canonicalReq+ , hexSha256Hash canonicalReq ] -- task 3, steps 1 and 2 let signature = ("AWS4" <> secret) &@@ -113,16 +131,15 @@ timestamp = render <$> getCurrentTime where render = S.pack . formatTime defaultTimeLocale "%Y%m%dT%H%M%SZ" . utcToLocalTime utc -- UTC printable: YYYYMMDDTHHMMSSZ- hmac' s k = toBytes (hmacGetDigest h)- where h = hmac k s :: (CT.HMAC CT.SHA256)+ hmac' :: S.ByteString -> S.ByteString -> S.ByteString+ hmac' s k = convert (hmacGetDigest h)+ where h = hmac k s :: (HMAC CT.SHA256) payloadHash :: Request -> S.ByteString payloadHash req = case HTTP.requestBody req of- HTTP.RequestBodyBS bs ->- HEX.encode $ SHA256.hash bs- HTTP.RequestBodyLBS lbs ->- HEX.encode $ SHA256.hashlazy lbs+ HTTP.RequestBodyBS bs -> hexSha256Hash bs+ HTTP.RequestBodyLBS lbs -> hexSha256HashLazy lbs _ -> error "addTmpPayloadHashHeader: unexpected request body type" -- Per AWS documentation at:@@ -148,6 +165,12 @@ -- not s3 | endpoint `elem` ["sts.amazonaws.com"] = ("sts", "us-east-1")+ | ".execute-api." `S.isInfixOf` endpoint =+ let gateway:service:region:_ = S.split '.' endpoint+ in (service, region)+ | ".es.amazonaws.com" `S.isSuffixOf` endpoint =+ let _:region:_ = S.split '.' endpoint+ in ("es", region) | svc `HashSet.member` noRegion = (svc, "us-east-1") | otherwise =@@ -179,5 +202,5 @@ | otherwise = hostname where p1 "-" = "." p1 other = other- p2 "--" = "-"- p2 other = other+ p2 "--" = "-"+ p2 other = other
Network/Wreq/Internal/Lens.hs view
@@ -13,6 +13,7 @@ , requestHeaders , requestBody , requestVersion+ , requestManagerOverride , onRequestBodyException , proxy , hostAddress@@ -20,12 +21,12 @@ , decompress , redirectCount , responseTimeout- , checkStatus- , getConnectionWrapper+ , checkResponse , cookieJar , seshCookies , seshManager , seshRun+ , seshRunHistory -- * Useful functions , assoc , assoc2
Network/Wreq/Internal/Types.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE DeriveDataTypeable, DeriveFunctor, FlexibleInstances, GADTs,- OverloadedStrings, RankNTypes, RecordWildCards #-}+ OverloadedStrings, RankNTypes, RecordWildCards, DefaultSignatures #-} -- | -- Module : Network.Wreq.Internal.Types@@ -19,10 +19,11 @@ , Mgr , Auth(..) , AWSAuthVersion(..)- , StatusChecker+ , ResponseChecker -- * Request payloads , Payload(..) , Postable(..)+ , Patchable(..) , Putable(..) -- ** URL-encoded forms , FormParam(..)@@ -38,12 +39,13 @@ -- * Sessions , Session(..) , Run+ , RunHistory , Body(..) -- * Caches , CacheEntry(..) ) where -import Control.Exception (Exception, SomeException)+import Control.Exception (Exception) import Data.IORef (IORef) import Data.Monoid ((<>), mconcat) import Data.Text (Text)@@ -52,7 +54,7 @@ import Network.HTTP.Client (CookieJar, Manager, ManagerSettings, Request, RequestBody) import Network.HTTP.Client.Internal (Response, Proxy)-import Network.HTTP.Types (Header, Status, ResponseHeaders)+import Network.HTTP.Types (Header) import Prelude hiding (head) import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy as L@@ -150,7 +152,7 @@ -- etc.), this field will be used only for the /first/ HTTP request -- to be issued during a 'Network.Wreq.Session.Session'. Any changes -- changes made for subsequent requests will be ignored.- , checkStatus :: Maybe StatusChecker+ , checkResponse :: Maybe ResponseChecker -- ^ Function that checks the status code and potentially returns an -- exception. --@@ -160,9 +162,8 @@ } deriving (Typeable) -- | A function that checks the result of a HTTP request and--- potentially returns an exception.-type StatusChecker = Status -> ResponseHeaders -> CookieJar- -> Maybe SomeException+-- potentially throw an exception.+type ResponseChecker = Request -> Response HTTP.BodyReader -> IO () -- | Supported authentication types. --@@ -180,9 +181,12 @@ -- 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)+ | AWSFullAuth AWSAuthVersion S.ByteString S.ByteString (Maybe S.ByteString) (Maybe (S.ByteString, S.ByteString))+ -- ^ Amazon Web Services request signing+ -- AWSAuthVersion key secret Maybe (service, region) | OAuth1 S.ByteString S.ByteString S.ByteString S.ByteString -- ^ OAuth1 request signing -- OAuth1 consumerToken consumerSecret token secret@@ -210,9 +214,19 @@ -- | 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. +-- | A type that can be converted into a PATCH request payload.+class Patchable a where+ patchPayload :: a -> Request -> IO Request+ default patchPayload :: Putable a => a -> Request -> IO Request+ patchPayload = putPayload+ -- ^ Represent a value in the request body (and perhaps the+ -- headers) of a PATCH request.+ -- | A type that can be converted into a PUT request payload. class Putable a where putPayload :: a -> Request -> IO Request@@ -289,12 +303,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
Network/Wreq/Lens.hs view
@@ -45,8 +45,8 @@ , params , cookie , cookies- , StatusChecker- , checkStatus+ , ResponseChecker+ , checkResponse -- ** Proxy setup , Proxy@@ -78,6 +78,12 @@ , responseStatus , responseVersion + -- * HistoriedResponse+ , HistoriedResponse+ , hrFinalResponse+ , hrFinalRequest+ , hrRedirects+ -- ** Status , Status , statusCode@@ -104,45 +110,42 @@ 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) import Network.HTTP.Types.Status (Status) import Network.HTTP.Types.Version (HttpVersion) import Network.Mime (MimeType)-import Network.Wreq.Types (Auth, Link, Options, StatusChecker)+import Network.Wreq.Types (Auth, Link, Options, ResponseChecker) import qualified Network.Wreq.Lens.TH as TH -- | A lens onto configuration of the connection manager provided by -- the http-client package. ----- In this example, we enable the use of OpenSSL for (hopefully)+-- In this example, we enable the use of TLS for (hopefully) -- secure connections: -- -- @---import "OpenSSL.Session" ('OpenSSL.Session.context')---import "Network.HTTP.Client.OpenSSL"+--import "Network.HTTP.Client.TLS" -----let opts = 'Network.Wreq.defaults' 'Control.Lens.&' 'manager' 'Control.Lens..~' Left ('Network.HTTP.Client.OpenSSL.opensslManagerSettings' 'OpenSSL.Session.context')---'Network.HTTP.Client.OpenSSL.withOpenSSL' $--- 'Network.Wreq.getWith' opts \"https:\/\/httpbin.org\/get\"+--let opts = 'Network.Wreq.defaults' 'Control.Lens.&' 'manager' 'Control.Lens..~' Left 'Network.HTTP.Client.TLS.tlsManagerSettings'+--'Network.Wreq.getWith' opts \"https:\/\/httpbin.org\/get\" -- @ -- -- In this example, we also set the response timeout to 10000 microseconds: -- -- @---import "OpenSSL.Session" ('OpenSSL.Session.context')---import "Network.HTTP.Client.OpenSSL"+--import "Network.HTTP.Client.TLS" --import "Network.HTTP.Client" ('Network.HTTP.Client.defaultManagerSettings', 'Network.HTTP.Client.managerResponseTimeout') -----let opts = 'Network.Wreq.defaults' 'Control.Lens.&' 'manager' 'Control.Lens..~' Left ('Network.HTTP.Client.OpenSSL.opensslManagerSettings' 'OpenSSL.Session.context')--- 'Control.Lens.&' 'manager' 'Control.Lens..~' Left ('Network.HTTP.Client.defaultManagerSettings' { 'Network.HTTP.Client.managerResponseTimeout' = Just 10000 } )+--let opts = 'Network.Wreq.defaults' 'Control.Lens.&' 'manager' 'Control.Lens..~' Left 'Network.HTTP.Client.TLS.tlsManagerSettings'+-- 'Control.Lens.&' 'manager' 'Control.Lens..~' Left ('Network.HTTP.Client.defaultManagerSettings' { 'Network.HTTP.Client.managerResponseTimeout' = responseTimeoutMicro 10000 } ) -----'Network.HTTP.Client.OpenSSL.withOpenSSL' $--- 'Network.Wreq.getWith' opts \"https:\/\/httpbin.org\/get\"+--'Network.Wreq.getWith' opts \"https:\/\/httpbin.org\/get\" -- @ manager :: Lens' Options (Either ManagerSettings Manager) manager = TH.manager@@ -228,8 +231,8 @@ redirects = TH.redirects -- | A lens to get the optional status check function-checkStatus :: Lens' Options (Maybe StatusChecker)-checkStatus = TH.checkStatus+checkResponse :: Lens' Options (Maybe ResponseChecker)+checkResponse = TH.checkResponse -- | A traversal onto the cookie with the given name, if one exists. --@@ -390,6 +393,18 @@ 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 statusCode = TH.statusCode@@ -447,7 +462,7 @@ -- >>> r ^. responseHeader "Allow" . atto verbs . to sort -- ["GET","HEAD","OPTIONS"] atto :: Parser a -> Fold ByteString a-atto = folding . parseOnly+atto p = folding (parseOnly p) -- | The same as 'atto', but ensures that the parser consumes the -- entire input.
Network/Wreq/Lens/TH.hs view
@@ -15,7 +15,7 @@ , redirects , cookie , cookies- , checkStatus+ , checkResponse , HTTP.Cookie , cookieName@@ -45,6 +45,11 @@ , responseCookieJar , responseClose' + , HTTP.HistoriedResponse+ , hrFinalResponse+ , hrFinalRequest+ , hrRedirects+ , HTTP.Status , statusCode , statusMessage@@ -53,7 +58,7 @@ , linkURL , linkParams - , Form.Part+ , Form.PartM , partName , partFilename , partContentType@@ -77,9 +82,10 @@ 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+makeLenses ''Form.PartM responseHeader :: HTTP.HeaderName -> Traversal' (HTTP.Response body) ByteString responseHeader n = responseHeaders . assoc n
Network/Wreq/Session.hs view
@@ -18,7 +18,7 @@ -- -- * Transparent cookie management. Any cookies set by the server -- persist from one request to the next. (Bypass this overhead--- using 'withAPISession'.)+-- using 'newAPISession'.) -- -- -- This module is designed to be used alongside the "Network.Wreq"@@ -28,27 +28,37 @@ -- import "Network.Wreq" -- import qualified "Network.Wreq.Session" as Sess ----- main = Sess.'withSession' $ \\sess ->+-- main = do+-- sess <- Sess.'newSession' -- Sess.'get' sess \"http:\/\/httpbin.org\/get\" -- @ ----- We create a 'Session' using 'withSession', then pass the session to+-- We create a 'Session' using 'newSession', then pass the session to -- subsequent functions. When talking to a REST-like service that does--- not use cookies, it is more efficient to use 'withAPISession'.+-- not use cookies, it is more efficient to use 'newAPISession'. -- -- 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 'newSessionControl') 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@@ -56,6 +66,7 @@ , options , put , delete+ , customMethod -- ** Configurable verbs , getWith , postWith@@ -63,21 +74,28 @@ , optionsWith , putWith , 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 import qualified Data.ByteString.Lazy as L import qualified Network.HTTP.Client as HTTP import qualified Network.Wreq.Internal.Lens as Lens+import qualified Network.Wreq.Lens as Lens+import Data.Traversable as T -- | Create a 'Session', passing it to the given function. The -- 'Session' will no longer be valid after that function returns.@@ -85,21 +103,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@@ -108,13 +147,33 @@ -> HTTP.ManagerSettings -> (Session -> IO a) -> IO a withSessionControl mj settings act = do- mref <- maybe (return Nothing) (fmap Just . newIORef) mj- HTTP.withManager settings $ \mgr ->- 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 = T.traverse readIORef . seshCookies+ -- | 'Session'-specific version of 'Network.Wreq.get'. get :: Session -> String -> IO (Response L.ByteString) get = getWith defaults@@ -125,7 +184,7 @@ -- | 'Session'-specific version of 'Network.Wreq.head_'. head_ :: Session -> String -> IO (Response ())-head_ = headWith defaults+head_ = headWith (defaults & Lens.redirects .~ 0) -- | 'Session'-specific version of 'Network.Wreq.options'. options :: Session -> String -> IO (Response ())@@ -139,6 +198,10 @@ delete :: Session -> String -> IO (Response L.ByteString) delete = deleteWith defaults +-- | 'Session'-specific version of 'Network.Wreq.customMethod'.+customMethod :: String -> Session -> String -> IO (Response L.ByteString)+customMethod = flip customMethodWith defaults+ -- | 'Session'-specific version of 'Network.Wreq.getWith'. getWith :: Options -> Session -> String -> IO (Response L.ByteString) getWith opts sesh url = run string sesh =<< prepareGet opts url@@ -166,24 +229,70 @@ deleteWith :: Options -> Session -> String -> IO (Response L.ByteString) deleteWith opts sesh url = run string sesh =<< prepareDelete opts url -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.customMethodWith'.+customMethodWith :: String -> Options -> Session -> String -> IO (Response L.ByteString)+customMethodWith method opts sesh url = run string sesh =<< prepareMethod methodBS opts url+ 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)+customPayloadMethodWith method opts sesh url payload =+ run string sesh =<< preparePayloadMethod methodBS opts url payload+ where+ methodBS = BC8.pack method++-- | '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) `fmap` T.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)
Network/Wreq/Types.hs view
@@ -18,10 +18,11 @@ Options(..) , Auth(..) , AWSAuthVersion(..)- , StatusChecker+ , ResponseChecker -- * Request payloads , Payload(..) , Postable(..)+ , Patchable(..) , Putable(..) -- ** URL-encoded forms , FormParam(..)@@ -38,10 +39,11 @@ ) where import Control.Lens ((&), (.~))-import Data.Aeson (Value, encode)+import Data.Aeson (Encoding, Value, encode)+import Data.Aeson.Encoding (encodingToLazyByteString) 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 +55,54 @@ 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]+-- 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 Encoding -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 patchPayload+instance Patchable Part+instance Patchable [Part]+instance Patchable [(S.ByteString, S.ByteString)]+instance Patchable (S.ByteString, S.ByteString)+instance Patchable [FormParam]+instance Patchable FormParam+instance Patchable Payload+instance Patchable S.ByteString+instance Patchable L.ByteString+instance Patchable Value+instance Patchable Encoding -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}) `fmap` 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 =@@ -99,6 +118,9 @@ instance Putable Value where putPayload = payload "application/json" . HTTP.RequestBodyLBS . encode +instance Putable Encoding where+ putPayload = payload "application/json" . HTTP.RequestBodyLBS .+ encodingToLazyByteString instance FormValue T.Text where renderFormValue = T.encodeUtf8
Setup.hs view
@@ -1,64 +1,33 @@--- I don't know who originally wrote this, but I picked it up from--- Edward Kmett's folds package.-+{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wall #-} module Main (main) where -import Data.List (nub)-import Data.Version (showVersion)-import Distribution.Package- (PackageName(PackageName), Package, PackageId, InstalledPackageId,- packageVersion, packageName)-import Distribution.PackageDescription (PackageDescription(), TestSuite(..))-import Distribution.Simple- (defaultMainWithHooks, UserHooks(..), simpleUserHooks)-import Distribution.Simple.BuildPaths (autogenModulesDir)-import Distribution.Simple.LocalBuildInfo- (withLibLBI, withTestLBI, LocalBuildInfo(),- ComponentLocalBuildInfo(componentPackageDeps))-import Distribution.Simple.Setup- (BuildFlags(buildVerbosity), Flag(..), fromFlag,- HaddockFlags(haddockDistPref))-import Distribution.Simple.Utils- (rewriteFile, createDirectoryIfMissingVerbose, copyFiles)-import Distribution.Text (display)-import Distribution.Verbosity (Verbosity, normal)-import System.FilePath ((</>))+#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 = defaultMainWithHooks simpleUserHooks- { buildHook = \pkg lbi hooks flags -> do- generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi- buildHook simpleUserHooks pkg lbi hooks flags- , postHaddock = \args flags pkg lbi -> do- copyFiles normal (haddockOutputDir flags pkg) []- postHaddock simpleUserHooks args flags pkg lbi- }+main = defaultMainWithDoctests "doctests" -haddockOutputDir :: Package p => HaddockFlags -> p -> FilePath-haddockOutputDir flags pkg = destDir where- baseDir = case haddockDistPref flags of- NoFlag -> "."- Flag x -> x- destDir = baseDir </> "doc" </> "html" </> display (packageName pkg)+#else -generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo- -> IO ()-generateBuildModule verbosity pkg lbi = do- let dir = autogenModulesDir lbi- createDirectoryIfMissingVerbose verbosity True dir- withLibLBI pkg lbi $ \_ libcfg -> do- withTestLBI pkg lbi $ \suite suitecfg -> do- rewriteFile (dir </> "Build_" ++ testName suite ++ ".hs") $ unlines- [ "module Build_" ++ testName suite ++ " where"- , "deps :: [String]"- , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg))- ]- where- formatdeps = map (formatone . snd)- formatone p = case packageName p of- PackageName n -> n ++ "-" ++ showVersion (packageVersion p)+#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 -testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo- -> [(InstalledPackageId, PackageId)]-testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys+import Distribution.Simple++main :: IO ()+main = defaultMain++#endif
TODO.md view
@@ -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
changelog.md view
@@ -1,5 +1,98 @@ -*- markdown -*- +2026-02-16 0.5.4.5++* Dependency update (memory -> ram)+++2026-02-16 0.5.4.4++* Small doc/dep updates+++2023-08-15 0.5.4.3++* Replace cryptonite(deprecated) with crypto+++2023-08-15 0.5.4.2++* Fix base bounds+++2023-07-31 0.5.4.1++* Cabal version change2023-07-31 0.5.4.1++* Cabal version change++2023-03-01 0.5.4.0++* Aeson 2.0 compatibility+* Add patch request+++2020-02-08 0.5.3.3++* GHC9 compatibility++2019-01-25 0.5.3.2++* Compatibility with http-client >= 0.6.0++2018-12-10 0.5.3.1++* Fix AWS-related things++2018-11-16 0.5.3.0++* Added Postable/Putable on aeson encoding++* Added better AWS signing for urls without region++2018-03-01 0.5.2.1++* Fixed some building issues with older versions++* Removed dependency on cryptohash, using cryptonite instead++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++* 8.2 GHC compatibility++2017-01-09 0.5.0.0++* Compatible with `http-client` >= 0.5++* This compatibility change required a small API change: `checkStatus`+ is now named `checkResponse` for compatibility with the+ `http-client` package+ 2015-05-10 0.4.0.0 * Compatible with GHC 7.10.
examples/UploadPaste.hs view
@@ -12,11 +12,12 @@ {-# LANGUAGE OverloadedStrings, TemplateHaskell #-} {-# OPTIONS_GHC -Wall #-} + import Control.Applicative import Control.Lens import Data.Char (toLower) import Data.Maybe (listToMaybe)-import Data.Monoid (mempty)+import Data.Monoid (mempty, (<>)) import Network.Wreq (FormParam((:=)), post, responseBody) import Network.Wreq.Types (FormValue(..)) import Options.Applicative as Opts
examples/wreq-examples.cabal view
@@ -20,7 +20,6 @@ aeson, base >= 4.5 && < 5, containers,- ghc-prim, lens, lens-aeson, text,@@ -58,7 +57,3 @@ source-repository head type: git location: https://github.com/bos/wreq--source-repository head- type: mercurial- location: https://bitbucket.org/bos/wreq
httpbin/HttpBin/Server.hs view
@@ -8,7 +8,8 @@ import Control.Applicative ((<$>)) import Control.Monad.IO.Class (liftIO) import Data.Aeson (Value(..), eitherDecode, object, toJSON)-import Data.Aeson.Encode.Pretty (Config(..), encodePretty')+import Data.Aeson.Encode.Pretty (Config(..), Indent(Spaces), defConfig, encodePretty')+import Data.Aeson.Key (fromText) import Data.ByteString.Char8 (pack) import Data.CaseInsensitive (original) import Data.Maybe (catMaybes, fromMaybe)@@ -69,7 +70,7 @@ listCookies = do cks <- rqCookies <$> getRequest- let cs = [(decodeUtf8 (cookieName c),+ let cs = [(fromText(decodeUtf8 (cookieName c)), toJSON (decodeUtf8 (cookieValue c))) | c <- cks] respond $ \obj -> return $ obj <> [("cookies", object cs)] @@ -133,7 +134,7 @@ writeJSON obj = do modifyResponse $ setContentType "application/json"- writeLBS . (<> "\n") . encodePretty' (Config 2 compare) . object $ obj+ writeLBS . (<> "\n") . encodePretty' defConfig { confIndent = Spaces 2, confCompare = compare } . object $ obj respond act = do req <- getRequest@@ -141,15 +142,15 @@ 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)] writeJSON =<< act ([ ("args", toJSON params) , ("headers", toJSON hdrs)- , ("origin", toJSON . decodeUtf8 . rqRemoteAddr $ req)+ , ("origin", toJSON . decodeUtf8 . rqClientAddr $ req) ] <> url) meths ms h = methods ms (path "" h)
tests/AWS.hs view
@@ -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"
tests/AWS/IAM.hs view
@@ -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::<acct>: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 _ =
− tests/DocTests.hs
@@ -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"
tests/UnitTests.hs view
@@ -8,18 +8,18 @@ import Control.Applicative ((<$>)) import Control.Concurrent (forkIO, killThread) import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)-import Control.Exception (Exception, toException)-import Control.Lens ((^.), (^?), (.~), (?~), (&))+import Control.Exception (Exception, throwIO)+import Control.Lens ((^.), (^?), (.~), (?~), (&), iso, ix, Traversal') import Control.Monad (unless, void)-import Data.Aeson-import Data.Aeson.Lens (key)+import Data.Aeson hiding (Options)+import Data.Aeson.Lens (key, AsValue, _Object) import Data.ByteString (ByteString) import Data.Char (toUpper) import Data.Maybe (isJust) import Data.Monoid ((<>)) import HttpBin.Server (serve)-import Network.HTTP.Client (HttpException(..))-import Network.HTTP.Types.Status (Status(Status), status200, status401)+import Network.HTTP.Client (HttpException(..), HttpExceptionContent(..))+import Network.HTTP.Types.Status (status200, status401) import Network.HTTP.Types.Version (http11) import Network.Wreq hiding (get, post, head_, put, options, delete,@@ -33,6 +33,9 @@ import Test.Framework.Providers.HUnit (testCase) import Test.HUnit (assertBool, assertEqual, assertFailure) import qualified Control.Exception as E+import qualified Data.Aeson.KeyMap as KM+import qualified Data.CaseInsensitive as CI+import qualified Data.HashMap.Strict as HMap import qualified Data.Text as T import qualified Network.Wreq.Session as Session import qualified Data.ByteString.Lazy as L@@ -41,13 +44,13 @@ data Verb = Verb { get :: String -> IO (Response L.ByteString) , getWith :: Options -> String -> IO (Response L.ByteString)- , post :: Postable a => String -> a -> IO (Response L.ByteString)- , postWith :: Postable a => Options -> String -> a+ , post :: forall a. Postable a => String -> a -> IO (Response L.ByteString)+ , postWith :: forall a. Postable a => Options -> String -> a -> IO (Response L.ByteString) , head_ :: String -> IO (Response ()) , headWith :: Options -> String -> IO (Response ())- , put :: Putable a => String -> a -> IO (Response L.ByteString)- , putWith :: Putable a => Options -> String -> a -> IO (Response L.ByteString)+ , put :: forall a. Putable a => String -> a -> IO (Response L.ByteString)+ , putWith :: forall a. Putable a => Options -> String -> a -> IO (Response L.ByteString) , options :: String -> IO (Response ()) , optionsWith :: Options -> String -> IO (Response ()) , delete :: String -> IO (Response L.ByteString)@@ -76,10 +79,20 @@ , delete = Session.delete s , deleteWith = flip Session.deleteWith s } +-- Helper aeson lens for case insensitive keys+-- The test 'snap' server unfortunately lowercases all headers, we have to be case-insensitive+-- when checking the returned header list.+cikey :: AsValue t => T.Text -> Traversal' t Value+cikey i = _Object . toInsensitive . ix (CI.mk i)+ where+ toInsensitive = iso toCi fromCi+ toCi = HMap.mapKeys CI.mk . KM.toHashMapText+ fromCi = KM.fromHashMapText . HMap.mapKeys CI.original+ basicGet Verb{..} site = do r <- get (site "/get") assertBool "GET request has User-Agent header" $- isJust (r ^. responseBody ^? key "headers" . key "User-Agent")+ isJust (r ^. responseBody ^? key "headers" . cikey "User-Agent") -- test the various lenses assertEqual "GET succeeds" status200 (r ^. responseStatus) assertEqual "GET succeeds 200" 200 (r ^. responseStatus . statusCode)@@ -96,7 +109,7 @@ assertEqual "POST succeeds" status200 (r ^. responseStatus) assertEqual "POST echoes input" (Just "wibble") (body ^? key "data") assertEqual "POST is binary" (Just "application/octet-stream")- (body ^? key "headers" . key "Content-Type")+ (body ^? key "headers" . cikey "Content-Type") multipartPost Verb{..} site = withSystemTempFile "foo.html" $ \name handle -> do@@ -139,14 +152,14 @@ r <- put (site "/put") $ toJSON solrAdd assertEqual "toJSON PUT request has correct Content-Type header" (Just "application/json")- (r ^. responseBody ^? key "headers" . key "Content-Type")+ (r ^. responseBody ^? key "headers" . cikey "Content-Type") byteStringPut Verb{..} site = do let opts = defaults & header "Content-Type" .~ ["application/json"] r <- putWith opts (site "/put") $ encode solrAdd assertEqual "ByteString PUT request has correct Content-Type header" (Just "application/json")- (r ^. responseBody ^? key "headers" . key "Content-Type")+ (r ^. responseBody ^? key "headers" . cikey "Content-Type") basicDelete Verb{..} site = do r <- delete (site "/delete")@@ -155,18 +168,21 @@ throwsStatusCode Verb{..} site = assertThrows "404 causes exception to be thrown" inspect $ head_ (site "/status/404")- where inspect e = case e of- StatusCodeException _ _ _ -> return ()+ where inspect (HttpExceptionRequest _ e) = case e of+ StatusCodeException _ _ -> return () _ -> assertFailure "unexpected exception thrown"+ inspect _ = assertFailure "unexpected exception thrown" getBasicAuth Verb{..} site = do let opts = defaults & auth ?~ basicAuth "user" "passwd" r <- getWith opts (site "/basic-auth/user/passwd") assertEqual "basic auth GET succeeds" status200 (r ^. responseStatus)- let inspect e = case e of- StatusCodeException status _ _ ->+ let inspect (HttpExceptionRequest _ e) = case e of+ StatusCodeException resp _ -> assertEqual "basic auth failed GET gives 401"- status401 status+ status401 (resp ^. responseStatus)+ inspect _ = assertFailure "unexpected exception thrown"+ assertThrows "basic auth GET fails if password is bad" inspect $ getWith opts (site "/basic-auth/user/asswd") @@ -175,10 +191,11 @@ r <- getWith opts (site $ "/oauth2/" <> kind <> "/token1234") assertEqual ("oauth2 " <> kind <> " GET succeeds") status200 (r ^. responseStatus)- let inspect e = case e of- StatusCodeException status _ _ ->+ let inspect (HttpExceptionRequest _ e) = case e of+ StatusCodeException resp _ -> assertEqual ("oauth2 " <> kind <> " failed GET gives 401")- status401 status+ status401 (resp ^. responseStatus)+ inspect _ = assertFailure "unexpected exception thrown" assertThrows ("oauth2 " <> kind <> " GET fails if token is bad") inspect $ getWith opts (site $ "/oauth2/" <> kind <> "/token123") @@ -209,10 +226,10 @@ r <- getWith opts (site "/get") assertEqual "extra header set correctly" (Just "bar")- (r ^. responseBody ^? key "headers" . key "X-Wibble")+ (r ^. responseBody ^? key "headers" . cikey "X-Wibble") getCheckStatus Verb {..} site = do- let opts = defaults & checkStatus .~ (Just customCs)+ let opts = defaults & checkResponse .~ Just customRc r <- getWith opts (site "/status/404") assertThrows "Non 404 throws error" inspect $ getWith opts (site "/get")@@ -220,36 +237,43 @@ 404 (r ^. responseStatus . statusCode) where- customCs (Status 404 _) _ _ = Nothing- customCs s h cj = Just . toException . StatusCodeException s h $ cj+ customRc :: ResponseChecker+ customRc _ resp+ | resp ^. responseStatus . statusCode == 404 = return ()+ customRc req resp = throwIO $ HttpExceptionRequest req (StatusCodeException (void resp) "") - inspect e = case e of- (StatusCodeException (Status sc _) _ _) ->- assertEqual "200 Status Error" sc 200+ inspect (HttpExceptionRequest _ e) = case e of+ (StatusCodeException resp _) ->+ assertEqual "200 Status Error" (resp ^. responseStatus) status200+ inspect _ = assertFailure "unexpected exception thrown" + getGzip Verb{..} site = do r <- get (site "/gzip") assertEqual "gzip decoded for us" (Just (Bool True)) (r ^. responseBody ^? key "gzipped") -headRedirect Verb{..} site =+headRedirect Verb{..} site = do assertThrows "HEAD of redirect throws exception" inspect $ head_ (site "/redirect/3")- where inspect e = case e of- StatusCodeException status _ _ ->- let code = status ^. statusCode+ where inspect (HttpExceptionRequest _ e) = case e of+ StatusCodeException resp _ ->+ let code = resp ^. responseStatus . statusCode in assertBool "code is redirect" (code >= 300 && code < 400)+ inspect _ = assertFailure "unexpected exception thrown" + redirectOverflow Verb{..} site = assertThrows "GET with too many redirects throws exception" inspect $ getWith (defaults & redirects .~ 3) (site "/redirect/5")- where inspect e = case e of TooManyRedirects _ -> return ()+ where inspect (HttpExceptionRequest _ e) = case e of TooManyRedirects _ -> return ()+ inspect _ = assertFailure "unexpected exception thrown" invalidURL Verb{..} _site = do let noProto (InvalidUrlException _ _) = return () assertThrows "exception if no protocol" noProto (get "wheeee")- let noHost (InvalidDestinationHost _) = return ()+ let noHost (HttpExceptionRequest _ (InvalidDestinationHost _)) = return () assertThrows "exception if no host" noHost (get "http://") funkyScheme Verb{..} site = do@@ -263,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)@@ -342,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@@ -367,8 +393,8 @@ let go n | n >= 100 = putMVar started Nothing | otherwise = do let port = 8000 + n- startedUp p = putMVar started (Just ("http://localhost:" <> p))- mkCfg = return . setBind ("localhost") . setPort port .+ startedUp p = putMVar started (Just ("http://0.0.0.0:" <> p))+ mkCfg = return . setBind ("0.0.0.0") . setPort port . setVerbose False . setStartupHook (const (startedUp (show port))) serve mkCfg `E.catch` \(_::E.IOException) -> go (n+1)@@ -378,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)] <>
+ tests/doctests.hs view
@@ -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
wreq.cabal view
@@ -1,5 +1,6 @@+cabal-version: 3.0 name: wreq-version: 0.4.1.0+version: 0.5.4.5 synopsis: An easy-to-use HTTP client library. description: .@@ -28,16 +29,16 @@ . * Early TLS support via the tls package homepage: http://www.serpentine.com/wreq-bug-reports: https://github.com/bos/wreq/issues-license: BSD3+bug-reports: https://github.com/haskell/wreq/issues+license: BSD-3-Clause license-file: LICENSE.md author: Bryan O'Sullivan <bos@serpentine.com>-maintainer: bos@serpentine.com+maintainer: Ondřej Palkovský copyright: 2014 Bryan O'Sullivan category: Web build-type: Custom-cabal-version: >=1.10-extra-source-files:+tested-with: GHC ==9.2.8 || ==9.4.8 || ==9.6.4 || ==9.10.3+extra-doc-files: README.md TODO.md changelog.md@@ -47,6 +48,10 @@ www/*.md www/Makefile +custom-setup+ setup-depends:+ base < 5, Cabal < 4.0, cabal-doctest >=1.0.2 && <1.1+ -- disable doctests with -f-doctest flag doctest description: enable doctest tests@@ -93,31 +98,32 @@ Network.Wreq.Lens.Machinery Network.Wreq.Lens.TH Paths_wreq+ autogen-modules:+ Paths_wreq build-depends: psqueues >= 0.2, aeson >= 0.7.0.3, attoparsec >= 0.11.1.0,- authenticate-oauth == 1.5.*,- base >= 4.5 && < 5,+ authenticate-oauth >= 1.5,+ base >= 4.13 && < 5, base16-bytestring,- byteable, bytestring >= 0.9, case-insensitive, containers,- cryptohash,+ crypton >= 1.1, exceptions >= 0.5,- ghc-prim, hashable,- http-client >= 0.4.6,- http-client-tls >= 0.2,+ http-client >= 0.6,+ http-client-tls >= 0.3.3, http-types >= 0.8, lens >= 4.5, lens-aeson,+ ram, mime-types, time-locale-compat, template-haskell, text,- time,+ time >= 1.5, unordered-containers -- A convenient server for testing locally, or if httpbin.org is down.@@ -134,14 +140,14 @@ buildable: False else build-depends:- aeson >= 0.7,- aeson-pretty >= 0.7.1,- base >= 4.5 && < 5,+ aeson >= 2.0,+ aeson-pretty >= 0.8.0,+ base >= 4.13 && < 5, base64-bytestring, bytestring, case-insensitive, containers,- snap-core,+ snap-core >= 1.0.0.0, snap-server >= 0.9.4.4, text, time,@@ -160,6 +166,7 @@ other-modules: Properties.Store UnitTests+ HttpBin.Server if flag(aws) cpp-options: -DAWS_TESTS@@ -171,15 +178,12 @@ AWS.S3 AWS.SQS - if flag(aws)- build-depends: base >= 4.7 && < 5- build-depends: HUnit, QuickCheck >= 2.7, aeson,- aeson-pretty >= 0.7.1,- base >= 4.5 && < 5,+ aeson-pretty >= 0.8.0,+ base >= 4.13 && < 5, base64-bytestring, bytestring, case-insensitive,@@ -190,7 +194,7 @@ lens, lens-aeson, network-info,- snap-core,+ snap-core >= 1.0.0.0, snap-server >= 0.9.4.4, temporary, test-framework,@@ -199,33 +203,30 @@ text, time, transformers,+ unordered-containers, unix-compat, uuid, 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 else build-depends:- base >= 4.5 && < 5,+ base >= 4.13 && < 5, directory, doctest, filepath source-repository head type: git- location: https://github.com/bos/wreq--source-repository head- type: mercurial- location: https://bitbucket.org/bos/wreq+ location: https://github.com/haskell/wreq
www/tutorial.md view
@@ -435,7 +435,11 @@ ~~~~ {.haskell} ghci> r <- get "http://httpbin.org/basic-auth/user/pass"-*** Exception: StatusCodeException (Status {statusCode = 401, {-...-}+*** Exception: HttpExceptionRequest Request { ... }+ (StatusCodeException (Response {+ responseStatus = Status {statusCode = 401, {-...-} }+ , {- ... -}+ }), "..." ) ~~~~ If we then supply a username and password, our request will succeed.@@ -516,7 +520,11 @@ ~~~~ {.haskell} h> r <- get "http://httpbin.org/wibblesticks"-*** Exception: StatusCodeException (Status {statusCode = 404, {-...-}+*** Exception: HttpExceptionRequest Request { ... }+ (StatusCodeException (Response {+ responseStatus = Status {statusCode = 404, {-...-} }+ , {- ... -}+ }), "..." ) ~~~~ Here's a simple example of how we can respond to one kind of error: a@@ -526,17 +534,19 @@ ~~~~ {.haskell} import Control.Exception as E import Control.Lens-import Network.HTTP.Client+import Network.HTTP.Client (HttpException (HttpExceptionRequest),+ HttpExceptionContent (StatusCodeException)) import Network.Wreq getAuth url myauth = get url `E.catch` handler where- handler e@(StatusCodeException s _ _)- | s ^. statusCode == 401 = getWith authopts authurl- | otherwise = throwIO e- where authopts = defaults & auth .~ myauth- -- switch to TLS when we use auth- authurl = "https" ++ dropWhile (/=':') url+ handler e@(HttpExceptionRequest _ (StatusCodeException r _))+ | r ^. responseStatus . statusCode == 401 = getWith authopts authurl+ | otherwise = throwIO e+ handler e = throwIO e+ authopts = defaults & auth ?~ myauth+ -- switch to TLS when we use auth+ authurl = "https" ++ dropWhile (/=':') url ~~~~ (A "real world" version would remember which URLs required@@ -573,7 +583,8 @@ import qualified Network.Wreq.Session as S main :: IO ()-main = S.withSession $ \sess -> do+main = do+ sess <- S.newSession -- First request: tell the server to set a cookie S.get sess "http://httpbin.org/cookies/set?name=hi" @@ -589,8 +600,7 @@ module qualified, and we'll identify its functions by prefixing them with "`S.`". -* To create a `Session`, we use `S.withSession`. It calls our code- with `sess`, the `Session` value we'll use.+* To create a `Session`, we use `S.newSession`. * Instead of `get` and `post`, we call the `Session`-specific versions, [`S.get`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq-Session.html#v:get) and [`S.post`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq-Session.html#v:post), and pass `sess` to each of them.