Commit 43636485 authored by Daniel Barlow's avatar Daniel Barlow
Browse files

First draft of a cclan automatic download tool, currently

rather sbcl-specific.  Indirects through :(package ...) links
on cliki pages to download locations, which may be on cclan nodes
or elsewhere on the net.  Requires tar and gpg, but no dependencies
on Lisp packages other than what's included in SBCL contrib
parent edddef57
Loading
Loading
Loading
Loading

asdf-install.lisp

0 → 100644
+284 −0
Original line number Diff line number Diff line
;;; Install an ASDF system or anything else that looks convincingly
;;; like one, including updating symlink for all the toplevel .asd files it
;;; contains

#||

This is intended to be built as a command line utility: here's how 

(require 'sb-executable)
(compile-file "asdf-install")
(sb-executable:make-executable "asdf-install" *)

$ ./asdf-install net-telent-date_0.1.tar.gz pgutils.tar.gz split-sequence.tar.gz


TODO:
a) enable gpg signature checking
3) behaviour if no trusted signature found probably should be customizable
   
done- b) clear up the temporary files we're using for downloads

c) error handling and stuff.  one obvious problem with in-place compilation is
that no backout is possible after upgrading to a package that turns out to be
buggy or for which dependencies are missing.  That said, this would be simpler
if packages unpacked into a directory with the version number in their name
(yes, like clx does)

d) find where the user has put gpgpgpgp and tar instead of hardcoding locations

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

f) ought to pull in some rc file after doing default locations of
things, so that the user actually has a chance to configure without editing
these specials and rebuilding

||#
(in-package :cl-user)
(eval-when (:compile-toplevel :load-toplevel :execute)
  (require 'asdf)
  (require 'sb-posix)
  (require 'sb-executable)
  (require 'sb-bsd-sockets))

(defpackage :asdf-install (:use "CL" "SB-EXT"  "SB-BSD-SOCKETS"))

(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/experimental/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* 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")))

(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 (package-name file-name)
  (let ((url (format nil "http://www.cliki.net/~A?download" package-name)))
    (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*
	(verify-gpg-signature url file-name)))))

(defun verify-gpg-signature (url file-name)
  (destructuring-bind (response headers stream)
      (url-connection (concatenate 'string url ".asc"))
    (declare (ignore headers))
    (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 "/usr/bin/gpg"
					   (list "--verify" "-"
						 (namestring file-name))
					   :output 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 (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 "/bin/tar"
				 (list "-C" (namestring source)
				       "-xzvf" (namestring packagename))
				 :output o
				 :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)
  (merge-pathnames (make-pathname :type "asdf-install-tmp")
		   (merge-pathnames p)))

(defun run (&optional (packages (cdr *posix-argv*)))
  (destructuring-bind (source system name) (where)
    (labels ((one-iter (packages)
	       (dolist (asd
			 (loop for p in packages
			       unless (probe-file p)
			       do (let ((tmp (temp-file-name p)))
				    (download p tmp)
				    (pushnew tmp *temporary-files*)
				    (setf p tmp))
			       end
			       do (format t "Installing ~A in ~A,~A~%" p source system)
			       append (install 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))))

(handler-case
    (let ((*temporary-files* nil))
      (unwind-protect
	   (run)
	(dolist (l *temporary-files*) (delete-file l))))
  (error (c)
    (princ "Install failed due to error:") (terpri)
    (princ c) (terpri)
    (quit :unix-status 1)))

;(quit)
 No newline at end of file