X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fasdf-install%2Finstaller.lisp;h=d17d7e1bcdf5988f2133ab517d85d299cad5f1e3;hb=ded744f74ab2f1a97679ad4f91e0eb8d995daef2;hp=c8a3551f559293a94e12ba11cdb4cbf130e76a76;hpb=08e218c9bd9fdfb1e4dcc5f5e245feea17762471;p=sbcl.git diff --git a/contrib/asdf-install/installer.lisp b/contrib/asdf-install/installer.lisp index c8a3551..d17d7e1 100644 --- a/contrib/asdf-install/installer.lisp +++ b/contrib/asdf-install/installer.lisp @@ -4,16 +4,16 @@ (defvar *cclan-mirror* (or (posix-getenv "CCLAN_MIRROR") "http://ftp.linux.org.uk/pub/lisp/cclan/")) - + (defun directorify (name) ;; input name may or may not have a training #\/, but we know we ;; want a directory (let ((path (pathname name))) (if (pathname-name path) (merge-pathnames - (make-pathname :directory `(:relative ,(pathname-name path)) - :name "") - path) + (make-pathname :directory `(:relative ,(pathname-name path))) + (make-pathname :directory (pathname-directory path) + :host (pathname-host path))) path))) (defvar *sbcl-home* (directorify (posix-getenv "SBCL_HOME"))) @@ -21,13 +21,8 @@ (merge-pathnames (make-pathname :directory '(:relative ".sbcl")) (user-homedir-pathname))) -(defvar *verify-gpg-signatures* :unknown-locations - "Should we get detached GPG signatures for the packages and verify them? -NIL - no, T - yes, :UNKNOWN-LOCATIONS - for any URL which isn't in CCLAN -and doesn't begin with one of the prefixes in *SAFE-URL-PREFIXES*") -(defvar *safe-url-prefixes* - (list "http://ftp.linux.org.uk/pub/lisp/" - "http://files.b9.com/")) +(defparameter *trusted-uids* nil) + (defun verify-gpg-signatures-p (url) (labels ((prefixp (prefix string) @@ -67,7 +62,33 @@ and doesn't begin with one of the prefixes in *SAFE-URL-PREFIXES*") (:report (lambda (c s) (format s "Cannot verify package signature: ~A" (signature-error-cause c))))) - + +(define-condition gpg-error (error) + ((message :initarg :message :reader gpg-error-message)) + (:report (lambda (c s) + (format t "GPG failed with error status:~%~S" + (gpg-error-message c))))) + +(define-condition no-signature (gpg-error) ()) +(define-condition key-not-found (gpg-error) + ((key-id :initarg :key-id :reader key-id)) + (:report (lambda (c s) + (format s "No key found for key id 0x~A. Try some command like ~% gpg --recv-keys 0x~A" + (key-id c) (key-id c))))) + +(define-condition key-not-trusted (gpg-error) + ((key-id :initarg :key-id :reader key-id) + (key-user-name :initarg :key-user-name :reader key-user-name)) + (:report (lambda (c s) + (format s "GPG warns that the key id 0x~A (~A) is not fully trusted" + (key-id c) (key-user-name c))))) +(define-condition author-not-trusted (gpg-error) + ((key-id :initarg :key-id :reader key-id) + (key-user-name :initarg :key-user-name :reader key-user-name)) + (:report (lambda (c s) + (format s "~A (key id ~A) is not on your package supplier list" + (key-user-name c) (key-id c))))) + (defun url-host (url) (assert (string-equal url "http://" :end1 7)) (let* ((port-start (position #\: url :start 7)) @@ -78,12 +99,13 @@ and doesn't begin with one of the prefixes in *SAFE-URL-PREFIXES*") (defun url-port (url) (assert (string-equal url "http://" :end1 7)) (let ((port-start (position #\: url :start 7))) - (if port-start (parse-integer url :start port-start :junk-allowed t) 80))) + (if port-start (parse-integer url :start (1+ port-start) :junk-allowed t) 80))) (defun url-connection (url) (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp)) (host (url-host url)) (port (url-port url))) + (declare (ignore port)) (socket-connect s (car (host-ent-addresses (get-host-by-name (url-host (or *proxy* url))))) (url-port (or *proxy* url))) @@ -138,47 +160,76 @@ and doesn't begin with one of the prefixes in *SAFE-URL-PREFIXES*") (sb-executable:copy-stream stream o)))) (close stream) (terpri) - ;; seems to have worked. let's try for a detached gpg signature too - (when (verify-gpg-signatures-p url) - (verify-gpg-signature url file-name))))) + (restart-case + (verify-gpg-signature/url url file-name) + (skip-gpg-check (&rest rest) + :report "Don't check GPG signature for this package" + nil))))) + +(defun read-until-eof (stream) + (with-output-to-string (o) + (sb-executable:copy-stream stream o))) + +(defun verify-gpg-signature/string (string file-name) + (let* ((proc + (sb-ext:run-program + "gpg" + (list + "--status-fd" "1" "--verify" "-" + (namestring file-name)) + :output :stream :error :stream :search t + :input (make-string-input-stream string) :wait t)) + (ret (process-exit-code proc)) + (err (read-until-eof (process-error proc))) + tags) + (loop for l = (read-line (process-output proc) nil nil) + while l + when (> (mismatch l "[GNUPG:]") 6) + do (destructuring-bind (_ tag &rest data) (asdf::split l) + (pushnew (cons (intern tag :keyword) + data) tags))) + ;; test for obvious key/sig problems + (let ((errsig (assoc :errsig tags))) + (and errsig (error 'key-not-found :key-id (second errsig) :gpg-err err))) + (let ((badsig (assoc :badsig tags))) + (and badsig (error 'key-not-found :key-id (second badsig) :gpg-err err))) + (let* ((good (assoc :goodsig tags)) + (id (second good)) + (name (format nil "~{~A~^ ~}" (nthcdr 2 good)))) + ;; good signature, but perhaps not trusted + (unless (or (assoc :trust_ultimate tags) + (assoc :trust_fully tags)) + (cerror "Install the package anyway" + 'key-not-trusted + :key-user-name name + :key-id id :gpg-err err)) + (loop + (when + (restart-case + (or (assoc id *trusted-uids* :test #'equal) + (error 'author-not-trusted + :key-user-name name + :key-id id :gpg-err nil)) + (add-key (&rest rest) + :report "Add to package supplier list" + (pushnew (list id name) *trusted-uids*))) + (return)))))) + -(defun verify-gpg-signature (url file-name) + +(defun verify-gpg-signature/url (url file-name) (destructuring-bind (response headers stream) (url-connection (concatenate 'string url ".asc")) (unwind-protect (if (= response 200) - ;; sadly, we can't pass the stream directly to run-program, - ;; because (at least in sbcl 0.8) that ignores existing buffered - ;; data and only reads new fresh data direct from the file - ;; descriptor (let ((data (make-string (parse-integer (cdr (assoc :content-length headers)) :junk-allowed t)))) (read-sequence data stream) - (let ((ret - (process-exit-code - (sb-ext:run-program "gpg" - (list "--verify" "-" - (namestring file-name)) - :output t - :search t - :input (make-string-input-stream data) - :wait t)))) - (unless (zerop ret) - (error 'signature-error - :cause (make-condition - 'simple-error - :format-control "GPG returned exit status ~A" - :format-arguments (list ret)))))) - (error 'signature-error - :cause - (make-condition - 'download-error :url (concatenate 'string url ".asc") - :response response))) + (verify-gpg-signature/string data file-name)) + (error 'download-error :url (concatenate 'string url ".asc") + :response response)) (close stream)))) - - - (defun where () (format t "Install where?~%") @@ -198,7 +249,8 @@ and doesn't begin with one of the prefixes in *SAFE-URL-PREFIXES*") (let* ((tar (with-output-to-string (o) (or - (sb-ext:run-program "tar" + (sb-ext:run-program #-darwin "tar" + #+darwin "gnutar" (list "-C" (namestring source) "-xzvf" (namestring packagename)) :output o @@ -212,6 +264,7 @@ and doesn't begin with one of the prefixes in *SAFE-URL-PREFIXES*") (make-pathname :directory `(:relative ,(subseq tar 0 pos-slash))) source))) + (declare (ignore dummy)) (loop for asd in (directory (make-pathname :name :wild :type "asd")) do (let ((target (merge-pathnames @@ -235,7 +288,11 @@ and doesn't begin with one of the prefixes in *SAFE-URL-PREFIXES*") ;; this is the external entry point (defun install (&rest packages) - (let ((*temporary-files* nil)) + (let ((*temporary-files* nil) + (*trusted-uids* + (let ((p (merge-pathnames "trusted-uids.lisp" *dot-sbcl*))) + (when (probe-file p) + (with-open-file (f p) (read f)))))) (unwind-protect (destructuring-bind (source system name) (where) (labels ((one-iter (packages) @@ -250,17 +307,44 @@ and doesn't begin with one of the prefixes in *SAFE-URL-PREFIXES*") do (format t "Installing ~A in ~A,~A~%" p source system) append (install-package source system p))) - (handler-case - (asdf:operate 'asdf:load-op asd) - (asdf:missing-dependency (c) - (format t - "Downloading package ~A, required by ~A~%" - (asdf::missing-requires c) - (asdf:component-name - (asdf::missing-required-by c))) - (one-iter (list - (symbol-name - (asdf::missing-requires c))))))))) + (handler-bind + ((asdf:missing-dependency + (lambda (c) + (format t + "Downloading package ~A, required by ~A~%" + (asdf::missing-requires c) + (asdf:component-name + (asdf::missing-required-by c))) + (one-iter (list + (symbol-name + (asdf::missing-requires c)))) + (invoke-restart 'retry)))) + (loop + (multiple-value-bind (ret restart-p) + (with-simple-restart + (retry "Retry installation") + (asdf:operate 'asdf:load-op asd)) + (unless restart-p (return)))))))) (one-iter packages))) + (let ((p (merge-pathnames "trusted-uids.lisp" *dot-sbcl*))) + (ensure-directories-exist p) + (with-open-file (out p :direction :output :if-exists :supersede) + (with-standard-io-syntax + (prin1 *trusted-uids* out)))) (dolist (l *temporary-files*) - (when (probe-file l) (delete-file l)))))) + (when (probe-file l) (delete-file l)))))) + +(defun uninstall (system &optional (prompt t)) + (let* ((asd (asdf:system-definition-pathname system)) + (system (asdf:find-system system)) + (dir (asdf::pathname-sans-name+type + (asdf::resolve-symlinks asd)))) + (when (or (not prompt) + (y-or-n-p + "Delete system ~A~%asd file: ~A~%sources: ~A~%Are you sure?" + system asd dir)) + (delete-file asd) + (asdf:run-shell-command "rm -r ~A" (namestring dir))))) + +;;; some day we will also do UPGRADE, but we need to sort out version +;;; numbering a bit better first