diff --git a/src/Network/Minio.hs b/src/Network/Minio.hs index 38dabdd..e08fd77 100644 --- a/src/Network/Minio.hs +++ b/src/Network/Minio.hs @@ -19,61 +19,86 @@ module Network.Minio ( + -- * Connecting to object storage + --------------------------------- ConnectInfo(..) , awsCI - + -- ** Connection helpers + ------------------------ , awsWithRegionCI , minioPlayCI , minioCI + -- * Minio Monad + ---------------- + -- | The Minio monad provides connection-reuse, bucket-location + -- caching, resource management and simpler error handling + -- functionality. All actions on object storage are performed within + -- this Monad. + , Minio , runMinio , def - -- * Error handling - ----------------------- - -- | Data types representing various errors that may occur while working - -- with an object storage service. - , MinioErr(..) - , MErrV(..) - , ServiceErr(..) - - -- * Data Types - ---------------- - -- | Data types representing various object store concepts. - , Bucket - , Object - , BucketInfo(..) - , ObjectInfo(..) - , UploadInfo(..) - , ObjectPartInfo(..) - , UploadId - , ObjectData(..) - , CopyPartSource(..) - -- * Bucket Operations ---------------------- - , listBuckets - , getLocation - , bucketExists + + -- ** Creation, removal and querying + , Bucket , makeBucket , removeBucket + , bucketExists + , Region + , getLocation + -- ** Listing + , BucketInfo(..) + , listBuckets + , ObjectInfo(..) , listObjects , listObjectsV1 + , UploadId + , UploadInfo(..) , listIncompleteUploads + , ObjectPartInfo(..) + , listIncompleteParts + + -- ** Notifications + , Notification(..) + , NotificationConfig(..) + , Arn + , Event(..) + , Filter(..) + , FilterKey(..) + , FilterRules(..) + , FilterRule(..) + , getBucketNotification + , putBucketNotification + , removeAllBucketNotification -- * Object Operations ---------------------- + + , Object + + -- ** File operations , fGetObject , fPutObject - , putObject - , copyObject - , removeObject + -- ** Conduit-based streaming operations + , putObject , getObject + + -- ** Server-side copying + , CopyPartSource(..) + , copyObject + + -- ** Querying , statObject + + -- ** Object removal functions + , removeObject , removeIncompleteUpload -- * Presigned Operations @@ -83,6 +108,14 @@ module Network.Minio , presignedGetObjectUrl , presignedHeadObjectUrl + -- ** Utilities for POST (browser) uploads + , PostPolicy + , PostPolicyError(..) + , newPostPolicy + , presignedPostPolicy + , showPostPolicy + + -- *** Utilities to specify Post Policy conditions , PostPolicyCondition , ppCondBucket , ppCondContentLengthRange @@ -91,12 +124,15 @@ module Network.Minio , ppCondKeyStartsWith , ppCondSuccessActionStatus - , PostPolicy - , PostPolicyError(..) - , newPostPolicy - , presignedPostPolicy - , showPostPolicy - ) where + -- * Error handling + ----------------------- + -- | Data types representing various errors that may occur while working + -- with an object storage service. + , MinioErr(..) + , MErrV(..) + , ServiceErr(..) + +) where {- This module exports the high-level Minio API for object storage. diff --git a/src/Network/Minio/Data.hs b/src/Network/Minio/Data.hs index 500a776..ddb6b0c 100644 --- a/src/Network/Minio/Data.hs +++ b/src/Network/Minio/Data.hs @@ -34,6 +34,8 @@ import qualified Network.HTTP.Types as HT import Network.Minio.Errors import Text.XML +import GHC.Show (Show(..)) + import Lib.Prelude @@ -280,6 +282,106 @@ cpsToObject cps = do where splits = T.splitOn "/" $ cpSource cps +-- | A data-type for events that can occur in the object storage +-- server. Reference: +-- https://docs.aws.amazon.com/AmazonS3/latest/dev/NotificationHowTo.html#supported-notification-event-types +data Event = ObjectCreated + | ObjectCreatedPut + | ObjectCreatedPost + | ObjectCreatedCopy + | ObjectCreatedMultipartUpload + | ObjectRemoved + | ObjectRemovedDelete + | ObjectRemovedDeleteMarkerCreated + | ReducedRedundancyLostObject + deriving (Eq) + +instance Show Event where + show ObjectCreated = "s3:ObjectCreated:*" + show ObjectCreatedPut = "s3:ObjectCreated:Put" + show ObjectCreatedPost = "s3:ObjectCreated:Post" + show ObjectCreatedCopy = "s3:ObjectCreated:Copy" + show ObjectCreatedMultipartUpload = "s3:ObjectCreated:MultipartUpload" + show ObjectRemoved = "s3:ObjectRemoved:*" + show ObjectRemovedDelete = "s3:ObjectRemoved:Delete" + show ObjectRemovedDeleteMarkerCreated = "s3:ObjectRemoved:DeleteMarkerCreated" + show ReducedRedundancyLostObject = "s3:ReducedRedundancyLostObject" + +textToEvent :: Text -> Maybe Event +textToEvent t = case t of + "s3:ObjectCreated:*" -> Just ObjectCreated + "s3:ObjectCreated:Put" -> Just ObjectCreatedPut + "s3:ObjectCreated:Post" -> Just ObjectCreatedPost + "s3:ObjectCreated:Copy" -> Just ObjectCreatedCopy + "s3:ObjectCreated:MultipartUpload" -> Just ObjectCreatedMultipartUpload + "s3:ObjectRemoved:*" -> Just ObjectRemoved + "s3:ObjectRemoved:Delete" -> Just ObjectRemovedDelete + "s3:ObjectRemoved:DeleteMarkerCreated" -> Just ObjectRemovedDeleteMarkerCreated + "s3:ReducedRedundancyLostObject" -> Just ReducedRedundancyLostObject + _ -> Nothing + + +data Filter = Filter + { fFilter :: FilterKey + } deriving (Show, Eq) + +instance Default Filter where + def = Filter def + +data FilterKey = FilterKey + { fkKey :: FilterRules + } deriving (Show, Eq) + +instance Default FilterKey where + def = FilterKey def + +data FilterRules = FilterRules + { frFilterRules :: [FilterRule] + } deriving (Show, Eq) + +instance Default FilterRules where + def = FilterRules [] + +-- | A filter rule that can act based on the suffix or prefix of an +-- object. As an example, let's create two filter rules: +-- +-- > let suffixRule = FilterRule "suffix" ".jpg" +-- > let prefixRule = FilterRule "prefix" "images/" +-- +-- The `suffixRule` restricts the notification to be triggered only +-- for objects having a suffix of ".jpg", and the `prefixRule` +-- restricts it to objects having a prefix of "images/". +data FilterRule = FilterRule + { frName :: Text + , frValue :: Text + } deriving (Show, Eq) + +type Arn = Text + +-- | A data-type representing the configuration for a particular +-- notification system. It could represent a Queue, Topic or Lambda +-- Function configuration. +data NotificationConfig = NotificationConfig + { ncId :: Text + , ncArn :: Arn + , ncEvents :: [Event] + , ncFilter :: Filter + } deriving (Show, Eq) + +-- | A data-type to represent bucket notification configuration. It is +-- a collection of queue, topic or lambda function configurations. The +-- structure of the types follow closely the XML representation +-- described at +-- +data Notification = Notification + { nQueueConfigurations :: [NotificationConfig] + , nTopicConfigurations :: [NotificationConfig] + , nCloudFunctionConfigurations :: [NotificationConfig] + } deriving (Eq, Show) + +instance Default Notification where + def = Notification [] [] [] + -- | Represents different kinds of payload that are used with S3 API -- requests. data Payload = PayloadBS ByteString diff --git a/src/Network/Minio/S3API.hs b/src/Network/Minio/S3API.hs index 76c998a..3f11caa 100644 --- a/src/Network/Minio/S3API.hs +++ b/src/Network/Minio/S3API.hs @@ -32,6 +32,7 @@ module Network.Minio.S3API -- * Retrieving buckets , headBucket + -- * Retrieving objects ----------------------- , getObject' @@ -69,6 +70,20 @@ module Network.Minio.S3API -- * Presigned Operations ----------------------------- , module Network.Minio.PresignedOperations + + -- * Bucket Notifications + ------------------------- + , Notification(..) + , NotificationConfig(..) + , Arn + , Event(..) + , Filter(..) + , FilterKey(..) + , FilterRules(..) + , FilterRule(..) + , getBucketNotification + , putBucketNotification + , removeAllBucketNotification ) where import Control.Monad.Catch (catches, Handler(..)) @@ -382,3 +397,26 @@ headBucket bucket = headBucketEx `catches` , riBucket = Just bucket } return $ NC.responseStatus resp == HT.ok200 + +-- | Set the notification configuration on a bucket. +putBucketNotification :: Bucket -> Notification -> Minio () +putBucketNotification bucket ncfg = + void $ executeRequest $ def { riMethod = HT.methodPut + , riBucket = Just bucket + , riQueryParams = [("notification", Nothing)] + , riPayload = PayloadBS $ + mkPutNotificationRequest ncfg + } + +-- | Retrieve the notification configuration on a bucket. +getBucketNotification :: Bucket -> Minio Notification +getBucketNotification bucket = do + resp <- executeRequest $ def { riMethod = HT.methodGet + , riBucket = Just bucket + , riQueryParams = [("notification", Nothing)] + } + parseNotification $ NC.responseBody resp + +-- | Remove all notifications configured on a bucket. +removeAllBucketNotification :: Bucket -> Minio () +removeAllBucketNotification = flip putBucketNotification def diff --git a/src/Network/Minio/XmlGenerator.hs b/src/Network/Minio/XmlGenerator.hs index b6576a7..0de27ff 100644 --- a/src/Network/Minio/XmlGenerator.hs +++ b/src/Network/Minio/XmlGenerator.hs @@ -17,12 +17,13 @@ module Network.Minio.XmlGenerator ( mkCreateBucketConfig , mkCompleteMultipartUploadRequest + , mkPutNotificationRequest ) where import qualified Data.ByteString.Lazy as LBS -import qualified Data.Map as M -import qualified Data.Text as T +import qualified Data.Map as M +import qualified Data.Text as T import Text.XML import Lib.Prelude @@ -55,3 +56,47 @@ mkCompleteMultipartUploadRequest partInfo = [NodeContent etag] ] cmur = Document (Prologue [] Nothing []) root [] + +-- Simplified XML representation without element attributes. +data XNode = XNode Text [XNode] + | XLeaf Text Text + deriving (Eq, Show) + +toXML :: XNode -> ByteString +toXML node = LBS.toStrict $ renderLBS def $ + Document (Prologue [] Nothing []) (xmlNode node) [] + where + xmlNode :: XNode -> Element + xmlNode (XNode name nodes) = Element (s3Name name) M.empty $ + map (NodeElement . xmlNode) nodes + xmlNode (XLeaf name content) = Element (s3Name name) M.empty + [NodeContent content] + +class ToXNode a where + toXNode :: a -> XNode + +instance ToXNode Event where + toXNode = XLeaf "Event" . show + +instance ToXNode Notification where + toXNode (Notification qc tc lc) = XNode "NotificationConfiguration" $ + map (toXNodesWithArnName "QueueConfiguration" "Queue") qc ++ + map (toXNodesWithArnName "TopicConfiguration" "Topic") tc ++ + map (toXNodesWithArnName "CloudFunctionConfiguration" "CloudFunction") lc + +toXNodesWithArnName :: Text -> Text -> NotificationConfig -> XNode +toXNodesWithArnName eltName arnName (NotificationConfig id arn events fRule) = + XNode eltName $ [XLeaf "Id" id, XLeaf arnName arn] ++ map toXNode events ++ + [toXNode fRule] + +instance ToXNode Filter where + toXNode (Filter (FilterKey (FilterRules rules))) = + XNode "Filter" [XNode "S3Key" (map getFRXNode rules)] + +getFRXNode :: FilterRule -> XNode +getFRXNode (FilterRule n v) = XNode "FilterRule" [ XLeaf "Name" n + , XLeaf "Value" v + ] + +mkPutNotificationRequest :: Notification -> ByteString +mkPutNotificationRequest = toXML . toXNode diff --git a/src/Network/Minio/XmlParser.hs b/src/Network/Minio/XmlParser.hs index f1bf7c7..5ee47f6 100644 --- a/src/Network/Minio/XmlParser.hs +++ b/src/Network/Minio/XmlParser.hs @@ -25,15 +25,16 @@ module Network.Minio.XmlParser , parseListUploadsResponse , parseListPartsResponse , parseErrResponse + , parseNotification ) where import Control.Monad.Trans.Resource -import Data.List (zip3, zip4) -import qualified Data.Text as T -import Data.Text.Read (decimal) +import Data.List (zip3, zip4) +import qualified Data.Text as T +import Data.Text.Read (decimal) import Data.Time import Text.XML -import Text.XML.Cursor hiding (bool) +import Text.XML.Cursor hiding (bool) import Lib.Prelude @@ -56,7 +57,8 @@ parseS3XMLTime = either (throwM . MErrVXmlParse) return . T.unpack parseDecimal :: (MonadThrow m, Integral a) => Text -> m a -parseDecimal numStr = either (throwM . MErrVXmlParse . show) return $ fst <$> decimal numStr +parseDecimal numStr = either (throwM . MErrVXmlParse . show) return $ + fst <$> decimal numStr parseDecimals :: (MonadThrow m, Integral a) => [Text] -> m [a] parseDecimals numStr = forM numStr parseDecimal @@ -87,15 +89,13 @@ parseLocation xmldata = do return $ bool "us-east-1" region $ region /= "" -- | Parse the response XML of an newMultipartUpload call. -parseNewMultipartUpload :: (MonadThrow m) - => LByteString -> m UploadId +parseNewMultipartUpload :: (MonadThrow m) => LByteString -> m UploadId parseNewMultipartUpload xmldata = do r <- parseRoot xmldata return $ T.concat $ r $// s3Elem "UploadId" &/ content -- | Parse the response XML of completeMultipartUpload call. -parseCompleteMultipartUploadResponse :: (MonadThrow m) - => LByteString -> m ETag +parseCompleteMultipartUploadResponse :: (MonadThrow m) => LByteString -> m ETag parseCompleteMultipartUploadResponse xmldata = do r <- parseRoot xmldata return $ T.concat $ r $// s3Elem "ETag" &/ content @@ -139,8 +139,7 @@ parseListObjectsV1Response xmldata = do return $ ListObjectsV1Result hasMore nextMarker objects prefixes -- | Parse the response XML of a list objects call. -parseListObjectsResponse :: (MonadThrow m) - => LByteString -> m ListObjectsResult +parseListObjectsResponse :: (MonadThrow m) => LByteString -> m ListObjectsResult parseListObjectsResponse xmldata = do r <- parseRoot xmldata let @@ -167,8 +166,7 @@ parseListObjectsResponse xmldata = do return $ ListObjectsResult hasMore nextToken objects prefixes -- | Parse the response XML of a list incomplete multipart upload call. -parseListUploadsResponse :: (MonadThrow m) - => LByteString -> m ListUploadsResult +parseListUploadsResponse :: (MonadThrow m) => LByteString -> m ListUploadsResult parseListUploadsResponse xmldata = do r <- parseRoot xmldata let @@ -187,8 +185,7 @@ parseListUploadsResponse xmldata = do return $ ListUploadsResult hasMore nextKey nextUpload uploads prefixes -parseListPartsResponse :: (MonadThrow m) - => LByteString -> m ListPartsResult +parseListPartsResponse :: (MonadThrow m) => LByteString -> m ListPartsResult parseListPartsResponse xmldata = do r <- parseRoot xmldata let @@ -211,10 +208,35 @@ parseListPartsResponse xmldata = do return $ ListPartsResult hasMore (listToMaybe nextPartNum) partInfos -parseErrResponse :: (MonadThrow m) - => LByteString -> m ServiceErr +parseErrResponse :: (MonadThrow m) => LByteString -> m ServiceErr parseErrResponse xmldata = do r <- parseRoot xmldata let code = T.concat $ r $/ element "Code" &/ content message = T.concat $ r $/ element "Message" &/ content return $ toServiceErr code message + +parseNotification :: (MonadThrow m) => LByteString -> m Notification +parseNotification xmldata = do + r <- parseRoot xmldata + let qcfg = map node $ r $/ s3Elem "QueueConfiguration" + tcfg = map node $ r $/ s3Elem "TopicConfiguration" + lcfg = map node $ r $/ s3Elem "CloudFunctionConfiguration" + Notification <$> (mapM (parseNode "Queue") qcfg) + <*> (mapM (parseNode "Topic") tcfg) + <*> (mapM (parseNode "CloudFunction") lcfg) + where + + getFilterRule c = + let name = T.concat $ c $/ s3Elem "Name" &/ content + value = T.concat $ c $/ s3Elem "Value" &/ content + in FilterRule name value + + parseNode arnName nodeData = do + let c = fromNode nodeData + id = T.concat $ c $/ s3Elem "Id" &/ content + arn = T.concat $ c $/ s3Elem arnName &/ content + events = catMaybes $ map textToEvent $ c $/ s3Elem "Event" &/ content + rules = c $/ s3Elem "Filter" &/ s3Elem "S3Key" &/ + s3Elem "FilterRule" &| getFilterRule + return $ NotificationConfig id arn events + (Filter $ FilterKey $ FilterRules rules) diff --git a/test/Network/Minio/XmlGenerator/Test.hs b/test/Network/Minio/XmlGenerator/Test.hs index 5978ee6..b691308 100644 --- a/test/Network/Minio/XmlGenerator/Test.hs +++ b/test/Network/Minio/XmlGenerator/Test.hs @@ -18,17 +18,22 @@ module Network.Minio.XmlGenerator.Test ( xmlGeneratorTests ) where -import Test.Tasty -import Test.Tasty.HUnit +import Test.Tasty +import Test.Tasty.HUnit -import Lib.Prelude +import Lib.Prelude -import Network.Minio.XmlGenerator +import Data.Default (def) + +import Network.Minio.Data +import Network.Minio.XmlGenerator +import Network.Minio.XmlParser (parseNotification) xmlGeneratorTests :: TestTree xmlGeneratorTests = testGroup "XML Generator Tests" [ testCase "Test mkCreateBucketConfig" testMkCreateBucketConfig , testCase "Test mkCompleteMultipartUploadRequest" testMkCompleteMultipartUploadRequest + , testCase "Test mkPutNotificationRequest" testMkPutNotificationRequest ] testMkCreateBucketConfig :: Assertion @@ -52,3 +57,39 @@ testMkCompleteMultipartUploadRequest = \1abc\ \\ \" + +testMkPutNotificationRequest :: Assertion +testMkPutNotificationRequest = + forM_ cases $ \val -> do + let result = toS $ mkPutNotificationRequest val + ntf <- runExceptT $ parseNotification result + either (\_ -> assertFailure "XML Parse Error!") + (@?= val) ntf + where + cases = [ Notification [] + [ NotificationConfig + "YjVkM2Y0YmUtNGI3NC00ZjQyLWEwNGItNDIyYWUxY2I0N2M4" + "arn:aws:sns:us-east-1:account-id:s3notificationtopic2" + [ReducedRedundancyLostObject, ObjectCreated] def + ] + [] + , Notification + [ NotificationConfig + "1" "arn:aws:sqs:us-west-2:444455556666:s3notificationqueue" + [ObjectCreatedPut] + (Filter $ FilterKey $ FilterRules + [ FilterRule "prefix" "images/" + , FilterRule "suffix" ".jpg"]) + , NotificationConfig + "" "arn:aws:sqs:us-east-1:356671443308:s3notificationqueue" + [ObjectCreated] def + ] + [ NotificationConfig + "" "arn:aws:sns:us-east-1:356671443308:s3notificationtopic2" + [ReducedRedundancyLostObject] def + ] + [ NotificationConfig + "ObjectCreatedEvents" "arn:aws:lambda:us-west-2:35667example:function:CreateThumbnail" + [ObjectCreated] def + ] + ] diff --git a/test/Network/Minio/XmlParser/Test.hs b/test/Network/Minio/XmlParser/Test.hs index d27f997..787571b 100644 --- a/test/Network/Minio/XmlParser/Test.hs +++ b/test/Network/Minio/XmlParser/Test.hs @@ -19,13 +19,15 @@ module Network.Minio.XmlParser.Test xmlParserTests ) where -import qualified Control.Monad.Catch as MC -import Data.Time (fromGregorian) +import qualified Control.Monad.Catch as MC +import Data.Time (fromGregorian) import Test.Tasty import Test.Tasty.HUnit import Lib.Prelude +import Data.Default (def) + import Network.Minio.Data import Network.Minio.Errors import Network.Minio.XmlParser @@ -40,6 +42,7 @@ xmlParserTests = testGroup "XML Parser Tests" , testCase "Test parseCompleteMultipartUploadResponse" testParseCompleteMultipartUploadResponse , testCase "Test parseListPartsResponse" testParseListPartsResponse , testCase "Test parseCopyObjectResponse" testParseCopyObjectResponse + , testCase "Test parseNotification" testParseNotification ] tryValidationErr :: (MC.MonadCatch m) => m a -> m (Either MErrV a) @@ -49,7 +52,7 @@ assertValidtionErr :: MErrV -> Assertion assertValidtionErr e = assertFailure $ "Failed due to validation error => " ++ show e eitherValidationErr :: Either MErrV a -> (a -> Assertion) -> Assertion -eitherValidationErr (Left e) _ = assertValidtionErr e +eitherValidationErr (Left e) _ = assertValidtionErr e eitherValidationErr (Right a) f = f a testParseLocation :: Assertion @@ -279,3 +282,77 @@ testParseCopyObjectResponse = do forM_ cases $ \(xmldata, (etag, modTime)) -> do parseResult <- runExceptT $ parseCopyObjectResponse xmldata eitherValidationErr parseResult (@?= (etag, modTime)) + +testParseNotification :: Assertion +testParseNotification = do + let + cases = [ ("\ +\ \ +\ YjVkM2Y0YmUtNGI3NC00ZjQyLWEwNGItNDIyYWUxY2I0N2M4\ +\ arn:aws:sns:us-east-1:account-id:s3notificationtopic2\ +\ s3:ReducedRedundancyLostObject\ +\ s3:ObjectCreated:*\ +\ \ +\", + Notification [] + [ NotificationConfig + "YjVkM2Y0YmUtNGI3NC00ZjQyLWEwNGItNDIyYWUxY2I0N2M4" + "arn:aws:sns:us-east-1:account-id:s3notificationtopic2" + [ReducedRedundancyLostObject, ObjectCreated] def + ] + []) + , ("\ +\ \ +\ ObjectCreatedEvents\ +\ arn:aws:lambda:us-west-2:35667example:function:CreateThumbnail\ +\ s3:ObjectCreated:*\ +\ \ +\ \ +\ 1\ +\ \ +\ \ +\ \ +\ prefix\ +\ images/\ +\ \ +\ \ +\ suffix\ +\ .jpg\ +\ \ +\ \ +\ \ +\ arn:aws:sqs:us-west-2:444455556666:s3notificationqueue\ +\ s3:ObjectCreated:Put\ +\ \ +\ \ +\ arn:aws:sns:us-east-1:356671443308:s3notificationtopic2\ +\ s3:ReducedRedundancyLostObject\ +\ \ +\ \ +\ arn:aws:sqs:us-east-1:356671443308:s3notificationqueue\ +\ s3:ObjectCreated:*\ +\ )\ +\", + Notification [ NotificationConfig + "1" "arn:aws:sqs:us-west-2:444455556666:s3notificationqueue" + [ObjectCreatedPut] + (Filter $ FilterKey $ FilterRules + [FilterRule "prefix" "images/", + FilterRule "suffix" ".jpg"]) + , NotificationConfig + "" "arn:aws:sqs:us-east-1:356671443308:s3notificationqueue" + [ObjectCreated] def + ] + [ NotificationConfig + "" "arn:aws:sns:us-east-1:356671443308:s3notificationtopic2" + [ReducedRedundancyLostObject] def + ] + [ NotificationConfig + "ObjectCreatedEvents" "arn:aws:lambda:us-west-2:35667example:function:CreateThumbnail" + [ObjectCreated] def + ]) + ] + + forM_ cases $ \(xmldata, val) -> do + result <- runExceptT $ parseNotification xmldata + eitherValidationErr result (@?= val)