annotate vext.sml @ 317:c3a3edc6c2f0

Update Vext
author Chris Cannam
date Tue, 02 Jan 2018 10:56:52 +0000
parents 9ebb9ac79bdf
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@315 4 source files in the Vext repository.
Chris@315 5 *)
Chris@303 6
Chris@303 7 (*
Chris@303 8 Vext
Chris@303 9
Chris@303 10 A simple manager for third-party source code dependencies
Chris@303 11
Chris@315 12 Copyright 2017 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@317 41 val vext_version = "0.9.92"
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@303 136 structure VextFilenames = struct
Chris@303 137 val project_file = "vext-project.json"
Chris@303 138 val project_lock_file = "vext-lock.json"
Chris@303 139 val user_config_file = ".vext.json"
Chris@315 140 val archive_dir = ".vext-archive"
Chris@303 141 end
Chris@303 142
Chris@303 143 signature VCS_CONTROL = sig
Chris@303 144
Chris@303 145 (** Test whether the library is present locally at all *)
Chris@303 146 val exists : context -> libname -> bool result
Chris@303 147
Chris@303 148 (** Return the id (hash) of the current revision for the library *)
Chris@303 149 val id_of : context -> libname -> id_or_tag result
Chris@303 150
Chris@303 151 (** Test whether the library is at the given id *)
Chris@303 152 val is_at : context -> libname * id_or_tag -> bool result
Chris@303 153
Chris@303 154 (** Test whether the library is on the given branch, i.e. is at
Chris@303 155 the branch tip or an ancestor of it *)
Chris@303 156 val is_on_branch : context -> libname * branch -> bool result
Chris@303 157
Chris@303 158 (** Test whether the library is at the newest revision for the
Chris@303 159 given branch. False may indicate that the branch has advanced
Chris@303 160 or that the library is not on the branch at all. This function
Chris@303 161 may use the network to check for new revisions *)
Chris@317 162 val is_newest : context -> libname * source * branch -> bool result
Chris@303 163
Chris@303 164 (** Test whether the library is at the newest revision available
Chris@303 165 locally for the given branch. False may indicate that the
Chris@303 166 branch has advanced or that the library is not on the branch
Chris@303 167 at all. This function must not use the network *)
Chris@303 168 val is_newest_locally : context -> libname * branch -> bool result
Chris@303 169
Chris@303 170 (** Test whether the library has been modified in the local
Chris@303 171 working copy *)
Chris@303 172 val is_modified_locally : context -> libname -> bool result
Chris@303 173
Chris@303 174 (** Check out, i.e. clone a fresh copy of, the repo for the given
Chris@303 175 library on the given branch *)
Chris@303 176 val checkout : context -> libname * source * branch -> unit result
Chris@303 177
Chris@317 178 (** Update the library to the given branch tip. Assumes that a
Chris@317 179 local copy of the library already exists *)
Chris@317 180 val update : context -> libname * source * branch -> unit result
Chris@303 181
Chris@303 182 (** Update the library to the given specific id or tag *)
Chris@317 183 val update_to : context -> libname * source * id_or_tag -> unit result
Chris@317 184
Chris@317 185 (** Return a URL from which the library can be cloned, given that
Chris@317 186 the local copy already exists. For a DVCS this can be the
Chris@317 187 local copy, but for a centralised VCS it will have to be the
Chris@317 188 remote repository URL. Used for archiving *)
Chris@317 189 val copy_url_for : context -> libname -> string result
Chris@303 190 end
Chris@303 191
Chris@303 192 signature LIB_CONTROL = sig
Chris@303 193 val review : context -> libspec -> (libstate * localstate) result
Chris@303 194 val status : context -> libspec -> (libstate * localstate) result
Chris@317 195 val update : context -> libspec -> unit result
Chris@314 196 val id_of : context -> libspec -> id_or_tag result
Chris@303 197 end
Chris@303 198
Chris@303 199 structure FileBits :> sig
Chris@303 200 val extpath : context -> string
Chris@303 201 val libpath : context -> libname -> string
Chris@303 202 val subpath : context -> libname -> string -> string
Chris@303 203 val command_output : context -> libname -> string list -> string result
Chris@303 204 val command : context -> libname -> string list -> unit result
Chris@317 205 val file_url : string -> string
Chris@303 206 val file_contents : string -> string
Chris@303 207 val mydir : unit -> string
Chris@303 208 val homedir : unit -> string
Chris@303 209 val mkpath : string -> unit result
Chris@315 210 val rmpath : string -> unit result
Chris@317 211 val nonempty_dir_exists : string -> bool
Chris@303 212 val project_spec_path : string -> string
Chris@303 213 val project_lock_path : string -> string
Chris@303 214 val verbose : unit -> bool
Chris@303 215 end = struct
Chris@303 216
Chris@303 217 fun verbose () =
Chris@303 218 case OS.Process.getEnv "VEXT_VERBOSE" of
Chris@303 219 SOME "0" => false
Chris@303 220 | SOME _ => true
Chris@303 221 | NONE => false
Chris@303 222
Chris@317 223 fun split_relative path desc =
Chris@317 224 case OS.Path.fromString path of
Chris@317 225 { isAbs = true, ... } => raise Fail (desc ^ " may not be absolute")
Chris@317 226 | { arcs, ... } => arcs
Chris@317 227
Chris@303 228 fun extpath ({ rootpath, extdir, ... } : context) =
Chris@303 229 let val { isAbs, vol, arcs } = OS.Path.fromString rootpath
Chris@303 230 in OS.Path.toString {
Chris@303 231 isAbs = isAbs,
Chris@303 232 vol = vol,
Chris@317 233 arcs = arcs @
Chris@317 234 split_relative extdir "extdir"
Chris@303 235 }
Chris@303 236 end
Chris@303 237
Chris@303 238 fun subpath ({ rootpath, extdir, ... } : context) libname remainder =
Chris@303 239 (* NB libname is allowed to be a path fragment, e.g. foo/bar *)
Chris@303 240 let val { isAbs, vol, arcs } = OS.Path.fromString rootpath
Chris@303 241 in OS.Path.toString {
Chris@303 242 isAbs = isAbs,
Chris@303 243 vol = vol,
Chris@317 244 arcs = arcs @
Chris@317 245 split_relative extdir "extdir" @
Chris@317 246 split_relative libname "library path" @
Chris@317 247 split_relative remainder "subpath"
Chris@303 248 }
Chris@303 249 end
Chris@303 250
Chris@303 251 fun libpath context "" =
Chris@303 252 extpath context
Chris@303 253 | libpath context libname =
Chris@303 254 subpath context libname ""
Chris@303 255
Chris@303 256 fun project_file_path rootpath filename =
Chris@303 257 let val { isAbs, vol, arcs } = OS.Path.fromString rootpath
Chris@303 258 in OS.Path.toString {
Chris@303 259 isAbs = isAbs,
Chris@303 260 vol = vol,
Chris@303 261 arcs = arcs @ [ filename ]
Chris@303 262 }
Chris@303 263 end
Chris@303 264
Chris@303 265 fun project_spec_path rootpath =
Chris@303 266 project_file_path rootpath (VextFilenames.project_file)
Chris@303 267
Chris@303 268 fun project_lock_path rootpath =
Chris@303 269 project_file_path rootpath (VextFilenames.project_lock_file)
Chris@303 270
Chris@303 271 fun trim str =
Chris@303 272 hd (String.fields (fn x => x = #"\n" orelse x = #"\r") str)
Chris@317 273
Chris@317 274 fun file_url path =
Chris@317 275 let val forward_path =
Chris@317 276 String.translate (fn #"\\" => "/" |
Chris@317 277 c => Char.toString c)
Chris@317 278 (OS.Path.mkCanonical path)
Chris@317 279 in
Chris@317 280 (* Path is expected to be absolute already, but if it
Chris@317 281 starts with a drive letter, we'll need an extra slash *)
Chris@317 282 case explode forward_path of
Chris@317 283 #"/"::rest => "file:///" ^ implode rest
Chris@317 284 | _ => "file:///" ^ forward_path
Chris@317 285 end
Chris@303 286
Chris@303 287 fun file_contents filename =
Chris@303 288 let val stream = TextIO.openIn filename
Chris@303 289 fun read_all str acc =
Chris@303 290 case TextIO.inputLine str of
Chris@303 291 SOME line => read_all str (trim line :: acc)
Chris@303 292 | NONE => rev acc
Chris@303 293 val contents = read_all stream []
Chris@303 294 val _ = TextIO.closeIn stream
Chris@303 295 in
Chris@303 296 String.concatWith "\n" contents
Chris@303 297 end
Chris@303 298
Chris@303 299 fun expand_commandline cmdlist =
Chris@303 300 (* We are quite [too] strict about what we accept here, except
Chris@303 301 for the first element in cmdlist which is assumed to be a
Chris@303 302 known command location rather than arbitrary user input. NB
Chris@303 303 only ASCII accepted at this point. *)
Chris@303 304 let open Char
Chris@303 305 fun quote arg =
Chris@303 306 if List.all
Chris@303 307 (fn c => isAlphaNum c orelse c = #"-" orelse c = #"_")
Chris@303 308 (explode arg)
Chris@303 309 then arg
Chris@303 310 else "\"" ^ arg ^ "\""
Chris@303 311 fun check arg =
Chris@303 312 let val valid = explode " /#:;?,._-{}@="
Chris@303 313 in
Chris@303 314 app (fn c =>
Chris@303 315 if isAlphaNum c orelse
Chris@303 316 List.exists (fn v => v = c) valid
Chris@303 317 then ()
Chris@303 318 else raise Fail ("Invalid character '" ^
Chris@303 319 (Char.toString c) ^
Chris@303 320 "' in command list"))
Chris@303 321 (explode arg);
Chris@303 322 arg
Chris@303 323 end
Chris@303 324 in
Chris@303 325 String.concatWith " "
Chris@303 326 (map quote
Chris@303 327 (hd cmdlist :: map check (tl cmdlist)))
Chris@303 328 end
Chris@303 329
Chris@303 330 val tick_cycle = ref 0
Chris@303 331 val tick_chars = Vector.fromList (map String.str (explode "|/-\\"))
Chris@303 332
Chris@303 333 fun tick libname cmdlist =
Chris@303 334 let val n = Vector.length tick_chars
Chris@303 335 fun pad_to n str =
Chris@303 336 if n <= String.size str then str
Chris@303 337 else pad_to n (str ^ " ")
Chris@303 338 val name = if libname <> "" then libname
Chris@303 339 else if cmdlist = nil then ""
Chris@303 340 else hd (rev cmdlist)
Chris@303 341 in
Chris@303 342 print (" " ^
Chris@303 343 Vector.sub(tick_chars, !tick_cycle) ^ " " ^
Chris@303 344 pad_to 24 name ^
Chris@303 345 "\r");
Chris@303 346 tick_cycle := (if !tick_cycle = n - 1 then 0 else 1 + !tick_cycle)
Chris@303 347 end
Chris@303 348
Chris@303 349 fun run_command context libname cmdlist redirect =
Chris@303 350 let open OS
Chris@303 351 val dir = libpath context libname
Chris@303 352 val cmd = expand_commandline cmdlist
Chris@303 353 val _ = if verbose ()
Chris@303 354 then print ("Running: " ^ cmd ^
Chris@303 355 " (in dir " ^ dir ^ ")...\n")
Chris@303 356 else tick libname cmdlist
Chris@303 357 val _ = FileSys.chDir dir
Chris@303 358 val status = case redirect of
Chris@303 359 NONE => Process.system cmd
Chris@303 360 | SOME file => Process.system (cmd ^ ">" ^ file)
Chris@303 361 in
Chris@303 362 if Process.isSuccess status
Chris@303 363 then OK ()
Chris@303 364 else ERROR ("Command failed: " ^ cmd ^ " (in dir " ^ dir ^ ")")
Chris@303 365 end
Chris@303 366 handle ex => ERROR ("Unable to run command: " ^ exnMessage ex)
Chris@303 367
Chris@303 368 fun command context libname cmdlist =
Chris@303 369 run_command context libname cmdlist NONE
Chris@303 370
Chris@303 371 fun command_output context libname cmdlist =
Chris@303 372 let open OS
Chris@303 373 val tmpFile = FileSys.tmpName ()
Chris@303 374 val result = run_command context libname cmdlist (SOME tmpFile)
Chris@303 375 val contents = file_contents tmpFile
Chris@317 376 val _ = if verbose ()
Chris@317 377 then print ("Output was:\n\"" ^ contents ^ "\"\n")
Chris@317 378 else ()
Chris@303 379 in
Chris@303 380 FileSys.remove tmpFile handle _ => ();
Chris@303 381 case result of
Chris@303 382 OK () => OK contents
Chris@303 383 | ERROR e => ERROR e
Chris@303 384 end
Chris@303 385
Chris@303 386 fun mydir () =
Chris@303 387 let open OS
Chris@303 388 val { dir, file } = Path.splitDirFile (CommandLine.name ())
Chris@303 389 in
Chris@303 390 FileSys.realPath
Chris@303 391 (if Path.isAbsolute dir
Chris@303 392 then dir
Chris@303 393 else Path.concat (FileSys.getDir (), dir))
Chris@303 394 end
Chris@303 395
Chris@303 396 fun homedir () =
Chris@303 397 (* Failure is not routine, so we use an exception here *)
Chris@303 398 case (OS.Process.getEnv "HOME",
Chris@303 399 OS.Process.getEnv "HOMEPATH") of
Chris@303 400 (SOME home, _) => home
Chris@303 401 | (NONE, SOME home) => home
Chris@303 402 | (NONE, NONE) =>
Chris@303 403 raise Fail "Failed to look up home directory from environment"
Chris@303 404
Chris@317 405 fun mkpath' path =
Chris@303 406 if OS.FileSys.isDir path handle _ => false
Chris@303 407 then OK ()
Chris@303 408 else case OS.Path.fromString path of
Chris@303 409 { arcs = nil, ... } => OK ()
Chris@303 410 | { isAbs = false, ... } => ERROR "mkpath requires absolute path"
Chris@303 411 | { isAbs, vol, arcs } =>
Chris@317 412 case mkpath' (OS.Path.toString { (* parent *)
Chris@317 413 isAbs = isAbs,
Chris@317 414 vol = vol,
Chris@317 415 arcs = rev (tl (rev arcs)) }) of
Chris@303 416 ERROR e => ERROR e
Chris@303 417 | OK () => ((OS.FileSys.mkDir path; OK ())
Chris@303 418 handle OS.SysErr (e, _) =>
Chris@303 419 ERROR ("Directory creation failed: " ^ e))
Chris@315 420
Chris@317 421 fun mkpath path =
Chris@317 422 mkpath' (OS.Path.mkCanonical path)
Chris@317 423
Chris@317 424 fun dir_contents dir =
Chris@315 425 let open OS
Chris@315 426 fun files_from dirstream =
Chris@315 427 case FileSys.readDir dirstream of
Chris@315 428 NONE => []
Chris@315 429 | SOME file =>
Chris@315 430 (* readDir is supposed to filter these,
Chris@315 431 but let's be extra cautious: *)
Chris@315 432 if file = Path.parentArc orelse file = Path.currentArc
Chris@315 433 then files_from dirstream
Chris@315 434 else file :: files_from dirstream
Chris@317 435 val stream = FileSys.openDir dir
Chris@317 436 val files = map (fn f => Path.joinDirFile
Chris@317 437 { dir = dir, file = f })
Chris@317 438 (files_from stream)
Chris@317 439 val _ = FileSys.closeDir stream
Chris@317 440 in
Chris@317 441 files
Chris@317 442 end
Chris@317 443
Chris@317 444 fun rmpath' path =
Chris@317 445 let open OS
Chris@315 446 fun remove path =
Chris@315 447 if FileSys.isLink path (* dangling links bother isDir *)
Chris@315 448 then FileSys.remove path
Chris@315 449 else if FileSys.isDir path
Chris@317 450 then (app remove (dir_contents path); FileSys.rmDir path)
Chris@315 451 else FileSys.remove path
Chris@315 452 in
Chris@315 453 (remove path; OK ())
Chris@315 454 handle SysErr (e, _) => ERROR ("Path removal failed: " ^ e)
Chris@315 455 end
Chris@317 456
Chris@317 457 fun rmpath path =
Chris@317 458 rmpath' (OS.Path.mkCanonical path)
Chris@317 459
Chris@317 460 fun nonempty_dir_exists path =
Chris@317 461 let open OS.FileSys
Chris@317 462 in
Chris@317 463 (not (isLink path) andalso
Chris@317 464 isDir path andalso
Chris@317 465 dir_contents path <> [])
Chris@317 466 handle _ => false
Chris@317 467 end
Chris@317 468
Chris@303 469 end
Chris@303 470
Chris@303 471 functor LibControlFn (V: VCS_CONTROL) :> LIB_CONTROL = struct
Chris@303 472
Chris@303 473 (* Valid states for unpinned libraries:
Chris@303 474
Chris@303 475 - CORRECT: We are on the right branch and are up-to-date with
Chris@303 476 it as far as we can tell. (If not using the network, this
Chris@303 477 should be reported to user as "Present" rather than "Correct"
Chris@303 478 as the remote repo may have advanced without us knowing.)
Chris@303 479
Chris@303 480 - SUPERSEDED: We are on the right branch but we can see that
Chris@303 481 there is a newer revision either locally or on the remote (in
Chris@303 482 Git terms, we are at an ancestor of the desired branch tip).
Chris@303 483
Chris@303 484 - WRONG: We are on the wrong branch (in Git terms, we are not
Chris@303 485 at the desired branch tip or any ancestor of it).
Chris@303 486
Chris@303 487 - ABSENT: Repo doesn't exist here at all.
Chris@303 488
Chris@303 489 Valid states for pinned libraries:
Chris@303 490
Chris@303 491 - CORRECT: We are at the pinned revision.
Chris@303 492
Chris@303 493 - WRONG: We are at any revision other than the pinned one.
Chris@303 494
Chris@303 495 - ABSENT: Repo doesn't exist here at all.
Chris@303 496 *)
Chris@303 497
Chris@314 498 fun check with_network context
Chris@317 499 ({ libname, source, branch,
Chris@317 500 project_pin, lock_pin, ... } : libspec) =
Chris@303 501 let fun check_unpinned () =
Chris@317 502 let val newest =
Chris@317 503 if with_network
Chris@317 504 then V.is_newest context (libname, source, branch)
Chris@317 505 else V.is_newest_locally context (libname, branch)
Chris@303 506 in
Chris@317 507 case newest of
Chris@303 508 ERROR e => ERROR e
Chris@303 509 | OK true => OK CORRECT
Chris@303 510 | OK false =>
Chris@303 511 case V.is_on_branch context (libname, branch) of
Chris@303 512 ERROR e => ERROR e
Chris@303 513 | OK true => OK SUPERSEDED
Chris@303 514 | OK false => OK WRONG
Chris@303 515 end
Chris@303 516 fun check_pinned target =
Chris@303 517 case V.is_at context (libname, target) of
Chris@303 518 ERROR e => ERROR e
Chris@303 519 | OK true => OK CORRECT
Chris@303 520 | OK false => OK WRONG
Chris@314 521 fun check_remote () =
Chris@314 522 case project_pin of
Chris@303 523 UNPINNED => check_unpinned ()
Chris@303 524 | PINNED target => check_pinned target
Chris@314 525 fun check_local () =
Chris@314 526 case V.is_modified_locally context libname of
Chris@314 527 ERROR e => ERROR e
Chris@314 528 | OK true => OK MODIFIED
Chris@314 529 | OK false =>
Chris@314 530 case lock_pin of
Chris@314 531 UNPINNED => OK CLEAN
Chris@314 532 | PINNED target =>
Chris@314 533 case V.is_at context (libname, target) of
Chris@314 534 ERROR e => ERROR e
Chris@314 535 | OK true => OK CLEAN
Chris@314 536 | OK false => OK LOCK_MISMATCHED
Chris@303 537 in
Chris@303 538 case V.exists context libname of
Chris@303 539 ERROR e => ERROR e
Chris@314 540 | OK false => OK (ABSENT, CLEAN)
Chris@303 541 | OK true =>
Chris@314 542 case (check_remote (), check_local ()) of
Chris@303 543 (ERROR e, _) => ERROR e
Chris@303 544 | (_, ERROR e) => ERROR e
Chris@314 545 | (OK r, OK l) => OK (r, l)
Chris@303 546 end
Chris@303 547
Chris@303 548 val review = check true
Chris@303 549 val status = check false
Chris@314 550
Chris@314 551 fun update context
Chris@314 552 ({ libname, source, branch,
Chris@314 553 project_pin, lock_pin, ... } : libspec) =
Chris@303 554 let fun update_unpinned () =
Chris@317 555 case V.is_newest context (libname, source, branch) of
Chris@303 556 ERROR e => ERROR e
Chris@317 557 | OK true => OK ()
Chris@317 558 | OK false => V.update context (libname, source, branch)
Chris@303 559 fun update_pinned target =
Chris@303 560 case V.is_at context (libname, target) of
Chris@303 561 ERROR e => ERROR e
Chris@317 562 | OK true => OK ()
Chris@317 563 | OK false => V.update_to context (libname, source, target)
Chris@303 564 fun update' () =
Chris@314 565 case lock_pin of
Chris@314 566 PINNED target => update_pinned target
Chris@314 567 | UNPINNED =>
Chris@314 568 case project_pin of
Chris@314 569 PINNED target => update_pinned target
Chris@314 570 | UNPINNED => update_unpinned ()
Chris@303 571 in
Chris@303 572 case V.exists context libname of
Chris@303 573 ERROR e => ERROR e
Chris@303 574 | OK true => update' ()
Chris@303 575 | OK false =>
Chris@303 576 case V.checkout context (libname, source, branch) of
Chris@303 577 ERROR e => ERROR e
Chris@303 578 | OK () => update' ()
Chris@303 579 end
Chris@314 580
Chris@314 581 fun id_of context ({ libname, ... } : libspec) =
Chris@314 582 V.id_of context libname
Chris@314 583
Chris@303 584 end
Chris@303 585
Chris@303 586 (* Simple Standard ML JSON parser
Chris@303 587 ==============================
Chris@303 588
Chris@303 589 https://bitbucket.org/cannam/sml-simplejson
Chris@303 590
Chris@303 591 An RFC-compliant JSON parser in one SML file with no dependency
Chris@303 592 on anything outside the Basis library. Also includes a simple
Chris@303 593 serialiser.
Chris@303 594
Chris@303 595 Tested with MLton, Poly/ML, and SML/NJ compilers.
Chris@303 596
Chris@303 597 Parser notes:
Chris@303 598
Chris@303 599 * Complies with RFC 7159, The JavaScript Object Notation (JSON)
Chris@303 600 Data Interchange Format
Chris@303 601
Chris@303 602 * Passes all of the JSONTestSuite parser accept/reject tests that
Chris@303 603 exist at the time of writing, as listed in "Parsing JSON is a
Chris@303 604 Minefield" (http://seriot.ch/parsing_json.php)
Chris@303 605
Chris@303 606 * Two-pass parser using naive exploded strings, therefore not
Chris@303 607 particularly fast and not suitable for large input files
Chris@303 608
Chris@303 609 * Only supports UTF-8 input, not UTF-16 or UTF-32. Doesn't check
Chris@303 610 that JSON strings are valid UTF-8 -- the caller must do that --
Chris@303 611 but does handle \u escapes
Chris@303 612
Chris@303 613 * Converts all numbers to type "real". If that is a 64-bit IEEE
Chris@303 614 float type (common but not guaranteed in SML) then we're pretty
Chris@303 615 standard for a JSON parser
Chris@303 616
Chris@303 617 Copyright 2017 Chris Cannam.
Chris@303 618 Parts based on the JSON parser in the Ponyo library by Phil Eaton.
Chris@303 619
Chris@303 620 Permission is hereby granted, free of charge, to any person
Chris@303 621 obtaining a copy of this software and associated documentation
Chris@303 622 files (the "Software"), to deal in the Software without
Chris@303 623 restriction, including without limitation the rights to use, copy,
Chris@303 624 modify, merge, publish, distribute, sublicense, and/or sell copies
Chris@303 625 of the Software, and to permit persons to whom the Software is
Chris@303 626 furnished to do so, subject to the following conditions:
Chris@303 627
Chris@303 628 The above copyright notice and this permission notice shall be
Chris@303 629 included in all copies or substantial portions of the Software.
Chris@303 630
Chris@303 631 THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
Chris@303 632 EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
Chris@303 633 MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
Chris@303 634 NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR
Chris@303 635 ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF
Chris@303 636 CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
Chris@303 637 WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
Chris@303 638
Chris@303 639 Except as contained in this notice, the names of Chris Cannam and
Chris@303 640 Particular Programs Ltd shall not be used in advertising or
Chris@303 641 otherwise to promote the sale, use or other dealings in this
Chris@303 642 Software without prior written authorization.
Chris@303 643 *)
Chris@303 644
Chris@303 645 signature JSON = sig
Chris@303 646
Chris@303 647 datatype json = OBJECT of (string * json) list
Chris@303 648 | ARRAY of json list
Chris@303 649 | NUMBER of real
Chris@303 650 | STRING of string
Chris@303 651 | BOOL of bool
Chris@303 652 | NULL
Chris@303 653
Chris@303 654 datatype 'a result = OK of 'a
Chris@303 655 | ERROR of string
Chris@303 656
Chris@303 657 val parse : string -> json result
Chris@303 658 val serialise : json -> string
Chris@303 659 val serialiseIndented : json -> string
Chris@303 660
Chris@303 661 end
Chris@303 662
Chris@303 663 structure Json :> JSON = struct
Chris@303 664
Chris@303 665 datatype json = OBJECT of (string * json) list
Chris@303 666 | ARRAY of json list
Chris@303 667 | NUMBER of real
Chris@303 668 | STRING of string
Chris@303 669 | BOOL of bool
Chris@303 670 | NULL
Chris@303 671
Chris@303 672 datatype 'a result = OK of 'a
Chris@303 673 | ERROR of string
Chris@303 674
Chris@303 675 structure T = struct
Chris@303 676 datatype token = NUMBER of char list
Chris@303 677 | STRING of string
Chris@303 678 | BOOL of bool
Chris@303 679 | NULL
Chris@303 680 | CURLY_L
Chris@303 681 | CURLY_R
Chris@303 682 | SQUARE_L
Chris@303 683 | SQUARE_R
Chris@303 684 | COLON
Chris@303 685 | COMMA
Chris@303 686
Chris@303 687 fun toString t =
Chris@303 688 case t of NUMBER digits => implode digits
Chris@303 689 | STRING s => s
Chris@303 690 | BOOL b => Bool.toString b
Chris@303 691 | NULL => "null"
Chris@303 692 | CURLY_L => "{"
Chris@303 693 | CURLY_R => "}"
Chris@303 694 | SQUARE_L => "["
Chris@303 695 | SQUARE_R => "]"
Chris@303 696 | COLON => ":"
Chris@303 697 | COMMA => ","
Chris@303 698 end
Chris@303 699
Chris@303 700 fun bmpToUtf8 cp = (* convert a codepoint in Unicode BMP to utf8 bytes *)
Chris@303 701 let open Word
Chris@303 702 infix 6 orb andb >>
Chris@303 703 in
Chris@303 704 map (Char.chr o toInt)
Chris@303 705 (if cp < 0wx80 then
Chris@303 706 [cp]
Chris@303 707 else if cp < 0wx800 then
Chris@303 708 [0wxc0 orb (cp >> 0w6), 0wx80 orb (cp andb 0wx3f)]
Chris@303 709 else if cp < 0wx10000 then
Chris@303 710 [0wxe0 orb (cp >> 0w12),
Chris@303 711 0wx80 orb ((cp >> 0w6) andb 0wx3f),
Chris@303 712 0wx80 orb (cp andb 0wx3f)]
Chris@303 713 else raise Fail ("Invalid BMP point " ^ (Word.toString cp)))
Chris@303 714 end
Chris@303 715
Chris@303 716 fun error pos text = ERROR (text ^ " at character position " ^
Chris@303 717 Int.toString (pos - 1))
Chris@303 718 fun token_error pos = error pos ("Unexpected token")
Chris@303 719
Chris@303 720 fun lexNull pos acc (#"u" :: #"l" :: #"l" :: xs) =
Chris@303 721 lex (pos + 3) (T.NULL :: acc) xs
Chris@303 722 | lexNull pos acc _ = token_error pos
Chris@303 723
Chris@303 724 and lexTrue pos acc (#"r" :: #"u" :: #"e" :: xs) =
Chris@303 725 lex (pos + 3) (T.BOOL true :: acc) xs
Chris@303 726 | lexTrue pos acc _ = token_error pos
Chris@303 727
Chris@303 728 and lexFalse pos acc (#"a" :: #"l" :: #"s" :: #"e" :: xs) =
Chris@303 729 lex (pos + 4) (T.BOOL false :: acc) xs
Chris@303 730 | lexFalse pos acc _ = token_error pos
Chris@303 731
Chris@303 732 and lexChar tok pos acc xs =
Chris@303 733 lex pos (tok :: acc) xs
Chris@303 734
Chris@303 735 and lexString pos acc cc =
Chris@303 736 let datatype escaped = ESCAPED | NORMAL
Chris@303 737 fun lexString' pos text ESCAPED [] =
Chris@303 738 error pos "End of input during escape sequence"
Chris@303 739 | lexString' pos text NORMAL [] =
Chris@303 740 error pos "End of input during string"
Chris@303 741 | lexString' pos text ESCAPED (x :: xs) =
Chris@303 742 let fun esc c = lexString' (pos + 1) (c :: text) NORMAL xs
Chris@303 743 in case x of
Chris@303 744 #"\"" => esc x
Chris@303 745 | #"\\" => esc x
Chris@303 746 | #"/" => esc x
Chris@303 747 | #"b" => esc #"\b"
Chris@303 748 | #"f" => esc #"\f"
Chris@303 749 | #"n" => esc #"\n"
Chris@303 750 | #"r" => esc #"\r"
Chris@303 751 | #"t" => esc #"\t"
Chris@303 752 | _ => error pos ("Invalid escape \\" ^
Chris@303 753 Char.toString x)
Chris@303 754 end
Chris@303 755 | lexString' pos text NORMAL (#"\\" :: #"u" ::a::b::c::d:: xs) =
Chris@303 756 if List.all Char.isHexDigit [a,b,c,d]
Chris@303 757 then case Word.fromString ("0wx" ^ (implode [a,b,c,d])) of
Chris@303 758 SOME w => (let val utf = rev (bmpToUtf8 w) in
Chris@303 759 lexString' (pos + 6) (utf @ text)
Chris@303 760 NORMAL xs
Chris@303 761 end
Chris@303 762 handle Fail err => error pos err)
Chris@303 763 | NONE => error pos "Invalid Unicode BMP escape sequence"
Chris@303 764 else error pos "Invalid Unicode BMP escape sequence"
Chris@303 765 | lexString' pos text NORMAL (x :: xs) =
Chris@303 766 if Char.ord x < 0x20
Chris@303 767 then error pos "Invalid unescaped control character"
Chris@303 768 else
Chris@303 769 case x of
Chris@303 770 #"\"" => OK (rev text, xs, pos + 1)
Chris@303 771 | #"\\" => lexString' (pos + 1) text ESCAPED xs
Chris@303 772 | _ => lexString' (pos + 1) (x :: text) NORMAL xs
Chris@303 773 in
Chris@303 774 case lexString' pos [] NORMAL cc of
Chris@303 775 OK (text, rest, newpos) =>
Chris@303 776 lex newpos (T.STRING (implode text) :: acc) rest
Chris@303 777 | ERROR e => ERROR e
Chris@303 778 end
Chris@303 779
Chris@303 780 and lexNumber firstChar pos acc cc =
Chris@303 781 let val valid = explode ".+-e"
Chris@303 782 fun lexNumber' pos digits [] = (rev digits, [], pos)
Chris@303 783 | lexNumber' pos digits (x :: xs) =
Chris@303 784 if x = #"E" then lexNumber' (pos + 1) (#"e" :: digits) xs
Chris@303 785 else if Char.isDigit x orelse List.exists (fn c => x = c) valid
Chris@303 786 then lexNumber' (pos + 1) (x :: digits) xs
Chris@303 787 else (rev digits, x :: xs, pos)
Chris@303 788 val (digits, rest, newpos) =
Chris@303 789 lexNumber' (pos - 1) [] (firstChar :: cc)
Chris@303 790 in
Chris@303 791 case digits of
Chris@303 792 [] => token_error pos
Chris@303 793 | _ => lex newpos (T.NUMBER digits :: acc) rest
Chris@303 794 end
Chris@303 795
Chris@303 796 and lex pos acc [] = OK (rev acc)
Chris@303 797 | lex pos acc (x::xs) =
Chris@303 798 (case x of
Chris@303 799 #" " => lex
Chris@303 800 | #"\t" => lex
Chris@303 801 | #"\n" => lex
Chris@303 802 | #"\r" => lex
Chris@303 803 | #"{" => lexChar T.CURLY_L
Chris@303 804 | #"}" => lexChar T.CURLY_R
Chris@303 805 | #"[" => lexChar T.SQUARE_L
Chris@303 806 | #"]" => lexChar T.SQUARE_R
Chris@303 807 | #":" => lexChar T.COLON
Chris@303 808 | #"," => lexChar T.COMMA
Chris@303 809 | #"\"" => lexString
Chris@303 810 | #"t" => lexTrue
Chris@303 811 | #"f" => lexFalse
Chris@303 812 | #"n" => lexNull
Chris@303 813 | x => lexNumber x) (pos + 1) acc xs
Chris@303 814
Chris@303 815 fun show [] = "end of input"
Chris@303 816 | show (tok :: _) = T.toString tok
Chris@303 817
Chris@303 818 fun parseNumber digits =
Chris@303 819 (* Note lexNumber already case-insensitised the E for us *)
Chris@303 820 let open Char
Chris@303 821
Chris@303 822 fun okExpDigits [] = false
Chris@303 823 | okExpDigits (c :: []) = isDigit c
Chris@303 824 | okExpDigits (c :: cs) = isDigit c andalso okExpDigits cs
Chris@303 825
Chris@303 826 fun okExponent [] = false
Chris@303 827 | okExponent (#"+" :: cs) = okExpDigits cs
Chris@303 828 | okExponent (#"-" :: cs) = okExpDigits cs
Chris@303 829 | okExponent cc = okExpDigits cc
Chris@303 830
Chris@303 831 fun okFracTrailing [] = true
Chris@303 832 | okFracTrailing (c :: cs) =
Chris@303 833 (isDigit c andalso okFracTrailing cs) orelse
Chris@303 834 (c = #"e" andalso okExponent cs)
Chris@303 835
Chris@303 836 fun okFraction [] = false
Chris@303 837 | okFraction (c :: cs) =
Chris@303 838 isDigit c andalso okFracTrailing cs
Chris@303 839
Chris@303 840 fun okPosTrailing [] = true
Chris@303 841 | okPosTrailing (#"." :: cs) = okFraction cs
Chris@303 842 | okPosTrailing (#"e" :: cs) = okExponent cs
Chris@303 843 | okPosTrailing (c :: cs) =
Chris@303 844 isDigit c andalso okPosTrailing cs
Chris@303 845
Chris@303 846 fun okPositive [] = false
Chris@303 847 | okPositive (#"0" :: []) = true
Chris@303 848 | okPositive (#"0" :: #"." :: cs) = okFraction cs
Chris@303 849 | okPositive (#"0" :: #"e" :: cs) = okExponent cs
Chris@303 850 | okPositive (#"0" :: cs) = false
Chris@303 851 | okPositive (c :: cs) = isDigit c andalso okPosTrailing cs
Chris@303 852
Chris@303 853 fun okNumber (#"-" :: cs) = okPositive cs
Chris@303 854 | okNumber cc = okPositive cc
Chris@303 855 in
Chris@303 856 if okNumber digits
Chris@303 857 then case Real.fromString (implode digits) of
Chris@303 858 NONE => ERROR "Number out of range"
Chris@303 859 | SOME r => OK r
Chris@303 860 else ERROR ("Invalid number \"" ^ (implode digits) ^ "\"")
Chris@303 861 end
Chris@303 862
Chris@303 863 fun parseObject (T.CURLY_R :: xs) = OK (OBJECT [], xs)
Chris@303 864 | parseObject tokens =
Chris@303 865 let fun parsePair (T.STRING key :: T.COLON :: xs) =
Chris@303 866 (case parseTokens xs of
Chris@303 867 ERROR e => ERROR e
Chris@303 868 | OK (j, xs) => OK ((key, j), xs))
Chris@303 869 | parsePair other =
Chris@303 870 ERROR ("Object key/value pair expected around \"" ^
Chris@303 871 show other ^ "\"")
Chris@303 872 fun parseObject' acc [] = ERROR "End of input during object"
Chris@303 873 | parseObject' acc tokens =
Chris@303 874 case parsePair tokens of
Chris@303 875 ERROR e => ERROR e
Chris@303 876 | OK (pair, T.COMMA :: xs) =>
Chris@303 877 parseObject' (pair :: acc) xs
Chris@303 878 | OK (pair, T.CURLY_R :: xs) =>
Chris@303 879 OK (OBJECT (rev (pair :: acc)), xs)
Chris@303 880 | OK (_, _) => ERROR "Expected , or } after object element"
Chris@303 881 in
Chris@303 882 parseObject' [] tokens
Chris@303 883 end
Chris@303 884
Chris@303 885 and parseArray (T.SQUARE_R :: xs) = OK (ARRAY [], xs)
Chris@303 886 | parseArray tokens =
Chris@303 887 let fun parseArray' acc [] = ERROR "End of input during array"
Chris@303 888 | parseArray' acc tokens =
Chris@303 889 case parseTokens tokens of
Chris@303 890 ERROR e => ERROR e
Chris@303 891 | OK (j, T.COMMA :: xs) => parseArray' (j :: acc) xs
Chris@303 892 | OK (j, T.SQUARE_R :: xs) => OK (ARRAY (rev (j :: acc)), xs)
Chris@303 893 | OK (_, _) => ERROR "Expected , or ] after array element"
Chris@303 894 in
Chris@303 895 parseArray' [] tokens
Chris@303 896 end
Chris@303 897
Chris@303 898 and parseTokens [] = ERROR "Value expected"
Chris@303 899 | parseTokens (tok :: xs) =
Chris@303 900 (case tok of
Chris@303 901 T.NUMBER d => (case parseNumber d of
Chris@303 902 OK r => OK (NUMBER r, xs)
Chris@303 903 | ERROR e => ERROR e)
Chris@303 904 | T.STRING s => OK (STRING s, xs)
Chris@303 905 | T.BOOL b => OK (BOOL b, xs)
Chris@303 906 | T.NULL => OK (NULL, xs)
Chris@303 907 | T.CURLY_L => parseObject xs
Chris@303 908 | T.SQUARE_L => parseArray xs
Chris@303 909 | _ => ERROR ("Unexpected token " ^ T.toString tok ^
Chris@303 910 " before " ^ show xs))
Chris@303 911
Chris@303 912 fun parse str =
Chris@303 913 case lex 1 [] (explode str) of
Chris@303 914 ERROR e => ERROR e
Chris@303 915 | OK tokens => case parseTokens tokens of
Chris@303 916 OK (value, []) => OK value
Chris@303 917 | OK (_, _) => ERROR "Extra data after input"
Chris@303 918 | ERROR e => ERROR e
Chris@303 919
Chris@303 920 fun stringEscape s =
Chris@303 921 let fun esc x = [x, #"\\"]
Chris@303 922 fun escape' acc [] = rev acc
Chris@303 923 | escape' acc (x :: xs) =
Chris@303 924 escape' (case x of
Chris@303 925 #"\"" => esc x @ acc
Chris@303 926 | #"\\" => esc x @ acc
Chris@303 927 | #"\b" => esc #"b" @ acc
Chris@303 928 | #"\f" => esc #"f" @ acc
Chris@303 929 | #"\n" => esc #"n" @ acc
Chris@303 930 | #"\r" => esc #"r" @ acc
Chris@303 931 | #"\t" => esc #"t" @ acc
Chris@303 932 | _ =>
Chris@303 933 let val c = Char.ord x
Chris@303 934 in
Chris@303 935 if c < 0x20
Chris@303 936 then let val hex = Word.toString (Word.fromInt c)
Chris@303 937 in (rev o explode) (if c < 0x10
Chris@303 938 then ("\\u000" ^ hex)
Chris@303 939 else ("\\u00" ^ hex))
Chris@303 940 end @ acc
Chris@303 941 else
Chris@303 942 x :: acc
Chris@303 943 end)
Chris@303 944 xs
Chris@303 945 in
Chris@303 946 implode (escape' [] (explode s))
Chris@303 947 end
Chris@303 948
Chris@303 949 fun serialise json =
Chris@303 950 case json of
Chris@303 951 OBJECT pp => "{" ^ String.concatWith
Chris@303 952 "," (map (fn (key, value) =>
Chris@303 953 serialise (STRING key) ^ ":" ^
Chris@303 954 serialise value) pp) ^
Chris@303 955 "}"
Chris@303 956 | ARRAY arr => "[" ^ String.concatWith "," (map serialise arr) ^ "]"
Chris@303 957 | NUMBER n => implode (map (fn #"~" => #"-" | c => c)
Chris@303 958 (explode (Real.toString n)))
Chris@303 959 | STRING s => "\"" ^ stringEscape s ^ "\""
Chris@303 960 | BOOL b => Bool.toString b
Chris@303 961 | NULL => "null"
Chris@303 962
Chris@303 963 fun serialiseIndented json =
Chris@303 964 let fun indent 0 = ""
Chris@303 965 | indent i = " " ^ indent (i - 1)
Chris@303 966 fun serialiseIndented' i json =
Chris@303 967 let val ser = serialiseIndented' (i + 1)
Chris@303 968 in
Chris@303 969 case json of
Chris@303 970 OBJECT [] => "{}"
Chris@303 971 | ARRAY [] => "[]"
Chris@303 972 | OBJECT pp => "{\n" ^ indent (i + 1) ^
Chris@303 973 String.concatWith
Chris@303 974 (",\n" ^ indent (i + 1))
Chris@303 975 (map (fn (key, value) =>
Chris@303 976 ser (STRING key) ^ ": " ^
Chris@303 977 ser value) pp) ^
Chris@303 978 "\n" ^ indent i ^ "}"
Chris@303 979 | ARRAY arr => "[\n" ^ indent (i + 1) ^
Chris@303 980 String.concatWith
Chris@303 981 (",\n" ^ indent (i + 1))
Chris@303 982 (map ser arr) ^
Chris@303 983 "\n" ^ indent i ^ "]"
Chris@303 984 | other => serialise other
Chris@303 985 end
Chris@303 986 in
Chris@303 987 serialiseIndented' 0 json ^ "\n"
Chris@303 988 end
Chris@303 989
Chris@303 990 end
Chris@303 991
Chris@303 992
Chris@303 993 structure JsonBits :> sig
Chris@303 994 val load_json_from : string -> Json.json (* filename -> json *)
Chris@303 995 val save_json_to : string -> Json.json -> unit
Chris@303 996 val lookup_optional : Json.json -> string list -> Json.json option
Chris@303 997 val lookup_optional_string : Json.json -> string list -> string option
Chris@303 998 val lookup_mandatory : Json.json -> string list -> Json.json
Chris@303 999 val lookup_mandatory_string : Json.json -> string list -> string
Chris@303 1000 end = struct
Chris@303 1001
Chris@303 1002 fun load_json_from filename =
Chris@303 1003 case Json.parse (FileBits.file_contents filename) of
Chris@303 1004 Json.OK json => json
Chris@303 1005 | Json.ERROR e => raise Fail ("Failed to parse file: " ^ e)
Chris@303 1006
Chris@303 1007 fun save_json_to filename json =
Chris@303 1008 (* using binary I/O to avoid ever writing CR/LF line endings *)
Chris@303 1009 let val jstr = Json.serialiseIndented json
Chris@303 1010 val stream = BinIO.openOut filename
Chris@303 1011 in
Chris@303 1012 BinIO.output (stream, Byte.stringToBytes jstr);
Chris@303 1013 BinIO.closeOut stream
Chris@303 1014 end
Chris@303 1015
Chris@303 1016 fun lookup_optional json kk =
Chris@303 1017 let fun lookup key =
Chris@303 1018 case json of
Chris@303 1019 Json.OBJECT kvs =>
Chris@303 1020 (case List.find (fn (k, v) => k = key) kvs of
Chris@303 1021 SOME (k, v) => SOME v
Chris@303 1022 | NONE => NONE)
Chris@303 1023 | _ => raise Fail "Object expected"
Chris@303 1024 in
Chris@303 1025 case kk of
Chris@303 1026 [] => NONE
Chris@303 1027 | key::[] => lookup key
Chris@303 1028 | key::kk => case lookup key of
Chris@303 1029 NONE => NONE
Chris@303 1030 | SOME j => lookup_optional j kk
Chris@303 1031 end
Chris@303 1032
Chris@303 1033 fun lookup_optional_string json kk =
Chris@303 1034 case lookup_optional json kk of
Chris@303 1035 SOME (Json.STRING s) => SOME s
Chris@303 1036 | SOME _ => raise Fail ("Value (if present) must be string: " ^
Chris@303 1037 (String.concatWith " -> " kk))
Chris@303 1038 | NONE => NONE
Chris@303 1039
Chris@303 1040 fun lookup_mandatory json kk =
Chris@303 1041 case lookup_optional json kk of
Chris@303 1042 SOME v => v
Chris@303 1043 | NONE => raise Fail ("Value is mandatory: " ^
Chris@303 1044 (String.concatWith " -> " kk) ^ " in json: " ^
Chris@303 1045 (Json.serialise json))
Chris@303 1046
Chris@303 1047 fun lookup_mandatory_string json kk =
Chris@303 1048 case lookup_optional json kk of
Chris@303 1049 SOME (Json.STRING s) => s
Chris@303 1050 | _ => raise Fail ("Value must be string: " ^
Chris@303 1051 (String.concatWith " -> " kk))
Chris@303 1052 end
Chris@303 1053
Chris@303 1054 structure Provider :> sig
Chris@303 1055 val load_providers : Json.json -> provider list
Chris@303 1056 val load_more_providers : provider list -> Json.json -> provider list
Chris@303 1057 val remote_url : context -> vcs -> source -> libname -> string
Chris@303 1058 end = struct
Chris@303 1059
Chris@303 1060 val known_providers : provider list =
Chris@303 1061 [ {
Chris@303 1062 service = "bitbucket",
Chris@303 1063 supports = [HG, GIT],
Chris@303 1064 remote_spec = {
Chris@303 1065 anon = SOME "https://bitbucket.org/{owner}/{repository}",
Chris@303 1066 auth = SOME "ssh://{vcs}@bitbucket.org/{owner}/{repository}"
Chris@303 1067 }
Chris@303 1068 },
Chris@303 1069 {
Chris@303 1070 service = "github",
Chris@303 1071 supports = [GIT],
Chris@303 1072 remote_spec = {
Chris@303 1073 anon = SOME "https://github.com/{owner}/{repository}",
Chris@303 1074 auth = SOME "ssh://{vcs}@github.com/{owner}/{repository}"
Chris@303 1075 }
Chris@303 1076 }
Chris@303 1077 ]
Chris@303 1078
Chris@303 1079 fun vcs_name vcs =
Chris@317 1080 case vcs of HG => "hg"
Chris@317 1081 | GIT => "git"
Chris@317 1082 | SVN => "svn"
Chris@303 1083
Chris@303 1084 fun vcs_from_name name =
Chris@317 1085 case name of "hg" => HG
Chris@317 1086 | "git" => GIT
Chris@317 1087 | "svn" => SVN
Chris@303 1088 | other => raise Fail ("Unknown vcs name \"" ^ name ^ "\"")
Chris@303 1089
Chris@303 1090 fun load_more_providers previously_loaded json =
Chris@303 1091 let open JsonBits
Chris@303 1092 fun load pjson pname : provider =
Chris@303 1093 {
Chris@303 1094 service = pname,
Chris@303 1095 supports =
Chris@303 1096 case lookup_mandatory pjson ["vcs"] of
Chris@303 1097 Json.ARRAY vv =>
Chris@303 1098 map (fn (Json.STRING v) => vcs_from_name v
Chris@303 1099 | _ => raise Fail "Strings expected in vcs array")
Chris@303 1100 vv
Chris@303 1101 | _ => raise Fail "Array expected for vcs",
Chris@303 1102 remote_spec = {
Chris@303 1103 anon = lookup_optional_string pjson ["anonymous"],
Chris@303 1104 auth = lookup_optional_string pjson ["authenticated"]
Chris@303 1105 }
Chris@303 1106 }
Chris@303 1107 val loaded =
Chris@303 1108 case lookup_optional json ["services"] of
Chris@303 1109 NONE => []
Chris@303 1110 | SOME (Json.OBJECT pl) => map (fn (k, v) => load v k) pl
Chris@303 1111 | _ => raise Fail "Object expected for services in config"
Chris@303 1112 val newly_loaded =
Chris@303 1113 List.filter (fn p => not (List.exists (fn pp => #service p =
Chris@303 1114 #service pp)
Chris@303 1115 previously_loaded))
Chris@303 1116 loaded
Chris@303 1117 in
Chris@303 1118 previously_loaded @ newly_loaded
Chris@303 1119 end
Chris@303 1120
Chris@303 1121 fun load_providers json =
Chris@303 1122 load_more_providers known_providers json
Chris@303 1123
Chris@303 1124 fun expand_spec spec { vcs, service, owner, repo } login =
Chris@303 1125 (* ugly *)
Chris@303 1126 let fun replace str =
Chris@303 1127 case str of
Chris@303 1128 "vcs" => vcs_name vcs
Chris@303 1129 | "service" => service
Chris@303 1130 | "owner" =>
Chris@303 1131 (case owner of
Chris@303 1132 SOME ostr => ostr
Chris@303 1133 | NONE => raise Fail ("Owner not specified for service " ^
Chris@303 1134 service))
Chris@303 1135 | "repository" => repo
Chris@303 1136 | "account" =>
Chris@303 1137 (case login of
Chris@303 1138 SOME acc => acc
Chris@303 1139 | NONE => raise Fail ("Account not given for service " ^
Chris@303 1140 service))
Chris@303 1141 | other => raise Fail ("Unknown variable \"" ^ other ^
Chris@303 1142 "\" in spec for service " ^ service)
Chris@303 1143 fun expand' acc sstr =
Chris@303 1144 case Substring.splitl (fn c => c <> #"{") sstr of
Chris@303 1145 (pfx, sfx) =>
Chris@303 1146 if Substring.isEmpty sfx
Chris@303 1147 then rev (pfx :: acc)
Chris@303 1148 else
Chris@303 1149 case Substring.splitl (fn c => c <> #"}") sfx of
Chris@303 1150 (tok, remainder) =>
Chris@303 1151 if Substring.isEmpty remainder
Chris@303 1152 then rev (tok :: pfx :: acc)
Chris@303 1153 else let val replacement =
Chris@303 1154 replace
Chris@303 1155 (* tok begins with "{": *)
Chris@303 1156 (Substring.string
Chris@303 1157 (Substring.triml 1 tok))
Chris@303 1158 in
Chris@303 1159 expand' (Substring.full replacement ::
Chris@303 1160 pfx :: acc)
Chris@303 1161 (* remainder begins with "}": *)
Chris@303 1162 (Substring.triml 1 remainder)
Chris@303 1163 end
Chris@303 1164 in
Chris@303 1165 Substring.concat (expand' [] (Substring.full spec))
Chris@303 1166 end
Chris@303 1167
Chris@303 1168 fun provider_url req login providers =
Chris@303 1169 case providers of
Chris@303 1170 [] => raise Fail ("Unknown service \"" ^ (#service req) ^
Chris@303 1171 "\" for vcs \"" ^ (vcs_name (#vcs req)) ^ "\"")
Chris@303 1172 | ({ service, supports, remote_spec : remote_spec } :: rest) =>
Chris@303 1173 if service <> (#service req) orelse
Chris@303 1174 not (List.exists (fn v => v = (#vcs req)) supports)
Chris@303 1175 then provider_url req login rest
Chris@303 1176 else
Chris@303 1177 case (login, #auth remote_spec, #anon remote_spec) of
Chris@303 1178 (SOME _, SOME auth, _) => expand_spec auth req login
Chris@303 1179 | (SOME _, _, SOME anon) => expand_spec anon req NONE
Chris@303 1180 | (NONE, _, SOME anon) => expand_spec anon req NONE
Chris@303 1181 | _ => raise Fail ("No suitable anonymous or authenticated " ^
Chris@303 1182 "URL spec provided for service \"" ^
Chris@303 1183 service ^ "\"")
Chris@303 1184
Chris@303 1185 fun login_for ({ accounts, ... } : context) service =
Chris@303 1186 case List.find (fn a => service = #service a) accounts of
Chris@303 1187 SOME { login, ... } => SOME login
Chris@303 1188 | NONE => NONE
Chris@317 1189
Chris@317 1190 fun reponame_for path =
Chris@317 1191 case String.tokens (fn c => c = #"/") path of
Chris@317 1192 [] => raise Fail "Non-empty library path required"
Chris@317 1193 | toks => hd (rev toks)
Chris@317 1194
Chris@303 1195 fun remote_url (context : context) vcs source libname =
Chris@303 1196 case source of
Chris@303 1197 URL_SOURCE u => u
Chris@303 1198 | SERVICE_SOURCE { service, owner, repo } =>
Chris@303 1199 provider_url { vcs = vcs,
Chris@303 1200 service = service,
Chris@303 1201 owner = owner,
Chris@303 1202 repo = case repo of
Chris@303 1203 SOME r => r
Chris@317 1204 | NONE => reponame_for libname }
Chris@303 1205 (login_for context service)
Chris@303 1206 (#providers context)
Chris@303 1207 end
Chris@303 1208
Chris@303 1209 structure HgControl :> VCS_CONTROL = struct
Chris@317 1210
Chris@317 1211 (* Pulls always use an explicit URL, never just the default
Chris@317 1212 remote, in order to ensure we update properly if the location
Chris@317 1213 given in the project file changes. *)
Chris@317 1214
Chris@303 1215 type vcsstate = { id: string, modified: bool,
Chris@303 1216 branch: string, tags: string list }
Chris@303 1217
Chris@317 1218 val hg_args = [ "--config", "ui.interactive=true",
Chris@317 1219 "--config", "ui.merge=:merge" ]
Chris@303 1220
Chris@303 1221 fun hg_command context libname args =
Chris@303 1222 FileBits.command context libname ("hg" :: hg_args @ args)
Chris@303 1223
Chris@303 1224 fun hg_command_output context libname args =
Chris@303 1225 FileBits.command_output context libname ("hg" :: hg_args @ args)
Chris@303 1226
Chris@303 1227 fun exists context libname =
Chris@303 1228 OK (OS.FileSys.isDir (FileBits.subpath context libname ".hg"))
Chris@303 1229 handle _ => OK false
Chris@303 1230
Chris@303 1231 fun remote_for context (libname, source) =
Chris@303 1232 Provider.remote_url context HG source libname
Chris@303 1233
Chris@303 1234 fun current_state context libname : vcsstate result =
Chris@303 1235 let fun is_branch text = text <> "" andalso #"(" = hd (explode text)
Chris@303 1236 and extract_branch b =
Chris@303 1237 if is_branch b (* need to remove enclosing parens *)
Chris@303 1238 then (implode o rev o tl o rev o tl o explode) b
Chris@303 1239 else "default"
Chris@303 1240 and is_modified id = id <> "" andalso #"+" = hd (rev (explode id))
Chris@303 1241 and extract_id id =
Chris@303 1242 if is_modified id (* need to remove trailing "+" *)
Chris@303 1243 then (implode o rev o tl o rev o explode) id
Chris@303 1244 else id
Chris@303 1245 and split_tags tags = String.tokens (fn c => c = #"/") tags
Chris@303 1246 and state_for (id, branch, tags) =
Chris@303 1247 OK { id = extract_id id,
Chris@303 1248 modified = is_modified id,
Chris@303 1249 branch = extract_branch branch,
Chris@303 1250 tags = split_tags tags }
Chris@303 1251 in
Chris@303 1252 case hg_command_output context libname ["id"] of
Chris@303 1253 ERROR e => ERROR e
Chris@303 1254 | OK out =>
Chris@303 1255 case String.tokens (fn x => x = #" ") out of
Chris@303 1256 [id, branch, tags] => state_for (id, branch, tags)
Chris@303 1257 | [id, other] => if is_branch other
Chris@303 1258 then state_for (id, other, "")
Chris@303 1259 else state_for (id, "", other)
Chris@303 1260 | [id] => state_for (id, "", "")
Chris@303 1261 | _ => ERROR ("Unexpected output from hg id: " ^ out)
Chris@303 1262 end
Chris@303 1263
Chris@303 1264 fun branch_name branch = case branch of
Chris@303 1265 DEFAULT_BRANCH => "default"
Chris@303 1266 | BRANCH "" => "default"
Chris@303 1267 | BRANCH b => b
Chris@303 1268
Chris@303 1269 fun id_of context libname =
Chris@303 1270 case current_state context libname of
Chris@303 1271 ERROR e => ERROR e
Chris@303 1272 | OK { id, ... } => OK id
Chris@303 1273
Chris@303 1274 fun is_at context (libname, id_or_tag) =
Chris@303 1275 case current_state context libname of
Chris@303 1276 ERROR e => ERROR e
Chris@303 1277 | OK { id, tags, ... } =>
Chris@303 1278 OK (String.isPrefix id_or_tag id orelse
Chris@303 1279 String.isPrefix id id_or_tag orelse
Chris@303 1280 List.exists (fn t => t = id_or_tag) tags)
Chris@303 1281
Chris@303 1282 fun is_on_branch context (libname, b) =
Chris@303 1283 case current_state context libname of
Chris@303 1284 ERROR e => ERROR e
Chris@303 1285 | OK { branch, ... } => OK (branch = branch_name b)
Chris@303 1286
Chris@303 1287 fun is_newest_locally context (libname, branch) =
Chris@303 1288 case hg_command_output context libname
Chris@303 1289 ["log", "-l1",
Chris@303 1290 "-b", branch_name branch,
Chris@303 1291 "--template", "{node}"] of
Chris@317 1292 ERROR e => OK false (* desired branch does not exist *)
Chris@303 1293 | OK newest_in_repo => is_at context (libname, newest_in_repo)
Chris@303 1294
Chris@317 1295 fun pull context (libname, source) =
Chris@317 1296 let val url = remote_for context (libname, source)
Chris@317 1297 in
Chris@317 1298 hg_command context libname
Chris@317 1299 (if FileBits.verbose ()
Chris@317 1300 then ["pull", url]
Chris@317 1301 else ["pull", "-q", url])
Chris@317 1302 end
Chris@303 1303
Chris@317 1304 fun is_newest context (libname, source, branch) =
Chris@303 1305 case is_newest_locally context (libname, branch) of
Chris@303 1306 ERROR e => ERROR e
Chris@303 1307 | OK false => OK false
Chris@303 1308 | OK true =>
Chris@317 1309 case pull context (libname, source) of
Chris@303 1310 ERROR e => ERROR e
Chris@303 1311 | _ => is_newest_locally context (libname, branch)
Chris@303 1312
Chris@303 1313 fun is_modified_locally context libname =
Chris@303 1314 case current_state context libname of
Chris@303 1315 ERROR e => ERROR e
Chris@303 1316 | OK { modified, ... } => OK modified
Chris@303 1317
Chris@303 1318 fun checkout context (libname, source, branch) =
Chris@303 1319 let val url = remote_for context (libname, source)
Chris@303 1320 in
Chris@317 1321 (* make the lib dir rather than just the ext dir, since
Chris@317 1322 the lib dir might be nested and hg will happily check
Chris@317 1323 out into an existing empty dir anyway *)
Chris@317 1324 case FileBits.mkpath (FileBits.libpath context libname) of
Chris@303 1325 ERROR e => ERROR e
Chris@303 1326 | _ => hg_command context ""
Chris@303 1327 ["clone", "-u", branch_name branch,
Chris@303 1328 url, libname]
Chris@303 1329 end
Chris@303 1330
Chris@317 1331 fun update context (libname, source, branch) =
Chris@317 1332 let val pull_result = pull context (libname, source)
Chris@303 1333 in
Chris@303 1334 case hg_command context libname ["update", branch_name branch] of
Chris@303 1335 ERROR e => ERROR e
Chris@303 1336 | _ =>
Chris@303 1337 case pull_result of
Chris@303 1338 ERROR e => ERROR e
Chris@317 1339 | _ => OK ()
Chris@303 1340 end
Chris@303 1341
Chris@317 1342 fun update_to context (libname, _, "") =
Chris@303 1343 ERROR "Non-empty id (tag or revision id) required for update_to"
Chris@317 1344 | update_to context (libname, source, id) =
Chris@317 1345 let val pull_result = pull context (libname, source)
Chris@303 1346 in
Chris@303 1347 case hg_command context libname ["update", "-r", id] of
Chris@317 1348 OK _ => OK ()
Chris@303 1349 | ERROR e =>
Chris@303 1350 case pull_result of
Chris@303 1351 ERROR e' => ERROR e' (* this was the ur-error *)
Chris@303 1352 | _ => ERROR e
Chris@303 1353 end
Chris@317 1354
Chris@317 1355 fun copy_url_for context libname =
Chris@317 1356 OK (FileBits.file_url (FileBits.libpath context libname))
Chris@317 1357
Chris@303 1358 end
Chris@303 1359
Chris@303 1360 structure GitControl :> VCS_CONTROL = struct
Chris@303 1361
Chris@303 1362 (* With Git repos we always operate in detached HEAD state. Even
Chris@317 1363 the master branch is checked out using a remote reference
Chris@317 1364 (vext/master). The remote we use is always named vext, and we
Chris@317 1365 update it to the expected URL each time we fetch, in order to
Chris@317 1366 ensure we update properly if the location given in the project
Chris@317 1367 file changes. The origin remote is unused. *)
Chris@303 1368
Chris@303 1369 fun git_command context libname args =
Chris@303 1370 FileBits.command context libname ("git" :: args)
Chris@303 1371
Chris@303 1372 fun git_command_output context libname args =
Chris@303 1373 FileBits.command_output context libname ("git" :: args)
Chris@303 1374
Chris@303 1375 fun exists context libname =
Chris@303 1376 OK (OS.FileSys.isDir (FileBits.subpath context libname ".git"))
Chris@303 1377 handle _ => OK false
Chris@303 1378
Chris@303 1379 fun remote_for context (libname, source) =
Chris@303 1380 Provider.remote_url context GIT source libname
Chris@303 1381
Chris@303 1382 fun branch_name branch = case branch of
Chris@303 1383 DEFAULT_BRANCH => "master"
Chris@303 1384 | BRANCH "" => "master"
Chris@303 1385 | BRANCH b => b
Chris@303 1386
Chris@317 1387 val our_remote = "vext"
Chris@317 1388
Chris@317 1389 fun remote_branch_name branch = our_remote ^ "/" ^ branch_name branch
Chris@303 1390
Chris@303 1391 fun checkout context (libname, source, branch) =
Chris@303 1392 let val url = remote_for context (libname, source)
Chris@303 1393 in
Chris@317 1394 (* make the lib dir rather than just the ext dir, since
Chris@317 1395 the lib dir might be nested and git will happily check
Chris@317 1396 out into an existing empty dir anyway *)
Chris@317 1397 case FileBits.mkpath (FileBits.libpath context libname) of
Chris@303 1398 OK () => git_command context ""
Chris@317 1399 ["clone", "--origin", our_remote,
Chris@317 1400 "--branch", branch_name branch,
Chris@303 1401 url, libname]
Chris@303 1402 | ERROR e => ERROR e
Chris@303 1403 end
Chris@303 1404
Chris@317 1405 fun add_our_remote context (libname, source) =
Chris@317 1406 (* When we do the checkout ourselves (above), we add the
Chris@317 1407 remote at the same time. But if the repo was cloned by
Chris@317 1408 someone else, we'll need to do it after the fact. Git
Chris@317 1409 doesn't seem to have a means to add a remote or change its
Chris@317 1410 url if it already exists; seems we have to do this: *)
Chris@317 1411 let val url = remote_for context (libname, source)
Chris@317 1412 in
Chris@317 1413 case git_command context libname
Chris@317 1414 ["remote", "set-url", our_remote, url] of
Chris@317 1415 OK () => OK ()
Chris@317 1416 | ERROR e => git_command context libname
Chris@317 1417 ["remote", "add", "-f", our_remote, url]
Chris@317 1418 end
Chris@317 1419
Chris@303 1420 (* NB git rev-parse HEAD shows revision id of current checkout;
Chris@303 1421 git rev-list -1 <tag> shows revision id of revision with that tag *)
Chris@303 1422
Chris@303 1423 fun id_of context libname =
Chris@303 1424 git_command_output context libname ["rev-parse", "HEAD"]
Chris@303 1425
Chris@303 1426 fun is_at context (libname, id_or_tag) =
Chris@303 1427 case id_of context libname of
Chris@317 1428 ERROR e => OK false (* HEAD nonexistent, expected in empty repo *)
Chris@303 1429 | OK id =>
Chris@303 1430 if String.isPrefix id_or_tag id orelse
Chris@303 1431 String.isPrefix id id_or_tag
Chris@303 1432 then OK true
Chris@303 1433 else
Chris@303 1434 case git_command_output context libname
Chris@303 1435 ["show-ref",
Chris@317 1436 "refs/tags/" ^ id_or_tag,
Chris@317 1437 "--"] of
Chris@303 1438 OK "" => OK false
Chris@303 1439 | ERROR _ => OK false
Chris@303 1440 | OK s => OK (id = hd (String.tokens (fn c => c = #" ") s))
Chris@303 1441
Chris@303 1442 fun branch_tip context (libname, branch) =
Chris@317 1443 (* We don't have access to the source info or the network
Chris@317 1444 here, as this is used by status (e.g. via is_on_branch) as
Chris@317 1445 well as review. It's possible the remote branch won't exist,
Chris@317 1446 e.g. if the repo was checked out by something other than
Chris@317 1447 Vext, and if that's the case, we can't add it here; we'll
Chris@317 1448 just have to fail, since checking against local branches
Chris@317 1449 instead could produce the wrong result. *)
Chris@303 1450 git_command_output context libname
Chris@303 1451 ["rev-list", "-1",
Chris@317 1452 remote_branch_name branch, "--"]
Chris@303 1453
Chris@303 1454 fun is_newest_locally context (libname, branch) =
Chris@303 1455 case branch_tip context (libname, branch) of
Chris@317 1456 ERROR e => OK false
Chris@303 1457 | OK rev => is_at context (libname, rev)
Chris@303 1458
Chris@303 1459 fun is_on_branch context (libname, branch) =
Chris@303 1460 case branch_tip context (libname, branch) of
Chris@317 1461 ERROR e => OK false
Chris@303 1462 | OK rev =>
Chris@303 1463 case is_at context (libname, rev) of
Chris@303 1464 ERROR e => ERROR e
Chris@303 1465 | OK true => OK true
Chris@303 1466 | OK false =>
Chris@303 1467 case git_command context libname
Chris@303 1468 ["merge-base", "--is-ancestor",
Chris@303 1469 "HEAD", remote_branch_name branch] of
Chris@303 1470 ERROR e => OK false (* cmd returns non-zero for no *)
Chris@303 1471 | _ => OK true
Chris@303 1472
Chris@317 1473 fun fetch context (libname, source) =
Chris@317 1474 case add_our_remote context (libname, source) of
Chris@303 1475 ERROR e => ERROR e
Chris@317 1476 | _ => git_command context libname ["fetch", our_remote]
Chris@317 1477
Chris@317 1478 fun is_newest context (libname, source, branch) =
Chris@317 1479 case add_our_remote context (libname, source) of
Chris@317 1480 ERROR e => ERROR e
Chris@317 1481 | OK () =>
Chris@317 1482 case is_newest_locally context (libname, branch) of
Chris@303 1483 ERROR e => ERROR e
Chris@317 1484 | OK false => OK false
Chris@317 1485 | OK true =>
Chris@317 1486 case fetch context (libname, source) of
Chris@317 1487 ERROR e => ERROR e
Chris@317 1488 | _ => is_newest_locally context (libname, branch)
Chris@303 1489
Chris@303 1490 fun is_modified_locally context libname =
Chris@303 1491 case git_command_output context libname ["status", "--porcelain"] of
Chris@303 1492 ERROR e => ERROR e
Chris@303 1493 | OK "" => OK false
Chris@303 1494 | OK _ => OK true
Chris@303 1495
Chris@303 1496 (* This function updates to the latest revision on a branch rather
Chris@303 1497 than to a specific id or tag. We can't just checkout the given
Chris@303 1498 branch, as that will succeed even if the branch isn't up to
Chris@303 1499 date. We could checkout the branch and then fetch and merge,
Chris@303 1500 but it's perhaps cleaner not to maintain a local branch at all,
Chris@303 1501 but instead checkout the remote branch as a detached head. *)
Chris@303 1502
Chris@317 1503 fun update context (libname, source, branch) =
Chris@317 1504 case fetch context (libname, source) of
Chris@303 1505 ERROR e => ERROR e
Chris@303 1506 | _ =>
Chris@303 1507 case git_command context libname ["checkout", "--detach",
Chris@303 1508 remote_branch_name branch] of
Chris@303 1509 ERROR e => ERROR e
Chris@317 1510 | _ => OK ()
Chris@303 1511
Chris@303 1512 (* This function is dealing with a specific id or tag, so if we
Chris@303 1513 can successfully check it out (detached) then that's all we
Chris@303 1514 need to do, regardless of whether fetch succeeded or not. We do
Chris@303 1515 attempt the fetch first, though, purely in order to avoid ugly
Chris@303 1516 error messages in the common case where we're being asked to
Chris@303 1517 update to a new pin (from the lock file) that hasn't been
Chris@303 1518 fetched yet. *)
Chris@303 1519
Chris@317 1520 fun update_to context (libname, _, "") =
Chris@303 1521 ERROR "Non-empty id (tag or revision id) required for update_to"
Chris@317 1522 | update_to context (libname, source, id) =
Chris@317 1523 let val fetch_result = fetch context (libname, source)
Chris@303 1524 in
Chris@303 1525 case git_command context libname ["checkout", "--detach", id] of
Chris@317 1526 OK _ => OK ()
Chris@303 1527 | ERROR e =>
Chris@303 1528 case fetch_result of
Chris@303 1529 ERROR e' => ERROR e' (* this was the ur-error *)
Chris@303 1530 | _ => ERROR e
Chris@303 1531 end
Chris@317 1532
Chris@317 1533 fun copy_url_for context libname =
Chris@317 1534 OK (FileBits.file_url (FileBits.libpath context libname))
Chris@303 1535
Chris@303 1536 end
Chris@303 1537
Chris@317 1538 structure SvnControl :> VCS_CONTROL = struct
Chris@317 1539
Chris@317 1540 fun svn_command context libname args =
Chris@317 1541 FileBits.command context libname ("svn" :: args)
Chris@317 1542
Chris@317 1543 fun svn_command_output context libname args =
Chris@317 1544 FileBits.command_output context libname ("svn" :: args)
Chris@317 1545
Chris@317 1546 fun svn_command_lines context libname args =
Chris@317 1547 case svn_command_output context libname args of
Chris@317 1548 ERROR e => ERROR e
Chris@317 1549 | OK s => OK (String.tokens (fn c => c = #"\n" orelse c = #"\r") s)
Chris@317 1550
Chris@317 1551 fun split_line_pair line =
Chris@317 1552 let fun strip_leading_ws str = case explode str of
Chris@317 1553 #" "::rest => implode rest
Chris@317 1554 | _ => str
Chris@317 1555 in
Chris@317 1556 case String.tokens (fn c => c = #":") line of
Chris@317 1557 [] => ("", "")
Chris@317 1558 | first::rest =>
Chris@317 1559 (first, strip_leading_ws (String.concatWith ":" rest))
Chris@317 1560 end
Chris@317 1561
Chris@317 1562 fun svn_info_item context libname key =
Chris@317 1563 (* SVN 1.9 has info --show-item which is what we need, but at
Chris@317 1564 this point we still have 1.8 on the CI boxes so we might as
Chris@317 1565 well aim to support it *)
Chris@317 1566 case svn_command_lines context libname ["info"] of
Chris@317 1567 ERROR e => ERROR e
Chris@317 1568 | OK lines =>
Chris@317 1569 case List.find (fn (k, v) => k = key) (map split_line_pair lines) of
Chris@317 1570 NONE => ERROR ("Key \"" ^ key ^ "\" not found in output")
Chris@317 1571 | SOME (_, v) => OK v
Chris@317 1572
Chris@317 1573 fun exists context libname =
Chris@317 1574 OK (OS.FileSys.isDir (FileBits.subpath context libname ".svn"))
Chris@317 1575 handle _ => OK false
Chris@317 1576
Chris@317 1577 fun remote_for context (libname, source) =
Chris@317 1578 Provider.remote_url context SVN source libname
Chris@317 1579
Chris@317 1580 fun id_of context libname =
Chris@317 1581 svn_info_item context libname "Revision" (*!!! check: does svn localise this? should we ensure C locale? *)
Chris@317 1582
Chris@317 1583 fun is_at context (libname, id_or_tag) =
Chris@317 1584 case id_of context libname of
Chris@317 1585 ERROR e => ERROR e
Chris@317 1586 | OK id => OK (id = id_or_tag)
Chris@317 1587
Chris@317 1588 fun is_on_branch context (libname, b) =
Chris@317 1589 OK (b = DEFAULT_BRANCH)
Chris@317 1590
Chris@317 1591 fun is_newest context (libname, source, branch) =
Chris@317 1592 case svn_command_lines context libname ["status", "--show-updates"] of
Chris@317 1593 ERROR e => ERROR e
Chris@317 1594 | OK lines =>
Chris@317 1595 case rev lines of
Chris@317 1596 [] => ERROR "No result returned for server status"
Chris@317 1597 | last_line::_ =>
Chris@317 1598 case rev (String.tokens (fn c => c = #" ") last_line) of
Chris@317 1599 [] => ERROR "No revision field found in server status"
Chris@317 1600 | server_id::_ => is_at context (libname, server_id)
Chris@317 1601
Chris@317 1602 fun is_newest_locally context (libname, branch) =
Chris@317 1603 OK true (* no local history *)
Chris@317 1604
Chris@317 1605 fun is_modified_locally context libname =
Chris@317 1606 case svn_command_output context libname ["status"] of
Chris@317 1607 ERROR e => ERROR e
Chris@317 1608 | OK "" => OK false
Chris@317 1609 | OK _ => OK true
Chris@317 1610
Chris@317 1611 fun checkout context (libname, source, branch) =
Chris@317 1612 let val url = remote_for context (libname, source)
Chris@317 1613 val path = FileBits.libpath context libname
Chris@317 1614 in
Chris@317 1615 if FileBits.nonempty_dir_exists path
Chris@317 1616 then (* Surprisingly, SVN itself has no problem with
Chris@317 1617 this. But for consistency with other VCSes we
Chris@317 1618 don't allow it *)
Chris@317 1619 ERROR ("Refusing checkout to nonempty dir \"" ^ path ^ "\"")
Chris@317 1620 else
Chris@317 1621 (* make the lib dir rather than just the ext dir, since
Chris@317 1622 the lib dir might be nested and svn will happily check
Chris@317 1623 out into an existing empty dir anyway *)
Chris@317 1624 case FileBits.mkpath (FileBits.libpath context libname) of
Chris@317 1625 ERROR e => ERROR e
Chris@317 1626 | _ => svn_command context "" ["checkout", url, libname]
Chris@317 1627 end
Chris@317 1628
Chris@317 1629 fun update context (libname, source, branch) =
Chris@317 1630 case svn_command context libname
Chris@317 1631 ["update", "--accept", "postpone"] of
Chris@317 1632 ERROR e => ERROR e
Chris@317 1633 | _ => OK ()
Chris@317 1634
Chris@317 1635 fun update_to context (libname, _, "") =
Chris@317 1636 ERROR "Non-empty id (tag or revision id) required for update_to"
Chris@317 1637 | update_to context (libname, source, id) =
Chris@317 1638 case svn_command context libname
Chris@317 1639 ["update", "-r", id, "--accept", "postpone"] of
Chris@317 1640 ERROR e => ERROR e
Chris@317 1641 | OK _ => OK ()
Chris@317 1642
Chris@317 1643 fun copy_url_for context libname =
Chris@317 1644 svn_info_item context libname "URL"
Chris@317 1645
Chris@317 1646 end
Chris@317 1647
Chris@303 1648 structure AnyLibControl :> LIB_CONTROL = struct
Chris@303 1649
Chris@303 1650 structure H = LibControlFn(HgControl)
Chris@303 1651 structure G = LibControlFn(GitControl)
Chris@317 1652 structure S = LibControlFn(SvnControl)
Chris@303 1653
Chris@303 1654 fun review context (spec as { vcs, ... } : libspec) =
Chris@317 1655 (fn HG => H.review | GIT => G.review | SVN => S.review) vcs context spec
Chris@303 1656
Chris@303 1657 fun status context (spec as { vcs, ... } : libspec) =
Chris@317 1658 (fn HG => H.status | GIT => G.status | SVN => S.status) vcs context spec
Chris@303 1659
Chris@303 1660 fun update context (spec as { vcs, ... } : libspec) =
Chris@317 1661 (fn HG => H.update | GIT => G.update | SVN => S.update) vcs context spec
Chris@314 1662
Chris@314 1663 fun id_of context (spec as { vcs, ... } : libspec) =
Chris@317 1664 (fn HG => H.id_of | GIT => G.id_of | SVN => S.id_of) vcs context spec
Chris@317 1665
Chris@303 1666 end
Chris@303 1667
Chris@315 1668
Chris@315 1669 type exclusions = string list
Chris@315 1670
Chris@315 1671 structure Archive :> sig
Chris@315 1672
Chris@315 1673 val archive : string * exclusions -> project -> OS.Process.status
Chris@315 1674
Chris@315 1675 end = struct
Chris@315 1676
Chris@315 1677 (* The idea of "archive" is to replace hg/git archive, which won't
Chris@315 1678 include files, like the Vext-introduced external libraries,
Chris@315 1679 that are not under version control with the main repo.
Chris@315 1680
Chris@315 1681 The process goes like this:
Chris@315 1682
Chris@315 1683 - Make sure we have a target filename from the user, and take
Chris@315 1684 its basename as our archive directory name
Chris@315 1685
Chris@315 1686 - Make an "archive root" subdir of the project repo, named
Chris@315 1687 typically .vext-archive
Chris@315 1688
Chris@315 1689 - Identify the VCS used for the project repo. Note that any
Chris@315 1690 explicit references to VCS type in this structure are to
Chris@315 1691 the VCS used for the project (something Vext doesn't
Chris@315 1692 otherwise care about), not for an individual library
Chris@315 1693
Chris@315 1694 - Synthesise a Vext project with the archive root as its
Chris@315 1695 root path, "." as its extdir, with one library whose
Chris@315 1696 name is the user-supplied basename and whose explicit
Chris@315 1697 source URL is the original project root; update that
Chris@315 1698 project -- thus cloning the original project to a subdir
Chris@315 1699 of the archive root
Chris@315 1700
Chris@315 1701 - Synthesise a Vext project identical to the original one for
Chris@315 1702 this project, but with the newly-cloned copy as its root
Chris@315 1703 path; update that project -- thus checking out clean copies
Chris@315 1704 of the external library dirs
Chris@315 1705
Chris@315 1706 - Call out to an archive program to archive up the new copy,
Chris@315 1707 running e.g.
Chris@315 1708 tar cvzf project-release.tar.gz \
Chris@315 1709 --exclude=.hg --exclude=.git project-release
Chris@315 1710 in the archive root dir
Chris@315 1711
Chris@315 1712 - (We also omit the vext-project.json file and any trace of
Chris@315 1713 Vext. It can't properly be run in a directory where the
Chris@315 1714 external project folders already exist but their repo history
Chris@315 1715 does not. End users shouldn't get to see Vext)
Chris@315 1716
Chris@315 1717 - Clean up by deleting the new copy
Chris@315 1718 *)
Chris@315 1719
Chris@317 1720 fun project_vcs_id_and_url dir =
Chris@315 1721 let val context = {
Chris@315 1722 rootpath = dir,
Chris@315 1723 extdir = ".",
Chris@315 1724 providers = [],
Chris@315 1725 accounts = []
Chris@315 1726 }
Chris@315 1727 val vcs_maybe =
Chris@315 1728 case [HgControl.exists context ".",
Chris@317 1729 GitControl.exists context ".",
Chris@317 1730 SvnControl.exists context "."] of
Chris@317 1731 [OK true, OK false, OK false] => OK HG
Chris@317 1732 | [OK false, OK true, OK false] => OK GIT
Chris@317 1733 | [OK false, OK false, OK true] => OK SVN
Chris@315 1734 | _ => ERROR ("Unable to identify VCS for directory " ^ dir)
Chris@315 1735 in
Chris@315 1736 case vcs_maybe of
Chris@315 1737 ERROR e => ERROR e
Chris@315 1738 | OK vcs =>
Chris@317 1739 case (fn HG => HgControl.id_of
Chris@317 1740 | GIT => GitControl.id_of
Chris@317 1741 | SVN => SvnControl.id_of)
Chris@315 1742 vcs context "." of
Chris@317 1743 ERROR e => ERROR ("Unable to find id of project repo: " ^ e)
Chris@317 1744 | OK id =>
Chris@317 1745 case (fn HG => HgControl.copy_url_for
Chris@317 1746 | GIT => GitControl.copy_url_for
Chris@317 1747 | SVN => SvnControl.copy_url_for)
Chris@317 1748 vcs context "." of
Chris@317 1749 ERROR e => ERROR ("Unable to find URL of project repo: "
Chris@317 1750 ^ e)
Chris@317 1751 | OK url => OK (vcs, id, url)
Chris@315 1752 end
Chris@315 1753
Chris@315 1754 fun make_archive_root (context : context) =
Chris@315 1755 let val path = OS.Path.joinDirFile {
Chris@315 1756 dir = #rootpath context,
Chris@315 1757 file = VextFilenames.archive_dir
Chris@315 1758 }
Chris@315 1759 in
Chris@315 1760 case FileBits.mkpath path of
Chris@315 1761 ERROR e => raise Fail ("Failed to create archive directory \""
Chris@315 1762 ^ path ^ "\": " ^ e)
Chris@315 1763 | OK () => path
Chris@315 1764 end
Chris@315 1765
Chris@315 1766 fun archive_path archive_dir target_name =
Chris@315 1767 OS.Path.joinDirFile {
Chris@315 1768 dir = archive_dir,
Chris@315 1769 file = target_name
Chris@315 1770 }
Chris@315 1771
Chris@315 1772 fun check_nonexistent path =
Chris@315 1773 case SOME (OS.FileSys.fileSize path) handle OS.SysErr _ => NONE of
Chris@315 1774 NONE => ()
Chris@315 1775 | _ => raise Fail ("Path " ^ path ^ " exists, not overwriting")
Chris@315 1776
Chris@317 1777 fun make_archive_copy target_name (vcs, project_id, source_url)
Chris@315 1778 ({ context, ... } : project) =
Chris@315 1779 let val archive_root = make_archive_root context
Chris@315 1780 val synthetic_context = {
Chris@315 1781 rootpath = archive_root,
Chris@315 1782 extdir = ".",
Chris@315 1783 providers = [],
Chris@315 1784 accounts = []
Chris@315 1785 }
Chris@315 1786 val synthetic_library = {
Chris@315 1787 libname = target_name,
Chris@315 1788 vcs = vcs,
Chris@317 1789 source = URL_SOURCE source_url,
Chris@315 1790 branch = DEFAULT_BRANCH, (* overridden by pinned id below *)
Chris@315 1791 project_pin = PINNED project_id,
Chris@315 1792 lock_pin = PINNED project_id
Chris@315 1793 }
Chris@315 1794 val path = archive_path archive_root target_name
Chris@315 1795 val _ = print ("Cloning original project to " ^ path
Chris@315 1796 ^ " at revision " ^ project_id ^ "...\n");
Chris@315 1797 val _ = check_nonexistent path
Chris@315 1798 in
Chris@315 1799 case AnyLibControl.update synthetic_context synthetic_library of
Chris@315 1800 ERROR e => ERROR ("Failed to clone original project to "
Chris@315 1801 ^ path ^ ": " ^ e)
Chris@315 1802 | OK _ => OK archive_root
Chris@315 1803 end
Chris@315 1804
Chris@315 1805 fun update_archive archive_root target_name
Chris@315 1806 (project as { context, ... } : project) =
Chris@315 1807 let val synthetic_context = {
Chris@315 1808 rootpath = archive_path archive_root target_name,
Chris@315 1809 extdir = #extdir context,
Chris@315 1810 providers = #providers context,
Chris@315 1811 accounts = #accounts context
Chris@315 1812 }
Chris@315 1813 in
Chris@315 1814 foldl (fn (lib, acc) =>
Chris@315 1815 case acc of
Chris@315 1816 ERROR e => ERROR e
Chris@317 1817 | OK () => AnyLibControl.update synthetic_context lib)
Chris@317 1818 (OK ())
Chris@315 1819 (#libs project)
Chris@315 1820 end
Chris@315 1821
Chris@315 1822 datatype packer = TAR
Chris@315 1823 | TAR_GZ
Chris@315 1824 | TAR_BZ2
Chris@315 1825 | TAR_XZ
Chris@315 1826 (* could add other packers, e.g. zip, if we knew how to
Chris@315 1827 handle the file omissions etc properly in pack_archive *)
Chris@315 1828
Chris@315 1829 fun packer_and_basename path =
Chris@315 1830 let val extensions = [ (".tar", TAR),
Chris@315 1831 (".tar.gz", TAR_GZ),
Chris@315 1832 (".tar.bz2", TAR_BZ2),
Chris@315 1833 (".tar.xz", TAR_XZ)]
Chris@315 1834 val filename = OS.Path.file path
Chris@315 1835 in
Chris@315 1836 foldl (fn ((ext, packer), acc) =>
Chris@315 1837 if String.isSuffix ext filename
Chris@315 1838 then SOME (packer,
Chris@315 1839 String.substring (filename, 0,
Chris@315 1840 String.size filename -
Chris@315 1841 String.size ext))
Chris@315 1842 else acc)
Chris@315 1843 NONE
Chris@315 1844 extensions
Chris@315 1845 end
Chris@315 1846
Chris@315 1847 fun pack_archive archive_root target_name target_path packer exclusions =
Chris@315 1848 case FileBits.command {
Chris@315 1849 rootpath = archive_root,
Chris@315 1850 extdir = ".",
Chris@315 1851 providers = [],
Chris@315 1852 accounts = []
Chris@315 1853 } "" ([
Chris@315 1854 "tar",
Chris@315 1855 case packer of
Chris@315 1856 TAR => "cf"
Chris@315 1857 | TAR_GZ => "czf"
Chris@315 1858 | TAR_BZ2 => "cjf"
Chris@315 1859 | TAR_XZ => "cJf",
Chris@315 1860 target_path,
Chris@315 1861 "--exclude=.hg",
Chris@315 1862 "--exclude=.git",
Chris@317 1863 "--exclude=.svn",
Chris@315 1864 "--exclude=vext",
Chris@315 1865 "--exclude=vext.sml",
Chris@315 1866 "--exclude=vext.ps1",
Chris@315 1867 "--exclude=vext.bat",
Chris@315 1868 "--exclude=vext-project.json",
Chris@315 1869 "--exclude=vext-lock.json"
Chris@315 1870 ] @ (map (fn e => "--exclude=" ^ e) exclusions) @
Chris@315 1871 [ target_name ])
Chris@315 1872 of
Chris@315 1873 ERROR e => ERROR e
Chris@315 1874 | OK _ => FileBits.rmpath (archive_path archive_root target_name)
Chris@315 1875
Chris@315 1876 fun archive (target_path, exclusions) (project : project) =
Chris@315 1877 let val _ = check_nonexistent target_path
Chris@315 1878 val (packer, name) =
Chris@315 1879 case packer_and_basename target_path of
Chris@315 1880 NONE => raise Fail ("Unsupported archive file extension in "
Chris@315 1881 ^ target_path)
Chris@315 1882 | SOME pn => pn
Chris@315 1883 val details =
Chris@317 1884 case project_vcs_id_and_url (#rootpath (#context project)) of
Chris@315 1885 ERROR e => raise Fail e
Chris@315 1886 | OK details => details
Chris@315 1887 val archive_root =
Chris@315 1888 case make_archive_copy name details project of
Chris@315 1889 ERROR e => raise Fail e
Chris@315 1890 | OK archive_root => archive_root
Chris@315 1891 val outcome =
Chris@315 1892 case update_archive archive_root name project of
Chris@315 1893 ERROR e => ERROR e
Chris@315 1894 | OK _ =>
Chris@315 1895 case pack_archive archive_root name
Chris@315 1896 target_path packer exclusions of
Chris@315 1897 ERROR e => ERROR e
Chris@315 1898 | OK _ => OK ()
Chris@315 1899 in
Chris@315 1900 case outcome of
Chris@315 1901 ERROR e => raise Fail e
Chris@315 1902 | OK () => OS.Process.success
Chris@315 1903 end
Chris@315 1904
Chris@315 1905 end
Chris@315 1906
Chris@303 1907 val libobjname = "libraries"
Chris@303 1908
Chris@303 1909 fun load_libspec spec_json lock_json libname : libspec =
Chris@303 1910 let open JsonBits
Chris@303 1911 val libobj = lookup_mandatory spec_json [libobjname, libname]
Chris@303 1912 val vcs = lookup_mandatory_string libobj ["vcs"]
Chris@303 1913 val retrieve = lookup_optional_string libobj
Chris@303 1914 val service = retrieve ["service"]
Chris@303 1915 val owner = retrieve ["owner"]
Chris@303 1916 val repo = retrieve ["repository"]
Chris@303 1917 val url = retrieve ["url"]
Chris@303 1918 val branch = retrieve ["branch"]
Chris@314 1919 val project_pin = case retrieve ["pin"] of
Chris@314 1920 NONE => UNPINNED
Chris@314 1921 | SOME p => PINNED p
Chris@303 1922 val lock_pin = case lookup_optional lock_json [libobjname, libname] of
Chris@314 1923 NONE => UNPINNED
Chris@314 1924 | SOME ll => case lookup_optional_string ll ["pin"] of
Chris@314 1925 SOME p => PINNED p
Chris@314 1926 | NONE => UNPINNED
Chris@303 1927 in
Chris@303 1928 {
Chris@303 1929 libname = libname,
Chris@303 1930 vcs = case vcs of
Chris@303 1931 "hg" => HG
Chris@303 1932 | "git" => GIT
Chris@317 1933 | "svn" => SVN
Chris@303 1934 | other => raise Fail ("Unknown version-control system \"" ^
Chris@303 1935 other ^ "\""),
Chris@303 1936 source = case (url, service, owner, repo) of
Chris@303 1937 (SOME u, NONE, _, _) => URL_SOURCE u
Chris@303 1938 | (NONE, SOME ss, owner, repo) =>
Chris@303 1939 SERVICE_SOURCE { service = ss, owner = owner, repo = repo }
Chris@303 1940 | _ => raise Fail ("Must have exactly one of service " ^
Chris@303 1941 "or url string"),
Chris@314 1942 project_pin = project_pin,
Chris@314 1943 lock_pin = lock_pin,
Chris@303 1944 branch = case branch of
Chris@317 1945 NONE => DEFAULT_BRANCH
Chris@317 1946 | SOME b =>
Chris@317 1947 case vcs of
Chris@317 1948 "svn" => raise Fail ("Branches not supported for " ^
Chris@317 1949 "svn repositories; change " ^
Chris@317 1950 "URL instead")
Chris@317 1951 | _ => BRANCH b
Chris@303 1952 }
Chris@303 1953 end
Chris@303 1954
Chris@303 1955 fun load_userconfig () : userconfig =
Chris@303 1956 let val home = FileBits.homedir ()
Chris@303 1957 val conf_json =
Chris@303 1958 JsonBits.load_json_from
Chris@303 1959 (OS.Path.joinDirFile {
Chris@303 1960 dir = home,
Chris@303 1961 file = VextFilenames.user_config_file })
Chris@303 1962 handle IO.Io _ => Json.OBJECT []
Chris@303 1963 in
Chris@303 1964 {
Chris@303 1965 accounts = case JsonBits.lookup_optional conf_json ["accounts"] of
Chris@303 1966 NONE => []
Chris@303 1967 | SOME (Json.OBJECT aa) =>
Chris@303 1968 map (fn (k, (Json.STRING v)) =>
Chris@303 1969 { service = k, login = v }
Chris@303 1970 | _ => raise Fail
Chris@303 1971 "String expected for account name")
Chris@303 1972 aa
Chris@303 1973 | _ => raise Fail "Array expected for accounts",
Chris@303 1974 providers = Provider.load_providers conf_json
Chris@303 1975 }
Chris@303 1976 end
Chris@303 1977
Chris@303 1978 datatype pintype =
Chris@303 1979 NO_LOCKFILE |
Chris@303 1980 USE_LOCKFILE
Chris@303 1981
Chris@303 1982 fun load_project (userconfig : userconfig) rootpath pintype : project =
Chris@303 1983 let val spec_file = FileBits.project_spec_path rootpath
Chris@303 1984 val lock_file = FileBits.project_lock_path rootpath
Chris@303 1985 val _ = if OS.FileSys.access (spec_file, [OS.FileSys.A_READ])
Chris@303 1986 handle OS.SysErr _ => false
Chris@303 1987 then ()
Chris@303 1988 else raise Fail ("Failed to open project spec file " ^
Chris@303 1989 (VextFilenames.project_file) ^ " in " ^
Chris@303 1990 rootpath ^
Chris@303 1991 ".\nPlease ensure the spec file is in the " ^
Chris@303 1992 "project root and run this from there.")
Chris@303 1993 val spec_json = JsonBits.load_json_from spec_file
Chris@303 1994 val lock_json = if pintype = USE_LOCKFILE
Chris@303 1995 then JsonBits.load_json_from lock_file
Chris@303 1996 handle IO.Io _ => Json.OBJECT []
Chris@303 1997 else Json.OBJECT []
Chris@303 1998 val extdir = JsonBits.lookup_mandatory_string spec_json
Chris@303 1999 ["config", "extdir"]
Chris@303 2000 val spec_libs = JsonBits.lookup_optional spec_json [libobjname]
Chris@303 2001 val lock_libs = JsonBits.lookup_optional lock_json [libobjname]
Chris@303 2002 val providers = Provider.load_more_providers
Chris@303 2003 (#providers userconfig) spec_json
Chris@303 2004 val libnames = case spec_libs of
Chris@303 2005 NONE => []
Chris@303 2006 | SOME (Json.OBJECT ll) => map (fn (k, v) => k) ll
Chris@303 2007 | _ => raise Fail "Object expected for libs"
Chris@303 2008 in
Chris@303 2009 {
Chris@303 2010 context = {
Chris@303 2011 rootpath = rootpath,
Chris@303 2012 extdir = extdir,
Chris@303 2013 providers = providers,
Chris@303 2014 accounts = #accounts userconfig
Chris@303 2015 },
Chris@303 2016 libs = map (load_libspec spec_json lock_json) libnames
Chris@303 2017 }
Chris@303 2018 end
Chris@303 2019
Chris@303 2020 fun save_lock_file rootpath locks =
Chris@303 2021 let val lock_file = FileBits.project_lock_path rootpath
Chris@303 2022 open Json
Chris@303 2023 val lock_json =
Chris@303 2024 OBJECT [
Chris@303 2025 (libobjname,
Chris@303 2026 OBJECT (map (fn { libname, id_or_tag } =>
Chris@303 2027 (libname,
Chris@303 2028 OBJECT [ ("pin", STRING id_or_tag) ]))
Chris@303 2029 locks))
Chris@303 2030 ]
Chris@303 2031 in
Chris@303 2032 JsonBits.save_json_to lock_file lock_json
Chris@303 2033 end
Chris@303 2034
Chris@303 2035 fun pad_to n str =
Chris@303 2036 if n <= String.size str then str
Chris@303 2037 else pad_to n (str ^ " ")
Chris@303 2038
Chris@303 2039 fun hline_to 0 = ""
Chris@303 2040 | hline_to n = "-" ^ hline_to (n-1)
Chris@303 2041
Chris@303 2042 val libname_width = 25
Chris@303 2043 val libstate_width = 11
Chris@314 2044 val localstate_width = 17
Chris@303 2045 val notes_width = 5
Chris@303 2046 val divider = " | "
Chris@314 2047 val clear_line = "\r" ^ pad_to 80 "";
Chris@303 2048
Chris@303 2049 fun print_status_header () =
Chris@314 2050 print (clear_line ^ "\n " ^
Chris@303 2051 pad_to libname_width "Library" ^ divider ^
Chris@303 2052 pad_to libstate_width "State" ^ divider ^
Chris@303 2053 pad_to localstate_width "Local" ^ divider ^
Chris@303 2054 "Notes" ^ "\n " ^
Chris@303 2055 hline_to libname_width ^ "-+-" ^
Chris@303 2056 hline_to libstate_width ^ "-+-" ^
Chris@303 2057 hline_to localstate_width ^ "-+-" ^
Chris@303 2058 hline_to notes_width ^ "\n")
Chris@303 2059
Chris@303 2060 fun print_outcome_header () =
Chris@314 2061 print (clear_line ^ "\n " ^
Chris@303 2062 pad_to libname_width "Library" ^ divider ^
Chris@303 2063 pad_to libstate_width "Outcome" ^ divider ^
Chris@303 2064 "Notes" ^ "\n " ^
Chris@303 2065 hline_to libname_width ^ "-+-" ^
Chris@303 2066 hline_to libstate_width ^ "-+-" ^
Chris@303 2067 hline_to notes_width ^ "\n")
Chris@303 2068
Chris@303 2069 fun print_status with_network (libname, status) =
Chris@303 2070 let val libstate_str =
Chris@303 2071 case status of
Chris@303 2072 OK (ABSENT, _) => "Absent"
Chris@303 2073 | OK (CORRECT, _) => if with_network then "Correct" else "Present"
Chris@303 2074 | OK (SUPERSEDED, _) => "Superseded"
Chris@303 2075 | OK (WRONG, _) => "Wrong"
Chris@303 2076 | ERROR _ => "Error"
Chris@303 2077 val localstate_str =
Chris@303 2078 case status of
Chris@303 2079 OK (_, MODIFIED) => "Modified"
Chris@314 2080 | OK (_, LOCK_MISMATCHED) => "Differs from Lock"
Chris@314 2081 | OK (_, CLEAN) => "Clean"
Chris@314 2082 | ERROR _ => ""
Chris@303 2083 val error_str =
Chris@303 2084 case status of
Chris@303 2085 ERROR e => e
Chris@303 2086 | _ => ""
Chris@303 2087 in
Chris@303 2088 print (" " ^
Chris@303 2089 pad_to libname_width libname ^ divider ^
Chris@303 2090 pad_to libstate_width libstate_str ^ divider ^
Chris@303 2091 pad_to localstate_width localstate_str ^ divider ^
Chris@303 2092 error_str ^ "\n")
Chris@303 2093 end
Chris@303 2094
Chris@303 2095 fun print_update_outcome (libname, outcome) =
Chris@303 2096 let val outcome_str =
Chris@303 2097 case outcome of
Chris@303 2098 OK id => "Ok"
Chris@303 2099 | ERROR e => "Failed"
Chris@303 2100 val error_str =
Chris@303 2101 case outcome of
Chris@303 2102 ERROR e => e
Chris@303 2103 | _ => ""
Chris@303 2104 in
Chris@303 2105 print (" " ^
Chris@303 2106 pad_to libname_width libname ^ divider ^
Chris@303 2107 pad_to libstate_width outcome_str ^ divider ^
Chris@303 2108 error_str ^ "\n")
Chris@303 2109 end
Chris@303 2110
Chris@303 2111 fun act_and_print action print_header print_line (libs : libspec list) =
Chris@303 2112 let val lines = map (fn lib => (#libname lib, action lib)) libs
Chris@303 2113 val _ = print_header ()
Chris@303 2114 in
Chris@303 2115 app print_line lines;
Chris@303 2116 lines
Chris@303 2117 end
Chris@303 2118
Chris@303 2119 fun return_code_for outcomes =
Chris@303 2120 foldl (fn ((_, result), acc) =>
Chris@303 2121 case result of
Chris@303 2122 ERROR _ => OS.Process.failure
Chris@303 2123 | _ => acc)
Chris@303 2124 OS.Process.success
Chris@303 2125 outcomes
Chris@303 2126
Chris@303 2127 fun status_of_project ({ context, libs } : project) =
Chris@303 2128 return_code_for (act_and_print (AnyLibControl.status context)
Chris@303 2129 print_status_header (print_status false)
Chris@303 2130 libs)
Chris@303 2131
Chris@303 2132 fun review_project ({ context, libs } : project) =
Chris@303 2133 return_code_for (act_and_print (AnyLibControl.review context)
Chris@303 2134 print_status_header (print_status true)
Chris@303 2135 libs)
Chris@303 2136
Chris@314 2137 fun lock_project ({ context, libs } : project) =
Chris@317 2138 let val _ = if FileBits.verbose ()
Chris@317 2139 then print ("Scanning IDs for lock file...\n")
Chris@317 2140 else ()
Chris@317 2141 val outcomes = map (fn lib =>
Chris@314 2142 (#libname lib, AnyLibControl.id_of context lib))
Chris@314 2143 libs
Chris@314 2144 val locks =
Chris@314 2145 List.concat
Chris@314 2146 (map (fn (libname, result) =>
Chris@314 2147 case result of
Chris@314 2148 ERROR _ => []
Chris@314 2149 | OK id => [{ libname = libname, id_or_tag = id }])
Chris@314 2150 outcomes)
Chris@314 2151 val return_code = return_code_for outcomes
Chris@314 2152 val _ = print clear_line
Chris@314 2153 in
Chris@314 2154 if OS.Process.isSuccess return_code
Chris@314 2155 then save_lock_file (#rootpath context) locks
Chris@314 2156 else ();
Chris@314 2157 return_code
Chris@314 2158 end
Chris@317 2159
Chris@317 2160 fun update_project (project as { context, libs }) =
Chris@317 2161 let val outcomes = act_and_print
Chris@317 2162 (AnyLibControl.update context)
Chris@317 2163 print_outcome_header print_update_outcome libs
Chris@317 2164 val _ = if List.exists (fn (_, OK _) => true | _ => false) outcomes
Chris@317 2165 then lock_project project
Chris@317 2166 else OS.Process.success
Chris@317 2167 in
Chris@317 2168 return_code_for outcomes
Chris@317 2169 end
Chris@315 2170
Chris@303 2171 fun load_local_project pintype =
Chris@303 2172 let val userconfig = load_userconfig ()
Chris@303 2173 val rootpath = OS.FileSys.getDir ()
Chris@303 2174 in
Chris@303 2175 load_project userconfig rootpath pintype
Chris@303 2176 end
Chris@303 2177
Chris@303 2178 fun with_local_project pintype f =
Chris@303 2179 let val return_code = f (load_local_project pintype)
Chris@315 2180 handle e => (print ("Error: " ^ exnMessage e);
Chris@315 2181 OS.Process.failure)
Chris@303 2182 val _ = print "\n";
Chris@303 2183 in
Chris@303 2184 return_code
Chris@303 2185 end
Chris@303 2186
Chris@314 2187 fun review () = with_local_project USE_LOCKFILE review_project
Chris@314 2188 fun status () = with_local_project USE_LOCKFILE status_of_project
Chris@303 2189 fun update () = with_local_project NO_LOCKFILE update_project
Chris@314 2190 fun lock () = with_local_project NO_LOCKFILE lock_project
Chris@303 2191 fun install () = with_local_project USE_LOCKFILE update_project
Chris@303 2192
Chris@303 2193 fun version () =
Chris@303 2194 (print ("v" ^ vext_version ^ "\n");
Chris@303 2195 OS.Process.success)
Chris@303 2196
Chris@303 2197 fun usage () =
Chris@303 2198 (print "\nVext ";
Chris@303 2199 version ();
Chris@303 2200 print ("\nA simple manager for third-party source code dependencies.\n\n"
Chris@303 2201 ^ "Usage:\n\n"
Chris@303 2202 ^ " vext <command>\n\n"
Chris@303 2203 ^ "where <command> is one of:\n\n"
Chris@303 2204 ^ " status print quick report on local status only, without using network\n"
Chris@303 2205 ^ " review check configured libraries against their providers, and report\n"
Chris@303 2206 ^ " install update configured libraries according to project specs and lock file\n"
Chris@303 2207 ^ " update update configured libraries and lock file according to project specs\n"
Chris@314 2208 ^ " lock update lock file to match local library status\n"
Chris@315 2209 ^ " archive pack up project and all libraries into an archive file\n"
Chris@315 2210 ^ " (invoke as 'vext archive target-file.tar.gz')\n"
Chris@303 2211 ^ " version print the Vext version number and exit\n\n");
Chris@303 2212 OS.Process.failure)
Chris@303 2213
Chris@315 2214 fun archive target args =
Chris@315 2215 case args of
Chris@315 2216 [] =>
Chris@315 2217 with_local_project USE_LOCKFILE (Archive.archive (target, []))
Chris@315 2218 | "--exclude"::xs =>
Chris@315 2219 with_local_project USE_LOCKFILE (Archive.archive (target, xs))
Chris@315 2220 | _ => usage ()
Chris@315 2221
Chris@303 2222 fun vext args =
Chris@303 2223 let val return_code =
Chris@303 2224 case args of
Chris@303 2225 ["review"] => review ()
Chris@303 2226 | ["status"] => status ()
Chris@303 2227 | ["install"] => install ()
Chris@303 2228 | ["update"] => update ()
Chris@314 2229 | ["lock"] => lock ()
Chris@303 2230 | ["version"] => version ()
Chris@315 2231 | "archive"::target::args => archive target args
Chris@303 2232 | _ => usage ()
Chris@303 2233 in
Chris@303 2234 OS.Process.exit return_code;
Chris@303 2235 ()
Chris@303 2236 end
Chris@303 2237
Chris@303 2238 fun main () =
Chris@303 2239 vext (CommandLine.arguments ())