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