diff --git a/Network/Wreq/Cache.hs b/Network/Wreq/Cache.hs --- a/Network/Wreq/Cache.hs +++ b/Network/Wreq/Cache.hs @@ -1,5 +1,5 @@ {-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, - OverloadedStrings, RecordWildCards #-} + FlexibleContexts, OverloadedStrings, RecordWildCards #-} module Network.Wreq.Cache ( @@ -29,11 +29,16 @@ import Network.Wreq.Internal.Lens import Network.Wreq.Internal.Types import Network.Wreq.Lens -import System.Locale (defaultTimeLocale) import qualified Data.ByteString.Char8 as B import qualified Data.HashSet as HashSet import qualified Data.IntSet as IntSet 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') diff --git a/Network/Wreq/Cache/Store.hs b/Network/Wreq/Cache/Store.hs --- a/Network/Wreq/Cache/Store.hs +++ b/Network/Wreq/Cache/Store.hs @@ -15,8 +15,7 @@ import Data.Int (Int64) import Data.List (foldl') import Prelude hiding (lookup, map) -import qualified Data.HashMap.Lazy as HM -import qualified Data.PSQueue as PSQ +import qualified Data.HashPSQ as HashPSQ type Epoch = Int64 @@ -24,8 +23,7 @@ capacity :: {-# UNPACK #-} !Int , size :: {-# UNPACK #-} !Int , epoch :: {-# UNPACK #-} !Epoch - , lru :: !(PSQ.PSQ k Epoch) - , map :: !(HM.HashMap k v) + , psq :: !(HashPSQ.HashPSQ k Epoch v) } instance (Show k, Show v, Ord k, Hashable k) => Show (Store k v) where @@ -34,43 +32,29 @@ empty :: Ord k => Int -> Store k v empty cap | cap <= 0 = error "empty: invalid capacity" - | otherwise = Store cap 0 0 PSQ.empty HM.empty + | otherwise = Store cap 0 0 HashPSQ.empty {-# INLINABLE empty #-} insert :: (Ord k, Hashable k) => k -> v -> Store k v -> Store k v -insert k v st@Store{..} - | size < capacity || present = - st { size = if present then size else size + 1 - , epoch = epoch + 1 - , lru = PSQ.insert k epoch lru - , map = HM.insert k v map - } - | otherwise = - let Just (mink PSQ.:-> _, lru0) = PSQ.minView lru - in st { epoch = epoch + 1 - , lru = PSQ.insert k epoch lru0 - , map = HM.insert k v $ if mink == k - then map - else HM.delete mink map - } - where present = k `HM.member` map +insert k v st@Store{..} = case HashPSQ.insertView k epoch v psq of + (Just (_, _), psq0) -> st {epoch = epoch + 1, psq = psq0} + (Nothing, psq0) + | size < capacity -> st {size = size + 1, epoch = epoch + 1, psq = psq0} + | otherwise -> st {epoch = epoch + 1, psq = HashPSQ.deleteMin psq0} {-# INLINABLE insert #-} lookup :: (Ord k, Hashable k) => k -> Store k v -> Maybe (v, Store k v) -lookup k st@Store{..} = do - v <- HM.lookup k map - let !st' = st { epoch = epoch + 1, lru = PSQ.insert k epoch lru } - return (v, st') +lookup k st@Store{..} = case HashPSQ.alter tick k psq of + (Nothing, _) -> Nothing + (Just v, psq0) -> Just (v, st { epoch = epoch + 1, psq = psq0 }) + where tick Nothing = (Nothing, Nothing) + tick (Just (_, v)) = (Just v, Just (epoch, v)) {-# INLINABLE lookup #-} delete :: (Ord k, Hashable k) => k -> Store k v -> Store k v -delete k st@Store{..} - | k `HM.member` map = - st { size = size - 1 - , lru = PSQ.delete k lru - , map = HM.delete k map - } - | otherwise = st +delete k st@Store{..} = case HashPSQ.deleteView k psq of + Nothing -> st + Just (_, _, psq0) -> st {size = size - 1, psq = psq0} {-# INLINABLE delete #-} fromList :: (Ord k, Hashable k) => Int -> [(k, v)] -> Store k v @@ -78,6 +62,5 @@ {-# INLINABLE fromList #-} toList :: (Ord k, Hashable k) => Store k v -> [(k, v)] -toList Store{..} = [(k,v) | (k PSQ.:-> _) <- PSQ.toList lru, - let v = map HM.! k] +toList Store{..} = [(k,v) | (k, _, v) <- HashPSQ.toList psq] {-# INLINABLE toList #-} diff --git a/Network/Wreq/Internal.hs b/Network/Wreq/Internal.hs --- a/Network/Wreq/Internal.hs +++ b/Network/Wreq/Internal.hs @@ -63,7 +63,7 @@ , headers = [("User-Agent", userAgent)] , params = [] , redirects = 10 - , cookies = HTTP.createCookieJar [] + , cookies = Just (HTTP.createCookieJar []) , checkStatus = Nothing } where userAgent = "haskell wreq-" <> Char8.pack (showVersion version) @@ -112,7 +112,7 @@ & setProxy opts & setCheckStatus opts & setRedirects opts - & Lens.cookieJar .~ Just (cookies opts) + & Lens.cookieJar .~ cookies opts signRequest :: Request -> IO Request signRequest = maybe return f $ auth opts where diff --git a/Network/Wreq/Internal/AWS.hs b/Network/Wreq/Internal/AWS.hs --- a/Network/Wreq/Internal/AWS.hs +++ b/Network/Wreq/Internal/AWS.hs @@ -1,10 +1,9 @@ -{-# LANGUAGE OverloadedStrings, BangPatterns #-} +{-# LANGUAGE CPP, OverloadedStrings, BangPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Network.Wreq.Internal.AWS ( signRequest - , addTmpPayloadHashHeader ) where import Control.Applicative ((<$>)) @@ -14,7 +13,6 @@ import Data.Byteable (toBytes) import Data.Char (toLower) import Data.List (sort) -import Data.Maybe (fromJust) import Data.Monoid ((<>)) import Data.Time.Clock (getCurrentTime) import Data.Time.Format (formatTime) @@ -22,14 +20,19 @@ import Network.HTTP.Types (parseSimpleQuery, urlEncode) import Network.Wreq.Internal.Lens import Network.Wreq.Internal.Types (AWSAuthVersion(..)) -import System.Locale (defaultTimeLocale) import qualified Crypto.Hash as CT (HMAC, SHA256) import qualified Crypto.Hash.SHA256 as SHA256 (hash, hashlazy) import qualified Data.ByteString.Char8 as S -import qualified Data.CaseInsensitive as CI (CI, original) +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 -- @@ -41,18 +44,6 @@ -- with and without Bucket Authorization enabled -- ("Runscope-Bucket-Auth"). -- --- Q: how do we get the payload hash to the signRequest function? --- --- A: we use a (temporary) HTTP header to 'tunnel' the payload hash to --- the signing function. For POST and PUT requests, the --- Network.Wreq.Types.payload function adds a HTTP header (name --- defined in 'tmpPayloadHashHeader'). The --- Network.Wreq.Internal.AWS.signRequest function reads the value of --- the header and then removes it from the request. For GET, HEAD, --- and (currently) DELETE that carry no body, we use "" per AWS --- documentation Item 6: "use empty string" in --- http://docs.aws.amazon.com/general/latest/gr/sigv4-create-canonical-request.html - -- TODO: adjust when DELETE supports a body or PATCH is added signRequest :: AWSAuthVersion -> S.ByteString -> S.ByteString -> Request -> IO Request @@ -68,8 +59,7 @@ (service, region) = serviceAndRegion noRunscopeHost date = S.takeWhile (/= 'T') ts -- YYYYMMDD hashedPayload - | request ^. method `elem` ["POST", "PUT"] = - fromJust . lookup tmpPayloadHashHeader $ request ^. requestHeaders + | 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). @@ -77,7 +67,6 @@ (([ ("host", noRunscopeHost) , ("x-amz-date", ts)] ++ [("x-amz-content-sha256", hashedPayload) | service == "s3"]) ++) - . deleteKey tmpPayloadHashHeader -- drop tmp header -- Runscope (correctly) doesn't send Bucket Auth header to AWS, -- remove it from the headers we sign. Adding back in at the end. . deleteKey "Runscope-Bucket-Auth" @@ -132,25 +121,27 @@ hmac' s k = toBytes (hmacGetDigest h) where h = hmac k s :: (CT.HMAC CT.SHA256) -addTmpPayloadHashHeader :: Request -> IO Request -addTmpPayloadHashHeader req = do - let payloadHash = case HTTP.requestBody req of - HTTP.RequestBodyBS bs -> - HEX.encode $ SHA256.hash bs - HTTP.RequestBodyLBS lbs -> - HEX.encode $ SHA256.hashlazy lbs - _ -> error "addTmpPayloadHashHeader: unexpected request body type" - return $ setHeader tmpPayloadHashHeader payloadHash req - -tmpPayloadHashHeader :: CI.CI S.ByteString -tmpPayloadHashHeader = "X-LOCAL-CONTENT-HASH-HEADER-746352" - -- 746352 to reduce collision risk +payloadHash :: Request -> S.ByteString +payloadHash req = + case HTTP.requestBody req of + HTTP.RequestBodyBS bs -> + 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"] = @@ -160,6 +151,8 @@ 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 = @@ -168,8 +161,14 @@ where svc = servicePrefix '.' endpoint servicePrefix c = S.map toLower . S.takeWhile (/= c) - noRegion = HashSet.fromList ["iam", "sts", "importexport", "route53", - "cloudfront"] + regionInS3VHost s = + S.takeWhile (/= '.') -- "eu-west-1" + . S.reverse -- "eu-west-1.amazonaws.com" + . fst -- "moc.swanozama.1-tsew-ue" + . S.breakSubstring (S.pack "-3s.") + . S.reverse + $ s -- johnsmith.eu.s3-eu-west-1.amazonaws.com + noRegion = HashSet.fromList ["iam", "importexport", "route53", "cloudfront"] -- If the hostname doesn't end in runscope.net, return the original. -- For a hostname that includes runscope.net: diff --git a/Network/Wreq/Internal/Types.hs b/Network/Wreq/Internal/Types.hs --- a/Network/Wreq/Internal/Types.hs +++ b/Network/Wreq/Internal/Types.hs @@ -19,6 +19,7 @@ , Mgr , Auth(..) , AWSAuthVersion(..) + , StatusChecker -- * Request payloads , Payload(..) , Postable(..) @@ -42,14 +43,14 @@ , CacheEntry(..) ) where -import Control.Concurrent.MVar (MVar) 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, destroyCookieJar) + RequestBody) import Network.HTTP.Client.Internal (Response, Proxy) import Network.HTTP.Types (Header, Status, ResponseHeaders) import Prelude hiding (head) @@ -140,7 +141,7 @@ --let opts = 'Network.Wreq.defaults' { 'redirects' = 3 } --'Network.Wreq.getWith' opts \"http:\/\/httpbin.org\/redirect/5\" -- @ - , cookies :: CookieJar + , cookies :: Maybe CookieJar -- ^ Cookies to set when issuing requests. -- -- /Note/: when issuing HTTP requests using 'Options'-based @@ -149,15 +150,20 @@ -- etc.), this field will be used only for the /first/ HTTP request -- to be issued during a 'Network.Wreq.Session.Session'. Any changes -- changes made for subsequent requests will be ignored. - , checkStatus :: - Maybe (Status -> ResponseHeaders -> CookieJar -> Maybe SomeException) - -- ^ Function that checks the status code and potentially returns an exception. + , 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. + -- '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. @@ -184,18 +190,19 @@ deriving (Eq, Show) instance Show Options where - show (Options{..}) = concat ["Options { " - , "manager = ", case manager of - Left _ -> "Left _" - Right _ -> "Right _" - , ", proxy = ", show proxy - , ", auth = ", show auth - , ", headers = ", show headers - , ", params = ", show params - , ", redirects = ", show redirects - , ", cookies = ", show (destroyCookieJar cookies) - , " }" - ] + show (Options{..}) = concat [ + "Options { " + , "manager = ", case manager of + Left _ -> "Left _" + Right _ -> "Right _" + , ", proxy = ", show proxy + , ", auth = ", show auth + , ", headers = ", show headers + , ", params = ", show params + , ", redirects = ", show redirects + , ", cookies = ", show cookies + , " }" + ] -- | A type that can be converted into a POST request payload. class Postable a where @@ -282,7 +289,7 @@ -- | A session that spans multiple requests. This is responsible for -- cookie management and TCP connection reuse. data Session = Session { - seshCookies :: MVar CookieJar + seshCookies :: Maybe (IORef CookieJar) , seshManager :: Manager , seshRun :: Session -> Run Body -> Run Body } diff --git a/Network/Wreq/Lens.hs b/Network/Wreq/Lens.hs --- a/Network/Wreq/Lens.hs +++ b/Network/Wreq/Lens.hs @@ -45,6 +45,7 @@ , params , cookie , cookies + , StatusChecker , checkStatus -- ** Proxy setup @@ -100,7 +101,6 @@ ) where import Control.Applicative ((<*)) -import Control.Exception (SomeException) import Control.Lens (Fold, Lens, Lens', Traversal', folding) import Data.Attoparsec.ByteString (Parser, endOfInput, parseOnly) import Data.ByteString (ByteString) @@ -113,7 +113,7 @@ import Network.HTTP.Types.Status (Status) import Network.HTTP.Types.Version (HttpVersion) import Network.Mime (MimeType) -import Network.Wreq.Types (Auth, Link, Options) +import Network.Wreq.Types (Auth, Link, Options, StatusChecker) import qualified Network.Wreq.Lens.TH as TH -- | A lens onto configuration of the connection manager provided by @@ -228,7 +228,7 @@ redirects = TH.redirects -- | A lens to get the optional status check function -checkStatus :: Lens' Options (Maybe (Status -> ResponseHeaders -> CookieJar -> Maybe SomeException)) +checkStatus :: Lens' Options (Maybe StatusChecker) checkStatus = TH.checkStatus -- | A traversal onto the cookie with the given name, if one exists. @@ -240,7 +240,7 @@ cookie = TH.cookie -- | A lens onto all cookies. -cookies :: Lens' Options CookieJar +cookies :: Lens' Options (Maybe CookieJar) cookies = TH.cookies -- | A lens onto the name of a cookie. diff --git a/Network/Wreq/Lens/TH.hs b/Network/Wreq/Lens/TH.hs --- a/Network/Wreq/Lens/TH.hs +++ b/Network/Wreq/Lens/TH.hs @@ -95,7 +95,7 @@ -- N.B. This is an "illegal" traversal because we can change its cookie_name. cookie :: ByteString -> Traversal' Types.Options HTTP.Cookie -cookie name = cookies . _CookieJar . traverse . filtered +cookie name = cookies . _Just . _CookieJar . traverse . filtered (\c -> HTTP.cookie_name c == name) responseCookie :: ByteString -> Fold (HTTP.Response body) HTTP.Cookie diff --git a/Network/Wreq/Session.hs b/Network/Wreq/Session.hs --- a/Network/Wreq/Session.hs +++ b/Network/Wreq/Session.hs @@ -1,7 +1,7 @@ {-# LANGUAGE RankNTypes, RecordWildCards #-} -- | --- Module : Network.Wreq +-- Module : Network.Wreq.Session -- Copyright : (c) 2014 Bryan O'Sullivan -- -- License : BSD-style @@ -17,7 +17,8 @@ -- being used. -- -- * Transparent cookie management. Any cookies set by the server --- persist from one request to the next. +-- persist from one request to the next. (Bypass this overhead +-- using 'withAPISession'.) -- -- -- This module is designed to be used alongside the "Network.Wreq" @@ -32,16 +33,22 @@ -- @ -- -- We create a 'Session' using 'withSession', then pass the session to --- subsequent functions. +-- 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 a qualified import statement, so that we can refer --- unambiguously to the 'Session'-specific implementation of HTTP GET. +-- Note the use of qualified import statements in the examples above, +-- so that we can refer unambiguously to the 'Session'-specific +-- implementation of HTTP GET. module Network.Wreq.Session ( + -- * Session creation Session , withSession + , withAPISession + -- ** More control-oriented session creation , withSessionWith + , withSessionControl -- * HTTP verbs , get , post @@ -60,8 +67,9 @@ , Lens.seshRun ) where -import Control.Concurrent.MVar (modifyMVar, newMVar) -import Control.Lens ((&), (?~), (^.)) +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(..)) @@ -69,20 +77,40 @@ import Prelude hiding (head) import qualified Data.ByteString.Lazy as L import qualified Network.HTTP.Client as HTTP -import qualified Network.Wreq as Wreq import qualified Network.Wreq.Internal.Lens as Lens -- | 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, using the given manager settings. +-- | 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 settings act = do - mv <- newMVar $ HTTP.createCookieJar [] +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 = mv + act Session { seshCookies = mref , seshManager = mgr , seshRun = runWith } @@ -139,10 +167,14 @@ deleteWith opts sesh url = run string sesh =<< prepareDelete opts url runWith :: Session -> Run Body -> Run Body -runWith Session{..} act (Req _ req) = - modifyMVar seshCookies $ \cj -> do - resp <- act (Req (Right seshManager) (req & Lens.cookieJar ?~ cj)) - return (resp ^. Wreq.responseCookieJar, resp) +runWith 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) diff --git a/Network/Wreq/Types.hs b/Network/Wreq/Types.hs --- a/Network/Wreq/Types.hs +++ b/Network/Wreq/Types.hs @@ -18,6 +18,7 @@ Options(..) , Auth(..) , AWSAuthVersion(..) + , StatusChecker -- * Request payloads , Payload(..) , Postable(..) @@ -51,7 +52,6 @@ import qualified Data.Text.Lazy.Builder as TL import qualified Network.HTTP.Client as HTTP import qualified Network.Wreq.Internal.Lens as Lens -import qualified Network.Wreq.Internal.AWS as AWS (addTmpPayloadHashHeader) instance Postable Part where postPayload a = postPayload [a] @@ -141,6 +141,6 @@ renderFormValue Nothing = "" payload :: S.ByteString -> HTTP.RequestBody -> Request -> IO Request -payload ct body req = AWS.addTmpPayloadHashHeader $ req - & Lens.maybeSetHeader "Content-Type" ct - & Lens.requestBody .~ body +payload ct body req = + return $ req & Lens.maybeSetHeader "Content-Type" ct + & Lens.requestBody .~ body diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# wreq: a Haskell web client library +# wreq: a Haskell web client library [![Build Status](https://travis-ci.org/bos/wreq.svg)](https://travis-ci.org/bos/wreq) `wreq` is a library that makes HTTP client programming in Haskell easy. diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,9 +1,26 @@ -*- markdown -*- +2015-05-10 0.4.0.0 + +* Compatible with GHC 7.10. + +* New withAPISession and withSessionControl functions make talking to + REST services more efficient. + +* Added support for AWS S3 virtual-host style URLs. + +* Added signing support for region specific calls to the AWS Security + Token Service (AWS STS). + +* The introduction of AWS support accidentally introduced unwanted AWS + headers and computation into all requests. This has been fixed. + + 2014-12-11 0.3.0.1 * Bump lower bound on http-client to 0.3.0.1 + 2014-12-02 0.3.0.0 * Support for Amazon Web Services request signing @@ -14,9 +31,11 @@ * httpProxy, basicAuth, oauth2Bearer, oauth2Token: removed Maybe from result types, changed documentation to suggest use of (?~) + 2014-08-25 0.2.0.0 * Support for lens 4.4 + 2014-04-22 0.1.0.0 diff --git a/httpbin/HttpBin/Server.hs b/httpbin/HttpBin/Server.hs --- a/httpbin/HttpBin/Server.hs +++ b/httpbin/HttpBin/Server.hs @@ -15,6 +15,7 @@ import Data.Monoid ((<>)) import Data.Text.Encoding (decodeUtf8) import Data.Text.Read (decimal) +import Data.Time.Clock (UTCTime(..)) import Data.UUID (toASCIIBytes) import Data.UUID.V4 (nextRandom) import Snap.Core @@ -49,6 +50,16 @@ localRequest (setHeader "Accept-Encoding" "gzip") . withCompression . respond $ \obj -> return $ obj <> [("gzipped", Bool True)] +deleteCookies = do + req <- getRequest + let expire name = Cookie name "" (Just mcfly) Nothing (Just "/") False False + mcfly = UTCTime (read "1985-10-26") 4800 + modifyResponse . foldr (.) id $ [ + addResponseCookie (expire name) . deleteResponseCookie name + | name <- Map.keys (rqQueryParams req) + ] + redirect "/cookies" + setCookies = do params <- rqQueryParams <$> getRequest modifyResponse . foldr (.) id . map addResponseCookie $ @@ -141,22 +152,26 @@ , ("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", methods [GET,HEAD] get) - , ("/post", method POST post) - , ("/put", method PUT put) - , ("/delete", method DELETE delete) + ("/get", meths [GET,HEAD] get) + , ("/post", meth POST post) + , ("/put", meth PUT put) + , ("/delete", meth DELETE delete) , ("/redirect/:n", redirect_) , ("/status/:val", status) - , ("/gzip", methods [GET,HEAD] gzip) - , ("/cookies/set", methods [GET,HEAD] setCookies) - , ("/cookies", methods [GET,HEAD] listCookies) - , ("/basic-auth/:user/:pass", methods [GET,HEAD] basicAuth) - , ("/oauth2/:kind/:token", methods [GET,HEAD] oauth2token) - , ("/cache", methods [GET,HEAD] cache) + , ("/gzip", meths [GET,HEAD] gzip) + , ("/cookies/delete", meths [GET,HEAD] deleteCookies) + , ("/cookies/set", meths [GET,HEAD] setCookies) + , ("/cookies", meths [GET,HEAD] listCookies) + , ("/basic-auth/:user/:pass", meths [GET,HEAD] basicAuth) + , ("/oauth2/:kind/:token", meths [GET,HEAD] oauth2token) + , ("/cache", meths [GET,HEAD] cache) ] diff --git a/tests/AWS.hs b/tests/AWS.hs --- a/tests/AWS.hs +++ b/tests/AWS.hs @@ -65,7 +65,7 @@ import Control.Lens import Data.ByteString.Char8 as BS8 (pack) import Data.IORef (newIORef) -import Network.Info (getNetworkInterfaces, mac) +import Network.Info (getNetworkInterfaces, mac, ipv6) import Network.Wreq import System.Environment (getEnv) import Test.Framework (Test, testGroup) @@ -96,27 +96,38 @@ let baseopts = defaults & auth ?~ awsAuth AWSv4 key secret prefix <- env "deleteWreqTest" "WREQ_AWS_TEST_PREFIX" sqsTestState <- newIORef "missing" + iamTestState <- newIORef "missing" uniq <- uniqueMachineId + let bucketname = prefix ++ uniq return $ testGroup "aws" [ AWS.DynamoDB.tests (prefix ++ "DynamoDB") region baseopts - , AWS.IAM.tests (prefix ++ "IAM") region baseopts + , AWS.IAM.tests (prefix ++ "IAM") region baseopts iamTestState , AWS.SQS.tests (prefix ++ "SQS") region baseopts sqsTestState -- S3 buckets are global entities and the namespace shared among -- all AWS customers. We will use a unique id based on the MAC -- address of our client to avoid naming conflicts among different -- developers running the tests. - , AWS.S3.tests (prefix ++ "S3" ++ uniq) region baseopts + , AWS.S3.tests bucketname region baseopts + --, AWS.S3.tests bucketname "us-east-1" baseopts -- classic + --, AWS.S3.tests bucketname "external-1" baseopts -- Virginia ] -- return a globally unique machine id (uses a MAC address) uniqueMachineId :: IO String uniqueMachineId = do - l <- (filter $ (/=) "00:00:00:00:00:00" . show . mac) `fmap` - getNetworkInterfaces - return $ concatMap (\c -> if c == ':' then [] else [c]) - . show - . mac - . head $ l + nis <- getNetworkInterfaces + let lmac = filter ((/=) "00:00:00:00:00:00") $ map (show . mac) nis + -- travis-ci.org doesn't show mac addresses - use ipv6 (e.g. of venet0) + let lipv6 = filter (\s -> (s /= "0:0:0:0:0:0:0:0") && + (s /= "0:0:0:0:0:0:0:1") && + (s /= "fe80:0:0:0:0:0:0:1")) + $ map (show . ipv6) nis + if (null $ lmac ++ lipv6) + then error "FATAL: can't determine unique id automatically in this runtime env!" + else do + let uniq = concatMap (\c -> if c == ':' then [] else [c]) + $ head (lmac ++ lipv6) + return uniq env :: String -> String -> IO String env defVal name = getEnv name `E.catch` \(_::IOException) -> return defVal diff --git a/tests/AWS/Aeson.hs b/tests/AWS/Aeson.hs new file mode 100644 --- /dev/null +++ b/tests/AWS/Aeson.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE FlexibleInstances, TypeFamilies, TypeSynonymInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module AWS.Aeson + ( + object + , string + , true + , (.=) + ) where + +import Data.Aeson hiding ((.=)) +import Data.Text (Text, pack) +import GHC.Exts +import qualified Data.Vector as Vector + +instance Num Value where + fromInteger = Number . fromInteger + +instance Fractional Value where + fromRational = Number . fromRational + +instance IsList Value where + type Item Value = Value + fromList = Array . Vector.fromList + toList (Array a) = Vector.toList a + toList _ = error "AWS.Aeson.toList" + +class Stringy a where + string :: a -> Value + +instance Stringy Text where + string = String + +instance Stringy String where + string = String . pack + +true :: Value +true = Bool True + +(.=) :: Text -> Value -> (Text, Value) +a .= b = (a,b) diff --git a/tests/AWS/DynamoDB.hs b/tests/AWS/DynamoDB.hs --- a/tests/AWS/DynamoDB.hs +++ b/tests/AWS/DynamoDB.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE OverloadedStrings, QuasiQuotes #-} +{-# LANGUAGE OverloadedLists, OverloadedStrings #-} module AWS.DynamoDB (tests) where +import AWS.Aeson import Control.Concurrent (threadDelay) -import Control.Lens +import Control.Lens hiding ((.=)) import Data.Aeson.Lens (key, _String, values, _Double) -import Data.Aeson.QQ import Data.Text as T (pack) import Network.Wreq import System.Timeout (timeout) @@ -34,21 +34,21 @@ & header "X-Amz-Target" .~ ["DynamoDB_20120810.CreateTable"] & header "Content-Type" .~ ["application/x-amz-json-1.0"] r <- postWith opts (url region) $ - [aesonQQ| { - "TableName": #{prefix ++ tablename}, - "KeySchema": [ - { "AttributeName": "name", "KeyType": "HASH" }, - { "AttributeName": "age", "KeyType": "RANGE" } - ], - "AttributeDefinitions": [ - { "AttributeName": "name", "AttributeType": "S" }, - { "AttributeName": "age", "AttributeType": "S" } - ], - "ProvisionedThroughput": { - "ReadCapacityUnits": 1, - "WriteCapacityUnits": 1 - } - } |] + object [ + "TableName" .= string (prefix ++ tablename), + "KeySchema" .= [ + object ["AttributeName" .= "name", "KeyType" .= "HASH"], + object ["AttributeName" .= "age", "KeyType" .= "RANGE"] + ], + "AttributeDefinitions" .= [ + object ["AttributeName" .= "name", "AttributeType" .= "S"], + object ["AttributeName" .= "age", "AttributeType" .= "S"] + ], + "ProvisionedThroughput" .= object [ + "ReadCapacityUnits" .= 1, + "WriteCapacityUnits" .= 1 + ] + ] assertBool "createTables 200" $ r ^. responseStatus . statusCode == 200 assertBool "createTables OK" $ r ^. responseStatus . statusMessage == "OK" assertBool "createTables status CREATING" $ @@ -62,7 +62,7 @@ & header "X-Amz-Target" .~ ["DynamoDB_20120810.ListTables"] & header "Content-Type" .~ ["application/x-amz-json-1.0"] -- FIXME avoid limit to keep tests from failing if there are > tables? - r <- postWith opts (url region) [aesonQQ| { "Limit": 100 } |] + r <- postWith opts (url region) $ object ["Limit" .= 100] assertBool "listTables 200" $ r ^. responseStatus . statusCode == 200 assertBool "listTables OK" $ r ^. responseStatus . statusMessage == "OK" assertBool "listTables contains test table" $ @@ -83,8 +83,8 @@ let opts = baseopts & header "X-Amz-Target" .~ ["DynamoDB_20120810.DescribeTable"] & header "Content-Type" .~ ["application/x-amz-json-1.0"] - r <- postWith opts (url region) - [aesonQQ| { "TableName": #{prefix ++ tablename} } |] + r <- postWith opts (url region) $ + object ["TableName" .= string (prefix ++ tablename)] assertBool "awaitTableActive 200" $ r ^. responseStatus . statusCode == 200 assertBool "awaitTableActive OK" $ r ^. responseStatus . statusMessage == "OK" -- Prelude.putStr "." @@ -101,7 +101,7 @@ & header "X-Amz-Target" .~ ["DynamoDB_20120810.DeleteTable"] & header "Content-Type" .~ ["application/x-amz-json-1.0"] r <- postWith opts (url region) $ - [aesonQQ| { "TableName": #{prefix ++ tablename} } |] + object ["TableName" .= string (prefix ++ tablename)] assertBool "deleteTable 200" $ r ^. responseStatus . statusCode == 200 assertBool "deleteTable OK" $ r ^. responseStatus . statusMessage == "OK" @@ -111,14 +111,14 @@ & header "X-Amz-Target" .~ ["DynamoDB_20120810.PutItem"] & header "Content-Type" .~ ["application/x-amz-json-1.0"] r <- postWith opts (url region) $ - [aesonQQ| { - "TableName": #{prefix ++ tablename}, - "Item": { - "name": { "S": "someone" }, - "age": {"S": "whatever"}, - "bar": {"S": "baz"} - } - } |] + object [ + "TableName" .= string (prefix ++ tablename), + "Item" .= object [ + "name" .= object ["S" .= "someone"], + "age" .= object ["S" .= "whatever"], + "bar" .= object ["S" .= "baz"] + ] + ] assertBool "putItem 200" $ r ^. responseStatus . statusCode == 200 assertBool "putItem OK" $ r ^. responseStatus . statusMessage == "OK" @@ -128,16 +128,16 @@ & header "X-Amz-Target" .~ ["DynamoDB_20120810.GetItem"] & header "Content-Type" .~ ["application/x-amz-json-1.0"] r <- postWith opts (url region) $ - [aesonQQ| { - "TableName": #{prefix ++ tablename}, - "Key": { - "name": { "S": "someone" }, - "age": {"S": "whatever"} - }, - "AttributesToGet": [ "bar" ], - "ConsistentRead": true, - "ReturnConsumedCapacity": "TOTAL" - } |] + object [ + "TableName" .= string (prefix ++ tablename), + "Key" .= object [ + "name" .= object ["S" .= "someone"], + "age" .= object ["S" .= "whatever"] + ], + "AttributesToGet" .= ["bar"], + "ConsistentRead" .= true, + "ReturnConsumedCapacity" .= "TOTAL" + ] assertBool "getItem 200" $ r ^. responseStatus . statusCode == 200 assertBool "getItem OK" $ r ^. responseStatus . statusMessage == "OK" assertBool "getItem baz value is bar" $ @@ -149,14 +149,14 @@ & header "X-Amz-Target" .~ ["DynamoDB_20120810.DeleteItem"] & header "Content-Type" .~ ["application/x-amz-json-1.0"] r <- postWith opts (url region) $ - [aesonQQ| { - "TableName": #{prefix ++ tablename}, - "Key": { - "name": { "S": "someone" }, - "age": {"S": "whatever"} - }, - "ReturnValues": "ALL_OLD" - } |] + object [ + "TableName" .= string (prefix ++ tablename), + "Key" .= object [ + "name" .= object ["S" .= "someone"], + "age" .= object ["S" .= "whatever"] + ], + "ReturnValues" .= "ALL_OLD" + ] assertBool "getItem 200" $ r ^. responseStatus . statusCode == 200 assertBool "getItem OK" $ r ^. responseStatus . statusMessage == "OK" diff --git a/tests/AWS/IAM.hs b/tests/AWS/IAM.hs --- a/tests/AWS/IAM.hs +++ b/tests/AWS/IAM.hs @@ -1,15 +1,29 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLists, OverloadedStrings #-} module AWS.IAM (tests) where -import Control.Lens +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 -> Test -tests prefix region baseopts = testGroup "iam" [ - testCase "listUsers" $ listUsers prefix region baseopts +tests :: String -> String -> Options -> IORef String -> Test +tests prefix region baseopts iamTestState = testGroup "iam" [ + testCase "listUsers" $ listUsers prefix region baseopts + , testCase "createRole" $ createRole prefix region baseopts iamTestState + , testCase "listRoles" $ listRoles prefix region baseopts + , testCase "putRolePolicy" $ putRolePolicy prefix region baseopts + , testCase "stsAssumeRole" $ stsAssumeRole prefix region baseopts iamTestState + , testCase "deleteRolePolicy" $ deleteRolePolicy prefix region baseopts + , testCase "deleteRole" $ deleteRole prefix region baseopts ] listUsers :: String -> String -> Options -> IO () @@ -18,10 +32,155 @@ & param "Action" .~ ["ListUsers"] & param "Version" .~ ["2010-05-08"] & header "Accept" .~ ["application/json"] - r <- getWith opts (url region) + r <- getWith opts (iamUrl region) assertBool "listUsers 200" $ r ^. responseStatus . statusCode == 200 assertBool "listUsers OK" $ r ^. responseStatus . statusMessage == "OK" -url :: String -> String -url _ = - "https://iam.amazonaws.com/" -- not region specific +createRole :: String -> String -> Options -> IORef String -> IO () +createRole prefix region baseopts iamTestState = do + let opts = baseopts + & param "Action" .~ ["CreateRole"] + & param "Version" .~ ["2010-05-08"] + & param "RoleName" .~ [T.pack $ prefix ++ roleName] + & param "AssumeRolePolicyDocument" .~ [rolePolicyDoc] + & header "Accept" .~ ["application/json"] + r <- getWith opts (iamUrl region) + assertBool "createRole 200" $ r ^. responseStatus . statusCode == 200 + assertBool "createRole OK" $ r ^. responseStatus . statusMessage == "OK" + let [arn] = r ^.. responseBody . key "CreateRoleResponse" + . key "CreateRoleResult" + . key "Role" + . key "Arn" . _String + writeIORef iamTestState $ T.unpack arn + +putRolePolicy :: String -> String -> Options -> IO () +putRolePolicy prefix region baseopts = do + let opts = baseopts + & param "Action" .~ ["PutRolePolicy"] + & param "Version" .~ ["2010-05-08"] + & param "RoleName" .~ [T.pack $ prefix ++ roleName] + & param "PolicyName" .~ [testPolicyName] + & param "PolicyDocument" .~ [policyDoc] + & header "Accept" .~ ["application/json"] + r <- getWith opts (iamUrl region) + assertBool "putRolePolicy 200" $ r ^. responseStatus . statusCode == 200 + assertBool "putRolePolicy OK" $ r ^. responseStatus . statusMessage == "OK" + threadDelay $ 30*1000*1000 -- 30 sleep, allow change to propagate to region + +deleteRolePolicy :: String -> String -> Options -> IO () +deleteRolePolicy prefix region baseopts = do + let opts = baseopts + & param "Action" .~ ["DeleteRolePolicy"] + & param "Version" .~ ["2010-05-08"] + & param "RoleName" .~ [T.pack $ prefix ++ roleName] + & param "PolicyName" .~ [testPolicyName] + & param "PolicyDocument" .~ [policyDoc] + & header "Accept" .~ ["application/json"] + r <- getWith opts (iamUrl region) + assertBool "deleteRolePolicy 200" $ r ^. responseStatus . statusCode == 200 + assertBool "deleteRolePolicy OK" $ r ^. responseStatus . statusMessage == "OK" + +deleteRole :: String -> String -> Options -> IO () +deleteRole prefix region baseopts = do + let opts = baseopts + & param "Action" .~ ["DeleteRole"] + & param "Version" .~ ["2010-05-08"] + & param "RoleName" .~ [T.pack $ prefix ++ roleName] + & header "Accept" .~ ["application/json"] + r <- getWith opts (iamUrl region) + assertBool "deleteRole 200" $ r ^. responseStatus . statusCode == 200 + assertBool "deleteRole OK" $ r ^. responseStatus . statusMessage == "OK" + +listRoles :: String -> String -> Options -> IO () +listRoles prefix region baseopts = do + let opts = baseopts + & param "Action" .~ ["ListRoles"] + & param "Version" .~ ["2010-05-08"] + & header "Accept" .~ ["application/json"] + r <- getWith opts (iamUrl region) + assertBool "listRoles 200" $ r ^. responseStatus . statusCode == 200 + assertBool "listRoles OK" $ r ^. responseStatus . statusMessage == "OK" + let arns = r ^.. responseBody . key "ListRolesResponse" . + key "ListRolesResult" . + key "Roles" . + values . + key "Arn" . _String + -- arns are of form: "arn:aws:iam:::role/ec2-role" + let arns' = map (T.unpack . last . T.split (=='/')) arns + assertBool "listRoles contains test role" $ + elem (prefix ++ roleName) arns' + +-- Security Token Service (STS) +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 --- a/tests/AWS/S3.hs +++ b/tests/AWS/S3.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE OverloadedStrings, QuasiQuotes #-} +{-# LANGUAGE OverloadedLists, OverloadedStrings #-} module AWS.S3 (tests) where -import Control.Lens -import Data.Aeson.QQ +import AWS.Aeson +import Control.Lens hiding ((.=)) import Data.Char (toLower) import Data.Monoid ((<>)) import Network.Wreq @@ -20,57 +20,79 @@ tests :: String -> String -> Options -> Test tests prefix region baseopts = let lowerPrefix = map toLower prefix - in testGroup "s3" [ - testCase "createBucket" $ createBucket lowerPrefix region baseopts - , testCase "putObjectJSON" $ putObjectJSON lowerPrefix region baseopts - , testCase "getObjectJSON" $ getObjectJSON lowerPrefix region baseopts - , testCase "deleteObjectJSON" $ deleteObjectJSON lowerPrefix region baseopts - , testCase "deleteBucket" $ deleteBucket lowerPrefix region baseopts -- call last - ] + t = \(mkUrl, label) -> + testGroup (region ++ "_" ++ label) [ + testCase "createBucket" $ + createBucket mkUrl lowerPrefix region baseopts + , testCase "putObjectJSON" $ + putObjectJSON mkUrl lowerPrefix region baseopts + , testCase "getObjectJSON" $ + getObjectJSON mkUrl lowerPrefix region baseopts + , testCase "deleteObjectJSON" $ + deleteObjectJSON mkUrl lowerPrefix region baseopts + , testCase "deleteBucket" $ + deleteBucket mkUrl lowerPrefix region baseopts -- call last + ] + in testGroup "s3" $ map t [ (urlPath, "bucket-in-path") + , (urlVHost, "bucket-in-vhost") ] -createBucket :: String -> String -> Options -> IO () -createBucket prefix region baseopts = do - r <- putWith baseopts (url region ++ prefix ++ "testbucket") $ +-- Path based bucket access +createBucket :: MkURL -> String -> String -> Options -> IO () +createBucket url prefix region baseopts = do + r <- putWith baseopts (url region prefix "testbucket") $ locationConstraint region assertBool "createBucket 200" $ r ^. responseStatus . statusCode == 200 assertBool "createBucket OK" $ r ^. responseStatus . statusMessage == "OK" -deleteBucket :: String -> String -> Options -> IO () -deleteBucket prefix region baseopts = do - r <- deleteWith baseopts (url region ++ prefix ++ "testbucket") +deleteBucket :: MkURL -> String -> String -> Options -> IO () +deleteBucket url prefix region baseopts = do + r <- deleteWith baseopts (url region prefix "testbucket") assertBool "deleteBucket 204 - no content" $ r ^. responseStatus . statusCode == 204 assertBool "deleteBucket OK" $ r ^. responseStatus . statusMessage == "No Content" -putObjectJSON :: String -> String -> Options -> IO () -putObjectJSON prefix region baseopts = do - -- S3 write object, incl. correct content-type, uses /bucket/object syntax - r <- putWith baseopts (url region ++ prefix ++ "testbucket/blabla-json") $ - [aesonQQ| { "test": "key", "testdata": [ 1, 2, 3 ] } |] +putObjectJSON :: MkURL -> String -> String -> Options -> IO () +putObjectJSON url prefix region baseopts = do + -- S3 write object, incl. correct content-type + r <- putWith baseopts (url region prefix "testbucket" ++ "blabla-json") $ + object ["test" .= "key", "testdata" .= [1, 2, 3]] assertBool "putObjectJSON 200" $ r ^. responseStatus . statusCode == 200 assertBool "putObjectJSON OK" $ r ^. responseStatus . statusMessage == "OK" -getObjectJSON :: String -> String -> Options -> IO () -getObjectJSON prefix region baseopts = do - r <- getWith baseopts (url region ++ prefix ++ "testbucket/blabla-json") +getObjectJSON :: MkURL -> String -> String -> Options -> IO () +getObjectJSON url prefix region baseopts = do + r <- getWith baseopts (url region prefix "testbucket" ++ "blabla-json") assertBool "getObjectJSON 200" $ r ^. responseStatus . statusCode == 200 assertBool "getObjectJSON OK" $ r ^. responseStatus . statusMessage == "OK" -deleteObjectJSON :: String -> String -> Options -> IO () -deleteObjectJSON prefix region baseopts = do - r <- deleteWith baseopts (url region ++ prefix ++ "testbucket/blabla-json") +deleteObjectJSON :: MkURL -> String -> String -> Options -> IO () +deleteObjectJSON url prefix region baseopts = do + r <- deleteWith baseopts (url region prefix "testbucket" ++ "blabla-json") assertBool "deleteObjectJSON 204 - no content" $ r ^. responseStatus . statusCode == 204 assertBool "deleteObjectJSON OK" $ r ^. responseStatus . statusMessage == "No Content" +type MkURL = String -> String -> String -> String --region prefix bucket + -- see http://docs.aws.amazon.com/general/latest/gr/rande.html#s3_region -url :: String -> String -url "us-east-1" = "https://s3.amazonaws.com/" -- uses 'classic' -url region = "https://s3-" ++ region ++ ".amazonaws.com/" +urlPath :: MkURL +urlPath "us-east-1" prefix bucketname = + "https://s3.amazonaws.com/" ++ prefix ++ bucketname ++ "/"-- uses 'classic' +urlPath region prefix bucketname = + "https://s3-" ++ region ++ ".amazonaws.com/" ++ prefix ++ bucketname ++ "/" +-- Generate a VirtualHost style URL +urlVHost :: MkURL +urlVHost "us-east-1" prefix bucketname = + "https://" ++ prefix ++ bucketname ++ ".s3.amazonaws.com/" +urlVHost region prefix bucketname = + "https://" ++ prefix ++ bucketname ++ ".s3-" ++ region ++ ".amazonaws.com/" + -- see http://docs.aws.amazon.com/AmazonS3/latest/API/RESTBucketPUT.html +-- and http://docs.aws.amazon.com/general/latest/gr/rande.html#s3_region locationConstraint :: String -> BS8.ByteString -locationConstraint "us-east-1" = "" -- no loc needed for classic and Virginia +locationConstraint "us-east-1" = "" -- no loc needed for classic and Virginia +locationConstraint "external-1" = "" -- no loc needed for Virginia locationConstraint region = "" <> BS8.pack region <> "" diff --git a/tests/Tests.hs b/tests/Tests.hs --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -1,13 +1,22 @@ +{-# LANGUAGE CPP #-} + module Main (main) where import Test.Framework (testGroup) import UnitTests (testWith) -import qualified AWS (tests) import qualified Properties.Store +#if defined(AWS_TESTS) +import qualified AWS (tests) +#endif + main :: IO () main = do +#if defined(AWS_TESTS) awsTests <- AWS.tests +#else + let awsTests = testGroup "aws" [] +#endif testWith [ testGroup "store" Properties.Store.tests , awsTests diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs --- a/tests/UnitTests.hs +++ b/tests/UnitTests.hs @@ -262,13 +262,42 @@ assertEqual "cookies are set correctly" (Just "y") (r ^? responseCookie "x" . cookieValue) + cookieSession site = Session.withSession $ \s -> do - void $ Session.get s (site "/cookies/set?foo=bar") - r <- Session.get s (site "/cookies") - assertEqual "cookies are set correctly" (Just "bar") - (r ^? responseCookie "foo" . cookieValue) - assertEqual "whee" (Just "bar") - (r ^. responseBody ^? key "cookies" . key "foo") + 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") diff --git a/wreq.cabal b/wreq.cabal --- a/wreq.cabal +++ b/wreq.cabal @@ -1,5 +1,5 @@ name: wreq -version: 0.3.0.1 +version: 0.4.0.0 synopsis: An easy-to-use HTTP client library. description: . @@ -53,6 +53,12 @@ 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 @@ -66,8 +72,6 @@ library ghc-options: -Wall -fwarn-tabs -funbox-strict-fields - if flag(developer) - ghc-options: -Werror default-language: Haskell98 exposed-modules: @@ -87,7 +91,7 @@ Network.Wreq.Lens.TH Paths_wreq build-depends: - PSQueue >= 1.1, + psqueues >= 0.2, aeson >= 0.7.0.3, attoparsec >= 0.11.1.0, base >= 4.5 && < 5, @@ -116,8 +120,6 @@ executable httpbin hs-source-dirs: httpbin ghc-options: -Wall -fwarn-tabs -threaded -rtsopts - if flag(developer) - ghc-options: -Werror default-language: Haskell98 main-is: HttpBin.hs other-modules: HttpBin.Server @@ -136,6 +138,7 @@ snap-core, snap-server >= 0.9.4.4, text, + time, transformers, unix-compat, uuid @@ -145,24 +148,29 @@ hs-source-dirs: httpbin tests main-is: Tests.hs ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -threaded -rtsopts - if flag(developer) - ghc-options: -Werror default-language: Haskell98 other-modules: Properties.Store UnitTests - AWS - AWS.DynamoDB - AWS.IAM - AWS.S3 - AWS.SQS + 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, - aeson-qq, base >= 4.5 && < 5, base64-bytestring, bytestring, @@ -181,9 +189,11 @@ test-framework-hunit, test-framework-quickcheck2, text, + time, transformers, unix-compat, uuid, + vector, wreq test-suite doctest @@ -191,8 +201,6 @@ hs-source-dirs: tests main-is: DocTests.hs ghc-options: -Wall -fwarn-tabs -threaded - if flag(developer) - ghc-options: -Werror default-language: Haskell98 if !flag(doctest) diff --git a/www/index.md b/www/index.md --- a/www/index.md +++ b/www/index.md @@ -89,6 +89,7 @@ the authors of our popular Tetris clones. ~~~~ {.haskell} +ghci> import Data.Aeson.Lens ghci> r ^.. responseBody . key "items" . values . key "owner" . key "login" . _String ["steffi2392","rmies","Spacejoker","walpen",{-...-}