content: --
  -- MinIO Haskell SDK, (C) 2017-2023 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.
  --
  
  import Conduit (replicateC)
  import qualified Conduit as C
  import qualified Control.Monad.Trans.Resource as R
  import qualified Data.ByteString as BS
  import Data.Conduit (yield)
  import qualified Data.Conduit.Binary as CB
  import Data.Conduit.Combinators (sinkList)
  import qualified Data.HashMap.Strict as H
  import qualified Data.Text as T
  import Data.Time (fromGregorian)
  import qualified Data.Time as Time
  import Lib.Prelude
  import qualified Network.HTTP.Client.MultipartFormData as Form
  import qualified Network.HTTP.Conduit as NC
  import qualified Network.HTTP.Types as HT
  import Network.Minio
  import Network.Minio.Credentials (Creds (CredsStatic))
  import Network.Minio.Data
  import Network.Minio.Data.Crypto
  import Network.Minio.S3API
  import Network.Minio.Utils
  import System.Directory (getTemporaryDirectory)
  import qualified System.Environment as Env
  import qualified Test.QuickCheck as Q
  import Test.Tasty
  import Test.Tasty.HUnit
  import Test.Tasty.QuickCheck as QC
  import qualified UnliftIO.IO as UIO
  
  main :: IO ()
  main = defaultMain tests
  
  tests :: TestTree
  tests = testGroup "Tests" [liveServerUnitTests]
  
  lookupTestEnv :: IO (Maybe ConnectInfo, (AccessKey, SecretKey))
  lookupTestEnv = do
    val <- Env.lookupEnv "MINIO_LOCAL"
    secure <- Env.lookupEnv "MINIO_SECURE"
    let localServerMaybe = case (val, secure) of
          (Just _, Just _) -> Just "https://localhost:9000"
          (Just _, Nothing) -> Just "http://localhost:9000"
          _ -> Nothing
    accessKeyE <- Env.lookupEnv "MINIO_ACCESS_KEY"
    let accessKey = maybe "minioadmin" fromString accessKeyE
    secretKeyE <- Env.lookupEnv "MINIO_SECRET_KEY"
    let secretKey = maybe "minioadmin" fromString secretKeyE
    return (localServerMaybe, (accessKey, secretKey))
  
  loadTestServerConnInfo :: IO ConnectInfo
  loadTestServerConnInfo = do
    (localServerMaybe, (ak, sk)) <- lookupTestEnv
    return $ case localServerMaybe of
      Just localServer -> do
        setCreds (CredentialValue ak sk mempty) localServer
      _ -> minioPlayCI
  
  loadTestServerConnInfoSTS :: IO ConnectInfo
  loadTestServerConnInfoSTS = do
    (localServerMaybe, (ak, sk)) <- lookupTestEnv
    case localServerMaybe of
      Just localServer -> do
        let creds = CredentialValue ak sk mempty
            assumeRole =
              STSAssumeRole
                { sarCredentials = creds,
                  sarOptions = defaultSTSAssumeRoleOptions
                }
        setSTSCredential assumeRole localServer
      Nothing -> do
        let creds = case connectCreds minioPlayCI of
              CredsStatic c -> c
              _ -> error "unexpected play creds"
            assumeRole =
              STSAssumeRole
                { sarCredentials = creds,
                  sarOptions = defaultSTSAssumeRoleOptions
                }
        setSTSCredential assumeRole minioPlayCI
  
  -- conduit that generates random binary stream of given length
  randomDataSrc :: (MonadIO m) => Int64 -> C.ConduitM () ByteString m ()
  randomDataSrc = genBS
    where
      concatIt bs n =
        BS.concat $
          replicate (fromIntegral q) bs
            ++ [BS.take (fromIntegral r) bs]
        where
          (q, r) = n `divMod` fromIntegral (BS.length bs)
      genBS s = do
        w8s <- liftIO $ generate $ Q.vectorOf 64 (Q.choose (0, 255))
        let byteArr64 = BS.pack w8s
        if s < oneMiB
          then yield $ concatIt byteArr64 s
          else do
            yield $ concatIt byteArr64 oneMiB
            genBS (s - oneMiB)
  
  mkRandFile :: (R.MonadResource m) => Int64 -> m FilePath
  mkRandFile size = do
    dir <- liftIO getTemporaryDirectory
    C.runConduit $ randomDataSrc size C..| CB.sinkTempFile dir "miniohstest.random"
  
  funTestBucketPrefix :: Text
  funTestBucketPrefix = "miniohstest-"
  
  funTestWithBucketNoSTS ::
    TestName ->
    (([Char] -> Minio ()) -> Bucket -> Minio ()) ->
    TestTree
  funTestWithBucketNoSTS t minioTest = testCaseSteps t $ \step -> do
    -- generate a random name for the bucket
    bktSuffix <- liftIO $ generate $ Q.vectorOf 10 (Q.choose ('a', 'z'))
    let b = T.concat [funTestBucketPrefix, T.pack bktSuffix]
        liftStep = liftIO . step
    connInfo <- loadTestServerConnInfo
    ret <- runMinio connInfo $ do
      liftStep $ "Creating bucket for test - " ++ t
      foundBucket <- bucketExists b
      liftIO $ foundBucket @?= False
      makeBucket b Nothing
      minioTest liftStep b
      deleteBucket b
    isRight ret @? ("Functional test " ++ t ++ " failed => " ++ show ret)
  
  funTestWithBucket ::
    TestName ->
    (([Char] -> Minio ()) -> Bucket -> Minio ()) ->
    TestTree
  funTestWithBucket t minioTest = testCaseSteps t $ \step -> do
    -- generate a random name for the bucket
    bktSuffix <- liftIO $ generate $ Q.vectorOf 10 (Q.choose ('a', 'z'))
    let b = T.concat [funTestBucketPrefix, T.pack bktSuffix]
        liftStep = liftIO . step
    connInfo <- loadTestServerConnInfo
    ret <- runMinio connInfo $ do
      liftStep $ "Creating bucket for test - " ++ t
      foundBucket <- bucketExists b
      liftIO $ foundBucket @?= False
      makeBucket b Nothing
      minioTest liftStep b
      deleteBucket b
    isRight ret @? ("Functional test " ++ t ++ " failed => " ++ show ret)
  
    connInfoSTS <- loadTestServerConnInfoSTS
    let t' = t ++ " (with AssumeRole Credentials)"
    ret' <- runMinio connInfoSTS $ do
      liftStep $ "Creating bucket for test - " ++ t'
      foundBucket <- bucketExists b
      liftIO $ foundBucket @?= False
      makeBucket b Nothing
      minioTest liftStep b
      deleteBucket b
    isRight ret' @? ("Functional test " ++ t' ++ " failed => " ++ show ret')
  
  liveServerUnitTests :: TestTree
  liveServerUnitTests =
    testGroup
      "Unit tests against a live server"
      [ basicTests,
        listingTest,
        highLevelListingTest,
        lowLevelMultipartTest,
        putObjectSizeTest,
        putObjectNoSizeTest,
        multipartTest,
        putObjectContentTypeTest,
        putObjectContentLanguageTest,
        putObjectStorageClassTest,
        putObjectUserMetadataTest,
        getObjectTest,
        copyObjectTests,
        presignedUrlFunTest,
        presignedPostPolicyFunTest,
        bucketPolicyFunTest,
        getNPutSSECTest,
        assumeRoleRequestTest
      ]
  
  basicTests :: TestTree
  basicTests = funTestWithBucket "Basic tests" $
    \step bucket -> do
      step "getService works and contains the test bucket."
      buckets <- getService
      unless (length (filter (== bucket) $ map biName buckets) == 1) $
        liftIO $
          assertFailure
            ( "The bucket "
                ++ show bucket
                ++ " was expected to exist."
            )
  
      step "makeBucket again to check if BucketAlreadyOwnedByYou exception is raised."
      mbE <- try $ makeBucket bucket Nothing
      case mbE of
        Left exn -> liftIO $ exn @?= BucketAlreadyOwnedByYou
        _ -> return ()
  
      step "makeBucket with an invalid bucket name and check for appropriate exception."
      invalidMBE <- try $ makeBucket "invalidBucketName" Nothing
      case invalidMBE of
        Left exn -> liftIO $ exn @?= MErrVInvalidBucketName "invalidBucketName"
        _ -> return ()
  
      step "getLocation works"
      region <- getLocation bucket
      liftIO $ region == "us-east-1" @? ("Got unexpected region => " ++ show region)
  
      step "singlepart putObject works"
      testFilepath <- mkRandFile 200
      fPutObject bucket "test-file" testFilepath defaultPutObjectOptions
  
      step "fPutObject onto a non-existent bucket and check for NoSuchBucket exception"
      fpE <- try $ fPutObject "nosuchbucket" "test-file-2" testFilepath defaultPutObjectOptions
      case fpE of
        Left exn -> liftIO $ exn @?= NoSuchBucket
        _ -> return ()
  
      outFile <- mkRandFile 0
      step "simple fGetObject works"
      fGetObject bucket "test-file" outFile defaultGetObjectOptions
  
      let unmodifiedTime = UTCTime (fromGregorian 2010 11 26) 69857
      step "fGetObject an object which is modified now but requesting as un-modified in past, check for exception"
      resE <-
        try $
          fGetObject
            bucket
            "test-file"
            outFile
            defaultGetObjectOptions
              { gooIfUnmodifiedSince = Just unmodifiedTime
              }
      case resE of
        Left exn -> liftIO $ exn @?= ServiceErr "PreconditionFailed" "At least one of the pre-conditions you specified did not hold"
        _ -> return ()
  
      step "fGetObject an object with no matching etag, check for exception"
      resE1 <-
        try $
          fGetObject
            bucket
            "test-file"
            outFile
            defaultGetObjectOptions
              { gooIfMatch = Just "invalid-etag"
              }
      case resE1 of
        Left exn -> liftIO $ exn @?= ServiceErr "PreconditionFailed" "At least one of the pre-conditions you specified did not hold"
        _ -> return ()
  
      step "fGetObject an object with no valid range, check for exception"
      resE2 <-
        try $
          fGetObject
            bucket
            "test-file"
            outFile
            defaultGetObjectOptions
              { gooRange = Just $ HT.ByteRangeFromTo 100 300
              }
      case resE2 of
        Left exn -> liftIO $ exn @?= ServiceErr "InvalidRange" "The requested range is not satisfiable"
        _ -> return ()
  
      step "fGetObject on object with a valid range"
      fGetObject
        bucket
        "test-file"
        outFile
        defaultGetObjectOptions
          { gooRange = Just $ HT.ByteRangeFrom 1
          }
  
      step "fGetObject a non-existent object and check for NoSuchKey exception"
      resE3 <- try $ fGetObject bucket "noSuchKey" outFile defaultGetObjectOptions
      case resE3 of
        Left exn -> liftIO $ exn @?= NoSuchKey
        _ -> return ()
  
      step "create new multipart upload works"
      uid <- newMultipartUpload bucket "newmpupload" []
      liftIO $ (T.length uid > 0) @? "Got an empty multipartUpload Id."
  
      step "abort a new multipart upload works"
      abortMultipartUpload bucket "newmpupload" uid
  
      step "delete object works"
      deleteObject bucket "test-file"
  
      step "statObject test"
      let object = "sample"
      step "create an object"
      inputFile <- mkRandFile 0
      fPutObject bucket object inputFile defaultPutObjectOptions
  
      step "get metadata of the object"
      res <- statObject bucket object defaultGetObjectOptions
      liftIO $ oiSize res @?= 0
  
      step "delete object"
      deleteObject bucket object
  
  lowLevelMultipartTest :: TestTree
  lowLevelMultipartTest = funTestWithBucket "Low-level Multipart Test" $
    \step bucket -> do
      -- low-level multipart operation tests.
      let object = "newmpupload"
          mb15 = 15 * 1024 * 1024
  
      step "Prepare for low-level multipart tests."
      step "create new multipart upload"
      uid <- newMultipartUpload bucket object []
      liftIO $ (T.length uid > 0) @? "Got an empty multipartUpload Id."
  
      randFile <- mkRandFile mb15
  
      step "put object parts 1 of 1"
      partInfo <-
        UIO.withBinaryFile randFile UIO.ReadMode $ \h ->
          putObjectPart bucket object uid 1 [] $ PayloadH h 0 mb15
  
      step "complete multipart"
      void $ completeMultipartUpload bucket object uid [partInfo]
  
      destFile <- mkRandFile 0
      step "Retrieve the created object and check size"
      fGetObject bucket object destFile defaultGetObjectOptions
      gotSize <- withNewHandle destFile getFileSize
      liftIO $
        gotSize
          == Right (Just mb15)
          @? "Wrong file size of put file after getting"
  
      step "Cleanup actions"
      removeObject bucket object
  
  putObjectSizeTest :: TestTree
  putObjectSizeTest = funTestWithBucket "PutObject of conduit source with size" $
    \step bucket -> do
      -- putObject test (conduit source, size specified)
      let obj = "msingle"
          mb1 = 1 * 1024 * 1024
  
      step "Prepare for putObject with from source with size."
      rFile <- mkRandFile mb1
  
      step "Upload single file."
      putObject bucket obj (CB.sourceFile rFile) (Just mb1) defaultPutObjectOptions
  
      step "Retrieve and verify file size"
      destFile <- mkRandFile 0
      fGetObject bucket obj destFile defaultGetObjectOptions
      gotSize <- withNewHandle destFile getFileSize
      liftIO $
        gotSize
          == Right (Just mb1)
          @? "Wrong file size of put file after getting"
  
      step "Cleanup actions"
      deleteObject bucket obj
  
  putObjectNoSizeTest :: TestTree
  putObjectNoSizeTest = funTestWithBucket "PutObject of conduit source with no size" $
    \step bucket -> do
      -- putObject test (conduit source, no size specified)
      let obj = "mpart"
          mb70 = 70 * 1024 * 1024
  
      step "Prepare for putObject with from source without providing size."
      rFile <- mkRandFile mb70
  
      step "Upload multipart file."
      putObject bucket obj (CB.sourceFile rFile) Nothing defaultPutObjectOptions
  
      step "Retrieve and verify file size"
      destFile <- mkRandFile 0
      fGetObject bucket obj destFile defaultGetObjectOptions
      gotSize <- withNewHandle destFile getFileSize
      liftIO $
        gotSize
          == Right (Just mb70)
          @? "Wrong file size of put file after getting"
  
      step "Cleanup actions"
      deleteObject bucket obj
  
  highLevelListingTest :: TestTree
  highLevelListingTest = funTestWithBucket "High-level listObjects Test" $
    \step bucket -> do
      step "High-level listObjects Test"
      step "put 3 objects"
      let extractObjectsFromList =
            mapM
              ( \case
                  ListItemObject o -> Just $ oiObject o
                  _ -> Nothing
              )
          extractObjectsAndDirsFromList =
            map
              ( \case
                  ListItemObject o -> oiObject o
                  ListItemPrefix d -> d
              )
          expectedObjects = ["dir/o1", "dir/dir1/o2", "dir/dir2/o3", "o4"]
          expectedNonRecList = ["o4", "dir/"]
  
      testFilepath <- mkRandFile 200
      forM_ expectedObjects $
        \obj -> fPutObject bucket obj testFilepath defaultPutObjectOptions
  
      step "High-level listing of objects"
      items <- C.runConduit $ listObjects bucket Nothing False C..| sinkList
      liftIO $
        assertEqual "Objects/Dirs match failed!" expectedNonRecList $
          extractObjectsAndDirsFromList items
  
      step "High-level recursive listing of objects"
      objects <- C.runConduit $ listObjects bucket Nothing True C..| sinkList
  
      liftIO
        $ assertEqual
          "Objects match failed!"
          (Just $ sort expectedObjects)
        $ extractObjectsFromList objects
  
      step "High-level listing of objects (version 1)"
      itemsV1 <- C.runConduit $ listObjectsV1 bucket Nothing False C..| sinkList
      liftIO $
        assertEqual "Objects/Dirs match failed!" expectedNonRecList $
          extractObjectsAndDirsFromList itemsV1
  
      step "High-level recursive listing of objects (version 1)"
      objectsV1 <-
        C.runConduit $
          listObjectsV1 bucket Nothing True
            C..| sinkList
  
      liftIO
        $ assertEqual
          "Objects match failed!"
          (Just $ sort expectedObjects)
        $ extractObjectsFromList objectsV1
  
      let expectedPrefListing = ["dir/o1", "dir/dir1/", "dir/dir2/"]
          expectedPrefListingRec = Just ["dir/dir1/o2", "dir/dir2/o3", "dir/o1"]
      step "High-level listing with prefix"
      prefItems <- C.runConduit $ listObjects bucket (Just "dir/") False C..| sinkList
      liftIO
        $ assertEqual
          "Objects/Dirs under prefix match failed!"
          expectedPrefListing
        $ extractObjectsAndDirsFromList prefItems
  
      step "High-level listing with prefix recursive"
      prefItemsRec <- C.runConduit $ listObjects bucket (Just "dir/") True C..| sinkList
      liftIO
        $ assertEqual
          "Objects/Dirs under prefix match recursive failed!"
          expectedPrefListingRec
        $ extractObjectsFromList prefItemsRec
  
      step "High-level listing with prefix (version 1)"
      prefItemsV1 <- C.runConduit $ listObjectsV1 bucket (Just "dir/") False C..| sinkList
      liftIO
        $ assertEqual
          "Objects/Dirs under prefix match failed!"
          expectedPrefListing
        $ extractObjectsAndDirsFromList prefItemsV1
  
      step "High-level listing with prefix recursive (version 1)"
      prefItemsRecV1 <- C.runConduit $ listObjectsV1 bucket (Just "dir/") True C..| sinkList
      liftIO
        $ assertEqual
          "Objects/Dirs under prefix match recursive failed!"
          expectedPrefListingRec
        $ extractObjectsFromList prefItemsRecV1
  
      step "Cleanup actions"
      forM_ expectedObjects $
        \obj -> removeObject bucket obj
  
      step "High-level listIncompleteUploads Test"
      let object = "newmpupload"
      step "create 10 multipart uploads"
      forM_ [1 .. 10 :: Int] $ \_ -> do
        uid <- newMultipartUpload bucket object []
        liftIO $ (T.length uid > 0) @? "Got an empty multipartUpload Id."
  
      step "High-level listing of incomplete multipart uploads"
      uploads <-
        C.runConduit $
          listIncompleteUploads bucket (Just "newmpupload") True
            C..| sinkList
      liftIO $ length uploads @?= 10
  
      step "cleanup"
      forM_ uploads $ \(UploadInfo _ uid _ _) ->
        abortMultipartUpload bucket object uid
  
      step "High-level listIncompleteParts Test"
      let mb5 = 5 * 1024 * 1024
  
      step "create a multipart upload"
      uid <- newMultipartUpload bucket object []
      liftIO $ (T.length uid > 0) @? "Got an empty multipartUpload Id."
  
      step "put object parts 1..10"
      inputFile <- mkRandFile mb5
      UIO.withBinaryFile inputFile UIO.ReadMode $ \h ->
        forM_ [1 .. 10] $ \pnum ->
          putObjectPart bucket object uid pnum [] $ PayloadH h 0 mb5
  
      step "fetch list parts"
      incompleteParts <-
        C.runConduit $
          listIncompleteParts bucket object uid
            C..| sinkList
      liftIO $ length incompleteParts @?= 10
  
      step "cleanup"
      abortMultipartUpload bucket object uid
  
  listingTest :: TestTree
  listingTest = funTestWithBucket "Listing Test" $ \step bucket -> do
    step "listObjects' test"
    step "put 10 objects"
    let objects = (\s -> T.concat ["test-file-", T.pack (show s)]) <$> [1 .. 10 :: Int]
  
    testFilepath <- mkRandFile 200
    forM_ [1 .. 10 :: Int] $ \s ->
      fPutObject bucket (T.concat ["test-file-", T.pack (show s)]) testFilepath defaultPutObjectOptions
  
    step "Simple list"
    res <- listObjects' bucket Nothing Nothing Nothing Nothing
    let expectedObjects = sort objects
    liftIO $
      assertEqual
        "Objects match failed!"
        expectedObjects
        (map oiObject $ lorObjects res)
  
    step "Simple list version 1"
    resV1 <- listObjectsV1' bucket Nothing Nothing Nothing Nothing
    let expected =
          sort $
            map
              ( T.concat
                  . ("test-file-" :)
                  . (: [])
                  . T.pack
                  . show
              )
              [1 .. 10 :: Int]
    liftIO $
      assertEqual
        "Objects match failed!"
        expected
        (map oiObject $ lorObjects' resV1)
  
    step "Cleanup actions"
    forM_ objects $ \obj -> deleteObject bucket obj
  
    step "listIncompleteUploads' test"
    step "create 10 multipart uploads"
    let object = "newmpupload"
    forM_ [1 .. 10 :: Int] $ \_ -> do
      uid <- newMultipartUpload bucket object []
      liftIO $ (T.length uid > 0) @? "Got an empty multipartUpload Id."
  
    step "list incomplete multipart uploads"
    incompleteUploads <-
      listIncompleteUploads'
        bucket
        (Just "newmpupload")
        Nothing
        Nothing
        Nothing
        Nothing
    liftIO $ length (lurUploads incompleteUploads) @?= 10
  
    step "cleanup"
    forM_ (lurUploads incompleteUploads) $
      \(_, uid, _) -> abortMultipartUpload bucket object uid
  
    step "Basic listIncompleteParts Test"
    let mb5 = 5 * 1024 * 1024
  
    step "create a multipart upload"
    uid <- newMultipartUpload bucket object []
    liftIO $ (T.length uid > 0) @? "Got an empty multipartUpload Id."
  
    step "put object parts 1..10"
    inputFile <- mkRandFile mb5
    UIO.withBinaryFile inputFile UIO.ReadMode $ \h ->
      forM_ [1 .. 10] $ \pnum ->
        putObjectPart bucket object uid pnum [] $ PayloadH h 0 mb5
  
    step "fetch list parts"
    listPartsResult <- listIncompleteParts' bucket object uid Nothing Nothing
    liftIO $ length (lprParts listPartsResult) @?= 10
    abortMultipartUpload bucket object uid
  
  presignedUrlFunTest :: TestTree
  presignedUrlFunTest = funTestWithBucket "presigned Url tests" $
    \step bucket -> do
      let obj = "mydir/myput"
          obj2 = "mydir1/myfile1"
  
      -- manager for http requests
      mgr <- liftIO $ NC.newManager NC.tlsManagerSettings
  
      step "PUT object presigned URL - makePresignedUrl"
      putUrl <-
        makePresignedUrl
          3600
          HT.methodPut
          (Just bucket)
          (Just obj)
          (Just "us-east-1")
          []
          []
  
      -- print putUrl
      let size1 = 1000 :: Int64
      inputFile <- mkRandFile size1
  
      -- attempt to upload using the presigned URL
      putResp <- putR size1 inputFile mgr putUrl
      liftIO $
        (NC.responseStatus putResp == HT.status200)
          @? "presigned PUT failed"
  
      step "GET object presigned URL - makePresignedUrl"
      getUrl <-
        makePresignedUrl
          3600
          HT.methodGet
          (Just bucket)
          (Just obj)
          (Just "us-east-1")
          []
          []
  
      getResp <- getR mgr getUrl
      liftIO $
        (NC.responseStatus getResp == HT.status200)
          @? "presigned GET failed"
  
      -- read content from file to compare with response above
      bs <- C.runConduit $ CB.sourceFile inputFile C..| CB.sinkLbs
      liftIO $
        (bs == NC.responseBody getResp)
          @? "presigned put and get got mismatched data"
  
      step "PUT object presigned - presignedPutObjectURL"
      putUrl2 <- presignedPutObjectUrl bucket obj2 604800 []
  
      let size2 = 1200
      testFile <- mkRandFile size2
  
      putResp2 <- putR size2 testFile mgr putUrl2
      liftIO $
        (NC.responseStatus putResp2 == HT.status200)
          @? "presigned PUT failed (presignedPutObjectUrl)"
  
      step "HEAD object presigned URL - presignedHeadObjectUrl"
      headUrl <- presignedHeadObjectUrl bucket obj2 3600 []
  
      headResp <- do
        let req = NC.parseRequest_ $ decodeUtf8 headUrl
        NC.httpLbs (req {NC.method = HT.methodHead}) mgr
      liftIO $
        (NC.responseStatus headResp == HT.status200)
          @? "presigned HEAD failed (presignedHeadObjectUrl)"
  
      -- check that header info is accurate
      let h = H.fromList $ NC.responseHeaders headResp
          cLen = H.lookupDefault "0" HT.hContentLength h
      liftIO $ (cLen == showBS size2) @? "Head req returned bad content length"
  
      step "GET object presigned URL - presignedGetObjectUrl"
      getUrl2 <- presignedGetObjectUrl bucket obj2 3600 [] []
  
      getResp2 <- getR mgr getUrl2
      liftIO $
        (NC.responseStatus getResp2 == HT.status200)
          @? "presigned GET failed (presignedGetObjectUrl)"
  
      -- read content from file to compare with response above
      bs2 <- C.runConduit $ CB.sourceFile testFile C..| CB.sinkLbs
      liftIO $
        (bs2 == NC.responseBody getResp2)
          @? "presigned put and get got mismatched data (presigned*Url)"
  
      mapM_ (removeObject bucket) [obj, obj2]
    where
      putR size filePath mgr url = do
        let req = NC.parseRequest_ $ decodeUtf8 url
        let req' =
              req
                { NC.method = HT.methodPut,
                  NC.requestBody =
                    NC.requestBodySource size $
                      CB.sourceFile filePath
                }
        NC.httpLbs req' mgr
      getR mgr url = do
        let req = NC.parseRequest_ $ decodeUtf8 url
        NC.httpLbs req mgr
  
  presignedPostPolicyFunTest :: TestTree
  presignedPostPolicyFunTest = funTestWithBucketNoSTS "Presigned Post Policy tests" $
    \step bucket -> do
      step "presignedPostPolicy basic test"
      now <- liftIO Time.getCurrentTime
  
      let key = "presignedPostPolicyTest/myfile"
          policyConds =
            [ ppCondBucket bucket,
              ppCondKey key,
              ppCondContentLengthRange 1 1000,
              ppCondContentType "application/octet-stream",
              ppCondSuccessActionStatus 200
            ]
          expirationTime = Time.addUTCTime 3600 now
          postPolicyE = newPostPolicy expirationTime policyConds
          size = 1000 :: Int64
  
      inputFile <- mkRandFile size
  
      case postPolicyE of
        Left err -> liftIO $ assertFailure $ show err
        Right postPolicy -> do
          (url, formData) <- presignedPostPolicy postPolicy
          -- liftIO (print url) >> liftIO (print formData)
          result <- liftIO $ postForm url formData inputFile
          liftIO $
            (NC.responseStatus result == HT.status200)
              @? "presigned POST failed"
  
      mapM_ (removeObject bucket) [key]
    where
      postForm url formData inputFile = do
        req <- NC.parseRequest $ decodeUtf8 url
        let parts =
              map (uncurry Form.partBS) $
                H.toList formData
            parts' = parts ++ [Form.partFile "file" inputFile]
        req' <- Form.formDataBody parts' req
        mgr <- NC.newManager NC.tlsManagerSettings
        NC.httpLbs req' mgr
  
  bucketPolicyFunTest :: TestTree
  bucketPolicyFunTest = funTestWithBucket "Bucket Policy tests" $
    \step bucket -> do
      step "bucketPolicy basic test - no policy exception"
      resE <- try $ getBucketPolicy bucket
      case resE of
        Left exn -> liftIO $ exn @?= ServiceErr "NoSuchBucketPolicy" "The bucket policy does not exist"
        _ -> return ()
  
      resE' <- try $ setBucketPolicy bucket T.empty
      case resE' of
        Left exn -> liftIO $ exn @?= ServiceErr "NoSuchBucketPolicy" "The bucket policy does not exist"
        _ -> return ()
  
      let expectedPolicyJSON = "{\"Version\":\"2012-10-17\",\"Statement\":[{\"Action\":[\"s3:GetBucketLocation\",\"s3:ListBucket\"],\"Effect\":\"Allow\",\"Principal\":{\"AWS\":[\"*\"]},\"Resource\":[\"arn:aws:s3:::testbucket\"]},{\"Action\":[\"s3:GetObject\"],\"Effect\":\"Allow\",\"Principal\":{\"AWS\":[\"*\"]},\"Resource\":[\"arn:aws:s3:::testbucket/*\"]}]}"
  
      step "try a malformed policy, expect error"
      resE'' <- try $ setBucketPolicy bucket expectedPolicyJSON
      case resE'' of
        Left exn -> liftIO $ exn @?= ServiceErr "MalformedPolicy" "bucket name does not match"
        _ -> return ()
  
      let expectedPolicyJSON' = "{\"Version\":\"2012-10-17\",\"Statement\":[{\"Action\":[\"s3:GetBucketLocation\",\"s3:ListBucket\"],\"Effect\":\"Allow\",\"Principal\":{\"AWS\":[\"*\"]},\"Resource\":[\"arn:aws:s3:::" <> bucket <> "\"]},{\"Action\":[\"s3:GetObject\"],\"Effect\":\"Allow\",\"Principal\":{\"AWS\":[\"*\"]},\"Resource\":[\"arn:aws:s3:::" <> bucket <> "/*\"]}]}"
  
      step "set bucket policy"
      setBucketPolicy bucket expectedPolicyJSON'
  
      let obj = "myobject"
  
      step "verify bucket policy: (1) create `myobject`"
      putObject bucket obj (replicateC 100 "c") Nothing defaultPutObjectOptions
  
      step "verify bucket policy: (2) get `myobject` anonymously"
      connInfo <- asks mcConnInfo
      let proto = bool "http://" "https://" $ connectIsSecure connInfo
          url =
            BS.concat
              [ proto,
                getHostAddr connInfo,
                "/",
                encodeUtf8 bucket,
                "/",
                encodeUtf8 obj
              ]
      respE <-
        liftIO $
          fmap (Right . toStrictBS) (NC.simpleHttp $ decodeUtf8 url)
            `catch` (\(e :: NC.HttpException) -> return $ Left (show e :: Text))
      case respE of
        Left err -> liftIO $ assertFailure $ show err
        Right s -> liftIO $ s @?= BS.concat (replicate 100 "c")
  
      deleteObject bucket obj
  
      step "delete bucket policy"
      setBucketPolicy bucket T.empty
  
  multipartTest :: TestTree
  multipartTest = funTestWithBucket "Multipart Tests" $
    \step bucket -> do
      -- Commenting out test since it's platform specific.
      -- FIXME: Need to find a platform agnostic way to test this.
      -- step "Prepare for putObjectInternal with non-seekable file, with size."
      -- step "Upload multipart file."
      -- let mb80 = 80 * 1024 * 1024
      --     obj = "mpart"
  
      -- void $ putObjectInternal bucket obj defaultPutObjectOptions $ ODFile "/dev/zero" (Just mb80)
  
      -- step "Retrieve and verify file size"
      -- destFile <- mkRandFile 0
      -- fGetObject bucket obj destFile defaultGetObjectOptions
      -- gotSize <- withNewHandle destFile getFileSize
      -- liftIO $
      --   gotSize == Right (Just mb80)
      --     @? "Wrong file size of put file after getting"
  
      -- step "Cleanup actions"
      -- removeObject bucket obj
  
      -- step "cleanup"
      -- removeObject bucket "big"
  
      step "Prepare for removeIncompleteUpload"
      -- low-level multipart operation tests.
      let object = "newmpupload"
          kb5 = 5 * 1024
  
      step "create new multipart upload"
      uid <- newMultipartUpload bucket object []
      liftIO $ (T.length uid > 0) @? "Got an empty multipartUpload Id."
  
      randFile <- mkRandFile kb5
  
      step "upload 2 parts"
      forM_ [1, 2] $ \partNum -> do
        UIO.withBinaryFile randFile UIO.ReadMode $ \h ->
          void $ putObjectPart bucket object uid partNum [] $ PayloadH h 0 kb5
  
      step "remove ongoing upload"
      removeIncompleteUpload bucket object
      uploads <-
        C.runConduit $
          listIncompleteUploads bucket (Just object) False
            C..| sinkList
      liftIO $ null uploads @? "removeIncompleteUploads didn't complete successfully"
  
  putObjectContentTypeTest :: TestTree
  putObjectContentTypeTest = funTestWithBucket "putObject contentType tests" $
    \step bucket -> do
      step "fPutObject content type test"
      let object = "xxx-content-type"
          size1 = 100 :: Int64
  
      step "create server object with content-type"
      inputFile <- mkRandFile size1
      fPutObject
        bucket
        object
        inputFile
        defaultPutObjectOptions
          { pooContentType = Just "application/javascript"
          }
  
      -- retrieve obj info to check
      oi <- headObject bucket object []
      let m = oiMetadata oi
  
      step "Validate content-type"
      liftIO $ assertEqual "Content-Type did not match" (Just "application/javascript") (H.lookup "Content-Type" m)
  
      step "upload object with content-encoding set to identity"
      fPutObject
        bucket
        object
        inputFile
        defaultPutObjectOptions
          { pooContentEncoding = Just "identity"
          }
  
      oiCE <- headObject bucket object []
      let m' = oiMetadata oiCE
  
      step "Validate content-encoding"
      liftIO $
        assertEqual
          "Content-Encoding did not match"
          (Just "identity")
          (H.lookup "Content-Encoding" m')
  
      step "Cleanup actions"
  
      removeObject bucket object
  
  putObjectContentLanguageTest :: TestTree
  putObjectContentLanguageTest = funTestWithBucket "putObject contentLanguage tests" $
    \step bucket -> do
      step "fPutObject content language test"
      let object = "xxx-content-language"
          size1 = 100 :: Int64
  
      step "create server object with content-language"
      inputFile <- mkRandFile size1
      fPutObject
        bucket
        object
        inputFile
        defaultPutObjectOptions
          { pooContentLanguage = Just "en-US"
          }
  
      -- retrieve obj info to check
      oi <- headObject bucket object []
      let m = oiMetadata oi
  
      step "Validate content-language"
      liftIO $
        assertEqual
          "content-language did not match"
          (Just "en-US")
          (H.lookup "Content-Language" m)
      step "Cleanup actions"
  
      removeObject bucket object
  
  putObjectUserMetadataTest :: TestTree
  putObjectUserMetadataTest = funTestWithBucket "putObject user-metadata test" $
    \step bucket -> do
      step "putObject user-metadata test"
      let object = "object-with-metadata"
          size1 = 100 :: Int64
  
      step "create server object with usermetdata"
      inputFile <- mkRandFile size1
  
      fPutObject
        bucket
        object
        inputFile
        defaultPutObjectOptions
          { pooUserMetadata =
              [ ("x-Amz-meta-mykey1", "myval1"),
                ("mykey2", "myval2")
              ]
          }
  
      step "Validate user-metadata"
      -- retrieve obj info to check
      oi <- headObject bucket object []
      let m = oiUserMetadata oi
          -- need to do a case-insensitive comparison
          sortedMeta =
            sort $
              map (bimap T.toLower T.toLower) $
                H.toList m
          ref = sort [("mykey1", "myval1"), ("mykey2", "myval2")]
  
      liftIO $ (sortedMeta == ref) @? "Metadata mismatch!"
  
      step "Cleanup actions"
      removeObject bucket object
  
  getObjectTest :: TestTree
  getObjectTest = funTestWithBucket "getObject test" $
    \step bucket -> do
      step "putObject with some metadata"
      let object = "object-with-metadata"
          size1 = 100 :: Int64
  
      inputFile <- mkRandFile size1
      fPutObject
        bucket
        object
        inputFile
        defaultPutObjectOptions
          { pooUserMetadata =
              [ ("x-Amz-meta-mykey1", "myval1"),
                ("mykey2", "myval2")
              ]
          }
  
      step "get the object - check the metadata matches"
      -- retrieve obj info to check
      gor <- getObject bucket object defaultGetObjectOptions
      let m = oiUserMetadata $ gorObjectInfo gor
          -- need to do a case-insensitive comparison
          sortedMeta =
            sort $
              map (bimap T.toLower T.toLower) $
                H.toList m
          ref = sort [("mykey1", "myval1"), ("mykey2", "myval2")]
  
      liftIO $ (sortedMeta == ref) @? "Metadata mismatch!"
  
      step "get the object content"
      getObjectHash <- hashSHA256FromSource $ gorObjectStream gor
      inputHash <- hashSHA256FromSource $ C.sourceFile inputFile
      liftIO $ (getObjectHash == inputHash) @? "Input file and output file mismatched!"
  
      step "Cleanup actions"
      removeObject bucket object
  
  putObjectStorageClassTest :: TestTree
  putObjectStorageClassTest = funTestWithBucket "putObject storageClass tests" $
    \step bucket -> do
      step "fPutObject storage class test"
      let object = "xxx-storage-class-standard"
          object' = "xxx-storage-class-reduced"
          object'' = "xxx-storage-class-invalid"
          size1 = 100 :: Int64
          size0 = 0 :: Int64
  
      step "create server objects with storageClass"
      inputFile <- mkRandFile size1
      inputFile' <- mkRandFile size1
      inputFile'' <- mkRandFile size0
  
      fPutObject
        bucket
        object
        inputFile
        defaultPutObjectOptions
          { pooStorageClass = Just "STANDARD"
          }
  
      fPutObject
        bucket
        object'
        inputFile'
        defaultPutObjectOptions
          { pooStorageClass = Just "REDUCED_REDUNDANCY"
          }
  
      removeObject bucket object
  
      -- retrieve obj info to check
      oi' <- headObject bucket object' []
      let m' = oiMetadata oi'
  
      step "Validate x-amz-storage-class rrs"
      liftIO $
        assertEqual
          "storageClass did not match"
          (Just "REDUCED_REDUNDANCY")
          (H.lookup "X-Amz-Storage-Class" m')
  
      fpE <-
        try $
          fPutObject
            bucket
            object''
            inputFile''
            defaultPutObjectOptions
              { pooStorageClass = Just "INVALID_STORAGE_CLASS"
              }
      case fpE of
        Left exn -> liftIO $ exn @?= ServiceErr "InvalidStorageClass" "Invalid storage class."
        _ -> return ()
  
      step "Cleanup actions"
  
      removeObject bucket object'
  
  copyObjectTests :: TestTree
  copyObjectTests = funTestWithBucket "copyObject related tests" $
    \step bucket -> do
      step "copyObjectSingle basic tests"
      let object = "xxx"
          objCopy = "xxxCopy"
          size1 = 100 :: Int64
  
      step "create server object to copy"
      inputFile <- mkRandFile size1
      fPutObject bucket object inputFile defaultPutObjectOptions
  
      step "copy object"
      let srcInfo = defaultSourceInfo {srcBucket = bucket, srcObject = object}
      (etag, modTime) <- copyObjectSingle bucket objCopy srcInfo []
  
      -- retrieve obj info to check
      oi <- headObject bucket objCopy []
      let t = oiModTime oi
      let e = oiETag oi
      let s = oiSize oi
  
      let isMTimeDiffOk = abs (diffUTCTime modTime t) < 1.0
  
      liftIO $
        (s == size1 && e == etag && isMTimeDiffOk)
          @? "Copied object did not match expected."
  
      step "cleanup actions"
      removeObject bucket object
      removeObject bucket objCopy
  
      step "copyObjectPart basic tests"
      let srcObj = "XXX"
          copyObj = "XXXCopy"
  
      step "Prepare"
      let mb15 = 15 * 1024 * 1024
          mb5 = 5 * 1024 * 1024
      randFile <- mkRandFile mb15
      fPutObject bucket srcObj randFile defaultPutObjectOptions
  
      step "create new multipart upload"
      uid <- newMultipartUpload bucket copyObj []
      liftIO $ (T.length uid > 0) @? "Got an empty multipartUpload Id."
  
      step "put object parts 1-3"
      let srcInfo' = defaultSourceInfo {srcBucket = bucket, srcObject = srcObj}
          dstInfo' = defaultDestinationInfo {dstBucket = bucket, dstObject = copyObj}
      parts <- forM [1 .. 3] $ \p -> do
        (etag', _) <-
          copyObjectPart
            dstInfo'
            srcInfo'
              { srcRange = Just $ (,) ((p - 1) * mb5) ((p - 1) * mb5 + (mb5 - 1))
              }
            uid
            (fromIntegral p)
            []
        return (fromIntegral p, etag')
  
      step "complete multipart"
      void $ completeMultipartUpload bucket copyObj uid parts
  
      step "verify copied object size"
      oi' <- headObject bucket copyObj []
      let s' = oiSize oi'
  
      liftIO $ (s' == mb15) @? "Size failed to match"
  
      step "Cleanup actions"
      removeObject bucket srcObj
      removeObject bucket copyObj
  
      step "copyObject basic tests"
      let srcs = ["XXX", "XXXL"]
          copyObjs = ["XXXCopy", "XXXLCopy"]
          sizes = map (* (1024 * 1024)) [15, 65]
  
      step "Prepare"
      forM_ (zip srcs sizes) $ \(src, size) -> do
        inputFile' <- mkRandFile size
        fPutObject bucket src inputFile' defaultPutObjectOptions
  
      step "make small and large object copy"
      forM_ (zip copyObjs srcs) $ \(cp, src) ->
        copyObject defaultDestinationInfo {dstBucket = bucket, dstObject = cp} defaultSourceInfo {srcBucket = bucket, srcObject = src}
  
      step "verify uploaded objects"
      uploadedSizes <- fmap oiSize <$> forM copyObjs (\o -> headObject bucket o [])
  
      liftIO $ (sizes == uploadedSizes) @? "Uploaded obj sizes failed to match"
  
      forM_ (srcs ++ copyObjs) (removeObject bucket)
  
      step "copyObject with offset test "
      let src = "XXX"
          size = 15 * 1024 * 1024
  
      step "Prepare"
      inputFile' <- mkRandFile size
      fPutObject bucket src inputFile' defaultPutObjectOptions
  
      step "copy last 10MiB of object"
      copyObject
        defaultDestinationInfo {dstBucket = bucket, dstObject = copyObj}
        defaultSourceInfo
          { srcBucket = bucket,
            srcObject = src,
            srcRange = Just $ (,) (5 * 1024 * 1024) (size - 1)
          }
  
      step "verify uploaded object"
      cSize <- oiSize <$> headObject bucket copyObj []
  
      liftIO $ (cSize == 10 * 1024 * 1024) @? "Uploaded obj size mismatched!"
  
      forM_ [src, copyObj] (removeObject bucket)
  
  getNPutSSECTest :: TestTree
  getNPutSSECTest =
    funTestWithBucket "Get and Put SSE-C Test" $ \step bucket -> do
      -- Skip this test if the server is not using TLS as encryption is
      -- disabled anyway.
      isTLSConn <- asks (connectIsSecure . mcConnInfo)
      if isTLSConn
        then do
          step "Make an encryption key"
          key <- case mkSSECKey $ BS.pack [0 .. 31] of
            Nothing -> liftIO $ assertFailure "This should not happen"
            Just k -> return k
  
          let mb1 = 1024 * 1024
              obj = "1"
          step "Upload an object using the encryption key"
          rFile <- mkRandFile mb1
          let putOpts = defaultPutObjectOptions {pooSSE = Just $ SSEC key}
          fPutObject bucket obj rFile putOpts
  
          step "Stat object without key - should fail"
          headRes <- try $ statObject bucket obj defaultGetObjectOptions
          case headRes of
            Right _ -> liftIO $ assertFailure "Cannot perform head object on encrypted object without specifying key"
            Left ex@(NC.HttpExceptionRequest _ (NC.StatusCodeException rsp _))
              | NC.responseStatus rsp == HT.status400 -> return ()
              | otherwise -> liftIO $ assertFailure $ "Unexpected err: " ++ show ex
            Left ex -> liftIO $ assertFailure $ "Unexpected err: " ++ show ex
  
          step "Get file and check length"
          dstFile <- mkRandFile 0
          let getOpts = defaultGetObjectOptions {gooSSECKey = Just key}
          fGetObject bucket obj dstFile getOpts
  
          gotSize <- withNewHandle dstFile getFileSize
          liftIO $
            gotSize
              == Right (Just mb1)
              @? "Wrong file size of object when getting"
  
          step "Cleanup"
          deleteObject bucket obj
        else step "Skipping encryption test as server is not using TLS"
  
  assumeRoleRequestTest :: TestTree
  assumeRoleRequestTest = testCaseSteps "Assume Role STS API" $ \step -> do
    step "Load credentials"
    (_, (ak, sk)) <- lookupTestEnv
    val <- Env.lookupEnv "MINIO_LOCAL"
    isSecure <- Env.lookupEnv "MINIO_SECURE"
    let localMinioCred = Just $ CredentialValue ak sk mempty
        playCreds =
          case connectCreds minioPlayCI of
            CredsStatic c -> Just c
            _ -> Nothing
        (cvMay, loc) =
          case (val, isSecure) of
            (Just _, Just _) -> (localMinioCred, "https://localhost:9000")
            (Just _, Nothing) -> (localMinioCred, "http://localhost:9000")
            (Nothing, _) -> (playCreds, "https://play.min.io:9000")
    cv <- maybe (assertFailure "bad creds") return cvMay
    let assumeRole =
          STSAssumeRole cv $
            defaultSTSAssumeRoleOptions
              { saroLocation = Just "us-east-1",
                saroEndpoint = Just loc
              }
    step "AssumeRole request"
    res <- requestSTSCredential assumeRole
    let v = credentialValueText $ fst res
    print (v, snd res)
  