(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*)
(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) ())
(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
(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
(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
(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))))))
(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
system)))
(when (probe-file target)
(sb-posix:unlink target))
+ #-win32
(sb-posix:symlink asd target))
collect (pathname-name asd))))
(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)
(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*)))
projects / sbcl.git / blobdiff