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