Artifact
0524c59e8f71532dba55c1f61d41003dab1ae262:
0000: 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 30 ;; Copyright 200
0010: 37 2d 32 30 31 31 2c 20 4d 61 74 74 68 65 77 20 7-2011, Matthew
0020: 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b 20 Welland..;; .;;
0030: 20 54 68 69 73 20 70 72 6f 67 72 61 6d 20 69 73 This program is
0040: 20 6d 61 64 65 20 61 76 61 69 6c 61 62 6c 65 20 made available
0050: 75 6e 64 65 72 20 74 68 65 20 47 4e 55 20 47 50 under the GNU GP
0060: 4c 20 76 65 72 73 69 6f 6e 20 32 2e 30 20 6f 72 L version 2.0 or
0070: 0a 3b 3b 20 20 67 72 65 61 74 65 72 2e 20 53 65 .;; greater. Se
0080: 65 20 74 68 65 20 61 63 63 6f 6d 70 61 6e 79 69 e the accompanyi
0090: 6e 67 20 66 69 6c 65 20 43 4f 50 59 49 4e 47 20 ng file COPYING
00a0: 66 6f 72 20 64 65 74 61 69 6c 73 2e 0a 3b 3b 20 for details..;;
00b0: 0a 3b 3b 20 20 54 68 69 73 20 70 72 6f 67 72 61 .;; This progra
00c0: 6d 20 69 73 20 64 69 73 74 72 69 62 75 74 65 64 m is distributed
00d0: 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 52 WITHOUT ANY WAR
00e0: 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 65 RANTY; without e
00f0: 76 65 6e 20 74 68 65 0a 3b 3b 20 20 69 6d 70 6c ven the.;; impl
0100: 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 20 ied warranty of
0110: 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 20 MERCHANTABILITY
0120: 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 41 or FITNESS FOR A
0130: 20 50 41 52 54 49 43 55 4c 41 52 0a 3b 3b 20 20 PARTICULAR.;;
0140: 50 55 52 50 4f 53 45 2e 0a 0a 28 64 65 63 6c 61 PURPOSE...(decla
0150: 72 65 20 28 75 6e 69 74 20 73 65 73 73 69 6f 6e re (unit session
0160: 29 29 0a 28 72 65 71 75 69 72 65 2d 6c 69 62 72 )).(require-libr
0170: 61 72 79 20 64 62 69 29 0a 28 75 73 65 20 72 65 ary dbi).(use re
0180: 67 65 78 29 0a 28 64 65 63 6c 61 72 65 20 28 75 gex).(declare (u
0190: 73 65 73 20 63 6f 6f 6b 69 65 29 29 0a 0a 3b 3b ses cookie))..;;
01a0: 20 73 65 73 73 69 6f 6e 73 20 74 61 62 6c 65 0a sessions table.
01b0: 3b 3b 20 69 64 20 73 65 73 73 69 6f 6e 5f 69 64 ;; id session_id
01c0: 20 73 65 73 73 69 6f 6e 5f 6b 65 79 0a 3b 3b 20 session_key.;;
01d0: 63 72 65 61 74 65 20 74 61 62 6c 65 20 73 65 73 create table ses
01e0: 73 69 6f 6e 73 20 28 69 64 20 73 65 72 69 61 6c sions (id serial
01f0: 20 6e 6f 74 20 6e 75 6c 6c 2c 73 65 73 73 69 6f not null,sessio
0200: 6e 2d 6b 65 79 20 74 65 78 74 29 3b 0a 0a 3b 3b n-key text);..;;
0210: 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 74 61 session_vars ta
0220: 62 6c 65 0a 3b 3b 20 69 64 20 73 65 73 73 69 6f ble.;; id sessio
0230: 6e 5f 69 64 20 70 61 67 65 5f 69 64 20 6b 65 79 n_id page_id key
0240: 20 76 61 6c 75 65 0a 3b 3b 20 63 72 65 61 74 65 value.;; create
0250: 20 74 61 62 6c 65 20 73 65 73 73 69 6f 6e 5f 76 table session_v
0260: 61 72 73 20 28 69 64 20 73 65 72 69 61 6c 20 6e ars (id serial n
0270: 6f 74 20 6e 75 6c 6c 2c 73 65 73 73 69 6f 6e 5f ot null,session_
0280: 69 64 20 69 6e 74 65 67 65 72 2c 70 61 67 65 20 id integer,page
0290: 74 65 78 74 2c 6b 65 79 20 74 65 78 74 2c 76 61 text,key text,va
02a0: 6c 75 65 20 74 65 78 74 29 3b 0a 0a 3b 3b 20 54 lue text);..;; T
02b0: 4f 44 4f 0a 3b 3b 20 20 43 6f 6e 63 65 70 74 20 ODO.;; Concept
02c0: 6f 66 20 6f 72 64 65 72 20 6e 75 6d 20 69 6e 63 of order num inc
02d0: 72 65 6d 65 6e 74 65 64 20 77 69 74 68 20 65 61 remented with ea
02e0: 63 68 20 70 61 67 65 20 61 63 63 65 73 73 0a 3b ch page access.;
02f0: 3b 20 20 20 20 20 69 66 20 61 20 62 72 61 6e 63 ; if a branc
0300: 68 20 69 73 20 74 61 6b 65 6e 20 74 68 65 6e 20 h is taken then
0310: 61 20 6e 65 77 20 73 65 73 73 69 6f 6e 20 77 6f a new session wo
0320: 75 6c 64 20 6e 65 65 64 20 74 6f 20 62 65 20 63 uld need to be c
0330: 72 65 61 74 65 64 0a 3b 3b 0a 0a 3b 3b 20 6d 61 reated.;;..;; ma
0340: 6b 65 2d 76 65 63 74 6f 72 2d 72 65 63 6f 72 64 ke-vector-record
0350: 20 73 65 73 73 69 6f 6e 20 73 65 73 73 69 6f 6e session session
0360: 20 64 62 74 79 70 65 20 64 62 69 6e 69 74 20 63 dbtype dbinit c
0370: 6f 6e 6e 20 70 61 72 61 6d 73 20 70 61 74 68 2d onn params path-
0380: 70 61 72 61 6d 73 20 73 65 73 73 69 6f 6e 2d 6b params session-k
0390: 65 79 20 73 65 73 73 69 6f 6e 2d 69 64 20 64 6f ey session-id do
03a0: 6d 61 69 6e 20 74 6f 70 70 61 67 65 20 70 61 67 main toppage pag
03b0: 65 20 63 75 72 72 2d 70 61 67 65 20 63 6f 6e 74 e curr-page cont
03c0: 65 6e 74 2d 74 79 70 65 20 70 61 67 65 2d 74 79 ent-type page-ty
03d0: 70 65 20 73 72 6f 6f 74 20 74 77 69 6b 69 64 69 pe sroot twikidi
03e0: 72 20 70 61 67 65 64 61 74 20 61 6c 74 2d 70 61 r pagedat alt-pa
03f0: 67 65 2d 64 61 74 20 70 61 67 65 76 61 72 73 20 ge-dat pagevars
0400: 70 61 67 65 76 61 72 73 2d 62 65 66 6f 72 65 20 pagevars-before
0410: 73 65 73 73 69 6f 6e 76 61 72 73 20 73 65 73 73 sessionvars sess
0420: 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 20 67 ionvars-before g
0430: 6c 6f 62 61 6c 76 61 72 73 20 67 6c 6f 62 61 6c lobalvars global
0440: 76 61 72 73 2d 62 65 66 6f 72 65 20 6c 6f 67 70 vars-before logp
0450: 74 20 66 6f 72 6d 64 61 74 20 72 65 71 75 65 73 t formdat reques
0460: 74 2d 6d 65 74 68 6f 64 20 73 65 73 73 69 6f 6e t-method session
0470: 2d 63 6f 6f 6b 69 65 20 63 75 72 72 2d 65 72 72 -cookie curr-err
0480: 20 6c 6f 67 2d 70 6f 72 74 20 6c 6f 67 66 69 6c log-port logfil
0490: 65 20 73 65 65 6e 2d 70 61 67 65 73 20 70 61 67 e seen-pages pag
04a0: 65 2d 64 69 72 2d 73 74 79 6c 65 20 64 65 62 75 e-dir-style debu
04b0: 67 6d 6f 64 65 0a 28 64 65 66 69 6e 65 20 28 6d gmode.(define (m
04c0: 61 6b 65 2d 73 64 61 74 29 28 6d 61 6b 65 2d 76 ake-sdat)(make-v
04d0: 65 63 74 6f 72 20 33 33 29 29 0a 28 64 65 66 69 ector 33)).(defi
04e0: 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 64 62 74 ne (sdat-get-dbt
04f0: 79 70 65 20 20 20 20 20 20 20 20 20 20 20 20 20 ype
0500: 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f vec) (vecto
0510: 72 2d 72 65 66 20 20 76 65 63 20 30 29 29 0a 28 r-ref vec 0)).(
0520: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 define (sdat-get
0530: 2d 64 62 69 6e 69 74 20 20 20 20 20 20 20 20 20 -dbinit
0540: 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 vec) (v
0550: 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 31 ector-ref vec 1
0560: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
0570: 2d 67 65 74 2d 63 6f 6e 6e 20 20 20 20 20 20 20 -get-conn
0580: 20 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 vec)
0590: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 (vector-ref v
05a0: 65 63 20 32 29 29 0a 28 64 65 66 69 6e 65 20 28 ec 2)).(define (
05b0: 73 64 61 74 2d 67 65 74 2d 70 61 72 61 6d 73 20 sdat-get-params
05c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 ve
05d0: 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 c) (vector-re
05e0: 66 20 20 76 65 63 20 33 29 29 0a 28 64 65 66 69 f vec 3)).(defi
05f0: 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 70 61 74 ne (sdat-get-pat
0600: 68 2d 70 61 72 61 6d 73 20 20 20 20 20 20 20 20 h-params
0610: 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f vec) (vecto
0620: 72 2d 72 65 66 20 20 76 65 63 20 34 29 29 0a 28 r-ref vec 4)).(
0630: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 define (sdat-get
0640: 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 20 20 20 -session-key
0650: 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 vec) (v
0660: 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 35 ector-ref vec 5
0670: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
0680: 2d 67 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 -get-session-id
0690: 20 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 vec)
06a0: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 (vector-ref v
06b0: 65 63 20 36 29 29 0a 28 64 65 66 69 6e 65 20 28 ec 6)).(define (
06c0: 73 64 61 74 2d 67 65 74 2d 64 6f 6d 61 69 6e 20 sdat-get-domain
06d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 ve
06e0: 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 c) (vector-re
06f0: 66 20 20 76 65 63 20 37 29 29 0a 28 64 65 66 69 f vec 7)).(defi
0700: 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 74 6f 70 ne (sdat-get-top
0710: 70 61 67 65 20 20 20 20 20 20 20 20 20 20 20 20 page
0720: 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f vec) (vecto
0730: 72 2d 72 65 66 20 20 76 65 63 20 38 29 29 0a 28 r-ref vec 8)).(
0740: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 define (sdat-get
0750: 2d 70 61 67 65 20 20 20 20 20 20 20 20 20 20 20 -page
0760: 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 vec) (v
0770: 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 39 ector-ref vec 9
0780: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
0790: 2d 67 65 74 2d 63 75 72 72 2d 70 61 67 65 20 20 -get-curr-page
07a0: 20 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 vec)
07b0: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 (vector-ref v
07c0: 65 63 20 31 30 29 29 0a 28 64 65 66 69 6e 65 20 ec 10)).(define
07d0: 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 74 65 6e (sdat-get-conten
07e0: 74 2d 74 79 70 65 20 20 20 20 20 20 20 20 20 76 t-type v
07f0: 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 ec) (vector-r
0800: 65 66 20 20 76 65 63 20 31 31 29 29 0a 28 64 65 ef vec 11)).(de
0810: 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 70 fine (sdat-get-p
0820: 61 67 65 2d 74 79 70 65 20 20 20 20 20 20 20 20 age-type
0830: 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 vec) (vec
0840: 74 6f 72 2d 72 65 66 20 20 76 65 63 20 31 32 29 tor-ref vec 12)
0850: 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d ).(define (sdat-
0860: 67 65 74 2d 73 72 6f 6f 74 20 20 20 20 20 20 20 get-sroot
0870: 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 vec)
0880: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 (vector-ref ve
0890: 63 20 31 33 29 29 0a 28 64 65 66 69 6e 65 20 28 c 13)).(define (
08a0: 73 64 61 74 2d 67 65 74 2d 74 77 69 6b 69 64 69 sdat-get-twikidi
08b0: 72 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 r ve
08c0: 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 c) (vector-re
08d0: 66 20 20 76 65 63 20 31 34 29 29 0a 28 64 65 66 f vec 14)).(def
08e0: 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 70 61 ine (sdat-get-pa
08f0: 67 65 64 61 74 20 20 20 20 20 20 20 20 20 20 20 gedat
0900: 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 vec) (vect
0910: 6f 72 2d 72 65 66 20 20 76 65 63 20 31 35 29 29 or-ref vec 15))
0920: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 .(define (sdat-g
0930: 65 74 2d 61 6c 74 2d 70 61 67 65 2d 64 61 74 20 et-alt-page-dat
0940: 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 vec)
0950: 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 (vector-ref vec
0960: 20 31 36 29 29 0a 28 64 65 66 69 6e 65 20 28 73 16)).(define (s
0970: 64 61 74 2d 67 65 74 2d 70 61 67 65 76 61 72 73 dat-get-pagevars
0980: 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 vec
0990: 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 ) (vector-ref
09a0: 20 20 76 65 63 20 31 37 29 29 0a 28 64 65 66 69 vec 17)).(defi
09b0: 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 ne (sdat-get-pag
09c0: 65 76 61 72 73 2d 62 65 66 6f 72 65 20 20 20 20 evars-before
09d0: 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f vec) (vecto
09e0: 72 2d 72 65 66 20 20 76 65 63 20 31 38 29 29 0a r-ref vec 18)).
09f0: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 (define (sdat-ge
0a00: 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 20 20 20 t-sessionvars
0a10: 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 vec) (
0a20: 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 vector-ref vec
0a30: 31 39 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 19)).(define (sd
0a40: 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 at-get-sessionva
0a50: 72 73 2d 62 65 66 6f 72 65 20 20 20 76 65 63 29 rs-before vec)
0a60: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
0a70: 20 76 65 63 20 32 30 29 29 0a 28 64 65 66 69 6e vec 20)).(defin
0a80: 65 20 28 73 64 61 74 2d 67 65 74 2d 67 6c 6f 62 e (sdat-get-glob
0a90: 61 6c 76 61 72 73 20 20 20 20 20 20 20 20 20 20 alvars
0aa0: 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 vec) (vector
0ab0: 2d 72 65 66 20 20 76 65 63 20 32 31 29 29 0a 28 -ref vec 21)).(
0ac0: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 define (sdat-get
0ad0: 2d 67 6c 6f 62 61 6c 76 61 72 73 2d 62 65 66 6f -globalvars-befo
0ae0: 72 65 20 20 20 20 76 65 63 29 20 20 20 20 28 76 re vec) (v
0af0: 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 32 ector-ref vec 2
0b00: 32 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 2)).(define (sda
0b10: 74 2d 67 65 74 2d 6c 6f 67 70 74 20 20 20 20 20 t-get-logpt
0b20: 20 20 20 20 20 20 20 20 20 20 20 76 65 63 29 20 vec)
0b30: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 (vector-ref
0b40: 76 65 63 20 32 33 29 29 0a 28 64 65 66 69 6e 65 vec 23)).(define
0b50: 20 28 73 64 61 74 2d 67 65 74 2d 66 6f 72 6d 64 (sdat-get-formd
0b60: 61 74 20 20 20 20 20 20 20 20 20 20 20 20 20 20 at
0b70: 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d vec) (vector-
0b80: 72 65 66 20 20 76 65 63 20 32 34 29 29 0a 28 64 ref vec 24)).(d
0b90: 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d efine (sdat-get-
0ba0: 72 65 71 75 65 73 74 2d 6d 65 74 68 6f 64 20 20 request-method
0bb0: 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 vec) (ve
0bc0: 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 32 35 ctor-ref vec 25
0bd0: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
0be0: 2d 67 65 74 2d 73 65 73 73 69 6f 6e 2d 63 6f 6f -get-session-coo
0bf0: 6b 69 65 20 20 20 20 20 20 20 76 65 63 29 20 20 kie vec)
0c00: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 (vector-ref v
0c10: 65 63 20 32 36 29 29 0a 28 64 65 66 69 6e 65 20 ec 26)).(define
0c20: 28 73 64 61 74 2d 67 65 74 2d 63 75 72 72 2d 65 (sdat-get-curr-e
0c30: 72 72 20 20 20 20 20 20 20 20 20 20 20 20 20 76 rr v
0c40: 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 ec) (vector-r
0c50: 65 66 20 20 76 65 63 20 32 37 29 29 0a 28 64 65 ef vec 27)).(de
0c60: 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 6c fine (sdat-get-l
0c70: 6f 67 2d 70 6f 72 74 20 20 20 20 20 20 20 20 20 og-port
0c80: 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 vec) (vec
0c90: 74 6f 72 2d 72 65 66 20 20 76 65 63 20 32 38 29 tor-ref vec 28)
0ca0: 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d ).(define (sdat-
0cb0: 67 65 74 2d 6c 6f 67 66 69 6c 65 20 20 20 20 20 get-logfile
0cc0: 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 vec)
0cd0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 (vector-ref ve
0ce0: 63 20 32 39 29 29 0a 28 64 65 66 69 6e 65 20 28 c 29)).(define (
0cf0: 73 64 61 74 2d 67 65 74 2d 73 65 65 6e 2d 70 61 sdat-get-seen-pa
0d00: 67 65 73 20 20 20 20 20 20 20 20 20 20 20 76 65 ges ve
0d10: 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 c) (vector-re
0d20: 66 20 20 76 65 63 20 33 30 29 29 0a 28 64 65 66 f vec 30)).(def
0d30: 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 70 61 ine (sdat-get-pa
0d40: 67 65 2d 64 69 72 2d 73 74 79 6c 65 20 20 20 20 ge-dir-style
0d50: 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 vec) (vect
0d60: 6f 72 2d 72 65 66 20 20 76 65 63 20 33 31 29 29 or-ref vec 31))
0d70: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 .(define (sdat-g
0d80: 65 74 2d 64 65 62 75 67 6d 6f 64 65 20 20 20 20 et-debugmode
0d90: 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 vec)
0da0: 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 (vector-ref vec
0db0: 20 33 32 29 29 0a 28 64 65 66 69 6e 65 20 28 73 32)).(define (s
0dc0: 64 61 74 2d 73 65 74 2d 64 62 74 79 70 65 21 20 dat-set-dbtype!
0dd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 vec
0de0: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
0df0: 21 20 76 65 63 20 30 20 76 61 6c 29 29 0a 28 64 ! vec 0 val)).(d
0e00: 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d efine (sdat-set-
0e10: 64 62 69 6e 69 74 21 20 20 20 20 20 20 20 20 20 dbinit!
0e20: 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 vec val)(ve
0e30: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 31 20 ctor-set! vec 1
0e40: 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 val)).(define (s
0e50: 64 61 74 2d 73 65 74 2d 63 6f 6e 6e 21 20 20 20 dat-set-conn!
0e60: 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 vec
0e70: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
0e80: 21 20 76 65 63 20 32 20 76 61 6c 29 29 0a 28 64 ! vec 2 val)).(d
0e90: 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d efine (sdat-set-
0ea0: 70 61 72 61 6d 73 21 20 20 20 20 20 20 20 20 20 params!
0eb0: 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 vec val)(ve
0ec0: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 33 20 ctor-set! vec 3
0ed0: 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 val)).(define (s
0ee0: 64 61 74 2d 73 65 74 2d 70 61 74 68 2d 70 61 72 dat-set-path-par
0ef0: 61 6d 73 21 20 20 20 20 20 20 20 20 20 76 65 63 ams! vec
0f00: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
0f10: 21 20 76 65 63 20 34 20 76 61 6c 29 29 0a 28 64 ! vec 4 val)).(d
0f20: 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d efine (sdat-set-
0f30: 73 65 73 73 69 6f 6e 2d 6b 65 79 21 20 20 20 20 session-key!
0f40: 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 vec val)(ve
0f50: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 35 20 ctor-set! vec 5
0f60: 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 val)).(define (s
0f70: 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e 2d dat-set-session-
0f80: 69 64 21 20 20 20 20 20 20 20 20 20 20 76 65 63 id! vec
0f90: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
0fa0: 21 20 76 65 63 20 36 20 76 61 6c 29 29 0a 28 64 ! vec 6 val)).(d
0fb0: 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d efine (sdat-set-
0fc0: 64 6f 6d 61 69 6e 21 20 20 20 20 20 20 20 20 20 domain!
0fd0: 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 vec val)(ve
0fe0: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 37 20 ctor-set! vec 7
0ff0: 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 val)).(define (s
1000: 64 61 74 2d 73 65 74 2d 74 6f 70 70 61 67 65 21 dat-set-toppage!
1010: 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 vec
1020: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
1030: 21 20 76 65 63 20 38 20 76 61 6c 29 29 0a 28 64 ! vec 8 val)).(d
1040: 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d efine (sdat-set-
1050: 70 61 67 65 21 20 20 20 20 20 20 20 20 20 20 20 page!
1060: 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 vec val)(ve
1070: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 39 20 ctor-set! vec 9
1080: 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 val)).(define (s
1090: 64 61 74 2d 73 65 74 2d 63 75 72 72 2d 70 61 67 dat-set-curr-pag
10a0: 65 21 20 20 20 20 20 20 20 20 20 20 20 76 65 63 e! vec
10b0: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
10c0: 21 20 76 65 63 20 31 30 20 76 61 6c 29 29 0a 28 ! vec 10 val)).(
10d0: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 define (sdat-set
10e0: 2d 63 6f 6e 74 65 6e 74 2d 74 79 70 65 21 20 20 -content-type!
10f0: 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 vec val)(v
1100: 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 31 ector-set! vec 1
1110: 31 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 1 val)).(define
1120: 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 2d 74 (sdat-set-page-t
1130: 79 70 65 21 20 20 20 20 20 20 20 20 20 20 20 76 ype! v
1140: 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 ec val)(vector-s
1150: 65 74 21 20 76 65 63 20 31 32 20 76 61 6c 29 29 et! vec 12 val))
1160: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 .(define (sdat-s
1170: 65 74 2d 73 72 6f 6f 74 21 20 20 20 20 20 20 20 et-sroot!
1180: 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 vec val)
1190: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 (vector-set! vec
11a0: 20 31 33 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 13 val)).(defin
11b0: 65 20 28 73 64 61 74 2d 73 65 74 2d 74 77 69 6b e (sdat-set-twik
11c0: 69 64 69 72 21 20 20 20 20 20 20 20 20 20 20 20 idir!
11d0: 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 vec val)(vector
11e0: 2d 73 65 74 21 20 76 65 63 20 31 34 20 76 61 6c -set! vec 14 val
11f0: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
1200: 2d 73 65 74 2d 70 61 67 65 64 61 74 21 20 20 20 -set-pagedat!
1210: 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 61 vec va
1220: 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 l)(vector-set! v
1230: 65 63 20 31 35 20 76 61 6c 29 29 0a 28 64 65 66 ec 15 val)).(def
1240: 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 61 6c ine (sdat-set-al
1250: 74 2d 70 61 67 65 2d 64 61 74 21 20 20 20 20 20 t-page-dat!
1260: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
1270: 6f 72 2d 73 65 74 21 20 76 65 63 20 31 36 20 76 or-set! vec 16 v
1280: 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 al)).(define (sd
1290: 61 74 2d 73 65 74 2d 70 61 67 65 76 61 72 73 21 at-set-pagevars!
12a0: 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 20 vec
12b0: 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 val)(vector-set!
12c0: 20 76 65 63 20 31 37 20 76 61 6c 29 29 0a 28 64 vec 17 val)).(d
12d0: 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d efine (sdat-set-
12e0: 70 61 67 65 76 61 72 73 2d 62 65 66 6f 72 65 21 pagevars-before!
12f0: 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 vec val)(ve
1300: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 31 38 ctor-set! vec 18
1310: 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 val)).(define (
1320: 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e sdat-set-session
1330: 76 61 72 73 21 20 20 20 20 20 20 20 20 20 76 65 vars! ve
1340: 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 c val)(vector-se
1350: 74 21 20 76 65 63 20 31 39 20 76 61 6c 29 29 0a t! vec 19 val)).
1360: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 (define (sdat-se
1370: 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 t-sessionvars-be
1380: 66 6f 72 65 21 20 20 76 65 63 20 76 61 6c 29 28 fore! vec val)(
1390: 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 vector-set! vec
13a0: 32 30 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 val)).(define
13b0: 20 28 73 64 61 74 2d 73 65 74 2d 67 6c 6f 62 61 (sdat-set-globa
13c0: 6c 76 61 72 73 21 20 20 20 20 20 20 20 20 20 20 lvars!
13d0: 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d vec val)(vector-
13e0: 73 65 74 21 20 76 65 63 20 32 31 20 76 61 6c 29 set! vec 21 val)
13f0: 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d ).(define (sdat-
1400: 73 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 2d 62 set-globalvars-b
1410: 65 66 6f 72 65 21 20 20 20 76 65 63 20 76 61 6c efore! vec val
1420: 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 )(vector-set! ve
1430: 63 20 32 32 20 76 61 6c 29 29 0a 28 64 65 66 69 c 22 val)).(defi
1440: 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 6c 6f 67 ne (sdat-set-log
1450: 70 74 21 20 20 20 20 20 20 20 20 20 20 20 20 20 pt!
1460: 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f vec val)(vecto
1470: 72 2d 73 65 74 21 20 76 65 63 20 32 33 20 76 61 r-set! vec 23 va
1480: 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 l)).(define (sda
1490: 74 2d 73 65 74 2d 66 6f 72 6d 64 61 74 21 20 20 t-set-formdat!
14a0: 20 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 vec v
14b0: 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 al)(vector-set!
14c0: 76 65 63 20 32 34 20 76 61 6c 29 29 0a 28 64 65 vec 24 val)).(de
14d0: 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 72 fine (sdat-set-r
14e0: 65 71 75 65 73 74 2d 6d 65 74 68 6f 64 21 20 20 equest-method!
14f0: 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 vec val)(vec
1500: 74 6f 72 2d 73 65 74 21 20 76 65 63 20 32 35 20 tor-set! vec 25
1510: 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 val)).(define (s
1520: 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e 2d dat-set-session-
1530: 63 6f 6f 6b 69 65 21 20 20 20 20 20 20 76 65 63 cookie! vec
1540: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
1550: 21 20 76 65 63 20 32 36 20 76 61 6c 29 29 0a 28 ! vec 26 val)).(
1560: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 define (sdat-set
1570: 2d 63 75 72 72 2d 65 72 72 21 20 20 20 20 20 20 -curr-err!
1580: 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 vec val)(v
1590: 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 32 ector-set! vec 2
15a0: 37 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 7 val)).(define
15b0: 28 73 64 61 74 2d 73 65 74 2d 6c 6f 67 2d 70 6f (sdat-set-log-po
15c0: 72 74 21 20 20 20 20 20 20 20 20 20 20 20 20 76 rt! v
15d0: 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 ec val)(vector-s
15e0: 65 74 21 20 76 65 63 20 32 38 20 76 61 6c 29 29 et! vec 28 val))
15f0: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 .(define (sdat-s
1600: 65 74 2d 6c 6f 67 66 69 6c 65 21 20 20 20 20 20 et-logfile!
1610: 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 vec val)
1620: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 (vector-set! vec
1630: 20 32 39 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 29 val)).(defin
1640: 65 20 28 73 64 61 74 2d 73 65 74 2d 73 65 65 6e e (sdat-set-seen
1650: 2d 70 61 67 65 73 21 20 20 20 20 20 20 20 20 20 -pages!
1660: 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 vec val)(vector
1670: 2d 73 65 74 21 20 76 65 63 20 33 30 20 76 61 6c -set! vec 30 val
1680: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
1690: 2d 73 65 74 2d 70 61 67 65 2d 64 69 72 2d 73 74 -set-page-dir-st
16a0: 79 6c 65 21 20 20 20 20 20 20 76 65 63 20 76 61 yle! vec va
16b0: 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 l)(vector-set! v
16c0: 65 63 20 33 31 20 76 61 6c 29 29 0a 28 64 65 66 ec 31 val)).(def
16d0: 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 64 65 ine (sdat-set-de
16e0: 62 75 67 6d 6f 64 65 21 20 20 20 20 20 20 20 20 bugmode!
16f0: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
1700: 6f 72 2d 73 65 74 21 20 76 65 63 20 33 32 20 76 or-set! vec 32 v
1710: 61 6c 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 al))..;; (define
1720: 2d 63 6c 61 73 73 20 3c 73 65 73 73 69 6f 6e 3e -class <session>
1730: 20 28 29 0a 3b 3b 20 20 20 28 64 62 74 79 70 65 ().;; (dbtype
1740: 20 20 20 20 20 20 20 3b 3b 20 27 70 67 20 6f 72 ;; 'pg or
1750: 20 27 73 71 6c 69 74 65 33 0a 3b 3b 20 20 20 20 'sqlite3.;;
1760: 64 62 69 6e 69 74 0a 3b 3b 20 20 20 20 63 6f 6e dbinit.;; con
1770: 6e 0a 3b 3b 20 20 20 20 70 61 72 61 6d 73 20 20 n.;; params
1780: 20 20 20 20 20 3b 3b 20 70 61 72 61 6d 73 20 66 ;; params f
1790: 72 6f 6d 20 74 68 65 20 6b 65 79 3d 76 61 6c 26 rom the key=val&
17a0: 6b 65 79 31 3d 76 61 6c 32 20 73 74 72 69 6e 67 key1=val2 string
17b0: 0a 3b 3b 20 20 20 20 70 61 74 68 2d 70 61 72 61 .;; path-para
17c0: 6d 73 20 20 3b 3b 20 72 65 6d 61 69 6e 69 6e 67 ms ;; remaining
17d0: 20 70 61 72 61 6d 73 20 66 72 6f 6d 20 74 68 65 params from the
17e0: 20 70 61 74 68 0a 3b 3b 20 20 20 20 73 65 73 73 path.;; sess
17f0: 69 6f 6e 2d 6b 65 79 0a 3b 3b 20 20 20 20 73 65 ion-key.;; se
1800: 73 73 69 6f 6e 2d 69 64 0a 3b 3b 20 20 20 20 64 ssion-id.;; d
1810: 6f 6d 61 69 6e 0a 3b 3b 20 20 20 20 74 6f 70 70 omain.;; topp
1820: 61 67 65 20 20 20 20 20 20 3b 3b 20 64 65 66 61 age ;; defa
1830: 75 6c 74 73 20 74 6f 20 22 69 6e 64 65 78 22 20 ults to "index"
1840: 2d 20 6f 76 65 72 72 69 64 65 20 69 6e 20 2e 73 - override in .s
1850: 74 6d 6c 2e 63 6f 6e 66 69 67 20 69 66 20 64 65 tml.config if de
1860: 73 69 72 65 64 0a 3b 3b 20 20 20 20 70 61 67 65 sired.;; page
1870: 20 20 20 20 20 20 20 20 20 3b 3b 20 74 68 65 20 ;; the
1880: 70 61 67 65 20 6e 61 6d 65 20 2d 20 64 65 66 61 page name - defa
1890: 75 6c 74 73 20 74 6f 20 68 6f 6d 65 0a 3b 3b 20 ults to home.;;
18a0: 20 20 20 63 75 72 72 2d 70 61 67 65 20 20 20 20 curr-page
18b0: 3b 3b 20 74 68 65 20 63 75 72 72 65 6e 74 20 70 ;; the current p
18c0: 61 67 65 20 62 65 69 6e 67 20 65 76 61 6c 75 61 age being evalua
18d0: 74 65 64 0a 3b 3b 20 20 20 20 63 6f 6e 74 65 6e ted.;; conten
18e0: 74 2d 74 79 70 65 20 3b 3b 20 74 68 65 20 64 65 t-type ;; the de
18f0: 66 61 75 6c 74 20 63 6f 6e 74 65 6e 74 20 74 79 fault content ty
1900: 70 65 20 69 73 20 74 65 78 74 2f 68 74 6d 6c 2c pe is text/html,
1910: 20 6f 76 65 72 72 69 64 65 20 74 6f 20 64 65 6c override to del
1920: 69 76 65 72 20 6f 74 68 65 72 20 73 74 75 66 66 iver other stuff
1930: 0a 3b 3b 20 20 20 20 70 61 67 65 2d 74 79 70 65 .;; page-type
1940: 20 20 20 20 3b 3b 20 75 73 65 20 69 6e 20 63 6f ;; use in co
1950: 6e 6a 75 6e 63 74 69 6f 6e 20 77 69 74 68 20 63 njunction with c
1960: 6f 6e 74 65 6e 74 2d 74 79 70 65 20 74 6f 20 64 ontent-type to d
1970: 65 6c 69 76 65 72 20 6f 74 68 65 72 20 70 61 79 eliver other pay
1980: 6c 6f 61 64 73 0a 3b 3b 20 20 20 20 73 72 6f 6f loads.;; sroo
1990: 74 0a 3b 3b 20 20 20 20 74 77 69 6b 69 64 69 72 t.;; twikidir
19a0: 20 20 20 20 20 3b 3b 20 6c 6f 63 61 74 69 6f 6e ;; location
19b0: 20 66 6f 72 20 74 77 69 6b 69 73 20 2d 20 6e 65 for twikis - ne
19c0: 65 64 73 20 74 6f 20 62 65 20 66 75 6c 6c 79 20 eds to be fully
19d0: 77 72 69 74 61 62 6c 65 20 62 79 20 77 65 62 20 writable by web
19e0: 73 65 72 76 65 72 0a 3b 3b 20 20 20 20 70 61 67 server.;; pag
19f0: 65 64 61 74 0a 3b 3b 20 20 20 20 61 6c 74 2d 70 edat.;; alt-p
1a00: 61 67 65 2d 64 61 74 0a 3b 3b 20 20 20 20 70 61 age-dat.;; pa
1a10: 67 65 76 61 72 73 20 20 20 20 20 3b 3b 20 73 65 gevars ;; se
1a20: 73 73 69 6f 6e 20 76 61 72 73 20 73 70 65 63 69 ssion vars speci
1a30: 66 69 63 20 74 6f 20 74 68 69 73 20 70 61 67 65 fic to this page
1a40: 0a 3b 3b 20 20 20 20 70 61 67 65 76 61 72 73 2d .;; pagevars-
1a50: 62 65 66 6f 72 65 0a 3b 3b 20 20 20 20 73 65 73 before.;; ses
1a60: 73 69 6f 6e 76 61 72 73 20 20 3b 3b 20 73 65 73 sionvars ;; ses
1a70: 73 69 6f 6e 20 76 61 72 73 20 76 69 73 69 62 6c sion vars visibl
1a80: 65 20 74 6f 20 61 6c 6c 20 70 61 67 65 73 0a 3b e to all pages.;
1a90: 3b 20 20 20 20 73 65 73 73 69 6f 6e 76 61 72 73 ; sessionvars
1aa0: 2d 62 65 66 6f 72 65 0a 3b 3b 20 20 20 20 67 6c -before.;; gl
1ab0: 6f 62 61 6c 76 61 72 73 20 20 20 3b 3b 20 67 6c obalvars ;; gl
1ac0: 6f 62 61 6c 20 76 61 72 73 20 76 69 73 69 62 6c obal vars visibl
1ad0: 65 20 74 6f 20 61 6c 6c 20 73 65 73 73 69 6f 6e e to all session
1ae0: 73 0a 3b 3b 20 20 20 20 67 6c 6f 62 61 6c 76 61 s.;; globalva
1af0: 72 73 2d 62 65 66 6f 72 65 0a 3b 3b 20 20 20 20 rs-before.;;
1b00: 6c 6f 67 70 74 0a 3b 3b 20 20 20 20 66 6f 72 6d logpt.;; form
1b10: 64 61 74 0a 3b 3b 20 20 20 20 72 65 71 75 65 73 dat.;; reques
1b20: 74 2d 6d 65 74 68 6f 64 0a 3b 3b 20 20 20 20 73 t-method.;; s
1b30: 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 0a 3b 3b ession-cookie.;;
1b40: 20 20 20 20 63 75 72 72 2d 65 72 72 0a 3b 3b 20 curr-err.;;
1b50: 20 20 20 6c 6f 67 2d 70 6f 72 74 0a 3b 3b 20 20 log-port.;;
1b60: 20 20 6c 6f 67 66 69 6c 65 0a 3b 3b 20 20 20 20 logfile.;;
1b70: 73 65 65 6e 2d 70 61 67 65 73 0a 3b 3b 20 20 20 seen-pages.;;
1b80: 20 70 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 20 page-dir-style
1b90: 20 3b 3b 20 23 74 20 3d 20 6e 65 77 20 73 74 79 ;; #t = new sty
1ba0: 6c 65 2c 20 23 66 20 3d 20 6f 6c 64 20 73 74 79 le, #f = old sty
1bb0: 6c 65 0a 3b 3b 20 20 20 20 64 65 62 75 67 6d 6f le.;; debugmo
1bc0: 64 65 29 29 0a 0a 3b 3b 20 53 50 4c 49 54 20 49 de))..;; SPLIT I
1bd0: 4e 54 4f 20 53 54 52 41 49 47 48 54 20 46 4f 52 NTO STRAIGHT FOR
1be0: 57 41 52 44 20 49 4e 49 54 20 41 4e 44 20 43 4f WARD INIT AND CO
1bf0: 4d 50 4c 45 58 20 49 4e 49 54 0a 28 64 65 66 69 MPLEX INIT.(defi
1c00: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 69 6e 69 74 ne (session:init
1c10: 69 61 6c 69 7a 65 20 73 65 6c 66 29 0a 20 20 28 ialize self). (
1c20: 73 64 61 74 2d 73 65 74 2d 64 62 74 79 70 65 21 sdat-set-dbtype!
1c30: 20 73 65 6c 66 20 20 20 20 20 20 27 70 67 29 0a self 'pg).
1c40: 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 (sdat-set-page
1c50: 21 20 73 65 6c 66 20 20 20 20 20 20 20 20 22 68 ! self "h
1c60: 6f 6d 65 22 29 20 20 20 20 20 20 20 20 3b 3b 20 ome") ;;
1c70: 74 68 65 73 65 20 61 72 65 20 64 65 66 61 75 6c these are defaul
1c80: 74 73 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 63 ts. (sdat-set-c
1c90: 75 72 72 2d 70 61 67 65 21 20 73 65 6c 66 20 20 urr-page! self
1ca0: 20 22 68 6f 6d 65 22 29 0a 20 20 28 73 64 61 74 "home"). (sdat
1cb0: 2d 73 65 74 2d 63 6f 6e 74 65 6e 74 2d 74 79 70 -set-content-typ
1cc0: 65 21 20 73 65 6c 66 20 22 43 6f 6e 74 65 6e 74 e! self "Content
1cd0: 2d 74 79 70 65 3a 20 74 65 78 74 2f 68 74 6d 6c -type: text/html
1ce0: 3b 20 63 68 61 72 73 65 74 3d 69 73 6f 2d 38 38 ; charset=iso-88
1cf0: 35 39 2d 31 5c 6e 5c 6e 22 29 0a 20 20 28 73 64 59-1\n\n"). (sd
1d00: 61 74 2d 73 65 74 2d 70 61 67 65 2d 74 79 70 65 at-set-page-type
1d10: 21 20 73 65 6c 66 20 20 20 27 68 74 6d 6c 29 0a ! self 'html).
1d20: 20 20 28 73 64 61 74 2d 73 65 74 2d 74 6f 70 70 (sdat-set-topp
1d30: 61 67 65 21 20 73 65 6c 66 20 20 20 20 20 22 69 age! self "i
1d40: 6e 64 65 78 22 29 0a 20 20 28 73 64 61 74 2d 73 ndex"). (sdat-s
1d50: 65 74 2d 70 61 72 61 6d 73 21 20 73 65 6c 66 20 et-params! self
1d60: 20 20 20 20 20 27 28 29 29 20 20 20 20 20 20 20 '())
1d70: 20 20 20 20 3b 3b 0a 20 20 28 73 64 61 74 2d 73 ;;. (sdat-s
1d80: 65 74 2d 70 61 74 68 2d 70 61 72 61 6d 73 21 20 et-path-params!
1d90: 73 65 6c 66 20 27 28 29 29 0a 20 20 28 73 64 61 self '()). (sda
1da0: 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 t-set-session-ke
1db0: 79 21 20 73 65 6c 66 20 23 66 29 0a 20 20 28 73 y! self #f). (s
1dc0: 64 61 74 2d 73 65 74 2d 70 61 67 65 64 61 74 21 dat-set-pagedat!
1dd0: 20 73 65 6c 66 20 20 20 20 20 27 28 29 29 0a 20 self '()).
1de0: 20 28 73 64 61 74 2d 73 65 74 2d 61 6c 74 2d 70 (sdat-set-alt-p
1df0: 61 67 65 2d 64 61 74 21 20 73 65 6c 66 20 23 66 age-dat! self #f
1e00: 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 73 72 ). (sdat-set-sr
1e10: 6f 6f 74 21 20 73 65 6c 66 20 20 20 20 20 20 20 oot! self
1e20: 22 2e 2f 22 29 0a 20 20 28 73 64 61 74 2d 73 65 "./"). (sdat-se
1e30: 74 2d 73 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 t-session-cookie
1e40: 21 20 73 65 6c 66 20 23 66 29 0a 20 20 28 73 64 ! self #f). (sd
1e50: 61 74 2d 73 65 74 2d 63 75 72 72 2d 65 72 72 21 at-set-curr-err!
1e60: 20 73 65 6c 66 20 23 66 29 0a 20 20 28 73 64 61 self #f). (sda
1e70: 74 2d 73 65 74 2d 6c 6f 67 2d 70 6f 72 74 21 20 t-set-log-port!
1e80: 73 65 6c 66 20 28 63 75 72 72 65 6e 74 2d 65 72 self (current-er
1e90: 72 6f 72 2d 70 6f 72 74 29 29 0a 20 20 28 73 64 ror-port)). (sd
1ea0: 61 74 2d 73 65 74 2d 73 65 65 6e 2d 70 61 67 65 at-set-seen-page
1eb0: 73 21 20 73 65 6c 66 20 27 28 29 29 0a 20 20 28 s! self '()). (
1ec0: 73 64 61 74 2d 73 65 74 2d 70 61 67 65 2d 64 69 sdat-set-page-di
1ed0: 72 2d 73 74 79 6c 65 21 20 73 65 6c 66 20 23 74 r-style! self #t
1ee0: 29 20 3b 3b 20 23 74 20 3a 20 70 61 67 65 73 2f ) ;; #t : pages/
1ef0: 3c 70 61 67 65 6e 61 6d 65 3e 5f 28 76 69 65 77 <pagename>_(view
1f00: 7c 63 6e 74 6c 29 2e 73 63 6d 0a 20 20 20 20 20 |cntl).scm.
1f10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1f20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1f30: 20 3b 3b 20 23 66 20 3a 20 70 61 67 65 73 2f 3c ;; #f : pages/<
1f40: 70 61 67 65 6e 61 6d 65 3e 2f 28 76 69 65 77 7c pagename>/(view|
1f50: 63 6f 6e 74 72 6f 6c 29 2e 73 63 6d 20 0a 20 20 control).scm .
1f60: 28 73 64 61 74 2d 73 65 74 2d 64 65 62 75 67 6d (sdat-set-debugm
1f70: 6f 64 65 21 20 20 20 20 20 20 20 20 20 20 73 65 ode! se
1f80: 6c 66 20 23 66 29 0a 20 20 09 09 09 20 20 20 20 lf #f). ...
1f90: 20 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 . (sdat-set-pa
1fa0: 67 65 76 61 72 73 21 20 20 20 20 20 20 20 20 20 gevars!
1fb0: 20 20 73 65 6c 66 20 28 6d 61 6b 65 2d 68 61 73 self (make-has
1fc0: 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 73 64 61 h-table)). (sda
1fd0: 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 t-set-sessionvar
1fe0: 73 21 20 20 20 20 20 20 20 20 73 65 6c 66 20 28 s! self (
1ff0: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
2000: 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 67 6c ). (sdat-set-gl
2010: 6f 62 61 6c 76 61 72 73 21 20 20 20 20 20 20 20 obalvars!
2020: 20 20 73 65 6c 66 20 28 6d 61 6b 65 2d 68 61 73 self (make-has
2030: 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 73 64 61 h-table)). (sda
2040: 74 2d 73 65 74 2d 70 61 67 65 76 61 72 73 2d 62 t-set-pagevars-b
2050: 65 66 6f 72 65 21 20 20 20 20 73 65 6c 66 20 28 efore! self (
2060: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
2070: 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 ). (sdat-set-se
2080: 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 ssionvars-before
2090: 21 20 73 65 6c 66 20 28 6d 61 6b 65 2d 68 61 73 ! self (make-has
20a0: 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 73 64 61 h-table)). (sda
20b0: 74 2d 73 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 t-set-globalvars
20c0: 2d 62 65 66 6f 72 65 21 20 20 73 65 6c 66 20 28 -before! self (
20d0: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
20e0: 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 64 6f ). (sdat-set-do
20f0: 6d 61 69 6e 21 20 20 20 20 20 20 20 20 20 20 20 main!
2100: 20 20 73 65 6c 66 20 22 6c 6f 63 61 68 6f 73 74 self "locahost
2110: 22 29 20 20 20 3b 3b 20 65 6e 64 20 6f 66 20 64 ") ;; end of d
2120: 65 66 61 75 6c 74 73 0a 20 20 28 6c 65 74 2a 20 efaults. (let*
2130: 28 28 72 61 77 63 6f 6e 66 69 67 64 61 74 20 28 ((rawconfigdat (
2140: 73 65 73 73 69 6f 6e 3a 72 65 61 64 2d 63 6f 6e session:read-con
2150: 66 69 67 20 73 65 6c 66 29 29 0a 09 20 28 63 6f fig self)).. (co
2160: 6e 66 69 67 64 61 74 20 28 69 66 20 72 61 77 63 nfigdat (if rawc
2170: 6f 6e 66 69 67 64 61 74 20 28 65 76 61 6c 20 72 onfigdat (eval r
2180: 61 77 63 6f 6e 66 69 67 64 61 74 29 20 27 28 29 awconfigdat) '()
2190: 29 29 0a 09 20 28 73 72 6f 6f 74 20 20 20 20 20 )).. (sroot
21a0: 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 27 73 (s:find-param 's
21b0: 72 6f 6f 74 20 20 20 20 63 6f 6e 66 69 67 64 61 root configda
21c0: 74 29 29 0a 09 20 28 6c 6f 67 66 69 6c 65 20 20 t)).. (logfile
21d0: 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 27 (s:find-param '
21e0: 6c 6f 67 66 69 6c 65 20 20 63 6f 6e 66 69 67 64 logfile configd
21f0: 61 74 29 29 0a 09 20 28 64 62 74 79 70 65 20 20 at)).. (dbtype
2200: 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 (s:find-param
2210: 27 64 62 74 79 70 65 20 20 20 63 6f 6e 66 69 67 'dbtype config
2220: 64 61 74 29 29 0a 09 20 28 64 62 69 6e 69 74 20 dat)).. (dbinit
2230: 20 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d (s:find-param
2240: 20 27 64 62 69 6e 69 74 20 20 20 63 6f 6e 66 69 'dbinit confi
2250: 67 64 61 74 29 29 0a 09 20 28 64 6f 6d 61 69 6e gdat)).. (domain
2260: 20 20 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 (s:find-para
2270: 6d 20 27 64 6f 6d 61 69 6e 20 20 20 63 6f 6e 66 m 'domain conf
2280: 69 67 64 61 74 29 29 0a 09 20 28 70 61 67 65 2d igdat)).. (page-
2290: 64 69 72 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 dir (s:find-par
22a0: 61 6d 20 27 70 61 67 65 2d 64 69 72 2d 73 74 79 am 'page-dir-sty
22b0: 6c 65 20 63 6f 6e 66 69 67 64 61 74 29 29 29 0a le configdat))).
22c0: 20 20 20 20 28 69 66 20 73 72 6f 6f 74 20 20 20 (if sroot
22d0: 28 73 64 61 74 2d 73 65 74 2d 73 72 6f 6f 74 21 (sdat-set-sroot!
22e0: 20 20 20 73 65 6c 66 20 73 72 6f 6f 74 29 29 0a self sroot)).
22f0: 20 20 20 20 28 69 66 20 6c 6f 67 66 69 6c 65 20 (if logfile
2300: 28 73 64 61 74 2d 73 65 74 2d 6c 6f 67 66 69 6c (sdat-set-logfil
2310: 65 21 20 73 65 6c 66 20 6c 6f 67 66 69 6c 65 29 e! self logfile)
2320: 29 0a 20 20 20 20 28 69 66 20 64 62 74 79 70 65 ). (if dbtype
2330: 20 20 28 73 64 61 74 2d 73 65 74 2d 64 62 74 79 (sdat-set-dbty
2340: 70 65 21 20 20 73 65 6c 66 20 64 62 74 79 70 65 pe! self dbtype
2350: 29 29 0a 20 20 20 20 28 69 66 20 64 62 69 6e 69 )). (if dbini
2360: 74 20 20 28 73 64 61 74 2d 73 65 74 2d 64 62 69 t (sdat-set-dbi
2370: 6e 69 74 21 20 20 73 65 6c 66 20 64 62 69 6e 69 nit! self dbini
2380: 74 29 29 0a 20 20 20 20 28 69 66 20 64 6f 6d 61 t)). (if doma
2390: 69 6e 20 20 28 73 64 61 74 2d 73 65 74 2d 64 6f in (sdat-set-do
23a0: 6d 61 69 6e 21 20 20 73 65 6c 66 20 64 6f 6d 61 main! self doma
23b0: 69 6e 29 29 0a 20 20 20 20 28 73 64 61 74 2d 73 in)). (sdat-s
23c0: 65 74 2d 70 61 67 65 2d 64 69 72 2d 73 74 79 6c et-page-dir-styl
23d0: 65 21 20 73 65 6c 66 20 70 61 67 65 2d 64 69 72 e! self page-dir
23e0: 29 0a 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 ). ;; (print
23f0: 22 63 6f 6e 66 69 67 64 61 74 3a 20 22 29 28 70 "configdat: ")(p
2400: 70 20 63 6f 6e 66 69 67 64 61 74 29 0a 20 20 20 p configdat).
2410: 20 3b 3b 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 ;;(session:log
2420: 73 65 6c 66 20 22 73 72 6f 6f 74 3a 20 22 20 73 self "sroot: " s
2430: 72 6f 6f 74 20 22 20 6c 6f 67 66 69 6c 65 3a 20 root " logfile:
2440: 22 20 6c 6f 67 66 69 6c 65 20 22 20 64 62 74 79 " logfile " dbty
2450: 70 65 3a 20 22 20 64 62 74 79 70 65 20 0a 20 20 pe: " dbtype .
2460: 20 20 3b 3b 09 09 20 22 20 64 62 69 6e 69 74 3a ;;.. " dbinit:
2470: 20 22 20 64 62 69 6e 69 74 20 22 20 64 6f 6d 61 " dbinit " doma
2480: 69 6e 3a 20 22 20 64 6f 6d 61 69 6e 20 22 20 70 in: " domain " p
2490: 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 3a 20 22 age-dir-style: "
24a0: 20 70 61 67 65 2d 64 69 72 29 0a 20 20 20 20 29 page-dir). )
24b0: 0a 20 20 29 0a 3b 3b 20 20 20 28 6c 65 74 20 28 . ).;; (let (
24c0: 28 64 62 74 79 70 65 20 28 73 64 61 74 2d 67 65 (dbtype (sdat-ge
24d0: 74 2d 64 62 74 79 70 65 20 73 65 6c 66 29 29 29 t-dbtype self)))
24e0: 0a 3b 3b 20 20 20 20 20 28 70 72 69 6e 74 20 22 .;; (print "
24f0: 64 62 74 79 70 65 3a 20 22 20 64 62 74 79 70 65 dbtype: " dbtype
2500: 29 0a 3b 3b 20 20 20 20 20 28 73 64 61 74 2d 73 ).;; (sdat-s
2510: 65 74 2d 64 62 74 79 70 65 21 20 73 65 6c 66 20 et-dbtype! self
2520: 28 65 76 61 6c 20 64 62 74 79 70 65 29 29 29 29 (eval dbtype))))
2530: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ..(define (sessi
2540: 6f 6e 3a 73 65 74 75 70 20 73 65 6c 66 29 0a 20 on:setup self).
2550: 20 28 6c 65 74 20 28 28 64 62 74 79 70 65 20 28 (let ((dbtype (
2560: 73 64 61 74 2d 67 65 74 2d 64 62 74 79 70 65 20 sdat-get-dbtype
2570: 73 65 6c 66 29 29 0a 09 28 64 62 69 6e 69 74 20 self))..(dbinit
2580: 28 65 76 61 6c 20 28 73 64 61 74 2d 67 65 74 2d (eval (sdat-get-
2590: 64 62 69 6e 69 74 20 73 65 6c 66 29 29 29 0a 09 dbinit self)))..
25a0: 28 64 62 65 78 69 73 74 73 20 23 66 29 29 0a 20 (dbexists #f)).
25b0: 20 20 20 28 6c 65 74 20 28 28 64 62 66 6e 61 6d (let ((dbfnam
25c0: 65 20 28 61 6c 69 73 74 2d 72 65 66 20 27 64 62 e (alist-ref 'db
25d0: 6e 61 6d 65 20 64 62 69 6e 69 74 29 29 29 0a 20 name dbinit))).
25e0: 20 20 20 20 20 28 69 66 20 28 65 71 3f 20 64 62 (if (eq? db
25f0: 74 79 70 65 20 27 73 71 6c 69 74 65 33 29 0a 09 type 'sqlite3)..
2600: 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 (if (file-exis
2610: 74 73 3f 20 64 62 66 6e 61 6d 65 29 0a 09 20 20 ts? dbfname)..
2620: 20 20 20 20 28 62 65 67 69 6e 0a 09 09 3b 3b 20 (begin...;;
2630: 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c (session:log sel
2640: 66 20 22 73 65 74 74 69 6e 67 20 64 62 65 78 69 f "setting dbexi
2650: 73 74 73 20 74 6f 20 23 74 22 29 0a 09 09 28 73 sts to #t")...(s
2660: 65 74 21 20 64 62 65 78 69 73 74 73 20 23 74 29 et! dbexists #t)
2670: 29 29 29 0a 20 20 20 20 20 20 3b 3b 20 28 73 65 ))). ;; (se
2680: 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 ssion:log self "
2690: 64 62 74 79 70 65 3a 20 22 20 64 62 74 79 70 65 dbtype: " dbtype
26a0: 20 22 20 64 62 66 6e 61 6d 65 3a 20 22 20 64 62 " dbfname: " db
26b0: 66 6e 61 6d 65 20 22 20 64 62 65 78 69 73 74 73 fname " dbexists
26c0: 3a 20 22 20 64 62 65 78 69 73 74 73 29 29 0a 20 : " dbexists)).
26d0: 20 20 20 20 20 29 0a 20 20 20 20 28 73 64 61 74 ). (sdat
26e0: 2d 73 65 74 2d 63 6f 6e 6e 21 20 73 65 6c 66 20 -set-conn! self
26f0: 28 64 62 69 3a 6f 70 65 6e 20 64 62 74 79 70 65 (dbi:open dbtype
2700: 20 64 62 69 6e 69 74 29 29 0a 20 20 20 20 28 69 dbinit)). (i
2710: 66 20 28 61 6e 64 20 28 6e 6f 74 20 64 62 65 78 f (and (not dbex
2720: 69 73 74 73 29 28 65 71 3f 20 64 62 74 79 70 65 ists)(eq? dbtype
2730: 20 27 73 71 6c 69 74 65 33 29 29 0a 20 09 28 62 'sqlite3)). .(b
2740: 65 67 69 6e 0a 09 20 20 28 70 72 69 6e 74 20 22 egin.. (print "
2750: 57 41 52 4e 49 4e 47 3a 20 53 65 74 74 69 6e 67 WARNING: Setting
2760: 20 75 70 20 73 65 73 73 69 6f 6e 20 64 62 20 77 up session db w
2770: 69 74 68 20 73 71 6c 69 74 65 33 22 29 0a 09 20 ith sqlite3")..
2780: 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 2d (session:setup-
2790: 64 62 20 73 65 6c 66 29 29 29 0a 20 20 20 20 28 db self))). (
27a0: 73 65 73 73 69 6f 6e 3a 70 72 6f 63 65 73 73 2d session:process-
27b0: 75 72 6c 2d 70 61 74 68 20 73 65 6c 66 29 0a 20 url-path self).
27c0: 20 20 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 75 (session:setu
27d0: 70 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 p-session-key se
27e0: 6c 66 29 0a 20 20 20 20 3b 3b 20 63 61 70 74 75 lf). ;; captu
27f0: 72 65 20 73 74 64 69 6e 20 69 66 20 74 68 69 73 re stdin if this
2800: 20 69 73 20 61 20 50 4f 53 54 0a 20 20 20 20 28 is a POST. (
2810: 73 64 61 74 2d 73 65 74 2d 72 65 71 75 65 73 74 sdat-set-request
2820: 2d 6d 65 74 68 6f 64 21 20 73 65 6c 66 20 28 67 -method! self (g
2830: 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 et-environment-v
2840: 61 72 69 61 62 6c 65 20 22 52 45 51 55 45 53 54 ariable "REQUEST
2850: 5f 4d 45 54 48 4f 44 22 29 29 0a 20 20 20 20 28 _METHOD")). (
2860: 73 64 61 74 2d 73 65 74 2d 66 6f 72 6d 64 61 74 sdat-set-formdat
2870: 21 20 73 65 6c 66 20 28 66 6f 72 6d 64 61 74 3a ! self (formdat:
2880: 6c 6f 61 64 2d 61 6c 6c 29 29 29 29 0a 0a 3b 3b load-all))))..;;
2890: 20 73 65 74 75 70 20 74 68 65 20 64 62 20 77 69 setup the db wi
28a0: 74 68 20 73 65 73 73 69 6f 6e 20 74 61 62 6c 65 th session table
28b0: 73 2c 20 77 6f 72 6b 73 20 66 6f 72 20 73 71 6c s, works for sql
28c0: 69 74 65 20 6f 6e 6c 79 20 72 69 67 68 74 20 6e ite only right n
28d0: 6f 77 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 ow.(define (sess
28e0: 69 6f 6e 3a 73 65 74 75 70 2d 64 62 20 73 65 6c ion:setup-db sel
28f0: 66 29 0a 20 20 28 6c 65 74 20 28 28 63 6f 6e 6e f). (let ((conn
2900: 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 (sdat-get-conn
2910: 73 65 6c 66 29 29 29 0a 20 20 20 20 28 66 6f 72 self))). (for
2920: 2d 65 61 63 68 20 0a 20 20 20 20 20 28 6c 61 6d -each . (lam
2930: 62 64 61 20 28 73 74 6d 74 29 0a 20 20 20 20 20 bda (stmt).
2940: 20 20 28 64 62 69 3a 65 78 65 63 20 63 6f 6e 6e (dbi:exec conn
2950: 20 73 74 6d 74 29 29 0a 20 20 20 20 20 28 6c 69 stmt)). (li
2960: 73 74 20 22 43 52 45 41 54 45 20 54 41 42 4c 45 st "CREATE TABLE
2970: 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 28 69 session_vars (i
2980: 64 20 49 4e 54 45 47 45 52 20 50 52 49 4d 41 52 d INTEGER PRIMAR
2990: 59 20 4b 45 59 2c 73 65 73 73 69 6f 6e 5f 69 64 Y KEY,session_id
29a0: 20 49 4e 54 45 47 45 52 2c 70 61 67 65 20 54 45 INTEGER,page TE
29b0: 58 54 2c 6b 65 79 20 54 45 58 54 2c 76 61 6c 75 XT,key TEXT,valu
29c0: 65 20 54 45 58 54 29 3b 22 0a 09 20 20 20 22 43 e TEXT);".. "C
29d0: 52 45 41 54 45 20 54 41 42 4c 45 20 73 65 73 73 REATE TABLE sess
29e0: 69 6f 6e 73 20 28 69 64 20 49 4e 54 45 47 45 52 ions (id INTEGER
29f0: 20 50 52 49 4d 41 52 59 20 4b 45 59 2c 73 65 73 PRIMARY KEY,ses
2a00: 73 69 6f 6e 5f 6b 65 79 20 54 45 58 54 2c 6c 61 sion_key TEXT,la
2a10: 73 74 5f 75 73 65 64 20 54 49 4d 45 53 54 41 4d st_used TIMESTAM
2a20: 50 29 3b 22 0a 20 20 20 20 20 20 20 20 20 20 20 P);".
2a30: 22 43 52 45 41 54 45 20 54 41 42 4c 45 20 6d 65 "CREATE TABLE me
2a40: 74 61 64 61 74 61 20 28 69 64 20 49 4e 54 45 47 tadata (id INTEG
2a50: 45 52 20 50 52 49 4d 41 52 59 20 4b 45 59 2c 6b ER PRIMARY KEY,k
2a60: 65 79 20 54 45 58 54 2c 76 61 6c 75 65 20 54 45 ey TEXT,value TE
2a70: 58 54 29 3b 22 29 29 29 29 0a 3b 3b 20 20 3b 3b XT);")))).;; ;;
2a80: 20 69 66 20 77 65 20 68 61 76 65 20 61 20 73 65 if we have a se
2a90: 73 73 69 6f 6e 5f 6b 65 79 20 6c 6f 6f 6b 20 75 ssion_key look u
2aa0: 70 20 74 68 65 20 73 65 73 73 69 6f 6e 2d 69 64 p the session-id
2ab0: 20 61 6e 64 20 73 74 6f 72 65 20 69 74 0a 3b 3b and store it.;;
2ac0: 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 (sdat-set-sess
2ad0: 69 6f 6e 2d 69 64 21 20 73 65 6c 66 20 28 73 65 ion-id! self (se
2ae0: 73 73 69 6f 6e 3a 67 65 74 2d 69 64 20 73 65 6c ssion:get-id sel
2af0: 66 29 29 29 0a 0a 3b 3b 20 6f 6e 6c 79 20 73 65 f)))..;; only se
2b00: 74 20 73 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 t session-cookie
2b10: 20 77 68 65 6e 20 61 20 6e 65 77 20 73 65 73 73 when a new sess
2b20: 69 6f 6e 20 69 73 20 63 72 65 61 74 65 64 0a 28 ion is created.(
2b30: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
2b40: 73 65 74 75 70 2d 73 65 73 73 69 6f 6e 2d 6b 65 setup-session-ke
2b50: 79 20 73 65 6c 66 29 20 20 0a 20 20 28 6c 65 74 y self) . (let
2b60: 2a 20 28 28 73 6b 20 20 28 73 65 73 73 69 6f 6e * ((sk (session
2b70: 3a 65 78 74 72 61 63 74 2d 73 65 73 73 69 6f 6e :extract-session
2b80: 2d 6b 65 79 20 73 65 6c 66 29 29 0a 20 20 20 20 -key self)).
2b90: 20 20 20 20 20 28 73 69 64 20 28 69 66 20 73 6b (sid (if sk
2ba0: 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 69 64 (session:get-id
2bb0: 20 73 65 6c 66 20 73 6b 29 20 23 66 29 29 29 0a self sk) #f))).
2bc0: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 73 69 64 (if (not sid
2bd0: 29 20 3b 3b 20 6e 65 65 64 20 61 20 6e 65 77 20 ) ;; need a new
2be0: 6b 65 79 0a 20 20 20 20 20 20 20 20 28 6c 65 74 key. (let
2bf0: 2a 20 28 28 6e 65 77 2d 6b 65 79 20 28 73 65 73 * ((new-key (ses
2c00: 73 69 6f 6e 3a 67 65 74 2d 6e 65 77 2d 6b 65 79 sion:get-new-key
2c10: 20 73 65 6c 66 29 29 0a 20 20 20 20 20 20 20 20 self)).
2c20: 20 20 20 20 20 20 20 28 6e 65 77 2d 73 69 64 20 (new-sid
2c30: 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 69 64 20 (session:get-id
2c40: 73 65 6c 66 20 6e 65 77 2d 6b 65 79 29 29 29 0a self new-key))).
2c50: 20 20 20 20 20 20 20 20 20 20 28 73 64 61 74 2d (sdat-
2c60: 73 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 21 set-session-key!
2c70: 20 73 65 6c 66 20 6e 65 77 2d 6b 65 79 29 0a 20 self new-key).
2c80: 20 20 20 20 20 20 20 20 20 28 73 64 61 74 2d 73 (sdat-s
2c90: 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 21 20 73 et-session-id! s
2ca0: 65 6c 66 20 6e 65 77 2d 73 69 64 29 0a 20 20 20 elf new-sid).
2cb0: 20 20 20 20 20 20 20 28 73 64 61 74 2d 73 65 74 (sdat-set
2cc0: 2d 73 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 21 -session-cookie!
2cd0: 20 73 65 6c 66 20 28 73 65 73 73 69 6f 6e 3a 6d self (session:m
2ce0: 61 6b 65 2d 63 6f 6f 6b 69 65 20 73 65 6c 66 29 ake-cookie self)
2cf0: 29 29 0a 20 20 20 20 20 20 20 20 28 73 64 61 74 )). (sdat
2d00: 2d 73 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 21 -set-session-id!
2d10: 20 73 65 6c 66 20 73 69 64 29 29 29 29 0a 0a 28 self sid))))..(
2d20: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
2d30: 6d 61 6b 65 2d 63 6f 6f 6b 69 65 20 73 65 6c 66 make-cookie self
2d40: 29 0a 20 20 3b 3b 20 28 6c 69 73 74 20 28 63 6f ). ;; (list (co
2d50: 6e 63 20 22 73 65 73 73 69 6f 6e 5f 6b 65 79 3d nc "session_key=
2d60: 22 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 " (sdat-get-sess
2d70: 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 20 22 3b ion-key self) ";
2d80: 20 50 61 74 68 3d 2f 3b 20 44 6f 6d 61 69 6e 3d Path=/; Domain=
2d90: 2e 22 20 28 73 64 61 74 2d 67 65 74 2d 64 6f 6d ." (sdat-get-dom
2da0: 61 69 6e 20 73 65 6c 66 29 20 22 3b 20 4d 61 78 ain self) "; Max
2db0: 2d 41 67 65 3d 22 20 28 2a 20 38 36 34 30 30 20 -Age=" (* 86400
2dc0: 31 34 29 20 22 3b 20 56 65 72 73 69 6f 6e 3d 31 14) "; Version=1
2dd0: 22 29 29 29 20 0a 20 20 28 6c 69 73 74 20 28 73 "))) . (list (s
2de0: 74 72 69 6e 67 2d 73 75 62 73 74 69 74 75 74 65 tring-substitute
2df0: 20 0a 09 20 22 3b 22 20 22 3b 20 22 20 0a 09 20 .. ";" "; " ..
2e00: 28 63 61 72 20 28 63 6f 6e 73 74 72 75 63 74 2d (car (construct-
2e10: 63 6f 6f 6b 69 65 2d 73 74 72 69 6e 67 20 0a 09 cookie-string ..
2e20: 20 20 20 20 20 20 20 3b 3b 20 77 61 72 6e 69 6e ;; warnin
2e30: 67 21 20 6d 65 73 73 69 6e 67 20 75 70 20 74 68 g! messing up th
2e40: 69 73 20 69 74 74 79 20 62 69 74 74 79 20 62 69 is itty bitty bi
2e50: 74 20 6f 66 20 63 6f 64 65 20 77 69 6c 6c 20 63 t of code will c
2e60: 6f 73 74 20 6d 75 63 68 20 74 69 6d 65 21 0a 09 ost much time!..
2e70: 20 20 20 20 20 20 20 60 28 28 22 73 65 73 73 69 `(("sessi
2e80: 6f 6e 5f 6b 65 79 22 20 2c 28 73 64 61 74 2d 67 on_key" ,(sdat-g
2e90: 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 et-session-key s
2ea0: 65 6c 66 29 0a 09 09 20 20 65 78 70 69 72 65 73 elf)... expires
2eb0: 3a 20 2c 28 2b 20 28 63 75 72 72 65 6e 74 2d 73 : ,(+ (current-s
2ec0: 65 63 6f 6e 64 73 29 20 28 2a 20 31 34 20 38 36 econds) (* 14 86
2ed0: 34 30 30 29 29 20 0a 09 09 20 20 6d 61 78 2d 61 400)) ... max-a
2ee0: 67 65 3a 20 28 2a 20 31 34 20 38 36 34 30 30 29 ge: (* 14 86400)
2ef0: 0a 09 09 20 20 70 61 74 68 3a 20 22 2f 22 20 3b ... path: "/" ;
2f00: 3b 20 0a 09 09 20 20 64 6f 6d 61 69 6e 3a 20 2c ; ... domain: ,
2f10: 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 22 (string-append "
2f20: 2e 22 20 28 73 64 61 74 2d 67 65 74 2d 64 6f 6d ." (sdat-get-dom
2f30: 61 69 6e 20 73 65 6c 66 29 29 0a 09 09 20 20 76 ain self))... v
2f40: 65 72 73 69 6f 6e 3a 20 31 29 29 20 30 29 29 29 ersion: 1)) 0)))
2f50: 29 29 0a 0a 3b 3b 20 6c 6f 6f 6b 20 75 70 20 61 ))..;; look up a
2f60: 20 67 69 76 65 6e 20 73 65 73 73 69 6f 6e 20 6b given session k
2f70: 65 79 20 61 6e 64 20 72 65 74 75 72 6e 20 74 68 ey and return th
2f80: 65 20 69 64 20 69 66 20 66 6f 75 6e 64 2c 20 23 e id if found, #
2f90: 66 20 69 66 20 6e 6f 74 20 66 6f 75 6e 64 0a 28 f if not found.(
2fa0: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
2fb0: 67 65 74 2d 69 64 20 73 65 6c 66 20 73 65 73 73 get-id self sess
2fc0: 69 6f 6e 2d 6b 65 79 29 0a 20 20 3b 3b 20 28 6c ion-key). ;; (l
2fd0: 65 74 20 28 28 73 65 73 73 69 6f 6e 2d 6b 65 79 et ((session-key
2fe0: 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 (sdat-get-sessi
2ff0: 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 29 29 0a 20 on-key self))).
3000: 20 28 69 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 (if session-key
3010: 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 71 75 . (let ((qu
3020: 65 72 79 20 28 73 74 72 69 6e 67 2d 61 70 70 65 ery (string-appe
3030: 6e 64 20 22 53 45 4c 45 43 54 20 69 64 20 46 52 nd "SELECT id FR
3040: 4f 4d 20 73 65 73 73 69 6f 6e 73 20 57 48 45 52 OM sessions WHER
3050: 45 20 73 65 73 73 69 6f 6e 5f 6b 65 79 3d 27 22 E session_key='"
3060: 20 73 65 73 73 69 6f 6e 2d 6b 65 79 20 22 27 22 session-key "'"
3070: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 )). (
3080: 63 6f 6e 6e 20 28 73 64 61 74 2d 67 65 74 2d 63 conn (sdat-get-c
3090: 6f 6e 6e 20 73 65 6c 66 29 29 0a 20 20 20 20 20 onn self)).
30a0: 20 20 20 20 20 20 20 28 72 65 73 75 6c 74 20 23 (result #
30b0: 66 29 29 0a 09 28 64 62 69 3a 66 6f 72 2d 65 61 f))..(dbi:for-ea
30c0: 63 68 2d 72 6f 77 20 0a 09 20 28 6c 61 6d 62 64 ch-row .. (lambd
30d0: 61 20 28 74 75 70 6c 65 29 0a 09 20 20 20 28 73 a (tuple).. (s
30e0: 65 74 21 20 72 65 73 75 6c 74 20 28 76 65 63 74 et! result (vect
30f0: 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 30 29 29 or-ref tuple 0))
3100: 29 0a 09 20 63 6f 6e 6e 20 71 75 65 72 79 29 0a ).. conn query).
3110: 09 28 69 66 20 72 65 73 75 6c 74 20 28 64 62 69 .(if result (dbi
3120: 3a 65 78 65 63 20 63 6f 6e 6e 20 28 63 6f 6e 63 :exec conn (conc
3130: 20 22 55 50 44 41 54 45 20 73 65 73 73 69 6f 6e "UPDATE session
3140: 73 20 53 45 54 20 6c 61 73 74 5f 75 73 65 64 3d s SET last_used=
3150: 22 20 28 64 62 69 3a 6e 6f 77 20 63 6f 6e 6e 29 " (dbi:now conn)
3160: 20 22 20 57 48 45 52 45 20 73 65 73 73 69 6f 6e " WHERE session
3170: 5f 6b 65 79 3d 3f 3b 22 29 20 73 65 73 73 69 6f _key=?;") sessio
3180: 6e 2d 6b 65 79 29 29 0a 20 20 20 20 20 20 20 20 n-key)).
3190: 72 65 73 75 6c 74 29 0a 20 20 20 20 20 20 23 66 result). #f
31a0: 29 29 0a 0a 3b 3b 20 0a 28 64 65 66 69 6e 65 20 ))..;; .(define
31b0: 28 73 65 73 73 69 6f 6e 3a 70 72 6f 63 65 73 73 (session:process
31c0: 2d 75 72 6c 2d 70 61 74 68 20 73 65 6c 66 29 0a -url-path self).
31d0: 20 20 28 6c 65 74 20 28 28 70 61 74 68 2d 69 6e (let ((path-in
31e0: 66 6f 20 20 20 20 28 67 65 74 2d 65 6e 76 69 72 fo (get-envir
31f0: 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 onment-variable
3200: 22 50 41 54 48 5f 49 4e 46 4f 22 29 29 0a 09 28 "PATH_INFO"))..(
3210: 71 75 65 72 79 2d 73 74 72 69 6e 67 20 28 67 65 query-string (ge
3220: 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 t-environment-va
3230: 72 69 61 62 6c 65 20 22 51 55 45 52 59 5f 53 54 riable "QUERY_ST
3240: 52 49 4e 47 22 29 29 29 0a 20 20 20 20 3b 3b 20 RING"))). ;;
3250: 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c (session:log sel
3260: 66 20 22 70 61 74 68 2d 69 6e 66 6f 3d 22 20 70 f "path-info=" p
3270: 61 74 68 2d 69 6e 66 6f 20 22 20 71 75 65 72 79 ath-info " query
3280: 2d 73 74 72 69 6e 67 3d 22 20 71 75 65 72 79 2d -string=" query-
3290: 73 74 72 69 6e 67 29 0a 20 20 20 20 28 69 66 20 string). (if
32a0: 70 61 74 68 2d 69 6e 66 6f 0a 09 28 6c 65 74 2a path-info..(let*
32b0: 20 28 28 70 61 72 74 73 20 20 20 20 28 73 74 72 ((parts (str
32c0: 69 6e 67 2d 73 70 6c 69 74 20 70 61 74 68 2d 69 ing-split path-i
32d0: 6e 66 6f 20 22 2f 22 29 29 0a 09 20 20 20 20 20 nfo "/"))..
32e0: 20 20 28 6e 75 6d 70 61 72 74 73 20 28 6c 65 6e (numparts (len
32f0: 67 74 68 20 70 61 72 74 73 29 29 29 0a 09 20 20 gth parts)))..
3300: 28 69 66 20 28 3e 20 6e 75 6d 70 61 72 74 73 20 (if (> numparts
3310: 30 29 0a 09 20 20 20 20 20 20 28 73 64 61 74 2d 0).. (sdat-
3320: 73 65 74 2d 70 61 67 65 21 20 73 65 6c 66 20 28 set-page! self (
3330: 63 61 72 20 70 61 72 74 73 29 29 29 0a 09 20 20 car parts)))..
3340: 3b 3b 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 ;; (session:log
3350: 73 65 6c 66 20 22 75 72 6c 2d 70 61 74 68 3d 22 self "url-path="
3360: 20 75 72 6c 2d 70 61 74 68 20 22 20 70 61 72 74 url-path " part
3370: 73 3d 22 20 70 61 72 74 73 29 0a 09 20 20 28 69 s=" parts).. (i
3380: 66 20 28 3e 20 6e 75 6d 70 61 72 74 73 20 31 29 f (> numparts 1)
3390: 0a 09 20 20 20 20 20 20 28 73 64 61 74 2d 73 65 .. (sdat-se
33a0: 74 2d 70 61 74 68 2d 70 61 72 61 6d 73 21 20 73 t-path-params! s
33b0: 65 6c 66 20 28 63 64 72 20 70 61 72 74 73 29 29 elf (cdr parts))
33c0: 29 0a 20 20 20 20 20 20 20 20 20 20 28 69 66 20 ). (if
33d0: 71 75 65 72 79 2d 73 74 72 69 6e 67 0a 20 20 20 query-string.
33e0: 20 20 20 20 20 20 20 20 20 20 20 28 73 64 61 74 (sdat
33f0: 2d 73 65 74 2d 70 61 72 61 6d 73 21 20 73 65 6c -set-params! sel
3400: 66 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 f (string-split
3410: 71 75 65 72 79 2d 73 74 72 69 6e 67 20 22 26 22 query-string "&"
3420: 29 29 29 29 29 29 29 0a 0a 3b 3b 20 42 55 47 47 )))))))..;; BUGG
3430: 59 21 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 Y!.(define (sess
3440: 69 6f 6e 3a 67 65 74 2d 6e 65 77 2d 6b 65 79 20 ion:get-new-key
3450: 73 65 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 63 self). (let ((c
3460: 6f 6e 6e 20 20 20 28 73 64 61 74 2d 67 65 74 2d onn (sdat-get-
3470: 63 6f 6e 6e 20 73 65 6c 66 29 29 0a 20 20 20 20 conn self)).
3480: 20 20 20 20 28 74 6d 70 6b 65 79 20 28 73 65 73 (tmpkey (ses
3490: 73 69 6f 6e 3a 6d 61 6b 65 2d 72 61 6e 64 2d 73 sion:make-rand-s
34a0: 74 72 69 6e 67 20 32 30 29 29 0a 20 20 20 20 20 tring 20)).
34b0: 20 20 20 28 73 74 61 74 75 73 20 23 66 29 29 0a (status #f)).
34c0: 20 20 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 (dbi:for-eac
34d0: 68 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 h-row (lambda (t
34e0: 75 70 6c 65 29 0a 09 09 09 28 73 65 74 21 20 73 uple)....(set! s
34f0: 74 61 74 75 73 20 23 74 29 29 0a 09 09 20 20 20 tatus #t))...
3500: 20 20 20 63 6f 6e 6e 20 28 73 74 72 69 6e 67 2d conn (string-
3510: 61 70 70 65 6e 64 20 22 49 4e 53 45 52 54 20 49 append "INSERT I
3520: 4e 54 4f 20 73 65 73 73 69 6f 6e 73 20 28 73 65 NTO sessions (se
3530: 73 73 69 6f 6e 5f 6b 65 79 29 20 56 41 4c 55 45 ssion_key) VALUE
3540: 53 20 28 27 22 20 74 6d 70 6b 65 79 20 22 27 29 S ('" tmpkey "')
3550: 22 29 29 0a 20 20 20 20 74 6d 70 6b 65 79 29 29 ")). tmpkey))
3560: 0a 0a 3b 3b 20 72 65 74 75 72 6e 73 20 73 65 73 ..;; returns ses
3570: 73 69 6f 6e 20 6b 65 79 20 49 46 46 20 69 74 20 sion key IFF it
3580: 69 73 20 69 6e 20 74 68 65 20 48 54 54 50 5f 43 is in the HTTP_C
3590: 4f 4f 4b 49 45 20 0a 28 64 65 66 69 6e 65 20 28 OOKIE .(define (
35a0: 73 65 73 73 69 6f 6e 3a 65 78 74 72 61 63 74 2d session:extract-
35b0: 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 session-key self
35c0: 29 0a 20 20 28 6c 65 74 20 28 28 68 74 74 70 2d ). (let ((http-
35d0: 73 65 73 73 69 6f 6e 20 28 67 65 74 2d 65 6e 76 session (get-env
35e0: 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c ironment-variabl
35f0: 65 20 22 48 54 54 50 5f 43 4f 4f 4b 49 45 22 29 e "HTTP_COOKIE")
3600: 29 29 0a 20 20 20 20 28 69 66 20 68 74 74 70 2d )). (if http-
3610: 73 65 73 73 69 6f 6e 20 0a 20 20 20 20 20 20 20 session .
3620: 20 28 73 65 73 73 69 6f 6e 3a 65 78 74 72 61 63 (session:extrac
3630: 74 2d 6b 65 79 2d 66 72 6f 6d 2d 70 61 72 61 6d t-key-from-param
3640: 20 73 65 6c 66 20 28 6c 69 73 74 20 68 74 74 70 self (list http
3650: 2d 73 65 73 73 69 6f 6e 29 20 22 73 65 73 73 69 -session) "sessi
3660: 6f 6e 5f 6b 65 79 22 29 0a 20 20 20 20 20 20 20 on_key").
3670: 20 23 66 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 #f)))..(define
3680: 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 73 65 73 (session:get-ses
3690: 73 69 6f 6e 2d 69 64 20 73 65 6c 66 20 73 65 73 sion-id self ses
36a0: 73 69 6f 6e 2d 6b 65 79 29 0a 20 20 28 6c 65 74 sion-key). (let
36b0: 20 28 28 71 75 65 72 79 20 22 53 45 4c 45 43 54 ((query "SELECT
36c0: 20 69 64 20 46 52 4f 4d 20 73 65 73 73 69 6f 6e id FROM session
36d0: 73 20 57 48 45 52 45 20 73 65 73 73 69 6f 6e 5f s WHERE session_
36e0: 6b 65 79 3d 3f 3b 22 29 0a 20 20 20 20 20 20 20 key=?;").
36f0: 20 28 72 65 73 75 6c 74 20 23 66 29 29 0a 20 20 (result #f)).
3700: 20 20 3b 3b 20 20 20 20 20 28 70 67 3a 71 75 65 ;; (pg:que
3710: 72 79 2d 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d ry-for-each (lam
3720: 62 64 61 20 28 74 75 70 6c 65 29 0a 20 20 20 20 bda (tuple).
3730: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
3740: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 65 74 (set
3750: 21 20 72 65 73 75 6c 74 20 28 76 65 63 74 6f 72 ! result (vector
3760: 2d 72 65 66 20 74 75 70 6c 65 20 30 29 29 29 20 -ref tuple 0)))
3770: 3b 3b 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 ;; (vector-ref t
3780: 75 70 6c 65 20 30 29 29 29 0a 20 20 20 20 3b 3b uple 0))). ;;
3790: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
37a0: 20 20 20 20 20 20 20 20 28 73 3a 73 71 6c 70 61 (s:sqlpa
37b0: 72 61 6d 20 71 75 65 72 79 20 73 65 73 73 69 6f ram query sessio
37c0: 6e 2d 6b 65 79 29 0a 20 20 20 20 3b 3b 20 20 20 n-key). ;;
37d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
37e0: 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d 63 (sdat-get-c
37f0: 6f 6e 6e 20 73 65 6c 66 29 29 0a 20 20 20 20 3b onn self)). ;
3800: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
3810: 20 20 20 20 20 20 20 20 20 63 6f 6e 6e 29 0a 20 conn).
3820: 20 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 (dbi:for-each
3830: 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 75 -row (lambda (tu
3840: 70 6c 65 29 0a 09 09 09 28 73 65 74 21 20 72 65 ple)....(set! re
3850: 73 75 6c 74 20 28 76 65 63 74 6f 72 2d 72 65 66 sult (vector-ref
3860: 20 74 75 70 6c 65 20 30 29 29 29 20 3b 3b 20 28 tuple 0))) ;; (
3870: 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 vector-ref tuple
3880: 20 30 29 29 29 0a 09 09 20 20 20 20 20 20 28 73 0)))... (s
3890: 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c dat-get-conn sel
38a0: 66 29 0a 09 09 20 20 20 20 20 20 28 73 3a 73 71 f)... (s:sq
38b0: 6c 70 61 72 61 6d 20 71 75 65 72 79 20 73 65 73 lparam query ses
38c0: 73 69 6f 6e 2d 6b 65 79 29 29 0a 20 20 20 20 72 sion-key)). r
38d0: 65 73 75 6c 74 29 29 0a 0a 3b 3b 20 64 65 6c 65 esult))..;; dele
38e0: 74 65 20 61 6c 6c 20 72 65 63 6f 72 64 73 20 66 te all records f
38f0: 6f 72 20 61 20 73 65 73 73 69 6f 6e 0a 3b 3b 0a or a session.;;.
3900: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
3910: 3a 64 65 6c 65 74 65 2d 73 65 73 73 69 6f 6e 20 :delete-session
3920: 73 65 6c 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 self session-key
3930: 29 0a 20 20 28 6c 65 74 20 28 28 73 65 73 73 69 ). (let ((sessi
3940: 6f 6e 2d 69 64 20 28 73 65 73 73 69 6f 6e 3a 67 on-id (session:g
3950: 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 et-session-id se
3960: 6c 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 lf session-key))
3970: 0a 20 20 20 20 20 20 20 20 28 71 72 79 20 20 20 . (qry
3980: 20 20 20 20 20 28 63 6f 6e 63 20 22 42 45 47 49 (conc "BEGI
3990: 4e 3b 22 0a 09 09 09 20 20 22 44 45 4c 45 54 45 N;".... "DELETE
39a0: 20 46 52 4f 4d 20 73 65 73 73 69 6f 6e 5f 76 61 FROM session_va
39b0: 72 73 20 57 48 45 52 45 20 73 65 73 73 69 6f 6e rs WHERE session
39c0: 5f 69 64 3d 3f 3b 22 0a 20 20 20 20 20 20 20 20 _id=?;".
39d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
39e0: 20 20 22 44 45 4c 45 54 45 20 46 52 4f 4d 20 73 "DELETE FROM s
39f0: 65 73 73 69 6f 6e 73 20 57 48 45 52 45 20 69 64 essions WHERE id
3a00: 3d 3f 3b 22 0a 09 09 09 20 20 22 43 4f 4d 4d 49 =?;".... "COMMI
3a10: 54 3b 22 29 29 0a 20 20 20 20 20 20 20 20 28 63 T;")). (c
3a20: 6f 6e 6e 20 20 20 20 20 20 20 20 20 20 20 20 20 onn
3a30: 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 (sdat-get-conn
3a40: 73 65 6c 66 29 29 29 0a 20 20 20 20 28 69 66 20 self))). (if
3a50: 73 65 73 73 69 6f 6e 2d 69 64 0a 20 20 20 20 20 session-id.
3a60: 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 (begin.
3a70: 20 20 20 20 28 64 62 69 3a 65 78 65 63 20 63 6f (dbi:exec co
3a80: 6e 6e 20 71 72 79 20 73 65 73 73 69 6f 6e 2d 69 nn qry session-i
3a90: 64 20 73 65 73 73 69 6f 6e 2d 69 64 29 0a 09 20 d session-id)..
3aa0: 20 28 73 65 73 73 69 6f 6e 3a 69 6e 69 74 69 61 (session:initia
3ab0: 6c 69 7a 65 20 73 65 6c 66 29 0a 09 20 20 28 73 lize self).. (s
3ac0: 65 73 73 69 6f 6e 3a 73 65 74 75 70 20 73 65 6c ession:setup sel
3ad0: 66 29 29 29 0a 20 20 20 20 28 6e 6f 74 20 28 73 f))). (not (s
3ae0: 65 73 73 69 6f 6e 3a 67 65 74 2d 73 65 73 73 69 ession:get-sessi
3af0: 6f 6e 2d 69 64 20 73 65 6c 66 20 73 65 73 73 69 on-id self sessi
3b00: 6f 6e 2d 6b 65 79 29 29 29 29 0a 0a 3b 3b 20 28 on-key))))..;; (
3b10: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
3b20: 64 65 6c 65 74 65 2d 73 65 73 73 69 6f 6e 20 73 delete-session s
3b30: 65 6c 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 elf session-key)
3b40: 0a 3b 3b 20 20 20 28 6c 65 74 20 28 28 73 65 73 .;; (let ((ses
3b50: 73 69 6f 6e 2d 69 64 20 28 73 65 73 73 69 6f 6e sion-id (session
3b60: 3a 67 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 :get-session-id
3b70: 73 65 6c 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 self session-key
3b80: 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 28 71 )).;; (q
3b90: 75 65 72 69 65 73 20 20 20 20 28 6c 69 73 74 20 ueries (list
3ba0: 22 42 45 47 49 4e 3b 22 0a 3b 3b 20 09 09 09 20 "BEGIN;".;; ...
3bb0: 20 22 44 45 4c 45 54 45 20 46 52 4f 4d 20 73 65 "DELETE FROM se
3bc0: 73 73 69 6f 6e 5f 76 61 72 73 20 57 48 45 52 45 ssion_vars WHERE
3bd0: 20 73 65 73 73 69 6f 6e 5f 69 64 3d 3f 3b 22 0a session_id=?;".
3be0: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
3bf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 22 44 45 "DE
3c00: 4c 45 54 45 20 46 52 4f 4d 20 73 65 73 73 69 6f LETE FROM sessio
3c10: 6e 73 20 57 48 45 52 45 20 69 64 3d 3f 3b 22 0a ns WHERE id=?;".
3c20: 3b 3b 20 09 09 09 20 20 22 43 4f 4d 4d 49 54 3b ;; ... "COMMIT;
3c30: 22 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 28 ")).;; (
3c40: 63 6f 6e 6e 20 20 20 20 20 20 20 20 20 20 20 20 conn
3c50: 20 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e (sdat-get-conn
3c60: 20 73 65 6c 66 29 29 29 0a 3b 3b 20 20 20 20 20 self))).;;
3c70: 28 69 66 20 73 65 73 73 69 6f 6e 2d 69 64 0a 3b (if session-id.;
3c80: 3b 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e ; (begin
3c90: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 28 66 .;; (f
3ca0: 6f 72 2d 65 61 63 68 0a 3b 3b 20 20 20 20 20 20 or-each.;;
3cb0: 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 71 (lambda (q
3cc0: 75 65 72 79 29 0a 3b 3b 20 20 20 20 20 20 20 20 uery).;;
3cd0: 20 20 20 20 20 20 28 64 62 69 3a 65 78 65 63 20 (dbi:exec
3ce0: 63 6f 6e 6e 20 71 75 65 72 79 20 73 65 73 73 69 conn query sessi
3cf0: 6f 6e 2d 69 64 29 29 0a 3b 3b 20 09 20 20 20 71 on-id)).;; . q
3d00: 75 65 72 69 65 73 29 0a 3b 3b 20 09 20 20 28 69 ueries).;; . (i
3d10: 6e 69 74 69 61 6c 69 7a 65 20 73 65 6c 66 20 27 nitialize self '
3d20: 28 29 29 0a 3b 3b 20 09 20 20 28 73 65 73 73 69 ()).;; . (sessi
3d30: 6f 6e 3a 73 65 74 75 70 20 73 65 6c 66 29 29 29 on:setup self)))
3d40: 0a 3b 3b 20 20 20 20 20 28 6e 6f 74 20 28 73 65 .;; (not (se
3d50: 73 73 69 6f 6e 3a 67 65 74 2d 73 65 73 73 69 6f ssion:get-sessio
3d60: 6e 2d 69 64 20 73 65 6c 66 20 73 65 73 73 69 6f n-id self sessio
3d70: 6e 2d 6b 65 79 29 29 29 29 0a 0a 28 64 65 66 69 n-key))))..(defi
3d80: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 65 78 74 72 ne (session:extr
3d90: 61 63 74 2d 6b 65 79 20 73 65 6c 66 20 6b 65 79 act-key self key
3da0: 29 0a 20 20 28 6c 65 74 20 28 28 70 61 72 61 6d ). (let ((param
3db0: 73 20 28 73 64 61 74 2d 67 65 74 2d 70 61 72 61 s (sdat-get-para
3dc0: 6d 73 20 73 65 6c 66 29 29 29 0a 20 20 20 20 28 ms self))). (
3dd0: 73 65 73 73 69 6f 6e 3a 65 78 74 72 61 63 74 2d session:extract-
3de0: 6b 65 79 2d 66 72 6f 6d 2d 70 61 72 61 6d 20 73 key-from-param s
3df0: 65 6c 66 20 70 61 72 61 6d 73 20 6b 65 79 29 29 elf params key))
3e00: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 )..(define (sess
3e10: 69 6f 6e 3a 65 78 74 72 61 63 74 2d 6b 65 79 2d ion:extract-key-
3e20: 66 72 6f 6d 2d 70 61 72 61 6d 20 73 65 6c 66 20 from-param self
3e30: 70 61 72 61 6d 73 20 6b 65 79 29 0a 20 20 28 6c params key). (l
3e40: 65 74 20 28 28 72 31 20 20 20 20 20 28 72 65 67 et ((r1 (reg
3e50: 65 78 70 20 28 73 74 72 69 6e 67 2d 61 70 70 65 exp (string-appe
3e60: 6e 64 20 22 5e 22 20 6b 65 79 20 22 3d 28 5b 5e nd "^" key "=([^
3e70: 3d 5d 2b 29 24 22 29 29 29 29 0a 20 20 20 20 28 =]+)$")))). (
3e80: 69 66 20 28 3c 20 28 6c 65 6e 67 74 68 20 70 61 if (< (length pa
3e90: 72 61 6d 73 29 20 31 29 20 23 66 0a 09 28 6c 65 rams) 1) #f..(le
3ea0: 74 20 6c 6f 6f 70 20 28 28 68 65 61 64 20 20 20 t loop ((head
3eb0: 28 63 61 72 20 70 61 72 61 6d 73 29 29 0a 09 09 (car params))...
3ec0: 20 20 20 28 74 61 69 6c 20 20 20 28 63 64 72 20 (tail (cdr
3ed0: 70 61 72 61 6d 73 29 29 29 0a 09 20 20 28 6c 65 params))).. (le
3ee0: 74 20 28 28 6d 61 74 63 68 20 28 73 74 72 69 6e t ((match (strin
3ef0: 67 2d 6d 61 74 63 68 20 72 31 20 68 65 61 64 29 g-match r1 head)
3f00: 29 29 0a 09 20 20 20 20 28 63 6f 6e 64 0a 09 20 )).. (cond..
3f10: 20 20 20 20 28 6d 61 74 63 68 0a 09 20 20 20 20 (match..
3f20: 20 20 28 6c 65 74 20 28 28 73 65 73 73 69 6f 6e (let ((session
3f30: 2d 6b 65 79 20 28 6c 69 73 74 2d 72 65 66 20 6d -key (list-ref m
3f40: 61 74 63 68 20 31 29 29 29 0a 09 09 28 73 64 61 atch 1)))...(sda
3f50: 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 t-set-session-ke
3f60: 79 21 20 73 65 6c 66 20 28 6c 69 73 74 2d 72 65 y! self (list-re
3f70: 66 20 6d 61 74 63 68 20 31 29 29 0a 09 09 73 65 f match 1))...se
3f80: 73 73 69 6f 6e 2d 6b 65 79 29 29 0a 09 20 20 20 ssion-key))..
3f90: 20 20 28 28 6e 75 6c 6c 3f 20 74 61 69 6c 29 0a ((null? tail).
3fa0: 09 20 20 20 20 20 20 23 66 29 0a 09 20 20 20 20 . #f)..
3fb0: 20 28 65 6c 73 65 0a 09 20 20 20 20 20 20 28 6c (else.. (l
3fc0: 6f 6f 70 20 28 63 61 72 20 74 61 69 6c 29 0a 09 oop (car tail)..
3fd0: 09 20 20 20 20 28 63 64 72 20 74 61 69 6c 29 29 . (cdr tail))
3fe0: 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 )))))))..(define
3ff0: 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 2d 70 61 (session:set-pa
4000: 67 65 21 20 73 65 6c 66 20 70 61 67 65 5f 6e 61 ge! self page_na
4010: 6d 65 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d me). (sdat-set-
4020: 70 61 67 65 21 20 73 65 6c 66 20 70 61 67 65 5f page! self page_
4030: 6e 61 6d 65 29 29 0a 0a 28 64 65 66 69 6e 65 20 name))..(define
4040: 28 73 65 73 73 69 6f 6e 3a 63 6c 6f 73 65 20 73 (session:close s
4050: 65 6c 66 29 0a 20 20 28 64 62 69 3a 63 6c 6f 73 elf). (dbi:clos
4060: 65 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e e (sdat-get-conn
4070: 20 73 65 6c 66 29 29 29 0a 3b 3b 20 28 63 6c 6f self))).;; (clo
4080: 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 28 se-output-port (
4090: 73 64 61 74 2d 67 65 74 2d 6c 6f 67 70 74 20 73 sdat-get-logpt s
40a0: 65 6c 66 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 elf))..(define (
40b0: 73 65 73 73 69 6f 6e 3a 65 72 72 2d 6d 73 67 20 session:err-msg
40c0: 73 65 6c 66 20 6d 73 67 29 0a 20 20 28 68 61 73 self msg). (has
40d0: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 28 73 64 h-table-set! (sd
40e0: 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 at-get-sessionva
40f0: 72 73 20 73 65 6c 66 29 20 22 45 52 52 4f 52 5f rs self) "ERROR_
4100: 4d 53 47 22 0a 09 09 20 20 20 28 73 74 72 69 6e MSG"... (strin
4110: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d g-intersperse (m
4120: 61 70 20 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 ap s:any->string
4130: 20 6d 73 67 29 20 22 20 22 29 29 29 0a 0a 28 64 msg) " ")))..(d
4140: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 70 efine (session:p
4150: 72 65 76 2d 65 72 72 20 73 65 6c 66 29 0a 20 20 rev-err self).
4160: 28 6c 65 74 20 28 28 70 72 65 76 2d 65 72 72 20 (let ((prev-err
4170: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
4180: 64 65 66 61 75 6c 74 20 28 73 64 61 74 2d 67 65 default (sdat-ge
4190: 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 t-sessionvars-be
41a0: 66 6f 72 65 20 73 65 6c 66 29 20 22 45 52 52 4f fore self) "ERRO
41b0: 52 5f 4d 53 47 22 20 23 66 29 29 0a 09 28 63 75 R_MSG" #f))..(cu
41c0: 72 72 2d 65 72 72 20 28 68 61 73 68 2d 74 61 62 rr-err (hash-tab
41d0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 28 le-ref/default (
41e0: 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e sdat-get-session
41f0: 76 61 72 73 20 73 65 6c 66 29 20 22 45 52 52 4f vars self) "ERRO
4200: 52 5f 4d 53 47 22 20 23 66 29 29 29 0a 20 20 20 R_MSG" #f))).
4210: 20 28 69 66 20 70 72 65 76 2d 65 72 72 20 70 72 (if prev-err pr
4220: 65 76 2d 65 72 72 0a 09 28 69 66 20 63 75 72 72 ev-err..(if curr
4230: 2d 65 72 72 20 63 75 72 72 2d 65 72 72 20 23 66 -err curr-err #f
4240: 29 29 29 29 0a 0a 3b 3b 20 73 65 73 73 69 6f 6e ))))..;; session
4250: 20 76 61 72 73 0a 3b 3b 20 31 2e 20 6b 65 79 73 vars.;; 1. keys
4260: 20 61 72 65 20 61 6c 77 61 79 73 20 61 20 73 74 are always a st
4270: 72 69 6e 67 20 4e 4f 54 20 61 20 73 79 6d 62 6f ring NOT a symbo
4280: 6c 0a 3b 3b 20 32 2e 20 76 61 6c 75 65 73 20 61 l.;; 2. values a
4290: 72 65 20 61 6c 77 61 79 73 20 61 20 73 74 72 69 re always a stri
42a0: 6e 67 20 63 6f 6e 76 65 72 73 69 6f 6e 20 69 73 ng conversion is
42b0: 20 74 68 65 20 72 65 73 70 6f 6e 73 69 62 69 6c the responsibil
42c0: 69 74 79 20 6f 66 20 74 68 65 20 0a 3b 3b 20 20 ity of the .;;
42d0: 20 20 63 6f 6e 73 75 6d 69 6e 67 20 66 75 6e 63 consuming func
42e0: 74 69 6f 6e 20 28 61 74 20 6c 65 61 73 74 20 66 tion (at least f
42f0: 6f 72 20 6e 6f 77 2c 20 49 27 64 20 6c 69 6b 65 or now, I'd like
4300: 20 74 6f 20 63 68 61 6e 67 65 20 74 68 69 73 29 to change this)
4310: 0a 0a 3b 3b 20 73 65 74 20 61 20 73 65 73 73 69 ..;; set a sessi
4320: 6f 6e 20 76 61 72 20 66 6f 72 20 74 68 65 20 63 on var for the c
4330: 75 72 72 65 6e 74 20 70 61 67 65 0a 3b 3b 0a 28 urrent page.;;.(
4340: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
4350: 73 65 74 21 20 73 65 6c 66 20 6b 65 79 20 76 61 set! self key va
4360: 6c 75 65 29 0a 20 20 28 68 61 73 68 2d 74 61 62 lue). (hash-tab
4370: 6c 65 2d 73 65 74 21 20 28 73 64 61 74 2d 67 65 le-set! (sdat-ge
4380: 74 2d 70 61 67 65 76 61 72 73 20 73 65 6c 66 29 t-pagevars self)
4390: 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 (s:any->string
43a0: 6b 65 79 29 20 28 73 3a 61 6e 79 2d 3e 73 74 72 key) (s:any->str
43b0: 69 6e 67 20 76 61 6c 75 65 29 29 29 0a 0a 3b 3b ing value)))..;;
43c0: 20 64 65 6c 20 61 20 76 61 72 20 66 6f 72 20 74 del a var for t
43d0: 68 65 20 63 75 72 72 65 6e 74 20 70 61 67 65 0a he current page.
43e0: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 ;;.(define (sess
43f0: 69 6f 6e 3a 64 65 6c 21 20 73 65 6c 66 20 6b 65 ion:del! self ke
4400: 79 29 0a 20 20 28 68 61 73 68 2d 74 61 62 6c 65 y). (hash-table
4410: 2d 64 65 6c 65 74 65 21 20 28 73 64 61 74 2d 67 -delete! (sdat-g
4420: 65 74 2d 70 61 67 65 76 61 72 73 20 73 65 6c 66 et-pagevars self
4430: 29 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 ) (s:any->string
4440: 20 6b 65 79 29 29 29 0a 0a 3b 3b 20 67 65 74 20 key)))..;; get
4450: 74 68 65 20 61 70 70 72 6f 70 72 69 61 74 65 20 the appropriate
4460: 68 61 73 68 20 67 69 76 65 6e 20 61 20 70 61 67 hash given a pag
4470: 65 20 22 2a 73 65 73 73 69 6f 6e 76 61 72 73 2a e "*sessionvars*
4480: 2c 20 2a 67 6c 6f 62 61 6c 76 61 72 73 2a 20 6f , *globalvars* o
4490: 72 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 69 6e r page.;;.(defin
44a0: 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 e (session:get-p
44b0: 61 67 65 2d 68 61 73 68 20 73 65 6c 66 20 70 61 age-hash self pa
44c0: 67 65 29 0a 20 20 28 69 66 20 28 73 74 72 69 6e ge). (if (strin
44d0: 67 3d 3f 20 70 61 67 65 20 22 2a 73 65 73 73 69 g=? page "*sessi
44e0: 6f 6e 76 61 72 73 2a 22 29 0a 20 20 20 20 20 20 onvars*").
44f0: 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f (sdat-get-sessio
4500: 6e 76 61 72 73 20 73 65 6c 66 29 0a 20 20 20 20 nvars self).
4510: 20 20 28 69 66 20 28 73 74 72 69 6e 67 3d 3f 20 (if (string=?
4520: 70 61 67 65 20 22 2a 67 6c 6f 62 61 6c 76 61 72 page "*globalvar
4530: 73 2a 22 29 0a 09 20 20 28 73 64 61 74 2d 67 65 s*").. (sdat-ge
4540: 74 2d 67 6c 6f 62 61 6c 76 61 72 73 20 73 65 6c t-globalvars sel
4550: 66 29 0a 09 20 20 28 73 64 61 74 2d 67 65 74 2d f).. (sdat-get-
4560: 70 61 67 65 76 61 72 73 20 73 65 6c 66 29 29 29 pagevars self)))
4570: 29 0a 0a 3b 3b 20 73 65 74 20 61 20 73 65 73 73 )..;; set a sess
4580: 69 6f 6e 20 76 61 72 20 66 6f 72 20 61 20 67 69 ion var for a gi
4590: 76 65 6e 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 ven page.;;.(def
45a0: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 ine (session:set
45b0: 21 20 73 65 6c 66 20 70 61 67 65 20 6b 65 79 20 ! self page key
45c0: 76 61 6c 75 65 29 0a 20 20 28 6c 65 74 20 28 28 value). (let ((
45d0: 68 74 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d ht (session:get-
45e0: 70 61 67 65 2d 68 61 73 68 20 73 65 6c 66 20 70 page-hash self p
45f0: 61 67 65 29 29 29 0a 20 20 20 20 28 68 61 73 68 age))). (hash
4600: 2d 74 61 62 6c 65 2d 73 65 74 21 20 68 74 20 28 -table-set! ht (
4610: 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6b 65 s:any->string ke
4620: 79 29 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e y) (s:any->strin
4630: 67 20 76 61 6c 75 65 29 29 29 29 0a 0a 3b 3b 20 g value))))..;;
4640: 67 65 74 20 73 65 73 73 69 6f 6e 20 76 61 72 73 get session vars
4650: 20 66 6f 72 20 74 68 65 20 63 75 72 72 65 6e 74 for the current
4660: 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 page.;;.(define
4670: 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 20 73 65 (session:get se
4680: 6c 66 20 6b 65 79 29 0a 20 20 28 68 61 73 68 2d lf key). (hash-
4690: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
46a0: 74 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 t (sdat-get-page
46b0: 76 61 72 73 20 73 65 6c 66 29 20 6b 65 79 20 23 vars self) key #
46c0: 66 29 29 0a 0a 3b 3b 20 67 65 74 20 73 65 73 73 f))..;; get sess
46d0: 69 6f 6e 20 76 61 72 73 20 66 6f 72 20 61 20 73 ion vars for a s
46e0: 70 65 63 69 66 69 65 64 20 70 61 67 65 0a 3b 3b pecified page.;;
46f0: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
4700: 6e 3a 67 65 74 20 73 65 6c 66 20 70 61 67 65 20 n:get self page
4710: 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 28 68 74 key). (let ((ht
4720: 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 (session:get-pa
4730: 67 65 2d 68 61 73 68 20 73 65 6c 66 20 70 61 67 ge-hash self pag
4740: 65 29 29 29 0a 20 20 20 20 28 68 61 73 68 2d 74 e))). (hash-t
4750: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
4760: 20 68 74 20 6b 65 79 20 23 66 29 29 29 0a 0a 3b ht key #f)))..;
4770: 3b 20 64 65 6c 65 74 65 20 61 20 73 65 73 73 69 ; delete a sessi
4780: 6f 6e 20 76 61 72 20 66 6f 72 20 61 20 73 70 65 on var for a spe
4790: 63 69 66 69 65 64 20 70 61 67 65 0a 3b 3b 0a 28 cified page.;;.(
47a0: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
47b0: 64 65 6c 21 20 73 65 6c 66 20 70 61 67 65 20 6b del! self page k
47c0: 65 79 29 0a 20 20 28 6c 65 74 20 28 28 68 74 20 ey). (let ((ht
47d0: 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 67 (session:get-pag
47e0: 65 2d 68 61 73 68 20 73 65 6c 66 20 70 61 67 65 e-hash self page
47f0: 29 29 29 0a 20 20 20 20 28 68 61 73 68 2d 74 61 ))). (hash-ta
4800: 62 6c 65 2d 64 65 6c 65 74 65 21 20 68 74 20 6b ble-delete! ht k
4810: 65 79 29 29 29 0a 0a 3b 3b 20 67 65 74 20 41 4c ey)))..;; get AL
4820: 4c 20 6b 65 79 73 20 66 6f 72 20 74 68 69 73 20 L keys for this
4830: 70 61 67 65 20 61 6e 64 20 73 74 6f 72 65 20 69 page and store i
4840: 6e 20 74 68 65 20 73 65 73 73 69 6f 6e 20 70 61 n the session pa
4850: 67 65 76 61 72 73 20 68 61 73 68 0a 3b 3b 0a 28 gevars hash.;;.(
4860: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
4870: 67 65 74 2d 76 61 72 73 20 73 65 6c 66 29 0a 20 get-vars self).
4880: 20 28 6c 65 74 20 28 28 73 65 73 73 69 6f 6e 2d (let ((session-
4890: 69 64 20 20 28 73 64 61 74 2d 67 65 74 2d 73 65 id (sdat-get-se
48a0: 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 29 29 29 ssion-id self)))
48b0: 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 73 65 . (if (not se
48c0: 73 73 69 6f 6e 2d 69 64 29 0a 09 28 65 72 72 3a ssion-id)..(err:
48d0: 6c 6f 67 20 22 45 52 52 4f 52 3a 20 4e 6f 20 73 log "ERROR: No s
48e0: 65 73 73 69 6f 6e 20 69 64 20 69 6e 20 73 65 73 ession id in ses
48f0: 73 69 6f 6e 20 6f 62 6a 65 63 74 21 20 73 65 73 sion object! ses
4900: 73 69 6f 6e 3a 67 65 74 2d 76 61 72 73 22 29 0a sion:get-vars").
4910: 09 28 6c 65 74 2a 20 28 28 72 65 73 75 6c 74 20 .(let* ((result
4920: 20 20 20 20 20 20 20 20 20 20 20 20 23 66 29 0a #f).
4930: 09 20 20 20 20 20 20 20 28 63 6f 6e 6e 20 20 20 . (conn
4940: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 64 61 (sda
4950: 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 t-get-conn self)
4960: 29 0a 09 20 20 20 20 20 20 20 28 70 61 67 65 76 ).. (pagev
4970: 61 72 73 2d 62 65 66 6f 72 65 20 20 20 20 28 73 ars-before (s
4980: 64 61 74 2d 67 65 74 2d 70 61 67 65 76 61 72 73 dat-get-pagevars
4990: 2d 62 65 66 6f 72 65 20 73 65 6c 66 29 29 0a 09 -before self))..
49a0: 20 20 20 20 20 20 20 28 73 65 73 73 69 6f 6e 76 (sessionv
49b0: 61 72 73 2d 62 65 66 6f 72 65 20 28 73 64 61 74 ars-before (sdat
49c0: 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 -get-sessionvars
49d0: 2d 62 65 66 6f 72 65 20 73 65 6c 66 29 29 0a 09 -before self))..
49e0: 20 20 20 20 20 20 20 28 67 6c 6f 62 61 6c 76 61 (globalva
49f0: 72 73 2d 62 65 66 6f 72 65 20 20 28 73 64 61 74 rs-before (sdat
4a00: 2d 67 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 2d -get-globalvars-
4a10: 62 65 66 6f 72 65 20 73 65 6c 66 29 29 0a 09 20 before self))..
4a20: 20 20 20 20 20 20 28 70 61 67 65 76 61 72 73 20 (pagevars
4a30: 20 20 20 20 20 20 20 20 20 20 28 73 64 61 74 2d (sdat-
4a40: 67 65 74 2d 70 61 67 65 76 61 72 73 20 73 65 6c get-pagevars sel
4a50: 66 29 29 0a 09 20 20 20 20 20 20 20 28 73 65 73 f)).. (ses
4a60: 73 69 6f 6e 76 61 72 73 20 20 20 20 20 20 20 20 sionvars
4a70: 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f (sdat-get-sessio
4a80: 6e 76 61 72 73 20 73 65 6c 66 29 29 0a 09 20 20 nvars self))..
4a90: 20 20 20 20 20 28 67 6c 6f 62 61 6c 76 61 72 73 (globalvars
4aa0: 20 20 20 20 20 20 20 20 20 28 73 64 61 74 2d 67 (sdat-g
4ab0: 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 20 73 65 et-globalvars se
4ac0: 6c 66 29 29 0a 09 20 20 20 20 20 20 20 28 70 61 lf)).. (pa
4ad0: 67 65 2d 6e 61 6d 65 20 20 20 20 20 20 20 20 20 ge-name
4ae0: 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 20 (sdat-get-page
4af0: 73 65 6c 66 29 29 0a 09 20 20 20 20 20 20 20 28 self)).. (
4b00: 73 65 73 73 69 6f 6e 2d 6b 65 79 20 20 20 20 20 session-key
4b10: 20 20 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 (sdat-get-ses
4b20: 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 29 0a sion-key self)).
4b30: 09 20 20 20 20 20 20 20 28 71 75 65 72 79 20 20 . (query
4b40: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 74 72 (str
4b50: 69 6e 67 2d 61 70 70 65 6e 64 0a 09 09 09 09 20 ing-append.....
4b60: 20 20 20 22 53 45 4c 45 43 54 20 6b 65 79 2c 76 "SELECT key,v
4b70: 61 6c 75 65 20 46 52 4f 4d 20 73 65 73 73 69 6f alue FROM sessio
4b80: 6e 5f 76 61 72 73 20 49 4e 4e 45 52 20 4a 4f 49 n_vars INNER JOI
4b90: 4e 20 73 65 73 73 69 6f 6e 73 20 4f 4e 20 73 65 N sessions ON se
4ba0: 73 73 69 6f 6e 5f 76 61 72 73 2e 73 65 73 73 69 ssion_vars.sessi
4bb0: 6f 6e 5f 69 64 3d 73 65 73 73 69 6f 6e 73 2e 69 on_id=sessions.i
4bc0: 64 20 22 0a 09 09 09 09 20 20 20 20 22 57 48 45 d "..... "WHE
4bd0: 52 45 20 73 65 73 73 69 6f 6e 5f 6b 65 79 3d 3f RE session_key=?
4be0: 20 41 4e 44 20 70 61 67 65 3d 3f 3b 22 29 29 29 AND page=?;")))
4bf0: 0a 09 20 20 3b 3b 20 66 69 72 73 74 20 74 68 65 .. ;; first the
4c00: 20 70 61 67 65 20 73 70 65 63 69 66 69 63 20 76 page specific v
4c10: 61 72 73 0a 09 20 20 28 64 62 69 3a 66 6f 72 2d ars.. (dbi:for-
4c20: 65 61 63 68 2d 72 6f 77 20 28 6c 61 6d 62 64 61 each-row (lambda
4c30: 20 28 74 75 70 6c 65 29 0a 09 09 09 20 20 20 20 (tuple)....
4c40: 20 20 28 6c 65 74 20 28 28 6b 20 28 76 65 63 74 (let ((k (vect
4c50: 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 30 29 29 or-ref tuple 0))
4c60: 0a 09 09 09 09 20 20 20 20 28 76 20 28 76 65 63 ..... (v (vec
4c70: 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 31 29 tor-ref tuple 1)
4c80: 29 29 0a 09 09 09 09 28 68 61 73 68 2d 74 61 62 )).....(hash-tab
4c90: 6c 65 2d 73 65 74 21 20 70 61 67 65 76 61 72 73 le-set! pagevars
4ca0: 2d 62 65 66 6f 72 65 20 6b 20 76 29 0a 09 09 09 -before k v)....
4cb0: 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 .(hash-table-set
4cc0: 21 20 70 61 67 65 76 61 72 73 20 20 20 20 20 20 ! pagevars
4cd0: 20 20 6b 20 76 29 29 29 0a 09 09 09 20 20 20 20 k v)))....
4ce0: 63 6f 6e 6e 0a 09 09 09 20 20 20 20 28 73 3a 73 conn.... (s:s
4cf0: 71 6c 70 61 72 61 6d 20 71 75 65 72 79 20 73 65 qlparam query se
4d00: 73 73 69 6f 6e 2d 6b 65 79 20 70 61 67 65 2d 6e ssion-key page-n
4d10: 61 6d 65 29 29 0a 09 20 20 3b 3b 20 74 68 65 6e ame)).. ;; then
4d20: 20 74 68 65 20 73 65 73 73 69 6f 6e 20 73 70 65 the session spe
4d30: 63 69 66 69 63 20 76 61 72 73 0a 09 20 20 28 64 cific vars.. (d
4d40: 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 bi:for-each-row
4d50: 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 29 0a (lambda (tuple).
4d60: 09 09 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 ... (let ((
4d70: 6b 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 75 k (vector-ref tu
4d80: 70 6c 65 20 30 29 29 0a 09 09 09 09 20 20 20 20 ple 0)).....
4d90: 28 76 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 (v (vector-ref t
4da0: 75 70 6c 65 20 31 29 29 29 0a 09 09 09 09 28 68 uple 1))).....(h
4db0: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 73 ash-table-set! s
4dc0: 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 essionvars-befor
4dd0: 65 20 6b 20 76 29 0a 09 09 09 09 28 68 61 73 68 e k v).....(hash
4de0: 2d 74 61 62 6c 65 2d 73 65 74 21 20 73 65 73 73 -table-set! sess
4df0: 69 6f 6e 76 61 72 73 20 20 20 20 20 20 20 20 6b ionvars k
4e00: 20 76 29 29 29 0a 09 09 09 20 20 20 20 63 6f 6e v))).... con
4e10: 6e 0a 09 09 09 20 20 20 20 28 73 3a 73 71 6c 70 n.... (s:sqlp
4e20: 61 72 61 6d 20 71 75 65 72 79 20 73 65 73 73 69 aram query sessi
4e30: 6f 6e 2d 6b 65 79 20 22 2a 73 65 73 73 69 6f 6e on-key "*session
4e40: 76 61 72 73 2a 22 29 29 0a 09 20 20 3b 3b 20 61 vars*")).. ;; a
4e50: 6e 64 20 66 69 6e 61 6c 6c 79 20 74 68 65 20 67 nd finally the g
4e60: 6c 6f 62 61 6c 20 76 61 72 73 0a 09 20 20 28 64 lobal vars.. (d
4e70: 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 bi:for-each-row
4e80: 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 29 0a (lambda (tuple).
4e90: 09 09 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 ... (let ((
4ea0: 6b 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 75 k (vector-ref tu
4eb0: 70 6c 65 20 30 29 29 0a 09 09 09 09 20 20 20 20 ple 0)).....
4ec0: 28 76 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 (v (vector-ref t
4ed0: 75 70 6c 65 20 31 29 29 29 0a 09 09 09 09 28 68 uple 1))).....(h
4ee0: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 67 ash-table-set! g
4ef0: 6c 6f 62 61 6c 76 61 72 73 2d 62 65 66 6f 72 65 lobalvars-before
4f00: 20 6b 20 76 29 0a 09 09 09 09 28 68 61 73 68 2d k v).....(hash-
4f10: 74 61 62 6c 65 2d 73 65 74 21 20 67 6c 6f 62 61 table-set! globa
4f20: 6c 76 61 72 73 20 20 20 20 20 20 20 20 6b 20 76 lvars k v
4f30: 29 29 29 0a 09 09 09 20 20 20 20 63 6f 6e 6e 0a ))).... conn.
4f40: 09 09 09 20 20 20 20 28 73 3a 73 71 6c 70 61 72 ... (s:sqlpar
4f50: 61 6d 20 71 75 65 72 79 20 73 65 73 73 69 6f 6e am query session
4f60: 2d 6b 65 79 20 22 2a 67 6c 6f 62 61 6c 76 61 72 -key "*globalvar
4f70: 73 22 29 29 0a 09 20 20 29 29 29 29 0a 0a 28 64 s")).. ))))..(d
4f80: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 efine (session:s
4f90: 61 76 65 2d 76 61 72 73 20 73 65 6c 66 29 0a 20 ave-vars self).
4fa0: 20 28 6c 65 74 20 28 28 73 65 73 73 69 6f 6e 2d (let ((session-
4fb0: 69 64 20 20 28 73 64 61 74 2d 67 65 74 2d 73 65 id (sdat-get-se
4fc0: 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 29 29 29 ssion-id self)))
4fd0: 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 73 65 . (if (not se
4fe0: 73 73 69 6f 6e 2d 69 64 29 0a 09 28 65 72 72 3a ssion-id)..(err:
4ff0: 6c 6f 67 20 22 45 52 52 4f 52 3a 20 4e 6f 20 73 log "ERROR: No s
5000: 65 73 73 69 6f 6e 20 69 64 20 69 6e 20 73 65 73 ession id in ses
5010: 73 69 6f 6e 20 6f 62 6a 65 63 74 21 20 73 65 73 sion object! ses
5020: 73 69 6f 6e 3a 67 65 74 2d 76 61 72 73 22 29 0a sion:get-vars").
5030: 09 28 6c 65 74 2a 20 28 28 73 74 61 74 75 73 20 .(let* ((status
5040: 20 20 20 20 20 23 66 29 0a 09 20 20 20 20 20 20 #f)..
5050: 20 28 63 6f 6e 6e 20 20 20 20 20 20 20 20 28 73 (conn (s
5060: 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c dat-get-conn sel
5070: 66 29 29 0a 09 20 20 20 20 20 20 20 28 70 61 67 f)).. (pag
5080: 65 2d 6e 61 6d 65 20 20 20 28 73 64 61 74 2d 67 e-name (sdat-g
5090: 65 74 2d 70 61 67 65 20 73 65 6c 66 29 29 0a 09 et-page self))..
50a0: 20 20 20 20 20 20 20 28 64 65 6c 2d 71 75 65 72 (del-quer
50b0: 79 20 20 20 22 44 45 4c 45 54 45 20 46 52 4f 4d y "DELETE FROM
50c0: 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 57 48 session_vars WH
50d0: 45 52 45 20 73 65 73 73 69 6f 6e 5f 69 64 3d 3f ERE session_id=?
50e0: 20 41 4e 44 20 70 61 67 65 3d 3f 20 41 4e 44 20 AND page=? AND
50f0: 6b 65 79 3d 3f 3b 22 29 0a 09 20 20 20 20 20 20 key=?;")..
5100: 20 28 69 6e 73 2d 71 75 65 72 79 20 20 20 22 49 (ins-query "I
5110: 4e 53 45 52 54 20 49 4e 54 4f 20 73 65 73 73 69 NSERT INTO sessi
5120: 6f 6e 5f 76 61 72 73 20 28 73 65 73 73 69 6f 6e on_vars (session
5130: 5f 69 64 2c 70 61 67 65 2c 6b 65 79 2c 76 61 6c _id,page,key,val
5140: 75 65 29 20 56 41 4c 55 45 53 28 3f 2c 3f 2c 3f ue) VALUES(?,?,?
5150: 2c 3f 29 3b 22 29 0a 09 20 20 20 20 20 20 20 28 ,?);").. (
5160: 75 70 64 2d 71 75 65 72 79 20 20 20 22 55 50 44 upd-query "UPD
5170: 41 54 45 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 ATE session_vars
5180: 20 73 65 74 20 76 61 6c 75 65 3d 3f 20 57 48 45 set value=? WHE
5190: 52 45 20 6b 65 79 3d 3f 20 41 4e 44 20 73 65 73 RE key=? AND ses
51a0: 73 69 6f 6e 5f 69 64 3d 3f 20 41 4e 44 20 70 61 sion_id=? AND pa
51b0: 67 65 3d 3f 3b 22 29 0a 09 20 20 20 20 20 20 20 ge=?;")..
51c0: 28 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 30 (changed-count 0
51d0: 29 29 0a 09 20 20 3b 3b 20 73 61 76 65 20 74 68 )).. ;; save th
51e0: 65 20 64 65 6c 74 61 20 6f 6e 6c 79 0a 09 20 20 e delta only..
51f0: 28 66 6f 72 2d 65 61 63 68 0a 09 20 20 20 28 6c (for-each.. (l
5200: 61 6d 62 64 61 20 28 70 61 67 65 29 20 3b 3b 20 ambda (page) ;;
5210: 70 61 67 65 20 69 73 3a 20 22 2a 67 6c 6f 62 61 page is: "*globa
5220: 6c 76 61 72 73 2a 22 20 22 2a 73 65 73 73 69 6f lvars*" "*sessio
5230: 6e 76 61 72 73 2a 22 20 6f 72 20 6f 74 68 65 72 nvars*" or other
5240: 73 74 72 69 6e 67 0a 09 20 20 20 20 20 28 6c 65 string.. (le
5250: 74 2a 20 28 28 62 65 66 6f 72 65 2d 61 66 74 65 t* ((before-afte
5260: 72 2d 68 74 20 28 63 6f 6e 64 0a 09 09 09 09 20 r-ht (cond.....
5270: 20 20 20 20 20 28 28 73 74 72 69 6e 67 3d 3f 20 ((string=?
5280: 70 61 67 65 20 22 2a 73 65 73 73 69 6f 6e 76 61 page "*sessionva
5290: 72 73 2a 22 29 0a 09 09 09 09 20 20 20 20 20 20 rs*").....
52a0: 20 28 76 65 63 74 6f 72 20 28 73 64 61 74 2d 67 (vector (sdat-g
52b0: 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 20 73 et-sessionvars s
52c0: 65 6c 66 29 0a 09 09 09 09 09 20 20 20 20 20 20 elf)......
52d0: 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 (sdat-get-sessi
52e0: 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 20 73 65 onvars-before se
52f0: 6c 66 29 29 29 0a 09 09 09 09 20 20 20 20 20 20 lf))).....
5300: 20 28 28 73 74 72 69 6e 67 3d 3f 20 70 61 67 65 ((string=? page
5310: 20 22 2a 67 6c 6f 62 61 6c 76 61 72 73 2a 22 29 "*globalvars*")
5320: 0a 09 09 09 09 09 28 76 65 63 74 6f 72 20 28 73 ......(vector (s
5330: 64 61 74 2d 67 65 74 2d 67 6c 6f 62 61 6c 76 61 dat-get-globalva
5340: 72 73 20 73 65 6c 66 29 0a 09 09 09 09 09 09 28 rs self).......(
5350: 73 64 61 74 2d 67 65 74 2d 67 6c 6f 62 61 6c 76 sdat-get-globalv
5360: 61 72 73 2d 62 65 66 6f 72 65 20 73 65 6c 66 29 ars-before self)
5370: 29 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 65 ))..... (e
5380: 6c 73 65 20 0a 09 09 09 09 09 28 76 65 63 74 6f lse ......(vecto
5390: 72 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 r (sdat-get-page
53a0: 76 61 72 73 20 73 65 6c 66 29 0a 09 09 09 09 09 vars self)......
53b0: 09 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 76 .(sdat-get-pagev
53c0: 61 72 73 2d 62 65 66 6f 72 65 20 73 65 6c 66 29 ars-before self)
53d0: 29 29 29 29 0a 09 09 20 20 20 20 28 6d 61 73 74 ))))... (mast
53e0: 65 72 2d 68 74 20 20 20 28 76 65 63 74 6f 72 2d er-ht (vector-
53f0: 72 65 66 20 62 65 66 6f 72 65 2d 61 66 74 65 72 ref before-after
5400: 2d 68 74 20 30 29 29 0a 09 09 20 20 20 20 28 62 -ht 0))... (b
5410: 65 66 6f 72 65 2d 68 74 20 20 20 28 76 65 63 74 efore-ht (vect
5420: 6f 72 2d 72 65 66 20 62 65 66 6f 72 65 2d 61 66 or-ref before-af
5430: 74 65 72 2d 68 74 20 31 29 29 0a 09 09 20 20 20 ter-ht 1))...
5440: 20 28 6d 61 73 74 65 72 2d 6b 65 79 73 20 28 68 (master-keys (h
5450: 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 6d ash-table-keys m
5460: 61 73 74 65 72 2d 68 74 29 29 0a 09 09 20 20 20 aster-ht))...
5470: 20 28 62 65 66 6f 72 65 2d 6b 65 79 73 20 28 68 (before-keys (h
5480: 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 62 ash-table-keys b
5490: 65 66 6f 72 65 2d 68 74 29 29 0a 09 09 20 20 20 efore-ht))...
54a0: 20 28 61 6c 6c 2d 6b 65 79 73 20 28 64 65 6c 65 (all-keys (dele
54b0: 74 65 2d 64 75 70 6c 69 63 61 74 65 73 20 28 61 te-duplicates (a
54c0: 70 70 65 6e 64 20 6d 61 73 74 65 72 2d 6b 65 79 ppend master-key
54d0: 73 20 62 65 66 6f 72 65 2d 6b 65 79 73 29 29 29 s before-keys)))
54e0: 29 0a 09 20 20 20 20 20 20 20 28 66 6f 72 2d 65 ).. (for-e
54f0: 61 63 68 20 0a 09 09 28 6c 61 6d 62 64 61 20 28 ach ...(lambda (
5500: 6b 65 79 29 0a 09 09 20 20 28 6c 65 74 20 28 28 key)... (let ((
5510: 6d 61 73 74 65 72 2d 76 61 6c 75 65 20 28 68 61 master-value (ha
5520: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
5530: 61 75 6c 74 20 6d 61 73 74 65 72 2d 68 74 20 6b ault master-ht k
5540: 65 79 20 23 66 29 29 0a 09 09 09 28 62 65 66 6f ey #f))....(befo
5550: 72 65 2d 76 61 6c 75 65 20 28 68 61 73 68 2d 74 re-value (hash-t
5560: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
5570: 20 62 65 66 6f 72 65 2d 68 74 20 6b 65 79 20 23 before-ht key #
5580: 66 29 29 29 0a 09 09 20 20 20 20 28 63 6f 6e 64 f)))... (cond
5590: 0a 09 09 20 20 20 20 20 3b 3b 20 62 65 66 6f 72 ... ;; befor
55a0: 65 20 61 6e 64 20 61 66 74 65 72 20 65 78 69 73 e and after exis
55b0: 74 20 61 6e 64 20 76 61 6c 75 65 20 75 6e 63 68 t and value unch
55c0: 61 6e 67 65 64 20 2d 20 64 6f 20 6e 6f 74 68 69 anged - do nothi
55d0: 6e 67 0a 09 09 20 20 20 20 20 28 28 61 6e 64 20 ng... ((and
55e0: 6d 61 73 74 65 72 2d 76 61 6c 75 65 20 62 65 66 master-value bef
55f0: 6f 72 65 2d 76 61 6c 75 65 20 28 65 71 75 61 6c ore-value (equal
5600: 3f 20 6d 61 73 74 65 72 2d 76 61 6c 75 65 20 62 ? master-value b
5610: 65 66 6f 72 65 2d 76 61 6c 75 65 29 29 29 0a 09 efore-value)))..
5620: 09 20 20 20 20 20 3b 3b 20 62 65 66 6f 72 65 20 . ;; before
5630: 61 6e 64 20 61 66 74 65 72 20 65 78 69 73 74 20 and after exist
5640: 62 75 74 20 61 72 65 20 63 68 61 6e 67 65 64 0a but are changed.
5650: 09 09 20 20 20 20 20 28 28 61 6e 64 20 6d 61 73 .. ((and mas
5660: 74 65 72 2d 76 61 6c 75 65 20 62 65 66 6f 72 65 ter-value before
5670: 2d 76 61 6c 75 65 29 0a 09 09 20 20 20 20 20 20 -value)...
5680: 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f (dbi:for-each-ro
5690: 77 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 w (lambda (tuple
56a0: 29 0a 09 09 09 09 09 20 20 28 73 65 74 21 20 63 )...... (set! c
56b0: 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 28 2b 20 hanged-count (+
56c0: 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 31 29 changed-count 1)
56d0: 29 29 0a 09 09 09 09 09 63 6f 6e 6e 0a 09 09 09 ))......conn....
56e0: 09 09 28 73 3a 73 71 6c 70 61 72 61 6d 20 75 70 ..(s:sqlparam up
56f0: 64 2d 71 75 65 72 79 20 6d 61 73 74 65 72 2d 76 d-query master-v
5700: 61 6c 75 65 20 6b 65 79 20 73 65 73 73 69 6f 6e alue key session
5710: 2d 69 64 20 70 61 67 65 29 29 29 0a 09 09 20 20 -id page)))...
5720: 20 20 20 3b 3b 20 6d 61 73 74 65 72 2d 76 61 6c ;; master-val
5730: 75 65 20 6e 6f 20 6c 6f 6e 67 65 72 20 65 78 69 ue no longer exi
5740: 73 74 73 20 28 69 2e 65 2e 20 23 66 29 20 2d 20 sts (i.e. #f) -
5750: 72 65 6d 6f 76 65 20 69 74 65 6d 0a 09 09 20 20 remove item...
5760: 20 20 20 28 28 6e 6f 74 20 6d 61 73 74 65 72 2d ((not master-
5770: 76 61 6c 75 65 29 0a 09 09 20 20 20 20 20 20 28 value)... (
5780: 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 dbi:for-each-row
5790: 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 29 (lambda (tuple)
57a0: 0a 09 09 09 09 09 20 20 28 73 65 74 21 20 63 68 ...... (set! ch
57b0: 61 6e 67 65 64 2d 63 6f 75 6e 74 20 28 2b 20 63 anged-count (+ c
57c0: 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 31 29 29 hanged-count 1))
57d0: 29 0a 09 09 09 09 09 63 6f 6e 6e 0a 09 09 09 09 )......conn.....
57e0: 09 28 73 3a 73 71 6c 70 61 72 61 6d 20 64 65 6c .(s:sqlparam del
57f0: 2d 71 75 65 72 79 20 73 65 73 73 69 6f 6e 2d 69 -query session-i
5800: 64 20 70 61 67 65 20 6b 65 79 29 29 29 0a 09 09 d page key)))...
5810: 20 20 20 20 20 3b 3b 20 62 65 66 6f 72 65 2d 76 ;; before-v
5820: 61 6c 75 65 20 64 6f 65 73 6e 27 74 20 65 78 69 alue doesn't exi
5830: 73 74 20 2d 20 69 6e 73 65 72 74 20 61 20 6e 65 st - insert a ne
5840: 77 20 76 61 6c 75 65 0a 09 09 20 20 20 20 20 28 w value... (
5850: 28 6e 6f 74 20 62 65 66 6f 72 65 2d 76 61 6c 75 (not before-valu
5860: 65 29 0a 09 09 20 20 20 20 20 20 28 64 62 69 3a e)... (dbi:
5870: 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 for-each-row (la
5880: 6d 62 64 61 20 28 74 75 70 6c 65 29 0a 09 09 09 mbda (tuple)....
5890: 09 09 20 20 28 73 65 74 21 20 63 68 61 6e 67 65 .. (set! change
58a0: 64 2d 63 6f 75 6e 74 20 28 2b 20 63 68 61 6e 67 d-count (+ chang
58b0: 65 64 2d 63 6f 75 6e 74 20 31 29 29 29 0a 09 09 ed-count 1)))...
58c0: 09 09 09 63 6f 6e 6e 0a 09 09 09 09 09 28 73 3a ...conn......(s:
58d0: 73 71 6c 70 61 72 61 6d 20 69 6e 73 2d 71 75 65 sqlparam ins-que
58e0: 72 79 20 73 65 73 73 69 6f 6e 2d 69 64 20 70 61 ry session-id pa
58f0: 67 65 20 6b 65 79 20 6d 61 73 74 65 72 2d 76 61 ge key master-va
5900: 6c 75 65 29 29 29 0a 09 09 20 20 20 20 20 28 65 lue)))... (e
5910: 6c 73 65 20 28 65 72 72 3a 6c 6f 67 20 22 53 68 lse (err:log "Sh
5920: 6f 75 6c 64 6e 27 74 20 67 65 74 20 68 65 72 65 ouldn't get here
5930: 22 29 29 29 29 29 0a 09 09 61 6c 6c 2d 6b 65 79 ")))))...all-key
5940: 73 29 29 29 20 3b 3b 20 70 72 6f 63 65 73 73 20 s))) ;; process
5950: 61 6c 6c 20 6b 65 79 73 0a 09 20 20 20 28 6c 69 all keys.. (li
5960: 73 74 20 22 2a 73 65 73 73 69 6f 6e 76 61 72 73 st "*sessionvars
5970: 2a 22 20 22 2a 67 6c 6f 62 61 6c 76 61 72 73 2a *" "*globalvars*
5980: 22 20 70 61 67 65 2d 6e 61 6d 65 29 29 29 29 29 " page-name)))))
5990: 29 0a 0a 3b 3b 20 28 70 67 3a 73 71 6c 2d 6e 75 )..;; (pg:sql-nu
59a0: 6c 6c 2d 6f 62 6a 65 63 74 3f 20 65 6c 65 6d 65 ll-object? eleme
59b0: 6e 74 29 0a 28 64 65 66 69 6e 65 20 28 73 65 73 nt).(define (ses
59c0: 73 69 6f 6e 3a 72 65 61 64 2d 63 6f 6e 66 69 67 sion:read-config
59d0: 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 self). (let ((
59e0: 6e 61 6d 65 20 28 73 74 72 69 6e 67 2d 61 70 70 name (string-app
59f0: 65 6e 64 20 22 2e 22 20 28 70 61 74 68 6e 61 6d end "." (pathnam
5a00: 65 2d 66 69 6c 65 20 28 63 61 72 20 28 61 72 67 e-file (car (arg
5a10: 76 29 29 29 20 22 2e 63 6f 6e 66 69 67 22 29 29 v))) ".config"))
5a20: 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 ). (if (not (
5a30: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 6e 61 6d file-exists? nam
5a40: 65 29 29 0a 09 28 70 72 69 6e 74 20 6e 61 6d 65 e))..(print name
5a50: 20 22 20 6e 6f 74 20 66 6f 75 6e 64 20 61 74 20 " not found at
5a60: 22 20 28 63 75 72 72 65 6e 74 2d 64 69 72 65 63 " (current-direc
5a70: 74 6f 72 79 29 29 0a 09 28 6c 65 74 2a 20 28 28 tory))..(let* ((
5a80: 66 70 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 66 fp (open-input-f
5a90: 69 6c 65 20 6e 61 6d 65 29 29 0a 09 20 20 20 20 ile name))..
5aa0: 20 20 20 28 69 6e 69 74 61 72 67 73 20 28 72 65 (initargs (re
5ab0: 61 64 20 66 70 29 29 29 0a 09 20 20 28 63 6c 6f ad fp))).. (clo
5ac0: 73 65 2d 69 6e 70 75 74 2d 70 6f 72 74 20 66 70 se-input-port fp
5ad0: 29 0a 09 20 20 69 6e 69 74 61 72 67 73 29 29 29 ).. initargs)))
5ae0: 29 0a 0a 3b 3b 20 63 61 6c 6c 20 74 68 65 20 63 )..;; call the c
5af0: 6f 6e 74 72 6f 6c 6c 65 72 20 69 66 20 69 74 20 ontroller if it
5b00: 65 78 69 73 74 73 0a 3b 3b 20 0a 3b 3b 20 57 41 exists.;; .;; WA
5b10: 52 4e 49 4e 47 20 2d 20 74 68 69 73 20 63 6f 64 RNING - this cod
5b20: 65 20 6e 65 65 64 73 20 61 20 64 65 66 65 6e 63 e needs a defenc
5b30: 65 20 61 67 61 69 6e 73 20 72 65 63 75 72 73 69 e agains recursi
5b40: 76 65 20 63 61 6c 6c 69 6e 67 21 21 21 21 21 0a ve calling!!!!!.
5b50: 3b 3b 0a 3b 3b 20 20 20 49 20 73 75 67 67 65 73 ;;.;; I sugges
5b60: 74 20 61 20 6c 69 6d 69 74 20 6f 66 20 31 30 30 t a limit of 100
5b70: 20 63 61 6c 6c 73 2e 20 50 6c 65 6e 74 79 20 66 calls. Plenty f
5b80: 6f 72 20 61 6c 6c 6f 77 69 6e 67 20 6d 75 6c 74 or allowing mult
5b90: 69 70 6c 65 20 69 6e 73 74 61 6e 63 65 73 0a 3b iple instances.;
5ba0: 3b 20 20 20 6f 66 20 61 20 70 61 67 65 20 69 6e ; of a page in
5bb0: 73 69 64 65 20 61 6e 6f 74 68 65 72 20 70 61 67 side another pag
5bc0: 65 2e 20 0a 3b 3b 0a 3b 3b 20 70 61 72 74 73 20 e. .;;.;; parts
5bd0: 3d 20 27 62 6f 74 68 20 7c 20 27 63 6f 6e 74 72 = 'both | 'contr
5be0: 6f 6c 20 7c 20 27 76 69 65 77 0a 3b 3b 0a 0a 28 ol | 'view.;;..(
5bf0: 64 65 66 69 6e 65 20 28 66 69 6c 65 73 2d 72 65 define (files-re
5c00: 61 64 2d 3e 73 74 72 69 6e 67 20 2e 20 66 69 6c ad->string . fil
5c10: 65 73 29 0a 20 20 28 73 74 72 69 6e 67 2d 69 6e es). (string-in
5c20: 74 65 72 73 70 65 72 73 65 20 0a 20 20 20 28 61 tersperse . (a
5c30: 70 70 6c 79 20 61 70 70 65 6e 64 20 28 6d 61 70 pply append (map
5c40: 20 66 69 6c 65 2d 72 65 61 64 2d 3e 73 74 72 69 file-read->stri
5c50: 6e 67 20 66 69 6c 65 73 29 29 20 22 5c 6e 22 29 ng files)) "\n")
5c60: 29 0a 0a 28 64 65 66 69 6e 65 20 28 66 69 6c 65 )..(define (file
5c70: 2d 72 65 61 64 2d 3e 73 74 72 69 6e 67 20 66 29 -read->string f)
5c80: 20 0a 20 20 28 6c 65 74 20 28 28 70 20 28 6f 70 . (let ((p (op
5c90: 65 6e 2d 69 6e 70 75 74 2d 66 69 6c 65 20 66 29 en-input-file f)
5ca0: 29 29 0a 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 )). (let loop
5cb0: 20 28 28 68 65 64 20 28 72 65 61 64 2d 6c 69 6e ((hed (read-lin
5cc0: 65 20 70 29 29 0a 09 20 20 20 20 20 20 20 28 72 e p)).. (r
5cd0: 65 73 20 27 28 29 29 29 0a 20 20 20 20 20 20 28 es '())). (
5ce0: 69 66 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 if (eof-object?
5cf0: 68 65 64 29 0a 09 20 20 72 65 73 0a 09 20 20 28 hed).. res.. (
5d00: 6c 6f 6f 70 20 28 72 65 61 64 2d 6c 69 6e 65 20 loop (read-line
5d10: 70 29 28 61 70 70 65 6e 64 20 72 65 73 20 28 6c p)(append res (l
5d20: 69 73 74 20 68 65 64 29 29 29 29 29 29 29 0a 0a ist hed)))))))..
5d30: 28 64 65 66 69 6e 65 20 28 70 72 6f 63 65 73 73 (define (process
5d40: 2d 70 6f 72 74 20 70 29 0a 20 20 28 6c 65 74 20 -port p). (let
5d50: 28 28 65 20 28 69 6e 74 65 72 61 63 74 69 6f 6e ((e (interaction
5d60: 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 29 29 29 0a -environment))).
5d70: 20 20 20 20 28 6d 61 70 20 0a 20 20 20 20 20 28 (map . (
5d80: 6c 61 6d 62 64 61 20 28 78 29 0a 20 20 20 20 20 lambda (x).
5d90: 20 20 28 63 6f 6e 64 0a 09 28 28 6c 69 73 74 3f (cond..((list?
5da0: 20 78 29 20 78 29 0a 09 28 28 73 74 72 69 6e 67 x) x)..((string
5db0: 3f 20 78 29 20 78 29 0a 09 28 65 6c 73 65 20 27 ? x) x)..(else '
5dc0: 28 29 29 29 29 0a 20 20 20 20 20 28 70 6f 72 74 ()))). (port
5dd0: 2d 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 73 29 -map (lambda (s)
5de0: 0a 09 09 20 28 65 76 61 6c 20 73 20 65 29 29 0a ... (eval s e)).
5df0: 09 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 . (lambda
5e00: 28 29 28 72 65 61 64 20 70 29 29 29 29 29 29 0a ()(read p)))))).
5e10: 0a 3b 3b 20 4d 61 79 20 32 30 31 31 2c 20 70 75 .;; May 2011, pu
5e20: 74 74 69 6e 67 20 61 6c 6c 20 70 61 67 65 73 20 tting all pages
5e30: 69 6e 74 6f 20 6f 6e 65 20 64 69 72 65 63 74 6f into one directo
5e40: 72 79 20 66 6f 72 20 74 68 65 20 66 6f 6c 6c 6f ry for the follo
5e50: 77 69 6e 67 20 72 65 61 73 6f 6e 73 3a 0a 3b 3b wing reasons:.;;
5e60: 20 20 20 31 2e 20 77 61 6e 74 20 66 69 6c 65 6e 1. want filen
5e70: 61 6d 65 20 74 6f 20 72 65 66 6c 65 63 74 20 70 ame to reflect p
5e80: 61 67 65 20 6e 61 6d 65 20 28 65 6d 61 63 73 20 age name (emacs
5e90: 6c 69 6d 69 74 61 74 69 6f 6e 29 0a 3b 3b 20 20 limitation).;;
5ea0: 20 32 2e 20 74 68 61 74 27 73 20 69 74 21 20 6e 2. that's it! n
5eb0: 6f 20 6f 74 68 65 72 20 72 65 61 73 6f 6e 2e 20 o other reason.
5ec0: 63 6f 75 6c 64 20 6d 61 6b 65 20 69 74 20 63 6f could make it co
5ed0: 6e 66 69 67 75 72 61 62 6c 65 20 2e 2e 2e 0a 28 nfigurable ....(
5ee0: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
5ef0: 63 61 6c 6c 2d 70 61 72 74 73 20 73 65 6c 66 20 call-parts self
5f00: 70 61 67 65 20 70 61 72 74 73 29 0a 20 20 28 73 page parts). (s
5f10: 64 61 74 2d 73 65 74 2d 63 75 72 72 2d 70 61 67 dat-set-curr-pag
5f20: 65 21 20 73 65 6c 66 20 70 61 67 65 29 0a 20 20 e! self page).
5f30: 3b 3b 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 ;; (session:log
5f40: 73 65 6c 66 20 22 70 61 67 65 2d 64 69 72 2d 73 self "page-dir-s
5f50: 74 79 6c 65 3a 20 22 20 28 73 64 61 74 2d 67 65 tyle: " (sdat-ge
5f60: 74 2d 70 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 t-page-dir-style
5f70: 20 73 65 6c 66 29 29 0a 20 20 28 6c 65 74 2a 20 self)). (let*
5f80: 28 28 64 69 72 2d 73 74 79 6c 65 20 3b 3b 20 28 ((dir-style ;; (
5f90: 65 71 75 61 6c 3f 20 28 73 64 61 74 2d 67 65 74 equal? (sdat-get
5fa0: 2d 70 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 20 -page-dir-style
5fb0: 73 65 6c 66 29 20 22 6f 6e 65 64 69 72 22 29 29 self) "onedir"))
5fc0: 20 3b 3b 20 66 6c 61 67 20 23 74 20 66 6f 72 20 ;; flag #t for
5fd0: 6f 6e 65 64 69 72 2c 20 23 66 20 66 6f 72 20 6f onedir, #f for o
5fe0: 6c 64 20 73 74 79 6c 65 0a 09 20 20 28 73 64 61 ld style.. (sda
5ff0: 74 2d 67 65 74 2d 70 61 67 65 2d 64 69 72 2d 73 t-get-page-dir-s
6000: 74 79 6c 65 20 73 65 6c 66 29 29 0a 09 20 28 64 tyle self)).. (d
6010: 69 72 20 20 20 20 20 28 73 74 72 69 6e 67 2d 61 ir (string-a
6020: 70 70 65 6e 64 20 28 73 64 61 74 2d 67 65 74 2d ppend (sdat-get-
6030: 73 72 6f 6f 74 20 73 65 6c 66 29 20 0a 09 09 09 sroot self) ....
6040: 09 20 28 69 66 20 64 69 72 2d 73 74 79 6c 65 20 . (if dir-style
6050: 0a 09 09 09 09 20 20 20 20 20 28 63 6f 6e 63 20 ..... (conc
6060: 22 2f 70 61 67 65 73 2f 22 29 0a 09 09 09 09 20 "/pages/").....
6070: 20 20 20 20 28 63 6f 6e 63 20 22 2f 70 61 67 65 (conc "/page
6080: 73 2f 22 20 70 61 67 65 29 29 29 29 0a 09 20 28 s/" page)))).. (
6090: 63 6f 6e 74 72 6f 6c 20 28 73 74 72 69 6e 67 2d control (string-
60a0: 61 70 70 65 6e 64 20 64 69 72 20 28 69 66 20 64 append dir (if d
60b0: 69 72 2d 73 74 79 6c 65 20 0a 09 09 09 09 09 20 ir-style ......
60c0: 28 63 6f 6e 63 20 70 61 67 65 20 22 5f 63 74 72 (conc page "_ctr
60d0: 6c 2e 73 63 6d 22 29 0a 09 09 09 09 09 20 22 2f l.scm")...... "/
60e0: 63 6f 6e 74 72 6f 6c 2e 73 63 6d 22 29 29 29 0a control.scm"))).
60f0: 09 20 28 76 69 65 77 20 20 20 20 28 73 74 72 69 . (view (stri
6100: 6e 67 2d 61 70 70 65 6e 64 20 64 69 72 20 28 69 ng-append dir (i
6110: 66 20 64 69 72 2d 73 74 79 6c 65 20 0a 09 09 09 f dir-style ....
6120: 09 09 20 28 63 6f 6e 63 20 70 61 67 65 20 22 5f .. (conc page "_
6130: 76 69 65 77 2e 73 63 6d 22 29 0a 09 09 09 09 09 view.scm")......
6140: 20 22 2f 76 69 65 77 2e 73 63 6d 22 29 29 29 0a "/view.scm"))).
6150: 09 20 28 6c 6f 61 64 2d 76 69 65 77 20 20 20 20 . (load-view
6160: 28 61 6e 64 20 28 66 69 6c 65 2d 65 78 69 73 74 (and (file-exist
6170: 73 3f 20 76 69 65 77 29 0a 09 09 09 20 20 20 20 s? view)....
6180: 28 6f 72 20 28 65 71 3f 20 70 61 72 74 73 20 27 (or (eq? parts '
6190: 62 6f 74 68 29 28 65 71 3f 20 70 61 72 74 73 20 both)(eq? parts
61a0: 27 76 69 65 77 29 29 29 29 0a 09 20 28 6c 6f 61 'view)))).. (loa
61b0: 64 2d 63 6f 6e 74 72 6f 6c 20 28 61 6e 64 20 28 d-control (and (
61c0: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 63 6f 6e file-exists? con
61d0: 74 72 6f 6c 29 0a 09 09 09 20 20 20 20 28 6f 72 trol).... (or
61e0: 20 28 65 71 3f 20 70 61 72 74 73 20 27 62 6f 74 (eq? parts 'bot
61f0: 68 29 28 65 71 3f 20 70 61 72 74 73 20 27 63 6f h)(eq? parts 'co
6200: 6e 74 72 6f 6c 29 29 29 29 0a 09 20 28 76 69 65 ntrol)))).. (vie
6210: 77 2d 64 61 74 20 20 20 27 28 29 29 29 0a 20 20 w-dat '())).
6220: 20 20 3b 3b 20 28 73 65 73 73 69 6f 6e 3a 6c 6f ;; (session:lo
6230: 67 20 73 65 6c 66 20 22 64 69 72 2d 73 74 79 6c g self "dir-styl
6240: 65 3a 20 22 20 64 69 72 2d 73 74 79 6c 65 29 0a e: " dir-style).
6250: 20 3b 3b 20 20 20 28 73 75 67 61 72 20 22 2f 68 ;; (sugar "/h
6260: 6f 6d 65 2f 6d 61 74 74 2f 6b 69 61 74 6f 61 2f ome/matt/kiatoa/
6270: 73 74 6d 6c 2f 73 75 67 61 72 2e 73 63 6d 22 20 stml/sugar.scm"
6280: 29 29 0a 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 )). ;; (print
6290: 20 22 64 69 72 3d 22 20 64 69 72 20 22 20 63 6f "dir=" dir " co
62a0: 6e 74 72 6f 6c 3d 22 20 63 6f 6e 74 72 6f 6c 20 ntrol=" control
62b0: 22 20 76 69 65 77 3d 22 20 76 69 65 77 20 22 20 " view=" view "
62c0: 6c 6f 61 64 2d 76 69 65 77 3d 22 20 6c 6f 61 64 load-view=" load
62d0: 2d 76 69 65 77 20 22 20 6c 6f 61 64 3d 63 6f 6e -view " load=con
62e0: 74 72 6f 6c 3d 22 20 6c 6f 61 64 2d 63 6f 6e 74 trol=" load-cont
62f0: 72 6f 6c 29 0a 20 20 20 20 28 69 66 20 6c 6f 61 rol). (if loa
6300: 64 2d 63 6f 6e 74 72 6f 6c 0a 09 28 62 65 67 69 d-control..(begi
6310: 6e 0a 09 20 20 28 6c 6f 61 64 20 63 6f 6e 74 72 n.. (load contr
6320: 6f 6c 29 0a 09 20 20 28 73 65 73 73 69 6f 6e 3a ol).. (session:
6330: 73 65 74 2d 63 61 6c 6c 65 64 21 20 73 65 6c 66 set-called! self
6340: 20 70 61 67 65 29 29 29 0a 20 20 20 20 3b 3b 20 page))). ;;
6350: 6d 6f 76 65 20 74 68 69 73 20 74 6f 20 77 68 65 move this to whe
6360: 72 65 20 69 74 20 67 65 74 73 20 65 78 65 63 74 re it gets exect
6370: 75 74 65 64 20 6f 6e 6c 79 20 6f 6e 63 65 0a 20 uted only once.
6380: 20 20 20 3b 3b 0a 20 20 20 20 3b 3b 28 73 3a 6c ;;. ;;(s:l
6390: 6f 67 20 22 73 3a 62 20 79 69 65 6c 64 73 20 22 og "s:b yields "
63a0: 20 28 73 3a 62 20 22 62 6c 61 68 22 29 29 0a 20 (s:b "blah")).
63b0: 20 20 20 28 69 66 20 6c 6f 61 64 2d 76 69 65 77 (if load-view
63c0: 0a 09 3b 3b 20 6f 70 74 69 6f 6e 20 6f 6e 65 3a ..;; option one:
63d0: 0a 09 3b 3b 0a 09 3b 3b 20 28 6c 65 74 20 28 28 ..;;..;; (let ((
63e0: 69 6e 70 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d inp (open-input-
63f0: 73 74 72 69 6e 67 20 0a 09 3b 3b 20 09 20 20 20 string ..;; .
6400: 20 28 66 69 6c 65 73 2d 72 65 61 64 2d 3e 73 74 (files-read->st
6410: 72 69 6e 67 20 22 2f 68 6f 6d 65 2f 6d 61 74 74 ring "/home/matt
6420: 2f 6b 69 61 74 6f 61 2f 73 74 6d 6c 2f 73 75 67 /kiatoa/stml/sug
6430: 61 72 2e 73 63 6d 22 20 0a 09 3b 3b 20 09 09 09 ar.scm" ..;; ...
6440: 09 76 69 65 77 29 29 29 29 0a 09 3b 3b 20 20 20 .view))))..;;
6450: 28 6d 61 70 20 0a 09 3b 3b 20 20 20 20 28 6c 61 (map ..;; (la
6460: 6d 62 64 61 20 28 78 29 0a 09 3b 3b 20 20 20 20 mbda (x)..;;
6470: 20 20 28 63 6f 6e 64 0a 09 3b 3b 20 20 20 20 20 (cond..;;
6480: 20 20 28 28 6c 69 73 74 3f 20 78 29 20 78 29 0a ((list? x) x).
6490: 09 3b 3b 20 20 20 20 20 20 20 28 28 73 74 72 69 .;; ((stri
64a0: 6e 67 3f 20 78 29 20 78 29 0a 09 3b 3b 20 20 20 ng? x) x)..;;
64b0: 20 20 20 20 28 65 6c 73 65 20 27 28 29 29 29 29 (else '())))
64c0: 0a 09 3b 3b 20 20 20 20 28 70 6f 72 74 2d 6d 61 ..;; (port-ma
64d0: 70 20 65 76 61 6c 20 28 6c 61 6d 62 64 61 20 28 p eval (lambda (
64e0: 29 0a 09 3b 3b 20 09 09 20 28 72 65 61 64 20 69 )..;; .. (read i
64f0: 6e 70 29 29 29 29 29 0a 09 3b 3b 0a 09 3b 3b 20 np)))))..;;..;;
6500: 6f 70 74 69 6f 6e 20 74 77 6f 3a 0a 09 3b 3b 0a option two:..;;.
6510: 09 28 6c 65 74 2a 20 28 3b 3b 20 28 69 6e 70 73 .(let* (;; (inps
6520: 20 28 6d 61 70 20 6f 70 65 6e 2d 69 6e 70 75 74 (map open-input
6530: 2d 66 69 6c 65 20 28 6c 69 73 74 20 76 69 65 77 -file (list view
6540: 29 29 29 20 3b 3b 20 73 75 67 61 72 20 76 69 65 ))) ;; sugar vie
6550: 77 29 29 29 0a 09 20 20 20 20 20 20 20 28 70 20 w))).. (p
6560: 20 20 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 66 (open-input-f
6570: 69 6c 65 20 76 69 65 77 29 29 20 3b 3b 20 28 61 ile view)) ;; (a
6580: 70 70 6c 79 20 6d 61 6b 65 2d 63 6f 6e 63 61 74 pply make-concat
6590: 65 6e 61 74 65 64 2d 70 6f 72 74 20 69 6e 70 73 enated-port inps
65a0: 29 29 0a 09 20 20 20 20 20 20 20 28 64 61 74 20 )).. (dat
65b0: 20 28 70 72 6f 63 65 73 73 2d 70 6f 72 74 20 70 (process-port p
65c0: 29 29 29 0a 09 09 3b 3b 28 6d 61 70 20 0a 09 09 )))...;;(map ...
65d0: 3b 3b 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 ;; (lambda
65e0: 28 78 29 0a 09 09 3b 3b 09 28 63 6f 6e 64 0a 09 (x)...;;.(cond..
65f0: 09 3b 3b 09 20 28 28 6c 69 73 74 3f 20 78 29 20 .;;. ((list? x)
6600: 78 29 0a 09 09 3b 3b 09 20 28 28 73 74 72 69 6e x)...;;. ((strin
6610: 67 3f 20 78 29 20 78 29 0a 09 09 3b 3b 09 20 28 g? x) x)...;;. (
6620: 65 6c 73 65 20 27 28 29 29 29 29 0a 09 09 3b 3b else '())))...;;
6630: 20 20 20 20 20 20 28 70 6f 72 74 2d 6d 61 70 20 (port-map
6640: 65 76 61 6c 20 28 6c 61 6d 62 64 61 20 28 29 28 eval (lambda ()(
6650: 72 65 61 64 20 70 29 29 29 29 29 29 0a 09 20 20 read p))))))..
6660: 3b 3b 20 28 6d 61 70 20 63 6c 6f 73 65 2d 69 6e ;; (map close-in
6670: 70 75 74 2d 70 6f 72 74 20 69 6e 70 73 29 0a 09 put-port inps)..
6680: 20 20 28 63 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 (close-input-p
6690: 6f 72 74 20 70 29 0a 09 20 20 64 61 74 29 0a 09 ort p).. dat)..
66a0: 28 6c 69 73 74 20 22 3c 70 3e 50 61 67 65 20 6e (list "<p>Page n
66b0: 6f 74 20 66 6f 75 6e 64 20 22 20 70 61 67 65 20 ot found " page
66c0: 22 20 3c 2f 70 3e 22 29 29 29 29 0a 0a 3b 3b 28 " </p>"))))..;;(
66d0: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
66e0: 63 61 6c 6c 20 73 65 6c 66 20 70 61 67 65 29 0a call self page).
66f0: 3b 3b 20 20 28 73 65 73 73 69 6f 6e 3a 63 61 6c ;; (session:cal
6700: 6c 2d 70 61 72 74 73 20 73 65 6c 66 20 70 61 67 l-parts self pag
6710: 65 20 27 62 6f 74 68 29 29 0a 0a 28 64 65 66 69 e 'both))..(defi
6720: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 63 61 6c 6c ne (session:call
6730: 20 73 65 6c 66 20 70 61 67 65 20 70 61 72 74 73 self page parts
6740: 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a 63 61 6c ). (session:cal
6750: 6c 2d 70 61 72 74 73 20 73 65 6c 66 20 70 61 67 l-parts self pag
6760: 65 20 27 62 6f 74 68 29 29 0a 0a 28 64 65 66 69 e 'both))..(defi
6770: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 61 64 ne (session:load
6780: 2d 6d 6f 64 65 6c 20 73 65 6c 66 20 6d 6f 64 65 -model self mode
6790: 6c 29 0a 20 20 28 6c 65 74 20 28 28 6d 6f 64 65 l). (let ((mode
67a0: 6c 2e 73 63 6d 20 28 73 74 72 69 6e 67 2d 61 70 l.scm (string-ap
67b0: 70 65 6e 64 20 28 73 64 61 74 2d 67 65 74 2d 73 pend (sdat-get-s
67c0: 72 6f 6f 74 20 73 65 6c 66 29 20 22 2f 6d 6f 64 root self) "/mod
67d0: 65 6c 73 2f 22 20 6d 6f 64 65 6c 20 22 2e 73 63 els/" model ".sc
67e0: 6d 22 29 29 0a 09 28 6d 6f 64 65 6c 2e 73 6f 20 m"))..(model.so
67f0: 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 (string-append
6800: 28 73 64 61 74 2d 67 65 74 2d 73 72 6f 6f 74 20 (sdat-get-sroot
6810: 73 65 6c 66 29 20 22 2f 6d 6f 64 65 6c 73 2f 22 self) "/models/"
6820: 20 6d 6f 64 65 6c 20 22 2e 73 6f 22 29 29 29 0a model ".so"))).
6830: 20 20 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 (if (file-ex
6840: 69 73 74 73 3f 20 6d 6f 64 65 6c 2e 73 6f 29 0a ists? model.so).
6850: 09 28 6c 6f 61 64 20 6d 6f 64 65 6c 2e 73 6f 29 .(load model.so)
6860: 0a 09 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 ..(if (file-exis
6870: 74 73 3f 20 6d 6f 64 65 6c 2e 73 63 6d 29 0a 09 ts? model.scm)..
6880: 20 20 20 20 28 6c 6f 61 64 20 6d 6f 64 65 6c 2e (load model.
6890: 73 63 6d 29 0a 09 20 20 20 20 28 73 3a 6c 6f 67 scm).. (s:log
68a0: 20 22 45 52 52 4f 52 3a 20 6d 6f 64 65 6c 20 22 "ERROR: model "
68b0: 20 6d 6f 64 65 6c 2e 73 63 6d 20 22 20 6e 6f 74 model.scm " not
68c0: 20 66 6f 75 6e 64 22 29 29 29 29 29 0a 0a 28 64 found")))))..(d
68d0: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 6d efine (session:m
68e0: 6f 64 65 6c 2d 70 61 74 68 20 73 65 6c 66 20 6d odel-path self m
68f0: 6f 64 65 6c 29 0a 20 20 28 73 74 72 69 6e 67 2d odel). (string-
6900: 61 70 70 65 6e 64 20 28 73 64 61 74 2d 67 65 74 append (sdat-get
6910: 2d 73 72 6f 6f 74 20 73 65 6c 66 29 20 22 2f 6d -sroot self) "/m
6920: 6f 64 65 6c 73 2f 22 20 6d 6f 64 65 6c 20 22 2e odels/" model ".
6930: 73 63 6d 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 scm"))..(define
6940: 28 73 65 73 73 69 6f 6e 3a 70 70 2d 66 6f 72 6d (session:pp-form
6950: 64 61 74 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 dat self). (let
6960: 20 28 28 64 61 74 20 28 66 6f 72 6d 64 61 74 3a ((dat (formdat:
6970: 61 6c 6c 2d 3e 73 74 72 69 6e 67 73 20 28 73 64 all->strings (sd
6980: 61 74 2d 67 65 74 2d 66 6f 72 6d 64 61 74 20 73 at-get-formdat s
6990: 65 6c 66 29 29 29 29 0a 20 20 20 20 28 73 74 72 elf)))). (str
69a0: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
69b0: 64 61 74 20 22 3c 62 72 3e 20 22 29 29 29 0a 0a dat "<br> ")))..
69c0: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
69d0: 3a 70 61 72 61 6d 2d 3e 73 74 72 69 6e 67 20 70 :param->string p
69e0: 61 72 61 6d 73 29 0a 20 20 3b 3b 20 28 65 72 72 arams). ;; (err
69f0: 3a 6c 6f 67 20 22 70 61 72 61 6d 73 3d 22 20 70 :log "params=" p
6a00: 61 72 61 6d 73 29 0a 20 20 28 69 66 20 28 3c 20 arams). (if (<
6a10: 28 6c 65 6e 67 74 68 20 70 61 72 61 6d 73 29 20 (length params)
6a20: 31 29 0a 20 20 20 20 20 20 22 22 0a 20 20 20 20 1). "".
6a30: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 6b 65 (let loop ((ke
6a40: 79 20 28 63 61 72 20 70 61 72 61 6d 73 29 29 0a y (car params)).
6a50: 09 09 20 28 76 61 6c 20 28 63 61 64 72 20 70 61 .. (val (cadr pa
6a60: 72 61 6d 73 29 29 0a 09 09 20 28 74 61 69 6c 20 rams))... (tail
6a70: 28 63 64 64 72 20 70 61 72 61 6d 73 29 29 0a 09 (cddr params))..
6a80: 09 20 28 72 65 73 75 6c 74 20 27 28 29 29 29 0a . (result '())).
6a90: 09 28 6c 65 74 20 28 28 6e 65 77 72 65 73 75 6c .(let ((newresul
6aa0: 74 20 28 63 6f 6e 73 20 28 73 74 72 69 6e 67 2d t (cons (string-
6ab0: 61 70 70 65 6e 64 20 28 73 3a 61 6e 79 2d 3e 73 append (s:any->s
6ac0: 74 72 69 6e 67 20 6b 65 79 29 20 22 3d 22 20 28 tring key) "=" (
6ad0: 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 76 61 s:any->string va
6ae0: 6c 29 29 0a 09 09 09 20 20 20 20 20 20 20 72 65 l)).... re
6af0: 73 75 6c 74 29 29 29 0a 09 20 20 28 69 66 20 28 sult))).. (if (
6b00: 3c 20 28 6c 65 6e 67 74 68 20 74 61 69 6c 29 20 < (length tail)
6b10: 31 29 20 3b 3b 20 74 72 75 65 20 69 66 20 64 6f 1) ;; true if do
6b20: 6e 65 0a 09 20 20 20 20 20 20 28 73 74 72 69 6e ne.. (strin
6b30: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 6e 65 g-intersperse ne
6b40: 77 72 65 73 75 6c 74 20 22 26 22 29 0a 09 20 20 wresult "&")..
6b50: 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 (loop (car t
6b60: 61 69 6c 29 28 63 61 64 72 20 74 61 69 6c 29 28 ail)(cadr tail)(
6b70: 63 64 64 72 20 74 61 69 6c 29 20 6e 65 77 72 65 cddr tail) newre
6b80: 73 75 6c 74 29 29 29 29 29 29 0a 0a 28 64 65 66 sult))))))..(def
6b90: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 6c 69 6e ine (session:lin
6ba0: 6b 2d 74 6f 20 73 65 6c 66 20 70 61 67 65 20 70 k-to self page p
6bb0: 61 72 61 6d 73 29 0a 20 20 28 6c 65 74 2a 20 28 arams). (let* (
6bc0: 28 73 65 72 76 65 72 20 20 20 20 28 69 66 20 28 (server (if (
6bd0: 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d get-environment-
6be0: 76 61 72 69 61 62 6c 65 20 22 48 54 54 50 5f 48 variable "HTTP_H
6bf0: 4f 53 54 22 29 0a 09 09 09 28 67 65 74 2d 65 6e OST")....(get-en
6c00: 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 vironment-variab
6c10: 6c 65 20 22 48 54 54 50 5f 48 4f 53 54 22 29 0a le "HTTP_HOST").
6c20: 09 09 09 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d ...(get-environm
6c30: 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 53 45 ent-variable "SE
6c40: 52 56 45 52 5f 4e 41 4d 45 22 29 29 29 0a 09 20 RVER_NAME")))..
6c50: 28 73 63 72 69 70 74 20 28 6c 65 74 20 28 28 73 (script (let ((s
6c60: 63 72 69 70 74 2d 6e 61 6d 65 20 28 73 74 72 69 cript-name (stri
6c70: 6e 67 2d 73 70 6c 69 74 20 28 67 65 74 2d 65 6e ng-split (get-en
6c80: 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 vironment-variab
6c90: 6c 65 20 22 53 43 52 49 50 54 5f 4e 41 4d 45 22 le "SCRIPT_NAME"
6ca0: 29 20 22 2f 22 29 29 29 0a 09 09 20 20 20 28 69 ) "/")))... (i
6cb0: 66 20 28 3e 20 28 6c 65 6e 67 74 68 20 73 63 72 f (> (length scr
6cc0: 69 70 74 2d 6e 61 6d 65 29 20 31 29 0a 09 09 20 ipt-name) 1)...
6cd0: 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 61 70 (string-ap
6ce0: 70 65 6e 64 20 28 63 61 72 20 73 63 72 69 70 74 pend (car script
6cf0: 2d 6e 61 6d 65 29 20 22 2f 22 20 28 63 61 64 72 -name) "/" (cadr
6d00: 20 73 63 72 69 70 74 2d 6e 61 6d 65 29 29 0a 09 script-name))..
6d10: 09 20 20 20 20 20 20 20 28 67 65 74 2d 65 6e 76 . (get-env
6d20: 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c ironment-variabl
6d30: 65 20 22 53 43 52 49 50 54 5f 4e 41 4d 45 22 29 e "SCRIPT_NAME")
6d40: 29 29 29 20 3b 3b 20 62 75 69 6c 64 20 73 63 72 ))) ;; build scr
6d50: 69 70 74 20 6e 61 6d 65 20 66 72 6f 6d 20 66 69 ipt name from fi
6d60: 72 73 74 20 74 77 6f 20 65 6c 65 6d 65 6e 74 73 rst two elements
6d70: 2e 20 54 68 69 73 20 69 73 20 61 20 68 61 6e 67 . This is a hang
6d80: 6f 76 65 72 20 66 72 6f 6d 20 62 65 66 6f 72 65 over from before
6d90: 20 49 20 75 73 65 64 20 3f 20 69 6e 20 74 68 65 I used ? in the
6da0: 20 55 52 4c 2e 0a 09 20 28 73 65 73 73 69 6f 6e URL... (session
6db0: 2d 6b 65 79 20 28 73 64 61 74 2d 67 65 74 2d 73 -key (sdat-get-s
6dc0: 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 ession-key self)
6dd0: 29 0a 09 20 28 70 61 72 61 6d 73 74 72 20 28 73 ).. (paramstr (s
6de0: 65 73 73 69 6f 6e 3a 70 61 72 61 6d 2d 3e 73 74 ession:param->st
6df0: 72 69 6e 67 20 70 61 72 61 6d 73 29 29 29 0a 20 ring params))).
6e00: 20 20 20 3b 3b 20 28 73 65 73 73 69 6f 6e 3a 6c ;; (session:l
6e10: 6f 67 20 73 65 6c 66 20 22 73 65 72 76 65 72 3d og self "server=
6e20: 22 20 73 65 72 76 65 72 20 22 20 73 63 72 69 70 " server " scrip
6e30: 74 3d 22 20 73 63 72 69 70 74 20 22 20 70 61 67 t=" script " pag
6e40: 65 3d 22 20 70 61 67 65 29 0a 20 20 20 20 28 73 e=" page). (s
6e50: 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 22 68 74 tring-append "ht
6e60: 74 70 3a 2f 2f 22 20 73 65 72 76 65 72 20 22 2f tp://" server "/
6e70: 22 20 73 63 72 69 70 74 20 22 2f 22 20 70 61 67 " script "/" pag
6e80: 65 20 22 3f 22 20 70 61 72 61 6d 73 74 72 29 29 e "?" paramstr))
6e90: 29 20 3b 3b 20 22 2f 73 6e 3d 22 20 73 65 73 73 ) ;; "/sn=" sess
6ea0: 69 6f 6e 2d 6b 65 79 29 29 29 0a 0a 28 64 65 66 ion-key)))..(def
6eb0: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 63 67 69 ine (session:cgi
6ec0: 2d 6f 75 74 20 73 65 6c 66 29 0a 20 20 28 6c 65 -out self). (le
6ed0: 74 2a 20 28 28 63 6f 6e 74 65 6e 74 20 20 28 6c t* ((content (l
6ee0: 69 73 74 20 28 73 64 61 74 2d 67 65 74 2d 63 6f ist (sdat-get-co
6ef0: 6e 74 65 6e 74 2d 74 79 70 65 20 73 65 6c 66 29 ntent-type self)
6f00: 29 29 20 3b 3b 20 27 28 22 43 6f 6e 74 65 6e 74 )) ;; '("Content
6f10: 2d 74 79 70 65 3a 20 74 65 78 74 2f 68 74 6d 6c -type: text/html
6f20: 3b 20 63 68 61 72 73 65 74 3d 69 73 6f 2d 38 38 ; charset=iso-88
6f30: 35 39 2d 31 5c 6e 5c 6e 22 29 29 0a 09 20 28 68 59-1\n\n")).. (h
6f40: 65 61 64 65 72 20 20 20 28 6c 65 74 20 28 28 63 eader (let ((c
6f50: 6f 6f 6b 69 65 20 28 73 64 61 74 2d 67 65 74 2d ookie (sdat-get-
6f60: 73 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 20 73 session-cookie s
6f70: 65 6c 66 29 29 29 0a 09 09 20 20 20 20 20 28 69 elf)))... (i
6f80: 66 20 63 6f 6f 6b 69 65 0a 09 09 09 20 28 63 6f f cookie.... (co
6f90: 6e 73 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e ns (string-appen
6fa0: 64 20 22 53 65 74 2d 43 6f 6f 6b 69 65 3a 20 22 d "Set-Cookie: "
6fb0: 20 28 63 61 72 20 63 6f 6f 6b 69 65 29 29 0a 09 (car cookie))..
6fc0: 09 09 20 20 20 20 20 20 20 63 6f 6e 74 65 6e 74 .. content
6fd0: 29 0a 09 09 09 20 63 6f 6e 74 65 6e 74 29 29 29 ).... content)))
6fe0: 0a 09 20 28 70 61 67 65 64 61 74 20 20 28 73 64 .. (pagedat (sd
6ff0: 61 74 2d 67 65 74 2d 70 61 67 65 64 61 74 20 73 at-get-pagedat s
7000: 65 6c 66 29 29 29 0a 20 20 20 20 28 73 3a 63 67 elf))). (s:cg
7010: 69 2d 6f 75 74 20 0a 20 20 20 20 20 28 63 6f 6e i-out . (con
7020: 73 20 68 65 61 64 65 72 20 70 61 67 65 64 61 74 s header pagedat
7030: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 ))))..(define (s
7040: 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 ession:log self
7050: 2e 20 6d 73 67 29 0a 20 20 28 77 69 74 68 2d 6f . msg). (with-o
7060: 75 74 70 75 74 2d 74 6f 2d 70 6f 72 74 20 28 73 utput-to-port (s
7070: 64 61 74 2d 67 65 74 2d 6c 6f 67 2d 70 6f 72 74 dat-get-log-port
7080: 20 73 65 6c 66 29 20 3b 3b 20 28 73 64 61 74 2d self) ;; (sdat-
7090: 67 65 74 2d 6c 6f 67 70 74 20 73 65 6c 66 29 0a get-logpt self).
70a0: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 20 0a (lambda () .
70b0: 20 20 20 20 20 20 28 61 70 70 6c 79 20 70 72 69 (apply pri
70c0: 6e 74 20 6d 73 67 29 29 29 29 0a 0a 28 64 65 66 nt msg))))..(def
70d0: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 ine (session:get
70e0: 2d 70 61 72 61 6d 20 73 65 6c 66 20 6b 65 79 29 -param self key)
70f0: 0a 20 20 3b 3b 20 28 73 65 73 73 69 6f 6e 3a 6c . ;; (session:l
7100: 6f 67 20 73 3a 73 65 73 73 69 6f 6e 20 22 70 61 og s:session "pa
7110: 72 61 6d 73 3d 22 20 28 73 6c 6f 74 2d 72 65 66 rams=" (slot-ref
7120: 20 73 3a 73 65 73 73 69 6f 6e 20 27 70 61 72 61 s:session 'para
7130: 6d 73 29 29 0a 20 20 28 6c 65 74 20 28 28 70 61 ms)). (let ((pa
7140: 72 61 6d 73 20 28 73 64 61 74 2d 67 65 74 2d 70 rams (sdat-get-p
7150: 61 72 61 6d 73 20 73 65 6c 66 29 29 29 0a 20 20 arams self))).
7160: 20 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 (session:get-p
7170: 61 72 61 6d 2d 66 72 6f 6d 20 70 61 72 61 6d 73 aram-from params
7180: 20 6b 65 79 29 29 29 0a 0a 3b 3b 20 54 68 69 73 key)))..;; This
7190: 20 6f 6e 65 20 77 69 6c 6c 20 67 65 74 20 74 68 one will get th
71a0: 65 20 66 69 72 73 74 20 76 61 6c 75 65 20 66 6f e first value fo
71b0: 75 6e 64 20 72 65 67 61 72 64 6c 65 73 73 20 6f und regardless o
71c0: 66 20 66 6f 72 6d 0a 28 64 65 66 69 6e 65 20 28 f form.(define (
71d0: 73 65 73 73 69 6f 6e 3a 67 65 74 2d 69 6e 70 75 session:get-inpu
71e0: 74 20 73 65 6c 66 20 6b 65 79 29 0a 20 20 28 6c t self key). (l
71f0: 65 74 2a 20 28 28 66 6f 72 6d 64 61 74 20 28 73 et* ((formdat (s
7200: 64 61 74 2d 67 65 74 2d 66 6f 72 6d 64 61 74 20 dat-get-formdat
7210: 73 65 6c 66 29 29 29 0a 20 20 20 20 28 69 66 20 self))). (if
7220: 28 6e 6f 74 20 66 6f 72 6d 64 61 74 29 20 23 66 (not formdat) #f
7230: 0a 09 28 69 66 20 28 6f 72 20 28 73 74 72 69 6e ..(if (or (strin
7240: 67 3f 20 6b 65 79 29 28 6e 75 6d 62 65 72 3f 20 g? key)(number?
7250: 6b 65 79 29 28 73 79 6d 62 6f 6c 3f 20 6b 65 79 key)(symbol? key
7260: 29 29 0a 09 20 20 20 20 28 69 66 20 28 65 71 3f )).. (if (eq?
7270: 20 28 63 6c 61 73 73 2d 6f 66 20 66 6f 72 6d 64 (class-of formd
7280: 61 74 29 20 3c 66 6f 72 6d 64 61 74 3e 29 0a 09 at) <formdat>)..
7290: 09 28 66 6f 72 6d 64 61 74 3a 67 65 74 20 66 6f .(formdat:get fo
72a0: 72 6d 64 61 74 20 6b 65 79 29 0a 09 09 28 62 65 rmdat key)...(be
72b0: 67 69 6e 0a 09 09 20 20 28 73 65 73 73 69 6f 6e gin... (session
72c0: 3a 6c 6f 67 20 73 65 6c 66 20 22 45 52 52 4f 52 :log self "ERROR
72d0: 3a 20 66 6f 72 6d 64 61 74 3a 20 22 20 66 6f 72 : formdat: " for
72e0: 6d 64 61 74 20 22 20 69 73 20 6e 6f 74 20 6f 66 mdat " is not of
72f0: 20 63 6c 61 73 73 20 3c 66 6f 72 6d 64 61 74 3e class <formdat>
7300: 22 29 0a 09 09 20 20 23 66 29 29 0a 09 20 20 20 ")... #f))..
7310: 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 (session:log se
7320: 6c 66 20 22 45 52 52 4f 52 3a 20 62 61 64 20 6b lf "ERROR: bad k
7330: 65 79 20 22 20 6b 65 79 29 29 29 29 29 0a 0a 28 ey " key)))))..(
7340: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
7350: 72 75 6e 2d 61 63 74 69 6f 6e 73 20 73 65 6c 66 run-actions self
7360: 29 0a 20 20 28 6c 65 74 2a 20 28 28 61 63 74 69 ). (let* ((acti
7370: 6f 6e 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 67 on (session:g
7380: 65 74 2d 70 61 72 61 6d 20 73 65 6c 66 20 27 61 et-param self 'a
7390: 63 74 69 6f 6e 29 29 0a 09 20 28 70 61 67 65 20 ction)).. (page
73a0: 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d 70 (sdat-get-p
73b0: 61 67 65 20 73 65 6c 66 29 29 29 0a 20 20 20 20 age self))).
73c0: 3b 3b 20 28 70 72 69 6e 74 20 22 61 63 74 69 6f ;; (print "actio
73d0: 6e 3d 22 20 61 63 74 69 6f 6e 20 22 20 70 61 67 n=" action " pag
73e0: 65 3d 22 20 70 61 67 65 29 0a 20 20 20 20 28 69 e=" page). (i
73f0: 66 20 61 63 74 69 6f 6e 0a 09 28 6c 65 74 20 28 f action..(let (
7400: 28 61 63 74 69 6f 6e 2d 6c 73 74 20 20 28 73 74 (action-lst (st
7410: 72 69 6e 67 2d 73 70 6c 69 74 20 61 63 74 69 6f ring-split actio
7420: 6e 20 22 2e 22 29 29 29 0a 09 20 20 3b 3b 20 28 n "."))).. ;; (
7430: 70 72 69 6e 74 20 22 61 63 74 69 6f 6e 2d 6c 73 print "action-ls
7440: 74 3d 22 20 61 63 74 69 6f 6e 2d 6c 73 74 29 0a t=" action-lst).
7450: 09 20 20 28 69 66 20 28 6e 6f 74 20 28 3d 20 28 . (if (not (= (
7460: 6c 65 6e 67 74 68 20 61 63 74 69 6f 6e 2d 6c 73 length action-ls
7470: 74 29 20 32 29 29 20 0a 09 20 20 20 20 20 20 28 t) 2)) .. (
7480: 65 72 72 3a 6c 6f 67 20 22 41 63 74 69 6f 6e 20 err:log "Action
7490: 73 68 6f 75 6c 64 20 62 65 20 6f 66 20 66 6f 72 should be of for
74a0: 6d 3a 20 6d 6f 64 75 6c 65 2e 61 63 74 69 6f 6e m: module.action
74b0: 22 29 0a 09 20 20 20 20 20 20 28 6c 65 74 2a 20 ").. (let*
74c0: 28 28 74 61 72 67 2d 70 61 67 65 20 20 20 28 63 ((targ-page (c
74d0: 61 72 20 61 63 74 69 6f 6e 2d 6c 73 74 29 29 0a ar action-lst)).
74e0: 09 09 20 20 20 20 20 28 70 72 6f 63 2d 6e 61 6d .. (proc-nam
74f0: 65 20 20 20 28 73 74 72 69 6e 67 2d 61 70 70 65 e (string-appe
7500: 6e 64 20 74 61 72 67 2d 70 61 67 65 20 22 2d 61 nd targ-page "-a
7510: 63 74 69 6f 6e 22 29 29 0a 09 09 20 20 20 20 20 ction"))...
7520: 28 74 61 72 67 2d 61 63 74 69 6f 6e 20 28 63 61 (targ-action (ca
7530: 64 72 20 61 63 74 69 6f 6e 2d 6c 73 74 29 29 29 dr action-lst)))
7540: 0a 09 09 3b 3b 20 28 65 72 72 3a 6c 6f 67 20 22 ...;; (err:log "
7550: 74 61 72 67 2d 70 61 67 65 3d 22 20 74 61 72 67 targ-page=" targ
7560: 2d 70 61 67 65 20 22 20 70 72 6f 63 2d 6e 61 6d -page " proc-nam
7570: 65 3d 22 20 70 72 6f 63 2d 6e 61 6d 65 20 22 20 e=" proc-name "
7580: 74 61 72 67 2d 61 63 74 69 6f 6e 3d 22 20 74 61 targ-action=" ta
7590: 72 67 2d 61 63 74 69 6f 6e 29 0a 0a 09 09 3b 3b rg-action)....;;
75a0: 20 63 61 6c 6c 20 68 65 72 65 20 6f 6e 6c 79 20 call here only
75b0: 69 66 20 6e 65 76 65 72 20 63 61 6c 6c 65 64 20 if never called
75c0: 62 65 66 6f 72 65 0a 09 09 28 69 66 20 28 73 65 before...(if (se
75d0: 73 73 69 6f 6e 3a 6e 65 76 65 72 2d 63 61 6c 6c ssion:never-call
75e0: 65 64 2d 70 61 67 65 3f 20 73 65 6c 66 20 74 61 ed-page? self ta
75f0: 72 67 2d 70 61 67 65 29 0a 09 09 20 20 20 20 28 rg-page)... (
7600: 73 65 73 73 69 6f 6e 3a 63 61 6c 6c 2d 70 61 72 session:call-par
7610: 74 73 20 73 65 6c 66 20 74 61 72 67 2d 70 61 67 ts self targ-pag
7620: 65 20 27 63 6f 6e 74 72 6f 6c 29 29 0a 09 09 3b e 'control))...;
7630: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
7640: 20 20 20 20 20 70 72 6f 63 20 20 20 20 20 20 20 proc
7650: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7660: 20 20 61 63 74 69 6f 6e 20 20 20 20 0a 0a 09 09 action ....
7670: 28 69 66 20 23 74 20 3b 3b 20 73 65 74 20 74 6f (if #t ;; set to
7680: 20 23 74 20 74 6f 20 73 65 65 20 62 65 74 74 65 #t to see bette
7690: 72 20 65 72 72 6f 72 20 6d 65 73 73 61 67 65 73 r error messages
76a0: 20 64 75 72 69 6e 67 20 64 65 62 75 67 67 69 6e during debuggin
76b0: 20 3a 2d 29 0a 09 09 20 20 20 20 28 28 65 76 61 :-)... ((eva
76c0: 6c 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f l (string->symbo
76d0: 6c 20 70 72 6f 63 2d 6e 61 6d 65 29 29 20 74 61 l proc-name)) ta
76e0: 72 67 2d 61 63 74 69 6f 6e 29 20 3b 3b 20 75 6e rg-action) ;; un
76f0: 73 61 66 65 20 65 78 65 63 75 74 69 6f 6e 0a 09 safe execution..
7700: 09 20 20 20 20 28 63 6f 6e 64 69 74 69 6f 6e 2d . (condition-
7710: 63 61 73 65 20 28 28 65 76 61 6c 20 28 73 74 72 case ((eval (str
7720: 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 70 72 6f 63 ing->symbol proc
7730: 2d 6e 61 6d 65 29 29 20 74 61 72 67 2d 61 63 74 -name)) targ-act
7740: 69 6f 6e 29 0a 09 09 09 09 20 20 20 20 28 28 65 ion)..... ((e
7750: 78 6e 20 66 69 6c 65 29 20 28 73 3a 6c 6f 67 20 xn file) (s:log
7760: 22 66 69 6c 65 20 65 72 72 6f 72 22 29 29 0a 09 "file error"))..
7770: 09 09 09 20 20 20 20 28 28 65 78 6e 20 69 2f 6f ... ((exn i/o
7780: 29 20 20 28 73 3a 6c 6f 67 20 22 69 2f 6f 20 65 ) (s:log "i/o e
7790: 72 72 6f 72 22 29 29 0a 09 09 09 09 20 20 20 20 rror")).....
77a0: 28 28 65 78 6e 20 29 20 20 20 20 20 28 73 3a 6c ((exn ) (s:l
77b0: 6f 67 20 22 41 63 74 69 6f 6e 20 6e 6f 74 20 69 og "Action not i
77c0: 6d 70 6c 65 6d 65 6e 74 65 64 3a 20 22 20 70 72 mplemented: " pr
77d0: 6f 63 2d 6e 61 6d 65 20 22 20 61 63 74 69 6f 6e oc-name " action
77e0: 3a 20 22 20 74 61 72 67 2d 61 63 74 69 6f 6e 29 : " targ-action)
77f0: 29 0a 09 09 09 09 20 20 20 20 28 76 61 72 20 28 )..... (var (
7800: 29 20 20 20 20 20 28 73 3a 6c 6f 67 20 22 55 6e ) (s:log "Un
7810: 6b 6e 6f 77 6e 20 45 72 72 6f 72 22 29 29 29 29 known Error"))))
7820: 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ))))))..(define
7830: 28 73 65 73 73 69 6f 6e 3a 6e 65 76 65 72 2d 63 (session:never-c
7840: 61 6c 6c 65 64 2d 70 61 67 65 3f 20 73 65 6c 66 alled-page? self
7850: 20 70 61 67 65 29 0a 20 20 28 73 65 73 73 69 6f page). (sessio
7860: 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 43 68 65 63 n:log self "Chec
7870: 6b 69 6e 67 20 66 6f 72 20 70 61 67 65 3a 20 22 king for page: "
7880: 20 70 61 67 65 29 0a 20 20 28 6e 6f 74 20 28 6d page). (not (m
7890: 65 6d 62 65 72 20 70 61 67 65 20 28 73 64 61 74 ember page (sdat
78a0: 2d 67 65 74 2d 73 65 65 6e 2d 70 61 67 65 73 20 -get-seen-pages
78b0: 73 65 6c 66 29 29 29 29 0a 0a 28 64 65 66 69 6e self))))..(defin
78c0: 65 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 2d 63 e (session:set-c
78d0: 61 6c 6c 65 64 21 20 73 65 6c 66 20 70 61 67 65 alled! self page
78e0: 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 ). (sdat-set-se
78f0: 65 6e 2d 70 61 67 65 73 21 20 73 65 6c 66 20 28 en-pages! self (
7900: 63 6f 6e 73 20 70 61 67 65 20 28 73 64 61 74 2d cons page (sdat-
7910: 67 65 74 2d 73 65 65 6e 2d 70 61 67 65 73 20 73 get-seen-pages s
7920: 65 6c 66 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d elf))))..;;=====
7930: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7940: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7950: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7960: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7970: 3d 0a 3b 3b 20 41 6c 74 65 72 6e 61 74 69 76 65 =.;; Alternative
7980: 20 64 61 74 61 20 74 79 70 65 20 64 65 6c 69 76 data type deliv
7990: 65 72 79 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ery.;;==========
79a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
79b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
79c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
79d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 ============..(d
79e0: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 61 efine (session:a
79f0: 6c 74 2d 6f 75 74 20 73 65 6c 66 29 0a 20 20 28 lt-out self). (
7a00: 6c 65 74 20 28 28 64 61 74 20 28 73 64 61 74 2d let ((dat (sdat-
7a10: 67 65 74 2d 61 6c 74 2d 70 61 67 65 2d 64 61 74 get-alt-page-dat
7a20: 20 73 65 6c 66 29 29 29 0a 20 20 20 20 3b 3b 20 self))). ;;
7a30: 28 73 3a 6c 6f 67 20 22 64 61 74 20 69 73 3a 20 (s:log "dat is:
7a40: 22 20 64 61 74 29 0a 20 20 20 20 3b 3b 20 28 70 " dat). ;; (p
7a50: 72 69 6e 74 20 22 48 54 54 50 2f 31 2e 31 20 32 rint "HTTP/1.1 2
7a60: 30 30 20 4f 4b 22 29 0a 20 20 20 20 28 70 72 69 00 OK"). (pri
7a70: 6e 74 20 22 44 61 74 65 3a 20 22 20 28 74 69 6d nt "Date: " (tim
7a80: 65 2d 3e 73 74 72 69 6e 67 20 28 73 65 63 6f 6e e->string (secon
7a90: 64 73 2d 3e 75 74 63 2d 74 69 6d 65 20 28 63 75 ds->utc-time (cu
7aa0: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 rrent-seconds)))
7ab0: 29 0a 20 20 20 20 28 70 72 69 6e 74 20 22 43 6f ). (print "Co
7ac0: 6e 74 65 6e 74 2d 54 79 70 65 3a 20 22 20 28 73 ntent-Type: " (s
7ad0: 64 61 74 2d 67 65 74 2d 63 6f 6e 74 65 6e 74 2d dat-get-content-
7ae0: 74 79 70 65 20 73 65 6c 66 29 29 0a 20 20 20 20 type self)).
7af0: 28 70 72 69 6e 74 20 22 41 63 63 65 70 74 2d 52 (print "Accept-R
7b00: 61 6e 67 65 73 3a 20 62 79 74 65 73 22 29 0a 20 anges: bytes").
7b10: 20 20 20 28 70 72 69 6e 74 20 22 43 6f 6e 74 65 (print "Conte
7b20: 6e 74 2d 4c 65 6e 67 74 68 3a 20 22 20 28 69 66 nt-Length: " (if
7b30: 20 28 62 6c 6f 62 3f 20 64 61 74 29 0a 09 09 09 (blob? dat)....
7b40: 09 20 20 28 62 6c 6f 62 2d 73 69 7a 65 20 64 61 . (blob-size da
7b50: 74 29 0a 09 09 09 09 20 20 30 29 29 0a 20 20 20 t)..... 0)).
7b60: 20 28 70 72 69 6e 74 20 22 4b 65 65 70 2d 41 6c (print "Keep-Al
7b70: 69 76 65 3a 20 74 69 6d 65 6f 75 74 3d 31 35 2c ive: timeout=15,
7b80: 20 6d 61 78 3d 31 30 30 22 29 0a 20 20 20 20 28 max=100"). (
7b90: 70 72 69 6e 74 20 22 43 6f 6e 6e 65 63 74 69 6f print "Connectio
7ba0: 6e 3a 20 4b 65 65 70 2d 41 6c 69 76 65 22 29 0a n: Keep-Alive").
7bb0: 20 20 20 20 28 70 72 69 6e 74 20 22 22 29 0a 20 (print "").
7bc0: 20 20 20 28 77 72 69 74 65 2d 73 74 72 69 6e 67 (write-string
7bd0: 20 28 62 6c 6f 62 2d 3e 73 74 72 69 6e 67 20 64 (blob->string d
7be0: 61 74 29 20 23 66 20 28 63 75 72 72 65 6e 74 2d at) #f (current-
7bf0: 6f 75 74 70 75 74 2d 70 6f 72 74 29 29 29 29 0a output-port)))).