Support extracting gzip on the fly
Some checks failed
Build / audit (push) Successful in 14m44s
Build / test (push) Failing after 5m47s

This commit is contained in:
Eugen Wissner 2024-03-03 17:12:29 +01:00
parent 4c06ae274b
commit e5bde183a5
Signed by: belka
GPG Key ID: A27FDC1E8EE902C0
4 changed files with 41 additions and 13 deletions

View File

@ -18,7 +18,7 @@ module SlackBuilder.Download
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import qualified Data.ByteString as ByteString import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Char8 as Char8 import qualified Data.ByteString.Char8 as Char8
import Data.Foldable (traverse_) import Data.Foldable (find)
import Data.Map.Strict (Map) import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
import Data.Text (Text) import Data.Text (Text)
@ -30,7 +30,7 @@ import Control.Monad.Trans.Reader (asks)
import Control.Monad.IO.Class (MonadIO(liftIO)) import Control.Monad.IO.Class (MonadIO(liftIO))
import System.Directory (createDirectory) import System.Directory (createDirectory)
import System.IO (IOMode(..), withFile) import System.IO (IOMode(..), withFile)
import System.FilePath ((</>), (<.>), takeFileName, takeDirectory) import System.FilePath ((</>), (<.>), takeFileName, takeDirectory, stripExtension)
import System.Process import System.Process
( CreateProcess(..) ( CreateProcess(..)
, StdStream(..) , StdStream(..)
@ -70,6 +70,8 @@ import Data.Conduit.Tar (untar, FileInfo(..))
import Crypto.Hash (Digest, MD5, hashInit, hashFinalize, hashUpdate) import Crypto.Hash (Digest, MD5, hashInit, hashFinalize, hashUpdate)
import Data.Void (Void) import Data.Void (Void)
import qualified Data.Conduit.Lzma as Lzma 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 :: Text -> Text -> Map Text Text -> SlackBuilderT ()
updateSlackBuildVersion packagePath version additionalDownloads = do updateSlackBuildVersion packagePath version additionalDownloads = do
@ -221,19 +223,41 @@ cloneAndUpload repo tarballPath tagPrefix = do
>> uploadCommand localPath remoteArchivePath >> uploadCommand localPath remoteArchivePath
>> liftIO (runConduitRes go) <&> Just . (remoteResultURI,) >> 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 extractRemote uri' packagePath = do
repository' <- SlackBuilderT $ asks repository repository' <- SlackBuilderT $ asks repository
let localToRepository = repository' </> Text.unpack packagePath let localToRepository = repository' </> Text.unpack packagePath
traverse_ (runReq defaultHttpConfig . go localToRepository . fst) case useHttpsURI uri' of
$ useHttpsURI uri' Just (httpsURI, _httpsOptions) ->
runReq defaultHttpConfig $ go localToRepository httpsURI
Nothing -> throwM $ HttpsUrlExpected uri'
where where
go toTarget url' = reqBr GET url' NoReqBody mempty $ readResponse toTarget go toTarget url' = reqBr GET url' NoReqBody mempty $ readResponse toTarget
readResponse :: FilePath -> Response BodyReader -> IO () readResponse :: FilePath -> Response BodyReader -> IO (Maybe Text)
readResponse toTarget response = runConduitRes readResponse toTarget response = do
$ responseBodySource response let attachmentName
.| Lzma.decompress Nothing = 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) .| untar (withDecompressedFile toTarget)
pure $ Text.pack <$> attachmentDirectory
withDecompressedFile toTarget FileInfo{..} withDecompressedFile toTarget FileInfo{..}
| Char8.last filePath /= '/' = | Char8.last filePath /= '/' =
sinkFile (toTarget </> Char8.unpack filePath) sinkFile (toTarget </> Char8.unpack filePath)

View File

@ -16,8 +16,11 @@ import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Catch (MonadCatch(..), MonadThrow(..)) import Control.Monad.Catch (MonadCatch(..), MonadThrow(..))
import Control.Exception (Exception(..)) import Control.Exception (Exception(..))
import System.FilePath ((</>)) import System.FilePath ((</>))
import Text.URI (URI)
newtype SlackBuilderException = UpdaterNotFound Text data SlackBuilderException
= UpdaterNotFound Text
| HttpsUrlExpected URI
deriving Show deriving Show
instance Exception SlackBuilderException instance Exception SlackBuilderException

View File

@ -20,6 +20,7 @@ common dependencies
base >= 4.16 && < 5, base >= 4.16 && < 5,
bytestring ^>= 0.11.0, bytestring ^>= 0.11.0,
conduit ^>= 1.3.5, conduit ^>= 1.3.5,
conduit-extra ^>= 1.3,
http-client ^>= 0.7, http-client ^>= 0.7,
containers ^>= 0.6, containers ^>= 0.6,
cryptonite >= 0.30, cryptonite >= 0.30,

View File

@ -61,7 +61,7 @@ import System.Console.ANSI
, ConsoleLayer(..) , ConsoleLayer(..)
) )
import System.Directory (listDirectory, doesDirectoryExist, withCurrentDirectory, removeDirectoryRecursive) import System.Directory (listDirectory, doesDirectoryExist, withCurrentDirectory, removeDirectoryRecursive)
import Control.Monad (filterM) import Control.Monad (filterM, void)
import Data.List (isPrefixOf, isSuffixOf, partition) import Data.List (isPrefixOf, isSuffixOf, partition)
import Conduit (runConduitRes, (.|), sourceFile) import Conduit (runConduitRes, (.|), sourceFile)
import Data.Functor ((<&>)) import Data.Functor ((<&>))
@ -407,7 +407,7 @@ reuploadWithTemplate downloadTemplate commands packagePath version = do
relativeTarball = Text.unpack $ packagePath <> "/" <> downloadFileName relativeTarball = Text.unpack $ packagePath <> "/" <> downloadFileName
tarball = repository' </> relativeTarball tarball = repository' </> relativeTarball
extractRemote uri' packagePath void $ extractRemote uri' packagePath
download' <- handleReupload relativeTarball downloadFileName download' <- handleReupload relativeTarball downloadFileName
checksum <- liftIO $ runConduitRes $ sourceFile tarball .| sinkHash checksum <- liftIO $ runConduitRes $ sourceFile tarball .| sinkHash