Mercurial > hg > tony
diff vext.sml @ 529:2cc8700975db
Update vext
| author | Chris Cannam |
|---|---|
| date | Fri, 06 Oct 2017 13:28:52 +0100 |
| parents | 9fc762aafd01 |
| children |
line wrap: on
line diff
--- a/vext.sml Thu Aug 31 18:48:07 2017 +0100 +++ b/vext.sml Fri Oct 06 13:28:52 2017 +0100 @@ -1,12 +1,16 @@ -(* This file is automatically generated from the individual - source files in the Vext repository. *) +(* + DO NOT EDIT THIS FILE. + This file is automatically generated from the individual + source files in the Vext repository. +*) (* Vext A simple manager for third-party source code dependencies - Copyright 2017 Chris Cannam. + Copyright 2017 Chris Cannam, Particular Programs Ltd, + and Queen Mary, University of London Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation @@ -27,13 +31,14 @@ CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - Except as contained in this notice, the names of Chris Cannam and - Particular Programs Ltd shall not be used in advertising or - otherwise to promote the sale, use or other dealings in this - Software without prior written authorization. + Except as contained in this notice, the names of Chris Cannam, + Particular Programs Ltd, and Queen Mary, University of London + 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.4" +val vext_version = "0.9.8" datatype vcs = @@ -48,9 +53,11 @@ repo : string option } +type id_or_tag = string + datatype pin = UNPINNED | - PINNED of string + PINNED of id_or_tag datatype libstate = ABSENT | @@ -60,7 +67,8 @@ datatype localstate = MODIFIED | - UNMODIFIED + LOCK_MISMATCHED | + CLEAN datatype branch = BRANCH of string | @@ -77,21 +85,20 @@ type libname = string -type id_or_tag = string - type libspec = { libname : libname, vcs : vcs, source : source, branch : branch, - pin : pin + project_pin : pin, + lock_pin : pin } type lock = { libname : libname, id_or_tag : id_or_tag } - + type remote_spec = { anon : string option, auth : string option @@ -129,6 +136,7 @@ val project_file = "vext-project.json" val project_lock_file = "vext-lock.json" val user_config_file = ".vext.json" + val archive_dir = ".vext-archive" end signature VCS_CONTROL = sig @@ -177,6 +185,7 @@ val review : context -> libspec -> (libstate * localstate) result val status : context -> libspec -> (libstate * localstate) result val update : context -> libspec -> id_or_tag result + val id_of : context -> libspec -> id_or_tag result end structure FileBits :> sig @@ -189,6 +198,7 @@ val mydir : unit -> string val homedir : unit -> string val mkpath : string -> unit result + val rmpath : string -> unit result val project_spec_path : string -> string val project_lock_path : string -> string val verbose : unit -> bool @@ -373,6 +383,36 @@ | OK () => ((OS.FileSys.mkDir path; OK ()) handle OS.SysErr (e, _) => ERROR ("Directory creation failed: " ^ e)) + + fun rmpath path = + let open OS + fun files_from dirstream = + case FileSys.readDir dirstream of + NONE => [] + | SOME file => + (* readDir is supposed to filter these, + but let's be extra cautious: *) + if file = Path.parentArc orelse file = Path.currentArc + then files_from dirstream + else file :: files_from dirstream + fun contents dir = + let val stream = FileSys.openDir dir + val files = map (fn f => Path.joinDirFile + { dir = dir, file = f }) + (files_from stream) + val _ = FileSys.closeDir stream + in files + end + fun remove path = + if FileSys.isLink path (* dangling links bother isDir *) + then FileSys.remove path + else if FileSys.isDir path + then (app remove (contents path); FileSys.rmDir path) + else FileSys.remove path + in + (remove path; OK ()) + handle SysErr (e, _) => ERROR ("Path removal failed: " ^ e) + end end functor LibControlFn (V: VCS_CONTROL) :> LIB_CONTROL = struct @@ -402,7 +442,8 @@ - ABSENT: Repo doesn't exist here at all. *) - fun check with_network context ({ libname, branch, pin, ... } : libspec) = + fun check with_network context + ({ libname, branch, project_pin, lock_pin, ... } : libspec) = let fun check_unpinned () = let val is_newest = if with_network then V.is_newest @@ -422,26 +463,39 @@ ERROR e => ERROR e | OK true => OK CORRECT | OK false => OK WRONG - fun check' () = - case pin of + fun check_remote () = + case project_pin of UNPINNED => check_unpinned () | PINNED target => check_pinned target + fun check_local () = + case V.is_modified_locally context libname of + ERROR e => ERROR e + | OK true => OK MODIFIED + | OK false => + case lock_pin of + UNPINNED => OK CLEAN + | PINNED target => + case V.is_at context (libname, target) of + ERROR e => ERROR e + | OK true => OK CLEAN + | OK false => OK LOCK_MISMATCHED in case V.exists context libname of ERROR e => ERROR e - | OK false => OK (ABSENT, UNMODIFIED) + | OK false => OK (ABSENT, CLEAN) | OK true => - case (check' (), V.is_modified_locally context libname) of + case (check_remote (), check_local ()) of (ERROR e, _) => ERROR e | (_, ERROR e) => ERROR e - | (OK state, OK true) => OK (state, MODIFIED) - | (OK state, OK false) => OK (state, UNMODIFIED) + | (OK r, OK l) => OK (r, l) end val review = check true val status = check false - - fun update context ({ libname, source, branch, pin, ... } : libspec) = + + fun update context + ({ libname, source, branch, + project_pin, lock_pin, ... } : libspec) = let fun update_unpinned () = case V.is_newest context (libname, branch) of ERROR e => ERROR e @@ -453,9 +507,12 @@ | OK true => OK target | OK false => V.update_to context (libname, target) fun update' () = - case pin of - UNPINNED => update_unpinned () - | PINNED target => update_pinned target + case lock_pin of + PINNED target => update_pinned target + | UNPINNED => + case project_pin of + PINNED target => update_pinned target + | UNPINNED => update_unpinned () in case V.exists context libname of ERROR e => ERROR e @@ -465,6 +522,10 @@ ERROR e => ERROR e | OK () => update' () end + + fun id_of context ({ libname, ... } : libspec) = + V.id_of context libname + end (* Simple Standard ML JSON parser @@ -1369,6 +1430,249 @@ fun update context (spec as { vcs, ... } : libspec) = (fn HG => H.update | GIT => G.update) vcs context spec + + fun id_of context (spec as { vcs, ... } : libspec) = + (fn HG => H.id_of | GIT => G.id_of) vcs context spec +end + + +type exclusions = string list + +structure Archive :> sig + + val archive : string * exclusions -> project -> OS.Process.status + +end = struct + + (* The idea of "archive" is to replace hg/git archive, which won't + include files, like the Vext-introduced external libraries, + that are not under version control with the main repo. + + The process goes like this: + + - Make sure we have a target filename from the user, and take + its basename as our archive directory name + + - Make an "archive root" subdir of the project repo, named + typically .vext-archive + + - Identify the VCS used for the project repo. Note that any + explicit references to VCS type in this structure are to + the VCS used for the project (something Vext doesn't + otherwise care about), not for an individual library + + - Synthesise a Vext project with the archive root as its + root path, "." as its extdir, with one library whose + name is the user-supplied basename and whose explicit + source URL is the original project root; update that + project -- thus cloning the original project to a subdir + of the archive root + + - Synthesise a Vext project identical to the original one for + this project, but with the newly-cloned copy as its root + path; update that project -- thus checking out clean copies + of the external library dirs + + - Call out to an archive program to archive up the new copy, + running e.g. + tar cvzf project-release.tar.gz \ + --exclude=.hg --exclude=.git project-release + in the archive root dir + + - (We also omit the vext-project.json file and any trace of + Vext. It can't properly be run in a directory where the + external project folders already exist but their repo history + does not. End users shouldn't get to see Vext) + + - Clean up by deleting the new copy + *) + + fun project_vcs_and_id dir = + let val context = { + rootpath = dir, + extdir = ".", + providers = [], + accounts = [] + } + val vcs_maybe = + case [HgControl.exists context ".", + GitControl.exists context "."] of + [OK true, OK false] => OK HG + | [OK false, OK true] => OK GIT + | _ => ERROR ("Unable to identify VCS for directory " ^ dir) + in + case vcs_maybe of + ERROR e => ERROR e + | OK vcs => + case (fn HG => HgControl.id_of | GIT => GitControl.id_of) + vcs context "." of + ERROR e => ERROR ("Unable to obtain id of project repo: " + ^ e) + | OK id => OK (vcs, id) + end + + fun make_archive_root (context : context) = + let val path = OS.Path.joinDirFile { + dir = #rootpath context, + file = VextFilenames.archive_dir + } + in + case FileBits.mkpath path of + ERROR e => raise Fail ("Failed to create archive directory \"" + ^ path ^ "\": " ^ e) + | OK () => path + end + + fun archive_path archive_dir target_name = + OS.Path.joinDirFile { + dir = archive_dir, + file = target_name + } + + fun check_nonexistent path = + case SOME (OS.FileSys.fileSize path) handle OS.SysErr _ => NONE of + NONE => () + | _ => raise Fail ("Path " ^ path ^ " exists, not overwriting") + + fun file_url path = + let val forward_path = + String.translate (fn #"\\" => "/" | + c => Char.toString c) path + in + (* Path is expected to be absolute already, but if it + starts with a drive letter, we'll need an extra slash *) + case explode forward_path of + #"/"::rest => "file:///" ^ implode rest + | _ => "file:///" ^ forward_path + end + + fun make_archive_copy target_name (vcs, project_id) + ({ context, ... } : project) = + let val archive_root = make_archive_root context + val synthetic_context = { + rootpath = archive_root, + extdir = ".", + providers = [], + accounts = [] + } + val synthetic_library = { + libname = target_name, + vcs = vcs, + source = URL_SOURCE (file_url (#rootpath context)), + branch = DEFAULT_BRANCH, (* overridden by pinned id below *) + project_pin = PINNED project_id, + lock_pin = PINNED project_id + } + val path = archive_path archive_root target_name + val _ = print ("Cloning original project to " ^ path + ^ " at revision " ^ project_id ^ "...\n"); + val _ = check_nonexistent path + in + case AnyLibControl.update synthetic_context synthetic_library of + ERROR e => ERROR ("Failed to clone original project to " + ^ path ^ ": " ^ e) + | OK _ => OK archive_root + end + + fun update_archive archive_root target_name + (project as { context, ... } : project) = + let val synthetic_context = { + rootpath = archive_path archive_root target_name, + extdir = #extdir context, + providers = #providers context, + accounts = #accounts context + } + in + foldl (fn (lib, acc) => + case acc of + ERROR e => ERROR e + | OK _ => AnyLibControl.update synthetic_context lib) + (OK "") + (#libs project) + end + + datatype packer = TAR + | TAR_GZ + | TAR_BZ2 + | TAR_XZ + (* could add other packers, e.g. zip, if we knew how to + handle the file omissions etc properly in pack_archive *) + + fun packer_and_basename path = + let val extensions = [ (".tar", TAR), + (".tar.gz", TAR_GZ), + (".tar.bz2", TAR_BZ2), + (".tar.xz", TAR_XZ)] + val filename = OS.Path.file path + in + foldl (fn ((ext, packer), acc) => + if String.isSuffix ext filename + then SOME (packer, + String.substring (filename, 0, + String.size filename - + String.size ext)) + else acc) + NONE + extensions + end + + fun pack_archive archive_root target_name target_path packer exclusions = + case FileBits.command { + rootpath = archive_root, + extdir = ".", + providers = [], + accounts = [] + } "" ([ + "tar", + case packer of + TAR => "cf" + | TAR_GZ => "czf" + | TAR_BZ2 => "cjf" + | TAR_XZ => "cJf", + target_path, + "--exclude=.hg", + "--exclude=.git", + "--exclude=vext", + "--exclude=vext.sml", + "--exclude=vext.ps1", + "--exclude=vext.bat", + "--exclude=vext-project.json", + "--exclude=vext-lock.json" + ] @ (map (fn e => "--exclude=" ^ e) exclusions) @ + [ target_name ]) + of + ERROR e => ERROR e + | OK _ => FileBits.rmpath (archive_path archive_root target_name) + + fun archive (target_path, exclusions) (project : project) = + let val _ = check_nonexistent target_path + val (packer, name) = + case packer_and_basename target_path of + NONE => raise Fail ("Unsupported archive file extension in " + ^ target_path) + | SOME pn => pn + val details = + case project_vcs_and_id (#rootpath (#context project)) of + ERROR e => raise Fail e + | OK details => details + val archive_root = + case make_archive_copy name details project of + ERROR e => raise Fail e + | OK archive_root => archive_root + val outcome = + case update_archive archive_root name project of + ERROR e => ERROR e + | OK _ => + case pack_archive archive_root name + target_path packer exclusions of + ERROR e => ERROR e + | OK _ => OK () + in + case outcome of + ERROR e => raise Fail e + | OK () => OS.Process.success + end + end val libobjname = "libraries" @@ -1383,10 +1687,14 @@ val repo = retrieve ["repository"] val url = retrieve ["url"] val branch = retrieve ["branch"] - val user_pin = retrieve ["pin"] + val project_pin = case retrieve ["pin"] of + NONE => UNPINNED + | SOME p => PINNED p val lock_pin = case lookup_optional lock_json [libobjname, libname] of - SOME ll => lookup_optional_string ll ["pin"] - | NONE => NONE + NONE => UNPINNED + | SOME ll => case lookup_optional_string ll ["pin"] of + SOME p => PINNED p + | NONE => UNPINNED in { libname = libname, @@ -1401,12 +1709,8 @@ SERVICE_SOURCE { service = ss, owner = owner, repo = repo } | _ => raise Fail ("Must have exactly one of service " ^ "or url string"), - pin = case lock_pin of - SOME p => PINNED p - | NONE => - case user_pin of - SOME p => PINNED p - | NONE => UNPINNED, + project_pin = project_pin, + lock_pin = lock_pin, branch = case branch of SOME b => BRANCH b | NONE => DEFAULT_BRANCH @@ -1502,12 +1806,13 @@ val libname_width = 25 val libstate_width = 11 -val localstate_width = 9 +val localstate_width = 17 val notes_width = 5 val divider = " | " +val clear_line = "\r" ^ pad_to 80 ""; fun print_status_header () = - print ("\r" ^ pad_to 80 "" ^ "\n " ^ + print (clear_line ^ "\n " ^ pad_to libname_width "Library" ^ divider ^ pad_to libstate_width "State" ^ divider ^ pad_to localstate_width "Local" ^ divider ^ @@ -1518,7 +1823,7 @@ hline_to notes_width ^ "\n") fun print_outcome_header () = - print ("\r" ^ pad_to 80 "" ^ "\n " ^ + print (clear_line ^ "\n " ^ pad_to libname_width "Library" ^ divider ^ pad_to libstate_width "Outcome" ^ divider ^ "Notes" ^ "\n " ^ @@ -1537,8 +1842,9 @@ val localstate_str = case status of OK (_, MODIFIED) => "Modified" - | OK (_, UNMODIFIED) => "Clean" - | _ => "" + | OK (_, LOCK_MISMATCHED) => "Differs from Lock" + | OK (_, CLEAN) => "Clean" + | ERROR _ => "" val error_str = case status of ERROR e => e @@ -1612,6 +1918,26 @@ return_code end +fun lock_project ({ context, libs } : project) = + let val outcomes = map (fn lib => + (#libname lib, AnyLibControl.id_of context lib)) + libs + val locks = + List.concat + (map (fn (libname, result) => + case result of + ERROR _ => [] + | OK id => [{ libname = libname, id_or_tag = id }]) + outcomes) + val return_code = return_code_for outcomes + val _ = print clear_line + in + if OS.Process.isSuccess return_code + then save_lock_file (#rootpath context) locks + else (); + return_code + end + fun load_local_project pintype = let val userconfig = load_userconfig () val rootpath = OS.FileSys.getDir () @@ -1621,18 +1947,17 @@ fun with_local_project pintype f = let val return_code = f (load_local_project pintype) - handle e => - (print ("Failed with exception: " ^ - (exnMessage e) ^ "\n"); - OS.Process.failure) + handle e => (print ("Error: " ^ exnMessage e); + OS.Process.failure) val _ = print "\n"; in return_code end -fun review () = with_local_project NO_LOCKFILE review_project -fun status () = with_local_project NO_LOCKFILE status_of_project +fun review () = with_local_project USE_LOCKFILE review_project +fun status () = with_local_project USE_LOCKFILE status_of_project fun update () = with_local_project NO_LOCKFILE update_project +fun lock () = with_local_project NO_LOCKFILE lock_project fun install () = with_local_project USE_LOCKFILE update_project fun version () = @@ -1650,9 +1975,20 @@ ^ " review check configured libraries against their providers, and report\n" ^ " install update configured libraries according to project specs and lock file\n" ^ " update update configured libraries and lock file according to project specs\n" + ^ " lock update lock file to match local library status\n" + ^ " archive pack up project and all libraries into an archive file\n" + ^ " (invoke as 'vext archive target-file.tar.gz')\n" ^ " version print the Vext version number and exit\n\n"); OS.Process.failure) +fun archive target args = + case args of + [] => + with_local_project USE_LOCKFILE (Archive.archive (target, [])) + | "--exclude"::xs => + with_local_project USE_LOCKFILE (Archive.archive (target, xs)) + | _ => usage () + fun vext args = let val return_code = case args of @@ -1660,7 +1996,9 @@ | ["status"] => status () | ["install"] => install () | ["update"] => update () + | ["lock"] => lock () | ["version"] => version () + | "archive"::target::args => archive target args | _ => usage () in OS.Process.exit return_code;