From e8de003aeae7f58d1c7e98cdb4a3c299ea24385a Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Thu, 14 Dec 2017 10:23:30 +0200
Subject: [PATCH 1/2] Support .tar archives #3647

---
 ChangeLog.md                 |  5 +++++
 src/Stack/PackageLocation.hs | 12 +++++++++---
 2 files changed, 14 insertions(+), 3 deletions(-)

diff --git a/ChangeLog.md b/ChangeLog.md
index 9e13aebe43..da807f195e 100644
--- a/ChangeLog.md
+++ b/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
diff --git a/src/Stack/PackageLocation.hs b/src/Stack/PackageLocation.hs
index d6f9e7127b..d59c004dfa 100644
--- a/src/Stack/PackageLocation.hs
+++ b/src/Stack/PackageLocation.hs
@@ -109,8 +109,8 @@ resolveSinglePackageLocation projRoot (PLArchive (Archive url subdir msha)) = do
 
         let fp = toFilePath file
 
-        let tryTar = do
-                logDebug $ "Trying to untar " <> T.pack fp
+        let tryTargz = do
+                logDebug $ "Trying to ungzip/untar " <> T.pack fp
                 liftIO $ withBinaryFile fp ReadMode $ \h -> do
                     lbs <- L.hGetContents h
                     let entries = Tar.read $ GZip.decompress lbs
@@ -120,6 +120,12 @@ resolveSinglePackageLocation projRoot (PLArchive (Archive url subdir msha)) = do
                 archive <- fmap Zip.toArchive $ liftIO $ L.readFile fp
                 liftIO $  Zip.extractFilesFromArchive [Zip.OptDestination
                                                        (toFilePath dirTmp)] archive
+            tryTar = do
+                logDebug $ "Trying to untar (no ungzip) " <> T.pack fp
+                liftIO $ withBinaryFile fp ReadMode $ \h -> do
+                    lbs <- L.hGetContents h
+                    let entries = Tar.read lbs
+                    Tar.unpack (toFilePath dirTmp) entries
             err = throwM $ UnableToExtractArchive url file
 
             catchAnyLog goodpath handler =
@@ -127,7 +133,7 @@ resolveSinglePackageLocation projRoot (PLArchive (Archive url subdir msha)) = 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

From 563a5f8ef240cae3fa1a9864835cd7682f99be1a Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Thu, 14 Dec 2017 11:25:49 +0200
Subject: [PATCH 2/2] Share file read for archives

---
 src/Stack/PackageLocation.hs | 39 +++++++++++++++++++-----------------
 1 file changed, 21 insertions(+), 18 deletions(-)

diff --git a/src/Stack/PackageLocation.hs b/src/Stack/PackageLocation.hs
index d59c004dfa..c0ba0f3d7d 100644
--- a/src/Stack/PackageLocation.hs
+++ b/src/Stack/PackageLocation.hs
@@ -109,31 +109,34 @@ resolveSinglePackageLocation projRoot (PLArchive (Archive url subdir msha)) = do
 
         let fp = toFilePath file
 
-        let tryTargz = 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
-                liftIO $ withBinaryFile fp ReadMode $ \h -> do
-                    lbs <- L.hGetContents h
-                    let entries = Tar.read $ GZip.decompress lbs
-                    Tar.unpack (toFilePath dirTmp) entries
-            tryZip = do
+                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
-            tryTar = do
+              tryTar = do
                 logDebug $ "Trying to untar (no ungzip) " <> T.pack fp
-                liftIO $ withBinaryFile fp ReadMode $ \h -> do
-                    lbs <- L.hGetContents h
-                    let entries = Tar.read lbs
-                    Tar.unpack (toFilePath dirTmp) entries
-            err = throwM $ UnableToExtractArchive url file
+                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
 
-        tryTargz `catchAnyLog` tryZip `catchAnyLog` tryTar `catchAnyLog` err
+          tryTargz `catchAnyLog` tryZip `catchAnyLog` tryTar `catchAnyLog` err
         renameDir dirTmp dir
 
     x <- listDir dir