Artifact
74a61ca45de5f68fab9f0ca4e98b1d9dbee90bcc:
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 29 0a 20 e configdat))).
2300: 20 20 20 28 69 66 20 73 72 6f 6f 74 20 20 20 20 (if sroot
2310: 28 73 64 61 74 2d 73 65 74 2d 73 72 6f 6f 74 21 (sdat-set-sroot!
2320: 20 20 20 20 73 65 6c 66 20 73 72 6f 6f 74 29 29 self sroot))
2330: 0a 20 20 20 20 28 69 66 20 6c 6f 67 66 69 6c 65 . (if logfile
2340: 20 20 28 73 64 61 74 2d 73 65 74 2d 6c 6f 67 66 (sdat-set-logf
2350: 69 6c 65 21 20 20 73 65 6c 66 20 6c 6f 67 66 69 ile! self logfi
2360: 6c 65 29 29 0a 20 20 20 20 28 69 66 20 64 62 74 le)). (if dbt
2370: 79 70 65 20 20 20 28 73 64 61 74 2d 73 65 74 2d ype (sdat-set-
2380: 64 62 74 79 70 65 21 20 20 20 73 65 6c 66 20 64 dbtype! self d
2390: 62 74 79 70 65 29 29 0a 20 20 20 20 28 69 66 20 btype)). (if
23a0: 64 62 69 6e 69 74 20 20 20 28 73 64 61 74 2d 73 dbinit (sdat-s
23b0: 65 74 2d 64 62 69 6e 69 74 21 20 20 20 73 65 6c et-dbinit! sel
23c0: 66 20 64 62 69 6e 69 74 29 29 0a 20 20 20 20 28 f dbinit)). (
23d0: 69 66 20 64 6f 6d 61 69 6e 20 20 20 28 73 64 61 if domain (sda
23e0: 74 2d 73 65 74 2d 64 6f 6d 61 69 6e 21 20 20 20 t-set-domain!
23f0: 73 65 6c 66 20 64 6f 6d 61 69 6e 29 29 0a 20 20 self domain)).
2400: 20 20 28 69 66 20 74 77 69 6b 69 64 69 72 20 28 (if twikidir (
2410: 73 64 61 74 2d 73 65 74 2d 74 77 69 6b 69 64 69 sdat-set-twikidi
2420: 72 21 20 73 65 6c 66 20 74 77 69 6b 69 64 69 72 r! self twikidir
2430: 29 29 0a 20 20 20 20 28 73 64 61 74 2d 73 65 74 )). (sdat-set
2440: 2d 70 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 21 -page-dir-style!
2450: 20 73 65 6c 66 20 70 61 67 65 2d 64 69 72 29 0a self page-dir).
2460: 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 63 ;; (print "c
2470: 6f 6e 66 69 67 64 61 74 3a 20 22 29 28 70 70 20 onfigdat: ")(pp
2480: 63 6f 6e 66 69 67 64 61 74 29 0a 20 20 20 20 3b configdat). ;
2490: 3b 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 ;(session:log se
24a0: 6c 66 20 22 73 72 6f 6f 74 3a 20 22 20 73 72 6f lf "sroot: " sro
24b0: 6f 74 20 22 20 6c 6f 67 66 69 6c 65 3a 20 22 20 ot " logfile: "
24c0: 6c 6f 67 66 69 6c 65 20 22 20 64 62 74 79 70 65 logfile " dbtype
24d0: 3a 20 22 20 64 62 74 79 70 65 20 0a 20 20 20 20 : " dbtype .
24e0: 3b 3b 09 09 20 22 20 64 62 69 6e 69 74 3a 20 22 ;;.. " dbinit: "
24f0: 20 64 62 69 6e 69 74 20 22 20 64 6f 6d 61 69 6e dbinit " domain
2500: 3a 20 22 20 64 6f 6d 61 69 6e 20 22 20 70 61 67 : " domain " pag
2510: 65 2d 64 69 72 2d 73 74 79 6c 65 3a 20 22 20 70 e-dir-style: " p
2520: 61 67 65 2d 64 69 72 29 0a 20 20 20 20 29 0a 20 age-dir). ).
2530: 20 29 0a 3b 3b 20 20 20 28 6c 65 74 20 28 28 64 ).;; (let ((d
2540: 62 74 79 70 65 20 28 73 64 61 74 2d 67 65 74 2d btype (sdat-get-
2550: 64 62 74 79 70 65 20 73 65 6c 66 29 29 29 0a 3b dbtype self))).;
2560: 3b 20 20 20 20 20 28 70 72 69 6e 74 20 22 64 62 ; (print "db
2570: 74 79 70 65 3a 20 22 20 64 62 74 79 70 65 29 0a type: " dbtype).
2580: 3b 3b 20 20 20 20 20 28 73 64 61 74 2d 73 65 74 ;; (sdat-set
2590: 2d 64 62 74 79 70 65 21 20 73 65 6c 66 20 28 65 -dbtype! self (e
25a0: 76 61 6c 20 64 62 74 79 70 65 29 29 29 29 0a 0a val dbtype))))..
25b0: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
25c0: 3a 73 65 74 75 70 20 73 65 6c 66 29 0a 20 20 28 :setup self). (
25d0: 6c 65 74 20 28 28 64 62 74 79 70 65 20 28 73 64 let ((dbtype (sd
25e0: 61 74 2d 67 65 74 2d 64 62 74 79 70 65 20 73 65 at-get-dbtype se
25f0: 6c 66 29 29 0a 09 28 64 62 69 6e 69 74 20 28 65 lf))..(dbinit (e
2600: 76 61 6c 20 28 73 64 61 74 2d 67 65 74 2d 64 62 val (sdat-get-db
2610: 69 6e 69 74 20 73 65 6c 66 29 29 29 0a 09 28 64 init self)))..(d
2620: 62 65 78 69 73 74 73 20 23 66 29 29 0a 20 20 20 bexists #f)).
2630: 20 28 6c 65 74 20 28 28 64 62 66 6e 61 6d 65 20 (let ((dbfname
2640: 28 61 6c 69 73 74 2d 72 65 66 20 27 64 62 6e 61 (alist-ref 'dbna
2650: 6d 65 20 64 62 69 6e 69 74 29 29 29 0a 20 20 20 me dbinit))).
2660: 20 20 20 28 69 66 20 28 65 71 3f 20 64 62 74 79 (if (eq? dbty
2670: 70 65 20 27 73 71 6c 69 74 65 33 29 0a 09 20 20 pe 'sqlite3)..
2680: 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 (if (file-exists
2690: 3f 20 64 62 66 6e 61 6d 65 29 0a 09 20 20 20 20 ? dbfname)..
26a0: 20 20 28 62 65 67 69 6e 0a 09 09 3b 3b 20 28 73 (begin...;; (s
26b0: 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 ession:log self
26c0: 22 73 65 74 74 69 6e 67 20 64 62 65 78 69 73 74 "setting dbexist
26d0: 73 20 74 6f 20 23 74 22 29 0a 09 09 28 73 65 74 s to #t")...(set
26e0: 21 20 64 62 65 78 69 73 74 73 20 23 74 29 29 29 ! dbexists #t)))
26f0: 29 0a 20 20 20 20 20 20 3b 3b 20 28 73 65 73 73 ). ;; (sess
2700: 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 64 62 ion:log self "db
2710: 74 79 70 65 3a 20 22 20 64 62 74 79 70 65 20 22 type: " dbtype "
2720: 20 64 62 66 6e 61 6d 65 3a 20 22 20 64 62 66 6e dbfname: " dbfn
2730: 61 6d 65 20 22 20 64 62 65 78 69 73 74 73 3a 20 ame " dbexists:
2740: 22 20 64 62 65 78 69 73 74 73 29 29 0a 20 20 20 " dbexists)).
2750: 20 20 20 29 0a 20 20 20 20 28 73 64 61 74 2d 73 ). (sdat-s
2760: 65 74 2d 63 6f 6e 6e 21 20 73 65 6c 66 20 28 64 et-conn! self (d
2770: 62 69 3a 6f 70 65 6e 20 64 62 74 79 70 65 20 64 bi:open dbtype d
2780: 62 69 6e 69 74 29 29 0a 20 20 20 20 28 69 66 20 binit)). (if
2790: 28 61 6e 64 20 28 6e 6f 74 20 64 62 65 78 69 73 (and (not dbexis
27a0: 74 73 29 28 65 71 3f 20 64 62 74 79 70 65 20 27 ts)(eq? dbtype '
27b0: 73 71 6c 69 74 65 33 29 29 0a 20 09 28 62 65 67 sqlite3)). .(beg
27c0: 69 6e 0a 09 20 20 28 70 72 69 6e 74 20 22 57 41 in.. (print "WA
27d0: 52 4e 49 4e 47 3a 20 53 65 74 74 69 6e 67 20 75 RNING: Setting u
27e0: 70 20 73 65 73 73 69 6f 6e 20 64 62 20 77 69 74 p session db wit
27f0: 68 20 73 71 6c 69 74 65 33 22 29 0a 09 20 20 28 h sqlite3").. (
2800: 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 2d 64 62 session:setup-db
2810: 20 73 65 6c 66 29 29 29 0a 20 20 20 20 28 73 65 self))). (se
2820: 73 73 69 6f 6e 3a 70 72 6f 63 65 73 73 2d 75 72 ssion:process-ur
2830: 6c 2d 70 61 74 68 20 73 65 6c 66 29 0a 20 20 20 l-path self).
2840: 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 2d (session:setup-
2850: 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 session-key self
2860: 29 0a 20 20 20 20 3b 3b 20 63 61 70 74 75 72 65 ). ;; capture
2870: 20 73 74 64 69 6e 20 69 66 20 74 68 69 73 20 69 stdin if this i
2880: 73 20 61 20 50 4f 53 54 0a 20 20 20 20 28 73 64 s a POST. (sd
2890: 61 74 2d 73 65 74 2d 72 65 71 75 65 73 74 2d 6d at-set-request-m
28a0: 65 74 68 6f 64 21 20 73 65 6c 66 20 28 67 65 74 ethod! self (get
28b0: 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 -environment-var
28c0: 69 61 62 6c 65 20 22 52 45 51 55 45 53 54 5f 4d iable "REQUEST_M
28d0: 45 54 48 4f 44 22 29 29 0a 20 20 20 20 28 73 64 ETHOD")). (sd
28e0: 61 74 2d 73 65 74 2d 66 6f 72 6d 64 61 74 21 20 at-set-formdat!
28f0: 73 65 6c 66 20 28 66 6f 72 6d 64 61 74 3a 6c 6f self (formdat:lo
2900: 61 64 2d 61 6c 6c 29 29 29 29 0a 0a 3b 3b 20 73 ad-all))))..;; s
2910: 65 74 75 70 20 74 68 65 20 64 62 20 77 69 74 68 etup the db with
2920: 20 73 65 73 73 69 6f 6e 20 74 61 62 6c 65 73 2c session tables,
2930: 20 77 6f 72 6b 73 20 66 6f 72 20 73 71 6c 69 74 works for sqlit
2940: 65 20 6f 6e 6c 79 20 72 69 67 68 74 20 6e 6f 77 e only right now
2950: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
2960: 6e 3a 73 65 74 75 70 2d 64 62 20 73 65 6c 66 29 n:setup-db self)
2970: 0a 20 20 28 6c 65 74 20 28 28 63 6f 6e 6e 20 28 . (let ((conn (
2980: 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 sdat-get-conn se
2990: 6c 66 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 lf))). (for-e
29a0: 61 63 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 ach . (lambd
29b0: 61 20 28 73 74 6d 74 29 0a 20 20 20 20 20 20 20 a (stmt).
29c0: 28 64 62 69 3a 65 78 65 63 20 63 6f 6e 6e 20 73 (dbi:exec conn s
29d0: 74 6d 74 29 29 0a 20 20 20 20 20 28 6c 69 73 74 tmt)). (list
29e0: 20 22 43 52 45 41 54 45 20 54 41 42 4c 45 20 73 "CREATE TABLE s
29f0: 65 73 73 69 6f 6e 5f 76 61 72 73 20 28 69 64 20 ession_vars (id
2a00: 49 4e 54 45 47 45 52 20 50 52 49 4d 41 52 59 20 INTEGER PRIMARY
2a10: 4b 45 59 2c 73 65 73 73 69 6f 6e 5f 69 64 20 49 KEY,session_id I
2a20: 4e 54 45 47 45 52 2c 70 61 67 65 20 54 45 58 54 NTEGER,page TEXT
2a30: 2c 6b 65 79 20 54 45 58 54 2c 76 61 6c 75 65 20 ,key TEXT,value
2a40: 54 45 58 54 29 3b 22 0a 09 20 20 20 22 43 52 45 TEXT);".. "CRE
2a50: 41 54 45 20 54 41 42 4c 45 20 73 65 73 73 69 6f ATE TABLE sessio
2a60: 6e 73 20 28 69 64 20 49 4e 54 45 47 45 52 20 50 ns (id INTEGER P
2a70: 52 49 4d 41 52 59 20 4b 45 59 2c 73 65 73 73 69 RIMARY KEY,sessi
2a80: 6f 6e 5f 6b 65 79 20 54 45 58 54 2c 6c 61 73 74 on_key TEXT,last
2a90: 5f 75 73 65 64 20 54 49 4d 45 53 54 41 4d 50 29 _used TIMESTAMP)
2aa0: 3b 22 0a 20 20 20 20 20 20 20 20 20 20 20 22 43 ;". "C
2ab0: 52 45 41 54 45 20 54 41 42 4c 45 20 6d 65 74 61 REATE TABLE meta
2ac0: 64 61 74 61 20 28 69 64 20 49 4e 54 45 47 45 52 data (id INTEGER
2ad0: 20 50 52 49 4d 41 52 59 20 4b 45 59 2c 6b 65 79 PRIMARY KEY,key
2ae0: 20 54 45 58 54 2c 76 61 6c 75 65 20 54 45 58 54 TEXT,value TEXT
2af0: 29 3b 22 29 29 29 29 0a 3b 3b 20 20 3b 3b 20 69 );")))).;; ;; i
2b00: 66 20 77 65 20 68 61 76 65 20 61 20 73 65 73 73 f we have a sess
2b10: 69 6f 6e 5f 6b 65 79 20 6c 6f 6f 6b 20 75 70 20 ion_key look up
2b20: 74 68 65 20 73 65 73 73 69 6f 6e 2d 69 64 20 61 the session-id a
2b30: 6e 64 20 73 74 6f 72 65 20 69 74 0a 3b 3b 20 20 nd store it.;;
2b40: 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f (sdat-set-sessio
2b50: 6e 2d 69 64 21 20 73 65 6c 66 20 28 73 65 73 73 n-id! self (sess
2b60: 69 6f 6e 3a 67 65 74 2d 69 64 20 73 65 6c 66 29 ion:get-id self)
2b70: 29 29 0a 0a 3b 3b 20 6f 6e 6c 79 20 73 65 74 20 ))..;; only set
2b80: 73 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 20 77 session-cookie w
2b90: 68 65 6e 20 61 20 6e 65 77 20 73 65 73 73 69 6f hen a new sessio
2ba0: 6e 20 69 73 20 63 72 65 61 74 65 64 0a 28 64 65 n is created.(de
2bb0: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 65 fine (session:se
2bc0: 74 75 70 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 tup-session-key
2bd0: 73 65 6c 66 29 20 20 0a 20 20 28 6c 65 74 2a 20 self) . (let*
2be0: 28 28 73 6b 20 20 28 73 65 73 73 69 6f 6e 3a 65 ((sk (session:e
2bf0: 78 74 72 61 63 74 2d 73 65 73 73 69 6f 6e 2d 6b xtract-session-k
2c00: 65 79 20 73 65 6c 66 29 29 0a 20 20 20 20 20 20 ey self)).
2c10: 20 20 20 28 73 69 64 20 28 69 66 20 73 6b 20 28 (sid (if sk (
2c20: 73 65 73 73 69 6f 6e 3a 67 65 74 2d 69 64 20 73 session:get-id s
2c30: 65 6c 66 20 73 6b 29 20 23 66 29 29 29 0a 20 20 elf sk) #f))).
2c40: 20 20 28 69 66 20 28 6e 6f 74 20 73 69 64 29 20 (if (not sid)
2c50: 3b 3b 20 6e 65 65 64 20 61 20 6e 65 77 20 6b 65 ;; need a new ke
2c60: 79 0a 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 y. (let*
2c70: 28 28 6e 65 77 2d 6b 65 79 20 28 73 65 73 73 69 ((new-key (sessi
2c80: 6f 6e 3a 67 65 74 2d 6e 65 77 2d 6b 65 79 20 73 on:get-new-key s
2c90: 65 6c 66 29 29 0a 20 20 20 20 20 20 20 20 20 20 elf)).
2ca0: 20 20 20 20 20 28 6e 65 77 2d 73 69 64 20 28 73 (new-sid (s
2cb0: 65 73 73 69 6f 6e 3a 67 65 74 2d 69 64 20 73 65 ession:get-id se
2cc0: 6c 66 20 6e 65 77 2d 6b 65 79 29 29 29 0a 20 20 lf new-key))).
2cd0: 20 20 20 20 20 20 20 20 28 73 64 61 74 2d 73 65 (sdat-se
2ce0: 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 21 20 73 t-session-key! s
2cf0: 65 6c 66 20 6e 65 77 2d 6b 65 79 29 0a 20 20 20 elf new-key).
2d00: 20 20 20 20 20 20 20 28 73 64 61 74 2d 73 65 74 (sdat-set
2d10: 2d 73 65 73 73 69 6f 6e 2d 69 64 21 20 73 65 6c -session-id! sel
2d20: 66 20 6e 65 77 2d 73 69 64 29 0a 20 20 20 20 20 f new-sid).
2d30: 20 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d 73 (sdat-set-s
2d40: 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 21 20 73 ession-cookie! s
2d50: 65 6c 66 20 28 73 65 73 73 69 6f 6e 3a 6d 61 6b elf (session:mak
2d60: 65 2d 63 6f 6f 6b 69 65 20 73 65 6c 66 29 29 29 e-cookie self)))
2d70: 0a 20 20 20 20 20 20 20 20 28 73 64 61 74 2d 73 . (sdat-s
2d80: 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 21 20 73 et-session-id! s
2d90: 65 6c 66 20 73 69 64 29 29 29 29 0a 0a 28 64 65 elf sid))))..(de
2da0: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 6d 61 fine (session:ma
2db0: 6b 65 2d 63 6f 6f 6b 69 65 20 73 65 6c 66 29 0a ke-cookie self).
2dc0: 20 20 3b 3b 20 28 6c 69 73 74 20 28 63 6f 6e 63 ;; (list (conc
2dd0: 20 22 73 65 73 73 69 6f 6e 5f 6b 65 79 3d 22 20 "session_key="
2de0: 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f (sdat-get-sessio
2df0: 6e 2d 6b 65 79 20 73 65 6c 66 29 20 22 3b 20 50 n-key self) "; P
2e00: 61 74 68 3d 2f 3b 20 44 6f 6d 61 69 6e 3d 2e 22 ath=/; Domain=."
2e10: 20 28 73 64 61 74 2d 67 65 74 2d 64 6f 6d 61 69 (sdat-get-domai
2e20: 6e 20 73 65 6c 66 29 20 22 3b 20 4d 61 78 2d 41 n self) "; Max-A
2e30: 67 65 3d 22 20 28 2a 20 38 36 34 30 30 20 31 34 ge=" (* 86400 14
2e40: 29 20 22 3b 20 56 65 72 73 69 6f 6e 3d 31 22 29 ) "; Version=1")
2e50: 29 29 20 0a 20 20 28 6c 69 73 74 20 28 73 74 72 )) . (list (str
2e60: 69 6e 67 2d 73 75 62 73 74 69 74 75 74 65 20 0a ing-substitute .
2e70: 09 20 22 3b 22 20 22 3b 20 22 20 0a 09 20 28 63 . ";" "; " .. (c
2e80: 61 72 20 28 63 6f 6e 73 74 72 75 63 74 2d 63 6f ar (construct-co
2e90: 6f 6b 69 65 2d 73 74 72 69 6e 67 20 0a 09 20 20 okie-string ..
2ea0: 20 20 20 20 20 3b 3b 20 77 61 72 6e 69 6e 67 21 ;; warning!
2eb0: 20 6d 65 73 73 69 6e 67 20 75 70 20 74 68 69 73 messing up this
2ec0: 20 69 74 74 79 20 62 69 74 74 79 20 62 69 74 20 itty bitty bit
2ed0: 6f 66 20 63 6f 64 65 20 77 69 6c 6c 20 63 6f 73 of code will cos
2ee0: 74 20 6d 75 63 68 20 74 69 6d 65 21 0a 09 20 20 t much time!..
2ef0: 20 20 20 20 20 60 28 28 22 73 65 73 73 69 6f 6e `(("session
2f00: 5f 6b 65 79 22 20 2c 28 73 64 61 74 2d 67 65 74 _key" ,(sdat-get
2f10: 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c -session-key sel
2f20: 66 29 0a 09 09 20 20 65 78 70 69 72 65 73 3a 20 f)... expires:
2f30: 2c 28 2b 20 28 63 75 72 72 65 6e 74 2d 73 65 63 ,(+ (current-sec
2f40: 6f 6e 64 73 29 20 28 2a 20 31 34 20 38 36 34 30 onds) (* 14 8640
2f50: 30 29 29 20 0a 09 09 20 20 6d 61 78 2d 61 67 65 0)) ... max-age
2f60: 3a 20 28 2a 20 31 34 20 38 36 34 30 30 29 0a 09 : (* 14 86400)..
2f70: 09 20 20 70 61 74 68 3a 20 22 2f 22 20 3b 3b 20 . path: "/" ;;
2f80: 0a 09 09 20 20 64 6f 6d 61 69 6e 3a 20 2c 28 73 ... domain: ,(s
2f90: 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 22 2e 22 tring-append "."
2fa0: 20 28 73 64 61 74 2d 67 65 74 2d 64 6f 6d 61 69 (sdat-get-domai
2fb0: 6e 20 73 65 6c 66 29 29 0a 09 09 20 20 76 65 72 n self))... ver
2fc0: 73 69 6f 6e 3a 20 31 29 29 20 30 29 29 29 29 29 sion: 1)) 0)))))
2fd0: 0a 0a 3b 3b 20 6c 6f 6f 6b 20 75 70 20 61 20 67 ..;; look up a g
2fe0: 69 76 65 6e 20 73 65 73 73 69 6f 6e 20 6b 65 79 iven session key
2ff0: 20 61 6e 64 20 72 65 74 75 72 6e 20 74 68 65 20 and return the
3000: 69 64 20 69 66 20 66 6f 75 6e 64 2c 20 23 66 20 id if found, #f
3010: 69 66 20 6e 6f 74 20 66 6f 75 6e 64 0a 28 64 65 if not found.(de
3020: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 fine (session:ge
3030: 74 2d 69 64 20 73 65 6c 66 20 73 65 73 73 69 6f t-id self sessio
3040: 6e 2d 6b 65 79 29 0a 20 20 3b 3b 20 28 6c 65 74 n-key). ;; (let
3050: 20 28 28 73 65 73 73 69 6f 6e 2d 6b 65 79 20 28 ((session-key (
3060: 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e sdat-get-session
3070: 2d 6b 65 79 20 73 65 6c 66 29 29 29 0a 20 20 28 -key self))). (
3080: 69 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 0a 20 if session-key.
3090: 20 20 20 20 20 28 6c 65 74 20 28 28 71 75 65 72 (let ((quer
30a0: 79 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 y (string-append
30b0: 20 22 53 45 4c 45 43 54 20 69 64 20 46 52 4f 4d "SELECT id FROM
30c0: 20 73 65 73 73 69 6f 6e 73 20 57 48 45 52 45 20 sessions WHERE
30d0: 73 65 73 73 69 6f 6e 5f 6b 65 79 3d 27 22 20 73 session_key='" s
30e0: 65 73 73 69 6f 6e 2d 6b 65 79 20 22 27 22 29 29 ession-key "'"))
30f0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f . (co
3100: 6e 6e 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e nn (sdat-get-con
3110: 6e 20 73 65 6c 66 29 29 0a 20 20 20 20 20 20 20 n self)).
3120: 20 20 20 20 20 28 72 65 73 75 6c 74 20 23 66 29 (result #f)
3130: 29 0a 09 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 )..(dbi:for-each
3140: 2d 72 6f 77 20 0a 09 20 28 6c 61 6d 62 64 61 20 -row .. (lambda
3150: 28 74 75 70 6c 65 29 0a 09 20 20 20 28 73 65 74 (tuple).. (set
3160: 21 20 72 65 73 75 6c 74 20 28 76 65 63 74 6f 72 ! result (vector
3170: 2d 72 65 66 20 74 75 70 6c 65 20 30 29 29 29 0a -ref tuple 0))).
3180: 09 20 63 6f 6e 6e 20 71 75 65 72 79 29 0a 09 28 . conn query)..(
3190: 69 66 20 72 65 73 75 6c 74 20 28 64 62 69 3a 65 if result (dbi:e
31a0: 78 65 63 20 63 6f 6e 6e 20 28 63 6f 6e 63 20 22 xec conn (conc "
31b0: 55 50 44 41 54 45 20 73 65 73 73 69 6f 6e 73 20 UPDATE sessions
31c0: 53 45 54 20 6c 61 73 74 5f 75 73 65 64 3d 22 20 SET last_used="
31d0: 28 64 62 69 3a 6e 6f 77 20 63 6f 6e 6e 29 20 22 (dbi:now conn) "
31e0: 20 57 48 45 52 45 20 73 65 73 73 69 6f 6e 5f 6b WHERE session_k
31f0: 65 79 3d 3f 3b 22 29 20 73 65 73 73 69 6f 6e 2d ey=?;") session-
3200: 6b 65 79 29 29 0a 20 20 20 20 20 20 20 20 72 65 key)). re
3210: 73 75 6c 74 29 0a 20 20 20 20 20 20 23 66 29 29 sult). #f))
3220: 0a 0a 3b 3b 20 0a 28 64 65 66 69 6e 65 20 28 73 ..;; .(define (s
3230: 65 73 73 69 6f 6e 3a 70 72 6f 63 65 73 73 2d 75 ession:process-u
3240: 72 6c 2d 70 61 74 68 20 73 65 6c 66 29 0a 20 20 rl-path self).
3250: 28 6c 65 74 20 28 28 70 61 74 68 2d 69 6e 66 6f (let ((path-info
3260: 20 20 20 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e (get-environ
3270: 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 50 ment-variable "P
3280: 41 54 48 5f 49 4e 46 4f 22 29 29 0a 09 28 71 75 ATH_INFO"))..(qu
3290: 65 72 79 2d 73 74 72 69 6e 67 20 28 67 65 74 2d ery-string (get-
32a0: 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 environment-vari
32b0: 61 62 6c 65 20 22 51 55 45 52 59 5f 53 54 52 49 able "QUERY_STRI
32c0: 4e 47 22 29 29 29 0a 20 20 20 20 3b 3b 20 28 73 NG"))). ;; (s
32d0: 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 ession:log self
32e0: 22 70 61 74 68 2d 69 6e 66 6f 3d 22 20 70 61 74 "path-info=" pat
32f0: 68 2d 69 6e 66 6f 20 22 20 71 75 65 72 79 2d 73 h-info " query-s
3300: 74 72 69 6e 67 3d 22 20 71 75 65 72 79 2d 73 74 tring=" query-st
3310: 72 69 6e 67 29 0a 20 20 20 20 28 69 66 20 70 61 ring). (if pa
3320: 74 68 2d 69 6e 66 6f 0a 09 28 6c 65 74 2a 20 28 th-info..(let* (
3330: 28 70 61 72 74 73 20 20 20 20 28 73 74 72 69 6e (parts (strin
3340: 67 2d 73 70 6c 69 74 20 70 61 74 68 2d 69 6e 66 g-split path-inf
3350: 6f 20 22 2f 22 29 29 0a 09 20 20 20 20 20 20 20 o "/"))..
3360: 28 6e 75 6d 70 61 72 74 73 20 28 6c 65 6e 67 74 (numparts (lengt
3370: 68 20 70 61 72 74 73 29 29 29 0a 09 20 20 28 69 h parts))).. (i
3380: 66 20 28 3e 20 6e 75 6d 70 61 72 74 73 20 30 29 f (> numparts 0)
3390: 0a 09 20 20 20 20 20 20 28 73 64 61 74 2d 73 65 .. (sdat-se
33a0: 74 2d 70 61 67 65 21 20 73 65 6c 66 20 28 63 61 t-page! self (ca
33b0: 72 20 70 61 72 74 73 29 29 29 0a 09 20 20 3b 3b r parts))).. ;;
33c0: 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 (session:log se
33d0: 6c 66 20 22 75 72 6c 2d 70 61 74 68 3d 22 20 75 lf "url-path=" u
33e0: 72 6c 2d 70 61 74 68 20 22 20 70 61 72 74 73 3d rl-path " parts=
33f0: 22 20 70 61 72 74 73 29 0a 09 20 20 28 69 66 20 " parts).. (if
3400: 28 3e 20 6e 75 6d 70 61 72 74 73 20 31 29 0a 09 (> numparts 1)..
3410: 20 20 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d (sdat-set-
3420: 70 61 74 68 2d 70 61 72 61 6d 73 21 20 73 65 6c path-params! sel
3430: 66 20 28 63 64 72 20 70 61 72 74 73 29 29 29 0a f (cdr parts))).
3440: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 71 75 (if qu
3450: 65 72 79 2d 73 74 72 69 6e 67 0a 20 20 20 20 20 ery-string.
3460: 20 20 20 20 20 20 20 20 20 28 73 64 61 74 2d 73 (sdat-s
3470: 65 74 2d 70 61 72 61 6d 73 21 20 73 65 6c 66 20 et-params! self
3480: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 71 75 (string-split qu
3490: 65 72 79 2d 73 74 72 69 6e 67 20 22 26 22 29 29 ery-string "&"))
34a0: 29 29 29 29 29 0a 0a 3b 3b 20 42 55 47 47 59 21 )))))..;; BUGGY!
34b0: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
34c0: 6e 3a 67 65 74 2d 6e 65 77 2d 6b 65 79 20 73 65 n:get-new-key se
34d0: 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 63 6f 6e lf). (let ((con
34e0: 6e 20 20 20 28 73 64 61 74 2d 67 65 74 2d 63 6f n (sdat-get-co
34f0: 6e 6e 20 73 65 6c 66 29 29 0a 20 20 20 20 20 20 nn self)).
3500: 20 20 28 74 6d 70 6b 65 79 20 28 73 65 73 73 69 (tmpkey (sessi
3510: 6f 6e 3a 6d 61 6b 65 2d 72 61 6e 64 2d 73 74 72 on:make-rand-str
3520: 69 6e 67 20 32 30 29 29 0a 20 20 20 20 20 20 20 ing 20)).
3530: 20 28 73 74 61 74 75 73 20 23 66 29 29 0a 20 20 (status #f)).
3540: 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d (dbi:for-each-
3550: 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 75 70 row (lambda (tup
3560: 6c 65 29 0a 09 09 09 28 73 65 74 21 20 73 74 61 le)....(set! sta
3570: 74 75 73 20 23 74 29 29 0a 09 09 20 20 20 20 20 tus #t))...
3580: 20 63 6f 6e 6e 20 28 73 74 72 69 6e 67 2d 61 70 conn (string-ap
3590: 70 65 6e 64 20 22 49 4e 53 45 52 54 20 49 4e 54 pend "INSERT INT
35a0: 4f 20 73 65 73 73 69 6f 6e 73 20 28 73 65 73 73 O sessions (sess
35b0: 69 6f 6e 5f 6b 65 79 29 20 56 41 4c 55 45 53 20 ion_key) VALUES
35c0: 28 27 22 20 74 6d 70 6b 65 79 20 22 27 29 22 29 ('" tmpkey "')")
35d0: 29 0a 20 20 20 20 74 6d 70 6b 65 79 29 29 0a 0a ). tmpkey))..
35e0: 3b 3b 20 72 65 74 75 72 6e 73 20 73 65 73 73 69 ;; returns sessi
35f0: 6f 6e 20 6b 65 79 20 49 46 46 20 69 74 20 69 73 on key IFF it is
3600: 20 69 6e 20 74 68 65 20 48 54 54 50 5f 43 4f 4f in the HTTP_COO
3610: 4b 49 45 20 0a 28 64 65 66 69 6e 65 20 28 73 65 KIE .(define (se
3620: 73 73 69 6f 6e 3a 65 78 74 72 61 63 74 2d 73 65 ssion:extract-se
3630: 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 0a ssion-key self).
3640: 20 20 28 6c 65 74 20 28 28 68 74 74 70 2d 73 65 (let ((http-se
3650: 73 73 69 6f 6e 20 28 67 65 74 2d 65 6e 76 69 72 ssion (get-envir
3660: 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 onment-variable
3670: 22 48 54 54 50 5f 43 4f 4f 4b 49 45 22 29 29 29 "HTTP_COOKIE")))
3680: 0a 20 20 20 20 28 69 66 20 68 74 74 70 2d 73 65 . (if http-se
3690: 73 73 69 6f 6e 20 0a 20 20 20 20 20 20 20 20 28 ssion . (
36a0: 73 65 73 73 69 6f 6e 3a 65 78 74 72 61 63 74 2d session:extract-
36b0: 6b 65 79 2d 66 72 6f 6d 2d 70 61 72 61 6d 20 73 key-from-param s
36c0: 65 6c 66 20 28 6c 69 73 74 20 68 74 74 70 2d 73 elf (list http-s
36d0: 65 73 73 69 6f 6e 29 20 22 73 65 73 73 69 6f 6e ession) "session
36e0: 5f 6b 65 79 22 29 0a 20 20 20 20 20 20 20 20 23 _key"). #
36f0: 66 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 f)))..(define (s
3700: 65 73 73 69 6f 6e 3a 67 65 74 2d 73 65 73 73 69 ession:get-sessi
3710: 6f 6e 2d 69 64 20 73 65 6c 66 20 73 65 73 73 69 on-id self sessi
3720: 6f 6e 2d 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 on-key). (let (
3730: 28 71 75 65 72 79 20 22 53 45 4c 45 43 54 20 69 (query "SELECT i
3740: 64 20 46 52 4f 4d 20 73 65 73 73 69 6f 6e 73 20 d FROM sessions
3750: 57 48 45 52 45 20 73 65 73 73 69 6f 6e 5f 6b 65 WHERE session_ke
3760: 79 3d 3f 3b 22 29 0a 20 20 20 20 20 20 20 20 28 y=?;"). (
3770: 72 65 73 75 6c 74 20 23 66 29 29 0a 20 20 20 20 result #f)).
3780: 3b 3b 20 20 20 20 20 28 70 67 3a 71 75 65 72 79 ;; (pg:query
3790: 2d 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 -for-each (lambd
37a0: 61 20 28 74 75 70 6c 65 29 0a 20 20 20 20 3b 3b a (tuple). ;;
37b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
37c0: 20 20 20 20 20 20 20 20 20 20 28 73 65 74 21 20 (set!
37d0: 72 65 73 75 6c 74 20 28 76 65 63 74 6f 72 2d 72 result (vector-r
37e0: 65 66 20 74 75 70 6c 65 20 30 29 29 29 20 3b 3b ef tuple 0))) ;;
37f0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 (vector-ref tup
3800: 6c 65 20 30 29 29 29 0a 20 20 20 20 3b 3b 20 20 le 0))). ;;
3810: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3820: 20 20 20 20 20 20 28 73 3a 73 71 6c 70 61 72 61 (s:sqlpara
3830: 6d 20 71 75 65 72 79 20 73 65 73 73 69 6f 6e 2d m query session-
3840: 6b 65 79 29 0a 20 20 20 20 3b 3b 20 20 20 20 20 key). ;;
3850: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3860: 20 20 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e (sdat-get-con
3870: 6e 20 73 65 6c 66 29 29 0a 20 20 20 20 3b 3b 20 n self)). ;;
3880: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3890: 20 20 20 20 20 20 20 63 6f 6e 6e 29 0a 20 20 20 conn).
38a0: 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 (dbi:for-each-r
38b0: 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c ow (lambda (tupl
38c0: 65 29 0a 09 09 09 28 73 65 74 21 20 72 65 73 75 e)....(set! resu
38d0: 6c 74 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 lt (vector-ref t
38e0: 75 70 6c 65 20 30 29 29 29 20 3b 3b 20 28 76 65 uple 0))) ;; (ve
38f0: 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 30 ctor-ref tuple 0
3900: 29 29 29 0a 09 09 20 20 20 20 20 20 28 73 64 61 )))... (sda
3910: 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 t-get-conn self)
3920: 0a 09 09 20 20 20 20 20 20 28 73 3a 73 71 6c 70 ... (s:sqlp
3930: 61 72 61 6d 20 71 75 65 72 79 20 73 65 73 73 69 aram query sessi
3940: 6f 6e 2d 6b 65 79 29 29 0a 20 20 20 20 72 65 73 on-key)). res
3950: 75 6c 74 29 29 0a 0a 3b 3b 20 64 65 6c 65 74 65 ult))..;; delete
3960: 20 61 6c 6c 20 72 65 63 6f 72 64 73 20 66 6f 72 all records for
3970: 20 61 20 73 65 73 73 69 6f 6e 0a 3b 3b 0a 28 64 a session.;;.(d
3980: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 64 efine (session:d
3990: 65 6c 65 74 65 2d 73 65 73 73 69 6f 6e 20 73 65 elete-session se
39a0: 6c 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 0a lf session-key).
39b0: 20 20 28 6c 65 74 20 28 28 73 65 73 73 69 6f 6e (let ((session
39c0: 2d 69 64 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 -id (session:get
39d0: 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 -session-id self
39e0: 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 0a 20 session-key)).
39f0: 20 20 20 20 20 20 20 28 71 72 79 20 20 20 20 20 (qry
3a00: 20 20 20 28 63 6f 6e 63 20 22 42 45 47 49 4e 3b (conc "BEGIN;
3a10: 22 0a 09 09 09 20 20 22 44 45 4c 45 54 45 20 46 ".... "DELETE F
3a20: 52 4f 4d 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 ROM session_vars
3a30: 20 57 48 45 52 45 20 73 65 73 73 69 6f 6e 5f 69 WHERE session_i
3a40: 64 3d 3f 3b 22 0a 20 20 20 20 20 20 20 20 20 20 d=?;".
3a50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3a60: 22 44 45 4c 45 54 45 20 46 52 4f 4d 20 73 65 73 "DELETE FROM ses
3a70: 73 69 6f 6e 73 20 57 48 45 52 45 20 69 64 3d 3f sions WHERE id=?
3a80: 3b 22 0a 09 09 09 20 20 22 43 4f 4d 4d 49 54 3b ;".... "COMMIT;
3a90: 22 29 29 0a 20 20 20 20 20 20 20 20 28 63 6f 6e ")). (con
3aa0: 6e 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 n (
3ab0: 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 sdat-get-conn se
3ac0: 6c 66 29 29 29 0a 20 20 20 20 28 69 66 20 73 65 lf))). (if se
3ad0: 73 73 69 6f 6e 2d 69 64 0a 20 20 20 20 20 20 20 ssion-id.
3ae0: 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 (begin.
3af0: 20 20 28 64 62 69 3a 65 78 65 63 20 63 6f 6e 6e (dbi:exec conn
3b00: 20 71 72 79 20 73 65 73 73 69 6f 6e 2d 69 64 20 qry session-id
3b10: 73 65 73 73 69 6f 6e 2d 69 64 29 0a 09 20 20 28 session-id).. (
3b20: 73 65 73 73 69 6f 6e 3a 69 6e 69 74 69 61 6c 69 session:initiali
3b30: 7a 65 20 73 65 6c 66 29 0a 09 20 20 28 73 65 73 ze self).. (ses
3b40: 73 69 6f 6e 3a 73 65 74 75 70 20 73 65 6c 66 29 sion:setup self)
3b50: 29 29 0a 20 20 20 20 28 6e 6f 74 20 28 73 65 73 )). (not (ses
3b60: 73 69 6f 6e 3a 67 65 74 2d 73 65 73 73 69 6f 6e sion:get-session
3b70: 2d 69 64 20 73 65 6c 66 20 73 65 73 73 69 6f 6e -id self session
3b80: 2d 6b 65 79 29 29 29 29 0a 0a 3b 3b 20 28 64 65 -key))))..;; (de
3b90: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 64 65 fine (session:de
3ba0: 6c 65 74 65 2d 73 65 73 73 69 6f 6e 20 73 65 6c lete-session sel
3bb0: 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 0a 3b f session-key).;
3bc0: 3b 20 20 20 28 6c 65 74 20 28 28 73 65 73 73 69 ; (let ((sessi
3bd0: 6f 6e 2d 69 64 20 28 73 65 73 73 69 6f 6e 3a 67 on-id (session:g
3be0: 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 et-session-id se
3bf0: 6c 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 lf session-key))
3c00: 0a 3b 3b 20 20 20 20 20 20 20 20 20 28 71 75 65 .;; (que
3c10: 72 69 65 73 20 20 20 20 28 6c 69 73 74 20 22 42 ries (list "B
3c20: 45 47 49 4e 3b 22 0a 3b 3b 20 09 09 09 20 20 22 EGIN;".;; ... "
3c30: 44 45 4c 45 54 45 20 46 52 4f 4d 20 73 65 73 73 DELETE FROM sess
3c40: 69 6f 6e 5f 76 61 72 73 20 57 48 45 52 45 20 73 ion_vars WHERE s
3c50: 65 73 73 69 6f 6e 5f 69 64 3d 3f 3b 22 0a 3b 3b ession_id=?;".;;
3c60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3c70: 20 20 20 20 20 20 20 20 20 20 20 22 44 45 4c 45 "DELE
3c80: 54 45 20 46 52 4f 4d 20 73 65 73 73 69 6f 6e 73 TE FROM sessions
3c90: 20 57 48 45 52 45 20 69 64 3d 3f 3b 22 0a 3b 3b WHERE id=?;".;;
3ca0: 20 09 09 09 20 20 22 43 4f 4d 4d 49 54 3b 22 29 ... "COMMIT;")
3cb0: 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 28 63 6f ).;; (co
3cc0: 6e 6e 20 20 20 20 20 20 20 20 20 20 20 20 20 20 nn
3cd0: 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 (sdat-get-conn s
3ce0: 65 6c 66 29 29 29 0a 3b 3b 20 20 20 20 20 28 69 elf))).;; (i
3cf0: 66 20 73 65 73 73 69 6f 6e 2d 69 64 0a 3b 3b 20 f session-id.;;
3d00: 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 3b (begin.;
3d10: 3b 20 20 20 20 20 20 20 20 20 20 20 28 66 6f 72 ; (for
3d20: 2d 65 61 63 68 0a 3b 3b 20 20 20 20 20 20 20 20 -each.;;
3d30: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 71 75 65 (lambda (que
3d40: 72 79 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 ry).;;
3d50: 20 20 20 20 28 64 62 69 3a 65 78 65 63 20 63 6f (dbi:exec co
3d60: 6e 6e 20 71 75 65 72 79 20 73 65 73 73 69 6f 6e nn query session
3d70: 2d 69 64 29 29 0a 3b 3b 20 09 20 20 20 71 75 65 -id)).;; . que
3d80: 72 69 65 73 29 0a 3b 3b 20 09 20 20 28 69 6e 69 ries).;; . (ini
3d90: 74 69 61 6c 69 7a 65 20 73 65 6c 66 20 27 28 29 tialize self '()
3da0: 29 0a 3b 3b 20 09 20 20 28 73 65 73 73 69 6f 6e ).;; . (session
3db0: 3a 73 65 74 75 70 20 73 65 6c 66 29 29 29 0a 3b :setup self))).;
3dc0: 3b 20 20 20 20 20 28 6e 6f 74 20 28 73 65 73 73 ; (not (sess
3dd0: 69 6f 6e 3a 67 65 74 2d 73 65 73 73 69 6f 6e 2d ion:get-session-
3de0: 69 64 20 73 65 6c 66 20 73 65 73 73 69 6f 6e 2d id self session-
3df0: 6b 65 79 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 key))))..(define
3e00: 20 28 73 65 73 73 69 6f 6e 3a 65 78 74 72 61 63 (session:extrac
3e10: 74 2d 6b 65 79 20 73 65 6c 66 20 6b 65 79 29 0a t-key self key).
3e20: 20 20 28 6c 65 74 20 28 28 70 61 72 61 6d 73 20 (let ((params
3e30: 28 73 64 61 74 2d 67 65 74 2d 70 61 72 61 6d 73 (sdat-get-params
3e40: 20 73 65 6c 66 29 29 29 0a 20 20 20 20 28 73 65 self))). (se
3e50: 73 73 69 6f 6e 3a 65 78 74 72 61 63 74 2d 6b 65 ssion:extract-ke
3e60: 79 2d 66 72 6f 6d 2d 70 61 72 61 6d 20 73 65 6c y-from-param sel
3e70: 66 20 70 61 72 61 6d 73 20 6b 65 79 29 29 29 0a f params key))).
3e80: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
3e90: 6e 3a 65 78 74 72 61 63 74 2d 6b 65 79 2d 66 72 n:extract-key-fr
3ea0: 6f 6d 2d 70 61 72 61 6d 20 73 65 6c 66 20 70 61 om-param self pa
3eb0: 72 61 6d 73 20 6b 65 79 29 0a 20 20 28 6c 65 74 rams key). (let
3ec0: 20 28 28 72 31 20 20 20 20 20 28 72 65 67 65 78 ((r1 (regex
3ed0: 70 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 p (string-append
3ee0: 20 22 5e 22 20 6b 65 79 20 22 3d 28 5b 5e 3d 5d "^" key "=([^=]
3ef0: 2b 29 24 22 29 29 29 29 0a 20 20 20 20 28 69 66 +)$")))). (if
3f00: 20 28 3c 20 28 6c 65 6e 67 74 68 20 70 61 72 61 (< (length para
3f10: 6d 73 29 20 31 29 20 23 66 0a 09 28 6c 65 74 20 ms) 1) #f..(let
3f20: 6c 6f 6f 70 20 28 28 68 65 61 64 20 20 20 28 63 loop ((head (c
3f30: 61 72 20 70 61 72 61 6d 73 29 29 0a 09 09 20 20 ar params))...
3f40: 20 28 74 61 69 6c 20 20 20 28 63 64 72 20 70 61 (tail (cdr pa
3f50: 72 61 6d 73 29 29 29 0a 09 20 20 28 6c 65 74 20 rams))).. (let
3f60: 28 28 6d 61 74 63 68 20 28 73 74 72 69 6e 67 2d ((match (string-
3f70: 6d 61 74 63 68 20 72 31 20 68 65 61 64 29 29 29 match r1 head)))
3f80: 0a 09 20 20 20 20 28 63 6f 6e 64 0a 09 20 20 20 .. (cond..
3f90: 20 20 28 6d 61 74 63 68 0a 09 20 20 20 20 20 20 (match..
3fa0: 28 6c 65 74 20 28 28 73 65 73 73 69 6f 6e 2d 6b (let ((session-k
3fb0: 65 79 20 28 6c 69 73 74 2d 72 65 66 20 6d 61 74 ey (list-ref mat
3fc0: 63 68 20 31 29 29 29 0a 09 09 28 73 64 61 74 2d ch 1)))...(sdat-
3fd0: 73 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 21 set-session-key!
3fe0: 20 73 65 6c 66 20 28 6c 69 73 74 2d 72 65 66 20 self (list-ref
3ff0: 6d 61 74 63 68 20 31 29 29 0a 09 09 73 65 73 73 match 1))...sess
4000: 69 6f 6e 2d 6b 65 79 29 29 0a 09 20 20 20 20 20 ion-key))..
4010: 28 28 6e 75 6c 6c 3f 20 74 61 69 6c 29 0a 09 20 ((null? tail)..
4020: 20 20 20 20 20 23 66 29 0a 09 20 20 20 20 20 28 #f).. (
4030: 65 6c 73 65 0a 09 20 20 20 20 20 20 28 6c 6f 6f else.. (loo
4040: 70 20 28 63 61 72 20 74 61 69 6c 29 0a 09 09 20 p (car tail)...
4050: 20 20 20 28 63 64 72 20 74 61 69 6c 29 29 29 29 (cdr tail))))
4060: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define (
4070: 73 65 73 73 69 6f 6e 3a 73 65 74 2d 70 61 67 65 session:set-page
4080: 21 20 73 65 6c 66 20 70 61 67 65 5f 6e 61 6d 65 ! self page_name
4090: 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 ). (sdat-set-pa
40a0: 67 65 21 20 73 65 6c 66 20 70 61 67 65 5f 6e 61 ge! self page_na
40b0: 6d 65 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 me))..(define (s
40c0: 65 73 73 69 6f 6e 3a 63 6c 6f 73 65 20 73 65 6c ession:close sel
40d0: 66 29 0a 20 20 28 64 62 69 3a 63 6c 6f 73 65 20 f). (dbi:close
40e0: 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 (sdat-get-conn s
40f0: 65 6c 66 29 29 29 0a 3b 3b 20 28 63 6c 6f 73 65 elf))).;; (close
4100: 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 28 73 64 -output-port (sd
4110: 61 74 2d 67 65 74 2d 6c 6f 67 70 74 20 73 65 6c at-get-logpt sel
4120: 66 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 f))..(define (se
4130: 73 73 69 6f 6e 3a 65 72 72 2d 6d 73 67 20 73 65 ssion:err-msg se
4140: 6c 66 20 6d 73 67 29 0a 20 20 28 68 61 73 68 2d lf msg). (hash-
4150: 74 61 62 6c 65 2d 73 65 74 21 20 28 73 64 61 74 table-set! (sdat
4160: 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 -get-sessionvars
4170: 20 73 65 6c 66 29 20 22 45 52 52 4f 52 5f 4d 53 self) "ERROR_MS
4180: 47 22 0a 09 09 20 20 20 28 73 74 72 69 6e 67 2d G"... (string-
4190: 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 intersperse (map
41a0: 20 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6d s:any->string m
41b0: 73 67 29 20 22 20 22 29 29 29 0a 0a 28 64 65 66 sg) " ")))..(def
41c0: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 70 72 65 ine (session:pre
41d0: 76 2d 65 72 72 20 73 65 6c 66 29 0a 20 20 28 6c v-err self). (l
41e0: 65 74 20 28 28 70 72 65 76 2d 65 72 72 20 28 68 et ((prev-err (h
41f0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
4200: 66 61 75 6c 74 20 28 73 64 61 74 2d 67 65 74 2d fault (sdat-get-
4210: 73 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 6f sessionvars-befo
4220: 72 65 20 73 65 6c 66 29 20 22 45 52 52 4f 52 5f re self) "ERROR_
4230: 4d 53 47 22 20 23 66 29 29 0a 09 28 63 75 72 72 MSG" #f))..(curr
4240: 2d 65 72 72 20 28 68 61 73 68 2d 74 61 62 6c 65 -err (hash-table
4250: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 28 73 64 -ref/default (sd
4260: 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 at-get-sessionva
4270: 72 73 20 73 65 6c 66 29 20 22 45 52 52 4f 52 5f rs self) "ERROR_
4280: 4d 53 47 22 20 23 66 29 29 29 0a 20 20 20 20 28 MSG" #f))). (
4290: 69 66 20 70 72 65 76 2d 65 72 72 20 70 72 65 76 if prev-err prev
42a0: 2d 65 72 72 0a 09 28 69 66 20 63 75 72 72 2d 65 -err..(if curr-e
42b0: 72 72 20 63 75 72 72 2d 65 72 72 20 23 66 29 29 rr curr-err #f))
42c0: 29 29 0a 0a 3b 3b 20 73 65 73 73 69 6f 6e 20 76 ))..;; session v
42d0: 61 72 73 0a 3b 3b 20 31 2e 20 6b 65 79 73 20 61 ars.;; 1. keys a
42e0: 72 65 20 61 6c 77 61 79 73 20 61 20 73 74 72 69 re always a stri
42f0: 6e 67 20 4e 4f 54 20 61 20 73 79 6d 62 6f 6c 0a ng NOT a symbol.
4300: 3b 3b 20 32 2e 20 76 61 6c 75 65 73 20 61 72 65 ;; 2. values are
4310: 20 61 6c 77 61 79 73 20 61 20 73 74 72 69 6e 67 always a string
4320: 20 63 6f 6e 76 65 72 73 69 6f 6e 20 69 73 20 74 conversion is t
4330: 68 65 20 72 65 73 70 6f 6e 73 69 62 69 6c 69 74 he responsibilit
4340: 79 20 6f 66 20 74 68 65 20 0a 3b 3b 20 20 20 20 y of the .;;
4350: 63 6f 6e 73 75 6d 69 6e 67 20 66 75 6e 63 74 69 consuming functi
4360: 6f 6e 20 28 61 74 20 6c 65 61 73 74 20 66 6f 72 on (at least for
4370: 20 6e 6f 77 2c 20 49 27 64 20 6c 69 6b 65 20 74 now, I'd like t
4380: 6f 20 63 68 61 6e 67 65 20 74 68 69 73 29 0a 0a o change this)..
4390: 3b 3b 20 73 65 74 20 61 20 73 65 73 73 69 6f 6e ;; set a session
43a0: 20 76 61 72 20 66 6f 72 20 74 68 65 20 63 75 72 var for the cur
43b0: 72 65 6e 74 20 70 61 67 65 0a 3b 3b 0a 28 64 65 rent page.;;.(de
43c0: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 63 75 fine (session:cu
43d0: 72 72 2d 70 61 67 65 2d 73 65 74 21 20 73 65 6c rr-page-set! sel
43e0: 66 20 6b 65 79 20 76 61 6c 75 65 29 0a 20 20 28 f key value). (
43f0: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
4400: 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 76 61 (sdat-get-pageva
4410: 72 73 20 73 65 6c 66 29 20 28 73 3a 61 6e 79 2d rs self) (s:any-
4420: 3e 73 74 72 69 6e 67 20 6b 65 79 29 20 28 73 3a >string key) (s:
4430: 61 6e 79 2d 3e 73 74 72 69 6e 67 20 76 61 6c 75 any->string valu
4440: 65 29 29 29 0a 0a 3b 3b 20 64 65 6c 20 61 20 76 e)))..;; del a v
4450: 61 72 20 66 6f 72 20 74 68 65 20 63 75 72 72 65 ar for the curre
4460: 6e 74 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 69 nt page.;;.(defi
4470: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 70 61 67 65 ne (session:page
4480: 2d 76 61 72 2d 64 65 6c 21 20 73 65 6c 66 20 6b -var-del! self k
4490: 65 79 29 0a 20 20 28 68 61 73 68 2d 74 61 62 6c ey). (hash-tabl
44a0: 65 2d 64 65 6c 65 74 65 21 20 28 73 64 61 74 2d e-delete! (sdat-
44b0: 67 65 74 2d 70 61 67 65 76 61 72 73 20 73 65 6c get-pagevars sel
44c0: 66 29 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e f) (s:any->strin
44d0: 67 20 6b 65 79 29 29 29 0a 0a 3b 3b 20 67 65 74 g key)))..;; get
44e0: 20 74 68 65 20 61 70 70 72 6f 70 72 69 61 74 65 the appropriate
44f0: 20 68 61 73 68 20 67 69 76 65 6e 20 61 20 70 61 hash given a pa
4500: 67 65 20 22 2a 73 65 73 73 69 6f 6e 76 61 72 73 ge "*sessionvars
4510: 2a 2c 20 2a 67 6c 6f 62 61 6c 76 61 72 73 2a 20 *, *globalvars*
4520: 6f 72 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 69 or page.;;.(defi
4530: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d ne (session:get-
4540: 70 61 67 65 2d 68 61 73 68 20 73 65 6c 66 20 70 page-hash self p
4550: 61 67 65 29 0a 20 20 28 69 66 20 28 73 74 72 69 age). (if (stri
4560: 6e 67 3d 3f 20 70 61 67 65 20 22 2a 73 65 73 73 ng=? page "*sess
4570: 69 6f 6e 76 61 72 73 2a 22 29 0a 20 20 20 20 20 ionvars*").
4580: 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 (sdat-get-sessi
4590: 6f 6e 76 61 72 73 20 73 65 6c 66 29 0a 20 20 20 onvars self).
45a0: 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 3d 3f (if (string=?
45b0: 20 70 61 67 65 20 22 2a 67 6c 6f 62 61 6c 76 61 page "*globalva
45c0: 72 73 2a 22 29 0a 09 20 20 28 73 64 61 74 2d 67 rs*").. (sdat-g
45d0: 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 20 73 65 et-globalvars se
45e0: 6c 66 29 0a 09 20 20 28 73 64 61 74 2d 67 65 74 lf).. (sdat-get
45f0: 2d 70 61 67 65 76 61 72 73 20 73 65 6c 66 29 29 -pagevars self))
4600: 29 29 0a 0a 3b 3b 20 73 65 74 20 61 20 73 65 73 ))..;; set a ses
4610: 73 69 6f 6e 20 76 61 72 20 66 6f 72 20 61 20 67 sion var for a g
4620: 69 76 65 6e 20 70 61 67 65 0a 3b 3b 0a 28 64 65 iven page.;;.(de
4630: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 65 fine (session:se
4640: 74 21 20 73 65 6c 66 20 70 61 67 65 20 6b 65 79 t! self page key
4650: 20 76 61 6c 75 65 29 0a 20 20 28 6c 65 74 20 28 value). (let (
4660: 28 68 74 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 (ht (session:get
4670: 2d 70 61 67 65 2d 68 61 73 68 20 73 65 6c 66 20 -page-hash self
4680: 70 61 67 65 29 29 29 0a 20 20 20 20 28 68 61 73 page))). (has
4690: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 68 74 20 h-table-set! ht
46a0: 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6b (s:any->string k
46b0: 65 79 29 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 ey) (s:any->stri
46c0: 6e 67 20 76 61 6c 75 65 29 29 29 29 0a 0a 3b 3b ng value))))..;;
46d0: 20 67 65 74 20 73 65 73 73 69 6f 6e 20 76 61 72 get session var
46e0: 73 20 66 6f 72 20 74 68 65 20 63 75 72 72 65 6e s for the curren
46f0: 74 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 69 6e t page.;;.(defin
4700: 65 20 28 73 65 73 73 69 6f 6e 3a 70 61 67 65 2d e (session:page-
4710: 67 65 74 20 73 65 6c 66 20 6b 65 79 29 0a 20 20 get self key).
4720: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
4730: 64 65 66 61 75 6c 74 20 28 73 64 61 74 2d 67 65 default (sdat-ge
4740: 74 2d 70 61 67 65 76 61 72 73 20 73 65 6c 66 29 t-pagevars self)
4750: 20 6b 65 79 20 23 66 29 29 0a 0a 3b 3b 20 67 65 key #f))..;; ge
4760: 74 20 73 65 73 73 69 6f 6e 20 76 61 72 73 20 66 t session vars f
4770: 6f 72 20 61 20 73 70 65 63 69 66 69 65 64 20 70 or a specified p
4780: 61 67 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 age.;;.(define (
4790: 73 65 73 73 69 6f 6e 3a 67 65 74 20 73 65 6c 66 session:get self
47a0: 20 70 61 67 65 20 6b 65 79 29 0a 20 20 28 6c 65 page key). (le
47b0: 74 20 28 28 68 74 20 28 73 65 73 73 69 6f 6e 3a t ((ht (session:
47c0: 67 65 74 2d 70 61 67 65 2d 68 61 73 68 20 73 65 get-page-hash se
47d0: 6c 66 20 70 61 67 65 29 29 29 0a 20 20 20 20 28 lf page))). (
47e0: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
47f0: 65 66 61 75 6c 74 20 68 74 20 6b 65 79 20 23 66 efault ht key #f
4800: 29 29 29 0a 0a 3b 3b 20 64 65 6c 65 74 65 20 61 )))..;; delete a
4810: 20 73 65 73 73 69 6f 6e 20 76 61 72 20 66 6f 72 session var for
4820: 20 61 20 73 70 65 63 69 66 69 65 64 20 70 61 67 a specified pag
4830: 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 e.;;.(define (se
4840: 73 73 69 6f 6e 3a 64 65 6c 21 20 73 65 6c 66 20 ssion:del! self
4850: 70 61 67 65 20 6b 65 79 29 0a 20 20 28 6c 65 74 page key). (let
4860: 20 28 28 68 74 20 28 73 65 73 73 69 6f 6e 3a 67 ((ht (session:g
4870: 65 74 2d 70 61 67 65 2d 68 61 73 68 20 73 65 6c et-page-hash sel
4880: 66 20 70 61 67 65 29 29 29 0a 20 20 20 20 28 68 f page))). (h
4890: 61 73 68 2d 74 61 62 6c 65 2d 64 65 6c 65 74 65 ash-table-delete
48a0: 21 20 68 74 20 6b 65 79 29 29 29 0a 0a 3b 3b 20 ! ht key)))..;;
48b0: 67 65 74 20 41 4c 4c 20 6b 65 79 73 20 66 6f 72 get ALL keys for
48c0: 20 74 68 69 73 20 70 61 67 65 20 61 6e 64 20 73 this page and s
48d0: 74 6f 72 65 20 69 6e 20 74 68 65 20 73 65 73 73 tore in the sess
48e0: 69 6f 6e 20 70 61 67 65 76 61 72 73 20 68 61 73 ion pagevars has
48f0: 68 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 h.;;.(define (se
4900: 73 73 69 6f 6e 3a 67 65 74 2d 76 61 72 73 20 73 ssion:get-vars s
4910: 65 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 73 65 elf). (let ((se
4920: 73 73 69 6f 6e 2d 69 64 20 20 28 73 64 61 74 2d ssion-id (sdat-
4930: 67 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 get-session-id s
4940: 65 6c 66 29 29 29 0a 20 20 20 20 28 69 66 20 28 elf))). (if (
4950: 6e 6f 74 20 73 65 73 73 69 6f 6e 2d 69 64 29 0a not session-id).
4960: 09 28 65 72 72 3a 6c 6f 67 20 22 45 52 52 4f 52 .(err:log "ERROR
4970: 3a 20 4e 6f 20 73 65 73 73 69 6f 6e 20 69 64 20 : No session id
4980: 69 6e 20 73 65 73 73 69 6f 6e 20 6f 62 6a 65 63 in session objec
4990: 74 21 20 73 65 73 73 69 6f 6e 3a 67 65 74 2d 76 t! session:get-v
49a0: 61 72 73 22 29 0a 09 28 6c 65 74 2a 20 28 28 72 ars")..(let* ((r
49b0: 65 73 75 6c 74 20 20 20 20 20 20 20 20 20 20 20 esult
49c0: 20 20 23 66 29 0a 09 20 20 20 20 20 20 20 28 63 #f).. (c
49d0: 6f 6e 6e 20 20 20 20 20 20 20 20 20 20 20 20 20 onn
49e0: 20 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e (sdat-get-conn
49f0: 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 20 20 self))..
4a00: 28 70 61 67 65 76 61 72 73 2d 62 65 66 6f 72 65 (pagevars-before
4a10: 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d 70 61 (sdat-get-pa
4a20: 67 65 76 61 72 73 2d 62 65 66 6f 72 65 20 73 65 gevars-before se
4a30: 6c 66 29 29 0a 09 20 20 20 20 20 20 20 28 73 65 lf)).. (se
4a40: 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 ssionvars-before
4a50: 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 (sdat-get-sessi
4a60: 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 20 73 65 onvars-before se
4a70: 6c 66 29 29 0a 09 20 20 20 20 20 20 20 28 67 6c lf)).. (gl
4a80: 6f 62 61 6c 76 61 72 73 2d 62 65 66 6f 72 65 20 obalvars-before
4a90: 20 28 73 64 61 74 2d 67 65 74 2d 67 6c 6f 62 61 (sdat-get-globa
4aa0: 6c 76 61 72 73 2d 62 65 66 6f 72 65 20 73 65 6c lvars-before sel
4ab0: 66 29 29 0a 09 20 20 20 20 20 20 20 28 70 61 67 f)).. (pag
4ac0: 65 76 61 72 73 20 20 20 20 20 20 20 20 20 20 20 evars
4ad0: 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 76 61 (sdat-get-pageva
4ae0: 72 73 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 rs self))..
4af0: 20 20 28 73 65 73 73 69 6f 6e 76 61 72 73 20 20 (sessionvars
4b00: 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d (sdat-get-
4b10: 73 65 73 73 69 6f 6e 76 61 72 73 20 73 65 6c 66 sessionvars self
4b20: 29 29 0a 09 20 20 20 20 20 20 20 28 67 6c 6f 62 )).. (glob
4b30: 61 6c 76 61 72 73 20 20 20 20 20 20 20 20 20 28 alvars (
4b40: 73 64 61 74 2d 67 65 74 2d 67 6c 6f 62 61 6c 76 sdat-get-globalv
4b50: 61 72 73 20 73 65 6c 66 29 29 0a 09 20 20 20 20 ars self))..
4b60: 20 20 20 28 70 61 67 65 2d 6e 61 6d 65 20 20 20 (page-name
4b70: 20 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 (sdat-get
4b80: 2d 70 61 67 65 20 73 65 6c 66 29 29 0a 09 20 20 -page self))..
4b90: 20 20 20 20 20 28 73 65 73 73 69 6f 6e 2d 6b 65 (session-ke
4ba0: 79 20 20 20 20 20 20 20 20 28 73 64 61 74 2d 67 y (sdat-g
4bb0: 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 et-session-key s
4bc0: 65 6c 66 29 29 0a 09 20 20 20 20 20 20 20 28 71 elf)).. (q
4bd0: 75 65 72 79 20 20 20 20 20 20 20 20 20 20 20 20 uery
4be0: 20 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 (string-append
4bf0: 0a 09 09 09 09 20 20 20 20 22 53 45 4c 45 43 54 ..... "SELECT
4c00: 20 6b 65 79 2c 76 61 6c 75 65 20 46 52 4f 4d 20 key,value FROM
4c10: 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 49 4e 4e session_vars INN
4c20: 45 52 20 4a 4f 49 4e 20 73 65 73 73 69 6f 6e 73 ER JOIN sessions
4c30: 20 4f 4e 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 ON session_vars
4c40: 2e 73 65 73 73 69 6f 6e 5f 69 64 3d 73 65 73 73 .session_id=sess
4c50: 69 6f 6e 73 2e 69 64 20 22 0a 09 09 09 09 20 20 ions.id ".....
4c60: 20 20 22 57 48 45 52 45 20 73 65 73 73 69 6f 6e "WHERE session
4c70: 5f 6b 65 79 3d 3f 20 41 4e 44 20 70 61 67 65 3d _key=? AND page=
4c80: 3f 3b 22 29 29 29 0a 09 20 20 3b 3b 20 66 69 72 ?;"))).. ;; fir
4c90: 73 74 20 74 68 65 20 70 61 67 65 20 73 70 65 63 st the page spec
4ca0: 69 66 69 63 20 76 61 72 73 0a 09 20 20 28 64 62 ific vars.. (db
4cb0: 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 28 i:for-each-row (
4cc0: 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 29 0a 09 lambda (tuple)..
4cd0: 09 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 6b .. (let ((k
4ce0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 (vector-ref tup
4cf0: 6c 65 20 30 29 29 0a 09 09 09 09 20 20 20 20 28 le 0))..... (
4d00: 76 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 75 v (vector-ref tu
4d10: 70 6c 65 20 31 29 29 29 0a 09 09 09 09 28 68 61 ple 1))).....(ha
4d20: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 70 61 sh-table-set! pa
4d30: 67 65 76 61 72 73 2d 62 65 66 6f 72 65 20 6b 20 gevars-before k
4d40: 76 29 0a 09 09 09 09 28 68 61 73 68 2d 74 61 62 v).....(hash-tab
4d50: 6c 65 2d 73 65 74 21 20 70 61 67 65 76 61 72 73 le-set! pagevars
4d60: 20 20 20 20 20 20 20 20 6b 20 76 29 29 29 0a 09 k v)))..
4d70: 09 09 20 20 20 20 63 6f 6e 6e 0a 09 09 09 20 20 .. conn....
4d80: 20 20 28 73 3a 73 71 6c 70 61 72 61 6d 20 71 75 (s:sqlparam qu
4d90: 65 72 79 20 73 65 73 73 69 6f 6e 2d 6b 65 79 20 ery session-key
4da0: 70 61 67 65 2d 6e 61 6d 65 29 29 0a 09 20 20 3b page-name)).. ;
4db0: 3b 20 74 68 65 6e 20 74 68 65 20 73 65 73 73 69 ; then the sessi
4dc0: 6f 6e 20 73 70 65 63 69 66 69 63 20 76 61 72 73 on specific vars
4dd0: 0a 09 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 .. (dbi:for-eac
4de0: 68 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 h-row (lambda (t
4df0: 75 70 6c 65 29 0a 09 09 09 20 20 20 20 20 20 28 uple).... (
4e00: 6c 65 74 20 28 28 6b 20 28 76 65 63 74 6f 72 2d let ((k (vector-
4e10: 72 65 66 20 74 75 70 6c 65 20 30 29 29 0a 09 09 ref tuple 0))...
4e20: 09 09 20 20 20 20 28 76 20 28 76 65 63 74 6f 72 .. (v (vector
4e30: 2d 72 65 66 20 74 75 70 6c 65 20 31 29 29 29 0a -ref tuple 1))).
4e40: 09 09 09 09 28 68 61 73 68 2d 74 61 62 6c 65 2d ....(hash-table-
4e50: 73 65 74 21 20 73 65 73 73 69 6f 6e 76 61 72 73 set! sessionvars
4e60: 2d 62 65 66 6f 72 65 20 6b 20 76 29 0a 09 09 09 -before k v)....
4e70: 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 .(hash-table-set
4e80: 21 20 73 65 73 73 69 6f 6e 76 61 72 73 20 20 20 ! sessionvars
4e90: 20 20 20 20 20 6b 20 76 29 29 29 0a 09 09 09 20 k v)))....
4ea0: 20 20 20 63 6f 6e 6e 0a 09 09 09 20 20 20 20 28 conn.... (
4eb0: 73 3a 73 71 6c 70 61 72 61 6d 20 71 75 65 72 79 s:sqlparam query
4ec0: 20 73 65 73 73 69 6f 6e 2d 6b 65 79 20 22 2a 73 session-key "*s
4ed0: 65 73 73 69 6f 6e 76 61 72 73 2a 22 29 29 0a 09 essionvars*"))..
4ee0: 20 20 3b 3b 20 61 6e 64 20 66 69 6e 61 6c 6c 79 ;; and finally
4ef0: 20 74 68 65 20 67 6c 6f 62 61 6c 20 76 61 72 73 the global vars
4f00: 0a 09 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 .. (dbi:for-eac
4f10: 68 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 h-row (lambda (t
4f20: 75 70 6c 65 29 0a 09 09 09 20 20 20 20 20 20 28 uple).... (
4f30: 6c 65 74 20 28 28 6b 20 28 76 65 63 74 6f 72 2d let ((k (vector-
4f40: 72 65 66 20 74 75 70 6c 65 20 30 29 29 0a 09 09 ref tuple 0))...
4f50: 09 09 20 20 20 20 28 76 20 28 76 65 63 74 6f 72 .. (v (vector
4f60: 2d 72 65 66 20 74 75 70 6c 65 20 31 29 29 29 0a -ref tuple 1))).
4f70: 09 09 09 09 28 68 61 73 68 2d 74 61 62 6c 65 2d ....(hash-table-
4f80: 73 65 74 21 20 67 6c 6f 62 61 6c 76 61 72 73 2d set! globalvars-
4f90: 62 65 66 6f 72 65 20 6b 20 76 29 0a 09 09 09 09 before k v).....
4fa0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
4fb0: 20 67 6c 6f 62 61 6c 76 61 72 73 20 20 20 20 20 globalvars
4fc0: 20 20 20 6b 20 76 29 29 29 0a 09 09 09 20 20 20 k v)))....
4fd0: 20 63 6f 6e 6e 0a 09 09 09 20 20 20 20 28 73 3a conn.... (s:
4fe0: 73 71 6c 70 61 72 61 6d 20 71 75 65 72 79 20 73 sqlparam query s
4ff0: 65 73 73 69 6f 6e 2d 6b 65 79 20 22 2a 67 6c 6f ession-key "*glo
5000: 62 61 6c 76 61 72 73 22 29 29 0a 09 20 20 29 29 balvars")).. ))
5010: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 ))..(define (ses
5020: 73 69 6f 6e 3a 73 61 76 65 2d 76 61 72 73 20 73 sion:save-vars s
5030: 65 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 73 65 elf). (let ((se
5040: 73 73 69 6f 6e 2d 69 64 20 20 28 73 64 61 74 2d ssion-id (sdat-
5050: 67 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 get-session-id s
5060: 65 6c 66 29 29 29 0a 20 20 20 20 28 69 66 20 28 elf))). (if (
5070: 6e 6f 74 20 73 65 73 73 69 6f 6e 2d 69 64 29 0a not session-id).
5080: 09 28 65 72 72 3a 6c 6f 67 20 22 45 52 52 4f 52 .(err:log "ERROR
5090: 3a 20 4e 6f 20 73 65 73 73 69 6f 6e 20 69 64 20 : No session id
50a0: 69 6e 20 73 65 73 73 69 6f 6e 20 6f 62 6a 65 63 in session objec
50b0: 74 21 20 73 65 73 73 69 6f 6e 3a 67 65 74 2d 76 t! session:get-v
50c0: 61 72 73 22 29 0a 09 28 6c 65 74 2a 20 28 28 73 ars")..(let* ((s
50d0: 74 61 74 75 73 20 20 20 20 20 20 23 66 29 0a 09 tatus #f)..
50e0: 20 20 20 20 20 20 20 28 63 6f 6e 6e 20 20 20 20 (conn
50f0: 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d 63 6f (sdat-get-co
5100: 6e 6e 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 nn self))..
5110: 20 20 28 70 61 67 65 2d 6e 61 6d 65 20 20 20 28 (page-name (
5120: 73 64 61 74 2d 67 65 74 2d 70 61 67 65 20 73 65 sdat-get-page se
5130: 6c 66 29 29 0a 09 20 20 20 20 20 20 20 28 64 65 lf)).. (de
5140: 6c 2d 71 75 65 72 79 20 20 20 22 44 45 4c 45 54 l-query "DELET
5150: 45 20 46 52 4f 4d 20 73 65 73 73 69 6f 6e 5f 76 E FROM session_v
5160: 61 72 73 20 57 48 45 52 45 20 73 65 73 73 69 6f ars WHERE sessio
5170: 6e 5f 69 64 3d 3f 20 41 4e 44 20 70 61 67 65 3d n_id=? AND page=
5180: 3f 20 41 4e 44 20 6b 65 79 3d 3f 3b 22 29 0a 09 ? AND key=?;")..
5190: 20 20 20 20 20 20 20 28 69 6e 73 2d 71 75 65 72 (ins-quer
51a0: 79 20 20 20 22 49 4e 53 45 52 54 20 49 4e 54 4f y "INSERT INTO
51b0: 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 28 73 session_vars (s
51c0: 65 73 73 69 6f 6e 5f 69 64 2c 70 61 67 65 2c 6b ession_id,page,k
51d0: 65 79 2c 76 61 6c 75 65 29 20 56 41 4c 55 45 53 ey,value) VALUES
51e0: 28 3f 2c 3f 2c 3f 2c 3f 29 3b 22 29 0a 09 20 20 (?,?,?,?);")..
51f0: 20 20 20 20 20 28 75 70 64 2d 71 75 65 72 79 20 (upd-query
5200: 20 20 22 55 50 44 41 54 45 20 73 65 73 73 69 6f "UPDATE sessio
5210: 6e 5f 76 61 72 73 20 73 65 74 20 76 61 6c 75 65 n_vars set value
5220: 3d 3f 20 57 48 45 52 45 20 6b 65 79 3d 3f 20 41 =? WHERE key=? A
5230: 4e 44 20 73 65 73 73 69 6f 6e 5f 69 64 3d 3f 20 ND session_id=?
5240: 41 4e 44 20 70 61 67 65 3d 3f 3b 22 29 0a 09 20 AND page=?;")..
5250: 20 20 20 20 20 20 28 63 68 61 6e 67 65 64 2d 63 (changed-c
5260: 6f 75 6e 74 20 30 29 29 0a 09 20 20 3b 3b 20 73 ount 0)).. ;; s
5270: 61 76 65 20 74 68 65 20 64 65 6c 74 61 20 6f 6e ave the delta on
5280: 6c 79 0a 09 20 20 28 66 6f 72 2d 65 61 63 68 0a ly.. (for-each.
5290: 09 20 20 20 28 6c 61 6d 62 64 61 20 28 70 61 67 . (lambda (pag
52a0: 65 29 20 3b 3b 20 70 61 67 65 20 69 73 3a 20 22 e) ;; page is: "
52b0: 2a 67 6c 6f 62 61 6c 76 61 72 73 2a 22 20 22 2a *globalvars*" "*
52c0: 73 65 73 73 69 6f 6e 76 61 72 73 2a 22 20 6f 72 sessionvars*" or
52d0: 20 6f 74 68 65 72 73 74 72 69 6e 67 0a 09 20 20 otherstring..
52e0: 20 20 20 28 6c 65 74 2a 20 28 28 62 65 66 6f 72 (let* ((befor
52f0: 65 2d 61 66 74 65 72 2d 68 74 20 28 63 6f 6e 64 e-after-ht (cond
5300: 0a 09 09 09 09 20 20 20 20 20 20 28 28 73 74 72 ..... ((str
5310: 69 6e 67 3d 3f 20 70 61 67 65 20 22 2a 73 65 73 ing=? page "*ses
5320: 73 69 6f 6e 76 61 72 73 2a 22 29 0a 09 09 09 09 sionvars*").....
5330: 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 20 28 (vector (
5340: 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e sdat-get-session
5350: 76 61 72 73 20 73 65 6c 66 29 0a 09 09 09 09 09 vars self)......
5360: 20 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 (sdat-get
5370: 2d 73 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 -sessionvars-bef
5380: 6f 72 65 20 73 65 6c 66 29 29 29 0a 09 09 09 09 ore self))).....
5390: 20 20 20 20 20 20 20 28 28 73 74 72 69 6e 67 3d ((string=
53a0: 3f 20 70 61 67 65 20 22 2a 67 6c 6f 62 61 6c 76 ? page "*globalv
53b0: 61 72 73 2a 22 29 0a 09 09 09 09 09 28 76 65 63 ars*")......(vec
53c0: 74 6f 72 20 28 73 64 61 74 2d 67 65 74 2d 67 6c tor (sdat-get-gl
53d0: 6f 62 61 6c 76 61 72 73 20 73 65 6c 66 29 0a 09 obalvars self)..
53e0: 09 09 09 09 09 28 73 64 61 74 2d 67 65 74 2d 67 .....(sdat-get-g
53f0: 6c 6f 62 61 6c 76 61 72 73 2d 62 65 66 6f 72 65 lobalvars-before
5400: 20 73 65 6c 66 29 29 29 0a 09 09 09 09 20 20 20 self))).....
5410: 20 20 20 20 28 65 6c 73 65 20 0a 09 09 09 09 09 (else ......
5420: 28 76 65 63 74 6f 72 20 28 73 64 61 74 2d 67 65 (vector (sdat-ge
5430: 74 2d 70 61 67 65 76 61 72 73 20 73 65 6c 66 29 t-pagevars self)
5440: 0a 09 09 09 09 09 09 28 73 64 61 74 2d 67 65 74 .......(sdat-get
5450: 2d 70 61 67 65 76 61 72 73 2d 62 65 66 6f 72 65 -pagevars-before
5460: 20 73 65 6c 66 29 29 29 29 29 0a 09 09 20 20 20 self)))))...
5470: 20 28 6d 61 73 74 65 72 2d 68 74 20 20 20 28 76 (master-ht (v
5480: 65 63 74 6f 72 2d 72 65 66 20 62 65 66 6f 72 65 ector-ref before
5490: 2d 61 66 74 65 72 2d 68 74 20 30 29 29 0a 09 09 -after-ht 0))...
54a0: 20 20 20 20 28 62 65 66 6f 72 65 2d 68 74 20 20 (before-ht
54b0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 62 65 66 (vector-ref bef
54c0: 6f 72 65 2d 61 66 74 65 72 2d 68 74 20 31 29 29 ore-after-ht 1))
54d0: 0a 09 09 20 20 20 20 28 6d 61 73 74 65 72 2d 6b ... (master-k
54e0: 65 79 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d eys (hash-table-
54f0: 6b 65 79 73 20 6d 61 73 74 65 72 2d 68 74 29 29 keys master-ht))
5500: 0a 09 09 20 20 20 20 28 62 65 66 6f 72 65 2d 6b ... (before-k
5510: 65 79 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d eys (hash-table-
5520: 6b 65 79 73 20 62 65 66 6f 72 65 2d 68 74 29 29 keys before-ht))
5530: 0a 09 09 20 20 20 20 28 61 6c 6c 2d 6b 65 79 73 ... (all-keys
5540: 20 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 (delete-duplica
5550: 74 65 73 20 28 61 70 70 65 6e 64 20 6d 61 73 74 tes (append mast
5560: 65 72 2d 6b 65 79 73 20 62 65 66 6f 72 65 2d 6b er-keys before-k
5570: 65 79 73 29 29 29 29 0a 09 20 20 20 20 20 20 20 eys))))..
5580: 28 66 6f 72 2d 65 61 63 68 20 0a 09 09 28 6c 61 (for-each ...(la
5590: 6d 62 64 61 20 28 6b 65 79 29 0a 09 09 20 20 28 mbda (key)... (
55a0: 6c 65 74 20 28 28 6d 61 73 74 65 72 2d 76 61 6c let ((master-val
55b0: 75 65 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 ue (hash-table-r
55c0: 65 66 2f 64 65 66 61 75 6c 74 20 6d 61 73 74 65 ef/default maste
55d0: 72 2d 68 74 20 6b 65 79 20 23 66 29 29 0a 09 09 r-ht key #f))...
55e0: 09 28 62 65 66 6f 72 65 2d 76 61 6c 75 65 20 28 .(before-value (
55f0: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
5600: 65 66 61 75 6c 74 20 62 65 66 6f 72 65 2d 68 74 efault before-ht
5610: 20 6b 65 79 20 23 66 29 29 29 0a 09 09 20 20 20 key #f)))...
5620: 20 28 63 6f 6e 64 0a 09 09 20 20 20 20 20 3b 3b (cond... ;;
5630: 20 62 65 66 6f 72 65 20 61 6e 64 20 61 66 74 65 before and afte
5640: 72 20 65 78 69 73 74 20 61 6e 64 20 76 61 6c 75 r exist and valu
5650: 65 20 75 6e 63 68 61 6e 67 65 64 20 2d 20 64 6f e unchanged - do
5660: 20 6e 6f 74 68 69 6e 67 0a 09 09 20 20 20 20 20 nothing...
5670: 28 28 61 6e 64 20 6d 61 73 74 65 72 2d 76 61 6c ((and master-val
5680: 75 65 20 62 65 66 6f 72 65 2d 76 61 6c 75 65 20 ue before-value
5690: 28 65 71 75 61 6c 3f 20 6d 61 73 74 65 72 2d 76 (equal? master-v
56a0: 61 6c 75 65 20 62 65 66 6f 72 65 2d 76 61 6c 75 alue before-valu
56b0: 65 29 29 29 0a 09 09 20 20 20 20 20 3b 3b 20 62 e)))... ;; b
56c0: 65 66 6f 72 65 20 61 6e 64 20 61 66 74 65 72 20 efore and after
56d0: 65 78 69 73 74 20 62 75 74 20 61 72 65 20 63 68 exist but are ch
56e0: 61 6e 67 65 64 0a 09 09 20 20 20 20 20 28 28 61 anged... ((a
56f0: 6e 64 20 6d 61 73 74 65 72 2d 76 61 6c 75 65 20 nd master-value
5700: 62 65 66 6f 72 65 2d 76 61 6c 75 65 29 0a 09 09 before-value)...
5710: 20 20 20 20 20 20 28 64 62 69 3a 66 6f 72 2d 65 (dbi:for-e
5720: 61 63 68 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 ach-row (lambda
5730: 28 74 75 70 6c 65 29 0a 09 09 09 09 09 20 20 28 (tuple)...... (
5740: 73 65 74 21 20 63 68 61 6e 67 65 64 2d 63 6f 75 set! changed-cou
5750: 6e 74 20 28 2b 20 63 68 61 6e 67 65 64 2d 63 6f nt (+ changed-co
5760: 75 6e 74 20 31 29 29 29 0a 09 09 09 09 09 63 6f unt 1)))......co
5770: 6e 6e 0a 09 09 09 09 09 28 73 3a 73 71 6c 70 61 nn......(s:sqlpa
5780: 72 61 6d 20 75 70 64 2d 71 75 65 72 79 20 6d 61 ram upd-query ma
5790: 73 74 65 72 2d 76 61 6c 75 65 20 6b 65 79 20 73 ster-value key s
57a0: 65 73 73 69 6f 6e 2d 69 64 20 70 61 67 65 29 29 ession-id page))
57b0: 29 0a 09 09 20 20 20 20 20 3b 3b 20 6d 61 73 74 )... ;; mast
57c0: 65 72 2d 76 61 6c 75 65 20 6e 6f 20 6c 6f 6e 67 er-value no long
57d0: 65 72 20 65 78 69 73 74 73 20 28 69 2e 65 2e 20 er exists (i.e.
57e0: 23 66 29 20 2d 20 72 65 6d 6f 76 65 20 69 74 65 #f) - remove ite
57f0: 6d 0a 09 09 20 20 20 20 20 28 28 6e 6f 74 20 6d m... ((not m
5800: 61 73 74 65 72 2d 76 61 6c 75 65 29 0a 09 09 20 aster-value)...
5810: 20 20 20 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 (dbi:for-ea
5820: 63 68 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 ch-row (lambda (
5830: 74 75 70 6c 65 29 0a 09 09 09 09 09 20 20 28 73 tuple)...... (s
5840: 65 74 21 20 63 68 61 6e 67 65 64 2d 63 6f 75 6e et! changed-coun
5850: 74 20 28 2b 20 63 68 61 6e 67 65 64 2d 63 6f 75 t (+ changed-cou
5860: 6e 74 20 31 29 29 29 0a 09 09 09 09 09 63 6f 6e nt 1)))......con
5870: 6e 0a 09 09 09 09 09 28 73 3a 73 71 6c 70 61 72 n......(s:sqlpar
5880: 61 6d 20 64 65 6c 2d 71 75 65 72 79 20 73 65 73 am del-query ses
5890: 73 69 6f 6e 2d 69 64 20 70 61 67 65 20 6b 65 79 sion-id page key
58a0: 29 29 29 0a 09 09 20 20 20 20 20 3b 3b 20 62 65 )))... ;; be
58b0: 66 6f 72 65 2d 76 61 6c 75 65 20 64 6f 65 73 6e fore-value doesn
58c0: 27 74 20 65 78 69 73 74 20 2d 20 69 6e 73 65 72 't exist - inser
58d0: 74 20 61 20 6e 65 77 20 76 61 6c 75 65 0a 09 09 t a new value...
58e0: 20 20 20 20 20 28 28 6e 6f 74 20 62 65 66 6f 72 ((not befor
58f0: 65 2d 76 61 6c 75 65 29 0a 09 09 20 20 20 20 20 e-value)...
5900: 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 (dbi:for-each-r
5910: 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c ow (lambda (tupl
5920: 65 29 0a 09 09 09 09 09 20 20 28 73 65 74 21 20 e)...... (set!
5930: 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 28 2b changed-count (+
5940: 20 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 31 changed-count 1
5950: 29 29 29 0a 09 09 09 09 09 63 6f 6e 6e 0a 09 09 )))......conn...
5960: 09 09 09 28 73 3a 73 71 6c 70 61 72 61 6d 20 69 ...(s:sqlparam i
5970: 6e 73 2d 71 75 65 72 79 20 73 65 73 73 69 6f 6e ns-query session
5980: 2d 69 64 20 70 61 67 65 20 6b 65 79 20 6d 61 73 -id page key mas
5990: 74 65 72 2d 76 61 6c 75 65 29 29 29 0a 09 09 20 ter-value)))...
59a0: 20 20 20 20 28 65 6c 73 65 20 28 65 72 72 3a 6c (else (err:l
59b0: 6f 67 20 22 53 68 6f 75 6c 64 6e 27 74 20 67 65 og "Shouldn't ge
59c0: 74 20 68 65 72 65 22 29 29 29 29 29 0a 09 09 61 t here")))))...a
59d0: 6c 6c 2d 6b 65 79 73 29 29 29 20 3b 3b 20 70 72 ll-keys))) ;; pr
59e0: 6f 63 65 73 73 20 61 6c 6c 20 6b 65 79 73 0a 09 ocess all keys..
59f0: 20 20 20 28 6c 69 73 74 20 22 2a 73 65 73 73 69 (list "*sessi
5a00: 6f 6e 76 61 72 73 2a 22 20 22 2a 67 6c 6f 62 61 onvars*" "*globa
5a10: 6c 76 61 72 73 2a 22 20 70 61 67 65 2d 6e 61 6d lvars*" page-nam
5a20: 65 29 29 29 29 29 29 0a 0a 3b 3b 20 28 70 67 3a e))))))..;; (pg:
5a30: 73 71 6c 2d 6e 75 6c 6c 2d 6f 62 6a 65 63 74 3f sql-null-object?
5a40: 20 65 6c 65 6d 65 6e 74 29 0a 28 64 65 66 69 6e element).(defin
5a50: 65 20 28 73 65 73 73 69 6f 6e 3a 72 65 61 64 2d e (session:read-
5a60: 63 6f 6e 66 69 67 20 73 65 6c 66 29 0a 20 20 28 config self). (
5a70: 6c 65 74 20 28 28 6e 61 6d 65 20 28 73 74 72 69 let ((name (stri
5a80: 6e 67 2d 61 70 70 65 6e 64 20 22 2e 22 20 28 70 ng-append "." (p
5a90: 61 74 68 6e 61 6d 65 2d 66 69 6c 65 20 28 63 61 athname-file (ca
5aa0: 72 20 28 61 72 67 76 29 29 29 20 22 2e 63 6f 6e r (argv))) ".con
5ab0: 66 69 67 22 29 29 29 0a 20 20 20 20 28 69 66 20 fig"))). (if
5ac0: 28 6e 6f 74 20 28 66 69 6c 65 2d 65 78 69 73 74 (not (file-exist
5ad0: 73 3f 20 6e 61 6d 65 29 29 0a 09 28 70 72 69 6e s? name))..(prin
5ae0: 74 20 6e 61 6d 65 20 22 20 6e 6f 74 20 66 6f 75 t name " not fou
5af0: 6e 64 20 61 74 20 22 20 28 63 75 72 72 65 6e 74 nd at " (current
5b00: 2d 64 69 72 65 63 74 6f 72 79 29 29 0a 09 28 6c -directory))..(l
5b10: 65 74 2a 20 28 28 66 70 20 28 6f 70 65 6e 2d 69 et* ((fp (open-i
5b20: 6e 70 75 74 2d 66 69 6c 65 20 6e 61 6d 65 29 29 nput-file name))
5b30: 0a 09 20 20 20 20 20 20 20 28 69 6e 69 74 61 72 .. (initar
5b40: 67 73 20 28 72 65 61 64 20 66 70 29 29 29 0a 09 gs (read fp)))..
5b50: 20 20 28 63 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 (close-input-p
5b60: 6f 72 74 20 66 70 29 0a 09 20 20 69 6e 69 74 61 ort fp).. inita
5b70: 72 67 73 29 29 29 29 0a 0a 3b 3b 20 63 61 6c 6c rgs))))..;; call
5b80: 20 74 68 65 20 63 6f 6e 74 72 6f 6c 6c 65 72 20 the controller
5b90: 69 66 20 69 74 20 65 78 69 73 74 73 0a 3b 3b 20 if it exists.;;
5ba0: 0a 3b 3b 20 57 41 52 4e 49 4e 47 20 2d 20 74 68 .;; WARNING - th
5bb0: 69 73 20 63 6f 64 65 20 6e 65 65 64 73 20 61 20 is code needs a
5bc0: 64 65 66 65 6e 63 65 20 61 67 61 69 6e 73 20 72 defence agains r
5bd0: 65 63 75 72 73 69 76 65 20 63 61 6c 6c 69 6e 67 ecursive calling
5be0: 21 21 21 21 21 0a 3b 3b 0a 3b 3b 20 20 20 49 20 !!!!!.;;.;; I
5bf0: 73 75 67 67 65 73 74 20 61 20 6c 69 6d 69 74 20 suggest a limit
5c00: 6f 66 20 31 30 30 20 63 61 6c 6c 73 2e 20 50 6c of 100 calls. Pl
5c10: 65 6e 74 79 20 66 6f 72 20 61 6c 6c 6f 77 69 6e enty for allowin
5c20: 67 20 6d 75 6c 74 69 70 6c 65 20 69 6e 73 74 61 g multiple insta
5c30: 6e 63 65 73 0a 3b 3b 20 20 20 6f 66 20 61 20 70 nces.;; of a p
5c40: 61 67 65 20 69 6e 73 69 64 65 20 61 6e 6f 74 68 age inside anoth
5c50: 65 72 20 70 61 67 65 2e 20 0a 3b 3b 0a 3b 3b 20 er page. .;;.;;
5c60: 70 61 72 74 73 20 3d 20 27 62 6f 74 68 20 7c 20 parts = 'both |
5c70: 27 63 6f 6e 74 72 6f 6c 20 7c 20 27 76 69 65 77 'control | 'view
5c80: 0a 3b 3b 0a 0a 28 64 65 66 69 6e 65 20 28 66 69 .;;..(define (fi
5c90: 6c 65 73 2d 72 65 61 64 2d 3e 73 74 72 69 6e 67 les-read->string
5ca0: 20 2e 20 66 69 6c 65 73 29 0a 20 20 28 73 74 72 . files). (str
5cb0: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
5cc0: 0a 20 20 20 28 61 70 70 6c 79 20 61 70 70 65 6e . (apply appen
5cd0: 64 20 28 6d 61 70 20 66 69 6c 65 2d 72 65 61 64 d (map file-read
5ce0: 2d 3e 73 74 72 69 6e 67 20 66 69 6c 65 73 29 29 ->string files))
5cf0: 20 22 5c 6e 22 29 29 0a 0a 28 64 65 66 69 6e 65 "\n"))..(define
5d00: 20 28 66 69 6c 65 2d 72 65 61 64 2d 3e 73 74 72 (file-read->str
5d10: 69 6e 67 20 66 29 20 0a 20 20 28 6c 65 74 20 28 ing f) . (let (
5d20: 28 70 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 66 (p (open-input-f
5d30: 69 6c 65 20 66 29 29 29 0a 20 20 20 20 28 6c 65 ile f))). (le
5d40: 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 72 65 t loop ((hed (re
5d50: 61 64 2d 6c 69 6e 65 20 70 29 29 0a 09 20 20 20 ad-line p))..
5d60: 20 20 20 20 28 72 65 73 20 27 28 29 29 29 0a 20 (res '())).
5d70: 20 20 20 20 20 28 69 66 20 28 65 6f 66 2d 6f 62 (if (eof-ob
5d80: 6a 65 63 74 3f 20 68 65 64 29 0a 09 20 20 72 65 ject? hed).. re
5d90: 73 0a 09 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 s.. (loop (read
5da0: 2d 6c 69 6e 65 20 70 29 28 61 70 70 65 6e 64 20 -line p)(append
5db0: 72 65 73 20 28 6c 69 73 74 20 68 65 64 29 29 29 res (list hed)))
5dc0: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 70 ))))..(define (p
5dd0: 72 6f 63 65 73 73 2d 70 6f 72 74 20 70 29 0a 20 rocess-port p).
5de0: 20 28 6c 65 74 20 28 28 65 20 28 69 6e 74 65 72 (let ((e (inter
5df0: 61 63 74 69 6f 6e 2d 65 6e 76 69 72 6f 6e 6d 65 action-environme
5e00: 6e 74 29 29 29 0a 20 20 20 20 28 6d 61 70 20 0a nt))). (map .
5e10: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 78 29 (lambda (x)
5e20: 0a 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 09 28 . (cond..(
5e30: 28 6c 69 73 74 3f 20 78 29 20 78 29 0a 09 28 28 (list? x) x)..((
5e40: 73 74 72 69 6e 67 3f 20 78 29 20 78 29 0a 09 28 string? x) x)..(
5e50: 65 6c 73 65 20 27 28 29 29 29 29 0a 20 20 20 20 else '()))).
5e60: 20 28 70 6f 72 74 2d 6d 61 70 20 28 6c 61 6d 62 (port-map (lamb
5e70: 64 61 20 28 73 29 0a 09 09 20 28 65 76 61 6c 20 da (s)... (eval
5e80: 73 20 65 29 29 0a 09 20 20 20 20 20 20 20 28 6c s e)).. (l
5e90: 61 6d 62 64 61 20 28 29 28 72 65 61 64 20 70 29 ambda ()(read p)
5ea0: 29 29 29 29 29 0a 0a 3b 3b 20 4d 61 79 20 32 30 )))))..;; May 20
5eb0: 31 31 2c 20 70 75 74 74 69 6e 67 20 61 6c 6c 20 11, putting all
5ec0: 70 61 67 65 73 20 69 6e 74 6f 20 6f 6e 65 20 64 pages into one d
5ed0: 69 72 65 63 74 6f 72 79 20 66 6f 72 20 74 68 65 irectory for the
5ee0: 20 66 6f 6c 6c 6f 77 69 6e 67 20 72 65 61 73 6f following reaso
5ef0: 6e 73 3a 0a 3b 3b 20 20 20 31 2e 20 77 61 6e 74 ns:.;; 1. want
5f00: 20 66 69 6c 65 6e 61 6d 65 20 74 6f 20 72 65 66 filename to ref
5f10: 6c 65 63 74 20 70 61 67 65 20 6e 61 6d 65 20 28 lect page name (
5f20: 65 6d 61 63 73 20 6c 69 6d 69 74 61 74 69 6f 6e emacs limitation
5f30: 29 0a 3b 3b 20 20 20 32 2e 20 74 68 61 74 27 73 ).;; 2. that's
5f40: 20 69 74 21 20 6e 6f 20 6f 74 68 65 72 20 72 65 it! no other re
5f50: 61 73 6f 6e 2e 20 63 6f 75 6c 64 20 6d 61 6b 65 ason. could make
5f60: 20 69 74 20 63 6f 6e 66 69 67 75 72 61 62 6c 65 it configurable
5f70: 20 2e 2e 2e 0a 28 64 65 66 69 6e 65 20 28 73 65 ....(define (se
5f80: 73 73 69 6f 6e 3a 63 61 6c 6c 2d 70 61 72 74 73 ssion:call-parts
5f90: 20 73 65 6c 66 20 70 61 67 65 20 70 61 72 74 73 self page parts
5fa0: 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 63 75 ). (sdat-set-cu
5fb0: 72 72 2d 70 61 67 65 21 20 73 65 6c 66 20 70 61 rr-page! self pa
5fc0: 67 65 29 0a 20 20 3b 3b 20 28 73 65 73 73 69 6f ge). ;; (sessio
5fd0: 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 70 61 67 65 n:log self "page
5fe0: 2d 64 69 72 2d 73 74 79 6c 65 3a 20 22 20 28 73 -dir-style: " (s
5ff0: 64 61 74 2d 67 65 74 2d 70 61 67 65 2d 64 69 72 dat-get-page-dir
6000: 2d 73 74 79 6c 65 20 73 65 6c 66 29 29 0a 20 20 -style self)).
6010: 28 6c 65 74 2a 20 28 28 64 69 72 2d 73 74 79 6c (let* ((dir-styl
6020: 65 20 3b 3b 20 28 65 71 75 61 6c 3f 20 28 73 64 e ;; (equal? (sd
6030: 61 74 2d 67 65 74 2d 70 61 67 65 2d 64 69 72 2d at-get-page-dir-
6040: 73 74 79 6c 65 20 73 65 6c 66 29 20 22 6f 6e 65 style self) "one
6050: 64 69 72 22 29 29 20 3b 3b 20 66 6c 61 67 20 23 dir")) ;; flag #
6060: 74 20 66 6f 72 20 6f 6e 65 64 69 72 2c 20 23 66 t for onedir, #f
6070: 20 66 6f 72 20 6f 6c 64 20 73 74 79 6c 65 0a 09 for old style..
6080: 20 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 (sdat-get-page
6090: 2d 64 69 72 2d 73 74 79 6c 65 20 73 65 6c 66 29 -dir-style self)
60a0: 29 0a 09 20 28 64 69 72 20 20 20 20 20 28 73 74 ).. (dir (st
60b0: 72 69 6e 67 2d 61 70 70 65 6e 64 20 28 73 64 61 ring-append (sda
60c0: 74 2d 67 65 74 2d 73 72 6f 6f 74 20 73 65 6c 66 t-get-sroot self
60d0: 29 20 0a 09 09 09 09 20 28 69 66 20 64 69 72 2d ) ..... (if dir-
60e0: 73 74 79 6c 65 20 0a 09 09 09 09 20 20 20 20 20 style .....
60f0: 28 63 6f 6e 63 20 22 2f 70 61 67 65 73 2f 22 29 (conc "/pages/")
6100: 0a 09 09 09 09 20 20 20 20 20 28 63 6f 6e 63 20 ..... (conc
6110: 22 2f 70 61 67 65 73 2f 22 20 70 61 67 65 29 29 "/pages/" page))
6120: 29 29 0a 09 20 28 63 6f 6e 74 72 6f 6c 20 28 73 )).. (control (s
6130: 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 64 69 72 tring-append dir
6140: 20 28 69 66 20 64 69 72 2d 73 74 79 6c 65 20 0a (if dir-style .
6150: 09 09 09 09 09 20 28 63 6f 6e 63 20 70 61 67 65 ..... (conc page
6160: 20 22 5f 63 74 72 6c 2e 73 63 6d 22 29 0a 09 09 "_ctrl.scm")...
6170: 09 09 09 20 22 2f 63 6f 6e 74 72 6f 6c 2e 73 63 ... "/control.sc
6180: 6d 22 29 29 29 0a 09 20 28 76 69 65 77 20 20 20 m"))).. (view
6190: 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 (string-append
61a0: 64 69 72 20 28 69 66 20 64 69 72 2d 73 74 79 6c dir (if dir-styl
61b0: 65 20 0a 09 09 09 09 09 20 28 63 6f 6e 63 20 70 e ...... (conc p
61c0: 61 67 65 20 22 5f 76 69 65 77 2e 73 63 6d 22 29 age "_view.scm")
61d0: 0a 09 09 09 09 09 20 22 2f 76 69 65 77 2e 73 63 ...... "/view.sc
61e0: 6d 22 29 29 29 0a 09 20 28 6c 6f 61 64 2d 76 69 m"))).. (load-vi
61f0: 65 77 20 20 20 20 28 61 6e 64 20 28 66 69 6c 65 ew (and (file
6200: 2d 65 78 69 73 74 73 3f 20 76 69 65 77 29 0a 09 -exists? view)..
6210: 09 09 20 20 20 20 28 6f 72 20 28 65 71 3f 20 70 .. (or (eq? p
6220: 61 72 74 73 20 27 62 6f 74 68 29 28 65 71 3f 20 arts 'both)(eq?
6230: 70 61 72 74 73 20 27 76 69 65 77 29 29 29 29 0a parts 'view)))).
6240: 09 20 28 6c 6f 61 64 2d 63 6f 6e 74 72 6f 6c 20 . (load-control
6250: 28 61 6e 64 20 28 66 69 6c 65 2d 65 78 69 73 74 (and (file-exist
6260: 73 3f 20 63 6f 6e 74 72 6f 6c 29 0a 09 09 09 20 s? control)....
6270: 20 20 20 28 6f 72 20 28 65 71 3f 20 70 61 72 74 (or (eq? part
6280: 73 20 27 62 6f 74 68 29 28 65 71 3f 20 70 61 72 s 'both)(eq? par
6290: 74 73 20 27 63 6f 6e 74 72 6f 6c 29 29 29 29 0a ts 'control)))).
62a0: 09 20 28 76 69 65 77 2d 64 61 74 20 20 20 27 28 . (view-dat '(
62b0: 29 29 29 0a 20 20 20 20 3b 3b 20 28 73 65 73 73 ))). ;; (sess
62c0: 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 64 69 ion:log self "di
62d0: 72 2d 73 74 79 6c 65 3a 20 22 20 64 69 72 2d 73 r-style: " dir-s
62e0: 74 79 6c 65 29 0a 20 3b 3b 20 20 20 28 73 75 67 tyle). ;; (sug
62f0: 61 72 20 22 2f 68 6f 6d 65 2f 6d 61 74 74 2f 6b ar "/home/matt/k
6300: 69 61 74 6f 61 2f 73 74 6d 6c 2f 73 75 67 61 72 iatoa/stml/sugar
6310: 2e 73 63 6d 22 20 29 29 0a 20 20 20 20 3b 3b 20 .scm" )). ;;
6320: 28 70 72 69 6e 74 20 22 64 69 72 3d 22 20 64 69 (print "dir=" di
6330: 72 20 22 20 63 6f 6e 74 72 6f 6c 3d 22 20 63 6f r " control=" co
6340: 6e 74 72 6f 6c 20 22 20 76 69 65 77 3d 22 20 76 ntrol " view=" v
6350: 69 65 77 20 22 20 6c 6f 61 64 2d 76 69 65 77 3d iew " load-view=
6360: 22 20 6c 6f 61 64 2d 76 69 65 77 20 22 20 6c 6f " load-view " lo
6370: 61 64 3d 63 6f 6e 74 72 6f 6c 3d 22 20 6c 6f 61 ad=control=" loa
6380: 64 2d 63 6f 6e 74 72 6f 6c 29 0a 20 20 20 20 28 d-control). (
6390: 69 66 20 6c 6f 61 64 2d 63 6f 6e 74 72 6f 6c 0a if load-control.
63a0: 09 28 62 65 67 69 6e 0a 09 20 20 28 6c 6f 61 64 .(begin.. (load
63b0: 20 63 6f 6e 74 72 6f 6c 29 0a 09 20 20 28 73 65 control).. (se
63c0: 73 73 69 6f 6e 3a 73 65 74 2d 63 61 6c 6c 65 64 ssion:set-called
63d0: 21 20 73 65 6c 66 20 70 61 67 65 29 29 29 0a 20 ! self page))).
63e0: 20 20 20 3b 3b 20 6d 6f 76 65 20 74 68 69 73 20 ;; move this
63f0: 74 6f 20 77 68 65 72 65 20 69 74 20 67 65 74 73 to where it gets
6400: 20 65 78 65 63 74 75 74 65 64 20 6f 6e 6c 79 20 exectuted only
6410: 6f 6e 63 65 0a 20 20 20 20 3b 3b 0a 20 20 20 20 once. ;;.
6420: 3b 3b 28 73 3a 6c 6f 67 20 22 73 3a 62 20 79 69 ;;(s:log "s:b yi
6430: 65 6c 64 73 20 22 20 28 73 3a 62 20 22 62 6c 61 elds " (s:b "bla
6440: 68 22 29 29 0a 20 20 20 20 28 69 66 20 6c 6f 61 h")). (if loa
6450: 64 2d 76 69 65 77 0a 09 3b 3b 20 6f 70 74 69 6f d-view..;; optio
6460: 6e 20 6f 6e 65 3a 0a 09 3b 3b 0a 09 3b 3b 20 28 n one:..;;..;; (
6470: 6c 65 74 20 28 28 69 6e 70 20 28 6f 70 65 6e 2d let ((inp (open-
6480: 69 6e 70 75 74 2d 73 74 72 69 6e 67 20 0a 09 3b input-string ..;
6490: 3b 20 09 20 20 20 20 28 66 69 6c 65 73 2d 72 65 ; . (files-re
64a0: 61 64 2d 3e 73 74 72 69 6e 67 20 22 2f 68 6f 6d ad->string "/hom
64b0: 65 2f 6d 61 74 74 2f 6b 69 61 74 6f 61 2f 73 74 e/matt/kiatoa/st
64c0: 6d 6c 2f 73 75 67 61 72 2e 73 63 6d 22 20 0a 09 ml/sugar.scm" ..
64d0: 3b 3b 20 09 09 09 09 76 69 65 77 29 29 29 29 0a ;; ....view)))).
64e0: 09 3b 3b 20 20 20 28 6d 61 70 20 0a 09 3b 3b 20 .;; (map ..;;
64f0: 20 20 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 (lambda (x)..
6500: 3b 3b 20 20 20 20 20 20 28 63 6f 6e 64 0a 09 3b ;; (cond..;
6510: 3b 20 20 20 20 20 20 20 28 28 6c 69 73 74 3f 20 ; ((list?
6520: 78 29 20 78 29 0a 09 3b 3b 20 20 20 20 20 20 20 x) x)..;;
6530: 28 28 73 74 72 69 6e 67 3f 20 78 29 20 78 29 0a ((string? x) x).
6540: 09 3b 3b 20 20 20 20 20 20 20 28 65 6c 73 65 20 .;; (else
6550: 27 28 29 29 29 29 0a 09 3b 3b 20 20 20 20 28 70 '())))..;; (p
6560: 6f 72 74 2d 6d 61 70 20 65 76 61 6c 20 28 6c 61 ort-map eval (la
6570: 6d 62 64 61 20 28 29 0a 09 3b 3b 20 09 09 20 28 mbda ()..;; .. (
6580: 72 65 61 64 20 69 6e 70 29 29 29 29 29 0a 09 3b read inp)))))..;
6590: 3b 0a 09 3b 3b 20 6f 70 74 69 6f 6e 20 74 77 6f ;..;; option two
65a0: 3a 0a 09 3b 3b 0a 09 28 6c 65 74 2a 20 28 3b 3b :..;;..(let* (;;
65b0: 20 28 69 6e 70 73 20 28 6d 61 70 20 6f 70 65 6e (inps (map open
65c0: 2d 69 6e 70 75 74 2d 66 69 6c 65 20 28 6c 69 73 -input-file (lis
65d0: 74 20 76 69 65 77 29 29 29 20 3b 3b 20 73 75 67 t view))) ;; sug
65e0: 61 72 20 76 69 65 77 29 29 29 0a 09 20 20 20 20 ar view)))..
65f0: 20 20 20 28 70 20 20 20 20 28 6f 70 65 6e 2d 69 (p (open-i
6600: 6e 70 75 74 2d 66 69 6c 65 20 76 69 65 77 29 29 nput-file view))
6610: 20 3b 3b 20 28 61 70 70 6c 79 20 6d 61 6b 65 2d ;; (apply make-
6620: 63 6f 6e 63 61 74 65 6e 61 74 65 64 2d 70 6f 72 concatenated-por
6630: 74 20 69 6e 70 73 29 29 0a 09 20 20 20 20 20 20 t inps))..
6640: 20 28 64 61 74 20 20 28 70 72 6f 63 65 73 73 2d (dat (process-
6650: 70 6f 72 74 20 70 29 29 29 0a 09 09 3b 3b 28 6d port p)))...;;(m
6660: 61 70 20 0a 09 09 3b 3b 20 20 20 20 20 20 28 6c ap ...;; (l
6670: 61 6d 62 64 61 20 28 78 29 0a 09 09 3b 3b 09 28 ambda (x)...;;.(
6680: 63 6f 6e 64 0a 09 09 3b 3b 09 20 28 28 6c 69 73 cond...;;. ((lis
6690: 74 3f 20 78 29 20 78 29 0a 09 09 3b 3b 09 20 28 t? x) x)...;;. (
66a0: 28 73 74 72 69 6e 67 3f 20 78 29 20 78 29 0a 09 (string? x) x)..
66b0: 09 3b 3b 09 20 28 65 6c 73 65 20 27 28 29 29 29 .;;. (else '()))
66c0: 29 0a 09 09 3b 3b 20 20 20 20 20 20 28 70 6f 72 )...;; (por
66d0: 74 2d 6d 61 70 20 65 76 61 6c 20 28 6c 61 6d 62 t-map eval (lamb
66e0: 64 61 20 28 29 28 72 65 61 64 20 70 29 29 29 29 da ()(read p))))
66f0: 29 29 0a 09 20 20 3b 3b 20 28 6d 61 70 20 63 6c )).. ;; (map cl
6700: 6f 73 65 2d 69 6e 70 75 74 2d 70 6f 72 74 20 69 ose-input-port i
6710: 6e 70 73 29 0a 09 20 20 28 63 6c 6f 73 65 2d 69 nps).. (close-i
6720: 6e 70 75 74 2d 70 6f 72 74 20 70 29 0a 09 20 20 nput-port p)..
6730: 64 61 74 29 0a 09 28 6c 69 73 74 20 22 3c 70 3e dat)..(list "<p>
6740: 50 61 67 65 20 6e 6f 74 20 66 6f 75 6e 64 20 22 Page not found "
6750: 20 70 61 67 65 20 22 20 3c 2f 70 3e 22 29 29 29 page " </p>")))
6760: 29 0a 0a 3b 3b 28 64 65 66 69 6e 65 20 28 73 65 )..;;(define (se
6770: 73 73 69 6f 6e 3a 63 61 6c 6c 20 73 65 6c 66 20 ssion:call self
6780: 70 61 67 65 29 0a 3b 3b 20 20 28 73 65 73 73 69 page).;; (sessi
6790: 6f 6e 3a 63 61 6c 6c 2d 70 61 72 74 73 20 73 65 on:call-parts se
67a0: 6c 66 20 70 61 67 65 20 27 62 6f 74 68 29 29 0a lf page 'both)).
67b0: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
67c0: 6e 3a 63 61 6c 6c 20 73 65 6c 66 20 70 61 67 65 n:call self page
67d0: 20 70 61 72 74 73 29 0a 20 20 28 73 65 73 73 69 parts). (sessi
67e0: 6f 6e 3a 63 61 6c 6c 2d 70 61 72 74 73 20 73 65 on:call-parts se
67f0: 6c 66 20 70 61 67 65 20 27 62 6f 74 68 29 29 0a lf page 'both)).
6800: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
6810: 6e 3a 6c 6f 61 64 2d 6d 6f 64 65 6c 20 73 65 6c n:load-model sel
6820: 66 20 6d 6f 64 65 6c 29 0a 20 20 28 6c 65 74 20 f model). (let
6830: 28 28 6d 6f 64 65 6c 2e 73 63 6d 20 28 73 74 72 ((model.scm (str
6840: 69 6e 67 2d 61 70 70 65 6e 64 20 28 73 64 61 74 ing-append (sdat
6850: 2d 67 65 74 2d 73 72 6f 6f 74 20 73 65 6c 66 29 -get-sroot self)
6860: 20 22 2f 6d 6f 64 65 6c 73 2f 22 20 6d 6f 64 65 "/models/" mode
6870: 6c 20 22 2e 73 63 6d 22 29 29 0a 09 28 6d 6f 64 l ".scm"))..(mod
6880: 65 6c 2e 73 6f 20 20 28 73 74 72 69 6e 67 2d 61 el.so (string-a
6890: 70 70 65 6e 64 20 28 73 64 61 74 2d 67 65 74 2d ppend (sdat-get-
68a0: 73 72 6f 6f 74 20 73 65 6c 66 29 20 22 2f 6d 6f sroot self) "/mo
68b0: 64 65 6c 73 2f 22 20 6d 6f 64 65 6c 20 22 2e 73 dels/" model ".s
68c0: 6f 22 29 29 29 0a 20 20 20 20 28 69 66 20 28 66 o"))). (if (f
68d0: 69 6c 65 2d 65 78 69 73 74 73 3f 20 6d 6f 64 65 ile-exists? mode
68e0: 6c 2e 73 6f 29 0a 09 28 6c 6f 61 64 20 6d 6f 64 l.so)..(load mod
68f0: 65 6c 2e 73 6f 29 0a 09 28 69 66 20 28 66 69 6c el.so)..(if (fil
6900: 65 2d 65 78 69 73 74 73 3f 20 6d 6f 64 65 6c 2e e-exists? model.
6910: 73 63 6d 29 0a 09 20 20 20 20 28 6c 6f 61 64 20 scm).. (load
6920: 6d 6f 64 65 6c 2e 73 63 6d 29 0a 09 20 20 20 20 model.scm)..
6930: 28 73 3a 6c 6f 67 20 22 45 52 52 4f 52 3a 20 6d (s:log "ERROR: m
6940: 6f 64 65 6c 20 22 20 6d 6f 64 65 6c 2e 73 63 6d odel " model.scm
6950: 20 22 20 6e 6f 74 20 66 6f 75 6e 64 22 29 29 29 " not found")))
6960: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 ))..(define (ses
6970: 73 69 6f 6e 3a 6d 6f 64 65 6c 2d 70 61 74 68 20 sion:model-path
6980: 73 65 6c 66 20 6d 6f 64 65 6c 29 0a 20 20 28 73 self model). (s
6990: 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 28 73 64 tring-append (sd
69a0: 61 74 2d 67 65 74 2d 73 72 6f 6f 74 20 73 65 6c at-get-sroot sel
69b0: 66 29 20 22 2f 6d 6f 64 65 6c 73 2f 22 20 6d 6f f) "/models/" mo
69c0: 64 65 6c 20 22 2e 73 63 6d 22 29 29 0a 0a 28 64 del ".scm"))..(d
69d0: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 70 efine (session:p
69e0: 70 2d 66 6f 72 6d 64 61 74 20 73 65 6c 66 29 0a p-formdat self).
69f0: 20 20 28 6c 65 74 20 28 28 64 61 74 20 28 66 6f (let ((dat (fo
6a00: 72 6d 64 61 74 3a 61 6c 6c 2d 3e 73 74 72 69 6e rmdat:all->strin
6a10: 67 73 20 28 73 64 61 74 2d 67 65 74 2d 66 6f 72 gs (sdat-get-for
6a20: 6d 64 61 74 20 73 65 6c 66 29 29 29 29 0a 20 20 mdat self)))).
6a30: 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 (string-inters
6a40: 70 65 72 73 65 20 64 61 74 20 22 3c 62 72 3e 20 perse dat "<br>
6a50: 22 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 ")))..(define (s
6a60: 65 73 73 69 6f 6e 3a 70 61 72 61 6d 2d 3e 73 74 ession:param->st
6a70: 72 69 6e 67 20 70 61 72 61 6d 73 29 0a 20 20 3b ring params). ;
6a80: 3b 20 28 65 72 72 3a 6c 6f 67 20 22 70 61 72 61 ; (err:log "para
6a90: 6d 73 3d 22 20 70 61 72 61 6d 73 29 0a 20 20 28 ms=" params). (
6aa0: 69 66 20 28 3c 20 28 6c 65 6e 67 74 68 20 70 61 if (< (length pa
6ab0: 72 61 6d 73 29 20 31 29 0a 20 20 20 20 20 20 22 rams) 1). "
6ac0: 22 0a 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f ". (let loo
6ad0: 70 20 28 28 6b 65 79 20 28 63 61 72 20 70 61 72 p ((key (car par
6ae0: 61 6d 73 29 29 0a 09 09 20 28 76 61 6c 20 28 63 ams))... (val (c
6af0: 61 64 72 20 70 61 72 61 6d 73 29 29 0a 09 09 20 adr params))...
6b00: 28 74 61 69 6c 20 28 63 64 64 72 20 70 61 72 61 (tail (cddr para
6b10: 6d 73 29 29 0a 09 09 20 28 72 65 73 75 6c 74 20 ms))... (result
6b20: 27 28 29 29 29 0a 09 28 6c 65 74 20 28 28 6e 65 '()))..(let ((ne
6b30: 77 72 65 73 75 6c 74 20 28 63 6f 6e 73 20 28 73 wresult (cons (s
6b40: 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 28 73 3a tring-append (s:
6b50: 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6b 65 79 29 any->string key)
6b60: 20 22 3d 22 20 28 73 3a 61 6e 79 2d 3e 73 74 72 "=" (s:any->str
6b70: 69 6e 67 20 76 61 6c 29 29 0a 09 09 09 20 20 20 ing val))....
6b80: 20 20 20 20 72 65 73 75 6c 74 29 29 29 0a 09 20 result)))..
6b90: 20 28 69 66 20 28 3c 20 28 6c 65 6e 67 74 68 20 (if (< (length
6ba0: 74 61 69 6c 29 20 31 29 20 3b 3b 20 74 72 75 65 tail) 1) ;; true
6bb0: 20 69 66 20 64 6f 6e 65 0a 09 20 20 20 20 20 20 if done..
6bc0: 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
6bd0: 72 73 65 20 6e 65 77 72 65 73 75 6c 74 20 22 26 rse newresult "&
6be0: 22 29 0a 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 ").. (loop
6bf0: 28 63 61 72 20 74 61 69 6c 29 28 63 61 64 72 20 (car tail)(cadr
6c00: 74 61 69 6c 29 28 63 64 64 72 20 74 61 69 6c 29 tail)(cddr tail)
6c10: 20 6e 65 77 72 65 73 75 6c 74 29 29 29 29 29 29 newresult))))))
6c20: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ..(define (sessi
6c30: 6f 6e 3a 6c 69 6e 6b 2d 74 6f 20 73 65 6c 66 20 on:link-to self
6c40: 70 61 67 65 20 70 61 72 61 6d 73 29 0a 20 20 28 page params). (
6c50: 6c 65 74 2a 20 28 28 73 65 72 76 65 72 20 20 20 let* ((server
6c60: 20 28 69 66 20 28 67 65 74 2d 65 6e 76 69 72 6f (if (get-enviro
6c70: 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 nment-variable "
6c80: 48 54 54 50 5f 48 4f 53 54 22 29 0a 09 09 09 28 HTTP_HOST")....(
6c90: 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d get-environment-
6ca0: 76 61 72 69 61 62 6c 65 20 22 48 54 54 50 5f 48 variable "HTTP_H
6cb0: 4f 53 54 22 29 0a 09 09 09 28 67 65 74 2d 65 6e OST")....(get-en
6cc0: 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 vironment-variab
6cd0: 6c 65 20 22 53 45 52 56 45 52 5f 4e 41 4d 45 22 le "SERVER_NAME"
6ce0: 29 29 29 0a 09 20 28 73 63 72 69 70 74 20 28 6c ))).. (script (l
6cf0: 65 74 20 28 28 73 63 72 69 70 74 2d 6e 61 6d 65 et ((script-name
6d00: 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 28 (string-split (
6d10: 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d get-environment-
6d20: 76 61 72 69 61 62 6c 65 20 22 53 43 52 49 50 54 variable "SCRIPT
6d30: 5f 4e 41 4d 45 22 29 20 22 2f 22 29 29 29 0a 09 _NAME") "/")))..
6d40: 09 20 20 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 . (if (> (leng
6d50: 74 68 20 73 63 72 69 70 74 2d 6e 61 6d 65 29 20 th script-name)
6d60: 31 29 0a 09 09 20 20 20 20 20 20 20 28 73 74 72 1)... (str
6d70: 69 6e 67 2d 61 70 70 65 6e 64 20 28 63 61 72 20 ing-append (car
6d80: 73 63 72 69 70 74 2d 6e 61 6d 65 29 20 22 2f 22 script-name) "/"
6d90: 20 28 63 61 64 72 20 73 63 72 69 70 74 2d 6e 61 (cadr script-na
6da0: 6d 65 29 29 0a 09 09 20 20 20 20 20 20 20 28 67 me))... (g
6db0: 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 et-environment-v
6dc0: 61 72 69 61 62 6c 65 20 22 53 43 52 49 50 54 5f ariable "SCRIPT_
6dd0: 4e 41 4d 45 22 29 29 29 29 20 3b 3b 20 62 75 69 NAME")))) ;; bui
6de0: 6c 64 20 73 63 72 69 70 74 20 6e 61 6d 65 20 66 ld script name f
6df0: 72 6f 6d 20 66 69 72 73 74 20 74 77 6f 20 65 6c rom first two el
6e00: 65 6d 65 6e 74 73 2e 20 54 68 69 73 20 69 73 20 ements. This is
6e10: 61 20 68 61 6e 67 6f 76 65 72 20 66 72 6f 6d 20 a hangover from
6e20: 62 65 66 6f 72 65 20 49 20 75 73 65 64 20 3f 20 before I used ?
6e30: 69 6e 20 74 68 65 20 55 52 4c 2e 0a 09 20 28 73 in the URL... (s
6e40: 65 73 73 69 6f 6e 2d 6b 65 79 20 28 73 64 61 74 ession-key (sdat
6e50: 2d 67 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 -get-session-key
6e60: 20 73 65 6c 66 29 29 0a 09 20 28 70 61 72 61 6d self)).. (param
6e70: 73 74 72 20 28 73 65 73 73 69 6f 6e 3a 70 61 72 str (session:par
6e80: 61 6d 2d 3e 73 74 72 69 6e 67 20 70 61 72 61 6d am->string param
6e90: 73 29 29 29 0a 20 20 20 20 3b 3b 20 28 73 65 73 s))). ;; (ses
6ea0: 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 73 sion:log self "s
6eb0: 65 72 76 65 72 3d 22 20 73 65 72 76 65 72 20 22 erver=" server "
6ec0: 20 73 63 72 69 70 74 3d 22 20 73 63 72 69 70 74 script=" script
6ed0: 20 22 20 70 61 67 65 3d 22 20 70 61 67 65 29 0a " page=" page).
6ee0: 20 20 20 20 28 73 74 72 69 6e 67 2d 61 70 70 65 (string-appe
6ef0: 6e 64 20 22 68 74 74 70 3a 2f 2f 22 20 73 65 72 nd "http://" ser
6f00: 76 65 72 20 22 2f 22 20 73 63 72 69 70 74 20 22 ver "/" script "
6f10: 2f 22 20 70 61 67 65 20 22 3f 22 20 70 61 72 61 /" page "?" para
6f20: 6d 73 74 72 29 29 29 20 3b 3b 20 22 2f 73 6e 3d mstr))) ;; "/sn=
6f30: 22 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 29 " session-key)))
6f40: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ..(define (sessi
6f50: 6f 6e 3a 63 67 69 2d 6f 75 74 20 73 65 6c 66 29 on:cgi-out self)
6f60: 0a 20 20 28 6c 65 74 2a 20 28 28 63 6f 6e 74 65 . (let* ((conte
6f70: 6e 74 20 20 28 6c 69 73 74 20 28 73 64 61 74 2d nt (list (sdat-
6f80: 67 65 74 2d 63 6f 6e 74 65 6e 74 2d 74 79 70 65 get-content-type
6f90: 20 73 65 6c 66 29 29 29 20 3b 3b 20 27 28 22 43 self))) ;; '("C
6fa0: 6f 6e 74 65 6e 74 2d 74 79 70 65 3a 20 74 65 78 ontent-type: tex
6fb0: 74 2f 68 74 6d 6c 3b 20 63 68 61 72 73 65 74 3d t/html; charset=
6fc0: 69 73 6f 2d 38 38 35 39 2d 31 5c 6e 5c 6e 22 29 iso-8859-1\n\n")
6fd0: 29 0a 09 20 28 68 65 61 64 65 72 20 20 20 28 6c ).. (header (l
6fe0: 65 74 20 28 28 63 6f 6f 6b 69 65 20 28 73 64 61 et ((cookie (sda
6ff0: 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 2d 63 6f t-get-session-co
7000: 6f 6b 69 65 20 73 65 6c 66 29 29 29 0a 09 09 20 okie self)))...
7010: 20 20 20 20 28 69 66 20 63 6f 6f 6b 69 65 0a 09 (if cookie..
7020: 09 09 20 28 63 6f 6e 73 20 28 73 74 72 69 6e 67 .. (cons (string
7030: 2d 61 70 70 65 6e 64 20 22 53 65 74 2d 43 6f 6f -append "Set-Coo
7040: 6b 69 65 3a 20 22 20 28 63 61 72 20 63 6f 6f 6b kie: " (car cook
7050: 69 65 29 29 0a 09 09 09 20 20 20 20 20 20 20 63 ie)).... c
7060: 6f 6e 74 65 6e 74 29 0a 09 09 09 20 63 6f 6e 74 ontent).... cont
7070: 65 6e 74 29 29 29 0a 09 20 28 70 61 67 65 64 61 ent))).. (pageda
7080: 74 20 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 t (sdat-get-pag
7090: 65 64 61 74 20 73 65 6c 66 29 29 29 0a 20 20 20 edat self))).
70a0: 20 28 73 3a 63 67 69 2d 6f 75 74 20 0a 20 20 20 (s:cgi-out .
70b0: 20 20 28 63 6f 6e 73 20 68 65 61 64 65 72 20 70 (cons header p
70c0: 61 67 65 64 61 74 29 29 29 29 0a 0a 28 64 65 66 agedat))))..(def
70d0: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 ine (session:log
70e0: 20 73 65 6c 66 20 2e 20 6d 73 67 29 0a 20 20 28 self . msg). (
70f0: 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 70 with-output-to-p
7100: 6f 72 74 20 28 73 64 61 74 2d 67 65 74 2d 6c 6f ort (sdat-get-lo
7110: 67 2d 70 6f 72 74 20 73 65 6c 66 29 20 3b 3b 20 g-port self) ;;
7120: 28 73 64 61 74 2d 67 65 74 2d 6c 6f 67 70 74 20 (sdat-get-logpt
7130: 73 65 6c 66 29 0a 20 20 20 20 28 6c 61 6d 62 64 self). (lambd
7140: 61 20 28 29 20 0a 20 20 20 20 20 20 28 61 70 70 a () . (app
7150: 6c 79 20 70 72 69 6e 74 20 6d 73 67 29 29 29 29 ly print msg))))
7160: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ..(define (sessi
7170: 6f 6e 3a 67 65 74 2d 70 61 72 61 6d 20 73 65 6c on:get-param sel
7180: 66 20 6b 65 79 29 0a 20 20 3b 3b 20 28 73 65 73 f key). ;; (ses
7190: 73 69 6f 6e 3a 6c 6f 67 20 73 3a 73 65 73 73 69 sion:log s:sessi
71a0: 6f 6e 20 22 70 61 72 61 6d 73 3d 22 20 28 73 6c on "params=" (sl
71b0: 6f 74 2d 72 65 66 20 73 3a 73 65 73 73 69 6f 6e ot-ref s:session
71c0: 20 27 70 61 72 61 6d 73 29 29 0a 20 20 28 6c 65 'params)). (le
71d0: 74 20 28 28 70 61 72 61 6d 73 20 28 73 64 61 74 t ((params (sdat
71e0: 2d 67 65 74 2d 70 61 72 61 6d 73 20 73 65 6c 66 -get-params self
71f0: 29 29 29 0a 20 20 20 20 28 73 65 73 73 69 6f 6e ))). (session
7200: 3a 67 65 74 2d 70 61 72 61 6d 2d 66 72 6f 6d 20 :get-param-from
7210: 70 61 72 61 6d 73 20 6b 65 79 29 29 29 0a 0a 3b params key)))..;
7220: 3b 20 54 68 69 73 20 6f 6e 65 20 77 69 6c 6c 20 ; This one will
7230: 67 65 74 20 74 68 65 20 66 69 72 73 74 20 76 61 get the first va
7240: 6c 75 65 20 66 6f 75 6e 64 20 72 65 67 61 72 64 lue found regard
7250: 6c 65 73 73 20 6f 66 20 66 6f 72 6d 0a 28 64 65 less of form.(de
7260: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 fine (session:ge
7270: 74 2d 69 6e 70 75 74 20 73 65 6c 66 20 6b 65 79 t-input self key
7280: 29 0a 20 20 28 6c 65 74 2a 20 28 28 66 6f 72 6d ). (let* ((form
7290: 64 61 74 20 28 73 64 61 74 2d 67 65 74 2d 66 6f dat (sdat-get-fo
72a0: 72 6d 64 61 74 20 73 65 6c 66 29 29 29 0a 20 20 rmdat self))).
72b0: 20 20 28 69 66 20 28 6e 6f 74 20 66 6f 72 6d 64 (if (not formd
72c0: 61 74 29 20 23 66 0a 09 28 69 66 20 28 6f 72 20 at) #f..(if (or
72d0: 28 73 74 72 69 6e 67 3f 20 6b 65 79 29 28 6e 75 (string? key)(nu
72e0: 6d 62 65 72 3f 20 6b 65 79 29 28 73 79 6d 62 6f mber? key)(symbo
72f0: 6c 3f 20 6b 65 79 29 29 0a 09 20 20 20 20 28 69 l? key)).. (i
7300: 66 20 28 61 6e 64 20 28 76 65 63 74 6f 72 3f 20 f (and (vector?
7310: 66 6f 72 6d 64 61 74 29 28 65 71 3f 20 28 76 65 formdat)(eq? (ve
7320: 63 74 6f 72 2d 6c 65 6e 67 74 68 20 66 6f 72 6d ctor-length form
7330: 64 61 74 29 20 31 29 28 68 61 73 68 2d 74 61 62 dat) 1)(hash-tab
7340: 6c 65 3f 20 28 76 65 63 74 6f 72 2d 72 65 66 20 le? (vector-ref
7350: 66 6f 72 6d 64 61 74 20 30 29 29 29 0a 09 09 28 formdat 0)))...(
7360: 66 6f 72 6d 64 61 74 3a 67 65 74 20 66 6f 72 6d formdat:get form
7370: 64 61 74 20 6b 65 79 29 0a 09 09 28 62 65 67 69 dat key)...(begi
7380: 6e 0a 09 09 20 20 28 73 65 73 73 69 6f 6e 3a 6c n... (session:l
7390: 6f 67 20 73 65 6c 66 20 22 45 52 52 4f 52 3a 20 og self "ERROR:
73a0: 66 6f 72 6d 64 61 74 3a 20 22 20 66 6f 72 6d 64 formdat: " formd
73b0: 61 74 20 22 20 69 73 20 6e 6f 74 20 6f 66 20 63 at " is not of c
73c0: 6c 61 73 73 20 3c 66 6f 72 6d 64 61 74 3e 22 29 lass <formdat>")
73d0: 0a 09 09 20 20 23 66 29 29 0a 09 20 20 20 20 28 ... #f)).. (
73e0: 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 session:log self
73f0: 20 22 45 52 52 4f 52 3a 20 62 61 64 20 6b 65 79 "ERROR: bad key
7400: 20 22 20 6b 65 79 29 29 29 29 29 0a 0a 28 64 65 " key)))))..(de
7410: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 72 75 fine (session:ru
7420: 6e 2d 61 63 74 69 6f 6e 73 20 73 65 6c 66 29 0a n-actions self).
7430: 20 20 28 6c 65 74 2a 20 28 28 61 63 74 69 6f 6e (let* ((action
7440: 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 (session:get
7450: 2d 70 61 72 61 6d 20 73 65 6c 66 20 27 61 63 74 -param self 'act
7460: 69 6f 6e 29 29 0a 09 20 28 70 61 67 65 20 20 20 ion)).. (page
7470: 20 20 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 (sdat-get-pag
7480: 65 20 73 65 6c 66 29 29 29 0a 20 20 20 20 3b 3b e self))). ;;
7490: 20 28 70 72 69 6e 74 20 22 61 63 74 69 6f 6e 3d (print "action=
74a0: 22 20 61 63 74 69 6f 6e 20 22 20 70 61 67 65 3d " action " page=
74b0: 22 20 70 61 67 65 29 0a 20 20 20 20 28 69 66 20 " page). (if
74c0: 61 63 74 69 6f 6e 0a 09 28 6c 65 74 20 28 28 61 action..(let ((a
74d0: 63 74 69 6f 6e 2d 6c 73 74 20 20 28 73 74 72 69 ction-lst (stri
74e0: 6e 67 2d 73 70 6c 69 74 20 61 63 74 69 6f 6e 20 ng-split action
74f0: 22 2e 22 29 29 29 0a 09 20 20 3b 3b 20 28 70 72 "."))).. ;; (pr
7500: 69 6e 74 20 22 61 63 74 69 6f 6e 2d 6c 73 74 3d int "action-lst=
7510: 22 20 61 63 74 69 6f 6e 2d 6c 73 74 29 0a 09 20 " action-lst)..
7520: 20 28 69 66 20 28 6e 6f 74 20 28 3d 20 28 6c 65 (if (not (= (le
7530: 6e 67 74 68 20 61 63 74 69 6f 6e 2d 6c 73 74 29 ngth action-lst)
7540: 20 32 29 29 20 0a 09 20 20 20 20 20 20 28 65 72 2)) .. (er
7550: 72 3a 6c 6f 67 20 22 41 63 74 69 6f 6e 20 73 68 r:log "Action sh
7560: 6f 75 6c 64 20 62 65 20 6f 66 20 66 6f 72 6d 3a ould be of form:
7570: 20 6d 6f 64 75 6c 65 2e 61 63 74 69 6f 6e 22 29 module.action")
7580: 0a 09 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 .. (let* ((
7590: 74 61 72 67 2d 70 61 67 65 20 20 20 28 63 61 72 targ-page (car
75a0: 20 61 63 74 69 6f 6e 2d 6c 73 74 29 29 0a 09 09 action-lst))...
75b0: 20 20 20 20 20 28 70 72 6f 63 2d 6e 61 6d 65 20 (proc-name
75c0: 20 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 (string-append
75d0: 20 74 61 72 67 2d 70 61 67 65 20 22 2d 61 63 74 targ-page "-act
75e0: 69 6f 6e 22 29 29 0a 09 09 20 20 20 20 20 28 74 ion"))... (t
75f0: 61 72 67 2d 61 63 74 69 6f 6e 20 28 63 61 64 72 arg-action (cadr
7600: 20 61 63 74 69 6f 6e 2d 6c 73 74 29 29 29 0a 09 action-lst)))..
7610: 09 3b 3b 20 28 65 72 72 3a 6c 6f 67 20 22 74 61 .;; (err:log "ta
7620: 72 67 2d 70 61 67 65 3d 22 20 74 61 72 67 2d 70 rg-page=" targ-p
7630: 61 67 65 20 22 20 70 72 6f 63 2d 6e 61 6d 65 3d age " proc-name=
7640: 22 20 70 72 6f 63 2d 6e 61 6d 65 20 22 20 74 61 " proc-name " ta
7650: 72 67 2d 61 63 74 69 6f 6e 3d 22 20 74 61 72 67 rg-action=" targ
7660: 2d 61 63 74 69 6f 6e 29 0a 0a 09 09 3b 3b 20 63 -action)....;; c
7670: 61 6c 6c 20 68 65 72 65 20 6f 6e 6c 79 20 69 66 all here only if
7680: 20 6e 65 76 65 72 20 63 61 6c 6c 65 64 20 62 65 never called be
7690: 66 6f 72 65 0a 09 09 28 69 66 20 28 73 65 73 73 fore...(if (sess
76a0: 69 6f 6e 3a 6e 65 76 65 72 2d 63 61 6c 6c 65 64 ion:never-called
76b0: 2d 70 61 67 65 3f 20 73 65 6c 66 20 74 61 72 67 -page? self targ
76c0: 2d 70 61 67 65 29 0a 09 09 20 20 20 20 28 73 65 -page)... (se
76d0: 73 73 69 6f 6e 3a 63 61 6c 6c 2d 70 61 72 74 73 ssion:call-parts
76e0: 20 73 65 6c 66 20 74 61 72 67 2d 70 61 67 65 20 self targ-page
76f0: 27 63 6f 6e 74 72 6f 6c 29 29 0a 09 09 3b 3b 20 'control))...;;
7700: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7710: 20 20 20 70 72 6f 63 20 20 20 20 20 20 20 20 20 proc
7720: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7730: 61 63 74 69 6f 6e 20 20 20 20 0a 0a 09 09 28 69 action ....(i
7740: 66 20 23 74 20 3b 3b 20 73 65 74 20 74 6f 20 23 f #t ;; set to #
7750: 74 20 74 6f 20 73 65 65 20 62 65 74 74 65 72 20 t to see better
7760: 65 72 72 6f 72 20 6d 65 73 73 61 67 65 73 20 64 error messages d
7770: 75 72 69 6e 67 20 64 65 62 75 67 67 69 6e 20 3a uring debuggin :
7780: 2d 29 0a 09 09 20 20 20 20 28 28 65 76 61 6c 20 -)... ((eval
7790: 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 (string->symbol
77a0: 70 72 6f 63 2d 6e 61 6d 65 29 29 20 74 61 72 67 proc-name)) targ
77b0: 2d 61 63 74 69 6f 6e 29 20 3b 3b 20 75 6e 73 61 -action) ;; unsa
77c0: 66 65 20 65 78 65 63 75 74 69 6f 6e 0a 09 09 20 fe execution...
77d0: 20 20 20 28 63 6f 6e 64 69 74 69 6f 6e 2d 63 61 (condition-ca
77e0: 73 65 20 28 28 65 76 61 6c 20 28 73 74 72 69 6e se ((eval (strin
77f0: 67 2d 3e 73 79 6d 62 6f 6c 20 70 72 6f 63 2d 6e g->symbol proc-n
7800: 61 6d 65 29 29 20 74 61 72 67 2d 61 63 74 69 6f ame)) targ-actio
7810: 6e 29 0a 09 09 09 09 20 20 20 20 28 28 65 78 6e n)..... ((exn
7820: 20 66 69 6c 65 29 20 28 73 3a 6c 6f 67 20 22 66 file) (s:log "f
7830: 69 6c 65 20 65 72 72 6f 72 22 29 29 0a 09 09 09 ile error"))....
7840: 09 20 20 20 20 28 28 65 78 6e 20 69 2f 6f 29 20 . ((exn i/o)
7850: 20 28 73 3a 6c 6f 67 20 22 69 2f 6f 20 65 72 72 (s:log "i/o err
7860: 6f 72 22 29 29 0a 09 09 09 09 20 20 20 20 28 28 or"))..... ((
7870: 65 78 6e 20 29 20 20 20 20 20 28 73 3a 6c 6f 67 exn ) (s:log
7880: 20 22 41 63 74 69 6f 6e 20 6e 6f 74 20 69 6d 70 "Action not imp
7890: 6c 65 6d 65 6e 74 65 64 3a 20 22 20 70 72 6f 63 lemented: " proc
78a0: 2d 6e 61 6d 65 20 22 20 61 63 74 69 6f 6e 3a 20 -name " action:
78b0: 22 20 74 61 72 67 2d 61 63 74 69 6f 6e 29 29 0a " targ-action)).
78c0: 09 09 09 09 20 20 20 20 28 76 61 72 20 28 29 20 .... (var ()
78d0: 20 20 20 20 28 73 3a 6c 6f 67 20 22 55 6e 6b 6e (s:log "Unkn
78e0: 6f 77 6e 20 45 72 72 6f 72 22 29 29 29 29 29 29 own Error"))))))
78f0: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 ))))..(define (s
7900: 65 73 73 69 6f 6e 3a 6e 65 76 65 72 2d 63 61 6c ession:never-cal
7910: 6c 65 64 2d 70 61 67 65 3f 20 73 65 6c 66 20 70 led-page? self p
7920: 61 67 65 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a age). (session:
7930: 6c 6f 67 20 73 65 6c 66 20 22 43 68 65 63 6b 69 log self "Checki
7940: 6e 67 20 66 6f 72 20 70 61 67 65 3a 20 22 20 70 ng for page: " p
7950: 61 67 65 29 0a 20 20 28 6e 6f 74 20 28 6d 65 6d age). (not (mem
7960: 62 65 72 20 70 61 67 65 20 28 73 64 61 74 2d 67 ber page (sdat-g
7970: 65 74 2d 73 65 65 6e 2d 70 61 67 65 73 20 73 65 et-seen-pages se
7980: 6c 66 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 lf))))..(define
7990: 28 73 65 73 73 69 6f 6e 3a 73 65 74 2d 63 61 6c (session:set-cal
79a0: 6c 65 64 21 20 73 65 6c 66 20 70 61 67 65 29 0a led! self page).
79b0: 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 65 6e (sdat-set-seen
79c0: 2d 70 61 67 65 73 21 20 73 65 6c 66 20 28 63 6f -pages! self (co
79d0: 6e 73 20 70 61 67 65 20 28 73 64 61 74 2d 67 65 ns page (sdat-ge
79e0: 74 2d 73 65 65 6e 2d 70 61 67 65 73 20 73 65 6c t-seen-pages sel
79f0: 66 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d f))))..;;=======
7a00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7a10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7a20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7a30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
7a40: 3b 3b 20 41 6c 74 65 72 6e 61 74 69 76 65 20 64 ;; Alternative d
7a50: 61 74 61 20 74 79 70 65 20 64 65 6c 69 76 65 72 ata type deliver
7a60: 79 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d y.;;============
7a70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7a80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7a90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7aa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 ==========..(def
7ab0: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 61 6c 74 ine (session:alt
7ac0: 2d 6f 75 74 20 73 65 6c 66 29 0a 20 20 28 6c 65 -out self). (le
7ad0: 74 20 28 28 64 61 74 20 28 73 64 61 74 2d 67 65 t ((dat (sdat-ge
7ae0: 74 2d 61 6c 74 2d 70 61 67 65 2d 64 61 74 20 73 t-alt-page-dat s
7af0: 65 6c 66 29 29 29 0a 20 20 20 20 3b 3b 20 28 73 elf))). ;; (s
7b00: 3a 6c 6f 67 20 22 64 61 74 20 69 73 3a 20 22 20 :log "dat is: "
7b10: 64 61 74 29 0a 20 20 20 20 3b 3b 20 28 70 72 69 dat). ;; (pri
7b20: 6e 74 20 22 48 54 54 50 2f 31 2e 31 20 32 30 30 nt "HTTP/1.1 200
7b30: 20 4f 4b 22 29 0a 20 20 20 20 28 70 72 69 6e 74 OK"). (print
7b40: 20 22 44 61 74 65 3a 20 22 20 28 74 69 6d 65 2d "Date: " (time-
7b50: 3e 73 74 72 69 6e 67 20 28 73 65 63 6f 6e 64 73 >string (seconds
7b60: 2d 3e 75 74 63 2d 74 69 6d 65 20 28 63 75 72 72 ->utc-time (curr
7b70: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 29 0a ent-seconds)))).
7b80: 20 20 20 20 28 70 72 69 6e 74 20 22 43 6f 6e 74 (print "Cont
7b90: 65 6e 74 2d 54 79 70 65 3a 20 22 20 28 73 64 61 ent-Type: " (sda
7ba0: 74 2d 67 65 74 2d 63 6f 6e 74 65 6e 74 2d 74 79 t-get-content-ty
7bb0: 70 65 20 73 65 6c 66 29 29 0a 20 20 20 20 28 70 pe self)). (p
7bc0: 72 69 6e 74 20 22 41 63 63 65 70 74 2d 52 61 6e rint "Accept-Ran
7bd0: 67 65 73 3a 20 62 79 74 65 73 22 29 0a 20 20 20 ges: bytes").
7be0: 20 28 70 72 69 6e 74 20 22 43 6f 6e 74 65 6e 74 (print "Content
7bf0: 2d 4c 65 6e 67 74 68 3a 20 22 20 28 69 66 20 28 -Length: " (if (
7c00: 62 6c 6f 62 3f 20 64 61 74 29 0a 09 09 09 09 20 blob? dat).....
7c10: 20 28 62 6c 6f 62 2d 73 69 7a 65 20 64 61 74 29 (blob-size dat)
7c20: 0a 09 09 09 09 20 20 30 29 29 0a 20 20 20 20 28 ..... 0)). (
7c30: 70 72 69 6e 74 20 22 4b 65 65 70 2d 41 6c 69 76 print "Keep-Aliv
7c40: 65 3a 20 74 69 6d 65 6f 75 74 3d 31 35 2c 20 6d e: timeout=15, m
7c50: 61 78 3d 31 30 30 22 29 0a 20 20 20 20 28 70 72 ax=100"). (pr
7c60: 69 6e 74 20 22 43 6f 6e 6e 65 63 74 69 6f 6e 3a int "Connection:
7c70: 20 4b 65 65 70 2d 41 6c 69 76 65 22 29 0a 20 20 Keep-Alive").
7c80: 20 20 28 70 72 69 6e 74 20 22 22 29 0a 20 20 20 (print "").
7c90: 20 28 77 72 69 74 65 2d 73 74 72 69 6e 67 20 28 (write-string (
7ca0: 62 6c 6f 62 2d 3e 73 74 72 69 6e 67 20 64 61 74 blob->string dat
7cb0: 29 20 23 66 20 28 63 75 72 72 65 6e 74 2d 6f 75 ) #f (current-ou
7cc0: 74 70 75 74 2d 70 6f 72 74 29 29 29 29 0a tput-port)))).