diff --git a/src/Network/Minio/Data.hs b/src/Network/Minio/Data.hs index bba6936..bb9a2f3 100644 --- a/src/Network/Minio/Data.hs +++ b/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 diff --git a/src/Network/Minio/S3API.hs b/src/Network/Minio/S3API.hs index ac19e88..0207754 100644 --- a/src/Network/Minio/S3API.hs +++ b/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 diff --git a/src/Network/Minio/XmlParser.hs b/src/Network/Minio/XmlParser.hs index d06c2dc..0709b4b 100644 --- a/src/Network/Minio/XmlParser.hs +++ b/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 diff --git a/test/Spec.hs b/test/Spec.hs index a0f30fc..b49aed2 100644 --- a/test/Spec.hs +++ b/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