Support extracting gzip on the fly

2 files changed, 38 insertions, 11 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