comparison vext.sml @ 1752:716e13004b19

Update Vext and subrepos

     shall not be used in advertising or otherwise to promote the sale,
     use or other dealings in this Software without prior written
     authorization.
 *)
 
-val vext_version = "0.9.9"
+val vext_version = "0.9.91"
 
 
 datatype vcs =
          HG |
          GIT

 
     (** Test whether the library is at the newest revision for the
         given branch. False may indicate that the branch has advanced
         or that the library is not on the branch at all. This function
         may use the network to check for new revisions *)
-    val is_newest : context -> libname * branch -> bool result
+    val is_newest : context -> libname * source * branch -> bool result
 
     (** Test whether the library is at the newest revision available
         locally for the given branch. False may indicate that the
         branch has advanced or that the library is not on the branch
         at all. This function must not use the network *)

     (** Check out, i.e. clone a fresh copy of, the repo for the given
         library on the given branch *)
     val checkout : context -> libname * source * branch -> unit result
 
     (** Update the library to the given branch tip *)
-    val update : context -> libname * branch -> id_or_tag result
+    val update : context -> libname * source * branch -> id_or_tag result
 
     (** Update the library to the given specific id or tag *)
-    val update_to : context -> libname * id_or_tag -> id_or_tag result
+    val update_to : context -> libname * source * id_or_tag -> id_or_tag result
 end
 
 signature LIB_CONTROL = sig
     val review : context -> libspec -> (libstate * localstate) result
     val status : context -> libspec -> (libstate * localstate) result

         case OS.Process.getEnv "VEXT_VERBOSE" of
             SOME "0" => false
           | SOME _ => true
           | NONE => false
 
+    fun split_relative path desc =
+        case OS.Path.fromString path of
+            { isAbs = true, ... } => raise Fail (desc ^ " may not be absolute")
+          | { arcs, ... } => arcs
+                        
     fun extpath ({ rootpath, extdir, ... } : context) =
         let val { isAbs, vol, arcs } = OS.Path.fromString rootpath
         in OS.Path.toString {
                 isAbs = isAbs,
                 vol = vol,
-                arcs = arcs @ [ extdir ]
+                arcs = arcs @
+                       split_relative extdir "extdir"
             }
         end
     
     fun subpath ({ rootpath, extdir, ... } : context) libname remainder =
         (* NB libname is allowed to be a path fragment, e.g. foo/bar *)
         let val { isAbs, vol, arcs } = OS.Path.fromString rootpath
-            val split = String.fields (fn c => c = #"/")
         in OS.Path.toString {
                 isAbs = isAbs,
                 vol = vol,
-                arcs = arcs @ [ extdir ] @ split libname @ split remainder
+                arcs = arcs @
+                       split_relative extdir "extdir" @
+                       split_relative libname "library path" @
+                       split_relative remainder "subpath"
             }
         end
 
     fun libpath context "" =
         extpath context

                    | OK () => ((OS.FileSys.mkDir path; OK ())
                                handle OS.SysErr (e, _) =>
                                       ERROR ("Directory creation failed: " ^ e))
 
     fun mkpath path =
-        (* strip any trailing '/', something isDir doesn't always handle *)
-        case rev (explode path) of
-            #"/"::rest => mkpath (implode (rev rest))
-          | _ => mkpath' path
-
-    fun rmpath path =
+        mkpath' (OS.Path.mkCanonical path)
+
+    fun rmpath' path =
         let open OS
             fun files_from dirstream =
                 case FileSys.readDir dirstream of
                     NONE => []
                   | SOME file =>

                 else FileSys.remove path
         in
             (remove path; OK ())
             handle SysErr (e, _) => ERROR ("Path removal failed: " ^ e)
         end
+
+    fun rmpath path =
+        rmpath' (OS.Path.mkCanonical path)
+
 end
                                          
 functor LibControlFn (V: VCS_CONTROL) :> LIB_CONTROL = struct
 
     (* Valid states for unpinned libraries:

 
        - ABSENT: Repo doesn't exist here at all.
     *)
 
     fun check with_network context
-              ({ libname, branch, project_pin, lock_pin, ... } : libspec) =
+              ({ libname, source, branch,
+                 project_pin, lock_pin, ... } : libspec) =
         let fun check_unpinned () =
-                let val is_newest = if with_network
-                                    then V.is_newest
-                                    else V.is_newest_locally
+                let val newest =
+                        if with_network
+                        then V.is_newest context (libname, source, branch)
+                        else V.is_newest_locally context (libname, branch)
                 in
-                    case is_newest context (libname, branch) of
+                    case newest of
                          ERROR e => ERROR e
                        | OK true => OK CORRECT
                        | OK false =>
                          case V.is_on_branch context (libname, branch) of
                              ERROR e => ERROR e

 
     fun update context
                ({ libname, source, branch,
                   project_pin, lock_pin, ... } : libspec) =
         let fun update_unpinned () =
-                case V.is_newest context (libname, branch) of
+                case V.is_newest context (libname, source, branch) of
                     ERROR e => ERROR e
                   | OK true => V.id_of context libname
-                  | OK false => V.update context (libname, branch)
+                  | OK false => V.update context (libname, source, branch)
             fun update_pinned target =
                 case V.is_at context (libname, target) of
                     ERROR e => ERROR e
                   | OK true => OK target
-                  | OK false => V.update_to context (libname, target)
+                  | OK false => V.update_to context (libname, source, target)
             fun update' () =
                 case lock_pin of
                     PINNED target => update_pinned target
                   | UNPINNED =>
                     case project_pin of

                          (login_for context service)
                          (#providers context)
 end
 
 structure HgControl :> VCS_CONTROL = struct
-                            
+
+    (* Pulls always use an explicit URL, never just the default
+       remote, in order to ensure we update properly if the location
+       given in the project file changes. *)
+
     type vcsstate = { id: string, modified: bool,
                       branch: string, tags: string list }
 
     val hg_args = [ "--config", "ui.interactive=true" ]
                         

     fun is_newest_locally context (libname, branch) =
         case hg_command_output context libname
                                ["log", "-l1",
                                 "-b", branch_name branch,
                                 "--template", "{node}"] of
-            ERROR e => ERROR e
+            ERROR e => OK false (* desired branch does not exist *)
           | OK newest_in_repo => is_at context (libname, newest_in_repo)
 
-    fun pull context libname =
-        hg_command context libname
-                   (if FileBits.verbose ()
-                    then ["pull"]
-                    else ["pull", "-q"])
-
-    fun is_newest context (libname, branch) =
+    fun pull context (libname, source) =
+        let val url = remote_for context (libname, source)
+        in
+            hg_command context libname
+                       (if FileBits.verbose ()
+                        then ["pull", url]
+                        else ["pull", "-q", url])
+        end
+
+    fun is_newest context (libname, source, branch) =
         case is_newest_locally context (libname, branch) of
             ERROR e => ERROR e
           | OK false => OK false
           | OK true =>
-            case pull context libname of
+            case pull context (libname, source) of
                 ERROR e => ERROR e
               | _ => is_newest_locally context (libname, branch)
 
     fun is_modified_locally context libname =
         case current_state context libname of

               | _ => hg_command context ""
                                 ["clone", "-u", branch_name branch,
                                  url, libname]
         end
                                                     
-    fun update context (libname, branch) =
-        let val pull_result = pull context libname
+    fun update context (libname, source, branch) =
+        let val pull_result = pull context (libname, source)
         in
             case hg_command context libname ["update", branch_name branch] of
                 ERROR e => ERROR e
               | _ =>
                 case pull_result of
                     ERROR e => ERROR e
                   | _ => id_of context libname
         end
 
-    fun update_to context (libname, "") =
+    fun update_to context (libname, _, "") =
         ERROR "Non-empty id (tag or revision id) required for update_to"
-      | update_to context (libname, id) = 
-        let val pull_result = pull context libname
+      | update_to context (libname, source, id) = 
+        let val pull_result = pull context (libname, source)
         in
             case hg_command context libname ["update", "-r", id] of
                 OK _ => id_of context libname
               | ERROR e =>
                 case pull_result of

 end
 
 structure GitControl :> VCS_CONTROL = struct
 
     (* With Git repos we always operate in detached HEAD state. Even
-       the master branch is checked out using the remote reference,
-       origin/master. *)
+       the master branch is checked out using a remote reference
+       (vext/master). The remote we use is always named vext, and we
+       update it to the expected URL each time we fetch, in order to
+       ensure we update properly if the location given in the project
+       file changes. The origin remote is unused. *)
 
     fun git_command context libname args =
         FileBits.command context libname ("git" :: args)
 
     fun git_command_output context libname args =

     fun branch_name branch = case branch of
                                  DEFAULT_BRANCH => "master"
                                | BRANCH "" => "master"
                                | BRANCH b => b
 
-    fun remote_branch_name branch = "origin/" ^ branch_name branch
+    val our_remote = "vext"
+                                                 
+    fun remote_branch_name branch = our_remote ^ "/" ^ branch_name branch
 
     fun checkout context (libname, source, branch) =
         let val url = remote_for context (libname, source)
         in
             (* make the lib dir rather than just the ext dir, since
                the lib dir might be nested and git will happily check
                out into an existing empty dir anyway *)
             case FileBits.mkpath (FileBits.libpath context libname) of
                 OK () => git_command context ""
-                                     ["clone", "-b",
-                                      branch_name branch,
+                                     ["clone", "--origin", our_remote,
+                                      "--branch", branch_name branch,
                                       url, libname]
               | ERROR e => ERROR e
+        end
+
+    fun add_our_remote context (libname, source) =
+        (* When we do the checkout ourselves (above), we add the
+           remote at the same time. But if the repo was cloned by
+           someone else, we'll need to do it after the fact. Git
+           doesn't seem to have a means to add a remote or change its
+           url if it already exists; seems we have to do this: *)
+        let val url = remote_for context (libname, source)
+        in
+            case git_command context libname
+                             ["remote", "set-url", our_remote, url] of
+                OK () => OK ()
+              | ERROR e => git_command context libname
+                                       ["remote", "add", "-f", our_remote, url]
         end
 
     (* NB git rev-parse HEAD shows revision id of current checkout;
        git rev-list -1 <tag> shows revision id of revision with that tag *)
 
     fun id_of context libname =
         git_command_output context libname ["rev-parse", "HEAD"]
             
     fun is_at context (libname, id_or_tag) =
         case id_of context libname of
-            ERROR e => ERROR e
+            ERROR e => OK false (* HEAD nonexistent, expected in empty repo *)
           | OK id =>
             if String.isPrefix id_or_tag id orelse
                String.isPrefix id id_or_tag
             then OK true
             else 
                 case git_command_output context libname
                                         ["show-ref",
-                                         "refs/tags/" ^ id_or_tag] of
+                                         "refs/tags/" ^ id_or_tag,
+                                         "--"] of
                     OK "" => OK false
                   | ERROR _ => OK false
                   | OK s => OK (id = hd (String.tokens (fn c => c = #" ") s))
 
     fun branch_tip context (libname, branch) =
+        (* We don't have access to the source info or the network
+           here, as this is used by status (e.g. via is_on_branch) as
+           well as review. It's possible the remote branch won't exist,
+           e.g. if the repo was checked out by something other than
+           Vext, and if that's the case, we can't add it here; we'll
+           just have to fail, since checking against local branches
+           instead could produce the wrong result. *)
         git_command_output context libname
                            ["rev-list", "-1",
-                            remote_branch_name branch]
+                            remote_branch_name branch, "--"]
                        
     fun is_newest_locally context (libname, branch) =
         case branch_tip context (libname, branch) of
-            ERROR e => ERROR e
+            ERROR e => OK false
           | OK rev => is_at context (libname, rev)
 
     fun is_on_branch context (libname, branch) =
         case branch_tip context (libname, branch) of
-            ERROR e => ERROR e
+            ERROR e => OK false
           | OK rev =>
             case is_at context (libname, rev) of
                 ERROR e => ERROR e
               | OK true => OK true
               | OK false =>

                                  ["merge-base", "--is-ancestor",
                                   "HEAD", remote_branch_name branch] of
                     ERROR e => OK false  (* cmd returns non-zero for no *)
                   | _ => OK true
 
-    fun is_newest context (libname, branch) =
-        case is_newest_locally context (libname, branch) of
+    fun fetch context (libname, source) =
+        case add_our_remote context (libname, source) of
             ERROR e => ERROR e
-          | OK false => OK false
-          | OK true =>
-            case git_command context libname ["fetch"] of
+          | _ => git_command context libname ["fetch", our_remote]
+                            
+    fun is_newest context (libname, source, branch) =
+        case add_our_remote context (libname, source) of
+            ERROR e => ERROR e
+          | OK () => 
+            case is_newest_locally context (libname, branch) of
                 ERROR e => ERROR e
-              | _ => is_newest_locally context (libname, branch)
+              | OK false => OK false
+              | OK true =>
+                case fetch context (libname, source) of
+                    ERROR e => ERROR e
+                  | _ => is_newest_locally context (libname, branch)
 
     fun is_modified_locally context libname =
         case git_command_output context libname ["status", "--porcelain"] of
             ERROR e => ERROR e
           | OK "" => OK false

        branch, as that will succeed even if the branch isn't up to
        date. We could checkout the branch and then fetch and merge,
        but it's perhaps cleaner not to maintain a local branch at all,
        but instead checkout the remote branch as a detached head. *)
 
-    fun update context (libname, branch) =
-        case git_command context libname ["fetch"] of
+    fun update context (libname, source, branch) =
+        case fetch context (libname, source) of
             ERROR e => ERROR e
           | _ =>
             case git_command context libname ["checkout", "--detach",
                                               remote_branch_name branch] of
                 ERROR e => ERROR e

        attempt the fetch first, though, purely in order to avoid ugly
        error messages in the common case where we're being asked to
        update to a new pin (from the lock file) that hasn't been
        fetched yet. *)
 
-    fun update_to context (libname, "") = 
+    fun update_to context (libname, _, "") = 
         ERROR "Non-empty id (tag or revision id) required for update_to"
-      | update_to context (libname, id) =
-        let val fetch_result = git_command context libname ["fetch"]
+      | update_to context (libname, source, id) =
+        let val fetch_result = fetch context (libname, source)
         in
             case git_command context libname ["checkout", "--detach", id] of
                 OK _ => id_of context libname
               | ERROR e =>
                 case fetch_result of