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