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                         :name "")
  16          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 (defvar *verify-gpg-signatures* :unknown-locations
  25   "Should we get detached GPG signatures for the packages and verify them?
  26 NIL - no, T - yes, :UNKNOWN-LOCATIONS - for any URL which isn't in CCLAN
  27 and doesn't begin with one of the prefixes in *SAFE-URL-PREFIXES*")
  28 (defvar *safe-url-prefixes*
  29   (list "http://ftp.linux.org.uk/pub/lisp/"
  30         "http://files.b9.com/"))
  31
  32 (defun verify-gpg-signatures-p (url)
  33   (labels ((prefixp (prefix string)
  34              (let ((m (mismatch prefix string)))
  35                (or (not m) (>= m (length prefix))))))
  36     (case *verify-gpg-signatures*
  37       (nil nil)
  38       (:unknown-locations
  39        (notany
  40         (lambda (x) (prefixp x url))
  41         (cons *cclan-mirror* *safe-url-prefixes*)))
  42       (t t))))
  43
  44 (defvar *locations*
  45   `((,(merge-pathnames "site/" *sbcl-home*)
  46      ,(merge-pathnames "site-systems/" *sbcl-home*)
  47      "System-wide install")
  48     (,(merge-pathnames "site/" *dot-sbcl*)
  49      ,(merge-pathnames "systems/" *dot-sbcl*)
  50      "Personal installation")))
  51
  52 (let* ((*package* (find-package :asdf-install-customize))
  53        (file (probe-file (merge-pathnames
  54                           (make-pathname :name ".asdf-install")
  55                           (user-homedir-pathname)))))
  56   (when file (load file)))
  57
  58 (define-condition download-error (error)
  59   ((url :initarg :url :reader download-url)
  60    (response :initarg :response :reader download-response))
  61   (:report (lambda (c s)
  62              (format s "Server responded ~A for GET ~A"
  63                      (download-response c) (download-url c)))))
  64
  65 (define-condition signature-error (error)
  66   ((cause :initarg :cause :reader signature-error-cause))
  67   (:report (lambda (c s)
  68              (format s "Cannot verify package signature:  ~A"
  69                      (signature-error-cause c)))))
  70
  71 (defun url-host (url)
  72   (assert (string-equal url "http://" :end1 7))
  73   (let* ((port-start (position #\: url :start 7))
  74          (host-end (min (or (position #\/ url :start 7) (length url))
  75                         (or port-start (length url)))))
  76     (subseq url 7 host-end)))
  77
  78 (defun url-port (url)
  79   (assert (string-equal url "http://" :end1 7))
  80   (let ((port-start (position #\: url :start 7)))
  81     (if port-start (parse-integer url :start port-start :junk-allowed t) 80)))
  82
  83 (defun url-connection (url)
  84   (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp))
  85         (host (url-host url))
  86         (port (url-port url)))
  87     (declare (ignore port))
  88     (socket-connect
  89      s (car (host-ent-addresses (get-host-by-name (url-host (or *proxy* url)))))
  90      (url-port (or  *proxy* url)))
  91     (let ((stream (socket-make-stream s :input t :output t :buffering :full)))
  92       ;; we are exceedingly unportable about proper line-endings here.
  93       ;; Anyone wishing to run this under non-SBCL should take especial care
  94       (format stream "GET ~A HTTP/1.0~%Host: ~A~%Cookie: CCLAN-SITE=~A~%~%"
  95               url host *cclan-mirror*)
  96       (force-output stream)
  97       (list
  98        (let* ((l (read-line stream))
  99               (space (position #\Space l)))
 100          (parse-integer l :start (1+ space) :junk-allowed t))
 101        (loop for line = (read-line stream nil nil)
 102              until (or (null line) (eql (elt line 0) (code-char 13)))
 103              collect
 104              (let ((colon (position #\: line)))
 105                (cons (intern (string-upcase (subseq line 0 colon)) :keyword)
 106                      (string-trim (list #\Space (code-char 13))
 107                                   (subseq line (1+ colon))))))
 108        stream))))
 109
 110 (defun download-files-for-package (package-name-or-url file-name)
 111   (let ((url
 112          (if (= (mismatch package-name-or-url "http://") 7)
 113              package-name-or-url
 114              (format nil "http://www.cliki.net/~A?download"
 115                      package-name-or-url))))
 116     (destructuring-bind (response headers stream)
 117         (block got
 118           (loop
 119            (destructuring-bind (response headers stream) (url-connection url)
 120              (unless (member response '(301 302))
 121                (return-from got (list response headers stream)))
 122              (close stream)
 123              (setf url (cdr (assoc :location headers))))))
 124       (if (>= response 400)
 125         (error 'download-error :url url :response response))
 126       (let ((length (parse-integer
 127                      (or (cdr (assoc :content-length headers)) "")
 128                      :junk-allowed t)))
 129         (format t "Downloading ~A bytes from ~A ..."
 130                 (if length length "some unknown number of") url)
 131         (force-output)
 132         (with-open-file (o file-name :direction :output)
 133           (if length
 134               (let ((buf (make-array length
 135                                      :element-type
 136                                      (stream-element-type stream)  )))
 137                 (read-sequence buf stream)
 138                 (write-sequence buf o))
 139               (sb-executable:copy-stream stream o))))
 140       (close stream)
 141       (terpri)
 142       ;; seems to have worked.  let's try for a detached gpg signature too
 143       (when (verify-gpg-signatures-p url)
 144         (verify-gpg-signature url file-name)))))
 145
 146 (defun verify-gpg-signature (url file-name)
 147   (destructuring-bind (response headers stream)
 148       (url-connection (concatenate 'string url ".asc"))
 149     (unwind-protect
 150          (if (= response 200)
 151              ;; sadly, we can't pass the stream directly to run-program,
 152              ;; because (at least in sbcl 0.8) that ignores existing buffered
 153              ;; data and only reads new fresh data direct from the file
 154              ;; descriptor
 155              (let ((data (make-string (parse-integer
 156                                        (cdr (assoc :content-length headers))
 157                                        :junk-allowed t))))
 158                (read-sequence data stream)
 159                (let ((ret
 160                       (process-exit-code
 161                        (sb-ext:run-program "gpg"
 162                                            (list "--verify" "-"
 163                                                  (namestring file-name))
 164                                            :output t
 165                                            :search t
 166                                            :input (make-string-input-stream data)
 167                                            :wait t))))
 168                  (unless (zerop ret)
 169                    (error 'signature-error
 170                           :cause (make-condition
 171                                   'simple-error
 172                                   :format-control "GPG returned exit status ~A"
 173                                   :format-arguments (list ret))))))
 174              (error 'signature-error
 175                     :cause
 176                     (make-condition
 177                      'download-error :url  (concatenate 'string url ".asc")
 178                      :response response)))
 179       (close stream))))
 180
 181
 182
 183
 184 (defun where ()
 185   (format t "Install where?~%")
 186   (loop for (source system name) in *locations*
 187         for i from 1
 188         do (format t "~A) ~A: ~%   System in ~A~%   Files in ~A ~%"
 189                    i name system source))
 190   (format t " --> ") (force-output)
 191   (let ((response (read)))
 192     (when (> response 0)
 193       (elt *locations* (1- response)))))
 194
 195 (defun install-package (source system packagename)
 196   "Returns a list of asdf system names for installed asdf systems"
 197   (ensure-directories-exist source )
 198     (ensure-directories-exist system )
 199   (let* ((tar
 200           (with-output-to-string (o)
 201             (or
 202              (sb-ext:run-program "tar"
 203                                  (list "-C" (namestring source)
 204                                        "-xzvf" (namestring packagename))
 205                                  :output o
 206                                  :search t
 207                                  :wait t)
 208              (error "can't untar"))))
 209          (dummy (princ tar))
 210          (pos-slash (position #\/ tar))
 211          (*default-pathname-defaults*
 212           (merge-pathnames
 213            (make-pathname :directory
 214                           `(:relative ,(subseq tar 0 pos-slash)))
 215            source)))
 216     (declare (ignore dummy))
 217     (loop for asd in (directory
 218                       (make-pathname :name :wild :type "asd"))
 219           do (let ((target (merge-pathnames
 220                             (make-pathname :name (pathname-name asd)
 221                                            :type (pathname-type asd))
 222                             system)))
 223                (when (probe-file target)
 224                  (sb-posix:unlink target))
 225                (sb-posix:symlink asd target))
 226           collect (pathname-name asd))))
 227
 228 (defvar *temporary-files*)
 229 (defun temp-file-name (p)
 230   (let* ((pos-slash (position #\/ p :from-end t))
 231          (pos-dot (position #\. p :start (or pos-slash 0))))
 232     (merge-pathnames
 233      (make-pathname
 234       :name (subseq p (if pos-slash (1+ pos-slash) 0) pos-dot)
 235       :type "asdf-install-tmp"))))
 236
 237
 238 ;; this is the external entry point
 239 (defun install (&rest packages)
 240   (let ((*temporary-files* nil))
 241     (unwind-protect
 242          (destructuring-bind (source system name) (where)
 243            (labels ((one-iter (packages)
 244                       (dolist (asd
 245                                 (loop for p in (mapcar 'string packages)
 246                                       unless (probe-file p)
 247                                       do (let ((tmp (temp-file-name p)))
 248                                            (pushnew tmp *temporary-files*)
 249                                            (download-files-for-package p tmp)
 250                                            (setf p tmp))
 251                                       end
 252                                       do (format t "Installing ~A in ~A,~A~%"
 253                                                  p source system)
 254                                       append (install-package source system p)))
 255                         (handler-case
 256                             (asdf:operate 'asdf:load-op asd)
 257                           (asdf:missing-dependency (c)
 258                             (format t
 259                                     "Downloading package ~A, required by ~A~%"
 260                                     (asdf::missing-requires c)
 261                                     (asdf:component-name
 262                                      (asdf::missing-required-by c)))
 263                             (one-iter (list
 264                                        (symbol-name
 265                                         (asdf::missing-requires c)))))))))
 266              (one-iter packages)))
 267       (dolist (l *temporary-files*)
 268             (when (probe-file l) (delete-file l))))))