From 3d81917627188cdbd8809729ecde7e20e21a1a43 Mon Sep 17 00:00:00 2001
From: Eugen Wissner <belka@caraus.de>
Date: Sun, 17 Mar 2024 11:00:13 +0100
Subject: Collect hash during creating an archive

---
 src/Main.hs | 35 +++++++++++++++++++----------------
 1 file changed, 19 insertions(+), 16 deletions(-)

(limited to 'src')

diff --git a/src/Main.hs b/src/Main.hs
index 18cbbbf..fb3a814 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -49,7 +49,6 @@ import System.Process
     ( CmdSpec(..)
     , CreateProcess(..)
     , StdStream(..)
-    , callProcess
     , withCreateProcess
     , waitForProcess
     )
@@ -61,11 +60,13 @@ import System.Console.ANSI
     , ConsoleLayer(..)
     )
 import System.Directory (listDirectory, doesDirectoryExist, withCurrentDirectory, removeDirectoryRecursive)
-import Control.Monad (filterM)
+import Control.Monad (filterM, void)
 import Data.List (isPrefixOf, isSuffixOf, partition)
-import Conduit (runConduitRes, (.|), sourceFile)
+import Conduit (runConduitRes, (.|), yield)
 import Data.Functor ((<&>))
 import Data.Bifunctor (Bifunctor(..))
+import Data.Conduit.Tar (tarFilePath)
+import qualified Data.Conduit.Lzma as Lzma
 
 autoUpdatable :: [PackageDescription]
 autoUpdatable =
@@ -403,31 +404,33 @@ reuploadWithTemplate downloadTemplate commands packagePath version = do
             $ NonEmpty.last $ snd $ fromJust $ URI.uriPath uri'
         packagePathRelativeToCurrent = repository' </> Text.unpack packagePath
 
-    (checksum, relativeTarball') <- case commands of
+    (relativeTarball', checksum) <- case commands of
         [] -> do
             (downloadedFileName, checksum) <- download uri' packagePathRelativeToCurrent
-            pure (checksum, packagePathRelativeToCurrent </> downloadedFileName)
+            pure (packagePathRelativeToCurrent </> downloadedFileName, checksum)
         _ -> do
             changedArchiveRootName <- extractRemote uri' packagePathRelativeToCurrent
             let relativeTarball = packagePathRelativeToCurrent
                     </> fromMaybe downloadFileName changedArchiveRootName
             prepareSource relativeTarball
-            checksum <- liftIO $ runConduitRes $ sourceFile relativeTarball .| sinkHash
-
-            pure (checksum, relativeTarball)
 
     download' <- handleReupload relativeTarball' downloadFileName
     pure $ Package.Download download' checksum
   where
     name' = Text.pack $ takeBaseName $ Text.unpack packagePath
-    prepareSource tarballPath = do
-        let packedDirectory = dropExtension $ dropExtension tarballPath
-         in liftIO (traverse (defaultCreateProcess packedDirectory) commands)
-            >> liftIO
-                ( withCurrentDirectory (takeDirectory tarballPath)
-                $ callProcess "tar" ["Jcvf", takeFileName tarballPath, takeFileName packedDirectory]
-                )
-            >> liftIO (removeDirectoryRecursive packedDirectory)
+    prepareSource tarballPath =
+        liftIO (traverse (defaultCreateProcess tarballPath) commands)
+            >> liftIO (tarCompress tarballPath)
+            <* liftIO (removeDirectoryRecursive tarballPath)
+    tarCompress tarballPath =
+        let archiveBaseFilename = takeFileName tarballPath
+            appendTarExtension = (<.> "tar.xz")
+         in fmap (appendTarExtension tarballPath,)
+            $ withCurrentDirectory (takeDirectory tarballPath)
+            $ runConduitRes $ yield archiveBaseFilename
+            .| void tarFilePath
+            .| Lzma.compress Nothing
+            .| sinkFileAndHash (appendTarExtension archiveBaseFilename)
     handleReupload relativeTarball downloadFileName = do
         downloadURL' <- SlackBuilderT $ asks downloadURL
 
-- 
cgit v1.2.3