From 271bbe7e5c6ea1a2b012348037ba56ef9e85f1ad Mon Sep 17 00:00:00 2001 From: Chris Cannam Date: Wed, 29 Sep 2021 08:49:56 +0100 Subject: [PATCH] Update Repoint --- repoint.ps1 | 7 ++++ repoint.sml | 117 ++++++++++++++++++++++++++++++++++++++++------------ 2 files changed, 97 insertions(+), 27 deletions(-) diff --git a/repoint.ps1 b/repoint.ps1 index 3c1978a..eb91aab 100644 --- a/repoint.ps1 +++ b/repoint.ps1 @@ -18,6 +18,7 @@ $program = "$mydir/repoint.sml" # We need either Poly/ML or SML/NJ. No great preference as to which. # Typical locations +$former_path = $env:PATH $env:PATH = "$env:PATH;C:\Program Files (x86)\SMLNJ\bin;C:\Program Files\Poly ML;C:\Program Files (x86)\Poly ML" if (!$sml) { @@ -43,6 +44,7 @@ ERROR: No supported SML compiler or interpreter found - executable name: polyml "@ + $env:PATH = $former_path exit 1 } } @@ -59,6 +61,7 @@ if ($sml -eq "poly") { echo "use ""$program""; repoint $arglist" | polyml -q --error-exit | Out-Host if (-not $?) { + $env:PATH = $former_path exit $LastExitCode } @@ -105,6 +108,7 @@ val _ = OS.Process.exit (OS.Process.success); if (-not $?) { del $tmpfile + $env:PATH = $former_path exit $LastExitCode } @@ -113,5 +117,8 @@ val _ = OS.Process.exit (OS.Process.success); } else { "Unknown SML implementation name: $sml" + $env:PATH = $former_path exit 2 } + +$env:PATH = $former_path diff --git a/repoint.sml b/repoint.sml index 1f3abb4..5ac6e76 100644 --- a/repoint.sml +++ b/repoint.sml @@ -38,7 +38,7 @@ authorization. *) -val repoint_version = "1.2" +val repoint_version = "1.3" datatype vcs = @@ -257,13 +257,27 @@ structure FileBits :> sig val project_lock_path : string -> string val project_completion_path : string -> string val verbose : unit -> bool + val insecure : unit -> bool end = struct fun verbose () = case OS.Process.getEnv "REPOINT_VERBOSE" of SOME "0" => false - | SOME _ => true | NONE => false + | _ => true + + val insecure_warned = ref false + + fun insecure () = + case OS.Process.getEnv "REPOINT_INSECURE" of + SOME "0" => false + | NONE => false + | _ => + (if ! insecure_warned (* deref not negate, so "if we have warned" *) + then () + else (print "Warning: Insecure mode active in environment, skipping security checks\n"; + insecure_warned := true); + true) fun split_relative path desc = case OS.Path.fromString path of @@ -954,7 +968,16 @@ structure Json :> JSON = struct in implode (escape' [] (explode s)) end - + + fun serialiseNumber n = + implode (map (fn #"~" => #"-" | c => c) + (explode + (if Real.isFinite n andalso + Real.== (n, Real.realRound n) andalso + Real.<= (Real.abs n, 1e6) + then Int.toString (Real.round n) + else Real.toString n))) + fun serialise json = case json of OBJECT pp => "{" ^ String.concatWith @@ -963,8 +986,7 @@ structure Json :> JSON = struct serialise value) pp) ^ "}" | ARRAY arr => "[" ^ String.concatWith "," (map serialise arr) ^ "]" - | NUMBER n => implode (map (fn #"~" => #"-" | c => c) - (explode (Real.toString n))) + | NUMBER n => serialiseNumber n | STRING s => "\"" ^ stringEscape s ^ "\"" | BOOL b => Bool.toString b | NULL => "null" @@ -1239,6 +1261,10 @@ structure HgControl :> VCS_CONTROL = struct val hg_args = [ "--config", "ui.interactive=true", "--config", "ui.merge=:merge" ] + + val hg_extra_clone_pull_args = if FileBits.insecure () + then [ "--insecure" ] + else [] fun hg_command context libname args = FileBits.command context libname (hg_program :: hg_args @ args) @@ -1347,9 +1373,10 @@ structure HgControl :> VCS_CONTROL = struct val url = remote_for context (libname, source) in hg_command context libname - (if FileBits.verbose () - then ["pull", url] - else ["pull", "-q", url]) + ((if FileBits.verbose () + then ["pull", url] + else ["pull", "-q", url]) + @ hg_extra_clone_pull_args) end fun is_newest context (libname, source, branch) = @@ -1373,8 +1400,8 @@ structure HgControl :> VCS_CONTROL = struct case FileBits.mkpath (FileBits.libpath context libname) of ERROR e => ERROR e | _ => hg_command context "" - ["clone", "-u", branch_name branch, - url, libname] + (["clone", "-u", branch_name branch, + url, libname] @ hg_extra_clone_pull_args) end fun update context (libname, source, branch) = @@ -1737,7 +1764,7 @@ structure SubXml :> SUBXML = struct fun entity pos cc = let fun entity' decoder pos text [] = - error pos "Document ends during hex character entity" + error pos "Document ends during character entity" | entity' decoder pos text (c :: rest) = if c <> #";" then entity' decoder (pos+1) (c :: text) rest @@ -2599,17 +2626,47 @@ fun load_project (userconfig : userconfig) rootpath pintype : project = } end -fun save_lock_file rootpath locks = +fun make_lock_properties locks = + map (fn { libname, id_or_tag } => + (libname, Json.OBJECT [ ("pin", Json.STRING id_or_tag) ])) + locks + +fun make_lock_json_from_properties properties = + Json.OBJECT [ (libobjname, Json.OBJECT properties) ] + +fun make_lock_json locks = + make_lock_json_from_properties (make_lock_properties locks) + +fun save_lock_file_afresh rootpath locks = + let val lock_file = FileBits.project_lock_path rootpath + val lock_json = make_lock_json locks + in + JsonBits.save_json_to lock_file lock_json + end + +fun save_lock_file_updating rootpath locks = let val lock_file = FileBits.project_lock_path rootpath - open Json + val prior_lock_json = JsonBits.load_json_from lock_file + handle IO.Io _ => Json.OBJECT [] + val new_lock_properties = make_lock_properties locks + val updated_prior_properties = + case prior_lock_json of + Json.OBJECT [ (_, Json.OBJECT properties) ] => + map (fn (entry as (lib, _)) => + case List.find (fn (lib', _) => lib = lib') + new_lock_properties of + NONE => entry + | SOME updated => updated) + properties + | _ => [] + val filtered_new_properties = + List.filter (fn (lib, _) => + not (List.exists (fn (lib', _) => lib = lib') + updated_prior_properties)) + new_lock_properties val lock_json = - OBJECT [ - (libobjname, - OBJECT (map (fn { libname, id_or_tag } => - (libname, - OBJECT [ ("pin", STRING id_or_tag) ])) - locks)) - ] + make_lock_json_from_properties + (updated_prior_properties @ filtered_new_properties) in JsonBits.save_json_to lock_file lock_json end @@ -2755,12 +2812,14 @@ fun review_project ({ context, libs } : project) = print_status_header (print_status true) context libs) -fun lock_project ({ context, libs } : project) = +fun lock_project (update_only : libspec list option) + ({ context, libs } : project) = let val _ = if FileBits.verbose () then print ("Scanning IDs for lock file...\n") else () + val to_update = Option.getOpt (update_only, libs) val outcomes = map (fn lib => (lib, AnyLibControl.id_of context lib)) - libs + to_update val locks = List.concat (map (fn (lib : libspec, result) => @@ -2773,7 +2832,9 @@ fun lock_project ({ context, libs } : project) = val _ = print clear_line in if OS.Process.isSuccess return_code - then save_lock_file (#rootpath context) locks + then (if Option.isSome update_only + then save_lock_file_updating + else save_lock_file_afresh) (#rootpath context) locks else (); return_code end @@ -2783,9 +2844,11 @@ fun update_project (project as { context, libs }) = (AnyLibControl.update context) print_outcome_header print_update_outcome context libs - val _ = if List.exists (fn (_, OK _) => true | _ => false) outcomes - then lock_project project - else OS.Process.success + val successes = List.filter (fn (_, OK _) => true | _ => false) + outcomes + val _ = if null successes + then OS.Process.success (* ignored, not the return value *) + else lock_project (SOME (map #1 successes)) project val return_code = return_code_for outcomes in if OS.Process.isSuccess return_code @@ -2819,7 +2882,7 @@ fun with_local_project pintype f = 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 lock () = with_local_project NO_LOCKFILE (lock_project NONE) fun install () = with_local_project USE_LOCKFILE update_project fun version () =