;; 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:
<command> ::= v <nullary> | <unary> | <binary>
<nullary> ::= flow | roots | leaves
  <unary> ::= ante | desc | path <vpatch-designator>
 <binary> ::= press <vpatch-designator> <press-directory>

<vpatch-designator> 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)))))