Updates from new ormolu 0.4 (#167)
* Changes from formatter * Fix github action run on master branch
This commit is contained in:
parent
193be59432
commit
c59b7066fc
4
.github/workflows/ci.yml
vendored
4
.github/workflows/ci.yml
vendored
@ -1,6 +1,6 @@
|
|||||||
name: CI
|
name: CI
|
||||||
|
|
||||||
# Trigger the workflow on push or pull request, but only for the main branch
|
# Trigger the workflow on push or pull request, but only for the master branch
|
||||||
on:
|
on:
|
||||||
pull_request:
|
pull_request:
|
||||||
branches: [master]
|
branches: [master]
|
||||||
@ -45,7 +45,7 @@ jobs:
|
|||||||
|
|
||||||
steps:
|
steps:
|
||||||
- uses: actions/checkout@v2
|
- uses: actions/checkout@v2
|
||||||
if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/main'
|
if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master'
|
||||||
|
|
||||||
- uses: haskell/actions/setup@v1
|
- uses: haskell/actions/setup@v1
|
||||||
id: setup-haskell-cabal
|
id: setup-haskell-cabal
|
||||||
|
|||||||
@ -88,10 +88,10 @@ getRegion ri = do
|
|||||||
-- getService/makeBucket/getLocation -- don't need location
|
-- getService/makeBucket/getLocation -- don't need location
|
||||||
if
|
if
|
||||||
| not $ riNeedsLocation ri ->
|
| not $ riNeedsLocation ri ->
|
||||||
return $ Just $ connectRegion ci
|
return $ Just $ connectRegion ci
|
||||||
-- if autodiscovery of location is disabled by user
|
-- if autodiscovery of location is disabled by user
|
||||||
| not $ connectAutoDiscoverRegion ci ->
|
| not $ connectAutoDiscoverRegion ci ->
|
||||||
return $ Just $ connectRegion ci
|
return $ Just $ connectRegion ci
|
||||||
-- discover the region for the request
|
-- discover the region for the request
|
||||||
| otherwise -> discoverRegion ri
|
| otherwise -> discoverRegion ri
|
||||||
|
|
||||||
@ -137,10 +137,10 @@ getHostPathRegion ri = do
|
|||||||
)
|
)
|
||||||
if
|
if
|
||||||
| isAWSConnectInfo ci ->
|
| isAWSConnectInfo ci ->
|
||||||
return $
|
return $
|
||||||
if bucketHasPeriods bucket
|
if bucketHasPeriods bucket
|
||||||
then pathStyle
|
then pathStyle
|
||||||
else virtualStyle
|
else virtualStyle
|
||||||
| otherwise -> return pathStyle
|
| otherwise -> return pathStyle
|
||||||
|
|
||||||
buildRequest :: S3ReqInfo -> Minio NC.Request
|
buildRequest :: S3ReqInfo -> Minio NC.Request
|
||||||
@ -196,42 +196,42 @@ buildRequest ri = do
|
|||||||
|
|
||||||
if
|
if
|
||||||
| isJust (riPresignExpirySecs ri') ->
|
| isJust (riPresignExpirySecs ri') ->
|
||||||
-- case 0 from above.
|
-- case 0 from above.
|
||||||
do
|
do
|
||||||
let signPairs = signV4 sp baseRequest
|
let signPairs = signV4 sp baseRequest
|
||||||
qpToAdd = (fmap . fmap) Just signPairs
|
qpToAdd = (fmap . fmap) Just signPairs
|
||||||
existingQueryParams = HT.parseQuery (NC.queryString baseRequest)
|
existingQueryParams = HT.parseQuery (NC.queryString baseRequest)
|
||||||
updatedQueryParams = existingQueryParams ++ qpToAdd
|
updatedQueryParams = existingQueryParams ++ qpToAdd
|
||||||
return $ NClient.setQueryString updatedQueryParams baseRequest
|
return $ NClient.setQueryString updatedQueryParams baseRequest
|
||||||
| isStreamingPayload (riPayload ri') && (not $ connectIsSecure ci') ->
|
| isStreamingPayload (riPayload ri') && (not $ connectIsSecure ci') ->
|
||||||
-- case 2 from above.
|
-- case 2 from above.
|
||||||
do
|
do
|
||||||
(pLen, pSrc) <- case riPayload ri of
|
(pLen, pSrc) <- case riPayload ri of
|
||||||
PayloadC l src -> return (l, src)
|
PayloadC l src -> return (l, src)
|
||||||
_ -> throwIO MErrVUnexpectedPayload
|
_ -> throwIO MErrVUnexpectedPayload
|
||||||
let reqFn = signV4Stream pLen sp baseRequest
|
let reqFn = signV4Stream pLen sp baseRequest
|
||||||
return $ reqFn pSrc
|
return $ reqFn pSrc
|
||||||
| otherwise ->
|
| otherwise ->
|
||||||
do
|
do
|
||||||
sp' <-
|
sp' <-
|
||||||
if
|
if
|
||||||
| connectIsSecure ci' ->
|
| connectIsSecure ci' ->
|
||||||
-- case 1 described above.
|
-- case 1 described above.
|
||||||
return sp
|
return sp
|
||||||
| otherwise ->
|
| otherwise ->
|
||||||
-- case 3 described above.
|
-- case 3 described above.
|
||||||
do
|
do
|
||||||
pHash <- getPayloadSHA256Hash $ riPayload ri'
|
pHash <- getPayloadSHA256Hash $ riPayload ri'
|
||||||
return $ sp {spPayloadHash = Just pHash}
|
return $ sp {spPayloadHash = Just pHash}
|
||||||
|
|
||||||
let signHeaders = signV4 sp' baseRequest
|
let signHeaders = signV4 sp' baseRequest
|
||||||
return $
|
return $
|
||||||
baseRequest
|
baseRequest
|
||||||
{ NC.requestHeaders =
|
{ NC.requestHeaders =
|
||||||
NC.requestHeaders baseRequest
|
NC.requestHeaders baseRequest
|
||||||
++ mkHeaderFromPairs signHeaders,
|
++ mkHeaderFromPairs signHeaders,
|
||||||
NC.requestBody = getRequestBody (riPayload ri')
|
NC.requestBody = getRequestBody (riPayload ri')
|
||||||
}
|
}
|
||||||
|
|
||||||
retryAPIRequest :: Minio a -> Minio a
|
retryAPIRequest :: Minio a -> Minio a
|
||||||
retryAPIRequest apiCall = do
|
retryAPIRequest apiCall = do
|
||||||
|
|||||||
@ -599,8 +599,8 @@ buildAdminRequest areq = do
|
|||||||
sha256Hash <-
|
sha256Hash <-
|
||||||
if
|
if
|
||||||
| connectIsSecure ci ->
|
| connectIsSecure ci ->
|
||||||
-- if secure connection
|
-- if secure connection
|
||||||
return "UNSIGNED-PAYLOAD"
|
return "UNSIGNED-PAYLOAD"
|
||||||
-- otherwise compute sha256
|
-- otherwise compute sha256
|
||||||
| otherwise -> getPayloadSHA256Hash (ariPayload areq)
|
| otherwise -> getPayloadSHA256Hash (ariPayload areq)
|
||||||
|
|
||||||
|
|||||||
@ -226,8 +226,8 @@ getHostAddr ci =
|
|||||||
if
|
if
|
||||||
| port == 80 || port == 443 -> toUtf8 host
|
| port == 80 || port == 443 -> toUtf8 host
|
||||||
| otherwise ->
|
| otherwise ->
|
||||||
toUtf8 $
|
toUtf8 $
|
||||||
T.concat [host, ":", Lib.Prelude.show port]
|
T.concat [host, ":", Lib.Prelude.show port]
|
||||||
where
|
where
|
||||||
port = connectPort ci
|
port = connectPort ci
|
||||||
host = connectHost ci
|
host = connectHost ci
|
||||||
@ -283,9 +283,9 @@ newtype SSECKey = SSECKey BA.ScrubbedBytes
|
|||||||
mkSSECKey :: MonadThrow m => ByteString -> m SSECKey
|
mkSSECKey :: MonadThrow m => ByteString -> m SSECKey
|
||||||
mkSSECKey keyBytes
|
mkSSECKey keyBytes
|
||||||
| B.length keyBytes /= 32 =
|
| B.length keyBytes /= 32 =
|
||||||
throwM MErrVInvalidEncryptionKeyLength
|
throwM MErrVInvalidEncryptionKeyLength
|
||||||
| otherwise =
|
| otherwise =
|
||||||
return $ SSECKey $ BA.convert keyBytes
|
return $ SSECKey $ BA.convert keyBytes
|
||||||
|
|
||||||
-- | Data type to represent Server-Side-Encryption settings
|
-- | Data type to represent Server-Side-Encryption settings
|
||||||
data SSE where
|
data SSE where
|
||||||
@ -1079,9 +1079,9 @@ instance HasSvcNamespace MinioConn where
|
|||||||
let host = connectHost $ mcConnInfo env
|
let host = connectHost $ mcConnInfo env
|
||||||
in if
|
in if
|
||||||
| host == "storage.googleapis.com" ->
|
| host == "storage.googleapis.com" ->
|
||||||
"http://doc.s3.amazonaws.com/2006-03-01"
|
"http://doc.s3.amazonaws.com/2006-03-01"
|
||||||
| otherwise ->
|
| otherwise ->
|
||||||
"http://s3.amazonaws.com/doc/2006-03-01/"
|
"http://s3.amazonaws.com/doc/2006-03-01/"
|
||||||
|
|
||||||
-- | Takes connection information and returns a connection object to
|
-- | Takes connection information and returns a connection object to
|
||||||
-- be passed to 'runMinio'. The returned value can be kept in the
|
-- be passed to 'runMinio'. The returned value can be kept in the
|
||||||
@ -1091,8 +1091,8 @@ connect :: ConnectInfo -> IO MinioConn
|
|||||||
connect ci = do
|
connect ci = do
|
||||||
let settings
|
let settings
|
||||||
| connectIsSecure ci && connectDisableTLSCertValidation ci =
|
| connectIsSecure ci && connectDisableTLSCertValidation ci =
|
||||||
let badTlsSettings = Conn.TLSSettingsSimple True False False
|
let badTlsSettings = Conn.TLSSettingsSimple True False False
|
||||||
in TLS.mkManagerSettings badTlsSettings Nothing
|
in TLS.mkManagerSettings badTlsSettings Nothing
|
||||||
| connectIsSecure ci = NC.tlsManagerSettings
|
| connectIsSecure ci = NC.tlsManagerSettings
|
||||||
| otherwise = defaultManagerSettings
|
| otherwise = defaultManagerSettings
|
||||||
mgr <- NC.newManager settings
|
mgr <- NC.newManager settings
|
||||||
|
|||||||
@ -66,7 +66,7 @@ uriEncodeChar ch _
|
|||||||
|| (ch == '-')
|
|| (ch == '-')
|
||||||
|| (ch == '.')
|
|| (ch == '.')
|
||||||
|| (ch == '~') =
|
|| (ch == '~') =
|
||||||
BB.char7 ch
|
BB.char7 ch
|
||||||
| otherwise = mconcat $ map f $ B.unpack $ encodeUtf8 $ T.singleton ch
|
| otherwise = mconcat $ map f $ B.unpack $ encodeUtf8 $ T.singleton ch
|
||||||
where
|
where
|
||||||
f :: Word8 -> BB.Builder
|
f :: Word8 -> BB.Builder
|
||||||
|
|||||||
@ -246,19 +246,19 @@ newPostPolicy ::
|
|||||||
newPostPolicy expirationTime conds
|
newPostPolicy expirationTime conds
|
||||||
-- object name condition must be present
|
-- object name condition must be present
|
||||||
| not $ any (keyEquals "key") conds =
|
| not $ any (keyEquals "key") conds =
|
||||||
Left PPEKeyNotSpecified
|
Left PPEKeyNotSpecified
|
||||||
-- bucket name condition must be present
|
-- bucket name condition must be present
|
||||||
| not $ any (keyEquals "bucket") conds =
|
| not $ any (keyEquals "bucket") conds =
|
||||||
Left PPEBucketNotSpecified
|
Left PPEBucketNotSpecified
|
||||||
-- a condition with an empty key is invalid
|
-- a condition with an empty key is invalid
|
||||||
| any (keyEquals "") conds || any isEmptyRangeKey conds =
|
| any (keyEquals "") conds || any isEmptyRangeKey conds =
|
||||||
Left PPEConditionKeyEmpty
|
Left PPEConditionKeyEmpty
|
||||||
-- invalid range check
|
-- invalid range check
|
||||||
| any isInvalidRange conds =
|
| any isInvalidRange conds =
|
||||||
Left PPERangeInvalid
|
Left PPERangeInvalid
|
||||||
-- all good!
|
-- all good!
|
||||||
| otherwise =
|
| otherwise =
|
||||||
return $ PostPolicy expirationTime conds
|
return $ PostPolicy expirationTime conds
|
||||||
where
|
where
|
||||||
keyEquals k' (PPCStartsWith k _) = k == k'
|
keyEquals k' (PPCStartsWith k _) = k == k'
|
||||||
keyEquals k' (PPCEquals k _) = k == k'
|
keyEquals k' (PPCEquals k _) = k == k'
|
||||||
|
|||||||
@ -71,8 +71,8 @@ putObjectInternal b o opts (ODStream src sizeMay) = do
|
|||||||
Just size ->
|
Just size ->
|
||||||
if
|
if
|
||||||
| size <= 64 * oneMiB -> do
|
| size <= 64 * oneMiB -> do
|
||||||
bs <- C.runConduit $ src C..| takeC (fromIntegral size) C..| CB.sinkLbs
|
bs <- C.runConduit $ src C..| takeC (fromIntegral size) C..| CB.sinkLbs
|
||||||
putObjectSingle' b o (pooToHeaders opts) $ LBS.toStrict bs
|
putObjectSingle' b o (pooToHeaders opts) $ LBS.toStrict bs
|
||||||
| size > maxObjectSize -> throwIO $ MErrVPutSizeExceeded size
|
| size > maxObjectSize -> throwIO $ MErrVPutSizeExceeded size
|
||||||
| otherwise -> sequentialMultipartUpload b o opts (Just size) src
|
| otherwise -> sequentialMultipartUpload b o opts (Just size) src
|
||||||
putObjectInternal b o opts (ODFile fp sizeMay) = do
|
putObjectInternal b o opts (ODFile fp sizeMay) = do
|
||||||
@ -95,13 +95,13 @@ putObjectInternal b o opts (ODFile fp sizeMay) = do
|
|||||||
Just size ->
|
Just size ->
|
||||||
if
|
if
|
||||||
| size <= 64 * oneMiB ->
|
| size <= 64 * oneMiB ->
|
||||||
either throwIO return
|
either throwIO return
|
||||||
=<< withNewHandle fp (\h -> putObjectSingle b o (pooToHeaders opts) h 0 size)
|
=<< withNewHandle fp (\h -> putObjectSingle b o (pooToHeaders opts) h 0 size)
|
||||||
| size > maxObjectSize -> throwIO $ MErrVPutSizeExceeded size
|
| size > maxObjectSize -> throwIO $ MErrVPutSizeExceeded size
|
||||||
| isSeekable -> parallelMultipartUpload b o opts fp size
|
| isSeekable -> parallelMultipartUpload b o opts fp size
|
||||||
| otherwise ->
|
| otherwise ->
|
||||||
sequentialMultipartUpload b o opts (Just size) $
|
sequentialMultipartUpload b o opts (Just size) $
|
||||||
CB.sourceFile fp
|
CB.sourceFile fp
|
||||||
|
|
||||||
parallelMultipartUpload ::
|
parallelMultipartUpload ::
|
||||||
Bucket ->
|
Bucket ->
|
||||||
|
|||||||
@ -186,7 +186,7 @@ crcCheck = do
|
|||||||
-- 12 bytes have been read off the current message. Now read the
|
-- 12 bytes have been read off the current message. Now read the
|
||||||
-- next (n-12)-4 bytes and accumulate the checksum, and yield it.
|
-- next (n-12)-4 bytes and accumulate the checksum, and yield it.
|
||||||
let startCrc = crc32 b
|
let startCrc = crc32 b
|
||||||
finalCrc <- accumulateYield (fromIntegral n -16) startCrc
|
finalCrc <- accumulateYield (fromIntegral n - 16) startCrc
|
||||||
|
|
||||||
bs <- readNBytes 4
|
bs <- readNBytes 4
|
||||||
expectedCrc :: Word32 <- liftIO $ parseBinary bs
|
expectedCrc :: Word32 <- liftIO $ parseBinary bs
|
||||||
@ -276,7 +276,7 @@ selectObjectContent b o r = do
|
|||||||
riNeedsLocation = False,
|
riNeedsLocation = False,
|
||||||
riQueryParams = [("select", Nothing), ("select-type", Just "2")]
|
riQueryParams = [("select", Nothing), ("select-type", Just "2")]
|
||||||
}
|
}
|
||||||
--print $ mkSelectRequest r
|
-- print $ mkSelectRequest r
|
||||||
resp <- mkStreamRequest reqInfo
|
resp <- mkStreamRequest reqInfo
|
||||||
return $ NC.responseBody resp .| selectProtoConduit
|
return $ NC.responseBody resp .| selectProtoConduit
|
||||||
|
|
||||||
|
|||||||
@ -365,41 +365,41 @@ signV4Stream !payloadLength !sp !req =
|
|||||||
-- 'chunkSizeConstant'.
|
-- 'chunkSizeConstant'.
|
||||||
if
|
if
|
||||||
| n > 0 -> do
|
| n > 0 -> do
|
||||||
bs <- mustTakeN chunkSizeConstant
|
bs <- mustTakeN chunkSizeConstant
|
||||||
let strToSign = chunkStrToSign prevSign (hashSHA256 bs)
|
let strToSign = chunkStrToSign prevSign (hashSHA256 bs)
|
||||||
nextSign = computeSignature strToSign signingKey
|
nextSign = computeSignature strToSign signingKey
|
||||||
chunkBS =
|
chunkBS =
|
||||||
toHexStr chunkSizeConstant
|
toHexStr chunkSizeConstant
|
||||||
<> ";chunk-signature="
|
<> ";chunk-signature="
|
||||||
<> nextSign
|
<> nextSign
|
||||||
<> "\r\n"
|
<> "\r\n"
|
||||||
<> bs
|
<> bs
|
||||||
<> "\r\n"
|
<> "\r\n"
|
||||||
C.yield chunkBS
|
C.yield chunkBS
|
||||||
signerConduit (n -1) lps nextSign
|
signerConduit (n - 1) lps nextSign
|
||||||
|
|
||||||
-- Second case encodes the last chunk which is smaller than
|
-- Second case encodes the last chunk which is smaller than
|
||||||
-- 'chunkSizeConstant'
|
-- 'chunkSizeConstant'
|
||||||
| lps > 0 -> do
|
| lps > 0 -> do
|
||||||
bs <- mustTakeN $ fromIntegral lps
|
bs <- mustTakeN $ fromIntegral lps
|
||||||
let strToSign = chunkStrToSign prevSign (hashSHA256 bs)
|
let strToSign = chunkStrToSign prevSign (hashSHA256 bs)
|
||||||
nextSign = computeSignature strToSign signingKey
|
nextSign = computeSignature strToSign signingKey
|
||||||
chunkBS =
|
chunkBS =
|
||||||
toHexStr lps <> ";chunk-signature="
|
toHexStr lps <> ";chunk-signature="
|
||||||
<> nextSign
|
<> nextSign
|
||||||
<> "\r\n"
|
<> "\r\n"
|
||||||
<> bs
|
<> bs
|
||||||
<> "\r\n"
|
<> "\r\n"
|
||||||
C.yield chunkBS
|
C.yield chunkBS
|
||||||
signerConduit 0 0 nextSign
|
signerConduit 0 0 nextSign
|
||||||
|
|
||||||
-- Last case encodes the final signature chunk that has no
|
-- Last case encodes the final signature chunk that has no
|
||||||
-- data.
|
-- data.
|
||||||
| otherwise -> do
|
| otherwise -> do
|
||||||
let strToSign = chunkStrToSign prevSign (hashSHA256 "")
|
let strToSign = chunkStrToSign prevSign (hashSHA256 "")
|
||||||
nextSign = computeSignature strToSign signingKey
|
nextSign = computeSignature strToSign signingKey
|
||||||
lastChunkBS = "0;chunk-signature=" <> nextSign <> "\r\n\r\n"
|
lastChunkBS = "0;chunk-signature=" <> nextSign <> "\r\n\r\n"
|
||||||
C.yield lastChunkBS
|
C.yield lastChunkBS
|
||||||
in \src ->
|
in \src ->
|
||||||
req
|
req
|
||||||
{ NC.requestHeaders = finalReqHeaders,
|
{ NC.requestHeaders = finalReqHeaders,
|
||||||
|
|||||||
@ -235,7 +235,7 @@ limitedMapConcurrently count act args = do
|
|||||||
waitSem t = U.atomically $ do
|
waitSem t = U.atomically $ do
|
||||||
v <- U.readTVar t
|
v <- U.readTVar t
|
||||||
if v > 0
|
if v > 0
|
||||||
then U.writeTVar t (v -1)
|
then U.writeTVar t (v - 1)
|
||||||
else U.retrySTM
|
else U.retrySTM
|
||||||
signalSem t = U.atomically $ do
|
signalSem t = U.atomically $ do
|
||||||
v <- U.readTVar t
|
v <- U.readTVar t
|
||||||
|
|||||||
@ -1076,7 +1076,7 @@ copyObjectTests = funTestWithBucket "copyObject related tests" $
|
|||||||
copyObjectPart
|
copyObjectPart
|
||||||
dstInfo'
|
dstInfo'
|
||||||
srcInfo'
|
srcInfo'
|
||||||
{ srcRange = Just $ (,) ((p -1) * mb5) ((p -1) * mb5 + (mb5 - 1))
|
{ srcRange = Just $ (,) ((p - 1) * mb5) ((p - 1) * mb5 + (mb5 - 1))
|
||||||
}
|
}
|
||||||
uid
|
uid
|
||||||
(fromIntegral p)
|
(fromIntegral p)
|
||||||
|
|||||||
@ -72,11 +72,11 @@ qcProps =
|
|||||||
isMinPartSizeOk =
|
isMinPartSizeOk =
|
||||||
if
|
if
|
||||||
| nparts > 1 -> -- last part can be smaller but > 0
|
| nparts > 1 -> -- last part can be smaller but > 0
|
||||||
all (>= minPartSize) (take (nparts - 1) sizes)
|
all (>= minPartSize) (take (nparts - 1) sizes)
|
||||||
&& all (\s -> s > 0) (drop (nparts - 1) sizes)
|
&& all (\s -> s > 0) (drop (nparts - 1) sizes)
|
||||||
| nparts == 1 -> -- size may be 0 here.
|
| nparts == 1 -> -- size may be 0 here.
|
||||||
maybe True (\x -> x >= 0 && x <= minPartSize) $
|
maybe True (\x -> x >= 0 && x <= minPartSize) $
|
||||||
headMay sizes
|
headMay sizes
|
||||||
| otherwise -> False
|
| otherwise -> False
|
||||||
in n < 0
|
in n < 0
|
||||||
|| ( isPNumsAscendingFrom1 && isOffsetsAsc && isSumSizeOk
|
|| ( isPNumsAscendingFrom1 && isOffsetsAsc && isSumSizeOk
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user