source: trunk/source/tools/asdf-install/installer.lisp @ 12898

Last change on this file since 12898 was 12898, checked in by rme, 10 years ago

Conditionalize SYSTEM-NAMESTRING for Clozure CL. Use SYSTEM-NAMESTRING
instead of NAMESTRING in several pertinent places. (see ticket:452)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 20.1 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(defun download-files-for-package (package-name-or-url)
155  (multiple-value-bind (package-url package-file) 
156      (download-url-to-temporary-file
157       (download-link-for-package package-name-or-url))
158    (if (verify-gpg-signatures-p package-name-or-url)
159        (multiple-value-bind (signature-url signature-file) 
160            (download-url-to-temporary-file
161             (download-link-for-signature package-url))
162          (declare (ignore signature-url))
163          (values package-file signature-file))
164        (values package-file nil))))
165 
166(defun verify-gpg-signature (file-name signature-name)
167  (block verify
168    (loop
169      (restart-case
170          (let ((tags (gpg-results file-name signature-name)))
171            ;; test that command returned something
172            (unless tags
173              (error 'gpg-shell-error))
174            ;; test for obvious key/sig problems
175            (let ((errsig (header-value :errsig tags)))
176              (and errsig (error 'key-not-found :key-id errsig)))
177            (let ((badsig (header-value :badsig tags)))
178              (and badsig (error 'key-not-found :key-id badsig)))
179            (let* ((good (header-value :goodsig tags))
180                   (id (first good))
181                   (name (format nil "~{~A~^ ~}" (rest good))))
182              ;; good signature, but perhaps not trusted
183              (restart-case
184                  (let ((trusted? (or (header-pair :trust_ultimate tags)
185                                      (header-pair :trust_fully tags)))
186                        (in-list? (assoc id *trusted-uids* :test #'equal)))
187                    (cond ((or trusted? in-list?)
188                           ;; ok
189                           )
190                          ((not trusted?)
191                           (error 'key-not-trusted 
192                                  :key-user-name name :key-id id))
193                          ((not in-list?)
194                           (error 'author-not-trusted
195                                  :key-user-name name :key-id id))))
196                (add-key (&rest rest)
197                  :report "Add to package supplier list"
198                  (declare (ignore rest))
199                  (pushnew (list id name) *trusted-uids*))))
200            (return-from verify t))
201        (install-anyways
202            (&rest rest)
203          :report "Don't check GPG signature for this package"
204          (declare (ignore rest))
205          (return-from verify t))
206        (retry-gpg-check
207            (&rest args)
208          :report "Retry GPG check \(e.g., after downloading the key\)"
209          (declare (ignore args))
210          nil)))))
211
212(defun header-value (name headers)
213  "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."
214  (cdr (header-pair name headers)))
215
216(defun header-pair (name headers)
217  "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."
218  (assoc name headers 
219         :test (lambda (a b) 
220                 (string-equal (symbol-name a) (symbol-name b)))))
221
222(defun validate-preferred-location ()
223  (typecase *preferred-location*
224    (null t)
225    ((integer 0) 
226     (assert (<= 1 *preferred-location* (length *locations*)) 
227             (*preferred-location*)
228             'invalid-preferred-location-number-error
229             :preferred-location *preferred-location*))
230    ((or symbol string) 
231     (assert (find *preferred-location* *locations* 
232                   :test (if (typep *preferred-location* 'symbol)
233                             #'eq #'string-equal) :key #'third)
234             (*preferred-location*)
235             'invalid-preferred-location-name-error 
236             :preferred-location *preferred-location*))
237    (t
238     (assert nil 
239             (*preferred-location*)
240             'invalid-preferred-location-error 
241             :preferred-location *preferred-location*)))
242  *preferred-location*)
243
244(defun select-location ()
245  (loop with n-locations = (length *locations*)
246     for response = (progn
247                      (format t "Install where?~%")
248                      (loop for (source system name) in *locations*
249                         for i from 1
250                         do (format t "~A) ~A: ~%   System in ~A~%   Files in ~A ~%"
251                                    i name system source))
252                      (format t "0) Abort installation.~% --> ")
253                      (force-output)
254                      (read))
255     when (and (numberp response)
256               (<= 1 response n-locations))
257     return response
258     when (and (numberp response)
259               (zerop response))
260     do (abort (make-condition 'installation-abort))))
261
262(defun install-location ()
263  (validate-preferred-location)
264  (let ((location-selection (or *preferred-location*
265                                (select-location))))
266    (etypecase location-selection
267      (integer 
268       (elt *locations* (1- location-selection)))
269      ((or symbol string)
270       (find location-selection *locations* :key #'third
271             :test (if (typep location-selection 'string) 
272                      #'string-equal #'eq))))))
273
274
275;;; install-package --
276
277(defun find-shell-command (command)
278  (loop for directory in *shell-search-paths* do
279       (let ((target (make-pathname :name command :type nil
280                                    :directory directory)))
281         (when (probe-file target)
282           (return-from find-shell-command (namestring target)))))
283  (values nil))
284
285(defun tar-command ()
286  #-(or :win32 :mswindows)
287  (find-shell-command *gnu-tar-program*)
288  #+(or :win32 :mswindows)
289  *cygwin-bash-program*)
290
291(defun tar-arguments (source packagename)
292  #-(or :win32 :mswindows :scl)
293  (list "-C" (system-namestring (truename source))
294        "-xzvf" (system-namestring (truename packagename)))
295  #+(or :win32 :mswindows)
296  (list "-l"
297        "-c"
298        (format nil "\"tar -C \\\"`cygpath '~A'`\\\" -xzvf \\\"`cygpath '~A'`\\\"\""
299                (system-namestring (truename source))
300                (system-namestring (truename packagename))))
301  #+scl
302  (list "-C" (ext:unix-namestring (truename source))
303        "-xzvf" (ext:unix-namestring (truename packagename))))
304
305(defun extract-using-tar (to-dir tarball)
306  (let ((tar-command (tar-command)))
307    (if (and tar-command (probe-file tar-command))
308        (return-output-from-program tar-command
309                                    (tar-arguments to-dir tarball))
310        (warn "Cannot find tar command ~S." tar-command))))
311
312(defun extract (to-dir tarball)
313  (or (some #'(lambda (extractor) (funcall extractor to-dir tarball))
314            *tar-extractors*)
315      (error "Unable to extract tarball ~A." tarball)))
316
317(defun install-package (source system packagename)
318  "Returns a list of system names (ASDF or MK:DEFSYSTEM) for installed systems."
319  (ensure-directories-exist source)
320  (ensure-directories-exist system)
321  (let* ((tar (extract source packagename))
322         (pos-slash (or (position #\/ tar)
323                        (position #\Return tar)
324                        (position #\Linefeed tar)))
325         (*default-pathname-defaults*
326          (merge-pathnames
327           (make-pathname :directory
328                          `(:relative ,(subseq tar 0 pos-slash)))
329           source)))
330    ;(princ tar)
331    (break)
332    (loop for sysfile in (append
333                          (directory
334                           (make-pathname :defaults *default-pathname-defaults*
335                                          :name :wild
336                                          :type "asd"))
337                          (directory
338                           (make-pathname :defaults *default-pathname-defaults*
339                                          :name :wild
340                                          :type "system")))
341       do (maybe-symlink-sysfile system sysfile)
342       do (installer-msg t "Found system definition: ~A" sysfile)
343       do (maybe-update-central-registry sysfile)
344       collect sysfile)))
345
346(defun maybe-update-central-registry (sysfile)
347  ;; make sure that the systems we install are accessible in case
348  ;; asdf-install:*locations* and asdf:*central-registry* are out
349  ;; of sync
350  (add-registry-location sysfile))
351
352(defun temp-file-name (p)
353  (declare (ignore p))
354  (let ((pathname nil))
355    (loop for i = 0 then (1+ i) do
356         (setf pathname 
357               (merge-pathnames
358                (make-pathname
359                 :name (format nil "asdf-install-~d" i)
360                 :type "asdf-install-tmp")
361                *temporary-directory*))
362         (unless (probe-file pathname)
363           (return-from temp-file-name pathname)))))
364
365
366;;; install
367;;; This is the external entry point.
368
369(defun install (packages &key (propagate nil) (where *preferred-location*))
370  (let* ((*preferred-location* where)
371         (*temporary-files* nil)
372         (trusted-uid-file 
373          (merge-pathnames "trusted-uids.lisp" *private-asdf-install-dirs*))
374         (*trusted-uids*
375          (when (probe-file trusted-uid-file)
376            (with-open-file (f trusted-uid-file) (read f))))
377         (old-uids (copy-list *trusted-uids*))
378         #+asdf
379         (*defined-systems* (if propagate 
380                              (make-hash-table :test 'equal)
381                              *defined-systems*))
382         (packages (if (atom packages) (list packages) packages))
383         (*propagate-installation* propagate)
384         (*systems-installed-this-time* nil))
385    (unwind-protect
386      (destructuring-bind (source system name) (install-location)
387        (declare (ignore name))
388        (labels 
389            ((one-iter (packages)
390               (let ((packages-to-install nil))
391                 (loop for p in (mapcar #'string packages) do
392                      (cond ((local-archive-p p)
393                             (setf packages-to-install
394                                   (append packages-to-install 
395                                           (install-package source system p))))
396                            (t
397                             (multiple-value-bind (package signature)
398                                 (download-files-for-package p)
399                               (when (verify-gpg-signatures-p p)
400                                 (verify-gpg-signature package signature))
401                               (installer-msg t "Installing ~A in ~A, ~A"
402                                              p source system)
403                               (install-package source system package))
404                             (setf packages-to-install
405                                   (append packages-to-install 
406                                           (list p))))))
407                 (dolist (package packages-to-install)
408                   (setf package
409                         (etypecase package
410                           (symbol package)
411                           (string (intern package :asdf-install))
412                           (pathname (intern
413                                      (namestring (pathname-name package))
414                                      :asdf-install))))
415                   (handler-bind
416                       (
417                        #+asdf
418                        (asdf:missing-dependency
419                         (lambda (c) 
420                           (installer-msg
421                            t
422                            "Downloading package ~A, required by ~A~%"
423                            (asdf::missing-requires c)
424                            (asdf:component-name
425                             (asdf::missing-required-by c)))
426                           (one-iter 
427                            (list (asdf::coerce-name 
428                                   (asdf::missing-requires c))))
429                           (invoke-restart 'retry)))
430                        #+mk-defsystem
431                        (make:missing-component
432                         (lambda (c) 
433                           (installer-msg 
434                            t
435                            "Downloading package ~A, required by ~A~%"
436                            (make:missing-component-name c)
437                            package)
438                           (one-iter (list (make:missing-component-name c)))
439                           (invoke-restart 'retry))))
440                     (loop (multiple-value-bind (ret restart-p)
441                               (with-simple-restart
442                                   (retry "Retry installation")
443                                 (push package *systems-installed-this-time*)
444                                 (load-package package))
445                             (declare (ignore ret))
446                             (unless restart-p (return)))))))))
447          (one-iter packages)))
448      ;;; cleanup
449      (unless (equal old-uids *trusted-uids*)
450        (let ((create-file-p nil))
451          (unless (probe-file trusted-uid-file)
452            (installer-msg t "Trusted UID file ~A does not exist"
453                           (namestring trusted-uid-file))
454            (setf create-file-p
455                  (y-or-n-p "Do you want to create the file?")))
456          (when (or create-file-p (probe-file trusted-uid-file))
457            (ensure-directories-exist trusted-uid-file)
458            (with-open-file (out trusted-uid-file
459                                 :direction :output
460                                 :if-exists :supersede)
461              (with-standard-io-syntax
462                (prin1 *trusted-uids* out))))))
463      (dolist (l *temporary-files* t)
464        (when (probe-file l) (delete-file l))))
465    (nreverse *systems-installed-this-time*)))
466
467(defun local-archive-p (package)
468  #+(or :sbcl :allegro) (probe-file package)
469  #-(or :sbcl :allegro) (and (/= (mismatch package "http://") 7)
470                           (probe-file package)))
471
472(defun load-package (package)
473  #+asdf
474  (progn
475    (installer-msg t "Loading system ~S via ASDF." package)
476    (asdf:operate 'asdf:load-op package))
477  #+mk-defsystem
478  (progn
479    (installer-msg t "Loading system ~S via MK:DEFSYSTEM." package)
480    (mk:load-system package)))
481
482;;; uninstall --
483
484(defun uninstall (system &optional (prompt t))
485  #+asdf
486  (let* ((asd (asdf:system-definition-pathname system))
487         (system (asdf:find-system system))
488         (dir (pathname-sans-name+type
489               (asdf::resolve-symlinks asd))))
490    (when (or (not prompt)
491              (y-or-n-p
492               "Delete system ~A~%asd file: ~A~%sources: ~A~%Are you sure?"
493               system asd dir))
494      #-(or :win32 :mswindows)
495      (delete-file asd)
496      (let ((dir (#-scl system-namestring #+scl ext:unix-namestring (truename dir))))
497        (when dir
498          (asdf:run-shell-command "rm -r '~A'" dir)))))
499
500  #+mk-defsystem
501  (multiple-value-bind (sysfile sysfile-exists-p)
502      (mk:system-definition-pathname system)
503    (when sysfile-exists-p
504      (let ((system (ignore-errors (mk:find-system system :error))))
505        (when system
506          (when (or (not prompt)
507                    (y-or-n-p
508                     "Delete system ~A.~%system file: ~A~%Are you sure?"
509                     system
510                     sysfile))
511            (mk:clean-system system)
512            (delete-file sysfile)
513            (dolist (f (mk:files-in-system system))
514              (delete-file f)))
515          ))
516      )))
517
518     
519;;; some day we will also do UPGRADE, but we need to sort out version
520;;; numbering a bit better first
521
522#+(and :asdf (or :win32 :mswindows))
523(defun sysdef-source-dir-search (system)
524  (let ((name (asdf::coerce-name system)))
525    (dolist (location *locations*)
526      (let* ((dir (first location))
527             (files (directory (merge-pathnames
528                                (make-pathname :name name
529                                               :type "asd"
530                                               :version :newest
531                                               :directory '(:relative :wild)
532                                               :host nil
533                                               :device nil)
534                                dir))))
535        (dolist (file files)
536          (when (probe-file file)
537            (return-from sysdef-source-dir-search file)))))))
538
539(defmethod asdf:find-component :around 
540    ((module (eql nil)) name &optional version)
541  (declare (ignore version))
542  (when (or (not *propagate-installation*) 
543            (member name *systems-installed-this-time* 
544                    :test (lambda (a b)
545                            (flet ((ensure-string (x)
546                                     (etypecase x
547                                       (symbol (symbol-name x))
548                                       (string x))))
549                              (string-equal (ensure-string a) (ensure-string b))))))
550    (call-next-method)))
551
552(defun show-version-information ()
553  (let ((version (asdf-install-version)))
554    (if version
555      (format *standard-output* "~&;;; ASDF-Install version ~A"
556              version)
557      (format *standard-output* "~&;;; ASDF-Install version unknown; unable to find ASDF system definition."))
558  (values)))
559
560(defun asdf-install-version ()
561  "Returns the ASDf-Install version information as a string or nil if it cannot be determined."
562  (let ((system (asdf:find-system 'asdf-install)))
563    (when system (asdf:component-version system))))
564
565;; load customizations if any
566(eval-when (:load-toplevel :execute)
567  (let* ((*package* (find-package :asdf-install-customize))
568         (file (probe-file (merge-pathnames
569                            (make-pathname :name ".asdf-install")
570                            (truename (user-homedir-pathname))))))
571    (when file (load file))))
572
573;;; end of file -- install.lisp --
Note: See TracBrowser for help on using the repository browser.