haskell/minio-hs
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Hlint fixes (#173)

Browse Source 
* Hlint fixes

- Will require major version bump as some types were changed from data
  to newtype

* ormolu fixes after hlint
This commit is contained in:
Aditya Manthramurthy 2022-05-27 14:33:05 -07:00 committed by GitHub
parent b91a7afd6b
commit d59f45fec4
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
28 changed files with 136 additions and 144 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
examples/FileUploader.hs
View File

@ -70,5 +70,5 @@ main = do
fPutObject bucket object filepath defaultPutObjectOptions
case res of
Left e -> putStrLn $ "file upload failed due to " ++ (show e)
Left e -> putStrLn $ "file upload failed due to " ++ show e
Right () -> putStrLn "file upload succeeded."

4
examples/GetConfig.hs
View File

@ -16,7 +16,6 @@
-- See the License for the specific language governing permissions and
-- limitations under the License.
--
{-# LANGUAGE OverloadedStrings #-}
import Network.Minio
import Network.Minio.AdminAPI
@ -25,6 +24,7 @@ import Prelude
main :: IO ()
main = do
res <-
runMinio minioPlayCI $
runMinio
minioPlayCI
getConfig
print res

2
examples/GetObject.hs
View File

@ -37,5 +37,5 @@ main = do
C.connect (gorObjectStream src) $ CB.sinkFileCautious "/tmp/my-object"
case res of
Left e -> putStrLn $ "getObject failed." ++ (show e)
Left e -> putStrLn $ "getObject failed." ++ show e
Right _ -> putStrLn "getObject succeeded."

1
examples/Heal.hs
View File

@ -16,7 +16,6 @@
-- See the License for the specific language governing permissions and
-- limitations under the License.
--
{-# LANGUAGE OverloadedStrings #-}
import Network.Minio
import Network.Minio.AdminAPI

2
examples/ListIncompleteUploads.hs
View File

@ -36,7 +36,7 @@ main = do
res <-
runMinio minioPlayCI $
runConduit $
listIncompleteUploads bucket Nothing True .| mapM_C (\v -> (liftIO $ print v))
listIncompleteUploads bucket Nothing True .| mapM_C (liftIO . print)
print res
{-

2
examples/ListObjects.hs
View File

@ -36,7 +36,7 @@ main = do
res <-
runMinio minioPlayCI $
runConduit $
listObjects bucket Nothing True .| mapM_C (\v -> (liftIO $ print v))
listObjects bucket Nothing True .| mapM_C (liftIO . print)
print res
{-

2
examples/PresignedGetObject.hs
View File

@ -46,7 +46,7 @@ main = do
res <- runMinio minioPlayCI $ do
liftIO $ B.putStrLn "Upload a file that we will fetch with a presigned URL..."
putObject bucket object (CC.repeat "a") (Just kb15) defaultPutObjectOptions
liftIO $ putStrLn $ "Done. Object created at: my-bucket/my-object"
liftIO $ putStrLn "Done. Object created at: my-bucket/my-object"
-- Extract Etag of uploaded object
oi <- statObject bucket object defaultGetObjectOptions

9
examples/PresignedPostPolicy.hs
View File

@ -55,7 +55,7 @@ main = do
]
case policyE of
Left err -> putStrLn $ show err
Left err -> print err
Right policy -> do
res <- runMinio minioPlayCI $ do
(url, formData) <- presignedPostPolicy policy
@ -74,13 +74,14 @@ main = do
formOptions = B.intercalate " " $ map formFn $ H.toList formData
return $
B.intercalate " " $
B.intercalate
" "
["curl", formOptions, "-F file=@/tmp/photo.jpg", url]
case res of
Left e -> putStrLn $ "post-policy error: " ++ (show e)
Left e -> putStrLn $ "post-policy error: " ++ show e
Right cmd -> do
putStrLn $ "Put a photo at /tmp/photo.jpg and run command:\n"
putStrLn "Put a photo at /tmp/photo.jpg and run command:\n"
-- print the generated curl command
Char8.putStrLn cmd

4
examples/SelectObject.hs
View File

@ -19,7 +19,7 @@
{-# LANGUAGE OverloadedStrings #-}
import qualified Conduit as C
import Control.Monad (when)
import Control.Monad (unless)
import Network.Minio
import Prelude
@ -35,7 +35,7 @@ main = do
res <- runMinio minioPlayCI $ do
exists <- bucketExists bucket
when (not exists) $
unless exists $
makeBucket bucket Nothing
C.liftIO $ putStrLn "Uploading csv object"

4
examples/ServerInfo.hs
View File

@ -16,7 +16,6 @@
-- See the License for the specific language governing permissions and
-- limitations under the License.
--
{-# LANGUAGE OverloadedStrings #-}
import Network.Minio
import Network.Minio.AdminAPI
@ -25,6 +24,7 @@ import Prelude
main :: IO ()
main = do
res <-
runMinio minioPlayCI $
runMinio
minioPlayCI
getServerInfo
print res

1
examples/ServiceSendRestart.hs
View File

@ -16,7 +16,6 @@
-- See the License for the specific language governing permissions and
-- limitations under the License.
--
{-# LANGUAGE OverloadedStrings #-}
import Network.Minio
import Network.Minio.AdminAPI

1
examples/ServiceSendStop.hs
View File

@ -16,7 +16,6 @@
-- See the License for the specific language governing permissions and
-- limitations under the License.
--
{-# LANGUAGE OverloadedStrings #-}
import Network.Minio
import Network.Minio.AdminAPI

4
examples/ServiceStatus.hs
View File

@ -16,7 +16,6 @@
-- See the License for the specific language governing permissions and
-- limitations under the License.
--
{-# LANGUAGE OverloadedStrings #-}
import Network.Minio
import Network.Minio.AdminAPI
@ -25,6 +24,7 @@ import Prelude
main :: IO ()
main = do
res <-
runMinio minioPlayCI $
runMinio
minioPlayCI
serviceStatus
print res

1
minio-hs.cabal
View File

@ -58,6 +58,7 @@ common base-settings
, DerivingStrategies
, FlexibleContexts
, FlexibleInstances
, LambdaCase
, MultiParamTypeClasses
, MultiWayIf
, OverloadedStrings

45
src/Network/Minio/API.hs
View File

@ -130,18 +130,18 @@ getHostPathRegion ri = do
regionMay
)
virtualStyle =
( ( bucket <> "." <> regionHost,
encodeUtf8 $ "/" <> fromMaybe "" (riObject ri),
regionMay
)
( bucket <> "." <> regionHost,
encodeUtf8 $ "/" <> fromMaybe "" (riObject ri),
regionMay
)
if
| isAWSConnectInfo ci ->
return $
if bucketHasPeriods bucket
then pathStyle
else virtualStyle
| otherwise -> return pathStyle
( if isAWSConnectInfo ci
then
return $
if bucketHasPeriods bucket
then pathStyle
else virtualStyle
else return pathStyle
)
buildRequest :: S3ReqInfo -> Minio NC.Request
buildRequest ri = do
@ -203,7 +203,7 @@ buildRequest ri = do
existingQueryParams = HT.parseQuery (NC.queryString baseRequest)
updatedQueryParams = existingQueryParams ++ qpToAdd
return $ NClient.setQueryString updatedQueryParams baseRequest
| isStreamingPayload (riPayload ri') && (not $ connectIsSecure ci') ->
| isStreamingPayload (riPayload ri') && not (connectIsSecure ci') ->
-- case 2 from above.
do
(pLen, pSrc) <- case riPayload ri of
@ -214,15 +214,16 @@ buildRequest ri = do
| otherwise ->
do
sp' <-
if
| connectIsSecure ci' ->
-- case 1 described above.
return sp
| otherwise ->
-- case 3 described above.
( if connectIsSecure ci'
then -- case 1 described above.
return sp
else
( -- case 3 described above.
do
pHash <- getPayloadSHA256Hash $ riPayload ri'
return $ sp {spPayloadHash = Just pHash}
)
)
let signHeaders = signV4 sp' baseRequest
return $
@ -285,8 +286,8 @@ isValidBucketName bucket =
not
( or
[ len < 3 || len > 63,
or (map labelCheck labels),
or (map labelCharsCheck labels),
any labelCheck labels,
any labelCharsCheck labels,
isIPCheck
]
)
@ -316,7 +317,7 @@ isValidBucketName bucket =
-- Throws exception iff bucket name is invalid according to AWS rules.
checkBucketNameValidity :: MonadIO m => Bucket -> m ()
checkBucketNameValidity bucket =
when (not $ isValidBucketName bucket) $
unless (isValidBucketName bucket) $
throwIO $
MErrVInvalidBucketName bucket
@ -326,6 +327,6 @@ isValidObjectName object =
checkObjectNameValidity :: MonadIO m => Object -> m ()
checkObjectNameValidity object =
when (not $ isValidObjectName object) $
unless (isValidObjectName object) $
throwIO $
MErrVInvalidObjectName object

13
src/Network/Minio/AdminAPI.hs
View File

@ -429,7 +429,7 @@ instance FromJSON HealStatus where
healPath :: Maybe Bucket -> Maybe Text -> ByteString
healPath bucket prefix = do
if (isJust bucket)
if isJust bucket
then
encodeUtf8 $
"v1/heal/"
@ -599,12 +599,11 @@ buildAdminRequest :: AdminReqInfo -> Minio NC.Request
buildAdminRequest areq = do
ci <- asks mcConnInfo
sha256Hash <-
if
| connectIsSecure ci ->
-- if secure connection
return "UNSIGNED-PAYLOAD"
-- otherwise compute sha256
| otherwise -> getPayloadSHA256Hash (ariPayload areq)
if connectIsSecure ci
then -- if secure connection
return "UNSIGNED-PAYLOAD"
else -- otherwise compute sha256
getPayloadSHA256Hash (ariPayload areq)
timeStamp <- liftIO getCurrentTime

49
src/Network/Minio/Data.hs
View File

@ -161,7 +161,7 @@ findFirst (f : fs) = do
fromAWSConfigFile :: Provider
fromAWSConfigFile = do
credsE <- runExceptT $ do
homeDir <- lift $ getHomeDirectory
homeDir <- lift getHomeDirectory
let awsCredsFile = homeDir `combine` ".aws" `combine` "credentials"
fileExists <- lift $ doesFileExist awsCredsFile
bool (throwE "FileNotFound") (return ()) fileExists
@ -201,7 +201,7 @@ setCredsFrom ps ci = do
pMay <- findFirst ps
maybe
(throwIO MErrVMissingCredentials)
(return . (flip setCreds ci))
(return . (`setCreds` ci))
pMay
-- | setCreds sets the given `Credentials` in the `ConnectInfo`.
@ -234,11 +234,11 @@ disableTLSCertValidation c = c {connectDisableTLSCertValidation = True}
getHostAddr :: ConnectInfo -> ByteString
getHostAddr ci =
if
| port == 80 || port == 443 -> encodeUtf8 host
| otherwise ->
encodeUtf8 $
T.concat [host, ":", show port]
if port == 80 || port == 443
then encodeUtf8 host
else
encodeUtf8 $
T.concat [host, ":", show port]
where
port = connectPort ci
host = connectHost ci
@ -382,12 +382,12 @@ addXAmzMetaPrefix s
| otherwise = "X-Amz-Meta-" <> s
mkHeaderFromMetadata :: [(Text, Text)] -> [HT.Header]
mkHeaderFromMetadata = map (\(x, y) -> (mk $ encodeUtf8 $ addXAmzMetaPrefix $ x, encodeUtf8 y))
mkHeaderFromMetadata = map (\(x, y) -> (mk $ encodeUtf8 $ addXAmzMetaPrefix x, encodeUtf8 y))
pooToHeaders :: PutObjectOptions -> [HT.Header]
pooToHeaders poo =
userMetadata
++ (catMaybes $ map tupToMaybe (zipWith (,) names values))
++ mapMaybe tupToMaybe (zip names values)
++ maybe [] toPutObjectHeaders (pooSSE poo)
where
tupToMaybe (k, Just v) = Just (k, v)
@ -658,7 +658,7 @@ textToEvent t = case t of
_ -> Nothing
-- | Filter data type - part of notification configuration
data Filter = Filter
newtype Filter = Filter
{ fFilter :: FilterKey
}
deriving stock (Show, Eq)
@ -669,7 +669,7 @@ defaultFilter :: Filter
defaultFilter = Filter defaultFilterKey
-- | FilterKey contains FilterRules, and is part of a Filter.
data FilterKey = FilterKey
newtype FilterKey = FilterKey
{ fkKey :: FilterRules
}
deriving stock (Show, Eq)
@ -680,7 +680,7 @@ defaultFilterKey :: FilterKey
defaultFilterKey = FilterKey defaultFilterRules
-- | FilterRules represents a collection of `FilterRule`s.
data FilterRules = FilterRules
newtype FilterRules = FilterRules
{ frFilterRules :: [FilterRule]
}
deriving stock (Show, Eq)
@ -856,21 +856,15 @@ type CSVInputProp = CSVProp
-- | CSVProp represents CSV format properties. It is built up using
-- the Monoid instance.
data CSVProp = CSVProp (H.HashMap Text Text)
newtype CSVProp = CSVProp (H.HashMap Text Text)
deriving stock (Show, Eq)
#if (__GLASGOW_HASKELL__ >= 804)
instance Semigroup CSVProp where
(CSVProp a) <> (CSVProp b) = CSVProp (b <> a)
#endif
(CSVProp a) <> (CSVProp b) = CSVProp (b <> a)
instance Monoid CSVProp where
mempty = CSVProp mempty
#if (__GLASGOW_HASKELL__ < 804)
mappend (CSVProp a) (CSVProp b) = CSVProp (b <> a)
#endif
csvPropsList :: CSVProp -> [(Text, Text)]
csvPropsList (CSVProp h) = sort $ H.toList h
@ -927,9 +921,9 @@ setInputCSVProps p is = is {isFormatInfo = InputFormatCSV p}
-- | Set the CSV format properties in the OutputSerialization.
outputCSVFromProps :: CSVProp -> OutputSerialization
outputCSVFromProps p = OutputSerializationCSV p
outputCSVFromProps = OutputSerializationCSV
data JSONInputProp = JSONInputProp {jsonipType :: JSONType}
newtype JSONInputProp = JSONInputProp {jsonipType :: JSONType}
deriving stock (Show, Eq)
data JSONType = JSONTypeDocument | JSONTypeLines
@ -957,7 +951,7 @@ quoteFields q = CSVProp $
data QuoteFields = QuoteFieldsAsNeeded | QuoteFieldsAlways
deriving stock (Show, Eq)
data JSONOutputProp = JSONOutputProp {jsonopRecordDelimiter :: Maybe Text}
newtype JSONOutputProp = JSONOutputProp {jsonopRecordDelimiter :: Maybe Text}
deriving stock (Show, Eq)
-- | Set the output record delimiter for JSON format
@ -1089,11 +1083,10 @@ class HasSvcNamespace env where
instance HasSvcNamespace MinioConn where
getSvcNamespace env =
let host = connectHost $ mcConnInfo env
in if
| host == "storage.googleapis.com" ->
"http://doc.s3.amazonaws.com/2006-03-01"
| otherwise ->
"http://s3.amazonaws.com/doc/2006-03-01/"
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

13
src/Network/Minio/ListOps.hs
View File

@ -143,12 +143,15 @@ listIncompleteUploads bucket prefix recurse = loop Nothing Nothing
C..| CC.sinkList
return $ foldl' (\sizeSofar p -> opiSize p + sizeSofar) 0 partInfos
CL.sourceList
$ map
( \((uKey, uId, uInitTime), size) ->
UploadInfo uKey uId uInitTime size
CL.sourceList $
zipWith
( curry
( \((uKey, uId, uInitTime), size) ->
UploadInfo uKey uId uInitTime size
)
)
$ zip (lurUploads res) aggrSizes
(lurUploads res)
aggrSizes
when (lurHasMore res) $
loop (lurNextKey res) (lurNextUpload res)

9
src/Network/Minio/PresignedOperations.hs
View File

@ -210,7 +210,7 @@ data PostPolicy = PostPolicy
instance Json.ToJSON PostPolicy where
toJSON (PostPolicy e c) =
Json.object $
Json.object
[ "expiration" .= iso8601TimeFormat e,
"conditions" .= c
]
@ -298,7 +298,7 @@ presignedPostPolicy ::
Minio (ByteString, H.HashMap Text ByteString)
presignedPostPolicy p = do
ci <- asks mcConnInfo
signTime <- liftIO $ Time.getCurrentTime
signTime <- liftIO Time.getCurrentTime
let extraConditions =
[ PPCEquals "x-amz-date" (toText $ awsTimeFormat signTime),
@ -332,8 +332,9 @@ presignedPostPolicy p = do
formFromPolicy =
H.map encodeUtf8 $
H.fromList $
catMaybes $
mkPair <$> conditions ppWithCreds
mapMaybe
mkPair
(conditions ppWithCreds)
formData = formFromPolicy `H.union` signData
-- compute POST upload URL
bucket = H.lookupDefault "" "bucket" formData

3
src/Network/Minio/S3API.hs
View File

@ -407,8 +407,7 @@ srcInfoToHeaders srcInfo =
fmap formatRFC1123 . srcIfModifiedSince
]
rangeHdr =
maybe [] (\a -> [("x-amz-copy-source-range", HT.renderByteRanges [a])]) $
toByteRange <$> srcRange srcInfo
maybe [] ((\a -> [("x-amz-copy-source-range", HT.renderByteRanges [a])]) . toByteRange) (srcRange srcInfo)
toByteRange :: (Int64, Int64) -> HT.ByteRange
toByteRange (x, y) = HT.ByteRangeFromTo (fromIntegral x) (fromIntegral y)

23
src/Network/Minio/Sign/V4.hs
View File

@ -130,9 +130,9 @@ signV4 !sp !req =
datePair = ("X-Amz-Date", awsTimeFormatBS ts)
computedHeaders =
NC.requestHeaders req
++ if isJust $ expiry
++ if isJust expiry
then []
else map (\(x, y) -> (mk x, y)) [datePair, sha256Hdr]
else map (first mk) [datePair, sha256Hdr]
headersToSign = getHeadersToSign computedHeaders
signedHeaderKeys = B.intercalate ";" $ sort $ map fst headersToSign
-- query-parameters to be added before signing for presigned URLs
@ -169,7 +169,7 @@ signV4 !sp !req =
if isJust expiry
then ("X-Amz-Signature", signature) : authQP
else
[ (\(x, y) -> (CI.foldedCase x, y)) authHeader,
[ first CI.foldedCase authHeader,
datePair,
sha256Hdr
]
@ -188,7 +188,7 @@ mkScope ts region =
getHeadersToSign :: [Header] -> [(ByteString, ByteString)]
getHeadersToSign !h =
filter ((\hdr -> not $ Set.member hdr ignoredHeaders) . fst) $
map (\(x, y) -> (CI.foldedCase x, stripBS y)) h
map (bimap CI.foldedCase stripBS) h
mkCanonicalRequest ::
Bool ->
@ -198,14 +198,13 @@ 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
( bimap (uriEncode True) (maybe "" (uriEncode True))
)
(parseQuery $ NC.queryString req)
sortedHeaders = sort headersForSign
canonicalHeaders =
B.concat $

4
src/Network/Minio/Utils.hs
View File

@ -103,7 +103,7 @@ withNewHandle fp fileAction = do
return resE
mkHeaderFromPairs :: [(ByteString, ByteString)] -> [HT.Header]
mkHeaderFromPairs = map ((\(x, y) -> (mk x, y)))
mkHeaderFromPairs = map (first mk)
lookupHeader :: HT.HeaderName -> [HT.Header] -> Maybe ByteString
lookupHeader hdr = listToMaybe . map snd . filter (\(h, _) -> h == hdr)
@ -113,7 +113,7 @@ getETagHeader hs = decodeUtf8Lenient <$> lookupHeader Hdr.hETag hs
getMetadata :: [HT.Header] -> [(Text, Text)]
getMetadata =
map ((\(x, y) -> (decodeUtf8Lenient $ original x, decodeUtf8Lenient $ stripBS y)))
map (\(x, y) -> (decodeUtf8Lenient $ original x, decodeUtf8Lenient $ stripBS y))
toMaybeMetadataHeader :: (Text, Text) -> Maybe (Text, Text)
toMaybeMetadataHeader (k, v) =

4
src/Network/Minio/XmlGenerator.hs
View File

@ -190,7 +190,7 @@ mkSelectRequest r = LBS.toStrict $ renderLBS def sr
Element
"CSV"
mempty
(map NodeElement $ map kvElement $ csvPropsList c)
(map (NodeElement . kvElement) (csvPropsList c))
formatNode (InputFormatJSON p) =
Element
"JSON"
@ -218,7 +218,7 @@ mkSelectRequest r = LBS.toStrict $ renderLBS def sr
Element
"CSV"
mempty
(map NodeElement $ map kvElement $ csvPropsList c)
(map (NodeElement . kvElement) (csvPropsList c))
]
rdElem Nothing = []
rdElem (Just t) =

8
src/Network/Minio/XmlParser.hs
View File

@ -236,9 +236,9 @@ parseNotification xmldata = do
tcfg = map node $ r $/ s3Elem' "TopicConfiguration"
lcfg = map node $ r $/ s3Elem' "CloudFunctionConfiguration"
Notification
<$> (mapM (parseNode ns "Queue") qcfg)
<*> (mapM (parseNode ns "Topic") tcfg)
<*> (mapM (parseNode ns "CloudFunction") lcfg)
<$> mapM (parseNode ns "Queue") qcfg
<*> mapM (parseNode ns "Topic") tcfg
<*> mapM (parseNode ns "CloudFunction") lcfg
where
getFilterRule ns c =
let name = T.concat $ c $/ s3Elem ns "Name" &/ content
@ -248,7 +248,7 @@ parseNotification xmldata = do
let c = fromNode nodeData
itemId = T.concat $ c $/ s3Elem ns "Id" &/ content
arn = T.concat $ c $/ s3Elem ns arnName &/ content
events = catMaybes $ map textToEvent $ c $/ s3Elem ns "Event" &/ content
events = mapMaybe textToEvent (c $/ s3Elem ns "Event" &/ content)
rules =
c
$/ s3Elem ns "Filter"

54
test/LiveServer.hs
View File

@ -52,7 +52,7 @@ tests = testGroup "Tests" [liveServerUnitTests]
-- conduit that generates random binary stream of given length
randomDataSrc :: MonadIO m => Int64 -> C.ConduitM () ByteString m ()
randomDataSrc s' = genBS s'
randomDataSrc = genBS
where
concatIt bs n =
BS.concat $
@ -180,7 +180,7 @@ basicTests = funTestWithBucket "Basic tests" $
"test-file"
outFile
defaultGetObjectOptions
{ gooIfUnmodifiedSince = (Just unmodifiedTime)
{ gooIfUnmodifiedSince = Just unmodifiedTime
}
case resE of
Left exn -> liftIO $ exn @?= ServiceErr "PreconditionFailed" "At least one of the pre-conditions you specified did not hold"
@ -194,7 +194,7 @@ basicTests = funTestWithBucket "Basic tests" $
"test-file"
outFile
defaultGetObjectOptions
{ gooIfMatch = (Just "invalid-etag")
{ gooIfMatch = Just "invalid-etag"
}
case resE1 of
Left exn -> liftIO $ exn @?= ServiceErr "PreconditionFailed" "At least one of the pre-conditions you specified did not hold"
@ -208,7 +208,7 @@ basicTests = funTestWithBucket "Basic tests" $
"test-file"
outFile
defaultGetObjectOptions
{ gooRange = (Just $ HT.ByteRangeFromTo 100 300)
{ gooRange = Just $ HT.ByteRangeFromTo 100 300
}
case resE2 of
Left exn -> liftIO $ exn @?= ServiceErr "InvalidRange" "The requested range is not satisfiable"
@ -220,7 +220,7 @@ basicTests = funTestWithBucket "Basic tests" $
"test-file"
outFile
defaultGetObjectOptions
{ gooRange = (Just $ HT.ByteRangeFrom 1)
{ gooRange = Just $ HT.ByteRangeFrom 1
}
step "fGetObject a non-existent object and check for NoSuchKey exception"
@ -231,7 +231,7 @@ basicTests = funTestWithBucket "Basic tests" $
step "create new multipart upload works"
uid <- newMultipartUpload bucket "newmpupload" []
liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")
liftIO $ (T.length uid > 0) @? "Got an empty multipartUpload Id."
step "abort a new multipart upload works"
abortMultipartUpload bucket "newmpupload" uid
@ -247,7 +247,7 @@ basicTests = funTestWithBucket "Basic tests" $
step "get metadata of the object"
res <- statObject bucket object defaultGetObjectOptions
liftIO $ (oiSize res) @?= 0
liftIO $ oiSize res @?= 0
step "delete object"
deleteObject bucket object
@ -262,7 +262,7 @@ lowLevelMultipartTest = funTestWithBucket "Low-level Multipart Test" $
step "Prepare for low-level multipart tests."
step "create new multipart upload"
uid <- newMultipartUpload bucket object []
liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")
liftIO $ (T.length uid > 0) @? "Got an empty multipartUpload Id."
randFile <- mkRandFile mb15
@ -338,22 +338,20 @@ highLevelListingTest = funTestWithBucket "High-level listObjects Test" $
\step bucket -> do
step "High-level listObjects Test"
step "put 3 objects"
let expectedObjects = ["dir/o1", "dir/dir1/o2", "dir/dir2/o3", "o4"]
extractObjectsFromList os =
let extractObjectsFromList =
mapM
( \t -> case t of
( \case
ListItemObject o -> Just $ oiObject o
_ -> Nothing
)
os
expectedNonRecList = ["o4", "dir/"]
extractObjectsAndDirsFromList os =
extractObjectsAndDirsFromList =
map
( \t -> case t of
( \case
ListItemObject o -> oiObject o
ListItemPrefix d -> d
)
os
expectedObjects = ["dir/o1", "dir/dir1/o2", "dir/dir2/o3", "o4"]
expectedNonRecList = ["o4", "dir/"]
testFilepath <- mkRandFile 200
forM_ expectedObjects $
@ -435,7 +433,7 @@ highLevelListingTest = funTestWithBucket "High-level listObjects Test" $
step "create 10 multipart uploads"
forM_ [1 .. 10 :: Int] $ \_ -> do
uid <- newMultipartUpload bucket object []
liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")
liftIO $ (T.length uid > 0) @? "Got an empty multipartUpload Id."
step "High-level listing of incomplete multipart uploads"
uploads <-
@ -497,7 +495,7 @@ listingTest = funTestWithBucket "Listing Test" $ \step bucket -> do
map
( T.concat
. ("test-file-" :)
. (\x -> [x])
. (: [])
. T.pack
. show
)
@ -516,7 +514,7 @@ listingTest = funTestWithBucket "Listing Test" $ \step bucket -> do
let object = "newmpupload"
forM_ [1 .. 10 :: Int] $ \_ -> do
uid <- newMultipartUpload bucket object []
liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")
liftIO $ (T.length uid > 0) @? "Got an empty multipartUpload Id."
step "list incomplete multipart uploads"
incompleteUploads <-
@ -527,7 +525,7 @@ listingTest = funTestWithBucket "Listing Test" $ \step bucket -> do
Nothing
Nothing
Nothing
liftIO $ (length $ lurUploads incompleteUploads) @?= 10
liftIO $ length (lurUploads incompleteUploads) @?= 10
step "cleanup"
forM_ (lurUploads incompleteUploads) $
@ -538,7 +536,7 @@ listingTest = funTestWithBucket "Listing Test" $ \step bucket -> do
step "create a multipart upload"
uid <- newMultipartUpload bucket object []
liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")
liftIO $ (T.length uid > 0) @? "Got an empty multipartUpload Id."
step "put object parts 1..10"
inputFile <- mkRandFile mb5
@ -548,7 +546,7 @@ listingTest = funTestWithBucket "Listing Test" $ \step bucket -> do
step "fetch list parts"
listPartsResult <- listIncompleteParts' bucket object uid Nothing Nothing
liftIO $ (length $ lprParts listPartsResult) @?= 10
liftIO $ length (lprParts listPartsResult) @?= 10
abortMultipartUpload bucket object uid
presignedUrlFunTest :: TestTree
@ -662,7 +660,7 @@ presignedPostPolicyFunTest :: TestTree
presignedPostPolicyFunTest = funTestWithBucket "Presigned Post Policy tests" $
\step bucket -> do
step "presignedPostPolicy basic test"
now <- liftIO $ Time.getCurrentTime
now <- liftIO Time.getCurrentTime
let key = "presignedPostPolicyTest/myfile"
policyConds =
@ -693,7 +691,7 @@ presignedPostPolicyFunTest = funTestWithBucket "Presigned Post Policy tests" $
postForm url formData inputFile = do
req <- NC.parseRequest $ decodeUtf8 url
let parts =
map (\(x, y) -> Form.partBS x y) $
map (uncurry Form.partBS) $
H.toList formData
parts' = parts ++ [Form.partFile "file" inputFile]
req' <- Form.formDataBody parts' req
@ -750,7 +748,7 @@ bucketPolicyFunTest = funTestWithBucket "Bucket Policy tests" $
`catch` (\(e :: NC.HttpException) -> return $ Left (show e :: Text))
case respE of
Left err -> liftIO $ assertFailure $ show err
Right s -> liftIO $ s @?= (BS.concat $ replicate 100 "c")
Right s -> liftIO $ s @?= BS.concat (replicate 100 "c")
deleteObject bucket obj
@ -805,7 +803,7 @@ multipartTest = funTestWithBucket "Multipart Tests" $
C.runConduit $
listIncompleteUploads bucket (Just object) False
C..| sinkList
liftIO $ (null uploads) @? "removeIncompleteUploads didn't complete successfully"
liftIO $ null uploads @? "removeIncompleteUploads didn't complete successfully"
putObjectContentTypeTest :: TestTree
putObjectContentTypeTest = funTestWithBucket "putObject contentType tests" $
@ -913,7 +911,7 @@ putObjectUserMetadataTest = funTestWithBucket "putObject user-metadata test" $
-- need to do a case-insensitive comparison
sortedMeta =
sort $
map (\(k, v) -> (T.toLower k, T.toLower v)) $
map (bimap T.toLower T.toLower) $
H.toList m
ref = sort [("mykey1", "myval1"), ("mykey2", "myval2")]
@ -948,7 +946,7 @@ getObjectTest = funTestWithBucket "getObject test" $
-- need to do a case-insensitive comparison
sortedMeta =
sort $
map (\(k, v) -> (T.toLower k, T.toLower v)) $
map (bimap T.toLower T.toLower) $
H.toList m
ref = sort [("mykey1", "myval1"), ("mykey2", "myval2")]

2
test/Network/Minio/JsonParser/Test.hs
View File

@ -34,7 +34,7 @@ jsonParserTests =
]
tryValidationErr :: (MonadUnliftIO m) => m a -> m (Either MErrV a)
tryValidationErr act = try act
tryValidationErr = try
assertValidationErr :: MErrV -> Assertion
assertValidationErr e = assertFailure $ "Failed due to validation error => " ++ show e

2
test/Network/Minio/XmlParser/Test.hs
View File

@ -49,7 +49,7 @@ xmlParserTests =
]
tryValidationErr :: (MonadUnliftIO m) => m a -> m (Either MErrV a)
tryValidationErr act = try act
tryValidationErr = try
assertValidtionErr :: MErrV -> Assertion
assertValidtionErr e = assertFailure $ "Failed due to validation error => " ++ show e

12
test/Spec.hs
View File

@ -55,17 +55,17 @@ qcProps =
\n ->
let (pns, offs, sizes) = L.unzip3 (selectPartSizes n)
-- check that pns increments from 1.
isPNumsAscendingFrom1 = all (\(a, b) -> a == b) $ zip pns [1 ..]
isPNumsAscendingFrom1 = all (uncurry (==)) $ zip pns [1 ..]
consPairs [] = []
consPairs [_] = []
consPairs (a : (b : c)) = (a, b) : (consPairs (b : c))
consPairs (a : (b : c)) = (a, b) : consPairs (b : c)
-- check `offs` is monotonically increasing.
isOffsetsAsc = all (\(a, b) -> a < b) $ consPairs offs
isOffsetsAsc = all (uncurry (<)) $ consPairs offs
-- check sizes sums to n.
isSumSizeOk = sum sizes == n
-- check sizes are constant except last
isSizesConstantExceptLast =
all (\(a, b) -> a == b) (consPairs $ L.init sizes)
all (uncurry (==)) (consPairs $ L.init sizes)
-- check each part except last is at least minPartSize;
-- last part may be 0 only if it is the only part.
nparts = length sizes
@ -94,7 +94,7 @@ qcProps =
isFirstPartOk = maybe False ((start ==) . fst) $ listToMaybe pairs
-- each pair is >=64MiB except last, and all those parts
-- have same size.
initSizes = maybe [] (map (\(a, b) -> b - a + 1)) $ init <$> nonEmpty pairs
initSizes = maybe [] (map (\(a, b) -> b - a + 1) . init) (nonEmpty pairs)
isPartSizesOk =
all (>= minPartSize) initSizes
&& maybe
@ -106,7 +106,7 @@ qcProps =
snds = take (length pairs - 1) $ map snd pairs
isContParts =
length fsts == length snds
&& and (map (\(a, b) -> a == b + 1) $ zip fsts snds)
&& all (\(a, b) -> a == b + 1) (zip fsts snds)
in start < 0
|| start > end
|| (isLastPartOk && isFirstPartOk && isPartSizesOk && isContParts),