From c8643a2fd4e8e81fde467c3b00eba606ebb2e761 Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Sun, 28 Jan 2024 13:35:53 +0100 Subject: [PATCH] Remove the source directory after repackaing --- lib/SlackBuilder/Download.hs | 25 ++++++++++++++- src/Main.hs | 61 ++++++++++++------------------------ 2 files changed, 44 insertions(+), 42 deletions(-) diff --git a/lib/SlackBuilder/Download.hs b/lib/SlackBuilder/Download.hs index 3e22b22..bf89a40 100644 --- a/lib/SlackBuilder/Download.hs +++ b/lib/SlackBuilder/Download.hs @@ -4,7 +4,7 @@ module SlackBuilder.Download ( cloneAndUpload - , cloneAndArchive + , extractRemote , commit , download , hostedSources @@ -17,6 +17,8 @@ module SlackBuilder.Download import Data.ByteString (ByteString) import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 as Char8 +import Data.Foldable (traverse_) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Text (Text) @@ -26,6 +28,7 @@ import SlackBuilder.Config import SlackBuilder.Trans import Control.Monad.Trans.Reader (asks) import Control.Monad.IO.Class (MonadIO(liftIO)) +import System.Directory (createDirectory) import System.IO (IOMode(..), withFile) import System.FilePath ((), (<.>), takeFileName, takeDirectory) import System.Process @@ -63,8 +66,10 @@ import Conduit , await , sourceFile ) +import Data.Conduit.Tar (untar, FileInfo(..)) import Crypto.Hash (Digest, MD5, hashInit, hashFinalize, hashUpdate) import Data.Void (Void) +import qualified Data.Conduit.Lzma as Lzma updateSlackBuildVersion :: Text -> Text -> Map Text Text -> SlackBuilderT () updateSlackBuildVersion packagePath version additionalDownloads = do @@ -215,3 +220,21 @@ cloneAndUpload repo tarballPath tagPrefix = do in cloneAndArchive repo tarballPath tagPrefix >> uploadCommand localPath remoteArchivePath >> liftIO (runConduitRes go) <&> Just . (remoteResultURI,) + +extractRemote :: URI -> Text -> SlackBuilderT () +extractRemote uri' packagePath = do + repository' <- SlackBuilderT $ asks repository + let localToRepository = repository' Text.unpack packagePath + traverse_ (runReq defaultHttpConfig . go localToRepository . fst) + $ useHttpsURI uri' + where + go toTarget url' = reqBr GET url' NoReqBody mempty $ readResponse toTarget + readResponse :: FilePath -> Response BodyReader -> IO () + readResponse toTarget response = runConduitRes + $ responseBodySource response + .| Lzma.decompress Nothing + .| untar (withDecompressedFile toTarget) + withDecompressedFile toTarget FileInfo{..} + | Char8.last filePath /= '/' = + sinkFile (toTarget Char8.unpack filePath) + | otherwise = liftIO (createDirectory (toTarget Char8.unpack filePath)) diff --git a/src/Main.hs b/src/Main.hs index 899cfd8..24f52c6 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -6,7 +6,6 @@ module Main ( main ) where -import qualified Data.ByteString.Char8 as Char8 import Data.Char (isNumber) import Control.Applicative (Applicative(liftA2)) import Data.List.NonEmpty (NonEmpty(..)) @@ -31,9 +30,9 @@ import SlackBuilder.Package (Package(..)) import qualified SlackBuilder.Package as Package import Text.URI (URI(..), mkURI) import Text.URI.QQ (uri) -import Data.Foldable (Foldable(..), for_, find, traverse_) +import Data.Foldable (Foldable(..), for_, find) import qualified Text.URI as URI -import System.FilePath ((), (<.>), dropExtension, takeBaseName, makeRelative, splitFileName) +import System.FilePath ((), (<.>), dropExtension, takeBaseName, makeRelative, splitFileName, takeDirectory, takeFileName) import SlackBuilder.Info import Text.Megaparsec (parse, errorBundlePretty) import GHC.Records (HasField(..)) @@ -52,21 +51,10 @@ import System.Console.ANSI , Color(..) , ConsoleLayer(..) ) -import System.Directory (listDirectory, doesDirectoryExist, createDirectory) +import System.Directory (listDirectory, doesDirectoryExist, withCurrentDirectory, removeDirectoryRecursive) import Control.Monad (filterM) import Data.List (isPrefixOf, isSuffixOf, partition) -import Network.HTTP.Client (Response, BodyReader) -import Network.HTTP.Req - ( runReq - , defaultHttpConfig - , useHttpsURI - , GET(..) - , reqBr - , NoReqBody(..) - ) -import Conduit (runConduitRes, (.|), sinkFile, sourceFile) -import Data.Conduit.Tar (untar, FileInfo(..)) -import qualified Data.Conduit.Lzma as Lzma +import Conduit (runConduitRes, (.|), sourceFile) autoUpdatable :: [Package] autoUpdatable = @@ -407,11 +395,11 @@ reuploadWithTemplate downloadTemplate commands packagePath version = do uri' <- liftIO $ Package.renderDownloadWithVersion downloadTemplate version let downloadFileName = URI.unRText $ NonEmpty.last $ snd $ fromJust $ URI.uriPath uri' - relativeTarball = packagePath <> "/" <> downloadFileName - tarball = repository' Text.unpack relativeTarball + relativeTarball = Text.unpack $ packagePath <> "/" <> downloadFileName + tarball = repository' relativeTarball - extractRemote uri' - download' <- handleReupload (Text.unpack relativeTarball) downloadFileName + extractRemote uri' packagePath + download' <- handleReupload relativeTarball downloadFileName checksum <- liftIO $ runConduitRes $ sourceFile tarball .| sinkHash pure $ Package.Download download' checksum @@ -419,18 +407,22 @@ reuploadWithTemplate downloadTemplate commands packagePath version = do name' = Text.pack $ takeBaseName $ Text.unpack packagePath handleReupload relativeTarball downloadFileName = do repository' <- SlackBuilderT $ asks repository + downloadURL' <- SlackBuilderT $ asks downloadURL + + liftIO $ putStrLn $ "Upload the source tarball " <> relativeTarball case commands of - [] -> uploadTarball relativeTarball downloadFileName + [] -> uploadCommand relativeTarball ("/" <> name') _ -> let tarballPath = repository' relativeTarball - packedDirectory = takeBaseName $ dropExtension tarballPath + packedDirectory = dropExtension $ dropExtension tarballPath in liftIO (traverse (defaultCreateProcess packedDirectory) commands) - >> liftIO (callProcess "tar" ["Jcvf", tarballPath, packedDirectory]) - >> uploadTarball relativeTarball downloadFileName - uploadTarball relativeTarball downloadFileName - = liftIO (putStrLn $ "Upload the source tarball " <> relativeTarball) - >> uploadCommand relativeTarball ("/" <> name') - >> liftIO (mkURI $ "https://download.dlackware.com/hosted-sources/" <> name' <> "/" <> downloadFileName) + >> liftIO + ( withCurrentDirectory (takeDirectory tarballPath) + $ callProcess "tar" ["Jcvf", takeFileName tarballPath, takeFileName packedDirectory] + ) + >> liftIO (removeDirectoryRecursive packedDirectory) + >> uploadCommand relativeTarball ("/" <> name') + liftIO $ mkURI $ downloadURL' <> "/" <> name' <> "/" <> downloadFileName defaultCreateProcess cwd' cmdSpec = flip withCreateProcess (const . const . const waitForProcess) $ CreateProcess @@ -450,19 +442,6 @@ reuploadWithTemplate downloadTemplate commands packagePath version = do , child_user = Nothing , child_group = Nothing } - extractRemote :: URI -> SlackBuilderT () - extractRemote uri' = traverse_ (runReq defaultHttpConfig . go . fst) - $ useHttpsURI uri' - go uri' = reqBr GET uri' NoReqBody mempty readResponse - readResponse :: Response BodyReader -> IO () - readResponse response = runConduitRes - $ responseBodySource response - .| Lzma.decompress Nothing - .| untar withDecompressedFile - withDecompressedFile FileInfo{..} - | Char8.last filePath /= '/' = - sinkFile (Char8.unpack filePath) - | otherwise = liftIO (createDirectory (Char8.unpack filePath)) updatePackage :: Package -> Text -> PackageInfo -> SlackBuilderT () updatePackage Package{..} version info = do