haskell/minio-hs
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Add Bucket Notification APIs (#59)

Browse Source 
- Adds get, put and remove operations

- Also adds more sections to the haddock API doc to make it more
  friendly.
This commit is contained in:
Aditya Manthramurthy 2017-10-25 08:43:35 +00:00 committed by GitHub
parent ee52b3c51c
commit 0d8f5c08e8
7 changed files with 421 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

104
src/Network/Minio.hs
View File

@ -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.

102
src/Network/Minio/Data.hs
View File

@ -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
-- <https://docs.aws.amazon.com/AmazonS3/latest/API/RESTBucketPUTnotification.html>
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

38
src/Network/Minio/S3API.hs
View File

@ -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

49
src/Network/Minio/XmlGenerator.hs
View File

@ -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

56
src/Network/Minio/XmlParser.hs
View File

@ -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)

49
test/Network/Minio/XmlGenerator/Test.hs
View File

@ -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 =
\<PartNumber>1</PartNumber><ETag>abc</ETag>\
\</Part>\
\</CompleteMultipartUpload>"
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
]
]

83
test/Network/Minio/XmlParser/Test.hs
View File

@ -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 = [ ("<NotificationConfiguration xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\
\ <TopicConfiguration>\
\ <Id>YjVkM2Y0YmUtNGI3NC00ZjQyLWEwNGItNDIyYWUxY2I0N2M4</Id>\
\ <Topic>arn:aws:sns:us-east-1:account-id:s3notificationtopic2</Topic>\
\ <Event>s3:ReducedRedundancyLostObject</Event>\
\ <Event>s3:ObjectCreated:*</Event>\
\ </TopicConfiguration>\
\</NotificationConfiguration>",
Notification []
[ NotificationConfig
"YjVkM2Y0YmUtNGI3NC00ZjQyLWEwNGItNDIyYWUxY2I0N2M4"
"arn:aws:sns:us-east-1:account-id:s3notificationtopic2"
[ReducedRedundancyLostObject, ObjectCreated] def
]
[])
, ("<NotificationConfiguration xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\
\ <CloudFunctionConfiguration>\
\ <Id>ObjectCreatedEvents</Id>\
\ <CloudFunction>arn:aws:lambda:us-west-2:35667example:function:CreateThumbnail</CloudFunction>\
\ <Event>s3:ObjectCreated:*</Event>\
\ </CloudFunctionConfiguration>\
\ <QueueConfiguration>\
\ <Id>1</Id>\
\ <Filter>\
\ <S3Key>\
\ <FilterRule>\
\ <Name>prefix</Name>\
\ <Value>images/</Value>\
\ </FilterRule>\
\ <FilterRule>\
\ <Name>suffix</Name>\
\ <Value>.jpg</Value>\
\ </FilterRule>\
\ </S3Key>\
\ </Filter>\
\ <Queue>arn:aws:sqs:us-west-2:444455556666:s3notificationqueue</Queue>\
\ <Event>s3:ObjectCreated:Put</Event>\
\ </QueueConfiguration>\
\ <TopicConfiguration>\
\ <Topic>arn:aws:sns:us-east-1:356671443308:s3notificationtopic2</Topic>\
\ <Event>s3:ReducedRedundancyLostObject</Event>\
\ </TopicConfiguration>\
\ <QueueConfiguration>\
\ <Queue>arn:aws:sqs:us-east-1:356671443308:s3notificationqueue</Queue>\
\ <Event>s3:ObjectCreated:*</Event>\
\ </QueueConfiguration>)\
\</NotificationConfiguration>",
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)