Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Initial commit

  • Loading branch information...
commit 173f249bd6e09838e6e183434f98023507de4fdc 0 parents
@pereckerdal authored
Showing with 19,831 additions and 0 deletions.
  1. +23 −0 LICENSE
  2. +69 −0 ds/queue.scm
  3. +709 −0 ds/wt-tree.scm
  4. +56 −0 misc/al.scm
  5. +222 −0 misc/exception.scm
  6. +47 −0 misc/mailbox.scm
  7. +104 −0 misc/match.scm
  8. +165 −0 misc/optionals.scm
  9. +28 −0 misc/splice.scm
  10. +98 −0 misc/token-table.scm
  11. +185 −0 misc/u8v.scm
  12. +63 −0 misc/uuid.scm
  13. +1,084 −0 net/http-client.scm
  14. +386 −0 net/http-common.scm
  15. +498 −0 net/http-server.scm
  16. +133 −0 net/http-session.scm
  17. +51 −0 net/tcpip.scm
  18. +709 −0 net/uri.scm
  19. +205 −0 net/x-www-form-urlencoded.scm
  20. +281 −0 spork/block.scm
  21. +207 −0 spork/comet.scm
  22. +658 −0 spork/core.scm
  23. +39 −0 spork/counter.scm
  24. +97 −0 spork/file.scm
  25. +1,029 −0 spork/js.scm
  26. +824 −0 spork/widget.scm
  27. +1,722 −0 srfi/1.scm
  28. +2,029 −0 srfi/13.scm
  29. +826 −0 srfi/14.scm
  30. +43 −0 srfi/16.scm
  31. +1,487 −0 srfi/19.scm
  32. +172 −0 srfi/95.scm
  33. +363 −0 string/base64.scm
  34. +1,500 −0 string/digest.scm
  35. +784 −0 string/pregexp.scm
  36. +660 −0 string/sxml-to-xml.scm
  37. +240 −0 string/util.scm
  38. +2,035 −0 string/xml-to-sxml.scm
23 LICENSE
@@ -0,0 +1,23 @@
+Unless otherwise noted in the source files, they are released
+under the MIT license, as follows:
+
+Permission is hereby granted, free of charge, to any person
+obtaining a copy of this software and associated documentation
+files (the "Software"), to deal in the Software without
+restriction, including without limitation the rights to use,
+copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the
+Software is furnished to do so, subject to the following
+conditions:
+
+The above copyright notice and this permission notice shall be
+included in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
+OTHER DEALINGS IN THE SOFTWARE.
69 ds/queue.scm
@@ -0,0 +1,69 @@
+;;; A very simple first-in-last-out queue library. Right now the
+;;; implementation is list-based and relies on set-car!/set-cdr!. All
+;;; operations are constant time.
+;;;
+;;; Copyright (c) 2008 Per Eckerdal
+
+(declare (block)
+ (mostly-fixnum)
+ (standard-bindings)
+ (extended-bindings))
+
+(export make-queue
+ (rename: (q-size queue-size)
+ (q? queue?))
+ queue-push!
+ queue-pop!
+ queue-empty?
+ queue-empty!
+ queue-front)
+
+(define-type q
+ id: F71EB1A0-828C-48D5-80C3-1CF3628012F9
+
+ data
+ (end-cons unprintable:)
+ (size unprintable:))
+
+(define (make-end-cons)
+ (cons 'end '()))
+
+(define no-value (list 'no-value))
+
+(define (make-queue)
+ (let ((end-cons (make-end-cons)))
+ (make-q end-cons end-cons 0)))
+
+(define (queue-push! q elm)
+ (let ((new-end-cons (make-end-cons))
+ (old-end-cons (q-end-cons q)))
+ (set-car! old-end-cons elm)
+ (set-cdr! old-end-cons new-end-cons)
+ (q-size-set! q (+ 1 (q-size q)))
+ (q-end-cons-set! q new-end-cons)))
+
+(define (queue-pop! q)
+ (if (queue-empty? q)
+ (error "Queue is empty")
+ (let ((data (q-data q)))
+ (q-data-set! q (cdr data))
+ (q-size-set! q (- (q-size q) 1))
+ (car data))))
+
+(define queue-size q-size)
+
+(define (queue-empty? q)
+ (= 0 (q-size q)))
+
+(define (queue-empty! q)
+ (q-size-set! q 0)
+ (let ((end-cons (make-end-cons)))
+ (q-data-set! q end-cons)
+ (q-end-cons-set! q end-cons)))
+
+(define (queue-front q #!optional (default no-value))
+ (if (queue-empty? q)
+ (if (eq? default no-value)
+ (error "Queue is empty")
+ default)
+ (car (q-data q))))
709 ds/wt-tree.scm
@@ -0,0 +1,709 @@
+;;; "wttree.scm" Weight balanced trees -*-Scheme-*-
+;;; Copyright (c) 1993-1994 Stephen Adams
+;;;
+;;; References:
+;;;
+;;; Stephen Adams, Implemeting Sets Efficiently in a Functional
+;;; Language, CSTR 92-10, Department of Electronics and Computer
+;;; Science, University of Southampton, 1992
+;;;
+;;;
+;;; Copyright (c) 1993-94 Massachusetts Institute of Technology
+;;;
+;;; This material was developed by the Scheme project at the
+;;; Massachusetts Institute of Technology, Department of Electrical
+;;; Engineering and Computer Science. Permission to copy and modify
+;;; this software, to redistribute either the original software or a
+;;; modified version, and to use this software for any purpose is
+;;; granted, subject to the following restrictions and understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a) to
+;;; return to the MIT Scheme project any improvements or extensions
+;;; that they make, so that these may be included in future releases;
+;;; and (b) to inform MIT of noteworthy uses of this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with the
+;;; usual standards of acknowledging credit in academic research.
+;;;
+;;; 4. MIT has made no warranty or representation that the operation
+;;; of this software will be error-free, and MIT is under no
+;;; obligation to provide any services, by way of maintenance, update,
+;;; or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the Massachusetts
+;;; Institute of Technology nor of any adaptation thereof in any
+;;; advertising, promotional, or sales literature without prior
+;;; written consent from MIT in each case.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; Weight Balanced Binary Trees
+;;
+;;
+;;
+;; This file has been modified from the MIT-Scheme library version to
+;; make it more standard. The main changes are
+;;
+;; . The whole thing has been put in a LET as R4RS Scheme has no module
+;; system.
+;; . The MIT-Scheme define structure operations have been written out by
+;; hand.
+;;
+;; It has been tested on MIT-Scheme, scheme48 and scm4e1
+;;
+;; If your system has a compiler and you want this code to run fast, you
+;; should do whatever is necessary to inline all of the structure accessors.
+;;
+;; This is MIT-Scheme's way of saying that +, car etc should all be inlined.
+;;
+;;(declare (usual-integrations))
+
+(declare (block)
+ (mostly-fixnum)
+ (standard-bindings)
+ (extended-bindings))
+
+(export make-wt-tree-type
+ make-wt-tree
+ singleton-wt-tree
+ alist->wt-tree
+ wt-tree/empty?
+ wt-tree/size
+ wt-tree/add
+ wt-tree/delete
+ wt-tree/add!
+ wt-tree/delete!
+ wt-tree/member?
+ wt-tree/lookup
+ wt-tree/split<
+ wt-tree/split>
+ wt-tree/union
+ wt-tree/intersection
+ wt-tree/difference
+ wt-tree/subset?
+ wt-tree/set-equal?
+ wt-tree/fold
+ wt-tree/for-each
+ wt-tree/index
+ wt-tree/index-datum
+ wt-tree/index-pair
+ wt-tree/rank
+ wt-tree/min
+ wt-tree/min-datum
+ wt-tree/min-pair
+ wt-tree/delete-min
+ wt-tree/delete-min!
+ number-wt-type
+ string-wt-type)
+
+(define slib:error error)
+
+;; We use the folowing MIT-Scheme operation on fixnums (small
+;; integers). R4RS compatible (but less efficient) definitions.
+;; You should replace these with something that is efficient in your
+;; system.
+
+;; EDIT: Changed these to the gambit names (Per Eckerdal)
+
+(define fix:fixnum? fixnum?)
+(define fix:+ fx+)
+(define fix:- fx-)
+(define fix:< fx<)
+(define fix:<= fx<=)
+(define fix:> fx>)
+(define fix:* fx*)
+
+;; A TREE-TYPE is a collection of those procedures that depend on the
+;; ordering relation.
+
+;; MIT-Scheme structure definition
+;;(define-structure
+;; (tree-type
+;; (conc-name tree-type/)
+;; (constructor %make-tree-type))
+;; (key<? #F read-only true)
+;; (alist->tree #F read-only true)
+;; (add #F read-only true)
+;; (insert! #F read-only true)
+;; (delete #F read-only true)
+;; (delete! #F read-only true)
+;; (member? #F read-only true)
+;; (lookup #F read-only true)
+;; (split-lt #F read-only true)
+;; (split-gt #F read-only true)
+;; (union #F read-only true)
+;; (intersection #F read-only true)
+;; (difference #F read-only true)
+;; (subset? #F read-only true)
+;; (rank #F read-only true)
+;;)
+
+;; EDIT: Using gambit-style define-type
+(define-type tree-type
+ (key<? read-only: unprintable:)
+ (alist->tree read-only: unprintable:)
+ (add read-only: unprintable:)
+ (insert! read-only: unprintable:)
+ (delete read-only: unprintable:)
+ (delete! read-only: unprintable:)
+ (member? read-only: unprintable:)
+ (lookup read-only: unprintable:)
+ (split-lt read-only: unprintable:)
+ (split-gt read-only: unprintable:)
+ (union read-only: unprintable:)
+ (intersection read-only: unprintable:)
+ (difference read-only: unprintable:)
+ (subset? read-only: unprintable:)
+ (rank read-only: unprintable:))
+
+;; User level tree representation.
+;;
+;; WT-TREE is a wrapper for trees of nodes.
+;;
+;;MIT-Scheme:
+;;(define-structure
+;; (wt-tree
+;; (conc-name tree/)
+;; (constructor %make-wt-tree))
+;; (type #F read-only true)
+;; (root #F read-only false))
+
+;; EDIT: Using gambit-style define-type
+(define-type wt-tree
+ constructor: %make-wt-tree
+ (type read-only: unprintable:)
+ (root unprintable:))
+
+;; Nodes are the thing from which the real trees are built. There are
+;; lots of these and the uninquisitibe user will never see them, so
+;; they are represented as untagged to save the slot that would be
+;; used for tagging structures.
+;; In MIT-Scheme these were all DEFINE-INTEGRABLE
+
+(define (make-node k v l r w) (vector w l k r v))
+(define (node/k node) (vector-ref node 2))
+(define (node/v node) (vector-ref node 4))
+(define (node/l node) (vector-ref node 1))
+(define (node/r node) (vector-ref node 3))
+(define (node/w node) (vector-ref node 0))
+
+(define empty 'empty)
+(define (empty? x) (eq? x 'empty))
+
+(define (node/size node)
+ (if (empty? node) 0 (node/w node)))
+
+(define (node/singleton k v) (make-node k v empty empty 1))
+
+(define (with-n-node node receiver)
+ (receiver (node/k node) (node/v node) (node/l node) (node/r node)))
+
+;;
+;; Constructors for building node trees of various complexity
+;;
+
+(define (n-join k v l r)
+ (make-node k v l r (fix:+ 1 (fix:+ (node/size l) (node/size r)))))
+
+(define (single-l a_k a_v x r)
+ (with-n-node r
+ (lambda (b_k b_v y z) (n-join b_k b_v (n-join a_k a_v x y) z))))
+
+(define (double-l a_k a_v x r)
+ (with-n-node r
+ (lambda (c_k c_v r_l z)
+ (with-n-node r_l
+ (lambda (b_k b_v y1 y2)
+ (n-join b_k b_v
+ (n-join a_k a_v x y1)
+ (n-join c_k c_v y2 z)))))))
+
+(define (single-r b_k b_v l z)
+ (with-n-node l
+ (lambda (a_k a_v x y) (n-join a_k a_v x (n-join b_k b_v y z)))))
+
+(define (double-r c_k c_v l z)
+ (with-n-node l
+ (lambda (a_k a_v x l_r)
+ (with-n-node l_r
+ (lambda (b_k b_v y1 y2)
+ (n-join b_k b_v
+ (n-join a_k a_v x y1)
+ (n-join c_k c_v y2 z)))))))
+
+;; (define-integrable wt-tree-ratio 5)
+(define wt-tree-ratio 5)
+
+(define (t-join k v l r)
+ (define (simple-join) (n-join k v l r))
+ (let ((l_n (node/size l))
+ (r_n (node/size r)))
+ (cond ((fix:< (fix:+ l_n r_n) 2) (simple-join))
+ ((fix:> r_n (fix:* wt-tree-ratio l_n))
+ ;; right is too big
+ (let ((r_l_n (node/size (node/l r)))
+ (r_r_n (node/size (node/r r))))
+ (if (fix:< r_l_n r_r_n)
+ (single-l k v l r)
+ (double-l k v l r))))
+ ((fix:> l_n (fix:* wt-tree-ratio r_n))
+ ;; left is too big
+ (let ((l_l_n (node/size (node/l l)))
+ (l_r_n (node/size (node/r l))))
+ (if (fix:< l_r_n l_l_n)
+ (single-r k v l r)
+ (double-r k v l r))))
+ (else
+ (simple-join)))))
+;;
+;; Node tree procedures that are independent of key<?
+;;
+
+(define (node/min node)
+ (cond ((empty? node) (error:empty 'min))
+ ((empty? (node/l node)) node)
+ (else (node/min (node/l node)))))
+
+(define (node/delmin node)
+ (cond ((empty? node) (error:empty 'delmin))
+ ((empty? (node/l node)) (node/r node))
+ (else (t-join (node/k node) (node/v node)
+ (node/delmin (node/l node)) (node/r node)))))
+
+(define (node/concat2 node1 node2)
+ (cond ((empty? node1) node2)
+ ((empty? node2) node1)
+ (else
+ (let ((min-node (node/min node2)))
+ (t-join (node/k min-node) (node/v min-node)
+ node1 (node/delmin node2))))))
+
+(define (node/inorder-fold procedure base node)
+ (define (fold base node)
+ (if (empty? node)
+ base
+ (with-n-node node
+ (lambda (k v l r)
+ (fold (procedure k v (fold base r)) l)))))
+ (fold base node))
+
+(define (node/for-each procedure node)
+ (if (not (empty? node))
+ (with-n-node node
+ (lambda (k v l r)
+ (node/for-each procedure l)
+ (procedure k v)
+ (node/for-each procedure r)))))
+
+(define (node/height node)
+ (if (empty? node)
+ 0
+ (+ 1 (max (node/height (node/l node))
+ (node/height (node/r node))))))
+
+(define (node/index node index)
+ (define (loop node index)
+ (let ((size_l (node/size (node/l node))))
+ (cond ((fix:< index size_l) (loop (node/l node) index))
+ ((fix:> index size_l) (loop (node/r node)
+ (fix:- index (fix:+ 1 size_l))))
+ (else node))))
+ (let ((bound (node/size node)))
+ (if (or (< index 0)
+ (>= index bound)
+ (not (fix:fixnum? index)))
+ (slib:error 'bad-range-argument index 'node/index)
+ (loop node index))))
+
+(define (error:empty owner)
+ (slib:error "Operation requires non-empty tree:" owner))
+
+
+(define (local:make-wt-tree-type key<?)
+
+ ;; MIT-Scheme definitions:
+ ;;(declare (integrate key<?))
+ ;;(define-integrable (key>? x y) (key<? y x))
+
+ (define (key>? x y) (key<? y x))
+
+ (define (node/find k node)
+ ;; Returns either the node or #f.
+ ;; Loop takes D comparisons where D is the depth of the tree
+ ;; rather than the traditional compare-low, compare-high which
+ ;; takes on average 1.5(D-1) comparisons
+ (define (loop this best)
+ (cond ((empty? this) best)
+ ((key<? k (node/k this)) (loop (node/l this) best))
+ (else (loop (node/r this) this))))
+ (let ((best (loop node #f)))
+ (cond ((not best) #f)
+ ((key<? (node/k best) k) #f)
+ (else best))))
+
+ (define (node/rank k node rank)
+ (cond ((empty? node) #f)
+ ((key<? k (node/k node)) (node/rank k (node/l node) rank))
+ ((key>? k (node/k node))
+ (node/rank k (node/r node)
+ (fix:+ 1 (fix:+ rank (node/size (node/l node))))))
+ (else (fix:+ rank (node/size (node/l node))))))
+
+ (define (node/add node k v)
+ (if (empty? node)
+ (node/singleton k v)
+ (with-n-node node
+ (lambda (key val l r)
+ (cond ((key<? k key) (t-join key val (node/add l k v) r))
+ ((key<? key k) (t-join key val l (node/add r k v)))
+ (else (n-join key v l r)))))))
+
+ (define (node/delete x node)
+ (if (empty? node)
+ empty
+ (with-n-node node
+ (lambda (key val l r)
+ (cond ((key<? x key) (t-join key val (node/delete x l) r))
+ ((key<? key x) (t-join key val l (node/delete x r)))
+ (else (node/concat2 l r)))))))
+
+ (define (node/concat tree1 tree2)
+ (cond ((empty? tree1) tree2)
+ ((empty? tree2) tree1)
+ (else
+ (let ((min-node (node/min tree2)))
+ (node/concat3 (node/k min-node) (node/v min-node) tree1
+ (node/delmin tree2))))))
+
+ (define (node/concat3 k v l r)
+ (cond ((empty? l) (node/add r k v))
+ ((empty? r) (node/add l k v))
+ (else
+ (let ((n1 (node/size l))
+ (n2 (node/size r)))
+ (cond ((fix:< (fix:* wt-tree-ratio n1) n2)
+ (with-n-node r
+ (lambda (k2 v2 l2 r2)
+ (t-join k2 v2 (node/concat3 k v l l2) r2))))
+ ((fix:< (fix:* wt-tree-ratio n2) n1)
+ (with-n-node l
+ (lambda (k1 v1 l1 r1)
+ (t-join k1 v1 l1 (node/concat3 k v r1 r)))))
+ (else
+ (n-join k v l r)))))))
+
+ (define (node/split-lt node x)
+ (cond ((empty? node) empty)
+ ((key<? x (node/k node))
+ (node/split-lt (node/l node) x))
+ ((key<? (node/k node) x)
+ (node/concat3 (node/k node) (node/v node) (node/l node)
+ (node/split-lt (node/r node) x)))
+ (else (node/l node))))
+
+ (define (node/split-gt node x)
+ (cond ((empty? node) empty)
+ ((key<? (node/k node) x)
+ (node/split-gt (node/r node) x))
+ ((key<? x (node/k node))
+ (node/concat3 (node/k node) (node/v node)
+ (node/split-gt (node/l node) x) (node/r node)))
+ (else (node/r node))))
+
+ (define (node/union tree1 tree2)
+ (cond ((empty? tree1) tree2)
+ ((empty? tree2) tree1)
+ (else
+ (with-n-node tree2
+ (lambda (ak av l r)
+ (let ((l1 (node/split-lt tree1 ak))
+ (r1 (node/split-gt tree1 ak)))
+ (node/concat3 ak av (node/union l1 l) (node/union r1 r))))))))
+
+ (define (node/difference tree1 tree2)
+ (cond ((empty? tree1) empty)
+ ((empty? tree2) tree1)
+ (else
+ (with-n-node tree2
+ (lambda (ak av l r)
+ (let ((l1 (node/split-lt tree1 ak))
+ (r1 (node/split-gt tree1 ak)))
+ av
+ (node/concat (node/difference l1 l)
+ (node/difference r1 r))))))))
+
+ (define (node/intersection tree1 tree2)
+ (cond ((empty? tree1) empty)
+ ((empty? tree2) empty)
+ (else
+ (with-n-node tree2
+ (lambda (ak av l r)
+ (let ((l1 (node/split-lt tree1 ak))
+ (r1 (node/split-gt tree1 ak)))
+ (if (node/find ak tree1)
+ (node/concat3 ak av (node/intersection l1 l)
+ (node/intersection r1 r))
+ (node/concat (node/intersection l1 l)
+ (node/intersection r1 r)))))))))
+
+ (define (node/subset? tree1 tree2)
+ (or (empty? tree1)
+ (and (fix:<= (node/size tree1) (node/size tree2))
+ (with-n-node tree1
+ (lambda (k v l r)
+ v
+ (cond ((key<? k (node/k tree2))
+ (and (node/subset? l (node/l tree2))
+ (node/find k tree2)
+ (node/subset? r tree2)))
+ ((key>? k (node/k tree2))
+ (and (node/subset? r (node/r tree2))
+ (node/find k tree2)
+ (node/subset? l tree2)))
+ (else
+ (and (node/subset? l (node/l tree2))
+ (node/subset? r (node/r tree2))))))))))
+
+
+ ;;; Tree interface: stripping off or injecting the tree types
+
+ (define (tree/map-add tree k v)
+ (%make-wt-tree (wt-tree-type tree)
+ (node/add (wt-tree-root tree) k v)))
+
+ (define (tree/insert! tree k v)
+ (wt-tree-root-set! tree (node/add (wt-tree-root tree) k v)))
+
+ (define (tree/delete tree k)
+ (%make-wt-tree (wt-tree-type tree)
+ (node/delete k (wt-tree-root tree))))
+
+ (define (tree/delete! tree k)
+ (wt-tree-root-set! tree (node/delete k (wt-tree-root tree))))
+
+ (define (tree/split-lt tree key)
+ (%make-wt-tree (wt-tree-type tree)
+ (node/split-lt (wt-tree-root tree) key)))
+
+ (define (tree/split-gt tree key)
+ (%make-wt-tree (wt-tree-type tree)
+ (node/split-gt (wt-tree-root tree) key)))
+
+ (define (tree/union tree1 tree2)
+ (%make-wt-tree (wt-tree-type tree1)
+ (node/union (wt-tree-root tree1) (wt-tree-root tree2))))
+
+ (define (tree/intersection tree1 tree2)
+ (%make-wt-tree (wt-tree-type tree1)
+ (node/intersection (wt-tree-root tree1) (wt-tree-root tree2))))
+
+ (define (tree/difference tree1 tree2)
+ (%make-wt-tree (wt-tree-type tree1)
+ (node/difference (wt-tree-root tree1) (wt-tree-root tree2))))
+
+ (define (tree/subset? tree1 tree2)
+ (node/subset? (wt-tree-root tree1) (wt-tree-root tree2)))
+
+ (define (alist->tree alist)
+ (define (loop alist node)
+ (cond ((null? alist) node)
+ ((pair? alist) (loop (cdr alist)
+ (node/add node (caar alist) (cdar alist))))
+ (else
+ (slib:error 'wrong-type-argument alist "alist" 'alist->tree))))
+ (%make-wt-tree my-type (loop alist empty)))
+
+ (define (tree/get tree key default)
+ (let ((node (node/find key (wt-tree-root tree))))
+ (if node
+ (node/v node)
+ default)))
+
+ (define (tree/rank tree key) (node/rank key (wt-tree-root tree) 0))
+
+ (define (tree/member? key tree)
+ (and (node/find key (wt-tree-root tree))
+ #t))
+
+ (define my-type #f)
+
+ (set! my-type
+ (make-tree-type ;; EDIT Removed % prefix
+ key<? ; key<?
+ alist->tree ; alist->tree
+ tree/map-add ; add
+ tree/insert! ; insert!
+ tree/delete ; delete
+ tree/delete! ; delete!
+ tree/member? ; member?
+ tree/get ; lookup
+ tree/split-lt ; split-lt
+ tree/split-gt ; split-gt
+ tree/union ; union
+ tree/intersection ; intersection
+ tree/difference ; difference
+ tree/subset? ; subset?
+ tree/rank ; rank
+ ))
+
+ my-type)
+
+(define (guarantee-tree tree procedure)
+ (if (not (wt-tree? tree))
+ (slib:error 'wrong-type-argument
+ tree "weight-balanced tree" procedure)))
+
+(define (guarantee-tree-type type procedure)
+ (if (not (tree-type? type))
+ (slib:error 'wrong-type-argument
+ type "weight-balanced tree type" procedure)))
+
+(define (guarantee-compatible-trees tree1 tree2 procedure)
+ (guarantee-tree tree1 procedure)
+ (guarantee-tree tree2 procedure)
+ (if (not (eq? (wt-tree-type tree1) (wt-tree-type tree2)))
+ (slib:error "The trees" tree1 'and tree2 'have 'incompatible 'types
+ (wt-tree-type tree1) 'and (wt-tree-type tree2))))
+
+;;;______________________________________________________________________
+;;;
+;;; Export interface
+;;;
+(define make-wt-tree-type local:make-wt-tree-type)
+
+(define (make-wt-tree tree-type)
+ (%make-wt-tree tree-type empty))
+
+(define (singleton-wt-tree type key value)
+ (guarantee-tree-type type 'singleton-wt-tree)
+ (%make-wt-tree type (node/singleton key value)))
+
+(define (alist->wt-tree type alist)
+ (guarantee-tree-type type 'alist->wt-tree)
+ ((tree-type-alist->tree type) alist))
+
+(define (wt-tree/empty? tree)
+ (guarantee-tree tree 'wt-tree/empty?)
+ (empty? (wt-tree-root tree)))
+
+(define (wt-tree/size tree)
+ (guarantee-tree tree 'wt-tree/size)
+ (node/size (wt-tree-root tree)))
+
+(define (wt-tree/add tree key datum)
+ (guarantee-tree tree 'wt-tree/add)
+ ((tree-type-add (wt-tree-type tree)) tree key datum))
+
+(define (wt-tree/delete tree key)
+ (guarantee-tree tree 'wt-tree/delete)
+ ((tree-type-delete (wt-tree-type tree)) tree key))
+
+(define (wt-tree/add! tree key datum)
+ (guarantee-tree tree 'wt-tree/add!)
+ ((tree-type-insert! (wt-tree-type tree)) tree key datum))
+
+(define (wt-tree/delete! tree key)
+ (guarantee-tree tree 'wt-tree/delete!)
+ ((tree-type-delete! (wt-tree-type tree)) tree key))
+
+(define (wt-tree/member? key tree)
+ (guarantee-tree tree 'wt-tree/member?)
+ ((tree-type-member? (wt-tree-type tree)) key tree))
+
+(define (wt-tree/lookup tree key default)
+ (guarantee-tree tree 'wt-tree/lookup)
+ ((tree-type-lookup (wt-tree-type tree)) tree key default))
+
+(define (wt-tree/split< tree key)
+ (guarantee-tree tree 'wt-tree/split<)
+ ((tree-type-split-lt (wt-tree-type tree)) tree key))
+
+(define (wt-tree/split> tree key)
+ (guarantee-tree tree 'wt-tree/split>)
+ ((tree-type-split-gt (wt-tree-type tree)) tree key))
+
+(define (wt-tree/union tree1 tree2)
+ (guarantee-compatible-trees tree1 tree2 'wt-tree/union)
+ ((tree-type-union (wt-tree-type tree1)) tree1 tree2))
+
+(define (wt-tree/intersection tree1 tree2)
+ (guarantee-compatible-trees tree1 tree2 'wt-tree/intersection)
+ ((tree-type-intersection (wt-tree-type tree1)) tree1 tree2))
+
+(define (wt-tree/difference tree1 tree2)
+ (guarantee-compatible-trees tree1 tree2 'wt-tree/difference)
+ ((tree-type-difference (wt-tree-type tree1)) tree1 tree2))
+
+(define (wt-tree/subset? tree1 tree2)
+ (guarantee-compatible-trees tree1 tree2 'wt-tree/subset?)
+ ((tree-type-subset? (wt-tree-type tree1)) tree1 tree2))
+
+(define (wt-tree/set-equal? tree1 tree2)
+ (and (wt-tree/subset? tree1 tree2)
+ (wt-tree/subset? tree2 tree1)))
+
+(define (wt-tree/fold combiner-key-datum-result init tree)
+ (guarantee-tree tree 'wt-tree/fold)
+ (node/inorder-fold combiner-key-datum-result
+ init
+ (wt-tree-root tree)))
+
+(define (wt-tree/for-each action-key-datum tree)
+ (guarantee-tree tree 'wt-tree/for-each)
+ (node/for-each action-key-datum (wt-tree-root tree)))
+
+(define (wt-tree/index tree index)
+ (guarantee-tree tree 'wt-tree/index)
+ (let ((node (node/index (wt-tree-root tree) index)))
+ (and node (node/k node))))
+
+(define (wt-tree/index-datum tree index)
+ (guarantee-tree tree 'wt-tree/index-datum)
+ (let ((node (node/index (wt-tree-root tree) index)))
+ (and node (node/v node))))
+
+(define (wt-tree/index-pair tree index)
+ (guarantee-tree tree 'wt-tree/index-pair)
+ (let ((node (node/index (wt-tree-root tree) index)))
+ (and node (cons (node/k node) (node/v node)))))
+
+(define (wt-tree/rank tree key)
+ (guarantee-tree tree 'wt-tree/rank)
+ ((tree-type-rank (wt-tree-type tree)) tree key))
+
+(define (wt-tree/min tree)
+ (guarantee-tree tree 'wt-tree/min)
+ (node/k (node/min (wt-tree-root tree))))
+
+(define (wt-tree/min-datum tree)
+ (guarantee-tree tree 'wt-tree/min-datum)
+ (node/v (node/min (wt-tree-root tree))))
+
+(define (wt-tree/min-pair tree)
+ (guarantee-tree tree 'wt-tree/min-pair)
+ (let ((node (node/min (wt-tree-root tree))))
+ (cons (node/k node) (node/v node))))
+
+(define (wt-tree/delete-min tree)
+ (guarantee-tree tree 'wt-tree/delete-min)
+ (%make-wt-tree (wt-tree-type tree)
+ (node/delmin (wt-tree-root tree))))
+
+(define (wt-tree/delete-min! tree)
+ (guarantee-tree tree 'wt-tree/delete-min!)
+ (wt-tree-root-set! tree (node/delmin (wt-tree-root tree))))
+
+;; < is a lexpr. Many compilers can open-code < so the lambda is faster
+;; than passing <.
+(define number-wt-type (local:make-wt-tree-type (lambda (u v) (< u v))))
+(define string-wt-type (local:make-wt-tree-type string<?))
+
+;;; Local Variables:
+;;; eval: (put 'with-n-node 'scheme-indent-function 1)
+;;; eval: (put 'with-n-node 'scheme-indent-hook 1)
+;;; End:
56 misc/al.scm
@@ -0,0 +1,56 @@
+;;; A-list utilities
+;;;
+;;; Copyright (c) 2008 Per Eckerdal, Mikael Möre
+
+(export al-get
+ al
+ al-set!
+ al-set!-dfl)
+
+(define (al-helper . args)
+ (if (null? args)
+ '()
+ (let ((key (car args))
+ (val (cadr args))
+ (rest (cddr args)))
+ (cons (cons key val)
+ (apply al-helper rest)))))
+
+(define (al-get lst key #!optional (dfl #f))
+ (let ((pair (assoc key lst)))
+ (if pair
+ (cdr pair)
+ dfl)))
+
+(define-syntax al
+ (sc-macro-transformer
+ (lambda (form env)
+ (let* ((args (cdr form))
+ (nargs
+ (let loop ((a args))
+ (cond
+ ((null? a) '())
+ ((pair? (car a))
+ `(',(caar a)
+ (lambda ,(cdar a) ,(cadr a))
+ ,@(loop (cddr a))))
+ (else `(',(car a) ,(cadr a) ,@(loop (cddr a))))))))
+ `(al-helper
+ ,@(map (lambda (x)
+ (make-syntactic-closure env '() x))
+ nargs))))))
+
+;; Set key to value in alist al.
+;; Replace al with the return value on return.
+(define (al-set! al key value)
+ (let ((v (or (assoc key al) (let ((v (cons key #f))) (set! al (cons v al)) v))))
+ (set-cdr! v value)
+ al))
+
+(define (al-set!-dfl al key value)
+ (let* ((not-set '(not-set))
+ (v (al-get al key not-set)))
+ (if (eq? v not-set)
+ (al-set! al key value)
+ al)))
+
222 misc/exception.scm
@@ -0,0 +1,222 @@
+;; Copyright 2006-2008 Christian Jaeger
+
+;; With additions by Per Eckerdal and Mikael Möre
+
+(export cmd-b
+ cmd-y
+ make-exception/continuation
+ exception/continuation?
+ exception/continuation-exception
+ exception/continuation-exception-set!
+ exception/continuation-continuation
+ exception/continuation-continuation-set!
+ exception/continuation-contextline
+ exception/continuation-contextlines
+ exception/continuation-message-in-context
+ exception/continuation-procedure
+ exception/continuation-locat
+ exception/continuation-text
+ repl-within-exception/continuation
+ exception/continuation->serialisation-object
+ exception/continuation->u8vector
+ u8vector->backtrace
+ with-exception/continuation-catcher
+ exception->string
+ exception/continuation->string)
+
+;; todo wha'ts their new safe name? none?
+(define (cmd-b cont port depth)
+ (if (and (##continuation? cont)
+ (port? port)
+ (fixnum? depth))
+ (##cmd-b cont port depth)
+ (error "cmd-b: invalid argument types of cont port depth:" cont port depth)))
+
+(define (cmd-y cont port pinpoint? depth)
+ (if (and (##continuation? cont)
+ (port? port)
+ (fixnum? depth))
+ (##cmd-y cont port pinpoint? depth)
+ (error "cmd-y: invalid argument types of cont port depth:" cont port depth)))
+
+(define-type exception/continuation
+ id: 4bad9e82-f84c-4ae4-9ba7-c8964bf3dffc
+ exception
+ continuation)
+
+;; private
+(define (to-port-or-string maybe-port fn)
+ (if maybe-port
+ (fn maybe-port)
+ (with-output-to-string "" (lambda () (fn (current-output-port))))))
+
+
+(define (exception/continuation-contextline e #!optional port)
+ (to-port-or-string
+ port
+ (lambda (port)
+ (cmd-y (exception/continuation-continuation e)
+ port
+ #f
+ 0))))
+
+
+(define (exception/continuation-contextlines e #!optional port)
+ (to-port-or-string
+ port
+ (lambda (port)
+ (cmd-b (exception/continuation-continuation e)
+ port
+ 0))))
+
+
+(define (exception/continuation-message-in-context e #!optional port)
+ (to-port-or-string
+ port
+ (lambda (port)
+ (display-exception-in-context (exception/continuation-exception e)
+ (exception/continuation-continuation e)
+ port))))
+
+
+(define (exception/continuation-procedure e)
+ (##exception->procedure
+ (exception/continuation-exception e)
+ (exception/continuation-continuation e)))
+
+
+(define (exception/continuation-locat e)
+ (##exception->locat
+ (exception/continuation-exception e)
+ (exception/continuation-continuation e)))
+
+
+;; delegates:
+
+(define (exception/continuation-text e #!optional port)
+ (to-port-or-string
+ port
+ (lambda (port)
+ (display-exception
+ (exception/continuation-exception e)
+ port))))
+
+
+(define (repl-within-exception/continuation e)
+ (if (exception/continuation? e)
+ (##repl-within (exception/continuation-continuation e)
+ "repl-within-exception/continuation")
+ ;; ^ don't know where the 2nd argument to ##repl-within is used
+ (error " not a exception/continuation:" e)))
+
+
+;; serialisation:
+
+
+;; private
+(define-type exception/continuation&string
+ id: d3a6b590-3d09-48e2-99e3-01e076126796
+ exception/continuation
+ string)
+
+
+
+(define (exception/continuation->serialisation-object e)
+ (make-exception/continuation&string
+ e
+ (exception/continuation-contextlines e)))
+
+
+(define (exception/continuation->u8vector e)
+ (object->u8vector
+ (exception/continuation->serialisation-object e)))
+
+(define (u8vector->backtrace vec)
+ (exception/continuation&string-string
+ (u8vector->object vec)))
+
+
+(define (with-exception/continuation-catcher handler th)
+ (continuation-capture
+ (lambda (cont)
+ (with-exception-handler
+ (lambda (e)
+ (continuation-capture
+ (lambda (c)
+ (continuation-graft
+ cont
+ handler
+ (make-exception/continuation e c)))))
+ th))))
+
+
+;; example:
+;; create an exception object with the continuation and
+;; raise this in the context of with-ec-catcher
+
+;; private
+(define (with-ec-catcher thunk)
+ (continuation-capture
+ (lambda (exit)
+ (with-exception-handler
+ (lambda (e)
+ (continuation-capture
+ (lambda (cont)
+ (continuation-graft
+ exit
+ (lambda ()
+ (raise (make-exception/continuation e cont)))))))
+ thunk))))
+
+
+
+(define (exception->string exc)
+ (call-with-output-string
+ ""
+ (lambda (port)
+ (display-exception exc port))))
+
+(define (exception/continuation->string exc #!optional (for-console #f))
+ (let* ((errdesc (exception->string exc))
+ (the-display-exception-in-context
+ (with-exception-handler
+ exception->string
+ (lambda ()
+ (call-with-output-string
+ ""
+ (lambda (port)
+ (display-exception-in-context
+ (exception/continuation-continuation exc)
+ (exception/continuation-continuation exc)
+ port))))))
+ (the-exception/continuation-message-in-context
+ (exception/continuation-message-in-context exc))
+ (the-cmd-b ; (exception/continuation-contextline exc)
+ (with-exception-handler
+ exception->string
+ (lambda ()
+ (call-with-output-string
+ (list output-width: 200)
+ (lambda (port)
+ (cmd-b (exception/continuation-continuation exc)
+ port
+ 0)))))))
+
+ (if for-console
+ (string-append
+ "***\n"
+ "*** Exception thrown.\n"
+ "*** display-exception: " errdesc "\n"
+ "*** display-exception-in-context: "
+ the-display-exception-in-context "\n"
+ "*** exception/continuation-message-in-context: "
+ the-exception/continuation-message-in-context "\n"
+ "*** cmd-b: " the-cmd-b)
+ (string-append
+ "display-exception:\n"
+ errdesc "\n"
+ "display-exception-in-context:\n"
+ the-display-exception-in-context "\n"
+ "exception/continuation-message-in-context:\n"
+ the-exception/continuation-message-in-context "\n"
+ "cmd-b: " the-cmd-b))))
47 misc/mailbox.scm
@@ -0,0 +1,47 @@
+;;; In-RAM Mailbox object routines
+;;;
+;;; This code is from Gambit's documentation.
+;;;
+;;; Copyright (c) 1994-2009 by Marc Feeley, All Rights Reserved.
+
+(define (make-empty-mailbox)
+ (let ((mutex (make-mutex))
+ (put-condvar (make-condition-variable))
+ (get-condvar (make-condition-variable))
+ (full? #f)
+ (cell #f))
+
+ (define (put! obj)
+ (mutex-lock! mutex)
+ (if full?
+ (begin
+ (mutex-unlock! mutex put-condvar)
+ (put! obj))
+ (begin
+ (set! cell obj)
+ (set! full? #t)
+ (condition-variable-signal! get-condvar)
+ (mutex-unlock! mutex))))
+
+ (define (get!)
+ (mutex-lock! mutex)
+ (if (not full?)
+ (begin
+ (mutex-unlock! mutex get-condvar)
+ (get!))
+ (let ((result cell))
+ (set! cell #f) ; avoid space leaks
+ (set! full? #f)
+ (condition-variable-signal! put-condvar)
+ (mutex-unlock! mutex)
+ result)))
+
+ (lambda (msg)
+ (case msg
+ ((put!) put!)
+ ((get!) get!)
+ (else (error "unknown message"))))))
+
+(define (mailbox-put! m obj) ((m 'put!) obj))
+
+(define (mailbox-get! m) ((m 'get!)))
104 misc/match.scm
@@ -0,0 +1,104 @@
+(import (only: (module) identifier?)) ;; TODO It might be good to
+ ;; remove this dependency
+
+(export match)
+
+(define (pattern-match-helper pattern message)
+ (cond
+ ((identifier? pattern)
+ (list message))
+
+ ((and (or (string? pattern)
+ (null? pattern)
+ (boolean? pattern)
+ (number? pattern))
+ (equal? message pattern))
+ '())
+
+ ((and (pair? pattern)
+ (eq? 'quote (car pattern))
+ (eq? message (cadr pattern)))
+ '())
+
+ ((and (pair? pattern)
+ (pair? message))
+ (let loop ((p pattern) (m message))
+ (cond
+ ((and (null? p)
+ (null? m))
+ '())
+
+ ((and (pair? p)
+ (pair? m))
+ (let ((res (pattern-match-helper
+ (car p)
+ (car m))))
+ (and res
+ (append
+ res
+ (loop (cdr p)
+ (cdr m))))))
+
+ ((and (not (pair? p))
+ (not (pair? m)))
+ (pattern-match-helper p m))
+
+ (else
+ #f))))
+
+ (else
+ #f)))
+
+
+(syntax-begin
+
+ (define (pattern-match-param-list mac-env env pattern)
+ (let ((pattern (extract-syntactic-closure-list pattern 1)))
+ (cond
+ ((identifier? pattern)
+ (list pattern))
+
+ ((and (pair? pattern)
+ (identifier=? mac-env 'quote env (car pattern)))
+ '())
+
+ ((pair? pattern)
+ (append (pattern-match-param-list mac-env env (car pattern))
+ (pattern-match-param-list mac-env env (cdr pattern))))
+
+ (else
+ '()))))
+
+ (define (pattern-match-make-lambda mac-env env pattern . body)
+ `(,(make-syntactic-closure mac-env '() 'lambda)
+ ,(pattern-match-param-list mac-env env pattern)
+ ,@body)))
+
+(define-syntax match-lambda
+ (sc-macro-transformer
+ (lambda (form env)
+ (capture-syntactic-environment
+ (lambda (mac-env)
+ (apply pattern-match-make-lambda
+ (cons mac-env
+ (cons env
+ (cdr form)))))))))
+
+(define-syntax match-inner
+ (syntax-rules ()
+ ((match var)
+ (error "Failed to match " var))
+
+ ((match var (pattern body ...) rest ...)
+ (let ((res (pattern-match-helper 'pattern var)))
+ (if res
+ (apply (match-lambda pattern body ...)
+ res)
+ (match var rest ...))))))
+
+(define-syntax match
+ (syntax-rules ()
+ ((match var rest ...)
+ (let ((x var))
+ (match-inner x rest ...)))))
+
165 misc/optionals.scm
@@ -0,0 +1,165 @@
+;; Taken from http://osdir.com/ml/lisp.scheme.scsh/1996-04/msg00010.html
+;; Written by Olin Shivers
+;; I removed the let-optionals macro (Per Eckerdal)
+
+;;; This file defines three macros for parsing optional arguments to procs:
+;;; (LET-OPTIONALS arg-list ((var1 default1) ...) . body)
+;;; (LET-OPTIONALS* arg-list ((var1 default1) ...) . body)
+;;; (:OPTIONAL rest-arg default-exp)
+;;;
+;;; The LET-OPTIONALS macro is defined using the Clinger/Rees
+;;; explicit-renaming low-level macro system. You'll have to do some work to
+;;; port it to another macro system.
+;;;
+;;; The LET-OPTIONALS* and :OPTIONAL macros are defined with simple
+;;; high-level macros, and should be portable to any R4RS system.
+;;;
+;;; These macros are all careful to evaluate their default forms *only* if
+;;; their values are needed.
+;;;
+;;; The top-level forms in this file are Scheme 48 module expressions.
+;;; I use the module system to help me break up the expander code for
+;;; LET-OPTIONALS into three procedures, which makes it easier to understand
+;;; and test. But if you wanted to port this code to a module-less Scheme
+;;; system, you'd probably have to inline the three procs into the actual
+;;; macro definition.
+;;;
+;;; The only interesting module that is exported by this file is
+;;; LET-OPT
+;;; which obeys the following interface:
+;;; (exports (let-optionals :syntax)
+;;; (let-optionals* :syntax)
+;;; (:optional :syntax))
+;;;
+;;; To repeat: This code is not simple Scheme code; it is module code.
+;;; It must be loaded into the Scheme 48 ,config package, not the ,user
+;;; package.
+;;;
+;;; The only non-R4RS dependencies in the macros are ERROR
+;;; and CALL-WITH-VALUES.
+;;;
+;;; See below for details on each macro.
+;;; -Olin
+
+;;; (LET-OPTIONALS arg-list ((var1 default1) ...)
+;;; body
+;;; ...)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; This form is for binding a procedure's optional arguments to either
+;;; the passed-in values or a default.
+;;;
+;;; The expression takes a rest list ARG-LIST and binds the VARi to
+;;; the elements of the rest list. When there are no more elements, then
+;;; the remaining VARi are bound to their corresponding DEFAULTi values.
+;;; It is an error if there are more args than variables.
+;;;
+;;; - The default expressions are *not* evaluated unless needed.
+;;;
+;;; - When evaluated, the default expressions are carried out in the *outer*
+;;; environment. That is, the DEFAULTi forms do *not* see any of the VARi
+;;; bindings.
+;;;
+;;; I originally wanted to have the DEFAULTi forms get eval'd in a LET*
+;;; style scope -- DEFAULT3 would see VAR1 and VAR2, etc. But this is
+;;; impossible to implement without side effects or redundant conditional
+;;; tests. If I drop this requirement, I can use the efficient expansion
+;;; shown below. If you need LET* scope, use the less-efficient
+;;; LET-OPTIONALS* form defined below.
+;;;
+;;; Example:
+;;; (define (read-string! str . maybe-args)
+;;; (let-optionals maybe-args ((port (current-input-port))
+;;; (start 0)
+;;; (end (string-length str)))
+;;; ...))
+;;;
+;;; expands to:
+;;;
+;;; (let* ((body (lambda (port start end) ...))
+;;; (end-def (lambda (%port %start) (body %port %start <end-default>)))
+;;; (start-def (lambda (%port) (end-def %port <start-default>)))
+;;; (port-def (lambda () (start-def <port-def>))))
+;;; (if (null? rest) (port-def)
+;;; (let ((%port (car rest))
+;;; (rest (cdr rest)))
+;;; (if (null? rest) (start-def %port)
+;;; (let ((%start (car rest))
+;;; (rest (cdr rest)))
+;;; (if (null? rest) (end-def %port %start)
+;;; (let ((%end (car rest))
+;;; (rest (cdr rest)))
+;;; (if (null? rest) (body %port %start %end)
+;;; (error ...)))))))))
+
+
+;;; (:optional rest-arg default-exp)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; This form is for evaluating optional arguments and their defaults
+;;; in simple procedures that take a *single* optional argument. It is
+;;; a macro so that the default will not be computed unless it is needed.
+;;;
+;;; REST-ARG is a rest list from a lambda -- e.g., R in
+;;; (lambda (a b . r) ...)
+;;; - If REST-ARG has 0 elements, evaluate DEFAULT-EXP and return that.
+;;; - If REST-ARG has 1 element, return that element.
+;;; - If REST-ARG has >1 element, error.
+
+(export :optional
+ let-optionals*)
+
+(define-syntax :optional
+ (syntax-rules ()
+ ((:optional rest default-exp)
+ (let ((maybe-arg rest))
+ (cond ((null? maybe-arg) default-exp)
+ ((null? (cdr maybe-arg)) (car maybe-arg))
+ (else (error "too many optional arguments" maybe-arg)))))))
+
+
+;;; (LET-OPTIONALS* args ((var1 default1) ... [rest]) body1 ...)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; This is just like LET-OPTIONALS, except that the DEFAULTi forms
+;;; are evaluated in a LET*-style environment. That is, DEFAULT3 is evaluated
+;;; within the scope of VAR1 and VAR2, and so forth.
+;;;
+;;; - If the last form in the ((var1 default1) ...) list is not a
+;;; (VARi DEFAULTi) pair, but a simple variable REST, then it is
+;;; bound to any left-over values. For example, if we have VAR1 through
+;;; VAR7, and ARGS has 9 values, then REST will be bound to the list of
+;;; the two values of ARGS. If ARGS is too short, causing defaults to
+;;; be used, then REST is bound to '().
+;;; - If there is no REST variable, then it is an error to have excess
+;;; values in the ARGS list.
+
+
+;;; This just interfaces to REALLY-LET-OPTIONALS*, which expects
+;;; the ARGS form to be a variable.
+
+(define-syntax really-let-optionals*
+ (syntax-rules ()
+ ;; Standard case. Do the first var/default and recurse.
+ ((really-let-optionals* args ((var1 default1 typecheck1 ...) etc ...)
+ body1 ...)
+ (call-with-values (lambda () (if (null? args)
+ (values default1 '())
+ (values (car args) (cdr args))))
+ (lambda (var1 rest)
+ (really-let-optionals* rest (etc ...)
+ body1 ...))))
+
+ ;; Single rest arg -- bind to the remaining rest values.
+ ((really-let-optionals* args (rest) body1 ...)
+ (let ((rest args)) body1 ...))
+
+ ;; No more vars. Make sure there are no unaccounted-for values, and
+ ;; do the body.
+ ((really-let-optionals* args () body1 ...)
+ (if (null? args) (begin body1 ...)
+ (error "Too many optional arguments." args)))))
+
+(define-syntax let-optionals*
+ (syntax-rules ()
+ ((let-optionals* args vars&defaults body1 ...)
+ (let ((rest args))
+ (really-let-optionals* rest vars&defaults body1 ...)))))
+
28 misc/splice.scm
@@ -0,0 +1,28 @@
+(export splice
+ splice?
+ (rename: (splice-data unsplice))
+ unsplice-list)
+
+(define-type splice
+ id: BFC5FE93-402B-4B7A-881E-8E864E6ED184
+ (data read-only:))
+
+(define (splice . args)
+ (make-splice args))
+
+(define (unsplice-list list)
+ (cond
+ ((and (pair? list)
+ (splice? (car list)))
+ (append (splice-data (car list))
+ (unsplice-list (cdr list))))
+
+ ((splice? list)
+ (splice-data list))
+
+ ((pair? list)
+ (cons (car list)
+ (unsplice-list (cdr list))))
+
+ (else
+ list)))
98 misc/token-table.scm
@@ -0,0 +1,98 @@
+;;; Extracted from http.scm HTTP server by Per Eckerdal
+
+;==============================================================================
+
+; File: "http.scm", Time-stamp: <2007-04-04 14:42:59 feeley>
+
+; Copyright (c) 2005-2007 by Marc Feeley, All Rights Reserved.
+
+;==============================================================================
+
+(declare
+ (standard-bindings)
+ (extended-bindings)
+ (block))
+
+;==============================================================================
+
+; Token tables.
+
+(define hash-substring
+ (lambda (str start end)
+
+ (define loop
+ (lambda (h i)
+ (if (< i end)
+ (loop (modulo (+ (* h 5063) (char->integer (string-ref str i)))
+ 65536)
+ (+ i 1))
+ h)))
+
+ (loop 0 start)))
+
+(define-macro (make-token-table . alist)
+
+ ; "alist" is a list of lists of the form "(string expression)"
+
+ ; The result is a perfect hash-table represented as a vector of
+ ; length 2*N, where N is the hash modulus. If the string S is in
+ ; the hash-table it is at index
+ ;
+ ; X = (* 2 (modulo (hash-substring S 0 (string-length S)) N))
+ ;
+ ; and the associated expression is at index X+1.
+
+ (define hash-substring ; repeated from above to be
+ (lambda (str start end) ; available for macro expansion
+
+ (let loop ((h 0) (i start))
+ (if (< i end)
+ (loop (modulo (+ (* h 5063) (char->integer (string-ref str i)))
+ 65536)
+ (+ i 1))
+ h))))
+
+ (define make-perfect-hash-table
+ (lambda (alist)
+ (let loop1 ((n (length alist)))
+ (let ((v (make-vector (* 2 n) #f)))
+ (let loop2 ((lst alist))
+ (if (pair? lst)
+ (let* ((x (car lst))
+ (str (car x)))
+ (let ((h
+ (* 2
+ (modulo (hash-substring str 0 (string-length str))
+ n))))
+ (if (vector-ref v h)
+ (loop1 (+ n 1))
+ (begin
+ (vector-set! v h str)
+ (vector-set! v (+ h 1) (cadr x))
+ (loop2 (cdr lst))))))
+ v))))))
+
+ (cons 'vector (vector->list (make-perfect-hash-table alist))))
+
+(define token-table-lookup-substring
+ (lambda (table str start end)
+ (let* ((n (quotient (vector-length table) 2))
+ (h (* 2 (modulo (hash-substring str start end) n)))
+ (x (vector-ref table h)))
+
+ (define loop
+ (lambda (i j)
+ (if (< i end)
+ (if (char=? (string-ref str i) (string-ref x j))
+ (loop (+ i 1) (+ j 1))
+ #f)
+ h)))
+
+ (and x
+ (= (string-length x) (- end start))
+ (loop start 0)))))
+
+(define token-table-lookup-string
+ (lambda (table str)
+ (token-table-lookup-substring table str 0 (string-length str))))
+
185 misc/u8v.scm
@@ -0,0 +1,185 @@
+;;; u8vector utilities, mostly string-related.
+;;;
+;;; Copyright (c) 2008 Mikael Möre
+
+(define (hex-char->integer c)
+ (let ((i (char->integer c)))
+ (cond
+ ((<= 48 i 57)
+ (- i 48))
+ ((<= 97 i 102)
+ (+ (- i 97) 10))
+ ((<= 65 i 70)
+ (+ (- i 65) 10))
+ (else
+ (error "Character not 0-9, A-F, a-f." c)))))
+
+(define (u8vector->string v
+ #!key
+ (char-encoding 'UTF-8)
+ (ignore-errors-in-encoding #f))
+ (call-with-input-u8vector
+ `(char-encoding: ,char-encoding
+ eol-encoding: cr-lf
+ init: ,v)
+ (lambda (input-port)
+ (call-with-output-string
+ '()
+ (lambda (output-port)
+ (let loop ()
+ (let ((c
+ (with-exception-catcher
+ (lambda (e)
+ (if ignore-errors-in-encoding
+ #f
+ (raise
+ (error "Failed to read u8vector, broken characters? Data: "
+ v))))
+ (lambda ()
+ (read-char input-port)))))
+ ; (dbg "Had " c)
+ (if (not (eq? c #!eof))
+ (begin
+ (if c (write-char c output-port))
+ (loop))))))))))
+
+(define (string->utf8-u8vector s)
+ (with-output-to-u8vector
+ '(char-encoding: UTF-8 eol-encoding: cr-lf)
+ (lambda ()
+ (display s))))
+
+(define (u8vector-reverse v)
+ (let* ((l (u8vector-length v))
+ (r (make-u8vector l)))
+ (let loop ((src-idx 0) (target-idx (- l 1)))
+ (u8vector-set! r target-idx (u8vector-ref v src-idx))
+ (if (> target-idx 0)
+ (loop (+ src-idx 1) (- target-idx 1))))
+ r))
+
+(define (ISO-8859-1-substring->u8vector str start end)
+ (let* ((len (- end start))
+ (u8vect (make-u8vector len)))
+ (let loop ((i 0))
+ (if (< i len)
+ (begin
+ (u8vector-set!
+ u8vect
+ i
+ (char->integer (string-ref str (+ start i))))
+ (loop (+ i 1)))
+ u8vect))))
+
+(define (ISO-8859-1-string->u8vector str)
+ (ISO-8859-1-substring->u8vector
+ str
+ 0
+ (string-length str)))
+
+(define (subu8vector->ISO-8859-1-string u8vect start end)
+ (let* ((len (- end start))
+ (str (make-string len)))
+ (let loop ((i 0))
+ (if (< i len)
+ (begin
+ (string-set!
+ str
+ i
+ (integer->char (u8vector-ref u8vect (+ start i))))
+ (loop (+ i 1)))
+ str))))
+
+(define (u8vector->ISO-8859-1-string u8vect)
+ (subu8vector->ISO-8859-1-string
+ u8vect
+ 0
+ (u8vector-length u8vect)))
+
+(define (subu8vector-move! src src-start src-end dst dst-start)
+ ;; Copy direction must be selected in case src and dst are the same
+ ;; vector.
+ (if (< src-start dst-start)
+ (let loop1 ((i (- src-end 1))
+ (j (- (+ dst-start (- src-end src-start)) 1)))
+ (if (< i src-start)
+ dst
+ (begin
+ (u8vector-set! dst j (u8vector-ref src i))
+ (loop1 (- i 1)
+ (- j 1)))))
+ (let loop2 ((i src-start)
+ (j dst-start))
+ (if (< i src-end)
+ (begin
+ (u8vector-set! dst j (u8vector-ref src i))
+ (loop2 (+ i 1)
+ (+ j 1)))
+ dst))))
+
+
+(define (subu8vector->hex-string u8vect start end)
+ (define (digit->char d)
+ (string-ref "0123456789abcdef" d))
+
+ (let* ((len (- end start))
+ (n (* len 2))
+ (str (make-string n)))
+ (let loop ((i 0) (j (- len 1)) (k 0))
+ (if (>= j 0)
+ (let ((x (u8vector-ref u8vect k)))
+ (string-set! str i (digit->char (quotient x 16)))
+ (string-set! str (+ i 1) (digit->char (modulo x 16)))
+ (loop (+ i 2) (- j 1) (+ k 1)))
+ str))))
+
+(define (u8vector->hex-string u8vect)
+ (subu8vector->hex-string
+ u8vect
+ 0
+ (u8vector-length u8vect)))
+
+
+(define (hex-string->u8vector s)
+ (let* ((l (string-length s)))
+ (if (= (modulo l 2) 1) (error "String length not multiple of two" s))
+ (let* ((c (/ l 2))
+ (v (make-u8vector c)))
+ (let loop ((i 0))
+ (let* ((m (* i 2))
+ (a (hex-char->integer (string-ref s m)))
+ (b (hex-char->integer (string-ref s (+ m 1))))
+ (n (+ (* a 16) b)))
+ (u8vector-set! v i n)
+ (let ((i (+ i 1)))
+ (if (not (eq? i c))
+ (loop i)))))
+ v)))
+
+(define (u8vector-invert! v)
+ (let loop ((i (u8vector-length v)))
+ (if (not (zero? i))
+ (let ((i (- i 1)))
+ (u8vector-set! v i (##fixnum.bitwise-xor
+ (u8vector-ref v i)
+ 255))
+ (loop i)))))
+
+
+(define (dump-u8vector-port-to-other-u8vector-port content-in
+ #!optional
+ (content-out '()))
+ (if (null? content-out)
+ (call-with-output-u8vector
+ '()
+ (lambda (port)
+ (dump-u8vector-port-to-other-u8vector-port content-in port)))
+
+ (let* ((tmp-bufsize (* 50 1024))
+ (tmp-buffer (make-u8vector tmp-bufsize)))
+ (let loop ()
+ (let ((n (read-subu8vector tmp-buffer 0 tmp-bufsize content-in)))
+ (if (> n 0)
+ (begin
+ (write-subu8vector tmp-buffer 0 n content-out)
+ (loop))))))))
63 misc/uuid.scm
@@ -0,0 +1,63 @@
+;;; UUID generation
+;;; See: http://www.ietf.org/rfc/rfc4122.txt
+;;;
+;;; Version 4 UUID, see section 4.4
+;;;
+;;; (taken from the termite distribution but modified by Per Eckerdal
+;;; to return a string instead of a symbol to avoid the memory leak of
+;;; an unbounded amount of interned symbols)
+
+(define (make-uuid)
+ (define hex
+ '#(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\A #\B #\C #\D #\E #\F))
+ (let ((n1 (random-integer 65536))
+ (n2 (random-integer 65536))
+ (n3 (random-integer 65536))
+ (n4 (random-integer 65536))
+ (n5 (random-integer 65536))
+ (n6 (random-integer 65536))
+ (n7 (random-integer 65536))
+ (n8 (random-integer 65536)))
+ (string
+ ;; time_lo
+ (vector-ref hex (extract-bit-field 4 12 n1))
+ (vector-ref hex (extract-bit-field 4 8 n1))
+ (vector-ref hex (extract-bit-field 4 4 n1))
+ (vector-ref hex (extract-bit-field 4 0 n1))
+ (vector-ref hex (extract-bit-field 4 12 n2))
+ (vector-ref hex (extract-bit-field 4 8 n2))
+ (vector-ref hex (extract-bit-field 4 4 n2))
+ (vector-ref hex (extract-bit-field 4 0 n2))
+ #\-
+ ;; time_mid
+ (vector-ref hex (extract-bit-field 4 12 n3))
+ (vector-ref hex (extract-bit-field 4 8 n3))
+ (vector-ref hex (extract-bit-field 4 4 n3))
+ (vector-ref hex (extract-bit-field 4 0 n3))
+ #\-
+ ;; time_hi_and_version
+ (vector-ref hex #b0100)
+ (vector-ref hex (extract-bit-field 4 8 n4))
+ (vector-ref hex (extract-bit-field 4 4 n4))
+ (vector-ref hex (extract-bit-field 4 0 n4))
+ #\-
+ ;; clock_seq_hi_and_reserved
+ (vector-ref hex (bitwise-ior (extract-bit-field 2 12 n5) #b1000))
+ (vector-ref hex (extract-bit-field 4 8 n5))
+ ;; clock_seq_low
+ (vector-ref hex (extract-bit-field 4 4 n5))
+ (vector-ref hex (extract-bit-field 4 0 n5))
+ #\-
+ ;; node
+ (vector-ref hex (extract-bit-field 4 12 n6))
+ (vector-ref hex (extract-bit-field 4 8 n6))
+ (vector-ref hex (extract-bit-field 4 4 n6))
+ (vector-ref hex (extract-bit-field 4 0 n6))
+ (vector-ref hex (extract-bit-field 4 12 n7))
+ (vector-ref hex (extract-bit-field 4 8 n7))
+ (vector-ref hex (extract-bit-field 4 4 n7))
+ (vector-ref hex (extract-bit-field 4 0 n7))
+ (vector-ref hex (extract-bit-field 4 12 n8))
+ (vector-ref hex (extract-bit-field 4 8 n8))
+ (vector-ref hex (extract-bit-field 4 4 n8))
+ (vector-ref hex (extract-bit-field 4 0 n8)))))
1,084 net/http-client.scm
@@ -0,0 +1,1084 @@
+;; ===================================================================
+;;
+;; Another http (1.1) client library, by Per Eckerdal
+;;
+;; Things it supports:
+;; * Reading chunked encoding
+;; * Optionally following redirects
+;; * Basic auth
+;; * Post requests with application/x-www-form-urlencoded
+;;
+;; Things it cannot do right now:
+;; * "multipart/form-data"
+;; * I should add (private) annotations.
+;; * .. and probably move out some of the code to lib/http-common
+;;
+;; ===================================================================
+;;
+;; History:
+;;
+;; 2008-09-23: Removed close-output-port call between sending headers
+;; and reading response, showed up not to work for certain
+;; remote hosts (!).
+;;
+
+(import http-common
+ uri
+ x-www-form-urlencoded
+ ../ds/queue
+ ../ds/wt-tree
+ ../string/base64
+ ../string/util
+ ../srfi/1
+ ../srfi/13
+ ../srfi/19)
+
+(export http-max-pipelined-requests-per-connection
+ http-max-connection-idle-time
+ http-max-connections-per-server
+ http-preferred-pipelined-connections
+
+ make-http-request
+ http-request?
+ http-request-method
+ http-request-uri
+ http-request-headers
+ http-request-query
+ http-request-port-callback
+ http-request-done-callback
+ http-request-method-set
+ http-request-uri-set
+ http-request-headers-set
+ http-request-query-set
+ http-request-port-callback-set
+ http-request-done-callback-set
+ http-queue-request
+ http-invoke-request
+
+ http-follow-request
+ http-request-to-string
+ http-post
+ http-get
+
+ make-http-client-error-from-remote
+ http-client-error-from-remote?
+ http-client-error-from-remote-code
+ http-client-error-from-remote-headers
+ http-client-error-from-remote-request-headers
+ http-client-error-from-remote-uri
+ http-client-error-from-remote-content
+ http-access-url
+ http-get-url
+ http-post-url
+ http-client-404-exception?
+ http-response-get-status
+ http-response-get-headers
+ http-response-get-content
+ http-response-get-content-string)
+
+(declare (block)
+ (mostly-fixnum)
+ (standard-bindings)
+ (extended-bindings))
+
+;; ===================================================================
+;;
+;; Tweakable parameters of the library
+;;
+
+;; Define them first, then set them. This is to be able to do (declare
+;; (block)) and still be able to |set!| these things later.
+(define http-max-pipelined-requests-per-connection #f)
+(define http-max-connection-idle-time #f) ;; In seconds
+(define http-max-connections-per-server #f)
+(define http-preferred-pipelined-connections #f) ;; Not implemented
+
+(set! http-max-pipelined-requests-per-connection 2)
+(set! http-max-connection-idle-time 30)
+(set! http-max-connections-per-server 200)
+(set! http-preferred-pipelined-connections 2) ;; Not implemented
+
+;; ===================================================================
+;;
+;; Utility functions
+;;
+
+(define (al-get lst key #!optional (dfl #f))
+ (let ((pair (assoc key lst)))
+ (if pair
+ (cdr pair)
+ dfl)))
+
+(define (mutex-thunk)
+ (let ((mtx (make-mutex)))
+ (lambda (thunk)
+ (dynamic-wind
+ (lambda ()
+ (mutex-lock! mtx))
+ thunk
+ (lambda ()
+ (mutex-unlock! mtx))))))
+
+;; TODO This functionality overlaps with lib/uri. lib/uri should
+;; really be used instead.
+(define (uri-query-string uri)
+ (with-output-to-string
+ (string)
+ (lambda ()
+ (display (let ((p (uri-path uri)))
+ (if (zero? (string-length p))
+ "/"
+ p)))
+
+ (let ((q (uri-query uri)))
+ (cond
+ ((string? q)
+ (display "?")
+ (display q))
+
+ ((pair? q)
+ (let ((first #t))
+ (for-each
+ (lambda (pair)
+ (display (if first
+ "?"
+ "&"))
+ (set! first #f)
+ (if (cdr pair)
+ (display (list
+ (urlencode (car pair))
+ "="
+ (urlencode (cdr pair))))
+ (display (urlencode (car pair)))))
+ q))))))))
+
+(define (pipe/buffer in-port out-port #!optional chars-left buf)
+ (let* ((buf (or buf (make-u8vector (* 5 1024))))
+ (buf-len (u8vector-length buf))
+ (bytes-to-read (if chars-left
+ (min chars-left buf-len)
+ buf-len)))
+ (if (zero? bytes-to-read)
+ #t
+ (let ((read-bytes
+ (read-subu8vector buf 0 bytes-to-read in-port)))
+ (if (and chars-left
+ (not (= bytes-to-read read-bytes)))
+ (error "Failed to read correct number of bytes"
+ read-bytes
+ bytes-to-read))
+ (write-subu8vector buf 0 read-bytes out-port)
+ (pipe/buffer in-port
+ out-port
+ (- chars-left bytes-to-read)
+ buf)))))
+
+(define (http-auth-headers un pw)
+ (cons 'authorization
+ (string-append "Basic "
+ (u8vector->base64-string
+ (string->utf8-u8vector
+ (string-append un ":" pw))))))
+
+;; Joins two alists of headers, the first one having precedence over
+;; the other. TODO Right now the implementation rather quick&dirty.
+(define (header-join one two)
+ (table->list
+ (table-merge!
+ (list->table one)
+ (list->table two))))
+
+(define (with-port-for-request uri thunk #!key (close-on-exit #t))
+ (let* ((host (let ((host (uri-host uri)))
+ (or host
+ (error "Cannot connect to server without address"
+ uri))))
+ (scheme (or (uri-scheme uri) "http"))
+ (port-number
+ (or (uri-port uri)
+ (cond ((equal? scheme "http")
+ 80)
+ ((equal? scheme "https")
+ 443)
+ (else
+ (error "Don't know what port number to use for protocol"
+ scheme)))))
+ ;; The following line is where one would hook up a green
+ ;; thread friendly dns lookup. I removed it because of
+ ;; licensing issues with the dns library used. Hopefully
+ ;; it'll be possible to use a better dns client in the
+ ;; future.
+ (server-address host)
+ (port
+ ((cond ((equal? scheme "http")
+ open-tcp-client)
+ ;; I have removed openssl support because of license
+ ;; issues with the openssl module. Hopefully it can
+ ;; be included in the future. To add the support
+ ;; again, just use the ssl module and uncomment these
+ ;; lines:
+ ;;
+ ;;((equal? scheme "https")
+ ;; open-ssl-tcp-client)
+ (else
+ (error "Unknown protocol" scheme)))
+ (list server-address: server-address
+ port-number: port-number))))
+
+ (let ((res (thunk port)))
+ (if close-on-exit
+ (close-port port))
+ res)))
+
+(define (chunked-coding-read-hex str)
+ (let* ((str-len (string-length str))
+ (chr-lst
+ (let loop ((lst '()) (idx 0))
+ (cond
+ ((or (>= idx str-len)
+ (let ((chr (string-ref str idx)))
+ (or (char=? #\; chr)
+ (char=? #\space chr))))
+ lst)
+
+ (else
+ (loop (cons (char->integer
+ (string-ref str idx))
+ lst)
+ (+ 1 idx))))))
+ (zero (char->integer #\0))
+ (nine (char->integer #\9))
+ (a (char->integer #\a))
+ (A (char->integer #\A))
+ (f (char->integer #\f))
+ (F (char->integer #\F)))
+ (let loop ((lst chr-lst) (multiple 1))
+ (if (null? lst)
+ 0
+ (let ((chr (car lst)))
+ (+ (loop (cdr lst) (* multiple 16))
+ (* multiple
+ (cond
+ ((and (>= chr zero)
+ (<= chr nine))
+ (- chr zero))
+
+ ((and (>= chr a)
+ (<= chr f))
+ (+ 10 (- chr a)))
+
+ ((and (>= chr A)
+ (<= chr F))
+ (+ 10 (- chr A)))
+
+ (else
+ (error "Invalid character in hex string" str))))))))))
+
+
+;; ===================================================================
+;;
+;; Request sending functions
+;;
+
+;; Bah.. This function is quite ugly.
+(define (display-request port method uri headers query)
+ (display (string-upcase (symbol->string method)) port)
+ (display " " port)
+ (display (uri-query-string uri) port)
+ (display-crlf port " HTTP/1.1")
+
+ (let* ((ct (al-get headers 'content-type))
+
+ (header-content-pair
+ (cond
+ ((not query)
+ (cons '() #f))
+
+ ((port? query)
+ (cons '((transfer-encoding . chunked))
+ query))
+
+ ((string? query)
+ (cons `((content-length . ,(string-length query)))
+ (string->utf8-u8vector query)))
+
+ ((u8vector? query)
+ (cons `((content-length . ,(u8vector-length query)))
+ query))
+
+ ((pair? query)
+ (cond
+ ((or (not ct)
+ (equal? ct "application/x-www-form-urlencoded"))
+ (let ((content (with-output-to-u8vector
+ (u8vector)
+ (lambda ()
+ (write-x-www-form-urlencoded query)))))
+ (cons
+ `((content-type . "application/x-www-form-urlencoded")
+ (content-length . ,(u8vector-length content)))
+ content)))
+
+ ((string-prefix? "multipart/form-data" ct)
+ (error "multipart/form-data is not implemented"))
+
+ (else
+ (error "Invalid Content-Type header for given query"
+ ct
+ query))))
+
+ (else
+ (error "Invalid query parameter type" query))))
+
+ (actual-headers
+ (header-join
+ headers
+ `((host . ,(uri-host uri))
+ (user-agent . "curl/7.18.2 (i486-pc-linux-gnu) libcurl/7.18.2")
+ (cache-control . "max-age=0")
+ (accept-charset . "utf-8;q=0.7,ISO-8859-1;q=0.6,*;q=0.5")
+ (accept . "text/xml,application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5")
+ (accept-encoding . "")
+ (accept-language . "en")
+ (pragma . "no-cache")
+ (cache-control . "no-cache")
+ ,@(car header-content-pair)))))
+ (display-headers port actual-headers)
+
+ ;; If method is post, and no content-length header has been sent, send one.
+ (if (and (eq? method 'post)
+ (not (assq 'content-length actual-headers)))
+ (display-header port (cons 'content-length 0)))
+
+ (display-crlf port)
+ (let ((content (cdr header-content-pair)))
+ (if content
+ (begin
+ (if (u8vector? content)
+ (write-u8vector content port)
+ (pipe/buffer content port))
+ (display-crlf port))))
+
+ (force-output port)))
+
+
+;; ===================================================================
+;;
+;; Response reading functions
+;;
+
+(define (read-content port output-port/vector headers)
+ (let ((output-port (if (u8vector? output-port/vector)
+ (open-u8vector output-port/vector)
+ output-port/vector))
+
+ (cl (let ((val (al-get headers "content-length")))
+ (and val (string->number val))))
+
+ (chunked?
+ (find (lambda (x)
+ (and (equal? "transfer-encoding" (car x))
+ (string-prefix? "chunked"
+ (string-downcase (cdr x)))))
+ headers)))
+ (cond
+ (chunked?
+ (let ((buf (make-u8vector (* 5 1024))))
+ (let loop ()
+ (let* ((len-str (permissive-read-line port))
+ (len (chunked-coding-read-hex len-str)))
+ (if (not (zero? len))
+ (begin
+ (pipe/buffer port
+ output-port
+ len
+ buf)
+ (permissive-read-line port)
+ (loop)))))))
+
+ (cl
+ (if (u8vector? output-port/vector)
+ ;; Do the case when the output port is a vector with an optimized
+ ;; (non-copying) algorithm.
+ (let ((read-bytes (read-subu8vector output-port/vector 0 cl port)))
+ (if (not (= read-bytes cl))
+ (error "Failed to read correct number of bytes" read-bytes cl)))
+
+
+ (let ((buf (make-u8vector (min cl (* 5 1024)))))
+ (pipe/buffer port output-port cl buf))))
+
+ (else
+ (dump-u8vector-port-to-other-u8vector-port
+ port
+ output-port)))))
+
+(define (read-status-line-code str)
+ (let* ((len (string-length str))
+ (start
+ (let loop ((start 0))
+ (if (and (< start len)
+ (not (char-numeric? (string-ref str start))))
+ (loop (+ 1 start))
+ start))))
+ (string->number
+ (substring str start (min (+ start 3) len)))))
+
+(define (read-response port req)
+ (let ((cont (http-request-port-callback req))
+ (method (http-request-method req)))
+ (call/cc
+ (lambda (ret)
+ (let* ((status-line (permissive-read-lines port))
+
+ (code
+ (or (read-status-line-code status-line)
+ (error "Couldn't parse status line" status-line)))
+
+ (has-message-body
+ (if (= 100 code)
+ (ret (read-response port req))
+
+ ;; 204 No Content does not include a message-body
+ ;; 304 Not Modified does not include a message-body
+ ;; 1xx responses don't include a message-body
+ ;;
+ ;; If the request was head, then the response
+ ;; doesn't include a message-body
+ (not
+ (or (= 204 code)
+ (= 304 code)
+ (= 1 (floor (/ code 100)))
+ (eq? method 'head)))))
+
+ (headers (read-header port))
+
+ (output-port (cont code headers has-message-body)))
+
+ (if has-message-body
+ (read-content port output-port headers))
+
+ ;; Return true if the server sent Connection: close
+ (member '("connection" . "close") headers))))))
+
+;; ===================================================================
+;;
+;; Persistent connection and pipelining layer
+;;
+
+;;; Functions that a user of the library might invoke
+
+;; This api demands some explanation. The parameters it takes are the
+;; obvious method ('get, 'post, 'method and so on), uri, headers (as
+;; an alist where the keys are lowercase symbols), query,
+;; port-callback, a thunk described later and done-callback, a thunk
+;; that takes no parameters and is invoked when the request is done.
+;;
+;; Both port-callback and done-callback will be invoked from another
+;; thread than the invocation of the http request was from, but they
+;; are guaranteed to be called from the same thread, done-callback
+;; after part-callback.
+;;
+;; part-callback should be a procedure taking three arguments:
+;; * code, the numerical response code of the http request,
+;; * headers, an alist where the car is a lowercase string of
+;; the header and cdr is a string of the value (not case-modified)
+;; * has-content?, a boolean indicating whether this response will
+;; have a content body.
+;;
+;; This function should return an output port or an u8vector. The
+;; response of the request will be written to this output
+;; port/u8vector.
+(define-type http-request
+ (method read-only:)
+ (uri read-only:)
+ (headers read-only:)
+ (query read-only:)
+ (port-callback read-only:)
+ (done-callback read-only:))
+
+(define (http-request-method-set req m)
+ (make-http-request
+ m
+ (http-request-uri req)
+ (http-request-headers req)
+ (http-request-query req)
+ (http-request-port-callback req)
+ (http-request-done-callback req)))
+
+(define (http-request-uri-set req u)
+ (make-http-request
+ (http-request-method req)
+ u
+ (http-request-headers req)
+ (http-request-query req)
+ (http-request-port-callback req)
+ (http-request-done-callback req)))
+
+(define (http-request-headers-set req h)
+ (make-http-request
+ (http-request-method req)
+ (http-request-uri req)
+ h
+ (http-request-query req)
+ (http-request-port-callback req)
+ (http-request-done-callback req)))
+
+(define (http-request-query-set req q)
+ (make-http-request
+ (http-request-method req)
+ (http-request-uri req)
+ (http-request-headers req)
+ q
+ (http-request-port-callback req)
+ (http-request-done-callback req)))
+
+(define (http-request-port-callback-set req pc)
+ (make-http-request
+ (http-request-method req)
+ (http-request-uri req)
+ (http-request-headers req)
+ (http-request-query req)
+ pc
+ (http-request-done-callback req)))
+
+(define (http-request-done-callback-set req dc)
+ (make-http-request
+ (http-request-method req)
+ (http-request-uri req)
+ (http-request-headers req)
+ (http-request-query req)
+ (http-request-port-callback req)
+ dc))
+
+;; The main entry point of this part of the machinery
+(define (http-queue-request req)
+ (let ((conns (request-queue-get-connections (http-request-uri req)
+ #t)))
+ (http-connections-push-request conns req)))
+
+;; Don't use persistent connections.
+(define (http-invoke-request req)
+ (thread-start!
+ (make-thread
+ (lambda ()
+ (with-port-for-request
+ (http-request-uri req)
+ (lambda (port)
+ (display-request port
+ (http-request-method req)
+ (http-request-uri req)
+ (header-join (http-request-headers req)
+ '((connection . close)))
+ (http-request-query req))
+ (read-response port req)
+ ((http-request-done-callback req))))))))
+
+
+;;; Functions regarding the request queue:
+
+(define request-queue-table (make-table))
+(define request-queue-with-mutex! (mutex-thunk))
+
+(define (request-queue-get-connections uri #!optional create-on-fail?)
+ (request-queue-with-mutex!
+ (lambda ()
+ (let* ((stripped-uri (make-uri (uri-scheme uri)
+ ;; Skip the userinfo part of the
+ ;; authority
+ (cons #f
+ (cdr (uri-authority uri)))
+ #f
+ #f
+ #f))
+ (res (table-ref request-queue-table
+ stripped-uri
+ #f)))
+ (if (and (not res) create-on-fail?)
+ (let ((new-conns (make-http-connections stripped-uri)))
+ (table-set! request-queue-table stripped-uri new-conns)
+ new-conns)
+ res)))))
+
+;; Used by http-connections-pop-connection when there is no longer an
+;; open connection to that server.
+(define (request-queue-pop-connections server)
+ (request-queue-with-mutex!
+ (lambda ()
+ (table-set! request-queue-table server))))
+
+
+
+;;; Functions regarding the http-connections structure:
+
+;; A http-connections object keeps the connections we have to one
+;; particular server (that is, protocol (http/https), host and port).
+(define-type http-connections
+ constructor: make-http-connections-internal
+
+ ;; This variable is never mutated so it can be used without mutex.
+ (server read-only:)
+
+ ;; (The following are only to be used internally by the
+ ;; http-connections functions.)
+
+ ;; conns is a wt-tree where the value is a thread with a connection
+ ;; and the key is the number of pipelined requests on that
+ ;; connection.
+ threads
+
+ ;; Because wt-tree cannot have more than one value with the same
+ ;; key, this variable is used to generate unique keys for the tree.
+ counter
+
+ ;; Used to maintain thread safety. All operations on the threads
+ ;; tree and the counter must go through this mutex.
+ (mutex read-only:))
+
+(define http-connections-wt-tree-type
+ (make-wt-tree-type
+ ;; Comparison function.
+ (lambda (a b)
+ (let ((a-val (car a))
+ (b-val (car b))
+ (a-uniq (cdr a))
+ (b-uniq (cdr b)))
+ (if (= a-val b-val)
+ (< a-uniq b-uniq)
+ (< a-val b-val))))))
+
+
+(define (make-http-connections server)
+ (make-http-connections-internal
+ server
+ (make-wt-tree http-connections-wt-tree-type)
+ 0
+ (make-mutex server)))
+
+;; Used internally by the http-connections functionse
+(define (http-connections-with-mutex! conns thunk)
+ (let ((mtx (http-connections-mutex conns)))
+ (dynamic-wind
+ (lambda ()
+ (mutex-lock! mtx))
+ thunk
+ (lambda ()
+ (mutex-unlock! mtx)))))
+
+;; Invoked by http-connections-push-request when it decides that one
+;; more connection is needed.
+;;
+;; Creates a new connection thread belonging to a http-connections
+;; structure.
+;;
+;; Note that this function does not lockt the http-connections
+;; mutex. The user of the function must do that.
+(define (http-connections-push-connection conns)
+ (let* ((uid (http-connections-counter conns))
+ (conn (http-connection-open conns uid))
+ (key (cons 0 uid)))
+ (http-connections-counter-set! conns (+ 1 uid))
+ (wt-tree/add! (http-connections-threads conns)
+ key
+ conn)
+ (cons key conn)))
+
+;; Invoked by the connection upon its death. If the connection queue
+;; gets empty, the http-connections object removes itself from the
+;; request queue.
+;;
+;; n-reqs is the number of requests that the connection has left to
+;; do, uid is the connection's id.
+(define (http-connections-pop-connection conns n-reqs uid)
+ (http-connections-with-mutex!
+ conns
+ (lambda ()
+ (let ((tree (http-connections-threads conns)))
+ (wt-tree/delete! tree (cons n-reqs uid))
+ (if (and (zero? n-reqs)
+ (wt-tree/empty? tree))
+ ;; Only pop this connection if the connection had zero
+ ;; pending requests. Otherwise we aren't done yet.
+ (request-queue-pop-connections conns))))))
+
+;; The "entry point" to the http-connections part of the
+;; machinery. Used by http-queue-request.
+;;
+;; This function takes a request and makes sure the request gets done.
+;;
+;; TODO The http-preferred-pipelined-connections stuff isn't
+;; implemented.
+(define (http-connections-push-request conns request)
+ (http-connections-with-mutex!
+ conns
+ (lambda ()
+ (let ((threads (http-connections-threads conns)))
+ (if (wt-tree/empty? threads)
+ (http-connection-push-request
+ (cdr (http-connections-push-connection conns))
+ request)
+ (let* ((min-pair (wt-tree/min-pair threads))
+ (pair
+ (if (and (> (caar min-pair)
+ http-max-pipelined-requests-per-connection)
+ (< (wt-tree/size threads)
+ http-max-connections-per-server))
+ (http-connections-push-connection conns)
+ min-pair)))
+ (wt-tree/delete! threads (car pair))
+ (wt-tree/add! threads
+ (cons (+ 1 (caar pair))
+ (cdar pair))
+ (cdr pair))
+ (http-connection-push-request
+ (cdr pair)
+ request)))))))
+
+;; Invoked by the connection when a request is completed. It decreases
+;; the number of requests that is kept for that connection in the
+;; threads tree.
+;;
+;; n-reqs is the requests the connection had earlier, uid is the
+;; connection's id, conn is the connection object.
+(define (http-connections-pop-request conns n-reqs uid conn)
+ (http-connections-with-mutex!
+ conns
+ (lambda ()
+ (let* ((tree (http-connections-threads conns)))
+ (wt-tree/delete! tree (cons n-reqs uid))
+ (wt-tree/add! tree
+ (cons (- n-reqs 1) uid)
+ conn)))))
+
+;;; Functions regarding the connection threads.
+
+(define (http-connection-open connections uid)
+ ;; The with-port-for-request should be outside of the thread because
+ ;; we want to throw an exception to the caller of this function if
+ ;; we fail to connect to the server.
+ (with-port-for-request
+ (http-connections-server connections)
+ (lambda (port)
+ (let* (;; A queue that contains the requests that the thread is
+ ;; scheduled to do. Is must be synced with the map that is
+ ;; kept in the connections object (the request count must be
+ ;; the same)
+ ;;
+ ;; A #f in the queue is a signal to the receiver thread that
+ ;; it should stop working.
+ (rq (make-queue))
+ (with-rq! (mutex-thunk)))
+ (thread-start!
+ (make-thread
+ (lambda ()
+ (let* ((sender (current-thread))
+ ;; Used to wake up the receiver thread when something
+ ;; should be read. It should be locked in the
+ ;; beginning to make the receiver wait correctly.
+ (receive-mutex (let ((m (make-mutex 'receive-mutex)))
+ (mutex-lock! m)
+ m))
+ (receiver
+ (thread-start!
+ (make-thread
+ (lambda ()
+ (let loop ()
+ (let ((req
+ (let loop ()
+ (or (with-rq!
+ (lambda ()
+ (queue-front rq #f)))
+ (begin
+ ;; Wait for a signal from the
+ ;; sender thread
+ (mutex-lock!
+ receive-mutex
+ http-max-connection-idle-time)
+ (loop))))))
+ (if req
+ (with-exception-catcher
+ (lambda (e)
+ ;; Silently ignore the error. After
+ ;; this, we send a message to the
+ ;; sender thread to kill itself.
+ #f)
+ (lambda ()
+ (let ((close?
+ (read-response port req)))
+ (with-rq!
+ (lambda ()
+ (http-connections-pop-request
+ connections
+ (queue-size rq)
+ uid
+ sender)
+ (queue-pop! rq)))
+ ((http-request-done-callback req))
+ (if (not close?) (loop))))))))
+ (thread-send sender #f))))))
+ ;; The sender loop
+ (with-exception-catcher
+ (lambda (e)
+ ;; This will be reached both when something goes wrong
+ ;; and when the timeout is reached.
+ #f)
+ (lambda ()
+ (let loop ()
+ (let ((req (thread-receive
+ http-max-connection-idle-time)))
+ (if (eq? 'alive
+ (thread-join! receiver 0 'alive))
+ (begin
+ (display-request port
+ (http-request-method req)
+ (http-request-uri req)
+ (http-request-headers req)
+ (http-request-query req))
+ (with-rq!
+ (lambda ()
+ (queue-push! rq req)))
+ (mutex-unlock! receive-mutex)
+ (if (not (member '(connection . close)
+ (http-request-headers req)))
+ ;; Only continue the loop if we didn't send a
+ ;; Connection: close header
+ (loop))))))))
+ ;; The connection is dead. Now shut everything down gracefully.
+ (with-rq!
+ (lambda ()
+ ;; Remove this connection from the connections structure
+ (http-connections-pop-connection
+ connections
+ (queue-size rq)
+ uid)
+ ;; Re-issue the requests that aren't done yet
+ (let loop ()
+ (if (not (queue-empty? rq))
+ (begin
+ (http-connections-push-request
+ connections
+ (queue-pop! rq)))))
+ ;; Tell the receiver thread to stop
+ (queue-push! rq #f)
+ (mutex-unlock! receive-mutex)))
+ ;; Wait for the receiver thread to exit before we close
+ ;; the connection.
+ (thread-join! receiver)
+ (close-port port)))))))
+ close-on-exit: #f))
+
+(define (http-connection-push-request conn req)
+ ;; I want guaranteed message delivery and last-in-first-out order of
+ ;; the messages, so I don't use termite.
+ (thread-send conn req))
+
+;; ===================================================================
+;;
+;; Higher-level functionality
+;;
+
+;; The follow parameter can be an integer or #f for one redirection
+(define (http-follow-request req
+ #!optional
+ (follow 10)
+ (req-fun http-queue-request))
+ (let ((method (http-request-method req))
+ (uri (http-request-uri req))
+ (headers (http-request-headers req))
+ (query (http-request-query req)))
+ (cond
+ ((not follow)
+ (req-fun req))
+
+ ((negative? follow)
+ (error "Too many redirects"))
+
+ (else
+ (let ((redir-loc #f))
+ ;; redir-loc is a variable that will be set later if this
+ ;; request gives a redirect as result. It is needed because we
+ ;; can't call send-http-request from within the port callback we
+ ;; send to it (or shouldn't, at least)
+ (req-fun
+ (make-http-request
+ method
+ uri
+ headers
+ query
+ (lambda (code resp-headers has-content?)
+ (if (or (and (or (= 301 code)
+ (= 302 code)
+ (= 307 code))
+ ;; Unless the method is get or head, don't redirect.
+ (or (eq? 'get method)
+ (eq? 'head method)))
+ (= 303 code))
+
+ (let ((loc (al-get resp-headers "location")))
+ (if loc
+ (begin
+ (set! redir-loc loc)
+ ;; Return a u8vector port. The content of the
+ ;; redirect response will be filled to that
+ ;; vector, which is then thrown away.
+ (if has-content? (open-u8vector (u8vector))))
+ (error "No location header of response" uri)))
+
+ ((http-request-port-callback req)
+ code
+ resp-headers
+ has-content?)))
+ (lambda ()
+ (if redir-loc
+
+ (http-follow-request
+ (http-request-uri-set
+ req
+ (uri-join uri
+ (string->uri redir-loc)))
+ (- follow 1)
+ req-fun)
+
+ ((http-request-done-callback req)))))))))))
+
+;;; Accessory functions
+
+(define (http-request-to-string method
+ url
+ #!optional
+ query
+ (headers '()))
+ (let ((up (open-output-u8vector (u8vector)))
+ (mtx (make-mutex)))
+ (mutex-lock! mtx)
+ (http-follow-request
+ (make-http-request
+ method
+ (if (uri? url) url (string->uri url))
+ headers
+ query
+ (lambda (code headers has-content?) up)
+ (lambda ()
+ (mutex-unlock! mtx))))
+ (mutex-lock! mtx)
+ (u8vector->string (get-output-u8vector up)
+ ignore-errors-in-encoding: #t)))
+
+(define (http-post url #!optional query (headers '()))
+ (http-request-to-string 'post url query headers))
+
+(define (http-get url #!optional (headers '()))