source: trunk/abcl/contrib/asdf-install/installer.lisp @ 13027

Last change on this file since 13027 was 13027, checked in by Mark Evenson, 12 years ago

Fix ASDF-INSTALL fails to download (ticket #110).

Use an 8-bit encoding (:iso-8559-1) in the streams for the package
download to prevent attempts to recode if ABCL is running under a
multi-bit encoding locale (i.e. UTF-8).

Ensure that we use 'gtar' under Solaris.

File size: 20.6 KB
Line 
1(in-package #:asdf-install)
2
3(pushnew :asdf-install *features*)
4
5(defun installer-msg (stream format-control &rest format-arguments)
6  (apply #'format stream "~&;;; ASDF-INSTALL: ~@?~%"
7   format-control format-arguments))
8
9(defun verify-gpg-signatures-p (url)
10  (labels ((prefixp (prefix string)
11       (let ((m (mismatch prefix string)))
12         (or (not m) (>= m (length prefix))))))
13    (case *verify-gpg-signatures*
14      ((nil) nil)
15      ((:unknown-locations)
16       (notany
17  (lambda (x) (prefixp x url))
18  *safe-url-prefixes*))
19      (t t))))
20   
21(defun same-central-registry-entry-p (a b)
22  (flet ((ensure-string (x)
23           (typecase x
24             (string x)
25             (pathname (namestring (translate-logical-pathname x)))
26             (t nil))))
27    (and (setf a (ensure-string a))
28         (setf b (ensure-string b))
29         a b (string-equal a b))))
30
31(defun add-registry-location (location)
32  (let ((location-directory (pathname-sans-name+type location)))
33    #+asdf
34    (pushnew location-directory
35       asdf:*central-registry*
36       :test #'same-central-registry-entry-p)
37 
38    #+mk-defsystem
39    (mk:add-registry-location location-directory)))
40
41;;; Fixing the handling of *LOCATIONS*
42
43(defun add-locations (loc-name site system-site)
44  (declare (type string loc-name)
45           (type pathname site system-site))
46  #+asdf
47  (progn
48    (pushnew site asdf:*central-registry* :test #'equal)
49    (pushnew system-site asdf:*central-registry* :test #'equal))
50
51  #+mk-defsystem
52  (progn
53    (mk:add-registry-location site)
54    (mk:add-registry-location system-site))
55  (setf *locations*
56        (append *locations* (list (list site system-site loc-name)))))
57
58;;;---------------------------------------------------------------------------
59;;; URL handling.
60
61(defun url-host (url)
62  (assert (string-equal url "http://" :end1 7))
63  (let* ((port-start (position #\: url :start 7))
64   (host-end (min (or (position #\/ url :start 7) (length url))
65      (or port-start (length url)))))
66    (subseq url 7 host-end)))
67
68(defun url-port (url)
69  (assert (string-equal url "http://" :end1 7))
70  (let ((port-start (position #\: url :start 7)))
71    (if port-start 
72  (parse-integer url :start (1+ port-start) :junk-allowed t) 80)))
73
74; This is from Juri Pakaste's <juri@iki.fi> base64.lisp
75(defparameter *encode-table*
76  "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=")
77
78(defun base64-encode (string)
79  (let ((result (make-array
80                 (list (* 4 (truncate (/ (+ 2 (length string)) 3))))
81                 :element-type 'base-char)))
82    (do ((sidx 0 (+ sidx 3))
83         (didx 0 (+ didx 4))
84         (chars 2 2)
85         (value nil nil))
86        ((>= sidx (length string)) t)
87      (setf value (ash (logand #xFF (char-code (char string sidx))) 8))
88      (dotimes (n 2)
89        (when (< (+ sidx n 1) (length string))
90          (setf value
91                (logior value
92                        (logand #xFF (char-code (char string (+ sidx n 1))))))
93          (incf chars))
94        (when (= n 0)
95          (setf value (ash value 8))))
96      (setf (elt result (+ didx 3))
97            (elt *encode-table* (if (> chars 3) (logand value #x3F) 64)))
98      (setf value (ash value -6))
99      (setf (elt result (+ didx 2))
100            (elt *encode-table* (if (> chars 2) (logand value #x3F) 64)))
101      (setf value (ash value -6))
102      (setf (elt result (+ didx 1))
103            (elt *encode-table* (logand value #x3F)))
104      (setf value (ash value -6))
105      (setf (elt result didx)
106            (elt *encode-table* (logand value #x3F))))
107    result))
108
109(defun request-uri (url)
110  (assert (string-equal url "http://" :end1 7))
111  (if *proxy*
112      url
113      (let ((path-start (position #\/ url :start 7)))
114  (assert (and path-start) nil "url does not specify a file.")
115        (subseq url path-start))))
116
117(defun url-connection (url)
118  (let ((stream (make-stream-from-url (or *proxy* url)))
119        (host (url-host url)))
120    (format stream "GET ~A HTTP/1.0~C~CHost: ~A~C~CCookie: CCLAN-SITE=~A~C~C"
121            (request-uri url) #\Return #\Linefeed
122            host #\Return #\Linefeed
123            *cclan-mirror* #\Return #\Linefeed)
124    (when (and *proxy-passwd* *proxy-user*)
125      (format stream "Proxy-Authorization: Basic ~A~C~C"
126              (base64-encode (format nil "~A:~A" *proxy-user* *proxy-passwd*))
127              #\Return #\Linefeed))
128    (format stream "~C~C" #\Return #\Linefeed)
129    (force-output stream)
130    (list
131     (let* ((l (read-header-line stream))
132            (space (position #\Space l)))
133       (parse-integer l :start (1+ space) :junk-allowed t))
134     (loop for line = (read-header-line stream)
135           until (or (null line)
136                     (zerop (length line))
137                     (eql (elt line 0) (code-char 13)))
138           collect
139           (let ((colon (position #\: line)))
140             (cons (intern (string-upcase (subseq line 0 colon)) :keyword)
141                   (string-trim (list #\Space (code-char 13))
142                                (subseq line (1+ colon))))))
143     stream)))
144
145(defun download-link-for-package (package-name-or-url)
146  (if (= (mismatch package-name-or-url "http://") 7)
147    package-name-or-url
148    (format nil "http://www.cliki.net/~A?download"
149            package-name-or-url)))
150
151(defun download-link-for-signature (url)
152  (concatenate 'string url ".asc"))
153
154;;; XXX unsightful hack
155(defvar *dont-check-signature* nil)
156
157(defun download-files-for-package (package-name-or-url)
158  (setf *dont-check-signature* nil)
159  (multiple-value-bind (package-url package-file) 
160      (download-url-to-temporary-file
161       (download-link-for-package package-name-or-url))
162    (if (verify-gpg-signatures-p package-name-or-url)
163        (restart-case
164            (multiple-value-bind (signature-url signature-file) 
165                (download-url-to-temporary-file
166                 (download-link-for-signature package-url))
167              (declare (ignore signature-url))
168              (values package-file signature-file))
169          (skip-gpg-check () 
170            :report "Don't check GPG signature for this package"
171            (progn
172              (setf *dont-check-signature* t)
173              (values package-file nil))))
174  (values package-file nil))))
175 
176(defun verify-gpg-signature (file-name signature-name)
177  (block verify
178    (when (and (null signature-name) *dont-check-signature*)
179      (return-from verify t))
180    (loop
181      (restart-case
182    (let ((tags (gpg-results file-name signature-name)))
183      ;; test that command returned something
184      (unless tags
185        (error 'gpg-shell-error))
186      ;; test for obvious key/sig problems
187      (let ((errsig (header-value :errsig tags)))
188        (and errsig (error 'key-not-found :key-id errsig)))
189      (let ((badsig (header-value :badsig tags)))
190        (and badsig (error 'key-not-found :key-id badsig)))
191      (let* ((good (header-value :goodsig tags))
192       (id (first good))
193       (name (format nil "~{~A~^ ~}" (rest good))))
194        ;; good signature, but perhaps not trusted
195        (restart-case
196      (let ((trusted? (or (header-pair :trust_ultimate tags)
197              (header-pair :trust_fully tags)))
198      (in-list? (assoc id *trusted-uids* :test #'equal)))
199        (cond ((or trusted? in-list?)
200         ;; ok
201         )
202        ((not trusted?)
203         (error 'key-not-trusted 
204          :key-user-name name :key-id id))
205        ((not in-list?)
206         (error 'author-not-trusted
207          :key-user-name name :key-id id))))
208    (add-key (&rest rest)
209      :report "Add to package supplier list"
210      (declare (ignore rest))
211      (pushnew (list id name) *trusted-uids*))))
212      (return-from verify t))
213        (install-anyways
214      (&rest rest)
215    :report "Don't check GPG signature for this package"
216    (declare (ignore rest))
217    (return-from verify t))
218        (retry-gpg-check
219      (&rest args)
220    :report "Retry GPG check \(e.g., after downloading the key\)"
221    (declare (ignore args))
222    nil)))))
223
224(defun header-value (name headers)
225  "Searchers headers for name _without_ case sensitivity. Headers should be an alist mapping symbols to values; name a symbol. Returns the value if name is found or nil if it is not."
226  (cdr (header-pair name headers)))
227
228(defun header-pair (name headers)
229  "Searchers headers for name _without_ case sensitivity. Headers should be an alist mapping symbols to values; name a symbol. Returns the \(name value\) pair if name is found or nil if it is not."
230  (assoc name headers 
231         :test (lambda (a b) 
232                 (string-equal (symbol-name a) (symbol-name b)))))
233
234(defun validate-preferred-location ()
235  (typecase *preferred-location*
236    (null t)
237    ((integer 0) 
238     (assert (<= 1 *preferred-location* (length *locations*)) 
239       (*preferred-location*)
240       'invalid-preferred-location-number-error
241       :preferred-location *preferred-location*))
242    ((or symbol string) 
243     (assert (find *preferred-location* *locations* 
244       :test (if (typep *preferred-location* 'symbol)
245           #'eq #'string-equal) :key #'third)
246       (*preferred-location*)
247       'invalid-preferred-location-name-error 
248       :preferred-location *preferred-location*))
249    (t
250     (assert nil 
251       (*preferred-location*)
252       'invalid-preferred-location-error 
253       :preferred-location *preferred-location*)))
254  *preferred-location*)
255
256(defun select-location ()
257  (loop with n-locations = (length *locations*)
258     for response = (progn
259          (format t "Install where?~%")
260          (loop for (source system name) in *locations*
261       for i from 1
262       do (format t "~A) ~A: ~%   System in ~A~%   Files in ~A ~%"
263            i name system source))
264          (format t "0) Abort installation.~% --> ")
265          (force-output)
266          (read))
267     when (and (numberp response)
268         (<= 1 response n-locations))
269     return response
270     when (and (numberp response)
271         (zerop response))
272     do (abort (make-condition 'installation-abort))))
273
274(defun install-location ()
275  (validate-preferred-location)
276  (let ((location-selection (or *preferred-location*
277        (select-location))))
278    (etypecase location-selection
279      (integer 
280       (elt *locations* (1- location-selection)))
281      ((or symbol string)
282       (find location-selection *locations* :key #'third
283       :test (if (typep location-selection 'string) 
284          #'string-equal #'eq))))))
285
286
287;;; install-package --
288
289(defun find-shell-command (command)
290  (loop for directory in *shell-search-paths* do
291       (let ((target (make-pathname :name command :type nil
292            :directory directory)))
293   (when (probe-file target)
294     (return-from find-shell-command (namestring target)))))
295  (values nil))
296
297(defun tar-command ()
298  #-(or :win32 :mswindows)
299  (find-shell-command *gnu-tar-program*)
300  #+(or :win32 :mswindows)
301  *cygwin-bash-program*)
302
303(defun tar-arguments (source packagename)
304  #-(or :win32 :mswindows :scl)
305  (list "-C"    (namestring (truename source))
306  "-xzvf" (namestring (truename packagename)))
307  #+(or :win32 :mswindows)
308  (list "-l"
309  "-c"
310  (format nil "\"tar -C \\\"`cygpath '~A'`\\\" -xzvf \\\"`cygpath '~A'`\\\"\""
311    (namestring (truename source))
312    (namestring (truename packagename))))
313  #+scl
314  (list "-C"    (ext:unix-namestring (truename source))
315  "-xzvf" (ext:unix-namestring (truename packagename))))
316
317(defun extract-using-tar (to-dir tarball)
318  (let ((tar-command (tar-command)))
319    (if (and tar-command (probe-file tar-command))
320  (return-output-from-program tar-command
321            (tar-arguments to-dir tarball))
322  (warn "Cannot find tar command ~S." tar-command))))
323
324(defun extract (to-dir tarball)
325  (or (some #'(lambda (extractor) (funcall extractor to-dir tarball))
326            *tar-extractors*)
327      (error "Unable to extract tarball ~A." tarball)))
328
329(defun install-package (source system packagename)
330  "Returns a list of system names (ASDF or MK:DEFSYSTEM) for installed systems."
331  (ensure-directories-exist source)
332  (ensure-directories-exist system)
333  (let* ((tar (extract source packagename))
334         ;; Some tar programs (OSX) list entries with preceeding "x "
335         ;; as in "x entry/file.asd"
336         (pos-begin (if (string= (subseq tar 0 2) "x ")
337                        2
338                        0))
339   (pos-slash (or (position #\/ tar)
340                        (position #\Return tar)
341                        (position #\Linefeed tar)))
342   (*default-pathname-defaults*
343    (merge-pathnames
344     (make-pathname :directory
345        `(:relative ,(subseq tar pos-begin pos-slash)))
346     source)))
347    (loop for sysfile in (append
348                          (directory
349               (make-pathname :defaults *default-pathname-defaults*
350                                          :name :wild
351                                          :type "asd"))
352                          (directory
353               (make-pathname :defaults *default-pathname-defaults*
354                                          :name :wild
355                                          :type "system")))
356       do (maybe-symlink-sysfile system sysfile)
357       do (installer-msg t "Found system definition: ~A" sysfile)
358       do (maybe-update-central-registry sysfile)
359       collect sysfile)))
360
361(defun maybe-update-central-registry (sysfile)
362  ;; make sure that the systems we install are accessible in case
363  ;; asdf-install:*locations* and asdf:*central-registry* are out
364  ;; of sync
365  (add-registry-location sysfile))
366
367(defun temp-file-name (p)
368  (declare (ignore p))
369  (let ((pathname nil))
370    (loop for i = 0 then (1+ i) do
371   (setf pathname 
372         (merge-pathnames
373    (make-pathname
374     :name (format nil "asdf-install-~d" i)
375     :type "asdf-install-tmp")
376    *temporary-directory*))
377   (unless (probe-file pathname)
378     (return-from temp-file-name pathname)))))
379
380
381;;; install
382;;; This is the external entry point.
383
384(defun install (packages &key (propagate nil) (where *preferred-location*))
385  (let* ((*preferred-location* where)
386   (*temporary-files* nil)
387         (trusted-uid-file 
388          (merge-pathnames "trusted-uids.lisp" *private-asdf-install-dirs*))
389   (*trusted-uids*
390          (when (probe-file trusted-uid-file)
391            (with-open-file (f trusted-uid-file) (read f))))
392         (old-uids (copy-list *trusted-uids*))
393         #+asdf
394         (*defined-systems* (if propagate 
395                              (make-hash-table :test 'equal)
396                              *defined-systems*))
397         (packages (if (atom packages) (list packages) packages))
398         (*propagate-installation* propagate)
399         (*systems-installed-this-time* nil))
400    (unwind-protect
401      (destructuring-bind (source system name) (install-location)
402        (declare (ignore name))
403        (labels 
404      ((one-iter (packages)
405         (let ((packages-to-install nil))
406     (loop for p in (mapcar #'string packages) do
407          (cond ((local-archive-p p)
408           (setf packages-to-install
409           (append packages-to-install 
410             (install-package source system p))))
411          (t
412           (multiple-value-bind (package signature)
413         (download-files-for-package p)
414             (when (verify-gpg-signatures-p p)
415         (verify-gpg-signature package signature))
416             (installer-msg t "Installing ~A in ~A, ~A"
417                p source system)
418             (install-package source system package))
419           (setf packages-to-install
420           (append packages-to-install 
421             (list p))))))
422     (dolist (package packages-to-install)
423       (setf package
424       (etypecase package
425         (symbol package)
426         (string (intern package :asdf-install))
427         (pathname (intern
428              (namestring (pathname-name package))
429              :asdf-install))))
430       (handler-bind
431           (
432      #+asdf
433      (asdf:missing-dependency
434       (lambda (c) 
435         (installer-msg
436          t
437          "Downloading package ~A, required by ~A~%"
438          (asdf::missing-requires c)
439          (asdf:component-name
440           (asdf::missing-required-by c)))
441         (one-iter 
442          (list (asdf::coerce-name 
443           (asdf::missing-requires c))))
444         (invoke-restart 'retry)))
445      #+mk-defsystem
446      (make:missing-component
447       (lambda (c) 
448         (installer-msg 
449          t
450          "Downloading package ~A, required by ~A~%"
451          (make:missing-component-name c)
452          package)
453         (one-iter (list (make:missing-component-name c)))
454         (invoke-restart 'retry))))
455         (loop (multiple-value-bind (ret restart-p)
456             (with-simple-restart
457           (retry "Retry installation")
458         (push package *systems-installed-this-time*)
459         (load-package package))
460           (declare (ignore ret))
461           (unless restart-p (return)))))))))
462    (one-iter packages)))
463      ;;; cleanup
464      (unless (equal old-uids *trusted-uids*)
465        (let ((create-file-p nil))
466    (unless (probe-file trusted-uid-file)
467      (installer-msg t "Trusted UID file ~A does not exist"
468         (namestring trusted-uid-file))
469      (setf create-file-p
470      (y-or-n-p "Do you want to create the file?")))
471          (when (or create-file-p (probe-file trusted-uid-file))
472      (ensure-directories-exist trusted-uid-file)
473      (with-open-file (out trusted-uid-file
474                                 :direction :output
475                                 :if-exists :supersede)
476        (with-standard-io-syntax
477          (prin1 *trusted-uids* out))))))
478      (dolist (l *temporary-files* t)
479  (when (probe-file l) (delete-file l))))
480    (nreverse *systems-installed-this-time*)))
481
482(defun local-archive-p (package)
483  #+(or :sbcl :allegro) (probe-file package)
484  #-(or :sbcl :allegro) (and (/= (mismatch package "http://") 7)
485         (probe-file package)))
486
487(defun load-package (package)
488  #+asdf
489  (progn
490    (installer-msg t "Loading system ~S via ASDF." package)
491    (asdf:operate 'asdf:load-op package))
492  #+mk-defsystem
493  (progn
494    (installer-msg t "Loading system ~S via MK:DEFSYSTEM." package)
495    (mk:load-system package)))
496
497;;; uninstall --
498
499(defun uninstall (system &optional (prompt t))
500  #+asdf
501  (let* ((asd (asdf:system-definition-pathname system))
502   (system (asdf:find-system system))
503   (dir (pathname-sans-name+type
504         (asdf::resolve-symlinks asd))))
505    (when (or (not prompt)
506        (y-or-n-p
507         "Delete system ~A~%asd file: ~A~%sources: ~A~%Are you sure?"
508         system asd dir))
509      #-(or :win32 :mswindows)
510      (delete-file asd)
511      (let ((dir (#-scl namestring #+scl ext:unix-namestring (truename dir))))
512  (when dir
513    (asdf:run-shell-command "rm -r '~A'" dir)))))
514
515  #+mk-defsystem
516  (multiple-value-bind (sysfile sysfile-exists-p)
517      (mk:system-definition-pathname system)
518    (when sysfile-exists-p
519      (let ((system (ignore-errors (mk:find-system system :error))))
520        (when system
521          (when (or (not prompt)
522              (y-or-n-p
523               "Delete system ~A.~%system file: ~A~%Are you sure?"
524               system
525                     sysfile))
526            (mk:clean-system system)
527            (delete-file sysfile)
528            (dolist (f (mk:files-in-system system))
529              (delete-file f)))
530          ))
531      )))
532
533     
534;;; some day we will also do UPGRADE, but we need to sort out version
535;;; numbering a bit better first
536
537#+(and :asdf (or :win32 :mswindows))
538(defun sysdef-source-dir-search (system)
539  (let ((name (asdf::coerce-name system)))
540    (dolist (location *locations*)
541      (let* ((dir (first location))
542             (files (directory (merge-pathnames
543                                (make-pathname :name name
544                                               :type "asd"
545                                               :version :newest
546                                               :directory '(:relative :wild)
547                                               :host nil
548                                               :device nil)
549                                dir))))
550        (dolist (file files)
551          (when (probe-file file)
552            (return-from sysdef-source-dir-search file)))))))
553
554(defmethod asdf:find-component :around 
555    ((module (eql nil)) name)
556  (when (or (not *propagate-installation*) 
557            (member name *systems-installed-this-time* 
558                    :test (lambda (a b)
559                            (flet ((ensure-string (x)
560                                     (etypecase x
561                                       (symbol (symbol-name x))
562                                       (string x))))
563                              (string-equal (ensure-string a) (ensure-string b))))))
564    (call-next-method)))
565
566(defun show-version-information ()
567  (let ((version (asdf-install-version)))
568    (if version
569      (format *standard-output* "~&;;; ASDF-Install version ~A"
570              version)
571      (format *standard-output* "~&;;; ASDF-Install version unknown; unable to find ASDF system definition."))
572  (values)))
573
574(defun asdf-install-version ()
575  "Returns the ASDf-Install version information as a string or nil if it cannot be determined."
576  (let ((system (asdf:find-system 'asdf-install)))
577    (when system (asdf:component-version system))))
578
579;; load customizations if any
580(eval-when (:load-toplevel :execute)
581  (let* ((*package* (find-package :asdf-install-customize))
582         (file (probe-file (merge-pathnames
583          (make-pathname :name ".asdf-install")
584          (truename (user-homedir-pathname))))))
585    (when file (load file))))
586
587;;; end of file -- install.lisp --
Note: See TracBrowser for help on using the repository browser.