From 1e1db559209a4b8374f959cf95ba401aa2586520 Mon Sep 17 00:00:00 2001 From: David Turner Date: Sat, 21 Nov 2015 23:03:47 +0000 Subject: [PATCH 1/6] Introduce RemotePackageLocation type The behaviour of http and git remote packages is very similar. This change will enable the similarities to be combined. --- src/Stack/Config.hs | 4 ++-- src/Stack/Types/Config.hs | 23 +++++++++++++++-------- 2 files changed, 17 insertions(+), 10 deletions(-) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index ee0b426ef5..7cbf18584b 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -434,7 +434,7 @@ resolvePackageLocation -> PackageLocation -> m (Path Abs Dir) resolvePackageLocation _ projRoot (PLFilePath fp) = resolveDir projRoot fp -resolvePackageLocation _ projRoot (PLHttpTarball url) = do +resolvePackageLocation _ projRoot (PLRemote url RPTHttpTarball) = do let name = T.unpack $ decodeUtf8 $ B16.encode $ SHA256.hash $ encodeUtf8 url root = projRoot workDirRel $(mkRelDir "downloaded") fileRel <- parseRelFile $ name ++ ".tar.gz" @@ -464,7 +464,7 @@ resolvePackageLocation _ projRoot (PLHttpTarball url) = do removeTreeIfExists dir throwM $ UnexpectedTarballContents dirs files -resolvePackageLocation menv projRoot (PLGit url commit) = do +resolvePackageLocation menv projRoot (PLRemote url (RPTGit 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" diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index fd1c5d0d5d..f03a1aac77 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -62,6 +62,7 @@ module Stack.Types.Config ,PackageEntry(..) ,peExtraDep ,PackageLocation(..) + ,RemotePackageType(..) -- ** PackageIndex, IndexName & IndexLocation ,PackageIndex(..) ,IndexName(..) @@ -551,14 +552,20 @@ 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 + 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] + instance FromJSON (PackageLocation, [JSONWarning]) where parseJSON v = ((,[]) <$> withText "PackageLocation" (\t -> http t <|> file t) v) <|> git v where @@ -566,10 +573,10 @@ instance FromJSON (PackageLocation, [JSONWarning]) where 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") -- | A project is a collection of packages. We can have multiple stack.yaml -- files, but only one of them may contain project information. From db9974c64fbf18381ff391e598540a760310aa1b Mon Sep 17 00:00:00 2001 From: David Turner Date: Sat, 21 Nov 2015 23:14:58 +0000 Subject: [PATCH 2/6] Combine the HTTP and Git cases of resolvePackageLocation --- src/Stack/Config.hs | 89 +++++++++++++++++++++++---------------------- 1 file changed, 45 insertions(+), 44 deletions(-) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 7cbf18584b..5fc86b9240 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -434,10 +434,17 @@ resolvePackageLocation -> PackageLocation -> m (Path Abs Dir) resolvePackageLocation _ projRoot (PLFilePath fp) = resolveDir projRoot fp -resolvePackageLocation _ projRoot (PLRemote url RPTHttpTarball) = 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] + 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 +453,45 @@ resolvePackageLocation _ projRoot (PLRemote url RPTHttpTarball) = 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 (PLRemote url (RPTGit 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 + 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 -> do + 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 - 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 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) From a59d54af06d4f35c7394b51e60de3f161f4ef3a2 Mon Sep 17 00:00:00 2001 From: David Turner Date: Sat, 21 Nov 2015 23:40:37 +0000 Subject: [PATCH 3/6] Add Hg cases in parallel with git's --- src/Stack/Config.hs | 30 ++++++++++++++++-------------- src/Stack/Types/Config.hs | 10 +++++++++- 2 files changed, 25 insertions(+), 15 deletions(-) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 5fc86b9240..bd091d8028 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -438,6 +438,7 @@ 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") fileExtension = case remotePackageType of @@ -454,6 +455,19 @@ resolvePackageLocation menv projRoot (PLRemote url remotePackageType) = do exists <- dirExists dir unless exists $ do removeTreeIfExists dirTmp + + 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 @@ -464,20 +478,8 @@ resolvePackageLocation menv projRoot (PLRemote url remotePackageType) = do let entries = Tar.read $ GZip.decompress lbs Tar.unpack (toFilePath dirTmp) entries - RPTGit commit -> do - 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 + RPTGit commit -> cloneAndExtract "git" ["reset", "--hard"] commit + RPTHg commit -> cloneAndExtract "hg" ["update", "-C"] commit renameDir dirTmp dir diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index f03a1aac77..0c0aa9fa9a 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -559,15 +559,20 @@ data PackageLocation data RemotePackageType = RPTHttpTarball | 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 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 = @@ -577,6 +582,9 @@ instance FromJSON (PackageLocation, [JSONWarning]) where git = withObjectWarnings "PackageGitLocation" $ \o -> PLRemote <$> o ..: "git" <*> (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. From b617bb1c8fde99b530087fe184682c3689f073da Mon Sep 17 00:00:00 2001 From: David Turner Date: Sun, 22 Nov 2015 09:54:38 +0000 Subject: [PATCH 4/6] Add new feature to docs --- doc/yaml_configuration.md | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/doc/yaml_configuration.md b/doc/yaml_configuration.md index 73c2a69999..afaf7f8938 100644 --- a/doc/yaml_configuration.md +++ b/doc/yaml_configuration.md @@ -27,7 +27,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 +36,12 @@ packages: - location: git: git@github.com: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: From 2d51fed7aa0f1fe2e1ae2a23ab48257004e88117 Mon Sep 17 00:00:00 2001 From: David Turner Date: Mon, 23 Nov 2015 08:22:18 +0000 Subject: [PATCH 5/6] Mercurial packages since 0.1.9.0 --- doc/yaml_configuration.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/doc/yaml_configuration.md b/doc/yaml_configuration.md index afaf7f8938..3a739f2e39 100644 --- a/doc/yaml_configuration.md +++ b/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 From b90ba6f461de7bae4b570d03911a92b65312255f Mon Sep 17 00:00:00 2001 From: David Turner Date: Mon, 23 Nov 2015 08:25:58 +0000 Subject: [PATCH 6/6] Add Mercurial package support to changelog --- ChangeLog.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/ChangeLog.md b/ChangeLog.md index 8e57db989f..d931baafd4 100644 --- a/ChangeLog.md +++ b/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: