Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

starting to be real

  • Loading branch information...
commit d6dc42b150f06b54397543ee838e3f47f5851654 1 parent 88b70fb
@mtravers authored
View
3  .gitignore
@@ -0,0 +1,3 @@
+quicklisp
+*.fasl
+*#
View
7 README.md
@@ -1,6 +1,11 @@
-Heroku buildpack: Hello
+Heroku buildpack: CL
=======================
+Attempt at a buildpack for Common Lisp (using OpenMCL). Work in progress.
+
+
+
+
This is an example [Heroku buildpack](http://devcenter.heroku.com/articles/buildpacks).
Usage
View
65 bin/compile
@@ -1,16 +1,61 @@
-#!/bin/sh
+#!/usr/bin/env bash
+# bin/compile <build-dir> <cache-dir>
-indent() {
- sed -u 's/^/ /'
+mktmpdir() {
+ dir=$(mktemp -t node-$1-XXXX)
+ rm -rf $dir
+ mkdir -p $dir
+ echo $dir
}
+function indent() {
+ c='s/^/ /'
+ case $(uname) in
+ Darwin) sed -l "$c";;
+ *) sed -u "$c";;
+ esac
+}
+
+S3_BUCKET="cl-heroku"
+CCL_PACKAGE="http://${S3_BUCKET}.s3.amazonaws.com/ccl-1.7.tgz"
+
+# parse and derive params
+BUILD_DIR=$1
+CACHE_DIR=$2
+CACHE_QUICKLISP_DIR="$CACHE_DIR/quicklisp/"
+BUILD_QUICKLISP_DIR="$BUILD_DIR/quicklisp/"
+
+CCL_DIR="$(mktmpdir ccl)"
+
+# don't we only want to do this if not there?
+echo "-----> Fetching ccl"
+mkdir -p $CCL_DIR && curl $CCL_PACKAGE -s -o - | tar xzf - -C $CCL_DIR
+
+# add to slug
+cp -r $CCL_DIR $BUILD_DIR/ccl
+
+echo echo "ccl installed" | indent
-echo "-----> Found a hello.txt"
+# setting up paths for building
+
+# unpack existing cache
+# nodejs is more elaborate; this ought work
+if [ -d $CACHE_QUICKLISP_DIR ]; then
+
+ cp -r $CACHE_QUICKLISP_DIR $BUILD_QUICKLISP_DIR
-# if hello.txt is empty, abort the build
-if [ ! -s $1/hello.txt ]; then
- echo "hello.txt was empty" | indent
- exit 1
fi
-# replace hello with goodbye in a new file
-cat $1/hello.txt | sed -e "s/[Hh]ello/Goodbye/g" > $1/goodbye.txt
+echo "-----> Installing dependencies with quicklisp"
+
+# run lisp to load quicklisp packages
+ccl/scripts/ccl -l compile.lisp
+
+echo "dependencies installed" | indent
+
+# copy quicklisp back to cache
+if [ -d $CACHE_QUICKLISP_DIR ]; then
+
+ rm -rf $CACHE_QUICKLISP_DIR
+ cp -r $BUILD_QUICKLISP_DIR $CACHE_QUICKLISP_DIR
+
+fi
View
6 bin/detect
@@ -1,8 +1,8 @@
#!/bin/sh
-# this pack is valid for apps with a hello.txt in the root
-if [ -f $1/hello.txt ]; then
- echo "GoodbyeFramework"
+# this pack is valid for apps with a setup.lisp in the root
+if [ -f $1/setup.lisp ]; then
+ echo "CLFramework"
exit 0
else
exit 1
View
2  bin/release
@@ -1,5 +1,7 @@
#!/bin/sh
+
+
cat << EOF
---
addons:
View
10 bin/scrap
@@ -0,0 +1,10 @@
+# get patched aserve
+if [ -d $CACHE_DIR/repos/portableaserve ]; then
+ pushd $CACHE_DIR/repos/portableaserve
+ git pull
+ popd
+else
+ pushd $CACHE_DIR/repos
+ git clone git://github.com/mtravers/portableaserve.git
+ popd
+fi
View
14 example.asd
@@ -0,0 +1,14 @@
+(in-package :asdf)
+
+(defsystem :example
+ :name "example"
+ :description "Example cl-heroku application"
+ :depends-on (:aserve :wuwei)
+ :components
+ ((:static-file "example.asd")
+ (:module :src
+ :serial t
+ :components
+ ((:file "hello-world"))
+ )))
+
View
1,580 lib/quicklisp.lisp
@@ -0,0 +1,1580 @@
+;;;;
+;;;; 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-impl
+ (:use #:cl)
+ (:export #:*implementation*)
+ (:export #:definterface
+ #:defimplementation)
+ (:export #:lisp
+ #:abcl
+ #:allegro
+ #:ccl
+ #:clisp
+ #:cmucl
+ #:cormanlisp
+ #:ecl
+ #:gcl
+ #:lispworks
+ #: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 #:tarball-contents
+ #: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))
+
+;;; 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))
+
+;;;
+;;; 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 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 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
+ :read-timeout nil
+ :element-type '(unsigned-byte 8)
+ :timeout 5))
+ (: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/2011103100")
+ (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 *asdf-url* "http://beta.quicklisp.org/quickstart/asdf.lisp")
+(defvar *quicklisp-tar-url* "http://beta.quicklisp.org/quickstart/quicklisp.tar")
+(defvar *setup-url* "http://beta.quicklisp.org/quickstart/setup.lisp")
+(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/\"~%~%"))
+(defvar *after-load-message*
+ (format nil "~&~% ==== quicklisp quickstart loaded ====~%~% ~
+ To continue with installation, evaluate: (quicklisp-quickstart:install)~%~% ~
+ For installation options, evaluate: (quicklisp-quickstart:help)~%~%"))
+
+(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 ()
+ (ensure-directories-exist (qmerge "tmp/"))
+ (ensure-directories-exist (qmerge "quicklisp/"))
+ (renaming-fetch *asdf-url* (qmerge "asdf.lisp"))
+ (let ((tmptar (qmerge "tmp/quicklisp.tar")))
+ (renaming-fetch *quicklisp-tar-url* tmptar)
+ (unpack-tarball tmptar :directory (qmerge "./")))
+ (renaming-fetch *setup-url* (qmerge "setup.lisp"))
+ (load (qmerge "setup.lisp"))
+ (write-string *after-initial-setup-message*)
+ (finish-output))
+
+(defun help ()
+ (write-string *help-message*)
+ t)
+
+(defun install (&key ((:path *home*) *home*)
+ ((:proxy *proxy-url*) *proxy-url*))
+ (setf *home* (merge-pathnames *home*))
+ (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 #'initial-install)))
+
+;;; Try to canonicalize to an absolute pathname; helps on Lisps where
+;;; *default-pathname-defaults* isn't an absolute pathname at startup
+;;; (e.g. CCL, CMUCL)
+(setf *default-pathname-defaults* (truename *default-pathname-defaults*))
+
+(write-string *after-load-message*)
+
+;;; End of quicklisp.lisp
View
5 setup/compile.lisp
@@ -0,0 +1,5 @@
+(in-package :cl-user)
+
+(load (make-pathname :defaults *load-pathname* :name "setup"))
+
+(ql:quickload *app-name*)
View
23 setup/setup.lisp
@@ -0,0 +1,23 @@
+(in-package :cl-user)
+
+;;; Customize
+
+(defvar *app-name* "example")
+
+;;; Standard
+
+(defvar *app-home* (butlast (pathname-directory *load-pathname*)))
+
+(if (probe-file (make-pathname :directory (append *app-home* '("quicklisp")) :defaults "setup.lisp"))
+ (load (make-pathname :directory (append *app-home* '("quicklisp")) :defaults "setup.lisp"))
+ (progn
+ (load (make-pathname :directory (append *app-home* '("lib")) :defaults "quicklisp.lisp"))
+; (quicklisp-quickstart:install :path (make-pathname :directory (append *app-home* '("quicklisp"))))
+ (funcall (symbol-function (find-symbol "INSTALL" (find-package "QUICKLISP-QUICKSTART")))
+ (make-pathname :directory (append *app-home* '("quicklisp"))))
+ ))
+
+(require :asdf)
+(load (make-pathname :directory *app-home* :name *app-name* :type "asd"))
+
+
View
8 src/hello-world.lisp
@@ -0,0 +1,8 @@
+(in-package :cl-user)
+
+(net.aserve:publish :path "/hello"
+ :function #'(lambda (req ent)
+ (net.aserve:html
+ (:h1 "Hello World")
+ (:princ "You're on heroku (or not)"))))
+
Please sign in to comment.
Something went wrong with that request. Please try again.