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,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
+  -> 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) (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"
   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 +213,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 +253,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 +267,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
                            }
 
@@ -278,7 +333,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) =
@@ -455,7 +510,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"