From e5bde183a5a44693a7d3cde72e8b40986ea03fad Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Sun, 3 Mar 2024 17:12:29 +0100 Subject: [PATCH] Support extracting gzip on the fly --- lib/SlackBuilder/Download.hs | 44 ++++++++++++++++++++++++++++-------- lib/SlackBuilder/Trans.hs | 5 +++- slackbuilder.cabal | 1 + src/Main.hs | 4 ++-- 4 files changed, 41 insertions(+), 13 deletions(-) diff --git a/lib/SlackBuilder/Download.hs b/lib/SlackBuilder/Download.hs index bf89a40..50eaff1 100644 --- a/lib/SlackBuilder/Download.hs +++ b/lib/SlackBuilder/Download.hs @@ -18,7 +18,7 @@ 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.Foldable (find) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Text (Text) @@ -30,7 +30,7 @@ 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.FilePath ((), (<.>), takeFileName, takeDirectory, stripExtension) import System.Process ( CreateProcess(..) , StdStream(..) @@ -70,6 +70,8 @@ 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 +import qualified Data.Conduit.Zlib as Zlib +import Control.Monad.Catch (MonadThrow(..)) updateSlackBuildVersion :: Text -> Text -> Map Text Text -> SlackBuilderT () updateSlackBuildVersion packagePath version additionalDownloads = do @@ -221,19 +223,41 @@ cloneAndUpload repo tarballPath tagPrefix = do >> uploadCommand localPath remoteArchivePath >> liftIO (runConduitRes go) <&> Just . (remoteResultURI,) -extractRemote :: URI -> Text -> SlackBuilderT () +-- | Downloads a compressed tar archive and extracts its contents on the fly to +-- a directory. +-- +-- If the download contains the disposition header and the attachment type was +-- recognized as tar archive, returns the attachment name from the +-- disposition header without the extension. So if the disposition header +-- is "attachment; filename=package-1.2.3.tar.gz", returns "package-1.2.3". +extractRemote :: URI -> Text -> SlackBuilderT (Maybe Text) extractRemote uri' packagePath = do repository' <- SlackBuilderT $ asks repository let localToRepository = repository' Text.unpack packagePath - traverse_ (runReq defaultHttpConfig . go localToRepository . fst) - $ useHttpsURI uri' + case useHttpsURI uri' of + Just (httpsURI, _httpsOptions) -> + runReq defaultHttpConfig $ go localToRepository httpsURI + Nothing -> throwM $ HttpsUrlExpected 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) + readResponse :: FilePath -> Response BodyReader -> IO (Maybe Text) + readResponse toTarget response = do + let attachmentName + = fmap (Char8.unpack . snd . Char8.breakEnd (== '=') . snd) + $ find ((== "Content-Disposition") . fst) + $ responseHeaders response + (decompress, attachmentDirectory) = + case attachmentName of + Just attachmentName' + | Just directoryName' <- stripExtension ".tar.gz" attachmentName' -> + (Zlib.ungzip, Just directoryName') + | Just directoryName' <- stripExtension ".tar.xz" attachmentName' -> + (Lzma.decompress Nothing, Just directoryName') + _ -> (pure (), Nothing) + runConduitRes $ responseBodySource response + .| decompress + .| untar (withDecompressedFile toTarget) + pure $ Text.pack <$> attachmentDirectory withDecompressedFile toTarget FileInfo{..} | Char8.last filePath /= '/' = sinkFile (toTarget Char8.unpack filePath) diff --git a/lib/SlackBuilder/Trans.hs b/lib/SlackBuilder/Trans.hs index 4ee3668..8d1d5b6 100644 --- a/lib/SlackBuilder/Trans.hs +++ b/lib/SlackBuilder/Trans.hs @@ -16,8 +16,11 @@ import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Catch (MonadCatch(..), MonadThrow(..)) import Control.Exception (Exception(..)) import System.FilePath (()) +import Text.URI (URI) -newtype SlackBuilderException = UpdaterNotFound Text +data SlackBuilderException + = UpdaterNotFound Text + | HttpsUrlExpected URI deriving Show instance Exception SlackBuilderException diff --git a/slackbuilder.cabal b/slackbuilder.cabal index 3d1bc53..c712acb 100644 --- a/slackbuilder.cabal +++ b/slackbuilder.cabal @@ -20,6 +20,7 @@ common dependencies base >= 4.16 && < 5, bytestring ^>= 0.11.0, conduit ^>= 1.3.5, + conduit-extra ^>= 1.3, http-client ^>= 0.7, containers ^>= 0.6, cryptonite >= 0.30, diff --git a/src/Main.hs b/src/Main.hs index 900891e..92b27f4 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -61,7 +61,7 @@ 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 Data.Functor ((<&>)) @@ -407,7 +407,7 @@ reuploadWithTemplate downloadTemplate commands packagePath version = do relativeTarball = Text.unpack $ packagePath <> "/" <> downloadFileName tarball = repository' relativeTarball - extractRemote uri' packagePath + void $ extractRemote uri' packagePath download' <- handleReupload relativeTarball downloadFileName checksum <- liftIO $ runConduitRes $ sourceFile tarball .| sinkHash