diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,9 @@ +## Version 0.0.3 (2018-12-27) + +- Add support for GHC 8.6.3 +- Remove dependency on `unliftio-core` to fix compatibility issue + with un-released version of amazonka + ## Version 0.0.2 (2018-12-27) - Fix missing `Real` from `mismi-p` diff --git a/mismi-s3.cabal b/mismi-s3.cabal --- a/mismi-s3.cabal +++ b/mismi-s3.cabal @@ -1,4 +1,4 @@ -version: 0.0.2 +version: 0.0.3 name: mismi-s3 @@ -28,6 +28,7 @@ tested-with: GHC == 8.2.2 , GHC == 8.4.3 + , GHC == 8.6.3 extra-source-files: CHANGELOG.md @@ -35,9 +36,9 @@ library build-depends: base >= 3 && < 5 - , mismi-core == 0.0.2.* - , mismi-s3-core == 0.0.2.* - , mismi-p == 0.0.2.* + , mismi-core == 0.0.3.* + , mismi-s3-core == 0.0.3.* + , mismi-p == 0.0.3.* , template-haskell , amazonka >= 1.5 && < 1.7 , amazonka-core >= 1.5 && < 1.7 @@ -67,12 +68,11 @@ , retry == 0.7.* , lens >= 4.8 && < 4.18 , SafeSemaphore == 0.10.* - , stm == 2.4.* + , stm >= 2.4 && < 2.6 , unix-bytestring == 0.3.7.* , time >= 1.4 && < 1.10 , unordered-containers >= 0.2.5 && < 0.3 , uuid == 1.3.* - , unliftio , mmorph >= 1.0 && < 1.2 , lifted-base == 0.2.* @@ -123,14 +123,14 @@ , amazonka-core >= 1.5 && < 1.7 , amazonka-s3 >= 1.5 && < 1.7 , hedgehog - , mismi-core == 0.0.2.* - , mismi-core-test == 0.0.2.* + , mismi-core == 0.0.3.* + , mismi-core-test == 0.0.3.* , mismi-s3 - , mismi-s3-core == 0.0.2.* - , mismi-s3-core-test == 0.0.2.* - , mismi-p == 0.0.2.* + , mismi-s3-core == 0.0.3.* + , mismi-s3-core-test == 0.0.3.* + , mismi-p == 0.0.3.* , conduit >= 1.2 && < 1.4 - , containers == 0.5.* + , containers >= 0.5 && < 0.7 , directory >= 1.2 && < 1.4 , exceptions >= 0.7 && < 0.11 , filepath >= 1.3 && < 1.5 @@ -168,12 +168,12 @@ build-depends: base - , mismi-core == 0.0.2.* - , mismi-core-test == 0.0.2.* + , mismi-core == 0.0.3.* + , mismi-core-test == 0.0.3.* , mismi-s3 - , mismi-s3-core == 0.0.2.* - , mismi-s3-core-test == 0.0.2.* - , mismi-p == 0.0.2.* + , mismi-s3-core == 0.0.3.* + , mismi-s3-core-test == 0.0.3.* + , mismi-p == 0.0.3.* , bytestring >= 0.10 && < 0.11 , cryptohash , directory >= 1.2 && < 1.4 @@ -211,10 +211,10 @@ build-depends: base - , mismi-core == 0.0.2.* - , mismi-core-test == 0.0.2.* + , mismi-core == 0.0.3.* + , mismi-core-test == 0.0.3.* , mismi-s3 - , mismi-p == 0.0.2.* + , mismi-p == 0.0.3.* , directory >= 1.2 && < 1.4 , exceptions >= 0.7 && < 0.11 , filepath >= 1.3 && < 1.5 @@ -245,10 +245,10 @@ build-depends: base - , mismi-core == 0.0.2.* - , mismi-core-test == 0.0.2.* + , mismi-core == 0.0.3.* + , mismi-core-test == 0.0.3.* , mismi-s3 - , mismi-p == 0.0.2.* + , mismi-p == 0.0.3.* , criterion >= 1.3 && < 1.5 , conduit-extra >= 1.1.13 && < 1.5 , directory >= 1.2 && < 1.4 diff --git a/src/Mismi/S3/Commands.hs b/src/Mismi/S3/Commands.hs --- a/src/Mismi/S3/Commands.hs +++ b/src/Mismi/S3/Commands.hs @@ -5,55 +5,85 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} module Mismi.S3.Commands ( + -- * Operations + -- ** Existence headObject , exists , existsPrefix + + -- ** Size , getSize , size , sizeRecursively + + -- ** Delete , delete - , read + + -- ** Copy , concatMultipart , copy , copyWithMode , copyMultipart + -- *** Recursive copy + , sync + , syncWithMode + + + -- ** Move , move + + -- ** Upload , upload , uploadWithMode , uploadRecursive , uploadRecursiveWithMode , multipartUpload , uploadSingle + + -- ** Write , write , writeWithMode + + -- ** Read + , read , getObjects , getObjectsRecursively + + -- ** List , listObjects , list + , listRecursively + + -- ** Download , download , downloadWithMode , downloadSingle , downloadWithRange + , multipartDownload , downloadRecursive , downloadRecursiveWithMode - , multipartDownload + + -- ** Multipart + , createMultipartUpload , listMultipartParts , listMultiparts , listOldMultiparts , listOldMultiparts' , abortMultipart , abortMultipart' + -- *** Filter , filterOld , filterNDays - , listRecursively - , sync - , syncWithMode - , createMultipartUpload + + -- ** Grant ACL , grantReadAccess + + -- * Utility , chunkFilesBySize ) where import Control.Arrow ((***)) +import Control.Concurrent.Async (mapConcurrently_) import Control.Exception (ioError) import qualified Control.Exception as CE import Control.Lens ((.~), (^.), to, view) @@ -117,8 +147,6 @@ import System.Posix.Files (fileSize, getFileStatus, isDirectory, isRegularFile) import qualified "unix-bytestring" System.Posix.IO.ByteString as UBS -import qualified UnliftIO.Async as UnliftIO -import qualified UnliftIO.Timeout as UnliftIO import System.IO.Error (userError) -- | Retrieves the 'HeadObjectResponse'. Handles any 404 response by converting to Maybe. @@ -159,19 +187,6 @@ delete = void . send . f' A.deleteObject --- | Retrieve the object at 'Address'. Handles any 404 response by converting to Maybe. -getObject' :: Address -> AWS (Maybe GetObjectResponse) -getObject' = - handle404 . send . f' A.getObject - --- | Read contents of 'Address'. --- -read :: Address -> AWS (Maybe Text) -read a = withRetries 5 $ do - r <- Stream.read a - z <- liftIO . sequence $ (\x -> runResourceT . runConduit $ x .| Conduit.sinkLbs) <$> r - pure $ fmap (T.concat . TL.toChunks . TL.decodeUtf8) z - concatMultipart :: WriteMode -> Int -> [Address] -> Address -> ExceptT ConcatError AWS () concatMultipart mode fork inputs dest = do when (mode == Fail) . @@ -318,11 +333,28 @@ m <- fromMaybeM (throwM . Invariant $ "cprETag") $ pr ^. A.cprETag pure $! Right $! PartResponse i m -createMultipartUpload :: Address -> AWS Text -createMultipartUpload a = do - mpu <- send $ f' A.createMultipartUpload a & A.cmuServerSideEncryption .~ Just sse - maybe (throwM . Invariant $ "MultipartUpload: missing 'UploadId'") pure (mpu ^. A.cmursUploadId) +sync :: Address -> Address -> Int -> ExceptT SyncError AWS () +sync = + syncWithMode FailSync +syncWithMode :: SyncMode -> Address -> Address -> Int -> ExceptT SyncError AWS () +syncWithMode mode source dest fork = do + e <- ask + void . firstT SyncError . ExceptT . liftIO $ + (consume (sinkQueue e (Stream.listRecursively source)) fork (syncWorker source dest mode e)) + +syncWorker :: Address -> Address -> SyncMode -> Env -> Address -> IO (Either SyncWorkerError ()) +syncWorker input output mode env f = runExceptT . runAWST env SyncAws $ do + n <- maybe (throwE $ SyncInvariant input f) pure $ removeCommonPrefix input f + let out = withKey (// n) output + liftCopy = firstT SyncCopyError + cp = liftCopy $ copy f out + foldSyncMode + (ifM (lift $ exists out) (throwE $ OutputExists out) cp) + (liftCopy $ copyWithMode Overwrite f out) + (ifM (lift $ exists out) (pure ()) cp) + mode + move :: Address -> Address -> ExceptT CopyError AWS () move source destination' = copy source destination' >> @@ -432,8 +464,9 @@ uploadFiles [(f,s)] | fromIntegral s < bigChunkSize = lift . uploadSingle f $ uploadAddress f | otherwise = uploadWithMode mode f $ uploadAddress f - uploadFiles xs = - lift $ UnliftIO.mapConcurrently_ (\ (f, _) -> uploadSingle f $ uploadAddress f) xs + uploadFiles xs = do + e <- ask + liftIO $ mapConcurrently_ (\ (f, _) -> unsafeRunAWS e . uploadSingle f $ uploadAddress f) xs prefixLen = L.length (src "a") - 1 @@ -442,9 +475,9 @@ uploadAddress fp = Address buck (ky // Key (T.pack $ L.drop prefixLen fp)) --- Take a list of files and their sizes, and convert it to a list of tests --- where the total size of the files in the sub list is less than `maxSize` --- and the length of the sub lists is <= `maxCount`. +-- | Take a list of files and their sizes, and convert it to a list of tests +-- where the total size of the files in the sub list is less than `maxSize` +-- and the length of the sub lists is <= `maxCount`. chunkFilesBySize :: Int -> Int64 -> [(FilePath, Int64)] -> [[(FilePath, Int64)]] chunkFilesBySize maxCount maxSize = takeFiles 0 [] . L.sortOn snd @@ -505,6 +538,19 @@ either pure (const $ pure WriteOk) result +-- | Retrieve the object at 'Address'. Handles any 404 response by converting to Maybe. +getObject' :: Address -> AWS (Maybe GetObjectResponse) +getObject' = + handle404 . send . f' A.getObject + +-- | Read contents of 'Address'. +-- +read :: Address -> AWS (Maybe Text) +read a = withRetries 5 $ do + r <- Stream.read a + z <- liftIO . sequence $ (\x -> runResourceT . runConduit $ x .| Conduit.sinkLbs) <$> r + pure $ fmap (T.concat . TL.toChunks . TL.decodeUtf8) z + -- pair of prefixs and keys getObjects :: Address -> AWS ([Key], [Key]) getObjects (Address (Bucket buck) (Key ky)) = @@ -550,6 +596,10 @@ list a = runConduit $ Stream.list a .| DC.consume +listRecursively :: Address -> AWS [Address] +listRecursively a = + runConduit $ Stream.listRecursively a .| DC.consume + download :: Address -> FilePath -> ExceptT DownloadError AWS () download = downloadWithMode Fail @@ -596,7 +646,7 @@ downloadWithRange a start end dest = withRetries 5 $ do -- Use a timeout of ten minutes. Arrivied at empirically. With a timeout of 5 -- minutes this was triggering too often. Want this to be the last resort. - res <- UnliftIO.timeout (10 * 60 * 1000 * 1000) $ do + res <- timeoutAWS (10 * 60 * 1000 * 1000) $ do r <- send $ f' A.getObject a & A.goRange .~ (Just $ bytesRange start end) @@ -636,6 +686,11 @@ downloadRecursive = downloadRecursiveWithMode Fail +createMultipartUpload :: Address -> AWS Text +createMultipartUpload a = do + mpu <- send $ f' A.createMultipartUpload a & A.cmuServerSideEncryption .~ Just sse + maybe (throwM . Invariant $ "MultipartUpload: missing 'UploadId'") pure (mpu ^. A.cmursUploadId) + listMultipartParts :: Address -> Text -> AWS [Part] listMultipartParts a uploadId = do let req = f' A.listParts a uploadId @@ -658,6 +713,8 @@ now <- liftIO getCurrentTime pure $ filter (filterNDays i now) mus +-- | Filter parts older than 7 days. +-- filterOld :: UTCTime -> MultipartUpload -> Bool filterOld = filterNDays 7 @@ -683,42 +740,13 @@ abortMultipart' a i = void . send $ f' A.abortMultipartUpload a i -listRecursively :: Address -> AWS [Address] -listRecursively a = - runConduit $ Stream.listRecursively a .| DC.consume - grantReadAccess :: Address -> ReadGrant -> AWS () grantReadAccess a g = void . send $ (f' P.putObjectACL a & P.poaGrantRead .~ Just (readGrant g)) -sync :: Address -> Address -> Int -> ExceptT SyncError AWS () -sync = - syncWithMode FailSync - -syncWithMode :: SyncMode -> Address -> Address -> Int -> ExceptT SyncError AWS () -syncWithMode mode source dest fork = do - e <- ask - void . firstT SyncError . ExceptT . liftIO $ - (consume (sinkQueue e (Stream.listRecursively source)) fork (worker source dest mode e)) - -worker :: Address -> Address -> SyncMode -> Env -> Address -> IO (Either SyncWorkerError ()) -worker input output mode env f = runExceptT . runAWST env SyncAws $ do - n <- maybe (throwE $ SyncInvariant input f) pure $ removeCommonPrefix input f - let out = withKey (// n) output - liftCopy = firstT SyncCopyError - cp = liftCopy $ copy f out - foldSyncMode - (ifM (lift $ exists out) (throwE $ OutputExists out) cp) - (liftCopy $ copyWithMode Overwrite f out) - (ifM (lift $ exists out) (pure ()) cp) - mode - tryIO :: MonadIO m => IO a -> m (Either IOError a) -tryIO = liftIO . CE.try - - - --- compat +tryIO = + liftIO . CE.try ifM :: Monad m => m Bool -> m a -> m a -> m a ifM p x y = diff --git a/src/Mismi/S3/Internal/Queue.hs b/src/Mismi/S3/Internal/Queue.hs --- a/src/Mismi/S3/Internal/Queue.hs +++ b/src/Mismi/S3/Internal/Queue.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} module Mismi.S3.Internal.Queue ( Queue , newQueue @@ -11,9 +12,17 @@ import Control.Concurrent.STM.TBQueue (TBQueue, newTBQueue, tryReadTBQueue, readTBQueue, writeTBQueue, isEmptyTBQueue) import GHC.Conc (atomically) +#if MIN_VERSION_stm(2,5,0) +import GHC.Natural (naturalFromInteger) +#endif import P +#if MIN_VERSION_stm(2,5,0) +import Prelude (toInteger) +#endif + + newtype Queue a = Queue { queue :: TBQueue a @@ -21,7 +30,12 @@ newQueue :: Int -> IO (Queue a) newQueue i = +#if MIN_VERSION_stm(2,5,0) + atomically $ Queue <$> newTBQueue (naturalFromInteger $ toInteger i) +#else atomically $ Queue <$> newTBQueue i +#endif + readQueue :: Queue a -> IO a readQueue = diff --git a/test/Test/IO/Mismi/S3/Control.hs b/test/Test/IO/Mismi/S3/Control.hs --- a/test/Test/IO/Mismi/S3/Control.hs +++ b/test/Test/IO/Mismi/S3/Control.hs @@ -14,14 +14,13 @@ import P import Test.Mismi (liftAWS, runAWSDefaultRegion) -import Test.Mismi.S3 (newAddress) +import Test.Mismi.S3 (newAddressAWS) prop_finalizer :: Property prop_finalizer = - withTests 10 . property . liftAWS $ do - a <- newAddress - + withTests 2 . property . liftAWS $ do r <- liftIO . runAWSDefaultRegion $ do + a <- newAddressAWS Unsafe.write a "" pure $ a diff --git a/test/Test/Mismi/S3.hs b/test/Test/Mismi/S3.hs --- a/test/Test/Mismi/S3.hs +++ b/test/Test/Mismi/S3.hs @@ -13,6 +13,7 @@ , createSmallFiles , files , newAddress + , newAddressAWS , newFilePath , addCleanupFinalizer , addPrintFinalizer @@ -94,14 +95,18 @@ fmap (\i -> withKey (// Key (name <> "-" <> (T.pack $ show i))) prefix) [1..n] newAddress :: PropertyT AWS Address -newAddress = do +newAddress = + lift newAddressAWS + +newAddressAWS :: AWS Address +newAddressAWS = do a <- liftIO $ do t <- Gen.sample genToken b <- testBucket u <- T.pack . U.toString <$> U.nextRandom pure $ Address b (Key . T.intercalate "/" $ ["mismi", u, unToken t]) - lift $ addCleanupFinalizer a - lift $ addPrintFinalizer a + addCleanupFinalizer a + addPrintFinalizer a pure $ a newFilePath :: PropertyT AWS FilePath