(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")))
(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)
(: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))
(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))
(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?~%")
(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
;; 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)
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
projects / sbcl.git / blobdiff