Artifact
6feb50842f21399ec8fb437e9bdfea19706a17e0:
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 36 29 29 0a 28 64 65 66 69 ector 36)).(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 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d ).(define (sdat-
0eb0: 67 65 74 2d 66 6f 72 63 65 2d 73 73 6c 20 20 20 get-force-ssl
0ec0: 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 vec)
0ed0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 (vector-ref ve
0ee0: 63 20 33 35 29 29 0a 0a 28 64 65 66 69 6e 65 20 c 35))..(define
0ef0: 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 73 68 61 (session:get-sha
0f00: 72 65 64 20 76 65 63 20 76 61 72 6e 61 6d 65 29 red vec varname)
0f10: 0a 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 . (hash-table-r
0f20: 65 66 2f 64 65 66 61 75 6c 74 20 28 76 65 63 74 ef/default (vect
0f30: 6f 72 2d 72 65 66 20 76 65 63 20 33 33 29 20 76 or-ref vec 33) v
0f40: 61 72 6e 61 6d 65 20 23 66 29 29 0a 0a 28 64 65 arname #f))..(de
0f50: 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 64 fine (sdat-set-d
0f60: 62 74 79 70 65 21 20 20 20 20 20 20 20 20 20 20 btype!
0f70: 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 vec val)(vec
0f80: 74 6f 72 2d 73 65 74 21 20 76 65 63 20 30 20 76 tor-set! vec 0 v
0f90: 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 al)).(define (sd
0fa0: 61 74 2d 73 65 74 2d 64 62 69 6e 69 74 21 20 20 at-set-dbinit!
0fb0: 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 20 vec
0fc0: 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 val)(vector-set!
0fd0: 20 76 65 63 20 31 20 76 61 6c 29 29 0a 28 64 65 vec 1 val)).(de
0fe0: 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 63 fine (sdat-set-c
0ff0: 6f 6e 6e 21 20 20 20 20 20 20 20 20 20 20 20 20 onn!
1000: 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 vec val)(vec
1010: 74 6f 72 2d 73 65 74 21 20 76 65 63 20 32 20 76 tor-set! vec 2 v
1020: 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 al)).(define (sd
1030: 61 74 2d 73 65 74 2d 70 61 72 61 6d 73 21 20 20 at-set-params!
1040: 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 20 vec
1050: 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 val)(vector-set!
1060: 20 76 65 63 20 33 20 76 61 6c 29 29 0a 28 64 65 vec 3 val)).(de
1070: 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 70 fine (sdat-set-p
1080: 61 74 68 2d 70 61 72 61 6d 73 21 20 20 20 20 20 ath-params!
1090: 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 vec val)(vec
10a0: 74 6f 72 2d 73 65 74 21 20 76 65 63 20 34 20 76 tor-set! vec 4 v
10b0: 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 al)).(define (sd
10c0: 61 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e 2d 6b at-set-session-k
10d0: 65 79 21 20 20 20 20 20 20 20 20 20 76 65 63 20 ey! vec
10e0: 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 val)(vector-set!
10f0: 20 76 65 63 20 35 20 76 61 6c 29 29 0a 28 64 65 vec 5 val)).(de
1100: 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 73 fine (sdat-set-s
1110: 65 73 73 69 6f 6e 2d 69 64 21 20 20 20 20 20 20 ession-id!
1120: 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 vec val)(vec
1130: 74 6f 72 2d 73 65 74 21 20 76 65 63 20 36 20 76 tor-set! vec 6 v
1140: 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 al)).(define (sd
1150: 61 74 2d 73 65 74 2d 64 6f 6d 61 69 6e 21 20 20 at-set-domain!
1160: 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 20 vec
1170: 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 val)(vector-set!
1180: 20 76 65 63 20 37 20 76 61 6c 29 29 0a 28 64 65 vec 7 val)).(de
1190: 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 74 fine (sdat-set-t
11a0: 6f 70 70 61 67 65 21 20 20 20 20 20 20 20 20 20 oppage!
11b0: 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 vec val)(vec
11c0: 74 6f 72 2d 73 65 74 21 20 76 65 63 20 38 20 76 tor-set! vec 8 v
11d0: 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 al)).(define (sd
11e0: 61 74 2d 73 65 74 2d 70 61 67 65 21 20 20 20 20 at-set-page!
11f0: 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 20 vec
1200: 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 val)(vector-set!
1210: 20 76 65 63 20 39 20 76 61 6c 29 29 0a 28 64 65 vec 9 val)).(de
1220: 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 63 fine (sdat-set-c
1230: 75 72 72 2d 70 61 67 65 21 20 20 20 20 20 20 20 urr-page!
1240: 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 vec val)(vec
1250: 74 6f 72 2d 73 65 74 21 20 76 65 63 20 31 30 20 tor-set! vec 10
1260: 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 val)).(define (s
1270: 64 61 74 2d 73 65 74 2d 63 6f 6e 74 65 6e 74 2d dat-set-content-
1280: 74 79 70 65 21 20 20 20 20 20 20 20 20 76 65 63 type! vec
1290: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
12a0: 21 20 76 65 63 20 31 31 20 76 61 6c 29 29 0a 28 ! vec 11 val)).(
12b0: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 define (sdat-set
12c0: 2d 70 61 67 65 2d 74 79 70 65 21 20 20 20 20 20 -page-type!
12d0: 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 vec val)(v
12e0: 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 31 ector-set! vec 1
12f0: 32 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 2 val)).(define
1300: 28 73 64 61 74 2d 73 65 74 2d 73 72 6f 6f 74 21 (sdat-set-sroot!
1310: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 76 v
1320: 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 ec val)(vector-s
1330: 65 74 21 20 76 65 63 20 31 33 20 76 61 6c 29 29 et! vec 13 val))
1340: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 .(define (sdat-s
1350: 65 74 2d 74 77 69 6b 69 64 69 72 21 20 20 20 20 et-twikidir!
1360: 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 vec val)
1370: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 (vector-set! vec
1380: 20 31 34 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 14 val)).(defin
1390: 65 20 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 e (sdat-set-page
13a0: 64 61 74 21 20 20 20 20 20 20 20 20 20 20 20 20 dat!
13b0: 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 vec val)(vector
13c0: 2d 73 65 74 21 20 76 65 63 20 31 35 20 76 61 6c -set! vec 15 val
13d0: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
13e0: 2d 73 65 74 2d 61 6c 74 2d 70 61 67 65 2d 64 61 -set-alt-page-da
13f0: 74 21 20 20 20 20 20 20 20 20 76 65 63 20 76 61 t! vec va
1400: 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 l)(vector-set! v
1410: 65 63 20 31 36 20 76 61 6c 29 29 0a 28 64 65 66 ec 16 val)).(def
1420: 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 70 61 ine (sdat-set-pa
1430: 67 65 76 61 72 73 21 20 20 20 20 20 20 20 20 20 gevars!
1440: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
1450: 6f 72 2d 73 65 74 21 20 76 65 63 20 31 37 20 76 or-set! vec 17 v
1460: 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 al)).(define (sd
1470: 61 74 2d 73 65 74 2d 70 61 67 65 76 61 72 73 2d at-set-pagevars-
1480: 62 65 66 6f 72 65 21 20 20 20 20 20 76 65 63 20 before! vec
1490: 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 val)(vector-set!
14a0: 20 76 65 63 20 31 38 20 76 61 6c 29 29 0a 28 64 vec 18 val)).(d
14b0: 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d efine (sdat-set-
14c0: 73 65 73 73 69 6f 6e 76 61 72 73 21 20 20 20 20 sessionvars!
14d0: 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 vec val)(ve
14e0: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 31 39 ctor-set! vec 19
14f0: 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 val)).(define (
1500: 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e sdat-set-session
1510: 76 61 72 73 2d 62 65 66 6f 72 65 21 20 20 76 65 vars-before! ve
1520: 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 c val)(vector-se
1530: 74 21 20 76 65 63 20 32 30 20 76 61 6c 29 29 0a t! vec 20 val)).
1540: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 (define (sdat-se
1550: 74 2d 67 6c 6f 62 61 6c 76 61 72 73 21 20 20 20 t-globalvars!
1560: 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 vec val)(
1570: 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 vector-set! vec
1580: 32 31 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 21 val)).(define
1590: 20 28 73 64 61 74 2d 73 65 74 2d 67 6c 6f 62 61 (sdat-set-globa
15a0: 6c 76 61 72 73 2d 62 65 66 6f 72 65 21 20 20 20 lvars-before!
15b0: 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d vec val)(vector-
15c0: 73 65 74 21 20 76 65 63 20 32 32 20 76 61 6c 29 set! vec 22 val)
15d0: 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d ).(define (sdat-
15e0: 73 65 74 2d 6c 6f 67 70 74 21 20 20 20 20 20 20 set-logpt!
15f0: 20 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c vec val
1600: 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 )(vector-set! ve
1610: 63 20 32 33 20 76 61 6c 29 29 0a 28 64 65 66 69 c 23 val)).(defi
1620: 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 66 6f 72 ne (sdat-set-for
1630: 6d 64 61 74 21 20 20 20 20 20 20 20 20 20 20 20 mdat!
1640: 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f vec val)(vecto
1650: 72 2d 73 65 74 21 20 76 65 63 20 32 34 20 76 61 r-set! vec 24 va
1660: 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 l)).(define (sda
1670: 74 2d 73 65 74 2d 72 65 71 75 65 73 74 2d 6d 65 t-set-request-me
1680: 74 68 6f 64 21 20 20 20 20 20 20 76 65 63 20 76 thod! vec v
1690: 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 al)(vector-set!
16a0: 76 65 63 20 32 35 20 76 61 6c 29 29 0a 28 64 65 vec 25 val)).(de
16b0: 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 73 fine (sdat-set-s
16c0: 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 21 20 20 ession-cookie!
16d0: 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 vec val)(vec
16e0: 74 6f 72 2d 73 65 74 21 20 76 65 63 20 32 36 20 tor-set! vec 26
16f0: 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 val)).(define (s
1700: 64 61 74 2d 73 65 74 2d 63 75 72 72 2d 65 72 72 dat-set-curr-err
1710: 21 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 ! vec
1720: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
1730: 21 20 76 65 63 20 32 37 20 76 61 6c 29 29 0a 28 ! vec 27 val)).(
1740: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 define (sdat-set
1750: 2d 6c 6f 67 2d 70 6f 72 74 21 20 20 20 20 20 20 -log-port!
1760: 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 vec val)(v
1770: 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 32 ector-set! vec 2
1780: 38 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 8 val)).(define
1790: 28 73 64 61 74 2d 73 65 74 2d 6c 6f 67 66 69 6c (sdat-set-logfil
17a0: 65 21 20 20 20 20 20 20 20 20 20 20 20 20 20 76 e! v
17b0: 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 ec val)(vector-s
17c0: 65 74 21 20 76 65 63 20 32 39 20 76 61 6c 29 29 et! vec 29 val))
17d0: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 .(define (sdat-s
17e0: 65 74 2d 73 65 65 6e 2d 70 61 67 65 73 21 20 20 et-seen-pages!
17f0: 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 vec val)
1800: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 (vector-set! vec
1810: 20 33 30 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 30 val)).(defin
1820: 65 20 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 e (sdat-set-page
1830: 2d 64 69 72 2d 73 74 79 6c 65 21 20 20 20 20 20 -dir-style!
1840: 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 vec val)(vector
1850: 2d 73 65 74 21 20 76 65 63 20 33 31 20 76 61 6c -set! vec 31 val
1860: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
1870: 2d 73 65 74 2d 64 65 62 75 67 6d 6f 64 65 21 20 -set-debugmode!
1880: 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 61 vec va
1890: 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 l)(vector-set! v
18a0: 65 63 20 33 32 20 76 61 6c 29 29 0a 28 64 65 66 ec 32 val)).(def
18b0: 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 73 68 ine (sdat-set-sh
18c0: 61 72 65 64 2d 68 61 73 68 21 20 20 20 20 20 20 ared-hash!
18d0: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
18e0: 6f 72 2d 73 65 74 21 20 76 65 63 20 33 33 20 76 or-set! vec 33 v
18f0: 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 al)).(define (sd
1900: 61 74 2d 73 65 74 2d 73 63 72 69 70 74 21 20 20 at-set-script!
1910: 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 20 vec
1920: 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 val)(vector-set!
1930: 20 76 65 63 20 33 34 20 76 61 6c 29 29 0a 28 64 vec 34 val)).(d
1940: 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d efine (sdat-set-
1950: 66 6f 72 63 65 2d 73 73 6c 21 20 20 20 20 20 20 force-ssl!
1960: 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 vec val)(ve
1970: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 33 35 ctor-set! vec 35
1980: 20 76 61 6c 29 29 0a 0a 28 64 65 66 69 6e 65 20 val))..(define
1990: 28 73 65 73 73 69 6f 6e 3a 73 65 74 2d 73 68 61 (session:set-sha
19a0: 72 65 64 21 20 76 65 63 20 76 61 72 6e 61 6d 65 red! vec varname
19b0: 20 76 61 6c 29 0a 20 20 28 68 61 73 68 2d 74 61 val). (hash-ta
19c0: 62 6c 65 2d 73 65 74 21 20 28 76 65 63 74 6f 72 ble-set! (vector
19d0: 2d 72 65 66 20 76 65 63 20 33 33 29 20 76 61 72 -ref vec 33) var
19e0: 6e 61 6d 65 20 76 61 6c 29 29 0a 0a 3b 3b 20 54 name val))..;; T
19f0: 68 65 20 67 6c 6f 62 61 6c 20 73 65 73 73 69 6f he global sessio
1a00: 6e 0a 28 64 65 66 69 6e 65 20 73 3a 73 65 73 73 n.(define s:sess
1a10: 69 6f 6e 20 28 6d 61 6b 65 2d 73 64 61 74 29 29 ion (make-sdat))
1a20: 0a 0a 3b 3b 20 53 50 4c 49 54 20 49 4e 54 4f 20 ..;; SPLIT INTO
1a30: 53 54 52 41 49 47 48 54 20 46 4f 52 57 41 52 44 STRAIGHT FORWARD
1a40: 20 49 4e 49 54 20 41 4e 44 20 43 4f 4d 50 4c 45 INIT AND COMPLE
1a50: 58 20 49 4e 49 54 0a 28 64 65 66 69 6e 65 20 28 X INIT.(define (
1a60: 73 65 73 73 69 6f 6e 3a 69 6e 69 74 69 61 6c 69 session:initiali
1a70: 7a 65 20 73 65 6c 66 29 0a 20 20 28 73 64 61 74 ze self). (sdat
1a80: 2d 73 65 74 2d 64 62 74 79 70 65 21 20 73 65 6c -set-dbtype! sel
1a90: 66 20 20 20 20 20 20 27 70 67 29 0a 20 20 28 73 f 'pg). (s
1aa0: 64 61 74 2d 73 65 74 2d 70 61 67 65 21 20 73 65 dat-set-page! se
1ab0: 6c 66 20 20 20 20 20 20 20 20 22 68 6f 6d 65 22 lf "home"
1ac0: 29 20 20 20 20 20 20 20 20 3b 3b 20 74 68 65 73 ) ;; thes
1ad0: 65 20 61 72 65 20 64 65 66 61 75 6c 74 73 0a 20 e are defaults.
1ae0: 20 28 73 64 61 74 2d 73 65 74 2d 63 75 72 72 2d (sdat-set-curr-
1af0: 70 61 67 65 21 20 73 65 6c 66 20 20 20 22 68 6f page! self "ho
1b00: 6d 65 22 29 0a 20 20 28 73 64 61 74 2d 73 65 74 me"). (sdat-set
1b10: 2d 63 6f 6e 74 65 6e 74 2d 74 79 70 65 21 20 73 -content-type! s
1b20: 65 6c 66 20 22 43 6f 6e 74 65 6e 74 2d 74 79 70 elf "Content-typ
1b30: 65 3a 20 74 65 78 74 2f 68 74 6d 6c 3b 20 63 68 e: text/html; ch
1b40: 61 72 73 65 74 3d 69 73 6f 2d 38 38 35 39 2d 31 arset=iso-8859-1
1b50: 5c 6e 5c 6e 22 29 0a 20 20 28 73 64 61 74 2d 73 \n\n"). (sdat-s
1b60: 65 74 2d 70 61 67 65 2d 74 79 70 65 21 20 73 65 et-page-type! se
1b70: 6c 66 20 20 20 27 68 74 6d 6c 29 0a 20 20 28 73 lf 'html). (s
1b80: 64 61 74 2d 73 65 74 2d 74 6f 70 70 61 67 65 21 dat-set-toppage!
1b90: 20 73 65 6c 66 20 20 20 20 20 22 69 6e 64 65 78 self "index
1ba0: 22 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 70 "). (sdat-set-p
1bb0: 61 72 61 6d 73 21 20 73 65 6c 66 20 20 20 20 20 arams! self
1bc0: 20 27 28 29 29 20 20 20 20 20 20 20 20 20 20 20 '())
1bd0: 3b 3b 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 70 ;;. (sdat-set-p
1be0: 61 74 68 2d 70 61 72 61 6d 73 21 20 73 65 6c 66 ath-params! self
1bf0: 20 27 28 29 29 0a 20 20 28 73 64 61 74 2d 73 65 '()). (sdat-se
1c00: 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 21 20 73 t-session-key! s
1c10: 65 6c 66 20 23 66 29 0a 20 20 28 73 64 61 74 2d elf #f). (sdat-
1c20: 73 65 74 2d 70 61 67 65 64 61 74 21 20 73 65 6c set-pagedat! sel
1c30: 66 20 20 20 20 20 27 28 29 29 0a 20 20 28 73 64 f '()). (sd
1c40: 61 74 2d 73 65 74 2d 61 6c 74 2d 70 61 67 65 2d at-set-alt-page-
1c50: 64 61 74 21 20 73 65 6c 66 20 23 66 29 0a 20 20 dat! self #f).
1c60: 28 73 64 61 74 2d 73 65 74 2d 73 72 6f 6f 74 21 (sdat-set-sroot!
1c70: 20 73 65 6c 66 20 20 20 20 20 20 20 22 2e 2f 22 self "./"
1c80: 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 ). (sdat-set-se
1c90: 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 21 20 73 65 ssion-cookie! se
1ca0: 6c 66 20 23 66 29 0a 20 20 28 73 64 61 74 2d 73 lf #f). (sdat-s
1cb0: 65 74 2d 63 75 72 72 2d 65 72 72 21 20 73 65 6c et-curr-err! sel
1cc0: 66 20 23 66 29 0a 20 20 28 73 64 61 74 2d 73 65 f #f). (sdat-se
1cd0: 74 2d 6c 6f 67 2d 70 6f 72 74 21 20 73 65 6c 66 t-log-port! self
1ce0: 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d (current-error-
1cf0: 70 6f 72 74 29 29 0a 20 20 28 73 64 61 74 2d 73 port)). (sdat-s
1d00: 65 74 2d 73 65 65 6e 2d 70 61 67 65 73 21 20 73 et-seen-pages! s
1d10: 65 6c 66 20 27 28 29 29 0a 20 20 28 73 64 61 74 elf '()). (sdat
1d20: 2d 73 65 74 2d 70 61 67 65 2d 64 69 72 2d 73 74 -set-page-dir-st
1d30: 79 6c 65 21 20 73 65 6c 66 20 23 74 29 20 3b 3b yle! self #t) ;;
1d40: 20 23 74 20 3a 20 70 61 67 65 73 2f 3c 70 61 67 #t : pages/<pag
1d50: 65 6e 61 6d 65 3e 5f 28 76 69 65 77 7c 63 6e 74 ename>_(view|cnt
1d60: 6c 29 2e 73 63 6d 0a 20 20 20 20 20 20 20 20 20 l).scm.
1d70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1d80: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
1d90: 23 66 20 3a 20 70 61 67 65 73 2f 3c 70 61 67 65 #f : pages/<page
1da0: 6e 61 6d 65 3e 2f 28 76 69 65 77 7c 63 6f 6e 74 name>/(view|cont
1db0: 72 6f 6c 29 2e 73 63 6d 20 0a 20 20 28 73 64 61 rol).scm . (sda
1dc0: 74 2d 73 65 74 2d 64 65 62 75 67 6d 6f 64 65 21 t-set-debugmode!
1dd0: 20 20 20 20 20 20 20 20 20 20 73 65 6c 66 20 23 self #
1de0: 66 29 0a 20 20 09 09 09 20 20 20 20 20 0a 20 20 f). ... .
1df0: 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 76 61 (sdat-set-pageva
1e00: 72 73 21 20 20 20 20 20 20 20 20 20 20 20 73 65 rs! se
1e10: 6c 66 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 lf (make-hash-ta
1e20: 62 6c 65 29 29 0a 20 20 28 73 64 61 74 2d 73 65 ble)). (sdat-se
1e30: 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 21 20 20 t-sessionvars!
1e40: 20 20 20 20 20 20 73 65 6c 66 20 28 6d 61 6b 65 self (make
1e50: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 -hash-table)).
1e60: 28 73 64 61 74 2d 73 65 74 2d 67 6c 6f 62 61 6c (sdat-set-global
1e70: 76 61 72 73 21 20 20 20 20 20 20 20 20 20 73 65 vars! se
1e80: 6c 66 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 lf (make-hash-ta
1e90: 62 6c 65 29 29 0a 20 20 28 73 64 61 74 2d 73 65 ble)). (sdat-se
1ea0: 74 2d 70 61 67 65 76 61 72 73 2d 62 65 66 6f 72 t-pagevars-befor
1eb0: 65 21 20 20 20 20 73 65 6c 66 20 28 6d 61 6b 65 e! self (make
1ec0: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 -hash-table)).
1ed0: 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f (sdat-set-sessio
1ee0: 6e 76 61 72 73 2d 62 65 66 6f 72 65 21 20 73 65 nvars-before! se
1ef0: 6c 66 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 lf (make-hash-ta
1f00: 62 6c 65 29 29 0a 20 20 28 73 64 61 74 2d 73 65 ble)). (sdat-se
1f10: 74 2d 67 6c 6f 62 61 6c 76 61 72 73 2d 62 65 66 t-globalvars-bef
1f20: 6f 72 65 21 20 20 73 65 6c 66 20 28 6d 61 6b 65 ore! self (make
1f30: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 -hash-table)).
1f40: 28 73 64 61 74 2d 73 65 74 2d 64 6f 6d 61 69 6e (sdat-set-domain
1f50: 21 20 20 20 20 20 20 20 20 20 20 20 20 20 73 65 ! se
1f60: 6c 66 20 22 6c 6f 63 61 68 6f 73 74 22 29 20 20 lf "locahost")
1f70: 20 3b 3b 20 65 6e 64 20 6f 66 20 64 65 66 61 75 ;; end of defau
1f80: 6c 74 73 0a 20 20 28 73 64 61 74 2d 73 65 74 2d lts. (sdat-set-
1f90: 73 63 72 69 70 74 21 20 20 20 20 20 20 20 20 20 script!
1fa0: 20 20 20 20 73 65 6c 66 20 23 66 29 0a 20 20 28 self #f). (
1fb0: 6c 65 74 2a 20 28 28 72 61 77 63 6f 6e 66 69 67 let* ((rawconfig
1fc0: 64 61 74 20 28 73 65 73 73 69 6f 6e 3a 72 65 61 dat (session:rea
1fd0: 64 2d 63 6f 6e 66 69 67 20 73 65 6c 66 29 29 0a d-config self)).
1fe0: 09 20 28 63 6f 6e 66 69 67 64 61 74 20 28 69 66 . (configdat (if
1ff0: 20 72 61 77 63 6f 6e 66 69 67 64 61 74 20 28 65 rawconfigdat (e
2000: 76 61 6c 20 72 61 77 63 6f 6e 66 69 67 64 61 74 val rawconfigdat
2010: 29 20 27 28 29 29 29 0a 09 20 28 73 72 6f 6f 74 ) '())).. (sroot
2020: 20 20 20 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 (s:find-par
2030: 61 6d 20 27 73 72 6f 6f 74 20 20 20 20 63 6f 6e am 'sroot con
2040: 66 69 67 64 61 74 29 29 0a 09 20 28 6c 6f 67 66 figdat)).. (logf
2050: 69 6c 65 20 20 20 28 73 3a 66 69 6e 64 2d 70 61 ile (s:find-pa
2060: 72 61 6d 20 27 6c 6f 67 66 69 6c 65 20 20 63 6f ram 'logfile co
2070: 6e 66 69 67 64 61 74 29 29 0a 09 20 28 64 62 74 nfigdat)).. (dbt
2080: 79 70 65 20 20 20 20 28 73 3a 66 69 6e 64 2d 70 ype (s:find-p
2090: 61 72 61 6d 20 27 64 62 74 79 70 65 20 20 20 63 aram 'dbtype c
20a0: 6f 6e 66 69 67 64 61 74 29 29 0a 09 20 28 64 62 onfigdat)).. (db
20b0: 69 6e 69 74 20 20 20 20 28 73 3a 66 69 6e 64 2d init (s:find-
20c0: 70 61 72 61 6d 20 27 64 62 69 6e 69 74 20 20 20 param 'dbinit
20d0: 63 6f 6e 66 69 67 64 61 74 29 29 0a 09 20 28 64 configdat)).. (d
20e0: 6f 6d 61 69 6e 20 20 20 20 28 73 3a 66 69 6e 64 omain (s:find
20f0: 2d 70 61 72 61 6d 20 27 64 6f 6d 61 69 6e 20 20 -param 'domain
2100: 20 63 6f 6e 66 69 67 64 61 74 29 29 0a 09 20 28 configdat)).. (
2110: 74 77 69 6b 69 64 69 72 20 20 28 73 3a 66 69 6e twikidir (s:fin
2120: 64 2d 70 61 72 61 6d 20 27 74 77 69 6b 69 64 69 d-param 'twikidi
2130: 72 20 63 6f 6e 66 69 67 64 61 74 29 29 0a 09 20 r configdat))..
2140: 28 70 61 67 65 2d 64 69 72 20 20 28 73 3a 66 69 (page-dir (s:fi
2150: 6e 64 2d 70 61 72 61 6d 20 27 70 61 67 65 2d 64 nd-param 'page-d
2160: 69 72 2d 73 74 79 6c 65 20 63 6f 6e 66 69 67 64 ir-style configd
2170: 61 74 29 29 0a 09 20 28 64 65 62 75 67 6d 6f 64 at)).. (debugmod
2180: 65 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 e (s:find-param
2190: 27 64 65 62 75 67 6d 6f 64 65 20 63 6f 6e 66 69 'debugmode confi
21a0: 67 64 61 74 29 29 0a 20 20 20 20 20 20 20 20 20 gdat)).
21b0: 28 73 63 72 69 70 74 20 20 20 20 28 73 3a 66 69 (script (s:fi
21c0: 6e 64 2d 70 61 72 61 6d 20 27 73 63 72 69 70 74 nd-param 'script
21d0: 20 20 20 20 63 6f 6e 66 69 67 64 61 74 29 29 0a configdat)).
21e0: 09 20 28 66 6f 72 63 65 2d 73 73 6c 20 28 73 3a . (force-ssl (s:
21f0: 66 69 6e 64 2d 70 61 72 61 6d 20 27 66 6f 72 63 find-param 'forc
2200: 65 2d 73 73 6c 20 63 6f 6e 66 69 67 64 61 74 29 e-ssl configdat)
2210: 29 29 0a 20 20 20 20 28 69 66 20 73 72 6f 6f 74 )). (if sroot
2220: 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d 73 72 (sdat-set-sr
2230: 6f 6f 74 21 20 20 20 20 73 65 6c 66 20 73 72 6f oot! self sro
2240: 6f 74 29 29 0a 20 20 20 20 28 69 66 20 6c 6f 67 ot)). (if log
2250: 66 69 6c 65 20 20 28 73 64 61 74 2d 73 65 74 2d file (sdat-set-
2260: 6c 6f 67 66 69 6c 65 21 20 20 73 65 6c 66 20 6c logfile! self l
2270: 6f 67 66 69 6c 65 29 29 0a 20 20 20 20 28 69 66 ogfile)). (if
2280: 20 64 62 74 79 70 65 20 20 20 28 73 64 61 74 2d dbtype (sdat-
2290: 73 65 74 2d 64 62 74 79 70 65 21 20 20 20 73 65 set-dbtype! se
22a0: 6c 66 20 64 62 74 79 70 65 29 29 0a 20 20 20 20 lf dbtype)).
22b0: 28 69 66 20 64 62 69 6e 69 74 20 20 20 28 73 64 (if dbinit (sd
22c0: 61 74 2d 73 65 74 2d 64 62 69 6e 69 74 21 20 20 at-set-dbinit!
22d0: 20 73 65 6c 66 20 64 62 69 6e 69 74 29 29 0a 20 self dbinit)).
22e0: 20 20 20 28 69 66 20 64 6f 6d 61 69 6e 20 20 20 (if domain
22f0: 28 73 64 61 74 2d 73 65 74 2d 64 6f 6d 61 69 6e (sdat-set-domain
2300: 21 20 20 20 73 65 6c 66 20 64 6f 6d 61 69 6e 29 ! self domain)
2310: 29 0a 20 20 20 20 28 69 66 20 74 77 69 6b 69 64 ). (if twikid
2320: 69 72 20 28 73 64 61 74 2d 73 65 74 2d 74 77 69 ir (sdat-set-twi
2330: 6b 69 64 69 72 21 20 73 65 6c 66 20 74 77 69 6b kidir! self twik
2340: 69 64 69 72 29 29 0a 20 20 20 20 28 69 66 20 64 idir)). (if d
2350: 65 62 75 67 6d 6f 64 65 20 28 73 64 61 74 2d 73 ebugmode (sdat-s
2360: 65 74 2d 64 65 62 75 67 6d 6f 64 65 21 20 73 65 et-debugmode! se
2370: 6c 66 20 64 65 62 75 67 6d 6f 64 65 29 29 0a 20 lf debugmode)).
2380: 20 20 20 28 69 66 20 73 63 72 69 70 74 20 20 20 (if script
2390: 20 28 73 64 61 74 2d 73 65 74 2d 73 63 72 69 70 (sdat-set-scrip
23a0: 74 21 20 20 20 20 73 65 6c 66 20 73 63 72 69 70 t! self scrip
23b0: 74 29 29 0a 20 20 20 20 28 69 66 20 66 6f 72 63 t)). (if forc
23c0: 65 2d 73 73 6c 20 28 73 64 61 74 2d 73 65 74 2d e-ssl (sdat-set-
23d0: 66 6f 72 63 65 2d 73 73 6c 21 20 73 65 6c 66 20 force-ssl! self
23e0: 66 6f 72 63 65 2d 73 73 6c 29 29 0a 20 20 20 20 force-ssl)).
23f0: 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 2d 64 (sdat-set-page-d
2400: 69 72 2d 73 74 79 6c 65 21 20 73 65 6c 66 20 70 ir-style! self p
2410: 61 67 65 2d 64 69 72 29 0a 20 20 20 20 3b 3b 20 age-dir). ;;
2420: 28 70 72 69 6e 74 20 22 63 6f 6e 66 69 67 64 61 (print "configda
2430: 74 3a 20 22 29 28 70 70 20 63 6f 6e 66 69 67 64 t: ")(pp configd
2440: 61 74 29 0a 20 20 20 20 28 69 66 20 64 65 62 75 at). (if debu
2450: 67 6d 6f 64 65 0a 09 28 73 65 73 73 69 6f 6e 3a gmode..(session:
2460: 6c 6f 67 20 73 65 6c 66 20 22 73 72 6f 6f 74 3a log self "sroot:
2470: 20 22 20 73 72 6f 6f 74 20 22 20 6c 6f 67 66 69 " sroot " logfi
2480: 6c 65 3a 20 22 20 6c 6f 67 66 69 6c 65 20 22 20 le: " logfile "
2490: 64 62 74 79 70 65 3a 20 22 20 64 62 74 79 70 65 dbtype: " dbtype
24a0: 20 0a 09 09 20 20 20 20 20 22 20 64 62 69 6e 69 ... " dbini
24b0: 74 3a 20 22 20 64 62 69 6e 69 74 20 22 20 64 6f t: " dbinit " do
24c0: 6d 61 69 6e 3a 20 22 20 64 6f 6d 61 69 6e 20 22 main: " domain "
24d0: 20 70 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 3a page-dir-style:
24e0: 20 22 20 70 61 67 65 2d 64 69 72 29 29 0a 20 20 " page-dir)).
24f0: 20 20 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d ). (sdat-set-
2500: 73 68 61 72 65 64 2d 68 61 73 68 21 20 73 65 6c shared-hash! sel
2510: 66 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 f (make-hash-tab
2520: 6c 65 29 29 0a 20 20 29 0a 0a 3b 3b 20 55 73 65 le)). )..;; Use
2530: 64 20 66 6f 72 20 74 68 65 20 73 74 72 61 6e 67 d for the strang
2540: 65 6c 79 20 69 6e 63 6f 6e 73 69 73 74 65 6e 74 ely inconsistent
2550: 20 68 61 6e 64 6c 69 6e 67 20 6f 66 20 74 68 65 handling of the
2560: 20 63 6f 6e 66 69 67 20 66 69 6c 65 2e 20 41 20 config file. A
2570: 62 65 74 74 65 72 20 77 61 79 20 69 73 20 6e 65 better way is ne
2580: 65 64 65 64 2e 0a 3b 3b 0a 3b 3b 20 20 20 28 6c eded..;;.;; (l
2590: 65 74 20 28 28 64 62 74 79 70 65 20 28 73 64 61 et ((dbtype (sda
25a0: 74 2d 67 65 74 2d 64 62 74 79 70 65 20 73 65 6c t-get-dbtype sel
25b0: 66 29 29 29 0a 3b 3b 20 20 20 20 20 28 70 72 69 f))).;; (pri
25c0: 6e 74 20 22 64 62 74 79 70 65 3a 20 22 20 64 62 nt "dbtype: " db
25d0: 74 79 70 65 29 0a 3b 3b 20 20 20 20 20 28 73 64 type).;; (sd
25e0: 61 74 2d 73 65 74 2d 64 62 74 79 70 65 21 20 73 at-set-dbtype! s
25f0: 65 6c 66 20 28 65 76 61 6c 20 64 62 74 79 70 65 elf (eval dbtype
2600: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 ))))..(define (s
2610: 65 73 73 69 6f 6e 3a 73 65 74 75 70 20 73 65 6c ession:setup sel
2620: 66 29 0a 20 20 28 6c 65 74 20 28 28 64 62 74 79 f). (let ((dbty
2630: 70 65 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d pe (sdat-get-
2640: 64 62 74 79 70 65 20 73 65 6c 66 29 29 0a 09 28 dbtype self))..(
2650: 64 65 62 75 67 6d 6f 64 65 20 28 73 64 61 74 2d debugmode (sdat-
2660: 67 65 74 2d 64 65 62 75 67 6d 6f 64 65 20 73 65 get-debugmode se
2670: 6c 66 29 29 0a 09 28 64 62 69 6e 69 74 20 20 20 lf))..(dbinit
2680: 20 28 65 76 61 6c 20 28 73 64 61 74 2d 67 65 74 (eval (sdat-get
2690: 2d 64 62 69 6e 69 74 20 73 65 6c 66 29 29 29 0a -dbinit self))).
26a0: 09 28 64 62 65 78 69 73 74 73 20 20 23 66 29 29 .(dbexists #f))
26b0: 0a 20 20 20 20 28 6c 65 74 20 28 28 64 62 66 6e . (let ((dbfn
26c0: 61 6d 65 20 28 61 6c 69 73 74 2d 72 65 66 20 27 ame (alist-ref '
26d0: 64 62 6e 61 6d 65 20 64 62 69 6e 69 74 29 29 29 dbname dbinit)))
26e0: 0a 20 20 20 20 20 20 28 69 66 20 64 65 62 75 67 . (if debug
26f0: 6d 6f 64 65 20 28 73 65 73 73 69 6f 6e 3a 6c 6f mode (session:lo
2700: 67 20 73 65 6c 66 20 22 73 65 73 73 69 6f 6e 3a g self "session:
2710: 73 65 74 75 70 20 64 62 66 6e 61 6d 65 3d 22 20 setup dbfname="
2720: 64 62 66 6e 61 6d 65 20 22 2c 20 64 62 74 79 70 dbfname ", dbtyp
2730: 65 3d 22 20 64 62 74 79 70 65 20 22 2c 20 64 62 e=" dbtype ", db
2740: 69 6e 69 74 3d 22 20 64 62 69 6e 69 74 29 29 0a init=" dbinit)).
2750: 20 20 20 20 20 20 28 69 66 20 28 65 71 3f 20 64 (if (eq? d
2760: 62 74 79 70 65 20 27 73 71 6c 69 74 65 33 29 0a btype 'sqlite3).
2770: 09 20 20 3b 3b 20 54 68 65 20 27 61 75 74 6f 20 . ;; The 'auto
2780: 6d 65 74 68 6f 64 20 77 69 6c 6c 20 64 69 73 74 method will dist
2790: 72 69 62 75 74 65 20 64 62 73 20 61 63 72 6f 73 ribute dbs acros
27a0: 73 20 74 68 65 20 64 69 73 6b 20 75 73 69 6e 67 s the disk using
27b0: 20 68 61 73 68 0a 09 20 20 3b 3b 20 6f 66 20 75 hash.. ;; of u
27c0: 73 65 72 20 68 6f 73 74 20 61 6e 64 20 75 73 65 ser host and use
27d0: 72 2e 20 54 4f 44 4f 0a 09 20 20 3b 3b 20 28 69 r. TODO.. ;; (i
27e0: 66 20 28 65 71 3f 20 64 62 66 6e 61 6d 65 20 27 f (eq? dbfname '
27f0: 61 75 74 6f 29 20 3b 3b 20 54 68 69 73 20 69 73 auto) ;; This is
2800: 20 74 68 65 20 61 75 74 6f 20 61 73 73 69 67 6e the auto assign
2810: 6d 65 6e 74 20 6f 66 20 61 20 64 62 20 62 61 73 ment of a db bas
2820: 65 64 20 6f 6e 20 68 61 73 68 20 6f 66 20 49 50 ed on hash of IP
2830: 0a 09 20 20 28 6c 65 74 20 28 28 64 62 70 61 74 .. (let ((dbpat
2840: 68 20 28 70 61 74 68 6e 61 6d 65 2d 64 69 72 65 h (pathname-dire
2850: 63 74 6f 72 79 20 64 62 66 6e 61 6d 65 29 29 29 ctory dbfname)))
2860: 20 20 3b 3b 20 64 6f 20 61 20 63 6f 75 70 6c 65 ;; do a couple
2870: 20 73 61 6e 69 74 79 20 63 68 65 63 6b 73 20 68 sanity checks h
2880: 65 72 65 20 74 6f 20 6d 61 6b 65 20 73 65 74 74 ere to make sett
2890: 69 6e 67 20 75 70 20 65 61 73 69 65 72 0a 09 20 ing up easier..
28a0: 20 20 20 28 69 66 20 64 65 62 75 67 6d 6f 64 65 (if debugmode
28b0: 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 (session:log se
28c0: 6c 66 20 22 49 4e 46 4f 3a 20 73 65 74 74 69 6e lf "INFO: settin
28d0: 67 20 75 70 20 66 6f 72 20 73 71 6c 69 74 65 33 g up for sqlite3
28e0: 20 64 62 20 61 63 63 65 73 73 20 74 6f 20 22 20 db access to "
28f0: 64 62 66 6e 61 6d 65 29 29 0a 09 20 20 20 20 28 dbfname)).. (
2900: 69 66 20 28 6e 6f 74 20 28 66 69 6c 65 2d 77 72 if (not (file-wr
2910: 69 74 65 2d 61 63 63 65 73 73 3f 20 64 62 70 61 ite-access? dbpa
2920: 74 68 29 29 0a 09 09 28 73 65 73 73 69 6f 6e 3a th))...(session:
2930: 6c 6f 67 20 73 65 6c 66 20 22 57 41 52 4e 49 4e log self "WARNIN
2940: 47 3a 20 43 61 6e 6e 6f 74 20 77 72 69 74 65 20 G: Cannot write
2950: 74 6f 20 22 20 64 62 70 61 74 68 29 0a 09 09 28 to " dbpath)...(
2960: 69 66 20 64 65 62 75 67 6d 6f 64 65 20 28 73 65 if debugmode (se
2970: 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 ssion:log self "
2980: 49 4e 46 4f 3a 20 22 20 64 62 70 61 74 68 20 22 INFO: " dbpath "
2990: 20 69 73 20 77 72 69 74 65 61 62 6c 65 22 29 29 is writeable"))
29a0: 29 0a 09 20 20 20 20 28 69 66 20 28 66 69 6c 65 ).. (if (file
29b0: 2d 65 78 69 73 74 73 3f 20 64 62 66 6e 61 6d 65 -exists? dbfname
29c0: 29 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 20 3b )...(begin... ;
29d0: 3b 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 ; (session:log s
29e0: 65 6c 66 20 22 73 65 74 74 69 6e 67 20 64 62 65 elf "setting dbe
29f0: 78 69 73 74 73 20 74 6f 20 23 74 22 29 0a 09 09 xists to #t")...
2a00: 20 20 28 73 65 74 21 20 64 62 65 78 69 73 74 73 (set! dbexists
2a10: 20 23 74 29 29 29 29 0a 09 20 20 28 69 66 20 64 #t)))).. (if d
2a20: 65 62 75 67 6d 6f 64 65 20 28 73 65 73 73 69 6f ebugmode (sessio
2a30: 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 49 4e 46 4f n:log self "INFO
2a40: 3a 20 73 65 74 74 69 6e 67 20 75 70 20 66 6f 72 : setting up for
2a50: 20 70 67 20 64 62 20 61 63 63 65 73 73 20 74 6f pg db access to
2a60: 20 61 63 63 6f 75 6e 74 20 69 6e 66 6f 20 22 20 account info "
2a70: 64 62 69 6e 69 74 29 29 29 0a 20 20 20 20 20 20 dbinit))).
2a80: 28 69 66 20 64 65 62 75 67 6d 6f 64 65 20 28 73 (if debugmode (s
2a90: 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 ession:log self
2aa0: 22 64 62 74 79 70 65 3a 20 22 20 64 62 74 79 70 "dbtype: " dbtyp
2ab0: 65 20 22 20 64 62 66 6e 61 6d 65 3a 20 22 20 64 e " dbfname: " d
2ac0: 62 66 6e 61 6d 65 20 22 20 64 62 65 78 69 73 74 bfname " dbexist
2ad0: 73 3a 20 22 20 64 62 65 78 69 73 74 73 29 29 29 s: " dbexists)))
2ae0: 0a 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d 63 . (sdat-set-c
2af0: 6f 6e 6e 21 20 73 65 6c 66 20 28 64 62 69 3a 6f onn! self (dbi:o
2b00: 70 65 6e 20 64 62 74 79 70 65 20 64 62 69 6e 69 pen dbtype dbini
2b10: 74 29 29 0a 20 20 20 20 28 73 65 74 21 20 2a 64 t)). (set! *d
2b20: 62 2a 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e b* (sdat-get-con
2b30: 6e 20 73 65 6c 66 29 29 0a 20 20 20 20 28 69 66 n self)). (if
2b40: 20 28 61 6e 64 20 28 6e 6f 74 20 64 62 65 78 69 (and (not dbexi
2b50: 73 74 73 29 28 65 71 3f 20 64 62 74 79 70 65 20 sts)(eq? dbtype
2b60: 27 73 71 6c 69 74 65 33 29 29 0a 20 09 28 62 65 'sqlite3)). .(be
2b70: 67 69 6e 0a 09 20 20 28 70 72 69 6e 74 20 22 57 gin.. (print "W
2b80: 41 52 4e 49 4e 47 3a 20 53 65 74 74 69 6e 67 20 ARNING: Setting
2b90: 75 70 20 73 65 73 73 69 6f 6e 20 64 62 20 77 69 up session db wi
2ba0: 74 68 20 73 71 6c 69 74 65 33 22 29 0a 09 20 20 th sqlite3")..
2bb0: 28 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 2d 64 (session:setup-d
2bc0: 62 20 73 65 6c 66 29 29 29 0a 20 20 20 20 28 73 b self))). (s
2bd0: 65 73 73 69 6f 6e 3a 70 72 6f 63 65 73 73 2d 75 ession:process-u
2be0: 72 6c 2d 70 61 74 68 20 73 65 6c 66 29 0a 20 20 rl-path self).
2bf0: 20 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 (session:setup
2c00: 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c -session-key sel
2c10: 66 29 0a 20 20 20 20 3b 3b 20 63 61 70 74 75 72 f). ;; captur
2c20: 65 20 73 74 64 69 6e 20 69 66 20 74 68 69 73 20 e stdin if this
2c30: 69 73 20 61 20 50 4f 53 54 0a 20 20 20 20 28 73 is a POST. (s
2c40: 64 61 74 2d 73 65 74 2d 72 65 71 75 65 73 74 2d dat-set-request-
2c50: 6d 65 74 68 6f 64 21 20 73 65 6c 66 20 28 67 65 method! self (ge
2c60: 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 t-environment-va
2c70: 72 69 61 62 6c 65 20 22 52 45 51 55 45 53 54 5f riable "REQUEST_
2c80: 4d 45 54 48 4f 44 22 29 29 0a 20 20 20 20 28 73 METHOD")). (s
2c90: 64 61 74 2d 73 65 74 2d 66 6f 72 6d 64 61 74 21 dat-set-formdat!
2ca0: 20 73 65 6c 66 20 28 66 6f 72 6d 64 61 74 3a 6c self (formdat:l
2cb0: 6f 61 64 2d 61 6c 6c 29 29 29 29 0a 0a 3b 3b 20 oad-all))))..;;
2cc0: 73 65 74 75 70 20 74 68 65 20 64 62 20 77 69 74 setup the db wit
2cd0: 68 20 73 65 73 73 69 6f 6e 20 74 61 62 6c 65 73 h session tables
2ce0: 2c 20 77 6f 72 6b 73 20 66 6f 72 20 73 71 6c 69 , works for sqli
2cf0: 74 65 20 6f 6e 6c 79 20 72 69 67 68 74 20 6e 6f te only right no
2d00: 77 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 w.(define (sessi
2d10: 6f 6e 3a 73 65 74 75 70 2d 64 62 20 73 65 6c 66 on:setup-db self
2d20: 29 0a 20 20 28 6c 65 74 20 28 28 63 6f 6e 6e 20 ). (let ((conn
2d30: 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 (sdat-get-conn s
2d40: 65 6c 66 29 29 29 0a 20 20 20 20 28 66 6f 72 2d elf))). (for-
2d50: 65 61 63 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 each . (lamb
2d60: 64 61 20 28 73 74 6d 74 29 0a 20 20 20 20 20 20 da (stmt).
2d70: 20 28 64 62 69 3a 65 78 65 63 20 63 6f 6e 6e 20 (dbi:exec conn
2d80: 73 74 6d 74 29 29 0a 20 20 20 20 20 28 6c 69 73 stmt)). (lis
2d90: 74 20 22 43 52 45 41 54 45 20 54 41 42 4c 45 20 t "CREATE TABLE
2da0: 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 28 69 64 session_vars (id
2db0: 20 49 4e 54 45 47 45 52 20 50 52 49 4d 41 52 59 INTEGER PRIMARY
2dc0: 20 4b 45 59 2c 73 65 73 73 69 6f 6e 5f 69 64 20 KEY,session_id
2dd0: 49 4e 54 45 47 45 52 2c 70 61 67 65 20 54 45 58 INTEGER,page TEX
2de0: 54 2c 6b 65 79 20 54 45 58 54 2c 76 61 6c 75 65 T,key TEXT,value
2df0: 20 54 45 58 54 29 3b 22 0a 09 20 20 20 22 43 52 TEXT);".. "CR
2e00: 45 41 54 45 20 54 41 42 4c 45 20 73 65 73 73 69 EATE TABLE sessi
2e10: 6f 6e 73 20 28 69 64 20 49 4e 54 45 47 45 52 20 ons (id INTEGER
2e20: 50 52 49 4d 41 52 59 20 4b 45 59 2c 73 65 73 73 PRIMARY KEY,sess
2e30: 69 6f 6e 5f 6b 65 79 20 54 45 58 54 2c 6c 61 73 ion_key TEXT,las
2e40: 74 5f 75 73 65 64 20 54 49 4d 45 53 54 41 4d 50 t_used TIMESTAMP
2e50: 29 3b 22 0a 20 20 20 20 20 20 20 20 20 20 20 22 );". "
2e60: 43 52 45 41 54 45 20 54 41 42 4c 45 20 6d 65 74 CREATE TABLE met
2e70: 61 64 61 74 61 20 28 69 64 20 49 4e 54 45 47 45 adata (id INTEGE
2e80: 52 20 50 52 49 4d 41 52 59 20 4b 45 59 2c 6b 65 R PRIMARY KEY,ke
2e90: 79 20 54 45 58 54 2c 76 61 6c 75 65 20 54 45 58 y TEXT,value TEX
2ea0: 54 29 3b 22 29 29 29 29 0a 3b 3b 20 20 3b 3b 20 T);")))).;; ;;
2eb0: 69 66 20 77 65 20 68 61 76 65 20 61 20 73 65 73 if we have a ses
2ec0: 73 69 6f 6e 5f 6b 65 79 20 6c 6f 6f 6b 20 75 70 sion_key look up
2ed0: 20 74 68 65 20 73 65 73 73 69 6f 6e 2d 69 64 20 the session-id
2ee0: 61 6e 64 20 73 74 6f 72 65 20 69 74 0a 3b 3b 20 and store it.;;
2ef0: 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 (sdat-set-sessi
2f00: 6f 6e 2d 69 64 21 20 73 65 6c 66 20 28 73 65 73 on-id! self (ses
2f10: 73 69 6f 6e 3a 67 65 74 2d 69 64 20 73 65 6c 66 sion:get-id self
2f20: 29 29 29 0a 0a 3b 3b 20 6f 6e 6c 79 20 73 65 74 )))..;; only set
2f30: 20 73 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 20 session-cookie
2f40: 77 68 65 6e 20 61 20 6e 65 77 20 73 65 73 73 69 when a new sessi
2f50: 6f 6e 20 69 73 20 63 72 65 61 74 65 64 0a 28 64 on is created.(d
2f60: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 efine (session:s
2f70: 65 74 75 70 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 etup-session-key
2f80: 20 73 65 6c 66 29 20 20 0a 20 20 28 6c 65 74 2a self) . (let*
2f90: 20 28 28 73 6b 20 20 28 73 65 73 73 69 6f 6e 3a ((sk (session:
2fa0: 65 78 74 72 61 63 74 2d 73 65 73 73 69 6f 6e 2d extract-session-
2fb0: 6b 65 79 20 73 65 6c 66 29 29 0a 20 20 20 20 20 key self)).
2fc0: 20 20 20 20 28 73 69 64 20 28 69 66 20 73 6b 20 (sid (if sk
2fd0: 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 69 64 20 (session:get-id
2fe0: 73 65 6c 66 20 73 6b 29 20 23 66 29 29 29 0a 20 self sk) #f))).
2ff0: 20 20 20 28 69 66 20 28 6e 6f 74 20 73 69 64 29 (if (not sid)
3000: 20 3b 3b 20 6e 65 65 64 20 61 20 6e 65 77 20 6b ;; need a new k
3010: 65 79 0a 20 20 20 20 20 20 20 20 28 6c 65 74 2a ey. (let*
3020: 20 28 28 6e 65 77 2d 6b 65 79 20 28 73 65 73 73 ((new-key (sess
3030: 69 6f 6e 3a 67 65 74 2d 6e 65 77 2d 6b 65 79 20 ion:get-new-key
3040: 73 65 6c 66 29 29 0a 20 20 20 20 20 20 20 20 20 self)).
3050: 20 20 20 20 20 20 28 6e 65 77 2d 73 69 64 20 28 (new-sid (
3060: 73 65 73 73 69 6f 6e 3a 67 65 74 2d 69 64 20 73 session:get-id s
3070: 65 6c 66 20 6e 65 77 2d 6b 65 79 29 29 29 0a 20 elf new-key))).
3080: 20 20 20 20 20 20 20 20 20 28 73 64 61 74 2d 73 (sdat-s
3090: 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 21 20 et-session-key!
30a0: 73 65 6c 66 20 6e 65 77 2d 6b 65 79 29 0a 20 20 self new-key).
30b0: 20 20 20 20 20 20 20 20 28 73 64 61 74 2d 73 65 (sdat-se
30c0: 74 2d 73 65 73 73 69 6f 6e 2d 69 64 21 20 73 65 t-session-id! se
30d0: 6c 66 20 6e 65 77 2d 73 69 64 29 0a 20 20 20 20 lf new-sid).
30e0: 20 20 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d (sdat-set-
30f0: 73 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 21 20 session-cookie!
3100: 73 65 6c 66 20 28 73 65 73 73 69 6f 6e 3a 6d 61 self (session:ma
3110: 6b 65 2d 63 6f 6f 6b 69 65 20 73 65 6c 66 29 29 ke-cookie self))
3120: 29 0a 20 20 20 20 20 20 20 20 28 73 64 61 74 2d ). (sdat-
3130: 73 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 21 20 set-session-id!
3140: 73 65 6c 66 20 73 69 64 29 29 29 29 0a 0a 28 64 self sid))))..(d
3150: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 6d efine (session:m
3160: 61 6b 65 2d 63 6f 6f 6b 69 65 20 73 65 6c 66 29 ake-cookie self)
3170: 0a 20 20 3b 3b 20 28 6c 69 73 74 20 28 63 6f 6e . ;; (list (con
3180: 63 20 22 73 65 73 73 69 6f 6e 5f 6b 65 79 3d 22 c "session_key="
3190: 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 (sdat-get-sessi
31a0: 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 20 22 3b 20 on-key self) ";
31b0: 50 61 74 68 3d 2f 3b 20 44 6f 6d 61 69 6e 3d 2e Path=/; Domain=.
31c0: 22 20 28 73 64 61 74 2d 67 65 74 2d 64 6f 6d 61 " (sdat-get-doma
31d0: 69 6e 20 73 65 6c 66 29 20 22 3b 20 4d 61 78 2d in self) "; Max-
31e0: 41 67 65 3d 22 20 28 2a 20 38 36 34 30 30 20 31 Age=" (* 86400 1
31f0: 34 29 20 22 3b 20 56 65 72 73 69 6f 6e 3d 31 22 4) "; Version=1"
3200: 29 29 29 20 0a 20 20 3b 3b 20 41 63 63 6f 72 64 ))) . ;; Accord
3210: 69 6e 67 20 74 6f 20 0a 20 20 3b 3b 20 20 20 20 ing to . ;;
3220: 68 74 74 70 3a 2f 2f 77 77 77 2e 63 6f 64 65 6d http://www.codem
3230: 61 72 76 65 6c 73 2e 63 6f 6d 2f 32 30 31 30 2f arvels.com/2010/
3240: 31 31 2f 61 70 61 63 68 65 2d 72 65 77 72 69 74 11/apache-rewrit
3250: 65 72 75 6c 65 2d 73 65 74 2d 61 2d 63 6f 6f 6b erule-set-a-cook
3260: 69 65 2d 6f 6e 2d 6c 6f 63 61 6c 68 6f 73 74 2f ie-on-localhost/
3270: 0a 0a 20 20 3b 3b 20 20 48 65 72 65 20 61 72 65 .. ;; Here are
3280: 20 74 68 65 20 32 20 28 6f 66 74 65 6e 20 6c 65 the 2 (often le
3290: 66 74 20 6f 75 74 29 20 72 65 71 75 69 72 65 6d ft out) requirem
32a0: 65 6e 74 73 20 74 6f 20 73 65 74 20 61 20 63 6f ents to set a co
32b0: 6f 6b 69 65 20 75 73 69 6e 67 0a 20 20 3b 3b 20 okie using. ;;
32c0: 20 68 74 74 70 64 1b 2d 46 ef bf bd 73 20 72 65 httpd.-F�s re
32d0: 77 72 69 74 65 20 72 75 6c 65 20 28 6d 6f 64 5f write rule (mod_
32e0: 72 65 77 72 69 74 65 29 2c 20 77 68 69 6c 65 20 rewrite), while
32f0: 77 6f 72 6b 69 6e 67 20 6f 6e 20 6c 6f 63 61 6c working on local
3300: 68 6f 73 74 3a 1b 2d 41 0a 20 20 3b 3b 0a 20 20 host:.-A. ;;.
3310: 3b 3b 20 20 55 73 65 20 74 68 65 20 49 50 20 31 ;; Use the IP 1
3320: 32 37 2e 30 2e 30 2e 31 20 69 6e 73 74 65 61 64 27.0.0.1 instead
3330: 20 6f 66 20 6c 6f 63 61 6c 68 6f 73 74 2f 6d 61 of localhost/ma
3340: 63 68 69 6e 65 2d 6e 61 6d 65 20 61 73 20 74 68 chine-name as th
3350: 65 0a 20 20 3b 3b 20 20 64 6f 6d 61 69 6e 3b 20 e. ;; domain;
3360: 65 2e 67 2e 20 5b 43 4f 3d 73 6f 6d 65 43 6f 6f e.g. [CO=someCoo
3370: 6b 69 65 3a 73 6f 6d 65 56 61 6c 75 65 3a 31 32 kie:someValue:12
3380: 37 2e 30 2e 30 2e 31 3a 32 3a 2f 5d 2c 20 77 68 7.0.0.1:2:/], wh
3390: 69 63 68 20 73 61 79 73 0a 20 20 3b 3b 20 20 63 ich says. ;; c
33a0: 72 65 61 74 65 20 61 20 63 6f 6f 6b 69 65 20 1b reate a cookie .
33b0: 2d 59 ef bf bd 73 6f 6d 65 43 6f 6f 6b 69 65 ef -Y�someCookieï
33c0: bf bd 20 77 69 74 68 20 76 61 6c 75 65 20 ef bf ¿½ with value ï¿
33d0: bd 73 6f 6d 65 56 61 6c 75 65 ef bf bd 20 66 6f ½someValue� fo
33e0: 72 20 74 68 65 0a 20 20 3b 3b 20 20 64 6f 6d 61 r the. ;; doma
33f0: 69 6e 20 ef bf bd 31 32 37 2e 30 2e 30 2e 31 1b in �127.0.0.1.
3400: 24 42 21 6d 1b 28 42 20 68 61 76 69 6e 67 20 61 $B!m.(B having a
3410: 20 6c 69 66 65 20 74 69 6d 65 20 6f 66 20 32 20 life time of 2
3420: 6d 69 6e 73 2c 20 66 6f 72 20 61 6e 79 20 70 61 mins, for any pa
3430: 74 68 20 69 6e 0a 20 20 3b 3b 20 20 74 68 65 20 th in. ;; the
3440: 64 6f 6d 61 69 6e 20 28 70 61 74 68 3d 2f 29 2e domain (path=/).
3450: 20 28 4f 62 76 69 6f 75 73 6c 79 20 79 6f 75 20 (Obviously you
3460: 77 69 6c 6c 20 68 61 76 65 20 74 6f 20 72 75 6e will have to run
3470: 20 74 68 65 0a 20 20 3b 3b 20 20 61 70 70 6c 69 the. ;; appli
3480: 63 61 74 69 6f 6e 20 77 69 74 68 20 74 68 69 73 cation with this
3490: 20 76 61 6c 75 65 20 69 6e 20 74 68 65 20 55 52 value in the UR
34a0: 4c 29 0a 20 20 3b 3b 0a 20 20 3b 3b 20 20 54 6f L). ;;. ;; To
34b0: 20 6d 61 6b 65 20 61 20 73 65 73 73 69 6f 6e 20 make a session
34c0: 63 6f 6f 6b 69 65 2c 20 6c 69 6d 69 74 20 74 68 cookie, limit th
34d0: 65 20 66 6c 61 67 20 73 74 61 74 65 6d 65 6e 74 e flag statement
34e0: 20 74 6f 20 6a 75 73 74 20 74 68 72 65 65 0a 20 to just three.
34f0: 20 3b 3b 20 20 61 74 74 72 69 62 75 74 65 73 3a ;; attributes:
3500: 20 6e 61 6d 65 2c 20 76 61 6c 75 65 20 61 6e 64 name, value and
3510: 20 64 6f 6d 61 69 6e 2e 20 65 2e 67 0a 20 20 3b domain. e.g. ;
3520: 3b 20 20 5b 43 4f 3d 73 6f 6d 65 43 6f 6f 6b 69 ; [CO=someCooki
3530: 65 3a 73 6f 6d 65 56 61 6c 75 65 3a 31 32 37 2e e:someValue:127.
3540: 30 2e 30 2e 31 5d 20 1b 25 47 e2 80 93 1b 25 40 0.0.1] .%G–.%@
3550: 20 41 6e 79 20 66 75 72 74 68 65 72 0a 20 20 3b Any further. ;
3560: 3b 20 20 73 65 74 74 69 6e 67 73 2c 20 61 70 61 ; settings, apa
3570: 63 68 65 20 77 72 69 74 65 73 20 61 6e ef bf bd che writes an�
3580: 20 65 78 70 69 72 65 73 ef bf bd 20 61 74 74 72 expires� attr
3590: 69 62 75 74 65 20 66 6f 72 20 74 68 65 20 73 65 ibute for the se
35a0: 74 2d 63 6f 6f 6b 69 65 0a 20 20 3b 3b 20 20 68 t-cookie. ;; h
35b0: 65 61 64 65 72 2c 20 77 68 69 63 68 20 6d 61 6b eader, which mak
35c0: 65 73 20 74 68 65 20 63 6f 6f 6b 69 65 20 61 20 es the cookie a
35d0: 70 65 72 73 69 73 74 65 6e 74 20 6f 6e 65 20 28 persistent one (
35e0: 6e 6f 74 20 72 65 61 6c 6c 79 0a 20 20 3b 3b 20 not really. ;;
35f0: 20 70 65 72 73 69 73 74 65 6e 74 2c 20 61 73 20 persistent, as
3600: 74 68 65 20 65 78 70 69 72 65 73 20 76 61 6c 75 the expires valu
3610: 65 20 73 65 74 20 69 73 20 74 68 65 20 63 75 72 e set is the cur
3620: 72 65 6e 74 20 73 65 72 76 65 72 20 74 69 6d 65 rent server time
3630: 0a 20 20 3b 3b 20 20 1b 25 47 e2 80 93 1b 25 40 . ;; .%G–.%@
3640: 20 73 6f 20 79 6f 75 20 64 6f 6e 1b 2d 46 1b 2d so you don.-F.-
3650: 46 ef bf bd 74 20 65 76 65 6e 20 67 65 74 20 74 F�t even get t
3660: 6f 20 73 65 65 20 79 6f 75 72 20 63 6f 6f 6b 69 o see your cooki
3670: 65 21 29 1b 2d 41 0a 20 20 28 6c 69 73 74 20 28 e!).-A. (list (
3680: 73 74 72 69 6e 67 2d 73 75 62 73 74 69 74 75 74 string-substitut
3690: 65 20 0a 09 20 22 3b 22 20 22 3b 20 22 20 0a 09 e .. ";" "; " ..
36a0: 20 28 63 61 72 20 28 63 6f 6e 73 74 72 75 63 74 (car (construct
36b0: 2d 63 6f 6f 6b 69 65 2d 73 74 72 69 6e 67 20 0a -cookie-string .
36c0: 09 20 20 20 20 20 20 20 3b 3b 20 77 61 72 6e 69 . ;; warni
36d0: 6e 67 21 20 6d 65 73 73 69 6e 67 20 75 70 20 74 ng! messing up t
36e0: 68 69 73 20 69 74 74 79 20 62 69 74 74 79 20 62 his itty bitty b
36f0: 69 74 20 6f 66 20 63 6f 64 65 20 77 69 6c 6c 20 it of code will
3700: 63 6f 73 74 20 6d 75 63 68 20 74 69 6d 65 21 0a cost much time!.
3710: 09 20 20 20 20 20 20 20 60 28 28 22 73 65 73 73 . `(("sess
3720: 69 6f 6e 5f 6b 65 79 22 20 2c 28 73 64 61 74 2d ion_key" ,(sdat-
3730: 67 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 get-session-key
3740: 73 65 6c 66 29 0a 09 09 20 20 65 78 70 69 72 65 self)... expire
3750: 73 3a 20 2c 28 2b 20 28 63 75 72 72 65 6e 74 2d s: ,(+ (current-
3760: 73 65 63 6f 6e 64 73 29 20 28 2a 20 31 34 20 38 seconds) (* 14 8
3770: 36 34 30 30 29 29 20 0a 09 09 20 20 3b 3b 20 6d 6400)) ... ;; m
3780: 61 78 2d 61 67 65 3a 20 28 2a 20 31 34 20 38 36 ax-age: (* 14 86
3790: 34 30 30 29 0a 09 09 20 20 70 61 74 68 3a 20 22 400)... path: "
37a0: 2f 22 20 3b 3b 20 0a 09 09 20 20 64 6f 6d 61 69 /" ;; ... domai
37b0: 6e 3a 20 2c 28 73 74 72 69 6e 67 2d 61 70 70 65 n: ,(string-appe
37c0: 6e 64 20 22 2e 22 20 28 73 64 61 74 2d 67 65 74 nd "." (sdat-get
37d0: 2d 64 6f 6d 61 69 6e 20 73 65 6c 66 29 29 0a 09 -domain self))..
37e0: 09 20 20 76 65 72 73 69 6f 6e 3a 20 31 29 29 20 . version: 1))
37f0: 30 29 29 29 29 29 0a 0a 3b 3b 20 6c 6f 6f 6b 20 0)))))..;; look
3800: 75 70 20 61 20 67 69 76 65 6e 20 73 65 73 73 69 up a given sessi
3810: 6f 6e 20 6b 65 79 20 61 6e 64 20 72 65 74 75 72 on key and retur
3820: 6e 20 74 68 65 20 69 64 20 69 66 20 66 6f 75 6e n the id if foun
3830: 64 2c 20 23 66 20 69 66 20 6e 6f 74 20 66 6f 75 d, #f if not fou
3840: 6e 64 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 nd.(define (sess
3850: 69 6f 6e 3a 67 65 74 2d 69 64 20 73 65 6c 66 20 ion:get-id self
3860: 73 65 73 73 69 6f 6e 2d 6b 65 79 29 0a 20 20 3b session-key). ;
3870: 3b 20 28 6c 65 74 20 28 28 73 65 73 73 69 6f 6e ; (let ((session
3880: 2d 6b 65 79 20 28 73 64 61 74 2d 67 65 74 2d 73 -key (sdat-get-s
3890: 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 ession-key self)
38a0: 29 29 0a 20 20 28 69 66 20 73 65 73 73 69 6f 6e )). (if session
38b0: 2d 6b 65 79 0a 20 20 20 20 20 20 28 6c 65 74 20 -key. (let
38c0: 28 28 71 75 65 72 79 20 28 73 74 72 69 6e 67 2d ((query (string-
38d0: 61 70 70 65 6e 64 20 22 53 45 4c 45 43 54 20 69 append "SELECT i
38e0: 64 20 46 52 4f 4d 20 73 65 73 73 69 6f 6e 73 20 d FROM sessions
38f0: 57 48 45 52 45 20 73 65 73 73 69 6f 6e 5f 6b 65 WHERE session_ke
3900: 79 3d 27 22 20 73 65 73 73 69 6f 6e 2d 6b 65 79 y='" session-key
3910: 20 22 27 22 29 29 0a 20 20 20 20 20 20 20 20 20 "'")).
3920: 20 20 20 28 63 6f 6e 6e 20 28 73 64 61 74 2d 67 (conn (sdat-g
3930: 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 0a 20 et-conn self)).
3940: 20 20 20 20 20 20 20 20 20 20 20 28 72 65 73 75 (resu
3950: 6c 74 20 23 66 29 29 0a 09 28 64 62 69 3a 66 6f lt #f))..(dbi:fo
3960: 72 2d 65 61 63 68 2d 72 6f 77 20 0a 09 20 28 6c r-each-row .. (l
3970: 61 6d 62 64 61 20 28 74 75 70 6c 65 29 0a 09 20 ambda (tuple)..
3980: 20 20 28 73 65 74 21 20 72 65 73 75 6c 74 20 28 (set! result (
3990: 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 vector-ref tuple
39a0: 20 30 29 29 29 0a 09 20 63 6f 6e 6e 20 71 75 65 0))).. conn que
39b0: 72 79 29 0a 09 28 69 66 20 72 65 73 75 6c 74 20 ry)..(if result
39c0: 28 64 62 69 3a 65 78 65 63 20 63 6f 6e 6e 20 28 (dbi:exec conn (
39d0: 63 6f 6e 63 20 22 55 50 44 41 54 45 20 73 65 73 conc "UPDATE ses
39e0: 73 69 6f 6e 73 20 53 45 54 20 6c 61 73 74 5f 75 sions SET last_u
39f0: 73 65 64 3d 22 20 28 64 62 69 3a 6e 6f 77 20 63 sed=" (dbi:now c
3a00: 6f 6e 6e 29 20 22 20 57 48 45 52 45 20 73 65 73 onn) " WHERE ses
3a10: 73 69 6f 6e 5f 6b 65 79 3d 3f 3b 22 29 20 73 65 sion_key=?;") se
3a20: 73 73 69 6f 6e 2d 6b 65 79 29 29 0a 20 20 20 20 ssion-key)).
3a30: 20 20 20 20 72 65 73 75 6c 74 29 0a 20 20 20 20 result).
3a40: 20 20 23 66 29 29 0a 0a 3b 3b 20 0a 28 64 65 66 #f))..;; .(def
3a50: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 70 72 6f ine (session:pro
3a60: 63 65 73 73 2d 75 72 6c 2d 70 61 74 68 20 73 65 cess-url-path se
3a70: 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 70 61 74 lf). (let ((pat
3a80: 68 2d 69 6e 66 6f 20 20 20 20 28 67 65 74 2d 65 h-info (get-e
3a90: 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 nvironment-varia
3aa0: 62 6c 65 20 22 50 41 54 48 5f 49 4e 46 4f 22 29 ble "PATH_INFO")
3ab0: 29 0a 09 28 71 75 65 72 79 2d 73 74 72 69 6e 67 )..(query-string
3ac0: 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e (get-environmen
3ad0: 74 2d 76 61 72 69 61 62 6c 65 20 22 51 55 45 52 t-variable "QUER
3ae0: 59 5f 53 54 52 49 4e 47 22 29 29 29 0a 20 20 20 Y_STRING"))).
3af0: 20 3b 3b 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 ;; (session:log
3b00: 20 73 65 6c 66 20 22 70 61 74 68 2d 69 6e 66 6f self "path-info
3b10: 3d 22 20 70 61 74 68 2d 69 6e 66 6f 20 22 20 71 =" path-info " q
3b20: 75 65 72 79 2d 73 74 72 69 6e 67 3d 22 20 71 75 uery-string=" qu
3b30: 65 72 79 2d 73 74 72 69 6e 67 29 0a 20 20 20 20 ery-string).
3b40: 28 69 66 20 70 61 74 68 2d 69 6e 66 6f 0a 09 28 (if path-info..(
3b50: 6c 65 74 2a 20 28 28 70 61 72 74 73 20 20 20 20 let* ((parts
3b60: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 70 61 (string-split pa
3b70: 74 68 2d 69 6e 66 6f 20 22 2f 22 29 29 0a 09 20 th-info "/"))..
3b80: 20 20 20 20 20 20 28 6e 75 6d 70 61 72 74 73 20 (numparts
3b90: 28 6c 65 6e 67 74 68 20 70 61 72 74 73 29 29 29 (length parts)))
3ba0: 0a 09 20 20 28 69 66 20 28 3e 20 6e 75 6d 70 61 .. (if (> numpa
3bb0: 72 74 73 20 30 29 0a 09 20 20 20 20 20 20 28 73 rts 0).. (s
3bc0: 64 61 74 2d 73 65 74 2d 70 61 67 65 21 20 73 65 dat-set-page! se
3bd0: 6c 66 20 28 63 61 72 20 70 61 72 74 73 29 29 29 lf (car parts)))
3be0: 0a 09 20 20 3b 3b 20 28 73 65 73 73 69 6f 6e 3a .. ;; (session:
3bf0: 6c 6f 67 20 73 65 6c 66 20 22 75 72 6c 2d 70 61 log self "url-pa
3c00: 74 68 3d 22 20 75 72 6c 2d 70 61 74 68 20 22 20 th=" url-path "
3c10: 70 61 72 74 73 3d 22 20 70 61 72 74 73 29 0a 09 parts=" parts)..
3c20: 20 20 28 69 66 20 28 3e 20 6e 75 6d 70 61 72 74 (if (> numpart
3c30: 73 20 31 29 0a 09 20 20 20 20 20 20 28 73 64 61 s 1).. (sda
3c40: 74 2d 73 65 74 2d 70 61 74 68 2d 70 61 72 61 6d t-set-path-param
3c50: 73 21 20 73 65 6c 66 20 28 63 64 72 20 70 61 72 s! self (cdr par
3c60: 74 73 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 ts))).
3c70: 28 69 66 20 71 75 65 72 79 2d 73 74 72 69 6e 67 (if query-string
3c80: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
3c90: 73 64 61 74 2d 73 65 74 2d 70 61 72 61 6d 73 21 sdat-set-params!
3ca0: 20 73 65 6c 66 20 28 73 74 72 69 6e 67 2d 73 70 self (string-sp
3cb0: 6c 69 74 20 71 75 65 72 79 2d 73 74 72 69 6e 67 lit query-string
3cc0: 20 22 26 22 29 29 29 29 29 29 29 0a 0a 3b 3b 20 "&")))))))..;;
3cd0: 42 55 47 47 59 21 0a 28 64 65 66 69 6e 65 20 28 BUGGY!.(define (
3ce0: 73 65 73 73 69 6f 6e 3a 67 65 74 2d 6e 65 77 2d session:get-new-
3cf0: 6b 65 79 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 key self). (let
3d00: 20 28 28 63 6f 6e 6e 20 20 20 28 73 64 61 74 2d ((conn (sdat-
3d10: 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 0a get-conn self)).
3d20: 20 20 20 20 20 20 20 20 28 74 6d 70 6b 65 79 20 (tmpkey
3d30: 28 73 65 73 73 69 6f 6e 3a 6d 61 6b 65 2d 72 61 (session:make-ra
3d40: 6e 64 2d 73 74 72 69 6e 67 20 32 30 29 29 0a 20 nd-string 20)).
3d50: 20 20 20 20 20 20 20 28 73 74 61 74 75 73 20 23 (status #
3d60: 66 29 29 0a 20 20 20 20 28 64 62 69 3a 66 6f 72 f)). (dbi:for
3d70: 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 6d 62 64 -each-row (lambd
3d80: 61 20 28 74 75 70 6c 65 29 0a 09 09 09 28 73 65 a (tuple)....(se
3d90: 74 21 20 73 74 61 74 75 73 20 23 74 29 29 0a 09 t! status #t))..
3da0: 09 20 20 20 20 20 20 63 6f 6e 6e 20 28 73 74 72 . conn (str
3db0: 69 6e 67 2d 61 70 70 65 6e 64 20 22 49 4e 53 45 ing-append "INSE
3dc0: 52 54 20 49 4e 54 4f 20 73 65 73 73 69 6f 6e 73 RT INTO sessions
3dd0: 20 28 73 65 73 73 69 6f 6e 5f 6b 65 79 29 20 56 (session_key) V
3de0: 41 4c 55 45 53 20 28 27 22 20 74 6d 70 6b 65 79 ALUES ('" tmpkey
3df0: 20 22 27 29 22 29 29 0a 20 20 20 20 74 6d 70 6b "')")). tmpk
3e00: 65 79 29 29 0a 0a 3b 3b 20 72 65 74 75 72 6e 73 ey))..;; returns
3e10: 20 73 65 73 73 69 6f 6e 20 6b 65 79 20 49 46 46 session key IFF
3e20: 20 69 74 20 69 73 20 69 6e 20 74 68 65 20 48 54 it is in the HT
3e30: 54 50 5f 43 4f 4f 4b 49 45 20 0a 28 64 65 66 69 TP_COOKIE .(defi
3e40: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 65 78 74 72 ne (session:extr
3e50: 61 63 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 act-session-key
3e60: 73 65 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 68 self). (let ((h
3e70: 74 74 70 2d 63 6f 6f 6b 69 65 20 28 67 65 74 2d ttp-cookie (get-
3e80: 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 environment-vari
3e90: 61 62 6c 65 20 22 48 54 54 50 5f 43 4f 4f 4b 49 able "HTTP_COOKI
3ea0: 45 22 29 29 29 0a 20 20 20 20 3b 3b 20 28 65 72 E"))). ;; (er
3eb0: 72 3a 6c 6f 67 20 22 68 74 74 70 2d 63 6f 6f 6b r:log "http-cook
3ec0: 69 65 3a 20 22 20 68 74 74 70 2d 63 6f 6f 6b 69 ie: " http-cooki
3ed0: 65 29 0a 20 20 20 20 28 69 66 20 68 74 74 70 2d e). (if http-
3ee0: 63 6f 6f 6b 69 65 0a 20 20 20 20 20 20 20 20 28 cookie. (
3ef0: 73 65 73 73 69 6f 6e 3a 65 78 74 72 61 63 74 2d session:extract-
3f00: 6b 65 79 2d 66 72 6f 6d 2d 70 61 72 61 6d 20 73 key-from-param s
3f10: 65 6c 66 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 elf (string-spli
3f20: 74 2d 66 69 65 6c 64 73 20 20 22 3b 5c 5c 73 2b t-fields ";\\s+
3f30: 22 20 68 74 74 70 2d 63 6f 6f 6b 69 65 20 69 6e " http-cookie in
3f40: 66 69 78 3a 29 20 22 73 65 73 73 69 6f 6e 5f 6b fix:) "session_k
3f50: 65 79 22 29 0a 20 20 20 20 20 20 20 20 23 66 29 ey"). #f)
3f60: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 ))..(define (ses
3f70: 73 69 6f 6e 3a 67 65 74 2d 73 65 73 73 69 6f 6e sion:get-session
3f80: 2d 69 64 20 73 65 6c 66 20 73 65 73 73 69 6f 6e -id self session
3f90: 2d 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 28 71 -key). (let ((q
3fa0: 75 65 72 79 20 22 53 45 4c 45 43 54 20 69 64 20 uery "SELECT id
3fb0: 46 52 4f 4d 20 73 65 73 73 69 6f 6e 73 20 57 48 FROM sessions WH
3fc0: 45 52 45 20 73 65 73 73 69 6f 6e 5f 6b 65 79 3d ERE session_key=
3fd0: 3f 3b 22 29 0a 20 20 20 20 20 20 20 20 28 72 65 ?;"). (re
3fe0: 73 75 6c 74 20 23 66 29 29 0a 20 20 20 20 3b 3b sult #f)). ;;
3ff0: 20 20 20 20 20 28 70 67 3a 71 75 65 72 79 2d 66 (pg:query-f
4000: 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 or-each (lambda
4010: 28 74 75 70 6c 65 29 0a 20 20 20 20 3b 3b 20 20 (tuple). ;;
4020: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4030: 20 20 20 20 20 20 20 20 28 73 65 74 21 20 72 65 (set! re
4040: 73 75 6c 74 20 28 76 65 63 74 6f 72 2d 72 65 66 sult (vector-ref
4050: 20 74 75 70 6c 65 20 30 29 29 29 20 3b 3b 20 28 tuple 0))) ;; (
4060: 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 vector-ref tuple
4070: 20 30 29 29 29 0a 20 20 20 20 3b 3b 20 20 20 20 0))). ;;
4080: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4090: 20 20 20 20 28 73 3a 73 71 6c 70 61 72 61 6d 20 (s:sqlparam
40a0: 71 75 65 72 79 20 73 65 73 73 69 6f 6e 2d 6b 65 query session-ke
40b0: 79 29 0a 20 20 20 20 3b 3b 20 20 20 20 20 20 20 y). ;;
40c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
40d0: 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 (sdat-get-conn
40e0: 73 65 6c 66 29 29 0a 20 20 20 20 3b 3b 20 20 20 self)). ;;
40f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4100: 20 20 20 20 20 63 6f 6e 6e 29 0a 20 20 20 20 28 conn). (
4110: 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 dbi:for-each-row
4120: 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 29 (lambda (tuple)
4130: 0a 09 09 09 28 73 65 74 21 20 72 65 73 75 6c 74 ....(set! result
4140: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 (vector-ref tup
4150: 6c 65 20 30 29 29 29 20 3b 3b 20 28 76 65 63 74 le 0))) ;; (vect
4160: 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 30 29 29 or-ref tuple 0))
4170: 29 0a 09 09 20 20 20 20 20 20 28 73 64 61 74 2d )... (sdat-
4180: 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 0a 09 get-conn self)..
4190: 09 20 20 20 20 20 20 28 73 3a 73 71 6c 70 61 72 . (s:sqlpar
41a0: 61 6d 20 71 75 65 72 79 20 73 65 73 73 69 6f 6e am query session
41b0: 2d 6b 65 79 29 29 0a 20 20 20 20 72 65 73 75 6c -key)). resul
41c0: 74 29 29 0a 0a 3b 3b 20 64 65 6c 65 74 65 20 61 t))..;; delete a
41d0: 6c 6c 20 72 65 63 6f 72 64 73 20 66 6f 72 20 61 ll records for a
41e0: 20 73 65 73 73 69 6f 6e 0a 3b 3b 20 0a 3b 3b 20 session.;; .;;
41f0: 4e 45 45 44 53 20 54 4f 20 42 45 20 54 52 41 4e NEEDS TO BE TRAN
4200: 53 41 43 54 49 4f 4e 49 5a 45 44 21 0a 3b 3b 0a SACTIONIZED!.;;.
4210: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
4220: 3a 64 65 6c 65 74 65 2d 73 65 73 73 69 6f 6e 20 :delete-session
4230: 73 65 6c 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 self session-key
4240: 29 0a 20 20 28 6c 65 74 20 28 28 73 65 73 73 69 ). (let ((sessi
4250: 6f 6e 2d 69 64 20 28 73 65 73 73 69 6f 6e 3a 67 on-id (session:g
4260: 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 et-session-id se
4270: 6c 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 lf session-key))
4280: 0a 20 20 20 20 20 20 20 20 28 71 72 79 31 20 20 . (qry1
4290: 20 20 20 20 20 20 3b 3b 20 28 63 6f 6e 63 20 22 ;; (conc "
42a0: 42 45 47 49 4e 3b 22 0a 09 09 09 20 20 22 44 45 BEGIN;".... "DE
42b0: 4c 45 54 45 20 46 52 4f 4d 20 73 65 73 73 69 6f LETE FROM sessio
42c0: 6e 5f 76 61 72 73 20 57 48 45 52 45 20 73 65 73 n_vars WHERE ses
42d0: 73 69 6f 6e 5f 69 64 3d 3f 3b 22 29 0a 09 28 71 sion_id=?;")..(q
42e0: 72 79 32 20 20 20 20 20 20 20 20 20 20 20 20 20 ry2
42f0: 22 44 45 4c 45 54 45 20 46 52 4f 4d 20 73 65 73 "DELETE FROM ses
4300: 73 69 6f 6e 73 20 57 48 45 52 45 20 69 64 3d 3f sions WHERE id=?
4310: 3b 22 29 0a 09 09 20 20 20 20 20 3b 3b 20 20 22 ;")... ;; "
4320: 43 4f 4d 4d 49 54 3b 22 29 29 0a 20 20 20 20 20 COMMIT;")).
4330: 20 20 20 28 63 6f 6e 6e 20 20 20 20 20 20 20 20 (conn
4340: 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d (sdat-get-
4350: 63 6f 6e 6e 20 73 65 6c 66 29 29 29 0a 20 20 20 conn self))).
4360: 20 28 69 66 20 73 65 73 73 69 6f 6e 2d 69 64 0a (if session-id.
4370: 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 (begin.
4380: 20 20 20 20 20 20 20 20 20 28 64 62 69 3a 65 78 (dbi:ex
4390: 65 63 20 63 6f 6e 6e 20 71 72 79 31 20 73 65 73 ec conn qry1 ses
43a0: 73 69 6f 6e 2d 69 64 29 20 3b 3b 20 73 65 73 73 sion-id) ;; sess
43b0: 69 6f 6e 2d 69 64 29 0a 09 20 20 28 64 62 69 3a ion-id).. (dbi:
43c0: 65 78 65 63 20 63 6f 6e 6e 20 71 72 79 32 20 73 exec conn qry2 s
43d0: 65 73 73 69 6f 6e 2d 69 64 29 0a 09 20 20 28 73 ession-id).. (s
43e0: 65 73 73 69 6f 6e 3a 69 6e 69 74 69 61 6c 69 7a ession:initializ
43f0: 65 20 73 65 6c 66 29 0a 09 20 20 28 73 65 73 73 e self).. (sess
4400: 69 6f 6e 3a 73 65 74 75 70 20 73 65 6c 66 29 29 ion:setup self))
4410: 29 0a 20 20 20 20 28 6e 6f 74 20 28 73 65 73 73 ). (not (sess
4420: 69 6f 6e 3a 67 65 74 2d 73 65 73 73 69 6f 6e 2d ion:get-session-
4430: 69 64 20 73 65 6c 66 20 73 65 73 73 69 6f 6e 2d id self session-
4440: 6b 65 79 29 29 29 29 0a 0a 3b 3b 20 28 64 65 66 key))))..;; (def
4450: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 64 65 6c ine (session:del
4460: 65 74 65 2d 73 65 73 73 69 6f 6e 20 73 65 6c 66 ete-session self
4470: 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 0a 3b 3b session-key).;;
4480: 20 20 20 28 6c 65 74 20 28 28 73 65 73 73 69 6f (let ((sessio
4490: 6e 2d 69 64 20 28 73 65 73 73 69 6f 6e 3a 67 65 n-id (session:ge
44a0: 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c t-session-id sel
44b0: 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 0a f session-key)).
44c0: 3b 3b 20 20 20 20 20 20 20 20 20 28 71 75 65 72 ;; (quer
44d0: 69 65 73 20 20 20 20 28 6c 69 73 74 20 22 42 45 ies (list "BE
44e0: 47 49 4e 3b 22 0a 3b 3b 20 09 09 09 20 20 22 44 GIN;".;; ... "D
44f0: 45 4c 45 54 45 20 46 52 4f 4d 20 73 65 73 73 69 ELETE FROM sessi
4500: 6f 6e 5f 76 61 72 73 20 57 48 45 52 45 20 73 65 on_vars WHERE se
4510: 73 73 69 6f 6e 5f 69 64 3d 3f 3b 22 0a 3b 3b 20 ssion_id=?;".;;
4520: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4530: 20 20 20 20 20 20 20 20 20 20 22 44 45 4c 45 54 "DELET
4540: 45 20 46 52 4f 4d 20 73 65 73 73 69 6f 6e 73 20 E FROM sessions
4550: 57 48 45 52 45 20 69 64 3d 3f 3b 22 0a 3b 3b 20 WHERE id=?;".;;
4560: 09 09 09 20 20 22 43 4f 4d 4d 49 54 3b 22 29 29 ... "COMMIT;"))
4570: 0a 3b 3b 20 20 20 20 20 20 20 20 20 28 63 6f 6e .;; (con
4580: 6e 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 n (
4590: 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 sdat-get-conn se
45a0: 6c 66 29 29 29 0a 3b 3b 20 20 20 20 20 28 69 66 lf))).;; (if
45b0: 20 73 65 73 73 69 6f 6e 2d 69 64 0a 3b 3b 20 20 session-id.;;
45c0: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 3b 3b (begin.;;
45d0: 20 20 20 20 20 20 20 20 20 20 20 28 66 6f 72 2d (for-
45e0: 65 61 63 68 0a 3b 3b 20 20 20 20 20 20 20 20 20 each.;;
45f0: 20 20 20 28 6c 61 6d 62 64 61 20 28 71 75 65 72 (lambda (quer
4600: 79 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 y).;;
4610: 20 20 20 28 64 62 69 3a 65 78 65 63 20 63 6f 6e (dbi:exec con
4620: 6e 20 71 75 65 72 79 20 73 65 73 73 69 6f 6e 2d n query session-
4630: 69 64 29 29 0a 3b 3b 20 09 20 20 20 71 75 65 72 id)).;; . quer
4640: 69 65 73 29 0a 3b 3b 20 09 20 20 28 69 6e 69 74 ies).;; . (init
4650: 69 61 6c 69 7a 65 20 73 65 6c 66 20 27 28 29 29 ialize self '())
4660: 0a 3b 3b 20 09 20 20 28 73 65 73 73 69 6f 6e 3a .;; . (session:
4670: 73 65 74 75 70 20 73 65 6c 66 29 29 29 0a 3b 3b setup self))).;;
4680: 20 20 20 20 20 28 6e 6f 74 20 28 73 65 73 73 69 (not (sessi
4690: 6f 6e 3a 67 65 74 2d 73 65 73 73 69 6f 6e 2d 69 on:get-session-i
46a0: 64 20 73 65 6c 66 20 73 65 73 73 69 6f 6e 2d 6b d self session-k
46b0: 65 79 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ey))))..(define
46c0: 28 73 65 73 73 69 6f 6e 3a 65 78 74 72 61 63 74 (session:extract
46d0: 2d 6b 65 79 20 73 65 6c 66 20 6b 65 79 29 0a 20 -key self key).
46e0: 20 28 6c 65 74 20 28 28 70 61 72 61 6d 73 20 28 (let ((params (
46f0: 73 64 61 74 2d 67 65 74 2d 70 61 72 61 6d 73 20 sdat-get-params
4700: 73 65 6c 66 29 29 29 0a 20 20 20 20 28 73 65 73 self))). (ses
4710: 73 69 6f 6e 3a 65 78 74 72 61 63 74 2d 6b 65 79 sion:extract-key
4720: 2d 66 72 6f 6d 2d 70 61 72 61 6d 20 73 65 6c 66 -from-param self
4730: 20 70 61 72 61 6d 73 20 6b 65 79 29 29 29 0a 0a params key)))..
4740: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
4750: 3a 65 78 74 72 61 63 74 2d 6b 65 79 2d 66 72 6f :extract-key-fro
4760: 6d 2d 70 61 72 61 6d 20 73 65 6c 66 20 70 61 72 m-param self par
4770: 61 6d 73 20 6b 65 79 29 0a 20 20 28 6c 65 74 20 ams key). (let
4780: 28 28 72 31 20 20 20 20 20 28 72 65 67 65 78 70 ((r1 (regexp
4790: 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 (string-append
47a0: 22 5e 22 20 6b 65 79 20 22 3d 28 5b 5e 3d 5d 2b "^" key "=([^=]+
47b0: 29 24 22 29 29 29 29 0a 20 20 20 20 28 65 72 72 )$")))). (err
47c0: 3a 6c 6f 67 20 22 49 4e 46 4f 3a 20 4c 6f 6f 6b :log "INFO: Look
47d0: 69 6e 67 20 66 6f 72 20 22 20 6b 65 79 20 22 20 ing for " key "
47e0: 69 6e 20 22 20 70 61 72 61 6d 73 29 0a 20 20 20 in " params).
47f0: 20 28 69 66 20 28 3c 20 28 6c 65 6e 67 74 68 20 (if (< (length
4800: 70 61 72 61 6d 73 29 20 31 29 20 23 66 0a 09 28 params) 1) #f..(
4810: 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 61 64 20 let loop ((head
4820: 20 20 28 63 61 72 20 70 61 72 61 6d 73 29 29 0a (car params)).
4830: 09 09 20 20 20 28 74 61 69 6c 20 20 20 28 63 64 .. (tail (cd
4840: 72 20 70 61 72 61 6d 73 29 29 29 0a 09 20 20 28 r params))).. (
4850: 6c 65 74 20 28 28 6d 61 74 63 68 20 28 73 74 72 let ((match (str
4860: 69 6e 67 2d 6d 61 74 63 68 20 72 31 20 68 65 61 ing-match r1 hea
4870: 64 29 29 29 0a 09 20 20 20 20 28 63 6f 6e 64 0a d))).. (cond.
4880: 09 20 20 20 20 20 28 6d 61 74 63 68 0a 09 20 20 . (match..
4890: 20 20 20 20 28 6c 65 74 20 28 28 73 65 73 73 69 (let ((sessi
48a0: 6f 6e 2d 6b 65 79 20 28 6c 69 73 74 2d 72 65 66 on-key (list-ref
48b0: 20 6d 61 74 63 68 20 31 29 29 29 0a 09 09 28 65 match 1)))...(e
48c0: 72 72 3a 6c 6f 67 20 22 49 4e 46 4f 3a 20 46 6f rr:log "INFO: Fo
48d0: 75 6e 64 20 73 65 73 73 69 6f 6e 20 6b 65 79 3d und session key=
48e0: 22 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 0a 09 " session-key)..
48f0: 09 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 .(sdat-set-sessi
4900: 6f 6e 2d 6b 65 79 21 20 73 65 6c 66 20 28 6c 69 on-key! self (li
4910: 73 74 2d 72 65 66 20 6d 61 74 63 68 20 31 29 29 st-ref match 1))
4920: 0a 09 09 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 ...session-key))
4930: 0a 09 20 20 20 20 20 28 28 6e 75 6c 6c 3f 20 74 .. ((null? t
4940: 61 69 6c 29 0a 09 20 20 20 20 20 20 23 66 29 0a ail).. #f).
4950: 09 20 20 20 20 20 28 65 6c 73 65 0a 09 20 20 20 . (else..
4960: 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 (loop (car ta
4970: 69 6c 29 0a 09 09 20 20 20 20 28 63 64 72 20 74 il)... (cdr t
4980: 61 69 6c 29 29 29 29 29 29 29 29 29 0a 0a 28 64 ail)))))))))..(d
4990: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 efine (session:s
49a0: 65 74 2d 70 61 67 65 21 20 73 65 6c 66 20 70 61 et-page! self pa
49b0: 67 65 5f 6e 61 6d 65 29 0a 20 20 28 73 64 61 74 ge_name). (sdat
49c0: 2d 73 65 74 2d 70 61 67 65 21 20 73 65 6c 66 20 -set-page! self
49d0: 70 61 67 65 5f 6e 61 6d 65 29 29 0a 0a 28 64 65 page_name))..(de
49e0: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 63 6c fine (session:cl
49f0: 6f 73 65 20 73 65 6c 66 29 0a 20 20 28 64 62 69 ose self). (dbi
4a00: 3a 63 6c 6f 73 65 20 28 73 64 61 74 2d 67 65 74 :close (sdat-get
4a10: 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 29 0a 3b 3b -conn self))).;;
4a20: 20 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 (close-output-p
4a30: 6f 72 74 20 28 73 64 61 74 2d 67 65 74 2d 6c 6f ort (sdat-get-lo
4a40: 67 70 74 20 73 65 6c 66 29 29 0a 0a 28 64 65 66 gpt self))..(def
4a50: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 65 72 72 ine (session:err
4a60: 2d 6d 73 67 20 73 65 6c 66 20 6d 73 67 29 0a 20 -msg self msg).
4a70: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
4a80: 21 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 ! (sdat-get-sess
4a90: 69 6f 6e 76 61 72 73 20 73 65 6c 66 29 20 22 45 ionvars self) "E
4aa0: 52 52 4f 52 5f 4d 53 47 22 0a 09 09 20 20 20 28 RROR_MSG"... (
4ab0: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
4ac0: 73 65 20 28 6d 61 70 20 73 3a 61 6e 79 2d 3e 73 se (map s:any->s
4ad0: 74 72 69 6e 67 20 6d 73 67 29 20 22 20 22 29 29 tring msg) " "))
4ae0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 )..(define (sess
4af0: 69 6f 6e 3a 70 72 65 76 2d 65 72 72 20 73 65 6c ion:prev-err sel
4b00: 66 29 0a 20 20 28 6c 65 74 20 28 28 70 72 65 76 f). (let ((prev
4b10: 2d 65 72 72 20 28 68 61 73 68 2d 74 61 62 6c 65 -err (hash-table
4b20: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 28 73 64 -ref/default (sd
4b30: 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 at-get-sessionva
4b40: 72 73 2d 62 65 66 6f 72 65 20 73 65 6c 66 29 20 rs-before self)
4b50: 22 45 52 52 4f 52 5f 4d 53 47 22 20 23 66 29 29 "ERROR_MSG" #f))
4b60: 0a 09 28 63 75 72 72 2d 65 72 72 20 28 68 61 73 ..(curr-err (has
4b70: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
4b80: 75 6c 74 20 28 73 64 61 74 2d 67 65 74 2d 73 65 ult (sdat-get-se
4b90: 73 73 69 6f 6e 76 61 72 73 20 73 65 6c 66 29 20 ssionvars self)
4ba0: 22 45 52 52 4f 52 5f 4d 53 47 22 20 23 66 29 29 "ERROR_MSG" #f))
4bb0: 29 0a 20 20 20 20 28 69 66 20 70 72 65 76 2d 65 ). (if prev-e
4bc0: 72 72 20 70 72 65 76 2d 65 72 72 0a 09 28 69 66 rr prev-err..(if
4bd0: 20 63 75 72 72 2d 65 72 72 20 63 75 72 72 2d 65 curr-err curr-e
4be0: 72 72 20 23 66 29 29 29 29 0a 0a 3b 3b 20 73 65 rr #f))))..;; se
4bf0: 73 73 69 6f 6e 20 76 61 72 73 0a 3b 3b 20 31 2e ssion vars.;; 1.
4c00: 20 6b 65 79 73 20 61 72 65 20 61 6c 77 61 79 73 keys are always
4c10: 20 61 20 73 74 72 69 6e 67 20 4e 4f 54 20 61 20 a string NOT a
4c20: 73 79 6d 62 6f 6c 0a 3b 3b 20 32 2e 20 76 61 6c symbol.;; 2. val
4c30: 75 65 73 20 61 72 65 20 61 6c 77 61 79 73 20 61 ues are always a
4c40: 20 73 74 72 69 6e 67 20 63 6f 6e 76 65 72 73 69 string conversi
4c50: 6f 6e 20 69 73 20 74 68 65 20 72 65 73 70 6f 6e on is the respon
4c60: 73 69 62 69 6c 69 74 79 20 6f 66 20 74 68 65 20 sibility of the
4c70: 0a 3b 3b 20 20 20 20 63 6f 6e 73 75 6d 69 6e 67 .;; consuming
4c80: 20 66 75 6e 63 74 69 6f 6e 20 28 61 74 20 6c 65 function (at le
4c90: 61 73 74 20 66 6f 72 20 6e 6f 77 2c 20 49 27 64 ast for now, I'd
4ca0: 20 6c 69 6b 65 20 74 6f 20 63 68 61 6e 67 65 20 like to change
4cb0: 74 68 69 73 29 0a 0a 3b 3b 20 73 65 74 20 61 20 this)..;; set a
4cc0: 73 65 73 73 69 6f 6e 20 76 61 72 20 66 6f 72 20 session var for
4cd0: 74 68 65 20 63 75 72 72 65 6e 74 20 70 61 67 65 the current page
4ce0: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 73 .;;.(define (ses
4cf0: 73 69 6f 6e 3a 63 75 72 72 2d 70 61 67 65 2d 73 sion:curr-page-s
4d00: 65 74 21 20 73 65 6c 66 20 6b 65 79 20 76 61 6c et! self key val
4d10: 75 65 29 0a 20 20 28 68 61 73 68 2d 74 61 62 6c ue). (hash-tabl
4d20: 65 2d 73 65 74 21 20 28 73 64 61 74 2d 67 65 74 e-set! (sdat-get
4d30: 2d 70 61 67 65 76 61 72 73 20 73 65 6c 66 29 20 -pagevars self)
4d40: 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6b (s:any->string k
4d50: 65 79 29 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 ey) (s:any->stri
4d60: 6e 67 20 76 61 6c 75 65 29 29 29 0a 0a 3b 3b 20 ng value)))..;;
4d70: 64 65 6c 20 61 20 76 61 72 20 66 6f 72 20 74 68 del a var for th
4d80: 65 20 63 75 72 72 65 6e 74 20 70 61 67 65 0a 3b e current page.;
4d90: 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ;.(define (sessi
4da0: 6f 6e 3a 70 61 67 65 2d 76 61 72 2d 64 65 6c 21 on:page-var-del!
4db0: 20 73 65 6c 66 20 6b 65 79 29 0a 20 20 28 68 61 self key). (ha
4dc0: 73 68 2d 74 61 62 6c 65 2d 64 65 6c 65 74 65 21 sh-table-delete!
4dd0: 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 76 (sdat-get-pagev
4de0: 61 72 73 20 73 65 6c 66 29 20 28 73 3a 61 6e 79 ars self) (s:any
4df0: 2d 3e 73 74 72 69 6e 67 20 6b 65 79 29 29 29 0a ->string key))).
4e00: 0a 3b 3b 20 67 65 74 20 74 68 65 20 61 70 70 72 .;; get the appr
4e10: 6f 70 72 69 61 74 65 20 68 61 73 68 20 67 69 76 opriate hash giv
4e20: 65 6e 20 61 20 70 61 67 65 20 22 2a 73 65 73 73 en a page "*sess
4e30: 69 6f 6e 76 61 72 73 2a 2c 20 2a 67 6c 6f 62 61 ionvars*, *globa
4e40: 6c 76 61 72 73 2a 20 6f 72 20 70 61 67 65 0a 3b lvars* or page.;
4e50: 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ;.(define (sessi
4e60: 6f 6e 3a 67 65 74 2d 70 61 67 65 2d 68 61 73 68 on:get-page-hash
4e70: 20 73 65 6c 66 20 70 61 67 65 29 0a 20 20 28 69 self page). (i
4e80: 66 20 28 73 74 72 69 6e 67 3d 3f 20 70 61 67 65 f (string=? page
4e90: 20 22 2a 73 65 73 73 69 6f 6e 76 61 72 73 2a 22 "*sessionvars*"
4ea0: 29 0a 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 ). (sdat-ge
4eb0: 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 20 73 65 t-sessionvars se
4ec0: 6c 66 29 0a 20 20 20 20 20 20 28 69 66 20 28 73 lf). (if (s
4ed0: 74 72 69 6e 67 3d 3f 20 70 61 67 65 20 22 2a 67 tring=? page "*g
4ee0: 6c 6f 62 61 6c 76 61 72 73 2a 22 29 0a 09 20 20 lobalvars*")..
4ef0: 28 73 64 61 74 2d 67 65 74 2d 67 6c 6f 62 61 6c (sdat-get-global
4f00: 76 61 72 73 20 73 65 6c 66 29 0a 09 20 20 28 73 vars self).. (s
4f10: 64 61 74 2d 67 65 74 2d 70 61 67 65 76 61 72 73 dat-get-pagevars
4f20: 20 73 65 6c 66 29 29 29 29 0a 0a 3b 3b 20 73 65 self))))..;; se
4f30: 74 20 61 20 73 65 73 73 69 6f 6e 20 76 61 72 20 t a session var
4f40: 66 6f 72 20 61 20 67 69 76 65 6e 20 70 61 67 65 for a given page
4f50: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 73 .;;.(define (ses
4f60: 73 69 6f 6e 3a 73 65 74 21 20 73 65 6c 66 20 70 sion:set! self p
4f70: 61 67 65 20 6b 65 79 20 76 61 6c 75 65 29 0a 20 age key value).
4f80: 20 28 6c 65 74 20 28 28 68 74 20 28 73 65 73 73 (let ((ht (sess
4f90: 69 6f 6e 3a 67 65 74 2d 70 61 67 65 2d 68 61 73 ion:get-page-has
4fa0: 68 20 73 65 6c 66 20 70 61 67 65 29 29 29 0a 20 h self page))).
4fb0: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 (hash-table-s
4fc0: 65 74 21 20 68 74 20 28 73 3a 61 6e 79 2d 3e 73 et! ht (s:any->s
4fd0: 74 72 69 6e 67 20 6b 65 79 29 20 28 73 3a 61 6e tring key) (s:an
4fe0: 79 2d 3e 73 74 72 69 6e 67 20 76 61 6c 75 65 29 y->string value)
4ff0: 29 29 29 0a 0a 3b 3b 20 67 65 74 20 73 65 73 73 )))..;; get sess
5000: 69 6f 6e 20 76 61 72 73 20 66 6f 72 20 74 68 65 ion vars for the
5010: 20 63 75 72 72 65 6e 74 20 70 61 67 65 0a 3b 3b current page.;;
5020: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
5030: 6e 3a 70 61 67 65 2d 67 65 74 20 73 65 6c 66 20 n:page-get self
5040: 6b 65 79 29 0a 20 20 28 68 61 73 68 2d 74 61 62 key). (hash-tab
5050: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 28 le-ref/default (
5060: 73 64 61 74 2d 67 65 74 2d 70 61 67 65 76 61 72 sdat-get-pagevar
5070: 73 20 73 65 6c 66 29 20 6b 65 79 20 23 66 29 29 s self) key #f))
5080: 0a 0a 3b 3b 20 67 65 74 20 73 65 73 73 69 6f 6e ..;; get session
5090: 20 76 61 72 73 20 66 6f 72 20 61 20 73 70 65 63 vars for a spec
50a0: 69 66 69 65 64 20 70 61 67 65 0a 3b 3b 0a 28 64 ified page.;;.(d
50b0: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 efine (session:g
50c0: 65 74 20 73 65 6c 66 20 70 61 67 65 20 6b 65 79 et self page key
50d0: 20 70 61 72 61 6d 73 29 0a 20 20 28 6c 65 74 2a params). (let*
50e0: 20 28 28 68 74 20 20 28 73 65 73 73 69 6f 6e 3a ((ht (session:
50f0: 67 65 74 2d 70 61 67 65 2d 68 61 73 68 20 73 65 get-page-hash se
5100: 6c 66 20 70 61 67 65 29 29 0a 09 20 28 72 65 73 lf page)).. (res
5110: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
5120: 2f 64 65 66 61 75 6c 74 20 68 74 20 28 73 3a 61 /default ht (s:a
5130: 6e 79 2d 3e 73 74 72 69 6e 67 20 6b 65 79 29 20 ny->string key)
5140: 23 66 29 29 29 0a 20 20 20 20 28 73 65 73 73 69 #f))). (sessi
5150: 6f 6e 3a 61 70 70 6c 79 2d 74 79 70 65 2d 70 72 on:apply-type-pr
5160: 65 66 65 72 65 6e 63 65 20 72 65 73 20 70 61 72 eference res par
5170: 61 6d 73 29 29 29 0a 0a 3b 3b 20 64 65 6c 65 74 ams)))..;; delet
5180: 65 20 61 20 73 65 73 73 69 6f 6e 20 76 61 72 20 e a session var
5190: 66 6f 72 20 61 20 73 70 65 63 69 66 69 65 64 20 for a specified
51a0: 70 61 67 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 page.;;.(define
51b0: 28 73 65 73 73 69 6f 6e 3a 64 65 6c 21 20 73 65 (session:del! se
51c0: 6c 66 20 70 61 67 65 20 6b 65 79 29 0a 20 20 28 lf page key). (
51d0: 6c 65 74 20 28 28 68 74 20 28 73 65 73 73 69 6f let ((ht (sessio
51e0: 6e 3a 67 65 74 2d 70 61 67 65 2d 68 61 73 68 20 n:get-page-hash
51f0: 73 65 6c 66 20 70 61 67 65 29 29 29 0a 20 20 20 self page))).
5200: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 64 65 6c (hash-table-del
5210: 65 74 65 21 20 68 74 20 28 73 3a 61 6e 79 2d 3e ete! ht (s:any->
5220: 73 74 72 69 6e 67 20 6b 65 79 29 29 29 29 0a 0a string key))))..
5230: 3b 3b 20 67 65 74 20 41 4c 4c 20 6b 65 79 73 20 ;; get ALL keys
5240: 66 6f 72 20 74 68 69 73 20 70 61 67 65 20 61 6e for this page an
5250: 64 20 73 74 6f 72 65 20 69 6e 20 74 68 65 20 73 d store in the s
5260: 65 73 73 69 6f 6e 20 70 61 67 65 76 61 72 73 20 ession pagevars
5270: 68 61 73 68 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 hash.;;.(define
5280: 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 76 61 72 (session:get-var
5290: 73 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 20 28 s self). (let (
52a0: 28 73 65 73 73 69 6f 6e 2d 69 64 20 20 28 73 64 (session-id (sd
52b0: 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 2d 69 at-get-session-i
52c0: 64 20 73 65 6c 66 29 29 29 0a 20 20 20 20 28 69 d self))). (i
52d0: 66 20 28 6e 6f 74 20 73 65 73 73 69 6f 6e 2d 69 f (not session-i
52e0: 64 29 0a 09 28 65 72 72 3a 6c 6f 67 20 22 45 52 d)..(err:log "ER
52f0: 52 4f 52 3a 20 4e 6f 20 73 65 73 73 69 6f 6e 20 ROR: No session
5300: 69 64 20 69 6e 20 73 65 73 73 69 6f 6e 20 6f 62 id in session ob
5310: 6a 65 63 74 21 20 73 65 73 73 69 6f 6e 3a 67 65 ject! session:ge
5320: 74 2d 76 61 72 73 22 29 0a 09 28 6c 65 74 2a 20 t-vars")..(let*
5330: 28 28 72 65 73 75 6c 74 20 20 20 20 20 20 20 20 ((result
5340: 20 20 20 20 20 23 66 29 0a 09 20 20 20 20 20 20 #f)..
5350: 20 28 63 6f 6e 6e 20 20 20 20 20 20 20 20 20 20 (conn
5360: 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d 63 (sdat-get-c
5370: 6f 6e 6e 20 73 65 6c 66 29 29 0a 09 20 20 20 20 onn self))..
5380: 20 20 20 28 70 61 67 65 76 61 72 73 2d 62 65 66 (pagevars-bef
5390: 6f 72 65 20 20 20 20 28 73 64 61 74 2d 67 65 74 ore (sdat-get
53a0: 2d 70 61 67 65 76 61 72 73 2d 62 65 66 6f 72 65 -pagevars-before
53b0: 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 20 20 self))..
53c0: 28 73 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 (sessionvars-bef
53d0: 6f 72 65 20 28 73 64 61 74 2d 67 65 74 2d 73 65 ore (sdat-get-se
53e0: 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 ssionvars-before
53f0: 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 20 20 self))..
5400: 28 67 6c 6f 62 61 6c 76 61 72 73 2d 62 65 66 6f (globalvars-befo
5410: 72 65 20 20 28 73 64 61 74 2d 67 65 74 2d 67 6c re (sdat-get-gl
5420: 6f 62 61 6c 76 61 72 73 2d 62 65 66 6f 72 65 20 obalvars-before
5430: 73 65 6c 66 29 29 0a 09 20 20 20 20 20 20 20 28 self)).. (
5440: 70 61 67 65 76 61 72 73 20 20 20 20 20 20 20 20 pagevars
5450: 20 20 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 (sdat-get-pag
5460: 65 76 61 72 73 20 73 65 6c 66 29 29 0a 09 20 20 evars self))..
5470: 20 20 20 20 20 28 73 65 73 73 69 6f 6e 76 61 72 (sessionvar
5480: 73 20 20 20 20 20 20 20 20 28 73 64 61 74 2d 67 s (sdat-g
5490: 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 20 73 et-sessionvars s
54a0: 65 6c 66 29 29 0a 09 20 20 20 20 20 20 20 28 67 elf)).. (g
54b0: 6c 6f 62 61 6c 76 61 72 73 20 20 20 20 20 20 20 lobalvars
54c0: 20 20 28 73 64 61 74 2d 67 65 74 2d 67 6c 6f 62 (sdat-get-glob
54d0: 61 6c 76 61 72 73 20 73 65 6c 66 29 29 0a 09 20 alvars self))..
54e0: 20 20 20 20 20 20 28 70 61 67 65 2d 6e 61 6d 65 (page-name
54f0: 20 20 20 20 20 20 20 20 20 20 28 73 64 61 74 2d (sdat-
5500: 67 65 74 2d 70 61 67 65 20 73 65 6c 66 29 29 0a get-page self)).
5510: 09 20 20 20 20 20 20 20 28 73 65 73 73 69 6f 6e . (session
5520: 2d 6b 65 79 20 20 20 20 20 20 20 20 28 73 64 61 -key (sda
5530: 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 t-get-session-ke
5540: 79 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 20 y self))..
5550: 20 28 71 75 65 72 79 20 20 20 20 20 20 20 20 20 (query
5560: 20 20 20 20 20 28 73 74 72 69 6e 67 2d 61 70 70 (string-app
5570: 65 6e 64 0a 09 09 09 09 20 20 20 20 22 53 45 4c end..... "SEL
5580: 45 43 54 20 6b 65 79 2c 76 61 6c 75 65 20 46 52 ECT key,value FR
5590: 4f 4d 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 OM session_vars
55a0: 49 4e 4e 45 52 20 4a 4f 49 4e 20 73 65 73 73 69 INNER JOIN sessi
55b0: 6f 6e 73 20 4f 4e 20 73 65 73 73 69 6f 6e 5f 76 ons ON session_v
55c0: 61 72 73 2e 73 65 73 73 69 6f 6e 5f 69 64 3d 73 ars.session_id=s
55d0: 65 73 73 69 6f 6e 73 2e 69 64 20 22 0a 09 09 09 essions.id "....
55e0: 09 20 20 20 20 22 57 48 45 52 45 20 73 65 73 73 . "WHERE sess
55f0: 69 6f 6e 5f 6b 65 79 3d 3f 20 41 4e 44 20 70 61 ion_key=? AND pa
5600: 67 65 3d 3f 3b 22 29 29 29 0a 09 20 20 3b 3b 20 ge=?;"))).. ;;
5610: 66 69 72 73 74 20 74 68 65 20 70 61 67 65 20 73 first the page s
5620: 70 65 63 69 66 69 63 20 76 61 72 73 0a 09 20 20 pecific vars..
5630: 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f (dbi:for-each-ro
5640: 77 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 w (lambda (tuple
5650: 29 0a 09 09 09 20 20 20 20 20 20 28 6c 65 74 20 ).... (let
5660: 28 28 6b 20 28 76 65 63 74 6f 72 2d 72 65 66 20 ((k (vector-ref
5670: 74 75 70 6c 65 20 30 29 29 0a 09 09 09 09 20 20 tuple 0)).....
5680: 20 20 28 76 20 28 76 65 63 74 6f 72 2d 72 65 66 (v (vector-ref
5690: 20 74 75 70 6c 65 20 31 29 29 29 0a 09 09 09 09 tuple 1))).....
56a0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
56b0: 20 70 61 67 65 76 61 72 73 2d 62 65 66 6f 72 65 pagevars-before
56c0: 20 6b 20 76 29 0a 09 09 09 09 28 68 61 73 68 2d k v).....(hash-
56d0: 74 61 62 6c 65 2d 73 65 74 21 20 70 61 67 65 76 table-set! pagev
56e0: 61 72 73 20 20 20 20 20 20 20 20 6b 20 76 29 29 ars k v))
56f0: 29 0a 09 09 09 20 20 20 20 63 6f 6e 6e 0a 09 09 ).... conn...
5700: 09 20 20 20 20 28 73 3a 73 71 6c 70 61 72 61 6d . (s:sqlparam
5710: 20 71 75 65 72 79 20 73 65 73 73 69 6f 6e 2d 6b query session-k
5720: 65 79 20 70 61 67 65 2d 6e 61 6d 65 29 29 0a 09 ey page-name))..
5730: 20 20 3b 3b 20 74 68 65 6e 20 74 68 65 20 73 65 ;; then the se
5740: 73 73 69 6f 6e 20 73 70 65 63 69 66 69 63 20 76 ssion specific v
5750: 61 72 73 0a 09 20 20 28 64 62 69 3a 66 6f 72 2d ars.. (dbi:for-
5760: 65 61 63 68 2d 72 6f 77 20 28 6c 61 6d 62 64 61 each-row (lambda
5770: 20 28 74 75 70 6c 65 29 0a 09 09 09 20 20 20 20 (tuple)....
5780: 20 20 28 6c 65 74 20 28 28 6b 20 28 76 65 63 74 (let ((k (vect
5790: 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 30 29 29 or-ref tuple 0))
57a0: 0a 09 09 09 09 20 20 20 20 28 76 20 28 76 65 63 ..... (v (vec
57b0: 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 31 29 tor-ref tuple 1)
57c0: 29 29 0a 09 09 09 09 28 68 61 73 68 2d 74 61 62 )).....(hash-tab
57d0: 6c 65 2d 73 65 74 21 20 73 65 73 73 69 6f 6e 76 le-set! sessionv
57e0: 61 72 73 2d 62 65 66 6f 72 65 20 6b 20 76 29 0a ars-before k v).
57f0: 09 09 09 09 28 68 61 73 68 2d 74 61 62 6c 65 2d ....(hash-table-
5800: 73 65 74 21 20 73 65 73 73 69 6f 6e 76 61 72 73 set! sessionvars
5810: 20 20 20 20 20 20 20 20 6b 20 76 29 29 29 0a 09 k v)))..
5820: 09 09 20 20 20 20 63 6f 6e 6e 0a 09 09 09 20 20 .. conn....
5830: 20 20 28 73 3a 73 71 6c 70 61 72 61 6d 20 71 75 (s:sqlparam qu
5840: 65 72 79 20 73 65 73 73 69 6f 6e 2d 6b 65 79 20 ery session-key
5850: 22 2a 73 65 73 73 69 6f 6e 76 61 72 73 2a 22 29 "*sessionvars*")
5860: 29 0a 09 20 20 3b 3b 20 61 6e 64 20 66 69 6e 61 ).. ;; and fina
5870: 6c 6c 79 20 74 68 65 20 67 6c 6f 62 61 6c 20 76 lly the global v
5880: 61 72 73 0a 09 20 20 28 64 62 69 3a 66 6f 72 2d ars.. (dbi:for-
5890: 65 61 63 68 2d 72 6f 77 20 28 6c 61 6d 62 64 61 each-row (lambda
58a0: 20 28 74 75 70 6c 65 29 0a 09 09 09 20 20 20 20 (tuple)....
58b0: 20 20 28 6c 65 74 20 28 28 6b 20 28 76 65 63 74 (let ((k (vect
58c0: 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 30 29 29 or-ref tuple 0))
58d0: 0a 09 09 09 09 20 20 20 20 28 76 20 28 76 65 63 ..... (v (vec
58e0: 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 31 29 tor-ref tuple 1)
58f0: 29 29 0a 09 09 09 09 28 68 61 73 68 2d 74 61 62 )).....(hash-tab
5900: 6c 65 2d 73 65 74 21 20 67 6c 6f 62 61 6c 76 61 le-set! globalva
5910: 72 73 2d 62 65 66 6f 72 65 20 6b 20 76 29 0a 09 rs-before k v)..
5920: 09 09 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 ...(hash-table-s
5930: 65 74 21 20 67 6c 6f 62 61 6c 76 61 72 73 20 20 et! globalvars
5940: 20 20 20 20 20 20 6b 20 76 29 29 29 0a 09 09 09 k v)))....
5950: 20 20 20 20 63 6f 6e 6e 0a 09 09 09 20 20 20 20 conn....
5960: 28 73 3a 73 71 6c 70 61 72 61 6d 20 71 75 65 72 (s:sqlparam quer
5970: 79 20 73 65 73 73 69 6f 6e 2d 6b 65 79 20 22 2a y session-key "*
5980: 67 6c 6f 62 61 6c 76 61 72 73 22 29 29 0a 09 20 globalvars"))..
5990: 20 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 ))))..(define (
59a0: 73 65 73 73 69 6f 6e 3a 73 61 76 65 2d 76 61 72 session:save-var
59b0: 73 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 20 28 s self). (let (
59c0: 28 73 65 73 73 69 6f 6e 2d 69 64 20 20 28 73 64 (session-id (sd
59d0: 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 2d 69 at-get-session-i
59e0: 64 20 73 65 6c 66 29 29 29 0a 20 20 20 20 28 69 d self))). (i
59f0: 66 20 28 6e 6f 74 20 73 65 73 73 69 6f 6e 2d 69 f (not session-i
5a00: 64 29 0a 09 28 65 72 72 3a 6c 6f 67 20 22 45 52 d)..(err:log "ER
5a10: 52 4f 52 3a 20 4e 6f 20 73 65 73 73 69 6f 6e 20 ROR: No session
5a20: 69 64 20 69 6e 20 73 65 73 73 69 6f 6e 20 6f 62 id in session ob
5a30: 6a 65 63 74 21 20 73 65 73 73 69 6f 6e 3a 67 65 ject! session:ge
5a40: 74 2d 76 61 72 73 22 29 0a 09 28 6c 65 74 2a 20 t-vars")..(let*
5a50: 28 28 73 74 61 74 75 73 20 20 20 20 20 20 23 66 ((status #f
5a60: 29 0a 09 20 20 20 20 20 20 20 28 63 6f 6e 6e 20 ).. (conn
5a70: 20 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 (sdat-get
5a80: 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 0a 09 20 20 -conn self))..
5a90: 20 20 20 20 20 28 70 61 67 65 2d 6e 61 6d 65 20 (page-name
5aa0: 20 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 (sdat-get-page
5ab0: 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 20 20 self))..
5ac0: 28 64 65 6c 2d 71 75 65 72 79 20 20 20 22 44 45 (del-query "DE
5ad0: 4c 45 54 45 20 46 52 4f 4d 20 73 65 73 73 69 6f LETE FROM sessio
5ae0: 6e 5f 76 61 72 73 20 57 48 45 52 45 20 73 65 73 n_vars WHERE ses
5af0: 73 69 6f 6e 5f 69 64 3d 3f 20 41 4e 44 20 70 61 sion_id=? AND pa
5b00: 67 65 3d 3f 20 41 4e 44 20 6b 65 79 3d 3f 3b 22 ge=? AND key=?;"
5b10: 29 0a 09 20 20 20 20 20 20 20 28 69 6e 73 2d 71 ).. (ins-q
5b20: 75 65 72 79 20 20 20 22 49 4e 53 45 52 54 20 49 uery "INSERT I
5b30: 4e 54 4f 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 NTO session_vars
5b40: 20 28 73 65 73 73 69 6f 6e 5f 69 64 2c 70 61 67 (session_id,pag
5b50: 65 2c 6b 65 79 2c 76 61 6c 75 65 29 20 56 41 4c e,key,value) VAL
5b60: 55 45 53 28 3f 2c 3f 2c 3f 2c 3f 29 3b 22 29 0a UES(?,?,?,?);").
5b70: 09 20 20 20 20 20 20 20 28 75 70 64 2d 71 75 65 . (upd-que
5b80: 72 79 20 20 20 22 55 50 44 41 54 45 20 73 65 73 ry "UPDATE ses
5b90: 73 69 6f 6e 5f 76 61 72 73 20 73 65 74 20 76 61 sion_vars set va
5ba0: 6c 75 65 3d 3f 20 57 48 45 52 45 20 6b 65 79 3d lue=? WHERE key=
5bb0: 3f 20 41 4e 44 20 73 65 73 73 69 6f 6e 5f 69 64 ? AND session_id
5bc0: 3d 3f 20 41 4e 44 20 70 61 67 65 3d 3f 3b 22 29 =? AND page=?;")
5bd0: 0a 09 20 20 20 20 20 20 20 28 63 68 61 6e 67 65 .. (change
5be0: 64 2d 63 6f 75 6e 74 20 30 29 29 0a 09 20 20 3b d-count 0)).. ;
5bf0: 3b 20 73 61 76 65 20 74 68 65 20 64 65 6c 74 61 ; save the delta
5c00: 20 6f 6e 6c 79 0a 09 20 20 28 66 6f 72 2d 65 61 only.. (for-ea
5c10: 63 68 0a 09 20 20 20 28 6c 61 6d 62 64 61 20 28 ch.. (lambda (
5c20: 70 61 67 65 29 20 3b 3b 20 70 61 67 65 20 69 73 page) ;; page is
5c30: 3a 20 22 2a 67 6c 6f 62 61 6c 76 61 72 73 2a 22 : "*globalvars*"
5c40: 20 22 2a 73 65 73 73 69 6f 6e 76 61 72 73 2a 22 "*sessionvars*"
5c50: 20 6f 72 20 6f 74 68 65 72 73 74 72 69 6e 67 0a or otherstring.
5c60: 09 20 20 20 20 20 28 6c 65 74 2a 20 28 28 62 65 . (let* ((be
5c70: 66 6f 72 65 2d 61 66 74 65 72 2d 68 74 20 28 63 fore-after-ht (c
5c80: 6f 6e 64 0a 09 09 09 09 20 20 20 20 20 20 28 28 ond..... ((
5c90: 73 74 72 69 6e 67 3d 3f 20 70 61 67 65 20 22 2a string=? page "*
5ca0: 73 65 73 73 69 6f 6e 76 61 72 73 2a 22 29 0a 09 sessionvars*")..
5cb0: 09 09 09 20 20 20 20 20 20 20 28 76 65 63 74 6f ... (vecto
5cc0: 72 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 r (sdat-get-sess
5cd0: 69 6f 6e 76 61 72 73 20 73 65 6c 66 29 0a 09 09 ionvars self)...
5ce0: 09 09 09 20 20 20 20 20 20 20 28 73 64 61 74 2d ... (sdat-
5cf0: 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 2d get-sessionvars-
5d00: 62 65 66 6f 72 65 20 73 65 6c 66 29 29 29 0a 09 before self)))..
5d10: 09 09 09 20 20 20 20 20 20 20 28 28 73 74 72 69 ... ((stri
5d20: 6e 67 3d 3f 20 70 61 67 65 20 22 2a 67 6c 6f 62 ng=? page "*glob
5d30: 61 6c 76 61 72 73 2a 22 29 0a 09 09 09 09 09 28 alvars*")......(
5d40: 76 65 63 74 6f 72 20 28 73 64 61 74 2d 67 65 74 vector (sdat-get
5d50: 2d 67 6c 6f 62 61 6c 76 61 72 73 20 73 65 6c 66 -globalvars self
5d60: 29 0a 09 09 09 09 09 09 28 73 64 61 74 2d 67 65 ).......(sdat-ge
5d70: 74 2d 67 6c 6f 62 61 6c 76 61 72 73 2d 62 65 66 t-globalvars-bef
5d80: 6f 72 65 20 73 65 6c 66 29 29 29 0a 09 09 09 09 ore self))).....
5d90: 20 20 20 20 20 20 20 28 65 6c 73 65 20 0a 09 09 (else ...
5da0: 09 09 09 28 76 65 63 74 6f 72 20 28 73 64 61 74 ...(vector (sdat
5db0: 2d 67 65 74 2d 70 61 67 65 76 61 72 73 20 73 65 -get-pagevars se
5dc0: 6c 66 29 0a 09 09 09 09 09 09 28 73 64 61 74 2d lf).......(sdat-
5dd0: 67 65 74 2d 70 61 67 65 76 61 72 73 2d 62 65 66 get-pagevars-bef
5de0: 6f 72 65 20 73 65 6c 66 29 29 29 29 29 0a 09 09 ore self)))))...
5df0: 20 20 20 20 28 6d 61 73 74 65 72 2d 68 74 20 20 (master-ht
5e00: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 62 65 66 (vector-ref bef
5e10: 6f 72 65 2d 61 66 74 65 72 2d 68 74 20 30 29 29 ore-after-ht 0))
5e20: 0a 09 09 20 20 20 20 28 62 65 66 6f 72 65 2d 68 ... (before-h
5e30: 74 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 t (vector-ref
5e40: 62 65 66 6f 72 65 2d 61 66 74 65 72 2d 68 74 20 before-after-ht
5e50: 31 29 29 0a 09 09 20 20 20 20 28 6d 61 73 74 65 1))... (maste
5e60: 72 2d 6b 65 79 73 20 28 68 61 73 68 2d 74 61 62 r-keys (hash-tab
5e70: 6c 65 2d 6b 65 79 73 20 6d 61 73 74 65 72 2d 68 le-keys master-h
5e80: 74 29 29 0a 09 09 20 20 20 20 28 62 65 66 6f 72 t))... (befor
5e90: 65 2d 6b 65 79 73 20 28 68 61 73 68 2d 74 61 62 e-keys (hash-tab
5ea0: 6c 65 2d 6b 65 79 73 20 62 65 66 6f 72 65 2d 68 le-keys before-h
5eb0: 74 29 29 0a 09 09 20 20 20 20 28 61 6c 6c 2d 6b t))... (all-k
5ec0: 65 79 73 20 28 64 65 6c 65 74 65 2d 64 75 70 6c eys (delete-dupl
5ed0: 69 63 61 74 65 73 20 28 61 70 70 65 6e 64 20 6d icates (append m
5ee0: 61 73 74 65 72 2d 6b 65 79 73 20 62 65 66 6f 72 aster-keys befor
5ef0: 65 2d 6b 65 79 73 29 29 29 29 0a 09 20 20 20 20 e-keys))))..
5f00: 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 09 09 (for-each ...
5f10: 28 6c 61 6d 62 64 61 20 28 6b 65 79 29 0a 09 09 (lambda (key)...
5f20: 20 20 28 6c 65 74 20 28 28 6d 61 73 74 65 72 2d (let ((master-
5f30: 76 61 6c 75 65 20 28 68 61 73 68 2d 74 61 62 6c value (hash-tabl
5f40: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 6d 61 e-ref/default ma
5f50: 73 74 65 72 2d 68 74 20 6b 65 79 20 23 66 29 29 ster-ht key #f))
5f60: 0a 09 09 09 28 62 65 66 6f 72 65 2d 76 61 6c 75 ....(before-valu
5f70: 65 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 e (hash-table-re
5f80: 66 2f 64 65 66 61 75 6c 74 20 62 65 66 6f 72 65 f/default before
5f90: 2d 68 74 20 6b 65 79 20 23 66 29 29 29 0a 09 09 -ht key #f)))...
5fa0: 20 20 20 20 28 63 6f 6e 64 0a 09 09 20 20 20 20 (cond...
5fb0: 20 3b 3b 20 62 65 66 6f 72 65 20 61 6e 64 20 61 ;; before and a
5fc0: 66 74 65 72 20 65 78 69 73 74 20 61 6e 64 20 76 fter exist and v
5fd0: 61 6c 75 65 20 75 6e 63 68 61 6e 67 65 64 20 2d alue unchanged -
5fe0: 20 64 6f 20 6e 6f 74 68 69 6e 67 0a 09 09 20 20 do nothing...
5ff0: 20 20 20 28 28 61 6e 64 20 6d 61 73 74 65 72 2d ((and master-
6000: 76 61 6c 75 65 20 62 65 66 6f 72 65 2d 76 61 6c value before-val
6010: 75 65 20 28 65 71 75 61 6c 3f 20 6d 61 73 74 65 ue (equal? maste
6020: 72 2d 76 61 6c 75 65 20 62 65 66 6f 72 65 2d 76 r-value before-v
6030: 61 6c 75 65 29 29 29 0a 09 09 20 20 20 20 20 3b alue)))... ;
6040: 3b 20 62 65 66 6f 72 65 20 61 6e 64 20 61 66 74 ; before and aft
6050: 65 72 20 65 78 69 73 74 20 62 75 74 20 61 72 65 er exist but are
6060: 20 63 68 61 6e 67 65 64 0a 09 09 20 20 20 20 20 changed...
6070: 28 28 61 6e 64 20 6d 61 73 74 65 72 2d 76 61 6c ((and master-val
6080: 75 65 20 62 65 66 6f 72 65 2d 76 61 6c 75 65 29 ue before-value)
6090: 0a 09 09 20 20 20 20 20 20 28 64 62 69 3a 66 6f ... (dbi:fo
60a0: 72 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 6d 62 r-each-row (lamb
60b0: 64 61 20 28 74 75 70 6c 65 29 0a 09 09 09 09 09 da (tuple)......
60c0: 20 20 28 73 65 74 21 20 63 68 61 6e 67 65 64 2d (set! changed-
60d0: 63 6f 75 6e 74 20 28 2b 20 63 68 61 6e 67 65 64 count (+ changed
60e0: 2d 63 6f 75 6e 74 20 31 29 29 29 0a 09 09 09 09 -count 1))).....
60f0: 09 63 6f 6e 6e 0a 09 09 09 09 09 28 73 3a 73 71 .conn......(s:sq
6100: 6c 70 61 72 61 6d 20 75 70 64 2d 71 75 65 72 79 lparam upd-query
6110: 20 6d 61 73 74 65 72 2d 76 61 6c 75 65 20 6b 65 master-value ke
6120: 79 20 73 65 73 73 69 6f 6e 2d 69 64 20 70 61 67 y session-id pag
6130: 65 29 29 29 0a 09 09 20 20 20 20 20 3b 3b 20 6d e)))... ;; m
6140: 61 73 74 65 72 2d 76 61 6c 75 65 20 6e 6f 20 6c aster-value no l
6150: 6f 6e 67 65 72 20 65 78 69 73 74 73 20 28 69 2e onger exists (i.
6160: 65 2e 20 23 66 29 20 2d 20 72 65 6d 6f 76 65 20 e. #f) - remove
6170: 69 74 65 6d 0a 09 09 20 20 20 20 20 28 28 6e 6f item... ((no
6180: 74 20 6d 61 73 74 65 72 2d 76 61 6c 75 65 29 0a t master-value).
6190: 09 09 20 20 20 20 20 20 28 64 62 69 3a 66 6f 72 .. (dbi:for
61a0: 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 6d 62 64 -each-row (lambd
61b0: 61 20 28 74 75 70 6c 65 29 0a 09 09 09 09 09 20 a (tuple)......
61c0: 20 28 73 65 74 21 20 63 68 61 6e 67 65 64 2d 63 (set! changed-c
61d0: 6f 75 6e 74 20 28 2b 20 63 68 61 6e 67 65 64 2d ount (+ changed-
61e0: 63 6f 75 6e 74 20 31 29 29 29 0a 09 09 09 09 09 count 1)))......
61f0: 63 6f 6e 6e 0a 09 09 09 09 09 28 73 3a 73 71 6c conn......(s:sql
6200: 70 61 72 61 6d 20 64 65 6c 2d 71 75 65 72 79 20 param del-query
6210: 73 65 73 73 69 6f 6e 2d 69 64 20 70 61 67 65 20 session-id page
6220: 6b 65 79 29 29 29 0a 09 09 20 20 20 20 20 3b 3b key)))... ;;
6230: 20 62 65 66 6f 72 65 2d 76 61 6c 75 65 20 64 6f before-value do
6240: 65 73 6e 27 74 20 65 78 69 73 74 20 2d 20 69 6e esn't exist - in
6250: 73 65 72 74 20 61 20 6e 65 77 20 76 61 6c 75 65 sert a new value
6260: 0a 09 09 20 20 20 20 20 28 28 6e 6f 74 20 62 65 ... ((not be
6270: 66 6f 72 65 2d 76 61 6c 75 65 29 0a 09 09 20 20 fore-value)...
6280: 20 20 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 (dbi:for-eac
6290: 68 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 h-row (lambda (t
62a0: 75 70 6c 65 29 0a 09 09 09 09 09 20 20 28 73 65 uple)...... (se
62b0: 74 21 20 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 t! changed-count
62c0: 20 28 2b 20 63 68 61 6e 67 65 64 2d 63 6f 75 6e (+ changed-coun
62d0: 74 20 31 29 29 29 0a 09 09 09 09 09 63 6f 6e 6e t 1)))......conn
62e0: 0a 09 09 09 09 09 28 73 3a 73 71 6c 70 61 72 61 ......(s:sqlpara
62f0: 6d 20 69 6e 73 2d 71 75 65 72 79 20 73 65 73 73 m ins-query sess
6300: 69 6f 6e 2d 69 64 20 70 61 67 65 20 6b 65 79 20 ion-id page key
6310: 6d 61 73 74 65 72 2d 76 61 6c 75 65 29 29 29 0a master-value))).
6320: 09 09 20 20 20 20 20 28 65 6c 73 65 20 28 65 72 .. (else (er
6330: 72 3a 6c 6f 67 20 22 53 68 6f 75 6c 64 6e 27 74 r:log "Shouldn't
6340: 20 67 65 74 20 68 65 72 65 22 29 29 29 29 29 0a get here"))))).
6350: 09 09 61 6c 6c 2d 6b 65 79 73 29 29 29 20 3b 3b ..all-keys))) ;;
6360: 20 70 72 6f 63 65 73 73 20 61 6c 6c 20 6b 65 79 process all key
6370: 73 0a 09 20 20 20 28 6c 69 73 74 20 22 2a 73 65 s.. (list "*se
6380: 73 73 69 6f 6e 76 61 72 73 2a 22 20 22 2a 67 6c ssionvars*" "*gl
6390: 6f 62 61 6c 76 61 72 73 2a 22 20 70 61 67 65 2d obalvars*" page-
63a0: 6e 61 6d 65 29 29 29 29 29 29 0a 0a 3b 3b 20 28 name))))))..;; (
63b0: 70 67 3a 73 71 6c 2d 6e 75 6c 6c 2d 6f 62 6a 65 pg:sql-null-obje
63c0: 63 74 3f 20 65 6c 65 6d 65 6e 74 29 0a 28 64 65 ct? element).(de
63d0: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 72 65 fine (session:re
63e0: 61 64 2d 63 6f 6e 66 69 67 20 73 65 6c 66 29 0a ad-config self).
63f0: 20 20 28 6c 65 74 2a 20 28 28 63 67 69 2d 70 61 (let* ((cgi-pa
6400: 74 68 20 28 70 61 74 68 6e 61 6d 65 2d 64 69 72 th (pathname-dir
6410: 65 63 74 6f 72 79 20 28 63 61 72 20 28 61 72 67 ectory (car (arg
6420: 76 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 v)))). (
6430: 6e 61 6d 65 20 20 20 20 20 28 73 74 72 69 6e 67 name (string
6440: 2d 61 70 70 65 6e 64 20 28 69 66 20 63 67 69 2d -append (if cgi-
6450: 70 61 74 68 20 28 63 6f 6e 63 20 63 67 69 2d 70 path (conc cgi-p
6460: 61 74 68 20 22 2f 22 29 20 22 22 29 20 22 2e 22 ath "/") "") "."
6470: 20 28 70 61 74 68 6e 61 6d 65 2d 66 69 6c 65 20 (pathname-file
6480: 28 63 61 72 20 28 61 72 67 76 29 29 29 20 22 2e (car (argv))) ".
6490: 63 6f 6e 66 69 67 22 29 29 29 0a 20 20 20 20 28 config"))). (
64a0: 69 66 20 28 6e 6f 74 20 28 66 69 6c 65 2d 65 78 if (not (file-ex
64b0: 69 73 74 73 3f 20 6e 61 6d 65 29 29 0a 09 28 70 ists? name))..(p
64c0: 72 69 6e 74 20 6e 61 6d 65 20 22 20 6e 6f 74 20 rint name " not
64d0: 66 6f 75 6e 64 20 61 74 20 22 20 28 63 75 72 72 found at " (curr
64e0: 65 6e 74 2d 64 69 72 65 63 74 6f 72 79 29 29 0a ent-directory)).
64f0: 09 28 6c 65 74 2a 20 28 28 66 70 20 28 6f 70 65 .(let* ((fp (ope
6500: 6e 2d 69 6e 70 75 74 2d 66 69 6c 65 20 6e 61 6d n-input-file nam
6510: 65 29 29 0a 09 20 20 20 20 20 20 20 28 69 6e 69 e)).. (ini
6520: 74 61 72 67 73 20 28 72 65 61 64 20 66 70 29 29 targs (read fp))
6530: 29 0a 09 20 20 28 63 6c 6f 73 65 2d 69 6e 70 75 ).. (close-inpu
6540: 74 2d 70 6f 72 74 20 66 70 29 0a 09 20 20 69 6e t-port fp).. in
6550: 69 74 61 72 67 73 29 29 29 29 0a 0a 3b 3b 20 63 itargs))))..;; c
6560: 61 6c 6c 20 74 68 65 20 63 6f 6e 74 72 6f 6c 6c all the controll
6570: 65 72 20 69 66 20 69 74 20 65 78 69 73 74 73 0a er if it exists.
6580: 3b 3b 20 0a 3b 3b 20 57 41 52 4e 49 4e 47 20 2d ;; .;; WARNING -
6590: 20 74 68 69 73 20 63 6f 64 65 20 6e 65 65 64 73 this code needs
65a0: 20 61 20 64 65 66 65 6e 63 65 20 61 67 61 69 6e a defence again
65b0: 73 20 72 65 63 75 72 73 69 76 65 20 63 61 6c 6c s recursive call
65c0: 69 6e 67 21 21 21 21 21 0a 3b 3b 0a 3b 3b 20 20 ing!!!!!.;;.;;
65d0: 20 49 20 73 75 67 67 65 73 74 20 61 20 6c 69 6d I suggest a lim
65e0: 69 74 20 6f 66 20 31 30 30 20 63 61 6c 6c 73 2e it of 100 calls.
65f0: 20 50 6c 65 6e 74 79 20 66 6f 72 20 61 6c 6c 6f Plenty for allo
6600: 77 69 6e 67 20 6d 75 6c 74 69 70 6c 65 20 69 6e wing multiple in
6610: 73 74 61 6e 63 65 73 0a 3b 3b 20 20 20 6f 66 20 stances.;; of
6620: 61 20 70 61 67 65 20 69 6e 73 69 64 65 20 61 6e a page inside an
6630: 6f 74 68 65 72 20 70 61 67 65 2e 20 0a 3b 3b 0a other page. .;;.
6640: 3b 3b 20 70 61 72 74 73 20 3d 20 27 62 6f 74 68 ;; parts = 'both
6650: 20 7c 20 27 63 6f 6e 74 72 6f 6c 20 7c 20 27 76 | 'control | 'v
6660: 69 65 77 0a 3b 3b 0a 0a 28 64 65 66 69 6e 65 20 iew.;;..(define
6670: 28 66 69 6c 65 73 2d 72 65 61 64 2d 3e 73 74 72 (files-read->str
6680: 69 6e 67 20 2e 20 66 69 6c 65 73 29 0a 20 20 28 ing . files). (
6690: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
66a0: 73 65 20 0a 20 20 20 28 61 70 70 6c 79 20 61 70 se . (apply ap
66b0: 70 65 6e 64 20 28 6d 61 70 20 66 69 6c 65 2d 72 pend (map file-r
66c0: 65 61 64 2d 3e 73 74 72 69 6e 67 20 66 69 6c 65 ead->string file
66d0: 73 29 29 20 22 5c 6e 22 29 29 0a 0a 28 64 65 66 s)) "\n"))..(def
66e0: 69 6e 65 20 28 66 69 6c 65 2d 72 65 61 64 2d 3e ine (file-read->
66f0: 73 74 72 69 6e 67 20 66 29 20 0a 20 20 28 6c 65 string f) . (le
6700: 74 20 28 28 70 20 28 6f 70 65 6e 2d 69 6e 70 75 t ((p (open-inpu
6710: 74 2d 66 69 6c 65 20 66 29 29 29 0a 20 20 20 20 t-file f))).
6720: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 (let loop ((hed
6730: 28 72 65 61 64 2d 6c 69 6e 65 20 70 29 29 0a 09 (read-line p))..
6740: 20 20 20 20 20 20 20 28 72 65 73 20 27 28 29 29 (res '())
6750: 29 0a 20 20 20 20 20 20 28 69 66 20 28 65 6f 66 ). (if (eof
6760: 2d 6f 62 6a 65 63 74 3f 20 68 65 64 29 0a 09 20 -object? hed)..
6770: 20 72 65 73 0a 09 20 20 28 6c 6f 6f 70 20 28 72 res.. (loop (r
6780: 65 61 64 2d 6c 69 6e 65 20 70 29 28 61 70 70 65 ead-line p)(appe
6790: 6e 64 20 72 65 73 20 28 6c 69 73 74 20 68 65 64 nd res (list hed
67a0: 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 )))))))..(define
67b0: 20 28 70 72 6f 63 65 73 73 2d 70 6f 72 74 20 70 (process-port p
67c0: 29 0a 20 20 28 6c 65 74 20 28 28 65 20 28 69 6e ). (let ((e (in
67d0: 74 65 72 61 63 74 69 6f 6e 2d 65 6e 76 69 72 6f teraction-enviro
67e0: 6e 6d 65 6e 74 29 29 29 0a 20 20 20 20 28 6d 61 nment))). (ma
67f0: 70 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 p . (lambda
6800: 28 78 29 0a 20 20 20 20 20 20 20 28 63 6f 6e 64 (x). (cond
6810: 0a 09 28 28 6c 69 73 74 3f 20 78 29 20 78 29 0a ..((list? x) x).
6820: 09 28 28 73 74 72 69 6e 67 3f 20 78 29 20 78 29 .((string? x) x)
6830: 0a 09 28 65 6c 73 65 20 27 28 29 29 29 29 0a 20 ..(else '()))).
6840: 20 20 20 20 28 70 6f 72 74 2d 6d 61 70 20 28 6c (port-map (l
6850: 61 6d 62 64 61 20 28 73 29 0a 09 09 20 28 65 76 ambda (s)... (ev
6860: 61 6c 20 73 20 65 29 29 0a 09 20 20 20 20 20 20 al s e))..
6870: 20 28 6c 61 6d 62 64 61 20 28 29 28 72 65 61 64 (lambda ()(read
6880: 20 70 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e p))))))..(defin
6890: 65 20 28 73 65 73 73 69 6f 6e 3a 70 72 6f 63 65 e (session:proce
68a0: 73 73 2d 66 69 6c 65 20 66 29 0a 20 20 28 6c 65 ss-file f). (le
68b0: 74 2a 20 28 28 70 20 20 20 20 28 6f 70 65 6e 2d t* ((p (open-
68c0: 69 6e 70 75 74 2d 66 69 6c 65 20 66 29 29 0a 09 input-file f))..
68d0: 20 28 64 61 74 20 20 28 70 72 6f 63 65 73 73 2d (dat (process-
68e0: 70 6f 72 74 20 70 29 29 29 0a 20 20 20 20 28 63 port p))). (c
68f0: 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 6f 72 74 20 lose-input-port
6900: 70 29 0a 20 20 20 20 64 61 74 29 29 0a 0a 3b 3b p). dat))..;;
6910: 20 4d 61 79 20 32 30 31 31 2c 20 70 75 74 74 69 May 2011, putti
6920: 6e 67 20 61 6c 6c 20 70 61 67 65 73 20 69 6e 74 ng all pages int
6930: 6f 20 6f 6e 65 20 64 69 72 65 63 74 6f 72 79 20 o one directory
6940: 66 6f 72 20 74 68 65 20 66 6f 6c 6c 6f 77 69 6e for the followin
6950: 67 20 72 65 61 73 6f 6e 73 3a 0a 3b 3b 20 20 20 g reasons:.;;
6960: 31 2e 20 77 61 6e 74 20 66 69 6c 65 6e 61 6d 65 1. want filename
6970: 20 74 6f 20 72 65 66 6c 65 63 74 20 70 61 67 65 to reflect page
6980: 20 6e 61 6d 65 20 28 65 6d 61 63 73 20 6c 69 6d name (emacs lim
6990: 69 74 61 74 69 6f 6e 29 0a 3b 3b 20 20 20 32 2e itation).;; 2.
69a0: 20 74 68 61 74 27 73 20 69 74 21 20 6e 6f 20 6f that's it! no o
69b0: 74 68 65 72 20 72 65 61 73 6f 6e 2e 20 63 6f 75 ther reason. cou
69c0: 6c 64 20 6d 61 6b 65 20 69 74 20 63 6f 6e 66 69 ld make it confi
69d0: 67 75 72 61 62 6c 65 20 2e 2e 2e 0a 3b 3b 20 70 gurable ....;; p
69e0: 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 20 69 73 age-dir-style is
69f0: 3a 0a 3b 3b 20 20 27 73 74 6f 72 65 64 20 20 20 :.;; 'stored
6a00: 3d 3e 20 73 74 6f 72 65 64 20 69 6e 20 65 78 65 => stored in exe
6a10: 63 75 74 61 62 6c 65 0a 3b 3b 20 20 27 66 6c 61 cutable.;; 'fla
6a20: 74 20 20 20 20 20 3d 3e 20 70 61 67 65 73 20 66 t => pages f
6a30: 6c 61 74 20 64 69 72 65 63 74 6f 72 79 0a 3b 3b lat directory.;;
6a40: 20 20 27 64 69 72 20 20 20 20 20 20 3d 3e 20 64 'dir => d
6a50: 69 72 65 63 74 6f 72 79 20 74 72 65 65 20 70 61 irectory tree pa
6a60: 67 65 73 2f 3c 70 61 67 65 6e 61 6d 65 3e 2f 7b ges/<pagename>/{
6a70: 76 69 65 77 2c 63 6f 6e 74 72 6f 6c 7d 2e 73 63 view,control}.sc
6a80: 6d 0a 3b 3b 20 70 61 72 74 73 3a 0a 3b 3b 20 20 m.;; parts:.;;
6a90: 27 62 6f 74 68 20 20 20 20 20 3d 3e 20 6c 6f 61 'both => loa
6aa0: 64 20 63 6f 6e 74 72 6f 6c 20 61 6e 64 20 76 69 d control and vi
6ab0: 65 77 20 28 61 6e 79 74 68 69 6e 67 20 6f 74 68 ew (anything oth
6ac0: 65 72 20 74 68 61 6e 20 76 69 65 77 20 6f 72 20 er than view or
6ad0: 63 6f 6e 74 72 6f 6c 20 61 6e 64 20 74 68 65 20 control and the
6ae0: 64 65 66 61 75 6c 74 29 0a 3b 3b 20 20 27 76 69 default).;; 'vi
6af0: 65 77 20 20 20 20 20 3d 3e 20 6c 6f 61 64 20 76 ew => load v
6b00: 69 65 77 20 6f 6e 6c 79 0a 3b 3b 20 20 27 63 6f iew only.;; 'co
6b10: 6e 74 72 6f 6c 20 20 3d 3e 20 6c 6f 61 64 20 63 ntrol => load c
6b20: 6f 6e 74 72 6f 6c 20 6f 6e 6c 79 0a 28 64 65 66 ontrol only.(def
6b30: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 63 61 6c ine (session:cal
6b40: 6c 2d 70 61 72 74 73 20 73 65 6c 66 20 70 61 67 l-parts self pag
6b50: 65 20 23 21 6b 65 79 20 28 70 61 72 74 73 20 27 e #!key (parts '
6b60: 62 6f 74 68 29 29 0a 20 20 28 73 64 61 74 2d 73 both)). (sdat-s
6b70: 65 74 2d 63 75 72 72 2d 70 61 67 65 21 20 73 65 et-curr-page! se
6b80: 6c 66 20 70 61 67 65 29 0a 20 20 28 6c 65 74 2a lf page). (let*
6b90: 20 28 28 64 69 72 2d 73 74 79 6c 65 20 20 20 20 ((dir-style
6ba0: 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 2d 64 (sdat-get-page-d
6bb0: 69 72 2d 73 74 79 6c 65 20 73 65 6c 66 29 29 3b ir-style self));
6bc0: 3b 20 28 65 71 75 61 6c 3f 20 28 73 64 61 74 2d ; (equal? (sdat-
6bd0: 67 65 74 2d 70 61 67 65 2d 64 69 72 2d 73 74 79 get-page-dir-sty
6be0: 6c 65 20 73 65 6c 66 29 20 22 6f 6e 65 64 69 72 le self) "onedir
6bf0: 22 29 29 20 3b 3b 20 66 6c 61 67 20 23 74 20 66 ")) ;; flag #t f
6c00: 6f 72 20 6f 6e 65 64 69 72 2c 20 23 66 20 66 6f or onedir, #f fo
6c10: 72 20 6f 6c 64 20 73 74 79 6c 65 0a 09 20 28 64 r old style.. (d
6c20: 69 72 20 20 20 20 20 20 20 20 20 20 28 73 74 72 ir (str
6c30: 69 6e 67 2d 61 70 70 65 6e 64 20 28 73 64 61 74 ing-append (sdat
6c40: 2d 67 65 74 2d 73 72 6f 6f 74 20 73 65 6c 66 29 -get-sroot self)
6c50: 20 0a 09 09 09 09 20 20 20 20 20 20 28 69 66 20 ..... (if
6c60: 64 69 72 2d 73 74 79 6c 65 20 0a 09 09 09 09 09 dir-style ......
6c70: 20 20 28 63 6f 6e 63 20 22 2f 70 61 67 65 73 2f (conc "/pages/
6c80: 22 29 0a 09 09 09 09 09 20 20 28 63 6f 6e 63 20 ")...... (conc
6c90: 22 2f 70 61 67 65 73 2f 22 20 70 61 67 65 29 29 "/pages/" page))
6ca0: 29 29 29 0a 20 20 20 20 28 63 61 73 65 20 64 69 ))). (case di
6cb0: 72 2d 73 74 79 6c 65 0a 20 20 20 20 20 20 3b 3b r-style. ;;
6cc0: 20 4e 42 2f 2f 20 53 74 6f 72 65 64 20 61 6c 77 NB// Stored alw
6cd0: 61 79 73 20 6c 6f 61 64 73 20 62 6f 74 68 20 63 ays loads both c
6ce0: 6f 6e 74 72 6f 6c 20 61 6e 64 20 76 69 65 77 0a ontrol and view.
6cf0: 20 20 20 20 20 20 28 28 73 74 6f 72 65 64 29 0a ((stored).
6d00: 20 20 20 20 20 20 20 28 28 65 76 61 6c 20 28 73 ((eval (s
6d10: 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 63 tring->symbol (c
6d20: 6f 6e 63 20 22 70 61 67 65 73 3a 22 20 70 61 67 onc "pages:" pag
6d30: 65 29 29 29 20 0a 09 73 65 6c 66 20 20 20 20 20 e))) ..self
6d40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6d50: 20 20 20 20 3b 3b 20 74 68 65 20 73 65 73 73 69 ;; the sessi
6d60: 6f 6e 0a 09 28 73 64 61 74 2d 67 65 74 2d 63 6f on..(sdat-get-co
6d70: 6e 6e 20 73 65 6c 66 29 20 20 20 20 20 20 20 20 nn self)
6d80: 20 3b 3b 20 74 68 65 20 64 62 20 63 6f 6e 6e 65 ;; the db conne
6d90: 63 74 69 6f 6e 0a 09 28 73 64 61 74 2d 67 65 74 ction..(sdat-get
6da0: 2d 73 68 61 72 65 64 2d 68 61 73 68 20 73 65 6c -shared-hash sel
6db0: 66 29 20 20 3b 3b 20 61 20 73 68 61 72 65 64 20 f) ;; a shared
6dc0: 68 61 73 68 20 74 61 62 6c 65 20 66 6f 72 20 70 hash table for p
6dd0: 61 73 73 69 6e 67 20 64 61 74 61 20 74 6f 2f 66 assing data to/f
6de0: 72 6f 6d 20 70 61 67 65 20 63 61 6c 6c 73 0a 09 rom page calls..
6df0: 29 29 0a 20 20 20 20 20 20 28 28 66 6c 61 74 29 )). ((flat)
6e00: 20 20 20 0a 20 20 20 20 20 20 20 28 6c 65 74 2a . (let*
6e10: 20 28 28 73 6f 2d 66 69 6c 65 20 20 28 63 6f 6e ((so-file (con
6e20: 63 20 64 69 72 20 70 61 67 65 20 22 2e 73 6f 22 c dir page ".so"
6e30: 29 29 0a 09 20 20 20 20 20 20 28 73 63 6d 2d 66 )).. (scm-f
6e40: 69 6c 65 20 28 63 6f 6e 63 20 64 69 72 20 70 61 ile (conc dir pa
6e50: 67 65 20 22 2e 73 63 6d 22 29 29 0a 09 20 20 20 ge ".scm"))..
6e60: 20 20 20 28 73 72 63 2d 66 69 6c 65 20 28 6f 72 (src-file (or
6e70: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 73 (file-exists? s
6e80: 6f 2d 66 69 6c 65 29 0a 09 09 09 20 20 20 20 28 o-file).... (
6e90: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 73 63 6d file-exists? scm
6ea0: 2d 66 69 6c 65 29 29 29 29 0a 09 20 28 69 66 20 -file)))).. (if
6eb0: 73 72 63 2d 66 69 6c 65 0a 09 20 20 20 20 20 28 src-file.. (
6ec0: 62 65 67 69 6e 0a 09 20 20 20 20 20 20 20 28 6c begin.. (l
6ed0: 6f 61 64 20 73 72 63 2d 66 69 6c 65 29 0a 09 20 oad src-file)..
6ee0: 20 20 20 20 20 20 28 28 65 76 61 6c 20 28 73 74 ((eval (st
6ef0: 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 63 6f ring->symbol (co
6f00: 6e 63 20 22 70 61 67 65 73 3a 22 20 70 61 67 65 nc "pages:" page
6f10: 29 29 29 20 0a 09 09 73 65 6c 66 20 20 20 20 20 ))) ...self
6f20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6f30: 20 20 20 20 3b 3b 20 74 68 65 20 73 65 73 73 69 ;; the sessi
6f40: 6f 6e 0a 09 09 28 73 64 61 74 2d 67 65 74 2d 63 on...(sdat-get-c
6f50: 6f 6e 6e 20 73 65 6c 66 29 20 20 20 20 20 20 20 onn self)
6f60: 20 20 3b 3b 20 74 68 65 20 64 62 20 63 6f 6e 6e ;; the db conn
6f70: 65 63 74 69 6f 6e 0a 09 09 28 73 64 61 74 2d 67 ection...(sdat-g
6f80: 65 74 2d 73 68 61 72 65 64 2d 68 61 73 68 20 73 et-shared-hash s
6f90: 65 6c 66 29 20 20 3b 3b 20 61 20 73 68 61 72 65 elf) ;; a share
6fa0: 64 20 68 61 73 68 20 74 61 62 6c 65 20 66 6f 72 d hash table for
6fb0: 20 70 61 73 73 69 6e 67 20 64 61 74 61 20 74 6f passing data to
6fc0: 2f 66 72 6f 6d 20 70 61 67 65 20 63 61 6c 6c 73 /from page calls
6fd0: 0a 09 09 29 29 0a 09 20 20 20 20 20 28 6c 69 73 ...)).. (lis
6fe0: 74 20 22 3c 70 3e 50 61 67 65 20 6e 6f 74 20 66 t "<p>Page not f
6ff0: 6f 75 6e 64 20 22 20 70 61 67 65 20 22 20 3c 2f ound " page " </
7000: 70 3e 22 29 29 29 29 0a 20 20 20 20 20 20 20 3b p>")))). ;
7010: 3b 20 66 69 72 73 74 20 74 68 65 20 63 6f 6e 74 ; first the cont
7020: 72 6f 6c 0a 20 20 20 20 20 20 20 3b 3b 20 28 6c rol. ;; (l
7030: 65 74 20 28 28 63 6f 6e 74 72 6f 6c 2d 66 69 6c et ((control-fil
7040: 65 20 28 63 6f 6e 63 20 22 70 61 67 65 73 2f 22 e (conc "pages/"
7050: 20 70 61 67 65 20 22 5f 63 74 72 6c 2e 73 63 6d page "_ctrl.scm
7060: 22 29 29 0a 20 20 20 20 20 20 20 3b 3b 20 20 20 ")). ;;
7070: 20 20 20 20 28 76 69 65 77 2d 66 69 6c 65 20 20 (view-file
7080: 20 20 28 63 6f 6e 63 20 22 70 61 67 65 73 2f 22 (conc "pages/"
7090: 20 70 61 67 65 20 22 5f 76 69 65 77 2e 73 63 6d page "_view.scm
70a0: 22 29 29 29 0a 20 20 20 20 20 20 20 3b 3b 20 20 "))). ;;
70b0: 20 28 69 66 20 28 61 6e 64 20 28 66 69 6c 65 2d (if (and (file-
70c0: 65 78 69 73 74 73 3f 20 63 6f 6e 74 72 6f 6c 2d exists? control-
70d0: 66 69 6c 65 29 0a 20 20 20 20 20 20 20 3b 3b 20 file). ;;
70e0: 20 09 20 20 28 6e 6f 74 20 28 65 71 3f 20 70 61 . (not (eq? pa
70f0: 72 74 73 20 27 76 69 65 77 29 29 29 0a 20 20 20 rts 'view))).
7100: 20 20 20 20 3b 3b 20 20 20 20 20 20 20 28 62 65 ;; (be
7110: 67 69 6e 0a 20 20 20 20 20 20 20 3b 3b 20 20 20 gin. ;;
7120: 20 20 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 73 (session:s
7130: 65 74 2d 63 61 6c 6c 65 64 21 20 73 65 6c 66 20 et-called! self
7140: 70 61 67 65 29 0a 20 20 20 20 20 20 20 3b 3b 20 page). ;;
7150: 20 20 20 20 20 20 20 20 28 6c 6f 61 64 20 63 6f (load co
7160: 6e 74 72 6f 6c 2d 66 69 6c 65 29 29 29 0a 20 20 ntrol-file))).
7170: 20 20 20 20 20 3b 3b 20 20 20 28 69 66 20 28 66 ;; (if (f
7180: 69 6c 65 2d 65 78 69 73 74 73 3f 20 76 69 65 77 ile-exists? view
7190: 2d 66 69 6c 65 29 0a 20 20 20 20 20 20 20 3b 3b -file). ;;
71a0: 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 (if (not
71b0: 28 65 71 3f 20 70 61 72 74 73 20 27 63 6f 6e 74 (eq? parts 'cont
71c0: 72 6f 6c 29 29 0a 20 20 20 20 20 20 20 3b 3b 20 rol)). ;;
71d0: 20 09 20 28 73 65 73 73 69 6f 6e 3a 70 72 6f 63 . (session:proc
71e0: 65 73 73 2d 66 69 6c 65 20 76 69 65 77 2d 66 69 ess-file view-fi
71f0: 6c 65 29 29 0a 20 20 20 20 20 20 20 3b 3b 20 20 le)). ;;
7200: 20 20 20 20 20 28 6c 69 73 74 20 22 3c 70 3e 50 (list "<p>P
7210: 61 67 65 20 6e 6f 74 20 66 6f 75 6e 64 20 22 20 age not found "
7220: 70 61 67 65 20 22 20 3c 2f 70 3e 22 29 29 29 0a page " </p>"))).
7230: 20 20 20 20 20 20 28 28 64 69 72 29 20 22 45 52 ((dir) "ER
7240: 52 4f 52 3a 20 20 64 69 72 20 73 74 79 6c 65 20 ROR: dir style
7250: 6e 6f 74 20 79 65 74 20 72 65 2d 69 6d 70 6c 65 not yet re-imple
7260: 6d 65 6e 74 65 64 22 29 0a 20 20 20 20 20 20 28 mented"). (
7270: 65 6c 73 65 0a 20 20 20 20 20 20 20 28 6c 69 73 else. (lis
7280: 74 20 22 45 52 52 4f 52 3a 20 70 61 67 65 2d 64 t "ERROR: page-d
7290: 69 72 2d 73 74 79 6c 65 20 6d 75 73 74 20 62 65 ir-style must be
72a0: 20 73 74 6f 72 65 64 2c 20 64 69 72 20 6f 72 20 stored, dir or
72b0: 66 6c 61 74 2c 20 67 6f 74 20 22 20 64 69 72 2d flat, got " dir-
72c0: 73 74 79 6c 65 29 29 29 29 29 0a 0a 28 64 65 66 style)))))..(def
72d0: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 63 61 6c ine (session:cal
72e0: 6c 20 73 65 6c 66 20 70 61 67 65 20 70 61 72 74 l self page part
72f0: 73 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a 63 61 s). (session:ca
7300: 6c 6c 2d 70 61 72 74 73 20 73 65 6c 66 20 70 61 ll-parts self pa
7310: 67 65 20 27 62 6f 74 68 29 29 0a 0a 3b 3b 20 28 ge 'both))..;; (
7320: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
7330: 6c 6f 61 64 2d 6d 6f 64 65 6c 20 73 65 6c 66 20 load-model self
7340: 6d 6f 64 65 6c 29 0a 3b 3b 20 20 20 28 6c 65 74 model).;; (let
7350: 20 28 28 6d 6f 64 65 6c 2e 73 63 6d 20 28 73 74 ((model.scm (st
7360: 72 69 6e 67 2d 61 70 70 65 6e 64 20 28 73 64 61 ring-append (sda
7370: 74 2d 67 65 74 2d 73 72 6f 6f 74 20 73 65 6c 66 t-get-sroot self
7380: 29 20 22 2f 6d 6f 64 65 6c 73 2f 22 20 6d 6f 64 ) "/models/" mod
7390: 65 6c 20 22 2e 73 63 6d 22 29 29 0a 3b 3b 20 09 el ".scm")).;; .
73a0: 28 6d 6f 64 65 6c 2e 73 6f 20 20 28 73 74 72 69 (model.so (stri
73b0: 6e 67 2d 61 70 70 65 6e 64 20 28 73 64 61 74 2d ng-append (sdat-
73c0: 67 65 74 2d 73 72 6f 6f 74 20 73 65 6c 66 29 20 get-sroot self)
73d0: 22 2f 6d 6f 64 65 6c 73 2f 22 20 6d 6f 64 65 6c "/models/" model
73e0: 20 22 2e 73 6f 22 29 29 29 0a 3b 3b 20 20 20 20 ".so"))).;;
73f0: 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 (if (file-exist
7400: 73 3f 20 6d 6f 64 65 6c 2e 73 6f 29 0a 3b 3b 20 s? model.so).;;
7410: 09 28 6c 6f 61 64 20 6d 6f 64 65 6c 2e 73 6f 29 .(load model.so)
7420: 0a 3b 3b 20 09 28 69 66 20 28 66 69 6c 65 2d 65 .;; .(if (file-e
7430: 78 69 73 74 73 3f 20 6d 6f 64 65 6c 2e 73 63 6d xists? model.scm
7440: 29 0a 3b 3b 20 09 20 20 20 20 28 6c 6f 61 64 20 ).;; . (load
7450: 6d 6f 64 65 6c 2e 73 63 6d 29 0a 3b 3b 20 09 20 model.scm).;; .
7460: 20 20 20 28 73 3a 6c 6f 67 20 22 45 52 52 4f 52 (s:log "ERROR
7470: 3a 20 6d 6f 64 65 6c 20 22 20 6d 6f 64 65 6c 2e : model " model.
7480: 73 63 6d 20 22 20 6e 6f 74 20 66 6f 75 6e 64 22 scm " not found"
7490: 29 29 29 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e )))))..;; (defin
74a0: 65 20 28 73 65 73 73 69 6f 6e 3a 6d 6f 64 65 6c e (session:model
74b0: 2d 70 61 74 68 20 73 65 6c 66 20 6d 6f 64 65 6c -path self model
74c0: 29 0a 3b 3b 20 20 20 28 73 74 72 69 6e 67 2d 61 ).;; (string-a
74d0: 70 70 65 6e 64 20 28 73 64 61 74 2d 67 65 74 2d ppend (sdat-get-
74e0: 73 72 6f 6f 74 20 73 65 6c 66 29 20 22 2f 6d 6f sroot self) "/mo
74f0: 64 65 6c 73 2f 22 20 6d 6f 64 65 6c 20 22 2e 73 dels/" model ".s
7500: 63 6d 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 cm"))..(define (
7510: 73 65 73 73 69 6f 6e 3a 70 70 2d 66 6f 72 6d 64 session:pp-formd
7520: 61 74 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 20 at self). (let
7530: 28 28 64 61 74 20 28 66 6f 72 6d 64 61 74 3a 61 ((dat (formdat:a
7540: 6c 6c 2d 3e 73 74 72 69 6e 67 73 20 28 73 64 61 ll->strings (sda
7550: 74 2d 67 65 74 2d 66 6f 72 6d 64 61 74 20 73 65 t-get-formdat se
7560: 6c 66 29 29 29 29 0a 20 20 20 20 28 73 74 72 69 lf)))). (stri
7570: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 64 ng-intersperse d
7580: 61 74 20 22 3c 62 72 3e 20 22 29 29 29 0a 0a 28 at "<br> ")))..(
7590: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
75a0: 70 61 72 61 6d 2d 3e 73 74 72 69 6e 67 20 70 61 param->string pa
75b0: 72 61 6d 73 29 0a 20 20 3b 3b 20 28 65 72 72 3a rams). ;; (err:
75c0: 6c 6f 67 20 22 70 61 72 61 6d 73 3d 22 20 70 61 log "params=" pa
75d0: 72 61 6d 73 29 0a 20 20 28 69 66 20 28 3c 20 28 rams). (if (< (
75e0: 6c 65 6e 67 74 68 20 70 61 72 61 6d 73 29 20 31 length params) 1
75f0: 29 0a 20 20 20 20 20 20 22 22 0a 20 20 20 20 20 ). "".
7600: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 6b 65 79 (let loop ((key
7610: 20 28 63 61 72 20 70 61 72 61 6d 73 29 29 0a 09 (car params))..
7620: 09 20 28 76 61 6c 20 28 63 61 64 72 20 70 61 72 . (val (cadr par
7630: 61 6d 73 29 29 0a 09 09 20 28 74 61 69 6c 20 28 ams))... (tail (
7640: 63 64 64 72 20 70 61 72 61 6d 73 29 29 0a 09 09 cddr params))...
7650: 20 28 72 65 73 75 6c 74 20 27 28 29 29 29 0a 09 (result '()))..
7660: 28 6c 65 74 20 28 28 6e 65 77 72 65 73 75 6c 74 (let ((newresult
7670: 20 28 63 6f 6e 73 20 28 73 74 72 69 6e 67 2d 61 (cons (string-a
7680: 70 70 65 6e 64 20 28 73 3a 61 6e 79 2d 3e 73 74 ppend (s:any->st
7690: 72 69 6e 67 20 6b 65 79 29 20 22 3d 22 20 28 73 ring key) "=" (s
76a0: 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 76 61 6c :any->string val
76b0: 29 29 0a 09 09 09 20 20 20 20 20 20 20 72 65 73 )).... res
76c0: 75 6c 74 29 29 29 0a 09 20 20 28 69 66 20 28 3c ult))).. (if (<
76d0: 20 28 6c 65 6e 67 74 68 20 74 61 69 6c 29 20 31 (length tail) 1
76e0: 29 20 3b 3b 20 74 72 75 65 20 69 66 20 64 6f 6e ) ;; true if don
76f0: 65 0a 09 20 20 20 20 20 20 28 73 74 72 69 6e 67 e.. (string
7700: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 6e 65 77 -intersperse new
7710: 72 65 73 75 6c 74 20 22 26 22 29 0a 09 20 20 20 result "&")..
7720: 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 (loop (car ta
7730: 69 6c 29 28 63 61 64 72 20 74 61 69 6c 29 28 63 il)(cadr tail)(c
7740: 64 64 72 20 74 61 69 6c 29 20 6e 65 77 72 65 73 ddr tail) newres
7750: 75 6c 74 29 29 29 29 29 29 0a 0a 28 64 65 66 69 ult))))))..(defi
7760: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 6c 69 6e 6b ne (session:link
7770: 2d 74 6f 20 73 65 6c 66 20 70 61 67 65 20 70 61 -to self page pa
7780: 72 61 6d 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 rams). (let* ((
7790: 68 74 74 70 73 2d 68 6f 73 74 20 20 20 28 67 65 https-host (ge
77a0: 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 t-environment-va
77b0: 72 69 61 62 6c 65 20 22 48 54 54 50 53 5f 48 4f riable "HTTPS_HO
77c0: 53 54 22 29 29 0a 20 20 20 20 20 20 20 20 20 28 ST")). (
77d0: 66 6f 72 63 65 2d 73 73 6c 20 20 20 20 28 73 64 force-ssl (sd
77e0: 61 74 2d 67 65 74 2d 66 6f 72 63 65 2d 73 73 6c at-get-force-ssl
77f0: 20 73 65 6c 66 29 29 0a 09 20 28 73 65 72 76 65 self)).. (serve
7800: 72 20 20 20 20 20 20 20 28 6f 72 20 28 73 64 61 r (or (sda
7810: 74 2d 67 65 74 2d 64 6f 6d 61 69 6e 20 73 65 6c t-get-domain sel
7820: 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 f).
7830: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 68 74 ht
7840: 74 70 73 2d 68 6f 73 74 20 3b 3b 20 41 73 73 75 tps-host ;; Assu
7850: 6d 69 6e 67 20 48 54 54 50 53 5f 48 4f 53 54 20 ming HTTPS_HOST
7860: 69 73 20 6f 6e 6c 79 20 73 65 74 20 69 66 20 61 is only set if a
7870: 76 61 69 6c 61 62 6c 65 0a 09 09 09 20 20 20 28 vailable.... (
7880: 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d get-environment-
7890: 76 61 72 69 61 62 6c 65 20 22 48 54 54 50 5f 48 variable "HTTP_H
78a0: 4f 53 54 22 29 0a 09 09 09 20 20 20 28 67 65 74 OST").... (get
78b0: 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 -environment-var
78c0: 69 61 62 6c 65 20 22 53 45 52 56 45 52 5f 4e 41 iable "SERVER_NA
78d0: 4d 45 22 29 29 29 0a 20 20 20 20 20 20 20 20 20 ME"))).
78e0: 28 66 6f 72 63 65 2d 73 63 72 69 70 74 20 20 28 (force-script (
78f0: 73 64 61 74 2d 67 65 74 2d 73 63 72 69 70 74 20 sdat-get-script
7900: 73 65 6c 66 29 29 0a 09 20 28 73 63 72 69 70 74 self)).. (script
7910: 20 20 20 20 20 20 20 20 28 6f 72 20 66 6f 72 63 (or forc
7920: 65 2d 73 63 72 69 70 74 0a 09 09 09 20 20 20 20 e-script....
7930: 28 6c 65 74 20 28 28 73 63 72 69 70 74 2d 6e 61 (let ((script-na
7940: 6d 65 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 me (string-split
7950: 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e (get-environmen
7960: 74 2d 76 61 72 69 61 62 6c 65 20 22 53 43 52 49 t-variable "SCRI
7970: 50 54 5f 4e 41 4d 45 22 29 20 22 2f 22 29 29 29 PT_NAME") "/")))
7980: 0a 09 09 09 20 20 20 20 20 20 28 69 66 20 28 3e .... (if (>
7990: 20 28 6c 65 6e 67 74 68 20 73 63 72 69 70 74 2d (length script-
79a0: 6e 61 6d 65 29 20 31 29 0a 09 09 09 09 20 20 28 name) 1)..... (
79b0: 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 28 63 string-append (c
79c0: 61 72 20 73 63 72 69 70 74 2d 6e 61 6d 65 29 20 ar script-name)
79d0: 22 2f 22 20 28 63 61 64 72 20 73 63 72 69 70 74 "/" (cadr script
79e0: 2d 6e 61 6d 65 29 29 0a 09 09 09 09 20 20 28 67 -name))..... (g
79f0: 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 et-environment-v
7a00: 61 72 69 61 62 6c 65 20 22 53 43 52 49 50 54 5f ariable "SCRIPT_
7a10: 4e 41 4d 45 22 29 29 29 29 29 20 3b 3b 20 62 75 NAME"))))) ;; bu
7a20: 69 6c 64 20 73 63 72 69 70 74 20 6e 61 6d 65 20 ild script name
7a30: 66 72 6f 6d 20 66 69 72 73 74 20 74 77 6f 20 65 from first two e
7a40: 6c 65 6d 65 6e 74 73 2e 20 54 68 69 73 20 69 73 lements. This is
7a50: 20 61 20 68 61 6e 67 6f 76 65 72 20 66 72 6f 6d a hangover from
7a60: 20 62 65 66 6f 72 65 20 49 20 75 73 65 64 20 3f before I used ?
7a70: 20 69 6e 20 74 68 65 20 55 52 4c 2e 29 0a 20 20 in the URL.).
7a80: 20 20 20 20 20 20 20 28 73 65 73 73 69 6f 6e 2d (session-
7a90: 6b 65 79 20 20 20 28 73 64 61 74 2d 67 65 74 2d key (sdat-get-
7aa0: 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 session-key self
7ab0: 29 29 0a 09 20 28 70 61 72 61 6d 73 74 72 20 20 )).. (paramstr
7ac0: 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 70 61 72 (session:par
7ad0: 61 6d 2d 3e 73 74 72 69 6e 67 20 70 61 72 61 6d am->string param
7ae0: 73 29 29 29 0a 20 20 20 20 3b 3b 20 28 73 65 73 s))). ;; (ses
7af0: 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 73 sion:log self "s
7b00: 65 72 76 65 72 3d 22 20 73 65 72 76 65 72 20 22 erver=" server "
7b10: 20 73 63 72 69 70 74 3d 22 20 73 63 72 69 70 74 script=" script
7b20: 20 22 20 70 61 67 65 3d 22 20 70 61 67 65 29 0a " page=" page).
7b30: 20 20 20 20 28 73 74 72 69 6e 67 2d 61 70 70 65 (string-appe
7b40: 6e 64 20 28 69 66 20 28 6f 72 20 68 74 74 70 73 nd (if (or https
7b50: 2d 68 6f 73 74 20 66 6f 72 63 65 2d 73 73 6c 29 -host force-ssl)
7b60: 0a 09 09 20 20 20 20 20 20 22 68 74 74 70 73 3a ... "https:
7b70: 2f 2f 22 0a 09 09 20 20 20 20 20 20 22 68 74 74 //"... "htt
7b80: 70 3a 2f 2f 22 29 0a 09 09 20 20 20 73 65 72 76 p://")... serv
7b90: 65 72 20 22 2f 22 20 73 63 72 69 70 74 20 22 2f er "/" script "/
7ba0: 22 20 70 61 67 65 20 22 3f 22 20 70 61 72 61 6d " page "?" param
7bb0: 73 74 72 29 29 29 20 3b 3b 20 22 2f 73 6e 3d 22 str))) ;; "/sn="
7bc0: 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 29 0a session-key))).
7bd0: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
7be0: 6e 3a 63 67 69 2d 6f 75 74 20 73 65 6c 66 29 0a n:cgi-out self).
7bf0: 20 20 28 6c 65 74 2a 20 28 28 63 6f 6e 74 65 6e (let* ((conten
7c00: 74 20 20 28 6c 69 73 74 20 28 73 64 61 74 2d 67 t (list (sdat-g
7c10: 65 74 2d 63 6f 6e 74 65 6e 74 2d 74 79 70 65 20 et-content-type
7c20: 73 65 6c 66 29 29 29 20 3b 3b 20 27 28 22 43 6f self))) ;; '("Co
7c30: 6e 74 65 6e 74 2d 74 79 70 65 3a 20 74 65 78 74 ntent-type: text
7c40: 2f 68 74 6d 6c 3b 20 63 68 61 72 73 65 74 3d 69 /html; charset=i
7c50: 73 6f 2d 38 38 35 39 2d 31 5c 6e 5c 6e 22 29 29 so-8859-1\n\n"))
7c60: 0a 09 20 28 68 65 61 64 65 72 20 20 20 28 6c 65 .. (header (le
7c70: 74 20 28 28 63 6f 6f 6b 69 65 20 28 73 64 61 74 t ((cookie (sdat
7c80: 2d 67 65 74 2d 73 65 73 73 69 6f 6e 2d 63 6f 6f -get-session-coo
7c90: 6b 69 65 20 73 65 6c 66 29 29 29 0a 09 09 20 20 kie self)))...
7ca0: 20 20 20 28 69 66 20 63 6f 6f 6b 69 65 0a 09 09 (if cookie...
7cb0: 09 20 28 63 6f 6e 73 20 28 73 74 72 69 6e 67 2d . (cons (string-
7cc0: 61 70 70 65 6e 64 20 22 53 65 74 2d 43 6f 6f 6b append "Set-Cook
7cd0: 69 65 3a 20 22 20 28 63 61 72 20 63 6f 6f 6b 69 ie: " (car cooki
7ce0: 65 29 29 0a 09 09 09 20 20 20 20 20 20 20 63 6f e)).... co
7cf0: 6e 74 65 6e 74 29 0a 09 09 09 20 63 6f 6e 74 65 ntent).... conte
7d00: 6e 74 29 29 29 0a 09 20 28 70 61 67 65 64 61 74 nt))).. (pagedat
7d10: 20 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 (sdat-get-page
7d20: 64 61 74 20 73 65 6c 66 29 29 29 0a 20 20 20 20 dat self))).
7d30: 28 73 3a 63 67 69 2d 6f 75 74 20 0a 20 20 20 20 (s:cgi-out .
7d40: 20 28 63 6f 6e 73 20 68 65 61 64 65 72 20 70 61 (cons header pa
7d50: 67 65 64 61 74 29 29 29 29 0a 0a 28 64 65 66 69 gedat))))..(defi
7d60: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 ne (session:log
7d70: 73 65 6c 66 20 2e 20 6d 73 67 29 0a 20 20 28 77 self . msg). (w
7d80: 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 70 6f ith-output-to-po
7d90: 72 74 20 28 73 64 61 74 2d 67 65 74 2d 6c 6f 67 rt (sdat-get-log
7da0: 2d 70 6f 72 74 20 73 65 6c 66 29 20 3b 3b 20 28 -port self) ;; (
7db0: 73 64 61 74 2d 67 65 74 2d 6c 6f 67 70 74 20 73 sdat-get-logpt s
7dc0: 65 6c 66 29 0a 20 20 20 20 28 6c 61 6d 62 64 61 elf). (lambda
7dd0: 20 28 29 20 0a 20 20 20 20 20 20 28 61 70 70 6c () . (appl
7de0: 79 20 70 72 69 6e 74 20 6d 73 67 29 29 29 29 0a y print msg)))).
7df0: 0a 3b 3b 20 65 73 63 61 70 65 2c 20 63 6f 6e 76 .;; escape, conv
7e00: 65 72 74 20 6f 72 20 72 65 74 75 72 6e 20 72 61 ert or return ra
7e10: 77 20 77 68 65 6e 20 67 69 76 65 6e 20 75 73 65 w when given use
7e20: 72 20 69 6e 70 75 74 20 64 61 74 61 20 74 68 61 r input data tha
7e30: 74 20 70 6f 74 65 6e 74 69 61 6c 6c 79 0a 3b 3b t potentially.;;
7e40: 20 63 6f 75 6c 64 20 62 65 20 6d 61 6c 69 63 69 could be malici
7e50: 6f 75 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 ous.;;.(define (
7e60: 73 65 73 73 69 6f 6e 3a 61 70 70 6c 79 2d 74 79 session:apply-ty
7e70: 70 65 2d 70 72 65 66 65 72 65 6e 63 65 20 72 65 pe-preference re
7e80: 73 20 70 61 72 61 6d 73 29 0a 20 20 28 6c 65 74 s params). (let
7e90: 2a 20 28 28 64 74 79 70 65 20 20 20 20 28 69 66 * ((dtype (if
7ea0: 20 28 6e 75 6c 6c 3f 20 70 61 72 61 6d 73 29 0a (null? params).
7eb0: 09 09 20 20 20 20 20 20 20 27 65 73 63 61 70 65 .. 'escape
7ec0: 64 0a 09 09 20 20 20 20 20 20 20 28 63 61 72 20 d... (car
7ed0: 70 61 72 61 6d 73 29 29 29 0a 09 20 28 74 61 67 params))).. (tag
7ee0: 73 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 s (if (null?
7ef0: 70 61 72 61 6d 73 29 0a 09 09 20 20 20 20 20 20 params)...
7f00: 27 28 29 0a 09 09 20 20 20 20 20 20 28 63 64 72 '()... (cdr
7f10: 20 70 61 72 61 6d 73 29 29 29 29 0a 20 20 20 20 params)))).
7f20: 28 63 61 73 65 20 64 74 79 70 65 0a 20 20 20 20 (case dtype.
7f30: 20 20 28 28 72 61 77 29 20 20 20 20 20 72 65 73 ((raw) res
7f40: 29 0a 20 20 20 20 20 20 28 28 6e 75 6d 62 65 72 ). ((number
7f50: 29 20 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 ) (if (string?
7f60: 72 65 73 29 28 73 74 72 69 6e 67 2d 3e 6e 75 6d res)(string->num
7f70: 62 65 72 20 72 65 73 29 20 23 66 29 29 0a 20 20 ber res) #f)).
7f80: 20 20 20 20 28 28 65 73 63 61 70 65 64 29 20 28 ((escaped) (
7f90: 69 66 20 28 73 74 72 69 6e 67 3f 20 72 65 73 29 if (string? res)
7fa0: 0a 09 09 20 20 20 20 20 28 73 3a 68 74 6d 6c 2d ... (s:html-
7fb0: 66 69 6c 74 65 72 2d 3e 73 74 72 69 6e 67 20 72 filter->string r
7fc0: 65 73 20 74 61 67 73 29 0a 09 09 20 20 20 20 20 es tags)...
7fd0: 72 65 73 29 29 0a 20 20 20 20 20 20 28 28 65 73 res)). ((es
7fe0: 63 61 70 65 64 2d 6e 6c 29 20 28 69 66 20 28 73 caped-nl) (if (s
7ff0: 74 72 69 6e 67 3f 20 72 65 73 29 20 3b 3b 20 65 tring? res) ;; e
8000: 73 63 61 70 65 20 5c 6e 20 61 6e 64 20 5c 72 0a scape \n and \r.
8010: 09 09 09 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 ...(string-inter
8020: 73 70 65 72 73 65 0a 09 09 09 20 28 73 74 72 69 sperse.... (stri
8030: 6e 67 2d 73 70 6c 69 74 0a 09 09 09 20 20 28 73 ng-split.... (s
8040: 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
8050: 65 0a 09 09 09 20 20 20 28 73 74 72 69 6e 67 2d e.... (string-
8060: 73 70 6c 69 74 20 28 73 3a 68 74 6d 6c 2d 66 69 split (s:html-fi
8070: 6c 74 65 72 2d 3e 73 74 72 69 6e 67 20 72 65 73 lter->string res
8080: 20 74 61 67 73 29 20 22 5c 6e 22 29 0a 09 09 09 tags) "\n")....
8090: 20 20 20 22 5c 5c 6e 22 29 0a 09 09 09 20 20 22 "\\n").... "
80a0: 5c 72 22 29 0a 09 09 09 20 22 5c 5c 72 22 29 0a \r").... "\\r").
80b0: 09 09 09 72 65 73 29 29 20 3b 3b 20 73 68 6f 75 ...res)) ;; shou
80c0: 6c 64 20 72 65 74 75 72 6e 20 23 66 20 69 66 20 ld return #f if
80d0: 6e 6f 74 20 61 20 73 74 72 69 6e 67 20 61 6e 64 not a string and
80e0: 20 63 61 6e 27 74 20 65 73 63 61 70 65 20 69 74 can't escape it
80f0: 3f 0a 20 20 20 20 20 20 28 65 6c 73 65 20 20 20 ?. (else
8100: 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 (if (string?
8110: 72 65 73 29 0a 09 09 20 20 20 20 20 28 73 3a 68 res)... (s:h
8120: 74 6d 6c 2d 66 69 6c 74 65 72 2d 3e 73 74 72 69 tml-filter->stri
8130: 6e 67 20 72 65 73 20 27 28 29 29 0a 09 09 20 20 ng res '())...
8140: 20 20 20 72 65 73 29 29 29 29 29 0a 0a 3b 3b 20 res)))))..;;
8150: 70 61 72 61 6d 73 20 61 72 65 20 73 74 6f 72 65 params are store
8160: 64 20 61 73 20 6c 69 73 74 20 6f 66 20 6b 65 79 d as list of key
8170: 3d 76 61 6c 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 =val.;;.(define
8180: 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 72 (session:get-par
8190: 61 6d 20 73 65 6c 66 20 6b 65 79 20 74 79 70 65 am self key type
81a0: 2d 70 61 72 61 6d 73 29 0a 20 20 3b 3b 20 28 73 -params). ;; (s
81b0: 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 3a 73 65 73 ession:log s:ses
81c0: 73 69 6f 6e 20 22 70 61 72 61 6d 73 3d 22 20 28 sion "params=" (
81d0: 73 6c 6f 74 2d 72 65 66 20 73 3a 73 65 73 73 69 slot-ref s:sessi
81e0: 6f 6e 20 27 70 61 72 61 6d 73 29 29 0a 20 20 28 on 'params)). (
81f0: 6c 65 74 2a 20 28 28 70 61 72 61 6d 73 20 28 73 let* ((params (s
8200: 64 61 74 2d 67 65 74 2d 70 61 72 61 6d 73 20 73 dat-get-params s
8210: 65 6c 66 29 29 0a 09 20 28 72 65 73 20 20 20 20 elf)).. (res
8220: 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 72 (session:get-par
8230: 61 6d 2d 66 72 6f 6d 20 70 61 72 61 6d 73 20 6b am-from params k
8240: 65 79 29 29 29 0a 20 20 20 20 28 73 65 73 73 69 ey))). (sessi
8250: 6f 6e 3a 61 70 70 6c 79 2d 74 79 70 65 2d 70 72 on:apply-type-pr
8260: 65 66 65 72 65 6e 63 65 20 72 65 73 20 74 79 70 eference res typ
8270: 65 2d 70 61 72 61 6d 73 29 29 29 0a 0a 3b 3b 20 e-params)))..;;
8280: 54 68 69 73 20 6f 6e 65 20 77 69 6c 6c 20 67 65 This one will ge
8290: 74 20 74 68 65 20 66 69 72 73 74 20 76 61 6c 75 t the first valu
82a0: 65 20 66 6f 75 6e 64 20 72 65 67 61 72 64 6c 65 e found regardle
82b0: 73 73 20 6f 66 20 66 6f 72 6d 0a 3b 3b 20 70 61 ss of form.;; pa
82c0: 72 61 6d 3a 20 28 64 74 79 70 65 20 5b 74 61 67 ram: (dtype [tag
82d0: 31 20 74 61 67 32 20 2e 2e 2e 5d 29 0a 3b 3b 20 1 tag2 ...]).;;
82e0: 64 74 79 70 65 3a 0a 3b 3b 20 20 20 20 27 72 61 dtype:.;; 'ra
82f0: 77 20 20 20 20 20 3a 20 64 6f 20 6e 6f 20 63 6f w : do no co
8300: 6e 76 65 72 73 69 6f 6e 0a 3b 3b 20 20 20 20 27 nversion.;; '
8310: 6e 75 6d 62 65 72 20 20 3a 20 63 6f 6e 76 65 72 number : conver
8320: 74 20 74 6f 20 6e 75 6d 62 65 72 2c 20 72 65 74 t to number, ret
8330: 75 72 6e 20 23 66 20 69 66 20 66 61 69 6c 73 0a urn #f if fails.
8340: 3b 3b 20 20 20 20 27 65 73 63 61 70 65 64 20 3a ;; 'escaped :
8350: 20 75 73 65 20 68 74 6d 6c 2d 65 73 63 61 70 65 use html-escape
8360: 20 74 6f 20 70 72 6f 74 65 63 74 20 74 68 65 20 to protect the
8370: 69 6e 70 75 74 20 2d 2d 20 74 68 69 73 20 69 73 input -- this is
8380: 20 74 68 65 20 64 65 66 61 75 6c 74 0a 3b 3b 0a the default.;;.
8390: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
83a0: 3a 67 65 74 2d 69 6e 70 75 74 20 73 65 6c 66 20 :get-input self
83b0: 6b 65 79 20 70 61 72 61 6d 73 29 0a 20 20 28 6c key params). (l
83c0: 65 74 2a 20 28 28 64 74 79 70 65 20 20 20 20 28 et* ((dtype (
83d0: 69 66 20 28 6e 75 6c 6c 3f 20 70 61 72 61 6d 73 if (null? params
83e0: 29 0a 09 09 20 20 20 20 20 20 20 27 65 73 63 61 )... 'esca
83f0: 70 65 64 0a 09 09 20 20 20 20 20 20 20 28 63 61 ped... (ca
8400: 72 20 70 61 72 61 6d 73 29 29 29 0a 09 20 28 74 r params))).. (t
8410: 61 67 73 20 20 20 20 28 69 66 20 28 6e 75 6c 6c ags (if (null
8420: 3f 20 70 61 72 61 6d 73 29 0a 09 09 20 20 20 20 ? params)...
8430: 20 20 27 28 29 0a 09 09 20 20 20 20 20 20 28 63 '()... (c
8440: 64 72 20 70 61 72 61 6d 73 29 29 29 0a 09 20 28 dr params))).. (
8450: 66 6f 72 6d 64 61 74 20 28 73 64 61 74 2d 67 65 formdat (sdat-ge
8460: 74 2d 66 6f 72 6d 64 61 74 20 73 65 6c 66 29 29 t-formdat self))
8470: 0a 09 20 28 72 65 73 20 20 20 20 20 28 69 66 20 .. (res (if
8480: 28 6e 6f 74 20 66 6f 72 6d 64 61 74 29 20 23 66 (not formdat) #f
8490: 0a 09 09 20 20 20 20 20 20 28 69 66 20 28 6f 72 ... (if (or
84a0: 20 28 73 74 72 69 6e 67 3f 20 6b 65 79 29 28 6e (string? key)(n
84b0: 75 6d 62 65 72 3f 20 6b 65 79 29 28 73 79 6d 62 umber? key)(symb
84c0: 6f 6c 3f 20 6b 65 79 29 29 0a 09 09 09 20 20 28 ol? key)).... (
84d0: 69 66 20 28 61 6e 64 20 28 76 65 63 74 6f 72 3f if (and (vector?
84e0: 20 66 6f 72 6d 64 61 74 29 28 65 71 3f 20 28 76 formdat)(eq? (v
84f0: 65 63 74 6f 72 2d 6c 65 6e 67 74 68 20 66 6f 72 ector-length for
8500: 6d 64 61 74 29 20 31 29 28 68 61 73 68 2d 74 61 mdat) 1)(hash-ta
8510: 62 6c 65 3f 20 28 76 65 63 74 6f 72 2d 72 65 66 ble? (vector-ref
8520: 20 66 6f 72 6d 64 61 74 20 30 29 29 29 0a 09 09 formdat 0)))...
8530: 09 20 20 20 20 20 20 28 66 6f 72 6d 64 61 74 3a . (formdat:
8540: 67 65 74 20 66 6f 72 6d 64 61 74 20 6b 65 79 29 get formdat key)
8550: 0a 09 09 09 20 20 20 20 20 20 28 62 65 67 69 6e .... (begin
8560: 0a 09 09 09 09 28 73 65 73 73 69 6f 6e 3a 6c 6f .....(session:lo
8570: 67 20 73 65 6c 66 20 22 45 52 52 4f 52 3a 20 66 g self "ERROR: f
8580: 6f 72 6d 64 61 74 3a 20 22 20 66 6f 72 6d 64 61 ormdat: " formda
8590: 74 20 22 20 69 73 20 6e 6f 74 20 6f 66 20 63 6c t " is not of cl
85a0: 61 73 73 20 3c 66 6f 72 6d 64 61 74 3e 22 29 0a ass <formdat>").
85b0: 09 09 09 09 23 66 29 29 0a 09 09 09 20 20 28 62 ....#f)).... (b
85c0: 65 67 69 6e 0a 09 09 09 20 20 20 20 28 73 65 73 egin.... (ses
85d0: 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 45 sion:log self "E
85e0: 52 52 4f 52 3a 20 62 61 64 20 6b 65 79 20 22 20 RROR: bad key "
85f0: 6b 65 79 29 0a 09 09 09 20 20 20 20 23 66 29 29 key).... #f))
8600: 29 29 29 0a 20 20 20 20 28 63 61 73 65 20 64 74 ))). (case dt
8610: 79 70 65 0a 20 20 20 20 20 20 28 28 72 61 77 29 ype. ((raw)
8620: 20 20 20 20 20 72 65 73 29 0a 20 20 20 20 20 20 res).
8630: 28 28 6e 75 6d 62 65 72 29 20 20 28 69 66 20 28 ((number) (if (
8640: 73 74 72 69 6e 67 3f 20 72 65 73 29 28 73 74 72 string? res)(str
8650: 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 72 65 73 29 ing->number res)
8660: 20 23 66 29 29 0a 20 20 20 20 20 20 28 28 65 73 #f)). ((es
8670: 63 61 70 65 64 29 20 28 69 66 20 28 73 74 72 69 caped) (if (stri
8680: 6e 67 3f 20 72 65 73 29 0a 09 09 20 20 20 20 20 ng? res)...
8690: 28 73 3a 68 74 6d 6c 2d 66 69 6c 74 65 72 2d 3e (s:html-filter->
86a0: 73 74 72 69 6e 67 20 72 65 73 20 74 61 67 73 29 string res tags)
86b0: 0a 09 09 20 20 20 20 20 72 65 73 29 29 0a 20 20 ... res)).
86c0: 20 20 20 20 28 65 6c 73 65 20 20 20 20 20 20 28 (else (
86d0: 69 66 20 28 73 74 72 69 6e 67 3f 20 72 65 73 29 if (string? res)
86e0: 0a 09 09 20 20 20 20 20 28 73 3a 68 74 6d 6c 2d ... (s:html-
86f0: 66 69 6c 74 65 72 2d 3e 73 74 72 69 6e 67 20 72 filter->string r
8700: 65 73 20 27 28 29 29 0a 09 09 20 20 20 20 20 72 es '())... r
8710: 65 73 29 29 29 29 29 0a 0a 3b 3b 20 54 68 69 73 es)))))..;; This
8720: 20 6f 6e 65 20 77 69 6c 6c 20 67 65 74 20 74 68 one will get th
8730: 65 20 66 69 72 73 74 20 76 61 6c 75 65 20 66 6f e first value fo
8740: 75 6e 64 20 72 65 67 61 72 64 6c 65 73 73 20 6f und regardless o
8750: 66 20 66 6f 72 6d 0a 28 64 65 66 69 6e 65 20 28 f form.(define (
8760: 73 65 73 73 69 6f 6e 3a 67 65 74 2d 69 6e 70 75 session:get-inpu
8770: 74 2d 6b 65 79 73 20 73 65 6c 66 29 0a 20 20 28 t-keys self). (
8780: 6c 65 74 2a 20 28 28 66 6f 72 6d 64 61 74 20 28 let* ((formdat (
8790: 73 64 61 74 2d 67 65 74 2d 66 6f 72 6d 64 61 74 sdat-get-formdat
87a0: 20 73 65 6c 66 29 29 29 0a 20 20 20 20 28 69 66 self))). (if
87b0: 20 28 6e 6f 74 20 66 6f 72 6d 64 61 74 29 20 23 (not formdat) #
87c0: 66 0a 09 28 69 66 20 28 61 6e 64 20 28 76 65 63 f..(if (and (vec
87d0: 74 6f 72 3f 20 66 6f 72 6d 64 61 74 29 28 65 71 tor? formdat)(eq
87e0: 3f 20 28 76 65 63 74 6f 72 2d 6c 65 6e 67 74 68 ? (vector-length
87f0: 20 66 6f 72 6d 64 61 74 29 20 31 29 28 68 61 73 formdat) 1)(has
8800: 68 2d 74 61 62 6c 65 3f 20 28 76 65 63 74 6f 72 h-table? (vector
8810: 2d 72 65 66 20 66 6f 72 6d 64 61 74 20 30 29 29 -ref formdat 0))
8820: 29 0a 09 20 20 20 20 28 66 6f 72 6d 64 61 74 3a ).. (formdat:
8830: 6b 65 79 73 20 66 6f 72 6d 64 61 74 29 0a 09 20 keys formdat)..
8840: 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 (begin..
8850: 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 (session:log se
8860: 6c 66 20 22 45 52 52 4f 52 3a 20 66 6f 72 6d 64 lf "ERROR: formd
8870: 61 74 3a 20 22 20 66 6f 72 6d 64 61 74 20 22 20 at: " formdat "
8880: 69 73 20 6e 6f 74 20 6f 66 20 63 6c 61 73 73 20 is not of class
8890: 3c 66 6f 72 6d 64 61 74 3e 22 29 0a 09 20 20 20 <formdat>")..
88a0: 20 20 20 23 66 29 29 29 29 29 0a 0a 28 64 65 66 #f)))))..(def
88b0: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 72 75 6e ine (session:run
88c0: 2d 61 63 74 69 6f 6e 73 20 73 65 6c 66 29 0a 20 -actions self).
88d0: 20 28 6c 65 74 2a 20 28 28 61 63 74 69 6f 6e 20 (let* ((action
88e0: 20 20 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d (session:get-
88f0: 70 61 72 61 6d 20 73 65 6c 66 20 27 61 63 74 69 param self 'acti
8900: 6f 6e 20 27 28 72 61 77 29 29 29 0a 09 20 28 70 on '(raw))).. (p
8910: 61 67 65 20 20 20 20 20 20 28 73 64 61 74 2d 67 age (sdat-g
8920: 65 74 2d 70 61 67 65 20 73 65 6c 66 29 29 29 0a et-page self))).
8930: 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 61 ;; (print "a
8940: 63 74 69 6f 6e 3d 22 20 61 63 74 69 6f 6e 20 22 ction=" action "
8950: 20 70 61 67 65 3d 22 20 70 61 67 65 29 0a 20 20 page=" page).
8960: 20 20 28 69 66 20 61 63 74 69 6f 6e 0a 09 28 6c (if action..(l
8970: 65 74 20 28 28 61 63 74 69 6f 6e 2d 6c 73 74 20 et ((action-lst
8980: 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 61 (string-split a
8990: 63 74 69 6f 6e 20 22 2e 22 29 29 29 0a 09 20 20 ction ".")))..
89a0: 3b 3b 20 28 70 72 69 6e 74 20 22 61 63 74 69 6f ;; (print "actio
89b0: 6e 2d 6c 73 74 3d 22 20 61 63 74 69 6f 6e 2d 6c n-lst=" action-l
89c0: 73 74 29 0a 09 20 20 28 69 66 20 28 6e 6f 74 20 st).. (if (not
89d0: 28 3d 20 28 6c 65 6e 67 74 68 20 61 63 74 69 6f (= (length actio
89e0: 6e 2d 6c 73 74 29 20 32 29 29 20 0a 09 20 20 20 n-lst) 2)) ..
89f0: 20 20 20 28 65 72 72 3a 6c 6f 67 20 22 41 63 74 (err:log "Act
8a00: 69 6f 6e 20 73 68 6f 75 6c 64 20 62 65 20 6f 66 ion should be of
8a10: 20 66 6f 72 6d 3a 20 6d 6f 64 75 6c 65 2e 61 63 form: module.ac
8a20: 74 69 6f 6e 22 29 0a 09 20 20 20 20 20 20 28 6c tion").. (l
8a30: 65 74 2a 20 28 28 74 61 72 67 2d 70 61 67 65 20 et* ((targ-page
8a40: 20 20 28 63 61 72 20 61 63 74 69 6f 6e 2d 6c 73 (car action-ls
8a50: 74 29 29 0a 09 09 20 20 20 20 20 28 70 72 6f 63 t))... (proc
8a60: 2d 6e 61 6d 65 20 20 20 28 73 74 72 69 6e 67 2d -name (string-
8a70: 61 70 70 65 6e 64 20 74 61 72 67 2d 70 61 67 65 append targ-page
8a80: 20 22 2d 61 63 74 69 6f 6e 22 29 29 0a 09 09 20 "-action"))...
8a90: 20 20 20 20 28 74 61 72 67 2d 61 63 74 69 6f 6e (targ-action
8aa0: 20 28 63 61 64 72 20 61 63 74 69 6f 6e 2d 6c 73 (cadr action-ls
8ab0: 74 29 29 29 0a 09 09 3b 3b 20 28 65 72 72 3a 6c t)))...;; (err:l
8ac0: 6f 67 20 22 74 61 72 67 2d 70 61 67 65 3d 22 20 og "targ-page="
8ad0: 74 61 72 67 2d 70 61 67 65 20 22 20 70 72 6f 63 targ-page " proc
8ae0: 2d 6e 61 6d 65 3d 22 20 70 72 6f 63 2d 6e 61 6d -name=" proc-nam
8af0: 65 20 22 20 74 61 72 67 2d 61 63 74 69 6f 6e 3d e " targ-action=
8b00: 22 20 74 61 72 67 2d 61 63 74 69 6f 6e 29 0a 0a " targ-action)..
8b10: 09 09 3b 3b 20 63 61 6c 6c 20 68 65 72 65 20 6f ..;; call here o
8b20: 6e 6c 79 20 69 66 20 6e 65 76 65 72 20 63 61 6c nly if never cal
8b30: 6c 65 64 20 62 65 66 6f 72 65 0a 09 09 28 69 66 led before...(if
8b40: 20 28 73 65 73 73 69 6f 6e 3a 6e 65 76 65 72 2d (session:never-
8b50: 63 61 6c 6c 65 64 2d 70 61 67 65 3f 20 73 65 6c called-page? sel
8b60: 66 20 74 61 72 67 2d 70 61 67 65 29 0a 09 09 20 f targ-page)...
8b70: 20 20 20 28 73 65 73 73 69 6f 6e 3a 63 61 6c 6c (session:call
8b80: 2d 70 61 72 74 73 20 73 65 6c 66 20 74 61 72 67 -parts self targ
8b90: 2d 70 61 67 65 20 27 63 6f 6e 74 72 6f 6c 29 29 -page 'control))
8ba0: 0a 09 09 3b 3b 20 20 20 20 20 20 20 20 20 20 20 ...;;
8bb0: 20 20 20 20 20 20 20 20 20 70 72 6f 63 20 20 20 proc
8bc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8bd0: 20 20 20 20 20 20 61 63 74 69 6f 6e 20 20 20 20 action
8be0: 0a 0a 09 09 28 69 66 20 23 74 20 3b 3b 20 73 65 ....(if #t ;; se
8bf0: 74 20 74 6f 20 23 74 20 74 6f 20 73 65 65 20 62 t to #t to see b
8c00: 65 74 74 65 72 20 65 72 72 6f 72 20 6d 65 73 73 etter error mess
8c10: 61 67 65 73 20 64 75 72 69 6e 67 20 64 65 62 75 ages during debu
8c20: 67 67 69 6e 20 3a 2d 29 0a 09 09 20 20 20 20 28 ggin :-)... (
8c30: 28 65 76 61 6c 20 28 73 74 72 69 6e 67 2d 3e 73 (eval (string->s
8c40: 79 6d 62 6f 6c 20 70 72 6f 63 2d 6e 61 6d 65 29 ymbol proc-name)
8c50: 29 20 74 61 72 67 2d 61 63 74 69 6f 6e 29 20 3b ) targ-action) ;
8c60: 3b 20 75 6e 73 61 66 65 20 65 78 65 63 75 74 69 ; unsafe executi
8c70: 6f 6e 0a 09 09 20 20 20 20 28 63 6f 6e 64 69 74 on... (condit
8c80: 69 6f 6e 2d 63 61 73 65 20 28 28 65 76 61 6c 20 ion-case ((eval
8c90: 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 (string->symbol
8ca0: 70 72 6f 63 2d 6e 61 6d 65 29 29 20 74 61 72 67 proc-name)) targ
8cb0: 2d 61 63 74 69 6f 6e 29 0a 09 09 09 09 20 20 20 -action).....
8cc0: 20 28 28 65 78 6e 20 66 69 6c 65 29 20 28 73 3a ((exn file) (s:
8cd0: 6c 6f 67 20 22 66 69 6c 65 20 65 72 72 6f 72 22 log "file error"
8ce0: 29 29 0a 09 09 09 09 20 20 20 20 28 28 65 78 6e ))..... ((exn
8cf0: 20 69 2f 6f 29 20 20 28 73 3a 6c 6f 67 20 22 69 i/o) (s:log "i
8d00: 2f 6f 20 65 72 72 6f 72 22 29 29 0a 09 09 09 09 /o error")).....
8d10: 20 20 20 20 28 28 65 78 6e 20 29 20 20 20 20 20 ((exn )
8d20: 28 73 3a 6c 6f 67 20 22 41 63 74 69 6f 6e 20 6e (s:log "Action n
8d30: 6f 74 20 69 6d 70 6c 65 6d 65 6e 74 65 64 3a 20 ot implemented:
8d40: 22 20 70 72 6f 63 2d 6e 61 6d 65 20 22 20 61 63 " proc-name " ac
8d50: 74 69 6f 6e 3a 20 22 20 74 61 72 67 2d 61 63 74 tion: " targ-act
8d60: 69 6f 6e 29 29 0a 09 09 09 09 20 20 20 20 28 76 ion))..... (v
8d70: 61 72 20 28 29 20 20 20 20 20 28 73 3a 6c 6f 67 ar () (s:log
8d80: 20 22 55 6e 6b 6e 6f 77 6e 20 45 72 72 6f 72 22 "Unknown Error"
8d90: 29 29 29 29 29 29 29 29 29 29 0a 0a 28 64 65 66 ))))))))))..(def
8da0: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 6e 65 76 ine (session:nev
8db0: 65 72 2d 63 61 6c 6c 65 64 2d 70 61 67 65 3f 20 er-called-page?
8dc0: 73 65 6c 66 20 70 61 67 65 29 0a 20 20 28 73 65 self page). (se
8dd0: 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 ssion:log self "
8de0: 43 68 65 63 6b 69 6e 67 20 66 6f 72 20 70 61 67 Checking for pag
8df0: 65 3a 20 22 20 70 61 67 65 29 0a 20 20 28 6e 6f e: " page). (no
8e00: 74 20 28 6d 65 6d 62 65 72 20 70 61 67 65 20 28 t (member page (
8e10: 73 64 61 74 2d 67 65 74 2d 73 65 65 6e 2d 70 61 sdat-get-seen-pa
8e20: 67 65 73 20 73 65 6c 66 29 29 29 29 0a 0a 28 64 ges self))))..(d
8e30: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 efine (session:s
8e40: 65 74 2d 63 61 6c 6c 65 64 21 20 73 65 6c 66 20 et-called! self
8e50: 70 61 67 65 29 0a 20 20 28 73 64 61 74 2d 73 65 page). (sdat-se
8e60: 74 2d 73 65 65 6e 2d 70 61 67 65 73 21 20 73 65 t-seen-pages! se
8e70: 6c 66 20 28 63 6f 6e 73 20 70 61 67 65 20 28 73 lf (cons page (s
8e80: 64 61 74 2d 67 65 74 2d 73 65 65 6e 2d 70 61 67 dat-get-seen-pag
8e90: 65 73 20 73 65 6c 66 29 29 29 29 0a 0a 3b 3b 3d es self))))..;;=
8ea0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8eb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8ec0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8ed0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8ee0: 3d 3d 3d 3d 3d 0a 3b 3b 20 41 6c 74 65 72 6e 61 =====.;; Alterna
8ef0: 74 69 76 65 20 64 61 74 61 20 74 79 70 65 20 64 tive data type d
8f00: 65 6c 69 76 65 72 79 0a 3b 3b 3d 3d 3d 3d 3d 3d elivery.;;======
8f10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8f20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8f30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8f40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8f50: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ..(define (sessi
8f60: 6f 6e 3a 61 6c 74 2d 6f 75 74 20 73 65 6c 66 29 on:alt-out self)
8f70: 0a 20 20 28 6c 65 74 20 28 28 64 61 74 20 28 73 . (let ((dat (s
8f80: 64 61 74 2d 67 65 74 2d 61 6c 74 2d 70 61 67 65 dat-get-alt-page
8f90: 2d 64 61 74 20 73 65 6c 66 29 29 29 0a 20 20 20 -dat self))).
8fa0: 20 3b 3b 20 28 73 3a 6c 6f 67 20 22 64 61 74 20 ;; (s:log "dat
8fb0: 69 73 3a 20 22 20 64 61 74 29 0a 20 20 20 20 3b is: " dat). ;
8fc0: 3b 20 28 70 72 69 6e 74 20 22 48 54 54 50 2f 31 ; (print "HTTP/1
8fd0: 2e 31 20 32 30 30 20 4f 4b 22 29 0a 20 20 20 20 .1 200 OK").
8fe0: 28 70 72 69 6e 74 20 22 44 61 74 65 3a 20 22 20 (print "Date: "
8ff0: 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 20 28 73 (time->string (s
9000: 65 63 6f 6e 64 73 2d 3e 75 74 63 2d 74 69 6d 65 econds->utc-time
9010: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
9020: 73 29 29 29 29 0a 20 20 20 20 28 70 72 69 6e 74 s)))). (print
9030: 20 22 43 6f 6e 74 65 6e 74 2d 54 79 70 65 3a 20 "Content-Type:
9040: 22 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 74 " (sdat-get-cont
9050: 65 6e 74 2d 74 79 70 65 20 73 65 6c 66 29 29 0a ent-type self)).
9060: 20 20 20 20 28 70 72 69 6e 74 20 22 41 63 63 65 (print "Acce
9070: 70 74 2d 52 61 6e 67 65 73 3a 20 62 79 74 65 73 pt-Ranges: bytes
9080: 22 29 0a 20 20 20 20 28 70 72 69 6e 74 20 22 43 "). (print "C
9090: 6f 6e 74 65 6e 74 2d 4c 65 6e 67 74 68 3a 20 22 ontent-Length: "
90a0: 20 28 69 66 20 28 62 6c 6f 62 3f 20 64 61 74 29 (if (blob? dat)
90b0: 0a 09 09 09 09 20 20 28 62 6c 6f 62 2d 73 69 7a ..... (blob-siz
90c0: 65 20 64 61 74 29 0a 09 09 09 09 20 20 30 29 29 e dat)..... 0))
90d0: 0a 20 20 20 20 28 70 72 69 6e 74 20 22 4b 65 65 . (print "Kee
90e0: 70 2d 41 6c 69 76 65 3a 20 74 69 6d 65 6f 75 74 p-Alive: timeout
90f0: 3d 31 35 2c 20 6d 61 78 3d 31 30 30 22 29 0a 20 =15, max=100").
9100: 20 20 20 28 70 72 69 6e 74 20 22 43 6f 6e 6e 65 (print "Conne
9110: 63 74 69 6f 6e 3a 20 4b 65 65 70 2d 41 6c 69 76 ction: Keep-Aliv
9120: 65 22 29 0a 20 20 20 20 28 70 72 69 6e 74 20 22 e"). (print "
9130: 22 29 0a 20 20 20 20 28 77 72 69 74 65 2d 73 74 "). (write-st
9140: 72 69 6e 67 20 28 62 6c 6f 62 2d 3e 73 74 72 69 ring (blob->stri
9150: 6e 67 20 64 61 74 29 20 23 66 20 28 63 75 72 72 ng dat) #f (curr
9160: 65 6e 74 2d 6f 75 74 70 75 74 2d 70 6f 72 74 29 ent-output-port)
9170: 29 29 29 0a ))).