mismi-s3 0.0.2 → 0.0.3
raw patch · 6 files changed
+144/−92 lines, 6 filesdep −unliftiodep ~containersdep ~mismi-coredep ~mismi-core-test
Dependencies removed: unliftio
Dependency ranges changed: containers, mismi-core, mismi-core-test, mismi-p, mismi-s3-core, mismi-s3-core-test, stm
Files
- CHANGELOG.md +6/−0
- mismi-s3.cabal +23/−23
- src/Mismi/S3/Commands.hs +90/−62
- src/Mismi/S3/Internal/Queue.hs +14/−0
- test/Test/IO/Mismi/S3/Control.hs +3/−4
- test/Test/Mismi/S3.hs +8/−3
CHANGELOG.md view
@@ -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`
mismi-s3.cabal view
@@ -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
src/Mismi/S3/Commands.hs view
@@ -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 =
src/Mismi/S3/Internal/Queue.hs view
@@ -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 =
test/Test/IO/Mismi/S3/Control.hs view
@@ -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
test/Test/Mismi/S3.hs view
@@ -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