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