From f8664e5b8a5dfdcc6d0cb2f923b7de7a4322a1fa Mon Sep 17 00:00:00 2001 From: Cyrus Harmon Date: Tue, 12 Nov 2013 14:10:59 -0800 Subject: [PATCH] remove asdf-install contrib --- contrib/asdf-install/.cvsignore | 2 - contrib/asdf-install/Makefile | 2 - contrib/asdf-install/README | 105 --------- contrib/asdf-install/asdf-install.asd | 10 - contrib/asdf-install/defpackage.lisp | 12 - contrib/asdf-install/installer.lisp | 390 --------------------------------- 6 files changed, 521 deletions(-) delete mode 100644 contrib/asdf-install/.cvsignore delete mode 100644 contrib/asdf-install/Makefile delete mode 100644 contrib/asdf-install/README delete mode 100644 contrib/asdf-install/asdf-install.asd delete mode 100644 contrib/asdf-install/defpackage.lisp delete mode 100644 contrib/asdf-install/installer.lisp diff --git a/contrib/asdf-install/.cvsignore b/contrib/asdf-install/.cvsignore deleted file mode 100644 index 1f7006e..0000000 --- a/contrib/asdf-install/.cvsignore +++ /dev/null @@ -1,2 +0,0 @@ -asdf-install -test-passed diff --git a/contrib/asdf-install/Makefile b/contrib/asdf-install/Makefile deleted file mode 100644 index c822c11..0000000 --- a/contrib/asdf-install/Makefile +++ /dev/null @@ -1,2 +0,0 @@ -SYSTEM=asdf-install -include ../asdf-module.mk diff --git a/contrib/asdf-install/README b/contrib/asdf-install/README deleted file mode 100644 index 92ff6b5..0000000 --- a/contrib/asdf-install/README +++ /dev/null @@ -1,105 +0,0 @@ -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 strongly recommend that package providers use PGP -or GPG to crypto-sign their packages (see details at the URL in the -PACKAGE CREATION section) and that users check the signatures. -asdf-install makes three checks - - 1) that the signature exists - - 2) that there is a GPG trust relationship between the package signer - and the installer (i.e. that the package comes from someone whose - key you've signed, or someone else you have GPG trust with has signed) - - 3) that the signature is one of the ones listed in - $HOME/.sbcl/trusted-uids.lisp as a valid supplier of Lisp code. - - -= 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 -*LOCATIONS* - Possible places in the filesystem to install packages into. See default - value for format - - -= 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 - - - -= 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 - - diff --git a/contrib/asdf-install/asdf-install.asd b/contrib/asdf-install/asdf-install.asd deleted file mode 100644 index 3ee25d3..0000000 --- a/contrib/asdf-install/asdf-install.asd +++ /dev/null @@ -1,10 +0,0 @@ -;;; -*- Lisp -*- -(defsystem asdf-install - :depends-on (sb-posix sb-bsd-sockets) - #+sb-building-contrib :pathname - #+sb-building-contrib #p"SYS:CONTRIB;ASDF-INSTALL;" - :version "0.2" - :components ((:file "defpackage") - (:file "installer" :depends-on ("defpackage"))) - :perform (load-op :after (o c) (provide 'asdf-install)) - :perform (test-op (o c) t)) diff --git a/contrib/asdf-install/defpackage.lisp b/contrib/asdf-install/defpackage.lisp deleted file mode 100644 index 166e0e1..0000000 --- a/contrib/asdf-install/defpackage.lisp +++ /dev/null @@ -1,12 +0,0 @@ -(cl:in-package :cl-user) -(defpackage :asdf-install - (:use "CL" "SB-EXT" "SB-BSD-SOCKETS") - (:export - ;; customizable variables - #:*proxy* #:*cclan-mirror* #:*sbcl-home* - #:*locations* - ;; external entry points - #:uninstall #:install)) - -(defpackage :asdf-install-customize - (:use "CL" "SB-EXT" "SB-BSD-SOCKETS" "ASDF-INSTALL")) diff --git a/contrib/asdf-install/installer.lisp b/contrib/asdf-install/installer.lisp deleted file mode 100644 index 5d76644..0000000 --- a/contrib/asdf-install/installer.lisp +++ /dev/null @@ -1,390 +0,0 @@ -(in-package :asdf-install) - -(defvar *proxy* (posix-getenv "http_proxy")) -(defvar *cclan-mirror* - (let ((mirror (posix-getenv "CCLAN_MIRROR"))) - (or (and (not (string= mirror "")) 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))) - (make-pathname :directory (pathname-directory path) - :host (pathname-host path) - :device (pathname-device path))) - path))) - -(defvar *sbcl-home* (directorify (posix-getenv "SBCL_HOME"))) -(defvar *dot-sbcl* - (merge-pathnames (make-pathname :directory '(:relative ".sbcl")) - (user-homedir-pathname))) - -(defparameter *trusted-uids* nil) - -(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"))) - -(unless (sb-ext:posix-getenv "SBCL_BUILDING_CONTRIB") - ;; Not during build, thanks. - (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))))) - -(define-condition gpg-error (error) - ((message :initarg :message :reader gpg-error-message)) - (:report (lambda (c s) - (format s "GPG failed with error status:~%~S" - (gpg-error-message c))))) - -(define-condition no-signature (gpg-error) ()) -(define-condition key-not-found (gpg-error) - ((key-id :initarg :key-id :reader key-id)) - (:report (lambda (c s) - (format s "No key found for key id 0x~A. Try some command like ~% gpg --recv-keys 0x~A" - (key-id c) (key-id c))))) - -(define-condition key-not-trusted (gpg-error) - ((key-id :initarg :key-id :reader key-id) - (key-user-name :initarg :key-user-name :reader key-user-name)) - (:report (lambda (c s) - (format s "GPG warns that the key id 0x~A (~A) is not fully trusted" - (key-id c) (key-user-name c))))) -(define-condition author-not-trusted (gpg-error) - ((key-id :initarg :key-id :reader key-id) - (key-user-name :initarg :key-user-name :reader key-user-name)) - (:report (lambda (c s) - (format s "~A (key id ~A) is not on your package supplier list" - (key-user-name c) (key-id 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 (1+ port-start) :junk-allowed t) 80))) - -(defun request-uri (url) - (assert (string-equal url "http://" :end1 7)) - (if *proxy* - url - (let ((path-start (position #\/ url :start 7))) - (subseq url path-start)))) - -(defun url-connection (url) - (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp)) - (host (url-host url)) - (port (url-port url)) - result) - (declare (ignore port)) - (unwind-protect - (progn - (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 - :element-type :default :external-format :iso-8859-1))) - ;; 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~c~%~ - Host: ~A~c~%~ - Cookie: CCLAN-SITE=~A~c~%~c~%" - (request-uri url) #\Return - host #\Return - *cclan-mirror* #\Return #\Return) - (force-output stream) - (setf result - (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)))) - (when (and (null result) - (socket-open-p s)) - (socket-close s))))) - - -(defun copy-stream (in out) - (let ((buf (make-array 8192 :element-type (stream-element-type out)))) - (loop for pos = (read-sequence buf in) - until (zerop pos) - do (write-sequence buf out :end pos)))) - -(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 (out file-name :direction :output - :element-type '(unsigned-byte 8)) - (if length - (let ((buf (make-array length :element-type '(unsigned-byte 8)))) - (read-sequence buf stream) - (write-sequence buf out)) - (copy-stream stream out)))) - (close stream) - (terpri) - (restart-case - (verify-gpg-signature/url url file-name) - (skip-gpg-check () - :report "Don't check GPG signature for this package" - nil))))) - -(defun read-until-eof (stream) - (with-output-to-string (o) - (copy-stream stream o))) - -(defun verify-gpg-signature/string (string file-name) - (let* ((proc - (sb-ext:run-program - "gpg" - (list - "--status-fd" "1" "--verify" "-" - (namestring file-name)) - :output :stream :error :stream :search t - :input (make-string-input-stream string) :wait t)) - (err (read-until-eof (process-error proc))) - tags) - (loop for l = (read-line (process-output proc) nil nil) - while l - when (> (mismatch l "[GNUPG:]") 6) - do (destructuring-bind (_ tag &rest data) (asdf::split-string l) - (declare (ignore _)) - (pushnew (cons (intern tag :keyword) - data) tags))) - ;; test for obvious key/sig problems - (let ((errsig (assoc :errsig tags))) - (and errsig (error 'key-not-found :key-id (second errsig) :gpg-err err))) - (let ((badsig (assoc :badsig tags))) - (and badsig (error 'key-not-found :key-id (second badsig) :gpg-err err))) - (let* ((good (assoc :goodsig tags)) - (id (second good)) - (name (format nil "~{~A~^ ~}" (nthcdr 2 good)))) - ;; good signature, but perhaps not trusted - (unless (or (assoc :trust_ultimate tags) - (assoc :trust_fully tags)) - (cerror "Install the package anyway" - 'key-not-trusted - :key-user-name name - :key-id id :gpg-err err)) - (loop - (when - (restart-case - (or (assoc id *trusted-uids* :test #'equal) - (error 'author-not-trusted - :key-user-name name - :key-id id :gpg-err nil)) - (add-key () - :report "Add to package supplier list" - (pushnew (list id name) *trusted-uids*))) - (return)))))) - - - -(defun verify-gpg-signature/url (url file-name) - (destructuring-bind (response headers stream) - (url-connection (concatenate 'string url ".asc")) - (unwind-protect - (if (= response 200) - (let ((data (make-string (parse-integer - (cdr (assoc :content-length headers)) - :junk-allowed t)))) - (read-sequence data stream) - (verify-gpg-signature/string data file-name)) - (error '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))))) - -(defparameter *tar-program* - ;; Please do not "clean this up" by using a bunch of #+'s and one - ;; #-. When the conditional is written this way, adding a new - ;; special case only involves one change. If #- is used, two changes - ;; are needed. -- JES, 2007-02-12 - (progn - "tar" - #+darwin "gnutar" - #+(or sunos netbsd) "gtar")) - -(defun get-tar-directory (packagename) - (let* ((tar (with-output-to-string (o) - (or - (sb-ext:run-program *tar-program* - (list "-tzf" (namestring packagename)) - :output o - :search t - :wait t) - (error "can't list archive")))) - (first-line (subseq tar 0 (position #\newline tar)))) - (if (find #\/ first-line) - (subseq first-line 0 (position #\/ first-line)) - first-line))) - -(defun untar-package (source packagename) - (with-output-to-string (o) - (or - (sb-ext:run-program *tar-program* - (list "-C" (namestring source) - "-xzvf" (namestring packagename)) - :output o - :search t - :wait t) - (error "can't untar")))) - -(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* ((tdir (get-tar-directory packagename)) - (*default-pathname-defaults* - (merge-pathnames (make-pathname :directory `(:relative ,tdir)) - source))) - (princ (untar-package source packagename)) - (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)) - #-win32 - (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) - (*trusted-uids* - (let ((p (merge-pathnames "trusted-uids.lisp" *dot-sbcl*))) - (when (probe-file p) - (with-open-file (f p) (read f)))))) - (unwind-protect - (destructuring-bind (source system name) (where) - (declare (ignore name)) - (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-bind - ((asdf:missing-dependency - (lambda (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)))) - (invoke-restart 'retry)))) - (loop - (multiple-value-bind (ret restart-p) - (with-simple-restart - (retry "Retry installation") - (asdf:operate 'asdf:load-op asd)) - (declare (ignore ret)) - (unless restart-p (return)))))))) - (one-iter packages))) - (let ((p (merge-pathnames "trusted-uids.lisp" *dot-sbcl*))) - (ensure-directories-exist p) - (with-open-file (out p :direction :output :if-exists :supersede) - (with-standard-io-syntax - (prin1 *trusted-uids* out)))) - (dolist (l *temporary-files*) - (when (probe-file l) (delete-file l)))))) - -(defun uninstall (system &optional (prompt t)) - (let* ((asd (asdf:system-definition-pathname system)) - (system (asdf:find-system system)) - (dir (asdf::pathname-sans-name+type - (asdf::resolve-symlinks asd)))) - (when (or (not prompt) - (y-or-n-p - "Delete system ~A~%asd file: ~A~%sources: ~A~%Are you sure?" - system asd dir)) - (delete-file asd) - (asdf:run-shell-command "rm -r ~A" (namestring dir))))) - -;;; some day we will also do UPGRADE, but we need to sort out version -;;; numbering a bit better first -- 1.7.10.4