wreq 0.2.0.0 → 0.5.4.5
raw patch · 38 files changed
Files
- Network/Wreq.hs +234/−36
- Network/Wreq/Cache.hs +153/−0
- Network/Wreq/Cache/Store.hs +66/−0
- Network/Wreq/Internal.hs +112/−25
- Network/Wreq/Internal/AWS.hs +206/−0
- Network/Wreq/Internal/Lens.hs +25/−4
- Network/Wreq/Internal/OAuth1.hs +12/−0
- Network/Wreq/Internal/Types.hs +129/−18
- Network/Wreq/Lens.hs +69/−13
- Network/Wreq/Lens/Machinery.hs +2/−2
- Network/Wreq/Lens/TH.hs +11/−3
- Network/Wreq/Session.hs +240/−39
- Network/Wreq/Types.hs +58/−29
- README.md +9/−2
- Setup.hs +25/−56
- TODO.md +2/−2
- changelog +0/−9
- changelog.md +135/−0
- examples/SimpleSession.hs +24/−0
- examples/UploadPaste.hs +9/−6
- examples/wreq-examples.cabal +14/−7
- httpbin/HttpBin.hs +4/−121
- httpbin/HttpBin/Server.hs +178/−0
- tests/AWS.hs +116/−0
- tests/AWS/Aeson.hs +42/−0
- tests/AWS/DynamoDB.hs +169/−0
- tests/AWS/IAM.hs +243/−0
- tests/AWS/S3.hs +98/−0
- tests/AWS/SQS.hs +118/−0
- tests/DocTests.hs +0/−47
- tests/Properties/Store.hs +83/−0
- tests/Tests.hs +17/−201
- tests/UnitTests.hs +419/−0
- tests/doctests.hs +12/−0
- wreq.cabal +106/−33
- www/Makefile +5/−3
- www/index.md +20/−4
- www/tutorial.md +129/−12
Network/Wreq.hs view
@@ -37,6 +37,10 @@ module Network.Wreq ( -- * HTTP verbs++ -- ** Sessions+ -- $session+ -- ** GET get , getWith@@ -53,9 +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@@ -72,13 +89,20 @@ , Lens.params , Lens.cookie , Lens.cookies+ , Lens.checkResponse+ -- ** Authentication -- $auth , Auth+ , AWSAuthVersion(..) , Lens.auth , basicAuth+ , oauth1Auth , oauth2Bearer , oauth2Token+ , awsAuth+ , awsFullAuth+ , awsSessionTokenAuth -- ** Proxy settings , Proxy(Proxy) , Lens.proxy@@ -116,6 +140,11 @@ , Lens.responseStatus , Lens.Status , Lens.statusCode+ , Lens.statusMessage+ , HistoriedResponse+ , Lens.hrFinalRequest+ , Lens.hrFinalResponse+ , Lens.hrRedirects -- ** Link headers , Lens.Link , Lens.linkURL@@ -136,16 +165,17 @@ -- * Parsing responses , Lens.atto+ , Lens.atto_ ) where import Control.Lens ((.~), (&)) import Control.Monad (unless) import Control.Monad.Catch (MonadThrow(throwM)) import Data.Aeson (FromJSON)-import Data.ByteString.Char8 () 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)@@ -157,10 +187,9 @@ import qualified Data.Text as T import qualified Network.HTTP.Client as HTTP import qualified Network.HTTP.Client.MultipartFormData as Form-import qualified Network.HTTP.Types as HTTP-import qualified Network.Wreq.Internal.Lens as Int import qualified Network.Wreq.Lens as Lens import qualified Network.Wreq.Types as Wreq+import qualified Data.ByteString.Char8 as BC8 -- | Issue a GET request. --@@ -177,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'.@@ -194,7 +224,7 @@ -- >>> r ^? responseBody . key "url" -- Just (String "http://httpbin.org/get?foo=bar") getWith :: Options -> String -> IO (Response L.ByteString)-getWith opts url = request id opts url readResponse+getWith opts url = runRead =<< prepareGet opts url -- | Issue a POST request. --@@ -205,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 @@ -224,9 +254,7 @@ -- >>> r ^? responseBody . key "url" -- Just (String "http://httpbin.org/post?foo=bar") postWith :: Postable a => Options -> String -> a -> IO (Response L.ByteString)-postWith opts url payload =- requestIO (postPayload payload . (Int.method .~ HTTP.methodPost)) opts url- readResponse+postWith opts url payload = runRead =<< preparePost opts url payload -- | Issue a HEAD request. --@@ -256,7 +284,7 @@ -- >>> r ^? responseHeader "Connection" -- Just "keep-alive" headWith :: Options -> String -> IO (Response ())-headWith = emptyMethodWith HTTP.methodHead+headWith opts url = runIgnore =<< prepareHead opts url -- | Issue a PUT request. put :: Putable a => String -> a -> IO (Response L.ByteString)@@ -264,10 +292,16 @@ -- | Issue a PUT request, using the supplied 'Options'. putWith :: Putable a => Options -> String -> a -> IO (Response L.ByteString)-putWith opts url payload =- requestIO (putPayload payload . (Int.method .~ HTTP.methodPut)) opts url- readResponse+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:@@ -289,7 +323,7 @@ --'optionsWith' opts \"http:\/\/httpbin.org\/get\" -- @ optionsWith :: Options -> String -> IO (Response ())-optionsWith = emptyMethodWith HTTP.methodOptions+optionsWith opts url = runIgnore =<< prepareOptions opts url -- | Issue a DELETE request. --@@ -302,7 +336,7 @@ -- >>> r <- delete "http://httpbin.org/delete" -- >>> r ^. responseStatus . statusCode -- 200-delete :: String -> IO (Response ())+delete :: String -> IO (Response L.ByteString) delete = deleteWith defaults -- | Issue a DELETE request, using the supplied 'Options'.@@ -318,14 +352,105 @@ -- >>> r <- deleteWith opts "http://httpbin.org/delete" -- >>> r ^. responseStatus . statusCode -- 200-deleteWith :: Options -> String -> IO (Response ())-deleteWith = emptyMethodWith HTTP.methodDelete+deleteWith :: Options -> String -> IO (Response L.ByteString)+deleteWith opts url = runRead =<< prepareDelete opts url +-- | Issue a custom-method request+--+-- Example:+--+-- @+-- 'customMethod' \"PATCH\" \"http:\/\/httpbin.org\/patch\"+-- @+--+-- >>> r <- customMethod "PATCH" "http://httpbin.org/patch"+-- >>> r ^. responseStatus . statusCode+-- 200+customMethod :: String -> String -> IO (Response L.ByteString)+customMethod method url = customMethodWith method defaults url++-- | Issue a custom request method request, using the supplied 'Options'.+--+-- Example:+--+-- @+--let opts = 'defaults' '&' 'Lens.redirects' '.~' 0+--'customMethodWith' \"PATCH\" opts \"http:\/\/httpbin.org\/patch\"+-- @+--+-- >>> let opts = defaults & redirects .~ 0+-- >>> r <- customMethodWith "PATCH" opts "http://httpbin.org/patch"+-- >>> r ^. responseStatus . statusCode+-- 200+customMethodWith :: String -> Options -> String -> IO (Response L.ByteString)+customMethodWith method opts url = runRead =<< prepareMethod methodBS opts url+ 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 foldGetWith :: Options -> (a -> S.ByteString -> IO a) -> a -> String -> IO a-foldGetWith opts f z0 url = request id opts url (foldResponseBody f z0)+foldGetWith opts f z0 url = request return opts url (foldResponseBody f z0) -- | Convert the body of an HTTP response from JSON to a suitable -- Haskell type.@@ -371,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)@@ -405,30 +531,44 @@ -- Example (note the use of TLS): -- -- @---let opts = 'defaults' '&' 'Lens.auth' '.~' 'basicAuth' \"user\" \"pass\"+--let opts = 'defaults' '&' 'Lens.auth' '?~' 'basicAuth' \"user\" \"pass\" --'getWith' opts \"https:\/\/httpbin.org\/basic-auth\/user\/pass\" -- @ ----- >>> let opts = defaults & auth .~ basicAuth "user" "pass"+-- Note here the use of the 'Control.Lens.?~' setter to turn an 'Auth'+-- into a 'Maybe' 'Auth', to make the type of the RHS compatible with+-- the 'Lens.auth' lens.+--+-- >>> let opts = defaults & auth ?~ basicAuth "user" "pass" -- >>> r <- getWith opts "https://httpbin.org/basic-auth/user/pass" -- >>> r ^? responseBody . key "authenticated" -- Just (Bool True) basicAuth :: S.ByteString -- ^ Username. -> S.ByteString -- ^ Password.- -> Maybe Auth-basicAuth user pass = Just (BasicAuth user pass)+ -> 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. -- -- Example (note the use of TLS): -- -- @---let opts = 'defaults' '&' 'Lens.auth' '.~' 'oauth2Bearer' \"1234abcd\"+--let opts = 'defaults' '&' 'Lens.auth' '?~' 'oauth2Bearer' \"1234abcd\" --'getWith' opts \"https:\/\/public-api.wordpress.com\/rest\/v1\/me\/\" -- @-oauth2Bearer :: S.ByteString -> Maybe Auth-oauth2Bearer token = Just (OAuth2Bearer token)+oauth2Bearer :: S.ByteString -> Auth+oauth2Bearer = OAuth2Bearer -- | A not-quite-standard OAuth2 bearer token (that seems to be used -- only by GitHub). This will be treated by whatever services accept@@ -437,26 +577,66 @@ -- Example (note the use of TLS): -- -- @---let opts = 'defaults' '&' 'Lens.auth' '.~' 'oauth2Token' \"abcd1234\"+--let opts = 'defaults' '&' 'Lens.auth' '?~' 'oauth2Token' \"abcd1234\" --'getWith' opts \"https:\/\/api.github.com\/user\" -- @-oauth2Token :: S.ByteString -> Maybe Auth-oauth2Token token = Just (OAuth2Token token)+oauth2Token :: S.ByteString -> Auth+oauth2Token = OAuth2Token +-- | AWS v4 request signature.+--+-- Example (note the use of TLS):+--+-- @+--let opts = 'defaults' '&' 'Lens.auth' '?~' 'awsAuth AWSv4' \"key\" \"secret\"+--'getWith' opts \"https:\/\/dynamodb.us-west-2.amazonaws.com\"+-- @+awsAuth :: AWSAuthVersion -> S.ByteString -> S.ByteString -> Auth+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: -- -- @---let opts = 'defaults' '&' 'Lens.proxy' '.~' 'httpProxy' \"localhost\" 8000+--let opts = 'defaults' '&' 'Lens.proxy' '?~' 'httpProxy' \"localhost\" 8000 --'getWith' opts \"http:\/\/httpbin.org\/get\" -- @ ----- (You may wonder why this function returns a 'Maybe Proxy'. This--- allows it to be easily used on the right hand side of an operation,--- as above, without its result needing to be wrapped in 'Just'.)-httpProxy :: S.ByteString -> Int -> Maybe Proxy-httpProxy host port = Just (Proxy host port)+-- Note here the use of the 'Control.Lens.?~' setter to turn a 'Proxy'+-- into a 'Maybe' 'Proxy', to make the type of the RHS compatible with+-- the 'Lens.proxy' lens.+httpProxy :: S.ByteString -> Int -> Proxy+httpProxy = Proxy -- | Make a 'Part' whose content is a strict 'T.Text', encoded as -- UTF-8.@@ -477,6 +657,20 @@ -> Form.Part partString name value = Form.partBS name (encodeUtf8 (T.pack value)) +-- $session+--+-- The basic HTTP functions ('get', 'post', and so on) in this module+-- have a few key drawbacks:+--+-- * If several requests go to the same server, there is no reuse of+-- TCP connections.+--+-- * There is no management of cookies across multiple requests.+--+-- This makes these functions inefficient and verbose for many common+-- uses. For greater efficiency, use the "Network.Wreq.Session"+-- module.+ -- $cookielenses -- -- These are only the most frequently-used cookie-related lenses. See@@ -507,6 +701,10 @@ -- The \"magical\" type conversion on the right-hand side of ':=' -- above is due to the 'FormValue' class. This package provides -- sensible instances for the standard string and number types.+-- You may need to explicitly add types to the values (e.g. :: String)+-- in order to evade ambigous type errors.+--+-- >>> r <- post "http://httpbin.org/post" ["num" := (31337 :: Int), "str" := ("foo" :: String)] -- -- The 'Aeson.Value' type gives a JSON request body with a -- @Content-Type@ of @application/json@. Any instance of
+ Network/Wreq/Cache.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveGeneric,+ FlexibleContexts, OverloadedStrings, RecordWildCards #-}++module Network.Wreq.Cache+ (+ shouldCache+ , validateEntry+ , cacheStore+ ) where++import Control.Applicative+import Control.Lens ((^?), (^.), (^..), folded, non, pre, to)+import Control.Monad (guard)+import Data.Attoparsec.ByteString.Char8 as A+import Data.CaseInsensitive (mk)+import Data.Foldable (forM_)+import Data.HashSet (HashSet)+import Data.Hashable (Hashable)+import Data.IntSet (IntSet)+import Data.IORef (newIORef)+import Data.List (sort)+import Data.Maybe (listToMaybe)+import Data.Monoid (First(..), mconcat)+import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime)+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 qualified Data.ByteString.Char8 as B+import qualified Data.HashSet as HashSet+import qualified Data.IntSet as IntSet+import qualified Network.Wreq.Cache.Store as Store++#if MIN_VERSION_base(4,6,0)+import Data.IORef (atomicModifyIORef')+#else+import Data.IORef (IORef, atomicModifyIORef)++atomicModifyIORef' :: IORef a -> (a -> (a, b)) -> IO b+atomicModifyIORef' = atomicModifyIORef+#endif++cacheStore :: Int -> IO (Run body -> Run body)+cacheStore capacity = do+ cache <- newIORef (Store.empty capacity)+ return $ \run req -> do+ let url = reqURL req+ before <- getCurrentTime+ mresp <- atomicModifyIORef' cache $ \s ->+ case Store.lookup url s of+ Nothing -> (s, Nothing)+ Just (ce, s') ->+ case validateEntry before ce of+ n@Nothing -> (Store.delete url s, n)+ resp -> (s', resp)+ case mresp of+ Just resp -> return resp+ Nothing -> do+ resp <- run req+ after <- getCurrentTime+ forM_ (shouldCache after req resp) $ \ce ->+ atomicModifyIORef' cache $ \s -> (Store.insert url ce s, ())+ return resp++cacheableStatuses :: IntSet+cacheableStatuses = IntSet.fromList [200, 203, 300, 301, 410]++cacheableMethods :: HashSet Method+cacheableMethods = HashSet.fromList ["GET", "HEAD", "OPTIONS"]++possiblyCacheable :: Request -> Response body -> Bool+possiblyCacheable req resp =+ (req ^. method) `HashSet.member` cacheableMethods &&+ (resp ^. responseStatus . statusCode) `IntSet.member` cacheableStatuses++computeExpiration :: UTCTime -> [CacheResponse Seconds] -> Maybe UTCTime+computeExpiration now crs = do+ guard $ and [NoCache [] `notElem` crs, NoStore `notElem` crs]+ age <- listToMaybe $ sort [age | MaxAge age <- crs]+ return $! fromIntegral age `addUTCTime` now++validateEntry :: UTCTime -> CacheEntry body -> Maybe (Response body)+validateEntry now CacheEntry{..} =+ case entryExpires of+ Nothing -> Just entryResponse+ Just e | e > now -> Just entryResponse+ _ -> Nothing++shouldCache :: UTCTime -> Req -> Response body -> Maybe (CacheEntry body)+shouldCache now (Req _ req) resp = do+ guard (possiblyCacheable req resp)+ let crs = resp ^.. responseHeader "Cache-Control" . atto_ parseCacheResponse .+ folded . to simplifyCacheResponse+ dateHeader name = responseHeader name . to parseDate . folded+ mexpires = case crs of+ [] -> resp ^? dateHeader "Expires"+ _ -> computeExpiration now crs+ created = resp ^. pre (dateHeader "Date") . non now+ case mexpires of+ Just expires | expires <= created -> empty+ Nothing | req ^. method == "GET" &&+ not (B.null (req ^. queryString)) -> empty+ _ -> return $ CacheEntry created mexpires resp++type Seconds = Int++data CacheResponse age = Public+ | Private [HeaderName]+ | NoCache [HeaderName]+ | NoStore+ | NoTransform+ | MustRevalidate+ | ProxyRevalidate+ | MaxAge age+ | SMaxAge age+ | Extension+ deriving (Eq, Show, Functor, Typeable, Generic)++instance Hashable age => Hashable (CacheResponse age)++simplifyCacheResponse :: CacheResponse age -> CacheResponse age+simplifyCacheResponse (Private _) = Private []+simplifyCacheResponse (NoCache _) = NoCache []+simplifyCacheResponse cr = cr++parseCacheResponse :: A.Parser [CacheResponse Seconds]+parseCacheResponse = commaSep1 body+ where+ body = "public" *> pure Public+ <|> "private" *> (Private <$> (eq headerNames <|> pure []))+ <|> "no-cache" *> (NoCache <$> (eq headerNames <|> pure []))+ <|> "no-store" *> pure NoStore+ <|> "no-transform" *> pure NoTransform+ <|> "must-revalidate" *> pure MustRevalidate+ <|> "proxy-revalidate" *> pure ProxyRevalidate+ <|> "max-age" *> eq (MaxAge <$> decimal)+ <|> "s-maxage" *> eq (SMaxAge <$> decimal)+ headerNames = A.char '"' *> commaSep1 hdr <* A.char '"'+ hdr = mk <$> A.takeWhile1 (inClass "a-zA-Z0-9_-")+ commaSep1 p = (p <* skipSpace) `sepBy1` (A.char ',' *> skipSpace)+ eq p = skipSpace *> A.char '=' *> skipSpace *> p++parseDate :: B.ByteString -> Maybe UTCTime+parseDate s = getFirst . mconcat . map tryout $ [+ "%a, %d %b %Y %H:%M:%S %Z"+ , "%A, %d-%b-%y %H:%M:%S %Z"+ , "%a %b %e %H:%M:%S %Y"+ ]+ where tryout fmt = First $ parseTimeM True defaultTimeLocale fmt (B.unpack s)
+ Network/Wreq/Cache/Store.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE BangPatterns, DeriveFunctor, RecordWildCards #-}++module Network.Wreq.Cache.Store+ (+ Store+ , empty+ , insert+ , delete+ , lookup+ , fromList+ , toList+ ) where++import Data.Hashable (Hashable)+import Data.Int (Int64)+import Data.List (foldl')+import Prelude hiding (lookup, map)+import qualified Data.HashPSQ as HashPSQ++type Epoch = Int64++data Store k v = Store {+ capacity :: {-# UNPACK #-} !Int+ , size :: {-# UNPACK #-} !Int+ , epoch :: {-# UNPACK #-} !Epoch+ , psq :: !(HashPSQ.HashPSQ k Epoch v)+ }++instance (Show k, Show v, Ord k, Hashable k) => Show (Store k v) where+ show st = "fromList " ++ show (toList st)++empty :: Ord k => Int -> Store k v+empty cap+ | cap <= 0 = error "empty: invalid capacity"+ | 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{..} = 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{..} = 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{..} = 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+fromList = foldl' (flip (uncurry insert)) . empty+{-# INLINABLE fromList #-}++toList :: (Ord k, Hashable k) => Store k v -> [(k, v)]+toList Store{..} = [(k,v) | (k, _, v) <- HashPSQ.toList psq]+{-# INLINABLE toList #-}
Network/Wreq/Internal.hs view
@@ -9,20 +9,33 @@ , ignoreResponse , readResponse , request- , requestIO+ , 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.Types (Auth(..), Options(..))+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@@ -30,7 +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.Lens as Lens+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 :-(@@ -38,6 +53,7 @@ import Paths_wreq (version) #else import Data.Version (Version(..))+version :: Version version = Version [0] ["wip"] #endif @@ -46,13 +62,14 @@ defaults :: Options defaults = Options {- manager = Left defaultManagerSettings- , proxy = Nothing- , auth = Nothing- , headers = [("User-Agent", userAgent)]- , params = []- , redirects = 10- , cookies = HTTP.createCookieJar []+ manager = Left defaultManagerSettings+ , proxy = Nothing+ , auth = Nothing+ , headers = [("User-Agent", userAgent)]+ , params = []+ , redirects = 10+ , cookies = Just (HTTP.createCookieJar [])+ , checkResponse = Nothing } where userAgent = "haskell wreq-" <> Char8.pack (showVersion version) @@ -63,7 +80,7 @@ emptyMethodWith :: HTTP.Method -> Options -> String -> IO (Response ()) emptyMethodWith method opts url =- request (Lens.method .~ method) opts url ignoreResponse+ request (return . (Lens.method .~ method)) opts url ignoreResponse ignoreResponse :: Response BodyReader -> IO (Response ()) ignoreResponse resp = (Lens.responseBody .~ ()) <$> readResponse resp@@ -73,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@@ -82,25 +105,37 @@ then return z else f z bs >>= go -requestIO :: (Request -> IO Request) -> Options -> String- -> (Response BodyReader -> IO a) -> IO a-requestIO modify opts url body =- either (flip HTTP.withManager go) go (manager opts)+request :: (Request -> IO Request) -> Options -> String+ -> (Response BodyReader -> IO a) -> IO a+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 (HTTP.newManager >=> go) go emgr+ where go mgr = HTTP.withResponse req mgr act++runHistory :: Mgr -> (HistoriedResponse BodyReader -> IO a) -> Request -> IO a+runHistory emgr act req = either (HTTP.newManager >=> go) go emgr+ where go mgr = HTTP.withResponseHistory req mgr act++prepare :: (Request -> IO Request) -> Options -> String -> IO Request+prepare modify opts url = do+ signRequest =<< modify =<< frob <$> HTTP.parseUrlThrow url where- go mgr = do- let frob req = req- & Lens.requestHeaders %~ (headers opts ++)+ frob req = req & Lens.requestHeaders %~ (headers opts ++) & setQuery opts & setAuth opts & setProxy opts+ & setCheckResponse opts & setRedirects opts- & Lens.cookieJar .~ Just (cookies opts)- req <- modify =<< (frob <$> HTTP.parseUrl url)- HTTP.withResponse req mgr body+ & 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 (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 -request :: (Request -> Request) -> Options -> String- -> (Response BodyReader -> IO a) -> IO a-request f = requestIO (return . f) setQuery :: Options -> Request -> Request setQuery opts =@@ -117,7 +152,59 @@ 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 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++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++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 (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++runIgnore :: Run ()+runIgnore (Req mgr req) = run mgr ignoreResponse req++prepareOptions :: Options -> String -> IO Req+prepareOptions = prepareMethod HTTP.methodOptions++preparePut :: Putable a => Options -> String -> a -> IO Req+preparePut opts url payload = Req (manager opts) <$>+ prepare (fmap (Lens.method .~ HTTP.methodPut) . putPayload payload) opts url++preparePatch :: Patchable a => Options -> String -> a -> IO Req+preparePatch opts url payload = Req (manager opts) <$>+ prepare (patchPayload payload . (Lens.method .~ HTTP.methodPatch)) opts url++prepareDelete :: Options -> String -> IO Req+prepareDelete = prepareMethod HTTP.methodDelete
+ Network/Wreq/Internal/AWS.hs view
@@ -0,0 +1,206 @@+{-# LANGUAGE OverloadedStrings, BangPatterns #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Network.Wreq.Internal.AWS+ (+ signRequest,+ signRequestFull+ ) where++import Control.Applicative ((<$>))+import Control.Lens ((%~), (^.), (&), to)+import Crypto.MAC.HMAC (HMAC (..), hmac, hmacGetDigest)+import Data.ByteString.Base16 as HEX (encode)+import Data.ByteArray (convert)+import Data.Char (toLower)+import Data.List (sort)+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 qualified Crypto.Hash as CT (Digest, SHA256, hash, hashlazy)+import qualified Data.ByteString.Char8 as S+import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.CaseInsensitive as CI (original)+import qualified Data.HashSet as HashSet+import qualified Network.HTTP.Client as HTTP++-- Sign requests following the AWS v4 request signing specification:+-- http://docs.aws.amazon.com/general/latest/gr/sigv4-create-canonical-request.html+--+-- Runscope Inc. Traffic Inspector support:+-- We support (optionally) sending requests through the Runscope+-- (http://www.runscope.com) Traffic Inspector. If given a Runscope+-- URL to an AWS service, we will extract and correctly sign the+-- request for the underlying AWS service. We support Runscope buckets+-- with and without Bucket Authorization enabled+-- ("Runscope-Bucket-Auth").+--+-- TODO: adjust when DELETE supports a body or PATCH is added+signRequest :: AWSAuthVersion -> S.ByteString -> S.ByteString ->+ Request -> IO Request+signRequest AWSv4 aid key r = signRequestFull AWSv4 aid key Nothing r++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) = case serviceRegion of+ Nothing -> serviceAndRegion noRunscopeHost+ Just (a, b) -> (a, b)+ date = S.takeWhile (/= 'T') ts -- YYYYMMDD+ hashedPayload+ | request ^. method `elem` ["POST", "PUT"] = payloadHash req+ | otherwise = 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"]) ++)+ -- 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+ , 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)+ . sort $+ parseSimpleQuery $ req ^. queryString+ , S.unlines -- step 4, incl. sort+ . map (\(k,v) -> lowerCI k <> ":" <> trimHeaderValue v) $ hl+ , signedHeaders -- step 5+ , hashedPayload -- step 6, handles empty payload+ ]+ -- task 2+ let dateScope = S.intercalate "/" [date, region, service, "aws4_request"]+ stringToSign = S.intercalate "\n" [+ "AWS4-HMAC-SHA256"+ , ts+ , dateScope+ , hexSha256Hash canonicalReq+ ]+ -- task 3, steps 1 and 2+ let signature = ("AWS4" <> secret) &+ hmac' date & hmac' region & hmac' service &+ hmac' "aws4_request" & hmac' stringToSign & HEX.encode+ authorization = S.intercalate ", " [+ "AWS4-HMAC-SHA256 Credential=" <> key <> "/" <> dateScope+ , "SignedHeaders=" <> signedHeaders+ , "Signature=" <> signature+ ]+ -- Add the AWS Authorization header.+ -- Restore the Host header to the Runscope endpoint+ -- so they can proxy accordingly (if used, otherwise this is a nop).+ -- Add the Runscope Bucket Auth header back in, if it was set originally.+ return $ setHeader "host" origHost+ <$> maybe id (setHeader "Runscope-Bucket-Auth") runscopeBucketAuth+ <$> setHeader "authorization" authorization $ req+ where+ lowerCI = S.map toLower . CI.original+ trimHeaderValue =+ id -- FIXME, see step 4, whitespace trimming but not in double+ -- quoted sections, AWS spec.+ timestamp = render <$> getCurrentTime+ where render = S.pack . formatTime defaultTimeLocale "%Y%m%dT%H%M%SZ" .+ utcToLocalTime utc -- UTC printable: YYYYMMDDTHHMMSSZ+ hmac' :: S.ByteString -> S.ByteString -> S.ByteString+ hmac' s k = convert (hmacGetDigest h)+ where h = hmac k s :: (HMAC CT.SHA256)++payloadHash :: Request -> S.ByteString+payloadHash req =+ case HTTP.requestBody req of+ HTTP.RequestBodyBS bs -> 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 <bucket>.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 /<bucket> style access, as opposed to+ -- <bucket>.s3... in the hostname.+ | endpoint `elem` ["s3.amazonaws.com", "s3-external-1.amazonaws.com"] =+ ("s3", "us-east-1")+ | servicePrefix '-' endpoint == "s3" =+ -- format: e.g. s3-us-west-2.amazonaws.com+ 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 =+ let service:region:_ = S.split '.' endpoint+ in (service, region)+ where+ svc = servicePrefix '.' endpoint+ servicePrefix c = S.map toLower . S.takeWhile (/= c)+ 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:+-- given sqs-us--east--1-amazonaws-com-<BUCKET>.runscope.net+-- return sqs.us-east-1.amazonaws.com+removeRunscope :: S.ByteString -> S.ByteString+removeRunscope hostname+ | ".runscope.net" `S.isSuffixOf` hostname =+ S.concat . Prelude.map (p2 . p1) . S.group -- decode+ -- drop suffix "-<BUCKET>.runscope.net" before decoding+ . S.reverse . S.tail . S.dropWhile (/= '-') . S.reverse+ $ hostname+ | otherwise = hostname+ where p1 "-" = "."+ p1 other = other+ p2 "--" = "-"+ p2 other = other
Network/Wreq/Internal/Lens.hs view
@@ -12,19 +12,27 @@ , queryString , requestHeaders , requestBody+ , requestVersion+ , requestManagerOverride+ , onRequestBodyException , proxy , hostAddress , rawBody , decompress , redirectCount , responseTimeout- , checkStatus- , getConnectionWrapper+ , checkResponse , cookieJar+ , seshCookies+ , seshManager+ , seshRun+ , seshRunHistory -- * Useful functions , assoc , assoc2 , setHeader+ , maybeSetHeader+ , deleteKey ) where import Control.Lens hiding (makeLenses)@@ -32,10 +40,12 @@ import Network.HTTP.Client (Request) import Network.HTTP.Types (HeaderName) import Network.Wreq.Lens.Machinery (makeLenses)+import Network.Wreq.Internal.Types (Session) import qualified Data.ByteString as S import qualified Network.HTTP.Client as HTTP makeLenses ''HTTP.Request+makeLenses ''Session assoc :: (Eq k) => k -> IndexedTraversal' k [(k, a)] a assoc i = traverse . itraversed . index i@@ -47,6 +57,17 @@ assoc2 k f = fmap (uncurry ((++) . fmap ((,) k))) . _1 (f . fmap snd) . partition ((==k) . fst) +-- | Set a header to the given value, replacing any prior value. setHeader :: HeaderName -> S.ByteString -> Request -> Request-setHeader name value = requestHeaders %~ ((name,value) :) .- filter ((/= name) . fst)+setHeader name value = requestHeaders %~ ((name,value) :) . deleteKey name++-- | Set a header to the given value, but only if the header was not+-- already set.+maybeSetHeader :: HeaderName -> S.ByteString -> Request -> Request+maybeSetHeader name value = requestHeaders %~+ \hdrs -> case lookup name hdrs of+ Just _ -> hdrs+ Nothing -> (name,value) : hdrs++deleteKey :: (Eq a) => a -> [(a,b)] -> [(a,b)]+deleteKey key = filter ((/= key) . fst)
+ Network/Wreq/Internal/OAuth1.hs view
@@ -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
Network/Wreq/Internal/Types.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, GADTs, RecordWildCards #-}+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, FlexibleInstances, GADTs,+ OverloadedStrings, RankNTypes, RecordWildCards, DefaultSignatures #-} -- | -- Module : Network.Wreq.Internal.Types@@ -15,10 +16,14 @@ ( -- * Client configuration Options(..)+ , Mgr , Auth(..)+ , AWSAuthVersion(..)+ , ResponseChecker -- * Request payloads , Payload(..) , Postable(..)+ , Patchable(..) , Putable(..) -- ** URL-encoded forms , FormParam(..)@@ -28,24 +33,41 @@ , Link(..) -- * Errors , JSONError(..)+ -- * Request types+ , Req(..)+ , reqURL+ -- * Sessions+ , Session(..)+ , Run+ , RunHistory+ , Body(..)+ -- * Caches+ , CacheEntry(..) ) where 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)-import Network.HTTP.Client.Internal (Proxy)+ RequestBody)+import Network.HTTP.Client.Internal (Response, Proxy) import Network.HTTP.Types (Header) import Prelude hiding (head)-import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S+import qualified Data.ByteString.Lazy as L+import qualified Network.HTTP.Client as HTTP -- | A MIME content type, e.g. @\"application/octet-stream\"@. type ContentType = S.ByteString +type Mgr = Either ManagerSettings Manager+ -- | Options for configuring a client. data Options = Options {- manager :: Either ManagerSettings Manager+ manager :: Mgr -- ^ Either configuration for a 'Manager', or an actual 'Manager'. -- -- If only 'ManagerSettings' are provided, then by default a new@@ -121,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@@ -130,8 +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.+ , 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. } 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.@@ -148,28 +181,52 @@ -- 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 (Maybe S.ByteString)+ -- ^ Amazon Web Services request signing+ -- 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+ -- ^ AWS request signing version 4+ 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@@ -218,3 +275,57 @@ linkURL :: S.ByteString , linkParams :: [(S.ByteString, S.ByteString)] } deriving (Eq, Show, Typeable)++-- | A request that is ready to be submitted.+data Req = Req Mgr Request++-- | Return the URL associated with the given 'Req'.+--+-- This includes the port number if not standard, and the query string+-- if one exists.+reqURL :: Req -> S.ByteString+reqURL (Req _ req) = mconcat [+ if https then "https" else "http"+ , "://"+ , HTTP.host req+ , case (HTTP.port req, https) of+ (80, False) -> ""+ (443, True) -> ""+ (p, _) -> S.pack (show p)+ , HTTP.path req+ , case HTTP.queryString req of+ qs | S.null qs -> ""+ | otherwise -> "?" <> qs+ ]+ where https = HTTP.secure req++-- | A function that runs a request and returns the associated+-- response.+type Run body = Req -> IO (Response body)++type RunHistory body = Req -> IO (HTTP.HistoriedResponse body)++-- | A session that spans multiple requests. This is responsible for+-- cookie management and TCP connection reuse.+data Session = Session {+ seshCookies :: Maybe (IORef CookieJar)+ , seshManager :: Manager+ , seshRun :: Session -> Run Body -> Run Body+ , seshRunHistory :: Session -> RunHistory Body -> RunHistory Body+ }++instance Show Session where+ show _ = "Session"++data CacheEntry body = CacheEntry {+ entryCreated :: UTCTime+ , entryExpires :: Maybe UTCTime+ , entryResponse :: Response body+ } deriving (Functor)++data Body = NoBody+ | StringBody L.ByteString+ | ReaderBody HTTP.BodyReader++instance Show (CacheEntry body) where+ show _ = "CacheEntry"
Network/Wreq/Lens.hs view
@@ -45,6 +45,8 @@ , params , cookie , cookies+ , ResponseChecker+ , checkResponse -- ** Proxy setup , Proxy@@ -76,6 +78,12 @@ , responseStatus , responseVersion + -- * HistoriedResponse+ , HistoriedResponse+ , hrFinalResponse+ , hrFinalRequest+ , hrRedirects+ -- ** Status , Status , statusCode@@ -95,37 +103,50 @@ -- * Parsing , atto+ , atto_ ) where +import Control.Applicative ((<*)) import Control.Lens (Fold, Lens, Lens', Traversal', folding)-import Data.Attoparsec (Parser, parseOnly)+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 "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.TLS.tlsManagerSettings'+-- 'Control.Lens.&' 'manager' 'Control.Lens..~' Left ('Network.HTTP.Client.defaultManagerSettings' { 'Network.HTTP.Client.managerResponseTimeout' = responseTimeoutMicro 10000 } )+--+--'Network.Wreq.getWith' opts \"https:\/\/httpbin.org\/get\"+-- @ manager :: Lens' Options (Either ManagerSettings Manager) manager = TH.manager @@ -134,9 +155,13 @@ -- Example: -- -- @---let opts = 'Network.Wreq.defaults' 'Control.Lens.&' 'proxy' 'Control.Lens..~' 'Network.Wreq.httpProxy' \"localhost\" 8000+--let opts = 'Network.Wreq.defaults' 'Control.Lens.&' 'proxy' 'Control.Lens.?~' 'Network.Wreq.httpProxy' \"localhost\" 8000 --'Network.Wreq.getWith' opts \"http:\/\/httpbin.org\/get\" -- @+--+-- Note here the use of the 'Control.Lens.?~' setter to turn a 'Proxy'+-- into a 'Maybe' 'Proxy', to make the type of the RHS compatible with+-- the 'Lens.proxy' lens. proxy :: Lens' Options (Maybe Proxy) proxy = TH.proxy @@ -145,7 +170,7 @@ -- Example (note the use of TLS): -- -- @---let opts = 'Network.Wreq.defaults' 'Control.Lens.&' 'Lens.auth' 'Control.Lens..~' 'Network.Wreq.basicAuth' \"user\" \"pass\"+--let opts = 'Network.Wreq.defaults' 'Control.Lens.&' 'Lens.auth' 'Control.Lens.?~' 'Network.Wreq.basicAuth' \"user\" \"pass\" --'Network.Wreq.getWith' opts \"https:\/\/httpbin.org\/basic-auth\/user\/pass\" -- @ auth :: Lens' Options (Maybe Auth)@@ -205,12 +230,20 @@ redirects :: Lens' Options Int redirects = TH.redirects +-- | A lens to get the optional status check function+checkResponse :: Lens' Options (Maybe ResponseChecker)+checkResponse = TH.checkResponse+ -- | A traversal onto the cookie with the given name, if one exists.+--+-- N.B. This is an \"illegal\" 'Traversal'': we can change the+-- 'cookieName' of the associated 'Cookie' so that it differs from the+-- name provided to this function. cookie :: ByteString -> Traversal' Options Cookie 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.@@ -360,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@@ -417,7 +462,18 @@ -- >>> 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.+--+-- Equivalent to:+--+-- @+--'atto_' myParser = 'atto' (myParser '<*' 'endOfInput')+-- @+atto_ :: Parser a -> Fold ByteString a+atto_ p = atto (p <* endOfInput) -- $setup --
Network/Wreq/Lens/Machinery.hs view
@@ -13,8 +13,8 @@ defaultRules :: LensRules defaultRules = lensRules -fieldName :: (String -> String) -> [Name] -> Name -> [DefName]-fieldName f _ name = [TopName . mkName . f . nameBase $ name]+fieldName :: (String -> String) -> Name -> [Name] -> Name -> [DefName]+fieldName f _ _ name = [TopName . mkName . f . nameBase $ name] makeLenses :: Name -> Q [Dec] makeLenses = makeLensesWith (defaultRules & lensField .~ fieldName id)
Network/Wreq/Lens/TH.hs view
@@ -15,6 +15,7 @@ , redirects , cookie , cookies+ , checkResponse , HTTP.Cookie , cookieName@@ -44,6 +45,11 @@ , responseCookieJar , responseClose' + , HTTP.HistoriedResponse+ , hrFinalResponse+ , hrFinalRequest+ , hrRedirects+ , HTTP.Status , statusCode , statusMessage@@ -52,11 +58,12 @@ , linkURL , linkParams - , Form.Part+ , Form.PartM , partName , partFilename , partContentType , partGetBody+ , partHeaders ) where import Control.Lens hiding (makeLenses)@@ -75,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@@ -93,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
Network/Wreq/Session.hs view
@@ -1,9 +1,64 @@-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RankNTypes, RecordWildCards #-} +-- |+-- Module : Network.Wreq.Session+-- Copyright : (c) 2014 Bryan O'Sullivan+--+-- License : BSD-style+-- Maintainer : bos@serpentine.com+-- Stability : experimental+-- Portability : GHC+--+-- The functions in this module use a 'Session' to handle the+-- following common needs:+--+-- * TCP connection reuse. This is important for performance when+-- multiple requests go to a single server, particularly if TLS is+-- being used.+--+-- * Transparent cookie management. Any cookies set by the server+-- persist from one request to the next. (Bypass this overhead+-- using 'newAPISession'.)+--+--+-- This module is designed to be used alongside the "Network.Wreq"+-- module. Typical usage will look like this:+--+-- @+-- import "Network.Wreq"+-- import qualified "Network.Wreq.Session" as Sess+--+-- main = do+-- sess <- Sess.'newSession'+-- Sess.'get' sess \"http:\/\/httpbin.org\/get\"+-- @+--+-- 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 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@@ -11,6 +66,7 @@ , options , put , delete+ , customMethod -- ** Configurable verbs , getWith , postWith@@ -18,80 +74,225 @@ , optionsWith , putWith , deleteWith+ , customMethodWith+ , customPayloadMethodWith+ , customHistoriedMethodWith+ , customHistoriedPayloadMethodWith+ -- * Extending a session+ , Lens.seshRun ) where -import Control.Concurrent.MVar (MVar, modifyMVar, newMVar)-import Control.Lens ((&), (.~), (^.))-import Network.Wreq (Options, Response, defaults)-import Network.Wreq.Internal (defaultManagerSettings)-import Network.Wreq.Types (Postable, Putable)+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(..), 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 -data Session = Session {- seshCookies :: MVar HTTP.CookieJar- , seshManager :: HTTP.Manager- }+-- | 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 act = newSession >>= act+{-# DEPRECATED withSession "Use newSession instead." #-} -instance Show Session where- show _ = "Session"+-- | 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 -withSession :: (Session -> IO a) -> IO a-withSession act = do- mv <- newMVar $ HTTP.createCookieJar []- HTTP.withManager defaultManagerSettings $ \mgr ->- act Session { seshCookies = mv, seshManager = mgr }+-- | 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 = 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 +-- | 'Session'-specific version of 'Network.Wreq.post'. post :: Postable a => Session -> String -> a -> IO (Response L.ByteString) post = postWith defaults +-- | '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 ()) options = optionsWith defaults +-- | 'Session'-specific version of 'Network.Wreq.put'. put :: Putable a => Session -> String -> a -> IO (Response L.ByteString) put = putWith defaults -delete :: Session -> String -> IO (Response ())+-- | 'Session'-specific version of 'Network.Wreq.delete'.+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 =- override opts sesh $ \opts' -> Wreq.getWith opts' url+getWith opts sesh url = run string sesh =<< prepareGet opts url +-- | 'Session'-specific version of 'Network.Wreq.postWith'. postWith :: Postable a => Options -> Session -> String -> a -> IO (Response L.ByteString) postWith opts sesh url payload =- override opts sesh $ \opts' -> Wreq.postWith opts' url payload+ run string sesh =<< preparePost opts url payload +-- | 'Session'-specific version of 'Network.Wreq.headWith'. headWith :: Options -> Session -> String -> IO (Response ())-headWith opts sesh url =- override opts sesh $ \opts' -> Wreq.headWith opts' url+headWith opts sesh url = run ignore sesh =<< prepareHead opts url +-- | 'Session'-specific version of 'Network.Wreq.optionsWith'. optionsWith :: Options -> Session -> String -> IO (Response ())-optionsWith opts sesh url =- override opts sesh $ \opts' -> Wreq.optionsWith opts' url+optionsWith opts sesh url = run ignore sesh =<< prepareOptions opts url +-- | 'Session'-specific version of 'Network.Wreq.putWith'. putWith :: Putable a => Options -> Session -> String -> a -> IO (Response L.ByteString)-putWith opts sesh url payload =- override opts sesh $ \opts' -> Wreq.putWith opts' url payload+putWith opts sesh url payload = run string sesh =<< preparePut opts url payload -deleteWith :: Options -> Session -> String -> IO (Response ())-deleteWith opts sesh url =- override opts sesh $ \opts' -> Wreq.deleteWith opts' url+-- | 'Session'-specific version of 'Network.Wreq.deleteWith'.+deleteWith :: Options -> Session -> String -> IO (Response L.ByteString)+deleteWith opts sesh url = run string sesh =<< prepareDelete opts url -override :: Options -> Session -> (Options -> IO (Response body))- -> IO (Response body)-override opts Session{..} act =- modifyMVar seshCookies $ \cj -> do- resp <- act $ opts & Wreq.cookies .~ cj &- Wreq.manager .~ Right seshManager- return (resp ^. Wreq.responseCookieJar, resp)+-- | '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 = 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 (), const NoBody, runIgnore)
Network/Wreq/Types.hs view
@@ -17,9 +17,12 @@ -- * Client configuration Options(..) , Auth(..)+ , AWSAuthVersion(..)+ , ResponseChecker -- * Request payloads , Payload(..) , Postable(..)+ , Patchable(..) , Putable(..) -- ** URL-encoded forms , FormParam(..)@@ -29,13 +32,18 @@ , Link(..) -- * Errors , JSONError(..)+ -- * Request handling+ , Req+ , reqURL+ , Run ) 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@@ -47,37 +55,54 @@ import qualified Network.HTTP.Client as HTTP import qualified Network.Wreq.Internal.Lens as Lens -instance Postable Part where- postPayload a = postPayload [a]--instance Postable [Part] where- postPayload = formDataBody--instance Postable [(S.ByteString, S.ByteString)] where- postPayload ps req = return $ HTTP.urlEncodedBody ps req--instance Postable (S.ByteString, S.ByteString) where- postPayload p = postPayload [p]+-- By default if the type is Putable, we use that as postPayload+instance Postable Part+instance Postable [Part]+instance Postable [(S.ByteString, S.ByteString)]+instance Postable (S.ByteString, S.ByteString)+instance Postable [FormParam]+instance Postable FormParam+instance Postable Payload+instance Postable S.ByteString+instance Postable L.ByteString+instance Postable Value+instance Postable Encoding -instance Postable [FormParam] where- postPayload ps = postPayload (map f ps)- where f (a := b) = (a, renderFormValue b)+-- By default if the type is Putable, we use that as patchPayload+instance Patchable Part+instance Patchable [Part]+instance Patchable [(S.ByteString, S.ByteString)]+instance Patchable (S.ByteString, S.ByteString)+instance Patchable [FormParam]+instance Patchable FormParam+instance Patchable Payload+instance Patchable S.ByteString+instance Patchable L.ByteString+instance Patchable Value+instance Patchable Encoding -instance Postable FormParam where- postPayload p = postPayload [p]+instance Putable Part where+ putPayload a = putPayload [a] -instance Postable Payload where- postPayload = putPayload+instance Putable [Part] where+ putPayload p req =+ -- According to doc, formDataBody changes the request type to POST which is wrong; change it back+ (\r -> r{method=method req}) `fmap` formDataBody p req -instance Postable S.ByteString where- postPayload = putPayload+instance Putable [(S.ByteString, S.ByteString)] where+ putPayload ps req =+ -- According to doc, urlEncodedBody changes the request type to POST which is wrong; change it back+ return $ HTTP.urlEncodedBody ps req {method=method req} -instance Postable L.ByteString where- postPayload = putPayload+instance Putable (S.ByteString, S.ByteString) where+ putPayload p = putPayload [p] -instance Postable Value where- postPayload = putPayload+instance Putable [FormParam] where+ putPayload ps = putPayload (map f ps)+ where f (a := b) = (a, renderFormValue b) +instance Putable FormParam where+ putPayload p = putPayload [p] instance Putable Payload where putPayload pl =@@ -93,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@@ -134,6 +162,7 @@ renderFormValue (Just a) = renderFormValue a renderFormValue Nothing = "" -payload :: ContentType -> HTTP.RequestBody -> Request -> IO Request-payload ct body req = return $ req & Lens.setHeader "Content-Type" ct &- Lens.requestBody .~ body+payload :: S.ByteString -> HTTP.RequestBody -> Request -> IO Request+payload ct body req =+ return $ req & Lens.maybeSetHeader "Content-Type" ct+ & Lens.requestBody .~ body
README.md view
@@ -1,9 +1,8 @@-# wreq: a Haskell web client library+# wreq: a Haskell web client library [](https://travis-ci.org/bos/wreq) `wreq` is a library that makes HTTP client programming in Haskell easy. - # Features * Simple but powerful `lens`-based API@@ -23,6 +22,14 @@ * Basic and OAuth2 bearer authentication +* Amazon Web Services (AWS) request signing (Version 4)++* AWS signing supports sending requests through the+ [Runscope Inc.](https://www.runscope.com) Traffic Inspector++# Tutorials++See [the tutorials](http://www.serpentine.com/wreq/) for a quick-start. # Is it done?
Setup.hs view
@@ -1,64 +1,33 @@--- I don't know who originally wrote this, but I picked it up from--- Edward Kmett's folds package.-+{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wall #-} module Main (main) where -import Data.List (nub)-import Data.Version (showVersion)-import Distribution.Package- (PackageName(PackageName), Package, PackageId, InstalledPackageId,- packageVersion, packageName)-import Distribution.PackageDescription (PackageDescription(), TestSuite(..))-import Distribution.Simple- (defaultMainWithHooks, UserHooks(..), simpleUserHooks)-import Distribution.Simple.BuildPaths (autogenModulesDir)-import Distribution.Simple.LocalBuildInfo- (withLibLBI, withTestLBI, LocalBuildInfo(),- ComponentLocalBuildInfo(componentPackageDeps))-import Distribution.Simple.Setup- (BuildFlags(buildVerbosity), Flag(..), fromFlag,- HaddockFlags(haddockDistPref))-import Distribution.Simple.Utils- (rewriteFile, createDirectoryIfMissingVerbose, copyFiles)-import Distribution.Text (display)-import Distribution.Verbosity (Verbosity, normal)-import System.FilePath ((</>))+#ifndef MIN_VERSION_cabal_doctest+#define MIN_VERSION_cabal_doctest(x,y,z) 0+#endif +#if MIN_VERSION_cabal_doctest(1,0,0)++import Distribution.Extra.Doctest ( defaultMainWithDoctests ) main :: IO ()-main = defaultMainWithHooks simpleUserHooks- { buildHook = \pkg lbi hooks flags -> do- generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi- buildHook simpleUserHooks pkg lbi hooks flags- , postHaddock = \args flags pkg lbi -> do- copyFiles normal (haddockOutputDir flags pkg) []- postHaddock simpleUserHooks args flags pkg lbi- }+main = defaultMainWithDoctests "doctests" -haddockOutputDir :: Package p => HaddockFlags -> p -> FilePath-haddockOutputDir flags pkg = destDir where- baseDir = case haddockDistPref flags of- NoFlag -> "."- Flag x -> x- destDir = baseDir </> "doc" </> "html" </> display (packageName pkg)+#else -generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo- -> IO ()-generateBuildModule verbosity pkg lbi = do- let dir = autogenModulesDir lbi- createDirectoryIfMissingVerbose verbosity True dir- withLibLBI pkg lbi $ \_ libcfg -> do- withTestLBI pkg lbi $ \suite suitecfg -> do- rewriteFile (dir </> "Build_" ++ testName suite ++ ".hs") $ unlines- [ "module Build_" ++ testName suite ++ " where"- , "deps :: [String]"- , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg))- ]- where- formatdeps = map (formatone . snd)- formatone p = case packageName p of- PackageName n -> n ++ "-" ++ showVersion (packageVersion p)+#ifdef MIN_VERSION_Cabal+-- If the macro is defined, we have new cabal-install,+-- but for some reason we don't have cabal-doctest in package-db+--+-- Probably we are running cabal sdist, when otherwise using new-build+-- workflow+#warning You are configuring this package without cabal-doctest installed. \+ The doctests test-suite will not work as a result. \+ To fix this, install cabal-doctest before configuring.+#endif -testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo- -> [(InstalledPackageId, PackageId)]-testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys+import Distribution.Simple++main :: IO ()+main = defaultMain++#endif
TODO.md view
@@ -2,8 +2,6 @@ * More advanced tutorial-style documentation -* TLS server certificate verification- * An example that spiders a Haddock package's docs to validate its internal and external links @@ -17,3 +15,5 @@ * Some poor sod needs to add digest authentication to `http-client` so we can use it++* Cache management
− changelog
@@ -1,9 +0,0 @@--*- markdown -*---2014-08-25 0.2.0.0--* Support for lens 4.4--2014-04-22 0.1.0.0--* Initial release.
+ changelog.md view
@@ -0,0 +1,135 @@+-*- 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++* New customMethod, customMethodWith functions allow use of arbitrary+ HTTP verbs++* 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++* Initial release.
+ examples/SimpleSession.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE OverloadedStrings #-}++import Control.Lens+import Network.Wreq+import qualified Network.Wreq.Session as S++main :: IO ()+main = S.withSession $ \sess -> do+ -- Our first request causes the httpbin.org server to set a cookie+ -- in its response.++ S.get sess "http://httpbin.org/cookies/set?name=hi"++ -- The session value manages both cookies and HTTP connection reuse+ -- for us. When we issue the second request, it should+ -- transparently reuse the same connection, and also send the+ -- cookies that we set during the first request.++ r2 <- S.post sess "http://httpbin.org/post" ["a" := (3 :: Int)]++ -- And here's where we verify that the cookie is still set on the+ -- second request.++ print $ r2 ^. responseCookie "name" . cookieValue
examples/UploadPaste.hs view
@@ -12,14 +12,16 @@ {-# 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 hiding ((&), header)+import Options.Applicative as Opts+import Options.Applicative.Types (readerAsk) import System.FilePath (takeExtension, takeFileName) import Text.HTML.TagSoup import qualified Data.ByteString.Char8 as B@@ -97,8 +99,9 @@ -- Try to match a user-supplied name to a Language type, looking at -- both full names and filename extensions.-readLanguage :: Monad m => String -> m Language-readLanguage l = do+readLanguage :: ReadM Language+readLanguage = do+ l <- readerAsk let ll = toLower <$> l ms = [lang | (suffixes, lang) <- languages, ll == (toLower <$> show lang) || ll `elem` (tail <$> suffixes)]@@ -158,9 +161,9 @@ (optional . fmap Channel . strOption $ long "channel" <> short 'c' <> metavar "CHANNEL" <> help "name of IRC channel to announce") <*>- (optional . nullOption $+ (optional . option readLanguage $ long "language" <> short 'l' <> metavar "LANG" <>- help "language to use" <> reader readLanguage) <*>+ help "language to use") <*> (Opts.argument str $ metavar "PATH" <> help "file to upload") <*> (pure ())
examples/wreq-examples.cabal view
@@ -20,25 +20,36 @@ aeson, base >= 4.5 && < 5, containers,- ghc-prim, lens, lens-aeson, text, wreq ++executable wreq-example-simple-session+ main-is: SimpleSession.hs+ ghc-options: -Wall -fwarn-tabs -threaded+ default-language: Haskell98++ build-depends:+ base >= 4.5 && < 5,+ lens,+ wreq+ executable upload-paste main-is: UploadPaste.hs ghc-options: -Wall -fwarn-tabs -threaded default-language: Haskell98 build-depends:- aeson >= 0.7.0.3,+ aeson, ansi-wl-pprint >= 0.6.6, base >= 4.5 && < 5, bytestring, filepath, lens,- optparse-applicative,+ optparse-applicative >= 0.11,+ mtl, tagsoup, text, wreq@@ -46,7 +57,3 @@ source-repository head type: git location: https://github.com/bos/wreq--source-repository head- type: mercurial- location: https://bitbucket.org/bos/wreq
httpbin/HttpBin.hs view
@@ -1,124 +1,7 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}---- TBD: basic-auth, gzip- module Main (main) where -import Control.Applicative ((<$>))-import Data.Aeson (Value(..), eitherDecode, object, toJSON)-import Data.Aeson.Encode.Pretty (Config(..), encodePretty')-import qualified Data.ByteString.Base64 as B64-import Data.ByteString.Char8 (pack)-import Data.CaseInsensitive (original)-import Data.Maybe (fromMaybe)-import Data.Monoid ((<>))-import Data.Text.Encoding (decodeUtf8)-import Data.Text.Read (decimal)-import Snap.Core-import Snap.Http.Server-import Snap.Util.GZip (withCompression)-import qualified Data.ByteString.Char8 as B-import qualified Data.Map as Map-import qualified Data.Text.Lazy.Encoding as Lazy--get = respond return--post = respond $ \obj -> do- body <- readRequestBody 65536- return $ obj <> [("data", toJSON (Lazy.decodeUtf8 body))] <>- case eitherDecode body of- Left _ -> [("json", Null)]- Right val -> [("json", val)]--put = post--delete = respond return--status = do- val <- (fromMaybe 200 . rqIntParam "val") <$> getRequest- let code | val >= 200 && val <= 505 = val- | otherwise = 400- modifyResponse $ setResponseCode code--gzip =- localRequest (setHeader "Accept-Encoding" "gzip") . withCompression .- respond $ \obj -> return $ obj <> [("gzipped", Bool True)]--setCookies = do- params <- rqQueryParams <$> getRequest- modifyResponse . foldr (.) id . map addResponseCookie $- [Cookie k v Nothing Nothing (Just "/") False False- | (k,vs) <- Map.toList params, v <- vs]- redirect "/cookies"--redirect_ = do- req <- getRequest- let n = fromMaybe (-1::Int) . rqIntParam "n" $ req- prefix = B.reverse . B.dropWhile (/='/') . B.reverse . rqURI $ req- case undefined of- _| n > 1 -> redirect $ prefix <> pack (show (n-1))- | n == 1 -> redirect "/get"- | otherwise -> modifyResponse $ setResponseCode 400--basicAuth = do- req <- getRequest- let unauthorized = modifyResponse $- setHeader "WWW-Authenticate" "Basic realm=\"Fake Realm\"" .- setResponseCode 401- case (rqParam "user" req, rqParam "pass" req) of- (Just [user], Just [passwd]) | not (':' `B.elem` user) ->- case getHeader "Authorization" (headers req) of- Nothing -> unauthorized- Just auth -> do- let expected = "Basic " <> B64.encode (user <> ":" <> passwd)- if auth /= expected- then unauthorized- else writeJSON [ ("user", toJSON (B.unpack user))- , ("authenticated", Bool True) ]- _ -> modifyResponse $ setResponseCode 400--rqIntParam name req =- case rqParam name req of- Just (str:_) -> case decimal (decodeUtf8 str) of- Right (n, "") -> Just n- _ -> Nothing- _ -> Nothing--writeJSON obj = do- modifyResponse $ setContentType "application/json"- writeLBS . (<> "\n") . encodePretty' (Config 2 compare) . object $ obj--respond act = do- req <- getRequest- let step m k v = Map.insert (decodeUtf8 k) (decodeUtf8 (head v)) m- 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- Nothing -> []- Just host -> [("url", toJSON . decodeUtf8 $- "http://" <> host <> rqURI req)]- writeJSON =<< act ([ ("args", toJSON params)- , ("headers", toJSON hdrs)- , ("origin", toJSON . decodeUtf8 . rqRemoteAddr $ req)- ] <> url)+import HttpBin.Server (serve)+import Snap.Http.Server.Config (commandLineConfig) -main = do- cfg <- commandLineConfig- . 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)- , ("/redirect/:n", redirect_)- , ("/status/:val", status)- , ("/gzip", methods [GET,HEAD] gzip)- , ("/cookies/set", methods [GET,HEAD] setCookies)- , ("/basic-auth/:user/:pass", methods [GET,HEAD] basicAuth)- ]+main :: IO ()+main = serve commandLineConfig
+ httpbin/HttpBin/Server.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++-- TBD: basic-auth, gzip++module HttpBin.Server (serve) where++import Control.Applicative ((<$>))+import Control.Monad.IO.Class (liftIO)+import Data.Aeson (Value(..), eitherDecode, object, toJSON)+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+import Snap.Http.Server as Snap+import Snap.Util.GZip (withCompression)+import System.PosixCompat.Time (epochTime)+import qualified Data.ByteString.Base64 as B64+import qualified Data.ByteString.Char8 as B+import qualified Data.Map as Map+import qualified Data.Text.Lazy.Encoding as Lazy++get = respond return++post = respond $ \obj -> do+ body <- readRequestBody 65536+ return $ obj <> [("data", toJSON (Lazy.decodeUtf8 body))] <>+ case eitherDecode body of+ Left _ -> [("json", Null)]+ Right val -> [("json", val)]++put = post++delete = respond return++status = do+ val <- (fromMaybe 200 . rqIntParam "val") <$> getRequest+ let code | val >= 200 && val <= 505 = val+ | otherwise = 400+ modifyResponse $ setResponseCode code++gzip =+ 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 $+ [Cookie k v Nothing Nothing (Just "/") False False+ | (k,vs) <- Map.toList params, v <- vs]+ redirect "/cookies"++listCookies = do+ cks <- rqCookies <$> getRequest+ let cs = [(fromText(decodeUtf8 (cookieName c)),+ toJSON (decodeUtf8 (cookieValue c))) | c <- cks]+ respond $ \obj -> return $ obj <> [("cookies", object cs)]++redirect_ = do+ req <- getRequest+ let n = fromMaybe (-1::Int) . rqIntParam "n" $ req+ prefix = B.reverse . B.dropWhile (/='/') . B.reverse . rqURI $ req+ case undefined of+ _| n > 1 -> redirect $ prefix <> pack (show (n-1))+ | n == 1 -> redirect "/get"+ | otherwise -> modifyResponse $ setResponseCode 400++unauthorized = modifyResponse $+ setHeader "WWW-Authenticate" "Basic realm=\"Fake Realm\"" .+ setResponseCode 401++simpleAuth expect = do+ req <- getRequest+ case expect req of+ Nothing -> modifyResponse $ setResponseCode 400+ Just (expected, resp) ->+ case getHeader "Authorization" (headers req) of+ Nothing -> unauthorized+ Just auth | auth == expected -> writeJSON $+ resp <> [("authenticated", Bool True)]+ | otherwise -> unauthorized++basicAuth = simpleAuth $ \req ->+ case (rqParam "user" req, rqParam "pass" req) of+ (Just [user], Just [passwd]) | not (':' `B.elem` user) ->+ Just ("Basic " <> B64.encode (user <> ":" <> passwd),+ [("user", toJSON (B.unpack user))])+ _ -> Nothing++oauth2token = simpleAuth $ \req ->+ case (rqParam "kind" req, rqParam "token" req) of+ (Just [kind], Just [token]) ->+ Just (kind <> " " <> token,+ [("token", toJSON (B.unpack token))])+ _ -> Nothing++cache = do+ hdrs <- headers <$> getRequest+ let cond = not . null . catMaybes . map (flip getHeader hdrs) $+ ["If-Modified-Since", "If-None-Match"]+ if cond+ then modifyResponse $ setResponseCode 304+ else do+ now <- liftIO $ formatHttpTime =<< epochTime+ uuid <- liftIO nextRandom+ modifyResponse $ setHeader "Last-Modified" now .+ setHeader "ETag" (toASCIIBytes uuid)+ respond return++rqIntParam name req =+ case rqParam name req of+ Just (str:_) -> case decimal (decodeUtf8 str) of+ Right (n, "") -> Just n+ _ -> Nothing+ _ -> Nothing++writeJSON obj = do+ modifyResponse $ setContentType "application/json"+ writeLBS . (<> "\n") . encodePretty' defConfig { confIndent = Spaces 2, confCompare = compare } . object $ obj++respond act = do+ req <- getRequest+ let step m k v = Map.insert (decodeUtf8 k) (decodeUtf8 (head v)) m+ params = Map.foldlWithKey' step Map.empty .+ rqQueryParams $ req+ wibble (k,v) = (decodeUtf8 (original k), decodeUtf8 v)+ 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 . 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", meths [GET,HEAD] get)+ , ("/post", meth POST post)+ , ("/put", meth PUT put)+ , ("/delete", meth DELETE delete)+ , ("/redirect/:n", redirect_)+ , ("/status/:val", status)+ , ("/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)+ ]
+ tests/AWS.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE ScopedTypeVariables #-}++{-+A set of end to end Amazon Web Services (AWS) tests to make sure we+can access a number of AWS services that use various AWS request+formats.++These tests help us guard against errors we may otherwise introduce+while refactoring or extending Wreq. The tests are not meant to+exercise the features of the respective AWS services exhaustively.++** ASSUMPTIONS **+To configure and run these tests you need an AWS account. We assume+that you are familiar with AWS concepts and the charging model.++** ENABLING AWS TESTS **+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:+ $ /bin/env WREQ_AWS_ACCESS_KEY_ID='...' \+ WREQ_AWS_SECRET_ACCESS_KEY='...' \+ cabal test++** CHARGES/COST **+These tests may incur small amounts of AWS charges for the minimum+DynamoDB IOs per second they provision and for the messages sent to+AWS SQS and objects stored in S3. These charges consume only a tiny+fraction of the AWS free tier allowance (if not used up otherwise).++** AWS REGIONS **+Tests are executed against the AWS Region `us-west-2` by default. You+can change the region by setting the AWS_REGION environment variable+(e.g. /bin/env WREQ_AWS_REGION=eu-west-1 cabal test).++In the case of S3, we translate 'us-east-1' to+'s3-external-1.amazonaws.com' denoting the Virginia (only) endpoint.+(see http://docs.aws.amazon.com/general/latest/gr/rande.html#s3_region).++** AWS USER AND LEAST PRIVILEDGE POLICY **+The file `tests/AWS/policy.json` contains the least priviledge "AWS+Identity and Access (IAM)" policy sufficient to run these tests. It is+a best security practice to run the tests using an AWS IAM user you+created specifically for this purpose. Use the AWS IAM Management+Console to create a new user, get the WREQ_AWS_ACCESS_KEY and+WREQ_AWS_SECRET_KEY for that user and apply the policy to the user to+limit its priviledges.++**AVOID AWS RESOURCE NAME COLLISIONS IN CONCURRENT TESTS**+To run tests concurrently in same AWS account, set the environment+variable WREQ_AWS_TEST_PREFIX to a unique string for each test client+or machine. The default prefix used for all resources created+(e.g. DynamoDB tables, SQS queues, S3 buckets, etc.) is+`deleteWreqTest`.+-}++module AWS (tests) where++import Control.Exception as E (IOException, catch)+import Control.Lens+import Data.ByteString.Char8 as BS8 (pack)+import Data.IORef (newIORef)+import Network.Info (getNetworkInterfaces, mac, ipv6)+import Network.Wreq+import System.Environment (getEnv)+import Test.Framework (Test, testGroup)+import qualified AWS.DynamoDB (tests)+import qualified AWS.IAM (tests)+import qualified AWS.S3 (tests)+import qualified AWS.SQS (tests)++tests :: IO Test+tests = 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 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 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+ 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
+ tests/AWS/Aeson.hs view
@@ -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)
+ tests/AWS/DynamoDB.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE OverloadedLists, OverloadedStrings #-}+module AWS.DynamoDB (tests) where++import AWS.Aeson+import Control.Concurrent (threadDelay)+import Control.Lens hiding ((.=))+import Data.Aeson.Lens (key, _String, values, _Double)+import Data.Text as T (pack)+import Network.Wreq+import System.Timeout (timeout)+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit (assertBool, assertFailure)++-- FIXME: retry create call in case the table is in DELETING state+-- from a previous test run (error 'Table already exists: ...'). For+-- now 'create' testcase and all others will fails. Rerun when ongoing+-- delete operation is complete.++tests :: String -> String -> Options -> Test+tests prefix region baseopts = testGroup "dynamodb" [+ testCase "createTable" $ createTable prefix region baseopts+ , testCase "listTables" $ listTables prefix region baseopts+ , testCase "awaitTableActive" $ awaitTableActive prefix region baseopts+ , testCase "putItem" $ putItem prefix region baseopts+ , testCase "getItem" $ getItem prefix region baseopts+ , testCase "deleteItem" $ deleteItem prefix region baseopts+ , testCase "deleteTable" $ deleteTable prefix region baseopts -- call last+ ]++createTable :: String -> String -> Options -> IO ()+createTable prefix region baseopts = do+ let opts = baseopts+ & header "X-Amz-Target" .~ ["DynamoDB_20120810.CreateTable"]+ & header "Content-Type" .~ ["application/x-amz-json-1.0"]+ r <- postWith opts (url region) $+ 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" $+ r ^. responseBody . key "TableDescription" . key "TableStatus" . _String == "CREATING"+ assertBool "createTables no items in new table" $+ r ^? responseBody . key "TableDescription" . key "ItemCount" . _Double == Just 0++listTables :: String -> String -> Options -> IO ()+listTables prefix region baseopts = do+ let opts = baseopts+ & 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) $ object ["Limit" .= 100]+ assertBool "listTables 200" $ r ^. responseStatus . statusCode == 200+ assertBool "listTables OK" $ r ^. responseStatus . statusMessage == "OK"+ assertBool "listTables contains test table" $+ elem (T.pack $ prefix ++ tablename)+ (r ^.. responseBody . key "TableNames" . values . _String)++awaitTableActive :: String -> String -> Options -> IO ()+awaitTableActive prefix region baseopts = do+ let dur = 45 -- typically ACTIVE in 20s or less (us-west-2, Sept 2014)+ res <- timeout (dur*1000*1000) check+ case res of+ Nothing ->+ assertFailure $ "timeout: table not ACTIVE after " ++ show dur ++ "s"+ Just () ->+ return () -- PASS+ where+ check = do+ let opts = baseopts+ & header "X-Amz-Target" .~ ["DynamoDB_20120810.DescribeTable"]+ & header "Content-Type" .~ ["application/x-amz-json-1.0"]+ 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 "."+ case r ^. responseBody . key "Table" . key "TableStatus" . _String of+ "ACTIVE" ->+ return ()+ _ -> do+ threadDelay $ 5*1000*1000 -- 5 sleep+ check++deleteTable :: String -> String -> Options -> IO ()+deleteTable prefix region baseopts = do+ let opts = baseopts+ & header "X-Amz-Target" .~ ["DynamoDB_20120810.DeleteTable"]+ & header "Content-Type" .~ ["application/x-amz-json-1.0"]+ r <- postWith opts (url region) $+ object ["TableName" .= string (prefix ++ tablename)]+ assertBool "deleteTable 200" $ r ^. responseStatus . statusCode == 200+ assertBool "deleteTable OK" $ r ^. responseStatus . statusMessage == "OK"++putItem :: String -> String -> Options -> IO ()+putItem prefix region baseopts = do+ let opts = baseopts+ & header "X-Amz-Target" .~ ["DynamoDB_20120810.PutItem"]+ & header "Content-Type" .~ ["application/x-amz-json-1.0"]+ r <- postWith opts (url region) $+ 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"++getItem :: String -> String -> Options -> IO ()+getItem prefix region baseopts = do+ let opts = baseopts+ & header "X-Amz-Target" .~ ["DynamoDB_20120810.GetItem"]+ & header "Content-Type" .~ ["application/x-amz-json-1.0"]+ r <- postWith opts (url region) $+ 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" $+ r ^. responseBody . key "Item" . key "bar" . key "S" . _String == "baz"++deleteItem :: String -> String -> Options -> IO ()+deleteItem prefix region baseopts = do+ let opts = baseopts+ & header "X-Amz-Target" .~ ["DynamoDB_20120810.DeleteItem"]+ & header "Content-Type" .~ ["application/x-amz-json-1.0"]+ r <- postWith opts (url region) $+ 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"++url :: String -> String+url region =+ "https://dynamodb." ++ region ++ ".amazonaws.com/"++tablename :: String+tablename =+ "test"
+ tests/AWS/IAM.hs view
@@ -0,0 +1,243 @@+{-# LANGUAGE OverloadedLists, OverloadedStrings, DeriveGeneric #-}+module AWS.IAM (tests) where++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 -> 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 ()+listUsers _prefix region baseopts = do+ let opts = baseopts+ & param "Action" .~ ["ListUsers"]+ & param "Version" .~ ["2010-05-08"]+ & header "Accept" .~ ["application/json"]+ r <- getWith opts (iamUrl region)+ assertBool "listUsers 200" $ r ^. responseStatus . statusCode == 200+ assertBool "listUsers OK" $ r ^. responseStatus . statusMessage == "OK"++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::<acct>: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::<acct>:role/ec2-role"+ let arns' = map (T.unpack . last . T.split (=='/')) arns+ assertBool "listRoles contains test role" $+ elem (prefix ++ roleName) arns'++ where+ conv :: DAT.FromJSON a => Maybe DAT.Value -> a+ conv v = case v of+ Nothing -> error "1"+ Just x ->+ case A.fromJSON x of+ A.Success r ->+ r+ A.Error e ->+ error $ show e++iamUrl :: String -> String+iamUrl _ =+ "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:<acct>.+ -- 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" .= ["*"]+ ]+ ]+ ]
+ tests/AWS/S3.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE OverloadedLists, OverloadedStrings #-}+module AWS.S3 (tests) where++import AWS.Aeson+import Control.Lens hiding ((.=))+import Data.Char (toLower)+import Data.Monoid ((<>))+import Network.Wreq+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit (assertBool)+import qualified Data.ByteString.Char8 as BS8 (ByteString, pack)++-- FIXME: retry create call in case we get the S3 specific "A+-- conflicting conditional operation is currently in progress against+-- this resource. Please try again." error from a previous test run+-- that is still deleting the test bucket. For now the 'create'+-- testcase and all others will fails.++tests :: String -> String -> Options -> Test+tests prefix region baseopts = let+ lowerPrefix = map toLower prefix+ 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") ]++-- 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 :: 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 :: 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 :: 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 :: 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+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 "external-1" = "" -- no loc needed for Virginia+locationConstraint region = "<CreateBucketConfiguration xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\"><LocationConstraint>" <> BS8.pack region <> "</LocationConstraint></CreateBucketConfiguration>"
+ tests/AWS/SQS.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE OverloadedStrings #-}+module AWS.SQS (tests) where++import Control.Lens+import Data.Aeson.Lens (key, _String, values)+import Data.IORef (IORef, readIORef, writeIORef)+import Data.Text as T (Text, pack, unpack, split)+import Network.Wreq+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit (assertBool)++-- FIXME: retry create call in case we get the SQS specific "wait 1+-- min after delete" error from a previous test run. For now the+-- 'create' testcase and all others will fails. Rerun after awaiting+-- the SQS 1 min window.++tests :: String -> String -> Options -> IORef String -> Test+tests prefix region baseopts sqsTestState = testGroup "sqs" [+ testCase "createQueue" $ createQueue prefix region baseopts sqsTestState+ , testCase "listQueues" $ listQueues prefix region baseopts+ , testCase "sendMessage" $ sendMessage prefix region baseopts sqsTestState+ , testCase "receiveMessage" $ receiveMessage prefix region baseopts sqsTestState+ , testCase "deleteQueue" $ deleteQueue prefix region baseopts sqsTestState+ ]++createQueue :: String -> String -> Options -> IORef String -> IO ()+createQueue prefix region baseopts sqsTestState = do+ let opts = baseopts+ & param "Action" .~ ["CreateQueue"]+ & param "QueueName" .~ [T.pack $ prefix ++ queuename]+ & param "Version" .~ ["2009-02-01"]+ & header "Accept" .~ ["application/json"]+ r <- getWith opts (url region)+ assertBool "listQueues 200" $ r ^. responseStatus . statusCode == 200+ assertBool "listQueues OK" $ r ^. responseStatus . statusMessage == "OK"+ let qurl = r ^. responseBody . key "CreateQueueResponse"+ . key "CreateQueueResult"+ . key "QueueUrl"+ . _String+ writeIORef sqsTestState $ acctFromQueueUrl qurl++listQueues :: String -> String -> Options -> IO ()+listQueues prefix region baseopts = do+ let opts = baseopts+ & param "Action" .~ ["ListQueues"]+ & param "Version" .~ ["2009-02-01"]+ & header "Accept" .~ ["application/json"]+ r <- getWith opts (url region)+ assertBool "listQueues 200" $ r ^. responseStatus . statusCode == 200+ assertBool "listQueues OK" $ r ^. responseStatus . statusMessage == "OK"+ let qurls = r ^.. responseBody . key "ListQueuesResponse" .+ key "ListQueuesResult" .+ key "queueUrls" .+ values . _String+ -- url of form: https://sqs.<region>.amazon.com/<acct>/<queuename>+ let qurls' = map (T.unpack . last . T.split (=='/')) qurls+ assertBool "listQueues contains test queue" $+ elem (prefix ++ queuename) qurls'++deleteQueue :: String -> String -> Options -> IORef String -> IO ()+deleteQueue prefix region baseopts sqsTestState = do+ acct <- readIORef sqsTestState+ let opts = baseopts+ & param "Action" .~ ["DeleteQueue"]+ & param "Version" .~ ["2009-02-01"]+ & header "Accept" .~ ["application/json"]+ r <- getWith opts (url region ++ acct ++ "/" ++ prefix ++ queuename)+ assertBool "deleteQueues 200" $ r ^. responseStatus . statusCode == 200+ assertBool "deleteQueues OK" $ r ^. responseStatus . statusMessage == "OK"++sendMessage :: String -> String -> Options -> IORef String -> IO ()+sendMessage prefix region baseopts sqsTestState = do+ acct <- readIORef sqsTestState+ let opts = baseopts+ & param "Action" .~ ["SendMessage"]+ & param "Version" .~ ["2012-11-05"]+ & param "MessageBody" .~ ["uffda"]+ & header "Accept" .~ ["application/json"]+ r <- getWith opts (url region ++ acct ++ "/" ++ prefix ++ queuename)+ assertBool "sendMessage 200" $ r ^. responseStatus . statusCode == 200+ assertBool "sendMessage OK" $ r ^. responseStatus . statusMessage == "OK"++receiveMessage :: String -> String -> Options -> IORef String -> IO ()+receiveMessage prefix region baseopts sqsTestState = do+ acct <- readIORef sqsTestState+ let opts = baseopts+ & param "Action" .~ ["ReceiveMessage"]+ & param "Version" .~ ["2009-02-01"]+ & header "Accept" .~ ["application/json"]+ r <- getWith opts (url region ++ acct ++ "/" ++ prefix ++ queuename)+ let [msg] = map T.unpack $ r ^.. responseBody . -- we sent only 1 message+ key "ReceiveMessageResponse" .+ key "ReceiveMessageResult" .+ key "messages" .+ values .+ key "Body" .+ _String+ assertBool "receiveMessage 200" $ r ^. responseStatus . statusCode == 200+ assertBool "receiveMessage OK" $ r ^. responseStatus . statusMessage == "OK"+ assertBool "receiveMessage match content" $ msg == "uffda"++url :: String -> String+url region =+ "https://sqs." ++ region ++ ".amazonaws.com/"++queuename :: String+queuename =+ "test"++-- url of form: https://sqs.<region>.amazon.com/<acct>/<queuename>+acctFromQueueUrl :: T.Text -> String+acctFromQueueUrl qurl =+ case T.split (=='/') qurl of+ _:_:_:acct:_ ->+ T.unpack acct+ _ ->+ "dummy"
− tests/DocTests.hs
@@ -1,47 +0,0 @@--- I don't know who originally wrote this, but I picked it up from--- Edward Kmett's folds package, and subsequently modified it.--module Main where--import Build_doctest (deps)-import Control.Applicative ((<$>), (<*>))-import Control.Monad (filterM)-import Data.List (isPrefixOf, isSuffixOf)-import System.Directory--- import System.Environment (getArgs)-import System.FilePath ((</>))-import Test.DocTest (doctest)--main :: IO ()-main = do- -- doctest chokes on the command line args that cabal test passes in- -- args <- getArgs- let args = []- srcs <- getSources- dist <- getDistDir- doctest $ args ++ [ "-i."- , "-i" ++ dist ++ "/build/autogen"- , "-optP-include"- , "-optP" ++ dist ++ "/build/autogen/cabal_macros.h"- , "-hide-all-packages"- ] ++ map ("-package="++) deps ++ srcs--getSources :: IO [FilePath]-getSources = filter (isSuffixOf ".hs") <$> go "Network"- where- go dir = do- (dirs, files) <- getFilesAndDirectories dir- (files ++) . concat <$> mapM go dirs--getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])-getFilesAndDirectories dir = do- c <- map (dir </>) . filter (`notElem` ["..", "."]) <$>- getDirectoryContents dir- (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c--getDistDir :: IO FilePath-getDistDir = do- names <- getDirectoryContents "dist"- return $ case filter ("dist-sandbox-" `isPrefixOf`) names of- (d:_) -> "dist/" ++ d- _ -> "dist"
+ tests/Properties/Store.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE RecordWildCards #-}++module Properties.Store+ (+ tests+ ) where++import Data.Functor ((<$>))+import Data.Hashable (Hashable)+import Data.List (foldl', sort, sortBy)+import Data.Maybe (listToMaybe)+import Data.Ord (comparing)+import Network.Wreq.Cache.Store as S+import Test.Framework (Test)+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck (Positive(..), Small(..))++data StoreModel k v = StoreModel {+ smCap :: Int+ , smGen :: Int+ , smSize :: Int+ , smList :: [(k,v,Int)]+ } deriving (Show)++emptySM :: Int -> StoreModel k v+emptySM n = StoreModel n 0 0 []++insertSM :: Eq k => k -> v -> StoreModel k v -> StoreModel k v+insertSM k v sm@StoreModel{..}+ | smSize < smCap || present =+ sm { smGen = smGen + 1+ , smSize = if present then smSize else smSize + 1+ , smList = (k,v,smGen) : [x | x@(kk,_,_) <- smList, kk /= k]+ }+ | otherwise =+ sm { smGen = smGen + 1+ , smList = (k,v,smGen) : tail (sortBy (comparing $ \(_,_,g) -> g) smList)+ }+ where present = any (\(kk,_,_) -> k == kk) smList++lookupSM :: Eq k => k -> StoreModel k v -> Maybe (v, StoreModel k v)+lookupSM k sm@StoreModel{..} = listToMaybe+ [(v, sm') | (kk,v,_) <- smList, k == kk]+ where sm' = sm { smGen = smGen + 1+ , smList = [(kk,v,if kk == k then smGen else g)+ | (kk,v,g) <- smList]+ }++fromListSM :: Eq k => Int -> [(k,v)] -> StoreModel k v+fromListSM = foldl' (flip (uncurry insertSM)) . emptySM++toListSM :: StoreModel k v -> [(k,v)]+toListSM sm = [(k,v) | (k,v,_) <- smList sm]++unS :: (Ord k, Hashable k, Ord v) => S.Store k v -> [(k,v)]+unS = sort . S.toList++unM :: (Ord k, Ord v) => StoreModel k v -> [(k,v)]+unM = sort . toListSM++type N = Positive (Small Int)++unN :: N -> Int+unN (Positive (Small n)) = n++t_fromList :: N -> [(Char,Char)] -> Bool+t_fromList n xs = unS (S.fromList (unN n) xs) == unM (fromListSM (unN n) xs)++t_lookup :: N -> Char -> [(Char,Char)] -> Bool+t_lookup n k xs = (fmap unS <$> S.lookup k s) == (fmap unM <$> lookupSM k m)+ where+ s = S.fromList (unN n) xs+ m = fromListSM (unN n) xs++t_lookup1 :: N -> Char -> Char -> [(Char, Char)] -> Bool+t_lookup1 n k v xs = t_lookup n k ((k,v):xs)++tests :: [Test]+tests = [+ testProperty "t_fromList" t_fromList+ , testProperty "t_lookup" t_lookup+ , testProperty "t_lookup1" t_lookup1+ ]
tests/Tests.hs view
@@ -1,207 +1,23 @@-{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}-{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-missing-signatures- -fno-warn-unused-binds #-}+{-# LANGUAGE CPP #-} module Main (main) where -import Control.Applicative ((<$>))-import Control.Exception (Exception)-import Control.Lens ((^.), (^?), (.~), (&))-import Control.Monad (unless, void)-import Data.Aeson (Value(..), object)-import Data.Aeson.Lens (key)-import Data.ByteString (ByteString)-import Data.Char (toUpper)-import Data.Maybe (isJust)-import Data.Monoid ((<>))-import Data.Text (pack)-import Network.HTTP.Client (HttpException(..))-import Network.HTTP.Types.Status (status200, status401)-import Network.HTTP.Types.Version (http11)-import Network.Wreq-import Network.Wreq.Lens-import qualified Network.Wreq.Session as Session-import System.IO (hClose, hPutStr)-import System.IO.Temp (withSystemTempFile)-import Test.Framework (defaultMain, testGroup)-import Test.Framework.Providers.HUnit (testCase)-import Test.HUnit (assertBool, assertEqual, assertFailure)-import qualified Control.Exception as E-import qualified Data.Text as T--basicGet site = do- r <- get (site "/get")- assertBool "GET request has User-Agent header" $- isJust (r ^. responseBody ^? key "headers" . key "User-Agent")- -- test the various lenses- assertEqual "GET succeeds" status200 (r ^. responseStatus)- assertEqual "GET succeeds 200" 200 (r ^. responseStatus . statusCode)- assertEqual "GET succeeds OK" "OK" (r ^. responseStatus . statusMessage)- assertEqual "GET response has HTTP/1.1 version" http11 (r ^. responseVersion)- assertBool "GET response has Content-Type header" $- isJust (r ^? responseHeader "Content-Type")- assertBool "GET response has Date header" $- isJust (lookup "Date" <$> r ^? responseHeaders)--basicPost site = do- r <- post (site "/post") ("wibble" :: ByteString) >>= asValue- let body = r ^. responseBody- 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")--multipartPost site =- withSystemTempFile "foo.html" $ \name handle -> do- hPutStr handle "<!DOCTYPE html><html></html"- hClose handle- r <- post (site "/post") (partFile "html" name)- assertEqual "POST succeeds" status200 (r ^. responseStatus)--basicHead site = do- r <- head_ (site "/get")- assertEqual "HEAD succeeds" status200 (r ^. responseStatus)--basicPut site = do- r <- put (site "/put") ("wibble" :: ByteString)- assertEqual "PUT succeeds" status200 (r ^. responseStatus)--basicDelete site = do- r <- delete (site "/delete")- assertEqual "DELETE succeeds" status200 (r ^. responseStatus)--throwsStatusCode site =- assertThrows "404 causes exception to be thrown" inspect $- head_ (site "/status/404")- where inspect e = case e of- StatusCodeException _ _ _ -> return ()- _ -> assertFailure "unexpected exception thrown"--getBasicAuth 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 _ _ ->- assertEqual "failed basic auth failed GET gives 401"- status401 status- assertThrows "basic auth GET fails if password is bad" inspect $- getWith opts (site "/basic-auth/user/asswd")--getRedirect site = do- r <- get (site "/redirect/3")- let stripProto = T.dropWhile (/=':')- smap f (String s) = String (f s)- assertEqual "redirect goes to /get"- (Just . String . stripProto . pack . site $ "/get")- (smap stripProto <$> (r ^. responseBody ^? key "url"))--getParams site = do- let opts1 = defaults & param "foo" .~ ["bar"]- r1 <- getWith opts1 (site "/get")- assertEqual "params set correctly 1" (Just (object [("foo","bar")]))- (r1 ^. responseBody ^? key "args")- let opts2 = defaults & params .~ [("quux","baz")]- r2 <- getWith opts2 (site "/get")- assertEqual "params set correctly 2" (Just (object [("quux","baz")]))- (r2 ^. responseBody ^? key "args")- r3 <- getWith opts2 (site "/get?whee=wat")- assertEqual "correctly handle mix of params from URI and Options"- (Just (object [("quux","baz"),("whee","wat")]))- (r3 ^. responseBody ^? key "args")--getHeaders site = do- let opts = defaults & header "X-Wibble" .~ ["bar"]- r <- getWith opts (site "/get")- assertEqual "extra header set correctly"- (Just "bar")- (r ^. responseBody ^? key "headers" . key "X-Wibble")--getGzip site = do- r <- get (site "/gzip")- assertEqual "gzip decoded for us" (Just (Bool True))- (r ^. responseBody ^? key "gzipped")--headRedirect site =- assertThrows "HEAD of redirect throws exception" inspect $- head_ (site "/redirect/3")- where inspect e = case e of- StatusCodeException status _ _ ->- let code = status ^. statusCode- in assertBool "code is redirect"- (code >= 300 && code < 400)--redirectOverflow 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 ()--invalidURL _site = do- let noProto (InvalidUrlException _ _) = return ()- assertThrows "exception if no protocol" noProto (get "wheeee")- let noHost (InvalidDestinationHost _) = return ()- assertThrows "exception if no host" noHost (get "http://")--funkyScheme site = do- -- schemes are case insensitive, per RFC 3986 section 3.1- let (scheme, rest) = break (==':') $ site "/get"- void . get $ map toUpper scheme <> rest--cookiesSet site = do- r <- get (site "/cookies/set?x=y")- 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")--getWithManager site = withManager $ \opts -> do- void $ getWith opts (site "/get?a=b")- void $ getWith opts (site "/get?b=c")+import Test.Framework (testGroup)+import UnitTests (testWith)+import qualified Properties.Store -assertThrows :: (Show e, Exception e) => String -> (e -> IO ()) -> IO a -> IO ()-assertThrows desc inspect act = do- let myInspect e = inspect e `E.catch` \(ee :: E.PatternMatchFail) ->- assertFailure (desc <> ": unexpected exception (" <>- show e <> "): " <> show ee)- caught <- (act >> return False) `E.catch` \e -> myInspect e >> return True- unless caught (assertFailure desc)+#if defined(AWS_TESTS)+import qualified AWS (tests)+#endif -testsWith site = [- testGroup "basic" [- testCase "get" $ basicGet site- , testCase "post" $ basicPost site- , testCase "head" $ basicHead site- , testCase "put" $ basicPut site- , testCase "delete" $ basicDelete site- , testCase "404" $ throwsStatusCode site- , testCase "headRedirect" $ headRedirect site- , testCase "redirectOverflow" $ redirectOverflow site- , testCase "invalidURL" $ invalidURL site- , testCase "funkyScheme" $ funkyScheme site- ]- , testGroup "fancy" [- testCase "basic auth" $ getBasicAuth site- , testCase "redirect" $ getRedirect site- , testCase "params" $ getParams site- , testCase "headers" $ getHeaders site- , testCase "gzip" $ getGzip site- , testCase "cookiesSet" $ cookiesSet site- , testCase "cookieSession" $ cookieSession site- , testCase "getWithManager" $ getWithManager site+main :: IO ()+main = do+#if defined(AWS_TESTS)+ awsTests <- AWS.tests+#else+ let awsTests = testGroup "aws" []+#endif+ testWith [+ testGroup "store" Properties.Store.tests+ , awsTests ]- ]--tests = [- testGroup "http" $ testsWith ("http://httpbin.org" <>)- , testGroup "https" $ testsWith ("https://httpbin.org" <>)- ]--main = defaultMain tests--localtest = defaultMain (testsWith ("http://localhost:8000" <>))
+ tests/UnitTests.hs view
@@ -0,0 +1,419 @@+{-# LANGUAGE OverloadedStrings, RankNTypes, RecordWildCards,+ ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-missing-signatures+ -fno-warn-unused-binds #-}++module UnitTests (testWith) where++import Control.Applicative ((<$>))+import Control.Concurrent (forkIO, killThread)+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)+import Control.Exception (Exception, throwIO)+import Control.Lens ((^.), (^?), (.~), (?~), (&), iso, ix, Traversal')+import Control.Monad (unless, void)+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(..), HttpExceptionContent(..))+import Network.HTTP.Types.Status (status200, status401)+import Network.HTTP.Types.Version (http11)+import Network.Wreq hiding+ (get, post, head_, put, options, delete,+ getWith, postWith, headWith, putWith, optionsWith, deleteWith)+import Network.Wreq.Lens+import Network.Wreq.Types (Postable, Putable)+import Snap.Http.Server.Config+import System.IO (hClose, hPutStr)+import System.IO.Temp (withSystemTempFile)+import Test.Framework (Test, defaultMain, testGroup)+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+import qualified Network.Wreq as Wreq++data Verb = Verb {+ get :: String -> IO (Response L.ByteString)+ , getWith :: Options -> String -> IO (Response L.ByteString)+ , 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 :: 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)+ , deleteWith :: Options -> String -> IO (Response L.ByteString)+ }++basic :: Verb+basic = Verb { get = Wreq.get, getWith = Wreq.getWith, post = Wreq.post+ , postWith = Wreq.postWith, head_ = Wreq.head_+ , headWith = Wreq.headWith, put = Wreq.put+ , putWith = Wreq.putWith, options = Wreq.options+ , optionsWith = Wreq.optionsWith, delete = Wreq.delete+ , deleteWith = Wreq.deleteWith }++session :: Session.Session -> Verb+session s = Verb { get = Session.get s+ , getWith = flip Session.getWith s+ , post = Session.post s+ , postWith = flip Session.postWith s+ , head_ = Session.head_ s+ , headWith = flip Session.headWith s+ , put = Session.put s+ , putWith = flip Session.putWith s+ , options = Session.options s+ , optionsWith = flip Session.optionsWith s+ , 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" . cikey "User-Agent")+ -- test the various lenses+ assertEqual "GET succeeds" status200 (r ^. responseStatus)+ assertEqual "GET succeeds 200" 200 (r ^. responseStatus . statusCode)+ assertEqual "GET succeeds OK" "OK" (r ^. responseStatus . statusMessage)+ assertEqual "GET response has HTTP/1.1 version" http11 (r ^. responseVersion)+ assertBool "GET response has Content-Type header" $+ isJust (r ^? responseHeader "Content-Type")+ assertBool "GET response has Date header" $+ isJust (lookup "Date" <$> r ^? responseHeaders)++basicPost Verb{..} site = do+ r <- post (site "/post") ("wibble" :: ByteString) >>= asValue+ let body = r ^. responseBody+ 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" . cikey "Content-Type")++multipartPost Verb{..} site =+ withSystemTempFile "foo.html" $ \name handle -> do+ hPutStr handle "<!DOCTYPE html><html></html"+ hClose handle+ r <- post (site "/post") (partFile "html" name)+ assertEqual "POST succeeds" status200 (r ^. responseStatus)++basicHead Verb{..} site = do+ r <- head_ (site "/get")+ assertEqual "HEAD succeeds" status200 (r ^. responseStatus)++basicPut Verb{..} site = do+ r <- put (site "/put") ("wibble" :: ByteString)+ assertEqual "PUT succeeds" status200 (r ^. responseStatus)++data SolrAdd = SolrAdd+ { doc :: String+ , boost :: Float+ , overwrite :: Bool+ , commitWithin :: Integer+ }++instance ToJSON SolrAdd where+ toJSON (SolrAdd doc boost overwrite commitWithin) =+ object+ [+ "add" .= object+ [ "doc" .= toJSON doc+ , "boost" .= boost+ , "overwrite" .= overwrite+ , "commitWithin" .= commitWithin+ ]+ ]++solrAdd :: SolrAdd+solrAdd = SolrAdd "wibble" 1.0 True 10000++jsonPut Verb{..} site = do+ r <- put (site "/put") $ toJSON solrAdd+ assertEqual "toJSON PUT request has correct Content-Type header"+ (Just "application/json")+ (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" . cikey "Content-Type")++basicDelete Verb{..} site = do+ r <- delete (site "/delete")+ assertEqual "DELETE succeeds" status200 (r ^. responseStatus)++throwsStatusCode Verb{..} site =+ assertThrows "404 causes exception to be thrown" inspect $+ head_ (site "/status/404")+ 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 (HttpExceptionRequest _ e) = case e of+ StatusCodeException resp _ ->+ assertEqual "basic auth failed GET gives 401"+ 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")++getOAuth2 Verb{..} kind ctor site = do+ let opts = defaults & auth ?~ ctor "token1234"+ r <- getWith opts (site $ "/oauth2/" <> kind <> "/token1234")+ assertEqual ("oauth2 " <> kind <> " GET succeeds")+ status200 (r ^. responseStatus)+ let inspect (HttpExceptionRequest _ e) = case e of+ StatusCodeException resp _ ->+ assertEqual ("oauth2 " <> kind <> " failed GET gives 401")+ status401 (resp ^. responseStatus)+ inspect _ = assertFailure "unexpected exception thrown"+ assertThrows ("oauth2 " <> kind <> " GET fails if token is bad") inspect $+ getWith opts (site $ "/oauth2/" <> kind <> "/token123")++getRedirect Verb{..} site = do+ r <- get (site "/redirect/3")+ let stripProto = T.dropWhile (/=':')+ smap f (String s) = String (f s)+ assertEqual "redirect goes to /get"+ (Just . String . stripProto . T.pack . site $ "/get")+ (smap stripProto <$> (r ^. responseBody ^? key "url"))++getParams Verb{..} site = do+ let opts1 = defaults & param "foo" .~ ["bar"]+ r1 <- getWith opts1 (site "/get")+ assertEqual "params set correctly 1" (Just (object [("foo","bar")]))+ (r1 ^. responseBody ^? key "args")+ let opts2 = defaults & params .~ [("quux","baz")]+ r2 <- getWith opts2 (site "/get")+ assertEqual "params set correctly 2" (Just (object [("quux","baz")]))+ (r2 ^. responseBody ^? key "args")+ r3 <- getWith opts2 (site "/get?whee=wat")+ assertEqual "correctly handle mix of params from URI and Options"+ (Just (object [("quux","baz"),("whee","wat")]))+ (r3 ^. responseBody ^? key "args")++getHeaders Verb{..} site = do+ let opts = defaults & header "X-Wibble" .~ ["bar"]+ r <- getWith opts (site "/get")+ assertEqual "extra header set correctly"+ (Just "bar")+ (r ^. responseBody ^? key "headers" . cikey "X-Wibble")++getCheckStatus Verb {..} site = do+ let opts = defaults & checkResponse .~ Just customRc+ r <- getWith opts (site "/status/404")+ assertThrows "Non 404 throws error" inspect $+ getWith opts (site "/get")+ assertEqual "Status 404"+ 404+ (r ^. responseStatus . statusCode)+ where+ customRc :: ResponseChecker+ customRc _ resp+ | resp ^. responseStatus . statusCode == 404 = return ()+ customRc req resp = throwIO $ HttpExceptionRequest req (StatusCodeException (void resp) "")++ 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 = do+ assertThrows "HEAD of redirect throws exception" inspect $+ head_ (site "/redirect/3")+ 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 (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 (HttpExceptionRequest _ (InvalidDestinationHost _)) = return ()+ assertThrows "exception if no host" noHost (get "http://")++funkyScheme Verb{..} site = do+ -- schemes are case insensitive, per RFC 3986 section 3.1+ let (scheme, rest) = break (==':') $ site "/get"+ void . get $ map toUpper scheme <> rest++cookiesSet Verb{..} site = do+ r <- get (site "/cookies/set?x=y")+ assertEqual "cookies are set correctly" (Just "y")+ (r ^? responseCookie "x" . cookieValue)+++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")++assertThrows :: (Show e, Exception e) => String -> (e -> IO ()) -> IO a -> IO ()+assertThrows desc inspect act = do+ let myInspect e = inspect e `E.catch` \(ee :: E.PatternMatchFail) ->+ assertFailure (desc <> ": unexpected exception (" <>+ show e <> "): " <> show ee)+ caught <- (act >> return False) `E.catch` \e -> myInspect e >> return True+ unless caught (assertFailure desc)++commonTestsWith verb site = [+ testGroup "basic" [+ testCase "get" $ basicGet verb site+ , testCase "post" $ basicPost verb site+ , testCase "head" $ basicHead verb site+ , testCase "put" $ basicPut verb site+ , testCase "delete" $ basicDelete verb site+ , testCase "404" $ throwsStatusCode verb site+ , testCase "headRedirect" $ headRedirect verb site+ , testCase "redirectOverflow" $ redirectOverflow verb site+ , testCase "invalidURL" $ invalidURL verb site+ , testCase "funkyScheme" $ funkyScheme verb site+ ]+ , testGroup "fancy" [+ testCase "basic auth" $ getBasicAuth verb site+ , testCase "redirect" $ getRedirect verb site+ , testCase "params" $ getParams verb site+ , testCase "headers" $ getHeaders verb site+ , testCase "gzip" $ getGzip verb site+ , testCase "json put" $ jsonPut verb site+ , testCase "bytestring put" $ byteStringPut verb site+ , testCase "cookiesSet" $ cookiesSet verb site+ , testCase "getWithManager" $ getWithManager site+ , testCase "cookieSession" $ cookieSession site+ , testCase "getCheckStatus" $ getCheckStatus verb site+ ]+ ]++-- 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 = do+ s <- Session.newSession+ basicHead (session s) site+ -- will crash with (InvalidStatusLine "0")+ basicGet (session s) site++httpbinTestsWith verb site = commonTestsWith verb site <> [+ ]++-- Tests that our local httpbin clone doesn't yet support.+httpbinTests verb = [testGroup "httpbin" [+ testGroup "http" $ httpbinTestsWith verb ("http://httpbin.org" <>)+ , testGroup "https" $ httpbinTestsWith verb ("https://httpbin.org" <>)+ ]]++-- Tests that httpbin.org doesn't support.+localTests verb site = commonTestsWith verb site <> [+ testCase "oauth2 Bearer" $ getOAuth2 verb "Bearer" oauth2Bearer site+ , testCase "oauth2 token" $ getOAuth2 verb "token" oauth2Token site+ ]++startServer = do+ started <- newEmptyMVar+ let go n | n >= 100 = putMVar started Nothing+ | otherwise = do+ let port = 8000 + n+ 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)+ tid <- forkIO $ go 0+ (,) tid <$> takeMVar started++testWith :: [Test] -> IO ()+testWith tests = do+ (tid, mserv) <- startServer+ s <- Session.newSession+ flip E.finally (killThread tid) .+ defaultMain $ tests <>+ [ testGroup "plain" $ httpbinTests basic+ , testGroup "session" $ httpbinTests (session s)] <>+ case mserv of+ Nothing -> []+ Just binding -> [+ testGroup "localhost" [+ testGroup "plain" $ localTests basic (binding <>)+ , testGroup "session" $ localTests (session s) (binding <>)+ ]+ ]
+ tests/doctests.hs view
@@ -0,0 +1,12 @@+module Main where++import Build_doctests (flags, pkgs, module_sources)+import Data.Foldable (traverse_)+import Test.DocTest (doctest)++main :: IO ()+main = do+ traverse_ putStrLn args+ doctest args+ where+ args = flags ++ pkgs ++ module_sources
wreq.cabal view
@@ -1,5 +1,6 @@+cabal-version: 3.0 name: wreq-version: 0.2.0.0+version: 0.5.4.5 synopsis: An easy-to-use HTTP client library. description: .@@ -28,132 +29,204 @@ . * Early TLS support via the tls package homepage: http://www.serpentine.com/wreq-bug-reports: https://github.com/bos/wreq/issues-license: BSD3+bug-reports: https://github.com/haskell/wreq/issues+license: BSD-3-Clause license-file: LICENSE.md author: Bryan O'Sullivan <bos@serpentine.com>-maintainer: bos@serpentine.com+maintainer: Ondřej Palkovský copyright: 2014 Bryan O'Sullivan category: Web build-type: Custom-cabal-version: >=1.10-extra-source-files:+tested-with: GHC ==9.2.8 || ==9.4.8 || ==9.6.4 || ==9.10.3+extra-doc-files: README.md TODO.md- changelog+ changelog.md examples/*.cabal examples/*.hs www/*.css 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 default: False manual: True +flag developer+ description: build in developer mode+ default: False+ manual: True+ library ghc-options: -Wall -fwarn-tabs -funbox-strict-fields+ if flag(developer)+ ghc-options: -Werror default-language: Haskell98 exposed-modules: Network.Wreq+ Network.Wreq.Cache+ Network.Wreq.Cache.Store Network.Wreq.Lens Network.Wreq.Session Network.Wreq.Types other-modules: Network.Wreq.Internal+ 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:+ 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, bytestring >= 0.9,+ case-insensitive,+ containers,+ crypton >= 1.1, exceptions >= 0.5,- http-client >= 0.3.1.1,- http-client-tls >= 0.2,+ hashable,+ http-client >= 0.6,+ http-client-tls >= 0.3.3, http-types >= 0.8,- lens >= 4.4,+ lens >= 4.5, lens-aeson,+ ram, mime-types,+ time-locale-compat, template-haskell, text,- time+ time >= 1.5,+ unordered-containers -- A convenient server for testing locally, or if httpbin.org is down. executable httpbin hs-source-dirs: httpbin- main-is: HttpBin.hs- ghc-options: -Wall -fwarn-tabs -threaded+ ghc-options: -Wall -fwarn-tabs -threaded -rtsopts+ if flag(developer)+ ghc-options: -Werror default-language: Haskell98+ main-is: HttpBin.hs+ other-modules: HttpBin.Server if !flag(httpbin) 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-server >= 0.9.4.2,- text+ snap-core >= 1.0.0.0,+ snap-server >= 0.9.4.4,+ text,+ time,+ transformers,+ unix-compat,+ uuid test-suite tests type: exitcode-stdio-1.0- hs-source-dirs: tests+ hs-source-dirs: httpbin tests main-is: Tests.hs- ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -threaded+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -threaded -rtsopts+ if flag(developer)+ ghc-options: -Werror default-language: Haskell98+ other-modules:+ Properties.Store+ UnitTests+ 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,- base >= 4.5 && < 5,+ aeson-pretty >= 0.8.0,+ base >= 4.13 && < 5,+ base64-bytestring, bytestring,+ case-insensitive,+ containers,+ hashable, http-client, http-types,- lens >= 4.4,+ lens, lens-aeson,+ network-info,+ 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- default-language: Haskell98+ if flag(developer)+ ghc-options: -Werror+ default-language: Haskell2010 if !flag(doctest) buildable: False else build-depends:- base >= 4.5 && < 5,+ base >= 4.13 && < 5, directory, doctest, filepath source-repository head type: git- location: https://github.com/bos/wreq--source-repository head- type: mercurial- location: https://bitbucket.org/bos/wreq+ location: https://github.com/haskell/wreq
www/Makefile view
@@ -3,13 +3,15 @@ files := index.html tutorial.html deps = bootstrap-custom.css background.jpg install := $(files) $(deps)+destdir := $(HOME)/public_html/wreq all: $(files) install: $(files)- -mkdir -p $(HOME)/public_html/wreq- cp -a $(install) $(HOME)/public_html/wreq- cp -a $(bootstrap) $(HOME)/public_html/wreq+ -mkdir -p $(destdir)+ cp -a $(install) $(destdir)+ cp -a $(bootstrap) $(destdir)+ -chcon -R -t httpd_sys_content_t $(destdir) %.html: %.md template.html $(deps) pandoc $< -o $@ --smart --template template.html \
www/index.md view
@@ -27,16 +27,31 @@ * Basic and OAuth2 bearer authentication +* Amazon Web Services (AWS) request signing (Version 4) +* AWS signing supports sending requests through the+ [Runscope Inc.](https://www.runscope.com) Traffic Inspector+ # Whirlwind tour +All of the examples that follow assume that you are using the+[`OverloadedStrings`](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/type-class-extensions.html#overloaded-strings)+language extension, which you can enable in `ghci` as follows:+ ~~~~ {.haskell}+ghci> :set -XOverloadedStrings+~~~~++And now let's get started.++~~~~ {.haskell} ghci> import Network.Wreq ghci> r <- get "http://httpbin.org/get" ~~~~ -Its `lens`-based API is easy to learn (the tutorial walks you through-the [basics of lenses](tutorial.html#a-quick-lens-backgrounder) and+The `wreq` library's `lens`-based API is easy to learn (the tutorial+walks you through the+[basics of lenses](tutorial.html#a-quick-lens-backgrounder)) and powerful to work with. ~~~~ {.haskell}@@ -51,7 +66,7 @@ ~~~~ {.haskell} ghci> let opts = defaults & param "q" .~ ["tetris"] & param "language" .~ ["haskell"]-ghci> r <- getWith opts "https://api.github.com/search/code"+ghci> r <- getWith opts "https://api.github.com/search/repositories" ~~~~ Haskell-to-JSON interoperation is seamless.@@ -74,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",{-...-}@@ -123,7 +139,7 @@ I'd like to thank Edward Kmett and Shachaf Ben-Kiki for tirelessly answering my never-ending stream of-[lens](https://lens.github.io/)-related questions in `#haskell-lens#`.+[lens](https://lens.github.io/)-related questions in `#haskell-lens`. I also want to thank Michael Snoyman for being so quick with helpful responses to bug reports and pull requests against his excellent
www/tutorial.md view
@@ -120,7 +120,7 @@ ~~~~ {.haskell} ghci> import Data.Aeson.Lens (_String, key) ghci> let opts = defaults & param "foo" .~ ["bar", "quux"]-ghci> r <- getWith opts "http://httpbin.org"+ghci> r <- getWith opts "http://httpbin.org/get" ghci> r ^. responseBody . key "url" . _String "http://httpbin.org/get?foo=bar&foo=quux" ~~~~@@ -386,6 +386,7 @@ [`partFileSource`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#t:partFileSource). ~~~~ {.haskell}+ghci> import Data.Aeson.Lens (members) ghci> r <- post "http://httpbin.org/post" (partFile "file" "hello.hs") ghci> r ^.. responseBody . key "files" . members . _String ["main = putStrLn \"hello\"\n"]@@ -413,7 +414,10 @@ "bar" ~~~~ +To make cookies even easier to deal with, we'll want to+[use the `Session` API](#session), but we'll come back to that later. + # Authentication The `wreq` library supports both basic authentication and OAuth2@@ -430,8 +434,12 @@ [`HttpException`](http://hackage.haskell.org/package/http-client/docs/Network-HTTP-Client.html#t:HttpException). ~~~~ {.haskell}-ghci> r <- get "http://httpbin.org/basic-auth/user/pass-*** Exception: StatusCodeException (Status {statusCode = 401, {-...-}+ghci> r <- get "http://httpbin.org/basic-auth/user/pass"+*** Exception: HttpExceptionRequest Request { ... }+ (StatusCodeException (Response {+ responseStatus = Status {statusCode = 401, {-...-} }+ , {- ... -}+ }), "..." ) ~~~~ If we then supply a username and password, our request will succeed.@@ -439,12 +447,22 @@ retry.) ~~~~ {.haskell}-ghci> let opts = defaults & auth .~ basicAuth "user" "pass"+ghci> let opts = defaults & auth ?~ basicAuth "user" "pass" ghci> r <- getWith opts "https://httpbin.org/basic-auth/user/pass" ghci> r ^. responseBody "{\n \"authenticated\": true,\n \"user\": \"user\"\n}" ~~~~ +<div class="alert alert-info">+We use the+[`?~`](http://hackage.haskell.org/package/lens/docs/Control-Lens-Setter.html#v:-63--126-)+ operator to turn an [`Auth`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#t:Auth)+into a `Maybe Auth` here, to make the type of value on the right hand+side compatible with the+[`auth`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#v:auth)+lens.+</div>+ For OAuth2 bearer authentication, `wreq` supports two flavours: [`oauth2Bearer`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#v:oauth2Bearer) is the standard bearer token, while@@ -452,7 +470,49 @@ is GitHub's variant. These tokens are equivalent in value to a username and password. +## Amazon Web Services (AWS)+To authenticate to Amazon Web Services (AWS), we use+[`awsAuth`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#v:awsAuth). In+this example, we set the `Accept` header to request JSON, as opposed+to XML output from AWS. +~~~~ {.haskell}+ghci> let opts = defaults & auth ?~ awsAuth AWSv4 "key" "secret"+ & header "Accept" .~ ["application/json"]+ghci> r <- getWith opts "https://sqs.us-east-1.amazonaws.com/?Action=ListQueues"+ghci> r ^. responseBody+"{\"ListQueuesResponse\":{\"ListQueuesResult\":{\"queueUrls\": ... }"+~~~~++## Runscope support for Amazon Web Services (AWS) requests+To send requests to AWS through the [Runscope Inc.](https://www.runscope.com)+Traffic Inspector, convert the AWS service URL to a Runscope Bucket URL+using the "URL Helper" section in the Runscope dashboard (as you+would for other HTTP endpoints). Then invoke the AWS service as+before. For example, if your Runscope bucket key is+`7kh11example`, call AWS like so:++~~~~ {.haskell}+ghci> let opts = defaults & auth ?~ awsAuth AWSv4 "key" "secret"+ & header "Accept" .~ ["application/json"]+ghci> r <- getWith opts "https://sqs-us--east--1-amazonaws-com-7kh11example.runscope.net/?Action=ListQueues"+ghci> r ^. responseBody+"{\"ListQueuesResponse\":{\"ListQueuesResult\":{\"queueUrls\": ... }"+~~~~++If you enabled "Require Authentication Token" in the "Bucket Settings"+of your Runscope dashboard, set the `Runscope-Bucket-Auth` header like so:++~~~~ {.haskell}+ghci> let opts = defaults & auth ?~ awsAuth AWSv4 "key" "secret"+ & header "Accept" .~ ["application/json"]+ & header "Runscope-Bucket-Auth" .~ ["1example-1111-4yyyy-zzzz-xxxxxxxx"]+ghci> r <- getWith opts "https://sqs-us--east--1-amazonaws-com-7kh11example.runscope.net/?Action=ListQueues"+ghci> r ^. responseBody+"{\"ListQueuesResponse\":{\"ListQueuesResult\":{\"queueUrls\": ... }"+~~~~++ # Error handling Most of the time when an error occurs or a request fails, `wreq` will@@ -460,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@@ -470,20 +534,73 @@ ~~~~ {.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 authentication during a session, to avoid the need for an unauthenticated failure followed by an authenticated success if we visit the same endpoint repeatedly.)+++# Handling multiple HTTP requests++<a id="session">For non-trivial applications</a>, we'll always want to+use a+[`Session`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq-Session.html#t:Session)+to efficiently and correctly handle multiple requests.++The `Session` API provides two important features:++* When we issue multiple HTTP requests to the same server, a `Session`+ will reuse TCP and TLS connections for us. (The simpler API we've+ discussed so far does not do this.) This greatly improves+ efficiency.++* A `Session` transparently manages HTTP cookies. (We can manage them+ by hand, but it's awkward and verbose, so we won't cover it in this+ tutorial.)++Here's a complete example.++~~~~ {.haskell}+{-# LANGUAGE OverloadedStrings #-}++import Control.Lens+import Network.Wreq+import qualified Network.Wreq.Session as S++main :: IO ()+main = do+ sess <- S.newSession+ -- First request: tell the server to set a cookie+ S.get sess "http://httpbin.org/cookies/set?name=hi"++ -- Second request: the cookie should still be set afterwards.+ r <- S.post sess "http://httpbin.org/post" ["a" := (3 :: Int)]+ print $ r ^. responseCookie "name" . cookieValue+~~~~++The key differences from the basic API are as follows.++* We import the+ [`Network.Wreq.Session`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq-Session.html)+ module qualified, and we'll identify its functions by prefixing them+ with "`S.`".++* 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.