X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fasdf-install%2Finstaller.lisp;h=db89bf4463ad9b8c1fb6fe16c8340c34fe60e974;hb=3eb0a28fe6a7912d6ff2b97221325c0e3bfc5703;hp=0f5b1f153e4209027ce928f4f10a826596854536;hpb=1f7be74ab9c2117e236b9ff359764393271f98ac;p=sbcl.git diff --git a/contrib/asdf-install/installer.lisp b/contrib/asdf-install/installer.lisp index 0f5b1f1..db89bf4 100644 --- a/contrib/asdf-install/installer.lisp +++ b/contrib/asdf-install/installer.lisp @@ -23,19 +23,6 @@ (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*) @@ -66,7 +53,7 @@ (define-condition gpg-error (error) ((message :initarg :message :reader gpg-error-message)) (:report (lambda (c s) - (format t "GPG failed with error status:~%~S" + (format s "GPG failed with error status:~%~S" (gpg-error-message c))))) (define-condition no-signature (gpg-error) ()) @@ -101,39 +88,58 @@ (let ((port-start (position #\: url :start 7))) (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)) - result) + result) (declare (ignore port)) (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 :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~%" - 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)))) + (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))))) + (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 @@ -157,25 +163,24 @@ (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 :external-format :iso-8859-1) + (with-open-file (out file-name :direction :output + :element-type '(unsigned-byte 8)) (if length - (let ((buf (make-array length - :element-type - (stream-element-type stream)))) + (let ((buf (make-array length :element-type '(unsigned-byte 8)))) (read-sequence buf stream) - (write-sequence buf o)) - (sb-executable:copy-stream stream o)))) + (write-sequence buf out)) + (copy-stream stream out)))) (close stream) (terpri) (restart-case (verify-gpg-signature/url url file-name) - (skip-gpg-check (&rest rest) + (skip-gpg-check () :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))) + (copy-stream stream o))) (defun verify-gpg-signature/string (string file-name) (let* ((proc @@ -186,13 +191,13 @@ (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) + (declare (ignore _)) (pushnew (cons (intern tag :keyword) data) tags))) ;; test for obvious key/sig problems @@ -217,7 +222,7 @@ (error 'author-not-trusted :key-user-name name :key-id id :gpg-err nil)) - (add-key (&rest rest) + (add-key () :report "Add to package supplier list" (pushnew (list id name) *trusted-uids*))) (return)))))) @@ -251,8 +256,8 @@ (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 @@ -280,6 +285,7 @@ system))) (when (probe-file target) (sb-posix:unlink target)) + #-win32 (sb-posix:symlink asd target)) collect (pathname-name asd)))) @@ -302,6 +308,7 @@ (with-open-file (f p) (read f)))))) (unwind-protect (destructuring-bind (source system name) (where) + (declare (ignore name)) (labels ((one-iter (packages) (dolist (asd (loop for p in (mapcar 'string packages) @@ -331,6 +338,7 @@ (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*)))