YAML config: support Zip archives

Instead of assuming a URL is a tarball based on its filename extension,
we can try to various archive formats until we give up. Added exception
UnableToExtractArchive.

NOTE: This changes filenames after .stack-work/downloads, since we
should not give an arbitrary archive the extension '.tar.gz'. Instead,
it shall be '.http-archive'.

Suggested-by: Michael Sloan <mgsloan@gmail.com>

doc/yaml_configuration.md

@@ -36,7 +36,7 @@ packages:
   - .
 ```
 
-However, it supports three other location types: an HTTP URL referring to a tarball that can be downloaded, and information on a Git or Mercurial (since 0.1.10.0) repo to clone, together with this SHA1 commit. For example:
+However, it supports three other location types: an HTTP URL referring to a tarball or a zip that can be downloaded, and information on a Git or Mercurial (since 0.1.10.0) repo to clone, together with this SHA1 commit. For example:
 
 ```yaml
 packages:
@@ -75,6 +75,16 @@ packages:
   - wai
 ```
 
+Instead of using Git to clone from Github, it is also possible to use the 'Download commit as Zip' feature of the website. For example:
+
+```yaml
+packages:
+- location: http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip
+  subdirs:
+  - auto-update
+  - wai
+```
+
 ### extra-deps
 
 This is a list of package identifiers for additional packages from upstream to

src/Stack/Config.hs

@@ -33,6 +33,7 @@ module Stack.Config
   ) where
 
 import qualified Codec.Archive.Tar as Tar
+import qualified Codec.Archive.Zip as Zip
 import qualified Codec.Compression.GZip as GZip
 import           Control.Applicative
 import           Control.Arrow ((***))
@@ -530,14 +531,14 @@ resolvePackageLocation _ projRoot (PLFilePath fp) = resolveDir projRoot fp
 resolvePackageLocation menv projRoot (PLRemote url remotePackageType) = do
     workDir <- getWorkDir
     let nameBeforeHashing = case remotePackageType of
-            RPTHttpTarball -> url
+            RPTHttp        -> url
             RPTGit commit  -> T.unwords [url, commit]
             RPTHg  commit  -> T.unwords [url, commit, "hg"]
         name = T.unpack $ decodeUtf8 $ B16.encode $ SHA256.hash $ encodeUtf8 nameBeforeHashing
         root = projRoot </> workDir </> $(mkRelDir "downloaded")
         fileExtension = case remotePackageType of
-            RPTHttpTarball -> ".tar.gz"
-            _              -> ".unused"
+            RPTHttp -> ".http-archive"
+            _       -> ".unused"
 
     fileRel <- parseRelFile $ name ++ fileExtension
     dirRel <- parseRelDir name
@@ -564,30 +565,44 @@ resolvePackageLocation menv projRoot (PLRemote url remotePackageType) = do
                       " exists within " <> url)
 
         case remotePackageType of
-            RPTHttpTarball -> do
+            RPTHttp -> do
+                let fp = toFilePath file
                 req <- parseUrl $ T.unpack url
                 _ <- download req file
 
-                liftIO $ withBinaryFile (toFilePath file) ReadMode $ \h -> do
-                    lbs <- L.hGetContents h
-                    let entries = Tar.read $ GZip.decompress lbs
-                    Tar.unpack (toFilePath dirTmp) entries
+                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 fp entries
+                    tryZip = do
+                        $logDebug $ "Trying to unzip " <> T.pack fp
+                        archive <- fmap Zip.toArchive $ liftIO $ L.readFile fp
+                        liftIO $  Zip.extractFilesFromArchive [Zip.OptDestination
+                                                               (toFilePath dirTmp)] archive
+                    err = throwM $ UnableToExtractArchive url file
+
+                    catchAllLog goodpath handler =
+                        catchAll goodpath $ \e -> do
+                            $logDebug $ "Got exception: " <> T.pack (show e)
+                            handler
+
+                tryTar `catchAllLog` tryZip `catchAllLog` err
 
             RPTGit commit -> cloneAndExtract "git" ["reset", "--hard"] commit
             RPTHg  commit -> cloneAndExtract "hg"  ["update", "-C"]    commit
 
         renameDir dirTmp dir
 
     case remotePackageType of
-        RPTHttpTarball -> do
-            x <- listDirectory dir
-            case x of
-                ([dir'], []) -> return dir'
-                (dirs, files) -> do
-                    removeFileIfExists file
-                    removeTreeIfExists dir
-                    throwM $ UnexpectedTarballContents dirs files
-
+        RPTHttp -> do x <- listDirectory dir
+                      case x of
+                          ([dir'], []) -> return dir'
+                          (dirs, files) -> do
+                              removeFileIfExists file
+                              removeTreeIfExists dir
+                              throwM $ UnexpectedArchiveContents dirs files
         _ -> return dir
 
 -- | Get the stack root, e.g. ~/.stack

src/Stack/Types/Config.hs

@@ -572,14 +572,14 @@ data PackageLocation
     deriving Show
 
 data RemotePackageType
-    = RPTHttpTarball
+    = RPTHttp
     | RPTGit Text -- ^ Commit
     | RPTHg  Text -- ^ Commit
     deriving Show
 
 instance ToJSON PackageLocation where
     toJSON (PLFilePath fp) = toJSON fp
-    toJSON (PLRemote t RPTHttpTarball) = toJSON t
+    toJSON (PLRemote t RPTHttp) = toJSON t
     toJSON (PLRemote x (RPTGit y)) = toJSON $ T.unwords ["git", x, y]
     toJSON (PLRemote x (RPTHg  y)) = toJSON $ T.unwords ["hg",  x, y]
 
@@ -592,8 +592,9 @@ instance FromJSON (PackageLocation, [JSONWarning]) where
         file t = pure $ PLFilePath $ T.unpack t
         http t =
             case parseUrl $ T.unpack t of
-                Left _ -> mzero
-                Right _ -> return $ PLRemote t RPTHttpTarball
+                Left  _ -> mzero
+                Right _ -> return $ PLRemote t RPTHttp
+
         git = withObjectWarnings "PackageGitLocation" $ \o -> PLRemote
             <$> o ..: "git"
             <*> (RPTGit <$> o ..: "commit")
@@ -1073,7 +1074,8 @@ data ConfigException
   = ParseConfigFileException (Path Abs File) ParseException
   | ParseResolverException Text
   | NoProjectConfigFound (Path Abs Dir) (Maybe Text)
-  | UnexpectedTarballContents [Path Abs Dir] [Path Abs File]
+  | UnexpectedArchiveContents [Path Abs Dir] [Path Abs File]
+  | UnableToExtractArchive Text (Path Abs File)
   | BadStackVersionException VersionRange
   | NoMatchingSnapshot [SnapName]
   | ResolverMismatch Resolver Text
@@ -1103,13 +1105,17 @@ instance Show ConfigException where
             Nothing -> ""
             Just cmd -> "\nRecommended action: stack " ++ T.unpack cmd
         ]
-    show (UnexpectedTarballContents dirs files) = concat
-        [ "When unpacking a tarball specified in your stack.yaml file, "
+    show (UnexpectedArchiveContents dirs files) = concat
+        [ "When unpacking an archive specified in your stack.yaml file, "
         , "did not find expected contents. Expected: a single directory. Found: "
         , show ( map (toFilePath . dirname) dirs
                , map (toFilePath . filename) files
                )
         ]
+    show (UnableToExtractArchive url file) = concat
+        [ "Archive extraction failed. We support tarballs and zip, couldn't handle the following URL, "
+        , T.unpack url, " downloaded to the file ", toFilePath $ filename file
+        ]
     show (BadStackVersionException requiredRange) = concat
         [ "The version of stack you are using ("
         , show (fromCabalVersion Meta.version)

stack.cabal

@@ -213,6 +213,7 @@ library
                    , hastache
                    , project-template >= 0.2
                    , uuid
+                   , zip-archive
   if os(windows)
     cpp-options:     -DWINDOWS
     build-depends:   Win32