diff --git a/antiope-s3.cabal b/antiope-s3.cabal --- a/antiope-s3.cabal +++ b/antiope-s3.cabal @@ -1,14 +1,15 @@ -cabal-version: 1.12 +cabal-version: 2.2 -- This file has been generated from package.yaml by hpack version 0.31.1. -- -- see: https://github.com/sol/hpack -- --- hash: 282b5f840ecbd3afbb1ec96fe2ccd47819d4fc98e6aa726a4bf9fc86863b8da1 +-- hash: 8a36985fa18723b082538f34eb086ed7df8a972cb70df24354d3250f5503ceb1 name: antiope-s3 -version: 6.4.0 -description: Please see the README on Github at +version: 7.0.0 +synopsis: Please see the README on Github at +description: Please see the README on Github at . category: Services homepage: https://github.com/arbor/antiope#readme bug-reports: https://github.com/arbor/antiope/issues @@ -37,10 +38,7 @@ Antiope.S3.Request Antiope.S3.Strict Antiope.S3.Types - other-modules: - Paths_antiope_s3 - hs-source-dirs: - src + hs-source-dirs: src default-extensions: BangPatterns GeneralizedNewtypeDeriving OverloadedStrings TupleSections ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -msse4.2 build-depends: @@ -49,6 +47,7 @@ , amazonka-core >=1.6 , amazonka-s3 >=1.6 , antiope-core + , antiope-messages , attoparsec , base >=4.7 && <5 , bytestring @@ -58,7 +57,6 @@ , generic-lens , http-types , lens - , monad-logger , mtl , network-uri , resourcet @@ -71,11 +69,10 @@ type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: + Antiope.S3.MessagesSpec Antiope.S3.TypesSpec Antiope.S3Spec - Paths_antiope_s3 - hs-source-dirs: - test + hs-source-dirs: test default-extensions: BangPatterns GeneralizedNewtypeDeriving OverloadedStrings TupleSections ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -msse4.2 -threaded -rtsopts -with-rtsopts=-N build-depends: @@ -93,11 +90,10 @@ , exceptions , generic-lens , hedgehog >=0.5 && <0.7 - , hspec >=2.4 && <2.6 + , hspec >=2.4 && <2.7 , http-types - , hw-hspec-hedgehog >=0.1 && <0.2 + , hw-hspec-hedgehog >=0.1 && <0.3 , lens - , monad-logger , mtl , network-uri , resourcet diff --git a/src/Antiope/S3/Messages.hs b/src/Antiope/S3/Messages.hs --- a/src/Antiope/S3/Messages.hs +++ b/src/Antiope/S3/Messages.hs @@ -1,21 +1,38 @@ -{-# LANGUAGE DeriveGeneric #-} - +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeApplications #-} module Antiope.S3.Messages ( EventName(..) , S3Message(..) - , readEventName + , messageToS3Uri + , fromSnsRecords ) where -import Antiope.S3 (BucketName (..), ETag (..), ObjectKey (..)) -import Data.Aeson as Aeson -import Data.Int (Int64) -import Data.Text (Text) -import Data.Time.Clock (UTCTime) -import GHC.Generics (Generic) +import Antiope.Messages +import Antiope.S3 (BucketName (..), ETag (..), ObjectKey (..)) +import Control.Lens (each, to, (^..), _Just) +import Data.Aeson as Aeson +import Data.Int (Int64) +import Data.Text (Text) +import Data.Time.Clock (UTCTime) +import GHC.Generics (Generic) +import Network.AWS.Data.Text (toText) +import qualified Antiope.S3.Types as Types import qualified Data.Text as T import qualified Data.Text.Encoding as T +import qualified Network.URI as URI +messageToS3Uri :: S3Message -> Types.S3Uri +messageToS3Uri msg = Types.S3Uri (bucket msg) (key msg) + +fromSnsRecords :: Text -> [S3Message] +fromSnsRecords msg = + Aeson.decodeStrict' @(WithEncoded "Message" (With "Records" [S3Message])) (T.encodeUtf8 msg) + ^.. _Just + . to fromWith2 + . each + data EventName = EventName { eventType :: !Text , action :: !Text @@ -27,7 +44,7 @@ , bucket :: !BucketName , key :: !ObjectKey , size :: !Int64 - , etag :: !(Maybe ETag) + , eTag :: !(Maybe ETag) } deriving (Show, Eq, Generic) instance FromJSON S3Message where @@ -38,10 +55,24 @@ bkt <- s3 .: "bucket" obj' <- s3 .: "object" bName <- BucketName <$> (bkt .: "name") - oKey <- ObjectKey <$> (obj' .: "key") + oKey <- (ObjectKey . T.pack . URI.unEscapeString . T.unpack) <$> (obj' .: "key") oSize <- obj' .: "size" oEtag <- fmap (ETag . T.encodeUtf8) <$> (obj' .:? "eTag") pure $ S3Message eTime eName bName oKey oSize oEtag + +instance ToJSON S3Message where + toJSON msg = Aeson.object + [ "eventTime" .= eventTime msg + , "eventName" .= T.intercalate ":" ["s3", eventType (eventName msg), action (eventName msg)] + , "s3" .= Aeson.object + [ "bucket" .= object [ "name" .= toText (bucket msg)] + , "object" .= object + [ "key" .= (T.pack . URI.escapeURIString URI.isAllowedInURI . T.unpack . toText . key) msg + , "size" .= size msg + , "eTag" .= fmap toText (eTag msg) + ] + ] + ] readEventName :: T.Text -> EventName readEventName evt = diff --git a/src/Antiope/S3/Types.hs b/src/Antiope/S3/Types.hs --- a/src/Antiope/S3/Types.hs +++ b/src/Antiope/S3/Types.hs @@ -16,7 +16,6 @@ import Control.Applicative import Control.Lens import Control.Monad -import Control.Monad.Logger (ToLogStr (..)) import Data.Char import Data.Generics.Product.Any import Data.List @@ -48,9 +47,6 @@ instance ToText S3Uri where toText loc = toS3Uri (loc ^. the @"bucket") (loc ^. the @"objectKey") - -instance ToLogStr S3Uri where - toLogStr s = fromString $ T.unpack $ toText s data Range = Range { first :: Int diff --git a/test/Antiope/S3/MessagesSpec.hs b/test/Antiope/S3/MessagesSpec.hs new file mode 100644 --- /dev/null +++ b/test/Antiope/S3/MessagesSpec.hs @@ -0,0 +1,68 @@ +module Antiope.S3.MessagesSpec +where + +import Antiope.S3 (BucketName (..), ETag (..), ObjectKey (..)) +import Antiope.S3.Messages +import Data.Aeson (decode, encode) +import Data.Monoid ((<>)) +import Data.Text (Text, pack) +import Data.Time.Calendar +import Data.Time.Clock + +import qualified Data.Text as Text + +import HaskellWorks.Hspec.Hedgehog +import Hedgehog +import Hedgehog.Gen as Gen +import Hedgehog.Range as Range +import Test.Hspec + +{-# ANN module ("HLint: Ignore Redundant do" :: String) #-} + +genUTCTime :: MonadGen m => m UTCTime +genUTCTime = do + y <- toInteger <$> Gen.int (Range.constant 2000 2019) + m <- Gen.int (Range.constant 1 12) + d <- Gen.int (Range.constant 1 28) + let day = fromGregorian y m d + secs <- toInteger <$> Gen.int (Range.constant 0 86401) + let diff = secondsToDiffTime secs + pure $ UTCTime day diff + +datedPath :: MonadGen m => m Text +datedPath = do + year <- Gen.int (Range.linear 2000 2050) + month <- Gen.int (Range.linear 1 12) + day <- Gen.int (Range.linear 1 28) + let parts = zipWith (\a b -> a <> "=" <> pack (show b)) ["year", "month", "day"] [year, month, day] + pure $ Text.intercalate "/" parts + +randomPath :: MonadGen m => m Text +randomPath = do + parts <- Gen.list (Range.linear 1 5) (Gen.text (Range.linear 1 10) Gen.alphaNum) + pure $ Text.intercalate "/" parts + +s3Message :: MonadGen m => m S3Message +s3Message = do + eName <- Gen.text (Range.linear 1 10) Gen.alphaNum + eType <- Gen.text (Range.linear 1 10) Gen.alphaNum + time <- Gen.maybe genUTCTime + bkt <- Gen.text (Range.linear 1 20) Gen.alphaNum + file <- Gen.text (Range.linear 1 20) Gen.alphaNum + path <- Gen.choice [datedPath, randomPath] + sz <- Gen.int64 (Range.linear 0 maxBound) + etag <- Gen.maybe (Gen.utf8 (Range.singleton 10) Gen.alphaNum) + pure S3Message + { eventTime = time + , eventName = EventName eType eName + , bucket = BucketName bkt + , key = ObjectKey (path <> "/" <> file) + , size = sz + , eTag = fmap ETag etag + } + +spec :: Spec +spec = describe "Antiope.S3.MessagesSpec" $ do + it "Can encode and decode S3Message" $ require $ property $ do + msg <- forAll $ s3Message + tripping msg encode decode