--
-- 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.
--

module Network.Minio.API
  ( connect,
    S3ReqInfo (..),
    runMinio,
    executeRequest,
    buildRequest,
    mkStreamRequest,
    getLocation,
    isValidBucketName,
    checkBucketNameValidity,
    isValidObjectName,
    checkObjectNameValidity,
    requestSTSCredential,
  )
where

import Control.Retry
  ( fullJitterBackoff,
    limitRetriesByCumulativeDelay,
    retrying,
  )
import qualified Data.ByteString as B
import qualified Data.Char as C
import qualified Data.Conduit as C
import qualified Data.HashMap.Strict as H
import qualified Data.Text as T
import qualified Data.Time.Clock as Time
import Lib.Prelude
import Network.HTTP.Client (defaultManagerSettings)
import qualified Network.HTTP.Client as NClient
import Network.HTTP.Conduit (Response)
import qualified Network.HTTP.Conduit as NC
import Network.HTTP.Types (simpleQueryToQuery)
import qualified Network.HTTP.Types as HT
import Network.HTTP.Types.Header (hHost)
import Network.Minio.APICommon
import Network.Minio.Credentials
import Network.Minio.Data
import Network.Minio.Errors
import Network.Minio.Sign.V4
import Network.Minio.Utils
import Network.Minio.XmlParser

-- | Fetch bucket location (region)
getLocation :: Bucket -> Minio Region
getLocation :: Object -> Minio Object
getLocation Object
bucket = do
  Response LByteString
resp <-
    S3ReqInfo -> Minio (Response LByteString)
executeRequest forall a b. (a -> b) -> a -> b
$
      S3ReqInfo
defaultS3ReqInfo
        { riBucket :: Maybe Object
riBucket = forall a. a -> Maybe a
Just Object
bucket,
          riQueryParams :: Query
riQueryParams = [(ByteString
"location", forall a. Maybe a
Nothing)],
          riNeedsLocation :: Bool
riNeedsLocation = Bool
False
        }
  forall (m :: * -> *). MonadIO m => LByteString -> m Object
parseLocation forall a b. (a -> b) -> a -> b
$ forall body. Response body -> body
NC.responseBody Response LByteString
resp

-- | Looks for region in RegionMap and updates it using getLocation if
-- absent.
discoverRegion :: S3ReqInfo -> Minio (Maybe Region)
discoverRegion :: S3ReqInfo -> Minio (Maybe Object)
discoverRegion S3ReqInfo
ri = forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ do
  Object
bucket <- forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ S3ReqInfo -> Maybe Object
riBucket S3ReqInfo
ri
  Maybe Object
regionMay <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Object -> Minio (Maybe Object)
lookupRegionCache Object
bucket
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe
    ( do
        Object
l <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Object -> Minio Object
getLocation Object
bucket
        forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Object -> Object -> Minio ()
addToRegionCache Object
bucket Object
l
        forall (m :: * -> *) a. Monad m => a -> m a
return Object
l
    )
    forall (m :: * -> *) a. Monad m => a -> m a
return
    Maybe Object
regionMay

-- | Returns the region to be used for the request.
getRegion :: S3ReqInfo -> Minio (Maybe Region)
getRegion :: S3ReqInfo -> Minio (Maybe Object)
getRegion S3ReqInfo
ri = do
  ConnectInfo
ci <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MinioConn -> ConnectInfo
mcConnInfo

  -- getService/makeBucket/getLocation -- don't need location
  if
      | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ S3ReqInfo -> Bool
riNeedsLocation S3ReqInfo
ri ->
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ConnectInfo -> Object
connectRegion ConnectInfo
ci
      -- if autodiscovery of location is disabled by user
      | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ ConnectInfo -> Bool
connectAutoDiscoverRegion ConnectInfo
ci ->
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ConnectInfo -> Object
connectRegion ConnectInfo
ci
      -- discover the region for the request
      | Bool
otherwise -> S3ReqInfo -> Minio (Maybe Object)
discoverRegion S3ReqInfo
ri

getRegionHost :: Region -> Minio Text
getRegionHost :: Object -> Minio Object
getRegionHost Object
r = do
  ConnectInfo
ci <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MinioConn -> ConnectInfo
mcConnInfo

  if Object
"amazonaws.com" Object -> Object -> Bool
`T.isSuffixOf` ConnectInfo -> Object
connectHost ConnectInfo
ci
    then
      forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        (forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Object -> MErrV
MErrVRegionNotSupported Object
r)
        forall (m :: * -> *) a. Monad m => a -> m a
return
        (forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup Object
r HashMap Object Object
awsRegionMap)
    else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ConnectInfo -> Object
connectHost ConnectInfo
ci

-- | Computes the appropriate host, path and region for the request.
--
-- For AWS, always use virtual bucket style, unless bucket has periods. For
-- MinIO and other non-AWS, default to path style.
getHostPathRegion :: S3ReqInfo -> Minio (Text, ByteString, Maybe Region)
getHostPathRegion :: S3ReqInfo -> Minio (Object, ByteString, Maybe Object)
getHostPathRegion S3ReqInfo
ri = do
  ConnectInfo
ci <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MinioConn -> ConnectInfo
mcConnInfo
  Maybe Object
regionMay <- S3ReqInfo -> Minio (Maybe Object)
getRegion S3ReqInfo
ri
  case S3ReqInfo -> Maybe Object
riBucket S3ReqInfo
ri of
    Maybe Object
Nothing ->
      -- Implies a ListBuckets request.
      forall (m :: * -> *) a. Monad m => a -> m a
return (ConnectInfo -> Object
connectHost ConnectInfo
ci, ByteString
"/", Maybe Object
regionMay)
    Just Object
bucket -> do
      Object
regionHost <- case Maybe Object
regionMay of
        Maybe Object
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ConnectInfo -> Object
connectHost ConnectInfo
ci
        Just Object
"" -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ConnectInfo -> Object
connectHost ConnectInfo
ci
        Just Object
r -> Object -> Minio Object
getRegionHost Object
r
      let pathStyle :: (Object, ByteString, Maybe Object)
pathStyle =
            ( Object
regionHost,
              Maybe Object -> Maybe Object -> ByteString
getS3Path (S3ReqInfo -> Maybe Object
riBucket S3ReqInfo
ri) (S3ReqInfo -> Maybe Object
riObject S3ReqInfo
ri),
              Maybe Object
regionMay
            )
          virtualStyle :: (Object, ByteString, Maybe Object)
virtualStyle =
            ( Object
bucket forall a. Semigroup a => a -> a -> a
<> Object
"." forall a. Semigroup a => a -> a -> a
<> Object
regionHost,
              forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 forall a b. (a -> b) -> a -> b
$ Object
"/" forall a. Semigroup a => a -> a -> a
<> forall a. a -> Maybe a -> a
fromMaybe Object
"" (S3ReqInfo -> Maybe Object
riObject S3ReqInfo
ri),
              Maybe Object
regionMay
            )
      ( if ConnectInfo -> Bool
isAWSConnectInfo ConnectInfo
ci
          then
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
              if Object -> Bool
bucketHasPeriods Object
bucket
                then (Object, ByteString, Maybe Object)
pathStyle
                else (Object, ByteString, Maybe Object)
virtualStyle
          else forall (m :: * -> *) a. Monad m => a -> m a
return (Object, ByteString, Maybe Object)
pathStyle
        )

-- | requestSTSCredential requests temporary credentials using the Security Token
-- Service API. The returned credential will include a populated 'SessionToken'
-- and an 'ExpiryTime'.
requestSTSCredential :: (STSCredentialProvider p) => p -> IO (CredentialValue, ExpiryTime)
requestSTSCredential :: forall p.
STSCredentialProvider p =>
p -> IO (CredentialValue, ExpiryTime)
requestSTSCredential p
p = do
  Object
endpoint <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ MErrV -> MinioErr
MErrValidation MErrV
MErrVSTSEndpointNotFound) forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p. STSCredentialProvider p => p -> Maybe Object
getSTSEndpoint p
p
  let endPt :: Request
endPt = String -> Request
NC.parseRequest_ forall a b. (a -> b) -> a -> b
$ forall a. ToString a => a -> String
toString Object
endpoint
      settings :: ManagerSettings
settings
        | Request -> Bool
NC.secure Request
endPt = ManagerSettings
NC.tlsManagerSettings
        | Bool
otherwise = ManagerSettings
defaultManagerSettings

  Manager
mgr <- ManagerSettings -> IO Manager
NC.newManager ManagerSettings
settings
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall p.
STSCredentialProvider p =>
p -> Endpoint -> Manager -> IO (CredentialValue, ExpiryTime)
retrieveSTSCredentials p
p (ByteString
"", Int
0, Bool
False) Manager
mgr

buildRequest :: S3ReqInfo -> Minio NC.Request
buildRequest :: S3ReqInfo -> Minio Request
buildRequest S3ReqInfo
ri = do
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall (m :: * -> *). MonadIO m => Object -> m ()
checkBucketNameValidity forall a b. (a -> b) -> a -> b
$ S3ReqInfo -> Maybe Object
riBucket S3ReqInfo
ri
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall (m :: * -> *). MonadIO m => Object -> m ()
checkObjectNameValidity forall a b. (a -> b) -> a -> b
$ S3ReqInfo -> Maybe Object
riObject S3ReqInfo
ri

  ConnectInfo
ci <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MinioConn -> ConnectInfo
mcConnInfo

  (Object
host, ByteString
path, Maybe Object
regionMay) <- S3ReqInfo -> Minio (Object, ByteString, Maybe Object)
getHostPathRegion S3ReqInfo
ri

  let ci' :: ConnectInfo
ci' = ConnectInfo
ci {connectHost :: Object
connectHost = Object
host}
      hostHeader :: (HeaderName, ByteString)
hostHeader = (HeaderName
hHost, ConnectInfo -> ByteString
getHostAddr ConnectInfo
ci')
      ri' :: S3ReqInfo
ri' =
        S3ReqInfo
ri
          { riHeaders :: [(HeaderName, ByteString)]
riHeaders = (HeaderName, ByteString)
hostHeader forall a. a -> [a] -> [a]
: S3ReqInfo -> [(HeaderName, ByteString)]
riHeaders S3ReqInfo
ri,
            riRegion :: Maybe Object
riRegion = Maybe Object
regionMay
          }
      -- Does not contain body and auth info.
      baseRequest :: Request
baseRequest =
        Request
NC.defaultRequest
          { method :: ByteString
NC.method = S3ReqInfo -> ByteString
riMethod S3ReqInfo
ri',
            secure :: Bool
NC.secure = ConnectInfo -> Bool
connectIsSecure ConnectInfo
ci',
            host :: ByteString
NC.host = forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 forall a b. (a -> b) -> a -> b
$ ConnectInfo -> Object
connectHost ConnectInfo
ci',
            port :: Int
NC.port = ConnectInfo -> Int
connectPort ConnectInfo
ci',
            path :: ByteString
NC.path = ByteString
path,
            requestHeaders :: [(HeaderName, ByteString)]
NC.requestHeaders = S3ReqInfo -> [(HeaderName, ByteString)]
riHeaders S3ReqInfo
ri',
            queryString :: ByteString
NC.queryString = Bool -> Query -> ByteString
HT.renderQuery Bool
False forall a b. (a -> b) -> a -> b
$ S3ReqInfo -> Query
riQueryParams S3ReqInfo
ri'
          }

  UTCTime
timeStamp <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
Time.getCurrentTime

  Manager
mgr <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MinioConn -> Manager
mcConnManager
  CredentialValue
cv <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Creds -> Endpoint -> Manager -> IO CredentialValue
getCredential (ConnectInfo -> Creds
connectCreds ConnectInfo
ci') (ConnectInfo -> Endpoint
getEndpoint ConnectInfo
ci') Manager
mgr

  let sp :: SignParams
sp =
        Object
-> ScrubbedBytes
-> Maybe ScrubbedBytes
-> Service
-> UTCTime
-> Maybe Object
-> Maybe Int
-> Maybe ByteString
-> SignParams
SignParams
          (coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ CredentialValue -> AccessKey
cvAccessKey CredentialValue
cv)
          (coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ CredentialValue -> SecretKey
cvSecretKey CredentialValue
cv)
          (coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ CredentialValue -> Maybe SessionToken
cvSessionToken CredentialValue
cv)
          Service
ServiceS3
          UTCTime
timeStamp
          (S3ReqInfo -> Maybe Object
riRegion S3ReqInfo
ri')
          (S3ReqInfo -> Maybe Int
riPresignExpirySecs S3ReqInfo
ri')
          forall a. Maybe a
Nothing

  -- Cases to handle:
  --
  -- 0. Handle presign URL case.
  --
  -- 1. Connection is secure: use unsigned payload
  --
  -- 2. Insecure connection, streaming signature is enabled via use of
  --    conduit payload: use streaming signature for request.
  --
  -- 3. Insecure connection, non-conduit payload: compute payload
  -- sha256hash, buffer request in memory and perform request.

  if
      | forall a. Maybe a -> Bool
isJust (S3ReqInfo -> Maybe Int
riPresignExpirySecs S3ReqInfo
ri') ->
          -- case 0 from above.
          do
            let signPairs :: SimpleQuery
signPairs = SignParams -> Request -> SimpleQuery
signV4QueryParams SignParams
sp Request
baseRequest
                qpToAdd :: Query
qpToAdd = SimpleQuery -> Query
simpleQueryToQuery SimpleQuery
signPairs
                existingQueryParams :: Query
existingQueryParams = ByteString -> Query
HT.parseQuery (Request -> ByteString
NC.queryString Request
baseRequest)
                updatedQueryParams :: Query
updatedQueryParams = Query
existingQueryParams forall a. [a] -> [a] -> [a]
++ Query
qpToAdd
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Query -> Request -> Request
NClient.setQueryString Query
updatedQueryParams Request
baseRequest
      | Payload -> Bool
isStreamingPayload (S3ReqInfo -> Payload
riPayload S3ReqInfo
ri') Bool -> Bool -> Bool
&& Bool -> Bool
not (ConnectInfo -> Bool
connectIsSecure ConnectInfo
ci') ->
          -- case 2 from above.
          do
            (Int64
pLen, ConduitT () ByteString (ResourceT IO) ()
pSrc) <- case S3ReqInfo -> Payload
riPayload S3ReqInfo
ri of
              PayloadC Int64
l ConduitT () ByteString (ResourceT IO) ()
src -> forall (m :: * -> *) a. Monad m => a -> m a
return (Int64
l, ConduitT () ByteString (ResourceT IO) ()
src)
              Payload
_ -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO MErrV
MErrVUnexpectedPayload
            let reqFn :: ConduitT () ByteString (ResourceT IO) () -> Request
reqFn = Int64
-> SignParams
-> Request
-> ConduitT () ByteString (ResourceT IO) ()
-> Request
signV4Stream Int64
pLen SignParams
sp Request
baseRequest
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ConduitT () ByteString (ResourceT IO) () -> Request
reqFn ConduitT () ByteString (ResourceT IO) ()
pSrc
      | Bool
otherwise ->
          do
            SignParams
sp' <-
              ( if ConnectInfo -> Bool
connectIsSecure ConnectInfo
ci'
                  then -- case 1 described above.
                    forall (m :: * -> *) a. Monad m => a -> m a
return SignParams
sp
                  else
                    ( -- case 3 described above.
                      do
                        ByteString
pHash <- Payload -> Minio ByteString
getPayloadSHA256Hash forall a b. (a -> b) -> a -> b
$ S3ReqInfo -> Payload
riPayload S3ReqInfo
ri'
                        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SignParams
sp {spPayloadHash :: Maybe ByteString
spPayloadHash = forall a. a -> Maybe a
Just ByteString
pHash}
                    )
                )

            let signHeaders :: [(HeaderName, ByteString)]
signHeaders = SignParams -> Request -> [(HeaderName, ByteString)]
signV4 SignParams
sp' Request
baseRequest
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
              Request
baseRequest
                { requestHeaders :: [(HeaderName, ByteString)]
NC.requestHeaders =
                    Request -> [(HeaderName, ByteString)]
NC.requestHeaders Request
baseRequest forall a. [a] -> [a] -> [a]
++ [(HeaderName, ByteString)]
signHeaders,
                  requestBody :: RequestBody
NC.requestBody = Payload -> RequestBody
getRequestBody (S3ReqInfo -> Payload
riPayload S3ReqInfo
ri')
                }

retryAPIRequest :: Minio a -> Minio a
retryAPIRequest :: forall a. Minio a -> Minio a
retryAPIRequest Minio a
apiCall = do
  Either HttpException a
resE <-
    forall (m :: * -> *) b.
MonadIO m =>
RetryPolicyM m
-> (RetryStatus -> b -> m Bool) -> (RetryStatus -> m b) -> m b
retrying RetryPolicyM Minio
retryPolicy (forall a b. a -> b -> a
const forall a. Either HttpException a -> Minio Bool
shouldRetry) forall a b. (a -> b) -> a -> b
$
      forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try Minio a
apiCall
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall (m :: * -> *) a. Monad m => a -> m a
return Either HttpException a
resE
  where
    -- Retry using the full-jitter backoff method for up to 10 mins
    -- total
    retryPolicy :: RetryPolicyM Minio
retryPolicy =
      forall (m :: * -> *).
Monad m =>
Int -> RetryPolicyM m -> RetryPolicyM m
limitRetriesByCumulativeDelay Int
tenMins forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *). MonadIO m => Int -> RetryPolicyM m
fullJitterBackoff Int
oneMilliSecond
    oneMilliSecond :: Int
oneMilliSecond = Int
1000 -- in microseconds
    tenMins :: Int
tenMins = Int
10 forall a. Num a => a -> a -> a
* Int
60 forall a. Num a => a -> a -> a
* Int
1000000 -- in microseconds
    -- retry on connection related failure
    shouldRetry :: Either NC.HttpException a -> Minio Bool
    shouldRetry :: forall a. Either HttpException a -> Minio Bool
shouldRetry Either HttpException a
resE =
      case Either HttpException a
resE of
        -- API request returned successfully
        Right a
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        -- API request failed with a retryable exception
        Left httpExn :: HttpException
httpExn@(NC.HttpExceptionRequest Request
_ HttpExceptionContent
exn) ->
          case (HttpExceptionContent
exn :: NC.HttpExceptionContent) of
            HttpExceptionContent
NC.ResponseTimeout -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
            HttpExceptionContent
NC.ConnectionTimeout -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
            NC.ConnectionFailure SomeException
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
            -- We received an unexpected exception
            HttpExceptionContent
_ -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO HttpException
httpExn
        -- We received an unexpected exception
        Left HttpException
someOtherExn -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO HttpException
someOtherExn

executeRequest :: S3ReqInfo -> Minio (Response LByteString)
executeRequest :: S3ReqInfo -> Minio (Response LByteString)
executeRequest S3ReqInfo
ri = do
  Request
req <- S3ReqInfo -> Minio Request
buildRequest S3ReqInfo
ri
  Manager
mgr <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MinioConn -> Manager
mcConnManager
  forall a. Minio a -> Minio a
retryAPIRequest forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
Request -> Manager -> m (Response LByteString)
httpLbs Request
req Manager
mgr

mkStreamRequest ::
  S3ReqInfo ->
  Minio (Response (C.ConduitM () ByteString Minio ()))
mkStreamRequest :: S3ReqInfo -> Minio (Response (ConduitM () ByteString Minio ()))
mkStreamRequest S3ReqInfo
ri = do
  Request
req <- S3ReqInfo -> Minio Request
buildRequest S3ReqInfo
ri
  Manager
mgr <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MinioConn -> Manager
mcConnManager
  forall a. Minio a -> Minio a
retryAPIRequest forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadUnliftIO m, MonadResource m) =>
Request -> Manager -> m (Response (ConduitT () ByteString m ()))
http Request
req Manager
mgr

-- Bucket name validity check according to AWS rules.
isValidBucketName :: Bucket -> Bool
isValidBucketName :: Object -> Bool
isValidBucketName Object
bucket =
  Bool -> Bool
not
    ( forall (t :: * -> *). Foldable t => t Bool -> Bool
or
        [ Int
len forall a. Ord a => a -> a -> Bool
< Int
3 Bool -> Bool -> Bool
|| Int
len forall a. Ord a => a -> a -> Bool
> Int
63,
          forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Object -> Bool
labelCheck [Object]
labels,
          forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Object -> Bool
labelCharsCheck [Object]
labels,
          Bool
isIPCheck
        ]
    )
  where
    len :: Int
len = Object -> Int
T.length Object
bucket
    labels :: [Object]
labels = Object -> Object -> [Object]
T.splitOn Object
"." Object
bucket
    -- does label `l` fail basic checks of length and start/end?
    labelCheck :: Object -> Bool
labelCheck Object
l = Object -> Int
T.length Object
l forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
|| Object -> Char
T.head Object
l forall a. Eq a => a -> a -> Bool
== Char
'-' Bool -> Bool -> Bool
|| Object -> Char
T.last Object
l forall a. Eq a => a -> a -> Bool
== Char
'-'
    -- does label `l` have non-allowed characters?
    labelCharsCheck :: Object -> Bool
labelCharsCheck Object
l =
      forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$
        (Char -> Bool) -> Object -> Maybe Char
T.find
          ( \Char
x ->
              Bool -> Bool
not
                ( Char -> Bool
C.isAsciiLower Char
x
                    Bool -> Bool -> Bool
|| Char
x forall a. Eq a => a -> a -> Bool
== Char
'-'
                    Bool -> Bool -> Bool
|| Char -> Bool
C.isDigit Char
x
                )
          )
          Object
l
    -- does label `l` have non-digit characters?
    labelNonDigits :: Object -> Bool
labelNonDigits Object
l = forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Object -> Maybe Char
T.find (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
C.isDigit) Object
l
    labelAsNums :: [Bool]
labelAsNums = forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> Bool
labelNonDigits) [Object]
labels
    -- check if bucket name looks like an IP
    isIPCheck :: Bool
isIPCheck = forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
labelAsNums Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Int
length [Bool]
labelAsNums forall a. Eq a => a -> a -> Bool
== Int
4

-- Throws exception iff bucket name is invalid according to AWS rules.
checkBucketNameValidity :: (MonadIO m) => Bucket -> m ()
checkBucketNameValidity :: forall (m :: * -> *). MonadIO m => Object -> m ()
checkBucketNameValidity Object
bucket =
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Object -> Bool
isValidBucketName Object
bucket) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$
      Object -> MErrV
MErrVInvalidBucketName Object
bucket

isValidObjectName :: Object -> Bool
isValidObjectName :: Object -> Bool
isValidObjectName Object
object =
  Object -> Int
T.length Object
object forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& ByteString -> Int
B.length (forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Object
object) forall a. Ord a => a -> a -> Bool
<= Int
1024

checkObjectNameValidity :: (MonadIO m) => Object -> m ()
checkObjectNameValidity :: forall (m :: * -> *). MonadIO m => Object -> m ()
checkObjectNameValidity Object
object =
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Object -> Bool
isValidObjectName Object
object) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$
      Object -> MErrV
MErrVInvalidObjectName Object
object