Artifact
6e4737146850d405c86a194a5803fba2257fc141:
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 68 74 74 70 73 2d 68 6f (let* ((https-ho
76a0: 73 74 20 20 20 28 67 65 74 2d 65 6e 76 69 72 6f st (get-enviro
76b0: 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 nment-variable "
76c0: 48 54 54 50 53 5f 48 4f 53 54 22 29 29 0a 09 20 HTTPS_HOST"))..
76d0: 28 73 65 72 76 65 72 20 20 20 20 20 20 20 28 6f (server (o
76e0: 72 20 68 74 74 70 73 2d 68 6f 73 74 20 3b 3b 20 r https-host ;;
76f0: 41 73 73 75 6d 69 6e 67 20 48 54 54 50 53 5f 48 Assuming HTTPS_H
7700: 4f 53 54 20 69 73 20 6f 6e 6c 79 20 73 65 74 20 OST is only set
7710: 69 66 20 61 76 61 69 6c 61 62 6c 65 0a 09 09 09 if available....
7720: 20 20 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d (get-environm
7730: 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 48 54 ent-variable "HT
7740: 54 50 5f 48 4f 53 54 22 29 0a 09 09 09 20 20 20 TP_HOST")....
7750: 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 (get-environment
7760: 2d 76 61 72 69 61 62 6c 65 20 22 53 45 52 56 45 -variable "SERVE
7770: 52 5f 4e 41 4d 45 22 29 29 29 0a 20 20 20 20 20 R_NAME"))).
7780: 20 20 20 20 28 66 6f 72 63 65 2d 73 63 72 69 70 (force-scrip
7790: 74 20 20 28 73 64 61 74 2d 67 65 74 2d 73 63 72 t (sdat-get-scr
77a0: 69 70 74 20 73 65 6c 66 29 29 0a 09 20 28 73 63 ipt self)).. (sc
77b0: 72 69 70 74 20 20 20 20 20 20 20 20 28 6f 72 20 ript (or
77c0: 66 6f 72 63 65 2d 73 63 72 69 70 74 0a 09 09 09 force-script....
77d0: 20 20 20 20 28 6c 65 74 20 28 28 73 63 72 69 70 (let ((scrip
77e0: 74 2d 6e 61 6d 65 20 28 73 74 72 69 6e 67 2d 73 t-name (string-s
77f0: 70 6c 69 74 20 28 67 65 74 2d 65 6e 76 69 72 6f plit (get-enviro
7800: 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 nment-variable "
7810: 53 43 52 49 50 54 5f 4e 41 4d 45 22 29 20 22 2f SCRIPT_NAME") "/
7820: 22 29 29 29 0a 09 09 09 20 20 20 20 20 20 28 69 "))).... (i
7830: 66 20 28 3e 20 28 6c 65 6e 67 74 68 20 73 63 72 f (> (length scr
7840: 69 70 74 2d 6e 61 6d 65 29 20 31 29 0a 09 09 09 ipt-name) 1)....
7850: 09 20 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e . (string-appen
7860: 64 20 28 63 61 72 20 73 63 72 69 70 74 2d 6e 61 d (car script-na
7870: 6d 65 29 20 22 2f 22 20 28 63 61 64 72 20 73 63 me) "/" (cadr sc
7880: 72 69 70 74 2d 6e 61 6d 65 29 29 0a 09 09 09 09 ript-name)).....
7890: 20 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 (get-environme
78a0: 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 53 43 52 nt-variable "SCR
78b0: 49 50 54 5f 4e 41 4d 45 22 29 29 29 29 29 20 3b IPT_NAME"))))) ;
78c0: 3b 20 62 75 69 6c 64 20 73 63 72 69 70 74 20 6e ; build script n
78d0: 61 6d 65 20 66 72 6f 6d 20 66 69 72 73 74 20 74 ame from first t
78e0: 77 6f 20 65 6c 65 6d 65 6e 74 73 2e 20 54 68 69 wo elements. Thi
78f0: 73 20 69 73 20 61 20 68 61 6e 67 6f 76 65 72 20 s is a hangover
7900: 66 72 6f 6d 20 62 65 66 6f 72 65 20 49 20 75 73 from before I us
7910: 65 64 20 3f 20 69 6e 20 74 68 65 20 55 52 4c 2e ed ? in the URL.
7920: 29 0a 20 20 20 20 20 20 20 20 20 28 73 65 73 73 ). (sess
7930: 69 6f 6e 2d 6b 65 79 20 20 20 28 73 64 61 74 2d ion-key (sdat-
7940: 67 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 get-session-key
7950: 73 65 6c 66 29 29 0a 09 20 28 70 61 72 61 6d 73 self)).. (params
7960: 74 72 20 20 20 20 20 20 28 73 65 73 73 69 6f 6e tr (session
7970: 3a 70 61 72 61 6d 2d 3e 73 74 72 69 6e 67 20 70 :param->string p
7980: 61 72 61 6d 73 29 29 29 0a 20 20 20 20 3b 3b 20 arams))). ;;
7990: 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c (session:log sel
79a0: 66 20 22 73 65 72 76 65 72 3d 22 20 73 65 72 76 f "server=" serv
79b0: 65 72 20 22 20 73 63 72 69 70 74 3d 22 20 73 63 er " script=" sc
79c0: 72 69 70 74 20 22 20 70 61 67 65 3d 22 20 70 61 ript " page=" pa
79d0: 67 65 29 0a 20 20 20 20 28 73 74 72 69 6e 67 2d ge). (string-
79e0: 61 70 70 65 6e 64 20 28 69 66 20 68 74 74 70 73 append (if https
79f0: 2d 68 6f 73 74 0a 09 09 20 20 20 20 20 20 20 22 -host... "
7a00: 68 74 74 70 73 3a 2f 2f 22 0a 09 09 20 20 20 20 https://"...
7a10: 20 20 20 22 68 74 74 70 3a 2f 2f 22 29 0a 09 09 "http://")...
7a20: 20 20 20 73 65 72 76 65 72 20 22 2f 22 20 73 63 server "/" sc
7a30: 72 69 70 74 20 22 2f 22 20 70 61 67 65 20 22 3f ript "/" page "?
7a40: 22 20 70 61 72 61 6d 73 74 72 29 29 29 20 3b 3b " paramstr))) ;;
7a50: 20 22 2f 73 6e 3d 22 20 73 65 73 73 69 6f 6e 2d "/sn=" session-
7a60: 6b 65 79 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 key)))..(define
7a70: 28 73 65 73 73 69 6f 6e 3a 63 67 69 2d 6f 75 74 (session:cgi-out
7a80: 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 2a 20 28 self). (let* (
7a90: 28 63 6f 6e 74 65 6e 74 20 20 28 6c 69 73 74 20 (content (list
7aa0: 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 74 65 6e (sdat-get-conten
7ab0: 74 2d 74 79 70 65 20 73 65 6c 66 29 29 29 20 3b t-type self))) ;
7ac0: 3b 20 27 28 22 43 6f 6e 74 65 6e 74 2d 74 79 70 ; '("Content-typ
7ad0: 65 3a 20 74 65 78 74 2f 68 74 6d 6c 3b 20 63 68 e: text/html; ch
7ae0: 61 72 73 65 74 3d 69 73 6f 2d 38 38 35 39 2d 31 arset=iso-8859-1
7af0: 5c 6e 5c 6e 22 29 29 0a 09 20 28 68 65 61 64 65 \n\n")).. (heade
7b00: 72 20 20 20 28 6c 65 74 20 28 28 63 6f 6f 6b 69 r (let ((cooki
7b10: 65 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 e (sdat-get-sess
7b20: 69 6f 6e 2d 63 6f 6f 6b 69 65 20 73 65 6c 66 29 ion-cookie self)
7b30: 29 29 0a 09 09 20 20 20 20 20 28 69 66 20 63 6f ))... (if co
7b40: 6f 6b 69 65 0a 09 09 09 20 28 63 6f 6e 73 20 28 okie.... (cons (
7b50: 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 22 53 string-append "S
7b60: 65 74 2d 43 6f 6f 6b 69 65 3a 20 22 20 28 63 61 et-Cookie: " (ca
7b70: 72 20 63 6f 6f 6b 69 65 29 29 0a 09 09 09 20 20 r cookie))....
7b80: 20 20 20 20 20 63 6f 6e 74 65 6e 74 29 0a 09 09 content)...
7b90: 09 20 63 6f 6e 74 65 6e 74 29 29 29 0a 09 20 28 . content))).. (
7ba0: 70 61 67 65 64 61 74 20 20 28 73 64 61 74 2d 67 pagedat (sdat-g
7bb0: 65 74 2d 70 61 67 65 64 61 74 20 73 65 6c 66 29 et-pagedat self)
7bc0: 29 29 0a 20 20 20 20 28 73 3a 63 67 69 2d 6f 75 )). (s:cgi-ou
7bd0: 74 20 0a 20 20 20 20 20 28 63 6f 6e 73 20 68 65 t . (cons he
7be0: 61 64 65 72 20 70 61 67 65 64 61 74 29 29 29 29 ader pagedat))))
7bf0: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ..(define (sessi
7c00: 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 2e 20 6d 73 on:log self . ms
7c10: 67 29 0a 20 20 28 77 69 74 68 2d 6f 75 74 70 75 g). (with-outpu
7c20: 74 2d 74 6f 2d 70 6f 72 74 20 28 73 64 61 74 2d t-to-port (sdat-
7c30: 67 65 74 2d 6c 6f 67 2d 70 6f 72 74 20 73 65 6c get-log-port sel
7c40: 66 29 20 3b 3b 20 28 73 64 61 74 2d 67 65 74 2d f) ;; (sdat-get-
7c50: 6c 6f 67 70 74 20 73 65 6c 66 29 0a 20 20 20 20 logpt self).
7c60: 28 6c 61 6d 62 64 61 20 28 29 20 0a 20 20 20 20 (lambda () .
7c70: 20 20 28 61 70 70 6c 79 20 70 72 69 6e 74 20 6d (apply print m
7c80: 73 67 29 29 29 29 0a 0a 3b 3b 20 65 73 63 61 70 sg))))..;; escap
7c90: 65 2c 20 63 6f 6e 76 65 72 74 20 6f 72 20 72 65 e, convert or re
7ca0: 74 75 72 6e 20 72 61 77 20 77 68 65 6e 20 67 69 turn raw when gi
7cb0: 76 65 6e 20 75 73 65 72 20 69 6e 70 75 74 20 64 ven user input d
7cc0: 61 74 61 20 74 68 61 74 20 70 6f 74 65 6e 74 69 ata that potenti
7cd0: 61 6c 6c 79 0a 3b 3b 20 63 6f 75 6c 64 20 62 65 ally.;; could be
7ce0: 20 6d 61 6c 69 63 69 6f 75 73 0a 3b 3b 0a 28 64 malicious.;;.(d
7cf0: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 61 efine (session:a
7d00: 70 70 6c 79 2d 74 79 70 65 2d 70 72 65 66 65 72 pply-type-prefer
7d10: 65 6e 63 65 20 72 65 73 20 70 61 72 61 6d 73 29 ence res params)
7d20: 0a 20 20 28 6c 65 74 2a 20 28 28 64 74 79 70 65 . (let* ((dtype
7d30: 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 70 (if (null? p
7d40: 61 72 61 6d 73 29 0a 09 09 20 20 20 20 20 20 20 arams)...
7d50: 27 65 73 63 61 70 65 64 0a 09 09 20 20 20 20 20 'escaped...
7d60: 20 20 28 63 61 72 20 70 61 72 61 6d 73 29 29 29 (car params)))
7d70: 0a 09 20 28 74 61 67 73 20 20 20 20 28 69 66 20 .. (tags (if
7d80: 28 6e 75 6c 6c 3f 20 70 61 72 61 6d 73 29 0a 09 (null? params)..
7d90: 09 20 20 20 20 20 20 27 28 29 0a 09 09 20 20 20 . '()...
7da0: 20 20 20 28 63 64 72 20 70 61 72 61 6d 73 29 29 (cdr params))
7db0: 29 29 0a 20 20 20 20 28 63 61 73 65 20 64 74 79 )). (case dty
7dc0: 70 65 0a 20 20 20 20 20 20 28 28 72 61 77 29 20 pe. ((raw)
7dd0: 20 20 20 20 72 65 73 29 0a 20 20 20 20 20 20 28 res). (
7de0: 28 6e 75 6d 62 65 72 29 20 20 28 69 66 20 28 73 (number) (if (s
7df0: 74 72 69 6e 67 3f 20 72 65 73 29 28 73 74 72 69 tring? res)(stri
7e00: 6e 67 2d 3e 6e 75 6d 62 65 72 20 72 65 73 29 20 ng->number res)
7e10: 23 66 29 29 0a 20 20 20 20 20 20 28 28 65 73 63 #f)). ((esc
7e20: 61 70 65 64 29 20 28 69 66 20 28 73 74 72 69 6e aped) (if (strin
7e30: 67 3f 20 72 65 73 29 0a 09 09 20 20 20 20 20 28 g? res)... (
7e40: 73 3a 68 74 6d 6c 2d 66 69 6c 74 65 72 2d 3e 73 s:html-filter->s
7e50: 74 72 69 6e 67 20 72 65 73 20 74 61 67 73 29 0a tring res tags).
7e60: 09 09 20 20 20 20 20 72 65 73 29 29 0a 20 20 20 .. res)).
7e70: 20 20 20 28 28 65 73 63 61 70 65 64 2d 6e 6c 29 ((escaped-nl)
7e80: 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 72 65 (if (string? re
7e90: 73 29 20 3b 3b 20 65 73 63 61 70 65 20 5c 6e 20 s) ;; escape \n
7ea0: 61 6e 64 20 5c 72 0a 09 09 09 28 73 74 72 69 6e and \r....(strin
7eb0: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 0a 09 09 g-intersperse...
7ec0: 09 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 0a . (string-split.
7ed0: 09 09 09 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 ... (string-int
7ee0: 65 72 73 70 65 72 73 65 0a 09 09 09 20 20 20 28 ersperse.... (
7ef0: 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 28 73 3a string-split (s:
7f00: 68 74 6d 6c 2d 66 69 6c 74 65 72 2d 3e 73 74 72 html-filter->str
7f10: 69 6e 67 20 72 65 73 20 74 61 67 73 29 20 22 5c ing res tags) "\
7f20: 6e 22 29 0a 09 09 09 20 20 20 22 5c 5c 6e 22 29 n").... "\\n")
7f30: 0a 09 09 09 20 20 22 5c 72 22 29 0a 09 09 09 20 .... "\r")....
7f40: 22 5c 5c 72 22 29 0a 09 09 09 72 65 73 29 29 20 "\\r")....res))
7f50: 3b 3b 20 73 68 6f 75 6c 64 20 72 65 74 75 72 6e ;; should return
7f60: 20 23 66 20 69 66 20 6e 6f 74 20 61 20 73 74 72 #f if not a str
7f70: 69 6e 67 20 61 6e 64 20 63 61 6e 27 74 20 65 73 ing and can't es
7f80: 63 61 70 65 20 69 74 3f 0a 20 20 20 20 20 20 28 cape it?. (
7f90: 65 6c 73 65 20 20 20 20 20 20 28 69 66 20 28 73 else (if (s
7fa0: 74 72 69 6e 67 3f 20 72 65 73 29 0a 09 09 20 20 tring? res)...
7fb0: 20 20 20 28 73 3a 68 74 6d 6c 2d 66 69 6c 74 65 (s:html-filte
7fc0: 72 2d 3e 73 74 72 69 6e 67 20 72 65 73 20 27 28 r->string res '(
7fd0: 29 29 0a 09 09 20 20 20 20 20 72 65 73 29 29 29 ))... res)))
7fe0: 29 29 0a 0a 3b 3b 20 70 61 72 61 6d 73 20 61 72 ))..;; params ar
7ff0: 65 20 73 74 6f 72 65 64 20 61 73 20 6c 69 73 74 e stored as list
8000: 20 6f 66 20 6b 65 79 3d 76 61 6c 0a 3b 3b 0a 28 of key=val.;;.(
8010: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
8020: 67 65 74 2d 70 61 72 61 6d 20 73 65 6c 66 20 6b get-param self k
8030: 65 79 20 74 79 70 65 2d 70 61 72 61 6d 73 29 0a ey type-params).
8040: 20 20 3b 3b 20 28 73 65 73 73 69 6f 6e 3a 6c 6f ;; (session:lo
8050: 67 20 73 3a 73 65 73 73 69 6f 6e 20 22 70 61 72 g s:session "par
8060: 61 6d 73 3d 22 20 28 73 6c 6f 74 2d 72 65 66 20 ams=" (slot-ref
8070: 73 3a 73 65 73 73 69 6f 6e 20 27 70 61 72 61 6d s:session 'param
8080: 73 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 70 61 s)). (let* ((pa
8090: 72 61 6d 73 20 28 73 64 61 74 2d 67 65 74 2d 70 rams (sdat-get-p
80a0: 61 72 61 6d 73 20 73 65 6c 66 29 29 0a 09 20 28 arams self)).. (
80b0: 72 65 73 20 20 20 20 28 73 65 73 73 69 6f 6e 3a res (session:
80c0: 67 65 74 2d 70 61 72 61 6d 2d 66 72 6f 6d 20 70 get-param-from p
80d0: 61 72 61 6d 73 20 6b 65 79 29 29 29 0a 20 20 20 arams key))).
80e0: 20 28 73 65 73 73 69 6f 6e 3a 61 70 70 6c 79 2d (session:apply-
80f0: 74 79 70 65 2d 70 72 65 66 65 72 65 6e 63 65 20 type-preference
8100: 72 65 73 20 74 79 70 65 2d 70 61 72 61 6d 73 29 res type-params)
8110: 29 29 0a 0a 3b 3b 20 54 68 69 73 20 6f 6e 65 20 ))..;; This one
8120: 77 69 6c 6c 20 67 65 74 20 74 68 65 20 66 69 72 will get the fir
8130: 73 74 20 76 61 6c 75 65 20 66 6f 75 6e 64 20 72 st value found r
8140: 65 67 61 72 64 6c 65 73 73 20 6f 66 20 66 6f 72 egardless of for
8150: 6d 0a 3b 3b 20 70 61 72 61 6d 3a 20 28 64 74 79 m.;; param: (dty
8160: 70 65 20 5b 74 61 67 31 20 74 61 67 32 20 2e 2e pe [tag1 tag2 ..
8170: 2e 5d 29 0a 3b 3b 20 64 74 79 70 65 3a 0a 3b 3b .]).;; dtype:.;;
8180: 20 20 20 20 27 72 61 77 20 20 20 20 20 3a 20 64 'raw : d
8190: 6f 20 6e 6f 20 63 6f 6e 76 65 72 73 69 6f 6e 0a o no conversion.
81a0: 3b 3b 20 20 20 20 27 6e 75 6d 62 65 72 20 20 3a ;; 'number :
81b0: 20 63 6f 6e 76 65 72 74 20 74 6f 20 6e 75 6d 62 convert to numb
81c0: 65 72 2c 20 72 65 74 75 72 6e 20 23 66 20 69 66 er, return #f if
81d0: 20 66 61 69 6c 73 0a 3b 3b 20 20 20 20 27 65 73 fails.;; 'es
81e0: 63 61 70 65 64 20 3a 20 75 73 65 20 68 74 6d 6c caped : use html
81f0: 2d 65 73 63 61 70 65 20 74 6f 20 70 72 6f 74 65 -escape to prote
8200: 63 74 20 74 68 65 20 69 6e 70 75 74 20 2d 2d 20 ct the input --
8210: 74 68 69 73 20 69 73 20 74 68 65 20 64 65 66 61 this is the defa
8220: 75 6c 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 ult.;;.(define (
8230: 73 65 73 73 69 6f 6e 3a 67 65 74 2d 69 6e 70 75 session:get-inpu
8240: 74 20 73 65 6c 66 20 6b 65 79 20 70 61 72 61 6d t self key param
8250: 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 74 79 s). (let* ((dty
8260: 70 65 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f pe (if (null?
8270: 20 70 61 72 61 6d 73 29 0a 09 09 20 20 20 20 20 params)...
8280: 20 20 27 65 73 63 61 70 65 64 0a 09 09 20 20 20 'escaped...
8290: 20 20 20 20 28 63 61 72 20 70 61 72 61 6d 73 29 (car params)
82a0: 29 29 0a 09 20 28 74 61 67 73 20 20 20 20 28 69 )).. (tags (i
82b0: 66 20 28 6e 75 6c 6c 3f 20 70 61 72 61 6d 73 29 f (null? params)
82c0: 0a 09 09 20 20 20 20 20 20 27 28 29 0a 09 09 20 ... '()...
82d0: 20 20 20 20 20 28 63 64 72 20 70 61 72 61 6d 73 (cdr params
82e0: 29 29 29 0a 09 20 28 66 6f 72 6d 64 61 74 20 28 ))).. (formdat (
82f0: 73 64 61 74 2d 67 65 74 2d 66 6f 72 6d 64 61 74 sdat-get-formdat
8300: 20 73 65 6c 66 29 29 0a 09 20 28 72 65 73 20 20 self)).. (res
8310: 20 20 20 28 69 66 20 28 6e 6f 74 20 66 6f 72 6d (if (not form
8320: 64 61 74 29 20 23 66 0a 09 09 20 20 20 20 20 20 dat) #f...
8330: 28 69 66 20 28 6f 72 20 28 73 74 72 69 6e 67 3f (if (or (string?
8340: 20 6b 65 79 29 28 6e 75 6d 62 65 72 3f 20 6b 65 key)(number? ke
8350: 79 29 28 73 79 6d 62 6f 6c 3f 20 6b 65 79 29 29 y)(symbol? key))
8360: 0a 09 09 09 20 20 28 69 66 20 28 61 6e 64 20 28 .... (if (and (
8370: 76 65 63 74 6f 72 3f 20 66 6f 72 6d 64 61 74 29 vector? formdat)
8380: 28 65 71 3f 20 28 76 65 63 74 6f 72 2d 6c 65 6e (eq? (vector-len
8390: 67 74 68 20 66 6f 72 6d 64 61 74 29 20 31 29 28 gth formdat) 1)(
83a0: 68 61 73 68 2d 74 61 62 6c 65 3f 20 28 76 65 63 hash-table? (vec
83b0: 74 6f 72 2d 72 65 66 20 66 6f 72 6d 64 61 74 20 tor-ref formdat
83c0: 30 29 29 29 0a 09 09 09 20 20 20 20 20 20 28 66 0))).... (f
83d0: 6f 72 6d 64 61 74 3a 67 65 74 20 66 6f 72 6d 64 ormdat:get formd
83e0: 61 74 20 6b 65 79 29 0a 09 09 09 20 20 20 20 20 at key)....
83f0: 20 28 62 65 67 69 6e 0a 09 09 09 09 28 73 65 73 (begin.....(ses
8400: 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 45 sion:log self "E
8410: 52 52 4f 52 3a 20 66 6f 72 6d 64 61 74 3a 20 22 RROR: formdat: "
8420: 20 66 6f 72 6d 64 61 74 20 22 20 69 73 20 6e 6f formdat " is no
8430: 74 20 6f 66 20 63 6c 61 73 73 20 3c 66 6f 72 6d t of class <form
8440: 64 61 74 3e 22 29 0a 09 09 09 09 23 66 29 29 0a dat>").....#f)).
8450: 09 09 09 20 20 28 62 65 67 69 6e 0a 09 09 09 20 ... (begin....
8460: 20 20 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 (session:log
8470: 73 65 6c 66 20 22 45 52 52 4f 52 3a 20 62 61 64 self "ERROR: bad
8480: 20 6b 65 79 20 22 20 6b 65 79 29 0a 09 09 09 20 key " key)....
8490: 20 20 20 23 66 29 29 29 29 29 0a 20 20 20 20 28 #f))))). (
84a0: 63 61 73 65 20 64 74 79 70 65 0a 20 20 20 20 20 case dtype.
84b0: 20 28 28 72 61 77 29 20 20 20 20 20 72 65 73 29 ((raw) res)
84c0: 0a 20 20 20 20 20 20 28 28 6e 75 6d 62 65 72 29 . ((number)
84d0: 20 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 72 (if (string? r
84e0: 65 73 29 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 es)(string->numb
84f0: 65 72 20 72 65 73 29 20 23 66 29 29 0a 20 20 20 er res) #f)).
8500: 20 20 20 28 28 65 73 63 61 70 65 64 29 20 28 69 ((escaped) (i
8510: 66 20 28 73 74 72 69 6e 67 3f 20 72 65 73 29 0a f (string? res).
8520: 09 09 20 20 20 20 20 28 73 3a 68 74 6d 6c 2d 66 .. (s:html-f
8530: 69 6c 74 65 72 2d 3e 73 74 72 69 6e 67 20 72 65 ilter->string re
8540: 73 20 74 61 67 73 29 0a 09 09 20 20 20 20 20 72 s tags)... r
8550: 65 73 29 29 0a 20 20 20 20 20 20 28 65 6c 73 65 es)). (else
8560: 20 20 20 20 20 20 28 69 66 20 28 73 74 72 69 6e (if (strin
8570: 67 3f 20 72 65 73 29 0a 09 09 20 20 20 20 20 28 g? res)... (
8580: 73 3a 68 74 6d 6c 2d 66 69 6c 74 65 72 2d 3e 73 s:html-filter->s
8590: 74 72 69 6e 67 20 72 65 73 20 27 28 29 29 0a 09 tring res '())..
85a0: 09 20 20 20 20 20 72 65 73 29 29 29 29 29 0a 0a . res)))))..
85b0: 3b 3b 20 54 68 69 73 20 6f 6e 65 20 77 69 6c 6c ;; This one will
85c0: 20 67 65 74 20 74 68 65 20 66 69 72 73 74 20 76 get the first v
85d0: 61 6c 75 65 20 66 6f 75 6e 64 20 72 65 67 61 72 alue found regar
85e0: 64 6c 65 73 73 20 6f 66 20 66 6f 72 6d 0a 28 64 dless of form.(d
85f0: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 efine (session:g
8600: 65 74 2d 69 6e 70 75 74 2d 6b 65 79 73 20 73 65 et-input-keys se
8610: 6c 66 29 0a 20 20 28 6c 65 74 2a 20 28 28 66 6f lf). (let* ((fo
8620: 72 6d 64 61 74 20 28 73 64 61 74 2d 67 65 74 2d rmdat (sdat-get-
8630: 66 6f 72 6d 64 61 74 20 73 65 6c 66 29 29 29 0a formdat self))).
8640: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 66 6f 72 (if (not for
8650: 6d 64 61 74 29 20 23 66 0a 09 28 69 66 20 28 61 mdat) #f..(if (a
8660: 6e 64 20 28 76 65 63 74 6f 72 3f 20 66 6f 72 6d nd (vector? form
8670: 64 61 74 29 28 65 71 3f 20 28 76 65 63 74 6f 72 dat)(eq? (vector
8680: 2d 6c 65 6e 67 74 68 20 66 6f 72 6d 64 61 74 29 -length formdat)
8690: 20 31 29 28 68 61 73 68 2d 74 61 62 6c 65 3f 20 1)(hash-table?
86a0: 28 76 65 63 74 6f 72 2d 72 65 66 20 66 6f 72 6d (vector-ref form
86b0: 64 61 74 20 30 29 29 29 0a 09 20 20 20 20 28 66 dat 0))).. (f
86c0: 6f 72 6d 64 61 74 3a 6b 65 79 73 20 66 6f 72 6d ormdat:keys form
86d0: 64 61 74 29 0a 09 20 20 20 20 28 62 65 67 69 6e dat).. (begin
86e0: 0a 09 20 20 20 20 20 20 28 73 65 73 73 69 6f 6e .. (session
86f0: 3a 6c 6f 67 20 73 65 6c 66 20 22 45 52 52 4f 52 :log self "ERROR
8700: 3a 20 66 6f 72 6d 64 61 74 3a 20 22 20 66 6f 72 : formdat: " for
8710: 6d 64 61 74 20 22 20 69 73 20 6e 6f 74 20 6f 66 mdat " is not of
8720: 20 63 6c 61 73 73 20 3c 66 6f 72 6d 64 61 74 3e class <formdat>
8730: 22 29 0a 09 20 20 20 20 20 20 23 66 29 29 29 29 ").. #f))))
8740: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 )..(define (sess
8750: 69 6f 6e 3a 72 75 6e 2d 61 63 74 69 6f 6e 73 20 ion:run-actions
8760: 73 65 6c 66 29 0a 20 20 28 6c 65 74 2a 20 28 28 self). (let* ((
8770: 61 63 74 69 6f 6e 20 20 20 20 28 73 65 73 73 69 action (sessi
8780: 6f 6e 3a 67 65 74 2d 70 61 72 61 6d 20 73 65 6c on:get-param sel
8790: 66 20 27 61 63 74 69 6f 6e 20 27 28 72 61 77 29 f 'action '(raw)
87a0: 29 29 0a 09 20 28 70 61 67 65 20 20 20 20 20 20 )).. (page
87b0: 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 20 73 (sdat-get-page s
87c0: 65 6c 66 29 29 29 0a 20 20 20 20 3b 3b 20 28 70 elf))). ;; (p
87d0: 72 69 6e 74 20 22 61 63 74 69 6f 6e 3d 22 20 61 rint "action=" a
87e0: 63 74 69 6f 6e 20 22 20 70 61 67 65 3d 22 20 70 ction " page=" p
87f0: 61 67 65 29 0a 20 20 20 20 28 69 66 20 61 63 74 age). (if act
8800: 69 6f 6e 0a 09 28 6c 65 74 20 28 28 61 63 74 69 ion..(let ((acti
8810: 6f 6e 2d 6c 73 74 20 20 28 73 74 72 69 6e 67 2d on-lst (string-
8820: 73 70 6c 69 74 20 61 63 74 69 6f 6e 20 22 2e 22 split action "."
8830: 29 29 29 0a 09 20 20 3b 3b 20 28 70 72 69 6e 74 ))).. ;; (print
8840: 20 22 61 63 74 69 6f 6e 2d 6c 73 74 3d 22 20 61 "action-lst=" a
8850: 63 74 69 6f 6e 2d 6c 73 74 29 0a 09 20 20 28 69 ction-lst).. (i
8860: 66 20 28 6e 6f 74 20 28 3d 20 28 6c 65 6e 67 74 f (not (= (lengt
8870: 68 20 61 63 74 69 6f 6e 2d 6c 73 74 29 20 32 29 h action-lst) 2)
8880: 29 20 0a 09 20 20 20 20 20 20 28 65 72 72 3a 6c ) .. (err:l
8890: 6f 67 20 22 41 63 74 69 6f 6e 20 73 68 6f 75 6c og "Action shoul
88a0: 64 20 62 65 20 6f 66 20 66 6f 72 6d 3a 20 6d 6f d be of form: mo
88b0: 64 75 6c 65 2e 61 63 74 69 6f 6e 22 29 0a 09 20 dule.action")..
88c0: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 61 72 (let* ((tar
88d0: 67 2d 70 61 67 65 20 20 20 28 63 61 72 20 61 63 g-page (car ac
88e0: 74 69 6f 6e 2d 6c 73 74 29 29 0a 09 09 20 20 20 tion-lst))...
88f0: 20 20 28 70 72 6f 63 2d 6e 61 6d 65 20 20 20 28 (proc-name (
8900: 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 74 61 string-append ta
8910: 72 67 2d 70 61 67 65 20 22 2d 61 63 74 69 6f 6e rg-page "-action
8920: 22 29 29 0a 09 09 20 20 20 20 20 28 74 61 72 67 "))... (targ
8930: 2d 61 63 74 69 6f 6e 20 28 63 61 64 72 20 61 63 -action (cadr ac
8940: 74 69 6f 6e 2d 6c 73 74 29 29 29 0a 09 09 3b 3b tion-lst)))...;;
8950: 20 28 65 72 72 3a 6c 6f 67 20 22 74 61 72 67 2d (err:log "targ-
8960: 70 61 67 65 3d 22 20 74 61 72 67 2d 70 61 67 65 page=" targ-page
8970: 20 22 20 70 72 6f 63 2d 6e 61 6d 65 3d 22 20 70 " proc-name=" p
8980: 72 6f 63 2d 6e 61 6d 65 20 22 20 74 61 72 67 2d roc-name " targ-
8990: 61 63 74 69 6f 6e 3d 22 20 74 61 72 67 2d 61 63 action=" targ-ac
89a0: 74 69 6f 6e 29 0a 0a 09 09 3b 3b 20 63 61 6c 6c tion)....;; call
89b0: 20 68 65 72 65 20 6f 6e 6c 79 20 69 66 20 6e 65 here only if ne
89c0: 76 65 72 20 63 61 6c 6c 65 64 20 62 65 66 6f 72 ver called befor
89d0: 65 0a 09 09 28 69 66 20 28 73 65 73 73 69 6f 6e e...(if (session
89e0: 3a 6e 65 76 65 72 2d 63 61 6c 6c 65 64 2d 70 61 :never-called-pa
89f0: 67 65 3f 20 73 65 6c 66 20 74 61 72 67 2d 70 61 ge? self targ-pa
8a00: 67 65 29 0a 09 09 20 20 20 20 28 73 65 73 73 69 ge)... (sessi
8a10: 6f 6e 3a 63 61 6c 6c 2d 70 61 72 74 73 20 73 65 on:call-parts se
8a20: 6c 66 20 74 61 72 67 2d 70 61 67 65 20 27 63 6f lf targ-page 'co
8a30: 6e 74 72 6f 6c 29 29 0a 09 09 3b 3b 20 20 20 20 ntrol))...;;
8a40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8a50: 70 72 6f 63 20 20 20 20 20 20 20 20 20 20 20 20 proc
8a60: 20 20 20 20 20 20 20 20 20 20 20 20 20 61 63 74 act
8a70: 69 6f 6e 20 20 20 20 0a 0a 09 09 28 69 66 20 23 ion ....(if #
8a80: 74 20 3b 3b 20 73 65 74 20 74 6f 20 23 74 20 74 t ;; set to #t t
8a90: 6f 20 73 65 65 20 62 65 74 74 65 72 20 65 72 72 o see better err
8aa0: 6f 72 20 6d 65 73 73 61 67 65 73 20 64 75 72 69 or messages duri
8ab0: 6e 67 20 64 65 62 75 67 67 69 6e 20 3a 2d 29 0a ng debuggin :-).
8ac0: 09 09 20 20 20 20 28 28 65 76 61 6c 20 28 73 74 .. ((eval (st
8ad0: 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 70 72 6f ring->symbol pro
8ae0: 63 2d 6e 61 6d 65 29 29 20 74 61 72 67 2d 61 63 c-name)) targ-ac
8af0: 74 69 6f 6e 29 20 3b 3b 20 75 6e 73 61 66 65 20 tion) ;; unsafe
8b00: 65 78 65 63 75 74 69 6f 6e 0a 09 09 20 20 20 20 execution...
8b10: 28 63 6f 6e 64 69 74 69 6f 6e 2d 63 61 73 65 20 (condition-case
8b20: 28 28 65 76 61 6c 20 28 73 74 72 69 6e 67 2d 3e ((eval (string->
8b30: 73 79 6d 62 6f 6c 20 70 72 6f 63 2d 6e 61 6d 65 symbol proc-name
8b40: 29 29 20 74 61 72 67 2d 61 63 74 69 6f 6e 29 0a )) targ-action).
8b50: 09 09 09 09 20 20 20 20 28 28 65 78 6e 20 66 69 .... ((exn fi
8b60: 6c 65 29 20 28 73 3a 6c 6f 67 20 22 66 69 6c 65 le) (s:log "file
8b70: 20 65 72 72 6f 72 22 29 29 0a 09 09 09 09 20 20 error")).....
8b80: 20 20 28 28 65 78 6e 20 69 2f 6f 29 20 20 28 73 ((exn i/o) (s
8b90: 3a 6c 6f 67 20 22 69 2f 6f 20 65 72 72 6f 72 22 :log "i/o error"
8ba0: 29 29 0a 09 09 09 09 20 20 20 20 28 28 65 78 6e ))..... ((exn
8bb0: 20 29 20 20 20 20 20 28 73 3a 6c 6f 67 20 22 41 ) (s:log "A
8bc0: 63 74 69 6f 6e 20 6e 6f 74 20 69 6d 70 6c 65 6d ction not implem
8bd0: 65 6e 74 65 64 3a 20 22 20 70 72 6f 63 2d 6e 61 ented: " proc-na
8be0: 6d 65 20 22 20 61 63 74 69 6f 6e 3a 20 22 20 74 me " action: " t
8bf0: 61 72 67 2d 61 63 74 69 6f 6e 29 29 0a 09 09 09 arg-action))....
8c00: 09 20 20 20 20 28 76 61 72 20 28 29 20 20 20 20 . (var ()
8c10: 20 28 73 3a 6c 6f 67 20 22 55 6e 6b 6e 6f 77 6e (s:log "Unknown
8c20: 20 45 72 72 6f 72 22 29 29 29 29 29 29 29 29 29 Error")))))))))
8c30: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 )..(define (sess
8c40: 69 6f 6e 3a 6e 65 76 65 72 2d 63 61 6c 6c 65 64 ion:never-called
8c50: 2d 70 61 67 65 3f 20 73 65 6c 66 20 70 61 67 65 -page? self page
8c60: 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 ). (session:log
8c70: 20 73 65 6c 66 20 22 43 68 65 63 6b 69 6e 67 20 self "Checking
8c80: 66 6f 72 20 70 61 67 65 3a 20 22 20 70 61 67 65 for page: " page
8c90: 29 0a 20 20 28 6e 6f 74 20 28 6d 65 6d 62 65 72 ). (not (member
8ca0: 20 70 61 67 65 20 28 73 64 61 74 2d 67 65 74 2d page (sdat-get-
8cb0: 73 65 65 6e 2d 70 61 67 65 73 20 73 65 6c 66 29 seen-pages self)
8cc0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 )))..(define (se
8cd0: 73 73 69 6f 6e 3a 73 65 74 2d 63 61 6c 6c 65 64 ssion:set-called
8ce0: 21 20 73 65 6c 66 20 70 61 67 65 29 0a 20 20 28 ! self page). (
8cf0: 73 64 61 74 2d 73 65 74 2d 73 65 65 6e 2d 70 61 sdat-set-seen-pa
8d00: 67 65 73 21 20 73 65 6c 66 20 28 63 6f 6e 73 20 ges! self (cons
8d10: 70 61 67 65 20 28 73 64 61 74 2d 67 65 74 2d 73 page (sdat-get-s
8d20: 65 65 6e 2d 70 61 67 65 73 20 73 65 6c 66 29 29 een-pages self))
8d30: 29 29 0a 0a 3b 3b 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 3d 3d 3d ================
8d60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8d70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
8d80: 41 6c 74 65 72 6e 61 74 69 76 65 20 64 61 74 61 Alternative data
8d90: 20 74 79 70 65 20 64 65 6c 69 76 65 72 79 0a 3b type delivery.;
8da0: 3b 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 3d 3d 3d 3d 3d 3d 3d 3d ================
8dd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8de0: 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 =======..(define
8df0: 20 28 73 65 73 73 69 6f 6e 3a 61 6c 74 2d 6f 75 (session:alt-ou
8e00: 74 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 20 28 t self). (let (
8e10: 28 64 61 74 20 28 73 64 61 74 2d 67 65 74 2d 61 (dat (sdat-get-a
8e20: 6c 74 2d 70 61 67 65 2d 64 61 74 20 73 65 6c 66 lt-page-dat self
8e30: 29 29 29 0a 20 20 20 20 3b 3b 20 28 73 3a 6c 6f ))). ;; (s:lo
8e40: 67 20 22 64 61 74 20 69 73 3a 20 22 20 64 61 74 g "dat is: " dat
8e50: 29 0a 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 ). ;; (print
8e60: 22 48 54 54 50 2f 31 2e 31 20 32 30 30 20 4f 4b "HTTP/1.1 200 OK
8e70: 22 29 0a 20 20 20 20 28 70 72 69 6e 74 20 22 44 "). (print "D
8e80: 61 74 65 3a 20 22 20 28 74 69 6d 65 2d 3e 73 74 ate: " (time->st
8e90: 72 69 6e 67 20 28 73 65 63 6f 6e 64 73 2d 3e 75 ring (seconds->u
8ea0: 74 63 2d 74 69 6d 65 20 28 63 75 72 72 65 6e 74 tc-time (current
8eb0: 2d 73 65 63 6f 6e 64 73 29 29 29 29 0a 20 20 20 -seconds)))).
8ec0: 20 28 70 72 69 6e 74 20 22 43 6f 6e 74 65 6e 74 (print "Content
8ed0: 2d 54 79 70 65 3a 20 22 20 28 73 64 61 74 2d 67 -Type: " (sdat-g
8ee0: 65 74 2d 63 6f 6e 74 65 6e 74 2d 74 79 70 65 20 et-content-type
8ef0: 73 65 6c 66 29 29 0a 20 20 20 20 28 70 72 69 6e self)). (prin
8f00: 74 20 22 41 63 63 65 70 74 2d 52 61 6e 67 65 73 t "Accept-Ranges
8f10: 3a 20 62 79 74 65 73 22 29 0a 20 20 20 20 28 70 : bytes"). (p
8f20: 72 69 6e 74 20 22 43 6f 6e 74 65 6e 74 2d 4c 65 rint "Content-Le
8f30: 6e 67 74 68 3a 20 22 20 28 69 66 20 28 62 6c 6f ngth: " (if (blo
8f40: 62 3f 20 64 61 74 29 0a 09 09 09 09 20 20 28 62 b? dat)..... (b
8f50: 6c 6f 62 2d 73 69 7a 65 20 64 61 74 29 0a 09 09 lob-size dat)...
8f60: 09 09 20 20 30 29 29 0a 20 20 20 20 28 70 72 69 .. 0)). (pri
8f70: 6e 74 20 22 4b 65 65 70 2d 41 6c 69 76 65 3a 20 nt "Keep-Alive:
8f80: 74 69 6d 65 6f 75 74 3d 31 35 2c 20 6d 61 78 3d timeout=15, max=
8f90: 31 30 30 22 29 0a 20 20 20 20 28 70 72 69 6e 74 100"). (print
8fa0: 20 22 43 6f 6e 6e 65 63 74 69 6f 6e 3a 20 4b 65 "Connection: Ke
8fb0: 65 70 2d 41 6c 69 76 65 22 29 0a 20 20 20 20 28 ep-Alive"). (
8fc0: 70 72 69 6e 74 20 22 22 29 0a 20 20 20 20 28 77 print ""). (w
8fd0: 72 69 74 65 2d 73 74 72 69 6e 67 20 28 62 6c 6f rite-string (blo
8fe0: 62 2d 3e 73 74 72 69 6e 67 20 64 61 74 29 20 23 b->string dat) #
8ff0: 66 20 28 63 75 72 72 65 6e 74 2d 6f 75 74 70 75 f (current-outpu
9000: 74 2d 70 6f 72 74 29 29 29 29 0a t-port)))).