Artifact
b7ff27d8a3fe7f30b0bd626955c8e095dd593c88:
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 28 64 65 63 6c 61 PURPOSE...(decla
0150: 72 65 20 28 75 6e 69 74 20 73 65 73 73 69 6f 6e re (unit session
0160: 29 29 0a 28 72 65 71 75 69 72 65 2d 6c 69 62 72 )).(require-libr
0170: 61 72 79 20 64 62 69 29 0a 28 72 65 71 75 69 72 ary dbi).(requir
0180: 65 2d 65 78 74 65 6e 73 69 6f 6e 20 72 65 67 65 e-extension rege
0190: 78 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 x).(declare (use
01a0: 73 20 63 6f 6f 6b 69 65 29 29 0a 0a 3b 3b 20 73 s cookie))..;; s
01b0: 65 73 73 69 6f 6e 73 20 74 61 62 6c 65 0a 3b 3b essions table.;;
01c0: 20 69 64 20 73 65 73 73 69 6f 6e 5f 69 64 20 73 id session_id s
01d0: 65 73 73 69 6f 6e 5f 6b 65 79 0a 3b 3b 20 63 72 ession_key.;; cr
01e0: 65 61 74 65 20 74 61 62 6c 65 20 73 65 73 73 69 eate table sessi
01f0: 6f 6e 73 20 28 69 64 20 73 65 72 69 61 6c 20 6e ons (id serial n
0200: 6f 74 20 6e 75 6c 6c 2c 73 65 73 73 69 6f 6e 2d ot null,session-
0210: 6b 65 79 20 74 65 78 74 29 3b 0a 0a 3b 3b 20 73 key text);..;; s
0220: 65 73 73 69 6f 6e 5f 76 61 72 73 20 74 61 62 6c ession_vars tabl
0230: 65 0a 3b 3b 20 69 64 20 73 65 73 73 69 6f 6e 5f e.;; id session_
0240: 69 64 20 70 61 67 65 5f 69 64 20 6b 65 79 20 76 id page_id key v
0250: 61 6c 75 65 0a 3b 3b 20 63 72 65 61 74 65 20 74 alue.;; create t
0260: 61 62 6c 65 20 73 65 73 73 69 6f 6e 5f 76 61 72 able session_var
0270: 73 20 28 69 64 20 73 65 72 69 61 6c 20 6e 6f 74 s (id serial not
0280: 20 6e 75 6c 6c 2c 73 65 73 73 69 6f 6e 5f 69 64 null,session_id
0290: 20 69 6e 74 65 67 65 72 2c 70 61 67 65 20 74 65 integer,page te
02a0: 78 74 2c 6b 65 79 20 74 65 78 74 2c 76 61 6c 75 xt,key text,valu
02b0: 65 20 74 65 78 74 29 3b 0a 0a 3b 3b 20 54 4f 44 e text);..;; TOD
02c0: 4f 0a 3b 3b 20 20 43 6f 6e 63 65 70 74 20 6f 66 O.;; Concept of
02d0: 20 6f 72 64 65 72 20 6e 75 6d 20 69 6e 63 72 65 order num incre
02e0: 6d 65 6e 74 65 64 20 77 69 74 68 20 65 61 63 68 mented with each
02f0: 20 70 61 67 65 20 61 63 63 65 73 73 0a 3b 3b 20 page access.;;
0300: 20 20 20 20 69 66 20 61 20 62 72 61 6e 63 68 20 if a branch
0310: 69 73 20 74 61 6b 65 6e 20 74 68 65 6e 20 61 20 is taken then a
0320: 6e 65 77 20 73 65 73 73 69 6f 6e 20 77 6f 75 6c new session woul
0330: 64 20 6e 65 65 64 20 74 6f 20 62 65 20 63 72 65 d need to be cre
0340: 61 74 65 64 0a 3b 3b 0a 0a 3b 3b 20 6d 61 6b 65 ated.;;..;; make
0350: 2d 76 65 63 74 6f 72 2d 72 65 63 6f 72 64 20 73 -vector-record s
0360: 65 73 73 69 6f 6e 20 73 65 73 73 69 6f 6e 20 64 ession session d
0370: 62 74 79 70 65 20 64 62 69 6e 69 74 20 63 6f 6e btype dbinit con
0380: 6e 20 70 61 72 61 6d 73 20 70 61 74 68 2d 70 61 n params path-pa
0390: 72 61 6d 73 20 73 65 73 73 69 6f 6e 2d 6b 65 79 rams session-key
03a0: 20 73 65 73 73 69 6f 6e 2d 69 64 20 64 6f 6d 61 session-id doma
03b0: 69 6e 20 74 6f 70 70 61 67 65 20 70 61 67 65 20 in toppage page
03c0: 63 75 72 72 2d 70 61 67 65 20 63 6f 6e 74 65 6e curr-page conten
03d0: 74 2d 74 79 70 65 20 70 61 67 65 2d 74 79 70 65 t-type page-type
03e0: 20 73 72 6f 6f 74 20 74 77 69 6b 69 64 69 72 20 sroot twikidir
03f0: 70 61 67 65 64 61 74 20 61 6c 74 2d 70 61 67 65 pagedat alt-page
0400: 2d 64 61 74 20 70 61 67 65 76 61 72 73 20 70 61 -dat pagevars pa
0410: 67 65 76 61 72 73 2d 62 65 66 6f 72 65 20 73 65 gevars-before se
0420: 73 73 69 6f 6e 76 61 72 73 20 73 65 73 73 69 6f ssionvars sessio
0430: 6e 76 61 72 73 2d 62 65 66 6f 72 65 20 67 6c 6f nvars-before glo
0440: 62 61 6c 76 61 72 73 20 67 6c 6f 62 61 6c 76 61 balvars globalva
0450: 72 73 2d 62 65 66 6f 72 65 20 6c 6f 67 70 74 20 rs-before logpt
0460: 66 6f 72 6d 64 61 74 20 72 65 71 75 65 73 74 2d formdat request-
0470: 6d 65 74 68 6f 64 20 73 65 73 73 69 6f 6e 2d 63 method session-c
0480: 6f 6f 6b 69 65 20 63 75 72 72 2d 65 72 72 20 6c ookie curr-err l
0490: 6f 67 2d 70 6f 72 74 20 6c 6f 67 66 69 6c 65 20 og-port logfile
04a0: 73 65 65 6e 2d 70 61 67 65 73 20 70 61 67 65 2d seen-pages page-
04b0: 64 69 72 2d 73 74 79 6c 65 20 64 65 62 75 67 6d dir-style debugm
04c0: 6f 64 65 0a 28 64 65 66 69 6e 65 20 28 6d 61 6b ode.(define (mak
04d0: 65 2d 73 64 61 74 29 28 6d 61 6b 65 2d 76 65 63 e-sdat)(make-vec
04e0: 74 6f 72 20 33 33 29 29 0a 28 64 65 66 69 6e 65 tor 33)).(define
04f0: 20 28 73 64 61 74 2d 67 65 74 2d 64 62 74 79 70 (sdat-get-dbtyp
0500: 65 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 e
0510: 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d vec) (vector-
0520: 72 65 66 20 20 76 65 63 20 30 29 29 0a 28 64 65 ref vec 0)).(de
0530: 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 64 fine (sdat-get-d
0540: 62 69 6e 69 74 20 20 20 20 20 20 20 20 20 20 20 binit
0550: 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 vec) (vec
0560: 74 6f 72 2d 72 65 66 20 20 76 65 63 20 31 29 29 tor-ref vec 1))
0570: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 .(define (sdat-g
0580: 65 74 2d 63 6f 6e 6e 20 20 20 20 20 20 20 20 20 et-conn
0590: 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 vec)
05a0: 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 (vector-ref vec
05b0: 20 32 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 2)).(define (sd
05c0: 61 74 2d 67 65 74 2d 70 67 63 6f 6e 6e 20 20 20 at-get-pgconn
05d0: 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 29 vec)
05e0: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
05f0: 28 76 65 63 74 6f 72 2d 72 65 66 20 76 65 63 20 (vector-ref vec
0600: 32 29 20 31 29 29 0a 28 64 65 66 69 6e 65 20 28 2) 1)).(define (
0610: 73 64 61 74 2d 67 65 74 2d 70 61 72 61 6d 73 20 sdat-get-params
0620: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 ve
0630: 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 c) (vector-re
0640: 66 20 20 76 65 63 20 33 29 29 0a 28 64 65 66 69 f vec 3)).(defi
0650: 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 70 61 74 ne (sdat-get-pat
0660: 68 2d 70 61 72 61 6d 73 20 20 20 20 20 20 20 20 h-params
0670: 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f vec) (vecto
0680: 72 2d 72 65 66 20 20 76 65 63 20 34 29 29 0a 28 r-ref vec 4)).(
0690: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 define (sdat-get
06a0: 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 20 20 20 -session-key
06b0: 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 vec) (v
06c0: 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 35 ector-ref vec 5
06d0: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
06e0: 2d 67 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 -get-session-id
06f0: 20 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 vec)
0700: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 (vector-ref v
0710: 65 63 20 36 29 29 0a 28 64 65 66 69 6e 65 20 28 ec 6)).(define (
0720: 73 64 61 74 2d 67 65 74 2d 64 6f 6d 61 69 6e 20 sdat-get-domain
0730: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 ve
0740: 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 c) (vector-re
0750: 66 20 20 76 65 63 20 37 29 29 0a 28 64 65 66 69 f vec 7)).(defi
0760: 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 74 6f 70 ne (sdat-get-top
0770: 70 61 67 65 20 20 20 20 20 20 20 20 20 20 20 20 page
0780: 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f vec) (vecto
0790: 72 2d 72 65 66 20 20 76 65 63 20 38 29 29 0a 28 r-ref vec 8)).(
07a0: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 define (sdat-get
07b0: 2d 70 61 67 65 20 20 20 20 20 20 20 20 20 20 20 -page
07c0: 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 vec) (v
07d0: 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 39 ector-ref vec 9
07e0: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
07f0: 2d 67 65 74 2d 63 75 72 72 2d 70 61 67 65 20 20 -get-curr-page
0800: 20 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 vec)
0810: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 (vector-ref v
0820: 65 63 20 31 30 29 29 0a 28 64 65 66 69 6e 65 20 ec 10)).(define
0830: 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 74 65 6e (sdat-get-conten
0840: 74 2d 74 79 70 65 20 20 20 20 20 20 20 20 20 76 t-type v
0850: 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 ec) (vector-r
0860: 65 66 20 20 76 65 63 20 31 31 29 29 0a 28 64 65 ef vec 11)).(de
0870: 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 70 fine (sdat-get-p
0880: 61 67 65 2d 74 79 70 65 20 20 20 20 20 20 20 20 age-type
0890: 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 vec) (vec
08a0: 74 6f 72 2d 72 65 66 20 20 76 65 63 20 31 32 29 tor-ref vec 12)
08b0: 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d ).(define (sdat-
08c0: 67 65 74 2d 73 72 6f 6f 74 20 20 20 20 20 20 20 get-sroot
08d0: 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 vec)
08e0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 (vector-ref ve
08f0: 63 20 31 33 29 29 0a 28 64 65 66 69 6e 65 20 28 c 13)).(define (
0900: 73 64 61 74 2d 67 65 74 2d 74 77 69 6b 69 64 69 sdat-get-twikidi
0910: 72 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 r ve
0920: 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 c) (vector-re
0930: 66 20 20 76 65 63 20 31 34 29 29 0a 28 64 65 66 f vec 14)).(def
0940: 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 70 61 ine (sdat-get-pa
0950: 67 65 64 61 74 20 20 20 20 20 20 20 20 20 20 20 gedat
0960: 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 vec) (vect
0970: 6f 72 2d 72 65 66 20 20 76 65 63 20 31 35 29 29 or-ref vec 15))
0980: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 .(define (sdat-g
0990: 65 74 2d 61 6c 74 2d 70 61 67 65 2d 64 61 74 20 et-alt-page-dat
09a0: 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 vec)
09b0: 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 (vector-ref vec
09c0: 20 31 36 29 29 0a 28 64 65 66 69 6e 65 20 28 73 16)).(define (s
09d0: 64 61 74 2d 67 65 74 2d 70 61 67 65 76 61 72 73 dat-get-pagevars
09e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 vec
09f0: 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 ) (vector-ref
0a00: 20 20 76 65 63 20 31 37 29 29 0a 28 64 65 66 69 vec 17)).(defi
0a10: 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 ne (sdat-get-pag
0a20: 65 76 61 72 73 2d 62 65 66 6f 72 65 20 20 20 20 evars-before
0a30: 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f vec) (vecto
0a40: 72 2d 72 65 66 20 20 76 65 63 20 31 38 29 29 0a r-ref vec 18)).
0a50: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 (define (sdat-ge
0a60: 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 20 20 20 t-sessionvars
0a70: 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 vec) (
0a80: 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 vector-ref vec
0a90: 31 39 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 19)).(define (sd
0aa0: 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 at-get-sessionva
0ab0: 72 73 2d 62 65 66 6f 72 65 20 20 20 76 65 63 29 rs-before vec)
0ac0: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
0ad0: 20 76 65 63 20 32 30 29 29 0a 28 64 65 66 69 6e vec 20)).(defin
0ae0: 65 20 28 73 64 61 74 2d 67 65 74 2d 67 6c 6f 62 e (sdat-get-glob
0af0: 61 6c 76 61 72 73 20 20 20 20 20 20 20 20 20 20 alvars
0b00: 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 vec) (vector
0b10: 2d 72 65 66 20 20 76 65 63 20 32 31 29 29 0a 28 -ref vec 21)).(
0b20: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 define (sdat-get
0b30: 2d 67 6c 6f 62 61 6c 76 61 72 73 2d 62 65 66 6f -globalvars-befo
0b40: 72 65 20 20 20 20 76 65 63 29 20 20 20 20 28 76 re vec) (v
0b50: 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 32 ector-ref vec 2
0b60: 32 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 2)).(define (sda
0b70: 74 2d 67 65 74 2d 6c 6f 67 70 74 20 20 20 20 20 t-get-logpt
0b80: 20 20 20 20 20 20 20 20 20 20 20 76 65 63 29 20 vec)
0b90: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 (vector-ref
0ba0: 76 65 63 20 32 33 29 29 0a 28 64 65 66 69 6e 65 vec 23)).(define
0bb0: 20 28 73 64 61 74 2d 67 65 74 2d 66 6f 72 6d 64 (sdat-get-formd
0bc0: 61 74 20 20 20 20 20 20 20 20 20 20 20 20 20 20 at
0bd0: 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d vec) (vector-
0be0: 72 65 66 20 20 76 65 63 20 32 34 29 29 0a 28 64 ref vec 24)).(d
0bf0: 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d efine (sdat-get-
0c00: 72 65 71 75 65 73 74 2d 6d 65 74 68 6f 64 20 20 request-method
0c10: 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 vec) (ve
0c20: 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 32 35 ctor-ref vec 25
0c30: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
0c40: 2d 67 65 74 2d 73 65 73 73 69 6f 6e 2d 63 6f 6f -get-session-coo
0c50: 6b 69 65 20 20 20 20 20 20 20 76 65 63 29 20 20 kie vec)
0c60: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 (vector-ref v
0c70: 65 63 20 32 36 29 29 0a 28 64 65 66 69 6e 65 20 ec 26)).(define
0c80: 28 73 64 61 74 2d 67 65 74 2d 63 75 72 72 2d 65 (sdat-get-curr-e
0c90: 72 72 20 20 20 20 20 20 20 20 20 20 20 20 20 76 rr v
0ca0: 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 ec) (vector-r
0cb0: 65 66 20 20 76 65 63 20 32 37 29 29 0a 28 64 65 ef vec 27)).(de
0cc0: 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 6c fine (sdat-get-l
0cd0: 6f 67 2d 70 6f 72 74 20 20 20 20 20 20 20 20 20 og-port
0ce0: 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 vec) (vec
0cf0: 74 6f 72 2d 72 65 66 20 20 76 65 63 20 32 38 29 tor-ref vec 28)
0d00: 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d ).(define (sdat-
0d10: 67 65 74 2d 6c 6f 67 66 69 6c 65 20 20 20 20 20 get-logfile
0d20: 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 vec)
0d30: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 (vector-ref ve
0d40: 63 20 32 39 29 29 0a 28 64 65 66 69 6e 65 20 28 c 29)).(define (
0d50: 73 64 61 74 2d 67 65 74 2d 73 65 65 6e 2d 70 61 sdat-get-seen-pa
0d60: 67 65 73 20 20 20 20 20 20 20 20 20 20 20 76 65 ges ve
0d70: 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 c) (vector-re
0d80: 66 20 20 76 65 63 20 33 30 29 29 0a 28 64 65 66 f vec 30)).(def
0d90: 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 70 61 ine (sdat-get-pa
0da0: 67 65 2d 64 69 72 2d 73 74 79 6c 65 20 20 20 20 ge-dir-style
0db0: 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 vec) (vect
0dc0: 6f 72 2d 72 65 66 20 20 76 65 63 20 33 31 29 29 or-ref vec 31))
0dd0: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 .(define (sdat-g
0de0: 65 74 2d 64 65 62 75 67 6d 6f 64 65 20 20 20 20 et-debugmode
0df0: 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 vec)
0e00: 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 (vector-ref vec
0e10: 20 33 32 29 29 0a 28 64 65 66 69 6e 65 20 28 73 32)).(define (s
0e20: 64 61 74 2d 73 65 74 2d 64 62 74 79 70 65 21 20 dat-set-dbtype!
0e30: 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 vec
0e40: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
0e50: 21 20 76 65 63 20 30 20 76 61 6c 29 29 0a 28 64 ! vec 0 val)).(d
0e60: 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d efine (sdat-set-
0e70: 64 62 69 6e 69 74 21 20 20 20 20 20 20 20 20 20 dbinit!
0e80: 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 vec val)(ve
0e90: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 31 20 ctor-set! vec 1
0ea0: 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 val)).(define (s
0eb0: 64 61 74 2d 73 65 74 2d 63 6f 6e 6e 21 20 20 20 dat-set-conn!
0ec0: 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 vec
0ed0: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
0ee0: 21 20 76 65 63 20 32 20 76 61 6c 29 29 0a 28 64 ! vec 2 val)).(d
0ef0: 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d efine (sdat-set-
0f00: 70 61 72 61 6d 73 21 20 20 20 20 20 20 20 20 20 params!
0f10: 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 vec val)(ve
0f20: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 33 20 ctor-set! vec 3
0f30: 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 val)).(define (s
0f40: 64 61 74 2d 73 65 74 2d 70 61 74 68 2d 70 61 72 dat-set-path-par
0f50: 61 6d 73 21 20 20 20 20 20 20 20 20 20 76 65 63 ams! vec
0f60: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
0f70: 21 20 76 65 63 20 34 20 76 61 6c 29 29 0a 28 64 ! vec 4 val)).(d
0f80: 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d efine (sdat-set-
0f90: 73 65 73 73 69 6f 6e 2d 6b 65 79 21 20 20 20 20 session-key!
0fa0: 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 vec val)(ve
0fb0: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 35 20 ctor-set! vec 5
0fc0: 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 val)).(define (s
0fd0: 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e 2d dat-set-session-
0fe0: 69 64 21 20 20 20 20 20 20 20 20 20 20 76 65 63 id! vec
0ff0: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
1000: 21 20 76 65 63 20 36 20 76 61 6c 29 29 0a 28 64 ! vec 6 val)).(d
1010: 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d efine (sdat-set-
1020: 64 6f 6d 61 69 6e 21 20 20 20 20 20 20 20 20 20 domain!
1030: 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 vec val)(ve
1040: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 37 20 ctor-set! vec 7
1050: 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 val)).(define (s
1060: 64 61 74 2d 73 65 74 2d 74 6f 70 70 61 67 65 21 dat-set-toppage!
1070: 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 vec
1080: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
1090: 21 20 76 65 63 20 38 20 76 61 6c 29 29 0a 28 64 ! vec 8 val)).(d
10a0: 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d efine (sdat-set-
10b0: 70 61 67 65 21 20 20 20 20 20 20 20 20 20 20 20 page!
10c0: 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 vec val)(ve
10d0: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 39 20 ctor-set! vec 9
10e0: 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 val)).(define (s
10f0: 64 61 74 2d 73 65 74 2d 63 75 72 72 2d 70 61 67 dat-set-curr-pag
1100: 65 21 20 20 20 20 20 20 20 20 20 20 20 76 65 63 e! vec
1110: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
1120: 21 20 76 65 63 20 31 30 20 76 61 6c 29 29 0a 28 ! vec 10 val)).(
1130: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 define (sdat-set
1140: 2d 63 6f 6e 74 65 6e 74 2d 74 79 70 65 21 20 20 -content-type!
1150: 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 vec val)(v
1160: 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 31 ector-set! vec 1
1170: 31 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 1 val)).(define
1180: 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 2d 74 (sdat-set-page-t
1190: 79 70 65 21 20 20 20 20 20 20 20 20 20 20 20 76 ype! v
11a0: 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 ec val)(vector-s
11b0: 65 74 21 20 76 65 63 20 31 32 20 76 61 6c 29 29 et! vec 12 val))
11c0: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 .(define (sdat-s
11d0: 65 74 2d 73 72 6f 6f 74 21 20 20 20 20 20 20 20 et-sroot!
11e0: 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 vec val)
11f0: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 (vector-set! vec
1200: 20 31 33 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 13 val)).(defin
1210: 65 20 28 73 64 61 74 2d 73 65 74 2d 74 77 69 6b e (sdat-set-twik
1220: 69 64 69 72 21 20 20 20 20 20 20 20 20 20 20 20 idir!
1230: 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 vec val)(vector
1240: 2d 73 65 74 21 20 76 65 63 20 31 34 20 76 61 6c -set! vec 14 val
1250: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
1260: 2d 73 65 74 2d 70 61 67 65 64 61 74 21 20 20 20 -set-pagedat!
1270: 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 61 vec va
1280: 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 l)(vector-set! v
1290: 65 63 20 31 35 20 76 61 6c 29 29 0a 28 64 65 66 ec 15 val)).(def
12a0: 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 61 6c ine (sdat-set-al
12b0: 74 2d 70 61 67 65 2d 64 61 74 21 20 20 20 20 20 t-page-dat!
12c0: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
12d0: 6f 72 2d 73 65 74 21 20 76 65 63 20 31 36 20 76 or-set! vec 16 v
12e0: 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 al)).(define (sd
12f0: 61 74 2d 73 65 74 2d 70 61 67 65 76 61 72 73 21 at-set-pagevars!
1300: 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 20 vec
1310: 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 val)(vector-set!
1320: 20 76 65 63 20 31 37 20 76 61 6c 29 29 0a 28 64 vec 17 val)).(d
1330: 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d efine (sdat-set-
1340: 70 61 67 65 76 61 72 73 2d 62 65 66 6f 72 65 21 pagevars-before!
1350: 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 vec val)(ve
1360: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 31 38 ctor-set! vec 18
1370: 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 val)).(define (
1380: 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e sdat-set-session
1390: 76 61 72 73 21 20 20 20 20 20 20 20 20 20 76 65 vars! ve
13a0: 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 c val)(vector-se
13b0: 74 21 20 76 65 63 20 31 39 20 76 61 6c 29 29 0a t! vec 19 val)).
13c0: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 (define (sdat-se
13d0: 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 t-sessionvars-be
13e0: 66 6f 72 65 21 20 20 76 65 63 20 76 61 6c 29 28 fore! vec val)(
13f0: 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 vector-set! vec
1400: 32 30 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 val)).(define
1410: 20 28 73 64 61 74 2d 73 65 74 2d 67 6c 6f 62 61 (sdat-set-globa
1420: 6c 76 61 72 73 21 20 20 20 20 20 20 20 20 20 20 lvars!
1430: 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d vec val)(vector-
1440: 73 65 74 21 20 76 65 63 20 32 31 20 76 61 6c 29 set! vec 21 val)
1450: 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d ).(define (sdat-
1460: 73 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 2d 62 set-globalvars-b
1470: 65 66 6f 72 65 21 20 20 20 76 65 63 20 76 61 6c efore! vec val
1480: 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 )(vector-set! ve
1490: 63 20 32 32 20 76 61 6c 29 29 0a 28 64 65 66 69 c 22 val)).(defi
14a0: 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 6c 6f 67 ne (sdat-set-log
14b0: 70 74 21 20 20 20 20 20 20 20 20 20 20 20 20 20 pt!
14c0: 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f vec val)(vecto
14d0: 72 2d 73 65 74 21 20 76 65 63 20 32 33 20 76 61 r-set! vec 23 va
14e0: 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 l)).(define (sda
14f0: 74 2d 73 65 74 2d 66 6f 72 6d 64 61 74 21 20 20 t-set-formdat!
1500: 20 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 vec v
1510: 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 al)(vector-set!
1520: 76 65 63 20 32 34 20 76 61 6c 29 29 0a 28 64 65 vec 24 val)).(de
1530: 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 72 fine (sdat-set-r
1540: 65 71 75 65 73 74 2d 6d 65 74 68 6f 64 21 20 20 equest-method!
1550: 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 vec val)(vec
1560: 74 6f 72 2d 73 65 74 21 20 76 65 63 20 32 35 20 tor-set! vec 25
1570: 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 val)).(define (s
1580: 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e 2d dat-set-session-
1590: 63 6f 6f 6b 69 65 21 20 20 20 20 20 20 76 65 63 cookie! vec
15a0: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
15b0: 21 20 76 65 63 20 32 36 20 76 61 6c 29 29 0a 28 ! vec 26 val)).(
15c0: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 define (sdat-set
15d0: 2d 63 75 72 72 2d 65 72 72 21 20 20 20 20 20 20 -curr-err!
15e0: 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 vec val)(v
15f0: 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 32 ector-set! vec 2
1600: 37 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 7 val)).(define
1610: 28 73 64 61 74 2d 73 65 74 2d 6c 6f 67 2d 70 6f (sdat-set-log-po
1620: 72 74 21 20 20 20 20 20 20 20 20 20 20 20 20 76 rt! v
1630: 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 ec val)(vector-s
1640: 65 74 21 20 76 65 63 20 32 38 20 76 61 6c 29 29 et! vec 28 val))
1650: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 .(define (sdat-s
1660: 65 74 2d 6c 6f 67 66 69 6c 65 21 20 20 20 20 20 et-logfile!
1670: 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 vec val)
1680: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 (vector-set! vec
1690: 20 32 39 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 29 val)).(defin
16a0: 65 20 28 73 64 61 74 2d 73 65 74 2d 73 65 65 6e e (sdat-set-seen
16b0: 2d 70 61 67 65 73 21 20 20 20 20 20 20 20 20 20 -pages!
16c0: 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 vec val)(vector
16d0: 2d 73 65 74 21 20 76 65 63 20 33 30 20 76 61 6c -set! vec 30 val
16e0: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
16f0: 2d 73 65 74 2d 70 61 67 65 2d 64 69 72 2d 73 74 -set-page-dir-st
1700: 79 6c 65 21 20 20 20 20 20 20 76 65 63 20 76 61 yle! vec va
1710: 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 l)(vector-set! v
1720: 65 63 20 33 31 20 76 61 6c 29 29 0a 28 64 65 66 ec 31 val)).(def
1730: 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 64 65 ine (sdat-set-de
1740: 62 75 67 6d 6f 64 65 21 20 20 20 20 20 20 20 20 bugmode!
1750: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
1760: 6f 72 2d 73 65 74 21 20 76 65 63 20 33 32 20 76 or-set! vec 32 v
1770: 61 6c 29 29 0a 0a 3b 3b 20 54 68 65 20 67 6c 6f al))..;; The glo
1780: 62 61 6c 20 73 65 73 73 69 6f 6e 0a 28 64 65 66 bal session.(def
1790: 69 6e 65 20 73 3a 73 65 73 73 69 6f 6e 20 28 6d ine s:session (m
17a0: 61 6b 65 2d 73 64 61 74 29 29 0a 0a 3b 3b 20 53 ake-sdat))..;; S
17b0: 50 4c 49 54 20 49 4e 54 4f 20 53 54 52 41 49 47 PLIT INTO STRAIG
17c0: 48 54 20 46 4f 52 57 41 52 44 20 49 4e 49 54 20 HT FORWARD INIT
17d0: 41 4e 44 20 43 4f 4d 50 4c 45 58 20 49 4e 49 54 AND COMPLEX INIT
17e0: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
17f0: 6e 3a 69 6e 69 74 69 61 6c 69 7a 65 20 73 65 6c n:initialize sel
1800: 66 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 64 f). (sdat-set-d
1810: 62 74 79 70 65 21 20 73 65 6c 66 20 20 20 20 20 btype! self
1820: 20 27 70 67 29 0a 20 20 28 73 64 61 74 2d 73 65 'pg). (sdat-se
1830: 74 2d 70 61 67 65 21 20 73 65 6c 66 20 20 20 20 t-page! self
1840: 20 20 20 20 22 68 6f 6d 65 22 29 20 20 20 20 20 "home")
1850: 20 20 20 3b 3b 20 74 68 65 73 65 20 61 72 65 20 ;; these are
1860: 64 65 66 61 75 6c 74 73 0a 20 20 28 73 64 61 74 defaults. (sdat
1870: 2d 73 65 74 2d 63 75 72 72 2d 70 61 67 65 21 20 -set-curr-page!
1880: 73 65 6c 66 20 20 20 22 68 6f 6d 65 22 29 0a 20 self "home").
1890: 20 28 73 64 61 74 2d 73 65 74 2d 63 6f 6e 74 65 (sdat-set-conte
18a0: 6e 74 2d 74 79 70 65 21 20 73 65 6c 66 20 22 43 nt-type! self "C
18b0: 6f 6e 74 65 6e 74 2d 74 79 70 65 3a 20 74 65 78 ontent-type: tex
18c0: 74 2f 68 74 6d 6c 3b 20 63 68 61 72 73 65 74 3d t/html; charset=
18d0: 69 73 6f 2d 38 38 35 39 2d 31 5c 6e 5c 6e 22 29 iso-8859-1\n\n")
18e0: 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 67 . (sdat-set-pag
18f0: 65 2d 74 79 70 65 21 20 73 65 6c 66 20 20 20 27 e-type! self '
1900: 68 74 6d 6c 29 0a 20 20 28 73 64 61 74 2d 73 65 html). (sdat-se
1910: 74 2d 74 6f 70 70 61 67 65 21 20 73 65 6c 66 20 t-toppage! self
1920: 20 20 20 20 22 69 6e 64 65 78 22 29 0a 20 20 28 "index"). (
1930: 73 64 61 74 2d 73 65 74 2d 70 61 72 61 6d 73 21 sdat-set-params!
1940: 20 73 65 6c 66 20 20 20 20 20 20 27 28 29 29 20 self '())
1950: 20 20 20 20 20 20 20 20 20 20 3b 3b 0a 20 20 28 ;;. (
1960: 73 64 61 74 2d 73 65 74 2d 70 61 74 68 2d 70 61 sdat-set-path-pa
1970: 72 61 6d 73 21 20 73 65 6c 66 20 27 28 29 29 0a rams! self '()).
1980: 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 (sdat-set-sess
1990: 69 6f 6e 2d 6b 65 79 21 20 73 65 6c 66 20 23 66 ion-key! self #f
19a0: 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 ). (sdat-set-pa
19b0: 67 65 64 61 74 21 20 73 65 6c 66 20 20 20 20 20 gedat! self
19c0: 27 28 29 29 0a 20 20 28 73 64 61 74 2d 73 65 74 '()). (sdat-set
19d0: 2d 61 6c 74 2d 70 61 67 65 2d 64 61 74 21 20 73 -alt-page-dat! s
19e0: 65 6c 66 20 23 66 29 0a 20 20 28 73 64 61 74 2d elf #f). (sdat-
19f0: 73 65 74 2d 73 72 6f 6f 74 21 20 73 65 6c 66 20 set-sroot! self
1a00: 20 20 20 20 20 20 22 2e 2f 22 29 0a 20 20 28 73 "./"). (s
1a10: 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e 2d dat-set-session-
1a20: 63 6f 6f 6b 69 65 21 20 73 65 6c 66 20 23 66 29 cookie! self #f)
1a30: 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 63 75 72 . (sdat-set-cur
1a40: 72 2d 65 72 72 21 20 73 65 6c 66 20 23 66 29 0a r-err! self #f).
1a50: 20 20 28 73 64 61 74 2d 73 65 74 2d 6c 6f 67 2d (sdat-set-log-
1a60: 70 6f 72 74 21 20 73 65 6c 66 20 28 63 75 72 72 port! self (curr
1a70: 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 ent-error-port))
1a80: 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 65 . (sdat-set-see
1a90: 6e 2d 70 61 67 65 73 21 20 73 65 6c 66 20 27 28 n-pages! self '(
1aa0: 29 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 70 )). (sdat-set-p
1ab0: 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 21 20 73 age-dir-style! s
1ac0: 65 6c 66 20 23 74 29 20 3b 3b 20 23 74 20 3a 20 elf #t) ;; #t :
1ad0: 70 61 67 65 73 2f 3c 70 61 67 65 6e 61 6d 65 3e pages/<pagename>
1ae0: 5f 28 76 69 65 77 7c 63 6e 74 6c 29 2e 73 63 6d _(view|cntl).scm
1af0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
1b00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1b10: 20 20 20 20 20 20 20 3b 3b 20 23 66 20 3a 20 70 ;; #f : p
1b20: 61 67 65 73 2f 3c 70 61 67 65 6e 61 6d 65 3e 2f ages/<pagename>/
1b30: 28 76 69 65 77 7c 63 6f 6e 74 72 6f 6c 29 2e 73 (view|control).s
1b40: 63 6d 20 0a 20 20 28 73 64 61 74 2d 73 65 74 2d cm . (sdat-set-
1b50: 64 65 62 75 67 6d 6f 64 65 21 20 20 20 20 20 20 debugmode!
1b60: 20 20 20 20 73 65 6c 66 20 23 66 29 0a 20 20 09 self #f). .
1b70: 09 09 20 20 20 20 20 0a 20 20 28 73 64 61 74 2d .. . (sdat-
1b80: 73 65 74 2d 70 61 67 65 76 61 72 73 21 20 20 20 set-pagevars!
1b90: 20 20 20 20 20 20 20 20 73 65 6c 66 20 28 6d 61 self (ma
1ba0: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
1bb0: 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 (sdat-set-sess
1bc0: 69 6f 6e 76 61 72 73 21 20 20 20 20 20 20 20 20 ionvars!
1bd0: 73 65 6c 66 20 28 6d 61 6b 65 2d 68 61 73 68 2d self (make-hash-
1be0: 74 61 62 6c 65 29 29 0a 20 20 28 73 64 61 74 2d table)). (sdat-
1bf0: 73 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 21 20 set-globalvars!
1c00: 20 20 20 20 20 20 20 20 73 65 6c 66 20 28 6d 61 self (ma
1c10: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
1c20: 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 (sdat-set-page
1c30: 76 61 72 73 2d 62 65 66 6f 72 65 21 20 20 20 20 vars-before!
1c40: 73 65 6c 66 20 28 6d 61 6b 65 2d 68 61 73 68 2d self (make-hash-
1c50: 74 61 62 6c 65 29 29 0a 20 20 28 73 64 61 74 2d table)). (sdat-
1c60: 73 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 2d set-sessionvars-
1c70: 62 65 66 6f 72 65 21 20 73 65 6c 66 20 28 6d 61 before! self (ma
1c80: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
1c90: 20 20 28 73 64 61 74 2d 73 65 74 2d 67 6c 6f 62 (sdat-set-glob
1ca0: 61 6c 76 61 72 73 2d 62 65 66 6f 72 65 21 20 20 alvars-before!
1cb0: 73 65 6c 66 20 28 6d 61 6b 65 2d 68 61 73 68 2d self (make-hash-
1cc0: 74 61 62 6c 65 29 29 0a 20 20 28 73 64 61 74 2d table)). (sdat-
1cd0: 73 65 74 2d 64 6f 6d 61 69 6e 21 20 20 20 20 20 set-domain!
1ce0: 20 20 20 20 20 20 20 20 73 65 6c 66 20 22 6c 6f self "lo
1cf0: 63 61 68 6f 73 74 22 29 20 20 20 3b 3b 20 65 6e cahost") ;; en
1d00: 64 20 6f 66 20 64 65 66 61 75 6c 74 73 0a 20 20 d of defaults.
1d10: 28 6c 65 74 2a 20 28 28 72 61 77 63 6f 6e 66 69 (let* ((rawconfi
1d20: 67 64 61 74 20 28 73 65 73 73 69 6f 6e 3a 72 65 gdat (session:re
1d30: 61 64 2d 63 6f 6e 66 69 67 20 73 65 6c 66 29 29 ad-config self))
1d40: 0a 09 20 28 63 6f 6e 66 69 67 64 61 74 20 28 69 .. (configdat (i
1d50: 66 20 72 61 77 63 6f 6e 66 69 67 64 61 74 20 28 f rawconfigdat (
1d60: 65 76 61 6c 20 72 61 77 63 6f 6e 66 69 67 64 61 eval rawconfigda
1d70: 74 29 20 27 28 29 29 29 0a 09 20 28 73 72 6f 6f t) '())).. (sroo
1d80: 74 20 20 20 20 20 28 73 3a 66 69 6e 64 2d 70 61 t (s:find-pa
1d90: 72 61 6d 20 27 73 72 6f 6f 74 20 20 20 20 63 6f ram 'sroot co
1da0: 6e 66 69 67 64 61 74 29 29 0a 09 20 28 6c 6f 67 nfigdat)).. (log
1db0: 66 69 6c 65 20 20 20 28 73 3a 66 69 6e 64 2d 70 file (s:find-p
1dc0: 61 72 61 6d 20 27 6c 6f 67 66 69 6c 65 20 20 63 aram 'logfile c
1dd0: 6f 6e 66 69 67 64 61 74 29 29 0a 09 20 28 64 62 onfigdat)).. (db
1de0: 74 79 70 65 20 20 20 20 28 73 3a 66 69 6e 64 2d type (s:find-
1df0: 70 61 72 61 6d 20 27 64 62 74 79 70 65 20 20 20 param 'dbtype
1e00: 63 6f 6e 66 69 67 64 61 74 29 29 0a 09 20 28 64 configdat)).. (d
1e10: 62 69 6e 69 74 20 20 20 20 28 73 3a 66 69 6e 64 binit (s:find
1e20: 2d 70 61 72 61 6d 20 27 64 62 69 6e 69 74 20 20 -param 'dbinit
1e30: 20 63 6f 6e 66 69 67 64 61 74 29 29 0a 09 20 28 configdat)).. (
1e40: 64 6f 6d 61 69 6e 20 20 20 20 28 73 3a 66 69 6e domain (s:fin
1e50: 64 2d 70 61 72 61 6d 20 27 64 6f 6d 61 69 6e 20 d-param 'domain
1e60: 20 20 63 6f 6e 66 69 67 64 61 74 29 29 0a 09 20 configdat))..
1e70: 28 74 77 69 6b 69 64 69 72 20 20 28 73 3a 66 69 (twikidir (s:fi
1e80: 6e 64 2d 70 61 72 61 6d 20 27 74 77 69 6b 69 64 nd-param 'twikid
1e90: 69 72 20 63 6f 6e 66 69 67 64 61 74 29 29 0a 09 ir configdat))..
1ea0: 20 28 70 61 67 65 2d 64 69 72 20 20 28 73 3a 66 (page-dir (s:f
1eb0: 69 6e 64 2d 70 61 72 61 6d 20 27 70 61 67 65 2d ind-param 'page-
1ec0: 64 69 72 2d 73 74 79 6c 65 20 63 6f 6e 66 69 67 dir-style config
1ed0: 64 61 74 29 29 0a 09 20 28 64 65 62 75 67 6d 6f dat)).. (debugmo
1ee0: 64 65 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d de (s:find-param
1ef0: 20 27 64 65 62 75 67 6d 6f 64 65 20 63 6f 6e 66 'debugmode conf
1f00: 69 67 64 61 74 29 29 29 0a 20 20 20 20 28 69 66 igdat))). (if
1f10: 20 73 72 6f 6f 74 20 20 20 20 28 73 64 61 74 2d sroot (sdat-
1f20: 73 65 74 2d 73 72 6f 6f 74 21 20 20 20 20 73 65 set-sroot! se
1f30: 6c 66 20 73 72 6f 6f 74 29 29 0a 20 20 20 20 28 lf sroot)). (
1f40: 69 66 20 6c 6f 67 66 69 6c 65 20 20 28 73 64 61 if logfile (sda
1f50: 74 2d 73 65 74 2d 6c 6f 67 66 69 6c 65 21 20 20 t-set-logfile!
1f60: 73 65 6c 66 20 6c 6f 67 66 69 6c 65 29 29 0a 20 self logfile)).
1f70: 20 20 20 28 69 66 20 64 62 74 79 70 65 20 20 20 (if dbtype
1f80: 28 73 64 61 74 2d 73 65 74 2d 64 62 74 79 70 65 (sdat-set-dbtype
1f90: 21 20 20 20 73 65 6c 66 20 64 62 74 79 70 65 29 ! self dbtype)
1fa0: 29 0a 20 20 20 20 28 69 66 20 64 62 69 6e 69 74 ). (if dbinit
1fb0: 20 20 20 28 73 64 61 74 2d 73 65 74 2d 64 62 69 (sdat-set-dbi
1fc0: 6e 69 74 21 20 20 20 73 65 6c 66 20 64 62 69 6e nit! self dbin
1fd0: 69 74 29 29 0a 20 20 20 20 28 69 66 20 64 6f 6d it)). (if dom
1fe0: 61 69 6e 20 20 20 28 73 64 61 74 2d 73 65 74 2d ain (sdat-set-
1ff0: 64 6f 6d 61 69 6e 21 20 20 20 73 65 6c 66 20 64 domain! self d
2000: 6f 6d 61 69 6e 29 29 0a 20 20 20 20 28 69 66 20 omain)). (if
2010: 74 77 69 6b 69 64 69 72 20 28 73 64 61 74 2d 73 twikidir (sdat-s
2020: 65 74 2d 74 77 69 6b 69 64 69 72 21 20 73 65 6c et-twikidir! sel
2030: 66 20 74 77 69 6b 69 64 69 72 29 29 0a 20 20 20 f twikidir)).
2040: 20 28 69 66 20 64 65 62 75 67 6d 6f 64 65 20 28 (if debugmode (
2050: 73 64 61 74 2d 73 65 74 2d 64 65 62 75 67 6d 6f sdat-set-debugmo
2060: 64 65 21 20 73 65 6c 66 20 64 65 62 75 67 6d 6f de! self debugmo
2070: 64 65 29 29 0a 20 20 20 20 28 73 64 61 74 2d 73 de)). (sdat-s
2080: 65 74 2d 70 61 67 65 2d 64 69 72 2d 73 74 79 6c et-page-dir-styl
2090: 65 21 20 73 65 6c 66 20 70 61 67 65 2d 64 69 72 e! self page-dir
20a0: 29 0a 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 ). ;; (print
20b0: 22 63 6f 6e 66 69 67 64 61 74 3a 20 22 29 28 70 "configdat: ")(p
20c0: 70 20 63 6f 6e 66 69 67 64 61 74 29 0a 20 20 20 p configdat).
20d0: 20 28 69 66 20 64 65 62 75 67 6d 6f 64 65 0a 09 (if debugmode..
20e0: 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c (session:log sel
20f0: 66 20 22 73 72 6f 6f 74 3a 20 22 20 73 72 6f 6f f "sroot: " sroo
2100: 74 20 22 20 6c 6f 67 66 69 6c 65 3a 20 22 20 6c t " logfile: " l
2110: 6f 67 66 69 6c 65 20 22 20 64 62 74 79 70 65 3a ogfile " dbtype:
2120: 20 22 20 64 62 74 79 70 65 20 0a 09 09 20 20 20 " dbtype ...
2130: 20 20 22 20 64 62 69 6e 69 74 3a 20 22 20 64 62 " dbinit: " db
2140: 69 6e 69 74 20 22 20 64 6f 6d 61 69 6e 3a 20 22 init " domain: "
2150: 20 64 6f 6d 61 69 6e 20 22 20 70 61 67 65 2d 64 domain " page-d
2160: 69 72 2d 73 74 79 6c 65 3a 20 22 20 70 61 67 65 ir-style: " page
2170: 2d 64 69 72 29 29 0a 20 20 20 20 29 0a 20 20 29 -dir)). ). )
2180: 0a 3b 3b 20 20 20 28 6c 65 74 20 28 28 64 62 74 .;; (let ((dbt
2190: 79 70 65 20 28 73 64 61 74 2d 67 65 74 2d 64 62 ype (sdat-get-db
21a0: 74 79 70 65 20 73 65 6c 66 29 29 29 0a 3b 3b 20 type self))).;;
21b0: 20 20 20 20 28 70 72 69 6e 74 20 22 64 62 74 79 (print "dbty
21c0: 70 65 3a 20 22 20 64 62 74 79 70 65 29 0a 3b 3b pe: " dbtype).;;
21d0: 20 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d 64 (sdat-set-d
21e0: 62 74 79 70 65 21 20 73 65 6c 66 20 28 65 76 61 btype! self (eva
21f0: 6c 20 64 62 74 79 70 65 29 29 29 29 0a 0a 28 64 l dbtype))))..(d
2200: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 efine (session:s
2210: 65 74 75 70 20 73 65 6c 66 29 0a 20 20 28 6c 65 etup self). (le
2220: 74 20 28 28 64 62 74 79 70 65 20 20 20 20 28 73 t ((dbtype (s
2230: 64 61 74 2d 67 65 74 2d 64 62 74 79 70 65 20 73 dat-get-dbtype s
2240: 65 6c 66 29 29 0a 09 28 64 65 62 75 67 6d 6f 64 elf))..(debugmod
2250: 65 20 28 73 64 61 74 2d 67 65 74 2d 64 65 62 75 e (sdat-get-debu
2260: 67 6d 6f 64 65 20 73 65 6c 66 29 29 0a 09 28 64 gmode self))..(d
2270: 62 69 6e 69 74 20 20 20 20 28 65 76 61 6c 20 28 binit (eval (
2280: 73 64 61 74 2d 67 65 74 2d 64 62 69 6e 69 74 20 sdat-get-dbinit
2290: 73 65 6c 66 29 29 29 0a 09 28 64 62 65 78 69 73 self)))..(dbexis
22a0: 74 73 20 20 23 66 29 29 0a 20 20 20 20 28 6c 65 ts #f)). (le
22b0: 74 20 28 28 64 62 66 6e 61 6d 65 20 28 61 6c 69 t ((dbfname (ali
22c0: 73 74 2d 72 65 66 20 27 64 62 6e 61 6d 65 20 64 st-ref 'dbname d
22d0: 62 69 6e 69 74 29 29 29 0a 20 20 20 20 20 20 28 binit))). (
22e0: 69 66 20 64 65 62 75 67 6d 6f 64 65 20 28 73 65 if debugmode (se
22f0: 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 ssion:log self "
2300: 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 20 64 62 session:setup db
2310: 66 6e 61 6d 65 3d 22 20 64 62 66 6e 61 6d 65 20 fname=" dbfname
2320: 22 2c 20 64 62 74 79 70 65 3d 22 20 64 62 74 79 ", dbtype=" dbty
2330: 70 65 20 22 2c 20 64 62 69 6e 69 74 3d 22 20 64 pe ", dbinit=" d
2340: 62 69 6e 69 74 29 29 0a 20 20 20 20 20 20 28 69 binit)). (i
2350: 66 20 28 65 71 3f 20 64 62 74 79 70 65 20 27 73 f (eq? dbtype 's
2360: 71 6c 69 74 65 33 29 0a 09 20 20 28 6c 65 74 20 qlite3).. (let
2370: 28 28 64 62 70 61 74 68 20 28 70 61 74 68 6e 61 ((dbpath (pathna
2380: 6d 65 2d 64 69 72 65 63 74 6f 72 79 20 64 62 66 me-directory dbf
2390: 6e 61 6d 65 29 29 29 20 20 3b 3b 20 64 6f 20 61 name))) ;; do a
23a0: 20 63 6f 75 70 6c 65 20 73 61 6e 69 74 79 20 63 couple sanity c
23b0: 68 65 63 6b 73 20 68 65 72 65 20 74 6f 20 6d 61 hecks here to ma
23c0: 6b 65 20 73 65 74 74 69 6e 67 20 75 70 20 65 61 ke setting up ea
23d0: 73 69 65 72 0a 09 20 20 20 20 28 69 66 20 64 65 sier.. (if de
23e0: 62 75 67 6d 6f 64 65 20 28 73 65 73 73 69 6f 6e bugmode (session
23f0: 3a 6c 6f 67 20 73 65 6c 66 20 22 49 4e 46 4f 3a :log self "INFO:
2400: 20 73 65 74 74 69 6e 67 20 75 70 20 66 6f 72 20 setting up for
2410: 73 71 6c 69 74 65 33 20 64 62 20 61 63 63 65 73 sqlite3 db acces
2420: 73 20 74 6f 20 22 20 64 62 66 6e 61 6d 65 29 29 s to " dbfname))
2430: 0a 09 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 .. (if (not (
2440: 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 73 file-write-acces
2450: 73 3f 20 64 62 70 61 74 68 29 29 0a 09 09 28 73 s? dbpath))...(s
2460: 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 ession:log self
2470: 22 57 41 52 4e 49 4e 47 3a 20 43 61 6e 6e 6f 74 "WARNING: Cannot
2480: 20 77 72 69 74 65 20 74 6f 20 22 20 64 62 70 61 write to " dbpa
2490: 74 68 29 0a 09 09 28 69 66 20 64 65 62 75 67 6d th)...(if debugm
24a0: 6f 64 65 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 ode (session:log
24b0: 20 73 65 6c 66 20 22 49 4e 46 4f 3a 20 22 20 64 self "INFO: " d
24c0: 62 70 61 74 68 20 22 20 69 73 20 77 72 69 74 65 bpath " is write
24d0: 61 62 6c 65 22 29 29 29 0a 09 20 20 20 20 28 69 able"))).. (i
24e0: 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 f (file-exists?
24f0: 64 62 66 6e 61 6d 65 29 0a 09 09 28 62 65 67 69 dbfname)...(begi
2500: 6e 0a 09 09 20 20 3b 3b 20 28 73 65 73 73 69 6f n... ;; (sessio
2510: 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 73 65 74 74 n:log self "sett
2520: 69 6e 67 20 64 62 65 78 69 73 74 73 20 74 6f 20 ing dbexists to
2530: 23 74 22 29 0a 09 09 20 20 28 73 65 74 21 20 64 #t")... (set! d
2540: 62 65 78 69 73 74 73 20 23 74 29 29 29 29 0a 09 bexists #t))))..
2550: 20 20 28 69 66 20 64 65 62 75 67 6d 6f 64 65 20 (if debugmode
2560: 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c (session:log sel
2570: 66 20 22 49 4e 46 4f 3a 20 73 65 74 74 69 6e 67 f "INFO: setting
2580: 20 75 70 20 66 6f 72 20 70 67 20 64 62 20 61 63 up for pg db ac
2590: 63 65 73 73 20 74 6f 20 61 63 63 6f 75 6e 74 20 cess to account
25a0: 69 6e 66 6f 20 22 20 64 62 69 6e 69 74 29 29 29 info " dbinit)))
25b0: 0a 20 20 20 20 20 20 28 69 66 20 64 65 62 75 67 . (if debug
25c0: 6d 6f 64 65 20 28 73 65 73 73 69 6f 6e 3a 6c 6f mode (session:lo
25d0: 67 20 73 65 6c 66 20 22 64 62 74 79 70 65 3a 20 g self "dbtype:
25e0: 22 20 64 62 74 79 70 65 20 22 20 64 62 66 6e 61 " dbtype " dbfna
25f0: 6d 65 3a 20 22 20 64 62 66 6e 61 6d 65 20 22 20 me: " dbfname "
2600: 64 62 65 78 69 73 74 73 3a 20 22 20 64 62 65 78 dbexists: " dbex
2610: 69 73 74 73 29 29 29 0a 20 20 20 20 28 73 64 61 ists))). (sda
2620: 74 2d 73 65 74 2d 63 6f 6e 6e 21 20 73 65 6c 66 t-set-conn! self
2630: 20 28 64 62 69 3a 6f 70 65 6e 20 64 62 74 79 70 (dbi:open dbtyp
2640: 65 20 64 62 69 6e 69 74 29 29 0a 20 20 20 20 28 e dbinit)). (
2650: 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 64 62 65 if (and (not dbe
2660: 78 69 73 74 73 29 28 65 71 3f 20 64 62 74 79 70 xists)(eq? dbtyp
2670: 65 20 27 73 71 6c 69 74 65 33 29 29 0a 20 09 28 e 'sqlite3)). .(
2680: 62 65 67 69 6e 0a 09 20 20 28 70 72 69 6e 74 20 begin.. (print
2690: 22 57 41 52 4e 49 4e 47 3a 20 53 65 74 74 69 6e "WARNING: Settin
26a0: 67 20 75 70 20 73 65 73 73 69 6f 6e 20 64 62 20 g up session db
26b0: 77 69 74 68 20 73 71 6c 69 74 65 33 22 29 0a 09 with sqlite3")..
26c0: 20 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 (session:setup
26d0: 2d 64 62 20 73 65 6c 66 29 29 29 0a 20 20 20 20 -db self))).
26e0: 28 73 65 73 73 69 6f 6e 3a 70 72 6f 63 65 73 73 (session:process
26f0: 2d 75 72 6c 2d 70 61 74 68 20 73 65 6c 66 29 0a -url-path self).
2700: 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 (session:set
2710: 75 70 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 up-session-key s
2720: 65 6c 66 29 0a 20 20 20 20 3b 3b 20 63 61 70 74 elf). ;; capt
2730: 75 72 65 20 73 74 64 69 6e 20 69 66 20 74 68 69 ure stdin if thi
2740: 73 20 69 73 20 61 20 50 4f 53 54 0a 20 20 20 20 s is a POST.
2750: 28 73 64 61 74 2d 73 65 74 2d 72 65 71 75 65 73 (sdat-set-reques
2760: 74 2d 6d 65 74 68 6f 64 21 20 73 65 6c 66 20 28 t-method! self (
2770: 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d get-environment-
2780: 76 61 72 69 61 62 6c 65 20 22 52 45 51 55 45 53 variable "REQUES
2790: 54 5f 4d 45 54 48 4f 44 22 29 29 0a 20 20 20 20 T_METHOD")).
27a0: 28 73 64 61 74 2d 73 65 74 2d 66 6f 72 6d 64 61 (sdat-set-formda
27b0: 74 21 20 73 65 6c 66 20 28 66 6f 72 6d 64 61 74 t! self (formdat
27c0: 3a 6c 6f 61 64 2d 61 6c 6c 29 29 29 29 0a 0a 3b :load-all))))..;
27d0: 3b 20 73 65 74 75 70 20 74 68 65 20 64 62 20 77 ; setup the db w
27e0: 69 74 68 20 73 65 73 73 69 6f 6e 20 74 61 62 6c ith session tabl
27f0: 65 73 2c 20 77 6f 72 6b 73 20 66 6f 72 20 73 71 es, works for sq
2800: 6c 69 74 65 20 6f 6e 6c 79 20 72 69 67 68 74 20 lite only right
2810: 6e 6f 77 0a 28 64 65 66 69 6e 65 20 28 73 65 73 now.(define (ses
2820: 73 69 6f 6e 3a 73 65 74 75 70 2d 64 62 20 73 65 sion:setup-db se
2830: 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 63 6f 6e lf). (let ((con
2840: 6e 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e n (sdat-get-conn
2850: 20 73 65 6c 66 29 29 29 0a 20 20 20 20 28 66 6f self))). (fo
2860: 72 2d 65 61 63 68 20 0a 20 20 20 20 20 28 6c 61 r-each . (la
2870: 6d 62 64 61 20 28 73 74 6d 74 29 0a 20 20 20 20 mbda (stmt).
2880: 20 20 20 28 64 62 69 3a 65 78 65 63 20 63 6f 6e (dbi:exec con
2890: 6e 20 73 74 6d 74 29 29 0a 20 20 20 20 20 28 6c n stmt)). (l
28a0: 69 73 74 20 22 43 52 45 41 54 45 20 54 41 42 4c ist "CREATE TABL
28b0: 45 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 28 E session_vars (
28c0: 69 64 20 49 4e 54 45 47 45 52 20 50 52 49 4d 41 id INTEGER PRIMA
28d0: 52 59 20 4b 45 59 2c 73 65 73 73 69 6f 6e 5f 69 RY KEY,session_i
28e0: 64 20 49 4e 54 45 47 45 52 2c 70 61 67 65 20 54 d INTEGER,page T
28f0: 45 58 54 2c 6b 65 79 20 54 45 58 54 2c 76 61 6c EXT,key TEXT,val
2900: 75 65 20 54 45 58 54 29 3b 22 0a 09 20 20 20 22 ue TEXT);".. "
2910: 43 52 45 41 54 45 20 54 41 42 4c 45 20 73 65 73 CREATE TABLE ses
2920: 73 69 6f 6e 73 20 28 69 64 20 49 4e 54 45 47 45 sions (id INTEGE
2930: 52 20 50 52 49 4d 41 52 59 20 4b 45 59 2c 73 65 R PRIMARY KEY,se
2940: 73 73 69 6f 6e 5f 6b 65 79 20 54 45 58 54 2c 6c ssion_key TEXT,l
2950: 61 73 74 5f 75 73 65 64 20 54 49 4d 45 53 54 41 ast_used TIMESTA
2960: 4d 50 29 3b 22 0a 20 20 20 20 20 20 20 20 20 20 MP);".
2970: 20 22 43 52 45 41 54 45 20 54 41 42 4c 45 20 6d "CREATE TABLE m
2980: 65 74 61 64 61 74 61 20 28 69 64 20 49 4e 54 45 etadata (id INTE
2990: 47 45 52 20 50 52 49 4d 41 52 59 20 4b 45 59 2c GER PRIMARY KEY,
29a0: 6b 65 79 20 54 45 58 54 2c 76 61 6c 75 65 20 54 key TEXT,value T
29b0: 45 58 54 29 3b 22 29 29 29 29 0a 3b 3b 20 20 3b EXT);")))).;; ;
29c0: 3b 20 69 66 20 77 65 20 68 61 76 65 20 61 20 73 ; if we have a s
29d0: 65 73 73 69 6f 6e 5f 6b 65 79 20 6c 6f 6f 6b 20 ession_key look
29e0: 75 70 20 74 68 65 20 73 65 73 73 69 6f 6e 2d 69 up the session-i
29f0: 64 20 61 6e 64 20 73 74 6f 72 65 20 69 74 0a 3b d and store it.;
2a00: 3b 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 ; (sdat-set-ses
2a10: 73 69 6f 6e 2d 69 64 21 20 73 65 6c 66 20 28 73 sion-id! self (s
2a20: 65 73 73 69 6f 6e 3a 67 65 74 2d 69 64 20 73 65 ession:get-id se
2a30: 6c 66 29 29 29 0a 0a 3b 3b 20 6f 6e 6c 79 20 73 lf)))..;; only s
2a40: 65 74 20 73 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 et session-cooki
2a50: 65 20 77 68 65 6e 20 61 20 6e 65 77 20 73 65 73 e when a new ses
2a60: 73 69 6f 6e 20 69 73 20 63 72 65 61 74 65 64 0a sion is created.
2a70: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
2a80: 3a 73 65 74 75 70 2d 73 65 73 73 69 6f 6e 2d 6b :setup-session-k
2a90: 65 79 20 73 65 6c 66 29 20 20 0a 20 20 28 6c 65 ey self) . (le
2aa0: 74 2a 20 28 28 73 6b 20 20 28 73 65 73 73 69 6f t* ((sk (sessio
2ab0: 6e 3a 65 78 74 72 61 63 74 2d 73 65 73 73 69 6f n:extract-sessio
2ac0: 6e 2d 6b 65 79 20 73 65 6c 66 29 29 0a 20 20 20 n-key self)).
2ad0: 20 20 20 20 20 20 28 73 69 64 20 28 69 66 20 73 (sid (if s
2ae0: 6b 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 69 k (session:get-i
2af0: 64 20 73 65 6c 66 20 73 6b 29 20 23 66 29 29 29 d self sk) #f)))
2b00: 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 73 69 . (if (not si
2b10: 64 29 20 3b 3b 20 6e 65 65 64 20 61 20 6e 65 77 d) ;; need a new
2b20: 20 6b 65 79 0a 20 20 20 20 20 20 20 20 28 6c 65 key. (le
2b30: 74 2a 20 28 28 6e 65 77 2d 6b 65 79 20 28 73 65 t* ((new-key (se
2b40: 73 73 69 6f 6e 3a 67 65 74 2d 6e 65 77 2d 6b 65 ssion:get-new-ke
2b50: 79 20 73 65 6c 66 29 29 0a 20 20 20 20 20 20 20 y self)).
2b60: 20 20 20 20 20 20 20 20 28 6e 65 77 2d 73 69 64 (new-sid
2b70: 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 69 64 (session:get-id
2b80: 20 73 65 6c 66 20 6e 65 77 2d 6b 65 79 29 29 29 self new-key)))
2b90: 0a 20 20 20 20 20 20 20 20 20 20 28 73 64 61 74 . (sdat
2ba0: 2d 73 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 -set-session-key
2bb0: 21 20 73 65 6c 66 20 6e 65 77 2d 6b 65 79 29 0a ! self new-key).
2bc0: 20 20 20 20 20 20 20 20 20 20 28 73 64 61 74 2d (sdat-
2bd0: 73 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 21 20 set-session-id!
2be0: 73 65 6c 66 20 6e 65 77 2d 73 69 64 29 0a 20 20 self new-sid).
2bf0: 20 20 20 20 20 20 20 20 28 73 64 61 74 2d 73 65 (sdat-se
2c00: 74 2d 73 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 t-session-cookie
2c10: 21 20 73 65 6c 66 20 28 73 65 73 73 69 6f 6e 3a ! self (session:
2c20: 6d 61 6b 65 2d 63 6f 6f 6b 69 65 20 73 65 6c 66 make-cookie self
2c30: 29 29 29 0a 20 20 20 20 20 20 20 20 28 73 64 61 ))). (sda
2c40: 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 t-set-session-id
2c50: 21 20 73 65 6c 66 20 73 69 64 29 29 29 29 0a 0a ! self sid))))..
2c60: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
2c70: 3a 6d 61 6b 65 2d 63 6f 6f 6b 69 65 20 73 65 6c :make-cookie sel
2c80: 66 29 0a 20 20 3b 3b 20 28 6c 69 73 74 20 28 63 f). ;; (list (c
2c90: 6f 6e 63 20 22 73 65 73 73 69 6f 6e 5f 6b 65 79 onc "session_key
2ca0: 3d 22 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 =" (sdat-get-ses
2cb0: 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 20 22 sion-key self) "
2cc0: 3b 20 50 61 74 68 3d 2f 3b 20 44 6f 6d 61 69 6e ; Path=/; Domain
2cd0: 3d 2e 22 20 28 73 64 61 74 2d 67 65 74 2d 64 6f =." (sdat-get-do
2ce0: 6d 61 69 6e 20 73 65 6c 66 29 20 22 3b 20 4d 61 main self) "; Ma
2cf0: 78 2d 41 67 65 3d 22 20 28 2a 20 38 36 34 30 30 x-Age=" (* 86400
2d00: 20 31 34 29 20 22 3b 20 56 65 72 73 69 6f 6e 3d 14) "; Version=
2d10: 31 22 29 29 29 20 0a 20 20 3b 3b 20 41 63 63 6f 1"))) . ;; Acco
2d20: 72 64 69 6e 67 20 74 6f 20 0a 20 20 3b 3b 20 20 rding to . ;;
2d30: 20 20 68 74 74 70 3a 2f 2f 77 77 77 2e 63 6f 64 http://www.cod
2d40: 65 6d 61 72 76 65 6c 73 2e 63 6f 6d 2f 32 30 31 emarvels.com/201
2d50: 30 2f 31 31 2f 61 70 61 63 68 65 2d 72 65 77 72 0/11/apache-rewr
2d60: 69 74 65 72 75 6c 65 2d 73 65 74 2d 61 2d 63 6f iterule-set-a-co
2d70: 6f 6b 69 65 2d 6f 6e 2d 6c 6f 63 61 6c 68 6f 73 okie-on-localhos
2d80: 74 2f 0a 0a 20 20 3b 3b 20 20 48 65 72 65 20 61 t/.. ;; Here a
2d90: 72 65 20 74 68 65 20 32 20 28 6f 66 74 65 6e 20 re the 2 (often
2da0: 6c 65 66 74 20 6f 75 74 29 20 72 65 71 75 69 72 left out) requir
2db0: 65 6d 65 6e 74 73 20 74 6f 20 73 65 74 20 61 20 ements to set a
2dc0: 63 6f 6f 6b 69 65 20 75 73 69 6e 67 0a 20 20 3b cookie using. ;
2dd0: 3b 20 20 68 74 74 70 64 1b 2d 46 a2 73 20 72 65 ; httpd.-F˘s re
2de0: 77 72 69 74 65 20 72 75 6c 65 20 28 6d 6f 64 5f write rule (mod_
2df0: 72 65 77 72 69 74 65 29 2c 20 77 68 69 6c 65 20 rewrite), while
2e00: 77 6f 72 6b 69 6e 67 20 6f 6e 20 6c 6f 63 61 6c working on local
2e10: 68 6f 73 74 3a 1b 2d 41 0a 20 20 3b 3b 0a 20 20 host:.-A. ;;.
2e20: 3b 3b 20 20 55 73 65 20 74 68 65 20 49 50 20 31 ;; Use the IP 1
2e30: 32 37 2e 30 2e 30 2e 31 20 69 6e 73 74 65 61 64 27.0.0.1 instead
2e40: 20 6f 66 20 6c 6f 63 61 6c 68 6f 73 74 2f 6d 61 of localhost/ma
2e50: 63 68 69 6e 65 2d 6e 61 6d 65 20 61 73 20 74 68 chine-name as th
2e60: 65 0a 20 20 3b 3b 20 20 64 6f 6d 61 69 6e 3b 20 e. ;; domain;
2e70: 65 2e 67 2e 20 5b 43 4f 3d 73 6f 6d 65 43 6f 6f e.g. [CO=someCoo
2e80: 6b 69 65 3a 73 6f 6d 65 56 61 6c 75 65 3a 31 32 kie:someValue:12
2e90: 37 2e 30 2e 30 2e 31 3a 32 3a 2f 5d 2c 20 77 68 7.0.0.1:2:/], wh
2ea0: 69 63 68 20 73 61 79 73 0a 20 20 3b 3b 20 20 63 ich says. ;; c
2eb0: 72 65 61 74 65 20 61 20 63 6f 6f 6b 69 65 20 1b reate a cookie .
2ec0: 2d 59 b4 73 6f 6d 65 43 6f 6f 6b 69 65 a1 20 77 -Y´someCookieˇ w
2ed0: 69 74 68 20 76 61 6c 75 65 20 b4 73 6f 6d 65 56 ith value ´someV
2ee0: 61 6c 75 65 a1 20 66 6f 72 20 74 68 65 0a 20 20 alueˇ for the.
2ef0: 3b 3b 20 20 64 6f 6d 61 69 6e 20 b4 31 32 37 2e ;; domain ´127.
2f00: 30 2e 30 2e 31 1b 24 42 21 6d 1b 28 42 20 68 61 0.0.1.$B!m.(B ha
2f10: 76 69 6e 67 20 61 20 6c 69 66 65 20 74 69 6d 65 ving a life time
2f20: 20 6f 66 20 32 20 6d 69 6e 73 2c 20 66 6f 72 20 of 2 mins, for
2f30: 61 6e 79 20 70 61 74 68 20 69 6e 0a 20 20 3b 3b any path in. ;;
2f40: 20 20 74 68 65 20 64 6f 6d 61 69 6e 20 28 70 61 the domain (pa
2f50: 74 68 3d 2f 29 2e 20 28 4f 62 76 69 6f 75 73 6c th=/). (Obviousl
2f60: 79 20 79 6f 75 20 77 69 6c 6c 20 68 61 76 65 20 y you will have
2f70: 74 6f 20 72 75 6e 20 74 68 65 0a 20 20 3b 3b 20 to run the. ;;
2f80: 20 61 70 70 6c 69 63 61 74 69 6f 6e 20 77 69 74 application wit
2f90: 68 20 74 68 69 73 20 76 61 6c 75 65 20 69 6e 20 h this value in
2fa0: 74 68 65 20 55 52 4c 29 0a 20 20 3b 3b 0a 20 20 the URL). ;;.
2fb0: 3b 3b 20 20 54 6f 20 6d 61 6b 65 20 61 20 73 65 ;; To make a se
2fc0: 73 73 69 6f 6e 20 63 6f 6f 6b 69 65 2c 20 6c 69 ssion cookie, li
2fd0: 6d 69 74 20 74 68 65 20 66 6c 61 67 20 73 74 61 mit the flag sta
2fe0: 74 65 6d 65 6e 74 20 74 6f 20 6a 75 73 74 20 74 tement to just t
2ff0: 68 72 65 65 0a 20 20 3b 3b 20 20 61 74 74 72 69 hree. ;; attri
3000: 62 75 74 65 73 3a 20 6e 61 6d 65 2c 20 76 61 6c butes: name, val
3010: 75 65 20 61 6e 64 20 64 6f 6d 61 69 6e 2e 20 65 ue and domain. e
3020: 2e 67 0a 20 20 3b 3b 20 20 5b 43 4f 3d 73 6f 6d .g. ;; [CO=som
3030: 65 43 6f 6f 6b 69 65 3a 73 6f 6d 65 56 61 6c 75 eCookie:someValu
3040: 65 3a 31 32 37 2e 30 2e 30 2e 31 5d 20 1b 25 47 e:127.0.0.1] .%G
3050: e2 80 93 1b 25 40 20 41 6e 79 20 66 75 72 74 68 –.%@ Any furth
3060: 65 72 0a 20 20 3b 3b 20 20 73 65 74 74 69 6e 67 er. ;; setting
3070: 73 2c 20 61 70 61 63 68 65 20 77 72 69 74 65 73 s, apache writes
3080: 20 61 6e a1 20 65 78 70 69 72 65 73 a1 20 61 74 anˇ expiresˇ at
3090: 74 72 69 62 75 74 65 20 66 6f 72 20 74 68 65 20 tribute for the
30a0: 73 65 74 2d 63 6f 6f 6b 69 65 0a 20 20 3b 3b 20 set-cookie. ;;
30b0: 20 68 65 61 64 65 72 2c 20 77 68 69 63 68 20 6d header, which m
30c0: 61 6b 65 73 20 74 68 65 20 63 6f 6f 6b 69 65 20 akes the cookie
30d0: 61 20 70 65 72 73 69 73 74 65 6e 74 20 6f 6e 65 a persistent one
30e0: 20 28 6e 6f 74 20 72 65 61 6c 6c 79 0a 20 20 3b (not really. ;
30f0: 3b 20 20 70 65 72 73 69 73 74 65 6e 74 2c 20 61 ; persistent, a
3100: 73 20 74 68 65 20 65 78 70 69 72 65 73 20 76 61 s the expires va
3110: 6c 75 65 20 73 65 74 20 69 73 20 74 68 65 20 63 lue set is the c
3120: 75 72 72 65 6e 74 20 73 65 72 76 65 72 20 74 69 urrent server ti
3130: 6d 65 0a 20 20 3b 3b 20 20 1b 25 47 e2 80 93 1b me. ;; .%G–.
3140: 25 40 20 73 6f 20 79 6f 75 20 64 6f 6e 1b 2d 46 %@ so you don.-F
3150: 1b 2d 46 a2 74 20 65 76 65 6e 20 67 65 74 20 74 .-F˘t even get t
3160: 6f 20 73 65 65 20 79 6f 75 72 20 63 6f 6f 6b 69 o see your cooki
3170: 65 21 29 1b 2d 41 0a 20 20 28 6c 69 73 74 20 28 e!).-A. (list (
3180: 73 74 72 69 6e 67 2d 73 75 62 73 74 69 74 75 74 string-substitut
3190: 65 20 0a 09 20 22 3b 22 20 22 3b 20 22 20 0a 09 e .. ";" "; " ..
31a0: 20 28 63 61 72 20 28 63 6f 6e 73 74 72 75 63 74 (car (construct
31b0: 2d 63 6f 6f 6b 69 65 2d 73 74 72 69 6e 67 20 0a -cookie-string .
31c0: 09 20 20 20 20 20 20 20 3b 3b 20 77 61 72 6e 69 . ;; warni
31d0: 6e 67 21 20 6d 65 73 73 69 6e 67 20 75 70 20 74 ng! messing up t
31e0: 68 69 73 20 69 74 74 79 20 62 69 74 74 79 20 62 his itty bitty b
31f0: 69 74 20 6f 66 20 63 6f 64 65 20 77 69 6c 6c 20 it of code will
3200: 63 6f 73 74 20 6d 75 63 68 20 74 69 6d 65 21 0a cost much time!.
3210: 09 20 20 20 20 20 20 20 60 28 28 22 73 65 73 73 . `(("sess
3220: 69 6f 6e 5f 6b 65 79 22 20 2c 28 73 64 61 74 2d ion_key" ,(sdat-
3230: 67 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 get-session-key
3240: 73 65 6c 66 29 0a 09 09 20 20 65 78 70 69 72 65 self)... expire
3250: 73 3a 20 2c 28 2b 20 28 63 75 72 72 65 6e 74 2d s: ,(+ (current-
3260: 73 65 63 6f 6e 64 73 29 20 28 2a 20 31 34 20 38 seconds) (* 14 8
3270: 36 34 30 30 29 29 20 0a 09 09 20 20 3b 3b 20 6d 6400)) ... ;; m
3280: 61 78 2d 61 67 65 3a 20 28 2a 20 31 34 20 38 36 ax-age: (* 14 86
3290: 34 30 30 29 0a 09 09 20 20 70 61 74 68 3a 20 22 400)... path: "
32a0: 2f 22 20 3b 3b 20 0a 09 09 20 20 64 6f 6d 61 69 /" ;; ... domai
32b0: 6e 3a 20 2c 28 73 74 72 69 6e 67 2d 61 70 70 65 n: ,(string-appe
32c0: 6e 64 20 22 2e 22 20 28 73 64 61 74 2d 67 65 74 nd "." (sdat-get
32d0: 2d 64 6f 6d 61 69 6e 20 73 65 6c 66 29 29 0a 09 -domain self))..
32e0: 09 20 20 76 65 72 73 69 6f 6e 3a 20 31 29 29 20 . version: 1))
32f0: 30 29 29 29 29 29 0a 0a 3b 3b 20 6c 6f 6f 6b 20 0)))))..;; look
3300: 75 70 20 61 20 67 69 76 65 6e 20 73 65 73 73 69 up a given sessi
3310: 6f 6e 20 6b 65 79 20 61 6e 64 20 72 65 74 75 72 on key and retur
3320: 6e 20 74 68 65 20 69 64 20 69 66 20 66 6f 75 6e n the id if foun
3330: 64 2c 20 23 66 20 69 66 20 6e 6f 74 20 66 6f 75 d, #f if not fou
3340: 6e 64 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 nd.(define (sess
3350: 69 6f 6e 3a 67 65 74 2d 69 64 20 73 65 6c 66 20 ion:get-id self
3360: 73 65 73 73 69 6f 6e 2d 6b 65 79 29 0a 20 20 3b session-key). ;
3370: 3b 20 28 6c 65 74 20 28 28 73 65 73 73 69 6f 6e ; (let ((session
3380: 2d 6b 65 79 20 28 73 64 61 74 2d 67 65 74 2d 73 -key (sdat-get-s
3390: 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 ession-key self)
33a0: 29 29 0a 20 20 28 69 66 20 73 65 73 73 69 6f 6e )). (if session
33b0: 2d 6b 65 79 0a 20 20 20 20 20 20 28 6c 65 74 20 -key. (let
33c0: 28 28 71 75 65 72 79 20 28 73 74 72 69 6e 67 2d ((query (string-
33d0: 61 70 70 65 6e 64 20 22 53 45 4c 45 43 54 20 69 append "SELECT i
33e0: 64 20 46 52 4f 4d 20 73 65 73 73 69 6f 6e 73 20 d FROM sessions
33f0: 57 48 45 52 45 20 73 65 73 73 69 6f 6e 5f 6b 65 WHERE session_ke
3400: 79 3d 27 22 20 73 65 73 73 69 6f 6e 2d 6b 65 79 y='" session-key
3410: 20 22 27 22 29 29 0a 20 20 20 20 20 20 20 20 20 "'")).
3420: 20 20 20 28 63 6f 6e 6e 20 28 73 64 61 74 2d 67 (conn (sdat-g
3430: 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 0a 20 et-conn self)).
3440: 20 20 20 20 20 20 20 20 20 20 20 28 72 65 73 75 (resu
3450: 6c 74 20 23 66 29 29 0a 09 28 64 62 69 3a 66 6f lt #f))..(dbi:fo
3460: 72 2d 65 61 63 68 2d 72 6f 77 20 0a 09 20 28 6c r-each-row .. (l
3470: 61 6d 62 64 61 20 28 74 75 70 6c 65 29 0a 09 20 ambda (tuple)..
3480: 20 20 28 73 65 74 21 20 72 65 73 75 6c 74 20 28 (set! result (
3490: 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 vector-ref tuple
34a0: 20 30 29 29 29 0a 09 20 63 6f 6e 6e 20 71 75 65 0))).. conn que
34b0: 72 79 29 0a 09 28 69 66 20 72 65 73 75 6c 74 20 ry)..(if result
34c0: 28 64 62 69 3a 65 78 65 63 20 63 6f 6e 6e 20 28 (dbi:exec conn (
34d0: 63 6f 6e 63 20 22 55 50 44 41 54 45 20 73 65 73 conc "UPDATE ses
34e0: 73 69 6f 6e 73 20 53 45 54 20 6c 61 73 74 5f 75 sions SET last_u
34f0: 73 65 64 3d 22 20 28 64 62 69 3a 6e 6f 77 20 63 sed=" (dbi:now c
3500: 6f 6e 6e 29 20 22 20 57 48 45 52 45 20 73 65 73 onn) " WHERE ses
3510: 73 69 6f 6e 5f 6b 65 79 3d 3f 3b 22 29 20 73 65 sion_key=?;") se
3520: 73 73 69 6f 6e 2d 6b 65 79 29 29 0a 20 20 20 20 ssion-key)).
3530: 20 20 20 20 72 65 73 75 6c 74 29 0a 20 20 20 20 result).
3540: 20 20 23 66 29 29 0a 0a 3b 3b 20 0a 28 64 65 66 #f))..;; .(def
3550: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 70 72 6f ine (session:pro
3560: 63 65 73 73 2d 75 72 6c 2d 70 61 74 68 20 73 65 cess-url-path se
3570: 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 70 61 74 lf). (let ((pat
3580: 68 2d 69 6e 66 6f 20 20 20 20 28 67 65 74 2d 65 h-info (get-e
3590: 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 nvironment-varia
35a0: 62 6c 65 20 22 50 41 54 48 5f 49 4e 46 4f 22 29 ble "PATH_INFO")
35b0: 29 0a 09 28 71 75 65 72 79 2d 73 74 72 69 6e 67 )..(query-string
35c0: 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e (get-environmen
35d0: 74 2d 76 61 72 69 61 62 6c 65 20 22 51 55 45 52 t-variable "QUER
35e0: 59 5f 53 54 52 49 4e 47 22 29 29 29 0a 20 20 20 Y_STRING"))).
35f0: 20 3b 3b 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 ;; (session:log
3600: 20 73 65 6c 66 20 22 70 61 74 68 2d 69 6e 66 6f self "path-info
3610: 3d 22 20 70 61 74 68 2d 69 6e 66 6f 20 22 20 71 =" path-info " q
3620: 75 65 72 79 2d 73 74 72 69 6e 67 3d 22 20 71 75 uery-string=" qu
3630: 65 72 79 2d 73 74 72 69 6e 67 29 0a 20 20 20 20 ery-string).
3640: 28 69 66 20 70 61 74 68 2d 69 6e 66 6f 0a 09 28 (if path-info..(
3650: 6c 65 74 2a 20 28 28 70 61 72 74 73 20 20 20 20 let* ((parts
3660: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 70 61 (string-split pa
3670: 74 68 2d 69 6e 66 6f 20 22 2f 22 29 29 0a 09 20 th-info "/"))..
3680: 20 20 20 20 20 20 28 6e 75 6d 70 61 72 74 73 20 (numparts
3690: 28 6c 65 6e 67 74 68 20 70 61 72 74 73 29 29 29 (length parts)))
36a0: 0a 09 20 20 28 69 66 20 28 3e 20 6e 75 6d 70 61 .. (if (> numpa
36b0: 72 74 73 20 30 29 0a 09 20 20 20 20 20 20 28 73 rts 0).. (s
36c0: 64 61 74 2d 73 65 74 2d 70 61 67 65 21 20 73 65 dat-set-page! se
36d0: 6c 66 20 28 63 61 72 20 70 61 72 74 73 29 29 29 lf (car parts)))
36e0: 0a 09 20 20 3b 3b 20 28 73 65 73 73 69 6f 6e 3a .. ;; (session:
36f0: 6c 6f 67 20 73 65 6c 66 20 22 75 72 6c 2d 70 61 log self "url-pa
3700: 74 68 3d 22 20 75 72 6c 2d 70 61 74 68 20 22 20 th=" url-path "
3710: 70 61 72 74 73 3d 22 20 70 61 72 74 73 29 0a 09 parts=" parts)..
3720: 20 20 28 69 66 20 28 3e 20 6e 75 6d 70 61 72 74 (if (> numpart
3730: 73 20 31 29 0a 09 20 20 20 20 20 20 28 73 64 61 s 1).. (sda
3740: 74 2d 73 65 74 2d 70 61 74 68 2d 70 61 72 61 6d t-set-path-param
3750: 73 21 20 73 65 6c 66 20 28 63 64 72 20 70 61 72 s! self (cdr par
3760: 74 73 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 ts))).
3770: 28 69 66 20 71 75 65 72 79 2d 73 74 72 69 6e 67 (if query-string
3780: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
3790: 73 64 61 74 2d 73 65 74 2d 70 61 72 61 6d 73 21 sdat-set-params!
37a0: 20 73 65 6c 66 20 28 73 74 72 69 6e 67 2d 73 70 self (string-sp
37b0: 6c 69 74 20 71 75 65 72 79 2d 73 74 72 69 6e 67 lit query-string
37c0: 20 22 26 22 29 29 29 29 29 29 29 0a 0a 3b 3b 20 "&")))))))..;;
37d0: 42 55 47 47 59 21 0a 28 64 65 66 69 6e 65 20 28 BUGGY!.(define (
37e0: 73 65 73 73 69 6f 6e 3a 67 65 74 2d 6e 65 77 2d session:get-new-
37f0: 6b 65 79 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 key self). (let
3800: 20 28 28 63 6f 6e 6e 20 20 20 28 73 64 61 74 2d ((conn (sdat-
3810: 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 0a get-conn self)).
3820: 20 20 20 20 20 20 20 20 28 74 6d 70 6b 65 79 20 (tmpkey
3830: 28 73 65 73 73 69 6f 6e 3a 6d 61 6b 65 2d 72 61 (session:make-ra
3840: 6e 64 2d 73 74 72 69 6e 67 20 32 30 29 29 0a 20 nd-string 20)).
3850: 20 20 20 20 20 20 20 28 73 74 61 74 75 73 20 23 (status #
3860: 66 29 29 0a 20 20 20 20 28 64 62 69 3a 66 6f 72 f)). (dbi:for
3870: 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 6d 62 64 -each-row (lambd
3880: 61 20 28 74 75 70 6c 65 29 0a 09 09 09 28 73 65 a (tuple)....(se
3890: 74 21 20 73 74 61 74 75 73 20 23 74 29 29 0a 09 t! status #t))..
38a0: 09 20 20 20 20 20 20 63 6f 6e 6e 20 28 73 74 72 . conn (str
38b0: 69 6e 67 2d 61 70 70 65 6e 64 20 22 49 4e 53 45 ing-append "INSE
38c0: 52 54 20 49 4e 54 4f 20 73 65 73 73 69 6f 6e 73 RT INTO sessions
38d0: 20 28 73 65 73 73 69 6f 6e 5f 6b 65 79 29 20 56 (session_key) V
38e0: 41 4c 55 45 53 20 28 27 22 20 74 6d 70 6b 65 79 ALUES ('" tmpkey
38f0: 20 22 27 29 22 29 29 0a 20 20 20 20 74 6d 70 6b "')")). tmpk
3900: 65 79 29 29 0a 0a 3b 3b 20 72 65 74 75 72 6e 73 ey))..;; returns
3910: 20 73 65 73 73 69 6f 6e 20 6b 65 79 20 49 46 46 session key IFF
3920: 20 69 74 20 69 73 20 69 6e 20 74 68 65 20 48 54 it is in the HT
3930: 54 50 5f 43 4f 4f 4b 49 45 20 0a 28 64 65 66 69 TP_COOKIE .(defi
3940: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 65 78 74 72 ne (session:extr
3950: 61 63 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 act-session-key
3960: 73 65 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 68 self). (let ((h
3970: 74 74 70 2d 63 6f 6f 6b 69 65 20 28 67 65 74 2d ttp-cookie (get-
3980: 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 environment-vari
3990: 61 62 6c 65 20 22 48 54 54 50 5f 43 4f 4f 4b 49 able "HTTP_COOKI
39a0: 45 22 29 29 29 0a 20 20 20 20 3b 3b 20 28 65 72 E"))). ;; (er
39b0: 72 3a 6c 6f 67 20 22 68 74 74 70 2d 63 6f 6f 6b r:log "http-cook
39c0: 69 65 3a 20 22 20 68 74 74 70 2d 63 6f 6f 6b 69 ie: " http-cooki
39d0: 65 29 0a 20 20 20 20 28 69 66 20 68 74 74 70 2d e). (if http-
39e0: 63 6f 6f 6b 69 65 0a 20 20 20 20 20 20 20 20 28 cookie. (
39f0: 73 65 73 73 69 6f 6e 3a 65 78 74 72 61 63 74 2d session:extract-
3a00: 6b 65 79 2d 66 72 6f 6d 2d 70 61 72 61 6d 20 73 key-from-param s
3a10: 65 6c 66 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 elf (string-spli
3a20: 74 2d 66 69 65 6c 64 73 20 20 22 3b 5c 5c 73 2b t-fields ";\\s+
3a30: 22 20 68 74 74 70 2d 63 6f 6f 6b 69 65 20 69 6e " http-cookie in
3a40: 66 69 78 3a 29 20 22 73 65 73 73 69 6f 6e 5f 6b fix:) "session_k
3a50: 65 79 22 29 0a 20 20 20 20 20 20 20 20 23 66 29 ey"). #f)
3a60: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 ))..(define (ses
3a70: 73 69 6f 6e 3a 67 65 74 2d 73 65 73 73 69 6f 6e sion:get-session
3a80: 2d 69 64 20 73 65 6c 66 20 73 65 73 73 69 6f 6e -id self session
3a90: 2d 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 28 71 -key). (let ((q
3aa0: 75 65 72 79 20 22 53 45 4c 45 43 54 20 69 64 20 uery "SELECT id
3ab0: 46 52 4f 4d 20 73 65 73 73 69 6f 6e 73 20 57 48 FROM sessions WH
3ac0: 45 52 45 20 73 65 73 73 69 6f 6e 5f 6b 65 79 3d ERE session_key=
3ad0: 3f 3b 22 29 0a 20 20 20 20 20 20 20 20 28 72 65 ?;"). (re
3ae0: 73 75 6c 74 20 23 66 29 29 0a 20 20 20 20 3b 3b sult #f)). ;;
3af0: 20 20 20 20 20 28 70 67 3a 71 75 65 72 79 2d 66 (pg:query-f
3b00: 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 or-each (lambda
3b10: 28 74 75 70 6c 65 29 0a 20 20 20 20 3b 3b 20 20 (tuple). ;;
3b20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3b30: 20 20 20 20 20 20 20 20 28 73 65 74 21 20 72 65 (set! re
3b40: 73 75 6c 74 20 28 76 65 63 74 6f 72 2d 72 65 66 sult (vector-ref
3b50: 20 74 75 70 6c 65 20 30 29 29 29 20 3b 3b 20 28 tuple 0))) ;; (
3b60: 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 vector-ref tuple
3b70: 20 30 29 29 29 0a 20 20 20 20 3b 3b 20 20 20 20 0))). ;;
3b80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3b90: 20 20 20 20 28 73 3a 73 71 6c 70 61 72 61 6d 20 (s:sqlparam
3ba0: 71 75 65 72 79 20 73 65 73 73 69 6f 6e 2d 6b 65 query session-ke
3bb0: 79 29 0a 20 20 20 20 3b 3b 20 20 20 20 20 20 20 y). ;;
3bc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3bd0: 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 (sdat-get-conn
3be0: 73 65 6c 66 29 29 0a 20 20 20 20 3b 3b 20 20 20 self)). ;;
3bf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3c00: 20 20 20 20 20 63 6f 6e 6e 29 0a 20 20 20 20 28 conn). (
3c10: 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 dbi:for-each-row
3c20: 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 29 (lambda (tuple)
3c30: 0a 09 09 09 28 73 65 74 21 20 72 65 73 75 6c 74 ....(set! result
3c40: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 (vector-ref tup
3c50: 6c 65 20 30 29 29 29 20 3b 3b 20 28 76 65 63 74 le 0))) ;; (vect
3c60: 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 30 29 29 or-ref tuple 0))
3c70: 29 0a 09 09 20 20 20 20 20 20 28 73 64 61 74 2d )... (sdat-
3c80: 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 0a 09 get-conn self)..
3c90: 09 20 20 20 20 20 20 28 73 3a 73 71 6c 70 61 72 . (s:sqlpar
3ca0: 61 6d 20 71 75 65 72 79 20 73 65 73 73 69 6f 6e am query session
3cb0: 2d 6b 65 79 29 29 0a 20 20 20 20 72 65 73 75 6c -key)). resul
3cc0: 74 29 29 0a 0a 3b 3b 20 64 65 6c 65 74 65 20 61 t))..;; delete a
3cd0: 6c 6c 20 72 65 63 6f 72 64 73 20 66 6f 72 20 61 ll records for a
3ce0: 20 73 65 73 73 69 6f 6e 0a 3b 3b 20 0a 3b 3b 20 session.;; .;;
3cf0: 4e 45 45 44 53 20 54 4f 20 42 45 20 54 52 41 4e NEEDS TO BE TRAN
3d00: 53 41 43 54 49 4f 4e 49 5a 45 44 21 0a 3b 3b 0a SACTIONIZED!.;;.
3d10: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
3d20: 3a 64 65 6c 65 74 65 2d 73 65 73 73 69 6f 6e 20 :delete-session
3d30: 73 65 6c 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 self session-key
3d40: 29 0a 20 20 28 6c 65 74 20 28 28 73 65 73 73 69 ). (let ((sessi
3d50: 6f 6e 2d 69 64 20 28 73 65 73 73 69 6f 6e 3a 67 on-id (session:g
3d60: 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 et-session-id se
3d70: 6c 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 lf session-key))
3d80: 0a 20 20 20 20 20 20 20 20 28 71 72 79 31 20 20 . (qry1
3d90: 20 20 20 20 20 20 3b 3b 20 28 63 6f 6e 63 20 22 ;; (conc "
3da0: 42 45 47 49 4e 3b 22 0a 09 09 09 20 20 22 44 45 BEGIN;".... "DE
3db0: 4c 45 54 45 20 46 52 4f 4d 20 73 65 73 73 69 6f LETE FROM sessio
3dc0: 6e 5f 76 61 72 73 20 57 48 45 52 45 20 73 65 73 n_vars WHERE ses
3dd0: 73 69 6f 6e 5f 69 64 3d 3f 3b 22 29 0a 09 28 71 sion_id=?;")..(q
3de0: 72 79 32 20 20 20 20 20 20 20 20 20 20 20 20 20 ry2
3df0: 22 44 45 4c 45 54 45 20 46 52 4f 4d 20 73 65 73 "DELETE FROM ses
3e00: 73 69 6f 6e 73 20 57 48 45 52 45 20 69 64 3d 3f sions WHERE id=?
3e10: 3b 22 29 0a 09 09 20 20 20 20 20 3b 3b 20 20 22 ;")... ;; "
3e20: 43 4f 4d 4d 49 54 3b 22 29 29 0a 20 20 20 20 20 COMMIT;")).
3e30: 20 20 20 28 63 6f 6e 6e 20 20 20 20 20 20 20 20 (conn
3e40: 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d (sdat-get-
3e50: 63 6f 6e 6e 20 73 65 6c 66 29 29 29 0a 20 20 20 conn self))).
3e60: 20 28 69 66 20 73 65 73 73 69 6f 6e 2d 69 64 0a (if session-id.
3e70: 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 (begin.
3e80: 20 20 20 20 20 20 20 20 20 28 64 62 69 3a 65 78 (dbi:ex
3e90: 65 63 20 63 6f 6e 6e 20 71 72 79 31 20 73 65 73 ec conn qry1 ses
3ea0: 73 69 6f 6e 2d 69 64 29 20 3b 3b 20 73 65 73 73 sion-id) ;; sess
3eb0: 69 6f 6e 2d 69 64 29 0a 09 20 20 28 64 62 69 3a ion-id).. (dbi:
3ec0: 65 78 65 63 20 63 6f 6e 6e 20 71 72 79 32 20 73 exec conn qry2 s
3ed0: 65 73 73 69 6f 6e 2d 69 64 29 0a 09 20 20 28 73 ession-id).. (s
3ee0: 65 73 73 69 6f 6e 3a 69 6e 69 74 69 61 6c 69 7a ession:initializ
3ef0: 65 20 73 65 6c 66 29 0a 09 20 20 28 73 65 73 73 e self).. (sess
3f00: 69 6f 6e 3a 73 65 74 75 70 20 73 65 6c 66 29 29 ion:setup self))
3f10: 29 0a 20 20 20 20 28 6e 6f 74 20 28 73 65 73 73 ). (not (sess
3f20: 69 6f 6e 3a 67 65 74 2d 73 65 73 73 69 6f 6e 2d ion:get-session-
3f30: 69 64 20 73 65 6c 66 20 73 65 73 73 69 6f 6e 2d id self session-
3f40: 6b 65 79 29 29 29 29 0a 0a 3b 3b 20 28 64 65 66 key))))..;; (def
3f50: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 64 65 6c ine (session:del
3f60: 65 74 65 2d 73 65 73 73 69 6f 6e 20 73 65 6c 66 ete-session self
3f70: 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 0a 3b 3b session-key).;;
3f80: 20 20 20 28 6c 65 74 20 28 28 73 65 73 73 69 6f (let ((sessio
3f90: 6e 2d 69 64 20 28 73 65 73 73 69 6f 6e 3a 67 65 n-id (session:ge
3fa0: 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c t-session-id sel
3fb0: 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 0a f session-key)).
3fc0: 3b 3b 20 20 20 20 20 20 20 20 20 28 71 75 65 72 ;; (quer
3fd0: 69 65 73 20 20 20 20 28 6c 69 73 74 20 22 42 45 ies (list "BE
3fe0: 47 49 4e 3b 22 0a 3b 3b 20 09 09 09 20 20 22 44 GIN;".;; ... "D
3ff0: 45 4c 45 54 45 20 46 52 4f 4d 20 73 65 73 73 69 ELETE FROM sessi
4000: 6f 6e 5f 76 61 72 73 20 57 48 45 52 45 20 73 65 on_vars WHERE se
4010: 73 73 69 6f 6e 5f 69 64 3d 3f 3b 22 0a 3b 3b 20 ssion_id=?;".;;
4020: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4030: 20 20 20 20 20 20 20 20 20 20 22 44 45 4c 45 54 "DELET
4040: 45 20 46 52 4f 4d 20 73 65 73 73 69 6f 6e 73 20 E FROM sessions
4050: 57 48 45 52 45 20 69 64 3d 3f 3b 22 0a 3b 3b 20 WHERE id=?;".;;
4060: 09 09 09 20 20 22 43 4f 4d 4d 49 54 3b 22 29 29 ... "COMMIT;"))
4070: 0a 3b 3b 20 20 20 20 20 20 20 20 20 28 63 6f 6e .;; (con
4080: 6e 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 n (
4090: 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 sdat-get-conn se
40a0: 6c 66 29 29 29 0a 3b 3b 20 20 20 20 20 28 69 66 lf))).;; (if
40b0: 20 73 65 73 73 69 6f 6e 2d 69 64 0a 3b 3b 20 20 session-id.;;
40c0: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 3b 3b (begin.;;
40d0: 20 20 20 20 20 20 20 20 20 20 20 28 66 6f 72 2d (for-
40e0: 65 61 63 68 0a 3b 3b 20 20 20 20 20 20 20 20 20 each.;;
40f0: 20 20 20 28 6c 61 6d 62 64 61 20 28 71 75 65 72 (lambda (quer
4100: 79 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 y).;;
4110: 20 20 20 28 64 62 69 3a 65 78 65 63 20 63 6f 6e (dbi:exec con
4120: 6e 20 71 75 65 72 79 20 73 65 73 73 69 6f 6e 2d n query session-
4130: 69 64 29 29 0a 3b 3b 20 09 20 20 20 71 75 65 72 id)).;; . quer
4140: 69 65 73 29 0a 3b 3b 20 09 20 20 28 69 6e 69 74 ies).;; . (init
4150: 69 61 6c 69 7a 65 20 73 65 6c 66 20 27 28 29 29 ialize self '())
4160: 0a 3b 3b 20 09 20 20 28 73 65 73 73 69 6f 6e 3a .;; . (session:
4170: 73 65 74 75 70 20 73 65 6c 66 29 29 29 0a 3b 3b setup self))).;;
4180: 20 20 20 20 20 28 6e 6f 74 20 28 73 65 73 73 69 (not (sessi
4190: 6f 6e 3a 67 65 74 2d 73 65 73 73 69 6f 6e 2d 69 on:get-session-i
41a0: 64 20 73 65 6c 66 20 73 65 73 73 69 6f 6e 2d 6b d self session-k
41b0: 65 79 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ey))))..(define
41c0: 28 73 65 73 73 69 6f 6e 3a 65 78 74 72 61 63 74 (session:extract
41d0: 2d 6b 65 79 20 73 65 6c 66 20 6b 65 79 29 0a 20 -key self key).
41e0: 20 28 6c 65 74 20 28 28 70 61 72 61 6d 73 20 28 (let ((params (
41f0: 73 64 61 74 2d 67 65 74 2d 70 61 72 61 6d 73 20 sdat-get-params
4200: 73 65 6c 66 29 29 29 0a 20 20 20 20 28 73 65 73 self))). (ses
4210: 73 69 6f 6e 3a 65 78 74 72 61 63 74 2d 6b 65 79 sion:extract-key
4220: 2d 66 72 6f 6d 2d 70 61 72 61 6d 20 73 65 6c 66 -from-param self
4230: 20 70 61 72 61 6d 73 20 6b 65 79 29 29 29 0a 0a params key)))..
4240: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
4250: 3a 65 78 74 72 61 63 74 2d 6b 65 79 2d 66 72 6f :extract-key-fro
4260: 6d 2d 70 61 72 61 6d 20 73 65 6c 66 20 70 61 72 m-param self par
4270: 61 6d 73 20 6b 65 79 29 0a 20 20 28 6c 65 74 20 ams key). (let
4280: 28 28 72 31 20 20 20 20 20 28 72 65 67 65 78 70 ((r1 (regexp
4290: 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 (string-append
42a0: 22 5e 22 20 6b 65 79 20 22 3d 28 5b 5e 3d 5d 2b "^" key "=([^=]+
42b0: 29 24 22 29 29 29 29 0a 20 20 20 20 28 65 72 72 )$")))). (err
42c0: 3a 6c 6f 67 20 22 49 4e 46 4f 3a 20 4c 6f 6f 6b :log "INFO: Look
42d0: 69 6e 67 20 66 6f 72 20 22 20 6b 65 79 20 22 20 ing for " key "
42e0: 69 6e 20 22 20 70 61 72 61 6d 73 29 0a 20 20 20 in " params).
42f0: 20 28 69 66 20 28 3c 20 28 6c 65 6e 67 74 68 20 (if (< (length
4300: 70 61 72 61 6d 73 29 20 31 29 20 23 66 0a 09 28 params) 1) #f..(
4310: 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 61 64 20 let loop ((head
4320: 20 20 28 63 61 72 20 70 61 72 61 6d 73 29 29 0a (car params)).
4330: 09 09 20 20 20 28 74 61 69 6c 20 20 20 28 63 64 .. (tail (cd
4340: 72 20 70 61 72 61 6d 73 29 29 29 0a 09 20 20 28 r params))).. (
4350: 6c 65 74 20 28 28 6d 61 74 63 68 20 28 73 74 72 let ((match (str
4360: 69 6e 67 2d 6d 61 74 63 68 20 72 31 20 68 65 61 ing-match r1 hea
4370: 64 29 29 29 0a 09 20 20 20 20 28 63 6f 6e 64 0a d))).. (cond.
4380: 09 20 20 20 20 20 28 6d 61 74 63 68 0a 09 20 20 . (match..
4390: 20 20 20 20 28 6c 65 74 20 28 28 73 65 73 73 69 (let ((sessi
43a0: 6f 6e 2d 6b 65 79 20 28 6c 69 73 74 2d 72 65 66 on-key (list-ref
43b0: 20 6d 61 74 63 68 20 31 29 29 29 0a 09 09 28 65 match 1)))...(e
43c0: 72 72 3a 6c 6f 67 20 22 49 4e 46 4f 3a 20 46 6f rr:log "INFO: Fo
43d0: 75 6e 64 20 73 65 73 73 69 6f 6e 20 6b 65 79 3d und session key=
43e0: 22 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 0a 09 " session-key)..
43f0: 09 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 .(sdat-set-sessi
4400: 6f 6e 2d 6b 65 79 21 20 73 65 6c 66 20 28 6c 69 on-key! self (li
4410: 73 74 2d 72 65 66 20 6d 61 74 63 68 20 31 29 29 st-ref match 1))
4420: 0a 09 09 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 ...session-key))
4430: 0a 09 20 20 20 20 20 28 28 6e 75 6c 6c 3f 20 74 .. ((null? t
4440: 61 69 6c 29 0a 09 20 20 20 20 20 20 23 66 29 0a ail).. #f).
4450: 09 20 20 20 20 20 28 65 6c 73 65 0a 09 20 20 20 . (else..
4460: 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 (loop (car ta
4470: 69 6c 29 0a 09 09 20 20 20 20 28 63 64 72 20 74 il)... (cdr t
4480: 61 69 6c 29 29 29 29 29 29 29 29 29 0a 0a 28 64 ail)))))))))..(d
4490: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 efine (session:s
44a0: 65 74 2d 70 61 67 65 21 20 73 65 6c 66 20 70 61 et-page! self pa
44b0: 67 65 5f 6e 61 6d 65 29 0a 20 20 28 73 64 61 74 ge_name). (sdat
44c0: 2d 73 65 74 2d 70 61 67 65 21 20 73 65 6c 66 20 -set-page! self
44d0: 70 61 67 65 5f 6e 61 6d 65 29 29 0a 0a 28 64 65 page_name))..(de
44e0: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 63 6c fine (session:cl
44f0: 6f 73 65 20 73 65 6c 66 29 0a 20 20 28 64 62 69 ose self). (dbi
4500: 3a 63 6c 6f 73 65 20 28 73 64 61 74 2d 67 65 74 :close (sdat-get
4510: 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 29 0a 3b 3b -conn self))).;;
4520: 20 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 (close-output-p
4530: 6f 72 74 20 28 73 64 61 74 2d 67 65 74 2d 6c 6f ort (sdat-get-lo
4540: 67 70 74 20 73 65 6c 66 29 29 0a 0a 28 64 65 66 gpt self))..(def
4550: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 65 72 72 ine (session:err
4560: 2d 6d 73 67 20 73 65 6c 66 20 6d 73 67 29 0a 20 -msg self msg).
4570: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
4580: 21 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 ! (sdat-get-sess
4590: 69 6f 6e 76 61 72 73 20 73 65 6c 66 29 20 22 45 ionvars self) "E
45a0: 52 52 4f 52 5f 4d 53 47 22 0a 09 09 20 20 20 28 RROR_MSG"... (
45b0: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
45c0: 73 65 20 28 6d 61 70 20 73 3a 61 6e 79 2d 3e 73 se (map s:any->s
45d0: 74 72 69 6e 67 20 6d 73 67 29 20 22 20 22 29 29 tring msg) " "))
45e0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 )..(define (sess
45f0: 69 6f 6e 3a 70 72 65 76 2d 65 72 72 20 73 65 6c ion:prev-err sel
4600: 66 29 0a 20 20 28 6c 65 74 20 28 28 70 72 65 76 f). (let ((prev
4610: 2d 65 72 72 20 28 68 61 73 68 2d 74 61 62 6c 65 -err (hash-table
4620: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 28 73 64 -ref/default (sd
4630: 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 at-get-sessionva
4640: 72 73 2d 62 65 66 6f 72 65 20 73 65 6c 66 29 20 rs-before self)
4650: 22 45 52 52 4f 52 5f 4d 53 47 22 20 23 66 29 29 "ERROR_MSG" #f))
4660: 0a 09 28 63 75 72 72 2d 65 72 72 20 28 68 61 73 ..(curr-err (has
4670: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
4680: 75 6c 74 20 28 73 64 61 74 2d 67 65 74 2d 73 65 ult (sdat-get-se
4690: 73 73 69 6f 6e 76 61 72 73 20 73 65 6c 66 29 20 ssionvars self)
46a0: 22 45 52 52 4f 52 5f 4d 53 47 22 20 23 66 29 29 "ERROR_MSG" #f))
46b0: 29 0a 20 20 20 20 28 69 66 20 70 72 65 76 2d 65 ). (if prev-e
46c0: 72 72 20 70 72 65 76 2d 65 72 72 0a 09 28 69 66 rr prev-err..(if
46d0: 20 63 75 72 72 2d 65 72 72 20 63 75 72 72 2d 65 curr-err curr-e
46e0: 72 72 20 23 66 29 29 29 29 0a 0a 3b 3b 20 73 65 rr #f))))..;; se
46f0: 73 73 69 6f 6e 20 76 61 72 73 0a 3b 3b 20 31 2e ssion vars.;; 1.
4700: 20 6b 65 79 73 20 61 72 65 20 61 6c 77 61 79 73 keys are always
4710: 20 61 20 73 74 72 69 6e 67 20 4e 4f 54 20 61 20 a string NOT a
4720: 73 79 6d 62 6f 6c 0a 3b 3b 20 32 2e 20 76 61 6c symbol.;; 2. val
4730: 75 65 73 20 61 72 65 20 61 6c 77 61 79 73 20 61 ues are always a
4740: 20 73 74 72 69 6e 67 20 63 6f 6e 76 65 72 73 69 string conversi
4750: 6f 6e 20 69 73 20 74 68 65 20 72 65 73 70 6f 6e on is the respon
4760: 73 69 62 69 6c 69 74 79 20 6f 66 20 74 68 65 20 sibility of the
4770: 0a 3b 3b 20 20 20 20 63 6f 6e 73 75 6d 69 6e 67 .;; consuming
4780: 20 66 75 6e 63 74 69 6f 6e 20 28 61 74 20 6c 65 function (at le
4790: 61 73 74 20 66 6f 72 20 6e 6f 77 2c 20 49 27 64 ast for now, I'd
47a0: 20 6c 69 6b 65 20 74 6f 20 63 68 61 6e 67 65 20 like to change
47b0: 74 68 69 73 29 0a 0a 3b 3b 20 73 65 74 20 61 20 this)..;; set a
47c0: 73 65 73 73 69 6f 6e 20 76 61 72 20 66 6f 72 20 session var for
47d0: 74 68 65 20 63 75 72 72 65 6e 74 20 70 61 67 65 the current page
47e0: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 73 .;;.(define (ses
47f0: 73 69 6f 6e 3a 63 75 72 72 2d 70 61 67 65 2d 73 sion:curr-page-s
4800: 65 74 21 20 73 65 6c 66 20 6b 65 79 20 76 61 6c et! self key val
4810: 75 65 29 0a 20 20 28 68 61 73 68 2d 74 61 62 6c ue). (hash-tabl
4820: 65 2d 73 65 74 21 20 28 73 64 61 74 2d 67 65 74 e-set! (sdat-get
4830: 2d 70 61 67 65 76 61 72 73 20 73 65 6c 66 29 20 -pagevars self)
4840: 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6b (s:any->string k
4850: 65 79 29 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 ey) (s:any->stri
4860: 6e 67 20 76 61 6c 75 65 29 29 29 0a 0a 3b 3b 20 ng value)))..;;
4870: 64 65 6c 20 61 20 76 61 72 20 66 6f 72 20 74 68 del a var for th
4880: 65 20 63 75 72 72 65 6e 74 20 70 61 67 65 0a 3b e current page.;
4890: 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ;.(define (sessi
48a0: 6f 6e 3a 70 61 67 65 2d 76 61 72 2d 64 65 6c 21 on:page-var-del!
48b0: 20 73 65 6c 66 20 6b 65 79 29 0a 20 20 28 68 61 self key). (ha
48c0: 73 68 2d 74 61 62 6c 65 2d 64 65 6c 65 74 65 21 sh-table-delete!
48d0: 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 76 (sdat-get-pagev
48e0: 61 72 73 20 73 65 6c 66 29 20 28 73 3a 61 6e 79 ars self) (s:any
48f0: 2d 3e 73 74 72 69 6e 67 20 6b 65 79 29 29 29 0a ->string key))).
4900: 0a 3b 3b 20 67 65 74 20 74 68 65 20 61 70 70 72 .;; get the appr
4910: 6f 70 72 69 61 74 65 20 68 61 73 68 20 67 69 76 opriate hash giv
4920: 65 6e 20 61 20 70 61 67 65 20 22 2a 73 65 73 73 en a page "*sess
4930: 69 6f 6e 76 61 72 73 2a 2c 20 2a 67 6c 6f 62 61 ionvars*, *globa
4940: 6c 76 61 72 73 2a 20 6f 72 20 70 61 67 65 0a 3b lvars* or page.;
4950: 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ;.(define (sessi
4960: 6f 6e 3a 67 65 74 2d 70 61 67 65 2d 68 61 73 68 on:get-page-hash
4970: 20 73 65 6c 66 20 70 61 67 65 29 0a 20 20 28 69 self page). (i
4980: 66 20 28 73 74 72 69 6e 67 3d 3f 20 70 61 67 65 f (string=? page
4990: 20 22 2a 73 65 73 73 69 6f 6e 76 61 72 73 2a 22 "*sessionvars*"
49a0: 29 0a 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 ). (sdat-ge
49b0: 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 20 73 65 t-sessionvars se
49c0: 6c 66 29 0a 20 20 20 20 20 20 28 69 66 20 28 73 lf). (if (s
49d0: 74 72 69 6e 67 3d 3f 20 70 61 67 65 20 22 2a 67 tring=? page "*g
49e0: 6c 6f 62 61 6c 76 61 72 73 2a 22 29 0a 09 20 20 lobalvars*")..
49f0: 28 73 64 61 74 2d 67 65 74 2d 67 6c 6f 62 61 6c (sdat-get-global
4a00: 76 61 72 73 20 73 65 6c 66 29 0a 09 20 20 28 73 vars self).. (s
4a10: 64 61 74 2d 67 65 74 2d 70 61 67 65 76 61 72 73 dat-get-pagevars
4a20: 20 73 65 6c 66 29 29 29 29 0a 0a 3b 3b 20 73 65 self))))..;; se
4a30: 74 20 61 20 73 65 73 73 69 6f 6e 20 76 61 72 20 t a session var
4a40: 66 6f 72 20 61 20 67 69 76 65 6e 20 70 61 67 65 for a given page
4a50: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 73 .;;.(define (ses
4a60: 73 69 6f 6e 3a 73 65 74 21 20 73 65 6c 66 20 70 sion:set! self p
4a70: 61 67 65 20 6b 65 79 20 76 61 6c 75 65 29 0a 20 age key value).
4a80: 20 28 6c 65 74 20 28 28 68 74 20 28 73 65 73 73 (let ((ht (sess
4a90: 69 6f 6e 3a 67 65 74 2d 70 61 67 65 2d 68 61 73 ion:get-page-has
4aa0: 68 20 73 65 6c 66 20 70 61 67 65 29 29 29 0a 20 h self page))).
4ab0: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 (hash-table-s
4ac0: 65 74 21 20 68 74 20 28 73 3a 61 6e 79 2d 3e 73 et! ht (s:any->s
4ad0: 74 72 69 6e 67 20 6b 65 79 29 20 28 73 3a 61 6e tring key) (s:an
4ae0: 79 2d 3e 73 74 72 69 6e 67 20 76 61 6c 75 65 29 y->string value)
4af0: 29 29 29 0a 0a 3b 3b 20 67 65 74 20 73 65 73 73 )))..;; get sess
4b00: 69 6f 6e 20 76 61 72 73 20 66 6f 72 20 74 68 65 ion vars for the
4b10: 20 63 75 72 72 65 6e 74 20 70 61 67 65 0a 3b 3b current page.;;
4b20: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
4b30: 6e 3a 70 61 67 65 2d 67 65 74 20 73 65 6c 66 20 n:page-get self
4b40: 6b 65 79 29 0a 20 20 28 68 61 73 68 2d 74 61 62 key). (hash-tab
4b50: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 28 le-ref/default (
4b60: 73 64 61 74 2d 67 65 74 2d 70 61 67 65 76 61 72 sdat-get-pagevar
4b70: 73 20 73 65 6c 66 29 20 6b 65 79 20 23 66 29 29 s self) key #f))
4b80: 0a 0a 3b 3b 20 67 65 74 20 73 65 73 73 69 6f 6e ..;; get session
4b90: 20 76 61 72 73 20 66 6f 72 20 61 20 73 70 65 63 vars for a spec
4ba0: 69 66 69 65 64 20 70 61 67 65 0a 3b 3b 0a 28 64 ified page.;;.(d
4bb0: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 efine (session:g
4bc0: 65 74 20 73 65 6c 66 20 70 61 67 65 20 6b 65 79 et self page key
4bd0: 29 0a 20 20 28 6c 65 74 20 28 28 68 74 20 28 73 ). (let ((ht (s
4be0: 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 67 65 2d ession:get-page-
4bf0: 68 61 73 68 20 73 65 6c 66 20 70 61 67 65 29 29 hash self page))
4c00: 29 0a 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c ). (hash-tabl
4c10: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 68 74 e-ref/default ht
4c20: 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 (s:any->string
4c30: 6b 65 79 29 20 23 66 29 29 29 0a 0a 3b 3b 20 64 key) #f)))..;; d
4c40: 65 6c 65 74 65 20 61 20 73 65 73 73 69 6f 6e 20 elete a session
4c50: 76 61 72 20 66 6f 72 20 61 20 73 70 65 63 69 66 var for a specif
4c60: 69 65 64 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 ied page.;;.(def
4c70: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 64 65 6c ine (session:del
4c80: 21 20 73 65 6c 66 20 70 61 67 65 20 6b 65 79 29 ! self page key)
4c90: 0a 20 20 28 6c 65 74 20 28 28 68 74 20 28 73 65 . (let ((ht (se
4ca0: 73 73 69 6f 6e 3a 67 65 74 2d 70 61 67 65 2d 68 ssion:get-page-h
4cb0: 61 73 68 20 73 65 6c 66 20 70 61 67 65 29 29 29 ash self page)))
4cc0: 0a 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 . (hash-table
4cd0: 2d 64 65 6c 65 74 65 21 20 68 74 20 28 73 3a 61 -delete! ht (s:a
4ce0: 6e 79 2d 3e 73 74 72 69 6e 67 20 6b 65 79 29 29 ny->string key))
4cf0: 29 29 0a 0a 3b 3b 20 67 65 74 20 41 4c 4c 20 6b ))..;; get ALL k
4d00: 65 79 73 20 66 6f 72 20 74 68 69 73 20 70 61 67 eys for this pag
4d10: 65 20 61 6e 64 20 73 74 6f 72 65 20 69 6e 20 74 e and store in t
4d20: 68 65 20 73 65 73 73 69 6f 6e 20 70 61 67 65 76 he session pagev
4d30: 61 72 73 20 68 61 73 68 0a 3b 3b 0a 28 64 65 66 ars hash.;;.(def
4d40: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 ine (session:get
4d50: 2d 76 61 72 73 20 73 65 6c 66 29 0a 20 20 28 6c -vars self). (l
4d60: 65 74 20 28 28 73 65 73 73 69 6f 6e 2d 69 64 20 et ((session-id
4d70: 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 (sdat-get-sessi
4d80: 6f 6e 2d 69 64 20 73 65 6c 66 29 29 29 0a 20 20 on-id self))).
4d90: 20 20 28 69 66 20 28 6e 6f 74 20 73 65 73 73 69 (if (not sessi
4da0: 6f 6e 2d 69 64 29 0a 09 28 65 72 72 3a 6c 6f 67 on-id)..(err:log
4db0: 20 22 45 52 52 4f 52 3a 20 4e 6f 20 73 65 73 73 "ERROR: No sess
4dc0: 69 6f 6e 20 69 64 20 69 6e 20 73 65 73 73 69 6f ion id in sessio
4dd0: 6e 20 6f 62 6a 65 63 74 21 20 73 65 73 73 69 6f n object! sessio
4de0: 6e 3a 67 65 74 2d 76 61 72 73 22 29 0a 09 28 6c n:get-vars")..(l
4df0: 65 74 2a 20 28 28 72 65 73 75 6c 74 20 20 20 20 et* ((result
4e00: 20 20 20 20 20 20 20 20 20 23 66 29 0a 09 20 20 #f)..
4e10: 20 20 20 20 20 28 63 6f 6e 6e 20 20 20 20 20 20 (conn
4e20: 20 20 20 20 20 20 20 20 20 28 73 64 61 74 2d 67 (sdat-g
4e30: 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 0a 09 et-conn self))..
4e40: 20 20 20 20 20 20 20 28 70 61 67 65 76 61 72 73 (pagevars
4e50: 2d 62 65 66 6f 72 65 20 20 20 20 28 73 64 61 74 -before (sdat
4e60: 2d 67 65 74 2d 70 61 67 65 76 61 72 73 2d 62 65 -get-pagevars-be
4e70: 66 6f 72 65 20 73 65 6c 66 29 29 0a 09 20 20 20 fore self))..
4e80: 20 20 20 20 28 73 65 73 73 69 6f 6e 76 61 72 73 (sessionvars
4e90: 2d 62 65 66 6f 72 65 20 28 73 64 61 74 2d 67 65 -before (sdat-ge
4ea0: 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 t-sessionvars-be
4eb0: 66 6f 72 65 20 73 65 6c 66 29 29 0a 09 20 20 20 fore self))..
4ec0: 20 20 20 20 28 67 6c 6f 62 61 6c 76 61 72 73 2d (globalvars-
4ed0: 62 65 66 6f 72 65 20 20 28 73 64 61 74 2d 67 65 before (sdat-ge
4ee0: 74 2d 67 6c 6f 62 61 6c 76 61 72 73 2d 62 65 66 t-globalvars-bef
4ef0: 6f 72 65 20 73 65 6c 66 29 29 0a 09 20 20 20 20 ore self))..
4f00: 20 20 20 28 70 61 67 65 76 61 72 73 20 20 20 20 (pagevars
4f10: 20 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 (sdat-get
4f20: 2d 70 61 67 65 76 61 72 73 20 73 65 6c 66 29 29 -pagevars self))
4f30: 0a 09 20 20 20 20 20 20 20 28 73 65 73 73 69 6f .. (sessio
4f40: 6e 76 61 72 73 20 20 20 20 20 20 20 20 28 73 64 nvars (sd
4f50: 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 at-get-sessionva
4f60: 72 73 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 rs self))..
4f70: 20 20 28 67 6c 6f 62 61 6c 76 61 72 73 20 20 20 (globalvars
4f80: 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d (sdat-get-
4f90: 67 6c 6f 62 61 6c 76 61 72 73 20 73 65 6c 66 29 globalvars self)
4fa0: 29 0a 09 20 20 20 20 20 20 20 28 70 61 67 65 2d ).. (page-
4fb0: 6e 61 6d 65 20 20 20 20 20 20 20 20 20 20 28 73 name (s
4fc0: 64 61 74 2d 67 65 74 2d 70 61 67 65 20 73 65 6c dat-get-page sel
4fd0: 66 29 29 0a 09 20 20 20 20 20 20 20 28 73 65 73 f)).. (ses
4fe0: 73 69 6f 6e 2d 6b 65 79 20 20 20 20 20 20 20 20 sion-key
4ff0: 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f (sdat-get-sessio
5000: 6e 2d 6b 65 79 20 73 65 6c 66 29 29 0a 09 20 20 n-key self))..
5010: 20 20 20 20 20 28 71 75 65 72 79 20 20 20 20 20 (query
5020: 20 20 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 (string
5030: 2d 61 70 70 65 6e 64 0a 09 09 09 09 20 20 20 20 -append.....
5040: 22 53 45 4c 45 43 54 20 6b 65 79 2c 76 61 6c 75 "SELECT key,valu
5050: 65 20 46 52 4f 4d 20 73 65 73 73 69 6f 6e 5f 76 e FROM session_v
5060: 61 72 73 20 49 4e 4e 45 52 20 4a 4f 49 4e 20 73 ars INNER JOIN s
5070: 65 73 73 69 6f 6e 73 20 4f 4e 20 73 65 73 73 69 essions ON sessi
5080: 6f 6e 5f 76 61 72 73 2e 73 65 73 73 69 6f 6e 5f on_vars.session_
5090: 69 64 3d 73 65 73 73 69 6f 6e 73 2e 69 64 20 22 id=sessions.id "
50a0: 0a 09 09 09 09 20 20 20 20 22 57 48 45 52 45 20 ..... "WHERE
50b0: 73 65 73 73 69 6f 6e 5f 6b 65 79 3d 3f 20 41 4e session_key=? AN
50c0: 44 20 70 61 67 65 3d 3f 3b 22 29 29 29 0a 09 20 D page=?;")))..
50d0: 20 3b 3b 20 66 69 72 73 74 20 74 68 65 20 70 61 ;; first the pa
50e0: 67 65 20 73 70 65 63 69 66 69 63 20 76 61 72 73 ge specific vars
50f0: 0a 09 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 .. (dbi:for-eac
5100: 68 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 h-row (lambda (t
5110: 75 70 6c 65 29 0a 09 09 09 20 20 20 20 20 20 28 uple).... (
5120: 6c 65 74 20 28 28 6b 20 28 76 65 63 74 6f 72 2d let ((k (vector-
5130: 72 65 66 20 74 75 70 6c 65 20 30 29 29 0a 09 09 ref tuple 0))...
5140: 09 09 20 20 20 20 28 76 20 28 76 65 63 74 6f 72 .. (v (vector
5150: 2d 72 65 66 20 74 75 70 6c 65 20 31 29 29 29 0a -ref tuple 1))).
5160: 09 09 09 09 28 68 61 73 68 2d 74 61 62 6c 65 2d ....(hash-table-
5170: 73 65 74 21 20 70 61 67 65 76 61 72 73 2d 62 65 set! pagevars-be
5180: 66 6f 72 65 20 6b 20 76 29 0a 09 09 09 09 28 68 fore k v).....(h
5190: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 70 ash-table-set! p
51a0: 61 67 65 76 61 72 73 20 20 20 20 20 20 20 20 6b agevars k
51b0: 20 76 29 29 29 0a 09 09 09 20 20 20 20 63 6f 6e v))).... con
51c0: 6e 0a 09 09 09 20 20 20 20 28 73 3a 73 71 6c 70 n.... (s:sqlp
51d0: 61 72 61 6d 20 71 75 65 72 79 20 73 65 73 73 69 aram query sessi
51e0: 6f 6e 2d 6b 65 79 20 70 61 67 65 2d 6e 61 6d 65 on-key page-name
51f0: 29 29 0a 09 20 20 3b 3b 20 74 68 65 6e 20 74 68 )).. ;; then th
5200: 65 20 73 65 73 73 69 6f 6e 20 73 70 65 63 69 66 e session specif
5210: 69 63 20 76 61 72 73 0a 09 20 20 28 64 62 69 3a ic vars.. (dbi:
5220: 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 for-each-row (la
5230: 6d 62 64 61 20 28 74 75 70 6c 65 29 0a 09 09 09 mbda (tuple)....
5240: 20 20 20 20 20 20 28 6c 65 74 20 28 28 6b 20 28 (let ((k (
5250: 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 vector-ref tuple
5260: 20 30 29 29 0a 09 09 09 09 20 20 20 20 28 76 20 0))..... (v
5270: 28 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c (vector-ref tupl
5280: 65 20 31 29 29 29 0a 09 09 09 09 28 68 61 73 68 e 1))).....(hash
5290: 2d 74 61 62 6c 65 2d 73 65 74 21 20 73 65 73 73 -table-set! sess
52a0: 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 20 6b ionvars-before k
52b0: 20 76 29 0a 09 09 09 09 28 68 61 73 68 2d 74 61 v).....(hash-ta
52c0: 62 6c 65 2d 73 65 74 21 20 73 65 73 73 69 6f 6e ble-set! session
52d0: 76 61 72 73 20 20 20 20 20 20 20 20 6b 20 76 29 vars k v)
52e0: 29 29 0a 09 09 09 20 20 20 20 63 6f 6e 6e 0a 09 )).... conn..
52f0: 09 09 20 20 20 20 28 73 3a 73 71 6c 70 61 72 61 .. (s:sqlpara
5300: 6d 20 71 75 65 72 79 20 73 65 73 73 69 6f 6e 2d m query session-
5310: 6b 65 79 20 22 2a 73 65 73 73 69 6f 6e 76 61 72 key "*sessionvar
5320: 73 2a 22 29 29 0a 09 20 20 3b 3b 20 61 6e 64 20 s*")).. ;; and
5330: 66 69 6e 61 6c 6c 79 20 74 68 65 20 67 6c 6f 62 finally the glob
5340: 61 6c 20 76 61 72 73 0a 09 20 20 28 64 62 69 3a al vars.. (dbi:
5350: 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 for-each-row (la
5360: 6d 62 64 61 20 28 74 75 70 6c 65 29 0a 09 09 09 mbda (tuple)....
5370: 20 20 20 20 20 20 28 6c 65 74 20 28 28 6b 20 28 (let ((k (
5380: 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 vector-ref tuple
5390: 20 30 29 29 0a 09 09 09 09 20 20 20 20 28 76 20 0))..... (v
53a0: 28 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c (vector-ref tupl
53b0: 65 20 31 29 29 29 0a 09 09 09 09 28 68 61 73 68 e 1))).....(hash
53c0: 2d 74 61 62 6c 65 2d 73 65 74 21 20 67 6c 6f 62 -table-set! glob
53d0: 61 6c 76 61 72 73 2d 62 65 66 6f 72 65 20 6b 20 alvars-before k
53e0: 76 29 0a 09 09 09 09 28 68 61 73 68 2d 74 61 62 v).....(hash-tab
53f0: 6c 65 2d 73 65 74 21 20 67 6c 6f 62 61 6c 76 61 le-set! globalva
5400: 72 73 20 20 20 20 20 20 20 20 6b 20 76 29 29 29 rs k v)))
5410: 0a 09 09 09 20 20 20 20 63 6f 6e 6e 0a 09 09 09 .... conn....
5420: 20 20 20 20 28 73 3a 73 71 6c 70 61 72 61 6d 20 (s:sqlparam
5430: 71 75 65 72 79 20 73 65 73 73 69 6f 6e 2d 6b 65 query session-ke
5440: 79 20 22 2a 67 6c 6f 62 61 6c 76 61 72 73 22 29 y "*globalvars")
5450: 29 0a 09 20 20 29 29 29 29 0a 0a 28 64 65 66 69 ).. ))))..(defi
5460: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 61 76 65 ne (session:save
5470: 2d 76 61 72 73 20 73 65 6c 66 29 0a 20 20 28 6c -vars self). (l
5480: 65 74 20 28 28 73 65 73 73 69 6f 6e 2d 69 64 20 et ((session-id
5490: 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 (sdat-get-sessi
54a0: 6f 6e 2d 69 64 20 73 65 6c 66 29 29 29 0a 20 20 on-id self))).
54b0: 20 20 28 69 66 20 28 6e 6f 74 20 73 65 73 73 69 (if (not sessi
54c0: 6f 6e 2d 69 64 29 0a 09 28 65 72 72 3a 6c 6f 67 on-id)..(err:log
54d0: 20 22 45 52 52 4f 52 3a 20 4e 6f 20 73 65 73 73 "ERROR: No sess
54e0: 69 6f 6e 20 69 64 20 69 6e 20 73 65 73 73 69 6f ion id in sessio
54f0: 6e 20 6f 62 6a 65 63 74 21 20 73 65 73 73 69 6f n object! sessio
5500: 6e 3a 67 65 74 2d 76 61 72 73 22 29 0a 09 28 6c n:get-vars")..(l
5510: 65 74 2a 20 28 28 73 74 61 74 75 73 20 20 20 20 et* ((status
5520: 20 20 23 66 29 0a 09 20 20 20 20 20 20 20 28 63 #f).. (c
5530: 6f 6e 6e 20 20 20 20 20 20 20 20 28 73 64 61 74 onn (sdat
5540: 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 -get-conn self))
5550: 0a 09 20 20 20 20 20 20 20 28 70 61 67 65 2d 6e .. (page-n
5560: 61 6d 65 20 20 20 28 73 64 61 74 2d 67 65 74 2d ame (sdat-get-
5570: 70 61 67 65 20 73 65 6c 66 29 29 0a 09 20 20 20 page self))..
5580: 20 20 20 20 28 64 65 6c 2d 71 75 65 72 79 20 20 (del-query
5590: 20 22 44 45 4c 45 54 45 20 46 52 4f 4d 20 73 65 "DELETE FROM se
55a0: 73 73 69 6f 6e 5f 76 61 72 73 20 57 48 45 52 45 ssion_vars WHERE
55b0: 20 73 65 73 73 69 6f 6e 5f 69 64 3d 3f 20 41 4e session_id=? AN
55c0: 44 20 70 61 67 65 3d 3f 20 41 4e 44 20 6b 65 79 D page=? AND key
55d0: 3d 3f 3b 22 29 0a 09 20 20 20 20 20 20 20 28 69 =?;").. (i
55e0: 6e 73 2d 71 75 65 72 79 20 20 20 22 49 4e 53 45 ns-query "INSE
55f0: 52 54 20 49 4e 54 4f 20 73 65 73 73 69 6f 6e 5f RT INTO session_
5600: 76 61 72 73 20 28 73 65 73 73 69 6f 6e 5f 69 64 vars (session_id
5610: 2c 70 61 67 65 2c 6b 65 79 2c 76 61 6c 75 65 29 ,page,key,value)
5620: 20 56 41 4c 55 45 53 28 3f 2c 3f 2c 3f 2c 3f 29 VALUES(?,?,?,?)
5630: 3b 22 29 0a 09 20 20 20 20 20 20 20 28 75 70 64 ;").. (upd
5640: 2d 71 75 65 72 79 20 20 20 22 55 50 44 41 54 45 -query "UPDATE
5650: 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 73 65 session_vars se
5660: 74 20 76 61 6c 75 65 3d 3f 20 57 48 45 52 45 20 t value=? WHERE
5670: 6b 65 79 3d 3f 20 41 4e 44 20 73 65 73 73 69 6f key=? AND sessio
5680: 6e 5f 69 64 3d 3f 20 41 4e 44 20 70 61 67 65 3d n_id=? AND page=
5690: 3f 3b 22 29 0a 09 20 20 20 20 20 20 20 28 63 68 ?;").. (ch
56a0: 61 6e 67 65 64 2d 63 6f 75 6e 74 20 30 29 29 0a anged-count 0)).
56b0: 09 20 20 3b 3b 20 73 61 76 65 20 74 68 65 20 64 . ;; save the d
56c0: 65 6c 74 61 20 6f 6e 6c 79 0a 09 20 20 28 66 6f elta only.. (fo
56d0: 72 2d 65 61 63 68 0a 09 20 20 20 28 6c 61 6d 62 r-each.. (lamb
56e0: 64 61 20 28 70 61 67 65 29 20 3b 3b 20 70 61 67 da (page) ;; pag
56f0: 65 20 69 73 3a 20 22 2a 67 6c 6f 62 61 6c 76 61 e is: "*globalva
5700: 72 73 2a 22 20 22 2a 73 65 73 73 69 6f 6e 76 61 rs*" "*sessionva
5710: 72 73 2a 22 20 6f 72 20 6f 74 68 65 72 73 74 72 rs*" or otherstr
5720: 69 6e 67 0a 09 20 20 20 20 20 28 6c 65 74 2a 20 ing.. (let*
5730: 28 28 62 65 66 6f 72 65 2d 61 66 74 65 72 2d 68 ((before-after-h
5740: 74 20 28 63 6f 6e 64 0a 09 09 09 09 20 20 20 20 t (cond.....
5750: 20 20 28 28 73 74 72 69 6e 67 3d 3f 20 70 61 67 ((string=? pag
5760: 65 20 22 2a 73 65 73 73 69 6f 6e 76 61 72 73 2a e "*sessionvars*
5770: 22 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 76 ")..... (v
5780: 65 63 74 6f 72 20 28 73 64 61 74 2d 67 65 74 2d ector (sdat-get-
5790: 73 65 73 73 69 6f 6e 76 61 72 73 20 73 65 6c 66 sessionvars self
57a0: 29 0a 09 09 09 09 09 20 20 20 20 20 20 20 28 73 )...... (s
57b0: 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 dat-get-sessionv
57c0: 61 72 73 2d 62 65 66 6f 72 65 20 73 65 6c 66 29 ars-before self)
57d0: 29 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 28 ))..... ((
57e0: 73 74 72 69 6e 67 3d 3f 20 70 61 67 65 20 22 2a string=? page "*
57f0: 67 6c 6f 62 61 6c 76 61 72 73 2a 22 29 0a 09 09 globalvars*")...
5800: 09 09 09 28 76 65 63 74 6f 72 20 28 73 64 61 74 ...(vector (sdat
5810: 2d 67 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 20 -get-globalvars
5820: 73 65 6c 66 29 0a 09 09 09 09 09 09 28 73 64 61 self).......(sda
5830: 74 2d 67 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 t-get-globalvars
5840: 2d 62 65 66 6f 72 65 20 73 65 6c 66 29 29 29 0a -before self))).
5850: 09 09 09 09 20 20 20 20 20 20 20 28 65 6c 73 65 .... (else
5860: 20 0a 09 09 09 09 09 28 76 65 63 74 6f 72 20 28 ......(vector (
5870: 73 64 61 74 2d 67 65 74 2d 70 61 67 65 76 61 72 sdat-get-pagevar
5880: 73 20 73 65 6c 66 29 0a 09 09 09 09 09 09 28 73 s self).......(s
5890: 64 61 74 2d 67 65 74 2d 70 61 67 65 76 61 72 73 dat-get-pagevars
58a0: 2d 62 65 66 6f 72 65 20 73 65 6c 66 29 29 29 29 -before self))))
58b0: 29 0a 09 09 20 20 20 20 28 6d 61 73 74 65 72 2d )... (master-
58c0: 68 74 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 ht (vector-ref
58d0: 20 62 65 66 6f 72 65 2d 61 66 74 65 72 2d 68 74 before-after-ht
58e0: 20 30 29 29 0a 09 09 20 20 20 20 28 62 65 66 6f 0))... (befo
58f0: 72 65 2d 68 74 20 20 20 28 76 65 63 74 6f 72 2d re-ht (vector-
5900: 72 65 66 20 62 65 66 6f 72 65 2d 61 66 74 65 72 ref before-after
5910: 2d 68 74 20 31 29 29 0a 09 09 20 20 20 20 28 6d -ht 1))... (m
5920: 61 73 74 65 72 2d 6b 65 79 73 20 28 68 61 73 68 aster-keys (hash
5930: 2d 74 61 62 6c 65 2d 6b 65 79 73 20 6d 61 73 74 -table-keys mast
5940: 65 72 2d 68 74 29 29 0a 09 09 20 20 20 20 28 62 er-ht))... (b
5950: 65 66 6f 72 65 2d 6b 65 79 73 20 28 68 61 73 68 efore-keys (hash
5960: 2d 74 61 62 6c 65 2d 6b 65 79 73 20 62 65 66 6f -table-keys befo
5970: 72 65 2d 68 74 29 29 0a 09 09 20 20 20 20 28 61 re-ht))... (a
5980: 6c 6c 2d 6b 65 79 73 20 28 64 65 6c 65 74 65 2d ll-keys (delete-
5990: 64 75 70 6c 69 63 61 74 65 73 20 28 61 70 70 65 duplicates (appe
59a0: 6e 64 20 6d 61 73 74 65 72 2d 6b 65 79 73 20 62 nd master-keys b
59b0: 65 66 6f 72 65 2d 6b 65 79 73 29 29 29 29 0a 09 efore-keys))))..
59c0: 20 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 (for-each
59d0: 20 0a 09 09 28 6c 61 6d 62 64 61 20 28 6b 65 79 ...(lambda (key
59e0: 29 0a 09 09 20 20 28 6c 65 74 20 28 28 6d 61 73 )... (let ((mas
59f0: 74 65 72 2d 76 61 6c 75 65 20 28 68 61 73 68 2d ter-value (hash-
5a00: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
5a10: 74 20 6d 61 73 74 65 72 2d 68 74 20 6b 65 79 20 t master-ht key
5a20: 23 66 29 29 0a 09 09 09 28 62 65 66 6f 72 65 2d #f))....(before-
5a30: 76 61 6c 75 65 20 28 68 61 73 68 2d 74 61 62 6c value (hash-tabl
5a40: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 62 65 e-ref/default be
5a50: 66 6f 72 65 2d 68 74 20 6b 65 79 20 23 66 29 29 fore-ht key #f))
5a60: 29 0a 09 09 20 20 20 20 28 63 6f 6e 64 0a 09 09 )... (cond...
5a70: 20 20 20 20 20 3b 3b 20 62 65 66 6f 72 65 20 61 ;; before a
5a80: 6e 64 20 61 66 74 65 72 20 65 78 69 73 74 20 61 nd after exist a
5a90: 6e 64 20 76 61 6c 75 65 20 75 6e 63 68 61 6e 67 nd value unchang
5aa0: 65 64 20 2d 20 64 6f 20 6e 6f 74 68 69 6e 67 0a ed - do nothing.
5ab0: 09 09 20 20 20 20 20 28 28 61 6e 64 20 6d 61 73 .. ((and mas
5ac0: 74 65 72 2d 76 61 6c 75 65 20 62 65 66 6f 72 65 ter-value before
5ad0: 2d 76 61 6c 75 65 20 28 65 71 75 61 6c 3f 20 6d -value (equal? m
5ae0: 61 73 74 65 72 2d 76 61 6c 75 65 20 62 65 66 6f aster-value befo
5af0: 72 65 2d 76 61 6c 75 65 29 29 29 0a 09 09 20 20 re-value)))...
5b00: 20 20 20 3b 3b 20 62 65 66 6f 72 65 20 61 6e 64 ;; before and
5b10: 20 61 66 74 65 72 20 65 78 69 73 74 20 62 75 74 after exist but
5b20: 20 61 72 65 20 63 68 61 6e 67 65 64 0a 09 09 20 are changed...
5b30: 20 20 20 20 28 28 61 6e 64 20 6d 61 73 74 65 72 ((and master
5b40: 2d 76 61 6c 75 65 20 62 65 66 6f 72 65 2d 76 61 -value before-va
5b50: 6c 75 65 29 0a 09 09 20 20 20 20 20 20 28 64 62 lue)... (db
5b60: 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 28 i:for-each-row (
5b70: 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 29 0a 09 lambda (tuple)..
5b80: 09 09 09 09 20 20 28 73 65 74 21 20 63 68 61 6e .... (set! chan
5b90: 67 65 64 2d 63 6f 75 6e 74 20 28 2b 20 63 68 61 ged-count (+ cha
5ba0: 6e 67 65 64 2d 63 6f 75 6e 74 20 31 29 29 29 0a nged-count 1))).
5bb0: 09 09 09 09 09 63 6f 6e 6e 0a 09 09 09 09 09 28 .....conn......(
5bc0: 73 3a 73 71 6c 70 61 72 61 6d 20 75 70 64 2d 71 s:sqlparam upd-q
5bd0: 75 65 72 79 20 6d 61 73 74 65 72 2d 76 61 6c 75 uery master-valu
5be0: 65 20 6b 65 79 20 73 65 73 73 69 6f 6e 2d 69 64 e key session-id
5bf0: 20 70 61 67 65 29 29 29 0a 09 09 20 20 20 20 20 page)))...
5c00: 3b 3b 20 6d 61 73 74 65 72 2d 76 61 6c 75 65 20 ;; master-value
5c10: 6e 6f 20 6c 6f 6e 67 65 72 20 65 78 69 73 74 73 no longer exists
5c20: 20 28 69 2e 65 2e 20 23 66 29 20 2d 20 72 65 6d (i.e. #f) - rem
5c30: 6f 76 65 20 69 74 65 6d 0a 09 09 20 20 20 20 20 ove item...
5c40: 28 28 6e 6f 74 20 6d 61 73 74 65 72 2d 76 61 6c ((not master-val
5c50: 75 65 29 0a 09 09 20 20 20 20 20 20 28 64 62 69 ue)... (dbi
5c60: 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 28 6c :for-each-row (l
5c70: 61 6d 62 64 61 20 28 74 75 70 6c 65 29 0a 09 09 ambda (tuple)...
5c80: 09 09 09 20 20 28 73 65 74 21 20 63 68 61 6e 67 ... (set! chang
5c90: 65 64 2d 63 6f 75 6e 74 20 28 2b 20 63 68 61 6e ed-count (+ chan
5ca0: 67 65 64 2d 63 6f 75 6e 74 20 31 29 29 29 0a 09 ged-count 1)))..
5cb0: 09 09 09 09 63 6f 6e 6e 0a 09 09 09 09 09 28 73 ....conn......(s
5cc0: 3a 73 71 6c 70 61 72 61 6d 20 64 65 6c 2d 71 75 :sqlparam del-qu
5cd0: 65 72 79 20 73 65 73 73 69 6f 6e 2d 69 64 20 70 ery session-id p
5ce0: 61 67 65 20 6b 65 79 29 29 29 0a 09 09 20 20 20 age key)))...
5cf0: 20 20 3b 3b 20 62 65 66 6f 72 65 2d 76 61 6c 75 ;; before-valu
5d00: 65 20 64 6f 65 73 6e 27 74 20 65 78 69 73 74 20 e doesn't exist
5d10: 2d 20 69 6e 73 65 72 74 20 61 20 6e 65 77 20 76 - insert a new v
5d20: 61 6c 75 65 0a 09 09 20 20 20 20 20 28 28 6e 6f alue... ((no
5d30: 74 20 62 65 66 6f 72 65 2d 76 61 6c 75 65 29 0a t before-value).
5d40: 09 09 20 20 20 20 20 20 28 64 62 69 3a 66 6f 72 .. (dbi:for
5d50: 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 6d 62 64 -each-row (lambd
5d60: 61 20 28 74 75 70 6c 65 29 0a 09 09 09 09 09 20 a (tuple)......
5d70: 20 28 73 65 74 21 20 63 68 61 6e 67 65 64 2d 63 (set! changed-c
5d80: 6f 75 6e 74 20 28 2b 20 63 68 61 6e 67 65 64 2d ount (+ changed-
5d90: 63 6f 75 6e 74 20 31 29 29 29 0a 09 09 09 09 09 count 1)))......
5da0: 63 6f 6e 6e 0a 09 09 09 09 09 28 73 3a 73 71 6c conn......(s:sql
5db0: 70 61 72 61 6d 20 69 6e 73 2d 71 75 65 72 79 20 param ins-query
5dc0: 73 65 73 73 69 6f 6e 2d 69 64 20 70 61 67 65 20 session-id page
5dd0: 6b 65 79 20 6d 61 73 74 65 72 2d 76 61 6c 75 65 key master-value
5de0: 29 29 29 0a 09 09 20 20 20 20 20 28 65 6c 73 65 )))... (else
5df0: 20 28 65 72 72 3a 6c 6f 67 20 22 53 68 6f 75 6c (err:log "Shoul
5e00: 64 6e 27 74 20 67 65 74 20 68 65 72 65 22 29 29 dn't get here"))
5e10: 29 29 29 0a 09 09 61 6c 6c 2d 6b 65 79 73 29 29 )))...all-keys))
5e20: 29 20 3b 3b 20 70 72 6f 63 65 73 73 20 61 6c 6c ) ;; process all
5e30: 20 6b 65 79 73 0a 09 20 20 20 28 6c 69 73 74 20 keys.. (list
5e40: 22 2a 73 65 73 73 69 6f 6e 76 61 72 73 2a 22 20 "*sessionvars*"
5e50: 22 2a 67 6c 6f 62 61 6c 76 61 72 73 2a 22 20 70 "*globalvars*" p
5e60: 61 67 65 2d 6e 61 6d 65 29 29 29 29 29 29 0a 0a age-name))))))..
5e70: 3b 3b 20 28 70 67 3a 73 71 6c 2d 6e 75 6c 6c 2d ;; (pg:sql-null-
5e80: 6f 62 6a 65 63 74 3f 20 65 6c 65 6d 65 6e 74 29 object? element)
5e90: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
5ea0: 6e 3a 72 65 61 64 2d 63 6f 6e 66 69 67 20 73 65 n:read-config se
5eb0: 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 6e 61 6d lf). (let ((nam
5ec0: 65 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 e (string-append
5ed0: 20 22 2e 22 20 28 70 61 74 68 6e 61 6d 65 2d 66 "." (pathname-f
5ee0: 69 6c 65 20 28 63 61 72 20 28 61 72 67 76 29 29 ile (car (argv))
5ef0: 29 20 22 2e 63 6f 6e 66 69 67 22 29 29 29 0a 20 ) ".config"))).
5f00: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 66 69 6c (if (not (fil
5f10: 65 2d 65 78 69 73 74 73 3f 20 6e 61 6d 65 29 29 e-exists? name))
5f20: 0a 09 28 70 72 69 6e 74 20 6e 61 6d 65 20 22 20 ..(print name "
5f30: 6e 6f 74 20 66 6f 75 6e 64 20 61 74 20 22 20 28 not found at " (
5f40: 63 75 72 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 current-director
5f50: 79 29 29 0a 09 28 6c 65 74 2a 20 28 28 66 70 20 y))..(let* ((fp
5f60: 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 66 69 6c 65 (open-input-file
5f70: 20 6e 61 6d 65 29 29 0a 09 20 20 20 20 20 20 20 name))..
5f80: 28 69 6e 69 74 61 72 67 73 20 28 72 65 61 64 20 (initargs (read
5f90: 66 70 29 29 29 0a 09 20 20 28 63 6c 6f 73 65 2d fp))).. (close-
5fa0: 69 6e 70 75 74 2d 70 6f 72 74 20 66 70 29 0a 09 input-port fp)..
5fb0: 20 20 69 6e 69 74 61 72 67 73 29 29 29 29 0a 0a initargs))))..
5fc0: 3b 3b 20 63 61 6c 6c 20 74 68 65 20 63 6f 6e 74 ;; call the cont
5fd0: 72 6f 6c 6c 65 72 20 69 66 20 69 74 20 65 78 69 roller if it exi
5fe0: 73 74 73 0a 3b 3b 20 0a 3b 3b 20 57 41 52 4e 49 sts.;; .;; WARNI
5ff0: 4e 47 20 2d 20 74 68 69 73 20 63 6f 64 65 20 6e NG - this code n
6000: 65 65 64 73 20 61 20 64 65 66 65 6e 63 65 20 61 eeds a defence a
6010: 67 61 69 6e 73 20 72 65 63 75 72 73 69 76 65 20 gains recursive
6020: 63 61 6c 6c 69 6e 67 21 21 21 21 21 0a 3b 3b 0a calling!!!!!.;;.
6030: 3b 3b 20 20 20 49 20 73 75 67 67 65 73 74 20 61 ;; I suggest a
6040: 20 6c 69 6d 69 74 20 6f 66 20 31 30 30 20 63 61 limit of 100 ca
6050: 6c 6c 73 2e 20 50 6c 65 6e 74 79 20 66 6f 72 20 lls. Plenty for
6060: 61 6c 6c 6f 77 69 6e 67 20 6d 75 6c 74 69 70 6c allowing multipl
6070: 65 20 69 6e 73 74 61 6e 63 65 73 0a 3b 3b 20 20 e instances.;;
6080: 20 6f 66 20 61 20 70 61 67 65 20 69 6e 73 69 64 of a page insid
6090: 65 20 61 6e 6f 74 68 65 72 20 70 61 67 65 2e 20 e another page.
60a0: 0a 3b 3b 0a 3b 3b 20 70 61 72 74 73 20 3d 20 27 .;;.;; parts = '
60b0: 62 6f 74 68 20 7c 20 27 63 6f 6e 74 72 6f 6c 20 both | 'control
60c0: 7c 20 27 76 69 65 77 0a 3b 3b 0a 0a 28 64 65 66 | 'view.;;..(def
60d0: 69 6e 65 20 28 66 69 6c 65 73 2d 72 65 61 64 2d ine (files-read-
60e0: 3e 73 74 72 69 6e 67 20 2e 20 66 69 6c 65 73 29 >string . files)
60f0: 0a 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 . (string-inter
6100: 73 70 65 72 73 65 20 0a 20 20 20 28 61 70 70 6c sperse . (appl
6110: 79 20 61 70 70 65 6e 64 20 28 6d 61 70 20 66 69 y append (map fi
6120: 6c 65 2d 72 65 61 64 2d 3e 73 74 72 69 6e 67 20 le-read->string
6130: 66 69 6c 65 73 29 29 20 22 5c 6e 22 29 29 0a 0a files)) "\n"))..
6140: 28 64 65 66 69 6e 65 20 28 66 69 6c 65 2d 72 65 (define (file-re
6150: 61 64 2d 3e 73 74 72 69 6e 67 20 66 29 20 0a 20 ad->string f) .
6160: 20 28 6c 65 74 20 28 28 70 20 28 6f 70 65 6e 2d (let ((p (open-
6170: 69 6e 70 75 74 2d 66 69 6c 65 20 66 29 29 29 0a input-file f))).
6180: 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 (let loop ((
6190: 68 65 64 20 28 72 65 61 64 2d 6c 69 6e 65 20 70 hed (read-line p
61a0: 29 29 0a 09 20 20 20 20 20 20 20 28 72 65 73 20 )).. (res
61b0: 27 28 29 29 29 0a 20 20 20 20 20 20 28 69 66 20 '())). (if
61c0: 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 68 65 64 (eof-object? hed
61d0: 29 0a 09 20 20 72 65 73 0a 09 20 20 28 6c 6f 6f ).. res.. (loo
61e0: 70 20 28 72 65 61 64 2d 6c 69 6e 65 20 70 29 28 p (read-line p)(
61f0: 61 70 70 65 6e 64 20 72 65 73 20 28 6c 69 73 74 append res (list
6200: 20 68 65 64 29 29 29 29 29 29 29 0a 0a 28 64 65 hed)))))))..(de
6210: 66 69 6e 65 20 28 70 72 6f 63 65 73 73 2d 70 6f fine (process-po
6220: 72 74 20 70 29 0a 20 20 28 6c 65 74 20 28 28 65 rt p). (let ((e
6230: 20 28 69 6e 74 65 72 61 63 74 69 6f 6e 2d 65 6e (interaction-en
6240: 76 69 72 6f 6e 6d 65 6e 74 29 29 29 0a 20 20 20 vironment))).
6250: 20 28 6d 61 70 20 0a 20 20 20 20 20 28 6c 61 6d (map . (lam
6260: 62 64 61 20 28 78 29 0a 20 20 20 20 20 20 20 28 bda (x). (
6270: 63 6f 6e 64 0a 09 28 28 6c 69 73 74 3f 20 78 29 cond..((list? x)
6280: 20 78 29 0a 09 28 28 73 74 72 69 6e 67 3f 20 78 x)..((string? x
6290: 29 20 78 29 0a 09 28 65 6c 73 65 20 27 28 29 29 ) x)..(else '())
62a0: 29 29 0a 20 20 20 20 20 28 70 6f 72 74 2d 6d 61 )). (port-ma
62b0: 70 20 28 6c 61 6d 62 64 61 20 28 73 29 0a 09 09 p (lambda (s)...
62c0: 20 28 65 76 61 6c 20 73 20 65 29 29 0a 09 20 20 (eval s e))..
62d0: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 28 (lambda ()(
62e0: 72 65 61 64 20 70 29 29 29 29 29 29 0a 0a 28 64 read p))))))..(d
62f0: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 70 efine (session:p
6300: 72 6f 63 65 73 73 2d 66 69 6c 65 20 66 29 0a 20 rocess-file f).
6310: 20 28 6c 65 74 2a 20 28 28 70 20 20 20 20 28 6f (let* ((p (o
6320: 70 65 6e 2d 69 6e 70 75 74 2d 66 69 6c 65 20 66 pen-input-file f
6330: 29 29 0a 09 20 28 64 61 74 20 20 28 70 72 6f 63 )).. (dat (proc
6340: 65 73 73 2d 70 6f 72 74 20 70 29 29 29 0a 20 20 ess-port p))).
6350: 20 20 28 63 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 (close-input-p
6360: 6f 72 74 20 70 29 0a 20 20 20 20 64 61 74 29 29 ort p). dat))
6370: 0a 0a 3b 3b 20 4d 61 79 20 32 30 31 31 2c 20 70 ..;; May 2011, p
6380: 75 74 74 69 6e 67 20 61 6c 6c 20 70 61 67 65 73 utting all pages
6390: 20 69 6e 74 6f 20 6f 6e 65 20 64 69 72 65 63 74 into one direct
63a0: 6f 72 79 20 66 6f 72 20 74 68 65 20 66 6f 6c 6c ory for the foll
63b0: 6f 77 69 6e 67 20 72 65 61 73 6f 6e 73 3a 0a 3b owing reasons:.;
63c0: 3b 20 20 20 31 2e 20 77 61 6e 74 20 66 69 6c 65 ; 1. want file
63d0: 6e 61 6d 65 20 74 6f 20 72 65 66 6c 65 63 74 20 name to reflect
63e0: 70 61 67 65 20 6e 61 6d 65 20 28 65 6d 61 63 73 page name (emacs
63f0: 20 6c 69 6d 69 74 61 74 69 6f 6e 29 0a 3b 3b 20 limitation).;;
6400: 20 20 32 2e 20 74 68 61 74 27 73 20 69 74 21 20 2. that's it!
6410: 6e 6f 20 6f 74 68 65 72 20 72 65 61 73 6f 6e 2e no other reason.
6420: 20 63 6f 75 6c 64 20 6d 61 6b 65 20 69 74 20 63 could make it c
6430: 6f 6e 66 69 67 75 72 61 62 6c 65 20 2e 2e 2e 0a onfigurable ....
6440: 3b 3b 20 70 61 67 65 2d 64 69 72 2d 73 74 79 6c ;; page-dir-styl
6450: 65 20 69 73 3a 0a 3b 3b 20 20 27 73 74 6f 72 65 e is:.;; 'store
6460: 64 20 20 20 3d 3e 20 73 74 6f 72 65 64 20 69 6e d => stored in
6470: 20 65 78 65 63 75 74 61 62 6c 65 0a 3b 3b 20 20 executable.;;
6480: 27 66 6c 61 74 20 20 20 20 20 3d 3e 20 70 61 67 'flat => pag
6490: 65 73 20 66 6c 61 74 20 64 69 72 65 63 74 6f 72 es flat director
64a0: 79 0a 3b 3b 20 20 27 64 69 72 20 20 20 20 20 20 y.;; 'dir
64b0: 3d 3e 20 64 69 72 65 63 74 6f 72 79 20 74 72 65 => directory tre
64c0: 65 20 70 61 67 65 73 2f 3c 70 61 67 65 6e 61 6d e pages/<pagenam
64d0: 65 3e 2f 7b 76 69 65 77 2c 63 6f 6e 74 72 6f 6c e>/{view,control
64e0: 7d 2e 73 63 6d 0a 3b 3b 20 70 61 72 74 73 3a 0a }.scm.;; parts:.
64f0: 3b 3b 20 20 27 62 6f 74 68 20 20 20 20 20 3d 3e ;; 'both =>
6500: 20 6c 6f 61 64 20 63 6f 6e 74 72 6f 6c 20 61 6e load control an
6510: 64 20 76 69 65 77 20 28 61 6e 79 74 68 69 6e 67 d view (anything
6520: 20 6f 74 68 65 72 20 74 68 61 6e 20 76 69 65 77 other than view
6530: 20 6f 72 20 63 6f 6e 74 72 6f 6c 0a 3b 3b 20 20 or control.;;
6540: 27 76 69 65 77 20 20 20 20 20 3d 3e 20 6c 6f 61 'view => loa
6550: 64 20 76 69 65 77 20 6f 6e 6c 79 0a 3b 3b 20 20 d view only.;;
6560: 27 63 6f 6e 74 72 6f 6c 20 20 3d 3e 20 6c 6f 61 'control => loa
6570: 64 20 63 6f 6e 74 72 6f 6c 20 6f 6e 6c 79 0a 28 d control only.(
6580: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
6590: 63 61 6c 6c 2d 70 61 72 74 73 20 73 65 6c 66 20 call-parts self
65a0: 70 61 67 65 20 23 21 6b 65 79 20 28 70 61 72 74 page #!key (part
65b0: 73 20 27 62 6f 74 68 29 29 0a 20 20 28 73 64 61 s 'both)). (sda
65c0: 74 2d 73 65 74 2d 63 75 72 72 2d 70 61 67 65 21 t-set-curr-page!
65d0: 20 73 65 6c 66 20 70 61 67 65 29 0a 20 20 28 73 self page). (s
65e0: 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 ession:log self
65f0: 22 70 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 3a "page-dir-style:
6600: 20 22 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 " (sdat-get-pag
6610: 65 2d 64 69 72 2d 73 74 79 6c 65 20 73 65 6c 66 e-dir-style self
6620: 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 69 72 )). (let* ((dir
6630: 2d 73 74 79 6c 65 20 20 20 20 28 73 64 61 74 2d -style (sdat-
6640: 67 65 74 2d 70 61 67 65 2d 64 69 72 2d 73 74 79 get-page-dir-sty
6650: 6c 65 20 73 65 6c 66 29 29 3b 3b 20 28 65 71 75 le self));; (equ
6660: 61 6c 3f 20 28 73 64 61 74 2d 67 65 74 2d 70 61 al? (sdat-get-pa
6670: 67 65 2d 64 69 72 2d 73 74 79 6c 65 20 73 65 6c ge-dir-style sel
6680: 66 29 20 22 6f 6e 65 64 69 72 22 29 29 20 3b 3b f) "onedir")) ;;
6690: 20 66 6c 61 67 20 23 74 20 66 6f 72 20 6f 6e 65 flag #t for one
66a0: 64 69 72 2c 20 23 66 20 66 6f 72 20 6f 6c 64 20 dir, #f for old
66b0: 73 74 79 6c 65 0a 09 20 28 64 69 72 20 20 20 20 style.. (dir
66c0: 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 61 70 (string-ap
66d0: 70 65 6e 64 20 28 73 64 61 74 2d 67 65 74 2d 73 pend (sdat-get-s
66e0: 72 6f 6f 74 20 73 65 6c 66 29 20 0a 09 09 09 09 root self) .....
66f0: 20 20 20 20 20 20 28 69 66 20 64 69 72 2d 73 74 (if dir-st
6700: 79 6c 65 20 0a 09 09 09 09 09 20 20 28 63 6f 6e yle ...... (con
6710: 63 20 22 2f 70 61 67 65 73 2f 22 29 0a 09 09 09 c "/pages/")....
6720: 09 09 20 20 28 63 6f 6e 63 20 22 2f 70 61 67 65 .. (conc "/page
6730: 73 2f 22 20 70 61 67 65 29 29 29 29 29 0a 20 20 s/" page))))).
6740: 20 20 28 63 61 73 65 20 64 69 72 2d 73 74 79 6c (case dir-styl
6750: 65 0a 20 20 20 20 20 20 3b 3b 20 4e 42 2f 2f 20 e. ;; NB//
6760: 53 74 6f 72 65 64 20 61 6c 77 61 79 73 20 6c 6f Stored always lo
6770: 61 64 73 20 62 6f 74 68 20 63 6f 6e 74 72 6f 6c ads both control
6780: 20 61 6e 64 20 76 69 65 77 0a 20 20 20 20 20 20 and view.
6790: 28 28 73 74 6f 72 65 64 29 28 28 65 76 61 6c 20 ((stored)((eval
67a0: 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 (string->symbol
67b0: 28 63 6f 6e 63 20 22 70 61 67 65 73 3a 22 20 70 (conc "pages:" p
67c0: 61 67 65 29 29 29 29 29 0a 20 20 20 20 20 20 28 age))))). (
67d0: 28 64 69 72 29 20 20 20 0a 20 20 20 20 20 20 20 (dir) .
67e0: 3b 3b 20 66 69 72 73 74 20 74 68 65 20 63 6f 6e ;; first the con
67f0: 74 72 6f 6c 0a 20 20 20 20 20 20 20 28 6c 65 74 trol. (let
6800: 20 28 28 63 6f 6e 74 72 6f 6c 2d 66 69 6c 65 20 ((control-file
6810: 28 63 6f 6e 63 20 22 70 61 67 65 73 2f 22 20 70 (conc "pages/" p
6820: 61 67 65 20 22 5f 63 74 72 6c 2e 73 63 6d 22 29 age "_ctrl.scm")
6830: 29 0a 09 20 20 20 20 20 28 76 69 65 77 2d 66 69 ).. (view-fi
6840: 6c 65 20 20 20 20 28 63 6f 6e 63 20 22 70 61 67 le (conc "pag
6850: 65 73 2f 22 20 70 61 67 65 20 22 5f 76 69 65 77 es/" page "_view
6860: 2e 73 63 6d 22 29 29 29 0a 09 20 28 69 66 20 28 .scm"))).. (if (
6870: 61 6e 64 20 28 66 69 6c 65 2d 65 78 69 73 74 73 and (file-exists
6880: 3f 20 63 6f 6e 74 72 6f 6c 2d 66 69 6c 65 29 0a ? control-file).
6890: 09 09 20 20 28 6e 6f 74 20 28 65 71 3f 20 70 61 .. (not (eq? pa
68a0: 72 74 73 20 27 76 69 65 77 29 29 29 0a 09 20 20 rts 'view)))..
68b0: 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 (begin..
68c0: 20 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 2d 63 (session:set-c
68d0: 61 6c 6c 65 64 21 20 73 65 6c 66 20 70 61 67 65 alled! self page
68e0: 29 0a 09 20 20 20 20 20 20 20 28 6c 6f 61 64 20 ).. (load
68f0: 63 6f 6e 74 72 6f 6c 2d 66 69 6c 65 29 29 29 0a control-file))).
6900: 09 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 . (if (file-exis
6910: 74 73 3f 20 76 69 65 77 2d 66 69 6c 65 29 0a 09 ts? view-file)..
6920: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 (if (not (e
6930: 71 3f 20 70 61 72 74 73 20 27 63 6f 6e 74 72 6f q? parts 'contro
6940: 6c 29 29 0a 09 09 20 28 73 65 73 73 69 6f 6e 3a l))... (session:
6950: 70 72 6f 63 65 73 73 2d 66 69 6c 65 20 76 69 65 process-file vie
6960: 77 2d 66 69 6c 65 29 29 0a 09 20 20 20 20 20 28 w-file)).. (
6970: 6c 69 73 74 20 22 3c 70 3e 50 61 67 65 20 6e 6f list "<p>Page no
6980: 74 20 66 6f 75 6e 64 20 22 20 70 61 67 65 20 22 t found " page "
6990: 20 3c 2f 70 3e 22 29 29 29 29 0a 20 20 20 20 20 </p>")))).
69a0: 20 28 28 66 6c 61 74 29 29 0a 20 20 20 20 20 20 ((flat)).
69b0: 28 65 6c 73 65 0a 20 20 20 20 20 20 20 28 6c 69 (else. (li
69c0: 73 74 20 22 45 52 52 4f 52 3a 20 70 61 67 65 2d st "ERROR: page-
69d0: 64 69 72 2d 73 74 79 6c 65 20 6d 75 73 74 20 62 dir-style must b
69e0: 65 20 73 74 6f 72 65 64 2c 20 64 69 72 20 6f 72 e stored, dir or
69f0: 20 66 6c 61 74 2c 20 67 6f 74 20 22 20 64 69 72 flat, got " dir
6a00: 2d 73 74 79 6c 65 29 29 29 29 29 0a 0a 28 64 65 -style)))))..(de
6a10: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 63 61 fine (session:ca
6a20: 6c 6c 20 73 65 6c 66 20 70 61 67 65 20 70 61 72 ll self page par
6a30: 74 73 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a 63 ts). (session:c
6a40: 61 6c 6c 2d 70 61 72 74 73 20 73 65 6c 66 20 70 all-parts self p
6a50: 61 67 65 20 27 62 6f 74 68 29 29 0a 0a 3b 3b 20 age 'both))..;;
6a60: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
6a70: 3a 6c 6f 61 64 2d 6d 6f 64 65 6c 20 73 65 6c 66 :load-model self
6a80: 20 6d 6f 64 65 6c 29 0a 3b 3b 20 20 20 28 6c 65 model).;; (le
6a90: 74 20 28 28 6d 6f 64 65 6c 2e 73 63 6d 20 28 73 t ((model.scm (s
6aa0: 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 28 73 64 tring-append (sd
6ab0: 61 74 2d 67 65 74 2d 73 72 6f 6f 74 20 73 65 6c at-get-sroot sel
6ac0: 66 29 20 22 2f 6d 6f 64 65 6c 73 2f 22 20 6d 6f f) "/models/" mo
6ad0: 64 65 6c 20 22 2e 73 63 6d 22 29 29 0a 3b 3b 20 del ".scm")).;;
6ae0: 09 28 6d 6f 64 65 6c 2e 73 6f 20 20 28 73 74 72 .(model.so (str
6af0: 69 6e 67 2d 61 70 70 65 6e 64 20 28 73 64 61 74 ing-append (sdat
6b00: 2d 67 65 74 2d 73 72 6f 6f 74 20 73 65 6c 66 29 -get-sroot self)
6b10: 20 22 2f 6d 6f 64 65 6c 73 2f 22 20 6d 6f 64 65 "/models/" mode
6b20: 6c 20 22 2e 73 6f 22 29 29 29 0a 3b 3b 20 20 20 l ".so"))).;;
6b30: 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 (if (file-exis
6b40: 74 73 3f 20 6d 6f 64 65 6c 2e 73 6f 29 0a 3b 3b ts? model.so).;;
6b50: 20 09 28 6c 6f 61 64 20 6d 6f 64 65 6c 2e 73 6f .(load model.so
6b60: 29 0a 3b 3b 20 09 28 69 66 20 28 66 69 6c 65 2d ).;; .(if (file-
6b70: 65 78 69 73 74 73 3f 20 6d 6f 64 65 6c 2e 73 63 exists? model.sc
6b80: 6d 29 0a 3b 3b 20 09 20 20 20 20 28 6c 6f 61 64 m).;; . (load
6b90: 20 6d 6f 64 65 6c 2e 73 63 6d 29 0a 3b 3b 20 09 model.scm).;; .
6ba0: 20 20 20 20 28 73 3a 6c 6f 67 20 22 45 52 52 4f (s:log "ERRO
6bb0: 52 3a 20 6d 6f 64 65 6c 20 22 20 6d 6f 64 65 6c R: model " model
6bc0: 2e 73 63 6d 20 22 20 6e 6f 74 20 66 6f 75 6e 64 .scm " not found
6bd0: 22 29 29 29 29 29 0a 0a 3b 3b 20 28 64 65 66 69 ")))))..;; (defi
6be0: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 6d 6f 64 65 ne (session:mode
6bf0: 6c 2d 70 61 74 68 20 73 65 6c 66 20 6d 6f 64 65 l-path self mode
6c00: 6c 29 0a 3b 3b 20 20 20 28 73 74 72 69 6e 67 2d l).;; (string-
6c10: 61 70 70 65 6e 64 20 28 73 64 61 74 2d 67 65 74 append (sdat-get
6c20: 2d 73 72 6f 6f 74 20 73 65 6c 66 29 20 22 2f 6d -sroot self) "/m
6c30: 6f 64 65 6c 73 2f 22 20 6d 6f 64 65 6c 20 22 2e odels/" model ".
6c40: 73 63 6d 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 scm"))..(define
6c50: 28 73 65 73 73 69 6f 6e 3a 70 70 2d 66 6f 72 6d (session:pp-form
6c60: 64 61 74 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 dat self). (let
6c70: 20 28 28 64 61 74 20 28 66 6f 72 6d 64 61 74 3a ((dat (formdat:
6c80: 61 6c 6c 2d 3e 73 74 72 69 6e 67 73 20 28 73 64 all->strings (sd
6c90: 61 74 2d 67 65 74 2d 66 6f 72 6d 64 61 74 20 73 at-get-formdat s
6ca0: 65 6c 66 29 29 29 29 0a 20 20 20 20 28 73 74 72 elf)))). (str
6cb0: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
6cc0: 64 61 74 20 22 3c 62 72 3e 20 22 29 29 29 0a 0a dat "<br> ")))..
6cd0: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
6ce0: 3a 70 61 72 61 6d 2d 3e 73 74 72 69 6e 67 20 70 :param->string p
6cf0: 61 72 61 6d 73 29 0a 20 20 3b 3b 20 28 65 72 72 arams). ;; (err
6d00: 3a 6c 6f 67 20 22 70 61 72 61 6d 73 3d 22 20 70 :log "params=" p
6d10: 61 72 61 6d 73 29 0a 20 20 28 69 66 20 28 3c 20 arams). (if (<
6d20: 28 6c 65 6e 67 74 68 20 70 61 72 61 6d 73 29 20 (length params)
6d30: 31 29 0a 20 20 20 20 20 20 22 22 0a 20 20 20 20 1). "".
6d40: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 6b 65 (let loop ((ke
6d50: 79 20 28 63 61 72 20 70 61 72 61 6d 73 29 29 0a y (car params)).
6d60: 09 09 20 28 76 61 6c 20 28 63 61 64 72 20 70 61 .. (val (cadr pa
6d70: 72 61 6d 73 29 29 0a 09 09 20 28 74 61 69 6c 20 rams))... (tail
6d80: 28 63 64 64 72 20 70 61 72 61 6d 73 29 29 0a 09 (cddr params))..
6d90: 09 20 28 72 65 73 75 6c 74 20 27 28 29 29 29 0a . (result '())).
6da0: 09 28 6c 65 74 20 28 28 6e 65 77 72 65 73 75 6c .(let ((newresul
6db0: 74 20 28 63 6f 6e 73 20 28 73 74 72 69 6e 67 2d t (cons (string-
6dc0: 61 70 70 65 6e 64 20 28 73 3a 61 6e 79 2d 3e 73 append (s:any->s
6dd0: 74 72 69 6e 67 20 6b 65 79 29 20 22 3d 22 20 28 tring key) "=" (
6de0: 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 76 61 s:any->string va
6df0: 6c 29 29 0a 09 09 09 20 20 20 20 20 20 20 72 65 l)).... re
6e00: 73 75 6c 74 29 29 29 0a 09 20 20 28 69 66 20 28 sult))).. (if (
6e10: 3c 20 28 6c 65 6e 67 74 68 20 74 61 69 6c 29 20 < (length tail)
6e20: 31 29 20 3b 3b 20 74 72 75 65 20 69 66 20 64 6f 1) ;; true if do
6e30: 6e 65 0a 09 20 20 20 20 20 20 28 73 74 72 69 6e ne.. (strin
6e40: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 6e 65 g-intersperse ne
6e50: 77 72 65 73 75 6c 74 20 22 26 22 29 0a 09 20 20 wresult "&")..
6e60: 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 (loop (car t
6e70: 61 69 6c 29 28 63 61 64 72 20 74 61 69 6c 29 28 ail)(cadr tail)(
6e80: 63 64 64 72 20 74 61 69 6c 29 20 6e 65 77 72 65 cddr tail) newre
6e90: 73 75 6c 74 29 29 29 29 29 29 0a 0a 28 64 65 66 sult))))))..(def
6ea0: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 6c 69 6e ine (session:lin
6eb0: 6b 2d 74 6f 20 73 65 6c 66 20 70 61 67 65 20 70 k-to self page p
6ec0: 61 72 61 6d 73 29 0a 20 20 28 6c 65 74 2a 20 28 arams). (let* (
6ed0: 28 73 65 72 76 65 72 20 20 20 20 28 69 66 20 28 (server (if (
6ee0: 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d get-environment-
6ef0: 76 61 72 69 61 62 6c 65 20 22 48 54 54 50 5f 48 variable "HTTP_H
6f00: 4f 53 54 22 29 0a 09 09 09 28 67 65 74 2d 65 6e OST")....(get-en
6f10: 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 vironment-variab
6f20: 6c 65 20 22 48 54 54 50 5f 48 4f 53 54 22 29 0a le "HTTP_HOST").
6f30: 09 09 09 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d ...(get-environm
6f40: 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 53 45 ent-variable "SE
6f50: 52 56 45 52 5f 4e 41 4d 45 22 29 29 29 0a 09 20 RVER_NAME")))..
6f60: 28 73 63 72 69 70 74 20 28 6c 65 74 20 28 28 73 (script (let ((s
6f70: 63 72 69 70 74 2d 6e 61 6d 65 20 28 73 74 72 69 cript-name (stri
6f80: 6e 67 2d 73 70 6c 69 74 20 28 67 65 74 2d 65 6e ng-split (get-en
6f90: 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 vironment-variab
6fa0: 6c 65 20 22 53 43 52 49 50 54 5f 4e 41 4d 45 22 le "SCRIPT_NAME"
6fb0: 29 20 22 2f 22 29 29 29 0a 09 09 20 20 20 28 69 ) "/")))... (i
6fc0: 66 20 28 3e 20 28 6c 65 6e 67 74 68 20 73 63 72 f (> (length scr
6fd0: 69 70 74 2d 6e 61 6d 65 29 20 31 29 0a 09 09 20 ipt-name) 1)...
6fe0: 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 61 70 (string-ap
6ff0: 70 65 6e 64 20 28 63 61 72 20 73 63 72 69 70 74 pend (car script
7000: 2d 6e 61 6d 65 29 20 22 2f 22 20 28 63 61 64 72 -name) "/" (cadr
7010: 20 73 63 72 69 70 74 2d 6e 61 6d 65 29 29 0a 09 script-name))..
7020: 09 20 20 20 20 20 20 20 28 67 65 74 2d 65 6e 76 . (get-env
7030: 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c ironment-variabl
7040: 65 20 22 53 43 52 49 50 54 5f 4e 41 4d 45 22 29 e "SCRIPT_NAME")
7050: 29 29 29 20 3b 3b 20 62 75 69 6c 64 20 73 63 72 ))) ;; build scr
7060: 69 70 74 20 6e 61 6d 65 20 66 72 6f 6d 20 66 69 ipt name from fi
7070: 72 73 74 20 74 77 6f 20 65 6c 65 6d 65 6e 74 73 rst two elements
7080: 2e 20 54 68 69 73 20 69 73 20 61 20 68 61 6e 67 . This is a hang
7090: 6f 76 65 72 20 66 72 6f 6d 20 62 65 66 6f 72 65 over from before
70a0: 20 49 20 75 73 65 64 20 3f 20 69 6e 20 74 68 65 I used ? in the
70b0: 20 55 52 4c 2e 0a 09 20 28 73 65 73 73 69 6f 6e URL... (session
70c0: 2d 6b 65 79 20 28 73 64 61 74 2d 67 65 74 2d 73 -key (sdat-get-s
70d0: 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 ession-key self)
70e0: 29 0a 09 20 28 70 61 72 61 6d 73 74 72 20 28 73 ).. (paramstr (s
70f0: 65 73 73 69 6f 6e 3a 70 61 72 61 6d 2d 3e 73 74 ession:param->st
7100: 72 69 6e 67 20 70 61 72 61 6d 73 29 29 29 0a 20 ring params))).
7110: 20 20 20 3b 3b 20 28 73 65 73 73 69 6f 6e 3a 6c ;; (session:l
7120: 6f 67 20 73 65 6c 66 20 22 73 65 72 76 65 72 3d og self "server=
7130: 22 20 73 65 72 76 65 72 20 22 20 73 63 72 69 70 " server " scrip
7140: 74 3d 22 20 73 63 72 69 70 74 20 22 20 70 61 67 t=" script " pag
7150: 65 3d 22 20 70 61 67 65 29 0a 20 20 20 20 28 73 e=" page). (s
7160: 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 22 68 74 tring-append "ht
7170: 74 70 3a 2f 2f 22 20 73 65 72 76 65 72 20 22 2f tp://" server "/
7180: 22 20 73 63 72 69 70 74 20 22 2f 22 20 70 61 67 " script "/" pag
7190: 65 20 22 3f 22 20 70 61 72 61 6d 73 74 72 29 29 e "?" paramstr))
71a0: 29 20 3b 3b 20 22 2f 73 6e 3d 22 20 73 65 73 73 ) ;; "/sn=" sess
71b0: 69 6f 6e 2d 6b 65 79 29 29 29 0a 0a 28 64 65 66 ion-key)))..(def
71c0: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 63 67 69 ine (session:cgi
71d0: 2d 6f 75 74 20 73 65 6c 66 29 0a 20 20 28 6c 65 -out self). (le
71e0: 74 2a 20 28 28 63 6f 6e 74 65 6e 74 20 20 28 6c t* ((content (l
71f0: 69 73 74 20 28 73 64 61 74 2d 67 65 74 2d 63 6f ist (sdat-get-co
7200: 6e 74 65 6e 74 2d 74 79 70 65 20 73 65 6c 66 29 ntent-type self)
7210: 29 29 20 3b 3b 20 27 28 22 43 6f 6e 74 65 6e 74 )) ;; '("Content
7220: 2d 74 79 70 65 3a 20 74 65 78 74 2f 68 74 6d 6c -type: text/html
7230: 3b 20 63 68 61 72 73 65 74 3d 69 73 6f 2d 38 38 ; charset=iso-88
7240: 35 39 2d 31 5c 6e 5c 6e 22 29 29 0a 09 20 28 68 59-1\n\n")).. (h
7250: 65 61 64 65 72 20 20 20 28 6c 65 74 20 28 28 63 eader (let ((c
7260: 6f 6f 6b 69 65 20 28 73 64 61 74 2d 67 65 74 2d ookie (sdat-get-
7270: 73 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 20 73 session-cookie s
7280: 65 6c 66 29 29 29 0a 09 09 20 20 20 20 20 28 69 elf)))... (i
7290: 66 20 63 6f 6f 6b 69 65 0a 09 09 09 20 28 63 6f f cookie.... (co
72a0: 6e 73 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e ns (string-appen
72b0: 64 20 22 53 65 74 2d 43 6f 6f 6b 69 65 3a 20 22 d "Set-Cookie: "
72c0: 20 28 63 61 72 20 63 6f 6f 6b 69 65 29 29 0a 09 (car cookie))..
72d0: 09 09 20 20 20 20 20 20 20 63 6f 6e 74 65 6e 74 .. content
72e0: 29 0a 09 09 09 20 63 6f 6e 74 65 6e 74 29 29 29 ).... content)))
72f0: 0a 09 20 28 70 61 67 65 64 61 74 20 20 28 73 64 .. (pagedat (sd
7300: 61 74 2d 67 65 74 2d 70 61 67 65 64 61 74 20 73 at-get-pagedat s
7310: 65 6c 66 29 29 29 0a 20 20 20 20 28 73 3a 63 67 elf))). (s:cg
7320: 69 2d 6f 75 74 20 0a 20 20 20 20 20 28 63 6f 6e i-out . (con
7330: 73 20 68 65 61 64 65 72 20 70 61 67 65 64 61 74 s header pagedat
7340: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 ))))..(define (s
7350: 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 ession:log self
7360: 2e 20 6d 73 67 29 0a 20 20 28 77 69 74 68 2d 6f . msg). (with-o
7370: 75 74 70 75 74 2d 74 6f 2d 70 6f 72 74 20 28 73 utput-to-port (s
7380: 64 61 74 2d 67 65 74 2d 6c 6f 67 2d 70 6f 72 74 dat-get-log-port
7390: 20 73 65 6c 66 29 20 3b 3b 20 28 73 64 61 74 2d self) ;; (sdat-
73a0: 67 65 74 2d 6c 6f 67 70 74 20 73 65 6c 66 29 0a get-logpt self).
73b0: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 20 0a (lambda () .
73c0: 20 20 20 20 20 20 28 61 70 70 6c 79 20 70 72 69 (apply pri
73d0: 6e 74 20 6d 73 67 29 29 29 29 0a 0a 28 64 65 66 nt msg))))..(def
73e0: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 ine (session:get
73f0: 2d 70 61 72 61 6d 20 73 65 6c 66 20 6b 65 79 29 -param self key)
7400: 0a 20 20 3b 3b 20 28 73 65 73 73 69 6f 6e 3a 6c . ;; (session:l
7410: 6f 67 20 73 3a 73 65 73 73 69 6f 6e 20 22 70 61 og s:session "pa
7420: 72 61 6d 73 3d 22 20 28 73 6c 6f 74 2d 72 65 66 rams=" (slot-ref
7430: 20 73 3a 73 65 73 73 69 6f 6e 20 27 70 61 72 61 s:session 'para
7440: 6d 73 29 29 0a 20 20 28 6c 65 74 20 28 28 70 61 ms)). (let ((pa
7450: 72 61 6d 73 20 28 73 64 61 74 2d 67 65 74 2d 70 rams (sdat-get-p
7460: 61 72 61 6d 73 20 73 65 6c 66 29 29 29 0a 20 20 arams self))).
7470: 20 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 (session:get-p
7480: 61 72 61 6d 2d 66 72 6f 6d 20 70 61 72 61 6d 73 aram-from params
7490: 20 6b 65 79 29 29 29 0a 0a 3b 3b 20 54 68 69 73 key)))..;; This
74a0: 20 6f 6e 65 20 77 69 6c 6c 20 67 65 74 20 74 68 one will get th
74b0: 65 20 66 69 72 73 74 20 76 61 6c 75 65 20 66 6f e first value fo
74c0: 75 6e 64 20 72 65 67 61 72 64 6c 65 73 73 20 6f und regardless o
74d0: 66 20 66 6f 72 6d 0a 28 64 65 66 69 6e 65 20 28 f form.(define (
74e0: 73 65 73 73 69 6f 6e 3a 67 65 74 2d 69 6e 70 75 session:get-inpu
74f0: 74 20 73 65 6c 66 20 6b 65 79 29 0a 20 20 28 6c t self key). (l
7500: 65 74 2a 20 28 28 66 6f 72 6d 64 61 74 20 28 73 et* ((formdat (s
7510: 64 61 74 2d 67 65 74 2d 66 6f 72 6d 64 61 74 20 dat-get-formdat
7520: 73 65 6c 66 29 29 29 0a 20 20 20 20 28 69 66 20 self))). (if
7530: 28 6e 6f 74 20 66 6f 72 6d 64 61 74 29 20 23 66 (not formdat) #f
7540: 0a 09 28 69 66 20 28 6f 72 20 28 73 74 72 69 6e ..(if (or (strin
7550: 67 3f 20 6b 65 79 29 28 6e 75 6d 62 65 72 3f 20 g? key)(number?
7560: 6b 65 79 29 28 73 79 6d 62 6f 6c 3f 20 6b 65 79 key)(symbol? key
7570: 29 29 0a 09 20 20 20 20 28 69 66 20 28 61 6e 64 )).. (if (and
7580: 20 28 76 65 63 74 6f 72 3f 20 66 6f 72 6d 64 61 (vector? formda
7590: 74 29 28 65 71 3f 20 28 76 65 63 74 6f 72 2d 6c t)(eq? (vector-l
75a0: 65 6e 67 74 68 20 66 6f 72 6d 64 61 74 29 20 31 ength formdat) 1
75b0: 29 28 68 61 73 68 2d 74 61 62 6c 65 3f 20 28 76 )(hash-table? (v
75c0: 65 63 74 6f 72 2d 72 65 66 20 66 6f 72 6d 64 61 ector-ref formda
75d0: 74 20 30 29 29 29 0a 09 09 28 66 6f 72 6d 64 61 t 0)))...(formda
75e0: 74 3a 67 65 74 20 66 6f 72 6d 64 61 74 20 6b 65 t:get formdat ke
75f0: 79 29 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 20 y)...(begin...
7600: 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c (session:log sel
7610: 66 20 22 45 52 52 4f 52 3a 20 66 6f 72 6d 64 61 f "ERROR: formda
7620: 74 3a 20 22 20 66 6f 72 6d 64 61 74 20 22 20 69 t: " formdat " i
7630: 73 20 6e 6f 74 20 6f 66 20 63 6c 61 73 73 20 3c s not of class <
7640: 66 6f 72 6d 64 61 74 3e 22 29 0a 09 09 20 20 23 formdat>")... #
7650: 66 29 29 0a 09 20 20 20 20 28 73 65 73 73 69 6f f)).. (sessio
7660: 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 45 52 52 4f n:log self "ERRO
7670: 52 3a 20 62 61 64 20 6b 65 79 20 22 20 6b 65 79 R: bad key " key
7680: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define (
7690: 73 65 73 73 69 6f 6e 3a 72 75 6e 2d 61 63 74 69 session:run-acti
76a0: 6f 6e 73 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 ons self). (let
76b0: 2a 20 28 28 61 63 74 69 6f 6e 20 20 20 20 28 73 * ((action (s
76c0: 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 72 61 6d ession:get-param
76d0: 20 73 65 6c 66 20 27 61 63 74 69 6f 6e 29 29 0a self 'action)).
76e0: 09 20 28 70 61 67 65 20 20 20 20 20 20 28 73 64 . (page (sd
76f0: 61 74 2d 67 65 74 2d 70 61 67 65 20 73 65 6c 66 at-get-page self
7700: 29 29 29 0a 20 20 20 20 3b 3b 20 28 70 72 69 6e ))). ;; (prin
7710: 74 20 22 61 63 74 69 6f 6e 3d 22 20 61 63 74 69 t "action=" acti
7720: 6f 6e 20 22 20 70 61 67 65 3d 22 20 70 61 67 65 on " page=" page
7730: 29 0a 20 20 20 20 28 69 66 20 61 63 74 69 6f 6e ). (if action
7740: 0a 09 28 6c 65 74 20 28 28 61 63 74 69 6f 6e 2d ..(let ((action-
7750: 6c 73 74 20 20 28 73 74 72 69 6e 67 2d 73 70 6c lst (string-spl
7760: 69 74 20 61 63 74 69 6f 6e 20 22 2e 22 29 29 29 it action ".")))
7770: 0a 09 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 61 .. ;; (print "a
7780: 63 74 69 6f 6e 2d 6c 73 74 3d 22 20 61 63 74 69 ction-lst=" acti
7790: 6f 6e 2d 6c 73 74 29 0a 09 20 20 28 69 66 20 28 on-lst).. (if (
77a0: 6e 6f 74 20 28 3d 20 28 6c 65 6e 67 74 68 20 61 not (= (length a
77b0: 63 74 69 6f 6e 2d 6c 73 74 29 20 32 29 29 20 0a ction-lst) 2)) .
77c0: 09 20 20 20 20 20 20 28 65 72 72 3a 6c 6f 67 20 . (err:log
77d0: 22 41 63 74 69 6f 6e 20 73 68 6f 75 6c 64 20 62 "Action should b
77e0: 65 20 6f 66 20 66 6f 72 6d 3a 20 6d 6f 64 75 6c e of form: modul
77f0: 65 2e 61 63 74 69 6f 6e 22 29 0a 09 20 20 20 20 e.action")..
7800: 20 20 28 6c 65 74 2a 20 28 28 74 61 72 67 2d 70 (let* ((targ-p
7810: 61 67 65 20 20 20 28 63 61 72 20 61 63 74 69 6f age (car actio
7820: 6e 2d 6c 73 74 29 29 0a 09 09 20 20 20 20 20 28 n-lst))... (
7830: 70 72 6f 63 2d 6e 61 6d 65 20 20 20 28 73 74 72 proc-name (str
7840: 69 6e 67 2d 61 70 70 65 6e 64 20 74 61 72 67 2d ing-append targ-
7850: 70 61 67 65 20 22 2d 61 63 74 69 6f 6e 22 29 29 page "-action"))
7860: 0a 09 09 20 20 20 20 20 28 74 61 72 67 2d 61 63 ... (targ-ac
7870: 74 69 6f 6e 20 28 63 61 64 72 20 61 63 74 69 6f tion (cadr actio
7880: 6e 2d 6c 73 74 29 29 29 0a 09 09 3b 3b 20 28 65 n-lst)))...;; (e
7890: 72 72 3a 6c 6f 67 20 22 74 61 72 67 2d 70 61 67 rr:log "targ-pag
78a0: 65 3d 22 20 74 61 72 67 2d 70 61 67 65 20 22 20 e=" targ-page "
78b0: 70 72 6f 63 2d 6e 61 6d 65 3d 22 20 70 72 6f 63 proc-name=" proc
78c0: 2d 6e 61 6d 65 20 22 20 74 61 72 67 2d 61 63 74 -name " targ-act
78d0: 69 6f 6e 3d 22 20 74 61 72 67 2d 61 63 74 69 6f ion=" targ-actio
78e0: 6e 29 0a 0a 09 09 3b 3b 20 63 61 6c 6c 20 68 65 n)....;; call he
78f0: 72 65 20 6f 6e 6c 79 20 69 66 20 6e 65 76 65 72 re only if never
7900: 20 63 61 6c 6c 65 64 20 62 65 66 6f 72 65 0a 09 called before..
7910: 09 28 69 66 20 28 73 65 73 73 69 6f 6e 3a 6e 65 .(if (session:ne
7920: 76 65 72 2d 63 61 6c 6c 65 64 2d 70 61 67 65 3f ver-called-page?
7930: 20 73 65 6c 66 20 74 61 72 67 2d 70 61 67 65 29 self targ-page)
7940: 0a 09 09 20 20 20 20 28 73 65 73 73 69 6f 6e 3a ... (session:
7950: 63 61 6c 6c 2d 70 61 72 74 73 20 73 65 6c 66 20 call-parts self
7960: 74 61 72 67 2d 70 61 67 65 20 27 63 6f 6e 74 72 targ-page 'contr
7970: 6f 6c 29 29 0a 09 09 3b 3b 20 20 20 20 20 20 20 ol))...;;
7980: 20 20 20 20 20 20 20 20 20 20 20 20 20 70 72 6f pro
7990: 63 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 c
79a0: 20 20 20 20 20 20 20 20 20 20 61 63 74 69 6f 6e action
79b0: 20 20 20 20 0a 0a 09 09 28 69 66 20 23 74 20 3b ....(if #t ;
79c0: 3b 20 73 65 74 20 74 6f 20 23 74 20 74 6f 20 73 ; set to #t to s
79d0: 65 65 20 62 65 74 74 65 72 20 65 72 72 6f 72 20 ee better error
79e0: 6d 65 73 73 61 67 65 73 20 64 75 72 69 6e 67 20 messages during
79f0: 64 65 62 75 67 67 69 6e 20 3a 2d 29 0a 09 09 20 debuggin :-)...
7a00: 20 20 20 28 28 65 76 61 6c 20 28 73 74 72 69 6e ((eval (strin
7a10: 67 2d 3e 73 79 6d 62 6f 6c 20 70 72 6f 63 2d 6e g->symbol proc-n
7a20: 61 6d 65 29 29 20 74 61 72 67 2d 61 63 74 69 6f ame)) targ-actio
7a30: 6e 29 20 3b 3b 20 75 6e 73 61 66 65 20 65 78 65 n) ;; unsafe exe
7a40: 63 75 74 69 6f 6e 0a 09 09 20 20 20 20 28 63 6f cution... (co
7a50: 6e 64 69 74 69 6f 6e 2d 63 61 73 65 20 28 28 65 ndition-case ((e
7a60: 76 61 6c 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d val (string->sym
7a70: 62 6f 6c 20 70 72 6f 63 2d 6e 61 6d 65 29 29 20 bol proc-name))
7a80: 74 61 72 67 2d 61 63 74 69 6f 6e 29 0a 09 09 09 targ-action)....
7a90: 09 20 20 20 20 28 28 65 78 6e 20 66 69 6c 65 29 . ((exn file)
7aa0: 20 28 73 3a 6c 6f 67 20 22 66 69 6c 65 20 65 72 (s:log "file er
7ab0: 72 6f 72 22 29 29 0a 09 09 09 09 20 20 20 20 28 ror"))..... (
7ac0: 28 65 78 6e 20 69 2f 6f 29 20 20 28 73 3a 6c 6f (exn i/o) (s:lo
7ad0: 67 20 22 69 2f 6f 20 65 72 72 6f 72 22 29 29 0a g "i/o error")).
7ae0: 09 09 09 09 20 20 20 20 28 28 65 78 6e 20 29 20 .... ((exn )
7af0: 20 20 20 20 28 73 3a 6c 6f 67 20 22 41 63 74 69 (s:log "Acti
7b00: 6f 6e 20 6e 6f 74 20 69 6d 70 6c 65 6d 65 6e 74 on not implement
7b10: 65 64 3a 20 22 20 70 72 6f 63 2d 6e 61 6d 65 20 ed: " proc-name
7b20: 22 20 61 63 74 69 6f 6e 3a 20 22 20 74 61 72 67 " action: " targ
7b30: 2d 61 63 74 69 6f 6e 29 29 0a 09 09 09 09 20 20 -action)).....
7b40: 20 20 28 76 61 72 20 28 29 20 20 20 20 20 28 73 (var () (s
7b50: 3a 6c 6f 67 20 22 55 6e 6b 6e 6f 77 6e 20 45 72 :log "Unknown Er
7b60: 72 6f 72 22 29 29 29 29 29 29 29 29 29 29 0a 0a ror"))))))))))..
7b70: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
7b80: 3a 6e 65 76 65 72 2d 63 61 6c 6c 65 64 2d 70 61 :never-called-pa
7b90: 67 65 3f 20 73 65 6c 66 20 70 61 67 65 29 0a 20 ge? self page).
7ba0: 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 (session:log se
7bb0: 6c 66 20 22 43 68 65 63 6b 69 6e 67 20 66 6f 72 lf "Checking for
7bc0: 20 70 61 67 65 3a 20 22 20 70 61 67 65 29 0a 20 page: " page).
7bd0: 20 28 6e 6f 74 20 28 6d 65 6d 62 65 72 20 70 61 (not (member pa
7be0: 67 65 20 28 73 64 61 74 2d 67 65 74 2d 73 65 65 ge (sdat-get-see
7bf0: 6e 2d 70 61 67 65 73 20 73 65 6c 66 29 29 29 29 n-pages self))))
7c00: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ..(define (sessi
7c10: 6f 6e 3a 73 65 74 2d 63 61 6c 6c 65 64 21 20 73 on:set-called! s
7c20: 65 6c 66 20 70 61 67 65 29 0a 20 20 28 73 64 61 elf page). (sda
7c30: 74 2d 73 65 74 2d 73 65 65 6e 2d 70 61 67 65 73 t-set-seen-pages
7c40: 21 20 73 65 6c 66 20 28 63 6f 6e 73 20 70 61 67 ! self (cons pag
7c50: 65 20 28 73 64 61 74 2d 67 65 74 2d 73 65 65 6e e (sdat-get-seen
7c60: 2d 70 61 67 65 73 20 73 65 6c 66 29 29 29 29 0a -pages self)))).
7c70: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
7c80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7c90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7ca0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7cb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 41 6c 74 =========.;; Alt
7cc0: 65 72 6e 61 74 69 76 65 20 64 61 74 61 20 74 79 ernative data ty
7cd0: 70 65 20 64 65 6c 69 76 65 72 79 0a 3b 3b 3d 3d pe delivery.;;==
7ce0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7cf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7d00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7d10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7d20: 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 73 ====..(define (s
7d30: 65 73 73 69 6f 6e 3a 61 6c 74 2d 6f 75 74 20 73 ession:alt-out s
7d40: 65 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 64 61 elf). (let ((da
7d50: 74 20 28 73 64 61 74 2d 67 65 74 2d 61 6c 74 2d t (sdat-get-alt-
7d60: 70 61 67 65 2d 64 61 74 20 73 65 6c 66 29 29 29 page-dat self)))
7d70: 0a 20 20 20 20 3b 3b 20 28 73 3a 6c 6f 67 20 22 . ;; (s:log "
7d80: 64 61 74 20 69 73 3a 20 22 20 64 61 74 29 0a 20 dat is: " dat).
7d90: 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 48 54 ;; (print "HT
7da0: 54 50 2f 31 2e 31 20 32 30 30 20 4f 4b 22 29 0a TP/1.1 200 OK").
7db0: 20 20 20 20 28 70 72 69 6e 74 20 22 44 61 74 65 (print "Date
7dc0: 3a 20 22 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e : " (time->strin
7dd0: 67 20 28 73 65 63 6f 6e 64 73 2d 3e 75 74 63 2d g (seconds->utc-
7de0: 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 65 time (current-se
7df0: 63 6f 6e 64 73 29 29 29 29 0a 20 20 20 20 28 70 conds)))). (p
7e00: 72 69 6e 74 20 22 43 6f 6e 74 65 6e 74 2d 54 79 rint "Content-Ty
7e10: 70 65 3a 20 22 20 28 73 64 61 74 2d 67 65 74 2d pe: " (sdat-get-
7e20: 63 6f 6e 74 65 6e 74 2d 74 79 70 65 20 73 65 6c content-type sel
7e30: 66 29 29 0a 20 20 20 20 28 70 72 69 6e 74 20 22 f)). (print "
7e40: 41 63 63 65 70 74 2d 52 61 6e 67 65 73 3a 20 62 Accept-Ranges: b
7e50: 79 74 65 73 22 29 0a 20 20 20 20 28 70 72 69 6e ytes"). (prin
7e60: 74 20 22 43 6f 6e 74 65 6e 74 2d 4c 65 6e 67 74 t "Content-Lengt
7e70: 68 3a 20 22 20 28 69 66 20 28 62 6c 6f 62 3f 20 h: " (if (blob?
7e80: 64 61 74 29 0a 09 09 09 09 20 20 28 62 6c 6f 62 dat)..... (blob
7e90: 2d 73 69 7a 65 20 64 61 74 29 0a 09 09 09 09 20 -size dat).....
7ea0: 20 30 29 29 0a 20 20 20 20 28 70 72 69 6e 74 20 0)). (print
7eb0: 22 4b 65 65 70 2d 41 6c 69 76 65 3a 20 74 69 6d "Keep-Alive: tim
7ec0: 65 6f 75 74 3d 31 35 2c 20 6d 61 78 3d 31 30 30 eout=15, max=100
7ed0: 22 29 0a 20 20 20 20 28 70 72 69 6e 74 20 22 43 "). (print "C
7ee0: 6f 6e 6e 65 63 74 69 6f 6e 3a 20 4b 65 65 70 2d onnection: Keep-
7ef0: 41 6c 69 76 65 22 29 0a 20 20 20 20 28 70 72 69 Alive"). (pri
7f00: 6e 74 20 22 22 29 0a 20 20 20 20 28 77 72 69 74 nt ""). (writ
7f10: 65 2d 73 74 72 69 6e 67 20 28 62 6c 6f 62 2d 3e e-string (blob->
7f20: 73 74 72 69 6e 67 20 64 61 74 29 20 23 66 20 28 string dat) #f (
7f30: 63 75 72 72 65 6e 74 2d 6f 75 74 70 75 74 2d 70 current-output-p
7f40: 6f 72 74 29 29 29 29 0a ort)))).