mismi-s3: Multi-thread downloadRecursive

mismi-s3/src/Mismi/S3/Commands.hs

@@ -619,6 +619,12 @@ hoistDownloadError e =
       throwM $ DestinationNotDirectory f
     DownloadInvariant a b ->
       throwM $ Invariant (renderDownloadError $ DownloadInvariant a b)
+    DownloadAws a ->
+      throwM a
+    DownloadRunError (WorkerError a) ->
+      throwM a
+    DownloadRunError (BlowUpError a) ->
+      throwM a
     MultipartError (WorkerError a) ->
       throwM a
     MultipartError (BlowUpError a) ->
@@ -700,15 +706,17 @@ downloadRecursiveWithMode mode src dest = do
     Left _ -> pure ()
     Right st -> unless (isDirectory st) . left $ DownloadDestinationNotDirectory dest
   -- Real business starts here.
-  addrs <- lift $ listRecursively src
-  mapM_ drWorker addrs
+  e <- ask
+  bimapEitherT DownloadRunError id . void . newEitherT . liftIO $
+    (consume (sinkQueue e (listRecursively' src)) 1 (drWorker e))
   where
-    drWorker :: Address -> EitherT DownloadError AWS ()
-    drWorker addr = do
+    drWorker :: Env -> Address -> IO (Either DownloadError ())
+    drWorker env addr = runEitherT . runAWST env DownloadAws $ do
       fpdest <- hoistMaybe (DownloadInvariant addr src) $
                     ((</>) dest) . T.unpack . unKey <$> removeCommonPrefix src addr
       downloadWithMode mode addr fpdest
 
+
 downloadRecursive :: Address -> FilePath -> EitherT DownloadError AWS ()
 downloadRecursive =
   downloadRecursiveWithMode Fail

mismi-s3/src/Mismi/S3/Data.hs

@@ -129,9 +129,13 @@ data DownloadError =
   | DownloadDestinationExists FilePath
   | DownloadDestinationNotDirectory FilePath
   | DownloadInvariant Address Address
+  | DownloadAws Error
+  | DownloadRunError (RunError DownloadError)
   | MultipartError (RunError Error)
   deriving Show
 
+instance Exception DownloadError
+
 renderDownloadError :: DownloadError -> Text
 renderDownloadError d =
   case d of
@@ -145,6 +149,10 @@ renderDownloadError d =
       "Remove common prefix invariant: " <>
       "[" <> addressToText b <> "] is not a common prefix of " <>
       "[" <> addressToText a <> "]"
+    DownloadAws e ->
+      "AWS failure during 'download': " <> renderError e
+    DownloadRunError r ->
+      "Download error: " <> renderRunError r renderDownloadError
     MultipartError r ->
       "Multipart download error: " <> renderRunError r renderError