1 (in-package :asdf-install
)
3 (defvar *proxy
* (posix-getenv "http_proxy"))
5 (let ((mirror (posix-getenv "CCLAN_MIRROR")))
6 (or (and (not (string= mirror
"")) mirror
)
7 "http://ftp.linux.org.uk/pub/lisp/cclan/")))
9 (defun directorify (name)
10 ;; input name may or may not have a training #\/, but we know we
12 (let ((path (pathname name
)))
13 (if (pathname-name path
)
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
)))
21 (defvar *sbcl-home
* (directorify (posix-getenv "SBCL_HOME")))
23 (merge-pathnames (make-pathname :directory
'(:relative
".sbcl"))
24 (user-homedir-pathname)))
26 (defparameter *trusted-uids
* nil
)
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")))
36 (unless (sb-ext:posix-getenv
"SBCL_BUILDING_CONTRIB")
37 ;; Not during build, thanks.
38 (let* ((*package
* (find-package :asdf-install-customize
))
39 (file (probe-file (merge-pathnames
40 (make-pathname :name
".asdf-install")
41 (user-homedir-pathname)))))
42 (when file
(load file
))))
44 (define-condition download-error
(error)
45 ((url :initarg
:url
:reader download-url
)
46 (response :initarg
:response
:reader download-response
))
47 (:report
(lambda (c s
)
48 (format s
"Server responded ~A for GET ~A"
49 (download-response c
) (download-url c
)))))
51 (define-condition signature-error
(error)
52 ((cause :initarg
:cause
:reader signature-error-cause
))
53 (:report
(lambda (c s
)
54 (format s
"Cannot verify package signature: ~A"
55 (signature-error-cause c
)))))
57 (define-condition gpg-error
(error)
58 ((message :initarg
:message
:reader gpg-error-message
))
59 (:report
(lambda (c s
)
60 (format s
"GPG failed with error status:~%~S"
61 (gpg-error-message c
)))))
63 (define-condition no-signature
(gpg-error) ())
64 (define-condition key-not-found
(gpg-error)
65 ((key-id :initarg
:key-id
:reader key-id
))
66 (:report
(lambda (c s
)
67 (format s
"No key found for key id 0x~A. Try some command like ~% gpg --recv-keys 0x~A"
68 (key-id c
) (key-id c
)))))
70 (define-condition key-not-trusted
(gpg-error)
71 ((key-id :initarg
:key-id
:reader key-id
)
72 (key-user-name :initarg
:key-user-name
:reader key-user-name
))
73 (:report
(lambda (c s
)
74 (format s
"GPG warns that the key id 0x~A (~A) is not fully trusted"
75 (key-id c
) (key-user-name c
)))))
76 (define-condition author-not-trusted
(gpg-error)
77 ((key-id :initarg
:key-id
:reader key-id
)
78 (key-user-name :initarg
:key-user-name
:reader key-user-name
))
79 (:report
(lambda (c s
)
80 (format s
"~A (key id ~A) is not on your package supplier list"
81 (key-user-name c
) (key-id c
)))))
84 (assert (string-equal url
"http://" :end1
7))
85 (let* ((port-start (position #\
: url
:start
7))
86 (host-end (min (or (position #\
/ url
:start
7) (length url
))
87 (or port-start
(length url
)))))
88 (subseq url
7 host-end
)))
91 (assert (string-equal url
"http://" :end1
7))
92 (let ((port-start (position #\
: url
:start
7)))
93 (if port-start
(parse-integer url
:start
(1+ port-start
) :junk-allowed t
) 80)))
95 (defun request-uri (url)
96 (assert (string-equal url
"http://" :end1
7))
99 (let ((path-start (position #\
/ url
:start
7)))
100 (subseq url path-start
))))
102 (defun url-connection (url)
103 (let ((s (make-instance 'inet-socket
:type
:stream
:protocol
:tcp
))
104 (host (url-host url
))
105 (port (url-port url
))
107 (declare (ignore port
))
111 s
(car (host-ent-addresses (get-host-by-name (url-host (or *proxy
* url
)))))
112 (url-port (or *proxy
* url
)))
113 (let ((stream (socket-make-stream s
:input t
:output t
:buffering
:full
114 :element-type
:default
:external-format
:iso-8859-1
)))
115 ;; we are exceedingly unportable about proper line-endings here.
116 ;; Anyone wishing to run this under non-SBCL should take especial care
117 (format stream
"GET ~A HTTP/1.0~c~%~
119 Cookie: CCLAN-SITE=~A~c~%~c~%"
120 (request-uri url
) #\Return
122 *cclan-mirror
* #\Return
#\Return
)
123 (force-output stream
)
126 (let* ((l (read-line stream
))
127 (space (position #\Space l
)))
128 (parse-integer l
:start
(1+ space
) :junk-allowed t
))
129 (loop for line
= (read-line stream nil nil
)
130 until
(or (null line
) (eql (elt line
0) (code-char 13)))
132 (let ((colon (position #\
: line
)))
133 (cons (intern (string-upcase (subseq line
0 colon
)) :keyword
)
134 (string-trim (list #\Space
(code-char 13))
135 (subseq line
(1+ colon
))))))
137 (when (and (null result
)
142 (defun copy-stream (in out
)
143 (let ((buf (make-array 8192 :element-type
(stream-element-type out
))))
144 (loop for pos
= (read-sequence buf in
)
146 do
(write-sequence buf out
:end pos
))))
148 (defun download-files-for-package (package-name-or-url file-name
)
150 (if (= (mismatch package-name-or-url
"http://") 7)
152 (format nil
"http://www.cliki.net/~A?download"
153 package-name-or-url
))))
154 (destructuring-bind (response headers stream
)
157 (destructuring-bind (response headers stream
) (url-connection url
)
158 (unless (member response
'(301 302))
159 (return-from got
(list response headers stream
)))
161 (setf url
(cdr (assoc :location headers
))))))
162 (if (>= response
400)
163 (error 'download-error
:url url
:response response
))
164 (let ((length (parse-integer
165 (or (cdr (assoc :content-length headers
)) "")
167 (format t
"Downloading ~A bytes from ~A ..."
168 (if length length
"some unknown number of") url
)
170 (with-open-file (out file-name
:direction
:output
171 :element-type
'(unsigned-byte 8))
173 (let ((buf (make-array length
:element-type
'(unsigned-byte 8))))
174 (read-sequence buf stream
)
175 (write-sequence buf out
))
176 (copy-stream stream out
))))
180 (verify-gpg-signature/url url file-name
)
182 :report
"Don't check GPG signature for this package"
185 (defun read-until-eof (stream)
186 (with-output-to-string (o)
187 (copy-stream stream o
)))
189 (defun verify-gpg-signature/string
(string file-name
)
194 "--status-fd" "1" "--verify" "-"
195 (namestring file-name
))
196 :output
:stream
:error
:stream
:search t
197 :input
(make-string-input-stream string
) :wait t
))
198 (err (read-until-eof (process-error proc
)))
200 (loop for l
= (read-line (process-output proc
) nil nil
)
202 when
(> (mismatch l
"[GNUPG:]") 6)
203 do
(destructuring-bind (_ tag
&rest data
) (asdf::split-string l
)
205 (pushnew (cons (intern tag
:keyword
)
207 ;; test for obvious key/sig problems
208 (let ((errsig (assoc :errsig tags
)))
209 (and errsig
(error 'key-not-found
:key-id
(second errsig
) :gpg-err err
)))
210 (let ((badsig (assoc :badsig tags
)))
211 (and badsig
(error 'key-not-found
:key-id
(second badsig
) :gpg-err err
)))
212 (let* ((good (assoc :goodsig tags
))
214 (name (format nil
"~{~A~^ ~}" (nthcdr 2 good
))))
215 ;; good signature, but perhaps not trusted
216 (unless (or (assoc :trust_ultimate tags
)
217 (assoc :trust_fully tags
))
218 (cerror "Install the package anyway"
221 :key-id id
:gpg-err err
))
225 (or (assoc id
*trusted-uids
* :test
#'equal
)
226 (error 'author-not-trusted
228 :key-id id
:gpg-err nil
))
230 :report
"Add to package supplier list"
231 (pushnew (list id name
) *trusted-uids
*)))
236 (defun verify-gpg-signature/url
(url file-name
)
237 (destructuring-bind (response headers stream
)
238 (url-connection (concatenate 'string url
".asc"))
241 (let ((data (make-string (parse-integer
242 (cdr (assoc :content-length headers
))
244 (read-sequence data stream
)
245 (verify-gpg-signature/string data file-name
))
246 (error 'download-error
:url
(concatenate 'string url
".asc")
251 (format t
"Install where?~%")
252 (loop for
(source system name
) in
*locations
*
254 do
(format t
"~A) ~A: ~% System in ~A~% Files in ~A ~%"
255 i name system source
))
256 (format t
" --> ") (force-output)
257 (let ((response (read)))
259 (elt *locations
* (1- response
)))))
261 (defparameter *tar-program
*
262 ;; Please do not "clean this up" by using a bunch of #+'s and one
263 ;; #-. When the conditional is written this way, adding a new
264 ;; special case only involves one change. If #- is used, two changes
265 ;; are needed. -- JES, 2007-02-12
269 #+(or sunos netbsd
) "gtar"))
271 (defun get-tar-directory (packagename)
272 (let* ((tar (with-output-to-string (o)
274 (sb-ext:run-program
*tar-program
*
275 (list "-tzf" (namestring packagename
))
279 (error "can't list archive"))))
280 (first-line (subseq tar
0 (position #\newline tar
))))
281 (if (find #\
/ first-line
)
282 (subseq first-line
0 (position #\
/ first-line
))
285 (defun untar-package (source packagename
)
286 (with-output-to-string (o)
288 (sb-ext:run-program
*tar-program
*
289 (list "-C" (namestring source
)
290 "-xzvf" (namestring packagename
))
294 (error "can't untar"))))
296 (defun install-package (source system packagename
)
297 "Returns a list of asdf system names for installed asdf systems"
298 (ensure-directories-exist source
)
299 (ensure-directories-exist system
)
300 (let* ((tdir (get-tar-directory packagename
))
301 (*default-pathname-defaults
*
302 (merge-pathnames (make-pathname :directory
`(:relative
,tdir
))
304 (princ (untar-package source packagename
))
305 (loop for asd in
(directory
306 (make-pathname :name
:wild
:type
"asd"))
307 do
(let ((target (merge-pathnames
308 (make-pathname :name
(pathname-name asd
)
309 :type
(pathname-type asd
))
311 (when (probe-file target
)
312 (sb-posix:unlink target
))
314 (sb-posix:symlink asd target
))
315 collect
(pathname-name asd
))))
317 (defvar *temporary-files
*)
318 (defun temp-file-name (p)
319 (let* ((pos-slash (position #\
/ p
:from-end t
))
320 (pos-dot (position #\. p
:start
(or pos-slash
0))))
323 :name
(subseq p
(if pos-slash
(1+ pos-slash
) 0) pos-dot
)
324 :type
"asdf-install-tmp"))))
327 ;; this is the external entry point
328 (defun install (&rest packages
)
329 (let ((*temporary-files
* nil
)
331 (let ((p (merge-pathnames "trusted-uids.lisp" *dot-sbcl
*)))
333 (with-open-file (f p
) (read f
))))))
335 (destructuring-bind (source system name
) (where)
336 (declare (ignore name
))
337 (labels ((one-iter (packages)
339 (loop for p in
(mapcar 'string packages
)
340 unless
(probe-file p
)
341 do
(let ((tmp (temp-file-name p
)))
342 (pushnew tmp
*temporary-files
*)
343 (download-files-for-package p tmp
)
346 do
(format t
"Installing ~A in ~A,~A~%"
348 append
(install-package source system p
)))
350 ((asdf:missing-dependency
353 "Downloading package ~A, required by ~A~%"
354 (asdf::missing-requires c
)
356 (asdf::missing-required-by c
)))
359 (asdf::missing-requires c
))))
360 (invoke-restart 'retry
))))
362 (multiple-value-bind (ret restart-p
)
364 (retry "Retry installation")
365 (asdf:operate
'asdf
:load-op asd
))
366 (declare (ignore ret
))
367 (unless restart-p
(return))))))))
368 (one-iter packages
)))
369 (let ((p (merge-pathnames "trusted-uids.lisp" *dot-sbcl
*)))
370 (ensure-directories-exist p
)
371 (with-open-file (out p
:direction
:output
:if-exists
:supersede
)
372 (with-standard-io-syntax
373 (prin1 *trusted-uids
* out
))))
374 (dolist (l *temporary-files
*)
375 (when (probe-file l
) (delete-file l
))))))
377 (defun uninstall (system &optional
(prompt t
))
378 (let* ((asd (asdf:system-definition-pathname system
))
379 (system (asdf:find-system system
))
380 (dir (asdf::pathname-sans-name
+type
381 (asdf::resolve-symlinks asd
))))
382 (when (or (not prompt
)
384 "Delete system ~A~%asd file: ~A~%sources: ~A~%Are you sure?"
387 (asdf:run-shell-command
"rm -r ~A" (namestring dir
)))))
389 ;;; some day we will also do UPGRADE, but we need to sort out version
390 ;;; numbering a bit better first