1 (in-package :asdf-install)
3 (defvar *proxy* (posix-getenv "http_proxy"))
5 (or (posix-getenv "CCLAN_MIRROR")
6 "http://ftp.linux.org.uk/pub/lisp/cclan/"))
8 (defun directorify (name)
9 ;; input name may or may not have a training #\/, but we know we
11 (let ((path (pathname name)))
12 (if (pathname-name path)
14 (make-pathname :directory `(:relative ,(pathname-name path))
19 (defvar *sbcl-home* (directorify (posix-getenv "SBCL_HOME")))
21 (merge-pathnames (make-pathname :directory '(:relative ".sbcl"))
22 (user-homedir-pathname)))
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/"))
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*
40 (lambda (x) (prefixp x url))
41 (cons *cclan-mirror* *safe-url-prefixes*)))
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")))
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)))
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)))))
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)))))
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)))
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)))
83 (defun url-connection (url)
84 (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp))
86 (port (url-port url)))
87 (declare (ignore port))
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*)
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)))
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))))))
110 (defun download-files-for-package (package-name-or-url file-name)
112 (if (= (mismatch package-name-or-url "http://") 7)
114 (format nil "http://www.cliki.net/~A?download"
115 package-name-or-url))))
116 (destructuring-bind (response headers stream)
119 (destructuring-bind (response headers stream) (url-connection url)
120 (unless (member response '(301 302))
121 (return-from got (list response headers 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)) "")
129 (format t "Downloading ~A bytes from ~A ..."
130 (if length length "some unknown number of") url)
132 (with-open-file (o file-name :direction :output)
134 (let ((buf (make-array length
136 (stream-element-type stream) )))
137 (read-sequence buf stream)
138 (write-sequence buf o))
139 (sb-executable:copy-stream stream o))))
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)))))
146 (defun verify-gpg-signature (url file-name)
147 (destructuring-bind (response headers stream)
148 (url-connection (concatenate 'string url ".asc"))
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
155 (let ((data (make-string (parse-integer
156 (cdr (assoc :content-length headers))
158 (read-sequence data stream)
161 (sb-ext:run-program "gpg"
163 (namestring file-name))
166 :input (make-string-input-stream data)
169 (error 'signature-error
170 :cause (make-condition
172 :format-control "GPG returned exit status ~A"
173 :format-arguments (list ret))))))
174 (error 'signature-error
177 'download-error :url (concatenate 'string url ".asc")
178 :response response)))
185 (format t "Install where?~%")
186 (loop for (source system name) in *locations*
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)))
193 (elt *locations* (1- response)))))
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 )
200 (with-output-to-string (o)
202 (sb-ext:run-program "tar"
203 (list "-C" (namestring source)
204 "-xzvf" (namestring packagename))
208 (error "can't untar"))))
210 (pos-slash (position #\/ tar))
211 (*default-pathname-defaults*
213 (make-pathname :directory
214 `(:relative ,(subseq tar 0 pos-slash)))
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))
223 (when (probe-file target)
224 (sb-posix:unlink target))
225 (sb-posix:symlink asd target))
226 collect (pathname-name asd))))
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))))
234 :name (subseq p (if pos-slash (1+ pos-slash) 0) pos-dot)
235 :type "asdf-install-tmp"))))
238 ;; this is the external entry point
239 (defun install (&rest packages)
240 (let ((*temporary-files* nil))
242 (destructuring-bind (source system name) (where)
243 (labels ((one-iter (packages)
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)
252 do (format t "Installing ~A in ~A,~A~%"
254 append (install-package source system p)))
256 ((asdf:missing-dependency
259 "Downloading package ~A, required by ~A~%"
260 (asdf::missing-requires c)
262 (asdf::missing-required-by c)))
265 (asdf::missing-requires c))))
266 (invoke-restart 'retry))))
268 (multiple-value-bind (ret restart-p)
270 (retry "Retry installation")
271 (asdf:operate 'asdf:load-op asd))
272 (unless restart-p (return))))))))
273 (one-iter packages)))
274 (dolist (l *temporary-files*)
275 (when (probe-file l) (delete-file l))))))