;;;; ;;;; This is quicklisp.lisp, the quickstart file for Quicklisp. To use ;;;; it, start Lisp, then (load "quicklisp.lisp") ;;;; ;;;; Quicklisp is beta software and comes with no warranty of any kind. ;;;; ;;;; For more information about the Quicklisp beta, see: ;;;; ;;;; http://www.quicklisp.org/beta/ ;;;; ;;;; If you have any questions or comments about Quicklisp, please ;;;; contact: ;;;; ;;;; Zach Beane ;;;; (cl:in-package #:cl-user) (cl:defpackage #:qlqs-user (:use #:cl)) (cl:in-package #:qlqs-user) (defpackage #:qlqs-info (:export #:*version*)) (defvar qlqs-info:*version* "2015-01-28") (defpackage #:qlqs-impl (:use #:cl) (:export #:*implementation*) (:export #:definterface #:defimplementation) (:export #:lisp #:abcl #:allegro #:ccl #:clasp #:clisp #:cmucl #:cormanlisp #:ecl #:gcl #:lispworks #:mkcl #:scl #:sbcl)) (defpackage #:qlqs-impl-util (:use #:cl #:qlqs-impl) (:export #:call-with-quiet-compilation)) (defpackage #:qlqs-network (:use #:cl #:qlqs-impl) (:export #:open-connection #:write-octets #:read-octets #:close-connection #:with-connection)) (defpackage #:qlqs-progress (:use #:cl) (:export #:make-progress-bar #:start-display #:update-progress #:finish-display)) (defpackage #:qlqs-http (:use #:cl #:qlqs-network #:qlqs-progress) (:export #:fetch #:*proxy-url* #:*maximum-redirects* #:*default-url-defaults*)) (defpackage #:qlqs-minitar (:use #:cl) (:export #:unpack-tarball)) (defpackage #:quicklisp-quickstart (:use #:cl #:qlqs-impl #:qlqs-impl-util #:qlqs-http #:qlqs-minitar) (:export #:install #:help #:*proxy-url* #:*asdf-url* #:*quicklisp-tar-url* #:*setup-url* #:*help-message* #:*after-load-message* #:*after-initial-setup-message*)) ;;; ;;; Defining implementation-specific packages and functionality ;;; (in-package #:qlqs-impl) (eval-when (:compile-toplevel :load-toplevel :execute) (defun error-unimplemented (&rest args) (declare (ignore args)) (error "Not implemented"))) (defmacro neuter-package (name) `(eval-when (:compile-toplevel :load-toplevel :execute) (let ((definition (fdefinition 'error-unimplemented))) (do-external-symbols (symbol ,(string name)) (unless (fboundp symbol) (setf (fdefinition symbol) definition)))))) (eval-when (:compile-toplevel :load-toplevel :execute) (defun feature-expression-passes-p (expression) (cond ((keywordp expression) (member expression *features*)) ((consp expression) (case (first expression) (or (some 'feature-expression-passes-p (rest expression))) (and (every 'feature-expression-passes-p (rest expression))))) (t (error "Unrecognized feature expression -- ~S" expression))))) (defmacro define-implementation-package (feature package-name &rest options) (let* ((output-options '((:use) (:export #:lisp))) (prep (cdr (assoc :prep options))) (class-option (cdr (assoc :class options))) (class (first class-option)) (superclasses (rest class-option)) (import-options '()) (effectivep (feature-expression-passes-p feature))) (dolist (option options) (ecase (first option) ((:prep :class)) ((:import-from :import) (push option import-options)) ((:export :shadow :intern :documentation) (push option output-options)) ((:reexport-from) (push (cons :export (cddr option)) output-options) (push (cons :import-from (cdr option)) import-options)))) `(eval-when (:compile-toplevel :load-toplevel :execute) ,@(when effectivep prep) (defclass ,class ,superclasses ()) (defpackage ,package-name ,@output-options ,@(when effectivep import-options)) ,@(when effectivep `((setf *implementation* (make-instance ',class)))) ,@(unless effectivep `((neuter-package ,package-name)))))) (defmacro definterface (name lambda-list &body options) (let* ((forbidden (intersection lambda-list lambda-list-keywords)) (gf-options (remove :implementation options :key #'first)) (implementations (set-difference options gf-options))) (when forbidden (error "~S not allowed in definterface lambda list" forbidden)) (flet ((method-option (class body) `(:method ((*implementation* ,class) ,@lambda-list) ,@body))) (let ((generic-name (intern (format nil "%~A" name)))) `(eval-when (:compile-toplevel :load-toplevel :execute) (defgeneric ,generic-name (lisp ,@lambda-list) ,@gf-options ,@(mapcar (lambda (implementation) (destructuring-bind (class &rest body) (rest implementation) (method-option class body))) implementations)) (defun ,name ,lambda-list (,generic-name *implementation* ,@lambda-list))))))) (defmacro defimplementation (name-and-options lambda-list &body body) (destructuring-bind (name &key (for t) qualifier) (if (consp name-and-options) name-and-options (list name-and-options)) (unless for (error "You must specify an implementation name.")) (let ((generic-name (find-symbol (format nil "%~A" name)))) (unless (and generic-name (fboundp generic-name)) (error "~S does not name an implementation function" name)) `(defmethod ,generic-name ,@(when qualifier (list qualifier)) ,(list* `(*implementation* ,for) lambda-list) ,@body)))) ;;; Bootstrap implementations (defvar *implementation* nil) (defclass lisp () ()) ;;; Allegro Common Lisp (define-implementation-package :allegro #:qlqs-allegro (:documentation "Allegro Common Lisp - http://www.franz.com/products/allegrocl/") (:class allegro) (:reexport-from #:socket #:make-socket) (:reexport-from #:excl #:read-vector)) ;;; Armed Bear Common Lisp (define-implementation-package :abcl #:qlqs-abcl (:documentation "Armed Bear Common Lisp - http://common-lisp.net/project/armedbear/") (:class abcl) (:reexport-from #:system #:make-socket #:get-socket-stream)) ;;; Clozure CL (define-implementation-package :ccl #:qlqs-ccl (:documentation "Clozure Common Lisp - http://www.clozure.com/clozurecl.html") (:class ccl) (:reexport-from #:ccl #:make-socket)) ;;; CLASP (define-implementation-package :clasp #:qlqs-clasp (:documentation "CLASP - http://github.com/drmeister/clasp") (:class clasp) (:prep (require 'sockets)) (:intern #:host-network-address) (:reexport-from #:sb-bsd-sockets #:get-host-by-name #:host-ent-address #:socket-connect #:socket-make-stream #:inet-socket)) ;;; GNU CLISP (define-implementation-package :clisp #:qlqs-clisp (:documentation "GNU CLISP - http://clisp.cons.org/") (:class clisp) (:reexport-from #:socket #:socket-connect) (:reexport-from #:ext #:read-byte-sequence)) ;;; CMUCL (define-implementation-package :cmu #:qlqs-cmucl (:documentation "CMU Common Lisp - http://www.cons.org/cmucl/") (:class cmucl) (:reexport-from #:ext #:*gc-verbose*) (:reexport-from #:system #:make-fd-stream) (:reexport-from #:extensions #:connect-to-inet-socket)) (defvar qlqs-cmucl:*gc-verbose* nil) ;;; Scieneer CL (define-implementation-package :scl #:qlqs-scl (:documentation "Scieneer Common Lisp - http://www.scieneer.com/scl/") (:class scl) (:reexport-from #:system #:make-fd-stream) (:reexport-from #:extensions #:connect-to-inet-socket)) ;;; ECL (define-implementation-package :ecl #:qlqs-ecl (:documentation "ECL - http://ecls.sourceforge.net/") (:class ecl) (:prep (require 'sockets)) (:intern #:host-network-address) (:reexport-from #:sb-bsd-sockets #:get-host-by-name #:host-ent-address #:socket-connect #:socket-make-stream #:inet-socket)) ;;; LispWorks (define-implementation-package :lispworks #:qlqs-lispworks (:documentation "LispWorks - http://www.lispworks.com/") (:class lispworks) (:prep (require "comm")) (:reexport-from #:comm #:open-tcp-stream #:get-host-entry)) ;;; SBCL (define-implementation-package :sbcl #:qlqs-sbcl (:class sbcl) (:documentation "Steel Bank Common Lisp - http://www.sbcl.org/") (:prep (require 'sb-bsd-sockets)) (:intern #:host-network-address) (:reexport-from #:sb-ext #:compiler-note) (:reexport-from #:sb-bsd-sockets #:get-host-by-name #:inet-socket #:host-ent-address #:socket-connect #:socket-make-stream)) ;;; MKCL (define-implementation-package :mkcl #:qlqs-mkcl (:class mkcl) (:documentation "ManKai Common Lisp - http://common-lisp.net/project/mkcl/") (:prep (require 'sockets)) (:intern #:host-network-address) (:reexport-from #:sb-bsd-sockets #:get-host-by-name #:inet-socket #:host-ent-address #:socket-connect #:socket-make-stream)) ;;; ;;; Utility function ;;; (in-package #:qlqs-impl-util) (definterface call-with-quiet-compilation (fun) (:implementation t (let ((*load-verbose* nil) (*compile-verbose* nil) (*load-print* nil) (*compile-print* nil)) (handler-bind ((warning #'muffle-warning)) (funcall fun))))) (defimplementation (call-with-quiet-compilation :for sbcl :qualifier :around) (fun) (declare (ignorable fun)) (handler-bind ((qlqs-sbcl:compiler-note #'muffle-warning)) (call-next-method))) (defimplementation (call-with-quiet-compilation :for cmucl :qualifier :around) (fun) (declare (ignorable fun)) (let ((qlqs-cmucl:*gc-verbose* nil)) (call-next-method))) ;;; ;;; Low-level networking implementations ;;; (in-package #:qlqs-network) (definterface host-address (host) (:implementation t host) (:implementation mkcl (qlqs-mkcl:host-ent-address (qlqs-mkcl:get-host-by-name host))) (:implementation sbcl (qlqs-sbcl:host-ent-address (qlqs-sbcl:get-host-by-name host)))) (definterface open-connection (host port) (:implementation t (declare (ignorable host port)) (error "Sorry, quicklisp in implementation ~S is not supported yet." (lisp-implementation-type))) (:implementation allegro (qlqs-allegro:make-socket :remote-host host :remote-port port)) (:implementation abcl (let ((socket (qlqs-abcl:make-socket host port))) (qlqs-abcl:get-socket-stream socket :element-type '(unsigned-byte 8)))) (:implementation ccl (qlqs-ccl:make-socket :remote-host host :remote-port port)) (:implementation clasp (let* ((endpoint (qlqs-clasp:host-ent-address (qlqs-clasp:get-host-by-name host))) (socket (make-instance 'qlqs-clasp:inet-socket :protocol :tcp :type :stream))) (qlqs-clasp:socket-connect socket endpoint port) (qlqs-clasp:socket-make-stream socket :element-type '(unsigned-byte 8) :input t :output t :buffering :full))) (:implementation clisp (qlqs-clisp:socket-connect port host :element-type '(unsigned-byte 8))) (:implementation cmucl (let ((fd (qlqs-cmucl:connect-to-inet-socket host port))) (qlqs-cmucl:make-fd-stream fd :element-type '(unsigned-byte 8) :binary-stream-p t :input t :output t))) (:implementation scl (let ((fd (qlqs-scl:connect-to-inet-socket host port))) (qlqs-scl:make-fd-stream fd :element-type '(unsigned-byte 8) :input t :output t))) (:implementation ecl (let* ((endpoint (qlqs-ecl:host-ent-address (qlqs-ecl:get-host-by-name host))) (socket (make-instance 'qlqs-ecl:inet-socket :protocol :tcp :type :stream))) (qlqs-ecl:socket-connect socket endpoint port) (qlqs-ecl:socket-make-stream socket :element-type '(unsigned-byte 8) :input t :output t :buffering :full))) (:implementation lispworks (qlqs-lispworks:open-tcp-stream host port :direction :io :errorp t :read-timeout nil :element-type '(unsigned-byte 8) :timeout 5)) (:implementation mkcl (let* ((endpoint (qlqs-mkcl:host-ent-address (qlqs-mkcl:get-host-by-name host))) (socket (make-instance 'qlqs-mkcl:inet-socket :protocol :tcp :type :stream))) (qlqs-mkcl:socket-connect socket endpoint port) (qlqs-mkcl:socket-make-stream socket :element-type '(unsigned-byte 8) :input t :output t :buffering :full))) (:implementation sbcl (let* ((endpoint (qlqs-sbcl:host-ent-address (qlqs-sbcl:get-host-by-name host))) (socket (make-instance 'qlqs-sbcl:inet-socket :protocol :tcp :type :stream))) (qlqs-sbcl:socket-connect socket endpoint port) (qlqs-sbcl:socket-make-stream socket :element-type '(unsigned-byte 8) :input t :output t :buffering :full)))) (definterface read-octets (buffer connection) (:implementation t (read-sequence buffer connection)) (:implementation allegro (qlqs-allegro:read-vector buffer connection)) (:implementation clisp (qlqs-clisp:read-byte-sequence buffer connection :no-hang nil :interactive t))) (definterface write-octets (buffer connection) (:implementation t (write-sequence buffer connection) (finish-output connection))) (definterface close-connection (connection) (:implementation t (ignore-errors (close connection)))) (definterface call-with-connection (host port fun) (:implementation t (let (connection) (unwind-protect (progn (setf connection (open-connection host port)) (funcall fun connection)) (when connection (close connection)))))) (defmacro with-connection ((connection host port) &body body) `(call-with-connection ,host ,port (lambda (,connection) ,@body))) ;;; ;;; A text progress bar ;;; (in-package #:qlqs-progress) (defclass progress-bar () ((start-time :initarg :start-time :accessor start-time) (end-time :initarg :end-time :accessor end-time) (progress-character :initarg :progress-character :accessor progress-character) (character-count :initarg :character-count :accessor character-count :documentation "How many characters wide is the progress bar?") (characters-so-far :initarg :characters-so-far :accessor characters-so-far) (update-interval :initarg :update-interval :accessor update-interval :documentation "Update the progress bar display after this many internal-time units.") (last-update-time :initarg :last-update-time :accessor last-update-time :documentation "The display was last updated at this time.") (total :initarg :total :accessor total :documentation "The total number of units tracked by this progress bar.") (progress :initarg :progress :accessor progress :documentation "How far in the progress are we?") (pending :initarg :pending :accessor pending :documentation "How many raw units should be tracked in the next display update?")) (:default-initargs :progress-character #\= :character-count 50 :characters-so-far 0 :update-interval (floor internal-time-units-per-second 4) :last-update-time 0 :total 0 :progress 0 :pending 0)) (defgeneric start-display (progress-bar)) (defgeneric update-progress (progress-bar unit-count)) (defgeneric update-display (progress-bar)) (defgeneric finish-display (progress-bar)) (defgeneric elapsed-time (progress-bar)) (defgeneric units-per-second (progress-bar)) (defmethod start-display (progress-bar) (setf (last-update-time progress-bar) (get-internal-real-time)) (setf (start-time progress-bar) (get-internal-real-time)) (fresh-line) (finish-output)) (defmethod update-display (progress-bar) (incf (progress progress-bar) (pending progress-bar)) (setf (pending progress-bar) 0) (setf (last-update-time progress-bar) (get-internal-real-time)) (let* ((showable (floor (character-count progress-bar) (/ (total progress-bar) (progress progress-bar)))) (needed (- showable (characters-so-far progress-bar)))) (setf (characters-so-far progress-bar) showable) (dotimes (i needed) (write-char (progress-character progress-bar))) (finish-output))) (defmethod update-progress (progress-bar unit-count) (incf (pending progress-bar) unit-count) (let ((now (get-internal-real-time))) (when (< (update-interval progress-bar) (- now (last-update-time progress-bar))) (update-display progress-bar)))) (defmethod finish-display (progress-bar) (update-display progress-bar) (setf (end-time progress-bar) (get-internal-real-time)) (terpri) (format t "~:D bytes in ~$ seconds (~$KB/sec)" (total progress-bar) (elapsed-time progress-bar) (/ (units-per-second progress-bar) 1024)) (finish-output)) (defmethod elapsed-time (progress-bar) (/ (- (end-time progress-bar) (start-time progress-bar)) internal-time-units-per-second)) (defmethod units-per-second (progress-bar) (if (plusp (elapsed-time progress-bar)) (/ (total progress-bar) (elapsed-time progress-bar)) 0)) (defun kb/sec (progress-bar) (/ (units-per-second progress-bar) 1024)) (defparameter *uncertain-progress-chars* "?") (defclass uncertain-size-progress-bar (progress-bar) ((progress-char-index :initarg :progress-char-index :accessor progress-char-index) (units-per-char :initarg :units-per-char :accessor units-per-char)) (:default-initargs :total 0 :progress-char-index 0 :units-per-char (floor (expt 1024 2) 50))) (defmethod update-progress :after ((progress-bar uncertain-size-progress-bar) unit-count) (incf (total progress-bar) unit-count)) (defmethod progress-character ((progress-bar uncertain-size-progress-bar)) (let ((index (progress-char-index progress-bar))) (prog1 (char *uncertain-progress-chars* index) (setf (progress-char-index progress-bar) (mod (1+ index) (length *uncertain-progress-chars*)))))) (defmethod update-display ((progress-bar uncertain-size-progress-bar)) (setf (last-update-time progress-bar) (get-internal-real-time)) (multiple-value-bind (chars pend) (floor (pending progress-bar) (units-per-char progress-bar)) (setf (pending progress-bar) pend) (dotimes (i chars) (write-char (progress-character progress-bar)) (incf (characters-so-far progress-bar)) (when (<= (character-count progress-bar) (characters-so-far progress-bar)) (terpri) (setf (characters-so-far progress-bar) 0) (finish-output))) (finish-output))) (defun make-progress-bar (total) (if (or (not total) (zerop total)) (make-instance 'uncertain-size-progress-bar) (make-instance 'progress-bar :total total))) ;;; ;;; A simple HTTP client ;;; (in-package #:qlqs-http) ;;; Octet data (deftype octet () '(unsigned-byte 8)) (defun make-octet-vector (size) (make-array size :element-type 'octet :initial-element 0)) (defun octet-vector (&rest octets) (make-array (length octets) :element-type 'octet :initial-contents octets)) ;;; ASCII characters as integers (defun acode (char) (cond ((eql char :cr) 13) ((eql char :lf) 10) (t (let ((code (char-code char))) (if (<= 0 code 127) code (error "Character ~S is not in the ASCII character set" char)))))) (defvar *whitespace* (list (acode #\Space) (acode #\Tab) (acode :cr) (acode :lf))) (defun whitep (code) (member code *whitespace*)) (defun ascii-vector (string) (let ((vector (make-octet-vector (length string)))) (loop for char across string for code = (char-code char) for i from 0 if (< 127 code) do (error "Invalid character for ASCII -- ~A" char) else do (setf (aref vector i) code)) vector)) (defun ascii-subseq (vector start end) "Return a subseq of octet-specialized VECTOR as a string." (let ((string (make-string (- end start)))) (loop for i from 0 for j from start below end do (setf (char string i) (code-char (aref vector j)))) string)) (defun ascii-downcase (code) (if (<= 65 code 90) (+ code 32) code)) (defun ascii-equal (a b) (eql (ascii-downcase a) (ascii-downcase b))) (defmacro acase (value &body cases) (flet ((convert-case-keys (keys) (mapcar (lambda (key) (etypecase key (integer key) (character (char-code key)) (symbol (ecase key (:cr 13) (:lf 10) ((t) t))))) (if (consp keys) keys (list keys))))) `(case ,value ,@(mapcar (lambda (case) (destructuring-bind (keys &rest body) case `(,(if (eql keys t) t (convert-case-keys keys)) ,@body))) cases)))) ;;; Pattern matching (for finding headers) (defclass matcher () ((pattern :initarg :pattern :reader pattern) (pos :initform 0 :accessor match-pos) (matchedp :initform nil :accessor matchedp))) (defun reset-match (matcher) (setf (match-pos matcher) 0 (matchedp matcher) nil)) (define-condition match-failure (error) ()) (defun match (matcher input &key (start 0) end error) (let ((i start) (end (or end (length input))) (match-end (length (pattern matcher)))) (with-slots (pattern pos) matcher (loop (cond ((= pos match-end) (let ((match-start (- i pos))) (setf pos 0) (setf (matchedp matcher) t) (return (values match-start (+ match-start match-end))))) ((= i end) (return nil)) ((= (aref pattern pos) (aref input i)) (incf i) (incf pos)) (t (if error (error 'match-failure) (if (zerop pos) (incf i) (setf pos 0))))))))) (defun ascii-matcher (string) (make-instance 'matcher :pattern (ascii-vector string))) (defun octet-matcher (&rest octets) (make-instance 'matcher :pattern (apply 'octet-vector octets))) (defun acode-matcher (&rest codes) (make-instance 'matcher :pattern (make-array (length codes) :element-type 'octet :initial-contents (mapcar 'acode codes)))) ;;; "Connection Buffers" are a kind of callback-driven, ;;; pattern-matching chunky stream. Callbacks can be called for a ;;; certain number of octets or until one or more patterns are seen in ;;; the input. cbufs automatically refill themselves from a ;;; connection as needed. (defvar *cbuf-buffer-size* 8192) (define-condition end-of-data (error) ()) (defclass cbuf () ((data :initarg :data :accessor data) (connection :initarg :connection :accessor connection) (start :initarg :start :accessor start) (end :initarg :end :accessor end) (eofp :initarg :eofp :accessor eofp)) (:default-initargs :data (make-octet-vector *cbuf-buffer-size*) :connection nil :start 0 :end 0 :eofp nil) (:documentation "A CBUF is a connection buffer that keeps track of incoming data from a connection. Several functions make it easy to treat a CBUF as a kind of chunky, callback-driven stream.")) (define-condition cbuf-progress () ((size :initarg :size :accessor cbuf-progress-size :initform 0))) (defun call-processor (fun cbuf start end) (signal 'cbuf-progress :size (- end start)) (funcall fun (data cbuf) start end)) (defun make-cbuf (connection) (make-instance 'cbuf :connection connection)) (defun make-stream-writer (stream) "Create a callback for writing data to STREAM." (lambda (data start end) (write-sequence data stream :start start :end end))) (defgeneric size (cbuf) (:method ((cbuf cbuf)) (- (end cbuf) (start cbuf)))) (defgeneric emptyp (cbuf) (:method ((cbuf cbuf)) (zerop (size cbuf)))) (defgeneric refill (cbuf) (:method ((cbuf cbuf)) (when (eofp cbuf) (error 'end-of-data)) (setf (start cbuf) 0) (setf (end cbuf) (read-octets (data cbuf) (connection cbuf))) (cond ((emptyp cbuf) (setf (eofp cbuf) t) (error 'end-of-data)) (t (size cbuf))))) (defun process-all (fun cbuf) (unless (emptyp cbuf) (call-processor fun cbuf (start cbuf) (end cbuf)))) (defun multi-cmatch (matchers cbuf) (let (start end) (dolist (matcher matchers (values start end)) (multiple-value-bind (s e) (match matcher (data cbuf) :start (start cbuf) :end (end cbuf)) (when (and s (or (null start) (< s start))) (setf start s end e)))))) (defun cmatch (matcher cbuf) (if (consp matcher) (multi-cmatch matcher cbuf) (match matcher (data cbuf) :start (start cbuf) :end (end cbuf)))) (defun call-until-end (fun cbuf) (handler-case (loop (process-all fun cbuf) (refill cbuf)) (end-of-data () (return-from call-until-end)))) (defun show-cbuf (context cbuf) (format t "cbuf: ~A ~D - ~D~%" context (start cbuf) (end cbuf))) (defun call-for-n-octets (n fun cbuf) (let ((remaining n)) (loop (when (<= remaining (size cbuf)) (let ((end (+ (start cbuf) remaining))) (call-processor fun cbuf (start cbuf) end) (setf (start cbuf) end) (return))) (process-all fun cbuf) (decf remaining (size cbuf)) (refill cbuf)))) (defun call-until-matching (matcher fun cbuf) (loop (multiple-value-bind (start end) (cmatch matcher cbuf) (when start (call-processor fun cbuf (start cbuf) end) (setf (start cbuf) end) (return))) (process-all fun cbuf) (refill cbuf))) (defun ignore-data (data start end) (declare (ignore data start end))) (defun skip-until-matching (matcher cbuf) (call-until-matching matcher 'ignore-data cbuf)) ;;; Creating HTTP requests as octet buffers (defclass octet-sink () ((storage :initarg :storage :accessor storage)) (:default-initargs :storage (make-array 1024 :element-type 'octet :fill-pointer 0 :adjustable t)) (:documentation "A simple stream-like target for collecting octets.")) (defun add-octet (octet sink) (vector-push-extend octet (storage sink))) (defun add-octets (octets sink &key (start 0) end) (setf end (or end (length octets))) (loop for i from start below end do (add-octet (aref octets i) sink))) (defun add-string (string sink) (loop for char across string for code = (char-code char) do (add-octet code sink))) (defun add-strings (sink &rest strings) (mapc (lambda (string) (add-string string sink)) strings)) (defun add-newline (sink) (add-octet 13 sink) (add-octet 10 sink)) (defun sink-buffer (sink) (subseq (storage sink) 0)) (defvar *proxy-url* nil) (defun full-proxy-path (host port path) (format nil "~:[http~;https~]://~A~:[:~D~;~*~]~A" (= port 443) host (or (= port 80) (= port 443)) port path)) (defun make-request-buffer (host port path &key (method "GET")) (setf method (string method)) (when *proxy-url* (setf path (full-proxy-path host port path))) (let ((sink (make-instance 'octet-sink))) (flet ((add-line (&rest strings) (apply #'add-strings sink strings) (add-newline sink))) (add-line method " " path " HTTP/1.1") (add-line "Host: " host (if (= port 80) "" (format nil ":~D" port))) (add-line "Connection: close") ;; FIXME: get this version string from somewhere else. (add-line "User-Agent: quicklisp-alpha-bootstrap/" qlqs-info:*version*) (add-newline sink) (sink-buffer sink)))) (defun sink-until-matching (matcher cbuf) (let ((sink (make-instance 'octet-sink))) (call-until-matching matcher (lambda (buffer start end) (add-octets buffer sink :start start :end end)) cbuf) (sink-buffer sink))) ;;; HTTP headers (defclass header () ((data :initarg :data :accessor data) (status :initarg :status :accessor status) (name-starts :initarg :name-starts :accessor name-starts) (name-ends :initarg :name-ends :accessor name-ends) (value-starts :initarg :value-starts :accessor value-starts) (value-ends :initarg :value-ends :accessor value-ends))) (defmethod print-object ((header header) stream) (print-unreadable-object (header stream :type t) (prin1 (status header) stream))) (defun matches-at (pattern target pos) (= (mismatch pattern target :start2 pos) (length pattern))) (defun header-value-indexes (field-name header) (loop with data = (data header) with pattern = (ascii-vector (string-downcase field-name)) for start across (name-starts header) for i from 0 when (matches-at pattern data start) return (values (aref (value-starts header) i) (aref (value-ends header) i)))) (defun ascii-header-value (field-name header) (multiple-value-bind (start end) (header-value-indexes field-name header) (when start (ascii-subseq (data header) start end)))) (defun all-field-names (header) (map 'list (lambda (start end) (ascii-subseq (data header) start end)) (name-starts header) (name-ends header))) (defun headers-alist (header) (mapcar (lambda (name) (cons name (ascii-header-value name header))) (all-field-names header))) (defmethod describe-object :after ((header header) stream) (format stream "~&Decoded headers:~% ~S~%" (headers-alist header))) (defun content-length (header) (let ((field-value (ascii-header-value "content-length" header))) (when field-value (let ((value (ignore-errors (parse-integer field-value)))) (or value (error "Content-Length header field value is not a number -- ~A" field-value)))))) (defun chunkedp (header) (string= (ascii-header-value "transfer-encoding" header) "chunked")) (defun location (header) (ascii-header-value "location" header)) (defun status-code (vector) (let* ((space (position (acode #\Space) vector)) (c1 (- (aref vector (incf space)) 48)) (c2 (- (aref vector (incf space)) 48)) (c3 (- (aref vector (incf space)) 48))) (+ (* c1 100) (* c2 10) (* c3 1)))) (defun force-downcase-field-names (header) (loop with data = (data header) for start across (name-starts header) for end across (name-ends header) do (loop for i from start below end for code = (aref data i) do (setf (aref data i) (ascii-downcase code))))) (defun skip-white-forward (pos vector) (position-if-not 'whitep vector :start pos)) (defun skip-white-backward (pos vector) (let ((nonwhite (position-if-not 'whitep vector :end pos :from-end t))) (if nonwhite (1+ nonwhite) pos))) (defun contract-field-value-indexes (header) "Header field values exclude leading and trailing whitespace; adjust the indexes in the header accordingly." (loop with starts = (value-starts header) with ends = (value-ends header) with data = (data header) for i from 0 for start across starts for end across ends do (setf (aref starts i) (skip-white-forward start data)) (setf (aref ends i) (skip-white-backward end data)))) (defun next-line-pos (vector) (let ((pos 0)) (labels ((finish (&optional (i pos)) (return-from next-line-pos i)) (after-cr (code) (acase code (:lf (finish pos)) (t (finish (1- pos))))) (pending (code) (acase code (:cr #'after-cr) (:lf (finish pos)) (t #'pending)))) (let ((state #'pending)) (loop (setf state (funcall state (aref vector pos))) (incf pos)))))) (defun make-hvector () (make-array 16 :fill-pointer 0 :adjustable t)) (defun process-header (vector) "Create a HEADER instance from the octet data in VECTOR." (let* ((name-starts (make-hvector)) (name-ends (make-hvector)) (value-starts (make-hvector)) (value-ends (make-hvector)) (header (make-instance 'header :data vector :status 999 :name-starts name-starts :name-ends name-ends :value-starts value-starts :value-ends value-ends)) (mark nil) (pos (next-line-pos vector))) (unless pos (error "Unable to process HTTP header")) (setf (status header) (status-code vector)) (labels ((save (value vector) (vector-push-extend value vector)) (mark () (setf mark pos)) (clear-mark () (setf mark nil)) (finish () (if mark (save mark value-ends) (save pos value-ends)) (force-downcase-field-names header) (contract-field-value-indexes header) (return-from process-header header)) (in-new-line (code) (acase code ((#\Tab #\Space) (setf mark nil) #'in-value) (t (when mark (save mark value-ends)) (clear-mark) (save pos name-starts) (in-name code)))) (after-cr (code) (acase code (:lf #'in-new-line) (t (in-new-line code)))) (pending-value (code) (acase code ((#\Tab #\Space) #'pending-value) (:cr #'after-cr) (:lf #'in-new-line) (t (save pos value-starts) #'in-value))) (in-name (code) (acase code (#\: (save pos name-ends) (save (1+ pos) value-starts) #'in-value) ((:cr :lf) (finish)) ((#\Tab #\Space) (error "Unexpected whitespace in header field name")) (t (unless (<= 0 code 127) (error "Unexpected non-ASCII header field name")) #'in-name))) (in-value (code) (acase code (:lf (mark) #'in-new-line) (:cr (mark) #'after-cr) (t #'in-value)))) (let ((state #'in-new-line)) (loop (incf pos) (when (<= (length vector) pos) (error "No header found in response")) (setf state (funcall state (aref vector pos)))))))) ;;; HTTP URL parsing (defclass url () ((hostname :initarg :hostname :accessor hostname :initform nil) (port :initarg :port :accessor port :initform 80) (path :initarg :path :accessor path :initform "/"))) (defun parse-urlstring (urlstring) (setf urlstring (string-trim " " urlstring)) (let* ((pos (mismatch urlstring "http://" :test 'char-equal)) (mark pos) (url (make-instance 'url))) (labels ((save () (subseq urlstring mark pos)) (mark () (setf mark pos)) (finish () (return-from parse-urlstring url)) (hostname-char-p (char) (position char "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-_." :test 'char-equal)) (at-start (char) (case char (#\/ (setf (port url) nil) (mark) #'in-path) (t #'in-host))) (in-host (char) (case char ((#\/ :end) (setf (hostname url) (save)) (mark) #'in-path) (#\: (setf (hostname url) (save)) (mark) #'in-port) (t (unless (hostname-char-p char) (error "~S is not a valid URL" urlstring)) #'in-host))) (in-port (char) (case char ((#\/ :end) (setf (port url) (parse-integer urlstring :start (1+ mark) :end pos)) (mark) #'in-path) (t (unless (digit-char-p char) (error "Bad port in URL ~S" urlstring)) #'in-port))) (in-path (char) (case char ((#\# :end) (setf (path url) (save)) (finish))) #'in-path)) (let ((state #'at-start)) (loop (when (<= (length urlstring) pos) (funcall state :end) (finish)) (setf state (funcall state (aref urlstring pos))) (incf pos)))))) (defun url (thing) (if (stringp thing) (parse-urlstring thing) thing)) (defgeneric request-buffer (method url) (:method (method url) (setf url (url url)) (make-request-buffer (hostname url) (port url) (path url) :method method))) (defun urlstring (url) (format nil "~@[http://~A~]~@[:~D~]~A" (hostname url) (and (/= 80 (port url)) (port url)) (path url))) (defmethod print-object ((url url) stream) (print-unreadable-object (url stream :type t) (prin1 (urlstring url) stream))) (defun merge-urls (url1 url2) (setf url1 (url url1)) (setf url2 (url url2)) (make-instance 'url :hostname (or (hostname url1) (hostname url2)) :port (or (port url1) (port url2)) :path (or (path url1) (path url2)))) ;;; Requesting an URL and saving it to a file (defparameter *maximum-redirects* 10) (defvar *default-url-defaults* (url "http://src.quicklisp.org/")) (defun read-http-header (cbuf) (let ((header-data (sink-until-matching (list (acode-matcher :lf :lf) (acode-matcher :cr :cr) (acode-matcher :cr :lf :cr :lf)) cbuf))) (process-header header-data))) (defun read-chunk-header (cbuf) (let* ((header-data (sink-until-matching (acode-matcher :cr :lf) cbuf)) (end (or (position (acode :cr) header-data) (position (acode #\;) header-data)))) (values (parse-integer (ascii-subseq header-data 0 end) :radix 16)))) (defun save-chunk-response (stream cbuf) "For a chunked response, read all chunks and write them to STREAM." (let ((fun (make-stream-writer stream)) (matcher (acode-matcher :cr :lf))) (loop (let ((chunk-size (read-chunk-header cbuf))) (when (zerop chunk-size) (return)) (call-for-n-octets chunk-size fun cbuf) (skip-until-matching matcher cbuf))))) (defun save-response (file header cbuf) (with-open-file (stream file :direction :output :if-exists :supersede :element-type 'octet) (let ((content-length (content-length header))) (cond ((chunkedp header) (save-chunk-response stream cbuf)) (content-length (call-for-n-octets content-length (make-stream-writer stream) cbuf)) (t (call-until-end (make-stream-writer stream) cbuf)))))) (defun call-with-progress-bar (size fun) (let ((progress-bar (make-progress-bar size))) (start-display progress-bar) (flet ((update (condition) (update-progress progress-bar (cbuf-progress-size condition)))) (handler-bind ((cbuf-progress #'update)) (funcall fun))) (finish-display progress-bar))) (defun fetch (url file &key (follow-redirects t) quietly (maximum-redirects *maximum-redirects*)) "Request URL and write the body of the response to FILE." (setf url (merge-urls url *default-url-defaults*)) (setf file (merge-pathnames file)) (let ((redirect-count 0) (original-url url) (connect-url (or (url *proxy-url*) url)) (stream (if quietly (make-broadcast-stream) *trace-output*))) (loop (when (<= maximum-redirects redirect-count) (error "Too many redirects for ~A" original-url)) (with-connection (connection (hostname connect-url) (port connect-url)) (let ((cbuf (make-instance 'cbuf :connection connection)) (request (request-buffer "GET" url))) (write-octets request connection) (let ((header (read-http-header cbuf))) (loop while (= (status header) 100) do (setf header (read-http-header cbuf))) (cond ((= (status header) 200) (let ((size (content-length header))) (format stream "~&; Fetching ~A~%" url) (if (and (numberp size) (plusp size)) (format stream "; ~$KB~%" (/ size 1024)) (format stream "; Unknown size~%")) (if quietly (save-response file header cbuf) (call-with-progress-bar (content-length header) (lambda () (save-response file header cbuf)))))) ((not (<= 300 (status header) 399)) (error "Unexpected status for ~A: ~A" url (status header)))) (if (and follow-redirects (<= 300 (status header) 399)) (let ((new-urlstring (ascii-header-value "location" header))) (when (not new-urlstring) (error "Redirect code ~D received, but no Location: header" (status header))) (incf redirect-count) (setf url (merge-urls new-urlstring url)) (format stream "~&; Redirecting to ~A~%" url)) (return (values header (and file (probe-file file))))))))))) ;;; A primitive tar unpacker (in-package #:qlqs-minitar) (defun make-block-buffer () (make-array 512 :element-type '(unsigned-byte 8) :initial-element 0)) (defun skip-n-blocks (n stream) (let ((block (make-block-buffer))) (dotimes (i n) (read-sequence block stream)))) (defun ascii-subseq (vector start end) (let ((string (make-string (- end start)))) (loop for i from 0 for j from start below end do (setf (char string i) (code-char (aref vector j)))) string)) (defun block-asciiz-string (block start length) (let* ((end (+ start length)) (eos (or (position 0 block :start start :end end) end))) (ascii-subseq block start eos))) (defun prefix (header) (when (plusp (aref header 345)) (block-asciiz-string header 345 155))) (defun name (header) (block-asciiz-string header 0 100)) (defun payload-size (header) (values (parse-integer (block-asciiz-string header 124 12) :radix 8))) (defun nth-block (n file) (with-open-file (stream file :element-type '(unsigned-byte 8)) (let ((block (make-block-buffer))) (skip-n-blocks (1- n) stream) (read-sequence block stream) block))) (defun payload-type (code) (case code (0 :file) (48 :file) (53 :directory) (t :unsupported))) (defun full-path (header) (let ((prefix (prefix header)) (name (name header))) (if prefix (format nil "~A/~A" prefix name) name))) (defun save-file (file size stream) (multiple-value-bind (full-blocks partial) (truncate size 512) (ensure-directories-exist file) (with-open-file (outstream file :direction :output :if-exists :supersede :element-type '(unsigned-byte 8)) (let ((block (make-block-buffer))) (dotimes (i full-blocks) (read-sequence block stream) (write-sequence block outstream)) (when (plusp partial) (read-sequence block stream) (write-sequence block outstream :end partial)))))) (defun unpack-tarball (tarfile &key (directory *default-pathname-defaults*)) (let ((block (make-block-buffer))) (with-open-file (stream tarfile :element-type '(unsigned-byte 8)) (loop (let ((size (read-sequence block stream))) (when (zerop size) (return)) (unless (= size 512) (error "Bad size on tarfile")) (when (every #'zerop block) (return)) (let* ((payload-code (aref block 156)) (payload-type (payload-type payload-code)) (tar-path (full-path block)) (full-path (merge-pathnames tar-path directory)) (payload-size (payload-size block))) (case payload-type (:file (save-file full-path payload-size stream)) (:directory (ensure-directories-exist full-path)) (t (warn "Unknown tar block payload code -- ~D" payload-code) (skip-n-blocks (ceiling (payload-size block) 512) stream))))))))) (defun contents (tarfile) (let ((block (make-block-buffer)) (result '())) (with-open-file (stream tarfile :element-type '(unsigned-byte 8)) (loop (let ((size (read-sequence block stream))) (when (zerop size) (return (nreverse result))) (unless (= size 512) (error "Bad size on tarfile")) (when (every #'zerop block) (return (nreverse result))) (let* ((payload-type (payload-type (aref block 156))) (tar-path (full-path block)) (payload-size (payload-size block))) (skip-n-blocks (ceiling payload-size 512) stream) (case payload-type (:file (push tar-path result)) (:directory (push tar-path result))))))))) ;;; ;;; The actual bootstrapping work ;;; (in-package #:quicklisp-quickstart) (defvar *home* (merge-pathnames (make-pathname :directory '(:relative "quicklisp")) (user-homedir-pathname))) (defun qmerge (pathname) (merge-pathnames pathname *home*)) (defun renaming-fetch (url file) (let ((tmpfile (qmerge "tmp/fetch.dat"))) (fetch url tmpfile) (rename-file tmpfile file))) (defvar *quickstart-parameters* nil "This plist is populated with parameters that may carry over to the initial configuration of the client, e.g. :proxy-url or :initial-dist-url") (defvar *quicklisp-hostname* "alpha.quicklisp.org") (defvar *client-info-url* (format nil "http://~A/client/quicklisp.sexp" *quicklisp-hostname*)) (defclass client-info () ((setup-url :reader setup-url :initarg :setup-url) (asdf-url :reader asdf-url :initarg :asdf-url) (client-tar-url :reader client-tar-url :initarg :client-tar-url) (version :reader version :initarg :version) (plist :reader plist :initarg :plist) (source-file :reader source-file :initarg :source-file))) (defmethod print-object ((client-info client-info) stream) (print-unreadable-object (client-info stream :type t) (prin1 (version client-info) stream))) (defun safely-read (stream) (let ((*read-eval* nil)) (read stream))) (defun fetch-client-info-plist (url) "Fetch and return the client info data at URL." (let ((local-client-info-file (qmerge "tmp/client-info.sexp"))) (ensure-directories-exist local-client-info-file) (renaming-fetch url local-client-info-file) (with-open-file (stream local-client-info-file) (list* :source-file local-client-info-file (safely-read stream))))) (defun fetch-client-info (url) (let ((plist (fetch-client-info-plist url))) (destructuring-bind (&key setup asdf client-tar version source-file &allow-other-keys) plist (unless (and setup asdf client-tar version) (error "Invalid data from client info URL -- ~A" url)) (make-instance 'client-info :setup-url (getf setup :url) :asdf-url (getf asdf :url) :client-tar-url (getf client-tar :url) :version version :plist plist :source-file source-file)))) (defun client-info-url-from-version (version) (format nil "http://~A/client/~A/client-info.sexp" *quicklisp-hostname* version)) (defun distinfo-url-from-version (version) (format nil "http://~A/dist/~A/distinfo.txt" *quicklisp-hostname* version)) (defvar *help-message* (format nil "~&~% ==== quicklisp quickstart install help ====~%~% ~ quicklisp-quickstart:install can take the following ~ optional arguments:~%~% ~ :path \"/path/to/installation/\"~%~% ~ :proxy \"http://your.proxy:port/\"~%~% ~ :client-url ~%~% ~ :client-version ~%~% ~ :dist-url ~%~% ~ :dist-version ~%~%")) (defvar *after-load-message* (format nil "~&~% ==== quicklisp quickstart ~A loaded ====~%~% ~ To continue with installation, evaluate: (quicklisp-quickstart:install)~%~% ~ For installation options, evaluate: (quicklisp-quickstart:help)~%~%" qlqs-info:*version*)) (defvar *after-initial-setup-message* (with-output-to-string (*standard-output*) (format t "~&~% ==== quicklisp installed ====~%~%") (format t " To load a system, use: (ql:quickload \"system-name\")~%~%") (format t " To find systems, use: (ql:system-apropos \"term\")~%~%") (format t " To load Quicklisp every time you start Lisp, use: (ql:add-to-init-file)~%~%") (format t " For more information, see http://www.quicklisp.org/beta/~%~%"))) (defun initial-install (&key (client-url *client-info-url*) dist-url) (setf *quickstart-parameters* (list :proxy-url *proxy-url* :initial-dist-url dist-url)) (ensure-directories-exist (qmerge "tmp/")) (let ((client-info (fetch-client-info client-url)) (tmptar (qmerge "tmp/quicklisp.tar")) (setup (qmerge "setup.lisp")) (asdf (qmerge "asdf.lisp"))) (renaming-fetch (client-tar-url client-info) tmptar) (unpack-tarball tmptar :directory (qmerge "./")) (renaming-fetch (setup-url client-info) setup) (renaming-fetch (asdf-url client-info) asdf) (rename-file (source-file client-info) (qmerge "client-info.sexp")) (load setup :verbose nil :print nil) (write-string *after-initial-setup-message*) (finish-output))) (defun help () (write-string *help-message*) t) (defun non-empty-file-namestring (pathname) (let ((string (file-namestring pathname))) (unless (or (null string) (equal string "")) string))) (defun install (&key ((:path *home*) *home*) ((:proxy *proxy-url*) *proxy-url*) client-url client-version dist-url dist-version) (setf *home* (merge-pathnames *home* (truename *default-pathname-defaults*))) (let ((name (non-empty-file-namestring *home*))) (when name (warn "Making ~A part of the install pathname directory" name) ;; This corrects a pathname like "/foo/bar" to "/foo/bar/" and ;; "foo" to "foo/" (setf *home* (make-pathname :defaults *home* :directory (append (pathname-directory *home*) (list name)))))) (let ((setup-file (qmerge "setup.lisp"))) (when (probe-file setup-file) (multiple-value-bind (result proceed) (with-simple-restart (load-setup "Load ~S" setup-file) (error "Quicklisp has already been installed. Load ~S instead." setup-file)) (declare (ignore result)) (when proceed (return-from install (load setup-file)))))) (if (find-package '#:ql) (progn (write-line "!!! Quicklisp has already been set up. !!!") (write-string *after-initial-setup-message*) t) (call-with-quiet-compilation (lambda () (let ((client-url (or client-url (and client-version (client-info-url-from-version client-version)) *client-info-url*)) ;; It's ok for dist-url to be nil; there's a default in ;; the client (dist-url (or dist-url (and dist-version (distinfo-url-from-version dist-version))))) (initial-install :client-url client-url :dist-url dist-url)))))) (write-string *after-load-message*) ;;; End of quicklisp.lisp