From e761abb91156af919e8964ccba91380efbd2ea25 Mon Sep 17 00:00:00 2001 From: Michael Xavier Date: Tue, 13 Jun 2017 12:52:45 -0700 Subject: [PATCH 01/10] First stab at allowing branch, tag or SHA This could be a half-measure for #33. This does not prevent usage of master, but it arguably does behave how you'd expect: it always keeps whatever reference you're using as a package set up to date, and happens to also allow you to use a SHA in addition to a revision. I'm going to give this a spin, but if we later wanted to disallow branches, we could probably cobble together a git command that would tell us if a tree-ish or whatever they call it is a branch or not. --- app/Main.hs | 44 ++++++++++++++++++++++++++++---------------- 1 file changed, 28 insertions(+), 16 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 28438f4..a6f47d5 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -114,20 +114,34 @@ cloneShallow :: Text -- ^ repo -> Text - -- ^ branch/tag + -- ^ branch/tag/SHA -> Turtle.FilePath -- ^ target directory - -> IO ExitCode -cloneShallow from ref into = - proc "git" - [ "clone" - , "-q" - , "-c", "advice.detachedHead=false" - , "--depth", "1" - , "-b", ref - , from - , pathToTextUnsafe into - ] empty .||. exit (ExitFailure 1) + -> IO () +cloneShallow from ref into = do + gitExists <- testdir (into ".git") + unless gitExists $ void $ do + proc "git" + [ "clone" + , "-q" + , "-c", "advice.detachedHead=false" + , "--depth", "1" + , from + , pathToTextUnsafe into + ] empty .||. exit (ExitFailure 1) + inGitRepo $ proc "git" + [ "fetch" + , "-q" + , "--tags" + ] empty .||. exit (ExitFailure 1) + inGitRepo $ proc "git" + [ "reset" + , "-q" + , "--hard" + , ref + ] empty .||. exit (ExitFailure 1) + where + inGitRepo m = (view (pushd into >> m)) listRemoteTags :: Text @@ -144,8 +158,7 @@ listRemoteTags from = let gitProc = inproc "git" getPackageSet :: PackageConfig -> IO () getPackageSet PackageConfig{ source, set } = do let pkgDir = ".psc-package" fromText set ".set" - exists <- testdir pkgDir - unless exists . void $ cloneShallow source set pkgDir + void $ cloneShallow source set pkgDir readPackageSet :: PackageConfig -> IO PackageSet readPackageSet PackageConfig{ set } = do @@ -170,8 +183,7 @@ installOrUpdate :: Text -> PackageName -> PackageInfo -> IO Turtle.FilePath installOrUpdate set pkgName PackageInfo{ repo, version } = do echoT ("Updating " <> runPackageName pkgName) let pkgDir = ".psc-package" fromText set fromText (runPackageName pkgName) fromText version - exists <- testdir pkgDir - unless exists . void $ cloneShallow repo version pkgDir + void $ cloneShallow repo version pkgDir pure pkgDir getTransitiveDeps :: PackageSet -> [PackageName] -> IO [(PackageName, PackageInfo)] From aff276f142ab5bb025cfc028b7c0aba88a9970e5 Mon Sep 17 00:00:00 2001 From: Michael Xavier Date: Wed, 14 Jun 2017 08:46:53 -0700 Subject: [PATCH 02/10] Quieter output view actually dumps the exit status, sh does not. --- app/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/app/Main.hs b/app/Main.hs index a6f47d5..c43c12d 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -141,7 +141,7 @@ cloneShallow from ref into = do , ref ] empty .||. exit (ExitFailure 1) where - inGitRepo m = (view (pushd into >> m)) + inGitRepo m = (sh (pushd into >> m)) listRemoteTags :: Text From 159343d34a388accec95c3fd5256f44dec812695 Mon Sep 17 00:00:00 2001 From: Michael Xavier Date: Wed, 14 Jun 2017 16:21:05 -0700 Subject: [PATCH 03/10] Set cloned repo so it can fetch any rev/tag --- app/Main.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/app/Main.hs b/app/Main.hs index c43c12d..0d461b8 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -125,6 +125,7 @@ cloneShallow from ref into = do [ "clone" , "-q" , "-c", "advice.detachedHead=false" + , "-c", "remote.origin.fetch=+refs/heads/*:refs/remotes/origin/*" , "--depth", "1" , from , pathToTextUnsafe into From 9d5c6f768aa6e992090b1a7979d888f8133286e7 Mon Sep 17 00:00:00 2001 From: Michael Xavier Date: Wed, 16 Aug 2017 19:31:59 -0700 Subject: [PATCH 04/10] Implement new cloning logic This is for #45. We'll see what the tests say. Summary: * I use a newtype for Repo since things were starting to get complicated differentiating it from tags. Hope that's ok. * I use the ls-remote trick (you're a lifesaver, @Pauan!) to pull refs. If the ref is *proven* to be a branch, bail out with an error. If its *proven* to be a tag, we can shortcut the clone without running a checkout afterwards. Otherwise, assume its a SHA. * Restore the "exists" checks since we have decided to treat SHAs and tags as immutable. This should avoid unnecessary network calls on subsequent runs. --- README.md | 2 +- app/Main.hs | 129 ++++++++++++++++++++++++++++++++++------------------ 2 files changed, 87 insertions(+), 44 deletions(-) diff --git a/README.md b/README.md index 0d9343f..8742062 100644 --- a/README.md +++ b/README.md @@ -48,7 +48,7 @@ Here is a simple project configuration: It defines: - The project name -- The package set to use to resolve dependencies (this corresponds to a branch or tag of the package set source repository) +- The package set to use to resolve dependencies (this corresponds to a SHA or tag of the package set source repository) - The package set source repository Git URL (change this if you want to host your own package sets) - Any dependencies of the project, as a list of names of packages from the package set diff --git a/app/Main.hs b/app/Main.hs index 9ae20f9..cce07c7 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -48,7 +48,7 @@ data PackageConfig = PackageConfig { name :: PackageName , depends :: [PackageName] , set :: Text - , source :: Text + , source :: Repo } deriving (Show, Generic, Aeson.FromJSON, Aeson.ToJSON) pathToTextUnsafe :: Turtle.FilePath -> Text @@ -96,63 +96,104 @@ writePackageFile = . packageConfigToJSON data PackageInfo = PackageInfo - { repo :: Text + { repo :: Repo , version :: Text , dependencies :: [PackageName] } deriving (Show, Eq, Generic, Aeson.FromJSON, Aeson.ToJSON) type PackageSet = Map.Map PackageName PackageInfo +newtype Repo = Repo { unRepo :: Text } deriving (Show, Eq) + +instance Aeson.FromJSON Repo where + parseJSON = fmap Repo . Aeson.parseJSON + + +instance Aeson.ToJSON Repo where + toJSON = Aeson.toJSON . unRepo + + +data CloneTarget = CloneTag Text + | CloneSHA Text + deriving (Show) + +toCloneTarget + :: Repo + -> Text + -> IO CloneTarget +toCloneTarget (Repo from) raw = do + remoteLines <- Turtle.fold (lineToText <$> gitProc) Foldl.list + let refs = Set.fromList (mapMaybe parseRef remoteLines) + if Set.member rawAsBranch refs + then do + echoT (raw <> " is a branch. psc-package only supports tags and SHAs.") + exit (ExitFailure 1) + else if Set.member rawAsTag refs + then return (CloneTag raw) + else return (CloneSHA raw) + where + rawAsBranch = "refs/heads/" <> raw + rawAsTag = "refs/tags/" <> raw + gitProc = inproc "git" ["ls-remote", "-q", "--refs", from] empty + parseRef line = case T.splitOn "\t" line of + [_, ref] | "refs/" `T.isPrefixOf` ref -> Just ref + _ -> Nothing + +-- Both tags and SHAs can be treated as immutable so we only have to run this once cloneShallow - :: Text + :: Repo -- ^ repo - -> Text - -- ^ branch/tag/SHA + -> CloneTarget + -- ^ tag/SHA -> Turtle.FilePath -- ^ target directory -> IO () -cloneShallow from ref into = do - gitExists <- testdir (into ".git") - unless gitExists $ void $ do - proc "git" - [ "clone" - , "-q" - , "-c", "advice.detachedHead=false" - , "-c", "remote.origin.fetch=+refs/heads/*:refs/remotes/origin/*" - , "--depth", "1" - , from - , pathToTextUnsafe into - ] empty .||. exit (ExitFailure 1) - inGitRepo $ proc "git" - [ "fetch" - , "-q" - , "--tags" - ] empty .||. exit (ExitFailure 1) - inGitRepo $ proc "git" - [ "reset" - , "-q" - , "--hard" - , ref - ] empty .||. exit (ExitFailure 1) +cloneShallow (Repo from) (CloneTag tag) into = + void $ proc "git" + [ "clone" + , "-q" + , "-c", "advice.detachedHead=false" + , "--no-checkout" + , "-b", tag + , from + , pathToTextUnsafe into + ] empty .||. exit (ExitFailure 1) +cloneShallow (Repo from) (CloneSHA sha) into = do + void $ proc "git" + [ "clone" + , "-q" + , "-c", "advice.detachedHead=false" + , "--no-checkout" + , from + , pathToTextUnsafe into + ] empty .||. exit (ExitFailure 1) + inGitRepo $ void $ proc "git" + [ "checkout" + , "-q" + , "-c", "advice.detachedHead=false" + , "--no-checkout" + , sha + ] empty .||. exit (ExitFailure 1) where inGitRepo m = (sh (pushd into >> m)) listRemoteTags - :: Text + :: Repo -- ^ repo -> Turtle.Shell Text -listRemoteTags from = let gitProc = inproc "git" - [ "ls-remote" - , "-q" - , "-t" - , from - ] empty - in lineToText <$> gitProc +listRemoteTags (Repo from) = let gitProc = inproc "git" + [ "ls-remote" + , "-q" + , "-t" + , from + ] empty + in lineToText <$> gitProc getPackageSet :: PackageConfig -> IO () getPackageSet PackageConfig{ source, set } = do let pkgDir = ".psc-package" fromText set ".set" - void $ cloneShallow source set pkgDir + exists <- testdir pkgDir + unless exists . void $ cloneShallow source (CloneTag set) pkgDir readPackageSet :: PackageConfig -> IO PackageSet readPackageSet PackageConfig{ set } = do @@ -177,7 +218,9 @@ installOrUpdate :: Text -> PackageName -> PackageInfo -> IO Turtle.FilePath installOrUpdate set pkgName PackageInfo{ repo, version } = do let pkgDir = ".psc-package" fromText set fromText (runPackageName pkgName) fromText version echoT ("Updating " <> runPackageName pkgName) - cloneShallow repo version pkgDir + target <- toCloneTarget repo version + exists <- testdir pkgDir + unless exists . void $ cloneShallow repo target pkgDir pure pkgDir getTransitiveDeps :: PackageSet -> [PackageName] -> IO [(PackageName, PackageInfo)] @@ -217,7 +260,7 @@ getPureScriptVersion = do echoT "Unable to parse output of purs --version" >> exit (ExitFailure 1) _ -> echoT "Unexpected output from purs --version" >> exit (ExitFailure 1) -initialize :: Maybe (Text, Maybe Text) -> IO () +initialize :: Maybe (Text, Maybe Repo) -> IO () initialize setAndSource = do exists <- testfile "psc-package.json" when exists $ do @@ -233,13 +276,13 @@ initialize setAndSource = do echoT "(Use --source / --set to override this behavior)" pure PackageConfig { name = pkgName , depends = [ preludePackageName ] - , source = "https://github.com/purescript/package-sets.git" + , source = Repo "https://github.com/purescript/package-sets.git" , set = ("psc-" <> pack (showVersion pursVersion)) } Just (set, source) -> pure PackageConfig { name = pkgName , depends = [ preludePackageName ] - , source = fromMaybe "https://github.com/purescript/package-sets.git" source + , source = fromMaybe (Repo "https://github.com/purescript/package-sets.git") source , set } @@ -293,7 +336,7 @@ listPackages sorted = do where fmt :: (PackageName, PackageInfo) -> Text fmt (name, PackageInfo{ version, repo }) = - runPackageName name <> " (" <> version <> ", " <> repo <> ")" + runPackageName name <> " (" <> version <> ", " <> unRepo repo <> ")" inOrder xs = fromNode . fromVertex <$> vs where (gr, fromVertex) = @@ -471,7 +514,7 @@ main = do commands = (Opts.subparser . fold) [ Opts.command "init" (Opts.info (initialize <$> optional ((,) <$> (fromString <$> set) - <*> optional (fromString <$> source)) + <*> optional (Repo . fromString <$> source)) Opts.<**> Opts.helper) (Opts.progDesc "Initialize a new package")) , Opts.command "uninstall" From 2da6fb438fe88c46e71ee45e964f16f0405a798c Mon Sep 17 00:00:00 2001 From: Michael Xavier Date: Wed, 23 Aug 2017 17:51:28 -0700 Subject: [PATCH 05/10] Indent wheres --- app/Main.hs | 36 ++++++++++++++++++------------------ 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index f050428..57361bc 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -132,12 +132,12 @@ toCloneTarget (Repo from) raw = do then return (CloneTag raw) else return (CloneSHA raw) where - rawAsBranch = "refs/heads/" <> raw - rawAsTag = "refs/tags/" <> raw - gitProc = inproc "git" ["ls-remote", "-q", "--refs", from] empty - parseRef line = case T.splitOn "\t" line of - [_, ref] | "refs/" `T.isPrefixOf` ref -> Just ref - _ -> Nothing + rawAsBranch = "refs/heads/" <> raw + rawAsTag = "refs/tags/" <> raw + gitProc = inproc "git" ["ls-remote", "-q", "--refs", from] empty + parseRef line = case T.splitOn "\t" line of + [_, ref] | "refs/" `T.isPrefixOf` ref -> Just ref + _ -> Nothing -- Both tags and SHAs can be treated as immutable so we only have to run this once cloneShallow @@ -175,7 +175,7 @@ cloneShallow (Repo from) (CloneSHA sha) into = do , sha ] empty .||. exit (ExitFailure 1) where - inGitRepo m = (sh (pushd into >> m)) + inGitRepo m = sh (pushd into >> m) listRemoteTags :: Repo @@ -331,17 +331,17 @@ listPackages sorted = do then traverse_ echoT (fmt <$> inOrder (Map.assocs db)) else traverse_ echoT (fmt <$> Map.assocs db) where - fmt :: (PackageName, PackageInfo) -> Text - fmt (name, PackageInfo{ version, repo }) = - runPackageName name <> " (" <> version <> ", " <> unRepo repo <> ")" - - inOrder xs = fromNode . fromVertex <$> vs where - (gr, fromVertex) = - G.graphFromEdges' [ (pkg, name, dependencies pkg) - | (name, pkg) <- xs - ] - vs = G.topSort (G.transposeG gr) - fromNode (pkg, name, _) = (name, pkg) + fmt :: (PackageName, PackageInfo) -> Text + fmt (name, PackageInfo{ version, repo }) = + runPackageName name <> " (" <> version <> ", " <> unRepo repo <> ")" + + inOrder xs = fromNode . fromVertex <$> vs where + (gr, fromVertex) = + G.graphFromEdges' [ (pkg, name, dependencies pkg) + | (name, pkg) <- xs + ] + vs = G.topSort (G.transposeG gr) + fromNode (pkg, name, _) = (name, pkg) getSourcePaths :: PackageConfig -> PackageSet -> [PackageName] -> IO [Turtle.FilePath] getSourcePaths PackageConfig{..} db pkgNames = do From 4c81122d438a5f15e57663cadac9c98f96539f1c Mon Sep 17 00:00:00 2001 From: Michael Xavier Date: Wed, 23 Aug 2017 18:05:24 -0700 Subject: [PATCH 06/10] Remove redundancy --- app/Main.hs | 47 ++++++++++++++++++++++------------------------- 1 file changed, 22 insertions(+), 25 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 57361bc..32afd66 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -148,34 +148,31 @@ cloneShallow -> Turtle.FilePath -- ^ target directory -> IO () -cloneShallow (Repo from) (CloneTag tag) into = - void $ proc "git" - [ "clone" - , "-q" - , "-c", "advice.detachedHead=false" - , "--no-checkout" - , "-b", tag - , from - , pathToTextUnsafe into - ] empty .||. exit (ExitFailure 1) -cloneShallow (Repo from) (CloneSHA sha) into = do +cloneShallow (Repo from) tgt into = do void $ proc "git" - [ "clone" - , "-q" - , "-c", "advice.detachedHead=false" - , "--no-checkout" - , from - , pathToTextUnsafe into - ] empty .||. exit (ExitFailure 1) - inGitRepo $ void $ proc "git" - [ "checkout" - , "-q" - , "-c", "advice.detachedHead=false" - , "--no-checkout" - , sha - ] empty .||. exit (ExitFailure 1) + [ "clone" + , "-q" + , "-c", "advice.detachedHead=false" + , "--no-checkout" + , "-b", tgtText + , from + , pathToTextUnsafe into + ] empty .||. exit (ExitFailure 1) + case tgt of + CloneSHA sha -> + inGitRepo $ void $ proc "git" + [ "checkout" + , "-q" + , "-c", "advice.detachedHead=false" + , "--no-checkout" + , sha + ] empty .||. exit (ExitFailure 1) + CloneTag _ -> return () where inGitRepo m = sh (pushd into >> m) + tgtText = case tgt of + CloneTag t -> t + CloneSHA t -> t listRemoteTags :: Repo From b69be298ab92bb6d991143d777be5382a9b1b772 Mon Sep 17 00:00:00 2001 From: Michael Xavier Date: Wed, 23 Aug 2017 18:09:08 -0700 Subject: [PATCH 07/10] Use --heads --tags --refs in ls-remote As per @Paun's suggestion as it returns less extraneous data this way. --- app/Main.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/app/Main.hs b/app/Main.hs index 32afd66..50a21ad 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -134,7 +134,14 @@ toCloneTarget (Repo from) raw = do where rawAsBranch = "refs/heads/" <> raw rawAsTag = "refs/tags/" <> raw - gitProc = inproc "git" ["ls-remote", "-q", "--refs", from] empty + gitProc = inproc "git" + ["ls-remote" + , "-q" + , "--refs" + , "--heads" + , "--tags" + , from + ] empty parseRef line = case T.splitOn "\t" line of [_, ref] | "refs/" `T.isPrefixOf` ref -> Just ref _ -> Nothing From cb46cce3949a845d423b89bd4140fed132ea57e4 Mon Sep 17 00:00:00 2001 From: Michael Xavier Date: Wed, 29 Nov 2017 19:03:09 -0800 Subject: [PATCH 08/10] Switch to offline clone target type inference In response to recent comments in #45. Now we don't need an expensive ls-remote call to determine if a clone target is a tag or sha. I'm still lacking a good way to test this out though. --- app/Main.hs | 51 ++++++++++++++++++++------------------------------- 1 file changed, 20 insertions(+), 31 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 50a21ad..f241ff9 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -117,34 +117,21 @@ data CloneTarget = CloneTag Text | CloneSHA Text deriving (Show) -toCloneTarget - :: Repo - -> Text - -> IO CloneTarget -toCloneTarget (Repo from) raw = do - remoteLines <- Turtle.fold (lineToText <$> gitProc) Foldl.list - let refs = Set.fromList (mapMaybe parseRef remoteLines) - if Set.member rawAsBranch refs - then do - echoT (raw <> " is a branch. psc-package only supports tags and SHAs.") - exit (ExitFailure 1) - else if Set.member rawAsTag refs - then return (CloneTag raw) - else return (CloneSHA raw) + +parseCloneTarget + :: Text + -> Either Text CloneTarget +parseCloneTarget t = + if T.null remainder + then Right (CloneTag t) + else case T.toLower schemeName of + "sha" -> Right (CloneSHA withoutScheme) + "tag" -> Right (CloneTag withoutScheme) + _ -> Left ("Invalid scheme. Expected sha:// | tag:// but got " <> schemeName) where - rawAsBranch = "refs/heads/" <> raw - rawAsTag = "refs/tags/" <> raw - gitProc = inproc "git" - ["ls-remote" - , "-q" - , "--refs" - , "--heads" - , "--tags" - , from - ] empty - parseRef line = case T.splitOn "\t" line of - [_, ref] | "refs/" `T.isPrefixOf` ref -> Just ref - _ -> Nothing + (schemeName, remainder) = T.breakOn "://" t + withoutScheme = T.drop 3 remainder + -- Both tags and SHAs can be treated as immutable so we only have to run this once cloneShallow @@ -218,10 +205,12 @@ installOrUpdate :: Text -> PackageName -> PackageInfo -> IO Turtle.FilePath installOrUpdate set pkgName PackageInfo{ repo, version } = do let pkgDir = ".psc-package" fromText set fromText (runPackageName pkgName) fromText version echoT ("Updating " <> runPackageName pkgName) - target <- toCloneTarget repo version - exists <- testdir pkgDir - unless exists . void $ cloneShallow repo target pkgDir - pure pkgDir + case parseCloneTarget version of + Left parseError -> exitWithErr parseError + Right target -> do + exists <- testdir pkgDir + unless exists . void $ cloneShallow repo target pkgDir + pure pkgDir getTransitiveDeps :: PackageSet -> [PackageName] -> IO [(PackageName, PackageInfo)] getTransitiveDeps db deps = From 71c8a53d546d527ccd48f8a28681dcb0d3511bf4 Mon Sep 17 00:00:00 2001 From: Michael Xavier Date: Sun, 14 Jan 2018 21:22:46 -0800 Subject: [PATCH 09/10] Remove // from reference parsing This is in accordance to the comments in #45 --- app/Main.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index f241ff9..b5c3d82 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -127,9 +127,9 @@ parseCloneTarget t = else case T.toLower schemeName of "sha" -> Right (CloneSHA withoutScheme) "tag" -> Right (CloneTag withoutScheme) - _ -> Left ("Invalid scheme. Expected sha:// | tag:// but got " <> schemeName) + _ -> Left ("Invalid scheme. Expected sha: | tag: but got " <> schemeName) where - (schemeName, remainder) = T.breakOn "://" t + (schemeName, remainder) = T.breakOn ":" t withoutScheme = T.drop 3 remainder From a5d4df33772dacc675659472b5bfde0858f00506 Mon Sep 17 00:00:00 2001 From: Michael Xavier Date: Sat, 10 Feb 2018 10:07:22 -0800 Subject: [PATCH 10/10] Update clone target parser's shema parsing The drop call was not updated when we went from "scheme://identifier" to "scheme:identifier" and was eating 2 characters from the identifier when a scheme was specified. --- app/Main.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/app/Main.hs b/app/Main.hs index b5c3d82..03e1b90 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -118,6 +118,8 @@ data CloneTarget = CloneTag Text deriving (Show) +-- | Parses "sha:somesha", "tag:sometag", and "sometag" without a +-- schema as a tag. parseCloneTarget :: Text -> Either Text CloneTarget @@ -130,7 +132,7 @@ parseCloneTarget t = _ -> Left ("Invalid scheme. Expected sha: | tag: but got " <> schemeName) where (schemeName, remainder) = T.breakOn ":" t - withoutScheme = T.drop 3 remainder + withoutScheme = T.drop 1 remainder -- Both tags and SHAs can be treated as immutable so we only have to run this once