packages feed

wreq-sb (empty) → 0.4.0.0

raw patch · 40 files changed

+5688/−0 lines, 40 filesdep +HUnitdep +QuickCheckdep +aesonbuild-type:Customsetup-changed

Dependencies added: HUnit, QuickCheck, aeson, aeson-pretty, attoparsec, authenticate-oauth, base, base16-bytestring, base64-bytestring, byteable, bytestring, case-insensitive, containers, cryptohash, directory, doctest, exceptions, filepath, ghc-prim, hashable, http-client, http-client-tls, http-types, lens, lens-aeson, mime-types, network-info, old-locale, psqueues, snap-core, snap-server, template-haskell, temporary, test-framework, test-framework-hunit, test-framework-quickcheck2, text, time, transformers, unix-compat, unordered-containers, uuid, vector, wreq-sb

Files

+ LICENSE.md view
@@ -0,0 +1,29 @@+Copyright © 2014, Bryan O'Sullivan.++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright+  notice, this list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright+  notice, this list of conditions and the following disclaimer in the+  documentation and/or other materials provided with the distribution.++* Neither the name of nor the names of other contributors may be used+  to endorse or promote products derived from this software without+  specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Network/Wreq.hs view
@@ -0,0 +1,604 @@+{-# LANGUAGE FlexibleContexts, OverloadedStrings #-}++-- |+-- Module      : Network.Wreq+-- Copyright   : (c) 2014 Bryan O'Sullivan+--+-- License     : BSD-style+-- Maintainer  : bos@serpentine.com+-- Stability   : experimental+-- Portability : GHC+--+-- A library for client-side HTTP requests, focused on ease of use.+--+-- When reading the examples in this module, you should assume the+-- following environment:+--+-- @+-- \-\- Make it easy to write literal 'S.ByteString' and 'Text' values.+-- \{\-\# LANGUAGE OverloadedStrings \#\-\}+--+-- \-\- Our handy module.+-- import "Network.Wreq"+--+-- \-\- Operators such as ('&') and ('.~').+-- import "Control.Lens"+--+-- \-\- Conversion of Haskell values to JSON.+-- import "Data.Aeson" ('Data.Aeson.toJSON')+--+-- \-\- Easy traversal of JSON data.+-- import "Data.Aeson.Lens" ('Data.Aeson.Lens.key', 'Data.Aeson.Lens.nth')+-- @+--+-- There exist some less frequently used lenses that are not exported+-- from this module; these can be found in "Network.Wreq.Lens".++module Network.Wreq+    (+    -- * HTTP verbs++    -- ** Sessions+    -- $session++    -- ** GET+      get+    , getWith+    -- ** POST+    -- $postable+    , post+    , postWith+    -- ** HEAD+    , head_+    , headWith+    -- ** OPTIONS+    , options+    , optionsWith+    -- ** PUT+    , put+    , putWith+    -- ** DELETE+    , delete+    , deleteWith+    -- ** Custom Method+    , customMethod+    , customMethodWith+    -- * Incremental consumption of responses+    -- ** GET+    , foldGet+    , foldGetWith++    -- * Configuration+    , Options+    , defaults+    , Lens.manager+    , Lens.header+    , Lens.param+    , Lens.redirects+    , Lens.headers+    , Lens.params+    , Lens.cookie+    , Lens.cookies+    , Lens.checkStatus++    -- ** Authentication+    -- $auth+    , Auth+    , AWSAuthVersion(..)+    , Lens.auth+    , basicAuth+    , oauth1Auth+    , oauth2Bearer+    , oauth2Token+    , awsAuth+    -- ** Proxy settings+    , Proxy(Proxy)+    , Lens.proxy+    , httpProxy+    -- ** Using a manager with defaults+    , withManager++    -- * Payloads for POST and PUT+    , Payload(..)+    -- ** URL-encoded form data+    , FormParam(..)+    , FormValue+    -- ** Multipart form data+    , Form.Part+    , Lens.partName+    , Lens.partFileName+    , Lens.partContentType+    , Lens.partGetBody+    -- *** Smart constructors+    , Form.partBS+    , Form.partLBS+    , partText+    , partString+    , Form.partFile+    , Form.partFileSource++    -- * Responses+    , Response+    , Lens.responseBody+    , Lens.responseHeader+    , Lens.responseLink+    , Lens.responseCookie+    , Lens.responseHeaders+    , Lens.responseCookieJar+    , Lens.responseStatus+    , Lens.Status+    , Lens.statusCode+    , Lens.statusMessage+    -- ** Link headers+    , Lens.Link+    , Lens.linkURL+    , Lens.linkParams+    -- ** Decoding responses+    , JSONError(..)+    , asJSON+    , asValue++    -- * Cookies+    -- $cookielenses+    , Lens.Cookie+    , Lens.cookieName+    , Lens.cookieValue+    , Lens.cookieExpiryTime+    , Lens.cookieDomain+    , Lens.cookiePath++    -- * 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.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Text.Encoding (encodeUtf8)+import Network.HTTP.Client.Internal (Proxy(..), Response)+import Network.Wreq.Internal+import Network.Wreq.Types (Options)+import Network.Wreq.Types hiding (Options(..))+import Prelude hiding (head)+import qualified Data.Aeson as Aeson+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import qualified Data.Text as T+import qualified Network.HTTP.Client as HTTP+import qualified Network.HTTP.Client.MultipartFormData as Form+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.+--+-- Example:+--+-- @+--'get' \"http:\/\/httpbin.org\/get\"+-- @+--+-- >>> r <- get "http://httpbin.org/get"+-- >>> r ^. responseStatus . statusCode+-- 200+get :: String -> IO (Response L.ByteString)+get url = getWith defaults url++withManager :: (Options -> IO a) -> IO a+withManager act = HTTP.withManager defaultManagerSettings $ \mgr ->+  act defaults { Wreq.manager = Right mgr }++-- | Issue a GET request, using the supplied 'Options'.+--+-- Example:+--+-- @+--let opts = 'defaults' '&' 'Lens.param' \"foo\" '.~' [\"bar\"]+--'getWith' opts \"http:\/\/httpbin.org\/get\"+-- @+--+-- >>> let opts = defaults & param "foo" .~ ["bar"]+-- >>> r <- getWith opts "http://httpbin.org/get"+-- >>> r ^? responseBody . key "url"+-- Just (String "http://httpbin.org/get?foo=bar")+getWith :: Options -> String -> IO (Response L.ByteString)+getWith opts url = runRead =<< prepareGet opts url++-- | Issue a POST request.+--+-- Example:+--+-- @+--'post' \"http:\/\/httpbin.org\/post\" ('Aeson.toJSON' [1,2,3])+-- @+--+-- >>> 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]))+post :: Postable a => String -> a -> IO (Response L.ByteString)+post url payload = postWith defaults url payload++-- | Issue a POST request, using the supplied 'Options'.+--+-- Example:+--+-- @+--let opts = 'defaults' '&' 'Lens.param' \"foo\" '.~' [\"bar\"]+--'postWith' opts \"http:\/\/httpbin.org\/post\" ('Aeson.toJSON' [1,2,3])+-- @+--+-- >>> let opts = defaults & param "foo" .~ ["bar"]+-- >>> r <- postWith opts "http://httpbin.org/post" (toJSON [1,2,3])+-- >>> 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 = runRead =<< preparePost opts url payload++-- | Issue a HEAD request.+--+-- Example:+--+-- @+--'head_' \"http:\/\/httpbin.org\/get\"+-- @+--+-- >>> r <- head_ "http://httpbin.org/get"+-- >>> r ^? responseHeader "Content-Type"+-- Just "application/json"+head_ :: String -> IO (Response ())+head_ = headWith (defaults & Lens.redirects .~ 0)++-- | Issue a HEAD request, using the supplied 'Options'.+--+-- Example:+--+-- @+--let opts = 'defaults' '&' 'Lens.param' \"foo\" '.~' [\"bar\"]+--'headWith' opts \"http:\/\/httpbin.org\/get\"+-- @+--+-- >>> let opts = defaults & param "foo" .~ ["bar"]+-- >>> r <- headWith opts "http://httpbin.org/get"+-- >>> r ^? responseHeader "Connection"+-- Just "keep-alive"+headWith :: Options -> String -> IO (Response ())+headWith opts url = runIgnore =<< prepareHead opts url++-- | Issue a PUT request.+put :: Putable a => String -> a -> IO (Response L.ByteString)+put url payload = putWith defaults url payload++-- | Issue a PUT request, using the supplied 'Options'.+putWith :: Putable a => Options -> String -> a -> IO (Response L.ByteString)+putWith opts url payload = runRead =<< preparePut opts url payload++-- | Issue an OPTIONS request.+--+-- Example:+--+-- @+--'options' \"http:\/\/httpbin.org\/get\"+-- @+--+-- See 'Lens.atto' for a more complex worked example.+options :: String -> IO (Response ())+options = optionsWith defaults++-- | Issue an OPTIONS request, using the supplied 'Options'.+--+-- Example:+--+-- @+--let opts = 'defaults' '&' 'Lens.param' \"foo\" '.~' [\"bar\"]+--'optionsWith' opts \"http:\/\/httpbin.org\/get\"+-- @+optionsWith :: Options -> String -> IO (Response ())+optionsWith opts url = runIgnore =<< prepareOptions opts url++-- | Issue a DELETE request.+--+-- Example:+--+-- @+--'delete' \"http:\/\/httpbin.org\/delete\"+-- @+--+-- >>> r <- delete "http://httpbin.org/delete"+-- >>> r ^. responseStatus . statusCode+-- 200+delete :: String -> IO (Response L.ByteString)+delete = deleteWith defaults++-- | Issue a DELETE request, using the supplied 'Options'.+--+-- Example:+--+-- @+--let opts = 'defaults' '&' 'Lens.redirects' '.~' 0+--'deleteWith' opts \"http:\/\/httpbin.org\/delete\"+-- @+--+-- >>> let opts = defaults & redirects .~ 0+-- >>> r <- deleteWith opts "http://httpbin.org/delete"+-- >>> r ^. responseStatus . statusCode+-- 200+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++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 return opts url (foldResponseBody f z0)++-- | Convert the body of an HTTP response from JSON to a suitable+-- Haskell type.+--+-- In this example, we use 'asJSON' in the @IO@ monad, where it will+-- throw a 'JSONError' exception if conversion to the desired type+-- fails.+--+-- @+-- \{-\# LANGUAGE DeriveGeneric \#-\}+--import "GHC.Generics" ('GHC.Generics.Generic')+--+-- \{- This Haskell type corresponds to the structure of a+--   response body from httpbin.org. -\}+--+--data GetBody = GetBody {+--    headers :: 'Data.Map.Map' 'Data.Text.Text' 'Data.Text.Text'+--  , args :: 'Data.Map.Map' 'Data.Text.Text' 'Data.Text.Text'+--  , origin :: 'Data.Text.Text'+--  , url :: 'Data.Text.Text'+--  } deriving (Show, 'GHC.Generics.Generic')+--+-- \-\- Get GHC to derive a 'FromJSON' instance for us.+--instance 'FromJSON' GetBody+--+-- \{- The fact that we want a GetBody below will be inferred by our+--   use of the \"headers\" accessor function. -\}+--+--foo = do+--  r <- 'asJSON' =<< 'get' \"http:\/\/httpbin.org\/get\"+--  print (headers (r 'Control.Lens.^.' 'responseBody'))+-- @+--+-- If we use 'asJSON' in the 'Either' monad, it will return 'Left'+-- with a 'JSONError' payload if conversion fails, and 'Right' with a+-- 'Response' whose 'responseBody' is the converted value on success.++asJSON :: (MonadThrow m, FromJSON a) =>+          Response L.ByteString -> m (Response a)+{-# SPECIALIZE asJSON :: (FromJSON a) =>+                         Response L.ByteString -> IO (Response a) #-}+{-# SPECIALIZE asJSON :: Response L.ByteString -> IO (Response Aeson.Value) #-}+asJSON resp = do+  let contentType = fst . S.break (==59) . fromMaybe "unknown" .+                    lookup "Content-Type" . HTTP.responseHeaders $ resp+  unless ("application/json" `S.isPrefixOf` contentType) $+    throwM . JSONError $ "content type of response is " ++ show contentType+  case Aeson.eitherDecode' (HTTP.responseBody resp) of+    Left err  -> throwM (JSONError err)+    Right val -> return (fmap (const val) resp)+++-- | Convert the body of an HTTP response from JSON to a 'Value'.+--+-- In this example, we use 'asValue' in the @IO@ monad, where it will+-- throw a 'JSONError' exception if the conversion to 'Value' fails.+--+-- @+--foo = do+--  r <- 'asValue' =<< 'get' \"http:\/\/httpbin.org\/get\"+--  print (r 'Control.Lens.^?' 'responseBody' . key \"headers\" . key \"User-Agent\")+-- @+asValue :: (MonadThrow m) => Response L.ByteString -> m (Response Aeson.Value)+{-# SPECIALIZE asValue :: Response L.ByteString+                       -> IO (Response Aeson.Value) #-}+asValue = asJSON++-- $auth+--+-- Do not use HTTP authentication unless you are using TLS encryption.+-- These authentication tokens can easily be captured and reused by an+-- attacker if transmitted in the clear.++-- | Basic authentication. This consists of a plain username and+-- password.+--+-- Example (note the use of TLS):+--+-- @+--let opts = 'defaults' '&' 'Lens.auth' '?~' 'basicAuth' \"user\" \"pass\"+--'getWith' opts \"https:\/\/httpbin.org\/basic-auth\/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.+          -> 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\"+--'getWith' opts \"https:\/\/public-api.wordpress.com\/rest\/v1\/me\/\"+-- @+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+-- it as the equivalent of a username and password.+--+-- Example (note the use of TLS):+--+-- @+--let opts = 'defaults' '&' 'Lens.auth' '?~' 'oauth2Token' \"abcd1234\"+--'getWith' opts \"https:\/\/api.github.com\/user\"+-- @+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 = AWSAuth++-- | Proxy configuration.+--+-- Example:+--+-- @+--let opts = 'defaults' '&' 'Lens.proxy' '?~' 'httpProxy' \"localhost\" 8000+--'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.+httpProxy :: S.ByteString -> Int -> Proxy+httpProxy = Proxy++-- | Make a 'Part' whose content is a strict 'T.Text', encoded as+-- UTF-8.+--+-- The 'Part' does not have a file name or content type associated+-- with it.+partText :: Text             -- ^ Name of the corresponding \<input\>.+         -> Text             -- ^ The body for this 'Form.Part'.+         -> Form.Part+partText name value = Form.partBS name (encodeUtf8 value)++-- | Make a 'Part' whose content is a 'String', encoded as UTF-8.+--+-- The 'Part' does not have a file name or content type associated+-- with it.+partString :: Text           -- ^ Name of the corresponding \<input\>.+           -> String         -- ^ The body for this 'Form.Part'.+           -> 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+-- "Network.Wreq.Lens" for the full accounting of them all.++-- $postable+--+-- The 'Postable' class determines which Haskell types can be used as+-- POST payloads.+--+-- 'Form.Part' and ['Form.Part'] give a request body with a+-- @Content-Type@ of @multipart/form-data@.  Constructor functions+-- include 'partText' and 'Form.partFile'.+--+-- >>> r <- post "http://httpbin.org/post" (partText "hello" "world")+-- >>> r ^? responseBody . key "form" . key "hello"+-- Just (String "world")+--+-- ('S.ByteString', 'S.ByteString') and 'FormParam' (and lists of+-- each) give a request body with a @Content-Type@ of+-- @application/x-www-form-urlencoded@. The easiest way to use this is+-- via the (':=') constructor.+--+-- >>> r <- post "http://httpbin.org/post" ["num" := 31337, "str" := "foo"]+-- >>> r ^? responseBody . key "form" . key "num"+-- Just (String "31337")+--+-- 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.+--+-- The 'Aeson.Value' type gives a JSON request body with a+-- @Content-Type@ of @application/json@. Any instance of+-- 'Aeson.ToJSON' can of course be converted to a 'Aeson.Value' using+-- 'Aeson.toJSON'.+--+-- >>> r <- post "http://httpbin.org/post" (toJSON [1,2,3])+-- >>> r ^? responseBody . key "json" . nth 0+-- Just (Number 1.0)++-- $setup+--+-- >>> :set -XOverloadedStrings+-- >>> import Control.Lens+-- >>> import Data.Aeson (toJSON)+-- >>> import Data.Aeson.Lens (key, nth)+-- >>> import Network.Wreq
+ Network/Wreq/Cache.hs view
@@ -0,0 +1,158 @@+{-# 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 (parseTime)+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_time(1,5,0)+import Data.Time.Format (defaultTimeLocale)+#else+import System.Locale (defaultTimeLocale)+#endif++#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 $ parseTime 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
@@ -0,0 +1,180 @@+{-# LANGUAGE CPP, GADTs, OverloadedStrings #-}++module Network.Wreq.Internal+    (+      defaults+    , defaultManagerSettings+    , emptyMethodWith+    , foldResponseBody+    , ignoreResponse+    , readResponse+    , request+    , prepareGet+    , preparePost+    , runRead+    , prepareHead+    , runIgnore+    , prepareOptions+    , preparePut+    , prepareDelete+    , prepareMethod+    ) where++import Control.Applicative ((<$>))+import Control.Arrow ((***))+import Control.Lens ((&), (.~), (%~))+import Data.Monoid ((<>))+import Data.Text.Encoding (encodeUtf8)+import Data.Version (showVersion)+import Network.HTTP.Client (BodyReader)+import Network.HTTP.Client.Internal (Proxy(..), Request, Response(..), addProxy)+import Network.HTTP.Client.TLS (tlsManagerSettings)+import Network.Wreq.Internal.Lens (setHeader)+import Network.Wreq.Internal.Types (Mgr, Req(..), Run)+import Network.Wreq.Types (Auth(..), Options(..), Postable(..), Putable(..))+import Prelude hiding (head)+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as Char8+import qualified Data.ByteString.Lazy as L+import qualified Network.HTTP.Client as HTTP+import qualified Network.HTTP.Types as HTTP+import qualified Network.Wreq.Internal.Lens as Lens+import qualified Network.Wreq.Internal.AWS as AWS (signRequest)+import qualified Network.Wreq.Internal.OAuth1 as OAuth1 (signRequest)+import qualified Network.Wreq.Lens as Lens hiding (checkStatus)++-- This mess allows this module to continue to load during interactive+-- development in ghci :-(+#if defined(VERSION_base)+import Paths_wreq_sb (version)+#else+import Data.Version (Version(..))+version :: Version+version = Version [0] ["wip"]+#endif++defaultManagerSettings :: HTTP.ManagerSettings+defaultManagerSettings = tlsManagerSettings++defaults :: Options+defaults = Options {+    manager     = Left defaultManagerSettings+  , proxy       = Nothing+  , auth        = Nothing+  , headers     = [("User-Agent", userAgent)]+  , params      = []+  , redirects   = 10+  , cookies     = Just (HTTP.createCookieJar [])+  , checkStatus = Nothing+  }+  where userAgent = "haskell wreq-" <> Char8.pack (showVersion version)++setRedirects :: Options -> Request -> Request+setRedirects opts req+  | redirects opts == HTTP.redirectCount req = req+  | otherwise = req { HTTP.redirectCount = redirects opts }++emptyMethodWith :: HTTP.Method -> Options -> String -> IO (Response ())+emptyMethodWith method opts url =+  request (return . (Lens.method .~ method)) opts url ignoreResponse++ignoreResponse :: Response BodyReader -> IO (Response ())+ignoreResponse resp = (Lens.responseBody .~ ()) <$> readResponse resp++readResponse :: Response BodyReader -> IO (Response L.ByteString)+readResponse resp = do+  chunks <- HTTP.brConsume (HTTP.responseBody resp)+  return resp { responseBody = L.fromChunks chunks }++foldResponseBody :: (a -> S.ByteString -> IO a) -> a+                 -> Response BodyReader -> IO a+foldResponseBody f z0 resp = go z0+  where go z = do+          bs <- HTTP.brRead (HTTP.responseBody resp)+          if S.null bs+            then return z+            else f z bs >>= go++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 (flip HTTP.withManager go) go emgr+  where go mgr = HTTP.withResponse req mgr act++prepare :: (Request -> IO Request) -> Options -> String -> IO Request+prepare modify opts url = do+  signRequest =<< modify =<< frob <$> HTTP.parseUrl url+  where+    frob req = req & Lens.requestHeaders %~ (headers opts ++)+                   & setQuery opts+                   & setAuth opts+                   & setProxy opts+                   & setCheckStatus opts+                   & setRedirects opts+                   & Lens.cookieJar .~ cookies opts+    signRequest :: Request -> IO Request+    signRequest = maybe return f $ auth opts+      where+        f (AWSAuth versn key secret) = AWS.signRequest versn key secret+        f (OAuth1 consumerToken consumerSecret token secret) = OAuth1.signRequest consumerToken consumerSecret token secret+        f _ = return+++setQuery :: Options -> Request -> Request+setQuery opts =+  case params opts of+    [] -> id+    ps -> Lens.queryString %~ \qs ->+          let n = S.length qs in+          qs <> (if n > 1 then "&" else "") <> HTTP.renderSimpleQuery (n==0)+          (map (encodeUtf8 *** encodeUtf8) ps)++setAuth :: Options -> Request -> Request+setAuth = maybe id f . auth+  where+    f (BasicAuth user pass) = HTTP.applyBasicAuth user pass+    f (OAuth2Bearer token)  = setHeader "Authorization" ("Bearer " <> token)+    f (OAuth2Token token)   = setHeader "Authorization" ("token " <> token)+    -- for AWS request signature, see Internal/AWS+    f (AWSAuth _ _ _)       = id+    f (OAuth1 _ _ _ _)      = id++setProxy :: Options -> Request -> Request+setProxy = maybe id f . proxy+  where f (Proxy host port) = addProxy host port++setCheckStatus :: Options -> Request -> Request+setCheckStatus = maybe id f . checkStatus+  where f cs = ( & Lens.checkStatus .~ cs)++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++preparePost :: Postable a => Options -> String -> a -> IO Req+preparePost opts url payload = Req (manager opts) <$>+  prepare (postPayload payload . (Lens.method .~ HTTP.methodPost)) opts url++prepareMethod :: HTTP.Method -> Options -> String -> IO Req+prepareMethod method opts url = Req (manager opts) <$>+  prepare (return . (Lens.method .~ method)) 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 (putPayload payload . (Lens.method .~ HTTP.methodPut)) opts url++prepareDelete :: Options -> String -> IO Req+prepareDelete = prepareMethod HTTP.methodDelete
+ Network/Wreq/Internal/AWS.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE CPP, OverloadedStrings, BangPatterns #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Network.Wreq.Internal.AWS+    (+      signRequest+    ) where++import Control.Applicative ((<$>))+import Control.Lens ((%~), (^.), (&), to)+import Crypto.MAC (hmac, hmacGetDigest)+import Data.ByteString.Base16 as HEX (encode)+import Data.Byteable (toBytes)+import Data.Char (toLower)+import Data.List (sort)+import Data.Monoid ((<>))+import Data.Time.Clock (getCurrentTime)+import Data.Time.Format (formatTime)+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 (HMAC, SHA256)+import qualified Crypto.Hash.SHA256 as SHA256 (hash, hashlazy)+import qualified Data.ByteString.Char8 as S+import qualified Data.CaseInsensitive  as CI (original)+import qualified Data.HashSet as HashSet+import qualified Network.HTTP.Client as HTTP++#if MIN_VERSION_time(1,5,0)+import Data.Time.Format (defaultTimeLocale)+#else+import System.Locale (defaultTimeLocale)+#endif++-- 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 = signRequestV4++signRequestV4 :: S.ByteString -> S.ByteString -> Request -> IO Request+signRequestV4 key secret request = do+  !ts <- timestamp                         -- YYYYMMDDT242424Z, UTC based+  let origHost = request ^. host          -- potentially w/ runscope bucket+      runscopeBucketAuth =+        lookup "Runscope-Bucket-Auth" $ request ^. requestHeaders+      noRunscopeHost = removeRunscope origHost -- rm Runscope for signing+      (service, region) = serviceAndRegion noRunscopeHost+      date = S.takeWhile (/= 'T') ts      -- YYYYMMDD+      hashedPayload+        | request ^. method `elem` ["POST", "PUT"] = payloadHash req+        | otherwise = HEX.encode $ SHA256.hash ""+      -- 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"+  -- task 1+  let hl = req ^. requestHeaders . to sort+      signedHeaders = S.intercalate ";" . map (lowerCI . fst) $ hl+      canonicalReq = S.intercalate "\n" [+          req ^. method             -- step 1+        , req ^. path               -- step 2+        ,   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+        , HEX.encode $ SHA256.hash 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 k = toBytes (hmacGetDigest h)+      where h = hmac k s :: (CT.HMAC CT.SHA256)++payloadHash :: Request -> S.ByteString+payloadHash req =+  case HTTP.requestBody req of+    HTTP.RequestBodyBS bs ->+      HEX.encode $ SHA256.hash bs+    HTTP.RequestBodyLBS lbs ->+      HEX.encode $ SHA256.hashlazy lbs+    _ -> 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")+  | 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
@@ -0,0 +1,72 @@+{-# LANGUAGE RankNTypes, TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++module Network.Wreq.Internal.Lens+    (+      HTTP.Request+    , method+    , secure+    , host+    , port+    , path+    , queryString+    , requestHeaders+    , requestBody+    , requestVersion+    , onRequestBodyException+    , proxy+    , hostAddress+    , rawBody+    , decompress+    , redirectCount+    , responseTimeout+    , checkStatus+    , getConnectionWrapper+    , cookieJar+    , seshCookies+    , seshManager+    , seshRun+    -- * Useful functions+    , assoc+    , assoc2+    , setHeader+    , maybeSetHeader+    , deleteKey+    ) where++import Control.Lens hiding (makeLenses)+import Data.List (partition)+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++assoc2 :: Eq k => k -> Lens' [(k,a)] [a]+-- This is only a lens up to the ordering of the list (which changes+-- when we modify the list).+-- assoc2 :: (Eq b, Functor f) => b -> ([a] -> f [a]) -> [(b, a)] -> f [(b, a)]+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) :) . 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/Link.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Wreq.Internal.Link+       (+         links+       ) where++import Control.Applicative ((<$>), (<*>), (*>), (<*), many)+import Data.Attoparsec.ByteString.Char8 as A8+import Data.ByteString (ByteString)+import Network.Wreq.Types (Link(..))+import qualified Data.Attoparsec.ByteString as A+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8++links :: B.ByteString -> [Link]+links hdr = case parseOnly f hdr of+              Left _   -> []+              Right xs -> xs+  where f = sepBy1 (link <* skipSpace) (char8 ',' *> skipSpace) <* endOfInput++link :: Parser Link+link = Link <$> url <*> many (char8 ';' *> skipSpace *> param)+  where url = char8 '<' *> A8.takeTill (=='>') <* char8 '>' <* skipSpace++param :: Parser (ByteString, ByteString)+param = do+  name <- paramName+  skipSpace *> "=" *> skipSpace+  c <- peekChar'+  let isTokenChar = A.inClass "!#$%&'()*+./0-9:<=>?@a-zA-Z[]^_`{|}~-"+  val <- case c of+           '"' -> quotedString+           _   -> A.takeWhile isTokenChar+  skipSpace+  return (name, val)++data Quot = Literal | Backslash++quotedString :: Parser ByteString+quotedString = char '"' *> (fixup <$> body) <* char '"'+  where body = A8.scan Literal $ \s c ->+          case (s,c) of+            (Literal,  '\\') -> backslash+            (Literal,  '"')  -> Nothing+            _                -> literal+        literal   = Just Literal+        backslash = Just Backslash+        fixup = B8.pack . go . B8.unpack+          where go ('\\' : x@'\\' : xs) = x : go xs+                go ('\\' : x@'"' : xs)  = x : go xs+                go (x : xs)             = x : go xs+                go xs                   = xs++paramName :: Parser ByteString+paramName = do+  name <- A.takeWhile1 $ A.inClass "a-zA-Z0-9!#$&+-.^_`|~"+  c <- peekChar+  return $ case c of+             Just '*' -> B8.snoc name '*'+             _        -> name
+ 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
@@ -0,0 +1,314 @@+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, FlexibleInstances, GADTs,+    OverloadedStrings, RankNTypes, RecordWildCards #-}++-- |+-- Module      : Network.Wreq.Internal.Types+-- Copyright   : (c) 2014 Bryan O'Sullivan+--+-- License     : BSD-style+-- Maintainer  : bos@serpentine.com+-- Stability   : experimental+-- Portability : GHC+--+-- HTTP client types.++module Network.Wreq.Internal.Types+    (+    -- * Client configuration+      Options(..)+    , Mgr+    , Auth(..)+    , AWSAuthVersion(..)+    , StatusChecker+    -- * Request payloads+    , Payload(..)+    , Postable(..)+    , Putable(..)+    -- ** URL-encoded forms+    , FormParam(..)+    , FormValue(..)+    -- * Headers+    , ContentType+    , Link(..)+    -- * Errors+    , JSONError(..)+    -- * Request types+    , Req(..)+    , reqURL+    -- * Sessions+    , Session(..)+    , Run+    , Body(..)+    -- * Caches+    , CacheEntry(..)+    ) where++import Control.Exception (Exception, SomeException)+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)+import Network.HTTP.Client.Internal (Response, Proxy)+import Network.HTTP.Types (Header, Status, ResponseHeaders)+import Prelude hiding (head)+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 :: Mgr+  -- ^ Either configuration for a 'Manager', or an actual 'Manager'.+  --+  -- If only 'ManagerSettings' are provided, then by default a new+  -- 'Manager' will be created for each request.+  --+  -- /Note/: when issuing HTTP requests using 'Options'-based+  -- functions from the the "Network.Wreq.Session" module+  -- ('Network.Wreq.Session.getWith', 'Network.Wreq.Session.putWith',+  -- etc.), this field will be ignored.+  --+  -- An example of using a specific manager:+  --+  -- @+  --import "Network.HTTP.Client" ('Network.HTTP.Client.withManager')+  --+  --'Network.HTTP.Client.withManager' $ \\mgr -> do+  --  let opts = 'Network.Wreq.defaults' { 'manager' = Right mgr }+  --  'Network.Wreq.getWith' opts \"http:\/\/httpbin.org\/get\"+  -- @+  --+  -- An example of changing settings (this will use a separate+  -- 'Manager' for every request, so make sense only if you're issuing+  -- a tiny handful of requets):+  --+  -- @+  --import "Network.HTTP.Client" ('Network.HTTP.Client.defaultManagerSettings')+  --+  --let settings = 'Network.HTTP.Client.defaultManagerSettings' { managerConnCount = 5 }+  --    opts = 'Network.Wreq.defaults' { 'manager' = Left settings }+  --'Network.Wreq.getWith' opts \"http:\/\/httpbin.org\/get\"+  -- @+  , proxy :: Maybe Proxy+  -- ^ Host name and port for a proxy to use, if any.+  , auth :: Maybe Auth+  -- ^ Authentication information.+  --+  -- Example (note the use of TLS):+  --+  -- @+  --let opts = 'Network.Wreq.defaults' { 'auth' = 'Network.Wreq.basicAuth' \"user\" \"pass\" }+  --'Network.Wreq.getWith' opts \"https:\/\/httpbin.org\/basic-auth\/user\/pass\"+  -- @+  , headers :: [Header]+  -- ^ Additional headers to send with each request.+  --+  -- @+  --let opts = 'Network.Wreq.defaults' { 'headers' = [(\"Accept\", \"*\/*\")] }+  --'Network.Wreq.getWith' opts \"http:\/\/httpbin.org\/get\"+  -- @+  , params :: [(Text, Text)]+  -- ^ Key-value pairs to assemble into a query string to add to the+  -- end of a URL.+  --+  -- For example, given:+  --+  -- @+  --let opts = 'Network.Wreq.defaults' { params = [(\"sort\", \"ascending\"), (\"key\", \"name\")] }+  --'Network.Wreq.getWith' opts \"http:\/\/httpbin.org\/get\"+  -- @+  --+  -- This will generate a URL of the form:+  --+  -- >http://httpbin.org/get?sort=ascending&key=name+  , redirects :: Int+  -- ^ The maximum number of HTTP redirects to follow before giving up+  -- and throwing an exception.+  --+  -- In this example, a 'Network.HTTP.Client.HttpException' will be+  -- thrown with a 'Network.HTTP.Client.TooManyRedirects' constructor,+  -- because the maximum number of redirects allowed will be exceeded:+  --+  -- @+  --let opts = 'Network.Wreq.defaults' { 'redirects' = 3 }+  --'Network.Wreq.getWith' opts \"http:\/\/httpbin.org\/redirect/5\"+  -- @+  , cookies :: Maybe CookieJar+  -- ^ Cookies to set when issuing requests.+  --+  -- /Note/: when issuing HTTP requests using 'Options'-based+  -- functions from the the "Network.Wreq.Session" module+  -- ('Network.Wreq.Session.getWith', 'Network.Wreq.Session.putWith',+  -- etc.), this field will be used only for the /first/ HTTP request+  -- to be issued during a 'Network.Wreq.Session.Session'. Any changes+  -- changes made for subsequent requests will be ignored.+  , checkStatus :: Maybe StatusChecker+  -- ^ 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 returns an exception.+type StatusChecker = Status -> ResponseHeaders -> CookieJar+                   -> Maybe SomeException++-- | Supported authentication types.+--+-- Do not use HTTP authentication unless you are using TLS encryption.+-- These authentication tokens can easily be captured and reused by an+-- attacker if transmitted in the clear.+data Auth = BasicAuth S.ByteString S.ByteString+            -- ^ Basic authentication. This consists of a plain+            -- username and password.+          | OAuth2Bearer S.ByteString+            -- ^ An OAuth2 bearer token. This is treated by many+            -- services as the equivalent of a username and password.+          | OAuth2Token S.ByteString+            -- ^ A not-quite-standard OAuth2 bearer token (that seems+            -- 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+            -- ^ Amazon Web Services request signing+            -- AWSAuthVersion key secret+          | 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 cookies+    , " }"+    ]++-- | A type that can be converted into a POST request payload.+class Postable a where+    postPayload :: a -> Request -> IO Request+    -- ^ Represent a value in the request body (and perhaps the+    -- headers) of a POST request.++-- | A type that can be converted into a PUT request payload.+class Putable a where+    putPayload :: a -> Request -> IO Request+    -- ^ Represent a value in the request body (and perhaps the+    -- headers) of a PUT request.++-- | A product type for representing more complex payload types.+data Payload where+    Raw  :: ContentType -> RequestBody -> Payload+  deriving (Typeable)++-- | A type that can be rendered as the value portion of a key\/value+-- pair for use in an @application\/x-www-form-urlencoded@ POST+-- body. Intended for use with the 'FormParam' type.+--+-- The instances for 'String', strict 'Data.Text.Text', and lazy+-- 'Data.Text.Lazy.Text' are all encoded using UTF-8 before being+-- URL-encoded.+--+-- The instance for 'Maybe' gives an empty string on 'Nothing',+-- and otherwise uses the contained type's instance.+class FormValue a where+    renderFormValue :: a -> S.ByteString+    -- ^ Render the given value.++-- | A key\/value pair for an @application\/x-www-form-urlencoded@+-- POST request body.+data FormParam where+    (:=) :: (FormValue v) => S.ByteString -> v -> FormParam++instance Show FormParam where+    show (a := b) = show a ++ " := " ++ show (renderFormValue b)++infixr 3 :=++-- | The error type used by 'Network.Wreq.asJSON' and+-- 'Network.Wreq.asValue' if a failure occurs when parsing a response+-- body as JSON.+data JSONError = JSONError String+               deriving (Show, Typeable)++instance Exception JSONError++-- | An element of a @Link@ header.+data Link = Link {+      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)++-- | 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+    }++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
@@ -0,0 +1,469 @@+{-# LANGUAGE RankNTypes #-}++-- |+-- Module      : Network.Wreq.Lens+-- Copyright   : (c) 2014 Bryan O'Sullivan+--+-- License     : BSD-style+-- Maintainer  : bos@serpentine.com+-- Stability   : experimental+-- Portability : GHC+--+-- HTTP client lens machinery.+--+-- When reading the examples in this module, you should assume the+-- following environment:+--+-- @+-- \-\- Make it easy to write literal 'S.ByteString' and 'Text' values.+-- \{\-\# LANGUAGE OverloadedStrings \#\-\}+--+-- \-\- Our handy module.+-- import "Network.Wreq"+--+-- \-\- Operators such as ('&') and ('.~').+-- import "Control.Lens"+--+-- \-\- Conversion of Haskell values to JSON.+-- import "Data.Aeson" ('Data.Aeson.toJSON')+--+-- \-\- Easy traversal of JSON data.+-- import "Data.Aeson.Lens" ('Data.Aeson.Lens.key', 'Data.Aeson.Lens.nth')+-- @++module Network.Wreq.Lens+    (+    -- * Configuration+      Options+    , manager+    , proxy+    , auth+    , header+    , param+    , redirects+    , headers+    , params+    , cookie+    , cookies+    , StatusChecker+    , checkStatus++    -- ** Proxy setup+    , Proxy+    , proxyHost+    , proxyPort++    -- * Cookie+    , Cookie+    , cookieName+    , cookieValue+    , cookieExpiryTime+    , cookieDomain+    , cookiePath+    , cookieCreationTime+    , cookieLastAccessTime+    , cookiePersistent+    , cookieHostOnly+    , cookieSecureOnly+    , cookieHttpOnly++    -- * Response+    , Response+    , responseBody+    , responseHeader+    , responseLink+    , responseCookie+    , responseHeaders+    , responseCookieJar+    , responseStatus+    , responseVersion++    -- ** Status+    , Status+    , statusCode+    , statusMessage++    -- * Link header+    , Link+    , linkURL+    , linkParams++    -- * POST body part+    , Part+    , partName+    , partFileName+    , partContentType+    , partGetBody++    -- * Parsing+    , atto+    , atto_+    ) where++import Control.Applicative ((<*))+import Control.Lens (Fold, Lens, Lens', Traversal', folding)+import Data.Attoparsec.ByteString (Parser, endOfInput, parseOnly)+import Data.ByteString (ByteString)+import Data.Text (Text)+import Data.Time.Clock (UTCTime)+import Network.HTTP.Client (Cookie, CookieJar, Manager, ManagerSettings, Proxy)+import Network.HTTP.Client (RequestBody, Response)+import Network.HTTP.Client.MultipartFormData (Part)+import Network.HTTP.Types.Header (Header, HeaderName, ResponseHeaders)+import Network.HTTP.Types.Status (Status)+import Network.HTTP.Types.Version (HttpVersion)+import Network.Mime (MimeType)+import Network.Wreq.Types (Auth, Link, Options, StatusChecker)+import 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)+-- secure connections:+--+-- @+--import "OpenSSL.Session" ('OpenSSL.Session.context')+--import "Network.HTTP.Client.OpenSSL"+--+--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\"+-- @+--+-- In this example, we also set the response timeout to 10000 microseconds:+--+-- @+--import "OpenSSL.Session" ('OpenSSL.Session.context')+--import "Network.HTTP.Client.OpenSSL"+--import "Network.HTTP.Client" ('Network.HTTP.Client.defaultManagerSettings', 'Network.HTTP.Client.managerResponseTimeout')+--+--let opts = 'Network.Wreq.defaults' 'Control.Lens.&' 'manager' 'Control.Lens..~' Left ('Network.HTTP.Client.OpenSSL.opensslManagerSettings' 'OpenSSL.Session.context')+--                    'Control.Lens.&' 'manager' 'Control.Lens..~' Left ('Network.HTTP.Client.defaultManagerSettings' { 'Network.HTTP.Client.managerResponseTimeout' = Just 10000 } )+--+--'Network.HTTP.Client.OpenSSL.withOpenSSL' $+--  'Network.Wreq.getWith' opts \"https:\/\/httpbin.org\/get\"+-- @+manager :: Lens' Options (Either ManagerSettings Manager)+manager = TH.manager++-- | A lens onto proxy configuration.+--+-- Example:+--+-- @+--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++-- | A lens onto request authentication.+--+-- Example (note the use of TLS):+--+-- @+--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)+auth = TH.auth++-- | A lens onto all headers with the given name (there can+-- legitimately be zero or more).+--+-- Example:+--+-- @+--let opts = 'Network.Wreq.defaults' 'Control.Lens.&' 'header' \"Accept\" 'Control.Lens..~' [\"*\/*\"]+--'Network.Wreq.getWith' opts \"http:\/\/httpbin.org\/get\"+-- @+header :: HeaderName -> Lens' Options [ByteString]+header = TH.header++-- | A lens onto all headers (there can legitimately be zero or more).+--+-- In this example, we print all the headers sent by default with+-- every request.+--+-- @+--print ('Network.Wreq.defaults' 'Control.Lens.^.' 'headers')+-- @+headers :: Lens' Options [Header]+headers = TH.headers++-- | A lens onto all query parameters with the given name (there can+-- legitimately be zero or more).+--+-- In this example, we construct the query URL+-- \"@http:\/\/httpbin.org\/get?foo=bar&foo=quux@\".+--+-- @+--let opts = 'Network.Wreq.defaults' 'Control.Lens.&' 'param' \"foo\" 'Control.Lens..~' [\"bar\", \"quux\"]+--'Network.Wreq.getWith' opts \"http:\/\/httpbin.org\/get\"+-- @+param :: Text -> Lens' Options [Text]+param = TH.param++-- | A lens onto all query parameters.+params :: Lens' Options [(Text, Text)]+params = TH.params++-- | A lens onto the maximum number of redirects that will be followed+-- before an exception is thrown.+--+-- In this example, a 'Network.HTTP.Client.HttpException' will be+-- thrown with a 'Network.HTTP.Client.TooManyRedirects' constructor,+-- because the maximum number of redirects allowed will be exceeded.+--+-- @+--let opts = 'Network.Wreq.defaults' 'Control.Lens.&' 'redirects' 'Control.Lens..~' 3+--'Network.Wreq.getWith' opts \"http:\/\/httpbin.org\/redirect\/5\"+-- @+redirects :: Lens' Options Int+redirects = TH.redirects++-- | A lens to get the optional status check function+checkStatus :: Lens' Options (Maybe StatusChecker)+checkStatus = TH.checkStatus++-- | 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 (Maybe CookieJar)+cookies = TH.cookies++-- | A lens onto the name of a cookie.+cookieName :: Lens' Cookie ByteString+cookieName = TH.cookieName++-- | A lens onto the value of a cookie.+cookieValue :: Lens' Cookie ByteString+cookieValue = TH.cookieValue++-- | A lens onto the expiry time of a cookie.+cookieExpiryTime :: Lens' Cookie UTCTime+cookieExpiryTime = TH.cookieExpiryTime++-- | A lens onto the domain of a cookie.+cookieDomain :: Lens' Cookie ByteString+cookieDomain = TH.cookieDomain++-- | A lens onto the path of a cookie.+cookiePath :: Lens' Cookie ByteString+cookiePath = TH.cookiePath++-- | A lens onto the creation time of a cookie.+cookieCreationTime :: Lens' Cookie UTCTime+cookieCreationTime = TH.cookieCreationTime++-- | A lens onto the last access time of a cookie.+cookieLastAccessTime :: Lens' Cookie UTCTime+cookieLastAccessTime = TH.cookieLastAccessTime++-- | A lens onto whether a cookie is persistent across sessions (also+-- known as a \"tracking cookie\").+cookiePersistent :: Lens' Cookie Bool+cookiePersistent = TH.cookiePersistent++-- | A lens onto whether a cookie is host-only.+cookieHostOnly :: Lens' Cookie Bool+cookieHostOnly = TH.cookieHostOnly++-- | A lens onto whether a cookie is secure-only, such that it will+-- only be used over TLS.+cookieSecureOnly :: Lens' Cookie Bool+cookieSecureOnly = TH.cookieSecureOnly++-- | A lens onto whether a cookie is \"HTTP-only\".+--+-- Such cookies should be used only by browsers when transmitting HTTP+-- requests.  They must be unavailable in non-browser environments,+-- such as when executing JavaScript scripts.+cookieHttpOnly :: Lens' Cookie Bool+cookieHttpOnly = TH.cookieHttpOnly++-- | A lens onto the hostname portion of a proxy configuration.+proxyHost :: Lens' Proxy ByteString+proxyHost = TH.proxyHost++-- | A lens onto the TCP port number of a proxy configuration.+proxyPort :: Lens' Proxy Int+proxyPort = TH.proxyPort++-- | A lens onto the status of an HTTP response.+responseStatus :: Lens' (Response body) Status+responseStatus = TH.responseStatus++-- | A lens onto the version of an HTTP response.+responseVersion :: Lens' (Response body) HttpVersion+responseVersion = TH.responseVersion++-- | A lens onto all matching named headers in an HTTP response.+--+-- To access exactly one header (the result will be the empty string if+-- there is no match), use the ('Control.Lens.^.') operator.+--+-- @+--r <- 'Network.Wreq.get' \"http:\/\/httpbin.org\/get\"+--print (r 'Control.Lens.^.' 'responseHeader' \"Content-Type\")+-- @+--+-- To access at most one header (the result will be 'Nothing' if there+-- is no match), use the ('Control.Lens.^?') operator.+--+-- @+--r <- 'Network.Wreq.get' \"http:\/\/httpbin.org\/get\"+--print (r 'Control.Lens.^?' 'responseHeader' \"Content-Transfer-Encoding\")+-- @+--+-- To access all (zero or more) matching headers, use the+-- ('Control.Lens.^..') operator.+--+-- @+--r <- 'Network.Wreq.get' \"http:\/\/httpbin.org\/get\"+--print (r 'Control.Lens.^..' 'responseHeader' \"Set-Cookie\")+-- @+responseHeader :: HeaderName+               -- ^ Header name to match.+               -> Traversal' (Response body) ByteString+responseHeader = TH.responseHeader++-- | A lens onto all headers in an HTTP response.+responseHeaders :: Lens' (Response body) ResponseHeaders+responseHeaders = TH.responseHeaders++-- | A fold over @Link@ headers, matching on both parameter name+-- and value.+--+-- For example, here is a @Link@ header returned by the GitHub search API.+--+-- > Link:+-- >   <https://api.github.com/search/code?q=addClass+user%3Amozilla&page=2>; rel="next",+-- >   <https://api.github.com/search/code?q=addClass+user%3Amozilla&page=34>; rel="last"+--+-- And here is an example of how we can retrieve the URL for the @next@ link+-- programatically.+--+-- @+--r <- 'Network.Wreq.get' \"https:\/\/api.github.com\/search\/code?q=addClass+user:mozilla\"+--print (r 'Control.Lens.^?' 'responseLink' \"rel\" \"next\" . 'linkURL')+-- @+responseLink :: ByteString+             -- ^ Parameter name to match.+             -> ByteString+             -- ^ Parameter value to match.+             -> Fold (Response body) Link+responseLink = TH.responseLink++-- | A lens onto the body of a response.+--+-- @+--r <- 'Network.Wreq.get' \"http:\/\/httpbin.org\/get\"+--print (r 'Control.Lens.^.' 'responseBody')+-- @+responseBody :: Lens (Response body0) (Response body1) body0 body1+responseBody = TH.responseBody++-- | A fold over any cookies that match the given name.+--+-- @+--r <- 'Network.Wreq.get' \"http:\/\/www.nytimes.com\/\"+--print (r 'Control.Lens.^?' responseCookie \"RMID\")+-- @+responseCookie :: ByteString+               -- ^ Name of cookie to match.+               -> Fold (Response body) Cookie+responseCookie = TH.responseCookie++-- | A lens onto all cookies set in the response.+responseCookieJar :: Lens' (Response body) CookieJar+responseCookieJar = TH.responseCookieJar++-- | A lens onto the numeric identifier of an HTTP status.+statusCode :: Lens' Status Int+statusCode = TH.statusCode++-- | A lens onto the textual description of an HTTP status.+statusMessage :: Lens' Status ByteString+statusMessage = TH.statusMessage++-- | A lens onto the URL portion of a @Link@ element.+linkURL :: Lens' Link ByteString+linkURL = TH.linkURL++-- | A lens onto the parameters of a @Link@ element.+linkParams :: Lens' Link [(ByteString, ByteString)]+linkParams = TH.linkParams++-- | A lens onto the name of the @<input>@ element associated with+-- part of a multipart form upload.+partName :: Lens' Part Text+partName = TH.partName++-- | A lens onto the filename associated with part of a multipart form+-- upload.+partFileName :: Lens' Part (Maybe String)+partFileName = TH.partFilename++-- | A lens onto the content-type associated with part of a multipart+-- form upload.+partContentType :: Traversal' Part (Maybe MimeType)+partContentType = TH.partContentType++-- | A lens onto the code that fetches the data associated with part+-- of a multipart form upload.+partGetBody :: Lens' Part (IO RequestBody)+partGetBody = TH.partGetBody++-- | Turn an attoparsec 'Parser' into a 'Fold'.+--+-- Both headers and bodies can contain complicated data that we may+-- need to parse.+--+-- Example: when responding to an OPTIONS request, a server may return+-- the list of verbs it supports in any order, up to and including+-- changing the order on every request (which httpbin.org /actually+-- does/!).  To deal with this possibility, we parse the list, then+-- sort it.+--+-- >>> import Data.Attoparsec.ByteString.Char8 as A+-- >>> import Data.List (sort)+-- >>>+-- >>> let comma = skipSpace >> "," >> skipSpace+-- >>> let verbs = A.takeWhile isAlpha_ascii `sepBy` comma+-- >>>+-- >>> r <- options "http://httpbin.org/get"+-- >>> r ^. responseHeader "Allow" . atto verbs . to sort+-- ["GET","HEAD","OPTIONS"]+atto :: Parser a -> Fold ByteString a+atto = folding . parseOnly++-- | 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+--+-- >>> :set -XOverloadedStrings+-- >>> import Control.Lens+-- >>> import Data.Aeson (toJSON)+-- >>> import Data.Aeson.Lens (key, nth)+-- >>> import Network.Wreq
+ Network/Wreq/Lens/Machinery.hs view
@@ -0,0 +1,27 @@+module Network.Wreq.Lens.Machinery+    (+      makeLenses+    , fieldName+    , toCamelCase+    ) where++import Control.Lens ((&), (.~))+import Control.Lens.TH hiding (makeLenses)+import Data.Char (toUpper)+import Language.Haskell.TH.Syntax (Dec, Name, Q, mkName, nameBase)++defaultRules :: LensRules+defaultRules = lensRules++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)++toCamelCase :: String -> String+toCamelCase (x0:x0s)  = x0 : go x0s+  where go ('_':x:xs) = toUpper x : go xs+        go (x:xs)     = x : go xs+        go []         = []+toCamelCase []        = []
+ Network/Wreq/Lens/TH.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE FlexibleContexts, OverloadedStrings, RankNTypes,+    TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++module Network.Wreq.Lens.TH+    (+      Types.Options+    , manager+    , proxy+    , auth+    , header+    , headers+    , param+    , params+    , redirects+    , cookie+    , cookies+    , checkStatus++    , HTTP.Cookie+    , cookieName+    , cookieValue+    , cookieExpiryTime+    , cookieDomain+    , cookiePath+    , cookieCreationTime+    , cookieLastAccessTime+    , cookiePersistent+    , cookieHostOnly+    , cookieSecureOnly+    , cookieHttpOnly++    , HTTP.Proxy+    , proxyHost+    , proxyPort++    , HTTP.Response+    , responseStatus+    , responseVersion+    , responseHeader+    , responseHeaders+    , responseLink+    , responseBody+    , responseCookie+    , responseCookieJar+    , responseClose'++    , HTTP.Status+    , statusCode+    , statusMessage++    , Types.Link+    , linkURL+    , linkParams++    , Form.Part+    , partName+    , partFilename+    , partContentType+    , partGetBody+    , partHeaders+    ) where++import Control.Lens hiding (makeLenses)+import Data.ByteString (ByteString)+import Data.Text (Text)+import Network.Wreq.Internal.Lens (assoc, assoc2)+import Network.Wreq.Internal.Link+import Network.Wreq.Lens.Machinery (fieldName, makeLenses, toCamelCase)+import qualified Network.HTTP.Client as HTTP+import qualified Network.HTTP.Client.MultipartFormData as Form+import qualified Network.HTTP.Types.Header as HTTP+import qualified Network.HTTP.Types.Status as HTTP+import qualified Network.Wreq.Types as Types++makeLenses ''Types.Options+makeLensesWith (lensRules & lensField .~ fieldName toCamelCase) ''HTTP.Cookie+makeLenses ''HTTP.Proxy+makeLenses ''HTTP.Response+makeLenses ''HTTP.Status+makeLenses ''Types.Link+makeLenses ''Form.Part++responseHeader :: HTTP.HeaderName -> Traversal' (HTTP.Response body) ByteString+responseHeader n = responseHeaders . assoc n++param :: Text -> Lens' Types.Options [Text]+param n = params . assoc2 n++header :: HTTP.HeaderName -> Lens' Types.Options [ByteString]+header n = headers . assoc2 n++_CookieJar :: Iso' HTTP.CookieJar [HTTP.Cookie]+_CookieJar = iso HTTP.destroyCookieJar HTTP.createCookieJar++-- N.B. This is an "illegal" traversal because we can change its cookie_name.+cookie :: ByteString -> Traversal' Types.Options HTTP.Cookie+cookie name = cookies . _Just . _CookieJar . traverse . filtered+              (\c -> HTTP.cookie_name c == name)++responseCookie :: ByteString -> Fold (HTTP.Response body) HTTP.Cookie+responseCookie name =+  responseCookieJar . folding HTTP.destroyCookieJar . filtered+  ((==name) . HTTP.cookie_name)++responseLink :: ByteString -> ByteString -> Fold (HTTP.Response body) Types.Link+responseLink name val =+  responseHeader "Link" . folding links .+  filtered (has (linkParams . folded . filtered (== (name,val))))
+ Network/Wreq/Session.hs view
@@ -0,0 +1,189 @@+{-# 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 'withAPISession'.)+--+--+-- 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 = Sess.'withSession' $ \\sess ->+--   Sess.'get' sess \"http:\/\/httpbin.org\/get\"+-- @+--+-- We create a 'Session' using 'withSession', then pass the session to+-- subsequent functions.  When talking to a REST-like service that does+-- not use cookies, it is more efficient to use 'withAPISession'.+--+-- 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.++module Network.Wreq.Session+    (+    -- * Session creation+      Session+    , withSession+    , withAPISession+    -- ** More control-oriented session creation+    , withSessionWith+    , withSessionControl+    -- * HTTP verbs+    , get+    , post+    , head_+    , options+    , put+    , delete+    -- ** Configurable verbs+    , getWith+    , postWith+    , headWith+    , optionsWith+    , putWith+    , deleteWith+    -- * Extending a session+    , Lens.seshRun+    ) where++import Control.Lens ((&), (?~), (.~))+import Data.Foldable (forM_)+import Data.IORef (newIORef, readIORef, writeIORef)+import Network.Wreq (Options, Response)+import Network.Wreq.Internal+import Network.Wreq.Internal.Types (Body(..), Req(..), Session(..))+import Network.Wreq.Types (Postable, Putable, Run)+import Prelude hiding (head)+import qualified Data.ByteString.Lazy as L+import qualified Network.HTTP.Client as HTTP+import qualified Network.Wreq.Internal.Lens as Lens++-- | Create a 'Session', passing it to the given function.  The+-- 'Session' will no longer be valid after that function returns.+--+-- This session manages cookies and uses default session manager+-- configuration.+withSession :: (Session -> IO a) -> IO a+withSession = withSessionWith defaultManagerSettings++-- | Create a session.+--+-- This uses the default session manager settings, but does not manage+-- cookies.  It is intended for use with REST-like HTTP-based APIs,+-- which typically do not use cookies.+withAPISession :: (Session -> IO a) -> IO a+withAPISession = withSessionControl Nothing defaultManagerSettings++-- | Create a session, using the given manager settings.  This session+-- manages cookies.+withSessionWith :: HTTP.ManagerSettings -> (Session -> IO a) -> IO a+withSessionWith = withSessionControl (Just (HTTP.createCookieJar []))+{-# DEPRECATED withSessionWith "Use withSessionControl instead." #-}++-- | 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+  mref <- maybe (return Nothing) (fmap Just . newIORef) mj+  HTTP.withManager settings $ \mgr ->+    act Session { seshCookies = mref+                , seshManager = mgr+                , seshRun = runWith+                }++-- | '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++-- | '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++-- | 'Session'-specific version of 'Network.Wreq.delete'.+delete :: Session -> String -> IO (Response L.ByteString)+delete = deleteWith defaults++-- | 'Session'-specific version of 'Network.Wreq.getWith'.+getWith :: Options -> Session -> String -> IO (Response L.ByteString)+getWith opts sesh url = run string sesh =<< prepareGet opts url++-- | 'Session'-specific version of 'Network.Wreq.postWith'.+postWith :: Postable a => Options -> Session -> String -> a+         -> IO (Response L.ByteString)+postWith opts sesh 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 = run ignore sesh =<< prepareHead opts url++-- | 'Session'-specific version of 'Network.Wreq.optionsWith'.+optionsWith :: Options -> Session -> String -> IO (Response ())+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 = run string sesh =<< preparePut opts url payload++-- | '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++runWith :: Session -> Run Body -> Run Body+runWith Session{..} act (Req _ req) = do+  req' <- case seshCookies of+            Nothing -> return (req & Lens.cookieJar .~ Nothing)+            Just ref -> (\s -> req & Lens.cookieJar ?~ s) `fmap` readIORef ref+  resp <- act (Req (Right seshManager) req')+  forM_ seshCookies $ \ref ->+    writeIORef ref (HTTP.responseCookieJar resp)+  return resp++type Mapping a = (Body -> a, a -> Body, Run a)++run :: Mapping a -> Session -> Run a+run (to,from,act) sesh =+  fmap (fmap to) . seshRun sesh sesh (fmap (fmap from) . act)++string :: Mapping L.ByteString+string = (\(StringBody s) -> s, StringBody, runRead)++ignore :: Mapping ()+ignore = (\_ -> (), const NoBody, runIgnore)
+ Network/Wreq/Types.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE FlexibleInstances, OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- |+-- Module      : Network.Wreq.Types+-- Copyright   : (c) 2014 Bryan O'Sullivan+--+-- License     : BSD-style+-- Maintainer  : bos@serpentine.com+-- Stability   : experimental+-- Portability : GHC+--+-- HTTP client types.++module Network.Wreq.Types+    (+    -- * Client configuration+      Options(..)+    , Auth(..)+    , AWSAuthVersion(..)+    , StatusChecker+    -- * Request payloads+    , Payload(..)+    , Postable(..)+    , Putable(..)+    -- ** URL-encoded forms+    , FormParam(..)+    , FormValue(..)+    -- * Headers+    , ContentType+    , Link(..)+    -- * Errors+    , JSONError(..)+    -- * Request handling+    , Req+    , reqURL+    , Run+    ) where++import Control.Lens ((&), (.~))+import Data.Aeson (Value, encode)+import Data.Int (Int8, Int16, Int32, Int64)+import Data.Word (Word, Word8, Word16, Word32, Word64)+import Network.HTTP.Client (Request)+import Network.HTTP.Client.MultipartFormData (Part, formDataBody)+import Network.Wreq.Internal.Types+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TL+import qualified Network.HTTP.Client as HTTP+import qualified Network.Wreq.Internal.Lens as Lens++instance Postable Part where+    postPayload a = postPayload [a]++instance Postable [Part] where+    postPayload = formDataBody++instance Postable [(S.ByteString, S.ByteString)] where+    postPayload ps req = return $ HTTP.urlEncodedBody ps req++instance Postable (S.ByteString, S.ByteString) where+    postPayload p = postPayload [p]++instance Postable [FormParam] where+    postPayload ps = postPayload (map f ps)+      where f (a := b) = (a, renderFormValue b)++instance Postable FormParam where+    postPayload p = postPayload [p]++instance Postable Payload where+    postPayload = putPayload++instance Postable S.ByteString where+    postPayload = putPayload++instance Postable L.ByteString where+    postPayload = putPayload++instance Postable Value where+    postPayload = putPayload+++instance Putable Payload where+    putPayload pl =+      case pl of+        Raw ct rb -> payload ct rb++instance Putable S.ByteString where+    putPayload = payload "application/octet-stream" . HTTP.RequestBodyBS++instance Putable L.ByteString where+    putPayload = payload "application/octet-stream" . HTTP.RequestBodyLBS++instance Putable Value where+    putPayload = payload "application/json" . HTTP.RequestBodyLBS . encode+++instance FormValue T.Text where+    renderFormValue = T.encodeUtf8++instance FormValue TL.Text where+    renderFormValue = T.encodeUtf8 . TL.toStrict++instance FormValue TL.Builder where+    renderFormValue = T.encodeUtf8 . TL.toStrict . TL.toLazyText++instance FormValue String where+    renderFormValue = T.encodeUtf8 . T.pack++instance FormValue S.ByteString where+    renderFormValue = id++instance FormValue L.ByteString where+    renderFormValue = S.concat . L.toChunks++instance FormValue Int where renderFormValue = renderFormValue . show+instance FormValue Int8 where renderFormValue = renderFormValue . show+instance FormValue Int16 where renderFormValue = renderFormValue . show+instance FormValue Int32 where renderFormValue = renderFormValue . show+instance FormValue Int64 where renderFormValue = renderFormValue . show+instance FormValue Integer where renderFormValue = renderFormValue . show++instance FormValue Word where renderFormValue = renderFormValue . show+instance FormValue Word8 where renderFormValue = renderFormValue . show+instance FormValue Word16 where renderFormValue = renderFormValue . show+instance FormValue Word32 where renderFormValue = renderFormValue . show+instance FormValue Word64 where renderFormValue = renderFormValue . show++instance FormValue Float where renderFormValue = renderFormValue . show+instance FormValue Double where renderFormValue = renderFormValue . show++instance FormValue () where renderFormValue _ = ""++instance (FormValue a) => FormValue (Maybe a) where+    renderFormValue (Just a) = renderFormValue a+    renderFormValue Nothing  = ""++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
@@ -0,0 +1,36 @@+# wreq: a Haskell web client library [![Build Status](https://travis-ci.org/stackbuilders/wreq.svg)](https://travis-ci.org/stackbuilders/wreq)++`wreq` is a library that makes HTTP client programming in Haskell+easy.++# Features++* Simple but powerful `lens`-based API++* Over 100 tests, and built on reliable libraries like [`http-client`](http://hackage.haskell.org/package/http-client/)+  and [`lens`](https://lens.github.io/)++* Session handling includes connection keep-alive and pooling, and+  cookie persistence++* Automatic decompression++* Powerful multipart form and file upload handling++* Support for JSON requests and responses, including navigation of+  schema-less responses++* 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?++No!  See [`TODO.md`](TODO.md) for a rather long list of ideas.
+ Setup.hs view
@@ -0,0 +1,64 @@+-- I don't know who originally wrote this, but I picked it up from+-- Edward Kmett's folds package.++{-# 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 ((</>))++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+  }++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)++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)++testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo+         -> [(InstalledPackageId, PackageId)]+testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys
+ TODO.md view
@@ -0,0 +1,21 @@+# Work yet to be done++* 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++* Integration with tagsoup (see+  [the mess in `UploadPaste.hs`](https://github.com/bos/wreq/blob/master/examples/UploadPaste.hs#L137))++* International domain support?++* Better authentication support, including session-long memory of+  which URLs do and don't need authentication++* Some poor sod needs to add digest authentication to `http-client` so+  we can use it++* Cache management
+ changelog.md view
@@ -0,0 +1,42 @@+-*- markdown -*-++xxx-xxx 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/JsonResponse.hs view
@@ -0,0 +1,122 @@+-- Examples of handling for JSON responses+--+-- This library provides several ways to handle JSON responses++{-# LANGUAGE DeriveGeneric, OverloadedStrings, ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-unused-binds #-}++import Control.Lens ((&), (^.), (^?), (.~))+import Data.Aeson (FromJSON)+import Data.Aeson.Lens (key)+import Data.Map (Map)+import Data.Text (Text)+import GHC.Generics (Generic)+import qualified Control.Exception as E++import Network.Wreq+++-- This Haskell type corresponds to the structure of a response body+-- from httpbin.org.++data GetBody = GetBody {+    headers :: Map Text Text+  , args :: Map Text Text+  , origin :: Text+  , url :: Text+  } deriving (Show, Generic)++-- Get GHC to derive a FromJSON instance for us.++instance FromJSON GetBody++++-- We expect this to succeed.++basic_asJSON :: IO ()+basic_asJSON = do+  let opts = defaults & param "foo" .~ ["bar"]+  r <- asJSON =<< getWith opts "http://httpbin.org/get"++  -- The fact that we want a GetBody here will be inferred by our use+  -- of the "headers" accessor function.++  putStrLn $ "args: " ++ show (args (r ^. responseBody))++++-- The response we expect here is valid JSON, but cannot be converted+-- to an [Int], so this will throw a JSONError.++failing_asJSON :: IO ()+failing_asJSON = do+  (r :: Response [Int]) <- asJSON =<< get "http://httpbin.org/get"+  putStrLn $ "response: " ++ show (r ^. responseBody)++++-- This demonstrates how to catch a JSONError.++failing_asJSON_catch :: IO ()+failing_asJSON_catch =+  failing_asJSON `E.catch` \(e :: JSONError) -> print e++++-- Because asJSON is parameterized over MonadThrow, we can use it with+-- other instances.+--+-- Here, instead of throwing an exception in the IO monad, we instead+-- evaluate the result as an Either:+--+-- * if the conversion fails, the Left constructor will contain+--   whatever exception describes the error+--+-- * if the conversion succeeds, the Right constructor will contain+--   the converted response++either_asJSON :: IO ()+either_asJSON = do+  r <- get "http://httpbin.org/get"++  -- This first conversion attempt will fail, but because we're using+  -- Either, it will not throw an exception that kills execution.+  let failing = asJSON r :: Either E.SomeException (Response [Int])+  print failing++  -- Our second conversion attempt will succeed.+  let succeeding = asJSON r :: Either E.SomeException (Response GetBody)+  print succeeding++++-- The lens package defines some handy combinators for use with the+-- aeson package, with which we can easily traverse parts of a JSON+-- response.++lens_aeson :: IO ()+lens_aeson = do+  r <- get "http://httpbin.org/get"+  print $ r ^? responseBody . key "headers" . key "User-Agent"++  -- If we maintain the ResponseBody as a ByteString, the lens+  -- combinators will have to convert the body to a Value every time+  -- we start a new traversal.++  -- When we need to poke at several parts of a response, it's more+  -- efficient to use asValue to perform the conversion to a Value+  -- once.++  let opts = defaults & param "baz" .~ ["quux"]+  v <- asValue =<< getWith opts "http://httpbin.org/get"+  print $ v ^? responseBody . key "args" . key "baz"++++main :: IO ()+main = do+  basic_asJSON+  failing_asJSON_catch+  either_asJSON+  lens_aeson
+ 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
@@ -0,0 +1,168 @@+-- upload a paste to lpaste.net+--+-- This example is pretty beefy, as it does double duty.+--+-- Perhaps the majority of it shows off some complex uses of the+-- optparse-applicative package.+--+-- The POST portion is in the function named upload below.  It uploads+-- an application/x-www-urlencoded form that creates a paste on the+-- Haskell community pastebin at <http://lpaste.net/>.++{-# 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 Network.Wreq (FormParam((:=)), post, responseBody)+import Network.Wreq.Types (FormValue(..))+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+import qualified Data.ByteString.Lazy.Char8 as L++-- A post to lpaste.net can either be private or public (visible in an+-- index).+data Visibility = Private | Public+                deriving (Show)++-- Wreq supports uploading an application/x-www-urlencoded form (see+-- uses of the := operator in the upload function below), so we tell+-- it how to render a value of a custom datatype.+instance FormValue Visibility where+  renderFormValue = renderFormValue . show++-- The languages that lpaste.net supports. It just so happens that if+-- we convert one of these constructor names to a lower-case string,+-- it exactly matches what lpaste.net needs in its upload form.+data Language =+  Haskell | Agda | Assembly | Bash | C | Coq | Cpp | Cs | Diff | Elm | ELisp |+  Erlang | Go | Idris | Java | JavaScript | LiterateHaskell | Lisp |+  Lua | OCaml | ObjectiveC | Perl | Prolog | Python | Ruby | SQL | Scala |+  Scheme | Smalltalk | TeX+  deriving (Eq, Show)++instance FormValue Language where+  renderFormValue = renderFormValue . fmap toLower . show++-- An association between filename suffixes and our Language type.+languages :: [([String], Language)]+languages = [+  ([".hs"], Haskell), ([".agda"], Agda), ([".el"], ELisp), ([".ocaml"], OCaml),+  ([".cl"], Lisp), ([".erl"], Erlang), ([".lhs"], LiterateHaskell),+  ([".scala"], Scala), ([".go"], Go), ([".py"], Python), ([".rb"], Ruby),+  ([".elm"], Elm), ([".idris"], Idris), ([".prl"], Prolog), ([".scm"], Scheme),+  ([".coq"], Coq), ([".s", ".asm"], Assembly), ([".sh"], Bash),+  ([".c", ".h"], C), ([".cs"], Cs), ([".tex"], TeX), ([".lua"], Lua),+  ([".cxx", ".cpp", ".cc", ".hxx", ".hpp", ".hh"], Cpp), ([".pl", ".pm"], Perl),+  ([".diff", ".patch"], Diff), ([".java"], Java), ([".js"], JavaScript),+  ([".m"], ObjectiveC), ([".smalltalk"], Smalltalk), ([".sql"], SQL)+  ]++-- An IRC channel to which an announcement of a paste can be posted.+-- We wrap this in a newtype so we can control how it is rendered in a+-- form.+newtype Channel = Channel { fromChannel :: String }+                deriving (Eq, Show)++-- If a user forgot to supply a leading '#' for a channel name, we add+-- it here.+instance FormValue Channel where+  renderFormValue = renderFormValue . checkHash . fromChannel+    where checkHash cs@('#':_) = cs+          checkHash cs@(_:_)   = '#' : cs+          checkHash cs         = cs++-- This type plays two roles.  It describes the command line options+-- we accept, and also the contents of the form we'll upload to create+-- a new paste.+--+-- We've parameterised the type so that the payload field can either+-- be a filename or the actual contents of the file.+data Paste a = Paste {+    _private :: Visibility+  , _title :: Maybe String+  , _author :: Maybe String+  , _channel :: Maybe Channel+  , _language :: Maybe Language+  , _payload :: a+  , _email :: () -- used by lpaste.net for spam protection+  } deriving (Show)++makeLenses ''Paste++-- Try to match a user-supplied name to a Language type, looking at+-- both full names and filename extensions.+readLanguage :: ReadM Language+readLanguage = do+  l <- readerAsk+  let ll = toLower <$> l+      ms = [lang | (suffixes, lang) <- languages,+            ll == (toLower <$> show lang) || ll `elem` (tail <$> suffixes)]+  case ms of+    [m] -> return m+    _   -> fail $ "unsupported language " ++ show l++-- Figure out the language to specify for a file, either explicitly as+-- specified by the user, or implicitly from the filename extension.+guessLanguage :: FilePath -> Paste a -> Maybe Language+guessLanguage filename p =+    (p ^. language) <|>+    listToMaybe [lang | (suffixes, lang) <- languages, sfx `elem` suffixes]+  where sfx = toLower <$> takeExtension filename++upload :: Paste FilePath -> IO ()+upload p0 = do+  let path = p0 ^. payload+  body <- B.readFile path+  -- Transform command line options into form contents.+  let p = p0 & payload .~ body+             & title .~ (p0 ^. title <|> Just (takeFileName path))+             & language .~ guessLanguage path p0+  -- The := operator defines a key/value pair for a form.+  resp <- post "http://lpaste.net/new" [+            "private" := p ^. private+          , "title" := p ^. title+          , "author" := p ^. author+          , "channel" := p ^. channel+          , "language" := p ^. language+          , "paste" := p ^. payload+          , "email" := p ^. email+          ]+  -- Since lpaste.net doesn't provide an API and just spits HTML back+  -- at us, we use tagsoup to look through the tags for the permalink+  -- of the paste we just uploaded.+  let findURI (TagOpen "strong" [] : TagText "Paste:" : TagClose "strong" :+               TagOpen "a" [("href",uri)] : _) = Just uri+      findURI (_:xs) = findURI xs+      findURI _      = Nothing+  case findURI (parseTagsOptions parseOptionsFast (resp ^. responseBody)) of+    Just uri -> L.putStrLn $ "http://lpaste.net" <> uri+    Nothing  -> putStrLn "no uri in response!?"++main :: IO ()+main = upload =<< execParser opts+  where opts = info (helper <*> optionParser) mempty+        optionParser = Paste <$>+          (flag Private Public $ long "public" <>+                                 help "display in index of pastes") <*>+          (optional . strOption $+           long "title" <> short 't' <> metavar "TITLE" <>+           help "title to use for paste") <*>+          (optional . strOption $+           long "author" <> short 'a' <> metavar "AUTHOR" <>+           help "author to display for paste") <*>+          (optional . fmap Channel . strOption $+           long "channel" <> short 'c' <> metavar "CHANNEL" <>+           help "name of IRC channel to announce") <*>+          (optional . option readLanguage $+           long "language" <> short 'l' <> metavar "LANG" <>+           help "language to use") <*>+          (Opts.argument str $ metavar "PATH" <>+                               help "file to upload") <*>+          (pure ())
+ examples/wreq-examples.cabal view
@@ -0,0 +1,64 @@+name:                wreq-examples+version:             0+synopsis:            wreq examples, not for installing+description:+homepage:            https://github.com/bos/wreq+bug-reports:         https://github.com/bos/wreq/issues+license:             BSD3+license-file:        ../LICENSE.md+maintainer:          bos@serpentine.com+category:            Web+build-type:          Simple+cabal-version:       >=1.10++executable wreq-example-json-response+  main-is:        JsonResponse.hs+  ghc-options:    -Wall -fwarn-tabs -threaded+  default-language: Haskell98++  build-depends:+    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,+    ansi-wl-pprint >= 0.6.6,+    base >= 4.5 && < 5,+    bytestring,+    filepath,+    lens,+    optparse-applicative >= 0.11,+    mtl,+    tagsoup,+    text,+    wreq++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
@@ -0,0 +1,7 @@+module Main (main) where++import HttpBin.Server (serve)+import Snap.Http.Server.Config (commandLineConfig)++main :: IO ()+main = serve commandLineConfig
+ httpbin/HttpBin/Server.hs view
@@ -0,0 +1,177 @@+{-# 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(..), encodePretty')+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 = [(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' (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)++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,133 @@+{-# 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 **+For now, enable AWS tests by setting the WREQ_AWS_ACCESS_KEY_ID+env variable per below.++TODO| To enable AWS tests use the `-faws` flag as part of+TODO|   $ cabal configure --enable-tests -faws ...+TODO| To capture code coverage information, add the `-fdeveloper` flag.++** 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+  -- TODO - use ... configure -faws ... in the future+  --        but couldn't figure out (yet) how to get+  --        a hold of the flag value in test code.+  -- Workaround: for now, the presence of the+  --   WREQ_AWS_ACCESS_KEY_ID+  -- env variable enables the tests.+  flag <- (getEnv "WREQ_AWS_ACCESS_KEY_ID" >> return True) `E.catch`+          \(_::IOException) -> return False+  tests0 flag++tests0 :: Bool -> IO Test+tests0 False =+  return $ testGroup "aws" [] -- skip AWS tests+tests0 True = do+  region <- env "us-west-2" "WREQ_AWS_REGION"+  key <- BS8.pack `fmap` getEnv "WREQ_AWS_ACCESS_KEY_ID"+  secret <- BS8.pack `fmap` getEnv "WREQ_AWS_SECRET_ACCESS_KEY"+  let baseopts = defaults & auth ?~ awsAuth AWSv4 key secret+  prefix <- env "deleteWreqTest" "WREQ_AWS_TEST_PREFIX"+  sqsTestState <- newIORef "missing"+  iamTestState <- newIORef "missing"+  uniq <- uniqueMachineId+  let bucketname = prefix ++ uniq+  return $ testGroup "aws" [+      AWS.DynamoDB.tests (prefix ++ "DynamoDB") region baseopts+    , AWS.IAM.tests (prefix ++ "IAM") region baseopts 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,186 @@+{-# LANGUAGE OverloadedLists, OverloadedStrings #-}+module AWS.IAM (tests) where++import AWS.Aeson+import Control.Concurrent (threadDelay)+import Control.Lens hiding ((.=))+import Data.Aeson.Encode (encode)+import Data.Aeson.Lens (key, _String, values)+import Data.IORef (IORef, readIORef, writeIORef)+import Data.Text as T (Text, pack, unpack, split)+import Data.Text.Lazy as LT (toStrict)+import Data.Text.Lazy.Encoding as E (decodeUtf8)+import Network.Wreq+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit (assertBool)++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)+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)+  assertBool "stsAssumeRole 200" $ r ^. responseStatus . statusCode == 200+  assertBool "stsAssumeRole OK" $ r ^. responseStatus . statusMessage == "OK"++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 view
@@ -0,0 +1,47 @@+-- 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
@@ -0,0 +1,23 @@+{-# LANGUAGE CPP #-}++module Main (main) where++import Test.Framework (testGroup)+import UnitTests (testWith)+import qualified Properties.Store++#if defined(AWS_TESTS)+import qualified AWS (tests)+#endif++main :: IO ()+main = do+#if defined(AWS_TESTS)+  awsTests <- AWS.tests+#else+  let awsTests = testGroup "aws" []+#endif+  testWith [+      testGroup "store" Properties.Store.tests+    , awsTests+    ]
+ tests/UnitTests.hs view
@@ -0,0 +1,393 @@+{-# 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, toException)+import Control.Lens ((^.), (^?), (.~), (?~), (&))+import Control.Monad (unless, void)+import Data.Aeson+import Data.Aeson.Lens (key)+import Data.ByteString (ByteString)+import Data.Char (toUpper)+import Data.Maybe (isJust)+import Data.Monoid ((<>))+import HttpBin.Server (serve)+import Network.HTTP.Client (HttpException(..))+import Network.HTTP.Types.Status (Status(Status), status200, status401)+import Network.HTTP.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.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 :: Postable a => String -> a -> IO (Response L.ByteString)+  , postWith :: Postable a => Options -> String -> a+             -> IO (Response L.ByteString)+  , head_ :: String -> IO (Response ())+  , headWith :: Options -> String -> IO (Response ())+  , put :: Putable a => String -> a -> IO (Response L.ByteString)+  , putWith :: Putable a => Options -> String -> a -> IO (Response L.ByteString)+  , 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 }++basicGet Verb{..} 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 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" . key "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" . key "Content-Type")++byteStringPut Verb{..} site = do+  let opts = defaults & header "Content-Type" .~ ["application/json"]+  r <- putWith opts (site "/put") $ encode solrAdd+  assertEqual "ByteString PUT request has correct Content-Type header"+    (Just "application/json")+    (r ^. responseBody ^? key "headers" . key "Content-Type")++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 e = case e of+                      StatusCodeException _ _ _ -> return ()+                      _ -> assertFailure "unexpected exception thrown"++getBasicAuth Verb{..} site = do+  let opts = defaults & auth ?~ basicAuth "user" "passwd"+  r <- getWith opts (site "/basic-auth/user/passwd")+  assertEqual "basic auth GET succeeds" status200 (r ^. responseStatus)+  let inspect e = case e of+                    StatusCodeException status _ _ ->+                      assertEqual "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")++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 e = case e of+                    StatusCodeException status _ _ ->+                      assertEqual ("oauth2 " <> kind <> " failed GET gives 401")+                        status401 status+  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" . key "X-Wibble")++getCheckStatus Verb {..} site = do+  let opts = defaults & checkStatus .~ (Just customCs)+  r <- getWith opts (site "/status/404")+  assertThrows "Non 404 throws error" inspect $+    getWith opts (site "/get")+  assertEqual "Status 404"+    404+    (r ^. responseStatus . statusCode)+  where+    customCs (Status 404 _) _ _ = Nothing+    customCs s h cj             = Just . toException . StatusCodeException s h $ cj++    inspect e = case e of+      (StatusCodeException (Status sc _) _ _) ->+        assertEqual "200 Status Error" sc 200++getGzip Verb{..} site = do+  r <- get (site "/gzip")+  assertEqual "gzip decoded for us" (Just (Bool True))+    (r ^. responseBody ^? key "gzipped")++headRedirect Verb{..} 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 Verb{..} site =+  assertThrows "GET with too many redirects throws exception" inspect $+    getWith (defaults & redirects .~ 3) (site "/redirect/5")+  where inspect e = case e of TooManyRedirects _ -> return ()++invalidURL Verb{..} _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 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 = Session.withSession $ \s -> do+  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 = Session.withSession $ \s -> do+  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://localhost:" <> p))+            mkCfg = return . setBind ("localhost") . 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+  Session.withSession $ \s ->+    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 <>)+            ]+          ]
+ wreq-sb.cabal view
@@ -0,0 +1,219 @@+name:                wreq-sb+version:             0.4.0.0+synopsis:            An easy-to-use HTTP client library.+description:+  .+  A web client library that is designed for ease of use.+  .+  Tutorial: <http://www.serpentine.com/wreq/tutorial.html>+  .+  Features include:+  .+  * Simple but powerful `lens`-based API+  .+  * A solid test suite, and built on reliable libraries like+    http-client and lens+  .+  * Session handling includes connection keep-alive and pooling, and+    cookie persistence+  .+  * Automatic response body decompression+  .+  * Powerful multipart form and file upload handling+  .+  * Support for JSON requests and responses, including navigation of+    schema-less responses+  .+  * Basic and OAuth2 bearer authentication+  .+  * Early TLS support via the tls package+homepage:            http://www.serpentine.com/wreq+bug-reports:         https://github.com/stackbuilders/wreq/issues+license:             BSD3+license-file:        LICENSE.md+author:              Bryan O'Sullivan <bos@serpentine.com>+maintainer:          bos@serpentine.com+copyright:           2014 Bryan O'Sullivan+category:            Web+build-type:          Custom+cabal-version:       >=1.10+extra-source-files:+  README.md+  TODO.md+  changelog.md+  examples/*.cabal+  examples/*.hs+  www/*.css+  www/*.md+  www/Makefile++-- 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+  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_sb+  build-depends:+    psqueues >= 0.2,+    aeson >= 0.7.0.3,+    attoparsec >= 0.11.1.0,+    authenticate-oauth == 1.5.*,+    base >= 4.5 && < 5,+    base16-bytestring,+    byteable,+    bytestring >= 0.9,+    case-insensitive,+    containers,+    cryptohash,+    exceptions >= 0.5,+    ghc-prim,+    hashable,+    http-client >= 0.4.6,+    http-client-tls >= 0.2,+    http-types >= 0.8,+    lens >= 4.5,+    lens-aeson,+    mime-types,+    old-locale,+    template-haskell,+    text,+    time,+    unordered-containers++-- A convenient server for testing locally, or if httpbin.org is down.+executable httpbin+  hs-source-dirs: httpbin+  ghc-options:    -Wall -fwarn-tabs -threaded -rtsopts+  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,+      base64-bytestring,+      bytestring,+      case-insensitive,+      containers,+      snap-core,+      snap-server >= 0.9.4.4,+      text,+      time,+      transformers,+      unix-compat,+      uuid++test-suite tests+  type:           exitcode-stdio-1.0+  hs-source-dirs: httpbin tests+  main-is:        Tests.hs+  ghc-options:    -Wall -fwarn-tabs -funbox-strict-fields -threaded -rtsopts+  default-language: Haskell98+  other-modules:+    Properties.Store+    UnitTests++  if flag(aws)+    cpp-options: -DAWS_TESTS+    other-modules:+      AWS+      AWS.Aeson+      AWS.DynamoDB+      AWS.IAM+      AWS.S3+      AWS.SQS++  if flag(aws)+    build-depends: base >= 4.7 && < 5++  build-depends:+    HUnit,+    QuickCheck >= 2.7,+    aeson,+    aeson-pretty >= 0.7.1,+    base >= 4.5 && < 5,+    base64-bytestring,+    bytestring,+    case-insensitive,+    containers,+    hashable,+    http-client,+    http-types,+    lens,+    lens-aeson,+    network-info,+    snap-core,+    snap-server >= 0.9.4.4,+    temporary,+    test-framework,+    test-framework-hunit,+    test-framework-quickcheck2,+    text,+    time,+    transformers,+    unix-compat,+    uuid,+    vector,+    wreq-sb++test-suite doctest+  type:           exitcode-stdio-1.0+  hs-source-dirs: tests+  main-is:        DocTests.hs+  ghc-options:    -Wall -fwarn-tabs -threaded+  default-language: Haskell98++  if !flag(doctest)+    buildable: False+  else+    build-depends:+      base >= 4.5 && < 5,+      directory,+      doctest,+      filepath++source-repository head+  type:     git+  location: https://github.com/stackbuilders/wreq
+ www/Makefile view
@@ -0,0 +1,23 @@+bootstrap := bootstrap-3.1.1-dist++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 $(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 \+	  --css $(bootstrap)/css/bootstrap.css \+	  --css bootstrap-custom.css \+	  --toc --toc-depth 2++clean:+	-rm -f $(files)
+ www/bootstrap-custom.css view
@@ -0,0 +1,59 @@+html {+    position: relative;+    min-height: 100%;+}+body {+    /* Margin bottom by footer height */+    margin-bottom: 80px;+}+#footer {+    position: absolute;+    bottom: 0;+    width: 100%;+    /* Set the fixed height of the footer here */+    height: 80px;+    background-color: #f5f5f5;+}++a > code { color: #02d; }+a > code:hover { color: #44f; }+div.nav.bs-docs-sidenav > ul { list-style-type: none; }+div.nav.bs-docs-sidenav > ul > li > ul { list-style-type: none; }++h1, h2, h3, h4 {+    font-family: 'Roboto', 'sans-serif';+    margin-top: 40px;+}+p, div {+    font-family: 'Roboto Slab', 'sans-serif';+}++.container .text-muted {+    margin: 10px 0;+}++.jumboback > .navbar {+     background: rgba(0,0,0,0.4);+     margin-bottom: 0;+     text-shadow: none;+     border: 0;+     border-radius: 0;+}++.jumboback > .navbar > a, .jumboback > .navbar > ul > li > a {+    color: white;+}++.jumboback > .jumbotron {+    background: transparent;+}++.jumboback {+    background-image: url(background.jpg);+    margin-bottom: 20px;+    background-position: -20% 25%;+    background-size: cover;+    background-repeat: no-repeat;+    color: white;+    text-shadow: black 0em 0em 0.8em;+}
+ www/index.md view
@@ -0,0 +1,150 @@+% wreq: a Haskell web client library+% HTTP made easy for Haskell.+  <a href="tutorial.html" class="btn btn-primary btn-lg" role="button">Tutorial</a>++++`wreq` is a library that makes HTTP client programming in Haskell+easy.+++# Features++* Simple but powerful `lens`-based API++* Over 100 tests, and built on reliable libraries like [`http-client`](http://hackage.haskell.org/package/http-client/)+  and [`lens`](https://lens.github.io/)++* Session handling includes connection keep-alive and pooling, and+  cookie persistence++* Automatic decompression++* Powerful multipart form and file upload handling++* Support for JSON requests and responses, including navigation of+  schema-less responses++* 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"+~~~~++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}+ghci> import Control.Lens+ghci> r ^. responseHeader "Content-Type"+"application/json"+~~~~++Safely and sanely add query parameters to URLs. Let's find the most+popular implementations of Tetris in Haskell.++~~~~ {.haskell}+ghci> let opts = defaults & param "q" .~ ["tetris"]+                          & param "language" .~ ["haskell"]+ghci> r <- getWith opts "https://api.github.com/search/repositories"+~~~~++Haskell-to-JSON interoperation is seamless.++~~~~ {.haskell}+ghci> import GHC.Generics+ghci> import Data.Aeson+ghci> :set -XDeriveGeneric++ghci> data Addr = Addr Int String deriving (Generic)+ghci> instance ToJSON Addr++ghci> let addr = Addr 1600 "Pennsylvania"+ghci> post "http://httpbin.org/post" (toJSON addr)+~~~~+++Work easily with schemaless JSON APIs.  This traverses the complex+JSON search result we just received from GitHub above, and pulls out+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",{-...-}+~~~~++Easily write+[`attoparsec`](http://hackage.haskell.org/package/attoparsec) parsers+on the spot, to safely and reliably deal with complicated headers and+bodies.++~~~~ {.haskell}+ghci> import Data.Attoparsec.ByteString.Char8 as A+ghci> import Data.List (sort)++ghci> let comma = skipSpace >> "," >> skipSpace+ghci> let verbs = A.takeWhile isAlpha_ascii `sepBy` comma++ghci> r <- options "http://httpbin.org/get"+ghci> r ^. responseHeader "Allow" . atto verbs . to sort+ghci> ["GET","HEAD","OPTIONS"]+~~~~++There's a lot more, but why not jump in and start coding. In fact, if+you'd like to add new features, that would be great! We love pull+requests.+++<div class="jumbotron" style="margin-top: 40px;">+<h2 style="margin-top: 20px;">Ready to jump in?</h2>++We've worked hard to make `wreq` quick to learn.++<a href="tutorial.html" class="btn btn-success btn-lg" role="button">Tutorial</a>++We're proud of the example-filled docs.++<a href="http://hackage.haskell.org/package/wreq" class="btn btn-info btn-lg" role="button">Documentation</a>++If you run into problems, let us know.++<a href="https://github.com/bos/wreq" class="btn btn-warning btn-lg" role="button">Issues</a>++</div>+++# Acknowledgments++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`.++I also want to thank Michael Snoyman for being so quick with helpful+responses to bug reports and pull requests against his excellent+[http-client](http://hackage.haskell.org/package/http-client) package.++Finally, thanks to Kenneth Reitz for building the indispensable+[httpbin.org](http://httpbin.org/) HTTP testing service, and of course+for his [requests library](http://docs.python-requests.org/en/latest/).
+ www/tutorial.md view
@@ -0,0 +1,596 @@+% A wreq tutorial+% Learn how to write web clients. We start easy, then ramp up the power.++# Installation++To use the `wreq` package, simply use `cabal`, the standard Haskell+package management command.++~~~~+cabal update+cabal install -j --disable-tests wreq+~~~~++Depending on how many prerequisites you already have installed, and+what your Cabal configuration looks like, the build may take a few+minutes: a few seconds for `wreq`, and the rest for its dependencies.+++# Interactive usage++We'll run our examples interactively via the `ghci` shell.++~~~~+$ ghci+~~~~++To start using `wreq`, we import the+[`Network.Wreq`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html)+module.++~~~~ {.haskell}+ghci> import Network.Wreq+ghci> r <- get "http://httpbin.org/get"+ghci> :type r+r :: Response ByteString+~~~~++The variable `r` above is the+[`Response`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#t:Response)+from the server.+++## Working with string-like types++Complex Haskell libraries and applications have to deal fluently with+Haskell's three main string types: `String` ("legacy"), `Text`, and+`ByteString` (mostly used for binary data, sometimes ASCII).++To write string literals without having to always provide a conversion+function, we use the `OverloadedStrings` language extension.++Throughout the rest of this tutorial, we'll assume that you have+enabled `OverloadedStrings` in `ghci`:++~~~~ {.haskell}+ghci> :set -XOverloadedStrings+~~~~++If you're using `wreq` from a Haskell source file, put a pragma at the+top of your file:++~~~~ {.haskell}+{-# LANGUAGE OverloadedStrings #-}+~~~~+++# A quick lens backgrounder++The `wreq` package makes heavy use of Edward Kmett's+[`lens`](https://lens.github.io/) package to provide a clean,+consistent API.++~~~~ {.haskell}+ghci> import Control.Lens+~~~~++While `lens` has a vast surface area, the portion that you must+understand in order to productively use `wreq` is tiny.++A lens provides a way to focus on a portion of a Haskell value. For+example, the `Response` type has a+[`responseStatus`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#v:responseStatus)+lens, which focuses on the status information returned by the server.++~~~~ {.haskell}+ghci> r ^. responseStatus+Status {statusCode = 200, statusMessage = "OK"}+~~~~++The+[`^.`](http://hackage.haskell.org/package/lens/docs/Control-Lens-Getter.html#v:-94-.)+operator takes a value as its first argument, a lens as its second,+and returns the portion of the value focused on by the lens.++We compose lenses using function composition, which allows us to+easily focus on part of a deeply nested structure.++~~~~ {.haskell}+ghci> r ^. responseStatus . statusCode+200+~~~~++We'll have more to say about lenses as this tutorial proceeds.+++# Changing default behaviours++While+[`get`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#v:get)+ is convenient and easy to use, there's a lot more power+available to us.++For example, if we want to add parameters to the query string of a+URL, we will use the+[`getWith`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#v:getWith)+function.  The `*With` family of functions all accept an+[`Options`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#t:Options)+parameter that allow changes from the library's default behaviours.++~~~~ {.haskell}+ghci> import Data.Aeson.Lens (_String, key)+ghci> let opts = defaults & param "foo" .~ ["bar", "quux"]+ghci> r <- getWith opts "http://httpbin.org/get"+ghci> r ^. responseBody . key "url" . _String+"http://httpbin.org/get?foo=bar&foo=quux"+~~~~++(We'll talk more about `key` and `_String` below.)++The default parameters for all queries is represented by the variable+[`defaults`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#v:defaults).+(In fact, `get` is defined simply as `getWith defaults`.)++Here's where we get to learn a little more about lenses.++In addition to *getting* a value from a nested structure, we can also+*set* (edit) a value within a nested structure, which makes an+identical copy of the structure except for the portion we want to+modify.++The `&` operator is just function application with its operands+reversed, so the function is on the right and its parameter is on the+left.++~~~~ {.haskell}+parameter & functionToApply+~~~~++The+[`.~`](http://hackage.haskell.org/package/lens/docs/Control-Lens-Setter.html#v:.-126-)+ operator turns a lens into a setter function, with the lens+on the left and the new value on the right.++~~~~ {.haskell}+param "foo" .~ ["bar", "quux"]+~~~~++<a id="param">The+[`param`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#v:param)+lens</a> focuses on the values associated with the given key in the+query string.++~~~~ {.haskell}+param :: Text -> Lens' Options [Text]+~~~~++The reason we allow for a list of values instead of just a single+value is simply that this is completely legitimate. For instance, in+our example above we generate the query string `foo=bar&foo=quux`.++If you use non-ASCII characters in a `param` key or value, they will+be encoded as UTF-8 before being URL-encoded, so that they can be+safely transmitted over the wire.+++# Accessing the body of a response++The+[`responseBody`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#v:responseBody)+lens gives us access to the body of a response.++~~~~ {.haskell}+ghci> r <- get "http://httpbin.org/get"+ghci> r ^. responseBody+"{\n  \"headers\": {\n    \"Accept-Encoding\": \"gzip"{-...-}+~~~~++The response body is a raw lazy+[`ByteString`](http://hackage.haskell.org/package/bytestring/docs/Data-ByteString-Lazy.html#t:ByteString).+++## JSON responses++We can use the+[`asJSON`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#v:asJSON)+function to convert a response body to a Haskell value that implements+the+[`FromJSON`](http://hackage.haskell.org/package/aeson/docs/Data-Aeson-Types.html#t:FromJSON)+class.++~~~~ {.haskell}+ghci> import Data.Map as Map+ghci> import Data.Aeson (Value)+ghci> type Resp = Response (Map String Value)+ghci> r <- asJSON =<< get "http://httpbin.org/get" :: IO Resp+ghci> Map.size (r ^. responseBody)+4+~~~~++<div class="alert alert-info">+In this example, we have to tell `ghci` exactly what target type we+are expecting. In a real Haskell program, the correct return type will+usually be inferred automatically, making an explicit type signature+unnecessary in most cases.+</div>++If the response is not `application/json`, or we try to convert to an+incompatible Haskell type, a+[`JSONError`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#t:JSONError)+exception will be thrown.++~~~~ {.haskell}+ghci> type Resp = Response [Int]+ghci> r <- asJSON =<< get "http://httpbin.org/get" :: IO Resp+*** Exception: JSONError "when expecting a [a], encountered Object instead"+~~~~+++## Convenient JSON traversal++The `lens` package provides some extremely useful functions for+traversing JSON structures without having to either build a+corresponding Haskell type or traverse a `Value` by hand.++The first of these is+[`key`](http://hackage.haskell.org/package/lens/docs/Data-Aeson-Lens.html#v:key),+which traverses to the named key in a JSON object.++~~~~ {.haskell}+ghci> import Data.Aeson.Lens (key)+ghci> r <- get "http://httpbin.org/get"+ghci> r ^? responseBody . key "url"+Just (String "http://httpbin.org/get")+~~~~++<div class="alert alert-info">+Notice our use of the+[`^?`](http://hackage.haskell.org/package/lens-4.1.2/docs/Control-Lens-Fold.html#v:-94--63-)+operator here. This is like `^.`, but it allows for the possibility+that an access might fail---and of course there may not be a key named+`"url"` in our object.+</div>++That said, our result above has the type `Maybe Value`, so it's quite+annoying to work with. This is where the `_String` lens comes in.++~~~~ {.haskell}+ghci> import Data.Aeson.Lens (_String, key)+ghci> r <- get "http://httpbin.org/get"+ghci> r ^. responseBody . key "url" . _String+"http://httpbin.org/get"+~~~~++If the key exists, and is a `Value` with a `String` constructor,+`_String` gives us back a regular `Text` value with all the wrappers+removed; otherwise it gives an empty value. Notice what happens as we+switch between `^?` and `^.` in these examples.++~~~~ {.haskell}+ghci> r ^. responseBody . key "fnord" . _String+""+ghci> r ^? responseBody . key "fnord" . _String+Nothing+ghci> r ^? responseBody . key "url" . _String+Just "http://httpbin.org/get"+~~~~+++# Working with headers++To add headers to a request, we use the+[`header`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#v:header)+lens.++~~~~ {.haskell}+ghci> let opts = defaults & header "Accept" .~ ["application/json"]+ghci> getWith opts "http://httpbin.org/get"+~~~~++As with the [`param`](#param) lens, if we provide more than one value to go+with a single key, this will expand to several headers.++~~~~ {.haskell}+header :: HeaderName -> Lens' Options [ByteString]+~~~~++When we want to inspect the headers of a response, we use the+[`responseHeader`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#v:responseHeader)+lens.++~~~~ {.haskell}+ghci> r <- get "http://httpbin.org/get"+ghci> r ^. responseHeader "content-type"+"application/json"+~~~~++<div class="alert alert-info">+Header names are case insensitive.+</div>++If a header is not present in a response, then `^.` will give an empty+string, while `^?` will give `Nothing`.++~~~~ {.haskell}+ghci> r ^. responseHeader "X-Nonesuch"+""+ghci> r ^? responseHeader "X-Nonesuch"+Nothing+~~~~+++# Uploading data via POST++We use the [`post`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#v:post)+ and+ [`postWith`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#v:postWith)+ functions to issue POST requests.++~~~~ {.haskell}+ghci> r <- post "http://httpbin.org/post" ["num" := 3, "str" := "wat"]+ghci> r ^? responseBody . key "form"+Just (Object fromList [("num",String "3"),("str",String "wat")])+~~~~++The [httpbin.org](http://httpbin.org/) server conveniently echoes our+request headers back at us, so we can see what kind of body we POSTed.++~~~~ {.haskell}+ghci> r ^. responseBody . key "headers" . key "Content-Type" . _String+"application/x-www-form-urlencoded"+~~~~++The+[`:=`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#v::-61-)+operator is the constructor for the+[`FormParam`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#t:FormParam)+type, which `wreq` uses as a key/value pair to generate an+`application/x-www-form-urlencoded` form body to upload.++A class named+[`FormValue`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#t:FormValue)+determines how the operand on the right-hand side of `:=` is encoded,+with sensible default behaviours for strings and numbers.++The slightly more modern way to upload POST data is via a+`multipart/form-data` payload, for which `wreq` provides the+[`Part`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#t:Part)+type.++~~~~ {.haskell}+ghci> r <- post "http://httpbin.org/post" [partText "button" "o hai"]+ghci> r ^. responseBody . key "headers" . key "Content-Type" . _String+"multipart/form-data; boundary=----WebKitFormBoundaryJsEZfuj89uj"+~~~~++The first argument to these `part*` functions is the label of the+`<input>` element in the form being uploaded.++Let's inspect httpbin.org's response to see what we uploaded.  When we+think there could be more than one value associated with a lens, we+use the+[`^..`](http://hackage.haskell.org/package/lens-4.1.2/docs/Control-Lens-Fold.html#v:-94-..)+operator, which returns a list.++~~~~ {.haskell}+ghci> r ^.. responseBody . key "form"+[Object fromList [("button",String "o hai")]]+~~~~+++## Uploading file contents++To upload a file as part of a `multipart/form-data` POST, we use+[`partFile`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#t:partFile),+or if the file is large enough that we want to stream its contents,+[`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"]+~~~~++Both `partFile` and `partFileSource` will set the filename of a part+to whatever name they are given, and guess its content-type based on+the file name extension.  Here's an example of how we can upload a+file without revealing its name.++~~~~ {.haskell}+ghci> partFile "label" "foo.hs" & partFileName .~ Nothing+Part "label" Nothing (Just "text/plain") <m (RequestBody m)>+~~~~+++# Cookies++To see how easily we can work with cookies, let's ask the+ever-valuable httpbin.org to set a cookie in a response.++~~~~ {.haskell}+ghci> r <- get "http://httpbin.org/cookies/set?foo=bar"+ghci> r ^. responseCookie "foo" . cookieValue+"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+bearer authentication.++<div class="alert alert-danger">+**Note:** the security of these mechanisms is _absolutely dependent on+your use of TLS_, as the credentials can easily be stolen and reused+if transmitted unencrypted.+</div>++If we try to access a service that requires authentication, `wreq`+will throw a+[`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, {-...-}+~~~~++If we then supply a username and password, our request will succeed.+(Notice that we follow our own advice: we switch to `https` for our+retry.)++~~~~ {.haskell}+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+[`oauth2Token`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#v:oauth2Token)+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+throw a `HttpException`.++~~~~ {.haskell}+h> r <- get "http://httpbin.org/wibblesticks"+*** Exception: StatusCodeException (Status {statusCode = 404, {-...-}+~~~~++Here's a simple example of how we can respond to one kind of error: a+`get`-like function that retries with authentication if an+unauthenticated request fails.++~~~~ {.haskell}+import Control.Exception as E+import Control.Lens+import Network.HTTP.Client+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+~~~~++(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 = S.withSession $ \sess -> do+  -- 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.withSession`. It calls our code+  with `sess`, the `Session` value we'll use.++* 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.