;;;;
;;;; 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 <zach@quicklisp.org>
;;;;
(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-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* "beta.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 <url>~%~% ~
:client-version <version>~%~% ~
:dist-url <url>~%~% ~
:dist-version <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