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     (socket-connect
  88      s (car (host-ent-addresses (get-host-by-name (url-host (or *proxy* url)))))
  89      (url-port (or  *proxy* url)))
  90     (let ((stream (socket-make-stream s :input t :output t :buffering :full)))
  91       ;; we are exceedingly unportable about proper line-endings here.
  92       ;; Anyone wishing to run this under non-SBCL should take especial care
  93       (format stream "GET ~A HTTP/1.0~%Host: ~A~%Cookie: CCLAN-SITE=~A~%~%"
  94               url host *cclan-mirror*)
  95       (force-output stream)
  96       (list
  97        (let* ((l (read-line stream))
  98               (space (position #\Space l)))
  99          (parse-integer l :start (1+ space) :junk-allowed t))
 100        (loop for line = (read-line stream nil nil)
 101              until (or (null line) (eql (elt line 0) (code-char 13)))
 102              collect
 103              (let ((colon (position #\: line)))
 104                (cons (intern (string-upcase (subseq line 0 colon)) :keyword)
 105                      (string-trim (list #\Space (code-char 13))
 106                                   (subseq line (1+ colon))))))
 107        stream))))
 108
 109 (defun download-files-for-package (package-name-or-url file-name)
 110   (let ((url
 111          (if (= (mismatch package-name-or-url "http://") 7)
 112              package-name-or-url
 113              (format nil "http://www.cliki.net/~A?download"
 114                      package-name-or-url))))
 115     (destructuring-bind (response headers stream)
 116         (block got
 117           (loop
 118            (destructuring-bind (response headers stream) (url-connection url)
 119              (unless (member response '(301 302))
 120                (return-from got (list response headers stream)))
 121              (close stream)
 122              (setf url (cdr (assoc :location headers))))))
 123       (if (>= response 400)
 124         (error 'download-error :url url :response response))
 125       (let ((length (parse-integer
 126                      (or (cdr (assoc :content-length headers)) "")
 127                      :junk-allowed t)))
 128         (format t "Downloading ~A bytes from ~A ..."
 129                 (if length length "some unknown number of") url)
 130         (force-output)
 131         (with-open-file (o file-name :direction :output)
 132           (if length
 133               (let ((buf (make-array length
 134                                      :element-type
 135                                      (stream-element-type stream)  )))
 136                 (read-sequence buf stream)
 137                 (write-sequence buf o))
 138               (sb-executable:copy-stream stream o))))
 139       (close stream)
 140       (terpri)
 141       ;; seems to have worked.  let's try for a detached gpg signature too
 142       (when (verify-gpg-signatures-p url)
 143         (verify-gpg-signature url file-name)))))
 144
 145 (defun verify-gpg-signature (url file-name)
 146   (destructuring-bind (response headers stream)
 147       (url-connection (concatenate 'string url ".asc"))
 148     (unwind-protect
 149          (if (= response 200)
 150              ;; sadly, we can't pass the stream directly to run-program,
 151              ;; because (at least in sbcl 0.8) that ignores existing buffered
 152              ;; data and only reads new fresh data direct from the file
 153              ;; descriptor
 154              (let ((data (make-string (parse-integer
 155                                        (cdr (assoc :content-length headers))
 156                                        :junk-allowed t))))
 157                (read-sequence data stream)
 158                (let ((ret
 159                       (process-exit-code
 160                        (sb-ext:run-program "gpg"
 161                                            (list "--verify" "-"
 162                                                  (namestring file-name))
 163                                            :output t
 164                                            :search t
 165                                            :input (make-string-input-stream data)
 166                                            :wait t))))
 167                  (unless (zerop ret)
 168                    (error 'signature-error
 169                           :cause (make-condition
 170                                   'simple-error
 171                                   :format-control "GPG returned exit status ~A"
 172                                   :format-arguments (list ret))))))
 173              (error 'signature-error
 174                     :cause
 175                     (make-condition
 176                      'download-error :url  (concatenate 'string url ".asc")
 177                      :response response)))
 178       (close stream))))
 179
 180
 181
 182
 183 (defun where ()
 184   (format t "Install where?~%")
 185   (loop for (source system name) in *locations*
 186         for i from 1
 187         do (format t "~A) ~A: ~%   System in ~A~%   Files in ~A ~%"
 188                    i name system source))
 189   (format t " --> ") (force-output)
 190   (let ((response (read)))
 191     (when (> response 0)
 192       (elt *locations* (1- response)))))
 193
 194 (defun install-package (source system packagename)
 195   "Returns a list of asdf system names for installed asdf systems"
 196   (ensure-directories-exist source )
 197     (ensure-directories-exist system )
 198   (let* ((tar
 199           (with-output-to-string (o)
 200             (or
 201              (sb-ext:run-program "tar"
 202                                  (list "-C" (namestring source)
 203                                        "-xzvf" (namestring packagename))
 204                                  :output o
 205                                  :search t
 206                                  :wait t)
 207              (error "can't untar"))))
 208          (dummy (princ tar))
 209          (pos-slash (position #\/ tar))
 210          (*default-pathname-defaults*
 211           (merge-pathnames
 212            (make-pathname :directory
 213                           `(:relative ,(subseq tar 0 pos-slash)))
 214            source)))
 215     (loop for asd in (directory
 216                       (make-pathname :name :wild :type "asd"))
 217           do (let ((target (merge-pathnames
 218                             (make-pathname :name (pathname-name asd)
 219                                            :type (pathname-type asd))
 220                             system)))
 221                (when (probe-file target)
 222                  (sb-posix:unlink target))
 223                (sb-posix:symlink asd target))
 224           collect (pathname-name asd))))
 225
 226 (defvar *temporary-files*)
 227 (defun temp-file-name (p)
 228   (let* ((pos-slash (position #\/ p :from-end t))
 229          (pos-dot (position #\. p :start (or pos-slash 0))))
 230     (merge-pathnames
 231      (make-pathname
 232       :name (subseq p (if pos-slash (1+ pos-slash) 0) pos-dot)
 233       :type "asdf-install-tmp"))))
 234
 235
 236 ;; this is the external entry point
 237 (defun install (&rest packages)
 238   (let ((*temporary-files* nil))
 239     (unwind-protect
 240          (destructuring-bind (source system name) (where)
 241            (labels ((one-iter (packages)
 242                       (dolist (asd
 243                                 (loop for p in (mapcar 'string packages)
 244                                       unless (probe-file p)
 245                                       do (let ((tmp (temp-file-name p)))
 246                                            (pushnew tmp *temporary-files*)
 247                                            (download-files-for-package p tmp)
 248                                            (setf p tmp))
 249                                       end
 250                                       do (format t "Installing ~A in ~A,~A~%"
 251                                                  p source system)
 252                                       append (install-package source system p)))
 253                         (handler-case
 254                             (asdf:operate 'asdf:load-op asd)
 255                           (asdf:missing-dependency (c)
 256                             (format t
 257                                     "Downloading package ~A, required by ~A~%"
 258                                     (asdf::missing-requires c)
 259                                     (asdf:component-name
 260                                      (asdf::missing-required-by c)))
 261                             (one-iter (list
 262                                        (symbol-name
 263                                         (asdf::missing-requires c)))))))))
 264              (one-iter packages)))
 265       (dolist (l *temporary-files*)
 266             (when (probe-file l) (delete-file l))))))