Artifact
65e2ea7eb0c8349e045cc0d4dde59e37307b34b1:
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 75 73 65 20 28 70 72 65 66 69 78 20 )).(use (prefix
0170: 64 62 69 20 64 62 69 3a 29 29 0a 28 72 65 71 75 dbi dbi:)).(requ
0180: 69 72 65 2d 65 78 74 65 6e 73 69 6f 6e 20 72 65 ire-extension re
0190: 67 65 78 29 0a 28 64 65 63 6c 61 72 65 20 28 75 gex).(declare (u
01a0: 73 65 73 20 63 6f 6f 6b 69 65 29 29 0a 0a 3b 3b ses cookie))..;;
01b0: 20 73 65 73 73 69 6f 6e 73 20 74 61 62 6c 65 0a sessions table.
01c0: 3b 3b 20 69 64 20 73 65 73 73 69 6f 6e 5f 69 64 ;; id session_id
01d0: 20 73 65 73 73 69 6f 6e 5f 6b 65 79 0a 3b 3b 20 session_key.;;
01e0: 63 72 65 61 74 65 20 74 61 62 6c 65 20 73 65 73 create table ses
01f0: 73 69 6f 6e 73 20 28 69 64 20 73 65 72 69 61 6c sions (id serial
0200: 20 6e 6f 74 20 6e 75 6c 6c 2c 73 65 73 73 69 6f not null,sessio
0210: 6e 2d 6b 65 79 20 74 65 78 74 29 3b 0a 0a 3b 3b n-key text);..;;
0220: 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 74 61 session_vars ta
0230: 62 6c 65 0a 3b 3b 20 69 64 20 73 65 73 73 69 6f ble.;; id sessio
0240: 6e 5f 69 64 20 70 61 67 65 5f 69 64 20 6b 65 79 n_id page_id key
0250: 20 76 61 6c 75 65 0a 3b 3b 20 63 72 65 61 74 65 value.;; create
0260: 20 74 61 62 6c 65 20 73 65 73 73 69 6f 6e 5f 76 table session_v
0270: 61 72 73 20 28 69 64 20 73 65 72 69 61 6c 20 6e ars (id serial n
0280: 6f 74 20 6e 75 6c 6c 2c 73 65 73 73 69 6f 6e 5f ot null,session_
0290: 69 64 20 69 6e 74 65 67 65 72 2c 70 61 67 65 20 id integer,page
02a0: 74 65 78 74 2c 6b 65 79 20 74 65 78 74 2c 76 61 text,key text,va
02b0: 6c 75 65 20 74 65 78 74 29 3b 0a 0a 3b 3b 20 54 lue text);..;; T
02c0: 4f 44 4f 0a 3b 3b 20 20 43 6f 6e 63 65 70 74 20 ODO.;; Concept
02d0: 6f 66 20 6f 72 64 65 72 20 6e 75 6d 20 69 6e 63 of order num inc
02e0: 72 65 6d 65 6e 74 65 64 20 77 69 74 68 20 65 61 remented with ea
02f0: 63 68 20 70 61 67 65 20 61 63 63 65 73 73 0a 3b ch page access.;
0300: 3b 20 20 20 20 20 69 66 20 61 20 62 72 61 6e 63 ; if a branc
0310: 68 20 69 73 20 74 61 6b 65 6e 20 74 68 65 6e 20 h is taken then
0320: 61 20 6e 65 77 20 73 65 73 73 69 6f 6e 20 77 6f a new session wo
0330: 75 6c 64 20 6e 65 65 64 20 74 6f 20 62 65 20 63 uld need to be c
0340: 72 65 61 74 65 64 0a 3b 3b 0a 0a 3b 3b 20 6d 61 reated.;;..;; ma
0350: 6b 65 2d 76 65 63 74 6f 72 2d 72 65 63 6f 72 64 ke-vector-record
0360: 20 73 65 73 73 69 6f 6e 20 73 65 73 73 69 6f 6e session session
0370: 20 64 62 74 79 70 65 20 64 62 69 6e 69 74 20 63 dbtype dbinit c
0380: 6f 6e 6e 20 70 61 72 61 6d 73 20 70 61 74 68 2d onn params path-
0390: 70 61 72 61 6d 73 20 73 65 73 73 69 6f 6e 2d 6b params session-k
03a0: 65 79 20 73 65 73 73 69 6f 6e 2d 69 64 20 64 6f ey session-id do
03b0: 6d 61 69 6e 20 74 6f 70 70 61 67 65 20 70 61 67 main toppage pag
03c0: 65 20 63 75 72 72 2d 70 61 67 65 20 63 6f 6e 74 e curr-page cont
03d0: 65 6e 74 2d 74 79 70 65 20 70 61 67 65 2d 74 79 ent-type page-ty
03e0: 70 65 20 73 72 6f 6f 74 20 74 77 69 6b 69 64 69 pe sroot twikidi
03f0: 72 20 70 61 67 65 64 61 74 20 61 6c 74 2d 70 61 r pagedat alt-pa
0400: 67 65 2d 64 61 74 20 70 61 67 65 76 61 72 73 20 ge-dat pagevars
0410: 70 61 67 65 76 61 72 73 2d 62 65 66 6f 72 65 20 pagevars-before
0420: 73 65 73 73 69 6f 6e 76 61 72 73 20 73 65 73 73 sessionvars sess
0430: 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 20 67 ionvars-before g
0440: 6c 6f 62 61 6c 76 61 72 73 20 67 6c 6f 62 61 6c lobalvars global
0450: 76 61 72 73 2d 62 65 66 6f 72 65 20 6c 6f 67 70 vars-before logp
0460: 74 20 66 6f 72 6d 64 61 74 20 72 65 71 75 65 73 t formdat reques
0470: 74 2d 6d 65 74 68 6f 64 20 73 65 73 73 69 6f 6e t-method session
0480: 2d 63 6f 6f 6b 69 65 20 63 75 72 72 2d 65 72 72 -cookie curr-err
0490: 20 6c 6f 67 2d 70 6f 72 74 20 6c 6f 67 66 69 6c log-port logfil
04a0: 65 20 73 65 65 6e 2d 70 61 67 65 73 20 70 61 67 e seen-pages pag
04b0: 65 2d 64 69 72 2d 73 74 79 6c 65 20 64 65 62 75 e-dir-style debu
04c0: 67 6d 6f 64 65 0a 28 64 65 66 69 6e 65 20 28 6d gmode.(define (m
04d0: 61 6b 65 2d 73 64 61 74 29 28 6d 61 6b 65 2d 76 ake-sdat)(make-v
04e0: 65 63 74 6f 72 20 33 35 29 29 0a 28 64 65 66 69 ector 35)).(defi
04f0: 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 64 62 74 ne (sdat-get-dbt
0500: 79 70 65 20 20 20 20 20 20 20 20 20 20 20 20 20 ype
0510: 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f vec) (vecto
0520: 72 2d 72 65 66 20 20 76 65 63 20 30 29 29 0a 28 r-ref vec 0)).(
0530: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 define (sdat-get
0540: 2d 64 62 69 6e 69 74 20 20 20 20 20 20 20 20 20 -dbinit
0550: 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 vec) (v
0560: 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 31 ector-ref vec 1
0570: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
0580: 2d 67 65 74 2d 63 6f 6e 6e 20 20 20 20 20 20 20 -get-conn
0590: 20 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 vec)
05a0: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 (vector-ref v
05b0: 65 63 20 32 29 29 0a 28 64 65 66 69 6e 65 20 28 ec 2)).(define (
05c0: 73 64 61 74 2d 67 65 74 2d 70 67 63 6f 6e 6e 20 sdat-get-pgconn
05d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 ve
05e0: 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 c) (vector-re
05f0: 66 20 28 76 65 63 74 6f 72 2d 72 65 66 20 76 65 f (vector-ref ve
0600: 63 20 32 29 20 31 29 29 0a 28 64 65 66 69 6e 65 c 2) 1)).(define
0610: 20 28 73 64 61 74 2d 67 65 74 2d 70 61 72 61 6d (sdat-get-param
0620: 73 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 s
0630: 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d vec) (vector-
0640: 72 65 66 20 20 76 65 63 20 33 29 29 0a 28 64 65 ref vec 3)).(de
0650: 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 70 fine (sdat-get-p
0660: 61 74 68 2d 70 61 72 61 6d 73 20 20 20 20 20 20 ath-params
0670: 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 vec) (vec
0680: 74 6f 72 2d 72 65 66 20 20 76 65 63 20 34 29 29 tor-ref vec 4))
0690: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 .(define (sdat-g
06a0: 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 20 et-session-key
06b0: 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 vec)
06c0: 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 (vector-ref vec
06d0: 20 35 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 5)).(define (sd
06e0: 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 2d 69 at-get-session-i
06f0: 64 20 20 20 20 20 20 20 20 20 20 20 76 65 63 29 d vec)
0700: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
0710: 20 76 65 63 20 36 29 29 0a 28 64 65 66 69 6e 65 vec 6)).(define
0720: 20 28 73 64 61 74 2d 67 65 74 2d 64 6f 6d 61 69 (sdat-get-domai
0730: 6e 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 n
0740: 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d vec) (vector-
0750: 72 65 66 20 20 76 65 63 20 37 29 29 0a 28 64 65 ref vec 7)).(de
0760: 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 74 fine (sdat-get-t
0770: 6f 70 70 61 67 65 20 20 20 20 20 20 20 20 20 20 oppage
0780: 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 vec) (vec
0790: 74 6f 72 2d 72 65 66 20 20 76 65 63 20 38 29 29 tor-ref vec 8))
07a0: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 .(define (sdat-g
07b0: 65 74 2d 70 61 67 65 20 20 20 20 20 20 20 20 20 et-page
07c0: 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 vec)
07d0: 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 (vector-ref vec
07e0: 20 39 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 9)).(define (sd
07f0: 61 74 2d 67 65 74 2d 63 75 72 72 2d 70 61 67 65 at-get-curr-page
0800: 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 29 vec)
0810: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
0820: 20 76 65 63 20 31 30 29 29 0a 28 64 65 66 69 6e vec 10)).(defin
0830: 65 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 74 e (sdat-get-cont
0840: 65 6e 74 2d 74 79 70 65 20 20 20 20 20 20 20 20 ent-type
0850: 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 vec) (vector
0860: 2d 72 65 66 20 20 76 65 63 20 31 31 29 29 0a 28 -ref vec 11)).(
0870: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 define (sdat-get
0880: 2d 70 61 67 65 2d 74 79 70 65 20 20 20 20 20 20 -page-type
0890: 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 vec) (v
08a0: 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 31 ector-ref vec 1
08b0: 32 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 2)).(define (sda
08c0: 74 2d 67 65 74 2d 73 72 6f 6f 74 20 20 20 20 20 t-get-sroot
08d0: 20 20 20 20 20 20 20 20 20 20 20 76 65 63 29 20 vec)
08e0: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 (vector-ref
08f0: 76 65 63 20 31 33 29 29 0a 28 64 65 66 69 6e 65 vec 13)).(define
0900: 20 28 73 64 61 74 2d 67 65 74 2d 74 77 69 6b 69 (sdat-get-twiki
0910: 64 69 72 20 20 20 20 20 20 20 20 20 20 20 20 20 dir
0920: 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d vec) (vector-
0930: 72 65 66 20 20 76 65 63 20 31 34 29 29 0a 28 64 ref vec 14)).(d
0940: 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d efine (sdat-get-
0950: 70 61 67 65 64 61 74 20 20 20 20 20 20 20 20 20 pagedat
0960: 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 vec) (ve
0970: 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 31 35 ctor-ref vec 15
0980: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
0990: 2d 67 65 74 2d 61 6c 74 2d 70 61 67 65 2d 64 61 -get-alt-page-da
09a0: 74 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 t vec)
09b0: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 (vector-ref v
09c0: 65 63 20 31 36 29 29 0a 28 64 65 66 69 6e 65 20 ec 16)).(define
09d0: 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 76 61 (sdat-get-pageva
09e0: 72 73 20 20 20 20 20 20 20 20 20 20 20 20 20 76 rs v
09f0: 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 ec) (vector-r
0a00: 65 66 20 20 76 65 63 20 31 37 29 29 0a 28 64 65 ef vec 17)).(de
0a10: 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 70 fine (sdat-get-p
0a20: 61 67 65 76 61 72 73 2d 62 65 66 6f 72 65 20 20 agevars-before
0a30: 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 vec) (vec
0a40: 74 6f 72 2d 72 65 66 20 20 76 65 63 20 31 38 29 tor-ref vec 18)
0a50: 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d ).(define (sdat-
0a60: 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 20 get-sessionvars
0a70: 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 vec)
0a80: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 (vector-ref ve
0a90: 63 20 31 39 29 29 0a 28 64 65 66 69 6e 65 20 28 c 19)).(define (
0aa0: 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e sdat-get-session
0ab0: 76 61 72 73 2d 62 65 66 6f 72 65 20 20 20 76 65 vars-before ve
0ac0: 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 c) (vector-re
0ad0: 66 20 20 76 65 63 20 32 30 29 29 0a 28 64 65 66 f vec 20)).(def
0ae0: 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 67 6c ine (sdat-get-gl
0af0: 6f 62 61 6c 76 61 72 73 20 20 20 20 20 20 20 20 obalvars
0b00: 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 vec) (vect
0b10: 6f 72 2d 72 65 66 20 20 76 65 63 20 32 31 29 29 or-ref vec 21))
0b20: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 .(define (sdat-g
0b30: 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 2d 62 65 et-globalvars-be
0b40: 66 6f 72 65 20 20 20 20 76 65 63 29 20 20 20 20 fore vec)
0b50: 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 (vector-ref vec
0b60: 20 32 32 29 29 0a 28 64 65 66 69 6e 65 20 28 73 22)).(define (s
0b70: 64 61 74 2d 67 65 74 2d 6c 6f 67 70 74 20 20 20 dat-get-logpt
0b80: 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 vec
0b90: 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 ) (vector-ref
0ba0: 20 20 76 65 63 20 32 33 29 29 0a 28 64 65 66 69 vec 23)).(defi
0bb0: 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 66 6f 72 ne (sdat-get-for
0bc0: 6d 64 61 74 20 20 20 20 20 20 20 20 20 20 20 20 mdat
0bd0: 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f vec) (vecto
0be0: 72 2d 72 65 66 20 20 76 65 63 20 32 34 29 29 0a r-ref vec 24)).
0bf0: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 (define (sdat-ge
0c00: 74 2d 72 65 71 75 65 73 74 2d 6d 65 74 68 6f 64 t-request-method
0c10: 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 vec) (
0c20: 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 vector-ref vec
0c30: 32 35 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 25)).(define (sd
0c40: 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 2d 63 at-get-session-c
0c50: 6f 6f 6b 69 65 20 20 20 20 20 20 20 76 65 63 29 ookie vec)
0c60: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
0c70: 20 76 65 63 20 32 36 29 29 0a 28 64 65 66 69 6e vec 26)).(defin
0c80: 65 20 28 73 64 61 74 2d 67 65 74 2d 63 75 72 72 e (sdat-get-curr
0c90: 2d 65 72 72 20 20 20 20 20 20 20 20 20 20 20 20 -err
0ca0: 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 vec) (vector
0cb0: 2d 72 65 66 20 20 76 65 63 20 32 37 29 29 0a 28 -ref vec 27)).(
0cc0: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 define (sdat-get
0cd0: 2d 6c 6f 67 2d 70 6f 72 74 20 20 20 20 20 20 20 -log-port
0ce0: 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 vec) (v
0cf0: 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 32 ector-ref vec 2
0d00: 38 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 8)).(define (sda
0d10: 74 2d 67 65 74 2d 6c 6f 67 66 69 6c 65 20 20 20 t-get-logfile
0d20: 20 20 20 20 20 20 20 20 20 20 20 76 65 63 29 20 vec)
0d30: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 (vector-ref
0d40: 76 65 63 20 32 39 29 29 0a 28 64 65 66 69 6e 65 vec 29)).(define
0d50: 20 28 73 64 61 74 2d 67 65 74 2d 73 65 65 6e 2d (sdat-get-seen-
0d60: 70 61 67 65 73 20 20 20 20 20 20 20 20 20 20 20 pages
0d70: 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d vec) (vector-
0d80: 72 65 66 20 20 76 65 63 20 33 30 29 29 0a 28 64 ref vec 30)).(d
0d90: 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d efine (sdat-get-
0da0: 70 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 20 20 page-dir-style
0db0: 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 vec) (ve
0dc0: 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 33 31 ctor-ref vec 31
0dd0: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
0de0: 2d 67 65 74 2d 64 65 62 75 67 6d 6f 64 65 20 20 -get-debugmode
0df0: 20 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 vec)
0e00: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 (vector-ref v
0e10: 65 63 20 33 32 29 29 0a 28 64 65 66 69 6e 65 20 ec 32)).(define
0e20: 28 73 64 61 74 2d 67 65 74 2d 73 68 61 72 65 64 (sdat-get-shared
0e30: 2d 68 61 73 68 20 20 20 20 20 20 20 20 20 20 76 -hash v
0e40: 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 ec) (vector-r
0e50: 65 66 20 20 76 65 63 20 33 33 29 29 0a 28 64 65 ef vec 33)).(de
0e60: 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 73 fine (sdat-get-s
0e70: 63 72 69 70 74 20 20 20 20 20 20 20 20 20 20 20 cript
0e80: 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 vec) (vec
0e90: 74 6f 72 2d 72 65 66 20 20 76 65 63 20 33 34 29 tor-ref vec 34)
0ea0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 )..(define (sess
0eb0: 69 6f 6e 3a 67 65 74 2d 73 68 61 72 65 64 20 76 ion:get-shared v
0ec0: 65 63 20 76 61 72 6e 61 6d 65 29 0a 20 20 28 68 ec varname). (h
0ed0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
0ee0: 66 61 75 6c 74 20 28 76 65 63 74 6f 72 2d 72 65 fault (vector-re
0ef0: 66 20 76 65 63 20 33 33 29 20 76 61 72 6e 61 6d f vec 33) varnam
0f00: 65 20 23 66 29 29 0a 0a 28 64 65 66 69 6e 65 20 e #f))..(define
0f10: 28 73 64 61 74 2d 73 65 74 2d 64 62 74 79 70 65 (sdat-set-dbtype
0f20: 21 20 20 20 20 20 20 20 20 20 20 20 20 20 20 76 ! v
0f30: 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 ec val)(vector-s
0f40: 65 74 21 20 76 65 63 20 30 20 76 61 6c 29 29 0a et! vec 0 val)).
0f50: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 (define (sdat-se
0f60: 74 2d 64 62 69 6e 69 74 21 20 20 20 20 20 20 20 t-dbinit!
0f70: 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 vec val)(
0f80: 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 vector-set! vec
0f90: 31 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 1 val)).(define
0fa0: 28 73 64 61 74 2d 73 65 74 2d 63 6f 6e 6e 21 20 (sdat-set-conn!
0fb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 76 v
0fc0: 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 ec val)(vector-s
0fd0: 65 74 21 20 76 65 63 20 32 20 76 61 6c 29 29 0a et! vec 2 val)).
0fe0: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 (define (sdat-se
0ff0: 74 2d 70 61 72 61 6d 73 21 20 20 20 20 20 20 20 t-params!
1000: 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 vec val)(
1010: 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 vector-set! vec
1020: 33 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 3 val)).(define
1030: 28 73 64 61 74 2d 73 65 74 2d 70 61 74 68 2d 70 (sdat-set-path-p
1040: 61 72 61 6d 73 21 20 20 20 20 20 20 20 20 20 76 arams! v
1050: 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 ec val)(vector-s
1060: 65 74 21 20 76 65 63 20 34 20 76 61 6c 29 29 0a et! vec 4 val)).
1070: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 (define (sdat-se
1080: 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 21 20 20 t-session-key!
1090: 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 vec val)(
10a0: 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 vector-set! vec
10b0: 35 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 5 val)).(define
10c0: 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f (sdat-set-sessio
10d0: 6e 2d 69 64 21 20 20 20 20 20 20 20 20 20 20 76 n-id! v
10e0: 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 ec val)(vector-s
10f0: 65 74 21 20 76 65 63 20 36 20 76 61 6c 29 29 0a et! vec 6 val)).
1100: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 (define (sdat-se
1110: 74 2d 64 6f 6d 61 69 6e 21 20 20 20 20 20 20 20 t-domain!
1120: 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 vec val)(
1130: 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 vector-set! vec
1140: 37 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 7 val)).(define
1150: 28 73 64 61 74 2d 73 65 74 2d 74 6f 70 70 61 67 (sdat-set-toppag
1160: 65 21 20 20 20 20 20 20 20 20 20 20 20 20 20 76 e! v
1170: 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 ec val)(vector-s
1180: 65 74 21 20 76 65 63 20 38 20 76 61 6c 29 29 0a et! vec 8 val)).
1190: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 (define (sdat-se
11a0: 74 2d 70 61 67 65 21 20 20 20 20 20 20 20 20 20 t-page!
11b0: 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 vec val)(
11c0: 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 vector-set! vec
11d0: 39 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 9 val)).(define
11e0: 28 73 64 61 74 2d 73 65 74 2d 63 75 72 72 2d 70 (sdat-set-curr-p
11f0: 61 67 65 21 20 20 20 20 20 20 20 20 20 20 20 76 age! v
1200: 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 ec val)(vector-s
1210: 65 74 21 20 76 65 63 20 31 30 20 76 61 6c 29 29 et! vec 10 val))
1220: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 .(define (sdat-s
1230: 65 74 2d 63 6f 6e 74 65 6e 74 2d 74 79 70 65 21 et-content-type!
1240: 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 vec val)
1250: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 (vector-set! vec
1260: 20 31 31 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 11 val)).(defin
1270: 65 20 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 e (sdat-set-page
1280: 2d 74 79 70 65 21 20 20 20 20 20 20 20 20 20 20 -type!
1290: 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 vec val)(vector
12a0: 2d 73 65 74 21 20 76 65 63 20 31 32 20 76 61 6c -set! vec 12 val
12b0: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
12c0: 2d 73 65 74 2d 73 72 6f 6f 74 21 20 20 20 20 20 -set-sroot!
12d0: 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 61 vec va
12e0: 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 l)(vector-set! v
12f0: 65 63 20 31 33 20 76 61 6c 29 29 0a 28 64 65 66 ec 13 val)).(def
1300: 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 74 77 ine (sdat-set-tw
1310: 69 6b 69 64 69 72 21 20 20 20 20 20 20 20 20 20 ikidir!
1320: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
1330: 6f 72 2d 73 65 74 21 20 76 65 63 20 31 34 20 76 or-set! vec 14 v
1340: 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 al)).(define (sd
1350: 61 74 2d 73 65 74 2d 70 61 67 65 64 61 74 21 20 at-set-pagedat!
1360: 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 20 vec
1370: 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 val)(vector-set!
1380: 20 76 65 63 20 31 35 20 76 61 6c 29 29 0a 28 64 vec 15 val)).(d
1390: 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d efine (sdat-set-
13a0: 61 6c 74 2d 70 61 67 65 2d 64 61 74 21 20 20 20 alt-page-dat!
13b0: 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 vec val)(ve
13c0: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 31 36 ctor-set! vec 16
13d0: 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 val)).(define (
13e0: 73 64 61 74 2d 73 65 74 2d 70 61 67 65 76 61 72 sdat-set-pagevar
13f0: 73 21 20 20 20 20 20 20 20 20 20 20 20 20 76 65 s! ve
1400: 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 c val)(vector-se
1410: 74 21 20 76 65 63 20 31 37 20 76 61 6c 29 29 0a t! vec 17 val)).
1420: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 (define (sdat-se
1430: 74 2d 70 61 67 65 76 61 72 73 2d 62 65 66 6f 72 t-pagevars-befor
1440: 65 21 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 e! vec val)(
1450: 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 vector-set! vec
1460: 31 38 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 18 val)).(define
1470: 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 (sdat-set-sessi
1480: 6f 6e 76 61 72 73 21 20 20 20 20 20 20 20 20 20 onvars!
1490: 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d vec val)(vector-
14a0: 73 65 74 21 20 76 65 63 20 31 39 20 76 61 6c 29 set! vec 19 val)
14b0: 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d ).(define (sdat-
14c0: 73 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 2d set-sessionvars-
14d0: 62 65 66 6f 72 65 21 20 20 76 65 63 20 76 61 6c before! vec val
14e0: 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 )(vector-set! ve
14f0: 63 20 32 30 20 76 61 6c 29 29 0a 28 64 65 66 69 c 20 val)).(defi
1500: 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 67 6c 6f ne (sdat-set-glo
1510: 62 61 6c 76 61 72 73 21 20 20 20 20 20 20 20 20 balvars!
1520: 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f vec val)(vecto
1530: 72 2d 73 65 74 21 20 76 65 63 20 32 31 20 76 61 r-set! vec 21 va
1540: 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 l)).(define (sda
1550: 74 2d 73 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 t-set-globalvars
1560: 2d 62 65 66 6f 72 65 21 20 20 20 76 65 63 20 76 -before! vec v
1570: 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 al)(vector-set!
1580: 76 65 63 20 32 32 20 76 61 6c 29 29 0a 28 64 65 vec 22 val)).(de
1590: 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 6c fine (sdat-set-l
15a0: 6f 67 70 74 21 20 20 20 20 20 20 20 20 20 20 20 ogpt!
15b0: 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 vec val)(vec
15c0: 74 6f 72 2d 73 65 74 21 20 76 65 63 20 32 33 20 tor-set! vec 23
15d0: 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 val)).(define (s
15e0: 64 61 74 2d 73 65 74 2d 66 6f 72 6d 64 61 74 21 dat-set-formdat!
15f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 vec
1600: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
1610: 21 20 76 65 63 20 32 34 20 76 61 6c 29 29 0a 28 ! vec 24 val)).(
1620: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 define (sdat-set
1630: 2d 72 65 71 75 65 73 74 2d 6d 65 74 68 6f 64 21 -request-method!
1640: 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 vec val)(v
1650: 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 32 ector-set! vec 2
1660: 35 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 5 val)).(define
1670: 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f (sdat-set-sessio
1680: 6e 2d 63 6f 6f 6b 69 65 21 20 20 20 20 20 20 76 n-cookie! v
1690: 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 ec val)(vector-s
16a0: 65 74 21 20 76 65 63 20 32 36 20 76 61 6c 29 29 et! vec 26 val))
16b0: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 .(define (sdat-s
16c0: 65 74 2d 63 75 72 72 2d 65 72 72 21 20 20 20 20 et-curr-err!
16d0: 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 vec val)
16e0: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 (vector-set! vec
16f0: 20 32 37 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 27 val)).(defin
1700: 65 20 28 73 64 61 74 2d 73 65 74 2d 6c 6f 67 2d e (sdat-set-log-
1710: 70 6f 72 74 21 20 20 20 20 20 20 20 20 20 20 20 port!
1720: 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 vec val)(vector
1730: 2d 73 65 74 21 20 76 65 63 20 32 38 20 76 61 6c -set! vec 28 val
1740: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
1750: 2d 73 65 74 2d 6c 6f 67 66 69 6c 65 21 20 20 20 -set-logfile!
1760: 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 61 vec va
1770: 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 l)(vector-set! v
1780: 65 63 20 32 39 20 76 61 6c 29 29 0a 28 64 65 66 ec 29 val)).(def
1790: 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 73 65 ine (sdat-set-se
17a0: 65 6e 2d 70 61 67 65 73 21 20 20 20 20 20 20 20 en-pages!
17b0: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
17c0: 6f 72 2d 73 65 74 21 20 76 65 63 20 33 30 20 76 or-set! vec 30 v
17d0: 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 al)).(define (sd
17e0: 61 74 2d 73 65 74 2d 70 61 67 65 2d 64 69 72 2d at-set-page-dir-
17f0: 73 74 79 6c 65 21 20 20 20 20 20 20 76 65 63 20 style! vec
1800: 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 val)(vector-set!
1810: 20 76 65 63 20 33 31 20 76 61 6c 29 29 0a 28 64 vec 31 val)).(d
1820: 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d efine (sdat-set-
1830: 64 65 62 75 67 6d 6f 64 65 21 20 20 20 20 20 20 debugmode!
1840: 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 vec val)(ve
1850: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 33 32 ctor-set! vec 32
1860: 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 val)).(define (
1870: 73 64 61 74 2d 73 65 74 2d 73 68 61 72 65 64 2d sdat-set-shared-
1880: 68 61 73 68 21 20 20 20 20 20 20 20 20 20 76 65 hash! ve
1890: 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 c val)(vector-se
18a0: 74 21 20 76 65 63 20 33 33 20 76 61 6c 29 29 0a t! vec 33 val)).
18b0: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 (define (sdat-se
18c0: 74 2d 73 63 72 69 70 74 21 20 20 20 20 20 20 20 t-script!
18d0: 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 vec val)(
18e0: 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 vector-set! vec
18f0: 33 34 20 76 61 6c 29 29 0a 0a 28 64 65 66 69 6e 34 val))..(defin
1900: 65 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 2d 73 e (session:set-s
1910: 68 61 72 65 64 21 20 76 65 63 20 76 61 72 6e 61 hared! vec varna
1920: 6d 65 20 76 61 6c 29 0a 20 20 28 68 61 73 68 2d me val). (hash-
1930: 74 61 62 6c 65 2d 73 65 74 21 20 28 76 65 63 74 table-set! (vect
1940: 6f 72 2d 72 65 66 20 76 65 63 20 33 33 29 20 76 or-ref vec 33) v
1950: 61 72 6e 61 6d 65 20 76 61 6c 29 29 0a 0a 3b 3b arname val))..;;
1960: 20 54 68 65 20 67 6c 6f 62 61 6c 20 73 65 73 73 The global sess
1970: 69 6f 6e 0a 28 64 65 66 69 6e 65 20 73 3a 73 65 ion.(define s:se
1980: 73 73 69 6f 6e 20 28 6d 61 6b 65 2d 73 64 61 74 ssion (make-sdat
1990: 29 29 0a 0a 3b 3b 20 53 50 4c 49 54 20 49 4e 54 ))..;; SPLIT INT
19a0: 4f 20 53 54 52 41 49 47 48 54 20 46 4f 52 57 41 O STRAIGHT FORWA
19b0: 52 44 20 49 4e 49 54 20 41 4e 44 20 43 4f 4d 50 RD INIT AND COMP
19c0: 4c 45 58 20 49 4e 49 54 0a 28 64 65 66 69 6e 65 LEX INIT.(define
19d0: 20 28 73 65 73 73 69 6f 6e 3a 69 6e 69 74 69 61 (session:initia
19e0: 6c 69 7a 65 20 73 65 6c 66 29 0a 20 20 28 73 64 lize self). (sd
19f0: 61 74 2d 73 65 74 2d 64 62 74 79 70 65 21 20 73 at-set-dbtype! s
1a00: 65 6c 66 20 20 20 20 20 20 27 70 67 29 0a 20 20 elf 'pg).
1a10: 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 21 20 (sdat-set-page!
1a20: 73 65 6c 66 20 20 20 20 20 20 20 20 22 68 6f 6d self "hom
1a30: 65 22 29 20 20 20 20 20 20 20 20 3b 3b 20 74 68 e") ;; th
1a40: 65 73 65 20 61 72 65 20 64 65 66 61 75 6c 74 73 ese are defaults
1a50: 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 63 75 72 . (sdat-set-cur
1a60: 72 2d 70 61 67 65 21 20 73 65 6c 66 20 20 20 22 r-page! self "
1a70: 68 6f 6d 65 22 29 0a 20 20 28 73 64 61 74 2d 73 home"). (sdat-s
1a80: 65 74 2d 63 6f 6e 74 65 6e 74 2d 74 79 70 65 21 et-content-type!
1a90: 20 73 65 6c 66 20 22 43 6f 6e 74 65 6e 74 2d 74 self "Content-t
1aa0: 79 70 65 3a 20 74 65 78 74 2f 68 74 6d 6c 3b 20 ype: text/html;
1ab0: 63 68 61 72 73 65 74 3d 69 73 6f 2d 38 38 35 39 charset=iso-8859
1ac0: 2d 31 5c 6e 5c 6e 22 29 0a 20 20 28 73 64 61 74 -1\n\n"). (sdat
1ad0: 2d 73 65 74 2d 70 61 67 65 2d 74 79 70 65 21 20 -set-page-type!
1ae0: 73 65 6c 66 20 20 20 27 68 74 6d 6c 29 0a 20 20 self 'html).
1af0: 28 73 64 61 74 2d 73 65 74 2d 74 6f 70 70 61 67 (sdat-set-toppag
1b00: 65 21 20 73 65 6c 66 20 20 20 20 20 22 69 6e 64 e! self "ind
1b10: 65 78 22 29 0a 20 20 28 73 64 61 74 2d 73 65 74 ex"). (sdat-set
1b20: 2d 70 61 72 61 6d 73 21 20 73 65 6c 66 20 20 20 -params! self
1b30: 20 20 20 27 28 29 29 20 20 20 20 20 20 20 20 20 '())
1b40: 20 20 3b 3b 0a 20 20 28 73 64 61 74 2d 73 65 74 ;;. (sdat-set
1b50: 2d 70 61 74 68 2d 70 61 72 61 6d 73 21 20 73 65 -path-params! se
1b60: 6c 66 20 27 28 29 29 0a 20 20 28 73 64 61 74 2d lf '()). (sdat-
1b70: 73 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 21 set-session-key!
1b80: 20 73 65 6c 66 20 23 66 29 0a 20 20 28 73 64 61 self #f). (sda
1b90: 74 2d 73 65 74 2d 70 61 67 65 64 61 74 21 20 73 t-set-pagedat! s
1ba0: 65 6c 66 20 20 20 20 20 27 28 29 29 0a 20 20 28 elf '()). (
1bb0: 73 64 61 74 2d 73 65 74 2d 61 6c 74 2d 70 61 67 sdat-set-alt-pag
1bc0: 65 2d 64 61 74 21 20 73 65 6c 66 20 23 66 29 0a e-dat! self #f).
1bd0: 20 20 28 73 64 61 74 2d 73 65 74 2d 73 72 6f 6f (sdat-set-sroo
1be0: 74 21 20 73 65 6c 66 20 20 20 20 20 20 20 22 2e t! self ".
1bf0: 2f 22 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d /"). (sdat-set-
1c00: 73 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 21 20 session-cookie!
1c10: 73 65 6c 66 20 23 66 29 0a 20 20 28 73 64 61 74 self #f). (sdat
1c20: 2d 73 65 74 2d 63 75 72 72 2d 65 72 72 21 20 73 -set-curr-err! s
1c30: 65 6c 66 20 23 66 29 0a 20 20 28 73 64 61 74 2d elf #f). (sdat-
1c40: 73 65 74 2d 6c 6f 67 2d 70 6f 72 74 21 20 73 65 set-log-port! se
1c50: 6c 66 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f lf (current-erro
1c60: 72 2d 70 6f 72 74 29 29 0a 20 20 28 73 64 61 74 r-port)). (sdat
1c70: 2d 73 65 74 2d 73 65 65 6e 2d 70 61 67 65 73 21 -set-seen-pages!
1c80: 20 73 65 6c 66 20 27 28 29 29 0a 20 20 28 73 64 self '()). (sd
1c90: 61 74 2d 73 65 74 2d 70 61 67 65 2d 64 69 72 2d at-set-page-dir-
1ca0: 73 74 79 6c 65 21 20 73 65 6c 66 20 23 74 29 20 style! self #t)
1cb0: 3b 3b 20 23 74 20 3a 20 70 61 67 65 73 2f 3c 70 ;; #t : pages/<p
1cc0: 61 67 65 6e 61 6d 65 3e 5f 28 76 69 65 77 7c 63 agename>_(view|c
1cd0: 6e 74 6c 29 2e 73 63 6d 0a 20 20 20 20 20 20 20 ntl).scm.
1ce0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1cf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
1d00: 3b 20 23 66 20 3a 20 70 61 67 65 73 2f 3c 70 61 ; #f : pages/<pa
1d10: 67 65 6e 61 6d 65 3e 2f 28 76 69 65 77 7c 63 6f gename>/(view|co
1d20: 6e 74 72 6f 6c 29 2e 73 63 6d 20 0a 20 20 28 73 ntrol).scm . (s
1d30: 64 61 74 2d 73 65 74 2d 64 65 62 75 67 6d 6f 64 dat-set-debugmod
1d40: 65 21 20 20 20 20 20 20 20 20 20 20 73 65 6c 66 e! self
1d50: 20 23 66 29 0a 20 20 09 09 09 20 20 20 20 20 0a #f). ... .
1d60: 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 (sdat-set-page
1d70: 76 61 72 73 21 20 20 20 20 20 20 20 20 20 20 20 vars!
1d80: 73 65 6c 66 20 28 6d 61 6b 65 2d 68 61 73 68 2d self (make-hash-
1d90: 74 61 62 6c 65 29 29 0a 20 20 28 73 64 61 74 2d table)). (sdat-
1da0: 73 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 21 set-sessionvars!
1db0: 20 20 20 20 20 20 20 20 73 65 6c 66 20 28 6d 61 self (ma
1dc0: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
1dd0: 20 20 28 73 64 61 74 2d 73 65 74 2d 67 6c 6f 62 (sdat-set-glob
1de0: 61 6c 76 61 72 73 21 20 20 20 20 20 20 20 20 20 alvars!
1df0: 73 65 6c 66 20 28 6d 61 6b 65 2d 68 61 73 68 2d self (make-hash-
1e00: 74 61 62 6c 65 29 29 0a 20 20 28 73 64 61 74 2d table)). (sdat-
1e10: 73 65 74 2d 70 61 67 65 76 61 72 73 2d 62 65 66 set-pagevars-bef
1e20: 6f 72 65 21 20 20 20 20 73 65 6c 66 20 28 6d 61 ore! self (ma
1e30: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
1e40: 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 (sdat-set-sess
1e50: 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 21 20 ionvars-before!
1e60: 73 65 6c 66 20 28 6d 61 6b 65 2d 68 61 73 68 2d self (make-hash-
1e70: 74 61 62 6c 65 29 29 0a 20 20 28 73 64 61 74 2d table)). (sdat-
1e80: 73 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 2d 62 set-globalvars-b
1e90: 65 66 6f 72 65 21 20 20 73 65 6c 66 20 28 6d 61 efore! self (ma
1ea0: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
1eb0: 20 20 28 73 64 61 74 2d 73 65 74 2d 64 6f 6d 61 (sdat-set-doma
1ec0: 69 6e 21 20 20 20 20 20 20 20 20 20 20 20 20 20 in!
1ed0: 73 65 6c 66 20 22 6c 6f 63 61 68 6f 73 74 22 29 self "locahost")
1ee0: 20 20 20 3b 3b 20 65 6e 64 20 6f 66 20 64 65 66 ;; end of def
1ef0: 61 75 6c 74 73 0a 20 20 28 73 64 61 74 2d 73 65 aults. (sdat-se
1f00: 74 2d 73 63 72 69 70 74 21 20 20 20 20 20 20 20 t-script!
1f10: 20 20 20 20 20 20 73 65 6c 66 20 23 66 29 0a 20 self #f).
1f20: 20 28 6c 65 74 2a 20 28 28 72 61 77 63 6f 6e 66 (let* ((rawconf
1f30: 69 67 64 61 74 20 28 73 65 73 73 69 6f 6e 3a 72 igdat (session:r
1f40: 65 61 64 2d 63 6f 6e 66 69 67 20 73 65 6c 66 29 ead-config self)
1f50: 29 0a 09 20 28 63 6f 6e 66 69 67 64 61 74 20 28 ).. (configdat (
1f60: 69 66 20 72 61 77 63 6f 6e 66 69 67 64 61 74 20 if rawconfigdat
1f70: 28 65 76 61 6c 20 72 61 77 63 6f 6e 66 69 67 64 (eval rawconfigd
1f80: 61 74 29 20 27 28 29 29 29 0a 09 20 28 73 72 6f at) '())).. (sro
1f90: 6f 74 20 20 20 20 20 28 73 3a 66 69 6e 64 2d 70 ot (s:find-p
1fa0: 61 72 61 6d 20 27 73 72 6f 6f 74 20 20 20 20 63 aram 'sroot c
1fb0: 6f 6e 66 69 67 64 61 74 29 29 0a 09 20 28 6c 6f onfigdat)).. (lo
1fc0: 67 66 69 6c 65 20 20 20 28 73 3a 66 69 6e 64 2d gfile (s:find-
1fd0: 70 61 72 61 6d 20 27 6c 6f 67 66 69 6c 65 20 20 param 'logfile
1fe0: 63 6f 6e 66 69 67 64 61 74 29 29 0a 09 20 28 64 configdat)).. (d
1ff0: 62 74 79 70 65 20 20 20 20 28 73 3a 66 69 6e 64 btype (s:find
2000: 2d 70 61 72 61 6d 20 27 64 62 74 79 70 65 20 20 -param 'dbtype
2010: 20 63 6f 6e 66 69 67 64 61 74 29 29 0a 09 20 28 configdat)).. (
2020: 64 62 69 6e 69 74 20 20 20 20 28 73 3a 66 69 6e dbinit (s:fin
2030: 64 2d 70 61 72 61 6d 20 27 64 62 69 6e 69 74 20 d-param 'dbinit
2040: 20 20 63 6f 6e 66 69 67 64 61 74 29 29 0a 09 20 configdat))..
2050: 28 64 6f 6d 61 69 6e 20 20 20 20 28 73 3a 66 69 (domain (s:fi
2060: 6e 64 2d 70 61 72 61 6d 20 27 64 6f 6d 61 69 6e nd-param 'domain
2070: 20 20 20 63 6f 6e 66 69 67 64 61 74 29 29 0a 09 configdat))..
2080: 20 28 74 77 69 6b 69 64 69 72 20 20 28 73 3a 66 (twikidir (s:f
2090: 69 6e 64 2d 70 61 72 61 6d 20 27 74 77 69 6b 69 ind-param 'twiki
20a0: 64 69 72 20 63 6f 6e 66 69 67 64 61 74 29 29 0a dir configdat)).
20b0: 09 20 28 70 61 67 65 2d 64 69 72 20 20 28 73 3a . (page-dir (s:
20c0: 66 69 6e 64 2d 70 61 72 61 6d 20 27 70 61 67 65 find-param 'page
20d0: 2d 64 69 72 2d 73 74 79 6c 65 20 63 6f 6e 66 69 -dir-style confi
20e0: 67 64 61 74 29 29 0a 09 20 28 64 65 62 75 67 6d gdat)).. (debugm
20f0: 6f 64 65 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 ode (s:find-para
2100: 6d 20 27 64 65 62 75 67 6d 6f 64 65 20 63 6f 6e m 'debugmode con
2110: 66 69 67 64 61 74 29 29 0a 20 20 20 20 20 20 20 figdat)).
2120: 20 20 28 73 63 72 69 70 74 20 20 20 20 28 73 3a (script (s:
2130: 66 69 6e 64 2d 70 61 72 61 6d 20 27 73 63 72 69 find-param 'scri
2140: 70 74 20 20 20 20 63 6f 6e 66 69 67 64 61 74 29 pt configdat)
2150: 29 29 0a 20 20 20 20 28 69 66 20 73 72 6f 6f 74 )). (if sroot
2160: 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d 73 72 (sdat-set-sr
2170: 6f 6f 74 21 20 20 20 20 73 65 6c 66 20 73 72 6f oot! self sro
2180: 6f 74 29 29 0a 20 20 20 20 28 69 66 20 6c 6f 67 ot)). (if log
2190: 66 69 6c 65 20 20 28 73 64 61 74 2d 73 65 74 2d file (sdat-set-
21a0: 6c 6f 67 66 69 6c 65 21 20 20 73 65 6c 66 20 6c logfile! self l
21b0: 6f 67 66 69 6c 65 29 29 0a 20 20 20 20 28 69 66 ogfile)). (if
21c0: 20 64 62 74 79 70 65 20 20 20 28 73 64 61 74 2d dbtype (sdat-
21d0: 73 65 74 2d 64 62 74 79 70 65 21 20 20 20 73 65 set-dbtype! se
21e0: 6c 66 20 64 62 74 79 70 65 29 29 0a 20 20 20 20 lf dbtype)).
21f0: 28 69 66 20 64 62 69 6e 69 74 20 20 20 28 73 64 (if dbinit (sd
2200: 61 74 2d 73 65 74 2d 64 62 69 6e 69 74 21 20 20 at-set-dbinit!
2210: 20 73 65 6c 66 20 64 62 69 6e 69 74 29 29 0a 20 self dbinit)).
2220: 20 20 20 28 69 66 20 64 6f 6d 61 69 6e 20 20 20 (if domain
2230: 28 73 64 61 74 2d 73 65 74 2d 64 6f 6d 61 69 6e (sdat-set-domain
2240: 21 20 20 20 73 65 6c 66 20 64 6f 6d 61 69 6e 29 ! self domain)
2250: 29 0a 20 20 20 20 28 69 66 20 74 77 69 6b 69 64 ). (if twikid
2260: 69 72 20 28 73 64 61 74 2d 73 65 74 2d 74 77 69 ir (sdat-set-twi
2270: 6b 69 64 69 72 21 20 73 65 6c 66 20 74 77 69 6b kidir! self twik
2280: 69 64 69 72 29 29 0a 20 20 20 20 28 69 66 20 64 idir)). (if d
2290: 65 62 75 67 6d 6f 64 65 20 28 73 64 61 74 2d 73 ebugmode (sdat-s
22a0: 65 74 2d 64 65 62 75 67 6d 6f 64 65 21 20 73 65 et-debugmode! se
22b0: 6c 66 20 64 65 62 75 67 6d 6f 64 65 29 29 0a 20 lf debugmode)).
22c0: 20 20 20 28 69 66 20 73 63 72 69 70 74 20 20 20 (if script
22d0: 20 28 73 64 61 74 2d 73 65 74 2d 73 63 72 69 70 (sdat-set-scrip
22e0: 74 21 20 20 20 20 73 65 6c 66 20 73 63 72 69 70 t! self scrip
22f0: 74 29 29 0a 20 20 20 20 28 73 64 61 74 2d 73 65 t)). (sdat-se
2300: 74 2d 70 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 t-page-dir-style
2310: 21 20 73 65 6c 66 20 70 61 67 65 2d 64 69 72 29 ! self page-dir)
2320: 0a 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 . ;; (print "
2330: 63 6f 6e 66 69 67 64 61 74 3a 20 22 29 28 70 70 configdat: ")(pp
2340: 20 63 6f 6e 66 69 67 64 61 74 29 0a 20 20 20 20 configdat).
2350: 28 69 66 20 64 65 62 75 67 6d 6f 64 65 0a 09 28 (if debugmode..(
2360: 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 session:log self
2370: 20 22 73 72 6f 6f 74 3a 20 22 20 73 72 6f 6f 74 "sroot: " sroot
2380: 20 22 20 6c 6f 67 66 69 6c 65 3a 20 22 20 6c 6f " logfile: " lo
2390: 67 66 69 6c 65 20 22 20 64 62 74 79 70 65 3a 20 gfile " dbtype:
23a0: 22 20 64 62 74 79 70 65 20 0a 09 09 20 20 20 20 " dbtype ...
23b0: 20 22 20 64 62 69 6e 69 74 3a 20 22 20 64 62 69 " dbinit: " dbi
23c0: 6e 69 74 20 22 20 64 6f 6d 61 69 6e 3a 20 22 20 nit " domain: "
23d0: 64 6f 6d 61 69 6e 20 22 20 70 61 67 65 2d 64 69 domain " page-di
23e0: 72 2d 73 74 79 6c 65 3a 20 22 20 70 61 67 65 2d r-style: " page-
23f0: 64 69 72 29 29 0a 20 20 20 20 29 0a 20 20 28 73 dir)). ). (s
2400: 64 61 74 2d 73 65 74 2d 73 68 61 72 65 64 2d 68 dat-set-shared-h
2410: 61 73 68 21 20 73 65 6c 66 20 28 6d 61 6b 65 2d ash! self (make-
2420: 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 29 hash-table)). )
2430: 0a 0a 3b 3b 20 55 73 65 64 20 66 6f 72 20 74 68 ..;; Used for th
2440: 65 20 73 74 72 61 6e 67 65 6c 79 20 69 6e 63 6f e strangely inco
2450: 6e 73 69 73 74 65 6e 74 20 68 61 6e 64 6c 69 6e nsistent handlin
2460: 67 20 6f 66 20 74 68 65 20 63 6f 6e 66 69 67 20 g of the config
2470: 66 69 6c 65 2e 20 41 20 62 65 74 74 65 72 20 77 file. A better w
2480: 61 79 20 69 73 20 6e 65 65 64 65 64 2e 0a 3b 3b ay is needed..;;
2490: 0a 3b 3b 20 20 20 28 6c 65 74 20 28 28 64 62 74 .;; (let ((dbt
24a0: 79 70 65 20 28 73 64 61 74 2d 67 65 74 2d 64 62 ype (sdat-get-db
24b0: 74 79 70 65 20 73 65 6c 66 29 29 29 0a 3b 3b 20 type self))).;;
24c0: 20 20 20 20 28 70 72 69 6e 74 20 22 64 62 74 79 (print "dbty
24d0: 70 65 3a 20 22 20 64 62 74 79 70 65 29 0a 3b 3b pe: " dbtype).;;
24e0: 20 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d 64 (sdat-set-d
24f0: 62 74 79 70 65 21 20 73 65 6c 66 20 28 65 76 61 btype! self (eva
2500: 6c 20 64 62 74 79 70 65 29 29 29 29 0a 0a 28 64 l dbtype))))..(d
2510: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 efine (session:s
2520: 65 74 75 70 20 73 65 6c 66 29 0a 20 20 28 6c 65 etup self). (le
2530: 74 20 28 28 64 62 74 79 70 65 20 20 20 20 28 73 t ((dbtype (s
2540: 64 61 74 2d 67 65 74 2d 64 62 74 79 70 65 20 73 dat-get-dbtype s
2550: 65 6c 66 29 29 0a 09 28 64 65 62 75 67 6d 6f 64 elf))..(debugmod
2560: 65 20 28 73 64 61 74 2d 67 65 74 2d 64 65 62 75 e (sdat-get-debu
2570: 67 6d 6f 64 65 20 73 65 6c 66 29 29 0a 09 28 64 gmode self))..(d
2580: 62 69 6e 69 74 20 20 20 20 28 65 76 61 6c 20 28 binit (eval (
2590: 73 64 61 74 2d 67 65 74 2d 64 62 69 6e 69 74 20 sdat-get-dbinit
25a0: 73 65 6c 66 29 29 29 0a 09 28 64 62 65 78 69 73 self)))..(dbexis
25b0: 74 73 20 20 23 66 29 29 0a 20 20 20 20 28 6c 65 ts #f)). (le
25c0: 74 20 28 28 64 62 66 6e 61 6d 65 20 28 61 6c 69 t ((dbfname (ali
25d0: 73 74 2d 72 65 66 20 27 64 62 6e 61 6d 65 20 64 st-ref 'dbname d
25e0: 62 69 6e 69 74 29 29 29 0a 20 20 20 20 20 20 28 binit))). (
25f0: 69 66 20 64 65 62 75 67 6d 6f 64 65 20 28 73 65 if debugmode (se
2600: 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 ssion:log self "
2610: 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 20 64 62 session:setup db
2620: 66 6e 61 6d 65 3d 22 20 64 62 66 6e 61 6d 65 20 fname=" dbfname
2630: 22 2c 20 64 62 74 79 70 65 3d 22 20 64 62 74 79 ", dbtype=" dbty
2640: 70 65 20 22 2c 20 64 62 69 6e 69 74 3d 22 20 64 pe ", dbinit=" d
2650: 62 69 6e 69 74 29 29 0a 20 20 20 20 20 20 28 69 binit)). (i
2660: 66 20 28 65 71 3f 20 64 62 74 79 70 65 20 27 73 f (eq? dbtype 's
2670: 71 6c 69 74 65 33 29 0a 09 20 20 3b 3b 20 54 68 qlite3).. ;; Th
2680: 65 20 27 61 75 74 6f 20 6d 65 74 68 6f 64 20 77 e 'auto method w
2690: 69 6c 6c 20 64 69 73 74 72 69 62 75 74 65 20 64 ill distribute d
26a0: 62 73 20 61 63 72 6f 73 73 20 74 68 65 20 64 69 bs across the di
26b0: 73 6b 20 75 73 69 6e 67 20 68 61 73 68 0a 09 20 sk using hash..
26c0: 20 3b 3b 20 6f 66 20 75 73 65 72 20 68 6f 73 74 ;; of user host
26d0: 20 61 6e 64 20 75 73 65 72 2e 20 54 4f 44 4f 0a and user. TODO.
26e0: 09 20 20 3b 3b 20 28 69 66 20 28 65 71 3f 20 64 . ;; (if (eq? d
26f0: 62 66 6e 61 6d 65 20 27 61 75 74 6f 29 20 3b 3b bfname 'auto) ;;
2700: 20 54 68 69 73 20 69 73 20 74 68 65 20 61 75 74 This is the aut
2710: 6f 20 61 73 73 69 67 6e 6d 65 6e 74 20 6f 66 20 o assignment of
2720: 61 20 64 62 20 62 61 73 65 64 20 6f 6e 20 68 61 a db based on ha
2730: 73 68 20 6f 66 20 49 50 0a 09 20 20 28 6c 65 74 sh of IP.. (let
2740: 20 28 28 64 62 70 61 74 68 20 28 70 61 74 68 6e ((dbpath (pathn
2750: 61 6d 65 2d 64 69 72 65 63 74 6f 72 79 20 64 62 ame-directory db
2760: 66 6e 61 6d 65 29 29 29 20 20 3b 3b 20 64 6f 20 fname))) ;; do
2770: 61 20 63 6f 75 70 6c 65 20 73 61 6e 69 74 79 20 a couple sanity
2780: 63 68 65 63 6b 73 20 68 65 72 65 20 74 6f 20 6d checks here to m
2790: 61 6b 65 20 73 65 74 74 69 6e 67 20 75 70 20 65 ake setting up e
27a0: 61 73 69 65 72 0a 09 20 20 20 20 28 69 66 20 64 asier.. (if d
27b0: 65 62 75 67 6d 6f 64 65 20 28 73 65 73 73 69 6f ebugmode (sessio
27c0: 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 49 4e 46 4f n:log self "INFO
27d0: 3a 20 73 65 74 74 69 6e 67 20 75 70 20 66 6f 72 : setting up for
27e0: 20 73 71 6c 69 74 65 33 20 64 62 20 61 63 63 65 sqlite3 db acce
27f0: 73 73 20 74 6f 20 22 20 64 62 66 6e 61 6d 65 29 ss to " dbfname)
2800: 29 0a 09 20 20 20 20 28 69 66 20 28 6e 6f 74 20 ).. (if (not
2810: 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 (file-write-acce
2820: 73 73 3f 20 64 62 70 61 74 68 29 29 0a 09 09 28 ss? dbpath))...(
2830: 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 session:log self
2840: 20 22 57 41 52 4e 49 4e 47 3a 20 43 61 6e 6e 6f "WARNING: Canno
2850: 74 20 77 72 69 74 65 20 74 6f 20 22 20 64 62 70 t write to " dbp
2860: 61 74 68 29 0a 09 09 28 69 66 20 64 65 62 75 67 ath)...(if debug
2870: 6d 6f 64 65 20 28 73 65 73 73 69 6f 6e 3a 6c 6f mode (session:lo
2880: 67 20 73 65 6c 66 20 22 49 4e 46 4f 3a 20 22 20 g self "INFO: "
2890: 64 62 70 61 74 68 20 22 20 69 73 20 77 72 69 74 dbpath " is writ
28a0: 65 61 62 6c 65 22 29 29 29 0a 09 20 20 20 20 28 eable"))).. (
28b0: 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f if (file-exists?
28c0: 20 64 62 66 6e 61 6d 65 29 0a 09 09 28 62 65 67 dbfname)...(beg
28d0: 69 6e 0a 09 09 20 20 3b 3b 20 28 73 65 73 73 69 in... ;; (sessi
28e0: 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 73 65 74 on:log self "set
28f0: 74 69 6e 67 20 64 62 65 78 69 73 74 73 20 74 6f ting dbexists to
2900: 20 23 74 22 29 0a 09 09 20 20 28 73 65 74 21 20 #t")... (set!
2910: 64 62 65 78 69 73 74 73 20 23 74 29 29 29 29 0a dbexists #t)))).
2920: 09 20 20 28 69 66 20 64 65 62 75 67 6d 6f 64 65 . (if debugmode
2930: 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 (session:log se
2940: 6c 66 20 22 49 4e 46 4f 3a 20 73 65 74 74 69 6e lf "INFO: settin
2950: 67 20 75 70 20 66 6f 72 20 70 67 20 64 62 20 61 g up for pg db a
2960: 63 63 65 73 73 20 74 6f 20 61 63 63 6f 75 6e 74 ccess to account
2970: 20 69 6e 66 6f 20 22 20 64 62 69 6e 69 74 29 29 info " dbinit))
2980: 29 0a 20 20 20 20 20 20 28 69 66 20 64 65 62 75 ). (if debu
2990: 67 6d 6f 64 65 20 28 73 65 73 73 69 6f 6e 3a 6c gmode (session:l
29a0: 6f 67 20 73 65 6c 66 20 22 64 62 74 79 70 65 3a og self "dbtype:
29b0: 20 22 20 64 62 74 79 70 65 20 22 20 64 62 66 6e " dbtype " dbfn
29c0: 61 6d 65 3a 20 22 20 64 62 66 6e 61 6d 65 20 22 ame: " dbfname "
29d0: 20 64 62 65 78 69 73 74 73 3a 20 22 20 64 62 65 dbexists: " dbe
29e0: 78 69 73 74 73 29 29 29 0a 20 20 20 20 28 73 64 xists))). (sd
29f0: 61 74 2d 73 65 74 2d 63 6f 6e 6e 21 20 73 65 6c at-set-conn! sel
2a00: 66 20 28 64 62 69 3a 6f 70 65 6e 20 64 62 74 79 f (dbi:open dbty
2a10: 70 65 20 64 62 69 6e 69 74 29 29 0a 20 20 20 20 pe dbinit)).
2a20: 28 73 65 74 21 20 2a 64 62 2a 20 28 73 64 61 74 (set! *db* (sdat
2a30: 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 -get-conn self))
2a40: 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 6e . (if (and (n
2a50: 6f 74 20 64 62 65 78 69 73 74 73 29 28 65 71 3f ot dbexists)(eq?
2a60: 20 64 62 74 79 70 65 20 27 73 71 6c 69 74 65 33 dbtype 'sqlite3
2a70: 29 29 0a 20 09 28 62 65 67 69 6e 0a 09 20 20 28 )). .(begin.. (
2a80: 70 72 69 6e 74 20 22 57 41 52 4e 49 4e 47 3a 20 print "WARNING:
2a90: 53 65 74 74 69 6e 67 20 75 70 20 73 65 73 73 69 Setting up sessi
2aa0: 6f 6e 20 64 62 20 77 69 74 68 20 73 71 6c 69 74 on db with sqlit
2ab0: 65 33 22 29 0a 09 20 20 28 73 65 73 73 69 6f 6e e3").. (session
2ac0: 3a 73 65 74 75 70 2d 64 62 20 73 65 6c 66 29 29 :setup-db self))
2ad0: 29 0a 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 70 ). (session:p
2ae0: 72 6f 63 65 73 73 2d 75 72 6c 2d 70 61 74 68 20 rocess-url-path
2af0: 73 65 6c 66 29 0a 20 20 20 20 28 73 65 73 73 69 self). (sessi
2b00: 6f 6e 3a 73 65 74 75 70 2d 73 65 73 73 69 6f 6e on:setup-session
2b10: 2d 6b 65 79 20 73 65 6c 66 29 0a 20 20 20 20 3b -key self). ;
2b20: 3b 20 63 61 70 74 75 72 65 20 73 74 64 69 6e 20 ; capture stdin
2b30: 69 66 20 74 68 69 73 20 69 73 20 61 20 50 4f 53 if this is a POS
2b40: 54 0a 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d T. (sdat-set-
2b50: 72 65 71 75 65 73 74 2d 6d 65 74 68 6f 64 21 20 request-method!
2b60: 73 65 6c 66 20 28 67 65 74 2d 65 6e 76 69 72 6f self (get-enviro
2b70: 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 nment-variable "
2b80: 52 45 51 55 45 53 54 5f 4d 45 54 48 4f 44 22 29 REQUEST_METHOD")
2b90: 29 0a 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d ). (sdat-set-
2ba0: 66 6f 72 6d 64 61 74 21 20 73 65 6c 66 20 28 66 formdat! self (f
2bb0: 6f 72 6d 64 61 74 3a 6c 6f 61 64 2d 61 6c 6c 29 ormdat:load-all)
2bc0: 29 29 29 0a 0a 3b 3b 20 73 65 74 75 70 20 74 68 )))..;; setup th
2bd0: 65 20 64 62 20 77 69 74 68 20 73 65 73 73 69 6f e db with sessio
2be0: 6e 20 74 61 62 6c 65 73 2c 20 77 6f 72 6b 73 20 n tables, works
2bf0: 66 6f 72 20 73 71 6c 69 74 65 20 6f 6e 6c 79 20 for sqlite only
2c00: 72 69 67 68 74 20 6e 6f 77 0a 28 64 65 66 69 6e right now.(defin
2c10: 65 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 e (session:setup
2c20: 2d 64 62 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 -db self). (let
2c30: 20 28 28 63 6f 6e 6e 20 28 73 64 61 74 2d 67 65 ((conn (sdat-ge
2c40: 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 29 0a 20 t-conn self))).
2c50: 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 (for-each .
2c60: 20 20 20 28 6c 61 6d 62 64 61 20 28 73 74 6d 74 (lambda (stmt
2c70: 29 0a 20 20 20 20 20 20 20 28 64 62 69 3a 65 78 ). (dbi:ex
2c80: 65 63 20 63 6f 6e 6e 20 73 74 6d 74 29 29 0a 20 ec conn stmt)).
2c90: 20 20 20 20 28 6c 69 73 74 20 22 43 52 45 41 54 (list "CREAT
2ca0: 45 20 54 41 42 4c 45 20 73 65 73 73 69 6f 6e 5f E TABLE session_
2cb0: 76 61 72 73 20 28 69 64 20 49 4e 54 45 47 45 52 vars (id INTEGER
2cc0: 20 50 52 49 4d 41 52 59 20 4b 45 59 2c 73 65 73 PRIMARY KEY,ses
2cd0: 73 69 6f 6e 5f 69 64 20 49 4e 54 45 47 45 52 2c sion_id INTEGER,
2ce0: 70 61 67 65 20 54 45 58 54 2c 6b 65 79 20 54 45 page TEXT,key TE
2cf0: 58 54 2c 76 61 6c 75 65 20 54 45 58 54 29 3b 22 XT,value TEXT);"
2d00: 0a 09 20 20 20 22 43 52 45 41 54 45 20 54 41 42 .. "CREATE TAB
2d10: 4c 45 20 73 65 73 73 69 6f 6e 73 20 28 69 64 20 LE sessions (id
2d20: 49 4e 54 45 47 45 52 20 50 52 49 4d 41 52 59 20 INTEGER PRIMARY
2d30: 4b 45 59 2c 73 65 73 73 69 6f 6e 5f 6b 65 79 20 KEY,session_key
2d40: 54 45 58 54 2c 6c 61 73 74 5f 75 73 65 64 20 54 TEXT,last_used T
2d50: 49 4d 45 53 54 41 4d 50 29 3b 22 0a 20 20 20 20 IMESTAMP);".
2d60: 20 20 20 20 20 20 20 22 43 52 45 41 54 45 20 54 "CREATE T
2d70: 41 42 4c 45 20 6d 65 74 61 64 61 74 61 20 28 69 ABLE metadata (i
2d80: 64 20 49 4e 54 45 47 45 52 20 50 52 49 4d 41 52 d INTEGER PRIMAR
2d90: 59 20 4b 45 59 2c 6b 65 79 20 54 45 58 54 2c 76 Y KEY,key TEXT,v
2da0: 61 6c 75 65 20 54 45 58 54 29 3b 22 29 29 29 29 alue TEXT);"))))
2db0: 0a 3b 3b 20 20 3b 3b 20 69 66 20 77 65 20 68 61 .;; ;; if we ha
2dc0: 76 65 20 61 20 73 65 73 73 69 6f 6e 5f 6b 65 79 ve a session_key
2dd0: 20 6c 6f 6f 6b 20 75 70 20 74 68 65 20 73 65 73 look up the ses
2de0: 73 69 6f 6e 2d 69 64 20 61 6e 64 20 73 74 6f 72 sion-id and stor
2df0: 65 20 69 74 0a 3b 3b 20 20 28 73 64 61 74 2d 73 e it.;; (sdat-s
2e00: 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 21 20 73 et-session-id! s
2e10: 65 6c 66 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 elf (session:get
2e20: 2d 69 64 20 73 65 6c 66 29 29 29 0a 0a 3b 3b 20 -id self)))..;;
2e30: 6f 6e 6c 79 20 73 65 74 20 73 65 73 73 69 6f 6e only set session
2e40: 2d 63 6f 6f 6b 69 65 20 77 68 65 6e 20 61 20 6e -cookie when a n
2e50: 65 77 20 73 65 73 73 69 6f 6e 20 69 73 20 63 72 ew session is cr
2e60: 65 61 74 65 64 0a 28 64 65 66 69 6e 65 20 28 73 eated.(define (s
2e70: 65 73 73 69 6f 6e 3a 73 65 74 75 70 2d 73 65 73 ession:setup-ses
2e80: 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 20 20 sion-key self)
2e90: 0a 20 20 28 6c 65 74 2a 20 28 28 73 6b 20 20 28 . (let* ((sk (
2ea0: 73 65 73 73 69 6f 6e 3a 65 78 74 72 61 63 74 2d session:extract-
2eb0: 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 session-key self
2ec0: 29 29 0a 20 20 20 20 20 20 20 20 20 28 73 69 64 )). (sid
2ed0: 20 28 69 66 20 73 6b 20 28 73 65 73 73 69 6f 6e (if sk (session
2ee0: 3a 67 65 74 2d 69 64 20 73 65 6c 66 20 73 6b 29 :get-id self sk)
2ef0: 20 23 66 29 29 29 0a 20 20 20 20 28 69 66 20 28 #f))). (if (
2f00: 6e 6f 74 20 73 69 64 29 20 3b 3b 20 6e 65 65 64 not sid) ;; need
2f10: 20 61 20 6e 65 77 20 6b 65 79 0a 20 20 20 20 20 a new key.
2f20: 20 20 20 28 6c 65 74 2a 20 28 28 6e 65 77 2d 6b (let* ((new-k
2f30: 65 79 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d ey (session:get-
2f40: 6e 65 77 2d 6b 65 79 20 73 65 6c 66 29 29 0a 20 new-key self)).
2f50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6e (n
2f60: 65 77 2d 73 69 64 20 28 73 65 73 73 69 6f 6e 3a ew-sid (session:
2f70: 67 65 74 2d 69 64 20 73 65 6c 66 20 6e 65 77 2d get-id self new-
2f80: 6b 65 79 29 29 29 0a 20 20 20 20 20 20 20 20 20 key))).
2f90: 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 (sdat-set-sessi
2fa0: 6f 6e 2d 6b 65 79 21 20 73 65 6c 66 20 6e 65 77 on-key! self new
2fb0: 2d 6b 65 79 29 0a 20 20 20 20 20 20 20 20 20 20 -key).
2fc0: 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f (sdat-set-sessio
2fd0: 6e 2d 69 64 21 20 73 65 6c 66 20 6e 65 77 2d 73 n-id! self new-s
2fe0: 69 64 29 0a 20 20 20 20 20 20 20 20 20 20 28 73 id). (s
2ff0: 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e 2d dat-set-session-
3000: 63 6f 6f 6b 69 65 21 20 73 65 6c 66 20 28 73 65 cookie! self (se
3010: 73 73 69 6f 6e 3a 6d 61 6b 65 2d 63 6f 6f 6b 69 ssion:make-cooki
3020: 65 20 73 65 6c 66 29 29 29 0a 20 20 20 20 20 20 e self))).
3030: 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 (sdat-set-sess
3040: 69 6f 6e 2d 69 64 21 20 73 65 6c 66 20 73 69 64 ion-id! self sid
3050: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 ))))..(define (s
3060: 65 73 73 69 6f 6e 3a 6d 61 6b 65 2d 63 6f 6f 6b ession:make-cook
3070: 69 65 20 73 65 6c 66 29 0a 20 20 3b 3b 20 28 6c ie self). ;; (l
3080: 69 73 74 20 28 63 6f 6e 63 20 22 73 65 73 73 69 ist (conc "sessi
3090: 6f 6e 5f 6b 65 79 3d 22 20 28 73 64 61 74 2d 67 on_key=" (sdat-g
30a0: 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 et-session-key s
30b0: 65 6c 66 29 20 22 3b 20 50 61 74 68 3d 2f 3b 20 elf) "; Path=/;
30c0: 44 6f 6d 61 69 6e 3d 2e 22 20 28 73 64 61 74 2d Domain=." (sdat-
30d0: 67 65 74 2d 64 6f 6d 61 69 6e 20 73 65 6c 66 29 get-domain self)
30e0: 20 22 3b 20 4d 61 78 2d 41 67 65 3d 22 20 28 2a "; Max-Age=" (*
30f0: 20 38 36 34 30 30 20 31 34 29 20 22 3b 20 56 65 86400 14) "; Ve
3100: 72 73 69 6f 6e 3d 31 22 29 29 29 20 0a 20 20 3b rsion=1"))) . ;
3110: 3b 20 41 63 63 6f 72 64 69 6e 67 20 74 6f 20 0a ; According to .
3120: 20 20 3b 3b 20 20 20 20 68 74 74 70 3a 2f 2f 77 ;; http://w
3130: 77 77 2e 63 6f 64 65 6d 61 72 76 65 6c 73 2e 63 ww.codemarvels.c
3140: 6f 6d 2f 32 30 31 30 2f 31 31 2f 61 70 61 63 68 om/2010/11/apach
3150: 65 2d 72 65 77 72 69 74 65 72 75 6c 65 2d 73 65 e-rewriterule-se
3160: 74 2d 61 2d 63 6f 6f 6b 69 65 2d 6f 6e 2d 6c 6f t-a-cookie-on-lo
3170: 63 61 6c 68 6f 73 74 2f 0a 0a 20 20 3b 3b 20 20 calhost/.. ;;
3180: 48 65 72 65 20 61 72 65 20 74 68 65 20 32 20 28 Here are the 2 (
3190: 6f 66 74 65 6e 20 6c 65 66 74 20 6f 75 74 29 20 often left out)
31a0: 72 65 71 75 69 72 65 6d 65 6e 74 73 20 74 6f 20 requirements to
31b0: 73 65 74 20 61 20 63 6f 6f 6b 69 65 20 75 73 69 set a cookie usi
31c0: 6e 67 0a 20 20 3b 3b 20 20 68 74 74 70 64 1b 2d ng. ;; httpd.-
31d0: 46 ef bf bd 73 20 72 65 77 72 69 74 65 20 72 75 F�s rewrite ru
31e0: 6c 65 20 28 6d 6f 64 5f 72 65 77 72 69 74 65 29 le (mod_rewrite)
31f0: 2c 20 77 68 69 6c 65 20 77 6f 72 6b 69 6e 67 20 , while working
3200: 6f 6e 20 6c 6f 63 61 6c 68 6f 73 74 3a 1b 2d 41 on localhost:.-A
3210: 0a 20 20 3b 3b 0a 20 20 3b 3b 20 20 55 73 65 20 . ;;. ;; Use
3220: 74 68 65 20 49 50 20 31 32 37 2e 30 2e 30 2e 31 the IP 127.0.0.1
3230: 20 69 6e 73 74 65 61 64 20 6f 66 20 6c 6f 63 61 instead of loca
3240: 6c 68 6f 73 74 2f 6d 61 63 68 69 6e 65 2d 6e 61 lhost/machine-na
3250: 6d 65 20 61 73 20 74 68 65 0a 20 20 3b 3b 20 20 me as the. ;;
3260: 64 6f 6d 61 69 6e 3b 20 65 2e 67 2e 20 5b 43 4f domain; e.g. [CO
3270: 3d 73 6f 6d 65 43 6f 6f 6b 69 65 3a 73 6f 6d 65 =someCookie:some
3280: 56 61 6c 75 65 3a 31 32 37 2e 30 2e 30 2e 31 3a Value:127.0.0.1:
3290: 32 3a 2f 5d 2c 20 77 68 69 63 68 20 73 61 79 73 2:/], which says
32a0: 0a 20 20 3b 3b 20 20 63 72 65 61 74 65 20 61 20 . ;; create a
32b0: 63 6f 6f 6b 69 65 20 1b 2d 59 ef bf bd 73 6f 6d cookie .-Y�som
32c0: 65 43 6f 6f 6b 69 65 ef bf bd 20 77 69 74 68 20 eCookie� with
32d0: 76 61 6c 75 65 20 ef bf bd 73 6f 6d 65 56 61 6c value �someVal
32e0: 75 65 ef bf bd 20 66 6f 72 20 74 68 65 0a 20 20 ue� for the.
32f0: 3b 3b 20 20 64 6f 6d 61 69 6e 20 ef bf bd 31 32 ;; domain �12
3300: 37 2e 30 2e 30 2e 31 1b 24 42 21 6d 1b 28 42 20 7.0.0.1.$B!m.(B
3310: 68 61 76 69 6e 67 20 61 20 6c 69 66 65 20 74 69 having a life ti
3320: 6d 65 20 6f 66 20 32 20 6d 69 6e 73 2c 20 66 6f me of 2 mins, fo
3330: 72 20 61 6e 79 20 70 61 74 68 20 69 6e 0a 20 20 r any path in.
3340: 3b 3b 20 20 74 68 65 20 64 6f 6d 61 69 6e 20 28 ;; the domain (
3350: 70 61 74 68 3d 2f 29 2e 20 28 4f 62 76 69 6f 75 path=/). (Obviou
3360: 73 6c 79 20 79 6f 75 20 77 69 6c 6c 20 68 61 76 sly you will hav
3370: 65 20 74 6f 20 72 75 6e 20 74 68 65 0a 20 20 3b e to run the. ;
3380: 3b 20 20 61 70 70 6c 69 63 61 74 69 6f 6e 20 77 ; application w
3390: 69 74 68 20 74 68 69 73 20 76 61 6c 75 65 20 69 ith this value i
33a0: 6e 20 74 68 65 20 55 52 4c 29 0a 20 20 3b 3b 0a n the URL). ;;.
33b0: 20 20 3b 3b 20 20 54 6f 20 6d 61 6b 65 20 61 20 ;; To make a
33c0: 73 65 73 73 69 6f 6e 20 63 6f 6f 6b 69 65 2c 20 session cookie,
33d0: 6c 69 6d 69 74 20 74 68 65 20 66 6c 61 67 20 73 limit the flag s
33e0: 74 61 74 65 6d 65 6e 74 20 74 6f 20 6a 75 73 74 tatement to just
33f0: 20 74 68 72 65 65 0a 20 20 3b 3b 20 20 61 74 74 three. ;; att
3400: 72 69 62 75 74 65 73 3a 20 6e 61 6d 65 2c 20 76 ributes: name, v
3410: 61 6c 75 65 20 61 6e 64 20 64 6f 6d 61 69 6e 2e alue and domain.
3420: 20 65 2e 67 0a 20 20 3b 3b 20 20 5b 43 4f 3d 73 e.g. ;; [CO=s
3430: 6f 6d 65 43 6f 6f 6b 69 65 3a 73 6f 6d 65 56 61 omeCookie:someVa
3440: 6c 75 65 3a 31 32 37 2e 30 2e 30 2e 31 5d 20 1b lue:127.0.0.1] .
3450: 25 47 e2 80 93 1b 25 40 20 41 6e 79 20 66 75 72 %G–.%@ Any fur
3460: 74 68 65 72 0a 20 20 3b 3b 20 20 73 65 74 74 69 ther. ;; setti
3470: 6e 67 73 2c 20 61 70 61 63 68 65 20 77 72 69 74 ngs, apache writ
3480: 65 73 20 61 6e ef bf bd 20 65 78 70 69 72 65 73 es an� expires
3490: ef bf bd 20 61 74 74 72 69 62 75 74 65 20 66 6f � attribute fo
34a0: 72 20 74 68 65 20 73 65 74 2d 63 6f 6f 6b 69 65 r the set-cookie
34b0: 0a 20 20 3b 3b 20 20 68 65 61 64 65 72 2c 20 77 . ;; header, w
34c0: 68 69 63 68 20 6d 61 6b 65 73 20 74 68 65 20 63 hich makes the c
34d0: 6f 6f 6b 69 65 20 61 20 70 65 72 73 69 73 74 65 ookie a persiste
34e0: 6e 74 20 6f 6e 65 20 28 6e 6f 74 20 72 65 61 6c nt one (not real
34f0: 6c 79 0a 20 20 3b 3b 20 20 70 65 72 73 69 73 74 ly. ;; persist
3500: 65 6e 74 2c 20 61 73 20 74 68 65 20 65 78 70 69 ent, as the expi
3510: 72 65 73 20 76 61 6c 75 65 20 73 65 74 20 69 73 res value set is
3520: 20 74 68 65 20 63 75 72 72 65 6e 74 20 73 65 72 the current ser
3530: 76 65 72 20 74 69 6d 65 0a 20 20 3b 3b 20 20 1b ver time. ;; .
3540: 25 47 e2 80 93 1b 25 40 20 73 6f 20 79 6f 75 20 %G–.%@ so you
3550: 64 6f 6e 1b 2d 46 1b 2d 46 ef bf bd 74 20 65 76 don.-F.-F�t ev
3560: 65 6e 20 67 65 74 20 74 6f 20 73 65 65 20 79 6f en get to see yo
3570: 75 72 20 63 6f 6f 6b 69 65 21 29 1b 2d 41 0a 20 ur cookie!).-A.
3580: 20 28 6c 69 73 74 20 28 73 74 72 69 6e 67 2d 73 (list (string-s
3590: 75 62 73 74 69 74 75 74 65 20 0a 09 20 22 3b 22 ubstitute .. ";"
35a0: 20 22 3b 20 22 20 0a 09 20 28 63 61 72 20 28 63 "; " .. (car (c
35b0: 6f 6e 73 74 72 75 63 74 2d 63 6f 6f 6b 69 65 2d onstruct-cookie-
35c0: 73 74 72 69 6e 67 20 0a 09 20 20 20 20 20 20 20 string ..
35d0: 3b 3b 20 77 61 72 6e 69 6e 67 21 20 6d 65 73 73 ;; warning! mess
35e0: 69 6e 67 20 75 70 20 74 68 69 73 20 69 74 74 79 ing up this itty
35f0: 20 62 69 74 74 79 20 62 69 74 20 6f 66 20 63 6f bitty bit of co
3600: 64 65 20 77 69 6c 6c 20 63 6f 73 74 20 6d 75 63 de will cost muc
3610: 68 20 74 69 6d 65 21 0a 09 20 20 20 20 20 20 20 h time!..
3620: 60 28 28 22 73 65 73 73 69 6f 6e 5f 6b 65 79 22 `(("session_key"
3630: 20 2c 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 ,(sdat-get-sess
3640: 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 0a 09 09 ion-key self)...
3650: 20 20 65 78 70 69 72 65 73 3a 20 2c 28 2b 20 28 expires: ,(+ (
3660: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
3670: 20 28 2a 20 31 34 20 38 36 34 30 30 29 29 20 0a (* 14 86400)) .
3680: 09 09 20 20 3b 3b 20 6d 61 78 2d 61 67 65 3a 20 .. ;; max-age:
3690: 28 2a 20 31 34 20 38 36 34 30 30 29 0a 09 09 20 (* 14 86400)...
36a0: 20 70 61 74 68 3a 20 22 2f 22 20 3b 3b 20 0a 09 path: "/" ;; ..
36b0: 09 20 20 64 6f 6d 61 69 6e 3a 20 2c 28 73 74 72 . domain: ,(str
36c0: 69 6e 67 2d 61 70 70 65 6e 64 20 22 2e 22 20 28 ing-append "." (
36d0: 73 64 61 74 2d 67 65 74 2d 64 6f 6d 61 69 6e 20 sdat-get-domain
36e0: 73 65 6c 66 29 29 0a 09 09 20 20 76 65 72 73 69 self))... versi
36f0: 6f 6e 3a 20 31 29 29 20 30 29 29 29 29 29 0a 0a on: 1)) 0)))))..
3700: 3b 3b 20 6c 6f 6f 6b 20 75 70 20 61 20 67 69 76 ;; look up a giv
3710: 65 6e 20 73 65 73 73 69 6f 6e 20 6b 65 79 20 61 en session key a
3720: 6e 64 20 72 65 74 75 72 6e 20 74 68 65 20 69 64 nd return the id
3730: 20 69 66 20 66 6f 75 6e 64 2c 20 23 66 20 69 66 if found, #f if
3740: 20 6e 6f 74 20 66 6f 75 6e 64 0a 28 64 65 66 69 not found.(defi
3750: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d ne (session:get-
3760: 69 64 20 73 65 6c 66 20 73 65 73 73 69 6f 6e 2d id self session-
3770: 6b 65 79 29 0a 20 20 3b 3b 20 28 6c 65 74 20 28 key). ;; (let (
3780: 28 73 65 73 73 69 6f 6e 2d 6b 65 79 20 28 73 64 (session-key (sd
3790: 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 2d 6b at-get-session-k
37a0: 65 79 20 73 65 6c 66 29 29 29 0a 20 20 28 69 66 ey self))). (if
37b0: 20 73 65 73 73 69 6f 6e 2d 6b 65 79 0a 20 20 20 session-key.
37c0: 20 20 20 28 6c 65 74 20 28 28 71 75 65 72 79 20 (let ((query
37d0: 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 22 (string-append "
37e0: 53 45 4c 45 43 54 20 69 64 20 46 52 4f 4d 20 73 SELECT id FROM s
37f0: 65 73 73 69 6f 6e 73 20 57 48 45 52 45 20 73 65 essions WHERE se
3800: 73 73 69 6f 6e 5f 6b 65 79 3d 27 22 20 73 65 73 ssion_key='" ses
3810: 73 69 6f 6e 2d 6b 65 79 20 22 27 22 29 29 0a 20 sion-key "'")).
3820: 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 6e (conn
3830: 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 (sdat-get-conn
3840: 73 65 6c 66 29 29 0a 20 20 20 20 20 20 20 20 20 self)).
3850: 20 20 20 28 72 65 73 75 6c 74 20 23 66 29 29 0a (result #f)).
3860: 09 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 .(dbi:for-each-r
3870: 6f 77 20 0a 09 20 28 6c 61 6d 62 64 61 20 28 74 ow .. (lambda (t
3880: 75 70 6c 65 29 0a 09 20 20 20 28 73 65 74 21 20 uple).. (set!
3890: 72 65 73 75 6c 74 20 28 76 65 63 74 6f 72 2d 72 result (vector-r
38a0: 65 66 20 74 75 70 6c 65 20 30 29 29 29 0a 09 20 ef tuple 0)))..
38b0: 63 6f 6e 6e 20 71 75 65 72 79 29 0a 09 28 69 66 conn query)..(if
38c0: 20 72 65 73 75 6c 74 20 28 64 62 69 3a 65 78 65 result (dbi:exe
38d0: 63 20 63 6f 6e 6e 20 28 63 6f 6e 63 20 22 55 50 c conn (conc "UP
38e0: 44 41 54 45 20 73 65 73 73 69 6f 6e 73 20 53 45 DATE sessions SE
38f0: 54 20 6c 61 73 74 5f 75 73 65 64 3d 22 20 28 64 T last_used=" (d
3900: 62 69 3a 6e 6f 77 20 63 6f 6e 6e 29 20 22 20 57 bi:now conn) " W
3910: 48 45 52 45 20 73 65 73 73 69 6f 6e 5f 6b 65 79 HERE session_key
3920: 3d 3f 3b 22 29 20 73 65 73 73 69 6f 6e 2d 6b 65 =?;") session-ke
3930: 79 29 29 0a 20 20 20 20 20 20 20 20 72 65 73 75 y)). resu
3940: 6c 74 29 0a 20 20 20 20 20 20 23 66 29 29 0a 0a lt). #f))..
3950: 3b 3b 20 0a 28 64 65 66 69 6e 65 20 28 73 65 73 ;; .(define (ses
3960: 73 69 6f 6e 3a 70 72 6f 63 65 73 73 2d 75 72 6c sion:process-url
3970: 2d 70 61 74 68 20 73 65 6c 66 29 0a 20 20 28 6c -path self). (l
3980: 65 74 20 28 28 70 61 74 68 2d 69 6e 66 6f 20 20 et ((path-info
3990: 20 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 (get-environme
39a0: 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 50 41 54 nt-variable "PAT
39b0: 48 5f 49 4e 46 4f 22 29 29 0a 09 28 71 75 65 72 H_INFO"))..(quer
39c0: 79 2d 73 74 72 69 6e 67 20 28 67 65 74 2d 65 6e y-string (get-en
39d0: 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 vironment-variab
39e0: 6c 65 20 22 51 55 45 52 59 5f 53 54 52 49 4e 47 le "QUERY_STRING
39f0: 22 29 29 29 0a 20 20 20 20 3b 3b 20 28 73 65 73 "))). ;; (ses
3a00: 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 70 sion:log self "p
3a10: 61 74 68 2d 69 6e 66 6f 3d 22 20 70 61 74 68 2d ath-info=" path-
3a20: 69 6e 66 6f 20 22 20 71 75 65 72 79 2d 73 74 72 info " query-str
3a30: 69 6e 67 3d 22 20 71 75 65 72 79 2d 73 74 72 69 ing=" query-stri
3a40: 6e 67 29 0a 20 20 20 20 28 69 66 20 70 61 74 68 ng). (if path
3a50: 2d 69 6e 66 6f 0a 09 28 6c 65 74 2a 20 28 28 70 -info..(let* ((p
3a60: 61 72 74 73 20 20 20 20 28 73 74 72 69 6e 67 2d arts (string-
3a70: 73 70 6c 69 74 20 70 61 74 68 2d 69 6e 66 6f 20 split path-info
3a80: 22 2f 22 29 29 0a 09 20 20 20 20 20 20 20 28 6e "/")).. (n
3a90: 75 6d 70 61 72 74 73 20 28 6c 65 6e 67 74 68 20 umparts (length
3aa0: 70 61 72 74 73 29 29 29 0a 09 20 20 28 69 66 20 parts))).. (if
3ab0: 28 3e 20 6e 75 6d 70 61 72 74 73 20 30 29 0a 09 (> numparts 0)..
3ac0: 20 20 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d (sdat-set-
3ad0: 70 61 67 65 21 20 73 65 6c 66 20 28 63 61 72 20 page! self (car
3ae0: 70 61 72 74 73 29 29 29 0a 09 20 20 3b 3b 20 28 parts))).. ;; (
3af0: 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 session:log self
3b00: 20 22 75 72 6c 2d 70 61 74 68 3d 22 20 75 72 6c "url-path=" url
3b10: 2d 70 61 74 68 20 22 20 70 61 72 74 73 3d 22 20 -path " parts="
3b20: 70 61 72 74 73 29 0a 09 20 20 28 69 66 20 28 3e parts).. (if (>
3b30: 20 6e 75 6d 70 61 72 74 73 20 31 29 0a 09 20 20 numparts 1)..
3b40: 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 (sdat-set-pa
3b50: 74 68 2d 70 61 72 61 6d 73 21 20 73 65 6c 66 20 th-params! self
3b60: 28 63 64 72 20 70 61 72 74 73 29 29 29 0a 20 20 (cdr parts))).
3b70: 20 20 20 20 20 20 20 20 28 69 66 20 71 75 65 72 (if quer
3b80: 79 2d 73 74 72 69 6e 67 0a 20 20 20 20 20 20 20 y-string.
3b90: 20 20 20 20 20 20 20 28 73 64 61 74 2d 73 65 74 (sdat-set
3ba0: 2d 70 61 72 61 6d 73 21 20 73 65 6c 66 20 28 73 -params! self (s
3bb0: 74 72 69 6e 67 2d 73 70 6c 69 74 20 71 75 65 72 tring-split quer
3bc0: 79 2d 73 74 72 69 6e 67 20 22 26 22 29 29 29 29 y-string "&"))))
3bd0: 29 29 29 0a 0a 3b 3b 20 42 55 47 47 59 21 0a 28 )))..;; BUGGY!.(
3be0: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
3bf0: 67 65 74 2d 6e 65 77 2d 6b 65 79 20 73 65 6c 66 get-new-key self
3c00: 29 0a 20 20 28 6c 65 74 20 28 28 63 6f 6e 6e 20 ). (let ((conn
3c10: 20 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e (sdat-get-conn
3c20: 20 73 65 6c 66 29 29 0a 20 20 20 20 20 20 20 20 self)).
3c30: 28 74 6d 70 6b 65 79 20 28 73 65 73 73 69 6f 6e (tmpkey (session
3c40: 3a 6d 61 6b 65 2d 72 61 6e 64 2d 73 74 72 69 6e :make-rand-strin
3c50: 67 20 32 30 29 29 0a 20 20 20 20 20 20 20 20 28 g 20)). (
3c60: 73 74 61 74 75 73 20 23 66 29 29 0a 20 20 20 20 status #f)).
3c70: 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f (dbi:for-each-ro
3c80: 77 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 w (lambda (tuple
3c90: 29 0a 09 09 09 28 73 65 74 21 20 73 74 61 74 75 )....(set! statu
3ca0: 73 20 23 74 29 29 0a 09 09 20 20 20 20 20 20 63 s #t))... c
3cb0: 6f 6e 6e 20 28 73 74 72 69 6e 67 2d 61 70 70 65 onn (string-appe
3cc0: 6e 64 20 22 49 4e 53 45 52 54 20 49 4e 54 4f 20 nd "INSERT INTO
3cd0: 73 65 73 73 69 6f 6e 73 20 28 73 65 73 73 69 6f sessions (sessio
3ce0: 6e 5f 6b 65 79 29 20 56 41 4c 55 45 53 20 28 27 n_key) VALUES ('
3cf0: 22 20 74 6d 70 6b 65 79 20 22 27 29 22 29 29 0a " tmpkey "')")).
3d00: 20 20 20 20 74 6d 70 6b 65 79 29 29 0a 0a 3b 3b tmpkey))..;;
3d10: 20 72 65 74 75 72 6e 73 20 73 65 73 73 69 6f 6e returns session
3d20: 20 6b 65 79 20 49 46 46 20 69 74 20 69 73 20 69 key IFF it is i
3d30: 6e 20 74 68 65 20 48 54 54 50 5f 43 4f 4f 4b 49 n the HTTP_COOKI
3d40: 45 20 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 E .(define (sess
3d50: 69 6f 6e 3a 65 78 74 72 61 63 74 2d 73 65 73 73 ion:extract-sess
3d60: 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 0a 20 20 ion-key self).
3d70: 28 6c 65 74 20 28 28 68 74 74 70 2d 63 6f 6f 6b (let ((http-cook
3d80: 69 65 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d ie (get-environm
3d90: 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 48 54 ent-variable "HT
3da0: 54 50 5f 43 4f 4f 4b 49 45 22 29 29 29 0a 20 20 TP_COOKIE"))).
3db0: 20 20 3b 3b 20 28 65 72 72 3a 6c 6f 67 20 22 68 ;; (err:log "h
3dc0: 74 74 70 2d 63 6f 6f 6b 69 65 3a 20 22 20 68 74 ttp-cookie: " ht
3dd0: 74 70 2d 63 6f 6f 6b 69 65 29 0a 20 20 20 20 28 tp-cookie). (
3de0: 69 66 20 68 74 74 70 2d 63 6f 6f 6b 69 65 0a 20 if http-cookie.
3df0: 20 20 20 20 20 20 20 28 73 65 73 73 69 6f 6e 3a (session:
3e00: 65 78 74 72 61 63 74 2d 6b 65 79 2d 66 72 6f 6d extract-key-from
3e10: 2d 70 61 72 61 6d 20 73 65 6c 66 20 28 73 74 72 -param self (str
3e20: 69 6e 67 2d 73 70 6c 69 74 2d 66 69 65 6c 64 73 ing-split-fields
3e30: 20 20 22 3b 5c 5c 73 2b 22 20 68 74 74 70 2d 63 ";\\s+" http-c
3e40: 6f 6f 6b 69 65 20 69 6e 66 69 78 3a 29 20 22 73 ookie infix:) "s
3e50: 65 73 73 69 6f 6e 5f 6b 65 79 22 29 0a 20 20 20 ession_key").
3e60: 20 20 20 20 20 23 66 29 29 29 0a 0a 28 64 65 66 #f)))..(def
3e70: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 ine (session:get
3e80: 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 -session-id self
3e90: 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 0a 20 20 session-key).
3ea0: 28 6c 65 74 20 28 28 71 75 65 72 79 20 22 53 45 (let ((query "SE
3eb0: 4c 45 43 54 20 69 64 20 46 52 4f 4d 20 73 65 73 LECT id FROM ses
3ec0: 73 69 6f 6e 73 20 57 48 45 52 45 20 73 65 73 73 sions WHERE sess
3ed0: 69 6f 6e 5f 6b 65 79 3d 3f 3b 22 29 0a 20 20 20 ion_key=?;").
3ee0: 20 20 20 20 20 28 72 65 73 75 6c 74 20 23 66 29 (result #f)
3ef0: 29 0a 20 20 20 20 3b 3b 20 20 20 20 20 28 70 67 ). ;; (pg
3f00: 3a 71 75 65 72 79 2d 66 6f 72 2d 65 61 63 68 20 :query-for-each
3f10: 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 29 0a (lambda (tuple).
3f20: 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 ;;
3f30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3f40: 28 73 65 74 21 20 72 65 73 75 6c 74 20 28 76 65 (set! result (ve
3f50: 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 30 ctor-ref tuple 0
3f60: 29 29 29 20 3b 3b 20 28 76 65 63 74 6f 72 2d 72 ))) ;; (vector-r
3f70: 65 66 20 74 75 70 6c 65 20 30 29 29 29 0a 20 20 ef tuple 0))).
3f80: 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 ;;
3f90: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 3a 73 (s:s
3fa0: 71 6c 70 61 72 61 6d 20 71 75 65 72 79 20 73 65 qlparam query se
3fb0: 73 73 69 6f 6e 2d 6b 65 79 29 0a 20 20 20 20 3b ssion-key). ;
3fc0: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
3fd0: 20 20 20 20 20 20 20 20 20 28 73 64 61 74 2d 67 (sdat-g
3fe0: 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 0a 20 et-conn self)).
3ff0: 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 ;;
4000: 20 20 20 20 20 20 20 20 20 20 20 20 20 63 6f 6e con
4010: 6e 29 0a 20 20 20 20 28 64 62 69 3a 66 6f 72 2d n). (dbi:for-
4020: 65 61 63 68 2d 72 6f 77 20 28 6c 61 6d 62 64 61 each-row (lambda
4030: 20 28 74 75 70 6c 65 29 0a 09 09 09 28 73 65 74 (tuple)....(set
4040: 21 20 72 65 73 75 6c 74 20 28 76 65 63 74 6f 72 ! result (vector
4050: 2d 72 65 66 20 74 75 70 6c 65 20 30 29 29 29 20 -ref tuple 0)))
4060: 3b 3b 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 ;; (vector-ref t
4070: 75 70 6c 65 20 30 29 29 29 0a 09 09 20 20 20 20 uple 0)))...
4080: 20 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e (sdat-get-conn
4090: 20 73 65 6c 66 29 0a 09 09 20 20 20 20 20 20 28 self)... (
40a0: 73 3a 73 71 6c 70 61 72 61 6d 20 71 75 65 72 79 s:sqlparam query
40b0: 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 0a 20 session-key)).
40c0: 20 20 20 72 65 73 75 6c 74 29 29 0a 0a 3b 3b 20 result))..;;
40d0: 64 65 6c 65 74 65 20 61 6c 6c 20 72 65 63 6f 72 delete all recor
40e0: 64 73 20 66 6f 72 20 61 20 73 65 73 73 69 6f 6e ds for a session
40f0: 0a 3b 3b 20 0a 3b 3b 20 4e 45 45 44 53 20 54 4f .;; .;; NEEDS TO
4100: 20 42 45 20 54 52 41 4e 53 41 43 54 49 4f 4e 49 BE TRANSACTIONI
4110: 5a 45 44 21 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 ZED!.;;.(define
4120: 28 73 65 73 73 69 6f 6e 3a 64 65 6c 65 74 65 2d (session:delete-
4130: 73 65 73 73 69 6f 6e 20 73 65 6c 66 20 73 65 73 session self ses
4140: 73 69 6f 6e 2d 6b 65 79 29 0a 20 20 28 6c 65 74 sion-key). (let
4150: 20 28 28 73 65 73 73 69 6f 6e 2d 69 64 20 28 73 ((session-id (s
4160: 65 73 73 69 6f 6e 3a 67 65 74 2d 73 65 73 73 69 ession:get-sessi
4170: 6f 6e 2d 69 64 20 73 65 6c 66 20 73 65 73 73 69 on-id self sessi
4180: 6f 6e 2d 6b 65 79 29 29 0a 20 20 20 20 20 20 20 on-key)).
4190: 20 28 71 72 79 31 20 20 20 20 20 20 20 20 3b 3b (qry1 ;;
41a0: 20 28 63 6f 6e 63 20 22 42 45 47 49 4e 3b 22 0a (conc "BEGIN;".
41b0: 09 09 09 20 20 22 44 45 4c 45 54 45 20 46 52 4f ... "DELETE FRO
41c0: 4d 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 57 M session_vars W
41d0: 48 45 52 45 20 73 65 73 73 69 6f 6e 5f 69 64 3d HERE session_id=
41e0: 3f 3b 22 29 0a 09 28 71 72 79 32 20 20 20 20 20 ?;")..(qry2
41f0: 20 20 20 20 20 20 20 20 22 44 45 4c 45 54 45 20 "DELETE
4200: 46 52 4f 4d 20 73 65 73 73 69 6f 6e 73 20 57 48 FROM sessions WH
4210: 45 52 45 20 69 64 3d 3f 3b 22 29 0a 09 09 20 20 ERE id=?;")...
4220: 20 20 20 3b 3b 20 20 22 43 4f 4d 4d 49 54 3b 22 ;; "COMMIT;"
4230: 29 29 0a 20 20 20 20 20 20 20 20 28 63 6f 6e 6e )). (conn
4240: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
4250: 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c dat-get-conn sel
4260: 66 29 29 29 0a 20 20 20 20 28 69 66 20 73 65 73 f))). (if ses
4270: 73 69 6f 6e 2d 69 64 0a 20 20 20 20 20 20 20 20 sion-id.
4280: 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 (begin.
4290: 20 28 64 62 69 3a 65 78 65 63 20 63 6f 6e 6e 20 (dbi:exec conn
42a0: 71 72 79 31 20 73 65 73 73 69 6f 6e 2d 69 64 29 qry1 session-id)
42b0: 20 3b 3b 20 73 65 73 73 69 6f 6e 2d 69 64 29 0a ;; session-id).
42c0: 09 20 20 28 64 62 69 3a 65 78 65 63 20 63 6f 6e . (dbi:exec con
42d0: 6e 20 71 72 79 32 20 73 65 73 73 69 6f 6e 2d 69 n qry2 session-i
42e0: 64 29 0a 09 20 20 28 73 65 73 73 69 6f 6e 3a 69 d).. (session:i
42f0: 6e 69 74 69 61 6c 69 7a 65 20 73 65 6c 66 29 0a nitialize self).
4300: 09 20 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 75 . (session:setu
4310: 70 20 73 65 6c 66 29 29 29 0a 20 20 20 20 28 6e p self))). (n
4320: 6f 74 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d ot (session:get-
4330: 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 20 session-id self
4340: 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 29 29 0a session-key)))).
4350: 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 65 73 .;; (define (ses
4360: 73 69 6f 6e 3a 64 65 6c 65 74 65 2d 73 65 73 73 sion:delete-sess
4370: 69 6f 6e 20 73 65 6c 66 20 73 65 73 73 69 6f 6e ion self session
4380: 2d 6b 65 79 29 0a 3b 3b 20 20 20 28 6c 65 74 20 -key).;; (let
4390: 28 28 73 65 73 73 69 6f 6e 2d 69 64 20 28 73 65 ((session-id (se
43a0: 73 73 69 6f 6e 3a 67 65 74 2d 73 65 73 73 69 6f ssion:get-sessio
43b0: 6e 2d 69 64 20 73 65 6c 66 20 73 65 73 73 69 6f n-id self sessio
43c0: 6e 2d 6b 65 79 29 29 0a 3b 3b 20 20 20 20 20 20 n-key)).;;
43d0: 20 20 20 28 71 75 65 72 69 65 73 20 20 20 20 28 (queries (
43e0: 6c 69 73 74 20 22 42 45 47 49 4e 3b 22 0a 3b 3b list "BEGIN;".;;
43f0: 20 09 09 09 20 20 22 44 45 4c 45 54 45 20 46 52 ... "DELETE FR
4400: 4f 4d 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 OM session_vars
4410: 57 48 45 52 45 20 73 65 73 73 69 6f 6e 5f 69 64 WHERE session_id
4420: 3d 3f 3b 22 0a 3b 3b 20 20 20 20 20 20 20 20 20 =?;".;;
4430: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4440: 20 20 22 44 45 4c 45 54 45 20 46 52 4f 4d 20 73 "DELETE FROM s
4450: 65 73 73 69 6f 6e 73 20 57 48 45 52 45 20 69 64 essions WHERE id
4460: 3d 3f 3b 22 0a 3b 3b 20 09 09 09 20 20 22 43 4f =?;".;; ... "CO
4470: 4d 4d 49 54 3b 22 29 29 0a 3b 3b 20 20 20 20 20 MMIT;")).;;
4480: 20 20 20 20 28 63 6f 6e 6e 20 20 20 20 20 20 20 (conn
4490: 20 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 (sdat-get
44a0: 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 29 0a 3b 3b -conn self))).;;
44b0: 20 20 20 20 20 28 69 66 20 73 65 73 73 69 6f 6e (if session
44c0: 2d 69 64 0a 3b 3b 20 20 20 20 20 20 20 20 20 28 -id.;; (
44d0: 62 65 67 69 6e 0a 3b 3b 20 20 20 20 20 20 20 20 begin.;;
44e0: 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 3b 3b 20 (for-each.;;
44f0: 20 20 20 20 20 20 20 20 20 20 20 28 6c 61 6d 62 (lamb
4500: 64 61 20 28 71 75 65 72 79 29 0a 3b 3b 20 20 20 da (query).;;
4510: 20 20 20 20 20 20 20 20 20 20 20 28 64 62 69 3a (dbi:
4520: 65 78 65 63 20 63 6f 6e 6e 20 71 75 65 72 79 20 exec conn query
4530: 73 65 73 73 69 6f 6e 2d 69 64 29 29 0a 3b 3b 20 session-id)).;;
4540: 09 20 20 20 71 75 65 72 69 65 73 29 0a 3b 3b 20 . queries).;;
4550: 09 20 20 28 69 6e 69 74 69 61 6c 69 7a 65 20 73 . (initialize s
4560: 65 6c 66 20 27 28 29 29 0a 3b 3b 20 09 20 20 28 elf '()).;; . (
4570: 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 20 73 65 session:setup se
4580: 6c 66 29 29 29 0a 3b 3b 20 20 20 20 20 28 6e 6f lf))).;; (no
4590: 74 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 73 t (session:get-s
45a0: 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 20 73 ession-id self s
45b0: 65 73 73 69 6f 6e 2d 6b 65 79 29 29 29 29 0a 0a ession-key))))..
45c0: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
45d0: 3a 65 78 74 72 61 63 74 2d 6b 65 79 20 73 65 6c :extract-key sel
45e0: 66 20 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 28 f key). (let ((
45f0: 70 61 72 61 6d 73 20 28 73 64 61 74 2d 67 65 74 params (sdat-get
4600: 2d 70 61 72 61 6d 73 20 73 65 6c 66 29 29 29 0a -params self))).
4610: 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 65 78 74 (session:ext
4620: 72 61 63 74 2d 6b 65 79 2d 66 72 6f 6d 2d 70 61 ract-key-from-pa
4630: 72 61 6d 20 73 65 6c 66 20 70 61 72 61 6d 73 20 ram self params
4640: 6b 65 79 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 key)))..(define
4650: 28 73 65 73 73 69 6f 6e 3a 65 78 74 72 61 63 74 (session:extract
4660: 2d 6b 65 79 2d 66 72 6f 6d 2d 70 61 72 61 6d 20 -key-from-param
4670: 73 65 6c 66 20 70 61 72 61 6d 73 20 6b 65 79 29 self params key)
4680: 0a 20 20 28 6c 65 74 20 28 28 72 31 20 20 20 20 . (let ((r1
4690: 20 28 72 65 67 65 78 70 20 28 73 74 72 69 6e 67 (regexp (string
46a0: 2d 61 70 70 65 6e 64 20 22 5e 22 20 6b 65 79 20 -append "^" key
46b0: 22 3d 28 5b 5e 3d 5d 2b 29 24 22 29 29 29 29 0a "=([^=]+)$")))).
46c0: 20 20 20 20 28 65 72 72 3a 6c 6f 67 20 22 49 4e (err:log "IN
46d0: 46 4f 3a 20 4c 6f 6f 6b 69 6e 67 20 66 6f 72 20 FO: Looking for
46e0: 22 20 6b 65 79 20 22 20 69 6e 20 22 20 70 61 72 " key " in " par
46f0: 61 6d 73 29 0a 20 20 20 20 28 69 66 20 28 3c 20 ams). (if (<
4700: 28 6c 65 6e 67 74 68 20 70 61 72 61 6d 73 29 20 (length params)
4710: 31 29 20 23 66 0a 09 28 6c 65 74 20 6c 6f 6f 70 1) #f..(let loop
4720: 20 28 28 68 65 61 64 20 20 20 28 63 61 72 20 70 ((head (car p
4730: 61 72 61 6d 73 29 29 0a 09 09 20 20 20 28 74 61 arams))... (ta
4740: 69 6c 20 20 20 28 63 64 72 20 70 61 72 61 6d 73 il (cdr params
4750: 29 29 29 0a 09 20 20 28 6c 65 74 20 28 28 6d 61 ))).. (let ((ma
4760: 74 63 68 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 tch (string-matc
4770: 68 20 72 31 20 68 65 61 64 29 29 29 0a 09 20 20 h r1 head)))..
4780: 20 20 28 63 6f 6e 64 0a 09 20 20 20 20 20 28 6d (cond.. (m
4790: 61 74 63 68 0a 09 20 20 20 20 20 20 28 6c 65 74 atch.. (let
47a0: 20 28 28 73 65 73 73 69 6f 6e 2d 6b 65 79 20 28 ((session-key (
47b0: 6c 69 73 74 2d 72 65 66 20 6d 61 74 63 68 20 31 list-ref match 1
47c0: 29 29 29 0a 09 09 28 65 72 72 3a 6c 6f 67 20 22 )))...(err:log "
47d0: 49 4e 46 4f 3a 20 46 6f 75 6e 64 20 73 65 73 73 INFO: Found sess
47e0: 69 6f 6e 20 6b 65 79 3d 22 20 73 65 73 73 69 6f ion key=" sessio
47f0: 6e 2d 6b 65 79 29 0a 09 09 28 73 64 61 74 2d 73 n-key)...(sdat-s
4800: 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 21 20 et-session-key!
4810: 73 65 6c 66 20 28 6c 69 73 74 2d 72 65 66 20 6d self (list-ref m
4820: 61 74 63 68 20 31 29 29 0a 09 09 73 65 73 73 69 atch 1))...sessi
4830: 6f 6e 2d 6b 65 79 29 29 0a 09 20 20 20 20 20 28 on-key)).. (
4840: 28 6e 75 6c 6c 3f 20 74 61 69 6c 29 0a 09 20 20 (null? tail)..
4850: 20 20 20 20 23 66 29 0a 09 20 20 20 20 20 28 65 #f).. (e
4860: 6c 73 65 0a 09 20 20 20 20 20 20 28 6c 6f 6f 70 lse.. (loop
4870: 20 28 63 61 72 20 74 61 69 6c 29 0a 09 09 20 20 (car tail)...
4880: 20 20 28 63 64 72 20 74 61 69 6c 29 29 29 29 29 (cdr tail)))))
4890: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 ))))..(define (s
48a0: 65 73 73 69 6f 6e 3a 73 65 74 2d 70 61 67 65 21 ession:set-page!
48b0: 20 73 65 6c 66 20 70 61 67 65 5f 6e 61 6d 65 29 self page_name)
48c0: 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 67 . (sdat-set-pag
48d0: 65 21 20 73 65 6c 66 20 70 61 67 65 5f 6e 61 6d e! self page_nam
48e0: 65 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 e))..(define (se
48f0: 73 73 69 6f 6e 3a 63 6c 6f 73 65 20 73 65 6c 66 ssion:close self
4900: 29 0a 20 20 28 64 62 69 3a 63 6c 6f 73 65 20 28 ). (dbi:close (
4910: 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 sdat-get-conn se
4920: 6c 66 29 29 29 0a 3b 3b 20 28 63 6c 6f 73 65 2d lf))).;; (close-
4930: 6f 75 74 70 75 74 2d 70 6f 72 74 20 28 73 64 61 output-port (sda
4940: 74 2d 67 65 74 2d 6c 6f 67 70 74 20 73 65 6c 66 t-get-logpt self
4950: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 ))..(define (ses
4960: 73 69 6f 6e 3a 65 72 72 2d 6d 73 67 20 73 65 6c sion:err-msg sel
4970: 66 20 6d 73 67 29 0a 20 20 28 68 61 73 68 2d 74 f msg). (hash-t
4980: 61 62 6c 65 2d 73 65 74 21 20 28 73 64 61 74 2d able-set! (sdat-
4990: 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 20 get-sessionvars
49a0: 73 65 6c 66 29 20 22 45 52 52 4f 52 5f 4d 53 47 self) "ERROR_MSG
49b0: 22 0a 09 09 20 20 20 28 73 74 72 69 6e 67 2d 69 "... (string-i
49c0: 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 20 ntersperse (map
49d0: 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6d 73 s:any->string ms
49e0: 67 29 20 22 20 22 29 29 29 0a 0a 28 64 65 66 69 g) " ")))..(defi
49f0: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 70 72 65 76 ne (session:prev
4a00: 2d 65 72 72 20 73 65 6c 66 29 0a 20 20 28 6c 65 -err self). (le
4a10: 74 20 28 28 70 72 65 76 2d 65 72 72 20 28 68 61 t ((prev-err (ha
4a20: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
4a30: 61 75 6c 74 20 28 73 64 61 74 2d 67 65 74 2d 73 ault (sdat-get-s
4a40: 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 essionvars-befor
4a50: 65 20 73 65 6c 66 29 20 22 45 52 52 4f 52 5f 4d e self) "ERROR_M
4a60: 53 47 22 20 23 66 29 29 0a 09 28 63 75 72 72 2d SG" #f))..(curr-
4a70: 65 72 72 20 28 68 61 73 68 2d 74 61 62 6c 65 2d err (hash-table-
4a80: 72 65 66 2f 64 65 66 61 75 6c 74 20 28 73 64 61 ref/default (sda
4a90: 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 t-get-sessionvar
4aa0: 73 20 73 65 6c 66 29 20 22 45 52 52 4f 52 5f 4d s self) "ERROR_M
4ab0: 53 47 22 20 23 66 29 29 29 0a 20 20 20 20 28 69 SG" #f))). (i
4ac0: 66 20 70 72 65 76 2d 65 72 72 20 70 72 65 76 2d f prev-err prev-
4ad0: 65 72 72 0a 09 28 69 66 20 63 75 72 72 2d 65 72 err..(if curr-er
4ae0: 72 20 63 75 72 72 2d 65 72 72 20 23 66 29 29 29 r curr-err #f)))
4af0: 29 0a 0a 3b 3b 20 73 65 73 73 69 6f 6e 20 76 61 )..;; session va
4b00: 72 73 0a 3b 3b 20 31 2e 20 6b 65 79 73 20 61 72 rs.;; 1. keys ar
4b10: 65 20 61 6c 77 61 79 73 20 61 20 73 74 72 69 6e e always a strin
4b20: 67 20 4e 4f 54 20 61 20 73 79 6d 62 6f 6c 0a 3b g NOT a symbol.;
4b30: 3b 20 32 2e 20 76 61 6c 75 65 73 20 61 72 65 20 ; 2. values are
4b40: 61 6c 77 61 79 73 20 61 20 73 74 72 69 6e 67 20 always a string
4b50: 63 6f 6e 76 65 72 73 69 6f 6e 20 69 73 20 74 68 conversion is th
4b60: 65 20 72 65 73 70 6f 6e 73 69 62 69 6c 69 74 79 e responsibility
4b70: 20 6f 66 20 74 68 65 20 0a 3b 3b 20 20 20 20 63 of the .;; c
4b80: 6f 6e 73 75 6d 69 6e 67 20 66 75 6e 63 74 69 6f onsuming functio
4b90: 6e 20 28 61 74 20 6c 65 61 73 74 20 66 6f 72 20 n (at least for
4ba0: 6e 6f 77 2c 20 49 27 64 20 6c 69 6b 65 20 74 6f now, I'd like to
4bb0: 20 63 68 61 6e 67 65 20 74 68 69 73 29 0a 0a 3b change this)..;
4bc0: 3b 20 73 65 74 20 61 20 73 65 73 73 69 6f 6e 20 ; set a session
4bd0: 76 61 72 20 66 6f 72 20 74 68 65 20 63 75 72 72 var for the curr
4be0: 65 6e 74 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 ent page.;;.(def
4bf0: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 63 75 72 ine (session:cur
4c00: 72 2d 70 61 67 65 2d 73 65 74 21 20 73 65 6c 66 r-page-set! self
4c10: 20 6b 65 79 20 76 61 6c 75 65 29 0a 20 20 28 68 key value). (h
4c20: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 28 ash-table-set! (
4c30: 73 64 61 74 2d 67 65 74 2d 70 61 67 65 76 61 72 sdat-get-pagevar
4c40: 73 20 73 65 6c 66 29 20 28 73 3a 61 6e 79 2d 3e s self) (s:any->
4c50: 73 74 72 69 6e 67 20 6b 65 79 29 20 28 73 3a 61 string key) (s:a
4c60: 6e 79 2d 3e 73 74 72 69 6e 67 20 76 61 6c 75 65 ny->string value
4c70: 29 29 29 0a 0a 3b 3b 20 64 65 6c 20 61 20 76 61 )))..;; del a va
4c80: 72 20 66 6f 72 20 74 68 65 20 63 75 72 72 65 6e r for the curren
4c90: 74 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 69 6e t page.;;.(defin
4ca0: 65 20 28 73 65 73 73 69 6f 6e 3a 70 61 67 65 2d e (session:page-
4cb0: 76 61 72 2d 64 65 6c 21 20 73 65 6c 66 20 6b 65 var-del! self ke
4cc0: 79 29 0a 20 20 28 68 61 73 68 2d 74 61 62 6c 65 y). (hash-table
4cd0: 2d 64 65 6c 65 74 65 21 20 28 73 64 61 74 2d 67 -delete! (sdat-g
4ce0: 65 74 2d 70 61 67 65 76 61 72 73 20 73 65 6c 66 et-pagevars self
4cf0: 29 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 ) (s:any->string
4d00: 20 6b 65 79 29 29 29 0a 0a 3b 3b 20 67 65 74 20 key)))..;; get
4d10: 74 68 65 20 61 70 70 72 6f 70 72 69 61 74 65 20 the appropriate
4d20: 68 61 73 68 20 67 69 76 65 6e 20 61 20 70 61 67 hash given a pag
4d30: 65 20 22 2a 73 65 73 73 69 6f 6e 76 61 72 73 2a e "*sessionvars*
4d40: 2c 20 2a 67 6c 6f 62 61 6c 76 61 72 73 2a 20 6f , *globalvars* o
4d50: 72 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 69 6e r page.;;.(defin
4d60: 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 e (session:get-p
4d70: 61 67 65 2d 68 61 73 68 20 73 65 6c 66 20 70 61 age-hash self pa
4d80: 67 65 29 0a 20 20 28 69 66 20 28 73 74 72 69 6e ge). (if (strin
4d90: 67 3d 3f 20 70 61 67 65 20 22 2a 73 65 73 73 69 g=? page "*sessi
4da0: 6f 6e 76 61 72 73 2a 22 29 0a 20 20 20 20 20 20 onvars*").
4db0: 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f (sdat-get-sessio
4dc0: 6e 76 61 72 73 20 73 65 6c 66 29 0a 20 20 20 20 nvars self).
4dd0: 20 20 28 69 66 20 28 73 74 72 69 6e 67 3d 3f 20 (if (string=?
4de0: 70 61 67 65 20 22 2a 67 6c 6f 62 61 6c 76 61 72 page "*globalvar
4df0: 73 2a 22 29 0a 09 20 20 28 73 64 61 74 2d 67 65 s*").. (sdat-ge
4e00: 74 2d 67 6c 6f 62 61 6c 76 61 72 73 20 73 65 6c t-globalvars sel
4e10: 66 29 0a 09 20 20 28 73 64 61 74 2d 67 65 74 2d f).. (sdat-get-
4e20: 70 61 67 65 76 61 72 73 20 73 65 6c 66 29 29 29 pagevars self)))
4e30: 29 0a 0a 3b 3b 20 73 65 74 20 61 20 73 65 73 73 )..;; set a sess
4e40: 69 6f 6e 20 76 61 72 20 66 6f 72 20 61 20 67 69 ion var for a gi
4e50: 76 65 6e 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 ven page.;;.(def
4e60: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 ine (session:set
4e70: 21 20 73 65 6c 66 20 70 61 67 65 20 6b 65 79 20 ! self page key
4e80: 76 61 6c 75 65 29 0a 20 20 28 6c 65 74 20 28 28 value). (let ((
4e90: 68 74 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d ht (session:get-
4ea0: 70 61 67 65 2d 68 61 73 68 20 73 65 6c 66 20 70 page-hash self p
4eb0: 61 67 65 29 29 29 0a 20 20 20 20 28 68 61 73 68 age))). (hash
4ec0: 2d 74 61 62 6c 65 2d 73 65 74 21 20 68 74 20 28 -table-set! ht (
4ed0: 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6b 65 s:any->string ke
4ee0: 79 29 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e y) (s:any->strin
4ef0: 67 20 76 61 6c 75 65 29 29 29 29 0a 0a 3b 3b 20 g value))))..;;
4f00: 67 65 74 20 73 65 73 73 69 6f 6e 20 76 61 72 73 get session vars
4f10: 20 66 6f 72 20 74 68 65 20 63 75 72 72 65 6e 74 for the current
4f20: 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 page.;;.(define
4f30: 20 28 73 65 73 73 69 6f 6e 3a 70 61 67 65 2d 67 (session:page-g
4f40: 65 74 20 73 65 6c 66 20 6b 65 79 29 0a 20 20 28 et self key). (
4f50: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
4f60: 65 66 61 75 6c 74 20 28 73 64 61 74 2d 67 65 74 efault (sdat-get
4f70: 2d 70 61 67 65 76 61 72 73 20 73 65 6c 66 29 20 -pagevars self)
4f80: 6b 65 79 20 23 66 29 29 0a 0a 3b 3b 20 67 65 74 key #f))..;; get
4f90: 20 73 65 73 73 69 6f 6e 20 76 61 72 73 20 66 6f session vars fo
4fa0: 72 20 61 20 73 70 65 63 69 66 69 65 64 20 70 61 r a specified pa
4fb0: 67 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 ge.;;.(define (s
4fc0: 65 73 73 69 6f 6e 3a 67 65 74 20 73 65 6c 66 20 ession:get self
4fd0: 70 61 67 65 20 6b 65 79 20 70 61 72 61 6d 73 29 page key params)
4fe0: 0a 20 20 28 6c 65 74 2a 20 28 28 68 74 20 20 28 . (let* ((ht (
4ff0: 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 67 65 session:get-page
5000: 2d 68 61 73 68 20 73 65 6c 66 20 70 61 67 65 29 -hash self page)
5010: 29 0a 09 20 28 72 65 73 20 28 68 61 73 68 2d 74 ).. (res (hash-t
5020: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
5030: 20 68 74 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 ht (s:any->stri
5040: 6e 67 20 6b 65 79 29 20 23 66 29 29 29 0a 20 20 ng key) #f))).
5050: 20 20 28 73 65 73 73 69 6f 6e 3a 61 70 70 6c 79 (session:apply
5060: 2d 74 79 70 65 2d 70 72 65 66 65 72 65 6e 63 65 -type-preference
5070: 20 72 65 73 20 70 61 72 61 6d 73 29 29 29 0a 0a res params)))..
5080: 3b 3b 20 64 65 6c 65 74 65 20 61 20 73 65 73 73 ;; delete a sess
5090: 69 6f 6e 20 76 61 72 20 66 6f 72 20 61 20 73 70 ion var for a sp
50a0: 65 63 69 66 69 65 64 20 70 61 67 65 0a 3b 3b 0a ecified page.;;.
50b0: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
50c0: 3a 64 65 6c 21 20 73 65 6c 66 20 70 61 67 65 20 :del! self page
50d0: 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 28 68 74 key). (let ((ht
50e0: 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 (session:get-pa
50f0: 67 65 2d 68 61 73 68 20 73 65 6c 66 20 70 61 67 ge-hash self pag
5100: 65 29 29 29 0a 20 20 20 20 28 68 61 73 68 2d 74 e))). (hash-t
5110: 61 62 6c 65 2d 64 65 6c 65 74 65 21 20 68 74 20 able-delete! ht
5120: 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6b (s:any->string k
5130: 65 79 29 29 29 29 0a 0a 3b 3b 20 67 65 74 20 41 ey))))..;; get A
5140: 4c 4c 20 6b 65 79 73 20 66 6f 72 20 74 68 69 73 LL keys for this
5150: 20 70 61 67 65 20 61 6e 64 20 73 74 6f 72 65 20 page and store
5160: 69 6e 20 74 68 65 20 73 65 73 73 69 6f 6e 20 70 in the session p
5170: 61 67 65 76 61 72 73 20 68 61 73 68 0a 3b 3b 0a agevars hash.;;.
5180: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
5190: 3a 67 65 74 2d 76 61 72 73 20 73 65 6c 66 29 0a :get-vars self).
51a0: 20 20 28 6c 65 74 20 28 28 73 65 73 73 69 6f 6e (let ((session
51b0: 2d 69 64 20 20 28 73 64 61 74 2d 67 65 74 2d 73 -id (sdat-get-s
51c0: 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 29 29 ession-id self))
51d0: 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 73 ). (if (not s
51e0: 65 73 73 69 6f 6e 2d 69 64 29 0a 09 28 65 72 72 ession-id)..(err
51f0: 3a 6c 6f 67 20 22 45 52 52 4f 52 3a 20 4e 6f 20 :log "ERROR: No
5200: 73 65 73 73 69 6f 6e 20 69 64 20 69 6e 20 73 65 session id in se
5210: 73 73 69 6f 6e 20 6f 62 6a 65 63 74 21 20 73 65 ssion object! se
5220: 73 73 69 6f 6e 3a 67 65 74 2d 76 61 72 73 22 29 ssion:get-vars")
5230: 0a 09 28 6c 65 74 2a 20 28 28 72 65 73 75 6c 74 ..(let* ((result
5240: 20 20 20 20 20 20 20 20 20 20 20 20 20 23 66 29 #f)
5250: 0a 09 20 20 20 20 20 20 20 28 63 6f 6e 6e 20 20 .. (conn
5260: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 64 (sd
5270: 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 at-get-conn self
5280: 29 29 0a 09 20 20 20 20 20 20 20 28 70 61 67 65 )).. (page
5290: 76 61 72 73 2d 62 65 66 6f 72 65 20 20 20 20 28 vars-before (
52a0: 73 64 61 74 2d 67 65 74 2d 70 61 67 65 76 61 72 sdat-get-pagevar
52b0: 73 2d 62 65 66 6f 72 65 20 73 65 6c 66 29 29 0a s-before self)).
52c0: 09 20 20 20 20 20 20 20 28 73 65 73 73 69 6f 6e . (session
52d0: 76 61 72 73 2d 62 65 66 6f 72 65 20 28 73 64 61 vars-before (sda
52e0: 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 t-get-sessionvar
52f0: 73 2d 62 65 66 6f 72 65 20 73 65 6c 66 29 29 0a s-before self)).
5300: 09 20 20 20 20 20 20 20 28 67 6c 6f 62 61 6c 76 . (globalv
5310: 61 72 73 2d 62 65 66 6f 72 65 20 20 28 73 64 61 ars-before (sda
5320: 74 2d 67 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 t-get-globalvars
5330: 2d 62 65 66 6f 72 65 20 73 65 6c 66 29 29 0a 09 -before self))..
5340: 20 20 20 20 20 20 20 28 70 61 67 65 76 61 72 73 (pagevars
5350: 20 20 20 20 20 20 20 20 20 20 20 28 73 64 61 74 (sdat
5360: 2d 67 65 74 2d 70 61 67 65 76 61 72 73 20 73 65 -get-pagevars se
5370: 6c 66 29 29 0a 09 20 20 20 20 20 20 20 28 73 65 lf)).. (se
5380: 73 73 69 6f 6e 76 61 72 73 20 20 20 20 20 20 20 ssionvars
5390: 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 (sdat-get-sessi
53a0: 6f 6e 76 61 72 73 20 73 65 6c 66 29 29 0a 09 20 onvars self))..
53b0: 20 20 20 20 20 20 28 67 6c 6f 62 61 6c 76 61 72 (globalvar
53c0: 73 20 20 20 20 20 20 20 20 20 28 73 64 61 74 2d s (sdat-
53d0: 67 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 20 73 get-globalvars s
53e0: 65 6c 66 29 29 0a 09 20 20 20 20 20 20 20 28 70 elf)).. (p
53f0: 61 67 65 2d 6e 61 6d 65 20 20 20 20 20 20 20 20 age-name
5400: 20 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 (sdat-get-page
5410: 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 20 20 self))..
5420: 28 73 65 73 73 69 6f 6e 2d 6b 65 79 20 20 20 20 (session-key
5430: 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d 73 65 (sdat-get-se
5440: 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 29 ssion-key self))
5450: 0a 09 20 20 20 20 20 20 20 28 71 75 65 72 79 20 .. (query
5460: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 74 (st
5470: 72 69 6e 67 2d 61 70 70 65 6e 64 0a 09 09 09 09 ring-append.....
5480: 20 20 20 20 22 53 45 4c 45 43 54 20 6b 65 79 2c "SELECT key,
5490: 76 61 6c 75 65 20 46 52 4f 4d 20 73 65 73 73 69 value FROM sessi
54a0: 6f 6e 5f 76 61 72 73 20 49 4e 4e 45 52 20 4a 4f on_vars INNER JO
54b0: 49 4e 20 73 65 73 73 69 6f 6e 73 20 4f 4e 20 73 IN sessions ON s
54c0: 65 73 73 69 6f 6e 5f 76 61 72 73 2e 73 65 73 73 ession_vars.sess
54d0: 69 6f 6e 5f 69 64 3d 73 65 73 73 69 6f 6e 73 2e ion_id=sessions.
54e0: 69 64 20 22 0a 09 09 09 09 20 20 20 20 22 57 48 id "..... "WH
54f0: 45 52 45 20 73 65 73 73 69 6f 6e 5f 6b 65 79 3d ERE session_key=
5500: 3f 20 41 4e 44 20 70 61 67 65 3d 3f 3b 22 29 29 ? AND page=?;"))
5510: 29 0a 09 20 20 3b 3b 20 66 69 72 73 74 20 74 68 ).. ;; first th
5520: 65 20 70 61 67 65 20 73 70 65 63 69 66 69 63 20 e page specific
5530: 76 61 72 73 0a 09 20 20 28 64 62 69 3a 66 6f 72 vars.. (dbi:for
5540: 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 6d 62 64 -each-row (lambd
5550: 61 20 28 74 75 70 6c 65 29 0a 09 09 09 20 20 20 a (tuple)....
5560: 20 20 20 28 6c 65 74 20 28 28 6b 20 28 76 65 63 (let ((k (vec
5570: 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 30 29 tor-ref tuple 0)
5580: 29 0a 09 09 09 09 20 20 20 20 28 76 20 28 76 65 )..... (v (ve
5590: 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 31 ctor-ref tuple 1
55a0: 29 29 29 0a 09 09 09 09 28 68 61 73 68 2d 74 61 ))).....(hash-ta
55b0: 62 6c 65 2d 73 65 74 21 20 70 61 67 65 76 61 72 ble-set! pagevar
55c0: 73 2d 62 65 66 6f 72 65 20 6b 20 76 29 0a 09 09 s-before k v)...
55d0: 09 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 ..(hash-table-se
55e0: 74 21 20 70 61 67 65 76 61 72 73 20 20 20 20 20 t! pagevars
55f0: 20 20 20 6b 20 76 29 29 29 0a 09 09 09 20 20 20 k v)))....
5600: 20 63 6f 6e 6e 0a 09 09 09 20 20 20 20 28 73 3a conn.... (s:
5610: 73 71 6c 70 61 72 61 6d 20 71 75 65 72 79 20 73 sqlparam query s
5620: 65 73 73 69 6f 6e 2d 6b 65 79 20 70 61 67 65 2d ession-key page-
5630: 6e 61 6d 65 29 29 0a 09 20 20 3b 3b 20 74 68 65 name)).. ;; the
5640: 6e 20 74 68 65 20 73 65 73 73 69 6f 6e 20 73 70 n the session sp
5650: 65 63 69 66 69 63 20 76 61 72 73 0a 09 20 20 28 ecific vars.. (
5660: 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 dbi:for-each-row
5670: 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 29 (lambda (tuple)
5680: 0a 09 09 09 20 20 20 20 20 20 28 6c 65 74 20 28 .... (let (
5690: 28 6b 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 (k (vector-ref t
56a0: 75 70 6c 65 20 30 29 29 0a 09 09 09 09 20 20 20 uple 0)).....
56b0: 20 28 76 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (v (vector-ref
56c0: 74 75 70 6c 65 20 31 29 29 29 0a 09 09 09 09 28 tuple 1))).....(
56d0: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
56e0: 73 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 6f sessionvars-befo
56f0: 72 65 20 6b 20 76 29 0a 09 09 09 09 28 68 61 73 re k v).....(has
5700: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 73 65 73 h-table-set! ses
5710: 73 69 6f 6e 76 61 72 73 20 20 20 20 20 20 20 20 sionvars
5720: 6b 20 76 29 29 29 0a 09 09 09 20 20 20 20 63 6f k v))).... co
5730: 6e 6e 0a 09 09 09 20 20 20 20 28 73 3a 73 71 6c nn.... (s:sql
5740: 70 61 72 61 6d 20 71 75 65 72 79 20 73 65 73 73 param query sess
5750: 69 6f 6e 2d 6b 65 79 20 22 2a 73 65 73 73 69 6f ion-key "*sessio
5760: 6e 76 61 72 73 2a 22 29 29 0a 09 20 20 3b 3b 20 nvars*")).. ;;
5770: 61 6e 64 20 66 69 6e 61 6c 6c 79 20 74 68 65 20 and finally the
5780: 67 6c 6f 62 61 6c 20 76 61 72 73 0a 09 20 20 28 global vars.. (
5790: 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 dbi:for-each-row
57a0: 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 29 (lambda (tuple)
57b0: 0a 09 09 09 20 20 20 20 20 20 28 6c 65 74 20 28 .... (let (
57c0: 28 6b 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 (k (vector-ref t
57d0: 75 70 6c 65 20 30 29 29 0a 09 09 09 09 20 20 20 uple 0)).....
57e0: 20 28 76 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (v (vector-ref
57f0: 74 75 70 6c 65 20 31 29 29 29 0a 09 09 09 09 28 tuple 1))).....(
5800: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
5810: 67 6c 6f 62 61 6c 76 61 72 73 2d 62 65 66 6f 72 globalvars-befor
5820: 65 20 6b 20 76 29 0a 09 09 09 09 28 68 61 73 68 e k v).....(hash
5830: 2d 74 61 62 6c 65 2d 73 65 74 21 20 67 6c 6f 62 -table-set! glob
5840: 61 6c 76 61 72 73 20 20 20 20 20 20 20 20 6b 20 alvars k
5850: 76 29 29 29 0a 09 09 09 20 20 20 20 63 6f 6e 6e v))).... conn
5860: 0a 09 09 09 20 20 20 20 28 73 3a 73 71 6c 70 61 .... (s:sqlpa
5870: 72 61 6d 20 71 75 65 72 79 20 73 65 73 73 69 6f ram query sessio
5880: 6e 2d 6b 65 79 20 22 2a 67 6c 6f 62 61 6c 76 61 n-key "*globalva
5890: 72 73 22 29 29 0a 09 20 20 29 29 29 29 0a 0a 28 rs")).. ))))..(
58a0: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
58b0: 73 61 76 65 2d 76 61 72 73 20 73 65 6c 66 29 0a save-vars self).
58c0: 20 20 28 6c 65 74 20 28 28 73 65 73 73 69 6f 6e (let ((session
58d0: 2d 69 64 20 20 28 73 64 61 74 2d 67 65 74 2d 73 -id (sdat-get-s
58e0: 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 29 29 ession-id self))
58f0: 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 73 ). (if (not s
5900: 65 73 73 69 6f 6e 2d 69 64 29 0a 09 28 65 72 72 ession-id)..(err
5910: 3a 6c 6f 67 20 22 45 52 52 4f 52 3a 20 4e 6f 20 :log "ERROR: No
5920: 73 65 73 73 69 6f 6e 20 69 64 20 69 6e 20 73 65 session id in se
5930: 73 73 69 6f 6e 20 6f 62 6a 65 63 74 21 20 73 65 ssion object! se
5940: 73 73 69 6f 6e 3a 67 65 74 2d 76 61 72 73 22 29 ssion:get-vars")
5950: 0a 09 28 6c 65 74 2a 20 28 28 73 74 61 74 75 73 ..(let* ((status
5960: 20 20 20 20 20 20 23 66 29 0a 09 20 20 20 20 20 #f)..
5970: 20 20 28 63 6f 6e 6e 20 20 20 20 20 20 20 20 28 (conn (
5980: 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 sdat-get-conn se
5990: 6c 66 29 29 0a 09 20 20 20 20 20 20 20 28 70 61 lf)).. (pa
59a0: 67 65 2d 6e 61 6d 65 20 20 20 28 73 64 61 74 2d ge-name (sdat-
59b0: 67 65 74 2d 70 61 67 65 20 73 65 6c 66 29 29 0a get-page self)).
59c0: 09 20 20 20 20 20 20 20 28 64 65 6c 2d 71 75 65 . (del-que
59d0: 72 79 20 20 20 22 44 45 4c 45 54 45 20 46 52 4f ry "DELETE FRO
59e0: 4d 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 57 M session_vars W
59f0: 48 45 52 45 20 73 65 73 73 69 6f 6e 5f 69 64 3d HERE session_id=
5a00: 3f 20 41 4e 44 20 70 61 67 65 3d 3f 20 41 4e 44 ? AND page=? AND
5a10: 20 6b 65 79 3d 3f 3b 22 29 0a 09 20 20 20 20 20 key=?;")..
5a20: 20 20 28 69 6e 73 2d 71 75 65 72 79 20 20 20 22 (ins-query "
5a30: 49 4e 53 45 52 54 20 49 4e 54 4f 20 73 65 73 73 INSERT INTO sess
5a40: 69 6f 6e 5f 76 61 72 73 20 28 73 65 73 73 69 6f ion_vars (sessio
5a50: 6e 5f 69 64 2c 70 61 67 65 2c 6b 65 79 2c 76 61 n_id,page,key,va
5a60: 6c 75 65 29 20 56 41 4c 55 45 53 28 3f 2c 3f 2c lue) VALUES(?,?,
5a70: 3f 2c 3f 29 3b 22 29 0a 09 20 20 20 20 20 20 20 ?,?);")..
5a80: 28 75 70 64 2d 71 75 65 72 79 20 20 20 22 55 50 (upd-query "UP
5a90: 44 41 54 45 20 73 65 73 73 69 6f 6e 5f 76 61 72 DATE session_var
5aa0: 73 20 73 65 74 20 76 61 6c 75 65 3d 3f 20 57 48 s set value=? WH
5ab0: 45 52 45 20 6b 65 79 3d 3f 20 41 4e 44 20 73 65 ERE key=? AND se
5ac0: 73 73 69 6f 6e 5f 69 64 3d 3f 20 41 4e 44 20 70 ssion_id=? AND p
5ad0: 61 67 65 3d 3f 3b 22 29 0a 09 20 20 20 20 20 20 age=?;")..
5ae0: 20 28 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 (changed-count
5af0: 30 29 29 0a 09 20 20 3b 3b 20 73 61 76 65 20 74 0)).. ;; save t
5b00: 68 65 20 64 65 6c 74 61 20 6f 6e 6c 79 0a 09 20 he delta only..
5b10: 20 28 66 6f 72 2d 65 61 63 68 0a 09 20 20 20 28 (for-each.. (
5b20: 6c 61 6d 62 64 61 20 28 70 61 67 65 29 20 3b 3b lambda (page) ;;
5b30: 20 70 61 67 65 20 69 73 3a 20 22 2a 67 6c 6f 62 page is: "*glob
5b40: 61 6c 76 61 72 73 2a 22 20 22 2a 73 65 73 73 69 alvars*" "*sessi
5b50: 6f 6e 76 61 72 73 2a 22 20 6f 72 20 6f 74 68 65 onvars*" or othe
5b60: 72 73 74 72 69 6e 67 0a 09 20 20 20 20 20 28 6c rstring.. (l
5b70: 65 74 2a 20 28 28 62 65 66 6f 72 65 2d 61 66 74 et* ((before-aft
5b80: 65 72 2d 68 74 20 28 63 6f 6e 64 0a 09 09 09 09 er-ht (cond.....
5b90: 20 20 20 20 20 20 28 28 73 74 72 69 6e 67 3d 3f ((string=?
5ba0: 20 70 61 67 65 20 22 2a 73 65 73 73 69 6f 6e 76 page "*sessionv
5bb0: 61 72 73 2a 22 29 0a 09 09 09 09 20 20 20 20 20 ars*").....
5bc0: 20 20 28 76 65 63 74 6f 72 20 28 73 64 61 74 2d (vector (sdat-
5bd0: 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 20 get-sessionvars
5be0: 73 65 6c 66 29 0a 09 09 09 09 09 20 20 20 20 20 self)......
5bf0: 20 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 (sdat-get-sess
5c00: 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 20 73 ionvars-before s
5c10: 65 6c 66 29 29 29 0a 09 09 09 09 20 20 20 20 20 elf))).....
5c20: 20 20 28 28 73 74 72 69 6e 67 3d 3f 20 70 61 67 ((string=? pag
5c30: 65 20 22 2a 67 6c 6f 62 61 6c 76 61 72 73 2a 22 e "*globalvars*"
5c40: 29 0a 09 09 09 09 09 28 76 65 63 74 6f 72 20 28 )......(vector (
5c50: 73 64 61 74 2d 67 65 74 2d 67 6c 6f 62 61 6c 76 sdat-get-globalv
5c60: 61 72 73 20 73 65 6c 66 29 0a 09 09 09 09 09 09 ars self).......
5c70: 28 73 64 61 74 2d 67 65 74 2d 67 6c 6f 62 61 6c (sdat-get-global
5c80: 76 61 72 73 2d 62 65 66 6f 72 65 20 73 65 6c 66 vars-before self
5c90: 29 29 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 )))..... (
5ca0: 65 6c 73 65 20 0a 09 09 09 09 09 28 76 65 63 74 else ......(vect
5cb0: 6f 72 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 or (sdat-get-pag
5cc0: 65 76 61 72 73 20 73 65 6c 66 29 0a 09 09 09 09 evars self).....
5cd0: 09 09 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 ..(sdat-get-page
5ce0: 76 61 72 73 2d 62 65 66 6f 72 65 20 73 65 6c 66 vars-before self
5cf0: 29 29 29 29 29 0a 09 09 20 20 20 20 28 6d 61 73 )))))... (mas
5d00: 74 65 72 2d 68 74 20 20 20 28 76 65 63 74 6f 72 ter-ht (vector
5d10: 2d 72 65 66 20 62 65 66 6f 72 65 2d 61 66 74 65 -ref before-afte
5d20: 72 2d 68 74 20 30 29 29 0a 09 09 20 20 20 20 28 r-ht 0))... (
5d30: 62 65 66 6f 72 65 2d 68 74 20 20 20 28 76 65 63 before-ht (vec
5d40: 74 6f 72 2d 72 65 66 20 62 65 66 6f 72 65 2d 61 tor-ref before-a
5d50: 66 74 65 72 2d 68 74 20 31 29 29 0a 09 09 20 20 fter-ht 1))...
5d60: 20 20 28 6d 61 73 74 65 72 2d 6b 65 79 73 20 28 (master-keys (
5d70: 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 hash-table-keys
5d80: 6d 61 73 74 65 72 2d 68 74 29 29 0a 09 09 20 20 master-ht))...
5d90: 20 20 28 62 65 66 6f 72 65 2d 6b 65 79 73 20 28 (before-keys (
5da0: 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 hash-table-keys
5db0: 62 65 66 6f 72 65 2d 68 74 29 29 0a 09 09 20 20 before-ht))...
5dc0: 20 20 28 61 6c 6c 2d 6b 65 79 73 20 28 64 65 6c (all-keys (del
5dd0: 65 74 65 2d 64 75 70 6c 69 63 61 74 65 73 20 28 ete-duplicates (
5de0: 61 70 70 65 6e 64 20 6d 61 73 74 65 72 2d 6b 65 append master-ke
5df0: 79 73 20 62 65 66 6f 72 65 2d 6b 65 79 73 29 29 ys before-keys))
5e00: 29 29 0a 09 20 20 20 20 20 20 20 28 66 6f 72 2d )).. (for-
5e10: 65 61 63 68 20 0a 09 09 28 6c 61 6d 62 64 61 20 each ...(lambda
5e20: 28 6b 65 79 29 0a 09 09 20 20 28 6c 65 74 20 28 (key)... (let (
5e30: 28 6d 61 73 74 65 72 2d 76 61 6c 75 65 20 28 68 (master-value (h
5e40: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
5e50: 66 61 75 6c 74 20 6d 61 73 74 65 72 2d 68 74 20 fault master-ht
5e60: 6b 65 79 20 23 66 29 29 0a 09 09 09 28 62 65 66 key #f))....(bef
5e70: 6f 72 65 2d 76 61 6c 75 65 20 28 68 61 73 68 2d ore-value (hash-
5e80: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
5e90: 74 20 62 65 66 6f 72 65 2d 68 74 20 6b 65 79 20 t before-ht key
5ea0: 23 66 29 29 29 0a 09 09 20 20 20 20 28 63 6f 6e #f)))... (con
5eb0: 64 0a 09 09 20 20 20 20 20 3b 3b 20 62 65 66 6f d... ;; befo
5ec0: 72 65 20 61 6e 64 20 61 66 74 65 72 20 65 78 69 re and after exi
5ed0: 73 74 20 61 6e 64 20 76 61 6c 75 65 20 75 6e 63 st and value unc
5ee0: 68 61 6e 67 65 64 20 2d 20 64 6f 20 6e 6f 74 68 hanged - do noth
5ef0: 69 6e 67 0a 09 09 20 20 20 20 20 28 28 61 6e 64 ing... ((and
5f00: 20 6d 61 73 74 65 72 2d 76 61 6c 75 65 20 62 65 master-value be
5f10: 66 6f 72 65 2d 76 61 6c 75 65 20 28 65 71 75 61 fore-value (equa
5f20: 6c 3f 20 6d 61 73 74 65 72 2d 76 61 6c 75 65 20 l? master-value
5f30: 62 65 66 6f 72 65 2d 76 61 6c 75 65 29 29 29 0a before-value))).
5f40: 09 09 20 20 20 20 20 3b 3b 20 62 65 66 6f 72 65 .. ;; before
5f50: 20 61 6e 64 20 61 66 74 65 72 20 65 78 69 73 74 and after exist
5f60: 20 62 75 74 20 61 72 65 20 63 68 61 6e 67 65 64 but are changed
5f70: 0a 09 09 20 20 20 20 20 28 28 61 6e 64 20 6d 61 ... ((and ma
5f80: 73 74 65 72 2d 76 61 6c 75 65 20 62 65 66 6f 72 ster-value befor
5f90: 65 2d 76 61 6c 75 65 29 0a 09 09 20 20 20 20 20 e-value)...
5fa0: 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 (dbi:for-each-r
5fb0: 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c ow (lambda (tupl
5fc0: 65 29 0a 09 09 09 09 09 20 20 28 73 65 74 21 20 e)...... (set!
5fd0: 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 28 2b changed-count (+
5fe0: 20 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 31 changed-count 1
5ff0: 29 29 29 0a 09 09 09 09 09 63 6f 6e 6e 0a 09 09 )))......conn...
6000: 09 09 09 28 73 3a 73 71 6c 70 61 72 61 6d 20 75 ...(s:sqlparam u
6010: 70 64 2d 71 75 65 72 79 20 6d 61 73 74 65 72 2d pd-query master-
6020: 76 61 6c 75 65 20 6b 65 79 20 73 65 73 73 69 6f value key sessio
6030: 6e 2d 69 64 20 70 61 67 65 29 29 29 0a 09 09 20 n-id page)))...
6040: 20 20 20 20 3b 3b 20 6d 61 73 74 65 72 2d 76 61 ;; master-va
6050: 6c 75 65 20 6e 6f 20 6c 6f 6e 67 65 72 20 65 78 lue no longer ex
6060: 69 73 74 73 20 28 69 2e 65 2e 20 23 66 29 20 2d ists (i.e. #f) -
6070: 20 72 65 6d 6f 76 65 20 69 74 65 6d 0a 09 09 20 remove item...
6080: 20 20 20 20 28 28 6e 6f 74 20 6d 61 73 74 65 72 ((not master
6090: 2d 76 61 6c 75 65 29 0a 09 09 20 20 20 20 20 20 -value)...
60a0: 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f (dbi:for-each-ro
60b0: 77 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 w (lambda (tuple
60c0: 29 0a 09 09 09 09 09 20 20 28 73 65 74 21 20 63 )...... (set! c
60d0: 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 28 2b 20 hanged-count (+
60e0: 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 31 29 changed-count 1)
60f0: 29 29 0a 09 09 09 09 09 63 6f 6e 6e 0a 09 09 09 ))......conn....
6100: 09 09 28 73 3a 73 71 6c 70 61 72 61 6d 20 64 65 ..(s:sqlparam de
6110: 6c 2d 71 75 65 72 79 20 73 65 73 73 69 6f 6e 2d l-query session-
6120: 69 64 20 70 61 67 65 20 6b 65 79 29 29 29 0a 09 id page key)))..
6130: 09 20 20 20 20 20 3b 3b 20 62 65 66 6f 72 65 2d . ;; before-
6140: 76 61 6c 75 65 20 64 6f 65 73 6e 27 74 20 65 78 value doesn't ex
6150: 69 73 74 20 2d 20 69 6e 73 65 72 74 20 61 20 6e ist - insert a n
6160: 65 77 20 76 61 6c 75 65 0a 09 09 20 20 20 20 20 ew value...
6170: 28 28 6e 6f 74 20 62 65 66 6f 72 65 2d 76 61 6c ((not before-val
6180: 75 65 29 0a 09 09 20 20 20 20 20 20 28 64 62 69 ue)... (dbi
6190: 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 28 6c :for-each-row (l
61a0: 61 6d 62 64 61 20 28 74 75 70 6c 65 29 0a 09 09 ambda (tuple)...
61b0: 09 09 09 20 20 28 73 65 74 21 20 63 68 61 6e 67 ... (set! chang
61c0: 65 64 2d 63 6f 75 6e 74 20 28 2b 20 63 68 61 6e ed-count (+ chan
61d0: 67 65 64 2d 63 6f 75 6e 74 20 31 29 29 29 0a 09 ged-count 1)))..
61e0: 09 09 09 09 63 6f 6e 6e 0a 09 09 09 09 09 28 73 ....conn......(s
61f0: 3a 73 71 6c 70 61 72 61 6d 20 69 6e 73 2d 71 75 :sqlparam ins-qu
6200: 65 72 79 20 73 65 73 73 69 6f 6e 2d 69 64 20 70 ery session-id p
6210: 61 67 65 20 6b 65 79 20 6d 61 73 74 65 72 2d 76 age key master-v
6220: 61 6c 75 65 29 29 29 0a 09 09 20 20 20 20 20 28 alue)))... (
6230: 65 6c 73 65 20 28 65 72 72 3a 6c 6f 67 20 22 53 else (err:log "S
6240: 68 6f 75 6c 64 6e 27 74 20 67 65 74 20 68 65 72 houldn't get her
6250: 65 22 29 29 29 29 29 0a 09 09 61 6c 6c 2d 6b 65 e")))))...all-ke
6260: 79 73 29 29 29 20 3b 3b 20 70 72 6f 63 65 73 73 ys))) ;; process
6270: 20 61 6c 6c 20 6b 65 79 73 0a 09 20 20 20 28 6c all keys.. (l
6280: 69 73 74 20 22 2a 73 65 73 73 69 6f 6e 76 61 72 ist "*sessionvar
6290: 73 2a 22 20 22 2a 67 6c 6f 62 61 6c 76 61 72 73 s*" "*globalvars
62a0: 2a 22 20 70 61 67 65 2d 6e 61 6d 65 29 29 29 29 *" page-name))))
62b0: 29 29 0a 0a 3b 3b 20 28 70 67 3a 73 71 6c 2d 6e ))..;; (pg:sql-n
62c0: 75 6c 6c 2d 6f 62 6a 65 63 74 3f 20 65 6c 65 6d ull-object? elem
62d0: 65 6e 74 29 0a 28 64 65 66 69 6e 65 20 28 73 65 ent).(define (se
62e0: 73 73 69 6f 6e 3a 72 65 61 64 2d 63 6f 6e 66 69 ssion:read-confi
62f0: 67 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 2a 20 g self). (let*
6300: 28 28 63 67 69 2d 70 61 74 68 20 28 70 61 74 68 ((cgi-path (path
6310: 6e 61 6d 65 2d 64 69 72 65 63 74 6f 72 79 20 28 name-directory (
6320: 63 61 72 20 28 61 72 67 76 29 29 29 29 0a 20 20 car (argv)))).
6330: 20 20 20 20 20 20 20 28 6e 61 6d 65 20 20 20 20 (name
6340: 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 (string-append
6350: 28 69 66 20 63 67 69 2d 70 61 74 68 20 28 63 6f (if cgi-path (co
6360: 6e 63 20 63 67 69 2d 70 61 74 68 20 22 2f 22 29 nc cgi-path "/")
6370: 20 22 22 29 20 22 2e 22 20 28 70 61 74 68 6e 61 "") "." (pathna
6380: 6d 65 2d 66 69 6c 65 20 28 63 61 72 20 28 61 72 me-file (car (ar
6390: 67 76 29 29 29 20 22 2e 63 6f 6e 66 69 67 22 29 gv))) ".config")
63a0: 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 )). (if (not
63b0: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 6e 61 (file-exists? na
63c0: 6d 65 29 29 0a 09 28 70 72 69 6e 74 20 6e 61 6d me))..(print nam
63d0: 65 20 22 20 6e 6f 74 20 66 6f 75 6e 64 20 61 74 e " not found at
63e0: 20 22 20 28 63 75 72 72 65 6e 74 2d 64 69 72 65 " (current-dire
63f0: 63 74 6f 72 79 29 29 0a 09 28 6c 65 74 2a 20 28 ctory))..(let* (
6400: 28 66 70 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d (fp (open-input-
6410: 66 69 6c 65 20 6e 61 6d 65 29 29 0a 09 20 20 20 file name))..
6420: 20 20 20 20 28 69 6e 69 74 61 72 67 73 20 28 72 (initargs (r
6430: 65 61 64 20 66 70 29 29 29 0a 09 20 20 28 63 6c ead fp))).. (cl
6440: 6f 73 65 2d 69 6e 70 75 74 2d 70 6f 72 74 20 66 ose-input-port f
6450: 70 29 0a 09 20 20 69 6e 69 74 61 72 67 73 29 29 p).. initargs))
6460: 29 29 0a 0a 3b 3b 20 63 61 6c 6c 20 74 68 65 20 ))..;; call the
6470: 63 6f 6e 74 72 6f 6c 6c 65 72 20 69 66 20 69 74 controller if it
6480: 20 65 78 69 73 74 73 0a 3b 3b 20 0a 3b 3b 20 57 exists.;; .;; W
6490: 41 52 4e 49 4e 47 20 2d 20 74 68 69 73 20 63 6f ARNING - this co
64a0: 64 65 20 6e 65 65 64 73 20 61 20 64 65 66 65 6e de needs a defen
64b0: 63 65 20 61 67 61 69 6e 73 20 72 65 63 75 72 73 ce agains recurs
64c0: 69 76 65 20 63 61 6c 6c 69 6e 67 21 21 21 21 21 ive calling!!!!!
64d0: 0a 3b 3b 0a 3b 3b 20 20 20 49 20 73 75 67 67 65 .;;.;; I sugge
64e0: 73 74 20 61 20 6c 69 6d 69 74 20 6f 66 20 31 30 st a limit of 10
64f0: 30 20 63 61 6c 6c 73 2e 20 50 6c 65 6e 74 79 20 0 calls. Plenty
6500: 66 6f 72 20 61 6c 6c 6f 77 69 6e 67 20 6d 75 6c for allowing mul
6510: 74 69 70 6c 65 20 69 6e 73 74 61 6e 63 65 73 0a tiple instances.
6520: 3b 3b 20 20 20 6f 66 20 61 20 70 61 67 65 20 69 ;; of a page i
6530: 6e 73 69 64 65 20 61 6e 6f 74 68 65 72 20 70 61 nside another pa
6540: 67 65 2e 20 0a 3b 3b 0a 3b 3b 20 70 61 72 74 73 ge. .;;.;; parts
6550: 20 3d 20 27 62 6f 74 68 20 7c 20 27 63 6f 6e 74 = 'both | 'cont
6560: 72 6f 6c 20 7c 20 27 76 69 65 77 0a 3b 3b 0a 0a rol | 'view.;;..
6570: 28 64 65 66 69 6e 65 20 28 66 69 6c 65 73 2d 72 (define (files-r
6580: 65 61 64 2d 3e 73 74 72 69 6e 67 20 2e 20 66 69 ead->string . fi
6590: 6c 65 73 29 0a 20 20 28 73 74 72 69 6e 67 2d 69 les). (string-i
65a0: 6e 74 65 72 73 70 65 72 73 65 20 0a 20 20 20 28 ntersperse . (
65b0: 61 70 70 6c 79 20 61 70 70 65 6e 64 20 28 6d 61 apply append (ma
65c0: 70 20 66 69 6c 65 2d 72 65 61 64 2d 3e 73 74 72 p file-read->str
65d0: 69 6e 67 20 66 69 6c 65 73 29 29 20 22 5c 6e 22 ing files)) "\n"
65e0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 66 69 6c ))..(define (fil
65f0: 65 2d 72 65 61 64 2d 3e 73 74 72 69 6e 67 20 66 e-read->string f
6600: 29 20 0a 20 20 28 6c 65 74 20 28 28 70 20 28 6f ) . (let ((p (o
6610: 70 65 6e 2d 69 6e 70 75 74 2d 66 69 6c 65 20 66 pen-input-file f
6620: 29 29 29 0a 20 20 20 20 28 6c 65 74 20 6c 6f 6f ))). (let loo
6630: 70 20 28 28 68 65 64 20 28 72 65 61 64 2d 6c 69 p ((hed (read-li
6640: 6e 65 20 70 29 29 0a 09 20 20 20 20 20 20 20 28 ne p)).. (
6650: 72 65 73 20 27 28 29 29 29 0a 20 20 20 20 20 20 res '())).
6660: 28 69 66 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f (if (eof-object?
6670: 20 68 65 64 29 0a 09 20 20 72 65 73 0a 09 20 20 hed).. res..
6680: 28 6c 6f 6f 70 20 28 72 65 61 64 2d 6c 69 6e 65 (loop (read-line
6690: 20 70 29 28 61 70 70 65 6e 64 20 72 65 73 20 28 p)(append res (
66a0: 6c 69 73 74 20 68 65 64 29 29 29 29 29 29 29 0a list hed))))))).
66b0: 0a 28 64 65 66 69 6e 65 20 28 70 72 6f 63 65 73 .(define (proces
66c0: 73 2d 70 6f 72 74 20 70 29 0a 20 20 28 6c 65 74 s-port p). (let
66d0: 20 28 28 65 20 28 69 6e 74 65 72 61 63 74 69 6f ((e (interactio
66e0: 6e 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 29 29 29 n-environment)))
66f0: 0a 20 20 20 20 28 6d 61 70 20 0a 20 20 20 20 20 . (map .
6700: 28 6c 61 6d 62 64 61 20 28 78 29 0a 20 20 20 20 (lambda (x).
6710: 20 20 20 28 63 6f 6e 64 0a 09 28 28 6c 69 73 74 (cond..((list
6720: 3f 20 78 29 20 78 29 0a 09 28 28 73 74 72 69 6e ? x) x)..((strin
6730: 67 3f 20 78 29 20 78 29 0a 09 28 65 6c 73 65 20 g? x) x)..(else
6740: 27 28 29 29 29 29 0a 20 20 20 20 20 28 70 6f 72 '()))). (por
6750: 74 2d 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 73 t-map (lambda (s
6760: 29 0a 09 09 20 28 65 76 61 6c 20 73 20 65 29 29 )... (eval s e))
6770: 0a 09 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 .. (lambda
6780: 20 28 29 28 72 65 61 64 20 70 29 29 29 29 29 29 ()(read p))))))
6790: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ..(define (sessi
67a0: 6f 6e 3a 70 72 6f 63 65 73 73 2d 66 69 6c 65 20 on:process-file
67b0: 66 29 0a 20 20 28 6c 65 74 2a 20 28 28 70 20 20 f). (let* ((p
67c0: 20 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 66 69 (open-input-fi
67d0: 6c 65 20 66 29 29 0a 09 20 28 64 61 74 20 20 28 le f)).. (dat (
67e0: 70 72 6f 63 65 73 73 2d 70 6f 72 74 20 70 29 29 process-port p))
67f0: 29 0a 20 20 20 20 28 63 6c 6f 73 65 2d 69 6e 70 ). (close-inp
6800: 75 74 2d 70 6f 72 74 20 70 29 0a 20 20 20 20 64 ut-port p). d
6810: 61 74 29 29 0a 0a 3b 3b 20 4d 61 79 20 32 30 31 at))..;; May 201
6820: 31 2c 20 70 75 74 74 69 6e 67 20 61 6c 6c 20 70 1, putting all p
6830: 61 67 65 73 20 69 6e 74 6f 20 6f 6e 65 20 64 69 ages into one di
6840: 72 65 63 74 6f 72 79 20 66 6f 72 20 74 68 65 20 rectory for the
6850: 66 6f 6c 6c 6f 77 69 6e 67 20 72 65 61 73 6f 6e following reason
6860: 73 3a 0a 3b 3b 20 20 20 31 2e 20 77 61 6e 74 20 s:.;; 1. want
6870: 66 69 6c 65 6e 61 6d 65 20 74 6f 20 72 65 66 6c filename to refl
6880: 65 63 74 20 70 61 67 65 20 6e 61 6d 65 20 28 65 ect page name (e
6890: 6d 61 63 73 20 6c 69 6d 69 74 61 74 69 6f 6e 29 macs limitation)
68a0: 0a 3b 3b 20 20 20 32 2e 20 74 68 61 74 27 73 20 .;; 2. that's
68b0: 69 74 21 20 6e 6f 20 6f 74 68 65 72 20 72 65 61 it! no other rea
68c0: 73 6f 6e 2e 20 63 6f 75 6c 64 20 6d 61 6b 65 20 son. could make
68d0: 69 74 20 63 6f 6e 66 69 67 75 72 61 62 6c 65 20 it configurable
68e0: 2e 2e 2e 0a 3b 3b 20 70 61 67 65 2d 64 69 72 2d ....;; page-dir-
68f0: 73 74 79 6c 65 20 69 73 3a 0a 3b 3b 20 20 27 73 style is:.;; 's
6900: 74 6f 72 65 64 20 20 20 3d 3e 20 73 74 6f 72 65 tored => store
6910: 64 20 69 6e 20 65 78 65 63 75 74 61 62 6c 65 0a d in executable.
6920: 3b 3b 20 20 27 66 6c 61 74 20 20 20 20 20 3d 3e ;; 'flat =>
6930: 20 70 61 67 65 73 20 66 6c 61 74 20 64 69 72 65 pages flat dire
6940: 63 74 6f 72 79 0a 3b 3b 20 20 27 64 69 72 20 20 ctory.;; 'dir
6950: 20 20 20 20 3d 3e 20 64 69 72 65 63 74 6f 72 79 => directory
6960: 20 74 72 65 65 20 70 61 67 65 73 2f 3c 70 61 67 tree pages/<pag
6970: 65 6e 61 6d 65 3e 2f 7b 76 69 65 77 2c 63 6f 6e ename>/{view,con
6980: 74 72 6f 6c 7d 2e 73 63 6d 0a 3b 3b 20 70 61 72 trol}.scm.;; par
6990: 74 73 3a 0a 3b 3b 20 20 27 62 6f 74 68 20 20 20 ts:.;; 'both
69a0: 20 20 3d 3e 20 6c 6f 61 64 20 63 6f 6e 74 72 6f => load contro
69b0: 6c 20 61 6e 64 20 76 69 65 77 20 28 61 6e 79 74 l and view (anyt
69c0: 68 69 6e 67 20 6f 74 68 65 72 20 74 68 61 6e 20 hing other than
69d0: 76 69 65 77 20 6f 72 20 63 6f 6e 74 72 6f 6c 20 view or control
69e0: 61 6e 64 20 74 68 65 20 64 65 66 61 75 6c 74 29 and the default)
69f0: 0a 3b 3b 20 20 27 76 69 65 77 20 20 20 20 20 3d .;; 'view =
6a00: 3e 20 6c 6f 61 64 20 76 69 65 77 20 6f 6e 6c 79 > load view only
6a10: 0a 3b 3b 20 20 27 63 6f 6e 74 72 6f 6c 20 20 3d .;; 'control =
6a20: 3e 20 6c 6f 61 64 20 63 6f 6e 74 72 6f 6c 20 6f > load control o
6a30: 6e 6c 79 0a 28 64 65 66 69 6e 65 20 28 73 65 73 nly.(define (ses
6a40: 73 69 6f 6e 3a 63 61 6c 6c 2d 70 61 72 74 73 20 sion:call-parts
6a50: 73 65 6c 66 20 70 61 67 65 20 23 21 6b 65 79 20 self page #!key
6a60: 28 70 61 72 74 73 20 27 62 6f 74 68 29 29 0a 20 (parts 'both)).
6a70: 20 28 73 64 61 74 2d 73 65 74 2d 63 75 72 72 2d (sdat-set-curr-
6a80: 70 61 67 65 21 20 73 65 6c 66 20 70 61 67 65 29 page! self page)
6a90: 0a 20 20 28 6c 65 74 2a 20 28 28 64 69 72 2d 73 . (let* ((dir-s
6aa0: 74 79 6c 65 20 20 20 20 28 73 64 61 74 2d 67 65 tyle (sdat-ge
6ab0: 74 2d 70 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 t-page-dir-style
6ac0: 20 73 65 6c 66 29 29 3b 3b 20 28 65 71 75 61 6c self));; (equal
6ad0: 3f 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 ? (sdat-get-page
6ae0: 2d 64 69 72 2d 73 74 79 6c 65 20 73 65 6c 66 29 -dir-style self)
6af0: 20 22 6f 6e 65 64 69 72 22 29 29 20 3b 3b 20 66 "onedir")) ;; f
6b00: 6c 61 67 20 23 74 20 66 6f 72 20 6f 6e 65 64 69 lag #t for onedi
6b10: 72 2c 20 23 66 20 66 6f 72 20 6f 6c 64 20 73 74 r, #f for old st
6b20: 79 6c 65 0a 09 20 28 64 69 72 20 20 20 20 20 20 yle.. (dir
6b30: 20 20 20 20 28 73 74 72 69 6e 67 2d 61 70 70 65 (string-appe
6b40: 6e 64 20 28 73 64 61 74 2d 67 65 74 2d 73 72 6f nd (sdat-get-sro
6b50: 6f 74 20 73 65 6c 66 29 20 0a 09 09 09 09 20 20 ot self) .....
6b60: 20 20 20 20 28 69 66 20 64 69 72 2d 73 74 79 6c (if dir-styl
6b70: 65 20 0a 09 09 09 09 09 20 20 28 63 6f 6e 63 20 e ...... (conc
6b80: 22 2f 70 61 67 65 73 2f 22 29 0a 09 09 09 09 09 "/pages/")......
6b90: 20 20 28 63 6f 6e 63 20 22 2f 70 61 67 65 73 2f (conc "/pages/
6ba0: 22 20 70 61 67 65 29 29 29 29 29 0a 20 20 20 20 " page))))).
6bb0: 28 63 61 73 65 20 64 69 72 2d 73 74 79 6c 65 0a (case dir-style.
6bc0: 20 20 20 20 20 20 3b 3b 20 4e 42 2f 2f 20 53 74 ;; NB// St
6bd0: 6f 72 65 64 20 61 6c 77 61 79 73 20 6c 6f 61 64 ored always load
6be0: 73 20 62 6f 74 68 20 63 6f 6e 74 72 6f 6c 20 61 s both control a
6bf0: 6e 64 20 76 69 65 77 0a 20 20 20 20 20 20 28 28 nd view. ((
6c00: 73 74 6f 72 65 64 29 0a 20 20 20 20 20 20 20 28 stored). (
6c10: 28 65 76 61 6c 20 28 73 74 72 69 6e 67 2d 3e 73 (eval (string->s
6c20: 79 6d 62 6f 6c 20 28 63 6f 6e 63 20 22 70 61 67 ymbol (conc "pag
6c30: 65 73 3a 22 20 70 61 67 65 29 29 29 20 0a 09 73 es:" page))) ..s
6c40: 65 6c 66 20 20 20 20 20 20 20 20 20 20 20 20 20 elf
6c50: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 74 ;; t
6c60: 68 65 20 73 65 73 73 69 6f 6e 0a 09 28 73 64 61 he session..(sda
6c70: 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 t-get-conn self)
6c80: 20 20 20 20 20 20 20 20 20 3b 3b 20 74 68 65 20 ;; the
6c90: 64 62 20 63 6f 6e 6e 65 63 74 69 6f 6e 0a 09 28 db connection..(
6ca0: 73 64 61 74 2d 67 65 74 2d 73 68 61 72 65 64 2d sdat-get-shared-
6cb0: 68 61 73 68 20 73 65 6c 66 29 20 20 3b 3b 20 61 hash self) ;; a
6cc0: 20 73 68 61 72 65 64 20 68 61 73 68 20 74 61 62 shared hash tab
6cd0: 6c 65 20 66 6f 72 20 70 61 73 73 69 6e 67 20 64 le for passing d
6ce0: 61 74 61 20 74 6f 2f 66 72 6f 6d 20 70 61 67 65 ata to/from page
6cf0: 20 63 61 6c 6c 73 0a 09 29 29 0a 20 20 20 20 20 calls..)).
6d00: 20 28 28 66 6c 61 74 29 20 20 20 0a 20 20 20 20 ((flat) .
6d10: 20 20 20 28 6c 65 74 2a 20 28 28 73 6f 2d 66 69 (let* ((so-fi
6d20: 6c 65 20 20 28 63 6f 6e 63 20 64 69 72 20 70 61 le (conc dir pa
6d30: 67 65 20 22 2e 73 6f 22 29 29 0a 09 20 20 20 20 ge ".so"))..
6d40: 20 20 28 73 63 6d 2d 66 69 6c 65 20 28 63 6f 6e (scm-file (con
6d50: 63 20 64 69 72 20 70 61 67 65 20 22 2e 73 63 6d c dir page ".scm
6d60: 22 29 29 0a 09 20 20 20 20 20 20 28 73 72 63 2d ")).. (src-
6d70: 66 69 6c 65 20 28 6f 72 20 28 66 69 6c 65 2d 65 file (or (file-e
6d80: 78 69 73 74 73 3f 20 73 6f 2d 66 69 6c 65 29 0a xists? so-file).
6d90: 09 09 09 20 20 20 20 28 66 69 6c 65 2d 65 78 69 ... (file-exi
6da0: 73 74 73 3f 20 73 63 6d 2d 66 69 6c 65 29 29 29 sts? scm-file)))
6db0: 29 0a 09 20 28 69 66 20 73 72 63 2d 66 69 6c 65 ).. (if src-file
6dc0: 0a 09 20 20 20 20 20 28 62 65 67 69 6e 0a 09 20 .. (begin..
6dd0: 20 20 20 20 20 20 28 6c 6f 61 64 20 73 72 63 2d (load src-
6de0: 66 69 6c 65 29 0a 09 20 20 20 20 20 20 20 28 28 file).. ((
6df0: 65 76 61 6c 20 28 73 74 72 69 6e 67 2d 3e 73 79 eval (string->sy
6e00: 6d 62 6f 6c 20 28 63 6f 6e 63 20 22 70 61 67 65 mbol (conc "page
6e10: 73 3a 22 20 70 61 67 65 29 29 29 20 0a 09 09 73 s:" page))) ...s
6e20: 65 6c 66 20 20 20 20 20 20 20 20 20 20 20 20 20 elf
6e30: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 74 ;; t
6e40: 68 65 20 73 65 73 73 69 6f 6e 0a 09 09 28 73 64 he session...(sd
6e50: 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 at-get-conn self
6e60: 29 20 20 20 20 20 20 20 20 20 3b 3b 20 74 68 65 ) ;; the
6e70: 20 64 62 20 63 6f 6e 6e 65 63 74 69 6f 6e 0a 09 db connection..
6e80: 09 28 73 64 61 74 2d 67 65 74 2d 73 68 61 72 65 .(sdat-get-share
6e90: 64 2d 68 61 73 68 20 73 65 6c 66 29 20 20 3b 3b d-hash self) ;;
6ea0: 20 61 20 73 68 61 72 65 64 20 68 61 73 68 20 74 a shared hash t
6eb0: 61 62 6c 65 20 66 6f 72 20 70 61 73 73 69 6e 67 able for passing
6ec0: 20 64 61 74 61 20 74 6f 2f 66 72 6f 6d 20 70 61 data to/from pa
6ed0: 67 65 20 63 61 6c 6c 73 0a 09 09 29 29 0a 09 20 ge calls...))..
6ee0: 20 20 20 20 28 6c 69 73 74 20 22 3c 70 3e 50 61 (list "<p>Pa
6ef0: 67 65 20 6e 6f 74 20 66 6f 75 6e 64 20 22 20 70 ge not found " p
6f00: 61 67 65 20 22 20 3c 2f 70 3e 22 29 29 29 29 0a age " </p>")))).
6f10: 20 20 20 20 20 20 20 3b 3b 20 66 69 72 73 74 20 ;; first
6f20: 74 68 65 20 63 6f 6e 74 72 6f 6c 0a 20 20 20 20 the control.
6f30: 20 20 20 3b 3b 20 28 6c 65 74 20 28 28 63 6f 6e ;; (let ((con
6f40: 74 72 6f 6c 2d 66 69 6c 65 20 28 63 6f 6e 63 20 trol-file (conc
6f50: 22 70 61 67 65 73 2f 22 20 70 61 67 65 20 22 5f "pages/" page "_
6f60: 63 74 72 6c 2e 73 63 6d 22 29 29 0a 20 20 20 20 ctrl.scm")).
6f70: 20 20 20 3b 3b 20 20 20 20 20 20 20 28 76 69 65 ;; (vie
6f80: 77 2d 66 69 6c 65 20 20 20 20 28 63 6f 6e 63 20 w-file (conc
6f90: 22 70 61 67 65 73 2f 22 20 70 61 67 65 20 22 5f "pages/" page "_
6fa0: 76 69 65 77 2e 73 63 6d 22 29 29 29 0a 20 20 20 view.scm"))).
6fb0: 20 20 20 20 3b 3b 20 20 20 28 69 66 20 28 61 6e ;; (if (an
6fc0: 64 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 d (file-exists?
6fd0: 63 6f 6e 74 72 6f 6c 2d 66 69 6c 65 29 0a 20 20 control-file).
6fe0: 20 20 20 20 20 3b 3b 20 20 09 20 20 28 6e 6f 74 ;; . (not
6ff0: 20 28 65 71 3f 20 70 61 72 74 73 20 27 76 69 65 (eq? parts 'vie
7000: 77 29 29 29 0a 20 20 20 20 20 20 20 3b 3b 20 20 w))). ;;
7010: 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 (begin.
7020: 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 28 73 ;; (s
7030: 65 73 73 69 6f 6e 3a 73 65 74 2d 63 61 6c 6c 65 ession:set-calle
7040: 64 21 20 73 65 6c 66 20 70 61 67 65 29 0a 20 20 d! self page).
7050: 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 ;;
7060: 28 6c 6f 61 64 20 63 6f 6e 74 72 6f 6c 2d 66 69 (load control-fi
7070: 6c 65 29 29 29 0a 20 20 20 20 20 20 20 3b 3b 20 le))). ;;
7080: 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 (if (file-exis
7090: 74 73 3f 20 76 69 65 77 2d 66 69 6c 65 29 0a 20 ts? view-file).
70a0: 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 28 ;; (
70b0: 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 70 61 72 if (not (eq? par
70c0: 74 73 20 27 63 6f 6e 74 72 6f 6c 29 29 0a 20 20 ts 'control)).
70d0: 20 20 20 20 20 3b 3b 20 20 09 20 28 73 65 73 73 ;; . (sess
70e0: 69 6f 6e 3a 70 72 6f 63 65 73 73 2d 66 69 6c 65 ion:process-file
70f0: 20 76 69 65 77 2d 66 69 6c 65 29 29 0a 20 20 20 view-file)).
7100: 20 20 20 20 3b 3b 20 20 20 20 20 20 20 28 6c 69 ;; (li
7110: 73 74 20 22 3c 70 3e 50 61 67 65 20 6e 6f 74 20 st "<p>Page not
7120: 66 6f 75 6e 64 20 22 20 70 61 67 65 20 22 20 3c found " page " <
7130: 2f 70 3e 22 29 29 29 0a 20 20 20 20 20 20 28 28 /p>"))). ((
7140: 64 69 72 29 20 22 45 52 52 4f 52 3a 20 20 64 69 dir) "ERROR: di
7150: 72 20 73 74 79 6c 65 20 6e 6f 74 20 79 65 74 20 r style not yet
7160: 72 65 2d 69 6d 70 6c 65 6d 65 6e 74 65 64 22 29 re-implemented")
7170: 0a 20 20 20 20 20 20 28 65 6c 73 65 0a 20 20 20 . (else.
7180: 20 20 20 20 28 6c 69 73 74 20 22 45 52 52 4f 52 (list "ERROR
7190: 3a 20 70 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 : page-dir-style
71a0: 20 6d 75 73 74 20 62 65 20 73 74 6f 72 65 64 2c must be stored,
71b0: 20 64 69 72 20 6f 72 20 66 6c 61 74 2c 20 67 6f dir or flat, go
71c0: 74 20 22 20 64 69 72 2d 73 74 79 6c 65 29 29 29 t " dir-style)))
71d0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 ))..(define (ses
71e0: 73 69 6f 6e 3a 63 61 6c 6c 20 73 65 6c 66 20 70 sion:call self p
71f0: 61 67 65 20 70 61 72 74 73 29 0a 20 20 28 73 65 age parts). (se
7200: 73 73 69 6f 6e 3a 63 61 6c 6c 2d 70 61 72 74 73 ssion:call-parts
7210: 20 73 65 6c 66 20 70 61 67 65 20 27 62 6f 74 68 self page 'both
7220: 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 ))..;; (define (
7230: 73 65 73 73 69 6f 6e 3a 6c 6f 61 64 2d 6d 6f 64 session:load-mod
7240: 65 6c 20 73 65 6c 66 20 6d 6f 64 65 6c 29 0a 3b el self model).;
7250: 3b 20 20 20 28 6c 65 74 20 28 28 6d 6f 64 65 6c ; (let ((model
7260: 2e 73 63 6d 20 28 73 74 72 69 6e 67 2d 61 70 70 .scm (string-app
7270: 65 6e 64 20 28 73 64 61 74 2d 67 65 74 2d 73 72 end (sdat-get-sr
7280: 6f 6f 74 20 73 65 6c 66 29 20 22 2f 6d 6f 64 65 oot self) "/mode
7290: 6c 73 2f 22 20 6d 6f 64 65 6c 20 22 2e 73 63 6d ls/" model ".scm
72a0: 22 29 29 0a 3b 3b 20 09 28 6d 6f 64 65 6c 2e 73 ")).;; .(model.s
72b0: 6f 20 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e o (string-appen
72c0: 64 20 28 73 64 61 74 2d 67 65 74 2d 73 72 6f 6f d (sdat-get-sroo
72d0: 74 20 73 65 6c 66 29 20 22 2f 6d 6f 64 65 6c 73 t self) "/models
72e0: 2f 22 20 6d 6f 64 65 6c 20 22 2e 73 6f 22 29 29 /" model ".so"))
72f0: 29 0a 3b 3b 20 20 20 20 20 28 69 66 20 28 66 69 ).;; (if (fi
7300: 6c 65 2d 65 78 69 73 74 73 3f 20 6d 6f 64 65 6c le-exists? model
7310: 2e 73 6f 29 0a 3b 3b 20 09 28 6c 6f 61 64 20 6d .so).;; .(load m
7320: 6f 64 65 6c 2e 73 6f 29 0a 3b 3b 20 09 28 69 66 odel.so).;; .(if
7330: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 6d (file-exists? m
7340: 6f 64 65 6c 2e 73 63 6d 29 0a 3b 3b 20 09 20 20 odel.scm).;; .
7350: 20 20 28 6c 6f 61 64 20 6d 6f 64 65 6c 2e 73 63 (load model.sc
7360: 6d 29 0a 3b 3b 20 09 20 20 20 20 28 73 3a 6c 6f m).;; . (s:lo
7370: 67 20 22 45 52 52 4f 52 3a 20 6d 6f 64 65 6c 20 g "ERROR: model
7380: 22 20 6d 6f 64 65 6c 2e 73 63 6d 20 22 20 6e 6f " model.scm " no
7390: 74 20 66 6f 75 6e 64 22 29 29 29 29 29 0a 0a 3b t found")))))..;
73a0: 3b 20 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ; (define (sessi
73b0: 6f 6e 3a 6d 6f 64 65 6c 2d 70 61 74 68 20 73 65 on:model-path se
73c0: 6c 66 20 6d 6f 64 65 6c 29 0a 3b 3b 20 20 20 28 lf model).;; (
73d0: 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 28 73 string-append (s
73e0: 64 61 74 2d 67 65 74 2d 73 72 6f 6f 74 20 73 65 dat-get-sroot se
73f0: 6c 66 29 20 22 2f 6d 6f 64 65 6c 73 2f 22 20 6d lf) "/models/" m
7400: 6f 64 65 6c 20 22 2e 73 63 6d 22 29 29 0a 0a 28 odel ".scm"))..(
7410: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
7420: 70 70 2d 66 6f 72 6d 64 61 74 20 73 65 6c 66 29 pp-formdat self)
7430: 0a 20 20 28 6c 65 74 20 28 28 64 61 74 20 28 66 . (let ((dat (f
7440: 6f 72 6d 64 61 74 3a 61 6c 6c 2d 3e 73 74 72 69 ormdat:all->stri
7450: 6e 67 73 20 28 73 64 61 74 2d 67 65 74 2d 66 6f ngs (sdat-get-fo
7460: 72 6d 64 61 74 20 73 65 6c 66 29 29 29 29 0a 20 rmdat self)))).
7470: 20 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 (string-inter
7480: 73 70 65 72 73 65 20 64 61 74 20 22 3c 62 72 3e sperse dat "<br>
7490: 20 22 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 ")))..(define (
74a0: 73 65 73 73 69 6f 6e 3a 70 61 72 61 6d 2d 3e 73 session:param->s
74b0: 74 72 69 6e 67 20 70 61 72 61 6d 73 29 0a 20 20 tring params).
74c0: 3b 3b 20 28 65 72 72 3a 6c 6f 67 20 22 70 61 72 ;; (err:log "par
74d0: 61 6d 73 3d 22 20 70 61 72 61 6d 73 29 0a 20 20 ams=" params).
74e0: 28 69 66 20 28 3c 20 28 6c 65 6e 67 74 68 20 70 (if (< (length p
74f0: 61 72 61 6d 73 29 20 31 29 0a 20 20 20 20 20 20 arams) 1).
7500: 22 22 0a 20 20 20 20 20 20 28 6c 65 74 20 6c 6f "". (let lo
7510: 6f 70 20 28 28 6b 65 79 20 28 63 61 72 20 70 61 op ((key (car pa
7520: 72 61 6d 73 29 29 0a 09 09 20 28 76 61 6c 20 28 rams))... (val (
7530: 63 61 64 72 20 70 61 72 61 6d 73 29 29 0a 09 09 cadr params))...
7540: 20 28 74 61 69 6c 20 28 63 64 64 72 20 70 61 72 (tail (cddr par
7550: 61 6d 73 29 29 0a 09 09 20 28 72 65 73 75 6c 74 ams))... (result
7560: 20 27 28 29 29 29 0a 09 28 6c 65 74 20 28 28 6e '()))..(let ((n
7570: 65 77 72 65 73 75 6c 74 20 28 63 6f 6e 73 20 28 ewresult (cons (
7580: 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 28 73 string-append (s
7590: 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6b 65 79 :any->string key
75a0: 29 20 22 3d 22 20 28 73 3a 61 6e 79 2d 3e 73 74 ) "=" (s:any->st
75b0: 72 69 6e 67 20 76 61 6c 29 29 0a 09 09 09 20 20 ring val))....
75c0: 20 20 20 20 20 72 65 73 75 6c 74 29 29 29 0a 09 result)))..
75d0: 20 20 28 69 66 20 28 3c 20 28 6c 65 6e 67 74 68 (if (< (length
75e0: 20 74 61 69 6c 29 20 31 29 20 3b 3b 20 74 72 75 tail) 1) ;; tru
75f0: 65 20 69 66 20 64 6f 6e 65 0a 09 20 20 20 20 20 e if done..
7600: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
7610: 65 72 73 65 20 6e 65 77 72 65 73 75 6c 74 20 22 erse newresult "
7620: 26 22 29 0a 09 20 20 20 20 20 20 28 6c 6f 6f 70 &").. (loop
7630: 20 28 63 61 72 20 74 61 69 6c 29 28 63 61 64 72 (car tail)(cadr
7640: 20 74 61 69 6c 29 28 63 64 64 72 20 74 61 69 6c tail)(cddr tail
7650: 29 20 6e 65 77 72 65 73 75 6c 74 29 29 29 29 29 ) newresult)))))
7660: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 )..(define (sess
7670: 69 6f 6e 3a 6c 69 6e 6b 2d 74 6f 20 73 65 6c 66 ion:link-to self
7680: 20 70 61 67 65 20 70 61 72 61 6d 73 29 0a 20 20 page params).
7690: 28 6c 65 74 2a 20 28 28 73 65 72 76 65 72 20 20 (let* ((server
76a0: 20 20 28 6f 72 20 28 67 65 74 2d 65 6e 76 69 72 (or (get-envir
76b0: 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 onment-variable
76c0: 22 48 54 54 50 53 5f 48 4f 53 54 22 29 20 3b 3b "HTTPS_HOST") ;;
76d0: 20 41 73 73 75 6d 69 6e 67 20 48 54 54 50 53 5f Assuming HTTPS_
76e0: 48 4f 53 54 20 69 73 20 6f 6e 6c 79 20 73 65 74 HOST is only set
76f0: 20 69 66 20 61 76 61 69 6c 61 62 6c 65 0a 09 09 if available...
7700: 09 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e .(get-environmen
7710: 74 2d 76 61 72 69 61 62 6c 65 20 22 48 54 54 50 t-variable "HTTP
7720: 5f 48 4f 53 54 22 29 0a 09 09 09 28 67 65 74 2d _HOST")....(get-
7730: 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 environment-vari
7740: 61 62 6c 65 20 22 53 45 52 56 45 52 5f 4e 41 4d able "SERVER_NAM
7750: 45 22 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 E"))). (
7760: 66 6f 72 63 65 2d 73 63 72 69 70 74 20 20 28 73 force-script (s
7770: 64 61 74 2d 67 65 74 2d 73 63 72 69 70 74 20 73 dat-get-script s
7780: 65 6c 66 29 29 0a 09 20 28 73 63 72 69 70 74 20 elf)).. (script
7790: 28 6f 72 20 66 6f 72 63 65 2d 73 63 72 69 70 74 (or force-script
77a0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
77b0: 20 20 20 20 20 20 28 6c 65 74 20 28 28 73 63 72 (let ((scr
77c0: 69 70 74 2d 6e 61 6d 65 20 28 73 74 72 69 6e 67 ipt-name (string
77d0: 2d 73 70 6c 69 74 20 28 67 65 74 2d 65 6e 76 69 -split (get-envi
77e0: 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 ronment-variable
77f0: 20 22 53 43 52 49 50 54 5f 4e 41 4d 45 22 29 20 "SCRIPT_NAME")
7800: 22 2f 22 29 29 29 0a 20 20 20 20 20 20 20 20 20 "/"))).
7810: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
7820: 66 20 28 3e 20 28 6c 65 6e 67 74 68 20 73 63 72 f (> (length scr
7830: 69 70 74 2d 6e 61 6d 65 29 20 31 29 0a 20 20 20 ipt-name) 1).
7840: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7850: 20 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d (string-
7860: 61 70 70 65 6e 64 20 28 63 61 72 20 73 63 72 69 append (car scri
7870: 70 74 2d 6e 61 6d 65 29 20 22 2f 22 20 28 63 61 pt-name) "/" (ca
7880: 64 72 20 73 63 72 69 70 74 2d 6e 61 6d 65 29 29 dr script-name))
7890: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
78a0: 20 20 20 20 20 20 20 20 20 20 20 20 28 67 65 74 (get
78b0: 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 -environment-var
78c0: 69 61 62 6c 65 20 22 53 43 52 49 50 54 5f 4e 41 iable "SCRIPT_NA
78d0: 4d 45 22 29 29 29 29 29 20 3b 3b 20 62 75 69 6c ME"))))) ;; buil
78e0: 64 20 73 63 72 69 70 74 20 6e 61 6d 65 20 66 72 d script name fr
78f0: 6f 6d 20 66 69 72 73 74 20 74 77 6f 20 65 6c 65 om first two ele
7900: 6d 65 6e 74 73 2e 20 54 68 69 73 20 69 73 20 61 ments. This is a
7910: 20 68 61 6e 67 6f 76 65 72 20 66 72 6f 6d 20 62 hangover from b
7920: 65 66 6f 72 65 20 49 20 75 73 65 64 20 3f 20 69 efore I used ? i
7930: 6e 20 74 68 65 20 55 52 4c 2e 29 0a 20 20 20 20 n the URL.).
7940: 20 20 20 20 20 28 73 65 73 73 69 6f 6e 2d 6b 65 (session-ke
7950: 79 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 y (sdat-get-sess
7960: 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 29 0a 09 ion-key self))..
7970: 20 28 70 61 72 61 6d 73 74 72 20 28 73 65 73 73 (paramstr (sess
7980: 69 6f 6e 3a 70 61 72 61 6d 2d 3e 73 74 72 69 6e ion:param->strin
7990: 67 20 70 61 72 61 6d 73 29 29 29 0a 20 20 20 20 g params))).
79a0: 3b 3b 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 ;; (session:log
79b0: 73 65 6c 66 20 22 73 65 72 76 65 72 3d 22 20 73 self "server=" s
79c0: 65 72 76 65 72 20 22 20 73 63 72 69 70 74 3d 22 erver " script="
79d0: 20 73 63 72 69 70 74 20 22 20 70 61 67 65 3d 22 script " page="
79e0: 20 70 61 67 65 29 0a 20 20 20 20 28 73 74 72 69 page). (stri
79f0: 6e 67 2d 61 70 70 65 6e 64 20 22 68 74 74 70 3a ng-append "http:
7a00: 2f 2f 22 20 73 65 72 76 65 72 20 22 2f 22 20 73 //" server "/" s
7a10: 63 72 69 70 74 20 22 2f 22 20 70 61 67 65 20 22 cript "/" page "
7a20: 3f 22 20 70 61 72 61 6d 73 74 72 29 29 29 20 3b ?" paramstr))) ;
7a30: 3b 20 22 2f 73 6e 3d 22 20 73 65 73 73 69 6f 6e ; "/sn=" session
7a40: 2d 6b 65 79 29 29 29 0a 0a 28 64 65 66 69 6e 65 -key)))..(define
7a50: 20 28 73 65 73 73 69 6f 6e 3a 63 67 69 2d 6f 75 (session:cgi-ou
7a60: 74 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 2a 20 t self). (let*
7a70: 28 28 63 6f 6e 74 65 6e 74 20 20 28 6c 69 73 74 ((content (list
7a80: 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 74 65 (sdat-get-conte
7a90: 6e 74 2d 74 79 70 65 20 73 65 6c 66 29 29 29 20 nt-type self)))
7aa0: 3b 3b 20 27 28 22 43 6f 6e 74 65 6e 74 2d 74 79 ;; '("Content-ty
7ab0: 70 65 3a 20 74 65 78 74 2f 68 74 6d 6c 3b 20 63 pe: text/html; c
7ac0: 68 61 72 73 65 74 3d 69 73 6f 2d 38 38 35 39 2d harset=iso-8859-
7ad0: 31 5c 6e 5c 6e 22 29 29 0a 09 20 28 68 65 61 64 1\n\n")).. (head
7ae0: 65 72 20 20 20 28 6c 65 74 20 28 28 63 6f 6f 6b er (let ((cook
7af0: 69 65 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 ie (sdat-get-ses
7b00: 73 69 6f 6e 2d 63 6f 6f 6b 69 65 20 73 65 6c 66 sion-cookie self
7b10: 29 29 29 0a 09 09 20 20 20 20 20 28 69 66 20 63 )))... (if c
7b20: 6f 6f 6b 69 65 0a 09 09 09 20 28 63 6f 6e 73 20 ookie.... (cons
7b30: 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 22 (string-append "
7b40: 53 65 74 2d 43 6f 6f 6b 69 65 3a 20 22 20 28 63 Set-Cookie: " (c
7b50: 61 72 20 63 6f 6f 6b 69 65 29 29 0a 09 09 09 20 ar cookie))....
7b60: 20 20 20 20 20 20 63 6f 6e 74 65 6e 74 29 0a 09 content)..
7b70: 09 09 20 63 6f 6e 74 65 6e 74 29 29 29 0a 09 20 .. content)))..
7b80: 28 70 61 67 65 64 61 74 20 20 28 73 64 61 74 2d (pagedat (sdat-
7b90: 67 65 74 2d 70 61 67 65 64 61 74 20 73 65 6c 66 get-pagedat self
7ba0: 29 29 29 0a 20 20 20 20 28 73 3a 63 67 69 2d 6f ))). (s:cgi-o
7bb0: 75 74 20 0a 20 20 20 20 20 28 63 6f 6e 73 20 68 ut . (cons h
7bc0: 65 61 64 65 72 20 70 61 67 65 64 61 74 29 29 29 eader pagedat)))
7bd0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 )..(define (sess
7be0: 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 2e 20 6d ion:log self . m
7bf0: 73 67 29 0a 20 20 28 77 69 74 68 2d 6f 75 74 70 sg). (with-outp
7c00: 75 74 2d 74 6f 2d 70 6f 72 74 20 28 73 64 61 74 ut-to-port (sdat
7c10: 2d 67 65 74 2d 6c 6f 67 2d 70 6f 72 74 20 73 65 -get-log-port se
7c20: 6c 66 29 20 3b 3b 20 28 73 64 61 74 2d 67 65 74 lf) ;; (sdat-get
7c30: 2d 6c 6f 67 70 74 20 73 65 6c 66 29 0a 20 20 20 -logpt self).
7c40: 20 28 6c 61 6d 62 64 61 20 28 29 20 0a 20 20 20 (lambda () .
7c50: 20 20 20 28 61 70 70 6c 79 20 70 72 69 6e 74 20 (apply print
7c60: 6d 73 67 29 29 29 29 0a 0a 3b 3b 20 65 73 63 61 msg))))..;; esca
7c70: 70 65 2c 20 63 6f 6e 76 65 72 74 20 6f 72 20 72 pe, convert or r
7c80: 65 74 75 72 6e 20 72 61 77 20 77 68 65 6e 20 67 eturn raw when g
7c90: 69 76 65 6e 20 75 73 65 72 20 69 6e 70 75 74 20 iven user input
7ca0: 64 61 74 61 20 74 68 61 74 20 70 6f 74 65 6e 74 data that potent
7cb0: 69 61 6c 6c 79 0a 3b 3b 20 63 6f 75 6c 64 20 62 ially.;; could b
7cc0: 65 20 6d 61 6c 69 63 69 6f 75 73 0a 3b 3b 0a 28 e malicious.;;.(
7cd0: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
7ce0: 61 70 70 6c 79 2d 74 79 70 65 2d 70 72 65 66 65 apply-type-prefe
7cf0: 72 65 6e 63 65 20 72 65 73 20 70 61 72 61 6d 73 rence res params
7d00: 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 74 79 70 ). (let* ((dtyp
7d10: 65 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 e (if (null?
7d20: 70 61 72 61 6d 73 29 0a 09 09 20 20 20 20 20 20 params)...
7d30: 20 27 65 73 63 61 70 65 64 0a 09 09 20 20 20 20 'escaped...
7d40: 20 20 20 28 63 61 72 20 70 61 72 61 6d 73 29 29 (car params))
7d50: 29 0a 09 20 28 74 61 67 73 20 20 20 20 28 69 66 ).. (tags (if
7d60: 20 28 6e 75 6c 6c 3f 20 70 61 72 61 6d 73 29 0a (null? params).
7d70: 09 09 20 20 20 20 20 20 27 28 29 0a 09 09 20 20 .. '()...
7d80: 20 20 20 20 28 63 64 72 20 70 61 72 61 6d 73 29 (cdr params)
7d90: 29 29 29 0a 20 20 20 20 28 63 61 73 65 20 64 74 ))). (case dt
7da0: 79 70 65 0a 20 20 20 20 20 20 28 28 72 61 77 29 ype. ((raw)
7db0: 20 20 20 20 20 72 65 73 29 0a 20 20 20 20 20 20 res).
7dc0: 28 28 6e 75 6d 62 65 72 29 20 20 28 69 66 20 28 ((number) (if (
7dd0: 73 74 72 69 6e 67 3f 20 72 65 73 29 28 73 74 72 string? res)(str
7de0: 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 72 65 73 29 ing->number res)
7df0: 20 23 66 29 29 0a 20 20 20 20 20 20 28 28 65 73 #f)). ((es
7e00: 63 61 70 65 64 29 20 28 69 66 20 28 73 74 72 69 caped) (if (stri
7e10: 6e 67 3f 20 72 65 73 29 0a 09 09 20 20 20 20 20 ng? res)...
7e20: 28 73 3a 68 74 6d 6c 2d 66 69 6c 74 65 72 2d 3e (s:html-filter->
7e30: 73 74 72 69 6e 67 20 72 65 73 20 74 61 67 73 29 string res tags)
7e40: 0a 09 09 20 20 20 20 20 72 65 73 29 29 0a 20 20 ... res)).
7e50: 20 20 20 20 28 28 65 73 63 61 70 65 64 2d 6e 6c ((escaped-nl
7e60: 29 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 72 ) (if (string? r
7e70: 65 73 29 20 3b 3b 20 65 73 63 61 70 65 20 5c 6e es) ;; escape \n
7e80: 20 61 6e 64 20 5c 72 0a 09 09 09 28 73 74 72 69 and \r....(stri
7e90: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 0a 09 ng-intersperse..
7ea0: 09 09 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 .. (string-split
7eb0: 0a 09 09 09 20 20 28 73 74 72 69 6e 67 2d 69 6e .... (string-in
7ec0: 74 65 72 73 70 65 72 73 65 0a 09 09 09 20 20 20 tersperse....
7ed0: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 28 73 (string-split (s
7ee0: 3a 68 74 6d 6c 2d 66 69 6c 74 65 72 2d 3e 73 74 :html-filter->st
7ef0: 72 69 6e 67 20 72 65 73 20 74 61 67 73 29 20 22 ring res tags) "
7f00: 5c 6e 22 29 0a 09 09 09 20 20 20 22 5c 5c 6e 22 \n").... "\\n"
7f10: 29 0a 09 09 09 20 20 22 5c 72 22 29 0a 09 09 09 ).... "\r")....
7f20: 20 22 5c 5c 72 22 29 0a 09 09 09 72 65 73 29 29 "\\r")....res))
7f30: 20 3b 3b 20 73 68 6f 75 6c 64 20 72 65 74 75 72 ;; should retur
7f40: 6e 20 23 66 20 69 66 20 6e 6f 74 20 61 20 73 74 n #f if not a st
7f50: 72 69 6e 67 20 61 6e 64 20 63 61 6e 27 74 20 65 ring and can't e
7f60: 73 63 61 70 65 20 69 74 3f 0a 20 20 20 20 20 20 scape it?.
7f70: 28 65 6c 73 65 20 20 20 20 20 20 28 69 66 20 28 (else (if (
7f80: 73 74 72 69 6e 67 3f 20 72 65 73 29 0a 09 09 20 string? res)...
7f90: 20 20 20 20 28 73 3a 68 74 6d 6c 2d 66 69 6c 74 (s:html-filt
7fa0: 65 72 2d 3e 73 74 72 69 6e 67 20 72 65 73 20 27 er->string res '
7fb0: 28 29 29 0a 09 09 20 20 20 20 20 72 65 73 29 29 ())... res))
7fc0: 29 29 29 0a 0a 3b 3b 20 70 61 72 61 6d 73 20 61 )))..;; params a
7fd0: 72 65 20 73 74 6f 72 65 64 20 61 73 20 6c 69 73 re stored as lis
7fe0: 74 20 6f 66 20 6b 65 79 3d 76 61 6c 0a 3b 3b 0a t of key=val.;;.
7ff0: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
8000: 3a 67 65 74 2d 70 61 72 61 6d 20 73 65 6c 66 20 :get-param self
8010: 6b 65 79 20 74 79 70 65 2d 70 61 72 61 6d 73 29 key type-params)
8020: 0a 20 20 3b 3b 20 28 73 65 73 73 69 6f 6e 3a 6c . ;; (session:l
8030: 6f 67 20 73 3a 73 65 73 73 69 6f 6e 20 22 70 61 og s:session "pa
8040: 72 61 6d 73 3d 22 20 28 73 6c 6f 74 2d 72 65 66 rams=" (slot-ref
8050: 20 73 3a 73 65 73 73 69 6f 6e 20 27 70 61 72 61 s:session 'para
8060: 6d 73 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 70 ms)). (let* ((p
8070: 61 72 61 6d 73 20 28 73 64 61 74 2d 67 65 74 2d arams (sdat-get-
8080: 70 61 72 61 6d 73 20 73 65 6c 66 29 29 0a 09 20 params self))..
8090: 28 72 65 73 20 20 20 20 28 73 65 73 73 69 6f 6e (res (session
80a0: 3a 67 65 74 2d 70 61 72 61 6d 2d 66 72 6f 6d 20 :get-param-from
80b0: 70 61 72 61 6d 73 20 6b 65 79 29 29 29 0a 20 20 params key))).
80c0: 20 20 28 73 65 73 73 69 6f 6e 3a 61 70 70 6c 79 (session:apply
80d0: 2d 74 79 70 65 2d 70 72 65 66 65 72 65 6e 63 65 -type-preference
80e0: 20 72 65 73 20 74 79 70 65 2d 70 61 72 61 6d 73 res type-params
80f0: 29 29 29 0a 0a 3b 3b 20 54 68 69 73 20 6f 6e 65 )))..;; This one
8100: 20 77 69 6c 6c 20 67 65 74 20 74 68 65 20 66 69 will get the fi
8110: 72 73 74 20 76 61 6c 75 65 20 66 6f 75 6e 64 20 rst value found
8120: 72 65 67 61 72 64 6c 65 73 73 20 6f 66 20 66 6f regardless of fo
8130: 72 6d 0a 3b 3b 20 70 61 72 61 6d 3a 20 28 64 74 rm.;; param: (dt
8140: 79 70 65 20 5b 74 61 67 31 20 74 61 67 32 20 2e ype [tag1 tag2 .
8150: 2e 2e 5d 29 0a 3b 3b 20 64 74 79 70 65 3a 0a 3b ..]).;; dtype:.;
8160: 3b 20 20 20 20 27 72 61 77 20 20 20 20 20 3a 20 ; 'raw :
8170: 64 6f 20 6e 6f 20 63 6f 6e 76 65 72 73 69 6f 6e do no conversion
8180: 0a 3b 3b 20 20 20 20 27 6e 75 6d 62 65 72 20 20 .;; 'number
8190: 3a 20 63 6f 6e 76 65 72 74 20 74 6f 20 6e 75 6d : convert to num
81a0: 62 65 72 2c 20 72 65 74 75 72 6e 20 23 66 20 69 ber, return #f i
81b0: 66 20 66 61 69 6c 73 0a 3b 3b 20 20 20 20 27 65 f fails.;; 'e
81c0: 73 63 61 70 65 64 20 3a 20 75 73 65 20 68 74 6d scaped : use htm
81d0: 6c 2d 65 73 63 61 70 65 20 74 6f 20 70 72 6f 74 l-escape to prot
81e0: 65 63 74 20 74 68 65 20 69 6e 70 75 74 20 2d 2d ect the input --
81f0: 20 74 68 69 73 20 69 73 20 74 68 65 20 64 65 66 this is the def
8200: 61 75 6c 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 ault.;;.(define
8210: 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 69 6e 70 (session:get-inp
8220: 75 74 20 73 65 6c 66 20 6b 65 79 20 70 61 72 61 ut self key para
8230: 6d 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 74 ms). (let* ((dt
8240: 79 70 65 20 20 20 20 28 69 66 20 28 6e 75 6c 6c ype (if (null
8250: 3f 20 70 61 72 61 6d 73 29 0a 09 09 20 20 20 20 ? params)...
8260: 20 20 20 27 65 73 63 61 70 65 64 0a 09 09 20 20 'escaped...
8270: 20 20 20 20 20 28 63 61 72 20 70 61 72 61 6d 73 (car params
8280: 29 29 29 0a 09 20 28 74 61 67 73 20 20 20 20 28 ))).. (tags (
8290: 69 66 20 28 6e 75 6c 6c 3f 20 70 61 72 61 6d 73 if (null? params
82a0: 29 0a 09 09 20 20 20 20 20 20 27 28 29 0a 09 09 )... '()...
82b0: 20 20 20 20 20 20 28 63 64 72 20 70 61 72 61 6d (cdr param
82c0: 73 29 29 29 0a 09 20 28 66 6f 72 6d 64 61 74 20 s))).. (formdat
82d0: 28 73 64 61 74 2d 67 65 74 2d 66 6f 72 6d 64 61 (sdat-get-formda
82e0: 74 20 73 65 6c 66 29 29 0a 09 20 28 72 65 73 20 t self)).. (res
82f0: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 66 6f 72 (if (not for
8300: 6d 64 61 74 29 20 23 66 0a 09 09 20 20 20 20 20 mdat) #f...
8310: 20 28 69 66 20 28 6f 72 20 28 73 74 72 69 6e 67 (if (or (string
8320: 3f 20 6b 65 79 29 28 6e 75 6d 62 65 72 3f 20 6b ? key)(number? k
8330: 65 79 29 28 73 79 6d 62 6f 6c 3f 20 6b 65 79 29 ey)(symbol? key)
8340: 29 0a 09 09 09 20 20 28 69 66 20 28 61 6e 64 20 ).... (if (and
8350: 28 76 65 63 74 6f 72 3f 20 66 6f 72 6d 64 61 74 (vector? formdat
8360: 29 28 65 71 3f 20 28 76 65 63 74 6f 72 2d 6c 65 )(eq? (vector-le
8370: 6e 67 74 68 20 66 6f 72 6d 64 61 74 29 20 31 29 ngth formdat) 1)
8380: 28 68 61 73 68 2d 74 61 62 6c 65 3f 20 28 76 65 (hash-table? (ve
8390: 63 74 6f 72 2d 72 65 66 20 66 6f 72 6d 64 61 74 ctor-ref formdat
83a0: 20 30 29 29 29 0a 09 09 09 20 20 20 20 20 20 28 0))).... (
83b0: 66 6f 72 6d 64 61 74 3a 67 65 74 20 66 6f 72 6d formdat:get form
83c0: 64 61 74 20 6b 65 79 29 0a 09 09 09 20 20 20 20 dat key)....
83d0: 20 20 28 62 65 67 69 6e 0a 09 09 09 09 28 73 65 (begin.....(se
83e0: 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 ssion:log self "
83f0: 45 52 52 4f 52 3a 20 66 6f 72 6d 64 61 74 3a 20 ERROR: formdat:
8400: 22 20 66 6f 72 6d 64 61 74 20 22 20 69 73 20 6e " formdat " is n
8410: 6f 74 20 6f 66 20 63 6c 61 73 73 20 3c 66 6f 72 ot of class <for
8420: 6d 64 61 74 3e 22 29 0a 09 09 09 09 23 66 29 29 mdat>").....#f))
8430: 0a 09 09 09 20 20 28 62 65 67 69 6e 0a 09 09 09 .... (begin....
8440: 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 (session:log
8450: 20 73 65 6c 66 20 22 45 52 52 4f 52 3a 20 62 61 self "ERROR: ba
8460: 64 20 6b 65 79 20 22 20 6b 65 79 29 0a 09 09 09 d key " key)....
8470: 20 20 20 20 23 66 29 29 29 29 29 0a 20 20 20 20 #f))))).
8480: 28 63 61 73 65 20 64 74 79 70 65 0a 20 20 20 20 (case dtype.
8490: 20 20 28 28 72 61 77 29 20 20 20 20 20 72 65 73 ((raw) res
84a0: 29 0a 20 20 20 20 20 20 28 28 6e 75 6d 62 65 72 ). ((number
84b0: 29 20 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 ) (if (string?
84c0: 72 65 73 29 28 73 74 72 69 6e 67 2d 3e 6e 75 6d res)(string->num
84d0: 62 65 72 20 72 65 73 29 20 23 66 29 29 0a 20 20 ber res) #f)).
84e0: 20 20 20 20 28 28 65 73 63 61 70 65 64 29 20 28 ((escaped) (
84f0: 69 66 20 28 73 74 72 69 6e 67 3f 20 72 65 73 29 if (string? res)
8500: 0a 09 09 20 20 20 20 20 28 73 3a 68 74 6d 6c 2d ... (s:html-
8510: 66 69 6c 74 65 72 2d 3e 73 74 72 69 6e 67 20 72 filter->string r
8520: 65 73 20 74 61 67 73 29 0a 09 09 20 20 20 20 20 es tags)...
8530: 72 65 73 29 29 0a 20 20 20 20 20 20 28 65 6c 73 res)). (els
8540: 65 20 20 20 20 20 20 28 69 66 20 28 73 74 72 69 e (if (stri
8550: 6e 67 3f 20 72 65 73 29 0a 09 09 20 20 20 20 20 ng? res)...
8560: 28 73 3a 68 74 6d 6c 2d 66 69 6c 74 65 72 2d 3e (s:html-filter->
8570: 73 74 72 69 6e 67 20 72 65 73 20 27 28 29 29 0a string res '()).
8580: 09 09 20 20 20 20 20 72 65 73 29 29 29 29 29 0a .. res))))).
8590: 0a 3b 3b 20 54 68 69 73 20 6f 6e 65 20 77 69 6c .;; This one wil
85a0: 6c 20 67 65 74 20 74 68 65 20 66 69 72 73 74 20 l get the first
85b0: 76 61 6c 75 65 20 66 6f 75 6e 64 20 72 65 67 61 value found rega
85c0: 72 64 6c 65 73 73 20 6f 66 20 66 6f 72 6d 0a 28 rdless of form.(
85d0: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
85e0: 67 65 74 2d 69 6e 70 75 74 2d 6b 65 79 73 20 73 get-input-keys s
85f0: 65 6c 66 29 0a 20 20 28 6c 65 74 2a 20 28 28 66 elf). (let* ((f
8600: 6f 72 6d 64 61 74 20 28 73 64 61 74 2d 67 65 74 ormdat (sdat-get
8610: 2d 66 6f 72 6d 64 61 74 20 73 65 6c 66 29 29 29 -formdat self)))
8620: 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 66 6f . (if (not fo
8630: 72 6d 64 61 74 29 20 23 66 0a 09 28 69 66 20 28 rmdat) #f..(if (
8640: 61 6e 64 20 28 76 65 63 74 6f 72 3f 20 66 6f 72 and (vector? for
8650: 6d 64 61 74 29 28 65 71 3f 20 28 76 65 63 74 6f mdat)(eq? (vecto
8660: 72 2d 6c 65 6e 67 74 68 20 66 6f 72 6d 64 61 74 r-length formdat
8670: 29 20 31 29 28 68 61 73 68 2d 74 61 62 6c 65 3f ) 1)(hash-table?
8680: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 66 6f 72 (vector-ref for
8690: 6d 64 61 74 20 30 29 29 29 0a 09 20 20 20 20 28 mdat 0))).. (
86a0: 66 6f 72 6d 64 61 74 3a 6b 65 79 73 20 66 6f 72 formdat:keys for
86b0: 6d 64 61 74 29 0a 09 20 20 20 20 28 62 65 67 69 mdat).. (begi
86c0: 6e 0a 09 20 20 20 20 20 20 28 73 65 73 73 69 6f n.. (sessio
86d0: 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 45 52 52 4f n:log self "ERRO
86e0: 52 3a 20 66 6f 72 6d 64 61 74 3a 20 22 20 66 6f R: formdat: " fo
86f0: 72 6d 64 61 74 20 22 20 69 73 20 6e 6f 74 20 6f rmdat " is not o
8700: 66 20 63 6c 61 73 73 20 3c 66 6f 72 6d 64 61 74 f class <formdat
8710: 3e 22 29 0a 09 20 20 20 20 20 20 23 66 29 29 29 >").. #f)))
8720: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 ))..(define (ses
8730: 73 69 6f 6e 3a 72 75 6e 2d 61 63 74 69 6f 6e 73 sion:run-actions
8740: 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 2a 20 28 self). (let* (
8750: 28 61 63 74 69 6f 6e 20 20 20 20 28 73 65 73 73 (action (sess
8760: 69 6f 6e 3a 67 65 74 2d 70 61 72 61 6d 20 73 65 ion:get-param se
8770: 6c 66 20 27 61 63 74 69 6f 6e 20 27 28 72 61 77 lf 'action '(raw
8780: 29 29 29 0a 09 20 28 70 61 67 65 20 20 20 20 20 ))).. (page
8790: 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 20 (sdat-get-page
87a0: 73 65 6c 66 29 29 29 0a 20 20 20 20 3b 3b 20 28 self))). ;; (
87b0: 70 72 69 6e 74 20 22 61 63 74 69 6f 6e 3d 22 20 print "action="
87c0: 61 63 74 69 6f 6e 20 22 20 70 61 67 65 3d 22 20 action " page="
87d0: 70 61 67 65 29 0a 20 20 20 20 28 69 66 20 61 63 page). (if ac
87e0: 74 69 6f 6e 0a 09 28 6c 65 74 20 28 28 61 63 74 tion..(let ((act
87f0: 69 6f 6e 2d 6c 73 74 20 20 28 73 74 72 69 6e 67 ion-lst (string
8800: 2d 73 70 6c 69 74 20 61 63 74 69 6f 6e 20 22 2e -split action ".
8810: 22 29 29 29 0a 09 20 20 3b 3b 20 28 70 72 69 6e "))).. ;; (prin
8820: 74 20 22 61 63 74 69 6f 6e 2d 6c 73 74 3d 22 20 t "action-lst="
8830: 61 63 74 69 6f 6e 2d 6c 73 74 29 0a 09 20 20 28 action-lst).. (
8840: 69 66 20 28 6e 6f 74 20 28 3d 20 28 6c 65 6e 67 if (not (= (leng
8850: 74 68 20 61 63 74 69 6f 6e 2d 6c 73 74 29 20 32 th action-lst) 2
8860: 29 29 20 0a 09 20 20 20 20 20 20 28 65 72 72 3a )) .. (err:
8870: 6c 6f 67 20 22 41 63 74 69 6f 6e 20 73 68 6f 75 log "Action shou
8880: 6c 64 20 62 65 20 6f 66 20 66 6f 72 6d 3a 20 6d ld be of form: m
8890: 6f 64 75 6c 65 2e 61 63 74 69 6f 6e 22 29 0a 09 odule.action")..
88a0: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 61 (let* ((ta
88b0: 72 67 2d 70 61 67 65 20 20 20 28 63 61 72 20 61 rg-page (car a
88c0: 63 74 69 6f 6e 2d 6c 73 74 29 29 0a 09 09 20 20 ction-lst))...
88d0: 20 20 20 28 70 72 6f 63 2d 6e 61 6d 65 20 20 20 (proc-name
88e0: 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 74 (string-append t
88f0: 61 72 67 2d 70 61 67 65 20 22 2d 61 63 74 69 6f arg-page "-actio
8900: 6e 22 29 29 0a 09 09 20 20 20 20 20 28 74 61 72 n"))... (tar
8910: 67 2d 61 63 74 69 6f 6e 20 28 63 61 64 72 20 61 g-action (cadr a
8920: 63 74 69 6f 6e 2d 6c 73 74 29 29 29 0a 09 09 3b ction-lst)))...;
8930: 3b 20 28 65 72 72 3a 6c 6f 67 20 22 74 61 72 67 ; (err:log "targ
8940: 2d 70 61 67 65 3d 22 20 74 61 72 67 2d 70 61 67 -page=" targ-pag
8950: 65 20 22 20 70 72 6f 63 2d 6e 61 6d 65 3d 22 20 e " proc-name="
8960: 70 72 6f 63 2d 6e 61 6d 65 20 22 20 74 61 72 67 proc-name " targ
8970: 2d 61 63 74 69 6f 6e 3d 22 20 74 61 72 67 2d 61 -action=" targ-a
8980: 63 74 69 6f 6e 29 0a 0a 09 09 3b 3b 20 63 61 6c ction)....;; cal
8990: 6c 20 68 65 72 65 20 6f 6e 6c 79 20 69 66 20 6e l here only if n
89a0: 65 76 65 72 20 63 61 6c 6c 65 64 20 62 65 66 6f ever called befo
89b0: 72 65 0a 09 09 28 69 66 20 28 73 65 73 73 69 6f re...(if (sessio
89c0: 6e 3a 6e 65 76 65 72 2d 63 61 6c 6c 65 64 2d 70 n:never-called-p
89d0: 61 67 65 3f 20 73 65 6c 66 20 74 61 72 67 2d 70 age? self targ-p
89e0: 61 67 65 29 0a 09 09 20 20 20 20 28 73 65 73 73 age)... (sess
89f0: 69 6f 6e 3a 63 61 6c 6c 2d 70 61 72 74 73 20 73 ion:call-parts s
8a00: 65 6c 66 20 74 61 72 67 2d 70 61 67 65 20 27 63 elf targ-page 'c
8a10: 6f 6e 74 72 6f 6c 29 29 0a 09 09 3b 3b 20 20 20 ontrol))...;;
8a20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8a30: 20 70 72 6f 63 20 20 20 20 20 20 20 20 20 20 20 proc
8a40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 61 63 ac
8a50: 74 69 6f 6e 20 20 20 20 0a 0a 09 09 28 69 66 20 tion ....(if
8a60: 23 74 20 3b 3b 20 73 65 74 20 74 6f 20 23 74 20 #t ;; set to #t
8a70: 74 6f 20 73 65 65 20 62 65 74 74 65 72 20 65 72 to see better er
8a80: 72 6f 72 20 6d 65 73 73 61 67 65 73 20 64 75 72 ror messages dur
8a90: 69 6e 67 20 64 65 62 75 67 67 69 6e 20 3a 2d 29 ing debuggin :-)
8aa0: 0a 09 09 20 20 20 20 28 28 65 76 61 6c 20 28 73 ... ((eval (s
8ab0: 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 70 72 tring->symbol pr
8ac0: 6f 63 2d 6e 61 6d 65 29 29 20 74 61 72 67 2d 61 oc-name)) targ-a
8ad0: 63 74 69 6f 6e 29 20 3b 3b 20 75 6e 73 61 66 65 ction) ;; unsafe
8ae0: 20 65 78 65 63 75 74 69 6f 6e 0a 09 09 20 20 20 execution...
8af0: 20 28 63 6f 6e 64 69 74 69 6f 6e 2d 63 61 73 65 (condition-case
8b00: 20 28 28 65 76 61 6c 20 28 73 74 72 69 6e 67 2d ((eval (string-
8b10: 3e 73 79 6d 62 6f 6c 20 70 72 6f 63 2d 6e 61 6d >symbol proc-nam
8b20: 65 29 29 20 74 61 72 67 2d 61 63 74 69 6f 6e 29 e)) targ-action)
8b30: 0a 09 09 09 09 20 20 20 20 28 28 65 78 6e 20 66 ..... ((exn f
8b40: 69 6c 65 29 20 28 73 3a 6c 6f 67 20 22 66 69 6c ile) (s:log "fil
8b50: 65 20 65 72 72 6f 72 22 29 29 0a 09 09 09 09 20 e error")).....
8b60: 20 20 20 28 28 65 78 6e 20 69 2f 6f 29 20 20 28 ((exn i/o) (
8b70: 73 3a 6c 6f 67 20 22 69 2f 6f 20 65 72 72 6f 72 s:log "i/o error
8b80: 22 29 29 0a 09 09 09 09 20 20 20 20 28 28 65 78 "))..... ((ex
8b90: 6e 20 29 20 20 20 20 20 28 73 3a 6c 6f 67 20 22 n ) (s:log "
8ba0: 41 63 74 69 6f 6e 20 6e 6f 74 20 69 6d 70 6c 65 Action not imple
8bb0: 6d 65 6e 74 65 64 3a 20 22 20 70 72 6f 63 2d 6e mented: " proc-n
8bc0: 61 6d 65 20 22 20 61 63 74 69 6f 6e 3a 20 22 20 ame " action: "
8bd0: 74 61 72 67 2d 61 63 74 69 6f 6e 29 29 0a 09 09 targ-action))...
8be0: 09 09 20 20 20 20 28 76 61 72 20 28 29 20 20 20 .. (var ()
8bf0: 20 20 28 73 3a 6c 6f 67 20 22 55 6e 6b 6e 6f 77 (s:log "Unknow
8c00: 6e 20 45 72 72 6f 72 22 29 29 29 29 29 29 29 29 n Error"))))))))
8c10: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 ))..(define (ses
8c20: 73 69 6f 6e 3a 6e 65 76 65 72 2d 63 61 6c 6c 65 sion:never-calle
8c30: 64 2d 70 61 67 65 3f 20 73 65 6c 66 20 70 61 67 d-page? self pag
8c40: 65 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a 6c 6f e). (session:lo
8c50: 67 20 73 65 6c 66 20 22 43 68 65 63 6b 69 6e 67 g self "Checking
8c60: 20 66 6f 72 20 70 61 67 65 3a 20 22 20 70 61 67 for page: " pag
8c70: 65 29 0a 20 20 28 6e 6f 74 20 28 6d 65 6d 62 65 e). (not (membe
8c80: 72 20 70 61 67 65 20 28 73 64 61 74 2d 67 65 74 r page (sdat-get
8c90: 2d 73 65 65 6e 2d 70 61 67 65 73 20 73 65 6c 66 -seen-pages self
8ca0: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 ))))..(define (s
8cb0: 65 73 73 69 6f 6e 3a 73 65 74 2d 63 61 6c 6c 65 ession:set-calle
8cc0: 64 21 20 73 65 6c 66 20 70 61 67 65 29 0a 20 20 d! self page).
8cd0: 28 73 64 61 74 2d 73 65 74 2d 73 65 65 6e 2d 70 (sdat-set-seen-p
8ce0: 61 67 65 73 21 20 73 65 6c 66 20 28 63 6f 6e 73 ages! self (cons
8cf0: 20 70 61 67 65 20 28 73 64 61 74 2d 67 65 74 2d page (sdat-get-
8d00: 73 65 65 6e 2d 70 61 67 65 73 20 73 65 6c 66 29 seen-pages self)
8d10: 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d )))..;;=========
8d20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8d30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8d40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8d50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
8d60: 20 41 6c 74 65 72 6e 61 74 69 76 65 20 64 61 74 Alternative dat
8d70: 61 20 74 79 70 65 20 64 65 6c 69 76 65 72 79 0a a type delivery.
8d80: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
8d90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8da0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8db0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8dc0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e ========..(defin
8dd0: 65 20 28 73 65 73 73 69 6f 6e 3a 61 6c 74 2d 6f e (session:alt-o
8de0: 75 74 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 20 ut self). (let
8df0: 28 28 64 61 74 20 28 73 64 61 74 2d 67 65 74 2d ((dat (sdat-get-
8e00: 61 6c 74 2d 70 61 67 65 2d 64 61 74 20 73 65 6c alt-page-dat sel
8e10: 66 29 29 29 0a 20 20 20 20 3b 3b 20 28 73 3a 6c f))). ;; (s:l
8e20: 6f 67 20 22 64 61 74 20 69 73 3a 20 22 20 64 61 og "dat is: " da
8e30: 74 29 0a 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 t). ;; (print
8e40: 20 22 48 54 54 50 2f 31 2e 31 20 32 30 30 20 4f "HTTP/1.1 200 O
8e50: 4b 22 29 0a 20 20 20 20 28 70 72 69 6e 74 20 22 K"). (print "
8e60: 44 61 74 65 3a 20 22 20 28 74 69 6d 65 2d 3e 73 Date: " (time->s
8e70: 74 72 69 6e 67 20 28 73 65 63 6f 6e 64 73 2d 3e tring (seconds->
8e80: 75 74 63 2d 74 69 6d 65 20 28 63 75 72 72 65 6e utc-time (curren
8e90: 74 2d 73 65 63 6f 6e 64 73 29 29 29 29 0a 20 20 t-seconds)))).
8ea0: 20 20 28 70 72 69 6e 74 20 22 43 6f 6e 74 65 6e (print "Conten
8eb0: 74 2d 54 79 70 65 3a 20 22 20 28 73 64 61 74 2d t-Type: " (sdat-
8ec0: 67 65 74 2d 63 6f 6e 74 65 6e 74 2d 74 79 70 65 get-content-type
8ed0: 20 73 65 6c 66 29 29 0a 20 20 20 20 28 70 72 69 self)). (pri
8ee0: 6e 74 20 22 41 63 63 65 70 74 2d 52 61 6e 67 65 nt "Accept-Range
8ef0: 73 3a 20 62 79 74 65 73 22 29 0a 20 20 20 20 28 s: bytes"). (
8f00: 70 72 69 6e 74 20 22 43 6f 6e 74 65 6e 74 2d 4c print "Content-L
8f10: 65 6e 67 74 68 3a 20 22 20 28 69 66 20 28 62 6c ength: " (if (bl
8f20: 6f 62 3f 20 64 61 74 29 0a 09 09 09 09 20 20 28 ob? dat)..... (
8f30: 62 6c 6f 62 2d 73 69 7a 65 20 64 61 74 29 0a 09 blob-size dat)..
8f40: 09 09 09 20 20 30 29 29 0a 20 20 20 20 28 70 72 ... 0)). (pr
8f50: 69 6e 74 20 22 4b 65 65 70 2d 41 6c 69 76 65 3a int "Keep-Alive:
8f60: 20 74 69 6d 65 6f 75 74 3d 31 35 2c 20 6d 61 78 timeout=15, max
8f70: 3d 31 30 30 22 29 0a 20 20 20 20 28 70 72 69 6e =100"). (prin
8f80: 74 20 22 43 6f 6e 6e 65 63 74 69 6f 6e 3a 20 4b t "Connection: K
8f90: 65 65 70 2d 41 6c 69 76 65 22 29 0a 20 20 20 20 eep-Alive").
8fa0: 28 70 72 69 6e 74 20 22 22 29 0a 20 20 20 20 28 (print ""). (
8fb0: 77 72 69 74 65 2d 73 74 72 69 6e 67 20 28 62 6c write-string (bl
8fc0: 6f 62 2d 3e 73 74 72 69 6e 67 20 64 61 74 29 20 ob->string dat)
8fd0: 23 66 20 28 63 75 72 72 65 6e 74 2d 6f 75 74 70 #f (current-outp
8fe0: 75 74 2d 70 6f 72 74 29 29 29 29 0a ut-port)))).