faster SVREF and (SETF SVREF) compilation
[sbcl.git] / contrib / asdf-install / installer.lisp
1 (in-package :asdf-install)
2
3 (defvar *proxy* (posix-getenv "http_proxy"))
4 (defvar *cclan-mirror*
5   (let ((mirror (posix-getenv "CCLAN_MIRROR")))
6     (or (and (not (string= mirror "")) mirror)
7         "http://ftp.linux.org.uk/pub/lisp/cclan/")))
8
9 (defun directorify (name)
10   ;; input name may or may not have a training #\/, but we know we
11   ;; want a directory
12   (let ((path (pathname name)))
13     (if (pathname-name path)
14         (merge-pathnames
15          (make-pathname :directory `(:relative ,(pathname-name path)))
16          (make-pathname :directory (pathname-directory path)
17                         :host (pathname-host path)
18                         :device (pathname-device path)))
19         path)))
20
21 (defvar *sbcl-home* (directorify (posix-getenv "SBCL_HOME")))
22 (defvar *dot-sbcl*
23   (merge-pathnames (make-pathname :directory '(:relative ".sbcl"))
24                    (user-homedir-pathname)))
25
26 (defparameter *trusted-uids* nil)
27
28 (defvar *locations*
29   `((,(merge-pathnames "site/" *sbcl-home*)
30      ,(merge-pathnames "site-systems/" *sbcl-home*)
31      "System-wide install")
32     (,(merge-pathnames "site/" *dot-sbcl*)
33      ,(merge-pathnames "systems/" *dot-sbcl*)
34      "Personal installation")))
35
36 (unless (sb-ext:posix-getenv "SBCL_BUILDING_CONTRIB")
37   ;; Not during build, thanks.
38   (let* ((*package* (find-package :asdf-install-customize))
39          (file (probe-file (merge-pathnames
40                             (make-pathname :name ".asdf-install")
41                             (user-homedir-pathname)))))
42     (when file (load file))))
43
44 (define-condition download-error (error)
45   ((url :initarg :url :reader download-url)
46    (response :initarg :response :reader download-response))
47   (:report (lambda (c s)
48              (format s "Server responded ~A for GET ~A"
49                      (download-response c) (download-url c)))))
50
51 (define-condition signature-error (error)
52   ((cause :initarg :cause :reader signature-error-cause))
53   (:report (lambda (c s)
54              (format s "Cannot verify package signature:  ~A"
55                      (signature-error-cause c)))))
56
57 (define-condition gpg-error (error)
58   ((message :initarg :message :reader gpg-error-message))
59   (:report (lambda (c s)
60              (format s "GPG failed with error status:~%~S"
61                      (gpg-error-message c)))))
62
63 (define-condition no-signature (gpg-error) ())
64 (define-condition key-not-found (gpg-error)
65   ((key-id :initarg :key-id :reader key-id))
66   (:report (lambda (c s)
67              (format s "No key found for key id 0x~A.  Try some command like ~%  gpg  --recv-keys 0x~A"
68                      (key-id c) (key-id c)))))
69
70 (define-condition key-not-trusted (gpg-error)
71   ((key-id :initarg :key-id :reader key-id)
72    (key-user-name :initarg :key-user-name :reader key-user-name))
73   (:report (lambda (c s)
74              (format s "GPG warns that the key id 0x~A (~A) is not fully trusted"
75                      (key-id c) (key-user-name c)))))
76 (define-condition author-not-trusted (gpg-error)
77   ((key-id :initarg :key-id :reader key-id)
78    (key-user-name :initarg :key-user-name :reader key-user-name))
79   (:report (lambda (c s)
80              (format s "~A (key id ~A) is not on your package supplier list"
81                      (key-user-name c) (key-id c)))))
82
83 (defun url-host (url)
84   (assert (string-equal url "http://" :end1 7))
85   (let* ((port-start (position #\: url :start 7))
86          (host-end (min (or (position #\/ url :start 7) (length url))
87                         (or port-start (length url)))))
88     (subseq url 7 host-end)))
89
90 (defun url-port (url)
91   (assert (string-equal url "http://" :end1 7))
92   (let ((port-start (position #\: url :start 7)))
93     (if port-start (parse-integer url :start (1+ port-start) :junk-allowed t) 80)))
94
95 (defun request-uri (url)
96   (assert (string-equal url "http://" :end1 7))
97   (if *proxy*
98       url
99       (let ((path-start (position #\/ url :start 7)))
100         (subseq url path-start))))
101
102 (defun url-connection (url)
103   (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp))
104         (host (url-host url))
105         (port (url-port url))
106         result)
107     (declare (ignore port))
108     (unwind-protect
109         (progn
110           (socket-connect
111            s (car (host-ent-addresses (get-host-by-name (url-host (or *proxy* url)))))
112            (url-port (or  *proxy* url)))
113           (let ((stream (socket-make-stream s :input t :output t :buffering :full
114                                             :element-type :default :external-format :iso-8859-1)))
115             ;; we are exceedingly unportable about proper line-endings here.
116             ;; Anyone wishing to run this under non-SBCL should take especial care
117             (format stream "GET ~A HTTP/1.0~c~%~
118                             Host: ~A~c~%~
119                             Cookie: CCLAN-SITE=~A~c~%~c~%"
120                     (request-uri url) #\Return
121                     host #\Return
122                     *cclan-mirror* #\Return #\Return)
123             (force-output stream)
124             (setf result
125                   (list
126                    (let* ((l (read-line stream))
127                           (space (position #\Space l)))
128                      (parse-integer l :start (1+ space) :junk-allowed t))
129                    (loop for line = (read-line stream nil nil)
130                          until (or (null line) (eql (elt line 0) (code-char 13)))
131                          collect
132                          (let ((colon (position #\: line)))
133                            (cons (intern (string-upcase (subseq line 0 colon)) :keyword)
134                                  (string-trim (list #\Space (code-char 13))
135                                               (subseq line (1+ colon))))))
136                    stream))))
137       (when (and (null result)
138                  (socket-open-p s))
139         (socket-close s)))))
140
141
142 (defun copy-stream (in out)
143   (let ((buf (make-array 8192 :element-type (stream-element-type out))))
144     (loop for pos = (read-sequence buf in)
145           until (zerop pos)
146           do (write-sequence buf out :end pos))))
147
148 (defun download-files-for-package (package-name-or-url file-name)
149   (let ((url
150          (if (= (mismatch package-name-or-url "http://") 7)
151              package-name-or-url
152              (format nil "http://www.cliki.net/~A?download"
153                      package-name-or-url))))
154     (destructuring-bind (response headers stream)
155         (block got
156           (loop
157            (destructuring-bind (response headers stream) (url-connection url)
158              (unless (member response '(301 302))
159                (return-from got (list response headers stream)))
160              (close stream)
161              (setf url (cdr (assoc :location headers))))))
162       (if (>= response 400)
163         (error 'download-error :url url :response response))
164       (let ((length (parse-integer
165                      (or (cdr (assoc :content-length headers)) "")
166                      :junk-allowed t)))
167         (format t "Downloading ~A bytes from ~A ..."
168                 (if length length "some unknown number of") url)
169         (force-output)
170         (with-open-file (out file-name :direction :output
171                              :element-type '(unsigned-byte 8))
172           (if length
173               (let ((buf (make-array length :element-type '(unsigned-byte 8))))
174                 (read-sequence buf stream)
175                 (write-sequence buf out))
176               (copy-stream stream out))))
177       (close stream)
178       (terpri)
179       (restart-case
180           (verify-gpg-signature/url url file-name)
181         (skip-gpg-check ()
182           :report "Don't check GPG signature for this package"
183           nil)))))
184
185 (defun read-until-eof (stream)
186   (with-output-to-string (o)
187     (copy-stream stream o)))
188
189 (defun verify-gpg-signature/string (string file-name)
190   (let* ((proc
191           (sb-ext:run-program
192            "gpg"
193            (list
194             "--status-fd" "1" "--verify" "-"
195             (namestring file-name))
196            :output :stream :error :stream :search t
197            :input (make-string-input-stream string) :wait t))
198          (err (read-until-eof (process-error proc)))
199          tags)
200     (loop for l = (read-line (process-output proc) nil nil)
201           while l
202           when (> (mismatch l "[GNUPG:]") 6)
203           do (destructuring-bind (_ tag &rest data) (asdf::split-string l)
204                (declare (ignore _))
205                (pushnew (cons (intern tag :keyword)
206                               data) tags)))
207     ;; test for obvious key/sig problems
208     (let ((errsig (assoc :errsig tags)))
209       (and errsig (error 'key-not-found :key-id (second errsig) :gpg-err err)))
210     (let ((badsig (assoc :badsig tags)))
211       (and badsig (error 'key-not-found :key-id (second badsig) :gpg-err err)))
212     (let* ((good (assoc :goodsig tags))
213            (id (second good))
214            (name (format nil "~{~A~^ ~}" (nthcdr 2 good))))
215       ;; good signature, but perhaps not trusted
216       (unless (or (assoc :trust_ultimate tags)
217                   (assoc :trust_fully tags))
218         (cerror "Install the package anyway"
219                 'key-not-trusted
220                 :key-user-name name
221                 :key-id id :gpg-err err))
222       (loop
223        (when
224            (restart-case
225                (or (assoc id *trusted-uids* :test #'equal)
226                    (error 'author-not-trusted
227                           :key-user-name name
228                           :key-id id :gpg-err nil))
229              (add-key ()
230                :report "Add to package supplier list"
231                (pushnew (list id name) *trusted-uids*)))
232          (return))))))
233
234
235
236 (defun verify-gpg-signature/url (url file-name)
237   (destructuring-bind (response headers stream)
238       (url-connection (concatenate 'string url ".asc"))
239     (unwind-protect
240          (if (= response 200)
241              (let ((data (make-string (parse-integer
242                                        (cdr (assoc :content-length headers))
243                                        :junk-allowed t))))
244                (read-sequence data stream)
245                (verify-gpg-signature/string data file-name))
246              (error 'download-error :url  (concatenate 'string url ".asc")
247                     :response response))
248       (close stream))))
249
250 (defun where ()
251   (format t "Install where?~%")
252   (loop for (source system name) in *locations*
253         for i from 1
254         do (format t "~A) ~A: ~%   System in ~A~%   Files in ~A ~%"
255                    i name system source))
256   (format t " --> ") (force-output)
257   (let ((response (read)))
258     (when (> response 0)
259       (elt *locations* (1- response)))))
260
261 (defparameter *tar-program*
262   ;; Please do not "clean this up" by using a bunch of #+'s and one
263   ;; #-. When the conditional is written this way, adding a new
264   ;; special case only involves one change. If #- is used, two changes
265   ;; are needed. -- JES, 2007-02-12
266   (progn
267     "tar"
268     #+darwin "gnutar"
269     #+(or sunos netbsd) "gtar"))
270
271 (defun get-tar-directory (packagename)
272   (let* ((tar (with-output-to-string (o)
273                 (or
274                  (sb-ext:run-program *tar-program*
275                                      (list "-tzf" (namestring packagename))
276                                      :output o
277                                      :search t
278                                      :wait t)
279                  (error "can't list archive"))))
280          (first-line (subseq tar 0 (position #\newline tar))))
281     (if (find #\/ first-line)
282         (subseq first-line 0 (position #\/ first-line))
283         first-line)))
284
285 (defun untar-package (source packagename)
286   (with-output-to-string (o)
287     (or
288      (sb-ext:run-program *tar-program*
289                          (list "-C" (namestring source)
290                                "-xzvf" (namestring packagename))
291                          :output o
292                          :search t
293                          :wait t)
294      (error "can't untar"))))
295
296 (defun install-package (source system packagename)
297   "Returns a list of asdf system names for installed asdf systems"
298   (ensure-directories-exist source)
299   (ensure-directories-exist system)
300   (let* ((tdir (get-tar-directory packagename))
301          (*default-pathname-defaults*
302           (merge-pathnames (make-pathname :directory `(:relative ,tdir))
303                            source)))
304     (princ (untar-package source packagename))
305     (loop for asd in (directory
306                       (make-pathname :name :wild :type "asd"))
307           do (let ((target (merge-pathnames
308                             (make-pathname :name (pathname-name asd)
309                                            :type (pathname-type asd))
310                             system)))
311                (when (probe-file target)
312                  (sb-posix:unlink target))
313                #-win32
314                (sb-posix:symlink asd target))
315           collect (pathname-name asd))))
316
317 (defvar *temporary-files*)
318 (defun temp-file-name (p)
319   (let* ((pos-slash (position #\/ p :from-end t))
320          (pos-dot (position #\. p :start (or pos-slash 0))))
321     (merge-pathnames
322      (make-pathname
323       :name (subseq p (if pos-slash (1+ pos-slash) 0) pos-dot)
324       :type "asdf-install-tmp"))))
325
326
327 ;; this is the external entry point
328 (defun install (&rest packages)
329   (let ((*temporary-files* nil)
330         (*trusted-uids*
331          (let ((p (merge-pathnames "trusted-uids.lisp" *dot-sbcl*)))
332            (when (probe-file p)
333              (with-open-file (f p) (read f))))))
334     (unwind-protect
335          (destructuring-bind (source system name) (where)
336            (declare (ignore name))
337            (labels ((one-iter (packages)
338                       (dolist (asd
339                                 (loop for p in (mapcar 'string packages)
340                                       unless (probe-file p)
341                                       do (let ((tmp (temp-file-name p)))
342                                            (pushnew tmp *temporary-files*)
343                                            (download-files-for-package p tmp)
344                                            (setf p tmp))
345                                       end
346                                       do (format t "Installing ~A in ~A,~A~%"
347                                                  p source system)
348                                       append (install-package source system p)))
349                         (handler-bind
350                             ((asdf:missing-dependency
351                               (lambda (c)
352                                 (format t
353                                         "Downloading package ~A, required by ~A~%"
354                                         (asdf::missing-requires c)
355                                         (asdf:component-name
356                                          (asdf::missing-required-by c)))
357                                 (one-iter (list
358                                            (symbol-name
359                                             (asdf::missing-requires c))))
360                                 (invoke-restart 'retry))))
361                           (loop
362                            (multiple-value-bind (ret restart-p)
363                                (with-simple-restart
364                                    (retry "Retry installation")
365                                  (asdf:operate 'asdf:load-op asd))
366                              (declare (ignore ret))
367                              (unless restart-p (return))))))))
368              (one-iter packages)))
369       (let ((p (merge-pathnames "trusted-uids.lisp" *dot-sbcl*)))
370         (ensure-directories-exist p)
371         (with-open-file (out p :direction :output :if-exists :supersede)
372           (with-standard-io-syntax
373             (prin1 *trusted-uids* out))))
374       (dolist (l *temporary-files*)
375         (when (probe-file l) (delete-file l))))))
376
377 (defun uninstall (system &optional (prompt t))
378   (let* ((asd (asdf:system-definition-pathname system))
379          (system (asdf:find-system system))
380          (dir (asdf::pathname-sans-name+type
381                (asdf::resolve-symlinks asd))))
382     (when (or (not prompt)
383               (y-or-n-p
384                "Delete system ~A~%asd file: ~A~%sources: ~A~%Are you sure?"
385                system asd dir))
386       (delete-file asd)
387       (asdf:run-shell-command "rm -r ~A" (namestring dir)))))
388
389 ;;; some day we will also do UPGRADE, but we need to sort out version
390 ;;; numbering a bit better first