annotate repoint.sml @ 395:dec56c3e793b

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