tree checksum vpatch file split hunks
all signers: esthlos
antecedents:
press order:
| v_genesis | esthlos |
patch:
(0 . 0)(1 . 10)
5 LISP=sbcl
6
7 all: ${LISP}
8
9 sbcl:
10 sbcl --no-sysinit --no-userinit --disable-debugger --load v.lisp --eval "(sb-ext:save-lisp-and-die #p\"v\" :toplevel #'v::main :executable t)"
11
12 #credit: trinque
13 ccl:
14 ccl --no-init --load v.lisp --eval "(ccl:save-application #P\"v\" :toplevel-function #'v::main :prepend-kernel t)"
-(0 . 0)(1 . 1)
19 526499 v_genesis esthlos Genesis of a Common Lisp vtron, tested on SBCL 1.4.4 and CCL 1.11.5.
-(0 . 0)(1 . 817)
24 ;; Andrew Erlanger, 2018
25 ;; http://wot.deedbot.org/EDB93AD2CAB28398010B46D025C71657FDA71DC2.html
26 ;;
27 ;; You do not have, nor can you ever acquire the right to use, copy or
28 ;; distribute this software. Should you use this software for any purpose, or
29 ;; copy and distribute it, to anyone or in any manner, you are breaking the
30 ;; laws of whatever soi-disant "sovereign jurisdiction" you may be deemed to
31 ;; be located within, and you promise to continue doing so in the indefinite
32 ;; future.
33
34 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
35 ;; contents
36 ;;; package definition
37 ;;; global tuning parameters
38 ;;; error conditions
39 ;;; subprocess management
40 ;;; classes
41 ;;; printing objects
42 ;;; generics
43 ;;; validation using gpg
44 ;;; loading vpatches
45 ;;; applying vpatches
46 ;;; generating the dependency graph
47 ;;; topologically sorting a directed graph
48 ;;; procedures to assist main operations
49 ;;; main operations
50 ;;; for use as a binturd
51
52 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
53 ;; package definition
54
55 (cl:defpackage "V"
56 (:use "COMMON-LISP")
57 (:export "FLOW" "ROOTS" "LEAVES"
58 "ANTECEDENTS" "DESCENDANTS" "PRESS-PATH"
59 "PRESS"))
60
61 (in-package "V")
62
63 ;; sbcl 1.4.4 barfs on making an executable without this
64 #+sbcl (require :sb-posix)
65
66 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
67 ;; global tuning parameters
68
69 (defparameter *default-vpatch-dir* "./patches/")
70 (defparameter *default-wot-dir* "./wot/")
71 (defparameter *default-seal-dir* "./seals/")
72 (defparameter *default-keyring-dir-location* "./")
73 (defparameter *default-keyring-dir-template* "gpgXXXXXX")
74 (defparameter *gpg-location* "/usr/bin/gpg")
75 (defparameter *patch-location* "/usr/bin/patch")
76 (defparameter *rm-location* "/bin/rm")
77
78 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
79 ;; error conditions
80
81 (define-condition bad-public-key (error)
82 ((text :initarg :text :reader text))
83 (:documentation "Raised if gpg failes to load a public key.")
84 (:report (lambda (condition stream)
85 (format stream
86 "GnuPG failed to import key ~S."
87 (text condition)))))
88
89 (define-condition bad-seal (error)
90 ((text :initarg :text :reader text))
91 (:documentation "Raised if gpg detects a bad signature.")
92 (:report (lambda (condition stream)
93 (format stream
94 "GnuPG failed to verify seal ~S."
95 (text condition)))))
96
97 (define-condition cyclic (error)
98 ()
99 (:documentation "Cycle encountered during topological sort."))
100
101 (define-condition no-seal (error)
102 ((text :initarg :text :reader text))
103 (:documentation "Raised if a vpatch has no seal.")
104 (:report (lambda (condition stream)
105 (format stream
106 "Failed to find a seal for vpatch ~S."
107 (text condition)))))
108
109 (define-condition output-dir-dne (error)
110 ((text :initarg :text :reader text))
111 (:documentation "Raised if the output dir does not exist.")
112 (:report (lambda (condition stream)
113 (format stream
114 "Output directory not found at location ~S."
115 (text condition)))))
116
117 (define-condition patch-failure (error)
118 ((text :initarg :text :reader text))
119 (:documentation "Raised if a patching operation fails.")
120 (:report (lambda (condition stream)
121 (format stream
122 "Failed to apply vpatch ~S."
123 (text condition)))))
124
125 (define-condition unsupported-cl (error)
126 ()
127 (:documentation "Unsupported Common Lisp implementation detected."))
128
129 (define-condition vpatch-lookup (error)
130 ((text :initarg :text :reader text))
131 (:documentation "Raised when no vpatch matches a search pattern.")
132 (:report (lambda (condition stream)
133 (format stream
134 "Failed to find vpatch matching ~S."
135 (text condition)))))
136
137 (define-condition wot-dir-creation (error)
138 ((text :initarg :text :reader text))
139 (:documentation "Raised if a wot dir does not exist.")
140 (:report (lambda (condition stream)
141 (format stream
142 "Failed to make temporary WoT directory: ~S."
143 (text condition)))))
144
145 (define-condition wot-dir-dne (error)
146 ((text :initarg :text :reader text))
147 (:documentation "Raised if a wot dir does not exist.")
148 (:report (lambda (condition stream)
149 (format stream
150 "WoT directory not found at location ~S."
151 (text condition)))))
152
153 (define-condition keyring-dir-dne (error)
154 ((text :initarg :text :reader text))
155 (:documentation "Raised if the parent directory for the temporary
156 keyring dir does not exist.")
157 (:report (lambda (condition stream)
158 (format stream
159 "Keyring parent directory not found at location ~S."
160 (text condition)))))
161
162
163 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
164 ;; subprocess management
165
166 (defun run-subprocess (program args)
167 #+sbcl (sb-ext:process-exit-code (sb-ext:run-program program args))
168 #+ccl (nth-value 1 (ccl:external-process-status
169 (ccl:run-program program args)))
170 #-(or :sbcl :ccl) (error 'unsupported-cl))
171
172
173 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
174 ;; classes
175
176 (defclass subpatch ()
177 ((path :initarg :path :reader path)
178 (pre-hash :initarg :pre-hash :reader pre-hash)
179 (post-hash :initarg :post-hash :reader post-hash))
180 (:documentation "A subpatch is a patch for a single file."))
181
182 (defclass vpatch ()
183 ((name :initarg :name :reader name)
184 (subpatches :initarg :subpatches :reader subpatches)
185 (path :initarg :path :reader path)
186 (seals :initarg :seals :reader seals))
187 (:documentation "A representation of a vpatch."))
188
189 (defclass wot ()
190 ((basename :initarg :basename :reader basename)
191 (homedir :initarg :homedir :reader homedir)
192 (key-names :initarg :names :reader names))
193 (:documentation ""))
194
195 (defclass directed-edge ()
196 ((head :initarg :head :reader head)
197 (tail :initarg :tail :reader tail))
198 (:documentation "A directed edge of a directed graph."))
199
200 (defclass directed-graph ()
201 ((vertices :initarg :vertices :reader vertices)
202 (edges :initarg :edges :reader edges))
203 (:documentation "A directed graph, consisting of vertices
204 and directed edges."))
205
206
207 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
208 ;; printing objects
209
210 (defmethod print-object ((obj subpatch) stream)
211 (print-unreadable-object (obj stream :type t)
212 (labels ((fingerprint (hash-string)
213 (if (equal "false" hash-string)
214 "_"
215 (subseq hash-string (- (length hash-string) 4)))))
216 (format stream
217 "~a -> ~a"
218 (fingerprint (pre-hash obj))
219 (fingerprint (post-hash obj))))))
220
221 (defmethod print-object ((obj vpatch) stream)
222 (print-unreadable-object (obj stream :type t)
223 (princ (name obj) stream)))
224
225 (defmethod print-object ((obj wot) stream)
226 (print-unreadable-object (obj stream :type t)
227 (princ (basename obj)
228 stream)))
229
230
231 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
232 ;; generics
233
234 (defgeneric remove-wot (wot))
235 (defgeneric check-trust (vpatch wot))
236 (defgeneric patch (vpatch output-dir))
237 (defgeneric alignedp (obj1 obj2))
238 (defgeneric alignment (obj1 obj2))
239 (defgeneric adjacentp (obj1 obj2))
240 (defgeneric parentp (vp1 vp2))
241 (defgeneric toposort (obj))
242
243
244 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
245 ;; validation using gpg
246
247 ;; credit: phf and trinque
248 (defun make-temp-dir (path)
249 "Makes a temporary directory by calling the foreign function mkdtemp.
250
251 Returns the NAMESTRING of the path of the temporary directory.
252
253 Raises WOT-DIR-CREATION of the directory creation fails."
254 #+sbcl (let ((noerrors nil)
255 (p nil))
256 (ignore-errors
257 (setq p (sb-posix:mkdtemp (namestring path)))
258 (setq noerrors t))
259 (if noerrors
260 p
261 (error 'wot-dir-creation :text (namestring path))))
262 #+ccl (ccl:with-cstrs ((s (namestring path)))
263 (if (ccl:%null-ptr-p (#_mkdtemp s))
264 (error 'wot-dir-creation :text (namestring path))
265 (ccl:%get-cstring s))))
266
267 (defun make-wot (&key
268 (wot-dir *default-wot-dir*)
269 (keyring-dir-location *default-keyring-dir-location*)
270 (keyring-dir-template *default-keyring-dir-template*))
271 "Generates a gpg keyring under KEYRING-DIR, loading
272 in all in WOT-DIR ending in .asc .
273
274 Returns a WOT object corresponding to the generated keyring.
275
276 Raises WOT-DIR-DNE if WOT-DIR does not exist.
277
278 Raises KEYRING-DIR-DNE if KEYRING-DIR does not exist. Note that this procedure
279 attempts to create KEYRING-DIR if it does not exist.
280
281 Raises BAD-PUBLIC-KEY if gpg fails to import a key."
282 (if (not (probe-file wot-dir))
283 (error 'wot-dir-dne :text wot-dir))
284 (if (not (probe-file keyring-dir-location))
285 (error 'keyring-dir-dne :text keyring-dir-location))
286 (let ((homedir (make-temp-dir
287 (merge-pathnames (make-pathname :name
288 keyring-dir-template)
289 keyring-dir-location))))
290 (make-instance
291 'wot
292 :homedir homedir
293 :basename (file-namestring homedir)
294 :names (mapcar #'(lambda (w)
295 (let ((name (namestring w)))
296 (if (not (eq 0
297 (run-subprocess
298 *gpg-location*
299 (list "--homedir"
300 homedir
301 "--import"
302 name))))
303 (error 'bad-public-key :text name)
304 (file-namestring name))))
305 (directory (concatenate 'string wot-dir "*.asc"))))))
306
307 (defmethod remove-wot ((w wot))
308 "Unlink the files associated with w. Note that w itself is unaffected."
309 (run-subprocess *rm-location* (list "-rf" (homedir w))))
310
311 (defmacro with-wot (symb &rest body-forms)
312 (check-type symb symbol)
313 `(let ((,symb (make-wot)))
314 (let ((rtn (progn ,@body-forms)))
315 (remove-wot ,symb)
316 rtn)))
317
318 (defmethod check-trust ((vp vpatch) (w wot))
319 (if (seals vp)
320 (progn
321 (mapcar #'(lambda (s)
322 (if (not (eq 0
323 (run-subprocess
324 *gpg-location*
325 (list
326 "--homedir"
327 (homedir w)
328 "--verify"
329 s
330 (namestring (path vp))))))
331 (error 'bad-seal :text (file-namestring s))))
332 (mapcar #'namestring (seals vp)))
333 vp)
334 (error 'no-seal :text (name vp))))
335
336 (defmethod check-trust ((list list) (w wot))
337 (mapcar #'(lambda (vp) (check-trust vp w))
338 list))
339
340
341 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
342 ;; loading vpatches
343
344 (defun find-seals (name &optional
345 (seal-dir *default-seal-dir*))
346 "Returns a list of paths to seals in SEAL-DIR whose basename
347 contains NAME as a subsequence.
348
349 A seal in this case is defined as a file whose basename ends in \".sig\"."
350 (remove-if-not #'(lambda (seal-path)
351 (let ((seal-name (file-namestring
352 (namestring seal-path))))
353 (and (>= (length seal-name) (length name))
354 (equal name
355 (subseq seal-name
356 0
357 (length name))))))
358 (directory (concatenate 'string
359 seal-dir
360 "*.sig"))))
361
362 (defun last-word (string)
363 "Returns the last subsequence s of string such that s contains no spaces."
364 (subseq string
365 (1+ (position #\Space string :from-end t))))
366
367 (defun subpatch-start (string)
368 "Determines if string indicates the start of a new subpatch."
369 (and (>= (length string) 4)
370 (equal "diff" (subseq string 0 4))))
371
372 (defun extract-hashes (vpatch-filepath)
373 "Given a path to a vpatch file, return a list of lists containing hash
374 information for subpatches in the vpatch.
375
376 Each list contains, in order, the path to the subpatch, the pre-patch
377 hash, and the post-patch hash.
378
379 Per the standard, nonexistance is denoted \"false\"."
380 (let ((hash-list nil))
381 (with-open-file (s vpatch-filepath)
382 (do ((L (read-line s) (read-line s nil)))
383 ((eql L nil))
384 (if (subpatch-start L)
385 (setq hash-list
386 (cons (mapcar #'last-word
387 (list L (read-line s) (read-line s)))
388 hash-list)))))
389 hash-list))
390
391 (defun make-vpatch (filepath)
392 "Given a filepath, MAKE-VPATCH attempts to read its contents
393 and form a VPATCH object.
394
395 Returns the newly created VPATCH object."
396 (let ((name (file-namestring (namestring filepath))))
397 (make-instance 'vpatch
398 :name name
399 :path filepath
400 :seals (find-seals name)
401 :subpatches (mapcar #'(lambda (x)
402 (make-instance
403 'subpatch
404 :path (first x)
405 :pre-hash (second x)
406 :post-hash (third x)))
407 (extract-hashes filepath)))))
408
409 (defun load-vpatches (path)
410 "Returns a list containing the application of MAKE-VPATCH to
411 every .vpatch file at PATH."
412 (mapcar #'make-vpatch
413 (directory (concatenate 'string path
414 "/*.vpatch"))))
415
416
417 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
418 ;; applying vpatches
419
420 (defmethod patch ((vp vpatch) output-dir)
421 "Apply vpatch VP using a external patch utility.
422
423 Returns t if the external patch utility returns 0. Otherwise returns NIL.
424
425 The patch is applied in OUTPUT-DIR."
426 (if (eq 0
427 (run-subprocess *patch-location*
428 (list "--dir" output-dir
429 "-F" "0" "-E" "-p1" "-i"
430 (namestring (path vp)))))
431 t
432 (error 'patch-failure :text (name vp))))
433
434
435 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
436 ;; generating the dependency graph
437
438 (defmethod alignedp ((sp1 subpatch) (sp2 subpatch))
439 (equal (path sp1) (path sp2)))
440
441 (defmethod alignment ((vp1 vpatch) (vp2 vpatch))
442 (loop for sp1 in (subpatches vp1)
443 append (loop for sp2 in (subpatches vp2)
444 if (alignedp sp1 sp2)
445 collect (list sp1 sp2))))
446
447 (defmethod parentp ((sp1 subpatch) (sp2 subpatch))
448 (equal (post-hash sp1) (pre-hash sp2)))
449
450 (defmethod parentp ((vp1 vpatch) (vp2 vpatch))
451 (let ((alignment (alignment vp1 vp2)))
452 (labels ((parentp-apply (x) (apply #'parentp x)))
453 (and (every #'parentp-apply alignment)
454 (some #'parentp-apply alignment)))))
455
456 (defun generate-depgraph (vpatch-list)
457 "Generate a directed graph from the input list VPATCH-LIST of vpatches.
458
459 Returns a LIST whose first member is the input list of vpatches,
460 and second member is a list of all directed edges (VP1 VP2)
461 where VP1 is a parent of VP2."
462 (make-instance 'directed-graph
463 :vertices vpatch-list
464 :edges (loop for vp1 in vpatch-list
465 append (loop for vp2 in vpatch-list
466 if (parentp vp1 vp2)
467 collect (make-instance 'directed-edge
468 :head vp1
469 :tail vp2)))))
470
471
472 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
473 ;; topologically sorting a directed graph
474
475 (defun partition (proposition list)
476 "Given a unary function PROPOSITION and a list LIST, separates
477 those which satisfy PROPOSITION from those which do not.
478
479 Returns two values: the first contains exactly the elements of LIST
480 for which PROPOSITION does not return NIL; the second contains exactly those
481 elements of LIST for which PROPOSITION returns NIL."
482 (let ((successes '())
483 (failures '()))
484 (mapcar #'(lambda (x) (if (funcall proposition x)
485 (push x successes)
486 (push x failures)))
487 list)
488 (values successes failures)))
489
490 (defun rootp (vertex edges)
491 "Determines if VERTEX is a root in the list of edges EDGES.
492
493 Returns t if VERTEX is not the tail of any edge in EDGES, and NIL otherwise."
494 (notany #'(lambda (e) (eq (tail e) vertex))
495 edges))
496
497 (defun leafp (vertex edges)
498 "Determines if VERTEX is a leaf in the list of edges EDGES.
499
500 Returns t if VERTEX is not the head of any edge in EDGES, nil otherwise."
501 (notany #'(lambda (e) (eq (head e) vertex))
502 edges))
503
504 (defun decapitate (vertices edges)
505 "Removes all edges with head in vertices"
506 (remove-if #'(lambda (edge) (member (head edge) vertices))
507 edges))
508
509 (defmethod toposort ((dg directed-graph))
510 "Topologically sorts the directed graph DG using the standard method from
511 Knuth.
512
513 Raises CYCLIC if a cycle is encountered.
514
515 Returns a sorted list of the vertices of DG."
516 (labels ((flatten-rec (vertices edges)
517 (if (null vertices)
518 '()
519 (multiple-value-bind (roots others)
520 (partition #'(lambda (v) (rootp v edges))
521 vertices)
522 (if (null roots)
523 (error 'cyclic)
524 (append roots
525 (flatten-rec others (decapitate roots
526 edges))))))))
527 (flatten-rec (vertices dg) (edges dg))))
528
529
530 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
531 ;; procedures to assist main operations
532
533 (defun ancestors (vpatch
534 vpatch-list
535 ancestor-function)
536 "Finds all vpatches in VPATCH-LIST which can result from repeated
537 application of ANCESTOR-FUNCTION, starting at VPATCH.
538
539 Returns the transitive closure of the binary relation
540 ANCESTOR-FUNCTION in the list VPATCH-LIST, rooted at VPATCH."
541 (labels ((anc-rec (vp1)
542 (let ((ancestors
543 (remove-if-not #'(lambda (vp2)
544 (funcall ancestor-function
545 vp1
546 vp2))
547 vpatch-list)))
548 ;; below sexp technically not needed, increases efficiency
549 (setq vpatch-list
550 (remove-if #'(lambda (v)
551 (member v ancestors))
552 vpatch-list))
553 (if (null ancestors)
554 nil
555 (append ancestors
556 (remove-duplicates
557 (apply #'append
558 (mapcar #'anc-rec
559 ancestors))))))))
560 (anc-rec vpatch)))
561
562 (defun lookup (subseq &key vpatch-list error-on-fail)
563 "Scans VPATCH for vpatches in vpatch-list whose path basename
564 contains SUBSEQ as a subsequence.
565
566 If a match exists, the leftmost match is returned. Otherwise NIL
567 is returned.
568
569 If VPATCH-LIST is null, load all vpatches from *default-vpatch-dir*
570 and searches through those vpatches.
571
572 If ERROR-ON-FAIL is not null, raises VPATCH-LOOKUP error if the lookup
573 fails to find a match.
574
575 The user should note that lookup generates a new list of vpatch
576 objects when vpatch-list is null. Hence calling lookup with the
577 same regex twice can result in different vpatch objects. Thus
578 if the user wants a vpatch returned from a known list, that list
579 must be given as an argument."
580 (let ((result (find-if #'(lambda (vp)
581 (search subseq
582 (file-namestring
583 (namestring
584 (path vp)))))
585 vpatch-list)))
586 (if (and (null result) error-on-fail)
587 (error 'vpatch-lookup :text subseq)
588 result)))
589
590 (defmacro interpret-and-verify (items &rest body)
591 "This macro makes it cleaner for various operations to take in
592 either strings identifying vpatches, or vpatch objects. Allowing
593 strings makes operations simpler at the REPL, and allows for
594 POSIX terminal interaction.
595
596 If VPATCH is a string and is not a substring of the name of
597 some vpatch, raises a VPATCH-LOOKUP error."
598 `(let* ,(append
599 '((created-wot nil))
600 '((wot (if (null wot)
601 (progn (setq created-wot t)
602 (make-wot))
603 wot)))
604 (if (member 'vpatch-list items)
605 '((vpatch-list (check-trust
606 (if (null vpatch-list)
607 (load-vpatches *default-vpatch-dir*)
608 vpatch-list)
609 wot)))
610 '())
611 (if (member 'vpatch items)
612 '((vpatch (check-trust
613 (if (stringp vpatch)
614 (lookup vpatch
615 :vpatch-list vpatch-list
616 :error-on-fail t)
617 vpatch)
618 wot)))
619 '())
620 `((result (progn ,@body))))
621 (if created-wot (remove-wot wot))
622 result))
623
624
625 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
626 ;; main operations
627
628 (defun flow (&optional vpatch-list wot)
629 "Returns a topologically sorted list of trusted vpatches.
630
631 If VPATCH-LIST is null, loads vpatches from *default-vpatch-dir*.
632
633 If WOT is null, creates a wot object using the public keys in
634 *default-wot-dir*, and uses that object to check trust.
635
636 If a cycle is detected during sorting, the condition CYCLIC will be raised."
637 (interpret-and-verify
638 (vpatch-list)
639 (toposort
640 (generate-depgraph vpatch-list))))
641
642 (defun roots (&optional vpatch-list wot)
643 "Returns a list of trusted vpatches which are the roots of
644 the dependency tree derived from VPATCH-LIST.
645
646 The returned list is in topologically sorted order.
647
648 If VPATCH-LIST is null, loads vpatches from *default-vpatch-dir*.
649
650 If WOT is null, creates a wot object using the public keys in
651 *default-wot-dir*, and uses that object to check trust."
652 (interpret-and-verify
653 (vpatch-list)
654 (toposort
655 (generate-depgraph
656 (remove-if-not #'(lambda (vp)
657 (rootp vp
658 (edges (generate-depgraph vpatch-list))))
659 vpatch-list)))))
660
661 (defun leaves (&optional vpatch-list wot)
662 "Returns a list of trusted vpatches which are the leaves of
663 the dependency tree derived from VPATCH-LIST.
664
665 The returned list is in topologically sorted order.
666
667 If VPATCH-LIST is null, loads vpatches from *default-vpatch-dir*.
668
669 If WOT is null, creates a wot object using the public keys in
670 *default-wot-dir*, and uses that object to check trust."
671 (interpret-and-verify
672 (vpatch-list)
673 (toposort
674 (generate-depgraph
675 (remove-if-not #'(lambda (vp)
676 (leafp vp
677 (edges (generate-depgraph vpatch-list))))
678 vpatch-list)))))
679
680 (defun antecedents (vpatch &optional vpatch-list wot)
681 "Returns a list of trusted vpatches containing exactly those vpatches
682 v such that a directed path exists from VPATCH to v. The existence of
683 directed paths is determined by the dependency tree derived from VPATCH-LIST.
684
685 The returned list is in topologically sorted order.
686
687 VPATCH may be either a string, or a vpatch object. If VPATCH is a string,
688 the first vpatch in VPATCH-LIST whose name has VPATCH as a substring
689 will be used. If no match is found, the condition VPATCH-LOOKUP will be raised.
690
691 If VPATCH-LIST is null, loads vpatches from *default-vpatch-dir*.
692
693 If WOT is null, creates a wot object using the public keys in
694 *default-wot-dir*, and uses that object to check trust."
695 (interpret-and-verify
696 (vpatch vpatch-list)
697 (toposort
698 (generate-depgraph
699 (ancestors vpatch
700 vpatch-list
701 #'(lambda (vp1 vp2) (parentp vp2 vp1)))))))
702
703 (defun descendants (vpatch &optional vpatch-list wot)
704 "Returns a list of trusted vpatches containing exactly those vpatches
705 v such that a directed path exists from v to VPATCH. The existence of
706 directed paths is determined by the dependency tree derived from VPATCH-LIST.
707
708 The returned list is in topologically sorted order.
709
710 VPATCH may be either a string, or a vpatch object. If VPATCH is a string,
711 the first vpatch in VPATCH-LIST whose name has VPATCH as a substring
712 will be used. If no match is found, the condition VPATCH-LOOKUP will be raised.
713
714 If VPATCH-LIST is null, loads vpatches from *default-vpatch-dir*.
715
716 If WOT is null, creates a wot object using the public keys in
717 *default-wot-dir*, and uses that object to check trust."
718 (interpret-and-verify
719 (vpatch vpatch-list)
720 (toposort
721 (generate-depgraph
722 (ancestors vpatch
723 vpatch-list
724 #'(lambda (vp1 vp2) (parentp vp1 vp2)))))))
725
726 (defun press-path (vpatch &optional vpatch-list wot)
727 "Returns a list of containing exactly all trusted vpatches needed
728 to press VPATCH.
729
730 The returned list is in topologically sorted order.
731
732 VPATCH may be either a string, or a vpatch object. If VPATCH is a string,
733 the first vpatch in VPATCH-LIST whose name has VPATCH as a substring
734 will be used. If no match is found, the condition VPATCH-LOOKUP will be raised.
735
736 If VPATCH-LIST is null, loads vpatches from *default-vpatch-dir*.
737
738 If WOT is null, creates a wot object using the public keys in
739 *default-wot-dir*, and uses that object to check trust."
740 (interpret-and-verify
741 (vpatch vpatch-list)
742 (toposort
743 (generate-depgraph
744 (append (antecedents vpatch
745 vpatch-list)
746 (list vpatch))))))
747
748 (defun press (vpatch output-dir &optional vpatch-list wot)
749 "Presses all trusted vpatches of VPATCH-LIST which are in
750 the press-path of VPATCH. The press is conducted in OUTPUT-DIR.
751
752 The returned list is in topologically sorted order.
753
754 If OUTPUT-DIR does not exist, PRESS will attempt to create it. If creation
755 fails, the condition OUTPUT-DIR-DNE will be raised.
756
757 VPATCH may be either a string, or a vpatch object. If VPATCH is a string,
758 the first vpatch in VPATCH-LIST whose name has VPATCH as a substring
759 will be used. If no match is found, the condition VPATCH-LOOKUP will be raised.
760
761 If VPATCH-LIST is null, loads vpatches from *default-vpatch-dir*.
762
763 If WOT is null, creates a wot object using the public keys in
764 *default-wot-dir*, and uses that object to check trust."
765 (ensure-directories-exist
766 (make-pathname :directory `(:relative ,output-dir)))
767 (if (not (probe-file output-dir))
768 (error 'output-dir-dne))
769 (interpret-and-verify
770 (vpatch vpatch-list)
771 (every #'(lambda (vp) (patch vp output-dir))
772 (toposort
773 (generate-depgraph
774 (append (antecedents vpatch
775 vpatch-list)
776 (list vpatch)))))))
777
778
779 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
780 ;; for use as a binturd
781
782 (defun print-usage ()
783 (format t "Usage:
784 <command> ::= v <nullary> | <unary> | <binary>
785 <nullary> ::= flow | roots | leaves
786 <unary> ::= ante | desc | path <vpatch-designator>
787 <binary> ::= press <vpatch-designator> <press-directory>
788
789 <vpatch-designator> is a substring of the basename of some vpatch.
790 "))
791
792 (defun print-all (obj)
793 (labels ((print-all-recur (r)
794 (cond
795 ((null r) nil)
796 ((listp r)
797 (mapcar #'print-all-recur r))
798 ((typep r 'vpatch) (format t "~a~%" (name r)))
799 ((eq r t) (format t "Success~%"))
800 (t (format t "~a~%" r)))))
801 (print-all-recur obj)))
802
803 (defun main ()
804 (handler-case
805 (let ((args #+sbcl (cdr sb-ext:*posix-argv*)
806 #+ccl (cdr ccl:*command-line-argument-list*)))
807 (labels ((call (n procedure)
808 (if (not (= (length (cdr args)) n))
809 (print-usage)
810 (print-all (apply procedure (cdr args))))))
811 (let ((cmd (car args)))
812 (cond
813 ((string= cmd "flow") (call 0 #'flow))
814 ((string= cmd "roots") (call 0 #'roots))
815 ((string= cmd "leaves") (call 0 #'leaves))
816 ((string= cmd "ante") (call 1 #'antecedents))
817 ((string= cmd "desc") (call 1 #'descendants))
818 ((string= cmd "path") (call 1 #'press-path))
819 ((string= cmd "press") (call 2 #'press))
820 (t (print-usage))))))
821 (bad-public-key (c)
822 (format t "GnuPG failed to import key ~S.~%" (text c)))
823 (bad-seal (c)
824 (format t "GnuPG failed to verify seal ~S.~%" (text c)))
825 (cyclic ()
826 (format t "Cycle encountered during topological sort.~%"))
827 (no-seal (c)
828 (format t "Failed to find a seal for vpatch ~S.~%" (text c)))
829 (output-dir-dne (c)
830 (format t "Output directory not found at location ~S." (text c)))
831 (patch-failure (c)
832 (format t "Failed to apply vpatch ~S.~%" (text c)))
833 (unsupported-cl ()
834 (format t "Unsupported Common Lisp implementation detected.~%"))
835 (vpatch-lookup (c)
836 (format t "Failed to find vpatch matching ~S.~%" (text c)))
837 (wot-dir-creation (c)
838 (format t "Failed to make temporary WoT directory: ~S.~%" (text c)))
839 (wot-dir-dne (c)
840 (format t "WoT directory not found at location ~S.~%" (text c)))))