1758 lines
56 KiB
Common Lisp
1758 lines
56 KiB
Common Lisp
;;;;
|
|
;;;; 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
|