Artifact
464fa3c6e40253530ef778dd745d91b5aedbf835:
0000: 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 30 ;; Copyright 200
0010: 37 2d 32 30 31 31 2c 20 4d 61 74 74 68 65 77 20 7-2011, Matthew
0020: 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b 20 Welland..;; .;;
0030: 20 54 68 69 73 20 70 72 6f 67 72 61 6d 20 69 73 This program is
0040: 20 6d 61 64 65 20 61 76 61 69 6c 61 62 6c 65 20 made available
0050: 75 6e 64 65 72 20 74 68 65 20 47 4e 55 20 47 50 under the GNU GP
0060: 4c 20 76 65 72 73 69 6f 6e 20 32 2e 30 20 6f 72 L version 2.0 or
0070: 0a 3b 3b 20 20 67 72 65 61 74 65 72 2e 20 53 65 .;; greater. Se
0080: 65 20 74 68 65 20 61 63 63 6f 6d 70 61 6e 79 69 e the accompanyi
0090: 6e 67 20 66 69 6c 65 20 43 4f 50 59 49 4e 47 20 ng file COPYING
00a0: 66 6f 72 20 64 65 74 61 69 6c 73 2e 0a 3b 3b 20 for details..;;
00b0: 0a 3b 3b 20 20 54 68 69 73 20 70 72 6f 67 72 61 .;; This progra
00c0: 6d 20 69 73 20 64 69 73 74 72 69 62 75 74 65 64 m is distributed
00d0: 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 52 WITHOUT ANY WAR
00e0: 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 65 RANTY; without e
00f0: 76 65 6e 20 74 68 65 0a 3b 3b 20 20 69 6d 70 6c ven the.;; impl
0100: 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 20 ied warranty of
0110: 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 20 MERCHANTABILITY
0120: 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 41 or FITNESS FOR A
0130: 20 50 41 52 54 49 43 55 4c 41 52 0a 3b 3b 20 20 PARTICULAR.;;
0140: 50 55 52 50 4f 53 45 2e 0a 0a 3b 3b 20 28 64 65 PURPOSE...;; (de
0150: 63 6c 61 72 65 20 28 75 6e 69 74 20 73 65 73 73 clare (unit sess
0160: 69 6f 6e 29 29 0a 28 6d 6f 64 75 6c 65 20 73 65 ion)).(module se
0170: 73 73 69 6f 6e 0a 20 20 20 20 2a 0a 20 20 0a 28 ssion. *. .(
0180: 69 6d 70 6f 72 74 20 63 68 69 63 6b 65 6e 20 73 import chicken s
0190: 63 68 65 6d 65 20 64 61 74 61 2d 73 74 72 75 63 cheme data-struc
01a0: 74 75 72 65 73 20 65 78 74 72 61 73 20 73 72 66 tures extras srf
01b0: 69 2d 31 33 20 70 6f 72 74 73 20 70 6f 73 69 78 i-13 ports posix
01c0: 20 66 69 6c 65 73 20 73 72 66 69 2d 31 29 0a 28 files srfi-1).(
01d0: 75 73 65 20 66 6f 72 6d 64 61 74 20 68 74 6d 6c use formdat html
01e0: 2d 66 69 6c 74 65 72 20 6d 69 73 63 2d 73 74 6d -filter misc-stm
01f0: 6c 29 0a 0a 28 75 73 65 20 28 70 72 65 66 69 78 l)..(use (prefix
0200: 20 64 62 69 20 64 62 69 3a 29 20 73 72 66 69 2d dbi dbi:) srfi-
0210: 36 39 29 0a 28 72 65 71 75 69 72 65 2d 65 78 74 69).(require-ext
0220: 65 6e 73 69 6f 6e 20 72 65 67 65 78 29 0a 28 75 ension regex).(u
0230: 73 65 20 63 6f 6f 6b 69 65 29 20 3b 3b 20 28 64 se cookie) ;; (d
0240: 65 63 6c 61 72 65 20 28 75 73 65 73 20 63 6f 6f eclare (uses coo
0250: 6b 69 65 29 29 0a 0a 3b 3b 20 73 65 73 73 69 6f kie))..;; sessio
0260: 6e 73 20 74 61 62 6c 65 0a 3b 3b 20 69 64 20 73 ns table.;; id s
0270: 65 73 73 69 6f 6e 5f 69 64 20 73 65 73 73 69 6f ession_id sessio
0280: 6e 5f 6b 65 79 0a 3b 3b 20 63 72 65 61 74 65 20 n_key.;; create
0290: 74 61 62 6c 65 20 73 65 73 73 69 6f 6e 73 20 28 table sessions (
02a0: 69 64 20 73 65 72 69 61 6c 20 6e 6f 74 20 6e 75 id serial not nu
02b0: 6c 6c 2c 73 65 73 73 69 6f 6e 2d 6b 65 79 20 74 ll,session-key t
02c0: 65 78 74 29 3b 0a 0a 3b 3b 20 73 65 73 73 69 6f ext);..;; sessio
02d0: 6e 5f 76 61 72 73 20 74 61 62 6c 65 0a 3b 3b 20 n_vars table.;;
02e0: 69 64 20 73 65 73 73 69 6f 6e 5f 69 64 20 70 61 id session_id pa
02f0: 67 65 5f 69 64 20 6b 65 79 20 76 61 6c 75 65 0a ge_id key value.
0300: 3b 3b 20 63 72 65 61 74 65 20 74 61 62 6c 65 20 ;; create table
0310: 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 28 69 64 session_vars (id
0320: 20 73 65 72 69 61 6c 20 6e 6f 74 20 6e 75 6c 6c serial not null
0330: 2c 73 65 73 73 69 6f 6e 5f 69 64 20 69 6e 74 65 ,session_id inte
0340: 67 65 72 2c 70 61 67 65 20 74 65 78 74 2c 6b 65 ger,page text,ke
0350: 79 20 74 65 78 74 2c 76 61 6c 75 65 20 74 65 78 y text,value tex
0360: 74 29 3b 0a 0a 3b 3b 20 54 4f 44 4f 0a 3b 3b 20 t);..;; TODO.;;
0370: 20 43 6f 6e 63 65 70 74 20 6f 66 20 6f 72 64 65 Concept of orde
0380: 72 20 6e 75 6d 20 69 6e 63 72 65 6d 65 6e 74 65 r num incremente
0390: 64 20 77 69 74 68 20 65 61 63 68 20 70 61 67 65 d with each page
03a0: 20 61 63 63 65 73 73 0a 3b 3b 20 20 20 20 20 69 access.;; i
03b0: 66 20 61 20 62 72 61 6e 63 68 20 69 73 20 74 61 f a branch is ta
03c0: 6b 65 6e 20 74 68 65 6e 20 61 20 6e 65 77 20 73 ken then a new s
03d0: 65 73 73 69 6f 6e 20 77 6f 75 6c 64 20 6e 65 65 ession would nee
03e0: 64 20 74 6f 20 62 65 20 63 72 65 61 74 65 64 0a d to be created.
03f0: 3b 3b 0a 0a 3b 3b 20 6d 61 6b 65 2d 76 65 63 74 ;;..;; make-vect
0400: 6f 72 2d 72 65 63 6f 72 64 20 73 65 73 73 69 6f or-record sessio
0410: 6e 20 73 65 73 73 69 6f 6e 20 64 62 74 79 70 65 n session dbtype
0420: 20 64 62 69 6e 69 74 20 63 6f 6e 6e 20 70 61 72 dbinit conn par
0430: 61 6d 73 20 70 61 74 68 2d 70 61 72 61 6d 73 20 ams path-params
0440: 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 73 73 session-key sess
0450: 69 6f 6e 2d 69 64 20 64 6f 6d 61 69 6e 20 74 6f ion-id domain to
0460: 70 70 61 67 65 20 70 61 67 65 20 63 75 72 72 2d ppage page curr-
0470: 70 61 67 65 20 63 6f 6e 74 65 6e 74 2d 74 79 70 page content-typ
0480: 65 20 70 61 67 65 2d 74 79 70 65 20 73 72 6f 6f e page-type sroo
0490: 74 20 74 77 69 6b 69 64 69 72 20 70 61 67 65 64 t twikidir paged
04a0: 61 74 20 61 6c 74 2d 70 61 67 65 2d 64 61 74 20 at alt-page-dat
04b0: 70 61 67 65 76 61 72 73 20 70 61 67 65 76 61 72 pagevars pagevar
04c0: 73 2d 62 65 66 6f 72 65 20 73 65 73 73 69 6f 6e s-before session
04d0: 76 61 72 73 20 73 65 73 73 69 6f 6e 76 61 72 73 vars sessionvars
04e0: 2d 62 65 66 6f 72 65 20 67 6c 6f 62 61 6c 76 61 -before globalva
04f0: 72 73 20 67 6c 6f 62 61 6c 76 61 72 73 2d 62 65 rs globalvars-be
0500: 66 6f 72 65 20 6c 6f 67 70 74 20 66 6f 72 6d 64 fore logpt formd
0510: 61 74 20 72 65 71 75 65 73 74 2d 6d 65 74 68 6f at request-metho
0520: 64 20 73 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 d session-cookie
0530: 20 63 75 72 72 2d 65 72 72 20 6c 6f 67 2d 70 6f curr-err log-po
0540: 72 74 20 6c 6f 67 66 69 6c 65 20 73 65 65 6e 2d rt logfile seen-
0550: 70 61 67 65 73 20 70 61 67 65 2d 64 69 72 2d 73 pages page-dir-s
0560: 74 79 6c 65 20 64 65 62 75 67 6d 6f 64 65 0a 28 tyle debugmode.(
0570: 64 65 66 69 6e 65 20 28 6d 61 6b 65 2d 73 64 61 define (make-sda
0580: 74 29 28 6d 61 6b 65 2d 76 65 63 74 6f 72 20 33 t)(make-vector 3
0590: 36 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 6)).(define (sda
05a0: 74 2d 67 65 74 2d 64 62 74 79 70 65 20 20 20 20 t-get-dbtype
05b0: 20 20 20 20 20 20 20 20 20 20 20 76 65 63 29 20 vec)
05c0: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 (vector-ref
05d0: 76 65 63 20 30 29 29 0a 28 64 65 66 69 6e 65 20 vec 0)).(define
05e0: 28 73 64 61 74 2d 67 65 74 2d 64 62 69 6e 69 74 (sdat-get-dbinit
05f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 76 v
0600: 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 ec) (vector-r
0610: 65 66 20 20 76 65 63 20 31 29 29 0a 28 64 65 66 ef vec 1)).(def
0620: 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 63 6f ine (sdat-get-co
0630: 6e 6e 20 20 20 20 20 20 20 20 20 20 20 20 20 20 nn
0640: 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 vec) (vect
0650: 6f 72 2d 72 65 66 20 20 76 65 63 20 32 29 29 0a or-ref vec 2)).
0660: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 (define (sdat-ge
0670: 74 2d 70 67 63 6f 6e 6e 20 20 20 20 20 20 20 20 t-pgconn
0680: 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 vec) (
0690: 76 65 63 74 6f 72 2d 72 65 66 20 28 76 65 63 74 vector-ref (vect
06a0: 6f 72 2d 72 65 66 20 76 65 63 20 32 29 20 31 29 or-ref vec 2) 1)
06b0: 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d ).(define (sdat-
06c0: 67 65 74 2d 70 61 72 61 6d 73 20 20 20 20 20 20 get-params
06d0: 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 vec)
06e0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 (vector-ref ve
06f0: 63 20 33 29 29 0a 28 64 65 66 69 6e 65 20 28 73 c 3)).(define (s
0700: 64 61 74 2d 67 65 74 2d 70 61 74 68 2d 70 61 72 dat-get-path-par
0710: 61 6d 73 20 20 20 20 20 20 20 20 20 20 76 65 63 ams vec
0720: 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 ) (vector-ref
0730: 20 20 76 65 63 20 34 29 29 0a 28 64 65 66 69 6e vec 4)).(defin
0740: 65 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 e (sdat-get-sess
0750: 69 6f 6e 2d 6b 65 79 20 20 20 20 20 20 20 20 20 ion-key
0760: 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 vec) (vector
0770: 2d 72 65 66 20 20 76 65 63 20 35 29 29 0a 28 64 -ref vec 5)).(d
0780: 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d efine (sdat-get-
0790: 73 65 73 73 69 6f 6e 2d 69 64 20 20 20 20 20 20 session-id
07a0: 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 vec) (ve
07b0: 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 36 29 ctor-ref vec 6)
07c0: 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d ).(define (sdat-
07d0: 67 65 74 2d 64 6f 6d 61 69 6e 20 20 20 20 20 20 get-domain
07e0: 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 vec)
07f0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 (vector-ref ve
0800: 63 20 37 29 29 0a 28 64 65 66 69 6e 65 20 28 73 c 7)).(define (s
0810: 64 61 74 2d 67 65 74 2d 74 6f 70 70 61 67 65 20 dat-get-toppage
0820: 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 vec
0830: 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 ) (vector-ref
0840: 20 20 76 65 63 20 38 29 29 0a 28 64 65 66 69 6e vec 8)).(defin
0850: 65 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 e (sdat-get-page
0860: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0870: 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 vec) (vector
0880: 2d 72 65 66 20 20 76 65 63 20 39 29 29 0a 28 64 -ref vec 9)).(d
0890: 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d efine (sdat-get-
08a0: 63 75 72 72 2d 70 61 67 65 20 20 20 20 20 20 20 curr-page
08b0: 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 vec) (ve
08c0: 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 31 30 ctor-ref vec 10
08d0: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
08e0: 2d 67 65 74 2d 63 6f 6e 74 65 6e 74 2d 74 79 70 -get-content-typ
08f0: 65 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 e vec)
0900: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 (vector-ref v
0910: 65 63 20 31 31 29 29 0a 28 64 65 66 69 6e 65 20 ec 11)).(define
0920: 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 2d 74 (sdat-get-page-t
0930: 79 70 65 20 20 20 20 20 20 20 20 20 20 20 20 76 ype v
0940: 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 ec) (vector-r
0950: 65 66 20 20 76 65 63 20 31 32 29 29 0a 28 64 65 ef vec 12)).(de
0960: 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 73 fine (sdat-get-s
0970: 72 6f 6f 74 20 20 20 20 20 20 20 20 20 20 20 20 root
0980: 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 vec) (vec
0990: 74 6f 72 2d 72 65 66 20 20 76 65 63 20 31 33 29 tor-ref vec 13)
09a0: 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d ).(define (sdat-
09b0: 67 65 74 2d 74 77 69 6b 69 64 69 72 20 20 20 20 get-twikidir
09c0: 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 vec)
09d0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 (vector-ref ve
09e0: 63 20 31 34 29 29 0a 28 64 65 66 69 6e 65 20 28 c 14)).(define (
09f0: 73 64 61 74 2d 67 65 74 2d 70 61 67 65 64 61 74 sdat-get-pagedat
0a00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 ve
0a10: 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 c) (vector-re
0a20: 66 20 20 76 65 63 20 31 35 29 29 0a 28 64 65 66 f vec 15)).(def
0a30: 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 61 6c ine (sdat-get-al
0a40: 74 2d 70 61 67 65 2d 64 61 74 20 20 20 20 20 20 t-page-dat
0a50: 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 vec) (vect
0a60: 6f 72 2d 72 65 66 20 20 76 65 63 20 31 36 29 29 or-ref vec 16))
0a70: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 .(define (sdat-g
0a80: 65 74 2d 70 61 67 65 76 61 72 73 20 20 20 20 20 et-pagevars
0a90: 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 vec)
0aa0: 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 (vector-ref vec
0ab0: 20 31 37 29 29 0a 28 64 65 66 69 6e 65 20 28 73 17)).(define (s
0ac0: 64 61 74 2d 67 65 74 2d 70 61 67 65 76 61 72 73 dat-get-pagevars
0ad0: 2d 62 65 66 6f 72 65 20 20 20 20 20 20 76 65 63 -before vec
0ae0: 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 ) (vector-ref
0af0: 20 20 76 65 63 20 31 38 29 29 0a 28 64 65 66 69 vec 18)).(defi
0b00: 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 ne (sdat-get-ses
0b10: 73 69 6f 6e 76 61 72 73 20 20 20 20 20 20 20 20 sionvars
0b20: 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f vec) (vecto
0b30: 72 2d 72 65 66 20 20 76 65 63 20 31 39 29 29 0a r-ref vec 19)).
0b40: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 (define (sdat-ge
0b50: 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 t-sessionvars-be
0b60: 66 6f 72 65 20 20 20 76 65 63 29 20 20 20 20 28 fore vec) (
0b70: 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 vector-ref vec
0b80: 32 30 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 20)).(define (sd
0b90: 61 74 2d 67 65 74 2d 67 6c 6f 62 61 6c 76 61 72 at-get-globalvar
0ba0: 73 20 20 20 20 20 20 20 20 20 20 20 76 65 63 29 s vec)
0bb0: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
0bc0: 20 76 65 63 20 32 31 29 29 0a 28 64 65 66 69 6e vec 21)).(defin
0bd0: 65 20 28 73 64 61 74 2d 67 65 74 2d 67 6c 6f 62 e (sdat-get-glob
0be0: 61 6c 76 61 72 73 2d 62 65 66 6f 72 65 20 20 20 alvars-before
0bf0: 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 vec) (vector
0c00: 2d 72 65 66 20 20 76 65 63 20 32 32 29 29 0a 28 -ref vec 22)).(
0c10: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 define (sdat-get
0c20: 2d 6c 6f 67 70 74 20 20 20 20 20 20 20 20 20 20 -logpt
0c30: 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 vec) (v
0c40: 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 32 ector-ref vec 2
0c50: 33 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 3)).(define (sda
0c60: 74 2d 67 65 74 2d 66 6f 72 6d 64 61 74 20 20 20 t-get-formdat
0c70: 20 20 20 20 20 20 20 20 20 20 20 76 65 63 29 20 vec)
0c80: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 (vector-ref
0c90: 76 65 63 20 32 34 29 29 0a 28 64 65 66 69 6e 65 vec 24)).(define
0ca0: 20 28 73 64 61 74 2d 67 65 74 2d 72 65 71 75 65 (sdat-get-reque
0cb0: 73 74 2d 6d 65 74 68 6f 64 20 20 20 20 20 20 20 st-method
0cc0: 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d vec) (vector-
0cd0: 72 65 66 20 20 76 65 63 20 32 35 29 29 0a 28 64 ref vec 25)).(d
0ce0: 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d efine (sdat-get-
0cf0: 73 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 20 20 session-cookie
0d00: 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 vec) (ve
0d10: 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 32 36 ctor-ref vec 26
0d20: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
0d30: 2d 67 65 74 2d 63 75 72 72 2d 65 72 72 20 20 20 -get-curr-err
0d40: 20 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 vec)
0d50: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 (vector-ref v
0d60: 65 63 20 32 37 29 29 0a 28 64 65 66 69 6e 65 20 ec 27)).(define
0d70: 28 73 64 61 74 2d 67 65 74 2d 6c 6f 67 2d 70 6f (sdat-get-log-po
0d80: 72 74 20 20 20 20 20 20 20 20 20 20 20 20 20 76 rt v
0d90: 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 ec) (vector-r
0da0: 65 66 20 20 76 65 63 20 32 38 29 29 0a 28 64 65 ef vec 28)).(de
0db0: 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 6c fine (sdat-get-l
0dc0: 6f 67 66 69 6c 65 20 20 20 20 20 20 20 20 20 20 ogfile
0dd0: 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 vec) (vec
0de0: 74 6f 72 2d 72 65 66 20 20 76 65 63 20 32 39 29 tor-ref vec 29)
0df0: 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d ).(define (sdat-
0e00: 67 65 74 2d 73 65 65 6e 2d 70 61 67 65 73 20 20 get-seen-pages
0e10: 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 vec)
0e20: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 (vector-ref ve
0e30: 63 20 33 30 29 29 0a 28 64 65 66 69 6e 65 20 28 c 30)).(define (
0e40: 73 64 61 74 2d 67 65 74 2d 70 61 67 65 2d 64 69 sdat-get-page-di
0e50: 72 2d 73 74 79 6c 65 20 20 20 20 20 20 20 76 65 r-style ve
0e60: 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 c) (vector-re
0e70: 66 20 20 76 65 63 20 33 31 29 29 0a 28 64 65 66 f vec 31)).(def
0e80: 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 64 65 ine (sdat-get-de
0e90: 62 75 67 6d 6f 64 65 20 20 20 20 20 20 20 20 20 bugmode
0ea0: 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 vec) (vect
0eb0: 6f 72 2d 72 65 66 20 20 76 65 63 20 33 32 29 29 or-ref vec 32))
0ec0: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 .(define (sdat-g
0ed0: 65 74 2d 73 68 61 72 65 64 2d 68 61 73 68 20 20 et-shared-hash
0ee0: 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 vec)
0ef0: 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 (vector-ref vec
0f00: 20 33 33 29 29 0a 28 64 65 66 69 6e 65 20 28 73 33)).(define (s
0f10: 64 61 74 2d 67 65 74 2d 73 63 72 69 70 74 20 20 dat-get-script
0f20: 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 vec
0f30: 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 ) (vector-ref
0f40: 20 20 76 65 63 20 33 34 29 29 0a 28 64 65 66 69 vec 34)).(defi
0f50: 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 66 6f 72 ne (sdat-get-for
0f60: 63 65 2d 73 73 6c 20 20 20 20 20 20 20 20 20 20 ce-ssl
0f70: 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f vec) (vecto
0f80: 72 2d 72 65 66 20 20 76 65 63 20 33 35 29 29 0a r-ref vec 35)).
0f90: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
0fa0: 6e 3a 67 65 74 2d 73 68 61 72 65 64 20 76 65 63 n:get-shared vec
0fb0: 20 76 61 72 6e 61 6d 65 29 0a 20 20 28 68 61 73 varname). (has
0fc0: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
0fd0: 75 6c 74 20 28 76 65 63 74 6f 72 2d 72 65 66 20 ult (vector-ref
0fe0: 76 65 63 20 33 33 29 20 76 61 72 6e 61 6d 65 20 vec 33) varname
0ff0: 23 66 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 #f))..(define (s
1000: 64 61 74 2d 73 65 74 2d 64 62 74 79 70 65 21 20 dat-set-dbtype!
1010: 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 vec
1020: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
1030: 21 20 76 65 63 20 30 20 76 61 6c 29 29 0a 28 64 ! vec 0 val)).(d
1040: 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d efine (sdat-set-
1050: 64 62 69 6e 69 74 21 20 20 20 20 20 20 20 20 20 dbinit!
1060: 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 vec val)(ve
1070: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 31 20 ctor-set! vec 1
1080: 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 val)).(define (s
1090: 64 61 74 2d 73 65 74 2d 63 6f 6e 6e 21 20 20 20 dat-set-conn!
10a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 vec
10b0: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
10c0: 21 20 76 65 63 20 32 20 76 61 6c 29 29 0a 28 64 ! vec 2 val)).(d
10d0: 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d efine (sdat-set-
10e0: 70 61 72 61 6d 73 21 20 20 20 20 20 20 20 20 20 params!
10f0: 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 vec val)(ve
1100: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 33 20 ctor-set! vec 3
1110: 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 val)).(define (s
1120: 64 61 74 2d 73 65 74 2d 70 61 74 68 2d 70 61 72 dat-set-path-par
1130: 61 6d 73 21 20 20 20 20 20 20 20 20 20 76 65 63 ams! vec
1140: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
1150: 21 20 76 65 63 20 34 20 76 61 6c 29 29 0a 28 64 ! vec 4 val)).(d
1160: 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d efine (sdat-set-
1170: 73 65 73 73 69 6f 6e 2d 6b 65 79 21 20 20 20 20 session-key!
1180: 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 vec val)(ve
1190: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 35 20 ctor-set! vec 5
11a0: 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 val)).(define (s
11b0: 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e 2d dat-set-session-
11c0: 69 64 21 20 20 20 20 20 20 20 20 20 20 76 65 63 id! vec
11d0: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
11e0: 21 20 76 65 63 20 36 20 76 61 6c 29 29 0a 28 64 ! vec 6 val)).(d
11f0: 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d efine (sdat-set-
1200: 64 6f 6d 61 69 6e 21 20 20 20 20 20 20 20 20 20 domain!
1210: 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 vec val)(ve
1220: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 37 20 ctor-set! vec 7
1230: 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 val)).(define (s
1240: 64 61 74 2d 73 65 74 2d 74 6f 70 70 61 67 65 21 dat-set-toppage!
1250: 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 vec
1260: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
1270: 21 20 76 65 63 20 38 20 76 61 6c 29 29 0a 28 64 ! vec 8 val)).(d
1280: 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d efine (sdat-set-
1290: 70 61 67 65 21 20 20 20 20 20 20 20 20 20 20 20 page!
12a0: 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 vec val)(ve
12b0: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 39 20 ctor-set! vec 9
12c0: 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 val)).(define (s
12d0: 64 61 74 2d 73 65 74 2d 63 75 72 72 2d 70 61 67 dat-set-curr-pag
12e0: 65 21 20 20 20 20 20 20 20 20 20 20 20 76 65 63 e! vec
12f0: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
1300: 21 20 76 65 63 20 31 30 20 76 61 6c 29 29 0a 28 ! vec 10 val)).(
1310: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 define (sdat-set
1320: 2d 63 6f 6e 74 65 6e 74 2d 74 79 70 65 21 20 20 -content-type!
1330: 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 vec val)(v
1340: 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 31 ector-set! vec 1
1350: 31 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 1 val)).(define
1360: 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 2d 74 (sdat-set-page-t
1370: 79 70 65 21 20 20 20 20 20 20 20 20 20 20 20 76 ype! v
1380: 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 ec val)(vector-s
1390: 65 74 21 20 76 65 63 20 31 32 20 76 61 6c 29 29 et! vec 12 val))
13a0: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 .(define (sdat-s
13b0: 65 74 2d 73 72 6f 6f 74 21 20 20 20 20 20 20 20 et-sroot!
13c0: 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 vec val)
13d0: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 (vector-set! vec
13e0: 20 31 33 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 13 val)).(defin
13f0: 65 20 28 73 64 61 74 2d 73 65 74 2d 74 77 69 6b e (sdat-set-twik
1400: 69 64 69 72 21 20 20 20 20 20 20 20 20 20 20 20 idir!
1410: 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 vec val)(vector
1420: 2d 73 65 74 21 20 76 65 63 20 31 34 20 76 61 6c -set! vec 14 val
1430: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
1440: 2d 73 65 74 2d 70 61 67 65 64 61 74 21 20 20 20 -set-pagedat!
1450: 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 61 vec va
1460: 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 l)(vector-set! v
1470: 65 63 20 31 35 20 76 61 6c 29 29 0a 28 64 65 66 ec 15 val)).(def
1480: 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 61 6c ine (sdat-set-al
1490: 74 2d 70 61 67 65 2d 64 61 74 21 20 20 20 20 20 t-page-dat!
14a0: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
14b0: 6f 72 2d 73 65 74 21 20 76 65 63 20 31 36 20 76 or-set! vec 16 v
14c0: 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 al)).(define (sd
14d0: 61 74 2d 73 65 74 2d 70 61 67 65 76 61 72 73 21 at-set-pagevars!
14e0: 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 20 vec
14f0: 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 val)(vector-set!
1500: 20 76 65 63 20 31 37 20 76 61 6c 29 29 0a 28 64 vec 17 val)).(d
1510: 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d efine (sdat-set-
1520: 70 61 67 65 76 61 72 73 2d 62 65 66 6f 72 65 21 pagevars-before!
1530: 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 vec val)(ve
1540: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 31 38 ctor-set! vec 18
1550: 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 val)).(define (
1560: 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e sdat-set-session
1570: 76 61 72 73 21 20 20 20 20 20 20 20 20 20 76 65 vars! ve
1580: 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 c val)(vector-se
1590: 74 21 20 76 65 63 20 31 39 20 76 61 6c 29 29 0a t! vec 19 val)).
15a0: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 (define (sdat-se
15b0: 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 t-sessionvars-be
15c0: 66 6f 72 65 21 20 20 76 65 63 20 76 61 6c 29 28 fore! vec val)(
15d0: 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 vector-set! vec
15e0: 32 30 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 val)).(define
15f0: 20 28 73 64 61 74 2d 73 65 74 2d 67 6c 6f 62 61 (sdat-set-globa
1600: 6c 76 61 72 73 21 20 20 20 20 20 20 20 20 20 20 lvars!
1610: 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d vec val)(vector-
1620: 73 65 74 21 20 76 65 63 20 32 31 20 76 61 6c 29 set! vec 21 val)
1630: 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d ).(define (sdat-
1640: 73 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 2d 62 set-globalvars-b
1650: 65 66 6f 72 65 21 20 20 20 76 65 63 20 76 61 6c efore! vec val
1660: 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 )(vector-set! ve
1670: 63 20 32 32 20 76 61 6c 29 29 0a 28 64 65 66 69 c 22 val)).(defi
1680: 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 6c 6f 67 ne (sdat-set-log
1690: 70 74 21 20 20 20 20 20 20 20 20 20 20 20 20 20 pt!
16a0: 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f vec val)(vecto
16b0: 72 2d 73 65 74 21 20 76 65 63 20 32 33 20 76 61 r-set! vec 23 va
16c0: 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 l)).(define (sda
16d0: 74 2d 73 65 74 2d 66 6f 72 6d 64 61 74 21 20 20 t-set-formdat!
16e0: 20 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 vec v
16f0: 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 al)(vector-set!
1700: 76 65 63 20 32 34 20 76 61 6c 29 29 0a 28 64 65 vec 24 val)).(de
1710: 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 72 fine (sdat-set-r
1720: 65 71 75 65 73 74 2d 6d 65 74 68 6f 64 21 20 20 equest-method!
1730: 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 vec val)(vec
1740: 74 6f 72 2d 73 65 74 21 20 76 65 63 20 32 35 20 tor-set! vec 25
1750: 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 val)).(define (s
1760: 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e 2d dat-set-session-
1770: 63 6f 6f 6b 69 65 21 20 20 20 20 20 20 76 65 63 cookie! vec
1780: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
1790: 21 20 76 65 63 20 32 36 20 76 61 6c 29 29 0a 28 ! vec 26 val)).(
17a0: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 define (sdat-set
17b0: 2d 63 75 72 72 2d 65 72 72 21 20 20 20 20 20 20 -curr-err!
17c0: 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 vec val)(v
17d0: 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 32 ector-set! vec 2
17e0: 37 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 7 val)).(define
17f0: 28 73 64 61 74 2d 73 65 74 2d 6c 6f 67 2d 70 6f (sdat-set-log-po
1800: 72 74 21 20 20 20 20 20 20 20 20 20 20 20 20 76 rt! v
1810: 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 ec val)(vector-s
1820: 65 74 21 20 76 65 63 20 32 38 20 76 61 6c 29 29 et! vec 28 val))
1830: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 .(define (sdat-s
1840: 65 74 2d 6c 6f 67 66 69 6c 65 21 20 20 20 20 20 et-logfile!
1850: 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 vec val)
1860: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 (vector-set! vec
1870: 20 32 39 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 29 val)).(defin
1880: 65 20 28 73 64 61 74 2d 73 65 74 2d 73 65 65 6e e (sdat-set-seen
1890: 2d 70 61 67 65 73 21 20 20 20 20 20 20 20 20 20 -pages!
18a0: 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 vec val)(vector
18b0: 2d 73 65 74 21 20 76 65 63 20 33 30 20 76 61 6c -set! vec 30 val
18c0: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
18d0: 2d 73 65 74 2d 70 61 67 65 2d 64 69 72 2d 73 74 -set-page-dir-st
18e0: 79 6c 65 21 20 20 20 20 20 20 76 65 63 20 76 61 yle! vec va
18f0: 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 l)(vector-set! v
1900: 65 63 20 33 31 20 76 61 6c 29 29 0a 28 64 65 66 ec 31 val)).(def
1910: 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 64 65 ine (sdat-set-de
1920: 62 75 67 6d 6f 64 65 21 20 20 20 20 20 20 20 20 bugmode!
1930: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
1940: 6f 72 2d 73 65 74 21 20 76 65 63 20 33 32 20 76 or-set! vec 32 v
1950: 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 al)).(define (sd
1960: 61 74 2d 73 65 74 2d 73 68 61 72 65 64 2d 68 61 at-set-shared-ha
1970: 73 68 21 20 20 20 20 20 20 20 20 20 76 65 63 20 sh! vec
1980: 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 val)(vector-set!
1990: 20 76 65 63 20 33 33 20 76 61 6c 29 29 0a 28 64 vec 33 val)).(d
19a0: 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d efine (sdat-set-
19b0: 73 63 72 69 70 74 21 20 20 20 20 20 20 20 20 20 script!
19c0: 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 vec val)(ve
19d0: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 33 34 ctor-set! vec 34
19e0: 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 val)).(define (
19f0: 73 64 61 74 2d 73 65 74 2d 66 6f 72 63 65 2d 73 sdat-set-force-s
1a00: 73 6c 21 20 20 20 20 20 20 20 20 20 20 20 76 65 sl! ve
1a10: 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 c val)(vector-se
1a20: 74 21 20 76 65 63 20 33 35 20 76 61 6c 29 29 0a t! vec 35 val)).
1a30: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
1a40: 6e 3a 73 65 74 2d 73 68 61 72 65 64 21 20 76 65 n:set-shared! ve
1a50: 63 20 76 61 72 6e 61 6d 65 20 76 61 6c 29 0a 20 c varname val).
1a60: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
1a70: 21 20 28 76 65 63 74 6f 72 2d 72 65 66 20 76 65 ! (vector-ref ve
1a80: 63 20 33 33 29 20 76 61 72 6e 61 6d 65 20 76 61 c 33) varname va
1a90: 6c 29 29 0a 0a 3b 3b 20 54 68 65 20 67 6c 6f 62 l))..;; The glob
1aa0: 61 6c 20 73 65 73 73 69 6f 6e 0a 28 64 65 66 69 al session.(defi
1ab0: 6e 65 20 73 3a 73 65 73 73 69 6f 6e 20 28 6d 61 ne s:session (ma
1ac0: 6b 65 2d 73 64 61 74 29 29 0a 0a 3b 3b 20 53 50 ke-sdat))..;; SP
1ad0: 4c 49 54 20 49 4e 54 4f 20 53 54 52 41 49 47 48 LIT INTO STRAIGH
1ae0: 54 20 46 4f 52 57 41 52 44 20 49 4e 49 54 20 41 T FORWARD INIT A
1af0: 4e 44 20 43 4f 4d 50 4c 45 58 20 49 4e 49 54 0a ND COMPLEX INIT.
1b00: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
1b10: 3a 69 6e 69 74 69 61 6c 69 7a 65 20 73 65 6c 66 :initialize self
1b20: 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 64 62 ). (sdat-set-db
1b30: 74 79 70 65 21 20 73 65 6c 66 20 20 20 20 20 20 type! self
1b40: 27 70 67 29 0a 20 20 28 73 64 61 74 2d 73 65 74 'pg). (sdat-set
1b50: 2d 70 61 67 65 21 20 73 65 6c 66 20 20 20 20 20 -page! self
1b60: 20 20 20 22 68 6f 6d 65 22 29 20 20 20 20 20 20 "home")
1b70: 20 20 3b 3b 20 74 68 65 73 65 20 61 72 65 20 64 ;; these are d
1b80: 65 66 61 75 6c 74 73 0a 20 20 28 73 64 61 74 2d efaults. (sdat-
1b90: 73 65 74 2d 63 75 72 72 2d 70 61 67 65 21 20 73 set-curr-page! s
1ba0: 65 6c 66 20 20 20 22 68 6f 6d 65 22 29 0a 20 20 elf "home").
1bb0: 28 73 64 61 74 2d 73 65 74 2d 63 6f 6e 74 65 6e (sdat-set-conten
1bc0: 74 2d 74 79 70 65 21 20 73 65 6c 66 20 22 43 6f t-type! self "Co
1bd0: 6e 74 65 6e 74 2d 74 79 70 65 3a 20 74 65 78 74 ntent-type: text
1be0: 2f 68 74 6d 6c 3b 20 63 68 61 72 73 65 74 3d 69 /html; charset=i
1bf0: 73 6f 2d 38 38 35 39 2d 31 5c 6e 5c 6e 22 29 0a so-8859-1\n\n").
1c00: 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 (sdat-set-page
1c10: 2d 74 79 70 65 21 20 73 65 6c 66 20 20 20 27 68 -type! self 'h
1c20: 74 6d 6c 29 0a 20 20 28 73 64 61 74 2d 73 65 74 tml). (sdat-set
1c30: 2d 74 6f 70 70 61 67 65 21 20 73 65 6c 66 20 20 -toppage! self
1c40: 20 20 20 22 69 6e 64 65 78 22 29 0a 20 20 28 73 "index"). (s
1c50: 64 61 74 2d 73 65 74 2d 70 61 72 61 6d 73 21 20 dat-set-params!
1c60: 73 65 6c 66 20 20 20 20 20 20 27 28 29 29 20 20 self '())
1c70: 20 20 20 20 20 20 20 20 20 3b 3b 0a 20 20 28 73 ;;. (s
1c80: 64 61 74 2d 73 65 74 2d 70 61 74 68 2d 70 61 72 dat-set-path-par
1c90: 61 6d 73 21 20 73 65 6c 66 20 27 28 29 29 0a 20 ams! self '()).
1ca0: 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 (sdat-set-sessi
1cb0: 6f 6e 2d 6b 65 79 21 20 73 65 6c 66 20 23 66 29 on-key! self #f)
1cc0: 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 67 . (sdat-set-pag
1cd0: 65 64 61 74 21 20 73 65 6c 66 20 20 20 20 20 27 edat! self '
1ce0: 28 29 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d ()). (sdat-set-
1cf0: 61 6c 74 2d 70 61 67 65 2d 64 61 74 21 20 73 65 alt-page-dat! se
1d00: 6c 66 20 23 66 29 0a 20 20 28 73 64 61 74 2d 73 lf #f). (sdat-s
1d10: 65 74 2d 73 72 6f 6f 74 21 20 73 65 6c 66 20 20 et-sroot! self
1d20: 20 20 20 20 20 22 2e 2f 22 29 0a 20 20 28 73 64 "./"). (sd
1d30: 61 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e 2d 63 at-set-session-c
1d40: 6f 6f 6b 69 65 21 20 73 65 6c 66 20 23 66 29 0a ookie! self #f).
1d50: 20 20 28 73 64 61 74 2d 73 65 74 2d 63 75 72 72 (sdat-set-curr
1d60: 2d 65 72 72 21 20 73 65 6c 66 20 23 66 29 0a 20 -err! self #f).
1d70: 20 28 73 64 61 74 2d 73 65 74 2d 6c 6f 67 2d 70 (sdat-set-log-p
1d80: 6f 72 74 21 20 73 65 6c 66 20 28 63 75 72 72 65 ort! self (curre
1d90: 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a nt-error-port)).
1da0: 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 65 6e (sdat-set-seen
1db0: 2d 70 61 67 65 73 21 20 73 65 6c 66 20 27 28 29 -pages! self '()
1dc0: 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 ). (sdat-set-pa
1dd0: 67 65 2d 64 69 72 2d 73 74 79 6c 65 21 20 73 65 ge-dir-style! se
1de0: 6c 66 20 23 74 29 20 3b 3b 20 23 74 20 3a 20 70 lf #t) ;; #t : p
1df0: 61 67 65 73 2f 3c 70 61 67 65 6e 61 6d 65 3e 5f ages/<pagename>_
1e00: 28 76 69 65 77 7c 63 6e 74 6c 29 2e 73 63 6d 0a (view|cntl).scm.
1e10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1e20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1e30: 20 20 20 20 20 20 3b 3b 20 23 66 20 3a 20 70 61 ;; #f : pa
1e40: 67 65 73 2f 3c 70 61 67 65 6e 61 6d 65 3e 2f 28 ges/<pagename>/(
1e50: 76 69 65 77 7c 63 6f 6e 74 72 6f 6c 29 2e 73 63 view|control).sc
1e60: 6d 20 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 64 m . (sdat-set-d
1e70: 65 62 75 67 6d 6f 64 65 21 20 20 20 20 20 20 20 ebugmode!
1e80: 20 20 20 73 65 6c 66 20 23 66 29 0a 20 20 09 09 self #f). ..
1e90: 09 20 20 20 20 20 0a 20 20 28 73 64 61 74 2d 73 . . (sdat-s
1ea0: 65 74 2d 70 61 67 65 76 61 72 73 21 20 20 20 20 et-pagevars!
1eb0: 20 20 20 20 20 20 20 73 65 6c 66 20 28 6d 61 6b self (mak
1ec0: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 e-hash-table)).
1ed0: 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 (sdat-set-sessi
1ee0: 6f 6e 76 61 72 73 21 20 20 20 20 20 20 20 20 73 onvars! s
1ef0: 65 6c 66 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 elf (make-hash-t
1f00: 61 62 6c 65 29 29 0a 20 20 28 73 64 61 74 2d 73 able)). (sdat-s
1f10: 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 21 20 20 et-globalvars!
1f20: 20 20 20 20 20 20 20 73 65 6c 66 20 28 6d 61 6b self (mak
1f30: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 e-hash-table)).
1f40: 20 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 76 (sdat-set-pagev
1f50: 61 72 73 2d 62 65 66 6f 72 65 21 20 20 20 20 73 ars-before! s
1f60: 65 6c 66 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 elf (make-hash-t
1f70: 61 62 6c 65 29 29 0a 20 20 28 73 64 61 74 2d 73 able)). (sdat-s
1f80: 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 2d 62 et-sessionvars-b
1f90: 65 66 6f 72 65 21 20 73 65 6c 66 20 28 6d 61 6b efore! self (mak
1fa0: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 e-hash-table)).
1fb0: 20 28 73 64 61 74 2d 73 65 74 2d 67 6c 6f 62 61 (sdat-set-globa
1fc0: 6c 76 61 72 73 2d 62 65 66 6f 72 65 21 20 20 73 lvars-before! s
1fd0: 65 6c 66 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 elf (make-hash-t
1fe0: 61 62 6c 65 29 29 0a 20 20 28 73 64 61 74 2d 73 able)). (sdat-s
1ff0: 65 74 2d 64 6f 6d 61 69 6e 21 20 20 20 20 20 20 et-domain!
2000: 20 20 20 20 20 20 20 73 65 6c 66 20 22 6c 6f 63 self "loc
2010: 61 68 6f 73 74 22 29 20 20 20 3b 3b 20 65 6e 64 ahost") ;; end
2020: 20 6f 66 20 64 65 66 61 75 6c 74 73 0a 20 20 28 of defaults. (
2030: 73 64 61 74 2d 73 65 74 2d 73 63 72 69 70 74 21 sdat-set-script!
2040: 20 20 20 20 20 20 20 20 20 20 20 20 20 73 65 6c sel
2050: 66 20 23 66 29 0a 20 20 28 73 64 61 74 2d 73 65 f #f). (sdat-se
2060: 74 2d 66 6f 72 63 65 2d 73 73 6c 21 20 20 20 20 t-force-ssl!
2070: 20 20 20 20 20 20 73 65 6c 66 20 23 66 29 0a 20 self #f).
2080: 20 28 6c 65 74 2a 20 28 28 72 61 77 63 6f 6e 66 (let* ((rawconf
2090: 69 67 64 61 74 20 28 73 65 73 73 69 6f 6e 3a 72 igdat (session:r
20a0: 65 61 64 2d 63 6f 6e 66 69 67 20 73 65 6c 66 29 ead-config self)
20b0: 29 0a 09 20 28 63 6f 6e 66 69 67 64 61 74 20 28 ).. (configdat (
20c0: 69 66 20 72 61 77 63 6f 6e 66 69 67 64 61 74 20 if rawconfigdat
20d0: 28 65 76 61 6c 20 72 61 77 63 6f 6e 66 69 67 64 (eval rawconfigd
20e0: 61 74 29 20 27 28 29 29 29 0a 09 20 28 73 72 6f at) '())).. (sro
20f0: 6f 74 20 20 20 20 20 28 73 3a 66 69 6e 64 2d 70 ot (s:find-p
2100: 61 72 61 6d 20 27 73 72 6f 6f 74 20 20 20 20 63 aram 'sroot c
2110: 6f 6e 66 69 67 64 61 74 29 29 0a 09 20 28 6c 6f onfigdat)).. (lo
2120: 67 66 69 6c 65 20 20 20 28 73 3a 66 69 6e 64 2d gfile (s:find-
2130: 70 61 72 61 6d 20 27 6c 6f 67 66 69 6c 65 20 20 param 'logfile
2140: 63 6f 6e 66 69 67 64 61 74 29 29 0a 09 20 28 64 configdat)).. (d
2150: 62 74 79 70 65 20 20 20 20 28 73 3a 66 69 6e 64 btype (s:find
2160: 2d 70 61 72 61 6d 20 27 64 62 74 79 70 65 20 20 -param 'dbtype
2170: 20 63 6f 6e 66 69 67 64 61 74 29 29 0a 09 20 28 configdat)).. (
2180: 64 62 69 6e 69 74 20 20 20 20 28 73 3a 66 69 6e dbinit (s:fin
2190: 64 2d 70 61 72 61 6d 20 27 64 62 69 6e 69 74 20 d-param 'dbinit
21a0: 20 20 63 6f 6e 66 69 67 64 61 74 29 29 0a 09 20 configdat))..
21b0: 28 64 6f 6d 61 69 6e 20 20 20 20 28 73 3a 66 69 (domain (s:fi
21c0: 6e 64 2d 70 61 72 61 6d 20 27 64 6f 6d 61 69 6e nd-param 'domain
21d0: 20 20 20 63 6f 6e 66 69 67 64 61 74 29 29 0a 09 configdat))..
21e0: 20 28 74 77 69 6b 69 64 69 72 20 20 28 73 3a 66 (twikidir (s:f
21f0: 69 6e 64 2d 70 61 72 61 6d 20 27 74 77 69 6b 69 ind-param 'twiki
2200: 64 69 72 20 63 6f 6e 66 69 67 64 61 74 29 29 0a dir configdat)).
2210: 09 20 28 70 61 67 65 2d 64 69 72 20 20 28 73 3a . (page-dir (s:
2220: 66 69 6e 64 2d 70 61 72 61 6d 20 27 70 61 67 65 find-param 'page
2230: 2d 64 69 72 2d 73 74 79 6c 65 20 63 6f 6e 66 69 -dir-style confi
2240: 67 64 61 74 29 29 0a 09 20 28 64 65 62 75 67 6d gdat)).. (debugm
2250: 6f 64 65 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 ode (s:find-para
2260: 6d 20 27 64 65 62 75 67 6d 6f 64 65 20 63 6f 6e m 'debugmode con
2270: 66 69 67 64 61 74 29 29 0a 20 20 20 20 20 20 20 figdat)).
2280: 20 20 28 73 63 72 69 70 74 20 20 20 20 28 73 3a (script (s:
2290: 66 69 6e 64 2d 70 61 72 61 6d 20 27 73 63 72 69 find-param 'scri
22a0: 70 74 20 20 20 20 63 6f 6e 66 69 67 64 61 74 29 pt configdat)
22b0: 29 0a 09 20 28 66 6f 72 63 65 2d 73 73 6c 20 28 ).. (force-ssl (
22c0: 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 27 66 6f s:find-param 'fo
22d0: 72 63 65 2d 73 73 6c 20 63 6f 6e 66 69 67 64 61 rce-ssl configda
22e0: 74 29 29 29 0a 20 20 20 20 28 69 66 20 73 72 6f t))). (if sro
22f0: 6f 74 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d ot (sdat-set-
2300: 73 72 6f 6f 74 21 20 20 20 20 73 65 6c 66 20 73 sroot! self s
2310: 72 6f 6f 74 29 29 0a 20 20 20 20 28 69 66 20 6c root)). (if l
2320: 6f 67 66 69 6c 65 20 20 28 73 64 61 74 2d 73 65 ogfile (sdat-se
2330: 74 2d 6c 6f 67 66 69 6c 65 21 20 20 73 65 6c 66 t-logfile! self
2340: 20 6c 6f 67 66 69 6c 65 29 29 0a 20 20 20 20 28 logfile)). (
2350: 69 66 20 64 62 74 79 70 65 20 20 20 28 73 64 61 if dbtype (sda
2360: 74 2d 73 65 74 2d 64 62 74 79 70 65 21 20 20 20 t-set-dbtype!
2370: 73 65 6c 66 20 64 62 74 79 70 65 29 29 0a 20 20 self dbtype)).
2380: 20 20 28 69 66 20 64 62 69 6e 69 74 20 20 20 28 (if dbinit (
2390: 73 64 61 74 2d 73 65 74 2d 64 62 69 6e 69 74 21 sdat-set-dbinit!
23a0: 20 20 20 73 65 6c 66 20 64 62 69 6e 69 74 29 29 self dbinit))
23b0: 0a 20 20 20 20 28 69 66 20 64 6f 6d 61 69 6e 20 . (if domain
23c0: 20 20 28 73 64 61 74 2d 73 65 74 2d 64 6f 6d 61 (sdat-set-doma
23d0: 69 6e 21 20 20 20 73 65 6c 66 20 64 6f 6d 61 69 in! self domai
23e0: 6e 29 29 0a 20 20 20 20 28 69 66 20 74 77 69 6b n)). (if twik
23f0: 69 64 69 72 20 28 73 64 61 74 2d 73 65 74 2d 74 idir (sdat-set-t
2400: 77 69 6b 69 64 69 72 21 20 73 65 6c 66 20 74 77 wikidir! self tw
2410: 69 6b 69 64 69 72 29 29 0a 20 20 20 20 28 69 66 ikidir)). (if
2420: 20 64 65 62 75 67 6d 6f 64 65 20 28 73 64 61 74 debugmode (sdat
2430: 2d 73 65 74 2d 64 65 62 75 67 6d 6f 64 65 21 20 -set-debugmode!
2440: 73 65 6c 66 20 64 65 62 75 67 6d 6f 64 65 29 29 self debugmode))
2450: 0a 20 20 20 20 28 69 66 20 73 63 72 69 70 74 20 . (if script
2460: 20 20 20 28 73 64 61 74 2d 73 65 74 2d 73 63 72 (sdat-set-scr
2470: 69 70 74 21 20 20 20 20 73 65 6c 66 20 73 63 72 ipt! self scr
2480: 69 70 74 29 29 0a 20 20 20 20 28 69 66 20 66 6f ipt)). (if fo
2490: 72 63 65 2d 73 73 6c 20 28 73 64 61 74 2d 73 65 rce-ssl (sdat-se
24a0: 74 2d 66 6f 72 63 65 2d 73 73 6c 21 20 73 65 6c t-force-ssl! sel
24b0: 66 20 66 6f 72 63 65 2d 73 73 6c 29 29 0a 20 20 f force-ssl)).
24c0: 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 (sdat-set-page
24d0: 2d 64 69 72 2d 73 74 79 6c 65 21 20 73 65 6c 66 -dir-style! self
24e0: 20 70 61 67 65 2d 64 69 72 29 0a 20 20 20 20 3b page-dir). ;
24f0: 3b 20 28 70 72 69 6e 74 20 22 63 6f 6e 66 69 67 ; (print "config
2500: 64 61 74 3a 20 22 29 28 70 70 20 63 6f 6e 66 69 dat: ")(pp confi
2510: 67 64 61 74 29 0a 20 20 20 20 28 69 66 20 64 65 gdat). (if de
2520: 62 75 67 6d 6f 64 65 0a 09 28 73 65 73 73 69 6f bugmode..(sessio
2530: 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 73 72 6f 6f n:log self "sroo
2540: 74 3a 20 22 20 73 72 6f 6f 74 20 22 20 6c 6f 67 t: " sroot " log
2550: 66 69 6c 65 3a 20 22 20 6c 6f 67 66 69 6c 65 20 file: " logfile
2560: 22 20 64 62 74 79 70 65 3a 20 22 20 64 62 74 79 " dbtype: " dbty
2570: 70 65 20 0a 09 09 20 20 20 20 20 22 20 64 62 69 pe ... " dbi
2580: 6e 69 74 3a 20 22 20 64 62 69 6e 69 74 20 22 20 nit: " dbinit "
2590: 64 6f 6d 61 69 6e 3a 20 22 20 64 6f 6d 61 69 6e domain: " domain
25a0: 20 22 20 70 61 67 65 2d 64 69 72 2d 73 74 79 6c " page-dir-styl
25b0: 65 3a 20 22 20 70 61 67 65 2d 64 69 72 29 29 0a e: " page-dir)).
25c0: 20 20 20 20 29 0a 20 20 28 73 64 61 74 2d 73 65 ). (sdat-se
25d0: 74 2d 73 68 61 72 65 64 2d 68 61 73 68 21 20 73 t-shared-hash! s
25e0: 65 6c 66 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 elf (make-hash-t
25f0: 61 62 6c 65 29 29 0a 20 20 29 0a 0a 3b 3b 20 55 able)). )..;; U
2600: 73 65 64 20 66 6f 72 20 74 68 65 20 73 74 72 61 sed for the stra
2610: 6e 67 65 6c 79 20 69 6e 63 6f 6e 73 69 73 74 65 ngely inconsiste
2620: 6e 74 20 68 61 6e 64 6c 69 6e 67 20 6f 66 20 74 nt handling of t
2630: 68 65 20 63 6f 6e 66 69 67 20 66 69 6c 65 2e 20 he config file.
2640: 41 20 62 65 74 74 65 72 20 77 61 79 20 69 73 20 A better way is
2650: 6e 65 65 64 65 64 2e 0a 3b 3b 0a 3b 3b 20 20 20 needed..;;.;;
2660: 28 6c 65 74 20 28 28 64 62 74 79 70 65 20 28 73 (let ((dbtype (s
2670: 64 61 74 2d 67 65 74 2d 64 62 74 79 70 65 20 73 dat-get-dbtype s
2680: 65 6c 66 29 29 29 0a 3b 3b 20 20 20 20 20 28 70 elf))).;; (p
2690: 72 69 6e 74 20 22 64 62 74 79 70 65 3a 20 22 20 rint "dbtype: "
26a0: 64 62 74 79 70 65 29 0a 3b 3b 20 20 20 20 20 28 dbtype).;; (
26b0: 73 64 61 74 2d 73 65 74 2d 64 62 74 79 70 65 21 sdat-set-dbtype!
26c0: 20 73 65 6c 66 20 28 65 76 61 6c 20 64 62 74 79 self (eval dbty
26d0: 70 65 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 pe))))..(define
26e0: 28 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 20 73 (session:setup s
26f0: 65 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 64 62 elf). (let ((db
2700: 74 79 70 65 20 20 20 20 28 73 64 61 74 2d 67 65 type (sdat-ge
2710: 74 2d 64 62 74 79 70 65 20 73 65 6c 66 29 29 0a t-dbtype self)).
2720: 09 28 64 65 62 75 67 6d 6f 64 65 20 28 73 64 61 .(debugmode (sda
2730: 74 2d 67 65 74 2d 64 65 62 75 67 6d 6f 64 65 20 t-get-debugmode
2740: 73 65 6c 66 29 29 0a 09 28 64 62 69 6e 69 74 20 self))..(dbinit
2750: 20 20 20 28 65 76 61 6c 20 28 73 64 61 74 2d 67 (eval (sdat-g
2760: 65 74 2d 64 62 69 6e 69 74 20 73 65 6c 66 29 29 et-dbinit self))
2770: 29 0a 09 28 64 62 65 78 69 73 74 73 20 20 23 66 )..(dbexists #f
2780: 29 29 0a 20 20 20 20 28 6c 65 74 20 28 28 64 62 )). (let ((db
2790: 66 6e 61 6d 65 20 28 61 6c 69 73 74 2d 72 65 66 fname (alist-ref
27a0: 20 27 64 62 6e 61 6d 65 20 64 62 69 6e 69 74 29 'dbname dbinit)
27b0: 29 29 0a 20 20 20 20 20 20 28 69 66 20 64 65 62 )). (if deb
27c0: 75 67 6d 6f 64 65 20 28 73 65 73 73 69 6f 6e 3a ugmode (session:
27d0: 6c 6f 67 20 73 65 6c 66 20 22 73 65 73 73 69 6f log self "sessio
27e0: 6e 3a 73 65 74 75 70 20 64 62 66 6e 61 6d 65 3d n:setup dbfname=
27f0: 22 20 64 62 66 6e 61 6d 65 20 22 2c 20 64 62 74 " dbfname ", dbt
2800: 79 70 65 3d 22 20 64 62 74 79 70 65 20 22 2c 20 ype=" dbtype ",
2810: 64 62 69 6e 69 74 3d 22 20 64 62 69 6e 69 74 29 dbinit=" dbinit)
2820: 29 0a 20 20 20 20 20 20 28 69 66 20 28 65 71 3f ). (if (eq?
2830: 20 64 62 74 79 70 65 20 27 73 71 6c 69 74 65 33 dbtype 'sqlite3
2840: 29 0a 09 20 20 3b 3b 20 54 68 65 20 27 61 75 74 ).. ;; The 'aut
2850: 6f 20 6d 65 74 68 6f 64 20 77 69 6c 6c 20 64 69 o method will di
2860: 73 74 72 69 62 75 74 65 20 64 62 73 20 61 63 72 stribute dbs acr
2870: 6f 73 73 20 74 68 65 20 64 69 73 6b 20 75 73 69 oss the disk usi
2880: 6e 67 20 68 61 73 68 0a 09 20 20 3b 3b 20 6f 66 ng hash.. ;; of
2890: 20 75 73 65 72 20 68 6f 73 74 20 61 6e 64 20 75 user host and u
28a0: 73 65 72 2e 20 54 4f 44 4f 0a 09 20 20 3b 3b 20 ser. TODO.. ;;
28b0: 28 69 66 20 28 65 71 3f 20 64 62 66 6e 61 6d 65 (if (eq? dbfname
28c0: 20 27 61 75 74 6f 29 20 3b 3b 20 54 68 69 73 20 'auto) ;; This
28d0: 69 73 20 74 68 65 20 61 75 74 6f 20 61 73 73 69 is the auto assi
28e0: 67 6e 6d 65 6e 74 20 6f 66 20 61 20 64 62 20 62 gnment of a db b
28f0: 61 73 65 64 20 6f 6e 20 68 61 73 68 20 6f 66 20 ased on hash of
2900: 49 50 0a 09 20 20 28 6c 65 74 20 28 28 64 62 70 IP.. (let ((dbp
2910: 61 74 68 20 28 70 61 74 68 6e 61 6d 65 2d 64 69 ath (pathname-di
2920: 72 65 63 74 6f 72 79 20 64 62 66 6e 61 6d 65 29 rectory dbfname)
2930: 29 29 20 20 3b 3b 20 64 6f 20 61 20 63 6f 75 70 )) ;; do a coup
2940: 6c 65 20 73 61 6e 69 74 79 20 63 68 65 63 6b 73 le sanity checks
2950: 20 68 65 72 65 20 74 6f 20 6d 61 6b 65 20 73 65 here to make se
2960: 74 74 69 6e 67 20 75 70 20 65 61 73 69 65 72 0a tting up easier.
2970: 09 20 20 20 20 28 69 66 20 64 65 62 75 67 6d 6f . (if debugmo
2980: 64 65 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 de (session:log
2990: 73 65 6c 66 20 22 49 4e 46 4f 3a 20 73 65 74 74 self "INFO: sett
29a0: 69 6e 67 20 75 70 20 66 6f 72 20 73 71 6c 69 74 ing up for sqlit
29b0: 65 33 20 64 62 20 61 63 63 65 73 73 20 74 6f 20 e3 db access to
29c0: 22 20 64 62 66 6e 61 6d 65 29 29 0a 09 20 20 20 " dbfname))..
29d0: 20 28 69 66 20 28 6e 6f 74 20 28 66 69 6c 65 2d (if (not (file-
29e0: 77 72 69 74 65 2d 61 63 63 65 73 73 3f 20 64 62 write-access? db
29f0: 70 61 74 68 29 29 0a 09 09 28 73 65 73 73 69 6f path))...(sessio
2a00: 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 57 41 52 4e n:log self "WARN
2a10: 49 4e 47 3a 20 43 61 6e 6e 6f 74 20 77 72 69 74 ING: Cannot writ
2a20: 65 20 74 6f 20 22 20 64 62 70 61 74 68 29 0a 09 e to " dbpath)..
2a30: 09 28 69 66 20 64 65 62 75 67 6d 6f 64 65 20 28 .(if debugmode (
2a40: 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 session:log self
2a50: 20 22 49 4e 46 4f 3a 20 22 20 64 62 70 61 74 68 "INFO: " dbpath
2a60: 20 22 20 69 73 20 77 72 69 74 65 61 62 6c 65 22 " is writeable"
2a70: 29 29 29 0a 09 20 20 20 20 28 69 66 20 28 66 69 ))).. (if (fi
2a80: 6c 65 2d 65 78 69 73 74 73 3f 20 64 62 66 6e 61 le-exists? dbfna
2a90: 6d 65 29 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 me)...(begin...
2aa0: 20 3b 3b 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 ;; (session:log
2ab0: 20 73 65 6c 66 20 22 73 65 74 74 69 6e 67 20 64 self "setting d
2ac0: 62 65 78 69 73 74 73 20 74 6f 20 23 74 22 29 0a bexists to #t").
2ad0: 09 09 20 20 28 73 65 74 21 20 64 62 65 78 69 73 .. (set! dbexis
2ae0: 74 73 20 23 74 29 29 29 29 0a 09 20 20 28 69 66 ts #t)))).. (if
2af0: 20 64 65 62 75 67 6d 6f 64 65 20 28 73 65 73 73 debugmode (sess
2b00: 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 49 4e ion:log self "IN
2b10: 46 4f 3a 20 73 65 74 74 69 6e 67 20 75 70 20 66 FO: setting up f
2b20: 6f 72 20 70 67 20 64 62 20 61 63 63 65 73 73 20 or pg db access
2b30: 74 6f 20 61 63 63 6f 75 6e 74 20 69 6e 66 6f 20 to account info
2b40: 22 20 64 62 69 6e 69 74 29 29 29 0a 20 20 20 20 " dbinit))).
2b50: 20 20 28 69 66 20 64 65 62 75 67 6d 6f 64 65 20 (if debugmode
2b60: 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c (session:log sel
2b70: 66 20 22 64 62 74 79 70 65 3a 20 22 20 64 62 74 f "dbtype: " dbt
2b80: 79 70 65 20 22 20 64 62 66 6e 61 6d 65 3a 20 22 ype " dbfname: "
2b90: 20 64 62 66 6e 61 6d 65 20 22 20 64 62 65 78 69 dbfname " dbexi
2ba0: 73 74 73 3a 20 22 20 64 62 65 78 69 73 74 73 29 sts: " dbexists)
2bb0: 29 29 0a 20 20 20 20 28 73 64 61 74 2d 73 65 74 )). (sdat-set
2bc0: 2d 63 6f 6e 6e 21 20 73 65 6c 66 20 28 64 62 69 -conn! self (dbi
2bd0: 3a 6f 70 65 6e 20 64 62 74 79 70 65 20 64 62 69 :open dbtype dbi
2be0: 6e 69 74 29 29 0a 20 20 20 20 28 73 65 74 21 20 nit)). (set!
2bf0: 2a 64 62 2a 20 28 73 64 61 74 2d 67 65 74 2d 63 *db* (sdat-get-c
2c00: 6f 6e 6e 20 73 65 6c 66 29 29 0a 20 20 20 20 28 onn self)). (
2c10: 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 64 62 65 if (and (not dbe
2c20: 78 69 73 74 73 29 28 65 71 3f 20 64 62 74 79 70 xists)(eq? dbtyp
2c30: 65 20 27 73 71 6c 69 74 65 33 29 29 0a 20 09 28 e 'sqlite3)). .(
2c40: 62 65 67 69 6e 0a 09 20 20 28 70 72 69 6e 74 20 begin.. (print
2c50: 22 57 41 52 4e 49 4e 47 3a 20 53 65 74 74 69 6e "WARNING: Settin
2c60: 67 20 75 70 20 73 65 73 73 69 6f 6e 20 64 62 20 g up session db
2c70: 77 69 74 68 20 73 71 6c 69 74 65 33 22 29 0a 09 with sqlite3")..
2c80: 20 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 (session:setup
2c90: 2d 64 62 20 73 65 6c 66 29 29 29 0a 20 20 20 20 -db self))).
2ca0: 28 73 65 73 73 69 6f 6e 3a 70 72 6f 63 65 73 73 (session:process
2cb0: 2d 75 72 6c 2d 70 61 74 68 20 73 65 6c 66 29 0a -url-path self).
2cc0: 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 (session:set
2cd0: 75 70 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 up-session-key s
2ce0: 65 6c 66 29 0a 20 20 20 20 3b 3b 20 63 61 70 74 elf). ;; capt
2cf0: 75 72 65 20 73 74 64 69 6e 20 69 66 20 74 68 69 ure stdin if thi
2d00: 73 20 69 73 20 61 20 50 4f 53 54 0a 20 20 20 20 s is a POST.
2d10: 28 73 64 61 74 2d 73 65 74 2d 72 65 71 75 65 73 (sdat-set-reques
2d20: 74 2d 6d 65 74 68 6f 64 21 20 73 65 6c 66 20 28 t-method! self (
2d30: 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d get-environment-
2d40: 76 61 72 69 61 62 6c 65 20 22 52 45 51 55 45 53 variable "REQUES
2d50: 54 5f 4d 45 54 48 4f 44 22 29 29 0a 20 20 20 20 T_METHOD")).
2d60: 28 73 64 61 74 2d 73 65 74 2d 66 6f 72 6d 64 61 (sdat-set-formda
2d70: 74 21 20 73 65 6c 66 20 28 66 6f 72 6d 64 61 74 t! self (formdat
2d80: 3a 6c 6f 61 64 2d 61 6c 6c 29 29 29 29 0a 0a 3b :load-all))))..;
2d90: 3b 20 73 65 74 75 70 20 74 68 65 20 64 62 20 77 ; setup the db w
2da0: 69 74 68 20 73 65 73 73 69 6f 6e 20 74 61 62 6c ith session tabl
2db0: 65 73 2c 20 77 6f 72 6b 73 20 66 6f 72 20 73 71 es, works for sq
2dc0: 6c 69 74 65 20 6f 6e 6c 79 20 72 69 67 68 74 20 lite only right
2dd0: 6e 6f 77 0a 28 64 65 66 69 6e 65 20 28 73 65 73 now.(define (ses
2de0: 73 69 6f 6e 3a 73 65 74 75 70 2d 64 62 20 73 65 sion:setup-db se
2df0: 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 63 6f 6e lf). (let ((con
2e00: 6e 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e n (sdat-get-conn
2e10: 20 73 65 6c 66 29 29 29 0a 20 20 20 20 28 66 6f self))). (fo
2e20: 72 2d 65 61 63 68 20 0a 20 20 20 20 20 28 6c 61 r-each . (la
2e30: 6d 62 64 61 20 28 73 74 6d 74 29 0a 20 20 20 20 mbda (stmt).
2e40: 20 20 20 28 64 62 69 3a 65 78 65 63 20 63 6f 6e (dbi:exec con
2e50: 6e 20 73 74 6d 74 29 29 0a 20 20 20 20 20 28 6c n stmt)). (l
2e60: 69 73 74 20 22 43 52 45 41 54 45 20 54 41 42 4c ist "CREATE TABL
2e70: 45 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 28 E session_vars (
2e80: 69 64 20 49 4e 54 45 47 45 52 20 50 52 49 4d 41 id INTEGER PRIMA
2e90: 52 59 20 4b 45 59 2c 73 65 73 73 69 6f 6e 5f 69 RY KEY,session_i
2ea0: 64 20 49 4e 54 45 47 45 52 2c 70 61 67 65 20 54 d INTEGER,page T
2eb0: 45 58 54 2c 6b 65 79 20 54 45 58 54 2c 76 61 6c EXT,key TEXT,val
2ec0: 75 65 20 54 45 58 54 29 3b 22 0a 09 20 20 20 22 ue TEXT);".. "
2ed0: 43 52 45 41 54 45 20 54 41 42 4c 45 20 73 65 73 CREATE TABLE ses
2ee0: 73 69 6f 6e 73 20 28 69 64 20 49 4e 54 45 47 45 sions (id INTEGE
2ef0: 52 20 50 52 49 4d 41 52 59 20 4b 45 59 2c 73 65 R PRIMARY KEY,se
2f00: 73 73 69 6f 6e 5f 6b 65 79 20 54 45 58 54 2c 6c ssion_key TEXT,l
2f10: 61 73 74 5f 75 73 65 64 20 54 49 4d 45 53 54 41 ast_used TIMESTA
2f20: 4d 50 29 3b 22 0a 20 20 20 20 20 20 20 20 20 20 MP);".
2f30: 20 22 43 52 45 41 54 45 20 54 41 42 4c 45 20 6d "CREATE TABLE m
2f40: 65 74 61 64 61 74 61 20 28 69 64 20 49 4e 54 45 etadata (id INTE
2f50: 47 45 52 20 50 52 49 4d 41 52 59 20 4b 45 59 2c GER PRIMARY KEY,
2f60: 6b 65 79 20 54 45 58 54 2c 76 61 6c 75 65 20 54 key TEXT,value T
2f70: 45 58 54 29 3b 22 29 29 29 29 0a 3b 3b 20 20 3b EXT);")))).;; ;
2f80: 3b 20 69 66 20 77 65 20 68 61 76 65 20 61 20 73 ; if we have a s
2f90: 65 73 73 69 6f 6e 5f 6b 65 79 20 6c 6f 6f 6b 20 ession_key look
2fa0: 75 70 20 74 68 65 20 73 65 73 73 69 6f 6e 2d 69 up the session-i
2fb0: 64 20 61 6e 64 20 73 74 6f 72 65 20 69 74 0a 3b d and store it.;
2fc0: 3b 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 ; (sdat-set-ses
2fd0: 73 69 6f 6e 2d 69 64 21 20 73 65 6c 66 20 28 73 sion-id! self (s
2fe0: 65 73 73 69 6f 6e 3a 67 65 74 2d 69 64 20 73 65 ession:get-id se
2ff0: 6c 66 29 29 29 0a 0a 3b 3b 20 6f 6e 6c 79 20 73 lf)))..;; only s
3000: 65 74 20 73 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 et session-cooki
3010: 65 20 77 68 65 6e 20 61 20 6e 65 77 20 73 65 73 e when a new ses
3020: 73 69 6f 6e 20 69 73 20 63 72 65 61 74 65 64 0a sion is created.
3030: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
3040: 3a 73 65 74 75 70 2d 73 65 73 73 69 6f 6e 2d 6b :setup-session-k
3050: 65 79 20 73 65 6c 66 29 20 20 0a 20 20 28 6c 65 ey self) . (le
3060: 74 2a 20 28 28 73 6b 20 20 28 73 65 73 73 69 6f t* ((sk (sessio
3070: 6e 3a 65 78 74 72 61 63 74 2d 73 65 73 73 69 6f n:extract-sessio
3080: 6e 2d 6b 65 79 20 73 65 6c 66 29 29 0a 20 20 20 n-key self)).
3090: 20 20 20 20 20 20 28 73 69 64 20 28 69 66 20 73 (sid (if s
30a0: 6b 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 69 k (session:get-i
30b0: 64 20 73 65 6c 66 20 73 6b 29 20 23 66 29 29 29 d self sk) #f)))
30c0: 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 73 69 . (if (not si
30d0: 64 29 20 3b 3b 20 6e 65 65 64 20 61 20 6e 65 77 d) ;; need a new
30e0: 20 6b 65 79 0a 20 20 20 20 20 20 20 20 28 6c 65 key. (le
30f0: 74 2a 20 28 28 6e 65 77 2d 6b 65 79 20 28 73 65 t* ((new-key (se
3100: 73 73 69 6f 6e 3a 67 65 74 2d 6e 65 77 2d 6b 65 ssion:get-new-ke
3110: 79 20 73 65 6c 66 29 29 0a 20 20 20 20 20 20 20 y self)).
3120: 20 20 20 20 20 20 20 20 28 6e 65 77 2d 73 69 64 (new-sid
3130: 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 69 64 (session:get-id
3140: 20 73 65 6c 66 20 6e 65 77 2d 6b 65 79 29 29 29 self new-key)))
3150: 0a 20 20 20 20 20 20 20 20 20 20 28 73 64 61 74 . (sdat
3160: 2d 73 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 -set-session-key
3170: 21 20 73 65 6c 66 20 6e 65 77 2d 6b 65 79 29 0a ! self new-key).
3180: 20 20 20 20 20 20 20 20 20 20 28 73 64 61 74 2d (sdat-
3190: 73 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 21 20 set-session-id!
31a0: 73 65 6c 66 20 6e 65 77 2d 73 69 64 29 0a 20 20 self new-sid).
31b0: 20 20 20 20 20 20 20 20 28 73 64 61 74 2d 73 65 (sdat-se
31c0: 74 2d 73 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 t-session-cookie
31d0: 21 20 73 65 6c 66 20 28 73 65 73 73 69 6f 6e 3a ! self (session:
31e0: 6d 61 6b 65 2d 63 6f 6f 6b 69 65 20 73 65 6c 66 make-cookie self
31f0: 29 29 29 0a 20 20 20 20 20 20 20 20 28 73 64 61 ))). (sda
3200: 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 t-set-session-id
3210: 21 20 73 65 6c 66 20 73 69 64 29 29 29 29 0a 0a ! self sid))))..
3220: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
3230: 3a 6d 61 6b 65 2d 63 6f 6f 6b 69 65 20 73 65 6c :make-cookie sel
3240: 66 29 0a 20 20 3b 3b 20 28 6c 69 73 74 20 28 63 f). ;; (list (c
3250: 6f 6e 63 20 22 73 65 73 73 69 6f 6e 5f 6b 65 79 onc "session_key
3260: 3d 22 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 =" (sdat-get-ses
3270: 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 20 22 sion-key self) "
3280: 3b 20 50 61 74 68 3d 2f 3b 20 44 6f 6d 61 69 6e ; Path=/; Domain
3290: 3d 2e 22 20 28 73 64 61 74 2d 67 65 74 2d 64 6f =." (sdat-get-do
32a0: 6d 61 69 6e 20 73 65 6c 66 29 20 22 3b 20 4d 61 main self) "; Ma
32b0: 78 2d 41 67 65 3d 22 20 28 2a 20 38 36 34 30 30 x-Age=" (* 86400
32c0: 20 31 34 29 20 22 3b 20 56 65 72 73 69 6f 6e 3d 14) "; Version=
32d0: 31 22 29 29 29 20 0a 20 20 3b 3b 20 41 63 63 6f 1"))) . ;; Acco
32e0: 72 64 69 6e 67 20 74 6f 20 0a 20 20 3b 3b 20 20 rding to . ;;
32f0: 20 20 68 74 74 70 3a 2f 2f 77 77 77 2e 63 6f 64 http://www.cod
3300: 65 6d 61 72 76 65 6c 73 2e 63 6f 6d 2f 32 30 31 emarvels.com/201
3310: 30 2f 31 31 2f 61 70 61 63 68 65 2d 72 65 77 72 0/11/apache-rewr
3320: 69 74 65 72 75 6c 65 2d 73 65 74 2d 61 2d 63 6f iterule-set-a-co
3330: 6f 6b 69 65 2d 6f 6e 2d 6c 6f 63 61 6c 68 6f 73 okie-on-localhos
3340: 74 2f 0a 0a 20 20 3b 3b 20 20 48 65 72 65 20 61 t/.. ;; Here a
3350: 72 65 20 74 68 65 20 32 20 28 6f 66 74 65 6e 20 re the 2 (often
3360: 6c 65 66 74 20 6f 75 74 29 20 72 65 71 75 69 72 left out) requir
3370: 65 6d 65 6e 74 73 20 74 6f 20 73 65 74 20 61 20 ements to set a
3380: 63 6f 6f 6b 69 65 20 75 73 69 6e 67 0a 20 20 3b cookie using. ;
3390: 3b 20 20 68 74 74 70 64 1b 2d 46 ef bf bd 73 20 ; httpd.-F�s
33a0: 72 65 77 72 69 74 65 20 72 75 6c 65 20 28 6d 6f rewrite rule (mo
33b0: 64 5f 72 65 77 72 69 74 65 29 2c 20 77 68 69 6c d_rewrite), whil
33c0: 65 20 77 6f 72 6b 69 6e 67 20 6f 6e 20 6c 6f 63 e working on loc
33d0: 61 6c 68 6f 73 74 3a 1b 2d 41 0a 20 20 3b 3b 0a alhost:.-A. ;;.
33e0: 20 20 3b 3b 20 20 55 73 65 20 74 68 65 20 49 50 ;; Use the IP
33f0: 20 31 32 37 2e 30 2e 30 2e 31 20 69 6e 73 74 65 127.0.0.1 inste
3400: 61 64 20 6f 66 20 6c 6f 63 61 6c 68 6f 73 74 2f ad of localhost/
3410: 6d 61 63 68 69 6e 65 2d 6e 61 6d 65 20 61 73 20 machine-name as
3420: 74 68 65 0a 20 20 3b 3b 20 20 64 6f 6d 61 69 6e the. ;; domain
3430: 3b 20 65 2e 67 2e 20 5b 43 4f 3d 73 6f 6d 65 43 ; e.g. [CO=someC
3440: 6f 6f 6b 69 65 3a 73 6f 6d 65 56 61 6c 75 65 3a ookie:someValue:
3450: 31 32 37 2e 30 2e 30 2e 31 3a 32 3a 2f 5d 2c 20 127.0.0.1:2:/],
3460: 77 68 69 63 68 20 73 61 79 73 0a 20 20 3b 3b 20 which says. ;;
3470: 20 63 72 65 61 74 65 20 61 20 63 6f 6f 6b 69 65 create a cookie
3480: 20 1b 2d 59 ef bf bd 73 6f 6d 65 43 6f 6f 6b 69 .-Y�someCooki
3490: 65 ef bf bd 20 77 69 74 68 20 76 61 6c 75 65 20 e� with value
34a0: ef bf bd 73 6f 6d 65 56 61 6c 75 65 ef bf bd 20 �someValue�
34b0: 66 6f 72 20 74 68 65 0a 20 20 3b 3b 20 20 64 6f for the. ;; do
34c0: 6d 61 69 6e 20 ef bf bd 31 32 37 2e 30 2e 30 2e main �127.0.0.
34d0: 31 1b 24 42 21 6d 1b 28 42 20 68 61 76 69 6e 67 1.$B!m.(B having
34e0: 20 61 20 6c 69 66 65 20 74 69 6d 65 20 6f 66 20 a life time of
34f0: 32 20 6d 69 6e 73 2c 20 66 6f 72 20 61 6e 79 20 2 mins, for any
3500: 70 61 74 68 20 69 6e 0a 20 20 3b 3b 20 20 74 68 path in. ;; th
3510: 65 20 64 6f 6d 61 69 6e 20 28 70 61 74 68 3d 2f e domain (path=/
3520: 29 2e 20 28 4f 62 76 69 6f 75 73 6c 79 20 79 6f ). (Obviously yo
3530: 75 20 77 69 6c 6c 20 68 61 76 65 20 74 6f 20 72 u will have to r
3540: 75 6e 20 74 68 65 0a 20 20 3b 3b 20 20 61 70 70 un the. ;; app
3550: 6c 69 63 61 74 69 6f 6e 20 77 69 74 68 20 74 68 lication with th
3560: 69 73 20 76 61 6c 75 65 20 69 6e 20 74 68 65 20 is value in the
3570: 55 52 4c 29 0a 20 20 3b 3b 0a 20 20 3b 3b 20 20 URL). ;;. ;;
3580: 54 6f 20 6d 61 6b 65 20 61 20 73 65 73 73 69 6f To make a sessio
3590: 6e 20 63 6f 6f 6b 69 65 2c 20 6c 69 6d 69 74 20 n cookie, limit
35a0: 74 68 65 20 66 6c 61 67 20 73 74 61 74 65 6d 65 the flag stateme
35b0: 6e 74 20 74 6f 20 6a 75 73 74 20 74 68 72 65 65 nt to just three
35c0: 0a 20 20 3b 3b 20 20 61 74 74 72 69 62 75 74 65 . ;; attribute
35d0: 73 3a 20 6e 61 6d 65 2c 20 76 61 6c 75 65 20 61 s: name, value a
35e0: 6e 64 20 64 6f 6d 61 69 6e 2e 20 65 2e 67 0a 20 nd domain. e.g.
35f0: 20 3b 3b 20 20 5b 43 4f 3d 73 6f 6d 65 43 6f 6f ;; [CO=someCoo
3600: 6b 69 65 3a 73 6f 6d 65 56 61 6c 75 65 3a 31 32 kie:someValue:12
3610: 37 2e 30 2e 30 2e 31 5d 20 1b 25 47 e2 80 93 1b 7.0.0.1] .%G–.
3620: 25 40 20 41 6e 79 20 66 75 72 74 68 65 72 0a 20 %@ Any further.
3630: 20 3b 3b 20 20 73 65 74 74 69 6e 67 73 2c 20 61 ;; settings, a
3640: 70 61 63 68 65 20 77 72 69 74 65 73 20 61 6e ef pache writes anï
3650: bf bd 20 65 78 70 69 72 65 73 ef bf bd 20 61 74 ¿½ expires� at
3660: 74 72 69 62 75 74 65 20 66 6f 72 20 74 68 65 20 tribute for the
3670: 73 65 74 2d 63 6f 6f 6b 69 65 0a 20 20 3b 3b 20 set-cookie. ;;
3680: 20 68 65 61 64 65 72 2c 20 77 68 69 63 68 20 6d header, which m
3690: 61 6b 65 73 20 74 68 65 20 63 6f 6f 6b 69 65 20 akes the cookie
36a0: 61 20 70 65 72 73 69 73 74 65 6e 74 20 6f 6e 65 a persistent one
36b0: 20 28 6e 6f 74 20 72 65 61 6c 6c 79 0a 20 20 3b (not really. ;
36c0: 3b 20 20 70 65 72 73 69 73 74 65 6e 74 2c 20 61 ; persistent, a
36d0: 73 20 74 68 65 20 65 78 70 69 72 65 73 20 76 61 s the expires va
36e0: 6c 75 65 20 73 65 74 20 69 73 20 74 68 65 20 63 lue set is the c
36f0: 75 72 72 65 6e 74 20 73 65 72 76 65 72 20 74 69 urrent server ti
3700: 6d 65 0a 20 20 3b 3b 20 20 1b 25 47 e2 80 93 1b me. ;; .%G–.
3710: 25 40 20 73 6f 20 79 6f 75 20 64 6f 6e 1b 2d 46 %@ so you don.-F
3720: 1b 2d 46 ef bf bd 74 20 65 76 65 6e 20 67 65 74 .-F�t even get
3730: 20 74 6f 20 73 65 65 20 79 6f 75 72 20 63 6f 6f to see your coo
3740: 6b 69 65 21 29 1b 2d 41 0a 20 20 28 6c 69 73 74 kie!).-A. (list
3750: 20 28 73 74 72 69 6e 67 2d 73 75 62 73 74 69 74 (string-substit
3760: 75 74 65 20 0a 09 20 22 3b 22 20 22 3b 20 22 20 ute .. ";" "; "
3770: 0a 09 20 28 63 61 72 20 28 63 6f 6e 73 74 72 75 .. (car (constru
3780: 63 74 2d 63 6f 6f 6b 69 65 2d 73 74 72 69 6e 67 ct-cookie-string
3790: 20 0a 09 20 20 20 20 20 20 20 3b 3b 20 77 61 72 .. ;; war
37a0: 6e 69 6e 67 21 20 6d 65 73 73 69 6e 67 20 75 70 ning! messing up
37b0: 20 74 68 69 73 20 69 74 74 79 20 62 69 74 74 79 this itty bitty
37c0: 20 62 69 74 20 6f 66 20 63 6f 64 65 20 77 69 6c bit of code wil
37d0: 6c 20 63 6f 73 74 20 6d 75 63 68 20 74 69 6d 65 l cost much time
37e0: 21 0a 09 20 20 20 20 20 20 20 60 28 28 22 73 65 !.. `(("se
37f0: 73 73 69 6f 6e 5f 6b 65 79 22 20 2c 28 73 64 61 ssion_key" ,(sda
3800: 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 t-get-session-ke
3810: 79 20 73 65 6c 66 29 0a 09 09 20 20 65 78 70 69 y self)... expi
3820: 72 65 73 3a 20 2c 28 2b 20 28 63 75 72 72 65 6e res: ,(+ (curren
3830: 74 2d 73 65 63 6f 6e 64 73 29 20 28 2a 20 31 34 t-seconds) (* 14
3840: 20 38 36 34 30 30 29 29 20 0a 09 09 20 20 3b 3b 86400)) ... ;;
3850: 20 6d 61 78 2d 61 67 65 3a 20 28 2a 20 31 34 20 max-age: (* 14
3860: 38 36 34 30 30 29 0a 09 09 20 20 70 61 74 68 3a 86400)... path:
3870: 20 22 2f 22 20 3b 3b 20 0a 09 09 20 20 64 6f 6d "/" ;; ... dom
3880: 61 69 6e 3a 20 2c 28 73 74 72 69 6e 67 2d 61 70 ain: ,(string-ap
3890: 70 65 6e 64 20 22 2e 22 20 28 73 64 61 74 2d 67 pend "." (sdat-g
38a0: 65 74 2d 64 6f 6d 61 69 6e 20 73 65 6c 66 29 29 et-domain self))
38b0: 0a 09 09 20 20 76 65 72 73 69 6f 6e 3a 20 31 29 ... version: 1)
38c0: 29 20 30 29 29 29 29 29 0a 0a 3b 3b 20 6c 6f 6f ) 0)))))..;; loo
38d0: 6b 20 75 70 20 61 20 67 69 76 65 6e 20 73 65 73 k up a given ses
38e0: 73 69 6f 6e 20 6b 65 79 20 61 6e 64 20 72 65 74 sion key and ret
38f0: 75 72 6e 20 74 68 65 20 69 64 20 69 66 20 66 6f urn the id if fo
3900: 75 6e 64 2c 20 23 66 20 69 66 20 6e 6f 74 20 66 und, #f if not f
3910: 6f 75 6e 64 0a 28 64 65 66 69 6e 65 20 28 73 65 ound.(define (se
3920: 73 73 69 6f 6e 3a 67 65 74 2d 69 64 20 73 65 6c ssion:get-id sel
3930: 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 0a 20 f session-key).
3940: 20 3b 3b 20 28 6c 65 74 20 28 28 73 65 73 73 69 ;; (let ((sessi
3950: 6f 6e 2d 6b 65 79 20 28 73 64 61 74 2d 67 65 74 on-key (sdat-get
3960: 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c -session-key sel
3970: 66 29 29 29 0a 20 20 28 69 66 20 73 65 73 73 69 f))). (if sessi
3980: 6f 6e 2d 6b 65 79 0a 20 20 20 20 20 20 28 6c 65 on-key. (le
3990: 74 20 28 28 71 75 65 72 79 20 28 73 74 72 69 6e t ((query (strin
39a0: 67 2d 61 70 70 65 6e 64 20 22 53 45 4c 45 43 54 g-append "SELECT
39b0: 20 69 64 20 46 52 4f 4d 20 73 65 73 73 69 6f 6e id FROM session
39c0: 73 20 57 48 45 52 45 20 73 65 73 73 69 6f 6e 5f s WHERE session_
39d0: 6b 65 79 3d 27 22 20 73 65 73 73 69 6f 6e 2d 6b key='" session-k
39e0: 65 79 20 22 27 22 29 29 0a 20 20 20 20 20 20 20 ey "'")).
39f0: 20 20 20 20 20 28 63 6f 6e 6e 20 28 73 64 61 74 (conn (sdat
3a00: 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 -get-conn self))
3a10: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 72 65 . (re
3a20: 73 75 6c 74 20 23 66 29 29 0a 09 28 64 62 69 3a sult #f))..(dbi:
3a30: 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 0a 09 20 for-each-row ..
3a40: 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 29 0a (lambda (tuple).
3a50: 09 20 20 20 28 73 65 74 21 20 72 65 73 75 6c 74 . (set! result
3a60: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 (vector-ref tup
3a70: 6c 65 20 30 29 29 29 0a 09 20 63 6f 6e 6e 20 71 le 0))).. conn q
3a80: 75 65 72 79 29 0a 09 28 69 66 20 72 65 73 75 6c uery)..(if resul
3a90: 74 20 28 64 62 69 3a 65 78 65 63 20 63 6f 6e 6e t (dbi:exec conn
3aa0: 20 28 63 6f 6e 63 20 22 55 50 44 41 54 45 20 73 (conc "UPDATE s
3ab0: 65 73 73 69 6f 6e 73 20 53 45 54 20 6c 61 73 74 essions SET last
3ac0: 5f 75 73 65 64 3d 22 20 28 64 62 69 3a 6e 6f 77 _used=" (dbi:now
3ad0: 20 63 6f 6e 6e 29 20 22 20 57 48 45 52 45 20 73 conn) " WHERE s
3ae0: 65 73 73 69 6f 6e 5f 6b 65 79 3d 3f 3b 22 29 20 ession_key=?;")
3af0: 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 0a 20 20 session-key)).
3b00: 20 20 20 20 20 20 72 65 73 75 6c 74 29 0a 20 20 result).
3b10: 20 20 20 20 23 66 29 29 0a 0a 3b 3b 20 0a 28 64 #f))..;; .(d
3b20: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 70 efine (session:p
3b30: 72 6f 63 65 73 73 2d 75 72 6c 2d 70 61 74 68 20 rocess-url-path
3b40: 73 65 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 70 self). (let ((p
3b50: 61 74 68 2d 69 6e 66 6f 20 20 20 20 28 67 65 74 ath-info (get
3b60: 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 -environment-var
3b70: 69 61 62 6c 65 20 22 50 41 54 48 5f 49 4e 46 4f iable "PATH_INFO
3b80: 22 29 29 0a 09 28 71 75 65 72 79 2d 73 74 72 69 "))..(query-stri
3b90: 6e 67 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d ng (get-environm
3ba0: 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 51 55 ent-variable "QU
3bb0: 45 52 59 5f 53 54 52 49 4e 47 22 29 29 29 0a 20 ERY_STRING"))).
3bc0: 20 20 20 3b 3b 20 28 73 65 73 73 69 6f 6e 3a 6c ;; (session:l
3bd0: 6f 67 20 73 65 6c 66 20 22 70 61 74 68 2d 69 6e og self "path-in
3be0: 66 6f 3d 22 20 70 61 74 68 2d 69 6e 66 6f 20 22 fo=" path-info "
3bf0: 20 71 75 65 72 79 2d 73 74 72 69 6e 67 3d 22 20 query-string="
3c00: 71 75 65 72 79 2d 73 74 72 69 6e 67 29 0a 20 20 query-string).
3c10: 20 20 28 69 66 20 70 61 74 68 2d 69 6e 66 6f 0a (if path-info.
3c20: 09 28 6c 65 74 2a 20 28 28 70 61 72 74 73 20 20 .(let* ((parts
3c30: 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 (string-split
3c40: 70 61 74 68 2d 69 6e 66 6f 20 22 2f 22 29 29 0a path-info "/")).
3c50: 09 20 20 20 20 20 20 20 28 6e 75 6d 70 61 72 74 . (numpart
3c60: 73 20 28 6c 65 6e 67 74 68 20 70 61 72 74 73 29 s (length parts)
3c70: 29 29 0a 09 20 20 28 69 66 20 28 3e 20 6e 75 6d )).. (if (> num
3c80: 70 61 72 74 73 20 30 29 0a 09 20 20 20 20 20 20 parts 0)..
3c90: 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 21 20 (sdat-set-page!
3ca0: 73 65 6c 66 20 28 63 61 72 20 70 61 72 74 73 29 self (car parts)
3cb0: 29 29 0a 09 20 20 3b 3b 20 28 73 65 73 73 69 6f )).. ;; (sessio
3cc0: 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 75 72 6c 2d n:log self "url-
3cd0: 70 61 74 68 3d 22 20 75 72 6c 2d 70 61 74 68 20 path=" url-path
3ce0: 22 20 70 61 72 74 73 3d 22 20 70 61 72 74 73 29 " parts=" parts)
3cf0: 0a 09 20 20 28 69 66 20 28 3e 20 6e 75 6d 70 61 .. (if (> numpa
3d00: 72 74 73 20 31 29 0a 09 20 20 20 20 20 20 28 73 rts 1).. (s
3d10: 64 61 74 2d 73 65 74 2d 70 61 74 68 2d 70 61 72 dat-set-path-par
3d20: 61 6d 73 21 20 73 65 6c 66 20 28 63 64 72 20 70 ams! self (cdr p
3d30: 61 72 74 73 29 29 29 0a 20 20 20 20 20 20 20 20 arts))).
3d40: 20 20 28 69 66 20 71 75 65 72 79 2d 73 74 72 69 (if query-stri
3d50: 6e 67 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ng.
3d60: 20 28 73 64 61 74 2d 73 65 74 2d 70 61 72 61 6d (sdat-set-param
3d70: 73 21 20 73 65 6c 66 20 28 73 74 72 69 6e 67 2d s! self (string-
3d80: 73 70 6c 69 74 20 71 75 65 72 79 2d 73 74 72 69 split query-stri
3d90: 6e 67 20 22 26 22 29 29 29 29 29 29 29 0a 0a 3b ng "&")))))))..;
3da0: 3b 20 42 55 47 47 59 21 0a 28 64 65 66 69 6e 65 ; BUGGY!.(define
3db0: 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 6e 65 (session:get-ne
3dc0: 77 2d 6b 65 79 20 73 65 6c 66 29 0a 20 20 28 6c w-key self). (l
3dd0: 65 74 20 28 28 63 6f 6e 6e 20 20 20 28 73 64 61 et ((conn (sda
3de0: 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 t-get-conn self)
3df0: 29 0a 20 20 20 20 20 20 20 20 28 74 6d 70 6b 65 ). (tmpke
3e00: 79 20 28 73 65 73 73 69 6f 6e 3a 6d 61 6b 65 2d y (session:make-
3e10: 72 61 6e 64 2d 73 74 72 69 6e 67 20 32 30 29 29 rand-string 20))
3e20: 0a 20 20 20 20 20 20 20 20 28 73 74 61 74 75 73 . (status
3e30: 20 23 66 29 29 0a 20 20 20 20 28 64 62 69 3a 66 #f)). (dbi:f
3e40: 6f 72 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 6d or-each-row (lam
3e50: 62 64 61 20 28 74 75 70 6c 65 29 0a 09 09 09 28 bda (tuple)....(
3e60: 73 65 74 21 20 73 74 61 74 75 73 20 23 74 29 29 set! status #t))
3e70: 0a 09 09 20 20 20 20 20 20 63 6f 6e 6e 20 28 73 ... conn (s
3e80: 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 22 49 4e tring-append "IN
3e90: 53 45 52 54 20 49 4e 54 4f 20 73 65 73 73 69 6f SERT INTO sessio
3ea0: 6e 73 20 28 73 65 73 73 69 6f 6e 5f 6b 65 79 29 ns (session_key)
3eb0: 20 56 41 4c 55 45 53 20 28 27 22 20 74 6d 70 6b VALUES ('" tmpk
3ec0: 65 79 20 22 27 29 22 29 29 0a 20 20 20 20 74 6d ey "')")). tm
3ed0: 70 6b 65 79 29 29 0a 0a 3b 3b 20 72 65 74 75 72 pkey))..;; retur
3ee0: 6e 73 20 73 65 73 73 69 6f 6e 20 6b 65 79 20 49 ns session key I
3ef0: 46 46 20 69 74 20 69 73 20 69 6e 20 74 68 65 20 FF it is in the
3f00: 48 54 54 50 5f 43 4f 4f 4b 49 45 20 0a 28 64 65 HTTP_COOKIE .(de
3f10: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 65 78 fine (session:ex
3f20: 74 72 61 63 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 tract-session-ke
3f30: 79 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 20 28 y self). (let (
3f40: 28 68 74 74 70 2d 63 6f 6f 6b 69 65 20 28 67 65 (http-cookie (ge
3f50: 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 t-environment-va
3f60: 72 69 61 62 6c 65 20 22 48 54 54 50 5f 43 4f 4f riable "HTTP_COO
3f70: 4b 49 45 22 29 29 29 0a 20 20 20 20 3b 3b 20 28 KIE"))). ;; (
3f80: 65 72 72 3a 6c 6f 67 20 22 68 74 74 70 2d 63 6f err:log "http-co
3f90: 6f 6b 69 65 3a 20 22 20 68 74 74 70 2d 63 6f 6f okie: " http-coo
3fa0: 6b 69 65 29 0a 20 20 20 20 28 69 66 20 68 74 74 kie). (if htt
3fb0: 70 2d 63 6f 6f 6b 69 65 0a 20 20 20 20 20 20 20 p-cookie.
3fc0: 20 28 73 65 73 73 69 6f 6e 3a 65 78 74 72 61 63 (session:extrac
3fd0: 74 2d 6b 65 79 2d 66 72 6f 6d 2d 70 61 72 61 6d t-key-from-param
3fe0: 20 73 65 6c 66 20 28 73 74 72 69 6e 67 2d 73 70 self (string-sp
3ff0: 6c 69 74 2d 66 69 65 6c 64 73 20 20 22 3b 5c 5c lit-fields ";\\
4000: 73 2b 22 20 68 74 74 70 2d 63 6f 6f 6b 69 65 20 s+" http-cookie
4010: 69 6e 66 69 78 3a 29 20 22 73 65 73 73 69 6f 6e infix:) "session
4020: 5f 6b 65 79 22 29 0a 20 20 20 20 20 20 20 20 23 _key"). #
4030: 66 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 f)))..(define (s
4040: 65 73 73 69 6f 6e 3a 67 65 74 2d 73 65 73 73 69 ession:get-sessi
4050: 6f 6e 2d 69 64 20 73 65 6c 66 20 73 65 73 73 69 on-id self sessi
4060: 6f 6e 2d 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 on-key). (let (
4070: 28 71 75 65 72 79 20 22 53 45 4c 45 43 54 20 69 (query "SELECT i
4080: 64 20 46 52 4f 4d 20 73 65 73 73 69 6f 6e 73 20 d FROM sessions
4090: 57 48 45 52 45 20 73 65 73 73 69 6f 6e 5f 6b 65 WHERE session_ke
40a0: 79 3d 3f 3b 22 29 0a 20 20 20 20 20 20 20 20 28 y=?;"). (
40b0: 72 65 73 75 6c 74 20 23 66 29 29 0a 20 20 20 20 result #f)).
40c0: 3b 3b 20 20 20 20 20 28 70 67 3a 71 75 65 72 79 ;; (pg:query
40d0: 2d 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 -for-each (lambd
40e0: 61 20 28 74 75 70 6c 65 29 0a 20 20 20 20 3b 3b a (tuple). ;;
40f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4100: 20 20 20 20 20 20 20 20 20 20 28 73 65 74 21 20 (set!
4110: 72 65 73 75 6c 74 20 28 76 65 63 74 6f 72 2d 72 result (vector-r
4120: 65 66 20 74 75 70 6c 65 20 30 29 29 29 20 3b 3b ef tuple 0))) ;;
4130: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 (vector-ref tup
4140: 6c 65 20 30 29 29 29 0a 20 20 20 20 3b 3b 20 20 le 0))). ;;
4150: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4160: 20 20 20 20 20 20 28 73 3a 73 71 6c 70 61 72 61 (s:sqlpara
4170: 6d 20 71 75 65 72 79 20 73 65 73 73 69 6f 6e 2d m query session-
4180: 6b 65 79 29 0a 20 20 20 20 3b 3b 20 20 20 20 20 key). ;;
4190: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
41a0: 20 20 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e (sdat-get-con
41b0: 6e 20 73 65 6c 66 29 29 0a 20 20 20 20 3b 3b 20 n self)). ;;
41c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
41d0: 20 20 20 20 20 20 20 63 6f 6e 6e 29 0a 20 20 20 conn).
41e0: 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 (dbi:for-each-r
41f0: 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c ow (lambda (tupl
4200: 65 29 0a 09 09 09 28 73 65 74 21 20 72 65 73 75 e)....(set! resu
4210: 6c 74 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 lt (vector-ref t
4220: 75 70 6c 65 20 30 29 29 29 20 3b 3b 20 28 76 65 uple 0))) ;; (ve
4230: 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 30 ctor-ref tuple 0
4240: 29 29 29 0a 09 09 20 20 20 20 20 20 28 73 64 61 )))... (sda
4250: 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 t-get-conn self)
4260: 0a 09 09 20 20 20 20 20 20 28 73 3a 73 71 6c 70 ... (s:sqlp
4270: 61 72 61 6d 20 71 75 65 72 79 20 73 65 73 73 69 aram query sessi
4280: 6f 6e 2d 6b 65 79 29 29 0a 20 20 20 20 72 65 73 on-key)). res
4290: 75 6c 74 29 29 0a 0a 3b 3b 20 64 65 6c 65 74 65 ult))..;; delete
42a0: 20 61 6c 6c 20 72 65 63 6f 72 64 73 20 66 6f 72 all records for
42b0: 20 61 20 73 65 73 73 69 6f 6e 0a 3b 3b 20 0a 3b a session.;; .;
42c0: 3b 20 4e 45 45 44 53 20 54 4f 20 42 45 20 54 52 ; NEEDS TO BE TR
42d0: 41 4e 53 41 43 54 49 4f 4e 49 5a 45 44 21 0a 3b ANSACTIONIZED!.;
42e0: 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ;.(define (sessi
42f0: 6f 6e 3a 64 65 6c 65 74 65 2d 73 65 73 73 69 6f on:delete-sessio
4300: 6e 20 73 65 6c 66 20 73 65 73 73 69 6f 6e 2d 6b n self session-k
4310: 65 79 29 0a 20 20 28 6c 65 74 20 28 28 73 65 73 ey). (let ((ses
4320: 73 69 6f 6e 2d 69 64 20 28 73 65 73 73 69 6f 6e sion-id (session
4330: 3a 67 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 :get-session-id
4340: 73 65 6c 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 self session-key
4350: 29 29 0a 20 20 20 20 20 20 20 20 28 71 72 79 31 )). (qry1
4360: 20 20 20 20 20 20 20 20 3b 3b 20 28 63 6f 6e 63 ;; (conc
4370: 20 22 42 45 47 49 4e 3b 22 0a 09 09 09 20 20 22 "BEGIN;".... "
4380: 44 45 4c 45 54 45 20 46 52 4f 4d 20 73 65 73 73 DELETE FROM sess
4390: 69 6f 6e 5f 76 61 72 73 20 57 48 45 52 45 20 73 ion_vars WHERE s
43a0: 65 73 73 69 6f 6e 5f 69 64 3d 3f 3b 22 29 0a 09 ession_id=?;")..
43b0: 28 71 72 79 32 20 20 20 20 20 20 20 20 20 20 20 (qry2
43c0: 20 20 22 44 45 4c 45 54 45 20 46 52 4f 4d 20 73 "DELETE FROM s
43d0: 65 73 73 69 6f 6e 73 20 57 48 45 52 45 20 69 64 essions WHERE id
43e0: 3d 3f 3b 22 29 0a 09 09 20 20 20 20 20 3b 3b 20 =?;")... ;;
43f0: 20 22 43 4f 4d 4d 49 54 3b 22 29 29 0a 20 20 20 "COMMIT;")).
4400: 20 20 20 20 20 28 63 6f 6e 6e 20 20 20 20 20 20 (conn
4410: 20 20 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 (sdat-ge
4420: 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 29 0a 20 t-conn self))).
4430: 20 20 20 28 69 66 20 73 65 73 73 69 6f 6e 2d 69 (if session-i
4440: 64 0a 20 20 20 20 20 20 20 20 28 62 65 67 69 6e d. (begin
4450: 0a 20 20 20 20 20 20 20 20 20 20 28 64 62 69 3a . (dbi:
4460: 65 78 65 63 20 63 6f 6e 6e 20 71 72 79 31 20 73 exec conn qry1 s
4470: 65 73 73 69 6f 6e 2d 69 64 29 20 3b 3b 20 73 65 ession-id) ;; se
4480: 73 73 69 6f 6e 2d 69 64 29 0a 09 20 20 28 64 62 ssion-id).. (db
4490: 69 3a 65 78 65 63 20 63 6f 6e 6e 20 71 72 79 32 i:exec conn qry2
44a0: 20 73 65 73 73 69 6f 6e 2d 69 64 29 0a 09 20 20 session-id)..
44b0: 28 73 65 73 73 69 6f 6e 3a 69 6e 69 74 69 61 6c (session:initial
44c0: 69 7a 65 20 73 65 6c 66 29 0a 09 20 20 28 73 65 ize self).. (se
44d0: 73 73 69 6f 6e 3a 73 65 74 75 70 20 73 65 6c 66 ssion:setup self
44e0: 29 29 29 0a 20 20 20 20 28 6e 6f 74 20 28 73 65 ))). (not (se
44f0: 73 73 69 6f 6e 3a 67 65 74 2d 73 65 73 73 69 6f ssion:get-sessio
4500: 6e 2d 69 64 20 73 65 6c 66 20 73 65 73 73 69 6f n-id self sessio
4510: 6e 2d 6b 65 79 29 29 29 29 0a 0a 3b 3b 20 28 64 n-key))))..;; (d
4520: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 64 efine (session:d
4530: 65 6c 65 74 65 2d 73 65 73 73 69 6f 6e 20 73 65 elete-session se
4540: 6c 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 0a lf session-key).
4550: 3b 3b 20 20 20 28 6c 65 74 20 28 28 73 65 73 73 ;; (let ((sess
4560: 69 6f 6e 2d 69 64 20 28 73 65 73 73 69 6f 6e 3a ion-id (session:
4570: 67 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 get-session-id s
4580: 65 6c 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 elf session-key)
4590: 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 28 71 75 ).;; (qu
45a0: 65 72 69 65 73 20 20 20 20 28 6c 69 73 74 20 22 eries (list "
45b0: 42 45 47 49 4e 3b 22 0a 3b 3b 20 09 09 09 20 20 BEGIN;".;; ...
45c0: 22 44 45 4c 45 54 45 20 46 52 4f 4d 20 73 65 73 "DELETE FROM ses
45d0: 73 69 6f 6e 5f 76 61 72 73 20 57 48 45 52 45 20 sion_vars WHERE
45e0: 73 65 73 73 69 6f 6e 5f 69 64 3d 3f 3b 22 0a 3b session_id=?;".;
45f0: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
4600: 20 20 20 20 20 20 20 20 20 20 20 20 22 44 45 4c "DEL
4610: 45 54 45 20 46 52 4f 4d 20 73 65 73 73 69 6f 6e ETE FROM session
4620: 73 20 57 48 45 52 45 20 69 64 3d 3f 3b 22 0a 3b s WHERE id=?;".;
4630: 3b 20 09 09 09 20 20 22 43 4f 4d 4d 49 54 3b 22 ; ... "COMMIT;"
4640: 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 28 63 )).;; (c
4650: 6f 6e 6e 20 20 20 20 20 20 20 20 20 20 20 20 20 onn
4660: 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 (sdat-get-conn
4670: 73 65 6c 66 29 29 29 0a 3b 3b 20 20 20 20 20 28 self))).;; (
4680: 69 66 20 73 65 73 73 69 6f 6e 2d 69 64 0a 3b 3b if session-id.;;
4690: 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a (begin.
46a0: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 28 66 6f ;; (fo
46b0: 72 2d 65 61 63 68 0a 3b 3b 20 20 20 20 20 20 20 r-each.;;
46c0: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 71 75 (lambda (qu
46d0: 65 72 79 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 ery).;;
46e0: 20 20 20 20 20 28 64 62 69 3a 65 78 65 63 20 63 (dbi:exec c
46f0: 6f 6e 6e 20 71 75 65 72 79 20 73 65 73 73 69 6f onn query sessio
4700: 6e 2d 69 64 29 29 0a 3b 3b 20 09 20 20 20 71 75 n-id)).;; . qu
4710: 65 72 69 65 73 29 0a 3b 3b 20 09 20 20 28 69 6e eries).;; . (in
4720: 69 74 69 61 6c 69 7a 65 20 73 65 6c 66 20 27 28 itialize self '(
4730: 29 29 0a 3b 3b 20 09 20 20 28 73 65 73 73 69 6f )).;; . (sessio
4740: 6e 3a 73 65 74 75 70 20 73 65 6c 66 29 29 29 0a n:setup self))).
4750: 3b 3b 20 20 20 20 20 28 6e 6f 74 20 28 73 65 73 ;; (not (ses
4760: 73 69 6f 6e 3a 67 65 74 2d 73 65 73 73 69 6f 6e sion:get-session
4770: 2d 69 64 20 73 65 6c 66 20 73 65 73 73 69 6f 6e -id self session
4780: 2d 6b 65 79 29 29 29 29 0a 0a 28 64 65 66 69 6e -key))))..(defin
4790: 65 20 28 73 65 73 73 69 6f 6e 3a 65 78 74 72 61 e (session:extra
47a0: 63 74 2d 6b 65 79 20 73 65 6c 66 20 6b 65 79 29 ct-key self key)
47b0: 0a 20 20 28 6c 65 74 20 28 28 70 61 72 61 6d 73 . (let ((params
47c0: 20 28 73 64 61 74 2d 67 65 74 2d 70 61 72 61 6d (sdat-get-param
47d0: 73 20 73 65 6c 66 29 29 29 0a 20 20 20 20 28 73 s self))). (s
47e0: 65 73 73 69 6f 6e 3a 65 78 74 72 61 63 74 2d 6b ession:extract-k
47f0: 65 79 2d 66 72 6f 6d 2d 70 61 72 61 6d 20 73 65 ey-from-param se
4800: 6c 66 20 70 61 72 61 6d 73 20 6b 65 79 29 29 29 lf params key)))
4810: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ..(define (sessi
4820: 6f 6e 3a 65 78 74 72 61 63 74 2d 6b 65 79 2d 66 on:extract-key-f
4830: 72 6f 6d 2d 70 61 72 61 6d 20 73 65 6c 66 20 70 rom-param self p
4840: 61 72 61 6d 73 20 6b 65 79 29 0a 20 20 28 6c 65 arams key). (le
4850: 74 20 28 28 72 31 20 20 20 20 20 28 72 65 67 65 t ((r1 (rege
4860: 78 70 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e xp (string-appen
4870: 64 20 22 5e 22 20 6b 65 79 20 22 3d 28 5b 5e 3d d "^" key "=([^=
4880: 5d 2b 29 24 22 29 29 29 29 0a 20 20 20 20 28 65 ]+)$")))). (e
4890: 72 72 3a 6c 6f 67 20 22 49 4e 46 4f 3a 20 4c 6f rr:log "INFO: Lo
48a0: 6f 6b 69 6e 67 20 66 6f 72 20 22 20 6b 65 79 20 oking for " key
48b0: 22 20 69 6e 20 22 20 70 61 72 61 6d 73 29 0a 20 " in " params).
48c0: 20 20 20 28 69 66 20 28 3c 20 28 6c 65 6e 67 74 (if (< (lengt
48d0: 68 20 70 61 72 61 6d 73 29 20 31 29 20 23 66 0a h params) 1) #f.
48e0: 09 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 61 .(let loop ((hea
48f0: 64 20 20 20 28 63 61 72 20 70 61 72 61 6d 73 29 d (car params)
4900: 29 0a 09 09 20 20 20 28 74 61 69 6c 20 20 20 28 )... (tail (
4910: 63 64 72 20 70 61 72 61 6d 73 29 29 29 0a 09 20 cdr params)))..
4920: 20 28 6c 65 74 20 28 28 6d 61 74 63 68 20 28 73 (let ((match (s
4930: 74 72 69 6e 67 2d 6d 61 74 63 68 20 72 31 20 68 tring-match r1 h
4940: 65 61 64 29 29 29 0a 09 20 20 20 20 28 63 6f 6e ead))).. (con
4950: 64 0a 09 20 20 20 20 20 28 6d 61 74 63 68 0a 09 d.. (match..
4960: 20 20 20 20 20 20 28 6c 65 74 20 28 28 73 65 73 (let ((ses
4970: 73 69 6f 6e 2d 6b 65 79 20 28 6c 69 73 74 2d 72 sion-key (list-r
4980: 65 66 20 6d 61 74 63 68 20 31 29 29 29 0a 09 09 ef match 1)))...
4990: 28 65 72 72 3a 6c 6f 67 20 22 49 4e 46 4f 3a 20 (err:log "INFO:
49a0: 46 6f 75 6e 64 20 73 65 73 73 69 6f 6e 20 6b 65 Found session ke
49b0: 79 3d 22 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 y=" session-key)
49c0: 0a 09 09 28 73 64 61 74 2d 73 65 74 2d 73 65 73 ...(sdat-set-ses
49d0: 73 69 6f 6e 2d 6b 65 79 21 20 73 65 6c 66 20 28 sion-key! self (
49e0: 6c 69 73 74 2d 72 65 66 20 6d 61 74 63 68 20 31 list-ref match 1
49f0: 29 29 0a 09 09 73 65 73 73 69 6f 6e 2d 6b 65 79 ))...session-key
4a00: 29 29 0a 09 20 20 20 20 20 28 28 6e 75 6c 6c 3f )).. ((null?
4a10: 20 74 61 69 6c 29 0a 09 20 20 20 20 20 20 23 66 tail).. #f
4a20: 29 0a 09 20 20 20 20 20 28 65 6c 73 65 0a 09 20 ).. (else..
4a30: 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 (loop (car
4a40: 74 61 69 6c 29 0a 09 09 20 20 20 20 28 63 64 72 tail)... (cdr
4a50: 20 74 61 69 6c 29 29 29 29 29 29 29 29 29 0a 0a tail)))))))))..
4a60: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
4a70: 3a 73 65 74 2d 70 61 67 65 21 20 73 65 6c 66 20 :set-page! self
4a80: 70 61 67 65 5f 6e 61 6d 65 29 0a 20 20 28 73 64 page_name). (sd
4a90: 61 74 2d 73 65 74 2d 70 61 67 65 21 20 73 65 6c at-set-page! sel
4aa0: 66 20 70 61 67 65 5f 6e 61 6d 65 29 29 0a 0a 28 f page_name))..(
4ab0: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
4ac0: 63 6c 6f 73 65 20 73 65 6c 66 29 0a 20 20 28 64 close self). (d
4ad0: 62 69 3a 63 6c 6f 73 65 20 28 73 64 61 74 2d 67 bi:close (sdat-g
4ae0: 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 29 0a et-conn self))).
4af0: 3b 3b 20 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 ;; (close-output
4b00: 2d 70 6f 72 74 20 28 73 64 61 74 2d 67 65 74 2d -port (sdat-get-
4b10: 6c 6f 67 70 74 20 73 65 6c 66 29 29 0a 0a 28 64 logpt self))..(d
4b20: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 65 efine (session:e
4b30: 72 72 2d 6d 73 67 20 73 65 6c 66 20 6d 73 67 29 rr-msg self msg)
4b40: 0a 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 . (hash-table-s
4b50: 65 74 21 20 28 73 64 61 74 2d 67 65 74 2d 73 65 et! (sdat-get-se
4b60: 73 73 69 6f 6e 76 61 72 73 20 73 65 6c 66 29 20 ssionvars self)
4b70: 22 45 52 52 4f 52 5f 4d 53 47 22 0a 09 09 20 20 "ERROR_MSG"...
4b80: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
4b90: 65 72 73 65 20 28 6d 61 70 20 73 3a 61 6e 79 2d erse (map s:any-
4ba0: 3e 73 74 72 69 6e 67 20 6d 73 67 29 20 22 20 22 >string msg) " "
4bb0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 )))..(define (se
4bc0: 73 73 69 6f 6e 3a 70 72 65 76 2d 65 72 72 20 73 ssion:prev-err s
4bd0: 65 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 70 72 elf). (let ((pr
4be0: 65 76 2d 65 72 72 20 28 68 61 73 68 2d 74 61 62 ev-err (hash-tab
4bf0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 28 le-ref/default (
4c00: 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e sdat-get-session
4c10: 76 61 72 73 2d 62 65 66 6f 72 65 20 73 65 6c 66 vars-before self
4c20: 29 20 22 45 52 52 4f 52 5f 4d 53 47 22 20 23 66 ) "ERROR_MSG" #f
4c30: 29 29 0a 09 28 63 75 72 72 2d 65 72 72 20 28 68 ))..(curr-err (h
4c40: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
4c50: 66 61 75 6c 74 20 28 73 64 61 74 2d 67 65 74 2d fault (sdat-get-
4c60: 73 65 73 73 69 6f 6e 76 61 72 73 20 73 65 6c 66 sessionvars self
4c70: 29 20 22 45 52 52 4f 52 5f 4d 53 47 22 20 23 66 ) "ERROR_MSG" #f
4c80: 29 29 29 0a 20 20 20 20 28 69 66 20 70 72 65 76 ))). (if prev
4c90: 2d 65 72 72 20 70 72 65 76 2d 65 72 72 0a 09 28 -err prev-err..(
4ca0: 69 66 20 63 75 72 72 2d 65 72 72 20 63 75 72 72 if curr-err curr
4cb0: 2d 65 72 72 20 23 66 29 29 29 29 0a 0a 3b 3b 20 -err #f))))..;;
4cc0: 73 65 73 73 69 6f 6e 20 76 61 72 73 0a 3b 3b 20 session vars.;;
4cd0: 31 2e 20 6b 65 79 73 20 61 72 65 20 61 6c 77 61 1. keys are alwa
4ce0: 79 73 20 61 20 73 74 72 69 6e 67 20 4e 4f 54 20 ys a string NOT
4cf0: 61 20 73 79 6d 62 6f 6c 0a 3b 3b 20 32 2e 20 76 a symbol.;; 2. v
4d00: 61 6c 75 65 73 20 61 72 65 20 61 6c 77 61 79 73 alues are always
4d10: 20 61 20 73 74 72 69 6e 67 20 63 6f 6e 76 65 72 a string conver
4d20: 73 69 6f 6e 20 69 73 20 74 68 65 20 72 65 73 70 sion is the resp
4d30: 6f 6e 73 69 62 69 6c 69 74 79 20 6f 66 20 74 68 onsibility of th
4d40: 65 20 0a 3b 3b 20 20 20 20 63 6f 6e 73 75 6d 69 e .;; consumi
4d50: 6e 67 20 66 75 6e 63 74 69 6f 6e 20 28 61 74 20 ng function (at
4d60: 6c 65 61 73 74 20 66 6f 72 20 6e 6f 77 2c 20 49 least for now, I
4d70: 27 64 20 6c 69 6b 65 20 74 6f 20 63 68 61 6e 67 'd like to chang
4d80: 65 20 74 68 69 73 29 0a 0a 3b 3b 20 73 65 74 20 e this)..;; set
4d90: 61 20 73 65 73 73 69 6f 6e 20 76 61 72 20 66 6f a session var fo
4da0: 72 20 74 68 65 20 63 75 72 72 65 6e 74 20 70 61 r the current pa
4db0: 67 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 ge.;;.(define (s
4dc0: 65 73 73 69 6f 6e 3a 63 75 72 72 2d 70 61 67 65 ession:curr-page
4dd0: 2d 73 65 74 21 20 73 65 6c 66 20 6b 65 79 20 76 -set! self key v
4de0: 61 6c 75 65 29 0a 20 20 28 68 61 73 68 2d 74 61 alue). (hash-ta
4df0: 62 6c 65 2d 73 65 74 21 20 28 73 64 61 74 2d 67 ble-set! (sdat-g
4e00: 65 74 2d 70 61 67 65 76 61 72 73 20 73 65 6c 66 et-pagevars self
4e10: 29 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 ) (s:any->string
4e20: 20 6b 65 79 29 20 28 73 3a 61 6e 79 2d 3e 73 74 key) (s:any->st
4e30: 72 69 6e 67 20 76 61 6c 75 65 29 29 29 0a 0a 3b ring value)))..;
4e40: 3b 20 64 65 6c 20 61 20 76 61 72 20 66 6f 72 20 ; del a var for
4e50: 74 68 65 20 63 75 72 72 65 6e 74 20 70 61 67 65 the current page
4e60: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 73 .;;.(define (ses
4e70: 73 69 6f 6e 3a 70 61 67 65 2d 76 61 72 2d 64 65 sion:page-var-de
4e80: 6c 21 20 73 65 6c 66 20 6b 65 79 29 0a 20 20 28 l! self key). (
4e90: 68 61 73 68 2d 74 61 62 6c 65 2d 64 65 6c 65 74 hash-table-delet
4ea0: 65 21 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 e! (sdat-get-pag
4eb0: 65 76 61 72 73 20 73 65 6c 66 29 20 28 73 3a 61 evars self) (s:a
4ec0: 6e 79 2d 3e 73 74 72 69 6e 67 20 6b 65 79 29 29 ny->string key))
4ed0: 29 0a 0a 3b 3b 20 67 65 74 20 74 68 65 20 61 70 )..;; get the ap
4ee0: 70 72 6f 70 72 69 61 74 65 20 68 61 73 68 20 67 propriate hash g
4ef0: 69 76 65 6e 20 61 20 70 61 67 65 20 22 2a 73 65 iven a page "*se
4f00: 73 73 69 6f 6e 76 61 72 73 2a 2c 20 2a 67 6c 6f ssionvars*, *glo
4f10: 62 61 6c 76 61 72 73 2a 20 6f 72 20 70 61 67 65 balvars* or page
4f20: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 73 .;;.(define (ses
4f30: 73 69 6f 6e 3a 67 65 74 2d 70 61 67 65 2d 68 61 sion:get-page-ha
4f40: 73 68 20 73 65 6c 66 20 70 61 67 65 29 0a 20 20 sh self page).
4f50: 28 69 66 20 28 73 74 72 69 6e 67 3d 3f 20 70 61 (if (string=? pa
4f60: 67 65 20 22 2a 73 65 73 73 69 6f 6e 76 61 72 73 ge "*sessionvars
4f70: 2a 22 29 0a 20 20 20 20 20 20 28 73 64 61 74 2d *"). (sdat-
4f80: 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 20 get-sessionvars
4f90: 73 65 6c 66 29 0a 20 20 20 20 20 20 28 69 66 20 self). (if
4fa0: 28 73 74 72 69 6e 67 3d 3f 20 70 61 67 65 20 22 (string=? page "
4fb0: 2a 67 6c 6f 62 61 6c 76 61 72 73 2a 22 29 0a 09 *globalvars*")..
4fc0: 20 20 28 73 64 61 74 2d 67 65 74 2d 67 6c 6f 62 (sdat-get-glob
4fd0: 61 6c 76 61 72 73 20 73 65 6c 66 29 0a 09 20 20 alvars self)..
4fe0: 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 76 61 (sdat-get-pageva
4ff0: 72 73 20 73 65 6c 66 29 29 29 29 0a 0a 3b 3b 20 rs self))))..;;
5000: 73 65 74 20 61 20 73 65 73 73 69 6f 6e 20 76 61 set a session va
5010: 72 20 66 6f 72 20 61 20 67 69 76 65 6e 20 70 61 r for a given pa
5020: 67 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 ge.;;.(define (s
5030: 65 73 73 69 6f 6e 3a 73 65 74 21 20 73 65 6c 66 ession:set! self
5040: 20 70 61 67 65 20 6b 65 79 20 76 61 6c 75 65 29 page key value)
5050: 0a 20 20 28 6c 65 74 20 28 28 68 74 20 28 73 65 . (let ((ht (se
5060: 73 73 69 6f 6e 3a 67 65 74 2d 70 61 67 65 2d 68 ssion:get-page-h
5070: 61 73 68 20 73 65 6c 66 20 70 61 67 65 29 29 29 ash self page)))
5080: 0a 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 . (hash-table
5090: 2d 73 65 74 21 20 68 74 20 28 73 3a 61 6e 79 2d -set! ht (s:any-
50a0: 3e 73 74 72 69 6e 67 20 6b 65 79 29 20 28 73 3a >string key) (s:
50b0: 61 6e 79 2d 3e 73 74 72 69 6e 67 20 76 61 6c 75 any->string valu
50c0: 65 29 29 29 29 0a 0a 3b 3b 20 67 65 74 20 73 65 e))))..;; get se
50d0: 73 73 69 6f 6e 20 76 61 72 73 20 66 6f 72 20 74 ssion vars for t
50e0: 68 65 20 63 75 72 72 65 6e 74 20 70 61 67 65 0a he current page.
50f0: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 ;;.(define (sess
5100: 69 6f 6e 3a 70 61 67 65 2d 67 65 74 20 73 65 6c ion:page-get sel
5110: 66 20 6b 65 79 29 0a 20 20 28 68 61 73 68 2d 74 f key). (hash-t
5120: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
5130: 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 76 (sdat-get-pagev
5140: 61 72 73 20 73 65 6c 66 29 20 6b 65 79 20 23 66 ars self) key #f
5150: 29 29 0a 0a 3b 3b 20 67 65 74 20 73 65 73 73 69 ))..;; get sessi
5160: 6f 6e 20 76 61 72 73 20 66 6f 72 20 61 20 73 70 on vars for a sp
5170: 65 63 69 66 69 65 64 20 70 61 67 65 0a 3b 3b 0a ecified page.;;.
5180: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
5190: 3a 67 65 74 20 73 65 6c 66 20 70 61 67 65 20 6b :get self page k
51a0: 65 79 20 70 61 72 61 6d 73 29 0a 20 20 28 6c 65 ey params). (le
51b0: 74 2a 20 28 28 68 74 20 20 28 73 65 73 73 69 6f t* ((ht (sessio
51c0: 6e 3a 67 65 74 2d 70 61 67 65 2d 68 61 73 68 20 n:get-page-hash
51d0: 73 65 6c 66 20 70 61 67 65 29 29 0a 09 20 28 72 self page)).. (r
51e0: 65 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 es (hash-table-r
51f0: 65 66 2f 64 65 66 61 75 6c 74 20 68 74 20 28 73 ef/default ht (s
5200: 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6b 65 79 :any->string key
5210: 29 20 23 66 29 29 29 0a 20 20 20 20 28 73 65 73 ) #f))). (ses
5220: 73 69 6f 6e 3a 61 70 70 6c 79 2d 74 79 70 65 2d sion:apply-type-
5230: 70 72 65 66 65 72 65 6e 63 65 20 72 65 73 20 70 preference res p
5240: 61 72 61 6d 73 29 29 29 0a 0a 3b 3b 20 64 65 6c arams)))..;; del
5250: 65 74 65 20 61 20 73 65 73 73 69 6f 6e 20 76 61 ete a session va
5260: 72 20 66 6f 72 20 61 20 73 70 65 63 69 66 69 65 r for a specifie
5270: 64 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 69 6e d page.;;.(defin
5280: 65 20 28 73 65 73 73 69 6f 6e 3a 64 65 6c 21 20 e (session:del!
5290: 73 65 6c 66 20 70 61 67 65 20 6b 65 79 29 0a 20 self page key).
52a0: 20 28 6c 65 74 20 28 28 68 74 20 28 73 65 73 73 (let ((ht (sess
52b0: 69 6f 6e 3a 67 65 74 2d 70 61 67 65 2d 68 61 73 ion:get-page-has
52c0: 68 20 73 65 6c 66 20 70 61 67 65 29 29 29 0a 20 h self page))).
52d0: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 64 (hash-table-d
52e0: 65 6c 65 74 65 21 20 68 74 20 28 73 3a 61 6e 79 elete! ht (s:any
52f0: 2d 3e 73 74 72 69 6e 67 20 6b 65 79 29 29 29 29 ->string key))))
5300: 0a 0a 3b 3b 20 67 65 74 20 41 4c 4c 20 6b 65 79 ..;; get ALL key
5310: 73 20 66 6f 72 20 74 68 69 73 20 70 61 67 65 20 s for this page
5320: 61 6e 64 20 73 74 6f 72 65 20 69 6e 20 74 68 65 and store in the
5330: 20 73 65 73 73 69 6f 6e 20 70 61 67 65 76 61 72 session pagevar
5340: 73 20 68 61 73 68 0a 3b 3b 0a 28 64 65 66 69 6e s hash.;;.(defin
5350: 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 76 e (session:get-v
5360: 61 72 73 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 ars self). (let
5370: 20 28 28 73 65 73 73 69 6f 6e 2d 69 64 20 20 28 ((session-id (
5380: 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e sdat-get-session
5390: 2d 69 64 20 73 65 6c 66 29 29 29 0a 20 20 20 20 -id self))).
53a0: 28 69 66 20 28 6e 6f 74 20 73 65 73 73 69 6f 6e (if (not session
53b0: 2d 69 64 29 0a 09 28 65 72 72 3a 6c 6f 67 20 22 -id)..(err:log "
53c0: 45 52 52 4f 52 3a 20 4e 6f 20 73 65 73 73 69 6f ERROR: No sessio
53d0: 6e 20 69 64 20 69 6e 20 73 65 73 73 69 6f 6e 20 n id in session
53e0: 6f 62 6a 65 63 74 21 20 73 65 73 73 69 6f 6e 3a object! session:
53f0: 67 65 74 2d 76 61 72 73 22 29 0a 09 28 6c 65 74 get-vars")..(let
5400: 2a 20 28 28 72 65 73 75 6c 74 20 20 20 20 20 20 * ((result
5410: 20 20 20 20 20 20 20 23 66 29 0a 09 20 20 20 20 #f)..
5420: 20 20 20 28 63 6f 6e 6e 20 20 20 20 20 20 20 20 (conn
5430: 20 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 (sdat-get
5440: 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 0a 09 20 20 -conn self))..
5450: 20 20 20 20 20 28 70 61 67 65 76 61 72 73 2d 62 (pagevars-b
5460: 65 66 6f 72 65 20 20 20 20 28 73 64 61 74 2d 67 efore (sdat-g
5470: 65 74 2d 70 61 67 65 76 61 72 73 2d 62 65 66 6f et-pagevars-befo
5480: 72 65 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 re self))..
5490: 20 20 28 73 65 73 73 69 6f 6e 76 61 72 73 2d 62 (sessionvars-b
54a0: 65 66 6f 72 65 20 28 73 64 61 74 2d 67 65 74 2d efore (sdat-get-
54b0: 73 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 6f sessionvars-befo
54c0: 72 65 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 re self))..
54d0: 20 20 28 67 6c 6f 62 61 6c 76 61 72 73 2d 62 65 (globalvars-be
54e0: 66 6f 72 65 20 20 28 73 64 61 74 2d 67 65 74 2d fore (sdat-get-
54f0: 67 6c 6f 62 61 6c 76 61 72 73 2d 62 65 66 6f 72 globalvars-befor
5500: 65 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 20 e self))..
5510: 20 28 70 61 67 65 76 61 72 73 20 20 20 20 20 20 (pagevars
5520: 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d 70 (sdat-get-p
5530: 61 67 65 76 61 72 73 20 73 65 6c 66 29 29 0a 09 agevars self))..
5540: 20 20 20 20 20 20 20 28 73 65 73 73 69 6f 6e 76 (sessionv
5550: 61 72 73 20 20 20 20 20 20 20 20 28 73 64 61 74 ars (sdat
5560: 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 -get-sessionvars
5570: 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 20 20 self))..
5580: 28 67 6c 6f 62 61 6c 76 61 72 73 20 20 20 20 20 (globalvars
5590: 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d 67 6c (sdat-get-gl
55a0: 6f 62 61 6c 76 61 72 73 20 73 65 6c 66 29 29 0a obalvars self)).
55b0: 09 20 20 20 20 20 20 20 28 70 61 67 65 2d 6e 61 . (page-na
55c0: 6d 65 20 20 20 20 20 20 20 20 20 20 28 73 64 61 me (sda
55d0: 74 2d 67 65 74 2d 70 61 67 65 20 73 65 6c 66 29 t-get-page self)
55e0: 29 0a 09 20 20 20 20 20 20 20 28 73 65 73 73 69 ).. (sessi
55f0: 6f 6e 2d 6b 65 79 20 20 20 20 20 20 20 20 28 73 on-key (s
5600: 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 2d dat-get-session-
5610: 6b 65 79 20 73 65 6c 66 29 29 0a 09 20 20 20 20 key self))..
5620: 20 20 20 28 71 75 65 72 79 20 20 20 20 20 20 20 (query
5630: 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 61 (string-a
5640: 70 70 65 6e 64 0a 09 09 09 09 20 20 20 20 22 53 ppend..... "S
5650: 45 4c 45 43 54 20 6b 65 79 2c 76 61 6c 75 65 20 ELECT key,value
5660: 46 52 4f 4d 20 73 65 73 73 69 6f 6e 5f 76 61 72 FROM session_var
5670: 73 20 49 4e 4e 45 52 20 4a 4f 49 4e 20 73 65 73 s INNER JOIN ses
5680: 73 69 6f 6e 73 20 4f 4e 20 73 65 73 73 69 6f 6e sions ON session
5690: 5f 76 61 72 73 2e 73 65 73 73 69 6f 6e 5f 69 64 _vars.session_id
56a0: 3d 73 65 73 73 69 6f 6e 73 2e 69 64 20 22 0a 09 =sessions.id "..
56b0: 09 09 09 20 20 20 20 22 57 48 45 52 45 20 73 65 ... "WHERE se
56c0: 73 73 69 6f 6e 5f 6b 65 79 3d 3f 20 41 4e 44 20 ssion_key=? AND
56d0: 70 61 67 65 3d 3f 3b 22 29 29 29 0a 09 20 20 3b page=?;"))).. ;
56e0: 3b 20 66 69 72 73 74 20 74 68 65 20 70 61 67 65 ; first the page
56f0: 20 73 70 65 63 69 66 69 63 20 76 61 72 73 0a 09 specific vars..
5700: 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d (dbi:for-each-
5710: 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 75 70 row (lambda (tup
5720: 6c 65 29 0a 09 09 09 20 20 20 20 20 20 28 6c 65 le).... (le
5730: 74 20 28 28 6b 20 28 76 65 63 74 6f 72 2d 72 65 t ((k (vector-re
5740: 66 20 74 75 70 6c 65 20 30 29 29 0a 09 09 09 09 f tuple 0)).....
5750: 20 20 20 20 28 76 20 28 76 65 63 74 6f 72 2d 72 (v (vector-r
5760: 65 66 20 74 75 70 6c 65 20 31 29 29 29 0a 09 09 ef tuple 1)))...
5770: 09 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 ..(hash-table-se
5780: 74 21 20 70 61 67 65 76 61 72 73 2d 62 65 66 6f t! pagevars-befo
5790: 72 65 20 6b 20 76 29 0a 09 09 09 09 28 68 61 73 re k v).....(has
57a0: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 70 61 67 h-table-set! pag
57b0: 65 76 61 72 73 20 20 20 20 20 20 20 20 6b 20 76 evars k v
57c0: 29 29 29 0a 09 09 09 20 20 20 20 63 6f 6e 6e 0a ))).... conn.
57d0: 09 09 09 20 20 20 20 28 73 3a 73 71 6c 70 61 72 ... (s:sqlpar
57e0: 61 6d 20 71 75 65 72 79 20 73 65 73 73 69 6f 6e am query session
57f0: 2d 6b 65 79 20 70 61 67 65 2d 6e 61 6d 65 29 29 -key page-name))
5800: 0a 09 20 20 3b 3b 20 74 68 65 6e 20 74 68 65 20 .. ;; then the
5810: 73 65 73 73 69 6f 6e 20 73 70 65 63 69 66 69 63 session specific
5820: 20 76 61 72 73 0a 09 20 20 28 64 62 69 3a 66 6f vars.. (dbi:fo
5830: 72 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 6d 62 r-each-row (lamb
5840: 64 61 20 28 74 75 70 6c 65 29 0a 09 09 09 20 20 da (tuple)....
5850: 20 20 20 20 28 6c 65 74 20 28 28 6b 20 28 76 65 (let ((k (ve
5860: 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 30 ctor-ref tuple 0
5870: 29 29 0a 09 09 09 09 20 20 20 20 28 76 20 28 76 ))..... (v (v
5880: 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 ector-ref tuple
5890: 31 29 29 29 0a 09 09 09 09 28 68 61 73 68 2d 74 1))).....(hash-t
58a0: 61 62 6c 65 2d 73 65 74 21 20 73 65 73 73 69 6f able-set! sessio
58b0: 6e 76 61 72 73 2d 62 65 66 6f 72 65 20 6b 20 76 nvars-before k v
58c0: 29 0a 09 09 09 09 28 68 61 73 68 2d 74 61 62 6c ).....(hash-tabl
58d0: 65 2d 73 65 74 21 20 73 65 73 73 69 6f 6e 76 61 e-set! sessionva
58e0: 72 73 20 20 20 20 20 20 20 20 6b 20 76 29 29 29 rs k v)))
58f0: 0a 09 09 09 20 20 20 20 63 6f 6e 6e 0a 09 09 09 .... conn....
5900: 20 20 20 20 28 73 3a 73 71 6c 70 61 72 61 6d 20 (s:sqlparam
5910: 71 75 65 72 79 20 73 65 73 73 69 6f 6e 2d 6b 65 query session-ke
5920: 79 20 22 2a 73 65 73 73 69 6f 6e 76 61 72 73 2a y "*sessionvars*
5930: 22 29 29 0a 09 20 20 3b 3b 20 61 6e 64 20 66 69 ")).. ;; and fi
5940: 6e 61 6c 6c 79 20 74 68 65 20 67 6c 6f 62 61 6c nally the global
5950: 20 76 61 72 73 0a 09 20 20 28 64 62 69 3a 66 6f vars.. (dbi:fo
5960: 72 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 6d 62 r-each-row (lamb
5970: 64 61 20 28 74 75 70 6c 65 29 0a 09 09 09 20 20 da (tuple)....
5980: 20 20 20 20 28 6c 65 74 20 28 28 6b 20 28 76 65 (let ((k (ve
5990: 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 30 ctor-ref tuple 0
59a0: 29 29 0a 09 09 09 09 20 20 20 20 28 76 20 28 76 ))..... (v (v
59b0: 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 ector-ref tuple
59c0: 31 29 29 29 0a 09 09 09 09 28 68 61 73 68 2d 74 1))).....(hash-t
59d0: 61 62 6c 65 2d 73 65 74 21 20 67 6c 6f 62 61 6c able-set! global
59e0: 76 61 72 73 2d 62 65 66 6f 72 65 20 6b 20 76 29 vars-before k v)
59f0: 0a 09 09 09 09 28 68 61 73 68 2d 74 61 62 6c 65 .....(hash-table
5a00: 2d 73 65 74 21 20 67 6c 6f 62 61 6c 76 61 72 73 -set! globalvars
5a10: 20 20 20 20 20 20 20 20 6b 20 76 29 29 29 0a 09 k v)))..
5a20: 09 09 20 20 20 20 63 6f 6e 6e 0a 09 09 09 20 20 .. conn....
5a30: 20 20 28 73 3a 73 71 6c 70 61 72 61 6d 20 71 75 (s:sqlparam qu
5a40: 65 72 79 20 73 65 73 73 69 6f 6e 2d 6b 65 79 20 ery session-key
5a50: 22 2a 67 6c 6f 62 61 6c 76 61 72 73 22 29 29 0a "*globalvars")).
5a60: 09 20 20 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 . ))))..(define
5a70: 20 28 73 65 73 73 69 6f 6e 3a 73 61 76 65 2d 76 (session:save-v
5a80: 61 72 73 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 ars self). (let
5a90: 20 28 28 73 65 73 73 69 6f 6e 2d 69 64 20 20 28 ((session-id (
5aa0: 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e sdat-get-session
5ab0: 2d 69 64 20 73 65 6c 66 29 29 29 0a 20 20 20 20 -id self))).
5ac0: 28 69 66 20 28 6e 6f 74 20 73 65 73 73 69 6f 6e (if (not session
5ad0: 2d 69 64 29 0a 09 28 65 72 72 3a 6c 6f 67 20 22 -id)..(err:log "
5ae0: 45 52 52 4f 52 3a 20 4e 6f 20 73 65 73 73 69 6f ERROR: No sessio
5af0: 6e 20 69 64 20 69 6e 20 73 65 73 73 69 6f 6e 20 n id in session
5b00: 6f 62 6a 65 63 74 21 20 73 65 73 73 69 6f 6e 3a object! session:
5b10: 67 65 74 2d 76 61 72 73 22 29 0a 09 28 6c 65 74 get-vars")..(let
5b20: 2a 20 28 28 73 74 61 74 75 73 20 20 20 20 20 20 * ((status
5b30: 23 66 29 0a 09 20 20 20 20 20 20 20 28 63 6f 6e #f).. (con
5b40: 6e 20 20 20 20 20 20 20 20 28 73 64 61 74 2d 67 n (sdat-g
5b50: 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 0a 09 et-conn self))..
5b60: 20 20 20 20 20 20 20 28 70 61 67 65 2d 6e 61 6d (page-nam
5b70: 65 20 20 20 28 73 64 61 74 2d 67 65 74 2d 70 61 e (sdat-get-pa
5b80: 67 65 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 ge self))..
5b90: 20 20 28 64 65 6c 2d 71 75 65 72 79 20 20 20 22 (del-query "
5ba0: 44 45 4c 45 54 45 20 46 52 4f 4d 20 73 65 73 73 DELETE FROM sess
5bb0: 69 6f 6e 5f 76 61 72 73 20 57 48 45 52 45 20 73 ion_vars WHERE s
5bc0: 65 73 73 69 6f 6e 5f 69 64 3d 3f 20 41 4e 44 20 ession_id=? AND
5bd0: 70 61 67 65 3d 3f 20 41 4e 44 20 6b 65 79 3d 3f page=? AND key=?
5be0: 3b 22 29 0a 09 20 20 20 20 20 20 20 28 69 6e 73 ;").. (ins
5bf0: 2d 71 75 65 72 79 20 20 20 22 49 4e 53 45 52 54 -query "INSERT
5c00: 20 49 4e 54 4f 20 73 65 73 73 69 6f 6e 5f 76 61 INTO session_va
5c10: 72 73 20 28 73 65 73 73 69 6f 6e 5f 69 64 2c 70 rs (session_id,p
5c20: 61 67 65 2c 6b 65 79 2c 76 61 6c 75 65 29 20 56 age,key,value) V
5c30: 41 4c 55 45 53 28 3f 2c 3f 2c 3f 2c 3f 29 3b 22 ALUES(?,?,?,?);"
5c40: 29 0a 09 20 20 20 20 20 20 20 28 75 70 64 2d 71 ).. (upd-q
5c50: 75 65 72 79 20 20 20 22 55 50 44 41 54 45 20 73 uery "UPDATE s
5c60: 65 73 73 69 6f 6e 5f 76 61 72 73 20 73 65 74 20 ession_vars set
5c70: 76 61 6c 75 65 3d 3f 20 57 48 45 52 45 20 6b 65 value=? WHERE ke
5c80: 79 3d 3f 20 41 4e 44 20 73 65 73 73 69 6f 6e 5f y=? AND session_
5c90: 69 64 3d 3f 20 41 4e 44 20 70 61 67 65 3d 3f 3b id=? AND page=?;
5ca0: 22 29 0a 09 20 20 20 20 20 20 20 28 63 68 61 6e ").. (chan
5cb0: 67 65 64 2d 63 6f 75 6e 74 20 30 29 29 0a 09 20 ged-count 0))..
5cc0: 20 3b 3b 20 73 61 76 65 20 74 68 65 20 64 65 6c ;; save the del
5cd0: 74 61 20 6f 6e 6c 79 0a 09 20 20 28 66 6f 72 2d ta only.. (for-
5ce0: 65 61 63 68 0a 09 20 20 20 28 6c 61 6d 62 64 61 each.. (lambda
5cf0: 20 28 70 61 67 65 29 20 3b 3b 20 70 61 67 65 20 (page) ;; page
5d00: 69 73 3a 20 22 2a 67 6c 6f 62 61 6c 76 61 72 73 is: "*globalvars
5d10: 2a 22 20 22 2a 73 65 73 73 69 6f 6e 76 61 72 73 *" "*sessionvars
5d20: 2a 22 20 6f 72 20 6f 74 68 65 72 73 74 72 69 6e *" or otherstrin
5d30: 67 0a 09 20 20 20 20 20 28 6c 65 74 2a 20 28 28 g.. (let* ((
5d40: 62 65 66 6f 72 65 2d 61 66 74 65 72 2d 68 74 20 before-after-ht
5d50: 28 63 6f 6e 64 0a 09 09 09 09 20 20 20 20 20 20 (cond.....
5d60: 28 28 73 74 72 69 6e 67 3d 3f 20 70 61 67 65 20 ((string=? page
5d70: 22 2a 73 65 73 73 69 6f 6e 76 61 72 73 2a 22 29 "*sessionvars*")
5d80: 0a 09 09 09 09 20 20 20 20 20 20 20 28 76 65 63 ..... (vec
5d90: 74 6f 72 20 28 73 64 61 74 2d 67 65 74 2d 73 65 tor (sdat-get-se
5da0: 73 73 69 6f 6e 76 61 72 73 20 73 65 6c 66 29 0a ssionvars self).
5db0: 09 09 09 09 09 20 20 20 20 20 20 20 28 73 64 61 ..... (sda
5dc0: 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 t-get-sessionvar
5dd0: 73 2d 62 65 66 6f 72 65 20 73 65 6c 66 29 29 29 s-before self)))
5de0: 0a 09 09 09 09 20 20 20 20 20 20 20 28 28 73 74 ..... ((st
5df0: 72 69 6e 67 3d 3f 20 70 61 67 65 20 22 2a 67 6c ring=? page "*gl
5e00: 6f 62 61 6c 76 61 72 73 2a 22 29 0a 09 09 09 09 obalvars*").....
5e10: 09 28 76 65 63 74 6f 72 20 28 73 64 61 74 2d 67 .(vector (sdat-g
5e20: 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 20 73 65 et-globalvars se
5e30: 6c 66 29 0a 09 09 09 09 09 09 28 73 64 61 74 2d lf).......(sdat-
5e40: 67 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 2d 62 get-globalvars-b
5e50: 65 66 6f 72 65 20 73 65 6c 66 29 29 29 0a 09 09 efore self)))...
5e60: 09 09 20 20 20 20 20 20 20 28 65 6c 73 65 20 0a .. (else .
5e70: 09 09 09 09 09 28 76 65 63 74 6f 72 20 28 73 64 .....(vector (sd
5e80: 61 74 2d 67 65 74 2d 70 61 67 65 76 61 72 73 20 at-get-pagevars
5e90: 73 65 6c 66 29 0a 09 09 09 09 09 09 28 73 64 61 self).......(sda
5ea0: 74 2d 67 65 74 2d 70 61 67 65 76 61 72 73 2d 62 t-get-pagevars-b
5eb0: 65 66 6f 72 65 20 73 65 6c 66 29 29 29 29 29 0a efore self))))).
5ec0: 09 09 20 20 20 20 28 6d 61 73 74 65 72 2d 68 74 .. (master-ht
5ed0: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 62 (vector-ref b
5ee0: 65 66 6f 72 65 2d 61 66 74 65 72 2d 68 74 20 30 efore-after-ht 0
5ef0: 29 29 0a 09 09 20 20 20 20 28 62 65 66 6f 72 65 ))... (before
5f00: 2d 68 74 20 20 20 28 76 65 63 74 6f 72 2d 72 65 -ht (vector-re
5f10: 66 20 62 65 66 6f 72 65 2d 61 66 74 65 72 2d 68 f before-after-h
5f20: 74 20 31 29 29 0a 09 09 20 20 20 20 28 6d 61 73 t 1))... (mas
5f30: 74 65 72 2d 6b 65 79 73 20 28 68 61 73 68 2d 74 ter-keys (hash-t
5f40: 61 62 6c 65 2d 6b 65 79 73 20 6d 61 73 74 65 72 able-keys master
5f50: 2d 68 74 29 29 0a 09 09 20 20 20 20 28 62 65 66 -ht))... (bef
5f60: 6f 72 65 2d 6b 65 79 73 20 28 68 61 73 68 2d 74 ore-keys (hash-t
5f70: 61 62 6c 65 2d 6b 65 79 73 20 62 65 66 6f 72 65 able-keys before
5f80: 2d 68 74 29 29 0a 09 09 20 20 20 20 28 61 6c 6c -ht))... (all
5f90: 2d 6b 65 79 73 20 28 64 65 6c 65 74 65 2d 64 75 -keys (delete-du
5fa0: 70 6c 69 63 61 74 65 73 20 28 61 70 70 65 6e 64 plicates (append
5fb0: 20 6d 61 73 74 65 72 2d 6b 65 79 73 20 62 65 66 master-keys bef
5fc0: 6f 72 65 2d 6b 65 79 73 29 29 29 29 0a 09 20 20 ore-keys))))..
5fd0: 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a (for-each .
5fe0: 09 09 28 6c 61 6d 62 64 61 20 28 6b 65 79 29 0a ..(lambda (key).
5ff0: 09 09 20 20 28 6c 65 74 20 28 28 6d 61 73 74 65 .. (let ((maste
6000: 72 2d 76 61 6c 75 65 20 28 68 61 73 68 2d 74 61 r-value (hash-ta
6010: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
6020: 6d 61 73 74 65 72 2d 68 74 20 6b 65 79 20 23 66 master-ht key #f
6030: 29 29 0a 09 09 09 28 62 65 66 6f 72 65 2d 76 61 ))....(before-va
6040: 6c 75 65 20 28 68 61 73 68 2d 74 61 62 6c 65 2d lue (hash-table-
6050: 72 65 66 2f 64 65 66 61 75 6c 74 20 62 65 66 6f ref/default befo
6060: 72 65 2d 68 74 20 6b 65 79 20 23 66 29 29 29 0a re-ht key #f))).
6070: 09 09 20 20 20 20 28 63 6f 6e 64 0a 09 09 20 20 .. (cond...
6080: 20 20 20 3b 3b 20 62 65 66 6f 72 65 20 61 6e 64 ;; before and
6090: 20 61 66 74 65 72 20 65 78 69 73 74 20 61 6e 64 after exist and
60a0: 20 76 61 6c 75 65 20 75 6e 63 68 61 6e 67 65 64 value unchanged
60b0: 20 2d 20 64 6f 20 6e 6f 74 68 69 6e 67 0a 09 09 - do nothing...
60c0: 20 20 20 20 20 28 28 61 6e 64 20 6d 61 73 74 65 ((and maste
60d0: 72 2d 76 61 6c 75 65 20 62 65 66 6f 72 65 2d 76 r-value before-v
60e0: 61 6c 75 65 20 28 65 71 75 61 6c 3f 20 6d 61 73 alue (equal? mas
60f0: 74 65 72 2d 76 61 6c 75 65 20 62 65 66 6f 72 65 ter-value before
6100: 2d 76 61 6c 75 65 29 29 29 0a 09 09 20 20 20 20 -value)))...
6110: 20 3b 3b 20 62 65 66 6f 72 65 20 61 6e 64 20 61 ;; before and a
6120: 66 74 65 72 20 65 78 69 73 74 20 62 75 74 20 61 fter exist but a
6130: 72 65 20 63 68 61 6e 67 65 64 0a 09 09 20 20 20 re changed...
6140: 20 20 28 28 61 6e 64 20 6d 61 73 74 65 72 2d 76 ((and master-v
6150: 61 6c 75 65 20 62 65 66 6f 72 65 2d 76 61 6c 75 alue before-valu
6160: 65 29 0a 09 09 20 20 20 20 20 20 28 64 62 69 3a e)... (dbi:
6170: 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 for-each-row (la
6180: 6d 62 64 61 20 28 74 75 70 6c 65 29 0a 09 09 09 mbda (tuple)....
6190: 09 09 20 20 28 73 65 74 21 20 63 68 61 6e 67 65 .. (set! change
61a0: 64 2d 63 6f 75 6e 74 20 28 2b 20 63 68 61 6e 67 d-count (+ chang
61b0: 65 64 2d 63 6f 75 6e 74 20 31 29 29 29 0a 09 09 ed-count 1)))...
61c0: 09 09 09 63 6f 6e 6e 0a 09 09 09 09 09 28 73 3a ...conn......(s:
61d0: 73 71 6c 70 61 72 61 6d 20 75 70 64 2d 71 75 65 sqlparam upd-que
61e0: 72 79 20 6d 61 73 74 65 72 2d 76 61 6c 75 65 20 ry master-value
61f0: 6b 65 79 20 73 65 73 73 69 6f 6e 2d 69 64 20 70 key session-id p
6200: 61 67 65 29 29 29 0a 09 09 20 20 20 20 20 3b 3b age)))... ;;
6210: 20 6d 61 73 74 65 72 2d 76 61 6c 75 65 20 6e 6f master-value no
6220: 20 6c 6f 6e 67 65 72 20 65 78 69 73 74 73 20 28 longer exists (
6230: 69 2e 65 2e 20 23 66 29 20 2d 20 72 65 6d 6f 76 i.e. #f) - remov
6240: 65 20 69 74 65 6d 0a 09 09 20 20 20 20 20 28 28 e item... ((
6250: 6e 6f 74 20 6d 61 73 74 65 72 2d 76 61 6c 75 65 not master-value
6260: 29 0a 09 09 20 20 20 20 20 20 28 64 62 69 3a 66 )... (dbi:f
6270: 6f 72 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 6d or-each-row (lam
6280: 62 64 61 20 28 74 75 70 6c 65 29 0a 09 09 09 09 bda (tuple).....
6290: 09 20 20 28 73 65 74 21 20 63 68 61 6e 67 65 64 . (set! changed
62a0: 2d 63 6f 75 6e 74 20 28 2b 20 63 68 61 6e 67 65 -count (+ change
62b0: 64 2d 63 6f 75 6e 74 20 31 29 29 29 0a 09 09 09 d-count 1)))....
62c0: 09 09 63 6f 6e 6e 0a 09 09 09 09 09 28 73 3a 73 ..conn......(s:s
62d0: 71 6c 70 61 72 61 6d 20 64 65 6c 2d 71 75 65 72 qlparam del-quer
62e0: 79 20 73 65 73 73 69 6f 6e 2d 69 64 20 70 61 67 y session-id pag
62f0: 65 20 6b 65 79 29 29 29 0a 09 09 20 20 20 20 20 e key)))...
6300: 3b 3b 20 62 65 66 6f 72 65 2d 76 61 6c 75 65 20 ;; before-value
6310: 64 6f 65 73 6e 27 74 20 65 78 69 73 74 20 2d 20 doesn't exist -
6320: 69 6e 73 65 72 74 20 61 20 6e 65 77 20 76 61 6c insert a new val
6330: 75 65 0a 09 09 20 20 20 20 20 28 28 6e 6f 74 20 ue... ((not
6340: 62 65 66 6f 72 65 2d 76 61 6c 75 65 29 0a 09 09 before-value)...
6350: 20 20 20 20 20 20 28 64 62 69 3a 66 6f 72 2d 65 (dbi:for-e
6360: 61 63 68 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 ach-row (lambda
6370: 28 74 75 70 6c 65 29 0a 09 09 09 09 09 20 20 28 (tuple)...... (
6380: 73 65 74 21 20 63 68 61 6e 67 65 64 2d 63 6f 75 set! changed-cou
6390: 6e 74 20 28 2b 20 63 68 61 6e 67 65 64 2d 63 6f nt (+ changed-co
63a0: 75 6e 74 20 31 29 29 29 0a 09 09 09 09 09 63 6f unt 1)))......co
63b0: 6e 6e 0a 09 09 09 09 09 28 73 3a 73 71 6c 70 61 nn......(s:sqlpa
63c0: 72 61 6d 20 69 6e 73 2d 71 75 65 72 79 20 73 65 ram ins-query se
63d0: 73 73 69 6f 6e 2d 69 64 20 70 61 67 65 20 6b 65 ssion-id page ke
63e0: 79 20 6d 61 73 74 65 72 2d 76 61 6c 75 65 29 29 y master-value))
63f0: 29 0a 09 09 20 20 20 20 20 28 65 6c 73 65 20 28 )... (else (
6400: 65 72 72 3a 6c 6f 67 20 22 53 68 6f 75 6c 64 6e err:log "Shouldn
6410: 27 74 20 67 65 74 20 68 65 72 65 22 29 29 29 29 't get here"))))
6420: 29 0a 09 09 61 6c 6c 2d 6b 65 79 73 29 29 29 20 )...all-keys)))
6430: 3b 3b 20 70 72 6f 63 65 73 73 20 61 6c 6c 20 6b ;; process all k
6440: 65 79 73 0a 09 20 20 20 28 6c 69 73 74 20 22 2a eys.. (list "*
6450: 73 65 73 73 69 6f 6e 76 61 72 73 2a 22 20 22 2a sessionvars*" "*
6460: 67 6c 6f 62 61 6c 76 61 72 73 2a 22 20 70 61 67 globalvars*" pag
6470: 65 2d 6e 61 6d 65 29 29 29 29 29 29 0a 0a 3b 3b e-name))))))..;;
6480: 20 28 70 67 3a 73 71 6c 2d 6e 75 6c 6c 2d 6f 62 (pg:sql-null-ob
6490: 6a 65 63 74 3f 20 65 6c 65 6d 65 6e 74 29 0a 28 ject? element).(
64a0: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
64b0: 72 65 61 64 2d 63 6f 6e 66 69 67 20 73 65 6c 66 read-config self
64c0: 29 0a 20 20 28 6c 65 74 2a 20 28 28 63 67 69 2d ). (let* ((cgi-
64d0: 70 61 74 68 20 28 70 61 74 68 6e 61 6d 65 2d 64 path (pathname-d
64e0: 69 72 65 63 74 6f 72 79 20 28 63 61 72 20 28 61 irectory (car (a
64f0: 72 67 76 29 29 29 29 0a 20 20 20 20 20 20 20 20 rgv)))).
6500: 20 28 6e 61 6d 65 20 20 20 20 20 28 73 74 72 69 (name (stri
6510: 6e 67 2d 61 70 70 65 6e 64 20 28 69 66 20 63 67 ng-append (if cg
6520: 69 2d 70 61 74 68 20 28 63 6f 6e 63 20 63 67 69 i-path (conc cgi
6530: 2d 70 61 74 68 20 22 2f 22 29 20 22 22 29 20 22 -path "/") "") "
6540: 2e 22 20 28 70 61 74 68 6e 61 6d 65 2d 66 69 6c ." (pathname-fil
6550: 65 20 28 63 61 72 20 28 61 72 67 76 29 29 29 20 e (car (argv)))
6560: 22 2e 63 6f 6e 66 69 67 22 29 29 29 0a 20 20 20 ".config"))).
6570: 20 28 69 66 20 28 6e 6f 74 20 28 66 69 6c 65 2d (if (not (file-
6580: 65 78 69 73 74 73 3f 20 6e 61 6d 65 29 29 0a 09 exists? name))..
6590: 28 70 72 69 6e 74 20 6e 61 6d 65 20 22 20 6e 6f (print name " no
65a0: 74 20 66 6f 75 6e 64 20 61 74 20 22 20 28 63 75 t found at " (cu
65b0: 72 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 79 29 rrent-directory)
65c0: 29 0a 09 28 6c 65 74 2a 20 28 28 66 70 20 28 6f )..(let* ((fp (o
65d0: 70 65 6e 2d 69 6e 70 75 74 2d 66 69 6c 65 20 6e pen-input-file n
65e0: 61 6d 65 29 29 0a 09 20 20 20 20 20 20 20 28 69 ame)).. (i
65f0: 6e 69 74 61 72 67 73 20 28 72 65 61 64 20 66 70 nitargs (read fp
6600: 29 29 29 0a 09 20 20 28 63 6c 6f 73 65 2d 69 6e ))).. (close-in
6610: 70 75 74 2d 70 6f 72 74 20 66 70 29 0a 09 20 20 put-port fp)..
6620: 69 6e 69 74 61 72 67 73 29 29 29 29 0a 0a 3b 3b initargs))))..;;
6630: 20 63 61 6c 6c 20 74 68 65 20 63 6f 6e 74 72 6f call the contro
6640: 6c 6c 65 72 20 69 66 20 69 74 20 65 78 69 73 74 ller if it exist
6650: 73 0a 3b 3b 20 0a 3b 3b 20 57 41 52 4e 49 4e 47 s.;; .;; WARNING
6660: 20 2d 20 74 68 69 73 20 63 6f 64 65 20 6e 65 65 - this code nee
6670: 64 73 20 61 20 64 65 66 65 6e 63 65 20 61 67 61 ds a defence aga
6680: 69 6e 73 20 72 65 63 75 72 73 69 76 65 20 63 61 ins recursive ca
6690: 6c 6c 69 6e 67 21 21 21 21 21 0a 3b 3b 0a 3b 3b lling!!!!!.;;.;;
66a0: 20 20 20 49 20 73 75 67 67 65 73 74 20 61 20 6c I suggest a l
66b0: 69 6d 69 74 20 6f 66 20 31 30 30 20 63 61 6c 6c imit of 100 call
66c0: 73 2e 20 50 6c 65 6e 74 79 20 66 6f 72 20 61 6c s. Plenty for al
66d0: 6c 6f 77 69 6e 67 20 6d 75 6c 74 69 70 6c 65 20 lowing multiple
66e0: 69 6e 73 74 61 6e 63 65 73 0a 3b 3b 20 20 20 6f instances.;; o
66f0: 66 20 61 20 70 61 67 65 20 69 6e 73 69 64 65 20 f a page inside
6700: 61 6e 6f 74 68 65 72 20 70 61 67 65 2e 20 0a 3b another page. .;
6710: 3b 0a 3b 3b 20 70 61 72 74 73 20 3d 20 27 62 6f ;.;; parts = 'bo
6720: 74 68 20 7c 20 27 63 6f 6e 74 72 6f 6c 20 7c 20 th | 'control |
6730: 27 76 69 65 77 0a 3b 3b 0a 0a 28 64 65 66 69 6e 'view.;;..(defin
6740: 65 20 28 66 69 6c 65 73 2d 72 65 61 64 2d 3e 73 e (files-read->s
6750: 74 72 69 6e 67 20 2e 20 66 69 6c 65 73 29 0a 20 tring . files).
6760: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
6770: 65 72 73 65 20 0a 20 20 20 28 61 70 70 6c 79 20 erse . (apply
6780: 61 70 70 65 6e 64 20 28 6d 61 70 20 66 69 6c 65 append (map file
6790: 2d 72 65 61 64 2d 3e 73 74 72 69 6e 67 20 66 69 -read->string fi
67a0: 6c 65 73 29 29 20 22 5c 6e 22 29 29 0a 0a 28 64 les)) "\n"))..(d
67b0: 65 66 69 6e 65 20 28 66 69 6c 65 2d 72 65 61 64 efine (file-read
67c0: 2d 3e 73 74 72 69 6e 67 20 66 29 20 0a 20 20 28 ->string f) . (
67d0: 6c 65 74 20 28 28 70 20 28 6f 70 65 6e 2d 69 6e let ((p (open-in
67e0: 70 75 74 2d 66 69 6c 65 20 66 29 29 29 0a 20 20 put-file f))).
67f0: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 (let loop ((he
6800: 64 20 28 72 65 61 64 2d 6c 69 6e 65 20 70 29 29 d (read-line p))
6810: 0a 09 20 20 20 20 20 20 20 28 72 65 73 20 27 28 .. (res '(
6820: 29 29 29 0a 20 20 20 20 20 20 28 69 66 20 28 65 ))). (if (e
6830: 6f 66 2d 6f 62 6a 65 63 74 3f 20 68 65 64 29 0a of-object? hed).
6840: 09 20 20 72 65 73 0a 09 20 20 28 6c 6f 6f 70 20 . res.. (loop
6850: 28 72 65 61 64 2d 6c 69 6e 65 20 70 29 28 61 70 (read-line p)(ap
6860: 70 65 6e 64 20 72 65 73 20 28 6c 69 73 74 20 68 pend res (list h
6870: 65 64 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 ed)))))))..(defi
6880: 6e 65 20 28 70 72 6f 63 65 73 73 2d 70 6f 72 74 ne (process-port
6890: 20 70 29 0a 20 20 28 6c 65 74 20 28 28 65 20 28 p). (let ((e (
68a0: 69 6e 74 65 72 61 63 74 69 6f 6e 2d 65 6e 76 69 interaction-envi
68b0: 72 6f 6e 6d 65 6e 74 29 29 29 0a 20 20 20 20 28 ronment))). (
68c0: 6d 61 70 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 map . (lambd
68d0: 61 20 28 78 29 0a 20 20 20 20 20 20 20 28 63 6f a (x). (co
68e0: 6e 64 0a 09 28 28 6c 69 73 74 3f 20 78 29 20 78 nd..((list? x) x
68f0: 29 0a 09 28 28 73 74 72 69 6e 67 3f 20 78 29 20 )..((string? x)
6900: 78 29 0a 09 28 65 6c 73 65 20 27 28 29 29 29 29 x)..(else '())))
6910: 0a 20 20 20 20 20 28 70 6f 72 74 2d 6d 61 70 20 . (port-map
6920: 28 6c 61 6d 62 64 61 20 28 73 29 0a 09 09 20 28 (lambda (s)... (
6930: 65 76 61 6c 20 73 20 65 29 29 0a 09 20 20 20 20 eval s e))..
6940: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 28 72 65 (lambda ()(re
6950: 61 64 20 70 29 29 29 29 29 29 0a 0a 28 64 65 66 ad p))))))..(def
6960: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 70 72 6f ine (session:pro
6970: 63 65 73 73 2d 66 69 6c 65 20 66 29 0a 20 20 28 cess-file f). (
6980: 6c 65 74 2a 20 28 28 70 20 20 20 20 28 6f 70 65 let* ((p (ope
6990: 6e 2d 69 6e 70 75 74 2d 66 69 6c 65 20 66 29 29 n-input-file f))
69a0: 0a 09 20 28 64 61 74 20 20 28 70 72 6f 63 65 73 .. (dat (proces
69b0: 73 2d 70 6f 72 74 20 70 29 29 29 0a 20 20 20 20 s-port p))).
69c0: 28 63 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 6f 72 (close-input-por
69d0: 74 20 70 29 0a 20 20 20 20 64 61 74 29 29 0a 0a t p). dat))..
69e0: 3b 3b 20 4d 61 79 20 32 30 31 31 2c 20 70 75 74 ;; May 2011, put
69f0: 74 69 6e 67 20 61 6c 6c 20 70 61 67 65 73 20 69 ting all pages i
6a00: 6e 74 6f 20 6f 6e 65 20 64 69 72 65 63 74 6f 72 nto one director
6a10: 79 20 66 6f 72 20 74 68 65 20 66 6f 6c 6c 6f 77 y for the follow
6a20: 69 6e 67 20 72 65 61 73 6f 6e 73 3a 0a 3b 3b 20 ing reasons:.;;
6a30: 20 20 31 2e 20 77 61 6e 74 20 66 69 6c 65 6e 61 1. want filena
6a40: 6d 65 20 74 6f 20 72 65 66 6c 65 63 74 20 70 61 me to reflect pa
6a50: 67 65 20 6e 61 6d 65 20 28 65 6d 61 63 73 20 6c ge name (emacs l
6a60: 69 6d 69 74 61 74 69 6f 6e 29 0a 3b 3b 20 20 20 imitation).;;
6a70: 32 2e 20 74 68 61 74 27 73 20 69 74 21 20 6e 6f 2. that's it! no
6a80: 20 6f 74 68 65 72 20 72 65 61 73 6f 6e 2e 20 63 other reason. c
6a90: 6f 75 6c 64 20 6d 61 6b 65 20 69 74 20 63 6f 6e ould make it con
6aa0: 66 69 67 75 72 61 62 6c 65 20 2e 2e 2e 0a 3b 3b figurable ....;;
6ab0: 20 70 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 20 page-dir-style
6ac0: 69 73 3a 0a 3b 3b 20 20 27 73 74 6f 72 65 64 20 is:.;; 'stored
6ad0: 20 20 3d 3e 20 73 74 6f 72 65 64 20 69 6e 20 65 => stored in e
6ae0: 78 65 63 75 74 61 62 6c 65 0a 3b 3b 20 20 27 66 xecutable.;; 'f
6af0: 6c 61 74 20 20 20 20 20 3d 3e 20 70 61 67 65 73 lat => pages
6b00: 20 66 6c 61 74 20 64 69 72 65 63 74 6f 72 79 0a flat directory.
6b10: 3b 3b 20 20 27 64 69 72 20 20 20 20 20 20 3d 3e ;; 'dir =>
6b20: 20 64 69 72 65 63 74 6f 72 79 20 74 72 65 65 20 directory tree
6b30: 70 61 67 65 73 2f 3c 70 61 67 65 6e 61 6d 65 3e pages/<pagename>
6b40: 2f 7b 76 69 65 77 2c 63 6f 6e 74 72 6f 6c 7d 2e /{view,control}.
6b50: 73 63 6d 0a 3b 3b 20 70 61 72 74 73 3a 0a 3b 3b scm.;; parts:.;;
6b60: 20 20 27 62 6f 74 68 20 20 20 20 20 3d 3e 20 6c 'both => l
6b70: 6f 61 64 20 63 6f 6e 74 72 6f 6c 20 61 6e 64 20 oad control and
6b80: 76 69 65 77 20 28 61 6e 79 74 68 69 6e 67 20 6f view (anything o
6b90: 74 68 65 72 20 74 68 61 6e 20 76 69 65 77 20 6f ther than view o
6ba0: 72 20 63 6f 6e 74 72 6f 6c 20 61 6e 64 20 74 68 r control and th
6bb0: 65 20 64 65 66 61 75 6c 74 29 0a 3b 3b 20 20 27 e default).;; '
6bc0: 76 69 65 77 20 20 20 20 20 3d 3e 20 6c 6f 61 64 view => load
6bd0: 20 76 69 65 77 20 6f 6e 6c 79 0a 3b 3b 20 20 27 view only.;; '
6be0: 63 6f 6e 74 72 6f 6c 20 20 3d 3e 20 6c 6f 61 64 control => load
6bf0: 20 63 6f 6e 74 72 6f 6c 20 6f 6e 6c 79 0a 28 64 control only.(d
6c00: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 63 efine (session:c
6c10: 61 6c 6c 2d 70 61 72 74 73 20 73 65 6c 66 20 70 all-parts self p
6c20: 61 67 65 20 23 21 6b 65 79 20 28 70 61 72 74 73 age #!key (parts
6c30: 20 27 62 6f 74 68 29 29 0a 20 20 28 73 64 61 74 'both)). (sdat
6c40: 2d 73 65 74 2d 63 75 72 72 2d 70 61 67 65 21 20 -set-curr-page!
6c50: 73 65 6c 66 20 70 61 67 65 29 0a 20 20 28 6c 65 self page). (le
6c60: 74 2a 20 28 28 64 69 72 2d 73 74 79 6c 65 20 20 t* ((dir-style
6c70: 20 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 (sdat-get-page
6c80: 2d 64 69 72 2d 73 74 79 6c 65 20 73 65 6c 66 29 -dir-style self)
6c90: 29 3b 3b 20 28 65 71 75 61 6c 3f 20 28 73 64 61 );; (equal? (sda
6ca0: 74 2d 67 65 74 2d 70 61 67 65 2d 64 69 72 2d 73 t-get-page-dir-s
6cb0: 74 79 6c 65 20 73 65 6c 66 29 20 22 6f 6e 65 64 tyle self) "oned
6cc0: 69 72 22 29 29 20 3b 3b 20 66 6c 61 67 20 23 74 ir")) ;; flag #t
6cd0: 20 66 6f 72 20 6f 6e 65 64 69 72 2c 20 23 66 20 for onedir, #f
6ce0: 66 6f 72 20 6f 6c 64 20 73 74 79 6c 65 0a 09 20 for old style..
6cf0: 28 64 69 72 20 20 20 20 20 20 20 20 20 20 28 73 (dir (s
6d00: 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 28 73 64 tring-append (sd
6d10: 61 74 2d 67 65 74 2d 73 72 6f 6f 74 20 73 65 6c at-get-sroot sel
6d20: 66 29 20 0a 09 09 09 09 20 20 20 20 20 20 28 69 f) ..... (i
6d30: 66 20 64 69 72 2d 73 74 79 6c 65 20 0a 09 09 09 f dir-style ....
6d40: 09 09 20 20 28 63 6f 6e 63 20 22 2f 70 61 67 65 .. (conc "/page
6d50: 73 2f 22 29 0a 09 09 09 09 09 20 20 28 63 6f 6e s/")...... (con
6d60: 63 20 22 2f 70 61 67 65 73 2f 22 20 70 61 67 65 c "/pages/" page
6d70: 29 29 29 29 29 0a 20 20 20 20 28 63 61 73 65 20 ))))). (case
6d80: 64 69 72 2d 73 74 79 6c 65 0a 20 20 20 20 20 20 dir-style.
6d90: 3b 3b 20 4e 42 2f 2f 20 53 74 6f 72 65 64 20 61 ;; NB// Stored a
6da0: 6c 77 61 79 73 20 6c 6f 61 64 73 20 62 6f 74 68 lways loads both
6db0: 20 63 6f 6e 74 72 6f 6c 20 61 6e 64 20 76 69 65 control and vie
6dc0: 77 0a 20 20 20 20 20 20 28 28 73 74 6f 72 65 64 w. ((stored
6dd0: 29 0a 20 20 20 20 20 20 20 28 28 65 76 61 6c 20 ). ((eval
6de0: 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 (string->symbol
6df0: 28 63 6f 6e 63 20 22 70 61 67 65 73 3a 22 20 70 (conc "pages:" p
6e00: 61 67 65 29 29 29 20 0a 09 73 65 6c 66 20 20 20 age))) ..self
6e10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6e20: 20 20 20 20 20 20 3b 3b 20 74 68 65 20 73 65 73 ;; the ses
6e30: 73 69 6f 6e 0a 09 28 73 64 61 74 2d 67 65 74 2d sion..(sdat-get-
6e40: 63 6f 6e 6e 20 73 65 6c 66 29 20 20 20 20 20 20 conn self)
6e50: 20 20 20 3b 3b 20 74 68 65 20 64 62 20 63 6f 6e ;; the db con
6e60: 6e 65 63 74 69 6f 6e 0a 09 28 73 64 61 74 2d 67 nection..(sdat-g
6e70: 65 74 2d 73 68 61 72 65 64 2d 68 61 73 68 20 73 et-shared-hash s
6e80: 65 6c 66 29 20 20 3b 3b 20 61 20 73 68 61 72 65 elf) ;; a share
6e90: 64 20 68 61 73 68 20 74 61 62 6c 65 20 66 6f 72 d hash table for
6ea0: 20 70 61 73 73 69 6e 67 20 64 61 74 61 20 74 6f passing data to
6eb0: 2f 66 72 6f 6d 20 70 61 67 65 20 63 61 6c 6c 73 /from page calls
6ec0: 0a 09 29 29 0a 20 20 20 20 20 20 28 28 66 6c 61 ..)). ((fla
6ed0: 74 29 20 20 20 0a 20 20 20 20 20 20 20 28 6c 65 t) . (le
6ee0: 74 2a 20 28 28 73 6f 2d 66 69 6c 65 20 20 28 63 t* ((so-file (c
6ef0: 6f 6e 63 20 64 69 72 20 70 61 67 65 20 22 2e 73 onc dir page ".s
6f00: 6f 22 29 29 0a 09 20 20 20 20 20 20 28 73 63 6d o")).. (scm
6f10: 2d 66 69 6c 65 20 28 63 6f 6e 63 20 64 69 72 20 -file (conc dir
6f20: 70 61 67 65 20 22 2e 73 63 6d 22 29 29 0a 09 20 page ".scm"))..
6f30: 20 20 20 20 20 28 73 72 63 2d 66 69 6c 65 20 28 (src-file (
6f40: 6f 72 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f or (file-exists?
6f50: 20 73 6f 2d 66 69 6c 65 29 0a 09 09 09 20 20 20 so-file)....
6f60: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 73 (file-exists? s
6f70: 63 6d 2d 66 69 6c 65 29 29 29 29 0a 09 20 28 69 cm-file)))).. (i
6f80: 66 20 73 72 63 2d 66 69 6c 65 0a 09 20 20 20 20 f src-file..
6f90: 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 20 (begin..
6fa0: 28 6c 6f 61 64 20 73 72 63 2d 66 69 6c 65 29 0a (load src-file).
6fb0: 09 20 20 20 20 20 20 20 28 28 65 76 61 6c 20 28 . ((eval (
6fc0: 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 string->symbol (
6fd0: 63 6f 6e 63 20 22 70 61 67 65 73 3a 22 20 70 61 conc "pages:" pa
6fe0: 67 65 29 29 29 20 0a 09 09 73 65 6c 66 20 20 20 ge))) ...self
6ff0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7000: 20 20 20 20 20 20 3b 3b 20 74 68 65 20 73 65 73 ;; the ses
7010: 73 69 6f 6e 0a 09 09 28 73 64 61 74 2d 67 65 74 sion...(sdat-get
7020: 2d 63 6f 6e 6e 20 73 65 6c 66 29 20 20 20 20 20 -conn self)
7030: 20 20 20 20 3b 3b 20 74 68 65 20 64 62 20 63 6f ;; the db co
7040: 6e 6e 65 63 74 69 6f 6e 0a 09 09 28 73 64 61 74 nnection...(sdat
7050: 2d 67 65 74 2d 73 68 61 72 65 64 2d 68 61 73 68 -get-shared-hash
7060: 20 73 65 6c 66 29 20 20 3b 3b 20 61 20 73 68 61 self) ;; a sha
7070: 72 65 64 20 68 61 73 68 20 74 61 62 6c 65 20 66 red hash table f
7080: 6f 72 20 70 61 73 73 69 6e 67 20 64 61 74 61 20 or passing data
7090: 74 6f 2f 66 72 6f 6d 20 70 61 67 65 20 63 61 6c to/from page cal
70a0: 6c 73 0a 09 09 29 29 0a 09 20 20 20 20 20 28 6c ls...)).. (l
70b0: 69 73 74 20 22 3c 70 3e 50 61 67 65 20 6e 6f 74 ist "<p>Page not
70c0: 20 66 6f 75 6e 64 20 22 20 70 61 67 65 20 22 20 found " page "
70d0: 3c 2f 70 3e 22 29 29 29 29 0a 20 20 20 20 20 20 </p>")))).
70e0: 20 3b 3b 20 66 69 72 73 74 20 74 68 65 20 63 6f ;; first the co
70f0: 6e 74 72 6f 6c 0a 20 20 20 20 20 20 20 3b 3b 20 ntrol. ;;
7100: 28 6c 65 74 20 28 28 63 6f 6e 74 72 6f 6c 2d 66 (let ((control-f
7110: 69 6c 65 20 28 63 6f 6e 63 20 22 70 61 67 65 73 ile (conc "pages
7120: 2f 22 20 70 61 67 65 20 22 5f 63 74 72 6c 2e 73 /" page "_ctrl.s
7130: 63 6d 22 29 29 0a 20 20 20 20 20 20 20 3b 3b 20 cm")). ;;
7140: 20 20 20 20 20 20 28 76 69 65 77 2d 66 69 6c 65 (view-file
7150: 20 20 20 20 28 63 6f 6e 63 20 22 70 61 67 65 73 (conc "pages
7160: 2f 22 20 70 61 67 65 20 22 5f 76 69 65 77 2e 73 /" page "_view.s
7170: 63 6d 22 29 29 29 0a 20 20 20 20 20 20 20 3b 3b cm"))). ;;
7180: 20 20 20 28 69 66 20 28 61 6e 64 20 28 66 69 6c (if (and (fil
7190: 65 2d 65 78 69 73 74 73 3f 20 63 6f 6e 74 72 6f e-exists? contro
71a0: 6c 2d 66 69 6c 65 29 0a 20 20 20 20 20 20 20 3b l-file). ;
71b0: 3b 20 20 09 20 20 28 6e 6f 74 20 28 65 71 3f 20 ; . (not (eq?
71c0: 70 61 72 74 73 20 27 76 69 65 77 29 29 29 0a 20 parts 'view))).
71d0: 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 28 ;; (
71e0: 62 65 67 69 6e 0a 20 20 20 20 20 20 20 3b 3b 20 begin. ;;
71f0: 20 20 20 20 20 20 20 20 28 73 65 73 73 69 6f 6e (session
7200: 3a 73 65 74 2d 63 61 6c 6c 65 64 21 20 73 65 6c :set-called! sel
7210: 66 20 70 61 67 65 29 0a 20 20 20 20 20 20 20 3b f page). ;
7220: 3b 20 20 20 20 20 20 20 20 20 28 6c 6f 61 64 20 ; (load
7230: 63 6f 6e 74 72 6f 6c 2d 66 69 6c 65 29 29 29 0a control-file))).
7240: 20 20 20 20 20 20 20 3b 3b 20 20 20 28 69 66 20 ;; (if
7250: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 76 69 (file-exists? vi
7260: 65 77 2d 66 69 6c 65 29 0a 20 20 20 20 20 20 20 ew-file).
7270: 3b 3b 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f ;; (if (no
7280: 74 20 28 65 71 3f 20 70 61 72 74 73 20 27 63 6f t (eq? parts 'co
7290: 6e 74 72 6f 6c 29 29 0a 20 20 20 20 20 20 20 3b ntrol)). ;
72a0: 3b 20 20 09 20 28 73 65 73 73 69 6f 6e 3a 70 72 ; . (session:pr
72b0: 6f 63 65 73 73 2d 66 69 6c 65 20 76 69 65 77 2d ocess-file view-
72c0: 66 69 6c 65 29 29 0a 20 20 20 20 20 20 20 3b 3b file)). ;;
72d0: 20 20 20 20 20 20 20 28 6c 69 73 74 20 22 3c 70 (list "<p
72e0: 3e 50 61 67 65 20 6e 6f 74 20 66 6f 75 6e 64 20 >Page not found
72f0: 22 20 70 61 67 65 20 22 20 3c 2f 70 3e 22 29 29 " page " </p>"))
7300: 29 0a 20 20 20 20 20 20 28 28 64 69 72 29 20 22 ). ((dir) "
7310: 45 52 52 4f 52 3a 20 20 64 69 72 20 73 74 79 6c ERROR: dir styl
7320: 65 20 6e 6f 74 20 79 65 74 20 72 65 2d 69 6d 70 e not yet re-imp
7330: 6c 65 6d 65 6e 74 65 64 22 29 0a 20 20 20 20 20 lemented").
7340: 20 28 65 6c 73 65 0a 20 20 20 20 20 20 20 28 6c (else. (l
7350: 69 73 74 20 22 45 52 52 4f 52 3a 20 70 61 67 65 ist "ERROR: page
7360: 2d 64 69 72 2d 73 74 79 6c 65 20 6d 75 73 74 20 -dir-style must
7370: 62 65 20 73 74 6f 72 65 64 2c 20 64 69 72 20 6f be stored, dir o
7380: 72 20 66 6c 61 74 2c 20 67 6f 74 20 22 20 64 69 r flat, got " di
7390: 72 2d 73 74 79 6c 65 29 29 29 29 29 0a 0a 28 64 r-style)))))..(d
73a0: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 63 efine (session:c
73b0: 61 6c 6c 20 73 65 6c 66 20 70 61 67 65 20 70 61 all self page pa
73c0: 72 74 73 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a rts). (session:
73d0: 63 61 6c 6c 2d 70 61 72 74 73 20 73 65 6c 66 20 call-parts self
73e0: 70 61 67 65 20 27 62 6f 74 68 29 29 0a 0a 3b 3b page 'both))..;;
73f0: 20 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f (define (sessio
7400: 6e 3a 6c 6f 61 64 2d 6d 6f 64 65 6c 20 73 65 6c n:load-model sel
7410: 66 20 6d 6f 64 65 6c 29 0a 3b 3b 20 20 20 28 6c f model).;; (l
7420: 65 74 20 28 28 6d 6f 64 65 6c 2e 73 63 6d 20 28 et ((model.scm (
7430: 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 28 73 string-append (s
7440: 64 61 74 2d 67 65 74 2d 73 72 6f 6f 74 20 73 65 dat-get-sroot se
7450: 6c 66 29 20 22 2f 6d 6f 64 65 6c 73 2f 22 20 6d lf) "/models/" m
7460: 6f 64 65 6c 20 22 2e 73 63 6d 22 29 29 0a 3b 3b odel ".scm")).;;
7470: 20 09 28 6d 6f 64 65 6c 2e 73 6f 20 20 28 73 74 .(model.so (st
7480: 72 69 6e 67 2d 61 70 70 65 6e 64 20 28 73 64 61 ring-append (sda
7490: 74 2d 67 65 74 2d 73 72 6f 6f 74 20 73 65 6c 66 t-get-sroot self
74a0: 29 20 22 2f 6d 6f 64 65 6c 73 2f 22 20 6d 6f 64 ) "/models/" mod
74b0: 65 6c 20 22 2e 73 6f 22 29 29 29 0a 3b 3b 20 20 el ".so"))).;;
74c0: 20 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 (if (file-exi
74d0: 73 74 73 3f 20 6d 6f 64 65 6c 2e 73 6f 29 0a 3b sts? model.so).;
74e0: 3b 20 09 28 6c 6f 61 64 20 6d 6f 64 65 6c 2e 73 ; .(load model.s
74f0: 6f 29 0a 3b 3b 20 09 28 69 66 20 28 66 69 6c 65 o).;; .(if (file
7500: 2d 65 78 69 73 74 73 3f 20 6d 6f 64 65 6c 2e 73 -exists? model.s
7510: 63 6d 29 0a 3b 3b 20 09 20 20 20 20 28 6c 6f 61 cm).;; . (loa
7520: 64 20 6d 6f 64 65 6c 2e 73 63 6d 29 0a 3b 3b 20 d model.scm).;;
7530: 09 20 20 20 20 28 73 3a 6c 6f 67 20 22 45 52 52 . (s:log "ERR
7540: 4f 52 3a 20 6d 6f 64 65 6c 20 22 20 6d 6f 64 65 OR: model " mode
7550: 6c 2e 73 63 6d 20 22 20 6e 6f 74 20 66 6f 75 6e l.scm " not foun
7560: 64 22 29 29 29 29 29 0a 0a 3b 3b 20 28 64 65 66 d")))))..;; (def
7570: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 6d 6f 64 ine (session:mod
7580: 65 6c 2d 70 61 74 68 20 73 65 6c 66 20 6d 6f 64 el-path self mod
7590: 65 6c 29 0a 3b 3b 20 20 20 28 73 74 72 69 6e 67 el).;; (string
75a0: 2d 61 70 70 65 6e 64 20 28 73 64 61 74 2d 67 65 -append (sdat-ge
75b0: 74 2d 73 72 6f 6f 74 20 73 65 6c 66 29 20 22 2f t-sroot self) "/
75c0: 6d 6f 64 65 6c 73 2f 22 20 6d 6f 64 65 6c 20 22 models/" model "
75d0: 2e 73 63 6d 22 29 29 0a 0a 28 64 65 66 69 6e 65 .scm"))..(define
75e0: 20 28 73 65 73 73 69 6f 6e 3a 70 70 2d 66 6f 72 (session:pp-for
75f0: 6d 64 61 74 20 73 65 6c 66 29 0a 20 20 28 6c 65 mdat self). (le
7600: 74 20 28 28 64 61 74 20 28 66 6f 72 6d 64 61 74 t ((dat (formdat
7610: 3a 61 6c 6c 2d 3e 73 74 72 69 6e 67 73 20 28 73 :all->strings (s
7620: 64 61 74 2d 67 65 74 2d 66 6f 72 6d 64 61 74 20 dat-get-formdat
7630: 73 65 6c 66 29 29 29 29 0a 20 20 20 20 28 73 74 self)))). (st
7640: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
7650: 20 64 61 74 20 22 3c 62 72 3e 20 22 29 29 29 0a dat "<br> "))).
7660: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
7670: 6e 3a 70 61 72 61 6d 2d 3e 73 74 72 69 6e 67 20 n:param->string
7680: 70 61 72 61 6d 73 29 0a 20 20 3b 3b 20 28 65 72 params). ;; (er
7690: 72 3a 6c 6f 67 20 22 70 61 72 61 6d 73 3d 22 20 r:log "params="
76a0: 70 61 72 61 6d 73 29 0a 20 20 28 69 66 20 28 3c params). (if (<
76b0: 20 28 6c 65 6e 67 74 68 20 70 61 72 61 6d 73 29 (length params)
76c0: 20 31 29 0a 20 20 20 20 20 20 22 22 0a 20 20 20 1). "".
76d0: 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 6b (let loop ((k
76e0: 65 79 20 28 63 61 72 20 70 61 72 61 6d 73 29 29 ey (car params))
76f0: 0a 09 09 20 28 76 61 6c 20 28 63 61 64 72 20 70 ... (val (cadr p
7700: 61 72 61 6d 73 29 29 0a 09 09 20 28 74 61 69 6c arams))... (tail
7710: 20 28 63 64 64 72 20 70 61 72 61 6d 73 29 29 0a (cddr params)).
7720: 09 09 20 28 72 65 73 75 6c 74 20 27 28 29 29 29 .. (result '()))
7730: 0a 09 28 6c 65 74 20 28 28 6e 65 77 72 65 73 75 ..(let ((newresu
7740: 6c 74 20 28 63 6f 6e 73 20 28 73 74 72 69 6e 67 lt (cons (string
7750: 2d 61 70 70 65 6e 64 20 28 73 3a 61 6e 79 2d 3e -append (s:any->
7760: 73 74 72 69 6e 67 20 6b 65 79 29 20 22 3d 22 20 string key) "="
7770: 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 76 (s:any->string v
7780: 61 6c 29 29 0a 09 09 09 20 20 20 20 20 20 20 72 al)).... r
7790: 65 73 75 6c 74 29 29 29 0a 09 20 20 28 69 66 20 esult))).. (if
77a0: 28 3c 20 28 6c 65 6e 67 74 68 20 74 61 69 6c 29 (< (length tail)
77b0: 20 31 29 20 3b 3b 20 74 72 75 65 20 69 66 20 64 1) ;; true if d
77c0: 6f 6e 65 0a 09 20 20 20 20 20 20 28 73 74 72 69 one.. (stri
77d0: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 6e ng-intersperse n
77e0: 65 77 72 65 73 75 6c 74 20 22 26 22 29 0a 09 20 ewresult "&")..
77f0: 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 (loop (car
7800: 74 61 69 6c 29 28 63 61 64 72 20 74 61 69 6c 29 tail)(cadr tail)
7810: 28 63 64 64 72 20 74 61 69 6c 29 20 6e 65 77 72 (cddr tail) newr
7820: 65 73 75 6c 74 29 29 29 29 29 29 0a 0a 28 64 65 esult))))))..(de
7830: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 6c 69 fine (session:li
7840: 6e 6b 2d 74 6f 20 73 65 6c 66 20 70 61 67 65 20 nk-to self page
7850: 70 61 72 61 6d 73 29 0a 20 20 28 6c 65 74 2a 20 params). (let*
7860: 28 28 68 74 74 70 73 2d 68 6f 73 74 20 20 20 28 ((https-host (
7870: 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d get-environment-
7880: 76 61 72 69 61 62 6c 65 20 22 48 54 54 50 53 5f variable "HTTPS_
7890: 48 4f 53 54 22 29 29 0a 20 20 20 20 20 20 20 20 HOST")).
78a0: 20 28 66 6f 72 63 65 2d 73 73 6c 20 20 20 20 28 (force-ssl (
78b0: 73 64 61 74 2d 67 65 74 2d 66 6f 72 63 65 2d 73 sdat-get-force-s
78c0: 73 6c 20 73 65 6c 66 29 29 0a 09 20 28 73 65 72 sl self)).. (ser
78d0: 76 65 72 20 20 20 20 20 20 20 28 6f 72 20 68 74 ver (or ht
78e0: 74 70 73 2d 68 6f 73 74 20 3b 3b 20 41 73 73 75 tps-host ;; Assu
78f0: 6d 69 6e 67 20 48 54 54 50 53 5f 48 4f 53 54 20 ming HTTPS_HOST
7900: 69 73 20 6f 6e 6c 79 20 73 65 74 20 69 66 20 61 is only set if a
7910: 76 61 69 6c 61 62 6c 65 0a 09 09 09 20 20 20 28 vailable.... (
7920: 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d get-environment-
7930: 76 61 72 69 61 62 6c 65 20 22 48 54 54 50 5f 48 variable "HTTP_H
7940: 4f 53 54 22 29 0a 09 09 09 20 20 20 28 67 65 74 OST").... (get
7950: 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 -environment-var
7960: 69 61 62 6c 65 20 22 53 45 52 56 45 52 5f 4e 41 iable "SERVER_NA
7970: 4d 45 22 29 0a 09 09 09 20 20 20 28 73 64 61 74 ME").... (sdat
7980: 2d 67 65 74 2d 64 6f 6d 61 69 6e 20 73 65 6c 66 -get-domain self
7990: 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 66 6f ))). (fo
79a0: 72 63 65 2d 73 63 72 69 70 74 20 20 28 73 64 61 rce-script (sda
79b0: 74 2d 67 65 74 2d 73 63 72 69 70 74 20 73 65 6c t-get-script sel
79c0: 66 29 29 0a 09 20 28 73 63 72 69 70 74 20 20 20 f)).. (script
79d0: 20 20 20 20 20 28 6f 72 20 66 6f 72 63 65 2d 73 (or force-s
79e0: 63 72 69 70 74 0a 09 09 09 20 20 20 20 28 6c 65 cript.... (le
79f0: 74 20 28 28 73 63 72 69 70 74 2d 6e 61 6d 65 20 t ((script-name
7a00: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 28 67 (string-split (g
7a10: 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 et-environment-v
7a20: 61 72 69 61 62 6c 65 20 22 53 43 52 49 50 54 5f ariable "SCRIPT_
7a30: 4e 41 4d 45 22 29 20 22 2f 22 29 29 29 0a 09 09 NAME") "/")))...
7a40: 09 20 20 20 20 20 20 28 69 66 20 28 3e 20 28 6c . (if (> (l
7a50: 65 6e 67 74 68 20 73 63 72 69 70 74 2d 6e 61 6d ength script-nam
7a60: 65 29 20 31 29 0a 09 09 09 09 20 20 28 73 74 72 e) 1)..... (str
7a70: 69 6e 67 2d 61 70 70 65 6e 64 20 28 63 61 72 20 ing-append (car
7a80: 73 63 72 69 70 74 2d 6e 61 6d 65 29 20 22 2f 22 script-name) "/"
7a90: 20 28 63 61 64 72 20 73 63 72 69 70 74 2d 6e 61 (cadr script-na
7aa0: 6d 65 29 29 0a 09 09 09 09 20 20 28 67 65 74 2d me))..... (get-
7ab0: 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 environment-vari
7ac0: 61 62 6c 65 20 22 53 43 52 49 50 54 5f 4e 41 4d able "SCRIPT_NAM
7ad0: 45 22 29 29 29 29 29 20 3b 3b 20 62 75 69 6c 64 E"))))) ;; build
7ae0: 20 73 63 72 69 70 74 20 6e 61 6d 65 20 66 72 6f script name fro
7af0: 6d 20 66 69 72 73 74 20 74 77 6f 20 65 6c 65 6d m first two elem
7b00: 65 6e 74 73 2e 20 54 68 69 73 20 69 73 20 61 20 ents. This is a
7b10: 68 61 6e 67 6f 76 65 72 20 66 72 6f 6d 20 62 65 hangover from be
7b20: 66 6f 72 65 20 49 20 75 73 65 64 20 3f 20 69 6e fore I used ? in
7b30: 20 74 68 65 20 55 52 4c 2e 29 0a 20 20 20 20 20 the URL.).
7b40: 20 20 20 20 28 73 65 73 73 69 6f 6e 2d 6b 65 79 (session-key
7b50: 20 20 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 (sdat-get-ses
7b60: 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 29 0a sion-key self)).
7b70: 09 20 28 70 61 72 61 6d 73 74 72 20 20 20 20 20 . (paramstr
7b80: 20 28 73 65 73 73 69 6f 6e 3a 70 61 72 61 6d 2d (session:param-
7b90: 3e 73 74 72 69 6e 67 20 70 61 72 61 6d 73 29 29 >string params))
7ba0: 29 0a 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 6c ). (session:l
7bb0: 6f 67 20 73 65 6c 66 20 22 73 65 72 76 65 72 3d og self "server=
7bc0: 22 20 73 65 72 76 65 72 20 22 20 73 63 72 69 70 " server " scrip
7bd0: 74 3d 22 20 73 63 72 69 70 74 20 22 20 70 61 67 t=" script " pag
7be0: 65 3d 22 20 70 61 67 65 29 0a 20 20 20 20 28 73 e=" page). (s
7bf0: 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 28 69 66 tring-append (if
7c00: 20 28 6f 72 20 68 74 74 70 73 2d 68 6f 73 74 20 (or https-host
7c10: 66 6f 72 63 65 2d 73 73 6c 29 0a 09 09 20 20 20 force-ssl)...
7c20: 20 20 20 22 68 74 74 70 73 3a 2f 2f 22 0a 09 09 "https://"...
7c30: 20 20 20 20 20 20 22 68 74 74 70 3a 2f 2f 22 29 "http://")
7c40: 0a 09 09 20 20 20 73 65 72 76 65 72 20 22 2f 22 ... server "/"
7c50: 20 73 63 72 69 70 74 20 22 2f 22 20 70 61 67 65 script "/" page
7c60: 20 22 3f 22 20 70 61 72 61 6d 73 74 72 29 29 29 "?" paramstr)))
7c70: 20 3b 3b 20 22 2f 73 6e 3d 22 20 73 65 73 73 69 ;; "/sn=" sessi
7c80: 6f 6e 2d 6b 65 79 29 29 29 0a 0a 28 64 65 66 69 on-key)))..(defi
7c90: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 63 67 69 2d ne (session:cgi-
7ca0: 6f 75 74 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 out self). (let
7cb0: 2a 20 28 28 63 6f 6e 74 65 6e 74 20 20 28 6c 69 * ((content (li
7cc0: 73 74 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e st (sdat-get-con
7cd0: 74 65 6e 74 2d 74 79 70 65 20 73 65 6c 66 29 29 tent-type self))
7ce0: 29 20 3b 3b 20 27 28 22 43 6f 6e 74 65 6e 74 2d ) ;; '("Content-
7cf0: 74 79 70 65 3a 20 74 65 78 74 2f 68 74 6d 6c 3b type: text/html;
7d00: 20 63 68 61 72 73 65 74 3d 69 73 6f 2d 38 38 35 charset=iso-885
7d10: 39 2d 31 5c 6e 5c 6e 22 29 29 0a 09 20 28 68 65 9-1\n\n")).. (he
7d20: 61 64 65 72 20 20 20 28 6c 65 74 20 28 28 63 6f ader (let ((co
7d30: 6f 6b 69 65 20 28 73 64 61 74 2d 67 65 74 2d 73 okie (sdat-get-s
7d40: 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 20 73 65 ession-cookie se
7d50: 6c 66 29 29 29 0a 09 09 20 20 20 20 20 28 69 66 lf)))... (if
7d60: 20 63 6f 6f 6b 69 65 0a 09 09 09 20 28 63 6f 6e cookie.... (con
7d70: 73 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 s (string-append
7d80: 20 22 53 65 74 2d 43 6f 6f 6b 69 65 3a 20 22 20 "Set-Cookie: "
7d90: 28 63 61 72 20 63 6f 6f 6b 69 65 29 29 0a 09 09 (car cookie))...
7da0: 09 20 20 20 20 20 20 20 63 6f 6e 74 65 6e 74 29 . content)
7db0: 0a 09 09 09 20 63 6f 6e 74 65 6e 74 29 29 29 0a .... content))).
7dc0: 09 20 28 70 61 67 65 64 61 74 20 20 28 73 64 61 . (pagedat (sda
7dd0: 74 2d 67 65 74 2d 70 61 67 65 64 61 74 20 73 65 t-get-pagedat se
7de0: 6c 66 29 29 29 0a 20 20 20 20 28 73 3a 63 67 69 lf))). (s:cgi
7df0: 2d 6f 75 74 20 0a 20 20 20 20 20 28 63 6f 6e 73 -out . (cons
7e00: 20 68 65 61 64 65 72 20 70 61 67 65 64 61 74 29 header pagedat)
7e10: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 )))..(define (se
7e20: 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 2e ssion:log self .
7e30: 20 6d 73 67 29 0a 20 20 28 77 69 74 68 2d 6f 75 msg). (with-ou
7e40: 74 70 75 74 2d 74 6f 2d 70 6f 72 74 20 28 73 64 tput-to-port (sd
7e50: 61 74 2d 67 65 74 2d 6c 6f 67 2d 70 6f 72 74 20 at-get-log-port
7e60: 73 65 6c 66 29 20 3b 3b 20 28 73 64 61 74 2d 67 self) ;; (sdat-g
7e70: 65 74 2d 6c 6f 67 70 74 20 73 65 6c 66 29 0a 20 et-logpt self).
7e80: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 20 0a 20 (lambda () .
7e90: 20 20 20 20 20 28 61 70 70 6c 79 20 70 72 69 6e (apply prin
7ea0: 74 20 6d 73 67 29 29 29 29 0a 0a 3b 3b 20 65 73 t msg))))..;; es
7eb0: 63 61 70 65 2c 20 63 6f 6e 76 65 72 74 20 6f 72 cape, convert or
7ec0: 20 72 65 74 75 72 6e 20 72 61 77 20 77 68 65 6e return raw when
7ed0: 20 67 69 76 65 6e 20 75 73 65 72 20 69 6e 70 75 given user inpu
7ee0: 74 20 64 61 74 61 20 74 68 61 74 20 70 6f 74 65 t data that pote
7ef0: 6e 74 69 61 6c 6c 79 0a 3b 3b 20 63 6f 75 6c 64 ntially.;; could
7f00: 20 62 65 20 6d 61 6c 69 63 69 6f 75 73 0a 3b 3b be malicious.;;
7f10: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
7f20: 6e 3a 61 70 70 6c 79 2d 74 79 70 65 2d 70 72 65 n:apply-type-pre
7f30: 66 65 72 65 6e 63 65 20 72 65 73 20 70 61 72 61 ference res para
7f40: 6d 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 74 ms). (let* ((dt
7f50: 79 70 65 20 20 20 20 28 69 66 20 28 6e 75 6c 6c ype (if (null
7f60: 3f 20 70 61 72 61 6d 73 29 0a 09 09 20 20 20 20 ? params)...
7f70: 20 20 20 27 65 73 63 61 70 65 64 0a 09 09 20 20 'escaped...
7f80: 20 20 20 20 20 28 63 61 72 20 70 61 72 61 6d 73 (car params
7f90: 29 29 29 0a 09 20 28 74 61 67 73 20 20 20 20 28 ))).. (tags (
7fa0: 69 66 20 28 6e 75 6c 6c 3f 20 70 61 72 61 6d 73 if (null? params
7fb0: 29 0a 09 09 20 20 20 20 20 20 27 28 29 0a 09 09 )... '()...
7fc0: 20 20 20 20 20 20 28 63 64 72 20 70 61 72 61 6d (cdr param
7fd0: 73 29 29 29 29 0a 20 20 20 20 28 63 61 73 65 20 s)))). (case
7fe0: 64 74 79 70 65 0a 20 20 20 20 20 20 28 28 72 61 dtype. ((ra
7ff0: 77 29 20 20 20 20 20 72 65 73 29 0a 20 20 20 20 w) res).
8000: 20 20 28 28 6e 75 6d 62 65 72 29 20 20 28 69 66 ((number) (if
8010: 20 28 73 74 72 69 6e 67 3f 20 72 65 73 29 28 73 (string? res)(s
8020: 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 72 65 tring->number re
8030: 73 29 20 23 66 29 29 0a 20 20 20 20 20 20 28 28 s) #f)). ((
8040: 65 73 63 61 70 65 64 29 20 28 69 66 20 28 73 74 escaped) (if (st
8050: 72 69 6e 67 3f 20 72 65 73 29 0a 09 09 20 20 20 ring? res)...
8060: 20 20 28 73 3a 68 74 6d 6c 2d 66 69 6c 74 65 72 (s:html-filter
8070: 2d 3e 73 74 72 69 6e 67 20 72 65 73 20 74 61 67 ->string res tag
8080: 73 29 0a 09 09 20 20 20 20 20 72 65 73 29 29 0a s)... res)).
8090: 20 20 20 20 20 20 28 28 65 73 63 61 70 65 64 2d ((escaped-
80a0: 6e 6c 29 20 28 69 66 20 28 73 74 72 69 6e 67 3f nl) (if (string?
80b0: 20 72 65 73 29 20 3b 3b 20 65 73 63 61 70 65 20 res) ;; escape
80c0: 5c 6e 20 61 6e 64 20 5c 72 0a 09 09 09 28 73 74 \n and \r....(st
80d0: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
80e0: 0a 09 09 09 20 28 73 74 72 69 6e 67 2d 73 70 6c .... (string-spl
80f0: 69 74 0a 09 09 09 20 20 28 73 74 72 69 6e 67 2d it.... (string-
8100: 69 6e 74 65 72 73 70 65 72 73 65 0a 09 09 09 20 intersperse....
8110: 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 (string-split
8120: 28 73 3a 68 74 6d 6c 2d 66 69 6c 74 65 72 2d 3e (s:html-filter->
8130: 73 74 72 69 6e 67 20 72 65 73 20 74 61 67 73 29 string res tags)
8140: 20 22 5c 6e 22 29 0a 09 09 09 20 20 20 22 5c 5c "\n").... "\\
8150: 6e 22 29 0a 09 09 09 20 20 22 5c 72 22 29 0a 09 n").... "\r")..
8160: 09 09 20 22 5c 5c 72 22 29 0a 09 09 09 72 65 73 .. "\\r")....res
8170: 29 29 20 3b 3b 20 73 68 6f 75 6c 64 20 72 65 74 )) ;; should ret
8180: 75 72 6e 20 23 66 20 69 66 20 6e 6f 74 20 61 20 urn #f if not a
8190: 73 74 72 69 6e 67 20 61 6e 64 20 63 61 6e 27 74 string and can't
81a0: 20 65 73 63 61 70 65 20 69 74 3f 0a 20 20 20 20 escape it?.
81b0: 20 20 28 65 6c 73 65 20 20 20 20 20 20 28 69 66 (else (if
81c0: 20 28 73 74 72 69 6e 67 3f 20 72 65 73 29 0a 09 (string? res)..
81d0: 09 20 20 20 20 20 28 73 3a 68 74 6d 6c 2d 66 69 . (s:html-fi
81e0: 6c 74 65 72 2d 3e 73 74 72 69 6e 67 20 72 65 73 lter->string res
81f0: 20 27 28 29 29 0a 09 09 20 20 20 20 20 72 65 73 '())... res
8200: 29 29 29 29 29 0a 0a 23 3b 28 64 65 66 69 6e 65 )))))..#;(define
8210: 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 (session:get-pa
8220: 72 61 6d 2d 66 72 6f 6d 20 70 61 72 61 6d 73 20 ram-from params
8230: 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 28 72 31 key). (let ((r1
8240: 20 28 72 65 67 65 78 70 20 28 63 6f 6e 63 20 22 (regexp (conc "
8250: 5e 22 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e ^" (s:any->strin
8260: 67 20 6b 65 79 29 20 22 3d 28 2e 2a 29 24 22 29 g key) "=(.*)$")
8270: 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 75 6c ))). (if (nul
8280: 6c 3f 20 70 61 72 61 6d 73 29 20 23 66 0a 20 20 l? params) #f.
8290: 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 (let loop
82a0: 28 28 68 65 61 64 20 28 63 61 72 20 70 61 72 61 ((head (car para
82b0: 6d 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 ms)).
82c0: 20 20 20 20 20 20 20 20 28 74 61 69 6c 20 28 63 (tail (c
82d0: 64 72 20 70 61 72 61 6d 73 29 29 29 0a 20 20 20 dr params))).
82e0: 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 6d 61 (let ((ma
82f0: 74 63 68 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 tch (string-matc
8300: 68 20 72 31 20 68 65 61 64 29 29 29 0a 20 20 20 h r1 head))).
8310: 20 20 20 20 20 20 20 20 20 28 69 66 20 6d 61 74 (if mat
8320: 63 68 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ch.
8330: 20 20 20 28 6c 69 73 74 2d 72 65 66 20 6d 61 74 (list-ref mat
8340: 63 68 20 31 29 0a 20 20 20 20 20 20 20 20 20 20 ch 1).
8350: 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f (if (null?
8360: 20 74 61 69 6c 29 20 23 66 0a 20 20 20 20 20 20 tail) #f.
8370: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
8380: 6f 6f 70 20 28 63 61 72 20 74 61 69 6c 29 28 63 oop (car tail)(c
8390: 64 72 20 74 61 69 6c 29 29 29 29 29 29 29 29 29 dr tail)))))))))
83a0: 0a 0a 3b 3b 20 70 61 72 61 6d 73 20 61 72 65 20 ..;; params are
83b0: 73 74 6f 72 65 64 20 61 73 20 6c 69 73 74 20 6f stored as list o
83c0: 66 20 6b 65 79 3d 76 61 6c 0a 3b 3b 0a 28 64 65 f key=val.;;.(de
83d0: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 fine (session:ge
83e0: 74 2d 70 61 72 61 6d 20 73 65 6c 66 20 6b 65 79 t-param self key
83f0: 20 74 79 70 65 2d 70 61 72 61 6d 73 29 0a 20 20 type-params).
8400: 3b 3b 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 ;; (session:log
8410: 73 3a 73 65 73 73 69 6f 6e 20 22 70 61 72 61 6d s:session "param
8420: 73 3d 22 20 28 73 6c 6f 74 2d 72 65 66 20 73 3a s=" (slot-ref s:
8430: 73 65 73 73 69 6f 6e 20 27 70 61 72 61 6d 73 29 session 'params)
8440: 29 0a 20 20 28 6c 65 74 2a 20 28 28 70 61 72 61 ). (let* ((para
8450: 6d 73 20 28 73 64 61 74 2d 67 65 74 2d 70 61 72 ms (sdat-get-par
8460: 61 6d 73 20 73 65 6c 66 29 29 0a 09 20 28 72 65 ams self)).. (re
8470: 73 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 67 65 s (session:ge
8480: 74 2d 70 61 72 61 6d 2d 66 72 6f 6d 20 70 61 72 t-param-from par
8490: 61 6d 73 20 6b 65 79 29 29 29 0a 20 20 20 20 28 ams key))). (
84a0: 73 65 73 73 69 6f 6e 3a 61 70 70 6c 79 2d 74 79 session:apply-ty
84b0: 70 65 2d 70 72 65 66 65 72 65 6e 63 65 20 72 65 pe-preference re
84c0: 73 20 74 79 70 65 2d 70 61 72 61 6d 73 29 29 29 s type-params)))
84d0: 0a 0a 3b 3b 20 54 68 69 73 20 6f 6e 65 20 77 69 ..;; This one wi
84e0: 6c 6c 20 67 65 74 20 74 68 65 20 66 69 72 73 74 ll get the first
84f0: 20 76 61 6c 75 65 20 66 6f 75 6e 64 20 72 65 67 value found reg
8500: 61 72 64 6c 65 73 73 20 6f 66 20 66 6f 72 6d 0a ardless of form.
8510: 3b 3b 20 70 61 72 61 6d 3a 20 28 64 74 79 70 65 ;; param: (dtype
8520: 20 5b 74 61 67 31 20 74 61 67 32 20 2e 2e 2e 5d [tag1 tag2 ...]
8530: 29 0a 3b 3b 20 64 74 79 70 65 3a 0a 3b 3b 20 20 ).;; dtype:.;;
8540: 20 20 27 72 61 77 20 20 20 20 20 3a 20 64 6f 20 'raw : do
8550: 6e 6f 20 63 6f 6e 76 65 72 73 69 6f 6e 0a 3b 3b no conversion.;;
8560: 20 20 20 20 27 6e 75 6d 62 65 72 20 20 3a 20 63 'number : c
8570: 6f 6e 76 65 72 74 20 74 6f 20 6e 75 6d 62 65 72 onvert to number
8580: 2c 20 72 65 74 75 72 6e 20 23 66 20 69 66 20 66 , return #f if f
8590: 61 69 6c 73 0a 3b 3b 20 20 20 20 27 65 73 63 61 ails.;; 'esca
85a0: 70 65 64 20 3a 20 75 73 65 20 68 74 6d 6c 2d 65 ped : use html-e
85b0: 73 63 61 70 65 20 74 6f 20 70 72 6f 74 65 63 74 scape to protect
85c0: 20 74 68 65 20 69 6e 70 75 74 20 2d 2d 20 74 68 the input -- th
85d0: 69 73 20 69 73 20 74 68 65 20 64 65 66 61 75 6c is is the defaul
85e0: 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 t.;;.(define (se
85f0: 73 73 69 6f 6e 3a 67 65 74 2d 69 6e 70 75 74 20 ssion:get-input
8600: 73 65 6c 66 20 6b 65 79 20 70 61 72 61 6d 73 29 self key params)
8610: 0a 20 20 28 6c 65 74 2a 20 28 28 64 74 79 70 65 . (let* ((dtype
8620: 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 70 (if (null? p
8630: 61 72 61 6d 73 29 0a 09 09 20 20 20 20 20 20 20 arams)...
8640: 27 65 73 63 61 70 65 64 0a 09 09 20 20 20 20 20 'escaped...
8650: 20 20 28 63 61 72 20 70 61 72 61 6d 73 29 29 29 (car params)))
8660: 0a 09 20 28 74 61 67 73 20 20 20 20 28 69 66 20 .. (tags (if
8670: 28 6e 75 6c 6c 3f 20 70 61 72 61 6d 73 29 0a 09 (null? params)..
8680: 09 20 20 20 20 20 20 27 28 29 0a 09 09 20 20 20 . '()...
8690: 20 20 20 28 63 64 72 20 70 61 72 61 6d 73 29 29 (cdr params))
86a0: 29 0a 09 20 28 66 6f 72 6d 64 61 74 20 28 73 64 ).. (formdat (sd
86b0: 61 74 2d 67 65 74 2d 66 6f 72 6d 64 61 74 20 73 at-get-formdat s
86c0: 65 6c 66 29 29 0a 09 20 28 72 65 73 20 20 20 20 elf)).. (res
86d0: 20 28 69 66 20 28 6e 6f 74 20 66 6f 72 6d 64 61 (if (not formda
86e0: 74 29 20 23 66 0a 09 09 20 20 20 20 20 20 28 69 t) #f... (i
86f0: 66 20 28 6f 72 20 28 73 74 72 69 6e 67 3f 20 6b f (or (string? k
8700: 65 79 29 28 6e 75 6d 62 65 72 3f 20 6b 65 79 29 ey)(number? key)
8710: 28 73 79 6d 62 6f 6c 3f 20 6b 65 79 29 29 0a 09 (symbol? key))..
8720: 09 09 20 20 28 69 66 20 28 61 6e 64 20 28 76 65 .. (if (and (ve
8730: 63 74 6f 72 3f 20 66 6f 72 6d 64 61 74 29 28 65 ctor? formdat)(e
8740: 71 3f 20 28 76 65 63 74 6f 72 2d 6c 65 6e 67 74 q? (vector-lengt
8750: 68 20 66 6f 72 6d 64 61 74 29 20 31 29 28 68 61 h formdat) 1)(ha
8760: 73 68 2d 74 61 62 6c 65 3f 20 28 76 65 63 74 6f sh-table? (vecto
8770: 72 2d 72 65 66 20 66 6f 72 6d 64 61 74 20 30 29 r-ref formdat 0)
8780: 29 29 0a 09 09 09 20 20 20 20 20 20 28 66 6f 72 )).... (for
8790: 6d 64 61 74 3a 67 65 74 20 66 6f 72 6d 64 61 74 mdat:get formdat
87a0: 20 6b 65 79 29 0a 09 09 09 20 20 20 20 20 20 28 key).... (
87b0: 62 65 67 69 6e 0a 09 09 09 09 28 73 65 73 73 69 begin.....(sessi
87c0: 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 45 52 52 on:log self "ERR
87d0: 4f 52 3a 20 66 6f 72 6d 64 61 74 3a 20 22 20 66 OR: formdat: " f
87e0: 6f 72 6d 64 61 74 20 22 20 69 73 20 6e 6f 74 20 ormdat " is not
87f0: 6f 66 20 63 6c 61 73 73 20 3c 66 6f 72 6d 64 61 of class <formda
8800: 74 3e 22 29 0a 09 09 09 09 23 66 29 29 0a 09 09 t>").....#f))...
8810: 09 20 20 28 62 65 67 69 6e 0a 09 09 09 20 20 20 . (begin....
8820: 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 (session:log se
8830: 6c 66 20 22 45 52 52 4f 52 3a 20 62 61 64 20 6b lf "ERROR: bad k
8840: 65 79 20 22 20 6b 65 79 29 0a 09 09 09 20 20 20 ey " key)....
8850: 20 23 66 29 29 29 29 29 0a 20 20 20 20 28 63 61 #f))))). (ca
8860: 73 65 20 64 74 79 70 65 0a 20 20 20 20 20 20 28 se dtype. (
8870: 28 72 61 77 29 20 20 20 20 20 72 65 73 29 0a 20 (raw) res).
8880: 20 20 20 20 20 28 28 6e 75 6d 62 65 72 29 20 20 ((number)
8890: 28 69 66 20 28 73 74 72 69 6e 67 3f 20 72 65 73 (if (string? res
88a0: 29 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 )(string->number
88b0: 20 72 65 73 29 20 23 66 29 29 0a 20 20 20 20 20 res) #f)).
88c0: 20 28 28 65 73 63 61 70 65 64 29 20 28 69 66 20 ((escaped) (if
88d0: 28 73 74 72 69 6e 67 3f 20 72 65 73 29 0a 09 09 (string? res)...
88e0: 20 20 20 20 20 28 73 3a 68 74 6d 6c 2d 66 69 6c (s:html-fil
88f0: 74 65 72 2d 3e 73 74 72 69 6e 67 20 72 65 73 20 ter->string res
8900: 74 61 67 73 29 0a 09 09 20 20 20 20 20 72 65 73 tags)... res
8910: 29 29 0a 20 20 20 20 20 20 28 65 6c 73 65 20 20 )). (else
8920: 20 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 3f (if (string?
8930: 20 72 65 73 29 0a 09 09 20 20 20 20 20 28 73 3a res)... (s:
8940: 68 74 6d 6c 2d 66 69 6c 74 65 72 2d 3e 73 74 72 html-filter->str
8950: 69 6e 67 20 72 65 73 20 27 28 29 29 0a 09 09 20 ing res '())...
8960: 20 20 20 20 72 65 73 29 29 29 29 29 0a 0a 3b 3b res)))))..;;
8970: 20 54 68 69 73 20 6f 6e 65 20 77 69 6c 6c 20 67 This one will g
8980: 65 74 20 74 68 65 20 66 69 72 73 74 20 76 61 6c et the first val
8990: 75 65 20 66 6f 75 6e 64 20 72 65 67 61 72 64 6c ue found regardl
89a0: 65 73 73 20 6f 66 20 66 6f 72 6d 0a 28 64 65 66 ess of form.(def
89b0: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 ine (session:get
89c0: 2d 69 6e 70 75 74 2d 6b 65 79 73 20 73 65 6c 66 -input-keys self
89d0: 29 0a 20 20 28 6c 65 74 2a 20 28 28 66 6f 72 6d ). (let* ((form
89e0: 64 61 74 20 28 73 64 61 74 2d 67 65 74 2d 66 6f dat (sdat-get-fo
89f0: 72 6d 64 61 74 20 73 65 6c 66 29 29 29 0a 20 20 rmdat self))).
8a00: 20 20 28 69 66 20 28 6e 6f 74 20 66 6f 72 6d 64 (if (not formd
8a10: 61 74 29 20 23 66 0a 09 28 69 66 20 28 61 6e 64 at) #f..(if (and
8a20: 20 28 76 65 63 74 6f 72 3f 20 66 6f 72 6d 64 61 (vector? formda
8a30: 74 29 28 65 71 3f 20 28 76 65 63 74 6f 72 2d 6c t)(eq? (vector-l
8a40: 65 6e 67 74 68 20 66 6f 72 6d 64 61 74 29 20 31 ength formdat) 1
8a50: 29 28 68 61 73 68 2d 74 61 62 6c 65 3f 20 28 76 )(hash-table? (v
8a60: 65 63 74 6f 72 2d 72 65 66 20 66 6f 72 6d 64 61 ector-ref formda
8a70: 74 20 30 29 29 29 0a 09 20 20 20 20 28 66 6f 72 t 0))).. (for
8a80: 6d 64 61 74 3a 6b 65 79 73 20 66 6f 72 6d 64 61 mdat:keys formda
8a90: 74 29 0a 09 20 20 20 20 28 62 65 67 69 6e 0a 09 t).. (begin..
8aa0: 20 20 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 6c (session:l
8ab0: 6f 67 20 73 65 6c 66 20 22 45 52 52 4f 52 3a 20 og self "ERROR:
8ac0: 66 6f 72 6d 64 61 74 3a 20 22 20 66 6f 72 6d 64 formdat: " formd
8ad0: 61 74 20 22 20 69 73 20 6e 6f 74 20 6f 66 20 63 at " is not of c
8ae0: 6c 61 73 73 20 3c 66 6f 72 6d 64 61 74 3e 22 29 lass <formdat>")
8af0: 0a 09 20 20 20 20 20 20 23 66 29 29 29 29 29 0a .. #f))))).
8b00: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
8b10: 6e 3a 72 75 6e 2d 61 63 74 69 6f 6e 73 20 73 65 n:run-actions se
8b20: 6c 66 29 0a 20 20 28 6c 65 74 2a 20 28 28 61 63 lf). (let* ((ac
8b30: 74 69 6f 6e 20 20 20 20 28 73 65 73 73 69 6f 6e tion (session
8b40: 3a 67 65 74 2d 70 61 72 61 6d 20 73 65 6c 66 20 :get-param self
8b50: 27 61 63 74 69 6f 6e 20 27 28 72 61 77 29 29 29 'action '(raw)))
8b60: 0a 09 20 28 70 61 67 65 20 20 20 20 20 20 28 73 .. (page (s
8b70: 64 61 74 2d 67 65 74 2d 70 61 67 65 20 73 65 6c dat-get-page sel
8b80: 66 29 29 29 0a 20 20 20 20 3b 3b 20 28 70 72 69 f))). ;; (pri
8b90: 6e 74 20 22 61 63 74 69 6f 6e 3d 22 20 61 63 74 nt "action=" act
8ba0: 69 6f 6e 20 22 20 70 61 67 65 3d 22 20 70 61 67 ion " page=" pag
8bb0: 65 29 0a 20 20 20 20 28 69 66 20 61 63 74 69 6f e). (if actio
8bc0: 6e 0a 09 28 6c 65 74 20 28 28 61 63 74 69 6f 6e n..(let ((action
8bd0: 2d 6c 73 74 20 20 28 73 74 72 69 6e 67 2d 73 70 -lst (string-sp
8be0: 6c 69 74 20 61 63 74 69 6f 6e 20 22 2e 22 29 29 lit action "."))
8bf0: 29 0a 09 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 ).. ;; (print "
8c00: 61 63 74 69 6f 6e 2d 6c 73 74 3d 22 20 61 63 74 action-lst=" act
8c10: 69 6f 6e 2d 6c 73 74 29 0a 09 20 20 28 69 66 20 ion-lst).. (if
8c20: 28 6e 6f 74 20 28 3d 20 28 6c 65 6e 67 74 68 20 (not (= (length
8c30: 61 63 74 69 6f 6e 2d 6c 73 74 29 20 32 29 29 20 action-lst) 2))
8c40: 0a 09 20 20 20 20 20 20 28 65 72 72 3a 6c 6f 67 .. (err:log
8c50: 20 22 41 63 74 69 6f 6e 20 73 68 6f 75 6c 64 20 "Action should
8c60: 62 65 20 6f 66 20 66 6f 72 6d 3a 20 6d 6f 64 75 be of form: modu
8c70: 6c 65 2e 61 63 74 69 6f 6e 22 29 0a 09 20 20 20 le.action")..
8c80: 20 20 20 28 6c 65 74 2a 20 28 28 74 61 72 67 2d (let* ((targ-
8c90: 70 61 67 65 20 20 20 28 63 61 72 20 61 63 74 69 page (car acti
8ca0: 6f 6e 2d 6c 73 74 29 29 0a 09 09 20 20 20 20 20 on-lst))...
8cb0: 28 70 72 6f 63 2d 6e 61 6d 65 20 20 20 28 73 74 (proc-name (st
8cc0: 72 69 6e 67 2d 61 70 70 65 6e 64 20 74 61 72 67 ring-append targ
8cd0: 2d 70 61 67 65 20 22 2d 61 63 74 69 6f 6e 22 29 -page "-action")
8ce0: 29 0a 09 09 20 20 20 20 20 28 74 61 72 67 2d 61 )... (targ-a
8cf0: 63 74 69 6f 6e 20 28 63 61 64 72 20 61 63 74 69 ction (cadr acti
8d00: 6f 6e 2d 6c 73 74 29 29 29 0a 09 09 3b 3b 20 28 on-lst)))...;; (
8d10: 65 72 72 3a 6c 6f 67 20 22 74 61 72 67 2d 70 61 err:log "targ-pa
8d20: 67 65 3d 22 20 74 61 72 67 2d 70 61 67 65 20 22 ge=" targ-page "
8d30: 20 70 72 6f 63 2d 6e 61 6d 65 3d 22 20 70 72 6f proc-name=" pro
8d40: 63 2d 6e 61 6d 65 20 22 20 74 61 72 67 2d 61 63 c-name " targ-ac
8d50: 74 69 6f 6e 3d 22 20 74 61 72 67 2d 61 63 74 69 tion=" targ-acti
8d60: 6f 6e 29 0a 0a 09 09 3b 3b 20 63 61 6c 6c 20 68 on)....;; call h
8d70: 65 72 65 20 6f 6e 6c 79 20 69 66 20 6e 65 76 65 ere only if neve
8d80: 72 20 63 61 6c 6c 65 64 20 62 65 66 6f 72 65 0a r called before.
8d90: 09 09 28 69 66 20 28 73 65 73 73 69 6f 6e 3a 6e ..(if (session:n
8da0: 65 76 65 72 2d 63 61 6c 6c 65 64 2d 70 61 67 65 ever-called-page
8db0: 3f 20 73 65 6c 66 20 74 61 72 67 2d 70 61 67 65 ? self targ-page
8dc0: 29 0a 09 09 20 20 20 20 28 73 65 73 73 69 6f 6e )... (session
8dd0: 3a 63 61 6c 6c 2d 70 61 72 74 73 20 73 65 6c 66 :call-parts self
8de0: 20 74 61 72 67 2d 70 61 67 65 20 27 63 6f 6e 74 targ-page 'cont
8df0: 72 6f 6c 29 29 0a 09 09 3b 3b 20 20 20 20 20 20 rol))...;;
8e00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 70 72 pr
8e10: 6f 63 20 20 20 20 20 20 20 20 20 20 20 20 20 20 oc
8e20: 20 20 20 20 20 20 20 20 20 20 20 61 63 74 69 6f actio
8e30: 6e 20 20 20 20 0a 0a 09 09 28 69 66 20 23 74 20 n ....(if #t
8e40: 3b 3b 20 73 65 74 20 74 6f 20 23 74 20 74 6f 20 ;; set to #t to
8e50: 73 65 65 20 62 65 74 74 65 72 20 65 72 72 6f 72 see better error
8e60: 20 6d 65 73 73 61 67 65 73 20 64 75 72 69 6e 67 messages during
8e70: 20 64 65 62 75 67 67 69 6e 20 3a 2d 29 0a 09 09 debuggin :-)...
8e80: 20 20 20 20 28 28 65 76 61 6c 20 28 73 74 72 69 ((eval (stri
8e90: 6e 67 2d 3e 73 79 6d 62 6f 6c 20 70 72 6f 63 2d ng->symbol proc-
8ea0: 6e 61 6d 65 29 29 20 74 61 72 67 2d 61 63 74 69 name)) targ-acti
8eb0: 6f 6e 29 20 3b 3b 20 75 6e 73 61 66 65 20 65 78 on) ;; unsafe ex
8ec0: 65 63 75 74 69 6f 6e 0a 09 09 20 20 20 20 28 63 ecution... (c
8ed0: 6f 6e 64 69 74 69 6f 6e 2d 63 61 73 65 20 28 28 ondition-case ((
8ee0: 65 76 61 6c 20 28 73 74 72 69 6e 67 2d 3e 73 79 eval (string->sy
8ef0: 6d 62 6f 6c 20 70 72 6f 63 2d 6e 61 6d 65 29 29 mbol proc-name))
8f00: 20 74 61 72 67 2d 61 63 74 69 6f 6e 29 0a 09 09 targ-action)...
8f10: 09 09 20 20 20 20 28 28 65 78 6e 20 66 69 6c 65 .. ((exn file
8f20: 29 20 28 73 3a 6c 6f 67 20 22 66 69 6c 65 20 65 ) (s:log "file e
8f30: 72 72 6f 72 22 29 29 0a 09 09 09 09 20 20 20 20 rror")).....
8f40: 28 28 65 78 6e 20 69 2f 6f 29 20 20 28 73 3a 6c ((exn i/o) (s:l
8f50: 6f 67 20 22 69 2f 6f 20 65 72 72 6f 72 22 29 29 og "i/o error"))
8f60: 0a 09 09 09 09 20 20 20 20 28 28 65 78 6e 20 29 ..... ((exn )
8f70: 20 20 20 20 20 28 73 3a 6c 6f 67 20 22 41 63 74 (s:log "Act
8f80: 69 6f 6e 20 6e 6f 74 20 69 6d 70 6c 65 6d 65 6e ion not implemen
8f90: 74 65 64 3a 20 22 20 70 72 6f 63 2d 6e 61 6d 65 ted: " proc-name
8fa0: 20 22 20 61 63 74 69 6f 6e 3a 20 22 20 74 61 72 " action: " tar
8fb0: 67 2d 61 63 74 69 6f 6e 29 29 0a 09 09 09 09 20 g-action)).....
8fc0: 20 20 20 28 76 61 72 20 28 29 20 20 20 20 20 28 (var () (
8fd0: 73 3a 6c 6f 67 20 22 55 6e 6b 6e 6f 77 6e 20 45 s:log "Unknown E
8fe0: 72 72 6f 72 22 29 29 29 29 29 29 29 29 29 29 0a rror")))))))))).
8ff0: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
9000: 6e 3a 6e 65 76 65 72 2d 63 61 6c 6c 65 64 2d 70 n:never-called-p
9010: 61 67 65 3f 20 73 65 6c 66 20 70 61 67 65 29 0a age? self page).
9020: 20 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 (session:log s
9030: 65 6c 66 20 22 43 68 65 63 6b 69 6e 67 20 66 6f elf "Checking fo
9040: 72 20 70 61 67 65 3a 20 22 20 70 61 67 65 29 0a r page: " page).
9050: 20 20 28 6e 6f 74 20 28 6d 65 6d 62 65 72 20 70 (not (member p
9060: 61 67 65 20 28 73 64 61 74 2d 67 65 74 2d 73 65 age (sdat-get-se
9070: 65 6e 2d 70 61 67 65 73 20 73 65 6c 66 29 29 29 en-pages self)))
9080: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 )..(define (sess
9090: 69 6f 6e 3a 73 65 74 2d 63 61 6c 6c 65 64 21 20 ion:set-called!
90a0: 73 65 6c 66 20 70 61 67 65 29 0a 20 20 28 73 64 self page). (sd
90b0: 61 74 2d 73 65 74 2d 73 65 65 6e 2d 70 61 67 65 at-set-seen-page
90c0: 73 21 20 73 65 6c 66 20 28 63 6f 6e 73 20 70 61 s! self (cons pa
90d0: 67 65 20 28 73 64 61 74 2d 67 65 74 2d 73 65 65 ge (sdat-get-see
90e0: 6e 2d 70 61 67 65 73 20 73 65 6c 66 29 29 29 29 n-pages self))))
90f0: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
9100: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9110: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9120: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9130: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 41 6c ==========.;; Al
9140: 74 65 72 6e 61 74 69 76 65 20 64 61 74 61 20 74 ternative data t
9150: 79 70 65 20 64 65 6c 69 76 65 72 79 0a 3b 3b 3d ype delivery.;;=
9160: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9170: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9180: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9190: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
91a0: 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 =====..(define (
91b0: 73 65 73 73 69 6f 6e 3a 61 6c 74 2d 6f 75 74 20 session:alt-out
91c0: 73 65 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 64 self). (let ((d
91d0: 61 74 20 28 73 64 61 74 2d 67 65 74 2d 61 6c 74 at (sdat-get-alt
91e0: 2d 70 61 67 65 2d 64 61 74 20 73 65 6c 66 29 29 -page-dat self))
91f0: 29 0a 20 20 20 20 3b 3b 20 28 73 3a 6c 6f 67 20 ). ;; (s:log
9200: 22 64 61 74 20 69 73 3a 20 22 20 64 61 74 29 0a "dat is: " dat).
9210: 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 48 ;; (print "H
9220: 54 54 50 2f 31 2e 31 20 32 30 30 20 4f 4b 22 29 TTP/1.1 200 OK")
9230: 0a 20 20 20 20 28 70 72 69 6e 74 20 22 44 61 74 . (print "Dat
9240: 65 3a 20 22 20 28 74 69 6d 65 2d 3e 73 74 72 69 e: " (time->stri
9250: 6e 67 20 28 73 65 63 6f 6e 64 73 2d 3e 75 74 63 ng (seconds->utc
9260: 2d 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 -time (current-s
9270: 65 63 6f 6e 64 73 29 29 29 29 0a 20 20 20 20 28 econds)))). (
9280: 70 72 69 6e 74 20 22 43 6f 6e 74 65 6e 74 2d 54 print "Content-T
9290: 79 70 65 3a 20 22 20 28 73 64 61 74 2d 67 65 74 ype: " (sdat-get
92a0: 2d 63 6f 6e 74 65 6e 74 2d 74 79 70 65 20 73 65 -content-type se
92b0: 6c 66 29 29 0a 20 20 20 20 28 70 72 69 6e 74 20 lf)). (print
92c0: 22 41 63 63 65 70 74 2d 52 61 6e 67 65 73 3a 20 "Accept-Ranges:
92d0: 62 79 74 65 73 22 29 0a 20 20 20 20 28 70 72 69 bytes"). (pri
92e0: 6e 74 20 22 43 6f 6e 74 65 6e 74 2d 4c 65 6e 67 nt "Content-Leng
92f0: 74 68 3a 20 22 20 28 69 66 20 28 62 6c 6f 62 3f th: " (if (blob?
9300: 20 64 61 74 29 0a 09 09 09 09 20 20 28 62 6c 6f dat)..... (blo
9310: 62 2d 73 69 7a 65 20 64 61 74 29 0a 09 09 09 09 b-size dat).....
9320: 20 20 30 29 29 0a 20 20 20 20 28 70 72 69 6e 74 0)). (print
9330: 20 22 4b 65 65 70 2d 41 6c 69 76 65 3a 20 74 69 "Keep-Alive: ti
9340: 6d 65 6f 75 74 3d 31 35 2c 20 6d 61 78 3d 31 30 meout=15, max=10
9350: 30 22 29 0a 20 20 20 20 28 70 72 69 6e 74 20 22 0"). (print "
9360: 43 6f 6e 6e 65 63 74 69 6f 6e 3a 20 4b 65 65 70 Connection: Keep
9370: 2d 41 6c 69 76 65 22 29 0a 20 20 20 20 28 70 72 -Alive"). (pr
9380: 69 6e 74 20 22 22 29 0a 20 20 20 20 28 77 72 69 int ""). (wri
9390: 74 65 2d 73 74 72 69 6e 67 20 28 62 6c 6f 62 2d te-string (blob-
93a0: 3e 73 74 72 69 6e 67 20 64 61 74 29 20 23 66 20 >string dat) #f
93b0: 28 63 75 72 72 65 6e 74 2d 6f 75 74 70 75 74 2d (current-output-
93c0: 70 6f 72 74 29 29 29 29 0a 0a 3b 3b 20 77 61 73 port))))..;; was
93d0: 20 69 6e 20 73 65 74 75 70 0a 3b 3b 0a 28 64 65 in setup.;;.(de
93e0: 66 69 6e 65 20 28 73 3a 6c 6f 67 20 2e 20 6d 73 fine (s:log . ms
93f0: 67 29 0a 20 20 28 61 70 70 6c 79 20 73 65 73 73 g). (apply sess
9400: 69 6f 6e 3a 6c 6f 67 20 73 3a 73 65 73 73 69 6f ion:log s:sessio
9410: 6e 20 6d 73 67 29 29 0a 0a 29 0a n msg))..).