1 (in-package :asdf-install)
3 (defvar *proxy* (posix-getenv "http_proxy"))
5 (or (posix-getenv "CCLAN_MIRROR")
6 "http://ftp.linux.org.uk/pub/lisp/cclan/"))
8 (defun directorify (name)
9 ;; input name may or may not have a training #\/, but we know we
11 (let ((path (pathname name)))
12 (if (pathname-name path)
14 (make-pathname :directory `(:relative ,(pathname-name path)))
15 (make-pathname :directory (pathname-directory path)
16 :host (pathname-host path)))
19 (defvar *sbcl-home* (directorify (posix-getenv "SBCL_HOME")))
21 (merge-pathnames (make-pathname :directory '(:relative ".sbcl"))
22 (user-homedir-pathname)))
24 (defparameter *trusted-uids* nil)
27 (defun verify-gpg-signatures-p (url)
28 (labels ((prefixp (prefix string)
29 (let ((m (mismatch prefix string)))
30 (or (not m) (>= m (length prefix))))))
31 (case *verify-gpg-signatures*
35 (lambda (x) (prefixp x url))
36 (cons *cclan-mirror* *safe-url-prefixes*)))
40 `((,(merge-pathnames "site/" *sbcl-home*)
41 ,(merge-pathnames "site-systems/" *sbcl-home*)
42 "System-wide install")
43 (,(merge-pathnames "site/" *dot-sbcl*)
44 ,(merge-pathnames "systems/" *dot-sbcl*)
45 "Personal installation")))
47 (let* ((*package* (find-package :asdf-install-customize))
48 (file (probe-file (merge-pathnames
49 (make-pathname :name ".asdf-install")
50 (user-homedir-pathname)))))
51 (when file (load file)))
53 (define-condition download-error (error)
54 ((url :initarg :url :reader download-url)
55 (response :initarg :response :reader download-response))
56 (:report (lambda (c s)
57 (format s "Server responded ~A for GET ~A"
58 (download-response c) (download-url c)))))
60 (define-condition signature-error (error)
61 ((cause :initarg :cause :reader signature-error-cause))
62 (:report (lambda (c s)
63 (format s "Cannot verify package signature: ~A"
64 (signature-error-cause c)))))
66 (define-condition gpg-error (error)
67 ((message :initarg :message :reader gpg-error-message))
68 (:report (lambda (c s)
69 (format t "GPG failed with error status:~%~S"
70 (gpg-error-message c)))))
72 (define-condition no-signature (gpg-error) ())
73 (define-condition key-not-found (gpg-error)
74 ((key-id :initarg :key-id :reader key-id))
75 (:report (lambda (c s)
76 (format s "No key found for key id 0x~A. Try some command like ~% gpg --recv-keys 0x~A"
77 (key-id c) (key-id c)))))
79 (define-condition key-not-trusted (gpg-error)
80 ((key-id :initarg :key-id :reader key-id)
81 (key-user-name :initarg :key-user-name :reader key-user-name))
82 (:report (lambda (c s)
83 (format s "GPG warns that the key id 0x~A (~A) is not fully trusted"
84 (key-id c) (key-user-name c)))))
85 (define-condition author-not-trusted (gpg-error)
86 ((key-id :initarg :key-id :reader key-id)
87 (key-user-name :initarg :key-user-name :reader key-user-name))
88 (:report (lambda (c s)
89 (format s "~A (key id ~A) is not on your package supplier list"
90 (key-user-name c) (key-id c)))))
93 (assert (string-equal url "http://" :end1 7))
94 (let* ((port-start (position #\: url :start 7))
95 (host-end (min (or (position #\/ url :start 7) (length url))
96 (or port-start (length url)))))
97 (subseq url 7 host-end)))
100 (assert (string-equal url "http://" :end1 7))
101 (let ((port-start (position #\: url :start 7)))
102 (if port-start (parse-integer url :start (1+ port-start) :junk-allowed t) 80)))
104 (defun url-connection (url)
105 (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp))
106 (host (url-host url))
107 (port (url-port url))
109 (declare (ignore port))
113 s (car (host-ent-addresses (get-host-by-name (url-host (or *proxy* url)))))
114 (url-port (or *proxy* url)))
115 (let ((stream (socket-make-stream s :input t :output t :buffering :full :external-format :iso-8859-1)))
116 ;; we are exceedingly unportable about proper line-endings here.
117 ;; Anyone wishing to run this under non-SBCL should take especial care
118 (format stream "GET ~A HTTP/1.0~c~%Host: ~A~c~%Cookie: CCLAN-SITE=~A~c~%~c~%"
119 url #\Return host #\Return *cclan-mirror* #\Return #\Return)
120 (force-output stream)
123 (let* ((l (read-line stream))
124 (space (position #\Space l)))
125 (parse-integer l :start (1+ space) :junk-allowed t))
126 (loop for line = (read-line stream nil nil)
127 until (or (null line) (eql (elt line 0) (code-char 13)))
129 (let ((colon (position #\: line)))
130 (cons (intern (string-upcase (subseq line 0 colon)) :keyword)
131 (string-trim (list #\Space (code-char 13))
132 (subseq line (1+ colon))))))
134 (when (and (null result)
138 (defun download-files-for-package (package-name-or-url file-name)
140 (if (= (mismatch package-name-or-url "http://") 7)
142 (format nil "http://www.cliki.net/~A?download"
143 package-name-or-url))))
144 (destructuring-bind (response headers stream)
147 (destructuring-bind (response headers stream) (url-connection url)
148 (unless (member response '(301 302))
149 (return-from got (list response headers stream)))
151 (setf url (cdr (assoc :location headers))))))
152 (if (>= response 400)
153 (error 'download-error :url url :response response))
154 (let ((length (parse-integer
155 (or (cdr (assoc :content-length headers)) "")
157 (format t "Downloading ~A bytes from ~A ..."
158 (if length length "some unknown number of") url)
160 (with-open-file (o file-name :direction :output :external-format :iso-8859-1)
162 (let ((buf (make-array length
164 (stream-element-type stream))))
165 (read-sequence buf stream)
166 (write-sequence buf o))
167 (sb-executable:copy-stream stream o))))
171 (verify-gpg-signature/url url file-name)
172 (skip-gpg-check (&rest rest)
173 :report "Don't check GPG signature for this package"
176 (defun read-until-eof (stream)
177 (with-output-to-string (o)
178 (sb-executable:copy-stream stream o)))
180 (defun verify-gpg-signature/string (string file-name)
185 "--status-fd" "1" "--verify" "-"
186 (namestring file-name))
187 :output :stream :error :stream :search t
188 :input (make-string-input-stream string) :wait t))
189 (ret (process-exit-code proc))
190 (err (read-until-eof (process-error proc)))
192 (loop for l = (read-line (process-output proc) nil nil)
194 when (> (mismatch l "[GNUPG:]") 6)
195 do (destructuring-bind (_ tag &rest data) (asdf::split l)
196 (pushnew (cons (intern tag :keyword)
198 ;; test for obvious key/sig problems
199 (let ((errsig (assoc :errsig tags)))
200 (and errsig (error 'key-not-found :key-id (second errsig) :gpg-err err)))
201 (let ((badsig (assoc :badsig tags)))
202 (and badsig (error 'key-not-found :key-id (second badsig) :gpg-err err)))
203 (let* ((good (assoc :goodsig tags))
205 (name (format nil "~{~A~^ ~}" (nthcdr 2 good))))
206 ;; good signature, but perhaps not trusted
207 (unless (or (assoc :trust_ultimate tags)
208 (assoc :trust_fully tags))
209 (cerror "Install the package anyway"
212 :key-id id :gpg-err err))
216 (or (assoc id *trusted-uids* :test #'equal)
217 (error 'author-not-trusted
219 :key-id id :gpg-err nil))
220 (add-key (&rest rest)
221 :report "Add to package supplier list"
222 (pushnew (list id name) *trusted-uids*)))
227 (defun verify-gpg-signature/url (url file-name)
228 (destructuring-bind (response headers stream)
229 (url-connection (concatenate 'string url ".asc"))
232 (let ((data (make-string (parse-integer
233 (cdr (assoc :content-length headers))
235 (read-sequence data stream)
236 (verify-gpg-signature/string data file-name))
237 (error 'download-error :url (concatenate 'string url ".asc")
242 (format t "Install where?~%")
243 (loop for (source system name) in *locations*
245 do (format t "~A) ~A: ~% System in ~A~% Files in ~A ~%"
246 i name system source))
247 (format t " --> ") (force-output)
248 (let ((response (read)))
250 (elt *locations* (1- response)))))
252 (defun install-package (source system packagename)
253 "Returns a list of asdf system names for installed asdf systems"
254 (ensure-directories-exist source )
255 (ensure-directories-exist system )
257 (with-output-to-string (o)
259 (sb-ext:run-program #-darwin "tar"
261 (list "-C" (namestring source)
262 "-xzvf" (namestring packagename))
266 (error "can't untar"))))
268 (pos-slash (position #\/ tar))
269 (*default-pathname-defaults*
271 (make-pathname :directory
272 `(:relative ,(subseq tar 0 pos-slash)))
274 (declare (ignore dummy))
275 (loop for asd in (directory
276 (make-pathname :name :wild :type "asd"))
277 do (let ((target (merge-pathnames
278 (make-pathname :name (pathname-name asd)
279 :type (pathname-type asd))
281 (when (probe-file target)
282 (sb-posix:unlink target))
283 (sb-posix:symlink asd target))
284 collect (pathname-name asd))))
286 (defvar *temporary-files*)
287 (defun temp-file-name (p)
288 (let* ((pos-slash (position #\/ p :from-end t))
289 (pos-dot (position #\. p :start (or pos-slash 0))))
292 :name (subseq p (if pos-slash (1+ pos-slash) 0) pos-dot)
293 :type "asdf-install-tmp"))))
296 ;; this is the external entry point
297 (defun install (&rest packages)
298 (let ((*temporary-files* nil)
300 (let ((p (merge-pathnames "trusted-uids.lisp" *dot-sbcl*)))
302 (with-open-file (f p) (read f))))))
304 (destructuring-bind (source system name) (where)
305 (labels ((one-iter (packages)
307 (loop for p in (mapcar 'string packages)
308 unless (probe-file p)
309 do (let ((tmp (temp-file-name p)))
310 (pushnew tmp *temporary-files*)
311 (download-files-for-package p tmp)
314 do (format t "Installing ~A in ~A,~A~%"
316 append (install-package source system p)))
318 ((asdf:missing-dependency
321 "Downloading package ~A, required by ~A~%"
322 (asdf::missing-requires c)
324 (asdf::missing-required-by c)))
327 (asdf::missing-requires c))))
328 (invoke-restart 'retry))))
330 (multiple-value-bind (ret restart-p)
332 (retry "Retry installation")
333 (asdf:operate 'asdf:load-op asd))
334 (unless restart-p (return))))))))
335 (one-iter packages)))
336 (let ((p (merge-pathnames "trusted-uids.lisp" *dot-sbcl*)))
337 (ensure-directories-exist p)
338 (with-open-file (out p :direction :output :if-exists :supersede)
339 (with-standard-io-syntax
340 (prin1 *trusted-uids* out))))
341 (dolist (l *temporary-files*)
342 (when (probe-file l) (delete-file l))))))
344 (defun uninstall (system &optional (prompt t))
345 (let* ((asd (asdf:system-definition-pathname system))
346 (system (asdf:find-system system))
347 (dir (asdf::pathname-sans-name+type
348 (asdf::resolve-symlinks asd))))
349 (when (or (not prompt)
351 "Delete system ~A~%asd file: ~A~%sources: ~A~%Are you sure?"
354 (asdf:run-shell-command "rm -r ~A" (namestring dir)))))
356 ;;; some day we will also do UPGRADE, but we need to sort out version
357 ;;; numbering a bit better first