contrib/asdf-install/installer.lisp

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