Support extracting gzip on the fly

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
+    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)

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

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,

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