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