Mercurial > hg > sonic-visualiser

comparison vext.sml @ 1733:d6d7c74c7eb7

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Merge from branch "vext"
author Chris Cannam
date Mon, 10 Jul 2017 14:04:44 +0100
parents 76872ffc03a3
children 669bd699082d
comparison
equal deleted inserted replaced
1714:b693b9218f66 1733:d6d7c74c7eb7
1 (* This file is automatically generated from the individual
2 source files in the Vext repository. *)
3
4 (*
5 Vext
6
7 A simple manager for third-party source code dependencies
8
9 Copyright 2017 Chris Cannam.
10
11 Permission is hereby granted, free of charge, to any person
12 obtaining a copy of this software and associated documentation
13 files (the "Software"), to deal in the Software without
14 restriction, including without limitation the rights to use, copy,
15 modify, merge, publish, distribute, sublicense, and/or sell copies
16 of the Software, and to permit persons to whom the Software is
17 furnished to do so, subject to the following conditions:
18
19 The above copyright notice and this permission notice shall be
20 included in all copies or substantial portions of the Software.
21
22 THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
23 EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
24 MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
25 NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR
26 ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF
27 CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
28 WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
29
30 Except as contained in this notice, the names of Chris Cannam and
31 Particular Programs Ltd shall not be used in advertising or
32 otherwise to promote the sale, use or other dealings in this
33 Software without prior written authorization.
34 *)
35
36 val vext_version = "0.9.4"
37
38
39 datatype vcs =
40 HG |
41 GIT
42
43 datatype source =
44 URL_SOURCE of string |
45 SERVICE_SOURCE of {
46 service : string,
47 owner : string option,
48 repo : string option
49 }
50
51 datatype pin =
52 UNPINNED |
53 PINNED of string
54
55 datatype libstate =
56 ABSENT |
57 CORRECT |
58 SUPERSEDED |
59 WRONG
60
61 datatype localstate =
62 MODIFIED |
63 UNMODIFIED
64
65 datatype branch =
66 BRANCH of string |
67 DEFAULT_BRANCH
68
69 (* If we can recover from an error, for example by reporting failure
70 for this one thing and going on to the next thing, then the error
71 should usually be returned through a result type rather than an
72 exception. *)
73
74 datatype 'a result =
75 OK of 'a |
76 ERROR of string
77
78 type libname = string
79
80 type id_or_tag = string
81
82 type libspec = {
83 libname : libname,
84 vcs : vcs,
85 source : source,
86 branch : branch,
87 pin : pin
88 }
89
90 type lock = {
91 libname : libname,
92 id_or_tag : id_or_tag
93 }
94
95 type remote_spec = {
96 anon : string option,
97 auth : string option
98 }
99
100 type provider = {
101 service : string,
102 supports : vcs list,
103 remote_spec : remote_spec
104 }
105
106 type account = {
107 service : string,
108 login : string
109 }
110
111 type context = {
112 rootpath : string,
113 extdir : string,
114 providers : provider list,
115 accounts : account list
116 }
117
118 type userconfig = {
119 providers : provider list,
120 accounts : account list
121 }
122
123 type project = {
124 context : context,
125 libs : libspec list
126 }
127
128 structure VextFilenames = struct
129 val project_file = "vext-project.json"
130 val project_lock_file = "vext-lock.json"
131 val user_config_file = ".vext.json"
132 end
133
134 signature VCS_CONTROL = sig
135
136 (** Test whether the library is present locally at all *)
137 val exists : context -> libname -> bool result
138
139 (** Return the id (hash) of the current revision for the library *)
140 val id_of : context -> libname -> id_or_tag result
141
142 (** Test whether the library is at the given id *)
143 val is_at : context -> libname * id_or_tag -> bool result
144
145 (** Test whether the library is on the given branch, i.e. is at
146 the branch tip or an ancestor of it *)
147 val is_on_branch : context -> libname * branch -> bool result
148
149 (** Test whether the library is at the newest revision for the
150 given branch. False may indicate that the branch has advanced
151 or that the library is not on the branch at all. This function
152 may use the network to check for new revisions *)
153 val is_newest : context -> libname * branch -> bool result
154
155 (** Test whether the library is at the newest revision available
156 locally for the given branch. False may indicate that the
157 branch has advanced or that the library is not on the branch
158 at all. This function must not use the network *)
159 val is_newest_locally : context -> libname * branch -> bool result
160
161 (** Test whether the library has been modified in the local
162 working copy *)
163 val is_modified_locally : context -> libname -> bool result
164
165 (** Check out, i.e. clone a fresh copy of, the repo for the given
166 library on the given branch *)
167 val checkout : context -> libname * source * branch -> unit result
168
169 (** Update the library to the given branch tip *)
170 val update : context -> libname * branch -> id_or_tag result
171
172 (** Update the library to the given specific id or tag *)
173 val update_to : context -> libname * id_or_tag -> id_or_tag result
174 end
175
176 signature LIB_CONTROL = sig
177 val review : context -> libspec -> (libstate * localstate) result
178 val status : context -> libspec -> (libstate * localstate) result
179 val update : context -> libspec -> id_or_tag result
180 end
181
182 structure FileBits :> sig
183 val extpath : context -> string
184 val libpath : context -> libname -> string
185 val subpath : context -> libname -> string -> string
186 val command_output : context -> libname -> string list -> string result
187 val command : context -> libname -> string list -> unit result
188 val file_contents : string -> string
189 val mydir : unit -> string
190 val homedir : unit -> string
191 val mkpath : string -> unit result
192 val project_spec_path : string -> string
193 val project_lock_path : string -> string
194 val verbose : unit -> bool
195 end = struct
196
197 fun verbose () =
198 case OS.Process.getEnv "VEXT_VERBOSE" of
199 SOME "0" => false
200 | SOME _ => true
201 | NONE => false
202
203 fun extpath ({ rootpath, extdir, ... } : context) =
204 let val { isAbs, vol, arcs } = OS.Path.fromString rootpath
205 in OS.Path.toString {
206 isAbs = isAbs,
207 vol = vol,
208 arcs = arcs @ [ extdir ]
209 }
210 end
211
212 fun subpath ({ rootpath, extdir, ... } : context) libname remainder =
213 (* NB libname is allowed to be a path fragment, e.g. foo/bar *)
214 let val { isAbs, vol, arcs } = OS.Path.fromString rootpath
215 val split = String.fields (fn c => c = #"/")
216 in OS.Path.toString {
217 isAbs = isAbs,
218 vol = vol,
219 arcs = arcs @ [ extdir ] @ split libname @ split remainder
220 }
221 end
222
223 fun libpath context "" =
224 extpath context
225 | libpath context libname =
226 subpath context libname ""
227
228 fun project_file_path rootpath filename =
229 let val { isAbs, vol, arcs } = OS.Path.fromString rootpath
230 in OS.Path.toString {
231 isAbs = isAbs,
232 vol = vol,
233 arcs = arcs @ [ filename ]
234 }
235 end
236
237 fun project_spec_path rootpath =
238 project_file_path rootpath (VextFilenames.project_file)
239
240 fun project_lock_path rootpath =
241 project_file_path rootpath (VextFilenames.project_lock_file)
242
243 fun trim str =
244 hd (String.fields (fn x => x = #"\n" orelse x = #"\r") str)
245
246 fun file_contents filename =
247 let val stream = TextIO.openIn filename
248 fun read_all str acc =
249 case TextIO.inputLine str of
250 SOME line => read_all str (trim line :: acc)
251 | NONE => rev acc
252 val contents = read_all stream []
253 val _ = TextIO.closeIn stream
254 in
255 String.concatWith "\n" contents
256 end
257
258 fun expand_commandline cmdlist =
259 (* We are quite [too] strict about what we accept here, except
260 for the first element in cmdlist which is assumed to be a
261 known command location rather than arbitrary user input. NB
262 only ASCII accepted at this point. *)
263 let open Char
264 fun quote arg =
265 if List.all
266 (fn c => isAlphaNum c orelse c = #"-" orelse c = #"_")
267 (explode arg)
268 then arg
269 else "\"" ^ arg ^ "\""
270 fun check arg =
271 let val valid = explode " /#:;?,._-{}@="
272 in
273 app (fn c =>
274 if isAlphaNum c orelse
275 List.exists (fn v => v = c) valid
276 then ()
277 else raise Fail ("Invalid character '" ^
278 (Char.toString c) ^
279 "' in command list"))
280 (explode arg);
281 arg
282 end
283 in
284 String.concatWith " "
285 (map quote
286 (hd cmdlist :: map check (tl cmdlist)))
287 end
288
289 val tick_cycle = ref 0
290 val tick_chars = Vector.fromList (map String.str (explode "|/-\\"))
291
292 fun tick libname cmdlist =
293 let val n = Vector.length tick_chars
294 fun pad_to n str =
295 if n <= String.size str then str
296 else pad_to n (str ^ " ")
297 val name = if libname <> "" then libname
298 else if cmdlist = nil then ""
299 else hd (rev cmdlist)
300 in
301 print (" " ^
302 Vector.sub(tick_chars, !tick_cycle) ^ " " ^
303 pad_to 24 name ^
304 "\r");
305 tick_cycle := (if !tick_cycle = n - 1 then 0 else 1 + !tick_cycle)
306 end
307
308 fun run_command context libname cmdlist redirect =
309 let open OS
310 val dir = libpath context libname
311 val cmd = expand_commandline cmdlist
312 val _ = if verbose ()
313 then print ("Running: " ^ cmd ^
314 " (in dir " ^ dir ^ ")...\n")
315 else tick libname cmdlist
316 val _ = FileSys.chDir dir
317 val status = case redirect of
318 NONE => Process.system cmd
319 | SOME file => Process.system (cmd ^ ">" ^ file)
320 in
321 if Process.isSuccess status
322 then OK ()
323 else ERROR ("Command failed: " ^ cmd ^ " (in dir " ^ dir ^ ")")
324 end
325 handle ex => ERROR ("Unable to run command: " ^ exnMessage ex)
326
327 fun command context libname cmdlist =
328 run_command context libname cmdlist NONE
329
330 fun command_output context libname cmdlist =
331 let open OS
332 val tmpFile = FileSys.tmpName ()
333 val result = run_command context libname cmdlist (SOME tmpFile)
334 val contents = file_contents tmpFile
335 in
336 FileSys.remove tmpFile handle _ => ();
337 case result of
338 OK () => OK contents
339 | ERROR e => ERROR e
340 end
341
342 fun mydir () =
343 let open OS
344 val { dir, file } = Path.splitDirFile (CommandLine.name ())
345 in
346 FileSys.realPath
347 (if Path.isAbsolute dir
348 then dir
349 else Path.concat (FileSys.getDir (), dir))
350 end
351
352 fun homedir () =
353 (* Failure is not routine, so we use an exception here *)
354 case (OS.Process.getEnv "HOME",
355 OS.Process.getEnv "HOMEPATH") of
356 (SOME home, _) => home
357 | (NONE, SOME home) => home
358 | (NONE, NONE) =>
359 raise Fail "Failed to look up home directory from environment"
360
361 fun mkpath path =
362 if OS.FileSys.isDir path handle _ => false
363 then OK ()
364 else case OS.Path.fromString path of
365 { arcs = nil, ... } => OK ()
366 | { isAbs = false, ... } => ERROR "mkpath requires absolute path"
367 | { isAbs, vol, arcs } =>
368 case mkpath (OS.Path.toString { (* parent *)
369 isAbs = isAbs,
370 vol = vol,
371 arcs = rev (tl (rev arcs)) }) of
372 ERROR e => ERROR e
373 | OK () => ((OS.FileSys.mkDir path; OK ())
374 handle OS.SysErr (e, _) =>
375 ERROR ("Directory creation failed: " ^ e))
376 end
377
378 functor LibControlFn (V: VCS_CONTROL) :> LIB_CONTROL = struct
379
380 (* Valid states for unpinned libraries:
381
382 - CORRECT: We are on the right branch and are up-to-date with
383 it as far as we can tell. (If not using the network, this
384 should be reported to user as "Present" rather than "Correct"
385 as the remote repo may have advanced without us knowing.)
386
387 - SUPERSEDED: We are on the right branch but we can see that
388 there is a newer revision either locally or on the remote (in
389 Git terms, we are at an ancestor of the desired branch tip).
390
391 - WRONG: We are on the wrong branch (in Git terms, we are not
392 at the desired branch tip or any ancestor of it).
393
394 - ABSENT: Repo doesn't exist here at all.
395
396 Valid states for pinned libraries:
397
398 - CORRECT: We are at the pinned revision.
399
400 - WRONG: We are at any revision other than the pinned one.
401
402 - ABSENT: Repo doesn't exist here at all.
403 *)
404
405 fun check with_network context ({ libname, branch, pin, ... } : libspec) =
406 let fun check_unpinned () =
407 let val is_newest = if with_network
408 then V.is_newest
409 else V.is_newest_locally
410 in
411 case is_newest context (libname, branch) of
412 ERROR e => ERROR e
413 | OK true => OK CORRECT
414 | OK false =>
415 case V.is_on_branch context (libname, branch) of
416 ERROR e => ERROR e
417 | OK true => OK SUPERSEDED
418 | OK false => OK WRONG
419 end
420 fun check_pinned target =
421 case V.is_at context (libname, target) of
422 ERROR e => ERROR e
423 | OK true => OK CORRECT
424 | OK false => OK WRONG
425 fun check' () =
426 case pin of
427 UNPINNED => check_unpinned ()
428 | PINNED target => check_pinned target
429 in
430 case V.exists context libname of
431 ERROR e => ERROR e
432 | OK false => OK (ABSENT, UNMODIFIED)
433 | OK true =>
434 case (check' (), V.is_modified_locally context libname) of
435 (ERROR e, _) => ERROR e
436 | (_, ERROR e) => ERROR e
437 | (OK state, OK true) => OK (state, MODIFIED)
438 | (OK state, OK false) => OK (state, UNMODIFIED)
439 end
440
441 val review = check true
442 val status = check false
443
444 fun update context ({ libname, source, branch, pin, ... } : libspec) =
445 let fun update_unpinned () =
446 case V.is_newest context (libname, branch) of
447 ERROR e => ERROR e
448 | OK true => V.id_of context libname
449 | OK false => V.update context (libname, branch)
450 fun update_pinned target =
451 case V.is_at context (libname, target) of
452 ERROR e => ERROR e
453 | OK true => OK target
454 | OK false => V.update_to context (libname, target)
455 fun update' () =
456 case pin of
457 UNPINNED => update_unpinned ()
458 | PINNED target => update_pinned target
459 in
460 case V.exists context libname of
461 ERROR e => ERROR e
462 | OK true => update' ()
463 | OK false =>
464 case V.checkout context (libname, source, branch) of
465 ERROR e => ERROR e
466 | OK () => update' ()
467 end
468 end
469
470 (* Simple Standard ML JSON parser
471 ==============================
472
473 https://bitbucket.org/cannam/sml-simplejson
474
475 An RFC-compliant JSON parser in one SML file with no dependency
476 on anything outside the Basis library. Also includes a simple
477 serialiser.
478
479 Tested with MLton, Poly/ML, and SML/NJ compilers.
480
481 Parser notes:
482
483 * Complies with RFC 7159, The JavaScript Object Notation (JSON)
484 Data Interchange Format
485
486 * Passes all of the JSONTestSuite parser accept/reject tests that
487 exist at the time of writing, as listed in "Parsing JSON is a
488 Minefield" (http://seriot.ch/parsing_json.php)
489
490 * Two-pass parser using naive exploded strings, therefore not
491 particularly fast and not suitable for large input files
492
493 * Only supports UTF-8 input, not UTF-16 or UTF-32. Doesn't check
494 that JSON strings are valid UTF-8 -- the caller must do that --
495 but does handle \u escapes
496
497 * Converts all numbers to type "real". If that is a 64-bit IEEE
498 float type (common but not guaranteed in SML) then we're pretty
499 standard for a JSON parser
500
501 Copyright 2017 Chris Cannam.
502 Parts based on the JSON parser in the Ponyo library by Phil Eaton.
503
504 Permission is hereby granted, free of charge, to any person
505 obtaining a copy of this software and associated documentation
506 files (the "Software"), to deal in the Software without
507 restriction, including without limitation the rights to use, copy,
508 modify, merge, publish, distribute, sublicense, and/or sell copies
509 of the Software, and to permit persons to whom the Software is
510 furnished to do so, subject to the following conditions:
511
512 The above copyright notice and this permission notice shall be
513 included in all copies or substantial portions of the Software.
514
515 THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
516 EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
517 MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
518 NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR
519 ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF
520 CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
521 WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
522
523 Except as contained in this notice, the names of Chris Cannam and
524 Particular Programs Ltd shall not be used in advertising or
525 otherwise to promote the sale, use or other dealings in this
526 Software without prior written authorization.
527 *)
528
529 signature JSON = sig
530
531 datatype json = OBJECT of (string * json) list
532 | ARRAY of json list
533 | NUMBER of real
534 | STRING of string
535 | BOOL of bool
536 | NULL
537
538 datatype 'a result = OK of 'a
539 | ERROR of string
540
541 val parse : string -> json result
542 val serialise : json -> string
543 val serialiseIndented : json -> string
544
545 end
546
547 structure Json :> JSON = struct
548
549 datatype json = OBJECT of (string * json) list
550 | ARRAY of json list
551 | NUMBER of real
552 | STRING of string
553 | BOOL of bool
554 | NULL
555
556 datatype 'a result = OK of 'a
557 | ERROR of string
558
559 structure T = struct
560 datatype token = NUMBER of char list
561 | STRING of string
562 | BOOL of bool
563 | NULL
564 | CURLY_L
565 | CURLY_R
566 | SQUARE_L
567 | SQUARE_R
568 | COLON
569 | COMMA
570
571 fun toString t =
572 case t of NUMBER digits => implode digits
573 | STRING s => s
574 | BOOL b => Bool.toString b
575 | NULL => "null"
576 | CURLY_L => "{"
577 | CURLY_R => "}"
578 | SQUARE_L => "["
579 | SQUARE_R => "]"
580 | COLON => ":"
581 | COMMA => ","
582 end
583
584 fun bmpToUtf8 cp = (* convert a codepoint in Unicode BMP to utf8 bytes *)
585 let open Word
586 infix 6 orb andb >>
587 in
588 map (Char.chr o toInt)
589 (if cp < 0wx80 then
590 [cp]
591 else if cp < 0wx800 then
592 [0wxc0 orb (cp >> 0w6), 0wx80 orb (cp andb 0wx3f)]
593 else if cp < 0wx10000 then
594 [0wxe0 orb (cp >> 0w12),
595 0wx80 orb ((cp >> 0w6) andb 0wx3f),
596 0wx80 orb (cp andb 0wx3f)]
597 else raise Fail ("Invalid BMP point " ^ (Word.toString cp)))
598 end
599
600 fun error pos text = ERROR (text ^ " at character position " ^
601 Int.toString (pos - 1))
602 fun token_error pos = error pos ("Unexpected token")
603
604 fun lexNull pos acc (#"u" :: #"l" :: #"l" :: xs) =
605 lex (pos + 3) (T.NULL :: acc) xs
606 | lexNull pos acc _ = token_error pos
607
608 and lexTrue pos acc (#"r" :: #"u" :: #"e" :: xs) =
609 lex (pos + 3) (T.BOOL true :: acc) xs
610 | lexTrue pos acc _ = token_error pos
611
612 and lexFalse pos acc (#"a" :: #"l" :: #"s" :: #"e" :: xs) =
613 lex (pos + 4) (T.BOOL false :: acc) xs
614 | lexFalse pos acc _ = token_error pos
615
616 and lexChar tok pos acc xs =
617 lex pos (tok :: acc) xs
618
619 and lexString pos acc cc =
620 let datatype escaped = ESCAPED | NORMAL
621 fun lexString' pos text ESCAPED [] =
622 error pos "End of input during escape sequence"
623 | lexString' pos text NORMAL [] =
624 error pos "End of input during string"
625 | lexString' pos text ESCAPED (x :: xs) =
626 let fun esc c = lexString' (pos + 1) (c :: text) NORMAL xs
627 in case x of
628 #"\"" => esc x
629 | #"\\" => esc x
630 | #"/" => esc x
631 | #"b" => esc #"\b"
632 | #"f" => esc #"\f"
633 | #"n" => esc #"\n"
634 | #"r" => esc #"\r"
635 | #"t" => esc #"\t"
636 | _ => error pos ("Invalid escape \\" ^
637 Char.toString x)
638 end
639 | lexString' pos text NORMAL (#"\\" :: #"u" ::a::b::c::d:: xs) =
640 if List.all Char.isHexDigit [a,b,c,d]
641 then case Word.fromString ("0wx" ^ (implode [a,b,c,d])) of
642 SOME w => (let val utf = rev (bmpToUtf8 w) in
643 lexString' (pos + 6) (utf @ text)
644 NORMAL xs
645 end
646 handle Fail err => error pos err)
647 | NONE => error pos "Invalid Unicode BMP escape sequence"
648 else error pos "Invalid Unicode BMP escape sequence"
649 | lexString' pos text NORMAL (x :: xs) =
650 if Char.ord x < 0x20
651 then error pos "Invalid unescaped control character"
652 else
653 case x of
654 #"\"" => OK (rev text, xs, pos + 1)
655 | #"\\" => lexString' (pos + 1) text ESCAPED xs
656 | _ => lexString' (pos + 1) (x :: text) NORMAL xs
657 in
658 case lexString' pos [] NORMAL cc of
659 OK (text, rest, newpos) =>
660 lex newpos (T.STRING (implode text) :: acc) rest
661 | ERROR e => ERROR e
662 end
663
664 and lexNumber firstChar pos acc cc =
665 let val valid = explode ".+-e"
666 fun lexNumber' pos digits [] = (rev digits, [], pos)
667 | lexNumber' pos digits (x :: xs) =
668 if x = #"E" then lexNumber' (pos + 1) (#"e" :: digits) xs
669 else if Char.isDigit x orelse List.exists (fn c => x = c) valid
670 then lexNumber' (pos + 1) (x :: digits) xs
671 else (rev digits, x :: xs, pos)
672 val (digits, rest, newpos) =
673 lexNumber' (pos - 1) [] (firstChar :: cc)
674 in
675 case digits of
676 [] => token_error pos
677 | _ => lex newpos (T.NUMBER digits :: acc) rest
678 end
679
680 and lex pos acc [] = OK (rev acc)
681 | lex pos acc (x::xs) =
682 (case x of
683 #" " => lex
684 | #"\t" => lex
685 | #"\n" => lex
686 | #"\r" => lex
687 | #"{" => lexChar T.CURLY_L
688 | #"}" => lexChar T.CURLY_R
689 | #"[" => lexChar T.SQUARE_L
690 | #"]" => lexChar T.SQUARE_R
691 | #":" => lexChar T.COLON
692 | #"," => lexChar T.COMMA
693 | #"\"" => lexString
694 | #"t" => lexTrue
695 | #"f" => lexFalse
696 | #"n" => lexNull
697 | x => lexNumber x) (pos + 1) acc xs
698
699 fun show [] = "end of input"
700 | show (tok :: _) = T.toString tok
701
702 fun parseNumber digits =
703 (* Note lexNumber already case-insensitised the E for us *)
704 let open Char
705
706 fun okExpDigits [] = false
707 | okExpDigits (c :: []) = isDigit c
708 | okExpDigits (c :: cs) = isDigit c andalso okExpDigits cs
709
710 fun okExponent [] = false
711 | okExponent (#"+" :: cs) = okExpDigits cs
712 | okExponent (#"-" :: cs) = okExpDigits cs
713 | okExponent cc = okExpDigits cc
714
715 fun okFracTrailing [] = true
716 | okFracTrailing (c :: cs) =
717 (isDigit c andalso okFracTrailing cs) orelse
718 (c = #"e" andalso okExponent cs)
719
720 fun okFraction [] = false
721 | okFraction (c :: cs) =
722 isDigit c andalso okFracTrailing cs
723
724 fun okPosTrailing [] = true
725 | okPosTrailing (#"." :: cs) = okFraction cs
726 | okPosTrailing (#"e" :: cs) = okExponent cs
727 | okPosTrailing (c :: cs) =
728 isDigit c andalso okPosTrailing cs
729
730 fun okPositive [] = false
731 | okPositive (#"0" :: []) = true
732 | okPositive (#"0" :: #"." :: cs) = okFraction cs
733 | okPositive (#"0" :: #"e" :: cs) = okExponent cs
734 | okPositive (#"0" :: cs) = false
735 | okPositive (c :: cs) = isDigit c andalso okPosTrailing cs
736
737 fun okNumber (#"-" :: cs) = okPositive cs
738 | okNumber cc = okPositive cc
739 in
740 if okNumber digits
741 then case Real.fromString (implode digits) of
742 NONE => ERROR "Number out of range"
743 | SOME r => OK r
744 else ERROR ("Invalid number \"" ^ (implode digits) ^ "\"")
745 end
746
747 fun parseObject (T.CURLY_R :: xs) = OK (OBJECT [], xs)
748 | parseObject tokens =
749 let fun parsePair (T.STRING key :: T.COLON :: xs) =
750 (case parseTokens xs of
751 ERROR e => ERROR e
752 | OK (j, xs) => OK ((key, j), xs))
753 | parsePair other =
754 ERROR ("Object key/value pair expected around \"" ^
755 show other ^ "\"")
756 fun parseObject' acc [] = ERROR "End of input during object"
757 | parseObject' acc tokens =
758 case parsePair tokens of
759 ERROR e => ERROR e
760 | OK (pair, T.COMMA :: xs) =>
761 parseObject' (pair :: acc) xs
762 | OK (pair, T.CURLY_R :: xs) =>
763 OK (OBJECT (rev (pair :: acc)), xs)
764 | OK (_, _) => ERROR "Expected , or } after object element"
765 in
766 parseObject' [] tokens
767 end
768
769 and parseArray (T.SQUARE_R :: xs) = OK (ARRAY [], xs)
770 | parseArray tokens =
771 let fun parseArray' acc [] = ERROR "End of input during array"
772 | parseArray' acc tokens =
773 case parseTokens tokens of
774 ERROR e => ERROR e
775 | OK (j, T.COMMA :: xs) => parseArray' (j :: acc) xs
776 | OK (j, T.SQUARE_R :: xs) => OK (ARRAY (rev (j :: acc)), xs)
777 | OK (_, _) => ERROR "Expected , or ] after array element"
778 in
779 parseArray' [] tokens
780 end
781
782 and parseTokens [] = ERROR "Value expected"
783 | parseTokens (tok :: xs) =
784 (case tok of
785 T.NUMBER d => (case parseNumber d of
786 OK r => OK (NUMBER r, xs)
787 | ERROR e => ERROR e)
788 | T.STRING s => OK (STRING s, xs)
789 | T.BOOL b => OK (BOOL b, xs)
790 | T.NULL => OK (NULL, xs)
791 | T.CURLY_L => parseObject xs
792 | T.SQUARE_L => parseArray xs
793 | _ => ERROR ("Unexpected token " ^ T.toString tok ^
794 " before " ^ show xs))
795
796 fun parse str =
797 case lex 1 [] (explode str) of
798 ERROR e => ERROR e
799 | OK tokens => case parseTokens tokens of
800 OK (value, []) => OK value
801 | OK (_, _) => ERROR "Extra data after input"
802 | ERROR e => ERROR e
803
804 fun stringEscape s =
805 let fun esc x = [x, #"\\"]
806 fun escape' acc [] = rev acc
807 | escape' acc (x :: xs) =
808 escape' (case x of
809 #"\"" => esc x @ acc
810 | #"\\" => esc x @ acc
811 | #"\b" => esc #"b" @ acc
812 | #"\f" => esc #"f" @ acc
813 | #"\n" => esc #"n" @ acc
814 | #"\r" => esc #"r" @ acc
815 | #"\t" => esc #"t" @ acc
816 | _ =>
817 let val c = Char.ord x
818 in
819 if c < 0x20
820 then let val hex = Word.toString (Word.fromInt c)
821 in (rev o explode) (if c < 0x10
822 then ("\\u000" ^ hex)
823 else ("\\u00" ^ hex))
824 end @ acc
825 else
826 x :: acc
827 end)
828 xs
829 in
830 implode (escape' [] (explode s))
831 end
832
833 fun serialise json =
834 case json of
835 OBJECT pp => "{" ^ String.concatWith
836 "," (map (fn (key, value) =>
837 serialise (STRING key) ^ ":" ^
838 serialise value) pp) ^
839 "}"
840 | ARRAY arr => "[" ^ String.concatWith "," (map serialise arr) ^ "]"
841 | NUMBER n => implode (map (fn #"~" => #"-" | c => c)
842 (explode (Real.toString n)))
843 | STRING s => "\"" ^ stringEscape s ^ "\""
844 | BOOL b => Bool.toString b
845 | NULL => "null"
846
847 fun serialiseIndented json =
848 let fun indent 0 = ""
849 | indent i = " " ^ indent (i - 1)
850 fun serialiseIndented' i json =
851 let val ser = serialiseIndented' (i + 1)
852 in
853 case json of
854 OBJECT [] => "{}"
855 | ARRAY [] => "[]"
856 | OBJECT pp => "{\n" ^ indent (i + 1) ^
857 String.concatWith
858 (",\n" ^ indent (i + 1))
859 (map (fn (key, value) =>
860 ser (STRING key) ^ ": " ^
861 ser value) pp) ^
862 "\n" ^ indent i ^ "}"
863 | ARRAY arr => "[\n" ^ indent (i + 1) ^
864 String.concatWith
865 (",\n" ^ indent (i + 1))
866 (map ser arr) ^
867 "\n" ^ indent i ^ "]"
868 | other => serialise other
869 end
870 in
871 serialiseIndented' 0 json ^ "\n"
872 end
873
874 end
875
876
877 structure JsonBits :> sig
878 val load_json_from : string -> Json.json (* filename -> json *)
879 val save_json_to : string -> Json.json -> unit
880 val lookup_optional : Json.json -> string list -> Json.json option
881 val lookup_optional_string : Json.json -> string list -> string option
882 val lookup_mandatory : Json.json -> string list -> Json.json
883 val lookup_mandatory_string : Json.json -> string list -> string
884 end = struct
885
886 fun load_json_from filename =
887 case Json.parse (FileBits.file_contents filename) of
888 Json.OK json => json
889 | Json.ERROR e => raise Fail ("Failed to parse file: " ^ e)
890
891 fun save_json_to filename json =
892 (* using binary I/O to avoid ever writing CR/LF line endings *)
893 let val jstr = Json.serialiseIndented json
894 val stream = BinIO.openOut filename
895 in
896 BinIO.output (stream, Byte.stringToBytes jstr);
897 BinIO.closeOut stream
898 end
899
900 fun lookup_optional json kk =
901 let fun lookup key =
902 case json of
903 Json.OBJECT kvs =>
904 (case List.find (fn (k, v) => k = key) kvs of
905 SOME (k, v) => SOME v
906 | NONE => NONE)
907 | _ => raise Fail "Object expected"
908 in
909 case kk of
910 [] => NONE
911 | key::[] => lookup key
912 | key::kk => case lookup key of
913 NONE => NONE
914 | SOME j => lookup_optional j kk
915 end
916
917 fun lookup_optional_string json kk =
918 case lookup_optional json kk of
919 SOME (Json.STRING s) => SOME s
920 | SOME _ => raise Fail ("Value (if present) must be string: " ^
921 (String.concatWith " -> " kk))
922 | NONE => NONE
923
924 fun lookup_mandatory json kk =
925 case lookup_optional json kk of
926 SOME v => v
927 | NONE => raise Fail ("Value is mandatory: " ^
928 (String.concatWith " -> " kk) ^ " in json: " ^
929 (Json.serialise json))
930
931 fun lookup_mandatory_string json kk =
932 case lookup_optional json kk of
933 SOME (Json.STRING s) => s
934 | _ => raise Fail ("Value must be string: " ^
935 (String.concatWith " -> " kk))
936 end
937
938 structure Provider :> sig
939 val load_providers : Json.json -> provider list
940 val load_more_providers : provider list -> Json.json -> provider list
941 val remote_url : context -> vcs -> source -> libname -> string
942 end = struct
943
944 val known_providers : provider list =
945 [ {
946 service = "bitbucket",
947 supports = [HG, GIT],
948 remote_spec = {
949 anon = SOME "https://bitbucket.org/{owner}/{repository}",
950 auth = SOME "ssh://{vcs}@bitbucket.org/{owner}/{repository}"
951 }
952 },
953 {
954 service = "github",
955 supports = [GIT],
956 remote_spec = {
957 anon = SOME "https://github.com/{owner}/{repository}",
958 auth = SOME "ssh://{vcs}@github.com/{owner}/{repository}"
959 }
960 }
961 ]
962
963 fun vcs_name vcs =
964 case vcs of GIT => "git" |
965 HG => "hg"
966
967 fun vcs_from_name name =
968 case name of "git" => GIT
969 | "hg" => HG
970 | other => raise Fail ("Unknown vcs name \"" ^ name ^ "\"")
971
972 fun load_more_providers previously_loaded json =
973 let open JsonBits
974 fun load pjson pname : provider =
975 {
976 service = pname,
977 supports =
978 case lookup_mandatory pjson ["vcs"] of
979 Json.ARRAY vv =>
980 map (fn (Json.STRING v) => vcs_from_name v
981 | _ => raise Fail "Strings expected in vcs array")
982 vv
983 | _ => raise Fail "Array expected for vcs",
984 remote_spec = {
985 anon = lookup_optional_string pjson ["anonymous"],
986 auth = lookup_optional_string pjson ["authenticated"]
987 }
988 }
989 val loaded =
990 case lookup_optional json ["services"] of
991 NONE => []
992 | SOME (Json.OBJECT pl) => map (fn (k, v) => load v k) pl
993 | _ => raise Fail "Object expected for services in config"
994 val newly_loaded =
995 List.filter (fn p => not (List.exists (fn pp => #service p =
996 #service pp)
997 previously_loaded))
998 loaded
999 in
1000 previously_loaded @ newly_loaded
1001 end
1002
1003 fun load_providers json =
1004 load_more_providers known_providers json
1005
1006 fun expand_spec spec { vcs, service, owner, repo } login =
1007 (* ugly *)
1008 let fun replace str =
1009 case str of
1010 "vcs" => vcs_name vcs
1011 | "service" => service
1012 | "owner" =>
1013 (case owner of
1014 SOME ostr => ostr
1015 | NONE => raise Fail ("Owner not specified for service " ^
1016 service))
1017 | "repository" => repo
1018 | "account" =>
1019 (case login of
1020 SOME acc => acc
1021 | NONE => raise Fail ("Account not given for service " ^
1022 service))
1023 | other => raise Fail ("Unknown variable \"" ^ other ^
1024 "\" in spec for service " ^ service)
1025 fun expand' acc sstr =
1026 case Substring.splitl (fn c => c <> #"{") sstr of
1027 (pfx, sfx) =>
1028 if Substring.isEmpty sfx
1029 then rev (pfx :: acc)
1030 else
1031 case Substring.splitl (fn c => c <> #"}") sfx of
1032 (tok, remainder) =>
1033 if Substring.isEmpty remainder
1034 then rev (tok :: pfx :: acc)
1035 else let val replacement =
1036 replace
1037 (* tok begins with "{": *)
1038 (Substring.string
1039 (Substring.triml 1 tok))
1040 in
1041 expand' (Substring.full replacement ::
1042 pfx :: acc)
1043 (* remainder begins with "}": *)
1044 (Substring.triml 1 remainder)
1045 end
1046 in
1047 Substring.concat (expand' [] (Substring.full spec))
1048 end
1049
1050 fun provider_url req login providers =
1051 case providers of
1052 [] => raise Fail ("Unknown service \"" ^ (#service req) ^
1053 "\" for vcs \"" ^ (vcs_name (#vcs req)) ^ "\"")
1054 | ({ service, supports, remote_spec : remote_spec } :: rest) =>
1055 if service <> (#service req) orelse
1056 not (List.exists (fn v => v = (#vcs req)) supports)
1057 then provider_url req login rest
1058 else
1059 case (login, #auth remote_spec, #anon remote_spec) of
1060 (SOME _, SOME auth, _) => expand_spec auth req login
1061 | (SOME _, _, SOME anon) => expand_spec anon req NONE
1062 | (NONE, _, SOME anon) => expand_spec anon req NONE
1063 | _ => raise Fail ("No suitable anonymous or authenticated " ^
1064 "URL spec provided for service \"" ^
1065 service ^ "\"")
1066
1067 fun login_for ({ accounts, ... } : context) service =
1068 case List.find (fn a => service = #service a) accounts of
1069 SOME { login, ... } => SOME login
1070 | NONE => NONE
1071
1072 fun remote_url (context : context) vcs source libname =
1073 case source of
1074 URL_SOURCE u => u
1075 | SERVICE_SOURCE { service, owner, repo } =>
1076 provider_url { vcs = vcs,
1077 service = service,
1078 owner = owner,
1079 repo = case repo of
1080 SOME r => r
1081 | NONE => libname }
1082 (login_for context service)
1083 (#providers context)
1084 end
1085
1086 structure HgControl :> VCS_CONTROL = struct
1087
1088 type vcsstate = { id: string, modified: bool,
1089 branch: string, tags: string list }
1090
1091 val hg_args = [ "--config", "ui.interactive=true" ]
1092
1093 fun hg_command context libname args =
1094 FileBits.command context libname ("hg" :: hg_args @ args)
1095
1096 fun hg_command_output context libname args =
1097 FileBits.command_output context libname ("hg" :: hg_args @ args)
1098
1099 fun exists context libname =
1100 OK (OS.FileSys.isDir (FileBits.subpath context libname ".hg"))
1101 handle _ => OK false
1102
1103 fun remote_for context (libname, source) =
1104 Provider.remote_url context HG source libname
1105
1106 fun current_state context libname : vcsstate result =
1107 let fun is_branch text = text <> "" andalso #"(" = hd (explode text)
1108 and extract_branch b =
1109 if is_branch b (* need to remove enclosing parens *)
1110 then (implode o rev o tl o rev o tl o explode) b
1111 else "default"
1112 and is_modified id = id <> "" andalso #"+" = hd (rev (explode id))
1113 and extract_id id =
1114 if is_modified id (* need to remove trailing "+" *)
1115 then (implode o rev o tl o rev o explode) id
1116 else id
1117 and split_tags tags = String.tokens (fn c => c = #"/") tags
1118 and state_for (id, branch, tags) =
1119 OK { id = extract_id id,
1120 modified = is_modified id,
1121 branch = extract_branch branch,
1122 tags = split_tags tags }
1123 in
1124 case hg_command_output context libname ["id"] of
1125 ERROR e => ERROR e
1126 | OK out =>
1127 case String.tokens (fn x => x = #" ") out of
1128 [id, branch, tags] => state_for (id, branch, tags)
1129 | [id, other] => if is_branch other
1130 then state_for (id, other, "")
1131 else state_for (id, "", other)
1132 | [id] => state_for (id, "", "")
1133 | _ => ERROR ("Unexpected output from hg id: " ^ out)
1134 end
1135
1136 fun branch_name branch = case branch of
1137 DEFAULT_BRANCH => "default"
1138 | BRANCH "" => "default"
1139 | BRANCH b => b
1140
1141 fun id_of context libname =
1142 case current_state context libname of
1143 ERROR e => ERROR e
1144 | OK { id, ... } => OK id
1145
1146 fun is_at context (libname, id_or_tag) =
1147 case current_state context libname of
1148 ERROR e => ERROR e
1149 | OK { id, tags, ... } =>
1150 OK (String.isPrefix id_or_tag id orelse
1151 String.isPrefix id id_or_tag orelse
1152 List.exists (fn t => t = id_or_tag) tags)
1153
1154 fun is_on_branch context (libname, b) =
1155 case current_state context libname of
1156 ERROR e => ERROR e
1157 | OK { branch, ... } => OK (branch = branch_name b)
1158
1159 fun is_newest_locally context (libname, branch) =
1160 case hg_command_output context libname
1161 ["log", "-l1",
1162 "-b", branch_name branch,
1163 "--template", "{node}"] of
1164 ERROR e => ERROR e
1165 | OK newest_in_repo => is_at context (libname, newest_in_repo)
1166
1167 fun pull context libname =
1168 hg_command context libname
1169 (if FileBits.verbose ()
1170 then ["pull"]
1171 else ["pull", "-q"])
1172
1173 fun is_newest context (libname, branch) =
1174 case is_newest_locally context (libname, branch) of
1175 ERROR e => ERROR e
1176 | OK false => OK false
1177 | OK true =>
1178 case pull context libname of
1179 ERROR e => ERROR e
1180 | _ => is_newest_locally context (libname, branch)
1181
1182 fun is_modified_locally context libname =
1183 case current_state context libname of
1184 ERROR e => ERROR e
1185 | OK { modified, ... } => OK modified
1186
1187 fun checkout context (libname, source, branch) =
1188 let val url = remote_for context (libname, source)
1189 in
1190 case FileBits.mkpath (FileBits.extpath context) of
1191 ERROR e => ERROR e
1192 | _ => hg_command context ""
1193 ["clone", "-u", branch_name branch,
1194 url, libname]
1195 end
1196
1197 fun update context (libname, branch) =
1198 let val pull_result = pull context libname
1199 in
1200 case hg_command context libname ["update", branch_name branch] of
1201 ERROR e => ERROR e
1202 | _ =>
1203 case pull_result of
1204 ERROR e => ERROR e
1205 | _ => id_of context libname
1206 end
1207
1208 fun update_to context (libname, "") =
1209 ERROR "Non-empty id (tag or revision id) required for update_to"
1210 | update_to context (libname, id) =
1211 let val pull_result = pull context libname
1212 in
1213 case hg_command context libname ["update", "-r", id] of
1214 OK _ => id_of context libname
1215 | ERROR e =>
1216 case pull_result of
1217 ERROR e' => ERROR e' (* this was the ur-error *)
1218 | _ => ERROR e
1219 end
1220
1221 end
1222
1223 structure GitControl :> VCS_CONTROL = struct
1224
1225 (* With Git repos we always operate in detached HEAD state. Even
1226 the master branch is checked out using the remote reference,
1227 origin/master. *)
1228
1229 fun git_command context libname args =
1230 FileBits.command context libname ("git" :: args)
1231
1232 fun git_command_output context libname args =
1233 FileBits.command_output context libname ("git" :: args)
1234
1235 fun exists context libname =
1236 OK (OS.FileSys.isDir (FileBits.subpath context libname ".git"))
1237 handle _ => OK false
1238
1239 fun remote_for context (libname, source) =
1240 Provider.remote_url context GIT source libname
1241
1242 fun branch_name branch = case branch of
1243 DEFAULT_BRANCH => "master"
1244 | BRANCH "" => "master"
1245 | BRANCH b => b
1246
1247 fun remote_branch_name branch = "origin/" ^ branch_name branch
1248
1249 fun checkout context (libname, source, branch) =
1250 let val url = remote_for context (libname, source)
1251 in
1252 case FileBits.mkpath (FileBits.extpath context) of
1253 OK () => git_command context ""
1254 ["clone", "-b",
1255 branch_name branch,
1256 url, libname]
1257 | ERROR e => ERROR e
1258 end
1259
1260 (* NB git rev-parse HEAD shows revision id of current checkout;
1261 git rev-list -1 <tag> shows revision id of revision with that tag *)
1262
1263 fun id_of context libname =
1264 git_command_output context libname ["rev-parse", "HEAD"]
1265
1266 fun is_at context (libname, id_or_tag) =
1267 case id_of context libname of
1268 ERROR e => ERROR e
1269 | OK id =>
1270 if String.isPrefix id_or_tag id orelse
1271 String.isPrefix id id_or_tag
1272 then OK true
1273 else
1274 case git_command_output context libname
1275 ["show-ref",
1276 "refs/tags/" ^ id_or_tag] of
1277 OK "" => OK false
1278 | ERROR _ => OK false
1279 | OK s => OK (id = hd (String.tokens (fn c => c = #" ") s))
1280
1281 fun branch_tip context (libname, branch) =
1282 git_command_output context libname
1283 ["rev-list", "-1",
1284 remote_branch_name branch]
1285
1286 fun is_newest_locally context (libname, branch) =
1287 case branch_tip context (libname, branch) of
1288 ERROR e => ERROR e
1289 | OK rev => is_at context (libname, rev)
1290
1291 fun is_on_branch context (libname, branch) =
1292 case branch_tip context (libname, branch) of
1293 ERROR e => ERROR e
1294 | OK rev =>
1295 case is_at context (libname, rev) of
1296 ERROR e => ERROR e
1297 | OK true => OK true
1298 | OK false =>
1299 case git_command context libname
1300 ["merge-base", "--is-ancestor",
1301 "HEAD", remote_branch_name branch] of
1302 ERROR e => OK false (* cmd returns non-zero for no *)
1303 | _ => OK true
1304
1305 fun is_newest context (libname, branch) =
1306 case is_newest_locally context (libname, branch) of
1307 ERROR e => ERROR e
1308 | OK false => OK false
1309 | OK true =>
1310 case git_command context libname ["fetch"] of
1311 ERROR e => ERROR e
1312 | _ => is_newest_locally context (libname, branch)
1313
1314 fun is_modified_locally context libname =
1315 case git_command_output context libname ["status", "--porcelain"] of
1316 ERROR e => ERROR e
1317 | OK "" => OK false
1318 | OK _ => OK true
1319
1320 (* This function updates to the latest revision on a branch rather
1321 than to a specific id or tag. We can't just checkout the given
1322 branch, as that will succeed even if the branch isn't up to
1323 date. We could checkout the branch and then fetch and merge,
1324 but it's perhaps cleaner not to maintain a local branch at all,
1325 but instead checkout the remote branch as a detached head. *)
1326
1327 fun update context (libname, branch) =
1328 case git_command context libname ["fetch"] of
1329 ERROR e => ERROR e
1330 | _ =>
1331 case git_command context libname ["checkout", "--detach",
1332 remote_branch_name branch] of
1333 ERROR e => ERROR e
1334 | _ => id_of context libname
1335
1336 (* This function is dealing with a specific id or tag, so if we
1337 can successfully check it out (detached) then that's all we
1338 need to do, regardless of whether fetch succeeded or not. We do
1339 attempt the fetch first, though, purely in order to avoid ugly
1340 error messages in the common case where we're being asked to
1341 update to a new pin (from the lock file) that hasn't been
1342 fetched yet. *)
1343
1344 fun update_to context (libname, "") =
1345 ERROR "Non-empty id (tag or revision id) required for update_to"
1346 | update_to context (libname, id) =
1347 let val fetch_result = git_command context libname ["fetch"]
1348 in
1349 case git_command context libname ["checkout", "--detach", id] of
1350 OK _ => id_of context libname
1351 | ERROR e =>
1352 case fetch_result of
1353 ERROR e' => ERROR e' (* this was the ur-error *)
1354 | _ => ERROR e
1355 end
1356
1357 end
1358
1359 structure AnyLibControl :> LIB_CONTROL = struct
1360
1361 structure H = LibControlFn(HgControl)
1362 structure G = LibControlFn(GitControl)
1363
1364 fun review context (spec as { vcs, ... } : libspec) =
1365 (fn HG => H.review | GIT => G.review) vcs context spec
1366
1367 fun status context (spec as { vcs, ... } : libspec) =
1368 (fn HG => H.status | GIT => G.status) vcs context spec
1369
1370 fun update context (spec as { vcs, ... } : libspec) =
1371 (fn HG => H.update | GIT => G.update) vcs context spec
1372 end
1373
1374 val libobjname = "libraries"
1375
1376 fun load_libspec spec_json lock_json libname : libspec =
1377 let open JsonBits
1378 val libobj = lookup_mandatory spec_json [libobjname, libname]
1379 val vcs = lookup_mandatory_string libobj ["vcs"]
1380 val retrieve = lookup_optional_string libobj
1381 val service = retrieve ["service"]
1382 val owner = retrieve ["owner"]
1383 val repo = retrieve ["repository"]
1384 val url = retrieve ["url"]
1385 val branch = retrieve ["branch"]
1386 val user_pin = retrieve ["pin"]
1387 val lock_pin = case lookup_optional lock_json [libobjname, libname] of
1388 SOME ll => lookup_optional_string ll ["pin"]
1389 | NONE => NONE
1390 in
1391 {
1392 libname = libname,
1393 vcs = case vcs of
1394 "hg" => HG
1395 | "git" => GIT
1396 | other => raise Fail ("Unknown version-control system \"" ^
1397 other ^ "\""),
1398 source = case (url, service, owner, repo) of
1399 (SOME u, NONE, _, _) => URL_SOURCE u
1400 | (NONE, SOME ss, owner, repo) =>
1401 SERVICE_SOURCE { service = ss, owner = owner, repo = repo }
1402 | _ => raise Fail ("Must have exactly one of service " ^
1403 "or url string"),
1404 pin = case lock_pin of
1405 SOME p => PINNED p
1406 | NONE =>
1407 case user_pin of
1408 SOME p => PINNED p
1409 | NONE => UNPINNED,
1410 branch = case branch of
1411 SOME b => BRANCH b
1412 | NONE => DEFAULT_BRANCH
1413 }
1414 end
1415
1416 fun load_userconfig () : userconfig =
1417 let val home = FileBits.homedir ()
1418 val conf_json =
1419 JsonBits.load_json_from
1420 (OS.Path.joinDirFile {
1421 dir = home,
1422 file = VextFilenames.user_config_file })
1423 handle IO.Io _ => Json.OBJECT []
1424 in
1425 {
1426 accounts = case JsonBits.lookup_optional conf_json ["accounts"] of
1427 NONE => []
1428 | SOME (Json.OBJECT aa) =>
1429 map (fn (k, (Json.STRING v)) =>
1430 { service = k, login = v }
1431 | _ => raise Fail
1432 "String expected for account name")
1433 aa
1434 | _ => raise Fail "Array expected for accounts",
1435 providers = Provider.load_providers conf_json
1436 }
1437 end
1438
1439 datatype pintype =
1440 NO_LOCKFILE |
1441 USE_LOCKFILE
1442
1443 fun load_project (userconfig : userconfig) rootpath pintype : project =
1444 let val spec_file = FileBits.project_spec_path rootpath
1445 val lock_file = FileBits.project_lock_path rootpath
1446 val _ = if OS.FileSys.access (spec_file, [OS.FileSys.A_READ])
1447 handle OS.SysErr _ => false
1448 then ()
1449 else raise Fail ("Failed to open project spec file " ^
1450 (VextFilenames.project_file) ^ " in " ^
1451 rootpath ^
1452 ".\nPlease ensure the spec file is in the " ^
1453 "project root and run this from there.")
1454 val spec_json = JsonBits.load_json_from spec_file
1455 val lock_json = if pintype = USE_LOCKFILE
1456 then JsonBits.load_json_from lock_file
1457 handle IO.Io _ => Json.OBJECT []
1458 else Json.OBJECT []
1459 val extdir = JsonBits.lookup_mandatory_string spec_json
1460 ["config", "extdir"]
1461 val spec_libs = JsonBits.lookup_optional spec_json [libobjname]
1462 val lock_libs = JsonBits.lookup_optional lock_json [libobjname]
1463 val providers = Provider.load_more_providers
1464 (#providers userconfig) spec_json
1465 val libnames = case spec_libs of
1466 NONE => []
1467 | SOME (Json.OBJECT ll) => map (fn (k, v) => k) ll
1468 | _ => raise Fail "Object expected for libs"
1469 in
1470 {
1471 context = {
1472 rootpath = rootpath,
1473 extdir = extdir,
1474 providers = providers,
1475 accounts = #accounts userconfig
1476 },
1477 libs = map (load_libspec spec_json lock_json) libnames
1478 }
1479 end
1480
1481 fun save_lock_file rootpath locks =
1482 let val lock_file = FileBits.project_lock_path rootpath
1483 open Json
1484 val lock_json =
1485 OBJECT [
1486 (libobjname,
1487 OBJECT (map (fn { libname, id_or_tag } =>
1488 (libname,
1489 OBJECT [ ("pin", STRING id_or_tag) ]))
1490 locks))
1491 ]
1492 in
1493 JsonBits.save_json_to lock_file lock_json
1494 end
1495
1496 fun pad_to n str =
1497 if n <= String.size str then str
1498 else pad_to n (str ^ " ")
1499
1500 fun hline_to 0 = ""
1501 | hline_to n = "-" ^ hline_to (n-1)
1502
1503 val libname_width = 25
1504 val libstate_width = 11
1505 val localstate_width = 9
1506 val notes_width = 5
1507 val divider = " | "
1508
1509 fun print_status_header () =
1510 print ("\r" ^ pad_to 80 "" ^ "\n " ^
1511 pad_to libname_width "Library" ^ divider ^
1512 pad_to libstate_width "State" ^ divider ^
1513 pad_to localstate_width "Local" ^ divider ^
1514 "Notes" ^ "\n " ^
1515 hline_to libname_width ^ "-+-" ^
1516 hline_to libstate_width ^ "-+-" ^
1517 hline_to localstate_width ^ "-+-" ^
1518 hline_to notes_width ^ "\n")
1519
1520 fun print_outcome_header () =
1521 print ("\r" ^ pad_to 80 "" ^ "\n " ^
1522 pad_to libname_width "Library" ^ divider ^
1523 pad_to libstate_width "Outcome" ^ divider ^
1524 "Notes" ^ "\n " ^
1525 hline_to libname_width ^ "-+-" ^
1526 hline_to libstate_width ^ "-+-" ^
1527 hline_to notes_width ^ "\n")
1528
1529 fun print_status with_network (libname, status) =
1530 let val libstate_str =
1531 case status of
1532 OK (ABSENT, _) => "Absent"
1533 | OK (CORRECT, _) => if with_network then "Correct" else "Present"
1534 | OK (SUPERSEDED, _) => "Superseded"
1535 | OK (WRONG, _) => "Wrong"
1536 | ERROR _ => "Error"
1537 val localstate_str =
1538 case status of
1539 OK (_, MODIFIED) => "Modified"
1540 | OK (_, UNMODIFIED) => "Clean"
1541 | _ => ""
1542 val error_str =
1543 case status of
1544 ERROR e => e
1545 | _ => ""
1546 in
1547 print (" " ^
1548 pad_to libname_width libname ^ divider ^
1549 pad_to libstate_width libstate_str ^ divider ^
1550 pad_to localstate_width localstate_str ^ divider ^
1551 error_str ^ "\n")
1552 end
1553
1554 fun print_update_outcome (libname, outcome) =
1555 let val outcome_str =
1556 case outcome of
1557 OK id => "Ok"
1558 | ERROR e => "Failed"
1559 val error_str =
1560 case outcome of
1561 ERROR e => e
1562 | _ => ""
1563 in
1564 print (" " ^
1565 pad_to libname_width libname ^ divider ^
1566 pad_to libstate_width outcome_str ^ divider ^
1567 error_str ^ "\n")
1568 end
1569
1570 fun act_and_print action print_header print_line (libs : libspec list) =
1571 let val lines = map (fn lib => (#libname lib, action lib)) libs
1572 val _ = print_header ()
1573 in
1574 app print_line lines;
1575 lines
1576 end
1577
1578 fun return_code_for outcomes =
1579 foldl (fn ((_, result), acc) =>
1580 case result of
1581 ERROR _ => OS.Process.failure
1582 | _ => acc)
1583 OS.Process.success
1584 outcomes
1585
1586 fun status_of_project ({ context, libs } : project) =
1587 return_code_for (act_and_print (AnyLibControl.status context)
1588 print_status_header (print_status false)
1589 libs)
1590
1591 fun review_project ({ context, libs } : project) =
1592 return_code_for (act_and_print (AnyLibControl.review context)
1593 print_status_header (print_status true)
1594 libs)
1595
1596 fun update_project ({ context, libs } : project) =
1597 let val outcomes = act_and_print
1598 (AnyLibControl.update context)
1599 print_outcome_header print_update_outcome libs
1600 val locks =
1601 List.concat
1602 (map (fn (libname, result) =>
1603 case result of
1604 ERROR _ => []
1605 | OK id => [{ libname = libname, id_or_tag = id }])
1606 outcomes)
1607 val return_code = return_code_for outcomes
1608 in
1609 if OS.Process.isSuccess return_code
1610 then save_lock_file (#rootpath context) locks
1611 else ();
1612 return_code
1613 end
1614
1615 fun load_local_project pintype =
1616 let val userconfig = load_userconfig ()
1617 val rootpath = OS.FileSys.getDir ()
1618 in
1619 load_project userconfig rootpath pintype
1620 end
1621
1622 fun with_local_project pintype f =
1623 let val return_code = f (load_local_project pintype)
1624 handle e =>
1625 (print ("Failed with exception: " ^
1626 (exnMessage e) ^ "\n");
1627 OS.Process.failure)
1628 val _ = print "\n";
1629 in
1630 return_code
1631 end
1632
1633 fun review () = with_local_project NO_LOCKFILE review_project
1634 fun status () = with_local_project NO_LOCKFILE status_of_project
1635 fun update () = with_local_project NO_LOCKFILE update_project
1636 fun install () = with_local_project USE_LOCKFILE update_project
1637
1638 fun version () =
1639 (print ("v" ^ vext_version ^ "\n");
1640 OS.Process.success)
1641
1642 fun usage () =
1643 (print "\nVext ";
1644 version ();
1645 print ("\nA simple manager for third-party source code dependencies.\n\n"
1646 ^ "Usage:\n\n"
1647 ^ " vext <command>\n\n"
1648 ^ "where <command> is one of:\n\n"
1649 ^ " status print quick report on local status only, without using network\n"
1650 ^ " review check configured libraries against their providers, and report\n"
1651 ^ " install update configured libraries according to project specs and lock file\n"
1652 ^ " update update configured libraries and lock file according to project specs\n"
1653 ^ " version print the Vext version number and exit\n\n");
1654 OS.Process.failure)
1655
1656 fun vext args =
1657 let val return_code =
1658 case args of
1659 ["review"] => review ()
1660 | ["status"] => status ()
1661 | ["install"] => install ()
1662 | ["update"] => update ()
1663 | ["version"] => version ()
1664 | _ => usage ()
1665 in
1666 OS.Process.exit return_code;
1667 ()
1668 end
1669
1670 fun main () =
1671 vext (CommandLine.arguments ())