Artifact
f4104e444e5a1b8ee26f035cb67bd30b69871c29:
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 34 29 29 0a 28 64 65 66 69 6e 65 tor 34)).(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 67 65 74 2d 73 68 61 72 65 64 2d 68 dat-get-shared-h
0e30: 61 73 68 20 20 20 20 20 20 20 20 20 20 76 65 63 ash vec
0e40: 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 ) (vector-ref
0e50: 20 20 76 65 63 20 33 33 29 29 0a 0a 28 64 65 66 vec 33))..(def
0e60: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 ine (session:get
0e70: 2d 73 68 61 72 65 64 20 76 65 63 20 76 61 72 6e -shared vec varn
0e80: 61 6d 65 29 0a 20 20 28 68 61 73 68 2d 74 61 62 ame). (hash-tab
0e90: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 28 le-ref/default (
0ea0: 76 65 63 74 6f 72 2d 72 65 66 20 76 65 63 20 33 vector-ref vec 3
0eb0: 33 29 20 76 61 72 6e 61 6d 65 20 23 66 29 29 0a 3) varname #f)).
0ec0: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 .(define (sdat-s
0ed0: 65 74 2d 64 62 74 79 70 65 21 20 20 20 20 20 20 et-dbtype!
0ee0: 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 vec val)
0ef0: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 (vector-set! vec
0f00: 20 30 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 0 val)).(define
0f10: 20 28 73 64 61 74 2d 73 65 74 2d 64 62 69 6e 69 (sdat-set-dbini
0f20: 74 21 20 20 20 20 20 20 20 20 20 20 20 20 20 20 t!
0f30: 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d vec val)(vector-
0f40: 73 65 74 21 20 76 65 63 20 31 20 76 61 6c 29 29 set! vec 1 val))
0f50: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 .(define (sdat-s
0f60: 65 74 2d 63 6f 6e 6e 21 20 20 20 20 20 20 20 20 et-conn!
0f70: 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 vec val)
0f80: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 (vector-set! vec
0f90: 20 32 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 2 val)).(define
0fa0: 20 28 73 64 61 74 2d 73 65 74 2d 70 61 72 61 6d (sdat-set-param
0fb0: 73 21 20 20 20 20 20 20 20 20 20 20 20 20 20 20 s!
0fc0: 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d vec val)(vector-
0fd0: 73 65 74 21 20 76 65 63 20 33 20 76 61 6c 29 29 set! vec 3 val))
0fe0: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 .(define (sdat-s
0ff0: 65 74 2d 70 61 74 68 2d 70 61 72 61 6d 73 21 20 et-path-params!
1000: 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 vec val)
1010: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 (vector-set! vec
1020: 20 34 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 4 val)).(define
1030: 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 (sdat-set-sessi
1040: 6f 6e 2d 6b 65 79 21 20 20 20 20 20 20 20 20 20 on-key!
1050: 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d vec val)(vector-
1060: 73 65 74 21 20 76 65 63 20 35 20 76 61 6c 29 29 set! vec 5 val))
1070: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 .(define (sdat-s
1080: 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 21 20 20 et-session-id!
1090: 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 vec val)
10a0: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 (vector-set! vec
10b0: 20 36 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 6 val)).(define
10c0: 20 28 73 64 61 74 2d 73 65 74 2d 64 6f 6d 61 69 (sdat-set-domai
10d0: 6e 21 20 20 20 20 20 20 20 20 20 20 20 20 20 20 n!
10e0: 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d vec val)(vector-
10f0: 73 65 74 21 20 76 65 63 20 37 20 76 61 6c 29 29 set! vec 7 val))
1100: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 .(define (sdat-s
1110: 65 74 2d 74 6f 70 70 61 67 65 21 20 20 20 20 20 et-toppage!
1120: 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 vec val)
1130: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 (vector-set! vec
1140: 20 38 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 8 val)).(define
1150: 20 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 21 (sdat-set-page!
1160: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1170: 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d vec val)(vector-
1180: 73 65 74 21 20 76 65 63 20 39 20 76 61 6c 29 29 set! vec 9 val))
1190: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 .(define (sdat-s
11a0: 65 74 2d 63 75 72 72 2d 70 61 67 65 21 20 20 20 et-curr-page!
11b0: 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 vec val)
11c0: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 (vector-set! vec
11d0: 20 31 30 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 10 val)).(defin
11e0: 65 20 28 73 64 61 74 2d 73 65 74 2d 63 6f 6e 74 e (sdat-set-cont
11f0: 65 6e 74 2d 74 79 70 65 21 20 20 20 20 20 20 20 ent-type!
1200: 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 vec val)(vector
1210: 2d 73 65 74 21 20 76 65 63 20 31 31 20 76 61 6c -set! vec 11 val
1220: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
1230: 2d 73 65 74 2d 70 61 67 65 2d 74 79 70 65 21 20 -set-page-type!
1240: 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 61 vec va
1250: 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 l)(vector-set! v
1260: 65 63 20 31 32 20 76 61 6c 29 29 0a 28 64 65 66 ec 12 val)).(def
1270: 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 73 72 ine (sdat-set-sr
1280: 6f 6f 74 21 20 20 20 20 20 20 20 20 20 20 20 20 oot!
1290: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
12a0: 6f 72 2d 73 65 74 21 20 76 65 63 20 31 33 20 76 or-set! vec 13 v
12b0: 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 al)).(define (sd
12c0: 61 74 2d 73 65 74 2d 74 77 69 6b 69 64 69 72 21 at-set-twikidir!
12d0: 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 20 vec
12e0: 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 val)(vector-set!
12f0: 20 76 65 63 20 31 34 20 76 61 6c 29 29 0a 28 64 vec 14 val)).(d
1300: 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d efine (sdat-set-
1310: 70 61 67 65 64 61 74 21 20 20 20 20 20 20 20 20 pagedat!
1320: 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 vec val)(ve
1330: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 31 35 ctor-set! vec 15
1340: 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 val)).(define (
1350: 73 64 61 74 2d 73 65 74 2d 61 6c 74 2d 70 61 67 sdat-set-alt-pag
1360: 65 2d 64 61 74 21 20 20 20 20 20 20 20 20 76 65 e-dat! ve
1370: 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 c val)(vector-se
1380: 74 21 20 76 65 63 20 31 36 20 76 61 6c 29 29 0a t! vec 16 val)).
1390: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 (define (sdat-se
13a0: 74 2d 70 61 67 65 76 61 72 73 21 20 20 20 20 20 t-pagevars!
13b0: 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 vec val)(
13c0: 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 vector-set! vec
13d0: 31 37 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 17 val)).(define
13e0: 20 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 76 (sdat-set-pagev
13f0: 61 72 73 2d 62 65 66 6f 72 65 21 20 20 20 20 20 ars-before!
1400: 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d vec val)(vector-
1410: 73 65 74 21 20 76 65 63 20 31 38 20 76 61 6c 29 set! vec 18 val)
1420: 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d ).(define (sdat-
1430: 73 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 21 set-sessionvars!
1440: 20 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c vec val
1450: 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 )(vector-set! ve
1460: 63 20 31 39 20 76 61 6c 29 29 0a 28 64 65 66 69 c 19 val)).(defi
1470: 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 ne (sdat-set-ses
1480: 73 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 21 sionvars-before!
1490: 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f vec val)(vecto
14a0: 72 2d 73 65 74 21 20 76 65 63 20 32 30 20 76 61 r-set! vec 20 va
14b0: 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 l)).(define (sda
14c0: 74 2d 73 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 t-set-globalvars
14d0: 21 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 ! vec v
14e0: 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 al)(vector-set!
14f0: 76 65 63 20 32 31 20 76 61 6c 29 29 0a 28 64 65 vec 21 val)).(de
1500: 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 67 fine (sdat-set-g
1510: 6c 6f 62 61 6c 76 61 72 73 2d 62 65 66 6f 72 65 lobalvars-before
1520: 21 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 ! vec val)(vec
1530: 74 6f 72 2d 73 65 74 21 20 76 65 63 20 32 32 20 tor-set! vec 22
1540: 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 val)).(define (s
1550: 64 61 74 2d 73 65 74 2d 6c 6f 67 70 74 21 20 20 dat-set-logpt!
1560: 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 vec
1570: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
1580: 21 20 76 65 63 20 32 33 20 76 61 6c 29 29 0a 28 ! vec 23 val)).(
1590: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 define (sdat-set
15a0: 2d 66 6f 72 6d 64 61 74 21 20 20 20 20 20 20 20 -formdat!
15b0: 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 vec val)(v
15c0: 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 32 ector-set! vec 2
15d0: 34 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 4 val)).(define
15e0: 28 73 64 61 74 2d 73 65 74 2d 72 65 71 75 65 73 (sdat-set-reques
15f0: 74 2d 6d 65 74 68 6f 64 21 20 20 20 20 20 20 76 t-method! v
1600: 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 ec val)(vector-s
1610: 65 74 21 20 76 65 63 20 32 35 20 76 61 6c 29 29 et! vec 25 val))
1620: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 .(define (sdat-s
1630: 65 74 2d 73 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 et-session-cooki
1640: 65 21 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 e! vec val)
1650: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 (vector-set! vec
1660: 20 32 36 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 26 val)).(defin
1670: 65 20 28 73 64 61 74 2d 73 65 74 2d 63 75 72 72 e (sdat-set-curr
1680: 2d 65 72 72 21 20 20 20 20 20 20 20 20 20 20 20 -err!
1690: 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 vec val)(vector
16a0: 2d 73 65 74 21 20 76 65 63 20 32 37 20 76 61 6c -set! vec 27 val
16b0: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
16c0: 2d 73 65 74 2d 6c 6f 67 2d 70 6f 72 74 21 20 20 -set-log-port!
16d0: 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 61 vec va
16e0: 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 l)(vector-set! v
16f0: 65 63 20 32 38 20 76 61 6c 29 29 0a 28 64 65 66 ec 28 val)).(def
1700: 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 6c 6f ine (sdat-set-lo
1710: 67 66 69 6c 65 21 20 20 20 20 20 20 20 20 20 20 gfile!
1720: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
1730: 6f 72 2d 73 65 74 21 20 76 65 63 20 32 39 20 76 or-set! vec 29 v
1740: 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 al)).(define (sd
1750: 61 74 2d 73 65 74 2d 73 65 65 6e 2d 70 61 67 65 at-set-seen-page
1760: 73 21 20 20 20 20 20 20 20 20 20 20 76 65 63 20 s! vec
1770: 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 val)(vector-set!
1780: 20 76 65 63 20 33 30 20 76 61 6c 29 29 0a 28 64 vec 30 val)).(d
1790: 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d efine (sdat-set-
17a0: 70 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 21 20 page-dir-style!
17b0: 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 vec val)(ve
17c0: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 33 31 ctor-set! vec 31
17d0: 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 val)).(define (
17e0: 73 64 61 74 2d 73 65 74 2d 64 65 62 75 67 6d 6f sdat-set-debugmo
17f0: 64 65 21 20 20 20 20 20 20 20 20 20 20 20 76 65 de! ve
1800: 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 c val)(vector-se
1810: 74 21 20 76 65 63 20 33 32 20 76 61 6c 29 29 0a t! vec 32 val)).
1820: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 (define (sdat-se
1830: 74 2d 73 68 61 72 65 64 2d 68 61 73 68 21 20 20 t-shared-hash!
1840: 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 vec val)(
1850: 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 vector-set! vec
1860: 33 33 20 76 61 6c 29 29 0a 0a 28 64 65 66 69 6e 33 val))..(defin
1870: 65 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 2d 73 e (session:set-s
1880: 68 61 72 65 64 21 20 76 65 63 20 76 61 72 6e 61 hared! vec varna
1890: 6d 65 20 76 61 6c 29 0a 20 20 28 68 61 73 68 2d me val). (hash-
18a0: 74 61 62 6c 65 2d 73 65 74 21 20 28 76 65 63 74 table-set! (vect
18b0: 6f 72 2d 72 65 66 20 76 65 63 20 33 33 29 20 76 or-ref vec 33) v
18c0: 61 72 6e 61 6d 65 20 76 61 6c 29 29 0a 0a 3b 3b arname val))..;;
18d0: 20 54 68 65 20 67 6c 6f 62 61 6c 20 73 65 73 73 The global sess
18e0: 69 6f 6e 0a 28 64 65 66 69 6e 65 20 73 3a 73 65 ion.(define s:se
18f0: 73 73 69 6f 6e 20 28 6d 61 6b 65 2d 73 64 61 74 ssion (make-sdat
1900: 29 29 0a 0a 3b 3b 20 53 50 4c 49 54 20 49 4e 54 ))..;; SPLIT INT
1910: 4f 20 53 54 52 41 49 47 48 54 20 46 4f 52 57 41 O STRAIGHT FORWA
1920: 52 44 20 49 4e 49 54 20 41 4e 44 20 43 4f 4d 50 RD INIT AND COMP
1930: 4c 45 58 20 49 4e 49 54 0a 28 64 65 66 69 6e 65 LEX INIT.(define
1940: 20 28 73 65 73 73 69 6f 6e 3a 69 6e 69 74 69 61 (session:initia
1950: 6c 69 7a 65 20 73 65 6c 66 29 0a 20 20 28 73 64 lize self). (sd
1960: 61 74 2d 73 65 74 2d 64 62 74 79 70 65 21 20 73 at-set-dbtype! s
1970: 65 6c 66 20 20 20 20 20 20 27 70 67 29 0a 20 20 elf 'pg).
1980: 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 21 20 (sdat-set-page!
1990: 73 65 6c 66 20 20 20 20 20 20 20 20 22 68 6f 6d self "hom
19a0: 65 22 29 20 20 20 20 20 20 20 20 3b 3b 20 74 68 e") ;; th
19b0: 65 73 65 20 61 72 65 20 64 65 66 61 75 6c 74 73 ese are defaults
19c0: 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 63 75 72 . (sdat-set-cur
19d0: 72 2d 70 61 67 65 21 20 73 65 6c 66 20 20 20 22 r-page! self "
19e0: 68 6f 6d 65 22 29 0a 20 20 28 73 64 61 74 2d 73 home"). (sdat-s
19f0: 65 74 2d 63 6f 6e 74 65 6e 74 2d 74 79 70 65 21 et-content-type!
1a00: 20 73 65 6c 66 20 22 43 6f 6e 74 65 6e 74 2d 74 self "Content-t
1a10: 79 70 65 3a 20 74 65 78 74 2f 68 74 6d 6c 3b 20 ype: text/html;
1a20: 63 68 61 72 73 65 74 3d 69 73 6f 2d 38 38 35 39 charset=iso-8859
1a30: 2d 31 5c 6e 5c 6e 22 29 0a 20 20 28 73 64 61 74 -1\n\n"). (sdat
1a40: 2d 73 65 74 2d 70 61 67 65 2d 74 79 70 65 21 20 -set-page-type!
1a50: 73 65 6c 66 20 20 20 27 68 74 6d 6c 29 0a 20 20 self 'html).
1a60: 28 73 64 61 74 2d 73 65 74 2d 74 6f 70 70 61 67 (sdat-set-toppag
1a70: 65 21 20 73 65 6c 66 20 20 20 20 20 22 69 6e 64 e! self "ind
1a80: 65 78 22 29 0a 20 20 28 73 64 61 74 2d 73 65 74 ex"). (sdat-set
1a90: 2d 70 61 72 61 6d 73 21 20 73 65 6c 66 20 20 20 -params! self
1aa0: 20 20 20 27 28 29 29 20 20 20 20 20 20 20 20 20 '())
1ab0: 20 20 3b 3b 0a 20 20 28 73 64 61 74 2d 73 65 74 ;;. (sdat-set
1ac0: 2d 70 61 74 68 2d 70 61 72 61 6d 73 21 20 73 65 -path-params! se
1ad0: 6c 66 20 27 28 29 29 0a 20 20 28 73 64 61 74 2d lf '()). (sdat-
1ae0: 73 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 21 set-session-key!
1af0: 20 73 65 6c 66 20 23 66 29 0a 20 20 28 73 64 61 self #f). (sda
1b00: 74 2d 73 65 74 2d 70 61 67 65 64 61 74 21 20 73 t-set-pagedat! s
1b10: 65 6c 66 20 20 20 20 20 27 28 29 29 0a 20 20 28 elf '()). (
1b20: 73 64 61 74 2d 73 65 74 2d 61 6c 74 2d 70 61 67 sdat-set-alt-pag
1b30: 65 2d 64 61 74 21 20 73 65 6c 66 20 23 66 29 0a e-dat! self #f).
1b40: 20 20 28 73 64 61 74 2d 73 65 74 2d 73 72 6f 6f (sdat-set-sroo
1b50: 74 21 20 73 65 6c 66 20 20 20 20 20 20 20 22 2e t! self ".
1b60: 2f 22 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d /"). (sdat-set-
1b70: 73 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 21 20 session-cookie!
1b80: 73 65 6c 66 20 23 66 29 0a 20 20 28 73 64 61 74 self #f). (sdat
1b90: 2d 73 65 74 2d 63 75 72 72 2d 65 72 72 21 20 73 -set-curr-err! s
1ba0: 65 6c 66 20 23 66 29 0a 20 20 28 73 64 61 74 2d elf #f). (sdat-
1bb0: 73 65 74 2d 6c 6f 67 2d 70 6f 72 74 21 20 73 65 set-log-port! se
1bc0: 6c 66 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f lf (current-erro
1bd0: 72 2d 70 6f 72 74 29 29 0a 20 20 28 73 64 61 74 r-port)). (sdat
1be0: 2d 73 65 74 2d 73 65 65 6e 2d 70 61 67 65 73 21 -set-seen-pages!
1bf0: 20 73 65 6c 66 20 27 28 29 29 0a 20 20 28 73 64 self '()). (sd
1c00: 61 74 2d 73 65 74 2d 70 61 67 65 2d 64 69 72 2d at-set-page-dir-
1c10: 73 74 79 6c 65 21 20 73 65 6c 66 20 23 74 29 20 style! self #t)
1c20: 3b 3b 20 23 74 20 3a 20 70 61 67 65 73 2f 3c 70 ;; #t : pages/<p
1c30: 61 67 65 6e 61 6d 65 3e 5f 28 76 69 65 77 7c 63 agename>_(view|c
1c40: 6e 74 6c 29 2e 73 63 6d 0a 20 20 20 20 20 20 20 ntl).scm.
1c50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1c60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
1c70: 3b 20 23 66 20 3a 20 70 61 67 65 73 2f 3c 70 61 ; #f : pages/<pa
1c80: 67 65 6e 61 6d 65 3e 2f 28 76 69 65 77 7c 63 6f gename>/(view|co
1c90: 6e 74 72 6f 6c 29 2e 73 63 6d 20 0a 20 20 28 73 ntrol).scm . (s
1ca0: 64 61 74 2d 73 65 74 2d 64 65 62 75 67 6d 6f 64 dat-set-debugmod
1cb0: 65 21 20 20 20 20 20 20 20 20 20 20 73 65 6c 66 e! self
1cc0: 20 23 66 29 0a 20 20 09 09 09 20 20 20 20 20 0a #f). ... .
1cd0: 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 (sdat-set-page
1ce0: 76 61 72 73 21 20 20 20 20 20 20 20 20 20 20 20 vars!
1cf0: 73 65 6c 66 20 28 6d 61 6b 65 2d 68 61 73 68 2d self (make-hash-
1d00: 74 61 62 6c 65 29 29 0a 20 20 28 73 64 61 74 2d table)). (sdat-
1d10: 73 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 21 set-sessionvars!
1d20: 20 20 20 20 20 20 20 20 73 65 6c 66 20 28 6d 61 self (ma
1d30: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
1d40: 20 20 28 73 64 61 74 2d 73 65 74 2d 67 6c 6f 62 (sdat-set-glob
1d50: 61 6c 76 61 72 73 21 20 20 20 20 20 20 20 20 20 alvars!
1d60: 73 65 6c 66 20 28 6d 61 6b 65 2d 68 61 73 68 2d self (make-hash-
1d70: 74 61 62 6c 65 29 29 0a 20 20 28 73 64 61 74 2d table)). (sdat-
1d80: 73 65 74 2d 70 61 67 65 76 61 72 73 2d 62 65 66 set-pagevars-bef
1d90: 6f 72 65 21 20 20 20 20 73 65 6c 66 20 28 6d 61 ore! self (ma
1da0: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
1db0: 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 (sdat-set-sess
1dc0: 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 21 20 ionvars-before!
1dd0: 73 65 6c 66 20 28 6d 61 6b 65 2d 68 61 73 68 2d self (make-hash-
1de0: 74 61 62 6c 65 29 29 0a 20 20 28 73 64 61 74 2d table)). (sdat-
1df0: 73 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 2d 62 set-globalvars-b
1e00: 65 66 6f 72 65 21 20 20 73 65 6c 66 20 28 6d 61 efore! self (ma
1e10: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
1e20: 20 20 28 73 64 61 74 2d 73 65 74 2d 64 6f 6d 61 (sdat-set-doma
1e30: 69 6e 21 20 20 20 20 20 20 20 20 20 20 20 20 20 in!
1e40: 73 65 6c 66 20 22 6c 6f 63 61 68 6f 73 74 22 29 self "locahost")
1e50: 20 20 20 3b 3b 20 65 6e 64 20 6f 66 20 64 65 66 ;; end of def
1e60: 61 75 6c 74 73 0a 20 20 28 6c 65 74 2a 20 28 28 aults. (let* ((
1e70: 72 61 77 63 6f 6e 66 69 67 64 61 74 20 28 73 65 rawconfigdat (se
1e80: 73 73 69 6f 6e 3a 72 65 61 64 2d 63 6f 6e 66 69 ssion:read-confi
1e90: 67 20 73 65 6c 66 29 29 0a 09 20 28 63 6f 6e 66 g self)).. (conf
1ea0: 69 67 64 61 74 20 28 69 66 20 72 61 77 63 6f 6e igdat (if rawcon
1eb0: 66 69 67 64 61 74 20 28 65 76 61 6c 20 72 61 77 figdat (eval raw
1ec0: 63 6f 6e 66 69 67 64 61 74 29 20 27 28 29 29 29 configdat) '()))
1ed0: 0a 09 20 28 73 72 6f 6f 74 20 20 20 20 20 28 73 .. (sroot (s
1ee0: 3a 66 69 6e 64 2d 70 61 72 61 6d 20 27 73 72 6f :find-param 'sro
1ef0: 6f 74 20 20 20 20 63 6f 6e 66 69 67 64 61 74 29 ot configdat)
1f00: 29 0a 09 20 28 6c 6f 67 66 69 6c 65 20 20 20 28 ).. (logfile (
1f10: 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 27 6c 6f s:find-param 'lo
1f20: 67 66 69 6c 65 20 20 63 6f 6e 66 69 67 64 61 74 gfile configdat
1f30: 29 29 0a 09 20 28 64 62 74 79 70 65 20 20 20 20 )).. (dbtype
1f40: 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 27 64 (s:find-param 'd
1f50: 62 74 79 70 65 20 20 20 63 6f 6e 66 69 67 64 61 btype configda
1f60: 74 29 29 0a 09 20 28 64 62 69 6e 69 74 20 20 20 t)).. (dbinit
1f70: 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 27 (s:find-param '
1f80: 64 62 69 6e 69 74 20 20 20 63 6f 6e 66 69 67 64 dbinit configd
1f90: 61 74 29 29 0a 09 20 28 64 6f 6d 61 69 6e 20 20 at)).. (domain
1fa0: 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 (s:find-param
1fb0: 27 64 6f 6d 61 69 6e 20 20 20 63 6f 6e 66 69 67 'domain config
1fc0: 64 61 74 29 29 0a 09 20 28 74 77 69 6b 69 64 69 dat)).. (twikidi
1fd0: 72 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d r (s:find-param
1fe0: 20 27 74 77 69 6b 69 64 69 72 20 63 6f 6e 66 69 'twikidir confi
1ff0: 67 64 61 74 29 29 0a 09 20 28 70 61 67 65 2d 64 gdat)).. (page-d
2000: 69 72 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 ir (s:find-para
2010: 6d 20 27 70 61 67 65 2d 64 69 72 2d 73 74 79 6c m 'page-dir-styl
2020: 65 20 63 6f 6e 66 69 67 64 61 74 29 29 0a 09 20 e configdat))..
2030: 28 64 65 62 75 67 6d 6f 64 65 20 28 73 3a 66 69 (debugmode (s:fi
2040: 6e 64 2d 70 61 72 61 6d 20 27 64 65 62 75 67 6d nd-param 'debugm
2050: 6f 64 65 20 63 6f 6e 66 69 67 64 61 74 29 29 29 ode configdat)))
2060: 0a 20 20 20 20 28 69 66 20 73 72 6f 6f 74 20 20 . (if sroot
2070: 20 20 28 73 64 61 74 2d 73 65 74 2d 73 72 6f 6f (sdat-set-sroo
2080: 74 21 20 20 20 20 73 65 6c 66 20 73 72 6f 6f 74 t! self sroot
2090: 29 29 0a 20 20 20 20 28 69 66 20 6c 6f 67 66 69 )). (if logfi
20a0: 6c 65 20 20 28 73 64 61 74 2d 73 65 74 2d 6c 6f le (sdat-set-lo
20b0: 67 66 69 6c 65 21 20 20 73 65 6c 66 20 6c 6f 67 gfile! self log
20c0: 66 69 6c 65 29 29 0a 20 20 20 20 28 69 66 20 64 file)). (if d
20d0: 62 74 79 70 65 20 20 20 28 73 64 61 74 2d 73 65 btype (sdat-se
20e0: 74 2d 64 62 74 79 70 65 21 20 20 20 73 65 6c 66 t-dbtype! self
20f0: 20 64 62 74 79 70 65 29 29 0a 20 20 20 20 28 69 dbtype)). (i
2100: 66 20 64 62 69 6e 69 74 20 20 20 28 73 64 61 74 f dbinit (sdat
2110: 2d 73 65 74 2d 64 62 69 6e 69 74 21 20 20 20 73 -set-dbinit! s
2120: 65 6c 66 20 64 62 69 6e 69 74 29 29 0a 20 20 20 elf dbinit)).
2130: 20 28 69 66 20 64 6f 6d 61 69 6e 20 20 20 28 73 (if domain (s
2140: 64 61 74 2d 73 65 74 2d 64 6f 6d 61 69 6e 21 20 dat-set-domain!
2150: 20 20 73 65 6c 66 20 64 6f 6d 61 69 6e 29 29 0a self domain)).
2160: 20 20 20 20 28 69 66 20 74 77 69 6b 69 64 69 72 (if twikidir
2170: 20 28 73 64 61 74 2d 73 65 74 2d 74 77 69 6b 69 (sdat-set-twiki
2180: 64 69 72 21 20 73 65 6c 66 20 74 77 69 6b 69 64 dir! self twikid
2190: 69 72 29 29 0a 20 20 20 20 28 69 66 20 64 65 62 ir)). (if deb
21a0: 75 67 6d 6f 64 65 20 28 73 64 61 74 2d 73 65 74 ugmode (sdat-set
21b0: 2d 64 65 62 75 67 6d 6f 64 65 21 20 73 65 6c 66 -debugmode! self
21c0: 20 64 65 62 75 67 6d 6f 64 65 29 29 0a 20 20 20 debugmode)).
21d0: 20 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 2d (sdat-set-page-
21e0: 64 69 72 2d 73 74 79 6c 65 21 20 73 65 6c 66 20 dir-style! self
21f0: 70 61 67 65 2d 64 69 72 29 0a 20 20 20 20 3b 3b page-dir). ;;
2200: 20 28 70 72 69 6e 74 20 22 63 6f 6e 66 69 67 64 (print "configd
2210: 61 74 3a 20 22 29 28 70 70 20 63 6f 6e 66 69 67 at: ")(pp config
2220: 64 61 74 29 0a 20 20 20 20 28 69 66 20 64 65 62 dat). (if deb
2230: 75 67 6d 6f 64 65 0a 09 28 73 65 73 73 69 6f 6e ugmode..(session
2240: 3a 6c 6f 67 20 73 65 6c 66 20 22 73 72 6f 6f 74 :log self "sroot
2250: 3a 20 22 20 73 72 6f 6f 74 20 22 20 6c 6f 67 66 : " sroot " logf
2260: 69 6c 65 3a 20 22 20 6c 6f 67 66 69 6c 65 20 22 ile: " logfile "
2270: 20 64 62 74 79 70 65 3a 20 22 20 64 62 74 79 70 dbtype: " dbtyp
2280: 65 20 0a 09 09 20 20 20 20 20 22 20 64 62 69 6e e ... " dbin
2290: 69 74 3a 20 22 20 64 62 69 6e 69 74 20 22 20 64 it: " dbinit " d
22a0: 6f 6d 61 69 6e 3a 20 22 20 64 6f 6d 61 69 6e 20 omain: " domain
22b0: 22 20 70 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 " page-dir-style
22c0: 3a 20 22 20 70 61 67 65 2d 64 69 72 29 29 0a 20 : " page-dir)).
22d0: 20 20 20 29 0a 20 20 28 73 64 61 74 2d 73 65 74 ). (sdat-set
22e0: 2d 73 68 61 72 65 64 2d 68 61 73 68 21 20 73 65 -shared-hash! se
22f0: 6c 66 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 lf (make-hash-ta
2300: 62 6c 65 29 29 0a 20 20 29 0a 0a 3b 3b 20 55 73 ble)). )..;; Us
2310: 65 64 20 66 6f 72 20 74 68 65 20 73 74 72 61 6e ed for the stran
2320: 67 65 6c 79 20 69 6e 63 6f 6e 73 69 73 74 65 6e gely inconsisten
2330: 74 20 68 61 6e 64 6c 69 6e 67 20 6f 66 20 74 68 t handling of th
2340: 65 20 63 6f 6e 66 69 67 20 66 69 6c 65 2e 20 41 e config file. A
2350: 20 62 65 74 74 65 72 20 77 61 79 20 69 73 20 6e better way is n
2360: 65 65 64 65 64 2e 0a 3b 3b 0a 3b 3b 20 20 20 28 eeded..;;.;; (
2370: 6c 65 74 20 28 28 64 62 74 79 70 65 20 28 73 64 let ((dbtype (sd
2380: 61 74 2d 67 65 74 2d 64 62 74 79 70 65 20 73 65 at-get-dbtype se
2390: 6c 66 29 29 29 0a 3b 3b 20 20 20 20 20 28 70 72 lf))).;; (pr
23a0: 69 6e 74 20 22 64 62 74 79 70 65 3a 20 22 20 64 int "dbtype: " d
23b0: 62 74 79 70 65 29 0a 3b 3b 20 20 20 20 20 28 73 btype).;; (s
23c0: 64 61 74 2d 73 65 74 2d 64 62 74 79 70 65 21 20 dat-set-dbtype!
23d0: 73 65 6c 66 20 28 65 76 61 6c 20 64 62 74 79 70 self (eval dbtyp
23e0: 65 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 e))))..(define (
23f0: 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 20 73 65 session:setup se
2400: 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 64 62 74 lf). (let ((dbt
2410: 79 70 65 20 20 20 20 28 73 64 61 74 2d 67 65 74 ype (sdat-get
2420: 2d 64 62 74 79 70 65 20 73 65 6c 66 29 29 0a 09 -dbtype self))..
2430: 28 64 65 62 75 67 6d 6f 64 65 20 28 73 64 61 74 (debugmode (sdat
2440: 2d 67 65 74 2d 64 65 62 75 67 6d 6f 64 65 20 73 -get-debugmode s
2450: 65 6c 66 29 29 0a 09 28 64 62 69 6e 69 74 20 20 elf))..(dbinit
2460: 20 20 28 65 76 61 6c 20 28 73 64 61 74 2d 67 65 (eval (sdat-ge
2470: 74 2d 64 62 69 6e 69 74 20 73 65 6c 66 29 29 29 t-dbinit self)))
2480: 0a 09 28 64 62 65 78 69 73 74 73 20 20 23 66 29 ..(dbexists #f)
2490: 29 0a 20 20 20 20 28 6c 65 74 20 28 28 64 62 66 ). (let ((dbf
24a0: 6e 61 6d 65 20 28 61 6c 69 73 74 2d 72 65 66 20 name (alist-ref
24b0: 27 64 62 6e 61 6d 65 20 64 62 69 6e 69 74 29 29 'dbname dbinit))
24c0: 29 0a 20 20 20 20 20 20 28 69 66 20 64 65 62 75 ). (if debu
24d0: 67 6d 6f 64 65 20 28 73 65 73 73 69 6f 6e 3a 6c gmode (session:l
24e0: 6f 67 20 73 65 6c 66 20 22 73 65 73 73 69 6f 6e og self "session
24f0: 3a 73 65 74 75 70 20 64 62 66 6e 61 6d 65 3d 22 :setup dbfname="
2500: 20 64 62 66 6e 61 6d 65 20 22 2c 20 64 62 74 79 dbfname ", dbty
2510: 70 65 3d 22 20 64 62 74 79 70 65 20 22 2c 20 64 pe=" dbtype ", d
2520: 62 69 6e 69 74 3d 22 20 64 62 69 6e 69 74 29 29 binit=" dbinit))
2530: 0a 20 20 20 20 20 20 28 69 66 20 28 65 71 3f 20 . (if (eq?
2540: 64 62 74 79 70 65 20 27 73 71 6c 69 74 65 33 29 dbtype 'sqlite3)
2550: 0a 09 20 20 28 6c 65 74 20 28 28 64 62 70 61 74 .. (let ((dbpat
2560: 68 20 28 70 61 74 68 6e 61 6d 65 2d 64 69 72 65 h (pathname-dire
2570: 63 74 6f 72 79 20 64 62 66 6e 61 6d 65 29 29 29 ctory dbfname)))
2580: 20 20 3b 3b 20 64 6f 20 61 20 63 6f 75 70 6c 65 ;; do a couple
2590: 20 73 61 6e 69 74 79 20 63 68 65 63 6b 73 20 68 sanity checks h
25a0: 65 72 65 20 74 6f 20 6d 61 6b 65 20 73 65 74 74 ere to make sett
25b0: 69 6e 67 20 75 70 20 65 61 73 69 65 72 0a 09 20 ing up easier..
25c0: 20 20 20 28 69 66 20 64 65 62 75 67 6d 6f 64 65 (if debugmode
25d0: 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 (session:log se
25e0: 6c 66 20 22 49 4e 46 4f 3a 20 73 65 74 74 69 6e lf "INFO: settin
25f0: 67 20 75 70 20 66 6f 72 20 73 71 6c 69 74 65 33 g up for sqlite3
2600: 20 64 62 20 61 63 63 65 73 73 20 74 6f 20 22 20 db access to "
2610: 64 62 66 6e 61 6d 65 29 29 0a 09 20 20 20 20 28 dbfname)).. (
2620: 69 66 20 28 6e 6f 74 20 28 66 69 6c 65 2d 77 72 if (not (file-wr
2630: 69 74 65 2d 61 63 63 65 73 73 3f 20 64 62 70 61 ite-access? dbpa
2640: 74 68 29 29 0a 09 09 28 73 65 73 73 69 6f 6e 3a th))...(session:
2650: 6c 6f 67 20 73 65 6c 66 20 22 57 41 52 4e 49 4e log self "WARNIN
2660: 47 3a 20 43 61 6e 6e 6f 74 20 77 72 69 74 65 20 G: Cannot write
2670: 74 6f 20 22 20 64 62 70 61 74 68 29 0a 09 09 28 to " dbpath)...(
2680: 69 66 20 64 65 62 75 67 6d 6f 64 65 20 28 73 65 if debugmode (se
2690: 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 ssion:log self "
26a0: 49 4e 46 4f 3a 20 22 20 64 62 70 61 74 68 20 22 INFO: " dbpath "
26b0: 20 69 73 20 77 72 69 74 65 61 62 6c 65 22 29 29 is writeable"))
26c0: 29 0a 09 20 20 20 20 28 69 66 20 28 66 69 6c 65 ).. (if (file
26d0: 2d 65 78 69 73 74 73 3f 20 64 62 66 6e 61 6d 65 -exists? dbfname
26e0: 29 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 20 3b )...(begin... ;
26f0: 3b 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 ; (session:log s
2700: 65 6c 66 20 22 73 65 74 74 69 6e 67 20 64 62 65 elf "setting dbe
2710: 78 69 73 74 73 20 74 6f 20 23 74 22 29 0a 09 09 xists to #t")...
2720: 20 20 28 73 65 74 21 20 64 62 65 78 69 73 74 73 (set! dbexists
2730: 20 23 74 29 29 29 29 0a 09 20 20 28 69 66 20 64 #t)))).. (if d
2740: 65 62 75 67 6d 6f 64 65 20 28 73 65 73 73 69 6f ebugmode (sessio
2750: 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 49 4e 46 4f n:log self "INFO
2760: 3a 20 73 65 74 74 69 6e 67 20 75 70 20 66 6f 72 : setting up for
2770: 20 70 67 20 64 62 20 61 63 63 65 73 73 20 74 6f pg db access to
2780: 20 61 63 63 6f 75 6e 74 20 69 6e 66 6f 20 22 20 account info "
2790: 64 62 69 6e 69 74 29 29 29 0a 20 20 20 20 20 20 dbinit))).
27a0: 28 69 66 20 64 65 62 75 67 6d 6f 64 65 20 28 73 (if debugmode (s
27b0: 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 ession:log self
27c0: 22 64 62 74 79 70 65 3a 20 22 20 64 62 74 79 70 "dbtype: " dbtyp
27d0: 65 20 22 20 64 62 66 6e 61 6d 65 3a 20 22 20 64 e " dbfname: " d
27e0: 62 66 6e 61 6d 65 20 22 20 64 62 65 78 69 73 74 bfname " dbexist
27f0: 73 3a 20 22 20 64 62 65 78 69 73 74 73 29 29 29 s: " dbexists)))
2800: 0a 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d 63 . (sdat-set-c
2810: 6f 6e 6e 21 20 73 65 6c 66 20 28 64 62 69 3a 6f onn! self (dbi:o
2820: 70 65 6e 20 64 62 74 79 70 65 20 64 62 69 6e 69 pen dbtype dbini
2830: 74 29 29 0a 20 20 20 20 28 73 65 74 21 20 2a 64 t)). (set! *d
2840: 62 2a 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e b* (sdat-get-con
2850: 6e 20 73 65 6c 66 29 29 0a 20 20 20 20 28 69 66 n self)). (if
2860: 20 28 61 6e 64 20 28 6e 6f 74 20 64 62 65 78 69 (and (not dbexi
2870: 73 74 73 29 28 65 71 3f 20 64 62 74 79 70 65 20 sts)(eq? dbtype
2880: 27 73 71 6c 69 74 65 33 29 29 0a 20 09 28 62 65 'sqlite3)). .(be
2890: 67 69 6e 0a 09 20 20 28 70 72 69 6e 74 20 22 57 gin.. (print "W
28a0: 41 52 4e 49 4e 47 3a 20 53 65 74 74 69 6e 67 20 ARNING: Setting
28b0: 75 70 20 73 65 73 73 69 6f 6e 20 64 62 20 77 69 up session db wi
28c0: 74 68 20 73 71 6c 69 74 65 33 22 29 0a 09 20 20 th sqlite3")..
28d0: 28 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 2d 64 (session:setup-d
28e0: 62 20 73 65 6c 66 29 29 29 0a 20 20 20 20 28 73 b self))). (s
28f0: 65 73 73 69 6f 6e 3a 70 72 6f 63 65 73 73 2d 75 ession:process-u
2900: 72 6c 2d 70 61 74 68 20 73 65 6c 66 29 0a 20 20 rl-path self).
2910: 20 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 (session:setup
2920: 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c -session-key sel
2930: 66 29 0a 20 20 20 20 3b 3b 20 63 61 70 74 75 72 f). ;; captur
2940: 65 20 73 74 64 69 6e 20 69 66 20 74 68 69 73 20 e stdin if this
2950: 69 73 20 61 20 50 4f 53 54 0a 20 20 20 20 28 73 is a POST. (s
2960: 64 61 74 2d 73 65 74 2d 72 65 71 75 65 73 74 2d dat-set-request-
2970: 6d 65 74 68 6f 64 21 20 73 65 6c 66 20 28 67 65 method! self (ge
2980: 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 t-environment-va
2990: 72 69 61 62 6c 65 20 22 52 45 51 55 45 53 54 5f riable "REQUEST_
29a0: 4d 45 54 48 4f 44 22 29 29 0a 20 20 20 20 28 73 METHOD")). (s
29b0: 64 61 74 2d 73 65 74 2d 66 6f 72 6d 64 61 74 21 dat-set-formdat!
29c0: 20 73 65 6c 66 20 28 66 6f 72 6d 64 61 74 3a 6c self (formdat:l
29d0: 6f 61 64 2d 61 6c 6c 29 29 29 29 0a 0a 3b 3b 20 oad-all))))..;;
29e0: 73 65 74 75 70 20 74 68 65 20 64 62 20 77 69 74 setup the db wit
29f0: 68 20 73 65 73 73 69 6f 6e 20 74 61 62 6c 65 73 h session tables
2a00: 2c 20 77 6f 72 6b 73 20 66 6f 72 20 73 71 6c 69 , works for sqli
2a10: 74 65 20 6f 6e 6c 79 20 72 69 67 68 74 20 6e 6f te only right no
2a20: 77 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 w.(define (sessi
2a30: 6f 6e 3a 73 65 74 75 70 2d 64 62 20 73 65 6c 66 on:setup-db self
2a40: 29 0a 20 20 28 6c 65 74 20 28 28 63 6f 6e 6e 20 ). (let ((conn
2a50: 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 (sdat-get-conn s
2a60: 65 6c 66 29 29 29 0a 20 20 20 20 28 66 6f 72 2d elf))). (for-
2a70: 65 61 63 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 each . (lamb
2a80: 64 61 20 28 73 74 6d 74 29 0a 20 20 20 20 20 20 da (stmt).
2a90: 20 28 64 62 69 3a 65 78 65 63 20 63 6f 6e 6e 20 (dbi:exec conn
2aa0: 73 74 6d 74 29 29 0a 20 20 20 20 20 28 6c 69 73 stmt)). (lis
2ab0: 74 20 22 43 52 45 41 54 45 20 54 41 42 4c 45 20 t "CREATE TABLE
2ac0: 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 28 69 64 session_vars (id
2ad0: 20 49 4e 54 45 47 45 52 20 50 52 49 4d 41 52 59 INTEGER PRIMARY
2ae0: 20 4b 45 59 2c 73 65 73 73 69 6f 6e 5f 69 64 20 KEY,session_id
2af0: 49 4e 54 45 47 45 52 2c 70 61 67 65 20 54 45 58 INTEGER,page TEX
2b00: 54 2c 6b 65 79 20 54 45 58 54 2c 76 61 6c 75 65 T,key TEXT,value
2b10: 20 54 45 58 54 29 3b 22 0a 09 20 20 20 22 43 52 TEXT);".. "CR
2b20: 45 41 54 45 20 54 41 42 4c 45 20 73 65 73 73 69 EATE TABLE sessi
2b30: 6f 6e 73 20 28 69 64 20 49 4e 54 45 47 45 52 20 ons (id INTEGER
2b40: 50 52 49 4d 41 52 59 20 4b 45 59 2c 73 65 73 73 PRIMARY KEY,sess
2b50: 69 6f 6e 5f 6b 65 79 20 54 45 58 54 2c 6c 61 73 ion_key TEXT,las
2b60: 74 5f 75 73 65 64 20 54 49 4d 45 53 54 41 4d 50 t_used TIMESTAMP
2b70: 29 3b 22 0a 20 20 20 20 20 20 20 20 20 20 20 22 );". "
2b80: 43 52 45 41 54 45 20 54 41 42 4c 45 20 6d 65 74 CREATE TABLE met
2b90: 61 64 61 74 61 20 28 69 64 20 49 4e 54 45 47 45 adata (id INTEGE
2ba0: 52 20 50 52 49 4d 41 52 59 20 4b 45 59 2c 6b 65 R PRIMARY KEY,ke
2bb0: 79 20 54 45 58 54 2c 76 61 6c 75 65 20 54 45 58 y TEXT,value TEX
2bc0: 54 29 3b 22 29 29 29 29 0a 3b 3b 20 20 3b 3b 20 T);")))).;; ;;
2bd0: 69 66 20 77 65 20 68 61 76 65 20 61 20 73 65 73 if we have a ses
2be0: 73 69 6f 6e 5f 6b 65 79 20 6c 6f 6f 6b 20 75 70 sion_key look up
2bf0: 20 74 68 65 20 73 65 73 73 69 6f 6e 2d 69 64 20 the session-id
2c00: 61 6e 64 20 73 74 6f 72 65 20 69 74 0a 3b 3b 20 and store it.;;
2c10: 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 (sdat-set-sessi
2c20: 6f 6e 2d 69 64 21 20 73 65 6c 66 20 28 73 65 73 on-id! self (ses
2c30: 73 69 6f 6e 3a 67 65 74 2d 69 64 20 73 65 6c 66 sion:get-id self
2c40: 29 29 29 0a 0a 3b 3b 20 6f 6e 6c 79 20 73 65 74 )))..;; only set
2c50: 20 73 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 20 session-cookie
2c60: 77 68 65 6e 20 61 20 6e 65 77 20 73 65 73 73 69 when a new sessi
2c70: 6f 6e 20 69 73 20 63 72 65 61 74 65 64 0a 28 64 on is created.(d
2c80: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 efine (session:s
2c90: 65 74 75 70 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 etup-session-key
2ca0: 20 73 65 6c 66 29 20 20 0a 20 20 28 6c 65 74 2a self) . (let*
2cb0: 20 28 28 73 6b 20 20 28 73 65 73 73 69 6f 6e 3a ((sk (session:
2cc0: 65 78 74 72 61 63 74 2d 73 65 73 73 69 6f 6e 2d extract-session-
2cd0: 6b 65 79 20 73 65 6c 66 29 29 0a 20 20 20 20 20 key self)).
2ce0: 20 20 20 20 28 73 69 64 20 28 69 66 20 73 6b 20 (sid (if sk
2cf0: 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 69 64 20 (session:get-id
2d00: 73 65 6c 66 20 73 6b 29 20 23 66 29 29 29 0a 20 self sk) #f))).
2d10: 20 20 20 28 69 66 20 28 6e 6f 74 20 73 69 64 29 (if (not sid)
2d20: 20 3b 3b 20 6e 65 65 64 20 61 20 6e 65 77 20 6b ;; need a new k
2d30: 65 79 0a 20 20 20 20 20 20 20 20 28 6c 65 74 2a ey. (let*
2d40: 20 28 28 6e 65 77 2d 6b 65 79 20 28 73 65 73 73 ((new-key (sess
2d50: 69 6f 6e 3a 67 65 74 2d 6e 65 77 2d 6b 65 79 20 ion:get-new-key
2d60: 73 65 6c 66 29 29 0a 20 20 20 20 20 20 20 20 20 self)).
2d70: 20 20 20 20 20 20 28 6e 65 77 2d 73 69 64 20 28 (new-sid (
2d80: 73 65 73 73 69 6f 6e 3a 67 65 74 2d 69 64 20 73 session:get-id s
2d90: 65 6c 66 20 6e 65 77 2d 6b 65 79 29 29 29 0a 20 elf new-key))).
2da0: 20 20 20 20 20 20 20 20 20 28 73 64 61 74 2d 73 (sdat-s
2db0: 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 21 20 et-session-key!
2dc0: 73 65 6c 66 20 6e 65 77 2d 6b 65 79 29 0a 20 20 self new-key).
2dd0: 20 20 20 20 20 20 20 20 28 73 64 61 74 2d 73 65 (sdat-se
2de0: 74 2d 73 65 73 73 69 6f 6e 2d 69 64 21 20 73 65 t-session-id! se
2df0: 6c 66 20 6e 65 77 2d 73 69 64 29 0a 20 20 20 20 lf new-sid).
2e00: 20 20 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d (sdat-set-
2e10: 73 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 21 20 session-cookie!
2e20: 73 65 6c 66 20 28 73 65 73 73 69 6f 6e 3a 6d 61 self (session:ma
2e30: 6b 65 2d 63 6f 6f 6b 69 65 20 73 65 6c 66 29 29 ke-cookie self))
2e40: 29 0a 20 20 20 20 20 20 20 20 28 73 64 61 74 2d ). (sdat-
2e50: 73 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 21 20 set-session-id!
2e60: 73 65 6c 66 20 73 69 64 29 29 29 29 0a 0a 28 64 self sid))))..(d
2e70: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 6d efine (session:m
2e80: 61 6b 65 2d 63 6f 6f 6b 69 65 20 73 65 6c 66 29 ake-cookie self)
2e90: 0a 20 20 3b 3b 20 28 6c 69 73 74 20 28 63 6f 6e . ;; (list (con
2ea0: 63 20 22 73 65 73 73 69 6f 6e 5f 6b 65 79 3d 22 c "session_key="
2eb0: 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 (sdat-get-sessi
2ec0: 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 20 22 3b 20 on-key self) ";
2ed0: 50 61 74 68 3d 2f 3b 20 44 6f 6d 61 69 6e 3d 2e Path=/; Domain=.
2ee0: 22 20 28 73 64 61 74 2d 67 65 74 2d 64 6f 6d 61 " (sdat-get-doma
2ef0: 69 6e 20 73 65 6c 66 29 20 22 3b 20 4d 61 78 2d in self) "; Max-
2f00: 41 67 65 3d 22 20 28 2a 20 38 36 34 30 30 20 31 Age=" (* 86400 1
2f10: 34 29 20 22 3b 20 56 65 72 73 69 6f 6e 3d 31 22 4) "; Version=1"
2f20: 29 29 29 20 0a 20 20 3b 3b 20 41 63 63 6f 72 64 ))) . ;; Accord
2f30: 69 6e 67 20 74 6f 20 0a 20 20 3b 3b 20 20 20 20 ing to . ;;
2f40: 68 74 74 70 3a 2f 2f 77 77 77 2e 63 6f 64 65 6d http://www.codem
2f50: 61 72 76 65 6c 73 2e 63 6f 6d 2f 32 30 31 30 2f arvels.com/2010/
2f60: 31 31 2f 61 70 61 63 68 65 2d 72 65 77 72 69 74 11/apache-rewrit
2f70: 65 72 75 6c 65 2d 73 65 74 2d 61 2d 63 6f 6f 6b erule-set-a-cook
2f80: 69 65 2d 6f 6e 2d 6c 6f 63 61 6c 68 6f 73 74 2f ie-on-localhost/
2f90: 0a 0a 20 20 3b 3b 20 20 48 65 72 65 20 61 72 65 .. ;; Here are
2fa0: 20 74 68 65 20 32 20 28 6f 66 74 65 6e 20 6c 65 the 2 (often le
2fb0: 66 74 20 6f 75 74 29 20 72 65 71 75 69 72 65 6d ft out) requirem
2fc0: 65 6e 74 73 20 74 6f 20 73 65 74 20 61 20 63 6f ents to set a co
2fd0: 6f 6b 69 65 20 75 73 69 6e 67 0a 20 20 3b 3b 20 okie using. ;;
2fe0: 20 68 74 74 70 64 1b 2d 46 a2 73 20 72 65 77 72 httpd.-F˘s rewr
2ff0: 69 74 65 20 72 75 6c 65 20 28 6d 6f 64 5f 72 65 ite rule (mod_re
3000: 77 72 69 74 65 29 2c 20 77 68 69 6c 65 20 77 6f write), while wo
3010: 72 6b 69 6e 67 20 6f 6e 20 6c 6f 63 61 6c 68 6f rking on localho
3020: 73 74 3a 1b 2d 41 0a 20 20 3b 3b 0a 20 20 3b 3b st:.-A. ;;. ;;
3030: 20 20 55 73 65 20 74 68 65 20 49 50 20 31 32 37 Use the IP 127
3040: 2e 30 2e 30 2e 31 20 69 6e 73 74 65 61 64 20 6f .0.0.1 instead o
3050: 66 20 6c 6f 63 61 6c 68 6f 73 74 2f 6d 61 63 68 f localhost/mach
3060: 69 6e 65 2d 6e 61 6d 65 20 61 73 20 74 68 65 0a ine-name as the.
3070: 20 20 3b 3b 20 20 64 6f 6d 61 69 6e 3b 20 65 2e ;; domain; e.
3080: 67 2e 20 5b 43 4f 3d 73 6f 6d 65 43 6f 6f 6b 69 g. [CO=someCooki
3090: 65 3a 73 6f 6d 65 56 61 6c 75 65 3a 31 32 37 2e e:someValue:127.
30a0: 30 2e 30 2e 31 3a 32 3a 2f 5d 2c 20 77 68 69 63 0.0.1:2:/], whic
30b0: 68 20 73 61 79 73 0a 20 20 3b 3b 20 20 63 72 65 h says. ;; cre
30c0: 61 74 65 20 61 20 63 6f 6f 6b 69 65 20 1b 2d 59 ate a cookie .-Y
30d0: b4 73 6f 6d 65 43 6f 6f 6b 69 65 a1 20 77 69 74 ´someCookieˇ wit
30e0: 68 20 76 61 6c 75 65 20 b4 73 6f 6d 65 56 61 6c h value ´someVal
30f0: 75 65 a1 20 66 6f 72 20 74 68 65 0a 20 20 3b 3b ueˇ for the. ;;
3100: 20 20 64 6f 6d 61 69 6e 20 b4 31 32 37 2e 30 2e domain ´127.0.
3110: 30 2e 31 1b 24 42 21 6d 1b 28 42 20 68 61 76 69 0.1.$B!m.(B havi
3120: 6e 67 20 61 20 6c 69 66 65 20 74 69 6d 65 20 6f ng a life time o
3130: 66 20 32 20 6d 69 6e 73 2c 20 66 6f 72 20 61 6e f 2 mins, for an
3140: 79 20 70 61 74 68 20 69 6e 0a 20 20 3b 3b 20 20 y path in. ;;
3150: 74 68 65 20 64 6f 6d 61 69 6e 20 28 70 61 74 68 the domain (path
3160: 3d 2f 29 2e 20 28 4f 62 76 69 6f 75 73 6c 79 20 =/). (Obviously
3170: 79 6f 75 20 77 69 6c 6c 20 68 61 76 65 20 74 6f you will have to
3180: 20 72 75 6e 20 74 68 65 0a 20 20 3b 3b 20 20 61 run the. ;; a
3190: 70 70 6c 69 63 61 74 69 6f 6e 20 77 69 74 68 20 pplication with
31a0: 74 68 69 73 20 76 61 6c 75 65 20 69 6e 20 74 68 this value in th
31b0: 65 20 55 52 4c 29 0a 20 20 3b 3b 0a 20 20 3b 3b e URL). ;;. ;;
31c0: 20 20 54 6f 20 6d 61 6b 65 20 61 20 73 65 73 73 To make a sess
31d0: 69 6f 6e 20 63 6f 6f 6b 69 65 2c 20 6c 69 6d 69 ion cookie, limi
31e0: 74 20 74 68 65 20 66 6c 61 67 20 73 74 61 74 65 t the flag state
31f0: 6d 65 6e 74 20 74 6f 20 6a 75 73 74 20 74 68 72 ment to just thr
3200: 65 65 0a 20 20 3b 3b 20 20 61 74 74 72 69 62 75 ee. ;; attribu
3210: 74 65 73 3a 20 6e 61 6d 65 2c 20 76 61 6c 75 65 tes: name, value
3220: 20 61 6e 64 20 64 6f 6d 61 69 6e 2e 20 65 2e 67 and domain. e.g
3230: 0a 20 20 3b 3b 20 20 5b 43 4f 3d 73 6f 6d 65 43 . ;; [CO=someC
3240: 6f 6f 6b 69 65 3a 73 6f 6d 65 56 61 6c 75 65 3a ookie:someValue:
3250: 31 32 37 2e 30 2e 30 2e 31 5d 20 1b 25 47 e2 80 127.0.0.1] .%Gâ€
3260: 93 1b 25 40 20 41 6e 79 20 66 75 72 74 68 65 72 “.%@ Any further
3270: 0a 20 20 3b 3b 20 20 73 65 74 74 69 6e 67 73 2c . ;; settings,
3280: 20 61 70 61 63 68 65 20 77 72 69 74 65 73 20 61 apache writes a
3290: 6e a1 20 65 78 70 69 72 65 73 a1 20 61 74 74 72 nˇ expiresˇ attr
32a0: 69 62 75 74 65 20 66 6f 72 20 74 68 65 20 73 65 ibute for the se
32b0: 74 2d 63 6f 6f 6b 69 65 0a 20 20 3b 3b 20 20 68 t-cookie. ;; h
32c0: 65 61 64 65 72 2c 20 77 68 69 63 68 20 6d 61 6b eader, which mak
32d0: 65 73 20 74 68 65 20 63 6f 6f 6b 69 65 20 61 20 es the cookie a
32e0: 70 65 72 73 69 73 74 65 6e 74 20 6f 6e 65 20 28 persistent one (
32f0: 6e 6f 74 20 72 65 61 6c 6c 79 0a 20 20 3b 3b 20 not really. ;;
3300: 20 70 65 72 73 69 73 74 65 6e 74 2c 20 61 73 20 persistent, as
3310: 74 68 65 20 65 78 70 69 72 65 73 20 76 61 6c 75 the expires valu
3320: 65 20 73 65 74 20 69 73 20 74 68 65 20 63 75 72 e set is the cur
3330: 72 65 6e 74 20 73 65 72 76 65 72 20 74 69 6d 65 rent server time
3340: 0a 20 20 3b 3b 20 20 1b 25 47 e2 80 93 1b 25 40 . ;; .%G–.%@
3350: 20 73 6f 20 79 6f 75 20 64 6f 6e 1b 2d 46 1b 2d so you don.-F.-
3360: 46 a2 74 20 65 76 65 6e 20 67 65 74 20 74 6f 20 F˘t even get to
3370: 73 65 65 20 79 6f 75 72 20 63 6f 6f 6b 69 65 21 see your cookie!
3380: 29 1b 2d 41 0a 20 20 28 6c 69 73 74 20 28 73 74 ).-A. (list (st
3390: 72 69 6e 67 2d 73 75 62 73 74 69 74 75 74 65 20 ring-substitute
33a0: 0a 09 20 22 3b 22 20 22 3b 20 22 20 0a 09 20 28 .. ";" "; " .. (
33b0: 63 61 72 20 28 63 6f 6e 73 74 72 75 63 74 2d 63 car (construct-c
33c0: 6f 6f 6b 69 65 2d 73 74 72 69 6e 67 20 0a 09 20 ookie-string ..
33d0: 20 20 20 20 20 20 3b 3b 20 77 61 72 6e 69 6e 67 ;; warning
33e0: 21 20 6d 65 73 73 69 6e 67 20 75 70 20 74 68 69 ! messing up thi
33f0: 73 20 69 74 74 79 20 62 69 74 74 79 20 62 69 74 s itty bitty bit
3400: 20 6f 66 20 63 6f 64 65 20 77 69 6c 6c 20 63 6f of code will co
3410: 73 74 20 6d 75 63 68 20 74 69 6d 65 21 0a 09 20 st much time!..
3420: 20 20 20 20 20 20 60 28 28 22 73 65 73 73 69 6f `(("sessio
3430: 6e 5f 6b 65 79 22 20 2c 28 73 64 61 74 2d 67 65 n_key" ,(sdat-ge
3440: 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 t-session-key se
3450: 6c 66 29 0a 09 09 20 20 65 78 70 69 72 65 73 3a lf)... expires:
3460: 20 2c 28 2b 20 28 63 75 72 72 65 6e 74 2d 73 65 ,(+ (current-se
3470: 63 6f 6e 64 73 29 20 28 2a 20 31 34 20 38 36 34 conds) (* 14 864
3480: 30 30 29 29 20 0a 09 09 20 20 3b 3b 20 6d 61 78 00)) ... ;; max
3490: 2d 61 67 65 3a 20 28 2a 20 31 34 20 38 36 34 30 -age: (* 14 8640
34a0: 30 29 0a 09 09 20 20 70 61 74 68 3a 20 22 2f 22 0)... path: "/"
34b0: 20 3b 3b 20 0a 09 09 20 20 64 6f 6d 61 69 6e 3a ;; ... domain:
34c0: 20 2c 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 ,(string-append
34d0: 20 22 2e 22 20 28 73 64 61 74 2d 67 65 74 2d 64 "." (sdat-get-d
34e0: 6f 6d 61 69 6e 20 73 65 6c 66 29 29 0a 09 09 20 omain self))...
34f0: 20 76 65 72 73 69 6f 6e 3a 20 31 29 29 20 30 29 version: 1)) 0)
3500: 29 29 29 29 0a 0a 3b 3b 20 6c 6f 6f 6b 20 75 70 ))))..;; look up
3510: 20 61 20 67 69 76 65 6e 20 73 65 73 73 69 6f 6e a given session
3520: 20 6b 65 79 20 61 6e 64 20 72 65 74 75 72 6e 20 key and return
3530: 74 68 65 20 69 64 20 69 66 20 66 6f 75 6e 64 2c the id if found,
3540: 20 23 66 20 69 66 20 6e 6f 74 20 66 6f 75 6e 64 #f if not found
3550: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
3560: 6e 3a 67 65 74 2d 69 64 20 73 65 6c 66 20 73 65 n:get-id self se
3570: 73 73 69 6f 6e 2d 6b 65 79 29 0a 20 20 3b 3b 20 ssion-key). ;;
3580: 28 6c 65 74 20 28 28 73 65 73 73 69 6f 6e 2d 6b (let ((session-k
3590: 65 79 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 ey (sdat-get-ses
35a0: 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 29 29 sion-key self)))
35b0: 0a 20 20 28 69 66 20 73 65 73 73 69 6f 6e 2d 6b . (if session-k
35c0: 65 79 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 ey. (let ((
35d0: 71 75 65 72 79 20 28 73 74 72 69 6e 67 2d 61 70 query (string-ap
35e0: 70 65 6e 64 20 22 53 45 4c 45 43 54 20 69 64 20 pend "SELECT id
35f0: 46 52 4f 4d 20 73 65 73 73 69 6f 6e 73 20 57 48 FROM sessions WH
3600: 45 52 45 20 73 65 73 73 69 6f 6e 5f 6b 65 79 3d ERE session_key=
3610: 27 22 20 73 65 73 73 69 6f 6e 2d 6b 65 79 20 22 '" session-key "
3620: 27 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 '")).
3630: 20 28 63 6f 6e 6e 20 28 73 64 61 74 2d 67 65 74 (conn (sdat-get
3640: 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 0a 20 20 20 -conn self)).
3650: 20 20 20 20 20 20 20 20 20 28 72 65 73 75 6c 74 (result
3660: 20 23 66 29 29 0a 09 28 64 62 69 3a 66 6f 72 2d #f))..(dbi:for-
3670: 65 61 63 68 2d 72 6f 77 20 0a 09 20 28 6c 61 6d each-row .. (lam
3680: 62 64 61 20 28 74 75 70 6c 65 29 0a 09 20 20 20 bda (tuple)..
3690: 28 73 65 74 21 20 72 65 73 75 6c 74 20 28 76 65 (set! result (ve
36a0: 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 30 ctor-ref tuple 0
36b0: 29 29 29 0a 09 20 63 6f 6e 6e 20 71 75 65 72 79 ))).. conn query
36c0: 29 0a 09 28 69 66 20 72 65 73 75 6c 74 20 28 64 )..(if result (d
36d0: 62 69 3a 65 78 65 63 20 63 6f 6e 6e 20 28 63 6f bi:exec conn (co
36e0: 6e 63 20 22 55 50 44 41 54 45 20 73 65 73 73 69 nc "UPDATE sessi
36f0: 6f 6e 73 20 53 45 54 20 6c 61 73 74 5f 75 73 65 ons SET last_use
3700: 64 3d 22 20 28 64 62 69 3a 6e 6f 77 20 63 6f 6e d=" (dbi:now con
3710: 6e 29 20 22 20 57 48 45 52 45 20 73 65 73 73 69 n) " WHERE sessi
3720: 6f 6e 5f 6b 65 79 3d 3f 3b 22 29 20 73 65 73 73 on_key=?;") sess
3730: 69 6f 6e 2d 6b 65 79 29 29 0a 20 20 20 20 20 20 ion-key)).
3740: 20 20 72 65 73 75 6c 74 29 0a 20 20 20 20 20 20 result).
3750: 23 66 29 29 0a 0a 3b 3b 20 0a 28 64 65 66 69 6e #f))..;; .(defin
3760: 65 20 28 73 65 73 73 69 6f 6e 3a 70 72 6f 63 65 e (session:proce
3770: 73 73 2d 75 72 6c 2d 70 61 74 68 20 73 65 6c 66 ss-url-path self
3780: 29 0a 20 20 28 6c 65 74 20 28 28 70 61 74 68 2d ). (let ((path-
3790: 69 6e 66 6f 20 20 20 20 28 67 65 74 2d 65 6e 76 info (get-env
37a0: 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c ironment-variabl
37b0: 65 20 22 50 41 54 48 5f 49 4e 46 4f 22 29 29 0a e "PATH_INFO")).
37c0: 09 28 71 75 65 72 79 2d 73 74 72 69 6e 67 20 28 .(query-string (
37d0: 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d get-environment-
37e0: 76 61 72 69 61 62 6c 65 20 22 51 55 45 52 59 5f variable "QUERY_
37f0: 53 54 52 49 4e 47 22 29 29 29 0a 20 20 20 20 3b STRING"))). ;
3800: 3b 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 ; (session:log s
3810: 65 6c 66 20 22 70 61 74 68 2d 69 6e 66 6f 3d 22 elf "path-info="
3820: 20 70 61 74 68 2d 69 6e 66 6f 20 22 20 71 75 65 path-info " que
3830: 72 79 2d 73 74 72 69 6e 67 3d 22 20 71 75 65 72 ry-string=" quer
3840: 79 2d 73 74 72 69 6e 67 29 0a 20 20 20 20 28 69 y-string). (i
3850: 66 20 70 61 74 68 2d 69 6e 66 6f 0a 09 28 6c 65 f path-info..(le
3860: 74 2a 20 28 28 70 61 72 74 73 20 20 20 20 28 73 t* ((parts (s
3870: 74 72 69 6e 67 2d 73 70 6c 69 74 20 70 61 74 68 tring-split path
3880: 2d 69 6e 66 6f 20 22 2f 22 29 29 0a 09 20 20 20 -info "/"))..
3890: 20 20 20 20 28 6e 75 6d 70 61 72 74 73 20 28 6c (numparts (l
38a0: 65 6e 67 74 68 20 70 61 72 74 73 29 29 29 0a 09 ength parts)))..
38b0: 20 20 28 69 66 20 28 3e 20 6e 75 6d 70 61 72 74 (if (> numpart
38c0: 73 20 30 29 0a 09 20 20 20 20 20 20 28 73 64 61 s 0).. (sda
38d0: 74 2d 73 65 74 2d 70 61 67 65 21 20 73 65 6c 66 t-set-page! self
38e0: 20 28 63 61 72 20 70 61 72 74 73 29 29 29 0a 09 (car parts)))..
38f0: 20 20 3b 3b 20 28 73 65 73 73 69 6f 6e 3a 6c 6f ;; (session:lo
3900: 67 20 73 65 6c 66 20 22 75 72 6c 2d 70 61 74 68 g self "url-path
3910: 3d 22 20 75 72 6c 2d 70 61 74 68 20 22 20 70 61 =" url-path " pa
3920: 72 74 73 3d 22 20 70 61 72 74 73 29 0a 09 20 20 rts=" parts)..
3930: 28 69 66 20 28 3e 20 6e 75 6d 70 61 72 74 73 20 (if (> numparts
3940: 31 29 0a 09 20 20 20 20 20 20 28 73 64 61 74 2d 1).. (sdat-
3950: 73 65 74 2d 70 61 74 68 2d 70 61 72 61 6d 73 21 set-path-params!
3960: 20 73 65 6c 66 20 28 63 64 72 20 70 61 72 74 73 self (cdr parts
3970: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 69 ))). (i
3980: 66 20 71 75 65 72 79 2d 73 74 72 69 6e 67 0a 20 f query-string.
3990: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 64 (sd
39a0: 61 74 2d 73 65 74 2d 70 61 72 61 6d 73 21 20 73 at-set-params! s
39b0: 65 6c 66 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 elf (string-spli
39c0: 74 20 71 75 65 72 79 2d 73 74 72 69 6e 67 20 22 t query-string "
39d0: 26 22 29 29 29 29 29 29 29 0a 0a 3b 3b 20 42 55 &")))))))..;; BU
39e0: 47 47 59 21 0a 28 64 65 66 69 6e 65 20 28 73 65 GGY!.(define (se
39f0: 73 73 69 6f 6e 3a 67 65 74 2d 6e 65 77 2d 6b 65 ssion:get-new-ke
3a00: 79 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 20 28 y self). (let (
3a10: 28 63 6f 6e 6e 20 20 20 28 73 64 61 74 2d 67 65 (conn (sdat-ge
3a20: 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 0a 20 20 t-conn self)).
3a30: 20 20 20 20 20 20 28 74 6d 70 6b 65 79 20 28 73 (tmpkey (s
3a40: 65 73 73 69 6f 6e 3a 6d 61 6b 65 2d 72 61 6e 64 ession:make-rand
3a50: 2d 73 74 72 69 6e 67 20 32 30 29 29 0a 20 20 20 -string 20)).
3a60: 20 20 20 20 20 28 73 74 61 74 75 73 20 23 66 29 (status #f)
3a70: 29 0a 20 20 20 20 28 64 62 69 3a 66 6f 72 2d 65 ). (dbi:for-e
3a80: 61 63 68 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 ach-row (lambda
3a90: 28 74 75 70 6c 65 29 0a 09 09 09 28 73 65 74 21 (tuple)....(set!
3aa0: 20 73 74 61 74 75 73 20 23 74 29 29 0a 09 09 20 status #t))...
3ab0: 20 20 20 20 20 63 6f 6e 6e 20 28 73 74 72 69 6e conn (strin
3ac0: 67 2d 61 70 70 65 6e 64 20 22 49 4e 53 45 52 54 g-append "INSERT
3ad0: 20 49 4e 54 4f 20 73 65 73 73 69 6f 6e 73 20 28 INTO sessions (
3ae0: 73 65 73 73 69 6f 6e 5f 6b 65 79 29 20 56 41 4c session_key) VAL
3af0: 55 45 53 20 28 27 22 20 74 6d 70 6b 65 79 20 22 UES ('" tmpkey "
3b00: 27 29 22 29 29 0a 20 20 20 20 74 6d 70 6b 65 79 ')")). tmpkey
3b10: 29 29 0a 0a 3b 3b 20 72 65 74 75 72 6e 73 20 73 ))..;; returns s
3b20: 65 73 73 69 6f 6e 20 6b 65 79 20 49 46 46 20 69 ession key IFF i
3b30: 74 20 69 73 20 69 6e 20 74 68 65 20 48 54 54 50 t is in the HTTP
3b40: 5f 43 4f 4f 4b 49 45 20 0a 28 64 65 66 69 6e 65 _COOKIE .(define
3b50: 20 28 73 65 73 73 69 6f 6e 3a 65 78 74 72 61 63 (session:extrac
3b60: 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 t-session-key se
3b70: 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 68 74 74 lf). (let ((htt
3b80: 70 2d 63 6f 6f 6b 69 65 20 28 67 65 74 2d 65 6e p-cookie (get-en
3b90: 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 vironment-variab
3ba0: 6c 65 20 22 48 54 54 50 5f 43 4f 4f 4b 49 45 22 le "HTTP_COOKIE"
3bb0: 29 29 29 0a 20 20 20 20 3b 3b 20 28 65 72 72 3a ))). ;; (err:
3bc0: 6c 6f 67 20 22 68 74 74 70 2d 63 6f 6f 6b 69 65 log "http-cookie
3bd0: 3a 20 22 20 68 74 74 70 2d 63 6f 6f 6b 69 65 29 : " http-cookie)
3be0: 0a 20 20 20 20 28 69 66 20 68 74 74 70 2d 63 6f . (if http-co
3bf0: 6f 6b 69 65 0a 20 20 20 20 20 20 20 20 28 73 65 okie. (se
3c00: 73 73 69 6f 6e 3a 65 78 74 72 61 63 74 2d 6b 65 ssion:extract-ke
3c10: 79 2d 66 72 6f 6d 2d 70 61 72 61 6d 20 73 65 6c y-from-param sel
3c20: 66 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 2d f (string-split-
3c30: 66 69 65 6c 64 73 20 20 22 3b 5c 5c 73 2b 22 20 fields ";\\s+"
3c40: 68 74 74 70 2d 63 6f 6f 6b 69 65 20 69 6e 66 69 http-cookie infi
3c50: 78 3a 29 20 22 73 65 73 73 69 6f 6e 5f 6b 65 79 x:) "session_key
3c60: 22 29 0a 20 20 20 20 20 20 20 20 23 66 29 29 29 "). #f)))
3c70: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ..(define (sessi
3c80: 6f 6e 3a 67 65 74 2d 73 65 73 73 69 6f 6e 2d 69 on:get-session-i
3c90: 64 20 73 65 6c 66 20 73 65 73 73 69 6f 6e 2d 6b d self session-k
3ca0: 65 79 29 0a 20 20 28 6c 65 74 20 28 28 71 75 65 ey). (let ((que
3cb0: 72 79 20 22 53 45 4c 45 43 54 20 69 64 20 46 52 ry "SELECT id FR
3cc0: 4f 4d 20 73 65 73 73 69 6f 6e 73 20 57 48 45 52 OM sessions WHER
3cd0: 45 20 73 65 73 73 69 6f 6e 5f 6b 65 79 3d 3f 3b E session_key=?;
3ce0: 22 29 0a 20 20 20 20 20 20 20 20 28 72 65 73 75 "). (resu
3cf0: 6c 74 20 23 66 29 29 0a 20 20 20 20 3b 3b 20 20 lt #f)). ;;
3d00: 20 20 20 28 70 67 3a 71 75 65 72 79 2d 66 6f 72 (pg:query-for
3d10: 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 74 -each (lambda (t
3d20: 75 70 6c 65 29 0a 20 20 20 20 3b 3b 20 20 20 20 uple). ;;
3d30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3d40: 20 20 20 20 20 20 28 73 65 74 21 20 72 65 73 75 (set! resu
3d50: 6c 74 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 lt (vector-ref t
3d60: 75 70 6c 65 20 30 29 29 29 20 3b 3b 20 28 76 65 uple 0))) ;; (ve
3d70: 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 30 ctor-ref tuple 0
3d80: 29 29 29 0a 20 20 20 20 3b 3b 20 20 20 20 20 20 ))). ;;
3d90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3da0: 20 20 28 73 3a 73 71 6c 70 61 72 61 6d 20 71 75 (s:sqlparam qu
3db0: 65 72 79 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 ery session-key)
3dc0: 0a 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 . ;;
3dd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
3de0: 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 sdat-get-conn se
3df0: 6c 66 29 29 0a 20 20 20 20 3b 3b 20 20 20 20 20 lf)). ;;
3e00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3e10: 20 20 20 63 6f 6e 6e 29 0a 20 20 20 20 28 64 62 conn). (db
3e20: 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 28 i:for-each-row (
3e30: 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 29 0a 09 lambda (tuple)..
3e40: 09 09 28 73 65 74 21 20 72 65 73 75 6c 74 20 28 ..(set! result (
3e50: 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 vector-ref tuple
3e60: 20 30 29 29 29 20 3b 3b 20 28 76 65 63 74 6f 72 0))) ;; (vector
3e70: 2d 72 65 66 20 74 75 70 6c 65 20 30 29 29 29 0a -ref tuple 0))).
3e80: 09 09 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 .. (sdat-ge
3e90: 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 0a 09 09 20 t-conn self)...
3ea0: 20 20 20 20 20 28 73 3a 73 71 6c 70 61 72 61 6d (s:sqlparam
3eb0: 20 71 75 65 72 79 20 73 65 73 73 69 6f 6e 2d 6b query session-k
3ec0: 65 79 29 29 0a 20 20 20 20 72 65 73 75 6c 74 29 ey)). result)
3ed0: 29 0a 0a 3b 3b 20 64 65 6c 65 74 65 20 61 6c 6c )..;; delete all
3ee0: 20 72 65 63 6f 72 64 73 20 66 6f 72 20 61 20 73 records for a s
3ef0: 65 73 73 69 6f 6e 0a 3b 3b 20 0a 3b 3b 20 4e 45 ession.;; .;; NE
3f00: 45 44 53 20 54 4f 20 42 45 20 54 52 41 4e 53 41 EDS TO BE TRANSA
3f10: 43 54 49 4f 4e 49 5a 45 44 21 0a 3b 3b 0a 28 64 CTIONIZED!.;;.(d
3f20: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 64 efine (session:d
3f30: 65 6c 65 74 65 2d 73 65 73 73 69 6f 6e 20 73 65 elete-session se
3f40: 6c 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 0a lf session-key).
3f50: 20 20 28 6c 65 74 20 28 28 73 65 73 73 69 6f 6e (let ((session
3f60: 2d 69 64 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 -id (session:get
3f70: 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 -session-id self
3f80: 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 0a 20 session-key)).
3f90: 20 20 20 20 20 20 20 28 71 72 79 31 20 20 20 20 (qry1
3fa0: 20 20 20 20 3b 3b 20 28 63 6f 6e 63 20 22 42 45 ;; (conc "BE
3fb0: 47 49 4e 3b 22 0a 09 09 09 20 20 22 44 45 4c 45 GIN;".... "DELE
3fc0: 54 45 20 46 52 4f 4d 20 73 65 73 73 69 6f 6e 5f TE FROM session_
3fd0: 76 61 72 73 20 57 48 45 52 45 20 73 65 73 73 69 vars WHERE sessi
3fe0: 6f 6e 5f 69 64 3d 3f 3b 22 29 0a 09 28 71 72 79 on_id=?;")..(qry
3ff0: 32 20 20 20 20 20 20 20 20 20 20 20 20 20 22 44 2 "D
4000: 45 4c 45 54 45 20 46 52 4f 4d 20 73 65 73 73 69 ELETE FROM sessi
4010: 6f 6e 73 20 57 48 45 52 45 20 69 64 3d 3f 3b 22 ons WHERE id=?;"
4020: 29 0a 09 09 20 20 20 20 20 3b 3b 20 20 22 43 4f )... ;; "CO
4030: 4d 4d 49 54 3b 22 29 29 0a 20 20 20 20 20 20 20 MMIT;")).
4040: 20 28 63 6f 6e 6e 20 20 20 20 20 20 20 20 20 20 (conn
4050: 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d 63 6f (sdat-get-co
4060: 6e 6e 20 73 65 6c 66 29 29 29 0a 20 20 20 20 28 nn self))). (
4070: 69 66 20 73 65 73 73 69 6f 6e 2d 69 64 0a 20 20 if session-id.
4080: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 (begin.
4090: 20 20 20 20 20 20 20 28 64 62 69 3a 65 78 65 63 (dbi:exec
40a0: 20 63 6f 6e 6e 20 71 72 79 31 20 73 65 73 73 69 conn qry1 sessi
40b0: 6f 6e 2d 69 64 29 20 3b 3b 20 73 65 73 73 69 6f on-id) ;; sessio
40c0: 6e 2d 69 64 29 0a 09 20 20 28 64 62 69 3a 65 78 n-id).. (dbi:ex
40d0: 65 63 20 63 6f 6e 6e 20 71 72 79 32 20 73 65 73 ec conn qry2 ses
40e0: 73 69 6f 6e 2d 69 64 29 0a 09 20 20 28 73 65 73 sion-id).. (ses
40f0: 73 69 6f 6e 3a 69 6e 69 74 69 61 6c 69 7a 65 20 sion:initialize
4100: 73 65 6c 66 29 0a 09 20 20 28 73 65 73 73 69 6f self).. (sessio
4110: 6e 3a 73 65 74 75 70 20 73 65 6c 66 29 29 29 0a n:setup self))).
4120: 20 20 20 20 28 6e 6f 74 20 28 73 65 73 73 69 6f (not (sessio
4130: 6e 3a 67 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 n:get-session-id
4140: 20 73 65 6c 66 20 73 65 73 73 69 6f 6e 2d 6b 65 self session-ke
4150: 79 29 29 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e y))))..;; (defin
4160: 65 20 28 73 65 73 73 69 6f 6e 3a 64 65 6c 65 74 e (session:delet
4170: 65 2d 73 65 73 73 69 6f 6e 20 73 65 6c 66 20 73 e-session self s
4180: 65 73 73 69 6f 6e 2d 6b 65 79 29 0a 3b 3b 20 20 ession-key).;;
4190: 20 28 6c 65 74 20 28 28 73 65 73 73 69 6f 6e 2d (let ((session-
41a0: 69 64 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d id (session:get-
41b0: 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 20 session-id self
41c0: 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 0a 3b 3b session-key)).;;
41d0: 20 20 20 20 20 20 20 20 20 28 71 75 65 72 69 65 (querie
41e0: 73 20 20 20 20 28 6c 69 73 74 20 22 42 45 47 49 s (list "BEGI
41f0: 4e 3b 22 0a 3b 3b 20 09 09 09 20 20 22 44 45 4c N;".;; ... "DEL
4200: 45 54 45 20 46 52 4f 4d 20 73 65 73 73 69 6f 6e ETE FROM session
4210: 5f 76 61 72 73 20 57 48 45 52 45 20 73 65 73 73 _vars WHERE sess
4220: 69 6f 6e 5f 69 64 3d 3f 3b 22 0a 3b 3b 20 20 20 ion_id=?;".;;
4230: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4240: 20 20 20 20 20 20 20 20 22 44 45 4c 45 54 45 20 "DELETE
4250: 46 52 4f 4d 20 73 65 73 73 69 6f 6e 73 20 57 48 FROM sessions WH
4260: 45 52 45 20 69 64 3d 3f 3b 22 0a 3b 3b 20 09 09 ERE id=?;".;; ..
4270: 09 20 20 22 43 4f 4d 4d 49 54 3b 22 29 29 0a 3b . "COMMIT;")).;
4280: 3b 20 20 20 20 20 20 20 20 20 28 63 6f 6e 6e 20 ; (conn
4290: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 64 (sd
42a0: 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 at-get-conn self
42b0: 29 29 29 0a 3b 3b 20 20 20 20 20 28 69 66 20 73 ))).;; (if s
42c0: 65 73 73 69 6f 6e 2d 69 64 0a 3b 3b 20 20 20 20 ession-id.;;
42d0: 20 20 20 20 20 28 62 65 67 69 6e 0a 3b 3b 20 20 (begin.;;
42e0: 20 20 20 20 20 20 20 20 20 28 66 6f 72 2d 65 61 (for-ea
42f0: 63 68 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 ch.;;
4300: 20 28 6c 61 6d 62 64 61 20 28 71 75 65 72 79 29 (lambda (query)
4310: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 .;;
4320: 20 28 64 62 69 3a 65 78 65 63 20 63 6f 6e 6e 20 (dbi:exec conn
4330: 71 75 65 72 79 20 73 65 73 73 69 6f 6e 2d 69 64 query session-id
4340: 29 29 0a 3b 3b 20 09 20 20 20 71 75 65 72 69 65 )).;; . querie
4350: 73 29 0a 3b 3b 20 09 20 20 28 69 6e 69 74 69 61 s).;; . (initia
4360: 6c 69 7a 65 20 73 65 6c 66 20 27 28 29 29 0a 3b lize self '()).;
4370: 3b 20 09 20 20 28 73 65 73 73 69 6f 6e 3a 73 65 ; . (session:se
4380: 74 75 70 20 73 65 6c 66 29 29 29 0a 3b 3b 20 20 tup self))).;;
4390: 20 20 20 28 6e 6f 74 20 28 73 65 73 73 69 6f 6e (not (session
43a0: 3a 67 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 :get-session-id
43b0: 73 65 6c 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 self session-key
43c0: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 ))))..(define (s
43d0: 65 73 73 69 6f 6e 3a 65 78 74 72 61 63 74 2d 6b ession:extract-k
43e0: 65 79 20 73 65 6c 66 20 6b 65 79 29 0a 20 20 28 ey self key). (
43f0: 6c 65 74 20 28 28 70 61 72 61 6d 73 20 28 73 64 let ((params (sd
4400: 61 74 2d 67 65 74 2d 70 61 72 61 6d 73 20 73 65 at-get-params se
4410: 6c 66 29 29 29 0a 20 20 20 20 28 73 65 73 73 69 lf))). (sessi
4420: 6f 6e 3a 65 78 74 72 61 63 74 2d 6b 65 79 2d 66 on:extract-key-f
4430: 72 6f 6d 2d 70 61 72 61 6d 20 73 65 6c 66 20 70 rom-param self p
4440: 61 72 61 6d 73 20 6b 65 79 29 29 29 0a 0a 28 64 arams key)))..(d
4450: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 65 efine (session:e
4460: 78 74 72 61 63 74 2d 6b 65 79 2d 66 72 6f 6d 2d xtract-key-from-
4470: 70 61 72 61 6d 20 73 65 6c 66 20 70 61 72 61 6d param self param
4480: 73 20 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 28 s key). (let ((
4490: 72 31 20 20 20 20 20 28 72 65 67 65 78 70 20 28 r1 (regexp (
44a0: 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 22 5e string-append "^
44b0: 22 20 6b 65 79 20 22 3d 28 5b 5e 3d 5d 2b 29 24 " key "=([^=]+)$
44c0: 22 29 29 29 29 0a 20 20 20 20 28 65 72 72 3a 6c ")))). (err:l
44d0: 6f 67 20 22 49 4e 46 4f 3a 20 4c 6f 6f 6b 69 6e og "INFO: Lookin
44e0: 67 20 66 6f 72 20 22 20 6b 65 79 20 22 20 69 6e g for " key " in
44f0: 20 22 20 70 61 72 61 6d 73 29 0a 20 20 20 20 28 " params). (
4500: 69 66 20 28 3c 20 28 6c 65 6e 67 74 68 20 70 61 if (< (length pa
4510: 72 61 6d 73 29 20 31 29 20 23 66 0a 09 28 6c 65 rams) 1) #f..(le
4520: 74 20 6c 6f 6f 70 20 28 28 68 65 61 64 20 20 20 t loop ((head
4530: 28 63 61 72 20 70 61 72 61 6d 73 29 29 0a 09 09 (car params))...
4540: 20 20 20 28 74 61 69 6c 20 20 20 28 63 64 72 20 (tail (cdr
4550: 70 61 72 61 6d 73 29 29 29 0a 09 20 20 28 6c 65 params))).. (le
4560: 74 20 28 28 6d 61 74 63 68 20 28 73 74 72 69 6e t ((match (strin
4570: 67 2d 6d 61 74 63 68 20 72 31 20 68 65 61 64 29 g-match r1 head)
4580: 29 29 0a 09 20 20 20 20 28 63 6f 6e 64 0a 09 20 )).. (cond..
4590: 20 20 20 20 28 6d 61 74 63 68 0a 09 20 20 20 20 (match..
45a0: 20 20 28 6c 65 74 20 28 28 73 65 73 73 69 6f 6e (let ((session
45b0: 2d 6b 65 79 20 28 6c 69 73 74 2d 72 65 66 20 6d -key (list-ref m
45c0: 61 74 63 68 20 31 29 29 29 0a 09 09 28 65 72 72 atch 1)))...(err
45d0: 3a 6c 6f 67 20 22 49 4e 46 4f 3a 20 46 6f 75 6e :log "INFO: Foun
45e0: 64 20 73 65 73 73 69 6f 6e 20 6b 65 79 3d 22 20 d session key="
45f0: 73 65 73 73 69 6f 6e 2d 6b 65 79 29 0a 09 09 28 session-key)...(
4600: 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e sdat-set-session
4610: 2d 6b 65 79 21 20 73 65 6c 66 20 28 6c 69 73 74 -key! self (list
4620: 2d 72 65 66 20 6d 61 74 63 68 20 31 29 29 0a 09 -ref match 1))..
4630: 09 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 0a 09 .session-key))..
4640: 20 20 20 20 20 28 28 6e 75 6c 6c 3f 20 74 61 69 ((null? tai
4650: 6c 29 0a 09 20 20 20 20 20 20 23 66 29 0a 09 20 l).. #f)..
4660: 20 20 20 20 28 65 6c 73 65 0a 09 20 20 20 20 20 (else..
4670: 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 69 6c (loop (car tail
4680: 29 0a 09 09 20 20 20 20 28 63 64 72 20 74 61 69 )... (cdr tai
4690: 6c 29 29 29 29 29 29 29 29 29 0a 0a 28 64 65 66 l)))))))))..(def
46a0: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 ine (session:set
46b0: 2d 70 61 67 65 21 20 73 65 6c 66 20 70 61 67 65 -page! self page
46c0: 5f 6e 61 6d 65 29 0a 20 20 28 73 64 61 74 2d 73 _name). (sdat-s
46d0: 65 74 2d 70 61 67 65 21 20 73 65 6c 66 20 70 61 et-page! self pa
46e0: 67 65 5f 6e 61 6d 65 29 29 0a 0a 28 64 65 66 69 ge_name))..(defi
46f0: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 63 6c 6f 73 ne (session:clos
4700: 65 20 73 65 6c 66 29 0a 20 20 28 64 62 69 3a 63 e self). (dbi:c
4710: 6c 6f 73 65 20 28 73 64 61 74 2d 67 65 74 2d 63 lose (sdat-get-c
4720: 6f 6e 6e 20 73 65 6c 66 29 29 29 0a 3b 3b 20 28 onn self))).;; (
4730: 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 close-output-por
4740: 74 20 28 73 64 61 74 2d 67 65 74 2d 6c 6f 67 70 t (sdat-get-logp
4750: 74 20 73 65 6c 66 29 29 0a 0a 28 64 65 66 69 6e t self))..(defin
4760: 65 20 28 73 65 73 73 69 6f 6e 3a 65 72 72 2d 6d e (session:err-m
4770: 73 67 20 73 65 6c 66 20 6d 73 67 29 0a 20 20 28 sg self msg). (
4780: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
4790: 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f (sdat-get-sessio
47a0: 6e 76 61 72 73 20 73 65 6c 66 29 20 22 45 52 52 nvars self) "ERR
47b0: 4f 52 5f 4d 53 47 22 0a 09 09 20 20 20 28 73 74 OR_MSG"... (st
47c0: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
47d0: 20 28 6d 61 70 20 73 3a 61 6e 79 2d 3e 73 74 72 (map s:any->str
47e0: 69 6e 67 20 6d 73 67 29 20 22 20 22 29 29 29 0a ing msg) " "))).
47f0: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
4800: 6e 3a 70 72 65 76 2d 65 72 72 20 73 65 6c 66 29 n:prev-err self)
4810: 0a 20 20 28 6c 65 74 20 28 28 70 72 65 76 2d 65 . (let ((prev-e
4820: 72 72 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 rr (hash-table-r
4830: 65 66 2f 64 65 66 61 75 6c 74 20 28 73 64 61 74 ef/default (sdat
4840: 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 -get-sessionvars
4850: 2d 62 65 66 6f 72 65 20 73 65 6c 66 29 20 22 45 -before self) "E
4860: 52 52 4f 52 5f 4d 53 47 22 20 23 66 29 29 0a 09 RROR_MSG" #f))..
4870: 28 63 75 72 72 2d 65 72 72 20 28 68 61 73 68 2d (curr-err (hash-
4880: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
4890: 74 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 t (sdat-get-sess
48a0: 69 6f 6e 76 61 72 73 20 73 65 6c 66 29 20 22 45 ionvars self) "E
48b0: 52 52 4f 52 5f 4d 53 47 22 20 23 66 29 29 29 0a RROR_MSG" #f))).
48c0: 20 20 20 20 28 69 66 20 70 72 65 76 2d 65 72 72 (if prev-err
48d0: 20 70 72 65 76 2d 65 72 72 0a 09 28 69 66 20 63 prev-err..(if c
48e0: 75 72 72 2d 65 72 72 20 63 75 72 72 2d 65 72 72 urr-err curr-err
48f0: 20 23 66 29 29 29 29 0a 0a 3b 3b 20 73 65 73 73 #f))))..;; sess
4900: 69 6f 6e 20 76 61 72 73 0a 3b 3b 20 31 2e 20 6b ion vars.;; 1. k
4910: 65 79 73 20 61 72 65 20 61 6c 77 61 79 73 20 61 eys are always a
4920: 20 73 74 72 69 6e 67 20 4e 4f 54 20 61 20 73 79 string NOT a sy
4930: 6d 62 6f 6c 0a 3b 3b 20 32 2e 20 76 61 6c 75 65 mbol.;; 2. value
4940: 73 20 61 72 65 20 61 6c 77 61 79 73 20 61 20 73 s are always a s
4950: 74 72 69 6e 67 20 63 6f 6e 76 65 72 73 69 6f 6e tring conversion
4960: 20 69 73 20 74 68 65 20 72 65 73 70 6f 6e 73 69 is the responsi
4970: 62 69 6c 69 74 79 20 6f 66 20 74 68 65 20 0a 3b bility of the .;
4980: 3b 20 20 20 20 63 6f 6e 73 75 6d 69 6e 67 20 66 ; consuming f
4990: 75 6e 63 74 69 6f 6e 20 28 61 74 20 6c 65 61 73 unction (at leas
49a0: 74 20 66 6f 72 20 6e 6f 77 2c 20 49 27 64 20 6c t for now, I'd l
49b0: 69 6b 65 20 74 6f 20 63 68 61 6e 67 65 20 74 68 ike to change th
49c0: 69 73 29 0a 0a 3b 3b 20 73 65 74 20 61 20 73 65 is)..;; set a se
49d0: 73 73 69 6f 6e 20 76 61 72 20 66 6f 72 20 74 68 ssion var for th
49e0: 65 20 63 75 72 72 65 6e 74 20 70 61 67 65 0a 3b e current page.;
49f0: 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ;.(define (sessi
4a00: 6f 6e 3a 63 75 72 72 2d 70 61 67 65 2d 73 65 74 on:curr-page-set
4a10: 21 20 73 65 6c 66 20 6b 65 79 20 76 61 6c 75 65 ! self key value
4a20: 29 0a 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ). (hash-table-
4a30: 73 65 74 21 20 28 73 64 61 74 2d 67 65 74 2d 70 set! (sdat-get-p
4a40: 61 67 65 76 61 72 73 20 73 65 6c 66 29 20 28 73 agevars self) (s
4a50: 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6b 65 79 :any->string key
4a60: 29 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 ) (s:any->string
4a70: 20 76 61 6c 75 65 29 29 29 0a 0a 3b 3b 20 64 65 value)))..;; de
4a80: 6c 20 61 20 76 61 72 20 66 6f 72 20 74 68 65 20 l a var for the
4a90: 63 75 72 72 65 6e 74 20 70 61 67 65 0a 3b 3b 0a current page.;;.
4aa0: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
4ab0: 3a 70 61 67 65 2d 76 61 72 2d 64 65 6c 21 20 73 :page-var-del! s
4ac0: 65 6c 66 20 6b 65 79 29 0a 20 20 28 68 61 73 68 elf key). (hash
4ad0: 2d 74 61 62 6c 65 2d 64 65 6c 65 74 65 21 20 28 -table-delete! (
4ae0: 73 64 61 74 2d 67 65 74 2d 70 61 67 65 76 61 72 sdat-get-pagevar
4af0: 73 20 73 65 6c 66 29 20 28 73 3a 61 6e 79 2d 3e s self) (s:any->
4b00: 73 74 72 69 6e 67 20 6b 65 79 29 29 29 0a 0a 3b string key)))..;
4b10: 3b 20 67 65 74 20 74 68 65 20 61 70 70 72 6f 70 ; get the approp
4b20: 72 69 61 74 65 20 68 61 73 68 20 67 69 76 65 6e riate hash given
4b30: 20 61 20 70 61 67 65 20 22 2a 73 65 73 73 69 6f a page "*sessio
4b40: 6e 76 61 72 73 2a 2c 20 2a 67 6c 6f 62 61 6c 76 nvars*, *globalv
4b50: 61 72 73 2a 20 6f 72 20 70 61 67 65 0a 3b 3b 0a ars* or page.;;.
4b60: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
4b70: 3a 67 65 74 2d 70 61 67 65 2d 68 61 73 68 20 73 :get-page-hash s
4b80: 65 6c 66 20 70 61 67 65 29 0a 20 20 28 69 66 20 elf page). (if
4b90: 28 73 74 72 69 6e 67 3d 3f 20 70 61 67 65 20 22 (string=? page "
4ba0: 2a 73 65 73 73 69 6f 6e 76 61 72 73 2a 22 29 0a *sessionvars*").
4bb0: 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d (sdat-get-
4bc0: 73 65 73 73 69 6f 6e 76 61 72 73 20 73 65 6c 66 sessionvars self
4bd0: 29 0a 20 20 20 20 20 20 28 69 66 20 28 73 74 72 ). (if (str
4be0: 69 6e 67 3d 3f 20 70 61 67 65 20 22 2a 67 6c 6f ing=? page "*glo
4bf0: 62 61 6c 76 61 72 73 2a 22 29 0a 09 20 20 28 73 balvars*").. (s
4c00: 64 61 74 2d 67 65 74 2d 67 6c 6f 62 61 6c 76 61 dat-get-globalva
4c10: 72 73 20 73 65 6c 66 29 0a 09 20 20 28 73 64 61 rs self).. (sda
4c20: 74 2d 67 65 74 2d 70 61 67 65 76 61 72 73 20 73 t-get-pagevars s
4c30: 65 6c 66 29 29 29 29 0a 0a 3b 3b 20 73 65 74 20 elf))))..;; set
4c40: 61 20 73 65 73 73 69 6f 6e 20 76 61 72 20 66 6f a session var fo
4c50: 72 20 61 20 67 69 76 65 6e 20 70 61 67 65 0a 3b r a given page.;
4c60: 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ;.(define (sessi
4c70: 6f 6e 3a 73 65 74 21 20 73 65 6c 66 20 70 61 67 on:set! self pag
4c80: 65 20 6b 65 79 20 76 61 6c 75 65 29 0a 20 20 28 e key value). (
4c90: 6c 65 74 20 28 28 68 74 20 28 73 65 73 73 69 6f let ((ht (sessio
4ca0: 6e 3a 67 65 74 2d 70 61 67 65 2d 68 61 73 68 20 n:get-page-hash
4cb0: 73 65 6c 66 20 70 61 67 65 29 29 29 0a 20 20 20 self page))).
4cc0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
4cd0: 21 20 68 74 20 28 73 3a 61 6e 79 2d 3e 73 74 72 ! ht (s:any->str
4ce0: 69 6e 67 20 6b 65 79 29 20 28 73 3a 61 6e 79 2d ing key) (s:any-
4cf0: 3e 73 74 72 69 6e 67 20 76 61 6c 75 65 29 29 29 >string value)))
4d00: 29 0a 0a 3b 3b 20 67 65 74 20 73 65 73 73 69 6f )..;; get sessio
4d10: 6e 20 76 61 72 73 20 66 6f 72 20 74 68 65 20 63 n vars for the c
4d20: 75 72 72 65 6e 74 20 70 61 67 65 0a 3b 3b 0a 28 urrent page.;;.(
4d30: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
4d40: 70 61 67 65 2d 67 65 74 20 73 65 6c 66 20 6b 65 page-get self ke
4d50: 79 29 0a 20 20 28 68 61 73 68 2d 74 61 62 6c 65 y). (hash-table
4d60: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 28 73 64 -ref/default (sd
4d70: 61 74 2d 67 65 74 2d 70 61 67 65 76 61 72 73 20 at-get-pagevars
4d80: 73 65 6c 66 29 20 6b 65 79 20 23 66 29 29 0a 0a self) key #f))..
4d90: 3b 3b 20 67 65 74 20 73 65 73 73 69 6f 6e 20 76 ;; get session v
4da0: 61 72 73 20 66 6f 72 20 61 20 73 70 65 63 69 66 ars for a specif
4db0: 69 65 64 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 ied page.;;.(def
4dc0: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 ine (session:get
4dd0: 20 73 65 6c 66 20 70 61 67 65 20 6b 65 79 29 0a self page key).
4de0: 20 20 28 6c 65 74 20 28 28 68 74 20 28 73 65 73 (let ((ht (ses
4df0: 73 69 6f 6e 3a 67 65 74 2d 70 61 67 65 2d 68 61 sion:get-page-ha
4e00: 73 68 20 73 65 6c 66 20 70 61 67 65 29 29 29 0a sh self page))).
4e10: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
4e20: 72 65 66 2f 64 65 66 61 75 6c 74 20 68 74 20 28 ref/default ht (
4e30: 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6b 65 s:any->string ke
4e40: 79 29 20 23 66 29 29 29 0a 0a 3b 3b 20 64 65 6c y) #f)))..;; del
4e50: 65 74 65 20 61 20 73 65 73 73 69 6f 6e 20 76 61 ete a session va
4e60: 72 20 66 6f 72 20 61 20 73 70 65 63 69 66 69 65 r for a specifie
4e70: 64 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 69 6e d page.;;.(defin
4e80: 65 20 28 73 65 73 73 69 6f 6e 3a 64 65 6c 21 20 e (session:del!
4e90: 73 65 6c 66 20 70 61 67 65 20 6b 65 79 29 0a 20 self page key).
4ea0: 20 28 6c 65 74 20 28 28 68 74 20 28 73 65 73 73 (let ((ht (sess
4eb0: 69 6f 6e 3a 67 65 74 2d 70 61 67 65 2d 68 61 73 ion:get-page-has
4ec0: 68 20 73 65 6c 66 20 70 61 67 65 29 29 29 0a 20 h self page))).
4ed0: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 64 (hash-table-d
4ee0: 65 6c 65 74 65 21 20 68 74 20 28 73 3a 61 6e 79 elete! ht (s:any
4ef0: 2d 3e 73 74 72 69 6e 67 20 6b 65 79 29 29 29 29 ->string key))))
4f00: 0a 0a 3b 3b 20 67 65 74 20 41 4c 4c 20 6b 65 79 ..;; get ALL key
4f10: 73 20 66 6f 72 20 74 68 69 73 20 70 61 67 65 20 s for this page
4f20: 61 6e 64 20 73 74 6f 72 65 20 69 6e 20 74 68 65 and store in the
4f30: 20 73 65 73 73 69 6f 6e 20 70 61 67 65 76 61 72 session pagevar
4f40: 73 20 68 61 73 68 0a 3b 3b 0a 28 64 65 66 69 6e s hash.;;.(defin
4f50: 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 76 e (session:get-v
4f60: 61 72 73 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 ars self). (let
4f70: 20 28 28 73 65 73 73 69 6f 6e 2d 69 64 20 20 28 ((session-id (
4f80: 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e sdat-get-session
4f90: 2d 69 64 20 73 65 6c 66 29 29 29 0a 20 20 20 20 -id self))).
4fa0: 28 69 66 20 28 6e 6f 74 20 73 65 73 73 69 6f 6e (if (not session
4fb0: 2d 69 64 29 0a 09 28 65 72 72 3a 6c 6f 67 20 22 -id)..(err:log "
4fc0: 45 52 52 4f 52 3a 20 4e 6f 20 73 65 73 73 69 6f ERROR: No sessio
4fd0: 6e 20 69 64 20 69 6e 20 73 65 73 73 69 6f 6e 20 n id in session
4fe0: 6f 62 6a 65 63 74 21 20 73 65 73 73 69 6f 6e 3a object! session:
4ff0: 67 65 74 2d 76 61 72 73 22 29 0a 09 28 6c 65 74 get-vars")..(let
5000: 2a 20 28 28 72 65 73 75 6c 74 20 20 20 20 20 20 * ((result
5010: 20 20 20 20 20 20 20 23 66 29 0a 09 20 20 20 20 #f)..
5020: 20 20 20 28 63 6f 6e 6e 20 20 20 20 20 20 20 20 (conn
5030: 20 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 (sdat-get
5040: 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 0a 09 20 20 -conn self))..
5050: 20 20 20 20 20 28 70 61 67 65 76 61 72 73 2d 62 (pagevars-b
5060: 65 66 6f 72 65 20 20 20 20 28 73 64 61 74 2d 67 efore (sdat-g
5070: 65 74 2d 70 61 67 65 76 61 72 73 2d 62 65 66 6f et-pagevars-befo
5080: 72 65 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 re self))..
5090: 20 20 28 73 65 73 73 69 6f 6e 76 61 72 73 2d 62 (sessionvars-b
50a0: 65 66 6f 72 65 20 28 73 64 61 74 2d 67 65 74 2d efore (sdat-get-
50b0: 73 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 6f sessionvars-befo
50c0: 72 65 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 re self))..
50d0: 20 20 28 67 6c 6f 62 61 6c 76 61 72 73 2d 62 65 (globalvars-be
50e0: 66 6f 72 65 20 20 28 73 64 61 74 2d 67 65 74 2d fore (sdat-get-
50f0: 67 6c 6f 62 61 6c 76 61 72 73 2d 62 65 66 6f 72 globalvars-befor
5100: 65 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 20 e self))..
5110: 20 28 70 61 67 65 76 61 72 73 20 20 20 20 20 20 (pagevars
5120: 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d 70 (sdat-get-p
5130: 61 67 65 76 61 72 73 20 73 65 6c 66 29 29 0a 09 agevars self))..
5140: 20 20 20 20 20 20 20 28 73 65 73 73 69 6f 6e 76 (sessionv
5150: 61 72 73 20 20 20 20 20 20 20 20 28 73 64 61 74 ars (sdat
5160: 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 -get-sessionvars
5170: 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 20 20 self))..
5180: 28 67 6c 6f 62 61 6c 76 61 72 73 20 20 20 20 20 (globalvars
5190: 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d 67 6c (sdat-get-gl
51a0: 6f 62 61 6c 76 61 72 73 20 73 65 6c 66 29 29 0a obalvars self)).
51b0: 09 20 20 20 20 20 20 20 28 70 61 67 65 2d 6e 61 . (page-na
51c0: 6d 65 20 20 20 20 20 20 20 20 20 20 28 73 64 61 me (sda
51d0: 74 2d 67 65 74 2d 70 61 67 65 20 73 65 6c 66 29 t-get-page self)
51e0: 29 0a 09 20 20 20 20 20 20 20 28 73 65 73 73 69 ).. (sessi
51f0: 6f 6e 2d 6b 65 79 20 20 20 20 20 20 20 20 28 73 on-key (s
5200: 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 2d dat-get-session-
5210: 6b 65 79 20 73 65 6c 66 29 29 0a 09 20 20 20 20 key self))..
5220: 20 20 20 28 71 75 65 72 79 20 20 20 20 20 20 20 (query
5230: 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 61 (string-a
5240: 70 70 65 6e 64 0a 09 09 09 09 20 20 20 20 22 53 ppend..... "S
5250: 45 4c 45 43 54 20 6b 65 79 2c 76 61 6c 75 65 20 ELECT key,value
5260: 46 52 4f 4d 20 73 65 73 73 69 6f 6e 5f 76 61 72 FROM session_var
5270: 73 20 49 4e 4e 45 52 20 4a 4f 49 4e 20 73 65 73 s INNER JOIN ses
5280: 73 69 6f 6e 73 20 4f 4e 20 73 65 73 73 69 6f 6e sions ON session
5290: 5f 76 61 72 73 2e 73 65 73 73 69 6f 6e 5f 69 64 _vars.session_id
52a0: 3d 73 65 73 73 69 6f 6e 73 2e 69 64 20 22 0a 09 =sessions.id "..
52b0: 09 09 09 20 20 20 20 22 57 48 45 52 45 20 73 65 ... "WHERE se
52c0: 73 73 69 6f 6e 5f 6b 65 79 3d 3f 20 41 4e 44 20 ssion_key=? AND
52d0: 70 61 67 65 3d 3f 3b 22 29 29 29 0a 09 20 20 3b page=?;"))).. ;
52e0: 3b 20 66 69 72 73 74 20 74 68 65 20 70 61 67 65 ; first the page
52f0: 20 73 70 65 63 69 66 69 63 20 76 61 72 73 0a 09 specific vars..
5300: 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d (dbi:for-each-
5310: 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 75 70 row (lambda (tup
5320: 6c 65 29 0a 09 09 09 20 20 20 20 20 20 28 6c 65 le).... (le
5330: 74 20 28 28 6b 20 28 76 65 63 74 6f 72 2d 72 65 t ((k (vector-re
5340: 66 20 74 75 70 6c 65 20 30 29 29 0a 09 09 09 09 f tuple 0)).....
5350: 20 20 20 20 28 76 20 28 76 65 63 74 6f 72 2d 72 (v (vector-r
5360: 65 66 20 74 75 70 6c 65 20 31 29 29 29 0a 09 09 ef tuple 1)))...
5370: 09 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 ..(hash-table-se
5380: 74 21 20 70 61 67 65 76 61 72 73 2d 62 65 66 6f t! pagevars-befo
5390: 72 65 20 6b 20 76 29 0a 09 09 09 09 28 68 61 73 re k v).....(has
53a0: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 70 61 67 h-table-set! pag
53b0: 65 76 61 72 73 20 20 20 20 20 20 20 20 6b 20 76 evars k v
53c0: 29 29 29 0a 09 09 09 20 20 20 20 63 6f 6e 6e 0a ))).... conn.
53d0: 09 09 09 20 20 20 20 28 73 3a 73 71 6c 70 61 72 ... (s:sqlpar
53e0: 61 6d 20 71 75 65 72 79 20 73 65 73 73 69 6f 6e am query session
53f0: 2d 6b 65 79 20 70 61 67 65 2d 6e 61 6d 65 29 29 -key page-name))
5400: 0a 09 20 20 3b 3b 20 74 68 65 6e 20 74 68 65 20 .. ;; then the
5410: 73 65 73 73 69 6f 6e 20 73 70 65 63 69 66 69 63 session specific
5420: 20 76 61 72 73 0a 09 20 20 28 64 62 69 3a 66 6f vars.. (dbi:fo
5430: 72 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 6d 62 r-each-row (lamb
5440: 64 61 20 28 74 75 70 6c 65 29 0a 09 09 09 20 20 da (tuple)....
5450: 20 20 20 20 28 6c 65 74 20 28 28 6b 20 28 76 65 (let ((k (ve
5460: 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 30 ctor-ref tuple 0
5470: 29 29 0a 09 09 09 09 20 20 20 20 28 76 20 28 76 ))..... (v (v
5480: 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 ector-ref tuple
5490: 31 29 29 29 0a 09 09 09 09 28 68 61 73 68 2d 74 1))).....(hash-t
54a0: 61 62 6c 65 2d 73 65 74 21 20 73 65 73 73 69 6f able-set! sessio
54b0: 6e 76 61 72 73 2d 62 65 66 6f 72 65 20 6b 20 76 nvars-before k v
54c0: 29 0a 09 09 09 09 28 68 61 73 68 2d 74 61 62 6c ).....(hash-tabl
54d0: 65 2d 73 65 74 21 20 73 65 73 73 69 6f 6e 76 61 e-set! sessionva
54e0: 72 73 20 20 20 20 20 20 20 20 6b 20 76 29 29 29 rs k v)))
54f0: 0a 09 09 09 20 20 20 20 63 6f 6e 6e 0a 09 09 09 .... conn....
5500: 20 20 20 20 28 73 3a 73 71 6c 70 61 72 61 6d 20 (s:sqlparam
5510: 71 75 65 72 79 20 73 65 73 73 69 6f 6e 2d 6b 65 query session-ke
5520: 79 20 22 2a 73 65 73 73 69 6f 6e 76 61 72 73 2a y "*sessionvars*
5530: 22 29 29 0a 09 20 20 3b 3b 20 61 6e 64 20 66 69 ")).. ;; and fi
5540: 6e 61 6c 6c 79 20 74 68 65 20 67 6c 6f 62 61 6c nally the global
5550: 20 76 61 72 73 0a 09 20 20 28 64 62 69 3a 66 6f vars.. (dbi:fo
5560: 72 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 6d 62 r-each-row (lamb
5570: 64 61 20 28 74 75 70 6c 65 29 0a 09 09 09 20 20 da (tuple)....
5580: 20 20 20 20 28 6c 65 74 20 28 28 6b 20 28 76 65 (let ((k (ve
5590: 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 30 ctor-ref tuple 0
55a0: 29 29 0a 09 09 09 09 20 20 20 20 28 76 20 28 76 ))..... (v (v
55b0: 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 ector-ref tuple
55c0: 31 29 29 29 0a 09 09 09 09 28 68 61 73 68 2d 74 1))).....(hash-t
55d0: 61 62 6c 65 2d 73 65 74 21 20 67 6c 6f 62 61 6c able-set! global
55e0: 76 61 72 73 2d 62 65 66 6f 72 65 20 6b 20 76 29 vars-before k v)
55f0: 0a 09 09 09 09 28 68 61 73 68 2d 74 61 62 6c 65 .....(hash-table
5600: 2d 73 65 74 21 20 67 6c 6f 62 61 6c 76 61 72 73 -set! globalvars
5610: 20 20 20 20 20 20 20 20 6b 20 76 29 29 29 0a 09 k v)))..
5620: 09 09 20 20 20 20 63 6f 6e 6e 0a 09 09 09 20 20 .. conn....
5630: 20 20 28 73 3a 73 71 6c 70 61 72 61 6d 20 71 75 (s:sqlparam qu
5640: 65 72 79 20 73 65 73 73 69 6f 6e 2d 6b 65 79 20 ery session-key
5650: 22 2a 67 6c 6f 62 61 6c 76 61 72 73 22 29 29 0a "*globalvars")).
5660: 09 20 20 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 . ))))..(define
5670: 20 28 73 65 73 73 69 6f 6e 3a 73 61 76 65 2d 76 (session:save-v
5680: 61 72 73 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 ars self). (let
5690: 20 28 28 73 65 73 73 69 6f 6e 2d 69 64 20 20 28 ((session-id (
56a0: 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e sdat-get-session
56b0: 2d 69 64 20 73 65 6c 66 29 29 29 0a 20 20 20 20 -id self))).
56c0: 28 69 66 20 28 6e 6f 74 20 73 65 73 73 69 6f 6e (if (not session
56d0: 2d 69 64 29 0a 09 28 65 72 72 3a 6c 6f 67 20 22 -id)..(err:log "
56e0: 45 52 52 4f 52 3a 20 4e 6f 20 73 65 73 73 69 6f ERROR: No sessio
56f0: 6e 20 69 64 20 69 6e 20 73 65 73 73 69 6f 6e 20 n id in session
5700: 6f 62 6a 65 63 74 21 20 73 65 73 73 69 6f 6e 3a object! session:
5710: 67 65 74 2d 76 61 72 73 22 29 0a 09 28 6c 65 74 get-vars")..(let
5720: 2a 20 28 28 73 74 61 74 75 73 20 20 20 20 20 20 * ((status
5730: 23 66 29 0a 09 20 20 20 20 20 20 20 28 63 6f 6e #f).. (con
5740: 6e 20 20 20 20 20 20 20 20 28 73 64 61 74 2d 67 n (sdat-g
5750: 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 0a 09 et-conn self))..
5760: 20 20 20 20 20 20 20 28 70 61 67 65 2d 6e 61 6d (page-nam
5770: 65 20 20 20 28 73 64 61 74 2d 67 65 74 2d 70 61 e (sdat-get-pa
5780: 67 65 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 ge self))..
5790: 20 20 28 64 65 6c 2d 71 75 65 72 79 20 20 20 22 (del-query "
57a0: 44 45 4c 45 54 45 20 46 52 4f 4d 20 73 65 73 73 DELETE FROM sess
57b0: 69 6f 6e 5f 76 61 72 73 20 57 48 45 52 45 20 73 ion_vars WHERE s
57c0: 65 73 73 69 6f 6e 5f 69 64 3d 3f 20 41 4e 44 20 ession_id=? AND
57d0: 70 61 67 65 3d 3f 20 41 4e 44 20 6b 65 79 3d 3f page=? AND key=?
57e0: 3b 22 29 0a 09 20 20 20 20 20 20 20 28 69 6e 73 ;").. (ins
57f0: 2d 71 75 65 72 79 20 20 20 22 49 4e 53 45 52 54 -query "INSERT
5800: 20 49 4e 54 4f 20 73 65 73 73 69 6f 6e 5f 76 61 INTO session_va
5810: 72 73 20 28 73 65 73 73 69 6f 6e 5f 69 64 2c 70 rs (session_id,p
5820: 61 67 65 2c 6b 65 79 2c 76 61 6c 75 65 29 20 56 age,key,value) V
5830: 41 4c 55 45 53 28 3f 2c 3f 2c 3f 2c 3f 29 3b 22 ALUES(?,?,?,?);"
5840: 29 0a 09 20 20 20 20 20 20 20 28 75 70 64 2d 71 ).. (upd-q
5850: 75 65 72 79 20 20 20 22 55 50 44 41 54 45 20 73 uery "UPDATE s
5860: 65 73 73 69 6f 6e 5f 76 61 72 73 20 73 65 74 20 ession_vars set
5870: 76 61 6c 75 65 3d 3f 20 57 48 45 52 45 20 6b 65 value=? WHERE ke
5880: 79 3d 3f 20 41 4e 44 20 73 65 73 73 69 6f 6e 5f y=? AND session_
5890: 69 64 3d 3f 20 41 4e 44 20 70 61 67 65 3d 3f 3b id=? AND page=?;
58a0: 22 29 0a 09 20 20 20 20 20 20 20 28 63 68 61 6e ").. (chan
58b0: 67 65 64 2d 63 6f 75 6e 74 20 30 29 29 0a 09 20 ged-count 0))..
58c0: 20 3b 3b 20 73 61 76 65 20 74 68 65 20 64 65 6c ;; save the del
58d0: 74 61 20 6f 6e 6c 79 0a 09 20 20 28 66 6f 72 2d ta only.. (for-
58e0: 65 61 63 68 0a 09 20 20 20 28 6c 61 6d 62 64 61 each.. (lambda
58f0: 20 28 70 61 67 65 29 20 3b 3b 20 70 61 67 65 20 (page) ;; page
5900: 69 73 3a 20 22 2a 67 6c 6f 62 61 6c 76 61 72 73 is: "*globalvars
5910: 2a 22 20 22 2a 73 65 73 73 69 6f 6e 76 61 72 73 *" "*sessionvars
5920: 2a 22 20 6f 72 20 6f 74 68 65 72 73 74 72 69 6e *" or otherstrin
5930: 67 0a 09 20 20 20 20 20 28 6c 65 74 2a 20 28 28 g.. (let* ((
5940: 62 65 66 6f 72 65 2d 61 66 74 65 72 2d 68 74 20 before-after-ht
5950: 28 63 6f 6e 64 0a 09 09 09 09 20 20 20 20 20 20 (cond.....
5960: 28 28 73 74 72 69 6e 67 3d 3f 20 70 61 67 65 20 ((string=? page
5970: 22 2a 73 65 73 73 69 6f 6e 76 61 72 73 2a 22 29 "*sessionvars*")
5980: 0a 09 09 09 09 20 20 20 20 20 20 20 28 76 65 63 ..... (vec
5990: 74 6f 72 20 28 73 64 61 74 2d 67 65 74 2d 73 65 tor (sdat-get-se
59a0: 73 73 69 6f 6e 76 61 72 73 20 73 65 6c 66 29 0a ssionvars self).
59b0: 09 09 09 09 09 20 20 20 20 20 20 20 28 73 64 61 ..... (sda
59c0: 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 t-get-sessionvar
59d0: 73 2d 62 65 66 6f 72 65 20 73 65 6c 66 29 29 29 s-before self)))
59e0: 0a 09 09 09 09 20 20 20 20 20 20 20 28 28 73 74 ..... ((st
59f0: 72 69 6e 67 3d 3f 20 70 61 67 65 20 22 2a 67 6c ring=? page "*gl
5a00: 6f 62 61 6c 76 61 72 73 2a 22 29 0a 09 09 09 09 obalvars*").....
5a10: 09 28 76 65 63 74 6f 72 20 28 73 64 61 74 2d 67 .(vector (sdat-g
5a20: 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 20 73 65 et-globalvars se
5a30: 6c 66 29 0a 09 09 09 09 09 09 28 73 64 61 74 2d lf).......(sdat-
5a40: 67 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 2d 62 get-globalvars-b
5a50: 65 66 6f 72 65 20 73 65 6c 66 29 29 29 0a 09 09 efore self)))...
5a60: 09 09 20 20 20 20 20 20 20 28 65 6c 73 65 20 0a .. (else .
5a70: 09 09 09 09 09 28 76 65 63 74 6f 72 20 28 73 64 .....(vector (sd
5a80: 61 74 2d 67 65 74 2d 70 61 67 65 76 61 72 73 20 at-get-pagevars
5a90: 73 65 6c 66 29 0a 09 09 09 09 09 09 28 73 64 61 self).......(sda
5aa0: 74 2d 67 65 74 2d 70 61 67 65 76 61 72 73 2d 62 t-get-pagevars-b
5ab0: 65 66 6f 72 65 20 73 65 6c 66 29 29 29 29 29 0a efore self))))).
5ac0: 09 09 20 20 20 20 28 6d 61 73 74 65 72 2d 68 74 .. (master-ht
5ad0: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 62 (vector-ref b
5ae0: 65 66 6f 72 65 2d 61 66 74 65 72 2d 68 74 20 30 efore-after-ht 0
5af0: 29 29 0a 09 09 20 20 20 20 28 62 65 66 6f 72 65 ))... (before
5b00: 2d 68 74 20 20 20 28 76 65 63 74 6f 72 2d 72 65 -ht (vector-re
5b10: 66 20 62 65 66 6f 72 65 2d 61 66 74 65 72 2d 68 f before-after-h
5b20: 74 20 31 29 29 0a 09 09 20 20 20 20 28 6d 61 73 t 1))... (mas
5b30: 74 65 72 2d 6b 65 79 73 20 28 68 61 73 68 2d 74 ter-keys (hash-t
5b40: 61 62 6c 65 2d 6b 65 79 73 20 6d 61 73 74 65 72 able-keys master
5b50: 2d 68 74 29 29 0a 09 09 20 20 20 20 28 62 65 66 -ht))... (bef
5b60: 6f 72 65 2d 6b 65 79 73 20 28 68 61 73 68 2d 74 ore-keys (hash-t
5b70: 61 62 6c 65 2d 6b 65 79 73 20 62 65 66 6f 72 65 able-keys before
5b80: 2d 68 74 29 29 0a 09 09 20 20 20 20 28 61 6c 6c -ht))... (all
5b90: 2d 6b 65 79 73 20 28 64 65 6c 65 74 65 2d 64 75 -keys (delete-du
5ba0: 70 6c 69 63 61 74 65 73 20 28 61 70 70 65 6e 64 plicates (append
5bb0: 20 6d 61 73 74 65 72 2d 6b 65 79 73 20 62 65 66 master-keys bef
5bc0: 6f 72 65 2d 6b 65 79 73 29 29 29 29 0a 09 20 20 ore-keys))))..
5bd0: 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a (for-each .
5be0: 09 09 28 6c 61 6d 62 64 61 20 28 6b 65 79 29 0a ..(lambda (key).
5bf0: 09 09 20 20 28 6c 65 74 20 28 28 6d 61 73 74 65 .. (let ((maste
5c00: 72 2d 76 61 6c 75 65 20 28 68 61 73 68 2d 74 61 r-value (hash-ta
5c10: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
5c20: 6d 61 73 74 65 72 2d 68 74 20 6b 65 79 20 23 66 master-ht key #f
5c30: 29 29 0a 09 09 09 28 62 65 66 6f 72 65 2d 76 61 ))....(before-va
5c40: 6c 75 65 20 28 68 61 73 68 2d 74 61 62 6c 65 2d lue (hash-table-
5c50: 72 65 66 2f 64 65 66 61 75 6c 74 20 62 65 66 6f ref/default befo
5c60: 72 65 2d 68 74 20 6b 65 79 20 23 66 29 29 29 0a re-ht key #f))).
5c70: 09 09 20 20 20 20 28 63 6f 6e 64 0a 09 09 20 20 .. (cond...
5c80: 20 20 20 3b 3b 20 62 65 66 6f 72 65 20 61 6e 64 ;; before and
5c90: 20 61 66 74 65 72 20 65 78 69 73 74 20 61 6e 64 after exist and
5ca0: 20 76 61 6c 75 65 20 75 6e 63 68 61 6e 67 65 64 value unchanged
5cb0: 20 2d 20 64 6f 20 6e 6f 74 68 69 6e 67 0a 09 09 - do nothing...
5cc0: 20 20 20 20 20 28 28 61 6e 64 20 6d 61 73 74 65 ((and maste
5cd0: 72 2d 76 61 6c 75 65 20 62 65 66 6f 72 65 2d 76 r-value before-v
5ce0: 61 6c 75 65 20 28 65 71 75 61 6c 3f 20 6d 61 73 alue (equal? mas
5cf0: 74 65 72 2d 76 61 6c 75 65 20 62 65 66 6f 72 65 ter-value before
5d00: 2d 76 61 6c 75 65 29 29 29 0a 09 09 20 20 20 20 -value)))...
5d10: 20 3b 3b 20 62 65 66 6f 72 65 20 61 6e 64 20 61 ;; before and a
5d20: 66 74 65 72 20 65 78 69 73 74 20 62 75 74 20 61 fter exist but a
5d30: 72 65 20 63 68 61 6e 67 65 64 0a 09 09 20 20 20 re changed...
5d40: 20 20 28 28 61 6e 64 20 6d 61 73 74 65 72 2d 76 ((and master-v
5d50: 61 6c 75 65 20 62 65 66 6f 72 65 2d 76 61 6c 75 alue before-valu
5d60: 65 29 0a 09 09 20 20 20 20 20 20 28 64 62 69 3a e)... (dbi:
5d70: 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 for-each-row (la
5d80: 6d 62 64 61 20 28 74 75 70 6c 65 29 0a 09 09 09 mbda (tuple)....
5d90: 09 09 20 20 28 73 65 74 21 20 63 68 61 6e 67 65 .. (set! change
5da0: 64 2d 63 6f 75 6e 74 20 28 2b 20 63 68 61 6e 67 d-count (+ chang
5db0: 65 64 2d 63 6f 75 6e 74 20 31 29 29 29 0a 09 09 ed-count 1)))...
5dc0: 09 09 09 63 6f 6e 6e 0a 09 09 09 09 09 28 73 3a ...conn......(s:
5dd0: 73 71 6c 70 61 72 61 6d 20 75 70 64 2d 71 75 65 sqlparam upd-que
5de0: 72 79 20 6d 61 73 74 65 72 2d 76 61 6c 75 65 20 ry master-value
5df0: 6b 65 79 20 73 65 73 73 69 6f 6e 2d 69 64 20 70 key session-id p
5e00: 61 67 65 29 29 29 0a 09 09 20 20 20 20 20 3b 3b age)))... ;;
5e10: 20 6d 61 73 74 65 72 2d 76 61 6c 75 65 20 6e 6f master-value no
5e20: 20 6c 6f 6e 67 65 72 20 65 78 69 73 74 73 20 28 longer exists (
5e30: 69 2e 65 2e 20 23 66 29 20 2d 20 72 65 6d 6f 76 i.e. #f) - remov
5e40: 65 20 69 74 65 6d 0a 09 09 20 20 20 20 20 28 28 e item... ((
5e50: 6e 6f 74 20 6d 61 73 74 65 72 2d 76 61 6c 75 65 not master-value
5e60: 29 0a 09 09 20 20 20 20 20 20 28 64 62 69 3a 66 )... (dbi:f
5e70: 6f 72 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 6d or-each-row (lam
5e80: 62 64 61 20 28 74 75 70 6c 65 29 0a 09 09 09 09 bda (tuple).....
5e90: 09 20 20 28 73 65 74 21 20 63 68 61 6e 67 65 64 . (set! changed
5ea0: 2d 63 6f 75 6e 74 20 28 2b 20 63 68 61 6e 67 65 -count (+ change
5eb0: 64 2d 63 6f 75 6e 74 20 31 29 29 29 0a 09 09 09 d-count 1)))....
5ec0: 09 09 63 6f 6e 6e 0a 09 09 09 09 09 28 73 3a 73 ..conn......(s:s
5ed0: 71 6c 70 61 72 61 6d 20 64 65 6c 2d 71 75 65 72 qlparam del-quer
5ee0: 79 20 73 65 73 73 69 6f 6e 2d 69 64 20 70 61 67 y session-id pag
5ef0: 65 20 6b 65 79 29 29 29 0a 09 09 20 20 20 20 20 e key)))...
5f00: 3b 3b 20 62 65 66 6f 72 65 2d 76 61 6c 75 65 20 ;; before-value
5f10: 64 6f 65 73 6e 27 74 20 65 78 69 73 74 20 2d 20 doesn't exist -
5f20: 69 6e 73 65 72 74 20 61 20 6e 65 77 20 76 61 6c insert a new val
5f30: 75 65 0a 09 09 20 20 20 20 20 28 28 6e 6f 74 20 ue... ((not
5f40: 62 65 66 6f 72 65 2d 76 61 6c 75 65 29 0a 09 09 before-value)...
5f50: 20 20 20 20 20 20 28 64 62 69 3a 66 6f 72 2d 65 (dbi:for-e
5f60: 61 63 68 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 ach-row (lambda
5f70: 28 74 75 70 6c 65 29 0a 09 09 09 09 09 20 20 28 (tuple)...... (
5f80: 73 65 74 21 20 63 68 61 6e 67 65 64 2d 63 6f 75 set! changed-cou
5f90: 6e 74 20 28 2b 20 63 68 61 6e 67 65 64 2d 63 6f nt (+ changed-co
5fa0: 75 6e 74 20 31 29 29 29 0a 09 09 09 09 09 63 6f unt 1)))......co
5fb0: 6e 6e 0a 09 09 09 09 09 28 73 3a 73 71 6c 70 61 nn......(s:sqlpa
5fc0: 72 61 6d 20 69 6e 73 2d 71 75 65 72 79 20 73 65 ram ins-query se
5fd0: 73 73 69 6f 6e 2d 69 64 20 70 61 67 65 20 6b 65 ssion-id page ke
5fe0: 79 20 6d 61 73 74 65 72 2d 76 61 6c 75 65 29 29 y master-value))
5ff0: 29 0a 09 09 20 20 20 20 20 28 65 6c 73 65 20 28 )... (else (
6000: 65 72 72 3a 6c 6f 67 20 22 53 68 6f 75 6c 64 6e err:log "Shouldn
6010: 27 74 20 67 65 74 20 68 65 72 65 22 29 29 29 29 't get here"))))
6020: 29 0a 09 09 61 6c 6c 2d 6b 65 79 73 29 29 29 20 )...all-keys)))
6030: 3b 3b 20 70 72 6f 63 65 73 73 20 61 6c 6c 20 6b ;; process all k
6040: 65 79 73 0a 09 20 20 20 28 6c 69 73 74 20 22 2a eys.. (list "*
6050: 73 65 73 73 69 6f 6e 76 61 72 73 2a 22 20 22 2a sessionvars*" "*
6060: 67 6c 6f 62 61 6c 76 61 72 73 2a 22 20 70 61 67 globalvars*" pag
6070: 65 2d 6e 61 6d 65 29 29 29 29 29 29 0a 0a 3b 3b e-name))))))..;;
6080: 20 28 70 67 3a 73 71 6c 2d 6e 75 6c 6c 2d 6f 62 (pg:sql-null-ob
6090: 6a 65 63 74 3f 20 65 6c 65 6d 65 6e 74 29 0a 28 ject? element).(
60a0: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
60b0: 72 65 61 64 2d 63 6f 6e 66 69 67 20 73 65 6c 66 read-config self
60c0: 29 0a 20 20 28 6c 65 74 20 28 28 6e 61 6d 65 20 ). (let ((name
60d0: 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 22 (string-append "
60e0: 2e 22 20 28 70 61 74 68 6e 61 6d 65 2d 66 69 6c ." (pathname-fil
60f0: 65 20 28 63 61 72 20 28 61 72 67 76 29 29 29 20 e (car (argv)))
6100: 22 2e 63 6f 6e 66 69 67 22 29 29 29 0a 20 20 20 ".config"))).
6110: 20 28 69 66 20 28 6e 6f 74 20 28 66 69 6c 65 2d (if (not (file-
6120: 65 78 69 73 74 73 3f 20 6e 61 6d 65 29 29 0a 09 exists? name))..
6130: 28 70 72 69 6e 74 20 6e 61 6d 65 20 22 20 6e 6f (print name " no
6140: 74 20 66 6f 75 6e 64 20 61 74 20 22 20 28 63 75 t found at " (cu
6150: 72 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 79 29 rrent-directory)
6160: 29 0a 09 28 6c 65 74 2a 20 28 28 66 70 20 28 6f )..(let* ((fp (o
6170: 70 65 6e 2d 69 6e 70 75 74 2d 66 69 6c 65 20 6e pen-input-file n
6180: 61 6d 65 29 29 0a 09 20 20 20 20 20 20 20 28 69 ame)).. (i
6190: 6e 69 74 61 72 67 73 20 28 72 65 61 64 20 66 70 nitargs (read fp
61a0: 29 29 29 0a 09 20 20 28 63 6c 6f 73 65 2d 69 6e ))).. (close-in
61b0: 70 75 74 2d 70 6f 72 74 20 66 70 29 0a 09 20 20 put-port fp)..
61c0: 69 6e 69 74 61 72 67 73 29 29 29 29 0a 0a 3b 3b initargs))))..;;
61d0: 20 63 61 6c 6c 20 74 68 65 20 63 6f 6e 74 72 6f call the contro
61e0: 6c 6c 65 72 20 69 66 20 69 74 20 65 78 69 73 74 ller if it exist
61f0: 73 0a 3b 3b 20 0a 3b 3b 20 57 41 52 4e 49 4e 47 s.;; .;; WARNING
6200: 20 2d 20 74 68 69 73 20 63 6f 64 65 20 6e 65 65 - this code nee
6210: 64 73 20 61 20 64 65 66 65 6e 63 65 20 61 67 61 ds a defence aga
6220: 69 6e 73 20 72 65 63 75 72 73 69 76 65 20 63 61 ins recursive ca
6230: 6c 6c 69 6e 67 21 21 21 21 21 0a 3b 3b 0a 3b 3b lling!!!!!.;;.;;
6240: 20 20 20 49 20 73 75 67 67 65 73 74 20 61 20 6c I suggest a l
6250: 69 6d 69 74 20 6f 66 20 31 30 30 20 63 61 6c 6c imit of 100 call
6260: 73 2e 20 50 6c 65 6e 74 79 20 66 6f 72 20 61 6c s. Plenty for al
6270: 6c 6f 77 69 6e 67 20 6d 75 6c 74 69 70 6c 65 20 lowing multiple
6280: 69 6e 73 74 61 6e 63 65 73 0a 3b 3b 20 20 20 6f instances.;; o
6290: 66 20 61 20 70 61 67 65 20 69 6e 73 69 64 65 20 f a page inside
62a0: 61 6e 6f 74 68 65 72 20 70 61 67 65 2e 20 0a 3b another page. .;
62b0: 3b 0a 3b 3b 20 70 61 72 74 73 20 3d 20 27 62 6f ;.;; parts = 'bo
62c0: 74 68 20 7c 20 27 63 6f 6e 74 72 6f 6c 20 7c 20 th | 'control |
62d0: 27 76 69 65 77 0a 3b 3b 0a 0a 28 64 65 66 69 6e 'view.;;..(defin
62e0: 65 20 28 66 69 6c 65 73 2d 72 65 61 64 2d 3e 73 e (files-read->s
62f0: 74 72 69 6e 67 20 2e 20 66 69 6c 65 73 29 0a 20 tring . files).
6300: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
6310: 65 72 73 65 20 0a 20 20 20 28 61 70 70 6c 79 20 erse . (apply
6320: 61 70 70 65 6e 64 20 28 6d 61 70 20 66 69 6c 65 append (map file
6330: 2d 72 65 61 64 2d 3e 73 74 72 69 6e 67 20 66 69 -read->string fi
6340: 6c 65 73 29 29 20 22 5c 6e 22 29 29 0a 0a 28 64 les)) "\n"))..(d
6350: 65 66 69 6e 65 20 28 66 69 6c 65 2d 72 65 61 64 efine (file-read
6360: 2d 3e 73 74 72 69 6e 67 20 66 29 20 0a 20 20 28 ->string f) . (
6370: 6c 65 74 20 28 28 70 20 28 6f 70 65 6e 2d 69 6e let ((p (open-in
6380: 70 75 74 2d 66 69 6c 65 20 66 29 29 29 0a 20 20 put-file f))).
6390: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 (let loop ((he
63a0: 64 20 28 72 65 61 64 2d 6c 69 6e 65 20 70 29 29 d (read-line p))
63b0: 0a 09 20 20 20 20 20 20 20 28 72 65 73 20 27 28 .. (res '(
63c0: 29 29 29 0a 20 20 20 20 20 20 28 69 66 20 28 65 ))). (if (e
63d0: 6f 66 2d 6f 62 6a 65 63 74 3f 20 68 65 64 29 0a of-object? hed).
63e0: 09 20 20 72 65 73 0a 09 20 20 28 6c 6f 6f 70 20 . res.. (loop
63f0: 28 72 65 61 64 2d 6c 69 6e 65 20 70 29 28 61 70 (read-line p)(ap
6400: 70 65 6e 64 20 72 65 73 20 28 6c 69 73 74 20 68 pend res (list h
6410: 65 64 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 ed)))))))..(defi
6420: 6e 65 20 28 70 72 6f 63 65 73 73 2d 70 6f 72 74 ne (process-port
6430: 20 70 29 0a 20 20 28 6c 65 74 20 28 28 65 20 28 p). (let ((e (
6440: 69 6e 74 65 72 61 63 74 69 6f 6e 2d 65 6e 76 69 interaction-envi
6450: 72 6f 6e 6d 65 6e 74 29 29 29 0a 20 20 20 20 28 ronment))). (
6460: 6d 61 70 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 map . (lambd
6470: 61 20 28 78 29 0a 20 20 20 20 20 20 20 28 63 6f a (x). (co
6480: 6e 64 0a 09 28 28 6c 69 73 74 3f 20 78 29 20 78 nd..((list? x) x
6490: 29 0a 09 28 28 73 74 72 69 6e 67 3f 20 78 29 20 )..((string? x)
64a0: 78 29 0a 09 28 65 6c 73 65 20 27 28 29 29 29 29 x)..(else '())))
64b0: 0a 20 20 20 20 20 28 70 6f 72 74 2d 6d 61 70 20 . (port-map
64c0: 28 6c 61 6d 62 64 61 20 28 73 29 0a 09 09 20 28 (lambda (s)... (
64d0: 65 76 61 6c 20 73 20 65 29 29 0a 09 20 20 20 20 eval s e))..
64e0: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 28 72 65 (lambda ()(re
64f0: 61 64 20 70 29 29 29 29 29 29 0a 0a 28 64 65 66 ad p))))))..(def
6500: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 70 72 6f ine (session:pro
6510: 63 65 73 73 2d 66 69 6c 65 20 66 29 0a 20 20 28 cess-file f). (
6520: 6c 65 74 2a 20 28 28 70 20 20 20 20 28 6f 70 65 let* ((p (ope
6530: 6e 2d 69 6e 70 75 74 2d 66 69 6c 65 20 66 29 29 n-input-file f))
6540: 0a 09 20 28 64 61 74 20 20 28 70 72 6f 63 65 73 .. (dat (proces
6550: 73 2d 70 6f 72 74 20 70 29 29 29 0a 20 20 20 20 s-port p))).
6560: 28 63 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 6f 72 (close-input-por
6570: 74 20 70 29 0a 20 20 20 20 64 61 74 29 29 0a 0a t p). dat))..
6580: 3b 3b 20 4d 61 79 20 32 30 31 31 2c 20 70 75 74 ;; May 2011, put
6590: 74 69 6e 67 20 61 6c 6c 20 70 61 67 65 73 20 69 ting all pages i
65a0: 6e 74 6f 20 6f 6e 65 20 64 69 72 65 63 74 6f 72 nto one director
65b0: 79 20 66 6f 72 20 74 68 65 20 66 6f 6c 6c 6f 77 y for the follow
65c0: 69 6e 67 20 72 65 61 73 6f 6e 73 3a 0a 3b 3b 20 ing reasons:.;;
65d0: 20 20 31 2e 20 77 61 6e 74 20 66 69 6c 65 6e 61 1. want filena
65e0: 6d 65 20 74 6f 20 72 65 66 6c 65 63 74 20 70 61 me to reflect pa
65f0: 67 65 20 6e 61 6d 65 20 28 65 6d 61 63 73 20 6c ge name (emacs l
6600: 69 6d 69 74 61 74 69 6f 6e 29 0a 3b 3b 20 20 20 imitation).;;
6610: 32 2e 20 74 68 61 74 27 73 20 69 74 21 20 6e 6f 2. that's it! no
6620: 20 6f 74 68 65 72 20 72 65 61 73 6f 6e 2e 20 63 other reason. c
6630: 6f 75 6c 64 20 6d 61 6b 65 20 69 74 20 63 6f 6e ould make it con
6640: 66 69 67 75 72 61 62 6c 65 20 2e 2e 2e 0a 3b 3b figurable ....;;
6650: 20 70 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 20 page-dir-style
6660: 69 73 3a 0a 3b 3b 20 20 27 73 74 6f 72 65 64 20 is:.;; 'stored
6670: 20 20 3d 3e 20 73 74 6f 72 65 64 20 69 6e 20 65 => stored in e
6680: 78 65 63 75 74 61 62 6c 65 0a 3b 3b 20 20 27 66 xecutable.;; 'f
6690: 6c 61 74 20 20 20 20 20 3d 3e 20 70 61 67 65 73 lat => pages
66a0: 20 66 6c 61 74 20 64 69 72 65 63 74 6f 72 79 0a flat directory.
66b0: 3b 3b 20 20 27 64 69 72 20 20 20 20 20 20 3d 3e ;; 'dir =>
66c0: 20 64 69 72 65 63 74 6f 72 79 20 74 72 65 65 20 directory tree
66d0: 70 61 67 65 73 2f 3c 70 61 67 65 6e 61 6d 65 3e pages/<pagename>
66e0: 2f 7b 76 69 65 77 2c 63 6f 6e 74 72 6f 6c 7d 2e /{view,control}.
66f0: 73 63 6d 0a 3b 3b 20 70 61 72 74 73 3a 0a 3b 3b scm.;; parts:.;;
6700: 20 20 27 62 6f 74 68 20 20 20 20 20 3d 3e 20 6c 'both => l
6710: 6f 61 64 20 63 6f 6e 74 72 6f 6c 20 61 6e 64 20 oad control and
6720: 76 69 65 77 20 28 61 6e 79 74 68 69 6e 67 20 6f view (anything o
6730: 74 68 65 72 20 74 68 61 6e 20 76 69 65 77 20 6f ther than view o
6740: 72 20 63 6f 6e 74 72 6f 6c 0a 3b 3b 20 20 27 76 r control.;; 'v
6750: 69 65 77 20 20 20 20 20 3d 3e 20 6c 6f 61 64 20 iew => load
6760: 76 69 65 77 20 6f 6e 6c 79 0a 3b 3b 20 20 27 63 view only.;; 'c
6770: 6f 6e 74 72 6f 6c 20 20 3d 3e 20 6c 6f 61 64 20 ontrol => load
6780: 63 6f 6e 74 72 6f 6c 20 6f 6e 6c 79 0a 28 64 65 control only.(de
6790: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 63 61 fine (session:ca
67a0: 6c 6c 2d 70 61 72 74 73 20 73 65 6c 66 20 70 61 ll-parts self pa
67b0: 67 65 20 23 21 6b 65 79 20 28 70 61 72 74 73 20 ge #!key (parts
67c0: 27 62 6f 74 68 29 29 0a 20 20 28 73 64 61 74 2d 'both)). (sdat-
67d0: 73 65 74 2d 63 75 72 72 2d 70 61 67 65 21 20 73 set-curr-page! s
67e0: 65 6c 66 20 70 61 67 65 29 0a 20 20 28 73 65 73 elf page). (ses
67f0: 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 70 sion:log self "p
6800: 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 3a 20 22 age-dir-style: "
6810: 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 2d (sdat-get-page-
6820: 64 69 72 2d 73 74 79 6c 65 20 73 65 6c 66 29 29 dir-style self))
6830: 0a 20 20 28 6c 65 74 2a 20 28 28 64 69 72 2d 73 . (let* ((dir-s
6840: 74 79 6c 65 20 20 20 20 28 73 64 61 74 2d 67 65 tyle (sdat-ge
6850: 74 2d 70 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 t-page-dir-style
6860: 20 73 65 6c 66 29 29 3b 3b 20 28 65 71 75 61 6c self));; (equal
6870: 3f 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 ? (sdat-get-page
6880: 2d 64 69 72 2d 73 74 79 6c 65 20 73 65 6c 66 29 -dir-style self)
6890: 20 22 6f 6e 65 64 69 72 22 29 29 20 3b 3b 20 66 "onedir")) ;; f
68a0: 6c 61 67 20 23 74 20 66 6f 72 20 6f 6e 65 64 69 lag #t for onedi
68b0: 72 2c 20 23 66 20 66 6f 72 20 6f 6c 64 20 73 74 r, #f for old st
68c0: 79 6c 65 0a 09 20 28 64 69 72 20 20 20 20 20 20 yle.. (dir
68d0: 20 20 20 20 28 73 74 72 69 6e 67 2d 61 70 70 65 (string-appe
68e0: 6e 64 20 28 73 64 61 74 2d 67 65 74 2d 73 72 6f nd (sdat-get-sro
68f0: 6f 74 20 73 65 6c 66 29 20 0a 09 09 09 09 20 20 ot self) .....
6900: 20 20 20 20 28 69 66 20 64 69 72 2d 73 74 79 6c (if dir-styl
6910: 65 20 0a 09 09 09 09 09 20 20 28 63 6f 6e 63 20 e ...... (conc
6920: 22 2f 70 61 67 65 73 2f 22 29 0a 09 09 09 09 09 "/pages/")......
6930: 20 20 28 63 6f 6e 63 20 22 2f 70 61 67 65 73 2f (conc "/pages/
6940: 22 20 70 61 67 65 29 29 29 29 29 0a 20 20 20 20 " page))))).
6950: 28 63 61 73 65 20 64 69 72 2d 73 74 79 6c 65 0a (case dir-style.
6960: 20 20 20 20 20 20 3b 3b 20 4e 42 2f 2f 20 53 74 ;; NB// St
6970: 6f 72 65 64 20 61 6c 77 61 79 73 20 6c 6f 61 64 ored always load
6980: 73 20 62 6f 74 68 20 63 6f 6e 74 72 6f 6c 20 61 s both control a
6990: 6e 64 20 76 69 65 77 0a 20 20 20 20 20 20 28 28 nd view. ((
69a0: 73 74 6f 72 65 64 29 0a 20 20 20 20 20 20 20 28 stored). (
69b0: 28 65 76 61 6c 20 28 73 74 72 69 6e 67 2d 3e 73 (eval (string->s
69c0: 79 6d 62 6f 6c 20 28 63 6f 6e 63 20 22 70 61 67 ymbol (conc "pag
69d0: 65 73 3a 22 20 70 61 67 65 29 29 29 20 0a 09 73 es:" page))) ..s
69e0: 65 6c 66 20 20 20 20 20 20 20 20 20 20 20 20 20 elf
69f0: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 74 ;; t
6a00: 68 65 20 73 65 73 73 69 6f 6e 0a 09 28 73 64 61 he session..(sda
6a10: 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 t-get-conn self)
6a20: 20 20 20 20 20 20 20 20 20 3b 3b 20 74 68 65 20 ;; the
6a30: 64 62 20 63 6f 6e 6e 65 63 74 69 6f 6e 0a 09 28 db connection..(
6a40: 73 64 61 74 2d 67 65 74 2d 73 68 61 72 65 64 2d sdat-get-shared-
6a50: 68 61 73 68 20 73 65 6c 66 29 20 20 3b 3b 20 61 hash self) ;; a
6a60: 20 73 68 61 72 65 64 20 68 61 73 68 20 74 61 62 shared hash tab
6a70: 6c 65 20 66 6f 72 20 70 61 73 73 69 6e 67 20 64 le for passing d
6a80: 61 74 61 20 74 6f 2f 66 72 6f 6d 20 70 61 67 65 ata to/from page
6a90: 20 63 61 6c 6c 73 0a 09 29 29 0a 20 20 20 20 20 calls..)).
6aa0: 20 28 28 66 6c 61 74 29 20 20 20 0a 20 20 20 20 ((flat) .
6ab0: 20 20 20 28 6c 6f 61 64 20 28 63 6f 6e 63 20 64 (load (conc d
6ac0: 69 72 20 70 61 67 65 20 22 2e 73 6f 22 29 29 0a ir page ".so")).
6ad0: 20 20 20 20 20 20 20 20 28 28 65 76 61 6c 20 28 ((eval (
6ae0: 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 string->symbol (
6af0: 63 6f 6e 63 20 22 70 61 67 65 73 3a 22 20 70 61 conc "pages:" pa
6b00: 67 65 29 29 29 20 0a 09 73 65 6c 66 20 20 20 20 ge))) ..self
6b10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6b20: 20 20 20 20 20 3b 3b 20 74 68 65 20 73 65 73 73 ;; the sess
6b30: 69 6f 6e 0a 09 28 73 64 61 74 2d 67 65 74 2d 63 ion..(sdat-get-c
6b40: 6f 6e 6e 20 73 65 6c 66 29 20 20 20 20 20 20 20 onn self)
6b50: 20 20 3b 3b 20 74 68 65 20 64 62 20 63 6f 6e 6e ;; the db conn
6b60: 65 63 74 69 6f 6e 0a 09 28 73 64 61 74 2d 67 65 ection..(sdat-ge
6b70: 74 2d 73 68 61 72 65 64 2d 68 61 73 68 20 73 65 t-shared-hash se
6b80: 6c 66 29 20 20 3b 3b 20 61 20 73 68 61 72 65 64 lf) ;; a shared
6b90: 20 68 61 73 68 20 74 61 62 6c 65 20 66 6f 72 20 hash table for
6ba0: 70 61 73 73 69 6e 67 20 64 61 74 61 20 74 6f 2f passing data to/
6bb0: 66 72 6f 6d 20 70 61 67 65 20 63 61 6c 6c 73 0a from page calls.
6bc0: 09 29 29 0a 20 20 20 20 20 20 20 3b 3b 20 66 69 .)). ;; fi
6bd0: 72 73 74 20 74 68 65 20 63 6f 6e 74 72 6f 6c 0a rst the control.
6be0: 20 20 20 20 20 20 20 3b 3b 20 28 6c 65 74 20 28 ;; (let (
6bf0: 28 63 6f 6e 74 72 6f 6c 2d 66 69 6c 65 20 28 63 (control-file (c
6c00: 6f 6e 63 20 22 70 61 67 65 73 2f 22 20 70 61 67 onc "pages/" pag
6c10: 65 20 22 5f 63 74 72 6c 2e 73 63 6d 22 29 29 0a e "_ctrl.scm")).
6c20: 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 ;;
6c30: 28 76 69 65 77 2d 66 69 6c 65 20 20 20 20 28 63 (view-file (c
6c40: 6f 6e 63 20 22 70 61 67 65 73 2f 22 20 70 61 67 onc "pages/" pag
6c50: 65 20 22 5f 76 69 65 77 2e 73 63 6d 22 29 29 29 e "_view.scm")))
6c60: 0a 20 20 20 20 20 20 20 3b 3b 20 20 20 28 69 66 . ;; (if
6c70: 20 28 61 6e 64 20 28 66 69 6c 65 2d 65 78 69 73 (and (file-exis
6c80: 74 73 3f 20 63 6f 6e 74 72 6f 6c 2d 66 69 6c 65 ts? control-file
6c90: 29 0a 20 20 20 20 20 20 20 3b 3b 20 20 09 20 20 ). ;; .
6ca0: 28 6e 6f 74 20 28 65 71 3f 20 70 61 72 74 73 20 (not (eq? parts
6cb0: 27 76 69 65 77 29 29 29 0a 20 20 20 20 20 20 20 'view))).
6cc0: 3b 3b 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a ;; (begin.
6cd0: 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 ;;
6ce0: 20 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 2d 63 (session:set-c
6cf0: 61 6c 6c 65 64 21 20 73 65 6c 66 20 70 61 67 65 alled! self page
6d00: 29 0a 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 ). ;;
6d10: 20 20 20 20 28 6c 6f 61 64 20 63 6f 6e 74 72 6f (load contro
6d20: 6c 2d 66 69 6c 65 29 29 29 0a 20 20 20 20 20 20 l-file))).
6d30: 20 3b 3b 20 20 20 28 69 66 20 28 66 69 6c 65 2d ;; (if (file-
6d40: 65 78 69 73 74 73 3f 20 76 69 65 77 2d 66 69 6c exists? view-fil
6d50: 65 29 0a 20 20 20 20 20 20 20 3b 3b 20 20 20 20 e). ;;
6d60: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 3f (if (not (eq?
6d70: 20 70 61 72 74 73 20 27 63 6f 6e 74 72 6f 6c 29 parts 'control)
6d80: 29 0a 20 20 20 20 20 20 20 3b 3b 20 20 09 20 28 ). ;; . (
6d90: 73 65 73 73 69 6f 6e 3a 70 72 6f 63 65 73 73 2d session:process-
6da0: 66 69 6c 65 20 76 69 65 77 2d 66 69 6c 65 29 29 file view-file))
6db0: 0a 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 . ;;
6dc0: 20 28 6c 69 73 74 20 22 3c 70 3e 50 61 67 65 20 (list "<p>Page
6dd0: 6e 6f 74 20 66 6f 75 6e 64 20 22 20 70 61 67 65 not found " page
6de0: 20 22 20 3c 2f 70 3e 22 29 29 29 0a 20 20 20 20 " </p>"))).
6df0: 20 20 28 28 64 69 72 29 20 22 45 52 52 4f 52 3a ((dir) "ERROR:
6e00: 20 20 64 69 72 20 73 74 79 6c 65 20 6e 6f 74 20 dir style not
6e10: 79 65 74 20 72 65 2d 69 6d 70 6c 65 6d 65 6e 74 yet re-implement
6e20: 65 64 22 29 0a 20 20 20 20 20 20 28 65 6c 73 65 ed"). (else
6e30: 0a 20 20 20 20 20 20 20 28 6c 69 73 74 20 22 45 . (list "E
6e40: 52 52 4f 52 3a 20 70 61 67 65 2d 64 69 72 2d 73 RROR: page-dir-s
6e50: 74 79 6c 65 20 6d 75 73 74 20 62 65 20 73 74 6f tyle must be sto
6e60: 72 65 64 2c 20 64 69 72 20 6f 72 20 66 6c 61 74 red, dir or flat
6e70: 2c 20 67 6f 74 20 22 20 64 69 72 2d 73 74 79 6c , got " dir-styl
6e80: 65 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 e)))))..(define
6e90: 28 73 65 73 73 69 6f 6e 3a 63 61 6c 6c 20 73 65 (session:call se
6ea0: 6c 66 20 70 61 67 65 20 70 61 72 74 73 29 0a 20 lf page parts).
6eb0: 20 28 73 65 73 73 69 6f 6e 3a 63 61 6c 6c 2d 70 (session:call-p
6ec0: 61 72 74 73 20 73 65 6c 66 20 70 61 67 65 20 27 arts self page '
6ed0: 62 6f 74 68 29 29 0a 0a 3b 3b 20 28 64 65 66 69 both))..;; (defi
6ee0: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 61 64 ne (session:load
6ef0: 2d 6d 6f 64 65 6c 20 73 65 6c 66 20 6d 6f 64 65 -model self mode
6f00: 6c 29 0a 3b 3b 20 20 20 28 6c 65 74 20 28 28 6d l).;; (let ((m
6f10: 6f 64 65 6c 2e 73 63 6d 20 28 73 74 72 69 6e 67 odel.scm (string
6f20: 2d 61 70 70 65 6e 64 20 28 73 64 61 74 2d 67 65 -append (sdat-ge
6f30: 74 2d 73 72 6f 6f 74 20 73 65 6c 66 29 20 22 2f t-sroot self) "/
6f40: 6d 6f 64 65 6c 73 2f 22 20 6d 6f 64 65 6c 20 22 models/" model "
6f50: 2e 73 63 6d 22 29 29 0a 3b 3b 20 09 28 6d 6f 64 .scm")).;; .(mod
6f60: 65 6c 2e 73 6f 20 20 28 73 74 72 69 6e 67 2d 61 el.so (string-a
6f70: 70 70 65 6e 64 20 28 73 64 61 74 2d 67 65 74 2d ppend (sdat-get-
6f80: 73 72 6f 6f 74 20 73 65 6c 66 29 20 22 2f 6d 6f sroot self) "/mo
6f90: 64 65 6c 73 2f 22 20 6d 6f 64 65 6c 20 22 2e 73 dels/" model ".s
6fa0: 6f 22 29 29 29 0a 3b 3b 20 20 20 20 20 28 69 66 o"))).;; (if
6fb0: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 6d (file-exists? m
6fc0: 6f 64 65 6c 2e 73 6f 29 0a 3b 3b 20 09 28 6c 6f odel.so).;; .(lo
6fd0: 61 64 20 6d 6f 64 65 6c 2e 73 6f 29 0a 3b 3b 20 ad model.so).;;
6fe0: 09 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 .(if (file-exist
6ff0: 73 3f 20 6d 6f 64 65 6c 2e 73 63 6d 29 0a 3b 3b s? model.scm).;;
7000: 20 09 20 20 20 20 28 6c 6f 61 64 20 6d 6f 64 65 . (load mode
7010: 6c 2e 73 63 6d 29 0a 3b 3b 20 09 20 20 20 20 28 l.scm).;; . (
7020: 73 3a 6c 6f 67 20 22 45 52 52 4f 52 3a 20 6d 6f s:log "ERROR: mo
7030: 64 65 6c 20 22 20 6d 6f 64 65 6c 2e 73 63 6d 20 del " model.scm
7040: 22 20 6e 6f 74 20 66 6f 75 6e 64 22 29 29 29 29 " not found"))))
7050: 29 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 )..;; (define (s
7060: 65 73 73 69 6f 6e 3a 6d 6f 64 65 6c 2d 70 61 74 ession:model-pat
7070: 68 20 73 65 6c 66 20 6d 6f 64 65 6c 29 0a 3b 3b h self model).;;
7080: 20 20 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e (string-appen
7090: 64 20 28 73 64 61 74 2d 67 65 74 2d 73 72 6f 6f d (sdat-get-sroo
70a0: 74 20 73 65 6c 66 29 20 22 2f 6d 6f 64 65 6c 73 t self) "/models
70b0: 2f 22 20 6d 6f 64 65 6c 20 22 2e 73 63 6d 22 29 /" model ".scm")
70c0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 )..(define (sess
70d0: 69 6f 6e 3a 70 70 2d 66 6f 72 6d 64 61 74 20 73 ion:pp-formdat s
70e0: 65 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 64 61 elf). (let ((da
70f0: 74 20 28 66 6f 72 6d 64 61 74 3a 61 6c 6c 2d 3e t (formdat:all->
7100: 73 74 72 69 6e 67 73 20 28 73 64 61 74 2d 67 65 strings (sdat-ge
7110: 74 2d 66 6f 72 6d 64 61 74 20 73 65 6c 66 29 29 t-formdat self))
7120: 29 29 0a 20 20 20 20 28 73 74 72 69 6e 67 2d 69 )). (string-i
7130: 6e 74 65 72 73 70 65 72 73 65 20 64 61 74 20 22 ntersperse dat "
7140: 3c 62 72 3e 20 22 29 29 29 0a 0a 28 64 65 66 69 <br> ")))..(defi
7150: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 70 61 72 61 ne (session:para
7160: 6d 2d 3e 73 74 72 69 6e 67 20 70 61 72 61 6d 73 m->string params
7170: 29 0a 20 20 3b 3b 20 28 65 72 72 3a 6c 6f 67 20 ). ;; (err:log
7180: 22 70 61 72 61 6d 73 3d 22 20 70 61 72 61 6d 73 "params=" params
7190: 29 0a 20 20 28 69 66 20 28 3c 20 28 6c 65 6e 67 ). (if (< (leng
71a0: 74 68 20 70 61 72 61 6d 73 29 20 31 29 0a 20 20 th params) 1).
71b0: 20 20 20 20 22 22 0a 20 20 20 20 20 20 28 6c 65 "". (le
71c0: 74 20 6c 6f 6f 70 20 28 28 6b 65 79 20 28 63 61 t loop ((key (ca
71d0: 72 20 70 61 72 61 6d 73 29 29 0a 09 09 20 28 76 r params))... (v
71e0: 61 6c 20 28 63 61 64 72 20 70 61 72 61 6d 73 29 al (cadr params)
71f0: 29 0a 09 09 20 28 74 61 69 6c 20 28 63 64 64 72 )... (tail (cddr
7200: 20 70 61 72 61 6d 73 29 29 0a 09 09 20 28 72 65 params))... (re
7210: 73 75 6c 74 20 27 28 29 29 29 0a 09 28 6c 65 74 sult '()))..(let
7220: 20 28 28 6e 65 77 72 65 73 75 6c 74 20 28 63 6f ((newresult (co
7230: 6e 73 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e ns (string-appen
7240: 64 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 d (s:any->string
7250: 20 6b 65 79 29 20 22 3d 22 20 28 73 3a 61 6e 79 key) "=" (s:any
7260: 2d 3e 73 74 72 69 6e 67 20 76 61 6c 29 29 0a 09 ->string val))..
7270: 09 09 20 20 20 20 20 20 20 72 65 73 75 6c 74 29 .. result)
7280: 29 29 0a 09 20 20 28 69 66 20 28 3c 20 28 6c 65 )).. (if (< (le
7290: 6e 67 74 68 20 74 61 69 6c 29 20 31 29 20 3b 3b ngth tail) 1) ;;
72a0: 20 74 72 75 65 20 69 66 20 64 6f 6e 65 0a 09 20 true if done..
72b0: 20 20 20 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 (string-int
72c0: 65 72 73 70 65 72 73 65 20 6e 65 77 72 65 73 75 ersperse newresu
72d0: 6c 74 20 22 26 22 29 0a 09 20 20 20 20 20 20 28 lt "&").. (
72e0: 6c 6f 6f 70 20 28 63 61 72 20 74 61 69 6c 29 28 loop (car tail)(
72f0: 63 61 64 72 20 74 61 69 6c 29 28 63 64 64 72 20 cadr tail)(cddr
7300: 74 61 69 6c 29 20 6e 65 77 72 65 73 75 6c 74 29 tail) newresult)
7310: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define (
7320: 73 65 73 73 69 6f 6e 3a 6c 69 6e 6b 2d 74 6f 20 session:link-to
7330: 73 65 6c 66 20 70 61 67 65 20 70 61 72 61 6d 73 self page params
7340: 29 0a 20 20 28 6c 65 74 2a 20 28 28 73 65 72 76 ). (let* ((serv
7350: 65 72 20 20 20 20 28 69 66 20 28 67 65 74 2d 65 er (if (get-e
7360: 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 nvironment-varia
7370: 62 6c 65 20 22 48 54 54 50 5f 48 4f 53 54 22 29 ble "HTTP_HOST")
7380: 0a 09 09 09 28 67 65 74 2d 65 6e 76 69 72 6f 6e ....(get-environ
7390: 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 48 ment-variable "H
73a0: 54 54 50 5f 48 4f 53 54 22 29 0a 09 09 09 28 67 TTP_HOST")....(g
73b0: 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 et-environment-v
73c0: 61 72 69 61 62 6c 65 20 22 53 45 52 56 45 52 5f ariable "SERVER_
73d0: 4e 41 4d 45 22 29 29 29 0a 09 20 28 73 63 72 69 NAME"))).. (scri
73e0: 70 74 20 28 6c 65 74 20 28 28 73 63 72 69 70 74 pt (let ((script
73f0: 2d 6e 61 6d 65 20 28 73 74 72 69 6e 67 2d 73 70 -name (string-sp
7400: 6c 69 74 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e lit (get-environ
7410: 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 53 ment-variable "S
7420: 43 52 49 50 54 5f 4e 41 4d 45 22 29 20 22 2f 22 CRIPT_NAME") "/"
7430: 29 29 29 0a 09 09 20 20 20 28 69 66 20 28 3e 20 )))... (if (>
7440: 28 6c 65 6e 67 74 68 20 73 63 72 69 70 74 2d 6e (length script-n
7450: 61 6d 65 29 20 31 29 0a 09 09 20 20 20 20 20 20 ame) 1)...
7460: 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 (string-append
7470: 28 63 61 72 20 73 63 72 69 70 74 2d 6e 61 6d 65 (car script-name
7480: 29 20 22 2f 22 20 28 63 61 64 72 20 73 63 72 69 ) "/" (cadr scri
7490: 70 74 2d 6e 61 6d 65 29 29 0a 09 09 20 20 20 20 pt-name))...
74a0: 20 20 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d (get-environm
74b0: 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 53 43 ent-variable "SC
74c0: 52 49 50 54 5f 4e 41 4d 45 22 29 29 29 29 20 3b RIPT_NAME")))) ;
74d0: 3b 20 62 75 69 6c 64 20 73 63 72 69 70 74 20 6e ; build script n
74e0: 61 6d 65 20 66 72 6f 6d 20 66 69 72 73 74 20 74 ame from first t
74f0: 77 6f 20 65 6c 65 6d 65 6e 74 73 2e 20 54 68 69 wo elements. Thi
7500: 73 20 69 73 20 61 20 68 61 6e 67 6f 76 65 72 20 s is a hangover
7510: 66 72 6f 6d 20 62 65 66 6f 72 65 20 49 20 75 73 from before I us
7520: 65 64 20 3f 20 69 6e 20 74 68 65 20 55 52 4c 2e ed ? in the URL.
7530: 0a 09 20 28 73 65 73 73 69 6f 6e 2d 6b 65 79 20 .. (session-key
7540: 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f (sdat-get-sessio
7550: 6e 2d 6b 65 79 20 73 65 6c 66 29 29 0a 09 20 28 n-key self)).. (
7560: 70 61 72 61 6d 73 74 72 20 28 73 65 73 73 69 6f paramstr (sessio
7570: 6e 3a 70 61 72 61 6d 2d 3e 73 74 72 69 6e 67 20 n:param->string
7580: 70 61 72 61 6d 73 29 29 29 0a 20 20 20 20 3b 3b params))). ;;
7590: 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 (session:log se
75a0: 6c 66 20 22 73 65 72 76 65 72 3d 22 20 73 65 72 lf "server=" ser
75b0: 76 65 72 20 22 20 73 63 72 69 70 74 3d 22 20 73 ver " script=" s
75c0: 63 72 69 70 74 20 22 20 70 61 67 65 3d 22 20 70 cript " page=" p
75d0: 61 67 65 29 0a 20 20 20 20 28 73 74 72 69 6e 67 age). (string
75e0: 2d 61 70 70 65 6e 64 20 22 68 74 74 70 3a 2f 2f -append "http://
75f0: 22 20 73 65 72 76 65 72 20 22 2f 22 20 73 63 72 " server "/" scr
7600: 69 70 74 20 22 2f 22 20 70 61 67 65 20 22 3f 22 ipt "/" page "?"
7610: 20 70 61 72 61 6d 73 74 72 29 29 29 20 3b 3b 20 paramstr))) ;;
7620: 22 2f 73 6e 3d 22 20 73 65 73 73 69 6f 6e 2d 6b "/sn=" session-k
7630: 65 79 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 ey)))..(define (
7640: 73 65 73 73 69 6f 6e 3a 63 67 69 2d 6f 75 74 20 session:cgi-out
7650: 73 65 6c 66 29 0a 20 20 28 6c 65 74 2a 20 28 28 self). (let* ((
7660: 63 6f 6e 74 65 6e 74 20 20 28 6c 69 73 74 20 28 content (list (
7670: 73 64 61 74 2d 67 65 74 2d 63 6f 6e 74 65 6e 74 sdat-get-content
7680: 2d 74 79 70 65 20 73 65 6c 66 29 29 29 20 3b 3b -type self))) ;;
7690: 20 27 28 22 43 6f 6e 74 65 6e 74 2d 74 79 70 65 '("Content-type
76a0: 3a 20 74 65 78 74 2f 68 74 6d 6c 3b 20 63 68 61 : text/html; cha
76b0: 72 73 65 74 3d 69 73 6f 2d 38 38 35 39 2d 31 5c rset=iso-8859-1\
76c0: 6e 5c 6e 22 29 29 0a 09 20 28 68 65 61 64 65 72 n\n")).. (header
76d0: 20 20 20 28 6c 65 74 20 28 28 63 6f 6f 6b 69 65 (let ((cookie
76e0: 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 (sdat-get-sessi
76f0: 6f 6e 2d 63 6f 6f 6b 69 65 20 73 65 6c 66 29 29 on-cookie self))
7700: 29 0a 09 09 20 20 20 20 20 28 69 66 20 63 6f 6f )... (if coo
7710: 6b 69 65 0a 09 09 09 20 28 63 6f 6e 73 20 28 73 kie.... (cons (s
7720: 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 22 53 65 tring-append "Se
7730: 74 2d 43 6f 6f 6b 69 65 3a 20 22 20 28 63 61 72 t-Cookie: " (car
7740: 20 63 6f 6f 6b 69 65 29 29 0a 09 09 09 20 20 20 cookie))....
7750: 20 20 20 20 63 6f 6e 74 65 6e 74 29 0a 09 09 09 content)....
7760: 20 63 6f 6e 74 65 6e 74 29 29 29 0a 09 20 28 70 content))).. (p
7770: 61 67 65 64 61 74 20 20 28 73 64 61 74 2d 67 65 agedat (sdat-ge
7780: 74 2d 70 61 67 65 64 61 74 20 73 65 6c 66 29 29 t-pagedat self))
7790: 29 0a 20 20 20 20 28 73 3a 63 67 69 2d 6f 75 74 ). (s:cgi-out
77a0: 20 0a 20 20 20 20 20 28 63 6f 6e 73 20 68 65 61 . (cons hea
77b0: 64 65 72 20 70 61 67 65 64 61 74 29 29 29 29 0a der pagedat)))).
77c0: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
77d0: 6e 3a 6c 6f 67 20 73 65 6c 66 20 2e 20 6d 73 67 n:log self . msg
77e0: 29 0a 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 ). (with-output
77f0: 2d 74 6f 2d 70 6f 72 74 20 28 73 64 61 74 2d 67 -to-port (sdat-g
7800: 65 74 2d 6c 6f 67 2d 70 6f 72 74 20 73 65 6c 66 et-log-port self
7810: 29 20 3b 3b 20 28 73 64 61 74 2d 67 65 74 2d 6c ) ;; (sdat-get-l
7820: 6f 67 70 74 20 73 65 6c 66 29 0a 20 20 20 20 28 ogpt self). (
7830: 6c 61 6d 62 64 61 20 28 29 20 0a 20 20 20 20 20 lambda () .
7840: 20 28 61 70 70 6c 79 20 70 72 69 6e 74 20 6d 73 (apply print ms
7850: 67 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 g))))..(define (
7860: 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 72 61 session:get-para
7870: 6d 20 73 65 6c 66 20 6b 65 79 29 0a 20 20 3b 3b m self key). ;;
7880: 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 3a (session:log s:
7890: 73 65 73 73 69 6f 6e 20 22 70 61 72 61 6d 73 3d session "params=
78a0: 22 20 28 73 6c 6f 74 2d 72 65 66 20 73 3a 73 65 " (slot-ref s:se
78b0: 73 73 69 6f 6e 20 27 70 61 72 61 6d 73 29 29 0a ssion 'params)).
78c0: 20 20 28 6c 65 74 20 28 28 70 61 72 61 6d 73 20 (let ((params
78d0: 28 73 64 61 74 2d 67 65 74 2d 70 61 72 61 6d 73 (sdat-get-params
78e0: 20 73 65 6c 66 29 29 29 0a 20 20 20 20 28 73 65 self))). (se
78f0: 73 73 69 6f 6e 3a 67 65 74 2d 70 61 72 61 6d 2d ssion:get-param-
7900: 66 72 6f 6d 20 70 61 72 61 6d 73 20 6b 65 79 29 from params key)
7910: 29 29 0a 0a 3b 3b 20 54 68 69 73 20 6f 6e 65 20 ))..;; This one
7920: 77 69 6c 6c 20 67 65 74 20 74 68 65 20 66 69 72 will get the fir
7930: 73 74 20 76 61 6c 75 65 20 66 6f 75 6e 64 20 72 st value found r
7940: 65 67 61 72 64 6c 65 73 73 20 6f 66 20 66 6f 72 egardless of for
7950: 6d 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 m.(define (sessi
7960: 6f 6e 3a 67 65 74 2d 69 6e 70 75 74 20 73 65 6c on:get-input sel
7970: 66 20 6b 65 79 29 0a 20 20 28 6c 65 74 2a 20 28 f key). (let* (
7980: 28 66 6f 72 6d 64 61 74 20 28 73 64 61 74 2d 67 (formdat (sdat-g
7990: 65 74 2d 66 6f 72 6d 64 61 74 20 73 65 6c 66 29 et-formdat self)
79a0: 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 )). (if (not
79b0: 66 6f 72 6d 64 61 74 29 20 23 66 0a 09 28 69 66 formdat) #f..(if
79c0: 20 28 6f 72 20 28 73 74 72 69 6e 67 3f 20 6b 65 (or (string? ke
79d0: 79 29 28 6e 75 6d 62 65 72 3f 20 6b 65 79 29 28 y)(number? key)(
79e0: 73 79 6d 62 6f 6c 3f 20 6b 65 79 29 29 0a 09 20 symbol? key))..
79f0: 20 20 20 28 69 66 20 28 61 6e 64 20 28 76 65 63 (if (and (vec
7a00: 74 6f 72 3f 20 66 6f 72 6d 64 61 74 29 28 65 71 tor? formdat)(eq
7a10: 3f 20 28 76 65 63 74 6f 72 2d 6c 65 6e 67 74 68 ? (vector-length
7a20: 20 66 6f 72 6d 64 61 74 29 20 31 29 28 68 61 73 formdat) 1)(has
7a30: 68 2d 74 61 62 6c 65 3f 20 28 76 65 63 74 6f 72 h-table? (vector
7a40: 2d 72 65 66 20 66 6f 72 6d 64 61 74 20 30 29 29 -ref formdat 0))
7a50: 29 0a 09 09 28 66 6f 72 6d 64 61 74 3a 67 65 74 )...(formdat:get
7a60: 20 66 6f 72 6d 64 61 74 20 6b 65 79 29 0a 09 09 formdat key)...
7a70: 28 62 65 67 69 6e 0a 09 09 20 20 28 73 65 73 73 (begin... (sess
7a80: 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 45 52 ion:log self "ER
7a90: 52 4f 52 3a 20 66 6f 72 6d 64 61 74 3a 20 22 20 ROR: formdat: "
7aa0: 66 6f 72 6d 64 61 74 20 22 20 69 73 20 6e 6f 74 formdat " is not
7ab0: 20 6f 66 20 63 6c 61 73 73 20 3c 66 6f 72 6d 64 of class <formd
7ac0: 61 74 3e 22 29 0a 09 09 20 20 23 66 29 29 0a 09 at>")... #f))..
7ad0: 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 (session:log
7ae0: 20 73 65 6c 66 20 22 45 52 52 4f 52 3a 20 62 61 self "ERROR: ba
7af0: 64 20 6b 65 79 20 22 20 6b 65 79 29 29 29 29 29 d key " key)))))
7b00: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ..(define (sessi
7b10: 6f 6e 3a 72 75 6e 2d 61 63 74 69 6f 6e 73 20 73 on:run-actions s
7b20: 65 6c 66 29 0a 20 20 28 6c 65 74 2a 20 28 28 61 elf). (let* ((a
7b30: 63 74 69 6f 6e 20 20 20 20 28 73 65 73 73 69 6f ction (sessio
7b40: 6e 3a 67 65 74 2d 70 61 72 61 6d 20 73 65 6c 66 n:get-param self
7b50: 20 27 61 63 74 69 6f 6e 29 29 0a 09 20 28 70 61 'action)).. (pa
7b60: 67 65 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 ge (sdat-ge
7b70: 74 2d 70 61 67 65 20 73 65 6c 66 29 29 29 0a 20 t-page self))).
7b80: 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 61 63 ;; (print "ac
7b90: 74 69 6f 6e 3d 22 20 61 63 74 69 6f 6e 20 22 20 tion=" action "
7ba0: 70 61 67 65 3d 22 20 70 61 67 65 29 0a 20 20 20 page=" page).
7bb0: 20 28 69 66 20 61 63 74 69 6f 6e 0a 09 28 6c 65 (if action..(le
7bc0: 74 20 28 28 61 63 74 69 6f 6e 2d 6c 73 74 20 20 t ((action-lst
7bd0: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 61 63 (string-split ac
7be0: 74 69 6f 6e 20 22 2e 22 29 29 29 0a 09 20 20 3b tion "."))).. ;
7bf0: 3b 20 28 70 72 69 6e 74 20 22 61 63 74 69 6f 6e ; (print "action
7c00: 2d 6c 73 74 3d 22 20 61 63 74 69 6f 6e 2d 6c 73 -lst=" action-ls
7c10: 74 29 0a 09 20 20 28 69 66 20 28 6e 6f 74 20 28 t).. (if (not (
7c20: 3d 20 28 6c 65 6e 67 74 68 20 61 63 74 69 6f 6e = (length action
7c30: 2d 6c 73 74 29 20 32 29 29 20 0a 09 20 20 20 20 -lst) 2)) ..
7c40: 20 20 28 65 72 72 3a 6c 6f 67 20 22 41 63 74 69 (err:log "Acti
7c50: 6f 6e 20 73 68 6f 75 6c 64 20 62 65 20 6f 66 20 on should be of
7c60: 66 6f 72 6d 3a 20 6d 6f 64 75 6c 65 2e 61 63 74 form: module.act
7c70: 69 6f 6e 22 29 0a 09 20 20 20 20 20 20 28 6c 65 ion").. (le
7c80: 74 2a 20 28 28 74 61 72 67 2d 70 61 67 65 20 20 t* ((targ-page
7c90: 20 28 63 61 72 20 61 63 74 69 6f 6e 2d 6c 73 74 (car action-lst
7ca0: 29 29 0a 09 09 20 20 20 20 20 28 70 72 6f 63 2d ))... (proc-
7cb0: 6e 61 6d 65 20 20 20 28 73 74 72 69 6e 67 2d 61 name (string-a
7cc0: 70 70 65 6e 64 20 74 61 72 67 2d 70 61 67 65 20 ppend targ-page
7cd0: 22 2d 61 63 74 69 6f 6e 22 29 29 0a 09 09 20 20 "-action"))...
7ce0: 20 20 20 28 74 61 72 67 2d 61 63 74 69 6f 6e 20 (targ-action
7cf0: 28 63 61 64 72 20 61 63 74 69 6f 6e 2d 6c 73 74 (cadr action-lst
7d00: 29 29 29 0a 09 09 3b 3b 20 28 65 72 72 3a 6c 6f )))...;; (err:lo
7d10: 67 20 22 74 61 72 67 2d 70 61 67 65 3d 22 20 74 g "targ-page=" t
7d20: 61 72 67 2d 70 61 67 65 20 22 20 70 72 6f 63 2d arg-page " proc-
7d30: 6e 61 6d 65 3d 22 20 70 72 6f 63 2d 6e 61 6d 65 name=" proc-name
7d40: 20 22 20 74 61 72 67 2d 61 63 74 69 6f 6e 3d 22 " targ-action="
7d50: 20 74 61 72 67 2d 61 63 74 69 6f 6e 29 0a 0a 09 targ-action)...
7d60: 09 3b 3b 20 63 61 6c 6c 20 68 65 72 65 20 6f 6e .;; call here on
7d70: 6c 79 20 69 66 20 6e 65 76 65 72 20 63 61 6c 6c ly if never call
7d80: 65 64 20 62 65 66 6f 72 65 0a 09 09 28 69 66 20 ed before...(if
7d90: 28 73 65 73 73 69 6f 6e 3a 6e 65 76 65 72 2d 63 (session:never-c
7da0: 61 6c 6c 65 64 2d 70 61 67 65 3f 20 73 65 6c 66 alled-page? self
7db0: 20 74 61 72 67 2d 70 61 67 65 29 0a 09 09 20 20 targ-page)...
7dc0: 20 20 28 73 65 73 73 69 6f 6e 3a 63 61 6c 6c 2d (session:call-
7dd0: 70 61 72 74 73 20 73 65 6c 66 20 74 61 72 67 2d parts self targ-
7de0: 70 61 67 65 20 27 63 6f 6e 74 72 6f 6c 29 29 0a page 'control)).
7df0: 09 09 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 ..;;
7e00: 20 20 20 20 20 20 20 20 70 72 6f 63 20 20 20 20 proc
7e10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7e20: 20 20 20 20 20 61 63 74 69 6f 6e 20 20 20 20 0a action .
7e30: 0a 09 09 28 69 66 20 23 74 20 3b 3b 20 73 65 74 ...(if #t ;; set
7e40: 20 74 6f 20 23 74 20 74 6f 20 73 65 65 20 62 65 to #t to see be
7e50: 74 74 65 72 20 65 72 72 6f 72 20 6d 65 73 73 61 tter error messa
7e60: 67 65 73 20 64 75 72 69 6e 67 20 64 65 62 75 67 ges during debug
7e70: 67 69 6e 20 3a 2d 29 0a 09 09 20 20 20 20 28 28 gin :-)... ((
7e80: 65 76 61 6c 20 28 73 74 72 69 6e 67 2d 3e 73 79 eval (string->sy
7e90: 6d 62 6f 6c 20 70 72 6f 63 2d 6e 61 6d 65 29 29 mbol proc-name))
7ea0: 20 74 61 72 67 2d 61 63 74 69 6f 6e 29 20 3b 3b targ-action) ;;
7eb0: 20 75 6e 73 61 66 65 20 65 78 65 63 75 74 69 6f unsafe executio
7ec0: 6e 0a 09 09 20 20 20 20 28 63 6f 6e 64 69 74 69 n... (conditi
7ed0: 6f 6e 2d 63 61 73 65 20 28 28 65 76 61 6c 20 28 on-case ((eval (
7ee0: 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 70 string->symbol p
7ef0: 72 6f 63 2d 6e 61 6d 65 29 29 20 74 61 72 67 2d roc-name)) targ-
7f00: 61 63 74 69 6f 6e 29 0a 09 09 09 09 20 20 20 20 action).....
7f10: 28 28 65 78 6e 20 66 69 6c 65 29 20 28 73 3a 6c ((exn file) (s:l
7f20: 6f 67 20 22 66 69 6c 65 20 65 72 72 6f 72 22 29 og "file error")
7f30: 29 0a 09 09 09 09 20 20 20 20 28 28 65 78 6e 20 )..... ((exn
7f40: 69 2f 6f 29 20 20 28 73 3a 6c 6f 67 20 22 69 2f i/o) (s:log "i/
7f50: 6f 20 65 72 72 6f 72 22 29 29 0a 09 09 09 09 20 o error")).....
7f60: 20 20 20 28 28 65 78 6e 20 29 20 20 20 20 20 28 ((exn ) (
7f70: 73 3a 6c 6f 67 20 22 41 63 74 69 6f 6e 20 6e 6f s:log "Action no
7f80: 74 20 69 6d 70 6c 65 6d 65 6e 74 65 64 3a 20 22 t implemented: "
7f90: 20 70 72 6f 63 2d 6e 61 6d 65 20 22 20 61 63 74 proc-name " act
7fa0: 69 6f 6e 3a 20 22 20 74 61 72 67 2d 61 63 74 69 ion: " targ-acti
7fb0: 6f 6e 29 29 0a 09 09 09 09 20 20 20 20 28 76 61 on))..... (va
7fc0: 72 20 28 29 20 20 20 20 20 28 73 3a 6c 6f 67 20 r () (s:log
7fd0: 22 55 6e 6b 6e 6f 77 6e 20 45 72 72 6f 72 22 29 "Unknown Error")
7fe0: 29 29 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 )))))))))..(defi
7ff0: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 6e 65 76 65 ne (session:neve
8000: 72 2d 63 61 6c 6c 65 64 2d 70 61 67 65 3f 20 73 r-called-page? s
8010: 65 6c 66 20 70 61 67 65 29 0a 20 20 28 73 65 73 elf page). (ses
8020: 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 43 sion:log self "C
8030: 68 65 63 6b 69 6e 67 20 66 6f 72 20 70 61 67 65 hecking for page
8040: 3a 20 22 20 70 61 67 65 29 0a 20 20 28 6e 6f 74 : " page). (not
8050: 20 28 6d 65 6d 62 65 72 20 70 61 67 65 20 28 73 (member page (s
8060: 64 61 74 2d 67 65 74 2d 73 65 65 6e 2d 70 61 67 dat-get-seen-pag
8070: 65 73 20 73 65 6c 66 29 29 29 29 0a 0a 28 64 65 es self))))..(de
8080: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 65 fine (session:se
8090: 74 2d 63 61 6c 6c 65 64 21 20 73 65 6c 66 20 70 t-called! self p
80a0: 61 67 65 29 0a 20 20 28 73 64 61 74 2d 73 65 74 age). (sdat-set
80b0: 2d 73 65 65 6e 2d 70 61 67 65 73 21 20 73 65 6c -seen-pages! sel
80c0: 66 20 28 63 6f 6e 73 20 70 61 67 65 20 28 73 64 f (cons page (sd
80d0: 61 74 2d 67 65 74 2d 73 65 65 6e 2d 70 61 67 65 at-get-seen-page
80e0: 73 20 73 65 6c 66 29 29 29 29 0a 0a 3b 3b 3d 3d s self))))..;;==
80f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8100: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8110: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8120: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8130: 3d 3d 3d 3d 0a 3b 3b 20 41 6c 74 65 72 6e 61 74 ====.;; Alternat
8140: 69 76 65 20 64 61 74 61 20 74 79 70 65 20 64 65 ive data type de
8150: 6c 69 76 65 72 79 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d livery.;;=======
8160: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8170: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8180: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8190: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
81a0: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
81b0: 6e 3a 61 6c 74 2d 6f 75 74 20 73 65 6c 66 29 0a n:alt-out self).
81c0: 20 20 28 6c 65 74 20 28 28 64 61 74 20 28 73 64 (let ((dat (sd
81d0: 61 74 2d 67 65 74 2d 61 6c 74 2d 70 61 67 65 2d at-get-alt-page-
81e0: 64 61 74 20 73 65 6c 66 29 29 29 0a 20 20 20 20 dat self))).
81f0: 3b 3b 20 28 73 3a 6c 6f 67 20 22 64 61 74 20 69 ;; (s:log "dat i
8200: 73 3a 20 22 20 64 61 74 29 0a 20 20 20 20 3b 3b s: " dat). ;;
8210: 20 28 70 72 69 6e 74 20 22 48 54 54 50 2f 31 2e (print "HTTP/1.
8220: 31 20 32 30 30 20 4f 4b 22 29 0a 20 20 20 20 28 1 200 OK"). (
8230: 70 72 69 6e 74 20 22 44 61 74 65 3a 20 22 20 28 print "Date: " (
8240: 74 69 6d 65 2d 3e 73 74 72 69 6e 67 20 28 73 65 time->string (se
8250: 63 6f 6e 64 73 2d 3e 75 74 63 2d 74 69 6d 65 20 conds->utc-time
8260: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
8270: 29 29 29 29 0a 20 20 20 20 28 70 72 69 6e 74 20 )))). (print
8280: 22 43 6f 6e 74 65 6e 74 2d 54 79 70 65 3a 20 22 "Content-Type: "
8290: 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 74 65 (sdat-get-conte
82a0: 6e 74 2d 74 79 70 65 20 73 65 6c 66 29 29 0a 20 nt-type self)).
82b0: 20 20 20 28 70 72 69 6e 74 20 22 41 63 63 65 70 (print "Accep
82c0: 74 2d 52 61 6e 67 65 73 3a 20 62 79 74 65 73 22 t-Ranges: bytes"
82d0: 29 0a 20 20 20 20 28 70 72 69 6e 74 20 22 43 6f ). (print "Co
82e0: 6e 74 65 6e 74 2d 4c 65 6e 67 74 68 3a 20 22 20 ntent-Length: "
82f0: 28 69 66 20 28 62 6c 6f 62 3f 20 64 61 74 29 0a (if (blob? dat).
8300: 09 09 09 09 20 20 28 62 6c 6f 62 2d 73 69 7a 65 .... (blob-size
8310: 20 64 61 74 29 0a 09 09 09 09 20 20 30 29 29 0a dat)..... 0)).
8320: 20 20 20 20 28 70 72 69 6e 74 20 22 4b 65 65 70 (print "Keep
8330: 2d 41 6c 69 76 65 3a 20 74 69 6d 65 6f 75 74 3d -Alive: timeout=
8340: 31 35 2c 20 6d 61 78 3d 31 30 30 22 29 0a 20 20 15, max=100").
8350: 20 20 28 70 72 69 6e 74 20 22 43 6f 6e 6e 65 63 (print "Connec
8360: 74 69 6f 6e 3a 20 4b 65 65 70 2d 41 6c 69 76 65 tion: Keep-Alive
8370: 22 29 0a 20 20 20 20 28 70 72 69 6e 74 20 22 22 "). (print ""
8380: 29 0a 20 20 20 20 28 77 72 69 74 65 2d 73 74 72 ). (write-str
8390: 69 6e 67 20 28 62 6c 6f 62 2d 3e 73 74 72 69 6e ing (blob->strin
83a0: 67 20 64 61 74 29 20 23 66 20 28 63 75 72 72 65 g dat) #f (curre
83b0: 6e 74 2d 6f 75 74 70 75 74 2d 70 6f 72 74 29 29 nt-output-port))
83c0: 29 29 0a )).