diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,29 @@ +Copyright © 2014, Bryan O'Sullivan. + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +* Neither the name of nor the names of other contributors may be used + to endorse or promote products derived from this software without + specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Network/Wreq.hs b/Network/Wreq.hs new file mode 100644 --- /dev/null +++ b/Network/Wreq.hs @@ -0,0 +1,604 @@ +{-# LANGUAGE FlexibleContexts, OverloadedStrings #-} + +-- | +-- Module : Network.Wreq +-- Copyright : (c) 2014 Bryan O'Sullivan +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : GHC +-- +-- A library for client-side HTTP requests, focused on ease of use. +-- +-- When reading the examples in this module, you should assume the +-- following environment: +-- +-- @ +-- \-\- Make it easy to write literal 'S.ByteString' and 'Text' values. +-- \{\-\# LANGUAGE OverloadedStrings \#\-\} +-- +-- \-\- Our handy module. +-- import "Network.Wreq" +-- +-- \-\- Operators such as ('&') and ('.~'). +-- import "Control.Lens" +-- +-- \-\- Conversion of Haskell values to JSON. +-- import "Data.Aeson" ('Data.Aeson.toJSON') +-- +-- \-\- Easy traversal of JSON data. +-- import "Data.Aeson.Lens" ('Data.Aeson.Lens.key', 'Data.Aeson.Lens.nth') +-- @ +-- +-- There exist some less frequently used lenses that are not exported +-- from this module; these can be found in "Network.Wreq.Lens". + +module Network.Wreq + ( + -- * HTTP verbs + + -- ** Sessions + -- $session + + -- ** GET + get + , getWith + -- ** POST + -- $postable + , post + , postWith + -- ** HEAD + , head_ + , headWith + -- ** OPTIONS + , options + , optionsWith + -- ** PUT + , put + , putWith + -- ** DELETE + , delete + , deleteWith + -- ** Custom Method + , customMethod + , customMethodWith + -- * Incremental consumption of responses + -- ** GET + , foldGet + , foldGetWith + + -- * Configuration + , Options + , defaults + , Lens.manager + , Lens.header + , Lens.param + , Lens.redirects + , Lens.headers + , Lens.params + , Lens.cookie + , Lens.cookies + , Lens.checkStatus + + -- ** Authentication + -- $auth + , Auth + , AWSAuthVersion(..) + , Lens.auth + , basicAuth + , oauth1Auth + , oauth2Bearer + , oauth2Token + , awsAuth + -- ** Proxy settings + , Proxy(Proxy) + , Lens.proxy + , httpProxy + -- ** Using a manager with defaults + , withManager + + -- * Payloads for POST and PUT + , Payload(..) + -- ** URL-encoded form data + , FormParam(..) + , FormValue + -- ** Multipart form data + , Form.Part + , Lens.partName + , Lens.partFileName + , Lens.partContentType + , Lens.partGetBody + -- *** Smart constructors + , Form.partBS + , Form.partLBS + , partText + , partString + , Form.partFile + , Form.partFileSource + + -- * Responses + , Response + , Lens.responseBody + , Lens.responseHeader + , Lens.responseLink + , Lens.responseCookie + , Lens.responseHeaders + , Lens.responseCookieJar + , Lens.responseStatus + , Lens.Status + , Lens.statusCode + , Lens.statusMessage + -- ** Link headers + , Lens.Link + , Lens.linkURL + , Lens.linkParams + -- ** Decoding responses + , JSONError(..) + , asJSON + , asValue + + -- * Cookies + -- $cookielenses + , Lens.Cookie + , Lens.cookieName + , Lens.cookieValue + , Lens.cookieExpiryTime + , Lens.cookieDomain + , Lens.cookiePath + + -- * Parsing responses + , Lens.atto + , Lens.atto_ + ) where + +import Control.Lens ((.~), (&)) +import Control.Monad (unless) +import Control.Monad.Catch (MonadThrow(throwM)) +import Data.Aeson (FromJSON) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) +import Network.HTTP.Client.Internal (Proxy(..), Response) +import Network.Wreq.Internal +import Network.Wreq.Types (Options) +import Network.Wreq.Types hiding (Options(..)) +import Prelude hiding (head) +import qualified Data.Aeson as Aeson +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import qualified Data.Text as T +import qualified Network.HTTP.Client as HTTP +import qualified Network.HTTP.Client.MultipartFormData as Form +import qualified Network.Wreq.Lens as Lens +import qualified Network.Wreq.Types as Wreq +import qualified Data.ByteString.Char8 as BC8 + +-- | Issue a GET request. +-- +-- Example: +-- +-- @ +--'get' \"http:\/\/httpbin.org\/get\" +-- @ +-- +-- >>> r <- get "http://httpbin.org/get" +-- >>> r ^. responseStatus . statusCode +-- 200 +get :: String -> IO (Response L.ByteString) +get url = getWith defaults url + +withManager :: (Options -> IO a) -> IO a +withManager act = HTTP.withManager defaultManagerSettings $ \mgr -> + act defaults { Wreq.manager = Right mgr } + +-- | Issue a GET request, using the supplied 'Options'. +-- +-- Example: +-- +-- @ +--let opts = 'defaults' '&' 'Lens.param' \"foo\" '.~' [\"bar\"] +--'getWith' opts \"http:\/\/httpbin.org\/get\" +-- @ +-- +-- >>> let opts = defaults & param "foo" .~ ["bar"] +-- >>> r <- getWith opts "http://httpbin.org/get" +-- >>> r ^? responseBody . key "url" +-- Just (String "http://httpbin.org/get?foo=bar") +getWith :: Options -> String -> IO (Response L.ByteString) +getWith opts url = runRead =<< prepareGet opts url + +-- | Issue a POST request. +-- +-- Example: +-- +-- @ +--'post' \"http:\/\/httpbin.org\/post\" ('Aeson.toJSON' [1,2,3]) +-- @ +-- +-- >>> r <- post "http://httpbin.org/post" (toJSON [1,2,3]) +-- >>> r ^? responseBody . key "json" +-- Just (Array (fromList [Number 1.0,Number 2.0,Number 3.0])) +post :: Postable a => String -> a -> IO (Response L.ByteString) +post url payload = postWith defaults url payload + +-- | Issue a POST request, using the supplied 'Options'. +-- +-- Example: +-- +-- @ +--let opts = 'defaults' '&' 'Lens.param' \"foo\" '.~' [\"bar\"] +--'postWith' opts \"http:\/\/httpbin.org\/post\" ('Aeson.toJSON' [1,2,3]) +-- @ +-- +-- >>> let opts = defaults & param "foo" .~ ["bar"] +-- >>> r <- postWith opts "http://httpbin.org/post" (toJSON [1,2,3]) +-- >>> r ^? responseBody . key "url" +-- Just (String "http://httpbin.org/post?foo=bar") +postWith :: Postable a => Options -> String -> a -> IO (Response L.ByteString) +postWith opts url payload = runRead =<< preparePost opts url payload + +-- | Issue a HEAD request. +-- +-- Example: +-- +-- @ +--'head_' \"http:\/\/httpbin.org\/get\" +-- @ +-- +-- >>> r <- head_ "http://httpbin.org/get" +-- >>> r ^? responseHeader "Content-Type" +-- Just "application/json" +head_ :: String -> IO (Response ()) +head_ = headWith (defaults & Lens.redirects .~ 0) + +-- | Issue a HEAD request, using the supplied 'Options'. +-- +-- Example: +-- +-- @ +--let opts = 'defaults' '&' 'Lens.param' \"foo\" '.~' [\"bar\"] +--'headWith' opts \"http:\/\/httpbin.org\/get\" +-- @ +-- +-- >>> let opts = defaults & param "foo" .~ ["bar"] +-- >>> r <- headWith opts "http://httpbin.org/get" +-- >>> r ^? responseHeader "Connection" +-- Just "keep-alive" +headWith :: Options -> String -> IO (Response ()) +headWith opts url = runIgnore =<< prepareHead opts url + +-- | Issue a PUT request. +put :: Putable a => String -> a -> IO (Response L.ByteString) +put url payload = putWith defaults url payload + +-- | Issue a PUT request, using the supplied 'Options'. +putWith :: Putable a => Options -> String -> a -> IO (Response L.ByteString) +putWith opts url payload = runRead =<< preparePut opts url payload + +-- | Issue an OPTIONS request. +-- +-- Example: +-- +-- @ +--'options' \"http:\/\/httpbin.org\/get\" +-- @ +-- +-- See 'Lens.atto' for a more complex worked example. +options :: String -> IO (Response ()) +options = optionsWith defaults + +-- | Issue an OPTIONS request, using the supplied 'Options'. +-- +-- Example: +-- +-- @ +--let opts = 'defaults' '&' 'Lens.param' \"foo\" '.~' [\"bar\"] +--'optionsWith' opts \"http:\/\/httpbin.org\/get\" +-- @ +optionsWith :: Options -> String -> IO (Response ()) +optionsWith opts url = runIgnore =<< prepareOptions opts url + +-- | Issue a DELETE request. +-- +-- Example: +-- +-- @ +--'delete' \"http:\/\/httpbin.org\/delete\" +-- @ +-- +-- >>> r <- delete "http://httpbin.org/delete" +-- >>> r ^. responseStatus . statusCode +-- 200 +delete :: String -> IO (Response L.ByteString) +delete = deleteWith defaults + +-- | Issue a DELETE request, using the supplied 'Options'. +-- +-- Example: +-- +-- @ +--let opts = 'defaults' '&' 'Lens.redirects' '.~' 0 +--'deleteWith' opts \"http:\/\/httpbin.org\/delete\" +-- @ +-- +-- >>> let opts = defaults & redirects .~ 0 +-- >>> r <- deleteWith opts "http://httpbin.org/delete" +-- >>> r ^. responseStatus . statusCode +-- 200 +deleteWith :: Options -> String -> IO (Response L.ByteString) +deleteWith opts url = runRead =<< prepareDelete opts url + +-- | Issue a custom-method request +-- +-- Example: +-- @ +-- 'customMethod' \"PATCH\" \"http:\/\/httpbin.org\/patch\" +-- @ +-- +-- >>> r <- customMethod "PATCH" "http://httpbin.org/patch" +-- >>> r ^. responseStatus . statusCode +-- 200 +customMethod :: String -> String -> IO (Response L.ByteString) +customMethod method url = customMethodWith method defaults url + +-- | Issue a custom request method request, using the supplied 'Options'. +-- +-- Example: +-- +-- @ +--let opts = 'defaults' '&' 'Lens.redirects' '.~' 0 +--'customMethodWith' \"PATCH\" opts \"http:\/\/httpbin.org\/patch\" +-- @ +-- +-- >>> let opts = defaults & redirects .~ 0 +-- >>> r <- customMethodWith "PATCH" opts "http://httpbin.org/patch" +-- >>> r ^. responseStatus . statusCode +-- 200 +customMethodWith :: String -> Options -> String -> IO (Response L.ByteString) +customMethodWith method opts url = runRead =<< prepareMethod methodBS opts url + where + methodBS = BC8.pack method + +foldGet :: (a -> S.ByteString -> IO a) -> a -> String -> IO a +foldGet f z url = foldGetWith defaults f z url + +foldGetWith :: Options -> (a -> S.ByteString -> IO a) -> a -> String -> IO a +foldGetWith opts f z0 url = request return opts url (foldResponseBody f z0) + +-- | Convert the body of an HTTP response from JSON to a suitable +-- Haskell type. +-- +-- In this example, we use 'asJSON' in the @IO@ monad, where it will +-- throw a 'JSONError' exception if conversion to the desired type +-- fails. +-- +-- @ +-- \{-\# LANGUAGE DeriveGeneric \#-\} +--import "GHC.Generics" ('GHC.Generics.Generic') +-- +-- \{- This Haskell type corresponds to the structure of a +-- response body from httpbin.org. -\} +-- +--data GetBody = GetBody { +-- headers :: 'Data.Map.Map' 'Data.Text.Text' 'Data.Text.Text' +-- , args :: 'Data.Map.Map' 'Data.Text.Text' 'Data.Text.Text' +-- , origin :: 'Data.Text.Text' +-- , url :: 'Data.Text.Text' +-- } deriving (Show, 'GHC.Generics.Generic') +-- +-- \-\- Get GHC to derive a 'FromJSON' instance for us. +--instance 'FromJSON' GetBody +-- +-- \{- The fact that we want a GetBody below will be inferred by our +-- use of the \"headers\" accessor function. -\} +-- +--foo = do +-- r <- 'asJSON' =<< 'get' \"http:\/\/httpbin.org\/get\" +-- print (headers (r 'Control.Lens.^.' 'responseBody')) +-- @ +-- +-- If we use 'asJSON' in the 'Either' monad, it will return 'Left' +-- with a 'JSONError' payload if conversion fails, and 'Right' with a +-- 'Response' whose 'responseBody' is the converted value on success. + +asJSON :: (MonadThrow m, FromJSON a) => + Response L.ByteString -> m (Response a) +{-# SPECIALIZE asJSON :: (FromJSON a) => + Response L.ByteString -> IO (Response a) #-} +{-# SPECIALIZE asJSON :: Response L.ByteString -> IO (Response Aeson.Value) #-} +asJSON resp = do + let contentType = fst . S.break (==59) . fromMaybe "unknown" . + lookup "Content-Type" . HTTP.responseHeaders $ resp + unless ("application/json" `S.isPrefixOf` contentType) $ + throwM . JSONError $ "content type of response is " ++ show contentType + case Aeson.eitherDecode' (HTTP.responseBody resp) of + Left err -> throwM (JSONError err) + Right val -> return (fmap (const val) resp) + + +-- | Convert the body of an HTTP response from JSON to a 'Value'. +-- +-- In this example, we use 'asValue' in the @IO@ monad, where it will +-- throw a 'JSONError' exception if the conversion to 'Value' fails. +-- +-- @ +--foo = do +-- r <- 'asValue' =<< 'get' \"http:\/\/httpbin.org\/get\" +-- print (r 'Control.Lens.^?' 'responseBody' . key \"headers\" . key \"User-Agent\") +-- @ +asValue :: (MonadThrow m) => Response L.ByteString -> m (Response Aeson.Value) +{-# SPECIALIZE asValue :: Response L.ByteString + -> IO (Response Aeson.Value) #-} +asValue = asJSON + +-- $auth +-- +-- Do not use HTTP authentication unless you are using TLS encryption. +-- These authentication tokens can easily be captured and reused by an +-- attacker if transmitted in the clear. + +-- | Basic authentication. This consists of a plain username and +-- password. +-- +-- Example (note the use of TLS): +-- +-- @ +--let opts = 'defaults' '&' 'Lens.auth' '?~' 'basicAuth' \"user\" \"pass\" +--'getWith' opts \"https:\/\/httpbin.org\/basic-auth\/user\/pass\" +-- @ +-- +-- Note here the use of the 'Control.Lens.?~' setter to turn an 'Auth' +-- into a 'Maybe' 'Auth', to make the type of the RHS compatible with +-- the 'Lens.auth' lens. +-- +-- >>> let opts = defaults & auth ?~ basicAuth "user" "pass" +-- >>> r <- getWith opts "https://httpbin.org/basic-auth/user/pass" +-- >>> r ^? responseBody . key "authenticated" +-- Just (Bool True) +basicAuth :: S.ByteString -- ^ Username. + -> S.ByteString -- ^ Password. + -> Auth +basicAuth = BasicAuth + +-- | OAuth1 authentication. This consists of a consumer token, +-- a consumer secret, a token and a token secret +oauth1Auth :: S.ByteString -- ^ Consumer token + -> S.ByteString -- ^ Consumer secret + -> S.ByteString -- ^ OAuth token + -> S.ByteString -- ^ OAuth token secret + -> Auth +oauth1Auth = OAuth1 + + +-- | An OAuth2 bearer token. This is treated by many services as the +-- equivalent of a username and password. +-- +-- Example (note the use of TLS): +-- +-- @ +--let opts = 'defaults' '&' 'Lens.auth' '?~' 'oauth2Bearer' \"1234abcd\" +--'getWith' opts \"https:\/\/public-api.wordpress.com\/rest\/v1\/me\/\" +-- @ +oauth2Bearer :: S.ByteString -> Auth +oauth2Bearer = OAuth2Bearer + +-- | A not-quite-standard OAuth2 bearer token (that seems to be used +-- only by GitHub). This will be treated by whatever services accept +-- it as the equivalent of a username and password. +-- +-- Example (note the use of TLS): +-- +-- @ +--let opts = 'defaults' '&' 'Lens.auth' '?~' 'oauth2Token' \"abcd1234\" +--'getWith' opts \"https:\/\/api.github.com\/user\" +-- @ +oauth2Token :: S.ByteString -> Auth +oauth2Token = OAuth2Token + +-- | AWS v4 request signature. +-- +-- Example (note the use of TLS): +-- +-- @ +--let opts = 'defaults' '&' 'Lens.auth' '?~' 'awsAuth AWSv4' \"key\" \"secret\" +--'getWith' opts \"https:\/\/dynamodb.us-west-2.amazonaws.com\" +-- @ +awsAuth :: AWSAuthVersion -> S.ByteString -> S.ByteString -> Auth +awsAuth = AWSAuth + +-- | Proxy configuration. +-- +-- Example: +-- +-- @ +--let opts = 'defaults' '&' 'Lens.proxy' '?~' 'httpProxy' \"localhost\" 8000 +--'getWith' opts \"http:\/\/httpbin.org\/get\" +-- @ +-- +-- Note here the use of the 'Control.Lens.?~' setter to turn a 'Proxy' +-- into a 'Maybe' 'Proxy', to make the type of the RHS compatible with +-- the 'Lens.proxy' lens. +httpProxy :: S.ByteString -> Int -> Proxy +httpProxy = Proxy + +-- | Make a 'Part' whose content is a strict 'T.Text', encoded as +-- UTF-8. +-- +-- The 'Part' does not have a file name or content type associated +-- with it. +partText :: Text -- ^ Name of the corresponding \. + -> 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 diff --git a/Network/Wreq/Cache.hs b/Network/Wreq/Cache.hs new file mode 100644 --- /dev/null +++ b/Network/Wreq/Cache.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, + FlexibleContexts, OverloadedStrings, RecordWildCards #-} + +module Network.Wreq.Cache + ( + shouldCache + , validateEntry + , cacheStore + ) where + +import Control.Applicative +import Control.Lens ((^?), (^.), (^..), folded, non, pre, to) +import Control.Monad (guard) +import Data.Attoparsec.ByteString.Char8 as A +import Data.CaseInsensitive (mk) +import Data.Foldable (forM_) +import Data.HashSet (HashSet) +import Data.Hashable (Hashable) +import Data.IntSet (IntSet) +import Data.IORef (newIORef) +import Data.List (sort) +import Data.Maybe (listToMaybe) +import Data.Monoid (First(..), mconcat) +import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime) +import Data.Time.Format (parseTime) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import Network.HTTP.Types (HeaderName, Method) +import Network.Wreq.Internal.Lens +import Network.Wreq.Internal.Types +import Network.Wreq.Lens +import qualified Data.ByteString.Char8 as B +import qualified Data.HashSet as HashSet +import qualified Data.IntSet as IntSet +import qualified Network.Wreq.Cache.Store as Store + +#if MIN_VERSION_time(1,5,0) +import Data.Time.Format (defaultTimeLocale) +#else +import System.Locale (defaultTimeLocale) +#endif + +#if MIN_VERSION_base(4,6,0) +import Data.IORef (atomicModifyIORef') +#else +import Data.IORef (IORef, atomicModifyIORef) + +atomicModifyIORef' :: IORef a -> (a -> (a, b)) -> IO b +atomicModifyIORef' = atomicModifyIORef +#endif + +cacheStore :: Int -> IO (Run body -> Run body) +cacheStore capacity = do + cache <- newIORef (Store.empty capacity) + return $ \run req -> do + let url = reqURL req + before <- getCurrentTime + mresp <- atomicModifyIORef' cache $ \s -> + case Store.lookup url s of + Nothing -> (s, Nothing) + Just (ce, s') -> + case validateEntry before ce of + n@Nothing -> (Store.delete url s, n) + resp -> (s', resp) + case mresp of + Just resp -> return resp + Nothing -> do + resp <- run req + after <- getCurrentTime + forM_ (shouldCache after req resp) $ \ce -> + atomicModifyIORef' cache $ \s -> (Store.insert url ce s, ()) + return resp + +cacheableStatuses :: IntSet +cacheableStatuses = IntSet.fromList [200, 203, 300, 301, 410] + +cacheableMethods :: HashSet Method +cacheableMethods = HashSet.fromList ["GET", "HEAD", "OPTIONS"] + +possiblyCacheable :: Request -> Response body -> Bool +possiblyCacheable req resp = + (req ^. method) `HashSet.member` cacheableMethods && + (resp ^. responseStatus . statusCode) `IntSet.member` cacheableStatuses + +computeExpiration :: UTCTime -> [CacheResponse Seconds] -> Maybe UTCTime +computeExpiration now crs = do + guard $ and [NoCache [] `notElem` crs, NoStore `notElem` crs] + age <- listToMaybe $ sort [age | MaxAge age <- crs] + return $! fromIntegral age `addUTCTime` now + +validateEntry :: UTCTime -> CacheEntry body -> Maybe (Response body) +validateEntry now CacheEntry{..} = + case entryExpires of + Nothing -> Just entryResponse + Just e | e > now -> Just entryResponse + _ -> Nothing + +shouldCache :: UTCTime -> Req -> Response body -> Maybe (CacheEntry body) +shouldCache now (Req _ req) resp = do + guard (possiblyCacheable req resp) + let crs = resp ^.. responseHeader "Cache-Control" . atto_ parseCacheResponse . + folded . to simplifyCacheResponse + dateHeader name = responseHeader name . to parseDate . folded + mexpires = case crs of + [] -> resp ^? dateHeader "Expires" + _ -> computeExpiration now crs + created = resp ^. pre (dateHeader "Date") . non now + case mexpires of + Just expires | expires <= created -> empty + Nothing | req ^. method == "GET" && + not (B.null (req ^. queryString)) -> empty + _ -> return $ CacheEntry created mexpires resp + +type Seconds = Int + +data CacheResponse age = Public + | Private [HeaderName] + | NoCache [HeaderName] + | NoStore + | NoTransform + | MustRevalidate + | ProxyRevalidate + | MaxAge age + | SMaxAge age + | Extension + deriving (Eq, Show, Functor, Typeable, Generic) + +instance Hashable age => Hashable (CacheResponse age) + +simplifyCacheResponse :: CacheResponse age -> CacheResponse age +simplifyCacheResponse (Private _) = Private [] +simplifyCacheResponse (NoCache _) = NoCache [] +simplifyCacheResponse cr = cr + +parseCacheResponse :: A.Parser [CacheResponse Seconds] +parseCacheResponse = commaSep1 body + where + body = "public" *> pure Public + <|> "private" *> (Private <$> (eq headerNames <|> pure [])) + <|> "no-cache" *> (NoCache <$> (eq headerNames <|> pure [])) + <|> "no-store" *> pure NoStore + <|> "no-transform" *> pure NoTransform + <|> "must-revalidate" *> pure MustRevalidate + <|> "proxy-revalidate" *> pure ProxyRevalidate + <|> "max-age" *> eq (MaxAge <$> decimal) + <|> "s-maxage" *> eq (SMaxAge <$> decimal) + headerNames = A.char '"' *> commaSep1 hdr <* A.char '"' + hdr = mk <$> A.takeWhile1 (inClass "a-zA-Z0-9_-") + commaSep1 p = (p <* skipSpace) `sepBy1` (A.char ',' *> skipSpace) + eq p = skipSpace *> A.char '=' *> skipSpace *> p + +parseDate :: B.ByteString -> Maybe UTCTime +parseDate s = getFirst . mconcat . map tryout $ [ + "%a, %d %b %Y %H:%M:%S %Z" + , "%A, %d-%b-%y %H:%M:%S %Z" + , "%a %b %e %H:%M:%S %Y" + ] + where tryout fmt = First $ parseTime defaultTimeLocale fmt (B.unpack s) diff --git a/Network/Wreq/Cache/Store.hs b/Network/Wreq/Cache/Store.hs new file mode 100644 --- /dev/null +++ b/Network/Wreq/Cache/Store.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE BangPatterns, DeriveFunctor, RecordWildCards #-} + +module Network.Wreq.Cache.Store + ( + Store + , empty + , insert + , delete + , lookup + , fromList + , toList + ) where + +import Data.Hashable (Hashable) +import Data.Int (Int64) +import Data.List (foldl') +import Prelude hiding (lookup, map) +import qualified Data.HashPSQ as HashPSQ + +type Epoch = Int64 + +data Store k v = Store { + capacity :: {-# UNPACK #-} !Int + , size :: {-# UNPACK #-} !Int + , epoch :: {-# UNPACK #-} !Epoch + , psq :: !(HashPSQ.HashPSQ k Epoch v) + } + +instance (Show k, Show v, Ord k, Hashable k) => Show (Store k v) where + show st = "fromList " ++ show (toList st) + +empty :: Ord k => Int -> Store k v +empty cap + | cap <= 0 = error "empty: invalid capacity" + | otherwise = Store cap 0 0 HashPSQ.empty +{-# INLINABLE empty #-} + +insert :: (Ord k, Hashable k) => k -> v -> Store k v -> Store k v +insert k v st@Store{..} = case HashPSQ.insertView k epoch v psq of + (Just (_, _), psq0) -> st {epoch = epoch + 1, psq = psq0} + (Nothing, psq0) + | size < capacity -> st {size = size + 1, epoch = epoch + 1, psq = psq0} + | otherwise -> st {epoch = epoch + 1, psq = HashPSQ.deleteMin psq0} +{-# INLINABLE insert #-} + +lookup :: (Ord k, Hashable k) => k -> Store k v -> Maybe (v, Store k v) +lookup k st@Store{..} = case HashPSQ.alter tick k psq of + (Nothing, _) -> Nothing + (Just v, psq0) -> Just (v, st { epoch = epoch + 1, psq = psq0 }) + where tick Nothing = (Nothing, Nothing) + tick (Just (_, v)) = (Just v, Just (epoch, v)) +{-# INLINABLE lookup #-} + +delete :: (Ord k, Hashable k) => k -> Store k v -> Store k v +delete k st@Store{..} = case HashPSQ.deleteView k psq of + Nothing -> st + Just (_, _, psq0) -> st {size = size - 1, psq = psq0} +{-# INLINABLE delete #-} + +fromList :: (Ord k, Hashable k) => Int -> [(k, v)] -> Store k v +fromList = foldl' (flip (uncurry insert)) . empty +{-# INLINABLE fromList #-} + +toList :: (Ord k, Hashable k) => Store k v -> [(k, v)] +toList Store{..} = [(k,v) | (k, _, v) <- HashPSQ.toList psq] +{-# INLINABLE toList #-} diff --git a/Network/Wreq/Internal.hs b/Network/Wreq/Internal.hs new file mode 100644 --- /dev/null +++ b/Network/Wreq/Internal.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE CPP, GADTs, OverloadedStrings #-} + +module Network.Wreq.Internal + ( + defaults + , defaultManagerSettings + , emptyMethodWith + , foldResponseBody + , ignoreResponse + , readResponse + , request + , prepareGet + , preparePost + , runRead + , prepareHead + , runIgnore + , prepareOptions + , preparePut + , prepareDelete + , prepareMethod + ) where + +import Control.Applicative ((<$>)) +import Control.Arrow ((***)) +import Control.Lens ((&), (.~), (%~)) +import Data.Monoid ((<>)) +import Data.Text.Encoding (encodeUtf8) +import Data.Version (showVersion) +import Network.HTTP.Client (BodyReader) +import Network.HTTP.Client.Internal (Proxy(..), Request, Response(..), addProxy) +import Network.HTTP.Client.TLS (tlsManagerSettings) +import Network.Wreq.Internal.Lens (setHeader) +import Network.Wreq.Internal.Types (Mgr, Req(..), Run) +import Network.Wreq.Types (Auth(..), Options(..), Postable(..), Putable(..)) +import Prelude hiding (head) +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as Char8 +import qualified Data.ByteString.Lazy as L +import qualified Network.HTTP.Client as HTTP +import qualified Network.HTTP.Types as HTTP +import qualified Network.Wreq.Internal.Lens as Lens +import qualified Network.Wreq.Internal.AWS as AWS (signRequest) +import qualified Network.Wreq.Internal.OAuth1 as OAuth1 (signRequest) +import qualified Network.Wreq.Lens as Lens hiding (checkStatus) + +-- This mess allows this module to continue to load during interactive +-- development in ghci :-( +#if defined(VERSION_base) +import Paths_wreq_sb (version) +#else +import Data.Version (Version(..)) +version :: Version +version = Version [0] ["wip"] +#endif + +defaultManagerSettings :: HTTP.ManagerSettings +defaultManagerSettings = tlsManagerSettings + +defaults :: Options +defaults = Options { + manager = Left defaultManagerSettings + , proxy = Nothing + , auth = Nothing + , headers = [("User-Agent", userAgent)] + , params = [] + , redirects = 10 + , cookies = Just (HTTP.createCookieJar []) + , checkStatus = Nothing + } + where userAgent = "haskell wreq-" <> Char8.pack (showVersion version) + +setRedirects :: Options -> Request -> Request +setRedirects opts req + | redirects opts == HTTP.redirectCount req = req + | otherwise = req { HTTP.redirectCount = redirects opts } + +emptyMethodWith :: HTTP.Method -> Options -> String -> IO (Response ()) +emptyMethodWith method opts url = + request (return . (Lens.method .~ method)) opts url ignoreResponse + +ignoreResponse :: Response BodyReader -> IO (Response ()) +ignoreResponse resp = (Lens.responseBody .~ ()) <$> readResponse resp + +readResponse :: Response BodyReader -> IO (Response L.ByteString) +readResponse resp = do + chunks <- HTTP.brConsume (HTTP.responseBody resp) + return resp { responseBody = L.fromChunks chunks } + +foldResponseBody :: (a -> S.ByteString -> IO a) -> a + -> Response BodyReader -> IO a +foldResponseBody f z0 resp = go z0 + where go z = do + bs <- HTTP.brRead (HTTP.responseBody resp) + if S.null bs + then return z + else f z bs >>= go + +request :: (Request -> IO Request) -> Options -> String + -> (Response BodyReader -> IO a) -> IO a +request modify opts url act = run (manager opts) act =<< prepare modify opts url + +run :: Mgr -> (Response BodyReader -> IO a) -> Request -> IO a +run emgr act req = either (flip HTTP.withManager go) go emgr + where go mgr = HTTP.withResponse req mgr act + +prepare :: (Request -> IO Request) -> Options -> String -> IO Request +prepare modify opts url = do + signRequest =<< modify =<< frob <$> HTTP.parseUrl url + where + frob req = req & Lens.requestHeaders %~ (headers opts ++) + & setQuery opts + & setAuth opts + & setProxy opts + & setCheckStatus opts + & setRedirects opts + & Lens.cookieJar .~ cookies opts + signRequest :: Request -> IO Request + signRequest = maybe return f $ auth opts + where + f (AWSAuth versn key secret) = AWS.signRequest versn key secret + f (OAuth1 consumerToken consumerSecret token secret) = OAuth1.signRequest consumerToken consumerSecret token secret + f _ = return + + +setQuery :: Options -> Request -> Request +setQuery opts = + case params opts of + [] -> id + ps -> Lens.queryString %~ \qs -> + let n = S.length qs in + qs <> (if n > 1 then "&" else "") <> HTTP.renderSimpleQuery (n==0) + (map (encodeUtf8 *** encodeUtf8) ps) + +setAuth :: Options -> Request -> Request +setAuth = maybe id f . auth + where + f (BasicAuth user pass) = HTTP.applyBasicAuth user pass + f (OAuth2Bearer token) = setHeader "Authorization" ("Bearer " <> token) + f (OAuth2Token token) = setHeader "Authorization" ("token " <> token) + -- for AWS request signature, see Internal/AWS + f (AWSAuth _ _ _) = id + f (OAuth1 _ _ _ _) = id + +setProxy :: Options -> Request -> Request +setProxy = maybe id f . proxy + where f (Proxy host port) = addProxy host port + +setCheckStatus :: Options -> Request -> Request +setCheckStatus = maybe id f . checkStatus + where f cs = ( & Lens.checkStatus .~ cs) + +prepareGet :: Options -> String -> IO Req +prepareGet opts url = Req (manager opts) <$> prepare return opts url + +runRead :: Run L.ByteString +runRead (Req mgr req) = run mgr readResponse req + +preparePost :: Postable a => Options -> String -> a -> IO Req +preparePost opts url payload = Req (manager opts) <$> + prepare (postPayload payload . (Lens.method .~ HTTP.methodPost)) opts url + +prepareMethod :: HTTP.Method -> Options -> String -> IO Req +prepareMethod method opts url = Req (manager opts) <$> + prepare (return . (Lens.method .~ method)) opts url + +prepareHead :: Options -> String -> IO Req +prepareHead = prepareMethod HTTP.methodHead + +runIgnore :: Run () +runIgnore (Req mgr req) = run mgr ignoreResponse req + +prepareOptions :: Options -> String -> IO Req +prepareOptions = prepareMethod HTTP.methodOptions + +preparePut :: Putable a => Options -> String -> a -> IO Req +preparePut opts url payload = Req (manager opts) <$> + prepare (putPayload payload . (Lens.method .~ HTTP.methodPut)) opts url + +prepareDelete :: Options -> String -> IO Req +prepareDelete = prepareMethod HTTP.methodDelete diff --git a/Network/Wreq/Internal/AWS.hs b/Network/Wreq/Internal/AWS.hs new file mode 100644 --- /dev/null +++ b/Network/Wreq/Internal/AWS.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE CPP, OverloadedStrings, BangPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Network.Wreq.Internal.AWS + ( + signRequest + ) where + +import Control.Applicative ((<$>)) +import Control.Lens ((%~), (^.), (&), to) +import Crypto.MAC (hmac, hmacGetDigest) +import Data.ByteString.Base16 as HEX (encode) +import Data.Byteable (toBytes) +import Data.Char (toLower) +import Data.List (sort) +import Data.Monoid ((<>)) +import Data.Time.Clock (getCurrentTime) +import Data.Time.Format (formatTime) +import Data.Time.LocalTime (utc, utcToLocalTime) +import Network.HTTP.Types (parseSimpleQuery, urlEncode) +import Network.Wreq.Internal.Lens +import Network.Wreq.Internal.Types (AWSAuthVersion(..)) +import qualified Crypto.Hash as CT (HMAC, SHA256) +import qualified Crypto.Hash.SHA256 as SHA256 (hash, hashlazy) +import qualified Data.ByteString.Char8 as S +import qualified Data.CaseInsensitive as CI (original) +import qualified Data.HashSet as HashSet +import qualified Network.HTTP.Client as HTTP + +#if MIN_VERSION_time(1,5,0) +import Data.Time.Format (defaultTimeLocale) +#else +import System.Locale (defaultTimeLocale) +#endif + +-- Sign requests following the AWS v4 request signing specification: +-- http://docs.aws.amazon.com/general/latest/gr/sigv4-create-canonical-request.html +-- +-- Runscope Inc. Traffic Inspector support: +-- We support (optionally) sending requests through the Runscope +-- (http://www.runscope.com) Traffic Inspector. If given a Runscope +-- URL to an AWS service, we will extract and correctly sign the +-- request for the underlying AWS service. We support Runscope buckets +-- with and without Bucket Authorization enabled +-- ("Runscope-Bucket-Auth"). +-- +-- TODO: adjust when DELETE supports a body or PATCH is added +signRequest :: AWSAuthVersion -> S.ByteString -> S.ByteString -> + Request -> IO Request +signRequest AWSv4 = signRequestV4 + +signRequestV4 :: S.ByteString -> S.ByteString -> Request -> IO Request +signRequestV4 key secret request = do + !ts <- timestamp -- YYYYMMDDT242424Z, UTC based + let origHost = request ^. host -- potentially w/ runscope bucket + runscopeBucketAuth = + lookup "Runscope-Bucket-Auth" $ request ^. requestHeaders + noRunscopeHost = removeRunscope origHost -- rm Runscope for signing + (service, region) = serviceAndRegion noRunscopeHost + date = S.takeWhile (/= 'T') ts -- YYYYMMDD + hashedPayload + | request ^. method `elem` ["POST", "PUT"] = payloadHash req + | otherwise = HEX.encode $ SHA256.hash "" + -- add common v4 signing headers, service specific headers, and + -- drop tmp header and Runscope-Bucket-Auth header (if present). + req = request & requestHeaders %~ + (([ ("host", noRunscopeHost) + , ("x-amz-date", ts)] ++ + [("x-amz-content-sha256", hashedPayload) | service == "s3"]) ++) + -- Runscope (correctly) doesn't send Bucket Auth header to AWS, + -- remove it from the headers we sign. Adding back in at the end. + . deleteKey "Runscope-Bucket-Auth" + -- task 1 + let hl = req ^. requestHeaders . to sort + signedHeaders = S.intercalate ";" . map (lowerCI . fst) $ hl + canonicalReq = S.intercalate "\n" [ + req ^. method -- step 1 + , req ^. path -- step 2 + , S.intercalate "&" -- step 3b, incl. sort + -- urlEncode True (QS) to encode ':' and '/' (e.g. in AWS arns) + . map (\(k,v) -> urlEncode True k <> "=" <> urlEncode True v) + . sort $ + parseSimpleQuery $ req ^. queryString + , S.unlines -- step 4, incl. sort + . map (\(k,v) -> lowerCI k <> ":" <> trimHeaderValue v) $ hl + , signedHeaders -- step 5 + , hashedPayload -- step 6, handles empty payload + ] + -- task 2 + let dateScope = S.intercalate "/" [date, region, service, "aws4_request"] + stringToSign = S.intercalate "\n" [ + "AWS4-HMAC-SHA256" + , ts + , dateScope + , HEX.encode $ SHA256.hash canonicalReq + ] + -- task 3, steps 1 and 2 + let signature = ("AWS4" <> secret) & + hmac' date & hmac' region & hmac' service & + hmac' "aws4_request" & hmac' stringToSign & HEX.encode + authorization = S.intercalate ", " [ + "AWS4-HMAC-SHA256 Credential=" <> key <> "/" <> dateScope + , "SignedHeaders=" <> signedHeaders + , "Signature=" <> signature + ] + -- Add the AWS Authorization header. + -- Restore the Host header to the Runscope endpoint + -- so they can proxy accordingly (if used, otherwise this is a nop). + -- Add the Runscope Bucket Auth header back in, if it was set originally. + return $ setHeader "host" origHost + <$> maybe id (setHeader "Runscope-Bucket-Auth") runscopeBucketAuth + <$> setHeader "authorization" authorization $ req + where + lowerCI = S.map toLower . CI.original + trimHeaderValue = + id -- FIXME, see step 4, whitespace trimming but not in double + -- quoted sections, AWS spec. + timestamp = render <$> getCurrentTime + where render = S.pack . formatTime defaultTimeLocale "%Y%m%dT%H%M%SZ" . + utcToLocalTime utc -- UTC printable: YYYYMMDDTHHMMSSZ + hmac' s k = toBytes (hmacGetDigest h) + where h = hmac k s :: (CT.HMAC CT.SHA256) + +payloadHash :: Request -> S.ByteString +payloadHash req = + case HTTP.requestBody req of + HTTP.RequestBodyBS bs -> + HEX.encode $ SHA256.hash bs + HTTP.RequestBodyLBS lbs -> + HEX.encode $ SHA256.hashlazy lbs + _ -> error "addTmpPayloadHashHeader: unexpected request body type" + +-- Per AWS documentation at: +-- http://docs.aws.amazon.com/general/latest/gr/rande.html +-- For example: "dynamodb.us-east-1.amazonaws.com" -> ("dynamodb", "us-east-1") +serviceAndRegion :: S.ByteString -> (S.ByteString, S.ByteString) +serviceAndRegion endpoint + -- For s3, check .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 diff --git a/Network/Wreq/Internal/Lens.hs b/Network/Wreq/Internal/Lens.hs new file mode 100644 --- /dev/null +++ b/Network/Wreq/Internal/Lens.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE RankNTypes, TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} + +module Network.Wreq.Internal.Lens + ( + HTTP.Request + , method + , secure + , host + , port + , path + , queryString + , requestHeaders + , requestBody + , requestVersion + , onRequestBodyException + , proxy + , hostAddress + , rawBody + , decompress + , redirectCount + , responseTimeout + , checkStatus + , getConnectionWrapper + , cookieJar + , seshCookies + , seshManager + , seshRun + -- * Useful functions + , assoc + , assoc2 + , setHeader + , maybeSetHeader + , deleteKey + ) where + +import Control.Lens hiding (makeLenses) +import Data.List (partition) +import Network.HTTP.Client (Request) +import Network.HTTP.Types (HeaderName) +import Network.Wreq.Lens.Machinery (makeLenses) +import Network.Wreq.Internal.Types (Session) +import qualified Data.ByteString as S +import qualified Network.HTTP.Client as HTTP + +makeLenses ''HTTP.Request +makeLenses ''Session + +assoc :: (Eq k) => k -> IndexedTraversal' k [(k, a)] a +assoc i = traverse . itraversed . index i + +assoc2 :: Eq k => k -> Lens' [(k,a)] [a] +-- This is only a lens up to the ordering of the list (which changes +-- when we modify the list). +-- assoc2 :: (Eq b, Functor f) => b -> ([a] -> f [a]) -> [(b, a)] -> f [(b, a)] +assoc2 k f = fmap (uncurry ((++) . fmap ((,) k))) . + _1 (f . fmap snd) . partition ((==k) . fst) + +-- | Set a header to the given value, replacing any prior value. +setHeader :: HeaderName -> S.ByteString -> Request -> Request +setHeader name value = requestHeaders %~ ((name,value) :) . deleteKey name + +-- | Set a header to the given value, but only if the header was not +-- already set. +maybeSetHeader :: HeaderName -> S.ByteString -> Request -> Request +maybeSetHeader name value = requestHeaders %~ + \hdrs -> case lookup name hdrs of + Just _ -> hdrs + Nothing -> (name,value) : hdrs + +deleteKey :: (Eq a) => a -> [(a,b)] -> [(a,b)] +deleteKey key = filter ((/= key) . fst) diff --git a/Network/Wreq/Internal/Link.hs b/Network/Wreq/Internal/Link.hs new file mode 100644 --- /dev/null +++ b/Network/Wreq/Internal/Link.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.Wreq.Internal.Link + ( + links + ) where + +import Control.Applicative ((<$>), (<*>), (*>), (<*), many) +import Data.Attoparsec.ByteString.Char8 as A8 +import Data.ByteString (ByteString) +import Network.Wreq.Types (Link(..)) +import qualified Data.Attoparsec.ByteString as A +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 + +links :: B.ByteString -> [Link] +links hdr = case parseOnly f hdr of + Left _ -> [] + Right xs -> xs + where f = sepBy1 (link <* skipSpace) (char8 ',' *> skipSpace) <* endOfInput + +link :: Parser Link +link = Link <$> url <*> many (char8 ';' *> skipSpace *> param) + where url = char8 '<' *> A8.takeTill (=='>') <* char8 '>' <* skipSpace + +param :: Parser (ByteString, ByteString) +param = do + name <- paramName + skipSpace *> "=" *> skipSpace + c <- peekChar' + let isTokenChar = A.inClass "!#$%&'()*+./0-9:<=>?@a-zA-Z[]^_`{|}~-" + val <- case c of + '"' -> quotedString + _ -> A.takeWhile isTokenChar + skipSpace + return (name, val) + +data Quot = Literal | Backslash + +quotedString :: Parser ByteString +quotedString = char '"' *> (fixup <$> body) <* char '"' + where body = A8.scan Literal $ \s c -> + case (s,c) of + (Literal, '\\') -> backslash + (Literal, '"') -> Nothing + _ -> literal + literal = Just Literal + backslash = Just Backslash + fixup = B8.pack . go . B8.unpack + where go ('\\' : x@'\\' : xs) = x : go xs + go ('\\' : x@'"' : xs) = x : go xs + go (x : xs) = x : go xs + go xs = xs + +paramName :: Parser ByteString +paramName = do + name <- A.takeWhile1 $ A.inClass "a-zA-Z0-9!#$&+-.^_`|~" + c <- peekChar + return $ case c of + Just '*' -> B8.snoc name '*' + _ -> name diff --git a/Network/Wreq/Internal/OAuth1.hs b/Network/Wreq/Internal/OAuth1.hs new file mode 100644 --- /dev/null +++ b/Network/Wreq/Internal/OAuth1.hs @@ -0,0 +1,12 @@ +module Network.Wreq.Internal.OAuth1 (signRequest) where + +import Network.HTTP.Client (Request(..)) +import Web.Authenticate.OAuth ( signOAuth, newOAuth, oauthConsumerKey + , oauthConsumerSecret, newCredential) +import qualified Data.ByteString as S + +signRequest :: S.ByteString -> S.ByteString -> S.ByteString -> S.ByteString -> Request -> IO Request +signRequest consumerToken consumerSecret token tokenSecret = signOAuth app creds + where + app = newOAuth { oauthConsumerKey = consumerToken, oauthConsumerSecret = consumerSecret } + creds = newCredential token tokenSecret diff --git a/Network/Wreq/Internal/Types.hs b/Network/Wreq/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/Network/Wreq/Internal/Types.hs @@ -0,0 +1,314 @@ +{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, FlexibleInstances, GADTs, + OverloadedStrings, RankNTypes, RecordWildCards #-} + +-- | +-- Module : Network.Wreq.Internal.Types +-- Copyright : (c) 2014 Bryan O'Sullivan +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : GHC +-- +-- HTTP client types. + +module Network.Wreq.Internal.Types + ( + -- * Client configuration + Options(..) + , Mgr + , Auth(..) + , AWSAuthVersion(..) + , StatusChecker + -- * Request payloads + , Payload(..) + , Postable(..) + , Putable(..) + -- ** URL-encoded forms + , FormParam(..) + , FormValue(..) + -- * Headers + , ContentType + , Link(..) + -- * Errors + , JSONError(..) + -- * Request types + , Req(..) + , reqURL + -- * Sessions + , Session(..) + , Run + , Body(..) + -- * Caches + , CacheEntry(..) + ) where + +import Control.Exception (Exception, SomeException) +import Data.IORef (IORef) +import Data.Monoid ((<>), mconcat) +import Data.Text (Text) +import Data.Time.Clock (UTCTime) +import Data.Typeable (Typeable) +import Network.HTTP.Client (CookieJar, Manager, ManagerSettings, Request, + RequestBody) +import Network.HTTP.Client.Internal (Response, Proxy) +import Network.HTTP.Types (Header, Status, ResponseHeaders) +import Prelude hiding (head) +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy as L +import qualified Network.HTTP.Client as HTTP + +-- | A MIME content type, e.g. @\"application/octet-stream\"@. +type ContentType = S.ByteString + +type Mgr = Either ManagerSettings Manager + +-- | Options for configuring a client. +data Options = Options { + manager :: Mgr + -- ^ Either configuration for a 'Manager', or an actual 'Manager'. + -- + -- If only 'ManagerSettings' are provided, then by default a new + -- 'Manager' will be created for each request. + -- + -- /Note/: when issuing HTTP requests using 'Options'-based + -- functions from the the "Network.Wreq.Session" module + -- ('Network.Wreq.Session.getWith', 'Network.Wreq.Session.putWith', + -- etc.), this field will be ignored. + -- + -- An example of using a specific manager: + -- + -- @ + --import "Network.HTTP.Client" ('Network.HTTP.Client.withManager') + -- + --'Network.HTTP.Client.withManager' $ \\mgr -> do + -- let opts = 'Network.Wreq.defaults' { 'manager' = Right mgr } + -- 'Network.Wreq.getWith' opts \"http:\/\/httpbin.org\/get\" + -- @ + -- + -- An example of changing settings (this will use a separate + -- 'Manager' for every request, so make sense only if you're issuing + -- a tiny handful of requets): + -- + -- @ + --import "Network.HTTP.Client" ('Network.HTTP.Client.defaultManagerSettings') + -- + --let settings = 'Network.HTTP.Client.defaultManagerSettings' { managerConnCount = 5 } + -- opts = 'Network.Wreq.defaults' { 'manager' = Left settings } + --'Network.Wreq.getWith' opts \"http:\/\/httpbin.org\/get\" + -- @ + , proxy :: Maybe Proxy + -- ^ Host name and port for a proxy to use, if any. + , auth :: Maybe Auth + -- ^ Authentication information. + -- + -- Example (note the use of TLS): + -- + -- @ + --let opts = 'Network.Wreq.defaults' { 'auth' = 'Network.Wreq.basicAuth' \"user\" \"pass\" } + --'Network.Wreq.getWith' opts \"https:\/\/httpbin.org\/basic-auth\/user\/pass\" + -- @ + , headers :: [Header] + -- ^ Additional headers to send with each request. + -- + -- @ + --let opts = 'Network.Wreq.defaults' { 'headers' = [(\"Accept\", \"*\/*\")] } + --'Network.Wreq.getWith' opts \"http:\/\/httpbin.org\/get\" + -- @ + , params :: [(Text, Text)] + -- ^ Key-value pairs to assemble into a query string to add to the + -- end of a URL. + -- + -- For example, given: + -- + -- @ + --let opts = 'Network.Wreq.defaults' { params = [(\"sort\", \"ascending\"), (\"key\", \"name\")] } + --'Network.Wreq.getWith' opts \"http:\/\/httpbin.org\/get\" + -- @ + -- + -- This will generate a URL of the form: + -- + -- >http://httpbin.org/get?sort=ascending&key=name + , redirects :: Int + -- ^ The maximum number of HTTP redirects to follow before giving up + -- and throwing an exception. + -- + -- In this example, a 'Network.HTTP.Client.HttpException' will be + -- thrown with a 'Network.HTTP.Client.TooManyRedirects' constructor, + -- because the maximum number of redirects allowed will be exceeded: + -- + -- @ + --let opts = 'Network.Wreq.defaults' { 'redirects' = 3 } + --'Network.Wreq.getWith' opts \"http:\/\/httpbin.org\/redirect/5\" + -- @ + , cookies :: Maybe CookieJar + -- ^ Cookies to set when issuing requests. + -- + -- /Note/: when issuing HTTP requests using 'Options'-based + -- functions from the the "Network.Wreq.Session" module + -- ('Network.Wreq.Session.getWith', 'Network.Wreq.Session.putWith', + -- etc.), this field will be used only for the /first/ HTTP request + -- to be issued during a 'Network.Wreq.Session.Session'. Any changes + -- changes made for subsequent requests will be ignored. + , checkStatus :: Maybe StatusChecker + -- ^ Function that checks the status code and potentially returns an + -- exception. + -- + -- This defaults to 'Nothing', which will just use the default of + -- 'Network.HTTP.Client.Request' which throws a 'StatusException' if + -- the status is not 2XX. + } deriving (Typeable) + +-- | A function that checks the result of a HTTP request and +-- potentially returns an exception. +type StatusChecker = Status -> ResponseHeaders -> CookieJar + -> Maybe SomeException + +-- | Supported authentication types. +-- +-- Do not use HTTP authentication unless you are using TLS encryption. +-- These authentication tokens can easily be captured and reused by an +-- attacker if transmitted in the clear. +data Auth = BasicAuth S.ByteString S.ByteString + -- ^ Basic authentication. This consists of a plain + -- username and password. + | OAuth2Bearer S.ByteString + -- ^ An OAuth2 bearer token. This is treated by many + -- services as the equivalent of a username and password. + | OAuth2Token S.ByteString + -- ^ A not-quite-standard OAuth2 bearer token (that seems + -- to be used only by GitHub). This is treated by whoever + -- accepts it as the equivalent of a username and + -- password. + | AWSAuth AWSAuthVersion S.ByteString S.ByteString + -- ^ Amazon Web Services request signing + -- AWSAuthVersion key secret + | OAuth1 S.ByteString S.ByteString S.ByteString S.ByteString + -- ^ OAuth1 request signing + -- OAuth1 consumerToken consumerSecret token secret + deriving (Eq, Show, Typeable) + +data AWSAuthVersion = AWSv4 + -- ^ AWS request signing version 4 + deriving (Eq, Show) + +instance Show Options where + show (Options{..}) = concat [ + "Options { " + , "manager = ", case manager of + Left _ -> "Left _" + Right _ -> "Right _" + , ", proxy = ", show proxy + , ", auth = ", show auth + , ", headers = ", show headers + , ", params = ", show params + , ", redirects = ", show redirects + , ", cookies = ", show cookies + , " }" + ] + +-- | A type that can be converted into a POST request payload. +class Postable a where + postPayload :: a -> Request -> IO Request + -- ^ Represent a value in the request body (and perhaps the + -- headers) of a POST request. + +-- | A type that can be converted into a PUT request payload. +class Putable a where + putPayload :: a -> Request -> IO Request + -- ^ Represent a value in the request body (and perhaps the + -- headers) of a PUT request. + +-- | A product type for representing more complex payload types. +data Payload where + Raw :: ContentType -> RequestBody -> Payload + deriving (Typeable) + +-- | A type that can be rendered as the value portion of a key\/value +-- pair for use in an @application\/x-www-form-urlencoded@ POST +-- body. Intended for use with the 'FormParam' type. +-- +-- The instances for 'String', strict 'Data.Text.Text', and lazy +-- 'Data.Text.Lazy.Text' are all encoded using UTF-8 before being +-- URL-encoded. +-- +-- The instance for 'Maybe' gives an empty string on 'Nothing', +-- and otherwise uses the contained type's instance. +class FormValue a where + renderFormValue :: a -> S.ByteString + -- ^ Render the given value. + +-- | A key\/value pair for an @application\/x-www-form-urlencoded@ +-- POST request body. +data FormParam where + (:=) :: (FormValue v) => S.ByteString -> v -> FormParam + +instance Show FormParam where + show (a := b) = show a ++ " := " ++ show (renderFormValue b) + +infixr 3 := + +-- | The error type used by 'Network.Wreq.asJSON' and +-- 'Network.Wreq.asValue' if a failure occurs when parsing a response +-- body as JSON. +data JSONError = JSONError String + deriving (Show, Typeable) + +instance Exception JSONError + +-- | An element of a @Link@ header. +data Link = Link { + linkURL :: S.ByteString + , linkParams :: [(S.ByteString, S.ByteString)] + } deriving (Eq, Show, Typeable) + +-- | A request that is ready to be submitted. +data Req = Req Mgr Request + +-- | Return the URL associated with the given 'Req'. +-- +-- This includes the port number if not standard, and the query string +-- if one exists. +reqURL :: Req -> S.ByteString +reqURL (Req _ req) = mconcat [ + if https then "https" else "http" + , "://" + , HTTP.host req + , case (HTTP.port req, https) of + (80, False) -> "" + (443, True) -> "" + (p, _) -> S.pack (show p) + , HTTP.path req + , case HTTP.queryString req of + qs | S.null qs -> "" + | otherwise -> "?" <> qs + ] + where https = HTTP.secure req + +-- | A function that runs a request and returns the associated +-- response. +type Run body = Req -> IO (Response body) + +-- | A session that spans multiple requests. This is responsible for +-- cookie management and TCP connection reuse. +data Session = Session { + seshCookies :: Maybe (IORef CookieJar) + , seshManager :: Manager + , seshRun :: Session -> Run Body -> Run Body + } + +instance Show Session where + show _ = "Session" + +data CacheEntry body = CacheEntry { + entryCreated :: UTCTime + , entryExpires :: Maybe UTCTime + , entryResponse :: Response body + } deriving (Functor) + +data Body = NoBody + | StringBody L.ByteString + | ReaderBody HTTP.BodyReader + +instance Show (CacheEntry body) where + show _ = "CacheEntry" diff --git a/Network/Wreq/Lens.hs b/Network/Wreq/Lens.hs new file mode 100644 --- /dev/null +++ b/Network/Wreq/Lens.hs @@ -0,0 +1,469 @@ +{-# LANGUAGE RankNTypes #-} + +-- | +-- Module : Network.Wreq.Lens +-- Copyright : (c) 2014 Bryan O'Sullivan +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : GHC +-- +-- HTTP client lens machinery. +-- +-- When reading the examples in this module, you should assume the +-- following environment: +-- +-- @ +-- \-\- Make it easy to write literal 'S.ByteString' and 'Text' values. +-- \{\-\# LANGUAGE OverloadedStrings \#\-\} +-- +-- \-\- Our handy module. +-- import "Network.Wreq" +-- +-- \-\- Operators such as ('&') and ('.~'). +-- import "Control.Lens" +-- +-- \-\- Conversion of Haskell values to JSON. +-- import "Data.Aeson" ('Data.Aeson.toJSON') +-- +-- \-\- Easy traversal of JSON data. +-- import "Data.Aeson.Lens" ('Data.Aeson.Lens.key', 'Data.Aeson.Lens.nth') +-- @ + +module Network.Wreq.Lens + ( + -- * Configuration + Options + , manager + , proxy + , auth + , header + , param + , redirects + , headers + , params + , cookie + , cookies + , StatusChecker + , checkStatus + + -- ** Proxy setup + , Proxy + , proxyHost + , proxyPort + + -- * Cookie + , Cookie + , cookieName + , cookieValue + , cookieExpiryTime + , cookieDomain + , cookiePath + , cookieCreationTime + , cookieLastAccessTime + , cookiePersistent + , cookieHostOnly + , cookieSecureOnly + , cookieHttpOnly + + -- * Response + , Response + , responseBody + , responseHeader + , responseLink + , responseCookie + , responseHeaders + , responseCookieJar + , responseStatus + , responseVersion + + -- ** Status + , Status + , statusCode + , statusMessage + + -- * Link header + , Link + , linkURL + , linkParams + + -- * POST body part + , Part + , partName + , partFileName + , partContentType + , partGetBody + + -- * Parsing + , atto + , atto_ + ) where + +import Control.Applicative ((<*)) +import Control.Lens (Fold, Lens, Lens', Traversal', folding) +import Data.Attoparsec.ByteString (Parser, endOfInput, parseOnly) +import Data.ByteString (ByteString) +import Data.Text (Text) +import Data.Time.Clock (UTCTime) +import Network.HTTP.Client (Cookie, CookieJar, Manager, ManagerSettings, Proxy) +import Network.HTTP.Client (RequestBody, Response) +import Network.HTTP.Client.MultipartFormData (Part) +import Network.HTTP.Types.Header (Header, HeaderName, ResponseHeaders) +import Network.HTTP.Types.Status (Status) +import Network.HTTP.Types.Version (HttpVersion) +import Network.Mime (MimeType) +import Network.Wreq.Types (Auth, Link, Options, StatusChecker) +import qualified Network.Wreq.Lens.TH as TH + +-- | A lens onto configuration of the connection manager provided by +-- the http-client package. +-- +-- In this example, we enable the use of OpenSSL for (hopefully) +-- secure connections: +-- +-- @ +--import "OpenSSL.Session" ('OpenSSL.Session.context') +--import "Network.HTTP.Client.OpenSSL" +-- +--let opts = 'Network.Wreq.defaults' 'Control.Lens.&' 'manager' 'Control.Lens..~' Left ('Network.HTTP.Client.OpenSSL.opensslManagerSettings' 'OpenSSL.Session.context') +--'Network.HTTP.Client.OpenSSL.withOpenSSL' $ +-- 'Network.Wreq.getWith' opts \"https:\/\/httpbin.org\/get\" +-- @ +-- +-- In this example, we also set the response timeout to 10000 microseconds: +-- +-- @ +--import "OpenSSL.Session" ('OpenSSL.Session.context') +--import "Network.HTTP.Client.OpenSSL" +--import "Network.HTTP.Client" ('Network.HTTP.Client.defaultManagerSettings', 'Network.HTTP.Client.managerResponseTimeout') +-- +--let opts = 'Network.Wreq.defaults' 'Control.Lens.&' 'manager' 'Control.Lens..~' Left ('Network.HTTP.Client.OpenSSL.opensslManagerSettings' 'OpenSSL.Session.context') +-- 'Control.Lens.&' 'manager' 'Control.Lens..~' Left ('Network.HTTP.Client.defaultManagerSettings' { 'Network.HTTP.Client.managerResponseTimeout' = Just 10000 } ) +-- +--'Network.HTTP.Client.OpenSSL.withOpenSSL' $ +-- 'Network.Wreq.getWith' opts \"https:\/\/httpbin.org\/get\" +-- @ +manager :: Lens' Options (Either ManagerSettings Manager) +manager = TH.manager + +-- | A lens onto proxy configuration. +-- +-- Example: +-- +-- @ +--let opts = 'Network.Wreq.defaults' 'Control.Lens.&' 'proxy' 'Control.Lens.?~' 'Network.Wreq.httpProxy' \"localhost\" 8000 +--'Network.Wreq.getWith' opts \"http:\/\/httpbin.org\/get\" +-- @ +-- +-- Note here the use of the 'Control.Lens.?~' setter to turn a 'Proxy' +-- into a 'Maybe' 'Proxy', to make the type of the RHS compatible with +-- the 'Lens.proxy' lens. +proxy :: Lens' Options (Maybe Proxy) +proxy = TH.proxy + +-- | A lens onto request authentication. +-- +-- Example (note the use of TLS): +-- +-- @ +--let opts = 'Network.Wreq.defaults' 'Control.Lens.&' 'Lens.auth' 'Control.Lens.?~' 'Network.Wreq.basicAuth' \"user\" \"pass\" +--'Network.Wreq.getWith' opts \"https:\/\/httpbin.org\/basic-auth\/user\/pass\" +-- @ +auth :: Lens' Options (Maybe Auth) +auth = TH.auth + +-- | A lens onto all headers with the given name (there can +-- legitimately be zero or more). +-- +-- Example: +-- +-- @ +--let opts = 'Network.Wreq.defaults' 'Control.Lens.&' 'header' \"Accept\" 'Control.Lens..~' [\"*\/*\"] +--'Network.Wreq.getWith' opts \"http:\/\/httpbin.org\/get\" +-- @ +header :: HeaderName -> Lens' Options [ByteString] +header = TH.header + +-- | A lens onto all headers (there can legitimately be zero or more). +-- +-- In this example, we print all the headers sent by default with +-- every request. +-- +-- @ +--print ('Network.Wreq.defaults' 'Control.Lens.^.' 'headers') +-- @ +headers :: Lens' Options [Header] +headers = TH.headers + +-- | A lens onto all query parameters with the given name (there can +-- legitimately be zero or more). +-- +-- In this example, we construct the query URL +-- \"@http:\/\/httpbin.org\/get?foo=bar&foo=quux@\". +-- +-- @ +--let opts = 'Network.Wreq.defaults' 'Control.Lens.&' 'param' \"foo\" 'Control.Lens..~' [\"bar\", \"quux\"] +--'Network.Wreq.getWith' opts \"http:\/\/httpbin.org\/get\" +-- @ +param :: Text -> Lens' Options [Text] +param = TH.param + +-- | A lens onto all query parameters. +params :: Lens' Options [(Text, Text)] +params = TH.params + +-- | A lens onto the maximum number of redirects that will be followed +-- before an exception is thrown. +-- +-- In this example, a 'Network.HTTP.Client.HttpException' will be +-- thrown with a 'Network.HTTP.Client.TooManyRedirects' constructor, +-- because the maximum number of redirects allowed will be exceeded. +-- +-- @ +--let opts = 'Network.Wreq.defaults' 'Control.Lens.&' 'redirects' 'Control.Lens..~' 3 +--'Network.Wreq.getWith' opts \"http:\/\/httpbin.org\/redirect\/5\" +-- @ +redirects :: Lens' Options Int +redirects = TH.redirects + +-- | A lens to get the optional status check function +checkStatus :: Lens' Options (Maybe StatusChecker) +checkStatus = TH.checkStatus + +-- | A traversal onto the cookie with the given name, if one exists. +-- +-- N.B. This is an \"illegal\" 'Traversal'': we can change the +-- 'cookieName' of the associated 'Cookie' so that it differs from the +-- name provided to this function. +cookie :: ByteString -> Traversal' Options Cookie +cookie = TH.cookie + +-- | A lens onto all cookies. +cookies :: Lens' Options (Maybe CookieJar) +cookies = TH.cookies + +-- | A lens onto the name of a cookie. +cookieName :: Lens' Cookie ByteString +cookieName = TH.cookieName + +-- | A lens onto the value of a cookie. +cookieValue :: Lens' Cookie ByteString +cookieValue = TH.cookieValue + +-- | A lens onto the expiry time of a cookie. +cookieExpiryTime :: Lens' Cookie UTCTime +cookieExpiryTime = TH.cookieExpiryTime + +-- | A lens onto the domain of a cookie. +cookieDomain :: Lens' Cookie ByteString +cookieDomain = TH.cookieDomain + +-- | A lens onto the path of a cookie. +cookiePath :: Lens' Cookie ByteString +cookiePath = TH.cookiePath + +-- | A lens onto the creation time of a cookie. +cookieCreationTime :: Lens' Cookie UTCTime +cookieCreationTime = TH.cookieCreationTime + +-- | A lens onto the last access time of a cookie. +cookieLastAccessTime :: Lens' Cookie UTCTime +cookieLastAccessTime = TH.cookieLastAccessTime + +-- | A lens onto whether a cookie is persistent across sessions (also +-- known as a \"tracking cookie\"). +cookiePersistent :: Lens' Cookie Bool +cookiePersistent = TH.cookiePersistent + +-- | A lens onto whether a cookie is host-only. +cookieHostOnly :: Lens' Cookie Bool +cookieHostOnly = TH.cookieHostOnly + +-- | A lens onto whether a cookie is secure-only, such that it will +-- only be used over TLS. +cookieSecureOnly :: Lens' Cookie Bool +cookieSecureOnly = TH.cookieSecureOnly + +-- | A lens onto whether a cookie is \"HTTP-only\". +-- +-- Such cookies should be used only by browsers when transmitting HTTP +-- requests. They must be unavailable in non-browser environments, +-- such as when executing JavaScript scripts. +cookieHttpOnly :: Lens' Cookie Bool +cookieHttpOnly = TH.cookieHttpOnly + +-- | A lens onto the hostname portion of a proxy configuration. +proxyHost :: Lens' Proxy ByteString +proxyHost = TH.proxyHost + +-- | A lens onto the TCP port number of a proxy configuration. +proxyPort :: Lens' Proxy Int +proxyPort = TH.proxyPort + +-- | A lens onto the status of an HTTP response. +responseStatus :: Lens' (Response body) Status +responseStatus = TH.responseStatus + +-- | A lens onto the version of an HTTP response. +responseVersion :: Lens' (Response body) HttpVersion +responseVersion = TH.responseVersion + +-- | A lens onto all matching named headers in an HTTP response. +-- +-- To access exactly one header (the result will be the empty string if +-- there is no match), use the ('Control.Lens.^.') operator. +-- +-- @ +--r <- 'Network.Wreq.get' \"http:\/\/httpbin.org\/get\" +--print (r 'Control.Lens.^.' 'responseHeader' \"Content-Type\") +-- @ +-- +-- To access at most one header (the result will be 'Nothing' if there +-- is no match), use the ('Control.Lens.^?') operator. +-- +-- @ +--r <- 'Network.Wreq.get' \"http:\/\/httpbin.org\/get\" +--print (r 'Control.Lens.^?' 'responseHeader' \"Content-Transfer-Encoding\") +-- @ +-- +-- To access all (zero or more) matching headers, use the +-- ('Control.Lens.^..') operator. +-- +-- @ +--r <- 'Network.Wreq.get' \"http:\/\/httpbin.org\/get\" +--print (r 'Control.Lens.^..' 'responseHeader' \"Set-Cookie\") +-- @ +responseHeader :: HeaderName + -- ^ Header name to match. + -> Traversal' (Response body) ByteString +responseHeader = TH.responseHeader + +-- | A lens onto all headers in an HTTP response. +responseHeaders :: Lens' (Response body) ResponseHeaders +responseHeaders = TH.responseHeaders + +-- | A fold over @Link@ headers, matching on both parameter name +-- and value. +-- +-- For example, here is a @Link@ header returned by the GitHub search API. +-- +-- > Link: +-- > ; 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 diff --git a/Network/Wreq/Lens/Machinery.hs b/Network/Wreq/Lens/Machinery.hs new file mode 100644 --- /dev/null +++ b/Network/Wreq/Lens/Machinery.hs @@ -0,0 +1,27 @@ +module Network.Wreq.Lens.Machinery + ( + makeLenses + , fieldName + , toCamelCase + ) where + +import Control.Lens ((&), (.~)) +import Control.Lens.TH hiding (makeLenses) +import Data.Char (toUpper) +import Language.Haskell.TH.Syntax (Dec, Name, Q, mkName, nameBase) + +defaultRules :: LensRules +defaultRules = lensRules + +fieldName :: (String -> String) -> Name -> [Name] -> Name -> [DefName] +fieldName f _ _ name = [TopName . mkName . f . nameBase $ name] + +makeLenses :: Name -> Q [Dec] +makeLenses = makeLensesWith (defaultRules & lensField .~ fieldName id) + +toCamelCase :: String -> String +toCamelCase (x0:x0s) = x0 : go x0s + where go ('_':x:xs) = toUpper x : go xs + go (x:xs) = x : go xs + go [] = [] +toCamelCase [] = [] diff --git a/Network/Wreq/Lens/TH.hs b/Network/Wreq/Lens/TH.hs new file mode 100644 --- /dev/null +++ b/Network/Wreq/Lens/TH.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE FlexibleContexts, OverloadedStrings, RankNTypes, + TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} + +module Network.Wreq.Lens.TH + ( + Types.Options + , manager + , proxy + , auth + , header + , headers + , param + , params + , redirects + , cookie + , cookies + , checkStatus + + , HTTP.Cookie + , cookieName + , cookieValue + , cookieExpiryTime + , cookieDomain + , cookiePath + , cookieCreationTime + , cookieLastAccessTime + , cookiePersistent + , cookieHostOnly + , cookieSecureOnly + , cookieHttpOnly + + , HTTP.Proxy + , proxyHost + , proxyPort + + , HTTP.Response + , responseStatus + , responseVersion + , responseHeader + , responseHeaders + , responseLink + , responseBody + , responseCookie + , responseCookieJar + , responseClose' + + , HTTP.Status + , statusCode + , statusMessage + + , Types.Link + , linkURL + , linkParams + + , Form.Part + , partName + , partFilename + , partContentType + , partGetBody + , partHeaders + ) where + +import Control.Lens hiding (makeLenses) +import Data.ByteString (ByteString) +import Data.Text (Text) +import Network.Wreq.Internal.Lens (assoc, assoc2) +import Network.Wreq.Internal.Link +import Network.Wreq.Lens.Machinery (fieldName, makeLenses, toCamelCase) +import qualified Network.HTTP.Client as HTTP +import qualified Network.HTTP.Client.MultipartFormData as Form +import qualified Network.HTTP.Types.Header as HTTP +import qualified Network.HTTP.Types.Status as HTTP +import qualified Network.Wreq.Types as Types + +makeLenses ''Types.Options +makeLensesWith (lensRules & lensField .~ fieldName toCamelCase) ''HTTP.Cookie +makeLenses ''HTTP.Proxy +makeLenses ''HTTP.Response +makeLenses ''HTTP.Status +makeLenses ''Types.Link +makeLenses ''Form.Part + +responseHeader :: HTTP.HeaderName -> Traversal' (HTTP.Response body) ByteString +responseHeader n = responseHeaders . assoc n + +param :: Text -> Lens' Types.Options [Text] +param n = params . assoc2 n + +header :: HTTP.HeaderName -> Lens' Types.Options [ByteString] +header n = headers . assoc2 n + +_CookieJar :: Iso' HTTP.CookieJar [HTTP.Cookie] +_CookieJar = iso HTTP.destroyCookieJar HTTP.createCookieJar + +-- N.B. This is an "illegal" traversal because we can change its cookie_name. +cookie :: ByteString -> Traversal' Types.Options HTTP.Cookie +cookie name = cookies . _Just . _CookieJar . traverse . filtered + (\c -> HTTP.cookie_name c == name) + +responseCookie :: ByteString -> Fold (HTTP.Response body) HTTP.Cookie +responseCookie name = + responseCookieJar . folding HTTP.destroyCookieJar . filtered + ((==name) . HTTP.cookie_name) + +responseLink :: ByteString -> ByteString -> Fold (HTTP.Response body) Types.Link +responseLink name val = + responseHeader "Link" . folding links . + filtered (has (linkParams . folded . filtered (== (name,val)))) diff --git a/Network/Wreq/Session.hs b/Network/Wreq/Session.hs new file mode 100644 --- /dev/null +++ b/Network/Wreq/Session.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE RankNTypes, RecordWildCards #-} + +-- | +-- Module : Network.Wreq.Session +-- Copyright : (c) 2014 Bryan O'Sullivan +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : GHC +-- +-- The functions in this module use a 'Session' to handle the +-- following common needs: +-- +-- * TCP connection reuse. This is important for performance when +-- multiple requests go to a single server, particularly if TLS is +-- being used. +-- +-- * Transparent cookie management. Any cookies set by the server +-- persist from one request to the next. (Bypass this overhead +-- using 'withAPISession'.) +-- +-- +-- This module is designed to be used alongside the "Network.Wreq" +-- module. Typical usage will look like this: +-- +-- @ +-- import "Network.Wreq" +-- import qualified "Network.Wreq.Session" as Sess +-- +-- main = Sess.'withSession' $ \\sess -> +-- Sess.'get' sess \"http:\/\/httpbin.org\/get\" +-- @ +-- +-- We create a 'Session' using 'withSession', then pass the session to +-- subsequent functions. When talking to a REST-like service that does +-- not use cookies, it is more efficient to use 'withAPISession'. +-- +-- Note the use of qualified import statements in the examples above, +-- so that we can refer unambiguously to the 'Session'-specific +-- implementation of HTTP GET. + +module Network.Wreq.Session + ( + -- * Session creation + Session + , withSession + , withAPISession + -- ** More control-oriented session creation + , withSessionWith + , withSessionControl + -- * HTTP verbs + , get + , post + , head_ + , options + , put + , delete + -- ** Configurable verbs + , getWith + , postWith + , headWith + , optionsWith + , putWith + , deleteWith + -- * Extending a session + , Lens.seshRun + ) where + +import Control.Lens ((&), (?~), (.~)) +import Data.Foldable (forM_) +import Data.IORef (newIORef, readIORef, writeIORef) +import Network.Wreq (Options, Response) +import Network.Wreq.Internal +import Network.Wreq.Internal.Types (Body(..), Req(..), Session(..)) +import Network.Wreq.Types (Postable, Putable, Run) +import Prelude hiding (head) +import qualified Data.ByteString.Lazy as L +import qualified Network.HTTP.Client as HTTP +import qualified Network.Wreq.Internal.Lens as Lens + +-- | Create a 'Session', passing it to the given function. The +-- 'Session' will no longer be valid after that function returns. +-- +-- This session manages cookies and uses default session manager +-- configuration. +withSession :: (Session -> IO a) -> IO a +withSession = withSessionWith defaultManagerSettings + +-- | Create a session. +-- +-- This uses the default session manager settings, but does not manage +-- cookies. It is intended for use with REST-like HTTP-based APIs, +-- which typically do not use cookies. +withAPISession :: (Session -> IO a) -> IO a +withAPISession = withSessionControl Nothing defaultManagerSettings + +-- | Create a session, using the given manager settings. This session +-- manages cookies. +withSessionWith :: HTTP.ManagerSettings -> (Session -> IO a) -> IO a +withSessionWith = withSessionControl (Just (HTTP.createCookieJar [])) +{-# DEPRECATED withSessionWith "Use withSessionControl instead." #-} + +-- | Create a session, using the given cookie jar and manager settings. +withSessionControl :: Maybe HTTP.CookieJar + -- ^ If 'Nothing' is specified, no cookie management + -- will be performed. + -> HTTP.ManagerSettings + -> (Session -> IO a) -> IO a +withSessionControl mj settings act = do + mref <- maybe (return Nothing) (fmap Just . newIORef) mj + HTTP.withManager settings $ \mgr -> + act Session { seshCookies = mref + , seshManager = mgr + , seshRun = runWith + } + +-- | 'Session'-specific version of 'Network.Wreq.get'. +get :: Session -> String -> IO (Response L.ByteString) +get = getWith defaults + +-- | 'Session'-specific version of 'Network.Wreq.post'. +post :: Postable a => Session -> String -> a -> IO (Response L.ByteString) +post = postWith defaults + +-- | 'Session'-specific version of 'Network.Wreq.head_'. +head_ :: Session -> String -> IO (Response ()) +head_ = headWith defaults + +-- | 'Session'-specific version of 'Network.Wreq.options'. +options :: Session -> String -> IO (Response ()) +options = optionsWith defaults + +-- | 'Session'-specific version of 'Network.Wreq.put'. +put :: Putable a => Session -> String -> a -> IO (Response L.ByteString) +put = putWith defaults + +-- | 'Session'-specific version of 'Network.Wreq.delete'. +delete :: Session -> String -> IO (Response L.ByteString) +delete = deleteWith defaults + +-- | 'Session'-specific version of 'Network.Wreq.getWith'. +getWith :: Options -> Session -> String -> IO (Response L.ByteString) +getWith opts sesh url = run string sesh =<< prepareGet opts url + +-- | 'Session'-specific version of 'Network.Wreq.postWith'. +postWith :: Postable a => Options -> Session -> String -> a + -> IO (Response L.ByteString) +postWith opts sesh url payload = + run string sesh =<< preparePost opts url payload + +-- | 'Session'-specific version of 'Network.Wreq.headWith'. +headWith :: Options -> Session -> String -> IO (Response ()) +headWith opts sesh url = run ignore sesh =<< prepareHead opts url + +-- | 'Session'-specific version of 'Network.Wreq.optionsWith'. +optionsWith :: Options -> Session -> String -> IO (Response ()) +optionsWith opts sesh url = run ignore sesh =<< prepareOptions opts url + +-- | 'Session'-specific version of 'Network.Wreq.putWith'. +putWith :: Putable a => Options -> Session -> String -> a + -> IO (Response L.ByteString) +putWith opts sesh url payload = run string sesh =<< preparePut opts url payload + +-- | 'Session'-specific version of 'Network.Wreq.deleteWith'. +deleteWith :: Options -> Session -> String -> IO (Response L.ByteString) +deleteWith opts sesh url = run string sesh =<< prepareDelete opts url + +runWith :: Session -> Run Body -> Run Body +runWith Session{..} act (Req _ req) = do + req' <- case seshCookies of + Nothing -> return (req & Lens.cookieJar .~ Nothing) + Just ref -> (\s -> req & Lens.cookieJar ?~ s) `fmap` readIORef ref + resp <- act (Req (Right seshManager) req') + forM_ seshCookies $ \ref -> + writeIORef ref (HTTP.responseCookieJar resp) + return resp + +type Mapping a = (Body -> a, a -> Body, Run a) + +run :: Mapping a -> Session -> Run a +run (to,from,act) sesh = + fmap (fmap to) . seshRun sesh sesh (fmap (fmap from) . act) + +string :: Mapping L.ByteString +string = (\(StringBody s) -> s, StringBody, runRead) + +ignore :: Mapping () +ignore = (\_ -> (), const NoBody, runIgnore) diff --git a/Network/Wreq/Types.hs b/Network/Wreq/Types.hs new file mode 100644 --- /dev/null +++ b/Network/Wreq/Types.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE FlexibleInstances, OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- Module : Network.Wreq.Types +-- Copyright : (c) 2014 Bryan O'Sullivan +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : GHC +-- +-- HTTP client types. + +module Network.Wreq.Types + ( + -- * Client configuration + Options(..) + , Auth(..) + , AWSAuthVersion(..) + , StatusChecker + -- * Request payloads + , Payload(..) + , Postable(..) + , Putable(..) + -- ** URL-encoded forms + , FormParam(..) + , FormValue(..) + -- * Headers + , ContentType + , Link(..) + -- * Errors + , JSONError(..) + -- * Request handling + , Req + , reqURL + , Run + ) where + +import Control.Lens ((&), (.~)) +import Data.Aeson (Value, encode) +import Data.Int (Int8, Int16, Int32, Int64) +import Data.Word (Word, Word8, Word16, Word32, Word64) +import Network.HTTP.Client (Request) +import Network.HTTP.Client.MultipartFormData (Part, formDataBody) +import Network.Wreq.Internal.Types +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TL +import qualified Network.HTTP.Client as HTTP +import qualified Network.Wreq.Internal.Lens as Lens + +instance Postable Part where + postPayload a = postPayload [a] + +instance Postable [Part] where + postPayload = formDataBody + +instance Postable [(S.ByteString, S.ByteString)] where + postPayload ps req = return $ HTTP.urlEncodedBody ps req + +instance Postable (S.ByteString, S.ByteString) where + postPayload p = postPayload [p] + +instance Postable [FormParam] where + postPayload ps = postPayload (map f ps) + where f (a := b) = (a, renderFormValue b) + +instance Postable FormParam where + postPayload p = postPayload [p] + +instance Postable Payload where + postPayload = putPayload + +instance Postable S.ByteString where + postPayload = putPayload + +instance Postable L.ByteString where + postPayload = putPayload + +instance Postable Value where + postPayload = putPayload + + +instance Putable Payload where + putPayload pl = + case pl of + Raw ct rb -> payload ct rb + +instance Putable S.ByteString where + putPayload = payload "application/octet-stream" . HTTP.RequestBodyBS + +instance Putable L.ByteString where + putPayload = payload "application/octet-stream" . HTTP.RequestBodyLBS + +instance Putable Value where + putPayload = payload "application/json" . HTTP.RequestBodyLBS . encode + + +instance FormValue T.Text where + renderFormValue = T.encodeUtf8 + +instance FormValue TL.Text where + renderFormValue = T.encodeUtf8 . TL.toStrict + +instance FormValue TL.Builder where + renderFormValue = T.encodeUtf8 . TL.toStrict . TL.toLazyText + +instance FormValue String where + renderFormValue = T.encodeUtf8 . T.pack + +instance FormValue S.ByteString where + renderFormValue = id + +instance FormValue L.ByteString where + renderFormValue = S.concat . L.toChunks + +instance FormValue Int where renderFormValue = renderFormValue . show +instance FormValue Int8 where renderFormValue = renderFormValue . show +instance FormValue Int16 where renderFormValue = renderFormValue . show +instance FormValue Int32 where renderFormValue = renderFormValue . show +instance FormValue Int64 where renderFormValue = renderFormValue . show +instance FormValue Integer where renderFormValue = renderFormValue . show + +instance FormValue Word where renderFormValue = renderFormValue . show +instance FormValue Word8 where renderFormValue = renderFormValue . show +instance FormValue Word16 where renderFormValue = renderFormValue . show +instance FormValue Word32 where renderFormValue = renderFormValue . show +instance FormValue Word64 where renderFormValue = renderFormValue . show + +instance FormValue Float where renderFormValue = renderFormValue . show +instance FormValue Double where renderFormValue = renderFormValue . show + +instance FormValue () where renderFormValue _ = "" + +instance (FormValue a) => FormValue (Maybe a) where + renderFormValue (Just a) = renderFormValue a + renderFormValue Nothing = "" + +payload :: S.ByteString -> HTTP.RequestBody -> Request -> IO Request +payload ct body req = + return $ req & Lens.maybeSetHeader "Content-Type" ct + & Lens.requestBody .~ body diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,36 @@ +# wreq: a Haskell web client library [![Build Status](https://travis-ci.org/stackbuilders/wreq.svg)](https://travis-ci.org/stackbuilders/wreq) + +`wreq` is a library that makes HTTP client programming in Haskell +easy. + +# Features + +* Simple but powerful `lens`-based API + +* Over 100 tests, and built on reliable libraries like [`http-client`](http://hackage.haskell.org/package/http-client/) + and [`lens`](https://lens.github.io/) + +* Session handling includes connection keep-alive and pooling, and + cookie persistence + +* Automatic decompression + +* Powerful multipart form and file upload handling + +* Support for JSON requests and responses, including navigation of + schema-less responses + +* Basic and OAuth2 bearer authentication + +* Amazon Web Services (AWS) request signing (Version 4) + +* AWS signing supports sending requests through the + [Runscope Inc.](https://www.runscope.com) Traffic Inspector + +# Tutorials + +See [the tutorials](http://www.serpentine.com/wreq/) for a quick-start. + +# Is it done? + +No! See [`TODO.md`](TODO.md) for a rather long list of ideas. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,64 @@ +-- I don't know who originally wrote this, but I picked it up from +-- Edward Kmett's folds package. + +{-# OPTIONS_GHC -Wall #-} +module Main (main) where + +import Data.List (nub) +import Data.Version (showVersion) +import Distribution.Package + (PackageName(PackageName), Package, PackageId, InstalledPackageId, + packageVersion, packageName) +import Distribution.PackageDescription (PackageDescription(), TestSuite(..)) +import Distribution.Simple + (defaultMainWithHooks, UserHooks(..), simpleUserHooks) +import Distribution.Simple.BuildPaths (autogenModulesDir) +import Distribution.Simple.LocalBuildInfo + (withLibLBI, withTestLBI, LocalBuildInfo(), + ComponentLocalBuildInfo(componentPackageDeps)) +import Distribution.Simple.Setup + (BuildFlags(buildVerbosity), Flag(..), fromFlag, + HaddockFlags(haddockDistPref)) +import Distribution.Simple.Utils + (rewriteFile, createDirectoryIfMissingVerbose, copyFiles) +import Distribution.Text (display) +import Distribution.Verbosity (Verbosity, normal) +import System.FilePath (()) + +main :: IO () +main = defaultMainWithHooks simpleUserHooks + { buildHook = \pkg lbi hooks flags -> do + generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi + buildHook simpleUserHooks pkg lbi hooks flags + , postHaddock = \args flags pkg lbi -> do + copyFiles normal (haddockOutputDir flags pkg) [] + postHaddock simpleUserHooks args flags pkg lbi + } + +haddockOutputDir :: Package p => HaddockFlags -> p -> FilePath +haddockOutputDir flags pkg = destDir where + baseDir = case haddockDistPref flags of + NoFlag -> "." + Flag x -> x + destDir = baseDir "doc" "html" display (packageName pkg) + +generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo + -> IO () +generateBuildModule verbosity pkg lbi = do + let dir = autogenModulesDir lbi + createDirectoryIfMissingVerbose verbosity True dir + withLibLBI pkg lbi $ \_ libcfg -> do + withTestLBI pkg lbi $ \suite suitecfg -> do + rewriteFile (dir "Build_" ++ testName suite ++ ".hs") $ unlines + [ "module Build_" ++ testName suite ++ " where" + , "deps :: [String]" + , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg)) + ] + where + formatdeps = map (formatone . snd) + formatone p = case packageName p of + PackageName n -> n ++ "-" ++ showVersion (packageVersion p) + +testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo + -> [(InstalledPackageId, PackageId)] +testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys diff --git a/TODO.md b/TODO.md new file mode 100644 --- /dev/null +++ b/TODO.md @@ -0,0 +1,21 @@ +# Work yet to be done + +* More advanced tutorial-style documentation + +* TLS server certificate verification + +* An example that spiders a Haddock package's docs to validate its + internal and external links + +* Integration with tagsoup (see + [the mess in `UploadPaste.hs`](https://github.com/bos/wreq/blob/master/examples/UploadPaste.hs#L137)) + +* International domain support? + +* Better authentication support, including session-long memory of + which URLs do and don't need authentication + +* Some poor sod needs to add digest authentication to `http-client` so + we can use it + +* Cache management diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,42 @@ +-*- markdown -*- + +xxx-xxx 0.4.0.0 + +* Compatible with GHC 7.10. + +* New withAPISession and withSessionControl functions make talking to + REST services more efficient. + +* Added support for AWS S3 virtual-host style URLs. + +* Added signing support for region specific calls to the AWS Security + Token Service (AWS STS). + +* The introduction of AWS support accidentally introduced unwanted AWS + headers and computation into all requests. This has been fixed. + + +2014-12-11 0.3.0.1 + +* Bump lower bound on http-client to 0.3.0.1 + + +2014-12-02 0.3.0.0 + +* Support for Amazon Web Services request signing + +* New customMethod, customMethodWith functions allow use of arbitrary + HTTP verbs + +* httpProxy, basicAuth, oauth2Bearer, oauth2Token: removed Maybe from + result types, changed documentation to suggest use of (?~) + + +2014-08-25 0.2.0.0 + +* Support for lens 4.4 + + +2014-04-22 0.1.0.0 + +* Initial release. diff --git a/examples/JsonResponse.hs b/examples/JsonResponse.hs new file mode 100644 --- /dev/null +++ b/examples/JsonResponse.hs @@ -0,0 +1,122 @@ +-- Examples of handling for JSON responses +-- +-- This library provides several ways to handle JSON responses + +{-# LANGUAGE DeriveGeneric, OverloadedStrings, ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-unused-binds #-} + +import Control.Lens ((&), (^.), (^?), (.~)) +import Data.Aeson (FromJSON) +import Data.Aeson.Lens (key) +import Data.Map (Map) +import Data.Text (Text) +import GHC.Generics (Generic) +import qualified Control.Exception as E + +import Network.Wreq + + +-- This Haskell type corresponds to the structure of a response body +-- from httpbin.org. + +data GetBody = GetBody { + headers :: Map Text Text + , args :: Map Text Text + , origin :: Text + , url :: Text + } deriving (Show, Generic) + +-- Get GHC to derive a FromJSON instance for us. + +instance FromJSON GetBody + + + +-- We expect this to succeed. + +basic_asJSON :: IO () +basic_asJSON = do + let opts = defaults & param "foo" .~ ["bar"] + r <- asJSON =<< getWith opts "http://httpbin.org/get" + + -- The fact that we want a GetBody here will be inferred by our use + -- of the "headers" accessor function. + + putStrLn $ "args: " ++ show (args (r ^. responseBody)) + + + +-- The response we expect here is valid JSON, but cannot be converted +-- to an [Int], so this will throw a JSONError. + +failing_asJSON :: IO () +failing_asJSON = do + (r :: Response [Int]) <- asJSON =<< get "http://httpbin.org/get" + putStrLn $ "response: " ++ show (r ^. responseBody) + + + +-- This demonstrates how to catch a JSONError. + +failing_asJSON_catch :: IO () +failing_asJSON_catch = + failing_asJSON `E.catch` \(e :: JSONError) -> print e + + + +-- Because asJSON is parameterized over MonadThrow, we can use it with +-- other instances. +-- +-- Here, instead of throwing an exception in the IO monad, we instead +-- evaluate the result as an Either: +-- +-- * if the conversion fails, the Left constructor will contain +-- whatever exception describes the error +-- +-- * if the conversion succeeds, the Right constructor will contain +-- the converted response + +either_asJSON :: IO () +either_asJSON = do + r <- get "http://httpbin.org/get" + + -- This first conversion attempt will fail, but because we're using + -- Either, it will not throw an exception that kills execution. + let failing = asJSON r :: Either E.SomeException (Response [Int]) + print failing + + -- Our second conversion attempt will succeed. + let succeeding = asJSON r :: Either E.SomeException (Response GetBody) + print succeeding + + + +-- The lens package defines some handy combinators for use with the +-- aeson package, with which we can easily traverse parts of a JSON +-- response. + +lens_aeson :: IO () +lens_aeson = do + r <- get "http://httpbin.org/get" + print $ r ^? responseBody . key "headers" . key "User-Agent" + + -- If we maintain the ResponseBody as a ByteString, the lens + -- combinators will have to convert the body to a Value every time + -- we start a new traversal. + + -- When we need to poke at several parts of a response, it's more + -- efficient to use asValue to perform the conversion to a Value + -- once. + + let opts = defaults & param "baz" .~ ["quux"] + v <- asValue =<< getWith opts "http://httpbin.org/get" + print $ v ^? responseBody . key "args" . key "baz" + + + +main :: IO () +main = do + basic_asJSON + failing_asJSON_catch + either_asJSON + lens_aeson diff --git a/examples/SimpleSession.hs b/examples/SimpleSession.hs new file mode 100644 --- /dev/null +++ b/examples/SimpleSession.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Control.Lens +import Network.Wreq +import qualified Network.Wreq.Session as S + +main :: IO () +main = S.withSession $ \sess -> do + -- Our first request causes the httpbin.org server to set a cookie + -- in its response. + + S.get sess "http://httpbin.org/cookies/set?name=hi" + + -- The session value manages both cookies and HTTP connection reuse + -- for us. When we issue the second request, it should + -- transparently reuse the same connection, and also send the + -- cookies that we set during the first request. + + r2 <- S.post sess "http://httpbin.org/post" ["a" := (3 :: Int)] + + -- And here's where we verify that the cookie is still set on the + -- second request. + + print $ r2 ^. responseCookie "name" . cookieValue diff --git a/examples/UploadPaste.hs b/examples/UploadPaste.hs new file mode 100644 --- /dev/null +++ b/examples/UploadPaste.hs @@ -0,0 +1,168 @@ +-- upload a paste to lpaste.net +-- +-- This example is pretty beefy, as it does double duty. +-- +-- Perhaps the majority of it shows off some complex uses of the +-- optparse-applicative package. +-- +-- The POST portion is in the function named upload below. It uploads +-- an application/x-www-urlencoded form that creates a paste on the +-- Haskell community pastebin at . + +{-# 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 ()) diff --git a/examples/wreq-examples.cabal b/examples/wreq-examples.cabal new file mode 100644 --- /dev/null +++ b/examples/wreq-examples.cabal @@ -0,0 +1,64 @@ +name: wreq-examples +version: 0 +synopsis: wreq examples, not for installing +description: +homepage: https://github.com/bos/wreq +bug-reports: https://github.com/bos/wreq/issues +license: BSD3 +license-file: ../LICENSE.md +maintainer: bos@serpentine.com +category: Web +build-type: Simple +cabal-version: >=1.10 + +executable wreq-example-json-response + main-is: JsonResponse.hs + ghc-options: -Wall -fwarn-tabs -threaded + default-language: Haskell98 + + build-depends: + aeson, + base >= 4.5 && < 5, + containers, + ghc-prim, + lens, + lens-aeson, + text, + wreq + + +executable wreq-example-simple-session + main-is: SimpleSession.hs + ghc-options: -Wall -fwarn-tabs -threaded + default-language: Haskell98 + + build-depends: + base >= 4.5 && < 5, + lens, + wreq + +executable upload-paste + main-is: UploadPaste.hs + ghc-options: -Wall -fwarn-tabs -threaded + default-language: Haskell98 + + build-depends: + aeson, + ansi-wl-pprint >= 0.6.6, + base >= 4.5 && < 5, + bytestring, + filepath, + lens, + optparse-applicative >= 0.11, + mtl, + tagsoup, + text, + wreq + +source-repository head + type: git + location: https://github.com/bos/wreq + +source-repository head + type: mercurial + location: https://bitbucket.org/bos/wreq diff --git a/httpbin/HttpBin.hs b/httpbin/HttpBin.hs new file mode 100644 --- /dev/null +++ b/httpbin/HttpBin.hs @@ -0,0 +1,7 @@ +module Main (main) where + +import HttpBin.Server (serve) +import Snap.Http.Server.Config (commandLineConfig) + +main :: IO () +main = serve commandLineConfig diff --git a/httpbin/HttpBin/Server.hs b/httpbin/HttpBin/Server.hs new file mode 100644 --- /dev/null +++ b/httpbin/HttpBin/Server.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} + +-- TBD: basic-auth, gzip + +module HttpBin.Server (serve) where + +import Control.Applicative ((<$>)) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (Value(..), eitherDecode, object, toJSON) +import Data.Aeson.Encode.Pretty (Config(..), encodePretty') +import Data.ByteString.Char8 (pack) +import Data.CaseInsensitive (original) +import Data.Maybe (catMaybes, fromMaybe) +import Data.Monoid ((<>)) +import Data.Text.Encoding (decodeUtf8) +import Data.Text.Read (decimal) +import Data.Time.Clock (UTCTime(..)) +import Data.UUID (toASCIIBytes) +import Data.UUID.V4 (nextRandom) +import Snap.Core +import Snap.Http.Server as Snap +import Snap.Util.GZip (withCompression) +import System.PosixCompat.Time (epochTime) +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Char8 as B +import qualified Data.Map as Map +import qualified Data.Text.Lazy.Encoding as Lazy + +get = respond return + +post = respond $ \obj -> do + body <- readRequestBody 65536 + return $ obj <> [("data", toJSON (Lazy.decodeUtf8 body))] <> + case eitherDecode body of + Left _ -> [("json", Null)] + Right val -> [("json", val)] + +put = post + +delete = respond return + +status = do + val <- (fromMaybe 200 . rqIntParam "val") <$> getRequest + let code | val >= 200 && val <= 505 = val + | otherwise = 400 + modifyResponse $ setResponseCode code + +gzip = + localRequest (setHeader "Accept-Encoding" "gzip") . withCompression . + respond $ \obj -> return $ obj <> [("gzipped", Bool True)] + +deleteCookies = do + req <- getRequest + let expire name = Cookie name "" (Just mcfly) Nothing (Just "/") False False + mcfly = UTCTime (read "1985-10-26") 4800 + modifyResponse . foldr (.) id $ [ + addResponseCookie (expire name) . deleteResponseCookie name + | name <- Map.keys (rqQueryParams req) + ] + redirect "/cookies" + +setCookies = do + params <- rqQueryParams <$> getRequest + modifyResponse . foldr (.) id . map addResponseCookie $ + [Cookie k v Nothing Nothing (Just "/") False False + | (k,vs) <- Map.toList params, v <- vs] + redirect "/cookies" + +listCookies = do + cks <- rqCookies <$> getRequest + let cs = [(decodeUtf8 (cookieName c), + toJSON (decodeUtf8 (cookieValue c))) | c <- cks] + respond $ \obj -> return $ obj <> [("cookies", object cs)] + +redirect_ = do + req <- getRequest + let n = fromMaybe (-1::Int) . rqIntParam "n" $ req + prefix = B.reverse . B.dropWhile (/='/') . B.reverse . rqURI $ req + case undefined of + _| n > 1 -> redirect $ prefix <> pack (show (n-1)) + | n == 1 -> redirect "/get" + | otherwise -> modifyResponse $ setResponseCode 400 + +unauthorized = modifyResponse $ + setHeader "WWW-Authenticate" "Basic realm=\"Fake Realm\"" . + setResponseCode 401 + +simpleAuth expect = do + req <- getRequest + case expect req of + Nothing -> modifyResponse $ setResponseCode 400 + Just (expected, resp) -> + case getHeader "Authorization" (headers req) of + Nothing -> unauthorized + Just auth | auth == expected -> writeJSON $ + resp <> [("authenticated", Bool True)] + | otherwise -> unauthorized + +basicAuth = simpleAuth $ \req -> + case (rqParam "user" req, rqParam "pass" req) of + (Just [user], Just [passwd]) | not (':' `B.elem` user) -> + Just ("Basic " <> B64.encode (user <> ":" <> passwd), + [("user", toJSON (B.unpack user))]) + _ -> Nothing + +oauth2token = simpleAuth $ \req -> + case (rqParam "kind" req, rqParam "token" req) of + (Just [kind], Just [token]) -> + Just (kind <> " " <> token, + [("token", toJSON (B.unpack token))]) + _ -> Nothing + +cache = do + hdrs <- headers <$> getRequest + let cond = not . null . catMaybes . map (flip getHeader hdrs) $ + ["If-Modified-Since", "If-None-Match"] + if cond + then modifyResponse $ setResponseCode 304 + else do + now <- liftIO $ formatHttpTime =<< epochTime + uuid <- liftIO nextRandom + modifyResponse $ setHeader "Last-Modified" now . + setHeader "ETag" (toASCIIBytes uuid) + respond return + +rqIntParam name req = + case rqParam name req of + Just (str:_) -> case decimal (decodeUtf8 str) of + Right (n, "") -> Just n + _ -> Nothing + _ -> Nothing + +writeJSON obj = do + modifyResponse $ setContentType "application/json" + writeLBS . (<> "\n") . encodePretty' (Config 2 compare) . object $ obj + +respond act = do + req <- getRequest + let step m k v = Map.insert (decodeUtf8 k) (decodeUtf8 (head v)) m + params = Map.foldlWithKey' step Map.empty . + rqQueryParams $ req + wibble (k,v) = (decodeUtf8 (original k), decodeUtf8 v) + rqHeaders = headers req + hdrs = Map.fromList . map wibble . listHeaders $ rqHeaders + url = case getHeader "Host" rqHeaders of + Nothing -> [] + Just host -> [("url", toJSON . decodeUtf8 $ + "http://" <> host <> rqURI req)] + writeJSON =<< act ([ ("args", toJSON params) + , ("headers", toJSON hdrs) + , ("origin", toJSON . decodeUtf8 . rqRemoteAddr $ req) + ] <> url) + +meths ms h = methods ms (path "" h) +meth m h = method m (path "" h) + +serve mkConfig = do + cfg <- mkConfig + . setAccessLog ConfigNoLog + . setErrorLog ConfigNoLog + $ defaultConfig + httpServe cfg $ route [ + ("/get", meths [GET,HEAD] get) + , ("/post", meth POST post) + , ("/put", meth PUT put) + , ("/delete", meth DELETE delete) + , ("/redirect/:n", redirect_) + , ("/status/:val", status) + , ("/gzip", meths [GET,HEAD] gzip) + , ("/cookies/delete", meths [GET,HEAD] deleteCookies) + , ("/cookies/set", meths [GET,HEAD] setCookies) + , ("/cookies", meths [GET,HEAD] listCookies) + , ("/basic-auth/:user/:pass", meths [GET,HEAD] basicAuth) + , ("/oauth2/:kind/:token", meths [GET,HEAD] oauth2token) + , ("/cache", meths [GET,HEAD] cache) + ] diff --git a/tests/AWS.hs b/tests/AWS.hs new file mode 100644 --- /dev/null +++ b/tests/AWS.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +{- +A set of end to end Amazon Web Services (AWS) tests to make sure we +can access a number of AWS services that use various AWS request +formats. + +These tests help us guard against errors we may otherwise introduce +while refactoring or extending Wreq. The tests are not meant to +exercise the features of the respective AWS services exhaustively. + +** ASSUMPTIONS ** +To configure and run these tests you need an AWS account. We assume +that you are familiar with AWS concepts and the charging model. + +** ENABLING AWS TESTS ** +For now, enable AWS tests by setting the WREQ_AWS_ACCESS_KEY_ID +env variable per below. + +TODO| To enable AWS tests use the `-faws` flag as part of +TODO| $ cabal configure --enable-tests -faws ... +TODO| To capture code coverage information, add the `-fdeveloper` flag. + +** REQUIRED CLIENT CONFIGURATION ** +The tests require two environment variables: + $ /bin/env WREQ_AWS_ACCESS_KEY_ID='...' \ + WREQ_AWS_SECRET_ACCESS_KEY='...' \ + cabal test + +** CHARGES/COST ** +These tests may incur small amounts of AWS charges for the minimum +DynamoDB IOs per second they provision and for the messages sent to +AWS SQS and objects stored in S3. These charges consume only a tiny +fraction of the AWS free tier allowance (if not used up otherwise). + +** AWS REGIONS ** +Tests are executed against the AWS Region `us-west-2` by default. You +can change the region by setting the AWS_REGION environment variable +(e.g. /bin/env WREQ_AWS_REGION=eu-west-1 cabal test). + +In the case of S3, we translate 'us-east-1' to +'s3-external-1.amazonaws.com' denoting the Virginia (only) endpoint. +(see http://docs.aws.amazon.com/general/latest/gr/rande.html#s3_region). + +** AWS USER AND LEAST PRIVILEDGE POLICY ** +The file `tests/AWS/policy.json` contains the least priviledge "AWS +Identity and Access (IAM)" policy sufficient to run these tests. It is +a best security practice to run the tests using an AWS IAM user you +created specifically for this purpose. Use the AWS IAM Management +Console to create a new user, get the WREQ_AWS_ACCESS_KEY and +WREQ_AWS_SECRET_KEY for that user and apply the policy to the user to +limit its priviledges. + +**AVOID AWS RESOURCE NAME COLLISIONS IN CONCURRENT TESTS** +To run tests concurrently in same AWS account, set the environment +variable WREQ_AWS_TEST_PREFIX to a unique string for each test client +or machine. The default prefix used for all resources created +(e.g. DynamoDB tables, SQS queues, S3 buckets, etc.) is +`deleteWreqTest`. +-} + +module AWS (tests) where + +import Control.Exception as E (IOException, catch) +import Control.Lens +import Data.ByteString.Char8 as BS8 (pack) +import Data.IORef (newIORef) +import Network.Info (getNetworkInterfaces, mac, ipv6) +import Network.Wreq +import System.Environment (getEnv) +import Test.Framework (Test, testGroup) +import qualified AWS.DynamoDB (tests) +import qualified AWS.IAM (tests) +import qualified AWS.S3 (tests) +import qualified AWS.SQS (tests) + +tests :: IO Test +tests = do + -- TODO - use ... configure -faws ... in the future + -- but couldn't figure out (yet) how to get + -- a hold of the flag value in test code. + -- Workaround: for now, the presence of the + -- WREQ_AWS_ACCESS_KEY_ID + -- env variable enables the tests. + flag <- (getEnv "WREQ_AWS_ACCESS_KEY_ID" >> return True) `E.catch` + \(_::IOException) -> return False + tests0 flag + +tests0 :: Bool -> IO Test +tests0 False = + return $ testGroup "aws" [] -- skip AWS tests +tests0 True = do + region <- env "us-west-2" "WREQ_AWS_REGION" + key <- BS8.pack `fmap` getEnv "WREQ_AWS_ACCESS_KEY_ID" + secret <- BS8.pack `fmap` getEnv "WREQ_AWS_SECRET_ACCESS_KEY" + let baseopts = defaults & auth ?~ awsAuth AWSv4 key secret + prefix <- env "deleteWreqTest" "WREQ_AWS_TEST_PREFIX" + sqsTestState <- newIORef "missing" + iamTestState <- newIORef "missing" + uniq <- uniqueMachineId + let bucketname = prefix ++ uniq + return $ testGroup "aws" [ + AWS.DynamoDB.tests (prefix ++ "DynamoDB") region baseopts + , AWS.IAM.tests (prefix ++ "IAM") region baseopts iamTestState + , AWS.SQS.tests (prefix ++ "SQS") region baseopts sqsTestState + -- S3 buckets are global entities and the namespace shared among + -- all AWS customers. We will use a unique id based on the MAC + -- address of our client to avoid naming conflicts among different + -- developers running the tests. + , AWS.S3.tests bucketname region baseopts + --, AWS.S3.tests bucketname "us-east-1" baseopts -- classic + --, AWS.S3.tests bucketname "external-1" baseopts -- Virginia + ] + +-- return a globally unique machine id (uses a MAC address) +uniqueMachineId :: IO String +uniqueMachineId = do + nis <- getNetworkInterfaces + let lmac = filter ((/=) "00:00:00:00:00:00") $ map (show . mac) nis + -- travis-ci.org doesn't show mac addresses - use ipv6 (e.g. of venet0) + let lipv6 = filter (\s -> (s /= "0:0:0:0:0:0:0:0") && + (s /= "0:0:0:0:0:0:0:1") && + (s /= "fe80:0:0:0:0:0:0:1")) + $ map (show . ipv6) nis + if (null $ lmac ++ lipv6) + then error "FATAL: can't determine unique id automatically in this runtime env!" + else do + let uniq = concatMap (\c -> if c == ':' then [] else [c]) + $ head (lmac ++ lipv6) + return uniq + +env :: String -> String -> IO String +env defVal name = getEnv name `E.catch` \(_::IOException) -> return defVal diff --git a/tests/AWS/Aeson.hs b/tests/AWS/Aeson.hs new file mode 100644 --- /dev/null +++ b/tests/AWS/Aeson.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE FlexibleInstances, TypeFamilies, TypeSynonymInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module AWS.Aeson + ( + object + , string + , true + , (.=) + ) where + +import Data.Aeson hiding ((.=)) +import Data.Text (Text, pack) +import GHC.Exts +import qualified Data.Vector as Vector + +instance Num Value where + fromInteger = Number . fromInteger + +instance Fractional Value where + fromRational = Number . fromRational + +instance IsList Value where + type Item Value = Value + fromList = Array . Vector.fromList + toList (Array a) = Vector.toList a + toList _ = error "AWS.Aeson.toList" + +class Stringy a where + string :: a -> Value + +instance Stringy Text where + string = String + +instance Stringy String where + string = String . pack + +true :: Value +true = Bool True + +(.=) :: Text -> Value -> (Text, Value) +a .= b = (a,b) diff --git a/tests/AWS/DynamoDB.hs b/tests/AWS/DynamoDB.hs new file mode 100644 --- /dev/null +++ b/tests/AWS/DynamoDB.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE OverloadedLists, OverloadedStrings #-} +module AWS.DynamoDB (tests) where + +import AWS.Aeson +import Control.Concurrent (threadDelay) +import Control.Lens hiding ((.=)) +import Data.Aeson.Lens (key, _String, values, _Double) +import Data.Text as T (pack) +import Network.Wreq +import System.Timeout (timeout) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (assertBool, assertFailure) + +-- FIXME: retry create call in case the table is in DELETING state +-- from a previous test run (error 'Table already exists: ...'). For +-- now 'create' testcase and all others will fails. Rerun when ongoing +-- delete operation is complete. + +tests :: String -> String -> Options -> Test +tests prefix region baseopts = testGroup "dynamodb" [ + testCase "createTable" $ createTable prefix region baseopts + , testCase "listTables" $ listTables prefix region baseopts + , testCase "awaitTableActive" $ awaitTableActive prefix region baseopts + , testCase "putItem" $ putItem prefix region baseopts + , testCase "getItem" $ getItem prefix region baseopts + , testCase "deleteItem" $ deleteItem prefix region baseopts + , testCase "deleteTable" $ deleteTable prefix region baseopts -- call last + ] + +createTable :: String -> String -> Options -> IO () +createTable prefix region baseopts = do + let opts = baseopts + & header "X-Amz-Target" .~ ["DynamoDB_20120810.CreateTable"] + & header "Content-Type" .~ ["application/x-amz-json-1.0"] + r <- postWith opts (url region) $ + object [ + "TableName" .= string (prefix ++ tablename), + "KeySchema" .= [ + object ["AttributeName" .= "name", "KeyType" .= "HASH"], + object ["AttributeName" .= "age", "KeyType" .= "RANGE"] + ], + "AttributeDefinitions" .= [ + object ["AttributeName" .= "name", "AttributeType" .= "S"], + object ["AttributeName" .= "age", "AttributeType" .= "S"] + ], + "ProvisionedThroughput" .= object [ + "ReadCapacityUnits" .= 1, + "WriteCapacityUnits" .= 1 + ] + ] + assertBool "createTables 200" $ r ^. responseStatus . statusCode == 200 + assertBool "createTables OK" $ r ^. responseStatus . statusMessage == "OK" + assertBool "createTables status CREATING" $ + r ^. responseBody . key "TableDescription" . key "TableStatus" . _String == "CREATING" + assertBool "createTables no items in new table" $ + r ^? responseBody . key "TableDescription" . key "ItemCount" . _Double == Just 0 + +listTables :: String -> String -> Options -> IO () +listTables prefix region baseopts = do + let opts = baseopts + & header "X-Amz-Target" .~ ["DynamoDB_20120810.ListTables"] + & header "Content-Type" .~ ["application/x-amz-json-1.0"] + -- FIXME avoid limit to keep tests from failing if there are > tables? + r <- postWith opts (url region) $ object ["Limit" .= 100] + assertBool "listTables 200" $ r ^. responseStatus . statusCode == 200 + assertBool "listTables OK" $ r ^. responseStatus . statusMessage == "OK" + assertBool "listTables contains test table" $ + elem (T.pack $ prefix ++ tablename) + (r ^.. responseBody . key "TableNames" . values . _String) + +awaitTableActive :: String -> String -> Options -> IO () +awaitTableActive prefix region baseopts = do + let dur = 45 -- typically ACTIVE in 20s or less (us-west-2, Sept 2014) + res <- timeout (dur*1000*1000) check + case res of + Nothing -> + assertFailure $ "timeout: table not ACTIVE after " ++ show dur ++ "s" + Just () -> + return () -- PASS + where + check = do + let opts = baseopts + & header "X-Amz-Target" .~ ["DynamoDB_20120810.DescribeTable"] + & header "Content-Type" .~ ["application/x-amz-json-1.0"] + r <- postWith opts (url region) $ + object ["TableName" .= string (prefix ++ tablename)] + assertBool "awaitTableActive 200" $ r ^. responseStatus . statusCode == 200 + assertBool "awaitTableActive OK" $ r ^. responseStatus . statusMessage == "OK" + -- Prelude.putStr "." + case r ^. responseBody . key "Table" . key "TableStatus" . _String of + "ACTIVE" -> + return () + _ -> do + threadDelay $ 5*1000*1000 -- 5 sleep + check + +deleteTable :: String -> String -> Options -> IO () +deleteTable prefix region baseopts = do + let opts = baseopts + & header "X-Amz-Target" .~ ["DynamoDB_20120810.DeleteTable"] + & header "Content-Type" .~ ["application/x-amz-json-1.0"] + r <- postWith opts (url region) $ + object ["TableName" .= string (prefix ++ tablename)] + assertBool "deleteTable 200" $ r ^. responseStatus . statusCode == 200 + assertBool "deleteTable OK" $ r ^. responseStatus . statusMessage == "OK" + +putItem :: String -> String -> Options -> IO () +putItem prefix region baseopts = do + let opts = baseopts + & header "X-Amz-Target" .~ ["DynamoDB_20120810.PutItem"] + & header "Content-Type" .~ ["application/x-amz-json-1.0"] + r <- postWith opts (url region) $ + object [ + "TableName" .= string (prefix ++ tablename), + "Item" .= object [ + "name" .= object ["S" .= "someone"], + "age" .= object ["S" .= "whatever"], + "bar" .= object ["S" .= "baz"] + ] + ] + assertBool "putItem 200" $ r ^. responseStatus . statusCode == 200 + assertBool "putItem OK" $ r ^. responseStatus . statusMessage == "OK" + +getItem :: String -> String -> Options -> IO () +getItem prefix region baseopts = do + let opts = baseopts + & header "X-Amz-Target" .~ ["DynamoDB_20120810.GetItem"] + & header "Content-Type" .~ ["application/x-amz-json-1.0"] + r <- postWith opts (url region) $ + object [ + "TableName" .= string (prefix ++ tablename), + "Key" .= object [ + "name" .= object ["S" .= "someone"], + "age" .= object ["S" .= "whatever"] + ], + "AttributesToGet" .= ["bar"], + "ConsistentRead" .= true, + "ReturnConsumedCapacity" .= "TOTAL" + ] + assertBool "getItem 200" $ r ^. responseStatus . statusCode == 200 + assertBool "getItem OK" $ r ^. responseStatus . statusMessage == "OK" + assertBool "getItem baz value is bar" $ + r ^. responseBody . key "Item" . key "bar" . key "S" . _String == "baz" + +deleteItem :: String -> String -> Options -> IO () +deleteItem prefix region baseopts = do + let opts = baseopts + & header "X-Amz-Target" .~ ["DynamoDB_20120810.DeleteItem"] + & header "Content-Type" .~ ["application/x-amz-json-1.0"] + r <- postWith opts (url region) $ + object [ + "TableName" .= string (prefix ++ tablename), + "Key" .= object [ + "name" .= object ["S" .= "someone"], + "age" .= object ["S" .= "whatever"] + ], + "ReturnValues" .= "ALL_OLD" + ] + assertBool "getItem 200" $ r ^. responseStatus . statusCode == 200 + assertBool "getItem OK" $ r ^. responseStatus . statusMessage == "OK" + +url :: String -> String +url region = + "https://dynamodb." ++ region ++ ".amazonaws.com/" + +tablename :: String +tablename = + "test" diff --git a/tests/AWS/IAM.hs b/tests/AWS/IAM.hs new file mode 100644 --- /dev/null +++ b/tests/AWS/IAM.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE OverloadedLists, OverloadedStrings #-} +module AWS.IAM (tests) where + +import AWS.Aeson +import Control.Concurrent (threadDelay) +import Control.Lens hiding ((.=)) +import Data.Aeson.Encode (encode) +import Data.Aeson.Lens (key, _String, values) +import Data.IORef (IORef, readIORef, writeIORef) +import Data.Text as T (Text, pack, unpack, split) +import Data.Text.Lazy as LT (toStrict) +import Data.Text.Lazy.Encoding as E (decodeUtf8) +import Network.Wreq +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (assertBool) + +tests :: String -> String -> Options -> IORef String -> Test +tests prefix region baseopts iamTestState = testGroup "iam" [ + testCase "listUsers" $ listUsers prefix region baseopts + , testCase "createRole" $ createRole prefix region baseopts iamTestState + , testCase "listRoles" $ listRoles prefix region baseopts + , testCase "putRolePolicy" $ putRolePolicy prefix region baseopts + , testCase "stsAssumeRole" $ stsAssumeRole prefix region baseopts iamTestState + , testCase "deleteRolePolicy" $ deleteRolePolicy prefix region baseopts + , testCase "deleteRole" $ deleteRole prefix region baseopts + ] + +listUsers :: String -> String -> Options -> IO () +listUsers _prefix region baseopts = do + let opts = baseopts + & param "Action" .~ ["ListUsers"] + & param "Version" .~ ["2010-05-08"] + & header "Accept" .~ ["application/json"] + r <- getWith opts (iamUrl region) + assertBool "listUsers 200" $ r ^. responseStatus . statusCode == 200 + assertBool "listUsers OK" $ r ^. responseStatus . statusMessage == "OK" + +createRole :: String -> String -> Options -> IORef String -> IO () +createRole prefix region baseopts iamTestState = do + let opts = baseopts + & param "Action" .~ ["CreateRole"] + & param "Version" .~ ["2010-05-08"] + & param "RoleName" .~ [T.pack $ prefix ++ roleName] + & param "AssumeRolePolicyDocument" .~ [rolePolicyDoc] + & header "Accept" .~ ["application/json"] + r <- getWith opts (iamUrl region) + assertBool "createRole 200" $ r ^. responseStatus . statusCode == 200 + assertBool "createRole OK" $ r ^. responseStatus . statusMessage == "OK" + let [arn] = r ^.. responseBody . key "CreateRoleResponse" + . key "CreateRoleResult" + . key "Role" + . key "Arn" . _String + writeIORef iamTestState $ T.unpack arn + +putRolePolicy :: String -> String -> Options -> IO () +putRolePolicy prefix region baseopts = do + let opts = baseopts + & param "Action" .~ ["PutRolePolicy"] + & param "Version" .~ ["2010-05-08"] + & param "RoleName" .~ [T.pack $ prefix ++ roleName] + & param "PolicyName" .~ [testPolicyName] + & param "PolicyDocument" .~ [policyDoc] + & header "Accept" .~ ["application/json"] + r <- getWith opts (iamUrl region) + assertBool "putRolePolicy 200" $ r ^. responseStatus . statusCode == 200 + assertBool "putRolePolicy OK" $ r ^. responseStatus . statusMessage == "OK" + threadDelay $ 30*1000*1000 -- 30 sleep, allow change to propagate to region + +deleteRolePolicy :: String -> String -> Options -> IO () +deleteRolePolicy prefix region baseopts = do + let opts = baseopts + & param "Action" .~ ["DeleteRolePolicy"] + & param "Version" .~ ["2010-05-08"] + & param "RoleName" .~ [T.pack $ prefix ++ roleName] + & param "PolicyName" .~ [testPolicyName] + & param "PolicyDocument" .~ [policyDoc] + & header "Accept" .~ ["application/json"] + r <- getWith opts (iamUrl region) + assertBool "deleteRolePolicy 200" $ r ^. responseStatus . statusCode == 200 + assertBool "deleteRolePolicy OK" $ r ^. responseStatus . statusMessage == "OK" + +deleteRole :: String -> String -> Options -> IO () +deleteRole prefix region baseopts = do + let opts = baseopts + & param "Action" .~ ["DeleteRole"] + & param "Version" .~ ["2010-05-08"] + & param "RoleName" .~ [T.pack $ prefix ++ roleName] + & header "Accept" .~ ["application/json"] + r <- getWith opts (iamUrl region) + assertBool "deleteRole 200" $ r ^. responseStatus . statusCode == 200 + assertBool "deleteRole OK" $ r ^. responseStatus . statusMessage == "OK" + +listRoles :: String -> String -> Options -> IO () +listRoles prefix region baseopts = do + let opts = baseopts + & param "Action" .~ ["ListRoles"] + & param "Version" .~ ["2010-05-08"] + & header "Accept" .~ ["application/json"] + r <- getWith opts (iamUrl region) + assertBool "listRoles 200" $ r ^. responseStatus . statusCode == 200 + assertBool "listRoles OK" $ r ^. responseStatus . statusMessage == "OK" + let arns = r ^.. responseBody . key "ListRolesResponse" . + key "ListRolesResult" . + key "Roles" . + values . + key "Arn" . _String + -- arns are of form: "arn:aws:iam:::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" .= ["*"] + ] + ] + ] diff --git a/tests/AWS/S3.hs b/tests/AWS/S3.hs new file mode 100644 --- /dev/null +++ b/tests/AWS/S3.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE OverloadedLists, OverloadedStrings #-} +module AWS.S3 (tests) where + +import AWS.Aeson +import Control.Lens hiding ((.=)) +import Data.Char (toLower) +import Data.Monoid ((<>)) +import Network.Wreq +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (assertBool) +import qualified Data.ByteString.Char8 as BS8 (ByteString, pack) + +-- FIXME: retry create call in case we get the S3 specific "A +-- conflicting conditional operation is currently in progress against +-- this resource. Please try again." error from a previous test run +-- that is still deleting the test bucket. For now the 'create' +-- testcase and all others will fails. + +tests :: String -> String -> Options -> Test +tests prefix region baseopts = let + lowerPrefix = map toLower prefix + t = \(mkUrl, label) -> + testGroup (region ++ "_" ++ label) [ + testCase "createBucket" $ + createBucket mkUrl lowerPrefix region baseopts + , testCase "putObjectJSON" $ + putObjectJSON mkUrl lowerPrefix region baseopts + , testCase "getObjectJSON" $ + getObjectJSON mkUrl lowerPrefix region baseopts + , testCase "deleteObjectJSON" $ + deleteObjectJSON mkUrl lowerPrefix region baseopts + , testCase "deleteBucket" $ + deleteBucket mkUrl lowerPrefix region baseopts -- call last + ] + in testGroup "s3" $ map t [ (urlPath, "bucket-in-path") + , (urlVHost, "bucket-in-vhost") ] + +-- Path based bucket access +createBucket :: MkURL -> String -> String -> Options -> IO () +createBucket url prefix region baseopts = do + r <- putWith baseopts (url region prefix "testbucket") $ + locationConstraint region + assertBool "createBucket 200" $ r ^. responseStatus . statusCode == 200 + assertBool "createBucket OK" $ r ^. responseStatus . statusMessage == "OK" + +deleteBucket :: MkURL -> String -> String -> Options -> IO () +deleteBucket url prefix region baseopts = do + r <- deleteWith baseopts (url region prefix "testbucket") + assertBool "deleteBucket 204 - no content" $ + r ^. responseStatus . statusCode == 204 + assertBool "deleteBucket OK" $ + r ^. responseStatus . statusMessage == "No Content" + +putObjectJSON :: MkURL -> String -> String -> Options -> IO () +putObjectJSON url prefix region baseopts = do + -- S3 write object, incl. correct content-type + r <- putWith baseopts (url region prefix "testbucket" ++ "blabla-json") $ + object ["test" .= "key", "testdata" .= [1, 2, 3]] + assertBool "putObjectJSON 200" $ r ^. responseStatus . statusCode == 200 + assertBool "putObjectJSON OK" $ r ^. responseStatus . statusMessage == "OK" + +getObjectJSON :: MkURL -> String -> String -> Options -> IO () +getObjectJSON url prefix region baseopts = do + r <- getWith baseopts (url region prefix "testbucket" ++ "blabla-json") + assertBool "getObjectJSON 200" $ r ^. responseStatus . statusCode == 200 + assertBool "getObjectJSON OK" $ r ^. responseStatus . statusMessage == "OK" + +deleteObjectJSON :: MkURL -> String -> String -> Options -> IO () +deleteObjectJSON url prefix region baseopts = do + r <- deleteWith baseopts (url region prefix "testbucket" ++ "blabla-json") + assertBool "deleteObjectJSON 204 - no content" $ + r ^. responseStatus . statusCode == 204 + assertBool "deleteObjectJSON OK" $ + r ^. responseStatus . statusMessage == "No Content" + +type MkURL = String -> String -> String -> String --region prefix bucket + +-- see http://docs.aws.amazon.com/general/latest/gr/rande.html#s3_region +urlPath :: MkURL +urlPath "us-east-1" prefix bucketname = + "https://s3.amazonaws.com/" ++ prefix ++ bucketname ++ "/"-- uses 'classic' +urlPath region prefix bucketname = + "https://s3-" ++ region ++ ".amazonaws.com/" ++ prefix ++ bucketname ++ "/" + +-- Generate a VirtualHost style URL +urlVHost :: MkURL +urlVHost "us-east-1" prefix bucketname = + "https://" ++ prefix ++ bucketname ++ ".s3.amazonaws.com/" +urlVHost region prefix bucketname = + "https://" ++ prefix ++ bucketname ++ ".s3-" ++ region ++ ".amazonaws.com/" + +-- see http://docs.aws.amazon.com/AmazonS3/latest/API/RESTBucketPUT.html +-- and http://docs.aws.amazon.com/general/latest/gr/rande.html#s3_region +locationConstraint :: String -> BS8.ByteString +locationConstraint "us-east-1" = "" -- no loc needed for classic and Virginia +locationConstraint "external-1" = "" -- no loc needed for Virginia +locationConstraint region = "" <> BS8.pack region <> "" diff --git a/tests/AWS/SQS.hs b/tests/AWS/SQS.hs new file mode 100644 --- /dev/null +++ b/tests/AWS/SQS.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE OverloadedStrings #-} +module AWS.SQS (tests) where + +import Control.Lens +import Data.Aeson.Lens (key, _String, values) +import Data.IORef (IORef, readIORef, writeIORef) +import Data.Text as T (Text, pack, unpack, split) +import Network.Wreq +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (assertBool) + +-- FIXME: retry create call in case we get the SQS specific "wait 1 +-- min after delete" error from a previous test run. For now the +-- 'create' testcase and all others will fails. Rerun after awaiting +-- the SQS 1 min window. + +tests :: String -> String -> Options -> IORef String -> Test +tests prefix region baseopts sqsTestState = testGroup "sqs" [ + testCase "createQueue" $ createQueue prefix region baseopts sqsTestState + , testCase "listQueues" $ listQueues prefix region baseopts + , testCase "sendMessage" $ sendMessage prefix region baseopts sqsTestState + , testCase "receiveMessage" $ receiveMessage prefix region baseopts sqsTestState + , testCase "deleteQueue" $ deleteQueue prefix region baseopts sqsTestState + ] + +createQueue :: String -> String -> Options -> IORef String -> IO () +createQueue prefix region baseopts sqsTestState = do + let opts = baseopts + & param "Action" .~ ["CreateQueue"] + & param "QueueName" .~ [T.pack $ prefix ++ queuename] + & param "Version" .~ ["2009-02-01"] + & header "Accept" .~ ["application/json"] + r <- getWith opts (url region) + assertBool "listQueues 200" $ r ^. responseStatus . statusCode == 200 + assertBool "listQueues OK" $ r ^. responseStatus . statusMessage == "OK" + let qurl = r ^. responseBody . key "CreateQueueResponse" + . key "CreateQueueResult" + . key "QueueUrl" + . _String + writeIORef sqsTestState $ acctFromQueueUrl qurl + +listQueues :: String -> String -> Options -> IO () +listQueues prefix region baseopts = do + let opts = baseopts + & param "Action" .~ ["ListQueues"] + & param "Version" .~ ["2009-02-01"] + & header "Accept" .~ ["application/json"] + r <- getWith opts (url region) + assertBool "listQueues 200" $ r ^. responseStatus . statusCode == 200 + assertBool "listQueues OK" $ r ^. responseStatus . statusMessage == "OK" + let qurls = r ^.. responseBody . key "ListQueuesResponse" . + key "ListQueuesResult" . + key "queueUrls" . + values . _String + -- url of form: https://sqs..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" diff --git a/tests/DocTests.hs b/tests/DocTests.hs new file mode 100644 --- /dev/null +++ b/tests/DocTests.hs @@ -0,0 +1,47 @@ +-- I don't know who originally wrote this, but I picked it up from +-- Edward Kmett's folds package, and subsequently modified it. + +module Main where + +import Build_doctest (deps) +import Control.Applicative ((<$>), (<*>)) +import Control.Monad (filterM) +import Data.List (isPrefixOf, isSuffixOf) +import System.Directory +-- import System.Environment (getArgs) +import System.FilePath (()) +import Test.DocTest (doctest) + +main :: IO () +main = do + -- doctest chokes on the command line args that cabal test passes in + -- args <- getArgs + let args = [] + srcs <- getSources + dist <- getDistDir + doctest $ args ++ [ "-i." + , "-i" ++ dist ++ "/build/autogen" + , "-optP-include" + , "-optP" ++ dist ++ "/build/autogen/cabal_macros.h" + , "-hide-all-packages" + ] ++ map ("-package="++) deps ++ srcs + +getSources :: IO [FilePath] +getSources = filter (isSuffixOf ".hs") <$> go "Network" + where + go dir = do + (dirs, files) <- getFilesAndDirectories dir + (files ++) . concat <$> mapM go dirs + +getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) +getFilesAndDirectories dir = do + c <- map (dir ) . filter (`notElem` ["..", "."]) <$> + getDirectoryContents dir + (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c + +getDistDir :: IO FilePath +getDistDir = do + names <- getDirectoryContents "dist" + return $ case filter ("dist-sandbox-" `isPrefixOf`) names of + (d:_) -> "dist/" ++ d + _ -> "dist" diff --git a/tests/Properties/Store.hs b/tests/Properties/Store.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/Store.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE RecordWildCards #-} + +module Properties.Store + ( + tests + ) where + +import Data.Functor ((<$>)) +import Data.Hashable (Hashable) +import Data.List (foldl', sort, sortBy) +import Data.Maybe (listToMaybe) +import Data.Ord (comparing) +import Network.Wreq.Cache.Store as S +import Test.Framework (Test) +import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck (Positive(..), Small(..)) + +data StoreModel k v = StoreModel { + smCap :: Int + , smGen :: Int + , smSize :: Int + , smList :: [(k,v,Int)] + } deriving (Show) + +emptySM :: Int -> StoreModel k v +emptySM n = StoreModel n 0 0 [] + +insertSM :: Eq k => k -> v -> StoreModel k v -> StoreModel k v +insertSM k v sm@StoreModel{..} + | smSize < smCap || present = + sm { smGen = smGen + 1 + , smSize = if present then smSize else smSize + 1 + , smList = (k,v,smGen) : [x | x@(kk,_,_) <- smList, kk /= k] + } + | otherwise = + sm { smGen = smGen + 1 + , smList = (k,v,smGen) : tail (sortBy (comparing $ \(_,_,g) -> g) smList) + } + where present = any (\(kk,_,_) -> k == kk) smList + +lookupSM :: Eq k => k -> StoreModel k v -> Maybe (v, StoreModel k v) +lookupSM k sm@StoreModel{..} = listToMaybe + [(v, sm') | (kk,v,_) <- smList, k == kk] + where sm' = sm { smGen = smGen + 1 + , smList = [(kk,v,if kk == k then smGen else g) + | (kk,v,g) <- smList] + } + +fromListSM :: Eq k => Int -> [(k,v)] -> StoreModel k v +fromListSM = foldl' (flip (uncurry insertSM)) . emptySM + +toListSM :: StoreModel k v -> [(k,v)] +toListSM sm = [(k,v) | (k,v,_) <- smList sm] + +unS :: (Ord k, Hashable k, Ord v) => S.Store k v -> [(k,v)] +unS = sort . S.toList + +unM :: (Ord k, Ord v) => StoreModel k v -> [(k,v)] +unM = sort . toListSM + +type N = Positive (Small Int) + +unN :: N -> Int +unN (Positive (Small n)) = n + +t_fromList :: N -> [(Char,Char)] -> Bool +t_fromList n xs = unS (S.fromList (unN n) xs) == unM (fromListSM (unN n) xs) + +t_lookup :: N -> Char -> [(Char,Char)] -> Bool +t_lookup n k xs = (fmap unS <$> S.lookup k s) == (fmap unM <$> lookupSM k m) + where + s = S.fromList (unN n) xs + m = fromListSM (unN n) xs + +t_lookup1 :: N -> Char -> Char -> [(Char, Char)] -> Bool +t_lookup1 n k v xs = t_lookup n k ((k,v):xs) + +tests :: [Test] +tests = [ + testProperty "t_fromList" t_fromList + , testProperty "t_lookup" t_lookup + , testProperty "t_lookup1" t_lookup1 + ] diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE CPP #-} + +module Main (main) where + +import Test.Framework (testGroup) +import UnitTests (testWith) +import qualified Properties.Store + +#if defined(AWS_TESTS) +import qualified AWS (tests) +#endif + +main :: IO () +main = do +#if defined(AWS_TESTS) + awsTests <- AWS.tests +#else + let awsTests = testGroup "aws" [] +#endif + testWith [ + testGroup "store" Properties.Store.tests + , awsTests + ] diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests.hs @@ -0,0 +1,393 @@ +{-# LANGUAGE OverloadedStrings, RankNTypes, RecordWildCards, + ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-missing-signatures + -fno-warn-unused-binds #-} + +module UnitTests (testWith) where + +import Control.Applicative ((<$>)) +import Control.Concurrent (forkIO, killThread) +import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) +import Control.Exception (Exception, toException) +import Control.Lens ((^.), (^?), (.~), (?~), (&)) +import Control.Monad (unless, void) +import Data.Aeson +import Data.Aeson.Lens (key) +import Data.ByteString (ByteString) +import Data.Char (toUpper) +import Data.Maybe (isJust) +import Data.Monoid ((<>)) +import HttpBin.Server (serve) +import Network.HTTP.Client (HttpException(..)) +import Network.HTTP.Types.Status (Status(Status), status200, status401) +import Network.HTTP.Types.Version (http11) +import Network.Wreq hiding + (get, post, head_, put, options, delete, + getWith, postWith, headWith, putWith, optionsWith, deleteWith) +import Network.Wreq.Lens +import Network.Wreq.Types (Postable, Putable) +import Snap.Http.Server.Config +import System.IO (hClose, hPutStr) +import System.IO.Temp (withSystemTempFile) +import Test.Framework (Test, defaultMain, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (assertBool, assertEqual, assertFailure) +import qualified Control.Exception as E +import qualified Data.Text as T +import qualified Network.Wreq.Session as Session +import qualified Data.ByteString.Lazy as L +import qualified Network.Wreq as Wreq + +data Verb = Verb { + get :: String -> IO (Response L.ByteString) + , getWith :: Options -> String -> IO (Response L.ByteString) + , post :: Postable a => String -> a -> IO (Response L.ByteString) + , postWith :: Postable a => Options -> String -> a + -> IO (Response L.ByteString) + , head_ :: String -> IO (Response ()) + , headWith :: Options -> String -> IO (Response ()) + , put :: Putable a => String -> a -> IO (Response L.ByteString) + , putWith :: Putable a => Options -> String -> a -> IO (Response L.ByteString) + , options :: String -> IO (Response ()) + , optionsWith :: Options -> String -> IO (Response ()) + , delete :: String -> IO (Response L.ByteString) + , deleteWith :: Options -> String -> IO (Response L.ByteString) + } + +basic :: Verb +basic = Verb { get = Wreq.get, getWith = Wreq.getWith, post = Wreq.post + , postWith = Wreq.postWith, head_ = Wreq.head_ + , headWith = Wreq.headWith, put = Wreq.put + , putWith = Wreq.putWith, options = Wreq.options + , optionsWith = Wreq.optionsWith, delete = Wreq.delete + , deleteWith = Wreq.deleteWith } + +session :: Session.Session -> Verb +session s = Verb { get = Session.get s + , getWith = flip Session.getWith s + , post = Session.post s + , postWith = flip Session.postWith s + , head_ = Session.head_ s + , headWith = flip Session.headWith s + , put = Session.put s + , putWith = flip Session.putWith s + , options = Session.options s + , optionsWith = flip Session.optionsWith s + , delete = Session.delete s + , deleteWith = flip Session.deleteWith s } + +basicGet Verb{..} site = do + r <- get (site "/get") + assertBool "GET request has User-Agent header" $ + isJust (r ^. responseBody ^? key "headers" . key "User-Agent") + -- test the various lenses + assertEqual "GET succeeds" status200 (r ^. responseStatus) + assertEqual "GET succeeds 200" 200 (r ^. responseStatus . statusCode) + assertEqual "GET succeeds OK" "OK" (r ^. responseStatus . statusMessage) + assertEqual "GET response has HTTP/1.1 version" http11 (r ^. responseVersion) + assertBool "GET response has Content-Type header" $ + isJust (r ^? responseHeader "Content-Type") + assertBool "GET response has Date header" $ + isJust (lookup "Date" <$> r ^? responseHeaders) + +basicPost Verb{..} site = do + r <- post (site "/post") ("wibble" :: ByteString) >>= asValue + let body = r ^. responseBody + assertEqual "POST succeeds" status200 (r ^. responseStatus) + assertEqual "POST echoes input" (Just "wibble") (body ^? key "data") + assertEqual "POST is binary" (Just "application/octet-stream") + (body ^? key "headers" . key "Content-Type") + +multipartPost Verb{..} site = + withSystemTempFile "foo.html" $ \name handle -> do + hPutStr handle " 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 <>) + ] + ] diff --git a/wreq-sb.cabal b/wreq-sb.cabal new file mode 100644 --- /dev/null +++ b/wreq-sb.cabal @@ -0,0 +1,219 @@ +name: wreq-sb +version: 0.4.0.0 +synopsis: An easy-to-use HTTP client library. +description: + . + A web client library that is designed for ease of use. + . + Tutorial: + . + Features include: + . + * Simple but powerful `lens`-based API + . + * A solid test suite, and built on reliable libraries like + http-client and lens + . + * Session handling includes connection keep-alive and pooling, and + cookie persistence + . + * Automatic response body decompression + . + * Powerful multipart form and file upload handling + . + * Support for JSON requests and responses, including navigation of + schema-less responses + . + * Basic and OAuth2 bearer authentication + . + * Early TLS support via the tls package +homepage: http://www.serpentine.com/wreq +bug-reports: https://github.com/stackbuilders/wreq/issues +license: BSD3 +license-file: LICENSE.md +author: Bryan O'Sullivan +maintainer: bos@serpentine.com +copyright: 2014 Bryan O'Sullivan +category: Web +build-type: Custom +cabal-version: >=1.10 +extra-source-files: + README.md + TODO.md + changelog.md + examples/*.cabal + examples/*.hs + www/*.css + www/*.md + www/Makefile + +-- disable doctests with -f-doctest +flag doctest + description: enable doctest tests + default: True + manual: True + +-- enable aws with -faws +flag aws + description: enable AWS tests + default: False + manual: True + +-- enable httpbin with -fhttpbin +flag httpbin + description: enable httpbin test daemon + default: False + manual: True + +flag developer + description: build in developer mode + default: False + manual: True + +library + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields + default-language: Haskell98 + + exposed-modules: + Network.Wreq + Network.Wreq.Cache + Network.Wreq.Cache.Store + Network.Wreq.Lens + Network.Wreq.Session + Network.Wreq.Types + other-modules: + Network.Wreq.Internal + Network.Wreq.Internal.AWS + Network.Wreq.Internal.Lens + Network.Wreq.Internal.Link + Network.Wreq.Internal.OAuth1 + Network.Wreq.Internal.Types + Network.Wreq.Lens.Machinery + Network.Wreq.Lens.TH + Paths_wreq_sb + build-depends: + psqueues >= 0.2, + aeson >= 0.7.0.3, + attoparsec >= 0.11.1.0, + authenticate-oauth == 1.5.*, + base >= 4.5 && < 5, + base16-bytestring, + byteable, + bytestring >= 0.9, + case-insensitive, + containers, + cryptohash, + exceptions >= 0.5, + ghc-prim, + hashable, + http-client >= 0.4.6, + http-client-tls >= 0.2, + http-types >= 0.8, + lens >= 4.5, + lens-aeson, + mime-types, + old-locale, + template-haskell, + text, + time, + unordered-containers + +-- A convenient server for testing locally, or if httpbin.org is down. +executable httpbin + hs-source-dirs: httpbin + ghc-options: -Wall -fwarn-tabs -threaded -rtsopts + default-language: Haskell98 + main-is: HttpBin.hs + other-modules: HttpBin.Server + + if !flag(httpbin) + buildable: False + else + build-depends: + aeson >= 0.7, + aeson-pretty >= 0.7.1, + base >= 4.5 && < 5, + base64-bytestring, + bytestring, + case-insensitive, + containers, + snap-core, + snap-server >= 0.9.4.4, + text, + time, + transformers, + unix-compat, + uuid + +test-suite tests + type: exitcode-stdio-1.0 + hs-source-dirs: httpbin tests + main-is: Tests.hs + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -threaded -rtsopts + default-language: Haskell98 + other-modules: + Properties.Store + UnitTests + + if flag(aws) + cpp-options: -DAWS_TESTS + other-modules: + AWS + AWS.Aeson + AWS.DynamoDB + AWS.IAM + AWS.S3 + AWS.SQS + + if flag(aws) + build-depends: base >= 4.7 && < 5 + + build-depends: + HUnit, + QuickCheck >= 2.7, + aeson, + aeson-pretty >= 0.7.1, + base >= 4.5 && < 5, + base64-bytestring, + bytestring, + case-insensitive, + containers, + hashable, + http-client, + http-types, + lens, + lens-aeson, + network-info, + snap-core, + snap-server >= 0.9.4.4, + temporary, + test-framework, + test-framework-hunit, + test-framework-quickcheck2, + text, + time, + transformers, + unix-compat, + uuid, + vector, + wreq-sb + +test-suite doctest + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: DocTests.hs + ghc-options: -Wall -fwarn-tabs -threaded + default-language: Haskell98 + + if !flag(doctest) + buildable: False + else + build-depends: + base >= 4.5 && < 5, + directory, + doctest, + filepath + +source-repository head + type: git + location: https://github.com/stackbuilders/wreq diff --git a/www/Makefile b/www/Makefile new file mode 100644 --- /dev/null +++ b/www/Makefile @@ -0,0 +1,23 @@ +bootstrap := bootstrap-3.1.1-dist + +files := index.html tutorial.html +deps = bootstrap-custom.css background.jpg +install := $(files) $(deps) +destdir := $(HOME)/public_html/wreq + +all: $(files) + +install: $(files) + -mkdir -p $(destdir) + cp -a $(install) $(destdir) + cp -a $(bootstrap) $(destdir) + -chcon -R -t httpd_sys_content_t $(destdir) + +%.html: %.md template.html $(deps) + pandoc $< -o $@ --smart --template template.html \ + --css $(bootstrap)/css/bootstrap.css \ + --css bootstrap-custom.css \ + --toc --toc-depth 2 + +clean: + -rm -f $(files) diff --git a/www/bootstrap-custom.css b/www/bootstrap-custom.css new file mode 100644 --- /dev/null +++ b/www/bootstrap-custom.css @@ -0,0 +1,59 @@ +html { + position: relative; + min-height: 100%; +} +body { + /* Margin bottom by footer height */ + margin-bottom: 80px; +} +#footer { + position: absolute; + bottom: 0; + width: 100%; + /* Set the fixed height of the footer here */ + height: 80px; + background-color: #f5f5f5; +} + +a > code { color: #02d; } +a > code:hover { color: #44f; } +div.nav.bs-docs-sidenav > ul { list-style-type: none; } +div.nav.bs-docs-sidenav > ul > li > ul { list-style-type: none; } + +h1, h2, h3, h4 { + font-family: 'Roboto', 'sans-serif'; + margin-top: 40px; +} +p, div { + font-family: 'Roboto Slab', 'sans-serif'; +} + +.container .text-muted { + margin: 10px 0; +} + +.jumboback > .navbar { + background: rgba(0,0,0,0.4); + margin-bottom: 0; + text-shadow: none; + border: 0; + border-radius: 0; +} + +.jumboback > .navbar > a, .jumboback > .navbar > ul > li > a { + color: white; +} + +.jumboback > .jumbotron { + background: transparent; +} + +.jumboback { + background-image: url(background.jpg); + margin-bottom: 20px; + background-position: -20% 25%; + background-size: cover; + background-repeat: no-repeat; + color: white; + text-shadow: black 0em 0em 0.8em; +} diff --git a/www/index.md b/www/index.md new file mode 100644 --- /dev/null +++ b/www/index.md @@ -0,0 +1,150 @@ +% 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/). diff --git a/www/tutorial.md b/www/tutorial.md new file mode 100644 --- /dev/null +++ b/www/tutorial.md @@ -0,0 +1,596 @@ +% A wreq tutorial +% Learn how to write web clients. We start easy, then ramp up the power. + +# Installation + +To use the `wreq` package, simply use `cabal`, the standard Haskell +package management command. + +~~~~ +cabal update +cabal install -j --disable-tests wreq +~~~~ + +Depending on how many prerequisites you already have installed, and +what your Cabal configuration looks like, the build may take a few +minutes: a few seconds for `wreq`, and the rest for its dependencies. + + +# Interactive usage + +We'll run our examples interactively via the `ghci` shell. + +~~~~ +$ ghci +~~~~ + +To start using `wreq`, we import the +[`Network.Wreq`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html) +module. + +~~~~ {.haskell} +ghci> import Network.Wreq +ghci> r <- get "http://httpbin.org/get" +ghci> :type r +r :: Response ByteString +~~~~ + +The variable `r` above is the +[`Response`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#t:Response) +from the server. + + +## Working with string-like types + +Complex Haskell libraries and applications have to deal fluently with +Haskell's three main string types: `String` ("legacy"), `Text`, and +`ByteString` (mostly used for binary data, sometimes ASCII). + +To write string literals without having to always provide a conversion +function, we use the `OverloadedStrings` language extension. + +Throughout the rest of this tutorial, we'll assume that you have +enabled `OverloadedStrings` in `ghci`: + +~~~~ {.haskell} +ghci> :set -XOverloadedStrings +~~~~ + +If you're using `wreq` from a Haskell source file, put a pragma at the +top of your file: + +~~~~ {.haskell} +{-# LANGUAGE OverloadedStrings #-} +~~~~ + + +# A quick lens backgrounder + +The `wreq` package makes heavy use of Edward Kmett's +[`lens`](https://lens.github.io/) package to provide a clean, +consistent API. + +~~~~ {.haskell} +ghci> import Control.Lens +~~~~ + +While `lens` has a vast surface area, the portion that you must +understand in order to productively use `wreq` is tiny. + +A lens provides a way to focus on a portion of a Haskell value. For +example, the `Response` type has a +[`responseStatus`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#v:responseStatus) +lens, which focuses on the status information returned by the server. + +~~~~ {.haskell} +ghci> r ^. responseStatus +Status {statusCode = 200, statusMessage = "OK"} +~~~~ + +The +[`^.`](http://hackage.haskell.org/package/lens/docs/Control-Lens-Getter.html#v:-94-.) +operator takes a value as its first argument, a lens as its second, +and returns the portion of the value focused on by the lens. + +We compose lenses using function composition, which allows us to +easily focus on part of a deeply nested structure. + +~~~~ {.haskell} +ghci> r ^. responseStatus . statusCode +200 +~~~~ + +We'll have more to say about lenses as this tutorial proceeds. + + +# Changing default behaviours + +While +[`get`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#v:get) + is convenient and easy to use, there's a lot more power +available to us. + +For example, if we want to add parameters to the query string of a +URL, we will use the +[`getWith`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#v:getWith) +function. The `*With` family of functions all accept an +[`Options`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#t:Options) +parameter that allow changes from the library's default behaviours. + +~~~~ {.haskell} +ghci> import Data.Aeson.Lens (_String, key) +ghci> let opts = defaults & param "foo" .~ ["bar", "quux"] +ghci> r <- getWith opts "http://httpbin.org/get" +ghci> r ^. responseBody . key "url" . _String +"http://httpbin.org/get?foo=bar&foo=quux" +~~~~ + +(We'll talk more about `key` and `_String` below.) + +The default parameters for all queries is represented by the variable +[`defaults`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#v:defaults). +(In fact, `get` is defined simply as `getWith defaults`.) + +Here's where we get to learn a little more about lenses. + +In addition to *getting* a value from a nested structure, we can also +*set* (edit) a value within a nested structure, which makes an +identical copy of the structure except for the portion we want to +modify. + +The `&` operator is just function application with its operands +reversed, so the function is on the right and its parameter is on the +left. + +~~~~ {.haskell} +parameter & functionToApply +~~~~ + +The +[`.~`](http://hackage.haskell.org/package/lens/docs/Control-Lens-Setter.html#v:.-126-) + operator turns a lens into a setter function, with the lens +on the left and the new value on the right. + +~~~~ {.haskell} +param "foo" .~ ["bar", "quux"] +~~~~ + +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.