diff -uNr a/Makefile b/Makefile --- a/Makefile 1969-12-31 19:00:00.000000000 -0500 false +++ b/Makefile 2018-06-07 21:23:51.000000000 -0400 1081b4974227147ad518435277e9d3d170f1def03e64497bc16c956b07ef5f5244bc380eb6c1dc49d4420fab3775bac4364a3d49f9e4028b1dc1150ab5a25544 @@ -0,0 +1,10 @@ +LISP=sbcl + +all: ${LISP} + +sbcl: + sbcl --no-sysinit --no-userinit --disable-debugger --load v.lisp --eval "(sb-ext:save-lisp-and-die #p\"v\" :toplevel #'v::main :executable t)" + +#credit: trinque +ccl: + ccl --no-init --load v.lisp --eval "(ccl:save-application #P\"v\" :toplevel-function #'v::main :prepend-kernel t)" diff -uNr a/manifest b/manifest --- a/manifest 1969-12-31 19:00:00.000000000 -0500 false +++ b/manifest 2018-06-07 21:23:51.000000000 -0400 b2593f0383cd9449613306acbc93c51fb6bd80e8cf2d52fc5d32c5ae6e7c61a798666ffc572087fc376052869796113364adbe1fd59f45311007037f925d58ae @@ -0,0 +1 @@ +526499 v_genesis esthlos Genesis of a Common Lisp vtron, tested on SBCL 1.4.4 and CCL 1.11.5. diff -uNr a/v.lisp b/v.lisp --- a/v.lisp 1969-12-31 19:00:00.000000000 -0500 false +++ b/v.lisp 2018-06-07 21:23:51.000000000 -0400 e2ec62b3b129132a0cc386715f1adef4e6f0bd5b742f21f2cab065823d04d634b21b9cdc88471acadb0c3116a21d30fef0dfa1cb44f0ff2de47e190f2df62ec4 @@ -0,0 +1,817 @@ +;; Andrew Erlanger, 2018 +;; http://wot.deedbot.org/EDB93AD2CAB28398010B46D025C71657FDA71DC2.html +;; +;; You do not have, nor can you ever acquire the right to use, copy or +;; distribute this software. Should you use this software for any purpose, or +;; copy and distribute it, to anyone or in any manner, you are breaking the +;; laws of whatever soi-disant "sovereign jurisdiction" you may be deemed to +;; be located within, and you promise to continue doing so in the indefinite +;; future. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; contents +;;; package definition +;;; global tuning parameters +;;; error conditions +;;; subprocess management +;;; classes +;;; printing objects +;;; generics +;;; validation using gpg +;;; loading vpatches +;;; applying vpatches +;;; generating the dependency graph +;;; topologically sorting a directed graph +;;; procedures to assist main operations +;;; main operations +;;; for use as a binturd + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; package definition + +(cl:defpackage "V" + (:use "COMMON-LISP") + (:export "FLOW" "ROOTS" "LEAVES" + "ANTECEDENTS" "DESCENDANTS" "PRESS-PATH" + "PRESS")) + +(in-package "V") + +;; sbcl 1.4.4 barfs on making an executable without this +#+sbcl (require :sb-posix) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; global tuning parameters + +(defparameter *default-vpatch-dir* "./patches/") +(defparameter *default-wot-dir* "./wot/") +(defparameter *default-seal-dir* "./seals/") +(defparameter *default-keyring-dir-location* "./") +(defparameter *default-keyring-dir-template* "gpgXXXXXX") +(defparameter *gpg-location* "/usr/bin/gpg") +(defparameter *patch-location* "/usr/bin/patch") +(defparameter *rm-location* "/bin/rm") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; error conditions + +(define-condition bad-public-key (error) + ((text :initarg :text :reader text)) + (:documentation "Raised if gpg failes to load a public key.") + (:report (lambda (condition stream) + (format stream + "GnuPG failed to import key ~S." + (text condition))))) + +(define-condition bad-seal (error) + ((text :initarg :text :reader text)) + (:documentation "Raised if gpg detects a bad signature.") + (:report (lambda (condition stream) + (format stream + "GnuPG failed to verify seal ~S." + (text condition))))) + +(define-condition cyclic (error) + () + (:documentation "Cycle encountered during topological sort.")) + +(define-condition no-seal (error) + ((text :initarg :text :reader text)) + (:documentation "Raised if a vpatch has no seal.") + (:report (lambda (condition stream) + (format stream + "Failed to find a seal for vpatch ~S." + (text condition))))) + +(define-condition output-dir-dne (error) + ((text :initarg :text :reader text)) + (:documentation "Raised if the output dir does not exist.") + (:report (lambda (condition stream) + (format stream + "Output directory not found at location ~S." + (text condition))))) + +(define-condition patch-failure (error) + ((text :initarg :text :reader text)) + (:documentation "Raised if a patching operation fails.") + (:report (lambda (condition stream) + (format stream + "Failed to apply vpatch ~S." + (text condition))))) + +(define-condition unsupported-cl (error) + () + (:documentation "Unsupported Common Lisp implementation detected.")) + +(define-condition vpatch-lookup (error) + ((text :initarg :text :reader text)) + (:documentation "Raised when no vpatch matches a search pattern.") + (:report (lambda (condition stream) + (format stream + "Failed to find vpatch matching ~S." + (text condition))))) + +(define-condition wot-dir-creation (error) + ((text :initarg :text :reader text)) + (:documentation "Raised if a wot dir does not exist.") + (:report (lambda (condition stream) + (format stream + "Failed to make temporary WoT directory: ~S." + (text condition))))) + +(define-condition wot-dir-dne (error) + ((text :initarg :text :reader text)) + (:documentation "Raised if a wot dir does not exist.") + (:report (lambda (condition stream) + (format stream + "WoT directory not found at location ~S." + (text condition))))) + +(define-condition keyring-dir-dne (error) + ((text :initarg :text :reader text)) + (:documentation "Raised if the parent directory for the temporary +keyring dir does not exist.") + (:report (lambda (condition stream) + (format stream + "Keyring parent directory not found at location ~S." + (text condition))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; subprocess management + +(defun run-subprocess (program args) + #+sbcl (sb-ext:process-exit-code (sb-ext:run-program program args)) + #+ccl (nth-value 1 (ccl:external-process-status + (ccl:run-program program args))) + #-(or :sbcl :ccl) (error 'unsupported-cl)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; classes + +(defclass subpatch () + ((path :initarg :path :reader path) + (pre-hash :initarg :pre-hash :reader pre-hash) + (post-hash :initarg :post-hash :reader post-hash)) + (:documentation "A subpatch is a patch for a single file.")) + +(defclass vpatch () + ((name :initarg :name :reader name) + (subpatches :initarg :subpatches :reader subpatches) + (path :initarg :path :reader path) + (seals :initarg :seals :reader seals)) + (:documentation "A representation of a vpatch.")) + +(defclass wot () + ((basename :initarg :basename :reader basename) + (homedir :initarg :homedir :reader homedir) + (key-names :initarg :names :reader names)) + (:documentation "")) + +(defclass directed-edge () + ((head :initarg :head :reader head) + (tail :initarg :tail :reader tail)) + (:documentation "A directed edge of a directed graph.")) + +(defclass directed-graph () + ((vertices :initarg :vertices :reader vertices) + (edges :initarg :edges :reader edges)) + (:documentation "A directed graph, consisting of vertices +and directed edges.")) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; printing objects + +(defmethod print-object ((obj subpatch) stream) + (print-unreadable-object (obj stream :type t) + (labels ((fingerprint (hash-string) + (if (equal "false" hash-string) + "_" + (subseq hash-string (- (length hash-string) 4))))) + (format stream + "~a -> ~a" + (fingerprint (pre-hash obj)) + (fingerprint (post-hash obj)))))) + +(defmethod print-object ((obj vpatch) stream) + (print-unreadable-object (obj stream :type t) + (princ (name obj) stream))) + +(defmethod print-object ((obj wot) stream) + (print-unreadable-object (obj stream :type t) + (princ (basename obj) + stream))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; generics + +(defgeneric remove-wot (wot)) +(defgeneric check-trust (vpatch wot)) +(defgeneric patch (vpatch output-dir)) +(defgeneric alignedp (obj1 obj2)) +(defgeneric alignment (obj1 obj2)) +(defgeneric adjacentp (obj1 obj2)) +(defgeneric parentp (vp1 vp2)) +(defgeneric toposort (obj)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; validation using gpg + +;; credit: phf and trinque +(defun make-temp-dir (path) + "Makes a temporary directory by calling the foreign function mkdtemp. + +Returns the NAMESTRING of the path of the temporary directory. + +Raises WOT-DIR-CREATION of the directory creation fails." + #+sbcl (let ((noerrors nil) + (p nil)) + (ignore-errors + (setq p (sb-posix:mkdtemp (namestring path))) + (setq noerrors t)) + (if noerrors + p + (error 'wot-dir-creation :text (namestring path)))) + #+ccl (ccl:with-cstrs ((s (namestring path))) + (if (ccl:%null-ptr-p (#_mkdtemp s)) + (error 'wot-dir-creation :text (namestring path)) + (ccl:%get-cstring s)))) + +(defun make-wot (&key + (wot-dir *default-wot-dir*) + (keyring-dir-location *default-keyring-dir-location*) + (keyring-dir-template *default-keyring-dir-template*)) + "Generates a gpg keyring under KEYRING-DIR, loading +in all in WOT-DIR ending in .asc . + +Returns a WOT object corresponding to the generated keyring. + +Raises WOT-DIR-DNE if WOT-DIR does not exist. + +Raises KEYRING-DIR-DNE if KEYRING-DIR does not exist. Note that this procedure +attempts to create KEYRING-DIR if it does not exist. + +Raises BAD-PUBLIC-KEY if gpg fails to import a key." + (if (not (probe-file wot-dir)) + (error 'wot-dir-dne :text wot-dir)) + (if (not (probe-file keyring-dir-location)) + (error 'keyring-dir-dne :text keyring-dir-location)) + (let ((homedir (make-temp-dir + (merge-pathnames (make-pathname :name + keyring-dir-template) + keyring-dir-location)))) + (make-instance + 'wot + :homedir homedir + :basename (file-namestring homedir) + :names (mapcar #'(lambda (w) + (let ((name (namestring w))) + (if (not (eq 0 + (run-subprocess + *gpg-location* + (list "--homedir" + homedir + "--import" + name)))) + (error 'bad-public-key :text name) + (file-namestring name)))) + (directory (concatenate 'string wot-dir "*.asc")))))) + +(defmethod remove-wot ((w wot)) + "Unlink the files associated with w. Note that w itself is unaffected." + (run-subprocess *rm-location* (list "-rf" (homedir w)))) + +(defmacro with-wot (symb &rest body-forms) + (check-type symb symbol) + `(let ((,symb (make-wot))) + (let ((rtn (progn ,@body-forms))) + (remove-wot ,symb) + rtn))) + +(defmethod check-trust ((vp vpatch) (w wot)) + (if (seals vp) + (progn + (mapcar #'(lambda (s) + (if (not (eq 0 + (run-subprocess + *gpg-location* + (list + "--homedir" + (homedir w) + "--verify" + s + (namestring (path vp)))))) + (error 'bad-seal :text (file-namestring s)))) + (mapcar #'namestring (seals vp))) + vp) + (error 'no-seal :text (name vp)))) + +(defmethod check-trust ((list list) (w wot)) + (mapcar #'(lambda (vp) (check-trust vp w)) + list)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; loading vpatches + +(defun find-seals (name &optional + (seal-dir *default-seal-dir*)) + "Returns a list of paths to seals in SEAL-DIR whose basename +contains NAME as a subsequence. + +A seal in this case is defined as a file whose basename ends in \".sig\"." + (remove-if-not #'(lambda (seal-path) + (let ((seal-name (file-namestring + (namestring seal-path)))) + (and (>= (length seal-name) (length name)) + (equal name + (subseq seal-name + 0 + (length name)))))) + (directory (concatenate 'string + seal-dir + "*.sig")))) + +(defun last-word (string) + "Returns the last subsequence s of string such that s contains no spaces." + (subseq string + (1+ (position #\Space string :from-end t)))) + +(defun subpatch-start (string) + "Determines if string indicates the start of a new subpatch." + (and (>= (length string) 4) + (equal "diff" (subseq string 0 4)))) + +(defun extract-hashes (vpatch-filepath) + "Given a path to a vpatch file, return a list of lists containing hash +information for subpatches in the vpatch. + +Each list contains, in order, the path to the subpatch, the pre-patch +hash, and the post-patch hash. + +Per the standard, nonexistance is denoted \"false\"." + (let ((hash-list nil)) + (with-open-file (s vpatch-filepath) + (do ((L (read-line s) (read-line s nil))) + ((eql L nil)) + (if (subpatch-start L) + (setq hash-list + (cons (mapcar #'last-word + (list L (read-line s) (read-line s))) + hash-list))))) + hash-list)) + +(defun make-vpatch (filepath) + "Given a filepath, MAKE-VPATCH attempts to read its contents +and form a VPATCH object. + +Returns the newly created VPATCH object." + (let ((name (file-namestring (namestring filepath)))) + (make-instance 'vpatch + :name name + :path filepath + :seals (find-seals name) + :subpatches (mapcar #'(lambda (x) + (make-instance + 'subpatch + :path (first x) + :pre-hash (second x) + :post-hash (third x))) + (extract-hashes filepath))))) + +(defun load-vpatches (path) + "Returns a list containing the application of MAKE-VPATCH to +every .vpatch file at PATH." + (mapcar #'make-vpatch + (directory (concatenate 'string path + "/*.vpatch")))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; applying vpatches + +(defmethod patch ((vp vpatch) output-dir) + "Apply vpatch VP using a external patch utility. + +Returns t if the external patch utility returns 0. Otherwise returns NIL. + +The patch is applied in OUTPUT-DIR." + (if (eq 0 + (run-subprocess *patch-location* + (list "--dir" output-dir + "-F" "0" "-E" "-p1" "-i" + (namestring (path vp))))) + t + (error 'patch-failure :text (name vp)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; generating the dependency graph + +(defmethod alignedp ((sp1 subpatch) (sp2 subpatch)) + (equal (path sp1) (path sp2))) + +(defmethod alignment ((vp1 vpatch) (vp2 vpatch)) + (loop for sp1 in (subpatches vp1) + append (loop for sp2 in (subpatches vp2) + if (alignedp sp1 sp2) + collect (list sp1 sp2)))) + +(defmethod parentp ((sp1 subpatch) (sp2 subpatch)) + (equal (post-hash sp1) (pre-hash sp2))) + +(defmethod parentp ((vp1 vpatch) (vp2 vpatch)) + (let ((alignment (alignment vp1 vp2))) + (labels ((parentp-apply (x) (apply #'parentp x))) + (and (every #'parentp-apply alignment) + (some #'parentp-apply alignment))))) + +(defun generate-depgraph (vpatch-list) + "Generate a directed graph from the input list VPATCH-LIST of vpatches. + +Returns a LIST whose first member is the input list of vpatches, +and second member is a list of all directed edges (VP1 VP2) +where VP1 is a parent of VP2." + (make-instance 'directed-graph + :vertices vpatch-list + :edges (loop for vp1 in vpatch-list + append (loop for vp2 in vpatch-list + if (parentp vp1 vp2) + collect (make-instance 'directed-edge + :head vp1 + :tail vp2))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; topologically sorting a directed graph + +(defun partition (proposition list) + "Given a unary function PROPOSITION and a list LIST, separates +those which satisfy PROPOSITION from those which do not. + +Returns two values: the first contains exactly the elements of LIST +for which PROPOSITION does not return NIL; the second contains exactly those +elements of LIST for which PROPOSITION returns NIL." + (let ((successes '()) + (failures '())) + (mapcar #'(lambda (x) (if (funcall proposition x) + (push x successes) + (push x failures))) + list) + (values successes failures))) + +(defun rootp (vertex edges) + "Determines if VERTEX is a root in the list of edges EDGES. + +Returns t if VERTEX is not the tail of any edge in EDGES, and NIL otherwise." + (notany #'(lambda (e) (eq (tail e) vertex)) + edges)) + +(defun leafp (vertex edges) + "Determines if VERTEX is a leaf in the list of edges EDGES. + +Returns t if VERTEX is not the head of any edge in EDGES, nil otherwise." + (notany #'(lambda (e) (eq (head e) vertex)) + edges)) + +(defun decapitate (vertices edges) + "Removes all edges with head in vertices" + (remove-if #'(lambda (edge) (member (head edge) vertices)) + edges)) + +(defmethod toposort ((dg directed-graph)) + "Topologically sorts the directed graph DG using the standard method from +Knuth. + +Raises CYCLIC if a cycle is encountered. + +Returns a sorted list of the vertices of DG." + (labels ((flatten-rec (vertices edges) + (if (null vertices) + '() + (multiple-value-bind (roots others) + (partition #'(lambda (v) (rootp v edges)) + vertices) + (if (null roots) + (error 'cyclic) + (append roots + (flatten-rec others (decapitate roots + edges)))))))) + (flatten-rec (vertices dg) (edges dg)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; procedures to assist main operations + +(defun ancestors (vpatch + vpatch-list + ancestor-function) + "Finds all vpatches in VPATCH-LIST which can result from repeated +application of ANCESTOR-FUNCTION, starting at VPATCH. + +Returns the transitive closure of the binary relation +ANCESTOR-FUNCTION in the list VPATCH-LIST, rooted at VPATCH." + (labels ((anc-rec (vp1) + (let ((ancestors + (remove-if-not #'(lambda (vp2) + (funcall ancestor-function + vp1 + vp2)) + vpatch-list))) + ;; below sexp technically not needed, increases efficiency + (setq vpatch-list + (remove-if #'(lambda (v) + (member v ancestors)) + vpatch-list)) + (if (null ancestors) + nil + (append ancestors + (remove-duplicates + (apply #'append + (mapcar #'anc-rec + ancestors)))))))) + (anc-rec vpatch))) + +(defun lookup (subseq &key vpatch-list error-on-fail) + "Scans VPATCH for vpatches in vpatch-list whose path basename +contains SUBSEQ as a subsequence. + +If a match exists, the leftmost match is returned. Otherwise NIL +is returned. + +If VPATCH-LIST is null, load all vpatches from *default-vpatch-dir* +and searches through those vpatches. + +If ERROR-ON-FAIL is not null, raises VPATCH-LOOKUP error if the lookup +fails to find a match. + +The user should note that lookup generates a new list of vpatch +objects when vpatch-list is null. Hence calling lookup with the +same regex twice can result in different vpatch objects. Thus +if the user wants a vpatch returned from a known list, that list +must be given as an argument." + (let ((result (find-if #'(lambda (vp) + (search subseq + (file-namestring + (namestring + (path vp))))) + vpatch-list))) + (if (and (null result) error-on-fail) + (error 'vpatch-lookup :text subseq) + result))) + +(defmacro interpret-and-verify (items &rest body) + "This macro makes it cleaner for various operations to take in +either strings identifying vpatches, or vpatch objects. Allowing +strings makes operations simpler at the REPL, and allows for +POSIX terminal interaction. + +If VPATCH is a string and is not a substring of the name of +some vpatch, raises a VPATCH-LOOKUP error." + `(let* ,(append + '((created-wot nil)) + '((wot (if (null wot) + (progn (setq created-wot t) + (make-wot)) + wot))) + (if (member 'vpatch-list items) + '((vpatch-list (check-trust + (if (null vpatch-list) + (load-vpatches *default-vpatch-dir*) + vpatch-list) + wot))) + '()) + (if (member 'vpatch items) + '((vpatch (check-trust + (if (stringp vpatch) + (lookup vpatch + :vpatch-list vpatch-list + :error-on-fail t) + vpatch) + wot))) + '()) + `((result (progn ,@body)))) + (if created-wot (remove-wot wot)) + result)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; main operations + +(defun flow (&optional vpatch-list wot) + "Returns a topologically sorted list of trusted vpatches. + +If VPATCH-LIST is null, loads vpatches from *default-vpatch-dir*. + +If WOT is null, creates a wot object using the public keys in +*default-wot-dir*, and uses that object to check trust. + +If a cycle is detected during sorting, the condition CYCLIC will be raised." + (interpret-and-verify + (vpatch-list) + (toposort + (generate-depgraph vpatch-list)))) + +(defun roots (&optional vpatch-list wot) + "Returns a list of trusted vpatches which are the roots of +the dependency tree derived from VPATCH-LIST. + +The returned list is in topologically sorted order. + +If VPATCH-LIST is null, loads vpatches from *default-vpatch-dir*. + +If WOT is null, creates a wot object using the public keys in +*default-wot-dir*, and uses that object to check trust." + (interpret-and-verify + (vpatch-list) + (toposort + (generate-depgraph + (remove-if-not #'(lambda (vp) + (rootp vp + (edges (generate-depgraph vpatch-list)))) + vpatch-list))))) + +(defun leaves (&optional vpatch-list wot) + "Returns a list of trusted vpatches which are the leaves of +the dependency tree derived from VPATCH-LIST. + +The returned list is in topologically sorted order. + +If VPATCH-LIST is null, loads vpatches from *default-vpatch-dir*. + +If WOT is null, creates a wot object using the public keys in +*default-wot-dir*, and uses that object to check trust." + (interpret-and-verify + (vpatch-list) + (toposort + (generate-depgraph + (remove-if-not #'(lambda (vp) + (leafp vp + (edges (generate-depgraph vpatch-list)))) + vpatch-list))))) + +(defun antecedents (vpatch &optional vpatch-list wot) + "Returns a list of trusted vpatches containing exactly those vpatches +v such that a directed path exists from VPATCH to v. The existence of +directed paths is determined by the dependency tree derived from VPATCH-LIST. + +The returned list is in topologically sorted order. + +VPATCH may be either a string, or a vpatch object. If VPATCH is a string, +the first vpatch in VPATCH-LIST whose name has VPATCH as a substring +will be used. If no match is found, the condition VPATCH-LOOKUP will be raised. + +If VPATCH-LIST is null, loads vpatches from *default-vpatch-dir*. + +If WOT is null, creates a wot object using the public keys in +*default-wot-dir*, and uses that object to check trust." + (interpret-and-verify + (vpatch vpatch-list) + (toposort + (generate-depgraph + (ancestors vpatch + vpatch-list + #'(lambda (vp1 vp2) (parentp vp2 vp1))))))) + +(defun descendants (vpatch &optional vpatch-list wot) + "Returns a list of trusted vpatches containing exactly those vpatches +v such that a directed path exists from v to VPATCH. The existence of +directed paths is determined by the dependency tree derived from VPATCH-LIST. + +The returned list is in topologically sorted order. + +VPATCH may be either a string, or a vpatch object. If VPATCH is a string, +the first vpatch in VPATCH-LIST whose name has VPATCH as a substring +will be used. If no match is found, the condition VPATCH-LOOKUP will be raised. + +If VPATCH-LIST is null, loads vpatches from *default-vpatch-dir*. + +If WOT is null, creates a wot object using the public keys in +*default-wot-dir*, and uses that object to check trust." + (interpret-and-verify + (vpatch vpatch-list) + (toposort + (generate-depgraph + (ancestors vpatch + vpatch-list + #'(lambda (vp1 vp2) (parentp vp1 vp2))))))) + +(defun press-path (vpatch &optional vpatch-list wot) + "Returns a list of containing exactly all trusted vpatches needed +to press VPATCH. + +The returned list is in topologically sorted order. + +VPATCH may be either a string, or a vpatch object. If VPATCH is a string, +the first vpatch in VPATCH-LIST whose name has VPATCH as a substring +will be used. If no match is found, the condition VPATCH-LOOKUP will be raised. + +If VPATCH-LIST is null, loads vpatches from *default-vpatch-dir*. + +If WOT is null, creates a wot object using the public keys in +*default-wot-dir*, and uses that object to check trust." + (interpret-and-verify + (vpatch vpatch-list) + (toposort + (generate-depgraph + (append (antecedents vpatch + vpatch-list) + (list vpatch)))))) + +(defun press (vpatch output-dir &optional vpatch-list wot) + "Presses all trusted vpatches of VPATCH-LIST which are in +the press-path of VPATCH. The press is conducted in OUTPUT-DIR. + +The returned list is in topologically sorted order. + +If OUTPUT-DIR does not exist, PRESS will attempt to create it. If creation +fails, the condition OUTPUT-DIR-DNE will be raised. + +VPATCH may be either a string, or a vpatch object. If VPATCH is a string, +the first vpatch in VPATCH-LIST whose name has VPATCH as a substring +will be used. If no match is found, the condition VPATCH-LOOKUP will be raised. + +If VPATCH-LIST is null, loads vpatches from *default-vpatch-dir*. + +If WOT is null, creates a wot object using the public keys in +*default-wot-dir*, and uses that object to check trust." + (ensure-directories-exist + (make-pathname :directory `(:relative ,output-dir))) + (if (not (probe-file output-dir)) + (error 'output-dir-dne)) + (interpret-and-verify + (vpatch vpatch-list) + (every #'(lambda (vp) (patch vp output-dir)) + (toposort + (generate-depgraph + (append (antecedents vpatch + vpatch-list) + (list vpatch))))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; for use as a binturd + +(defun print-usage () + (format t "Usage: + ::= v | | + ::= flow | roots | leaves + ::= ante | desc | path + ::= press + + is a substring of the basename of some vpatch. +")) + +(defun print-all (obj) + (labels ((print-all-recur (r) + (cond + ((null r) nil) + ((listp r) + (mapcar #'print-all-recur r)) + ((typep r 'vpatch) (format t "~a~%" (name r))) + ((eq r t) (format t "Success~%")) + (t (format t "~a~%" r))))) + (print-all-recur obj))) + +(defun main () + (handler-case + (let ((args #+sbcl (cdr sb-ext:*posix-argv*) + #+ccl (cdr ccl:*command-line-argument-list*))) + (labels ((call (n procedure) + (if (not (= (length (cdr args)) n)) + (print-usage) + (print-all (apply procedure (cdr args)))))) + (let ((cmd (car args))) + (cond + ((string= cmd "flow") (call 0 #'flow)) + ((string= cmd "roots") (call 0 #'roots)) + ((string= cmd "leaves") (call 0 #'leaves)) + ((string= cmd "ante") (call 1 #'antecedents)) + ((string= cmd "desc") (call 1 #'descendants)) + ((string= cmd "path") (call 1 #'press-path)) + ((string= cmd "press") (call 2 #'press)) + (t (print-usage)))))) + (bad-public-key (c) + (format t "GnuPG failed to import key ~S.~%" (text c))) + (bad-seal (c) + (format t "GnuPG failed to verify seal ~S.~%" (text c))) + (cyclic () + (format t "Cycle encountered during topological sort.~%")) + (no-seal (c) + (format t "Failed to find a seal for vpatch ~S.~%" (text c))) + (output-dir-dne (c) + (format t "Output directory not found at location ~S." (text c))) + (patch-failure (c) + (format t "Failed to apply vpatch ~S.~%" (text c))) + (unsupported-cl () + (format t "Unsupported Common Lisp implementation detected.~%")) + (vpatch-lookup (c) + (format t "Failed to find vpatch matching ~S.~%" (text c))) + (wot-dir-creation (c) + (format t "Failed to make temporary WoT directory: ~S.~%" (text c))) + (wot-dir-dne (c) + (format t "WoT directory not found at location ~S.~%" (text c)))))