(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)
- path)))
+ (merge-pathnames
+ (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")))
(defvar *dot-sbcl*
(merge-pathnames (make-pathname :directory '(:relative ".sbcl"))
- (user-homedir-pathname)))
+ (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)
- (let ((m (mismatch prefix string)))
- (or (not m) (>= m (length prefix))))))
- (case *verify-gpg-signatures*
- (nil nil)
- (:unknown-locations
- (notany
- (lambda (x) (prefixp x url))
- (cons *cclan-mirror* *safe-url-prefixes*)))
- (t t))))
-
(defvar *locations*
`((,(merge-pathnames "site/" *sbcl-home*)
,(merge-pathnames "site-systems/" *sbcl-home*)
(let* ((*package* (find-package :asdf-install-customize))
(file (probe-file (merge-pathnames
- (make-pathname :name ".asdf-install")
- (user-homedir-pathname)))))
+ (make-pathname :name ".asdf-install")
+ (user-homedir-pathname)))))
(when file (load file)))
(define-condition download-error (error)
((url :initarg :url :reader download-url)
(response :initarg :response :reader download-response))
(:report (lambda (c s)
- (format s "Server responded ~A for GET ~A"
- (download-response c) (download-url c)))))
+ (format s "Server responded ~A for GET ~A"
+ (download-response c) (download-url c)))))
(define-condition signature-error (error)
((cause :initarg :cause :reader signature-error-cause))
(:report (lambda (c s)
- (format s "Cannot verify package signature: ~A"
- (signature-error-cause c)))))
-
+ (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 s "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))
- (host-end (min (or (position #\/ url :start 7) (length url))
- (or port-start (length url)))))
+ (host-end (min (or (position #\/ url :start 7) (length url))
+ (or port-start (length url)))))
(subseq url 7 host-end)))
(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 request-uri (url)
+ (assert (string-equal url "http://" :end1 7))
+ (if *proxy*
+ url
+ (let ((path-start (position #\/ url :start 7)))
+ (subseq url path-start))))
(defun url-connection (url)
(let ((s (make-instance 'inet-socket :type :stream :protocol :tcp))
- (host (url-host url))
- (port (url-port url)))
+ (host (url-host url))
+ (port (url-port url))
+ result)
(declare (ignore port))
- (socket-connect
- s (car (host-ent-addresses (get-host-by-name (url-host (or *proxy* url)))))
- (url-port (or *proxy* url)))
- (let ((stream (socket-make-stream s :input t :output t :buffering :full)))
- ;; we are exceedingly unportable about proper line-endings here.
- ;; Anyone wishing to run this under non-SBCL should take especial care
- (format stream "GET ~A HTTP/1.0~%Host: ~A~%Cookie: CCLAN-SITE=~A~%~%"
- url host *cclan-mirror*)
- (force-output stream)
- (list
- (let* ((l (read-line stream))
- (space (position #\Space l)))
- (parse-integer l :start (1+ space) :junk-allowed t))
- (loop for line = (read-line stream nil nil)
- until (or (null line) (eql (elt line 0) (code-char 13)))
- collect
- (let ((colon (position #\: line)))
- (cons (intern (string-upcase (subseq line 0 colon)) :keyword)
- (string-trim (list #\Space (code-char 13))
- (subseq line (1+ colon))))))
- stream))))
+ (unwind-protect
+ (progn
+ (socket-connect
+ s (car (host-ent-addresses (get-host-by-name (url-host (or *proxy* url)))))
+ (url-port (or *proxy* url)))
+ (let ((stream (socket-make-stream s :input t :output t :buffering :full
+ :element-type :default :external-format :iso-8859-1)))
+ ;; we are exceedingly unportable about proper line-endings here.
+ ;; Anyone wishing to run this under non-SBCL should take especial care
+ (format stream "GET ~A HTTP/1.0~c~%~
+ Host: ~A~c~%~
+ Cookie: CCLAN-SITE=~A~c~%~c~%"
+ (request-uri url) #\Return
+ host #\Return
+ *cclan-mirror* #\Return #\Return)
+ (force-output stream)
+ (setf result
+ (list
+ (let* ((l (read-line stream))
+ (space (position #\Space l)))
+ (parse-integer l :start (1+ space) :junk-allowed t))
+ (loop for line = (read-line stream nil nil)
+ until (or (null line) (eql (elt line 0) (code-char 13)))
+ collect
+ (let ((colon (position #\: line)))
+ (cons (intern (string-upcase (subseq line 0 colon)) :keyword)
+ (string-trim (list #\Space (code-char 13))
+ (subseq line (1+ colon))))))
+ stream))))
+ (when (and (null result)
+ (socket-open-p s))
+ (socket-close s)))))
+
+
+(defun copy-stream (in out)
+ (let ((buf (make-array 8192 :element-type (stream-element-type in))))
+ (loop for pos = (read-sequence buf in)
+ until (zerop pos)
+ do (write-sequence buf out :end pos))))
(defun download-files-for-package (package-name-or-url file-name)
(let ((url
- (if (= (mismatch package-name-or-url "http://") 7)
- package-name-or-url
- (format nil "http://www.cliki.net/~A?download"
- package-name-or-url))))
+ (if (= (mismatch package-name-or-url "http://") 7)
+ package-name-or-url
+ (format nil "http://www.cliki.net/~A?download"
+ package-name-or-url))))
(destructuring-bind (response headers stream)
- (block got
- (loop
- (destructuring-bind (response headers stream) (url-connection url)
- (unless (member response '(301 302))
- (return-from got (list response headers stream)))
- (close stream)
- (setf url (cdr (assoc :location headers))))))
+ (block got
+ (loop
+ (destructuring-bind (response headers stream) (url-connection url)
+ (unless (member response '(301 302))
+ (return-from got (list response headers stream)))
+ (close stream)
+ (setf url (cdr (assoc :location headers))))))
(if (>= response 400)
- (error 'download-error :url url :response response))
+ (error 'download-error :url url :response response))
(let ((length (parse-integer
- (or (cdr (assoc :content-length headers)) "")
- :junk-allowed t)))
- (format t "Downloading ~A bytes from ~A ..."
- (if length length "some unknown number of") url)
- (force-output)
- (with-open-file (o file-name :direction :output)
- (if length
- (let ((buf (make-array length
- :element-type
- (stream-element-type stream) )))
- (read-sequence buf stream)
- (write-sequence buf o))
- (sb-executable:copy-stream stream o))))
+ (or (cdr (assoc :content-length headers)) "")
+ :junk-allowed t)))
+ (format t "Downloading ~A bytes from ~A ..."
+ (if length length "some unknown number of") url)
+ (force-output)
+ (with-open-file (out file-name :direction :output
+ :element-type '(unsigned-byte 8))
+ (if length
+ (let ((buf (make-array length :element-type '(unsigned-byte 8))))
+ (read-sequence buf stream)
+ (write-sequence buf out))
+ (copy-stream stream out))))
(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 ()
+ :report "Don't check GPG signature for this package"
+ nil)))))
+
+(defun read-until-eof (stream)
+ (with-output-to-string (o)
+ (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))
+ (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)
+ (declare (ignore _))
+ (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 ()
+ :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)))
+ (if (= response 200)
+ (let ((data (make-string (parse-integer
+ (cdr (assoc :content-length headers))
+ :junk-allowed t))))
+ (read-sequence data stream)
+ (verify-gpg-signature/string data file-name))
+ (error 'download-error :url (concatenate 'string url ".asc")
+ :response response))
(close stream))))
-
-
-
-(defun where ()
+(defun where ()
(format t "Install where?~%")
(loop for (source system name) in *locations*
- for i from 1
- do (format t "~A) ~A: ~% System in ~A~% Files in ~A ~%"
- i name system source))
+ for i from 1
+ do (format t "~A) ~A: ~% System in ~A~% Files in ~A ~%"
+ i name system source))
(format t " --> ") (force-output)
(let ((response (read)))
(when (> response 0)
(defun install-package (source system packagename)
"Returns a list of asdf system names for installed asdf systems"
- (ensure-directories-exist source )
- (ensure-directories-exist system )
+ (ensure-directories-exist source)
+ (ensure-directories-exist system)
(let* ((tar
- (with-output-to-string (o)
- (or
- (sb-ext:run-program "tar"
- (list "-C" (namestring source)
- "-xzvf" (namestring packagename))
- :output o
- :search t
- :wait t)
- (error "can't untar"))))
- (dummy (princ tar))
- (pos-slash (position #\/ tar))
- (*default-pathname-defaults*
- (merge-pathnames
- (make-pathname :directory
- `(:relative ,(subseq tar 0 pos-slash)))
- source)))
+ (with-output-to-string (o)
+ (or
+ (sb-ext:run-program #-darwin "tar"
+ #+darwin "gnutar"
+ (list "-C" (namestring source)
+ "-xzvf" (namestring packagename))
+ :output o
+ :search t
+ :wait t)
+ (error "can't untar"))))
+ (dummy (princ tar))
+ (pos-slash (position #\/ tar))
+ (*default-pathname-defaults*
+ (merge-pathnames
+ (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
- (make-pathname :name (pathname-name asd)
- :type (pathname-type asd))
- system)))
- (when (probe-file target)
- (sb-posix:unlink target))
- (sb-posix:symlink asd target))
- collect (pathname-name asd))))
+ (make-pathname :name :wild :type "asd"))
+ do (let ((target (merge-pathnames
+ (make-pathname :name (pathname-name asd)
+ :type (pathname-type asd))
+ system)))
+ (when (probe-file target)
+ (sb-posix:unlink target))
+ #-win32
+ (sb-posix:symlink asd target))
+ collect (pathname-name asd))))
(defvar *temporary-files*)
(defun temp-file-name (p)
(let* ((pos-slash (position #\/ p :from-end t))
- (pos-dot (position #\. p :start (or pos-slash 0))))
+ (pos-dot (position #\. p :start (or pos-slash 0))))
(merge-pathnames
(make-pathname
:name (subseq p (if pos-slash (1+ pos-slash) 0) pos-dot)
:type "asdf-install-tmp"))))
-
+
;; 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)
- (dolist (asd
- (loop for p in (mapcar 'string packages)
- unless (probe-file p)
- do (let ((tmp (temp-file-name p)))
- (pushnew tmp *temporary-files*)
- (download-files-for-package p tmp)
- (setf p tmp))
- end
- 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)))))))))
- (one-iter packages)))
+ (destructuring-bind (source system name) (where)
+ (declare (ignore name))
+ (labels ((one-iter (packages)
+ (dolist (asd
+ (loop for p in (mapcar 'string packages)
+ unless (probe-file p)
+ do (let ((tmp (temp-file-name p)))
+ (pushnew tmp *temporary-files*)
+ (download-files-for-package p tmp)
+ (setf p tmp))
+ end
+ do (format t "Installing ~A in ~A,~A~%"
+ p source system)
+ append (install-package source system p)))
+ (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))
+ (declare (ignore ret))
+ (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