diff --git a/Network/Wreq.hs b/Network/Wreq.hs --- a/Network/Wreq.hs +++ b/Network/Wreq.hs @@ -57,12 +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 @@ -79,7 +89,7 @@ , Lens.params , Lens.cookie , Lens.cookies - , Lens.checkStatus + , Lens.checkResponse -- ** Authentication -- $auth @@ -87,9 +97,12 @@ , AWSAuthVersion(..) , Lens.auth , basicAuth + , oauth1Auth , oauth2Bearer , oauth2Token , awsAuth + , awsFullAuth + , awsSessionTokenAuth -- ** Proxy settings , Proxy(Proxy) , Lens.proxy @@ -128,6 +141,10 @@ , Lens.Status , Lens.statusCode , Lens.statusMessage + , HistoriedResponse + , Lens.hrFinalRequest + , Lens.hrFinalResponse + , Lens.hrRedirects -- ** Link headers , Lens.Link , Lens.linkURL @@ -158,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) @@ -188,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'. @@ -216,8 +235,8 @@ -- @ -- -- >>> r <- post "http://httpbin.org/post" (toJSON [1,2,3]) --- >>> r ^? responseBody . key "json" --- Just (Array (fromList [Number 1.0,Number 2.0,Number 3.0])) +-- >>> r ^? responseBody . key "json" . nth 2 +-- Just (Number 3.0) post :: Postable a => String -> a -> IO (Response L.ByteString) post url payload = postWith defaults url payload @@ -275,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: @@ -331,6 +358,7 @@ -- | Issue a custom-method request -- -- Example: +-- -- @ -- 'customMethod' \"PATCH\" \"http:\/\/httpbin.org\/patch\" -- @ @@ -359,6 +387,65 @@ 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) + +customPayloadMethod method url payload = + customPayloadMethodWith method defaults url payload + +-- | 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 @@ -409,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) @@ -460,6 +548,16 @@ -> Auth basicAuth = BasicAuth +-- | OAuth1 authentication. This consists of a consumer token, +-- a consumer secret, a token and a token secret +oauth1Auth :: S.ByteString -- ^ Consumer token + -> S.ByteString -- ^ Consumer secret + -> S.ByteString -- ^ OAuth token + -> S.ByteString -- ^ OAuth token secret + -> Auth +oauth1Auth = OAuth1 + + -- | An OAuth2 bearer token. This is treated by many services as the -- equivalent of a username and password. -- @@ -494,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: @@ -574,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 diff --git a/Network/Wreq/Cache.hs b/Network/Wreq/Cache.hs --- a/Network/Wreq/Cache.hs +++ b/Network/Wreq/Cache.hs @@ -1,5 +1,5 @@ {-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, - OverloadedStrings, RecordWildCards #-} + FlexibleContexts, OverloadedStrings, RecordWildCards #-} module Network.Wreq.Cache ( @@ -22,14 +22,14 @@ 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) import Network.HTTP.Types (HeaderName, Method) import Network.Wreq.Internal.Lens import Network.Wreq.Internal.Types import Network.Wreq.Lens -import System.Locale (defaultTimeLocale) import qualified Data.ByteString.Char8 as B import qualified Data.HashSet as HashSet import qualified Data.IntSet as IntSet @@ -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) diff --git a/Network/Wreq/Cache/Store.hs b/Network/Wreq/Cache/Store.hs --- a/Network/Wreq/Cache/Store.hs +++ b/Network/Wreq/Cache/Store.hs @@ -15,8 +15,7 @@ import Data.Int (Int64) import Data.List (foldl') import Prelude hiding (lookup, map) -import qualified Data.HashMap.Lazy as HM -import qualified Data.PSQueue as PSQ +import qualified Data.HashPSQ as HashPSQ type Epoch = Int64 @@ -24,8 +23,7 @@ capacity :: {-# UNPACK #-} !Int , size :: {-# UNPACK #-} !Int , epoch :: {-# UNPACK #-} !Epoch - , lru :: !(PSQ.PSQ k Epoch) - , map :: !(HM.HashMap k v) + , psq :: !(HashPSQ.HashPSQ k Epoch v) } instance (Show k, Show v, Ord k, Hashable k) => Show (Store k v) where @@ -34,43 +32,29 @@ empty :: Ord k => Int -> Store k v empty cap | cap <= 0 = error "empty: invalid capacity" - | otherwise = Store cap 0 0 PSQ.empty HM.empty + | otherwise = Store cap 0 0 HashPSQ.empty {-# INLINABLE empty #-} insert :: (Ord k, Hashable k) => k -> v -> Store k v -> Store k v -insert k v st@Store{..} - | size < capacity || present = - st { size = if present then size else size + 1 - , epoch = epoch + 1 - , lru = PSQ.insert k epoch lru - , map = HM.insert k v map - } - | otherwise = - let Just (mink PSQ.:-> _, lru0) = PSQ.minView lru - in st { epoch = epoch + 1 - , lru = PSQ.insert k epoch lru0 - , map = HM.insert k v $ if mink == k - then map - else HM.delete mink map - } - where present = k `HM.member` map +insert k v st@Store{..} = case HashPSQ.insertView k epoch v psq of + (Just (_, _), psq0) -> st {epoch = epoch + 1, psq = psq0} + (Nothing, psq0) + | size < capacity -> st {size = size + 1, epoch = epoch + 1, psq = psq0} + | otherwise -> st {epoch = epoch + 1, psq = HashPSQ.deleteMin psq0} {-# INLINABLE insert #-} lookup :: (Ord k, Hashable k) => k -> Store k v -> Maybe (v, Store k v) -lookup k st@Store{..} = do - v <- HM.lookup k map - let !st' = st { epoch = epoch + 1, lru = PSQ.insert k epoch lru } - return (v, st') +lookup k st@Store{..} = case HashPSQ.alter tick k psq of + (Nothing, _) -> Nothing + (Just v, psq0) -> Just (v, st { epoch = epoch + 1, psq = psq0 }) + where tick Nothing = (Nothing, Nothing) + tick (Just (_, v)) = (Just v, Just (epoch, v)) {-# INLINABLE lookup #-} delete :: (Ord k, Hashable k) => k -> Store k v -> Store k v -delete k st@Store{..} - | k `HM.member` map = - st { size = size - 1 - , lru = PSQ.delete k lru - , map = HM.delete k map - } - | otherwise = st +delete k st@Store{..} = case HashPSQ.deleteView k psq of + Nothing -> st + Just (_, _, psq0) -> st {size = size - 1, psq = psq0} {-# INLINABLE delete #-} fromList :: (Ord k, Hashable k) => Int -> [(k, v)] -> Store k v @@ -78,6 +62,5 @@ {-# INLINABLE fromList #-} toList :: (Ord k, Hashable k) => Store k v -> [(k, v)] -toList Store{..} = [(k,v) | (k PSQ.:-> _) <- PSQ.toList lru, - let v = map HM.! k] +toList Store{..} = [(k,v) | (k, _, v) <- HashPSQ.toList psq] {-# INLINABLE toList #-} diff --git a/Network/Wreq/Internal.hs b/Network/Wreq/Internal.hs --- a/Network/Wreq/Internal.hs +++ b/Network/Wreq/Internal.hs @@ -12,26 +12,30 @@ , prepareGet , preparePost , runRead + , runReadHistory , prepareHead , runIgnore , prepareOptions , preparePut + , preparePatch , prepareDelete , prepareMethod + , preparePayloadMethod ) where 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 @@ -39,8 +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.Lens as Lens hiding (checkStatus) +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 (checkResponse) -- This mess allows this module to continue to load during interactive -- development in ghci :-( @@ -63,8 +68,8 @@ , headers = [("User-Agent", userAgent)] , params = [] , redirects = 10 - , cookies = HTTP.createCookieJar [] - , checkStatus = Nothing + , cookies = Just (HTTP.createCookieJar []) + , checkResponse = Nothing } where userAgent = "haskell wreq-" <> Char8.pack (showVersion version) @@ -85,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 @@ -99,26 +110,33 @@ 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 .~ Just (cookies 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 + setQuery :: Options -> Request -> Request setQuery opts = case params opts of @@ -134,16 +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 @@ -151,14 +173,22 @@ 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) <$> prepare (return . (Lens.method .~ method)) opts url +preparePayloadMethod :: Postable a => HTTP.Method -> Options -> String -> a + -> IO Req +preparePayloadMethod method opts url payload = Req (manager opts) <$> + prepare (fmap (Lens.method .~ method) . postPayload payload) opts url + prepareHead :: Options -> String -> IO Req prepareHead = prepareMethod HTTP.methodHead @@ -170,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 diff --git a/Network/Wreq/Internal/AWS.hs b/Network/Wreq/Internal/AWS.hs --- a/Network/Wreq/Internal/AWS.hs +++ b/Network/Wreq/Internal/AWS.hs @@ -3,30 +3,29 @@ module Network.Wreq.Internal.AWS ( - signRequest - , addTmpPayloadHashHeader + 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.Maybe (fromJust) import Data.Monoid ((<>)) import Data.Time.Clock (getCurrentTime) import Data.Time.Format (formatTime) +import Data.Time.Locale.Compat (defaultTimeLocale) import Data.Time.LocalTime (utc, utcToLocalTime) import Network.HTTP.Types (parseSimpleQuery, urlEncode) import Network.Wreq.Internal.Lens import Network.Wreq.Internal.Types (AWSAuthVersion(..)) -import System.Locale (defaultTimeLocale) -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.CaseInsensitive as CI (CI, original) +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 @@ -41,52 +40,55 @@ -- with and without Bucket Authorization enabled -- ("Runscope-Bucket-Auth"). -- --- Q: how do we get the payload hash to the signRequest function? --- --- A: we use a (temporary) HTTP header to 'tunnel' the payload hash to --- the signing function. For POST and PUT requests, the --- Network.Wreq.Types.payload function adds a HTTP header (name --- defined in 'tmpPayloadHashHeader'). The --- Network.Wreq.Internal.AWS.signRequest function reads the value of --- the header and then removes it from the request. For GET, HEAD, --- and (currently) DELETE that carry no body, we use "" per AWS --- documentation Item 6: "use empty string" in --- http://docs.aws.amazon.com/general/latest/gr/sigv4-create-canonical-request.html - -- 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"] = - fromJust . lookup tmpPayloadHashHeader $ request ^. requestHeaders - | otherwise = HEX.encode $ SHA256.hash "" + | request ^. method `elem` ["POST", "PUT"] = payloadHash req + | otherwise = hexSha256Hash "" -- add common v4 signing headers, service specific headers, and -- drop tmp header and Runscope-Bucket-Auth header (if present). req = request & requestHeaders %~ (([ ("host", noRunscopeHost) , ("x-amz-date", ts)] ++ [("x-amz-content-sha256", hashedPayload) | service == "s3"]) ++) - . deleteKey tmpPayloadHashHeader -- drop tmp header -- 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) @@ -103,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) & @@ -129,28 +131,29 @@ 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) - -addTmpPayloadHashHeader :: Request -> IO Request -addTmpPayloadHashHeader req = do - let payloadHash = case HTTP.requestBody req of - HTTP.RequestBodyBS bs -> - HEX.encode $ SHA256.hash bs - HTTP.RequestBodyLBS lbs -> - HEX.encode $ SHA256.hashlazy lbs - _ -> error "addTmpPayloadHashHeader: unexpected request body type" - return $ setHeader tmpPayloadHashHeader payloadHash req + hmac' :: S.ByteString -> S.ByteString -> S.ByteString + hmac' s k = convert (hmacGetDigest h) + where h = hmac k s :: (HMAC CT.SHA256) -tmpPayloadHashHeader :: CI.CI S.ByteString -tmpPayloadHashHeader = "X-LOCAL-CONTENT-HASH-HEADER-746352" - -- 746352 to reduce collision risk +payloadHash :: Request -> S.ByteString +payloadHash req = + case HTTP.requestBody req of + HTTP.RequestBodyBS bs -> hexSha256Hash bs + HTTP.RequestBodyLBS lbs -> hexSha256HashLazy lbs + _ -> error "addTmpPayloadHashHeader: unexpected request body type" -- Per AWS documentation at: -- http://docs.aws.amazon.com/general/latest/gr/rande.html -- For example: "dynamodb.us-east-1.amazonaws.com" -> ("dynamodb", "us-east-1") serviceAndRegion :: S.ByteString -> (S.ByteString, S.ByteString) serviceAndRegion endpoint + -- For s3, check .s3..., i.e. virtual-host style access + | ".s3.amazonaws.com" `S.isSuffixOf` endpoint = -- vhost style, classic + ("s3", "us-east-1") + | ".s3-external-1.amazonaws.com" `S.isSuffixOf` endpoint = + ("s3", "us-east-1") + | ".s3-" `S.isInfixOf` endpoint = -- vhost style, regional + ("s3", regionInS3VHost endpoint) -- For s3, use / style access, as opposed to -- .s3... in the hostname. | endpoint `elem` ["s3.amazonaws.com", "s3-external-1.amazonaws.com"] = @@ -160,6 +163,14 @@ let region = S.takeWhile (/= '.') $ S.drop 3 endpoint -- drop "s3-" in ("s3", region) -- 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 = @@ -168,8 +179,14 @@ where svc = servicePrefix '.' endpoint servicePrefix c = S.map toLower . S.takeWhile (/= c) - noRegion = HashSet.fromList ["iam", "sts", "importexport", "route53", - "cloudfront"] + regionInS3VHost s = + S.takeWhile (/= '.') -- "eu-west-1" + . S.reverse -- "eu-west-1.amazonaws.com" + . fst -- "moc.swanozama.1-tsew-ue" + . S.breakSubstring (S.pack "-3s.") + . S.reverse + $ s -- johnsmith.eu.s3-eu-west-1.amazonaws.com + noRegion = HashSet.fromList ["iam", "importexport", "route53", "cloudfront"] -- If the hostname doesn't end in runscope.net, return the original. -- For a hostname that includes runscope.net: @@ -185,5 +202,5 @@ | otherwise = hostname where p1 "-" = "." p1 other = other - p2 "--" = "-" - p2 other = other + p2 "--" = "-" + p2 other = other 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 @@ -20,12 +21,12 @@ , decompress , redirectCount , responseTimeout - , checkStatus - , getConnectionWrapper + , checkResponse , cookieJar , seshCookies , seshManager , seshRun + , seshRunHistory -- * Useful functions , assoc , assoc2 diff --git a/Network/Wreq/Internal/OAuth1.hs b/Network/Wreq/Internal/OAuth1.hs new file mode 100644 --- /dev/null +++ b/Network/Wreq/Internal/OAuth1.hs @@ -0,0 +1,12 @@ +module Network.Wreq.Internal.OAuth1 (signRequest) where + +import Network.HTTP.Client (Request(..)) +import Web.Authenticate.OAuth ( signOAuth, newOAuth, oauthConsumerKey + , oauthConsumerSecret, newCredential) +import qualified Data.ByteString as S + +signRequest :: S.ByteString -> S.ByteString -> S.ByteString -> S.ByteString -> Request -> IO Request +signRequest consumerToken consumerSecret token tokenSecret = signOAuth app creds + where + app = newOAuth { oauthConsumerKey = consumerToken, oauthConsumerSecret = consumerSecret } + creds = newCredential token tokenSecret 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 @@ -19,9 +19,11 @@ , Mgr , Auth(..) , AWSAuthVersion(..) + , ResponseChecker -- * Request payloads , Payload(..) , Postable(..) + , Patchable(..) , Putable(..) -- ** URL-encoded forms , FormParam(..) @@ -37,21 +39,22 @@ -- * Sessions , Session(..) , Run + , RunHistory , Body(..) -- * Caches , CacheEntry(..) ) where -import Control.Concurrent.MVar (MVar) -import Control.Exception (Exception, SomeException) +import Control.Exception (Exception) +import Data.IORef (IORef) import Data.Monoid ((<>), mconcat) import Data.Text (Text) import Data.Time.Clock (UTCTime) import Data.Typeable (Typeable) import Network.HTTP.Client (CookieJar, Manager, ManagerSettings, Request, - RequestBody, destroyCookieJar) + 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 @@ -140,7 +143,7 @@ --let opts = 'Network.Wreq.defaults' { 'redirects' = 3 } --'Network.Wreq.getWith' opts \"http:\/\/httpbin.org\/redirect/5\" -- @ - , cookies :: CookieJar + , cookies :: Maybe CookieJar -- ^ Cookies to set when issuing requests. -- -- /Note/: when issuing HTTP requests using 'Options'-based @@ -149,15 +152,19 @@ -- 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 (Status -> ResponseHeaders -> CookieJar -> Maybe SomeException) - -- ^ Function that checks the status code and potentially returns an exception. + , checkResponse :: Maybe ResponseChecker + -- ^ Function that checks the status code and potentially returns an + -- exception. -- -- This defaults to 'Nothing', which will just use the default of - -- 'Network.HTTP.Client.Request' which throws a 'StatusException' if the status - -- is not 2XX. + -- 'Network.HTTP.Client.Request' which throws a 'StatusException' if + -- the status is not 2XX. } deriving (Typeable) +-- | A function that checks the result of a HTTP request and +-- potentially throw an exception. +type ResponseChecker = Request -> Response HTTP.BodyReader -> IO () + -- | Supported authentication types. -- -- Do not use HTTP authentication unless you are using TLS encryption. @@ -174,9 +181,15 @@ -- 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 deriving (Eq, Show, Typeable) data AWSAuthVersion = AWSv4 @@ -184,25 +197,36 @@ deriving (Eq, Show) instance Show Options where - show (Options{..}) = concat ["Options { " - , "manager = ", case manager of - Left _ -> "Left _" - Right _ -> "Right _" - , ", proxy = ", show proxy - , ", auth = ", show auth - , ", headers = ", show headers - , ", params = ", show params - , ", redirects = ", show redirects - , ", cookies = ", show (destroyCookieJar cookies) - , " }" - ] + show (Options{..}) = concat [ + "Options { " + , "manager = ", case manager of + Left _ -> "Left _" + Right _ -> "Right _" + , ", proxy = ", show proxy + , ", auth = ", show auth + , ", headers = ", show headers + , ", params = ", show params + , ", redirects = ", show redirects + , ", cookies = ", show cookies + , " }" + ] -- | 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 @@ -279,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 :: MVar CookieJar + 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 @@ -45,7 +45,8 @@ , params , cookie , cookies - , checkStatus + , ResponseChecker + , checkResponse -- ** Proxy setup , Proxy @@ -77,6 +78,12 @@ , responseStatus , responseVersion + -- * HistoriedResponse + , HistoriedResponse + , hrFinalResponse + , hrFinalRequest + , hrRedirects + -- ** Status , Status , statusCode @@ -100,49 +107,45 @@ ) where import Control.Applicative ((<*)) -import Control.Exception (SomeException) 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) +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 (Status -> ResponseHeaders -> CookieJar -> Maybe SomeException)) -checkStatus = TH.checkStatus +checkResponse :: Lens' Options (Maybe ResponseChecker) +checkResponse = TH.checkResponse -- | A traversal onto the cookie with the given name, if one exists. -- @@ -240,7 +243,7 @@ cookie = TH.cookie -- | A lens onto all cookies. -cookies :: Lens' Options CookieJar +cookies :: Lens' Options (Maybe CookieJar) cookies = TH.cookies -- | A lens onto the name of a cookie. @@ -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. 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 @@ -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 @@ -95,7 +101,7 @@ -- N.B. This is an "illegal" traversal because we can change its cookie_name. cookie :: ByteString -> Traversal' Types.Options HTTP.Cookie -cookie name = cookies . _CookieJar . traverse . filtered +cookie name = cookies . _Just . _CookieJar . traverse . filtered (\c -> HTTP.cookie_name c == name) responseCookie :: ByteString -> Fold (HTTP.Response body) HTTP.Cookie diff --git a/Network/Wreq/Session.hs b/Network/Wreq/Session.hs --- a/Network/Wreq/Session.hs +++ b/Network/Wreq/Session.hs @@ -1,7 +1,7 @@ {-# LANGUAGE RankNTypes, RecordWildCards #-} -- | --- Module : Network.Wreq +-- Module : Network.Wreq.Session -- Copyright : (c) 2014 Bryan O'Sullivan -- -- License : BSD-style @@ -17,7 +17,8 @@ -- being used. -- -- * Transparent cookie management. Any cookies set by the server --- persist from one request to the next. +-- persist from one request to the next. (Bypass this overhead +-- using 'newAPISession'.) -- -- -- This module is designed to be used alongside the "Network.Wreq" @@ -27,21 +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 --- subsequent functions. +-- 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 'newAPISession'. -- --- Note the use of a qualified import statement, so that we can refer --- unambiguously to the 'Session'-specific implementation of HTTP GET. +-- 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 @@ -49,6 +66,7 @@ , options , put , delete + , customMethod -- ** Configurable verbs , getWith , postWith @@ -56,37 +74,106 @@ , optionsWith , putWith , deleteWith + , customMethodWith + , customPayloadMethodWith + , customHistoriedMethodWith + , customHistoriedPayloadMethodWith -- * Extending a session , Lens.seshRun ) where -import Control.Concurrent.MVar (modifyMVar, newMVar) -import Control.Lens ((&), (?~), (^.)) -import Network.Wreq (Options, Response) +import Control.Lens ((&), (.~)) +import Data.Foldable (forM_) +import Data.IORef (newIORef, readIORef, writeIORef) +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 as Wreq 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. +-- +-- 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, using the given manager settings. +-- | 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 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 settings act = do - mv <- newMVar $ HTTP.createCookieJar [] - HTTP.withManager settings $ \mgr -> - act Session { seshCookies = mv - , seshManager = mgr - , seshRun = runWith - } +withSessionWith = withSessionControl (Just (HTTP.createCookieJar [])) +{-# DEPRECATED withSessionWith "Use newSessionControl instead." #-} +-- | Create a session, using the given cookie jar and manager settings. +withSessionControl :: Maybe HTTP.CookieJar + -- ^ If 'Nothing' is specified, no cookie management + -- will be performed. + -> HTTP.ManagerSettings + -> (Session -> IO a) -> IO a +withSessionControl mj settings act = do + 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 @@ -97,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 ()) @@ -111,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 @@ -138,20 +229,70 @@ deleteWith :: Options -> Session -> String -> IO (Response L.ByteString) deleteWith opts sesh url = run string sesh =<< prepareDelete opts url +-- | '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 (extract resp)) + return resp + runWith :: Session -> Run Body -> Run Body -runWith Session{..} act (Req _ req) = - modifyMVar seshCookies $ \cj -> do - resp <- act (Req (Right seshManager) (req & Lens.cookieJar ?~ cj)) - return (resp ^. Wreq.responseCookieJar, resp) +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 @@ -18,9 +18,11 @@ Options(..) , Auth(..) , AWSAuthVersion(..) + , ResponseChecker -- * Request payloads , Payload(..) , Postable(..) + , Patchable(..) , Putable(..) -- ** URL-encoded forms , FormParam(..) @@ -37,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 @@ -51,39 +54,55 @@ import qualified Data.Text.Lazy.Builder as TL import qualified Network.HTTP.Client as HTTP import qualified Network.Wreq.Internal.Lens as Lens -import qualified Network.Wreq.Internal.AWS as AWS (addTmpPayloadHashHeader) -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 @@ -141,6 +163,6 @@ renderFormValue Nothing = "" payload :: S.ByteString -> HTTP.RequestBody -> Request -> IO Request -payload ct body req = AWS.addTmpPayloadHashHeader $ req - & Lens.maybeSetHeader "Content-Type" ct - & Lens.requestBody .~ body +payload ct body req = + return $ req & Lens.maybeSetHeader "Content-Type" ct + & Lens.requestBody .~ body diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# wreq: a Haskell web client library +# wreq: a Haskell web client library [![Build Status](https://travis-ci.org/bos/wreq.svg)](https://travis-ci.org/bos/wreq) `wreq` is a library that makes HTTP client programming in Haskell easy. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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 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,9 +1,119 @@ -*- 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. + +* New withAPISession and withSessionControl functions make talking to + REST services more efficient. + +* Added support for AWS S3 virtual-host style URLs. + +* Added signing support for region specific calls to the AWS Security + Token Service (AWS STS). + +* The introduction of AWS support accidentally introduced unwanted AWS + headers and computation into all requests. This has been fixed. + + 2014-12-11 0.3.0.1 * Bump lower bound on http-client to 0.3.0.1 + 2014-12-02 0.3.0.0 * Support for Amazon Web Services request signing @@ -14,9 +124,11 @@ * httpProxy, basicAuth, oauth2Bearer, oauth2Token: removed Maybe from result types, changed documentation to suggest use of (?~) + 2014-08-25 0.2.0.0 * Support for lens 4.4 + 2014-04-22 0.1.0.0 diff --git a/examples/UploadPaste.hs b/examples/UploadPaste.hs --- a/examples/UploadPaste.hs +++ b/examples/UploadPaste.hs @@ -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 diff --git a/examples/wreq-examples.cabal b/examples/wreq-examples.cabal --- a/examples/wreq-examples.cabal +++ b/examples/wreq-examples.cabal @@ -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 diff --git a/httpbin/HttpBin/Server.hs b/httpbin/HttpBin/Server.hs --- a/httpbin/HttpBin/Server.hs +++ b/httpbin/HttpBin/Server.hs @@ -8,13 +8,15 @@ 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) import Data.Monoid ((<>)) import Data.Text.Encoding (decodeUtf8) import Data.Text.Read (decimal) +import Data.Time.Clock (UTCTime(..)) import Data.UUID (toASCIIBytes) import Data.UUID.V4 (nextRandom) import Snap.Core @@ -49,6 +51,16 @@ localRequest (setHeader "Accept-Encoding" "gzip") . withCompression . respond $ \obj -> return $ obj <> [("gzipped", Bool True)] +deleteCookies = do + req <- getRequest + let expire name = Cookie name "" (Just mcfly) Nothing (Just "/") False False + mcfly = UTCTime (read "1985-10-26") 4800 + modifyResponse . foldr (.) id $ [ + addResponseCookie (expire name) . deleteResponseCookie name + | name <- Map.keys (rqQueryParams req) + ] + redirect "/cookies" + setCookies = do params <- rqQueryParams <$> getRequest modifyResponse . foldr (.) id . map addResponseCookie $ @@ -58,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)] @@ -122,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 @@ -130,33 +142,37 @@ 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) +meth m h = method m (path "" h) + serve mkConfig = do cfg <- mkConfig . setAccessLog ConfigNoLog . setErrorLog ConfigNoLog $ defaultConfig httpServe cfg $ route [ - ("/get", methods [GET,HEAD] get) - , ("/post", method POST post) - , ("/put", method PUT put) - , ("/delete", method DELETE delete) + ("/get", meths [GET,HEAD] get) + , ("/post", meth POST post) + , ("/put", meth PUT put) + , ("/delete", meth DELETE delete) , ("/redirect/:n", redirect_) , ("/status/:val", status) - , ("/gzip", methods [GET,HEAD] gzip) - , ("/cookies/set", methods [GET,HEAD] setCookies) - , ("/cookies", methods [GET,HEAD] listCookies) - , ("/basic-auth/:user/:pass", methods [GET,HEAD] basicAuth) - , ("/oauth2/:kind/:token", methods [GET,HEAD] oauth2token) - , ("/cache", methods [GET,HEAD] cache) + , ("/gzip", meths [GET,HEAD] gzip) + , ("/cookies/delete", meths [GET,HEAD] deleteCookies) + , ("/cookies/set", meths [GET,HEAD] setCookies) + , ("/cookies", meths [GET,HEAD] listCookies) + , ("/basic-auth/:user/:pass", meths [GET,HEAD] basicAuth) + , ("/oauth2/:kind/:token", meths [GET,HEAD] oauth2token) + , ("/cache", meths [GET,HEAD] cache) ] 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: @@ -65,7 +62,7 @@ import Control.Lens import Data.ByteString.Char8 as BS8 (pack) import Data.IORef (newIORef) -import Network.Info (getNetworkInterfaces, mac) +import Network.Info (getNetworkInterfaces, mac, ipv6) import Network.Wreq import System.Environment (getEnv) import Test.Framework (Test, testGroup) @@ -76,47 +73,44 @@ 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" let baseopts = defaults & auth ?~ awsAuth AWSv4 key secret prefix <- env "deleteWreqTest" "WREQ_AWS_TEST_PREFIX" sqsTestState <- newIORef "missing" + iamTestState <- newIORef "missing" uniq <- uniqueMachineId + let bucketname = prefix ++ uniq return $ testGroup "aws" [ AWS.DynamoDB.tests (prefix ++ "DynamoDB") region baseopts - , AWS.IAM.tests (prefix ++ "IAM") region baseopts + , AWS.IAM.tests (prefix ++ "IAM") region baseopts iamTestState , AWS.SQS.tests (prefix ++ "SQS") region baseopts sqsTestState -- S3 buckets are global entities and the namespace shared among -- all AWS customers. We will use a unique id based on the MAC -- address of our client to avoid naming conflicts among different -- developers running the tests. - , AWS.S3.tests (prefix ++ "S3" ++ uniq) region baseopts + , AWS.S3.tests bucketname region baseopts + --, AWS.S3.tests bucketname "us-east-1" baseopts -- classic + --, AWS.S3.tests bucketname "external-1" baseopts -- Virginia ] -- return a globally unique machine id (uses a MAC address) uniqueMachineId :: IO String uniqueMachineId = do - l <- (filter $ (/=) "00:00:00:00:00:00" . show . mac) `fmap` - getNetworkInterfaces - return $ concatMap (\c -> if c == ':' then [] else [c]) - . show - . mac - . head $ l + nis <- getNetworkInterfaces + let lmac = filter ((/=) "00:00:00:00:00:00") $ map (show . mac) nis + -- travis-ci.org doesn't show mac addresses - use ipv6 (e.g. of venet0) + let lipv6 = filter (\s -> (s /= "0:0:0:0:0:0:0:0") && + (s /= "0:0:0:0:0:0:0:1") && + (s /= "fe80:0:0:0:0:0:0:1")) + $ map (show . ipv6) nis + if (null $ lmac ++ lipv6) + then error "FATAL: can't determine unique id automatically in this runtime env!" + else do + let uniq = concatMap (\c -> if c == ':' then [] else [c]) + $ head (lmac ++ lipv6) + return uniq env :: String -> String -> IO String env defVal name = getEnv name `E.catch` \(_::IOException) -> return defVal diff --git a/tests/AWS/Aeson.hs b/tests/AWS/Aeson.hs new file mode 100644 --- /dev/null +++ b/tests/AWS/Aeson.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE FlexibleInstances, TypeFamilies, TypeSynonymInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module AWS.Aeson + ( + object + , string + , true + , (.=) + ) where + +import Data.Aeson hiding ((.=)) +import Data.Text (Text, pack) +import GHC.Exts +import qualified Data.Vector as Vector + +instance Num Value where + fromInteger = Number . fromInteger + +instance Fractional Value where + fromRational = Number . fromRational + +instance IsList Value where + type Item Value = Value + fromList = Array . Vector.fromList + toList (Array a) = Vector.toList a + toList _ = error "AWS.Aeson.toList" + +class Stringy a where + string :: a -> Value + +instance Stringy Text where + string = String + +instance Stringy String where + string = String . pack + +true :: Value +true = Bool True + +(.=) :: Text -> Value -> (Text, Value) +a .= b = (a,b) diff --git a/tests/AWS/DynamoDB.hs b/tests/AWS/DynamoDB.hs --- a/tests/AWS/DynamoDB.hs +++ b/tests/AWS/DynamoDB.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE OverloadedStrings, QuasiQuotes #-} +{-# LANGUAGE OverloadedLists, OverloadedStrings #-} module AWS.DynamoDB (tests) where +import AWS.Aeson import Control.Concurrent (threadDelay) -import Control.Lens +import Control.Lens hiding ((.=)) import Data.Aeson.Lens (key, _String, values, _Double) -import Data.Aeson.QQ import Data.Text as T (pack) import Network.Wreq import System.Timeout (timeout) @@ -34,21 +34,21 @@ & header "X-Amz-Target" .~ ["DynamoDB_20120810.CreateTable"] & header "Content-Type" .~ ["application/x-amz-json-1.0"] r <- postWith opts (url region) $ - [aesonQQ| { - "TableName": #{prefix ++ tablename}, - "KeySchema": [ - { "AttributeName": "name", "KeyType": "HASH" }, - { "AttributeName": "age", "KeyType": "RANGE" } - ], - "AttributeDefinitions": [ - { "AttributeName": "name", "AttributeType": "S" }, - { "AttributeName": "age", "AttributeType": "S" } - ], - "ProvisionedThroughput": { - "ReadCapacityUnits": 1, - "WriteCapacityUnits": 1 - } - } |] + object [ + "TableName" .= string (prefix ++ tablename), + "KeySchema" .= [ + object ["AttributeName" .= "name", "KeyType" .= "HASH"], + object ["AttributeName" .= "age", "KeyType" .= "RANGE"] + ], + "AttributeDefinitions" .= [ + object ["AttributeName" .= "name", "AttributeType" .= "S"], + object ["AttributeName" .= "age", "AttributeType" .= "S"] + ], + "ProvisionedThroughput" .= object [ + "ReadCapacityUnits" .= 1, + "WriteCapacityUnits" .= 1 + ] + ] assertBool "createTables 200" $ r ^. responseStatus . statusCode == 200 assertBool "createTables OK" $ r ^. responseStatus . statusMessage == "OK" assertBool "createTables status CREATING" $ @@ -62,7 +62,7 @@ & header "X-Amz-Target" .~ ["DynamoDB_20120810.ListTables"] & header "Content-Type" .~ ["application/x-amz-json-1.0"] -- FIXME avoid limit to keep tests from failing if there are > tables? - r <- postWith opts (url region) [aesonQQ| { "Limit": 100 } |] + r <- postWith opts (url region) $ object ["Limit" .= 100] assertBool "listTables 200" $ r ^. responseStatus . statusCode == 200 assertBool "listTables OK" $ r ^. responseStatus . statusMessage == "OK" assertBool "listTables contains test table" $ @@ -83,8 +83,8 @@ let opts = baseopts & header "X-Amz-Target" .~ ["DynamoDB_20120810.DescribeTable"] & header "Content-Type" .~ ["application/x-amz-json-1.0"] - r <- postWith opts (url region) - [aesonQQ| { "TableName": #{prefix ++ tablename} } |] + r <- postWith opts (url region) $ + object ["TableName" .= string (prefix ++ tablename)] assertBool "awaitTableActive 200" $ r ^. responseStatus . statusCode == 200 assertBool "awaitTableActive OK" $ r ^. responseStatus . statusMessage == "OK" -- Prelude.putStr "." @@ -101,7 +101,7 @@ & header "X-Amz-Target" .~ ["DynamoDB_20120810.DeleteTable"] & header "Content-Type" .~ ["application/x-amz-json-1.0"] r <- postWith opts (url region) $ - [aesonQQ| { "TableName": #{prefix ++ tablename} } |] + object ["TableName" .= string (prefix ++ tablename)] assertBool "deleteTable 200" $ r ^. responseStatus . statusCode == 200 assertBool "deleteTable OK" $ r ^. responseStatus . statusMessage == "OK" @@ -111,14 +111,14 @@ & header "X-Amz-Target" .~ ["DynamoDB_20120810.PutItem"] & header "Content-Type" .~ ["application/x-amz-json-1.0"] r <- postWith opts (url region) $ - [aesonQQ| { - "TableName": #{prefix ++ tablename}, - "Item": { - "name": { "S": "someone" }, - "age": {"S": "whatever"}, - "bar": {"S": "baz"} - } - } |] + object [ + "TableName" .= string (prefix ++ tablename), + "Item" .= object [ + "name" .= object ["S" .= "someone"], + "age" .= object ["S" .= "whatever"], + "bar" .= object ["S" .= "baz"] + ] + ] assertBool "putItem 200" $ r ^. responseStatus . statusCode == 200 assertBool "putItem OK" $ r ^. responseStatus . statusMessage == "OK" @@ -128,16 +128,16 @@ & header "X-Amz-Target" .~ ["DynamoDB_20120810.GetItem"] & header "Content-Type" .~ ["application/x-amz-json-1.0"] r <- postWith opts (url region) $ - [aesonQQ| { - "TableName": #{prefix ++ tablename}, - "Key": { - "name": { "S": "someone" }, - "age": {"S": "whatever"} - }, - "AttributesToGet": [ "bar" ], - "ConsistentRead": true, - "ReturnConsumedCapacity": "TOTAL" - } |] + object [ + "TableName" .= string (prefix ++ tablename), + "Key" .= object [ + "name" .= object ["S" .= "someone"], + "age" .= object ["S" .= "whatever"] + ], + "AttributesToGet" .= ["bar"], + "ConsistentRead" .= true, + "ReturnConsumedCapacity" .= "TOTAL" + ] assertBool "getItem 200" $ r ^. responseStatus . statusCode == 200 assertBool "getItem OK" $ r ^. responseStatus . statusMessage == "OK" assertBool "getItem baz value is bar" $ @@ -149,14 +149,14 @@ & header "X-Amz-Target" .~ ["DynamoDB_20120810.DeleteItem"] & header "Content-Type" .~ ["application/x-amz-json-1.0"] r <- postWith opts (url region) $ - [aesonQQ| { - "TableName": #{prefix ++ tablename}, - "Key": { - "name": { "S": "someone" }, - "age": {"S": "whatever"} - }, - "ReturnValues": "ALL_OLD" - } |] + object [ + "TableName" .= string (prefix ++ tablename), + "Key" .= object [ + "name" .= object ["S" .= "someone"], + "age" .= object ["S" .= "whatever"] + ], + "ReturnValues" .= "ALL_OLD" + ] assertBool "getItem 200" $ r ^. responseStatus . statusCode == 200 assertBool "getItem OK" $ r ^. responseStatus . statusMessage == "OK" diff --git a/tests/AWS/IAM.hs b/tests/AWS/IAM.hs --- a/tests/AWS/IAM.hs +++ b/tests/AWS/IAM.hs @@ -1,15 +1,34 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLists, OverloadedStrings, DeriveGeneric #-} module AWS.IAM (tests) where -import Control.Lens +import AWS.Aeson +import Control.Concurrent (threadDelay) +import Control.Lens hiding ((.=)) +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 -> Test -tests prefix region baseopts = testGroup "iam" [ - testCase "listUsers" $ listUsers prefix region baseopts +tests :: String -> String -> Options -> IORef String -> Test +tests prefix region baseopts iamTestState = testGroup "iam" [ + testCase "listUsers" $ listUsers prefix region baseopts + , testCase "createRole" $ createRole prefix region baseopts iamTestState + , testCase "listRoles" $ listRoles prefix region baseopts + , testCase "putRolePolicy" $ putRolePolicy prefix region baseopts + , testCase "stsAssumeRole" $ stsAssumeRole prefix region baseopts iamTestState + , testCase "deleteRolePolicy" $ deleteRolePolicy prefix region baseopts + , testCase "deleteRole" $ deleteRole prefix region baseopts ] listUsers :: String -> String -> Options -> IO () @@ -18,10 +37,207 @@ & param "Action" .~ ["ListUsers"] & param "Version" .~ ["2010-05-08"] & header "Accept" .~ ["application/json"] - r <- getWith opts (url region) + r <- getWith opts (iamUrl region) assertBool "listUsers 200" $ r ^. responseStatus . statusCode == 200 assertBool "listUsers OK" $ r ^. responseStatus . statusMessage == "OK" -url :: String -> String -url _ = - "https://iam.amazonaws.com/" -- not region specific +createRole :: String -> String -> Options -> IORef String -> IO () +createRole prefix region baseopts iamTestState = do + let opts = baseopts + & param "Action" .~ ["CreateRole"] + & param "Version" .~ ["2010-05-08"] + & param "RoleName" .~ [T.pack $ prefix ++ roleName] + & param "AssumeRolePolicyDocument" .~ [rolePolicyDoc] + & header "Accept" .~ ["application/json"] + r <- getWith opts (iamUrl region) + assertBool "createRole 200" $ r ^. responseStatus . statusCode == 200 + assertBool "createRole OK" $ r ^. responseStatus . statusMessage == "OK" + let [arn] = r ^.. responseBody . key "CreateRoleResponse" + . key "CreateRoleResult" + . key "Role" + . key "Arn" . _String + writeIORef iamTestState $ T.unpack arn + +putRolePolicy :: String -> String -> Options -> IO () +putRolePolicy prefix region baseopts = do + let opts = baseopts + & param "Action" .~ ["PutRolePolicy"] + & param "Version" .~ ["2010-05-08"] + & param "RoleName" .~ [T.pack $ prefix ++ roleName] + & param "PolicyName" .~ [testPolicyName] + & param "PolicyDocument" .~ [policyDoc] + & header "Accept" .~ ["application/json"] + r <- getWith opts (iamUrl region) + assertBool "putRolePolicy 200" $ r ^. responseStatus . statusCode == 200 + assertBool "putRolePolicy OK" $ r ^. responseStatus . statusMessage == "OK" + threadDelay $ 30*1000*1000 -- 30 sleep, allow change to propagate to region + +deleteRolePolicy :: String -> String -> Options -> IO () +deleteRolePolicy prefix region baseopts = do + let opts = baseopts + & param "Action" .~ ["DeleteRolePolicy"] + & param "Version" .~ ["2010-05-08"] + & param "RoleName" .~ [T.pack $ prefix ++ roleName] + & param "PolicyName" .~ [testPolicyName] + & param "PolicyDocument" .~ [policyDoc] + & header "Accept" .~ ["application/json"] + r <- getWith opts (iamUrl region) + assertBool "deleteRolePolicy 200" $ r ^. responseStatus . statusCode == 200 + assertBool "deleteRolePolicy OK" $ r ^. responseStatus . statusMessage == "OK" + +deleteRole :: String -> String -> Options -> IO () +deleteRole prefix region baseopts = do + let opts = baseopts + & param "Action" .~ ["DeleteRole"] + & param "Version" .~ ["2010-05-08"] + & param "RoleName" .~ [T.pack $ prefix ++ roleName] + & header "Accept" .~ ["application/json"] + r <- getWith opts (iamUrl region) + assertBool "deleteRole 200" $ r ^. responseStatus . statusCode == 200 + assertBool "deleteRole OK" $ r ^. responseStatus . statusMessage == "OK" + +listRoles :: String -> String -> Options -> IO () +listRoles prefix region baseopts = do + let opts = baseopts + & param "Action" .~ ["ListRoles"] + & param "Version" .~ ["2010-05-08"] + & header "Accept" .~ ["application/json"] + r <- getWith opts (iamUrl region) + assertBool "listRoles 200" $ r ^. responseStatus . statusCode == 200 + assertBool "listRoles OK" $ r ^. responseStatus . statusMessage == "OK" + let arns = r ^.. 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' + +-- 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 + arn <- readIORef iamTestState + let opts = baseopts + & param "Action" .~ ["AssumeRole"] + & param "Version" .~ ["2011-06-15"] + & param "RoleArn" .~ [T.pack arn] + & param "ExternalId" .~ [externalId] + & 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 _ = + "https://iam.amazonaws.com/" -- IAM is not region specific + +stsUrl :: String -> String +stsUrl _region = + "https://sts.amazonaws.com/" -- keep from needing to enable STS in regions + -- To test region specific behavior, uncomment the line below + -- "https://sts." ++ _region ++ ".amazonaws.com/" -- region specific + -- Note: to access AWS STS in any region other than us-east-1, or the default + -- region (sts.amazonaws.com), STS needs to be enabled in the + -- AWS Management Console under + -- Account Settings > Security Token Service Region + -- If you forget, the AssumeRole call will return a 403 error with: + -- "STS is not activated in this region for account:. + -- Your account administrator can activate STS in this region using + -- the IAM Console." + +roleName :: String +roleName = "test" + +testPolicyName :: T.Text +testPolicyName = "testPolicy" + +-- Note that ExternalId is a concept used for cross account use cases +-- with 3rd parties. But the check works for same-account as well, which +-- makes it more convenient to test. +-- For more, see: +-- http://docs.aws.amazon.com/STS/latest/UsingSTS/sts-delegating-externalid.html +externalId :: T.Text +externalId = "someExternalId" + +rolePolicyDoc :: T.Text +rolePolicyDoc = LT.toStrict . E.decodeUtf8 . encode $ + object [ + "Version" .= "2012-10-17", + "Statement" .= [ + object [ + "Effect" .= "Allow", + "Action" .= "sts:AssumeRole", + "Principal" .= object ["AWS" .= "*"], + "Condition" .= object ["StringEquals" .= + object ["sts:ExternalId" .= string externalId]] + ] + ] + ] + +policyDoc :: T.Text +policyDoc = LT.toStrict . E.decodeUtf8 . encode $ + object [ + "Version" .= "2012-10-17", + "Statement" .= [ + object [ + "Effect" .= "Allow", + "Action" .= ["*"], + "Resource" .= ["*"] + ] + ] + ] diff --git a/tests/AWS/S3.hs b/tests/AWS/S3.hs --- a/tests/AWS/S3.hs +++ b/tests/AWS/S3.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE OverloadedStrings, QuasiQuotes #-} +{-# LANGUAGE OverloadedLists, OverloadedStrings #-} module AWS.S3 (tests) where -import Control.Lens -import Data.Aeson.QQ +import AWS.Aeson +import Control.Lens hiding ((.=)) import Data.Char (toLower) import Data.Monoid ((<>)) import Network.Wreq @@ -20,57 +20,79 @@ tests :: String -> String -> Options -> Test tests prefix region baseopts = let lowerPrefix = map toLower prefix - in testGroup "s3" [ - testCase "createBucket" $ createBucket lowerPrefix region baseopts - , testCase "putObjectJSON" $ putObjectJSON lowerPrefix region baseopts - , testCase "getObjectJSON" $ getObjectJSON lowerPrefix region baseopts - , testCase "deleteObjectJSON" $ deleteObjectJSON lowerPrefix region baseopts - , testCase "deleteBucket" $ deleteBucket lowerPrefix region baseopts -- call last - ] + t = \(mkUrl, label) -> + testGroup (region ++ "_" ++ label) [ + testCase "createBucket" $ + createBucket mkUrl lowerPrefix region baseopts + , testCase "putObjectJSON" $ + putObjectJSON mkUrl lowerPrefix region baseopts + , testCase "getObjectJSON" $ + getObjectJSON mkUrl lowerPrefix region baseopts + , testCase "deleteObjectJSON" $ + deleteObjectJSON mkUrl lowerPrefix region baseopts + , testCase "deleteBucket" $ + deleteBucket mkUrl lowerPrefix region baseopts -- call last + ] + in testGroup "s3" $ map t [ (urlPath, "bucket-in-path") + , (urlVHost, "bucket-in-vhost") ] -createBucket :: String -> String -> Options -> IO () -createBucket prefix region baseopts = do - r <- putWith baseopts (url region ++ prefix ++ "testbucket") $ +-- Path based bucket access +createBucket :: MkURL -> String -> String -> Options -> IO () +createBucket url prefix region baseopts = do + r <- putWith baseopts (url region prefix "testbucket") $ locationConstraint region assertBool "createBucket 200" $ r ^. responseStatus . statusCode == 200 assertBool "createBucket OK" $ r ^. responseStatus . statusMessage == "OK" -deleteBucket :: String -> String -> Options -> IO () -deleteBucket prefix region baseopts = do - r <- deleteWith baseopts (url region ++ prefix ++ "testbucket") +deleteBucket :: MkURL -> String -> String -> Options -> IO () +deleteBucket url prefix region baseopts = do + r <- deleteWith baseopts (url region prefix "testbucket") assertBool "deleteBucket 204 - no content" $ r ^. responseStatus . statusCode == 204 assertBool "deleteBucket OK" $ r ^. responseStatus . statusMessage == "No Content" -putObjectJSON :: String -> String -> Options -> IO () -putObjectJSON prefix region baseopts = do - -- S3 write object, incl. correct content-type, uses /bucket/object syntax - r <- putWith baseopts (url region ++ prefix ++ "testbucket/blabla-json") $ - [aesonQQ| { "test": "key", "testdata": [ 1, 2, 3 ] } |] +putObjectJSON :: MkURL -> String -> String -> Options -> IO () +putObjectJSON url prefix region baseopts = do + -- S3 write object, incl. correct content-type + r <- putWith baseopts (url region prefix "testbucket" ++ "blabla-json") $ + object ["test" .= "key", "testdata" .= [1, 2, 3]] assertBool "putObjectJSON 200" $ r ^. responseStatus . statusCode == 200 assertBool "putObjectJSON OK" $ r ^. responseStatus . statusMessage == "OK" -getObjectJSON :: String -> String -> Options -> IO () -getObjectJSON prefix region baseopts = do - r <- getWith baseopts (url region ++ prefix ++ "testbucket/blabla-json") +getObjectJSON :: MkURL -> String -> String -> Options -> IO () +getObjectJSON url prefix region baseopts = do + r <- getWith baseopts (url region prefix "testbucket" ++ "blabla-json") assertBool "getObjectJSON 200" $ r ^. responseStatus . statusCode == 200 assertBool "getObjectJSON OK" $ r ^. responseStatus . statusMessage == "OK" -deleteObjectJSON :: String -> String -> Options -> IO () -deleteObjectJSON prefix region baseopts = do - r <- deleteWith baseopts (url region ++ prefix ++ "testbucket/blabla-json") +deleteObjectJSON :: MkURL -> String -> String -> Options -> IO () +deleteObjectJSON url prefix region baseopts = do + r <- deleteWith baseopts (url region prefix "testbucket" ++ "blabla-json") assertBool "deleteObjectJSON 204 - no content" $ r ^. responseStatus . statusCode == 204 assertBool "deleteObjectJSON OK" $ r ^. responseStatus . statusMessage == "No Content" +type MkURL = String -> String -> String -> String --region prefix bucket + -- see http://docs.aws.amazon.com/general/latest/gr/rande.html#s3_region -url :: String -> String -url "us-east-1" = "https://s3.amazonaws.com/" -- uses 'classic' -url region = "https://s3-" ++ region ++ ".amazonaws.com/" +urlPath :: MkURL +urlPath "us-east-1" prefix bucketname = + "https://s3.amazonaws.com/" ++ prefix ++ bucketname ++ "/"-- uses 'classic' +urlPath region prefix bucketname = + "https://s3-" ++ region ++ ".amazonaws.com/" ++ prefix ++ bucketname ++ "/" +-- Generate a VirtualHost style URL +urlVHost :: MkURL +urlVHost "us-east-1" prefix bucketname = + "https://" ++ prefix ++ bucketname ++ ".s3.amazonaws.com/" +urlVHost region prefix bucketname = + "https://" ++ prefix ++ bucketname ++ ".s3-" ++ region ++ ".amazonaws.com/" + -- see http://docs.aws.amazon.com/AmazonS3/latest/API/RESTBucketPUT.html +-- and http://docs.aws.amazon.com/general/latest/gr/rande.html#s3_region locationConstraint :: String -> BS8.ByteString -locationConstraint "us-east-1" = "" -- no loc needed for classic and Virginia +locationConstraint "us-east-1" = "" -- no loc needed for classic and Virginia +locationConstraint "external-1" = "" -- no loc needed for Virginia locationConstraint region = "" <> BS8.pack region <> "" 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/Tests.hs b/tests/Tests.hs --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -1,13 +1,22 @@ +{-# LANGUAGE CPP #-} + module Main (main) where import Test.Framework (testGroup) import UnitTests (testWith) -import qualified AWS (tests) import qualified Properties.Store +#if defined(AWS_TESTS) +import qualified AWS (tests) +#endif + main :: IO () main = do +#if defined(AWS_TESTS) awsTests <- AWS.tests +#else + let awsTests = testGroup "aws" [] +#endif testWith [ testGroup "store" Properties.Store.tests , awsTests diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs --- a/tests/UnitTests.hs +++ b/tests/UnitTests.hs @@ -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 @@ -262,14 +286,44 @@ assertEqual "cookies are set correctly" (Just "y") (r ^? responseCookie "x" . cookieValue) -cookieSession site = Session.withSession $ \s -> do - void $ Session.get s (site "/cookies/set?foo=bar") - r <- Session.get s (site "/cookies") - assertEqual "cookies are set correctly" (Just "bar") - (r ^? responseCookie "foo" . cookieValue) - assertEqual "whee" (Just "bar") - (r ^. responseBody ^? key "cookies" . key "foo") +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) + assertEqual "a different accessor works" (Just "bar") + (r0 ^. responseBody ^? key "cookies" . key "foo") + + r1 <- Session.get s (site "/cookies") + assertEqual "long after set foo, foo still set" (Just "bar") + (r1 ^? responseCookie "foo" . cookieValue) + + r2 <- Session.get s (site "/cookies/set?baz=quux") + assertEqual "after set baz, foo still set" (Just "bar") + (r2 ^? responseCookie "foo" . cookieValue) + assertEqual "after set baz, baz set" (Just "quux") + (r2 ^? responseCookie "baz" . cookieValue) + + r3 <- Session.get s (site "/cookies") + assertEqual "long after set baz, foo still set" (Just "bar") + (r3 ^? responseCookie "foo" . cookieValue) + assertEqual "long after set baz, baz still set" (Just "quux") + (r3 ^? responseCookie "baz" . cookieValue) + + r4 <- Session.get s (site "/cookies/delete?foo") + assertEqual "after delete foo, foo deleted" Nothing + (r4 ^? responseCookie "foo" . cookieValue) + assertEqual "after delete foo, baz still set" (Just "quux") + (r4 ^? responseCookie "baz" . cookieValue) + + r5 <- Session.get s (site "/cookies") + assertEqual "long after delete foo, foo still deleted" Nothing + (r5 ^? responseCookie "foo" . cookieValue) + assertEqual "long after delete foo, baz still set" (Just "quux") + (r5 ^? responseCookie "baz" . cookieValue) + + getWithManager site = withManager $ \opts -> do void $ Wreq.getWith opts (site "/get?a=b") void $ Wreq.getWith opts (site "/get?b=c") @@ -313,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 @@ -338,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) @@ -349,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,6 @@ +cabal-version: 3.0 name: wreq -version: 0.3.0.1 +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 -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,12 +48,22 @@ 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 default: True manual: True +-- enable aws with -faws +flag aws + description: enable AWS tests + default: False + manual: True + -- enable httpbin with -fhttpbin flag httpbin description: enable httpbin test daemon @@ -82,34 +93,37 @@ Network.Wreq.Internal.AWS Network.Wreq.Internal.Lens Network.Wreq.Internal.Link + Network.Wreq.Internal.OAuth1 Network.Wreq.Internal.Types Network.Wreq.Lens.Machinery Network.Wreq.Lens.TH Paths_wreq + autogen-modules: + Paths_wreq build-depends: - PSQueue >= 1.1, + psqueues >= 0.2, aeson >= 0.7.0.3, attoparsec >= 0.11.1.0, - 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, - old-locale, + time-locale-compat, template-haskell, text, - time, + time >= 1.5, unordered-containers -- A convenient server for testing locally, or if httpbin.org is down. @@ -126,16 +140,17 @@ 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, transformers, unix-compat, uuid @@ -151,19 +166,24 @@ other-modules: Properties.Store UnitTests - AWS - AWS.DynamoDB - AWS.IAM - AWS.S3 - AWS.SQS + HttpBin.Server + if flag(aws) + cpp-options: -DAWS_TESTS + other-modules: + AWS + AWS.Aeson + AWS.DynamoDB + AWS.IAM + AWS.S3 + AWS.SQS + build-depends: HUnit, QuickCheck >= 2.7, aeson, - aeson-pretty >= 0.7.1, - aeson-qq, - base >= 4.5 && < 5, + aeson-pretty >= 0.8.0, + base >= 4.13 && < 5, base64-bytestring, bytestring, case-insensitive, @@ -174,40 +194,39 @@ lens, lens-aeson, network-info, - snap-core, + snap-core >= 1.0.0.0, snap-server >= 0.9.4.4, temporary, test-framework, test-framework-hunit, test-framework-quickcheck2, 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 diff --git a/www/index.md b/www/index.md --- a/www/index.md +++ b/www/index.md @@ -89,6 +89,7 @@ the authors of our popular Tetris clones. ~~~~ {.haskell} +ghci> import Data.Aeson.Lens ghci> r ^.. responseBody . key "items" . values . key "owner" . key "login" . _String ["steffi2392","rmies","Spacejoker","walpen",{-...-} diff --git a/www/tutorial.md b/www/tutorial.md --- a/www/tutorial.md +++ b/www/tutorial.md @@ -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.