Merge pull request #3655 from commercialhaskell/3647-uncompressed-tarballs

Support .tar archives #3647

Author: snoyberg

ChangeLog.md

@@ -10,6 +10,11 @@ Behaviour changes:
 
 Other enhancements:
 
+* In addition to supporting `.tar.gz` and `.zip` files as remote archives,
+  plain `.tar` files are now accepted too. This will additionally help with
+  cases where HTTP servers mistakenly set the transfer encoding to `gzip`. See
+  [#3647](https://github.com/commercialhaskell/stack/issues/3647).
+
 Bug fixes:
 
 * For versions of Cabal before 1.24, ensure that the dependencies of

src/Stack/PackageLocation.hs

@@ -109,25 +109,34 @@ resolveSinglePackageLocation projRoot (PLArchive (Archive url subdir msha)) = do
 
         let fp = toFilePath file
 
-        let tryTar = do
-                logDebug $ "Trying to untar " <> T.pack fp
-                liftIO $ withBinaryFile fp ReadMode $ \h -> do
-                    lbs <- L.hGetContents h
-                    let entries = Tar.read $ GZip.decompress lbs
-                    Tar.unpack (toFilePath dirTmp) entries
-            tryZip = do
+        withBinaryFile fp ReadMode $ \h -> do
+          -- Share a single file read among all of the different
+          -- parsing attempts. We're not worried about unbounded
+          -- memory usage, as we will detect almost immediately if
+          -- this is the wrong type of file.
+          lbs <- liftIO $ L.hGetContents h
+
+          let tryTargz = do
+                logDebug $ "Trying to ungzip/untar " <> T.pack fp
+                let entries = Tar.read $ GZip.decompress lbs
+                liftIO $ Tar.unpack (toFilePath dirTmp) entries
+              tryZip = do
                 logDebug $ "Trying to unzip " <> T.pack fp
-                archive <- fmap Zip.toArchive $ liftIO $ L.readFile fp
+                let archive = Zip.toArchive lbs
                 liftIO $  Zip.extractFilesFromArchive [Zip.OptDestination
                                                        (toFilePath dirTmp)] archive
-            err = throwM $ UnableToExtractArchive url file
+              tryTar = do
+                logDebug $ "Trying to untar (no ungzip) " <> T.pack fp
+                let entries = Tar.read lbs
+                liftIO $ Tar.unpack (toFilePath dirTmp) entries
+              err = throwM $ UnableToExtractArchive url file
 
-            catchAnyLog goodpath handler =
-                catchAny goodpath $ \e -> do
-                    logDebug $ "Got exception: " <> T.pack (show e)
-                    handler
+              catchAnyLog goodpath handler =
+                  catchAny goodpath $ \e -> do
+                      logDebug $ "Got exception: " <> T.pack (show e)
+                      handler
 
-        tryTar `catchAnyLog` tryZip `catchAnyLog` err
+          tryTargz `catchAnyLog` tryZip `catchAnyLog` tryTar `catchAnyLog` err
         renameDir dirTmp dir
 
     x <- listDir dir