Artifact
8cf5e377cc16f137ae13a460714a40878a27d0ff:
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 28 64 65 66 69 6e 65 al))..;; (define
1780: 2d 63 6c 61 73 73 20 3c 73 65 73 73 69 6f 6e 3e -class <session>
1790: 20 28 29 0a 3b 3b 20 20 20 28 64 62 74 79 70 65 ().;; (dbtype
17a0: 20 20 20 20 20 20 20 3b 3b 20 27 70 67 20 6f 72 ;; 'pg or
17b0: 20 27 73 71 6c 69 74 65 33 0a 3b 3b 20 20 20 20 'sqlite3.;;
17c0: 64 62 69 6e 69 74 0a 3b 3b 20 20 20 20 63 6f 6e dbinit.;; con
17d0: 6e 0a 3b 3b 20 20 20 20 70 61 72 61 6d 73 20 20 n.;; params
17e0: 20 20 20 20 20 3b 3b 20 70 61 72 61 6d 73 20 66 ;; params f
17f0: 72 6f 6d 20 74 68 65 20 6b 65 79 3d 76 61 6c 26 rom the key=val&
1800: 6b 65 79 31 3d 76 61 6c 32 20 73 74 72 69 6e 67 key1=val2 string
1810: 0a 3b 3b 20 20 20 20 70 61 74 68 2d 70 61 72 61 .;; path-para
1820: 6d 73 20 20 3b 3b 20 72 65 6d 61 69 6e 69 6e 67 ms ;; remaining
1830: 20 70 61 72 61 6d 73 20 66 72 6f 6d 20 74 68 65 params from the
1840: 20 70 61 74 68 0a 3b 3b 20 20 20 20 73 65 73 73 path.;; sess
1850: 69 6f 6e 2d 6b 65 79 0a 3b 3b 20 20 20 20 73 65 ion-key.;; se
1860: 73 73 69 6f 6e 2d 69 64 0a 3b 3b 20 20 20 20 64 ssion-id.;; d
1870: 6f 6d 61 69 6e 0a 3b 3b 20 20 20 20 74 6f 70 70 omain.;; topp
1880: 61 67 65 20 20 20 20 20 20 3b 3b 20 64 65 66 61 age ;; defa
1890: 75 6c 74 73 20 74 6f 20 22 69 6e 64 65 78 22 20 ults to "index"
18a0: 2d 20 6f 76 65 72 72 69 64 65 20 69 6e 20 2e 73 - override in .s
18b0: 74 6d 6c 2e 63 6f 6e 66 69 67 20 69 66 20 64 65 tml.config if de
18c0: 73 69 72 65 64 0a 3b 3b 20 20 20 20 70 61 67 65 sired.;; page
18d0: 20 20 20 20 20 20 20 20 20 3b 3b 20 74 68 65 20 ;; the
18e0: 70 61 67 65 20 6e 61 6d 65 20 2d 20 64 65 66 61 page name - defa
18f0: 75 6c 74 73 20 74 6f 20 68 6f 6d 65 0a 3b 3b 20 ults to home.;;
1900: 20 20 20 63 75 72 72 2d 70 61 67 65 20 20 20 20 curr-page
1910: 3b 3b 20 74 68 65 20 63 75 72 72 65 6e 74 20 70 ;; the current p
1920: 61 67 65 20 62 65 69 6e 67 20 65 76 61 6c 75 61 age being evalua
1930: 74 65 64 0a 3b 3b 20 20 20 20 63 6f 6e 74 65 6e ted.;; conten
1940: 74 2d 74 79 70 65 20 3b 3b 20 74 68 65 20 64 65 t-type ;; the de
1950: 66 61 75 6c 74 20 63 6f 6e 74 65 6e 74 20 74 79 fault content ty
1960: 70 65 20 69 73 20 74 65 78 74 2f 68 74 6d 6c 2c pe is text/html,
1970: 20 6f 76 65 72 72 69 64 65 20 74 6f 20 64 65 6c override to del
1980: 69 76 65 72 20 6f 74 68 65 72 20 73 74 75 66 66 iver other stuff
1990: 0a 3b 3b 20 20 20 20 70 61 67 65 2d 74 79 70 65 .;; page-type
19a0: 20 20 20 20 3b 3b 20 75 73 65 20 69 6e 20 63 6f ;; use in co
19b0: 6e 6a 75 6e 63 74 69 6f 6e 20 77 69 74 68 20 63 njunction with c
19c0: 6f 6e 74 65 6e 74 2d 74 79 70 65 20 74 6f 20 64 ontent-type to d
19d0: 65 6c 69 76 65 72 20 6f 74 68 65 72 20 70 61 79 eliver other pay
19e0: 6c 6f 61 64 73 0a 3b 3b 20 20 20 20 73 72 6f 6f loads.;; sroo
19f0: 74 0a 3b 3b 20 20 20 20 74 77 69 6b 69 64 69 72 t.;; twikidir
1a00: 20 20 20 20 20 3b 3b 20 6c 6f 63 61 74 69 6f 6e ;; location
1a10: 20 66 6f 72 20 74 77 69 6b 69 73 20 2d 20 6e 65 for twikis - ne
1a20: 65 64 73 20 74 6f 20 62 65 20 66 75 6c 6c 79 20 eds to be fully
1a30: 77 72 69 74 61 62 6c 65 20 62 79 20 77 65 62 20 writable by web
1a40: 73 65 72 76 65 72 0a 3b 3b 20 20 20 20 70 61 67 server.;; pag
1a50: 65 64 61 74 0a 3b 3b 20 20 20 20 61 6c 74 2d 70 edat.;; alt-p
1a60: 61 67 65 2d 64 61 74 0a 3b 3b 20 20 20 20 70 61 age-dat.;; pa
1a70: 67 65 76 61 72 73 20 20 20 20 20 3b 3b 20 73 65 gevars ;; se
1a80: 73 73 69 6f 6e 20 76 61 72 73 20 73 70 65 63 69 ssion vars speci
1a90: 66 69 63 20 74 6f 20 74 68 69 73 20 70 61 67 65 fic to this page
1aa0: 0a 3b 3b 20 20 20 20 70 61 67 65 76 61 72 73 2d .;; pagevars-
1ab0: 62 65 66 6f 72 65 0a 3b 3b 20 20 20 20 73 65 73 before.;; ses
1ac0: 73 69 6f 6e 76 61 72 73 20 20 3b 3b 20 73 65 73 sionvars ;; ses
1ad0: 73 69 6f 6e 20 76 61 72 73 20 76 69 73 69 62 6c sion vars visibl
1ae0: 65 20 74 6f 20 61 6c 6c 20 70 61 67 65 73 0a 3b e to all pages.;
1af0: 3b 20 20 20 20 73 65 73 73 69 6f 6e 76 61 72 73 ; sessionvars
1b00: 2d 62 65 66 6f 72 65 0a 3b 3b 20 20 20 20 67 6c -before.;; gl
1b10: 6f 62 61 6c 76 61 72 73 20 20 20 3b 3b 20 67 6c obalvars ;; gl
1b20: 6f 62 61 6c 20 76 61 72 73 20 76 69 73 69 62 6c obal vars visibl
1b30: 65 20 74 6f 20 61 6c 6c 20 73 65 73 73 69 6f 6e e to all session
1b40: 73 0a 3b 3b 20 20 20 20 67 6c 6f 62 61 6c 76 61 s.;; globalva
1b50: 72 73 2d 62 65 66 6f 72 65 0a 3b 3b 20 20 20 20 rs-before.;;
1b60: 6c 6f 67 70 74 0a 3b 3b 20 20 20 20 66 6f 72 6d logpt.;; form
1b70: 64 61 74 0a 3b 3b 20 20 20 20 72 65 71 75 65 73 dat.;; reques
1b80: 74 2d 6d 65 74 68 6f 64 0a 3b 3b 20 20 20 20 73 t-method.;; s
1b90: 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 0a 3b 3b ession-cookie.;;
1ba0: 20 20 20 20 63 75 72 72 2d 65 72 72 0a 3b 3b 20 curr-err.;;
1bb0: 20 20 20 6c 6f 67 2d 70 6f 72 74 0a 3b 3b 20 20 log-port.;;
1bc0: 20 20 6c 6f 67 66 69 6c 65 0a 3b 3b 20 20 20 20 logfile.;;
1bd0: 73 65 65 6e 2d 70 61 67 65 73 0a 3b 3b 20 20 20 seen-pages.;;
1be0: 20 70 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 20 page-dir-style
1bf0: 20 3b 3b 20 23 74 20 3d 20 6e 65 77 20 73 74 79 ;; #t = new sty
1c00: 6c 65 2c 20 23 66 20 3d 20 6f 6c 64 20 73 74 79 le, #f = old sty
1c10: 6c 65 0a 3b 3b 20 20 20 20 64 65 62 75 67 6d 6f le.;; debugmo
1c20: 64 65 29 29 0a 0a 3b 3b 20 53 50 4c 49 54 20 49 de))..;; SPLIT I
1c30: 4e 54 4f 20 53 54 52 41 49 47 48 54 20 46 4f 52 NTO STRAIGHT FOR
1c40: 57 41 52 44 20 49 4e 49 54 20 41 4e 44 20 43 4f WARD INIT AND CO
1c50: 4d 50 4c 45 58 20 49 4e 49 54 0a 28 64 65 66 69 MPLEX INIT.(defi
1c60: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 69 6e 69 74 ne (session:init
1c70: 69 61 6c 69 7a 65 20 73 65 6c 66 29 0a 20 20 28 ialize self). (
1c80: 73 64 61 74 2d 73 65 74 2d 64 62 74 79 70 65 21 sdat-set-dbtype!
1c90: 20 73 65 6c 66 20 20 20 20 20 20 27 70 67 29 0a self 'pg).
1ca0: 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 (sdat-set-page
1cb0: 21 20 73 65 6c 66 20 20 20 20 20 20 20 20 22 68 ! self "h
1cc0: 6f 6d 65 22 29 20 20 20 20 20 20 20 20 3b 3b 20 ome") ;;
1cd0: 74 68 65 73 65 20 61 72 65 20 64 65 66 61 75 6c these are defaul
1ce0: 74 73 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 63 ts. (sdat-set-c
1cf0: 75 72 72 2d 70 61 67 65 21 20 73 65 6c 66 20 20 urr-page! self
1d00: 20 22 68 6f 6d 65 22 29 0a 20 20 28 73 64 61 74 "home"). (sdat
1d10: 2d 73 65 74 2d 63 6f 6e 74 65 6e 74 2d 74 79 70 -set-content-typ
1d20: 65 21 20 73 65 6c 66 20 22 43 6f 6e 74 65 6e 74 e! self "Content
1d30: 2d 74 79 70 65 3a 20 74 65 78 74 2f 68 74 6d 6c -type: text/html
1d40: 3b 20 63 68 61 72 73 65 74 3d 69 73 6f 2d 38 38 ; charset=iso-88
1d50: 35 39 2d 31 5c 6e 5c 6e 22 29 0a 20 20 28 73 64 59-1\n\n"). (sd
1d60: 61 74 2d 73 65 74 2d 70 61 67 65 2d 74 79 70 65 at-set-page-type
1d70: 21 20 73 65 6c 66 20 20 20 27 68 74 6d 6c 29 0a ! self 'html).
1d80: 20 20 28 73 64 61 74 2d 73 65 74 2d 74 6f 70 70 (sdat-set-topp
1d90: 61 67 65 21 20 73 65 6c 66 20 20 20 20 20 22 69 age! self "i
1da0: 6e 64 65 78 22 29 0a 20 20 28 73 64 61 74 2d 73 ndex"). (sdat-s
1db0: 65 74 2d 70 61 72 61 6d 73 21 20 73 65 6c 66 20 et-params! self
1dc0: 20 20 20 20 20 27 28 29 29 20 20 20 20 20 20 20 '())
1dd0: 20 20 20 20 3b 3b 0a 20 20 28 73 64 61 74 2d 73 ;;. (sdat-s
1de0: 65 74 2d 70 61 74 68 2d 70 61 72 61 6d 73 21 20 et-path-params!
1df0: 73 65 6c 66 20 27 28 29 29 0a 20 20 28 73 64 61 self '()). (sda
1e00: 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 t-set-session-ke
1e10: 79 21 20 73 65 6c 66 20 23 66 29 0a 20 20 28 73 y! self #f). (s
1e20: 64 61 74 2d 73 65 74 2d 70 61 67 65 64 61 74 21 dat-set-pagedat!
1e30: 20 73 65 6c 66 20 20 20 20 20 27 28 29 29 0a 20 self '()).
1e40: 20 28 73 64 61 74 2d 73 65 74 2d 61 6c 74 2d 70 (sdat-set-alt-p
1e50: 61 67 65 2d 64 61 74 21 20 73 65 6c 66 20 23 66 age-dat! self #f
1e60: 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 73 72 ). (sdat-set-sr
1e70: 6f 6f 74 21 20 73 65 6c 66 20 20 20 20 20 20 20 oot! self
1e80: 22 2e 2f 22 29 0a 20 20 28 73 64 61 74 2d 73 65 "./"). (sdat-se
1e90: 74 2d 73 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 t-session-cookie
1ea0: 21 20 73 65 6c 66 20 23 66 29 0a 20 20 28 73 64 ! self #f). (sd
1eb0: 61 74 2d 73 65 74 2d 63 75 72 72 2d 65 72 72 21 at-set-curr-err!
1ec0: 20 73 65 6c 66 20 23 66 29 0a 20 20 28 73 64 61 self #f). (sda
1ed0: 74 2d 73 65 74 2d 6c 6f 67 2d 70 6f 72 74 21 20 t-set-log-port!
1ee0: 73 65 6c 66 20 28 63 75 72 72 65 6e 74 2d 65 72 self (current-er
1ef0: 72 6f 72 2d 70 6f 72 74 29 29 0a 20 20 28 73 64 ror-port)). (sd
1f00: 61 74 2d 73 65 74 2d 73 65 65 6e 2d 70 61 67 65 at-set-seen-page
1f10: 73 21 20 73 65 6c 66 20 27 28 29 29 0a 20 20 28 s! self '()). (
1f20: 73 64 61 74 2d 73 65 74 2d 70 61 67 65 2d 64 69 sdat-set-page-di
1f30: 72 2d 73 74 79 6c 65 21 20 73 65 6c 66 20 23 74 r-style! self #t
1f40: 29 20 3b 3b 20 23 74 20 3a 20 70 61 67 65 73 2f ) ;; #t : pages/
1f50: 3c 70 61 67 65 6e 61 6d 65 3e 5f 28 76 69 65 77 <pagename>_(view
1f60: 7c 63 6e 74 6c 29 2e 73 63 6d 0a 20 20 20 20 20 |cntl).scm.
1f70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1f80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1f90: 20 3b 3b 20 23 66 20 3a 20 70 61 67 65 73 2f 3c ;; #f : pages/<
1fa0: 70 61 67 65 6e 61 6d 65 3e 2f 28 76 69 65 77 7c pagename>/(view|
1fb0: 63 6f 6e 74 72 6f 6c 29 2e 73 63 6d 20 0a 20 20 control).scm .
1fc0: 28 73 64 61 74 2d 73 65 74 2d 64 65 62 75 67 6d (sdat-set-debugm
1fd0: 6f 64 65 21 20 20 20 20 20 20 20 20 20 20 73 65 ode! se
1fe0: 6c 66 20 23 66 29 0a 20 20 09 09 09 20 20 20 20 lf #f). ...
1ff0: 20 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 . (sdat-set-pa
2000: 67 65 76 61 72 73 21 20 20 20 20 20 20 20 20 20 gevars!
2010: 20 20 73 65 6c 66 20 28 6d 61 6b 65 2d 68 61 73 self (make-has
2020: 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 73 64 61 h-table)). (sda
2030: 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 t-set-sessionvar
2040: 73 21 20 20 20 20 20 20 20 20 73 65 6c 66 20 28 s! self (
2050: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
2060: 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 67 6c ). (sdat-set-gl
2070: 6f 62 61 6c 76 61 72 73 21 20 20 20 20 20 20 20 obalvars!
2080: 20 20 73 65 6c 66 20 28 6d 61 6b 65 2d 68 61 73 self (make-has
2090: 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 73 64 61 h-table)). (sda
20a0: 74 2d 73 65 74 2d 70 61 67 65 76 61 72 73 2d 62 t-set-pagevars-b
20b0: 65 66 6f 72 65 21 20 20 20 20 73 65 6c 66 20 28 efore! self (
20c0: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
20d0: 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 ). (sdat-set-se
20e0: 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 ssionvars-before
20f0: 21 20 73 65 6c 66 20 28 6d 61 6b 65 2d 68 61 73 ! self (make-has
2100: 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 73 64 61 h-table)). (sda
2110: 74 2d 73 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 t-set-globalvars
2120: 2d 62 65 66 6f 72 65 21 20 20 73 65 6c 66 20 28 -before! self (
2130: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
2140: 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 64 6f ). (sdat-set-do
2150: 6d 61 69 6e 21 20 20 20 20 20 20 20 20 20 20 20 main!
2160: 20 20 73 65 6c 66 20 22 6c 6f 63 61 68 6f 73 74 self "locahost
2170: 22 29 20 20 20 3b 3b 20 65 6e 64 20 6f 66 20 64 ") ;; end of d
2180: 65 66 61 75 6c 74 73 0a 20 20 28 6c 65 74 2a 20 efaults. (let*
2190: 28 28 72 61 77 63 6f 6e 66 69 67 64 61 74 20 28 ((rawconfigdat (
21a0: 73 65 73 73 69 6f 6e 3a 72 65 61 64 2d 63 6f 6e session:read-con
21b0: 66 69 67 20 73 65 6c 66 29 29 0a 09 20 28 63 6f fig self)).. (co
21c0: 6e 66 69 67 64 61 74 20 28 69 66 20 72 61 77 63 nfigdat (if rawc
21d0: 6f 6e 66 69 67 64 61 74 20 28 65 76 61 6c 20 72 onfigdat (eval r
21e0: 61 77 63 6f 6e 66 69 67 64 61 74 29 20 27 28 29 awconfigdat) '()
21f0: 29 29 0a 09 20 28 73 72 6f 6f 74 20 20 20 20 20 )).. (sroot
2200: 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 27 73 (s:find-param 's
2210: 72 6f 6f 74 20 20 20 20 63 6f 6e 66 69 67 64 61 root configda
2220: 74 29 29 0a 09 20 28 6c 6f 67 66 69 6c 65 20 20 t)).. (logfile
2230: 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 27 (s:find-param '
2240: 6c 6f 67 66 69 6c 65 20 20 63 6f 6e 66 69 67 64 logfile configd
2250: 61 74 29 29 0a 09 20 28 64 62 74 79 70 65 20 20 at)).. (dbtype
2260: 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 (s:find-param
2270: 27 64 62 74 79 70 65 20 20 20 63 6f 6e 66 69 67 'dbtype config
2280: 64 61 74 29 29 0a 09 20 28 64 62 69 6e 69 74 20 dat)).. (dbinit
2290: 20 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d (s:find-param
22a0: 20 27 64 62 69 6e 69 74 20 20 20 63 6f 6e 66 69 'dbinit confi
22b0: 67 64 61 74 29 29 0a 09 20 28 64 6f 6d 61 69 6e gdat)).. (domain
22c0: 20 20 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 (s:find-para
22d0: 6d 20 27 64 6f 6d 61 69 6e 20 20 20 63 6f 6e 66 m 'domain conf
22e0: 69 67 64 61 74 29 29 0a 09 20 28 74 77 69 6b 69 igdat)).. (twiki
22f0: 64 69 72 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 dir (s:find-par
2300: 61 6d 20 27 74 77 69 6b 69 64 69 72 20 63 6f 6e am 'twikidir con
2310: 66 69 67 64 61 74 29 29 0a 09 20 28 70 61 67 65 figdat)).. (page
2320: 2d 64 69 72 20 20 28 73 3a 66 69 6e 64 2d 70 61 -dir (s:find-pa
2330: 72 61 6d 20 27 70 61 67 65 2d 64 69 72 2d 73 74 ram 'page-dir-st
2340: 79 6c 65 20 63 6f 6e 66 69 67 64 61 74 29 29 0a yle configdat)).
2350: 09 20 28 64 65 62 75 67 6d 6f 64 65 20 28 73 3a . (debugmode (s:
2360: 66 69 6e 64 2d 70 61 72 61 6d 20 27 64 65 62 75 find-param 'debu
2370: 67 6d 6f 64 65 20 63 6f 6e 66 69 67 64 61 74 29 gmode configdat)
2380: 29 29 0a 20 20 20 20 28 69 66 20 73 72 6f 6f 74 )). (if sroot
2390: 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d 73 72 (sdat-set-sr
23a0: 6f 6f 74 21 20 20 20 20 73 65 6c 66 20 73 72 6f oot! self sro
23b0: 6f 74 29 29 0a 20 20 20 20 28 69 66 20 6c 6f 67 ot)). (if log
23c0: 66 69 6c 65 20 20 28 73 64 61 74 2d 73 65 74 2d file (sdat-set-
23d0: 6c 6f 67 66 69 6c 65 21 20 20 73 65 6c 66 20 6c logfile! self l
23e0: 6f 67 66 69 6c 65 29 29 0a 20 20 20 20 28 69 66 ogfile)). (if
23f0: 20 64 62 74 79 70 65 20 20 20 28 73 64 61 74 2d dbtype (sdat-
2400: 73 65 74 2d 64 62 74 79 70 65 21 20 20 20 73 65 set-dbtype! se
2410: 6c 66 20 64 62 74 79 70 65 29 29 0a 20 20 20 20 lf dbtype)).
2420: 28 69 66 20 64 62 69 6e 69 74 20 20 20 28 73 64 (if dbinit (sd
2430: 61 74 2d 73 65 74 2d 64 62 69 6e 69 74 21 20 20 at-set-dbinit!
2440: 20 73 65 6c 66 20 64 62 69 6e 69 74 29 29 0a 20 self dbinit)).
2450: 20 20 20 28 69 66 20 64 6f 6d 61 69 6e 20 20 20 (if domain
2460: 28 73 64 61 74 2d 73 65 74 2d 64 6f 6d 61 69 6e (sdat-set-domain
2470: 21 20 20 20 73 65 6c 66 20 64 6f 6d 61 69 6e 29 ! self domain)
2480: 29 0a 20 20 20 20 28 69 66 20 74 77 69 6b 69 64 ). (if twikid
2490: 69 72 20 28 73 64 61 74 2d 73 65 74 2d 74 77 69 ir (sdat-set-twi
24a0: 6b 69 64 69 72 21 20 73 65 6c 66 20 74 77 69 6b kidir! self twik
24b0: 69 64 69 72 29 29 0a 20 20 20 20 28 69 66 20 64 idir)). (if d
24c0: 65 62 75 67 6d 6f 64 65 20 28 73 64 61 74 2d 73 ebugmode (sdat-s
24d0: 65 74 2d 64 65 62 75 67 6d 6f 64 65 21 20 73 65 et-debugmode! se
24e0: 6c 66 20 64 65 62 75 67 6d 6f 64 65 29 29 0a 20 lf debugmode)).
24f0: 20 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 67 (sdat-set-pag
2500: 65 2d 64 69 72 2d 73 74 79 6c 65 21 20 73 65 6c e-dir-style! sel
2510: 66 20 70 61 67 65 2d 64 69 72 29 0a 20 20 20 20 f page-dir).
2520: 3b 3b 20 28 70 72 69 6e 74 20 22 63 6f 6e 66 69 ;; (print "confi
2530: 67 64 61 74 3a 20 22 29 28 70 70 20 63 6f 6e 66 gdat: ")(pp conf
2540: 69 67 64 61 74 29 0a 20 20 20 20 3b 3b 28 73 65 igdat). ;;(se
2550: 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 ssion:log self "
2560: 73 72 6f 6f 74 3a 20 22 20 73 72 6f 6f 74 20 22 sroot: " sroot "
2570: 20 6c 6f 67 66 69 6c 65 3a 20 22 20 6c 6f 67 66 logfile: " logf
2580: 69 6c 65 20 22 20 64 62 74 79 70 65 3a 20 22 20 ile " dbtype: "
2590: 64 62 74 79 70 65 20 0a 20 20 20 20 3b 3b 09 09 dbtype . ;;..
25a0: 20 22 20 64 62 69 6e 69 74 3a 20 22 20 64 62 69 " dbinit: " dbi
25b0: 6e 69 74 20 22 20 64 6f 6d 61 69 6e 3a 20 22 20 nit " domain: "
25c0: 64 6f 6d 61 69 6e 20 22 20 70 61 67 65 2d 64 69 domain " page-di
25d0: 72 2d 73 74 79 6c 65 3a 20 22 20 70 61 67 65 2d r-style: " page-
25e0: 64 69 72 29 0a 20 20 20 20 29 0a 20 20 29 0a 3b dir). ). ).;
25f0: 3b 20 20 20 28 6c 65 74 20 28 28 64 62 74 79 70 ; (let ((dbtyp
2600: 65 20 28 73 64 61 74 2d 67 65 74 2d 64 62 74 79 e (sdat-get-dbty
2610: 70 65 20 73 65 6c 66 29 29 29 0a 3b 3b 20 20 20 pe self))).;;
2620: 20 20 28 70 72 69 6e 74 20 22 64 62 74 79 70 65 (print "dbtype
2630: 3a 20 22 20 64 62 74 79 70 65 29 0a 3b 3b 20 20 : " dbtype).;;
2640: 20 20 20 28 73 64 61 74 2d 73 65 74 2d 64 62 74 (sdat-set-dbt
2650: 79 70 65 21 20 73 65 6c 66 20 28 65 76 61 6c 20 ype! self (eval
2660: 64 62 74 79 70 65 29 29 29 29 0a 0a 28 64 65 66 dbtype))))..(def
2670: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 ine (session:set
2680: 75 70 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 20 up self). (let
2690: 28 28 64 62 74 79 70 65 20 28 73 64 61 74 2d 67 ((dbtype (sdat-g
26a0: 65 74 2d 64 62 74 79 70 65 20 73 65 6c 66 29 29 et-dbtype self))
26b0: 0a 09 28 64 62 69 6e 69 74 20 28 65 76 61 6c 20 ..(dbinit (eval
26c0: 28 73 64 61 74 2d 67 65 74 2d 64 62 69 6e 69 74 (sdat-get-dbinit
26d0: 20 73 65 6c 66 29 29 29 0a 09 28 64 62 65 78 69 self)))..(dbexi
26e0: 73 74 73 20 23 66 29 29 0a 20 20 20 20 28 6c 65 sts #f)). (le
26f0: 74 20 28 28 64 62 66 6e 61 6d 65 20 28 61 6c 69 t ((dbfname (ali
2700: 73 74 2d 72 65 66 20 27 64 62 6e 61 6d 65 20 64 st-ref 'dbname d
2710: 62 69 6e 69 74 29 29 29 0a 20 20 20 20 20 20 28 binit))). (
2720: 69 66 20 28 65 71 3f 20 64 62 74 79 70 65 20 27 if (eq? dbtype '
2730: 73 71 6c 69 74 65 33 29 0a 09 20 20 28 69 66 20 sqlite3).. (if
2740: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 64 62 (file-exists? db
2750: 66 6e 61 6d 65 29 0a 09 20 20 20 20 20 20 28 62 fname).. (b
2760: 65 67 69 6e 0a 09 09 3b 3b 20 28 73 65 73 73 69 egin...;; (sessi
2770: 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 73 65 74 on:log self "set
2780: 74 69 6e 67 20 64 62 65 78 69 73 74 73 20 74 6f ting dbexists to
2790: 20 23 74 22 29 0a 09 09 28 73 65 74 21 20 64 62 #t")...(set! db
27a0: 65 78 69 73 74 73 20 23 74 29 29 29 29 0a 20 20 exists #t)))).
27b0: 20 20 20 20 3b 3b 20 28 73 65 73 73 69 6f 6e 3a ;; (session:
27c0: 6c 6f 67 20 73 65 6c 66 20 22 64 62 74 79 70 65 log self "dbtype
27d0: 3a 20 22 20 64 62 74 79 70 65 20 22 20 64 62 66 : " dbtype " dbf
27e0: 6e 61 6d 65 3a 20 22 20 64 62 66 6e 61 6d 65 20 name: " dbfname
27f0: 22 20 64 62 65 78 69 73 74 73 3a 20 22 20 64 62 " dbexists: " db
2800: 65 78 69 73 74 73 29 29 0a 20 20 20 20 20 20 29 exists)). )
2810: 0a 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d 63 . (sdat-set-c
2820: 6f 6e 6e 21 20 73 65 6c 66 20 28 64 62 69 3a 6f onn! self (dbi:o
2830: 70 65 6e 20 64 62 74 79 70 65 20 64 62 69 6e 69 pen dbtype dbini
2840: 74 29 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 t)). (if (and
2850: 20 28 6e 6f 74 20 64 62 65 78 69 73 74 73 29 28 (not dbexists)(
2860: 65 71 3f 20 64 62 74 79 70 65 20 27 73 71 6c 69 eq? dbtype 'sqli
2870: 74 65 33 29 29 0a 20 09 28 62 65 67 69 6e 0a 09 te3)). .(begin..
2880: 20 20 28 70 72 69 6e 74 20 22 57 41 52 4e 49 4e (print "WARNIN
2890: 47 3a 20 53 65 74 74 69 6e 67 20 75 70 20 73 65 G: Setting up se
28a0: 73 73 69 6f 6e 20 64 62 20 77 69 74 68 20 73 71 ssion db with sq
28b0: 6c 69 74 65 33 22 29 0a 09 20 20 28 73 65 73 73 lite3").. (sess
28c0: 69 6f 6e 3a 73 65 74 75 70 2d 64 62 20 73 65 6c ion:setup-db sel
28d0: 66 29 29 29 0a 20 20 20 20 28 73 65 73 73 69 6f f))). (sessio
28e0: 6e 3a 70 72 6f 63 65 73 73 2d 75 72 6c 2d 70 61 n:process-url-pa
28f0: 74 68 20 73 65 6c 66 29 0a 20 20 20 20 28 73 65 th self). (se
2900: 73 73 69 6f 6e 3a 73 65 74 75 70 2d 73 65 73 73 ssion:setup-sess
2910: 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 0a 20 20 ion-key self).
2920: 20 20 3b 3b 20 63 61 70 74 75 72 65 20 73 74 64 ;; capture std
2930: 69 6e 20 69 66 20 74 68 69 73 20 69 73 20 61 20 in if this is a
2940: 50 4f 53 54 0a 20 20 20 20 28 73 64 61 74 2d 73 POST. (sdat-s
2950: 65 74 2d 72 65 71 75 65 73 74 2d 6d 65 74 68 6f et-request-metho
2960: 64 21 20 73 65 6c 66 20 28 67 65 74 2d 65 6e 76 d! self (get-env
2970: 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c ironment-variabl
2980: 65 20 22 52 45 51 55 45 53 54 5f 4d 45 54 48 4f e "REQUEST_METHO
2990: 44 22 29 29 0a 20 20 20 20 28 73 64 61 74 2d 73 D")). (sdat-s
29a0: 65 74 2d 66 6f 72 6d 64 61 74 21 20 73 65 6c 66 et-formdat! self
29b0: 20 28 66 6f 72 6d 64 61 74 3a 6c 6f 61 64 2d 61 (formdat:load-a
29c0: 6c 6c 29 29 29 29 0a 0a 3b 3b 20 73 65 74 75 70 ll))))..;; setup
29d0: 20 74 68 65 20 64 62 20 77 69 74 68 20 73 65 73 the db with ses
29e0: 73 69 6f 6e 20 74 61 62 6c 65 73 2c 20 77 6f 72 sion tables, wor
29f0: 6b 73 20 66 6f 72 20 73 71 6c 69 74 65 20 6f 6e ks for sqlite on
2a00: 6c 79 20 72 69 67 68 74 20 6e 6f 77 0a 28 64 65 ly right now.(de
2a10: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 65 fine (session:se
2a20: 74 75 70 2d 64 62 20 73 65 6c 66 29 0a 20 20 28 tup-db self). (
2a30: 6c 65 74 20 28 28 63 6f 6e 6e 20 28 73 64 61 74 let ((conn (sdat
2a40: 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 -get-conn self))
2a50: 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 ). (for-each
2a60: 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 73 . (lambda (s
2a70: 74 6d 74 29 0a 20 20 20 20 20 20 20 28 64 62 69 tmt). (dbi
2a80: 3a 65 78 65 63 20 63 6f 6e 6e 20 73 74 6d 74 29 :exec conn stmt)
2a90: 29 0a 20 20 20 20 20 28 6c 69 73 74 20 22 43 52 ). (list "CR
2aa0: 45 41 54 45 20 54 41 42 4c 45 20 73 65 73 73 69 EATE TABLE sessi
2ab0: 6f 6e 5f 76 61 72 73 20 28 69 64 20 49 4e 54 45 on_vars (id INTE
2ac0: 47 45 52 20 50 52 49 4d 41 52 59 20 4b 45 59 2c GER PRIMARY KEY,
2ad0: 73 65 73 73 69 6f 6e 5f 69 64 20 49 4e 54 45 47 session_id INTEG
2ae0: 45 52 2c 70 61 67 65 20 54 45 58 54 2c 6b 65 79 ER,page TEXT,key
2af0: 20 54 45 58 54 2c 76 61 6c 75 65 20 54 45 58 54 TEXT,value TEXT
2b00: 29 3b 22 0a 09 20 20 20 22 43 52 45 41 54 45 20 );".. "CREATE
2b10: 54 41 42 4c 45 20 73 65 73 73 69 6f 6e 73 20 28 TABLE sessions (
2b20: 69 64 20 49 4e 54 45 47 45 52 20 50 52 49 4d 41 id INTEGER PRIMA
2b30: 52 59 20 4b 45 59 2c 73 65 73 73 69 6f 6e 5f 6b RY KEY,session_k
2b40: 65 79 20 54 45 58 54 2c 6c 61 73 74 5f 75 73 65 ey TEXT,last_use
2b50: 64 20 54 49 4d 45 53 54 41 4d 50 29 3b 22 0a 20 d TIMESTAMP);".
2b60: 20 20 20 20 20 20 20 20 20 20 22 43 52 45 41 54 "CREAT
2b70: 45 20 54 41 42 4c 45 20 6d 65 74 61 64 61 74 61 E TABLE metadata
2b80: 20 28 69 64 20 49 4e 54 45 47 45 52 20 50 52 49 (id INTEGER PRI
2b90: 4d 41 52 59 20 4b 45 59 2c 6b 65 79 20 54 45 58 MARY KEY,key TEX
2ba0: 54 2c 76 61 6c 75 65 20 54 45 58 54 29 3b 22 29 T,value TEXT);")
2bb0: 29 29 29 0a 3b 3b 20 20 3b 3b 20 69 66 20 77 65 ))).;; ;; if we
2bc0: 20 68 61 76 65 20 61 20 73 65 73 73 69 6f 6e 5f have a session_
2bd0: 6b 65 79 20 6c 6f 6f 6b 20 75 70 20 74 68 65 20 key look up the
2be0: 73 65 73 73 69 6f 6e 2d 69 64 20 61 6e 64 20 73 session-id and s
2bf0: 74 6f 72 65 20 69 74 0a 3b 3b 20 20 28 73 64 61 tore it.;; (sda
2c00: 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 t-set-session-id
2c10: 21 20 73 65 6c 66 20 28 73 65 73 73 69 6f 6e 3a ! self (session:
2c20: 67 65 74 2d 69 64 20 73 65 6c 66 29 29 29 0a 0a get-id self)))..
2c30: 3b 3b 20 6f 6e 6c 79 20 73 65 74 20 73 65 73 73 ;; only set sess
2c40: 69 6f 6e 2d 63 6f 6f 6b 69 65 20 77 68 65 6e 20 ion-cookie when
2c50: 61 20 6e 65 77 20 73 65 73 73 69 6f 6e 20 69 73 a new session is
2c60: 20 63 72 65 61 74 65 64 0a 28 64 65 66 69 6e 65 created.(define
2c70: 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 2d (session:setup-
2c80: 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 session-key self
2c90: 29 20 20 0a 20 20 28 6c 65 74 2a 20 28 28 73 6b ) . (let* ((sk
2ca0: 20 20 28 73 65 73 73 69 6f 6e 3a 65 78 74 72 61 (session:extra
2cb0: 63 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 ct-session-key s
2cc0: 65 6c 66 29 29 0a 20 20 20 20 20 20 20 20 20 28 elf)). (
2cd0: 73 69 64 20 28 69 66 20 73 6b 20 28 73 65 73 73 sid (if sk (sess
2ce0: 69 6f 6e 3a 67 65 74 2d 69 64 20 73 65 6c 66 20 ion:get-id self
2cf0: 73 6b 29 20 23 66 29 29 29 0a 20 20 20 20 28 69 sk) #f))). (i
2d00: 66 20 28 6e 6f 74 20 73 69 64 29 20 3b 3b 20 6e f (not sid) ;; n
2d10: 65 65 64 20 61 20 6e 65 77 20 6b 65 79 0a 20 20 eed a new key.
2d20: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 6e 65 (let* ((ne
2d30: 77 2d 6b 65 79 20 28 73 65 73 73 69 6f 6e 3a 67 w-key (session:g
2d40: 65 74 2d 6e 65 77 2d 6b 65 79 20 73 65 6c 66 29 et-new-key self)
2d50: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
2d60: 20 28 6e 65 77 2d 73 69 64 20 28 73 65 73 73 69 (new-sid (sessi
2d70: 6f 6e 3a 67 65 74 2d 69 64 20 73 65 6c 66 20 6e on:get-id self n
2d80: 65 77 2d 6b 65 79 29 29 29 0a 20 20 20 20 20 20 ew-key))).
2d90: 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 (sdat-set-se
2da0: 73 73 69 6f 6e 2d 6b 65 79 21 20 73 65 6c 66 20 ssion-key! self
2db0: 6e 65 77 2d 6b 65 79 29 0a 20 20 20 20 20 20 20 new-key).
2dc0: 20 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 (sdat-set-ses
2dd0: 73 69 6f 6e 2d 69 64 21 20 73 65 6c 66 20 6e 65 sion-id! self ne
2de0: 77 2d 73 69 64 29 0a 20 20 20 20 20 20 20 20 20 w-sid).
2df0: 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 (sdat-set-sessi
2e00: 6f 6e 2d 63 6f 6f 6b 69 65 21 20 73 65 6c 66 20 on-cookie! self
2e10: 28 73 65 73 73 69 6f 6e 3a 6d 61 6b 65 2d 63 6f (session:make-co
2e20: 6f 6b 69 65 20 73 65 6c 66 29 29 29 0a 20 20 20 okie self))).
2e30: 20 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d 73 (sdat-set-s
2e40: 65 73 73 69 6f 6e 2d 69 64 21 20 73 65 6c 66 20 ession-id! self
2e50: 73 69 64 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 sid))))..(define
2e60: 20 28 73 65 73 73 69 6f 6e 3a 6d 61 6b 65 2d 63 (session:make-c
2e70: 6f 6f 6b 69 65 20 73 65 6c 66 29 0a 20 20 3b 3b ookie self). ;;
2e80: 20 28 6c 69 73 74 20 28 63 6f 6e 63 20 22 73 65 (list (conc "se
2e90: 73 73 69 6f 6e 5f 6b 65 79 3d 22 20 28 73 64 61 ssion_key=" (sda
2ea0: 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 t-get-session-ke
2eb0: 79 20 73 65 6c 66 29 20 22 3b 20 50 61 74 68 3d y self) "; Path=
2ec0: 2f 3b 20 44 6f 6d 61 69 6e 3d 2e 22 20 28 73 64 /; Domain=." (sd
2ed0: 61 74 2d 67 65 74 2d 64 6f 6d 61 69 6e 20 73 65 at-get-domain se
2ee0: 6c 66 29 20 22 3b 20 4d 61 78 2d 41 67 65 3d 22 lf) "; Max-Age="
2ef0: 20 28 2a 20 38 36 34 30 30 20 31 34 29 20 22 3b (* 86400 14) ";
2f00: 20 56 65 72 73 69 6f 6e 3d 31 22 29 29 29 20 0a Version=1"))) .
2f10: 20 20 3b 3b 20 41 63 63 6f 72 64 69 6e 67 20 74 ;; According t
2f20: 6f 20 0a 20 20 3b 3b 20 20 20 20 68 74 74 70 3a o . ;; http:
2f30: 2f 2f 77 77 77 2e 63 6f 64 65 6d 61 72 76 65 6c //www.codemarvel
2f40: 73 2e 63 6f 6d 2f 32 30 31 30 2f 31 31 2f 61 70 s.com/2010/11/ap
2f50: 61 63 68 65 2d 72 65 77 72 69 74 65 72 75 6c 65 ache-rewriterule
2f60: 2d 73 65 74 2d 61 2d 63 6f 6f 6b 69 65 2d 6f 6e -set-a-cookie-on
2f70: 2d 6c 6f 63 61 6c 68 6f 73 74 2f 0a 0a 20 20 3b -localhost/.. ;
2f80: 3b 20 20 48 65 72 65 20 61 72 65 20 74 68 65 20 ; Here are the
2f90: 32 20 28 6f 66 74 65 6e 20 6c 65 66 74 20 6f 75 2 (often left ou
2fa0: 74 29 20 72 65 71 75 69 72 65 6d 65 6e 74 73 20 t) requirements
2fb0: 74 6f 20 73 65 74 20 61 20 63 6f 6f 6b 69 65 20 to set a cookie
2fc0: 75 73 69 6e 67 0a 20 20 3b 3b 20 20 68 74 74 70 using. ;; http
2fd0: 64 1b 2d 46 a2 73 20 72 65 77 72 69 74 65 20 72 d.-F˘s rewrite r
2fe0: 75 6c 65 20 28 6d 6f 64 5f 72 65 77 72 69 74 65 ule (mod_rewrite
2ff0: 29 2c 20 77 68 69 6c 65 20 77 6f 72 6b 69 6e 67 ), while working
3000: 20 6f 6e 20 6c 6f 63 61 6c 68 6f 73 74 3a 1b 2d on localhost:.-
3010: 41 0a 20 20 3b 3b 0a 20 20 3b 3b 20 20 55 73 65 A. ;;. ;; Use
3020: 20 74 68 65 20 49 50 20 31 32 37 2e 30 2e 30 2e the IP 127.0.0.
3030: 31 20 69 6e 73 74 65 61 64 20 6f 66 20 6c 6f 63 1 instead of loc
3040: 61 6c 68 6f 73 74 2f 6d 61 63 68 69 6e 65 2d 6e alhost/machine-n
3050: 61 6d 65 20 61 73 20 74 68 65 0a 20 20 3b 3b 20 ame as the. ;;
3060: 20 64 6f 6d 61 69 6e 3b 20 65 2e 67 2e 20 5b 43 domain; e.g. [C
3070: 4f 3d 73 6f 6d 65 43 6f 6f 6b 69 65 3a 73 6f 6d O=someCookie:som
3080: 65 56 61 6c 75 65 3a 31 32 37 2e 30 2e 30 2e 31 eValue:127.0.0.1
3090: 3a 32 3a 2f 5d 2c 20 77 68 69 63 68 20 73 61 79 :2:/], which say
30a0: 73 0a 20 20 3b 3b 20 20 63 72 65 61 74 65 20 61 s. ;; create a
30b0: 20 63 6f 6f 6b 69 65 20 1b 2d 59 b4 73 6f 6d 65 cookie .-Y´some
30c0: 43 6f 6f 6b 69 65 a1 20 77 69 74 68 20 76 61 6c Cookieˇ with val
30d0: 75 65 20 b4 73 6f 6d 65 56 61 6c 75 65 a1 20 66 ue ´someValueˇ f
30e0: 6f 72 20 74 68 65 0a 20 20 3b 3b 20 20 64 6f 6d or the. ;; dom
30f0: 61 69 6e 20 b4 31 32 37 2e 30 2e 30 2e 31 1b 24 ain ´127.0.0.1.$
3100: 42 21 6d 1b 28 42 20 68 61 76 69 6e 67 20 61 20 B!m.(B having a
3110: 6c 69 66 65 20 74 69 6d 65 20 6f 66 20 32 20 6d life time of 2 m
3120: 69 6e 73 2c 20 66 6f 72 20 61 6e 79 20 70 61 74 ins, for any pat
3130: 68 20 69 6e 0a 20 20 3b 3b 20 20 74 68 65 20 64 h in. ;; the d
3140: 6f 6d 61 69 6e 20 28 70 61 74 68 3d 2f 29 2e 20 omain (path=/).
3150: 28 4f 62 76 69 6f 75 73 6c 79 20 79 6f 75 20 77 (Obviously you w
3160: 69 6c 6c 20 68 61 76 65 20 74 6f 20 72 75 6e 20 ill have to run
3170: 74 68 65 0a 20 20 3b 3b 20 20 61 70 70 6c 69 63 the. ;; applic
3180: 61 74 69 6f 6e 20 77 69 74 68 20 74 68 69 73 20 ation with this
3190: 76 61 6c 75 65 20 69 6e 20 74 68 65 20 55 52 4c value in the URL
31a0: 29 0a 20 20 3b 3b 0a 20 20 3b 3b 20 20 54 6f 20 ). ;;. ;; To
31b0: 6d 61 6b 65 20 61 20 73 65 73 73 69 6f 6e 20 63 make a session c
31c0: 6f 6f 6b 69 65 2c 20 6c 69 6d 69 74 20 74 68 65 ookie, limit the
31d0: 20 66 6c 61 67 20 73 74 61 74 65 6d 65 6e 74 20 flag statement
31e0: 74 6f 20 6a 75 73 74 20 74 68 72 65 65 0a 20 20 to just three.
31f0: 3b 3b 20 20 61 74 74 72 69 62 75 74 65 73 3a 20 ;; attributes:
3200: 6e 61 6d 65 2c 20 76 61 6c 75 65 20 61 6e 64 20 name, value and
3210: 64 6f 6d 61 69 6e 2e 20 65 2e 67 0a 20 20 3b 3b domain. e.g. ;;
3220: 20 20 5b 43 4f 3d 73 6f 6d 65 43 6f 6f 6b 69 65 [CO=someCookie
3230: 3a 73 6f 6d 65 56 61 6c 75 65 3a 31 32 37 2e 30 :someValue:127.0
3240: 2e 30 2e 31 5d 20 1b 25 47 e2 80 93 1b 25 40 20 .0.1] .%G–.%@
3250: 41 6e 79 20 66 75 72 74 68 65 72 0a 20 20 3b 3b Any further. ;;
3260: 20 20 73 65 74 74 69 6e 67 73 2c 20 61 70 61 63 settings, apac
3270: 68 65 20 77 72 69 74 65 73 20 61 6e a1 20 65 78 he writes anˇ ex
3280: 70 69 72 65 73 a1 20 61 74 74 72 69 62 75 74 65 piresˇ attribute
3290: 20 66 6f 72 20 74 68 65 20 73 65 74 2d 63 6f 6f for the set-coo
32a0: 6b 69 65 0a 20 20 3b 3b 20 20 68 65 61 64 65 72 kie. ;; header
32b0: 2c 20 77 68 69 63 68 20 6d 61 6b 65 73 20 74 68 , which makes th
32c0: 65 20 63 6f 6f 6b 69 65 20 61 20 70 65 72 73 69 e cookie a persi
32d0: 73 74 65 6e 74 20 6f 6e 65 20 28 6e 6f 74 20 72 stent one (not r
32e0: 65 61 6c 6c 79 0a 20 20 3b 3b 20 20 70 65 72 73 eally. ;; pers
32f0: 69 73 74 65 6e 74 2c 20 61 73 20 74 68 65 20 65 istent, as the e
3300: 78 70 69 72 65 73 20 76 61 6c 75 65 20 73 65 74 xpires value set
3310: 20 69 73 20 74 68 65 20 63 75 72 72 65 6e 74 20 is the current
3320: 73 65 72 76 65 72 20 74 69 6d 65 0a 20 20 3b 3b server time. ;;
3330: 20 20 1b 25 47 e2 80 93 1b 25 40 20 73 6f 20 79 .%G–.%@ so y
3340: 6f 75 20 64 6f 6e 1b 2d 46 1b 2d 46 a2 74 20 65 ou don.-F.-F˘t e
3350: 76 65 6e 20 67 65 74 20 74 6f 20 73 65 65 20 79 ven get to see y
3360: 6f 75 72 20 63 6f 6f 6b 69 65 21 29 1b 2d 41 0a our cookie!).-A.
3370: 20 20 28 6c 69 73 74 20 28 73 74 72 69 6e 67 2d (list (string-
3380: 73 75 62 73 74 69 74 75 74 65 20 0a 09 20 22 3b substitute .. ";
3390: 22 20 22 3b 20 22 20 0a 09 20 28 63 61 72 20 28 " "; " .. (car (
33a0: 63 6f 6e 73 74 72 75 63 74 2d 63 6f 6f 6b 69 65 construct-cookie
33b0: 2d 73 74 72 69 6e 67 20 0a 09 20 20 20 20 20 20 -string ..
33c0: 20 3b 3b 20 77 61 72 6e 69 6e 67 21 20 6d 65 73 ;; warning! mes
33d0: 73 69 6e 67 20 75 70 20 74 68 69 73 20 69 74 74 sing up this itt
33e0: 79 20 62 69 74 74 79 20 62 69 74 20 6f 66 20 63 y bitty bit of c
33f0: 6f 64 65 20 77 69 6c 6c 20 63 6f 73 74 20 6d 75 ode will cost mu
3400: 63 68 20 74 69 6d 65 21 0a 09 20 20 20 20 20 20 ch time!..
3410: 20 60 28 28 22 73 65 73 73 69 6f 6e 5f 6b 65 79 `(("session_key
3420: 22 20 2c 28 73 64 61 74 2d 67 65 74 2d 73 65 73 " ,(sdat-get-ses
3430: 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 0a 09 sion-key self)..
3440: 09 20 20 65 78 70 69 72 65 73 3a 20 2c 28 2b 20 . expires: ,(+
3450: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
3460: 29 20 28 2a 20 31 34 20 38 36 34 30 30 29 29 20 ) (* 14 86400))
3470: 0a 09 09 20 20 3b 3b 20 6d 61 78 2d 61 67 65 3a ... ;; max-age:
3480: 20 28 2a 20 31 34 20 38 36 34 30 30 29 0a 09 09 (* 14 86400)...
3490: 20 20 70 61 74 68 3a 20 22 2f 22 20 3b 3b 20 0a path: "/" ;; .
34a0: 09 09 20 20 64 6f 6d 61 69 6e 3a 20 2c 28 73 74 .. domain: ,(st
34b0: 72 69 6e 67 2d 61 70 70 65 6e 64 20 22 2e 22 20 ring-append "."
34c0: 28 73 64 61 74 2d 67 65 74 2d 64 6f 6d 61 69 6e (sdat-get-domain
34d0: 20 73 65 6c 66 29 29 0a 09 09 20 20 76 65 72 73 self))... vers
34e0: 69 6f 6e 3a 20 31 29 29 20 30 29 29 29 29 29 0a ion: 1)) 0))))).
34f0: 0a 3b 3b 20 6c 6f 6f 6b 20 75 70 20 61 20 67 69 .;; look up a gi
3500: 76 65 6e 20 73 65 73 73 69 6f 6e 20 6b 65 79 20 ven session key
3510: 61 6e 64 20 72 65 74 75 72 6e 20 74 68 65 20 69 and return the i
3520: 64 20 69 66 20 66 6f 75 6e 64 2c 20 23 66 20 69 d if found, #f i
3530: 66 20 6e 6f 74 20 66 6f 75 6e 64 0a 28 64 65 66 f not found.(def
3540: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 ine (session:get
3550: 2d 69 64 20 73 65 6c 66 20 73 65 73 73 69 6f 6e -id self session
3560: 2d 6b 65 79 29 0a 20 20 3b 3b 20 28 6c 65 74 20 -key). ;; (let
3570: 28 28 73 65 73 73 69 6f 6e 2d 6b 65 79 20 28 73 ((session-key (s
3580: 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 2d dat-get-session-
3590: 6b 65 79 20 73 65 6c 66 29 29 29 0a 20 20 28 69 key self))). (i
35a0: 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 0a 20 20 f session-key.
35b0: 20 20 20 20 28 6c 65 74 20 28 28 71 75 65 72 79 (let ((query
35c0: 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 (string-append
35d0: 22 53 45 4c 45 43 54 20 69 64 20 46 52 4f 4d 20 "SELECT id FROM
35e0: 73 65 73 73 69 6f 6e 73 20 57 48 45 52 45 20 73 sessions WHERE s
35f0: 65 73 73 69 6f 6e 5f 6b 65 79 3d 27 22 20 73 65 ession_key='" se
3600: 73 73 69 6f 6e 2d 6b 65 79 20 22 27 22 29 29 0a ssion-key "'")).
3610: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e (con
3620: 6e 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e n (sdat-get-conn
3630: 20 73 65 6c 66 29 29 0a 20 20 20 20 20 20 20 20 self)).
3640: 20 20 20 20 28 72 65 73 75 6c 74 20 23 66 29 29 (result #f))
3650: 0a 09 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d ..(dbi:for-each-
3660: 72 6f 77 20 0a 09 20 28 6c 61 6d 62 64 61 20 28 row .. (lambda (
3670: 74 75 70 6c 65 29 0a 09 20 20 20 28 73 65 74 21 tuple).. (set!
3680: 20 72 65 73 75 6c 74 20 28 76 65 63 74 6f 72 2d result (vector-
3690: 72 65 66 20 74 75 70 6c 65 20 30 29 29 29 0a 09 ref tuple 0)))..
36a0: 20 63 6f 6e 6e 20 71 75 65 72 79 29 0a 09 28 69 conn query)..(i
36b0: 66 20 72 65 73 75 6c 74 20 28 64 62 69 3a 65 78 f result (dbi:ex
36c0: 65 63 20 63 6f 6e 6e 20 28 63 6f 6e 63 20 22 55 ec conn (conc "U
36d0: 50 44 41 54 45 20 73 65 73 73 69 6f 6e 73 20 53 PDATE sessions S
36e0: 45 54 20 6c 61 73 74 5f 75 73 65 64 3d 22 20 28 ET last_used=" (
36f0: 64 62 69 3a 6e 6f 77 20 63 6f 6e 6e 29 20 22 20 dbi:now conn) "
3700: 57 48 45 52 45 20 73 65 73 73 69 6f 6e 5f 6b 65 WHERE session_ke
3710: 79 3d 3f 3b 22 29 20 73 65 73 73 69 6f 6e 2d 6b y=?;") session-k
3720: 65 79 29 29 0a 20 20 20 20 20 20 20 20 72 65 73 ey)). res
3730: 75 6c 74 29 0a 20 20 20 20 20 20 23 66 29 29 0a ult). #f)).
3740: 0a 3b 3b 20 0a 28 64 65 66 69 6e 65 20 28 73 65 .;; .(define (se
3750: 73 73 69 6f 6e 3a 70 72 6f 63 65 73 73 2d 75 72 ssion:process-ur
3760: 6c 2d 70 61 74 68 20 73 65 6c 66 29 0a 20 20 28 l-path self). (
3770: 6c 65 74 20 28 28 70 61 74 68 2d 69 6e 66 6f 20 let ((path-info
3780: 20 20 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d (get-environm
3790: 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 50 41 ent-variable "PA
37a0: 54 48 5f 49 4e 46 4f 22 29 29 0a 09 28 71 75 65 TH_INFO"))..(que
37b0: 72 79 2d 73 74 72 69 6e 67 20 28 67 65 74 2d 65 ry-string (get-e
37c0: 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 nvironment-varia
37d0: 62 6c 65 20 22 51 55 45 52 59 5f 53 54 52 49 4e ble "QUERY_STRIN
37e0: 47 22 29 29 29 0a 20 20 20 20 3b 3b 20 28 73 65 G"))). ;; (se
37f0: 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 ssion:log self "
3800: 70 61 74 68 2d 69 6e 66 6f 3d 22 20 70 61 74 68 path-info=" path
3810: 2d 69 6e 66 6f 20 22 20 71 75 65 72 79 2d 73 74 -info " query-st
3820: 72 69 6e 67 3d 22 20 71 75 65 72 79 2d 73 74 72 ring=" query-str
3830: 69 6e 67 29 0a 20 20 20 20 28 69 66 20 70 61 74 ing). (if pat
3840: 68 2d 69 6e 66 6f 0a 09 28 6c 65 74 2a 20 28 28 h-info..(let* ((
3850: 70 61 72 74 73 20 20 20 20 28 73 74 72 69 6e 67 parts (string
3860: 2d 73 70 6c 69 74 20 70 61 74 68 2d 69 6e 66 6f -split path-info
3870: 20 22 2f 22 29 29 0a 09 20 20 20 20 20 20 20 28 "/")).. (
3880: 6e 75 6d 70 61 72 74 73 20 28 6c 65 6e 67 74 68 numparts (length
3890: 20 70 61 72 74 73 29 29 29 0a 09 20 20 28 69 66 parts))).. (if
38a0: 20 28 3e 20 6e 75 6d 70 61 72 74 73 20 30 29 0a (> numparts 0).
38b0: 09 20 20 20 20 20 20 28 73 64 61 74 2d 73 65 74 . (sdat-set
38c0: 2d 70 61 67 65 21 20 73 65 6c 66 20 28 63 61 72 -page! self (car
38d0: 20 70 61 72 74 73 29 29 29 0a 09 20 20 3b 3b 20 parts))).. ;;
38e0: 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c (session:log sel
38f0: 66 20 22 75 72 6c 2d 70 61 74 68 3d 22 20 75 72 f "url-path=" ur
3900: 6c 2d 70 61 74 68 20 22 20 70 61 72 74 73 3d 22 l-path " parts="
3910: 20 70 61 72 74 73 29 0a 09 20 20 28 69 66 20 28 parts).. (if (
3920: 3e 20 6e 75 6d 70 61 72 74 73 20 31 29 0a 09 20 > numparts 1)..
3930: 20 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d 70 (sdat-set-p
3940: 61 74 68 2d 70 61 72 61 6d 73 21 20 73 65 6c 66 ath-params! self
3950: 20 28 63 64 72 20 70 61 72 74 73 29 29 29 0a 20 (cdr parts))).
3960: 20 20 20 20 20 20 20 20 20 28 69 66 20 71 75 65 (if que
3970: 72 79 2d 73 74 72 69 6e 67 0a 20 20 20 20 20 20 ry-string.
3980: 20 20 20 20 20 20 20 20 28 73 64 61 74 2d 73 65 (sdat-se
3990: 74 2d 70 61 72 61 6d 73 21 20 73 65 6c 66 20 28 t-params! self (
39a0: 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 71 75 65 string-split que
39b0: 72 79 2d 73 74 72 69 6e 67 20 22 26 22 29 29 29 ry-string "&")))
39c0: 29 29 29 29 0a 0a 3b 3b 20 42 55 47 47 59 21 0a ))))..;; BUGGY!.
39d0: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
39e0: 3a 67 65 74 2d 6e 65 77 2d 6b 65 79 20 73 65 6c :get-new-key sel
39f0: 66 29 0a 20 20 28 6c 65 74 20 28 28 63 6f 6e 6e f). (let ((conn
3a00: 20 20 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e (sdat-get-con
3a10: 6e 20 73 65 6c 66 29 29 0a 20 20 20 20 20 20 20 n self)).
3a20: 20 28 74 6d 70 6b 65 79 20 28 73 65 73 73 69 6f (tmpkey (sessio
3a30: 6e 3a 6d 61 6b 65 2d 72 61 6e 64 2d 73 74 72 69 n:make-rand-stri
3a40: 6e 67 20 32 30 29 29 0a 20 20 20 20 20 20 20 20 ng 20)).
3a50: 28 73 74 61 74 75 73 20 23 66 29 29 0a 20 20 20 (status #f)).
3a60: 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 (dbi:for-each-r
3a70: 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c ow (lambda (tupl
3a80: 65 29 0a 09 09 09 28 73 65 74 21 20 73 74 61 74 e)....(set! stat
3a90: 75 73 20 23 74 29 29 0a 09 09 20 20 20 20 20 20 us #t))...
3aa0: 63 6f 6e 6e 20 28 73 74 72 69 6e 67 2d 61 70 70 conn (string-app
3ab0: 65 6e 64 20 22 49 4e 53 45 52 54 20 49 4e 54 4f end "INSERT INTO
3ac0: 20 73 65 73 73 69 6f 6e 73 20 28 73 65 73 73 69 sessions (sessi
3ad0: 6f 6e 5f 6b 65 79 29 20 56 41 4c 55 45 53 20 28 on_key) VALUES (
3ae0: 27 22 20 74 6d 70 6b 65 79 20 22 27 29 22 29 29 '" tmpkey "')"))
3af0: 0a 20 20 20 20 74 6d 70 6b 65 79 29 29 0a 0a 3b . tmpkey))..;
3b00: 3b 20 72 65 74 75 72 6e 73 20 73 65 73 73 69 6f ; returns sessio
3b10: 6e 20 6b 65 79 20 49 46 46 20 69 74 20 69 73 20 n key IFF it is
3b20: 69 6e 20 74 68 65 20 48 54 54 50 5f 43 4f 4f 4b in the HTTP_COOK
3b30: 49 45 20 0a 28 64 65 66 69 6e 65 20 28 73 65 73 IE .(define (ses
3b40: 73 69 6f 6e 3a 65 78 74 72 61 63 74 2d 73 65 73 sion:extract-ses
3b50: 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 0a 20 sion-key self).
3b60: 20 28 6c 65 74 20 28 28 68 74 74 70 2d 63 6f 6f (let ((http-coo
3b70: 6b 69 65 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e kie (get-environ
3b80: 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 48 ment-variable "H
3b90: 54 54 50 5f 43 4f 4f 4b 49 45 22 29 29 29 0a 20 TTP_COOKIE"))).
3ba0: 20 20 20 3b 3b 20 28 65 72 72 3a 6c 6f 67 20 22 ;; (err:log "
3bb0: 68 74 74 70 2d 63 6f 6f 6b 69 65 3a 20 22 20 68 http-cookie: " h
3bc0: 74 74 70 2d 63 6f 6f 6b 69 65 29 0a 20 20 20 20 ttp-cookie).
3bd0: 28 69 66 20 68 74 74 70 2d 63 6f 6f 6b 69 65 0a (if http-cookie.
3be0: 20 20 20 20 20 20 20 20 28 73 65 73 73 69 6f 6e (session
3bf0: 3a 65 78 74 72 61 63 74 2d 6b 65 79 2d 66 72 6f :extract-key-fro
3c00: 6d 2d 70 61 72 61 6d 20 73 65 6c 66 20 28 73 74 m-param self (st
3c10: 72 69 6e 67 2d 73 70 6c 69 74 2d 66 69 65 6c 64 ring-split-field
3c20: 73 20 20 22 3b 5c 5c 73 2b 22 20 68 74 74 70 2d s ";\\s+" http-
3c30: 63 6f 6f 6b 69 65 20 69 6e 66 69 78 3a 29 20 22 cookie infix:) "
3c40: 73 65 73 73 69 6f 6e 5f 6b 65 79 22 29 0a 20 20 session_key").
3c50: 20 20 20 20 20 20 23 66 29 29 29 0a 0a 28 64 65 #f)))..(de
3c60: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 fine (session:ge
3c70: 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c t-session-id sel
3c80: 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 0a 20 f session-key).
3c90: 20 28 6c 65 74 20 28 28 71 75 65 72 79 20 22 53 (let ((query "S
3ca0: 45 4c 45 43 54 20 69 64 20 46 52 4f 4d 20 73 65 ELECT id FROM se
3cb0: 73 73 69 6f 6e 73 20 57 48 45 52 45 20 73 65 73 ssions WHERE ses
3cc0: 73 69 6f 6e 5f 6b 65 79 3d 3f 3b 22 29 0a 20 20 sion_key=?;").
3cd0: 20 20 20 20 20 20 28 72 65 73 75 6c 74 20 23 66 (result #f
3ce0: 29 29 0a 20 20 20 20 3b 3b 20 20 20 20 20 28 70 )). ;; (p
3cf0: 67 3a 71 75 65 72 79 2d 66 6f 72 2d 65 61 63 68 g:query-for-each
3d00: 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 29 (lambda (tuple)
3d10: 0a 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 . ;;
3d20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3d30: 20 28 73 65 74 21 20 72 65 73 75 6c 74 20 28 76 (set! result (v
3d40: 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 ector-ref tuple
3d50: 30 29 29 29 20 3b 3b 20 28 76 65 63 74 6f 72 2d 0))) ;; (vector-
3d60: 72 65 66 20 74 75 70 6c 65 20 30 29 29 29 0a 20 ref tuple 0))).
3d70: 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 ;;
3d80: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 3a (s:
3d90: 73 71 6c 70 61 72 61 6d 20 71 75 65 72 79 20 73 sqlparam query s
3da0: 65 73 73 69 6f 6e 2d 6b 65 79 29 0a 20 20 20 20 ession-key).
3db0: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
3dc0: 20 20 20 20 20 20 20 20 20 20 28 73 64 61 74 2d (sdat-
3dd0: 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 0a get-conn self)).
3de0: 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 ;;
3df0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 63 6f co
3e00: 6e 6e 29 0a 20 20 20 20 28 64 62 69 3a 66 6f 72 nn). (dbi:for
3e10: 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 6d 62 64 -each-row (lambd
3e20: 61 20 28 74 75 70 6c 65 29 0a 09 09 09 28 73 65 a (tuple)....(se
3e30: 74 21 20 72 65 73 75 6c 74 20 28 76 65 63 74 6f t! result (vecto
3e40: 72 2d 72 65 66 20 74 75 70 6c 65 20 30 29 29 29 r-ref tuple 0)))
3e50: 20 3b 3b 20 28 76 65 63 74 6f 72 2d 72 65 66 20 ;; (vector-ref
3e60: 74 75 70 6c 65 20 30 29 29 29 0a 09 09 20 20 20 tuple 0)))...
3e70: 20 20 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e (sdat-get-con
3e80: 6e 20 73 65 6c 66 29 0a 09 09 20 20 20 20 20 20 n self)...
3e90: 28 73 3a 73 71 6c 70 61 72 61 6d 20 71 75 65 72 (s:sqlparam quer
3ea0: 79 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 0a y session-key)).
3eb0: 20 20 20 20 72 65 73 75 6c 74 29 29 0a 0a 3b 3b result))..;;
3ec0: 20 64 65 6c 65 74 65 20 61 6c 6c 20 72 65 63 6f delete all reco
3ed0: 72 64 73 20 66 6f 72 20 61 20 73 65 73 73 69 6f rds for a sessio
3ee0: 6e 0a 3b 3b 20 0a 3b 3b 20 4e 45 45 44 53 20 54 n.;; .;; NEEDS T
3ef0: 4f 20 42 45 20 54 52 41 4e 53 41 43 54 49 4f 4e O BE TRANSACTION
3f00: 49 5a 45 44 21 0a 3b 3b 0a 28 64 65 66 69 6e 65 IZED!.;;.(define
3f10: 20 28 73 65 73 73 69 6f 6e 3a 64 65 6c 65 74 65 (session:delete
3f20: 2d 73 65 73 73 69 6f 6e 20 73 65 6c 66 20 73 65 -session self se
3f30: 73 73 69 6f 6e 2d 6b 65 79 29 0a 20 20 28 6c 65 ssion-key). (le
3f40: 74 20 28 28 73 65 73 73 69 6f 6e 2d 69 64 20 28 t ((session-id (
3f50: 73 65 73 73 69 6f 6e 3a 67 65 74 2d 73 65 73 73 session:get-sess
3f60: 69 6f 6e 2d 69 64 20 73 65 6c 66 20 73 65 73 73 ion-id self sess
3f70: 69 6f 6e 2d 6b 65 79 29 29 0a 20 20 20 20 20 20 ion-key)).
3f80: 20 20 28 71 72 79 31 20 20 20 20 20 20 20 20 3b (qry1 ;
3f90: 3b 20 28 63 6f 6e 63 20 22 42 45 47 49 4e 3b 22 ; (conc "BEGIN;"
3fa0: 0a 09 09 09 20 20 22 44 45 4c 45 54 45 20 46 52 .... "DELETE FR
3fb0: 4f 4d 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 OM session_vars
3fc0: 57 48 45 52 45 20 73 65 73 73 69 6f 6e 5f 69 64 WHERE session_id
3fd0: 3d 3f 3b 22 29 0a 09 28 71 72 79 32 20 20 20 20 =?;")..(qry2
3fe0: 20 20 20 20 20 20 20 20 20 22 44 45 4c 45 54 45 "DELETE
3ff0: 20 46 52 4f 4d 20 73 65 73 73 69 6f 6e 73 20 57 FROM sessions W
4000: 48 45 52 45 20 69 64 3d 3f 3b 22 29 0a 09 09 20 HERE id=?;")...
4010: 20 20 20 20 3b 3b 20 20 22 43 4f 4d 4d 49 54 3b ;; "COMMIT;
4020: 22 29 29 0a 20 20 20 20 20 20 20 20 28 63 6f 6e ")). (con
4030: 6e 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 n (
4040: 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 sdat-get-conn se
4050: 6c 66 29 29 29 0a 20 20 20 20 28 69 66 20 73 65 lf))). (if se
4060: 73 73 69 6f 6e 2d 69 64 0a 20 20 20 20 20 20 20 ssion-id.
4070: 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 (begin.
4080: 20 20 28 64 62 69 3a 65 78 65 63 20 63 6f 6e 6e (dbi:exec conn
4090: 20 71 72 79 31 20 73 65 73 73 69 6f 6e 2d 69 64 qry1 session-id
40a0: 29 20 3b 3b 20 73 65 73 73 69 6f 6e 2d 69 64 29 ) ;; session-id)
40b0: 0a 09 20 20 28 64 62 69 3a 65 78 65 63 20 63 6f .. (dbi:exec co
40c0: 6e 6e 20 71 72 79 32 20 73 65 73 73 69 6f 6e 2d nn qry2 session-
40d0: 69 64 29 0a 09 20 20 28 73 65 73 73 69 6f 6e 3a id).. (session:
40e0: 69 6e 69 74 69 61 6c 69 7a 65 20 73 65 6c 66 29 initialize self)
40f0: 0a 09 20 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 .. (session:set
4100: 75 70 20 73 65 6c 66 29 29 29 0a 20 20 20 20 28 up self))). (
4110: 6e 6f 74 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 not (session:get
4120: 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 -session-id self
4130: 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 29 29 session-key))))
4140: 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 65 ..;; (define (se
4150: 73 73 69 6f 6e 3a 64 65 6c 65 74 65 2d 73 65 73 ssion:delete-ses
4160: 73 69 6f 6e 20 73 65 6c 66 20 73 65 73 73 69 6f sion self sessio
4170: 6e 2d 6b 65 79 29 0a 3b 3b 20 20 20 28 6c 65 74 n-key).;; (let
4180: 20 28 28 73 65 73 73 69 6f 6e 2d 69 64 20 28 73 ((session-id (s
4190: 65 73 73 69 6f 6e 3a 67 65 74 2d 73 65 73 73 69 ession:get-sessi
41a0: 6f 6e 2d 69 64 20 73 65 6c 66 20 73 65 73 73 69 on-id self sessi
41b0: 6f 6e 2d 6b 65 79 29 29 0a 3b 3b 20 20 20 20 20 on-key)).;;
41c0: 20 20 20 20 28 71 75 65 72 69 65 73 20 20 20 20 (queries
41d0: 28 6c 69 73 74 20 22 42 45 47 49 4e 3b 22 0a 3b (list "BEGIN;".;
41e0: 3b 20 09 09 09 20 20 22 44 45 4c 45 54 45 20 46 ; ... "DELETE F
41f0: 52 4f 4d 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 ROM session_vars
4200: 20 57 48 45 52 45 20 73 65 73 73 69 6f 6e 5f 69 WHERE session_i
4210: 64 3d 3f 3b 22 0a 3b 3b 20 20 20 20 20 20 20 20 d=?;".;;
4220: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4230: 20 20 20 22 44 45 4c 45 54 45 20 46 52 4f 4d 20 "DELETE FROM
4240: 73 65 73 73 69 6f 6e 73 20 57 48 45 52 45 20 69 sessions WHERE i
4250: 64 3d 3f 3b 22 0a 3b 3b 20 09 09 09 20 20 22 43 d=?;".;; ... "C
4260: 4f 4d 4d 49 54 3b 22 29 29 0a 3b 3b 20 20 20 20 OMMIT;")).;;
4270: 20 20 20 20 20 28 63 6f 6e 6e 20 20 20 20 20 20 (conn
4280: 20 20 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 (sdat-ge
4290: 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 29 0a 3b t-conn self))).;
42a0: 3b 20 20 20 20 20 28 69 66 20 73 65 73 73 69 6f ; (if sessio
42b0: 6e 2d 69 64 0a 3b 3b 20 20 20 20 20 20 20 20 20 n-id.;;
42c0: 28 62 65 67 69 6e 0a 3b 3b 20 20 20 20 20 20 20 (begin.;;
42d0: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 3b 3b (for-each.;;
42e0: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 61 6d (lam
42f0: 62 64 61 20 28 71 75 65 72 79 29 0a 3b 3b 20 20 bda (query).;;
4300: 20 20 20 20 20 20 20 20 20 20 20 20 28 64 62 69 (dbi
4310: 3a 65 78 65 63 20 63 6f 6e 6e 20 71 75 65 72 79 :exec conn query
4320: 20 73 65 73 73 69 6f 6e 2d 69 64 29 29 0a 3b 3b session-id)).;;
4330: 20 09 20 20 20 71 75 65 72 69 65 73 29 0a 3b 3b . queries).;;
4340: 20 09 20 20 28 69 6e 69 74 69 61 6c 69 7a 65 20 . (initialize
4350: 73 65 6c 66 20 27 28 29 29 0a 3b 3b 20 09 20 20 self '()).;; .
4360: 28 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 20 73 (session:setup s
4370: 65 6c 66 29 29 29 0a 3b 3b 20 20 20 20 20 28 6e elf))).;; (n
4380: 6f 74 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d ot (session:get-
4390: 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 20 session-id self
43a0: 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 29 29 0a session-key)))).
43b0: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
43c0: 6e 3a 65 78 74 72 61 63 74 2d 6b 65 79 20 73 65 n:extract-key se
43d0: 6c 66 20 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 lf key). (let (
43e0: 28 70 61 72 61 6d 73 20 28 73 64 61 74 2d 67 65 (params (sdat-ge
43f0: 74 2d 70 61 72 61 6d 73 20 73 65 6c 66 29 29 29 t-params self)))
4400: 0a 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 65 78 . (session:ex
4410: 74 72 61 63 74 2d 6b 65 79 2d 66 72 6f 6d 2d 70 tract-key-from-p
4420: 61 72 61 6d 20 73 65 6c 66 20 70 61 72 61 6d 73 aram self params
4430: 20 6b 65 79 29 29 29 0a 0a 28 64 65 66 69 6e 65 key)))..(define
4440: 20 28 73 65 73 73 69 6f 6e 3a 65 78 74 72 61 63 (session:extrac
4450: 74 2d 6b 65 79 2d 66 72 6f 6d 2d 70 61 72 61 6d t-key-from-param
4460: 20 73 65 6c 66 20 70 61 72 61 6d 73 20 6b 65 79 self params key
4470: 29 0a 20 20 28 6c 65 74 20 28 28 72 31 20 20 20 ). (let ((r1
4480: 20 20 28 72 65 67 65 78 70 20 28 73 74 72 69 6e (regexp (strin
4490: 67 2d 61 70 70 65 6e 64 20 22 5e 22 20 6b 65 79 g-append "^" key
44a0: 20 22 3d 28 5b 5e 3d 5d 2b 29 24 22 29 29 29 29 "=([^=]+)$"))))
44b0: 0a 20 20 20 20 28 65 72 72 3a 6c 6f 67 20 22 49 . (err:log "I
44c0: 4e 46 4f 3a 20 4c 6f 6f 6b 69 6e 67 20 66 6f 72 NFO: Looking for
44d0: 20 22 20 6b 65 79 20 22 20 69 6e 20 22 20 70 61 " key " in " pa
44e0: 72 61 6d 73 29 0a 20 20 20 20 28 69 66 20 28 3c rams). (if (<
44f0: 20 28 6c 65 6e 67 74 68 20 70 61 72 61 6d 73 29 (length params)
4500: 20 31 29 20 23 66 0a 09 28 6c 65 74 20 6c 6f 6f 1) #f..(let loo
4510: 70 20 28 28 68 65 61 64 20 20 20 28 63 61 72 20 p ((head (car
4520: 70 61 72 61 6d 73 29 29 0a 09 09 20 20 20 28 74 params))... (t
4530: 61 69 6c 20 20 20 28 63 64 72 20 70 61 72 61 6d ail (cdr param
4540: 73 29 29 29 0a 09 20 20 28 6c 65 74 20 28 28 6d s))).. (let ((m
4550: 61 74 63 68 20 28 73 74 72 69 6e 67 2d 6d 61 74 atch (string-mat
4560: 63 68 20 72 31 20 68 65 61 64 29 29 29 0a 09 20 ch r1 head)))..
4570: 20 20 20 28 63 6f 6e 64 0a 09 20 20 20 20 20 28 (cond.. (
4580: 6d 61 74 63 68 0a 09 20 20 20 20 20 20 28 6c 65 match.. (le
4590: 74 20 28 28 73 65 73 73 69 6f 6e 2d 6b 65 79 20 t ((session-key
45a0: 28 6c 69 73 74 2d 72 65 66 20 6d 61 74 63 68 20 (list-ref match
45b0: 31 29 29 29 0a 09 09 28 65 72 72 3a 6c 6f 67 20 1)))...(err:log
45c0: 22 49 4e 46 4f 3a 20 46 6f 75 6e 64 20 73 65 73 "INFO: Found ses
45d0: 73 69 6f 6e 20 6b 65 79 3d 22 20 73 65 73 73 69 sion key=" sessi
45e0: 6f 6e 2d 6b 65 79 29 0a 09 09 28 73 64 61 74 2d on-key)...(sdat-
45f0: 73 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 21 set-session-key!
4600: 20 73 65 6c 66 20 28 6c 69 73 74 2d 72 65 66 20 self (list-ref
4610: 6d 61 74 63 68 20 31 29 29 0a 09 09 73 65 73 73 match 1))...sess
4620: 69 6f 6e 2d 6b 65 79 29 29 0a 09 20 20 20 20 20 ion-key))..
4630: 28 28 6e 75 6c 6c 3f 20 74 61 69 6c 29 0a 09 20 ((null? tail)..
4640: 20 20 20 20 20 23 66 29 0a 09 20 20 20 20 20 28 #f).. (
4650: 65 6c 73 65 0a 09 20 20 20 20 20 20 28 6c 6f 6f else.. (loo
4660: 70 20 28 63 61 72 20 74 61 69 6c 29 0a 09 09 20 p (car tail)...
4670: 20 20 20 28 63 64 72 20 74 61 69 6c 29 29 29 29 (cdr tail))))
4680: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define (
4690: 73 65 73 73 69 6f 6e 3a 73 65 74 2d 70 61 67 65 session:set-page
46a0: 21 20 73 65 6c 66 20 70 61 67 65 5f 6e 61 6d 65 ! self page_name
46b0: 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 ). (sdat-set-pa
46c0: 67 65 21 20 73 65 6c 66 20 70 61 67 65 5f 6e 61 ge! self page_na
46d0: 6d 65 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 me))..(define (s
46e0: 65 73 73 69 6f 6e 3a 63 6c 6f 73 65 20 73 65 6c ession:close sel
46f0: 66 29 0a 20 20 28 64 62 69 3a 63 6c 6f 73 65 20 f). (dbi:close
4700: 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 (sdat-get-conn s
4710: 65 6c 66 29 29 29 0a 3b 3b 20 28 63 6c 6f 73 65 elf))).;; (close
4720: 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 28 73 64 -output-port (sd
4730: 61 74 2d 67 65 74 2d 6c 6f 67 70 74 20 73 65 6c at-get-logpt sel
4740: 66 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 f))..(define (se
4750: 73 73 69 6f 6e 3a 65 72 72 2d 6d 73 67 20 73 65 ssion:err-msg se
4760: 6c 66 20 6d 73 67 29 0a 20 20 28 68 61 73 68 2d lf msg). (hash-
4770: 74 61 62 6c 65 2d 73 65 74 21 20 28 73 64 61 74 table-set! (sdat
4780: 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 -get-sessionvars
4790: 20 73 65 6c 66 29 20 22 45 52 52 4f 52 5f 4d 53 self) "ERROR_MS
47a0: 47 22 0a 09 09 20 20 20 28 73 74 72 69 6e 67 2d G"... (string-
47b0: 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 intersperse (map
47c0: 20 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6d s:any->string m
47d0: 73 67 29 20 22 20 22 29 29 29 0a 0a 28 64 65 66 sg) " ")))..(def
47e0: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 70 72 65 ine (session:pre
47f0: 76 2d 65 72 72 20 73 65 6c 66 29 0a 20 20 28 6c v-err self). (l
4800: 65 74 20 28 28 70 72 65 76 2d 65 72 72 20 28 68 et ((prev-err (h
4810: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
4820: 66 61 75 6c 74 20 28 73 64 61 74 2d 67 65 74 2d fault (sdat-get-
4830: 73 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 6f sessionvars-befo
4840: 72 65 20 73 65 6c 66 29 20 22 45 52 52 4f 52 5f re self) "ERROR_
4850: 4d 53 47 22 20 23 66 29 29 0a 09 28 63 75 72 72 MSG" #f))..(curr
4860: 2d 65 72 72 20 28 68 61 73 68 2d 74 61 62 6c 65 -err (hash-table
4870: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 28 73 64 -ref/default (sd
4880: 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 at-get-sessionva
4890: 72 73 20 73 65 6c 66 29 20 22 45 52 52 4f 52 5f rs self) "ERROR_
48a0: 4d 53 47 22 20 23 66 29 29 29 0a 20 20 20 20 28 MSG" #f))). (
48b0: 69 66 20 70 72 65 76 2d 65 72 72 20 70 72 65 76 if prev-err prev
48c0: 2d 65 72 72 0a 09 28 69 66 20 63 75 72 72 2d 65 -err..(if curr-e
48d0: 72 72 20 63 75 72 72 2d 65 72 72 20 23 66 29 29 rr curr-err #f))
48e0: 29 29 0a 0a 3b 3b 20 73 65 73 73 69 6f 6e 20 76 ))..;; session v
48f0: 61 72 73 0a 3b 3b 20 31 2e 20 6b 65 79 73 20 61 ars.;; 1. keys a
4900: 72 65 20 61 6c 77 61 79 73 20 61 20 73 74 72 69 re always a stri
4910: 6e 67 20 4e 4f 54 20 61 20 73 79 6d 62 6f 6c 0a ng NOT a symbol.
4920: 3b 3b 20 32 2e 20 76 61 6c 75 65 73 20 61 72 65 ;; 2. values are
4930: 20 61 6c 77 61 79 73 20 61 20 73 74 72 69 6e 67 always a string
4940: 20 63 6f 6e 76 65 72 73 69 6f 6e 20 69 73 20 74 conversion is t
4950: 68 65 20 72 65 73 70 6f 6e 73 69 62 69 6c 69 74 he responsibilit
4960: 79 20 6f 66 20 74 68 65 20 0a 3b 3b 20 20 20 20 y of the .;;
4970: 63 6f 6e 73 75 6d 69 6e 67 20 66 75 6e 63 74 69 consuming functi
4980: 6f 6e 20 28 61 74 20 6c 65 61 73 74 20 66 6f 72 on (at least for
4990: 20 6e 6f 77 2c 20 49 27 64 20 6c 69 6b 65 20 74 now, I'd like t
49a0: 6f 20 63 68 61 6e 67 65 20 74 68 69 73 29 0a 0a o change this)..
49b0: 3b 3b 20 73 65 74 20 61 20 73 65 73 73 69 6f 6e ;; set a session
49c0: 20 76 61 72 20 66 6f 72 20 74 68 65 20 63 75 72 var for the cur
49d0: 72 65 6e 74 20 70 61 67 65 0a 3b 3b 0a 28 64 65 rent page.;;.(de
49e0: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 63 75 fine (session:cu
49f0: 72 72 2d 70 61 67 65 2d 73 65 74 21 20 73 65 6c rr-page-set! sel
4a00: 66 20 6b 65 79 20 76 61 6c 75 65 29 0a 20 20 28 f key value). (
4a10: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
4a20: 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 76 61 (sdat-get-pageva
4a30: 72 73 20 73 65 6c 66 29 20 28 73 3a 61 6e 79 2d rs self) (s:any-
4a40: 3e 73 74 72 69 6e 67 20 6b 65 79 29 20 28 73 3a >string key) (s:
4a50: 61 6e 79 2d 3e 73 74 72 69 6e 67 20 76 61 6c 75 any->string valu
4a60: 65 29 29 29 0a 0a 3b 3b 20 64 65 6c 20 61 20 76 e)))..;; del a v
4a70: 61 72 20 66 6f 72 20 74 68 65 20 63 75 72 72 65 ar for the curre
4a80: 6e 74 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 69 nt page.;;.(defi
4a90: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 70 61 67 65 ne (session:page
4aa0: 2d 76 61 72 2d 64 65 6c 21 20 73 65 6c 66 20 6b -var-del! self k
4ab0: 65 79 29 0a 20 20 28 68 61 73 68 2d 74 61 62 6c ey). (hash-tabl
4ac0: 65 2d 64 65 6c 65 74 65 21 20 28 73 64 61 74 2d e-delete! (sdat-
4ad0: 67 65 74 2d 70 61 67 65 76 61 72 73 20 73 65 6c get-pagevars sel
4ae0: 66 29 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e f) (s:any->strin
4af0: 67 20 6b 65 79 29 29 29 0a 0a 3b 3b 20 67 65 74 g key)))..;; get
4b00: 20 74 68 65 20 61 70 70 72 6f 70 72 69 61 74 65 the appropriate
4b10: 20 68 61 73 68 20 67 69 76 65 6e 20 61 20 70 61 hash given a pa
4b20: 67 65 20 22 2a 73 65 73 73 69 6f 6e 76 61 72 73 ge "*sessionvars
4b30: 2a 2c 20 2a 67 6c 6f 62 61 6c 76 61 72 73 2a 20 *, *globalvars*
4b40: 6f 72 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 69 or page.;;.(defi
4b50: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d ne (session:get-
4b60: 70 61 67 65 2d 68 61 73 68 20 73 65 6c 66 20 70 page-hash self p
4b70: 61 67 65 29 0a 20 20 28 69 66 20 28 73 74 72 69 age). (if (stri
4b80: 6e 67 3d 3f 20 70 61 67 65 20 22 2a 73 65 73 73 ng=? page "*sess
4b90: 69 6f 6e 76 61 72 73 2a 22 29 0a 20 20 20 20 20 ionvars*").
4ba0: 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 (sdat-get-sessi
4bb0: 6f 6e 76 61 72 73 20 73 65 6c 66 29 0a 20 20 20 onvars self).
4bc0: 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 3d 3f (if (string=?
4bd0: 20 70 61 67 65 20 22 2a 67 6c 6f 62 61 6c 76 61 page "*globalva
4be0: 72 73 2a 22 29 0a 09 20 20 28 73 64 61 74 2d 67 rs*").. (sdat-g
4bf0: 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 20 73 65 et-globalvars se
4c00: 6c 66 29 0a 09 20 20 28 73 64 61 74 2d 67 65 74 lf).. (sdat-get
4c10: 2d 70 61 67 65 76 61 72 73 20 73 65 6c 66 29 29 -pagevars self))
4c20: 29 29 0a 0a 3b 3b 20 73 65 74 20 61 20 73 65 73 ))..;; set a ses
4c30: 73 69 6f 6e 20 76 61 72 20 66 6f 72 20 61 20 67 sion var for a g
4c40: 69 76 65 6e 20 70 61 67 65 0a 3b 3b 0a 28 64 65 iven page.;;.(de
4c50: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 65 fine (session:se
4c60: 74 21 20 73 65 6c 66 20 70 61 67 65 20 6b 65 79 t! self page key
4c70: 20 76 61 6c 75 65 29 0a 20 20 28 6c 65 74 20 28 value). (let (
4c80: 28 68 74 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 (ht (session:get
4c90: 2d 70 61 67 65 2d 68 61 73 68 20 73 65 6c 66 20 -page-hash self
4ca0: 70 61 67 65 29 29 29 0a 20 20 20 20 28 68 61 73 page))). (has
4cb0: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 68 74 20 h-table-set! ht
4cc0: 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6b (s:any->string k
4cd0: 65 79 29 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 ey) (s:any->stri
4ce0: 6e 67 20 76 61 6c 75 65 29 29 29 29 0a 0a 3b 3b ng value))))..;;
4cf0: 20 67 65 74 20 73 65 73 73 69 6f 6e 20 76 61 72 get session var
4d00: 73 20 66 6f 72 20 74 68 65 20 63 75 72 72 65 6e s for the curren
4d10: 74 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 69 6e t page.;;.(defin
4d20: 65 20 28 73 65 73 73 69 6f 6e 3a 70 61 67 65 2d e (session:page-
4d30: 67 65 74 20 73 65 6c 66 20 6b 65 79 29 0a 20 20 get self key).
4d40: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
4d50: 64 65 66 61 75 6c 74 20 28 73 64 61 74 2d 67 65 default (sdat-ge
4d60: 74 2d 70 61 67 65 76 61 72 73 20 73 65 6c 66 29 t-pagevars self)
4d70: 20 6b 65 79 20 23 66 29 29 0a 0a 3b 3b 20 67 65 key #f))..;; ge
4d80: 74 20 73 65 73 73 69 6f 6e 20 76 61 72 73 20 66 t session vars f
4d90: 6f 72 20 61 20 73 70 65 63 69 66 69 65 64 20 70 or a specified p
4da0: 61 67 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 age.;;.(define (
4db0: 73 65 73 73 69 6f 6e 3a 67 65 74 20 73 65 6c 66 session:get self
4dc0: 20 70 61 67 65 20 6b 65 79 29 0a 20 20 28 6c 65 page key). (le
4dd0: 74 20 28 28 68 74 20 28 73 65 73 73 69 6f 6e 3a t ((ht (session:
4de0: 67 65 74 2d 70 61 67 65 2d 68 61 73 68 20 73 65 get-page-hash se
4df0: 6c 66 20 70 61 67 65 29 29 29 0a 20 20 20 20 28 lf page))). (
4e00: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
4e10: 65 66 61 75 6c 74 20 68 74 20 6b 65 79 20 23 66 efault ht key #f
4e20: 29 29 29 0a 0a 3b 3b 20 64 65 6c 65 74 65 20 61 )))..;; delete a
4e30: 20 73 65 73 73 69 6f 6e 20 76 61 72 20 66 6f 72 session var for
4e40: 20 61 20 73 70 65 63 69 66 69 65 64 20 70 61 67 a specified pag
4e50: 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 e.;;.(define (se
4e60: 73 73 69 6f 6e 3a 64 65 6c 21 20 73 65 6c 66 20 ssion:del! self
4e70: 70 61 67 65 20 6b 65 79 29 0a 20 20 28 6c 65 74 page key). (let
4e80: 20 28 28 68 74 20 28 73 65 73 73 69 6f 6e 3a 67 ((ht (session:g
4e90: 65 74 2d 70 61 67 65 2d 68 61 73 68 20 73 65 6c et-page-hash sel
4ea0: 66 20 70 61 67 65 29 29 29 0a 20 20 20 20 28 68 f page))). (h
4eb0: 61 73 68 2d 74 61 62 6c 65 2d 64 65 6c 65 74 65 ash-table-delete
4ec0: 21 20 68 74 20 6b 65 79 29 29 29 0a 0a 3b 3b 20 ! ht key)))..;;
4ed0: 67 65 74 20 41 4c 4c 20 6b 65 79 73 20 66 6f 72 get ALL keys for
4ee0: 20 74 68 69 73 20 70 61 67 65 20 61 6e 64 20 73 this page and s
4ef0: 74 6f 72 65 20 69 6e 20 74 68 65 20 73 65 73 73 tore in the sess
4f00: 69 6f 6e 20 70 61 67 65 76 61 72 73 20 68 61 73 ion pagevars has
4f10: 68 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 h.;;.(define (se
4f20: 73 73 69 6f 6e 3a 67 65 74 2d 76 61 72 73 20 73 ssion:get-vars s
4f30: 65 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 73 65 elf). (let ((se
4f40: 73 73 69 6f 6e 2d 69 64 20 20 28 73 64 61 74 2d ssion-id (sdat-
4f50: 67 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 get-session-id s
4f60: 65 6c 66 29 29 29 0a 20 20 20 20 28 69 66 20 28 elf))). (if (
4f70: 6e 6f 74 20 73 65 73 73 69 6f 6e 2d 69 64 29 0a not session-id).
4f80: 09 28 65 72 72 3a 6c 6f 67 20 22 45 52 52 4f 52 .(err:log "ERROR
4f90: 3a 20 4e 6f 20 73 65 73 73 69 6f 6e 20 69 64 20 : No session id
4fa0: 69 6e 20 73 65 73 73 69 6f 6e 20 6f 62 6a 65 63 in session objec
4fb0: 74 21 20 73 65 73 73 69 6f 6e 3a 67 65 74 2d 76 t! session:get-v
4fc0: 61 72 73 22 29 0a 09 28 6c 65 74 2a 20 28 28 72 ars")..(let* ((r
4fd0: 65 73 75 6c 74 20 20 20 20 20 20 20 20 20 20 20 esult
4fe0: 20 20 23 66 29 0a 09 20 20 20 20 20 20 20 28 63 #f).. (c
4ff0: 6f 6e 6e 20 20 20 20 20 20 20 20 20 20 20 20 20 onn
5000: 20 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e (sdat-get-conn
5010: 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 20 20 self))..
5020: 28 70 61 67 65 76 61 72 73 2d 62 65 66 6f 72 65 (pagevars-before
5030: 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d 70 61 (sdat-get-pa
5040: 67 65 76 61 72 73 2d 62 65 66 6f 72 65 20 73 65 gevars-before se
5050: 6c 66 29 29 0a 09 20 20 20 20 20 20 20 28 73 65 lf)).. (se
5060: 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 ssionvars-before
5070: 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 (sdat-get-sessi
5080: 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 20 73 65 onvars-before se
5090: 6c 66 29 29 0a 09 20 20 20 20 20 20 20 28 67 6c lf)).. (gl
50a0: 6f 62 61 6c 76 61 72 73 2d 62 65 66 6f 72 65 20 obalvars-before
50b0: 20 28 73 64 61 74 2d 67 65 74 2d 67 6c 6f 62 61 (sdat-get-globa
50c0: 6c 76 61 72 73 2d 62 65 66 6f 72 65 20 73 65 6c lvars-before sel
50d0: 66 29 29 0a 09 20 20 20 20 20 20 20 28 70 61 67 f)).. (pag
50e0: 65 76 61 72 73 20 20 20 20 20 20 20 20 20 20 20 evars
50f0: 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 76 61 (sdat-get-pageva
5100: 72 73 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 rs self))..
5110: 20 20 28 73 65 73 73 69 6f 6e 76 61 72 73 20 20 (sessionvars
5120: 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d (sdat-get-
5130: 73 65 73 73 69 6f 6e 76 61 72 73 20 73 65 6c 66 sessionvars self
5140: 29 29 0a 09 20 20 20 20 20 20 20 28 67 6c 6f 62 )).. (glob
5150: 61 6c 76 61 72 73 20 20 20 20 20 20 20 20 20 28 alvars (
5160: 73 64 61 74 2d 67 65 74 2d 67 6c 6f 62 61 6c 76 sdat-get-globalv
5170: 61 72 73 20 73 65 6c 66 29 29 0a 09 20 20 20 20 ars self))..
5180: 20 20 20 28 70 61 67 65 2d 6e 61 6d 65 20 20 20 (page-name
5190: 20 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 (sdat-get
51a0: 2d 70 61 67 65 20 73 65 6c 66 29 29 0a 09 20 20 -page self))..
51b0: 20 20 20 20 20 28 73 65 73 73 69 6f 6e 2d 6b 65 (session-ke
51c0: 79 20 20 20 20 20 20 20 20 28 73 64 61 74 2d 67 y (sdat-g
51d0: 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 et-session-key s
51e0: 65 6c 66 29 29 0a 09 20 20 20 20 20 20 20 28 71 elf)).. (q
51f0: 75 65 72 79 20 20 20 20 20 20 20 20 20 20 20 20 uery
5200: 20 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 (string-append
5210: 0a 09 09 09 09 20 20 20 20 22 53 45 4c 45 43 54 ..... "SELECT
5220: 20 6b 65 79 2c 76 61 6c 75 65 20 46 52 4f 4d 20 key,value FROM
5230: 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 49 4e 4e session_vars INN
5240: 45 52 20 4a 4f 49 4e 20 73 65 73 73 69 6f 6e 73 ER JOIN sessions
5250: 20 4f 4e 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 ON session_vars
5260: 2e 73 65 73 73 69 6f 6e 5f 69 64 3d 73 65 73 73 .session_id=sess
5270: 69 6f 6e 73 2e 69 64 20 22 0a 09 09 09 09 20 20 ions.id ".....
5280: 20 20 22 57 48 45 52 45 20 73 65 73 73 69 6f 6e "WHERE session
5290: 5f 6b 65 79 3d 3f 20 41 4e 44 20 70 61 67 65 3d _key=? AND page=
52a0: 3f 3b 22 29 29 29 0a 09 20 20 3b 3b 20 66 69 72 ?;"))).. ;; fir
52b0: 73 74 20 74 68 65 20 70 61 67 65 20 73 70 65 63 st the page spec
52c0: 69 66 69 63 20 76 61 72 73 0a 09 20 20 28 64 62 ific vars.. (db
52d0: 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 28 i:for-each-row (
52e0: 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 29 0a 09 lambda (tuple)..
52f0: 09 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 6b .. (let ((k
5300: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 (vector-ref tup
5310: 6c 65 20 30 29 29 0a 09 09 09 09 20 20 20 20 28 le 0))..... (
5320: 76 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 75 v (vector-ref tu
5330: 70 6c 65 20 31 29 29 29 0a 09 09 09 09 28 68 61 ple 1))).....(ha
5340: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 70 61 sh-table-set! pa
5350: 67 65 76 61 72 73 2d 62 65 66 6f 72 65 20 6b 20 gevars-before k
5360: 76 29 0a 09 09 09 09 28 68 61 73 68 2d 74 61 62 v).....(hash-tab
5370: 6c 65 2d 73 65 74 21 20 70 61 67 65 76 61 72 73 le-set! pagevars
5380: 20 20 20 20 20 20 20 20 6b 20 76 29 29 29 0a 09 k v)))..
5390: 09 09 20 20 20 20 63 6f 6e 6e 0a 09 09 09 20 20 .. conn....
53a0: 20 20 28 73 3a 73 71 6c 70 61 72 61 6d 20 71 75 (s:sqlparam qu
53b0: 65 72 79 20 73 65 73 73 69 6f 6e 2d 6b 65 79 20 ery session-key
53c0: 70 61 67 65 2d 6e 61 6d 65 29 29 0a 09 20 20 3b page-name)).. ;
53d0: 3b 20 74 68 65 6e 20 74 68 65 20 73 65 73 73 69 ; then the sessi
53e0: 6f 6e 20 73 70 65 63 69 66 69 63 20 76 61 72 73 on specific vars
53f0: 0a 09 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 .. (dbi:for-eac
5400: 68 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 h-row (lambda (t
5410: 75 70 6c 65 29 0a 09 09 09 20 20 20 20 20 20 28 uple).... (
5420: 6c 65 74 20 28 28 6b 20 28 76 65 63 74 6f 72 2d let ((k (vector-
5430: 72 65 66 20 74 75 70 6c 65 20 30 29 29 0a 09 09 ref tuple 0))...
5440: 09 09 20 20 20 20 28 76 20 28 76 65 63 74 6f 72 .. (v (vector
5450: 2d 72 65 66 20 74 75 70 6c 65 20 31 29 29 29 0a -ref tuple 1))).
5460: 09 09 09 09 28 68 61 73 68 2d 74 61 62 6c 65 2d ....(hash-table-
5470: 73 65 74 21 20 73 65 73 73 69 6f 6e 76 61 72 73 set! sessionvars
5480: 2d 62 65 66 6f 72 65 20 6b 20 76 29 0a 09 09 09 -before k v)....
5490: 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 .(hash-table-set
54a0: 21 20 73 65 73 73 69 6f 6e 76 61 72 73 20 20 20 ! sessionvars
54b0: 20 20 20 20 20 6b 20 76 29 29 29 0a 09 09 09 20 k v)))....
54c0: 20 20 20 63 6f 6e 6e 0a 09 09 09 20 20 20 20 28 conn.... (
54d0: 73 3a 73 71 6c 70 61 72 61 6d 20 71 75 65 72 79 s:sqlparam query
54e0: 20 73 65 73 73 69 6f 6e 2d 6b 65 79 20 22 2a 73 session-key "*s
54f0: 65 73 73 69 6f 6e 76 61 72 73 2a 22 29 29 0a 09 essionvars*"))..
5500: 20 20 3b 3b 20 61 6e 64 20 66 69 6e 61 6c 6c 79 ;; and finally
5510: 20 74 68 65 20 67 6c 6f 62 61 6c 20 76 61 72 73 the global vars
5520: 0a 09 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 .. (dbi:for-eac
5530: 68 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 h-row (lambda (t
5540: 75 70 6c 65 29 0a 09 09 09 20 20 20 20 20 20 28 uple).... (
5550: 6c 65 74 20 28 28 6b 20 28 76 65 63 74 6f 72 2d let ((k (vector-
5560: 72 65 66 20 74 75 70 6c 65 20 30 29 29 0a 09 09 ref tuple 0))...
5570: 09 09 20 20 20 20 28 76 20 28 76 65 63 74 6f 72 .. (v (vector
5580: 2d 72 65 66 20 74 75 70 6c 65 20 31 29 29 29 0a -ref tuple 1))).
5590: 09 09 09 09 28 68 61 73 68 2d 74 61 62 6c 65 2d ....(hash-table-
55a0: 73 65 74 21 20 67 6c 6f 62 61 6c 76 61 72 73 2d set! globalvars-
55b0: 62 65 66 6f 72 65 20 6b 20 76 29 0a 09 09 09 09 before k v).....
55c0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
55d0: 20 67 6c 6f 62 61 6c 76 61 72 73 20 20 20 20 20 globalvars
55e0: 20 20 20 6b 20 76 29 29 29 0a 09 09 09 20 20 20 k v)))....
55f0: 20 63 6f 6e 6e 0a 09 09 09 20 20 20 20 28 73 3a conn.... (s:
5600: 73 71 6c 70 61 72 61 6d 20 71 75 65 72 79 20 73 sqlparam query s
5610: 65 73 73 69 6f 6e 2d 6b 65 79 20 22 2a 67 6c 6f ession-key "*glo
5620: 62 61 6c 76 61 72 73 22 29 29 0a 09 20 20 29 29 balvars")).. ))
5630: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 ))..(define (ses
5640: 73 69 6f 6e 3a 73 61 76 65 2d 76 61 72 73 20 73 sion:save-vars s
5650: 65 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 73 65 elf). (let ((se
5660: 73 73 69 6f 6e 2d 69 64 20 20 28 73 64 61 74 2d ssion-id (sdat-
5670: 67 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 get-session-id s
5680: 65 6c 66 29 29 29 0a 20 20 20 20 28 69 66 20 28 elf))). (if (
5690: 6e 6f 74 20 73 65 73 73 69 6f 6e 2d 69 64 29 0a not session-id).
56a0: 09 28 65 72 72 3a 6c 6f 67 20 22 45 52 52 4f 52 .(err:log "ERROR
56b0: 3a 20 4e 6f 20 73 65 73 73 69 6f 6e 20 69 64 20 : No session id
56c0: 69 6e 20 73 65 73 73 69 6f 6e 20 6f 62 6a 65 63 in session objec
56d0: 74 21 20 73 65 73 73 69 6f 6e 3a 67 65 74 2d 76 t! session:get-v
56e0: 61 72 73 22 29 0a 09 28 6c 65 74 2a 20 28 28 73 ars")..(let* ((s
56f0: 74 61 74 75 73 20 20 20 20 20 20 23 66 29 0a 09 tatus #f)..
5700: 20 20 20 20 20 20 20 28 63 6f 6e 6e 20 20 20 20 (conn
5710: 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d 63 6f (sdat-get-co
5720: 6e 6e 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 nn self))..
5730: 20 20 28 70 61 67 65 2d 6e 61 6d 65 20 20 20 28 (page-name (
5740: 73 64 61 74 2d 67 65 74 2d 70 61 67 65 20 73 65 sdat-get-page se
5750: 6c 66 29 29 0a 09 20 20 20 20 20 20 20 28 64 65 lf)).. (de
5760: 6c 2d 71 75 65 72 79 20 20 20 22 44 45 4c 45 54 l-query "DELET
5770: 45 20 46 52 4f 4d 20 73 65 73 73 69 6f 6e 5f 76 E FROM session_v
5780: 61 72 73 20 57 48 45 52 45 20 73 65 73 73 69 6f ars WHERE sessio
5790: 6e 5f 69 64 3d 3f 20 41 4e 44 20 70 61 67 65 3d n_id=? AND page=
57a0: 3f 20 41 4e 44 20 6b 65 79 3d 3f 3b 22 29 0a 09 ? AND key=?;")..
57b0: 20 20 20 20 20 20 20 28 69 6e 73 2d 71 75 65 72 (ins-quer
57c0: 79 20 20 20 22 49 4e 53 45 52 54 20 49 4e 54 4f y "INSERT INTO
57d0: 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 28 73 session_vars (s
57e0: 65 73 73 69 6f 6e 5f 69 64 2c 70 61 67 65 2c 6b ession_id,page,k
57f0: 65 79 2c 76 61 6c 75 65 29 20 56 41 4c 55 45 53 ey,value) VALUES
5800: 28 3f 2c 3f 2c 3f 2c 3f 29 3b 22 29 0a 09 20 20 (?,?,?,?);")..
5810: 20 20 20 20 20 28 75 70 64 2d 71 75 65 72 79 20 (upd-query
5820: 20 20 22 55 50 44 41 54 45 20 73 65 73 73 69 6f "UPDATE sessio
5830: 6e 5f 76 61 72 73 20 73 65 74 20 76 61 6c 75 65 n_vars set value
5840: 3d 3f 20 57 48 45 52 45 20 6b 65 79 3d 3f 20 41 =? WHERE key=? A
5850: 4e 44 20 73 65 73 73 69 6f 6e 5f 69 64 3d 3f 20 ND session_id=?
5860: 41 4e 44 20 70 61 67 65 3d 3f 3b 22 29 0a 09 20 AND page=?;")..
5870: 20 20 20 20 20 20 28 63 68 61 6e 67 65 64 2d 63 (changed-c
5880: 6f 75 6e 74 20 30 29 29 0a 09 20 20 3b 3b 20 73 ount 0)).. ;; s
5890: 61 76 65 20 74 68 65 20 64 65 6c 74 61 20 6f 6e ave the delta on
58a0: 6c 79 0a 09 20 20 28 66 6f 72 2d 65 61 63 68 0a ly.. (for-each.
58b0: 09 20 20 20 28 6c 61 6d 62 64 61 20 28 70 61 67 . (lambda (pag
58c0: 65 29 20 3b 3b 20 70 61 67 65 20 69 73 3a 20 22 e) ;; page is: "
58d0: 2a 67 6c 6f 62 61 6c 76 61 72 73 2a 22 20 22 2a *globalvars*" "*
58e0: 73 65 73 73 69 6f 6e 76 61 72 73 2a 22 20 6f 72 sessionvars*" or
58f0: 20 6f 74 68 65 72 73 74 72 69 6e 67 0a 09 20 20 otherstring..
5900: 20 20 20 28 6c 65 74 2a 20 28 28 62 65 66 6f 72 (let* ((befor
5910: 65 2d 61 66 74 65 72 2d 68 74 20 28 63 6f 6e 64 e-after-ht (cond
5920: 0a 09 09 09 09 20 20 20 20 20 20 28 28 73 74 72 ..... ((str
5930: 69 6e 67 3d 3f 20 70 61 67 65 20 22 2a 73 65 73 ing=? page "*ses
5940: 73 69 6f 6e 76 61 72 73 2a 22 29 0a 09 09 09 09 sionvars*").....
5950: 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 20 28 (vector (
5960: 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e sdat-get-session
5970: 76 61 72 73 20 73 65 6c 66 29 0a 09 09 09 09 09 vars self)......
5980: 20 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 (sdat-get
5990: 2d 73 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 -sessionvars-bef
59a0: 6f 72 65 20 73 65 6c 66 29 29 29 0a 09 09 09 09 ore self))).....
59b0: 20 20 20 20 20 20 20 28 28 73 74 72 69 6e 67 3d ((string=
59c0: 3f 20 70 61 67 65 20 22 2a 67 6c 6f 62 61 6c 76 ? page "*globalv
59d0: 61 72 73 2a 22 29 0a 09 09 09 09 09 28 76 65 63 ars*")......(vec
59e0: 74 6f 72 20 28 73 64 61 74 2d 67 65 74 2d 67 6c tor (sdat-get-gl
59f0: 6f 62 61 6c 76 61 72 73 20 73 65 6c 66 29 0a 09 obalvars self)..
5a00: 09 09 09 09 09 28 73 64 61 74 2d 67 65 74 2d 67 .....(sdat-get-g
5a10: 6c 6f 62 61 6c 76 61 72 73 2d 62 65 66 6f 72 65 lobalvars-before
5a20: 20 73 65 6c 66 29 29 29 0a 09 09 09 09 20 20 20 self))).....
5a30: 20 20 20 20 28 65 6c 73 65 20 0a 09 09 09 09 09 (else ......
5a40: 28 76 65 63 74 6f 72 20 28 73 64 61 74 2d 67 65 (vector (sdat-ge
5a50: 74 2d 70 61 67 65 76 61 72 73 20 73 65 6c 66 29 t-pagevars self)
5a60: 0a 09 09 09 09 09 09 28 73 64 61 74 2d 67 65 74 .......(sdat-get
5a70: 2d 70 61 67 65 76 61 72 73 2d 62 65 66 6f 72 65 -pagevars-before
5a80: 20 73 65 6c 66 29 29 29 29 29 0a 09 09 20 20 20 self)))))...
5a90: 20 28 6d 61 73 74 65 72 2d 68 74 20 20 20 28 76 (master-ht (v
5aa0: 65 63 74 6f 72 2d 72 65 66 20 62 65 66 6f 72 65 ector-ref before
5ab0: 2d 61 66 74 65 72 2d 68 74 20 30 29 29 0a 09 09 -after-ht 0))...
5ac0: 20 20 20 20 28 62 65 66 6f 72 65 2d 68 74 20 20 (before-ht
5ad0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 62 65 66 (vector-ref bef
5ae0: 6f 72 65 2d 61 66 74 65 72 2d 68 74 20 31 29 29 ore-after-ht 1))
5af0: 0a 09 09 20 20 20 20 28 6d 61 73 74 65 72 2d 6b ... (master-k
5b00: 65 79 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d eys (hash-table-
5b10: 6b 65 79 73 20 6d 61 73 74 65 72 2d 68 74 29 29 keys master-ht))
5b20: 0a 09 09 20 20 20 20 28 62 65 66 6f 72 65 2d 6b ... (before-k
5b30: 65 79 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d eys (hash-table-
5b40: 6b 65 79 73 20 62 65 66 6f 72 65 2d 68 74 29 29 keys before-ht))
5b50: 0a 09 09 20 20 20 20 28 61 6c 6c 2d 6b 65 79 73 ... (all-keys
5b60: 20 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 (delete-duplica
5b70: 74 65 73 20 28 61 70 70 65 6e 64 20 6d 61 73 74 tes (append mast
5b80: 65 72 2d 6b 65 79 73 20 62 65 66 6f 72 65 2d 6b er-keys before-k
5b90: 65 79 73 29 29 29 29 0a 09 20 20 20 20 20 20 20 eys))))..
5ba0: 28 66 6f 72 2d 65 61 63 68 20 0a 09 09 28 6c 61 (for-each ...(la
5bb0: 6d 62 64 61 20 28 6b 65 79 29 0a 09 09 20 20 28 mbda (key)... (
5bc0: 6c 65 74 20 28 28 6d 61 73 74 65 72 2d 76 61 6c let ((master-val
5bd0: 75 65 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 ue (hash-table-r
5be0: 65 66 2f 64 65 66 61 75 6c 74 20 6d 61 73 74 65 ef/default maste
5bf0: 72 2d 68 74 20 6b 65 79 20 23 66 29 29 0a 09 09 r-ht key #f))...
5c00: 09 28 62 65 66 6f 72 65 2d 76 61 6c 75 65 20 28 .(before-value (
5c10: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
5c20: 65 66 61 75 6c 74 20 62 65 66 6f 72 65 2d 68 74 efault before-ht
5c30: 20 6b 65 79 20 23 66 29 29 29 0a 09 09 20 20 20 key #f)))...
5c40: 20 28 63 6f 6e 64 0a 09 09 20 20 20 20 20 3b 3b (cond... ;;
5c50: 20 62 65 66 6f 72 65 20 61 6e 64 20 61 66 74 65 before and afte
5c60: 72 20 65 78 69 73 74 20 61 6e 64 20 76 61 6c 75 r exist and valu
5c70: 65 20 75 6e 63 68 61 6e 67 65 64 20 2d 20 64 6f e unchanged - do
5c80: 20 6e 6f 74 68 69 6e 67 0a 09 09 20 20 20 20 20 nothing...
5c90: 28 28 61 6e 64 20 6d 61 73 74 65 72 2d 76 61 6c ((and master-val
5ca0: 75 65 20 62 65 66 6f 72 65 2d 76 61 6c 75 65 20 ue before-value
5cb0: 28 65 71 75 61 6c 3f 20 6d 61 73 74 65 72 2d 76 (equal? master-v
5cc0: 61 6c 75 65 20 62 65 66 6f 72 65 2d 76 61 6c 75 alue before-valu
5cd0: 65 29 29 29 0a 09 09 20 20 20 20 20 3b 3b 20 62 e)))... ;; b
5ce0: 65 66 6f 72 65 20 61 6e 64 20 61 66 74 65 72 20 efore and after
5cf0: 65 78 69 73 74 20 62 75 74 20 61 72 65 20 63 68 exist but are ch
5d00: 61 6e 67 65 64 0a 09 09 20 20 20 20 20 28 28 61 anged... ((a
5d10: 6e 64 20 6d 61 73 74 65 72 2d 76 61 6c 75 65 20 nd master-value
5d20: 62 65 66 6f 72 65 2d 76 61 6c 75 65 29 0a 09 09 before-value)...
5d30: 20 20 20 20 20 20 28 64 62 69 3a 66 6f 72 2d 65 (dbi:for-e
5d40: 61 63 68 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 ach-row (lambda
5d50: 28 74 75 70 6c 65 29 0a 09 09 09 09 09 20 20 28 (tuple)...... (
5d60: 73 65 74 21 20 63 68 61 6e 67 65 64 2d 63 6f 75 set! changed-cou
5d70: 6e 74 20 28 2b 20 63 68 61 6e 67 65 64 2d 63 6f nt (+ changed-co
5d80: 75 6e 74 20 31 29 29 29 0a 09 09 09 09 09 63 6f unt 1)))......co
5d90: 6e 6e 0a 09 09 09 09 09 28 73 3a 73 71 6c 70 61 nn......(s:sqlpa
5da0: 72 61 6d 20 75 70 64 2d 71 75 65 72 79 20 6d 61 ram upd-query ma
5db0: 73 74 65 72 2d 76 61 6c 75 65 20 6b 65 79 20 73 ster-value key s
5dc0: 65 73 73 69 6f 6e 2d 69 64 20 70 61 67 65 29 29 ession-id page))
5dd0: 29 0a 09 09 20 20 20 20 20 3b 3b 20 6d 61 73 74 )... ;; mast
5de0: 65 72 2d 76 61 6c 75 65 20 6e 6f 20 6c 6f 6e 67 er-value no long
5df0: 65 72 20 65 78 69 73 74 73 20 28 69 2e 65 2e 20 er exists (i.e.
5e00: 23 66 29 20 2d 20 72 65 6d 6f 76 65 20 69 74 65 #f) - remove ite
5e10: 6d 0a 09 09 20 20 20 20 20 28 28 6e 6f 74 20 6d m... ((not m
5e20: 61 73 74 65 72 2d 76 61 6c 75 65 29 0a 09 09 20 aster-value)...
5e30: 20 20 20 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 (dbi:for-ea
5e40: 63 68 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 ch-row (lambda (
5e50: 74 75 70 6c 65 29 0a 09 09 09 09 09 20 20 28 73 tuple)...... (s
5e60: 65 74 21 20 63 68 61 6e 67 65 64 2d 63 6f 75 6e et! changed-coun
5e70: 74 20 28 2b 20 63 68 61 6e 67 65 64 2d 63 6f 75 t (+ changed-cou
5e80: 6e 74 20 31 29 29 29 0a 09 09 09 09 09 63 6f 6e nt 1)))......con
5e90: 6e 0a 09 09 09 09 09 28 73 3a 73 71 6c 70 61 72 n......(s:sqlpar
5ea0: 61 6d 20 64 65 6c 2d 71 75 65 72 79 20 73 65 73 am del-query ses
5eb0: 73 69 6f 6e 2d 69 64 20 70 61 67 65 20 6b 65 79 sion-id page key
5ec0: 29 29 29 0a 09 09 20 20 20 20 20 3b 3b 20 62 65 )))... ;; be
5ed0: 66 6f 72 65 2d 76 61 6c 75 65 20 64 6f 65 73 6e fore-value doesn
5ee0: 27 74 20 65 78 69 73 74 20 2d 20 69 6e 73 65 72 't exist - inser
5ef0: 74 20 61 20 6e 65 77 20 76 61 6c 75 65 0a 09 09 t a new value...
5f00: 20 20 20 20 20 28 28 6e 6f 74 20 62 65 66 6f 72 ((not befor
5f10: 65 2d 76 61 6c 75 65 29 0a 09 09 20 20 20 20 20 e-value)...
5f20: 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 (dbi:for-each-r
5f30: 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c ow (lambda (tupl
5f40: 65 29 0a 09 09 09 09 09 20 20 28 73 65 74 21 20 e)...... (set!
5f50: 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 28 2b changed-count (+
5f60: 20 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 31 changed-count 1
5f70: 29 29 29 0a 09 09 09 09 09 63 6f 6e 6e 0a 09 09 )))......conn...
5f80: 09 09 09 28 73 3a 73 71 6c 70 61 72 61 6d 20 69 ...(s:sqlparam i
5f90: 6e 73 2d 71 75 65 72 79 20 73 65 73 73 69 6f 6e ns-query session
5fa0: 2d 69 64 20 70 61 67 65 20 6b 65 79 20 6d 61 73 -id page key mas
5fb0: 74 65 72 2d 76 61 6c 75 65 29 29 29 0a 09 09 20 ter-value)))...
5fc0: 20 20 20 20 28 65 6c 73 65 20 28 65 72 72 3a 6c (else (err:l
5fd0: 6f 67 20 22 53 68 6f 75 6c 64 6e 27 74 20 67 65 og "Shouldn't ge
5fe0: 74 20 68 65 72 65 22 29 29 29 29 29 0a 09 09 61 t here")))))...a
5ff0: 6c 6c 2d 6b 65 79 73 29 29 29 20 3b 3b 20 70 72 ll-keys))) ;; pr
6000: 6f 63 65 73 73 20 61 6c 6c 20 6b 65 79 73 0a 09 ocess all keys..
6010: 20 20 20 28 6c 69 73 74 20 22 2a 73 65 73 73 69 (list "*sessi
6020: 6f 6e 76 61 72 73 2a 22 20 22 2a 67 6c 6f 62 61 onvars*" "*globa
6030: 6c 76 61 72 73 2a 22 20 70 61 67 65 2d 6e 61 6d lvars*" page-nam
6040: 65 29 29 29 29 29 29 0a 0a 3b 3b 20 28 70 67 3a e))))))..;; (pg:
6050: 73 71 6c 2d 6e 75 6c 6c 2d 6f 62 6a 65 63 74 3f sql-null-object?
6060: 20 65 6c 65 6d 65 6e 74 29 0a 28 64 65 66 69 6e element).(defin
6070: 65 20 28 73 65 73 73 69 6f 6e 3a 72 65 61 64 2d e (session:read-
6080: 63 6f 6e 66 69 67 20 73 65 6c 66 29 0a 20 20 28 config self). (
6090: 6c 65 74 20 28 28 6e 61 6d 65 20 28 73 74 72 69 let ((name (stri
60a0: 6e 67 2d 61 70 70 65 6e 64 20 22 2e 22 20 28 70 ng-append "." (p
60b0: 61 74 68 6e 61 6d 65 2d 66 69 6c 65 20 28 63 61 athname-file (ca
60c0: 72 20 28 61 72 67 76 29 29 29 20 22 2e 63 6f 6e r (argv))) ".con
60d0: 66 69 67 22 29 29 29 0a 20 20 20 20 28 69 66 20 fig"))). (if
60e0: 28 6e 6f 74 20 28 66 69 6c 65 2d 65 78 69 73 74 (not (file-exist
60f0: 73 3f 20 6e 61 6d 65 29 29 0a 09 28 70 72 69 6e s? name))..(prin
6100: 74 20 6e 61 6d 65 20 22 20 6e 6f 74 20 66 6f 75 t name " not fou
6110: 6e 64 20 61 74 20 22 20 28 63 75 72 72 65 6e 74 nd at " (current
6120: 2d 64 69 72 65 63 74 6f 72 79 29 29 0a 09 28 6c -directory))..(l
6130: 65 74 2a 20 28 28 66 70 20 28 6f 70 65 6e 2d 69 et* ((fp (open-i
6140: 6e 70 75 74 2d 66 69 6c 65 20 6e 61 6d 65 29 29 nput-file name))
6150: 0a 09 20 20 20 20 20 20 20 28 69 6e 69 74 61 72 .. (initar
6160: 67 73 20 28 72 65 61 64 20 66 70 29 29 29 0a 09 gs (read fp)))..
6170: 20 20 28 63 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 (close-input-p
6180: 6f 72 74 20 66 70 29 0a 09 20 20 69 6e 69 74 61 ort fp).. inita
6190: 72 67 73 29 29 29 29 0a 0a 3b 3b 20 63 61 6c 6c rgs))))..;; call
61a0: 20 74 68 65 20 63 6f 6e 74 72 6f 6c 6c 65 72 20 the controller
61b0: 69 66 20 69 74 20 65 78 69 73 74 73 0a 3b 3b 20 if it exists.;;
61c0: 0a 3b 3b 20 57 41 52 4e 49 4e 47 20 2d 20 74 68 .;; WARNING - th
61d0: 69 73 20 63 6f 64 65 20 6e 65 65 64 73 20 61 20 is code needs a
61e0: 64 65 66 65 6e 63 65 20 61 67 61 69 6e 73 20 72 defence agains r
61f0: 65 63 75 72 73 69 76 65 20 63 61 6c 6c 69 6e 67 ecursive calling
6200: 21 21 21 21 21 0a 3b 3b 0a 3b 3b 20 20 20 49 20 !!!!!.;;.;; I
6210: 73 75 67 67 65 73 74 20 61 20 6c 69 6d 69 74 20 suggest a limit
6220: 6f 66 20 31 30 30 20 63 61 6c 6c 73 2e 20 50 6c of 100 calls. Pl
6230: 65 6e 74 79 20 66 6f 72 20 61 6c 6c 6f 77 69 6e enty for allowin
6240: 67 20 6d 75 6c 74 69 70 6c 65 20 69 6e 73 74 61 g multiple insta
6250: 6e 63 65 73 0a 3b 3b 20 20 20 6f 66 20 61 20 70 nces.;; of a p
6260: 61 67 65 20 69 6e 73 69 64 65 20 61 6e 6f 74 68 age inside anoth
6270: 65 72 20 70 61 67 65 2e 20 0a 3b 3b 0a 3b 3b 20 er page. .;;.;;
6280: 70 61 72 74 73 20 3d 20 27 62 6f 74 68 20 7c 20 parts = 'both |
6290: 27 63 6f 6e 74 72 6f 6c 20 7c 20 27 76 69 65 77 'control | 'view
62a0: 0a 3b 3b 0a 0a 28 64 65 66 69 6e 65 20 28 66 69 .;;..(define (fi
62b0: 6c 65 73 2d 72 65 61 64 2d 3e 73 74 72 69 6e 67 les-read->string
62c0: 20 2e 20 66 69 6c 65 73 29 0a 20 20 28 73 74 72 . files). (str
62d0: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
62e0: 0a 20 20 20 28 61 70 70 6c 79 20 61 70 70 65 6e . (apply appen
62f0: 64 20 28 6d 61 70 20 66 69 6c 65 2d 72 65 61 64 d (map file-read
6300: 2d 3e 73 74 72 69 6e 67 20 66 69 6c 65 73 29 29 ->string files))
6310: 20 22 5c 6e 22 29 29 0a 0a 28 64 65 66 69 6e 65 "\n"))..(define
6320: 20 28 66 69 6c 65 2d 72 65 61 64 2d 3e 73 74 72 (file-read->str
6330: 69 6e 67 20 66 29 20 0a 20 20 28 6c 65 74 20 28 ing f) . (let (
6340: 28 70 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 66 (p (open-input-f
6350: 69 6c 65 20 66 29 29 29 0a 20 20 20 20 28 6c 65 ile f))). (le
6360: 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 72 65 t loop ((hed (re
6370: 61 64 2d 6c 69 6e 65 20 70 29 29 0a 09 20 20 20 ad-line p))..
6380: 20 20 20 20 28 72 65 73 20 27 28 29 29 29 0a 20 (res '())).
6390: 20 20 20 20 20 28 69 66 20 28 65 6f 66 2d 6f 62 (if (eof-ob
63a0: 6a 65 63 74 3f 20 68 65 64 29 0a 09 20 20 72 65 ject? hed).. re
63b0: 73 0a 09 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 s.. (loop (read
63c0: 2d 6c 69 6e 65 20 70 29 28 61 70 70 65 6e 64 20 -line p)(append
63d0: 72 65 73 20 28 6c 69 73 74 20 68 65 64 29 29 29 res (list hed)))
63e0: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 70 ))))..(define (p
63f0: 72 6f 63 65 73 73 2d 70 6f 72 74 20 70 29 0a 20 rocess-port p).
6400: 20 28 6c 65 74 20 28 28 65 20 28 69 6e 74 65 72 (let ((e (inter
6410: 61 63 74 69 6f 6e 2d 65 6e 76 69 72 6f 6e 6d 65 action-environme
6420: 6e 74 29 29 29 0a 20 20 20 20 28 6d 61 70 20 0a nt))). (map .
6430: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 78 29 (lambda (x)
6440: 0a 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 09 28 . (cond..(
6450: 28 6c 69 73 74 3f 20 78 29 20 78 29 0a 09 28 28 (list? x) x)..((
6460: 73 74 72 69 6e 67 3f 20 78 29 20 78 29 0a 09 28 string? x) x)..(
6470: 65 6c 73 65 20 27 28 29 29 29 29 0a 20 20 20 20 else '()))).
6480: 20 28 70 6f 72 74 2d 6d 61 70 20 28 6c 61 6d 62 (port-map (lamb
6490: 64 61 20 28 73 29 0a 09 09 20 28 65 76 61 6c 20 da (s)... (eval
64a0: 73 20 65 29 29 0a 09 20 20 20 20 20 20 20 28 6c s e)).. (l
64b0: 61 6d 62 64 61 20 28 29 28 72 65 61 64 20 70 29 ambda ()(read p)
64c0: 29 29 29 29 29 0a 0a 3b 3b 20 4d 61 79 20 32 30 )))))..;; May 20
64d0: 31 31 2c 20 70 75 74 74 69 6e 67 20 61 6c 6c 20 11, putting all
64e0: 70 61 67 65 73 20 69 6e 74 6f 20 6f 6e 65 20 64 pages into one d
64f0: 69 72 65 63 74 6f 72 79 20 66 6f 72 20 74 68 65 irectory for the
6500: 20 66 6f 6c 6c 6f 77 69 6e 67 20 72 65 61 73 6f following reaso
6510: 6e 73 3a 0a 3b 3b 20 20 20 31 2e 20 77 61 6e 74 ns:.;; 1. want
6520: 20 66 69 6c 65 6e 61 6d 65 20 74 6f 20 72 65 66 filename to ref
6530: 6c 65 63 74 20 70 61 67 65 20 6e 61 6d 65 20 28 lect page name (
6540: 65 6d 61 63 73 20 6c 69 6d 69 74 61 74 69 6f 6e emacs limitation
6550: 29 0a 3b 3b 20 20 20 32 2e 20 74 68 61 74 27 73 ).;; 2. that's
6560: 20 69 74 21 20 6e 6f 20 6f 74 68 65 72 20 72 65 it! no other re
6570: 61 73 6f 6e 2e 20 63 6f 75 6c 64 20 6d 61 6b 65 ason. could make
6580: 20 69 74 20 63 6f 6e 66 69 67 75 72 61 62 6c 65 it configurable
6590: 20 2e 2e 2e 0a 28 64 65 66 69 6e 65 20 28 73 65 ....(define (se
65a0: 73 73 69 6f 6e 3a 63 61 6c 6c 2d 70 61 72 74 73 ssion:call-parts
65b0: 20 73 65 6c 66 20 70 61 67 65 20 70 61 72 74 73 self page parts
65c0: 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 63 75 ). (sdat-set-cu
65d0: 72 72 2d 70 61 67 65 21 20 73 65 6c 66 20 70 61 rr-page! self pa
65e0: 67 65 29 0a 20 20 3b 3b 20 28 73 65 73 73 69 6f ge). ;; (sessio
65f0: 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 70 61 67 65 n:log self "page
6600: 2d 64 69 72 2d 73 74 79 6c 65 3a 20 22 20 28 73 -dir-style: " (s
6610: 64 61 74 2d 67 65 74 2d 70 61 67 65 2d 64 69 72 dat-get-page-dir
6620: 2d 73 74 79 6c 65 20 73 65 6c 66 29 29 0a 20 20 -style self)).
6630: 28 6c 65 74 2a 20 28 28 64 69 72 2d 73 74 79 6c (let* ((dir-styl
6640: 65 20 3b 3b 20 28 65 71 75 61 6c 3f 20 28 73 64 e ;; (equal? (sd
6650: 61 74 2d 67 65 74 2d 70 61 67 65 2d 64 69 72 2d at-get-page-dir-
6660: 73 74 79 6c 65 20 73 65 6c 66 29 20 22 6f 6e 65 style self) "one
6670: 64 69 72 22 29 29 20 3b 3b 20 66 6c 61 67 20 23 dir")) ;; flag #
6680: 74 20 66 6f 72 20 6f 6e 65 64 69 72 2c 20 23 66 t for onedir, #f
6690: 20 66 6f 72 20 6f 6c 64 20 73 74 79 6c 65 0a 09 for old style..
66a0: 20 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 (sdat-get-page
66b0: 2d 64 69 72 2d 73 74 79 6c 65 20 73 65 6c 66 29 -dir-style self)
66c0: 29 0a 09 20 28 64 69 72 20 20 20 20 20 28 73 74 ).. (dir (st
66d0: 72 69 6e 67 2d 61 70 70 65 6e 64 20 28 73 64 61 ring-append (sda
66e0: 74 2d 67 65 74 2d 73 72 6f 6f 74 20 73 65 6c 66 t-get-sroot self
66f0: 29 20 0a 09 09 09 09 20 28 69 66 20 64 69 72 2d ) ..... (if dir-
6700: 73 74 79 6c 65 20 0a 09 09 09 09 20 20 20 20 20 style .....
6710: 28 63 6f 6e 63 20 22 2f 70 61 67 65 73 2f 22 29 (conc "/pages/")
6720: 0a 09 09 09 09 20 20 20 20 20 28 63 6f 6e 63 20 ..... (conc
6730: 22 2f 70 61 67 65 73 2f 22 20 70 61 67 65 29 29 "/pages/" page))
6740: 29 29 0a 09 20 28 63 6f 6e 74 72 6f 6c 20 28 73 )).. (control (s
6750: 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 64 69 72 tring-append dir
6760: 20 28 69 66 20 64 69 72 2d 73 74 79 6c 65 20 0a (if dir-style .
6770: 09 09 09 09 09 20 28 63 6f 6e 63 20 70 61 67 65 ..... (conc page
6780: 20 22 5f 63 74 72 6c 2e 73 63 6d 22 29 0a 09 09 "_ctrl.scm")...
6790: 09 09 09 20 22 2f 63 6f 6e 74 72 6f 6c 2e 73 63 ... "/control.sc
67a0: 6d 22 29 29 29 0a 09 20 28 76 69 65 77 20 20 20 m"))).. (view
67b0: 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 (string-append
67c0: 64 69 72 20 28 69 66 20 64 69 72 2d 73 74 79 6c dir (if dir-styl
67d0: 65 20 0a 09 09 09 09 09 20 28 63 6f 6e 63 20 70 e ...... (conc p
67e0: 61 67 65 20 22 5f 76 69 65 77 2e 73 63 6d 22 29 age "_view.scm")
67f0: 0a 09 09 09 09 09 20 22 2f 76 69 65 77 2e 73 63 ...... "/view.sc
6800: 6d 22 29 29 29 0a 09 20 28 6c 6f 61 64 2d 76 69 m"))).. (load-vi
6810: 65 77 20 20 20 20 28 61 6e 64 20 28 66 69 6c 65 ew (and (file
6820: 2d 65 78 69 73 74 73 3f 20 76 69 65 77 29 0a 09 -exists? view)..
6830: 09 09 20 20 20 20 28 6f 72 20 28 65 71 3f 20 70 .. (or (eq? p
6840: 61 72 74 73 20 27 62 6f 74 68 29 28 65 71 3f 20 arts 'both)(eq?
6850: 70 61 72 74 73 20 27 76 69 65 77 29 29 29 29 0a parts 'view)))).
6860: 09 20 28 6c 6f 61 64 2d 63 6f 6e 74 72 6f 6c 20 . (load-control
6870: 28 61 6e 64 20 28 66 69 6c 65 2d 65 78 69 73 74 (and (file-exist
6880: 73 3f 20 63 6f 6e 74 72 6f 6c 29 0a 09 09 09 20 s? control)....
6890: 20 20 20 28 6f 72 20 28 65 71 3f 20 70 61 72 74 (or (eq? part
68a0: 73 20 27 62 6f 74 68 29 28 65 71 3f 20 70 61 72 s 'both)(eq? par
68b0: 74 73 20 27 63 6f 6e 74 72 6f 6c 29 29 29 29 0a ts 'control)))).
68c0: 09 20 28 76 69 65 77 2d 64 61 74 20 20 20 27 28 . (view-dat '(
68d0: 29 29 29 0a 20 20 20 20 3b 3b 20 28 73 65 73 73 ))). ;; (sess
68e0: 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 64 69 ion:log self "di
68f0: 72 2d 73 74 79 6c 65 3a 20 22 20 64 69 72 2d 73 r-style: " dir-s
6900: 74 79 6c 65 29 0a 20 3b 3b 20 20 20 28 73 75 67 tyle). ;; (sug
6910: 61 72 20 22 2f 68 6f 6d 65 2f 6d 61 74 74 2f 6b ar "/home/matt/k
6920: 69 61 74 6f 61 2f 73 74 6d 6c 2f 73 75 67 61 72 iatoa/stml/sugar
6930: 2e 73 63 6d 22 20 29 29 0a 20 20 20 20 3b 3b 20 .scm" )). ;;
6940: 28 70 72 69 6e 74 20 22 64 69 72 3d 22 20 64 69 (print "dir=" di
6950: 72 20 22 20 63 6f 6e 74 72 6f 6c 3d 22 20 63 6f r " control=" co
6960: 6e 74 72 6f 6c 20 22 20 76 69 65 77 3d 22 20 76 ntrol " view=" v
6970: 69 65 77 20 22 20 6c 6f 61 64 2d 76 69 65 77 3d iew " load-view=
6980: 22 20 6c 6f 61 64 2d 76 69 65 77 20 22 20 6c 6f " load-view " lo
6990: 61 64 3d 63 6f 6e 74 72 6f 6c 3d 22 20 6c 6f 61 ad=control=" loa
69a0: 64 2d 63 6f 6e 74 72 6f 6c 29 0a 20 20 20 20 28 d-control). (
69b0: 69 66 20 6c 6f 61 64 2d 63 6f 6e 74 72 6f 6c 0a if load-control.
69c0: 09 28 62 65 67 69 6e 0a 09 20 20 28 6c 6f 61 64 .(begin.. (load
69d0: 20 63 6f 6e 74 72 6f 6c 29 0a 09 20 20 28 73 65 control).. (se
69e0: 73 73 69 6f 6e 3a 73 65 74 2d 63 61 6c 6c 65 64 ssion:set-called
69f0: 21 20 73 65 6c 66 20 70 61 67 65 29 29 29 0a 20 ! self page))).
6a00: 20 20 20 3b 3b 20 6d 6f 76 65 20 74 68 69 73 20 ;; move this
6a10: 74 6f 20 77 68 65 72 65 20 69 74 20 67 65 74 73 to where it gets
6a20: 20 65 78 65 63 74 75 74 65 64 20 6f 6e 6c 79 20 exectuted only
6a30: 6f 6e 63 65 0a 20 20 20 20 3b 3b 0a 20 20 20 20 once. ;;.
6a40: 3b 3b 28 73 3a 6c 6f 67 20 22 73 3a 62 20 79 69 ;;(s:log "s:b yi
6a50: 65 6c 64 73 20 22 20 28 73 3a 62 20 22 62 6c 61 elds " (s:b "bla
6a60: 68 22 29 29 0a 20 20 20 20 28 69 66 20 6c 6f 61 h")). (if loa
6a70: 64 2d 76 69 65 77 0a 09 3b 3b 20 6f 70 74 69 6f d-view..;; optio
6a80: 6e 20 6f 6e 65 3a 0a 09 3b 3b 0a 09 3b 3b 20 28 n one:..;;..;; (
6a90: 6c 65 74 20 28 28 69 6e 70 20 28 6f 70 65 6e 2d let ((inp (open-
6aa0: 69 6e 70 75 74 2d 73 74 72 69 6e 67 20 0a 09 3b input-string ..;
6ab0: 3b 20 09 20 20 20 20 28 66 69 6c 65 73 2d 72 65 ; . (files-re
6ac0: 61 64 2d 3e 73 74 72 69 6e 67 20 22 2f 68 6f 6d ad->string "/hom
6ad0: 65 2f 6d 61 74 74 2f 6b 69 61 74 6f 61 2f 73 74 e/matt/kiatoa/st
6ae0: 6d 6c 2f 73 75 67 61 72 2e 73 63 6d 22 20 0a 09 ml/sugar.scm" ..
6af0: 3b 3b 20 09 09 09 09 76 69 65 77 29 29 29 29 0a ;; ....view)))).
6b00: 09 3b 3b 20 20 20 28 6d 61 70 20 0a 09 3b 3b 20 .;; (map ..;;
6b10: 20 20 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 (lambda (x)..
6b20: 3b 3b 20 20 20 20 20 20 28 63 6f 6e 64 0a 09 3b ;; (cond..;
6b30: 3b 20 20 20 20 20 20 20 28 28 6c 69 73 74 3f 20 ; ((list?
6b40: 78 29 20 78 29 0a 09 3b 3b 20 20 20 20 20 20 20 x) x)..;;
6b50: 28 28 73 74 72 69 6e 67 3f 20 78 29 20 78 29 0a ((string? x) x).
6b60: 09 3b 3b 20 20 20 20 20 20 20 28 65 6c 73 65 20 .;; (else
6b70: 27 28 29 29 29 29 0a 09 3b 3b 20 20 20 20 28 70 '())))..;; (p
6b80: 6f 72 74 2d 6d 61 70 20 65 76 61 6c 20 28 6c 61 ort-map eval (la
6b90: 6d 62 64 61 20 28 29 0a 09 3b 3b 20 09 09 20 28 mbda ()..;; .. (
6ba0: 72 65 61 64 20 69 6e 70 29 29 29 29 29 0a 09 3b read inp)))))..;
6bb0: 3b 0a 09 3b 3b 20 6f 70 74 69 6f 6e 20 74 77 6f ;..;; option two
6bc0: 3a 0a 09 3b 3b 0a 09 28 6c 65 74 2a 20 28 3b 3b :..;;..(let* (;;
6bd0: 20 28 69 6e 70 73 20 28 6d 61 70 20 6f 70 65 6e (inps (map open
6be0: 2d 69 6e 70 75 74 2d 66 69 6c 65 20 28 6c 69 73 -input-file (lis
6bf0: 74 20 76 69 65 77 29 29 29 20 3b 3b 20 73 75 67 t view))) ;; sug
6c00: 61 72 20 76 69 65 77 29 29 29 0a 09 20 20 20 20 ar view)))..
6c10: 20 20 20 28 70 20 20 20 20 28 6f 70 65 6e 2d 69 (p (open-i
6c20: 6e 70 75 74 2d 66 69 6c 65 20 76 69 65 77 29 29 nput-file view))
6c30: 20 3b 3b 20 28 61 70 70 6c 79 20 6d 61 6b 65 2d ;; (apply make-
6c40: 63 6f 6e 63 61 74 65 6e 61 74 65 64 2d 70 6f 72 concatenated-por
6c50: 74 20 69 6e 70 73 29 29 0a 09 20 20 20 20 20 20 t inps))..
6c60: 20 28 64 61 74 20 20 28 70 72 6f 63 65 73 73 2d (dat (process-
6c70: 70 6f 72 74 20 70 29 29 29 0a 09 09 3b 3b 28 6d port p)))...;;(m
6c80: 61 70 20 0a 09 09 3b 3b 20 20 20 20 20 20 28 6c ap ...;; (l
6c90: 61 6d 62 64 61 20 28 78 29 0a 09 09 3b 3b 09 28 ambda (x)...;;.(
6ca0: 63 6f 6e 64 0a 09 09 3b 3b 09 20 28 28 6c 69 73 cond...;;. ((lis
6cb0: 74 3f 20 78 29 20 78 29 0a 09 09 3b 3b 09 20 28 t? x) x)...;;. (
6cc0: 28 73 74 72 69 6e 67 3f 20 78 29 20 78 29 0a 09 (string? x) x)..
6cd0: 09 3b 3b 09 20 28 65 6c 73 65 20 27 28 29 29 29 .;;. (else '()))
6ce0: 29 0a 09 09 3b 3b 20 20 20 20 20 20 28 70 6f 72 )...;; (por
6cf0: 74 2d 6d 61 70 20 65 76 61 6c 20 28 6c 61 6d 62 t-map eval (lamb
6d00: 64 61 20 28 29 28 72 65 61 64 20 70 29 29 29 29 da ()(read p))))
6d10: 29 29 0a 09 20 20 3b 3b 20 28 6d 61 70 20 63 6c )).. ;; (map cl
6d20: 6f 73 65 2d 69 6e 70 75 74 2d 70 6f 72 74 20 69 ose-input-port i
6d30: 6e 70 73 29 0a 09 20 20 28 63 6c 6f 73 65 2d 69 nps).. (close-i
6d40: 6e 70 75 74 2d 70 6f 72 74 20 70 29 0a 09 20 20 nput-port p)..
6d50: 64 61 74 29 0a 09 28 6c 69 73 74 20 22 3c 70 3e dat)..(list "<p>
6d60: 50 61 67 65 20 6e 6f 74 20 66 6f 75 6e 64 20 22 Page not found "
6d70: 20 70 61 67 65 20 22 20 3c 2f 70 3e 22 29 29 29 page " </p>")))
6d80: 29 0a 0a 3b 3b 28 64 65 66 69 6e 65 20 28 73 65 )..;;(define (se
6d90: 73 73 69 6f 6e 3a 63 61 6c 6c 20 73 65 6c 66 20 ssion:call self
6da0: 70 61 67 65 29 0a 3b 3b 20 20 28 73 65 73 73 69 page).;; (sessi
6db0: 6f 6e 3a 63 61 6c 6c 2d 70 61 72 74 73 20 73 65 on:call-parts se
6dc0: 6c 66 20 70 61 67 65 20 27 62 6f 74 68 29 29 0a lf page 'both)).
6dd0: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
6de0: 6e 3a 63 61 6c 6c 20 73 65 6c 66 20 70 61 67 65 n:call self page
6df0: 20 70 61 72 74 73 29 0a 20 20 28 73 65 73 73 69 parts). (sessi
6e00: 6f 6e 3a 63 61 6c 6c 2d 70 61 72 74 73 20 73 65 on:call-parts se
6e10: 6c 66 20 70 61 67 65 20 27 62 6f 74 68 29 29 0a lf page 'both)).
6e20: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
6e30: 6e 3a 6c 6f 61 64 2d 6d 6f 64 65 6c 20 73 65 6c n:load-model sel
6e40: 66 20 6d 6f 64 65 6c 29 0a 20 20 28 6c 65 74 20 f model). (let
6e50: 28 28 6d 6f 64 65 6c 2e 73 63 6d 20 28 73 74 72 ((model.scm (str
6e60: 69 6e 67 2d 61 70 70 65 6e 64 20 28 73 64 61 74 ing-append (sdat
6e70: 2d 67 65 74 2d 73 72 6f 6f 74 20 73 65 6c 66 29 -get-sroot self)
6e80: 20 22 2f 6d 6f 64 65 6c 73 2f 22 20 6d 6f 64 65 "/models/" mode
6e90: 6c 20 22 2e 73 63 6d 22 29 29 0a 09 28 6d 6f 64 l ".scm"))..(mod
6ea0: 65 6c 2e 73 6f 20 20 28 73 74 72 69 6e 67 2d 61 el.so (string-a
6eb0: 70 70 65 6e 64 20 28 73 64 61 74 2d 67 65 74 2d ppend (sdat-get-
6ec0: 73 72 6f 6f 74 20 73 65 6c 66 29 20 22 2f 6d 6f sroot self) "/mo
6ed0: 64 65 6c 73 2f 22 20 6d 6f 64 65 6c 20 22 2e 73 dels/" model ".s
6ee0: 6f 22 29 29 29 0a 20 20 20 20 28 69 66 20 28 66 o"))). (if (f
6ef0: 69 6c 65 2d 65 78 69 73 74 73 3f 20 6d 6f 64 65 ile-exists? mode
6f00: 6c 2e 73 6f 29 0a 09 28 6c 6f 61 64 20 6d 6f 64 l.so)..(load mod
6f10: 65 6c 2e 73 6f 29 0a 09 28 69 66 20 28 66 69 6c el.so)..(if (fil
6f20: 65 2d 65 78 69 73 74 73 3f 20 6d 6f 64 65 6c 2e e-exists? model.
6f30: 73 63 6d 29 0a 09 20 20 20 20 28 6c 6f 61 64 20 scm).. (load
6f40: 6d 6f 64 65 6c 2e 73 63 6d 29 0a 09 20 20 20 20 model.scm)..
6f50: 28 73 3a 6c 6f 67 20 22 45 52 52 4f 52 3a 20 6d (s:log "ERROR: m
6f60: 6f 64 65 6c 20 22 20 6d 6f 64 65 6c 2e 73 63 6d odel " model.scm
6f70: 20 22 20 6e 6f 74 20 66 6f 75 6e 64 22 29 29 29 " not found")))
6f80: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 ))..(define (ses
6f90: 73 69 6f 6e 3a 6d 6f 64 65 6c 2d 70 61 74 68 20 sion:model-path
6fa0: 73 65 6c 66 20 6d 6f 64 65 6c 29 0a 20 20 28 73 self model). (s
6fb0: 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 28 73 64 tring-append (sd
6fc0: 61 74 2d 67 65 74 2d 73 72 6f 6f 74 20 73 65 6c at-get-sroot sel
6fd0: 66 29 20 22 2f 6d 6f 64 65 6c 73 2f 22 20 6d 6f f) "/models/" mo
6fe0: 64 65 6c 20 22 2e 73 63 6d 22 29 29 0a 0a 28 64 del ".scm"))..(d
6ff0: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 70 efine (session:p
7000: 70 2d 66 6f 72 6d 64 61 74 20 73 65 6c 66 29 0a p-formdat self).
7010: 20 20 28 6c 65 74 20 28 28 64 61 74 20 28 66 6f (let ((dat (fo
7020: 72 6d 64 61 74 3a 61 6c 6c 2d 3e 73 74 72 69 6e rmdat:all->strin
7030: 67 73 20 28 73 64 61 74 2d 67 65 74 2d 66 6f 72 gs (sdat-get-for
7040: 6d 64 61 74 20 73 65 6c 66 29 29 29 29 0a 20 20 mdat self)))).
7050: 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 (string-inters
7060: 70 65 72 73 65 20 64 61 74 20 22 3c 62 72 3e 20 perse dat "<br>
7070: 22 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 ")))..(define (s
7080: 65 73 73 69 6f 6e 3a 70 61 72 61 6d 2d 3e 73 74 ession:param->st
7090: 72 69 6e 67 20 70 61 72 61 6d 73 29 0a 20 20 3b ring params). ;
70a0: 3b 20 28 65 72 72 3a 6c 6f 67 20 22 70 61 72 61 ; (err:log "para
70b0: 6d 73 3d 22 20 70 61 72 61 6d 73 29 0a 20 20 28 ms=" params). (
70c0: 69 66 20 28 3c 20 28 6c 65 6e 67 74 68 20 70 61 if (< (length pa
70d0: 72 61 6d 73 29 20 31 29 0a 20 20 20 20 20 20 22 rams) 1). "
70e0: 22 0a 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f ". (let loo
70f0: 70 20 28 28 6b 65 79 20 28 63 61 72 20 70 61 72 p ((key (car par
7100: 61 6d 73 29 29 0a 09 09 20 28 76 61 6c 20 28 63 ams))... (val (c
7110: 61 64 72 20 70 61 72 61 6d 73 29 29 0a 09 09 20 adr params))...
7120: 28 74 61 69 6c 20 28 63 64 64 72 20 70 61 72 61 (tail (cddr para
7130: 6d 73 29 29 0a 09 09 20 28 72 65 73 75 6c 74 20 ms))... (result
7140: 27 28 29 29 29 0a 09 28 6c 65 74 20 28 28 6e 65 '()))..(let ((ne
7150: 77 72 65 73 75 6c 74 20 28 63 6f 6e 73 20 28 73 wresult (cons (s
7160: 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 28 73 3a tring-append (s:
7170: 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6b 65 79 29 any->string key)
7180: 20 22 3d 22 20 28 73 3a 61 6e 79 2d 3e 73 74 72 "=" (s:any->str
7190: 69 6e 67 20 76 61 6c 29 29 0a 09 09 09 20 20 20 ing val))....
71a0: 20 20 20 20 72 65 73 75 6c 74 29 29 29 0a 09 20 result)))..
71b0: 20 28 69 66 20 28 3c 20 28 6c 65 6e 67 74 68 20 (if (< (length
71c0: 74 61 69 6c 29 20 31 29 20 3b 3b 20 74 72 75 65 tail) 1) ;; true
71d0: 20 69 66 20 64 6f 6e 65 0a 09 20 20 20 20 20 20 if done..
71e0: 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
71f0: 72 73 65 20 6e 65 77 72 65 73 75 6c 74 20 22 26 rse newresult "&
7200: 22 29 0a 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 ").. (loop
7210: 28 63 61 72 20 74 61 69 6c 29 28 63 61 64 72 20 (car tail)(cadr
7220: 74 61 69 6c 29 28 63 64 64 72 20 74 61 69 6c 29 tail)(cddr tail)
7230: 20 6e 65 77 72 65 73 75 6c 74 29 29 29 29 29 29 newresult))))))
7240: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ..(define (sessi
7250: 6f 6e 3a 6c 69 6e 6b 2d 74 6f 20 73 65 6c 66 20 on:link-to self
7260: 70 61 67 65 20 70 61 72 61 6d 73 29 0a 20 20 28 page params). (
7270: 6c 65 74 2a 20 28 28 73 65 72 76 65 72 20 20 20 let* ((server
7280: 20 28 69 66 20 28 67 65 74 2d 65 6e 76 69 72 6f (if (get-enviro
7290: 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 nment-variable "
72a0: 48 54 54 50 5f 48 4f 53 54 22 29 0a 09 09 09 28 HTTP_HOST")....(
72b0: 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d get-environment-
72c0: 76 61 72 69 61 62 6c 65 20 22 48 54 54 50 5f 48 variable "HTTP_H
72d0: 4f 53 54 22 29 0a 09 09 09 28 67 65 74 2d 65 6e OST")....(get-en
72e0: 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 vironment-variab
72f0: 6c 65 20 22 53 45 52 56 45 52 5f 4e 41 4d 45 22 le "SERVER_NAME"
7300: 29 29 29 0a 09 20 28 73 63 72 69 70 74 20 28 6c ))).. (script (l
7310: 65 74 20 28 28 73 63 72 69 70 74 2d 6e 61 6d 65 et ((script-name
7320: 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 28 (string-split (
7330: 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d get-environment-
7340: 76 61 72 69 61 62 6c 65 20 22 53 43 52 49 50 54 variable "SCRIPT
7350: 5f 4e 41 4d 45 22 29 20 22 2f 22 29 29 29 0a 09 _NAME") "/")))..
7360: 09 20 20 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 . (if (> (leng
7370: 74 68 20 73 63 72 69 70 74 2d 6e 61 6d 65 29 20 th script-name)
7380: 31 29 0a 09 09 20 20 20 20 20 20 20 28 73 74 72 1)... (str
7390: 69 6e 67 2d 61 70 70 65 6e 64 20 28 63 61 72 20 ing-append (car
73a0: 73 63 72 69 70 74 2d 6e 61 6d 65 29 20 22 2f 22 script-name) "/"
73b0: 20 28 63 61 64 72 20 73 63 72 69 70 74 2d 6e 61 (cadr script-na
73c0: 6d 65 29 29 0a 09 09 20 20 20 20 20 20 20 28 67 me))... (g
73d0: 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 et-environment-v
73e0: 61 72 69 61 62 6c 65 20 22 53 43 52 49 50 54 5f ariable "SCRIPT_
73f0: 4e 41 4d 45 22 29 29 29 29 20 3b 3b 20 62 75 69 NAME")))) ;; bui
7400: 6c 64 20 73 63 72 69 70 74 20 6e 61 6d 65 20 66 ld script name f
7410: 72 6f 6d 20 66 69 72 73 74 20 74 77 6f 20 65 6c rom first two el
7420: 65 6d 65 6e 74 73 2e 20 54 68 69 73 20 69 73 20 ements. This is
7430: 61 20 68 61 6e 67 6f 76 65 72 20 66 72 6f 6d 20 a hangover from
7440: 62 65 66 6f 72 65 20 49 20 75 73 65 64 20 3f 20 before I used ?
7450: 69 6e 20 74 68 65 20 55 52 4c 2e 0a 09 20 28 73 in the URL... (s
7460: 65 73 73 69 6f 6e 2d 6b 65 79 20 28 73 64 61 74 ession-key (sdat
7470: 2d 67 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 -get-session-key
7480: 20 73 65 6c 66 29 29 0a 09 20 28 70 61 72 61 6d self)).. (param
7490: 73 74 72 20 28 73 65 73 73 69 6f 6e 3a 70 61 72 str (session:par
74a0: 61 6d 2d 3e 73 74 72 69 6e 67 20 70 61 72 61 6d am->string param
74b0: 73 29 29 29 0a 20 20 20 20 3b 3b 20 28 73 65 73 s))). ;; (ses
74c0: 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 73 sion:log self "s
74d0: 65 72 76 65 72 3d 22 20 73 65 72 76 65 72 20 22 erver=" server "
74e0: 20 73 63 72 69 70 74 3d 22 20 73 63 72 69 70 74 script=" script
74f0: 20 22 20 70 61 67 65 3d 22 20 70 61 67 65 29 0a " page=" page).
7500: 20 20 20 20 28 73 74 72 69 6e 67 2d 61 70 70 65 (string-appe
7510: 6e 64 20 22 68 74 74 70 3a 2f 2f 22 20 73 65 72 nd "http://" ser
7520: 76 65 72 20 22 2f 22 20 73 63 72 69 70 74 20 22 ver "/" script "
7530: 2f 22 20 70 61 67 65 20 22 3f 22 20 70 61 72 61 /" page "?" para
7540: 6d 73 74 72 29 29 29 20 3b 3b 20 22 2f 73 6e 3d mstr))) ;; "/sn=
7550: 22 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 29 " session-key)))
7560: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ..(define (sessi
7570: 6f 6e 3a 63 67 69 2d 6f 75 74 20 73 65 6c 66 29 on:cgi-out self)
7580: 0a 20 20 28 6c 65 74 2a 20 28 28 63 6f 6e 74 65 . (let* ((conte
7590: 6e 74 20 20 28 6c 69 73 74 20 28 73 64 61 74 2d nt (list (sdat-
75a0: 67 65 74 2d 63 6f 6e 74 65 6e 74 2d 74 79 70 65 get-content-type
75b0: 20 73 65 6c 66 29 29 29 20 3b 3b 20 27 28 22 43 self))) ;; '("C
75c0: 6f 6e 74 65 6e 74 2d 74 79 70 65 3a 20 74 65 78 ontent-type: tex
75d0: 74 2f 68 74 6d 6c 3b 20 63 68 61 72 73 65 74 3d t/html; charset=
75e0: 69 73 6f 2d 38 38 35 39 2d 31 5c 6e 5c 6e 22 29 iso-8859-1\n\n")
75f0: 29 0a 09 20 28 68 65 61 64 65 72 20 20 20 28 6c ).. (header (l
7600: 65 74 20 28 28 63 6f 6f 6b 69 65 20 28 73 64 61 et ((cookie (sda
7610: 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 2d 63 6f t-get-session-co
7620: 6f 6b 69 65 20 73 65 6c 66 29 29 29 0a 09 09 20 okie self)))...
7630: 20 20 20 20 28 69 66 20 63 6f 6f 6b 69 65 0a 09 (if cookie..
7640: 09 09 20 28 63 6f 6e 73 20 28 73 74 72 69 6e 67 .. (cons (string
7650: 2d 61 70 70 65 6e 64 20 22 53 65 74 2d 43 6f 6f -append "Set-Coo
7660: 6b 69 65 3a 20 22 20 28 63 61 72 20 63 6f 6f 6b kie: " (car cook
7670: 69 65 29 29 0a 09 09 09 20 20 20 20 20 20 20 63 ie)).... c
7680: 6f 6e 74 65 6e 74 29 0a 09 09 09 20 63 6f 6e 74 ontent).... cont
7690: 65 6e 74 29 29 29 0a 09 20 28 70 61 67 65 64 61 ent))).. (pageda
76a0: 74 20 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 t (sdat-get-pag
76b0: 65 64 61 74 20 73 65 6c 66 29 29 29 0a 20 20 20 edat self))).
76c0: 20 28 73 3a 63 67 69 2d 6f 75 74 20 0a 20 20 20 (s:cgi-out .
76d0: 20 20 28 63 6f 6e 73 20 68 65 61 64 65 72 20 70 (cons header p
76e0: 61 67 65 64 61 74 29 29 29 29 0a 0a 28 64 65 66 agedat))))..(def
76f0: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 ine (session:log
7700: 20 73 65 6c 66 20 2e 20 6d 73 67 29 0a 20 20 28 self . msg). (
7710: 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 70 with-output-to-p
7720: 6f 72 74 20 28 73 64 61 74 2d 67 65 74 2d 6c 6f ort (sdat-get-lo
7730: 67 2d 70 6f 72 74 20 73 65 6c 66 29 20 3b 3b 20 g-port self) ;;
7740: 28 73 64 61 74 2d 67 65 74 2d 6c 6f 67 70 74 20 (sdat-get-logpt
7750: 73 65 6c 66 29 0a 20 20 20 20 28 6c 61 6d 62 64 self). (lambd
7760: 61 20 28 29 20 0a 20 20 20 20 20 20 28 61 70 70 a () . (app
7770: 6c 79 20 70 72 69 6e 74 20 6d 73 67 29 29 29 29 ly print msg))))
7780: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ..(define (sessi
7790: 6f 6e 3a 67 65 74 2d 70 61 72 61 6d 20 73 65 6c on:get-param sel
77a0: 66 20 6b 65 79 29 0a 20 20 3b 3b 20 28 73 65 73 f key). ;; (ses
77b0: 73 69 6f 6e 3a 6c 6f 67 20 73 3a 73 65 73 73 69 sion:log s:sessi
77c0: 6f 6e 20 22 70 61 72 61 6d 73 3d 22 20 28 73 6c on "params=" (sl
77d0: 6f 74 2d 72 65 66 20 73 3a 73 65 73 73 69 6f 6e ot-ref s:session
77e0: 20 27 70 61 72 61 6d 73 29 29 0a 20 20 28 6c 65 'params)). (le
77f0: 74 20 28 28 70 61 72 61 6d 73 20 28 73 64 61 74 t ((params (sdat
7800: 2d 67 65 74 2d 70 61 72 61 6d 73 20 73 65 6c 66 -get-params self
7810: 29 29 29 0a 20 20 20 20 28 73 65 73 73 69 6f 6e ))). (session
7820: 3a 67 65 74 2d 70 61 72 61 6d 2d 66 72 6f 6d 20 :get-param-from
7830: 70 61 72 61 6d 73 20 6b 65 79 29 29 29 0a 0a 3b params key)))..;
7840: 3b 20 54 68 69 73 20 6f 6e 65 20 77 69 6c 6c 20 ; This one will
7850: 67 65 74 20 74 68 65 20 66 69 72 73 74 20 76 61 get the first va
7860: 6c 75 65 20 66 6f 75 6e 64 20 72 65 67 61 72 64 lue found regard
7870: 6c 65 73 73 20 6f 66 20 66 6f 72 6d 0a 28 64 65 less of form.(de
7880: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 fine (session:ge
7890: 74 2d 69 6e 70 75 74 20 73 65 6c 66 20 6b 65 79 t-input self key
78a0: 29 0a 20 20 28 6c 65 74 2a 20 28 28 66 6f 72 6d ). (let* ((form
78b0: 64 61 74 20 28 73 64 61 74 2d 67 65 74 2d 66 6f dat (sdat-get-fo
78c0: 72 6d 64 61 74 20 73 65 6c 66 29 29 29 0a 20 20 rmdat self))).
78d0: 20 20 28 69 66 20 28 6e 6f 74 20 66 6f 72 6d 64 (if (not formd
78e0: 61 74 29 20 23 66 0a 09 28 69 66 20 28 6f 72 20 at) #f..(if (or
78f0: 28 73 74 72 69 6e 67 3f 20 6b 65 79 29 28 6e 75 (string? key)(nu
7900: 6d 62 65 72 3f 20 6b 65 79 29 28 73 79 6d 62 6f mber? key)(symbo
7910: 6c 3f 20 6b 65 79 29 29 0a 09 20 20 20 20 28 69 l? key)).. (i
7920: 66 20 28 61 6e 64 20 28 76 65 63 74 6f 72 3f 20 f (and (vector?
7930: 66 6f 72 6d 64 61 74 29 28 65 71 3f 20 28 76 65 formdat)(eq? (ve
7940: 63 74 6f 72 2d 6c 65 6e 67 74 68 20 66 6f 72 6d ctor-length form
7950: 64 61 74 29 20 31 29 28 68 61 73 68 2d 74 61 62 dat) 1)(hash-tab
7960: 6c 65 3f 20 28 76 65 63 74 6f 72 2d 72 65 66 20 le? (vector-ref
7970: 66 6f 72 6d 64 61 74 20 30 29 29 29 0a 09 09 28 formdat 0)))...(
7980: 66 6f 72 6d 64 61 74 3a 67 65 74 20 66 6f 72 6d formdat:get form
7990: 64 61 74 20 6b 65 79 29 0a 09 09 28 62 65 67 69 dat key)...(begi
79a0: 6e 0a 09 09 20 20 28 73 65 73 73 69 6f 6e 3a 6c n... (session:l
79b0: 6f 67 20 73 65 6c 66 20 22 45 52 52 4f 52 3a 20 og self "ERROR:
79c0: 66 6f 72 6d 64 61 74 3a 20 22 20 66 6f 72 6d 64 formdat: " formd
79d0: 61 74 20 22 20 69 73 20 6e 6f 74 20 6f 66 20 63 at " is not of c
79e0: 6c 61 73 73 20 3c 66 6f 72 6d 64 61 74 3e 22 29 lass <formdat>")
79f0: 0a 09 09 20 20 23 66 29 29 0a 09 20 20 20 20 28 ... #f)).. (
7a00: 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 session:log self
7a10: 20 22 45 52 52 4f 52 3a 20 62 61 64 20 6b 65 79 "ERROR: bad key
7a20: 20 22 20 6b 65 79 29 29 29 29 29 0a 0a 28 64 65 " key)))))..(de
7a30: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 72 75 fine (session:ru
7a40: 6e 2d 61 63 74 69 6f 6e 73 20 73 65 6c 66 29 0a n-actions self).
7a50: 20 20 28 6c 65 74 2a 20 28 28 61 63 74 69 6f 6e (let* ((action
7a60: 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 (session:get
7a70: 2d 70 61 72 61 6d 20 73 65 6c 66 20 27 61 63 74 -param self 'act
7a80: 69 6f 6e 29 29 0a 09 20 28 70 61 67 65 20 20 20 ion)).. (page
7a90: 20 20 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 (sdat-get-pag
7aa0: 65 20 73 65 6c 66 29 29 29 0a 20 20 20 20 3b 3b e self))). ;;
7ab0: 20 28 70 72 69 6e 74 20 22 61 63 74 69 6f 6e 3d (print "action=
7ac0: 22 20 61 63 74 69 6f 6e 20 22 20 70 61 67 65 3d " action " page=
7ad0: 22 20 70 61 67 65 29 0a 20 20 20 20 28 69 66 20 " page). (if
7ae0: 61 63 74 69 6f 6e 0a 09 28 6c 65 74 20 28 28 61 action..(let ((a
7af0: 63 74 69 6f 6e 2d 6c 73 74 20 20 28 73 74 72 69 ction-lst (stri
7b00: 6e 67 2d 73 70 6c 69 74 20 61 63 74 69 6f 6e 20 ng-split action
7b10: 22 2e 22 29 29 29 0a 09 20 20 3b 3b 20 28 70 72 "."))).. ;; (pr
7b20: 69 6e 74 20 22 61 63 74 69 6f 6e 2d 6c 73 74 3d int "action-lst=
7b30: 22 20 61 63 74 69 6f 6e 2d 6c 73 74 29 0a 09 20 " action-lst)..
7b40: 20 28 69 66 20 28 6e 6f 74 20 28 3d 20 28 6c 65 (if (not (= (le
7b50: 6e 67 74 68 20 61 63 74 69 6f 6e 2d 6c 73 74 29 ngth action-lst)
7b60: 20 32 29 29 20 0a 09 20 20 20 20 20 20 28 65 72 2)) .. (er
7b70: 72 3a 6c 6f 67 20 22 41 63 74 69 6f 6e 20 73 68 r:log "Action sh
7b80: 6f 75 6c 64 20 62 65 20 6f 66 20 66 6f 72 6d 3a ould be of form:
7b90: 20 6d 6f 64 75 6c 65 2e 61 63 74 69 6f 6e 22 29 module.action")
7ba0: 0a 09 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 .. (let* ((
7bb0: 74 61 72 67 2d 70 61 67 65 20 20 20 28 63 61 72 targ-page (car
7bc0: 20 61 63 74 69 6f 6e 2d 6c 73 74 29 29 0a 09 09 action-lst))...
7bd0: 20 20 20 20 20 28 70 72 6f 63 2d 6e 61 6d 65 20 (proc-name
7be0: 20 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 (string-append
7bf0: 20 74 61 72 67 2d 70 61 67 65 20 22 2d 61 63 74 targ-page "-act
7c00: 69 6f 6e 22 29 29 0a 09 09 20 20 20 20 20 28 74 ion"))... (t
7c10: 61 72 67 2d 61 63 74 69 6f 6e 20 28 63 61 64 72 arg-action (cadr
7c20: 20 61 63 74 69 6f 6e 2d 6c 73 74 29 29 29 0a 09 action-lst)))..
7c30: 09 3b 3b 20 28 65 72 72 3a 6c 6f 67 20 22 74 61 .;; (err:log "ta
7c40: 72 67 2d 70 61 67 65 3d 22 20 74 61 72 67 2d 70 rg-page=" targ-p
7c50: 61 67 65 20 22 20 70 72 6f 63 2d 6e 61 6d 65 3d age " proc-name=
7c60: 22 20 70 72 6f 63 2d 6e 61 6d 65 20 22 20 74 61 " proc-name " ta
7c70: 72 67 2d 61 63 74 69 6f 6e 3d 22 20 74 61 72 67 rg-action=" targ
7c80: 2d 61 63 74 69 6f 6e 29 0a 0a 09 09 3b 3b 20 63 -action)....;; c
7c90: 61 6c 6c 20 68 65 72 65 20 6f 6e 6c 79 20 69 66 all here only if
7ca0: 20 6e 65 76 65 72 20 63 61 6c 6c 65 64 20 62 65 never called be
7cb0: 66 6f 72 65 0a 09 09 28 69 66 20 28 73 65 73 73 fore...(if (sess
7cc0: 69 6f 6e 3a 6e 65 76 65 72 2d 63 61 6c 6c 65 64 ion:never-called
7cd0: 2d 70 61 67 65 3f 20 73 65 6c 66 20 74 61 72 67 -page? self targ
7ce0: 2d 70 61 67 65 29 0a 09 09 20 20 20 20 28 73 65 -page)... (se
7cf0: 73 73 69 6f 6e 3a 63 61 6c 6c 2d 70 61 72 74 73 ssion:call-parts
7d00: 20 73 65 6c 66 20 74 61 72 67 2d 70 61 67 65 20 self targ-page
7d10: 27 63 6f 6e 74 72 6f 6c 29 29 0a 09 09 3b 3b 20 'control))...;;
7d20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7d30: 20 20 20 70 72 6f 63 20 20 20 20 20 20 20 20 20 proc
7d40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7d50: 61 63 74 69 6f 6e 20 20 20 20 0a 0a 09 09 28 69 action ....(i
7d60: 66 20 23 74 20 3b 3b 20 73 65 74 20 74 6f 20 23 f #t ;; set to #
7d70: 74 20 74 6f 20 73 65 65 20 62 65 74 74 65 72 20 t to see better
7d80: 65 72 72 6f 72 20 6d 65 73 73 61 67 65 73 20 64 error messages d
7d90: 75 72 69 6e 67 20 64 65 62 75 67 67 69 6e 20 3a uring debuggin :
7da0: 2d 29 0a 09 09 20 20 20 20 28 28 65 76 61 6c 20 -)... ((eval
7db0: 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 (string->symbol
7dc0: 70 72 6f 63 2d 6e 61 6d 65 29 29 20 74 61 72 67 proc-name)) targ
7dd0: 2d 61 63 74 69 6f 6e 29 20 3b 3b 20 75 6e 73 61 -action) ;; unsa
7de0: 66 65 20 65 78 65 63 75 74 69 6f 6e 0a 09 09 20 fe execution...
7df0: 20 20 20 28 63 6f 6e 64 69 74 69 6f 6e 2d 63 61 (condition-ca
7e00: 73 65 20 28 28 65 76 61 6c 20 28 73 74 72 69 6e se ((eval (strin
7e10: 67 2d 3e 73 79 6d 62 6f 6c 20 70 72 6f 63 2d 6e g->symbol proc-n
7e20: 61 6d 65 29 29 20 74 61 72 67 2d 61 63 74 69 6f ame)) targ-actio
7e30: 6e 29 0a 09 09 09 09 20 20 20 20 28 28 65 78 6e n)..... ((exn
7e40: 20 66 69 6c 65 29 20 28 73 3a 6c 6f 67 20 22 66 file) (s:log "f
7e50: 69 6c 65 20 65 72 72 6f 72 22 29 29 0a 09 09 09 ile error"))....
7e60: 09 20 20 20 20 28 28 65 78 6e 20 69 2f 6f 29 20 . ((exn i/o)
7e70: 20 28 73 3a 6c 6f 67 20 22 69 2f 6f 20 65 72 72 (s:log "i/o err
7e80: 6f 72 22 29 29 0a 09 09 09 09 20 20 20 20 28 28 or"))..... ((
7e90: 65 78 6e 20 29 20 20 20 20 20 28 73 3a 6c 6f 67 exn ) (s:log
7ea0: 20 22 41 63 74 69 6f 6e 20 6e 6f 74 20 69 6d 70 "Action not imp
7eb0: 6c 65 6d 65 6e 74 65 64 3a 20 22 20 70 72 6f 63 lemented: " proc
7ec0: 2d 6e 61 6d 65 20 22 20 61 63 74 69 6f 6e 3a 20 -name " action:
7ed0: 22 20 74 61 72 67 2d 61 63 74 69 6f 6e 29 29 0a " targ-action)).
7ee0: 09 09 09 09 20 20 20 20 28 76 61 72 20 28 29 20 .... (var ()
7ef0: 20 20 20 20 28 73 3a 6c 6f 67 20 22 55 6e 6b 6e (s:log "Unkn
7f00: 6f 77 6e 20 45 72 72 6f 72 22 29 29 29 29 29 29 own Error"))))))
7f10: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 ))))..(define (s
7f20: 65 73 73 69 6f 6e 3a 6e 65 76 65 72 2d 63 61 6c ession:never-cal
7f30: 6c 65 64 2d 70 61 67 65 3f 20 73 65 6c 66 20 70 led-page? self p
7f40: 61 67 65 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a age). (session:
7f50: 6c 6f 67 20 73 65 6c 66 20 22 43 68 65 63 6b 69 log self "Checki
7f60: 6e 67 20 66 6f 72 20 70 61 67 65 3a 20 22 20 70 ng for page: " p
7f70: 61 67 65 29 0a 20 20 28 6e 6f 74 20 28 6d 65 6d age). (not (mem
7f80: 62 65 72 20 70 61 67 65 20 28 73 64 61 74 2d 67 ber page (sdat-g
7f90: 65 74 2d 73 65 65 6e 2d 70 61 67 65 73 20 73 65 et-seen-pages se
7fa0: 6c 66 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 lf))))..(define
7fb0: 28 73 65 73 73 69 6f 6e 3a 73 65 74 2d 63 61 6c (session:set-cal
7fc0: 6c 65 64 21 20 73 65 6c 66 20 70 61 67 65 29 0a led! self page).
7fd0: 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 65 6e (sdat-set-seen
7fe0: 2d 70 61 67 65 73 21 20 73 65 6c 66 20 28 63 6f -pages! self (co
7ff0: 6e 73 20 70 61 67 65 20 28 73 64 61 74 2d 67 65 ns page (sdat-ge
8000: 74 2d 73 65 65 6e 2d 70 61 67 65 73 20 73 65 6c t-seen-pages sel
8010: 66 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d f))))..;;=======
8020: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8040: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8050: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
8060: 3b 3b 20 41 6c 74 65 72 6e 61 74 69 76 65 20 64 ;; Alternative d
8070: 61 74 61 20 74 79 70 65 20 64 65 6c 69 76 65 72 ata type deliver
8080: 79 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d y.;;============
8090: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
80a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
80b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
80c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 ==========..(def
80d0: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 61 6c 74 ine (session:alt
80e0: 2d 6f 75 74 20 73 65 6c 66 29 0a 20 20 28 6c 65 -out self). (le
80f0: 74 20 28 28 64 61 74 20 28 73 64 61 74 2d 67 65 t ((dat (sdat-ge
8100: 74 2d 61 6c 74 2d 70 61 67 65 2d 64 61 74 20 73 t-alt-page-dat s
8110: 65 6c 66 29 29 29 0a 20 20 20 20 3b 3b 20 28 73 elf))). ;; (s
8120: 3a 6c 6f 67 20 22 64 61 74 20 69 73 3a 20 22 20 :log "dat is: "
8130: 64 61 74 29 0a 20 20 20 20 3b 3b 20 28 70 72 69 dat). ;; (pri
8140: 6e 74 20 22 48 54 54 50 2f 31 2e 31 20 32 30 30 nt "HTTP/1.1 200
8150: 20 4f 4b 22 29 0a 20 20 20 20 28 70 72 69 6e 74 OK"). (print
8160: 20 22 44 61 74 65 3a 20 22 20 28 74 69 6d 65 2d "Date: " (time-
8170: 3e 73 74 72 69 6e 67 20 28 73 65 63 6f 6e 64 73 >string (seconds
8180: 2d 3e 75 74 63 2d 74 69 6d 65 20 28 63 75 72 72 ->utc-time (curr
8190: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 29 0a ent-seconds)))).
81a0: 20 20 20 20 28 70 72 69 6e 74 20 22 43 6f 6e 74 (print "Cont
81b0: 65 6e 74 2d 54 79 70 65 3a 20 22 20 28 73 64 61 ent-Type: " (sda
81c0: 74 2d 67 65 74 2d 63 6f 6e 74 65 6e 74 2d 74 79 t-get-content-ty
81d0: 70 65 20 73 65 6c 66 29 29 0a 20 20 20 20 28 70 pe self)). (p
81e0: 72 69 6e 74 20 22 41 63 63 65 70 74 2d 52 61 6e rint "Accept-Ran
81f0: 67 65 73 3a 20 62 79 74 65 73 22 29 0a 20 20 20 ges: bytes").
8200: 20 28 70 72 69 6e 74 20 22 43 6f 6e 74 65 6e 74 (print "Content
8210: 2d 4c 65 6e 67 74 68 3a 20 22 20 28 69 66 20 28 -Length: " (if (
8220: 62 6c 6f 62 3f 20 64 61 74 29 0a 09 09 09 09 20 blob? dat).....
8230: 20 28 62 6c 6f 62 2d 73 69 7a 65 20 64 61 74 29 (blob-size dat)
8240: 0a 09 09 09 09 20 20 30 29 29 0a 20 20 20 20 28 ..... 0)). (
8250: 70 72 69 6e 74 20 22 4b 65 65 70 2d 41 6c 69 76 print "Keep-Aliv
8260: 65 3a 20 74 69 6d 65 6f 75 74 3d 31 35 2c 20 6d e: timeout=15, m
8270: 61 78 3d 31 30 30 22 29 0a 20 20 20 20 28 70 72 ax=100"). (pr
8280: 69 6e 74 20 22 43 6f 6e 6e 65 63 74 69 6f 6e 3a int "Connection:
8290: 20 4b 65 65 70 2d 41 6c 69 76 65 22 29 0a 20 20 Keep-Alive").
82a0: 20 20 28 70 72 69 6e 74 20 22 22 29 0a 20 20 20 (print "").
82b0: 20 28 77 72 69 74 65 2d 73 74 72 69 6e 67 20 28 (write-string (
82c0: 62 6c 6f 62 2d 3e 73 74 72 69 6e 67 20 64 61 74 blob->string dat
82d0: 29 20 23 66 20 28 63 75 72 72 65 6e 74 2d 6f 75 ) #f (current-ou
82e0: 74 70 75 74 2d 70 6f 72 74 29 29 29 29 0a tput-port)))).