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)
137 (defun download-files-for-package (package-name-or-url file-name)
139 (if (= (mismatch package-name-or-url "http://") 7)
141 (format nil "http://www.cliki.net/~A?download"
142 package-name-or-url))))
143 (destructuring-bind (response headers stream)
146 (destructuring-bind (response headers stream) (url-connection url)
147 (unless (member response '(301 302))
148 (return-from got (list response headers stream)))
150 (setf url (cdr (assoc :location headers))))))
151 (if (>= response 400)
152 (error 'download-error :url url :response response))
153 (let ((length (parse-integer
154 (or (cdr (assoc :content-length headers)) "")
156 (format t "Downloading ~A bytes from ~A ..."
157 (if length length "some unknown number of") url)
159 (with-open-file (o file-name :direction :output :element-type '(unsigned-byte 8))
161 (let ((buf (make-array length
163 '(unsigned-byte 8))))
164 (read-sequence buf stream)
165 (write-sequence buf o))
166 (sb-executable:copy-stream stream o :element-type '(unsigned-byte 8)))))
170 (verify-gpg-signature/url url file-name)
172 :report "Don't check GPG signature for this package"
175 (defun read-until-eof (stream)
176 (with-output-to-string (o)
177 (sb-executable:copy-stream stream o)))
179 (defun verify-gpg-signature/string (string file-name)
184 "--status-fd" "1" "--verify" "-"
185 (namestring file-name))
186 :output :stream :error :stream :search t
187 :input (make-string-input-stream string) :wait t))
188 (err (read-until-eof (process-error proc)))
190 (loop for l = (read-line (process-output proc) nil nil)
192 when (> (mismatch l "[GNUPG:]") 6)
193 do (destructuring-bind (_ tag &rest data) (asdf::split l)
195 (pushnew (cons (intern tag :keyword)
197 ;; test for obvious key/sig problems
198 (let ((errsig (assoc :errsig tags)))
199 (and errsig (error 'key-not-found :key-id (second errsig) :gpg-err err)))
200 (let ((badsig (assoc :badsig tags)))
201 (and badsig (error 'key-not-found :key-id (second badsig) :gpg-err err)))
202 (let* ((good (assoc :goodsig tags))
204 (name (format nil "~{~A~^ ~}" (nthcdr 2 good))))
205 ;; good signature, but perhaps not trusted
206 (unless (or (assoc :trust_ultimate tags)
207 (assoc :trust_fully tags))
208 (cerror "Install the package anyway"
211 :key-id id :gpg-err err))
215 (or (assoc id *trusted-uids* :test #'equal)
216 (error 'author-not-trusted
218 :key-id id :gpg-err nil))
220 :report "Add to package supplier list"
221 (pushnew (list id name) *trusted-uids*)))
226 (defun verify-gpg-signature/url (url file-name)
227 (destructuring-bind (response headers stream)
228 (url-connection (concatenate 'string url ".asc"))
231 (let ((data (make-string (parse-integer
232 (cdr (assoc :content-length headers))
234 (read-sequence data stream)
235 (verify-gpg-signature/string data file-name))
236 (error 'download-error :url (concatenate 'string url ".asc")
241 (format t "Install where?~%")
242 (loop for (source system name) in *locations*
244 do (format t "~A) ~A: ~% System in ~A~% Files in ~A ~%"
245 i name system source))
246 (format t " --> ") (force-output)
247 (let ((response (read)))
249 (elt *locations* (1- response)))))
251 (defun install-package (source system packagename)
252 "Returns a list of asdf system names for installed asdf systems"
253 (ensure-directories-exist source )
254 (ensure-directories-exist system )
256 (with-output-to-string (o)
258 (sb-ext:run-program #-darwin "tar"
260 (list "-C" (namestring source)
261 "-xzvf" (namestring packagename))
265 (error "can't untar"))))
267 (pos-slash (position #\/ tar))
268 (*default-pathname-defaults*
270 (make-pathname :directory
271 `(:relative ,(subseq tar 0 pos-slash)))
273 (declare (ignore dummy))
274 (loop for asd in (directory
275 (make-pathname :name :wild :type "asd"))
276 do (let ((target (merge-pathnames
277 (make-pathname :name (pathname-name asd)
278 :type (pathname-type asd))
280 (when (probe-file target)
281 (sb-posix:unlink target))
282 (sb-posix:symlink asd target))
283 collect (pathname-name asd))))
285 (defvar *temporary-files*)
286 (defun temp-file-name (p)
287 (let* ((pos-slash (position #\/ p :from-end t))
288 (pos-dot (position #\. p :start (or pos-slash 0))))
291 :name (subseq p (if pos-slash (1+ pos-slash) 0) pos-dot)
292 :type "asdf-install-tmp"))))
295 ;; this is the external entry point
296 (defun install (&rest packages)
297 (let ((*temporary-files* nil)
299 (let ((p (merge-pathnames "trusted-uids.lisp" *dot-sbcl*)))
301 (with-open-file (f p) (read f))))))
303 (destructuring-bind (source system name) (where)
304 (declare (ignore name))
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 (declare (ignore ret))
335 (unless restart-p (return))))))))
336 (one-iter packages)))
337 (let ((p (merge-pathnames "trusted-uids.lisp" *dot-sbcl*)))
338 (ensure-directories-exist p)
339 (with-open-file (out p :direction :output :if-exists :supersede)
340 (with-standard-io-syntax
341 (prin1 *trusted-uids* out))))
342 (dolist (l *temporary-files*)
343 (when (probe-file l) (delete-file l))))))
345 (defun uninstall (system &optional (prompt t))
346 (let* ((asd (asdf:system-definition-pathname system))
347 (system (asdf:find-system system))
348 (dir (asdf::pathname-sans-name+type
349 (asdf::resolve-symlinks asd))))
350 (when (or (not prompt)
352 "Delete system ~A~%asd file: ~A~%sources: ~A~%Are you sure?"
355 (asdf:run-shell-command "rm -r ~A" (namestring dir)))))
357 ;;; some day we will also do UPGRADE, but we need to sort out version
358 ;;; numbering a bit better first