Artifact
2b15eaba58e0017024fcba56dc6bd5f9bf45a70e:
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: 73 64 61 74 2d 73 65 74 2d 66 6f 72 63 65 2d 73 sdat-set-force-s
1fc0: 73 6c 21 20 20 20 20 20 20 20 20 20 20 73 65 6c sl! sel
1fd0: 66 20 23 66 29 0a 20 20 28 6c 65 74 2a 20 28 28 f #f). (let* ((
1fe0: 72 61 77 63 6f 6e 66 69 67 64 61 74 20 28 73 65 rawconfigdat (se
1ff0: 73 73 69 6f 6e 3a 72 65 61 64 2d 63 6f 6e 66 69 ssion:read-confi
2000: 67 20 73 65 6c 66 29 29 0a 09 20 28 63 6f 6e 66 g self)).. (conf
2010: 69 67 64 61 74 20 28 69 66 20 72 61 77 63 6f 6e igdat (if rawcon
2020: 66 69 67 64 61 74 20 28 65 76 61 6c 20 72 61 77 figdat (eval raw
2030: 63 6f 6e 66 69 67 64 61 74 29 20 27 28 29 29 29 configdat) '()))
2040: 0a 09 20 28 73 72 6f 6f 74 20 20 20 20 20 28 73 .. (sroot (s
2050: 3a 66 69 6e 64 2d 70 61 72 61 6d 20 27 73 72 6f :find-param 'sro
2060: 6f 74 20 20 20 20 63 6f 6e 66 69 67 64 61 74 29 ot configdat)
2070: 29 0a 09 20 28 6c 6f 67 66 69 6c 65 20 20 20 28 ).. (logfile (
2080: 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 27 6c 6f s:find-param 'lo
2090: 67 66 69 6c 65 20 20 63 6f 6e 66 69 67 64 61 74 gfile configdat
20a0: 29 29 0a 09 20 28 64 62 74 79 70 65 20 20 20 20 )).. (dbtype
20b0: 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 27 64 (s:find-param 'd
20c0: 62 74 79 70 65 20 20 20 63 6f 6e 66 69 67 64 61 btype configda
20d0: 74 29 29 0a 09 20 28 64 62 69 6e 69 74 20 20 20 t)).. (dbinit
20e0: 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 27 (s:find-param '
20f0: 64 62 69 6e 69 74 20 20 20 63 6f 6e 66 69 67 64 dbinit configd
2100: 61 74 29 29 0a 09 20 28 64 6f 6d 61 69 6e 20 20 at)).. (domain
2110: 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 (s:find-param
2120: 27 64 6f 6d 61 69 6e 20 20 20 63 6f 6e 66 69 67 'domain config
2130: 64 61 74 29 29 0a 09 20 28 74 77 69 6b 69 64 69 dat)).. (twikidi
2140: 72 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d r (s:find-param
2150: 20 27 74 77 69 6b 69 64 69 72 20 63 6f 6e 66 69 'twikidir confi
2160: 67 64 61 74 29 29 0a 09 20 28 70 61 67 65 2d 64 gdat)).. (page-d
2170: 69 72 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 ir (s:find-para
2180: 6d 20 27 70 61 67 65 2d 64 69 72 2d 73 74 79 6c m 'page-dir-styl
2190: 65 20 63 6f 6e 66 69 67 64 61 74 29 29 0a 09 20 e configdat))..
21a0: 28 64 65 62 75 67 6d 6f 64 65 20 28 73 3a 66 69 (debugmode (s:fi
21b0: 6e 64 2d 70 61 72 61 6d 20 27 64 65 62 75 67 6d nd-param 'debugm
21c0: 6f 64 65 20 63 6f 6e 66 69 67 64 61 74 29 29 0a ode configdat)).
21d0: 20 20 20 20 20 20 20 20 20 28 73 63 72 69 70 74 (script
21e0: 20 20 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 (s:find-para
21f0: 6d 20 27 73 63 72 69 70 74 20 20 20 20 63 6f 6e m 'script con
2200: 66 69 67 64 61 74 29 29 0a 09 20 28 66 6f 72 63 figdat)).. (forc
2210: 65 2d 73 73 6c 20 28 73 3a 66 69 6e 64 2d 70 61 e-ssl (s:find-pa
2220: 72 61 6d 20 27 66 6f 72 63 65 2d 73 73 6c 20 63 ram 'force-ssl c
2230: 6f 6e 66 69 67 64 61 74 29 29 29 0a 20 20 20 20 onfigdat))).
2240: 28 69 66 20 73 72 6f 6f 74 20 20 20 20 28 73 64 (if sroot (sd
2250: 61 74 2d 73 65 74 2d 73 72 6f 6f 74 21 20 20 20 at-set-sroot!
2260: 20 73 65 6c 66 20 73 72 6f 6f 74 29 29 0a 20 20 self sroot)).
2270: 20 20 28 69 66 20 6c 6f 67 66 69 6c 65 20 20 28 (if logfile (
2280: 73 64 61 74 2d 73 65 74 2d 6c 6f 67 66 69 6c 65 sdat-set-logfile
2290: 21 20 20 73 65 6c 66 20 6c 6f 67 66 69 6c 65 29 ! self logfile)
22a0: 29 0a 20 20 20 20 28 69 66 20 64 62 74 79 70 65 ). (if dbtype
22b0: 20 20 20 28 73 64 61 74 2d 73 65 74 2d 64 62 74 (sdat-set-dbt
22c0: 79 70 65 21 20 20 20 73 65 6c 66 20 64 62 74 79 ype! self dbty
22d0: 70 65 29 29 0a 20 20 20 20 28 69 66 20 64 62 69 pe)). (if dbi
22e0: 6e 69 74 20 20 20 28 73 64 61 74 2d 73 65 74 2d nit (sdat-set-
22f0: 64 62 69 6e 69 74 21 20 20 20 73 65 6c 66 20 64 dbinit! self d
2300: 62 69 6e 69 74 29 29 0a 20 20 20 20 28 69 66 20 binit)). (if
2310: 64 6f 6d 61 69 6e 20 20 20 28 73 64 61 74 2d 73 domain (sdat-s
2320: 65 74 2d 64 6f 6d 61 69 6e 21 20 20 20 73 65 6c et-domain! sel
2330: 66 20 64 6f 6d 61 69 6e 29 29 0a 20 20 20 20 28 f domain)). (
2340: 69 66 20 74 77 69 6b 69 64 69 72 20 28 73 64 61 if twikidir (sda
2350: 74 2d 73 65 74 2d 74 77 69 6b 69 64 69 72 21 20 t-set-twikidir!
2360: 73 65 6c 66 20 74 77 69 6b 69 64 69 72 29 29 0a self twikidir)).
2370: 20 20 20 20 28 69 66 20 64 65 62 75 67 6d 6f 64 (if debugmod
2380: 65 20 28 73 64 61 74 2d 73 65 74 2d 64 65 62 75 e (sdat-set-debu
2390: 67 6d 6f 64 65 21 20 73 65 6c 66 20 64 65 62 75 gmode! self debu
23a0: 67 6d 6f 64 65 29 29 0a 20 20 20 20 28 69 66 20 gmode)). (if
23b0: 73 63 72 69 70 74 20 20 20 20 28 73 64 61 74 2d script (sdat-
23c0: 73 65 74 2d 73 63 72 69 70 74 21 20 20 20 20 73 set-script! s
23d0: 65 6c 66 20 73 63 72 69 70 74 29 29 0a 20 20 20 elf script)).
23e0: 20 28 69 66 20 66 6f 72 63 65 2d 73 73 6c 20 28 (if force-ssl (
23f0: 73 64 61 74 2d 73 65 74 2d 66 6f 72 63 65 2d 73 sdat-set-force-s
2400: 73 6c 21 20 73 65 6c 66 20 66 6f 72 63 65 2d 73 sl! self force-s
2410: 73 6c 29 29 0a 20 20 20 20 28 73 64 61 74 2d 73 sl)). (sdat-s
2420: 65 74 2d 70 61 67 65 2d 64 69 72 2d 73 74 79 6c et-page-dir-styl
2430: 65 21 20 73 65 6c 66 20 70 61 67 65 2d 64 69 72 e! self page-dir
2440: 29 0a 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 ). ;; (print
2450: 22 63 6f 6e 66 69 67 64 61 74 3a 20 22 29 28 70 "configdat: ")(p
2460: 70 20 63 6f 6e 66 69 67 64 61 74 29 0a 20 20 20 p configdat).
2470: 20 28 69 66 20 64 65 62 75 67 6d 6f 64 65 0a 09 (if debugmode..
2480: 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c (session:log sel
2490: 66 20 22 73 72 6f 6f 74 3a 20 22 20 73 72 6f 6f f "sroot: " sroo
24a0: 74 20 22 20 6c 6f 67 66 69 6c 65 3a 20 22 20 6c t " logfile: " l
24b0: 6f 67 66 69 6c 65 20 22 20 64 62 74 79 70 65 3a ogfile " dbtype:
24c0: 20 22 20 64 62 74 79 70 65 20 0a 09 09 20 20 20 " dbtype ...
24d0: 20 20 22 20 64 62 69 6e 69 74 3a 20 22 20 64 62 " dbinit: " db
24e0: 69 6e 69 74 20 22 20 64 6f 6d 61 69 6e 3a 20 22 init " domain: "
24f0: 20 64 6f 6d 61 69 6e 20 22 20 70 61 67 65 2d 64 domain " page-d
2500: 69 72 2d 73 74 79 6c 65 3a 20 22 20 70 61 67 65 ir-style: " page
2510: 2d 64 69 72 29 29 0a 20 20 20 20 29 0a 20 20 28 -dir)). ). (
2520: 73 64 61 74 2d 73 65 74 2d 73 68 61 72 65 64 2d sdat-set-shared-
2530: 68 61 73 68 21 20 73 65 6c 66 20 28 6d 61 6b 65 hash! self (make
2540: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 -hash-table)).
2550: 29 0a 0a 3b 3b 20 55 73 65 64 20 66 6f 72 20 74 )..;; Used for t
2560: 68 65 20 73 74 72 61 6e 67 65 6c 79 20 69 6e 63 he strangely inc
2570: 6f 6e 73 69 73 74 65 6e 74 20 68 61 6e 64 6c 69 onsistent handli
2580: 6e 67 20 6f 66 20 74 68 65 20 63 6f 6e 66 69 67 ng of the config
2590: 20 66 69 6c 65 2e 20 41 20 62 65 74 74 65 72 20 file. A better
25a0: 77 61 79 20 69 73 20 6e 65 65 64 65 64 2e 0a 3b way is needed..;
25b0: 3b 0a 3b 3b 20 20 20 28 6c 65 74 20 28 28 64 62 ;.;; (let ((db
25c0: 74 79 70 65 20 28 73 64 61 74 2d 67 65 74 2d 64 type (sdat-get-d
25d0: 62 74 79 70 65 20 73 65 6c 66 29 29 29 0a 3b 3b btype self))).;;
25e0: 20 20 20 20 20 28 70 72 69 6e 74 20 22 64 62 74 (print "dbt
25f0: 79 70 65 3a 20 22 20 64 62 74 79 70 65 29 0a 3b ype: " dbtype).;
2600: 3b 20 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d ; (sdat-set-
2610: 64 62 74 79 70 65 21 20 73 65 6c 66 20 28 65 76 dbtype! self (ev
2620: 61 6c 20 64 62 74 79 70 65 29 29 29 29 0a 0a 28 al dbtype))))..(
2630: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
2640: 73 65 74 75 70 20 73 65 6c 66 29 0a 20 20 28 6c setup self). (l
2650: 65 74 20 28 28 64 62 74 79 70 65 20 20 20 20 28 et ((dbtype (
2660: 73 64 61 74 2d 67 65 74 2d 64 62 74 79 70 65 20 sdat-get-dbtype
2670: 73 65 6c 66 29 29 0a 09 28 64 65 62 75 67 6d 6f self))..(debugmo
2680: 64 65 20 28 73 64 61 74 2d 67 65 74 2d 64 65 62 de (sdat-get-deb
2690: 75 67 6d 6f 64 65 20 73 65 6c 66 29 29 0a 09 28 ugmode self))..(
26a0: 64 62 69 6e 69 74 20 20 20 20 28 65 76 61 6c 20 dbinit (eval
26b0: 28 73 64 61 74 2d 67 65 74 2d 64 62 69 6e 69 74 (sdat-get-dbinit
26c0: 20 73 65 6c 66 29 29 29 0a 09 28 64 62 65 78 69 self)))..(dbexi
26d0: 73 74 73 20 20 23 66 29 29 0a 20 20 20 20 28 6c sts #f)). (l
26e0: 65 74 20 28 28 64 62 66 6e 61 6d 65 20 28 61 6c et ((dbfname (al
26f0: 69 73 74 2d 72 65 66 20 27 64 62 6e 61 6d 65 20 ist-ref 'dbname
2700: 64 62 69 6e 69 74 29 29 29 0a 20 20 20 20 20 20 dbinit))).
2710: 28 69 66 20 64 65 62 75 67 6d 6f 64 65 20 28 73 (if debugmode (s
2720: 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 ession:log self
2730: 22 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 20 64 "session:setup d
2740: 62 66 6e 61 6d 65 3d 22 20 64 62 66 6e 61 6d 65 bfname=" dbfname
2750: 20 22 2c 20 64 62 74 79 70 65 3d 22 20 64 62 74 ", dbtype=" dbt
2760: 79 70 65 20 22 2c 20 64 62 69 6e 69 74 3d 22 20 ype ", dbinit="
2770: 64 62 69 6e 69 74 29 29 0a 20 20 20 20 20 20 28 dbinit)). (
2780: 69 66 20 28 65 71 3f 20 64 62 74 79 70 65 20 27 if (eq? dbtype '
2790: 73 71 6c 69 74 65 33 29 0a 09 20 20 3b 3b 20 54 sqlite3).. ;; T
27a0: 68 65 20 27 61 75 74 6f 20 6d 65 74 68 6f 64 20 he 'auto method
27b0: 77 69 6c 6c 20 64 69 73 74 72 69 62 75 74 65 20 will distribute
27c0: 64 62 73 20 61 63 72 6f 73 73 20 74 68 65 20 64 dbs across the d
27d0: 69 73 6b 20 75 73 69 6e 67 20 68 61 73 68 0a 09 isk using hash..
27e0: 20 20 3b 3b 20 6f 66 20 75 73 65 72 20 68 6f 73 ;; of user hos
27f0: 74 20 61 6e 64 20 75 73 65 72 2e 20 54 4f 44 4f t and user. TODO
2800: 0a 09 20 20 3b 3b 20 28 69 66 20 28 65 71 3f 20 .. ;; (if (eq?
2810: 64 62 66 6e 61 6d 65 20 27 61 75 74 6f 29 20 3b dbfname 'auto) ;
2820: 3b 20 54 68 69 73 20 69 73 20 74 68 65 20 61 75 ; This is the au
2830: 74 6f 20 61 73 73 69 67 6e 6d 65 6e 74 20 6f 66 to assignment of
2840: 20 61 20 64 62 20 62 61 73 65 64 20 6f 6e 20 68 a db based on h
2850: 61 73 68 20 6f 66 20 49 50 0a 09 20 20 28 6c 65 ash of IP.. (le
2860: 74 20 28 28 64 62 70 61 74 68 20 28 70 61 74 68 t ((dbpath (path
2870: 6e 61 6d 65 2d 64 69 72 65 63 74 6f 72 79 20 64 name-directory d
2880: 62 66 6e 61 6d 65 29 29 29 20 20 3b 3b 20 64 6f bfname))) ;; do
2890: 20 61 20 63 6f 75 70 6c 65 20 73 61 6e 69 74 79 a couple sanity
28a0: 20 63 68 65 63 6b 73 20 68 65 72 65 20 74 6f 20 checks here to
28b0: 6d 61 6b 65 20 73 65 74 74 69 6e 67 20 75 70 20 make setting up
28c0: 65 61 73 69 65 72 0a 09 20 20 20 20 28 69 66 20 easier.. (if
28d0: 64 65 62 75 67 6d 6f 64 65 20 28 73 65 73 73 69 debugmode (sessi
28e0: 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 49 4e 46 on:log self "INF
28f0: 4f 3a 20 73 65 74 74 69 6e 67 20 75 70 20 66 6f O: setting up fo
2900: 72 20 73 71 6c 69 74 65 33 20 64 62 20 61 63 63 r sqlite3 db acc
2910: 65 73 73 20 74 6f 20 22 20 64 62 66 6e 61 6d 65 ess to " dbfname
2920: 29 29 0a 09 20 20 20 20 28 69 66 20 28 6e 6f 74 )).. (if (not
2930: 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 (file-write-acc
2940: 65 73 73 3f 20 64 62 70 61 74 68 29 29 0a 09 09 ess? dbpath))...
2950: 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c (session:log sel
2960: 66 20 22 57 41 52 4e 49 4e 47 3a 20 43 61 6e 6e f "WARNING: Cann
2970: 6f 74 20 77 72 69 74 65 20 74 6f 20 22 20 64 62 ot write to " db
2980: 70 61 74 68 29 0a 09 09 28 69 66 20 64 65 62 75 path)...(if debu
2990: 67 6d 6f 64 65 20 28 73 65 73 73 69 6f 6e 3a 6c gmode (session:l
29a0: 6f 67 20 73 65 6c 66 20 22 49 4e 46 4f 3a 20 22 og self "INFO: "
29b0: 20 64 62 70 61 74 68 20 22 20 69 73 20 77 72 69 dbpath " is wri
29c0: 74 65 61 62 6c 65 22 29 29 29 0a 09 20 20 20 20 teable")))..
29d0: 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 (if (file-exists
29e0: 3f 20 64 62 66 6e 61 6d 65 29 0a 09 09 28 62 65 ? dbfname)...(be
29f0: 67 69 6e 0a 09 09 20 20 3b 3b 20 28 73 65 73 73 gin... ;; (sess
2a00: 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 73 65 ion:log self "se
2a10: 74 74 69 6e 67 20 64 62 65 78 69 73 74 73 20 74 tting dbexists t
2a20: 6f 20 23 74 22 29 0a 09 09 20 20 28 73 65 74 21 o #t")... (set!
2a30: 20 64 62 65 78 69 73 74 73 20 23 74 29 29 29 29 dbexists #t))))
2a40: 0a 09 20 20 28 69 66 20 64 65 62 75 67 6d 6f 64 .. (if debugmod
2a50: 65 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 e (session:log s
2a60: 65 6c 66 20 22 49 4e 46 4f 3a 20 73 65 74 74 69 elf "INFO: setti
2a70: 6e 67 20 75 70 20 66 6f 72 20 70 67 20 64 62 20 ng up for pg db
2a80: 61 63 63 65 73 73 20 74 6f 20 61 63 63 6f 75 6e access to accoun
2a90: 74 20 69 6e 66 6f 20 22 20 64 62 69 6e 69 74 29 t info " dbinit)
2aa0: 29 29 0a 20 20 20 20 20 20 28 69 66 20 64 65 62 )). (if deb
2ab0: 75 67 6d 6f 64 65 20 28 73 65 73 73 69 6f 6e 3a ugmode (session:
2ac0: 6c 6f 67 20 73 65 6c 66 20 22 64 62 74 79 70 65 log self "dbtype
2ad0: 3a 20 22 20 64 62 74 79 70 65 20 22 20 64 62 66 : " dbtype " dbf
2ae0: 6e 61 6d 65 3a 20 22 20 64 62 66 6e 61 6d 65 20 name: " dbfname
2af0: 22 20 64 62 65 78 69 73 74 73 3a 20 22 20 64 62 " dbexists: " db
2b00: 65 78 69 73 74 73 29 29 29 0a 20 20 20 20 28 73 exists))). (s
2b10: 64 61 74 2d 73 65 74 2d 63 6f 6e 6e 21 20 73 65 dat-set-conn! se
2b20: 6c 66 20 28 64 62 69 3a 6f 70 65 6e 20 64 62 74 lf (dbi:open dbt
2b30: 79 70 65 20 64 62 69 6e 69 74 29 29 0a 20 20 20 ype dbinit)).
2b40: 20 28 73 65 74 21 20 2a 64 62 2a 20 28 73 64 61 (set! *db* (sda
2b50: 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 t-get-conn self)
2b60: 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 ). (if (and (
2b70: 6e 6f 74 20 64 62 65 78 69 73 74 73 29 28 65 71 not dbexists)(eq
2b80: 3f 20 64 62 74 79 70 65 20 27 73 71 6c 69 74 65 ? dbtype 'sqlite
2b90: 33 29 29 0a 20 09 28 62 65 67 69 6e 0a 09 20 20 3)). .(begin..
2ba0: 28 70 72 69 6e 74 20 22 57 41 52 4e 49 4e 47 3a (print "WARNING:
2bb0: 20 53 65 74 74 69 6e 67 20 75 70 20 73 65 73 73 Setting up sess
2bc0: 69 6f 6e 20 64 62 20 77 69 74 68 20 73 71 6c 69 ion db with sqli
2bd0: 74 65 33 22 29 0a 09 20 20 28 73 65 73 73 69 6f te3").. (sessio
2be0: 6e 3a 73 65 74 75 70 2d 64 62 20 73 65 6c 66 29 n:setup-db self)
2bf0: 29 29 0a 20 20 20 20 28 73 65 73 73 69 6f 6e 3a )). (session:
2c00: 70 72 6f 63 65 73 73 2d 75 72 6c 2d 70 61 74 68 process-url-path
2c10: 20 73 65 6c 66 29 0a 20 20 20 20 28 73 65 73 73 self). (sess
2c20: 69 6f 6e 3a 73 65 74 75 70 2d 73 65 73 73 69 6f ion:setup-sessio
2c30: 6e 2d 6b 65 79 20 73 65 6c 66 29 0a 20 20 20 20 n-key self).
2c40: 3b 3b 20 63 61 70 74 75 72 65 20 73 74 64 69 6e ;; capture stdin
2c50: 20 69 66 20 74 68 69 73 20 69 73 20 61 20 50 4f if this is a PO
2c60: 53 54 0a 20 20 20 20 28 73 64 61 74 2d 73 65 74 ST. (sdat-set
2c70: 2d 72 65 71 75 65 73 74 2d 6d 65 74 68 6f 64 21 -request-method!
2c80: 20 73 65 6c 66 20 28 67 65 74 2d 65 6e 76 69 72 self (get-envir
2c90: 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 onment-variable
2ca0: 22 52 45 51 55 45 53 54 5f 4d 45 54 48 4f 44 22 "REQUEST_METHOD"
2cb0: 29 29 0a 20 20 20 20 28 73 64 61 74 2d 73 65 74 )). (sdat-set
2cc0: 2d 66 6f 72 6d 64 61 74 21 20 73 65 6c 66 20 28 -formdat! self (
2cd0: 66 6f 72 6d 64 61 74 3a 6c 6f 61 64 2d 61 6c 6c formdat:load-all
2ce0: 29 29 29 29 0a 0a 3b 3b 20 73 65 74 75 70 20 74 ))))..;; setup t
2cf0: 68 65 20 64 62 20 77 69 74 68 20 73 65 73 73 69 he db with sessi
2d00: 6f 6e 20 74 61 62 6c 65 73 2c 20 77 6f 72 6b 73 on tables, works
2d10: 20 66 6f 72 20 73 71 6c 69 74 65 20 6f 6e 6c 79 for sqlite only
2d20: 20 72 69 67 68 74 20 6e 6f 77 0a 28 64 65 66 69 right now.(defi
2d30: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 75 ne (session:setu
2d40: 70 2d 64 62 20 73 65 6c 66 29 0a 20 20 28 6c 65 p-db self). (le
2d50: 74 20 28 28 63 6f 6e 6e 20 28 73 64 61 74 2d 67 t ((conn (sdat-g
2d60: 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 29 0a et-conn self))).
2d70: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 (for-each .
2d80: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 73 74 6d (lambda (stm
2d90: 74 29 0a 20 20 20 20 20 20 20 28 64 62 69 3a 65 t). (dbi:e
2da0: 78 65 63 20 63 6f 6e 6e 20 73 74 6d 74 29 29 0a xec conn stmt)).
2db0: 20 20 20 20 20 28 6c 69 73 74 20 22 43 52 45 41 (list "CREA
2dc0: 54 45 20 54 41 42 4c 45 20 73 65 73 73 69 6f 6e TE TABLE session
2dd0: 5f 76 61 72 73 20 28 69 64 20 49 4e 54 45 47 45 _vars (id INTEGE
2de0: 52 20 50 52 49 4d 41 52 59 20 4b 45 59 2c 73 65 R PRIMARY KEY,se
2df0: 73 73 69 6f 6e 5f 69 64 20 49 4e 54 45 47 45 52 ssion_id INTEGER
2e00: 2c 70 61 67 65 20 54 45 58 54 2c 6b 65 79 20 54 ,page TEXT,key T
2e10: 45 58 54 2c 76 61 6c 75 65 20 54 45 58 54 29 3b EXT,value TEXT);
2e20: 22 0a 09 20 20 20 22 43 52 45 41 54 45 20 54 41 ".. "CREATE TA
2e30: 42 4c 45 20 73 65 73 73 69 6f 6e 73 20 28 69 64 BLE sessions (id
2e40: 20 49 4e 54 45 47 45 52 20 50 52 49 4d 41 52 59 INTEGER PRIMARY
2e50: 20 4b 45 59 2c 73 65 73 73 69 6f 6e 5f 6b 65 79 KEY,session_key
2e60: 20 54 45 58 54 2c 6c 61 73 74 5f 75 73 65 64 20 TEXT,last_used
2e70: 54 49 4d 45 53 54 41 4d 50 29 3b 22 0a 20 20 20 TIMESTAMP);".
2e80: 20 20 20 20 20 20 20 20 22 43 52 45 41 54 45 20 "CREATE
2e90: 54 41 42 4c 45 20 6d 65 74 61 64 61 74 61 20 28 TABLE metadata (
2ea0: 69 64 20 49 4e 54 45 47 45 52 20 50 52 49 4d 41 id INTEGER PRIMA
2eb0: 52 59 20 4b 45 59 2c 6b 65 79 20 54 45 58 54 2c RY KEY,key TEXT,
2ec0: 76 61 6c 75 65 20 54 45 58 54 29 3b 22 29 29 29 value TEXT);")))
2ed0: 29 0a 3b 3b 20 20 3b 3b 20 69 66 20 77 65 20 68 ).;; ;; if we h
2ee0: 61 76 65 20 61 20 73 65 73 73 69 6f 6e 5f 6b 65 ave a session_ke
2ef0: 79 20 6c 6f 6f 6b 20 75 70 20 74 68 65 20 73 65 y look up the se
2f00: 73 73 69 6f 6e 2d 69 64 20 61 6e 64 20 73 74 6f ssion-id and sto
2f10: 72 65 20 69 74 0a 3b 3b 20 20 28 73 64 61 74 2d re it.;; (sdat-
2f20: 73 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 21 20 set-session-id!
2f30: 73 65 6c 66 20 28 73 65 73 73 69 6f 6e 3a 67 65 self (session:ge
2f40: 74 2d 69 64 20 73 65 6c 66 29 29 29 0a 0a 3b 3b t-id self)))..;;
2f50: 20 6f 6e 6c 79 20 73 65 74 20 73 65 73 73 69 6f only set sessio
2f60: 6e 2d 63 6f 6f 6b 69 65 20 77 68 65 6e 20 61 20 n-cookie when a
2f70: 6e 65 77 20 73 65 73 73 69 6f 6e 20 69 73 20 63 new session is c
2f80: 72 65 61 74 65 64 0a 28 64 65 66 69 6e 65 20 28 reated.(define (
2f90: 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 2d 73 65 session:setup-se
2fa0: 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 20 ssion-key self)
2fb0: 20 0a 20 20 28 6c 65 74 2a 20 28 28 73 6b 20 20 . (let* ((sk
2fc0: 28 73 65 73 73 69 6f 6e 3a 65 78 74 72 61 63 74 (session:extract
2fd0: 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c -session-key sel
2fe0: 66 29 29 0a 20 20 20 20 20 20 20 20 20 28 73 69 f)). (si
2ff0: 64 20 28 69 66 20 73 6b 20 28 73 65 73 73 69 6f d (if sk (sessio
3000: 6e 3a 67 65 74 2d 69 64 20 73 65 6c 66 20 73 6b n:get-id self sk
3010: 29 20 23 66 29 29 29 0a 20 20 20 20 28 69 66 20 ) #f))). (if
3020: 28 6e 6f 74 20 73 69 64 29 20 3b 3b 20 6e 65 65 (not sid) ;; nee
3030: 64 20 61 20 6e 65 77 20 6b 65 79 0a 20 20 20 20 d a new key.
3040: 20 20 20 20 28 6c 65 74 2a 20 28 28 6e 65 77 2d (let* ((new-
3050: 6b 65 79 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 key (session:get
3060: 2d 6e 65 77 2d 6b 65 79 20 73 65 6c 66 29 29 0a -new-key self)).
3070: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
3080: 6e 65 77 2d 73 69 64 20 28 73 65 73 73 69 6f 6e new-sid (session
3090: 3a 67 65 74 2d 69 64 20 73 65 6c 66 20 6e 65 77 :get-id self new
30a0: 2d 6b 65 79 29 29 29 0a 20 20 20 20 20 20 20 20 -key))).
30b0: 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 (sdat-set-sess
30c0: 69 6f 6e 2d 6b 65 79 21 20 73 65 6c 66 20 6e 65 ion-key! self ne
30d0: 77 2d 6b 65 79 29 0a 20 20 20 20 20 20 20 20 20 w-key).
30e0: 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 (sdat-set-sessi
30f0: 6f 6e 2d 69 64 21 20 73 65 6c 66 20 6e 65 77 2d on-id! self new-
3100: 73 69 64 29 0a 20 20 20 20 20 20 20 20 20 20 28 sid). (
3110: 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e sdat-set-session
3120: 2d 63 6f 6f 6b 69 65 21 20 73 65 6c 66 20 28 73 -cookie! self (s
3130: 65 73 73 69 6f 6e 3a 6d 61 6b 65 2d 63 6f 6f 6b ession:make-cook
3140: 69 65 20 73 65 6c 66 29 29 29 0a 20 20 20 20 20 ie self))).
3150: 20 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 (sdat-set-ses
3160: 73 69 6f 6e 2d 69 64 21 20 73 65 6c 66 20 73 69 sion-id! self si
3170: 64 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 d))))..(define (
3180: 73 65 73 73 69 6f 6e 3a 6d 61 6b 65 2d 63 6f 6f session:make-coo
3190: 6b 69 65 20 73 65 6c 66 29 0a 20 20 3b 3b 20 28 kie self). ;; (
31a0: 6c 69 73 74 20 28 63 6f 6e 63 20 22 73 65 73 73 list (conc "sess
31b0: 69 6f 6e 5f 6b 65 79 3d 22 20 28 73 64 61 74 2d ion_key=" (sdat-
31c0: 67 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 get-session-key
31d0: 73 65 6c 66 29 20 22 3b 20 50 61 74 68 3d 2f 3b self) "; Path=/;
31e0: 20 44 6f 6d 61 69 6e 3d 2e 22 20 28 73 64 61 74 Domain=." (sdat
31f0: 2d 67 65 74 2d 64 6f 6d 61 69 6e 20 73 65 6c 66 -get-domain self
3200: 29 20 22 3b 20 4d 61 78 2d 41 67 65 3d 22 20 28 ) "; Max-Age=" (
3210: 2a 20 38 36 34 30 30 20 31 34 29 20 22 3b 20 56 * 86400 14) "; V
3220: 65 72 73 69 6f 6e 3d 31 22 29 29 29 20 0a 20 20 ersion=1"))) .
3230: 3b 3b 20 41 63 63 6f 72 64 69 6e 67 20 74 6f 20 ;; According to
3240: 0a 20 20 3b 3b 20 20 20 20 68 74 74 70 3a 2f 2f . ;; http://
3250: 77 77 77 2e 63 6f 64 65 6d 61 72 76 65 6c 73 2e www.codemarvels.
3260: 63 6f 6d 2f 32 30 31 30 2f 31 31 2f 61 70 61 63 com/2010/11/apac
3270: 68 65 2d 72 65 77 72 69 74 65 72 75 6c 65 2d 73 he-rewriterule-s
3280: 65 74 2d 61 2d 63 6f 6f 6b 69 65 2d 6f 6e 2d 6c et-a-cookie-on-l
3290: 6f 63 61 6c 68 6f 73 74 2f 0a 0a 20 20 3b 3b 20 ocalhost/.. ;;
32a0: 20 48 65 72 65 20 61 72 65 20 74 68 65 20 32 20 Here are the 2
32b0: 28 6f 66 74 65 6e 20 6c 65 66 74 20 6f 75 74 29 (often left out)
32c0: 20 72 65 71 75 69 72 65 6d 65 6e 74 73 20 74 6f requirements to
32d0: 20 73 65 74 20 61 20 63 6f 6f 6b 69 65 20 75 73 set a cookie us
32e0: 69 6e 67 0a 20 20 3b 3b 20 20 68 74 74 70 64 1b ing. ;; httpd.
32f0: 2d 46 ef bf bd 73 20 72 65 77 72 69 74 65 20 72 -F�s rewrite r
3300: 75 6c 65 20 28 6d 6f 64 5f 72 65 77 72 69 74 65 ule (mod_rewrite
3310: 29 2c 20 77 68 69 6c 65 20 77 6f 72 6b 69 6e 67 ), while working
3320: 20 6f 6e 20 6c 6f 63 61 6c 68 6f 73 74 3a 1b 2d on localhost:.-
3330: 41 0a 20 20 3b 3b 0a 20 20 3b 3b 20 20 55 73 65 A. ;;. ;; Use
3340: 20 74 68 65 20 49 50 20 31 32 37 2e 30 2e 30 2e the IP 127.0.0.
3350: 31 20 69 6e 73 74 65 61 64 20 6f 66 20 6c 6f 63 1 instead of loc
3360: 61 6c 68 6f 73 74 2f 6d 61 63 68 69 6e 65 2d 6e alhost/machine-n
3370: 61 6d 65 20 61 73 20 74 68 65 0a 20 20 3b 3b 20 ame as the. ;;
3380: 20 64 6f 6d 61 69 6e 3b 20 65 2e 67 2e 20 5b 43 domain; e.g. [C
3390: 4f 3d 73 6f 6d 65 43 6f 6f 6b 69 65 3a 73 6f 6d O=someCookie:som
33a0: 65 56 61 6c 75 65 3a 31 32 37 2e 30 2e 30 2e 31 eValue:127.0.0.1
33b0: 3a 32 3a 2f 5d 2c 20 77 68 69 63 68 20 73 61 79 :2:/], which say
33c0: 73 0a 20 20 3b 3b 20 20 63 72 65 61 74 65 20 61 s. ;; create a
33d0: 20 63 6f 6f 6b 69 65 20 1b 2d 59 ef bf bd 73 6f cookie .-Y�so
33e0: 6d 65 43 6f 6f 6b 69 65 ef bf bd 20 77 69 74 68 meCookie� with
33f0: 20 76 61 6c 75 65 20 ef bf bd 73 6f 6d 65 56 61 value �someVa
3400: 6c 75 65 ef bf bd 20 66 6f 72 20 74 68 65 0a 20 lue� for the.
3410: 20 3b 3b 20 20 64 6f 6d 61 69 6e 20 ef bf bd 31 ;; domain �1
3420: 32 37 2e 30 2e 30 2e 31 1b 24 42 21 6d 1b 28 42 27.0.0.1.$B!m.(B
3430: 20 68 61 76 69 6e 67 20 61 20 6c 69 66 65 20 74 having a life t
3440: 69 6d 65 20 6f 66 20 32 20 6d 69 6e 73 2c 20 66 ime of 2 mins, f
3450: 6f 72 20 61 6e 79 20 70 61 74 68 20 69 6e 0a 20 or any path in.
3460: 20 3b 3b 20 20 74 68 65 20 64 6f 6d 61 69 6e 20 ;; the domain
3470: 28 70 61 74 68 3d 2f 29 2e 20 28 4f 62 76 69 6f (path=/). (Obvio
3480: 75 73 6c 79 20 79 6f 75 20 77 69 6c 6c 20 68 61 usly you will ha
3490: 76 65 20 74 6f 20 72 75 6e 20 74 68 65 0a 20 20 ve to run the.
34a0: 3b 3b 20 20 61 70 70 6c 69 63 61 74 69 6f 6e 20 ;; application
34b0: 77 69 74 68 20 74 68 69 73 20 76 61 6c 75 65 20 with this value
34c0: 69 6e 20 74 68 65 20 55 52 4c 29 0a 20 20 3b 3b in the URL). ;;
34d0: 0a 20 20 3b 3b 20 20 54 6f 20 6d 61 6b 65 20 61 . ;; To make a
34e0: 20 73 65 73 73 69 6f 6e 20 63 6f 6f 6b 69 65 2c session cookie,
34f0: 20 6c 69 6d 69 74 20 74 68 65 20 66 6c 61 67 20 limit the flag
3500: 73 74 61 74 65 6d 65 6e 74 20 74 6f 20 6a 75 73 statement to jus
3510: 74 20 74 68 72 65 65 0a 20 20 3b 3b 20 20 61 74 t three. ;; at
3520: 74 72 69 62 75 74 65 73 3a 20 6e 61 6d 65 2c 20 tributes: name,
3530: 76 61 6c 75 65 20 61 6e 64 20 64 6f 6d 61 69 6e value and domain
3540: 2e 20 65 2e 67 0a 20 20 3b 3b 20 20 5b 43 4f 3d . e.g. ;; [CO=
3550: 73 6f 6d 65 43 6f 6f 6b 69 65 3a 73 6f 6d 65 56 someCookie:someV
3560: 61 6c 75 65 3a 31 32 37 2e 30 2e 30 2e 31 5d 20 alue:127.0.0.1]
3570: 1b 25 47 e2 80 93 1b 25 40 20 41 6e 79 20 66 75 .%G–.%@ Any fu
3580: 72 74 68 65 72 0a 20 20 3b 3b 20 20 73 65 74 74 rther. ;; sett
3590: 69 6e 67 73 2c 20 61 70 61 63 68 65 20 77 72 69 ings, apache wri
35a0: 74 65 73 20 61 6e ef bf bd 20 65 78 70 69 72 65 tes an� expire
35b0: 73 ef bf bd 20 61 74 74 72 69 62 75 74 65 20 66 s� attribute f
35c0: 6f 72 20 74 68 65 20 73 65 74 2d 63 6f 6f 6b 69 or the set-cooki
35d0: 65 0a 20 20 3b 3b 20 20 68 65 61 64 65 72 2c 20 e. ;; header,
35e0: 77 68 69 63 68 20 6d 61 6b 65 73 20 74 68 65 20 which makes the
35f0: 63 6f 6f 6b 69 65 20 61 20 70 65 72 73 69 73 74 cookie a persist
3600: 65 6e 74 20 6f 6e 65 20 28 6e 6f 74 20 72 65 61 ent one (not rea
3610: 6c 6c 79 0a 20 20 3b 3b 20 20 70 65 72 73 69 73 lly. ;; persis
3620: 74 65 6e 74 2c 20 61 73 20 74 68 65 20 65 78 70 tent, as the exp
3630: 69 72 65 73 20 76 61 6c 75 65 20 73 65 74 20 69 ires value set i
3640: 73 20 74 68 65 20 63 75 72 72 65 6e 74 20 73 65 s the current se
3650: 72 76 65 72 20 74 69 6d 65 0a 20 20 3b 3b 20 20 rver time. ;;
3660: 1b 25 47 e2 80 93 1b 25 40 20 73 6f 20 79 6f 75 .%G–.%@ so you
3670: 20 64 6f 6e 1b 2d 46 1b 2d 46 ef bf bd 74 20 65 don.-F.-F�t e
3680: 76 65 6e 20 67 65 74 20 74 6f 20 73 65 65 20 79 ven get to see y
3690: 6f 75 72 20 63 6f 6f 6b 69 65 21 29 1b 2d 41 0a our cookie!).-A.
36a0: 20 20 28 6c 69 73 74 20 28 73 74 72 69 6e 67 2d (list (string-
36b0: 73 75 62 73 74 69 74 75 74 65 20 0a 09 20 22 3b substitute .. ";
36c0: 22 20 22 3b 20 22 20 0a 09 20 28 63 61 72 20 28 " "; " .. (car (
36d0: 63 6f 6e 73 74 72 75 63 74 2d 63 6f 6f 6b 69 65 construct-cookie
36e0: 2d 73 74 72 69 6e 67 20 0a 09 20 20 20 20 20 20 -string ..
36f0: 20 3b 3b 20 77 61 72 6e 69 6e 67 21 20 6d 65 73 ;; warning! mes
3700: 73 69 6e 67 20 75 70 20 74 68 69 73 20 69 74 74 sing up this itt
3710: 79 20 62 69 74 74 79 20 62 69 74 20 6f 66 20 63 y bitty bit of c
3720: 6f 64 65 20 77 69 6c 6c 20 63 6f 73 74 20 6d 75 ode will cost mu
3730: 63 68 20 74 69 6d 65 21 0a 09 20 20 20 20 20 20 ch time!..
3740: 20 60 28 28 22 73 65 73 73 69 6f 6e 5f 6b 65 79 `(("session_key
3750: 22 20 2c 28 73 64 61 74 2d 67 65 74 2d 73 65 73 " ,(sdat-get-ses
3760: 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 0a 09 sion-key self)..
3770: 09 20 20 65 78 70 69 72 65 73 3a 20 2c 28 2b 20 . expires: ,(+
3780: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
3790: 29 20 28 2a 20 31 34 20 38 36 34 30 30 29 29 20 ) (* 14 86400))
37a0: 0a 09 09 20 20 3b 3b 20 6d 61 78 2d 61 67 65 3a ... ;; max-age:
37b0: 20 28 2a 20 31 34 20 38 36 34 30 30 29 0a 09 09 (* 14 86400)...
37c0: 20 20 70 61 74 68 3a 20 22 2f 22 20 3b 3b 20 0a path: "/" ;; .
37d0: 09 09 20 20 64 6f 6d 61 69 6e 3a 20 2c 28 73 74 .. domain: ,(st
37e0: 72 69 6e 67 2d 61 70 70 65 6e 64 20 22 2e 22 20 ring-append "."
37f0: 28 73 64 61 74 2d 67 65 74 2d 64 6f 6d 61 69 6e (sdat-get-domain
3800: 20 73 65 6c 66 29 29 0a 09 09 20 20 76 65 72 73 self))... vers
3810: 69 6f 6e 3a 20 31 29 29 20 30 29 29 29 29 29 0a ion: 1)) 0))))).
3820: 0a 3b 3b 20 6c 6f 6f 6b 20 75 70 20 61 20 67 69 .;; look up a gi
3830: 76 65 6e 20 73 65 73 73 69 6f 6e 20 6b 65 79 20 ven session key
3840: 61 6e 64 20 72 65 74 75 72 6e 20 74 68 65 20 69 and return the i
3850: 64 20 69 66 20 66 6f 75 6e 64 2c 20 23 66 20 69 d if found, #f i
3860: 66 20 6e 6f 74 20 66 6f 75 6e 64 0a 28 64 65 66 f not found.(def
3870: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 ine (session:get
3880: 2d 69 64 20 73 65 6c 66 20 73 65 73 73 69 6f 6e -id self session
3890: 2d 6b 65 79 29 0a 20 20 3b 3b 20 28 6c 65 74 20 -key). ;; (let
38a0: 28 28 73 65 73 73 69 6f 6e 2d 6b 65 79 20 28 73 ((session-key (s
38b0: 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 2d dat-get-session-
38c0: 6b 65 79 20 73 65 6c 66 29 29 29 0a 20 20 28 69 key self))). (i
38d0: 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 0a 20 20 f session-key.
38e0: 20 20 20 20 28 6c 65 74 20 28 28 71 75 65 72 79 (let ((query
38f0: 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 (string-append
3900: 22 53 45 4c 45 43 54 20 69 64 20 46 52 4f 4d 20 "SELECT id FROM
3910: 73 65 73 73 69 6f 6e 73 20 57 48 45 52 45 20 73 sessions WHERE s
3920: 65 73 73 69 6f 6e 5f 6b 65 79 3d 27 22 20 73 65 ession_key='" se
3930: 73 73 69 6f 6e 2d 6b 65 79 20 22 27 22 29 29 0a ssion-key "'")).
3940: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e (con
3950: 6e 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e n (sdat-get-conn
3960: 20 73 65 6c 66 29 29 0a 20 20 20 20 20 20 20 20 self)).
3970: 20 20 20 20 28 72 65 73 75 6c 74 20 23 66 29 29 (result #f))
3980: 0a 09 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d ..(dbi:for-each-
3990: 72 6f 77 20 0a 09 20 28 6c 61 6d 62 64 61 20 28 row .. (lambda (
39a0: 74 75 70 6c 65 29 0a 09 20 20 20 28 73 65 74 21 tuple).. (set!
39b0: 20 72 65 73 75 6c 74 20 28 76 65 63 74 6f 72 2d result (vector-
39c0: 72 65 66 20 74 75 70 6c 65 20 30 29 29 29 0a 09 ref tuple 0)))..
39d0: 20 63 6f 6e 6e 20 71 75 65 72 79 29 0a 09 28 69 conn query)..(i
39e0: 66 20 72 65 73 75 6c 74 20 28 64 62 69 3a 65 78 f result (dbi:ex
39f0: 65 63 20 63 6f 6e 6e 20 28 63 6f 6e 63 20 22 55 ec conn (conc "U
3a00: 50 44 41 54 45 20 73 65 73 73 69 6f 6e 73 20 53 PDATE sessions S
3a10: 45 54 20 6c 61 73 74 5f 75 73 65 64 3d 22 20 28 ET last_used=" (
3a20: 64 62 69 3a 6e 6f 77 20 63 6f 6e 6e 29 20 22 20 dbi:now conn) "
3a30: 57 48 45 52 45 20 73 65 73 73 69 6f 6e 5f 6b 65 WHERE session_ke
3a40: 79 3d 3f 3b 22 29 20 73 65 73 73 69 6f 6e 2d 6b y=?;") session-k
3a50: 65 79 29 29 0a 20 20 20 20 20 20 20 20 72 65 73 ey)). res
3a60: 75 6c 74 29 0a 20 20 20 20 20 20 23 66 29 29 0a ult). #f)).
3a70: 0a 3b 3b 20 0a 28 64 65 66 69 6e 65 20 28 73 65 .;; .(define (se
3a80: 73 73 69 6f 6e 3a 70 72 6f 63 65 73 73 2d 75 72 ssion:process-ur
3a90: 6c 2d 70 61 74 68 20 73 65 6c 66 29 0a 20 20 28 l-path self). (
3aa0: 6c 65 74 20 28 28 70 61 74 68 2d 69 6e 66 6f 20 let ((path-info
3ab0: 20 20 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d (get-environm
3ac0: 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 50 41 ent-variable "PA
3ad0: 54 48 5f 49 4e 46 4f 22 29 29 0a 09 28 71 75 65 TH_INFO"))..(que
3ae0: 72 79 2d 73 74 72 69 6e 67 20 28 67 65 74 2d 65 ry-string (get-e
3af0: 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 nvironment-varia
3b00: 62 6c 65 20 22 51 55 45 52 59 5f 53 54 52 49 4e ble "QUERY_STRIN
3b10: 47 22 29 29 29 0a 20 20 20 20 3b 3b 20 28 73 65 G"))). ;; (se
3b20: 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 ssion:log self "
3b30: 70 61 74 68 2d 69 6e 66 6f 3d 22 20 70 61 74 68 path-info=" path
3b40: 2d 69 6e 66 6f 20 22 20 71 75 65 72 79 2d 73 74 -info " query-st
3b50: 72 69 6e 67 3d 22 20 71 75 65 72 79 2d 73 74 72 ring=" query-str
3b60: 69 6e 67 29 0a 20 20 20 20 28 69 66 20 70 61 74 ing). (if pat
3b70: 68 2d 69 6e 66 6f 0a 09 28 6c 65 74 2a 20 28 28 h-info..(let* ((
3b80: 70 61 72 74 73 20 20 20 20 28 73 74 72 69 6e 67 parts (string
3b90: 2d 73 70 6c 69 74 20 70 61 74 68 2d 69 6e 66 6f -split path-info
3ba0: 20 22 2f 22 29 29 0a 09 20 20 20 20 20 20 20 28 "/")).. (
3bb0: 6e 75 6d 70 61 72 74 73 20 28 6c 65 6e 67 74 68 numparts (length
3bc0: 20 70 61 72 74 73 29 29 29 0a 09 20 20 28 69 66 parts))).. (if
3bd0: 20 28 3e 20 6e 75 6d 70 61 72 74 73 20 30 29 0a (> numparts 0).
3be0: 09 20 20 20 20 20 20 28 73 64 61 74 2d 73 65 74 . (sdat-set
3bf0: 2d 70 61 67 65 21 20 73 65 6c 66 20 28 63 61 72 -page! self (car
3c00: 20 70 61 72 74 73 29 29 29 0a 09 20 20 3b 3b 20 parts))).. ;;
3c10: 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c (session:log sel
3c20: 66 20 22 75 72 6c 2d 70 61 74 68 3d 22 20 75 72 f "url-path=" ur
3c30: 6c 2d 70 61 74 68 20 22 20 70 61 72 74 73 3d 22 l-path " parts="
3c40: 20 70 61 72 74 73 29 0a 09 20 20 28 69 66 20 28 parts).. (if (
3c50: 3e 20 6e 75 6d 70 61 72 74 73 20 31 29 0a 09 20 > numparts 1)..
3c60: 20 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d 70 (sdat-set-p
3c70: 61 74 68 2d 70 61 72 61 6d 73 21 20 73 65 6c 66 ath-params! self
3c80: 20 28 63 64 72 20 70 61 72 74 73 29 29 29 0a 20 (cdr parts))).
3c90: 20 20 20 20 20 20 20 20 20 28 69 66 20 71 75 65 (if que
3ca0: 72 79 2d 73 74 72 69 6e 67 0a 20 20 20 20 20 20 ry-string.
3cb0: 20 20 20 20 20 20 20 20 28 73 64 61 74 2d 73 65 (sdat-se
3cc0: 74 2d 70 61 72 61 6d 73 21 20 73 65 6c 66 20 28 t-params! self (
3cd0: 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 71 75 65 string-split que
3ce0: 72 79 2d 73 74 72 69 6e 67 20 22 26 22 29 29 29 ry-string "&")))
3cf0: 29 29 29 29 0a 0a 3b 3b 20 42 55 47 47 59 21 0a ))))..;; BUGGY!.
3d00: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
3d10: 3a 67 65 74 2d 6e 65 77 2d 6b 65 79 20 73 65 6c :get-new-key sel
3d20: 66 29 0a 20 20 28 6c 65 74 20 28 28 63 6f 6e 6e f). (let ((conn
3d30: 20 20 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e (sdat-get-con
3d40: 6e 20 73 65 6c 66 29 29 0a 20 20 20 20 20 20 20 n self)).
3d50: 20 28 74 6d 70 6b 65 79 20 28 73 65 73 73 69 6f (tmpkey (sessio
3d60: 6e 3a 6d 61 6b 65 2d 72 61 6e 64 2d 73 74 72 69 n:make-rand-stri
3d70: 6e 67 20 32 30 29 29 0a 20 20 20 20 20 20 20 20 ng 20)).
3d80: 28 73 74 61 74 75 73 20 23 66 29 29 0a 20 20 20 (status #f)).
3d90: 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 (dbi:for-each-r
3da0: 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c ow (lambda (tupl
3db0: 65 29 0a 09 09 09 28 73 65 74 21 20 73 74 61 74 e)....(set! stat
3dc0: 75 73 20 23 74 29 29 0a 09 09 20 20 20 20 20 20 us #t))...
3dd0: 63 6f 6e 6e 20 28 73 74 72 69 6e 67 2d 61 70 70 conn (string-app
3de0: 65 6e 64 20 22 49 4e 53 45 52 54 20 49 4e 54 4f end "INSERT INTO
3df0: 20 73 65 73 73 69 6f 6e 73 20 28 73 65 73 73 69 sessions (sessi
3e00: 6f 6e 5f 6b 65 79 29 20 56 41 4c 55 45 53 20 28 on_key) VALUES (
3e10: 27 22 20 74 6d 70 6b 65 79 20 22 27 29 22 29 29 '" tmpkey "')"))
3e20: 0a 20 20 20 20 74 6d 70 6b 65 79 29 29 0a 0a 3b . tmpkey))..;
3e30: 3b 20 72 65 74 75 72 6e 73 20 73 65 73 73 69 6f ; returns sessio
3e40: 6e 20 6b 65 79 20 49 46 46 20 69 74 20 69 73 20 n key IFF it is
3e50: 69 6e 20 74 68 65 20 48 54 54 50 5f 43 4f 4f 4b in the HTTP_COOK
3e60: 49 45 20 0a 28 64 65 66 69 6e 65 20 28 73 65 73 IE .(define (ses
3e70: 73 69 6f 6e 3a 65 78 74 72 61 63 74 2d 73 65 73 sion:extract-ses
3e80: 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 0a 20 sion-key self).
3e90: 20 28 6c 65 74 20 28 28 68 74 74 70 2d 63 6f 6f (let ((http-coo
3ea0: 6b 69 65 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e kie (get-environ
3eb0: 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 48 ment-variable "H
3ec0: 54 54 50 5f 43 4f 4f 4b 49 45 22 29 29 29 0a 20 TTP_COOKIE"))).
3ed0: 20 20 20 3b 3b 20 28 65 72 72 3a 6c 6f 67 20 22 ;; (err:log "
3ee0: 68 74 74 70 2d 63 6f 6f 6b 69 65 3a 20 22 20 68 http-cookie: " h
3ef0: 74 74 70 2d 63 6f 6f 6b 69 65 29 0a 20 20 20 20 ttp-cookie).
3f00: 28 69 66 20 68 74 74 70 2d 63 6f 6f 6b 69 65 0a (if http-cookie.
3f10: 20 20 20 20 20 20 20 20 28 73 65 73 73 69 6f 6e (session
3f20: 3a 65 78 74 72 61 63 74 2d 6b 65 79 2d 66 72 6f :extract-key-fro
3f30: 6d 2d 70 61 72 61 6d 20 73 65 6c 66 20 28 73 74 m-param self (st
3f40: 72 69 6e 67 2d 73 70 6c 69 74 2d 66 69 65 6c 64 ring-split-field
3f50: 73 20 20 22 3b 5c 5c 73 2b 22 20 68 74 74 70 2d s ";\\s+" http-
3f60: 63 6f 6f 6b 69 65 20 69 6e 66 69 78 3a 29 20 22 cookie infix:) "
3f70: 73 65 73 73 69 6f 6e 5f 6b 65 79 22 29 0a 20 20 session_key").
3f80: 20 20 20 20 20 20 23 66 29 29 29 0a 0a 28 64 65 #f)))..(de
3f90: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 fine (session:ge
3fa0: 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c t-session-id sel
3fb0: 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 0a 20 f session-key).
3fc0: 20 28 6c 65 74 20 28 28 71 75 65 72 79 20 22 53 (let ((query "S
3fd0: 45 4c 45 43 54 20 69 64 20 46 52 4f 4d 20 73 65 ELECT id FROM se
3fe0: 73 73 69 6f 6e 73 20 57 48 45 52 45 20 73 65 73 ssions WHERE ses
3ff0: 73 69 6f 6e 5f 6b 65 79 3d 3f 3b 22 29 0a 20 20 sion_key=?;").
4000: 20 20 20 20 20 20 28 72 65 73 75 6c 74 20 23 66 (result #f
4010: 29 29 0a 20 20 20 20 3b 3b 20 20 20 20 20 28 70 )). ;; (p
4020: 67 3a 71 75 65 72 79 2d 66 6f 72 2d 65 61 63 68 g:query-for-each
4030: 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 29 (lambda (tuple)
4040: 0a 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 . ;;
4050: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4060: 20 28 73 65 74 21 20 72 65 73 75 6c 74 20 28 76 (set! result (v
4070: 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 ector-ref tuple
4080: 30 29 29 29 20 3b 3b 20 28 76 65 63 74 6f 72 2d 0))) ;; (vector-
4090: 72 65 66 20 74 75 70 6c 65 20 30 29 29 29 0a 20 ref tuple 0))).
40a0: 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 ;;
40b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 3a (s:
40c0: 73 71 6c 70 61 72 61 6d 20 71 75 65 72 79 20 73 sqlparam query s
40d0: 65 73 73 69 6f 6e 2d 6b 65 79 29 0a 20 20 20 20 ession-key).
40e0: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
40f0: 20 20 20 20 20 20 20 20 20 20 28 73 64 61 74 2d (sdat-
4100: 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 0a get-conn self)).
4110: 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 ;;
4120: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 63 6f co
4130: 6e 6e 29 0a 20 20 20 20 28 64 62 69 3a 66 6f 72 nn). (dbi:for
4140: 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 6d 62 64 -each-row (lambd
4150: 61 20 28 74 75 70 6c 65 29 0a 09 09 09 28 73 65 a (tuple)....(se
4160: 74 21 20 72 65 73 75 6c 74 20 28 76 65 63 74 6f t! result (vecto
4170: 72 2d 72 65 66 20 74 75 70 6c 65 20 30 29 29 29 r-ref tuple 0)))
4180: 20 3b 3b 20 28 76 65 63 74 6f 72 2d 72 65 66 20 ;; (vector-ref
4190: 74 75 70 6c 65 20 30 29 29 29 0a 09 09 20 20 20 tuple 0)))...
41a0: 20 20 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e (sdat-get-con
41b0: 6e 20 73 65 6c 66 29 0a 09 09 20 20 20 20 20 20 n self)...
41c0: 28 73 3a 73 71 6c 70 61 72 61 6d 20 71 75 65 72 (s:sqlparam quer
41d0: 79 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 0a y session-key)).
41e0: 20 20 20 20 72 65 73 75 6c 74 29 29 0a 0a 3b 3b result))..;;
41f0: 20 64 65 6c 65 74 65 20 61 6c 6c 20 72 65 63 6f delete all reco
4200: 72 64 73 20 66 6f 72 20 61 20 73 65 73 73 69 6f rds for a sessio
4210: 6e 0a 3b 3b 20 0a 3b 3b 20 4e 45 45 44 53 20 54 n.;; .;; NEEDS T
4220: 4f 20 42 45 20 54 52 41 4e 53 41 43 54 49 4f 4e O BE TRANSACTION
4230: 49 5a 45 44 21 0a 3b 3b 0a 28 64 65 66 69 6e 65 IZED!.;;.(define
4240: 20 28 73 65 73 73 69 6f 6e 3a 64 65 6c 65 74 65 (session:delete
4250: 2d 73 65 73 73 69 6f 6e 20 73 65 6c 66 20 73 65 -session self se
4260: 73 73 69 6f 6e 2d 6b 65 79 29 0a 20 20 28 6c 65 ssion-key). (le
4270: 74 20 28 28 73 65 73 73 69 6f 6e 2d 69 64 20 28 t ((session-id (
4280: 73 65 73 73 69 6f 6e 3a 67 65 74 2d 73 65 73 73 session:get-sess
4290: 69 6f 6e 2d 69 64 20 73 65 6c 66 20 73 65 73 73 ion-id self sess
42a0: 69 6f 6e 2d 6b 65 79 29 29 0a 20 20 20 20 20 20 ion-key)).
42b0: 20 20 28 71 72 79 31 20 20 20 20 20 20 20 20 3b (qry1 ;
42c0: 3b 20 28 63 6f 6e 63 20 22 42 45 47 49 4e 3b 22 ; (conc "BEGIN;"
42d0: 0a 09 09 09 20 20 22 44 45 4c 45 54 45 20 46 52 .... "DELETE FR
42e0: 4f 4d 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 OM session_vars
42f0: 57 48 45 52 45 20 73 65 73 73 69 6f 6e 5f 69 64 WHERE session_id
4300: 3d 3f 3b 22 29 0a 09 28 71 72 79 32 20 20 20 20 =?;")..(qry2
4310: 20 20 20 20 20 20 20 20 20 22 44 45 4c 45 54 45 "DELETE
4320: 20 46 52 4f 4d 20 73 65 73 73 69 6f 6e 73 20 57 FROM sessions W
4330: 48 45 52 45 20 69 64 3d 3f 3b 22 29 0a 09 09 20 HERE id=?;")...
4340: 20 20 20 20 3b 3b 20 20 22 43 4f 4d 4d 49 54 3b ;; "COMMIT;
4350: 22 29 29 0a 20 20 20 20 20 20 20 20 28 63 6f 6e ")). (con
4360: 6e 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 n (
4370: 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 sdat-get-conn se
4380: 6c 66 29 29 29 0a 20 20 20 20 28 69 66 20 73 65 lf))). (if se
4390: 73 73 69 6f 6e 2d 69 64 0a 20 20 20 20 20 20 20 ssion-id.
43a0: 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 (begin.
43b0: 20 20 28 64 62 69 3a 65 78 65 63 20 63 6f 6e 6e (dbi:exec conn
43c0: 20 71 72 79 31 20 73 65 73 73 69 6f 6e 2d 69 64 qry1 session-id
43d0: 29 20 3b 3b 20 73 65 73 73 69 6f 6e 2d 69 64 29 ) ;; session-id)
43e0: 0a 09 20 20 28 64 62 69 3a 65 78 65 63 20 63 6f .. (dbi:exec co
43f0: 6e 6e 20 71 72 79 32 20 73 65 73 73 69 6f 6e 2d nn qry2 session-
4400: 69 64 29 0a 09 20 20 28 73 65 73 73 69 6f 6e 3a id).. (session:
4410: 69 6e 69 74 69 61 6c 69 7a 65 20 73 65 6c 66 29 initialize self)
4420: 0a 09 20 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 .. (session:set
4430: 75 70 20 73 65 6c 66 29 29 29 0a 20 20 20 20 28 up self))). (
4440: 6e 6f 74 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 not (session:get
4450: 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 -session-id self
4460: 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 29 29 session-key))))
4470: 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 65 ..;; (define (se
4480: 73 73 69 6f 6e 3a 64 65 6c 65 74 65 2d 73 65 73 ssion:delete-ses
4490: 73 69 6f 6e 20 73 65 6c 66 20 73 65 73 73 69 6f sion self sessio
44a0: 6e 2d 6b 65 79 29 0a 3b 3b 20 20 20 28 6c 65 74 n-key).;; (let
44b0: 20 28 28 73 65 73 73 69 6f 6e 2d 69 64 20 28 73 ((session-id (s
44c0: 65 73 73 69 6f 6e 3a 67 65 74 2d 73 65 73 73 69 ession:get-sessi
44d0: 6f 6e 2d 69 64 20 73 65 6c 66 20 73 65 73 73 69 on-id self sessi
44e0: 6f 6e 2d 6b 65 79 29 29 0a 3b 3b 20 20 20 20 20 on-key)).;;
44f0: 20 20 20 20 28 71 75 65 72 69 65 73 20 20 20 20 (queries
4500: 28 6c 69 73 74 20 22 42 45 47 49 4e 3b 22 0a 3b (list "BEGIN;".;
4510: 3b 20 09 09 09 20 20 22 44 45 4c 45 54 45 20 46 ; ... "DELETE F
4520: 52 4f 4d 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 ROM session_vars
4530: 20 57 48 45 52 45 20 73 65 73 73 69 6f 6e 5f 69 WHERE session_i
4540: 64 3d 3f 3b 22 0a 3b 3b 20 20 20 20 20 20 20 20 d=?;".;;
4550: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4560: 20 20 20 22 44 45 4c 45 54 45 20 46 52 4f 4d 20 "DELETE FROM
4570: 73 65 73 73 69 6f 6e 73 20 57 48 45 52 45 20 69 sessions WHERE i
4580: 64 3d 3f 3b 22 0a 3b 3b 20 09 09 09 20 20 22 43 d=?;".;; ... "C
4590: 4f 4d 4d 49 54 3b 22 29 29 0a 3b 3b 20 20 20 20 OMMIT;")).;;
45a0: 20 20 20 20 20 28 63 6f 6e 6e 20 20 20 20 20 20 (conn
45b0: 20 20 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 (sdat-ge
45c0: 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 29 0a 3b t-conn self))).;
45d0: 3b 20 20 20 20 20 28 69 66 20 73 65 73 73 69 6f ; (if sessio
45e0: 6e 2d 69 64 0a 3b 3b 20 20 20 20 20 20 20 20 20 n-id.;;
45f0: 28 62 65 67 69 6e 0a 3b 3b 20 20 20 20 20 20 20 (begin.;;
4600: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 3b 3b (for-each.;;
4610: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 61 6d (lam
4620: 62 64 61 20 28 71 75 65 72 79 29 0a 3b 3b 20 20 bda (query).;;
4630: 20 20 20 20 20 20 20 20 20 20 20 20 28 64 62 69 (dbi
4640: 3a 65 78 65 63 20 63 6f 6e 6e 20 71 75 65 72 79 :exec conn query
4650: 20 73 65 73 73 69 6f 6e 2d 69 64 29 29 0a 3b 3b session-id)).;;
4660: 20 09 20 20 20 71 75 65 72 69 65 73 29 0a 3b 3b . queries).;;
4670: 20 09 20 20 28 69 6e 69 74 69 61 6c 69 7a 65 20 . (initialize
4680: 73 65 6c 66 20 27 28 29 29 0a 3b 3b 20 09 20 20 self '()).;; .
4690: 28 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 20 73 (session:setup s
46a0: 65 6c 66 29 29 29 0a 3b 3b 20 20 20 20 20 28 6e elf))).;; (n
46b0: 6f 74 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d ot (session:get-
46c0: 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 20 session-id self
46d0: 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 29 29 0a session-key)))).
46e0: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
46f0: 6e 3a 65 78 74 72 61 63 74 2d 6b 65 79 20 73 65 n:extract-key se
4700: 6c 66 20 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 lf key). (let (
4710: 28 70 61 72 61 6d 73 20 28 73 64 61 74 2d 67 65 (params (sdat-ge
4720: 74 2d 70 61 72 61 6d 73 20 73 65 6c 66 29 29 29 t-params self)))
4730: 0a 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 65 78 . (session:ex
4740: 74 72 61 63 74 2d 6b 65 79 2d 66 72 6f 6d 2d 70 tract-key-from-p
4750: 61 72 61 6d 20 73 65 6c 66 20 70 61 72 61 6d 73 aram self params
4760: 20 6b 65 79 29 29 29 0a 0a 28 64 65 66 69 6e 65 key)))..(define
4770: 20 28 73 65 73 73 69 6f 6e 3a 65 78 74 72 61 63 (session:extrac
4780: 74 2d 6b 65 79 2d 66 72 6f 6d 2d 70 61 72 61 6d t-key-from-param
4790: 20 73 65 6c 66 20 70 61 72 61 6d 73 20 6b 65 79 self params key
47a0: 29 0a 20 20 28 6c 65 74 20 28 28 72 31 20 20 20 ). (let ((r1
47b0: 20 20 28 72 65 67 65 78 70 20 28 73 74 72 69 6e (regexp (strin
47c0: 67 2d 61 70 70 65 6e 64 20 22 5e 22 20 6b 65 79 g-append "^" key
47d0: 20 22 3d 28 5b 5e 3d 5d 2b 29 24 22 29 29 29 29 "=([^=]+)$"))))
47e0: 0a 20 20 20 20 28 65 72 72 3a 6c 6f 67 20 22 49 . (err:log "I
47f0: 4e 46 4f 3a 20 4c 6f 6f 6b 69 6e 67 20 66 6f 72 NFO: Looking for
4800: 20 22 20 6b 65 79 20 22 20 69 6e 20 22 20 70 61 " key " in " pa
4810: 72 61 6d 73 29 0a 20 20 20 20 28 69 66 20 28 3c rams). (if (<
4820: 20 28 6c 65 6e 67 74 68 20 70 61 72 61 6d 73 29 (length params)
4830: 20 31 29 20 23 66 0a 09 28 6c 65 74 20 6c 6f 6f 1) #f..(let loo
4840: 70 20 28 28 68 65 61 64 20 20 20 28 63 61 72 20 p ((head (car
4850: 70 61 72 61 6d 73 29 29 0a 09 09 20 20 20 28 74 params))... (t
4860: 61 69 6c 20 20 20 28 63 64 72 20 70 61 72 61 6d ail (cdr param
4870: 73 29 29 29 0a 09 20 20 28 6c 65 74 20 28 28 6d s))).. (let ((m
4880: 61 74 63 68 20 28 73 74 72 69 6e 67 2d 6d 61 74 atch (string-mat
4890: 63 68 20 72 31 20 68 65 61 64 29 29 29 0a 09 20 ch r1 head)))..
48a0: 20 20 20 28 63 6f 6e 64 0a 09 20 20 20 20 20 28 (cond.. (
48b0: 6d 61 74 63 68 0a 09 20 20 20 20 20 20 28 6c 65 match.. (le
48c0: 74 20 28 28 73 65 73 73 69 6f 6e 2d 6b 65 79 20 t ((session-key
48d0: 28 6c 69 73 74 2d 72 65 66 20 6d 61 74 63 68 20 (list-ref match
48e0: 31 29 29 29 0a 09 09 28 65 72 72 3a 6c 6f 67 20 1)))...(err:log
48f0: 22 49 4e 46 4f 3a 20 46 6f 75 6e 64 20 73 65 73 "INFO: Found ses
4900: 73 69 6f 6e 20 6b 65 79 3d 22 20 73 65 73 73 69 sion key=" sessi
4910: 6f 6e 2d 6b 65 79 29 0a 09 09 28 73 64 61 74 2d on-key)...(sdat-
4920: 73 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 21 set-session-key!
4930: 20 73 65 6c 66 20 28 6c 69 73 74 2d 72 65 66 20 self (list-ref
4940: 6d 61 74 63 68 20 31 29 29 0a 09 09 73 65 73 73 match 1))...sess
4950: 69 6f 6e 2d 6b 65 79 29 29 0a 09 20 20 20 20 20 ion-key))..
4960: 28 28 6e 75 6c 6c 3f 20 74 61 69 6c 29 0a 09 20 ((null? tail)..
4970: 20 20 20 20 20 23 66 29 0a 09 20 20 20 20 20 28 #f).. (
4980: 65 6c 73 65 0a 09 20 20 20 20 20 20 28 6c 6f 6f else.. (loo
4990: 70 20 28 63 61 72 20 74 61 69 6c 29 0a 09 09 20 p (car tail)...
49a0: 20 20 20 28 63 64 72 20 74 61 69 6c 29 29 29 29 (cdr tail))))
49b0: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define (
49c0: 73 65 73 73 69 6f 6e 3a 73 65 74 2d 70 61 67 65 session:set-page
49d0: 21 20 73 65 6c 66 20 70 61 67 65 5f 6e 61 6d 65 ! self page_name
49e0: 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 ). (sdat-set-pa
49f0: 67 65 21 20 73 65 6c 66 20 70 61 67 65 5f 6e 61 ge! self page_na
4a00: 6d 65 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 me))..(define (s
4a10: 65 73 73 69 6f 6e 3a 63 6c 6f 73 65 20 73 65 6c ession:close sel
4a20: 66 29 0a 20 20 28 64 62 69 3a 63 6c 6f 73 65 20 f). (dbi:close
4a30: 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 (sdat-get-conn s
4a40: 65 6c 66 29 29 29 0a 3b 3b 20 28 63 6c 6f 73 65 elf))).;; (close
4a50: 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 28 73 64 -output-port (sd
4a60: 61 74 2d 67 65 74 2d 6c 6f 67 70 74 20 73 65 6c at-get-logpt sel
4a70: 66 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 f))..(define (se
4a80: 73 73 69 6f 6e 3a 65 72 72 2d 6d 73 67 20 73 65 ssion:err-msg se
4a90: 6c 66 20 6d 73 67 29 0a 20 20 28 68 61 73 68 2d lf msg). (hash-
4aa0: 74 61 62 6c 65 2d 73 65 74 21 20 28 73 64 61 74 table-set! (sdat
4ab0: 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 -get-sessionvars
4ac0: 20 73 65 6c 66 29 20 22 45 52 52 4f 52 5f 4d 53 self) "ERROR_MS
4ad0: 47 22 0a 09 09 20 20 20 28 73 74 72 69 6e 67 2d G"... (string-
4ae0: 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 intersperse (map
4af0: 20 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6d s:any->string m
4b00: 73 67 29 20 22 20 22 29 29 29 0a 0a 28 64 65 66 sg) " ")))..(def
4b10: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 70 72 65 ine (session:pre
4b20: 76 2d 65 72 72 20 73 65 6c 66 29 0a 20 20 28 6c v-err self). (l
4b30: 65 74 20 28 28 70 72 65 76 2d 65 72 72 20 28 68 et ((prev-err (h
4b40: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
4b50: 66 61 75 6c 74 20 28 73 64 61 74 2d 67 65 74 2d fault (sdat-get-
4b60: 73 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 6f sessionvars-befo
4b70: 72 65 20 73 65 6c 66 29 20 22 45 52 52 4f 52 5f re self) "ERROR_
4b80: 4d 53 47 22 20 23 66 29 29 0a 09 28 63 75 72 72 MSG" #f))..(curr
4b90: 2d 65 72 72 20 28 68 61 73 68 2d 74 61 62 6c 65 -err (hash-table
4ba0: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 28 73 64 -ref/default (sd
4bb0: 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 at-get-sessionva
4bc0: 72 73 20 73 65 6c 66 29 20 22 45 52 52 4f 52 5f rs self) "ERROR_
4bd0: 4d 53 47 22 20 23 66 29 29 29 0a 20 20 20 20 28 MSG" #f))). (
4be0: 69 66 20 70 72 65 76 2d 65 72 72 20 70 72 65 76 if prev-err prev
4bf0: 2d 65 72 72 0a 09 28 69 66 20 63 75 72 72 2d 65 -err..(if curr-e
4c00: 72 72 20 63 75 72 72 2d 65 72 72 20 23 66 29 29 rr curr-err #f))
4c10: 29 29 0a 0a 3b 3b 20 73 65 73 73 69 6f 6e 20 76 ))..;; session v
4c20: 61 72 73 0a 3b 3b 20 31 2e 20 6b 65 79 73 20 61 ars.;; 1. keys a
4c30: 72 65 20 61 6c 77 61 79 73 20 61 20 73 74 72 69 re always a stri
4c40: 6e 67 20 4e 4f 54 20 61 20 73 79 6d 62 6f 6c 0a ng NOT a symbol.
4c50: 3b 3b 20 32 2e 20 76 61 6c 75 65 73 20 61 72 65 ;; 2. values are
4c60: 20 61 6c 77 61 79 73 20 61 20 73 74 72 69 6e 67 always a string
4c70: 20 63 6f 6e 76 65 72 73 69 6f 6e 20 69 73 20 74 conversion is t
4c80: 68 65 20 72 65 73 70 6f 6e 73 69 62 69 6c 69 74 he responsibilit
4c90: 79 20 6f 66 20 74 68 65 20 0a 3b 3b 20 20 20 20 y of the .;;
4ca0: 63 6f 6e 73 75 6d 69 6e 67 20 66 75 6e 63 74 69 consuming functi
4cb0: 6f 6e 20 28 61 74 20 6c 65 61 73 74 20 66 6f 72 on (at least for
4cc0: 20 6e 6f 77 2c 20 49 27 64 20 6c 69 6b 65 20 74 now, I'd like t
4cd0: 6f 20 63 68 61 6e 67 65 20 74 68 69 73 29 0a 0a o change this)..
4ce0: 3b 3b 20 73 65 74 20 61 20 73 65 73 73 69 6f 6e ;; set a session
4cf0: 20 76 61 72 20 66 6f 72 20 74 68 65 20 63 75 72 var for the cur
4d00: 72 65 6e 74 20 70 61 67 65 0a 3b 3b 0a 28 64 65 rent page.;;.(de
4d10: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 63 75 fine (session:cu
4d20: 72 72 2d 70 61 67 65 2d 73 65 74 21 20 73 65 6c rr-page-set! sel
4d30: 66 20 6b 65 79 20 76 61 6c 75 65 29 0a 20 20 28 f key value). (
4d40: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
4d50: 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 76 61 (sdat-get-pageva
4d60: 72 73 20 73 65 6c 66 29 20 28 73 3a 61 6e 79 2d rs self) (s:any-
4d70: 3e 73 74 72 69 6e 67 20 6b 65 79 29 20 28 73 3a >string key) (s:
4d80: 61 6e 79 2d 3e 73 74 72 69 6e 67 20 76 61 6c 75 any->string valu
4d90: 65 29 29 29 0a 0a 3b 3b 20 64 65 6c 20 61 20 76 e)))..;; del a v
4da0: 61 72 20 66 6f 72 20 74 68 65 20 63 75 72 72 65 ar for the curre
4db0: 6e 74 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 69 nt page.;;.(defi
4dc0: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 70 61 67 65 ne (session:page
4dd0: 2d 76 61 72 2d 64 65 6c 21 20 73 65 6c 66 20 6b -var-del! self k
4de0: 65 79 29 0a 20 20 28 68 61 73 68 2d 74 61 62 6c ey). (hash-tabl
4df0: 65 2d 64 65 6c 65 74 65 21 20 28 73 64 61 74 2d e-delete! (sdat-
4e00: 67 65 74 2d 70 61 67 65 76 61 72 73 20 73 65 6c get-pagevars sel
4e10: 66 29 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e f) (s:any->strin
4e20: 67 20 6b 65 79 29 29 29 0a 0a 3b 3b 20 67 65 74 g key)))..;; get
4e30: 20 74 68 65 20 61 70 70 72 6f 70 72 69 61 74 65 the appropriate
4e40: 20 68 61 73 68 20 67 69 76 65 6e 20 61 20 70 61 hash given a pa
4e50: 67 65 20 22 2a 73 65 73 73 69 6f 6e 76 61 72 73 ge "*sessionvars
4e60: 2a 2c 20 2a 67 6c 6f 62 61 6c 76 61 72 73 2a 20 *, *globalvars*
4e70: 6f 72 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 69 or page.;;.(defi
4e80: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d ne (session:get-
4e90: 70 61 67 65 2d 68 61 73 68 20 73 65 6c 66 20 70 page-hash self p
4ea0: 61 67 65 29 0a 20 20 28 69 66 20 28 73 74 72 69 age). (if (stri
4eb0: 6e 67 3d 3f 20 70 61 67 65 20 22 2a 73 65 73 73 ng=? page "*sess
4ec0: 69 6f 6e 76 61 72 73 2a 22 29 0a 20 20 20 20 20 ionvars*").
4ed0: 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 (sdat-get-sessi
4ee0: 6f 6e 76 61 72 73 20 73 65 6c 66 29 0a 20 20 20 onvars self).
4ef0: 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 3d 3f (if (string=?
4f00: 20 70 61 67 65 20 22 2a 67 6c 6f 62 61 6c 76 61 page "*globalva
4f10: 72 73 2a 22 29 0a 09 20 20 28 73 64 61 74 2d 67 rs*").. (sdat-g
4f20: 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 20 73 65 et-globalvars se
4f30: 6c 66 29 0a 09 20 20 28 73 64 61 74 2d 67 65 74 lf).. (sdat-get
4f40: 2d 70 61 67 65 76 61 72 73 20 73 65 6c 66 29 29 -pagevars self))
4f50: 29 29 0a 0a 3b 3b 20 73 65 74 20 61 20 73 65 73 ))..;; set a ses
4f60: 73 69 6f 6e 20 76 61 72 20 66 6f 72 20 61 20 67 sion var for a g
4f70: 69 76 65 6e 20 70 61 67 65 0a 3b 3b 0a 28 64 65 iven page.;;.(de
4f80: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 65 fine (session:se
4f90: 74 21 20 73 65 6c 66 20 70 61 67 65 20 6b 65 79 t! self page key
4fa0: 20 76 61 6c 75 65 29 0a 20 20 28 6c 65 74 20 28 value). (let (
4fb0: 28 68 74 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 (ht (session:get
4fc0: 2d 70 61 67 65 2d 68 61 73 68 20 73 65 6c 66 20 -page-hash self
4fd0: 70 61 67 65 29 29 29 0a 20 20 20 20 28 68 61 73 page))). (has
4fe0: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 68 74 20 h-table-set! ht
4ff0: 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6b (s:any->string k
5000: 65 79 29 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 ey) (s:any->stri
5010: 6e 67 20 76 61 6c 75 65 29 29 29 29 0a 0a 3b 3b ng value))))..;;
5020: 20 67 65 74 20 73 65 73 73 69 6f 6e 20 76 61 72 get session var
5030: 73 20 66 6f 72 20 74 68 65 20 63 75 72 72 65 6e s for the curren
5040: 74 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 69 6e t page.;;.(defin
5050: 65 20 28 73 65 73 73 69 6f 6e 3a 70 61 67 65 2d e (session:page-
5060: 67 65 74 20 73 65 6c 66 20 6b 65 79 29 0a 20 20 get self key).
5070: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
5080: 64 65 66 61 75 6c 74 20 28 73 64 61 74 2d 67 65 default (sdat-ge
5090: 74 2d 70 61 67 65 76 61 72 73 20 73 65 6c 66 29 t-pagevars self)
50a0: 20 6b 65 79 20 23 66 29 29 0a 0a 3b 3b 20 67 65 key #f))..;; ge
50b0: 74 20 73 65 73 73 69 6f 6e 20 76 61 72 73 20 66 t session vars f
50c0: 6f 72 20 61 20 73 70 65 63 69 66 69 65 64 20 70 or a specified p
50d0: 61 67 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 age.;;.(define (
50e0: 73 65 73 73 69 6f 6e 3a 67 65 74 20 73 65 6c 66 session:get self
50f0: 20 70 61 67 65 20 6b 65 79 20 70 61 72 61 6d 73 page key params
5100: 29 0a 20 20 28 6c 65 74 2a 20 28 28 68 74 20 20 ). (let* ((ht
5110: 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 67 (session:get-pag
5120: 65 2d 68 61 73 68 20 73 65 6c 66 20 70 61 67 65 e-hash self page
5130: 29 29 0a 09 20 28 72 65 73 20 28 68 61 73 68 2d )).. (res (hash-
5140: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
5150: 74 20 68 74 20 28 73 3a 61 6e 79 2d 3e 73 74 72 t ht (s:any->str
5160: 69 6e 67 20 6b 65 79 29 20 23 66 29 29 29 0a 20 ing key) #f))).
5170: 20 20 20 28 73 65 73 73 69 6f 6e 3a 61 70 70 6c (session:appl
5180: 79 2d 74 79 70 65 2d 70 72 65 66 65 72 65 6e 63 y-type-preferenc
5190: 65 20 72 65 73 20 70 61 72 61 6d 73 29 29 29 0a e res params))).
51a0: 0a 3b 3b 20 64 65 6c 65 74 65 20 61 20 73 65 73 .;; delete a ses
51b0: 73 69 6f 6e 20 76 61 72 20 66 6f 72 20 61 20 73 sion var for a s
51c0: 70 65 63 69 66 69 65 64 20 70 61 67 65 0a 3b 3b pecified page.;;
51d0: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
51e0: 6e 3a 64 65 6c 21 20 73 65 6c 66 20 70 61 67 65 n:del! self page
51f0: 20 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 28 68 key). (let ((h
5200: 74 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 t (session:get-p
5210: 61 67 65 2d 68 61 73 68 20 73 65 6c 66 20 70 61 age-hash self pa
5220: 67 65 29 29 29 0a 20 20 20 20 28 68 61 73 68 2d ge))). (hash-
5230: 74 61 62 6c 65 2d 64 65 6c 65 74 65 21 20 68 74 table-delete! ht
5240: 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 (s:any->string
5250: 6b 65 79 29 29 29 29 0a 0a 3b 3b 20 67 65 74 20 key))))..;; get
5260: 41 4c 4c 20 6b 65 79 73 20 66 6f 72 20 74 68 69 ALL keys for thi
5270: 73 20 70 61 67 65 20 61 6e 64 20 73 74 6f 72 65 s page and store
5280: 20 69 6e 20 74 68 65 20 73 65 73 73 69 6f 6e 20 in the session
5290: 70 61 67 65 76 61 72 73 20 68 61 73 68 0a 3b 3b pagevars hash.;;
52a0: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
52b0: 6e 3a 67 65 74 2d 76 61 72 73 20 73 65 6c 66 29 n:get-vars self)
52c0: 0a 20 20 28 6c 65 74 20 28 28 73 65 73 73 69 6f . (let ((sessio
52d0: 6e 2d 69 64 20 20 28 73 64 61 74 2d 67 65 74 2d n-id (sdat-get-
52e0: 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 29 session-id self)
52f0: 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 )). (if (not
5300: 73 65 73 73 69 6f 6e 2d 69 64 29 0a 09 28 65 72 session-id)..(er
5310: 72 3a 6c 6f 67 20 22 45 52 52 4f 52 3a 20 4e 6f r:log "ERROR: No
5320: 20 73 65 73 73 69 6f 6e 20 69 64 20 69 6e 20 73 session id in s
5330: 65 73 73 69 6f 6e 20 6f 62 6a 65 63 74 21 20 73 ession object! s
5340: 65 73 73 69 6f 6e 3a 67 65 74 2d 76 61 72 73 22 ession:get-vars"
5350: 29 0a 09 28 6c 65 74 2a 20 28 28 72 65 73 75 6c )..(let* ((resul
5360: 74 20 20 20 20 20 20 20 20 20 20 20 20 20 23 66 t #f
5370: 29 0a 09 20 20 20 20 20 20 20 28 63 6f 6e 6e 20 ).. (conn
5380: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
5390: 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c dat-get-conn sel
53a0: 66 29 29 0a 09 20 20 20 20 20 20 20 28 70 61 67 f)).. (pag
53b0: 65 76 61 72 73 2d 62 65 66 6f 72 65 20 20 20 20 evars-before
53c0: 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 76 61 (sdat-get-pageva
53d0: 72 73 2d 62 65 66 6f 72 65 20 73 65 6c 66 29 29 rs-before self))
53e0: 0a 09 20 20 20 20 20 20 20 28 73 65 73 73 69 6f .. (sessio
53f0: 6e 76 61 72 73 2d 62 65 66 6f 72 65 20 28 73 64 nvars-before (sd
5400: 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 at-get-sessionva
5410: 72 73 2d 62 65 66 6f 72 65 20 73 65 6c 66 29 29 rs-before self))
5420: 0a 09 20 20 20 20 20 20 20 28 67 6c 6f 62 61 6c .. (global
5430: 76 61 72 73 2d 62 65 66 6f 72 65 20 20 28 73 64 vars-before (sd
5440: 61 74 2d 67 65 74 2d 67 6c 6f 62 61 6c 76 61 72 at-get-globalvar
5450: 73 2d 62 65 66 6f 72 65 20 73 65 6c 66 29 29 0a s-before self)).
5460: 09 20 20 20 20 20 20 20 28 70 61 67 65 76 61 72 . (pagevar
5470: 73 20 20 20 20 20 20 20 20 20 20 20 28 73 64 61 s (sda
5480: 74 2d 67 65 74 2d 70 61 67 65 76 61 72 73 20 73 t-get-pagevars s
5490: 65 6c 66 29 29 0a 09 20 20 20 20 20 20 20 28 73 elf)).. (s
54a0: 65 73 73 69 6f 6e 76 61 72 73 20 20 20 20 20 20 essionvars
54b0: 20 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 (sdat-get-sess
54c0: 69 6f 6e 76 61 72 73 20 73 65 6c 66 29 29 0a 09 ionvars self))..
54d0: 20 20 20 20 20 20 20 28 67 6c 6f 62 61 6c 76 61 (globalva
54e0: 72 73 20 20 20 20 20 20 20 20 20 28 73 64 61 74 rs (sdat
54f0: 2d 67 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 20 -get-globalvars
5500: 73 65 6c 66 29 29 0a 09 20 20 20 20 20 20 20 28 self)).. (
5510: 70 61 67 65 2d 6e 61 6d 65 20 20 20 20 20 20 20 page-name
5520: 20 20 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 (sdat-get-pag
5530: 65 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 20 e self))..
5540: 20 28 73 65 73 73 69 6f 6e 2d 6b 65 79 20 20 20 (session-key
5550: 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d 73 (sdat-get-s
5560: 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 ession-key self)
5570: 29 0a 09 20 20 20 20 20 20 20 28 71 75 65 72 79 ).. (query
5580: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
5590: 74 72 69 6e 67 2d 61 70 70 65 6e 64 0a 09 09 09 tring-append....
55a0: 09 20 20 20 20 22 53 45 4c 45 43 54 20 6b 65 79 . "SELECT key
55b0: 2c 76 61 6c 75 65 20 46 52 4f 4d 20 73 65 73 73 ,value FROM sess
55c0: 69 6f 6e 5f 76 61 72 73 20 49 4e 4e 45 52 20 4a ion_vars INNER J
55d0: 4f 49 4e 20 73 65 73 73 69 6f 6e 73 20 4f 4e 20 OIN sessions ON
55e0: 73 65 73 73 69 6f 6e 5f 76 61 72 73 2e 73 65 73 session_vars.ses
55f0: 73 69 6f 6e 5f 69 64 3d 73 65 73 73 69 6f 6e 73 sion_id=sessions
5600: 2e 69 64 20 22 0a 09 09 09 09 20 20 20 20 22 57 .id "..... "W
5610: 48 45 52 45 20 73 65 73 73 69 6f 6e 5f 6b 65 79 HERE session_key
5620: 3d 3f 20 41 4e 44 20 70 61 67 65 3d 3f 3b 22 29 =? AND page=?;")
5630: 29 29 0a 09 20 20 3b 3b 20 66 69 72 73 74 20 74 )).. ;; first t
5640: 68 65 20 70 61 67 65 20 73 70 65 63 69 66 69 63 he page specific
5650: 20 76 61 72 73 0a 09 20 20 28 64 62 69 3a 66 6f vars.. (dbi:fo
5660: 72 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 6d 62 r-each-row (lamb
5670: 64 61 20 28 74 75 70 6c 65 29 0a 09 09 09 20 20 da (tuple)....
5680: 20 20 20 20 28 6c 65 74 20 28 28 6b 20 28 76 65 (let ((k (ve
5690: 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 30 ctor-ref tuple 0
56a0: 29 29 0a 09 09 09 09 20 20 20 20 28 76 20 28 76 ))..... (v (v
56b0: 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 ector-ref tuple
56c0: 31 29 29 29 0a 09 09 09 09 28 68 61 73 68 2d 74 1))).....(hash-t
56d0: 61 62 6c 65 2d 73 65 74 21 20 70 61 67 65 76 61 able-set! pageva
56e0: 72 73 2d 62 65 66 6f 72 65 20 6b 20 76 29 0a 09 rs-before k v)..
56f0: 09 09 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 ...(hash-table-s
5700: 65 74 21 20 70 61 67 65 76 61 72 73 20 20 20 20 et! pagevars
5710: 20 20 20 20 6b 20 76 29 29 29 0a 09 09 09 20 20 k v)))....
5720: 20 20 63 6f 6e 6e 0a 09 09 09 20 20 20 20 28 73 conn.... (s
5730: 3a 73 71 6c 70 61 72 61 6d 20 71 75 65 72 79 20 :sqlparam query
5740: 73 65 73 73 69 6f 6e 2d 6b 65 79 20 70 61 67 65 session-key page
5750: 2d 6e 61 6d 65 29 29 0a 09 20 20 3b 3b 20 74 68 -name)).. ;; th
5760: 65 6e 20 74 68 65 20 73 65 73 73 69 6f 6e 20 73 en the session s
5770: 70 65 63 69 66 69 63 20 76 61 72 73 0a 09 20 20 pecific vars..
5780: 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f (dbi:for-each-ro
5790: 77 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 w (lambda (tuple
57a0: 29 0a 09 09 09 20 20 20 20 20 20 28 6c 65 74 20 ).... (let
57b0: 28 28 6b 20 28 76 65 63 74 6f 72 2d 72 65 66 20 ((k (vector-ref
57c0: 74 75 70 6c 65 20 30 29 29 0a 09 09 09 09 20 20 tuple 0)).....
57d0: 20 20 28 76 20 28 76 65 63 74 6f 72 2d 72 65 66 (v (vector-ref
57e0: 20 74 75 70 6c 65 20 31 29 29 29 0a 09 09 09 09 tuple 1))).....
57f0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
5800: 20 73 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 sessionvars-bef
5810: 6f 72 65 20 6b 20 76 29 0a 09 09 09 09 28 68 61 ore k v).....(ha
5820: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 73 65 sh-table-set! se
5830: 73 73 69 6f 6e 76 61 72 73 20 20 20 20 20 20 20 ssionvars
5840: 20 6b 20 76 29 29 29 0a 09 09 09 20 20 20 20 63 k v))).... c
5850: 6f 6e 6e 0a 09 09 09 20 20 20 20 28 73 3a 73 71 onn.... (s:sq
5860: 6c 70 61 72 61 6d 20 71 75 65 72 79 20 73 65 73 lparam query ses
5870: 73 69 6f 6e 2d 6b 65 79 20 22 2a 73 65 73 73 69 sion-key "*sessi
5880: 6f 6e 76 61 72 73 2a 22 29 29 0a 09 20 20 3b 3b onvars*")).. ;;
5890: 20 61 6e 64 20 66 69 6e 61 6c 6c 79 20 74 68 65 and finally the
58a0: 20 67 6c 6f 62 61 6c 20 76 61 72 73 0a 09 20 20 global vars..
58b0: 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f (dbi:for-each-ro
58c0: 77 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 w (lambda (tuple
58d0: 29 0a 09 09 09 20 20 20 20 20 20 28 6c 65 74 20 ).... (let
58e0: 28 28 6b 20 28 76 65 63 74 6f 72 2d 72 65 66 20 ((k (vector-ref
58f0: 74 75 70 6c 65 20 30 29 29 0a 09 09 09 09 20 20 tuple 0)).....
5900: 20 20 28 76 20 28 76 65 63 74 6f 72 2d 72 65 66 (v (vector-ref
5910: 20 74 75 70 6c 65 20 31 29 29 29 0a 09 09 09 09 tuple 1))).....
5920: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
5930: 20 67 6c 6f 62 61 6c 76 61 72 73 2d 62 65 66 6f globalvars-befo
5940: 72 65 20 6b 20 76 29 0a 09 09 09 09 28 68 61 73 re k v).....(has
5950: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 67 6c 6f h-table-set! glo
5960: 62 61 6c 76 61 72 73 20 20 20 20 20 20 20 20 6b balvars k
5970: 20 76 29 29 29 0a 09 09 09 20 20 20 20 63 6f 6e v))).... con
5980: 6e 0a 09 09 09 20 20 20 20 28 73 3a 73 71 6c 70 n.... (s:sqlp
5990: 61 72 61 6d 20 71 75 65 72 79 20 73 65 73 73 69 aram query sessi
59a0: 6f 6e 2d 6b 65 79 20 22 2a 67 6c 6f 62 61 6c 76 on-key "*globalv
59b0: 61 72 73 22 29 29 0a 09 20 20 29 29 29 29 0a 0a ars")).. ))))..
59c0: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
59d0: 3a 73 61 76 65 2d 76 61 72 73 20 73 65 6c 66 29 :save-vars self)
59e0: 0a 20 20 28 6c 65 74 20 28 28 73 65 73 73 69 6f . (let ((sessio
59f0: 6e 2d 69 64 20 20 28 73 64 61 74 2d 67 65 74 2d n-id (sdat-get-
5a00: 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 29 session-id self)
5a10: 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 )). (if (not
5a20: 73 65 73 73 69 6f 6e 2d 69 64 29 0a 09 28 65 72 session-id)..(er
5a30: 72 3a 6c 6f 67 20 22 45 52 52 4f 52 3a 20 4e 6f r:log "ERROR: No
5a40: 20 73 65 73 73 69 6f 6e 20 69 64 20 69 6e 20 73 session id in s
5a50: 65 73 73 69 6f 6e 20 6f 62 6a 65 63 74 21 20 73 ession object! s
5a60: 65 73 73 69 6f 6e 3a 67 65 74 2d 76 61 72 73 22 ession:get-vars"
5a70: 29 0a 09 28 6c 65 74 2a 20 28 28 73 74 61 74 75 )..(let* ((statu
5a80: 73 20 20 20 20 20 20 23 66 29 0a 09 20 20 20 20 s #f)..
5a90: 20 20 20 28 63 6f 6e 6e 20 20 20 20 20 20 20 20 (conn
5aa0: 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 (sdat-get-conn s
5ab0: 65 6c 66 29 29 0a 09 20 20 20 20 20 20 20 28 70 elf)).. (p
5ac0: 61 67 65 2d 6e 61 6d 65 20 20 20 28 73 64 61 74 age-name (sdat
5ad0: 2d 67 65 74 2d 70 61 67 65 20 73 65 6c 66 29 29 -get-page self))
5ae0: 0a 09 20 20 20 20 20 20 20 28 64 65 6c 2d 71 75 .. (del-qu
5af0: 65 72 79 20 20 20 22 44 45 4c 45 54 45 20 46 52 ery "DELETE FR
5b00: 4f 4d 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 OM session_vars
5b10: 57 48 45 52 45 20 73 65 73 73 69 6f 6e 5f 69 64 WHERE session_id
5b20: 3d 3f 20 41 4e 44 20 70 61 67 65 3d 3f 20 41 4e =? AND page=? AN
5b30: 44 20 6b 65 79 3d 3f 3b 22 29 0a 09 20 20 20 20 D key=?;")..
5b40: 20 20 20 28 69 6e 73 2d 71 75 65 72 79 20 20 20 (ins-query
5b50: 22 49 4e 53 45 52 54 20 49 4e 54 4f 20 73 65 73 "INSERT INTO ses
5b60: 73 69 6f 6e 5f 76 61 72 73 20 28 73 65 73 73 69 sion_vars (sessi
5b70: 6f 6e 5f 69 64 2c 70 61 67 65 2c 6b 65 79 2c 76 on_id,page,key,v
5b80: 61 6c 75 65 29 20 56 41 4c 55 45 53 28 3f 2c 3f alue) VALUES(?,?
5b90: 2c 3f 2c 3f 29 3b 22 29 0a 09 20 20 20 20 20 20 ,?,?);")..
5ba0: 20 28 75 70 64 2d 71 75 65 72 79 20 20 20 22 55 (upd-query "U
5bb0: 50 44 41 54 45 20 73 65 73 73 69 6f 6e 5f 76 61 PDATE session_va
5bc0: 72 73 20 73 65 74 20 76 61 6c 75 65 3d 3f 20 57 rs set value=? W
5bd0: 48 45 52 45 20 6b 65 79 3d 3f 20 41 4e 44 20 73 HERE key=? AND s
5be0: 65 73 73 69 6f 6e 5f 69 64 3d 3f 20 41 4e 44 20 ession_id=? AND
5bf0: 70 61 67 65 3d 3f 3b 22 29 0a 09 20 20 20 20 20 page=?;")..
5c00: 20 20 28 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 (changed-count
5c10: 20 30 29 29 0a 09 20 20 3b 3b 20 73 61 76 65 20 0)).. ;; save
5c20: 74 68 65 20 64 65 6c 74 61 20 6f 6e 6c 79 0a 09 the delta only..
5c30: 20 20 28 66 6f 72 2d 65 61 63 68 0a 09 20 20 20 (for-each..
5c40: 28 6c 61 6d 62 64 61 20 28 70 61 67 65 29 20 3b (lambda (page) ;
5c50: 3b 20 70 61 67 65 20 69 73 3a 20 22 2a 67 6c 6f ; page is: "*glo
5c60: 62 61 6c 76 61 72 73 2a 22 20 22 2a 73 65 73 73 balvars*" "*sess
5c70: 69 6f 6e 76 61 72 73 2a 22 20 6f 72 20 6f 74 68 ionvars*" or oth
5c80: 65 72 73 74 72 69 6e 67 0a 09 20 20 20 20 20 28 erstring.. (
5c90: 6c 65 74 2a 20 28 28 62 65 66 6f 72 65 2d 61 66 let* ((before-af
5ca0: 74 65 72 2d 68 74 20 28 63 6f 6e 64 0a 09 09 09 ter-ht (cond....
5cb0: 09 20 20 20 20 20 20 28 28 73 74 72 69 6e 67 3d . ((string=
5cc0: 3f 20 70 61 67 65 20 22 2a 73 65 73 73 69 6f 6e ? page "*session
5cd0: 76 61 72 73 2a 22 29 0a 09 09 09 09 20 20 20 20 vars*").....
5ce0: 20 20 20 28 76 65 63 74 6f 72 20 28 73 64 61 74 (vector (sdat
5cf0: 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 -get-sessionvars
5d00: 20 73 65 6c 66 29 0a 09 09 09 09 09 20 20 20 20 self)......
5d10: 20 20 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 (sdat-get-ses
5d20: 73 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 20 sionvars-before
5d30: 73 65 6c 66 29 29 29 0a 09 09 09 09 20 20 20 20 self))).....
5d40: 20 20 20 28 28 73 74 72 69 6e 67 3d 3f 20 70 61 ((string=? pa
5d50: 67 65 20 22 2a 67 6c 6f 62 61 6c 76 61 72 73 2a ge "*globalvars*
5d60: 22 29 0a 09 09 09 09 09 28 76 65 63 74 6f 72 20 ")......(vector
5d70: 28 73 64 61 74 2d 67 65 74 2d 67 6c 6f 62 61 6c (sdat-get-global
5d80: 76 61 72 73 20 73 65 6c 66 29 0a 09 09 09 09 09 vars self)......
5d90: 09 28 73 64 61 74 2d 67 65 74 2d 67 6c 6f 62 61 .(sdat-get-globa
5da0: 6c 76 61 72 73 2d 62 65 66 6f 72 65 20 73 65 6c lvars-before sel
5db0: 66 29 29 29 0a 09 09 09 09 20 20 20 20 20 20 20 f))).....
5dc0: 28 65 6c 73 65 20 0a 09 09 09 09 09 28 76 65 63 (else ......(vec
5dd0: 74 6f 72 20 28 73 64 61 74 2d 67 65 74 2d 70 61 tor (sdat-get-pa
5de0: 67 65 76 61 72 73 20 73 65 6c 66 29 0a 09 09 09 gevars self)....
5df0: 09 09 09 28 73 64 61 74 2d 67 65 74 2d 70 61 67 ...(sdat-get-pag
5e00: 65 76 61 72 73 2d 62 65 66 6f 72 65 20 73 65 6c evars-before sel
5e10: 66 29 29 29 29 29 0a 09 09 20 20 20 20 28 6d 61 f)))))... (ma
5e20: 73 74 65 72 2d 68 74 20 20 20 28 76 65 63 74 6f ster-ht (vecto
5e30: 72 2d 72 65 66 20 62 65 66 6f 72 65 2d 61 66 74 r-ref before-aft
5e40: 65 72 2d 68 74 20 30 29 29 0a 09 09 20 20 20 20 er-ht 0))...
5e50: 28 62 65 66 6f 72 65 2d 68 74 20 20 20 28 76 65 (before-ht (ve
5e60: 63 74 6f 72 2d 72 65 66 20 62 65 66 6f 72 65 2d ctor-ref before-
5e70: 61 66 74 65 72 2d 68 74 20 31 29 29 0a 09 09 20 after-ht 1))...
5e80: 20 20 20 28 6d 61 73 74 65 72 2d 6b 65 79 73 20 (master-keys
5e90: 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 (hash-table-keys
5ea0: 20 6d 61 73 74 65 72 2d 68 74 29 29 0a 09 09 20 master-ht))...
5eb0: 20 20 20 28 62 65 66 6f 72 65 2d 6b 65 79 73 20 (before-keys
5ec0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 (hash-table-keys
5ed0: 20 62 65 66 6f 72 65 2d 68 74 29 29 0a 09 09 20 before-ht))...
5ee0: 20 20 20 28 61 6c 6c 2d 6b 65 79 73 20 28 64 65 (all-keys (de
5ef0: 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 65 73 20 lete-duplicates
5f00: 28 61 70 70 65 6e 64 20 6d 61 73 74 65 72 2d 6b (append master-k
5f10: 65 79 73 20 62 65 66 6f 72 65 2d 6b 65 79 73 29 eys before-keys)
5f20: 29 29 29 0a 09 20 20 20 20 20 20 20 28 66 6f 72 ))).. (for
5f30: 2d 65 61 63 68 20 0a 09 09 28 6c 61 6d 62 64 61 -each ...(lambda
5f40: 20 28 6b 65 79 29 0a 09 09 20 20 28 6c 65 74 20 (key)... (let
5f50: 28 28 6d 61 73 74 65 72 2d 76 61 6c 75 65 20 28 ((master-value (
5f60: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
5f70: 65 66 61 75 6c 74 20 6d 61 73 74 65 72 2d 68 74 efault master-ht
5f80: 20 6b 65 79 20 23 66 29 29 0a 09 09 09 28 62 65 key #f))....(be
5f90: 66 6f 72 65 2d 76 61 6c 75 65 20 28 68 61 73 68 fore-value (hash
5fa0: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
5fb0: 6c 74 20 62 65 66 6f 72 65 2d 68 74 20 6b 65 79 lt before-ht key
5fc0: 20 23 66 29 29 29 0a 09 09 20 20 20 20 28 63 6f #f)))... (co
5fd0: 6e 64 0a 09 09 20 20 20 20 20 3b 3b 20 62 65 66 nd... ;; bef
5fe0: 6f 72 65 20 61 6e 64 20 61 66 74 65 72 20 65 78 ore and after ex
5ff0: 69 73 74 20 61 6e 64 20 76 61 6c 75 65 20 75 6e ist and value un
6000: 63 68 61 6e 67 65 64 20 2d 20 64 6f 20 6e 6f 74 changed - do not
6010: 68 69 6e 67 0a 09 09 20 20 20 20 20 28 28 61 6e hing... ((an
6020: 64 20 6d 61 73 74 65 72 2d 76 61 6c 75 65 20 62 d master-value b
6030: 65 66 6f 72 65 2d 76 61 6c 75 65 20 28 65 71 75 efore-value (equ
6040: 61 6c 3f 20 6d 61 73 74 65 72 2d 76 61 6c 75 65 al? master-value
6050: 20 62 65 66 6f 72 65 2d 76 61 6c 75 65 29 29 29 before-value)))
6060: 0a 09 09 20 20 20 20 20 3b 3b 20 62 65 66 6f 72 ... ;; befor
6070: 65 20 61 6e 64 20 61 66 74 65 72 20 65 78 69 73 e and after exis
6080: 74 20 62 75 74 20 61 72 65 20 63 68 61 6e 67 65 t but are change
6090: 64 0a 09 09 20 20 20 20 20 28 28 61 6e 64 20 6d d... ((and m
60a0: 61 73 74 65 72 2d 76 61 6c 75 65 20 62 65 66 6f aster-value befo
60b0: 72 65 2d 76 61 6c 75 65 29 0a 09 09 20 20 20 20 re-value)...
60c0: 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d (dbi:for-each-
60d0: 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 75 70 row (lambda (tup
60e0: 6c 65 29 0a 09 09 09 09 09 20 20 28 73 65 74 21 le)...... (set!
60f0: 20 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 28 changed-count (
6100: 2b 20 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 + changed-count
6110: 31 29 29 29 0a 09 09 09 09 09 63 6f 6e 6e 0a 09 1)))......conn..
6120: 09 09 09 09 28 73 3a 73 71 6c 70 61 72 61 6d 20 ....(s:sqlparam
6130: 75 70 64 2d 71 75 65 72 79 20 6d 61 73 74 65 72 upd-query master
6140: 2d 76 61 6c 75 65 20 6b 65 79 20 73 65 73 73 69 -value key sessi
6150: 6f 6e 2d 69 64 20 70 61 67 65 29 29 29 0a 09 09 on-id page)))...
6160: 20 20 20 20 20 3b 3b 20 6d 61 73 74 65 72 2d 76 ;; master-v
6170: 61 6c 75 65 20 6e 6f 20 6c 6f 6e 67 65 72 20 65 alue no longer e
6180: 78 69 73 74 73 20 28 69 2e 65 2e 20 23 66 29 20 xists (i.e. #f)
6190: 2d 20 72 65 6d 6f 76 65 20 69 74 65 6d 0a 09 09 - remove item...
61a0: 20 20 20 20 20 28 28 6e 6f 74 20 6d 61 73 74 65 ((not maste
61b0: 72 2d 76 61 6c 75 65 29 0a 09 09 20 20 20 20 20 r-value)...
61c0: 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 (dbi:for-each-r
61d0: 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c ow (lambda (tupl
61e0: 65 29 0a 09 09 09 09 09 20 20 28 73 65 74 21 20 e)...... (set!
61f0: 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 28 2b changed-count (+
6200: 20 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 31 changed-count 1
6210: 29 29 29 0a 09 09 09 09 09 63 6f 6e 6e 0a 09 09 )))......conn...
6220: 09 09 09 28 73 3a 73 71 6c 70 61 72 61 6d 20 64 ...(s:sqlparam d
6230: 65 6c 2d 71 75 65 72 79 20 73 65 73 73 69 6f 6e el-query session
6240: 2d 69 64 20 70 61 67 65 20 6b 65 79 29 29 29 0a -id page key))).
6250: 09 09 20 20 20 20 20 3b 3b 20 62 65 66 6f 72 65 .. ;; before
6260: 2d 76 61 6c 75 65 20 64 6f 65 73 6e 27 74 20 65 -value doesn't e
6270: 78 69 73 74 20 2d 20 69 6e 73 65 72 74 20 61 20 xist - insert a
6280: 6e 65 77 20 76 61 6c 75 65 0a 09 09 20 20 20 20 new value...
6290: 20 28 28 6e 6f 74 20 62 65 66 6f 72 65 2d 76 61 ((not before-va
62a0: 6c 75 65 29 0a 09 09 20 20 20 20 20 20 28 64 62 lue)... (db
62b0: 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 28 i:for-each-row (
62c0: 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 29 0a 09 lambda (tuple)..
62d0: 09 09 09 09 20 20 28 73 65 74 21 20 63 68 61 6e .... (set! chan
62e0: 67 65 64 2d 63 6f 75 6e 74 20 28 2b 20 63 68 61 ged-count (+ cha
62f0: 6e 67 65 64 2d 63 6f 75 6e 74 20 31 29 29 29 0a nged-count 1))).
6300: 09 09 09 09 09 63 6f 6e 6e 0a 09 09 09 09 09 28 .....conn......(
6310: 73 3a 73 71 6c 70 61 72 61 6d 20 69 6e 73 2d 71 s:sqlparam ins-q
6320: 75 65 72 79 20 73 65 73 73 69 6f 6e 2d 69 64 20 uery session-id
6330: 70 61 67 65 20 6b 65 79 20 6d 61 73 74 65 72 2d page key master-
6340: 76 61 6c 75 65 29 29 29 0a 09 09 20 20 20 20 20 value)))...
6350: 28 65 6c 73 65 20 28 65 72 72 3a 6c 6f 67 20 22 (else (err:log "
6360: 53 68 6f 75 6c 64 6e 27 74 20 67 65 74 20 68 65 Shouldn't get he
6370: 72 65 22 29 29 29 29 29 0a 09 09 61 6c 6c 2d 6b re")))))...all-k
6380: 65 79 73 29 29 29 20 3b 3b 20 70 72 6f 63 65 73 eys))) ;; proces
6390: 73 20 61 6c 6c 20 6b 65 79 73 0a 09 20 20 20 28 s all keys.. (
63a0: 6c 69 73 74 20 22 2a 73 65 73 73 69 6f 6e 76 61 list "*sessionva
63b0: 72 73 2a 22 20 22 2a 67 6c 6f 62 61 6c 76 61 72 rs*" "*globalvar
63c0: 73 2a 22 20 70 61 67 65 2d 6e 61 6d 65 29 29 29 s*" page-name)))
63d0: 29 29 29 0a 0a 3b 3b 20 28 70 67 3a 73 71 6c 2d )))..;; (pg:sql-
63e0: 6e 75 6c 6c 2d 6f 62 6a 65 63 74 3f 20 65 6c 65 null-object? ele
63f0: 6d 65 6e 74 29 0a 28 64 65 66 69 6e 65 20 28 73 ment).(define (s
6400: 65 73 73 69 6f 6e 3a 72 65 61 64 2d 63 6f 6e 66 ession:read-conf
6410: 69 67 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 2a ig self). (let*
6420: 20 28 28 63 67 69 2d 70 61 74 68 20 28 70 61 74 ((cgi-path (pat
6430: 68 6e 61 6d 65 2d 64 69 72 65 63 74 6f 72 79 20 hname-directory
6440: 28 63 61 72 20 28 61 72 67 76 29 29 29 29 0a 20 (car (argv)))).
6450: 20 20 20 20 20 20 20 20 28 6e 61 6d 65 20 20 20 (name
6460: 20 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 (string-append
6470: 20 28 69 66 20 63 67 69 2d 70 61 74 68 20 28 63 (if cgi-path (c
6480: 6f 6e 63 20 63 67 69 2d 70 61 74 68 20 22 2f 22 onc cgi-path "/"
6490: 29 20 22 22 29 20 22 2e 22 20 28 70 61 74 68 6e ) "") "." (pathn
64a0: 61 6d 65 2d 66 69 6c 65 20 28 63 61 72 20 28 61 ame-file (car (a
64b0: 72 67 76 29 29 29 20 22 2e 63 6f 6e 66 69 67 22 rgv))) ".config"
64c0: 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 ))). (if (not
64d0: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 6e (file-exists? n
64e0: 61 6d 65 29 29 0a 09 28 70 72 69 6e 74 20 6e 61 ame))..(print na
64f0: 6d 65 20 22 20 6e 6f 74 20 66 6f 75 6e 64 20 61 me " not found a
6500: 74 20 22 20 28 63 75 72 72 65 6e 74 2d 64 69 72 t " (current-dir
6510: 65 63 74 6f 72 79 29 29 0a 09 28 6c 65 74 2a 20 ectory))..(let*
6520: 28 28 66 70 20 28 6f 70 65 6e 2d 69 6e 70 75 74 ((fp (open-input
6530: 2d 66 69 6c 65 20 6e 61 6d 65 29 29 0a 09 20 20 -file name))..
6540: 20 20 20 20 20 28 69 6e 69 74 61 72 67 73 20 28 (initargs (
6550: 72 65 61 64 20 66 70 29 29 29 0a 09 20 20 28 63 read fp))).. (c
6560: 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 6f 72 74 20 lose-input-port
6570: 66 70 29 0a 09 20 20 69 6e 69 74 61 72 67 73 29 fp).. initargs)
6580: 29 29 29 0a 0a 3b 3b 20 63 61 6c 6c 20 74 68 65 )))..;; call the
6590: 20 63 6f 6e 74 72 6f 6c 6c 65 72 20 69 66 20 69 controller if i
65a0: 74 20 65 78 69 73 74 73 0a 3b 3b 20 0a 3b 3b 20 t exists.;; .;;
65b0: 57 41 52 4e 49 4e 47 20 2d 20 74 68 69 73 20 63 WARNING - this c
65c0: 6f 64 65 20 6e 65 65 64 73 20 61 20 64 65 66 65 ode needs a defe
65d0: 6e 63 65 20 61 67 61 69 6e 73 20 72 65 63 75 72 nce agains recur
65e0: 73 69 76 65 20 63 61 6c 6c 69 6e 67 21 21 21 21 sive calling!!!!
65f0: 21 0a 3b 3b 0a 3b 3b 20 20 20 49 20 73 75 67 67 !.;;.;; I sugg
6600: 65 73 74 20 61 20 6c 69 6d 69 74 20 6f 66 20 31 est a limit of 1
6610: 30 30 20 63 61 6c 6c 73 2e 20 50 6c 65 6e 74 79 00 calls. Plenty
6620: 20 66 6f 72 20 61 6c 6c 6f 77 69 6e 67 20 6d 75 for allowing mu
6630: 6c 74 69 70 6c 65 20 69 6e 73 74 61 6e 63 65 73 ltiple instances
6640: 0a 3b 3b 20 20 20 6f 66 20 61 20 70 61 67 65 20 .;; of a page
6650: 69 6e 73 69 64 65 20 61 6e 6f 74 68 65 72 20 70 inside another p
6660: 61 67 65 2e 20 0a 3b 3b 0a 3b 3b 20 70 61 72 74 age. .;;.;; part
6670: 73 20 3d 20 27 62 6f 74 68 20 7c 20 27 63 6f 6e s = 'both | 'con
6680: 74 72 6f 6c 20 7c 20 27 76 69 65 77 0a 3b 3b 0a trol | 'view.;;.
6690: 0a 28 64 65 66 69 6e 65 20 28 66 69 6c 65 73 2d .(define (files-
66a0: 72 65 61 64 2d 3e 73 74 72 69 6e 67 20 2e 20 66 read->string . f
66b0: 69 6c 65 73 29 0a 20 20 28 73 74 72 69 6e 67 2d iles). (string-
66c0: 69 6e 74 65 72 73 70 65 72 73 65 20 0a 20 20 20 intersperse .
66d0: 28 61 70 70 6c 79 20 61 70 70 65 6e 64 20 28 6d (apply append (m
66e0: 61 70 20 66 69 6c 65 2d 72 65 61 64 2d 3e 73 74 ap file-read->st
66f0: 72 69 6e 67 20 66 69 6c 65 73 29 29 20 22 5c 6e ring files)) "\n
6700: 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 66 69 "))..(define (fi
6710: 6c 65 2d 72 65 61 64 2d 3e 73 74 72 69 6e 67 20 le-read->string
6720: 66 29 20 0a 20 20 28 6c 65 74 20 28 28 70 20 28 f) . (let ((p (
6730: 6f 70 65 6e 2d 69 6e 70 75 74 2d 66 69 6c 65 20 open-input-file
6740: 66 29 29 29 0a 20 20 20 20 28 6c 65 74 20 6c 6f f))). (let lo
6750: 6f 70 20 28 28 68 65 64 20 28 72 65 61 64 2d 6c op ((hed (read-l
6760: 69 6e 65 20 70 29 29 0a 09 20 20 20 20 20 20 20 ine p))..
6770: 28 72 65 73 20 27 28 29 29 29 0a 20 20 20 20 20 (res '())).
6780: 20 28 69 66 20 28 65 6f 66 2d 6f 62 6a 65 63 74 (if (eof-object
6790: 3f 20 68 65 64 29 0a 09 20 20 72 65 73 0a 09 20 ? hed).. res..
67a0: 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d 6c 69 6e (loop (read-lin
67b0: 65 20 70 29 28 61 70 70 65 6e 64 20 72 65 73 20 e p)(append res
67c0: 28 6c 69 73 74 20 68 65 64 29 29 29 29 29 29 29 (list hed)))))))
67d0: 0a 0a 28 64 65 66 69 6e 65 20 28 70 72 6f 63 65 ..(define (proce
67e0: 73 73 2d 70 6f 72 74 20 70 29 0a 20 20 28 6c 65 ss-port p). (le
67f0: 74 20 28 28 65 20 28 69 6e 74 65 72 61 63 74 69 t ((e (interacti
6800: 6f 6e 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 29 29 on-environment))
6810: 29 0a 20 20 20 20 28 6d 61 70 20 0a 20 20 20 20 ). (map .
6820: 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 20 20 20 (lambda (x).
6830: 20 20 20 20 28 63 6f 6e 64 0a 09 28 28 6c 69 73 (cond..((lis
6840: 74 3f 20 78 29 20 78 29 0a 09 28 28 73 74 72 69 t? x) x)..((stri
6850: 6e 67 3f 20 78 29 20 78 29 0a 09 28 65 6c 73 65 ng? x) x)..(else
6860: 20 27 28 29 29 29 29 0a 20 20 20 20 20 28 70 6f '()))). (po
6870: 72 74 2d 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 rt-map (lambda (
6880: 73 29 0a 09 09 20 28 65 76 61 6c 20 73 20 65 29 s)... (eval s e)
6890: 29 0a 09 20 20 20 20 20 20 20 28 6c 61 6d 62 64 ).. (lambd
68a0: 61 20 28 29 28 72 65 61 64 20 70 29 29 29 29 29 a ()(read p)))))
68b0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 )..(define (sess
68c0: 69 6f 6e 3a 70 72 6f 63 65 73 73 2d 66 69 6c 65 ion:process-file
68d0: 20 66 29 0a 20 20 28 6c 65 74 2a 20 28 28 70 20 f). (let* ((p
68e0: 20 20 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 66 (open-input-f
68f0: 69 6c 65 20 66 29 29 0a 09 20 28 64 61 74 20 20 ile f)).. (dat
6900: 28 70 72 6f 63 65 73 73 2d 70 6f 72 74 20 70 29 (process-port p)
6910: 29 29 0a 20 20 20 20 28 63 6c 6f 73 65 2d 69 6e )). (close-in
6920: 70 75 74 2d 70 6f 72 74 20 70 29 0a 20 20 20 20 put-port p).
6930: 64 61 74 29 29 0a 0a 3b 3b 20 4d 61 79 20 32 30 dat))..;; May 20
6940: 31 31 2c 20 70 75 74 74 69 6e 67 20 61 6c 6c 20 11, putting all
6950: 70 61 67 65 73 20 69 6e 74 6f 20 6f 6e 65 20 64 pages into one d
6960: 69 72 65 63 74 6f 72 79 20 66 6f 72 20 74 68 65 irectory for the
6970: 20 66 6f 6c 6c 6f 77 69 6e 67 20 72 65 61 73 6f following reaso
6980: 6e 73 3a 0a 3b 3b 20 20 20 31 2e 20 77 61 6e 74 ns:.;; 1. want
6990: 20 66 69 6c 65 6e 61 6d 65 20 74 6f 20 72 65 66 filename to ref
69a0: 6c 65 63 74 20 70 61 67 65 20 6e 61 6d 65 20 28 lect page name (
69b0: 65 6d 61 63 73 20 6c 69 6d 69 74 61 74 69 6f 6e emacs limitation
69c0: 29 0a 3b 3b 20 20 20 32 2e 20 74 68 61 74 27 73 ).;; 2. that's
69d0: 20 69 74 21 20 6e 6f 20 6f 74 68 65 72 20 72 65 it! no other re
69e0: 61 73 6f 6e 2e 20 63 6f 75 6c 64 20 6d 61 6b 65 ason. could make
69f0: 20 69 74 20 63 6f 6e 66 69 67 75 72 61 62 6c 65 it configurable
6a00: 20 2e 2e 2e 0a 3b 3b 20 70 61 67 65 2d 64 69 72 ....;; page-dir
6a10: 2d 73 74 79 6c 65 20 69 73 3a 0a 3b 3b 20 20 27 -style is:.;; '
6a20: 73 74 6f 72 65 64 20 20 20 3d 3e 20 73 74 6f 72 stored => stor
6a30: 65 64 20 69 6e 20 65 78 65 63 75 74 61 62 6c 65 ed in executable
6a40: 0a 3b 3b 20 20 27 66 6c 61 74 20 20 20 20 20 3d .;; 'flat =
6a50: 3e 20 70 61 67 65 73 20 66 6c 61 74 20 64 69 72 > pages flat dir
6a60: 65 63 74 6f 72 79 0a 3b 3b 20 20 27 64 69 72 20 ectory.;; 'dir
6a70: 20 20 20 20 20 3d 3e 20 64 69 72 65 63 74 6f 72 => director
6a80: 79 20 74 72 65 65 20 70 61 67 65 73 2f 3c 70 61 y tree pages/<pa
6a90: 67 65 6e 61 6d 65 3e 2f 7b 76 69 65 77 2c 63 6f gename>/{view,co
6aa0: 6e 74 72 6f 6c 7d 2e 73 63 6d 0a 3b 3b 20 70 61 ntrol}.scm.;; pa
6ab0: 72 74 73 3a 0a 3b 3b 20 20 27 62 6f 74 68 20 20 rts:.;; 'both
6ac0: 20 20 20 3d 3e 20 6c 6f 61 64 20 63 6f 6e 74 72 => load contr
6ad0: 6f 6c 20 61 6e 64 20 76 69 65 77 20 28 61 6e 79 ol and view (any
6ae0: 74 68 69 6e 67 20 6f 74 68 65 72 20 74 68 61 6e thing other than
6af0: 20 76 69 65 77 20 6f 72 20 63 6f 6e 74 72 6f 6c view or control
6b00: 20 61 6e 64 20 74 68 65 20 64 65 66 61 75 6c 74 and the default
6b10: 29 0a 3b 3b 20 20 27 76 69 65 77 20 20 20 20 20 ).;; 'view
6b20: 3d 3e 20 6c 6f 61 64 20 76 69 65 77 20 6f 6e 6c => load view onl
6b30: 79 0a 3b 3b 20 20 27 63 6f 6e 74 72 6f 6c 20 20 y.;; 'control
6b40: 3d 3e 20 6c 6f 61 64 20 63 6f 6e 74 72 6f 6c 20 => load control
6b50: 6f 6e 6c 79 0a 28 64 65 66 69 6e 65 20 28 73 65 only.(define (se
6b60: 73 73 69 6f 6e 3a 63 61 6c 6c 2d 70 61 72 74 73 ssion:call-parts
6b70: 20 73 65 6c 66 20 70 61 67 65 20 23 21 6b 65 79 self page #!key
6b80: 20 28 70 61 72 74 73 20 27 62 6f 74 68 29 29 0a (parts 'both)).
6b90: 20 20 28 73 64 61 74 2d 73 65 74 2d 63 75 72 72 (sdat-set-curr
6ba0: 2d 70 61 67 65 21 20 73 65 6c 66 20 70 61 67 65 -page! self page
6bb0: 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 69 72 2d ). (let* ((dir-
6bc0: 73 74 79 6c 65 20 20 20 20 28 73 64 61 74 2d 67 style (sdat-g
6bd0: 65 74 2d 70 61 67 65 2d 64 69 72 2d 73 74 79 6c et-page-dir-styl
6be0: 65 20 73 65 6c 66 29 29 3b 3b 20 28 65 71 75 61 e self));; (equa
6bf0: 6c 3f 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 l? (sdat-get-pag
6c00: 65 2d 64 69 72 2d 73 74 79 6c 65 20 73 65 6c 66 e-dir-style self
6c10: 29 20 22 6f 6e 65 64 69 72 22 29 29 20 3b 3b 20 ) "onedir")) ;;
6c20: 66 6c 61 67 20 23 74 20 66 6f 72 20 6f 6e 65 64 flag #t for oned
6c30: 69 72 2c 20 23 66 20 66 6f 72 20 6f 6c 64 20 73 ir, #f for old s
6c40: 74 79 6c 65 0a 09 20 28 64 69 72 20 20 20 20 20 tyle.. (dir
6c50: 20 20 20 20 20 28 73 74 72 69 6e 67 2d 61 70 70 (string-app
6c60: 65 6e 64 20 28 73 64 61 74 2d 67 65 74 2d 73 72 end (sdat-get-sr
6c70: 6f 6f 74 20 73 65 6c 66 29 20 0a 09 09 09 09 20 oot self) .....
6c80: 20 20 20 20 20 28 69 66 20 64 69 72 2d 73 74 79 (if dir-sty
6c90: 6c 65 20 0a 09 09 09 09 09 20 20 28 63 6f 6e 63 le ...... (conc
6ca0: 20 22 2f 70 61 67 65 73 2f 22 29 0a 09 09 09 09 "/pages/").....
6cb0: 09 20 20 28 63 6f 6e 63 20 22 2f 70 61 67 65 73 . (conc "/pages
6cc0: 2f 22 20 70 61 67 65 29 29 29 29 29 0a 20 20 20 /" page))))).
6cd0: 20 28 63 61 73 65 20 64 69 72 2d 73 74 79 6c 65 (case dir-style
6ce0: 0a 20 20 20 20 20 20 3b 3b 20 4e 42 2f 2f 20 53 . ;; NB// S
6cf0: 74 6f 72 65 64 20 61 6c 77 61 79 73 20 6c 6f 61 tored always loa
6d00: 64 73 20 62 6f 74 68 20 63 6f 6e 74 72 6f 6c 20 ds both control
6d10: 61 6e 64 20 76 69 65 77 0a 20 20 20 20 20 20 28 and view. (
6d20: 28 73 74 6f 72 65 64 29 0a 20 20 20 20 20 20 20 (stored).
6d30: 28 28 65 76 61 6c 20 28 73 74 72 69 6e 67 2d 3e ((eval (string->
6d40: 73 79 6d 62 6f 6c 20 28 63 6f 6e 63 20 22 70 61 symbol (conc "pa
6d50: 67 65 73 3a 22 20 70 61 67 65 29 29 29 20 0a 09 ges:" page))) ..
6d60: 73 65 6c 66 20 20 20 20 20 20 20 20 20 20 20 20 self
6d70: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
6d80: 74 68 65 20 73 65 73 73 69 6f 6e 0a 09 28 73 64 the session..(sd
6d90: 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 at-get-conn self
6da0: 29 20 20 20 20 20 20 20 20 20 3b 3b 20 74 68 65 ) ;; the
6db0: 20 64 62 20 63 6f 6e 6e 65 63 74 69 6f 6e 0a 09 db connection..
6dc0: 28 73 64 61 74 2d 67 65 74 2d 73 68 61 72 65 64 (sdat-get-shared
6dd0: 2d 68 61 73 68 20 73 65 6c 66 29 20 20 3b 3b 20 -hash self) ;;
6de0: 61 20 73 68 61 72 65 64 20 68 61 73 68 20 74 61 a shared hash ta
6df0: 62 6c 65 20 66 6f 72 20 70 61 73 73 69 6e 67 20 ble for passing
6e00: 64 61 74 61 20 74 6f 2f 66 72 6f 6d 20 70 61 67 data to/from pag
6e10: 65 20 63 61 6c 6c 73 0a 09 29 29 0a 20 20 20 20 e calls..)).
6e20: 20 20 28 28 66 6c 61 74 29 20 20 20 0a 20 20 20 ((flat) .
6e30: 20 20 20 20 28 6c 65 74 2a 20 28 28 73 6f 2d 66 (let* ((so-f
6e40: 69 6c 65 20 20 28 63 6f 6e 63 20 64 69 72 20 70 ile (conc dir p
6e50: 61 67 65 20 22 2e 73 6f 22 29 29 0a 09 20 20 20 age ".so"))..
6e60: 20 20 20 28 73 63 6d 2d 66 69 6c 65 20 28 63 6f (scm-file (co
6e70: 6e 63 20 64 69 72 20 70 61 67 65 20 22 2e 73 63 nc dir page ".sc
6e80: 6d 22 29 29 0a 09 20 20 20 20 20 20 28 73 72 63 m")).. (src
6e90: 2d 66 69 6c 65 20 28 6f 72 20 28 66 69 6c 65 2d -file (or (file-
6ea0: 65 78 69 73 74 73 3f 20 73 6f 2d 66 69 6c 65 29 exists? so-file)
6eb0: 0a 09 09 09 20 20 20 20 28 66 69 6c 65 2d 65 78 .... (file-ex
6ec0: 69 73 74 73 3f 20 73 63 6d 2d 66 69 6c 65 29 29 ists? scm-file))
6ed0: 29 29 0a 09 20 28 69 66 20 73 72 63 2d 66 69 6c )).. (if src-fil
6ee0: 65 0a 09 20 20 20 20 20 28 62 65 67 69 6e 0a 09 e.. (begin..
6ef0: 20 20 20 20 20 20 20 28 6c 6f 61 64 20 73 72 63 (load src
6f00: 2d 66 69 6c 65 29 0a 09 20 20 20 20 20 20 20 28 -file).. (
6f10: 28 65 76 61 6c 20 28 73 74 72 69 6e 67 2d 3e 73 (eval (string->s
6f20: 79 6d 62 6f 6c 20 28 63 6f 6e 63 20 22 70 61 67 ymbol (conc "pag
6f30: 65 73 3a 22 20 70 61 67 65 29 29 29 20 0a 09 09 es:" page))) ...
6f40: 73 65 6c 66 20 20 20 20 20 20 20 20 20 20 20 20 self
6f50: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
6f60: 74 68 65 20 73 65 73 73 69 6f 6e 0a 09 09 28 73 the session...(s
6f70: 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c dat-get-conn sel
6f80: 66 29 20 20 20 20 20 20 20 20 20 3b 3b 20 74 68 f) ;; th
6f90: 65 20 64 62 20 63 6f 6e 6e 65 63 74 69 6f 6e 0a e db connection.
6fa0: 09 09 28 73 64 61 74 2d 67 65 74 2d 73 68 61 72 ..(sdat-get-shar
6fb0: 65 64 2d 68 61 73 68 20 73 65 6c 66 29 20 20 3b ed-hash self) ;
6fc0: 3b 20 61 20 73 68 61 72 65 64 20 68 61 73 68 20 ; a shared hash
6fd0: 74 61 62 6c 65 20 66 6f 72 20 70 61 73 73 69 6e table for passin
6fe0: 67 20 64 61 74 61 20 74 6f 2f 66 72 6f 6d 20 70 g data to/from p
6ff0: 61 67 65 20 63 61 6c 6c 73 0a 09 09 29 29 0a 09 age calls...))..
7000: 20 20 20 20 20 28 6c 69 73 74 20 22 3c 70 3e 50 (list "<p>P
7010: 61 67 65 20 6e 6f 74 20 66 6f 75 6e 64 20 22 20 age not found "
7020: 70 61 67 65 20 22 20 3c 2f 70 3e 22 29 29 29 29 page " </p>"))))
7030: 0a 20 20 20 20 20 20 20 3b 3b 20 66 69 72 73 74 . ;; first
7040: 20 74 68 65 20 63 6f 6e 74 72 6f 6c 0a 20 20 20 the control.
7050: 20 20 20 20 3b 3b 20 28 6c 65 74 20 28 28 63 6f ;; (let ((co
7060: 6e 74 72 6f 6c 2d 66 69 6c 65 20 28 63 6f 6e 63 ntrol-file (conc
7070: 20 22 70 61 67 65 73 2f 22 20 70 61 67 65 20 22 "pages/" page "
7080: 5f 63 74 72 6c 2e 73 63 6d 22 29 29 0a 20 20 20 _ctrl.scm")).
7090: 20 20 20 20 3b 3b 20 20 20 20 20 20 20 28 76 69 ;; (vi
70a0: 65 77 2d 66 69 6c 65 20 20 20 20 28 63 6f 6e 63 ew-file (conc
70b0: 20 22 70 61 67 65 73 2f 22 20 70 61 67 65 20 22 "pages/" page "
70c0: 5f 76 69 65 77 2e 73 63 6d 22 29 29 29 0a 20 20 _view.scm"))).
70d0: 20 20 20 20 20 3b 3b 20 20 20 28 69 66 20 28 61 ;; (if (a
70e0: 6e 64 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f nd (file-exists?
70f0: 20 63 6f 6e 74 72 6f 6c 2d 66 69 6c 65 29 0a 20 control-file).
7100: 20 20 20 20 20 20 3b 3b 20 20 09 20 20 28 6e 6f ;; . (no
7110: 74 20 28 65 71 3f 20 70 61 72 74 73 20 27 76 69 t (eq? parts 'vi
7120: 65 77 29 29 29 0a 20 20 20 20 20 20 20 3b 3b 20 ew))). ;;
7130: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 (begin.
7140: 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 28 ;; (
7150: 73 65 73 73 69 6f 6e 3a 73 65 74 2d 63 61 6c 6c session:set-call
7160: 65 64 21 20 73 65 6c 66 20 70 61 67 65 29 0a 20 ed! self page).
7170: 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 ;;
7180: 20 28 6c 6f 61 64 20 63 6f 6e 74 72 6f 6c 2d 66 (load control-f
7190: 69 6c 65 29 29 29 0a 20 20 20 20 20 20 20 3b 3b ile))). ;;
71a0: 20 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 (if (file-exi
71b0: 73 74 73 3f 20 76 69 65 77 2d 66 69 6c 65 29 0a sts? view-file).
71c0: 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 ;;
71d0: 28 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 70 61 (if (not (eq? pa
71e0: 72 74 73 20 27 63 6f 6e 74 72 6f 6c 29 29 0a 20 rts 'control)).
71f0: 20 20 20 20 20 20 3b 3b 20 20 09 20 28 73 65 73 ;; . (ses
7200: 73 69 6f 6e 3a 70 72 6f 63 65 73 73 2d 66 69 6c sion:process-fil
7210: 65 20 76 69 65 77 2d 66 69 6c 65 29 29 0a 20 20 e view-file)).
7220: 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 28 6c ;; (l
7230: 69 73 74 20 22 3c 70 3e 50 61 67 65 20 6e 6f 74 ist "<p>Page not
7240: 20 66 6f 75 6e 64 20 22 20 70 61 67 65 20 22 20 found " page "
7250: 3c 2f 70 3e 22 29 29 29 0a 20 20 20 20 20 20 28 </p>"))). (
7260: 28 64 69 72 29 20 22 45 52 52 4f 52 3a 20 20 64 (dir) "ERROR: d
7270: 69 72 20 73 74 79 6c 65 20 6e 6f 74 20 79 65 74 ir style not yet
7280: 20 72 65 2d 69 6d 70 6c 65 6d 65 6e 74 65 64 22 re-implemented"
7290: 29 0a 20 20 20 20 20 20 28 65 6c 73 65 0a 20 20 ). (else.
72a0: 20 20 20 20 20 28 6c 69 73 74 20 22 45 52 52 4f (list "ERRO
72b0: 52 3a 20 70 61 67 65 2d 64 69 72 2d 73 74 79 6c R: page-dir-styl
72c0: 65 20 6d 75 73 74 20 62 65 20 73 74 6f 72 65 64 e must be stored
72d0: 2c 20 64 69 72 20 6f 72 20 66 6c 61 74 2c 20 67 , dir or flat, g
72e0: 6f 74 20 22 20 64 69 72 2d 73 74 79 6c 65 29 29 ot " dir-style))
72f0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 )))..(define (se
7300: 73 73 69 6f 6e 3a 63 61 6c 6c 20 73 65 6c 66 20 ssion:call self
7310: 70 61 67 65 20 70 61 72 74 73 29 0a 20 20 28 73 page parts). (s
7320: 65 73 73 69 6f 6e 3a 63 61 6c 6c 2d 70 61 72 74 ession:call-part
7330: 73 20 73 65 6c 66 20 70 61 67 65 20 27 62 6f 74 s self page 'bot
7340: 68 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 h))..;; (define
7350: 28 73 65 73 73 69 6f 6e 3a 6c 6f 61 64 2d 6d 6f (session:load-mo
7360: 64 65 6c 20 73 65 6c 66 20 6d 6f 64 65 6c 29 0a del self model).
7370: 3b 3b 20 20 20 28 6c 65 74 20 28 28 6d 6f 64 65 ;; (let ((mode
7380: 6c 2e 73 63 6d 20 28 73 74 72 69 6e 67 2d 61 70 l.scm (string-ap
7390: 70 65 6e 64 20 28 73 64 61 74 2d 67 65 74 2d 73 pend (sdat-get-s
73a0: 72 6f 6f 74 20 73 65 6c 66 29 20 22 2f 6d 6f 64 root self) "/mod
73b0: 65 6c 73 2f 22 20 6d 6f 64 65 6c 20 22 2e 73 63 els/" model ".sc
73c0: 6d 22 29 29 0a 3b 3b 20 09 28 6d 6f 64 65 6c 2e m")).;; .(model.
73d0: 73 6f 20 20 28 73 74 72 69 6e 67 2d 61 70 70 65 so (string-appe
73e0: 6e 64 20 28 73 64 61 74 2d 67 65 74 2d 73 72 6f nd (sdat-get-sro
73f0: 6f 74 20 73 65 6c 66 29 20 22 2f 6d 6f 64 65 6c ot self) "/model
7400: 73 2f 22 20 6d 6f 64 65 6c 20 22 2e 73 6f 22 29 s/" model ".so")
7410: 29 29 0a 3b 3b 20 20 20 20 20 28 69 66 20 28 66 )).;; (if (f
7420: 69 6c 65 2d 65 78 69 73 74 73 3f 20 6d 6f 64 65 ile-exists? mode
7430: 6c 2e 73 6f 29 0a 3b 3b 20 09 28 6c 6f 61 64 20 l.so).;; .(load
7440: 6d 6f 64 65 6c 2e 73 6f 29 0a 3b 3b 20 09 28 69 model.so).;; .(i
7450: 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 f (file-exists?
7460: 6d 6f 64 65 6c 2e 73 63 6d 29 0a 3b 3b 20 09 20 model.scm).;; .
7470: 20 20 20 28 6c 6f 61 64 20 6d 6f 64 65 6c 2e 73 (load model.s
7480: 63 6d 29 0a 3b 3b 20 09 20 20 20 20 28 73 3a 6c cm).;; . (s:l
7490: 6f 67 20 22 45 52 52 4f 52 3a 20 6d 6f 64 65 6c og "ERROR: model
74a0: 20 22 20 6d 6f 64 65 6c 2e 73 63 6d 20 22 20 6e " model.scm " n
74b0: 6f 74 20 66 6f 75 6e 64 22 29 29 29 29 29 0a 0a ot found")))))..
74c0: 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 65 73 73 ;; (define (sess
74d0: 69 6f 6e 3a 6d 6f 64 65 6c 2d 70 61 74 68 20 73 ion:model-path s
74e0: 65 6c 66 20 6d 6f 64 65 6c 29 0a 3b 3b 20 20 20 elf model).;;
74f0: 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 28 (string-append (
7500: 73 64 61 74 2d 67 65 74 2d 73 72 6f 6f 74 20 73 sdat-get-sroot s
7510: 65 6c 66 29 20 22 2f 6d 6f 64 65 6c 73 2f 22 20 elf) "/models/"
7520: 6d 6f 64 65 6c 20 22 2e 73 63 6d 22 29 29 0a 0a model ".scm"))..
7530: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
7540: 3a 70 70 2d 66 6f 72 6d 64 61 74 20 73 65 6c 66 :pp-formdat self
7550: 29 0a 20 20 28 6c 65 74 20 28 28 64 61 74 20 28 ). (let ((dat (
7560: 66 6f 72 6d 64 61 74 3a 61 6c 6c 2d 3e 73 74 72 formdat:all->str
7570: 69 6e 67 73 20 28 73 64 61 74 2d 67 65 74 2d 66 ings (sdat-get-f
7580: 6f 72 6d 64 61 74 20 73 65 6c 66 29 29 29 29 0a ormdat self)))).
7590: 20 20 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 (string-inte
75a0: 72 73 70 65 72 73 65 20 64 61 74 20 22 3c 62 72 rsperse dat "<br
75b0: 3e 20 22 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 > ")))..(define
75c0: 28 73 65 73 73 69 6f 6e 3a 70 61 72 61 6d 2d 3e (session:param->
75d0: 73 74 72 69 6e 67 20 70 61 72 61 6d 73 29 0a 20 string params).
75e0: 20 3b 3b 20 28 65 72 72 3a 6c 6f 67 20 22 70 61 ;; (err:log "pa
75f0: 72 61 6d 73 3d 22 20 70 61 72 61 6d 73 29 0a 20 rams=" params).
7600: 20 28 69 66 20 28 3c 20 28 6c 65 6e 67 74 68 20 (if (< (length
7610: 70 61 72 61 6d 73 29 20 31 29 0a 20 20 20 20 20 params) 1).
7620: 20 22 22 0a 20 20 20 20 20 20 28 6c 65 74 20 6c "". (let l
7630: 6f 6f 70 20 28 28 6b 65 79 20 28 63 61 72 20 70 oop ((key (car p
7640: 61 72 61 6d 73 29 29 0a 09 09 20 28 76 61 6c 20 arams))... (val
7650: 28 63 61 64 72 20 70 61 72 61 6d 73 29 29 0a 09 (cadr params))..
7660: 09 20 28 74 61 69 6c 20 28 63 64 64 72 20 70 61 . (tail (cddr pa
7670: 72 61 6d 73 29 29 0a 09 09 20 28 72 65 73 75 6c rams))... (resul
7680: 74 20 27 28 29 29 29 0a 09 28 6c 65 74 20 28 28 t '()))..(let ((
7690: 6e 65 77 72 65 73 75 6c 74 20 28 63 6f 6e 73 20 newresult (cons
76a0: 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 28 (string-append (
76b0: 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6b 65 s:any->string ke
76c0: 79 29 20 22 3d 22 20 28 73 3a 61 6e 79 2d 3e 73 y) "=" (s:any->s
76d0: 74 72 69 6e 67 20 76 61 6c 29 29 0a 09 09 09 20 tring val))....
76e0: 20 20 20 20 20 20 72 65 73 75 6c 74 29 29 29 0a result))).
76f0: 09 20 20 28 69 66 20 28 3c 20 28 6c 65 6e 67 74 . (if (< (lengt
7700: 68 20 74 61 69 6c 29 20 31 29 20 3b 3b 20 74 72 h tail) 1) ;; tr
7710: 75 65 20 69 66 20 64 6f 6e 65 0a 09 20 20 20 20 ue if done..
7720: 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 (string-inters
7730: 70 65 72 73 65 20 6e 65 77 72 65 73 75 6c 74 20 perse newresult
7740: 22 26 22 29 0a 09 20 20 20 20 20 20 28 6c 6f 6f "&").. (loo
7750: 70 20 28 63 61 72 20 74 61 69 6c 29 28 63 61 64 p (car tail)(cad
7760: 72 20 74 61 69 6c 29 28 63 64 64 72 20 74 61 69 r tail)(cddr tai
7770: 6c 29 20 6e 65 77 72 65 73 75 6c 74 29 29 29 29 l) newresult))))
7780: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 ))..(define (ses
7790: 73 69 6f 6e 3a 6c 69 6e 6b 2d 74 6f 20 73 65 6c sion:link-to sel
77a0: 66 20 70 61 67 65 20 70 61 72 61 6d 73 29 0a 20 f page params).
77b0: 20 28 6c 65 74 2a 20 28 28 68 74 74 70 73 2d 68 (let* ((https-h
77c0: 6f 73 74 20 20 20 28 67 65 74 2d 65 6e 76 69 72 ost (get-envir
77d0: 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 onment-variable
77e0: 22 48 54 54 50 53 5f 48 4f 53 54 22 29 29 0a 20 "HTTPS_HOST")).
77f0: 20 20 20 20 20 20 20 20 28 66 6f 72 63 65 2d 73 (force-s
7800: 73 6c 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d sl (sdat-get-
7810: 66 6f 72 63 65 2d 73 73 6c 20 73 65 6c 66 29 29 force-ssl self))
7820: 0a 09 20 28 73 65 72 76 65 72 20 20 20 20 20 20 .. (server
7830: 20 28 6f 72 20 68 74 74 70 73 2d 68 6f 73 74 20 (or https-host
7840: 3b 3b 20 41 73 73 75 6d 69 6e 67 20 48 54 54 50 ;; Assuming HTTP
7850: 53 5f 48 4f 53 54 20 69 73 20 6f 6e 6c 79 20 73 S_HOST is only s
7860: 65 74 20 69 66 20 61 76 61 69 6c 61 62 6c 65 0a et if available.
7870: 09 09 09 20 20 20 28 67 65 74 2d 65 6e 76 69 72 ... (get-envir
7880: 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 onment-variable
7890: 22 48 54 54 50 5f 48 4f 53 54 22 29 0a 09 09 09 "HTTP_HOST")....
78a0: 20 20 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d (get-environm
78b0: 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 53 45 ent-variable "SE
78c0: 52 56 45 52 5f 4e 41 4d 45 22 29 0a 09 09 09 20 RVER_NAME")....
78d0: 20 20 28 73 64 61 74 2d 67 65 74 2d 64 6f 6d 61 (sdat-get-doma
78e0: 69 6e 20 73 65 6c 66 29 29 29 0a 20 20 20 20 20 in self))).
78f0: 20 20 20 20 28 66 6f 72 63 65 2d 73 63 72 69 70 (force-scrip
7900: 74 20 20 28 73 64 61 74 2d 67 65 74 2d 73 63 72 t (sdat-get-scr
7910: 69 70 74 20 73 65 6c 66 29 29 0a 09 20 28 73 63 ipt self)).. (sc
7920: 72 69 70 74 20 20 20 20 20 20 20 20 28 6f 72 20 ript (or
7930: 66 6f 72 63 65 2d 73 63 72 69 70 74 0a 09 09 09 force-script....
7940: 20 20 20 20 28 6c 65 74 20 28 28 73 63 72 69 70 (let ((scrip
7950: 74 2d 6e 61 6d 65 20 28 73 74 72 69 6e 67 2d 73 t-name (string-s
7960: 70 6c 69 74 20 28 67 65 74 2d 65 6e 76 69 72 6f plit (get-enviro
7970: 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 nment-variable "
7980: 53 43 52 49 50 54 5f 4e 41 4d 45 22 29 20 22 2f SCRIPT_NAME") "/
7990: 22 29 29 29 0a 09 09 09 20 20 20 20 20 20 28 69 "))).... (i
79a0: 66 20 28 3e 20 28 6c 65 6e 67 74 68 20 73 63 72 f (> (length scr
79b0: 69 70 74 2d 6e 61 6d 65 29 20 31 29 0a 09 09 09 ipt-name) 1)....
79c0: 09 20 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e . (string-appen
79d0: 64 20 28 63 61 72 20 73 63 72 69 70 74 2d 6e 61 d (car script-na
79e0: 6d 65 29 20 22 2f 22 20 28 63 61 64 72 20 73 63 me) "/" (cadr sc
79f0: 72 69 70 74 2d 6e 61 6d 65 29 29 0a 09 09 09 09 ript-name)).....
7a00: 20 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 (get-environme
7a10: 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 53 43 52 nt-variable "SCR
7a20: 49 50 54 5f 4e 41 4d 45 22 29 29 29 29 29 20 3b IPT_NAME"))))) ;
7a30: 3b 20 62 75 69 6c 64 20 73 63 72 69 70 74 20 6e ; build script n
7a40: 61 6d 65 20 66 72 6f 6d 20 66 69 72 73 74 20 74 ame from first t
7a50: 77 6f 20 65 6c 65 6d 65 6e 74 73 2e 20 54 68 69 wo elements. Thi
7a60: 73 20 69 73 20 61 20 68 61 6e 67 6f 76 65 72 20 s is a hangover
7a70: 66 72 6f 6d 20 62 65 66 6f 72 65 20 49 20 75 73 from before I us
7a80: 65 64 20 3f 20 69 6e 20 74 68 65 20 55 52 4c 2e ed ? in the URL.
7a90: 29 0a 20 20 20 20 20 20 20 20 20 28 73 65 73 73 ). (sess
7aa0: 69 6f 6e 2d 6b 65 79 20 20 20 28 73 64 61 74 2d ion-key (sdat-
7ab0: 67 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 get-session-key
7ac0: 73 65 6c 66 29 29 0a 09 20 28 70 61 72 61 6d 73 self)).. (params
7ad0: 74 72 20 20 20 20 20 20 28 73 65 73 73 69 6f 6e tr (session
7ae0: 3a 70 61 72 61 6d 2d 3e 73 74 72 69 6e 67 20 70 :param->string p
7af0: 61 72 61 6d 73 29 29 29 0a 20 20 20 20 28 73 65 arams))). (se
7b00: 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 ssion:log self "
7b10: 73 65 72 76 65 72 3d 22 20 73 65 72 76 65 72 20 server=" server
7b20: 22 20 73 63 72 69 70 74 3d 22 20 73 63 72 69 70 " script=" scrip
7b30: 74 20 22 20 70 61 67 65 3d 22 20 70 61 67 65 29 t " page=" page)
7b40: 0a 20 20 20 20 28 73 74 72 69 6e 67 2d 61 70 70 . (string-app
7b50: 65 6e 64 20 28 69 66 20 28 6f 72 20 68 74 74 70 end (if (or http
7b60: 73 2d 68 6f 73 74 20 66 6f 72 63 65 2d 73 73 6c s-host force-ssl
7b70: 29 0a 09 09 20 20 20 20 20 20 22 68 74 74 70 73 )... "https
7b80: 3a 2f 2f 22 0a 09 09 20 20 20 20 20 20 22 68 74 ://"... "ht
7b90: 74 70 3a 2f 2f 22 29 0a 09 09 20 20 20 73 65 72 tp://")... ser
7ba0: 76 65 72 20 22 2f 22 20 73 63 72 69 70 74 20 22 ver "/" script "
7bb0: 2f 22 20 70 61 67 65 20 22 3f 22 20 70 61 72 61 /" page "?" para
7bc0: 6d 73 74 72 29 29 29 20 3b 3b 20 22 2f 73 6e 3d mstr))) ;; "/sn=
7bd0: 22 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 29 " session-key)))
7be0: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ..(define (sessi
7bf0: 6f 6e 3a 63 67 69 2d 6f 75 74 20 73 65 6c 66 29 on:cgi-out self)
7c00: 0a 20 20 28 6c 65 74 2a 20 28 28 63 6f 6e 74 65 . (let* ((conte
7c10: 6e 74 20 20 28 6c 69 73 74 20 28 73 64 61 74 2d nt (list (sdat-
7c20: 67 65 74 2d 63 6f 6e 74 65 6e 74 2d 74 79 70 65 get-content-type
7c30: 20 73 65 6c 66 29 29 29 20 3b 3b 20 27 28 22 43 self))) ;; '("C
7c40: 6f 6e 74 65 6e 74 2d 74 79 70 65 3a 20 74 65 78 ontent-type: tex
7c50: 74 2f 68 74 6d 6c 3b 20 63 68 61 72 73 65 74 3d t/html; charset=
7c60: 69 73 6f 2d 38 38 35 39 2d 31 5c 6e 5c 6e 22 29 iso-8859-1\n\n")
7c70: 29 0a 09 20 28 68 65 61 64 65 72 20 20 20 28 6c ).. (header (l
7c80: 65 74 20 28 28 63 6f 6f 6b 69 65 20 28 73 64 61 et ((cookie (sda
7c90: 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 2d 63 6f t-get-session-co
7ca0: 6f 6b 69 65 20 73 65 6c 66 29 29 29 0a 09 09 20 okie self)))...
7cb0: 20 20 20 20 28 69 66 20 63 6f 6f 6b 69 65 0a 09 (if cookie..
7cc0: 09 09 20 28 63 6f 6e 73 20 28 73 74 72 69 6e 67 .. (cons (string
7cd0: 2d 61 70 70 65 6e 64 20 22 53 65 74 2d 43 6f 6f -append "Set-Coo
7ce0: 6b 69 65 3a 20 22 20 28 63 61 72 20 63 6f 6f 6b kie: " (car cook
7cf0: 69 65 29 29 0a 09 09 09 20 20 20 20 20 20 20 63 ie)).... c
7d00: 6f 6e 74 65 6e 74 29 0a 09 09 09 20 63 6f 6e 74 ontent).... cont
7d10: 65 6e 74 29 29 29 0a 09 20 28 70 61 67 65 64 61 ent))).. (pageda
7d20: 74 20 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 t (sdat-get-pag
7d30: 65 64 61 74 20 73 65 6c 66 29 29 29 0a 20 20 20 edat self))).
7d40: 20 28 73 3a 63 67 69 2d 6f 75 74 20 0a 20 20 20 (s:cgi-out .
7d50: 20 20 28 63 6f 6e 73 20 68 65 61 64 65 72 20 70 (cons header p
7d60: 61 67 65 64 61 74 29 29 29 29 0a 0a 28 64 65 66 agedat))))..(def
7d70: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 ine (session:log
7d80: 20 73 65 6c 66 20 2e 20 6d 73 67 29 0a 20 20 28 self . msg). (
7d90: 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 70 with-output-to-p
7da0: 6f 72 74 20 28 73 64 61 74 2d 67 65 74 2d 6c 6f ort (sdat-get-lo
7db0: 67 2d 70 6f 72 74 20 73 65 6c 66 29 20 3b 3b 20 g-port self) ;;
7dc0: 28 73 64 61 74 2d 67 65 74 2d 6c 6f 67 70 74 20 (sdat-get-logpt
7dd0: 73 65 6c 66 29 0a 20 20 20 20 28 6c 61 6d 62 64 self). (lambd
7de0: 61 20 28 29 20 0a 20 20 20 20 20 20 28 61 70 70 a () . (app
7df0: 6c 79 20 70 72 69 6e 74 20 6d 73 67 29 29 29 29 ly print msg))))
7e00: 0a 0a 3b 3b 20 65 73 63 61 70 65 2c 20 63 6f 6e ..;; escape, con
7e10: 76 65 72 74 20 6f 72 20 72 65 74 75 72 6e 20 72 vert or return r
7e20: 61 77 20 77 68 65 6e 20 67 69 76 65 6e 20 75 73 aw when given us
7e30: 65 72 20 69 6e 70 75 74 20 64 61 74 61 20 74 68 er input data th
7e40: 61 74 20 70 6f 74 65 6e 74 69 61 6c 6c 79 0a 3b at potentially.;
7e50: 3b 20 63 6f 75 6c 64 20 62 65 20 6d 61 6c 69 63 ; could be malic
7e60: 69 6f 75 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 ious.;;.(define
7e70: 28 73 65 73 73 69 6f 6e 3a 61 70 70 6c 79 2d 74 (session:apply-t
7e80: 79 70 65 2d 70 72 65 66 65 72 65 6e 63 65 20 72 ype-preference r
7e90: 65 73 20 70 61 72 61 6d 73 29 0a 20 20 28 6c 65 es params). (le
7ea0: 74 2a 20 28 28 64 74 79 70 65 20 20 20 20 28 69 t* ((dtype (i
7eb0: 66 20 28 6e 75 6c 6c 3f 20 70 61 72 61 6d 73 29 f (null? params)
7ec0: 0a 09 09 20 20 20 20 20 20 20 27 65 73 63 61 70 ... 'escap
7ed0: 65 64 0a 09 09 20 20 20 20 20 20 20 28 63 61 72 ed... (car
7ee0: 20 70 61 72 61 6d 73 29 29 29 0a 09 20 28 74 61 params))).. (ta
7ef0: 67 73 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f gs (if (null?
7f00: 20 70 61 72 61 6d 73 29 0a 09 09 20 20 20 20 20 params)...
7f10: 20 27 28 29 0a 09 09 20 20 20 20 20 20 28 63 64 '()... (cd
7f20: 72 20 70 61 72 61 6d 73 29 29 29 29 0a 20 20 20 r params)))).
7f30: 20 28 63 61 73 65 20 64 74 79 70 65 0a 20 20 20 (case dtype.
7f40: 20 20 20 28 28 72 61 77 29 20 20 20 20 20 72 65 ((raw) re
7f50: 73 29 0a 20 20 20 20 20 20 28 28 6e 75 6d 62 65 s). ((numbe
7f60: 72 29 20 20 28 69 66 20 28 73 74 72 69 6e 67 3f r) (if (string?
7f70: 20 72 65 73 29 28 73 74 72 69 6e 67 2d 3e 6e 75 res)(string->nu
7f80: 6d 62 65 72 20 72 65 73 29 20 23 66 29 29 0a 20 mber res) #f)).
7f90: 20 20 20 20 20 28 28 65 73 63 61 70 65 64 29 20 ((escaped)
7fa0: 28 69 66 20 28 73 74 72 69 6e 67 3f 20 72 65 73 (if (string? res
7fb0: 29 0a 09 09 20 20 20 20 20 28 73 3a 68 74 6d 6c )... (s:html
7fc0: 2d 66 69 6c 74 65 72 2d 3e 73 74 72 69 6e 67 20 -filter->string
7fd0: 72 65 73 20 74 61 67 73 29 0a 09 09 20 20 20 20 res tags)...
7fe0: 20 72 65 73 29 29 0a 20 20 20 20 20 20 28 28 65 res)). ((e
7ff0: 73 63 61 70 65 64 2d 6e 6c 29 20 28 69 66 20 28 scaped-nl) (if (
8000: 73 74 72 69 6e 67 3f 20 72 65 73 29 20 3b 3b 20 string? res) ;;
8010: 65 73 63 61 70 65 20 5c 6e 20 61 6e 64 20 5c 72 escape \n and \r
8020: 0a 09 09 09 28 73 74 72 69 6e 67 2d 69 6e 74 65 ....(string-inte
8030: 72 73 70 65 72 73 65 0a 09 09 09 20 28 73 74 72 rsperse.... (str
8040: 69 6e 67 2d 73 70 6c 69 74 0a 09 09 09 20 20 28 ing-split.... (
8050: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
8060: 73 65 0a 09 09 09 20 20 20 28 73 74 72 69 6e 67 se.... (string
8070: 2d 73 70 6c 69 74 20 28 73 3a 68 74 6d 6c 2d 66 -split (s:html-f
8080: 69 6c 74 65 72 2d 3e 73 74 72 69 6e 67 20 72 65 ilter->string re
8090: 73 20 74 61 67 73 29 20 22 5c 6e 22 29 0a 09 09 s tags) "\n")...
80a0: 09 20 20 20 22 5c 5c 6e 22 29 0a 09 09 09 20 20 . "\\n")....
80b0: 22 5c 72 22 29 0a 09 09 09 20 22 5c 5c 72 22 29 "\r").... "\\r")
80c0: 0a 09 09 09 72 65 73 29 29 20 3b 3b 20 73 68 6f ....res)) ;; sho
80d0: 75 6c 64 20 72 65 74 75 72 6e 20 23 66 20 69 66 uld return #f if
80e0: 20 6e 6f 74 20 61 20 73 74 72 69 6e 67 20 61 6e not a string an
80f0: 64 20 63 61 6e 27 74 20 65 73 63 61 70 65 20 69 d can't escape i
8100: 74 3f 0a 20 20 20 20 20 20 28 65 6c 73 65 20 20 t?. (else
8110: 20 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 3f (if (string?
8120: 20 72 65 73 29 0a 09 09 20 20 20 20 20 28 73 3a res)... (s:
8130: 68 74 6d 6c 2d 66 69 6c 74 65 72 2d 3e 73 74 72 html-filter->str
8140: 69 6e 67 20 72 65 73 20 27 28 29 29 0a 09 09 20 ing res '())...
8150: 20 20 20 20 72 65 73 29 29 29 29 29 0a 0a 3b 3b res)))))..;;
8160: 20 70 61 72 61 6d 73 20 61 72 65 20 73 74 6f 72 params are stor
8170: 65 64 20 61 73 20 6c 69 73 74 20 6f 66 20 6b 65 ed as list of ke
8180: 79 3d 76 61 6c 0a 3b 3b 0a 28 64 65 66 69 6e 65 y=val.;;.(define
8190: 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 (session:get-pa
81a0: 72 61 6d 20 73 65 6c 66 20 6b 65 79 20 74 79 70 ram self key typ
81b0: 65 2d 70 61 72 61 6d 73 29 0a 20 20 3b 3b 20 28 e-params). ;; (
81c0: 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 3a 73 65 session:log s:se
81d0: 73 73 69 6f 6e 20 22 70 61 72 61 6d 73 3d 22 20 ssion "params="
81e0: 28 73 6c 6f 74 2d 72 65 66 20 73 3a 73 65 73 73 (slot-ref s:sess
81f0: 69 6f 6e 20 27 70 61 72 61 6d 73 29 29 0a 20 20 ion 'params)).
8200: 28 6c 65 74 2a 20 28 28 70 61 72 61 6d 73 20 28 (let* ((params (
8210: 73 64 61 74 2d 67 65 74 2d 70 61 72 61 6d 73 20 sdat-get-params
8220: 73 65 6c 66 29 29 0a 09 20 28 72 65 73 20 20 20 self)).. (res
8230: 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 (session:get-pa
8240: 72 61 6d 2d 66 72 6f 6d 20 70 61 72 61 6d 73 20 ram-from params
8250: 6b 65 79 29 29 29 0a 20 20 20 20 28 73 65 73 73 key))). (sess
8260: 69 6f 6e 3a 61 70 70 6c 79 2d 74 79 70 65 2d 70 ion:apply-type-p
8270: 72 65 66 65 72 65 6e 63 65 20 72 65 73 20 74 79 reference res ty
8280: 70 65 2d 70 61 72 61 6d 73 29 29 29 0a 0a 3b 3b pe-params)))..;;
8290: 20 54 68 69 73 20 6f 6e 65 20 77 69 6c 6c 20 67 This one will g
82a0: 65 74 20 74 68 65 20 66 69 72 73 74 20 76 61 6c et the first val
82b0: 75 65 20 66 6f 75 6e 64 20 72 65 67 61 72 64 6c ue found regardl
82c0: 65 73 73 20 6f 66 20 66 6f 72 6d 0a 3b 3b 20 70 ess of form.;; p
82d0: 61 72 61 6d 3a 20 28 64 74 79 70 65 20 5b 74 61 aram: (dtype [ta
82e0: 67 31 20 74 61 67 32 20 2e 2e 2e 5d 29 0a 3b 3b g1 tag2 ...]).;;
82f0: 20 64 74 79 70 65 3a 0a 3b 3b 20 20 20 20 27 72 dtype:.;; 'r
8300: 61 77 20 20 20 20 20 3a 20 64 6f 20 6e 6f 20 63 aw : do no c
8310: 6f 6e 76 65 72 73 69 6f 6e 0a 3b 3b 20 20 20 20 onversion.;;
8320: 27 6e 75 6d 62 65 72 20 20 3a 20 63 6f 6e 76 65 'number : conve
8330: 72 74 20 74 6f 20 6e 75 6d 62 65 72 2c 20 72 65 rt to number, re
8340: 74 75 72 6e 20 23 66 20 69 66 20 66 61 69 6c 73 turn #f if fails
8350: 0a 3b 3b 20 20 20 20 27 65 73 63 61 70 65 64 20 .;; 'escaped
8360: 3a 20 75 73 65 20 68 74 6d 6c 2d 65 73 63 61 70 : use html-escap
8370: 65 20 74 6f 20 70 72 6f 74 65 63 74 20 74 68 65 e to protect the
8380: 20 69 6e 70 75 74 20 2d 2d 20 74 68 69 73 20 69 input -- this i
8390: 73 20 74 68 65 20 64 65 66 61 75 6c 74 0a 3b 3b s the default.;;
83a0: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
83b0: 6e 3a 67 65 74 2d 69 6e 70 75 74 20 73 65 6c 66 n:get-input self
83c0: 20 6b 65 79 20 70 61 72 61 6d 73 29 0a 20 20 28 key params). (
83d0: 6c 65 74 2a 20 28 28 64 74 79 70 65 20 20 20 20 let* ((dtype
83e0: 28 69 66 20 28 6e 75 6c 6c 3f 20 70 61 72 61 6d (if (null? param
83f0: 73 29 0a 09 09 20 20 20 20 20 20 20 27 65 73 63 s)... 'esc
8400: 61 70 65 64 0a 09 09 20 20 20 20 20 20 20 28 63 aped... (c
8410: 61 72 20 70 61 72 61 6d 73 29 29 29 0a 09 20 28 ar params))).. (
8420: 74 61 67 73 20 20 20 20 28 69 66 20 28 6e 75 6c tags (if (nul
8430: 6c 3f 20 70 61 72 61 6d 73 29 0a 09 09 20 20 20 l? params)...
8440: 20 20 20 27 28 29 0a 09 09 20 20 20 20 20 20 28 '()... (
8450: 63 64 72 20 70 61 72 61 6d 73 29 29 29 0a 09 20 cdr params)))..
8460: 28 66 6f 72 6d 64 61 74 20 28 73 64 61 74 2d 67 (formdat (sdat-g
8470: 65 74 2d 66 6f 72 6d 64 61 74 20 73 65 6c 66 29 et-formdat self)
8480: 29 0a 09 20 28 72 65 73 20 20 20 20 20 28 69 66 ).. (res (if
8490: 20 28 6e 6f 74 20 66 6f 72 6d 64 61 74 29 20 23 (not formdat) #
84a0: 66 0a 09 09 20 20 20 20 20 20 28 69 66 20 28 6f f... (if (o
84b0: 72 20 28 73 74 72 69 6e 67 3f 20 6b 65 79 29 28 r (string? key)(
84c0: 6e 75 6d 62 65 72 3f 20 6b 65 79 29 28 73 79 6d number? key)(sym
84d0: 62 6f 6c 3f 20 6b 65 79 29 29 0a 09 09 09 20 20 bol? key))....
84e0: 28 69 66 20 28 61 6e 64 20 28 76 65 63 74 6f 72 (if (and (vector
84f0: 3f 20 66 6f 72 6d 64 61 74 29 28 65 71 3f 20 28 ? formdat)(eq? (
8500: 76 65 63 74 6f 72 2d 6c 65 6e 67 74 68 20 66 6f vector-length fo
8510: 72 6d 64 61 74 29 20 31 29 28 68 61 73 68 2d 74 rmdat) 1)(hash-t
8520: 61 62 6c 65 3f 20 28 76 65 63 74 6f 72 2d 72 65 able? (vector-re
8530: 66 20 66 6f 72 6d 64 61 74 20 30 29 29 29 0a 09 f formdat 0)))..
8540: 09 09 20 20 20 20 20 20 28 66 6f 72 6d 64 61 74 .. (formdat
8550: 3a 67 65 74 20 66 6f 72 6d 64 61 74 20 6b 65 79 :get formdat key
8560: 29 0a 09 09 09 20 20 20 20 20 20 28 62 65 67 69 ).... (begi
8570: 6e 0a 09 09 09 09 28 73 65 73 73 69 6f 6e 3a 6c n.....(session:l
8580: 6f 67 20 73 65 6c 66 20 22 45 52 52 4f 52 3a 20 og self "ERROR:
8590: 66 6f 72 6d 64 61 74 3a 20 22 20 66 6f 72 6d 64 formdat: " formd
85a0: 61 74 20 22 20 69 73 20 6e 6f 74 20 6f 66 20 63 at " is not of c
85b0: 6c 61 73 73 20 3c 66 6f 72 6d 64 61 74 3e 22 29 lass <formdat>")
85c0: 0a 09 09 09 09 23 66 29 29 0a 09 09 09 20 20 28 .....#f)).... (
85d0: 62 65 67 69 6e 0a 09 09 09 20 20 20 20 28 73 65 begin.... (se
85e0: 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 ssion:log self "
85f0: 45 52 52 4f 52 3a 20 62 61 64 20 6b 65 79 20 22 ERROR: bad key "
8600: 20 6b 65 79 29 0a 09 09 09 20 20 20 20 23 66 29 key).... #f)
8610: 29 29 29 29 0a 20 20 20 20 28 63 61 73 65 20 64 )))). (case d
8620: 74 79 70 65 0a 20 20 20 20 20 20 28 28 72 61 77 type. ((raw
8630: 29 20 20 20 20 20 72 65 73 29 0a 20 20 20 20 20 ) res).
8640: 20 28 28 6e 75 6d 62 65 72 29 20 20 28 69 66 20 ((number) (if
8650: 28 73 74 72 69 6e 67 3f 20 72 65 73 29 28 73 74 (string? res)(st
8660: 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 72 65 73 ring->number res
8670: 29 20 23 66 29 29 0a 20 20 20 20 20 20 28 28 65 ) #f)). ((e
8680: 73 63 61 70 65 64 29 20 28 69 66 20 28 73 74 72 scaped) (if (str
8690: 69 6e 67 3f 20 72 65 73 29 0a 09 09 20 20 20 20 ing? res)...
86a0: 20 28 73 3a 68 74 6d 6c 2d 66 69 6c 74 65 72 2d (s:html-filter-
86b0: 3e 73 74 72 69 6e 67 20 72 65 73 20 74 61 67 73 >string res tags
86c0: 29 0a 09 09 20 20 20 20 20 72 65 73 29 29 0a 20 )... res)).
86d0: 20 20 20 20 20 28 65 6c 73 65 20 20 20 20 20 20 (else
86e0: 28 69 66 20 28 73 74 72 69 6e 67 3f 20 72 65 73 (if (string? res
86f0: 29 0a 09 09 20 20 20 20 20 28 73 3a 68 74 6d 6c )... (s:html
8700: 2d 66 69 6c 74 65 72 2d 3e 73 74 72 69 6e 67 20 -filter->string
8710: 72 65 73 20 27 28 29 29 0a 09 09 20 20 20 20 20 res '())...
8720: 72 65 73 29 29 29 29 29 0a 0a 3b 3b 20 54 68 69 res)))))..;; Thi
8730: 73 20 6f 6e 65 20 77 69 6c 6c 20 67 65 74 20 74 s one will get t
8740: 68 65 20 66 69 72 73 74 20 76 61 6c 75 65 20 66 he first value f
8750: 6f 75 6e 64 20 72 65 67 61 72 64 6c 65 73 73 20 ound regardless
8760: 6f 66 20 66 6f 72 6d 0a 28 64 65 66 69 6e 65 20 of form.(define
8770: 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 69 6e 70 (session:get-inp
8780: 75 74 2d 6b 65 79 73 20 73 65 6c 66 29 0a 20 20 ut-keys self).
8790: 28 6c 65 74 2a 20 28 28 66 6f 72 6d 64 61 74 20 (let* ((formdat
87a0: 28 73 64 61 74 2d 67 65 74 2d 66 6f 72 6d 64 61 (sdat-get-formda
87b0: 74 20 73 65 6c 66 29 29 29 0a 20 20 20 20 28 69 t self))). (i
87c0: 66 20 28 6e 6f 74 20 66 6f 72 6d 64 61 74 29 20 f (not formdat)
87d0: 23 66 0a 09 28 69 66 20 28 61 6e 64 20 28 76 65 #f..(if (and (ve
87e0: 63 74 6f 72 3f 20 66 6f 72 6d 64 61 74 29 28 65 ctor? formdat)(e
87f0: 71 3f 20 28 76 65 63 74 6f 72 2d 6c 65 6e 67 74 q? (vector-lengt
8800: 68 20 66 6f 72 6d 64 61 74 29 20 31 29 28 68 61 h formdat) 1)(ha
8810: 73 68 2d 74 61 62 6c 65 3f 20 28 76 65 63 74 6f sh-table? (vecto
8820: 72 2d 72 65 66 20 66 6f 72 6d 64 61 74 20 30 29 r-ref formdat 0)
8830: 29 29 0a 09 20 20 20 20 28 66 6f 72 6d 64 61 74 )).. (formdat
8840: 3a 6b 65 79 73 20 66 6f 72 6d 64 61 74 29 0a 09 :keys formdat)..
8850: 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 (begin..
8860: 20 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 (session:log s
8870: 65 6c 66 20 22 45 52 52 4f 52 3a 20 66 6f 72 6d elf "ERROR: form
8880: 64 61 74 3a 20 22 20 66 6f 72 6d 64 61 74 20 22 dat: " formdat "
8890: 20 69 73 20 6e 6f 74 20 6f 66 20 63 6c 61 73 73 is not of class
88a0: 20 3c 66 6f 72 6d 64 61 74 3e 22 29 0a 09 20 20 <formdat>")..
88b0: 20 20 20 20 23 66 29 29 29 29 29 0a 0a 28 64 65 #f)))))..(de
88c0: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 72 75 fine (session:ru
88d0: 6e 2d 61 63 74 69 6f 6e 73 20 73 65 6c 66 29 0a n-actions self).
88e0: 20 20 28 6c 65 74 2a 20 28 28 61 63 74 69 6f 6e (let* ((action
88f0: 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 (session:get
8900: 2d 70 61 72 61 6d 20 73 65 6c 66 20 27 61 63 74 -param self 'act
8910: 69 6f 6e 20 27 28 72 61 77 29 29 29 0a 09 20 28 ion '(raw))).. (
8920: 70 61 67 65 20 20 20 20 20 20 28 73 64 61 74 2d page (sdat-
8930: 67 65 74 2d 70 61 67 65 20 73 65 6c 66 29 29 29 get-page self)))
8940: 0a 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 . ;; (print "
8950: 61 63 74 69 6f 6e 3d 22 20 61 63 74 69 6f 6e 20 action=" action
8960: 22 20 70 61 67 65 3d 22 20 70 61 67 65 29 0a 20 " page=" page).
8970: 20 20 20 28 69 66 20 61 63 74 69 6f 6e 0a 09 28 (if action..(
8980: 6c 65 74 20 28 28 61 63 74 69 6f 6e 2d 6c 73 74 let ((action-lst
8990: 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 (string-split
89a0: 61 63 74 69 6f 6e 20 22 2e 22 29 29 29 0a 09 20 action ".")))..
89b0: 20 3b 3b 20 28 70 72 69 6e 74 20 22 61 63 74 69 ;; (print "acti
89c0: 6f 6e 2d 6c 73 74 3d 22 20 61 63 74 69 6f 6e 2d on-lst=" action-
89d0: 6c 73 74 29 0a 09 20 20 28 69 66 20 28 6e 6f 74 lst).. (if (not
89e0: 20 28 3d 20 28 6c 65 6e 67 74 68 20 61 63 74 69 (= (length acti
89f0: 6f 6e 2d 6c 73 74 29 20 32 29 29 20 0a 09 20 20 on-lst) 2)) ..
8a00: 20 20 20 20 28 65 72 72 3a 6c 6f 67 20 22 41 63 (err:log "Ac
8a10: 74 69 6f 6e 20 73 68 6f 75 6c 64 20 62 65 20 6f tion should be o
8a20: 66 20 66 6f 72 6d 3a 20 6d 6f 64 75 6c 65 2e 61 f form: module.a
8a30: 63 74 69 6f 6e 22 29 0a 09 20 20 20 20 20 20 28 ction").. (
8a40: 6c 65 74 2a 20 28 28 74 61 72 67 2d 70 61 67 65 let* ((targ-page
8a50: 20 20 20 28 63 61 72 20 61 63 74 69 6f 6e 2d 6c (car action-l
8a60: 73 74 29 29 0a 09 09 20 20 20 20 20 28 70 72 6f st))... (pro
8a70: 63 2d 6e 61 6d 65 20 20 20 28 73 74 72 69 6e 67 c-name (string
8a80: 2d 61 70 70 65 6e 64 20 74 61 72 67 2d 70 61 67 -append targ-pag
8a90: 65 20 22 2d 61 63 74 69 6f 6e 22 29 29 0a 09 09 e "-action"))...
8aa0: 20 20 20 20 20 28 74 61 72 67 2d 61 63 74 69 6f (targ-actio
8ab0: 6e 20 28 63 61 64 72 20 61 63 74 69 6f 6e 2d 6c n (cadr action-l
8ac0: 73 74 29 29 29 0a 09 09 3b 3b 20 28 65 72 72 3a st)))...;; (err:
8ad0: 6c 6f 67 20 22 74 61 72 67 2d 70 61 67 65 3d 22 log "targ-page="
8ae0: 20 74 61 72 67 2d 70 61 67 65 20 22 20 70 72 6f targ-page " pro
8af0: 63 2d 6e 61 6d 65 3d 22 20 70 72 6f 63 2d 6e 61 c-name=" proc-na
8b00: 6d 65 20 22 20 74 61 72 67 2d 61 63 74 69 6f 6e me " targ-action
8b10: 3d 22 20 74 61 72 67 2d 61 63 74 69 6f 6e 29 0a =" targ-action).
8b20: 0a 09 09 3b 3b 20 63 61 6c 6c 20 68 65 72 65 20 ...;; call here
8b30: 6f 6e 6c 79 20 69 66 20 6e 65 76 65 72 20 63 61 only if never ca
8b40: 6c 6c 65 64 20 62 65 66 6f 72 65 0a 09 09 28 69 lled before...(i
8b50: 66 20 28 73 65 73 73 69 6f 6e 3a 6e 65 76 65 72 f (session:never
8b60: 2d 63 61 6c 6c 65 64 2d 70 61 67 65 3f 20 73 65 -called-page? se
8b70: 6c 66 20 74 61 72 67 2d 70 61 67 65 29 0a 09 09 lf targ-page)...
8b80: 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 63 61 6c (session:cal
8b90: 6c 2d 70 61 72 74 73 20 73 65 6c 66 20 74 61 72 l-parts self tar
8ba0: 67 2d 70 61 67 65 20 27 63 6f 6e 74 72 6f 6c 29 g-page 'control)
8bb0: 29 0a 09 09 3b 3b 20 20 20 20 20 20 20 20 20 20 )...;;
8bc0: 20 20 20 20 20 20 20 20 20 20 70 72 6f 63 20 20 proc
8bd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8be0: 20 20 20 20 20 20 20 61 63 74 69 6f 6e 20 20 20 action
8bf0: 20 0a 0a 09 09 28 69 66 20 23 74 20 3b 3b 20 73 ....(if #t ;; s
8c00: 65 74 20 74 6f 20 23 74 20 74 6f 20 73 65 65 20 et to #t to see
8c10: 62 65 74 74 65 72 20 65 72 72 6f 72 20 6d 65 73 better error mes
8c20: 73 61 67 65 73 20 64 75 72 69 6e 67 20 64 65 62 sages during deb
8c30: 75 67 67 69 6e 20 3a 2d 29 0a 09 09 20 20 20 20 uggin :-)...
8c40: 28 28 65 76 61 6c 20 28 73 74 72 69 6e 67 2d 3e ((eval (string->
8c50: 73 79 6d 62 6f 6c 20 70 72 6f 63 2d 6e 61 6d 65 symbol proc-name
8c60: 29 29 20 74 61 72 67 2d 61 63 74 69 6f 6e 29 20 )) targ-action)
8c70: 3b 3b 20 75 6e 73 61 66 65 20 65 78 65 63 75 74 ;; unsafe execut
8c80: 69 6f 6e 0a 09 09 20 20 20 20 28 63 6f 6e 64 69 ion... (condi
8c90: 74 69 6f 6e 2d 63 61 73 65 20 28 28 65 76 61 6c tion-case ((eval
8ca0: 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c (string->symbol
8cb0: 20 70 72 6f 63 2d 6e 61 6d 65 29 29 20 74 61 72 proc-name)) tar
8cc0: 67 2d 61 63 74 69 6f 6e 29 0a 09 09 09 09 20 20 g-action).....
8cd0: 20 20 28 28 65 78 6e 20 66 69 6c 65 29 20 28 73 ((exn file) (s
8ce0: 3a 6c 6f 67 20 22 66 69 6c 65 20 65 72 72 6f 72 :log "file error
8cf0: 22 29 29 0a 09 09 09 09 20 20 20 20 28 28 65 78 "))..... ((ex
8d00: 6e 20 69 2f 6f 29 20 20 28 73 3a 6c 6f 67 20 22 n i/o) (s:log "
8d10: 69 2f 6f 20 65 72 72 6f 72 22 29 29 0a 09 09 09 i/o error"))....
8d20: 09 20 20 20 20 28 28 65 78 6e 20 29 20 20 20 20 . ((exn )
8d30: 20 28 73 3a 6c 6f 67 20 22 41 63 74 69 6f 6e 20 (s:log "Action
8d40: 6e 6f 74 20 69 6d 70 6c 65 6d 65 6e 74 65 64 3a not implemented:
8d50: 20 22 20 70 72 6f 63 2d 6e 61 6d 65 20 22 20 61 " proc-name " a
8d60: 63 74 69 6f 6e 3a 20 22 20 74 61 72 67 2d 61 63 ction: " targ-ac
8d70: 74 69 6f 6e 29 29 0a 09 09 09 09 20 20 20 20 28 tion))..... (
8d80: 76 61 72 20 28 29 20 20 20 20 20 28 73 3a 6c 6f var () (s:lo
8d90: 67 20 22 55 6e 6b 6e 6f 77 6e 20 45 72 72 6f 72 g "Unknown Error
8da0: 22 29 29 29 29 29 29 29 29 29 29 0a 0a 28 64 65 "))))))))))..(de
8db0: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 6e 65 fine (session:ne
8dc0: 76 65 72 2d 63 61 6c 6c 65 64 2d 70 61 67 65 3f ver-called-page?
8dd0: 20 73 65 6c 66 20 70 61 67 65 29 0a 20 20 28 73 self page). (s
8de0: 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 ession:log self
8df0: 22 43 68 65 63 6b 69 6e 67 20 66 6f 72 20 70 61 "Checking for pa
8e00: 67 65 3a 20 22 20 70 61 67 65 29 0a 20 20 28 6e ge: " page). (n
8e10: 6f 74 20 28 6d 65 6d 62 65 72 20 70 61 67 65 20 ot (member page
8e20: 28 73 64 61 74 2d 67 65 74 2d 73 65 65 6e 2d 70 (sdat-get-seen-p
8e30: 61 67 65 73 20 73 65 6c 66 29 29 29 29 0a 0a 28 ages self))))..(
8e40: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
8e50: 73 65 74 2d 63 61 6c 6c 65 64 21 20 73 65 6c 66 set-called! self
8e60: 20 70 61 67 65 29 0a 20 20 28 73 64 61 74 2d 73 page). (sdat-s
8e70: 65 74 2d 73 65 65 6e 2d 70 61 67 65 73 21 20 73 et-seen-pages! s
8e80: 65 6c 66 20 28 63 6f 6e 73 20 70 61 67 65 20 28 elf (cons page (
8e90: 73 64 61 74 2d 67 65 74 2d 73 65 65 6e 2d 70 61 sdat-get-seen-pa
8ea0: 67 65 73 20 73 65 6c 66 29 29 29 29 0a 0a 3b 3b ges self))))..;;
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 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8ef0: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 41 6c 74 65 72 6e ======.;; Altern
8f00: 61 74 69 76 65 20 64 61 74 61 20 74 79 70 65 20 ative data type
8f10: 64 65 6c 69 76 65 72 79 0a 3b 3b 3d 3d 3d 3d 3d delivery.;;=====
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: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8f60: 3d 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 =..(define (sess
8f70: 69 6f 6e 3a 61 6c 74 2d 6f 75 74 20 73 65 6c 66 ion:alt-out self
8f80: 29 0a 20 20 28 6c 65 74 20 28 28 64 61 74 20 28 ). (let ((dat (
8f90: 73 64 61 74 2d 67 65 74 2d 61 6c 74 2d 70 61 67 sdat-get-alt-pag
8fa0: 65 2d 64 61 74 20 73 65 6c 66 29 29 29 0a 20 20 e-dat self))).
8fb0: 20 20 3b 3b 20 28 73 3a 6c 6f 67 20 22 64 61 74 ;; (s:log "dat
8fc0: 20 69 73 3a 20 22 20 64 61 74 29 0a 20 20 20 20 is: " dat).
8fd0: 3b 3b 20 28 70 72 69 6e 74 20 22 48 54 54 50 2f ;; (print "HTTP/
8fe0: 31 2e 31 20 32 30 30 20 4f 4b 22 29 0a 20 20 20 1.1 200 OK").
8ff0: 20 28 70 72 69 6e 74 20 22 44 61 74 65 3a 20 22 (print "Date: "
9000: 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 20 28 (time->string (
9010: 73 65 63 6f 6e 64 73 2d 3e 75 74 63 2d 74 69 6d seconds->utc-tim
9020: 65 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e e (current-secon
9030: 64 73 29 29 29 29 0a 20 20 20 20 28 70 72 69 6e ds)))). (prin
9040: 74 20 22 43 6f 6e 74 65 6e 74 2d 54 79 70 65 3a t "Content-Type:
9050: 20 22 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e " (sdat-get-con
9060: 74 65 6e 74 2d 74 79 70 65 20 73 65 6c 66 29 29 tent-type self))
9070: 0a 20 20 20 20 28 70 72 69 6e 74 20 22 41 63 63 . (print "Acc
9080: 65 70 74 2d 52 61 6e 67 65 73 3a 20 62 79 74 65 ept-Ranges: byte
9090: 73 22 29 0a 20 20 20 20 28 70 72 69 6e 74 20 22 s"). (print "
90a0: 43 6f 6e 74 65 6e 74 2d 4c 65 6e 67 74 68 3a 20 Content-Length:
90b0: 22 20 28 69 66 20 28 62 6c 6f 62 3f 20 64 61 74 " (if (blob? dat
90c0: 29 0a 09 09 09 09 20 20 28 62 6c 6f 62 2d 73 69 )..... (blob-si
90d0: 7a 65 20 64 61 74 29 0a 09 09 09 09 20 20 30 29 ze dat)..... 0)
90e0: 29 0a 20 20 20 20 28 70 72 69 6e 74 20 22 4b 65 ). (print "Ke
90f0: 65 70 2d 41 6c 69 76 65 3a 20 74 69 6d 65 6f 75 ep-Alive: timeou
9100: 74 3d 31 35 2c 20 6d 61 78 3d 31 30 30 22 29 0a t=15, max=100").
9110: 20 20 20 20 28 70 72 69 6e 74 20 22 43 6f 6e 6e (print "Conn
9120: 65 63 74 69 6f 6e 3a 20 4b 65 65 70 2d 41 6c 69 ection: Keep-Ali
9130: 76 65 22 29 0a 20 20 20 20 28 70 72 69 6e 74 20 ve"). (print
9140: 22 22 29 0a 20 20 20 20 28 77 72 69 74 65 2d 73 ""). (write-s
9150: 74 72 69 6e 67 20 28 62 6c 6f 62 2d 3e 73 74 72 tring (blob->str
9160: 69 6e 67 20 64 61 74 29 20 23 66 20 28 63 75 72 ing dat) #f (cur
9170: 72 65 6e 74 2d 6f 75 74 70 75 74 2d 70 6f 72 74 rent-output-port
9180: 29 29 29 29 0a )))).