Support for dependent packages in Mercurial

ChangeLog.md

@@ -6,6 +6,8 @@ Other enhancements:
 
 * Print latest applicable version of packages on conflicts
   [#508](https://github.com/commercialhaskell/stack/issues/508)
+* Support for packages located in Mercurial repositories
+  [#1397](https://github.com/commercialhaskell/stack/issues/1397)
 
 Bug fixes:
 

doc/yaml_configuration.md

@@ -18,6 +18,8 @@ Project specific options are only valid in the `stack.yaml` file local to a proj
 
 ### packages
 
+(Mercurial support since 0.1.9.0)
+
 This lists all local packages. In the simplest usage, it will be a list of directories, e.g.:
 
 ```yaml
@@ -27,7 +29,7 @@ packages:
 - dir3
 ```
 
-However, it supports two other location types: an HTTP URL referring to a tarball that can be downloaded, and information on a Git repo to clone, together with this SHA1 commit. For example:
+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 repo to clone, together with this SHA1 commit. For example:
 
 ```yaml
 packages:
@@ -36,9 +38,12 @@ packages:
 - location:
     git: [email protected]:commercialhaskell/stack
     commit: 6a86ee32e5b869a877151f74064572225e1a0398
+- location:
+    hg: https://example.com/hg/repo
+    commit: da39a3ee5e6b4b0d3255bfef95601890afd80709
 ```
 
-Note: it is highly recommended that you only use SHA1 values for a Git commit. Other values may work, but they are not officially supported, and may result in unexpected behavior (namely, stack will not automatically pull to update to new versions).
+Note: it is highly recommended that you only use SHA1 values for a Git or Mercurial commit. Other values may work, but they are not officially supported, and may result in unexpected behavior (namely, stack will not automatically pull to update to new versions).
 
 stack further allows you to tweak your packages by specifying two additional
 settings:

src/Stack/Config.hs

@@ -434,10 +434,18 @@ resolvePackageLocation
     -> PackageLocation
     -> m (Path Abs Dir)
 resolvePackageLocation _ projRoot (PLFilePath fp) = resolveDir projRoot fp
-resolvePackageLocation _ projRoot (PLHttpTarball url) = do
-    let name = T.unpack $ decodeUtf8 $ B16.encode $ SHA256.hash $ encodeUtf8 url
+resolvePackageLocation menv projRoot (PLRemote url remotePackageType) = do
+    let nameBeforeHashing = case remotePackageType of
+            RPTHttpTarball -> 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 </> workDirRel </> $(mkRelDir "downloaded")
-    fileRel <- parseRelFile $ name ++ ".tar.gz"
+        fileExtension = case remotePackageType of
+            RPTHttpTarball -> ".tar.gz"
+            _              -> ".unused"
+
+    fileRel <- parseRelFile $ name ++ fileExtension
     dirRel <- parseRelDir name
     dirRelTmp <- parseRelDir $ name ++ ".tmp"
     let file = root </> fileRel
@@ -446,51 +454,46 @@ resolvePackageLocation _ projRoot (PLHttpTarball url) = do
 
     exists <- dirExists dir
     unless exists $ do
-        req <- parseUrl $ T.unpack url
-        _ <- download req file
-
         removeTreeIfExists dirTmp
-        liftIO $ withBinaryFile (toFilePath file) ReadMode $ \h -> do
-            lbs <- L.hGetContents h
-            let entries = Tar.read $ GZip.decompress lbs
-            Tar.unpack (toFilePath dirTmp) entries
-            renameDir dirTmp dir
-
-    x <- listDirectory dir
-    case x of
-        ([dir'], []) -> return dir'
-        (dirs, files) -> do
-            removeFileIfExists file
-            removeTreeIfExists dir
-            throwM $ UnexpectedTarballContents dirs files
-
-resolvePackageLocation menv projRoot (PLGit url commit) = do
-    let name = T.unpack $ decodeUtf8 $ B16.encode $ SHA256.hash $ encodeUtf8 $ T.unwords [url, commit]
-        root = projRoot </> workDirRel </> $(mkRelDir "downloaded")
-    dirRel <- parseRelDir $ name ++ ".git"
-    dirRelTmp <- parseRelDir $ name ++ ".git.tmp"
-    let dir = root </> dirRel
-        dirTmp = root </> dirRelTmp
 
-    exists <- dirExists dir
-    unless exists $ do
-        removeTreeIfExists dirTmp
-        createTree (parent dirTmp)
-        readInNull (parent dirTmp) "git" menv
-            [ "clone"
-            , T.unpack url
-            , toFilePathNoTrailingSep dirTmp
-            ]
-            Nothing
-        readInNull dirTmp "git" menv
-            [ "reset"
-            , "--hard"
-            , T.unpack commit
-            ]
-            Nothing
+        let cloneAndExtract commandName resetCommand commit = do
+                createTree (parent dirTmp)
+                readInNull (parent dirTmp) commandName menv
+                    [ "clone"
+                    , T.unpack url
+                    , toFilePathNoTrailingSep dirTmp
+                    ]
+                    Nothing
+                readInNull dirTmp commandName menv
+                    (resetCommand ++ [T.unpack commit])
+                    Nothing
+
+        case remotePackageType of
+            RPTHttpTarball -> do
+                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
+
+            RPTGit commit -> cloneAndExtract "git" ["reset", "--hard"] commit
+            RPTHg  commit -> cloneAndExtract "hg"  ["update", "-C"]    commit
+
         renameDir dirTmp dir
 
-    return 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
+
+        _ -> return dir
 
 -- | Get the stack root, e.g. ~/.stack
 determineStackRoot :: (MonadIO m, MonadThrow m) => m (Path Abs Dir)

src/Stack/Types/Config.hs

@@ -62,6 +62,7 @@ module Stack.Types.Config
   ,PackageEntry(..)
   ,peExtraDep
   ,PackageLocation(..)
+  ,RemotePackageType(..)
   -- ** PackageIndex, IndexName & IndexLocation
   ,PackageIndex(..)
   ,IndexName(..)
@@ -551,25 +552,39 @@ data PackageLocation
     = PLFilePath FilePath
     -- ^ Note that we use @FilePath@ and not @Path@s. The goal is: first parse
     -- the value raw, and then use @canonicalizePath@ and @parseAbsDir@.
-    | PLHttpTarball Text
-    | PLGit Text Text
-    -- ^ URL and commit
+    | PLRemote Text RemotePackageType
+     -- ^ URL and further details
     deriving Show
+
+data RemotePackageType
+    = RPTHttpTarball
+    | RPTGit Text -- ^ Commit
+    | RPTHg  Text -- ^ Commit
+    deriving Show
+
 instance ToJSON PackageLocation where
     toJSON (PLFilePath fp) = toJSON fp
-    toJSON (PLHttpTarball t) = toJSON t
-    toJSON (PLGit x y) = toJSON $ T.unwords ["git", x, y]
+    toJSON (PLRemote t RPTHttpTarball) = toJSON t
+    toJSON (PLRemote x (RPTGit y)) = toJSON $ T.unwords ["git", x, y]
+    toJSON (PLRemote x (RPTHg  y)) = toJSON $ T.unwords ["hg",  x, y]
+
 instance FromJSON (PackageLocation, [JSONWarning]) where
-    parseJSON v = ((,[]) <$> withText "PackageLocation" (\t -> http t <|> file t) v) <|> git v
+    parseJSON v
+        = ((,[]) <$> withText "PackageLocation" (\t -> http t <|> file t) v)
+        <|> git v
+        <|> hg  v
       where
         file t = pure $ PLFilePath $ T.unpack t
         http t =
             case parseUrl $ T.unpack t of
                 Left _ -> mzero
-                Right _ -> return $ PLHttpTarball t
-        git = withObjectWarnings "PackageGitLocation" $ \o -> PLGit
+                Right _ -> return $ PLRemote t RPTHttpTarball
+        git = withObjectWarnings "PackageGitLocation" $ \o -> PLRemote
             <$> o ..: "git"
-            <*> o ..: "commit"
+            <*> (RPTGit <$> o ..: "commit")
+        hg  = withObjectWarnings "PackageHgLocation"  $ \o -> PLRemote
+            <$> o ..: "hg"
+            <*> (RPTHg  <$> o ..: "commit")
 
 -- | A project is a collection of packages. We can have multiple stack.yaml
 -- files, but only one of them may contain project information.