Add listObjects s3api.

src/Network/Minio/Data.hs

@@ -1,26 +1,5 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies #-}
-module Network.Minio.Data
-  ( ConnectInfo(..)
-  , RequestInfo(..)
-  , MinioConn(..)
-  , Bucket
-  , Object
-  , Region
-  , BucketInfo(..)
-  , PartNumber
-  , UploadId
-  , ETag
-  , PartInfo(..)
-  , getPathFromRI
-  , getRegionFromRI
-  , Minio
-  , MinioErr(..)
-  , MErrV(..)
-  , runMinio
-  , connect
-  , Payload(..)
-  , s3Name
-  ) where
+module Network.Minio.Data where
 
 import qualified Data.ByteString as B
 import           Network.HTTP.Client (defaultManagerSettings, HttpException)
@@ -87,6 +66,21 @@ data PartInfo = PartInfo PartNumber ETag
 instance Ord PartInfo where
   (PartInfo a _) `compare` (PartInfo b _) = a `compare` b
 
+
+data ListObjectsResult = ListObjectsResult {
+    lorHasMore :: Bool
+  , lorNextToken :: Maybe Text
+  , lorObjects :: [ObjectInfo]
+  , lorCPrefixes :: [Text]
+  } deriving (Show, Eq)
+
+data ObjectInfo = ObjectInfo {
+    oiObject :: Object
+  , oiModTime :: UTCTime
+  , oiETag :: ETag
+  , oiSize :: Int64
+  } deriving (Show, Eq)
+
 data Payload = PayloadBS ByteString
              | PayloadH Handle
                         Int64 -- offset

src/Network/Minio/S3API.hs

@@ -6,6 +6,9 @@ module Network.Minio.S3API
   --------------------
   , getService
 
+  -- * Listing objects
+  --------------------
+  , listObjects
 
   -- * Retrieving objects
   -----------------------
@@ -101,6 +104,25 @@ putObject bucket object headers h offset size = do
         , riPayload = PayloadH h offset size
         }
 
+listObjects :: Bucket -> Maybe Text -> Maybe Text -> Maybe Text
+            -> Minio ListObjectsResult
+listObjects bucket prefix nextToken delimiter = do
+  resp <- executeRequest $ def { riMethod = HT.methodGet
+                               , riBucket = Just bucket
+                               , riQueryParams = ("list-type", Just "2") : qp
+                               }
+  parseListObjectsResponse $ NC.responseBody resp
+  where
+    -- build optional query params
+    ctokList = map ((\k -> ("continuation_token", k)) . Just . encodeUtf8) $
+               maybeToList nextToken
+    prefixList = map ((\k -> ("prefix", k)) . Just . encodeUtf8) $
+                 maybeToList prefix
+    delimList = map ((\k -> ("delimiter", k)) . Just . encodeUtf8) $
+                maybeToList delimiter
+    qp = concat [ctokList, prefixList, delimList]
+
+
 -- | DELETE a bucket from the service.
 deleteBucket :: Bucket -> Minio ()
 deleteBucket bucket = do

src/Network/Minio/XmlParser.hs

@@ -3,12 +3,15 @@ module Network.Minio.XmlParser
   , parseLocation
   , parseNewMultipartUpload
   , parseCompleteMultipartUploadResponse
+  , parseListObjectsResponse
   ) where
 
 import Text.XML
 import Text.XML.Cursor
 import qualified Data.Text as T
 import Data.Time
+import Data.Text.Read (decimal)
+import Data.List (zip4)
 
 import           Lib.Prelude
 
@@ -53,3 +56,50 @@ parseCompleteMultipartUploadResponse xmldata = do
   doc <- either (throwError . MErrXml . show) return $ parseLBS def xmldata
   return $ T.concat $ fromDocument doc
     $// element (s3Name "ETag") &/ content
+
+parseListObjectsResponse :: (MonadError MinioErr m)
+                         => LByteString -> m ListObjectsResult
+parseListObjectsResponse xmldata = do
+  doc <- either (throwError . MErrXml . show) return $ parseLBS def xmldata
+
+  let
+    root = fromDocument doc
+    s3Elem = element . s3Name
+
+    hasMore :: Bool
+    hasMore = "true" == (T.concat $ contentOfChildElem root "IsTruncated")
+
+    nextToken :: Maybe Text
+    nextToken = listToMaybe $ contentOfChildElem root "NextContinuationToken"
+
+    cPrefTags :: [Cursor]
+    cPrefTags = child root >>= element (s3Name "CommonPrefixes")
+
+    prefixes :: [Text]
+    prefixes = cPrefTags >>= flip contentOfChildElem "Prefix"
+
+    keys = root $/ s3Elem "Contents" &/ s3Elem "Key" &/ content
+    modTimeStr = root $/ s3Elem "Contents" &/ s3Elem "LastModified" &/ content
+    etags = root $/ s3Elem "Contents" &/ s3Elem "ETag" &/ content
+    sizeStr = root $/ s3Elem "Contents" &/ s3Elem "Size" &/ content
+
+
+  modTimes <- either (throwError . MErrXml) return $
+    mapM (parseTimeM True defaultTimeLocale s3TimeFormat . T.unpack) $
+    modTimeStr
+
+  sizes <- forM sizeStr $ \str ->
+    either (throwError . MErrXml . show) return $ fst <$> decimal str
+
+  let objects = map (uncurry4 ObjectInfo) $ zip4 keys modTimes etags sizes
+  return $ ListObjectsResult hasMore nextToken objects prefixes
+
+  where
+    uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e
+    uncurry4 f (a, b, c, d) = f a b c d
+
+    -- get content of children with given cursor and child-element name.
+    contentOfChildElem :: Cursor -> Text -> [Text]
+    contentOfChildElem cursor elemName = child cursor >>=
+                                         element (s3Name elemName) >>=
+                                         content

test/Spec.hs

@@ -12,6 +12,7 @@ import Data.Default (Default(..))
 -- import Data.Conduit.Binary
 
 import Network.Minio
+import Network.Minio.Data
 import Network.Minio.S3API
 import Network.Minio.XmlGenerator.Test
 import Network.Minio.XmlParser.Test
@@ -112,6 +113,25 @@ liveServerUnitTests = testGroup "Unit tests against a live server"
 
       step $ "Cleanup actions"
       deleteObject bucket object
+
+  , funTestWithBucket "Basic listObjects Test" "testbucket3" $ \step bucket -> do
+      step "put 10 objects"
+      forM_ [1..10] $ \s ->
+        fPutObject bucket (T.concat ["lsb-release", T.pack (show s)]) "/etc/lsb-release"
+
+      step "Simple list"
+      res <- listObjects bucket Nothing Nothing Nothing
+      let expected = sort $ map (T.concat .
+                          ("lsb-release":) .
+                          (\x -> [x]) .
+                          T.pack .
+                          show) [1..10]
+      liftIO $ assertEqual "Objects match failed!" expected
+        (map oiObject $ lorObjects res)
+
+      step "cleanup"
+      forM_ [1..10] $ \s ->
+        deleteObject bucket (T.concat ["lsb-release", T.pack (show s)])
   ]
 
 unitTests :: TestTree