diff --git a/amazonka-core.cabal b/amazonka-core.cabal --- a/amazonka-core.cabal +++ b/amazonka-core.cabal @@ -1,5 +1,5 @@ name: amazonka-core -version: 0.0.4 +version: 0.0.5 synopsis: Core functionality, serialisation primitives, and data types for the Amazonka Amazon Web Services SDKs. homepage: https://github.com/brendanhay/amazonka license: OtherLicense @@ -81,7 +81,7 @@ , cryptohash-conduit >= 0.1.1 , data-default-class >= 0.0.1 , hashable >= 1.2 - , http-client >= 0.3.6 && < 0.4 + , http-client >= 0.4.3 && < 0.5 , http-types >= 0.8 , lens >= 4.3 && < 5 , mmorph >= 1 && < 2 diff --git a/src/Network/AWS/Data/Internal/Body.hs b/src/Network/AWS/Data/Internal/Body.hs --- a/src/Network/AWS/Data/Internal/Body.hs +++ b/src/Network/AWS/Data/Internal/Body.hs @@ -13,26 +13,27 @@ module Network.AWS.Data.Internal.Body where -import Control.Lens import Control.Applicative +import Control.Lens import Control.Monad.IO.Class import Control.Monad.Morph import Control.Monad.Trans.Resource import Crypto.Hash -import qualified Crypto.Hash.Conduit as Conduit +import qualified Crypto.Hash.Conduit as Conduit import Data.Aeson -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.Lazy.Char8 as LBS8 +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as Build +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lazy.Char8 as LBS8 import Data.Conduit -import qualified Data.Conduit.Binary as Conduit +import qualified Data.Conduit.Binary as Conduit import Data.IORef import Data.Int +import Data.List (intersperse) import Data.Monoid import Data.String -import qualified Data.Text as Text -import Network.AWS.Data.Internal.Text +import Network.AWS.Data.Internal.ByteString import Network.HTTP.Client import System.IO @@ -40,15 +41,15 @@ makePrisms ''RsBody -connectBody :: MonadResource m => RsBody -> Sink ByteString m a -> m a -connectBody (RsBody src) sink = hoist liftResourceT src $$+- sink - -instance ToText RsBody where - toText = const "RsBody " +instance ToBuilder RsBody where + build = const "RsBody { ResumableSource (ResourceT IO) ByteString }" instance Show RsBody where - show = Text.unpack . toText + show = LBS8.unpack . Build.toLazyByteString . build +connectBody :: MonadResource m => RsBody -> Sink ByteString m a -> m a +connectBody (RsBody src) sink = hoist liftResourceT src $$+- sink + data RqBody = RqBody { _bdyHash :: Digest SHA256 , _bdyBody :: RequestBody @@ -59,11 +60,16 @@ bodyHash :: RqBody -> ByteString bodyHash = digestToHexByteString . _bdyHash -instance ToText RqBody where - toText (RqBody h _) = "RqBody " <> toText h <> " " +instance ToBuilder RqBody where + build x@(RqBody _ b) = mconcat $ intersperse "\n" + [ " Body {" + , " hash = " <> build (bodyHash x) + , " payload =\n" <> build b + , " }" + ] instance Show RqBody where - show = Text.unpack . toText + show = LBS8.unpack . Build.toLazyByteString . build . _bdyBody instance IsString RqBody where fromString = toBody . LBS8.pack diff --git a/src/Network/AWS/Data/Internal/ByteString.hs b/src/Network/AWS/Data/Internal/ByteString.hs --- a/src/Network/AWS/Data/Internal/ByteString.hs +++ b/src/Network/AWS/Data/Internal/ByteString.hs @@ -1,5 +1,8 @@ {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} -- Copyright : (c) 2013-2014 Brendan Hay -- License : This Source Code Form is subject to the terms of @@ -12,13 +15,9 @@ module Network.AWS.Data.Internal.ByteString ( LazyByteString - , ToByteString (..) - , showBS - , ToBuilder (..) - , buildBS - + , showBS , stripBS ) where @@ -32,11 +31,14 @@ import qualified Data.CaseInsensitive as CI import Data.Char import Data.Int +import Data.List (intersperse) +import Data.Monoid import Data.Text (Text) import qualified Data.Text.Encoding as Text import Data.Time (UTCTime) import Network.AWS.Data.Internal.Text -import Network.HTTP.Types.Method +import Network.HTTP.Client +import Network.HTTP.Types import Numeric.Natural type LazyByteString = LBS.ByteString @@ -77,17 +79,94 @@ build = build . toBS {-# INLINE build #-} -instance ToBuilder Builder where build = id -instance ToBuilder ByteString where build = Build.byteString -instance ToBuilder Char where build = Build.charUtf8 -instance ToBuilder [Char] where build = Build.stringUtf8 -instance ToBuilder Int where build = Build.intDec -instance ToBuilder Int64 where build = Build.int64Dec -instance ToBuilder Integer where build = Build.integerDec -instance ToBuilder Natural where build = Build.integerDec . toInteger -instance ToBuilder Double where build = Build.doubleDec +instance ToBuilder Builder where build = id +instance ToBuilder ByteString where build = Build.byteString +instance ToBuilder LazyByteString where build = Build.lazyByteString +instance ToBuilder Text where build = Build.byteString . Text.encodeUtf8 +instance ToBuilder Char where build = Build.charUtf8 +instance ToBuilder [Char] where build = Build.stringUtf8 +instance ToBuilder Int where build = Build.intDec +instance ToBuilder Int64 where build = Build.int64Dec +instance ToBuilder Integer where build = Build.integerDec +instance ToBuilder Natural where build = Build.integerDec . toInteger +instance ToBuilder Double where build = Build.doubleDec instance ToBuilder StdMethod instance ToBuilder (Digest a) + +instance ToBuilder Bool where + build True = "True" + build False = "False" + +instance ToBuilder UTCTime where + build = Build.stringUtf8 . show + +instance ToBuilder a => ToBuilder (Maybe a) where + build Nothing = "Nothing" + build (Just x) = "Just " <> build x + +instance ToBuilder a => ToBuilder (CI a) where + build = build . CI.foldedCase + +instance ToBuilder [Header] where + build = mconcat + . intersperse "; " + . map (\(k, v) -> build k <> ": " <> build v) + +instance ToBuilder HttpVersion where + build HttpVersion{..} = "HTTP/" + <> build httpMajor + <> build '.' + <> build httpMinor + +instance ToBuilder RequestBody where + build = \case + RequestBodyLBS lbs + | n <= m -> build lbs + | otherwise -> " build n <> ">" + where + n = LBS.length lbs + + RequestBodyBS bs + | n <= fromIntegral m -> build bs + | otherwise -> " build n <> ">" + where + n = BS.length bs + + RequestBodyBuilder n _ -> " build n <> ">" + RequestBodyStream n _ -> " build n <> ">" + RequestBodyStreamChunked _ -> " " + where + m :: Int64 + m = 4096 + +instance ToBuilder Request where + build x = mconcat $ intersperse "\n" + [ "[Client Request] {" + , " host = " <> build (host x) + , " port = " <> build (port x) + , " secure = " <> build (secure x) + , " headers = " <> build (requestHeaders x) + , " path = " <> build (path x) + , " query = " <> build (queryString x) + , " method = " <> build (method x) + , " redirect count = " <> build (redirectCount x) + , " response timeout = " <> build (responseTimeout x) + , " request version = " <> build (requestVersion x) + , "}" + ] + +instance ToBuilder (Response a) where + build x = mconcat $ intersperse "\n" + [ "[Client Response] {" + , " status code = " <> build (statusCode s) + , " status message = " <> build (statusMessage s) + , " version = " <> build (responseVersion x) + , " headers = " <> build (responseHeaders x) + , " cookies = " <> build (show (responseCookieJar x)) + , "}" + ] + where + s = responseStatus x stripBS :: ByteString -> ByteString stripBS = BS.dropWhile isSpace . fst . BS.spanEnd isSpace diff --git a/src/Network/AWS/Data/Internal/List.hs b/src/Network/AWS/Data/Internal/List.hs --- a/src/Network/AWS/Data/Internal/List.hs +++ b/src/Network/AWS/Data/Internal/List.hs @@ -23,21 +23,23 @@ module Network.AWS.Data.Internal.List where -import Control.Lens hiding (coerce, element) +import Control.Lens hiding (coerce, element) import Control.Monad import Data.Aeson +import Data.ByteString (ByteString) import Data.Coerce -import Data.Foldable (Foldable) -import Data.List.NonEmpty (NonEmpty(..)) +import Data.Foldable (Foldable) +import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe import Data.Monoid import Data.Proxy -import Data.Semigroup (Semigroup) +import Data.Semigroup (Semigroup) import Data.String -import qualified Data.Text as Text -import qualified Data.Vector as Vector +import qualified Data.Text as Text +import qualified Data.Vector as Vector import GHC.Exts import GHC.TypeLits +import Network.AWS.Data.Internal.ByteString import Network.AWS.Data.Internal.Query import Network.AWS.Data.Internal.XML import Text.XML @@ -75,11 +77,21 @@ = Right $ List1 (x :| xs) toList1 _ = Left $ "Unexpected empty list, expected at least 1 element." -instance ToQuery a => ToQuery (List e a) where - toQuery = toQuery . list +toQueryList :: ToQuery a => ByteString -> [a] -> Query +toQueryList n = mconcat . zipWith (\i v -> n =? (toBS i, v)) idx + where + idx = [1..] :: [Int] +{-# INLINE toQueryList #-} -instance ToQuery a => ToQuery (List1 e a) where - toQuery = toQuery . toList . list1 +instance (KnownSymbol e, ToQuery a) => ToQuery (List e a) where + toQuery = toQueryList n . toList . list + where + n = fromString $ symbolVal (Proxy :: Proxy e) + +instance (KnownSymbol e, ToQuery a) => ToQuery (List1 e a) where + toQuery = toQueryList n . toList . list1 + where + n = fromString $ symbolVal (Proxy :: Proxy e) instance FromJSON a => FromJSON (List e a) where parseJSON = fmap List . parseJSON diff --git a/src/Network/AWS/Data/Internal/Map.hs b/src/Network/AWS/Data/Internal/Map.hs --- a/src/Network/AWS/Data/Internal/Map.hs +++ b/src/Network/AWS/Data/Internal/Map.hs @@ -123,7 +123,7 @@ , ToQuery k , ToQuery v ) => ToQuery (EMap e i j k v) where - toQuery m = toBS e =? (mconcat . zipWith go idx $ toList m) + toQuery m = e =? (mconcat . zipWith go idx $ toList m) where go n (k, v) = toBS n =? toQuery (i, k) <> toQuery (j, v) diff --git a/src/Network/AWS/Data/Internal/Query.hs b/src/Network/AWS/Data/Internal/Query.hs --- a/src/Network/AWS/Data/Internal/Query.hs +++ b/src/Network/AWS/Data/Internal/Query.hs @@ -30,8 +30,7 @@ , (=?) ) where -import Control.Applicative -import Control.Lens hiding (to, from) +import Control.Lens import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS import Data.Data @@ -69,8 +68,10 @@ instance ToByteString Query where toBS = renderQuery +instance ToBuilder Query + instance ToText Query where - toText = Text.decodeUtf8 . renderQuery + toText = Text.decodeUtf8 . toBS instance IsString Query where fromString = toQuery . BS.pack @@ -120,10 +121,6 @@ toQuery (k, v) = Pair (toBS k) (toQuery v) {-# INLINE toQuery #-} -instance (ToByteString k, ToByteString v) => ToQuery (k, Maybe v) where - toQuery (k, v) = Pair (toBS k) . Value $ toBS <$> v - {-# INLINE toQuery #-} - instance ToQuery Char where toQuery = toQuery . BS.singleton {-# INLINE toQuery #-} @@ -139,15 +136,15 @@ instance ToQuery Double where toQuery = toQuery . toBS instance ToQuery Natural where toQuery = toQuery . toBS -instance ToQuery a => ToQuery [a] where - toQuery = List . zipWith (\n v -> Pair (toBS n) (toQuery v)) idx - where - idx = [1..] :: [Integer] - {-# INLINE toQuery #-} - instance ToQuery a => ToQuery (Maybe a) where toQuery (Just x) = toQuery x toQuery Nothing = mempty + {-# INLINE toQuery #-} + +instance ToQuery a => ToQuery [a] where + toQuery = List . zipWith (\n v -> toBS n =? toQuery v) idx + where + idx = [1..] :: [Integer] {-# INLINE toQuery #-} instance ToQuery Bool where diff --git a/src/Network/AWS/Response.hs b/src/Network/AWS/Response.hs --- a/src/Network/AWS/Response.hs +++ b/src/Network/AWS/Response.hs @@ -108,6 +108,7 @@ case f hs o of Left e -> Left (SerializerError a e) Right x -> Right x +{-# INLINE deserialise #-} receive :: forall m a. (MonadResource m, AWSService (Sv a)) => (Abbrev -> ResponseHeaders -> ResponseBody -> m (Response a)) @@ -126,6 +127,7 @@ s = responseStatus rs bdy = responseBody rs hs = responseHeaders rs +{-# INLINE receive #-} sinkLbs :: MonadResource m => ResponseBody -> m LBS.ByteString sinkLbs bdy = liftResourceT (bdy $$+- Conduit.sinkLbs) diff --git a/src/Network/AWS/Signing/V2.hs b/src/Network/AWS/Signing/V2.hs --- a/src/Network/AWS/Signing/V2.hs +++ b/src/Network/AWS/Signing/V2.hs @@ -4,7 +4,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} --- Module : Network.AWS.Signing.V2 +-- Module : Network.AWS.Signaing.V2 -- Copyright : (c) 2013-2014 Brendan Hay -- License : This Source Code Form is subject to the terms of -- the Mozilla Public License, v. 2.0. @@ -29,6 +29,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString.Base64 as Base64 import qualified Data.ByteString.Char8 as BS +import Data.List (intersperse) import Data.Monoid import Data.Time import Network.AWS.Data @@ -44,11 +45,12 @@ , _mTime :: UTCTime } -instance Show (Meta V2) where - show Meta{..} = BS.unpack $ BS.unlines - [ "Version 2 Metadata:" - , "_mSignature " <> _mSignature - , "_mTime " <> toBS _mTime +instance ToBuilder (Meta V2) where + build Meta{..} = mconcat $ intersperse "\n" + [ "[Version 2 Metadata] {" + , " signature = " <> build _mSignature + , " time = " <> build _mTime + , "}" ] instance AWSSigner V2 where diff --git a/src/Network/AWS/Signing/V3.hs b/src/Network/AWS/Signing/V3.hs --- a/src/Network/AWS/Signing/V3.hs +++ b/src/Network/AWS/Signing/V3.hs @@ -28,8 +28,7 @@ import Control.Lens import Data.ByteString (ByteString) import qualified Data.ByteString.Base64 as Base64 -import qualified Data.ByteString.Char8 as BS -import Data.List (sortBy) +import Data.List (sortBy, intersperse) import Data.Maybe import Data.Monoid import Data.Ord @@ -47,11 +46,12 @@ , _mTime :: UTCTime } -instance Show (Meta V3) where - show Meta{..} = BS.unpack $ BS.unlines - [ "Version 3 Metadata:" - , "_mSignature " <> _mSignature - , "_mTime " <> toBS _mTime +instance ToBuilder (Meta V3) where + build Meta{..} = mconcat $ intersperse "\n" + [ "[Version 3 Metadata] {" + , " signature = " <> build _mSignature + , " time = " <> build _mTime + , "}" ] instance AWSSigner V3 where diff --git a/src/Network/AWS/Signing/V4.hs b/src/Network/AWS/Signing/V4.hs --- a/src/Network/AWS/Signing/V4.hs +++ b/src/Network/AWS/Signing/V4.hs @@ -58,16 +58,19 @@ , _mTime :: UTCTime } -instance Show (Meta V4) where - show Meta{..} = BS.unpack $ BS.unlines - [ "Version 4 Metadata:" - , "_mAlgorithm " <> _mAlgorithm - , "_mScope " <> _mScope - , "_mSigned " <> _mSigned - , "_mCReq " <> _mCReq - , "_mSTS " <> _mSTS - , "_mSignature " <> _mSignature - , "_mTime " <> toBS _mTime +instance ToBuilder (Meta V4) where + build Meta{..} = mconcat $ intersperse "\n" + [ "[Version 4 Metadata] {" + , " algorithm = " <> build _mAlgorithm + , " credential scope = " <> build _mScope + , " signed headers = " <> build _mSigned + , " canonical request = {" + , build _mCReq + , " }" + , " string to sign = " <> build _mSTS + , " signature = " <> build _mSignature + , " time = " <> build _mTime + , "}" ] instance AWSPresigner V4 where diff --git a/src/Network/AWS/Types.hs b/src/Network/AWS/Types.hs --- a/src/Network/AWS/Types.hs +++ b/src/Network/AWS/Types.hs @@ -35,10 +35,6 @@ , Auth (..) , withAuth - -- * Logger - , Logger (..) - , debug - -- * Services , Abbrev , AWSService (..) @@ -113,6 +109,7 @@ import qualified Data.HashSet as Set import Data.Hashable import Data.IORef +import Data.List (intersperse) import Data.Monoid import Data.String import Data.Text (Text) @@ -205,7 +202,7 @@ -- | A signed 'ClientRequest' and associated metadata specific to the signing -- algorithm that was used. data Signed a v where - Signed :: Show (Meta v) + Signed :: ToBuilder (Meta v) => { _sgMeta :: Meta v , _sgRequest :: ClientRequest } @@ -217,13 +214,6 @@ sgRequest :: Lens' (Signed a v) ClientRequest sgRequest f (Signed m rq) = f rq <&> \y -> Signed m y -instance ToText (Signed a v) where - toText (Signed m rq) = Text.unlines - [ Text.pack (show m) - , "HTTP Request:" - , Text.pack (show rq) - ] - class AWSSigner v where signed :: (AWSService (Sv a), v ~ Sg (Sv a)) => AuthEnv @@ -297,16 +287,6 @@ withAuth (Auth e) f = f e withAuth (Ref _ r) f = liftIO (readIORef r) >>= f --- | The log level and associated logger function. -data Logger - = None - | Debug (Text -> IO ()) - --- | Log a message using the debug logger, or if none is specified noop. -debug :: MonadIO m => Logger -> Text -> m () -debug None = const (return ()) -debug (Debug f) = liftIO . f - data Endpoint = Endpoint { _endpointHost :: ByteString , _endpointScope :: ByteString @@ -405,14 +385,18 @@ instance Default (Request a) where def = Request GET "/" mempty mempty "" -instance ToText (Request a) where - toText Request{..} = Text.unlines - [ "Request:" - , "_rqMethod = " <> toText _rqMethod - , "_rqPath = " <> toText _rqPath - , "_rqQuery = " <> toText _rqQuery - , "_rqHeaders = " <> toText _rqHeaders - , "_rqBody = " <> toText _rqBody +instance ToBuilder (Request a) where + build Request{..} = mconcat $ intersperse "\n" + [ "[Raw Request] {" + , " method = " <> build _rqMethod + , " path = " <> build _rqPath + , " query = " <> build _rqQuery + , " headers = " <> build _rqHeaders + , " body = {" + , " hash = " <> build (bodyHash _rqBody) + , " payload =\n" <> build (_bdyBody _rqBody) + , " }" + , "}" ] -- | The sum of available AWS regions.