Artifact
5ace07e7c57bea0f49c64df5d999262909e121af:
0000: 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 30 ;; Copyright 200
0010: 37 2d 32 30 31 31 2c 20 4d 61 74 74 68 65 77 20 7-2011, Matthew
0020: 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b 20 Welland..;; .;;
0030: 20 54 68 69 73 20 70 72 6f 67 72 61 6d 20 69 73 This program is
0040: 20 6d 61 64 65 20 61 76 61 69 6c 61 62 6c 65 20 made available
0050: 75 6e 64 65 72 20 74 68 65 20 47 4e 55 20 47 50 under the GNU GP
0060: 4c 20 76 65 72 73 69 6f 6e 20 32 2e 30 20 6f 72 L version 2.0 or
0070: 0a 3b 3b 20 20 67 72 65 61 74 65 72 2e 20 53 65 .;; greater. Se
0080: 65 20 74 68 65 20 61 63 63 6f 6d 70 61 6e 79 69 e the accompanyi
0090: 6e 67 20 66 69 6c 65 20 43 4f 50 59 49 4e 47 20 ng file COPYING
00a0: 66 6f 72 20 64 65 74 61 69 6c 73 2e 0a 3b 3b 20 for details..;;
00b0: 0a 3b 3b 20 20 54 68 69 73 20 70 72 6f 67 72 61 .;; This progra
00c0: 6d 20 69 73 20 64 69 73 74 72 69 62 75 74 65 64 m is distributed
00d0: 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 52 WITHOUT ANY WAR
00e0: 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 65 RANTY; without e
00f0: 76 65 6e 20 74 68 65 0a 3b 3b 20 20 69 6d 70 6c ven the.;; impl
0100: 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 20 ied warranty of
0110: 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 20 MERCHANTABILITY
0120: 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 41 or FITNESS FOR A
0130: 20 50 41 52 54 49 43 55 4c 41 52 0a 3b 3b 20 20 PARTICULAR.;;
0140: 50 55 52 50 4f 53 45 2e 0a 0a 28 64 65 63 6c 61 PURPOSE...(decla
0150: 72 65 20 28 75 6e 69 74 20 73 65 73 73 69 6f 6e re (unit session
0160: 29 29 0a 28 72 65 71 75 69 72 65 2d 6c 69 62 72 )).(require-libr
0170: 61 72 79 20 64 62 69 29 0a 28 72 65 71 75 69 72 ary dbi).(requir
0180: 65 2d 65 78 74 65 6e 73 69 6f 6e 20 72 65 67 65 e-extension rege
0190: 78 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 x).(declare (use
01a0: 73 20 63 6f 6f 6b 69 65 29 29 0a 0a 3b 3b 20 73 s cookie))..;; s
01b0: 65 73 73 69 6f 6e 73 20 74 61 62 6c 65 0a 3b 3b essions table.;;
01c0: 20 69 64 20 73 65 73 73 69 6f 6e 5f 69 64 20 73 id session_id s
01d0: 65 73 73 69 6f 6e 5f 6b 65 79 0a 3b 3b 20 63 72 ession_key.;; cr
01e0: 65 61 74 65 20 74 61 62 6c 65 20 73 65 73 73 69 eate table sessi
01f0: 6f 6e 73 20 28 69 64 20 73 65 72 69 61 6c 20 6e ons (id serial n
0200: 6f 74 20 6e 75 6c 6c 2c 73 65 73 73 69 6f 6e 2d ot null,session-
0210: 6b 65 79 20 74 65 78 74 29 3b 0a 0a 3b 3b 20 73 key text);..;; s
0220: 65 73 73 69 6f 6e 5f 76 61 72 73 20 74 61 62 6c ession_vars tabl
0230: 65 0a 3b 3b 20 69 64 20 73 65 73 73 69 6f 6e 5f e.;; id session_
0240: 69 64 20 70 61 67 65 5f 69 64 20 6b 65 79 20 76 id page_id key v
0250: 61 6c 75 65 0a 3b 3b 20 63 72 65 61 74 65 20 74 alue.;; create t
0260: 61 62 6c 65 20 73 65 73 73 69 6f 6e 5f 76 61 72 able session_var
0270: 73 20 28 69 64 20 73 65 72 69 61 6c 20 6e 6f 74 s (id serial not
0280: 20 6e 75 6c 6c 2c 73 65 73 73 69 6f 6e 5f 69 64 null,session_id
0290: 20 69 6e 74 65 67 65 72 2c 70 61 67 65 20 74 65 integer,page te
02a0: 78 74 2c 6b 65 79 20 74 65 78 74 2c 76 61 6c 75 xt,key text,valu
02b0: 65 20 74 65 78 74 29 3b 0a 0a 3b 3b 20 54 4f 44 e text);..;; TOD
02c0: 4f 0a 3b 3b 20 20 43 6f 6e 63 65 70 74 20 6f 66 O.;; Concept of
02d0: 20 6f 72 64 65 72 20 6e 75 6d 20 69 6e 63 72 65 order num incre
02e0: 6d 65 6e 74 65 64 20 77 69 74 68 20 65 61 63 68 mented with each
02f0: 20 70 61 67 65 20 61 63 63 65 73 73 0a 3b 3b 20 page access.;;
0300: 20 20 20 20 69 66 20 61 20 62 72 61 6e 63 68 20 if a branch
0310: 69 73 20 74 61 6b 65 6e 20 74 68 65 6e 20 61 20 is taken then a
0320: 6e 65 77 20 73 65 73 73 69 6f 6e 20 77 6f 75 6c new session woul
0330: 64 20 6e 65 65 64 20 74 6f 20 62 65 20 63 72 65 d need to be cre
0340: 61 74 65 64 0a 3b 3b 0a 0a 3b 3b 20 6d 61 6b 65 ated.;;..;; make
0350: 2d 76 65 63 74 6f 72 2d 72 65 63 6f 72 64 20 73 -vector-record s
0360: 65 73 73 69 6f 6e 20 73 65 73 73 69 6f 6e 20 64 ession session d
0370: 62 74 79 70 65 20 64 62 69 6e 69 74 20 63 6f 6e btype dbinit con
0380: 6e 20 70 61 72 61 6d 73 20 70 61 74 68 2d 70 61 n params path-pa
0390: 72 61 6d 73 20 73 65 73 73 69 6f 6e 2d 6b 65 79 rams session-key
03a0: 20 73 65 73 73 69 6f 6e 2d 69 64 20 64 6f 6d 61 session-id doma
03b0: 69 6e 20 74 6f 70 70 61 67 65 20 70 61 67 65 20 in toppage page
03c0: 63 75 72 72 2d 70 61 67 65 20 63 6f 6e 74 65 6e curr-page conten
03d0: 74 2d 74 79 70 65 20 70 61 67 65 2d 74 79 70 65 t-type page-type
03e0: 20 73 72 6f 6f 74 20 74 77 69 6b 69 64 69 72 20 sroot twikidir
03f0: 70 61 67 65 64 61 74 20 61 6c 74 2d 70 61 67 65 pagedat alt-page
0400: 2d 64 61 74 20 70 61 67 65 76 61 72 73 20 70 61 -dat pagevars pa
0410: 67 65 76 61 72 73 2d 62 65 66 6f 72 65 20 73 65 gevars-before se
0420: 73 73 69 6f 6e 76 61 72 73 20 73 65 73 73 69 6f ssionvars sessio
0430: 6e 76 61 72 73 2d 62 65 66 6f 72 65 20 67 6c 6f nvars-before glo
0440: 62 61 6c 76 61 72 73 20 67 6c 6f 62 61 6c 76 61 balvars globalva
0450: 72 73 2d 62 65 66 6f 72 65 20 6c 6f 67 70 74 20 rs-before logpt
0460: 66 6f 72 6d 64 61 74 20 72 65 71 75 65 73 74 2d formdat request-
0470: 6d 65 74 68 6f 64 20 73 65 73 73 69 6f 6e 2d 63 method session-c
0480: 6f 6f 6b 69 65 20 63 75 72 72 2d 65 72 72 20 6c ookie curr-err l
0490: 6f 67 2d 70 6f 72 74 20 6c 6f 67 66 69 6c 65 20 og-port logfile
04a0: 73 65 65 6e 2d 70 61 67 65 73 20 70 61 67 65 2d seen-pages page-
04b0: 64 69 72 2d 73 74 79 6c 65 20 64 65 62 75 67 6d dir-style debugm
04c0: 6f 64 65 0a 28 64 65 66 69 6e 65 20 28 6d 61 6b ode.(define (mak
04d0: 65 2d 73 64 61 74 29 28 6d 61 6b 65 2d 76 65 63 e-sdat)(make-vec
04e0: 74 6f 72 20 33 33 29 29 0a 28 64 65 66 69 6e 65 tor 33)).(define
04f0: 20 28 73 64 61 74 2d 67 65 74 2d 64 62 74 79 70 (sdat-get-dbtyp
0500: 65 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 e
0510: 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d vec) (vector-
0520: 72 65 66 20 20 76 65 63 20 30 29 29 0a 28 64 65 ref vec 0)).(de
0530: 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 64 fine (sdat-get-d
0540: 62 69 6e 69 74 20 20 20 20 20 20 20 20 20 20 20 binit
0550: 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 vec) (vec
0560: 74 6f 72 2d 72 65 66 20 20 76 65 63 20 31 29 29 tor-ref vec 1))
0570: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 .(define (sdat-g
0580: 65 74 2d 63 6f 6e 6e 20 20 20 20 20 20 20 20 20 et-conn
0590: 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 vec)
05a0: 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 (vector-ref vec
05b0: 20 32 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 2)).(define (sd
05c0: 61 74 2d 67 65 74 2d 70 61 72 61 6d 73 20 20 20 at-get-params
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: 20 76 65 63 20 33 29 29 0a 28 64 65 66 69 6e 65 vec 3)).(define
0600: 20 28 73 64 61 74 2d 67 65 74 2d 70 61 74 68 2d (sdat-get-path-
0610: 70 61 72 61 6d 73 20 20 20 20 20 20 20 20 20 20 params
0620: 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d vec) (vector-
0630: 72 65 66 20 20 76 65 63 20 34 29 29 0a 28 64 65 ref vec 4)).(de
0640: 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 73 fine (sdat-get-s
0650: 65 73 73 69 6f 6e 2d 6b 65 79 20 20 20 20 20 20 ession-key
0660: 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 vec) (vec
0670: 74 6f 72 2d 72 65 66 20 20 76 65 63 20 35 29 29 tor-ref vec 5))
0680: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 .(define (sdat-g
0690: 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 20 20 et-session-id
06a0: 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 vec)
06b0: 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 (vector-ref vec
06c0: 20 36 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 6)).(define (sd
06d0: 61 74 2d 67 65 74 2d 64 6f 6d 61 69 6e 20 20 20 at-get-domain
06e0: 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 29 vec)
06f0: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
0700: 20 76 65 63 20 37 29 29 0a 28 64 65 66 69 6e 65 vec 7)).(define
0710: 20 28 73 64 61 74 2d 67 65 74 2d 74 6f 70 70 61 (sdat-get-toppa
0720: 67 65 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ge
0730: 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d vec) (vector-
0740: 72 65 66 20 20 76 65 63 20 38 29 29 0a 28 64 65 ref vec 8)).(de
0750: 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 70 fine (sdat-get-p
0760: 61 67 65 20 20 20 20 20 20 20 20 20 20 20 20 20 age
0770: 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 vec) (vec
0780: 74 6f 72 2d 72 65 66 20 20 76 65 63 20 39 29 29 tor-ref vec 9))
0790: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 .(define (sdat-g
07a0: 65 74 2d 63 75 72 72 2d 70 61 67 65 20 20 20 20 et-curr-page
07b0: 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 vec)
07c0: 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 (vector-ref vec
07d0: 20 31 30 29 29 0a 28 64 65 66 69 6e 65 20 28 73 10)).(define (s
07e0: 64 61 74 2d 67 65 74 2d 63 6f 6e 74 65 6e 74 2d dat-get-content-
07f0: 74 79 70 65 20 20 20 20 20 20 20 20 20 76 65 63 type vec
0800: 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 ) (vector-ref
0810: 20 20 76 65 63 20 31 31 29 29 0a 28 64 65 66 69 vec 11)).(defi
0820: 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 ne (sdat-get-pag
0830: 65 2d 74 79 70 65 20 20 20 20 20 20 20 20 20 20 e-type
0840: 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f vec) (vecto
0850: 72 2d 72 65 66 20 20 76 65 63 20 31 32 29 29 0a r-ref vec 12)).
0860: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 (define (sdat-ge
0870: 74 2d 73 72 6f 6f 74 20 20 20 20 20 20 20 20 20 t-sroot
0880: 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 vec) (
0890: 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 vector-ref vec
08a0: 31 33 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 13)).(define (sd
08b0: 61 74 2d 67 65 74 2d 74 77 69 6b 69 64 69 72 20 at-get-twikidir
08c0: 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 29 vec)
08d0: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
08e0: 20 76 65 63 20 31 34 29 29 0a 28 64 65 66 69 6e vec 14)).(defin
08f0: 65 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 e (sdat-get-page
0900: 64 61 74 20 20 20 20 20 20 20 20 20 20 20 20 20 dat
0910: 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 vec) (vector
0920: 2d 72 65 66 20 20 76 65 63 20 31 35 29 29 0a 28 -ref vec 15)).(
0930: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 define (sdat-get
0940: 2d 61 6c 74 2d 70 61 67 65 2d 64 61 74 20 20 20 -alt-page-dat
0950: 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 vec) (v
0960: 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 31 ector-ref vec 1
0970: 36 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 6)).(define (sda
0980: 74 2d 67 65 74 2d 70 61 67 65 76 61 72 73 20 20 t-get-pagevars
0990: 20 20 20 20 20 20 20 20 20 20 20 76 65 63 29 20 vec)
09a0: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 (vector-ref
09b0: 76 65 63 20 31 37 29 29 0a 28 64 65 66 69 6e 65 vec 17)).(define
09c0: 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 76 (sdat-get-pagev
09d0: 61 72 73 2d 62 65 66 6f 72 65 20 20 20 20 20 20 ars-before
09e0: 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d vec) (vector-
09f0: 72 65 66 20 20 76 65 63 20 31 38 29 29 0a 28 64 ref vec 18)).(d
0a00: 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d efine (sdat-get-
0a10: 73 65 73 73 69 6f 6e 76 61 72 73 20 20 20 20 20 sessionvars
0a20: 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 vec) (ve
0a30: 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 31 39 ctor-ref vec 19
0a40: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
0a50: 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 -get-sessionvars
0a60: 2d 62 65 66 6f 72 65 20 20 20 76 65 63 29 20 20 -before vec)
0a70: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 (vector-ref v
0a80: 65 63 20 32 30 29 29 0a 28 64 65 66 69 6e 65 20 ec 20)).(define
0a90: 28 73 64 61 74 2d 67 65 74 2d 67 6c 6f 62 61 6c (sdat-get-global
0aa0: 76 61 72 73 20 20 20 20 20 20 20 20 20 20 20 76 vars v
0ab0: 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 ec) (vector-r
0ac0: 65 66 20 20 76 65 63 20 32 31 29 29 0a 28 64 65 ef vec 21)).(de
0ad0: 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 67 fine (sdat-get-g
0ae0: 6c 6f 62 61 6c 76 61 72 73 2d 62 65 66 6f 72 65 lobalvars-before
0af0: 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 vec) (vec
0b00: 74 6f 72 2d 72 65 66 20 20 76 65 63 20 32 32 29 tor-ref vec 22)
0b10: 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d ).(define (sdat-
0b20: 67 65 74 2d 6c 6f 67 70 74 20 20 20 20 20 20 20 get-logpt
0b30: 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 vec)
0b40: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 (vector-ref ve
0b50: 63 20 32 33 29 29 0a 28 64 65 66 69 6e 65 20 28 c 23)).(define (
0b60: 73 64 61 74 2d 67 65 74 2d 66 6f 72 6d 64 61 74 sdat-get-formdat
0b70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 ve
0b80: 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 c) (vector-re
0b90: 66 20 20 76 65 63 20 32 34 29 29 0a 28 64 65 66 f vec 24)).(def
0ba0: 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 72 65 ine (sdat-get-re
0bb0: 71 75 65 73 74 2d 6d 65 74 68 6f 64 20 20 20 20 quest-method
0bc0: 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 vec) (vect
0bd0: 6f 72 2d 72 65 66 20 20 76 65 63 20 32 35 29 29 or-ref vec 25))
0be0: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 .(define (sdat-g
0bf0: 65 74 2d 73 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 et-session-cooki
0c00: 65 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 e vec)
0c10: 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 (vector-ref vec
0c20: 20 32 36 29 29 0a 28 64 65 66 69 6e 65 20 28 73 26)).(define (s
0c30: 64 61 74 2d 67 65 74 2d 63 75 72 72 2d 65 72 72 dat-get-curr-err
0c40: 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 vec
0c50: 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 ) (vector-ref
0c60: 20 20 76 65 63 20 32 37 29 29 0a 28 64 65 66 69 vec 27)).(defi
0c70: 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 6c 6f 67 ne (sdat-get-log
0c80: 2d 70 6f 72 74 20 20 20 20 20 20 20 20 20 20 20 -port
0c90: 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f vec) (vecto
0ca0: 72 2d 72 65 66 20 20 76 65 63 20 32 38 29 29 0a r-ref vec 28)).
0cb0: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 (define (sdat-ge
0cc0: 74 2d 6c 6f 67 66 69 6c 65 20 20 20 20 20 20 20 t-logfile
0cd0: 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 vec) (
0ce0: 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 vector-ref vec
0cf0: 32 39 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 29)).(define (sd
0d00: 61 74 2d 67 65 74 2d 73 65 65 6e 2d 70 61 67 65 at-get-seen-page
0d10: 73 20 20 20 20 20 20 20 20 20 20 20 76 65 63 29 s vec)
0d20: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
0d30: 20 76 65 63 20 33 30 29 29 0a 28 64 65 66 69 6e vec 30)).(defin
0d40: 65 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 e (sdat-get-page
0d50: 2d 64 69 72 2d 73 74 79 6c 65 20 20 20 20 20 20 -dir-style
0d60: 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 vec) (vector
0d70: 2d 72 65 66 20 20 76 65 63 20 33 31 29 29 0a 28 -ref vec 31)).(
0d80: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 define (sdat-get
0d90: 2d 64 65 62 75 67 6d 6f 64 65 20 20 20 20 20 20 -debugmode
0da0: 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 vec) (v
0db0: 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 33 ector-ref vec 3
0dc0: 32 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 2)).(define (sda
0dd0: 74 2d 73 65 74 2d 64 62 74 79 70 65 21 20 20 20 t-set-dbtype!
0de0: 20 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 vec v
0df0: 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 al)(vector-set!
0e00: 76 65 63 20 30 20 76 61 6c 29 29 0a 28 64 65 66 vec 0 val)).(def
0e10: 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 64 62 ine (sdat-set-db
0e20: 69 6e 69 74 21 20 20 20 20 20 20 20 20 20 20 20 init!
0e30: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
0e40: 6f 72 2d 73 65 74 21 20 76 65 63 20 31 20 76 61 or-set! vec 1 va
0e50: 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 l)).(define (sda
0e60: 74 2d 73 65 74 2d 63 6f 6e 6e 21 20 20 20 20 20 t-set-conn!
0e70: 20 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 vec v
0e80: 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 al)(vector-set!
0e90: 76 65 63 20 32 20 76 61 6c 29 29 0a 28 64 65 66 vec 2 val)).(def
0ea0: 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 70 61 ine (sdat-set-pa
0eb0: 72 61 6d 73 21 20 20 20 20 20 20 20 20 20 20 20 rams!
0ec0: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
0ed0: 6f 72 2d 73 65 74 21 20 76 65 63 20 33 20 76 61 or-set! vec 3 va
0ee0: 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 l)).(define (sda
0ef0: 74 2d 73 65 74 2d 70 61 74 68 2d 70 61 72 61 6d t-set-path-param
0f00: 73 21 20 20 20 20 20 20 20 20 20 76 65 63 20 76 s! vec v
0f10: 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 al)(vector-set!
0f20: 76 65 63 20 34 20 76 61 6c 29 29 0a 28 64 65 66 vec 4 val)).(def
0f30: 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 73 65 ine (sdat-set-se
0f40: 73 73 69 6f 6e 2d 6b 65 79 21 20 20 20 20 20 20 ssion-key!
0f50: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
0f60: 6f 72 2d 73 65 74 21 20 76 65 63 20 35 20 76 61 or-set! vec 5 va
0f70: 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 l)).(define (sda
0f80: 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 t-set-session-id
0f90: 21 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 ! vec v
0fa0: 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 al)(vector-set!
0fb0: 76 65 63 20 36 20 76 61 6c 29 29 0a 28 64 65 66 vec 6 val)).(def
0fc0: 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 64 6f ine (sdat-set-do
0fd0: 6d 61 69 6e 21 20 20 20 20 20 20 20 20 20 20 20 main!
0fe0: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
0ff0: 6f 72 2d 73 65 74 21 20 76 65 63 20 37 20 76 61 or-set! vec 7 va
1000: 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 l)).(define (sda
1010: 74 2d 73 65 74 2d 74 6f 70 70 61 67 65 21 20 20 t-set-toppage!
1020: 20 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 vec v
1030: 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 al)(vector-set!
1040: 76 65 63 20 38 20 76 61 6c 29 29 0a 28 64 65 66 vec 8 val)).(def
1050: 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 70 61 ine (sdat-set-pa
1060: 67 65 21 20 20 20 20 20 20 20 20 20 20 20 20 20 ge!
1070: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
1080: 6f 72 2d 73 65 74 21 20 76 65 63 20 39 20 76 61 or-set! vec 9 va
1090: 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 l)).(define (sda
10a0: 74 2d 73 65 74 2d 63 75 72 72 2d 70 61 67 65 21 t-set-curr-page!
10b0: 20 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 vec v
10c0: 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 al)(vector-set!
10d0: 76 65 63 20 31 30 20 76 61 6c 29 29 0a 28 64 65 vec 10 val)).(de
10e0: 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 63 fine (sdat-set-c
10f0: 6f 6e 74 65 6e 74 2d 74 79 70 65 21 20 20 20 20 ontent-type!
1100: 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 vec val)(vec
1110: 74 6f 72 2d 73 65 74 21 20 76 65 63 20 31 31 20 tor-set! vec 11
1120: 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 val)).(define (s
1130: 64 61 74 2d 73 65 74 2d 70 61 67 65 2d 74 79 70 dat-set-page-typ
1140: 65 21 20 20 20 20 20 20 20 20 20 20 20 76 65 63 e! vec
1150: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
1160: 21 20 76 65 63 20 31 32 20 76 61 6c 29 29 0a 28 ! vec 12 val)).(
1170: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 define (sdat-set
1180: 2d 73 72 6f 6f 74 21 20 20 20 20 20 20 20 20 20 -sroot!
1190: 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 vec val)(v
11a0: 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 31 ector-set! vec 1
11b0: 33 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 3 val)).(define
11c0: 28 73 64 61 74 2d 73 65 74 2d 74 77 69 6b 69 64 (sdat-set-twikid
11d0: 69 72 21 20 20 20 20 20 20 20 20 20 20 20 20 76 ir! v
11e0: 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 ec val)(vector-s
11f0: 65 74 21 20 76 65 63 20 31 34 20 76 61 6c 29 29 et! vec 14 val))
1200: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 .(define (sdat-s
1210: 65 74 2d 70 61 67 65 64 61 74 21 20 20 20 20 20 et-pagedat!
1220: 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 vec val)
1230: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 (vector-set! vec
1240: 20 31 35 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 15 val)).(defin
1250: 65 20 28 73 64 61 74 2d 73 65 74 2d 61 6c 74 2d e (sdat-set-alt-
1260: 70 61 67 65 2d 64 61 74 21 20 20 20 20 20 20 20 page-dat!
1270: 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 vec val)(vector
1280: 2d 73 65 74 21 20 76 65 63 20 31 36 20 76 61 6c -set! vec 16 val
1290: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
12a0: 2d 73 65 74 2d 70 61 67 65 76 61 72 73 21 20 20 -set-pagevars!
12b0: 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 61 vec va
12c0: 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 l)(vector-set! v
12d0: 65 63 20 31 37 20 76 61 6c 29 29 0a 28 64 65 66 ec 17 val)).(def
12e0: 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 70 61 ine (sdat-set-pa
12f0: 67 65 76 61 72 73 2d 62 65 66 6f 72 65 21 20 20 gevars-before!
1300: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
1310: 6f 72 2d 73 65 74 21 20 76 65 63 20 31 38 20 76 or-set! vec 18 v
1320: 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 al)).(define (sd
1330: 61 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e 76 61 at-set-sessionva
1340: 72 73 21 20 20 20 20 20 20 20 20 20 76 65 63 20 rs! vec
1350: 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 val)(vector-set!
1360: 20 76 65 63 20 31 39 20 76 61 6c 29 29 0a 28 64 vec 19 val)).(d
1370: 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d efine (sdat-set-
1380: 73 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 6f sessionvars-befo
1390: 72 65 21 20 20 76 65 63 20 76 61 6c 29 28 76 65 re! vec val)(ve
13a0: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 32 30 ctor-set! vec 20
13b0: 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 val)).(define (
13c0: 73 64 61 74 2d 73 65 74 2d 67 6c 6f 62 61 6c 76 sdat-set-globalv
13d0: 61 72 73 21 20 20 20 20 20 20 20 20 20 20 76 65 ars! ve
13e0: 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 c val)(vector-se
13f0: 74 21 20 76 65 63 20 32 31 20 76 61 6c 29 29 0a t! vec 21 val)).
1400: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 (define (sdat-se
1410: 74 2d 67 6c 6f 62 61 6c 76 61 72 73 2d 62 65 66 t-globalvars-bef
1420: 6f 72 65 21 20 20 20 76 65 63 20 76 61 6c 29 28 ore! vec val)(
1430: 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 vector-set! vec
1440: 32 32 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 22 val)).(define
1450: 20 28 73 64 61 74 2d 73 65 74 2d 6c 6f 67 70 74 (sdat-set-logpt
1460: 21 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 !
1470: 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d vec val)(vector-
1480: 73 65 74 21 20 76 65 63 20 32 33 20 76 61 6c 29 set! vec 23 val)
1490: 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d ).(define (sdat-
14a0: 73 65 74 2d 66 6f 72 6d 64 61 74 21 20 20 20 20 set-formdat!
14b0: 20 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c vec val
14c0: 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 )(vector-set! ve
14d0: 63 20 32 34 20 76 61 6c 29 29 0a 28 64 65 66 69 c 24 val)).(defi
14e0: 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 72 65 71 ne (sdat-set-req
14f0: 75 65 73 74 2d 6d 65 74 68 6f 64 21 20 20 20 20 uest-method!
1500: 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f vec val)(vecto
1510: 72 2d 73 65 74 21 20 76 65 63 20 32 35 20 76 61 r-set! vec 25 va
1520: 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 l)).(define (sda
1530: 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e 2d 63 6f t-set-session-co
1540: 6f 6b 69 65 21 20 20 20 20 20 20 76 65 63 20 76 okie! vec v
1550: 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 al)(vector-set!
1560: 76 65 63 20 32 36 20 76 61 6c 29 29 0a 28 64 65 vec 26 val)).(de
1570: 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 63 fine (sdat-set-c
1580: 75 72 72 2d 65 72 72 21 20 20 20 20 20 20 20 20 urr-err!
1590: 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 vec val)(vec
15a0: 74 6f 72 2d 73 65 74 21 20 76 65 63 20 32 37 20 tor-set! vec 27
15b0: 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 val)).(define (s
15c0: 64 61 74 2d 73 65 74 2d 6c 6f 67 2d 70 6f 72 74 dat-set-log-port
15d0: 21 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 ! vec
15e0: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
15f0: 21 20 76 65 63 20 32 38 20 76 61 6c 29 29 0a 28 ! vec 28 val)).(
1600: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 define (sdat-set
1610: 2d 6c 6f 67 66 69 6c 65 21 20 20 20 20 20 20 20 -logfile!
1620: 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 vec val)(v
1630: 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 32 ector-set! vec 2
1640: 39 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 9 val)).(define
1650: 28 73 64 61 74 2d 73 65 74 2d 73 65 65 6e 2d 70 (sdat-set-seen-p
1660: 61 67 65 73 21 20 20 20 20 20 20 20 20 20 20 76 ages! v
1670: 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 ec val)(vector-s
1680: 65 74 21 20 76 65 63 20 33 30 20 76 61 6c 29 29 et! vec 30 val))
1690: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 .(define (sdat-s
16a0: 65 74 2d 70 61 67 65 2d 64 69 72 2d 73 74 79 6c et-page-dir-styl
16b0: 65 21 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 e! vec val)
16c0: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 (vector-set! vec
16d0: 20 33 31 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 31 val)).(defin
16e0: 65 20 28 73 64 61 74 2d 73 65 74 2d 64 65 62 75 e (sdat-set-debu
16f0: 67 6d 6f 64 65 21 20 20 20 20 20 20 20 20 20 20 gmode!
1700: 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 vec val)(vector
1710: 2d 73 65 74 21 20 76 65 63 20 33 32 20 76 61 6c -set! vec 32 val
1720: 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 2d 63 ))..;; (define-c
1730: 6c 61 73 73 20 3c 73 65 73 73 69 6f 6e 3e 20 28 lass <session> (
1740: 29 0a 3b 3b 20 20 20 28 64 62 74 79 70 65 20 20 ).;; (dbtype
1750: 20 20 20 20 20 3b 3b 20 27 70 67 20 6f 72 20 27 ;; 'pg or '
1760: 73 71 6c 69 74 65 33 0a 3b 3b 20 20 20 20 64 62 sqlite3.;; db
1770: 69 6e 69 74 0a 3b 3b 20 20 20 20 63 6f 6e 6e 0a init.;; conn.
1780: 3b 3b 20 20 20 20 70 61 72 61 6d 73 20 20 20 20 ;; params
1790: 20 20 20 3b 3b 20 70 61 72 61 6d 73 20 66 72 6f ;; params fro
17a0: 6d 20 74 68 65 20 6b 65 79 3d 76 61 6c 26 6b 65 m the key=val&ke
17b0: 79 31 3d 76 61 6c 32 20 73 74 72 69 6e 67 0a 3b y1=val2 string.;
17c0: 3b 20 20 20 20 70 61 74 68 2d 70 61 72 61 6d 73 ; path-params
17d0: 20 20 3b 3b 20 72 65 6d 61 69 6e 69 6e 67 20 70 ;; remaining p
17e0: 61 72 61 6d 73 20 66 72 6f 6d 20 74 68 65 20 70 arams from the p
17f0: 61 74 68 0a 3b 3b 20 20 20 20 73 65 73 73 69 6f ath.;; sessio
1800: 6e 2d 6b 65 79 0a 3b 3b 20 20 20 20 73 65 73 73 n-key.;; sess
1810: 69 6f 6e 2d 69 64 0a 3b 3b 20 20 20 20 64 6f 6d ion-id.;; dom
1820: 61 69 6e 0a 3b 3b 20 20 20 20 74 6f 70 70 61 67 ain.;; toppag
1830: 65 20 20 20 20 20 20 3b 3b 20 64 65 66 61 75 6c e ;; defaul
1840: 74 73 20 74 6f 20 22 69 6e 64 65 78 22 20 2d 20 ts to "index" -
1850: 6f 76 65 72 72 69 64 65 20 69 6e 20 2e 73 74 6d override in .stm
1860: 6c 2e 63 6f 6e 66 69 67 20 69 66 20 64 65 73 69 l.config if desi
1870: 72 65 64 0a 3b 3b 20 20 20 20 70 61 67 65 20 20 red.;; page
1880: 20 20 20 20 20 20 20 3b 3b 20 74 68 65 20 70 61 ;; the pa
1890: 67 65 20 6e 61 6d 65 20 2d 20 64 65 66 61 75 6c ge name - defaul
18a0: 74 73 20 74 6f 20 68 6f 6d 65 0a 3b 3b 20 20 20 ts to home.;;
18b0: 20 63 75 72 72 2d 70 61 67 65 20 20 20 20 3b 3b curr-page ;;
18c0: 20 74 68 65 20 63 75 72 72 65 6e 74 20 70 61 67 the current pag
18d0: 65 20 62 65 69 6e 67 20 65 76 61 6c 75 61 74 65 e being evaluate
18e0: 64 0a 3b 3b 20 20 20 20 63 6f 6e 74 65 6e 74 2d d.;; content-
18f0: 74 79 70 65 20 3b 3b 20 74 68 65 20 64 65 66 61 type ;; the defa
1900: 75 6c 74 20 63 6f 6e 74 65 6e 74 20 74 79 70 65 ult content type
1910: 20 69 73 20 74 65 78 74 2f 68 74 6d 6c 2c 20 6f is text/html, o
1920: 76 65 72 72 69 64 65 20 74 6f 20 64 65 6c 69 76 verride to deliv
1930: 65 72 20 6f 74 68 65 72 20 73 74 75 66 66 0a 3b er other stuff.;
1940: 3b 20 20 20 20 70 61 67 65 2d 74 79 70 65 20 20 ; page-type
1950: 20 20 3b 3b 20 75 73 65 20 69 6e 20 63 6f 6e 6a ;; use in conj
1960: 75 6e 63 74 69 6f 6e 20 77 69 74 68 20 63 6f 6e unction with con
1970: 74 65 6e 74 2d 74 79 70 65 20 74 6f 20 64 65 6c tent-type to del
1980: 69 76 65 72 20 6f 74 68 65 72 20 70 61 79 6c 6f iver other paylo
1990: 61 64 73 0a 3b 3b 20 20 20 20 73 72 6f 6f 74 0a ads.;; sroot.
19a0: 3b 3b 20 20 20 20 74 77 69 6b 69 64 69 72 20 20 ;; twikidir
19b0: 20 20 20 3b 3b 20 6c 6f 63 61 74 69 6f 6e 20 66 ;; location f
19c0: 6f 72 20 74 77 69 6b 69 73 20 2d 20 6e 65 65 64 or twikis - need
19d0: 73 20 74 6f 20 62 65 20 66 75 6c 6c 79 20 77 72 s to be fully wr
19e0: 69 74 61 62 6c 65 20 62 79 20 77 65 62 20 73 65 itable by web se
19f0: 72 76 65 72 0a 3b 3b 20 20 20 20 70 61 67 65 64 rver.;; paged
1a00: 61 74 0a 3b 3b 20 20 20 20 61 6c 74 2d 70 61 67 at.;; alt-pag
1a10: 65 2d 64 61 74 0a 3b 3b 20 20 20 20 70 61 67 65 e-dat.;; page
1a20: 76 61 72 73 20 20 20 20 20 3b 3b 20 73 65 73 73 vars ;; sess
1a30: 69 6f 6e 20 76 61 72 73 20 73 70 65 63 69 66 69 ion vars specifi
1a40: 63 20 74 6f 20 74 68 69 73 20 70 61 67 65 0a 3b c to this page.;
1a50: 3b 20 20 20 20 70 61 67 65 76 61 72 73 2d 62 65 ; pagevars-be
1a60: 66 6f 72 65 0a 3b 3b 20 20 20 20 73 65 73 73 69 fore.;; sessi
1a70: 6f 6e 76 61 72 73 20 20 3b 3b 20 73 65 73 73 69 onvars ;; sessi
1a80: 6f 6e 20 76 61 72 73 20 76 69 73 69 62 6c 65 20 on vars visible
1a90: 74 6f 20 61 6c 6c 20 70 61 67 65 73 0a 3b 3b 20 to all pages.;;
1aa0: 20 20 20 73 65 73 73 69 6f 6e 76 61 72 73 2d 62 sessionvars-b
1ab0: 65 66 6f 72 65 0a 3b 3b 20 20 20 20 67 6c 6f 62 efore.;; glob
1ac0: 61 6c 76 61 72 73 20 20 20 3b 3b 20 67 6c 6f 62 alvars ;; glob
1ad0: 61 6c 20 76 61 72 73 20 76 69 73 69 62 6c 65 20 al vars visible
1ae0: 74 6f 20 61 6c 6c 20 73 65 73 73 69 6f 6e 73 0a to all sessions.
1af0: 3b 3b 20 20 20 20 67 6c 6f 62 61 6c 76 61 72 73 ;; globalvars
1b00: 2d 62 65 66 6f 72 65 0a 3b 3b 20 20 20 20 6c 6f -before.;; lo
1b10: 67 70 74 0a 3b 3b 20 20 20 20 66 6f 72 6d 64 61 gpt.;; formda
1b20: 74 0a 3b 3b 20 20 20 20 72 65 71 75 65 73 74 2d t.;; request-
1b30: 6d 65 74 68 6f 64 0a 3b 3b 20 20 20 20 73 65 73 method.;; ses
1b40: 73 69 6f 6e 2d 63 6f 6f 6b 69 65 0a 3b 3b 20 20 sion-cookie.;;
1b50: 20 20 63 75 72 72 2d 65 72 72 0a 3b 3b 20 20 20 curr-err.;;
1b60: 20 6c 6f 67 2d 70 6f 72 74 0a 3b 3b 20 20 20 20 log-port.;;
1b70: 6c 6f 67 66 69 6c 65 0a 3b 3b 20 20 20 20 73 65 logfile.;; se
1b80: 65 6e 2d 70 61 67 65 73 0a 3b 3b 20 20 20 20 70 en-pages.;; p
1b90: 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 20 20 3b age-dir-style ;
1ba0: 3b 20 23 74 20 3d 20 6e 65 77 20 73 74 79 6c 65 ; #t = new style
1bb0: 2c 20 23 66 20 3d 20 6f 6c 64 20 73 74 79 6c 65 , #f = old style
1bc0: 0a 3b 3b 20 20 20 20 64 65 62 75 67 6d 6f 64 65 .;; debugmode
1bd0: 29 29 0a 0a 3b 3b 20 53 50 4c 49 54 20 49 4e 54 ))..;; SPLIT INT
1be0: 4f 20 53 54 52 41 49 47 48 54 20 46 4f 52 57 41 O STRAIGHT FORWA
1bf0: 52 44 20 49 4e 49 54 20 41 4e 44 20 43 4f 4d 50 RD INIT AND COMP
1c00: 4c 45 58 20 49 4e 49 54 0a 28 64 65 66 69 6e 65 LEX INIT.(define
1c10: 20 28 73 65 73 73 69 6f 6e 3a 69 6e 69 74 69 61 (session:initia
1c20: 6c 69 7a 65 20 73 65 6c 66 29 0a 20 20 28 73 64 lize self). (sd
1c30: 61 74 2d 73 65 74 2d 64 62 74 79 70 65 21 20 73 at-set-dbtype! s
1c40: 65 6c 66 20 20 20 20 20 20 27 70 67 29 0a 20 20 elf 'pg).
1c50: 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 21 20 (sdat-set-page!
1c60: 73 65 6c 66 20 20 20 20 20 20 20 20 22 68 6f 6d self "hom
1c70: 65 22 29 20 20 20 20 20 20 20 20 3b 3b 20 74 68 e") ;; th
1c80: 65 73 65 20 61 72 65 20 64 65 66 61 75 6c 74 73 ese are defaults
1c90: 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 63 75 72 . (sdat-set-cur
1ca0: 72 2d 70 61 67 65 21 20 73 65 6c 66 20 20 20 22 r-page! self "
1cb0: 68 6f 6d 65 22 29 0a 20 20 28 73 64 61 74 2d 73 home"). (sdat-s
1cc0: 65 74 2d 63 6f 6e 74 65 6e 74 2d 74 79 70 65 21 et-content-type!
1cd0: 20 73 65 6c 66 20 22 43 6f 6e 74 65 6e 74 2d 74 self "Content-t
1ce0: 79 70 65 3a 20 74 65 78 74 2f 68 74 6d 6c 3b 20 ype: text/html;
1cf0: 63 68 61 72 73 65 74 3d 69 73 6f 2d 38 38 35 39 charset=iso-8859
1d00: 2d 31 5c 6e 5c 6e 22 29 0a 20 20 28 73 64 61 74 -1\n\n"). (sdat
1d10: 2d 73 65 74 2d 70 61 67 65 2d 74 79 70 65 21 20 -set-page-type!
1d20: 73 65 6c 66 20 20 20 27 68 74 6d 6c 29 0a 20 20 self 'html).
1d30: 28 73 64 61 74 2d 73 65 74 2d 74 6f 70 70 61 67 (sdat-set-toppag
1d40: 65 21 20 73 65 6c 66 20 20 20 20 20 22 69 6e 64 e! self "ind
1d50: 65 78 22 29 0a 20 20 28 73 64 61 74 2d 73 65 74 ex"). (sdat-set
1d60: 2d 70 61 72 61 6d 73 21 20 73 65 6c 66 20 20 20 -params! self
1d70: 20 20 20 27 28 29 29 20 20 20 20 20 20 20 20 20 '())
1d80: 20 20 3b 3b 0a 20 20 28 73 64 61 74 2d 73 65 74 ;;. (sdat-set
1d90: 2d 70 61 74 68 2d 70 61 72 61 6d 73 21 20 73 65 -path-params! se
1da0: 6c 66 20 27 28 29 29 0a 20 20 28 73 64 61 74 2d lf '()). (sdat-
1db0: 73 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 21 set-session-key!
1dc0: 20 73 65 6c 66 20 23 66 29 0a 20 20 28 73 64 61 self #f). (sda
1dd0: 74 2d 73 65 74 2d 70 61 67 65 64 61 74 21 20 73 t-set-pagedat! s
1de0: 65 6c 66 20 20 20 20 20 27 28 29 29 0a 20 20 28 elf '()). (
1df0: 73 64 61 74 2d 73 65 74 2d 61 6c 74 2d 70 61 67 sdat-set-alt-pag
1e00: 65 2d 64 61 74 21 20 73 65 6c 66 20 23 66 29 0a e-dat! self #f).
1e10: 20 20 28 73 64 61 74 2d 73 65 74 2d 73 72 6f 6f (sdat-set-sroo
1e20: 74 21 20 73 65 6c 66 20 20 20 20 20 20 20 22 2e t! self ".
1e30: 2f 22 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d /"). (sdat-set-
1e40: 73 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 21 20 session-cookie!
1e50: 73 65 6c 66 20 23 66 29 0a 20 20 28 73 64 61 74 self #f). (sdat
1e60: 2d 73 65 74 2d 63 75 72 72 2d 65 72 72 21 20 73 -set-curr-err! s
1e70: 65 6c 66 20 23 66 29 0a 20 20 28 73 64 61 74 2d elf #f). (sdat-
1e80: 73 65 74 2d 6c 6f 67 2d 70 6f 72 74 21 20 73 65 set-log-port! se
1e90: 6c 66 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f lf (current-erro
1ea0: 72 2d 70 6f 72 74 29 29 0a 20 20 28 73 64 61 74 r-port)). (sdat
1eb0: 2d 73 65 74 2d 73 65 65 6e 2d 70 61 67 65 73 21 -set-seen-pages!
1ec0: 20 73 65 6c 66 20 27 28 29 29 0a 20 20 28 73 64 self '()). (sd
1ed0: 61 74 2d 73 65 74 2d 70 61 67 65 2d 64 69 72 2d at-set-page-dir-
1ee0: 73 74 79 6c 65 21 20 73 65 6c 66 20 23 74 29 20 style! self #t)
1ef0: 3b 3b 20 23 74 20 3a 20 70 61 67 65 73 2f 3c 70 ;; #t : pages/<p
1f00: 61 67 65 6e 61 6d 65 3e 5f 28 76 69 65 77 7c 63 agename>_(view|c
1f10: 6e 74 6c 29 2e 73 63 6d 0a 20 20 20 20 20 20 20 ntl).scm.
1f20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1f30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
1f40: 3b 20 23 66 20 3a 20 70 61 67 65 73 2f 3c 70 61 ; #f : pages/<pa
1f50: 67 65 6e 61 6d 65 3e 2f 28 76 69 65 77 7c 63 6f gename>/(view|co
1f60: 6e 74 72 6f 6c 29 2e 73 63 6d 20 0a 20 20 28 73 ntrol).scm . (s
1f70: 64 61 74 2d 73 65 74 2d 64 65 62 75 67 6d 6f 64 dat-set-debugmod
1f80: 65 21 20 20 20 20 20 20 20 20 20 20 73 65 6c 66 e! self
1f90: 20 23 66 29 0a 20 20 09 09 09 20 20 20 20 20 0a #f). ... .
1fa0: 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 (sdat-set-page
1fb0: 76 61 72 73 21 20 20 20 20 20 20 20 20 20 20 20 vars!
1fc0: 73 65 6c 66 20 28 6d 61 6b 65 2d 68 61 73 68 2d self (make-hash-
1fd0: 74 61 62 6c 65 29 29 0a 20 20 28 73 64 61 74 2d table)). (sdat-
1fe0: 73 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 21 set-sessionvars!
1ff0: 20 20 20 20 20 20 20 20 73 65 6c 66 20 28 6d 61 self (ma
2000: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
2010: 20 20 28 73 64 61 74 2d 73 65 74 2d 67 6c 6f 62 (sdat-set-glob
2020: 61 6c 76 61 72 73 21 20 20 20 20 20 20 20 20 20 alvars!
2030: 73 65 6c 66 20 28 6d 61 6b 65 2d 68 61 73 68 2d self (make-hash-
2040: 74 61 62 6c 65 29 29 0a 20 20 28 73 64 61 74 2d table)). (sdat-
2050: 73 65 74 2d 70 61 67 65 76 61 72 73 2d 62 65 66 set-pagevars-bef
2060: 6f 72 65 21 20 20 20 20 73 65 6c 66 20 28 6d 61 ore! self (ma
2070: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
2080: 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 (sdat-set-sess
2090: 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 21 20 ionvars-before!
20a0: 73 65 6c 66 20 28 6d 61 6b 65 2d 68 61 73 68 2d self (make-hash-
20b0: 74 61 62 6c 65 29 29 0a 20 20 28 73 64 61 74 2d table)). (sdat-
20c0: 73 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 2d 62 set-globalvars-b
20d0: 65 66 6f 72 65 21 20 20 73 65 6c 66 20 28 6d 61 efore! self (ma
20e0: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
20f0: 20 20 28 73 64 61 74 2d 73 65 74 2d 64 6f 6d 61 (sdat-set-doma
2100: 69 6e 21 20 20 20 20 20 20 20 20 20 20 20 20 20 in!
2110: 73 65 6c 66 20 22 6c 6f 63 61 68 6f 73 74 22 29 self "locahost")
2120: 20 20 20 3b 3b 20 65 6e 64 20 6f 66 20 64 65 66 ;; end of def
2130: 61 75 6c 74 73 0a 20 20 28 6c 65 74 2a 20 28 28 aults. (let* ((
2140: 72 61 77 63 6f 6e 66 69 67 64 61 74 20 28 73 65 rawconfigdat (se
2150: 73 73 69 6f 6e 3a 72 65 61 64 2d 63 6f 6e 66 69 ssion:read-confi
2160: 67 20 73 65 6c 66 29 29 0a 09 20 28 63 6f 6e 66 g self)).. (conf
2170: 69 67 64 61 74 20 28 69 66 20 72 61 77 63 6f 6e igdat (if rawcon
2180: 66 69 67 64 61 74 20 28 65 76 61 6c 20 72 61 77 figdat (eval raw
2190: 63 6f 6e 66 69 67 64 61 74 29 20 27 28 29 29 29 configdat) '()))
21a0: 0a 09 20 28 73 72 6f 6f 74 20 20 20 20 20 28 73 .. (sroot (s
21b0: 3a 66 69 6e 64 2d 70 61 72 61 6d 20 27 73 72 6f :find-param 'sro
21c0: 6f 74 20 20 20 20 63 6f 6e 66 69 67 64 61 74 29 ot configdat)
21d0: 29 0a 09 20 28 6c 6f 67 66 69 6c 65 20 20 20 28 ).. (logfile (
21e0: 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 27 6c 6f s:find-param 'lo
21f0: 67 66 69 6c 65 20 20 63 6f 6e 66 69 67 64 61 74 gfile configdat
2200: 29 29 0a 09 20 28 64 62 74 79 70 65 20 20 20 20 )).. (dbtype
2210: 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 27 64 (s:find-param 'd
2220: 62 74 79 70 65 20 20 20 63 6f 6e 66 69 67 64 61 btype configda
2230: 74 29 29 0a 09 20 28 64 62 69 6e 69 74 20 20 20 t)).. (dbinit
2240: 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 27 (s:find-param '
2250: 64 62 69 6e 69 74 20 20 20 63 6f 6e 66 69 67 64 dbinit configd
2260: 61 74 29 29 0a 09 20 28 64 6f 6d 61 69 6e 20 20 at)).. (domain
2270: 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 (s:find-param
2280: 27 64 6f 6d 61 69 6e 20 20 20 63 6f 6e 66 69 67 'domain config
2290: 64 61 74 29 29 0a 09 20 28 74 77 69 6b 69 64 69 dat)).. (twikidi
22a0: 72 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d r (s:find-param
22b0: 20 27 74 77 69 6b 69 64 69 72 20 63 6f 6e 66 69 'twikidir confi
22c0: 67 64 61 74 29 29 0a 09 20 28 70 61 67 65 2d 64 gdat)).. (page-d
22d0: 69 72 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 ir (s:find-para
22e0: 6d 20 27 70 61 67 65 2d 64 69 72 2d 73 74 79 6c m 'page-dir-styl
22f0: 65 20 63 6f 6e 66 69 67 64 61 74 29 29 0a 09 20 e configdat))..
2300: 28 64 65 62 75 67 6d 6f 64 65 20 28 73 3a 66 69 (debugmode (s:fi
2310: 6e 64 2d 70 61 72 61 6d 20 27 64 65 62 75 67 6d nd-param 'debugm
2320: 6f 64 65 20 63 6f 6e 66 69 67 64 61 74 29 29 29 ode configdat)))
2330: 0a 20 20 20 20 28 69 66 20 73 72 6f 6f 74 20 20 . (if sroot
2340: 20 20 28 73 64 61 74 2d 73 65 74 2d 73 72 6f 6f (sdat-set-sroo
2350: 74 21 20 20 20 20 73 65 6c 66 20 73 72 6f 6f 74 t! self sroot
2360: 29 29 0a 20 20 20 20 28 69 66 20 6c 6f 67 66 69 )). (if logfi
2370: 6c 65 20 20 28 73 64 61 74 2d 73 65 74 2d 6c 6f le (sdat-set-lo
2380: 67 66 69 6c 65 21 20 20 73 65 6c 66 20 6c 6f 67 gfile! self log
2390: 66 69 6c 65 29 29 0a 20 20 20 20 28 69 66 20 64 file)). (if d
23a0: 62 74 79 70 65 20 20 20 28 73 64 61 74 2d 73 65 btype (sdat-se
23b0: 74 2d 64 62 74 79 70 65 21 20 20 20 73 65 6c 66 t-dbtype! self
23c0: 20 64 62 74 79 70 65 29 29 0a 20 20 20 20 28 69 dbtype)). (i
23d0: 66 20 64 62 69 6e 69 74 20 20 20 28 73 64 61 74 f dbinit (sdat
23e0: 2d 73 65 74 2d 64 62 69 6e 69 74 21 20 20 20 73 -set-dbinit! s
23f0: 65 6c 66 20 64 62 69 6e 69 74 29 29 0a 20 20 20 elf dbinit)).
2400: 20 28 69 66 20 64 6f 6d 61 69 6e 20 20 20 28 73 (if domain (s
2410: 64 61 74 2d 73 65 74 2d 64 6f 6d 61 69 6e 21 20 dat-set-domain!
2420: 20 20 73 65 6c 66 20 64 6f 6d 61 69 6e 29 29 0a self domain)).
2430: 20 20 20 20 28 69 66 20 74 77 69 6b 69 64 69 72 (if twikidir
2440: 20 28 73 64 61 74 2d 73 65 74 2d 74 77 69 6b 69 (sdat-set-twiki
2450: 64 69 72 21 20 73 65 6c 66 20 74 77 69 6b 69 64 dir! self twikid
2460: 69 72 29 29 0a 20 20 20 20 28 69 66 20 64 65 62 ir)). (if deb
2470: 75 67 6d 6f 64 65 20 28 73 64 61 74 2d 73 65 74 ugmode (sdat-set
2480: 2d 64 65 62 75 67 6d 6f 64 65 21 20 73 65 6c 66 -debugmode! self
2490: 20 64 65 62 75 67 6d 6f 64 65 29 29 0a 20 20 20 debugmode)).
24a0: 20 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 2d (sdat-set-page-
24b0: 64 69 72 2d 73 74 79 6c 65 21 20 73 65 6c 66 20 dir-style! self
24c0: 70 61 67 65 2d 64 69 72 29 0a 20 20 20 20 3b 3b page-dir). ;;
24d0: 20 28 70 72 69 6e 74 20 22 63 6f 6e 66 69 67 64 (print "configd
24e0: 61 74 3a 20 22 29 28 70 70 20 63 6f 6e 66 69 67 at: ")(pp config
24f0: 64 61 74 29 0a 20 20 20 20 3b 3b 28 73 65 73 73 dat). ;;(sess
2500: 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 73 72 ion:log self "sr
2510: 6f 6f 74 3a 20 22 20 73 72 6f 6f 74 20 22 20 6c oot: " sroot " l
2520: 6f 67 66 69 6c 65 3a 20 22 20 6c 6f 67 66 69 6c ogfile: " logfil
2530: 65 20 22 20 64 62 74 79 70 65 3a 20 22 20 64 62 e " dbtype: " db
2540: 74 79 70 65 20 0a 20 20 20 20 3b 3b 09 09 20 22 type . ;;.. "
2550: 20 64 62 69 6e 69 74 3a 20 22 20 64 62 69 6e 69 dbinit: " dbini
2560: 74 20 22 20 64 6f 6d 61 69 6e 3a 20 22 20 64 6f t " domain: " do
2570: 6d 61 69 6e 20 22 20 70 61 67 65 2d 64 69 72 2d main " page-dir-
2580: 73 74 79 6c 65 3a 20 22 20 70 61 67 65 2d 64 69 style: " page-di
2590: 72 29 0a 20 20 20 20 29 0a 20 20 29 0a 3b 3b 20 r). ). ).;;
25a0: 20 20 28 6c 65 74 20 28 28 64 62 74 79 70 65 20 (let ((dbtype
25b0: 28 73 64 61 74 2d 67 65 74 2d 64 62 74 79 70 65 (sdat-get-dbtype
25c0: 20 73 65 6c 66 29 29 29 0a 3b 3b 20 20 20 20 20 self))).;;
25d0: 28 70 72 69 6e 74 20 22 64 62 74 79 70 65 3a 20 (print "dbtype:
25e0: 22 20 64 62 74 79 70 65 29 0a 3b 3b 20 20 20 20 " dbtype).;;
25f0: 20 28 73 64 61 74 2d 73 65 74 2d 64 62 74 79 70 (sdat-set-dbtyp
2600: 65 21 20 73 65 6c 66 20 28 65 76 61 6c 20 64 62 e! self (eval db
2610: 74 79 70 65 29 29 29 29 0a 0a 28 64 65 66 69 6e type))))..(defin
2620: 65 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 e (session:setup
2630: 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 self). (let ((
2640: 64 62 74 79 70 65 20 28 73 64 61 74 2d 67 65 74 dbtype (sdat-get
2650: 2d 64 62 74 79 70 65 20 73 65 6c 66 29 29 0a 09 -dbtype self))..
2660: 28 64 62 69 6e 69 74 20 28 65 76 61 6c 20 28 73 (dbinit (eval (s
2670: 64 61 74 2d 67 65 74 2d 64 62 69 6e 69 74 20 73 dat-get-dbinit s
2680: 65 6c 66 29 29 29 0a 09 28 64 62 65 78 69 73 74 elf)))..(dbexist
2690: 73 20 23 66 29 29 0a 20 20 20 20 28 6c 65 74 20 s #f)). (let
26a0: 28 28 64 62 66 6e 61 6d 65 20 28 61 6c 69 73 74 ((dbfname (alist
26b0: 2d 72 65 66 20 27 64 62 6e 61 6d 65 20 64 62 69 -ref 'dbname dbi
26c0: 6e 69 74 29 29 29 0a 20 20 20 20 20 20 28 69 66 nit))). (if
26d0: 20 28 65 71 3f 20 64 62 74 79 70 65 20 27 73 71 (eq? dbtype 'sq
26e0: 6c 69 74 65 33 29 0a 09 20 20 28 69 66 20 28 66 lite3).. (if (f
26f0: 69 6c 65 2d 65 78 69 73 74 73 3f 20 64 62 66 6e ile-exists? dbfn
2700: 61 6d 65 29 0a 09 20 20 20 20 20 20 28 62 65 67 ame).. (beg
2710: 69 6e 0a 09 09 3b 3b 20 28 73 65 73 73 69 6f 6e in...;; (session
2720: 3a 6c 6f 67 20 73 65 6c 66 20 22 73 65 74 74 69 :log self "setti
2730: 6e 67 20 64 62 65 78 69 73 74 73 20 74 6f 20 23 ng dbexists to #
2740: 74 22 29 0a 09 09 28 73 65 74 21 20 64 62 65 78 t")...(set! dbex
2750: 69 73 74 73 20 23 74 29 29 29 29 0a 20 20 20 20 ists #t)))).
2760: 20 20 3b 3b 20 28 73 65 73 73 69 6f 6e 3a 6c 6f ;; (session:lo
2770: 67 20 73 65 6c 66 20 22 64 62 74 79 70 65 3a 20 g self "dbtype:
2780: 22 20 64 62 74 79 70 65 20 22 20 64 62 66 6e 61 " dbtype " dbfna
2790: 6d 65 3a 20 22 20 64 62 66 6e 61 6d 65 20 22 20 me: " dbfname "
27a0: 64 62 65 78 69 73 74 73 3a 20 22 20 64 62 65 78 dbexists: " dbex
27b0: 69 73 74 73 29 29 0a 20 20 20 20 20 20 29 0a 20 ists)). ).
27c0: 20 20 20 28 73 64 61 74 2d 73 65 74 2d 63 6f 6e (sdat-set-con
27d0: 6e 21 20 73 65 6c 66 20 28 64 62 69 3a 6f 70 65 n! self (dbi:ope
27e0: 6e 20 64 62 74 79 70 65 20 64 62 69 6e 69 74 29 n dbtype dbinit)
27f0: 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 ). (if (and (
2800: 6e 6f 74 20 64 62 65 78 69 73 74 73 29 28 65 71 not dbexists)(eq
2810: 3f 20 64 62 74 79 70 65 20 27 73 71 6c 69 74 65 ? dbtype 'sqlite
2820: 33 29 29 0a 20 09 28 62 65 67 69 6e 0a 09 20 20 3)). .(begin..
2830: 28 70 72 69 6e 74 20 22 57 41 52 4e 49 4e 47 3a (print "WARNING:
2840: 20 53 65 74 74 69 6e 67 20 75 70 20 73 65 73 73 Setting up sess
2850: 69 6f 6e 20 64 62 20 77 69 74 68 20 73 71 6c 69 ion db with sqli
2860: 74 65 33 22 29 0a 09 20 20 28 73 65 73 73 69 6f te3").. (sessio
2870: 6e 3a 73 65 74 75 70 2d 64 62 20 73 65 6c 66 29 n:setup-db self)
2880: 29 29 0a 20 20 20 20 28 73 65 73 73 69 6f 6e 3a )). (session:
2890: 70 72 6f 63 65 73 73 2d 75 72 6c 2d 70 61 74 68 process-url-path
28a0: 20 73 65 6c 66 29 0a 20 20 20 20 28 73 65 73 73 self). (sess
28b0: 69 6f 6e 3a 73 65 74 75 70 2d 73 65 73 73 69 6f ion:setup-sessio
28c0: 6e 2d 6b 65 79 20 73 65 6c 66 29 0a 20 20 20 20 n-key self).
28d0: 3b 3b 20 63 61 70 74 75 72 65 20 73 74 64 69 6e ;; capture stdin
28e0: 20 69 66 20 74 68 69 73 20 69 73 20 61 20 50 4f if this is a PO
28f0: 53 54 0a 20 20 20 20 28 73 64 61 74 2d 73 65 74 ST. (sdat-set
2900: 2d 72 65 71 75 65 73 74 2d 6d 65 74 68 6f 64 21 -request-method!
2910: 20 73 65 6c 66 20 28 67 65 74 2d 65 6e 76 69 72 self (get-envir
2920: 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 onment-variable
2930: 22 52 45 51 55 45 53 54 5f 4d 45 54 48 4f 44 22 "REQUEST_METHOD"
2940: 29 29 0a 20 20 20 20 28 73 64 61 74 2d 73 65 74 )). (sdat-set
2950: 2d 66 6f 72 6d 64 61 74 21 20 73 65 6c 66 20 28 -formdat! self (
2960: 66 6f 72 6d 64 61 74 3a 6c 6f 61 64 2d 61 6c 6c formdat:load-all
2970: 29 29 29 29 0a 0a 3b 3b 20 73 65 74 75 70 20 74 ))))..;; setup t
2980: 68 65 20 64 62 20 77 69 74 68 20 73 65 73 73 69 he db with sessi
2990: 6f 6e 20 74 61 62 6c 65 73 2c 20 77 6f 72 6b 73 on tables, works
29a0: 20 66 6f 72 20 73 71 6c 69 74 65 20 6f 6e 6c 79 for sqlite only
29b0: 20 72 69 67 68 74 20 6e 6f 77 0a 28 64 65 66 69 right now.(defi
29c0: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 75 ne (session:setu
29d0: 70 2d 64 62 20 73 65 6c 66 29 0a 20 20 28 6c 65 p-db self). (le
29e0: 74 20 28 28 63 6f 6e 6e 20 28 73 64 61 74 2d 67 t ((conn (sdat-g
29f0: 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 29 0a et-conn self))).
2a00: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 (for-each .
2a10: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 73 74 6d (lambda (stm
2a20: 74 29 0a 20 20 20 20 20 20 20 28 64 62 69 3a 65 t). (dbi:e
2a30: 78 65 63 20 63 6f 6e 6e 20 73 74 6d 74 29 29 0a xec conn stmt)).
2a40: 20 20 20 20 20 28 6c 69 73 74 20 22 43 52 45 41 (list "CREA
2a50: 54 45 20 54 41 42 4c 45 20 73 65 73 73 69 6f 6e TE TABLE session
2a60: 5f 76 61 72 73 20 28 69 64 20 49 4e 54 45 47 45 _vars (id INTEGE
2a70: 52 20 50 52 49 4d 41 52 59 20 4b 45 59 2c 73 65 R PRIMARY KEY,se
2a80: 73 73 69 6f 6e 5f 69 64 20 49 4e 54 45 47 45 52 ssion_id INTEGER
2a90: 2c 70 61 67 65 20 54 45 58 54 2c 6b 65 79 20 54 ,page TEXT,key T
2aa0: 45 58 54 2c 76 61 6c 75 65 20 54 45 58 54 29 3b EXT,value TEXT);
2ab0: 22 0a 09 20 20 20 22 43 52 45 41 54 45 20 54 41 ".. "CREATE TA
2ac0: 42 4c 45 20 73 65 73 73 69 6f 6e 73 20 28 69 64 BLE sessions (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 6b 65 79 KEY,session_key
2af0: 20 54 45 58 54 2c 6c 61 73 74 5f 75 73 65 64 20 TEXT,last_used
2b00: 54 49 4d 45 53 54 41 4d 50 29 3b 22 0a 20 20 20 TIMESTAMP);".
2b10: 20 20 20 20 20 20 20 20 22 43 52 45 41 54 45 20 "CREATE
2b20: 54 41 42 4c 45 20 6d 65 74 61 64 61 74 61 20 28 TABLE metadata (
2b30: 69 64 20 49 4e 54 45 47 45 52 20 50 52 49 4d 41 id INTEGER PRIMA
2b40: 52 59 20 4b 45 59 2c 6b 65 79 20 54 45 58 54 2c RY KEY,key TEXT,
2b50: 76 61 6c 75 65 20 54 45 58 54 29 3b 22 29 29 29 value TEXT);")))
2b60: 29 0a 3b 3b 20 20 3b 3b 20 69 66 20 77 65 20 68 ).;; ;; if we h
2b70: 61 76 65 20 61 20 73 65 73 73 69 6f 6e 5f 6b 65 ave a session_ke
2b80: 79 20 6c 6f 6f 6b 20 75 70 20 74 68 65 20 73 65 y look up the se
2b90: 73 73 69 6f 6e 2d 69 64 20 61 6e 64 20 73 74 6f ssion-id and sto
2ba0: 72 65 20 69 74 0a 3b 3b 20 20 28 73 64 61 74 2d re it.;; (sdat-
2bb0: 73 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 21 20 set-session-id!
2bc0: 73 65 6c 66 20 28 73 65 73 73 69 6f 6e 3a 67 65 self (session:ge
2bd0: 74 2d 69 64 20 73 65 6c 66 29 29 29 0a 0a 3b 3b t-id self)))..;;
2be0: 20 6f 6e 6c 79 20 73 65 74 20 73 65 73 73 69 6f only set sessio
2bf0: 6e 2d 63 6f 6f 6b 69 65 20 77 68 65 6e 20 61 20 n-cookie when a
2c00: 6e 65 77 20 73 65 73 73 69 6f 6e 20 69 73 20 63 new session is c
2c10: 72 65 61 74 65 64 0a 28 64 65 66 69 6e 65 20 28 reated.(define (
2c20: 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 2d 73 65 session:setup-se
2c30: 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 20 ssion-key self)
2c40: 20 0a 20 20 28 6c 65 74 2a 20 28 28 73 6b 20 20 . (let* ((sk
2c50: 28 73 65 73 73 69 6f 6e 3a 65 78 74 72 61 63 74 (session:extract
2c60: 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c -session-key sel
2c70: 66 29 29 0a 20 20 20 20 20 20 20 20 20 28 73 69 f)). (si
2c80: 64 20 28 69 66 20 73 6b 20 28 73 65 73 73 69 6f d (if sk (sessio
2c90: 6e 3a 67 65 74 2d 69 64 20 73 65 6c 66 20 73 6b n:get-id self sk
2ca0: 29 20 23 66 29 29 29 0a 20 20 20 20 28 69 66 20 ) #f))). (if
2cb0: 28 6e 6f 74 20 73 69 64 29 20 3b 3b 20 6e 65 65 (not sid) ;; nee
2cc0: 64 20 61 20 6e 65 77 20 6b 65 79 0a 20 20 20 20 d a new key.
2cd0: 20 20 20 20 28 6c 65 74 2a 20 28 28 6e 65 77 2d (let* ((new-
2ce0: 6b 65 79 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 key (session:get
2cf0: 2d 6e 65 77 2d 6b 65 79 20 73 65 6c 66 29 29 0a -new-key self)).
2d00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
2d10: 6e 65 77 2d 73 69 64 20 28 73 65 73 73 69 6f 6e new-sid (session
2d20: 3a 67 65 74 2d 69 64 20 73 65 6c 66 20 6e 65 77 :get-id self new
2d30: 2d 6b 65 79 29 29 29 0a 20 20 20 20 20 20 20 20 -key))).
2d40: 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 (sdat-set-sess
2d50: 69 6f 6e 2d 6b 65 79 21 20 73 65 6c 66 20 6e 65 ion-key! self ne
2d60: 77 2d 6b 65 79 29 0a 20 20 20 20 20 20 20 20 20 w-key).
2d70: 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 (sdat-set-sessi
2d80: 6f 6e 2d 69 64 21 20 73 65 6c 66 20 6e 65 77 2d on-id! self new-
2d90: 73 69 64 29 0a 20 20 20 20 20 20 20 20 20 20 28 sid). (
2da0: 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e sdat-set-session
2db0: 2d 63 6f 6f 6b 69 65 21 20 73 65 6c 66 20 28 73 -cookie! self (s
2dc0: 65 73 73 69 6f 6e 3a 6d 61 6b 65 2d 63 6f 6f 6b ession:make-cook
2dd0: 69 65 20 73 65 6c 66 29 29 29 0a 20 20 20 20 20 ie self))).
2de0: 20 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 (sdat-set-ses
2df0: 73 69 6f 6e 2d 69 64 21 20 73 65 6c 66 20 73 69 sion-id! self si
2e00: 64 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 d))))..(define (
2e10: 73 65 73 73 69 6f 6e 3a 6d 61 6b 65 2d 63 6f 6f session:make-coo
2e20: 6b 69 65 20 73 65 6c 66 29 0a 20 20 3b 3b 20 28 kie self). ;; (
2e30: 6c 69 73 74 20 28 63 6f 6e 63 20 22 73 65 73 73 list (conc "sess
2e40: 69 6f 6e 5f 6b 65 79 3d 22 20 28 73 64 61 74 2d ion_key=" (sdat-
2e50: 67 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 get-session-key
2e60: 73 65 6c 66 29 20 22 3b 20 50 61 74 68 3d 2f 3b self) "; Path=/;
2e70: 20 44 6f 6d 61 69 6e 3d 2e 22 20 28 73 64 61 74 Domain=." (sdat
2e80: 2d 67 65 74 2d 64 6f 6d 61 69 6e 20 73 65 6c 66 -get-domain self
2e90: 29 20 22 3b 20 4d 61 78 2d 41 67 65 3d 22 20 28 ) "; Max-Age=" (
2ea0: 2a 20 38 36 34 30 30 20 31 34 29 20 22 3b 20 56 * 86400 14) "; V
2eb0: 65 72 73 69 6f 6e 3d 31 22 29 29 29 20 0a 20 20 ersion=1"))) .
2ec0: 3b 3b 20 41 63 63 6f 72 64 69 6e 67 20 74 6f 20 ;; According to
2ed0: 0a 20 20 3b 3b 20 20 20 20 68 74 74 70 3a 2f 2f . ;; http://
2ee0: 77 77 77 2e 63 6f 64 65 6d 61 72 76 65 6c 73 2e www.codemarvels.
2ef0: 63 6f 6d 2f 32 30 31 30 2f 31 31 2f 61 70 61 63 com/2010/11/apac
2f00: 68 65 2d 72 65 77 72 69 74 65 72 75 6c 65 2d 73 he-rewriterule-s
2f10: 65 74 2d 61 2d 63 6f 6f 6b 69 65 2d 6f 6e 2d 6c et-a-cookie-on-l
2f20: 6f 63 61 6c 68 6f 73 74 2f 0a 0a 20 20 3b 3b 20 ocalhost/.. ;;
2f30: 20 48 65 72 65 20 61 72 65 20 74 68 65 20 32 20 Here are the 2
2f40: 28 6f 66 74 65 6e 20 6c 65 66 74 20 6f 75 74 29 (often left out)
2f50: 20 72 65 71 75 69 72 65 6d 65 6e 74 73 20 74 6f requirements to
2f60: 20 73 65 74 20 61 20 63 6f 6f 6b 69 65 20 75 73 set a cookie us
2f70: 69 6e 67 0a 20 20 3b 3b 20 20 68 74 74 70 64 1b ing. ;; httpd.
2f80: 2d 46 a2 73 20 72 65 77 72 69 74 65 20 72 75 6c -F˘s rewrite rul
2f90: 65 20 28 6d 6f 64 5f 72 65 77 72 69 74 65 29 2c e (mod_rewrite),
2fa0: 20 77 68 69 6c 65 20 77 6f 72 6b 69 6e 67 20 6f while working o
2fb0: 6e 20 6c 6f 63 61 6c 68 6f 73 74 3a 1b 2d 41 0a n localhost:.-A.
2fc0: 20 20 3b 3b 0a 20 20 3b 3b 20 20 55 73 65 20 74 ;;. ;; Use t
2fd0: 68 65 20 49 50 20 31 32 37 2e 30 2e 30 2e 31 20 he IP 127.0.0.1
2fe0: 69 6e 73 74 65 61 64 20 6f 66 20 6c 6f 63 61 6c instead of local
2ff0: 68 6f 73 74 2f 6d 61 63 68 69 6e 65 2d 6e 61 6d host/machine-nam
3000: 65 20 61 73 20 74 68 65 0a 20 20 3b 3b 20 20 64 e as the. ;; d
3010: 6f 6d 61 69 6e 3b 20 65 2e 67 2e 20 5b 43 4f 3d omain; e.g. [CO=
3020: 73 6f 6d 65 43 6f 6f 6b 69 65 3a 73 6f 6d 65 56 someCookie:someV
3030: 61 6c 75 65 3a 31 32 37 2e 30 2e 30 2e 31 3a 32 alue:127.0.0.1:2
3040: 3a 2f 5d 2c 20 77 68 69 63 68 20 73 61 79 73 0a :/], which says.
3050: 20 20 3b 3b 20 20 63 72 65 61 74 65 20 61 20 63 ;; create a c
3060: 6f 6f 6b 69 65 20 1b 2d 59 b4 73 6f 6d 65 43 6f ookie .-Y´someCo
3070: 6f 6b 69 65 a1 20 77 69 74 68 20 76 61 6c 75 65 okieˇ with value
3080: 20 b4 73 6f 6d 65 56 61 6c 75 65 a1 20 66 6f 72 ´someValueˇ for
3090: 20 74 68 65 0a 20 20 3b 3b 20 20 64 6f 6d 61 69 the. ;; domai
30a0: 6e 20 b4 31 32 37 2e 30 2e 30 2e 31 1b 24 42 21 n ´127.0.0.1.$B!
30b0: 6d 1b 28 42 20 68 61 76 69 6e 67 20 61 20 6c 69 m.(B having a li
30c0: 66 65 20 74 69 6d 65 20 6f 66 20 32 20 6d 69 6e fe time of 2 min
30d0: 73 2c 20 66 6f 72 20 61 6e 79 20 70 61 74 68 20 s, for any path
30e0: 69 6e 0a 20 20 3b 3b 20 20 74 68 65 20 64 6f 6d in. ;; the dom
30f0: 61 69 6e 20 28 70 61 74 68 3d 2f 29 2e 20 28 4f ain (path=/). (O
3100: 62 76 69 6f 75 73 6c 79 20 79 6f 75 20 77 69 6c bviously you wil
3110: 6c 20 68 61 76 65 20 74 6f 20 72 75 6e 20 74 68 l have to run th
3120: 65 0a 20 20 3b 3b 20 20 61 70 70 6c 69 63 61 74 e. ;; applicat
3130: 69 6f 6e 20 77 69 74 68 20 74 68 69 73 20 76 61 ion with this va
3140: 6c 75 65 20 69 6e 20 74 68 65 20 55 52 4c 29 0a lue in the URL).
3150: 20 20 3b 3b 0a 20 20 3b 3b 20 20 54 6f 20 6d 61 ;;. ;; To ma
3160: 6b 65 20 61 20 73 65 73 73 69 6f 6e 20 63 6f 6f ke a session coo
3170: 6b 69 65 2c 20 6c 69 6d 69 74 20 74 68 65 20 66 kie, limit the f
3180: 6c 61 67 20 73 74 61 74 65 6d 65 6e 74 20 74 6f lag statement to
3190: 20 6a 75 73 74 20 74 68 72 65 65 0a 20 20 3b 3b just three. ;;
31a0: 20 20 61 74 74 72 69 62 75 74 65 73 3a 20 6e 61 attributes: na
31b0: 6d 65 2c 20 76 61 6c 75 65 20 61 6e 64 20 64 6f me, value and do
31c0: 6d 61 69 6e 2e 20 65 2e 67 0a 20 20 3b 3b 20 20 main. e.g. ;;
31d0: 5b 43 4f 3d 73 6f 6d 65 43 6f 6f 6b 69 65 3a 73 [CO=someCookie:s
31e0: 6f 6d 65 56 61 6c 75 65 3a 31 32 37 2e 30 2e 30 omeValue:127.0.0
31f0: 2e 31 5d 20 1b 25 47 e2 80 93 1b 25 40 20 41 6e .1] .%G–.%@ An
3200: 79 20 66 75 72 74 68 65 72 0a 20 20 3b 3b 20 20 y further. ;;
3210: 73 65 74 74 69 6e 67 73 2c 20 61 70 61 63 68 65 settings, apache
3220: 20 77 72 69 74 65 73 20 61 6e a1 20 65 78 70 69 writes anˇ expi
3230: 72 65 73 a1 20 61 74 74 72 69 62 75 74 65 20 66 resˇ attribute f
3240: 6f 72 20 74 68 65 20 73 65 74 2d 63 6f 6f 6b 69 or the set-cooki
3250: 65 0a 20 20 3b 3b 20 20 68 65 61 64 65 72 2c 20 e. ;; header,
3260: 77 68 69 63 68 20 6d 61 6b 65 73 20 74 68 65 20 which makes the
3270: 63 6f 6f 6b 69 65 20 61 20 70 65 72 73 69 73 74 cookie a persist
3280: 65 6e 74 20 6f 6e 65 20 28 6e 6f 74 20 72 65 61 ent one (not rea
3290: 6c 6c 79 0a 20 20 3b 3b 20 20 70 65 72 73 69 73 lly. ;; persis
32a0: 74 65 6e 74 2c 20 61 73 20 74 68 65 20 65 78 70 tent, as the exp
32b0: 69 72 65 73 20 76 61 6c 75 65 20 73 65 74 20 69 ires value set i
32c0: 73 20 74 68 65 20 63 75 72 72 65 6e 74 20 73 65 s the current se
32d0: 72 76 65 72 20 74 69 6d 65 0a 20 20 3b 3b 20 20 rver time. ;;
32e0: 1b 25 47 e2 80 93 1b 25 40 20 73 6f 20 79 6f 75 .%G–.%@ so you
32f0: 20 64 6f 6e 1b 2d 46 1b 2d 46 a2 74 20 65 76 65 don.-F.-F˘t eve
3300: 6e 20 67 65 74 20 74 6f 20 73 65 65 20 79 6f 75 n get to see you
3310: 72 20 63 6f 6f 6b 69 65 21 29 1b 2d 41 0a 20 20 r cookie!).-A.
3320: 28 6c 69 73 74 20 28 73 74 72 69 6e 67 2d 73 75 (list (string-su
3330: 62 73 74 69 74 75 74 65 20 0a 09 20 22 3b 22 20 bstitute .. ";"
3340: 22 3b 20 22 20 0a 09 20 28 63 61 72 20 28 63 6f "; " .. (car (co
3350: 6e 73 74 72 75 63 74 2d 63 6f 6f 6b 69 65 2d 73 nstruct-cookie-s
3360: 74 72 69 6e 67 20 0a 09 20 20 20 20 20 20 20 3b tring .. ;
3370: 3b 20 77 61 72 6e 69 6e 67 21 20 6d 65 73 73 69 ; warning! messi
3380: 6e 67 20 75 70 20 74 68 69 73 20 69 74 74 79 20 ng up this itty
3390: 62 69 74 74 79 20 62 69 74 20 6f 66 20 63 6f 64 bitty bit of cod
33a0: 65 20 77 69 6c 6c 20 63 6f 73 74 20 6d 75 63 68 e will cost much
33b0: 20 74 69 6d 65 21 0a 09 20 20 20 20 20 20 20 60 time!.. `
33c0: 28 28 22 73 65 73 73 69 6f 6e 5f 6b 65 79 22 20 (("session_key"
33d0: 2c 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 ,(sdat-get-sessi
33e0: 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 0a 09 09 20 on-key self)...
33f0: 20 65 78 70 69 72 65 73 3a 20 2c 28 2b 20 28 63 expires: ,(+ (c
3400: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 urrent-seconds)
3410: 28 2a 20 31 34 20 38 36 34 30 30 29 29 20 0a 09 (* 14 86400)) ..
3420: 09 20 20 3b 3b 20 6d 61 78 2d 61 67 65 3a 20 28 . ;; max-age: (
3430: 2a 20 31 34 20 38 36 34 30 30 29 0a 09 09 20 20 * 14 86400)...
3440: 70 61 74 68 3a 20 22 2f 22 20 3b 3b 20 0a 09 09 path: "/" ;; ...
3450: 20 20 64 6f 6d 61 69 6e 3a 20 2c 28 73 74 72 69 domain: ,(stri
3460: 6e 67 2d 61 70 70 65 6e 64 20 22 2e 22 20 28 73 ng-append "." (s
3470: 64 61 74 2d 67 65 74 2d 64 6f 6d 61 69 6e 20 73 dat-get-domain s
3480: 65 6c 66 29 29 0a 09 09 20 20 76 65 72 73 69 6f elf))... versio
3490: 6e 3a 20 31 29 29 20 30 29 29 29 29 29 0a 0a 3b n: 1)) 0)))))..;
34a0: 3b 20 6c 6f 6f 6b 20 75 70 20 61 20 67 69 76 65 ; look up a give
34b0: 6e 20 73 65 73 73 69 6f 6e 20 6b 65 79 20 61 6e n session key an
34c0: 64 20 72 65 74 75 72 6e 20 74 68 65 20 69 64 20 d return the id
34d0: 69 66 20 66 6f 75 6e 64 2c 20 23 66 20 69 66 20 if found, #f if
34e0: 6e 6f 74 20 66 6f 75 6e 64 0a 28 64 65 66 69 6e not found.(defin
34f0: 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 69 e (session:get-i
3500: 64 20 73 65 6c 66 20 73 65 73 73 69 6f 6e 2d 6b d self session-k
3510: 65 79 29 0a 20 20 3b 3b 20 28 6c 65 74 20 28 28 ey). ;; (let ((
3520: 73 65 73 73 69 6f 6e 2d 6b 65 79 20 28 73 64 61 session-key (sda
3530: 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 t-get-session-ke
3540: 79 20 73 65 6c 66 29 29 29 0a 20 20 28 69 66 20 y self))). (if
3550: 73 65 73 73 69 6f 6e 2d 6b 65 79 0a 20 20 20 20 session-key.
3560: 20 20 28 6c 65 74 20 28 28 71 75 65 72 79 20 28 (let ((query (
3570: 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 22 53 string-append "S
3580: 45 4c 45 43 54 20 69 64 20 46 52 4f 4d 20 73 65 ELECT id FROM se
3590: 73 73 69 6f 6e 73 20 57 48 45 52 45 20 73 65 73 ssions WHERE ses
35a0: 73 69 6f 6e 5f 6b 65 79 3d 27 22 20 73 65 73 73 sion_key='" sess
35b0: 69 6f 6e 2d 6b 65 79 20 22 27 22 29 29 0a 20 20 ion-key "'")).
35c0: 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 6e 20 (conn
35d0: 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 (sdat-get-conn s
35e0: 65 6c 66 29 29 0a 20 20 20 20 20 20 20 20 20 20 elf)).
35f0: 20 20 28 72 65 73 75 6c 74 20 23 66 29 29 0a 09 (result #f))..
3600: 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f (dbi:for-each-ro
3610: 77 20 0a 09 20 28 6c 61 6d 62 64 61 20 28 74 75 w .. (lambda (tu
3620: 70 6c 65 29 0a 09 20 20 20 28 73 65 74 21 20 72 ple).. (set! r
3630: 65 73 75 6c 74 20 28 76 65 63 74 6f 72 2d 72 65 esult (vector-re
3640: 66 20 74 75 70 6c 65 20 30 29 29 29 0a 09 20 63 f tuple 0))).. c
3650: 6f 6e 6e 20 71 75 65 72 79 29 0a 09 28 69 66 20 onn query)..(if
3660: 72 65 73 75 6c 74 20 28 64 62 69 3a 65 78 65 63 result (dbi:exec
3670: 20 63 6f 6e 6e 20 28 63 6f 6e 63 20 22 55 50 44 conn (conc "UPD
3680: 41 54 45 20 73 65 73 73 69 6f 6e 73 20 53 45 54 ATE sessions SET
3690: 20 6c 61 73 74 5f 75 73 65 64 3d 22 20 28 64 62 last_used=" (db
36a0: 69 3a 6e 6f 77 20 63 6f 6e 6e 29 20 22 20 57 48 i:now conn) " WH
36b0: 45 52 45 20 73 65 73 73 69 6f 6e 5f 6b 65 79 3d ERE session_key=
36c0: 3f 3b 22 29 20 73 65 73 73 69 6f 6e 2d 6b 65 79 ?;") session-key
36d0: 29 29 0a 20 20 20 20 20 20 20 20 72 65 73 75 6c )). resul
36e0: 74 29 0a 20 20 20 20 20 20 23 66 29 29 0a 0a 3b t). #f))..;
36f0: 3b 20 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 ; .(define (sess
3700: 69 6f 6e 3a 70 72 6f 63 65 73 73 2d 75 72 6c 2d ion:process-url-
3710: 70 61 74 68 20 73 65 6c 66 29 0a 20 20 28 6c 65 path self). (le
3720: 74 20 28 28 70 61 74 68 2d 69 6e 66 6f 20 20 20 t ((path-info
3730: 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e (get-environmen
3740: 74 2d 76 61 72 69 61 62 6c 65 20 22 50 41 54 48 t-variable "PATH
3750: 5f 49 4e 46 4f 22 29 29 0a 09 28 71 75 65 72 79 _INFO"))..(query
3760: 2d 73 74 72 69 6e 67 20 28 67 65 74 2d 65 6e 76 -string (get-env
3770: 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c ironment-variabl
3780: 65 20 22 51 55 45 52 59 5f 53 54 52 49 4e 47 22 e "QUERY_STRING"
3790: 29 29 29 0a 20 20 20 20 3b 3b 20 28 73 65 73 73 ))). ;; (sess
37a0: 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 70 61 ion:log self "pa
37b0: 74 68 2d 69 6e 66 6f 3d 22 20 70 61 74 68 2d 69 th-info=" path-i
37c0: 6e 66 6f 20 22 20 71 75 65 72 79 2d 73 74 72 69 nfo " query-stri
37d0: 6e 67 3d 22 20 71 75 65 72 79 2d 73 74 72 69 6e ng=" query-strin
37e0: 67 29 0a 20 20 20 20 28 69 66 20 70 61 74 68 2d g). (if path-
37f0: 69 6e 66 6f 0a 09 28 6c 65 74 2a 20 28 28 70 61 info..(let* ((pa
3800: 72 74 73 20 20 20 20 28 73 74 72 69 6e 67 2d 73 rts (string-s
3810: 70 6c 69 74 20 70 61 74 68 2d 69 6e 66 6f 20 22 plit path-info "
3820: 2f 22 29 29 0a 09 20 20 20 20 20 20 20 28 6e 75 /")).. (nu
3830: 6d 70 61 72 74 73 20 28 6c 65 6e 67 74 68 20 70 mparts (length p
3840: 61 72 74 73 29 29 29 0a 09 20 20 28 69 66 20 28 arts))).. (if (
3850: 3e 20 6e 75 6d 70 61 72 74 73 20 30 29 0a 09 20 > numparts 0)..
3860: 20 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d 70 (sdat-set-p
3870: 61 67 65 21 20 73 65 6c 66 20 28 63 61 72 20 70 age! self (car p
3880: 61 72 74 73 29 29 29 0a 09 20 20 3b 3b 20 28 73 arts))).. ;; (s
3890: 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 ession:log self
38a0: 22 75 72 6c 2d 70 61 74 68 3d 22 20 75 72 6c 2d "url-path=" url-
38b0: 70 61 74 68 20 22 20 70 61 72 74 73 3d 22 20 70 path " parts=" p
38c0: 61 72 74 73 29 0a 09 20 20 28 69 66 20 28 3e 20 arts).. (if (>
38d0: 6e 75 6d 70 61 72 74 73 20 31 29 0a 09 20 20 20 numparts 1)..
38e0: 20 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 74 (sdat-set-pat
38f0: 68 2d 70 61 72 61 6d 73 21 20 73 65 6c 66 20 28 h-params! self (
3900: 63 64 72 20 70 61 72 74 73 29 29 29 0a 20 20 20 cdr parts))).
3910: 20 20 20 20 20 20 20 28 69 66 20 71 75 65 72 79 (if query
3920: 2d 73 74 72 69 6e 67 0a 20 20 20 20 20 20 20 20 -string.
3930: 20 20 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d (sdat-set-
3940: 70 61 72 61 6d 73 21 20 73 65 6c 66 20 28 73 74 params! self (st
3950: 72 69 6e 67 2d 73 70 6c 69 74 20 71 75 65 72 79 ring-split query
3960: 2d 73 74 72 69 6e 67 20 22 26 22 29 29 29 29 29 -string "&")))))
3970: 29 29 0a 0a 3b 3b 20 42 55 47 47 59 21 0a 28 64 ))..;; BUGGY!.(d
3980: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 efine (session:g
3990: 65 74 2d 6e 65 77 2d 6b 65 79 20 73 65 6c 66 29 et-new-key self)
39a0: 0a 20 20 28 6c 65 74 20 28 28 63 6f 6e 6e 20 20 . (let ((conn
39b0: 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 (sdat-get-conn
39c0: 73 65 6c 66 29 29 0a 20 20 20 20 20 20 20 20 28 self)). (
39d0: 74 6d 70 6b 65 79 20 28 73 65 73 73 69 6f 6e 3a tmpkey (session:
39e0: 6d 61 6b 65 2d 72 61 6e 64 2d 73 74 72 69 6e 67 make-rand-string
39f0: 20 32 30 29 29 0a 20 20 20 20 20 20 20 20 28 73 20)). (s
3a00: 74 61 74 75 73 20 23 66 29 29 0a 20 20 20 20 28 tatus #f)). (
3a10: 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 dbi:for-each-row
3a20: 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 29 (lambda (tuple)
3a30: 0a 09 09 09 28 73 65 74 21 20 73 74 61 74 75 73 ....(set! status
3a40: 20 23 74 29 29 0a 09 09 20 20 20 20 20 20 63 6f #t))... co
3a50: 6e 6e 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e nn (string-appen
3a60: 64 20 22 49 4e 53 45 52 54 20 49 4e 54 4f 20 73 d "INSERT INTO s
3a70: 65 73 73 69 6f 6e 73 20 28 73 65 73 73 69 6f 6e essions (session
3a80: 5f 6b 65 79 29 20 56 41 4c 55 45 53 20 28 27 22 _key) VALUES ('"
3a90: 20 74 6d 70 6b 65 79 20 22 27 29 22 29 29 0a 20 tmpkey "')")).
3aa0: 20 20 20 74 6d 70 6b 65 79 29 29 0a 0a 3b 3b 20 tmpkey))..;;
3ab0: 72 65 74 75 72 6e 73 20 73 65 73 73 69 6f 6e 20 returns session
3ac0: 6b 65 79 20 49 46 46 20 69 74 20 69 73 20 69 6e key IFF it is in
3ad0: 20 74 68 65 20 48 54 54 50 5f 43 4f 4f 4b 49 45 the HTTP_COOKIE
3ae0: 20 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 .(define (sessi
3af0: 6f 6e 3a 65 78 74 72 61 63 74 2d 73 65 73 73 69 on:extract-sessi
3b00: 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 0a 20 20 28 on-key self). (
3b10: 6c 65 74 20 28 28 68 74 74 70 2d 63 6f 6f 6b 69 let ((http-cooki
3b20: 65 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 e (get-environme
3b30: 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 48 54 54 nt-variable "HTT
3b40: 50 5f 43 4f 4f 4b 49 45 22 29 29 29 0a 20 20 20 P_COOKIE"))).
3b50: 20 3b 3b 20 28 65 72 72 3a 6c 6f 67 20 22 68 74 ;; (err:log "ht
3b60: 74 70 2d 63 6f 6f 6b 69 65 3a 20 22 20 68 74 74 tp-cookie: " htt
3b70: 70 2d 63 6f 6f 6b 69 65 29 0a 20 20 20 20 28 69 p-cookie). (i
3b80: 66 20 68 74 74 70 2d 63 6f 6f 6b 69 65 0a 20 20 f http-cookie.
3b90: 20 20 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 65 (session:e
3ba0: 78 74 72 61 63 74 2d 6b 65 79 2d 66 72 6f 6d 2d xtract-key-from-
3bb0: 70 61 72 61 6d 20 73 65 6c 66 20 28 73 74 72 69 param self (stri
3bc0: 6e 67 2d 73 70 6c 69 74 2d 66 69 65 6c 64 73 20 ng-split-fields
3bd0: 20 22 3b 5c 5c 73 2b 22 20 68 74 74 70 2d 63 6f ";\\s+" http-co
3be0: 6f 6b 69 65 20 69 6e 66 69 78 3a 29 20 22 73 65 okie infix:) "se
3bf0: 73 73 69 6f 6e 5f 6b 65 79 22 29 0a 20 20 20 20 ssion_key").
3c00: 20 20 20 20 23 66 29 29 29 0a 0a 28 64 65 66 69 #f)))..(defi
3c10: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d ne (session:get-
3c20: 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 20 session-id self
3c30: 73 65 73 73 69 6f 6e 2d 6b 65 79 29 0a 20 20 28 session-key). (
3c40: 6c 65 74 20 28 28 71 75 65 72 79 20 22 53 45 4c let ((query "SEL
3c50: 45 43 54 20 69 64 20 46 52 4f 4d 20 73 65 73 73 ECT id FROM sess
3c60: 69 6f 6e 73 20 57 48 45 52 45 20 73 65 73 73 69 ions WHERE sessi
3c70: 6f 6e 5f 6b 65 79 3d 3f 3b 22 29 0a 20 20 20 20 on_key=?;").
3c80: 20 20 20 20 28 72 65 73 75 6c 74 20 23 66 29 29 (result #f))
3c90: 0a 20 20 20 20 3b 3b 20 20 20 20 20 28 70 67 3a . ;; (pg:
3ca0: 71 75 65 72 79 2d 66 6f 72 2d 65 61 63 68 20 28 query-for-each (
3cb0: 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 29 0a 20 lambda (tuple).
3cc0: 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 ;;
3cd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
3ce0: 73 65 74 21 20 72 65 73 75 6c 74 20 28 76 65 63 set! result (vec
3cf0: 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 30 29 tor-ref tuple 0)
3d00: 29 29 20 3b 3b 20 28 76 65 63 74 6f 72 2d 72 65 )) ;; (vector-re
3d10: 66 20 74 75 70 6c 65 20 30 29 29 29 0a 20 20 20 f tuple 0))).
3d20: 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
3d30: 20 20 20 20 20 20 20 20 20 20 20 28 73 3a 73 71 (s:sq
3d40: 6c 70 61 72 61 6d 20 71 75 65 72 79 20 73 65 73 lparam query ses
3d50: 73 69 6f 6e 2d 6b 65 79 29 0a 20 20 20 20 3b 3b sion-key). ;;
3d60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3d70: 20 20 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 (sdat-ge
3d80: 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 0a 20 20 t-conn self)).
3d90: 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 ;;
3da0: 20 20 20 20 20 20 20 20 20 20 20 20 63 6f 6e 6e conn
3db0: 29 0a 20 20 20 20 28 64 62 69 3a 66 6f 72 2d 65 ). (dbi:for-e
3dc0: 61 63 68 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 ach-row (lambda
3dd0: 28 74 75 70 6c 65 29 0a 09 09 09 28 73 65 74 21 (tuple)....(set!
3de0: 20 72 65 73 75 6c 74 20 28 76 65 63 74 6f 72 2d result (vector-
3df0: 72 65 66 20 74 75 70 6c 65 20 30 29 29 29 20 3b ref tuple 0))) ;
3e00: 3b 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 75 ; (vector-ref tu
3e10: 70 6c 65 20 30 29 29 29 0a 09 09 20 20 20 20 20 ple 0)))...
3e20: 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 (sdat-get-conn
3e30: 73 65 6c 66 29 0a 09 09 20 20 20 20 20 20 28 73 self)... (s
3e40: 3a 73 71 6c 70 61 72 61 6d 20 71 75 65 72 79 20 :sqlparam query
3e50: 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 0a 20 20 session-key)).
3e60: 20 20 72 65 73 75 6c 74 29 29 0a 0a 3b 3b 20 64 result))..;; d
3e70: 65 6c 65 74 65 20 61 6c 6c 20 72 65 63 6f 72 64 elete all record
3e80: 73 20 66 6f 72 20 61 20 73 65 73 73 69 6f 6e 0a s for a session.
3e90: 3b 3b 20 0a 3b 3b 20 4e 45 45 44 53 20 54 4f 20 ;; .;; NEEDS TO
3ea0: 42 45 20 54 52 41 4e 53 41 43 54 49 4f 4e 49 5a BE TRANSACTIONIZ
3eb0: 45 44 21 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 ED!.;;.(define (
3ec0: 73 65 73 73 69 6f 6e 3a 64 65 6c 65 74 65 2d 73 session:delete-s
3ed0: 65 73 73 69 6f 6e 20 73 65 6c 66 20 73 65 73 73 ession self sess
3ee0: 69 6f 6e 2d 6b 65 79 29 0a 20 20 28 6c 65 74 20 ion-key). (let
3ef0: 28 28 73 65 73 73 69 6f 6e 2d 69 64 20 28 73 65 ((session-id (se
3f00: 73 73 69 6f 6e 3a 67 65 74 2d 73 65 73 73 69 6f ssion:get-sessio
3f10: 6e 2d 69 64 20 73 65 6c 66 20 73 65 73 73 69 6f n-id self sessio
3f20: 6e 2d 6b 65 79 29 29 0a 20 20 20 20 20 20 20 20 n-key)).
3f30: 28 71 72 79 31 20 20 20 20 20 20 20 20 3b 3b 20 (qry1 ;;
3f40: 28 63 6f 6e 63 20 22 42 45 47 49 4e 3b 22 0a 09 (conc "BEGIN;"..
3f50: 09 09 20 20 22 44 45 4c 45 54 45 20 46 52 4f 4d .. "DELETE FROM
3f60: 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 57 48 session_vars WH
3f70: 45 52 45 20 73 65 73 73 69 6f 6e 5f 69 64 3d 3f ERE session_id=?
3f80: 3b 22 29 0a 09 28 71 72 79 32 20 20 20 20 20 20 ;")..(qry2
3f90: 20 20 20 20 20 20 20 22 44 45 4c 45 54 45 20 46 "DELETE F
3fa0: 52 4f 4d 20 73 65 73 73 69 6f 6e 73 20 57 48 45 ROM sessions WHE
3fb0: 52 45 20 69 64 3d 3f 3b 22 29 0a 09 09 20 20 20 RE id=?;")...
3fc0: 20 20 3b 3b 20 20 22 43 4f 4d 4d 49 54 3b 22 29 ;; "COMMIT;")
3fd0: 29 0a 20 20 20 20 20 20 20 20 28 63 6f 6e 6e 20 ). (conn
3fe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 64 (sd
3ff0: 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 at-get-conn self
4000: 29 29 29 0a 20 20 20 20 28 69 66 20 73 65 73 73 ))). (if sess
4010: 69 6f 6e 2d 69 64 0a 20 20 20 20 20 20 20 20 28 ion-id. (
4020: 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 begin.
4030: 28 64 62 69 3a 65 78 65 63 20 63 6f 6e 6e 20 71 (dbi:exec conn q
4040: 72 79 31 20 73 65 73 73 69 6f 6e 2d 69 64 29 20 ry1 session-id)
4050: 3b 3b 20 73 65 73 73 69 6f 6e 2d 69 64 29 0a 09 ;; session-id)..
4060: 20 20 28 64 62 69 3a 65 78 65 63 20 63 6f 6e 6e (dbi:exec conn
4070: 20 71 72 79 32 20 73 65 73 73 69 6f 6e 2d 69 64 qry2 session-id
4080: 29 0a 09 20 20 28 73 65 73 73 69 6f 6e 3a 69 6e ).. (session:in
4090: 69 74 69 61 6c 69 7a 65 20 73 65 6c 66 29 0a 09 itialize self)..
40a0: 20 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 (session:setup
40b0: 20 73 65 6c 66 29 29 29 0a 20 20 20 20 28 6e 6f self))). (no
40c0: 74 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 73 t (session:get-s
40d0: 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 20 73 ession-id self s
40e0: 65 73 73 69 6f 6e 2d 6b 65 79 29 29 29 29 0a 0a ession-key))))..
40f0: 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 65 73 73 ;; (define (sess
4100: 69 6f 6e 3a 64 65 6c 65 74 65 2d 73 65 73 73 69 ion:delete-sessi
4110: 6f 6e 20 73 65 6c 66 20 73 65 73 73 69 6f 6e 2d on self session-
4120: 6b 65 79 29 0a 3b 3b 20 20 20 28 6c 65 74 20 28 key).;; (let (
4130: 28 73 65 73 73 69 6f 6e 2d 69 64 20 28 73 65 73 (session-id (ses
4140: 73 69 6f 6e 3a 67 65 74 2d 73 65 73 73 69 6f 6e sion:get-session
4150: 2d 69 64 20 73 65 6c 66 20 73 65 73 73 69 6f 6e -id self session
4160: 2d 6b 65 79 29 29 0a 3b 3b 20 20 20 20 20 20 20 -key)).;;
4170: 20 20 28 71 75 65 72 69 65 73 20 20 20 20 28 6c (queries (l
4180: 69 73 74 20 22 42 45 47 49 4e 3b 22 0a 3b 3b 20 ist "BEGIN;".;;
4190: 09 09 09 20 20 22 44 45 4c 45 54 45 20 46 52 4f ... "DELETE FRO
41a0: 4d 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 57 M session_vars W
41b0: 48 45 52 45 20 73 65 73 73 69 6f 6e 5f 69 64 3d HERE session_id=
41c0: 3f 3b 22 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 ?;".;;
41d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
41e0: 20 22 44 45 4c 45 54 45 20 46 52 4f 4d 20 73 65 "DELETE FROM se
41f0: 73 73 69 6f 6e 73 20 57 48 45 52 45 20 69 64 3d ssions WHERE id=
4200: 3f 3b 22 0a 3b 3b 20 09 09 09 20 20 22 43 4f 4d ?;".;; ... "COM
4210: 4d 49 54 3b 22 29 29 0a 3b 3b 20 20 20 20 20 20 MIT;")).;;
4220: 20 20 20 28 63 6f 6e 6e 20 20 20 20 20 20 20 20 (conn
4230: 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d (sdat-get-
4240: 63 6f 6e 6e 20 73 65 6c 66 29 29 29 0a 3b 3b 20 conn self))).;;
4250: 20 20 20 20 28 69 66 20 73 65 73 73 69 6f 6e 2d (if session-
4260: 69 64 0a 3b 3b 20 20 20 20 20 20 20 20 20 28 62 id.;; (b
4270: 65 67 69 6e 0a 3b 3b 20 20 20 20 20 20 20 20 20 egin.;;
4280: 20 20 28 66 6f 72 2d 65 61 63 68 0a 3b 3b 20 20 (for-each.;;
4290: 20 20 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 (lambd
42a0: 61 20 28 71 75 65 72 79 29 0a 3b 3b 20 20 20 20 a (query).;;
42b0: 20 20 20 20 20 20 20 20 20 20 28 64 62 69 3a 65 (dbi:e
42c0: 78 65 63 20 63 6f 6e 6e 20 71 75 65 72 79 20 73 xec conn query s
42d0: 65 73 73 69 6f 6e 2d 69 64 29 29 0a 3b 3b 20 09 ession-id)).;; .
42e0: 20 20 20 71 75 65 72 69 65 73 29 0a 3b 3b 20 09 queries).;; .
42f0: 20 20 28 69 6e 69 74 69 61 6c 69 7a 65 20 73 65 (initialize se
4300: 6c 66 20 27 28 29 29 0a 3b 3b 20 09 20 20 28 73 lf '()).;; . (s
4310: 65 73 73 69 6f 6e 3a 73 65 74 75 70 20 73 65 6c ession:setup sel
4320: 66 29 29 29 0a 3b 3b 20 20 20 20 20 28 6e 6f 74 f))).;; (not
4330: 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 73 65 (session:get-se
4340: 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 20 73 65 ssion-id self se
4350: 73 73 69 6f 6e 2d 6b 65 79 29 29 29 29 0a 0a 28 ssion-key))))..(
4360: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
4370: 65 78 74 72 61 63 74 2d 6b 65 79 20 73 65 6c 66 extract-key self
4380: 20 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 28 70 key). (let ((p
4390: 61 72 61 6d 73 20 28 73 64 61 74 2d 67 65 74 2d arams (sdat-get-
43a0: 70 61 72 61 6d 73 20 73 65 6c 66 29 29 29 0a 20 params self))).
43b0: 20 20 20 28 73 65 73 73 69 6f 6e 3a 65 78 74 72 (session:extr
43c0: 61 63 74 2d 6b 65 79 2d 66 72 6f 6d 2d 70 61 72 act-key-from-par
43d0: 61 6d 20 73 65 6c 66 20 70 61 72 61 6d 73 20 6b am self params k
43e0: 65 79 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 ey)))..(define (
43f0: 73 65 73 73 69 6f 6e 3a 65 78 74 72 61 63 74 2d session:extract-
4400: 6b 65 79 2d 66 72 6f 6d 2d 70 61 72 61 6d 20 73 key-from-param s
4410: 65 6c 66 20 70 61 72 61 6d 73 20 6b 65 79 29 0a elf params key).
4420: 20 20 28 6c 65 74 20 28 28 72 31 20 20 20 20 20 (let ((r1
4430: 28 72 65 67 65 78 70 20 28 73 74 72 69 6e 67 2d (regexp (string-
4440: 61 70 70 65 6e 64 20 22 5e 22 20 6b 65 79 20 22 append "^" key "
4450: 3d 28 5b 5e 3d 5d 2b 29 24 22 29 29 29 29 0a 20 =([^=]+)$")))).
4460: 20 20 20 28 65 72 72 3a 6c 6f 67 20 22 49 4e 46 (err:log "INF
4470: 4f 3a 20 4c 6f 6f 6b 69 6e 67 20 66 6f 72 20 22 O: Looking for "
4480: 20 6b 65 79 20 22 20 69 6e 20 22 20 70 61 72 61 key " in " para
4490: 6d 73 29 0a 20 20 20 20 28 69 66 20 28 3c 20 28 ms). (if (< (
44a0: 6c 65 6e 67 74 68 20 70 61 72 61 6d 73 29 20 31 length params) 1
44b0: 29 20 23 66 0a 09 28 6c 65 74 20 6c 6f 6f 70 20 ) #f..(let loop
44c0: 28 28 68 65 61 64 20 20 20 28 63 61 72 20 70 61 ((head (car pa
44d0: 72 61 6d 73 29 29 0a 09 09 20 20 20 28 74 61 69 rams))... (tai
44e0: 6c 20 20 20 28 63 64 72 20 70 61 72 61 6d 73 29 l (cdr params)
44f0: 29 29 0a 09 20 20 28 6c 65 74 20 28 28 6d 61 74 )).. (let ((mat
4500: 63 68 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 ch (string-match
4510: 20 72 31 20 68 65 61 64 29 29 29 0a 09 20 20 20 r1 head)))..
4520: 20 28 63 6f 6e 64 0a 09 20 20 20 20 20 28 6d 61 (cond.. (ma
4530: 74 63 68 0a 09 20 20 20 20 20 20 28 6c 65 74 20 tch.. (let
4540: 28 28 73 65 73 73 69 6f 6e 2d 6b 65 79 20 28 6c ((session-key (l
4550: 69 73 74 2d 72 65 66 20 6d 61 74 63 68 20 31 29 ist-ref match 1)
4560: 29 29 0a 09 09 28 65 72 72 3a 6c 6f 67 20 22 49 ))...(err:log "I
4570: 4e 46 4f 3a 20 46 6f 75 6e 64 20 73 65 73 73 69 NFO: Found sessi
4580: 6f 6e 20 6b 65 79 3d 22 20 73 65 73 73 69 6f 6e on key=" session
4590: 2d 6b 65 79 29 0a 09 09 28 73 64 61 74 2d 73 65 -key)...(sdat-se
45a0: 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 21 20 73 t-session-key! s
45b0: 65 6c 66 20 28 6c 69 73 74 2d 72 65 66 20 6d 61 elf (list-ref ma
45c0: 74 63 68 20 31 29 29 0a 09 09 73 65 73 73 69 6f tch 1))...sessio
45d0: 6e 2d 6b 65 79 29 29 0a 09 20 20 20 20 20 28 28 n-key)).. ((
45e0: 6e 75 6c 6c 3f 20 74 61 69 6c 29 0a 09 20 20 20 null? tail)..
45f0: 20 20 20 23 66 29 0a 09 20 20 20 20 20 28 65 6c #f).. (el
4600: 73 65 0a 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 se.. (loop
4610: 28 63 61 72 20 74 61 69 6c 29 0a 09 09 20 20 20 (car tail)...
4620: 20 28 63 64 72 20 74 61 69 6c 29 29 29 29 29 29 (cdr tail))))))
4630: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 )))..(define (se
4640: 73 73 69 6f 6e 3a 73 65 74 2d 70 61 67 65 21 20 ssion:set-page!
4650: 73 65 6c 66 20 70 61 67 65 5f 6e 61 6d 65 29 0a self page_name).
4660: 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 (sdat-set-page
4670: 21 20 73 65 6c 66 20 70 61 67 65 5f 6e 61 6d 65 ! self page_name
4680: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 ))..(define (ses
4690: 73 69 6f 6e 3a 63 6c 6f 73 65 20 73 65 6c 66 29 sion:close self)
46a0: 0a 20 20 28 64 62 69 3a 63 6c 6f 73 65 20 28 73 . (dbi:close (s
46b0: 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c dat-get-conn sel
46c0: 66 29 29 29 0a 3b 3b 20 28 63 6c 6f 73 65 2d 6f f))).;; (close-o
46d0: 75 74 70 75 74 2d 70 6f 72 74 20 28 73 64 61 74 utput-port (sdat
46e0: 2d 67 65 74 2d 6c 6f 67 70 74 20 73 65 6c 66 29 -get-logpt self)
46f0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 )..(define (sess
4700: 69 6f 6e 3a 65 72 72 2d 6d 73 67 20 73 65 6c 66 ion:err-msg self
4710: 20 6d 73 67 29 0a 20 20 28 68 61 73 68 2d 74 61 msg). (hash-ta
4720: 62 6c 65 2d 73 65 74 21 20 28 73 64 61 74 2d 67 ble-set! (sdat-g
4730: 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 20 73 et-sessionvars s
4740: 65 6c 66 29 20 22 45 52 52 4f 52 5f 4d 53 47 22 elf) "ERROR_MSG"
4750: 0a 09 09 20 20 20 28 73 74 72 69 6e 67 2d 69 6e ... (string-in
4760: 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 20 73 tersperse (map s
4770: 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6d 73 67 :any->string msg
4780: 29 20 22 20 22 29 29 29 0a 0a 28 64 65 66 69 6e ) " ")))..(defin
4790: 65 20 28 73 65 73 73 69 6f 6e 3a 70 72 65 76 2d e (session:prev-
47a0: 65 72 72 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 err self). (let
47b0: 20 28 28 70 72 65 76 2d 65 72 72 20 28 68 61 73 ((prev-err (has
47c0: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
47d0: 75 6c 74 20 28 73 64 61 74 2d 67 65 74 2d 73 65 ult (sdat-get-se
47e0: 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 ssionvars-before
47f0: 20 73 65 6c 66 29 20 22 45 52 52 4f 52 5f 4d 53 self) "ERROR_MS
4800: 47 22 20 23 66 29 29 0a 09 28 63 75 72 72 2d 65 G" #f))..(curr-e
4810: 72 72 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 rr (hash-table-r
4820: 65 66 2f 64 65 66 61 75 6c 74 20 28 73 64 61 74 ef/default (sdat
4830: 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 -get-sessionvars
4840: 20 73 65 6c 66 29 20 22 45 52 52 4f 52 5f 4d 53 self) "ERROR_MS
4850: 47 22 20 23 66 29 29 29 0a 20 20 20 20 28 69 66 G" #f))). (if
4860: 20 70 72 65 76 2d 65 72 72 20 70 72 65 76 2d 65 prev-err prev-e
4870: 72 72 0a 09 28 69 66 20 63 75 72 72 2d 65 72 72 rr..(if curr-err
4880: 20 63 75 72 72 2d 65 72 72 20 23 66 29 29 29 29 curr-err #f))))
4890: 0a 0a 3b 3b 20 73 65 73 73 69 6f 6e 20 76 61 72 ..;; session var
48a0: 73 0a 3b 3b 20 31 2e 20 6b 65 79 73 20 61 72 65 s.;; 1. keys are
48b0: 20 61 6c 77 61 79 73 20 61 20 73 74 72 69 6e 67 always a string
48c0: 20 4e 4f 54 20 61 20 73 79 6d 62 6f 6c 0a 3b 3b NOT a symbol.;;
48d0: 20 32 2e 20 76 61 6c 75 65 73 20 61 72 65 20 61 2. values are a
48e0: 6c 77 61 79 73 20 61 20 73 74 72 69 6e 67 20 63 lways a string c
48f0: 6f 6e 76 65 72 73 69 6f 6e 20 69 73 20 74 68 65 onversion is the
4900: 20 72 65 73 70 6f 6e 73 69 62 69 6c 69 74 79 20 responsibility
4910: 6f 66 20 74 68 65 20 0a 3b 3b 20 20 20 20 63 6f of the .;; co
4920: 6e 73 75 6d 69 6e 67 20 66 75 6e 63 74 69 6f 6e nsuming function
4930: 20 28 61 74 20 6c 65 61 73 74 20 66 6f 72 20 6e (at least for n
4940: 6f 77 2c 20 49 27 64 20 6c 69 6b 65 20 74 6f 20 ow, I'd like to
4950: 63 68 61 6e 67 65 20 74 68 69 73 29 0a 0a 3b 3b change this)..;;
4960: 20 73 65 74 20 61 20 73 65 73 73 69 6f 6e 20 76 set a session v
4970: 61 72 20 66 6f 72 20 74 68 65 20 63 75 72 72 65 ar for the curre
4980: 6e 74 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 69 nt page.;;.(defi
4990: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 63 75 72 72 ne (session:curr
49a0: 2d 70 61 67 65 2d 73 65 74 21 20 73 65 6c 66 20 -page-set! self
49b0: 6b 65 79 20 76 61 6c 75 65 29 0a 20 20 28 68 61 key value). (ha
49c0: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 28 73 sh-table-set! (s
49d0: 64 61 74 2d 67 65 74 2d 70 61 67 65 76 61 72 73 dat-get-pagevars
49e0: 20 73 65 6c 66 29 20 28 73 3a 61 6e 79 2d 3e 73 self) (s:any->s
49f0: 74 72 69 6e 67 20 6b 65 79 29 20 28 73 3a 61 6e tring key) (s:an
4a00: 79 2d 3e 73 74 72 69 6e 67 20 76 61 6c 75 65 29 y->string value)
4a10: 29 29 0a 0a 3b 3b 20 64 65 6c 20 61 20 76 61 72 ))..;; del a var
4a20: 20 66 6f 72 20 74 68 65 20 63 75 72 72 65 6e 74 for the current
4a30: 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 page.;;.(define
4a40: 20 28 73 65 73 73 69 6f 6e 3a 70 61 67 65 2d 76 (session:page-v
4a50: 61 72 2d 64 65 6c 21 20 73 65 6c 66 20 6b 65 79 ar-del! self key
4a60: 29 0a 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ). (hash-table-
4a70: 64 65 6c 65 74 65 21 20 28 73 64 61 74 2d 67 65 delete! (sdat-ge
4a80: 74 2d 70 61 67 65 76 61 72 73 20 73 65 6c 66 29 t-pagevars self)
4a90: 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 (s:any->string
4aa0: 6b 65 79 29 29 29 0a 0a 3b 3b 20 67 65 74 20 74 key)))..;; get t
4ab0: 68 65 20 61 70 70 72 6f 70 72 69 61 74 65 20 68 he appropriate h
4ac0: 61 73 68 20 67 69 76 65 6e 20 61 20 70 61 67 65 ash given a page
4ad0: 20 22 2a 73 65 73 73 69 6f 6e 76 61 72 73 2a 2c "*sessionvars*,
4ae0: 20 2a 67 6c 6f 62 61 6c 76 61 72 73 2a 20 6f 72 *globalvars* or
4af0: 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 page.;;.(define
4b00: 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 (session:get-pa
4b10: 67 65 2d 68 61 73 68 20 73 65 6c 66 20 70 61 67 ge-hash self pag
4b20: 65 29 0a 20 20 28 69 66 20 28 73 74 72 69 6e 67 e). (if (string
4b30: 3d 3f 20 70 61 67 65 20 22 2a 73 65 73 73 69 6f =? page "*sessio
4b40: 6e 76 61 72 73 2a 22 29 0a 20 20 20 20 20 20 28 nvars*"). (
4b50: 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e sdat-get-session
4b60: 76 61 72 73 20 73 65 6c 66 29 0a 20 20 20 20 20 vars self).
4b70: 20 28 69 66 20 28 73 74 72 69 6e 67 3d 3f 20 70 (if (string=? p
4b80: 61 67 65 20 22 2a 67 6c 6f 62 61 6c 76 61 72 73 age "*globalvars
4b90: 2a 22 29 0a 09 20 20 28 73 64 61 74 2d 67 65 74 *").. (sdat-get
4ba0: 2d 67 6c 6f 62 61 6c 76 61 72 73 20 73 65 6c 66 -globalvars self
4bb0: 29 0a 09 20 20 28 73 64 61 74 2d 67 65 74 2d 70 ).. (sdat-get-p
4bc0: 61 67 65 76 61 72 73 20 73 65 6c 66 29 29 29 29 agevars self))))
4bd0: 0a 0a 3b 3b 20 73 65 74 20 61 20 73 65 73 73 69 ..;; set a sessi
4be0: 6f 6e 20 76 61 72 20 66 6f 72 20 61 20 67 69 76 on var for a giv
4bf0: 65 6e 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 69 en page.;;.(defi
4c00: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 21 ne (session:set!
4c10: 20 73 65 6c 66 20 70 61 67 65 20 6b 65 79 20 76 self page key v
4c20: 61 6c 75 65 29 0a 20 20 28 6c 65 74 20 28 28 68 alue). (let ((h
4c30: 74 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 t (session:get-p
4c40: 61 67 65 2d 68 61 73 68 20 73 65 6c 66 20 70 61 age-hash self pa
4c50: 67 65 29 29 29 0a 20 20 20 20 28 68 61 73 68 2d ge))). (hash-
4c60: 74 61 62 6c 65 2d 73 65 74 21 20 68 74 20 28 73 table-set! ht (s
4c70: 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6b 65 79 :any->string key
4c80: 29 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 ) (s:any->string
4c90: 20 76 61 6c 75 65 29 29 29 29 0a 0a 3b 3b 20 67 value))))..;; g
4ca0: 65 74 20 73 65 73 73 69 6f 6e 20 76 61 72 73 20 et session vars
4cb0: 66 6f 72 20 74 68 65 20 63 75 72 72 65 6e 74 20 for the current
4cc0: 70 61 67 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 page.;;.(define
4cd0: 28 73 65 73 73 69 6f 6e 3a 70 61 67 65 2d 67 65 (session:page-ge
4ce0: 74 20 73 65 6c 66 20 6b 65 79 29 0a 20 20 28 68 t self key). (h
4cf0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
4d00: 66 61 75 6c 74 20 28 73 64 61 74 2d 67 65 74 2d fault (sdat-get-
4d10: 70 61 67 65 76 61 72 73 20 73 65 6c 66 29 20 6b pagevars self) k
4d20: 65 79 20 23 66 29 29 0a 0a 3b 3b 20 67 65 74 20 ey #f))..;; get
4d30: 73 65 73 73 69 6f 6e 20 76 61 72 73 20 66 6f 72 session vars for
4d40: 20 61 20 73 70 65 63 69 66 69 65 64 20 70 61 67 a specified pag
4d50: 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 e.;;.(define (se
4d60: 73 73 69 6f 6e 3a 67 65 74 20 73 65 6c 66 20 70 ssion:get self p
4d70: 61 67 65 20 6b 65 79 29 0a 20 20 28 6c 65 74 20 age key). (let
4d80: 28 28 68 74 20 28 73 65 73 73 69 6f 6e 3a 67 65 ((ht (session:ge
4d90: 74 2d 70 61 67 65 2d 68 61 73 68 20 73 65 6c 66 t-page-hash self
4da0: 20 70 61 67 65 29 29 29 0a 20 20 20 20 28 68 61 page))). (ha
4db0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
4dc0: 61 75 6c 74 20 68 74 20 6b 65 79 20 23 66 29 29 ault ht key #f))
4dd0: 29 0a 0a 3b 3b 20 64 65 6c 65 74 65 20 61 20 73 )..;; delete a s
4de0: 65 73 73 69 6f 6e 20 76 61 72 20 66 6f 72 20 61 ession var for a
4df0: 20 73 70 65 63 69 66 69 65 64 20 70 61 67 65 0a specified page.
4e00: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 ;;.(define (sess
4e10: 69 6f 6e 3a 64 65 6c 21 20 73 65 6c 66 20 70 61 ion:del! self pa
4e20: 67 65 20 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 ge key). (let (
4e30: 28 68 74 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 (ht (session:get
4e40: 2d 70 61 67 65 2d 68 61 73 68 20 73 65 6c 66 20 -page-hash self
4e50: 70 61 67 65 29 29 29 0a 20 20 20 20 28 68 61 73 page))). (has
4e60: 68 2d 74 61 62 6c 65 2d 64 65 6c 65 74 65 21 20 h-table-delete!
4e70: 68 74 20 6b 65 79 29 29 29 0a 0a 3b 3b 20 67 65 ht key)))..;; ge
4e80: 74 20 41 4c 4c 20 6b 65 79 73 20 66 6f 72 20 74 t ALL keys for t
4e90: 68 69 73 20 70 61 67 65 20 61 6e 64 20 73 74 6f his page and sto
4ea0: 72 65 20 69 6e 20 74 68 65 20 73 65 73 73 69 6f re in the sessio
4eb0: 6e 20 70 61 67 65 76 61 72 73 20 68 61 73 68 0a n pagevars hash.
4ec0: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 ;;.(define (sess
4ed0: 69 6f 6e 3a 67 65 74 2d 76 61 72 73 20 73 65 6c ion:get-vars sel
4ee0: 66 29 0a 20 20 28 6c 65 74 20 28 28 73 65 73 73 f). (let ((sess
4ef0: 69 6f 6e 2d 69 64 20 20 28 73 64 61 74 2d 67 65 ion-id (sdat-ge
4f00: 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c t-session-id sel
4f10: 66 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f f))). (if (no
4f20: 74 20 73 65 73 73 69 6f 6e 2d 69 64 29 0a 09 28 t session-id)..(
4f30: 65 72 72 3a 6c 6f 67 20 22 45 52 52 4f 52 3a 20 err:log "ERROR:
4f40: 4e 6f 20 73 65 73 73 69 6f 6e 20 69 64 20 69 6e No session id in
4f50: 20 73 65 73 73 69 6f 6e 20 6f 62 6a 65 63 74 21 session object!
4f60: 20 73 65 73 73 69 6f 6e 3a 67 65 74 2d 76 61 72 session:get-var
4f70: 73 22 29 0a 09 28 6c 65 74 2a 20 28 28 72 65 73 s")..(let* ((res
4f80: 75 6c 74 20 20 20 20 20 20 20 20 20 20 20 20 20 ult
4f90: 23 66 29 0a 09 20 20 20 20 20 20 20 28 63 6f 6e #f).. (con
4fa0: 6e 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 n
4fb0: 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 (sdat-get-conn s
4fc0: 65 6c 66 29 29 0a 09 20 20 20 20 20 20 20 28 70 elf)).. (p
4fd0: 61 67 65 76 61 72 73 2d 62 65 66 6f 72 65 20 20 agevars-before
4fe0: 20 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 (sdat-get-page
4ff0: 76 61 72 73 2d 62 65 66 6f 72 65 20 73 65 6c 66 vars-before self
5000: 29 29 0a 09 20 20 20 20 20 20 20 28 73 65 73 73 )).. (sess
5010: 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 20 28 ionvars-before (
5020: 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e sdat-get-session
5030: 76 61 72 73 2d 62 65 66 6f 72 65 20 73 65 6c 66 vars-before self
5040: 29 29 0a 09 20 20 20 20 20 20 20 28 67 6c 6f 62 )).. (glob
5050: 61 6c 76 61 72 73 2d 62 65 66 6f 72 65 20 20 28 alvars-before (
5060: 73 64 61 74 2d 67 65 74 2d 67 6c 6f 62 61 6c 76 sdat-get-globalv
5070: 61 72 73 2d 62 65 66 6f 72 65 20 73 65 6c 66 29 ars-before self)
5080: 29 0a 09 20 20 20 20 20 20 20 28 70 61 67 65 76 ).. (pagev
5090: 61 72 73 20 20 20 20 20 20 20 20 20 20 20 28 73 ars (s
50a0: 64 61 74 2d 67 65 74 2d 70 61 67 65 76 61 72 73 dat-get-pagevars
50b0: 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 20 20 self))..
50c0: 28 73 65 73 73 69 6f 6e 76 61 72 73 20 20 20 20 (sessionvars
50d0: 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d 73 65 (sdat-get-se
50e0: 73 73 69 6f 6e 76 61 72 73 20 73 65 6c 66 29 29 ssionvars self))
50f0: 0a 09 20 20 20 20 20 20 20 28 67 6c 6f 62 61 6c .. (global
5100: 76 61 72 73 20 20 20 20 20 20 20 20 20 28 73 64 vars (sd
5110: 61 74 2d 67 65 74 2d 67 6c 6f 62 61 6c 76 61 72 at-get-globalvar
5120: 73 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 20 s self))..
5130: 20 28 70 61 67 65 2d 6e 61 6d 65 20 20 20 20 20 (page-name
5140: 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d 70 (sdat-get-p
5150: 61 67 65 20 73 65 6c 66 29 29 0a 09 20 20 20 20 age self))..
5160: 20 20 20 28 73 65 73 73 69 6f 6e 2d 6b 65 79 20 (session-key
5170: 20 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 (sdat-get
5180: 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c -session-key sel
5190: 66 29 29 0a 09 20 20 20 20 20 20 20 28 71 75 65 f)).. (que
51a0: 72 79 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ry
51b0: 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 0a 09 (string-append..
51c0: 09 09 09 20 20 20 20 22 53 45 4c 45 43 54 20 6b ... "SELECT k
51d0: 65 79 2c 76 61 6c 75 65 20 46 52 4f 4d 20 73 65 ey,value FROM se
51e0: 73 73 69 6f 6e 5f 76 61 72 73 20 49 4e 4e 45 52 ssion_vars INNER
51f0: 20 4a 4f 49 4e 20 73 65 73 73 69 6f 6e 73 20 4f JOIN sessions O
5200: 4e 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 2e 73 N session_vars.s
5210: 65 73 73 69 6f 6e 5f 69 64 3d 73 65 73 73 69 6f ession_id=sessio
5220: 6e 73 2e 69 64 20 22 0a 09 09 09 09 20 20 20 20 ns.id ".....
5230: 22 57 48 45 52 45 20 73 65 73 73 69 6f 6e 5f 6b "WHERE session_k
5240: 65 79 3d 3f 20 41 4e 44 20 70 61 67 65 3d 3f 3b ey=? AND page=?;
5250: 22 29 29 29 0a 09 20 20 3b 3b 20 66 69 72 73 74 "))).. ;; first
5260: 20 74 68 65 20 70 61 67 65 20 73 70 65 63 69 66 the page specif
5270: 69 63 20 76 61 72 73 0a 09 20 20 28 64 62 69 3a ic vars.. (dbi:
5280: 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 for-each-row (la
5290: 6d 62 64 61 20 28 74 75 70 6c 65 29 0a 09 09 09 mbda (tuple)....
52a0: 20 20 20 20 20 20 28 6c 65 74 20 28 28 6b 20 28 (let ((k (
52b0: 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 vector-ref tuple
52c0: 20 30 29 29 0a 09 09 09 09 20 20 20 20 28 76 20 0))..... (v
52d0: 28 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c (vector-ref tupl
52e0: 65 20 31 29 29 29 0a 09 09 09 09 28 68 61 73 68 e 1))).....(hash
52f0: 2d 74 61 62 6c 65 2d 73 65 74 21 20 70 61 67 65 -table-set! page
5300: 76 61 72 73 2d 62 65 66 6f 72 65 20 6b 20 76 29 vars-before k v)
5310: 0a 09 09 09 09 28 68 61 73 68 2d 74 61 62 6c 65 .....(hash-table
5320: 2d 73 65 74 21 20 70 61 67 65 76 61 72 73 20 20 -set! pagevars
5330: 20 20 20 20 20 20 6b 20 76 29 29 29 0a 09 09 09 k v)))....
5340: 20 20 20 20 63 6f 6e 6e 0a 09 09 09 20 20 20 20 conn....
5350: 28 73 3a 73 71 6c 70 61 72 61 6d 20 71 75 65 72 (s:sqlparam quer
5360: 79 20 73 65 73 73 69 6f 6e 2d 6b 65 79 20 70 61 y session-key pa
5370: 67 65 2d 6e 61 6d 65 29 29 0a 09 20 20 3b 3b 20 ge-name)).. ;;
5380: 74 68 65 6e 20 74 68 65 20 73 65 73 73 69 6f 6e then the session
5390: 20 73 70 65 63 69 66 69 63 20 76 61 72 73 0a 09 specific vars..
53a0: 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d (dbi:for-each-
53b0: 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 75 70 row (lambda (tup
53c0: 6c 65 29 0a 09 09 09 20 20 20 20 20 20 28 6c 65 le).... (le
53d0: 74 20 28 28 6b 20 28 76 65 63 74 6f 72 2d 72 65 t ((k (vector-re
53e0: 66 20 74 75 70 6c 65 20 30 29 29 0a 09 09 09 09 f tuple 0)).....
53f0: 20 20 20 20 28 76 20 28 76 65 63 74 6f 72 2d 72 (v (vector-r
5400: 65 66 20 74 75 70 6c 65 20 31 29 29 29 0a 09 09 ef tuple 1)))...
5410: 09 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 ..(hash-table-se
5420: 74 21 20 73 65 73 73 69 6f 6e 76 61 72 73 2d 62 t! sessionvars-b
5430: 65 66 6f 72 65 20 6b 20 76 29 0a 09 09 09 09 28 efore k v).....(
5440: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
5450: 73 65 73 73 69 6f 6e 76 61 72 73 20 20 20 20 20 sessionvars
5460: 20 20 20 6b 20 76 29 29 29 0a 09 09 09 20 20 20 k v)))....
5470: 20 63 6f 6e 6e 0a 09 09 09 20 20 20 20 28 73 3a conn.... (s:
5480: 73 71 6c 70 61 72 61 6d 20 71 75 65 72 79 20 73 sqlparam query s
5490: 65 73 73 69 6f 6e 2d 6b 65 79 20 22 2a 73 65 73 ession-key "*ses
54a0: 73 69 6f 6e 76 61 72 73 2a 22 29 29 0a 09 20 20 sionvars*"))..
54b0: 3b 3b 20 61 6e 64 20 66 69 6e 61 6c 6c 79 20 74 ;; and finally t
54c0: 68 65 20 67 6c 6f 62 61 6c 20 76 61 72 73 0a 09 he global vars..
54d0: 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d (dbi:for-each-
54e0: 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 75 70 row (lambda (tup
54f0: 6c 65 29 0a 09 09 09 20 20 20 20 20 20 28 6c 65 le).... (le
5500: 74 20 28 28 6b 20 28 76 65 63 74 6f 72 2d 72 65 t ((k (vector-re
5510: 66 20 74 75 70 6c 65 20 30 29 29 0a 09 09 09 09 f tuple 0)).....
5520: 20 20 20 20 28 76 20 28 76 65 63 74 6f 72 2d 72 (v (vector-r
5530: 65 66 20 74 75 70 6c 65 20 31 29 29 29 0a 09 09 ef tuple 1)))...
5540: 09 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 ..(hash-table-se
5550: 74 21 20 67 6c 6f 62 61 6c 76 61 72 73 2d 62 65 t! globalvars-be
5560: 66 6f 72 65 20 6b 20 76 29 0a 09 09 09 09 28 68 fore k v).....(h
5570: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 67 ash-table-set! g
5580: 6c 6f 62 61 6c 76 61 72 73 20 20 20 20 20 20 20 lobalvars
5590: 20 6b 20 76 29 29 29 0a 09 09 09 20 20 20 20 63 k v))).... c
55a0: 6f 6e 6e 0a 09 09 09 20 20 20 20 28 73 3a 73 71 onn.... (s:sq
55b0: 6c 70 61 72 61 6d 20 71 75 65 72 79 20 73 65 73 lparam query ses
55c0: 73 69 6f 6e 2d 6b 65 79 20 22 2a 67 6c 6f 62 61 sion-key "*globa
55d0: 6c 76 61 72 73 22 29 29 0a 09 20 20 29 29 29 29 lvars")).. ))))
55e0: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ..(define (sessi
55f0: 6f 6e 3a 73 61 76 65 2d 76 61 72 73 20 73 65 6c on:save-vars sel
5600: 66 29 0a 20 20 28 6c 65 74 20 28 28 73 65 73 73 f). (let ((sess
5610: 69 6f 6e 2d 69 64 20 20 28 73 64 61 74 2d 67 65 ion-id (sdat-ge
5620: 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c t-session-id sel
5630: 66 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f f))). (if (no
5640: 74 20 73 65 73 73 69 6f 6e 2d 69 64 29 0a 09 28 t session-id)..(
5650: 65 72 72 3a 6c 6f 67 20 22 45 52 52 4f 52 3a 20 err:log "ERROR:
5660: 4e 6f 20 73 65 73 73 69 6f 6e 20 69 64 20 69 6e No session id in
5670: 20 73 65 73 73 69 6f 6e 20 6f 62 6a 65 63 74 21 session object!
5680: 20 73 65 73 73 69 6f 6e 3a 67 65 74 2d 76 61 72 session:get-var
5690: 73 22 29 0a 09 28 6c 65 74 2a 20 28 28 73 74 61 s")..(let* ((sta
56a0: 74 75 73 20 20 20 20 20 20 23 66 29 0a 09 20 20 tus #f)..
56b0: 20 20 20 20 20 28 63 6f 6e 6e 20 20 20 20 20 20 (conn
56c0: 20 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e (sdat-get-conn
56d0: 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 20 20 self))..
56e0: 28 70 61 67 65 2d 6e 61 6d 65 20 20 20 28 73 64 (page-name (sd
56f0: 61 74 2d 67 65 74 2d 70 61 67 65 20 73 65 6c 66 at-get-page self
5700: 29 29 0a 09 20 20 20 20 20 20 20 28 64 65 6c 2d )).. (del-
5710: 71 75 65 72 79 20 20 20 22 44 45 4c 45 54 45 20 query "DELETE
5720: 46 52 4f 4d 20 73 65 73 73 69 6f 6e 5f 76 61 72 FROM session_var
5730: 73 20 57 48 45 52 45 20 73 65 73 73 69 6f 6e 5f s WHERE session_
5740: 69 64 3d 3f 20 41 4e 44 20 70 61 67 65 3d 3f 20 id=? AND page=?
5750: 41 4e 44 20 6b 65 79 3d 3f 3b 22 29 0a 09 20 20 AND key=?;")..
5760: 20 20 20 20 20 28 69 6e 73 2d 71 75 65 72 79 20 (ins-query
5770: 20 20 22 49 4e 53 45 52 54 20 49 4e 54 4f 20 73 "INSERT INTO s
5780: 65 73 73 69 6f 6e 5f 76 61 72 73 20 28 73 65 73 ession_vars (ses
5790: 73 69 6f 6e 5f 69 64 2c 70 61 67 65 2c 6b 65 79 sion_id,page,key
57a0: 2c 76 61 6c 75 65 29 20 56 41 4c 55 45 53 28 3f ,value) VALUES(?
57b0: 2c 3f 2c 3f 2c 3f 29 3b 22 29 0a 09 20 20 20 20 ,?,?,?);")..
57c0: 20 20 20 28 75 70 64 2d 71 75 65 72 79 20 20 20 (upd-query
57d0: 22 55 50 44 41 54 45 20 73 65 73 73 69 6f 6e 5f "UPDATE session_
57e0: 76 61 72 73 20 73 65 74 20 76 61 6c 75 65 3d 3f vars set value=?
57f0: 20 57 48 45 52 45 20 6b 65 79 3d 3f 20 41 4e 44 WHERE key=? AND
5800: 20 73 65 73 73 69 6f 6e 5f 69 64 3d 3f 20 41 4e session_id=? AN
5810: 44 20 70 61 67 65 3d 3f 3b 22 29 0a 09 20 20 20 D page=?;")..
5820: 20 20 20 20 28 63 68 61 6e 67 65 64 2d 63 6f 75 (changed-cou
5830: 6e 74 20 30 29 29 0a 09 20 20 3b 3b 20 73 61 76 nt 0)).. ;; sav
5840: 65 20 74 68 65 20 64 65 6c 74 61 20 6f 6e 6c 79 e the delta only
5850: 0a 09 20 20 28 66 6f 72 2d 65 61 63 68 0a 09 20 .. (for-each..
5860: 20 20 28 6c 61 6d 62 64 61 20 28 70 61 67 65 29 (lambda (page)
5870: 20 3b 3b 20 70 61 67 65 20 69 73 3a 20 22 2a 67 ;; page is: "*g
5880: 6c 6f 62 61 6c 76 61 72 73 2a 22 20 22 2a 73 65 lobalvars*" "*se
5890: 73 73 69 6f 6e 76 61 72 73 2a 22 20 6f 72 20 6f ssionvars*" or o
58a0: 74 68 65 72 73 74 72 69 6e 67 0a 09 20 20 20 20 therstring..
58b0: 20 28 6c 65 74 2a 20 28 28 62 65 66 6f 72 65 2d (let* ((before-
58c0: 61 66 74 65 72 2d 68 74 20 28 63 6f 6e 64 0a 09 after-ht (cond..
58d0: 09 09 09 20 20 20 20 20 20 28 28 73 74 72 69 6e ... ((strin
58e0: 67 3d 3f 20 70 61 67 65 20 22 2a 73 65 73 73 69 g=? page "*sessi
58f0: 6f 6e 76 61 72 73 2a 22 29 0a 09 09 09 09 20 20 onvars*").....
5900: 20 20 20 20 20 28 76 65 63 74 6f 72 20 28 73 64 (vector (sd
5910: 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 at-get-sessionva
5920: 72 73 20 73 65 6c 66 29 0a 09 09 09 09 09 20 20 rs self)......
5930: 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d 73 (sdat-get-s
5940: 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 essionvars-befor
5950: 65 20 73 65 6c 66 29 29 29 0a 09 09 09 09 20 20 e self))).....
5960: 20 20 20 20 20 28 28 73 74 72 69 6e 67 3d 3f 20 ((string=?
5970: 70 61 67 65 20 22 2a 67 6c 6f 62 61 6c 76 61 72 page "*globalvar
5980: 73 2a 22 29 0a 09 09 09 09 09 28 76 65 63 74 6f s*")......(vecto
5990: 72 20 28 73 64 61 74 2d 67 65 74 2d 67 6c 6f 62 r (sdat-get-glob
59a0: 61 6c 76 61 72 73 20 73 65 6c 66 29 0a 09 09 09 alvars self)....
59b0: 09 09 09 28 73 64 61 74 2d 67 65 74 2d 67 6c 6f ...(sdat-get-glo
59c0: 62 61 6c 76 61 72 73 2d 62 65 66 6f 72 65 20 73 balvars-before s
59d0: 65 6c 66 29 29 29 0a 09 09 09 09 20 20 20 20 20 elf))).....
59e0: 20 20 28 65 6c 73 65 20 0a 09 09 09 09 09 28 76 (else ......(v
59f0: 65 63 74 6f 72 20 28 73 64 61 74 2d 67 65 74 2d ector (sdat-get-
5a00: 70 61 67 65 76 61 72 73 20 73 65 6c 66 29 0a 09 pagevars self)..
5a10: 09 09 09 09 09 28 73 64 61 74 2d 67 65 74 2d 70 .....(sdat-get-p
5a20: 61 67 65 76 61 72 73 2d 62 65 66 6f 72 65 20 73 agevars-before s
5a30: 65 6c 66 29 29 29 29 29 0a 09 09 20 20 20 20 28 elf)))))... (
5a40: 6d 61 73 74 65 72 2d 68 74 20 20 20 28 76 65 63 master-ht (vec
5a50: 74 6f 72 2d 72 65 66 20 62 65 66 6f 72 65 2d 61 tor-ref before-a
5a60: 66 74 65 72 2d 68 74 20 30 29 29 0a 09 09 20 20 fter-ht 0))...
5a70: 20 20 28 62 65 66 6f 72 65 2d 68 74 20 20 20 28 (before-ht (
5a80: 76 65 63 74 6f 72 2d 72 65 66 20 62 65 66 6f 72 vector-ref befor
5a90: 65 2d 61 66 74 65 72 2d 68 74 20 31 29 29 0a 09 e-after-ht 1))..
5aa0: 09 20 20 20 20 28 6d 61 73 74 65 72 2d 6b 65 79 . (master-key
5ab0: 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 s (hash-table-ke
5ac0: 79 73 20 6d 61 73 74 65 72 2d 68 74 29 29 0a 09 ys master-ht))..
5ad0: 09 20 20 20 20 28 62 65 66 6f 72 65 2d 6b 65 79 . (before-key
5ae0: 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 s (hash-table-ke
5af0: 79 73 20 62 65 66 6f 72 65 2d 68 74 29 29 0a 09 ys before-ht))..
5b00: 09 20 20 20 20 28 61 6c 6c 2d 6b 65 79 73 20 28 . (all-keys (
5b10: 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 65 delete-duplicate
5b20: 73 20 28 61 70 70 65 6e 64 20 6d 61 73 74 65 72 s (append master
5b30: 2d 6b 65 79 73 20 62 65 66 6f 72 65 2d 6b 65 79 -keys before-key
5b40: 73 29 29 29 29 0a 09 20 20 20 20 20 20 20 28 66 s)))).. (f
5b50: 6f 72 2d 65 61 63 68 20 0a 09 09 28 6c 61 6d 62 or-each ...(lamb
5b60: 64 61 20 28 6b 65 79 29 0a 09 09 20 20 28 6c 65 da (key)... (le
5b70: 74 20 28 28 6d 61 73 74 65 72 2d 76 61 6c 75 65 t ((master-value
5b80: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
5b90: 2f 64 65 66 61 75 6c 74 20 6d 61 73 74 65 72 2d /default master-
5ba0: 68 74 20 6b 65 79 20 23 66 29 29 0a 09 09 09 28 ht key #f))....(
5bb0: 62 65 66 6f 72 65 2d 76 61 6c 75 65 20 28 68 61 before-value (ha
5bc0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
5bd0: 61 75 6c 74 20 62 65 66 6f 72 65 2d 68 74 20 6b ault before-ht k
5be0: 65 79 20 23 66 29 29 29 0a 09 09 20 20 20 20 28 ey #f)))... (
5bf0: 63 6f 6e 64 0a 09 09 20 20 20 20 20 3b 3b 20 62 cond... ;; b
5c00: 65 66 6f 72 65 20 61 6e 64 20 61 66 74 65 72 20 efore and after
5c10: 65 78 69 73 74 20 61 6e 64 20 76 61 6c 75 65 20 exist and value
5c20: 75 6e 63 68 61 6e 67 65 64 20 2d 20 64 6f 20 6e unchanged - do n
5c30: 6f 74 68 69 6e 67 0a 09 09 20 20 20 20 20 28 28 othing... ((
5c40: 61 6e 64 20 6d 61 73 74 65 72 2d 76 61 6c 75 65 and master-value
5c50: 20 62 65 66 6f 72 65 2d 76 61 6c 75 65 20 28 65 before-value (e
5c60: 71 75 61 6c 3f 20 6d 61 73 74 65 72 2d 76 61 6c qual? master-val
5c70: 75 65 20 62 65 66 6f 72 65 2d 76 61 6c 75 65 29 ue before-value)
5c80: 29 29 0a 09 09 20 20 20 20 20 3b 3b 20 62 65 66 ))... ;; bef
5c90: 6f 72 65 20 61 6e 64 20 61 66 74 65 72 20 65 78 ore and after ex
5ca0: 69 73 74 20 62 75 74 20 61 72 65 20 63 68 61 6e ist but are chan
5cb0: 67 65 64 0a 09 09 20 20 20 20 20 28 28 61 6e 64 ged... ((and
5cc0: 20 6d 61 73 74 65 72 2d 76 61 6c 75 65 20 62 65 master-value be
5cd0: 66 6f 72 65 2d 76 61 6c 75 65 29 0a 09 09 20 20 fore-value)...
5ce0: 20 20 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 (dbi:for-eac
5cf0: 68 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 h-row (lambda (t
5d00: 75 70 6c 65 29 0a 09 09 09 09 09 20 20 28 73 65 uple)...... (se
5d10: 74 21 20 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 t! changed-count
5d20: 20 28 2b 20 63 68 61 6e 67 65 64 2d 63 6f 75 6e (+ changed-coun
5d30: 74 20 31 29 29 29 0a 09 09 09 09 09 63 6f 6e 6e t 1)))......conn
5d40: 0a 09 09 09 09 09 28 73 3a 73 71 6c 70 61 72 61 ......(s:sqlpara
5d50: 6d 20 75 70 64 2d 71 75 65 72 79 20 6d 61 73 74 m upd-query mast
5d60: 65 72 2d 76 61 6c 75 65 20 6b 65 79 20 73 65 73 er-value key ses
5d70: 73 69 6f 6e 2d 69 64 20 70 61 67 65 29 29 29 0a sion-id page))).
5d80: 09 09 20 20 20 20 20 3b 3b 20 6d 61 73 74 65 72 .. ;; master
5d90: 2d 76 61 6c 75 65 20 6e 6f 20 6c 6f 6e 67 65 72 -value no longer
5da0: 20 65 78 69 73 74 73 20 28 69 2e 65 2e 20 23 66 exists (i.e. #f
5db0: 29 20 2d 20 72 65 6d 6f 76 65 20 69 74 65 6d 0a ) - remove item.
5dc0: 09 09 20 20 20 20 20 28 28 6e 6f 74 20 6d 61 73 .. ((not mas
5dd0: 74 65 72 2d 76 61 6c 75 65 29 0a 09 09 20 20 20 ter-value)...
5de0: 20 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 (dbi:for-each
5df0: 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 75 -row (lambda (tu
5e00: 70 6c 65 29 0a 09 09 09 09 09 20 20 28 73 65 74 ple)...... (set
5e10: 21 20 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 ! changed-count
5e20: 28 2b 20 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 (+ changed-count
5e30: 20 31 29 29 29 0a 09 09 09 09 09 63 6f 6e 6e 0a 1)))......conn.
5e40: 09 09 09 09 09 28 73 3a 73 71 6c 70 61 72 61 6d .....(s:sqlparam
5e50: 20 64 65 6c 2d 71 75 65 72 79 20 73 65 73 73 69 del-query sessi
5e60: 6f 6e 2d 69 64 20 70 61 67 65 20 6b 65 79 29 29 on-id page key))
5e70: 29 0a 09 09 20 20 20 20 20 3b 3b 20 62 65 66 6f )... ;; befo
5e80: 72 65 2d 76 61 6c 75 65 20 64 6f 65 73 6e 27 74 re-value doesn't
5e90: 20 65 78 69 73 74 20 2d 20 69 6e 73 65 72 74 20 exist - insert
5ea0: 61 20 6e 65 77 20 76 61 6c 75 65 0a 09 09 20 20 a new value...
5eb0: 20 20 20 28 28 6e 6f 74 20 62 65 66 6f 72 65 2d ((not before-
5ec0: 76 61 6c 75 65 29 0a 09 09 20 20 20 20 20 20 28 value)... (
5ed0: 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 dbi:for-each-row
5ee0: 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 29 (lambda (tuple)
5ef0: 0a 09 09 09 09 09 20 20 28 73 65 74 21 20 63 68 ...... (set! ch
5f00: 61 6e 67 65 64 2d 63 6f 75 6e 74 20 28 2b 20 63 anged-count (+ c
5f10: 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 31 29 29 hanged-count 1))
5f20: 29 0a 09 09 09 09 09 63 6f 6e 6e 0a 09 09 09 09 )......conn.....
5f30: 09 28 73 3a 73 71 6c 70 61 72 61 6d 20 69 6e 73 .(s:sqlparam ins
5f40: 2d 71 75 65 72 79 20 73 65 73 73 69 6f 6e 2d 69 -query session-i
5f50: 64 20 70 61 67 65 20 6b 65 79 20 6d 61 73 74 65 d page key maste
5f60: 72 2d 76 61 6c 75 65 29 29 29 0a 09 09 20 20 20 r-value)))...
5f70: 20 20 28 65 6c 73 65 20 28 65 72 72 3a 6c 6f 67 (else (err:log
5f80: 20 22 53 68 6f 75 6c 64 6e 27 74 20 67 65 74 20 "Shouldn't get
5f90: 68 65 72 65 22 29 29 29 29 29 0a 09 09 61 6c 6c here")))))...all
5fa0: 2d 6b 65 79 73 29 29 29 20 3b 3b 20 70 72 6f 63 -keys))) ;; proc
5fb0: 65 73 73 20 61 6c 6c 20 6b 65 79 73 0a 09 20 20 ess all keys..
5fc0: 20 28 6c 69 73 74 20 22 2a 73 65 73 73 69 6f 6e (list "*session
5fd0: 76 61 72 73 2a 22 20 22 2a 67 6c 6f 62 61 6c 76 vars*" "*globalv
5fe0: 61 72 73 2a 22 20 70 61 67 65 2d 6e 61 6d 65 29 ars*" page-name)
5ff0: 29 29 29 29 29 0a 0a 3b 3b 20 28 70 67 3a 73 71 )))))..;; (pg:sq
6000: 6c 2d 6e 75 6c 6c 2d 6f 62 6a 65 63 74 3f 20 65 l-null-object? e
6010: 6c 65 6d 65 6e 74 29 0a 28 64 65 66 69 6e 65 20 lement).(define
6020: 28 73 65 73 73 69 6f 6e 3a 72 65 61 64 2d 63 6f (session:read-co
6030: 6e 66 69 67 20 73 65 6c 66 29 0a 20 20 28 6c 65 nfig self). (le
6040: 74 20 28 28 6e 61 6d 65 20 28 73 74 72 69 6e 67 t ((name (string
6050: 2d 61 70 70 65 6e 64 20 22 2e 22 20 28 70 61 74 -append "." (pat
6060: 68 6e 61 6d 65 2d 66 69 6c 65 20 28 63 61 72 20 hname-file (car
6070: 28 61 72 67 76 29 29 29 20 22 2e 63 6f 6e 66 69 (argv))) ".confi
6080: 67 22 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e g"))). (if (n
6090: 6f 74 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f ot (file-exists?
60a0: 20 6e 61 6d 65 29 29 0a 09 28 70 72 69 6e 74 20 name))..(print
60b0: 6e 61 6d 65 20 22 20 6e 6f 74 20 66 6f 75 6e 64 name " not found
60c0: 20 61 74 20 22 20 28 63 75 72 72 65 6e 74 2d 64 at " (current-d
60d0: 69 72 65 63 74 6f 72 79 29 29 0a 09 28 6c 65 74 irectory))..(let
60e0: 2a 20 28 28 66 70 20 28 6f 70 65 6e 2d 69 6e 70 * ((fp (open-inp
60f0: 75 74 2d 66 69 6c 65 20 6e 61 6d 65 29 29 0a 09 ut-file name))..
6100: 20 20 20 20 20 20 20 28 69 6e 69 74 61 72 67 73 (initargs
6110: 20 28 72 65 61 64 20 66 70 29 29 29 0a 09 20 20 (read fp)))..
6120: 28 63 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 6f 72 (close-input-por
6130: 74 20 66 70 29 0a 09 20 20 69 6e 69 74 61 72 67 t fp).. initarg
6140: 73 29 29 29 29 0a 0a 3b 3b 20 63 61 6c 6c 20 74 s))))..;; call t
6150: 68 65 20 63 6f 6e 74 72 6f 6c 6c 65 72 20 69 66 he controller if
6160: 20 69 74 20 65 78 69 73 74 73 0a 3b 3b 20 0a 3b it exists.;; .;
6170: 3b 20 57 41 52 4e 49 4e 47 20 2d 20 74 68 69 73 ; WARNING - this
6180: 20 63 6f 64 65 20 6e 65 65 64 73 20 61 20 64 65 code needs a de
6190: 66 65 6e 63 65 20 61 67 61 69 6e 73 20 72 65 63 fence agains rec
61a0: 75 72 73 69 76 65 20 63 61 6c 6c 69 6e 67 21 21 ursive calling!!
61b0: 21 21 21 0a 3b 3b 0a 3b 3b 20 20 20 49 20 73 75 !!!.;;.;; I su
61c0: 67 67 65 73 74 20 61 20 6c 69 6d 69 74 20 6f 66 ggest a limit of
61d0: 20 31 30 30 20 63 61 6c 6c 73 2e 20 50 6c 65 6e 100 calls. Plen
61e0: 74 79 20 66 6f 72 20 61 6c 6c 6f 77 69 6e 67 20 ty for allowing
61f0: 6d 75 6c 74 69 70 6c 65 20 69 6e 73 74 61 6e 63 multiple instanc
6200: 65 73 0a 3b 3b 20 20 20 6f 66 20 61 20 70 61 67 es.;; of a pag
6210: 65 20 69 6e 73 69 64 65 20 61 6e 6f 74 68 65 72 e inside another
6220: 20 70 61 67 65 2e 20 0a 3b 3b 0a 3b 3b 20 70 61 page. .;;.;; pa
6230: 72 74 73 20 3d 20 27 62 6f 74 68 20 7c 20 27 63 rts = 'both | 'c
6240: 6f 6e 74 72 6f 6c 20 7c 20 27 76 69 65 77 0a 3b ontrol | 'view.;
6250: 3b 0a 0a 28 64 65 66 69 6e 65 20 28 66 69 6c 65 ;..(define (file
6260: 73 2d 72 65 61 64 2d 3e 73 74 72 69 6e 67 20 2e s-read->string .
6270: 20 66 69 6c 65 73 29 0a 20 20 28 73 74 72 69 6e files). (strin
6280: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 0a 20 g-intersperse .
6290: 20 20 28 61 70 70 6c 79 20 61 70 70 65 6e 64 20 (apply append
62a0: 28 6d 61 70 20 66 69 6c 65 2d 72 65 61 64 2d 3e (map file-read->
62b0: 73 74 72 69 6e 67 20 66 69 6c 65 73 29 29 20 22 string files)) "
62c0: 5c 6e 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 \n"))..(define (
62d0: 66 69 6c 65 2d 72 65 61 64 2d 3e 73 74 72 69 6e file-read->strin
62e0: 67 20 66 29 20 0a 20 20 28 6c 65 74 20 28 28 70 g f) . (let ((p
62f0: 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 66 69 6c (open-input-fil
6300: 65 20 66 29 29 29 0a 20 20 20 20 28 6c 65 74 20 e f))). (let
6310: 6c 6f 6f 70 20 28 28 68 65 64 20 28 72 65 61 64 loop ((hed (read
6320: 2d 6c 69 6e 65 20 70 29 29 0a 09 20 20 20 20 20 -line p))..
6330: 20 20 28 72 65 73 20 27 28 29 29 29 0a 20 20 20 (res '())).
6340: 20 20 20 28 69 66 20 28 65 6f 66 2d 6f 62 6a 65 (if (eof-obje
6350: 63 74 3f 20 68 65 64 29 0a 09 20 20 72 65 73 0a ct? hed).. res.
6360: 09 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d 6c . (loop (read-l
6370: 69 6e 65 20 70 29 28 61 70 70 65 6e 64 20 72 65 ine p)(append re
6380: 73 20 28 6c 69 73 74 20 68 65 64 29 29 29 29 29 s (list hed)))))
6390: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 70 72 6f ))..(define (pro
63a0: 63 65 73 73 2d 70 6f 72 74 20 70 29 0a 20 20 28 cess-port p). (
63b0: 6c 65 74 20 28 28 65 20 28 69 6e 74 65 72 61 63 let ((e (interac
63c0: 74 69 6f 6e 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 tion-environment
63d0: 29 29 29 0a 20 20 20 20 28 6d 61 70 20 0a 20 20 ))). (map .
63e0: 20 20 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 20 (lambda (x).
63f0: 20 20 20 20 20 20 28 63 6f 6e 64 0a 09 28 28 6c (cond..((l
6400: 69 73 74 3f 20 78 29 20 78 29 0a 09 28 28 73 74 ist? x) x)..((st
6410: 72 69 6e 67 3f 20 78 29 20 78 29 0a 09 28 65 6c ring? x) x)..(el
6420: 73 65 20 27 28 29 29 29 29 0a 20 20 20 20 20 28 se '()))). (
6430: 70 6f 72 74 2d 6d 61 70 20 28 6c 61 6d 62 64 61 port-map (lambda
6440: 20 28 73 29 0a 09 09 20 28 65 76 61 6c 20 73 20 (s)... (eval s
6450: 65 29 29 0a 09 20 20 20 20 20 20 20 28 6c 61 6d e)).. (lam
6460: 62 64 61 20 28 29 28 72 65 61 64 20 70 29 29 29 bda ()(read p)))
6470: 29 29 29 0a 0a 3b 3b 20 4d 61 79 20 32 30 31 31 )))..;; May 2011
6480: 2c 20 70 75 74 74 69 6e 67 20 61 6c 6c 20 70 61 , putting all pa
6490: 67 65 73 20 69 6e 74 6f 20 6f 6e 65 20 64 69 72 ges into one dir
64a0: 65 63 74 6f 72 79 20 66 6f 72 20 74 68 65 20 66 ectory for the f
64b0: 6f 6c 6c 6f 77 69 6e 67 20 72 65 61 73 6f 6e 73 ollowing reasons
64c0: 3a 0a 3b 3b 20 20 20 31 2e 20 77 61 6e 74 20 66 :.;; 1. want f
64d0: 69 6c 65 6e 61 6d 65 20 74 6f 20 72 65 66 6c 65 ilename to refle
64e0: 63 74 20 70 61 67 65 20 6e 61 6d 65 20 28 65 6d ct page name (em
64f0: 61 63 73 20 6c 69 6d 69 74 61 74 69 6f 6e 29 0a acs limitation).
6500: 3b 3b 20 20 20 32 2e 20 74 68 61 74 27 73 20 69 ;; 2. that's i
6510: 74 21 20 6e 6f 20 6f 74 68 65 72 20 72 65 61 73 t! no other reas
6520: 6f 6e 2e 20 63 6f 75 6c 64 20 6d 61 6b 65 20 69 on. could make i
6530: 74 20 63 6f 6e 66 69 67 75 72 61 62 6c 65 20 2e t configurable .
6540: 2e 2e 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 ...(define (sess
6550: 69 6f 6e 3a 63 61 6c 6c 2d 70 61 72 74 73 20 73 ion:call-parts s
6560: 65 6c 66 20 70 61 67 65 20 70 61 72 74 73 29 0a elf page parts).
6570: 20 20 28 73 64 61 74 2d 73 65 74 2d 63 75 72 72 (sdat-set-curr
6580: 2d 70 61 67 65 21 20 73 65 6c 66 20 70 61 67 65 -page! self page
6590: 29 0a 20 20 3b 3b 20 28 73 65 73 73 69 6f 6e 3a ). ;; (session:
65a0: 6c 6f 67 20 73 65 6c 66 20 22 70 61 67 65 2d 64 log self "page-d
65b0: 69 72 2d 73 74 79 6c 65 3a 20 22 20 28 73 64 61 ir-style: " (sda
65c0: 74 2d 67 65 74 2d 70 61 67 65 2d 64 69 72 2d 73 t-get-page-dir-s
65d0: 74 79 6c 65 20 73 65 6c 66 29 29 0a 20 20 28 6c tyle self)). (l
65e0: 65 74 2a 20 28 28 64 69 72 2d 73 74 79 6c 65 20 et* ((dir-style
65f0: 3b 3b 20 28 65 71 75 61 6c 3f 20 28 73 64 61 74 ;; (equal? (sdat
6600: 2d 67 65 74 2d 70 61 67 65 2d 64 69 72 2d 73 74 -get-page-dir-st
6610: 79 6c 65 20 73 65 6c 66 29 20 22 6f 6e 65 64 69 yle self) "onedi
6620: 72 22 29 29 20 3b 3b 20 66 6c 61 67 20 23 74 20 r")) ;; flag #t
6630: 66 6f 72 20 6f 6e 65 64 69 72 2c 20 23 66 20 66 for onedir, #f f
6640: 6f 72 20 6f 6c 64 20 73 74 79 6c 65 0a 09 20 20 or old style..
6650: 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 2d 64 (sdat-get-page-d
6660: 69 72 2d 73 74 79 6c 65 20 73 65 6c 66 29 29 0a ir-style self)).
6670: 09 20 28 64 69 72 20 20 20 20 20 28 73 74 72 69 . (dir (stri
6680: 6e 67 2d 61 70 70 65 6e 64 20 28 73 64 61 74 2d ng-append (sdat-
6690: 67 65 74 2d 73 72 6f 6f 74 20 73 65 6c 66 29 20 get-sroot self)
66a0: 0a 09 09 09 09 20 28 69 66 20 64 69 72 2d 73 74 ..... (if dir-st
66b0: 79 6c 65 20 0a 09 09 09 09 20 20 20 20 20 28 63 yle ..... (c
66c0: 6f 6e 63 20 22 2f 70 61 67 65 73 2f 22 29 0a 09 onc "/pages/")..
66d0: 09 09 09 20 20 20 20 20 28 63 6f 6e 63 20 22 2f ... (conc "/
66e0: 70 61 67 65 73 2f 22 20 70 61 67 65 29 29 29 29 pages/" page))))
66f0: 0a 09 20 28 63 6f 6e 74 72 6f 6c 20 28 73 74 72 .. (control (str
6700: 69 6e 67 2d 61 70 70 65 6e 64 20 64 69 72 20 28 ing-append dir (
6710: 69 66 20 64 69 72 2d 73 74 79 6c 65 20 0a 09 09 if dir-style ...
6720: 09 09 09 20 28 63 6f 6e 63 20 70 61 67 65 20 22 ... (conc page "
6730: 5f 63 74 72 6c 2e 73 63 6d 22 29 0a 09 09 09 09 _ctrl.scm").....
6740: 09 20 22 2f 63 6f 6e 74 72 6f 6c 2e 73 63 6d 22 . "/control.scm"
6750: 29 29 29 0a 09 20 28 76 69 65 77 20 20 20 20 28 ))).. (view (
6760: 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 64 69 string-append di
6770: 72 20 28 69 66 20 64 69 72 2d 73 74 79 6c 65 20 r (if dir-style
6780: 0a 09 09 09 09 09 20 28 63 6f 6e 63 20 70 61 67 ...... (conc pag
6790: 65 20 22 5f 76 69 65 77 2e 73 63 6d 22 29 0a 09 e "_view.scm")..
67a0: 09 09 09 09 20 22 2f 76 69 65 77 2e 73 63 6d 22 .... "/view.scm"
67b0: 29 29 29 0a 09 20 28 6c 6f 61 64 2d 76 69 65 77 ))).. (load-view
67c0: 20 20 20 20 28 61 6e 64 20 28 66 69 6c 65 2d 65 (and (file-e
67d0: 78 69 73 74 73 3f 20 76 69 65 77 29 0a 09 09 09 xists? view)....
67e0: 20 20 20 20 28 6f 72 20 28 65 71 3f 20 70 61 72 (or (eq? par
67f0: 74 73 20 27 62 6f 74 68 29 28 65 71 3f 20 70 61 ts 'both)(eq? pa
6800: 72 74 73 20 27 76 69 65 77 29 29 29 29 0a 09 20 rts 'view))))..
6810: 28 6c 6f 61 64 2d 63 6f 6e 74 72 6f 6c 20 28 61 (load-control (a
6820: 6e 64 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f nd (file-exists?
6830: 20 63 6f 6e 74 72 6f 6c 29 0a 09 09 09 20 20 20 control)....
6840: 20 28 6f 72 20 28 65 71 3f 20 70 61 72 74 73 20 (or (eq? parts
6850: 27 62 6f 74 68 29 28 65 71 3f 20 70 61 72 74 73 'both)(eq? parts
6860: 20 27 63 6f 6e 74 72 6f 6c 29 29 29 29 0a 09 20 'control))))..
6870: 28 76 69 65 77 2d 64 61 74 20 20 20 27 28 29 29 (view-dat '())
6880: 29 0a 20 20 20 20 3b 3b 20 28 73 65 73 73 69 6f ). ;; (sessio
6890: 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 64 69 72 2d n:log self "dir-
68a0: 73 74 79 6c 65 3a 20 22 20 64 69 72 2d 73 74 79 style: " dir-sty
68b0: 6c 65 29 0a 20 3b 3b 20 20 20 28 73 75 67 61 72 le). ;; (sugar
68c0: 20 22 2f 68 6f 6d 65 2f 6d 61 74 74 2f 6b 69 61 "/home/matt/kia
68d0: 74 6f 61 2f 73 74 6d 6c 2f 73 75 67 61 72 2e 73 toa/stml/sugar.s
68e0: 63 6d 22 20 29 29 0a 20 20 20 20 3b 3b 20 28 70 cm" )). ;; (p
68f0: 72 69 6e 74 20 22 64 69 72 3d 22 20 64 69 72 20 rint "dir=" dir
6900: 22 20 63 6f 6e 74 72 6f 6c 3d 22 20 63 6f 6e 74 " control=" cont
6910: 72 6f 6c 20 22 20 76 69 65 77 3d 22 20 76 69 65 rol " view=" vie
6920: 77 20 22 20 6c 6f 61 64 2d 76 69 65 77 3d 22 20 w " load-view="
6930: 6c 6f 61 64 2d 76 69 65 77 20 22 20 6c 6f 61 64 load-view " load
6940: 3d 63 6f 6e 74 72 6f 6c 3d 22 20 6c 6f 61 64 2d =control=" load-
6950: 63 6f 6e 74 72 6f 6c 29 0a 20 20 20 20 28 69 66 control). (if
6960: 20 6c 6f 61 64 2d 63 6f 6e 74 72 6f 6c 0a 09 28 load-control..(
6970: 62 65 67 69 6e 0a 09 20 20 28 6c 6f 61 64 20 63 begin.. (load c
6980: 6f 6e 74 72 6f 6c 29 0a 09 20 20 28 73 65 73 73 ontrol).. (sess
6990: 69 6f 6e 3a 73 65 74 2d 63 61 6c 6c 65 64 21 20 ion:set-called!
69a0: 73 65 6c 66 20 70 61 67 65 29 29 29 0a 20 20 20 self page))).
69b0: 20 3b 3b 20 6d 6f 76 65 20 74 68 69 73 20 74 6f ;; move this to
69c0: 20 77 68 65 72 65 20 69 74 20 67 65 74 73 20 65 where it gets e
69d0: 78 65 63 74 75 74 65 64 20 6f 6e 6c 79 20 6f 6e xectuted only on
69e0: 63 65 0a 20 20 20 20 3b 3b 0a 20 20 20 20 3b 3b ce. ;;. ;;
69f0: 28 73 3a 6c 6f 67 20 22 73 3a 62 20 79 69 65 6c (s:log "s:b yiel
6a00: 64 73 20 22 20 28 73 3a 62 20 22 62 6c 61 68 22 ds " (s:b "blah"
6a10: 29 29 0a 20 20 20 20 28 69 66 20 6c 6f 61 64 2d )). (if load-
6a20: 76 69 65 77 0a 09 3b 3b 20 6f 70 74 69 6f 6e 20 view..;; option
6a30: 6f 6e 65 3a 0a 09 3b 3b 0a 09 3b 3b 20 28 6c 65 one:..;;..;; (le
6a40: 74 20 28 28 69 6e 70 20 28 6f 70 65 6e 2d 69 6e t ((inp (open-in
6a50: 70 75 74 2d 73 74 72 69 6e 67 20 0a 09 3b 3b 20 put-string ..;;
6a60: 09 20 20 20 20 28 66 69 6c 65 73 2d 72 65 61 64 . (files-read
6a70: 2d 3e 73 74 72 69 6e 67 20 22 2f 68 6f 6d 65 2f ->string "/home/
6a80: 6d 61 74 74 2f 6b 69 61 74 6f 61 2f 73 74 6d 6c matt/kiatoa/stml
6a90: 2f 73 75 67 61 72 2e 73 63 6d 22 20 0a 09 3b 3b /sugar.scm" ..;;
6aa0: 20 09 09 09 09 76 69 65 77 29 29 29 29 0a 09 3b ....view))))..;
6ab0: 3b 20 20 20 28 6d 61 70 20 0a 09 3b 3b 20 20 20 ; (map ..;;
6ac0: 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 3b 3b (lambda (x)..;;
6ad0: 20 20 20 20 20 20 28 63 6f 6e 64 0a 09 3b 3b 20 (cond..;;
6ae0: 20 20 20 20 20 20 28 28 6c 69 73 74 3f 20 78 29 ((list? x)
6af0: 20 78 29 0a 09 3b 3b 20 20 20 20 20 20 20 28 28 x)..;; ((
6b00: 73 74 72 69 6e 67 3f 20 78 29 20 78 29 0a 09 3b string? x) x)..;
6b10: 3b 20 20 20 20 20 20 20 28 65 6c 73 65 20 27 28 ; (else '(
6b20: 29 29 29 29 0a 09 3b 3b 20 20 20 20 28 70 6f 72 ))))..;; (por
6b30: 74 2d 6d 61 70 20 65 76 61 6c 20 28 6c 61 6d 62 t-map eval (lamb
6b40: 64 61 20 28 29 0a 09 3b 3b 20 09 09 20 28 72 65 da ()..;; .. (re
6b50: 61 64 20 69 6e 70 29 29 29 29 29 0a 09 3b 3b 0a ad inp)))))..;;.
6b60: 09 3b 3b 20 6f 70 74 69 6f 6e 20 74 77 6f 3a 0a .;; option two:.
6b70: 09 3b 3b 0a 09 28 6c 65 74 2a 20 28 3b 3b 20 28 .;;..(let* (;; (
6b80: 69 6e 70 73 20 28 6d 61 70 20 6f 70 65 6e 2d 69 inps (map open-i
6b90: 6e 70 75 74 2d 66 69 6c 65 20 28 6c 69 73 74 20 nput-file (list
6ba0: 76 69 65 77 29 29 29 20 3b 3b 20 73 75 67 61 72 view))) ;; sugar
6bb0: 20 76 69 65 77 29 29 29 0a 09 20 20 20 20 20 20 view)))..
6bc0: 20 28 70 20 20 20 20 28 6f 70 65 6e 2d 69 6e 70 (p (open-inp
6bd0: 75 74 2d 66 69 6c 65 20 76 69 65 77 29 29 20 3b ut-file view)) ;
6be0: 3b 20 28 61 70 70 6c 79 20 6d 61 6b 65 2d 63 6f ; (apply make-co
6bf0: 6e 63 61 74 65 6e 61 74 65 64 2d 70 6f 72 74 20 ncatenated-port
6c00: 69 6e 70 73 29 29 0a 09 20 20 20 20 20 20 20 28 inps)).. (
6c10: 64 61 74 20 20 28 70 72 6f 63 65 73 73 2d 70 6f dat (process-po
6c20: 72 74 20 70 29 29 29 0a 09 09 3b 3b 28 6d 61 70 rt p)))...;;(map
6c30: 20 0a 09 09 3b 3b 20 20 20 20 20 20 28 6c 61 6d ...;; (lam
6c40: 62 64 61 20 28 78 29 0a 09 09 3b 3b 09 28 63 6f bda (x)...;;.(co
6c50: 6e 64 0a 09 09 3b 3b 09 20 28 28 6c 69 73 74 3f nd...;;. ((list?
6c60: 20 78 29 20 78 29 0a 09 09 3b 3b 09 20 28 28 73 x) x)...;;. ((s
6c70: 74 72 69 6e 67 3f 20 78 29 20 78 29 0a 09 09 3b tring? x) x)...;
6c80: 3b 09 20 28 65 6c 73 65 20 27 28 29 29 29 29 0a ;. (else '()))).
6c90: 09 09 3b 3b 20 20 20 20 20 20 28 70 6f 72 74 2d ..;; (port-
6ca0: 6d 61 70 20 65 76 61 6c 20 28 6c 61 6d 62 64 61 map eval (lambda
6cb0: 20 28 29 28 72 65 61 64 20 70 29 29 29 29 29 29 ()(read p))))))
6cc0: 0a 09 20 20 3b 3b 20 28 6d 61 70 20 63 6c 6f 73 .. ;; (map clos
6cd0: 65 2d 69 6e 70 75 74 2d 70 6f 72 74 20 69 6e 70 e-input-port inp
6ce0: 73 29 0a 09 20 20 28 63 6c 6f 73 65 2d 69 6e 70 s).. (close-inp
6cf0: 75 74 2d 70 6f 72 74 20 70 29 0a 09 20 20 64 61 ut-port p).. da
6d00: 74 29 0a 09 28 6c 69 73 74 20 22 3c 70 3e 50 61 t)..(list "<p>Pa
6d10: 67 65 20 6e 6f 74 20 66 6f 75 6e 64 20 22 20 70 ge not found " p
6d20: 61 67 65 20 22 20 3c 2f 70 3e 22 29 29 29 29 0a age " </p>")))).
6d30: 0a 3b 3b 28 64 65 66 69 6e 65 20 28 73 65 73 73 .;;(define (sess
6d40: 69 6f 6e 3a 63 61 6c 6c 20 73 65 6c 66 20 70 61 ion:call self pa
6d50: 67 65 29 0a 3b 3b 20 20 28 73 65 73 73 69 6f 6e ge).;; (session
6d60: 3a 63 61 6c 6c 2d 70 61 72 74 73 20 73 65 6c 66 :call-parts self
6d70: 20 70 61 67 65 20 27 62 6f 74 68 29 29 0a 0a 28 page 'both))..(
6d80: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
6d90: 63 61 6c 6c 20 73 65 6c 66 20 70 61 67 65 20 70 call self page p
6da0: 61 72 74 73 29 0a 20 20 28 73 65 73 73 69 6f 6e arts). (session
6db0: 3a 63 61 6c 6c 2d 70 61 72 74 73 20 73 65 6c 66 :call-parts self
6dc0: 20 70 61 67 65 20 27 62 6f 74 68 29 29 0a 0a 28 page 'both))..(
6dd0: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
6de0: 6c 6f 61 64 2d 6d 6f 64 65 6c 20 73 65 6c 66 20 load-model self
6df0: 6d 6f 64 65 6c 29 0a 20 20 28 6c 65 74 20 28 28 model). (let ((
6e00: 6d 6f 64 65 6c 2e 73 63 6d 20 28 73 74 72 69 6e model.scm (strin
6e10: 67 2d 61 70 70 65 6e 64 20 28 73 64 61 74 2d 67 g-append (sdat-g
6e20: 65 74 2d 73 72 6f 6f 74 20 73 65 6c 66 29 20 22 et-sroot self) "
6e30: 2f 6d 6f 64 65 6c 73 2f 22 20 6d 6f 64 65 6c 20 /models/" model
6e40: 22 2e 73 63 6d 22 29 29 0a 09 28 6d 6f 64 65 6c ".scm"))..(model
6e50: 2e 73 6f 20 20 28 73 74 72 69 6e 67 2d 61 70 70 .so (string-app
6e60: 65 6e 64 20 28 73 64 61 74 2d 67 65 74 2d 73 72 end (sdat-get-sr
6e70: 6f 6f 74 20 73 65 6c 66 29 20 22 2f 6d 6f 64 65 oot self) "/mode
6e80: 6c 73 2f 22 20 6d 6f 64 65 6c 20 22 2e 73 6f 22 ls/" model ".so"
6e90: 29 29 29 0a 20 20 20 20 28 69 66 20 28 66 69 6c ))). (if (fil
6ea0: 65 2d 65 78 69 73 74 73 3f 20 6d 6f 64 65 6c 2e e-exists? model.
6eb0: 73 6f 29 0a 09 28 6c 6f 61 64 20 6d 6f 64 65 6c so)..(load model
6ec0: 2e 73 6f 29 0a 09 28 69 66 20 28 66 69 6c 65 2d .so)..(if (file-
6ed0: 65 78 69 73 74 73 3f 20 6d 6f 64 65 6c 2e 73 63 exists? model.sc
6ee0: 6d 29 0a 09 20 20 20 20 28 6c 6f 61 64 20 6d 6f m).. (load mo
6ef0: 64 65 6c 2e 73 63 6d 29 0a 09 20 20 20 20 28 73 del.scm).. (s
6f00: 3a 6c 6f 67 20 22 45 52 52 4f 52 3a 20 6d 6f 64 :log "ERROR: mod
6f10: 65 6c 20 22 20 6d 6f 64 65 6c 2e 73 63 6d 20 22 el " model.scm "
6f20: 20 6e 6f 74 20 66 6f 75 6e 64 22 29 29 29 29 29 not found")))))
6f30: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ..(define (sessi
6f40: 6f 6e 3a 6d 6f 64 65 6c 2d 70 61 74 68 20 73 65 on:model-path se
6f50: 6c 66 20 6d 6f 64 65 6c 29 0a 20 20 28 73 74 72 lf model). (str
6f60: 69 6e 67 2d 61 70 70 65 6e 64 20 28 73 64 61 74 ing-append (sdat
6f70: 2d 67 65 74 2d 73 72 6f 6f 74 20 73 65 6c 66 29 -get-sroot self)
6f80: 20 22 2f 6d 6f 64 65 6c 73 2f 22 20 6d 6f 64 65 "/models/" mode
6f90: 6c 20 22 2e 73 63 6d 22 29 29 0a 0a 28 64 65 66 l ".scm"))..(def
6fa0: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 70 70 2d ine (session:pp-
6fb0: 66 6f 72 6d 64 61 74 20 73 65 6c 66 29 0a 20 20 formdat self).
6fc0: 28 6c 65 74 20 28 28 64 61 74 20 28 66 6f 72 6d (let ((dat (form
6fd0: 64 61 74 3a 61 6c 6c 2d 3e 73 74 72 69 6e 67 73 dat:all->strings
6fe0: 20 28 73 64 61 74 2d 67 65 74 2d 66 6f 72 6d 64 (sdat-get-formd
6ff0: 61 74 20 73 65 6c 66 29 29 29 29 0a 20 20 20 20 at self)))).
7000: 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
7010: 72 73 65 20 64 61 74 20 22 3c 62 72 3e 20 22 29 rse dat "<br> ")
7020: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 ))..(define (ses
7030: 73 69 6f 6e 3a 70 61 72 61 6d 2d 3e 73 74 72 69 sion:param->stri
7040: 6e 67 20 70 61 72 61 6d 73 29 0a 20 20 3b 3b 20 ng params). ;;
7050: 28 65 72 72 3a 6c 6f 67 20 22 70 61 72 61 6d 73 (err:log "params
7060: 3d 22 20 70 61 72 61 6d 73 29 0a 20 20 28 69 66 =" params). (if
7070: 20 28 3c 20 28 6c 65 6e 67 74 68 20 70 61 72 61 (< (length para
7080: 6d 73 29 20 31 29 0a 20 20 20 20 20 20 22 22 0a ms) 1). "".
7090: 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 (let loop
70a0: 28 28 6b 65 79 20 28 63 61 72 20 70 61 72 61 6d ((key (car param
70b0: 73 29 29 0a 09 09 20 28 76 61 6c 20 28 63 61 64 s))... (val (cad
70c0: 72 20 70 61 72 61 6d 73 29 29 0a 09 09 20 28 74 r params))... (t
70d0: 61 69 6c 20 28 63 64 64 72 20 70 61 72 61 6d 73 ail (cddr params
70e0: 29 29 0a 09 09 20 28 72 65 73 75 6c 74 20 27 28 ))... (result '(
70f0: 29 29 29 0a 09 28 6c 65 74 20 28 28 6e 65 77 72 )))..(let ((newr
7100: 65 73 75 6c 74 20 28 63 6f 6e 73 20 28 73 74 72 esult (cons (str
7110: 69 6e 67 2d 61 70 70 65 6e 64 20 28 73 3a 61 6e ing-append (s:an
7120: 79 2d 3e 73 74 72 69 6e 67 20 6b 65 79 29 20 22 y->string key) "
7130: 3d 22 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e =" (s:any->strin
7140: 67 20 76 61 6c 29 29 0a 09 09 09 20 20 20 20 20 g val))....
7150: 20 20 72 65 73 75 6c 74 29 29 29 0a 09 20 20 28 result))).. (
7160: 69 66 20 28 3c 20 28 6c 65 6e 67 74 68 20 74 61 if (< (length ta
7170: 69 6c 29 20 31 29 20 3b 3b 20 74 72 75 65 20 69 il) 1) ;; true i
7180: 66 20 64 6f 6e 65 0a 09 20 20 20 20 20 20 28 73 f done.. (s
7190: 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
71a0: 65 20 6e 65 77 72 65 73 75 6c 74 20 22 26 22 29 e newresult "&")
71b0: 0a 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 .. (loop (c
71c0: 61 72 20 74 61 69 6c 29 28 63 61 64 72 20 74 61 ar tail)(cadr ta
71d0: 69 6c 29 28 63 64 64 72 20 74 61 69 6c 29 20 6e il)(cddr tail) n
71e0: 65 77 72 65 73 75 6c 74 29 29 29 29 29 29 0a 0a ewresult))))))..
71f0: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
7200: 3a 6c 69 6e 6b 2d 74 6f 20 73 65 6c 66 20 70 61 :link-to self pa
7210: 67 65 20 70 61 72 61 6d 73 29 0a 20 20 28 6c 65 ge params). (le
7220: 74 2a 20 28 28 73 65 72 76 65 72 20 20 20 20 28 t* ((server (
7230: 69 66 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d if (get-environm
7240: 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 48 54 ent-variable "HT
7250: 54 50 5f 48 4f 53 54 22 29 0a 09 09 09 28 67 65 TP_HOST")....(ge
7260: 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 t-environment-va
7270: 72 69 61 62 6c 65 20 22 48 54 54 50 5f 48 4f 53 riable "HTTP_HOS
7280: 54 22 29 0a 09 09 09 28 67 65 74 2d 65 6e 76 69 T")....(get-envi
7290: 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 ronment-variable
72a0: 20 22 53 45 52 56 45 52 5f 4e 41 4d 45 22 29 29 "SERVER_NAME"))
72b0: 29 0a 09 20 28 73 63 72 69 70 74 20 28 6c 65 74 ).. (script (let
72c0: 20 28 28 73 63 72 69 70 74 2d 6e 61 6d 65 20 28 ((script-name (
72d0: 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 28 67 65 string-split (ge
72e0: 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 t-environment-va
72f0: 72 69 61 62 6c 65 20 22 53 43 52 49 50 54 5f 4e riable "SCRIPT_N
7300: 41 4d 45 22 29 20 22 2f 22 29 29 29 0a 09 09 20 AME") "/")))...
7310: 20 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 74 68 (if (> (length
7320: 20 73 63 72 69 70 74 2d 6e 61 6d 65 29 20 31 29 script-name) 1)
7330: 0a 09 09 20 20 20 20 20 20 20 28 73 74 72 69 6e ... (strin
7340: 67 2d 61 70 70 65 6e 64 20 28 63 61 72 20 73 63 g-append (car sc
7350: 72 69 70 74 2d 6e 61 6d 65 29 20 22 2f 22 20 28 ript-name) "/" (
7360: 63 61 64 72 20 73 63 72 69 70 74 2d 6e 61 6d 65 cadr script-name
7370: 29 29 0a 09 09 20 20 20 20 20 20 20 28 67 65 74 ))... (get
7380: 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 -environment-var
7390: 69 61 62 6c 65 20 22 53 43 52 49 50 54 5f 4e 41 iable "SCRIPT_NA
73a0: 4d 45 22 29 29 29 29 20 3b 3b 20 62 75 69 6c 64 ME")))) ;; build
73b0: 20 73 63 72 69 70 74 20 6e 61 6d 65 20 66 72 6f script name fro
73c0: 6d 20 66 69 72 73 74 20 74 77 6f 20 65 6c 65 6d m first two elem
73d0: 65 6e 74 73 2e 20 54 68 69 73 20 69 73 20 61 20 ents. This is a
73e0: 68 61 6e 67 6f 76 65 72 20 66 72 6f 6d 20 62 65 hangover from be
73f0: 66 6f 72 65 20 49 20 75 73 65 64 20 3f 20 69 6e fore I used ? in
7400: 20 74 68 65 20 55 52 4c 2e 0a 09 20 28 73 65 73 the URL... (ses
7410: 73 69 6f 6e 2d 6b 65 79 20 28 73 64 61 74 2d 67 sion-key (sdat-g
7420: 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 et-session-key s
7430: 65 6c 66 29 29 0a 09 20 28 70 61 72 61 6d 73 74 elf)).. (paramst
7440: 72 20 28 73 65 73 73 69 6f 6e 3a 70 61 72 61 6d r (session:param
7450: 2d 3e 73 74 72 69 6e 67 20 70 61 72 61 6d 73 29 ->string params)
7460: 29 29 0a 20 20 20 20 3b 3b 20 28 73 65 73 73 69 )). ;; (sessi
7470: 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 73 65 72 on:log self "ser
7480: 76 65 72 3d 22 20 73 65 72 76 65 72 20 22 20 73 ver=" server " s
7490: 63 72 69 70 74 3d 22 20 73 63 72 69 70 74 20 22 cript=" script "
74a0: 20 70 61 67 65 3d 22 20 70 61 67 65 29 0a 20 20 page=" page).
74b0: 20 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 (string-append
74c0: 20 22 68 74 74 70 3a 2f 2f 22 20 73 65 72 76 65 "http://" serve
74d0: 72 20 22 2f 22 20 73 63 72 69 70 74 20 22 2f 22 r "/" script "/"
74e0: 20 70 61 67 65 20 22 3f 22 20 70 61 72 61 6d 73 page "?" params
74f0: 74 72 29 29 29 20 3b 3b 20 22 2f 73 6e 3d 22 20 tr))) ;; "/sn="
7500: 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 29 0a 0a session-key)))..
7510: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
7520: 3a 63 67 69 2d 6f 75 74 20 73 65 6c 66 29 0a 20 :cgi-out self).
7530: 20 28 6c 65 74 2a 20 28 28 63 6f 6e 74 65 6e 74 (let* ((content
7540: 20 20 28 6c 69 73 74 20 28 73 64 61 74 2d 67 65 (list (sdat-ge
7550: 74 2d 63 6f 6e 74 65 6e 74 2d 74 79 70 65 20 73 t-content-type s
7560: 65 6c 66 29 29 29 20 3b 3b 20 27 28 22 43 6f 6e elf))) ;; '("Con
7570: 74 65 6e 74 2d 74 79 70 65 3a 20 74 65 78 74 2f tent-type: text/
7580: 68 74 6d 6c 3b 20 63 68 61 72 73 65 74 3d 69 73 html; charset=is
7590: 6f 2d 38 38 35 39 2d 31 5c 6e 5c 6e 22 29 29 0a o-8859-1\n\n")).
75a0: 09 20 28 68 65 61 64 65 72 20 20 20 28 6c 65 74 . (header (let
75b0: 20 28 28 63 6f 6f 6b 69 65 20 28 73 64 61 74 2d ((cookie (sdat-
75c0: 67 65 74 2d 73 65 73 73 69 6f 6e 2d 63 6f 6f 6b get-session-cook
75d0: 69 65 20 73 65 6c 66 29 29 29 0a 09 09 20 20 20 ie self)))...
75e0: 20 20 28 69 66 20 63 6f 6f 6b 69 65 0a 09 09 09 (if cookie....
75f0: 20 28 63 6f 6e 73 20 28 73 74 72 69 6e 67 2d 61 (cons (string-a
7600: 70 70 65 6e 64 20 22 53 65 74 2d 43 6f 6f 6b 69 ppend "Set-Cooki
7610: 65 3a 20 22 20 28 63 61 72 20 63 6f 6f 6b 69 65 e: " (car cookie
7620: 29 29 0a 09 09 09 20 20 20 20 20 20 20 63 6f 6e )).... con
7630: 74 65 6e 74 29 0a 09 09 09 20 63 6f 6e 74 65 6e tent).... conten
7640: 74 29 29 29 0a 09 20 28 70 61 67 65 64 61 74 20 t))).. (pagedat
7650: 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 64 (sdat-get-paged
7660: 61 74 20 73 65 6c 66 29 29 29 0a 20 20 20 20 28 at self))). (
7670: 73 3a 63 67 69 2d 6f 75 74 20 0a 20 20 20 20 20 s:cgi-out .
7680: 28 63 6f 6e 73 20 68 65 61 64 65 72 20 70 61 67 (cons header pag
7690: 65 64 61 74 29 29 29 29 0a 0a 28 64 65 66 69 6e edat))))..(defin
76a0: 65 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 e (session:log s
76b0: 65 6c 66 20 2e 20 6d 73 67 29 0a 20 20 28 77 69 elf . msg). (wi
76c0: 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 70 6f 72 th-output-to-por
76d0: 74 20 28 73 64 61 74 2d 67 65 74 2d 6c 6f 67 2d t (sdat-get-log-
76e0: 70 6f 72 74 20 73 65 6c 66 29 20 3b 3b 20 28 73 port self) ;; (s
76f0: 64 61 74 2d 67 65 74 2d 6c 6f 67 70 74 20 73 65 dat-get-logpt se
7700: 6c 66 29 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 lf). (lambda
7710: 28 29 20 0a 20 20 20 20 20 20 28 61 70 70 6c 79 () . (apply
7720: 20 70 72 69 6e 74 20 6d 73 67 29 29 29 29 0a 0a print msg))))..
7730: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
7740: 3a 67 65 74 2d 70 61 72 61 6d 20 73 65 6c 66 20 :get-param self
7750: 6b 65 79 29 0a 20 20 3b 3b 20 28 73 65 73 73 69 key). ;; (sessi
7760: 6f 6e 3a 6c 6f 67 20 73 3a 73 65 73 73 69 6f 6e on:log s:session
7770: 20 22 70 61 72 61 6d 73 3d 22 20 28 73 6c 6f 74 "params=" (slot
7780: 2d 72 65 66 20 73 3a 73 65 73 73 69 6f 6e 20 27 -ref s:session '
7790: 70 61 72 61 6d 73 29 29 0a 20 20 28 6c 65 74 20 params)). (let
77a0: 28 28 70 61 72 61 6d 73 20 28 73 64 61 74 2d 67 ((params (sdat-g
77b0: 65 74 2d 70 61 72 61 6d 73 20 73 65 6c 66 29 29 et-params self))
77c0: 29 0a 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 67 ). (session:g
77d0: 65 74 2d 70 61 72 61 6d 2d 66 72 6f 6d 20 70 61 et-param-from pa
77e0: 72 61 6d 73 20 6b 65 79 29 29 29 0a 0a 3b 3b 20 rams key)))..;;
77f0: 54 68 69 73 20 6f 6e 65 20 77 69 6c 6c 20 67 65 This one will ge
7800: 74 20 74 68 65 20 66 69 72 73 74 20 76 61 6c 75 t the first valu
7810: 65 20 66 6f 75 6e 64 20 72 65 67 61 72 64 6c 65 e found regardle
7820: 73 73 20 6f 66 20 66 6f 72 6d 0a 28 64 65 66 69 ss of form.(defi
7830: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d ne (session:get-
7840: 69 6e 70 75 74 20 73 65 6c 66 20 6b 65 79 29 0a input self key).
7850: 20 20 28 6c 65 74 2a 20 28 28 66 6f 72 6d 64 61 (let* ((formda
7860: 74 20 28 73 64 61 74 2d 67 65 74 2d 66 6f 72 6d t (sdat-get-form
7870: 64 61 74 20 73 65 6c 66 29 29 29 0a 20 20 20 20 dat self))).
7880: 28 69 66 20 28 6e 6f 74 20 66 6f 72 6d 64 61 74 (if (not formdat
7890: 29 20 23 66 0a 09 28 69 66 20 28 6f 72 20 28 73 ) #f..(if (or (s
78a0: 74 72 69 6e 67 3f 20 6b 65 79 29 28 6e 75 6d 62 tring? key)(numb
78b0: 65 72 3f 20 6b 65 79 29 28 73 79 6d 62 6f 6c 3f er? key)(symbol?
78c0: 20 6b 65 79 29 29 0a 09 20 20 20 20 28 69 66 20 key)).. (if
78d0: 28 61 6e 64 20 28 76 65 63 74 6f 72 3f 20 66 6f (and (vector? fo
78e0: 72 6d 64 61 74 29 28 65 71 3f 20 28 76 65 63 74 rmdat)(eq? (vect
78f0: 6f 72 2d 6c 65 6e 67 74 68 20 66 6f 72 6d 64 61 or-length formda
7900: 74 29 20 31 29 28 68 61 73 68 2d 74 61 62 6c 65 t) 1)(hash-table
7910: 3f 20 28 76 65 63 74 6f 72 2d 72 65 66 20 66 6f ? (vector-ref fo
7920: 72 6d 64 61 74 20 30 29 29 29 0a 09 09 28 66 6f rmdat 0)))...(fo
7930: 72 6d 64 61 74 3a 67 65 74 20 66 6f 72 6d 64 61 rmdat:get formda
7940: 74 20 6b 65 79 29 0a 09 09 28 62 65 67 69 6e 0a t key)...(begin.
7950: 09 09 20 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 .. (session:log
7960: 20 73 65 6c 66 20 22 45 52 52 4f 52 3a 20 66 6f self "ERROR: fo
7970: 72 6d 64 61 74 3a 20 22 20 66 6f 72 6d 64 61 74 rmdat: " formdat
7980: 20 22 20 69 73 20 6e 6f 74 20 6f 66 20 63 6c 61 " is not of cla
7990: 73 73 20 3c 66 6f 72 6d 64 61 74 3e 22 29 0a 09 ss <formdat>")..
79a0: 09 20 20 23 66 29 29 0a 09 20 20 20 20 28 73 65 . #f)).. (se
79b0: 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 ssion:log self "
79c0: 45 52 52 4f 52 3a 20 62 61 64 20 6b 65 79 20 22 ERROR: bad key "
79d0: 20 6b 65 79 29 29 29 29 29 0a 0a 28 64 65 66 69 key)))))..(defi
79e0: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 72 75 6e 2d ne (session:run-
79f0: 61 63 74 69 6f 6e 73 20 73 65 6c 66 29 0a 20 20 actions self).
7a00: 28 6c 65 74 2a 20 28 28 61 63 74 69 6f 6e 20 20 (let* ((action
7a10: 20 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 (session:get-p
7a20: 61 72 61 6d 20 73 65 6c 66 20 27 61 63 74 69 6f aram self 'actio
7a30: 6e 29 29 0a 09 20 28 70 61 67 65 20 20 20 20 20 n)).. (page
7a40: 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 20 (sdat-get-page
7a50: 73 65 6c 66 29 29 29 0a 20 20 20 20 3b 3b 20 28 self))). ;; (
7a60: 70 72 69 6e 74 20 22 61 63 74 69 6f 6e 3d 22 20 print "action="
7a70: 61 63 74 69 6f 6e 20 22 20 70 61 67 65 3d 22 20 action " page="
7a80: 70 61 67 65 29 0a 20 20 20 20 28 69 66 20 61 63 page). (if ac
7a90: 74 69 6f 6e 0a 09 28 6c 65 74 20 28 28 61 63 74 tion..(let ((act
7aa0: 69 6f 6e 2d 6c 73 74 20 20 28 73 74 72 69 6e 67 ion-lst (string
7ab0: 2d 73 70 6c 69 74 20 61 63 74 69 6f 6e 20 22 2e -split action ".
7ac0: 22 29 29 29 0a 09 20 20 3b 3b 20 28 70 72 69 6e "))).. ;; (prin
7ad0: 74 20 22 61 63 74 69 6f 6e 2d 6c 73 74 3d 22 20 t "action-lst="
7ae0: 61 63 74 69 6f 6e 2d 6c 73 74 29 0a 09 20 20 28 action-lst).. (
7af0: 69 66 20 28 6e 6f 74 20 28 3d 20 28 6c 65 6e 67 if (not (= (leng
7b00: 74 68 20 61 63 74 69 6f 6e 2d 6c 73 74 29 20 32 th action-lst) 2
7b10: 29 29 20 0a 09 20 20 20 20 20 20 28 65 72 72 3a )) .. (err:
7b20: 6c 6f 67 20 22 41 63 74 69 6f 6e 20 73 68 6f 75 log "Action shou
7b30: 6c 64 20 62 65 20 6f 66 20 66 6f 72 6d 3a 20 6d ld be of form: m
7b40: 6f 64 75 6c 65 2e 61 63 74 69 6f 6e 22 29 0a 09 odule.action")..
7b50: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 61 (let* ((ta
7b60: 72 67 2d 70 61 67 65 20 20 20 28 63 61 72 20 61 rg-page (car a
7b70: 63 74 69 6f 6e 2d 6c 73 74 29 29 0a 09 09 20 20 ction-lst))...
7b80: 20 20 20 28 70 72 6f 63 2d 6e 61 6d 65 20 20 20 (proc-name
7b90: 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 74 (string-append t
7ba0: 61 72 67 2d 70 61 67 65 20 22 2d 61 63 74 69 6f arg-page "-actio
7bb0: 6e 22 29 29 0a 09 09 20 20 20 20 20 28 74 61 72 n"))... (tar
7bc0: 67 2d 61 63 74 69 6f 6e 20 28 63 61 64 72 20 61 g-action (cadr a
7bd0: 63 74 69 6f 6e 2d 6c 73 74 29 29 29 0a 09 09 3b ction-lst)))...;
7be0: 3b 20 28 65 72 72 3a 6c 6f 67 20 22 74 61 72 67 ; (err:log "targ
7bf0: 2d 70 61 67 65 3d 22 20 74 61 72 67 2d 70 61 67 -page=" targ-pag
7c00: 65 20 22 20 70 72 6f 63 2d 6e 61 6d 65 3d 22 20 e " proc-name="
7c10: 70 72 6f 63 2d 6e 61 6d 65 20 22 20 74 61 72 67 proc-name " targ
7c20: 2d 61 63 74 69 6f 6e 3d 22 20 74 61 72 67 2d 61 -action=" targ-a
7c30: 63 74 69 6f 6e 29 0a 0a 09 09 3b 3b 20 63 61 6c ction)....;; cal
7c40: 6c 20 68 65 72 65 20 6f 6e 6c 79 20 69 66 20 6e l here only if n
7c50: 65 76 65 72 20 63 61 6c 6c 65 64 20 62 65 66 6f ever called befo
7c60: 72 65 0a 09 09 28 69 66 20 28 73 65 73 73 69 6f re...(if (sessio
7c70: 6e 3a 6e 65 76 65 72 2d 63 61 6c 6c 65 64 2d 70 n:never-called-p
7c80: 61 67 65 3f 20 73 65 6c 66 20 74 61 72 67 2d 70 age? self targ-p
7c90: 61 67 65 29 0a 09 09 20 20 20 20 28 73 65 73 73 age)... (sess
7ca0: 69 6f 6e 3a 63 61 6c 6c 2d 70 61 72 74 73 20 73 ion:call-parts s
7cb0: 65 6c 66 20 74 61 72 67 2d 70 61 67 65 20 27 63 elf targ-page 'c
7cc0: 6f 6e 74 72 6f 6c 29 29 0a 09 09 3b 3b 20 20 20 ontrol))...;;
7cd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7ce0: 20 70 72 6f 63 20 20 20 20 20 20 20 20 20 20 20 proc
7cf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 61 63 ac
7d00: 74 69 6f 6e 20 20 20 20 0a 0a 09 09 28 69 66 20 tion ....(if
7d10: 23 74 20 3b 3b 20 73 65 74 20 74 6f 20 23 74 20 #t ;; set to #t
7d20: 74 6f 20 73 65 65 20 62 65 74 74 65 72 20 65 72 to see better er
7d30: 72 6f 72 20 6d 65 73 73 61 67 65 73 20 64 75 72 ror messages dur
7d40: 69 6e 67 20 64 65 62 75 67 67 69 6e 20 3a 2d 29 ing debuggin :-)
7d50: 0a 09 09 20 20 20 20 28 28 65 76 61 6c 20 28 73 ... ((eval (s
7d60: 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 70 72 tring->symbol pr
7d70: 6f 63 2d 6e 61 6d 65 29 29 20 74 61 72 67 2d 61 oc-name)) targ-a
7d80: 63 74 69 6f 6e 29 20 3b 3b 20 75 6e 73 61 66 65 ction) ;; unsafe
7d90: 20 65 78 65 63 75 74 69 6f 6e 0a 09 09 20 20 20 execution...
7da0: 20 28 63 6f 6e 64 69 74 69 6f 6e 2d 63 61 73 65 (condition-case
7db0: 20 28 28 65 76 61 6c 20 28 73 74 72 69 6e 67 2d ((eval (string-
7dc0: 3e 73 79 6d 62 6f 6c 20 70 72 6f 63 2d 6e 61 6d >symbol proc-nam
7dd0: 65 29 29 20 74 61 72 67 2d 61 63 74 69 6f 6e 29 e)) targ-action)
7de0: 0a 09 09 09 09 20 20 20 20 28 28 65 78 6e 20 66 ..... ((exn f
7df0: 69 6c 65 29 20 28 73 3a 6c 6f 67 20 22 66 69 6c ile) (s:log "fil
7e00: 65 20 65 72 72 6f 72 22 29 29 0a 09 09 09 09 20 e error")).....
7e10: 20 20 20 28 28 65 78 6e 20 69 2f 6f 29 20 20 28 ((exn i/o) (
7e20: 73 3a 6c 6f 67 20 22 69 2f 6f 20 65 72 72 6f 72 s:log "i/o error
7e30: 22 29 29 0a 09 09 09 09 20 20 20 20 28 28 65 78 "))..... ((ex
7e40: 6e 20 29 20 20 20 20 20 28 73 3a 6c 6f 67 20 22 n ) (s:log "
7e50: 41 63 74 69 6f 6e 20 6e 6f 74 20 69 6d 70 6c 65 Action not imple
7e60: 6d 65 6e 74 65 64 3a 20 22 20 70 72 6f 63 2d 6e mented: " proc-n
7e70: 61 6d 65 20 22 20 61 63 74 69 6f 6e 3a 20 22 20 ame " action: "
7e80: 74 61 72 67 2d 61 63 74 69 6f 6e 29 29 0a 09 09 targ-action))...
7e90: 09 09 20 20 20 20 28 76 61 72 20 28 29 20 20 20 .. (var ()
7ea0: 20 20 28 73 3a 6c 6f 67 20 22 55 6e 6b 6e 6f 77 (s:log "Unknow
7eb0: 6e 20 45 72 72 6f 72 22 29 29 29 29 29 29 29 29 n Error"))))))))
7ec0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 ))..(define (ses
7ed0: 73 69 6f 6e 3a 6e 65 76 65 72 2d 63 61 6c 6c 65 sion:never-calle
7ee0: 64 2d 70 61 67 65 3f 20 73 65 6c 66 20 70 61 67 d-page? self pag
7ef0: 65 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a 6c 6f e). (session:lo
7f00: 67 20 73 65 6c 66 20 22 43 68 65 63 6b 69 6e 67 g self "Checking
7f10: 20 66 6f 72 20 70 61 67 65 3a 20 22 20 70 61 67 for page: " pag
7f20: 65 29 0a 20 20 28 6e 6f 74 20 28 6d 65 6d 62 65 e). (not (membe
7f30: 72 20 70 61 67 65 20 28 73 64 61 74 2d 67 65 74 r page (sdat-get
7f40: 2d 73 65 65 6e 2d 70 61 67 65 73 20 73 65 6c 66 -seen-pages self
7f50: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 ))))..(define (s
7f60: 65 73 73 69 6f 6e 3a 73 65 74 2d 63 61 6c 6c 65 ession:set-calle
7f70: 64 21 20 73 65 6c 66 20 70 61 67 65 29 0a 20 20 d! self page).
7f80: 28 73 64 61 74 2d 73 65 74 2d 73 65 65 6e 2d 70 (sdat-set-seen-p
7f90: 61 67 65 73 21 20 73 65 6c 66 20 28 63 6f 6e 73 ages! self (cons
7fa0: 20 70 61 67 65 20 28 73 64 61 74 2d 67 65 74 2d page (sdat-get-
7fb0: 73 65 65 6e 2d 70 61 67 65 73 20 73 65 6c 66 29 seen-pages self)
7fc0: 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d )))..;;=========
7fd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7fe0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7ff0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8000: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
8010: 20 41 6c 74 65 72 6e 61 74 69 76 65 20 64 61 74 Alternative dat
8020: 61 20 74 79 70 65 20 64 65 6c 69 76 65 72 79 0a a type delivery.
8030: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
8040: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8050: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8060: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8070: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e ========..(defin
8080: 65 20 28 73 65 73 73 69 6f 6e 3a 61 6c 74 2d 6f e (session:alt-o
8090: 75 74 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 20 ut self). (let
80a0: 28 28 64 61 74 20 28 73 64 61 74 2d 67 65 74 2d ((dat (sdat-get-
80b0: 61 6c 74 2d 70 61 67 65 2d 64 61 74 20 73 65 6c alt-page-dat sel
80c0: 66 29 29 29 0a 20 20 20 20 3b 3b 20 28 73 3a 6c f))). ;; (s:l
80d0: 6f 67 20 22 64 61 74 20 69 73 3a 20 22 20 64 61 og "dat is: " da
80e0: 74 29 0a 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 t). ;; (print
80f0: 20 22 48 54 54 50 2f 31 2e 31 20 32 30 30 20 4f "HTTP/1.1 200 O
8100: 4b 22 29 0a 20 20 20 20 28 70 72 69 6e 74 20 22 K"). (print "
8110: 44 61 74 65 3a 20 22 20 28 74 69 6d 65 2d 3e 73 Date: " (time->s
8120: 74 72 69 6e 67 20 28 73 65 63 6f 6e 64 73 2d 3e tring (seconds->
8130: 75 74 63 2d 74 69 6d 65 20 28 63 75 72 72 65 6e utc-time (curren
8140: 74 2d 73 65 63 6f 6e 64 73 29 29 29 29 0a 20 20 t-seconds)))).
8150: 20 20 28 70 72 69 6e 74 20 22 43 6f 6e 74 65 6e (print "Conten
8160: 74 2d 54 79 70 65 3a 20 22 20 28 73 64 61 74 2d t-Type: " (sdat-
8170: 67 65 74 2d 63 6f 6e 74 65 6e 74 2d 74 79 70 65 get-content-type
8180: 20 73 65 6c 66 29 29 0a 20 20 20 20 28 70 72 69 self)). (pri
8190: 6e 74 20 22 41 63 63 65 70 74 2d 52 61 6e 67 65 nt "Accept-Range
81a0: 73 3a 20 62 79 74 65 73 22 29 0a 20 20 20 20 28 s: bytes"). (
81b0: 70 72 69 6e 74 20 22 43 6f 6e 74 65 6e 74 2d 4c print "Content-L
81c0: 65 6e 67 74 68 3a 20 22 20 28 69 66 20 28 62 6c ength: " (if (bl
81d0: 6f 62 3f 20 64 61 74 29 0a 09 09 09 09 20 20 28 ob? dat)..... (
81e0: 62 6c 6f 62 2d 73 69 7a 65 20 64 61 74 29 0a 09 blob-size dat)..
81f0: 09 09 09 20 20 30 29 29 0a 20 20 20 20 28 70 72 ... 0)). (pr
8200: 69 6e 74 20 22 4b 65 65 70 2d 41 6c 69 76 65 3a int "Keep-Alive:
8210: 20 74 69 6d 65 6f 75 74 3d 31 35 2c 20 6d 61 78 timeout=15, max
8220: 3d 31 30 30 22 29 0a 20 20 20 20 28 70 72 69 6e =100"). (prin
8230: 74 20 22 43 6f 6e 6e 65 63 74 69 6f 6e 3a 20 4b t "Connection: K
8240: 65 65 70 2d 41 6c 69 76 65 22 29 0a 20 20 20 20 eep-Alive").
8250: 28 70 72 69 6e 74 20 22 22 29 0a 20 20 20 20 28 (print ""). (
8260: 77 72 69 74 65 2d 73 74 72 69 6e 67 20 28 62 6c write-string (bl
8270: 6f 62 2d 3e 73 74 72 69 6e 67 20 64 61 74 29 20 ob->string dat)
8280: 23 66 20 28 63 75 72 72 65 6e 74 2d 6f 75 74 70 #f (current-outp
8290: 75 74 2d 70 6f 72 74 29 29 29 29 0a ut-port)))).