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

module Network.Minio.API
  ( connect,
    S3ReqInfo (..),
    runMinio,
    executeRequest,
    buildRequest,
    mkStreamRequest,
    getLocation,
    isValidBucketName,
    checkBucketNameValidity,
    isValidObjectName,
    checkObjectNameValidity,
  )
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 qualified Network.HTTP.Client as NClient
import Network.HTTP.Conduit (Response)
import qualified Network.HTTP.Conduit as NC
import qualified Network.HTTP.Types as HT
import Network.HTTP.Types.Header (hHost)
import Network.Minio.APICommon
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 :: Bucket -> Minio Bucket
getLocation Bucket
bucket = do
  Response LByteString
resp <-
    S3ReqInfo -> Minio (Response LByteString)
executeRequest (S3ReqInfo -> Minio (Response LByteString))
-> S3ReqInfo -> Minio (Response LByteString)
forall a b. (a -> b) -> a -> b
$
      S3ReqInfo
defaultS3ReqInfo
        { riBucket :: Maybe Bucket
riBucket = Bucket -> Maybe Bucket
forall a. a -> Maybe a
Just Bucket
bucket,
          riQueryParams :: Query
riQueryParams = [(ByteString
"location", Maybe ByteString
forall a. Maybe a
Nothing)],
          riNeedsLocation :: Bool
riNeedsLocation = Bool
False
        }
  LByteString -> Minio Bucket
forall (m :: * -> *). MonadIO m => LByteString -> m Bucket
parseLocation (LByteString -> Minio Bucket) -> LByteString -> Minio Bucket
forall a b. (a -> b) -> a -> b
$ Response LByteString -> LByteString
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 Bucket)
discoverRegion S3ReqInfo
ri = MaybeT Minio Bucket -> Minio (Maybe Bucket)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT Minio Bucket -> Minio (Maybe Bucket))
-> MaybeT Minio Bucket -> Minio (Maybe Bucket)
forall a b. (a -> b) -> a -> b
$ do
  Bucket
bucket <- Minio (Maybe Bucket) -> MaybeT Minio Bucket
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Minio (Maybe Bucket) -> MaybeT Minio Bucket)
-> Minio (Maybe Bucket) -> MaybeT Minio Bucket
forall a b. (a -> b) -> a -> b
$ Maybe Bucket -> Minio (Maybe Bucket)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Bucket -> Minio (Maybe Bucket))
-> Maybe Bucket -> Minio (Maybe Bucket)
forall a b. (a -> b) -> a -> b
$ S3ReqInfo -> Maybe Bucket
riBucket S3ReqInfo
ri
  Maybe Bucket
regionMay <- Minio (Maybe Bucket) -> MaybeT Minio (Maybe Bucket)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Minio (Maybe Bucket) -> MaybeT Minio (Maybe Bucket))
-> Minio (Maybe Bucket) -> MaybeT Minio (Maybe Bucket)
forall a b. (a -> b) -> a -> b
$ Bucket -> Minio (Maybe Bucket)
lookupRegionCache Bucket
bucket
  MaybeT Minio Bucket
-> (Bucket -> MaybeT Minio Bucket)
-> Maybe Bucket
-> MaybeT Minio Bucket
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
    ( do
        Bucket
l <- Minio Bucket -> MaybeT Minio Bucket
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Minio Bucket -> MaybeT Minio Bucket)
-> Minio Bucket -> MaybeT Minio Bucket
forall a b. (a -> b) -> a -> b
$ Bucket -> Minio Bucket
getLocation Bucket
bucket
        Minio () -> MaybeT Minio ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Minio () -> MaybeT Minio ()) -> Minio () -> MaybeT Minio ()
forall a b. (a -> b) -> a -> b
$ Bucket -> Bucket -> Minio ()
addToRegionCache Bucket
bucket Bucket
l
        Bucket -> MaybeT Minio Bucket
forall (m :: * -> *) a. Monad m => a -> m a
return Bucket
l
    )
    Bucket -> MaybeT Minio Bucket
forall (m :: * -> *) a. Monad m => a -> m a
return
    Maybe Bucket
regionMay

-- | Returns the region to be used for the request.
getRegion :: S3ReqInfo -> Minio (Maybe Region)
getRegion :: S3ReqInfo -> Minio (Maybe Bucket)
getRegion S3ReqInfo
ri = do
  ConnectInfo
ci <- (MinioConn -> ConnectInfo) -> Minio ConnectInfo
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 (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ S3ReqInfo -> Bool
riNeedsLocation S3ReqInfo
ri ->
          Maybe Bucket -> Minio (Maybe Bucket)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Bucket -> Minio (Maybe Bucket))
-> Maybe Bucket -> Minio (Maybe Bucket)
forall a b. (a -> b) -> a -> b
$ Bucket -> Maybe Bucket
forall a. a -> Maybe a
Just (Bucket -> Maybe Bucket) -> Bucket -> Maybe Bucket
forall a b. (a -> b) -> a -> b
$ ConnectInfo -> Bucket
connectRegion ConnectInfo
ci
      -- if autodiscovery of location is disabled by user
      | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ConnectInfo -> Bool
connectAutoDiscoverRegion ConnectInfo
ci ->
          Maybe Bucket -> Minio (Maybe Bucket)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Bucket -> Minio (Maybe Bucket))
-> Maybe Bucket -> Minio (Maybe Bucket)
forall a b. (a -> b) -> a -> b
$ Bucket -> Maybe Bucket
forall a. a -> Maybe a
Just (Bucket -> Maybe Bucket) -> Bucket -> Maybe Bucket
forall a b. (a -> b) -> a -> b
$ ConnectInfo -> Bucket
connectRegion ConnectInfo
ci
      -- discover the region for the request
      | Bool
otherwise -> S3ReqInfo -> Minio (Maybe Bucket)
discoverRegion S3ReqInfo
ri

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

  if Bucket
"amazonaws.com" Bucket -> Bucket -> Bool
`T.isSuffixOf` ConnectInfo -> Bucket
connectHost ConnectInfo
ci
    then
      Minio Bucket
-> (Bucket -> Minio Bucket) -> Maybe Bucket -> Minio Bucket
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        (MErrV -> Minio Bucket
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (MErrV -> Minio Bucket) -> MErrV -> Minio Bucket
forall a b. (a -> b) -> a -> b
$ Bucket -> MErrV
MErrVRegionNotSupported Bucket
r)
        Bucket -> Minio Bucket
forall (m :: * -> *) a. Monad m => a -> m a
return
        (Bucket -> HashMap Bucket Bucket -> Maybe Bucket
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup Bucket
r HashMap Bucket Bucket
awsRegionMap)
    else Bucket -> Minio Bucket
forall (m :: * -> *) a. Monad m => a -> m a
return (Bucket -> Minio Bucket) -> Bucket -> Minio Bucket
forall a b. (a -> b) -> a -> b
$ ConnectInfo -> Bucket
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 (Bucket, ByteString, Maybe Bucket)
getHostPathRegion S3ReqInfo
ri = do
  ConnectInfo
ci <- (MinioConn -> ConnectInfo) -> Minio ConnectInfo
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MinioConn -> ConnectInfo
mcConnInfo
  Maybe Bucket
regionMay <- S3ReqInfo -> Minio (Maybe Bucket)
getRegion S3ReqInfo
ri
  case S3ReqInfo -> Maybe Bucket
riBucket S3ReqInfo
ri of
    Maybe Bucket
Nothing ->
      -- Implies a ListBuckets request.
      (Bucket, ByteString, Maybe Bucket)
-> Minio (Bucket, ByteString, Maybe Bucket)
forall (m :: * -> *) a. Monad m => a -> m a
return (ConnectInfo -> Bucket
connectHost ConnectInfo
ci, ByteString
"/", Maybe Bucket
regionMay)
    Just Bucket
bucket -> do
      Bucket
regionHost <- case Maybe Bucket
regionMay of
        Maybe Bucket
Nothing -> Bucket -> Minio Bucket
forall (m :: * -> *) a. Monad m => a -> m a
return (Bucket -> Minio Bucket) -> Bucket -> Minio Bucket
forall a b. (a -> b) -> a -> b
$ ConnectInfo -> Bucket
connectHost ConnectInfo
ci
        Just Bucket
"" -> Bucket -> Minio Bucket
forall (m :: * -> *) a. Monad m => a -> m a
return (Bucket -> Minio Bucket) -> Bucket -> Minio Bucket
forall a b. (a -> b) -> a -> b
$ ConnectInfo -> Bucket
connectHost ConnectInfo
ci
        Just Bucket
r -> Bucket -> Minio Bucket
getRegionHost Bucket
r
      let pathStyle :: (Bucket, ByteString, Maybe Bucket)
pathStyle =
            ( Bucket
regionHost,
              Maybe Bucket -> Maybe Bucket -> ByteString
getS3Path (S3ReqInfo -> Maybe Bucket
riBucket S3ReqInfo
ri) (S3ReqInfo -> Maybe Bucket
riObject S3ReqInfo
ri),
              Maybe Bucket
regionMay
            )
          virtualStyle :: (Bucket, ByteString, Maybe Bucket)
virtualStyle =
            ( Bucket
bucket Bucket -> Bucket -> Bucket
forall a. Semigroup a => a -> a -> a
<> Bucket
"." Bucket -> Bucket -> Bucket
forall a. Semigroup a => a -> a -> a
<> Bucket
regionHost,
              Bucket -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 (Bucket -> ByteString) -> Bucket -> ByteString
forall a b. (a -> b) -> a -> b
$ Bucket
"/" Bucket -> Bucket -> Bucket
forall a. Semigroup a => a -> a -> a
<> Bucket -> Maybe Bucket -> Bucket
forall a. a -> Maybe a -> a
fromMaybe Bucket
"" (S3ReqInfo -> Maybe Bucket
riObject S3ReqInfo
ri),
              Maybe Bucket
regionMay
            )
      ( if ConnectInfo -> Bool
isAWSConnectInfo ConnectInfo
ci
          then
            (Bucket, ByteString, Maybe Bucket)
-> Minio (Bucket, ByteString, Maybe Bucket)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bucket, ByteString, Maybe Bucket)
 -> Minio (Bucket, ByteString, Maybe Bucket))
-> (Bucket, ByteString, Maybe Bucket)
-> Minio (Bucket, ByteString, Maybe Bucket)
forall a b. (a -> b) -> a -> b
$
              if Bucket -> Bool
bucketHasPeriods Bucket
bucket
                then (Bucket, ByteString, Maybe Bucket)
pathStyle
                else (Bucket, ByteString, Maybe Bucket)
virtualStyle
          else (Bucket, ByteString, Maybe Bucket)
-> Minio (Bucket, ByteString, Maybe Bucket)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bucket, ByteString, Maybe Bucket)
pathStyle
        )

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

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

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

  let ci' :: ConnectInfo
ci' = ConnectInfo
ci {connectHost :: Bucket
connectHost = Bucket
host}
      hostHeader :: (HeaderName, ByteString)
hostHeader = (HeaderName
hHost, ConnectInfo -> ByteString
getHostAddr ConnectInfo
ci')
      ri' :: S3ReqInfo
ri' =
        S3ReqInfo
ri
          { riHeaders :: [(HeaderName, ByteString)]
riHeaders = (HeaderName, ByteString)
hostHeader (HeaderName, ByteString)
-> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
forall a. a -> [a] -> [a]
: S3ReqInfo -> [(HeaderName, ByteString)]
riHeaders S3ReqInfo
ri,
            riRegion :: Maybe Bucket
riRegion = Maybe Bucket
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 = Bucket -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 (Bucket -> ByteString) -> Bucket -> ByteString
forall a b. (a -> b) -> a -> b
$ ConnectInfo -> Bucket
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 (Query -> ByteString) -> Query -> ByteString
forall a b. (a -> b) -> a -> b
$ S3ReqInfo -> Query
riQueryParams S3ReqInfo
ri'
          }

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

  let sp :: SignParams
sp =
        Bucket
-> Bucket
-> UTCTime
-> Maybe Bucket
-> Maybe Int
-> Maybe ByteString
-> SignParams
SignParams
          (ConnectInfo -> Bucket
connectAccessKey ConnectInfo
ci')
          (ConnectInfo -> Bucket
connectSecretKey ConnectInfo
ci')
          UTCTime
timeStamp
          (S3ReqInfo -> Maybe Bucket
riRegion S3ReqInfo
ri')
          (S3ReqInfo -> Maybe Int
riPresignExpirySecs S3ReqInfo
ri')
          Maybe ByteString
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
      | Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust (S3ReqInfo -> Maybe Int
riPresignExpirySecs S3ReqInfo
ri') ->
          -- case 0 from above.
          do
            let signPairs :: [(ByteString, ByteString)]
signPairs = SignParams -> Request -> [(ByteString, ByteString)]
signV4 SignParams
sp Request
baseRequest
                qpToAdd :: Query
qpToAdd = (((ByteString, ByteString) -> (ByteString, Maybe ByteString))
-> [(ByteString, ByteString)] -> Query
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((ByteString, ByteString) -> (ByteString, Maybe ByteString))
 -> [(ByteString, ByteString)] -> Query)
-> ((ByteString -> Maybe ByteString)
    -> (ByteString, ByteString) -> (ByteString, Maybe ByteString))
-> (ByteString -> Maybe ByteString)
-> [(ByteString, ByteString)]
-> Query
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Maybe ByteString)
-> (ByteString, ByteString) -> (ByteString, Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just [(ByteString, ByteString)]
signPairs
                existingQueryParams :: Query
existingQueryParams = ByteString -> Query
HT.parseQuery (Request -> ByteString
NC.queryString Request
baseRequest)
                updatedQueryParams :: Query
updatedQueryParams = Query
existingQueryParams Query -> Query -> Query
forall a. [a] -> [a] -> [a]
++ Query
qpToAdd
            Request -> Minio Request
forall (m :: * -> *) a. Monad m => a -> m a
return (Request -> Minio Request) -> Request -> Minio Request
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 -> (Int64, ConduitT () ByteString (ResourceT IO) ())
-> Minio (Int64, ConduitT () ByteString (ResourceT IO) ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Int64
l, ConduitT () ByteString (ResourceT IO) ()
src)
              Payload
_ -> MErrV -> Minio (Int64, ConduitT () ByteString (ResourceT IO) ())
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
            Request -> Minio Request
forall (m :: * -> *) a. Monad m => a -> m a
return (Request -> Minio Request) -> Request -> Minio Request
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.
                    SignParams -> Minio SignParams
forall (m :: * -> *) a. Monad m => a -> m a
return SignParams
sp
                  else
                    ( -- case 3 described above.
                      do
                        ByteString
pHash <- Payload -> Minio ByteString
getPayloadSHA256Hash (Payload -> Minio ByteString) -> Payload -> Minio ByteString
forall a b. (a -> b) -> a -> b
$ S3ReqInfo -> Payload
riPayload S3ReqInfo
ri'
                        SignParams -> Minio SignParams
forall (m :: * -> *) a. Monad m => a -> m a
return (SignParams -> Minio SignParams) -> SignParams -> Minio SignParams
forall a b. (a -> b) -> a -> b
$ SignParams
sp {spPayloadHash :: Maybe ByteString
spPayloadHash = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
pHash}
                    )
                )

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

retryAPIRequest :: Minio a -> Minio a
retryAPIRequest :: Minio a -> Minio a
retryAPIRequest Minio a
apiCall = do
  Either HttpException a
resE <-
    RetryPolicyM Minio
-> (RetryStatus -> Either HttpException a -> Minio Bool)
-> (RetryStatus -> Minio (Either HttpException a))
-> Minio (Either HttpException a)
forall (m :: * -> *) b.
MonadIO m =>
RetryPolicyM m
-> (RetryStatus -> b -> m Bool) -> (RetryStatus -> m b) -> m b
retrying RetryPolicyM Minio
retryPolicy ((Either HttpException a -> Minio Bool)
-> RetryStatus -> Either HttpException a -> Minio Bool
forall a b. a -> b -> a
const Either HttpException a -> Minio Bool
forall a. Either HttpException a -> Minio Bool
shouldRetry) ((RetryStatus -> Minio (Either HttpException a))
 -> Minio (Either HttpException a))
-> (RetryStatus -> Minio (Either HttpException a))
-> Minio (Either HttpException a)
forall a b. (a -> b) -> a -> b
$
      Minio (Either HttpException a)
-> RetryStatus -> Minio (Either HttpException a)
forall a b. a -> b -> a
const (Minio (Either HttpException a)
 -> RetryStatus -> Minio (Either HttpException a))
-> Minio (Either HttpException a)
-> RetryStatus
-> Minio (Either HttpException a)
forall a b. (a -> b) -> a -> b
$
        Minio a -> Minio (Either HttpException a)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try Minio a
apiCall
  (HttpException -> Minio a)
-> (a -> Minio a) -> Either HttpException a -> Minio a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either HttpException -> Minio a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO a -> Minio a
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 =
      Int -> RetryPolicyM Minio -> RetryPolicyM Minio
forall (m :: * -> *).
Monad m =>
Int -> RetryPolicyM m -> RetryPolicyM m
limitRetriesByCumulativeDelay Int
tenMins (RetryPolicyM Minio -> RetryPolicyM Minio)
-> RetryPolicyM Minio -> RetryPolicyM Minio
forall a b. (a -> b) -> a -> b
$
        Int -> RetryPolicyM Minio
forall (m :: * -> *). MonadIO m => Int -> RetryPolicyM m
fullJitterBackoff Int
oneMilliSecond
    oneMilliSecond :: Int
oneMilliSecond = Int
1000 -- in microseconds
    tenMins :: Int
tenMins = Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
60 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000000 -- in microseconds
    -- retry on connection related failure
    shouldRetry :: Either NC.HttpException a -> Minio Bool
    shouldRetry :: Either HttpException a -> Minio Bool
shouldRetry Either HttpException a
resE =
      case Either HttpException a
resE of
        -- API request returned successfully
        Right a
_ -> Bool -> Minio Bool
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 -> Bool -> Minio Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
            HttpExceptionContent
NC.ConnectionTimeout -> Bool -> Minio Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
            NC.ConnectionFailure SomeException
_ -> Bool -> Minio Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
            -- We received an unexpected exception
            HttpExceptionContent
_ -> HttpException -> Minio Bool
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO HttpException
httpExn
        -- We received an unexpected exception
        Left HttpException
someOtherExn -> HttpException -> Minio Bool
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 <- (MinioConn -> Manager) -> Minio Manager
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MinioConn -> Manager
mcConnManager
  Minio (Response LByteString) -> Minio (Response LByteString)
forall a. Minio a -> Minio a
retryAPIRequest (Minio (Response LByteString) -> Minio (Response LByteString))
-> Minio (Response LByteString) -> Minio (Response LByteString)
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> Minio (Response LByteString)
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 <- (MinioConn -> Manager) -> Minio Manager
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MinioConn -> Manager
mcConnManager
  Minio (Response (ConduitM () ByteString Minio ()))
-> Minio (Response (ConduitM () ByteString Minio ()))
forall a. Minio a -> Minio a
retryAPIRequest (Minio (Response (ConduitM () ByteString Minio ()))
 -> Minio (Response (ConduitM () ByteString Minio ())))
-> Minio (Response (ConduitM () ByteString Minio ()))
-> Minio (Response (ConduitM () ByteString Minio ()))
forall a b. (a -> b) -> a -> b
$ Request
-> Manager -> Minio (Response (ConduitM () ByteString Minio ()))
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 :: Bucket -> Bool
isValidBucketName Bucket
bucket =
  Bool -> Bool
not
    ( [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or
        [ Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
3 Bool -> Bool -> Bool
|| Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
63,
          (Bucket -> Bool) -> [Bucket] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Bucket -> Bool
labelCheck [Bucket]
labels,
          (Bucket -> Bool) -> [Bucket] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Bucket -> Bool
labelCharsCheck [Bucket]
labels,
          Bool
isIPCheck
        ]
    )
  where
    len :: Int
len = Bucket -> Int
T.length Bucket
bucket
    labels :: [Bucket]
labels = Bucket -> Bucket -> [Bucket]
T.splitOn Bucket
"." Bucket
bucket
    -- does label `l` fail basic checks of length and start/end?
    labelCheck :: Bucket -> Bool
labelCheck Bucket
l = Bucket -> Int
T.length Bucket
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
|| Bucket -> Char
T.head Bucket
l Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-' Bool -> Bool -> Bool
|| Bucket -> Char
T.last Bucket
l Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-'
    -- does label `l` have non-allowed characters?
    labelCharsCheck :: Bucket -> Bool
labelCharsCheck Bucket
l =
      Maybe Char -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Char -> Bool) -> Maybe Char -> Bool
forall a b. (a -> b) -> a -> b
$
        (Char -> Bool) -> Bucket -> Maybe Char
T.find
          ( \Char
x ->
              Bool -> Bool
not
                ( Char -> Bool
C.isAsciiLower Char
x
                    Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-'
                    Bool -> Bool -> Bool
|| Char -> Bool
C.isDigit Char
x
                )
          )
          Bucket
l
    -- does label `l` have non-digit characters?
    labelNonDigits :: Bucket -> Bool
labelNonDigits Bucket
l = Maybe Char -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Char -> Bool) -> Maybe Char -> Bool
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Bucket -> Maybe Char
T.find (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
C.isDigit) Bucket
l
    labelAsNums :: [Bool]
labelAsNums = (Bucket -> Bool) -> [Bucket] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Bool
not (Bool -> Bool) -> (Bucket -> Bool) -> Bucket -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bucket -> Bool
labelNonDigits) [Bucket]
labels
    -- check if bucket name looks like an IP
    isIPCheck :: Bool
isIPCheck = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
labelAsNums Bool -> Bool -> Bool
&& [Bool] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Bool]
labelAsNums Int -> Int -> Bool
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 :: Bucket -> m ()
checkBucketNameValidity Bucket
bucket =
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bucket -> Bool
isValidBucketName Bucket
bucket) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    MErrV -> m ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (MErrV -> m ()) -> MErrV -> m ()
forall a b. (a -> b) -> a -> b
$
      Bucket -> MErrV
MErrVInvalidBucketName Bucket
bucket

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

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