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 `((,(merge-pathnames "site/" *sbcl-home*)
28 ,(merge-pathnames "site-systems/" *sbcl-home*)
29 "System-wide install")
30 (,(merge-pathnames "site/" *dot-sbcl*)
31 ,(merge-pathnames "systems/" *dot-sbcl*)
32 "Personal installation")))
34 (let* ((*package* (find-package :asdf-install-customize))
35 (file (probe-file (merge-pathnames
36 (make-pathname :name ".asdf-install")
37 (user-homedir-pathname)))))
38 (when file (load file)))
40 (define-condition download-error (error)
41 ((url :initarg :url :reader download-url)
42 (response :initarg :response :reader download-response))
43 (:report (lambda (c s)
44 (format s "Server responded ~A for GET ~A"
45 (download-response c) (download-url c)))))
47 (define-condition signature-error (error)
48 ((cause :initarg :cause :reader signature-error-cause))
49 (:report (lambda (c s)
50 (format s "Cannot verify package signature: ~A"
51 (signature-error-cause c)))))
53 (define-condition gpg-error (error)
54 ((message :initarg :message :reader gpg-error-message))
55 (:report (lambda (c s)
56 (format s "GPG failed with error status:~%~S"
57 (gpg-error-message c)))))
59 (define-condition no-signature (gpg-error) ())
60 (define-condition key-not-found (gpg-error)
61 ((key-id :initarg :key-id :reader key-id))
62 (:report (lambda (c s)
63 (format s "No key found for key id 0x~A. Try some command like ~% gpg --recv-keys 0x~A"
64 (key-id c) (key-id c)))))
66 (define-condition key-not-trusted (gpg-error)
67 ((key-id :initarg :key-id :reader key-id)
68 (key-user-name :initarg :key-user-name :reader key-user-name))
69 (:report (lambda (c s)
70 (format s "GPG warns that the key id 0x~A (~A) is not fully trusted"
71 (key-id c) (key-user-name c)))))
72 (define-condition author-not-trusted (gpg-error)
73 ((key-id :initarg :key-id :reader key-id)
74 (key-user-name :initarg :key-user-name :reader key-user-name))
75 (:report (lambda (c s)
76 (format s "~A (key id ~A) is not on your package supplier list"
77 (key-user-name c) (key-id c)))))
80 (assert (string-equal url "http://" :end1 7))
81 (let* ((port-start (position #\: url :start 7))
82 (host-end (min (or (position #\/ url :start 7) (length url))
83 (or port-start (length url)))))
84 (subseq url 7 host-end)))
87 (assert (string-equal url "http://" :end1 7))
88 (let ((port-start (position #\: url :start 7)))
89 (if port-start (parse-integer url :start (1+ port-start) :junk-allowed t) 80)))
91 (defun request-uri (url)
92 (assert (string-equal url "http://" :end1 7))
95 (let ((path-start (position #\/ url :start 7)))
96 (subseq url path-start))))
98 (defun url-connection (url)
99 (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp))
100 (host (url-host url))
101 (port (url-port url))
103 (declare (ignore port))
107 s (car (host-ent-addresses (get-host-by-name (url-host (or *proxy* url)))))
108 (url-port (or *proxy* url)))
109 (let ((stream (socket-make-stream s :input t :output t :buffering :full
110 :element-type :default :external-format :iso-8859-1)))
111 ;; we are exceedingly unportable about proper line-endings here.
112 ;; Anyone wishing to run this under non-SBCL should take especial care
113 (format stream "GET ~A HTTP/1.0~c~%~
115 Cookie: CCLAN-SITE=~A~c~%~c~%"
116 (request-uri url) #\Return
118 *cclan-mirror* #\Return #\Return)
119 (force-output stream)
122 (let* ((l (read-line stream))
123 (space (position #\Space l)))
124 (parse-integer l :start (1+ space) :junk-allowed t))
125 (loop for line = (read-line stream nil nil)
126 until (or (null line) (eql (elt line 0) (code-char 13)))
128 (let ((colon (position #\: line)))
129 (cons (intern (string-upcase (subseq line 0 colon)) :keyword)
130 (string-trim (list #\Space (code-char 13))
131 (subseq line (1+ colon))))))
133 (when (and (null result)
138 (defun copy-stream (in out)
139 (let ((buf (make-array 8192 :element-type (stream-element-type in))))
140 (loop for pos = (read-sequence buf in)
142 do (write-sequence buf out :end pos))))
144 (defun download-files-for-package (package-name-or-url file-name)
146 (if (= (mismatch package-name-or-url "http://") 7)
148 (format nil "http://www.cliki.net/~A?download"
149 package-name-or-url))))
150 (destructuring-bind (response headers stream)
153 (destructuring-bind (response headers stream) (url-connection url)
154 (unless (member response '(301 302))
155 (return-from got (list response headers stream)))
157 (setf url (cdr (assoc :location headers))))))
158 (if (>= response 400)
159 (error 'download-error :url url :response response))
160 (let ((length (parse-integer
161 (or (cdr (assoc :content-length headers)) "")
163 (format t "Downloading ~A bytes from ~A ..."
164 (if length length "some unknown number of") url)
166 (with-open-file (out file-name :direction :output
167 :element-type '(unsigned-byte 8))
169 (let ((buf (make-array length :element-type '(unsigned-byte 8))))
170 (read-sequence buf stream)
171 (write-sequence buf out))
172 (copy-stream stream out))))
176 (verify-gpg-signature/url url file-name)
178 :report "Don't check GPG signature for this package"
181 (defun read-until-eof (stream)
182 (with-output-to-string (o)
183 (copy-stream stream o)))
185 (defun verify-gpg-signature/string (string file-name)
190 "--status-fd" "1" "--verify" "-"
191 (namestring file-name))
192 :output :stream :error :stream :search t
193 :input (make-string-input-stream string) :wait t))
194 (err (read-until-eof (process-error proc)))
196 (loop for l = (read-line (process-output proc) nil nil)
198 when (> (mismatch l "[GNUPG:]") 6)
199 do (destructuring-bind (_ tag &rest data) (asdf::split l)
201 (pushnew (cons (intern tag :keyword)
203 ;; test for obvious key/sig problems
204 (let ((errsig (assoc :errsig tags)))
205 (and errsig (error 'key-not-found :key-id (second errsig) :gpg-err err)))
206 (let ((badsig (assoc :badsig tags)))
207 (and badsig (error 'key-not-found :key-id (second badsig) :gpg-err err)))
208 (let* ((good (assoc :goodsig tags))
210 (name (format nil "~{~A~^ ~}" (nthcdr 2 good))))
211 ;; good signature, but perhaps not trusted
212 (unless (or (assoc :trust_ultimate tags)
213 (assoc :trust_fully tags))
214 (cerror "Install the package anyway"
217 :key-id id :gpg-err err))
221 (or (assoc id *trusted-uids* :test #'equal)
222 (error 'author-not-trusted
224 :key-id id :gpg-err nil))
226 :report "Add to package supplier list"
227 (pushnew (list id name) *trusted-uids*)))
232 (defun verify-gpg-signature/url (url file-name)
233 (destructuring-bind (response headers stream)
234 (url-connection (concatenate 'string url ".asc"))
237 (let ((data (make-string (parse-integer
238 (cdr (assoc :content-length headers))
240 (read-sequence data stream)
241 (verify-gpg-signature/string data file-name))
242 (error 'download-error :url (concatenate 'string url ".asc")
247 (format t "Install where?~%")
248 (loop for (source system name) in *locations*
250 do (format t "~A) ~A: ~% System in ~A~% Files in ~A ~%"
251 i name system source))
252 (format t " --> ") (force-output)
253 (let ((response (read)))
255 (elt *locations* (1- response)))))
257 (defparameter *tar-program*
260 #-(or darwin sunos) "tar")
262 (defun get-tar-directory (packagename)
263 (let* ((tar (with-output-to-string (o)
265 (sb-ext:run-program *tar-program*
266 (list "-tzf" (namestring packagename))
270 (error "can't list archive"))))
271 (first-line (subseq tar 0 (position #\newline tar))))
272 (if (find #\/ first-line)
273 (subseq first-line 0 (position #\/ first-line))
276 (defun untar-package (source packagename)
277 (with-output-to-string (o)
279 (sb-ext:run-program *tar-program*
280 (list "-C" (namestring source)
281 "-xzvf" (namestring packagename))
285 (error "can't untar"))))
287 (defun install-package (source system packagename)
288 "Returns a list of asdf system names for installed asdf systems"
289 (ensure-directories-exist source)
290 (ensure-directories-exist system)
291 (let* ((tdir (get-tar-directory packagename))
292 (*default-pathname-defaults*
293 (merge-pathnames (make-pathname :directory `(:relative ,tdir))
295 (princ (untar-package source packagename))
296 (loop for asd in (directory
297 (make-pathname :name :wild :type "asd"))
298 do (let ((target (merge-pathnames
299 (make-pathname :name (pathname-name asd)
300 :type (pathname-type asd))
302 (when (probe-file target)
303 (sb-posix:unlink target))
305 (sb-posix:symlink asd target))
306 collect (pathname-name asd))))
308 (defvar *temporary-files*)
309 (defun temp-file-name (p)
310 (let* ((pos-slash (position #\/ p :from-end t))
311 (pos-dot (position #\. p :start (or pos-slash 0))))
314 :name (subseq p (if pos-slash (1+ pos-slash) 0) pos-dot)
315 :type "asdf-install-tmp"))))
318 ;; this is the external entry point
319 (defun install (&rest packages)
320 (let ((*temporary-files* nil)
322 (let ((p (merge-pathnames "trusted-uids.lisp" *dot-sbcl*)))
324 (with-open-file (f p) (read f))))))
326 (destructuring-bind (source system name) (where)
327 (declare (ignore name))
328 (labels ((one-iter (packages)
330 (loop for p in (mapcar 'string packages)
331 unless (probe-file p)
332 do (let ((tmp (temp-file-name p)))
333 (pushnew tmp *temporary-files*)
334 (download-files-for-package p tmp)
337 do (format t "Installing ~A in ~A,~A~%"
339 append (install-package source system p)))
341 ((asdf:missing-dependency
344 "Downloading package ~A, required by ~A~%"
345 (asdf::missing-requires c)
347 (asdf::missing-required-by c)))
350 (asdf::missing-requires c))))
351 (invoke-restart 'retry))))
353 (multiple-value-bind (ret restart-p)
355 (retry "Retry installation")
356 (asdf:operate 'asdf:load-op asd))
357 (declare (ignore ret))
358 (unless restart-p (return))))))))
359 (one-iter packages)))
360 (let ((p (merge-pathnames "trusted-uids.lisp" *dot-sbcl*)))
361 (ensure-directories-exist p)
362 (with-open-file (out p :direction :output :if-exists :supersede)
363 (with-standard-io-syntax
364 (prin1 *trusted-uids* out))))
365 (dolist (l *temporary-files*)
366 (when (probe-file l) (delete-file l))))))
368 (defun uninstall (system &optional (prompt t))
369 (let* ((asd (asdf:system-definition-pathname system))
370 (system (asdf:find-system system))
371 (dir (asdf::pathname-sans-name+type
372 (asdf::resolve-symlinks asd))))
373 (when (or (not prompt)
375 "Delete system ~A~%asd file: ~A~%sources: ~A~%Are you sure?"
378 (asdf:run-shell-command "rm -r ~A" (namestring dir)))))
380 ;;; some day we will also do UPGRADE, but we need to sort out version
381 ;;; numbering a bit better first