Collect hash during creating an archive

lib/SlackBuilder/Download.hs

@@ -2,6 +2,7 @@
    v. 2.0. If a copy of the MPL was not distributed with this file, You can
    obtain one at https://mozilla.org/MPL/2.0/. -}
 
+-- | Contains routines for downloading, cloning and uploading sources.
 module SlackBuilder.Download
     ( cloneAndUpload
     , extractRemote
@@ -10,6 +11,7 @@ module SlackBuilder.Download
     , hostedSources
     , remoteFileExists
     , responseBodySource
+    , sinkFileAndHash
     , sinkHash
     , updateSlackBuildVersion
     , uploadCommand
@@ -66,7 +68,7 @@ import Conduit
     , (.|)
     , ZipSink(..)
     , await
-    , sourceFile
+    , sourceFile, MonadResource
     )
 import Data.Conduit.Tar (untar, FileInfo(..))
 import Crypto.Hash (Digest, MD5, hashInit, hashFinalize, hashUpdate)
@@ -244,9 +246,14 @@ download uri packagePath = runReq defaultHttpConfig go
             target = packagePath </> fromMaybe downloadFileName attachmentName
         digest <- runConduitRes
             $ responseBodySource response
-            .| getZipSink (ZipSink (sinkFile target) *> ZipSink sinkHash)
+            .| sinkFileAndHash target
         pure (targetFileName, digest)
 
+-- | Writes a file to the destination path and accumulates its MD5 checksum.
+sinkFileAndHash :: MonadResource m => FilePath -> ConduitT ByteString Void m (Digest MD5)
+sinkFileAndHash target = getZipSink
+    $ ZipSink (sinkFile target) *> ZipSink sinkHash
+
 -- | Downloads a compressed tar archive and extracts its contents on the fly to
 -- a directory.
 --

lib/SlackBuilder/Package.hs

@@ -2,6 +2,7 @@
    v. 2.0. If a copy of the MPL was not distributed with this file, You can
    obtain one at https://mozilla.org/MPL/2.0/. -}
 
+-- | Contains data describing packages and how they are should be updated,
 module SlackBuilder.Package
     ( DownloadPlaceholder(..)
     , Download(..)

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
+    prepareSource tarballPath =
-        let packedDirectory = dropExtension $ dropExtension tarballPath
+        liftIO (traverse (defaultCreateProcess tarballPath) commands)
-         in liftIO (traverse (defaultCreateProcess packedDirectory) commands)
+            >> liftIO (tarCompress tarballPath)
-            >> liftIO
+            <* liftIO (removeDirectoryRecursive tarballPath)
-                ( withCurrentDirectory (takeDirectory tarballPath)
+    tarCompress tarballPath =
-                $ callProcess "tar" ["Jcvf", takeFileName tarballPath, takeFileName packedDirectory]
+        let archiveBaseFilename = takeFileName tarballPath
-                )
+            appendTarExtension = (<.> "tar.xz")
-            >> liftIO (removeDirectoryRecursive packedDirectory)
+         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