minio-hs/src/Network/Minio/ListOps.hs

--
-- MinIO Haskell SDK, (C) 2017-2019 MinIO, Inc.
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
--     http://www.apache.org/licenses/LICENSE-2.0
--
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS,
-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-- See the License for the specific language governing permissions and
-- limitations under the License.
--

module Network.Minio.ListOps where

import qualified Data.Conduit as C
import qualified Data.Conduit.Combinators as CC
import qualified Data.Conduit.List as CL
import Network.Minio.Data
  ( Bucket,
    ListObjectsResult
      ( lorCPrefixes,
        lorHasMore,
        lorNextToken,
        lorObjects
      ),
    ListObjectsV1Result
      ( lorCPrefixes',
        lorHasMore',
        lorNextMarker,
        lorObjects'
      ),
    ListPartsResult (lprHasMore, lprNextPart, lprParts),
    ListUploadsResult
      ( lurHasMore,
        lurNextKey,
        lurNextUpload,
        lurUploads
      ),
    Minio,
    Object,
    ObjectInfo,
    ObjectPartInfo (opiSize),
    UploadId,
    UploadInfo (UploadInfo),
  )
import Network.Minio.S3API
  ( listIncompleteParts',
    listIncompleteUploads',
    listObjects',
    listObjectsV1',
  )

-- | Represents a list output item - either an object or an object
-- prefix (i.e. a directory).
data ListItem
  = ListItemObject ObjectInfo
  | ListItemPrefix Text
  deriving stock (Show, Eq)

-- | @'listObjects' bucket prefix recurse@ lists objects in a bucket
-- similar to a file system tree traversal.
--
-- If @prefix@ is not 'Nothing', only items with the given prefix are
-- listed, otherwise items under the bucket are returned.
--
-- If @recurse@ is set to @True@ all directories under the prefix are
-- recursively traversed and only objects are returned.
--
-- If @recurse@ is set to @False@, objects and directories immediately
-- under the given prefix are returned (no recursive traversal is
-- performed).
listObjects :: Bucket -> Maybe Text -> Bool -> C.ConduitM () ListItem Minio ()
listObjects bucket prefix recurse = loop Nothing
  where
    loop :: Maybe Text -> C.ConduitM () ListItem Minio ()
    loop nextToken = do
      let delimiter = bool (Just "/") Nothing recurse

      res <- lift $ listObjects' bucket prefix nextToken delimiter Nothing
      CL.sourceList $ map ListItemObject $ lorObjects res
      unless recurse $
        CL.sourceList $
          map ListItemPrefix $
            lorCPrefixes res
      when (lorHasMore res) $
        loop (lorNextToken res)

-- | Lists objects - similar to @listObjects@, however uses the older
-- V1 AWS S3 API. Prefer @listObjects@ to this.
listObjectsV1 ::
  Bucket ->
  Maybe Text ->
  Bool ->
  C.ConduitM () ListItem Minio ()
listObjectsV1 bucket prefix recurse = loop Nothing
  where
    loop :: Maybe Text -> C.ConduitM () ListItem Minio ()
    loop nextMarker = do
      let delimiter = bool (Just "/") Nothing recurse

      res <- lift $ listObjectsV1' bucket prefix nextMarker delimiter Nothing
      CL.sourceList $ map ListItemObject $ lorObjects' res
      unless recurse $
        CL.sourceList $
          map ListItemPrefix $
            lorCPrefixes' res
      when (lorHasMore' res) $
        loop (lorNextMarker res)

-- | List incomplete uploads in a bucket matching the given prefix. If
-- recurse is set to True incomplete uploads for the given prefix are
-- recursively listed.
listIncompleteUploads ::
  Bucket ->
  Maybe Text ->
  Bool ->
  C.ConduitM () UploadInfo Minio ()
listIncompleteUploads bucket prefix recurse = loop Nothing Nothing
  where
    loop :: Maybe Text -> Maybe Text -> C.ConduitM () UploadInfo Minio ()
    loop nextKeyMarker nextUploadIdMarker = do
      let delimiter = bool (Just "/") Nothing recurse

      res <-
        lift $
          listIncompleteUploads'
            bucket
            prefix
            delimiter
            nextKeyMarker
            nextUploadIdMarker
            Nothing

      aggrSizes <- lift $
        forM (lurUploads res) $ \(uKey, uId, _) -> do
          partInfos <-
            C.runConduit $
              listIncompleteParts bucket uKey uId
                C..| CC.sinkList
          return $ foldl' (\sizeSofar p -> opiSize p + sizeSofar) 0 partInfos

      CL.sourceList $
        zipWith
          ( curry
              ( \((uKey, uId, uInitTime), size) ->
                  UploadInfo uKey uId uInitTime size
              )
          )
          (lurUploads res)
          aggrSizes

      when (lurHasMore res) $
        loop (lurNextKey res) (lurNextUpload res)

-- | List object parts of an ongoing multipart upload for given
-- bucket, object and uploadId.
listIncompleteParts ::
  Bucket ->
  Object ->
  UploadId ->
  C.ConduitM () ObjectPartInfo Minio ()
listIncompleteParts bucket object uploadId = loop Nothing
  where
    loop :: Maybe Text -> C.ConduitM () ObjectPartInfo Minio ()
    loop nextPartMarker = do
      res <-
        lift $
          listIncompleteParts'
            bucket
            object
            uploadId
            Nothing
            nextPartMarker
      CL.sourceList $ lprParts res
      when (lprHasMore res) $
        loop (show <$> lprNextPart res)