Update formatting with latest ormolu 1.4 (#163)
This commit is contained in:
Aditya Manthramurthy
GitHub
parent
73bc5b64a0
commit
b8cc1e57ee
@ -34,9 +34,9 @@ main = do
|
||||
-- Performs a recursive listing of incomplete uploads under bucket "test"
|
||||
-- on a local minio server.
|
||||
res <-
|
||||
runMinio minioPlayCI
|
||||
$ runConduit
|
||||
$ listIncompleteUploads bucket Nothing True .| mapM_C (\v -> (liftIO $ print v))
|
||||
runMinio minioPlayCI $
|
||||
runConduit $
|
||||
listIncompleteUploads bucket Nothing True .| mapM_C (\v -> (liftIO $ print v))
|
||||
print res
|
||||
|
||||
{-
|
||||
|
||||
@ -34,9 +34,9 @@ main = do
|
||||
-- Performs a recursive listing of all objects under bucket "test"
|
||||
-- on play.min.io.
|
||||
res <-
|
||||
runMinio minioPlayCI
|
||||
$ runConduit
|
||||
$ listObjects bucket Nothing True .| mapM_C (\v -> (liftIO $ print v))
|
||||
runMinio minioPlayCI $
|
||||
runConduit $
|
||||
listObjects bucket Nothing True .| mapM_C (\v -> (liftIO $ print v))
|
||||
print res
|
||||
|
||||
{-
|
||||
|
||||
@ -73,8 +73,9 @@ main = do
|
||||
]
|
||||
formOptions = B.intercalate " " $ map formFn $ H.toList formData
|
||||
|
||||
return $ B.intercalate " " $
|
||||
["curl", formOptions, "-F file=@/tmp/photo.jpg", url]
|
||||
return $
|
||||
B.intercalate " " $
|
||||
["curl", formOptions, "-F file=@/tmp/photo.jpg", url]
|
||||
|
||||
case res of
|
||||
Left e -> putStrLn $ "post-policy error: " ++ (show e)
|
||||
|
||||
@ -55,6 +55,7 @@ module Network.Minio
|
||||
gcsCI,
|
||||
|
||||
-- * Minio Monad
|
||||
|
||||
----------------
|
||||
|
||||
-- | The Minio Monad provides connection-reuse, bucket-location
|
||||
|
||||
@ -186,9 +186,9 @@ buildRequest ri = do
|
||||
retryAPIRequest :: Minio a -> Minio a
|
||||
retryAPIRequest apiCall = do
|
||||
resE <-
|
||||
retrying retryPolicy (const shouldRetry)
|
||||
$ const
|
||||
$ try apiCall
|
||||
retrying retryPolicy (const shouldRetry) $
|
||||
const $
|
||||
try apiCall
|
||||
either throwIO return resE
|
||||
where
|
||||
-- Retry using the full-jitter backoff method for up to 10 mins
|
||||
@ -266,9 +266,9 @@ isValidBucketName bucket =
|
||||
-- Throws exception iff bucket name is invalid according to AWS rules.
|
||||
checkBucketNameValidity :: MonadIO m => Bucket -> m ()
|
||||
checkBucketNameValidity bucket =
|
||||
when (not $ isValidBucketName bucket)
|
||||
$ throwIO
|
||||
$ MErrVInvalidBucketName bucket
|
||||
when (not $ isValidBucketName bucket) $
|
||||
throwIO $
|
||||
MErrVInvalidBucketName bucket
|
||||
|
||||
isValidObjectName :: Object -> Bool
|
||||
isValidObjectName object =
|
||||
@ -276,6 +276,6 @@ isValidObjectName object =
|
||||
|
||||
checkObjectNameValidity :: MonadIO m => Object -> m ()
|
||||
checkObjectNameValidity object =
|
||||
when (not $ isValidObjectName object)
|
||||
$ throwIO
|
||||
$ MErrVInvalidObjectName object
|
||||
when (not $ isValidObjectName object) $
|
||||
throwIO $
|
||||
MErrVInvalidObjectName object
|
||||
|
||||
@ -16,7 +16,8 @@
|
||||
|
||||
module Network.Minio.AdminAPI
|
||||
( -- * MinIO Admin API
|
||||
--------------------
|
||||
|
||||
--------------------
|
||||
|
||||
-- | Provides MinIO admin API and related types. It is in
|
||||
-- experimental state.
|
||||
@ -52,10 +53,7 @@ module Network.Minio.AdminAPI
|
||||
where
|
||||
|
||||
import Data.Aeson
|
||||
( (.:),
|
||||
(.:?),
|
||||
(.=),
|
||||
FromJSON,
|
||||
( FromJSON,
|
||||
ToJSON,
|
||||
Value (Object),
|
||||
eitherDecode,
|
||||
@ -66,6 +64,9 @@ import Data.Aeson
|
||||
toJSON,
|
||||
withObject,
|
||||
withText,
|
||||
(.:),
|
||||
(.:?),
|
||||
(.=),
|
||||
)
|
||||
import qualified Data.Aeson as A
|
||||
import Data.Aeson.Types (typeMismatch)
|
||||
@ -610,9 +611,9 @@ buildAdminRequest areq = do
|
||||
areq
|
||||
{ ariPayloadHash = Just sha256Hash,
|
||||
ariHeaders =
|
||||
hostHeader
|
||||
: sha256Header sha256Hash
|
||||
: ariHeaders areq
|
||||
hostHeader :
|
||||
sha256Header sha256Hash :
|
||||
ariHeaders areq
|
||||
}
|
||||
signReq = toRequest ci newAreq
|
||||
sp =
|
||||
|
||||
@ -51,8 +51,8 @@ copyObjectInternal b' o srcInfo = do
|
||||
endOffset >= fromIntegral srcSize
|
||||
]
|
||||
)
|
||||
$ throwIO
|
||||
$ MErrVInvalidSrcObjByteRange range
|
||||
$ throwIO $
|
||||
MErrVInvalidSrcObjByteRange range
|
||||
|
||||
-- 1. If sz > 64MiB (minPartSize) use multipart copy, OR
|
||||
-- 2. If startOffset /= 0 use multipart copy
|
||||
@ -69,9 +69,9 @@ copyObjectInternal b' o srcInfo = do
|
||||
-- used is minPartSize.
|
||||
selectCopyRanges :: (Int64, Int64) -> [(PartNumber, (Int64, Int64))]
|
||||
selectCopyRanges (st, end) =
|
||||
zip pns
|
||||
$ map (\(x, y) -> (st + x, st + x + y - 1))
|
||||
$ zip startOffsets partSizes
|
||||
zip pns $
|
||||
map (\(x, y) -> (st + x, st + x + y - 1)) $
|
||||
zip startOffsets partSizes
|
||||
where
|
||||
size = end - st + 1
|
||||
(pns, startOffsets, partSizes) = List.unzip3 $ selectPartSizes size
|
||||
|
||||
@ -38,8 +38,10 @@ class UriEncodable s where
|
||||
|
||||
instance UriEncodable [Char] where
|
||||
uriEncode encodeSlash payload =
|
||||
LB.toStrict $ BB.toLazyByteString $ mconcat $
|
||||
map (`uriEncodeChar` encodeSlash) payload
|
||||
LB.toStrict $
|
||||
BB.toLazyByteString $
|
||||
mconcat $
|
||||
map (`uriEncodeChar` encodeSlash) payload
|
||||
|
||||
instance UriEncodable ByteString where
|
||||
-- assumes that uriEncode is passed ASCII encoded strings.
|
||||
|
||||
@ -20,11 +20,11 @@ module Network.Minio.JsonParser
|
||||
where
|
||||
|
||||
import Data.Aeson
|
||||
( (.:),
|
||||
FromJSON,
|
||||
( FromJSON,
|
||||
eitherDecode,
|
||||
parseJSON,
|
||||
withObject,
|
||||
(.:),
|
||||
)
|
||||
import qualified Data.Text as T
|
||||
import Lib.Prelude
|
||||
|
||||
@ -51,10 +51,10 @@ listObjects bucket prefix recurse = loop Nothing
|
||||
|
||||
res <- lift $ listObjects' bucket prefix nextToken delimiter Nothing
|
||||
CL.sourceList $ map ListItemObject $ lorObjects res
|
||||
unless recurse
|
||||
$ CL.sourceList
|
||||
$ map ListItemPrefix
|
||||
$ lorCPrefixes res
|
||||
unless recurse $
|
||||
CL.sourceList $
|
||||
map ListItemPrefix $
|
||||
lorCPrefixes res
|
||||
when (lorHasMore res) $
|
||||
loop (lorNextToken res)
|
||||
|
||||
@ -73,10 +73,10 @@ listObjectsV1 bucket prefix recurse = loop Nothing
|
||||
|
||||
res <- lift $ listObjectsV1' bucket prefix nextMarker delimiter Nothing
|
||||
CL.sourceList $ map ListItemObject $ lorObjects' res
|
||||
unless recurse
|
||||
$ CL.sourceList
|
||||
$ map ListItemPrefix
|
||||
$ lorCPrefixes' res
|
||||
unless recurse $
|
||||
CL.sourceList $
|
||||
map ListItemPrefix $
|
||||
lorCPrefixes' res
|
||||
when (lorHasMore' res) $
|
||||
loop (lorNextMarker res)
|
||||
|
||||
@ -104,19 +104,20 @@ listIncompleteUploads bucket prefix recurse = loop Nothing Nothing
|
||||
nextUploadIdMarker
|
||||
Nothing
|
||||
|
||||
aggrSizes <- lift $ forM (lurUploads res) $ \(uKey, uId, _) -> do
|
||||
partInfos <-
|
||||
C.runConduit $
|
||||
listIncompleteParts bucket uKey uId
|
||||
C..| CC.sinkList
|
||||
return $ foldl (\sizeSofar p -> opiSize p + sizeSofar) 0 partInfos
|
||||
aggrSizes <- lift $
|
||||
forM (lurUploads res) $ \(uKey, uId, _) -> do
|
||||
partInfos <-
|
||||
C.runConduit $
|
||||
listIncompleteParts bucket uKey uId
|
||||
C..| CC.sinkList
|
||||
return $ foldl (\sizeSofar p -> opiSize p + sizeSofar) 0 partInfos
|
||||
|
||||
CL.sourceList
|
||||
$ map
|
||||
CL.sourceList $
|
||||
map
|
||||
( \((uKey, uId, uInitTime), size) ->
|
||||
UploadInfo uKey uId uInitTime size
|
||||
)
|
||||
$ zip (lurUploads res) aggrSizes
|
||||
$ zip (lurUploads res) aggrSizes
|
||||
|
||||
when (lurHasMore res) $
|
||||
loop (lurNextKey res) (lurNextUpload res)
|
||||
|
||||
@ -68,9 +68,9 @@ makePresignedUrl ::
|
||||
HT.RequestHeaders ->
|
||||
Minio ByteString
|
||||
makePresignedUrl expiry method bucket object region extraQuery extraHeaders = do
|
||||
when (expiry > 7 * 24 * 3600 || expiry < 0)
|
||||
$ throwIO
|
||||
$ MErrVInvalidUrlExpiry expiry
|
||||
when (expiry > 7 * 24 * 3600 || expiry < 0) $
|
||||
throwIO $
|
||||
MErrVInvalidUrlExpiry expiry
|
||||
|
||||
ci <- asks mcConnInfo
|
||||
|
||||
@ -103,11 +103,13 @@ makePresignedUrl expiry method bucket object region extraQuery extraHeaders = do
|
||||
((HT.parseQuery $ NC.queryString req) ++ qpToAdd)
|
||||
scheme = byteString $ bool "http://" "https://" $ connectIsSecure ci
|
||||
|
||||
return $ toStrictBS $ toLazyByteString $
|
||||
scheme
|
||||
<> byteString (getHostAddr ci)
|
||||
<> byteString (getS3Path bucket object)
|
||||
<> queryStr
|
||||
return $
|
||||
toStrictBS $
|
||||
toLazyByteString $
|
||||
scheme
|
||||
<> byteString (getHostAddr ci)
|
||||
<> byteString (getS3Path bucket object)
|
||||
<> queryStr
|
||||
|
||||
-- | Generate a URL with authentication signature to PUT (upload) an
|
||||
-- object. Any extra headers if passed, are signed, and so they are
|
||||
@ -331,18 +333,21 @@ presignedPostPolicy p = do
|
||||
mkPair (PPCEquals k v) = Just (k, v)
|
||||
mkPair _ = Nothing
|
||||
formFromPolicy =
|
||||
H.map toUtf8 $ H.fromList $ catMaybes $
|
||||
mkPair <$> conditions ppWithCreds
|
||||
H.map toUtf8 $
|
||||
H.fromList $
|
||||
catMaybes $
|
||||
mkPair <$> conditions ppWithCreds
|
||||
formData = formFromPolicy `H.union` signData
|
||||
-- compute POST upload URL
|
||||
bucket = H.lookupDefault "" "bucket" formData
|
||||
scheme = byteString $ bool "http://" "https://" $ connectIsSecure ci
|
||||
region = connectRegion ci
|
||||
url =
|
||||
toStrictBS $ toLazyByteString $
|
||||
scheme <> byteString (getHostAddr ci)
|
||||
<> byteString "/"
|
||||
<> byteString bucket
|
||||
<> byteString "/"
|
||||
toStrictBS $
|
||||
toLazyByteString $
|
||||
scheme <> byteString (getHostAddr ci)
|
||||
<> byteString "/"
|
||||
<> byteString bucket
|
||||
<> byteString "/"
|
||||
|
||||
return (url, formData)
|
||||
|
||||
@ -19,10 +19,12 @@ module Network.Minio.S3API
|
||||
getLocation,
|
||||
|
||||
-- * Listing buckets
|
||||
|
||||
--------------------
|
||||
getService,
|
||||
|
||||
-- * Listing objects
|
||||
|
||||
--------------------
|
||||
ListObjectsResult (..),
|
||||
ListObjectsV1Result (..),
|
||||
@ -33,11 +35,13 @@ module Network.Minio.S3API
|
||||
headBucket,
|
||||
|
||||
-- * Retrieving objects
|
||||
|
||||
-----------------------
|
||||
getObject',
|
||||
headObject,
|
||||
|
||||
-- * Creating buckets and objects
|
||||
|
||||
---------------------------------
|
||||
putBucket,
|
||||
ETag,
|
||||
@ -47,6 +51,7 @@ module Network.Minio.S3API
|
||||
copyObjectSingle,
|
||||
|
||||
-- * Multipart Upload APIs
|
||||
|
||||
--------------------------
|
||||
UploadId,
|
||||
PartTuple,
|
||||
@ -63,11 +68,13 @@ module Network.Minio.S3API
|
||||
listIncompleteParts',
|
||||
|
||||
-- * Deletion APIs
|
||||
|
||||
--------------------------
|
||||
deleteBucket,
|
||||
deleteObject,
|
||||
|
||||
-- * Presigned Operations
|
||||
|
||||
-----------------------------
|
||||
module Network.Minio.PresignedOperations,
|
||||
|
||||
@ -76,6 +83,7 @@ module Network.Minio.S3API
|
||||
setBucketPolicy,
|
||||
|
||||
-- * Bucket Notifications
|
||||
|
||||
-------------------------
|
||||
Notification (..),
|
||||
NotificationConfig (..),
|
||||
@ -157,24 +165,26 @@ getObject' bucket object queryParams headers = do
|
||||
{ riBucket = Just bucket,
|
||||
riObject = Just object,
|
||||
riQueryParams = queryParams,
|
||||
riHeaders = headers
|
||||
-- This header is required for safety as otherwise http-client,
|
||||
-- sends Accept-Encoding: gzip, and the server may actually gzip
|
||||
-- body. In that case Content-Length header will be missing.
|
||||
<> [("Accept-Encoding", "identity")]
|
||||
riHeaders =
|
||||
headers
|
||||
-- This header is required for safety as otherwise http-client,
|
||||
-- sends Accept-Encoding: gzip, and the server may actually gzip
|
||||
-- body. In that case Content-Length header will be missing.
|
||||
<> [("Accept-Encoding", "identity")]
|
||||
}
|
||||
|
||||
-- | Creates a bucket via a PUT bucket call.
|
||||
putBucket :: Bucket -> Region -> Minio ()
|
||||
putBucket bucket location = do
|
||||
ns <- asks getSvcNamespace
|
||||
void $ executeRequest $
|
||||
defaultS3ReqInfo
|
||||
{ riMethod = HT.methodPut,
|
||||
riBucket = Just bucket,
|
||||
riPayload = PayloadBS $ mkCreateBucketConfig ns location,
|
||||
riNeedsLocation = False
|
||||
}
|
||||
void $
|
||||
executeRequest $
|
||||
defaultS3ReqInfo
|
||||
{ riMethod = HT.methodPut,
|
||||
riBucket = Just bucket,
|
||||
riPayload = PayloadBS $ mkCreateBucketConfig ns location,
|
||||
riNeedsLocation = False
|
||||
}
|
||||
|
||||
-- | Single PUT object size.
|
||||
maxSinglePutObjectSizeBytes :: Int64
|
||||
@ -188,9 +198,9 @@ putObjectSingle' :: Bucket -> Object -> [HT.Header] -> ByteString -> Minio ETag
|
||||
putObjectSingle' bucket object headers bs = do
|
||||
let size = fromIntegral (BS.length bs)
|
||||
-- check length is within single PUT object size.
|
||||
when (size > maxSinglePutObjectSizeBytes)
|
||||
$ throwIO
|
||||
$ MErrVSinglePUTSizeExceeded size
|
||||
when (size > maxSinglePutObjectSizeBytes) $
|
||||
throwIO $
|
||||
MErrVSinglePUTSizeExceeded size
|
||||
|
||||
let payload = mkStreamingPayload $ PayloadBS bs
|
||||
resp <-
|
||||
@ -222,9 +232,9 @@ putObjectSingle ::
|
||||
Minio ETag
|
||||
putObjectSingle bucket object headers h offset size = do
|
||||
-- check length is within single PUT object size.
|
||||
when (size > maxSinglePutObjectSizeBytes)
|
||||
$ throwIO
|
||||
$ MErrVSinglePUTSizeExceeded size
|
||||
when (size > maxSinglePutObjectSizeBytes) $
|
||||
throwIO $
|
||||
MErrVSinglePUTSizeExceeded size
|
||||
|
||||
-- content-length header is automatically set by library.
|
||||
let payload = mkStreamingPayload $ PayloadH h offset size
|
||||
@ -301,23 +311,23 @@ listObjects' bucket prefix nextToken delimiter maxKeys = do
|
||||
-- | DELETE a bucket from the service.
|
||||
deleteBucket :: Bucket -> Minio ()
|
||||
deleteBucket bucket =
|
||||
void
|
||||
$ executeRequest
|
||||
$ defaultS3ReqInfo
|
||||
{ riMethod = HT.methodDelete,
|
||||
riBucket = Just bucket
|
||||
}
|
||||
void $
|
||||
executeRequest $
|
||||
defaultS3ReqInfo
|
||||
{ riMethod = HT.methodDelete,
|
||||
riBucket = Just bucket
|
||||
}
|
||||
|
||||
-- | DELETE an object from the service.
|
||||
deleteObject :: Bucket -> Object -> Minio ()
|
||||
deleteObject bucket object =
|
||||
void
|
||||
$ executeRequest
|
||||
$ defaultS3ReqInfo
|
||||
{ riMethod = HT.methodDelete,
|
||||
riBucket = Just bucket,
|
||||
riObject = Just object
|
||||
}
|
||||
void $
|
||||
executeRequest $
|
||||
defaultS3ReqInfo
|
||||
{ riMethod = HT.methodDelete,
|
||||
riBucket = Just bucket,
|
||||
riObject = Just object
|
||||
}
|
||||
|
||||
-- | Create a new multipart upload.
|
||||
newMultipartUpload :: Bucket -> Object -> [HT.Header] -> Minio UploadId
|
||||
@ -377,8 +387,8 @@ srcInfoToHeaders srcInfo =
|
||||
"/",
|
||||
srcObject srcInfo
|
||||
]
|
||||
)
|
||||
: rangeHdr
|
||||
) :
|
||||
rangeHdr
|
||||
++ zip names values
|
||||
where
|
||||
names =
|
||||
@ -477,14 +487,14 @@ completeMultipartUpload bucket object uploadId partTuple = do
|
||||
-- | Abort a multipart upload.
|
||||
abortMultipartUpload :: Bucket -> Object -> UploadId -> Minio ()
|
||||
abortMultipartUpload bucket object uploadId =
|
||||
void
|
||||
$ executeRequest
|
||||
$ defaultS3ReqInfo
|
||||
{ riMethod = HT.methodDelete,
|
||||
riBucket = Just bucket,
|
||||
riObject = Just object,
|
||||
riQueryParams = mkOptionalParams params
|
||||
}
|
||||
void $
|
||||
executeRequest $
|
||||
defaultS3ReqInfo
|
||||
{ riMethod = HT.methodDelete,
|
||||
riBucket = Just bucket,
|
||||
riObject = Just object,
|
||||
riQueryParams = mkOptionalParams params
|
||||
}
|
||||
where
|
||||
params = [("uploadId", Just uploadId)]
|
||||
|
||||
@ -509,14 +519,14 @@ listIncompleteUploads' bucket prefix delimiter keyMarker uploadIdMarker maxKeys
|
||||
where
|
||||
-- build query params
|
||||
params =
|
||||
("uploads", Nothing)
|
||||
: mkOptionalParams
|
||||
[ ("prefix", prefix),
|
||||
("delimiter", delimiter),
|
||||
("key-marker", keyMarker),
|
||||
("upload-id-marker", uploadIdMarker),
|
||||
("max-uploads", show <$> maxKeys)
|
||||
]
|
||||
("uploads", Nothing) :
|
||||
mkOptionalParams
|
||||
[ ("prefix", prefix),
|
||||
("delimiter", delimiter),
|
||||
("key-marker", keyMarker),
|
||||
("upload-id-marker", uploadIdMarker),
|
||||
("max-uploads", show <$> maxKeys)
|
||||
]
|
||||
|
||||
-- | List parts of an ongoing multipart upload.
|
||||
listIncompleteParts' ::
|
||||
@ -553,15 +563,16 @@ headObject bucket object reqHeaders = do
|
||||
{ riMethod = HT.methodHead,
|
||||
riBucket = Just bucket,
|
||||
riObject = Just object,
|
||||
riHeaders = reqHeaders
|
||||
-- This header is required for safety as otherwise http-client,
|
||||
-- sends Accept-Encoding: gzip, and the server may actually gzip
|
||||
-- body. In that case Content-Length header will be missing.
|
||||
<> [("Accept-Encoding", "identity")]
|
||||
riHeaders =
|
||||
reqHeaders
|
||||
-- This header is required for safety as otherwise http-client,
|
||||
-- sends Accept-Encoding: gzip, and the server may actually gzip
|
||||
-- body. In that case Content-Length header will be missing.
|
||||
<> [("Accept-Encoding", "identity")]
|
||||
}
|
||||
maybe (throwIO MErrVInvalidObjectInfoResponse) return
|
||||
$ parseGetObjectHeaders object
|
||||
$ NC.responseHeaders resp
|
||||
maybe (throwIO MErrVInvalidObjectInfoResponse) return $
|
||||
parseGetObjectHeaders object $
|
||||
NC.responseHeaders resp
|
||||
|
||||
-- | Query the object store if a given bucket exists.
|
||||
headBucket :: Bucket -> Minio Bool
|
||||
@ -594,15 +605,16 @@ headBucket bucket =
|
||||
putBucketNotification :: Bucket -> Notification -> Minio ()
|
||||
putBucketNotification bucket ncfg = do
|
||||
ns <- asks getSvcNamespace
|
||||
void $ executeRequest $
|
||||
defaultS3ReqInfo
|
||||
{ riMethod = HT.methodPut,
|
||||
riBucket = Just bucket,
|
||||
riQueryParams = [("notification", Nothing)],
|
||||
riPayload =
|
||||
PayloadBS $
|
||||
mkPutNotificationRequest ns ncfg
|
||||
}
|
||||
void $
|
||||
executeRequest $
|
||||
defaultS3ReqInfo
|
||||
{ riMethod = HT.methodPut,
|
||||
riBucket = Just bucket,
|
||||
riQueryParams = [("notification", Nothing)],
|
||||
riPayload =
|
||||
PayloadBS $
|
||||
mkPutNotificationRequest ns ncfg
|
||||
}
|
||||
|
||||
-- | Retrieve the notification configuration on a bucket.
|
||||
getBucketNotification :: Bucket -> Minio Notification
|
||||
@ -644,20 +656,22 @@ setBucketPolicy bucket policy = do
|
||||
-- | Save a new policy on a bucket.
|
||||
putBucketPolicy :: Bucket -> Text -> Minio ()
|
||||
putBucketPolicy bucket policy = do
|
||||
void $ executeRequest $
|
||||
defaultS3ReqInfo
|
||||
{ riMethod = HT.methodPut,
|
||||
riBucket = Just bucket,
|
||||
riQueryParams = [("policy", Nothing)],
|
||||
riPayload = PayloadBS $ encodeUtf8 policy
|
||||
}
|
||||
void $
|
||||
executeRequest $
|
||||
defaultS3ReqInfo
|
||||
{ riMethod = HT.methodPut,
|
||||
riBucket = Just bucket,
|
||||
riQueryParams = [("policy", Nothing)],
|
||||
riPayload = PayloadBS $ encodeUtf8 policy
|
||||
}
|
||||
|
||||
-- | Delete any policy set on a bucket.
|
||||
deleteBucketPolicy :: Bucket -> Minio ()
|
||||
deleteBucketPolicy bucket = do
|
||||
void $ executeRequest $
|
||||
defaultS3ReqInfo
|
||||
{ riMethod = HT.methodDelete,
|
||||
riBucket = Just bucket,
|
||||
riQueryParams = [("policy", Nothing)]
|
||||
}
|
||||
void $
|
||||
executeRequest $
|
||||
defaultS3ReqInfo
|
||||
{ riMethod = HT.methodDelete,
|
||||
riBucket = Just bucket,
|
||||
riQueryParams = [("policy", Nothing)]
|
||||
}
|
||||
|
||||
@ -198,14 +198,14 @@ mkCanonicalRequest ::
|
||||
ByteString
|
||||
mkCanonicalRequest !isStreaming !sp !req !headersForSign =
|
||||
let canonicalQueryString =
|
||||
B.intercalate "&"
|
||||
$ map (\(x, y) -> B.concat [x, "=", y])
|
||||
$ sort
|
||||
$ map
|
||||
( \(x, y) ->
|
||||
(uriEncode True x, maybe "" (uriEncode True) y)
|
||||
)
|
||||
$ (parseQuery $ NC.queryString req)
|
||||
B.intercalate "&" $
|
||||
map (\(x, y) -> B.concat [x, "=", y]) $
|
||||
sort $
|
||||
map
|
||||
( \(x, y) ->
|
||||
(uriEncode True x, maybe "" (uriEncode True) y)
|
||||
)
|
||||
$ (parseQuery $ NC.queryString req)
|
||||
sortedHeaders = sort headersForSign
|
||||
canonicalHeaders =
|
||||
B.concat $
|
||||
@ -298,8 +298,8 @@ signV4Stream !payloadLength !sp !req =
|
||||
in case ceMay of
|
||||
Nothing -> ("content-encoding", "aws-chunked") : hs
|
||||
Just (_, ce) ->
|
||||
("content-encoding", ce <> ",aws-chunked")
|
||||
: filter (\(x, _) -> x /= "content-encoding") hs
|
||||
("content-encoding", ce <> ",aws-chunked") :
|
||||
filter (\(x, _) -> x /= "content-encoding") hs
|
||||
-- headers to be added to the request
|
||||
datePair = ("X-Amz-Date", awsTimeFormatBS ts)
|
||||
computedHeaders =
|
||||
|
||||
@ -170,8 +170,9 @@ httpLbs req mgr = do
|
||||
sErr <- parseErrResponseJSON $ NC.responseBody resp
|
||||
throwIO sErr
|
||||
_ ->
|
||||
throwIO $ NC.HttpExceptionRequest req $
|
||||
NC.StatusCodeException (void resp) (showBS resp)
|
||||
throwIO $
|
||||
NC.HttpExceptionRequest req $
|
||||
NC.StatusCodeException (void resp) (showBS resp)
|
||||
|
||||
return resp
|
||||
where
|
||||
@ -199,8 +200,9 @@ http req mgr = do
|
||||
throwIO sErr
|
||||
_ -> do
|
||||
content <- LB.toStrict . NC.responseBody <$> NC.lbsResponse resp
|
||||
throwIO $ NC.HttpExceptionRequest req $
|
||||
NC.StatusCodeException (void resp) content
|
||||
throwIO $
|
||||
NC.HttpExceptionRequest req $
|
||||
NC.StatusCodeException (void resp) content
|
||||
|
||||
return resp
|
||||
where
|
||||
@ -265,9 +267,9 @@ chunkBSConduit (s : ss) = do
|
||||
-- be 64MiB.
|
||||
selectPartSizes :: Int64 -> [(PartNumber, Int64, Int64)]
|
||||
selectPartSizes size =
|
||||
uncurry (List.zip3 [1 ..])
|
||||
$ List.unzip
|
||||
$ loop 0 size
|
||||
uncurry (List.zip3 [1 ..]) $
|
||||
List.unzip $
|
||||
loop 0 size
|
||||
where
|
||||
ceil :: Double -> Int64
|
||||
ceil = ceiling
|
||||
|
||||
@ -56,9 +56,9 @@ uncurry6 f (a, b, c, d, e, g) = f a b c d e g
|
||||
-- | Parse time strings from XML
|
||||
parseS3XMLTime :: MonadIO m => Text -> m UTCTime
|
||||
parseS3XMLTime t =
|
||||
maybe (throwIO $ MErrVXmlParse $ "timestamp parse failure: " <> t) return
|
||||
$ parseTimeM True defaultTimeLocale s3TimeFormat
|
||||
$ T.unpack t
|
||||
maybe (throwIO $ MErrVXmlParse $ "timestamp parse failure: " <> t) return $
|
||||
parseTimeM True defaultTimeLocale s3TimeFormat $
|
||||
T.unpack t
|
||||
|
||||
parseDecimal :: (MonadIO m, Integral a) => Text -> m a
|
||||
parseDecimal numStr =
|
||||
|
||||
@ -134,12 +134,12 @@ basicTests = funTestWithBucket "Basic tests" $
|
||||
\step bucket -> do
|
||||
step "getService works and contains the test bucket."
|
||||
buckets <- getService
|
||||
unless (length (filter (== bucket) $ map biName buckets) == 1)
|
||||
$ liftIO
|
||||
$ assertFailure
|
||||
( "The bucket " ++ show bucket
|
||||
++ " was expected to exist."
|
||||
)
|
||||
unless (length (filter (== bucket) $ map biName buckets) == 1) $
|
||||
liftIO $
|
||||
assertFailure
|
||||
( "The bucket " ++ show bucket
|
||||
++ " was expected to exist."
|
||||
)
|
||||
|
||||
step "makeBucket again to check if BucketAlreadyOwnedByYou exception is raised."
|
||||
mbE <- try $ makeBucket bucket Nothing
|
||||
@ -361,22 +361,24 @@ highLevelListingTest = funTestWithBucket "High-level listObjects Test" $
|
||||
|
||||
step "High-level listing of objects"
|
||||
items <- C.runConduit $ listObjects bucket Nothing False C..| sinkList
|
||||
liftIO $ assertEqual "Objects/Dirs match failed!" expectedNonRecList $
|
||||
extractObjectsAndDirsFromList items
|
||||
liftIO $
|
||||
assertEqual "Objects/Dirs match failed!" expectedNonRecList $
|
||||
extractObjectsAndDirsFromList items
|
||||
|
||||
step "High-level recursive listing of objects"
|
||||
objects <- C.runConduit $ listObjects bucket Nothing True C..| sinkList
|
||||
|
||||
liftIO
|
||||
$ assertEqual
|
||||
liftIO $
|
||||
assertEqual
|
||||
"Objects match failed!"
|
||||
(Just $ sort expectedObjects)
|
||||
$ extractObjectsFromList objects
|
||||
$ extractObjectsFromList objects
|
||||
|
||||
step "High-level listing of objects (version 1)"
|
||||
itemsV1 <- C.runConduit $ listObjectsV1 bucket Nothing False C..| sinkList
|
||||
liftIO $ assertEqual "Objects/Dirs match failed!" expectedNonRecList $
|
||||
extractObjectsAndDirsFromList itemsV1
|
||||
liftIO $
|
||||
assertEqual "Objects/Dirs match failed!" expectedNonRecList $
|
||||
extractObjectsAndDirsFromList itemsV1
|
||||
|
||||
step "High-level recursive listing of objects (version 1)"
|
||||
objectsV1 <-
|
||||
@ -384,45 +386,45 @@ highLevelListingTest = funTestWithBucket "High-level listObjects Test" $
|
||||
listObjectsV1 bucket Nothing True
|
||||
C..| sinkList
|
||||
|
||||
liftIO
|
||||
$ assertEqual
|
||||
liftIO $
|
||||
assertEqual
|
||||
"Objects match failed!"
|
||||
(Just $ sort expectedObjects)
|
||||
$ extractObjectsFromList objectsV1
|
||||
$ extractObjectsFromList objectsV1
|
||||
|
||||
let expectedPrefListing = ["dir/o1", "dir/dir1/", "dir/dir2/"]
|
||||
expectedPrefListingRec = Just ["dir/dir1/o2", "dir/dir2/o3", "dir/o1"]
|
||||
step "High-level listing with prefix"
|
||||
prefItems <- C.runConduit $ listObjects bucket (Just "dir/") False C..| sinkList
|
||||
liftIO
|
||||
$ assertEqual
|
||||
liftIO $
|
||||
assertEqual
|
||||
"Objects/Dirs under prefix match failed!"
|
||||
expectedPrefListing
|
||||
$ extractObjectsAndDirsFromList prefItems
|
||||
$ extractObjectsAndDirsFromList prefItems
|
||||
|
||||
step "High-level listing with prefix recursive"
|
||||
prefItemsRec <- C.runConduit $ listObjects bucket (Just "dir/") True C..| sinkList
|
||||
liftIO
|
||||
$ assertEqual
|
||||
liftIO $
|
||||
assertEqual
|
||||
"Objects/Dirs under prefix match recursive failed!"
|
||||
expectedPrefListingRec
|
||||
$ extractObjectsFromList prefItemsRec
|
||||
$ extractObjectsFromList prefItemsRec
|
||||
|
||||
step "High-level listing with prefix (version 1)"
|
||||
prefItemsV1 <- C.runConduit $ listObjectsV1 bucket (Just "dir/") False C..| sinkList
|
||||
liftIO
|
||||
$ assertEqual
|
||||
liftIO $
|
||||
assertEqual
|
||||
"Objects/Dirs under prefix match failed!"
|
||||
expectedPrefListing
|
||||
$ extractObjectsAndDirsFromList prefItemsV1
|
||||
$ extractObjectsAndDirsFromList prefItemsV1
|
||||
|
||||
step "High-level listing with prefix recursive (version 1)"
|
||||
prefItemsRecV1 <- C.runConduit $ listObjectsV1 bucket (Just "dir/") True C..| sinkList
|
||||
liftIO
|
||||
$ assertEqual
|
||||
liftIO $
|
||||
assertEqual
|
||||
"Objects/Dirs under prefix match recursive failed!"
|
||||
expectedPrefListingRec
|
||||
$ extractObjectsFromList prefItemsRecV1
|
||||
$ extractObjectsFromList prefItemsRecV1
|
||||
|
||||
step "Cleanup actions"
|
||||
forM_ expectedObjects $
|
||||
@ -910,8 +912,9 @@ putObjectUserMetadataTest = funTestWithBucket "putObject user-metadata test" $
|
||||
let m = oiUserMetadata oi
|
||||
-- need to do a case-insensitive comparison
|
||||
sortedMeta =
|
||||
sort $ map (\(k, v) -> (T.toLower k, T.toLower v)) $
|
||||
H.toList m
|
||||
sort $
|
||||
map (\(k, v) -> (T.toLower k, T.toLower v)) $
|
||||
H.toList m
|
||||
ref = sort [("mykey1", "myval1"), ("mykey2", "myval2")]
|
||||
|
||||
liftIO $ (sortedMeta == ref) @? "Metadata mismatch!"
|
||||
@ -944,8 +947,9 @@ getObjectTest = funTestWithBucket "getObject test" $
|
||||
let m = oiUserMetadata $ gorObjectInfo gor
|
||||
-- need to do a case-insensitive comparison
|
||||
sortedMeta =
|
||||
sort $ map (\(k, v) -> (T.toLower k, T.toLower v)) $
|
||||
H.toList m
|
||||
sort $
|
||||
map (\(k, v) -> (T.toLower k, T.toLower v)) $
|
||||
H.toList m
|
||||
ref = sort [("mykey1", "myval1"), ("mykey2", "myval2")]
|
||||
|
||||
liftIO $ (sortedMeta == ref) @? "Metadata mismatch!"
|
||||
|
||||
@ -63,8 +63,9 @@ parseServerInfoJSONTest =
|
||||
testGroup "Parse MinIO Admin API ServerInfo JSON test" $
|
||||
map
|
||||
( \(tName, tDesc, tfn, tVal) ->
|
||||
testCase tName $ assertBool tDesc $
|
||||
tfn (eitherDecode tVal :: Either [Char] [ServerInfo])
|
||||
testCase tName $
|
||||
assertBool tDesc $
|
||||
tfn (eitherDecode tVal :: Either [Char] [ServerInfo])
|
||||
)
|
||||
testCases
|
||||
where
|
||||
@ -82,8 +83,9 @@ parseHealStatusTest =
|
||||
testGroup "Parse MinIO Admin API HealStatus JSON test" $
|
||||
map
|
||||
( \(tName, tDesc, tfn, tVal) ->
|
||||
testCase tName $ assertBool tDesc $
|
||||
tfn (eitherDecode tVal :: Either [Char] HealStatus)
|
||||
testCase tName $
|
||||
assertBool tDesc $
|
||||
tfn (eitherDecode tVal :: Either [Char] HealStatus)
|
||||
)
|
||||
testCases
|
||||
where
|
||||
@ -101,8 +103,9 @@ parseHealStartRespTest =
|
||||
testGroup "Parse MinIO Admin API HealStartResp JSON test" $
|
||||
map
|
||||
( \(tName, tDesc, tfn, tVal) ->
|
||||
testCase tName $ assertBool tDesc $
|
||||
tfn (eitherDecode tVal :: Either [Char] HealStartResp)
|
||||
testCase tName $
|
||||
assertBool tDesc $
|
||||
tfn (eitherDecode tVal :: Either [Char] HealStartResp)
|
||||
)
|
||||
testCases
|
||||
where
|
||||
|
||||
@ -43,9 +43,9 @@ testParseErrResponseJSON :: Assertion
|
||||
testParseErrResponseJSON = do
|
||||
-- 1. Test parsing of an invalid error json.
|
||||
parseResE <- tryValidationErr $ parseErrResponseJSON "ClearlyInvalidJSON"
|
||||
when (isRight parseResE)
|
||||
$ assertFailure
|
||||
$ "Parsing should have failed => " ++ show parseResE
|
||||
when (isRight parseResE) $
|
||||
assertFailure $
|
||||
"Parsing should have failed => " ++ show parseResE
|
||||
|
||||
forM_ cases $ \(jsondata, sErr) -> do
|
||||
parseErr <- tryValidationErr $ parseErrResponseJSON jsondata
|
||||
|
||||
@ -62,9 +62,9 @@ testParseLocation :: Assertion
|
||||
testParseLocation = do
|
||||
-- 1. Test parsing of an invalid location constraint xml.
|
||||
parseResE <- tryValidationErr $ parseLocation "ClearlyInvalidXml"
|
||||
when (isRight parseResE)
|
||||
$ assertFailure
|
||||
$ "Parsing should have failed => " ++ show parseResE
|
||||
when (isRight parseResE) $
|
||||
assertFailure $
|
||||
"Parsing should have failed => " ++ show parseResE
|
||||
|
||||
forM_ cases $ \(xmldata, expectedLocation) -> do
|
||||
parseLocE <- tryValidationErr $ parseLocation xmldata
|
||||
@ -344,11 +344,12 @@ testParseNotification = do
|
||||
"1"
|
||||
"arn:aws:sqs:us-west-2:444455556666:s3notificationqueue"
|
||||
[ObjectCreatedPut]
|
||||
( Filter $ FilterKey $
|
||||
FilterRules
|
||||
[ FilterRule "prefix" "images/",
|
||||
FilterRule "suffix" ".jpg"
|
||||
]
|
||||
( Filter $
|
||||
FilterKey $
|
||||
FilterRules
|
||||
[ FilterRule "prefix" "images/",
|
||||
FilterRule "suffix" ".jpg"
|
||||
]
|
||||
),
|
||||
NotificationConfig
|
||||
""
|
||||
|
||||
Loading…
Reference in New Issue
Block a user