diff --git a/.gitignore b/.gitignore
index 99799bf..e68c5e3 100644
--- a/.gitignore
+++ b/.gitignore
@@ -2,9 +2,14 @@
 !.gitignore
 !.gitmodules
 
+!.xinitrc
+!.xmodmap
+
 !scripts
 !scripts/*
 
+!quicklisp.lisp
+
 !.vimrc
 
 !.zshrc
diff --git a/.stumpwm.d/README.md b/.stumpwm.d/README.md
index f8726c9..1a2bebf 100644
--- a/.stumpwm.d/README.md
+++ b/.stumpwm.d/README.md
@@ -24,7 +24,12 @@ Then in the REPL:
 And install some packages from quicklisp:
 
 ```common-lisp
-(ql:quickload '(:clx :cl-ppcre :alexandria))
+(ql:quickload '(:clx :cl-ppcre :alexandria :sb-cltl :swank))
+```
+
+And in your .xinitrc:
+```
+export SBCL_HOME=/usr/lib/sbcl
 ```
 
 ### Other
diff --git a/.xinitrc b/.xinitrc
new file mode 100644
index 0000000..2ca0232
--- /dev/null
+++ b/.xinitrc
@@ -0,0 +1,25 @@
+#!/bin/sh
+
+export _JAVA_AWT_WM_NONREPARENTING=1
+export SBCL_HOME=/usr/lib/sbcl
+export _QWT_TOOLKT=MToolkit
+
+exec wmname compiz &
+
+exec emacs-keys-everywhere &
+exec picom -b --vsync --backend glx &
+exec xmodmap ~/.xmodmap &
+
+exec xsetroot -cursor_name left_ptr &
+exec xset s off &
+exec xset b off &
+exec xset -dpms &
+
+
+exec ~/.screenlayout/run.sh &
+
+exec feh --bg-fill --randomize ~/Wallpapers/*
+
+exec sleep 1s && dunst &
+
+/usr/local/bin/stumpwm
diff --git a/.xmodmap b/.xmodmap
new file mode 100644
index 0000000..f640019
--- /dev/null
+++ b/.xmodmap
@@ -0,0 +1,7 @@
+clear Lock
+remove Lock = Caps_Lock
+remove Control = Control_L
+keysym Control_L = Escape
+keysym Caps_Lock = Control_L
+add Control = Control_L
+add Lock = Caps_Lock
diff --git a/.zshrc b/.zshrc
index 7b9c956..7a0847a 100644
--- a/.zshrc
+++ b/.zshrc
@@ -26,9 +26,6 @@ alias gsh="git stash"
 alias gl="git log"
 
 alias sbcl="rlwrap sbcl"
-# Muscle memory is killing me man
-alias vim="nvim"
-alias startx="sway"
 
 export TERM=xterm-256color
 
diff --git a/quicklisp.lisp b/quicklisp.lisp
new file mode 100644
index 0000000..6cda472
--- /dev/null
+++ b/quicklisp.lisp
@@ -0,0 +1,1757 @@
+;;;;
+;;;; 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