annotate repoint.sml @ 2596:04d381f0d89a tip

Default branch is now named default on git as well as hg, in case we ever want to switch to mirroring in the other direction
author Chris Cannam
date Thu, 27 Aug 2020 15:58:56 +0100
parents 186a452dddd3
children
rev   line source
Chris@1808 1 (*
Chris@1808 2 DO NOT EDIT THIS FILE.
Chris@1808 3 This file is automatically generated from the individual
Chris@1808 4 source files in the Repoint repository.
Chris@1808 5 *)
Chris@1808 6
Chris@1808 7 (*
Chris@1808 8 Repoint
Chris@1808 9
Chris@1808 10 A simple manager for third-party source code dependencies
Chris@1808 11
Chris@1808 12 Copyright 2018 Chris Cannam, Particular Programs Ltd,
Chris@1808 13 and Queen Mary, University of London
Chris@1808 14
Chris@1808 15 Permission is hereby granted, free of charge, to any person
Chris@1808 16 obtaining a copy of this software and associated documentation
Chris@1808 17 files (the "Software"), to deal in the Software without
Chris@1808 18 restriction, including without limitation the rights to use, copy,
Chris@1808 19 modify, merge, publish, distribute, sublicense, and/or sell copies
Chris@1808 20 of the Software, and to permit persons to whom the Software is
Chris@1808 21 furnished to do so, subject to the following conditions:
Chris@1808 22
Chris@1808 23 The above copyright notice and this permission notice shall be
Chris@1808 24 included in all copies or substantial portions of the Software.
Chris@1808 25
Chris@1808 26 THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
Chris@1808 27 EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
Chris@1808 28 MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
Chris@1808 29 NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR
Chris@1808 30 ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF
Chris@1808 31 CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
Chris@1808 32 WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
Chris@1808 33
Chris@1808 34 Except as contained in this notice, the names of Chris Cannam,
Chris@1808 35 Particular Programs Ltd, and Queen Mary, University of London
Chris@1808 36 shall not be used in advertising or otherwise to promote the sale,
Chris@1808 37 use or other dealings in this Software without prior written
Chris@1808 38 authorization.
Chris@1808 39 *)
Chris@1808 40
Chris@2311 41 val repoint_version = "1.2"
Chris@1808 42
Chris@1808 43
Chris@1808 44 datatype vcs =
Chris@1808 45 HG |
Chris@1808 46 GIT |
Chris@1808 47 SVN
Chris@1808 48
Chris@1808 49 datatype source =
Chris@1808 50 URL_SOURCE of string |
Chris@1808 51 SERVICE_SOURCE of {
Chris@1808 52 service : string,
Chris@1808 53 owner : string option,
Chris@1808 54 repo : string option
Chris@1808 55 }
Chris@1808 56
Chris@1808 57 type id_or_tag = string
Chris@1808 58
Chris@1808 59 datatype pin =
Chris@1808 60 UNPINNED |
Chris@1808 61 PINNED of id_or_tag
Chris@1808 62
Chris@1808 63 datatype libstate =
Chris@1808 64 ABSENT |
Chris@1808 65 CORRECT |
Chris@1808 66 SUPERSEDED |
Chris@1808 67 WRONG
Chris@1808 68
Chris@1808 69 datatype localstate =
Chris@1808 70 MODIFIED |
Chris@1808 71 LOCK_MISMATCHED |
Chris@1808 72 CLEAN
Chris@1808 73
Chris@1808 74 datatype branch =
Chris@1808 75 BRANCH of string |
Chris@1808 76 DEFAULT_BRANCH
Chris@1808 77
Chris@1808 78 (* If we can recover from an error, for example by reporting failure
Chris@1808 79 for this one thing and going on to the next thing, then the error
Chris@1808 80 should usually be returned through a result type rather than an
Chris@1808 81 exception. *)
Chris@1808 82
Chris@1808 83 datatype 'a result =
Chris@1808 84 OK of 'a |
Chris@1808 85 ERROR of string
Chris@1808 86
Chris@1808 87 type libname = string
Chris@1808 88
Chris@1808 89 type libspec = {
Chris@1808 90 libname : libname,
Chris@1808 91 vcs : vcs,
Chris@1808 92 source : source,
Chris@1808 93 branch : branch,
Chris@1808 94 project_pin : pin,
Chris@1808 95 lock_pin : pin
Chris@1808 96 }
Chris@1808 97
Chris@1808 98 type lock = {
Chris@1808 99 libname : libname,
Chris@1808 100 id_or_tag : id_or_tag
Chris@1808 101 }
Chris@1808 102
Chris@1808 103 type remote_spec = {
Chris@1808 104 anon : string option,
Chris@1808 105 auth : string option
Chris@1808 106 }
Chris@1808 107
Chris@1808 108 type provider = {
Chris@1808 109 service : string,
Chris@1808 110 supports : vcs list,
Chris@1808 111 remote_spec : remote_spec
Chris@1808 112 }
Chris@1808 113
Chris@1808 114 type account = {
Chris@1808 115 service : string,
Chris@1808 116 login : string
Chris@1808 117 }
Chris@1808 118
Chris@1808 119 type context = {
Chris@1808 120 rootpath : string,
Chris@1808 121 extdir : string,
Chris@1808 122 providers : provider list,
Chris@1808 123 accounts : account list
Chris@1808 124 }
Chris@1808 125
Chris@1808 126 type userconfig = {
Chris@1808 127 providers : provider list,
Chris@1808 128 accounts : account list
Chris@1808 129 }
Chris@1808 130
Chris@1808 131 type project = {
Chris@1808 132 context : context,
Chris@1808 133 libs : libspec list
Chris@1808 134 }
Chris@1808 135
Chris@1808 136 structure RepointFilenames = struct
Chris@1808 137 val project_file = "repoint-project.json"
Chris@1808 138 val project_lock_file = "repoint-lock.json"
Chris@1865 139 val project_completion_file = ".repoint.point"
Chris@1808 140 val user_config_file = ".repoint.json"
Chris@1808 141 val archive_dir = ".repoint-archive"
Chris@1808 142 end
Chris@1808 143
Chris@1808 144 signature VCS_CONTROL = sig
Chris@1808 145
Chris@1808 146 (** Check whether the given VCS is installed and working *)
Chris@1808 147 val is_working : context -> bool result
Chris@1808 148
Chris@1808 149 (** Test whether the library is present locally at all *)
Chris@1808 150 val exists : context -> libname -> bool result
Chris@1808 151
Chris@1808 152 (** Return the id (hash) of the current revision for the library *)
Chris@1808 153 val id_of : context -> libname -> id_or_tag result
Chris@1808 154
Chris@1808 155 (** Test whether the library is at the given id *)
Chris@1808 156 val is_at : context -> libname * id_or_tag -> bool result
Chris@1808 157
Chris@1808 158 (** Test whether the library is on the given branch, i.e. is at
Chris@1808 159 the branch tip or an ancestor of it *)
Chris@1808 160 val is_on_branch : context -> libname * branch -> bool result
Chris@1808 161
Chris@1808 162 (** Test whether the library is at the newest revision for the
Chris@1808 163 given branch. False may indicate that the branch has advanced
Chris@1808 164 or that the library is not on the branch at all. This function
Chris@1808 165 may use the network to check for new revisions *)
Chris@1808 166 val is_newest : context -> libname * source * branch -> bool result
Chris@1808 167
Chris@1808 168 (** Test whether the library is at the newest revision available
Chris@1808 169 locally for the given branch. False may indicate that the
Chris@1808 170 branch has advanced or that the library is not on the branch
Chris@1808 171 at all. This function must not use the network *)
Chris@1808 172 val is_newest_locally : context -> libname * branch -> bool result
Chris@1808 173
Chris@1808 174 (** Test whether the library has been modified in the local
Chris@1808 175 working copy *)
Chris@1808 176 val is_modified_locally : context -> libname -> bool result
Chris@1808 177
Chris@1808 178 (** Check out, i.e. clone a fresh copy of, the repo for the given
Chris@1808 179 library on the given branch *)
Chris@1808 180 val checkout : context -> libname * source * branch -> unit result
Chris@1808 181
Chris@1808 182 (** Update the library to the given branch tip. Assumes that a
Chris@1808 183 local copy of the library already exists *)
Chris@1808 184 val update : context -> libname * source * branch -> unit result
Chris@1808 185
Chris@1808 186 (** Update the library to the given specific id or tag *)
Chris@1808 187 val update_to : context -> libname * source * id_or_tag -> unit result
Chris@1808 188
Chris@1808 189 (** Return a URL from which the library can be cloned, given that
Chris@1808 190 the local copy already exists. For a DVCS this can be the
Chris@1808 191 local copy, but for a centralised VCS it will have to be the
Chris@1808 192 remote repository URL. Used for archiving *)
Chris@1808 193 val copy_url_for : context -> libname -> string result
Chris@1808 194 end
Chris@1808 195
Chris@1808 196 signature LIB_CONTROL = sig
Chris@1808 197 val review : context -> libspec -> (libstate * localstate) result
Chris@1808 198 val status : context -> libspec -> (libstate * localstate) result
Chris@1808 199 val update : context -> libspec -> unit result
Chris@1808 200 val id_of : context -> libspec -> id_or_tag result
Chris@1808 201 val is_working : context -> vcs -> bool result
Chris@1808 202 end
Chris@1808 203
Chris@1808 204 structure FileBits :> sig
Chris@1808 205 val extpath : context -> string
Chris@1808 206 val libpath : context -> libname -> string
Chris@1808 207 val subpath : context -> libname -> string -> string
Chris@1808 208 val command_output : context -> libname -> string list -> string result
Chris@1808 209 val command : context -> libname -> string list -> unit result
Chris@1808 210 val file_url : string -> string
Chris@1808 211 val file_contents : string -> string
Chris@1808 212 val mydir : unit -> string
Chris@1808 213 val homedir : unit -> string
Chris@1808 214 val mkpath : string -> unit result
Chris@1808 215 val rmpath : string -> unit result
Chris@1808 216 val nonempty_dir_exists : string -> bool
Chris@1808 217 val project_spec_path : string -> string
Chris@1808 218 val project_lock_path : string -> string
Chris@1865 219 val project_completion_path : string -> string
Chris@1808 220 val verbose : unit -> bool
Chris@1808 221 end = struct
Chris@1808 222
Chris@1808 223 fun verbose () =
Chris@1808 224 case OS.Process.getEnv "REPOINT_VERBOSE" of
Chris@1808 225 SOME "0" => false
Chris@1808 226 | SOME _ => true
Chris@1808 227 | NONE => false
Chris@1808 228
Chris@1808 229 fun split_relative path desc =
Chris@1808 230 case OS.Path.fromString path of
Chris@1808 231 { isAbs = true, ... } => raise Fail (desc ^ " may not be absolute")
Chris@1808 232 | { arcs, ... } => arcs
Chris@1808 233
Chris@1808 234 fun extpath ({ rootpath, extdir, ... } : context) =
Chris@1808 235 let val { isAbs, vol, arcs } = OS.Path.fromString rootpath
Chris@1808 236 in OS.Path.toString {
Chris@1808 237 isAbs = isAbs,
Chris@1808 238 vol = vol,
Chris@1808 239 arcs = arcs @
Chris@1808 240 split_relative extdir "extdir"
Chris@1808 241 }
Chris@1808 242 end
Chris@1808 243
Chris@1808 244 fun subpath ({ rootpath, extdir, ... } : context) libname remainder =
Chris@1808 245 (* NB libname is allowed to be a path fragment, e.g. foo/bar *)
Chris@1808 246 let val { isAbs, vol, arcs } = OS.Path.fromString rootpath
Chris@1808 247 in OS.Path.toString {
Chris@1808 248 isAbs = isAbs,
Chris@1808 249 vol = vol,
Chris@1808 250 arcs = arcs @
Chris@1808 251 split_relative extdir "extdir" @
Chris@1808 252 split_relative libname "library path" @
Chris@1808 253 split_relative remainder "subpath"
Chris@1808 254 }
Chris@1808 255 end
Chris@1808 256
Chris@1808 257 fun libpath context "" =
Chris@1808 258 extpath context
Chris@1808 259 | libpath context libname =
Chris@1808 260 subpath context libname ""
Chris@1808 261
Chris@1808 262 fun project_file_path rootpath filename =
Chris@1808 263 let val { isAbs, vol, arcs } = OS.Path.fromString rootpath
Chris@1808 264 in OS.Path.toString {
Chris@1808 265 isAbs = isAbs,
Chris@1808 266 vol = vol,
Chris@1808 267 arcs = arcs @ [ filename ]
Chris@1808 268 }
Chris@1808 269 end
Chris@1808 270
Chris@1808 271 fun project_spec_path rootpath =
Chris@1808 272 project_file_path rootpath (RepointFilenames.project_file)
Chris@1808 273
Chris@1808 274 fun project_lock_path rootpath =
Chris@1808 275 project_file_path rootpath (RepointFilenames.project_lock_file)
Chris@1808 276
Chris@1865 277 fun project_completion_path rootpath =
Chris@1865 278 project_file_path rootpath (RepointFilenames.project_completion_file)
Chris@1865 279
Chris@1808 280 fun trim str =
Chris@1808 281 hd (String.fields (fn x => x = #"\n" orelse x = #"\r") str)
Chris@2293 282
Chris@2293 283 fun make_canonical path =
Chris@2293 284 (* SML/NJ doesn't properly handle "/" when splitting paths -
Chris@2293 285 it should be a path separator even on Windows, but SML/NJ
Chris@2293 286 treats it as a normal filename character there. So we must
Chris@2293 287 convert these explicitly *)
Chris@2293 288 OS.Path.mkCanonical
Chris@2293 289 (if OS.Path.concat ("a", "b") = "a\\b"
Chris@2293 290 then String.translate (fn #"/" => "\\" |
Chris@2293 291 c => Char.toString c)
Chris@2293 292 path
Chris@2293 293 else path)
Chris@1808 294
Chris@1808 295 fun file_url path =
Chris@1808 296 let val forward_path =
Chris@1808 297 String.translate (fn #"\\" => "/" |
Chris@1808 298 c => Char.toString c)
Chris@1808 299 (OS.Path.mkCanonical path)
Chris@1808 300 in
Chris@1808 301 (* Path is expected to be absolute already, but if it
Chris@1808 302 starts with a drive letter, we'll need an extra slash *)
Chris@1808 303 case explode forward_path of
Chris@1808 304 #"/"::rest => "file:///" ^ implode rest
Chris@1808 305 | _ => "file:///" ^ forward_path
Chris@1808 306 end
Chris@1808 307
Chris@1808 308 fun file_contents filename =
Chris@1808 309 let val stream = TextIO.openIn filename
Chris@1808 310 fun read_all str acc =
Chris@1808 311 case TextIO.inputLine str of
Chris@1808 312 SOME line => read_all str (trim line :: acc)
Chris@1808 313 | NONE => rev acc
Chris@1808 314 val contents = read_all stream []
Chris@1808 315 val _ = TextIO.closeIn stream
Chris@1808 316 in
Chris@1808 317 String.concatWith "\n" contents
Chris@1808 318 end
Chris@1808 319
Chris@1808 320 fun expand_commandline cmdlist =
Chris@1808 321 (* We are quite strict about what we accept here, except
Chris@1808 322 for the first element in cmdlist which is assumed to be a
Chris@1808 323 known command location rather than arbitrary user input. *)
Chris@1808 324 let open Char
Chris@1808 325 fun quote arg =
Chris@1808 326 if List.all
Chris@1808 327 (fn c => isAlphaNum c orelse c = #"-" orelse c = #"_")
Chris@1808 328 (explode arg)
Chris@1808 329 then arg
Chris@1808 330 else "\"" ^ arg ^ "\""
Chris@1808 331 fun check arg =
Chris@2311 332 let val valid = explode " /#:;?,._-{}@=+%"
Chris@1808 333 in
Chris@1808 334 app (fn c =>
Chris@1808 335 if isAlphaNum c orelse
Chris@1808 336 List.exists (fn v => v = c) valid orelse
Chris@1808 337 c > chr 127
Chris@1808 338 then ()
Chris@1808 339 else raise Fail ("Invalid character '" ^
Chris@1808 340 (Char.toString c) ^
Chris@1808 341 "' in command list"))
Chris@1808 342 (explode arg);
Chris@1808 343 arg
Chris@1808 344 end
Chris@1808 345 in
Chris@1808 346 String.concatWith " "
Chris@1808 347 (map quote
Chris@1808 348 (hd cmdlist :: map check (tl cmdlist)))
Chris@1808 349 end
Chris@1808 350
Chris@1808 351 val tick_cycle = ref 0
Chris@1808 352 val tick_chars = Vector.fromList (map String.str (explode "|/-\\"))
Chris@1808 353
Chris@1808 354 fun tick libname cmdlist =
Chris@1808 355 let val n = Vector.length tick_chars
Chris@1808 356 fun pad_to n str =
Chris@1808 357 if n <= String.size str then str
Chris@1808 358 else pad_to n (str ^ " ")
Chris@1808 359 val name = if libname <> "" then libname
Chris@1808 360 else if cmdlist = nil then ""
Chris@1808 361 else hd (rev cmdlist)
Chris@1808 362 in
Chris@1808 363 print (" " ^
Chris@1808 364 Vector.sub(tick_chars, !tick_cycle) ^ " " ^
Chris@1808 365 pad_to 70 name ^
Chris@1808 366 "\r");
Chris@1808 367 tick_cycle := (if !tick_cycle = n - 1 then 0 else 1 + !tick_cycle)
Chris@1808 368 end
Chris@1808 369
Chris@1808 370 fun run_command context libname cmdlist redirect =
Chris@1808 371 let open OS
Chris@1808 372 val dir = libpath context libname
Chris@1808 373 val cmd = expand_commandline cmdlist
Chris@1808 374 val _ = if verbose ()
Chris@1808 375 then print ("\n=== " ^ dir ^ "\n<<< " ^ cmd ^ "\n")
Chris@1808 376 else tick libname cmdlist
Chris@1808 377 val _ = FileSys.chDir dir
Chris@1808 378 val status = case redirect of
Chris@1808 379 NONE => Process.system cmd
Chris@1808 380 | SOME file => Process.system (cmd ^ ">" ^ file)
Chris@1808 381 in
Chris@1808 382 if Process.isSuccess status
Chris@1808 383 then OK ()
Chris@1808 384 else ERROR ("Command failed: " ^ cmd ^ " (in dir " ^ dir ^ ")")
Chris@1808 385 end
Chris@1808 386 handle ex => ERROR ("Unable to run command: " ^ exnMessage ex)
Chris@1808 387
Chris@1808 388 fun command context libname cmdlist =
Chris@1808 389 run_command context libname cmdlist NONE
Chris@1808 390
Chris@1808 391 fun command_output context libname cmdlist =
Chris@1808 392 let open OS
Chris@1808 393 val tmpFile = FileSys.tmpName ()
Chris@1808 394 val result = run_command context libname cmdlist (SOME tmpFile)
Chris@1808 395 val contents = file_contents tmpFile
Chris@1808 396 val _ = if verbose ()
Chris@1808 397 then print (">>> \"" ^ contents ^ "\"\n")
Chris@1808 398 else ()
Chris@1808 399 in
Chris@1808 400 FileSys.remove tmpFile handle _ => ();
Chris@1808 401 case result of
Chris@1808 402 OK () => OK contents
Chris@1808 403 | ERROR e => ERROR e
Chris@1808 404 end
Chris@1808 405
Chris@1808 406 fun mydir () =
Chris@1808 407 let open OS
Chris@1808 408 val { dir, file } = Path.splitDirFile (CommandLine.name ())
Chris@1808 409 in
Chris@1808 410 FileSys.realPath
Chris@1808 411 (if Path.isAbsolute dir
Chris@1808 412 then dir
Chris@1808 413 else Path.concat (FileSys.getDir (), dir))
Chris@1808 414 end
Chris@1808 415
Chris@1808 416 fun homedir () =
Chris@1808 417 (* Failure is not routine, so we use an exception here *)
Chris@1808 418 case (OS.Process.getEnv "HOME",
Chris@1808 419 OS.Process.getEnv "HOMEPATH") of
Chris@1808 420 (SOME home, _) => home
Chris@1808 421 | (NONE, SOME home) => home
Chris@1808 422 | (NONE, NONE) =>
Chris@1808 423 raise Fail "Failed to look up home directory from environment"
Chris@1808 424
Chris@1808 425 fun mkpath' path =
Chris@1808 426 if OS.FileSys.isDir path handle _ => false
Chris@1808 427 then OK ()
Chris@1808 428 else case OS.Path.fromString path of
Chris@1808 429 { arcs = nil, ... } => OK ()
Chris@1808 430 | { isAbs = false, ... } => ERROR "mkpath requires absolute path"
Chris@1808 431 | { isAbs, vol, arcs } =>
Chris@1808 432 case mkpath' (OS.Path.toString { (* parent *)
Chris@1808 433 isAbs = isAbs,
Chris@1808 434 vol = vol,
Chris@1808 435 arcs = rev (tl (rev arcs)) }) of
Chris@1808 436 ERROR e => ERROR e
Chris@1808 437 | OK () => ((OS.FileSys.mkDir path; OK ())
Chris@1808 438 handle OS.SysErr (e, _) =>
Chris@1808 439 ERROR ("Directory creation failed: " ^ e))
Chris@1808 440
Chris@1808 441 fun mkpath path =
Chris@2293 442 mkpath' (make_canonical path)
Chris@1808 443
Chris@1808 444 fun dir_contents dir =
Chris@1808 445 let open OS
Chris@1808 446 fun files_from dirstream =
Chris@1808 447 case FileSys.readDir dirstream of
Chris@1808 448 NONE => []
Chris@1808 449 | SOME file =>
Chris@1808 450 (* readDir is supposed to filter these,
Chris@1808 451 but let's be extra cautious: *)
Chris@1808 452 if file = Path.parentArc orelse file = Path.currentArc
Chris@1808 453 then files_from dirstream
Chris@1808 454 else file :: files_from dirstream
Chris@1808 455 val stream = FileSys.openDir dir
Chris@1808 456 val files = map (fn f => Path.joinDirFile
Chris@1808 457 { dir = dir, file = f })
Chris@1808 458 (files_from stream)
Chris@1808 459 val _ = FileSys.closeDir stream
Chris@1808 460 in
Chris@1808 461 files
Chris@1808 462 end
Chris@1808 463
Chris@1808 464 fun rmpath' path =
Chris@1808 465 let open OS
Chris@1808 466 fun remove path =
Chris@1808 467 if FileSys.isLink path (* dangling links bother isDir *)
Chris@1808 468 then FileSys.remove path
Chris@1808 469 else if FileSys.isDir path
Chris@1808 470 then (app remove (dir_contents path); FileSys.rmDir path)
Chris@1808 471 else FileSys.remove path
Chris@1808 472 in
Chris@1808 473 (remove path; OK ())
Chris@1808 474 handle SysErr (e, _) => ERROR ("Path removal failed: " ^ e)
Chris@1808 475 end
Chris@1808 476
Chris@1808 477 fun rmpath path =
Chris@2293 478 rmpath' (make_canonical path)
Chris@1808 479
Chris@1808 480 fun nonempty_dir_exists path =
Chris@1808 481 let open OS.FileSys
Chris@1808 482 in
Chris@1808 483 (not (isLink path) andalso
Chris@1808 484 isDir path andalso
Chris@1808 485 dir_contents path <> [])
Chris@1808 486 handle _ => false
Chris@1808 487 end
Chris@1808 488
Chris@1808 489 end
Chris@1808 490
Chris@1808 491 functor LibControlFn (V: VCS_CONTROL) :> LIB_CONTROL = struct
Chris@1808 492
Chris@1808 493 (* Valid states for unpinned libraries:
Chris@1808 494
Chris@1808 495 - CORRECT: We are on the right branch and are up-to-date with
Chris@1808 496 it as far as we can tell. (If not using the network, this
Chris@1808 497 should be reported to user as "Present" rather than "Correct"
Chris@1808 498 as the remote repo may have advanced without us knowing.)
Chris@1808 499
Chris@1808 500 - SUPERSEDED: We are on the right branch but we can see that
Chris@1808 501 there is a newer revision either locally or on the remote (in
Chris@1808 502 Git terms, we are at an ancestor of the desired branch tip).
Chris@1808 503
Chris@1808 504 - WRONG: We are on the wrong branch (in Git terms, we are not
Chris@1808 505 at the desired branch tip or any ancestor of it).
Chris@1808 506
Chris@1808 507 - ABSENT: Repo doesn't exist here at all.
Chris@1808 508
Chris@1808 509 Valid states for pinned libraries:
Chris@1808 510
Chris@1808 511 - CORRECT: We are at the pinned revision.
Chris@1808 512
Chris@1808 513 - WRONG: We are at any revision other than the pinned one.
Chris@1808 514
Chris@1808 515 - ABSENT: Repo doesn't exist here at all.
Chris@1808 516 *)
Chris@1808 517
Chris@1808 518 fun check with_network context
Chris@1808 519 ({ libname, source, branch,
Chris@1808 520 project_pin, lock_pin, ... } : libspec) =
Chris@1808 521 let fun check_unpinned () =
Chris@1808 522 let val newest =
Chris@1808 523 if with_network
Chris@1808 524 then V.is_newest context (libname, source, branch)
Chris@1808 525 else V.is_newest_locally context (libname, branch)
Chris@1808 526 in
Chris@1808 527 case newest of
Chris@1808 528 ERROR e => ERROR e
Chris@1808 529 | OK true => OK CORRECT
Chris@1808 530 | OK false =>
Chris@1808 531 case V.is_on_branch context (libname, branch) of
Chris@1808 532 ERROR e => ERROR e
Chris@1808 533 | OK true => OK SUPERSEDED
Chris@1808 534 | OK false => OK WRONG
Chris@1808 535 end
Chris@1808 536 fun check_pinned target =
Chris@1808 537 case V.is_at context (libname, target) of
Chris@1808 538 ERROR e => ERROR e
Chris@1808 539 | OK true => OK CORRECT
Chris@1808 540 | OK false => OK WRONG
Chris@1808 541 fun check_remote () =
Chris@1808 542 case project_pin of
Chris@1808 543 UNPINNED => check_unpinned ()
Chris@1808 544 | PINNED target => check_pinned target
Chris@1808 545 fun check_local () =
Chris@1808 546 case V.is_modified_locally context libname of
Chris@1808 547 ERROR e => ERROR e
Chris@1808 548 | OK true => OK MODIFIED
Chris@1808 549 | OK false =>
Chris@1808 550 case lock_pin of
Chris@1808 551 UNPINNED => OK CLEAN
Chris@1808 552 | PINNED target =>
Chris@1808 553 case V.is_at context (libname, target) of
Chris@1808 554 ERROR e => ERROR e
Chris@1808 555 | OK true => OK CLEAN
Chris@1808 556 | OK false => OK LOCK_MISMATCHED
Chris@1808 557 in
Chris@1808 558 case V.exists context libname of
Chris@1808 559 ERROR e => ERROR e
Chris@1808 560 | OK false => OK (ABSENT, CLEAN)
Chris@1808 561 | OK true =>
Chris@1808 562 case (check_remote (), check_local ()) of
Chris@1808 563 (ERROR e, _) => ERROR e
Chris@1808 564 | (_, ERROR e) => ERROR e
Chris@1808 565 | (OK r, OK l) => OK (r, l)
Chris@1808 566 end
Chris@1808 567
Chris@1808 568 val review = check true
Chris@1808 569 val status = check false
Chris@1808 570
Chris@1808 571 fun update context
Chris@1808 572 ({ libname, source, branch,
Chris@1808 573 project_pin, lock_pin, ... } : libspec) =
Chris@1808 574 let fun update_unpinned () =
Chris@1808 575 case V.is_newest context (libname, source, branch) of
Chris@1808 576 ERROR e => ERROR e
Chris@1808 577 | OK true => OK ()
Chris@1808 578 | OK false => V.update context (libname, source, branch)
Chris@1808 579 fun update_pinned target =
Chris@1808 580 case V.is_at context (libname, target) of
Chris@1808 581 ERROR e => ERROR e
Chris@1808 582 | OK true => OK ()
Chris@1808 583 | OK false => V.update_to context (libname, source, target)
Chris@1808 584 fun update' () =
Chris@1808 585 case lock_pin of
Chris@1808 586 PINNED target => update_pinned target
Chris@1808 587 | UNPINNED =>
Chris@1808 588 case project_pin of
Chris@1808 589 PINNED target => update_pinned target
Chris@1808 590 | UNPINNED => update_unpinned ()
Chris@1808 591 in
Chris@1808 592 case V.exists context libname of
Chris@1808 593 ERROR e => ERROR e
Chris@1808 594 | OK true => update' ()
Chris@1808 595 | OK false =>
Chris@1808 596 case V.checkout context (libname, source, branch) of
Chris@1808 597 ERROR e => ERROR e
Chris@1808 598 | OK () => update' ()
Chris@1808 599 end
Chris@1808 600
Chris@1808 601 fun id_of context ({ libname, ... } : libspec) =
Chris@1808 602 V.id_of context libname
Chris@1808 603
Chris@1808 604 fun is_working context vcs =
Chris@1808 605 V.is_working context
Chris@1808 606
Chris@1808 607 end
Chris@1808 608
Chris@1808 609 (* Simple Standard ML JSON parser
Chris@1808 610 https://bitbucket.org/cannam/sml-simplejson
Chris@1808 611 Copyright 2017 Chris Cannam. BSD licence.
Chris@1808 612 Parts based on the JSON parser in the Ponyo library by Phil Eaton.
Chris@1808 613 *)
Chris@1808 614
Chris@1808 615 signature JSON = sig
Chris@1808 616
Chris@1808 617 datatype json = OBJECT of (string * json) list
Chris@1808 618 | ARRAY of json list
Chris@1808 619 | NUMBER of real
Chris@1808 620 | STRING of string
Chris@1808 621 | BOOL of bool
Chris@1808 622 | NULL
Chris@1808 623
Chris@1808 624 datatype 'a result = OK of 'a
Chris@1808 625 | ERROR of string
Chris@1808 626
Chris@1808 627 val parse : string -> json result
Chris@1808 628 val serialise : json -> string
Chris@1808 629 val serialiseIndented : json -> string
Chris@1808 630
Chris@1808 631 end
Chris@1808 632
Chris@1808 633 structure Json :> JSON = struct
Chris@1808 634
Chris@1808 635 datatype json = OBJECT of (string * json) list
Chris@1808 636 | ARRAY of json list
Chris@1808 637 | NUMBER of real
Chris@1808 638 | STRING of string
Chris@1808 639 | BOOL of bool
Chris@1808 640 | NULL
Chris@1808 641
Chris@1808 642 datatype 'a result = OK of 'a
Chris@1808 643 | ERROR of string
Chris@1808 644
Chris@1808 645 structure T = struct
Chris@1808 646 datatype token = NUMBER of char list
Chris@1808 647 | STRING of string
Chris@1808 648 | BOOL of bool
Chris@1808 649 | NULL
Chris@1808 650 | CURLY_L
Chris@1808 651 | CURLY_R
Chris@1808 652 | SQUARE_L
Chris@1808 653 | SQUARE_R
Chris@1808 654 | COLON
Chris@1808 655 | COMMA
Chris@1808 656
Chris@1808 657 fun toString t =
Chris@1808 658 case t of NUMBER digits => implode digits
Chris@1808 659 | STRING s => s
Chris@1808 660 | BOOL b => Bool.toString b
Chris@1808 661 | NULL => "null"
Chris@1808 662 | CURLY_L => "{"
Chris@1808 663 | CURLY_R => "}"
Chris@1808 664 | SQUARE_L => "["
Chris@1808 665 | SQUARE_R => "]"
Chris@1808 666 | COLON => ":"
Chris@1808 667 | COMMA => ","
Chris@1808 668 end
Chris@1808 669
Chris@1808 670 fun bmpToUtf8 cp = (* convert a codepoint in Unicode BMP to utf8 bytes *)
Chris@1808 671 let open Word
Chris@1808 672 infix 6 orb andb >>
Chris@1808 673 in
Chris@1808 674 map (Char.chr o toInt)
Chris@1808 675 (if cp < 0wx80 then
Chris@1808 676 [cp]
Chris@1808 677 else if cp < 0wx800 then
Chris@1808 678 [0wxc0 orb (cp >> 0w6), 0wx80 orb (cp andb 0wx3f)]
Chris@1808 679 else if cp < 0wx10000 then
Chris@1808 680 [0wxe0 orb (cp >> 0w12),
Chris@1808 681 0wx80 orb ((cp >> 0w6) andb 0wx3f),
Chris@1808 682 0wx80 orb (cp andb 0wx3f)]
Chris@1808 683 else raise Fail ("Invalid BMP point " ^ (Word.toString cp)))
Chris@1808 684 end
Chris@1808 685
Chris@1808 686 fun error pos text = ERROR (text ^ " at character position " ^
Chris@1808 687 Int.toString (pos - 1))
Chris@1808 688 fun token_error pos = error pos ("Unexpected token")
Chris@1808 689
Chris@1808 690 fun lexNull pos acc (#"u" :: #"l" :: #"l" :: xs) =
Chris@1808 691 lex (pos + 3) (T.NULL :: acc) xs
Chris@1808 692 | lexNull pos acc _ = token_error pos
Chris@1808 693
Chris@1808 694 and lexTrue pos acc (#"r" :: #"u" :: #"e" :: xs) =
Chris@1808 695 lex (pos + 3) (T.BOOL true :: acc) xs
Chris@1808 696 | lexTrue pos acc _ = token_error pos
Chris@1808 697
Chris@1808 698 and lexFalse pos acc (#"a" :: #"l" :: #"s" :: #"e" :: xs) =
Chris@1808 699 lex (pos + 4) (T.BOOL false :: acc) xs
Chris@1808 700 | lexFalse pos acc _ = token_error pos
Chris@1808 701
Chris@1808 702 and lexChar tok pos acc xs =
Chris@1808 703 lex pos (tok :: acc) xs
Chris@1808 704
Chris@1808 705 and lexString pos acc cc =
Chris@1808 706 let datatype escaped = ESCAPED | NORMAL
Chris@1808 707 fun lexString' pos text ESCAPED [] =
Chris@1808 708 error pos "End of input during escape sequence"
Chris@1808 709 | lexString' pos text NORMAL [] =
Chris@1808 710 error pos "End of input during string"
Chris@1808 711 | lexString' pos text ESCAPED (x :: xs) =
Chris@1808 712 let fun esc c = lexString' (pos + 1) (c :: text) NORMAL xs
Chris@1808 713 in case x of
Chris@1808 714 #"\"" => esc x
Chris@1808 715 | #"\\" => esc x
Chris@1808 716 | #"/" => esc x
Chris@1808 717 | #"b" => esc #"\b"
Chris@1808 718 | #"f" => esc #"\f"
Chris@1808 719 | #"n" => esc #"\n"
Chris@1808 720 | #"r" => esc #"\r"
Chris@1808 721 | #"t" => esc #"\t"
Chris@1808 722 | _ => error pos ("Invalid escape \\" ^
Chris@1808 723 Char.toString x)
Chris@1808 724 end
Chris@1808 725 | lexString' pos text NORMAL (#"\\" :: #"u" ::a::b::c::d:: xs) =
Chris@1808 726 if List.all Char.isHexDigit [a,b,c,d]
Chris@1808 727 then case Word.fromString ("0wx" ^ (implode [a,b,c,d])) of
Chris@1808 728 SOME w => (let val utf = rev (bmpToUtf8 w) in
Chris@1808 729 lexString' (pos + 6) (utf @ text)
Chris@1808 730 NORMAL xs
Chris@1808 731 end
Chris@1808 732 handle Fail err => error pos err)
Chris@1808 733 | NONE => error pos "Invalid Unicode BMP escape sequence"
Chris@1808 734 else error pos "Invalid Unicode BMP escape sequence"
Chris@1808 735 | lexString' pos text NORMAL (x :: xs) =
Chris@1808 736 if Char.ord x < 0x20
Chris@1808 737 then error pos "Invalid unescaped control character"
Chris@1808 738 else
Chris@1808 739 case x of
Chris@1808 740 #"\"" => OK (rev text, xs, pos + 1)
Chris@1808 741 | #"\\" => lexString' (pos + 1) text ESCAPED xs
Chris@1808 742 | _ => lexString' (pos + 1) (x :: text) NORMAL xs
Chris@1808 743 in
Chris@1808 744 case lexString' pos [] NORMAL cc of
Chris@1808 745 OK (text, rest, newpos) =>
Chris@1808 746 lex newpos (T.STRING (implode text) :: acc) rest
Chris@1808 747 | ERROR e => ERROR e
Chris@1808 748 end
Chris@1808 749
Chris@1808 750 and lexNumber firstChar pos acc cc =
Chris@1808 751 let val valid = explode ".+-e"
Chris@1808 752 fun lexNumber' pos digits [] = (rev digits, [], pos)
Chris@1808 753 | lexNumber' pos digits (x :: xs) =
Chris@1808 754 if x = #"E" then lexNumber' (pos + 1) (#"e" :: digits) xs
Chris@1808 755 else if Char.isDigit x orelse List.exists (fn c => x = c) valid
Chris@1808 756 then lexNumber' (pos + 1) (x :: digits) xs
Chris@1808 757 else (rev digits, x :: xs, pos)
Chris@1808 758 val (digits, rest, newpos) =
Chris@1808 759 lexNumber' (pos - 1) [] (firstChar :: cc)
Chris@1808 760 in
Chris@1808 761 case digits of
Chris@1808 762 [] => token_error pos
Chris@1808 763 | _ => lex newpos (T.NUMBER digits :: acc) rest
Chris@1808 764 end
Chris@1808 765
Chris@1808 766 and lex pos acc [] = OK (rev acc)
Chris@1808 767 | lex pos acc (x::xs) =
Chris@1808 768 (case x of
Chris@1808 769 #" " => lex
Chris@1808 770 | #"\t" => lex
Chris@1808 771 | #"\n" => lex
Chris@1808 772 | #"\r" => lex
Chris@1808 773 | #"{" => lexChar T.CURLY_L
Chris@1808 774 | #"}" => lexChar T.CURLY_R
Chris@1808 775 | #"[" => lexChar T.SQUARE_L
Chris@1808 776 | #"]" => lexChar T.SQUARE_R
Chris@1808 777 | #":" => lexChar T.COLON
Chris@1808 778 | #"," => lexChar T.COMMA
Chris@1808 779 | #"\"" => lexString
Chris@1808 780 | #"t" => lexTrue
Chris@1808 781 | #"f" => lexFalse
Chris@1808 782 | #"n" => lexNull
Chris@1808 783 | x => lexNumber x) (pos + 1) acc xs
Chris@1808 784
Chris@1808 785 fun show [] = "end of input"
Chris@1808 786 | show (tok :: _) = T.toString tok
Chris@1808 787
Chris@1808 788 fun parseNumber digits =
Chris@1808 789 (* Note lexNumber already case-insensitised the E for us *)
Chris@1808 790 let open Char
Chris@1808 791
Chris@1808 792 fun okExpDigits [] = false
Chris@1808 793 | okExpDigits (c :: []) = isDigit c
Chris@1808 794 | okExpDigits (c :: cs) = isDigit c andalso okExpDigits cs
Chris@1808 795
Chris@1808 796 fun okExponent [] = false
Chris@1808 797 | okExponent (#"+" :: cs) = okExpDigits cs
Chris@1808 798 | okExponent (#"-" :: cs) = okExpDigits cs
Chris@1808 799 | okExponent cc = okExpDigits cc
Chris@1808 800
Chris@1808 801 fun okFracTrailing [] = true
Chris@1808 802 | okFracTrailing (c :: cs) =
Chris@1808 803 (isDigit c andalso okFracTrailing cs) orelse
Chris@1808 804 (c = #"e" andalso okExponent cs)
Chris@1808 805
Chris@1808 806 fun okFraction [] = false
Chris@1808 807 | okFraction (c :: cs) =
Chris@1808 808 isDigit c andalso okFracTrailing cs
Chris@1808 809
Chris@1808 810 fun okPosTrailing [] = true
Chris@1808 811 | okPosTrailing (#"." :: cs) = okFraction cs
Chris@1808 812 | okPosTrailing (#"e" :: cs) = okExponent cs
Chris@1808 813 | okPosTrailing (c :: cs) =
Chris@1808 814 isDigit c andalso okPosTrailing cs
Chris@1808 815
Chris@1808 816 fun okPositive [] = false
Chris@1808 817 | okPositive (#"0" :: []) = true
Chris@1808 818 | okPositive (#"0" :: #"." :: cs) = okFraction cs
Chris@1808 819 | okPositive (#"0" :: #"e" :: cs) = okExponent cs
Chris@1808 820 | okPositive (#"0" :: cs) = false
Chris@1808 821 | okPositive (c :: cs) = isDigit c andalso okPosTrailing cs
Chris@1808 822
Chris@1808 823 fun okNumber (#"-" :: cs) = okPositive cs
Chris@1808 824 | okNumber cc = okPositive cc
Chris@1808 825 in
Chris@1808 826 if okNumber digits
Chris@1808 827 then case Real.fromString (implode digits) of
Chris@1808 828 NONE => ERROR "Number out of range"
Chris@1808 829 | SOME r => OK r
Chris@1808 830 else ERROR ("Invalid number \"" ^ (implode digits) ^ "\"")
Chris@1808 831 end
Chris@1808 832
Chris@1808 833 fun parseObject (T.CURLY_R :: xs) = OK (OBJECT [], xs)
Chris@1808 834 | parseObject tokens =
Chris@1808 835 let fun parsePair (T.STRING key :: T.COLON :: xs) =
Chris@1808 836 (case parseTokens xs of
Chris@1808 837 ERROR e => ERROR e
Chris@1808 838 | OK (j, xs) => OK ((key, j), xs))
Chris@1808 839 | parsePair other =
Chris@1808 840 ERROR ("Object key/value pair expected around \"" ^
Chris@1808 841 show other ^ "\"")
Chris@1808 842 fun parseObject' acc [] = ERROR "End of input during object"
Chris@1808 843 | parseObject' acc tokens =
Chris@1808 844 case parsePair tokens of
Chris@1808 845 ERROR e => ERROR e
Chris@1808 846 | OK (pair, T.COMMA :: xs) =>
Chris@1808 847 parseObject' (pair :: acc) xs
Chris@1808 848 | OK (pair, T.CURLY_R :: xs) =>
Chris@1808 849 OK (OBJECT (rev (pair :: acc)), xs)
Chris@1808 850 | OK (_, _) => ERROR "Expected , or } after object element"
Chris@1808 851 in
Chris@1808 852 parseObject' [] tokens
Chris@1808 853 end
Chris@1808 854
Chris@1808 855 and parseArray (T.SQUARE_R :: xs) = OK (ARRAY [], xs)
Chris@1808 856 | parseArray tokens =
Chris@1808 857 let fun parseArray' acc [] = ERROR "End of input during array"
Chris@1808 858 | parseArray' acc tokens =
Chris@1808 859 case parseTokens tokens of
Chris@1808 860 ERROR e => ERROR e
Chris@1808 861 | OK (j, T.COMMA :: xs) => parseArray' (j :: acc) xs
Chris@1808 862 | OK (j, T.SQUARE_R :: xs) => OK (ARRAY (rev (j :: acc)), xs)
Chris@1808 863 | OK (_, _) => ERROR "Expected , or ] after array element"
Chris@1808 864 in
Chris@1808 865 parseArray' [] tokens
Chris@1808 866 end
Chris@1808 867
Chris@1808 868 and parseTokens [] = ERROR "Value expected"
Chris@1808 869 | parseTokens (tok :: xs) =
Chris@1808 870 (case tok of
Chris@1808 871 T.NUMBER d => (case parseNumber d of
Chris@1808 872 OK r => OK (NUMBER r, xs)
Chris@1808 873 | ERROR e => ERROR e)
Chris@1808 874 | T.STRING s => OK (STRING s, xs)
Chris@1808 875 | T.BOOL b => OK (BOOL b, xs)
Chris@1808 876 | T.NULL => OK (NULL, xs)
Chris@1808 877 | T.CURLY_L => parseObject xs
Chris@1808 878 | T.SQUARE_L => parseArray xs
Chris@1808 879 | _ => ERROR ("Unexpected token " ^ T.toString tok ^
Chris@1808 880 " before " ^ show xs))
Chris@1808 881
Chris@1808 882 fun parse str =
Chris@1808 883 case lex 1 [] (explode str) of
Chris@1808 884 ERROR e => ERROR e
Chris@1808 885 | OK tokens => case parseTokens tokens of
Chris@1808 886 OK (value, []) => OK value
Chris@1808 887 | OK (_, _) => ERROR "Extra data after input"
Chris@1808 888 | ERROR e => ERROR e
Chris@1808 889
Chris@1808 890 fun stringEscape s =
Chris@1808 891 let fun esc x = [x, #"\\"]
Chris@1808 892 fun escape' acc [] = rev acc
Chris@1808 893 | escape' acc (x :: xs) =
Chris@1808 894 escape' (case x of
Chris@1808 895 #"\"" => esc x @ acc
Chris@1808 896 | #"\\" => esc x @ acc
Chris@1808 897 | #"\b" => esc #"b" @ acc
Chris@1808 898 | #"\f" => esc #"f" @ acc
Chris@1808 899 | #"\n" => esc #"n" @ acc
Chris@1808 900 | #"\r" => esc #"r" @ acc
Chris@1808 901 | #"\t" => esc #"t" @ acc
Chris@1808 902 | _ =>
Chris@1808 903 let val c = Char.ord x
Chris@1808 904 in
Chris@1808 905 if c < 0x20
Chris@1808 906 then let val hex = Word.toString (Word.fromInt c)
Chris@1808 907 in (rev o explode) (if c < 0x10
Chris@1808 908 then ("\\u000" ^ hex)
Chris@1808 909 else ("\\u00" ^ hex))
Chris@1808 910 end @ acc
Chris@1808 911 else
Chris@1808 912 x :: acc
Chris@1808 913 end)
Chris@1808 914 xs
Chris@1808 915 in
Chris@1808 916 implode (escape' [] (explode s))
Chris@1808 917 end
Chris@1808 918
Chris@1808 919 fun serialise json =
Chris@1808 920 case json of
Chris@1808 921 OBJECT pp => "{" ^ String.concatWith
Chris@1808 922 "," (map (fn (key, value) =>
Chris@1808 923 serialise (STRING key) ^ ":" ^
Chris@1808 924 serialise value) pp) ^
Chris@1808 925 "}"
Chris@1808 926 | ARRAY arr => "[" ^ String.concatWith "," (map serialise arr) ^ "]"
Chris@1808 927 | NUMBER n => implode (map (fn #"~" => #"-" | c => c)
Chris@1808 928 (explode (Real.toString n)))
Chris@1808 929 | STRING s => "\"" ^ stringEscape s ^ "\""
Chris@1808 930 | BOOL b => Bool.toString b
Chris@1808 931 | NULL => "null"
Chris@1808 932
Chris@1808 933 fun serialiseIndented json =
Chris@1808 934 let fun indent 0 = ""
Chris@1808 935 | indent i = " " ^ indent (i - 1)
Chris@1808 936 fun serialiseIndented' i json =
Chris@1808 937 let val ser = serialiseIndented' (i + 1)
Chris@1808 938 in
Chris@1808 939 case json of
Chris@1808 940 OBJECT [] => "{}"
Chris@1808 941 | ARRAY [] => "[]"
Chris@1808 942 | OBJECT pp => "{\n" ^ indent (i + 1) ^
Chris@1808 943 String.concatWith
Chris@1808 944 (",\n" ^ indent (i + 1))
Chris@1808 945 (map (fn (key, value) =>
Chris@1808 946 ser (STRING key) ^ ": " ^
Chris@1808 947 ser value) pp) ^
Chris@1808 948 "\n" ^ indent i ^ "}"
Chris@1808 949 | ARRAY arr => "[\n" ^ indent (i + 1) ^
Chris@1808 950 String.concatWith
Chris@1808 951 (",\n" ^ indent (i + 1))
Chris@1808 952 (map ser arr) ^
Chris@1808 953 "\n" ^ indent i ^ "]"
Chris@1808 954 | other => serialise other
Chris@1808 955 end
Chris@1808 956 in
Chris@1808 957 serialiseIndented' 0 json ^ "\n"
Chris@1808 958 end
Chris@1808 959
Chris@1808 960 end
Chris@1808 961
Chris@1808 962
Chris@1808 963 structure JsonBits :> sig
Chris@1808 964 exception Config of string
Chris@1808 965 val load_json_from : string -> Json.json (* filename -> json *)
Chris@1808 966 val save_json_to : string -> Json.json -> unit
Chris@1808 967 val lookup_optional : Json.json -> string list -> Json.json option
Chris@1808 968 val lookup_optional_string : Json.json -> string list -> string option
Chris@1808 969 val lookup_mandatory : Json.json -> string list -> Json.json
Chris@1808 970 val lookup_mandatory_string : Json.json -> string list -> string
Chris@1808 971 end = struct
Chris@1808 972
Chris@1808 973 exception Config of string
Chris@1808 974
Chris@1808 975 fun load_json_from filename =
Chris@1808 976 case Json.parse (FileBits.file_contents filename) of
Chris@1808 977 Json.OK json => json
Chris@1808 978 | Json.ERROR e => raise Config ("Failed to parse file: " ^ e)
Chris@1808 979
Chris@1808 980 fun save_json_to filename json =
Chris@1808 981 (* using binary I/O to avoid ever writing CR/LF line endings *)
Chris@1808 982 let val jstr = Json.serialiseIndented json
Chris@1808 983 val stream = BinIO.openOut filename
Chris@1808 984 in
Chris@1808 985 BinIO.output (stream, Byte.stringToBytes jstr);
Chris@1808 986 BinIO.closeOut stream
Chris@1808 987 end
Chris@1808 988
Chris@1808 989 fun lookup_optional json kk =
Chris@1808 990 let fun lookup key =
Chris@1808 991 case json of
Chris@1808 992 Json.OBJECT kvs =>
Chris@1808 993 (case List.filter (fn (k, v) => k = key) kvs of
Chris@1808 994 [] => NONE
Chris@1808 995 | [(_,v)] => SOME v
Chris@1808 996 | _ => raise Config ("Duplicate key: " ^
Chris@1808 997 (String.concatWith " -> " kk)))
Chris@1808 998 | _ => raise Config "Object expected"
Chris@1808 999 in
Chris@1808 1000 case kk of
Chris@1808 1001 [] => NONE
Chris@1808 1002 | key::[] => lookup key
Chris@1808 1003 | key::kk => case lookup key of
Chris@1808 1004 NONE => NONE
Chris@1808 1005 | SOME j => lookup_optional j kk
Chris@1808 1006 end
Chris@1808 1007
Chris@1808 1008 fun lookup_optional_string json kk =
Chris@1808 1009 case lookup_optional json kk of
Chris@1808 1010 SOME (Json.STRING s) => SOME s
Chris@1808 1011 | SOME _ => raise Config ("Value (if present) must be string: " ^
Chris@1808 1012 (String.concatWith " -> " kk))
Chris@1808 1013 | NONE => NONE
Chris@1808 1014
Chris@1808 1015 fun lookup_mandatory json kk =
Chris@1808 1016 case lookup_optional json kk of
Chris@1808 1017 SOME v => v
Chris@1808 1018 | NONE => raise Config ("Value is mandatory: " ^
Chris@1808 1019 (String.concatWith " -> " kk))
Chris@1808 1020
Chris@1808 1021 fun lookup_mandatory_string json kk =
Chris@1808 1022 case lookup_optional json kk of
Chris@1808 1023 SOME (Json.STRING s) => s
Chris@1808 1024 | _ => raise Config ("Value must be string: " ^
Chris@1808 1025 (String.concatWith " -> " kk))
Chris@1808 1026 end
Chris@1808 1027
Chris@1808 1028 structure Provider :> sig
Chris@1808 1029 val load_providers : Json.json -> provider list
Chris@1808 1030 val load_more_providers : provider list -> Json.json -> provider list
Chris@1808 1031 val remote_url : context -> vcs -> source -> libname -> string
Chris@1808 1032 end = struct
Chris@1808 1033
Chris@1808 1034 val known_providers : provider list =
Chris@1808 1035 [ {
Chris@1808 1036 service = "bitbucket",
Chris@1808 1037 supports = [HG, GIT],
Chris@1808 1038 remote_spec = {
Chris@1808 1039 anon = SOME "https://bitbucket.org/{owner}/{repository}",
Chris@1808 1040 auth = SOME "ssh://{vcs}@bitbucket.org/{owner}/{repository}"
Chris@1808 1041 }
Chris@1808 1042 },
Chris@1808 1043 {
Chris@1808 1044 service = "github",
Chris@1808 1045 supports = [GIT],
Chris@1808 1046 remote_spec = {
Chris@1808 1047 anon = SOME "https://github.com/{owner}/{repository}",
Chris@1808 1048 auth = SOME "ssh://{vcs}@github.com/{owner}/{repository}"
Chris@1808 1049 }
Chris@2311 1050 },
Chris@2311 1051 { service = "sourcehut",
Chris@2311 1052 supports = [HG, GIT],
Chris@2311 1053 remote_spec = {
Chris@2311 1054 anon = SOME "https://{vcs}.sr.ht/%7E{owner}/{repository}",
Chris@2311 1055 auth = SOME "ssh://{vcs}@{vcs}.sr.ht/%7E{owner}/{repository}"
Chris@2311 1056 }
Chris@1808 1057 }
Chris@1808 1058 ]
Chris@1808 1059
Chris@1808 1060 fun vcs_name vcs =
Chris@1808 1061 case vcs of HG => "hg"
Chris@1808 1062 | GIT => "git"
Chris@1808 1063 | SVN => "svn"
Chris@1808 1064
Chris@1808 1065 fun vcs_from_name name =
Chris@1808 1066 case name of "hg" => HG
Chris@1808 1067 | "git" => GIT
Chris@1808 1068 | "svn" => SVN
Chris@1808 1069 | other => raise Fail ("Unknown vcs name \"" ^ name ^ "\"")
Chris@1808 1070
Chris@1808 1071 fun load_more_providers previously_loaded json =
Chris@1808 1072 let open JsonBits
Chris@1808 1073 fun load pjson pname : provider =
Chris@1808 1074 {
Chris@1808 1075 service = pname,
Chris@1808 1076 supports =
Chris@1808 1077 case lookup_mandatory pjson ["vcs"] of
Chris@1808 1078 Json.ARRAY vv =>
Chris@1808 1079 map (fn (Json.STRING v) => vcs_from_name v
Chris@1808 1080 | _ => raise Fail "Strings expected in vcs array")
Chris@1808 1081 vv
Chris@1808 1082 | _ => raise Fail "Array expected for vcs",
Chris@1808 1083 remote_spec = {
Chris@1808 1084 anon = lookup_optional_string pjson ["anonymous"],
Chris@1808 1085 auth = lookup_optional_string pjson ["authenticated"]
Chris@1808 1086 }
Chris@1808 1087 }
Chris@1808 1088 val loaded =
Chris@1808 1089 case lookup_optional json ["services"] of
Chris@1808 1090 NONE => []
Chris@1808 1091 | SOME (Json.OBJECT pl) => map (fn (k, v) => load v k) pl
Chris@1808 1092 | _ => raise Fail "Object expected for services in config"
Chris@1808 1093 val newly_loaded =
Chris@1808 1094 List.filter (fn p => not (List.exists (fn pp => #service p =
Chris@1808 1095 #service pp)
Chris@1808 1096 previously_loaded))
Chris@1808 1097 loaded
Chris@1808 1098 in
Chris@1808 1099 previously_loaded @ newly_loaded
Chris@1808 1100 end
Chris@1808 1101
Chris@1808 1102 fun load_providers json =
Chris@1808 1103 load_more_providers known_providers json
Chris@1808 1104
Chris@1808 1105 fun expand_spec spec { vcs, service, owner, repo } login =
Chris@1808 1106 (* ugly *)
Chris@1808 1107 let fun replace str =
Chris@1808 1108 case str of
Chris@1808 1109 "vcs" => vcs_name vcs
Chris@1808 1110 | "service" => service
Chris@1808 1111 | "owner" =>
Chris@1808 1112 (case owner of
Chris@1808 1113 SOME ostr => ostr
Chris@1808 1114 | NONE => raise Fail ("Owner not specified for service " ^
Chris@1808 1115 service))
Chris@1808 1116 | "repository" => repo
Chris@1808 1117 | "account" =>
Chris@1808 1118 (case login of
Chris@1808 1119 SOME acc => acc
Chris@1808 1120 | NONE => raise Fail ("Account not given for service " ^
Chris@1808 1121 service))
Chris@1808 1122 | other => raise Fail ("Unknown variable \"" ^ other ^
Chris@1808 1123 "\" in spec for service " ^ service)
Chris@1808 1124 fun expand' acc sstr =
Chris@1808 1125 case Substring.splitl (fn c => c <> #"{") sstr of
Chris@1808 1126 (pfx, sfx) =>
Chris@1808 1127 if Substring.isEmpty sfx
Chris@1808 1128 then rev (pfx :: acc)
Chris@1808 1129 else
Chris@1808 1130 case Substring.splitl (fn c => c <> #"}") sfx of
Chris@1808 1131 (tok, remainder) =>
Chris@1808 1132 if Substring.isEmpty remainder
Chris@1808 1133 then rev (tok :: pfx :: acc)
Chris@1808 1134 else let val replacement =
Chris@1808 1135 replace
Chris@1808 1136 (* tok begins with "{": *)
Chris@1808 1137 (Substring.string
Chris@1808 1138 (Substring.triml 1 tok))
Chris@1808 1139 in
Chris@1808 1140 expand' (Substring.full replacement ::
Chris@1808 1141 pfx :: acc)
Chris@1808 1142 (* remainder begins with "}": *)
Chris@1808 1143 (Substring.triml 1 remainder)
Chris@1808 1144 end
Chris@1808 1145 in
Chris@1808 1146 Substring.concat (expand' [] (Substring.full spec))
Chris@1808 1147 end
Chris@1808 1148
Chris@1808 1149 fun provider_url req login providers =
Chris@1808 1150 case providers of
Chris@1808 1151 [] => raise Fail ("Unknown service \"" ^ (#service req) ^
Chris@1808 1152 "\" for vcs \"" ^ (vcs_name (#vcs req)) ^ "\"")
Chris@1808 1153 | ({ service, supports, remote_spec : remote_spec } :: rest) =>
Chris@1808 1154 if service <> (#service req) orelse
Chris@1808 1155 not (List.exists (fn v => v = (#vcs req)) supports)
Chris@1808 1156 then provider_url req login rest
Chris@1808 1157 else
Chris@1808 1158 case (login, #auth remote_spec, #anon remote_spec) of
Chris@1808 1159 (SOME _, SOME auth, _) => expand_spec auth req login
Chris@1808 1160 | (SOME _, _, SOME anon) => expand_spec anon req NONE
Chris@1808 1161 | (NONE, _, SOME anon) => expand_spec anon req NONE
Chris@1808 1162 | _ => raise Fail ("No suitable anonymous or authenticated " ^
Chris@1808 1163 "URL spec provided for service \"" ^
Chris@1808 1164 service ^ "\"")
Chris@1808 1165
Chris@1808 1166 fun login_for ({ accounts, ... } : context) service =
Chris@1808 1167 case List.find (fn a => service = #service a) accounts of
Chris@1808 1168 SOME { login, ... } => SOME login
Chris@1808 1169 | NONE => NONE
Chris@1808 1170
Chris@1808 1171 fun reponame_for path =
Chris@1808 1172 case String.tokens (fn c => c = #"/") path of
Chris@1808 1173 [] => raise Fail "Non-empty library path required"
Chris@1808 1174 | toks => hd (rev toks)
Chris@1808 1175
Chris@1808 1176 fun remote_url (context : context) vcs source libname =
Chris@1808 1177 case source of
Chris@1808 1178 URL_SOURCE u => u
Chris@1808 1179 | SERVICE_SOURCE { service, owner, repo } =>
Chris@1808 1180 provider_url { vcs = vcs,
Chris@1808 1181 service = service,
Chris@1808 1182 owner = owner,
Chris@1808 1183 repo = case repo of
Chris@1808 1184 SOME r => r
Chris@1808 1185 | NONE => reponame_for libname }
Chris@1808 1186 (login_for context service)
Chris@1808 1187 (#providers context)
Chris@1808 1188 end
Chris@1808 1189
Chris@1808 1190 structure HgControl :> VCS_CONTROL = struct
Chris@1808 1191
Chris@1808 1192 (* Pulls always use an explicit URL, never just the default
Chris@1808 1193 remote, in order to ensure we update properly if the location
Chris@1808 1194 given in the project file changes. *)
Chris@1808 1195
Chris@1808 1196 type vcsstate = { id: string, modified: bool,
Chris@1808 1197 branch: string, tags: string list }
Chris@1808 1198
Chris@1808 1199 val hg_program = "hg"
Chris@1808 1200
Chris@1808 1201 val hg_args = [ "--config", "ui.interactive=true",
Chris@1808 1202 "--config", "ui.merge=:merge" ]
Chris@1808 1203
Chris@1808 1204 fun hg_command context libname args =
Chris@1808 1205 FileBits.command context libname (hg_program :: hg_args @ args)
Chris@1808 1206
Chris@1808 1207 fun hg_command_output context libname args =
Chris@1808 1208 FileBits.command_output context libname (hg_program :: hg_args @ args)
Chris@1808 1209
Chris@1808 1210 fun is_working context =
Chris@1808 1211 case hg_command_output context "" ["--version"] of
Chris@1808 1212 OK "" => OK false
Chris@1808 1213 | OK _ => OK true
Chris@1808 1214 | ERROR e => ERROR e
Chris@1808 1215
Chris@1808 1216 fun exists context libname =
Chris@1808 1217 OK (OS.FileSys.isDir (FileBits.subpath context libname ".hg"))
Chris@1808 1218 handle _ => OK false
Chris@1808 1219
Chris@1808 1220 fun remote_for context (libname, source) =
Chris@1808 1221 Provider.remote_url context HG source libname
Chris@1808 1222
Chris@1808 1223 fun current_state context libname : vcsstate result =
Chris@1808 1224 let fun is_branch text = text <> "" andalso #"(" = hd (explode text)
Chris@1808 1225 and extract_branch b =
Chris@1808 1226 if is_branch b (* need to remove enclosing parens *)
Chris@1808 1227 then (implode o rev o tl o rev o tl o explode) b
Chris@1808 1228 else "default"
Chris@1808 1229 and is_modified id = id <> "" andalso #"+" = hd (rev (explode id))
Chris@1808 1230 and extract_id id =
Chris@1808 1231 if is_modified id (* need to remove trailing "+" *)
Chris@1808 1232 then (implode o rev o tl o rev o explode) id
Chris@1808 1233 else id
Chris@1808 1234 and split_tags tags = String.tokens (fn c => c = #"/") tags
Chris@1808 1235 and state_for (id, branch, tags) =
Chris@1808 1236 OK { id = extract_id id,
Chris@1808 1237 modified = is_modified id,
Chris@1808 1238 branch = extract_branch branch,
Chris@1808 1239 tags = split_tags tags }
Chris@1808 1240 in
Chris@1808 1241 case hg_command_output context libname ["id"] of
Chris@1808 1242 ERROR e => ERROR e
Chris@1808 1243 | OK out =>
Chris@1808 1244 case String.tokens (fn x => x = #" ") out of
Chris@1808 1245 [id, branch, tags] => state_for (id, branch, tags)
Chris@1808 1246 | [id, other] => if is_branch other
Chris@1808 1247 then state_for (id, other, "")
Chris@1808 1248 else state_for (id, "", other)
Chris@1808 1249 | [id] => state_for (id, "", "")
Chris@1808 1250 | _ => ERROR ("Unexpected output from hg id: " ^ out)
Chris@1808 1251 end
Chris@1808 1252
Chris@1808 1253 fun branch_name branch = case branch of
Chris@1808 1254 DEFAULT_BRANCH => "default"
Chris@1808 1255 | BRANCH "" => "default"
Chris@1808 1256 | BRANCH b => b
Chris@1808 1257
Chris@1808 1258 fun id_of context libname =
Chris@1808 1259 case current_state context libname of
Chris@1808 1260 ERROR e => ERROR e
Chris@1808 1261 | OK { id, ... } => OK id
Chris@1808 1262
Chris@1808 1263 fun is_at context (libname, id_or_tag) =
Chris@1808 1264 case current_state context libname of
Chris@1808 1265 ERROR e => ERROR e
Chris@1808 1266 | OK { id, tags, ... } =>
Chris@1808 1267 OK (String.isPrefix id_or_tag id orelse
Chris@1808 1268 String.isPrefix id id_or_tag orelse
Chris@1808 1269 List.exists (fn t => t = id_or_tag) tags)
Chris@1808 1270
Chris@1808 1271 fun is_on_branch context (libname, b) =
Chris@1808 1272 case current_state context libname of
Chris@1808 1273 ERROR e => ERROR e
Chris@1808 1274 | OK { branch, ... } => OK (branch = branch_name b)
Chris@1808 1275
Chris@1808 1276 fun is_newest_locally context (libname, branch) =
Chris@1808 1277 case hg_command_output context libname
Chris@1808 1278 ["log", "-l1",
Chris@1808 1279 "-b", branch_name branch,
Chris@1808 1280 "--template", "{node}"] of
Chris@1808 1281 ERROR e => OK false (* desired branch does not exist *)
Chris@1808 1282 | OK newest_in_repo => is_at context (libname, newest_in_repo)
Chris@1808 1283
Chris@1808 1284 fun pull context (libname, source) =
Chris@1808 1285 let val url = remote_for context (libname, source)
Chris@1808 1286 in
Chris@1808 1287 hg_command context libname
Chris@1808 1288 (if FileBits.verbose ()
Chris@1808 1289 then ["pull", url]
Chris@1808 1290 else ["pull", "-q", url])
Chris@1808 1291 end
Chris@1808 1292
Chris@1808 1293 fun is_newest context (libname, source, branch) =
Chris@1808 1294 case is_newest_locally context (libname, branch) of
Chris@1808 1295 ERROR e => ERROR e
Chris@1808 1296 | OK false => OK false
Chris@1808 1297 | OK true =>
Chris@1808 1298 case pull context (libname, source) of
Chris@1808 1299 ERROR e => ERROR e
Chris@1808 1300 | _ => is_newest_locally context (libname, branch)
Chris@1808 1301
Chris@1808 1302 fun is_modified_locally context libname =
Chris@1808 1303 case current_state context libname of
Chris@1808 1304 ERROR e => ERROR e
Chris@1808 1305 | OK { modified, ... } => OK modified
Chris@1808 1306
Chris@1808 1307 fun checkout context (libname, source, branch) =
Chris@1808 1308 let val url = remote_for context (libname, source)
Chris@1808 1309 in
Chris@1808 1310 (* make the lib dir rather than just the ext dir, since
Chris@1808 1311 the lib dir might be nested and hg will happily check
Chris@1808 1312 out into an existing empty dir anyway *)
Chris@1808 1313 case FileBits.mkpath (FileBits.libpath context libname) of
Chris@1808 1314 ERROR e => ERROR e
Chris@1808 1315 | _ => hg_command context ""
Chris@1808 1316 ["clone", "-u", branch_name branch,
Chris@1808 1317 url, libname]
Chris@1808 1318 end
Chris@1808 1319
Chris@1808 1320 fun update context (libname, source, branch) =
Chris@1808 1321 let val pull_result = pull context (libname, source)
Chris@1808 1322 in
Chris@1808 1323 case hg_command context libname ["update", branch_name branch] of
Chris@1808 1324 ERROR e => ERROR e
Chris@1808 1325 | _ =>
Chris@1808 1326 case pull_result of
Chris@1808 1327 ERROR e => ERROR e
Chris@1808 1328 | _ => OK ()
Chris@1808 1329 end
Chris@1808 1330
Chris@1808 1331 fun update_to context (libname, _, "") =
Chris@1808 1332 ERROR "Non-empty id (tag or revision id) required for update_to"
Chris@1808 1333 | update_to context (libname, source, id) =
Chris@1808 1334 let val pull_result = pull context (libname, source)
Chris@1808 1335 in
Chris@1808 1336 case hg_command context libname ["update", "-r", id] of
Chris@1808 1337 OK _ => OK ()
Chris@1808 1338 | ERROR e =>
Chris@1808 1339 case pull_result of
Chris@1808 1340 ERROR e' => ERROR e' (* this was the ur-error *)
Chris@1808 1341 | _ => ERROR e
Chris@1808 1342 end
Chris@1808 1343
Chris@1808 1344 fun copy_url_for context libname =
Chris@1808 1345 OK (FileBits.file_url (FileBits.libpath context libname))
Chris@1808 1346
Chris@1808 1347 end
Chris@1808 1348
Chris@1808 1349 structure GitControl :> VCS_CONTROL = struct
Chris@1808 1350
Chris@1808 1351 (* With Git repos we always operate in detached HEAD state. Even
Chris@1808 1352 the master branch is checked out using a remote reference
Chris@1808 1353 (repoint/master). The remote we use is always named repoint, and we
Chris@1808 1354 update it to the expected URL each time we fetch, in order to
Chris@1808 1355 ensure we update properly if the location given in the project
Chris@1808 1356 file changes. The origin remote is unused. *)
Chris@1808 1357
Chris@1808 1358 val git_program = "git"
Chris@1808 1359
Chris@1808 1360 fun git_command context libname args =
Chris@1808 1361 FileBits.command context libname (git_program :: args)
Chris@1808 1362
Chris@1808 1363 fun git_command_output context libname args =
Chris@1808 1364 FileBits.command_output context libname (git_program :: args)
Chris@1808 1365
Chris@1808 1366 fun is_working context =
Chris@1808 1367 case git_command_output context "" ["--version"] of
Chris@1808 1368 OK "" => OK false
Chris@1808 1369 | OK _ => OK true
Chris@1808 1370 | ERROR e => ERROR e
Chris@1808 1371
Chris@1808 1372 fun exists context libname =
Chris@1808 1373 OK (OS.FileSys.isDir (FileBits.subpath context libname ".git"))
Chris@1808 1374 handle _ => OK false
Chris@1808 1375
Chris@1808 1376 fun remote_for context (libname, source) =
Chris@1808 1377 Provider.remote_url context GIT source libname
Chris@1808 1378
Chris@1808 1379 fun branch_name branch = case branch of
Chris@1808 1380 DEFAULT_BRANCH => "master"
Chris@1808 1381 | BRANCH "" => "master"
Chris@1808 1382 | BRANCH b => b
Chris@1808 1383
Chris@1808 1384 val our_remote = "repoint"
Chris@1808 1385
Chris@1808 1386 fun remote_branch_name branch = our_remote ^ "/" ^ branch_name branch
Chris@1808 1387
Chris@1808 1388 fun checkout context (libname, source, branch) =
Chris@1808 1389 let val url = remote_for context (libname, source)
Chris@1808 1390 in
Chris@1808 1391 (* make the lib dir rather than just the ext dir, since
Chris@1808 1392 the lib dir might be nested and git will happily check
Chris@1808 1393 out into an existing empty dir anyway *)
Chris@1808 1394 case FileBits.mkpath (FileBits.libpath context libname) of
Chris@1808 1395 OK () => git_command context ""
Chris@1808 1396 ["clone", "--origin", our_remote,
Chris@1808 1397 "--branch", branch_name branch,
Chris@1808 1398 url, libname]
Chris@1808 1399 | ERROR e => ERROR e
Chris@1808 1400 end
Chris@1808 1401
Chris@1808 1402 fun add_our_remote context (libname, source) =
Chris@1808 1403 (* When we do the checkout ourselves (above), we add the
Chris@1808 1404 remote at the same time. But if the repo was cloned by
Chris@1808 1405 someone else, we'll need to do it after the fact. Git
Chris@1808 1406 doesn't seem to have a means to add a remote or change its
Chris@1808 1407 url if it already exists; seems we have to do this: *)
Chris@1808 1408 let val url = remote_for context (libname, source)
Chris@1808 1409 in
Chris@1808 1410 case git_command context libname
Chris@1808 1411 ["remote", "set-url", our_remote, url] of
Chris@1808 1412 OK () => OK ()
Chris@1808 1413 | ERROR e => git_command context libname
Chris@1808 1414 ["remote", "add", "-f", our_remote, url]
Chris@1808 1415 end
Chris@1808 1416
Chris@1808 1417 (* NB git rev-parse HEAD shows revision id of current checkout;
Chris@1808 1418 git rev-list -1 <tag> shows revision id of revision with that tag *)
Chris@1808 1419
Chris@1808 1420 fun id_of context libname =
Chris@1808 1421 git_command_output context libname ["rev-parse", "HEAD"]
Chris@1808 1422
Chris@1808 1423 fun is_at context (libname, id_or_tag) =
Chris@1808 1424 case id_of context libname of
Chris@1808 1425 ERROR e => OK false (* HEAD nonexistent, expected in empty repo *)
Chris@1808 1426 | OK id =>
Chris@1808 1427 if String.isPrefix id_or_tag id orelse
Chris@1808 1428 String.isPrefix id id_or_tag
Chris@1808 1429 then OK true
Chris@1808 1430 else is_at_tag context (libname, id, id_or_tag)
Chris@1808 1431
Chris@1808 1432 and is_at_tag context (libname, id, tag) =
Chris@1808 1433 (* For annotated tags (with message) show-ref returns the tag
Chris@1808 1434 object ref rather than that of the revision being tagged;
Chris@1808 1435 we need the subsequent rev-list to chase that up. In fact
Chris@1808 1436 the rev-list on its own is enough to get us the id direct
Chris@1808 1437 from the tag name, but it fails with an error if the tag
Chris@1808 1438 doesn't exist, whereas we want to handle that quietly in
Chris@1808 1439 case the tag simply hasn't been pulled yet *)
Chris@1808 1440 case git_command_output context libname
Chris@1808 1441 ["show-ref", "refs/tags/" ^ tag, "--"] of
Chris@1808 1442 OK "" => OK false (* Not a tag *)
Chris@1808 1443 | ERROR _ => OK false
Chris@1808 1444 | OK s =>
Chris@1808 1445 let val tag_ref = hd (String.tokens (fn c => c = #" ") s)
Chris@1808 1446 in
Chris@1808 1447 case git_command_output context libname
Chris@1808 1448 ["rev-list", "-1", tag_ref] of
Chris@1808 1449 OK tagged => OK (id = tagged)
Chris@1808 1450 | ERROR _ => OK false
Chris@1808 1451 end
Chris@1808 1452
Chris@1808 1453 fun branch_tip context (libname, branch) =
Chris@1808 1454 (* We don't have access to the source info or the network
Chris@1808 1455 here, as this is used by status (e.g. via is_on_branch) as
Chris@1808 1456 well as review. It's possible the remote branch won't exist,
Chris@1808 1457 e.g. if the repo was checked out by something other than
Chris@1808 1458 Repoint, and if that's the case, we can't add it here; we'll
Chris@1808 1459 just have to fail, since checking against local branches
Chris@1808 1460 instead could produce the wrong result. *)
Chris@1808 1461 git_command_output context libname
Chris@1808 1462 ["rev-list", "-1",
Chris@1808 1463 remote_branch_name branch, "--"]
Chris@1808 1464
Chris@1808 1465 fun is_newest_locally context (libname, branch) =
Chris@1808 1466 case branch_tip context (libname, branch) of
Chris@1808 1467 ERROR e => OK false
Chris@1808 1468 | OK rev => is_at context (libname, rev)
Chris@1808 1469
Chris@1808 1470 fun is_on_branch context (libname, branch) =
Chris@1808 1471 case branch_tip context (libname, branch) of
Chris@1808 1472 ERROR e => OK false
Chris@1808 1473 | OK rev =>
Chris@1808 1474 case is_at context (libname, rev) of
Chris@1808 1475 ERROR e => ERROR e
Chris@1808 1476 | OK true => OK true
Chris@1808 1477 | OK false =>
Chris@1808 1478 case git_command context libname
Chris@1808 1479 ["merge-base", "--is-ancestor",
Chris@1808 1480 "HEAD", remote_branch_name branch] of
Chris@1808 1481 ERROR e => OK false (* cmd returns non-zero for no *)
Chris@1808 1482 | _ => OK true
Chris@1808 1483
Chris@1808 1484 fun fetch context (libname, source) =
Chris@1808 1485 case add_our_remote context (libname, source) of
Chris@1808 1486 ERROR e => ERROR e
Chris@1808 1487 | _ => git_command context libname ["fetch", our_remote]
Chris@1808 1488
Chris@1808 1489 fun is_newest context (libname, source, branch) =
Chris@1808 1490 case add_our_remote context (libname, source) of
Chris@1808 1491 ERROR e => ERROR e
Chris@1808 1492 | OK () =>
Chris@1808 1493 case is_newest_locally context (libname, branch) of
Chris@1808 1494 ERROR e => ERROR e
Chris@1808 1495 | OK false => OK false
Chris@1808 1496 | OK true =>
Chris@1808 1497 case fetch context (libname, source) of
Chris@1808 1498 ERROR e => ERROR e
Chris@1808 1499 | _ => is_newest_locally context (libname, branch)
Chris@1808 1500
Chris@1808 1501 fun is_modified_locally context libname =
Chris@1808 1502 case git_command_output context libname ["status", "--porcelain"] of
Chris@1808 1503 ERROR e => ERROR e
Chris@1808 1504 | OK "" => OK false
Chris@1808 1505 | OK _ => OK true
Chris@1808 1506
Chris@1808 1507 (* This function updates to the latest revision on a branch rather
Chris@1808 1508 than to a specific id or tag. We can't just checkout the given
Chris@1808 1509 branch, as that will succeed even if the branch isn't up to
Chris@1808 1510 date. We could checkout the branch and then fetch and merge,
Chris@1808 1511 but it's perhaps cleaner not to maintain a local branch at all,
Chris@1808 1512 but instead checkout the remote branch as a detached head. *)
Chris@1808 1513
Chris@1808 1514 fun update context (libname, source, branch) =
Chris@1808 1515 case fetch context (libname, source) of
Chris@1808 1516 ERROR e => ERROR e
Chris@1808 1517 | _ =>
Chris@1808 1518 case git_command context libname ["checkout", "--detach",
Chris@1808 1519 remote_branch_name branch] of
Chris@1808 1520 ERROR e => ERROR e
Chris@1808 1521 | _ => OK ()
Chris@1808 1522
Chris@1808 1523 (* This function is dealing with a specific id or tag, so if we
Chris@1808 1524 can successfully check it out (detached) then that's all we
Chris@1808 1525 need to do, regardless of whether fetch succeeded or not. We do
Chris@1808 1526 attempt the fetch first, though, purely in order to avoid ugly
Chris@1808 1527 error messages in the common case where we're being asked to
Chris@1808 1528 update to a new pin (from the lock file) that hasn't been
Chris@1808 1529 fetched yet. *)
Chris@1808 1530
Chris@1808 1531 fun update_to context (libname, _, "") =
Chris@1808 1532 ERROR "Non-empty id (tag or revision id) required for update_to"
Chris@1808 1533 | update_to context (libname, source, id) =
Chris@1808 1534 let val fetch_result = fetch context (libname, source)
Chris@1808 1535 in
Chris@1808 1536 case git_command context libname ["checkout", "--detach", id] of
Chris@1808 1537 OK _ => OK ()
Chris@1808 1538 | ERROR e =>
Chris@1808 1539 case fetch_result of
Chris@1808 1540 ERROR e' => ERROR e' (* this was the ur-error *)
Chris@1808 1541 | _ => ERROR e
Chris@1808 1542 end
Chris@1808 1543
Chris@1808 1544 fun copy_url_for context libname =
Chris@1808 1545 OK (FileBits.file_url (FileBits.libpath context libname))
Chris@1808 1546
Chris@1808 1547 end
Chris@1808 1548
Chris@1808 1549 (* SubXml - A parser for a subset of XML
Chris@1808 1550 https://bitbucket.org/cannam/sml-subxml
Chris@1808 1551 Copyright 2018 Chris Cannam. BSD licence.
Chris@1808 1552 *)
Chris@1808 1553
Chris@1808 1554 signature SUBXML = sig
Chris@1808 1555
Chris@1808 1556 datatype node = ELEMENT of { name : string, children : node list }
Chris@1808 1557 | ATTRIBUTE of { name : string, value : string }
Chris@1808 1558 | TEXT of string
Chris@1808 1559 | CDATA of string
Chris@1808 1560 | COMMENT of string
Chris@1808 1561
Chris@1808 1562 datatype document = DOCUMENT of { name : string, children : node list }
Chris@1808 1563
Chris@1808 1564 datatype 'a result = OK of 'a
Chris@1808 1565 | ERROR of string
Chris@1808 1566
Chris@1808 1567 val parse : string -> document result
Chris@1808 1568 val serialise : document -> string
Chris@1808 1569
Chris@1808 1570 end
Chris@1808 1571
Chris@1808 1572 structure SubXml :> SUBXML = struct
Chris@1808 1573
Chris@1808 1574 datatype node = ELEMENT of { name : string, children : node list }
Chris@1808 1575 | ATTRIBUTE of { name : string, value : string }
Chris@1808 1576 | TEXT of string
Chris@1808 1577 | CDATA of string
Chris@1808 1578 | COMMENT of string
Chris@1808 1579
Chris@1808 1580 datatype document = DOCUMENT of { name : string, children : node list }
Chris@1808 1581
Chris@1808 1582 datatype 'a result = OK of 'a
Chris@1808 1583 | ERROR of string
Chris@1808 1584
Chris@1808 1585 structure T = struct
Chris@1808 1586 datatype token = ANGLE_L
Chris@1808 1587 | ANGLE_R
Chris@1808 1588 | ANGLE_SLASH_L
Chris@1808 1589 | SLASH_ANGLE_R
Chris@1808 1590 | EQUAL
Chris@1808 1591 | NAME of string
Chris@1808 1592 | TEXT of string
Chris@1808 1593 | CDATA of string
Chris@1808 1594 | COMMENT of string
Chris@1808 1595
Chris@1808 1596 fun name t =
Chris@1808 1597 case t of ANGLE_L => "<"
Chris@1808 1598 | ANGLE_R => ">"
Chris@1808 1599 | ANGLE_SLASH_L => "</"
Chris@1808 1600 | SLASH_ANGLE_R => "/>"
Chris@1808 1601 | EQUAL => "="
Chris@1808 1602 | NAME s => "name \"" ^ s ^ "\""
Chris@1808 1603 | TEXT s => "text"
Chris@1808 1604 | CDATA _ => "CDATA section"
Chris@1808 1605 | COMMENT _ => "comment"
Chris@1808 1606 end
Chris@1808 1607
Chris@1808 1608 structure Lex :> sig
Chris@1808 1609 val lex : string -> T.token list result
Chris@1808 1610 end = struct
Chris@1808 1611
Chris@1808 1612 fun error pos text =
Chris@1808 1613 ERROR (text ^ " at character position " ^ Int.toString (pos-1))
Chris@1808 1614 fun tokenError pos token =
Chris@1808 1615 error pos ("Unexpected token '" ^ Char.toString token ^ "'")
Chris@1808 1616
Chris@1808 1617 val nameEnd = explode " \t\n\r\"'</>!=?"
Chris@1808 1618
Chris@1808 1619 fun quoted quote pos acc cc =
Chris@1808 1620 let fun quoted' pos text [] =
Chris@1808 1621 error pos "Document ends during quoted string"
Chris@1808 1622 | quoted' pos text (x::xs) =
Chris@1808 1623 if x = quote
Chris@1808 1624 then OK (rev text, xs, pos+1)
Chris@1808 1625 else quoted' (pos+1) (x::text) xs
Chris@1808 1626 in
Chris@1808 1627 case quoted' pos [] cc of
Chris@1808 1628 ERROR e => ERROR e
Chris@1808 1629 | OK (text, rest, newpos) =>
Chris@1808 1630 inside newpos (T.TEXT (implode text) :: acc) rest
Chris@1808 1631 end
Chris@1808 1632
Chris@1808 1633 and name first pos acc cc =
Chris@1808 1634 let fun name' pos text [] =
Chris@1808 1635 error pos "Document ends during name"
Chris@1808 1636 | name' pos text (x::xs) =
Chris@1808 1637 if List.find (fn c => c = x) nameEnd <> NONE
Chris@1808 1638 then OK (rev text, (x::xs), pos)
Chris@1808 1639 else name' (pos+1) (x::text) xs
Chris@1808 1640 in
Chris@1808 1641 case name' (pos-1) [] (first::cc) of
Chris@1808 1642 ERROR e => ERROR e
Chris@1808 1643 | OK ([], [], pos) => error pos "Document ends before name"
Chris@1808 1644 | OK ([], (x::xs), pos) => tokenError pos x
Chris@1808 1645 | OK (text, rest, pos) =>
Chris@1808 1646 inside pos (T.NAME (implode text) :: acc) rest
Chris@1808 1647 end
Chris@1808 1648
Chris@1808 1649 and comment pos acc cc =
Chris@1808 1650 let fun comment' pos text cc =
Chris@1808 1651 case cc of
Chris@1808 1652 #"-" :: #"-" :: #">" :: xs => OK (rev text, xs, pos+3)
Chris@1808 1653 | x :: xs => comment' (pos+1) (x::text) xs
Chris@1808 1654 | [] => error pos "Document ends during comment"
Chris@1808 1655 in
Chris@1808 1656 case comment' pos [] cc of
Chris@1808 1657 ERROR e => ERROR e
Chris@1808 1658 | OK (text, rest, pos) =>
Chris@1808 1659 outside pos (T.COMMENT (implode text) :: acc) rest
Chris@1808 1660 end
Chris@1808 1661
Chris@1808 1662 and instruction pos acc cc =
Chris@1808 1663 case cc of
Chris@1808 1664 #"?" :: #">" :: xs => outside (pos+2) acc xs
Chris@1808 1665 | #">" :: _ => tokenError pos #">"
Chris@1808 1666 | x :: xs => instruction (pos+1) acc xs
Chris@1808 1667 | [] => error pos "Document ends during processing instruction"
Chris@1808 1668
Chris@1808 1669 and cdata pos acc cc =
Chris@1808 1670 let fun cdata' pos text cc =
Chris@1808 1671 case cc of
Chris@1808 1672 #"]" :: #"]" :: #">" :: xs => OK (rev text, xs, pos+3)
Chris@1808 1673 | x :: xs => cdata' (pos+1) (x::text) xs
Chris@1808 1674 | [] => error pos "Document ends during CDATA section"
Chris@1808 1675 in
Chris@1808 1676 case cdata' pos [] cc of
Chris@1808 1677 ERROR e => ERROR e
Chris@1808 1678 | OK (text, rest, pos) =>
Chris@1808 1679 outside pos (T.CDATA (implode text) :: acc) rest
Chris@1808 1680 end
Chris@1808 1681
Chris@1808 1682 and doctype pos acc cc =
Chris@1808 1683 case cc of
Chris@1808 1684 #">" :: xs => outside (pos+1) acc xs
Chris@1808 1685 | x :: xs => doctype (pos+1) acc xs
Chris@1808 1686 | [] => error pos "Document ends during DOCTYPE"
Chris@1808 1687
Chris@1808 1688 and declaration pos acc cc =
Chris@1808 1689 case cc of
Chris@1808 1690 #"-" :: #"-" :: xs =>
Chris@1808 1691 comment (pos+2) acc xs
Chris@1808 1692 | #"[" :: #"C" :: #"D" :: #"A" :: #"T" :: #"A" :: #"[" :: xs =>
Chris@1808 1693 cdata (pos+7) acc xs
Chris@1808 1694 | #"D" :: #"O" :: #"C" :: #"T" :: #"Y" :: #"P" :: #"E" :: xs =>
Chris@1808 1695 doctype (pos+7) acc xs
Chris@1808 1696 | [] => error pos "Document ends during declaration"
Chris@1808 1697 | _ => error pos "Unsupported declaration type"
Chris@1808 1698
Chris@1808 1699 and left pos acc cc =
Chris@1808 1700 case cc of
Chris@1808 1701 #"/" :: xs => inside (pos+1) (T.ANGLE_SLASH_L :: acc) xs
Chris@1808 1702 | #"!" :: xs => declaration (pos+1) acc xs
Chris@1808 1703 | #"?" :: xs => instruction (pos+1) acc xs
Chris@1808 1704 | xs => inside pos (T.ANGLE_L :: acc) xs
Chris@1808 1705
Chris@1808 1706 and slash pos acc cc =
Chris@1808 1707 case cc of
Chris@1808 1708 #">" :: xs => outside (pos+1) (T.SLASH_ANGLE_R :: acc) xs
Chris@1808 1709 | x :: _ => tokenError pos x
Chris@1808 1710 | [] => error pos "Document ends before element closed"
Chris@1808 1711
Chris@1808 1712 and close pos acc xs = outside pos (T.ANGLE_R :: acc) xs
Chris@1808 1713
Chris@1808 1714 and equal pos acc xs = inside pos (T.EQUAL :: acc) xs
Chris@1808 1715
Chris@1808 1716 and outside pos acc [] = OK acc
Chris@1808 1717 | outside pos acc cc =
Chris@1808 1718 let fun textOf text = T.TEXT (implode (rev text))
Chris@1808 1719 fun outside' pos [] acc [] = OK acc
Chris@1808 1720 | outside' pos text acc [] = OK (textOf text :: acc)
Chris@1808 1721 | outside' pos text acc (x::xs) =
Chris@1808 1722 case x of
Chris@1808 1723 #"<" => if text = []
Chris@1808 1724 then left (pos+1) acc xs
Chris@1808 1725 else left (pos+1) (textOf text :: acc) xs
Chris@1808 1726 | x => outside' (pos+1) (x::text) acc xs
Chris@1808 1727 in
Chris@1808 1728 outside' pos [] acc cc
Chris@1808 1729 end
Chris@1808 1730
Chris@1808 1731 and inside pos acc [] = error pos "Document ends within tag"
Chris@1808 1732 | inside pos acc (#"<"::_) = tokenError pos #"<"
Chris@1808 1733 | inside pos acc (x::xs) =
Chris@1808 1734 (case x of
Chris@1808 1735 #" " => inside | #"\t" => inside
Chris@1808 1736 | #"\n" => inside | #"\r" => inside
Chris@1808 1737 | #"\"" => quoted x | #"'" => quoted x
Chris@1808 1738 | #"/" => slash | #">" => close | #"=" => equal
Chris@1808 1739 | x => name x) (pos+1) acc xs
Chris@1808 1740
Chris@1808 1741 fun lex str =
Chris@1808 1742 case outside 1 [] (explode str) of
Chris@1808 1743 ERROR e => ERROR e
Chris@1808 1744 | OK tokens => OK (rev tokens)
Chris@1808 1745 end
Chris@1808 1746
Chris@1808 1747 structure Parse :> sig
Chris@1808 1748 val parse : string -> document result
Chris@1808 1749 end = struct
Chris@1808 1750
Chris@1808 1751 fun show [] = "end of input"
Chris@1808 1752 | show (tok :: _) = T.name tok
Chris@1808 1753
Chris@1808 1754 fun error toks text = ERROR (text ^ " before " ^ show toks)
Chris@1808 1755
Chris@1808 1756 fun attribute elt name toks =
Chris@1808 1757 case toks of
Chris@1808 1758 T.EQUAL :: T.TEXT value :: xs =>
Chris@1808 1759 namedElement {
Chris@1808 1760 name = #name elt,
Chris@1808 1761 children = ATTRIBUTE { name = name, value = value } ::
Chris@1808 1762 #children elt
Chris@1808 1763 } xs
Chris@1808 1764 | T.EQUAL :: xs => error xs "Expected attribute value"
Chris@1808 1765 | toks => error toks "Expected attribute assignment"
Chris@1808 1766
Chris@1808 1767 and content elt toks =
Chris@1808 1768 case toks of
Chris@1808 1769 T.ANGLE_SLASH_L :: T.NAME n :: T.ANGLE_R :: xs =>
Chris@1808 1770 if n = #name elt
Chris@1808 1771 then OK (elt, xs)
Chris@1808 1772 else ERROR ("Closing tag </" ^ n ^ "> " ^
Chris@1808 1773 "does not match opening <" ^ #name elt ^ ">")
Chris@1808 1774 | T.TEXT text :: xs =>
Chris@1808 1775 content {
Chris@1808 1776 name = #name elt,
Chris@1808 1777 children = TEXT text :: #children elt
Chris@1808 1778 } xs
Chris@1808 1779 | T.CDATA text :: xs =>
Chris@1808 1780 content {
Chris@1808 1781 name = #name elt,
Chris@1808 1782 children = CDATA text :: #children elt
Chris@1808 1783 } xs
Chris@1808 1784 | T.COMMENT text :: xs =>
Chris@1808 1785 content {
Chris@1808 1786 name = #name elt,
Chris@1808 1787 children = COMMENT text :: #children elt
Chris@1808 1788 } xs
Chris@1808 1789 | T.ANGLE_L :: xs =>
Chris@1808 1790 (case element xs of
Chris@1808 1791 ERROR e => ERROR e
Chris@1808 1792 | OK (child, xs) =>
Chris@1808 1793 content {
Chris@1808 1794 name = #name elt,
Chris@1808 1795 children = ELEMENT child :: #children elt
Chris@1808 1796 } xs)
Chris@1808 1797 | tok :: xs =>
Chris@1808 1798 error xs ("Unexpected token " ^ T.name tok)
Chris@1808 1799 | [] =>
Chris@1808 1800 ERROR ("Document ends within element \"" ^ #name elt ^ "\"")
Chris@1808 1801
Chris@1808 1802 and namedElement elt toks =
Chris@1808 1803 case toks of
Chris@1808 1804 T.SLASH_ANGLE_R :: xs => OK (elt, xs)
Chris@1808 1805 | T.NAME name :: xs => attribute elt name xs
Chris@1808 1806 | T.ANGLE_R :: xs => content elt xs
Chris@1808 1807 | x :: xs => error xs ("Unexpected token " ^ T.name x)
Chris@1808 1808 | [] => ERROR "Document ends within opening tag"
Chris@1808 1809
Chris@1808 1810 and element toks =
Chris@1808 1811 case toks of
Chris@1808 1812 T.NAME name :: xs =>
Chris@1808 1813 (case namedElement { name = name, children = [] } xs of
Chris@1808 1814 ERROR e => ERROR e
Chris@1808 1815 | OK ({ name, children }, xs) =>
Chris@1808 1816 OK ({ name = name, children = rev children }, xs))
Chris@1808 1817 | toks => error toks "Expected element name"
Chris@1808 1818
Chris@1808 1819 and document [] = ERROR "Empty document"
Chris@1808 1820 | document (tok :: xs) =
Chris@1808 1821 case tok of
Chris@1808 1822 T.TEXT _ => document xs
Chris@1808 1823 | T.COMMENT _ => document xs
Chris@1808 1824 | T.ANGLE_L =>
Chris@1808 1825 (case element xs of
Chris@1808 1826 ERROR e => ERROR e
Chris@1808 1827 | OK (elt, []) => OK (DOCUMENT elt)
Chris@1808 1828 | OK (elt, (T.TEXT _ :: xs)) => OK (DOCUMENT elt)
Chris@1808 1829 | OK (elt, xs) => error xs "Extra data after document")
Chris@1808 1830 | _ => error xs ("Unexpected token " ^ T.name tok)
Chris@1808 1831
Chris@1808 1832 fun parse str =
Chris@1808 1833 case Lex.lex str of
Chris@1808 1834 ERROR e => ERROR e
Chris@1808 1835 | OK tokens => document tokens
Chris@1808 1836 end
Chris@1808 1837
Chris@1808 1838 structure Serialise :> sig
Chris@1808 1839 val serialise : document -> string
Chris@1808 1840 end = struct
Chris@1808 1841
Chris@1808 1842 fun attributes nodes =
Chris@1808 1843 String.concatWith
Chris@1808 1844 " "
Chris@1808 1845 (map node (List.filter
Chris@1808 1846 (fn ATTRIBUTE _ => true | _ => false)
Chris@1808 1847 nodes))
Chris@1808 1848
Chris@1808 1849 and nonAttributes nodes =
Chris@1808 1850 String.concat
Chris@1808 1851 (map node (List.filter
Chris@1808 1852 (fn ATTRIBUTE _ => false | _ => true)
Chris@1808 1853 nodes))
Chris@1808 1854
Chris@1808 1855 and node n =
Chris@1808 1856 case n of
Chris@1808 1857 TEXT string =>
Chris@1808 1858 string
Chris@1808 1859 | CDATA string =>
Chris@1808 1860 "<![CDATA[" ^ string ^ "]]>"
Chris@1808 1861 | COMMENT string =>
Chris@1808 1862 "<!-- " ^ string ^ "-->"
Chris@1808 1863 | ATTRIBUTE { name, value } =>
Chris@1808 1864 name ^ "=" ^ "\"" ^ value ^ "\"" (*!!!*)
Chris@1808 1865 | ELEMENT { name, children } =>
Chris@1808 1866 "<" ^ name ^
Chris@1808 1867 (case (attributes children) of
Chris@1808 1868 "" => ""
Chris@1808 1869 | s => " " ^ s) ^
Chris@1808 1870 (case (nonAttributes children) of
Chris@1808 1871 "" => "/>"
Chris@1808 1872 | s => ">" ^ s ^ "</" ^ name ^ ">")
Chris@1808 1873
Chris@1808 1874 fun serialise (DOCUMENT { name, children }) =
Chris@1808 1875 "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" ^
Chris@1808 1876 node (ELEMENT { name = name, children = children })
Chris@1808 1877 end
Chris@1808 1878
Chris@1808 1879 val parse = Parse.parse
Chris@1808 1880 val serialise = Serialise.serialise
Chris@1808 1881
Chris@1808 1882 end
Chris@1808 1883
Chris@1808 1884
Chris@1808 1885 structure SvnControl :> VCS_CONTROL = struct
Chris@1808 1886
Chris@1808 1887 val svn_program = "svn"
Chris@1808 1888
Chris@1808 1889 fun svn_command context libname args =
Chris@1808 1890 FileBits.command context libname (svn_program :: args)
Chris@1808 1891
Chris@1808 1892 fun svn_command_output context libname args =
Chris@1808 1893 FileBits.command_output context libname (svn_program :: args)
Chris@1808 1894
Chris@1808 1895 fun svn_command_lines context libname args =
Chris@1808 1896 case svn_command_output context libname args of
Chris@1808 1897 ERROR e => ERROR e
Chris@1808 1898 | OK s => OK (String.tokens (fn c => c = #"\n" orelse c = #"\r") s)
Chris@1808 1899
Chris@1808 1900 fun split_line_pair line =
Chris@1808 1901 let fun strip_leading_ws str = case explode str of
Chris@1808 1902 #" "::rest => implode rest
Chris@1808 1903 | _ => str
Chris@1808 1904 in
Chris@1808 1905 case String.tokens (fn c => c = #":") line of
Chris@1808 1906 [] => ("", "")
Chris@1808 1907 | first::rest =>
Chris@1808 1908 (first, strip_leading_ws (String.concatWith ":" rest))
Chris@1808 1909 end
Chris@1808 1910
Chris@1808 1911 fun is_working context =
Chris@1808 1912 case svn_command_output context "" ["--version"] of
Chris@1808 1913 OK "" => OK false
Chris@1808 1914 | OK _ => OK true
Chris@1808 1915 | ERROR e => ERROR e
Chris@1808 1916
Chris@1808 1917 structure X = SubXml
Chris@1808 1918
Chris@1808 1919 fun svn_info context libname route =
Chris@1808 1920 (* SVN 1.9 has info --show-item which is just what we need,
Chris@1808 1921 but at this point we still have 1.8 on the CI boxes so we
Chris@1808 1922 might as well aim to support it. For that we really have to
Chris@1808 1923 use the XML output format, since the default info output is
Chris@1808 1924 localised. This is the only thing our mini-XML parser is
Chris@1808 1925 used for though, so it would be good to trim it at some
Chris@1808 1926 point *)
Chris@1808 1927 let fun find elt [] = OK elt
Chris@1808 1928 | find { children, ... } (first :: rest) =
Chris@1808 1929 case List.find (fn (X.ELEMENT { name, ... }) => name = first
Chris@1808 1930 | _ => false)
Chris@1808 1931 children of
Chris@1808 1932 NONE => ERROR ("No element \"" ^ first ^ "\" in SVN XML")
Chris@1808 1933 | SOME (X.ELEMENT e) => find e rest
Chris@1808 1934 | SOME _ => ERROR "Internal error"
Chris@1808 1935 in
Chris@1808 1936 case svn_command_output context libname ["info", "--xml"] of
Chris@1808 1937 ERROR e => ERROR e
Chris@1808 1938 | OK xml =>
Chris@1808 1939 case X.parse xml of
Chris@1808 1940 X.ERROR e => ERROR e
Chris@1808 1941 | X.OK (X.DOCUMENT doc) => find doc route
Chris@1808 1942 end
Chris@1808 1943
Chris@1808 1944 fun exists context libname =
Chris@1808 1945 OK (OS.FileSys.isDir (FileBits.subpath context libname ".svn"))
Chris@1808 1946 handle _ => OK false
Chris@1808 1947
Chris@1808 1948 fun remote_for context (libname, source) =
Chris@1808 1949 Provider.remote_url context SVN source libname
Chris@1808 1950
Chris@1808 1951 (* Remote the checkout came from, not necessarily the one we want *)
Chris@1808 1952 fun actual_remote_for context libname =
Chris@1808 1953 case svn_info context libname ["entry", "url"] of
Chris@1808 1954 ERROR e => ERROR e
Chris@1808 1955 | OK { children, ... } =>
Chris@1808 1956 case List.find (fn (X.TEXT _) => true | _ => false) children of
Chris@1808 1957 NONE => ERROR "No content for URL in SVN info XML"
Chris@1808 1958 | SOME (X.TEXT url) => OK url
Chris@1808 1959 | SOME _ => ERROR "Internal error"
Chris@1808 1960
Chris@1808 1961 fun id_of context libname =
Chris@1808 1962 case svn_info context libname ["entry"] of
Chris@1808 1963 ERROR e => ERROR e
Chris@1808 1964 | OK { children, ... } =>
Chris@1808 1965 case List.find
Chris@1808 1966 (fn (X.ATTRIBUTE { name = "revision", ... }) => true
Chris@1808 1967 | _ => false)
Chris@1808 1968 children of
Chris@1808 1969 NONE => ERROR "No revision for entry in SVN info XML"
Chris@1808 1970 | SOME (X.ATTRIBUTE { value, ... }) => OK value
Chris@1808 1971 | SOME _ => ERROR "Internal error"
Chris@1808 1972
Chris@1808 1973 fun is_at context (libname, id_or_tag) =
Chris@1808 1974 case id_of context libname of
Chris@1808 1975 ERROR e => ERROR e
Chris@1808 1976 | OK id => OK (id = id_or_tag)
Chris@1808 1977
Chris@1808 1978 fun is_on_branch context (libname, b) =
Chris@1808 1979 OK (b = DEFAULT_BRANCH)
Chris@1808 1980
Chris@1808 1981 fun check_remote context (libname, source) =
Chris@1808 1982 case (remote_for context (libname, source),
Chris@1808 1983 actual_remote_for context libname) of
Chris@1808 1984 (_, ERROR e) => ERROR e
Chris@1808 1985 | (url, OK actual) =>
Chris@1808 1986 if actual = url
Chris@1808 1987 then OK ()
Chris@1808 1988 else svn_command context libname ["relocate", url]
Chris@1808 1989
Chris@1808 1990 fun is_newest context (libname, source, branch) =
Chris@1808 1991 case check_remote context (libname, source) of
Chris@1808 1992 ERROR e => ERROR e
Chris@1808 1993 | OK () =>
Chris@1808 1994 case svn_command_lines context libname
Chris@1808 1995 ["status", "--show-updates"] of
Chris@1808 1996 ERROR e => ERROR e
Chris@1808 1997 | OK lines =>
Chris@1808 1998 case rev lines of
Chris@1808 1999 [] => ERROR "No result returned for server status"
Chris@1808 2000 | last_line::_ =>
Chris@1808 2001 case rev (String.tokens (fn c => c = #" ") last_line) of
Chris@1808 2002 [] => ERROR "No revision field found in server status"
Chris@1808 2003 | server_id::_ => is_at context (libname, server_id)
Chris@1808 2004
Chris@1808 2005 fun is_newest_locally context (libname, branch) =
Chris@1808 2006 OK true (* no local history *)
Chris@1808 2007
Chris@1808 2008 fun is_modified_locally context libname =
Chris@1808 2009 case svn_command_output context libname ["status"] of
Chris@1808 2010 ERROR e => ERROR e
Chris@1808 2011 | OK "" => OK false
Chris@1808 2012 | OK _ => OK true
Chris@1808 2013
Chris@1808 2014 fun checkout context (libname, source, branch) =
Chris@1808 2015 let val url = remote_for context (libname, source)
Chris@1808 2016 val path = FileBits.libpath context libname
Chris@1808 2017 in
Chris@1808 2018 if FileBits.nonempty_dir_exists path
Chris@1808 2019 then (* Surprisingly, SVN itself has no problem with
Chris@1808 2020 this. But for consistency with other VCSes we
Chris@1808 2021 don't allow it *)
Chris@1808 2022 ERROR ("Refusing checkout to nonempty dir \"" ^ path ^ "\"")
Chris@1808 2023 else
Chris@1808 2024 (* make the lib dir rather than just the ext dir, since
Chris@1808 2025 the lib dir might be nested and svn will happily check
Chris@1808 2026 out into an existing empty dir anyway *)
Chris@1808 2027 case FileBits.mkpath (FileBits.libpath context libname) of
Chris@1808 2028 ERROR e => ERROR e
Chris@1808 2029 | _ => svn_command context "" ["checkout", url, libname]
Chris@1808 2030 end
Chris@1808 2031
Chris@1808 2032 fun update context (libname, source, branch) =
Chris@1808 2033 case check_remote context (libname, source) of
Chris@1808 2034 ERROR e => ERROR e
Chris@1808 2035 | OK () =>
Chris@1808 2036 case svn_command context libname
Chris@1808 2037 ["update", "--accept", "postpone"] of
Chris@1808 2038 ERROR e => ERROR e
Chris@1808 2039 | _ => OK ()
Chris@1808 2040
Chris@1808 2041 fun update_to context (libname, _, "") =
Chris@1808 2042 ERROR "Non-empty id (tag or revision id) required for update_to"
Chris@1808 2043 | update_to context (libname, source, id) =
Chris@1808 2044 case check_remote context (libname, source) of
Chris@1808 2045 ERROR e => ERROR e
Chris@1808 2046 | OK () =>
Chris@1808 2047 case svn_command context libname
Chris@1808 2048 ["update", "-r", id, "--accept", "postpone"] of
Chris@1808 2049 ERROR e => ERROR e
Chris@1808 2050 | OK _ => OK ()
Chris@1808 2051
Chris@1808 2052 fun copy_url_for context libname =
Chris@1808 2053 actual_remote_for context libname
Chris@1808 2054
Chris@1808 2055 end
Chris@1808 2056
Chris@1808 2057 structure AnyLibControl :> LIB_CONTROL = struct
Chris@1808 2058
Chris@1808 2059 structure H = LibControlFn(HgControl)
Chris@1808 2060 structure G = LibControlFn(GitControl)
Chris@1808 2061 structure S = LibControlFn(SvnControl)
Chris@1808 2062
Chris@1808 2063 fun review context (spec as { vcs, ... } : libspec) =
Chris@1808 2064 (fn HG => H.review | GIT => G.review | SVN => S.review) vcs context spec
Chris@1808 2065
Chris@1808 2066 fun status context (spec as { vcs, ... } : libspec) =
Chris@1808 2067 (fn HG => H.status | GIT => G.status | SVN => S.status) vcs context spec
Chris@1808 2068
Chris@1808 2069 fun update context (spec as { vcs, ... } : libspec) =
Chris@1808 2070 (fn HG => H.update | GIT => G.update | SVN => S.update) vcs context spec
Chris@1808 2071
Chris@1808 2072 fun id_of context (spec as { vcs, ... } : libspec) =
Chris@1808 2073 (fn HG => H.id_of | GIT => G.id_of | SVN => S.id_of) vcs context spec
Chris@1808 2074
Chris@1808 2075 fun is_working context vcs =
Chris@1808 2076 (fn HG => H.is_working | GIT => G.is_working | SVN => S.is_working)
Chris@1808 2077 vcs context vcs
Chris@1808 2078
Chris@1808 2079 end
Chris@1808 2080
Chris@1808 2081
Chris@1808 2082 type exclusions = string list
Chris@1808 2083
Chris@1808 2084 structure Archive :> sig
Chris@1808 2085
Chris@1808 2086 val archive : string * exclusions -> project -> OS.Process.status
Chris@1808 2087
Chris@1808 2088 end = struct
Chris@1808 2089
Chris@1808 2090 (* The idea of "archive" is to replace hg/git archive, which won't
Chris@1808 2091 include files, like the Repoint-introduced external libraries,
Chris@1808 2092 that are not under version control with the main repo.
Chris@1808 2093
Chris@1808 2094 The process goes like this:
Chris@1808 2095
Chris@1808 2096 - Make sure we have a target filename from the user, and take
Chris@1808 2097 its basename as our archive directory name
Chris@1808 2098
Chris@1808 2099 - Make an "archive root" subdir of the project repo, named
Chris@1808 2100 typically .repoint-archive
Chris@1808 2101
Chris@1808 2102 - Identify the VCS used for the project repo. Note that any
Chris@1808 2103 explicit references to VCS type in this structure are to
Chris@1808 2104 the VCS used for the project (something Repoint doesn't
Chris@1808 2105 otherwise care about), not for an individual library
Chris@1808 2106
Chris@1808 2107 - Synthesise a Repoint project with the archive root as its
Chris@1808 2108 root path, "." as its extdir, with one library whose
Chris@1808 2109 name is the user-supplied basename and whose explicit
Chris@1808 2110 source URL is the original project root; update that
Chris@1808 2111 project -- thus cloning the original project to a subdir
Chris@1808 2112 of the archive root
Chris@1808 2113
Chris@1808 2114 - Synthesise a Repoint project identical to the original one for
Chris@1808 2115 this project, but with the newly-cloned copy as its root
Chris@1808 2116 path; update that project -- thus checking out clean copies
Chris@1808 2117 of the external library dirs
Chris@1808 2118
Chris@1808 2119 - Call out to an archive program to archive up the new copy,
Chris@1808 2120 running e.g.
Chris@1808 2121 tar cvzf project-release.tar.gz \
Chris@1808 2122 --exclude=.hg --exclude=.git project-release
Chris@1808 2123 in the archive root dir
Chris@1808 2124
Chris@1808 2125 - (We also omit the repoint-project.json file and any trace of
Chris@1808 2126 Repoint. It can't properly be run in a directory where the
Chris@1808 2127 external project folders already exist but their repo history
Chris@1808 2128 does not. End users shouldn't get to see Repoint)
Chris@1808 2129
Chris@1808 2130 - Clean up by deleting the new copy
Chris@1808 2131 *)
Chris@1808 2132
Chris@1808 2133 fun project_vcs_id_and_url dir =
Chris@1808 2134 let val context = {
Chris@1808 2135 rootpath = dir,
Chris@1808 2136 extdir = ".",
Chris@1808 2137 providers = [],
Chris@1808 2138 accounts = []
Chris@1808 2139 }
Chris@1808 2140 val vcs_maybe =
Chris@1808 2141 case [HgControl.exists context ".",
Chris@1808 2142 GitControl.exists context ".",
Chris@1808 2143 SvnControl.exists context "."] of
Chris@1808 2144 [OK true, OK false, OK false] => OK HG
Chris@1808 2145 | [OK false, OK true, OK false] => OK GIT
Chris@1808 2146 | [OK false, OK false, OK true] => OK SVN
Chris@1808 2147 | _ => ERROR ("Unable to identify VCS for directory " ^ dir)
Chris@1808 2148 in
Chris@1808 2149 case vcs_maybe of
Chris@1808 2150 ERROR e => ERROR e
Chris@1808 2151 | OK vcs =>
Chris@1808 2152 case (fn HG => HgControl.id_of
Chris@1808 2153 | GIT => GitControl.id_of
Chris@1808 2154 | SVN => SvnControl.id_of)
Chris@1808 2155 vcs context "." of
Chris@1808 2156 ERROR e => ERROR ("Unable to find id of project repo: " ^ e)
Chris@1808 2157 | OK id =>
Chris@1808 2158 case (fn HG => HgControl.copy_url_for
Chris@1808 2159 | GIT => GitControl.copy_url_for
Chris@1808 2160 | SVN => SvnControl.copy_url_for)
Chris@1808 2161 vcs context "." of
Chris@1808 2162 ERROR e => ERROR ("Unable to find URL of project repo: "
Chris@1808 2163 ^ e)
Chris@1808 2164 | OK url => OK (vcs, id, url)
Chris@1808 2165 end
Chris@1808 2166
Chris@1808 2167 fun make_archive_root (context : context) =
Chris@1808 2168 let val path = OS.Path.joinDirFile {
Chris@1808 2169 dir = #rootpath context,
Chris@1808 2170 file = RepointFilenames.archive_dir
Chris@1808 2171 }
Chris@1808 2172 in
Chris@1808 2173 case FileBits.mkpath path of
Chris@1808 2174 ERROR e => raise Fail ("Failed to create archive directory \""
Chris@1808 2175 ^ path ^ "\": " ^ e)
Chris@1808 2176 | OK () => path
Chris@1808 2177 end
Chris@1808 2178
Chris@1808 2179 fun archive_path archive_dir target_name =
Chris@1808 2180 OS.Path.joinDirFile {
Chris@1808 2181 dir = archive_dir,
Chris@1808 2182 file = target_name
Chris@1808 2183 }
Chris@1808 2184
Chris@1808 2185 fun check_nonexistent path =
Chris@1808 2186 case SOME (OS.FileSys.fileSize path) handle OS.SysErr _ => NONE of
Chris@1808 2187 NONE => ()
Chris@1808 2188 | _ => raise Fail ("Path " ^ path ^ " exists, not overwriting")
Chris@1808 2189
Chris@1808 2190 fun make_archive_copy target_name (vcs, project_id, source_url)
Chris@1808 2191 ({ context, ... } : project) =
Chris@1808 2192 let val archive_root = make_archive_root context
Chris@1808 2193 val synthetic_context = {
Chris@1808 2194 rootpath = archive_root,
Chris@1808 2195 extdir = ".",
Chris@1808 2196 providers = [],
Chris@1808 2197 accounts = []
Chris@1808 2198 }
Chris@1808 2199 val synthetic_library = {
Chris@1808 2200 libname = target_name,
Chris@1808 2201 vcs = vcs,
Chris@1808 2202 source = URL_SOURCE source_url,
Chris@1808 2203 branch = DEFAULT_BRANCH, (* overridden by pinned id below *)
Chris@1808 2204 project_pin = PINNED project_id,
Chris@1808 2205 lock_pin = PINNED project_id
Chris@1808 2206 }
Chris@1808 2207 val path = archive_path archive_root target_name
Chris@1808 2208 val _ = print ("Cloning original project to " ^ path
Chris@1808 2209 ^ " at revision " ^ project_id ^ "...\n");
Chris@1808 2210 val _ = check_nonexistent path
Chris@1808 2211 in
Chris@1808 2212 case AnyLibControl.update synthetic_context synthetic_library of
Chris@1808 2213 ERROR e => ERROR ("Failed to clone original project to "
Chris@1808 2214 ^ path ^ ": " ^ e)
Chris@1808 2215 | OK _ => OK archive_root
Chris@1808 2216 end
Chris@1808 2217
Chris@1808 2218 fun update_archive archive_root target_name
Chris@1808 2219 (project as { context, ... } : project) =
Chris@1808 2220 let val synthetic_context = {
Chris@1808 2221 rootpath = archive_path archive_root target_name,
Chris@1808 2222 extdir = #extdir context,
Chris@1808 2223 providers = #providers context,
Chris@1808 2224 accounts = #accounts context
Chris@1808 2225 }
Chris@1808 2226 in
Chris@1808 2227 foldl (fn (lib, acc) =>
Chris@1808 2228 case acc of
Chris@1808 2229 ERROR e => ERROR e
Chris@1808 2230 | OK () => AnyLibControl.update synthetic_context lib)
Chris@1808 2231 (OK ())
Chris@1808 2232 (#libs project)
Chris@1808 2233 end
Chris@1808 2234
Chris@1808 2235 datatype packer = TAR
Chris@1808 2236 | TAR_GZ
Chris@1808 2237 | TAR_BZ2
Chris@1808 2238 | TAR_XZ
Chris@1808 2239 (* could add other packers, e.g. zip, if we knew how to
Chris@1808 2240 handle the file omissions etc properly in pack_archive *)
Chris@1808 2241
Chris@1808 2242 fun packer_and_basename path =
Chris@1808 2243 let val extensions = [ (".tar", TAR),
Chris@1808 2244 (".tar.gz", TAR_GZ),
Chris@1808 2245 (".tar.bz2", TAR_BZ2),
Chris@1808 2246 (".tar.xz", TAR_XZ)]
Chris@1808 2247 val filename = OS.Path.file path
Chris@1808 2248 in
Chris@1808 2249 foldl (fn ((ext, packer), acc) =>
Chris@1808 2250 if String.isSuffix ext filename
Chris@1808 2251 then SOME (packer,
Chris@1808 2252 String.substring (filename, 0,
Chris@1808 2253 String.size filename -
Chris@1808 2254 String.size ext))
Chris@1808 2255 else acc)
Chris@1808 2256 NONE
Chris@1808 2257 extensions
Chris@1808 2258 end
Chris@1808 2259
Chris@1808 2260 fun pack_archive archive_root target_name target_path packer exclusions =
Chris@1808 2261 case FileBits.command {
Chris@1808 2262 rootpath = archive_root,
Chris@1808 2263 extdir = ".",
Chris@1808 2264 providers = [],
Chris@1808 2265 accounts = []
Chris@1808 2266 } "" ([
Chris@1808 2267 "tar",
Chris@1808 2268 case packer of
Chris@1808 2269 TAR => "cf"
Chris@1808 2270 | TAR_GZ => "czf"
Chris@1808 2271 | TAR_BZ2 => "cjf"
Chris@1808 2272 | TAR_XZ => "cJf",
Chris@1808 2273 target_path,
Chris@1808 2274 "--exclude=.hg",
Chris@1808 2275 "--exclude=.git",
Chris@1808 2276 "--exclude=.svn",
Chris@1808 2277 "--exclude=repoint",
Chris@1808 2278 "--exclude=repoint.sml",
Chris@1808 2279 "--exclude=repoint.ps1",
Chris@1808 2280 "--exclude=repoint.bat",
Chris@1808 2281 "--exclude=repoint-project.json",
Chris@1808 2282 "--exclude=repoint-lock.json"
Chris@1808 2283 ] @ (map (fn e => "--exclude=" ^ e) exclusions) @
Chris@1808 2284 [ target_name ])
Chris@1808 2285 of
Chris@1808 2286 ERROR e => ERROR e
Chris@1808 2287 | OK _ => FileBits.rmpath (archive_path archive_root target_name)
Chris@1808 2288
Chris@1808 2289 fun archive (target_path, exclusions) (project : project) =
Chris@1808 2290 let val _ = check_nonexistent target_path
Chris@1808 2291 val (packer, name) =
Chris@1808 2292 case packer_and_basename target_path of
Chris@1808 2293 NONE => raise Fail ("Unsupported archive file extension in "
Chris@1808 2294 ^ target_path)
Chris@1808 2295 | SOME pn => pn
Chris@1808 2296 val details =
Chris@1808 2297 case project_vcs_id_and_url (#rootpath (#context project)) of
Chris@1808 2298 ERROR e => raise Fail e
Chris@1808 2299 | OK details => details
Chris@1808 2300 val archive_root =
Chris@1808 2301 case make_archive_copy name details project of
Chris@1808 2302 ERROR e => raise Fail e
Chris@1808 2303 | OK archive_root => archive_root
Chris@1808 2304 val outcome =
Chris@1808 2305 case update_archive archive_root name project of
Chris@1808 2306 ERROR e => ERROR e
Chris@1808 2307 | OK _ =>
Chris@1808 2308 case pack_archive archive_root name
Chris@1808 2309 target_path packer exclusions of
Chris@1808 2310 ERROR e => ERROR e
Chris@1808 2311 | OK _ => OK ()
Chris@1808 2312 in
Chris@1808 2313 case outcome of
Chris@1808 2314 ERROR e => raise Fail e
Chris@1808 2315 | OK () => OS.Process.success
Chris@1808 2316 end
Chris@1808 2317
Chris@1808 2318 end
Chris@1808 2319
Chris@1808 2320 val libobjname = "libraries"
Chris@1808 2321
Chris@1808 2322 fun load_libspec spec_json lock_json libname : libspec =
Chris@1808 2323 let open JsonBits
Chris@1808 2324 val libobj = lookup_mandatory spec_json [libobjname, libname]
Chris@1808 2325 val vcs = lookup_mandatory_string libobj ["vcs"]
Chris@1808 2326 val retrieve = lookup_optional_string libobj
Chris@1808 2327 val service = retrieve ["service"]
Chris@1808 2328 val owner = retrieve ["owner"]
Chris@1808 2329 val repo = retrieve ["repository"]
Chris@1808 2330 val url = retrieve ["url"]
Chris@1808 2331 val branch = retrieve ["branch"]
Chris@1808 2332 val project_pin = case retrieve ["pin"] of
Chris@1808 2333 NONE => UNPINNED
Chris@1808 2334 | SOME p => PINNED p
Chris@1808 2335 val lock_pin = case lookup_optional lock_json [libobjname, libname] of
Chris@1808 2336 NONE => UNPINNED
Chris@1808 2337 | SOME ll => case lookup_optional_string ll ["pin"] of
Chris@1808 2338 SOME p => PINNED p
Chris@1808 2339 | NONE => UNPINNED
Chris@1808 2340 in
Chris@1808 2341 {
Chris@1808 2342 libname = libname,
Chris@1808 2343 vcs = case vcs of
Chris@1808 2344 "hg" => HG
Chris@1808 2345 | "git" => GIT
Chris@1808 2346 | "svn" => SVN
Chris@1808 2347 | other => raise Fail ("Unknown version-control system \"" ^
Chris@1808 2348 other ^ "\""),
Chris@1808 2349 source = case (url, service, owner, repo) of
Chris@1808 2350 (SOME u, NONE, _, _) => URL_SOURCE u
Chris@1808 2351 | (NONE, SOME ss, owner, repo) =>
Chris@1808 2352 SERVICE_SOURCE { service = ss, owner = owner, repo = repo }
Chris@1808 2353 | _ => raise Fail ("Must have exactly one of service " ^
Chris@1808 2354 "or url string"),
Chris@1808 2355 project_pin = project_pin,
Chris@1808 2356 lock_pin = lock_pin,
Chris@1808 2357 branch = case branch of
Chris@1808 2358 NONE => DEFAULT_BRANCH
Chris@1808 2359 | SOME b =>
Chris@1808 2360 case vcs of
Chris@1808 2361 "svn" => raise Fail ("Branches not supported for " ^
Chris@1808 2362 "svn repositories; change " ^
Chris@1808 2363 "URL instead")
Chris@1808 2364 | _ => BRANCH b
Chris@1808 2365 }
Chris@1808 2366 end
Chris@1808 2367
Chris@1808 2368 fun load_userconfig () : userconfig =
Chris@1808 2369 let val home = FileBits.homedir ()
Chris@1808 2370 val conf_json =
Chris@1808 2371 JsonBits.load_json_from
Chris@1808 2372 (OS.Path.joinDirFile {
Chris@1808 2373 dir = home,
Chris@1808 2374 file = RepointFilenames.user_config_file })
Chris@1808 2375 handle IO.Io _ => Json.OBJECT []
Chris@1808 2376 in
Chris@1808 2377 {
Chris@1808 2378 accounts = case JsonBits.lookup_optional conf_json ["accounts"] of
Chris@1808 2379 NONE => []
Chris@1808 2380 | SOME (Json.OBJECT aa) =>
Chris@1808 2381 map (fn (k, (Json.STRING v)) =>
Chris@1808 2382 { service = k, login = v }
Chris@1808 2383 | _ => raise Fail
Chris@1808 2384 "String expected for account name")
Chris@1808 2385 aa
Chris@1808 2386 | _ => raise Fail "Array expected for accounts",
Chris@1808 2387 providers = Provider.load_providers conf_json
Chris@1808 2388 }
Chris@1808 2389 end
Chris@1808 2390
Chris@1808 2391 datatype pintype =
Chris@1808 2392 NO_LOCKFILE |
Chris@1808 2393 USE_LOCKFILE
Chris@1808 2394
Chris@1808 2395 fun load_project (userconfig : userconfig) rootpath pintype : project =
Chris@1808 2396 let val spec_file = FileBits.project_spec_path rootpath
Chris@1808 2397 val lock_file = FileBits.project_lock_path rootpath
Chris@1808 2398 val _ = if OS.FileSys.access (spec_file, [OS.FileSys.A_READ])
Chris@1808 2399 handle OS.SysErr _ => false
Chris@1808 2400 then ()
Chris@1808 2401 else raise Fail ("Failed to open project spec file " ^
Chris@1808 2402 (RepointFilenames.project_file) ^ " in " ^
Chris@1808 2403 rootpath ^
Chris@1808 2404 ".\nPlease ensure the spec file is in the " ^
Chris@1808 2405 "project root and run this from there.")
Chris@1808 2406 val spec_json = JsonBits.load_json_from spec_file
Chris@1808 2407 val lock_json = if pintype = USE_LOCKFILE
Chris@1808 2408 then JsonBits.load_json_from lock_file
Chris@1808 2409 handle IO.Io _ => Json.OBJECT []
Chris@1808 2410 else Json.OBJECT []
Chris@1808 2411 val extdir = JsonBits.lookup_mandatory_string spec_json
Chris@1808 2412 ["config", "extdir"]
Chris@1808 2413 val spec_libs = JsonBits.lookup_optional spec_json [libobjname]
Chris@1808 2414 val lock_libs = JsonBits.lookup_optional lock_json [libobjname]
Chris@1808 2415 val providers = Provider.load_more_providers
Chris@1808 2416 (#providers userconfig) spec_json
Chris@1808 2417 val libnames = case spec_libs of
Chris@1808 2418 NONE => []
Chris@1808 2419 | SOME (Json.OBJECT ll) => map (fn (k, v) => k) ll
Chris@1808 2420 | _ => raise Fail "Object expected for libs"
Chris@1808 2421 in
Chris@1808 2422 {
Chris@1808 2423 context = {
Chris@1808 2424 rootpath = rootpath,
Chris@1808 2425 extdir = extdir,
Chris@1808 2426 providers = providers,
Chris@1808 2427 accounts = #accounts userconfig
Chris@1808 2428 },
Chris@1808 2429 libs = map (load_libspec spec_json lock_json) libnames
Chris@1808 2430 }
Chris@1808 2431 end
Chris@1808 2432
Chris@1808 2433 fun save_lock_file rootpath locks =
Chris@1808 2434 let val lock_file = FileBits.project_lock_path rootpath
Chris@1808 2435 open Json
Chris@1808 2436 val lock_json =
Chris@1808 2437 OBJECT [
Chris@1808 2438 (libobjname,
Chris@1808 2439 OBJECT (map (fn { libname, id_or_tag } =>
Chris@1808 2440 (libname,
Chris@1808 2441 OBJECT [ ("pin", STRING id_or_tag) ]))
Chris@1808 2442 locks))
Chris@1808 2443 ]
Chris@1808 2444 in
Chris@1808 2445 JsonBits.save_json_to lock_file lock_json
Chris@1808 2446 end
Chris@1865 2447
Chris@1865 2448 fun checkpoint_completion_file rootpath =
Chris@1865 2449 let val completion_file = FileBits.project_completion_path rootpath
Chris@1865 2450 val stream = TextIO.openOut completion_file
Chris@1865 2451 in
Chris@1865 2452 TextIO.closeOut stream
Chris@1865 2453 end
Chris@1865 2454
Chris@1808 2455 fun pad_to n str =
Chris@1808 2456 if n <= String.size str then str
Chris@1808 2457 else pad_to n (str ^ " ")
Chris@1808 2458
Chris@1808 2459 fun hline_to 0 = ""
Chris@1808 2460 | hline_to n = "-" ^ hline_to (n-1)
Chris@1808 2461
Chris@1808 2462 val libname_width = 28
Chris@1808 2463 val libstate_width = 11
Chris@1808 2464 val localstate_width = 17
Chris@1808 2465 val notes_width = 5
Chris@1808 2466 val divider = " | "
Chris@1808 2467 val clear_line = "\r" ^ pad_to 80 "";
Chris@1808 2468
Chris@1808 2469 fun print_status_header () =
Chris@1808 2470 print (clear_line ^ "\n " ^
Chris@1808 2471 pad_to libname_width "Library" ^ divider ^
Chris@1808 2472 pad_to libstate_width "State" ^ divider ^
Chris@1808 2473 pad_to localstate_width "Local" ^ divider ^
Chris@1808 2474 "Notes" ^ "\n " ^
Chris@1808 2475 hline_to libname_width ^ "-+-" ^
Chris@1808 2476 hline_to libstate_width ^ "-+-" ^
Chris@1808 2477 hline_to localstate_width ^ "-+-" ^
Chris@1808 2478 hline_to notes_width ^ "\n")
Chris@1808 2479
Chris@1808 2480 fun print_outcome_header () =
Chris@1808 2481 print (clear_line ^ "\n " ^
Chris@1808 2482 pad_to libname_width "Library" ^ divider ^
Chris@1808 2483 pad_to libstate_width "Outcome" ^ divider ^
Chris@1808 2484 "Notes" ^ "\n " ^
Chris@1808 2485 hline_to libname_width ^ "-+-" ^
Chris@1808 2486 hline_to libstate_width ^ "-+-" ^
Chris@1808 2487 hline_to notes_width ^ "\n")
Chris@1808 2488
Chris@1808 2489 fun print_status with_network (lib : libspec, status) =
Chris@1808 2490 let val libstate_str =
Chris@1808 2491 case status of
Chris@1808 2492 OK (ABSENT, _) => "Absent"
Chris@1808 2493 | OK (CORRECT, _) => if with_network then "Correct" else "Present"
Chris@1808 2494 | OK (SUPERSEDED, _) => "Superseded"
Chris@1808 2495 | OK (WRONG, _) => "Wrong"
Chris@1808 2496 | ERROR _ => "Error"
Chris@1808 2497 val localstate_str =
Chris@1808 2498 case status of
Chris@1808 2499 OK (_, MODIFIED) => "Modified"
Chris@1808 2500 | OK (_, LOCK_MISMATCHED) => "Differs from Lock"
Chris@1808 2501 | OK (_, CLEAN) => "Clean"
Chris@1808 2502 | ERROR _ => ""
Chris@1808 2503 val error_str =
Chris@1808 2504 case status of
Chris@1808 2505 ERROR e => e
Chris@1808 2506 | _ => ""
Chris@1808 2507 in
Chris@1808 2508 print (" " ^
Chris@1808 2509 pad_to libname_width (#libname lib) ^ divider ^
Chris@1808 2510 pad_to libstate_width libstate_str ^ divider ^
Chris@1808 2511 pad_to localstate_width localstate_str ^ divider ^
Chris@1808 2512 error_str ^ "\n")
Chris@1808 2513 end
Chris@1808 2514
Chris@1808 2515 fun print_update_outcome (lib : libspec, outcome) =
Chris@1808 2516 let val outcome_str =
Chris@1808 2517 case outcome of
Chris@1808 2518 OK id => "Ok"
Chris@1808 2519 | ERROR e => "Failed"
Chris@1808 2520 val error_str =
Chris@1808 2521 case outcome of
Chris@1808 2522 ERROR e => e
Chris@1808 2523 | _ => ""
Chris@1808 2524 in
Chris@1808 2525 print (" " ^
Chris@1808 2526 pad_to libname_width (#libname lib) ^ divider ^
Chris@1808 2527 pad_to libstate_width outcome_str ^ divider ^
Chris@1808 2528 error_str ^ "\n")
Chris@1808 2529 end
Chris@1808 2530
Chris@1808 2531 fun vcs_name HG = ("Mercurial", "hg")
Chris@1808 2532 | vcs_name GIT = ("Git", "git")
Chris@1808 2533 | vcs_name SVN = ("Subversion", "svn")
Chris@1808 2534
Chris@1808 2535 fun print_problem_summary context lines =
Chris@1808 2536 let val failed_vcs =
Chris@1808 2537 foldl (fn (({ vcs, ... } : libspec, ERROR _), acc) => vcs::acc
Chris@1808 2538 | (_, acc) => acc) [] lines
Chris@1808 2539 fun report_nonworking vcs error =
Chris@1808 2540 print ((if error = "" then "" else error ^ "\n\n") ^
Chris@1808 2541 "Error: The project uses the " ^ (#1 (vcs_name vcs)) ^
Chris@1808 2542 " version control system, but its\n" ^
Chris@1808 2543 "executable program (" ^ (#2 (vcs_name vcs)) ^
Chris@1808 2544 ") does not appear to be installed in the program path\n\n")
Chris@1808 2545 fun check_working [] checked = ()
Chris@1808 2546 | check_working (vcs::rest) checked =
Chris@1808 2547 if List.exists (fn v => vcs = v) checked
Chris@1808 2548 then check_working rest checked
Chris@1808 2549 else
Chris@1808 2550 case AnyLibControl.is_working context vcs of
Chris@1808 2551 OK true => check_working rest checked
Chris@1808 2552 | OK false => (report_nonworking vcs "";
Chris@1808 2553 check_working rest (vcs::checked))
Chris@1808 2554 | ERROR e => (report_nonworking vcs e;
Chris@1808 2555 check_working rest (vcs::checked))
Chris@1808 2556 in
Chris@1808 2557 print "\nError: Some operations failed\n\n";
Chris@1808 2558 check_working failed_vcs []
Chris@1808 2559 end
Chris@1808 2560
Chris@1808 2561 fun act_and_print action print_header print_line context (libs : libspec list) =
Chris@1808 2562 let val lines = map (fn lib => (lib, action lib)) libs
Chris@1808 2563 val imperfect = List.exists (fn (_, ERROR _) => true | _ => false) lines
Chris@1808 2564 val _ = print_header ()
Chris@1808 2565 in
Chris@1808 2566 app print_line lines;
Chris@1808 2567 if imperfect then print_problem_summary context lines else ();
Chris@1808 2568 lines
Chris@1808 2569 end
Chris@1808 2570
Chris@1808 2571 fun return_code_for outcomes =
Chris@1808 2572 foldl (fn ((_, result), acc) =>
Chris@1808 2573 case result of
Chris@1808 2574 ERROR _ => OS.Process.failure
Chris@1808 2575 | _ => acc)
Chris@1808 2576 OS.Process.success
Chris@1808 2577 outcomes
Chris@1808 2578
Chris@1808 2579 fun status_of_project ({ context, libs } : project) =
Chris@1808 2580 return_code_for (act_and_print (AnyLibControl.status context)
Chris@1808 2581 print_status_header (print_status false)
Chris@1808 2582 context libs)
Chris@1808 2583
Chris@1808 2584 fun review_project ({ context, libs } : project) =
Chris@1808 2585 return_code_for (act_and_print (AnyLibControl.review context)
Chris@1808 2586 print_status_header (print_status true)
Chris@1808 2587 context libs)
Chris@1808 2588
Chris@1808 2589 fun lock_project ({ context, libs } : project) =
Chris@1808 2590 let val _ = if FileBits.verbose ()
Chris@1808 2591 then print ("Scanning IDs for lock file...\n")
Chris@1808 2592 else ()
Chris@1808 2593 val outcomes = map (fn lib => (lib, AnyLibControl.id_of context lib))
Chris@1808 2594 libs
Chris@1808 2595 val locks =
Chris@1808 2596 List.concat
Chris@1808 2597 (map (fn (lib : libspec, result) =>
Chris@1808 2598 case result of
Chris@1808 2599 ERROR _ => []
Chris@1808 2600 | OK id => [{ libname = #libname lib,
Chris@1808 2601 id_or_tag = id }])
Chris@1808 2602 outcomes)
Chris@1808 2603 val return_code = return_code_for outcomes
Chris@1808 2604 val _ = print clear_line
Chris@1808 2605 in
Chris@1808 2606 if OS.Process.isSuccess return_code
Chris@1808 2607 then save_lock_file (#rootpath context) locks
Chris@1808 2608 else ();
Chris@1808 2609 return_code
Chris@1808 2610 end
Chris@1808 2611
Chris@1808 2612 fun update_project (project as { context, libs }) =
Chris@1808 2613 let val outcomes = act_and_print
Chris@1808 2614 (AnyLibControl.update context)
Chris@1808 2615 print_outcome_header print_update_outcome
Chris@1808 2616 context libs
Chris@1808 2617 val _ = if List.exists (fn (_, OK _) => true | _ => false) outcomes
Chris@1808 2618 then lock_project project
Chris@1808 2619 else OS.Process.success
Chris@1865 2620 val return_code = return_code_for outcomes
Chris@1808 2621 in
Chris@1865 2622 if OS.Process.isSuccess return_code
Chris@1865 2623 then checkpoint_completion_file (#rootpath context)
Chris@1865 2624 else ();
Chris@1865 2625 return_code
Chris@1808 2626 end
Chris@1808 2627
Chris@1808 2628 fun load_local_project pintype =
Chris@1808 2629 let val userconfig = load_userconfig ()
Chris@1808 2630 val rootpath = OS.FileSys.getDir ()
Chris@1808 2631 in
Chris@1808 2632 load_project userconfig rootpath pintype
Chris@1808 2633 end
Chris@1808 2634
Chris@1808 2635 fun with_local_project pintype f =
Chris@1808 2636 let open OS.Process
Chris@1808 2637 val return_code =
Chris@1808 2638 f (load_local_project pintype)
Chris@1808 2639 handle Fail msg =>
Chris@1808 2640 failure before print ("Error: " ^ msg)
Chris@1808 2641 | JsonBits.Config msg =>
Chris@1808 2642 failure before print ("Error in configuration: " ^ msg)
Chris@1808 2643 | e =>
Chris@1808 2644 failure before print ("Error: " ^ exnMessage e)
Chris@1808 2645 val _ = print "\n";
Chris@1808 2646 in
Chris@1808 2647 return_code
Chris@1808 2648 end
Chris@1808 2649
Chris@1808 2650 fun review () = with_local_project USE_LOCKFILE review_project
Chris@1808 2651 fun status () = with_local_project USE_LOCKFILE status_of_project
Chris@1808 2652 fun update () = with_local_project NO_LOCKFILE update_project
Chris@1808 2653 fun lock () = with_local_project NO_LOCKFILE lock_project
Chris@1808 2654 fun install () = with_local_project USE_LOCKFILE update_project
Chris@1808 2655
Chris@1808 2656 fun version () =
Chris@1808 2657 (print ("v" ^ repoint_version ^ "\n");
Chris@1808 2658 OS.Process.success)
Chris@1808 2659
Chris@1808 2660 fun usage () =
Chris@1808 2661 (print "\nRepoint ";
Chris@1808 2662 version ();
Chris@1823 2663 print ("\n A simple manager for third-party source code dependencies.\n"
Chris@1823 2664 ^ " http://all-day-breakfast.com/repoint/\n\n"
Chris@1808 2665 ^ "Usage:\n\n"
Chris@1865 2666 ^ " repoint <command> [<options>]\n\n"
Chris@1808 2667 ^ "where <command> is one of:\n\n"
Chris@1808 2668 ^ " status print quick report on local status only, without using network\n"
Chris@1808 2669 ^ " review check configured libraries against their providers, and report\n"
Chris@1808 2670 ^ " install update configured libraries according to project specs and lock file\n"
Chris@1808 2671 ^ " update update configured libraries and lock file according to project specs\n"
Chris@1823 2672 ^ " lock rewrite lock file to match local library status\n"
Chris@1823 2673 ^ " archive pack up project and all libraries into an archive file:\n"
Chris@1823 2674 ^ " invoke as 'repoint archive targetfile.tar.gz --exclude unwanted.txt'\n"
Chris@1865 2675 ^ " version print the Repoint version number and exit\n\n"
Chris@1865 2676 ^ "and <options> may include:\n\n"
Chris@1865 2677 ^ " --directory <dir>\n"
Chris@1865 2678 ^ " change to directory <dir> before doing anything; in particular,\n"
Chris@1865 2679 ^ " expect to find project spec file in that directory\n\n");
Chris@1808 2680 OS.Process.failure)
Chris@1808 2681
Chris@1808 2682 fun archive target args =
Chris@1808 2683 case args of
Chris@1808 2684 [] =>
Chris@1808 2685 with_local_project USE_LOCKFILE (Archive.archive (target, []))
Chris@1808 2686 | "--exclude"::xs =>
Chris@1808 2687 with_local_project USE_LOCKFILE (Archive.archive (target, xs))
Chris@1808 2688 | _ => usage ()
Chris@1808 2689
Chris@1865 2690 fun handleSystemArgs args =
Chris@1865 2691 let fun handleSystemArgs' leftover args =
Chris@1865 2692 case args of
Chris@1865 2693 "--directory"::dir::rest =>
Chris@1865 2694 (OS.FileSys.chDir dir;
Chris@1865 2695 handleSystemArgs' leftover rest)
Chris@1865 2696 | arg::rest =>
Chris@1865 2697 handleSystemArgs' (leftover @ [arg]) rest
Chris@1865 2698 | [] => leftover
Chris@1865 2699 in
Chris@1865 2700 OK (handleSystemArgs' [] args)
Chris@1865 2701 handle e => ERROR (exnMessage e)
Chris@1865 2702 end
Chris@1865 2703
Chris@1808 2704 fun repoint args =
Chris@1865 2705 case handleSystemArgs args of
Chris@1865 2706 ERROR e => (print ("Error: " ^ e ^ "\n");
Chris@1865 2707 OS.Process.exit OS.Process.failure)
Chris@1865 2708 | OK args =>
Chris@1865 2709 let val return_code =
Chris@1808 2710 case args of
Chris@1808 2711 ["review"] => review ()
Chris@1808 2712 | ["status"] => status ()
Chris@1808 2713 | ["install"] => install ()
Chris@1808 2714 | ["update"] => update ()
Chris@1808 2715 | ["lock"] => lock ()
Chris@1808 2716 | ["version"] => version ()
Chris@1808 2717 | "archive"::target::args => archive target args
Chris@1808 2718 | arg::_ => (print ("Error: unknown argument \"" ^ arg ^ "\"\n");
Chris@1808 2719 usage ())
Chris@1808 2720 | _ => usage ()
Chris@1865 2721 in
Chris@1865 2722 OS.Process.exit return_code
Chris@1865 2723 end
Chris@1808 2724
Chris@1808 2725 fun main () =
Chris@1808 2726 repoint (CommandLine.arguments ())