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

Last change on this file since 13689 was 13689, checked in by rme, 9 years ago

Tweak for asdf 2 compatibility.

  • 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-output (extract source packagename))
322         (tar (if (string= tar-output "x " :end1 2)
323                (subseq tar-output 2)
324                tar-output))
325         (pos-slash (or (position #\/ tar)
326                        (position #\Return tar)
327                        (position #\Linefeed tar)))
328         (*default-pathname-defaults*
329          (merge-pathnames
330           (make-pathname :directory
331                          `(:relative ,(subseq tar 0 pos-slash)))
332           source)))
333    ;(princ tar)
334    (loop for sysfile in (append
335                          (directory
336                           (make-pathname :defaults *default-pathname-defaults*
337                                          :name :wild
338                                          :type "asd"))
339                          (directory
340                           (make-pathname :defaults *default-pathname-defaults*
341                                          :name :wild
342                                          :type "system")))
343       do (maybe-symlink-sysfile system sysfile)
344       do (installer-msg t "Found system definition: ~A" sysfile)
345       do (maybe-update-central-registry sysfile)
346       collect sysfile)))
347
348(defun maybe-update-central-registry (sysfile)
349  ;; make sure that the systems we install are accessible in case
350  ;; asdf-install:*locations* and asdf:*central-registry* are out
351  ;; of sync
352  (add-registry-location sysfile))
353
354(defun temp-file-name (p)
355  (declare (ignore p))
356  (let ((pathname nil))
357    (loop for i = 0 then (1+ i) do
358         (setf pathname 
359               (merge-pathnames
360                (make-pathname
361                 :name (format nil "asdf-install-~d" i)
362                 :type "asdf-install-tmp")
363                *temporary-directory*))
364         (unless (probe-file pathname)
365           (return-from temp-file-name pathname)))))
366
367
368;;; install
369;;; This is the external entry point.
370
371(defun install (packages &key (propagate nil) (where *preferred-location*))
372  (let* ((*preferred-location* where)
373         (*temporary-files* nil)
374         (trusted-uid-file 
375          (merge-pathnames "trusted-uids.lisp" *private-asdf-install-dirs*))
376         (*trusted-uids*
377          (when (probe-file trusted-uid-file)
378            (with-open-file (f trusted-uid-file) (read f))))
379         (old-uids (copy-list *trusted-uids*))
380         #+asdf
381         (*defined-systems* (if propagate 
382                              (make-hash-table :test 'equal)
383                              *defined-systems*))
384         (packages (if (atom packages) (list packages) packages))
385         (*propagate-installation* propagate)
386         (*systems-installed-this-time* nil))
387    (unwind-protect
388      (destructuring-bind (source system name) (install-location)
389        (declare (ignore name))
390        (labels 
391            ((one-iter (packages)
392               (let ((packages-to-install nil))
393                 (loop for p in (mapcar #'string packages) do
394                      (cond ((local-archive-p p)
395                             (setf packages-to-install
396                                   (append packages-to-install 
397                                           (install-package source system p))))
398                            (t
399                             (multiple-value-bind (package signature)
400                                 (download-files-for-package p)
401                               (when (verify-gpg-signatures-p p)
402                                 (verify-gpg-signature package signature))
403                               (installer-msg t "Installing ~A in ~A, ~A"
404                                              p source system)
405                               (install-package source system package))
406                             (setf packages-to-install
407                                   (append packages-to-install 
408                                           (list p))))))
409                 (dolist (package packages-to-install)
410                   (setf package
411                         (etypecase package
412                           (symbol package)
413                           (string (intern package :asdf-install))
414                           (pathname (intern
415                                      (namestring (pathname-name package))
416                                      :asdf-install))))
417                   (handler-bind
418                       (
419                        #+asdf
420                        (asdf:missing-dependency
421                         (lambda (c) 
422                           (installer-msg
423                            t
424                            "Downloading package ~A, required by ~A~%"
425                            (asdf::missing-requires c)
426                            (asdf:component-name
427                             (asdf::missing-required-by c)))
428                           (one-iter 
429                            (list (asdf::coerce-name 
430                                   (asdf::missing-requires c))))
431                           (invoke-restart 'retry)))
432                        #+mk-defsystem
433                        (make:missing-component
434                         (lambda (c) 
435                           (installer-msg 
436                            t
437                            "Downloading package ~A, required by ~A~%"
438                            (make:missing-component-name c)
439                            package)
440                           (one-iter (list (make:missing-component-name c)))
441                           (invoke-restart 'retry))))
442                     (loop (multiple-value-bind (ret restart-p)
443                               (with-simple-restart
444                                   (retry "Retry installation")
445                                 (push package *systems-installed-this-time*)
446                                 (load-package package))
447                             (declare (ignore ret))
448                             (unless restart-p (return)))))))))
449          (one-iter packages)))
450      ;;; cleanup
451      (unless (equal old-uids *trusted-uids*)
452        (let ((create-file-p nil))
453          (unless (probe-file trusted-uid-file)
454            (installer-msg t "Trusted UID file ~A does not exist"
455                           (namestring trusted-uid-file))
456            (setf create-file-p
457                  (y-or-n-p "Do you want to create the file?")))
458          (when (or create-file-p (probe-file trusted-uid-file))
459            (ensure-directories-exist trusted-uid-file)
460            (with-open-file (out trusted-uid-file
461                                 :direction :output
462                                 :if-exists :supersede)
463              (with-standard-io-syntax
464                (prin1 *trusted-uids* out))))))
465      (dolist (l *temporary-files* t)
466        (when (probe-file l) (delete-file l))))
467    (nreverse *systems-installed-this-time*)))
468
469(defun local-archive-p (package)
470  #+(or :sbcl :allegro) (probe-file package)
471  #-(or :sbcl :allegro) (and (/= (mismatch package "http://") 7)
472                           (probe-file package)))
473
474(defun load-package (package)
475  #+asdf
476  (progn
477    (installer-msg t "Loading system ~S via ASDF." package)
478    (asdf:operate 'asdf:load-op package))
479  #+mk-defsystem
480  (progn
481    (installer-msg t "Loading system ~S via MK:DEFSYSTEM." package)
482    (mk:load-system package)))
483
484;;; uninstall --
485
486(defun uninstall (system &optional (prompt t))
487  #+asdf
488  (let* ((asd (asdf:system-definition-pathname system))
489         (system (asdf:find-system system))
490         (dir (pathname-sans-name+type
491               (asdf::resolve-symlinks asd))))
492    (when (or (not prompt)
493              (y-or-n-p
494               "Delete system ~A~%asd file: ~A~%sources: ~A~%Are you sure?"
495               system asd dir))
496      #-(or :win32 :mswindows)
497      (delete-file asd)
498      (let ((dir (#-scl system-namestring #+scl ext:unix-namestring (truename dir))))
499        (when dir
500          (asdf:run-shell-command "rm -r '~A'" dir)))))
501
502  #+mk-defsystem
503  (multiple-value-bind (sysfile sysfile-exists-p)
504      (mk:system-definition-pathname system)
505    (when sysfile-exists-p
506      (let ((system (ignore-errors (mk:find-system system :error))))
507        (when system
508          (when (or (not prompt)
509                    (y-or-n-p
510                     "Delete system ~A.~%system file: ~A~%Are you sure?"
511                     system
512                     sysfile))
513            (mk:clean-system system)
514            (delete-file sysfile)
515            (dolist (f (mk:files-in-system system))
516              (delete-file f)))
517          ))
518      )))
519
520     
521;;; some day we will also do UPGRADE, but we need to sort out version
522;;; numbering a bit better first
523
524#+(and :asdf (or :win32 :mswindows))
525(defun sysdef-source-dir-search (system)
526  (let ((name (asdf::coerce-name system)))
527    (dolist (location *locations*)
528      (let* ((dir (first location))
529             (files (directory (merge-pathnames
530                                (make-pathname :name name
531                                               :type "asd"
532                                               :version :newest
533                                               :directory '(:relative :wild)
534                                               :host nil
535                                               :device nil)
536                                dir))))
537        (dolist (file files)
538          (when (probe-file file)
539            (return-from sysdef-source-dir-search file)))))))
540
541(defmethod asdf:find-component :around 
542    ((module (eql nil)) name)
543  (when (or (not *propagate-installation*) 
544            (member name *systems-installed-this-time* 
545                    :test (lambda (a b)
546                            (flet ((ensure-string (x)
547                                     (etypecase x
548                                       (symbol (symbol-name x))
549                                       (string x))))
550                              (string-equal (ensure-string a) (ensure-string b))))))
551    (call-next-method)))
552
553(defun show-version-information ()
554  (let ((version (asdf-install-version)))
555    (if version
556      (format *standard-output* "~&;;; ASDF-Install version ~A"
557              version)
558      (format *standard-output* "~&;;; ASDF-Install version unknown; unable to find ASDF system definition."))
559  (values)))
560
561(defun asdf-install-version ()
562  "Returns the ASDf-Install version information as a string or nil if it cannot be determined."
563  (let ((system (asdf:find-system 'asdf-install)))
564    (when system (asdf:component-version system))))
565
566;; load customizations if any
567(eval-when (:load-toplevel :execute)
568  (let* ((*package* (find-package :asdf-install-customize))
569         (file (probe-file (merge-pathnames
570                            (make-pathname :name ".asdf-install")
571                            (truename (user-homedir-pathname))))))
572    (when file (load file))))
573
574;;; end of file -- install.lisp --
Note: See TracBrowser for help on using the repository browser.