Update of /cvsroot/sbcl/sbcl/contrib/asdf-install
In directory sc8-pr-cvs1:/tmp/cvs-serv25853/contrib/asdf-install
Added Files:
Makefile README asdf-install asdf-install.asd defpackage.lisp
installer.lisp loader.lisp
Log Message:
0.8.2.23
A full and final answer[*] to all the people who keep asking
for slightly tangential software to be added to contrib: to
wit, a contrib module to automate the downloading and
installing of packages that are _not_ part of contrib.
* (require 'asdf-install)
* (asdf-install:install 'xlunit)
or
$ sbcl-asdf-install xlunit
See contrib/asdf-install/README for more details and scary
security-related muttering.
Also added a :INITIAL-FUNCTION to SB-EXECUTABLE:MAKE-EXECUTABLE
so that files don't have to be written such that the
application starts as soon as they're loaded
[*] Ha!
--- NEW FILE: Makefile ---
SYSTEM=asdf-install
EXTRA_INSTALL_TARGETS=asdf-install-install
include ../asdf-module.mk
asdf-install-install: asdf-install
if test -f $(INSTALL_ROOT)/bin/sbcl-asdf-install ; then \
mv $(INSTALL_ROOT)/bin/sbcl-asdf-install $(INSTALL_ROOT)/bin/sbcl-asdf-install.old ; \
fi
cp asdf-install $(INSTALL_ROOT)/bin/sbcl-asdf-install
--- NEW FILE: README ---
Downloads and installs an ASDF system or anything else that looks
convincingly like one, including updating the ASDF:*CENTRAL-REGISTRY*
symlinks for all the toplevel .asd files it contains. Please read
this file before use: in particular: this is an automatic tool that
downloads and compiles stuff it finds on the 'net. Please look at the
SECURITY section and be sure you understand the implications
= USAGE
This can be used either from within an SBCL instance:
* (require 'asdf-install)
* (asdf-install:install 'xlunit) ; for example
or standalone from the shell:
$ sbcl-asdf-install xlunit
Each argument may be -
- The name of a cliki page. asdf-install visits that page and finds
the download location from the `:(package)' tag - usually rendered
as "Download ASDF package from ..."
- A URL, which is downloaded directly
- A local tar.gz file, which is installed
= SECURITY CONCERNS: READ THIS CAREFULLY
When you invoke asdf-install, you are asking SBCL to download,
compile, and install software from some random site on the web. Given
that it's indirected through a page on CLiki, any malicious third party
doesn't even need to hack the distribution server to replace the
package with something else: he can just edit the link.
For this reason, we encourage package providers to crypto-sign their
packages (see details at the URL in the PACKAGE CREATION section) and
users to check the signatures. asdf-install has three levels of
automatic signature checking: "on", "off" and "unknown sites", which
can be set using the configuration variables described in
CUSTOMIZATION below. The default is "unknown sites", which will
expect a GPG signature on all downloads except those from
presumed-good sites. The current default presumed-good sites are
CCLAN nodes, and two web sites run by SBCL maintainers: again, see
below for customization details
= CUSTOMIZATION
If the file $HOME/.asdf-install exists, it is loaded. This can be
used to override the default values of exported special variables.
Presently these are
*PROXY*
defaults to $http_proxy environment variable
*CCLAN-MIRROR*
preferred/nearest CCLAN node. See the list at
http://ww.telent.net/cclan-choose-mirror
*SBCL-HOME*
Set from $SBCL_HOME environment variable. This should already be
correct for whatever SBCL is running, if it's been installed correctly
*VERIFY-GPG-SIGNATURES*
Verify GPG signatures for the downloaded packages?
NIL - no, T - yes, :UNKNOWN-LOCATIONS - only for URLs which aren't in CCLAN
and don't begin with one of the prefixes in *SAFE-URL-PREFIXES*
*LOCATIONS*
Possible places in the filesystem to install packages into. See default
value for format
*SAFE-URL-PREFIXES*
List of locations for which GPG signature checking /won't/ be done when
*verify-gpg-signatures* is :unknown-locations
= PACKAGE CREATION
If you want to create your own packages that can be installed using this
loader, see the "Making your package downloadable..." section at
<http://www.cliki.net/asdf-install>
= HACKERS NOTE
Listen very carefully: I will say this only as often as it appears to
be necessary to say it. asdf-install is not a good example of how to
write a URL parser, HTTP client, or anything else, really.
Well-written extensible and robust URL parsers, HTTP clients, FTP
clients, etc would definitely be nice things to have, but it would be
nicer to have them in CCLAN where anyone can use them - after having
downloaded them with asdf-install - than in SBCL contrib where they're
restricted to SBCL users and can only be updated once a month via SBCL
developers. This is a bootstrap tool, and as such, will tend to
resist changes that make it longer or dependent on more other
packages, unless they also add to its usefulness for bootstrapping.
= TODO
a) gpg signature checking would be better if it actually checked against
a list of "trusted to write Lisp" keys, instead of just "trusted to be
who they say they are"
e) nice to have: resume half-done downloads instead of starting from scratch
every time. but right now we're dealing in fairly small packages, this is not
an immediate concern
--- NEW FILE: asdf-install ---
#!/bin/sh --
exec sbcl --noinform --disable-debugger --userinit /dev/null --sysinit /dev/null --eval "(with-open-file (i \"$0\" :element-type '(unsigned-byte 8)) (loop while (< ret 2) when (= (read-byte i) 10) count 1 into ret) (load i) (funcall (quote RUN)) (quit))" --end-toplevel-options ${1+"$@"}
# FASL
compiled from "/home/dan/src/sourceforge/sbcl/contrib/asdf-install/loader.lisp"
at Saturday, August 9, 2003 09:51:21 PM NIL
on noetbook.telent.net
using SBCL version 0.8.2.22
ÿ
->L *PACKAGE*LPACKAGEQ&SB-C> COMPILED-DEBUG-INFOR Q
DEBUG-INFOR (>$$->(>$$->&top level form> Q COMPILED-DEBUG-FUNR Q DEBUG-FUNR (> $$>-> (>!$$
->"&Itop level form (SETQ *PACKAGE* (SB-INT:FIND-UNDELETED-PACKAGE-OR-LOSE #))>#NTOPLEVEL(
d
/QNABSOLUTER¼
NÃ)à]ô]ôEÀË)áSü{øsôì küëÿPÿë
ôR¿
ôR¿
MÌ
NÌ
NÌ
Ì
NÌ
NÌ
MQNRELATIVERQ UNWINDRÔ
--- NEW FILE: asdf-install.asd ---
;;; -*- Lisp -*-
(defpackage #:asdf-install-system
(:use #:cl #:asdf))
(in-package #:asdf-install-system)
(require 'sb-executable)
;;; this is appalling misuse of asdf. please don't treat it as any
;;; kind of example. this shouldn't be a compile-op, or if it is, should
;;; define output-files properly instead oif leaving it be the fasl
(defclass exe-file (cl-source-file) ())
(defmethod perform ((o compile-op) (c exe-file))
(call-next-method)
(sb-executable:make-executable
(make-pathname :name "asdf-install"
:type nil
:defaults (component-pathname c))
(output-files o c)
:initial-function "RUN"))
(defmethod perform ((o load-op) (c exe-file)) nil)
(defsystem asdf-install
:depends-on (sb-posix sb-bsd-sockets)
:version "0.2"
:components ((:file "defpackage")
(exe-file "loader")
(:file "installer")))
(defmethod perform :after ((o load-op) (c (eql (find-system :asdf-install))))
(provide 'asdf-install))
(defmethod perform ((o test-op) (c (eql (find-system :asdf-install))))
t)
--- NEW FILE: defpackage.lisp ---
(cl:in-package :cl-user)
(defpackage :asdf-install
(:use "CL" "SB-EXT" "SB-BSD-SOCKETS")
(:export
;; customizable variables
#:*proxy* #:*cclan-mirror* #:*sbcl-home*
#:*verify-gpg-signatures* #:*locations*
#:*safe-url-prefixes*
;; entry point
#:install))
(defpackage :asdf-install-customize
(:use "CL" "SB-EXT" "SB-BSD-SOCKETS" "ASDF-INSTALL"))
--- NEW FILE: installer.lisp ---
(in-package :asdf-install)
(defvar *proxy* (posix-getenv "http_proxy"))
(defvar *cclan-mirror*
(or (posix-getenv "CCLAN_MIRROR")
"http://ftp.linux.org.uk/pub/lisp/cclan/"))
(defun directorify (name)
;; input name may or may not have a training #\/, but we know we
;; want a directory
(let ((path (pathname name)))
(if (pathname-name path)
(merge-pathnames
(make-pathname :directory `(:relative ,(pathname-name path))
:name "")
path)
path)))
(defvar *sbcl-home* (directorify (posix-getenv "SBCL_HOME")))
(defvar *dot-sbcl*
(merge-pathnames (make-pathname :directory '(:relative ".sbcl"))
(user-homedir-pathname)))
(defvar *verify-gpg-signatures* :unknown-locations
"Should we get detached GPG signatures for the packages and verify them?
NIL - no, T - yes, :UNKNOWN-LOCATIONS - for any URL which isn't in CCLAN
and doesn't begin with one of the prefixes in *SAFE-URL-PREFIXES*")
(defvar *safe-url-prefixes*
(list "http://ftp.linux.org.uk/pub/lisp/"
"http://files.b9.com/"))
(defun verify-gpg-signatures-p (url)
(labels ((prefixp (prefix string)
(let ((m (mismatch prefix string)))
(or (not m) (>= m (length prefix))))))
(case *verify-gpg-signatures*
(nil nil)
(:unknown-locations
(notany
(lambda (x) (prefixp x url))
(cons *cclan-mirror* *safe-url-prefixes*)))
(t t))))
(defvar *locations*
`((,(merge-pathnames "site/" *sbcl-home*)
,(merge-pathnames "site-systems/" *sbcl-home*)
"System-wide install")
(,(merge-pathnames "site/" *dot-sbcl*)
,(merge-pathnames "systems/" *dot-sbcl*)
"Personal installation")))
(let* ((*package* (find-package :asdf-install-customize))
(file (probe-file (merge-pathnames
(make-pathname :name ".asdf-install")
(user-homedir-pathname)))))
(when file (load file)))
(define-condition download-error (error)
((url :initarg :url :reader download-url)
(response :initarg :response :reader download-response))
(:report (lambda (c s)
(format s "Server responded ~A for GET ~A"
(download-response c) (download-url c)))))
(define-condition signature-error (error)
((cause :initarg :cause :reader signature-error-cause))
(:report (lambda (c s)
(format s "Cannot verify package signature: ~A"
(signature-error-cause c)))))
(defun url-host (url)
(assert (string-equal url "http://" :end1 7))
(let* ((port-start (position #\: url :start 7))
(host-end (min (or (position #\/ url :start 7) (length url))
(or port-start (length url)))))
(subseq url 7 host-end)))
(defun url-port (url)
(assert (string-equal url "http://" :end1 7))
(let ((port-start (position #\: url :start 7)))
(if port-start (parse-integer url :start port-start :junk-allowed t) 80)))
(defun url-connection (url)
(let ((s (make-instance 'inet-socket :type :stream :protocol :tcp))
(host (url-host url))
(port (url-port url)))
(socket-connect
s (car (host-ent-addresses (get-host-by-name (url-host (or *proxy* url)))))
(url-port (or *proxy* url)))
(let ((stream (socket-make-stream s :input t :output t :buffering :full)))
;; we are exceedingly unportable about proper line-endings here.
;; Anyone wishing to run this under non-SBCL should take especial care
(format stream "GET ~A HTTP/1.0~%Host: ~A~%Cookie: CCLAN-SITE=~A~%~%"
url host *cclan-mirror*)
(force-output stream)
(list
(let* ((l (read-line stream))
(space (position #\Space l)))
(parse-integer l :start (1+ space) :junk-allowed t))
(loop for line = (read-line stream nil nil)
until (or (null line) (eql (elt line 0) (code-char 13)))
collect
(let ((colon (position #\: line)))
(cons (intern (string-upcase (subseq line 0 colon)) :keyword)
(string-trim (list #\Space (code-char 13))
(subseq line (1+ colon))))))
stream))))
(defun download-files-for-package (package-name-or-url file-name)
(let ((url
(if (= (mismatch package-name-or-url "http://") 7)
package-name-or-url
(format nil "http://www.cliki.net/~A?download"
package-name-or-url))))
(destructuring-bind (response headers stream)
(block got
(loop
(destructuring-bind (response headers stream) (url-connection url)
(unless (member response '(301 302))
(return-from got (list response headers stream)))
(close stream)
(setf url (cdr (assoc :location headers))))))
(if (>= response 400)
(error 'download-error :url url :response response))
(let ((length (parse-integer
(or (cdr (assoc :content-length headers)) "")
:junk-allowed t)))
(format t "Downloading ~A bytes from ~A ..."
(if length length "some unknown number of") url)
(force-output)
(with-open-file (o file-name :direction :output)
(if length
(let ((buf (make-array length
:element-type
(stream-element-type stream) )))
(read-sequence buf stream)
(write-sequence buf o))
(sb-executable:copy-stream stream o))))
(close stream)
(terpri)
;; seems to have worked. let's try for a detached gpg signature too
(when (verify-gpg-signatures-p url)
(verify-gpg-signature url file-name)))))
(defun verify-gpg-signature (url file-name)
(destructuring-bind (response headers stream)
(url-connection (concatenate 'string url ".asc"))
(unwind-protect
(if (= response 200)
;; sadly, we can't pass the stream directly to run-program,
;; because (at least in sbcl 0.8) that ignores existing buffered
;; data and only reads new fresh data direct from the file
;; descriptor
(let ((data (make-string (parse-integer
(cdr (assoc :content-length headers))
:junk-allowed t))))
(read-sequence data stream)
(let ((ret
(process-exit-code
(sb-ext:run-program "gpg"
(list "--verify" "-"
(namestring file-name))
:output t
:search t
:input (make-string-input-stream data)
:wait t))))
(unless (zerop ret)
(error 'signature-error
:cause (make-condition
'simple-error
:format-control "GPG returned exit status ~A"
:format-arguments (list ret))))))
(error 'signature-error
:cause
(make-condition
'download-error :url (concatenate 'string url ".asc")
:response response)))
(close stream))))
(defun where ()
(format t "Install where?~%")
(loop for (source system name) in *locations*
for i from 1
do (format t "~A) ~A: ~% System in ~A~% Files in ~A ~%"
i name system source))
(format t " --> ") (force-output)
(let ((response (read)))
(when (> response 0)
(elt *locations* (1- response)))))
(defun install-package (source system packagename)
"Returns a list of asdf system names for installed asdf systems"
(ensure-directories-exist source )
(ensure-directories-exist system )
(let* ((tar
(with-output-to-string (o)
(or
(sb-ext:run-program "tar"
(list "-C" (namestring source)
"-xzvf" (namestring packagename))
:output o
:search t
:wait t)
(error "can't untar"))))
(dummy (princ tar))
(pos-slash (position #\/ tar))
(*default-pathname-defaults*
(merge-pathnames
(make-pathname :directory
`(:relative ,(subseq tar 0 pos-slash)))
source)))
(loop for asd in (directory
(make-pathname :name :wild :type "asd"))
do (let ((target (merge-pathnames
(make-pathname :name (pathname-name asd)
:type (pathname-type asd))
system)))
(when (probe-file target)
(sb-posix:unlink target))
(sb-posix:symlink asd target))
collect (pathname-name asd))))
(defvar *temporary-files*)
(defun temp-file-name (p)
(let* ((pos-slash (position #\/ p :from-end t))
(pos-dot (position #\. p :start (or pos-slash 0))))
(merge-pathnames
(make-pathname
:name (subseq p (if pos-slash (1+ pos-slash) 0) pos-dot)
:type "asdf-install-tmp"))))
;; this is the external entry point
(defun install (&rest packages)
(let ((*temporary-files* nil))
(unwind-protect
(destructuring-bind (source system name) (where)
(labels ((one-iter (packages)
(dolist (asd
(loop for p in (mapcar 'string packages)
unless (probe-file p)
do (let ((tmp (temp-file-name p)))
(pushnew tmp *temporary-files*)
(download-files-for-package p tmp)
(setf p tmp))
end
do (format t "Installing ~A in ~A,~A~%"
p source system)
append (install-package source system p)))
(handler-case
(asdf:operate 'asdf:load-op asd)
(asdf:missing-dependency (c)
(format t
"Downloading package ~A, required by ~A~%"
(asdf::missing-requires c)
(asdf:component-name
(asdf::missing-required-by c)))
(one-iter (list
(symbol-name
(asdf::missing-requires c)))))))))
(one-iter packages)))
(dolist (l *temporary-files*)
(when (probe-file l) (delete-file l))))))
--- NEW FILE: loader.lisp ---
(in-package :cl-user)
(eval-when (:compile-toplevel :load-toplevel :execute)
(require 'asdf)
(asdf:operate 'asdf:load-op 'asdf-install :verbose nil))
(defun run ()
(handler-case
(apply #'asdf-install:install (cdr *posix-argv*))
(error (c)
(princ "Install failed due to error:") (terpri)
(princ c) (terpri)
(quit :unix-status 1))))
;(quit)
|