Data.hs

--
-- MinIO Haskell SDK, (C) 2017, 2018 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.
--
{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}

module Network.Minio.Data where

import qualified Conduit as C
import qualified Control.Concurrent.MVar as M
import Control.Monad.Trans.Except (throwE)
import Control.Monad.Trans.Resource
  ( MonadResource,
    MonadThrow (..),
    MonadUnliftIO,
    ResourceT,
    runResourceT,
  )
import qualified Data.Aeson as A
import qualified Data.ByteArray as BA
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as LB
import Data.CaseInsensitive (mk)
import qualified Data.HashMap.Strict as H
import qualified Data.Ini as Ini
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.Time (defaultTimeLocale, formatTime)
import Lib.Prelude (UTCTime, throwIO)
import qualified Network.Connection as Conn
import Network.HTTP.Client (defaultManagerSettings)
import qualified Network.HTTP.Client.TLS as TLS
import qualified Network.HTTP.Conduit as NC
import Network.HTTP.Types
  ( ByteRange,
    Header,
    Method,
    Query,
    hRange,
  )
import qualified Network.HTTP.Types as HT
import Network.Minio.Data.Crypto
  ( encodeToBase64,
    hashMD5ToBase64,
  )
import Network.Minio.Data.Time (UrlExpiry)
import Network.Minio.Errors
  ( MErrV (MErrVInvalidEncryptionKeyLength, MErrVMissingCredentials),
    MinioErr (..),
  )
import System.Directory (doesFileExist, getHomeDirectory)
import qualified System.Environment as Env
import System.FilePath.Posix (combine)
import Text.XML (Name (Name))
import qualified UnliftIO as U

-- | max obj size is 5TiB
maxObjectSize :: Int64
maxObjectSize = 5 * 1024 * 1024 * oneMiB

-- | minimum size of parts used in multipart operations.
minPartSize :: Int64
minPartSize = 64 * oneMiB

oneMiB :: Int64
oneMiB = 1024 * 1024

-- | maximum number of parts that can be uploaded for a single object.
maxMultipartParts :: Int64
maxMultipartParts = 10000

-- TODO: Add a type which provides typed constants for region.  this
-- type should have a IsString instance to infer the appropriate
-- constant.

-- | awsRegionMap - library constant
awsRegionMap :: H.HashMap Text Text
awsRegionMap =
  H.fromList
    [ ("us-east-1", "s3.us-east-1.amazonaws.com"),
      ("us-east-2", "s3.us-east-2.amazonaws.com"),
      ("us-west-1", "s3.us-west-1.amazonaws.com"),
      ("us-west-2", "s3.us-west-2.amazonaws.com"),
      ("ca-central-1", "s3.ca-central-1.amazonaws.com"),
      ("ap-south-1", "s3.ap-south-1.amazonaws.com"),
      ("ap-northeast-1", "s3.ap-northeast-1.amazonaws.com"),
      ("ap-northeast-2", "s3.ap-northeast-2.amazonaws.com"),
      ("ap-southeast-1", "s3.ap-southeast-1.amazonaws.com"),
      ("ap-southeast-2", "s3.ap-southeast-2.amazonaws.com"),
      ("eu-west-1", "s3.eu-west-1.amazonaws.com"),
      ("eu-west-2", "s3.eu-west-2.amazonaws.com"),
      ("eu-central-1", "s3.eu-central-1.amazonaws.com"),
      ("sa-east-1", "s3.sa-east-1.amazonaws.com")
    ]

-- | Connection Info data type. To create a 'ConnectInfo' value,
-- enable the @OverloadedStrings@ language extension and use the
-- `IsString` instance to provide a URL, for example:
--
-- > let c :: ConnectInfo = "https://play.min.io"
data ConnectInfo = ConnectInfo
  { connectHost :: Text,
    connectPort :: Int,
    connectAccessKey :: Text,
    connectSecretKey :: Text,
    connectIsSecure :: Bool,
    connectRegion :: Region,
    connectAutoDiscoverRegion :: Bool,
    connectDisableTLSCertValidation :: Bool
  }
  deriving stock (Eq, Show)

instance IsString ConnectInfo where
  fromString str =
    let req = NC.parseRequest_ str
     in ConnectInfo
          { connectHost = TE.decodeUtf8 $ NC.host req,
            connectPort = NC.port req,
            connectAccessKey = "",
            connectSecretKey = "",
            connectIsSecure = NC.secure req,
            connectRegion = "",
            connectAutoDiscoverRegion = True,
            connectDisableTLSCertValidation = False
          }

-- | Contains access key and secret key to access object storage.
data Credentials = Credentials
  { cAccessKey :: Text,
    cSecretKey :: Text
  }
  deriving stock (Eq, Show)

-- | A Provider is an action that may return Credentials. Providers
-- may be chained together using 'findFirst'.
type Provider = IO (Maybe Credentials)

-- | Combines the given list of providers, by calling each one in
-- order until Credentials are found.
findFirst :: [Provider] -> Provider
findFirst [] = return Nothing
findFirst (f : fs) = do
  c <- f
  maybe (findFirst fs) (return . Just) c

-- | This Provider loads `Credentials` from @~\/.aws\/credentials@
fromAWSConfigFile :: Provider
fromAWSConfigFile = do
  credsE <- runExceptT $ do
    homeDir <- lift getHomeDirectory
    let awsCredsFile = homeDir `combine` ".aws" `combine` "credentials"
    fileExists <- lift $ doesFileExist awsCredsFile
    bool (throwE "FileNotFound") (return ()) fileExists
    ini <- ExceptT $ Ini.readIniFile awsCredsFile
    akey <-
      ExceptT $
        return $
          Ini.lookupValue "default" "aws_access_key_id" ini
    skey <-
      ExceptT $
        return $
          Ini.lookupValue "default" "aws_secret_access_key" ini
    return $ Credentials akey skey
  return $ either (const Nothing) Just credsE

-- | This Provider loads `Credentials` from @AWS_ACCESS_KEY_ID@ and
-- @AWS_SECRET_ACCESS_KEY@ environment variables.
fromAWSEnv :: Provider
fromAWSEnv = runMaybeT $ do
  akey <- MaybeT $ Env.lookupEnv "AWS_ACCESS_KEY_ID"
  skey <- MaybeT $ Env.lookupEnv "AWS_SECRET_ACCESS_KEY"
  return $ Credentials (T.pack akey) (T.pack skey)

-- | This Provider loads `Credentials` from @MINIO_ACCESS_KEY@ and
-- @MINIO_SECRET_KEY@ environment variables.
fromMinioEnv :: Provider
fromMinioEnv = runMaybeT $ do
  akey <- MaybeT $ Env.lookupEnv "MINIO_ACCESS_KEY"
  skey <- MaybeT $ Env.lookupEnv "MINIO_SECRET_KEY"
  return $ Credentials (T.pack akey) (T.pack skey)

-- | setCredsFrom retrieves access credentials from the first
-- `Provider` form the given list that succeeds and sets it in the
-- `ConnectInfo`.
setCredsFrom :: [Provider] -> ConnectInfo -> IO ConnectInfo
setCredsFrom ps ci = do
  pMay <- findFirst ps
  maybe
    (throwIO MErrVMissingCredentials)
    (return . (`setCreds` ci))
    pMay

-- | setCreds sets the given `Credentials` in the `ConnectInfo`.
setCreds :: Credentials -> ConnectInfo -> ConnectInfo
setCreds (Credentials accessKey secretKey) connInfo =
  connInfo
    { connectAccessKey = accessKey,
      connectSecretKey = secretKey
    }

-- | Set the S3 region parameter in the `ConnectInfo`
setRegion :: Region -> ConnectInfo -> ConnectInfo
setRegion r connInfo =
  connInfo
    { connectRegion = r,
      connectAutoDiscoverRegion = False
    }

-- | Check if the connection to object storage server is secure
-- (i.e. uses TLS)
isConnectInfoSecure :: ConnectInfo -> Bool
isConnectInfoSecure = connectIsSecure

-- | Disable TLS certificate validation completely! This makes TLS
-- insecure! Use only for testing with self-signed or temporary
-- certificates. Note that this option has no effect, if you provide
-- your own Manager in `mkMinioConn`.
disableTLSCertValidation :: ConnectInfo -> ConnectInfo
disableTLSCertValidation c = c {connectDisableTLSCertValidation = True}

getHostAddr :: ConnectInfo -> ByteString
getHostAddr ci =
  if port == 80 || port == 443
    then encodeUtf8 host
    else
      encodeUtf8 $
        T.concat [host, ":", show port]
  where
    port = connectPort ci
    host = connectHost ci

-- | Default Google Compute Storage ConnectInfo. Works only for
-- "Simple Migration" use-case with interoperability mode enabled on
-- GCP console. For more information -
-- https://cloud.google.com/storage/docs/migrating
--
-- Credentials should be supplied before use.
gcsCI :: ConnectInfo
gcsCI =
  setRegion
    "us"
    "https://storage.googleapis.com"

-- | Default AWS S3 ConnectInfo. Connects to "us-east-1". Credentials
-- should be supplied before use.
awsCI :: ConnectInfo
awsCI = "https://s3.amazonaws.com"

-- | <https://play.min.io MinIO Play Server>
-- ConnectInfo. Credentials are already filled in.
minioPlayCI :: ConnectInfo
minioPlayCI =
  let playCreds = Credentials "Q3AM3UQ867SPQQA43P2F" "zuf+tfteSlswRu7BJ86wekitnifILbZam1KYY3TG"
   in setCreds playCreds $
        setRegion
          "us-east-1"
          "https://play.min.io"

-- |
-- Represents a bucket in the object store
type Bucket = Text

-- |
-- Represents an object name
type Object = Text

-- | Represents a region
type Region = Text

-- | A type alias to represent an Entity-Tag returned by S3-compatible APIs.
type ETag = Text

-- | Data type to represent an object encryption key. Create one using
-- the `mkSSECKey` function.
newtype SSECKey = SSECKey BA.ScrubbedBytes
  deriving stock (Eq, Show)

-- | Validates that the given ByteString is 32 bytes long and creates
-- an encryption key.
mkSSECKey :: MonadThrow m => ByteString -> m SSECKey
mkSSECKey keyBytes
  | B.length keyBytes /= 32 =
      throwM MErrVInvalidEncryptionKeyLength
  | otherwise =
      return $ SSECKey $ BA.convert keyBytes

-- | Data type to represent Server-Side-Encryption settings
data SSE where
  -- | Specifies SSE S3 encryption - server manages encryption keys
  SSE :: SSE
  -- | Specifies that KMS service should be used. The first argument
  -- to the constructor is the Key Id to be used by the server (if
  -- not specified, the default KMS key id is used). The second
  -- argument is the optional KMS context that must have a
  -- `A.ToJSON` instance - please refer to the AWS S3 documentation
  -- for detailed information.
  SSEKMS :: A.ToJSON a => Maybe ByteString -> Maybe a -> SSE
  -- | Specifies server-side encryption with customer provided
  -- key. The argument is the encryption key to be used.
  SSEC :: SSECKey -> SSE

toPutObjectHeaders :: SSE -> [HT.Header]
toPutObjectHeaders sseArg =
  let sseHeader = "x-amz-server-side-encryption"
      sseKmsIdHeader = sseHeader <> "-aws-kms-key-id"
      sseKmsContextHeader = sseHeader <> "-context"
      ssecAlgo = sseHeader <> "-customer-algorithm"
      ssecKey = sseHeader <> "-customer-key"
      ssecKeyMD5 = ssecKey <> "-MD5"
   in case sseArg of
        SSE -> [(sseHeader, "AES256")]
        SSEKMS keyIdMay ctxMay ->
          [(sseHeader, "aws:kms")]
            ++ maybe [] (\k -> [(sseKmsIdHeader, k)]) keyIdMay
            ++ maybe [] (\k -> [(sseKmsContextHeader, LB.toStrict $ A.encode k)]) ctxMay
        SSEC (SSECKey sb) ->
          [ (ssecAlgo, "AES256"),
            (ssecKey, encodeToBase64 sb),
            (ssecKeyMD5, hashMD5ToBase64 sb)
          ]

-- | Data type for options in PutObject call.  Start with the empty
-- `defaultPutObjectOptions` and use various the various poo*
-- accessors.
data PutObjectOptions = PutObjectOptions
  { -- | Set a standard MIME type describing the format of the object.
    pooContentType :: Maybe Text,
    -- | Set what content encodings have been applied to the object and thus
    -- what decoding mechanisms must be applied to obtain the media-type
    -- referenced by the Content-Type header field.
    pooContentEncoding :: Maybe Text,
    -- | Set presentational information for the object.
    pooContentDisposition :: Maybe Text,
    -- | Set to specify caching behavior for the object along the
    -- request/reply chain.
    pooCacheControl :: Maybe Text,
    -- | Set to describe the language(s) intended for the audience.
    pooContentLanguage :: Maybe Text,
    -- | Set to @STANDARD@ or @REDUCED_REDUNDANCY@ depending on your
    -- performance needs, storage class is @STANDARD@ by default (i.e
    -- when Nothing is passed).
    pooStorageClass :: Maybe Text,
    -- | Set user defined metadata to store with the object.
    pooUserMetadata :: [(Text, Text)],
    -- | Set number of worker threads used to upload an object.
    pooNumThreads :: Maybe Word,
    -- | Set object encryption parameters for the request.
    pooSSE :: Maybe SSE
  }

-- | Provide default `PutObjectOptions`.
defaultPutObjectOptions :: PutObjectOptions
defaultPutObjectOptions = PutObjectOptions Nothing Nothing Nothing Nothing Nothing Nothing [] Nothing Nothing

-- | If the given header name has the @X-Amz-Meta-@ prefix, it is
-- stripped and a Just is returned.
userMetadataHeaderNameMaybe :: Text -> Maybe Text
userMetadataHeaderNameMaybe k =
  let prefix = T.toCaseFold "X-Amz-Meta-"
      n = T.length prefix
   in if T.toCaseFold (T.take n k) == prefix
        then Just (T.drop n k)
        else Nothing

addXAmzMetaPrefix :: Text -> Text
addXAmzMetaPrefix s
  | isJust (userMetadataHeaderNameMaybe s) = s
  | otherwise = "X-Amz-Meta-" <> s

mkHeaderFromMetadata :: [(Text, Text)] -> [HT.Header]
mkHeaderFromMetadata = map (\(x, y) -> (mk $ encodeUtf8 $ addXAmzMetaPrefix x, encodeUtf8 y))

pooToHeaders :: PutObjectOptions -> [HT.Header]
pooToHeaders poo =
  userMetadata
    ++ mapMaybe tupToMaybe (zip names values)
    ++ maybe [] toPutObjectHeaders (pooSSE poo)
  where
    tupToMaybe (k, Just v) = Just (k, v)
    tupToMaybe (_, Nothing) = Nothing
    userMetadata = mkHeaderFromMetadata $ pooUserMetadata poo
    names =
      [ "content-type",
        "content-encoding",
        "content-disposition",
        "content-language",
        "cache-control",
        "x-amz-storage-class"
      ]
    values =
      map
        (fmap encodeUtf8 . (poo &))
        [ pooContentType,
          pooContentEncoding,
          pooContentDisposition,
          pooContentLanguage,
          pooCacheControl,
          pooStorageClass
        ]

-- |
-- BucketInfo returned for list buckets call
data BucketInfo = BucketInfo
  { biName :: Bucket,
    biCreationDate :: UTCTime
  }
  deriving stock (Show, Eq)

-- | A type alias to represent a part-number for multipart upload
type PartNumber = Int16

-- | A type alias to represent an upload-id for multipart upload
type UploadId = Text

-- | A type to represent a part-number and etag.
type PartTuple = (PartNumber, ETag)

-- | Represents result from a listing of object parts of an ongoing
-- multipart upload.
data ListPartsResult = ListPartsResult
  { lprHasMore :: Bool,
    lprNextPart :: Maybe Int,
    lprParts :: [ObjectPartInfo]
  }
  deriving stock (Show, Eq)

-- | Represents information about an object part in an ongoing
-- multipart upload.
data ObjectPartInfo = ObjectPartInfo
  { opiNumber :: PartNumber,
    opiETag :: ETag,
    opiSize :: Int64,
    opiModTime :: UTCTime
  }
  deriving stock (Show, Eq)

-- | Represents result from a listing of incomplete uploads to a
-- bucket.
data ListUploadsResult = ListUploadsResult
  { lurHasMore :: Bool,
    lurNextKey :: Maybe Text,
    lurNextUpload :: Maybe Text,
    lurUploads :: [(Object, UploadId, UTCTime)],
    lurCPrefixes :: [Text]
  }
  deriving stock (Show, Eq)

-- | Represents information about a multipart upload.
data UploadInfo = UploadInfo
  { uiKey :: Object,
    uiUploadId :: UploadId,
    uiInitTime :: UTCTime,
    uiSize :: Int64
  }
  deriving stock (Show, Eq)

-- | Represents result from a listing of objects in a bucket.
data ListObjectsResult = ListObjectsResult
  { lorHasMore :: Bool,
    lorNextToken :: Maybe Text,
    lorObjects :: [ObjectInfo],
    lorCPrefixes :: [Text]
  }
  deriving stock (Show, Eq)

-- | Represents result from a listing of objects version 1 in a bucket.
data ListObjectsV1Result = ListObjectsV1Result
  { lorHasMore' :: Bool,
    lorNextMarker :: Maybe Text,
    lorObjects' :: [ObjectInfo],
    lorCPrefixes' :: [Text]
  }
  deriving stock (Show, Eq)

-- | Represents information about an object.
data ObjectInfo = ObjectInfo
  { -- | Object key
    oiObject :: Object,
    -- | Modification time of the object
    oiModTime :: UTCTime,
    -- | ETag of the object
    oiETag :: ETag,
    -- | Size of the object in bytes
    oiSize :: Int64,
    -- | A map of user-metadata
    -- pairs stored with an
    -- object (keys will not
    -- have the @X-Amz-Meta-@
    -- prefix).
    oiUserMetadata :: H.HashMap Text Text,
    -- | A map of metadata
    -- key-value pairs (not
    -- including the
    -- user-metadata pairs)
    oiMetadata :: H.HashMap Text Text
  }
  deriving stock (Show, Eq)

-- | Represents source object in server-side copy object
data SourceInfo = SourceInfo
  { -- | Bucket containing the source object
    srcBucket :: Text,
    -- | Source object key
    srcObject :: Text,
    -- | Source object
    -- byte-range
    -- (inclusive)
    srcRange :: Maybe (Int64, Int64),
    -- | ETag condition on source -
    -- object is copied only if the
    -- source object's ETag matches
    -- this value.
    srcIfMatch :: Maybe Text,
    -- | ETag not match condition
    -- on source - object is copied
    -- if ETag does not match this
    -- value.
    srcIfNoneMatch :: Maybe Text,
    -- | Copy source object only
    -- if the source has been
    -- modified since this time.
    srcIfModifiedSince :: Maybe UTCTime,
    -- | Copy source object only
    -- if the source has been
    -- un-modified since this
    -- given time.
    srcIfUnmodifiedSince :: Maybe UTCTime
  }
  deriving stock (Show, Eq)

-- | Provide a default for `SourceInfo`
defaultSourceInfo :: SourceInfo
defaultSourceInfo = SourceInfo "" "" Nothing Nothing Nothing Nothing Nothing

-- | Represents destination object in server-side copy object
data DestinationInfo = DestinationInfo
  { -- | Destination bucket
    dstBucket :: Text,
    -- | Destination object key
    dstObject :: Text
  }
  deriving stock (Show, Eq)

-- | Provide a default for `DestinationInfo`
defaultDestinationInfo :: DestinationInfo
defaultDestinationInfo = DestinationInfo "" ""

-- | Data type for options when getting an object from the
-- service. Start with the empty `defaultGetObjectOptions` and modify
-- it using the goo* functions.
data GetObjectOptions = GetObjectOptions
  { -- | Set object's data of given offset begin and end,
    -- [ByteRangeFromTo 0 9] means first ten bytes of the source object.
    gooRange :: Maybe ByteRange,
    -- | Set matching ETag condition, GetObject which matches the following
    -- ETag.
    gooIfMatch :: Maybe ETag,
    -- | Set matching ETag none condition, GetObject which does not match
    -- the following ETag.
    gooIfNoneMatch :: Maybe ETag,
    -- | Set object unmodified condition, GetObject unmodified since given time.
    gooIfUnmodifiedSince :: Maybe UTCTime,
    -- | Set object modified condition, GetObject modified since given time.
    gooIfModifiedSince :: Maybe UTCTime,
    -- | Specify SSE-C key
    gooSSECKey :: Maybe SSECKey
  }

-- | Provide default  `GetObjectOptions`.
defaultGetObjectOptions :: GetObjectOptions
defaultGetObjectOptions =
  GetObjectOptions Nothing Nothing Nothing Nothing Nothing Nothing

gooToHeaders :: GetObjectOptions -> [HT.Header]
gooToHeaders goo =
  rangeHdr
    ++ zip names values
    ++ maybe [] (toPutObjectHeaders . SSEC) (gooSSECKey goo)
  where
    names =
      [ "If-Match",
        "If-None-Match",
        "If-Unmodified-Since",
        "If-Modified-Since"
      ]
    values =
      mapMaybe
        (fmap encodeUtf8 . (goo &))
        [ gooIfMatch,
          gooIfNoneMatch,
          fmap formatRFC1123 . gooIfUnmodifiedSince,
          fmap formatRFC1123 . gooIfModifiedSince
        ]
    rangeHdr =
      maybe [] (\a -> [(hRange, HT.renderByteRanges [a])]) $
        gooRange goo

-- | Data type returned by 'getObject' representing the object being
-- retrieved. Use the @gor*@ functions to access its contents.
data GetObjectResponse = GetObjectResponse
  { -- | ObjectInfo of the object being retrieved.
    gorObjectInfo :: ObjectInfo,
    -- | A conduit of the bytes of the object.
    gorObjectStream :: C.ConduitM () ByteString Minio ()
  }

-- | A data-type for events that can occur in the object storage
-- server. Reference:
-- https://docs.aws.amazon.com/AmazonS3/latest/dev/NotificationHowTo.html#supported-notification-event-types
data Event
  = ObjectCreated
  | ObjectCreatedPut
  | ObjectCreatedPost
  | ObjectCreatedCopy
  | ObjectCreatedMultipartUpload
  | ObjectRemoved
  | ObjectRemovedDelete
  | ObjectRemovedDeleteMarkerCreated
  | ReducedRedundancyLostObject
  deriving stock (Eq, Show)

instance ToText Event where
  toText ObjectCreated = "s3:ObjectCreated:*"
  toText ObjectCreatedPut = "s3:ObjectCreated:Put"
  toText ObjectCreatedPost = "s3:ObjectCreated:Post"
  toText ObjectCreatedCopy = "s3:ObjectCreated:Copy"
  toText ObjectCreatedMultipartUpload = "s3:ObjectCreated:MultipartUpload"
  toText ObjectRemoved = "s3:ObjectRemoved:*"
  toText ObjectRemovedDelete = "s3:ObjectRemoved:Delete"
  toText ObjectRemovedDeleteMarkerCreated = "s3:ObjectRemoved:DeleteMarkerCreated"
  toText ReducedRedundancyLostObject = "s3:ReducedRedundancyLostObject"

textToEvent :: Text -> Maybe Event
textToEvent t = case t of
  "s3:ObjectCreated:*" -> Just ObjectCreated
  "s3:ObjectCreated:Put" -> Just ObjectCreatedPut
  "s3:ObjectCreated:Post" -> Just ObjectCreatedPost
  "s3:ObjectCreated:Copy" -> Just ObjectCreatedCopy
  "s3:ObjectCreated:MultipartUpload" -> Just ObjectCreatedMultipartUpload
  "s3:ObjectRemoved:*" -> Just ObjectRemoved
  "s3:ObjectRemoved:Delete" -> Just ObjectRemovedDelete
  "s3:ObjectRemoved:DeleteMarkerCreated" -> Just ObjectRemovedDeleteMarkerCreated
  "s3:ReducedRedundancyLostObject" -> Just ReducedRedundancyLostObject
  _ -> Nothing

-- | Filter data type - part of notification configuration
newtype Filter = Filter
  { fFilter :: FilterKey
  }
  deriving stock (Show, Eq)

-- | defaultFilter is empty, used to create a notification
-- configuration.
defaultFilter :: Filter
defaultFilter = Filter defaultFilterKey

-- | FilterKey contains FilterRules, and is part of a Filter.
newtype FilterKey = FilterKey
  { fkKey :: FilterRules
  }
  deriving stock (Show, Eq)

-- | defaultFilterKey is empty, used to create notification
-- configuration.
defaultFilterKey :: FilterKey
defaultFilterKey = FilterKey defaultFilterRules

-- | FilterRules represents a collection of `FilterRule`s.
newtype FilterRules = FilterRules
  { frFilterRules :: [FilterRule]
  }
  deriving stock (Show, Eq)

-- | defaultFilterRules is empty, used to create notification
-- configuration.
defaultFilterRules :: FilterRules
defaultFilterRules = FilterRules []

-- | A filter rule that can act based on the suffix or prefix of an
-- object. As an example, let's create two filter rules:
--
--    > let suffixRule = FilterRule "suffix" ".jpg"
--    > let prefixRule = FilterRule "prefix" "images/"
--
-- The @suffixRule@ restricts the notification to be triggered only
-- for objects having a suffix of ".jpg", and the @prefixRule@
-- restricts it to objects having a prefix of "images/".
data FilterRule = FilterRule
  { frName :: Text,
    frValue :: Text
  }
  deriving stock (Show, Eq)

-- | Arn is an alias of Text
type Arn = Text

-- | A data-type representing the configuration for a particular
-- notification system. It could represent a Queue, Topic or Lambda
-- Function configuration.
data NotificationConfig = NotificationConfig
  { ncId :: Text,
    ncArn :: Arn,
    ncEvents :: [Event],
    ncFilter :: Filter
  }
  deriving stock (Show, Eq)

-- | A data-type to represent bucket notification configuration. It is
-- a collection of queue, topic or lambda function configurations. The
-- structure of the types follow closely the XML representation
-- described at
-- <https://docs.aws.amazon.com/AmazonS3/latest/API/RESTBucketPUTnotification.html>
data Notification = Notification
  { nQueueConfigurations :: [NotificationConfig],
    nTopicConfigurations :: [NotificationConfig],
    nCloudFunctionConfigurations :: [NotificationConfig]
  }
  deriving stock (Show, Eq)

-- | The default notification configuration is empty.
defaultNotification :: Notification
defaultNotification = Notification [] [] []

--------------------------------------------------------------------------
-- Select API Related Types
--------------------------------------------------------------------------

-- | SelectRequest represents the Select API call. Use the
-- `selectRequest` function to create a value of this type.
data SelectRequest = SelectRequest
  { srExpression :: Text,
    srExpressionType :: ExpressionType,
    srInputSerialization :: InputSerialization,
    srOutputSerialization :: OutputSerialization,
    srRequestProgressEnabled :: Maybe Bool
  }
  deriving stock (Show, Eq)

data ExpressionType = SQL
  deriving stock (Show, Eq)

-- | InputSerialization represents format information of the input
-- object being queried. Use one of the smart constructors such as
-- `defaultCsvInput` as a starting value, and add compression info
-- using `setInputCompressionType`
data InputSerialization = InputSerialization
  { isCompressionType :: Maybe CompressionType,
    isFormatInfo :: InputFormatInfo
  }
  deriving stock (Show, Eq)

-- | Data type representing the compression setting in a Select
-- request.
data CompressionType
  = CompressionTypeNone
  | CompressionTypeGzip
  | CompressionTypeBzip2
  deriving stock (Show, Eq)

-- | Data type representing input object format information in a
-- Select request.
data InputFormatInfo
  = InputFormatCSV CSVInputProp
  | InputFormatJSON JSONInputProp
  | InputFormatParquet
  deriving stock (Show, Eq)

-- | defaultCsvInput returns InputSerialization with default CSV
-- format, and without any compression setting.
defaultCsvInput :: InputSerialization
defaultCsvInput = InputSerialization Nothing (InputFormatCSV defaultCSVProp)

-- | linesJsonInput returns InputSerialization with JSON line based
-- format with no compression setting.
linesJsonInput :: InputSerialization
linesJsonInput =
  InputSerialization
    Nothing
    (InputFormatJSON $ JSONInputProp JSONTypeLines)

-- | documentJsonInput returns InputSerialization with JSON document
-- based format with no compression setting.
documentJsonInput :: InputSerialization
documentJsonInput =
  InputSerialization
    Nothing
    (InputFormatJSON $ JSONInputProp JSONTypeDocument)

-- | defaultParquetInput returns InputSerialization with Parquet
-- format, and no compression setting.
defaultParquetInput :: InputSerialization
defaultParquetInput = InputSerialization Nothing InputFormatParquet

-- | setInputCompressionType sets the compression type for the input
-- of the SelectRequest
setInputCompressionType ::
  CompressionType ->
  SelectRequest ->
  SelectRequest
setInputCompressionType c i =
  let is = srInputSerialization i
      is' = is {isCompressionType = Just c}
   in i {srInputSerialization = is'}

-- | defaultCsvOutput returns OutputSerialization with default CSV
-- format.
defaultCsvOutput :: OutputSerialization
defaultCsvOutput = OutputSerializationCSV defaultCSVProp

-- | defaultJsonInput returns OutputSerialization with default JSON
-- format.
defaultJsonOutput :: OutputSerialization
defaultJsonOutput = OutputSerializationJSON (JSONOutputProp Nothing)

-- | selectRequest is used to build a `SelectRequest`
-- value. @selectRequest query inputSer outputSer@ represents a
-- SelectRequest with the SQL query text given by @query@, the input
-- serialization settings (compression format and format information)
-- @inputSer@ and the output serialization settings @outputSer@.
selectRequest ::
  Text ->
  InputSerialization ->
  OutputSerialization ->
  SelectRequest
selectRequest sqlQuery inputSer outputSer =
  SelectRequest
    { srExpression = sqlQuery,
      srExpressionType = SQL,
      srInputSerialization = inputSer,
      srOutputSerialization = outputSer,
      srRequestProgressEnabled = Nothing
    }

-- | setRequestProgressEnabled sets the flag for turning on progress
-- messages when the Select response is being streamed back to the
-- client.
setRequestProgressEnabled :: Bool -> SelectRequest -> SelectRequest
setRequestProgressEnabled enabled sr =
  sr {srRequestProgressEnabled = Just enabled}

type CSVInputProp = CSVProp

-- | CSVProp represents CSV format properties. It is built up using
-- the Monoid instance.
newtype CSVProp = CSVProp (H.HashMap Text Text)
  deriving stock (Show, Eq)

instance Semigroup CSVProp where
  (CSVProp a) <> (CSVProp b) = CSVProp (b <> a)

instance Monoid CSVProp where
  mempty = CSVProp mempty

csvPropsList :: CSVProp -> [(Text, Text)]
csvPropsList (CSVProp h) = sort $ H.toList h

defaultCSVProp :: CSVProp
defaultCSVProp = mempty

-- | Specify the CSV record delimiter property.
recordDelimiter :: Text -> CSVProp
recordDelimiter = CSVProp . H.singleton "RecordDelimiter"

-- | Specify the CSV field delimiter property.
fieldDelimiter :: Text -> CSVProp
fieldDelimiter = CSVProp . H.singleton "FieldDelimiter"

-- | Specify the CSV quote character property.
quoteCharacter :: Text -> CSVProp
quoteCharacter = CSVProp . H.singleton "QuoteCharacter"

-- | Specify the CSV quote-escape character property.
quoteEscapeCharacter :: Text -> CSVProp
quoteEscapeCharacter = CSVProp . H.singleton "QuoteEscapeCharacter"

-- | FileHeaderInfo specifies information about column headers for CSV
-- format.
data FileHeaderInfo
  = -- | No column headers are present
    FileHeaderNone
  | -- | Headers are present and they should be used
    FileHeaderUse
  | -- | Header are present, but should be ignored
    FileHeaderIgnore
  deriving stock (Show, Eq)

-- | Specify the CSV file header info property.
fileHeaderInfo :: FileHeaderInfo -> CSVProp
fileHeaderInfo = CSVProp . H.singleton "FileHeaderInfo" . toStr
  where
    toStr FileHeaderNone = "NONE"
    toStr FileHeaderUse = "USE"
    toStr FileHeaderIgnore = "IGNORE"

-- | Specify the CSV comment character property. Lines starting with
-- this character are ignored by the server.
commentCharacter :: Text -> CSVProp
commentCharacter = CSVProp . H.singleton "Comments"

-- | Allow quoted record delimiters inside a row using this property.
allowQuotedRecordDelimiter :: CSVProp
allowQuotedRecordDelimiter = CSVProp $ H.singleton "AllowQuotedRecordDelimiter" "TRUE"

-- | Set the CSV format properties in the InputSerialization.
setInputCSVProps :: CSVProp -> InputSerialization -> InputSerialization
setInputCSVProps p is = is {isFormatInfo = InputFormatCSV p}

-- | Set the CSV format properties in the OutputSerialization.
outputCSVFromProps :: CSVProp -> OutputSerialization
outputCSVFromProps = OutputSerializationCSV

newtype JSONInputProp = JSONInputProp {jsonipType :: JSONType}
  deriving stock (Show, Eq)

data JSONType = JSONTypeDocument | JSONTypeLines
  deriving stock (Show, Eq)

-- | OutputSerialization represents output serialization settings for
-- the SelectRequest. Use `defaultCsvOutput` or `defaultJsonOutput` as
-- a starting point.
data OutputSerialization
  = OutputSerializationJSON JSONOutputProp
  | OutputSerializationCSV CSVOutputProp
  deriving stock (Show, Eq)

type CSVOutputProp = CSVProp

-- | quoteFields is an output serialization parameter
quoteFields :: QuoteFields -> CSVProp
quoteFields q = CSVProp $
  H.singleton "QuoteFields" $
    case q of
      QuoteFieldsAsNeeded -> "ASNEEDED"
      QuoteFieldsAlways -> "ALWAYS"

-- | Represent the QuoteField setting.
data QuoteFields = QuoteFieldsAsNeeded | QuoteFieldsAlways
  deriving stock (Show, Eq)

newtype JSONOutputProp = JSONOutputProp {jsonopRecordDelimiter :: Maybe Text}
  deriving stock (Show, Eq)

-- | Set the output record delimiter for JSON format
outputJSONFromRecordDelimiter :: Text -> OutputSerialization
outputJSONFromRecordDelimiter t =
  OutputSerializationJSON (JSONOutputProp $ Just t)

-- Response related types

-- | An EventMessage represents each kind of message received from the server.
data EventMessage
  = ProgressEventMessage {emProgress :: Progress}
  | StatsEventMessage {emStats :: Stats}
  | RequestLevelErrorMessage
      { emErrorCode :: Text,
        emErrorMessage :: Text
      }
  | RecordPayloadEventMessage {emPayloadBytes :: ByteString}
  deriving stock (Show, Eq)

data MsgHeaderName
  = MessageType
  | EventType
  | ContentType
  | ErrorCode
  | ErrorMessage
  deriving stock (Show, Eq)

msgHeaderValueType :: Word8
msgHeaderValueType = 7

type MessageHeader = (MsgHeaderName, Text)

-- | Represent the progress event returned in the Select response.
data Progress = Progress
  { pBytesScanned :: Int64,
    pBytesProcessed :: Int64,
    pBytesReturned :: Int64
  }
  deriving stock (Show, Eq)

-- | Represent the stats event returned at the end of the Select
-- response.
type Stats = Progress

--------------------------------------------------------------------------
-- Select API Related Types End
--------------------------------------------------------------------------

-- | Represents different kinds of payload that are used with S3 API
-- requests.
data Payload
  = PayloadBS ByteString
  | PayloadH Handle Int64 Int64 -- file handle, offset and length
  | PayloadC Int64 (C.ConduitT () ByteString (ResourceT IO) ()) -- length and byte source

defaultPayload :: Payload
defaultPayload = PayloadBS ""

data AdminReqInfo = AdminReqInfo
  { ariMethod :: Method,
    ariPayloadHash :: Maybe ByteString,
    ariPayload :: Payload,
    ariPath :: ByteString,
    ariHeaders :: [Header],
    ariQueryParams :: Query
  }

data S3ReqInfo = S3ReqInfo
  { riMethod :: Method,
    riBucket :: Maybe Bucket,
    riObject :: Maybe Object,
    riQueryParams :: Query,
    riHeaders :: [Header],
    riPayload :: Payload,
    riPayloadHash :: Maybe ByteString,
    riRegion :: Maybe Region,
    riNeedsLocation :: Bool,
    riPresignExpirySecs :: Maybe UrlExpiry
  }

defaultS3ReqInfo :: S3ReqInfo
defaultS3ReqInfo =
  S3ReqInfo
    HT.methodGet
    Nothing
    Nothing
    []
    []
    defaultPayload
    Nothing
    Nothing
    True
    Nothing

getS3Path :: Maybe Bucket -> Maybe Object -> ByteString
getS3Path b o =
  let segments = map encodeUtf8 $ catMaybes $ b : bool [] [o] (isJust b)
   in B.concat ["/", B.intercalate "/" segments]

type RegionMap = H.HashMap Bucket Region

-- | The Minio Monad - all computations accessing object storage
-- happens in it.
newtype Minio a = Minio
  { unMinio :: ReaderT MinioConn (ResourceT IO) a
  }
  deriving newtype
    ( Functor,
      Applicative,
      Monad,
      MonadIO,
      MonadReader MinioConn,
      MonadResource,
      MonadUnliftIO
    )

-- | MinioConn holds connection info and a connection pool to allow
-- for efficient resource re-use.
data MinioConn = MinioConn
  { mcConnInfo :: ConnectInfo,
    mcConnManager :: NC.Manager,
    mcRegionMap :: MVar RegionMap
  }

class HasSvcNamespace env where
  getSvcNamespace :: env -> Text

instance HasSvcNamespace MinioConn where
  getSvcNamespace env =
    let host = connectHost $ mcConnInfo env
     in ( if host == "storage.googleapis.com"
            then "http://doc.s3.amazonaws.com/2006-03-01"
            else "http://s3.amazonaws.com/doc/2006-03-01/"
        )

-- | Takes connection information and returns a connection object to
-- be passed to 'runMinio'. The returned value can be kept in the
-- application environment and passed to `runMinioWith` whenever
-- object storage is accessed.
connect :: ConnectInfo -> IO MinioConn
connect ci = do
  let settings
        | connectIsSecure ci && connectDisableTLSCertValidation ci =
            let badTlsSettings = Conn.TLSSettingsSimple True False False
             in TLS.mkManagerSettings badTlsSettings Nothing
        | connectIsSecure ci = NC.tlsManagerSettings
        | otherwise = defaultManagerSettings
  mgr <- NC.newManager settings
  mkMinioConn ci mgr

-- | Run the computation accessing object storage using the given
-- `MinioConn`. This reuses connections, but otherwise it is similar
-- to `runMinio`.
runMinioWith :: MinioConn -> Minio a -> IO (Either MinioErr a)
runMinioWith conn m = runResourceT $ runMinioResWith conn m

-- | Given `ConnectInfo` and a HTTP connection manager, create a
-- `MinioConn`.
mkMinioConn :: ConnectInfo -> NC.Manager -> IO MinioConn
mkMinioConn ci mgr = do
  rMapMVar <- M.newMVar H.empty
  return $ MinioConn ci mgr rMapMVar

-- | Run the Minio action and return the result or an error.
runMinio :: ConnectInfo -> Minio a -> IO (Either MinioErr a)
runMinio ci m = do
  conn <- connect ci
  runResourceT $ runMinioResWith conn m

-- | Similar to 'runMinioWith'. Allows applications to allocate/release
-- its resources along side MinIO's internal resources.
runMinioResWith :: MinioConn -> Minio a -> ResourceT IO (Either MinioErr a)
runMinioResWith conn m =
  flip runReaderT conn . unMinio $
    fmap Right m
      `U.catches` [ U.Handler handlerServiceErr,
                    U.Handler handlerHE,
                    U.Handler handlerFE,
                    U.Handler handlerValidation
                  ]
  where
    handlerServiceErr = return . Left . MErrService
    handlerHE = return . Left . MErrHTTP
    handlerFE = return . Left . MErrIO
    handlerValidation = return . Left . MErrValidation

-- | Similar to 'runMinio'. Allows applications to allocate/release
-- its resources along side MinIO's internal resources.
runMinioRes :: ConnectInfo -> Minio a -> ResourceT IO (Either MinioErr a)
runMinioRes ci m = do
  conn <- liftIO $ connect ci
  runMinioResWith conn m

s3Name :: Text -> Text -> Name
s3Name ns s = Name s (Just ns) Nothing

-- | Format as per RFC 1123.
formatRFC1123 :: UTCTime -> T.Text
formatRFC1123 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %X %Z"