wreq-0.4.1.0/0000755000000000000000000000000012636343441011024 5ustar0000000000000000wreq-0.4.1.0/changelog.md0000644000000000000000000000160312636343441013275 0ustar0000000000000000-*- markdown -*- 2015-05-10 0.4.0.0 * Compatible with GHC 7.10. * New withAPISession and withSessionControl functions make talking to REST services more efficient. * Added support for AWS S3 virtual-host style URLs. * Added signing support for region specific calls to the AWS Security Token Service (AWS STS). * The introduction of AWS support accidentally introduced unwanted AWS headers and computation into all requests. This has been fixed. 2014-12-11 0.3.0.1 * Bump lower bound on http-client to 0.3.0.1 2014-12-02 0.3.0.0 * Support for Amazon Web Services request signing * New customMethod, customMethodWith functions allow use of arbitrary HTTP verbs * httpProxy, basicAuth, oauth2Bearer, oauth2Token: removed Maybe from result types, changed documentation to suggest use of (?~) 2014-08-25 0.2.0.0 * Support for lens 4.4 2014-04-22 0.1.0.0 * Initial release. wreq-0.4.1.0/LICENSE.md0000644000000000000000000000270712636343441012436 0ustar0000000000000000Copyright © 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. wreq-0.4.1.0/README.md0000644000000000000000000000203012636343441012276 0ustar0000000000000000# wreq: a Haskell web client library [![Build Status](https://travis-ci.org/bos/wreq.svg)](https://travis-ci.org/bos/wreq) `wreq` is a library that makes HTTP client programming in Haskell easy. # 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. wreq-0.4.1.0/Setup.hs0000644000000000000000000000476312636343441012472 0ustar0000000000000000-- 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 wreq-0.4.1.0/TODO.md0000644000000000000000000000112412636343441012111 0ustar0000000000000000# 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 wreq-0.4.1.0/wreq.cabal0000644000000000000000000001172112636343441012770 0ustar0000000000000000name: wreq version: 0.4.1.0 synopsis: An easy-to-use HTTP client library. description: . A web client library that is designed for ease of use. . Tutorial: . 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/bos/wreq/issues license: BSD3 license-file: LICENSE.md author: Bryan O'Sullivan 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 if flag(developer) ghc-options: -Werror default-language: Haskell98 exposed-modules: Network.Wreq Network.Wreq.Cache Network.Wreq.Cache.Store Network.Wreq.Lens Network.Wreq.Session Network.Wreq.Types other-modules: Network.Wreq.Internal Network.Wreq.Internal.AWS Network.Wreq.Internal.Lens Network.Wreq.Internal.Link Network.Wreq.Internal.OAuth1 Network.Wreq.Internal.Types Network.Wreq.Lens.Machinery Network.Wreq.Lens.TH Paths_wreq 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, time-locale-compat, 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 if flag(developer) ghc-options: -Werror default-language: Haskell98 main-is: HttpBin.hs other-modules: HttpBin.Server if !flag(httpbin) buildable: False else build-depends: aeson >= 0.7, aeson-pretty >= 0.7.1, base >= 4.5 && < 5, 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 if flag(developer) ghc-options: -Werror 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 test-suite doctest type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: DocTests.hs ghc-options: -Wall -fwarn-tabs -threaded if flag(developer) ghc-options: -Werror 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/bos/wreq source-repository head type: mercurial location: https://bitbucket.org/bos/wreq wreq-0.4.1.0/examples/0000755000000000000000000000000012636343441012642 5ustar0000000000000000wreq-0.4.1.0/examples/JsonResponse.hs0000644000000000000000000000632012636343441015627 0ustar0000000000000000-- 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 wreq-0.4.1.0/examples/SimpleSession.hs0000644000000000000000000000140112636343441015767 0ustar0000000000000000{-# 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 wreq-0.4.1.0/examples/UploadPaste.hs0000644000000000000000000001526012636343441015423 0ustar0000000000000000-- 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 . {-# 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 ()) wreq-0.4.1.0/examples/wreq-examples.cabal0000644000000000000000000000257712636343441016433 0ustar0000000000000000name: 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 wreq-0.4.1.0/httpbin/0000755000000000000000000000000012636343441012474 5ustar0000000000000000wreq-0.4.1.0/httpbin/HttpBin.hs0000644000000000000000000000023112636343441014374 0ustar0000000000000000module Main (main) where import HttpBin.Server (serve) import Snap.Http.Server.Config (commandLineConfig) main :: IO () main = serve commandLineConfig wreq-0.4.1.0/httpbin/HttpBin/0000755000000000000000000000000012636343441014044 5ustar0000000000000000wreq-0.4.1.0/httpbin/HttpBin/Server.hs0000644000000000000000000001401312636343441015645 0ustar0000000000000000{-# 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) ] wreq-0.4.1.0/Network/0000755000000000000000000000000012636343441012455 5ustar0000000000000000wreq-0.4.1.0/Network/Wreq.hs0000644000000000000000000004375512636343441013745 0ustar0000000000000000{-# 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 -- ** Custom Payload Method , customPayloadMethod , customPayloadMethodWith -- * 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" . nth 2 -- Just (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 -- | Issue a custom-method request with a payload customPayloadMethod :: Postable a => String -> String -> a -> IO (Response L.ByteString) customPayloadMethod method url payload = customPayloadMethodWith method defaults url payload -- | Issue a custom-method request with a payload, using the supplied 'Options'. customPayloadMethodWith :: Postable a => String -> Options -> String -> a -> IO (Response L.ByteString) customPayloadMethodWith method opts url payload = runRead =<< preparePayloadMethod methodBS opts url payload where methodBS = BC8.pack method 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 \. -> 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 \. -> 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 wreq-0.4.1.0/Network/Wreq/0000755000000000000000000000000012636343441013373 5ustar0000000000000000wreq-0.4.1.0/Network/Wreq/Cache.hs0000644000000000000000000001301112636343441014726 0ustar0000000000000000{-# 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.Time.Locale.Compat (defaultTimeLocale) import Data.Typeable (Typeable) import GHC.Generics (Generic) import Network.HTTP.Types (HeaderName, Method) import Network.Wreq.Internal.Lens import Network.Wreq.Internal.Types import Network.Wreq.Lens import qualified Data.ByteString.Char8 as B import qualified Data.HashSet as HashSet import qualified Data.IntSet as IntSet import qualified Network.Wreq.Cache.Store as Store #if MIN_VERSION_base(4,6,0) import Data.IORef (atomicModifyIORef') #else import Data.IORef (IORef, atomicModifyIORef) atomicModifyIORef' :: IORef a -> (a -> (a, b)) -> IO b atomicModifyIORef' = atomicModifyIORef #endif cacheStore :: Int -> IO (Run body -> Run body) cacheStore capacity = do cache <- newIORef (Store.empty capacity) return $ \run req -> do let url = reqURL req before <- getCurrentTime mresp <- atomicModifyIORef' cache $ \s -> case Store.lookup url s of Nothing -> (s, Nothing) Just (ce, s') -> case validateEntry before ce of n@Nothing -> (Store.delete url s, n) resp -> (s', resp) case mresp of Just resp -> return resp Nothing -> do resp <- run req after <- getCurrentTime forM_ (shouldCache after req resp) $ \ce -> atomicModifyIORef' cache $ \s -> (Store.insert url ce s, ()) return resp cacheableStatuses :: IntSet cacheableStatuses = IntSet.fromList [200, 203, 300, 301, 410] cacheableMethods :: HashSet Method cacheableMethods = HashSet.fromList ["GET", "HEAD", "OPTIONS"] possiblyCacheable :: Request -> Response body -> Bool possiblyCacheable req resp = (req ^. method) `HashSet.member` cacheableMethods && (resp ^. responseStatus . statusCode) `IntSet.member` cacheableStatuses computeExpiration :: UTCTime -> [CacheResponse Seconds] -> Maybe UTCTime computeExpiration now crs = do guard $ and [NoCache [] `notElem` crs, NoStore `notElem` crs] age <- listToMaybe $ sort [age | MaxAge age <- crs] return $! fromIntegral age `addUTCTime` now validateEntry :: UTCTime -> CacheEntry body -> Maybe (Response body) validateEntry now CacheEntry{..} = case entryExpires of Nothing -> Just entryResponse Just e | e > now -> Just entryResponse _ -> Nothing shouldCache :: UTCTime -> Req -> Response body -> Maybe (CacheEntry body) shouldCache now (Req _ req) resp = do guard (possiblyCacheable req resp) let crs = resp ^.. responseHeader "Cache-Control" . atto_ parseCacheResponse . folded . to simplifyCacheResponse dateHeader name = responseHeader name . to parseDate . folded mexpires = case crs of [] -> resp ^? dateHeader "Expires" _ -> computeExpiration now crs created = resp ^. pre (dateHeader "Date") . non now case mexpires of Just expires | expires <= created -> empty Nothing | req ^. method == "GET" && not (B.null (req ^. queryString)) -> empty _ -> return $ CacheEntry created mexpires resp type Seconds = Int data CacheResponse age = Public | Private [HeaderName] | NoCache [HeaderName] | NoStore | NoTransform | MustRevalidate | ProxyRevalidate | MaxAge age | SMaxAge age | Extension deriving (Eq, Show, Functor, Typeable, Generic) instance Hashable age => Hashable (CacheResponse age) simplifyCacheResponse :: CacheResponse age -> CacheResponse age simplifyCacheResponse (Private _) = Private [] simplifyCacheResponse (NoCache _) = NoCache [] simplifyCacheResponse cr = cr parseCacheResponse :: A.Parser [CacheResponse Seconds] parseCacheResponse = commaSep1 body where body = "public" *> pure Public <|> "private" *> (Private <$> (eq headerNames <|> pure [])) <|> "no-cache" *> (NoCache <$> (eq headerNames <|> pure [])) <|> "no-store" *> pure NoStore <|> "no-transform" *> pure NoTransform <|> "must-revalidate" *> pure MustRevalidate <|> "proxy-revalidate" *> pure ProxyRevalidate <|> "max-age" *> eq (MaxAge <$> decimal) <|> "s-maxage" *> eq (SMaxAge <$> decimal) headerNames = A.char '"' *> commaSep1 hdr <* A.char '"' hdr = mk <$> A.takeWhile1 (inClass "a-zA-Z0-9_-") commaSep1 p = (p <* skipSpace) `sepBy1` (A.char ',' *> skipSpace) eq p = skipSpace *> A.char '=' *> skipSpace *> p parseDate :: B.ByteString -> Maybe UTCTime parseDate s = getFirst . mconcat . map tryout $ [ "%a, %d %b %Y %H:%M:%S %Z" , "%A, %d-%b-%y %H:%M:%S %Z" , "%a %b %e %H:%M:%S %Y" ] where tryout fmt = First $ parseTime defaultTimeLocale fmt (B.unpack s) wreq-0.4.1.0/Network/Wreq/Internal.hs0000644000000000000000000001473412636343441015514 0ustar0000000000000000{-# LANGUAGE CPP, GADTs, OverloadedStrings #-} module Network.Wreq.Internal ( defaults , defaultManagerSettings , emptyMethodWith , foldResponseBody , ignoreResponse , readResponse , request , prepareGet , preparePost , runRead , prepareHead , runIgnore , prepareOptions , preparePut , prepareDelete , prepareMethod , preparePayloadMethod ) 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 (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 preparePayloadMethod :: Postable a => HTTP.Method -> Options -> String -> a -> IO Req preparePayloadMethod method opts url payload = Req (manager opts) <$> prepare (postPayload payload . (Lens.method .~ method)) opts url 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 wreq-0.4.1.0/Network/Wreq/Lens.hs0000644000000000000000000003412612636343441014636 0ustar0000000000000000{-# 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: -- > ; rel="next", -- > ; 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 @@ 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 wreq-0.4.1.0/Network/Wreq/Session.hs0000644000000000000000000001500012636343441015346 0ustar0000000000000000{-# 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) wreq-0.4.1.0/Network/Wreq/Types.hs0000644000000000000000000001051012636343441015030 0ustar0000000000000000{-# 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 wreq-0.4.1.0/Network/Wreq/Cache/0000755000000000000000000000000012636343441014376 5ustar0000000000000000wreq-0.4.1.0/Network/Wreq/Cache/Store.hs0000644000000000000000000000407412636343441016033 0ustar0000000000000000{-# 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 #-} wreq-0.4.1.0/Network/Wreq/Internal/0000755000000000000000000000000012636343441015147 5ustar0000000000000000wreq-0.4.1.0/Network/Wreq/Internal/AWS.hs0000644000000000000000000001746412636343441016151 0ustar0000000000000000{-# LANGUAGE 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.Locale.Compat (defaultTimeLocale) import Data.Time.LocalTime (utc, utcToLocalTime) import Network.HTTP.Types (parseSimpleQuery, urlEncode) import Network.Wreq.Internal.Lens import Network.Wreq.Internal.Types (AWSAuthVersion(..)) import qualified Crypto.Hash as CT (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 -- 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 .s3..., i.e. virtual-host style access | ".s3.amazonaws.com" `S.isSuffixOf` endpoint = -- vhost style, classic ("s3", "us-east-1") | ".s3-external-1.amazonaws.com" `S.isSuffixOf` endpoint = ("s3", "us-east-1") | ".s3-" `S.isInfixOf` endpoint = -- vhost style, regional ("s3", regionInS3VHost endpoint) -- For s3, use / style access, as opposed to -- .s3... in the hostname. | endpoint `elem` ["s3.amazonaws.com", "s3-external-1.amazonaws.com"] = ("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-.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 "-.runscope.net" before decoding . S.reverse . S.tail . S.dropWhile (/= '-') . S.reverse $ hostname | otherwise = hostname where p1 "-" = "." p1 other = other p2 "--" = "-" p2 other = other wreq-0.4.1.0/Network/Wreq/Internal/Lens.hs0000644000000000000000000000377612636343441016421 0ustar0000000000000000{-# 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) wreq-0.4.1.0/Network/Wreq/Internal/Link.hs0000644000000000000000000000362012636343441016401 0ustar0000000000000000{-# 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 wreq-0.4.1.0/Network/Wreq/Internal/OAuth1.hs0000644000000000000000000000113312636343441016602 0ustar0000000000000000module 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 wreq-0.4.1.0/Network/Wreq/Internal/Types.hs0000644000000000000000000002436712636343441016623 0ustar0000000000000000{-# 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" wreq-0.4.1.0/Network/Wreq/Lens/0000755000000000000000000000000012636343441014274 5ustar0000000000000000wreq-0.4.1.0/Network/Wreq/Lens/Machinery.hs0000644000000000000000000000137312636343441016553 0ustar0000000000000000module 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 [] = [] wreq-0.4.1.0/Network/Wreq/Lens/TH.hs0000644000000000000000000000547612636343441015157 0ustar0000000000000000{-# 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)))) wreq-0.4.1.0/tests/0000755000000000000000000000000012636343441012166 5ustar0000000000000000wreq-0.4.1.0/tests/AWS.hs0000644000000000000000000001250712636343441013161 0ustar0000000000000000{-# 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 wreq-0.4.1.0/tests/DocTests.hs0000644000000000000000000000275212636343441014260 0ustar0000000000000000-- 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" wreq-0.4.1.0/tests/Tests.hs0000644000000000000000000000062612636343441013630 0ustar0000000000000000{-# 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 ] wreq-0.4.1.0/tests/UnitTests.hs0000644000000000000000000003671212636343441014475 0ustar0000000000000000{-# 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 " 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-0.4.1.0/tests/AWS/0000755000000000000000000000000012636343441012620 5ustar0000000000000000wreq-0.4.1.0/tests/AWS/Aeson.hs0000644000000000000000000000156412636343441014227 0ustar0000000000000000{-# 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) wreq-0.4.1.0/tests/AWS/DynamoDB.hs0000644000000000000000000001612512636343441014616 0ustar0000000000000000{-# 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" wreq-0.4.1.0/tests/AWS/IAM.hs0000644000000000000000000001755512636343441013577 0ustar0000000000000000{-# 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:::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:. -- 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" .= ["*"] ] ] ] wreq-0.4.1.0/tests/AWS/S3.hs0000644000000000000000000001072512636343441013446 0ustar0000000000000000{-# 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 = "" <> BS8.pack region <> "" wreq-0.4.1.0/tests/AWS/SQS.hs0000644000000000000000000001212012636343441013616 0ustar0000000000000000{-# 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..amazon.com// 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..amazon.com// acctFromQueueUrl :: T.Text -> String acctFromQueueUrl qurl = case T.split (=='/') qurl of _:_:_:acct:_ -> T.unpack acct _ -> "dummy" wreq-0.4.1.0/tests/Properties/0000755000000000000000000000000012636343441014322 5ustar0000000000000000wreq-0.4.1.0/tests/Properties/Store.hs0000644000000000000000000000457612636343441015766 0ustar0000000000000000{-# 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 ] wreq-0.4.1.0/www/0000755000000000000000000000000012636343441011650 5ustar0000000000000000wreq-0.4.1.0/www/bootstrap-custom.css0000644000000000000000000000224712636343441015714 0ustar0000000000000000html { 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; } wreq-0.4.1.0/www/index.md0000644000000000000000000001055312636343441013305 0ustar0000000000000000% wreq: a Haskell web client library % HTTP made easy for Haskell. Tutorial `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.

Ready to jump in?

We've worked hard to make `wreq` quick to learn. Tutorial We're proud of the example-filled docs. Documentation If you run into problems, let us know. Issues
# 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/). wreq-0.4.1.0/www/Makefile0000644000000000000000000000104312636343441013306 0ustar0000000000000000bootstrap := 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) wreq-0.4.1.0/www/tutorial.md0000644000000000000000000004675512636343441014056 0ustar0000000000000000% 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"] ~~~~ The [`param`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#v:param) lens 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 ~~~~
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.
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") ~~~~
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.
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" ~~~~
Header names are case insensitive.
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 `` 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") ~~~~ # 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.
**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.
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}" ~~~~
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.
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 For non-trivial applications, 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.