cannam@55: (* cannam@55: DO NOT EDIT THIS FILE. cannam@55: This file is automatically generated from the individual cannam@55: source files in the Repoint repository. cannam@55: *) cannam@54: cannam@54: (* cannam@55: Repoint cannam@54: cannam@54: A simple manager for third-party source code dependencies cannam@54: cannam@55: Copyright 2018 Chris Cannam, Particular Programs Ltd, cannam@55: and Queen Mary, University of London cannam@54: cannam@54: Permission is hereby granted, free of charge, to any person cannam@54: obtaining a copy of this software and associated documentation cannam@54: files (the "Software"), to deal in the Software without cannam@54: restriction, including without limitation the rights to use, copy, cannam@54: modify, merge, publish, distribute, sublicense, and/or sell copies cannam@54: of the Software, and to permit persons to whom the Software is cannam@54: furnished to do so, subject to the following conditions: cannam@54: cannam@54: The above copyright notice and this permission notice shall be cannam@54: included in all copies or substantial portions of the Software. cannam@54: cannam@54: THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, cannam@54: EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF cannam@54: MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND cannam@54: NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR cannam@54: ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF cannam@54: CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION cannam@54: WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. cannam@54: cannam@55: Except as contained in this notice, the names of Chris Cannam, cannam@55: Particular Programs Ltd, and Queen Mary, University of London cannam@55: shall not be used in advertising or otherwise to promote the sale, cannam@55: use or other dealings in this Software without prior written cannam@55: authorization. cannam@54: *) cannam@54: cannam@55: val repoint_version = "0.9.98" cannam@54: cannam@54: cannam@54: datatype vcs = cannam@54: HG | cannam@55: GIT | cannam@55: SVN cannam@54: cannam@54: datatype source = cannam@54: URL_SOURCE of string | cannam@54: SERVICE_SOURCE of { cannam@54: service : string, cannam@54: owner : string option, cannam@54: repo : string option cannam@54: } cannam@54: cannam@54: type id_or_tag = string cannam@54: cannam@54: datatype pin = cannam@54: UNPINNED | cannam@54: PINNED of id_or_tag cannam@54: cannam@54: datatype libstate = cannam@54: ABSENT | cannam@54: CORRECT | cannam@54: SUPERSEDED | cannam@54: WRONG cannam@54: cannam@54: datatype localstate = cannam@54: MODIFIED | cannam@54: LOCK_MISMATCHED | cannam@54: CLEAN cannam@54: cannam@54: datatype branch = cannam@54: BRANCH of string | cannam@54: DEFAULT_BRANCH cannam@54: cannam@54: (* If we can recover from an error, for example by reporting failure cannam@54: for this one thing and going on to the next thing, then the error cannam@54: should usually be returned through a result type rather than an cannam@54: exception. *) cannam@54: cannam@54: datatype 'a result = cannam@54: OK of 'a | cannam@54: ERROR of string cannam@54: cannam@54: type libname = string cannam@54: cannam@54: type libspec = { cannam@54: libname : libname, cannam@54: vcs : vcs, cannam@54: source : source, cannam@54: branch : branch, cannam@54: project_pin : pin, cannam@54: lock_pin : pin cannam@54: } cannam@54: cannam@54: type lock = { cannam@54: libname : libname, cannam@54: id_or_tag : id_or_tag cannam@54: } cannam@54: cannam@54: type remote_spec = { cannam@54: anon : string option, cannam@54: auth : string option cannam@54: } cannam@54: cannam@54: type provider = { cannam@54: service : string, cannam@54: supports : vcs list, cannam@54: remote_spec : remote_spec cannam@54: } cannam@54: cannam@54: type account = { cannam@54: service : string, cannam@54: login : string cannam@54: } cannam@54: cannam@54: type context = { cannam@54: rootpath : string, cannam@54: extdir : string, cannam@54: providers : provider list, cannam@54: accounts : account list cannam@54: } cannam@54: cannam@54: type userconfig = { cannam@54: providers : provider list, cannam@54: accounts : account list cannam@54: } cannam@54: cannam@54: type project = { cannam@54: context : context, cannam@54: libs : libspec list cannam@54: } cannam@54: cannam@55: structure RepointFilenames = struct cannam@55: val project_file = "repoint-project.json" cannam@55: val project_lock_file = "repoint-lock.json" cannam@55: val user_config_file = ".repoint.json" cannam@55: val archive_dir = ".repoint-archive" cannam@54: end cannam@54: cannam@54: signature VCS_CONTROL = sig cannam@54: cannam@55: (** Check whether the given VCS is installed and working *) cannam@55: val is_working : context -> bool result cannam@55: cannam@54: (** Test whether the library is present locally at all *) cannam@54: val exists : context -> libname -> bool result cannam@54: cannam@54: (** Return the id (hash) of the current revision for the library *) cannam@54: val id_of : context -> libname -> id_or_tag result cannam@54: cannam@54: (** Test whether the library is at the given id *) cannam@54: val is_at : context -> libname * id_or_tag -> bool result cannam@54: cannam@54: (** Test whether the library is on the given branch, i.e. is at cannam@54: the branch tip or an ancestor of it *) cannam@54: val is_on_branch : context -> libname * branch -> bool result cannam@54: cannam@54: (** Test whether the library is at the newest revision for the cannam@54: given branch. False may indicate that the branch has advanced cannam@54: or that the library is not on the branch at all. This function cannam@54: may use the network to check for new revisions *) cannam@55: val is_newest : context -> libname * source * branch -> bool result cannam@54: cannam@54: (** Test whether the library is at the newest revision available cannam@54: locally for the given branch. False may indicate that the cannam@54: branch has advanced or that the library is not on the branch cannam@54: at all. This function must not use the network *) cannam@54: val is_newest_locally : context -> libname * branch -> bool result cannam@54: cannam@54: (** Test whether the library has been modified in the local cannam@54: working copy *) cannam@54: val is_modified_locally : context -> libname -> bool result cannam@54: cannam@54: (** Check out, i.e. clone a fresh copy of, the repo for the given cannam@54: library on the given branch *) cannam@54: val checkout : context -> libname * source * branch -> unit result cannam@54: cannam@55: (** Update the library to the given branch tip. Assumes that a cannam@55: local copy of the library already exists *) cannam@55: val update : context -> libname * source * branch -> unit result cannam@54: cannam@54: (** Update the library to the given specific id or tag *) cannam@55: val update_to : context -> libname * source * id_or_tag -> unit result cannam@55: cannam@55: (** Return a URL from which the library can be cloned, given that cannam@55: the local copy already exists. For a DVCS this can be the cannam@55: local copy, but for a centralised VCS it will have to be the cannam@55: remote repository URL. Used for archiving *) cannam@55: val copy_url_for : context -> libname -> string result cannam@54: end cannam@54: cannam@54: signature LIB_CONTROL = sig cannam@54: val review : context -> libspec -> (libstate * localstate) result cannam@54: val status : context -> libspec -> (libstate * localstate) result cannam@55: val update : context -> libspec -> unit result cannam@54: val id_of : context -> libspec -> id_or_tag result cannam@55: val is_working : context -> vcs -> bool result cannam@54: end cannam@54: cannam@54: structure FileBits :> sig cannam@54: val extpath : context -> string cannam@54: val libpath : context -> libname -> string cannam@54: val subpath : context -> libname -> string -> string cannam@54: val command_output : context -> libname -> string list -> string result cannam@54: val command : context -> libname -> string list -> unit result cannam@55: val file_url : string -> string cannam@54: val file_contents : string -> string cannam@54: val mydir : unit -> string cannam@54: val homedir : unit -> string cannam@54: val mkpath : string -> unit result cannam@55: val rmpath : string -> unit result cannam@55: val nonempty_dir_exists : string -> bool cannam@54: val project_spec_path : string -> string cannam@54: val project_lock_path : string -> string cannam@54: val verbose : unit -> bool cannam@54: end = struct cannam@54: cannam@54: fun verbose () = cannam@55: case OS.Process.getEnv "REPOINT_VERBOSE" of cannam@54: SOME "0" => false cannam@54: | SOME _ => true cannam@54: | NONE => false cannam@54: cannam@55: fun split_relative path desc = cannam@55: case OS.Path.fromString path of cannam@55: { isAbs = true, ... } => raise Fail (desc ^ " may not be absolute") cannam@55: | { arcs, ... } => arcs cannam@55: cannam@54: fun extpath ({ rootpath, extdir, ... } : context) = cannam@54: let val { isAbs, vol, arcs } = OS.Path.fromString rootpath cannam@54: in OS.Path.toString { cannam@54: isAbs = isAbs, cannam@54: vol = vol, cannam@55: arcs = arcs @ cannam@55: split_relative extdir "extdir" cannam@54: } cannam@54: end cannam@54: cannam@54: fun subpath ({ rootpath, extdir, ... } : context) libname remainder = cannam@54: (* NB libname is allowed to be a path fragment, e.g. foo/bar *) cannam@54: let val { isAbs, vol, arcs } = OS.Path.fromString rootpath cannam@54: in OS.Path.toString { cannam@54: isAbs = isAbs, cannam@54: vol = vol, cannam@55: arcs = arcs @ cannam@55: split_relative extdir "extdir" @ cannam@55: split_relative libname "library path" @ cannam@55: split_relative remainder "subpath" cannam@54: } cannam@54: end cannam@54: cannam@54: fun libpath context "" = cannam@54: extpath context cannam@54: | libpath context libname = cannam@54: subpath context libname "" cannam@54: cannam@54: fun project_file_path rootpath filename = cannam@54: let val { isAbs, vol, arcs } = OS.Path.fromString rootpath cannam@54: in OS.Path.toString { cannam@54: isAbs = isAbs, cannam@54: vol = vol, cannam@54: arcs = arcs @ [ filename ] cannam@54: } cannam@54: end cannam@54: cannam@54: fun project_spec_path rootpath = cannam@55: project_file_path rootpath (RepointFilenames.project_file) cannam@54: cannam@54: fun project_lock_path rootpath = cannam@55: project_file_path rootpath (RepointFilenames.project_lock_file) cannam@54: cannam@54: fun trim str = cannam@54: hd (String.fields (fn x => x = #"\n" orelse x = #"\r") str) cannam@55: cannam@55: fun file_url path = cannam@55: let val forward_path = cannam@55: String.translate (fn #"\\" => "/" | cannam@55: c => Char.toString c) cannam@55: (OS.Path.mkCanonical path) cannam@55: in cannam@55: (* Path is expected to be absolute already, but if it cannam@55: starts with a drive letter, we'll need an extra slash *) cannam@55: case explode forward_path of cannam@55: #"/"::rest => "file:///" ^ implode rest cannam@55: | _ => "file:///" ^ forward_path cannam@55: end cannam@54: cannam@54: fun file_contents filename = cannam@54: let val stream = TextIO.openIn filename cannam@54: fun read_all str acc = cannam@54: case TextIO.inputLine str of cannam@54: SOME line => read_all str (trim line :: acc) cannam@54: | NONE => rev acc cannam@54: val contents = read_all stream [] cannam@54: val _ = TextIO.closeIn stream cannam@54: in cannam@54: String.concatWith "\n" contents cannam@54: end cannam@54: cannam@54: fun expand_commandline cmdlist = cannam@55: (* We are quite strict about what we accept here, except cannam@54: for the first element in cmdlist which is assumed to be a cannam@55: known command location rather than arbitrary user input. *) cannam@54: let open Char cannam@54: fun quote arg = cannam@54: if List.all cannam@54: (fn c => isAlphaNum c orelse c = #"-" orelse c = #"_") cannam@54: (explode arg) cannam@54: then arg cannam@54: else "\"" ^ arg ^ "\"" cannam@54: fun check arg = cannam@55: let val valid = explode " /#:;?,._-{}@=+" cannam@54: in cannam@54: app (fn c => cannam@54: if isAlphaNum c orelse cannam@55: List.exists (fn v => v = c) valid orelse cannam@55: c > chr 127 cannam@54: then () cannam@54: else raise Fail ("Invalid character '" ^ cannam@54: (Char.toString c) ^ cannam@54: "' in command list")) cannam@54: (explode arg); cannam@54: arg cannam@54: end cannam@54: in cannam@54: String.concatWith " " cannam@54: (map quote cannam@54: (hd cmdlist :: map check (tl cmdlist))) cannam@54: end cannam@54: cannam@54: val tick_cycle = ref 0 cannam@54: val tick_chars = Vector.fromList (map String.str (explode "|/-\\")) cannam@54: cannam@54: fun tick libname cmdlist = cannam@54: let val n = Vector.length tick_chars cannam@54: fun pad_to n str = cannam@54: if n <= String.size str then str cannam@54: else pad_to n (str ^ " ") cannam@54: val name = if libname <> "" then libname cannam@54: else if cmdlist = nil then "" cannam@54: else hd (rev cmdlist) cannam@54: in cannam@54: print (" " ^ cannam@54: Vector.sub(tick_chars, !tick_cycle) ^ " " ^ cannam@55: pad_to 70 name ^ cannam@54: "\r"); cannam@54: tick_cycle := (if !tick_cycle = n - 1 then 0 else 1 + !tick_cycle) cannam@54: end cannam@54: cannam@54: fun run_command context libname cmdlist redirect = cannam@54: let open OS cannam@54: val dir = libpath context libname cannam@54: val cmd = expand_commandline cmdlist cannam@54: val _ = if verbose () cannam@55: then print ("\n=== " ^ dir ^ "\n<<< " ^ cmd ^ "\n") cannam@54: else tick libname cmdlist cannam@54: val _ = FileSys.chDir dir cannam@54: val status = case redirect of cannam@54: NONE => Process.system cmd cannam@54: | SOME file => Process.system (cmd ^ ">" ^ file) cannam@54: in cannam@54: if Process.isSuccess status cannam@54: then OK () cannam@54: else ERROR ("Command failed: " ^ cmd ^ " (in dir " ^ dir ^ ")") cannam@54: end cannam@54: handle ex => ERROR ("Unable to run command: " ^ exnMessage ex) cannam@54: cannam@54: fun command context libname cmdlist = cannam@54: run_command context libname cmdlist NONE cannam@54: cannam@54: fun command_output context libname cmdlist = cannam@54: let open OS cannam@54: val tmpFile = FileSys.tmpName () cannam@54: val result = run_command context libname cmdlist (SOME tmpFile) cannam@54: val contents = file_contents tmpFile cannam@55: val _ = if verbose () cannam@55: then print (">>> \"" ^ contents ^ "\"\n") cannam@55: else () cannam@54: in cannam@54: FileSys.remove tmpFile handle _ => (); cannam@54: case result of cannam@54: OK () => OK contents cannam@54: | ERROR e => ERROR e cannam@54: end cannam@54: cannam@54: fun mydir () = cannam@54: let open OS cannam@54: val { dir, file } = Path.splitDirFile (CommandLine.name ()) cannam@54: in cannam@54: FileSys.realPath cannam@54: (if Path.isAbsolute dir cannam@54: then dir cannam@54: else Path.concat (FileSys.getDir (), dir)) cannam@54: end cannam@54: cannam@54: fun homedir () = cannam@54: (* Failure is not routine, so we use an exception here *) cannam@54: case (OS.Process.getEnv "HOME", cannam@54: OS.Process.getEnv "HOMEPATH") of cannam@54: (SOME home, _) => home cannam@54: | (NONE, SOME home) => home cannam@54: | (NONE, NONE) => cannam@54: raise Fail "Failed to look up home directory from environment" cannam@54: cannam@55: fun mkpath' path = cannam@54: if OS.FileSys.isDir path handle _ => false cannam@54: then OK () cannam@54: else case OS.Path.fromString path of cannam@54: { arcs = nil, ... } => OK () cannam@54: | { isAbs = false, ... } => ERROR "mkpath requires absolute path" cannam@54: | { isAbs, vol, arcs } => cannam@55: case mkpath' (OS.Path.toString { (* parent *) cannam@55: isAbs = isAbs, cannam@55: vol = vol, cannam@55: arcs = rev (tl (rev arcs)) }) of cannam@54: ERROR e => ERROR e cannam@54: | OK () => ((OS.FileSys.mkDir path; OK ()) cannam@54: handle OS.SysErr (e, _) => cannam@54: ERROR ("Directory creation failed: " ^ e)) cannam@55: cannam@55: fun mkpath path = cannam@55: mkpath' (OS.Path.mkCanonical path) cannam@55: cannam@55: fun dir_contents dir = cannam@55: let open OS cannam@55: fun files_from dirstream = cannam@55: case FileSys.readDir dirstream of cannam@55: NONE => [] cannam@55: | SOME file => cannam@55: (* readDir is supposed to filter these, cannam@55: but let's be extra cautious: *) cannam@55: if file = Path.parentArc orelse file = Path.currentArc cannam@55: then files_from dirstream cannam@55: else file :: files_from dirstream cannam@55: val stream = FileSys.openDir dir cannam@55: val files = map (fn f => Path.joinDirFile cannam@55: { dir = dir, file = f }) cannam@55: (files_from stream) cannam@55: val _ = FileSys.closeDir stream cannam@55: in cannam@55: files cannam@55: end cannam@55: cannam@55: fun rmpath' path = cannam@55: let open OS cannam@55: fun remove path = cannam@55: if FileSys.isLink path (* dangling links bother isDir *) cannam@55: then FileSys.remove path cannam@55: else if FileSys.isDir path cannam@55: then (app remove (dir_contents path); FileSys.rmDir path) cannam@55: else FileSys.remove path cannam@55: in cannam@55: (remove path; OK ()) cannam@55: handle SysErr (e, _) => ERROR ("Path removal failed: " ^ e) cannam@55: end cannam@55: cannam@55: fun rmpath path = cannam@55: rmpath' (OS.Path.mkCanonical path) cannam@55: cannam@55: fun nonempty_dir_exists path = cannam@55: let open OS.FileSys cannam@55: in cannam@55: (not (isLink path) andalso cannam@55: isDir path andalso cannam@55: dir_contents path <> []) cannam@55: handle _ => false cannam@55: end cannam@55: cannam@54: end cannam@54: cannam@54: functor LibControlFn (V: VCS_CONTROL) :> LIB_CONTROL = struct cannam@54: cannam@54: (* Valid states for unpinned libraries: cannam@54: cannam@54: - CORRECT: We are on the right branch and are up-to-date with cannam@54: it as far as we can tell. (If not using the network, this cannam@54: should be reported to user as "Present" rather than "Correct" cannam@54: as the remote repo may have advanced without us knowing.) cannam@54: cannam@54: - SUPERSEDED: We are on the right branch but we can see that cannam@54: there is a newer revision either locally or on the remote (in cannam@54: Git terms, we are at an ancestor of the desired branch tip). cannam@54: cannam@54: - WRONG: We are on the wrong branch (in Git terms, we are not cannam@54: at the desired branch tip or any ancestor of it). cannam@54: cannam@54: - ABSENT: Repo doesn't exist here at all. cannam@54: cannam@54: Valid states for pinned libraries: cannam@54: cannam@54: - CORRECT: We are at the pinned revision. cannam@54: cannam@54: - WRONG: We are at any revision other than the pinned one. cannam@54: cannam@54: - ABSENT: Repo doesn't exist here at all. cannam@54: *) cannam@54: cannam@54: fun check with_network context cannam@55: ({ libname, source, branch, cannam@55: project_pin, lock_pin, ... } : libspec) = cannam@54: let fun check_unpinned () = cannam@55: let val newest = cannam@55: if with_network cannam@55: then V.is_newest context (libname, source, branch) cannam@55: else V.is_newest_locally context (libname, branch) cannam@54: in cannam@55: case newest of cannam@54: ERROR e => ERROR e cannam@54: | OK true => OK CORRECT cannam@54: | OK false => cannam@54: case V.is_on_branch context (libname, branch) of cannam@54: ERROR e => ERROR e cannam@54: | OK true => OK SUPERSEDED cannam@54: | OK false => OK WRONG cannam@54: end cannam@54: fun check_pinned target = cannam@54: case V.is_at context (libname, target) of cannam@54: ERROR e => ERROR e cannam@54: | OK true => OK CORRECT cannam@54: | OK false => OK WRONG cannam@54: fun check_remote () = cannam@54: case project_pin of cannam@54: UNPINNED => check_unpinned () cannam@54: | PINNED target => check_pinned target cannam@54: fun check_local () = cannam@54: case V.is_modified_locally context libname of cannam@54: ERROR e => ERROR e cannam@54: | OK true => OK MODIFIED cannam@54: | OK false => cannam@54: case lock_pin of cannam@54: UNPINNED => OK CLEAN cannam@54: | PINNED target => cannam@54: case V.is_at context (libname, target) of cannam@54: ERROR e => ERROR e cannam@54: | OK true => OK CLEAN cannam@54: | OK false => OK LOCK_MISMATCHED cannam@54: in cannam@54: case V.exists context libname of cannam@54: ERROR e => ERROR e cannam@54: | OK false => OK (ABSENT, CLEAN) cannam@54: | OK true => cannam@54: case (check_remote (), check_local ()) of cannam@54: (ERROR e, _) => ERROR e cannam@54: | (_, ERROR e) => ERROR e cannam@54: | (OK r, OK l) => OK (r, l) cannam@54: end cannam@54: cannam@54: val review = check true cannam@54: val status = check false cannam@54: cannam@54: fun update context cannam@54: ({ libname, source, branch, cannam@54: project_pin, lock_pin, ... } : libspec) = cannam@54: let fun update_unpinned () = cannam@55: case V.is_newest context (libname, source, branch) of cannam@54: ERROR e => ERROR e cannam@55: | OK true => OK () cannam@55: | OK false => V.update context (libname, source, branch) cannam@54: fun update_pinned target = cannam@54: case V.is_at context (libname, target) of cannam@54: ERROR e => ERROR e cannam@55: | OK true => OK () cannam@55: | OK false => V.update_to context (libname, source, target) cannam@54: fun update' () = cannam@54: case lock_pin of cannam@54: PINNED target => update_pinned target cannam@54: | UNPINNED => cannam@54: case project_pin of cannam@54: PINNED target => update_pinned target cannam@54: | UNPINNED => update_unpinned () cannam@54: in cannam@54: case V.exists context libname of cannam@54: ERROR e => ERROR e cannam@54: | OK true => update' () cannam@54: | OK false => cannam@54: case V.checkout context (libname, source, branch) of cannam@54: ERROR e => ERROR e cannam@54: | OK () => update' () cannam@54: end cannam@54: cannam@54: fun id_of context ({ libname, ... } : libspec) = cannam@54: V.id_of context libname cannam@55: cannam@55: fun is_working context vcs = cannam@55: V.is_working context cannam@54: cannam@54: end cannam@54: cannam@54: (* Simple Standard ML JSON parser cannam@54: https://bitbucket.org/cannam/sml-simplejson cannam@55: Copyright 2017 Chris Cannam. BSD licence. cannam@54: Parts based on the JSON parser in the Ponyo library by Phil Eaton. cannam@54: *) cannam@54: cannam@54: signature JSON = sig cannam@54: cannam@54: datatype json = OBJECT of (string * json) list cannam@54: | ARRAY of json list cannam@54: | NUMBER of real cannam@54: | STRING of string cannam@54: | BOOL of bool cannam@54: | NULL cannam@54: cannam@54: datatype 'a result = OK of 'a cannam@54: | ERROR of string cannam@54: cannam@54: val parse : string -> json result cannam@54: val serialise : json -> string cannam@54: val serialiseIndented : json -> string cannam@54: cannam@54: end cannam@54: cannam@54: structure Json :> JSON = struct cannam@54: cannam@54: datatype json = OBJECT of (string * json) list cannam@54: | ARRAY of json list cannam@54: | NUMBER of real cannam@54: | STRING of string cannam@54: | BOOL of bool cannam@54: | NULL cannam@54: cannam@54: datatype 'a result = OK of 'a cannam@54: | ERROR of string cannam@54: cannam@54: structure T = struct cannam@54: datatype token = NUMBER of char list cannam@54: | STRING of string cannam@54: | BOOL of bool cannam@54: | NULL cannam@54: | CURLY_L cannam@54: | CURLY_R cannam@54: | SQUARE_L cannam@54: | SQUARE_R cannam@54: | COLON cannam@54: | COMMA cannam@54: cannam@54: fun toString t = cannam@54: case t of NUMBER digits => implode digits cannam@54: | STRING s => s cannam@54: | BOOL b => Bool.toString b cannam@54: | NULL => "null" cannam@54: | CURLY_L => "{" cannam@54: | CURLY_R => "}" cannam@54: | SQUARE_L => "[" cannam@54: | SQUARE_R => "]" cannam@54: | COLON => ":" cannam@54: | COMMA => "," cannam@54: end cannam@54: cannam@54: fun bmpToUtf8 cp = (* convert a codepoint in Unicode BMP to utf8 bytes *) cannam@54: let open Word cannam@54: infix 6 orb andb >> cannam@54: in cannam@54: map (Char.chr o toInt) cannam@54: (if cp < 0wx80 then cannam@54: [cp] cannam@54: else if cp < 0wx800 then cannam@54: [0wxc0 orb (cp >> 0w6), 0wx80 orb (cp andb 0wx3f)] cannam@54: else if cp < 0wx10000 then cannam@54: [0wxe0 orb (cp >> 0w12), cannam@54: 0wx80 orb ((cp >> 0w6) andb 0wx3f), cannam@54: 0wx80 orb (cp andb 0wx3f)] cannam@54: else raise Fail ("Invalid BMP point " ^ (Word.toString cp))) cannam@54: end cannam@54: cannam@54: fun error pos text = ERROR (text ^ " at character position " ^ cannam@54: Int.toString (pos - 1)) cannam@54: fun token_error pos = error pos ("Unexpected token") cannam@54: cannam@54: fun lexNull pos acc (#"u" :: #"l" :: #"l" :: xs) = cannam@54: lex (pos + 3) (T.NULL :: acc) xs cannam@54: | lexNull pos acc _ = token_error pos cannam@54: cannam@54: and lexTrue pos acc (#"r" :: #"u" :: #"e" :: xs) = cannam@54: lex (pos + 3) (T.BOOL true :: acc) xs cannam@54: | lexTrue pos acc _ = token_error pos cannam@54: cannam@54: and lexFalse pos acc (#"a" :: #"l" :: #"s" :: #"e" :: xs) = cannam@54: lex (pos + 4) (T.BOOL false :: acc) xs cannam@54: | lexFalse pos acc _ = token_error pos cannam@54: cannam@54: and lexChar tok pos acc xs = cannam@54: lex pos (tok :: acc) xs cannam@54: cannam@54: and lexString pos acc cc = cannam@54: let datatype escaped = ESCAPED | NORMAL cannam@54: fun lexString' pos text ESCAPED [] = cannam@54: error pos "End of input during escape sequence" cannam@54: | lexString' pos text NORMAL [] = cannam@54: error pos "End of input during string" cannam@54: | lexString' pos text ESCAPED (x :: xs) = cannam@54: let fun esc c = lexString' (pos + 1) (c :: text) NORMAL xs cannam@54: in case x of cannam@54: #"\"" => esc x cannam@54: | #"\\" => esc x cannam@54: | #"/" => esc x cannam@54: | #"b" => esc #"\b" cannam@54: | #"f" => esc #"\f" cannam@54: | #"n" => esc #"\n" cannam@54: | #"r" => esc #"\r" cannam@54: | #"t" => esc #"\t" cannam@54: | _ => error pos ("Invalid escape \\" ^ cannam@54: Char.toString x) cannam@54: end cannam@54: | lexString' pos text NORMAL (#"\\" :: #"u" ::a::b::c::d:: xs) = cannam@54: if List.all Char.isHexDigit [a,b,c,d] cannam@54: then case Word.fromString ("0wx" ^ (implode [a,b,c,d])) of cannam@54: SOME w => (let val utf = rev (bmpToUtf8 w) in cannam@54: lexString' (pos + 6) (utf @ text) cannam@54: NORMAL xs cannam@54: end cannam@54: handle Fail err => error pos err) cannam@54: | NONE => error pos "Invalid Unicode BMP escape sequence" cannam@54: else error pos "Invalid Unicode BMP escape sequence" cannam@54: | lexString' pos text NORMAL (x :: xs) = cannam@54: if Char.ord x < 0x20 cannam@54: then error pos "Invalid unescaped control character" cannam@54: else cannam@54: case x of cannam@54: #"\"" => OK (rev text, xs, pos + 1) cannam@54: | #"\\" => lexString' (pos + 1) text ESCAPED xs cannam@54: | _ => lexString' (pos + 1) (x :: text) NORMAL xs cannam@54: in cannam@54: case lexString' pos [] NORMAL cc of cannam@54: OK (text, rest, newpos) => cannam@54: lex newpos (T.STRING (implode text) :: acc) rest cannam@54: | ERROR e => ERROR e cannam@54: end cannam@54: cannam@54: and lexNumber firstChar pos acc cc = cannam@54: let val valid = explode ".+-e" cannam@54: fun lexNumber' pos digits [] = (rev digits, [], pos) cannam@54: | lexNumber' pos digits (x :: xs) = cannam@54: if x = #"E" then lexNumber' (pos + 1) (#"e" :: digits) xs cannam@54: else if Char.isDigit x orelse List.exists (fn c => x = c) valid cannam@54: then lexNumber' (pos + 1) (x :: digits) xs cannam@54: else (rev digits, x :: xs, pos) cannam@54: val (digits, rest, newpos) = cannam@54: lexNumber' (pos - 1) [] (firstChar :: cc) cannam@54: in cannam@54: case digits of cannam@54: [] => token_error pos cannam@54: | _ => lex newpos (T.NUMBER digits :: acc) rest cannam@54: end cannam@54: cannam@54: and lex pos acc [] = OK (rev acc) cannam@54: | lex pos acc (x::xs) = cannam@54: (case x of cannam@54: #" " => lex cannam@54: | #"\t" => lex cannam@54: | #"\n" => lex cannam@54: | #"\r" => lex cannam@54: | #"{" => lexChar T.CURLY_L cannam@54: | #"}" => lexChar T.CURLY_R cannam@54: | #"[" => lexChar T.SQUARE_L cannam@54: | #"]" => lexChar T.SQUARE_R cannam@54: | #":" => lexChar T.COLON cannam@54: | #"," => lexChar T.COMMA cannam@54: | #"\"" => lexString cannam@54: | #"t" => lexTrue cannam@54: | #"f" => lexFalse cannam@54: | #"n" => lexNull cannam@54: | x => lexNumber x) (pos + 1) acc xs cannam@54: cannam@54: fun show [] = "end of input" cannam@54: | show (tok :: _) = T.toString tok cannam@54: cannam@54: fun parseNumber digits = cannam@54: (* Note lexNumber already case-insensitised the E for us *) cannam@54: let open Char cannam@54: cannam@54: fun okExpDigits [] = false cannam@54: | okExpDigits (c :: []) = isDigit c cannam@54: | okExpDigits (c :: cs) = isDigit c andalso okExpDigits cs cannam@54: cannam@54: fun okExponent [] = false cannam@54: | okExponent (#"+" :: cs) = okExpDigits cs cannam@54: | okExponent (#"-" :: cs) = okExpDigits cs cannam@54: | okExponent cc = okExpDigits cc cannam@54: cannam@54: fun okFracTrailing [] = true cannam@54: | okFracTrailing (c :: cs) = cannam@54: (isDigit c andalso okFracTrailing cs) orelse cannam@54: (c = #"e" andalso okExponent cs) cannam@54: cannam@54: fun okFraction [] = false cannam@54: | okFraction (c :: cs) = cannam@54: isDigit c andalso okFracTrailing cs cannam@54: cannam@54: fun okPosTrailing [] = true cannam@54: | okPosTrailing (#"." :: cs) = okFraction cs cannam@54: | okPosTrailing (#"e" :: cs) = okExponent cs cannam@54: | okPosTrailing (c :: cs) = cannam@54: isDigit c andalso okPosTrailing cs cannam@54: cannam@54: fun okPositive [] = false cannam@54: | okPositive (#"0" :: []) = true cannam@54: | okPositive (#"0" :: #"." :: cs) = okFraction cs cannam@54: | okPositive (#"0" :: #"e" :: cs) = okExponent cs cannam@54: | okPositive (#"0" :: cs) = false cannam@54: | okPositive (c :: cs) = isDigit c andalso okPosTrailing cs cannam@54: cannam@54: fun okNumber (#"-" :: cs) = okPositive cs cannam@54: | okNumber cc = okPositive cc cannam@54: in cannam@54: if okNumber digits cannam@54: then case Real.fromString (implode digits) of cannam@54: NONE => ERROR "Number out of range" cannam@54: | SOME r => OK r cannam@54: else ERROR ("Invalid number \"" ^ (implode digits) ^ "\"") cannam@54: end cannam@54: cannam@54: fun parseObject (T.CURLY_R :: xs) = OK (OBJECT [], xs) cannam@54: | parseObject tokens = cannam@54: let fun parsePair (T.STRING key :: T.COLON :: xs) = cannam@54: (case parseTokens xs of cannam@54: ERROR e => ERROR e cannam@54: | OK (j, xs) => OK ((key, j), xs)) cannam@54: | parsePair other = cannam@54: ERROR ("Object key/value pair expected around \"" ^ cannam@54: show other ^ "\"") cannam@54: fun parseObject' acc [] = ERROR "End of input during object" cannam@54: | parseObject' acc tokens = cannam@54: case parsePair tokens of cannam@54: ERROR e => ERROR e cannam@54: | OK (pair, T.COMMA :: xs) => cannam@54: parseObject' (pair :: acc) xs cannam@54: | OK (pair, T.CURLY_R :: xs) => cannam@54: OK (OBJECT (rev (pair :: acc)), xs) cannam@54: | OK (_, _) => ERROR "Expected , or } after object element" cannam@54: in cannam@54: parseObject' [] tokens cannam@54: end cannam@54: cannam@54: and parseArray (T.SQUARE_R :: xs) = OK (ARRAY [], xs) cannam@54: | parseArray tokens = cannam@54: let fun parseArray' acc [] = ERROR "End of input during array" cannam@54: | parseArray' acc tokens = cannam@54: case parseTokens tokens of cannam@54: ERROR e => ERROR e cannam@54: | OK (j, T.COMMA :: xs) => parseArray' (j :: acc) xs cannam@54: | OK (j, T.SQUARE_R :: xs) => OK (ARRAY (rev (j :: acc)), xs) cannam@54: | OK (_, _) => ERROR "Expected , or ] after array element" cannam@54: in cannam@54: parseArray' [] tokens cannam@54: end cannam@54: cannam@54: and parseTokens [] = ERROR "Value expected" cannam@54: | parseTokens (tok :: xs) = cannam@54: (case tok of cannam@54: T.NUMBER d => (case parseNumber d of cannam@54: OK r => OK (NUMBER r, xs) cannam@54: | ERROR e => ERROR e) cannam@54: | T.STRING s => OK (STRING s, xs) cannam@54: | T.BOOL b => OK (BOOL b, xs) cannam@54: | T.NULL => OK (NULL, xs) cannam@54: | T.CURLY_L => parseObject xs cannam@54: | T.SQUARE_L => parseArray xs cannam@54: | _ => ERROR ("Unexpected token " ^ T.toString tok ^ cannam@54: " before " ^ show xs)) cannam@54: cannam@54: fun parse str = cannam@54: case lex 1 [] (explode str) of cannam@54: ERROR e => ERROR e cannam@54: | OK tokens => case parseTokens tokens of cannam@54: OK (value, []) => OK value cannam@54: | OK (_, _) => ERROR "Extra data after input" cannam@54: | ERROR e => ERROR e cannam@54: cannam@54: fun stringEscape s = cannam@54: let fun esc x = [x, #"\\"] cannam@54: fun escape' acc [] = rev acc cannam@54: | escape' acc (x :: xs) = cannam@54: escape' (case x of cannam@54: #"\"" => esc x @ acc cannam@54: | #"\\" => esc x @ acc cannam@54: | #"\b" => esc #"b" @ acc cannam@54: | #"\f" => esc #"f" @ acc cannam@54: | #"\n" => esc #"n" @ acc cannam@54: | #"\r" => esc #"r" @ acc cannam@54: | #"\t" => esc #"t" @ acc cannam@54: | _ => cannam@54: let val c = Char.ord x cannam@54: in cannam@54: if c < 0x20 cannam@54: then let val hex = Word.toString (Word.fromInt c) cannam@54: in (rev o explode) (if c < 0x10 cannam@54: then ("\\u000" ^ hex) cannam@54: else ("\\u00" ^ hex)) cannam@54: end @ acc cannam@54: else cannam@54: x :: acc cannam@54: end) cannam@54: xs cannam@54: in cannam@54: implode (escape' [] (explode s)) cannam@54: end cannam@54: cannam@54: fun serialise json = cannam@54: case json of cannam@54: OBJECT pp => "{" ^ String.concatWith cannam@54: "," (map (fn (key, value) => cannam@54: serialise (STRING key) ^ ":" ^ cannam@54: serialise value) pp) ^ cannam@54: "}" cannam@54: | ARRAY arr => "[" ^ String.concatWith "," (map serialise arr) ^ "]" cannam@54: | NUMBER n => implode (map (fn #"~" => #"-" | c => c) cannam@54: (explode (Real.toString n))) cannam@54: | STRING s => "\"" ^ stringEscape s ^ "\"" cannam@54: | BOOL b => Bool.toString b cannam@54: | NULL => "null" cannam@54: cannam@54: fun serialiseIndented json = cannam@54: let fun indent 0 = "" cannam@54: | indent i = " " ^ indent (i - 1) cannam@54: fun serialiseIndented' i json = cannam@54: let val ser = serialiseIndented' (i + 1) cannam@54: in cannam@54: case json of cannam@54: OBJECT [] => "{}" cannam@54: | ARRAY [] => "[]" cannam@54: | OBJECT pp => "{\n" ^ indent (i + 1) ^ cannam@54: String.concatWith cannam@54: (",\n" ^ indent (i + 1)) cannam@54: (map (fn (key, value) => cannam@54: ser (STRING key) ^ ": " ^ cannam@54: ser value) pp) ^ cannam@54: "\n" ^ indent i ^ "}" cannam@54: | ARRAY arr => "[\n" ^ indent (i + 1) ^ cannam@54: String.concatWith cannam@54: (",\n" ^ indent (i + 1)) cannam@54: (map ser arr) ^ cannam@54: "\n" ^ indent i ^ "]" cannam@54: | other => serialise other cannam@54: end cannam@54: in cannam@54: serialiseIndented' 0 json ^ "\n" cannam@54: end cannam@54: cannam@54: end cannam@54: cannam@54: cannam@54: structure JsonBits :> sig cannam@55: exception Config of string cannam@54: val load_json_from : string -> Json.json (* filename -> json *) cannam@54: val save_json_to : string -> Json.json -> unit cannam@54: val lookup_optional : Json.json -> string list -> Json.json option cannam@54: val lookup_optional_string : Json.json -> string list -> string option cannam@54: val lookup_mandatory : Json.json -> string list -> Json.json cannam@54: val lookup_mandatory_string : Json.json -> string list -> string cannam@54: end = struct cannam@54: cannam@55: exception Config of string cannam@55: cannam@54: fun load_json_from filename = cannam@54: case Json.parse (FileBits.file_contents filename) of cannam@54: Json.OK json => json cannam@55: | Json.ERROR e => raise Config ("Failed to parse file: " ^ e) cannam@54: cannam@54: fun save_json_to filename json = cannam@54: (* using binary I/O to avoid ever writing CR/LF line endings *) cannam@54: let val jstr = Json.serialiseIndented json cannam@54: val stream = BinIO.openOut filename cannam@54: in cannam@54: BinIO.output (stream, Byte.stringToBytes jstr); cannam@54: BinIO.closeOut stream cannam@54: end cannam@54: cannam@54: fun lookup_optional json kk = cannam@54: let fun lookup key = cannam@54: case json of cannam@54: Json.OBJECT kvs => cannam@55: (case List.filter (fn (k, v) => k = key) kvs of cannam@55: [] => NONE cannam@55: | [(_,v)] => SOME v cannam@55: | _ => raise Config ("Duplicate key: " ^ cannam@55: (String.concatWith " -> " kk))) cannam@55: | _ => raise Config "Object expected" cannam@54: in cannam@54: case kk of cannam@54: [] => NONE cannam@54: | key::[] => lookup key cannam@54: | key::kk => case lookup key of cannam@54: NONE => NONE cannam@54: | SOME j => lookup_optional j kk cannam@54: end cannam@54: cannam@54: fun lookup_optional_string json kk = cannam@54: case lookup_optional json kk of cannam@54: SOME (Json.STRING s) => SOME s cannam@55: | SOME _ => raise Config ("Value (if present) must be string: " ^ cannam@55: (String.concatWith " -> " kk)) cannam@54: | NONE => NONE cannam@54: cannam@54: fun lookup_mandatory json kk = cannam@54: case lookup_optional json kk of cannam@54: SOME v => v cannam@55: | NONE => raise Config ("Value is mandatory: " ^ cannam@55: (String.concatWith " -> " kk)) cannam@54: cannam@54: fun lookup_mandatory_string json kk = cannam@54: case lookup_optional json kk of cannam@54: SOME (Json.STRING s) => s cannam@55: | _ => raise Config ("Value must be string: " ^ cannam@55: (String.concatWith " -> " kk)) cannam@54: end cannam@54: cannam@54: structure Provider :> sig cannam@54: val load_providers : Json.json -> provider list cannam@54: val load_more_providers : provider list -> Json.json -> provider list cannam@54: val remote_url : context -> vcs -> source -> libname -> string cannam@54: end = struct cannam@54: cannam@54: val known_providers : provider list = cannam@54: [ { cannam@54: service = "bitbucket", cannam@54: supports = [HG, GIT], cannam@54: remote_spec = { cannam@54: anon = SOME "https://bitbucket.org/{owner}/{repository}", cannam@54: auth = SOME "ssh://{vcs}@bitbucket.org/{owner}/{repository}" cannam@54: } cannam@54: }, cannam@54: { cannam@54: service = "github", cannam@54: supports = [GIT], cannam@54: remote_spec = { cannam@54: anon = SOME "https://github.com/{owner}/{repository}", cannam@54: auth = SOME "ssh://{vcs}@github.com/{owner}/{repository}" cannam@54: } cannam@54: } cannam@54: ] cannam@54: cannam@54: fun vcs_name vcs = cannam@55: case vcs of HG => "hg" cannam@55: | GIT => "git" cannam@55: | SVN => "svn" cannam@54: cannam@54: fun vcs_from_name name = cannam@55: case name of "hg" => HG cannam@55: | "git" => GIT cannam@55: | "svn" => SVN cannam@54: | other => raise Fail ("Unknown vcs name \"" ^ name ^ "\"") cannam@54: cannam@54: fun load_more_providers previously_loaded json = cannam@54: let open JsonBits cannam@54: fun load pjson pname : provider = cannam@54: { cannam@54: service = pname, cannam@54: supports = cannam@54: case lookup_mandatory pjson ["vcs"] of cannam@54: Json.ARRAY vv => cannam@54: map (fn (Json.STRING v) => vcs_from_name v cannam@54: | _ => raise Fail "Strings expected in vcs array") cannam@54: vv cannam@54: | _ => raise Fail "Array expected for vcs", cannam@54: remote_spec = { cannam@54: anon = lookup_optional_string pjson ["anonymous"], cannam@54: auth = lookup_optional_string pjson ["authenticated"] cannam@54: } cannam@54: } cannam@54: val loaded = cannam@54: case lookup_optional json ["services"] of cannam@54: NONE => [] cannam@54: | SOME (Json.OBJECT pl) => map (fn (k, v) => load v k) pl cannam@54: | _ => raise Fail "Object expected for services in config" cannam@54: val newly_loaded = cannam@54: List.filter (fn p => not (List.exists (fn pp => #service p = cannam@54: #service pp) cannam@54: previously_loaded)) cannam@54: loaded cannam@54: in cannam@54: previously_loaded @ newly_loaded cannam@54: end cannam@54: cannam@54: fun load_providers json = cannam@54: load_more_providers known_providers json cannam@54: cannam@54: fun expand_spec spec { vcs, service, owner, repo } login = cannam@54: (* ugly *) cannam@54: let fun replace str = cannam@54: case str of cannam@54: "vcs" => vcs_name vcs cannam@54: | "service" => service cannam@54: | "owner" => cannam@54: (case owner of cannam@54: SOME ostr => ostr cannam@54: | NONE => raise Fail ("Owner not specified for service " ^ cannam@54: service)) cannam@54: | "repository" => repo cannam@54: | "account" => cannam@54: (case login of cannam@54: SOME acc => acc cannam@54: | NONE => raise Fail ("Account not given for service " ^ cannam@54: service)) cannam@54: | other => raise Fail ("Unknown variable \"" ^ other ^ cannam@54: "\" in spec for service " ^ service) cannam@54: fun expand' acc sstr = cannam@54: case Substring.splitl (fn c => c <> #"{") sstr of cannam@54: (pfx, sfx) => cannam@54: if Substring.isEmpty sfx cannam@54: then rev (pfx :: acc) cannam@54: else cannam@54: case Substring.splitl (fn c => c <> #"}") sfx of cannam@54: (tok, remainder) => cannam@54: if Substring.isEmpty remainder cannam@54: then rev (tok :: pfx :: acc) cannam@54: else let val replacement = cannam@54: replace cannam@54: (* tok begins with "{": *) cannam@54: (Substring.string cannam@54: (Substring.triml 1 tok)) cannam@54: in cannam@54: expand' (Substring.full replacement :: cannam@54: pfx :: acc) cannam@54: (* remainder begins with "}": *) cannam@54: (Substring.triml 1 remainder) cannam@54: end cannam@54: in cannam@54: Substring.concat (expand' [] (Substring.full spec)) cannam@54: end cannam@54: cannam@54: fun provider_url req login providers = cannam@54: case providers of cannam@54: [] => raise Fail ("Unknown service \"" ^ (#service req) ^ cannam@54: "\" for vcs \"" ^ (vcs_name (#vcs req)) ^ "\"") cannam@54: | ({ service, supports, remote_spec : remote_spec } :: rest) => cannam@54: if service <> (#service req) orelse cannam@54: not (List.exists (fn v => v = (#vcs req)) supports) cannam@54: then provider_url req login rest cannam@54: else cannam@54: case (login, #auth remote_spec, #anon remote_spec) of cannam@54: (SOME _, SOME auth, _) => expand_spec auth req login cannam@54: | (SOME _, _, SOME anon) => expand_spec anon req NONE cannam@54: | (NONE, _, SOME anon) => expand_spec anon req NONE cannam@54: | _ => raise Fail ("No suitable anonymous or authenticated " ^ cannam@54: "URL spec provided for service \"" ^ cannam@54: service ^ "\"") cannam@54: cannam@54: fun login_for ({ accounts, ... } : context) service = cannam@54: case List.find (fn a => service = #service a) accounts of cannam@54: SOME { login, ... } => SOME login cannam@54: | NONE => NONE cannam@55: cannam@55: fun reponame_for path = cannam@55: case String.tokens (fn c => c = #"/") path of cannam@55: [] => raise Fail "Non-empty library path required" cannam@55: | toks => hd (rev toks) cannam@55: cannam@54: fun remote_url (context : context) vcs source libname = cannam@54: case source of cannam@54: URL_SOURCE u => u cannam@54: | SERVICE_SOURCE { service, owner, repo } => cannam@54: provider_url { vcs = vcs, cannam@54: service = service, cannam@54: owner = owner, cannam@54: repo = case repo of cannam@54: SOME r => r cannam@55: | NONE => reponame_for libname } cannam@54: (login_for context service) cannam@54: (#providers context) cannam@54: end cannam@54: cannam@54: structure HgControl :> VCS_CONTROL = struct cannam@55: cannam@55: (* Pulls always use an explicit URL, never just the default cannam@55: remote, in order to ensure we update properly if the location cannam@55: given in the project file changes. *) cannam@55: cannam@54: type vcsstate = { id: string, modified: bool, cannam@54: branch: string, tags: string list } cannam@54: cannam@55: val hg_program = "hg" cannam@55: cannam@55: val hg_args = [ "--config", "ui.interactive=true", cannam@55: "--config", "ui.merge=:merge" ] cannam@54: cannam@54: fun hg_command context libname args = cannam@55: FileBits.command context libname (hg_program :: hg_args @ args) cannam@54: cannam@54: fun hg_command_output context libname args = cannam@55: FileBits.command_output context libname (hg_program :: hg_args @ args) cannam@55: cannam@55: fun is_working context = cannam@55: case hg_command_output context "" ["--version"] of cannam@55: OK "" => OK false cannam@55: | OK _ => OK true cannam@55: | ERROR e => ERROR e cannam@55: cannam@54: fun exists context libname = cannam@54: OK (OS.FileSys.isDir (FileBits.subpath context libname ".hg")) cannam@54: handle _ => OK false cannam@54: cannam@54: fun remote_for context (libname, source) = cannam@54: Provider.remote_url context HG source libname cannam@54: cannam@54: fun current_state context libname : vcsstate result = cannam@54: let fun is_branch text = text <> "" andalso #"(" = hd (explode text) cannam@54: and extract_branch b = cannam@54: if is_branch b (* need to remove enclosing parens *) cannam@54: then (implode o rev o tl o rev o tl o explode) b cannam@54: else "default" cannam@54: and is_modified id = id <> "" andalso #"+" = hd (rev (explode id)) cannam@54: and extract_id id = cannam@54: if is_modified id (* need to remove trailing "+" *) cannam@54: then (implode o rev o tl o rev o explode) id cannam@54: else id cannam@54: and split_tags tags = String.tokens (fn c => c = #"/") tags cannam@54: and state_for (id, branch, tags) = cannam@54: OK { id = extract_id id, cannam@54: modified = is_modified id, cannam@54: branch = extract_branch branch, cannam@54: tags = split_tags tags } cannam@54: in cannam@54: case hg_command_output context libname ["id"] of cannam@54: ERROR e => ERROR e cannam@54: | OK out => cannam@54: case String.tokens (fn x => x = #" ") out of cannam@54: [id, branch, tags] => state_for (id, branch, tags) cannam@54: | [id, other] => if is_branch other cannam@54: then state_for (id, other, "") cannam@54: else state_for (id, "", other) cannam@54: | [id] => state_for (id, "", "") cannam@54: | _ => ERROR ("Unexpected output from hg id: " ^ out) cannam@54: end cannam@54: cannam@54: fun branch_name branch = case branch of cannam@54: DEFAULT_BRANCH => "default" cannam@54: | BRANCH "" => "default" cannam@54: | BRANCH b => b cannam@54: cannam@54: fun id_of context libname = cannam@54: case current_state context libname of cannam@54: ERROR e => ERROR e cannam@54: | OK { id, ... } => OK id cannam@54: cannam@54: fun is_at context (libname, id_or_tag) = cannam@54: case current_state context libname of cannam@54: ERROR e => ERROR e cannam@54: | OK { id, tags, ... } => cannam@54: OK (String.isPrefix id_or_tag id orelse cannam@54: String.isPrefix id id_or_tag orelse cannam@54: List.exists (fn t => t = id_or_tag) tags) cannam@54: cannam@54: fun is_on_branch context (libname, b) = cannam@54: case current_state context libname of cannam@54: ERROR e => ERROR e cannam@54: | OK { branch, ... } => OK (branch = branch_name b) cannam@54: cannam@54: fun is_newest_locally context (libname, branch) = cannam@54: case hg_command_output context libname cannam@54: ["log", "-l1", cannam@54: "-b", branch_name branch, cannam@54: "--template", "{node}"] of cannam@55: ERROR e => OK false (* desired branch does not exist *) cannam@54: | OK newest_in_repo => is_at context (libname, newest_in_repo) cannam@54: cannam@55: fun pull context (libname, source) = cannam@55: let val url = remote_for context (libname, source) cannam@55: in cannam@55: hg_command context libname cannam@55: (if FileBits.verbose () cannam@55: then ["pull", url] cannam@55: else ["pull", "-q", url]) cannam@55: end cannam@54: cannam@55: fun is_newest context (libname, source, branch) = cannam@54: case is_newest_locally context (libname, branch) of cannam@54: ERROR e => ERROR e cannam@54: | OK false => OK false cannam@54: | OK true => cannam@55: case pull context (libname, source) of cannam@54: ERROR e => ERROR e cannam@54: | _ => is_newest_locally context (libname, branch) cannam@54: cannam@54: fun is_modified_locally context libname = cannam@54: case current_state context libname of cannam@54: ERROR e => ERROR e cannam@54: | OK { modified, ... } => OK modified cannam@54: cannam@54: fun checkout context (libname, source, branch) = cannam@54: let val url = remote_for context (libname, source) cannam@54: in cannam@55: (* make the lib dir rather than just the ext dir, since cannam@55: the lib dir might be nested and hg will happily check cannam@55: out into an existing empty dir anyway *) cannam@55: case FileBits.mkpath (FileBits.libpath context libname) of cannam@54: ERROR e => ERROR e cannam@54: | _ => hg_command context "" cannam@54: ["clone", "-u", branch_name branch, cannam@54: url, libname] cannam@54: end cannam@54: cannam@55: fun update context (libname, source, branch) = cannam@55: let val pull_result = pull context (libname, source) cannam@54: in cannam@54: case hg_command context libname ["update", branch_name branch] of cannam@54: ERROR e => ERROR e cannam@54: | _ => cannam@54: case pull_result of cannam@54: ERROR e => ERROR e cannam@55: | _ => OK () cannam@54: end cannam@54: cannam@55: fun update_to context (libname, _, "") = cannam@54: ERROR "Non-empty id (tag or revision id) required for update_to" cannam@55: | update_to context (libname, source, id) = cannam@55: let val pull_result = pull context (libname, source) cannam@54: in cannam@54: case hg_command context libname ["update", "-r", id] of cannam@55: OK _ => OK () cannam@54: | ERROR e => cannam@54: case pull_result of cannam@54: ERROR e' => ERROR e' (* this was the ur-error *) cannam@54: | _ => ERROR e cannam@54: end cannam@55: cannam@55: fun copy_url_for context libname = cannam@55: OK (FileBits.file_url (FileBits.libpath context libname)) cannam@55: cannam@54: end cannam@54: cannam@54: structure GitControl :> VCS_CONTROL = struct cannam@54: cannam@54: (* With Git repos we always operate in detached HEAD state. Even cannam@55: the master branch is checked out using a remote reference cannam@55: (repoint/master). The remote we use is always named repoint, and we cannam@55: update it to the expected URL each time we fetch, in order to cannam@55: ensure we update properly if the location given in the project cannam@55: file changes. The origin remote is unused. *) cannam@54: cannam@55: val git_program = "git" cannam@55: cannam@54: fun git_command context libname args = cannam@55: FileBits.command context libname (git_program :: args) cannam@54: cannam@54: fun git_command_output context libname args = cannam@55: FileBits.command_output context libname (git_program :: args) cannam@55: cannam@55: fun is_working context = cannam@55: case git_command_output context "" ["--version"] of cannam@55: OK "" => OK false cannam@55: | OK _ => OK true cannam@55: | ERROR e => ERROR e cannam@54: cannam@54: fun exists context libname = cannam@54: OK (OS.FileSys.isDir (FileBits.subpath context libname ".git")) cannam@54: handle _ => OK false cannam@54: cannam@54: fun remote_for context (libname, source) = cannam@54: Provider.remote_url context GIT source libname cannam@54: cannam@54: fun branch_name branch = case branch of cannam@54: DEFAULT_BRANCH => "master" cannam@54: | BRANCH "" => "master" cannam@54: | BRANCH b => b cannam@54: cannam@55: val our_remote = "repoint" cannam@55: cannam@55: fun remote_branch_name branch = our_remote ^ "/" ^ branch_name branch cannam@54: cannam@54: fun checkout context (libname, source, branch) = cannam@54: let val url = remote_for context (libname, source) cannam@54: in cannam@55: (* make the lib dir rather than just the ext dir, since cannam@55: the lib dir might be nested and git will happily check cannam@55: out into an existing empty dir anyway *) cannam@55: case FileBits.mkpath (FileBits.libpath context libname) of cannam@54: OK () => git_command context "" cannam@55: ["clone", "--origin", our_remote, cannam@55: "--branch", branch_name branch, cannam@54: url, libname] cannam@54: | ERROR e => ERROR e cannam@54: end cannam@54: cannam@55: fun add_our_remote context (libname, source) = cannam@55: (* When we do the checkout ourselves (above), we add the cannam@55: remote at the same time. But if the repo was cloned by cannam@55: someone else, we'll need to do it after the fact. Git cannam@55: doesn't seem to have a means to add a remote or change its cannam@55: url if it already exists; seems we have to do this: *) cannam@55: let val url = remote_for context (libname, source) cannam@55: in cannam@55: case git_command context libname cannam@55: ["remote", "set-url", our_remote, url] of cannam@55: OK () => OK () cannam@55: | ERROR e => git_command context libname cannam@55: ["remote", "add", "-f", our_remote, url] cannam@55: end cannam@55: cannam@54: (* NB git rev-parse HEAD shows revision id of current checkout; cannam@54: git rev-list -1 shows revision id of revision with that tag *) cannam@54: cannam@54: fun id_of context libname = cannam@54: git_command_output context libname ["rev-parse", "HEAD"] cannam@54: cannam@54: fun is_at context (libname, id_or_tag) = cannam@54: case id_of context libname of cannam@55: ERROR e => OK false (* HEAD nonexistent, expected in empty repo *) cannam@54: | OK id => cannam@54: if String.isPrefix id_or_tag id orelse cannam@54: String.isPrefix id id_or_tag cannam@54: then OK true cannam@55: else is_at_tag context (libname, id, id_or_tag) cannam@55: cannam@55: and is_at_tag context (libname, id, tag) = cannam@55: (* For annotated tags (with message) show-ref returns the tag cannam@55: object ref rather than that of the revision being tagged; cannam@55: we need the subsequent rev-list to chase that up. In fact cannam@55: the rev-list on its own is enough to get us the id direct cannam@55: from the tag name, but it fails with an error if the tag cannam@55: doesn't exist, whereas we want to handle that quietly in cannam@55: case the tag simply hasn't been pulled yet *) cannam@55: case git_command_output context libname cannam@55: ["show-ref", "refs/tags/" ^ tag, "--"] of cannam@55: OK "" => OK false (* Not a tag *) cannam@55: | ERROR _ => OK false cannam@55: | OK s => cannam@55: let val tag_ref = hd (String.tokens (fn c => c = #" ") s) cannam@55: in cannam@54: case git_command_output context libname cannam@55: ["rev-list", "-1", tag_ref] of cannam@55: OK tagged => OK (id = tagged) cannam@54: | ERROR _ => OK false cannam@55: end cannam@55: cannam@54: fun branch_tip context (libname, branch) = cannam@55: (* We don't have access to the source info or the network cannam@55: here, as this is used by status (e.g. via is_on_branch) as cannam@55: well as review. It's possible the remote branch won't exist, cannam@55: e.g. if the repo was checked out by something other than cannam@55: Repoint, and if that's the case, we can't add it here; we'll cannam@55: just have to fail, since checking against local branches cannam@55: instead could produce the wrong result. *) cannam@54: git_command_output context libname cannam@54: ["rev-list", "-1", cannam@55: remote_branch_name branch, "--"] cannam@54: cannam@54: fun is_newest_locally context (libname, branch) = cannam@54: case branch_tip context (libname, branch) of cannam@55: ERROR e => OK false cannam@54: | OK rev => is_at context (libname, rev) cannam@54: cannam@54: fun is_on_branch context (libname, branch) = cannam@54: case branch_tip context (libname, branch) of cannam@55: ERROR e => OK false cannam@54: | OK rev => cannam@54: case is_at context (libname, rev) of cannam@54: ERROR e => ERROR e cannam@54: | OK true => OK true cannam@54: | OK false => cannam@54: case git_command context libname cannam@54: ["merge-base", "--is-ancestor", cannam@54: "HEAD", remote_branch_name branch] of cannam@54: ERROR e => OK false (* cmd returns non-zero for no *) cannam@54: | _ => OK true cannam@54: cannam@55: fun fetch context (libname, source) = cannam@55: case add_our_remote context (libname, source) of cannam@54: ERROR e => ERROR e cannam@55: | _ => git_command context libname ["fetch", our_remote] cannam@55: cannam@55: fun is_newest context (libname, source, branch) = cannam@55: case add_our_remote context (libname, source) of cannam@55: ERROR e => ERROR e cannam@55: | OK () => cannam@55: case is_newest_locally context (libname, branch) of cannam@54: ERROR e => ERROR e cannam@55: | OK false => OK false cannam@55: | OK true => cannam@55: case fetch context (libname, source) of cannam@55: ERROR e => ERROR e cannam@55: | _ => is_newest_locally context (libname, branch) cannam@54: cannam@54: fun is_modified_locally context libname = cannam@54: case git_command_output context libname ["status", "--porcelain"] of cannam@54: ERROR e => ERROR e cannam@54: | OK "" => OK false cannam@54: | OK _ => OK true cannam@54: cannam@54: (* This function updates to the latest revision on a branch rather cannam@54: than to a specific id or tag. We can't just checkout the given cannam@54: branch, as that will succeed even if the branch isn't up to cannam@54: date. We could checkout the branch and then fetch and merge, cannam@54: but it's perhaps cleaner not to maintain a local branch at all, cannam@54: but instead checkout the remote branch as a detached head. *) cannam@54: cannam@55: fun update context (libname, source, branch) = cannam@55: case fetch context (libname, source) of cannam@54: ERROR e => ERROR e cannam@54: | _ => cannam@54: case git_command context libname ["checkout", "--detach", cannam@54: remote_branch_name branch] of cannam@54: ERROR e => ERROR e cannam@55: | _ => OK () cannam@54: cannam@54: (* This function is dealing with a specific id or tag, so if we cannam@54: can successfully check it out (detached) then that's all we cannam@54: need to do, regardless of whether fetch succeeded or not. We do cannam@54: attempt the fetch first, though, purely in order to avoid ugly cannam@54: error messages in the common case where we're being asked to cannam@54: update to a new pin (from the lock file) that hasn't been cannam@54: fetched yet. *) cannam@54: cannam@55: fun update_to context (libname, _, "") = cannam@54: ERROR "Non-empty id (tag or revision id) required for update_to" cannam@55: | update_to context (libname, source, id) = cannam@55: let val fetch_result = fetch context (libname, source) cannam@54: in cannam@54: case git_command context libname ["checkout", "--detach", id] of cannam@55: OK _ => OK () cannam@54: | ERROR e => cannam@54: case fetch_result of cannam@54: ERROR e' => ERROR e' (* this was the ur-error *) cannam@54: | _ => ERROR e cannam@54: end cannam@55: cannam@55: fun copy_url_for context libname = cannam@55: OK (FileBits.file_url (FileBits.libpath context libname)) cannam@54: cannam@54: end cannam@54: cannam@55: (* SubXml - A parser for a subset of XML cannam@55: https://bitbucket.org/cannam/sml-subxml cannam@55: Copyright 2018 Chris Cannam. BSD licence. cannam@55: *) cannam@55: cannam@55: signature SUBXML = sig cannam@55: cannam@55: datatype node = ELEMENT of { name : string, children : node list } cannam@55: | ATTRIBUTE of { name : string, value : string } cannam@55: | TEXT of string cannam@55: | CDATA of string cannam@55: | COMMENT of string cannam@55: cannam@55: datatype document = DOCUMENT of { name : string, children : node list } cannam@55: cannam@55: datatype 'a result = OK of 'a cannam@55: | ERROR of string cannam@55: cannam@55: val parse : string -> document result cannam@55: val serialise : document -> string cannam@55: cannam@55: end cannam@55: cannam@55: structure SubXml :> SUBXML = struct cannam@55: cannam@55: datatype node = ELEMENT of { name : string, children : node list } cannam@55: | ATTRIBUTE of { name : string, value : string } cannam@55: | TEXT of string cannam@55: | CDATA of string cannam@55: | COMMENT of string cannam@55: cannam@55: datatype document = DOCUMENT of { name : string, children : node list } cannam@55: cannam@55: datatype 'a result = OK of 'a cannam@55: | ERROR of string cannam@55: cannam@55: structure T = struct cannam@55: datatype token = ANGLE_L cannam@55: | ANGLE_R cannam@55: | ANGLE_SLASH_L cannam@55: | SLASH_ANGLE_R cannam@55: | EQUAL cannam@55: | NAME of string cannam@55: | TEXT of string cannam@55: | CDATA of string cannam@55: | COMMENT of string cannam@55: cannam@55: fun name t = cannam@55: case t of ANGLE_L => "<" cannam@55: | ANGLE_R => ">" cannam@55: | ANGLE_SLASH_L => " "/>" cannam@55: | EQUAL => "=" cannam@55: | NAME s => "name \"" ^ s ^ "\"" cannam@55: | TEXT s => "text" cannam@55: | CDATA _ => "CDATA section" cannam@55: | COMMENT _ => "comment" cannam@55: end cannam@55: cannam@55: structure Lex :> sig cannam@55: val lex : string -> T.token list result cannam@55: end = struct cannam@55: cannam@55: fun error pos text = cannam@55: ERROR (text ^ " at character position " ^ Int.toString (pos-1)) cannam@55: fun tokenError pos token = cannam@55: error pos ("Unexpected token '" ^ Char.toString token ^ "'") cannam@55: cannam@55: val nameEnd = explode " \t\n\r\"'!=?" cannam@55: cannam@55: fun quoted quote pos acc cc = cannam@55: let fun quoted' pos text [] = cannam@55: error pos "Document ends during quoted string" cannam@55: | quoted' pos text (x::xs) = cannam@55: if x = quote cannam@55: then OK (rev text, xs, pos+1) cannam@55: else quoted' (pos+1) (x::text) xs cannam@55: in cannam@55: case quoted' pos [] cc of cannam@55: ERROR e => ERROR e cannam@55: | OK (text, rest, newpos) => cannam@55: inside newpos (T.TEXT (implode text) :: acc) rest cannam@55: end cannam@55: cannam@55: and name first pos acc cc = cannam@55: let fun name' pos text [] = cannam@55: error pos "Document ends during name" cannam@55: | name' pos text (x::xs) = cannam@55: if List.find (fn c => c = x) nameEnd <> NONE cannam@55: then OK (rev text, (x::xs), pos) cannam@55: else name' (pos+1) (x::text) xs cannam@55: in cannam@55: case name' (pos-1) [] (first::cc) of cannam@55: ERROR e => ERROR e cannam@55: | OK ([], [], pos) => error pos "Document ends before name" cannam@55: | OK ([], (x::xs), pos) => tokenError pos x cannam@55: | OK (text, rest, pos) => cannam@55: inside pos (T.NAME (implode text) :: acc) rest cannam@55: end cannam@55: cannam@55: and comment pos acc cc = cannam@55: let fun comment' pos text cc = cannam@55: case cc of cannam@55: #"-" :: #"-" :: #">" :: xs => OK (rev text, xs, pos+3) cannam@55: | x :: xs => comment' (pos+1) (x::text) xs cannam@55: | [] => error pos "Document ends during comment" cannam@55: in cannam@55: case comment' pos [] cc of cannam@55: ERROR e => ERROR e cannam@55: | OK (text, rest, pos) => cannam@55: outside pos (T.COMMENT (implode text) :: acc) rest cannam@55: end cannam@55: cannam@55: and instruction pos acc cc = cannam@55: case cc of cannam@55: #"?" :: #">" :: xs => outside (pos+2) acc xs cannam@55: | #">" :: _ => tokenError pos #">" cannam@55: | x :: xs => instruction (pos+1) acc xs cannam@55: | [] => error pos "Document ends during processing instruction" cannam@55: cannam@55: and cdata pos acc cc = cannam@55: let fun cdata' pos text cc = cannam@55: case cc of cannam@55: #"]" :: #"]" :: #">" :: xs => OK (rev text, xs, pos+3) cannam@55: | x :: xs => cdata' (pos+1) (x::text) xs cannam@55: | [] => error pos "Document ends during CDATA section" cannam@55: in cannam@55: case cdata' pos [] cc of cannam@55: ERROR e => ERROR e cannam@55: | OK (text, rest, pos) => cannam@55: outside pos (T.CDATA (implode text) :: acc) rest cannam@55: end cannam@55: cannam@55: and doctype pos acc cc = cannam@55: case cc of cannam@55: #">" :: xs => outside (pos+1) acc xs cannam@55: | x :: xs => doctype (pos+1) acc xs cannam@55: | [] => error pos "Document ends during DOCTYPE" cannam@55: cannam@55: and declaration pos acc cc = cannam@55: case cc of cannam@55: #"-" :: #"-" :: xs => cannam@55: comment (pos+2) acc xs cannam@55: | #"[" :: #"C" :: #"D" :: #"A" :: #"T" :: #"A" :: #"[" :: xs => cannam@55: cdata (pos+7) acc xs cannam@55: | #"D" :: #"O" :: #"C" :: #"T" :: #"Y" :: #"P" :: #"E" :: xs => cannam@55: doctype (pos+7) acc xs cannam@55: | [] => error pos "Document ends during declaration" cannam@55: | _ => error pos "Unsupported declaration type" cannam@55: cannam@55: and left pos acc cc = cannam@55: case cc of cannam@55: #"/" :: xs => inside (pos+1) (T.ANGLE_SLASH_L :: acc) xs cannam@55: | #"!" :: xs => declaration (pos+1) acc xs cannam@55: | #"?" :: xs => instruction (pos+1) acc xs cannam@55: | xs => inside pos (T.ANGLE_L :: acc) xs cannam@55: cannam@55: and slash pos acc cc = cannam@55: case cc of cannam@55: #">" :: xs => outside (pos+1) (T.SLASH_ANGLE_R :: acc) xs cannam@55: | x :: _ => tokenError pos x cannam@55: | [] => error pos "Document ends before element closed" cannam@55: cannam@55: and close pos acc xs = outside pos (T.ANGLE_R :: acc) xs cannam@55: cannam@55: and equal pos acc xs = inside pos (T.EQUAL :: acc) xs cannam@55: cannam@55: and outside pos acc [] = OK acc cannam@55: | outside pos acc cc = cannam@55: let fun textOf text = T.TEXT (implode (rev text)) cannam@55: fun outside' pos [] acc [] = OK acc cannam@55: | outside' pos text acc [] = OK (textOf text :: acc) cannam@55: | outside' pos text acc (x::xs) = cannam@55: case x of cannam@55: #"<" => if text = [] cannam@55: then left (pos+1) acc xs cannam@55: else left (pos+1) (textOf text :: acc) xs cannam@55: | x => outside' (pos+1) (x::text) acc xs cannam@55: in cannam@55: outside' pos [] acc cc cannam@55: end cannam@55: cannam@55: and inside pos acc [] = error pos "Document ends within tag" cannam@55: | inside pos acc (#"<"::_) = tokenError pos #"<" cannam@55: | inside pos acc (x::xs) = cannam@55: (case x of cannam@55: #" " => inside | #"\t" => inside cannam@55: | #"\n" => inside | #"\r" => inside cannam@55: | #"\"" => quoted x | #"'" => quoted x cannam@55: | #"/" => slash | #">" => close | #"=" => equal cannam@55: | x => name x) (pos+1) acc xs cannam@55: cannam@55: fun lex str = cannam@55: case outside 1 [] (explode str) of cannam@55: ERROR e => ERROR e cannam@55: | OK tokens => OK (rev tokens) cannam@55: end cannam@55: cannam@55: structure Parse :> sig cannam@55: val parse : string -> document result cannam@55: end = struct cannam@55: cannam@55: fun show [] = "end of input" cannam@55: | show (tok :: _) = T.name tok cannam@55: cannam@55: fun error toks text = ERROR (text ^ " before " ^ show toks) cannam@55: cannam@55: fun attribute elt name toks = cannam@55: case toks of cannam@55: T.EQUAL :: T.TEXT value :: xs => cannam@55: namedElement { cannam@55: name = #name elt, cannam@55: children = ATTRIBUTE { name = name, value = value } :: cannam@55: #children elt cannam@55: } xs cannam@55: | T.EQUAL :: xs => error xs "Expected attribute value" cannam@55: | toks => error toks "Expected attribute assignment" cannam@55: cannam@55: and content elt toks = cannam@55: case toks of cannam@55: T.ANGLE_SLASH_L :: T.NAME n :: T.ANGLE_R :: xs => cannam@55: if n = #name elt cannam@55: then OK (elt, xs) cannam@55: else ERROR ("Closing tag " ^ cannam@55: "does not match opening <" ^ #name elt ^ ">") cannam@55: | T.TEXT text :: xs => cannam@55: content { cannam@55: name = #name elt, cannam@55: children = TEXT text :: #children elt cannam@55: } xs cannam@55: | T.CDATA text :: xs => cannam@55: content { cannam@55: name = #name elt, cannam@55: children = CDATA text :: #children elt cannam@55: } xs cannam@55: | T.COMMENT text :: xs => cannam@55: content { cannam@55: name = #name elt, cannam@55: children = COMMENT text :: #children elt cannam@55: } xs cannam@55: | T.ANGLE_L :: xs => cannam@55: (case element xs of cannam@55: ERROR e => ERROR e cannam@55: | OK (child, xs) => cannam@55: content { cannam@55: name = #name elt, cannam@55: children = ELEMENT child :: #children elt cannam@55: } xs) cannam@55: | tok :: xs => cannam@55: error xs ("Unexpected token " ^ T.name tok) cannam@55: | [] => cannam@55: ERROR ("Document ends within element \"" ^ #name elt ^ "\"") cannam@55: cannam@55: and namedElement elt toks = cannam@55: case toks of cannam@55: T.SLASH_ANGLE_R :: xs => OK (elt, xs) cannam@55: | T.NAME name :: xs => attribute elt name xs cannam@55: | T.ANGLE_R :: xs => content elt xs cannam@55: | x :: xs => error xs ("Unexpected token " ^ T.name x) cannam@55: | [] => ERROR "Document ends within opening tag" cannam@55: cannam@55: and element toks = cannam@55: case toks of cannam@55: T.NAME name :: xs => cannam@55: (case namedElement { name = name, children = [] } xs of cannam@55: ERROR e => ERROR e cannam@55: | OK ({ name, children }, xs) => cannam@55: OK ({ name = name, children = rev children }, xs)) cannam@55: | toks => error toks "Expected element name" cannam@55: cannam@55: and document [] = ERROR "Empty document" cannam@55: | document (tok :: xs) = cannam@55: case tok of cannam@55: T.TEXT _ => document xs cannam@55: | T.COMMENT _ => document xs cannam@55: | T.ANGLE_L => cannam@55: (case element xs of cannam@55: ERROR e => ERROR e cannam@55: | OK (elt, []) => OK (DOCUMENT elt) cannam@55: | OK (elt, (T.TEXT _ :: xs)) => OK (DOCUMENT elt) cannam@55: | OK (elt, xs) => error xs "Extra data after document") cannam@55: | _ => error xs ("Unexpected token " ^ T.name tok) cannam@55: cannam@55: fun parse str = cannam@55: case Lex.lex str of cannam@55: ERROR e => ERROR e cannam@55: | OK tokens => document tokens cannam@55: end cannam@55: cannam@55: structure Serialise :> sig cannam@55: val serialise : document -> string cannam@55: end = struct cannam@55: cannam@55: fun attributes nodes = cannam@55: String.concatWith cannam@55: " " cannam@55: (map node (List.filter cannam@55: (fn ATTRIBUTE _ => true | _ => false) cannam@55: nodes)) cannam@55: cannam@55: and nonAttributes nodes = cannam@55: String.concat cannam@55: (map node (List.filter cannam@55: (fn ATTRIBUTE _ => false | _ => true) cannam@55: nodes)) cannam@55: cannam@55: and node n = cannam@55: case n of cannam@55: TEXT string => cannam@55: string cannam@55: | CDATA string => cannam@55: "" cannam@55: | COMMENT string => cannam@55: "" cannam@55: | ATTRIBUTE { name, value } => cannam@55: name ^ "=" ^ "\"" ^ value ^ "\"" (*!!!*) cannam@55: | ELEMENT { name, children } => cannam@55: "<" ^ name ^ cannam@55: (case (attributes children) of cannam@55: "" => "" cannam@55: | s => " " ^ s) ^ cannam@55: (case (nonAttributes children) of cannam@55: "" => "/>" cannam@55: | s => ">" ^ s ^ "") cannam@55: cannam@55: fun serialise (DOCUMENT { name, children }) = cannam@55: "\n" ^ cannam@55: node (ELEMENT { name = name, children = children }) cannam@55: end cannam@55: cannam@55: val parse = Parse.parse cannam@55: val serialise = Serialise.serialise cannam@55: cannam@55: end cannam@55: cannam@55: cannam@55: structure SvnControl :> VCS_CONTROL = struct cannam@55: cannam@55: val svn_program = "svn" cannam@55: cannam@55: fun svn_command context libname args = cannam@55: FileBits.command context libname (svn_program :: args) cannam@55: cannam@55: fun svn_command_output context libname args = cannam@55: FileBits.command_output context libname (svn_program :: args) cannam@55: cannam@55: fun svn_command_lines context libname args = cannam@55: case svn_command_output context libname args of cannam@55: ERROR e => ERROR e cannam@55: | OK s => OK (String.tokens (fn c => c = #"\n" orelse c = #"\r") s) cannam@55: cannam@55: fun split_line_pair line = cannam@55: let fun strip_leading_ws str = case explode str of cannam@55: #" "::rest => implode rest cannam@55: | _ => str cannam@55: in cannam@55: case String.tokens (fn c => c = #":") line of cannam@55: [] => ("", "") cannam@55: | first::rest => cannam@55: (first, strip_leading_ws (String.concatWith ":" rest)) cannam@55: end cannam@55: cannam@55: fun is_working context = cannam@55: case svn_command_output context "" ["--version"] of cannam@55: OK "" => OK false cannam@55: | OK _ => OK true cannam@55: | ERROR e => ERROR e cannam@55: cannam@55: structure X = SubXml cannam@55: cannam@55: fun svn_info context libname route = cannam@55: (* SVN 1.9 has info --show-item which is just what we need, cannam@55: but at this point we still have 1.8 on the CI boxes so we cannam@55: might as well aim to support it. For that we really have to cannam@55: use the XML output format, since the default info output is cannam@55: localised. This is the only thing our mini-XML parser is cannam@55: used for though, so it would be good to trim it at some cannam@55: point *) cannam@55: let fun find elt [] = OK elt cannam@55: | find { children, ... } (first :: rest) = cannam@55: case List.find (fn (X.ELEMENT { name, ... }) => name = first cannam@55: | _ => false) cannam@55: children of cannam@55: NONE => ERROR ("No element \"" ^ first ^ "\" in SVN XML") cannam@55: | SOME (X.ELEMENT e) => find e rest cannam@55: | SOME _ => ERROR "Internal error" cannam@55: in cannam@55: case svn_command_output context libname ["info", "--xml"] of cannam@55: ERROR e => ERROR e cannam@55: | OK xml => cannam@55: case X.parse xml of cannam@55: X.ERROR e => ERROR e cannam@55: | X.OK (X.DOCUMENT doc) => find doc route cannam@55: end cannam@55: cannam@55: fun exists context libname = cannam@55: OK (OS.FileSys.isDir (FileBits.subpath context libname ".svn")) cannam@55: handle _ => OK false cannam@55: cannam@55: fun remote_for context (libname, source) = cannam@55: Provider.remote_url context SVN source libname cannam@55: cannam@55: (* Remote the checkout came from, not necessarily the one we want *) cannam@55: fun actual_remote_for context libname = cannam@55: case svn_info context libname ["entry", "url"] of cannam@55: ERROR e => ERROR e cannam@55: | OK { children, ... } => cannam@55: case List.find (fn (X.TEXT _) => true | _ => false) children of cannam@55: NONE => ERROR "No content for URL in SVN info XML" cannam@55: | SOME (X.TEXT url) => OK url cannam@55: | SOME _ => ERROR "Internal error" cannam@55: cannam@55: fun id_of context libname = cannam@55: case svn_info context libname ["entry"] of cannam@55: ERROR e => ERROR e cannam@55: | OK { children, ... } => cannam@55: case List.find cannam@55: (fn (X.ATTRIBUTE { name = "revision", ... }) => true cannam@55: | _ => false) cannam@55: children of cannam@55: NONE => ERROR "No revision for entry in SVN info XML" cannam@55: | SOME (X.ATTRIBUTE { value, ... }) => OK value cannam@55: | SOME _ => ERROR "Internal error" cannam@55: cannam@55: fun is_at context (libname, id_or_tag) = cannam@55: case id_of context libname of cannam@55: ERROR e => ERROR e cannam@55: | OK id => OK (id = id_or_tag) cannam@55: cannam@55: fun is_on_branch context (libname, b) = cannam@55: OK (b = DEFAULT_BRANCH) cannam@55: cannam@55: fun check_remote context (libname, source) = cannam@55: case (remote_for context (libname, source), cannam@55: actual_remote_for context libname) of cannam@55: (_, ERROR e) => ERROR e cannam@55: | (url, OK actual) => cannam@55: if actual = url cannam@55: then OK () cannam@55: else svn_command context libname ["relocate", url] cannam@55: cannam@55: fun is_newest context (libname, source, branch) = cannam@55: case check_remote context (libname, source) of cannam@55: ERROR e => ERROR e cannam@55: | OK () => cannam@55: case svn_command_lines context libname cannam@55: ["status", "--show-updates"] of cannam@55: ERROR e => ERROR e cannam@55: | OK lines => cannam@55: case rev lines of cannam@55: [] => ERROR "No result returned for server status" cannam@55: | last_line::_ => cannam@55: case rev (String.tokens (fn c => c = #" ") last_line) of cannam@55: [] => ERROR "No revision field found in server status" cannam@55: | server_id::_ => is_at context (libname, server_id) cannam@55: cannam@55: fun is_newest_locally context (libname, branch) = cannam@55: OK true (* no local history *) cannam@55: cannam@55: fun is_modified_locally context libname = cannam@55: case svn_command_output context libname ["status"] of cannam@55: ERROR e => ERROR e cannam@55: | OK "" => OK false cannam@55: | OK _ => OK true cannam@55: cannam@55: fun checkout context (libname, source, branch) = cannam@55: let val url = remote_for context (libname, source) cannam@55: val path = FileBits.libpath context libname cannam@55: in cannam@55: if FileBits.nonempty_dir_exists path cannam@55: then (* Surprisingly, SVN itself has no problem with cannam@55: this. But for consistency with other VCSes we cannam@55: don't allow it *) cannam@55: ERROR ("Refusing checkout to nonempty dir \"" ^ path ^ "\"") cannam@55: else cannam@55: (* make the lib dir rather than just the ext dir, since cannam@55: the lib dir might be nested and svn will happily check cannam@55: out into an existing empty dir anyway *) cannam@55: case FileBits.mkpath (FileBits.libpath context libname) of cannam@55: ERROR e => ERROR e cannam@55: | _ => svn_command context "" ["checkout", url, libname] cannam@55: end cannam@55: cannam@55: fun update context (libname, source, branch) = cannam@55: case check_remote context (libname, source) of cannam@55: ERROR e => ERROR e cannam@55: | OK () => cannam@55: case svn_command context libname cannam@55: ["update", "--accept", "postpone"] of cannam@55: ERROR e => ERROR e cannam@55: | _ => OK () cannam@55: cannam@55: fun update_to context (libname, _, "") = cannam@55: ERROR "Non-empty id (tag or revision id) required for update_to" cannam@55: | update_to context (libname, source, id) = cannam@55: case check_remote context (libname, source) of cannam@55: ERROR e => ERROR e cannam@55: | OK () => cannam@55: case svn_command context libname cannam@55: ["update", "-r", id, "--accept", "postpone"] of cannam@55: ERROR e => ERROR e cannam@55: | OK _ => OK () cannam@55: cannam@55: fun copy_url_for context libname = cannam@55: actual_remote_for context libname cannam@55: cannam@55: end cannam@55: cannam@54: structure AnyLibControl :> LIB_CONTROL = struct cannam@54: cannam@54: structure H = LibControlFn(HgControl) cannam@54: structure G = LibControlFn(GitControl) cannam@55: structure S = LibControlFn(SvnControl) cannam@54: cannam@54: fun review context (spec as { vcs, ... } : libspec) = cannam@55: (fn HG => H.review | GIT => G.review | SVN => S.review) vcs context spec cannam@54: cannam@54: fun status context (spec as { vcs, ... } : libspec) = cannam@55: (fn HG => H.status | GIT => G.status | SVN => S.status) vcs context spec cannam@54: cannam@54: fun update context (spec as { vcs, ... } : libspec) = cannam@55: (fn HG => H.update | GIT => G.update | SVN => S.update) vcs context spec cannam@54: cannam@54: fun id_of context (spec as { vcs, ... } : libspec) = cannam@55: (fn HG => H.id_of | GIT => G.id_of | SVN => S.id_of) vcs context spec cannam@55: cannam@55: fun is_working context vcs = cannam@55: (fn HG => H.is_working | GIT => G.is_working | SVN => S.is_working) cannam@55: vcs context vcs cannam@55: cannam@55: end cannam@55: cannam@55: cannam@55: type exclusions = string list cannam@55: cannam@55: structure Archive :> sig cannam@55: cannam@55: val archive : string * exclusions -> project -> OS.Process.status cannam@55: cannam@55: end = struct cannam@55: cannam@55: (* The idea of "archive" is to replace hg/git archive, which won't cannam@55: include files, like the Repoint-introduced external libraries, cannam@55: that are not under version control with the main repo. cannam@55: cannam@55: The process goes like this: cannam@55: cannam@55: - Make sure we have a target filename from the user, and take cannam@55: its basename as our archive directory name cannam@55: cannam@55: - Make an "archive root" subdir of the project repo, named cannam@55: typically .repoint-archive cannam@55: cannam@55: - Identify the VCS used for the project repo. Note that any cannam@55: explicit references to VCS type in this structure are to cannam@55: the VCS used for the project (something Repoint doesn't cannam@55: otherwise care about), not for an individual library cannam@55: cannam@55: - Synthesise a Repoint project with the archive root as its cannam@55: root path, "." as its extdir, with one library whose cannam@55: name is the user-supplied basename and whose explicit cannam@55: source URL is the original project root; update that cannam@55: project -- thus cloning the original project to a subdir cannam@55: of the archive root cannam@55: cannam@55: - Synthesise a Repoint project identical to the original one for cannam@55: this project, but with the newly-cloned copy as its root cannam@55: path; update that project -- thus checking out clean copies cannam@55: of the external library dirs cannam@55: cannam@55: - Call out to an archive program to archive up the new copy, cannam@55: running e.g. cannam@55: tar cvzf project-release.tar.gz \ cannam@55: --exclude=.hg --exclude=.git project-release cannam@55: in the archive root dir cannam@55: cannam@55: - (We also omit the repoint-project.json file and any trace of cannam@55: Repoint. It can't properly be run in a directory where the cannam@55: external project folders already exist but their repo history cannam@55: does not. End users shouldn't get to see Repoint) cannam@55: cannam@55: - Clean up by deleting the new copy cannam@55: *) cannam@55: cannam@55: fun project_vcs_id_and_url dir = cannam@55: let val context = { cannam@55: rootpath = dir, cannam@55: extdir = ".", cannam@55: providers = [], cannam@55: accounts = [] cannam@55: } cannam@55: val vcs_maybe = cannam@55: case [HgControl.exists context ".", cannam@55: GitControl.exists context ".", cannam@55: SvnControl.exists context "."] of cannam@55: [OK true, OK false, OK false] => OK HG cannam@55: | [OK false, OK true, OK false] => OK GIT cannam@55: | [OK false, OK false, OK true] => OK SVN cannam@55: | _ => ERROR ("Unable to identify VCS for directory " ^ dir) cannam@55: in cannam@55: case vcs_maybe of cannam@55: ERROR e => ERROR e cannam@55: | OK vcs => cannam@55: case (fn HG => HgControl.id_of cannam@55: | GIT => GitControl.id_of cannam@55: | SVN => SvnControl.id_of) cannam@55: vcs context "." of cannam@55: ERROR e => ERROR ("Unable to find id of project repo: " ^ e) cannam@55: | OK id => cannam@55: case (fn HG => HgControl.copy_url_for cannam@55: | GIT => GitControl.copy_url_for cannam@55: | SVN => SvnControl.copy_url_for) cannam@55: vcs context "." of cannam@55: ERROR e => ERROR ("Unable to find URL of project repo: " cannam@55: ^ e) cannam@55: | OK url => OK (vcs, id, url) cannam@55: end cannam@55: cannam@55: fun make_archive_root (context : context) = cannam@55: let val path = OS.Path.joinDirFile { cannam@55: dir = #rootpath context, cannam@55: file = RepointFilenames.archive_dir cannam@55: } cannam@55: in cannam@55: case FileBits.mkpath path of cannam@55: ERROR e => raise Fail ("Failed to create archive directory \"" cannam@55: ^ path ^ "\": " ^ e) cannam@55: | OK () => path cannam@55: end cannam@55: cannam@55: fun archive_path archive_dir target_name = cannam@55: OS.Path.joinDirFile { cannam@55: dir = archive_dir, cannam@55: file = target_name cannam@55: } cannam@55: cannam@55: fun check_nonexistent path = cannam@55: case SOME (OS.FileSys.fileSize path) handle OS.SysErr _ => NONE of cannam@55: NONE => () cannam@55: | _ => raise Fail ("Path " ^ path ^ " exists, not overwriting") cannam@55: cannam@55: fun make_archive_copy target_name (vcs, project_id, source_url) cannam@55: ({ context, ... } : project) = cannam@55: let val archive_root = make_archive_root context cannam@55: val synthetic_context = { cannam@55: rootpath = archive_root, cannam@55: extdir = ".", cannam@55: providers = [], cannam@55: accounts = [] cannam@55: } cannam@55: val synthetic_library = { cannam@55: libname = target_name, cannam@55: vcs = vcs, cannam@55: source = URL_SOURCE source_url, cannam@55: branch = DEFAULT_BRANCH, (* overridden by pinned id below *) cannam@55: project_pin = PINNED project_id, cannam@55: lock_pin = PINNED project_id cannam@55: } cannam@55: val path = archive_path archive_root target_name cannam@55: val _ = print ("Cloning original project to " ^ path cannam@55: ^ " at revision " ^ project_id ^ "...\n"); cannam@55: val _ = check_nonexistent path cannam@55: in cannam@55: case AnyLibControl.update synthetic_context synthetic_library of cannam@55: ERROR e => ERROR ("Failed to clone original project to " cannam@55: ^ path ^ ": " ^ e) cannam@55: | OK _ => OK archive_root cannam@55: end cannam@55: cannam@55: fun update_archive archive_root target_name cannam@55: (project as { context, ... } : project) = cannam@55: let val synthetic_context = { cannam@55: rootpath = archive_path archive_root target_name, cannam@55: extdir = #extdir context, cannam@55: providers = #providers context, cannam@55: accounts = #accounts context cannam@55: } cannam@55: in cannam@55: foldl (fn (lib, acc) => cannam@55: case acc of cannam@55: ERROR e => ERROR e cannam@55: | OK () => AnyLibControl.update synthetic_context lib) cannam@55: (OK ()) cannam@55: (#libs project) cannam@55: end cannam@55: cannam@55: datatype packer = TAR cannam@55: | TAR_GZ cannam@55: | TAR_BZ2 cannam@55: | TAR_XZ cannam@55: (* could add other packers, e.g. zip, if we knew how to cannam@55: handle the file omissions etc properly in pack_archive *) cannam@55: cannam@55: fun packer_and_basename path = cannam@55: let val extensions = [ (".tar", TAR), cannam@55: (".tar.gz", TAR_GZ), cannam@55: (".tar.bz2", TAR_BZ2), cannam@55: (".tar.xz", TAR_XZ)] cannam@55: val filename = OS.Path.file path cannam@55: in cannam@55: foldl (fn ((ext, packer), acc) => cannam@55: if String.isSuffix ext filename cannam@55: then SOME (packer, cannam@55: String.substring (filename, 0, cannam@55: String.size filename - cannam@55: String.size ext)) cannam@55: else acc) cannam@55: NONE cannam@55: extensions cannam@55: end cannam@55: cannam@55: fun pack_archive archive_root target_name target_path packer exclusions = cannam@55: case FileBits.command { cannam@55: rootpath = archive_root, cannam@55: extdir = ".", cannam@55: providers = [], cannam@55: accounts = [] cannam@55: } "" ([ cannam@55: "tar", cannam@55: case packer of cannam@55: TAR => "cf" cannam@55: | TAR_GZ => "czf" cannam@55: | TAR_BZ2 => "cjf" cannam@55: | TAR_XZ => "cJf", cannam@55: target_path, cannam@55: "--exclude=.hg", cannam@55: "--exclude=.git", cannam@55: "--exclude=.svn", cannam@55: "--exclude=repoint", cannam@55: "--exclude=repoint.sml", cannam@55: "--exclude=repoint.ps1", cannam@55: "--exclude=repoint.bat", cannam@55: "--exclude=repoint-project.json", cannam@55: "--exclude=repoint-lock.json" cannam@55: ] @ (map (fn e => "--exclude=" ^ e) exclusions) @ cannam@55: [ target_name ]) cannam@55: of cannam@55: ERROR e => ERROR e cannam@55: | OK _ => FileBits.rmpath (archive_path archive_root target_name) cannam@55: cannam@55: fun archive (target_path, exclusions) (project : project) = cannam@55: let val _ = check_nonexistent target_path cannam@55: val (packer, name) = cannam@55: case packer_and_basename target_path of cannam@55: NONE => raise Fail ("Unsupported archive file extension in " cannam@55: ^ target_path) cannam@55: | SOME pn => pn cannam@55: val details = cannam@55: case project_vcs_id_and_url (#rootpath (#context project)) of cannam@55: ERROR e => raise Fail e cannam@55: | OK details => details cannam@55: val archive_root = cannam@55: case make_archive_copy name details project of cannam@55: ERROR e => raise Fail e cannam@55: | OK archive_root => archive_root cannam@55: val outcome = cannam@55: case update_archive archive_root name project of cannam@55: ERROR e => ERROR e cannam@55: | OK _ => cannam@55: case pack_archive archive_root name cannam@55: target_path packer exclusions of cannam@55: ERROR e => ERROR e cannam@55: | OK _ => OK () cannam@55: in cannam@55: case outcome of cannam@55: ERROR e => raise Fail e cannam@55: | OK () => OS.Process.success cannam@55: end cannam@55: cannam@54: end cannam@54: cannam@54: val libobjname = "libraries" cannam@54: cannam@54: fun load_libspec spec_json lock_json libname : libspec = cannam@54: let open JsonBits cannam@54: val libobj = lookup_mandatory spec_json [libobjname, libname] cannam@54: val vcs = lookup_mandatory_string libobj ["vcs"] cannam@54: val retrieve = lookup_optional_string libobj cannam@54: val service = retrieve ["service"] cannam@54: val owner = retrieve ["owner"] cannam@54: val repo = retrieve ["repository"] cannam@54: val url = retrieve ["url"] cannam@54: val branch = retrieve ["branch"] cannam@54: val project_pin = case retrieve ["pin"] of cannam@54: NONE => UNPINNED cannam@54: | SOME p => PINNED p cannam@54: val lock_pin = case lookup_optional lock_json [libobjname, libname] of cannam@54: NONE => UNPINNED cannam@54: | SOME ll => case lookup_optional_string ll ["pin"] of cannam@54: SOME p => PINNED p cannam@54: | NONE => UNPINNED cannam@54: in cannam@54: { cannam@54: libname = libname, cannam@54: vcs = case vcs of cannam@54: "hg" => HG cannam@54: | "git" => GIT cannam@55: | "svn" => SVN cannam@54: | other => raise Fail ("Unknown version-control system \"" ^ cannam@54: other ^ "\""), cannam@54: source = case (url, service, owner, repo) of cannam@54: (SOME u, NONE, _, _) => URL_SOURCE u cannam@54: | (NONE, SOME ss, owner, repo) => cannam@54: SERVICE_SOURCE { service = ss, owner = owner, repo = repo } cannam@54: | _ => raise Fail ("Must have exactly one of service " ^ cannam@54: "or url string"), cannam@54: project_pin = project_pin, cannam@54: lock_pin = lock_pin, cannam@54: branch = case branch of cannam@55: NONE => DEFAULT_BRANCH cannam@55: | SOME b => cannam@55: case vcs of cannam@55: "svn" => raise Fail ("Branches not supported for " ^ cannam@55: "svn repositories; change " ^ cannam@55: "URL instead") cannam@55: | _ => BRANCH b cannam@54: } cannam@54: end cannam@54: cannam@54: fun load_userconfig () : userconfig = cannam@54: let val home = FileBits.homedir () cannam@54: val conf_json = cannam@54: JsonBits.load_json_from cannam@54: (OS.Path.joinDirFile { cannam@54: dir = home, cannam@55: file = RepointFilenames.user_config_file }) cannam@54: handle IO.Io _ => Json.OBJECT [] cannam@54: in cannam@54: { cannam@54: accounts = case JsonBits.lookup_optional conf_json ["accounts"] of cannam@54: NONE => [] cannam@54: | SOME (Json.OBJECT aa) => cannam@54: map (fn (k, (Json.STRING v)) => cannam@54: { service = k, login = v } cannam@54: | _ => raise Fail cannam@54: "String expected for account name") cannam@54: aa cannam@54: | _ => raise Fail "Array expected for accounts", cannam@54: providers = Provider.load_providers conf_json cannam@54: } cannam@54: end cannam@54: cannam@54: datatype pintype = cannam@54: NO_LOCKFILE | cannam@54: USE_LOCKFILE cannam@54: cannam@54: fun load_project (userconfig : userconfig) rootpath pintype : project = cannam@54: let val spec_file = FileBits.project_spec_path rootpath cannam@54: val lock_file = FileBits.project_lock_path rootpath cannam@54: val _ = if OS.FileSys.access (spec_file, [OS.FileSys.A_READ]) cannam@54: handle OS.SysErr _ => false cannam@54: then () cannam@54: else raise Fail ("Failed to open project spec file " ^ cannam@55: (RepointFilenames.project_file) ^ " in " ^ cannam@54: rootpath ^ cannam@54: ".\nPlease ensure the spec file is in the " ^ cannam@54: "project root and run this from there.") cannam@54: val spec_json = JsonBits.load_json_from spec_file cannam@54: val lock_json = if pintype = USE_LOCKFILE cannam@54: then JsonBits.load_json_from lock_file cannam@54: handle IO.Io _ => Json.OBJECT [] cannam@54: else Json.OBJECT [] cannam@54: val extdir = JsonBits.lookup_mandatory_string spec_json cannam@54: ["config", "extdir"] cannam@54: val spec_libs = JsonBits.lookup_optional spec_json [libobjname] cannam@54: val lock_libs = JsonBits.lookup_optional lock_json [libobjname] cannam@54: val providers = Provider.load_more_providers cannam@54: (#providers userconfig) spec_json cannam@54: val libnames = case spec_libs of cannam@54: NONE => [] cannam@54: | SOME (Json.OBJECT ll) => map (fn (k, v) => k) ll cannam@54: | _ => raise Fail "Object expected for libs" cannam@54: in cannam@54: { cannam@54: context = { cannam@54: rootpath = rootpath, cannam@54: extdir = extdir, cannam@54: providers = providers, cannam@54: accounts = #accounts userconfig cannam@54: }, cannam@54: libs = map (load_libspec spec_json lock_json) libnames cannam@54: } cannam@54: end cannam@54: cannam@54: fun save_lock_file rootpath locks = cannam@54: let val lock_file = FileBits.project_lock_path rootpath cannam@54: open Json cannam@54: val lock_json = cannam@54: OBJECT [ cannam@54: (libobjname, cannam@54: OBJECT (map (fn { libname, id_or_tag } => cannam@54: (libname, cannam@54: OBJECT [ ("pin", STRING id_or_tag) ])) cannam@54: locks)) cannam@54: ] cannam@54: in cannam@54: JsonBits.save_json_to lock_file lock_json cannam@54: end cannam@54: cannam@54: fun pad_to n str = cannam@54: if n <= String.size str then str cannam@54: else pad_to n (str ^ " ") cannam@54: cannam@54: fun hline_to 0 = "" cannam@54: | hline_to n = "-" ^ hline_to (n-1) cannam@54: cannam@55: val libname_width = 28 cannam@54: val libstate_width = 11 cannam@54: val localstate_width = 17 cannam@54: val notes_width = 5 cannam@54: val divider = " | " cannam@54: val clear_line = "\r" ^ pad_to 80 ""; cannam@54: cannam@54: fun print_status_header () = cannam@54: print (clear_line ^ "\n " ^ cannam@54: pad_to libname_width "Library" ^ divider ^ cannam@54: pad_to libstate_width "State" ^ divider ^ cannam@54: pad_to localstate_width "Local" ^ divider ^ cannam@54: "Notes" ^ "\n " ^ cannam@54: hline_to libname_width ^ "-+-" ^ cannam@54: hline_to libstate_width ^ "-+-" ^ cannam@54: hline_to localstate_width ^ "-+-" ^ cannam@54: hline_to notes_width ^ "\n") cannam@54: cannam@54: fun print_outcome_header () = cannam@54: print (clear_line ^ "\n " ^ cannam@54: pad_to libname_width "Library" ^ divider ^ cannam@54: pad_to libstate_width "Outcome" ^ divider ^ cannam@54: "Notes" ^ "\n " ^ cannam@54: hline_to libname_width ^ "-+-" ^ cannam@54: hline_to libstate_width ^ "-+-" ^ cannam@54: hline_to notes_width ^ "\n") cannam@54: cannam@55: fun print_status with_network (lib : libspec, status) = cannam@54: let val libstate_str = cannam@54: case status of cannam@54: OK (ABSENT, _) => "Absent" cannam@54: | OK (CORRECT, _) => if with_network then "Correct" else "Present" cannam@54: | OK (SUPERSEDED, _) => "Superseded" cannam@54: | OK (WRONG, _) => "Wrong" cannam@54: | ERROR _ => "Error" cannam@54: val localstate_str = cannam@54: case status of cannam@54: OK (_, MODIFIED) => "Modified" cannam@54: | OK (_, LOCK_MISMATCHED) => "Differs from Lock" cannam@54: | OK (_, CLEAN) => "Clean" cannam@54: | ERROR _ => "" cannam@54: val error_str = cannam@54: case status of cannam@54: ERROR e => e cannam@54: | _ => "" cannam@54: in cannam@54: print (" " ^ cannam@55: pad_to libname_width (#libname lib) ^ divider ^ cannam@54: pad_to libstate_width libstate_str ^ divider ^ cannam@54: pad_to localstate_width localstate_str ^ divider ^ cannam@54: error_str ^ "\n") cannam@54: end cannam@54: cannam@55: fun print_update_outcome (lib : libspec, outcome) = cannam@54: let val outcome_str = cannam@54: case outcome of cannam@54: OK id => "Ok" cannam@54: | ERROR e => "Failed" cannam@54: val error_str = cannam@54: case outcome of cannam@54: ERROR e => e cannam@54: | _ => "" cannam@54: in cannam@54: print (" " ^ cannam@55: pad_to libname_width (#libname lib) ^ divider ^ cannam@54: pad_to libstate_width outcome_str ^ divider ^ cannam@54: error_str ^ "\n") cannam@54: end cannam@54: cannam@55: fun vcs_name HG = ("Mercurial", "hg") cannam@55: | vcs_name GIT = ("Git", "git") cannam@55: | vcs_name SVN = ("Subversion", "svn") cannam@55: cannam@55: fun print_problem_summary context lines = cannam@55: let val failed_vcs = cannam@55: foldl (fn (({ vcs, ... } : libspec, ERROR _), acc) => vcs::acc cannam@55: | (_, acc) => acc) [] lines cannam@55: fun report_nonworking vcs error = cannam@55: print ((if error = "" then "" else error ^ "\n\n") ^ cannam@55: "Error: The project uses the " ^ (#1 (vcs_name vcs)) ^ cannam@55: " version control system, but its\n" ^ cannam@55: "executable program (" ^ (#2 (vcs_name vcs)) ^ cannam@55: ") does not appear to be installed in the program path\n\n") cannam@55: fun check_working [] checked = () cannam@55: | check_working (vcs::rest) checked = cannam@55: if List.exists (fn v => vcs = v) checked cannam@55: then check_working rest checked cannam@55: else cannam@55: case AnyLibControl.is_working context vcs of cannam@55: OK true => check_working rest checked cannam@55: | OK false => (report_nonworking vcs ""; cannam@55: check_working rest (vcs::checked)) cannam@55: | ERROR e => (report_nonworking vcs e; cannam@55: check_working rest (vcs::checked)) cannam@55: in cannam@55: print "\nError: Some operations failed\n\n"; cannam@55: check_working failed_vcs [] cannam@55: end cannam@55: cannam@55: fun act_and_print action print_header print_line context (libs : libspec list) = cannam@55: let val lines = map (fn lib => (lib, action lib)) libs cannam@55: val imperfect = List.exists (fn (_, ERROR _) => true | _ => false) lines cannam@54: val _ = print_header () cannam@54: in cannam@54: app print_line lines; cannam@55: if imperfect then print_problem_summary context lines else (); cannam@54: lines cannam@54: end cannam@54: cannam@54: fun return_code_for outcomes = cannam@54: foldl (fn ((_, result), acc) => cannam@54: case result of cannam@54: ERROR _ => OS.Process.failure cannam@54: | _ => acc) cannam@54: OS.Process.success cannam@54: outcomes cannam@54: cannam@54: fun status_of_project ({ context, libs } : project) = cannam@54: return_code_for (act_and_print (AnyLibControl.status context) cannam@54: print_status_header (print_status false) cannam@55: context libs) cannam@54: cannam@54: fun review_project ({ context, libs } : project) = cannam@54: return_code_for (act_and_print (AnyLibControl.review context) cannam@54: print_status_header (print_status true) cannam@55: context libs) cannam@54: cannam@54: fun lock_project ({ context, libs } : project) = cannam@55: let val _ = if FileBits.verbose () cannam@55: then print ("Scanning IDs for lock file...\n") cannam@55: else () cannam@55: val outcomes = map (fn lib => (lib, AnyLibControl.id_of context lib)) cannam@54: libs cannam@54: val locks = cannam@54: List.concat cannam@55: (map (fn (lib : libspec, result) => cannam@54: case result of cannam@54: ERROR _ => [] cannam@55: | OK id => [{ libname = #libname lib, cannam@55: id_or_tag = id }]) cannam@54: outcomes) cannam@54: val return_code = return_code_for outcomes cannam@54: val _ = print clear_line cannam@54: in cannam@54: if OS.Process.isSuccess return_code cannam@54: then save_lock_file (#rootpath context) locks cannam@54: else (); cannam@54: return_code cannam@54: end cannam@55: cannam@55: fun update_project (project as { context, libs }) = cannam@55: let val outcomes = act_and_print cannam@55: (AnyLibControl.update context) cannam@55: print_outcome_header print_update_outcome cannam@55: context libs cannam@55: val _ = if List.exists (fn (_, OK _) => true | _ => false) outcomes cannam@55: then lock_project project cannam@55: else OS.Process.success cannam@55: in cannam@55: return_code_for outcomes cannam@55: end cannam@55: cannam@54: fun load_local_project pintype = cannam@54: let val userconfig = load_userconfig () cannam@54: val rootpath = OS.FileSys.getDir () cannam@54: in cannam@54: load_project userconfig rootpath pintype cannam@54: end cannam@54: cannam@54: fun with_local_project pintype f = cannam@55: let open OS.Process cannam@55: val return_code = cannam@55: f (load_local_project pintype) cannam@55: handle Fail msg => cannam@55: failure before print ("Error: " ^ msg) cannam@55: | JsonBits.Config msg => cannam@55: failure before print ("Error in configuration: " ^ msg) cannam@55: | e => cannam@55: failure before print ("Error: " ^ exnMessage e) cannam@54: val _ = print "\n"; cannam@54: in cannam@54: return_code cannam@54: end cannam@54: cannam@54: fun review () = with_local_project USE_LOCKFILE review_project cannam@54: fun status () = with_local_project USE_LOCKFILE status_of_project cannam@54: fun update () = with_local_project NO_LOCKFILE update_project cannam@54: fun lock () = with_local_project NO_LOCKFILE lock_project cannam@54: fun install () = with_local_project USE_LOCKFILE update_project cannam@54: cannam@54: fun version () = cannam@55: (print ("v" ^ repoint_version ^ "\n"); cannam@54: OS.Process.success) cannam@54: cannam@54: fun usage () = cannam@55: (print "\nRepoint "; cannam@54: version (); cannam@54: print ("\nA simple manager for third-party source code dependencies.\n\n" cannam@54: ^ "Usage:\n\n" cannam@55: ^ " repoint \n\n" cannam@54: ^ "where is one of:\n\n" cannam@54: ^ " status print quick report on local status only, without using network\n" cannam@54: ^ " review check configured libraries against their providers, and report\n" cannam@54: ^ " install update configured libraries according to project specs and lock file\n" cannam@54: ^ " update update configured libraries and lock file according to project specs\n" cannam@54: ^ " lock update lock file to match local library status\n" cannam@55: ^ " archive pack up project and all libraries into an archive file\n" cannam@55: ^ " (invoke as 'repoint archive target-file.tar.gz')\n" cannam@55: ^ " version print the Repoint version number and exit\n\n"); cannam@54: OS.Process.failure) cannam@54: cannam@55: fun archive target args = cannam@55: case args of cannam@55: [] => cannam@55: with_local_project USE_LOCKFILE (Archive.archive (target, [])) cannam@55: | "--exclude"::xs => cannam@55: with_local_project USE_LOCKFILE (Archive.archive (target, xs)) cannam@55: | _ => usage () cannam@55: cannam@55: fun repoint args = cannam@54: let val return_code = cannam@54: case args of cannam@54: ["review"] => review () cannam@54: | ["status"] => status () cannam@54: | ["install"] => install () cannam@54: | ["update"] => update () cannam@54: | ["lock"] => lock () cannam@54: | ["version"] => version () cannam@55: | "archive"::target::args => archive target args cannam@55: | arg::_ => (print ("Error: unknown argument \"" ^ arg ^ "\"\n"); cannam@55: usage ()) cannam@54: | _ => usage () cannam@54: in cannam@54: OS.Process.exit return_code; cannam@54: () cannam@54: end cannam@54: cannam@54: fun main () = cannam@55: repoint (CommandLine.arguments ())