Allow revision

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
 

app/Main.hs

@@ -52,7 +52,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,49 +96,108 @@ 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"
+      , "--heads"
+      , "--tags"
+      , 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
+  -> CloneTarget
+  -- ^ 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 (Repo from) tgt into = do
+  void $ proc "git"
+               [ "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
-  :: 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"
   exists <- testdir pkgDir
-  unless exists . void $ cloneShallow source set pkgDir
+  unless exists . void $ cloneShallow source (CloneTag set) pkgDir
 
 readPackageSet :: PackageConfig -> IO PackageSet
 readPackageSet PackageConfig{ set } = do
@@ -158,10 +217,10 @@ writePackageSet PackageConfig{ set } =
 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 $ do
-    echoT ("Updating " <> runPackageName pkgName)
-    cloneShallow repo version pkgDir
+  unless exists . void $ cloneShallow repo target pkgDir
   pure pkgDir
 
 getTransitiveDeps :: PackageSet -> [PackageName] -> IO [(PackageName, PackageInfo)]
@@ -198,7 +257,7 @@ getPureScriptVersion = do
       | otherwise -> exitWithErr "Unable to parse output of purs --version"
     _ -> exitWithErr "Unexpected output from purs --version"
 
-initialize :: Maybe (Text, Maybe Text) -> IO ()
+initialize :: Maybe (Text, Maybe Repo) -> IO ()
 initialize setAndSource = do
     exists <- testfile "psc-package.json"
     when exists $ exitWithErr "psc-package.json already exists"
@@ -212,13 +271,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
                            }
 
@@ -276,17 +335,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 <> ", " <> 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
@@ -455,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 "update"