Bucket versioning

src/Network/Minio/Data.hs

@@ -14,6 +14,7 @@
 -- limitations under the License.
 --
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -1001,6 +1002,35 @@ type Stats = Progress
 -- Select API Related Types End
 --------------------------------------------------------------------------
 
+----------------------------------------------
+-- Bucket Versioning Related Types
+----------------------------------------------
+
+data BucketVersioning
+  = BVDisabled
+  | BVSuspended
+  | BVEnabled
+  deriving stock (Eq, Show)
+
+newtype MFAToken = MFAToken {unMfaToken :: Text}
+  deriving stock (Eq, Show)
+  deriving (IsString) via Text
+
+data MFADelete
+  = MFAEnabled MFAToken
+  | MFADisabled
+  deriving stock (Eq, Show)
+
+data BucketVersioningConfig = BVConfig
+  { vcVersioning :: BucketVersioning,
+    vcMFADelete :: MFADelete
+  }
+  deriving stock (Eq, Show)
+
+----------------------------------------------
+-- Bucket Versioning Related Types End
+----------------------------------------------
+
 -- | Represents different kinds of payload that are used with S3 API
 -- requests.
 data Payload

src/Network/Minio/S3API.hs

@@ -96,6 +96,11 @@ module Network.Minio.S3API
     getBucketNotification,
     putBucketNotification,
     removeAllBucketNotification,
+
+    -- * Bucket Versioning
+
+    --------------------------
+    getBucketVersioningConfig,
   )
 where
 
@@ -675,3 +680,14 @@ deleteBucketPolicy bucket = do
           riBucket = Just bucket,
           riQueryParams = [("policy", Nothing)]
         }
+
+getBucketVersioningConfig :: Bucket -> Minio BucketVersioningConfig
+getBucketVersioningConfig bucket = do
+  resp <-
+    executeRequest $
+      defaultS3ReqInfo
+        { riMethod = HT.methodGet,
+          riBucket = Just bucket,
+          riQueryParams = [("versioning", Nothing)]
+        }
+  parseBucketVersioningConfig $ NC.responseBody resp

src/Network/Minio/XmlGenerator.hs

@@ -19,6 +19,7 @@ module Network.Minio.XmlGenerator
     mkCompleteMultipartUploadRequest,
     mkPutNotificationRequest,
     mkSelectRequest,
+    mkBucketVersioningConfig,
   )
 where
 
@@ -228,3 +229,26 @@ mkSelectRequest r = LBS.toStrict $ renderLBS def sr
             mempty
             [NodeContent t]
       ]
+
+mkBucketVersioningConfig :: BucketVersioningConfig -> ByteString
+mkBucketVersioningConfig bv = LBS.toStrict $ renderLBS def sr
+  where
+    sr = Document (Prologue [] Nothing []) root []
+    mfaElem = case vcMFADelete bv of
+      MFAEnabled token -> [NodeElement $ Element "MFADelete" mempty [NodeContent (coerce token)]]
+      MFADisabled -> []
+    statusElem = case vcVersioning bv of
+      BVSuspended -> [NodeElement $ Element "Status" mempty [NodeContent "Suspended"]]
+      BVEnabled -> [NodeElement $ Element "Status" mempty [NodeContent "Enabled"]]
+      _ -> []
+    root =
+      Element
+        { elementName =
+            Name
+              { nameLocalName = "VersioningConfiguration",
+                nameNamespace = Just "http://s3.amazonaws.com/doc/2006-03-01/",
+                namePrefix = Nothing
+              },
+          elementAttributes = mempty,
+          elementNodes = statusElem <> mfaElem
+        }

src/Network/Minio/XmlParser.hs

@@ -27,6 +27,7 @@ module Network.Minio.XmlParser
     parseErrResponse,
     parseNotification,
     parseSelectProgress,
+    parseBucketVersioningConfig,
   )
 where
 
@@ -272,3 +273,30 @@ parseSelectProgress xmldata = do
     <$> parseDecimal bScanned
     <*> parseDecimal bProcessed
     <*> parseDecimal bReturned
+
+parseBucketVersioningConfig ::
+  (MonadReader env m, HasSvcNamespace env, MonadIO m) =>
+  LByteString ->
+  m BucketVersioningConfig
+parseBucketVersioningConfig xmldata = do
+  r <- parseRoot xmldata
+  ns <- asks getSvcNamespace
+  let s3Elem' = s3Elem ns
+  let status = T.concat $ r $/ s3Elem' "Status" &/ content
+      mfaToken = MFAToken $ T.concat $ r $/ s3Elem' "MfaDelete" &/ content
+      bv = case status of
+        "Enabled" -> BVEnabled
+        "Suspended" -> BVSuspended
+        _ -> BVDisabled
+      mfaDel = case mfaToken of
+        "" -> MFADisabled
+        _ -> MFAEnabled mfaToken
+
+  return $ BVConfig bv mfaDel
+
+{-
+<VersioningConfiguration>
+   <Status>string</Status>
+   <MfaDelete>string</MfaDelete>
+</VersioningConfiguration>
+-}

test/Network/Minio/XmlParser/Test.hs

@@ -45,7 +45,8 @@ xmlParserTests =
       testCase "Test parseListPartsResponse" testParseListPartsResponse,
       testCase "Test parseCopyObjectResponse" testParseCopyObjectResponse,
       testCase "Test parseNotification" testParseNotification,
-      testCase "Test parseSelectProgress" testParseSelectProgress
+      testCase "Test parseSelectProgress" testParseSelectProgress,
+      testCase "Test parseBucketVersioningConfig" testParseBucketVersioningConfig
     ]
 
 tryValidationErr :: (MonadUnliftIO m) => m a -> m (Either MErrV a)
@@ -401,3 +402,25 @@ testParseSelectProgress = do
   forM_ cases $ \(xmldata, progress) -> do
     result <- runExceptT $ parseSelectProgress xmldata
     eitherValidationErr result (@?= progress)
+
+testParseBucketVersioningConfig :: Assertion
+testParseBucketVersioningConfig = do
+  let cases =
+        [ ( [r|<VersioningConfiguration xmlns="http://s3.amazonaws.com/doc/2006-03-01/">
+                  <Status>Enabled</Status>
+               </VersioningConfiguration>|],
+            BVConfig BVEnabled MFADisabled
+          ),
+          ( [r|<VersioningConfiguration xmlns="http://s3.amazonaws.com/doc/2006-03-01/">
+                  <Status>Suspended</Status>
+               </VersioningConfiguration>|],
+            BVConfig BVSuspended MFADisabled
+          ),
+          ( [r|<VersioningConfiguration xmlns="http://s3.amazonaws.com/doc/2006-03-01/"/>|],
+            BVConfig BVDisabled MFADisabled
+          )
+        ]
+
+  forM_ cases $ \(xmldata, vcfg) -> do
+    result <- runExceptT $ runTestNS $ parseBucketVersioningConfig xmldata
+    eitherValidationErr result (@?= vcfg)