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