Artifact
d1e5e815432155e7d1f21013f38e46dae08c3c55:
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 3b 3b 20 28 72 65 71 75 69 72 65 2d 6c )).;; (require-l
0170: 69 62 72 61 72 79 20 64 62 69 29 0a 28 75 73 65 ibrary dbi).(use
0180: 20 64 62 69 29 0a 28 69 6d 70 6f 72 74 20 28 70 dbi).(import (p
0190: 72 65 66 69 78 20 64 62 69 20 64 62 69 3a 29 29 refix dbi dbi:))
01a0: 0a 28 72 65 71 75 69 72 65 2d 65 78 74 65 6e 73 .(require-extens
01b0: 69 6f 6e 20 72 65 67 65 78 29 0a 28 64 65 63 6c ion regex).(decl
01c0: 61 72 65 20 28 75 73 65 73 20 63 6f 6f 6b 69 65 are (uses cookie
01d0: 29 29 0a 0a 3b 3b 20 73 65 73 73 69 6f 6e 73 20 ))..;; sessions
01e0: 74 61 62 6c 65 0a 3b 3b 20 69 64 20 73 65 73 73 table.;; id sess
01f0: 69 6f 6e 5f 69 64 20 73 65 73 73 69 6f 6e 5f 6b ion_id session_k
0200: 65 79 0a 3b 3b 20 63 72 65 61 74 65 20 74 61 62 ey.;; create tab
0210: 6c 65 20 73 65 73 73 69 6f 6e 73 20 28 69 64 20 le sessions (id
0220: 73 65 72 69 61 6c 20 6e 6f 74 20 6e 75 6c 6c 2c serial not null,
0230: 73 65 73 73 69 6f 6e 2d 6b 65 79 20 74 65 78 74 session-key text
0240: 29 3b 0a 0a 3b 3b 20 73 65 73 73 69 6f 6e 5f 76 );..;; session_v
0250: 61 72 73 20 74 61 62 6c 65 0a 3b 3b 20 69 64 20 ars table.;; id
0260: 73 65 73 73 69 6f 6e 5f 69 64 20 70 61 67 65 5f session_id page_
0270: 69 64 20 6b 65 79 20 76 61 6c 75 65 0a 3b 3b 20 id key value.;;
0280: 63 72 65 61 74 65 20 74 61 62 6c 65 20 73 65 73 create table ses
0290: 73 69 6f 6e 5f 76 61 72 73 20 28 69 64 20 73 65 sion_vars (id se
02a0: 72 69 61 6c 20 6e 6f 74 20 6e 75 6c 6c 2c 73 65 rial not null,se
02b0: 73 73 69 6f 6e 5f 69 64 20 69 6e 74 65 67 65 72 ssion_id integer
02c0: 2c 70 61 67 65 20 74 65 78 74 2c 6b 65 79 20 74 ,page text,key t
02d0: 65 78 74 2c 76 61 6c 75 65 20 74 65 78 74 29 3b ext,value text);
02e0: 0a 0a 3b 3b 20 54 4f 44 4f 0a 3b 3b 20 20 43 6f ..;; TODO.;; Co
02f0: 6e 63 65 70 74 20 6f 66 20 6f 72 64 65 72 20 6e ncept of order n
0300: 75 6d 20 69 6e 63 72 65 6d 65 6e 74 65 64 20 77 um incremented w
0310: 69 74 68 20 65 61 63 68 20 70 61 67 65 20 61 63 ith each page ac
0320: 63 65 73 73 0a 3b 3b 20 20 20 20 20 69 66 20 61 cess.;; if a
0330: 20 62 72 61 6e 63 68 20 69 73 20 74 61 6b 65 6e branch is taken
0340: 20 74 68 65 6e 20 61 20 6e 65 77 20 73 65 73 73 then a new sess
0350: 69 6f 6e 20 77 6f 75 6c 64 20 6e 65 65 64 20 74 ion would need t
0360: 6f 20 62 65 20 63 72 65 61 74 65 64 0a 3b 3b 0a o be created.;;.
0370: 0a 3b 3b 20 6d 61 6b 65 2d 76 65 63 74 6f 72 2d .;; make-vector-
0380: 72 65 63 6f 72 64 20 73 65 73 73 69 6f 6e 20 73 record session s
0390: 65 73 73 69 6f 6e 20 64 62 74 79 70 65 20 64 62 ession dbtype db
03a0: 69 6e 69 74 20 63 6f 6e 6e 20 70 61 72 61 6d 73 init conn params
03b0: 20 70 61 74 68 2d 70 61 72 61 6d 73 20 73 65 73 path-params ses
03c0: 73 69 6f 6e 2d 6b 65 79 20 73 65 73 73 69 6f 6e sion-key session
03d0: 2d 69 64 20 64 6f 6d 61 69 6e 20 74 6f 70 70 61 -id domain toppa
03e0: 67 65 20 70 61 67 65 20 63 75 72 72 2d 70 61 67 ge page curr-pag
03f0: 65 20 63 6f 6e 74 65 6e 74 2d 74 79 70 65 20 70 e content-type p
0400: 61 67 65 2d 74 79 70 65 20 73 72 6f 6f 74 20 74 age-type sroot t
0410: 77 69 6b 69 64 69 72 20 70 61 67 65 64 61 74 20 wikidir pagedat
0420: 61 6c 74 2d 70 61 67 65 2d 64 61 74 20 70 61 67 alt-page-dat pag
0430: 65 76 61 72 73 20 70 61 67 65 76 61 72 73 2d 62 evars pagevars-b
0440: 65 66 6f 72 65 20 73 65 73 73 69 6f 6e 76 61 72 efore sessionvar
0450: 73 20 73 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 s sessionvars-be
0460: 66 6f 72 65 20 67 6c 6f 62 61 6c 76 61 72 73 20 fore globalvars
0470: 67 6c 6f 62 61 6c 76 61 72 73 2d 62 65 66 6f 72 globalvars-befor
0480: 65 20 6c 6f 67 70 74 20 66 6f 72 6d 64 61 74 20 e logpt formdat
0490: 72 65 71 75 65 73 74 2d 6d 65 74 68 6f 64 20 73 request-method s
04a0: 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 20 63 75 ession-cookie cu
04b0: 72 72 2d 65 72 72 20 6c 6f 67 2d 70 6f 72 74 20 rr-err log-port
04c0: 6c 6f 67 66 69 6c 65 20 73 65 65 6e 2d 70 61 67 logfile seen-pag
04d0: 65 73 20 70 61 67 65 2d 64 69 72 2d 73 74 79 6c es page-dir-styl
04e0: 65 20 64 65 62 75 67 6d 6f 64 65 0a 28 64 65 66 e debugmode.(def
04f0: 69 6e 65 20 28 6d 61 6b 65 2d 73 64 61 74 29 28 ine (make-sdat)(
0500: 6d 61 6b 65 2d 76 65 63 74 6f 72 20 33 34 29 29 make-vector 34))
0510: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 .(define (sdat-g
0520: 65 74 2d 64 62 74 79 70 65 20 20 20 20 20 20 20 et-dbtype
0530: 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 vec)
0540: 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 (vector-ref vec
0550: 20 30 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 0)).(define (sd
0560: 61 74 2d 67 65 74 2d 64 62 69 6e 69 74 20 20 20 at-get-dbinit
0570: 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 29 vec)
0580: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
0590: 20 76 65 63 20 31 29 29 0a 28 64 65 66 69 6e 65 vec 1)).(define
05a0: 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 (sdat-get-conn
05b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
05c0: 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d vec) (vector-
05d0: 72 65 66 20 20 76 65 63 20 32 29 29 0a 28 64 65 ref vec 2)).(de
05e0: 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 70 fine (sdat-get-p
05f0: 67 63 6f 6e 6e 20 20 20 20 20 20 20 20 20 20 20 gconn
0600: 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 vec) (vec
0610: 74 6f 72 2d 72 65 66 20 28 76 65 63 74 6f 72 2d tor-ref (vector-
0620: 72 65 66 20 76 65 63 20 32 29 20 31 29 29 0a 28 ref vec 2) 1)).(
0630: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 define (sdat-get
0640: 2d 70 61 72 61 6d 73 20 20 20 20 20 20 20 20 20 -params
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 33 ector-ref vec 3
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 70 61 74 68 2d 70 61 72 61 6d 73 -get-path-params
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 34 29 29 0a 28 64 65 66 69 6e 65 20 28 ec 4)).(define (
06c0: 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e sdat-get-session
06d0: 2d 6b 65 79 20 20 20 20 20 20 20 20 20 20 76 65 -key 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 35 29 29 0a 28 64 65 66 69 f vec 5)).(defi
0700: 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 ne (sdat-get-ses
0710: 73 69 6f 6e 2d 69 64 20 20 20 20 20 20 20 20 20 sion-id
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 36 29 29 0a 28 r-ref vec 6)).(
0740: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 define (sdat-get
0750: 2d 64 6f 6d 61 69 6e 20 20 20 20 20 20 20 20 20 -domain
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 37 ector-ref vec 7
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 74 6f 70 70 61 67 65 20 20 20 20 -get-toppage
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 38 29 29 0a 28 64 65 66 69 6e 65 20 28 ec 8)).(define (
07d0: 73 64 61 74 2d 67 65 74 2d 70 61 67 65 20 20 20 sdat-get-page
07e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 ve
07f0: 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 c) (vector-re
0800: 66 20 20 76 65 63 20 39 29 29 0a 28 64 65 66 69 f vec 9)).(defi
0810: 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 63 75 72 ne (sdat-get-cur
0820: 72 2d 70 61 67 65 20 20 20 20 20 20 20 20 20 20 r-page
0830: 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f vec) (vecto
0840: 72 2d 72 65 66 20 20 76 65 63 20 31 30 29 29 0a r-ref vec 10)).
0850: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 (define (sdat-ge
0860: 74 2d 63 6f 6e 74 65 6e 74 2d 74 79 70 65 20 20 t-content-type
0870: 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 vec) (
0880: 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 vector-ref vec
0890: 31 31 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 11)).(define (sd
08a0: 61 74 2d 67 65 74 2d 70 61 67 65 2d 74 79 70 65 at-get-page-type
08b0: 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 29 vec)
08c0: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
08d0: 20 76 65 63 20 31 32 29 29 0a 28 64 65 66 69 6e vec 12)).(defin
08e0: 65 20 28 73 64 61 74 2d 67 65 74 2d 73 72 6f 6f e (sdat-get-sroo
08f0: 74 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 t
0900: 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 vec) (vector
0910: 2d 72 65 66 20 20 76 65 63 20 31 33 29 29 0a 28 -ref vec 13)).(
0920: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 define (sdat-get
0930: 2d 74 77 69 6b 69 64 69 72 20 20 20 20 20 20 20 -twikidir
0940: 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 vec) (v
0950: 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 31 ector-ref vec 1
0960: 34 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 4)).(define (sda
0970: 74 2d 67 65 74 2d 70 61 67 65 64 61 74 20 20 20 t-get-pagedat
0980: 20 20 20 20 20 20 20 20 20 20 20 76 65 63 29 20 vec)
0990: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 (vector-ref
09a0: 76 65 63 20 31 35 29 29 0a 28 64 65 66 69 6e 65 vec 15)).(define
09b0: 20 28 73 64 61 74 2d 67 65 74 2d 61 6c 74 2d 70 (sdat-get-alt-p
09c0: 61 67 65 2d 64 61 74 20 20 20 20 20 20 20 20 20 age-dat
09d0: 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d vec) (vector-
09e0: 72 65 66 20 20 76 65 63 20 31 36 29 29 0a 28 64 ref vec 16)).(d
09f0: 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d efine (sdat-get-
0a00: 70 61 67 65 76 61 72 73 20 20 20 20 20 20 20 20 pagevars
0a10: 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 vec) (ve
0a20: 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 31 37 ctor-ref vec 17
0a30: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
0a40: 2d 67 65 74 2d 70 61 67 65 76 61 72 73 2d 62 65 -get-pagevars-be
0a50: 66 6f 72 65 20 20 20 20 20 20 76 65 63 29 20 20 fore vec)
0a60: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 (vector-ref v
0a70: 65 63 20 31 38 29 29 0a 28 64 65 66 69 6e 65 20 ec 18)).(define
0a80: 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f (sdat-get-sessio
0a90: 6e 76 61 72 73 20 20 20 20 20 20 20 20 20 20 76 nvars v
0aa0: 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 ec) (vector-r
0ab0: 65 66 20 20 76 65 63 20 31 39 29 29 0a 28 64 65 ef vec 19)).(de
0ac0: 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 73 fine (sdat-get-s
0ad0: 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 essionvars-befor
0ae0: 65 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 e vec) (vec
0af0: 74 6f 72 2d 72 65 66 20 20 76 65 63 20 32 30 29 tor-ref vec 20)
0b00: 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d ).(define (sdat-
0b10: 67 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 20 20 get-globalvars
0b20: 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 vec)
0b30: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 (vector-ref ve
0b40: 63 20 32 31 29 29 0a 28 64 65 66 69 6e 65 20 28 c 21)).(define (
0b50: 73 64 61 74 2d 67 65 74 2d 67 6c 6f 62 61 6c 76 sdat-get-globalv
0b60: 61 72 73 2d 62 65 66 6f 72 65 20 20 20 20 76 65 ars-before ve
0b70: 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 c) (vector-re
0b80: 66 20 20 76 65 63 20 32 32 29 29 0a 28 64 65 66 f vec 22)).(def
0b90: 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 6c 6f ine (sdat-get-lo
0ba0: 67 70 74 20 20 20 20 20 20 20 20 20 20 20 20 20 gpt
0bb0: 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 vec) (vect
0bc0: 6f 72 2d 72 65 66 20 20 76 65 63 20 32 33 29 29 or-ref vec 23))
0bd0: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 .(define (sdat-g
0be0: 65 74 2d 66 6f 72 6d 64 61 74 20 20 20 20 20 20 et-formdat
0bf0: 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 vec)
0c00: 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 (vector-ref vec
0c10: 20 32 34 29 29 0a 28 64 65 66 69 6e 65 20 28 73 24)).(define (s
0c20: 64 61 74 2d 67 65 74 2d 72 65 71 75 65 73 74 2d dat-get-request-
0c30: 6d 65 74 68 6f 64 20 20 20 20 20 20 20 76 65 63 method vec
0c40: 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 ) (vector-ref
0c50: 20 20 76 65 63 20 32 35 29 29 0a 28 64 65 66 69 vec 25)).(defi
0c60: 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 ne (sdat-get-ses
0c70: 73 69 6f 6e 2d 63 6f 6f 6b 69 65 20 20 20 20 20 sion-cookie
0c80: 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f vec) (vecto
0c90: 72 2d 72 65 66 20 20 76 65 63 20 32 36 29 29 0a r-ref vec 26)).
0ca0: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 (define (sdat-ge
0cb0: 74 2d 63 75 72 72 2d 65 72 72 20 20 20 20 20 20 t-curr-err
0cc0: 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 vec) (
0cd0: 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 vector-ref vec
0ce0: 32 37 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 27)).(define (sd
0cf0: 61 74 2d 67 65 74 2d 6c 6f 67 2d 70 6f 72 74 20 at-get-log-port
0d00: 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 29 vec)
0d10: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
0d20: 20 76 65 63 20 32 38 29 29 0a 28 64 65 66 69 6e vec 28)).(defin
0d30: 65 20 28 73 64 61 74 2d 67 65 74 2d 6c 6f 67 66 e (sdat-get-logf
0d40: 69 6c 65 20 20 20 20 20 20 20 20 20 20 20 20 20 ile
0d50: 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 vec) (vector
0d60: 2d 72 65 66 20 20 76 65 63 20 32 39 29 29 0a 28 -ref vec 29)).(
0d70: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 define (sdat-get
0d80: 2d 73 65 65 6e 2d 70 61 67 65 73 20 20 20 20 20 -seen-pages
0d90: 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 vec) (v
0da0: 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 33 ector-ref vec 3
0db0: 30 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 0)).(define (sda
0dc0: 74 2d 67 65 74 2d 70 61 67 65 2d 64 69 72 2d 73 t-get-page-dir-s
0dd0: 74 79 6c 65 20 20 20 20 20 20 20 76 65 63 29 20 tyle vec)
0de0: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 (vector-ref
0df0: 76 65 63 20 33 31 29 29 0a 28 64 65 66 69 6e 65 vec 31)).(define
0e00: 20 28 73 64 61 74 2d 67 65 74 2d 64 65 62 75 67 (sdat-get-debug
0e10: 6d 6f 64 65 20 20 20 20 20 20 20 20 20 20 20 20 mode
0e20: 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d vec) (vector-
0e30: 72 65 66 20 20 76 65 63 20 33 32 29 29 0a 28 64 ref vec 32)).(d
0e40: 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d efine (sdat-get-
0e50: 73 68 61 72 65 64 2d 68 61 73 68 20 20 20 20 20 shared-hash
0e60: 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 vec) (ve
0e70: 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 33 33 ctor-ref vec 33
0e80: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 ))..(define (ses
0e90: 73 69 6f 6e 3a 67 65 74 2d 73 68 61 72 65 64 20 sion:get-shared
0ea0: 76 65 63 20 76 61 72 6e 61 6d 65 29 0a 20 20 28 vec varname). (
0eb0: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
0ec0: 65 66 61 75 6c 74 20 28 76 65 63 74 6f 72 2d 72 efault (vector-r
0ed0: 65 66 20 76 65 63 20 33 33 29 20 76 61 72 6e 61 ef vec 33) varna
0ee0: 6d 65 20 23 66 29 29 0a 0a 28 64 65 66 69 6e 65 me #f))..(define
0ef0: 20 28 73 64 61 74 2d 73 65 74 2d 64 62 74 79 70 (sdat-set-dbtyp
0f00: 65 21 20 20 20 20 20 20 20 20 20 20 20 20 20 20 e!
0f10: 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d vec val)(vector-
0f20: 73 65 74 21 20 76 65 63 20 30 20 76 61 6c 29 29 set! vec 0 val))
0f30: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 .(define (sdat-s
0f40: 65 74 2d 64 62 69 6e 69 74 21 20 20 20 20 20 20 et-dbinit!
0f50: 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 vec val)
0f60: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 (vector-set! vec
0f70: 20 31 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 1 val)).(define
0f80: 20 28 73 64 61 74 2d 73 65 74 2d 63 6f 6e 6e 21 (sdat-set-conn!
0f90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0fa0: 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d vec val)(vector-
0fb0: 73 65 74 21 20 76 65 63 20 32 20 76 61 6c 29 29 set! vec 2 val))
0fc0: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 .(define (sdat-s
0fd0: 65 74 2d 70 61 72 61 6d 73 21 20 20 20 20 20 20 et-params!
0fe0: 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 vec val)
0ff0: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 (vector-set! vec
1000: 20 33 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 3 val)).(define
1010: 20 28 73 64 61 74 2d 73 65 74 2d 70 61 74 68 2d (sdat-set-path-
1020: 70 61 72 61 6d 73 21 20 20 20 20 20 20 20 20 20 params!
1030: 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d vec val)(vector-
1040: 73 65 74 21 20 76 65 63 20 34 20 76 61 6c 29 29 set! vec 4 val))
1050: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 .(define (sdat-s
1060: 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 21 20 et-session-key!
1070: 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 vec val)
1080: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 (vector-set! vec
1090: 20 35 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 5 val)).(define
10a0: 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 (sdat-set-sessi
10b0: 6f 6e 2d 69 64 21 20 20 20 20 20 20 20 20 20 20 on-id!
10c0: 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d vec val)(vector-
10d0: 73 65 74 21 20 76 65 63 20 36 20 76 61 6c 29 29 set! vec 6 val))
10e0: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 .(define (sdat-s
10f0: 65 74 2d 64 6f 6d 61 69 6e 21 20 20 20 20 20 20 et-domain!
1100: 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 vec val)
1110: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 (vector-set! vec
1120: 20 37 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 7 val)).(define
1130: 20 28 73 64 61 74 2d 73 65 74 2d 74 6f 70 70 61 (sdat-set-toppa
1140: 67 65 21 20 20 20 20 20 20 20 20 20 20 20 20 20 ge!
1150: 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d vec val)(vector-
1160: 73 65 74 21 20 76 65 63 20 38 20 76 61 6c 29 29 set! vec 8 val))
1170: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 .(define (sdat-s
1180: 65 74 2d 70 61 67 65 21 20 20 20 20 20 20 20 20 et-page!
1190: 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 vec val)
11a0: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 (vector-set! vec
11b0: 20 39 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 9 val)).(define
11c0: 20 28 73 64 61 74 2d 73 65 74 2d 63 75 72 72 2d (sdat-set-curr-
11d0: 70 61 67 65 21 20 20 20 20 20 20 20 20 20 20 20 page!
11e0: 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d vec val)(vector-
11f0: 73 65 74 21 20 76 65 63 20 31 30 20 76 61 6c 29 set! vec 10 val)
1200: 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d ).(define (sdat-
1210: 73 65 74 2d 63 6f 6e 74 65 6e 74 2d 74 79 70 65 set-content-type
1220: 21 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c ! vec val
1230: 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 )(vector-set! ve
1240: 63 20 31 31 20 76 61 6c 29 29 0a 28 64 65 66 69 c 11 val)).(defi
1250: 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 70 61 67 ne (sdat-set-pag
1260: 65 2d 74 79 70 65 21 20 20 20 20 20 20 20 20 20 e-type!
1270: 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f vec val)(vecto
1280: 72 2d 73 65 74 21 20 76 65 63 20 31 32 20 76 61 r-set! vec 12 va
1290: 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 l)).(define (sda
12a0: 74 2d 73 65 74 2d 73 72 6f 6f 74 21 20 20 20 20 t-set-sroot!
12b0: 20 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 vec v
12c0: 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 al)(vector-set!
12d0: 76 65 63 20 31 33 20 76 61 6c 29 29 0a 28 64 65 vec 13 val)).(de
12e0: 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 74 fine (sdat-set-t
12f0: 77 69 6b 69 64 69 72 21 20 20 20 20 20 20 20 20 wikidir!
1300: 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 vec val)(vec
1310: 74 6f 72 2d 73 65 74 21 20 76 65 63 20 31 34 20 tor-set! vec 14
1320: 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 val)).(define (s
1330: 64 61 74 2d 73 65 74 2d 70 61 67 65 64 61 74 21 dat-set-pagedat!
1340: 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 vec
1350: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
1360: 21 20 76 65 63 20 31 35 20 76 61 6c 29 29 0a 28 ! vec 15 val)).(
1370: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 define (sdat-set
1380: 2d 61 6c 74 2d 70 61 67 65 2d 64 61 74 21 20 20 -alt-page-dat!
1390: 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 vec val)(v
13a0: 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 31 ector-set! vec 1
13b0: 36 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 6 val)).(define
13c0: 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 76 61 (sdat-set-pageva
13d0: 72 73 21 20 20 20 20 20 20 20 20 20 20 20 20 76 rs! v
13e0: 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 ec val)(vector-s
13f0: 65 74 21 20 76 65 63 20 31 37 20 76 61 6c 29 29 et! vec 17 val))
1400: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 .(define (sdat-s
1410: 65 74 2d 70 61 67 65 76 61 72 73 2d 62 65 66 6f et-pagevars-befo
1420: 72 65 21 20 20 20 20 20 76 65 63 20 76 61 6c 29 re! vec val)
1430: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 (vector-set! vec
1440: 20 31 38 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 18 val)).(defin
1450: 65 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 e (sdat-set-sess
1460: 69 6f 6e 76 61 72 73 21 20 20 20 20 20 20 20 20 ionvars!
1470: 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 vec val)(vector
1480: 2d 73 65 74 21 20 76 65 63 20 31 39 20 76 61 6c -set! vec 19 val
1490: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
14a0: 2d 73 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 -set-sessionvars
14b0: 2d 62 65 66 6f 72 65 21 20 20 76 65 63 20 76 61 -before! vec va
14c0: 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 l)(vector-set! v
14d0: 65 63 20 32 30 20 76 61 6c 29 29 0a 28 64 65 66 ec 20 val)).(def
14e0: 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 67 6c ine (sdat-set-gl
14f0: 6f 62 61 6c 76 61 72 73 21 20 20 20 20 20 20 20 obalvars!
1500: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
1510: 6f 72 2d 73 65 74 21 20 76 65 63 20 32 31 20 76 or-set! vec 21 v
1520: 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 al)).(define (sd
1530: 61 74 2d 73 65 74 2d 67 6c 6f 62 61 6c 76 61 72 at-set-globalvar
1540: 73 2d 62 65 66 6f 72 65 21 20 20 20 76 65 63 20 s-before! vec
1550: 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 val)(vector-set!
1560: 20 76 65 63 20 32 32 20 76 61 6c 29 29 0a 28 64 vec 22 val)).(d
1570: 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d efine (sdat-set-
1580: 6c 6f 67 70 74 21 20 20 20 20 20 20 20 20 20 20 logpt!
1590: 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 vec val)(ve
15a0: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 32 33 ctor-set! vec 23
15b0: 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 val)).(define (
15c0: 73 64 61 74 2d 73 65 74 2d 66 6f 72 6d 64 61 74 sdat-set-formdat
15d0: 21 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 ! ve
15e0: 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 c val)(vector-se
15f0: 74 21 20 76 65 63 20 32 34 20 76 61 6c 29 29 0a t! vec 24 val)).
1600: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 (define (sdat-se
1610: 74 2d 72 65 71 75 65 73 74 2d 6d 65 74 68 6f 64 t-request-method
1620: 21 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 ! vec val)(
1630: 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 vector-set! vec
1640: 32 35 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 25 val)).(define
1650: 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 (sdat-set-sessi
1660: 6f 6e 2d 63 6f 6f 6b 69 65 21 20 20 20 20 20 20 on-cookie!
1670: 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d vec val)(vector-
1680: 73 65 74 21 20 76 65 63 20 32 36 20 76 61 6c 29 set! vec 26 val)
1690: 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d ).(define (sdat-
16a0: 73 65 74 2d 63 75 72 72 2d 65 72 72 21 20 20 20 set-curr-err!
16b0: 20 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c vec val
16c0: 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 )(vector-set! ve
16d0: 63 20 32 37 20 76 61 6c 29 29 0a 28 64 65 66 69 c 27 val)).(defi
16e0: 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 6c 6f 67 ne (sdat-set-log
16f0: 2d 70 6f 72 74 21 20 20 20 20 20 20 20 20 20 20 -port!
1700: 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f vec val)(vecto
1710: 72 2d 73 65 74 21 20 76 65 63 20 32 38 20 76 61 r-set! vec 28 va
1720: 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 l)).(define (sda
1730: 74 2d 73 65 74 2d 6c 6f 67 66 69 6c 65 21 20 20 t-set-logfile!
1740: 20 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 vec v
1750: 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 al)(vector-set!
1760: 76 65 63 20 32 39 20 76 61 6c 29 29 0a 28 64 65 vec 29 val)).(de
1770: 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 73 fine (sdat-set-s
1780: 65 65 6e 2d 70 61 67 65 73 21 20 20 20 20 20 20 een-pages!
1790: 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 vec val)(vec
17a0: 74 6f 72 2d 73 65 74 21 20 76 65 63 20 33 30 20 tor-set! vec 30
17b0: 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 val)).(define (s
17c0: 64 61 74 2d 73 65 74 2d 70 61 67 65 2d 64 69 72 dat-set-page-dir
17d0: 2d 73 74 79 6c 65 21 20 20 20 20 20 20 76 65 63 -style! vec
17e0: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
17f0: 21 20 76 65 63 20 33 31 20 76 61 6c 29 29 0a 28 ! vec 31 val)).(
1800: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 define (sdat-set
1810: 2d 64 65 62 75 67 6d 6f 64 65 21 20 20 20 20 20 -debugmode!
1820: 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 vec val)(v
1830: 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 33 ector-set! vec 3
1840: 32 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 2 val)).(define
1850: 28 73 64 61 74 2d 73 65 74 2d 73 68 61 72 65 64 (sdat-set-shared
1860: 2d 68 61 73 68 21 20 20 20 20 20 20 20 20 20 76 -hash! v
1870: 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 ec val)(vector-s
1880: 65 74 21 20 76 65 63 20 33 33 20 76 61 6c 29 29 et! vec 33 val))
1890: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ..(define (sessi
18a0: 6f 6e 3a 73 65 74 2d 73 68 61 72 65 64 21 20 76 on:set-shared! v
18b0: 65 63 20 76 61 72 6e 61 6d 65 20 76 61 6c 29 0a ec varname val).
18c0: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
18d0: 74 21 20 28 76 65 63 74 6f 72 2d 72 65 66 20 76 t! (vector-ref v
18e0: 65 63 20 33 33 29 20 76 61 72 6e 61 6d 65 20 76 ec 33) varname v
18f0: 61 6c 29 29 0a 0a 3b 3b 20 54 68 65 20 67 6c 6f al))..;; The glo
1900: 62 61 6c 20 73 65 73 73 69 6f 6e 0a 28 64 65 66 bal session.(def
1910: 69 6e 65 20 73 3a 73 65 73 73 69 6f 6e 20 28 6d ine s:session (m
1920: 61 6b 65 2d 73 64 61 74 29 29 0a 0a 3b 3b 20 53 ake-sdat))..;; S
1930: 50 4c 49 54 20 49 4e 54 4f 20 53 54 52 41 49 47 PLIT INTO STRAIG
1940: 48 54 20 46 4f 52 57 41 52 44 20 49 4e 49 54 20 HT FORWARD INIT
1950: 41 4e 44 20 43 4f 4d 50 4c 45 58 20 49 4e 49 54 AND COMPLEX INIT
1960: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
1970: 6e 3a 69 6e 69 74 69 61 6c 69 7a 65 20 73 65 6c n:initialize sel
1980: 66 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 64 f). (sdat-set-d
1990: 62 74 79 70 65 21 20 73 65 6c 66 20 20 20 20 20 btype! self
19a0: 20 27 70 67 29 0a 20 20 28 73 64 61 74 2d 73 65 'pg). (sdat-se
19b0: 74 2d 70 61 67 65 21 20 73 65 6c 66 20 20 20 20 t-page! self
19c0: 20 20 20 20 22 68 6f 6d 65 22 29 20 20 20 20 20 "home")
19d0: 20 20 20 3b 3b 20 74 68 65 73 65 20 61 72 65 20 ;; these are
19e0: 64 65 66 61 75 6c 74 73 0a 20 20 28 73 64 61 74 defaults. (sdat
19f0: 2d 73 65 74 2d 63 75 72 72 2d 70 61 67 65 21 20 -set-curr-page!
1a00: 73 65 6c 66 20 20 20 22 68 6f 6d 65 22 29 0a 20 self "home").
1a10: 20 28 73 64 61 74 2d 73 65 74 2d 63 6f 6e 74 65 (sdat-set-conte
1a20: 6e 74 2d 74 79 70 65 21 20 73 65 6c 66 20 22 43 nt-type! self "C
1a30: 6f 6e 74 65 6e 74 2d 74 79 70 65 3a 20 74 65 78 ontent-type: tex
1a40: 74 2f 68 74 6d 6c 3b 20 63 68 61 72 73 65 74 3d t/html; charset=
1a50: 69 73 6f 2d 38 38 35 39 2d 31 5c 6e 5c 6e 22 29 iso-8859-1\n\n")
1a60: 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 67 . (sdat-set-pag
1a70: 65 2d 74 79 70 65 21 20 73 65 6c 66 20 20 20 27 e-type! self '
1a80: 68 74 6d 6c 29 0a 20 20 28 73 64 61 74 2d 73 65 html). (sdat-se
1a90: 74 2d 74 6f 70 70 61 67 65 21 20 73 65 6c 66 20 t-toppage! self
1aa0: 20 20 20 20 22 69 6e 64 65 78 22 29 0a 20 20 28 "index"). (
1ab0: 73 64 61 74 2d 73 65 74 2d 70 61 72 61 6d 73 21 sdat-set-params!
1ac0: 20 73 65 6c 66 20 20 20 20 20 20 27 28 29 29 20 self '())
1ad0: 20 20 20 20 20 20 20 20 20 20 3b 3b 0a 20 20 28 ;;. (
1ae0: 73 64 61 74 2d 73 65 74 2d 70 61 74 68 2d 70 61 sdat-set-path-pa
1af0: 72 61 6d 73 21 20 73 65 6c 66 20 27 28 29 29 0a rams! self '()).
1b00: 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 (sdat-set-sess
1b10: 69 6f 6e 2d 6b 65 79 21 20 73 65 6c 66 20 23 66 ion-key! self #f
1b20: 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 ). (sdat-set-pa
1b30: 67 65 64 61 74 21 20 73 65 6c 66 20 20 20 20 20 gedat! self
1b40: 27 28 29 29 0a 20 20 28 73 64 61 74 2d 73 65 74 '()). (sdat-set
1b50: 2d 61 6c 74 2d 70 61 67 65 2d 64 61 74 21 20 73 -alt-page-dat! s
1b60: 65 6c 66 20 23 66 29 0a 20 20 28 73 64 61 74 2d elf #f). (sdat-
1b70: 73 65 74 2d 73 72 6f 6f 74 21 20 73 65 6c 66 20 set-sroot! self
1b80: 20 20 20 20 20 20 22 2e 2f 22 29 0a 20 20 28 73 "./"). (s
1b90: 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e 2d dat-set-session-
1ba0: 63 6f 6f 6b 69 65 21 20 73 65 6c 66 20 23 66 29 cookie! self #f)
1bb0: 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 63 75 72 . (sdat-set-cur
1bc0: 72 2d 65 72 72 21 20 73 65 6c 66 20 23 66 29 0a r-err! self #f).
1bd0: 20 20 28 73 64 61 74 2d 73 65 74 2d 6c 6f 67 2d (sdat-set-log-
1be0: 70 6f 72 74 21 20 73 65 6c 66 20 28 63 75 72 72 port! self (curr
1bf0: 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 ent-error-port))
1c00: 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 65 . (sdat-set-see
1c10: 6e 2d 70 61 67 65 73 21 20 73 65 6c 66 20 27 28 n-pages! self '(
1c20: 29 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 70 )). (sdat-set-p
1c30: 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 21 20 73 age-dir-style! s
1c40: 65 6c 66 20 23 74 29 20 3b 3b 20 23 74 20 3a 20 elf #t) ;; #t :
1c50: 70 61 67 65 73 2f 3c 70 61 67 65 6e 61 6d 65 3e pages/<pagename>
1c60: 5f 28 76 69 65 77 7c 63 6e 74 6c 29 2e 73 63 6d _(view|cntl).scm
1c70: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
1c80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1c90: 20 20 20 20 20 20 20 3b 3b 20 23 66 20 3a 20 70 ;; #f : p
1ca0: 61 67 65 73 2f 3c 70 61 67 65 6e 61 6d 65 3e 2f ages/<pagename>/
1cb0: 28 76 69 65 77 7c 63 6f 6e 74 72 6f 6c 29 2e 73 (view|control).s
1cc0: 63 6d 20 0a 20 20 28 73 64 61 74 2d 73 65 74 2d cm . (sdat-set-
1cd0: 64 65 62 75 67 6d 6f 64 65 21 20 20 20 20 20 20 debugmode!
1ce0: 20 20 20 20 73 65 6c 66 20 23 66 29 0a 20 20 09 self #f). .
1cf0: 09 09 20 20 20 20 20 0a 20 20 28 73 64 61 74 2d .. . (sdat-
1d00: 73 65 74 2d 70 61 67 65 76 61 72 73 21 20 20 20 set-pagevars!
1d10: 20 20 20 20 20 20 20 20 73 65 6c 66 20 28 6d 61 self (ma
1d20: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
1d30: 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 (sdat-set-sess
1d40: 69 6f 6e 76 61 72 73 21 20 20 20 20 20 20 20 20 ionvars!
1d50: 73 65 6c 66 20 28 6d 61 6b 65 2d 68 61 73 68 2d self (make-hash-
1d60: 74 61 62 6c 65 29 29 0a 20 20 28 73 64 61 74 2d table)). (sdat-
1d70: 73 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 21 20 set-globalvars!
1d80: 20 20 20 20 20 20 20 20 73 65 6c 66 20 28 6d 61 self (ma
1d90: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
1da0: 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 (sdat-set-page
1db0: 76 61 72 73 2d 62 65 66 6f 72 65 21 20 20 20 20 vars-before!
1dc0: 73 65 6c 66 20 28 6d 61 6b 65 2d 68 61 73 68 2d self (make-hash-
1dd0: 74 61 62 6c 65 29 29 0a 20 20 28 73 64 61 74 2d table)). (sdat-
1de0: 73 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 2d set-sessionvars-
1df0: 62 65 66 6f 72 65 21 20 73 65 6c 66 20 28 6d 61 before! self (ma
1e00: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
1e10: 20 20 28 73 64 61 74 2d 73 65 74 2d 67 6c 6f 62 (sdat-set-glob
1e20: 61 6c 76 61 72 73 2d 62 65 66 6f 72 65 21 20 20 alvars-before!
1e30: 73 65 6c 66 20 28 6d 61 6b 65 2d 68 61 73 68 2d self (make-hash-
1e40: 74 61 62 6c 65 29 29 0a 20 20 28 73 64 61 74 2d table)). (sdat-
1e50: 73 65 74 2d 64 6f 6d 61 69 6e 21 20 20 20 20 20 set-domain!
1e60: 20 20 20 20 20 20 20 20 73 65 6c 66 20 22 6c 6f self "lo
1e70: 63 61 68 6f 73 74 22 29 20 20 20 3b 3b 20 65 6e cahost") ;; en
1e80: 64 20 6f 66 20 64 65 66 61 75 6c 74 73 0a 20 20 d of defaults.
1e90: 28 6c 65 74 2a 20 28 28 72 61 77 63 6f 6e 66 69 (let* ((rawconfi
1ea0: 67 64 61 74 20 28 73 65 73 73 69 6f 6e 3a 72 65 gdat (session:re
1eb0: 61 64 2d 63 6f 6e 66 69 67 20 73 65 6c 66 29 29 ad-config self))
1ec0: 0a 09 20 28 63 6f 6e 66 69 67 64 61 74 20 28 69 .. (configdat (i
1ed0: 66 20 72 61 77 63 6f 6e 66 69 67 64 61 74 20 28 f rawconfigdat (
1ee0: 65 76 61 6c 20 72 61 77 63 6f 6e 66 69 67 64 61 eval rawconfigda
1ef0: 74 29 20 27 28 29 29 29 0a 09 20 28 73 72 6f 6f t) '())).. (sroo
1f00: 74 20 20 20 20 20 28 73 3a 66 69 6e 64 2d 70 61 t (s:find-pa
1f10: 72 61 6d 20 27 73 72 6f 6f 74 20 20 20 20 63 6f ram 'sroot co
1f20: 6e 66 69 67 64 61 74 29 29 0a 09 20 28 6c 6f 67 nfigdat)).. (log
1f30: 66 69 6c 65 20 20 20 28 73 3a 66 69 6e 64 2d 70 file (s:find-p
1f40: 61 72 61 6d 20 27 6c 6f 67 66 69 6c 65 20 20 63 aram 'logfile c
1f50: 6f 6e 66 69 67 64 61 74 29 29 0a 09 20 28 64 62 onfigdat)).. (db
1f60: 74 79 70 65 20 20 20 20 28 73 3a 66 69 6e 64 2d type (s:find-
1f70: 70 61 72 61 6d 20 27 64 62 74 79 70 65 20 20 20 param 'dbtype
1f80: 63 6f 6e 66 69 67 64 61 74 29 29 0a 09 20 28 64 configdat)).. (d
1f90: 62 69 6e 69 74 20 20 20 20 28 73 3a 66 69 6e 64 binit (s:find
1fa0: 2d 70 61 72 61 6d 20 27 64 62 69 6e 69 74 20 20 -param 'dbinit
1fb0: 20 63 6f 6e 66 69 67 64 61 74 29 29 0a 09 20 28 configdat)).. (
1fc0: 64 6f 6d 61 69 6e 20 20 20 20 28 73 3a 66 69 6e domain (s:fin
1fd0: 64 2d 70 61 72 61 6d 20 27 64 6f 6d 61 69 6e 20 d-param 'domain
1fe0: 20 20 63 6f 6e 66 69 67 64 61 74 29 29 0a 09 20 configdat))..
1ff0: 28 74 77 69 6b 69 64 69 72 20 20 28 73 3a 66 69 (twikidir (s:fi
2000: 6e 64 2d 70 61 72 61 6d 20 27 74 77 69 6b 69 64 nd-param 'twikid
2010: 69 72 20 63 6f 6e 66 69 67 64 61 74 29 29 0a 09 ir configdat))..
2020: 20 28 70 61 67 65 2d 64 69 72 20 20 28 73 3a 66 (page-dir (s:f
2030: 69 6e 64 2d 70 61 72 61 6d 20 27 70 61 67 65 2d ind-param 'page-
2040: 64 69 72 2d 73 74 79 6c 65 20 63 6f 6e 66 69 67 dir-style config
2050: 64 61 74 29 29 0a 09 20 28 64 65 62 75 67 6d 6f dat)).. (debugmo
2060: 64 65 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d de (s:find-param
2070: 20 27 64 65 62 75 67 6d 6f 64 65 20 63 6f 6e 66 'debugmode conf
2080: 69 67 64 61 74 29 29 29 0a 20 20 20 20 28 69 66 igdat))). (if
2090: 20 73 72 6f 6f 74 20 20 20 20 28 73 64 61 74 2d sroot (sdat-
20a0: 73 65 74 2d 73 72 6f 6f 74 21 20 20 20 20 73 65 set-sroot! se
20b0: 6c 66 20 73 72 6f 6f 74 29 29 0a 20 20 20 20 28 lf sroot)). (
20c0: 69 66 20 6c 6f 67 66 69 6c 65 20 20 28 73 64 61 if logfile (sda
20d0: 74 2d 73 65 74 2d 6c 6f 67 66 69 6c 65 21 20 20 t-set-logfile!
20e0: 73 65 6c 66 20 6c 6f 67 66 69 6c 65 29 29 0a 20 self logfile)).
20f0: 20 20 20 28 69 66 20 64 62 74 79 70 65 20 20 20 (if dbtype
2100: 28 73 64 61 74 2d 73 65 74 2d 64 62 74 79 70 65 (sdat-set-dbtype
2110: 21 20 20 20 73 65 6c 66 20 64 62 74 79 70 65 29 ! self dbtype)
2120: 29 0a 20 20 20 20 28 69 66 20 64 62 69 6e 69 74 ). (if dbinit
2130: 20 20 20 28 73 64 61 74 2d 73 65 74 2d 64 62 69 (sdat-set-dbi
2140: 6e 69 74 21 20 20 20 73 65 6c 66 20 64 62 69 6e nit! self dbin
2150: 69 74 29 29 0a 20 20 20 20 28 69 66 20 64 6f 6d it)). (if dom
2160: 61 69 6e 20 20 20 28 73 64 61 74 2d 73 65 74 2d ain (sdat-set-
2170: 64 6f 6d 61 69 6e 21 20 20 20 73 65 6c 66 20 64 domain! self d
2180: 6f 6d 61 69 6e 29 29 0a 20 20 20 20 28 69 66 20 omain)). (if
2190: 74 77 69 6b 69 64 69 72 20 28 73 64 61 74 2d 73 twikidir (sdat-s
21a0: 65 74 2d 74 77 69 6b 69 64 69 72 21 20 73 65 6c et-twikidir! sel
21b0: 66 20 74 77 69 6b 69 64 69 72 29 29 0a 20 20 20 f twikidir)).
21c0: 20 28 69 66 20 64 65 62 75 67 6d 6f 64 65 20 28 (if debugmode (
21d0: 73 64 61 74 2d 73 65 74 2d 64 65 62 75 67 6d 6f sdat-set-debugmo
21e0: 64 65 21 20 73 65 6c 66 20 64 65 62 75 67 6d 6f de! self debugmo
21f0: 64 65 29 29 0a 20 20 20 20 28 73 64 61 74 2d 73 de)). (sdat-s
2200: 65 74 2d 70 61 67 65 2d 64 69 72 2d 73 74 79 6c et-page-dir-styl
2210: 65 21 20 73 65 6c 66 20 70 61 67 65 2d 64 69 72 e! self page-dir
2220: 29 0a 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 ). ;; (print
2230: 22 63 6f 6e 66 69 67 64 61 74 3a 20 22 29 28 70 "configdat: ")(p
2240: 70 20 63 6f 6e 66 69 67 64 61 74 29 0a 20 20 20 p configdat).
2250: 20 28 69 66 20 64 65 62 75 67 6d 6f 64 65 0a 09 (if debugmode..
2260: 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c (session:log sel
2270: 66 20 22 73 72 6f 6f 74 3a 20 22 20 73 72 6f 6f f "sroot: " sroo
2280: 74 20 22 20 6c 6f 67 66 69 6c 65 3a 20 22 20 6c t " logfile: " l
2290: 6f 67 66 69 6c 65 20 22 20 64 62 74 79 70 65 3a ogfile " dbtype:
22a0: 20 22 20 64 62 74 79 70 65 20 0a 09 09 20 20 20 " dbtype ...
22b0: 20 20 22 20 64 62 69 6e 69 74 3a 20 22 20 64 62 " dbinit: " db
22c0: 69 6e 69 74 20 22 20 64 6f 6d 61 69 6e 3a 20 22 init " domain: "
22d0: 20 64 6f 6d 61 69 6e 20 22 20 70 61 67 65 2d 64 domain " page-d
22e0: 69 72 2d 73 74 79 6c 65 3a 20 22 20 70 61 67 65 ir-style: " page
22f0: 2d 64 69 72 29 29 0a 20 20 20 20 29 0a 20 20 28 -dir)). ). (
2300: 73 64 61 74 2d 73 65 74 2d 73 68 61 72 65 64 2d sdat-set-shared-
2310: 68 61 73 68 21 20 73 65 6c 66 20 28 6d 61 6b 65 hash! self (make
2320: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 -hash-table)).
2330: 29 0a 0a 3b 3b 20 55 73 65 64 20 66 6f 72 20 74 )..;; Used for t
2340: 68 65 20 73 74 72 61 6e 67 65 6c 79 20 69 6e 63 he strangely inc
2350: 6f 6e 73 69 73 74 65 6e 74 20 68 61 6e 64 6c 69 onsistent handli
2360: 6e 67 20 6f 66 20 74 68 65 20 63 6f 6e 66 69 67 ng of the config
2370: 20 66 69 6c 65 2e 20 41 20 62 65 74 74 65 72 20 file. A better
2380: 77 61 79 20 69 73 20 6e 65 65 64 65 64 2e 0a 3b way is needed..;
2390: 3b 0a 3b 3b 20 20 20 28 6c 65 74 20 28 28 64 62 ;.;; (let ((db
23a0: 74 79 70 65 20 28 73 64 61 74 2d 67 65 74 2d 64 type (sdat-get-d
23b0: 62 74 79 70 65 20 73 65 6c 66 29 29 29 0a 3b 3b btype self))).;;
23c0: 20 20 20 20 20 28 70 72 69 6e 74 20 22 64 62 74 (print "dbt
23d0: 79 70 65 3a 20 22 20 64 62 74 79 70 65 29 0a 3b ype: " dbtype).;
23e0: 3b 20 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d ; (sdat-set-
23f0: 64 62 74 79 70 65 21 20 73 65 6c 66 20 28 65 76 dbtype! self (ev
2400: 61 6c 20 64 62 74 79 70 65 29 29 29 29 0a 0a 28 al dbtype))))..(
2410: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
2420: 73 65 74 75 70 20 73 65 6c 66 29 0a 20 20 28 6c setup self). (l
2430: 65 74 20 28 28 64 62 74 79 70 65 20 20 20 20 28 et ((dbtype (
2440: 73 64 61 74 2d 67 65 74 2d 64 62 74 79 70 65 20 sdat-get-dbtype
2450: 73 65 6c 66 29 29 0a 09 28 64 65 62 75 67 6d 6f self))..(debugmo
2460: 64 65 20 28 73 64 61 74 2d 67 65 74 2d 64 65 62 de (sdat-get-deb
2470: 75 67 6d 6f 64 65 20 73 65 6c 66 29 29 0a 09 28 ugmode self))..(
2480: 64 62 69 6e 69 74 20 20 20 20 28 65 76 61 6c 20 dbinit (eval
2490: 28 73 64 61 74 2d 67 65 74 2d 64 62 69 6e 69 74 (sdat-get-dbinit
24a0: 20 73 65 6c 66 29 29 29 0a 09 28 64 62 65 78 69 self)))..(dbexi
24b0: 73 74 73 20 20 23 66 29 29 0a 20 20 20 20 28 6c sts #f)). (l
24c0: 65 74 20 28 28 64 62 66 6e 61 6d 65 20 28 61 6c et ((dbfname (al
24d0: 69 73 74 2d 72 65 66 20 27 64 62 6e 61 6d 65 20 ist-ref 'dbname
24e0: 64 62 69 6e 69 74 29 29 29 0a 20 20 20 20 20 20 dbinit))).
24f0: 28 69 66 20 64 65 62 75 67 6d 6f 64 65 20 28 73 (if debugmode (s
2500: 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 ession:log self
2510: 22 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 20 64 "session:setup d
2520: 62 66 6e 61 6d 65 3d 22 20 64 62 66 6e 61 6d 65 bfname=" dbfname
2530: 20 22 2c 20 64 62 74 79 70 65 3d 22 20 64 62 74 ", dbtype=" dbt
2540: 79 70 65 20 22 2c 20 64 62 69 6e 69 74 3d 22 20 ype ", dbinit="
2550: 64 62 69 6e 69 74 29 29 0a 20 20 20 20 20 20 28 dbinit)). (
2560: 69 66 20 28 65 71 3f 20 64 62 74 79 70 65 20 27 if (eq? dbtype '
2570: 73 71 6c 69 74 65 33 29 0a 09 20 20 3b 3b 20 54 sqlite3).. ;; T
2580: 68 65 20 27 61 75 74 6f 20 6d 65 74 68 6f 64 20 he 'auto method
2590: 77 69 6c 6c 20 64 69 73 74 72 69 62 75 74 65 20 will distribute
25a0: 64 62 73 20 61 63 72 6f 73 73 20 74 68 65 20 64 dbs across the d
25b0: 69 73 6b 20 75 73 69 6e 67 20 68 61 73 68 0a 09 isk using hash..
25c0: 20 20 3b 3b 20 6f 66 20 75 73 65 72 20 68 6f 73 ;; of user hos
25d0: 74 20 61 6e 64 20 75 73 65 72 2e 20 54 4f 44 4f t and user. TODO
25e0: 0a 09 20 20 3b 3b 20 28 69 66 20 28 65 71 3f 20 .. ;; (if (eq?
25f0: 64 62 66 6e 61 6d 65 20 27 61 75 74 6f 29 20 3b dbfname 'auto) ;
2600: 3b 20 54 68 69 73 20 69 73 20 74 68 65 20 61 75 ; This is the au
2610: 74 6f 20 61 73 73 69 67 6e 6d 65 6e 74 20 6f 66 to assignment of
2620: 20 61 20 64 62 20 62 61 73 65 64 20 6f 6e 20 68 a db based on h
2630: 61 73 68 20 6f 66 20 49 50 0a 09 20 20 28 6c 65 ash of IP.. (le
2640: 74 20 28 28 64 62 70 61 74 68 20 28 70 61 74 68 t ((dbpath (path
2650: 6e 61 6d 65 2d 64 69 72 65 63 74 6f 72 79 20 64 name-directory d
2660: 62 66 6e 61 6d 65 29 29 29 20 20 3b 3b 20 64 6f bfname))) ;; do
2670: 20 61 20 63 6f 75 70 6c 65 20 73 61 6e 69 74 79 a couple sanity
2680: 20 63 68 65 63 6b 73 20 68 65 72 65 20 74 6f 20 checks here to
2690: 6d 61 6b 65 20 73 65 74 74 69 6e 67 20 75 70 20 make setting up
26a0: 65 61 73 69 65 72 0a 09 20 20 20 20 28 69 66 20 easier.. (if
26b0: 64 65 62 75 67 6d 6f 64 65 20 28 73 65 73 73 69 debugmode (sessi
26c0: 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 49 4e 46 on:log self "INF
26d0: 4f 3a 20 73 65 74 74 69 6e 67 20 75 70 20 66 6f O: setting up fo
26e0: 72 20 73 71 6c 69 74 65 33 20 64 62 20 61 63 63 r sqlite3 db acc
26f0: 65 73 73 20 74 6f 20 22 20 64 62 66 6e 61 6d 65 ess to " dbfname
2700: 29 29 0a 09 20 20 20 20 28 69 66 20 28 6e 6f 74 )).. (if (not
2710: 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 (file-write-acc
2720: 65 73 73 3f 20 64 62 70 61 74 68 29 29 0a 09 09 ess? dbpath))...
2730: 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c (session:log sel
2740: 66 20 22 57 41 52 4e 49 4e 47 3a 20 43 61 6e 6e f "WARNING: Cann
2750: 6f 74 20 77 72 69 74 65 20 74 6f 20 22 20 64 62 ot write to " db
2760: 70 61 74 68 29 0a 09 09 28 69 66 20 64 65 62 75 path)...(if debu
2770: 67 6d 6f 64 65 20 28 73 65 73 73 69 6f 6e 3a 6c gmode (session:l
2780: 6f 67 20 73 65 6c 66 20 22 49 4e 46 4f 3a 20 22 og self "INFO: "
2790: 20 64 62 70 61 74 68 20 22 20 69 73 20 77 72 69 dbpath " is wri
27a0: 74 65 61 62 6c 65 22 29 29 29 0a 09 20 20 20 20 teable")))..
27b0: 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 (if (file-exists
27c0: 3f 20 64 62 66 6e 61 6d 65 29 0a 09 09 28 62 65 ? dbfname)...(be
27d0: 67 69 6e 0a 09 09 20 20 3b 3b 20 28 73 65 73 73 gin... ;; (sess
27e0: 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 73 65 ion:log self "se
27f0: 74 74 69 6e 67 20 64 62 65 78 69 73 74 73 20 74 tting dbexists t
2800: 6f 20 23 74 22 29 0a 09 09 20 20 28 73 65 74 21 o #t")... (set!
2810: 20 64 62 65 78 69 73 74 73 20 23 74 29 29 29 29 dbexists #t))))
2820: 0a 09 20 20 28 69 66 20 64 65 62 75 67 6d 6f 64 .. (if debugmod
2830: 65 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 e (session:log s
2840: 65 6c 66 20 22 49 4e 46 4f 3a 20 73 65 74 74 69 elf "INFO: setti
2850: 6e 67 20 75 70 20 66 6f 72 20 70 67 20 64 62 20 ng up for pg db
2860: 61 63 63 65 73 73 20 74 6f 20 61 63 63 6f 75 6e access to accoun
2870: 74 20 69 6e 66 6f 20 22 20 64 62 69 6e 69 74 29 t info " dbinit)
2880: 29 29 0a 20 20 20 20 20 20 28 69 66 20 64 65 62 )). (if deb
2890: 75 67 6d 6f 64 65 20 28 73 65 73 73 69 6f 6e 3a ugmode (session:
28a0: 6c 6f 67 20 73 65 6c 66 20 22 64 62 74 79 70 65 log self "dbtype
28b0: 3a 20 22 20 64 62 74 79 70 65 20 22 20 64 62 66 : " dbtype " dbf
28c0: 6e 61 6d 65 3a 20 22 20 64 62 66 6e 61 6d 65 20 name: " dbfname
28d0: 22 20 64 62 65 78 69 73 74 73 3a 20 22 20 64 62 " dbexists: " db
28e0: 65 78 69 73 74 73 29 29 29 0a 20 20 20 20 28 73 exists))). (s
28f0: 64 61 74 2d 73 65 74 2d 63 6f 6e 6e 21 20 73 65 dat-set-conn! se
2900: 6c 66 20 28 64 62 69 3a 6f 70 65 6e 20 64 62 74 lf (dbi:open dbt
2910: 79 70 65 20 64 62 69 6e 69 74 29 29 0a 20 20 20 ype dbinit)).
2920: 20 28 73 65 74 21 20 2a 64 62 2a 20 28 73 64 61 (set! *db* (sda
2930: 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 t-get-conn self)
2940: 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 ). (if (and (
2950: 6e 6f 74 20 64 62 65 78 69 73 74 73 29 28 65 71 not dbexists)(eq
2960: 3f 20 64 62 74 79 70 65 20 27 73 71 6c 69 74 65 ? dbtype 'sqlite
2970: 33 29 29 0a 20 09 28 62 65 67 69 6e 0a 09 20 20 3)). .(begin..
2980: 28 70 72 69 6e 74 20 22 57 41 52 4e 49 4e 47 3a (print "WARNING:
2990: 20 53 65 74 74 69 6e 67 20 75 70 20 73 65 73 73 Setting up sess
29a0: 69 6f 6e 20 64 62 20 77 69 74 68 20 73 71 6c 69 ion db with sqli
29b0: 74 65 33 22 29 0a 09 20 20 28 73 65 73 73 69 6f te3").. (sessio
29c0: 6e 3a 73 65 74 75 70 2d 64 62 20 73 65 6c 66 29 n:setup-db self)
29d0: 29 29 0a 20 20 20 20 28 73 65 73 73 69 6f 6e 3a )). (session:
29e0: 70 72 6f 63 65 73 73 2d 75 72 6c 2d 70 61 74 68 process-url-path
29f0: 20 73 65 6c 66 29 0a 20 20 20 20 28 73 65 73 73 self). (sess
2a00: 69 6f 6e 3a 73 65 74 75 70 2d 73 65 73 73 69 6f ion:setup-sessio
2a10: 6e 2d 6b 65 79 20 73 65 6c 66 29 0a 20 20 20 20 n-key self).
2a20: 3b 3b 20 63 61 70 74 75 72 65 20 73 74 64 69 6e ;; capture stdin
2a30: 20 69 66 20 74 68 69 73 20 69 73 20 61 20 50 4f if this is a PO
2a40: 53 54 0a 20 20 20 20 28 73 64 61 74 2d 73 65 74 ST. (sdat-set
2a50: 2d 72 65 71 75 65 73 74 2d 6d 65 74 68 6f 64 21 -request-method!
2a60: 20 73 65 6c 66 20 28 67 65 74 2d 65 6e 76 69 72 self (get-envir
2a70: 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 onment-variable
2a80: 22 52 45 51 55 45 53 54 5f 4d 45 54 48 4f 44 22 "REQUEST_METHOD"
2a90: 29 29 0a 20 20 20 20 28 73 64 61 74 2d 73 65 74 )). (sdat-set
2aa0: 2d 66 6f 72 6d 64 61 74 21 20 73 65 6c 66 20 28 -formdat! self (
2ab0: 66 6f 72 6d 64 61 74 3a 6c 6f 61 64 2d 61 6c 6c formdat:load-all
2ac0: 29 29 29 29 0a 0a 3b 3b 20 73 65 74 75 70 20 74 ))))..;; setup t
2ad0: 68 65 20 64 62 20 77 69 74 68 20 73 65 73 73 69 he db with sessi
2ae0: 6f 6e 20 74 61 62 6c 65 73 2c 20 77 6f 72 6b 73 on tables, works
2af0: 20 66 6f 72 20 73 71 6c 69 74 65 20 6f 6e 6c 79 for sqlite only
2b00: 20 72 69 67 68 74 20 6e 6f 77 0a 28 64 65 66 69 right now.(defi
2b10: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 75 ne (session:setu
2b20: 70 2d 64 62 20 73 65 6c 66 29 0a 20 20 28 6c 65 p-db self). (le
2b30: 74 20 28 28 63 6f 6e 6e 20 28 73 64 61 74 2d 67 t ((conn (sdat-g
2b40: 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 29 0a et-conn self))).
2b50: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 (for-each .
2b60: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 73 74 6d (lambda (stm
2b70: 74 29 0a 20 20 20 20 20 20 20 28 64 62 69 3a 65 t). (dbi:e
2b80: 78 65 63 20 63 6f 6e 6e 20 73 74 6d 74 29 29 0a xec conn stmt)).
2b90: 20 20 20 20 20 28 6c 69 73 74 20 22 43 52 45 41 (list "CREA
2ba0: 54 45 20 54 41 42 4c 45 20 73 65 73 73 69 6f 6e TE TABLE session
2bb0: 5f 76 61 72 73 20 28 69 64 20 49 4e 54 45 47 45 _vars (id INTEGE
2bc0: 52 20 50 52 49 4d 41 52 59 20 4b 45 59 2c 73 65 R PRIMARY KEY,se
2bd0: 73 73 69 6f 6e 5f 69 64 20 49 4e 54 45 47 45 52 ssion_id INTEGER
2be0: 2c 70 61 67 65 20 54 45 58 54 2c 6b 65 79 20 54 ,page TEXT,key T
2bf0: 45 58 54 2c 76 61 6c 75 65 20 54 45 58 54 29 3b EXT,value TEXT);
2c00: 22 0a 09 20 20 20 22 43 52 45 41 54 45 20 54 41 ".. "CREATE TA
2c10: 42 4c 45 20 73 65 73 73 69 6f 6e 73 20 28 69 64 BLE sessions (id
2c20: 20 49 4e 54 45 47 45 52 20 50 52 49 4d 41 52 59 INTEGER PRIMARY
2c30: 20 4b 45 59 2c 73 65 73 73 69 6f 6e 5f 6b 65 79 KEY,session_key
2c40: 20 54 45 58 54 2c 6c 61 73 74 5f 75 73 65 64 20 TEXT,last_used
2c50: 54 49 4d 45 53 54 41 4d 50 29 3b 22 0a 20 20 20 TIMESTAMP);".
2c60: 20 20 20 20 20 20 20 20 22 43 52 45 41 54 45 20 "CREATE
2c70: 54 41 42 4c 45 20 6d 65 74 61 64 61 74 61 20 28 TABLE metadata (
2c80: 69 64 20 49 4e 54 45 47 45 52 20 50 52 49 4d 41 id INTEGER PRIMA
2c90: 52 59 20 4b 45 59 2c 6b 65 79 20 54 45 58 54 2c RY KEY,key TEXT,
2ca0: 76 61 6c 75 65 20 54 45 58 54 29 3b 22 29 29 29 value TEXT);")))
2cb0: 29 0a 3b 3b 20 20 3b 3b 20 69 66 20 77 65 20 68 ).;; ;; if we h
2cc0: 61 76 65 20 61 20 73 65 73 73 69 6f 6e 5f 6b 65 ave a session_ke
2cd0: 79 20 6c 6f 6f 6b 20 75 70 20 74 68 65 20 73 65 y look up the se
2ce0: 73 73 69 6f 6e 2d 69 64 20 61 6e 64 20 73 74 6f ssion-id and sto
2cf0: 72 65 20 69 74 0a 3b 3b 20 20 28 73 64 61 74 2d re it.;; (sdat-
2d00: 73 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 21 20 set-session-id!
2d10: 73 65 6c 66 20 28 73 65 73 73 69 6f 6e 3a 67 65 self (session:ge
2d20: 74 2d 69 64 20 73 65 6c 66 29 29 29 0a 0a 3b 3b t-id self)))..;;
2d30: 20 6f 6e 6c 79 20 73 65 74 20 73 65 73 73 69 6f only set sessio
2d40: 6e 2d 63 6f 6f 6b 69 65 20 77 68 65 6e 20 61 20 n-cookie when a
2d50: 6e 65 77 20 73 65 73 73 69 6f 6e 20 69 73 20 63 new session is c
2d60: 72 65 61 74 65 64 0a 28 64 65 66 69 6e 65 20 28 reated.(define (
2d70: 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 2d 73 65 session:setup-se
2d80: 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 20 ssion-key self)
2d90: 20 0a 20 20 28 6c 65 74 2a 20 28 28 73 6b 20 20 . (let* ((sk
2da0: 28 73 65 73 73 69 6f 6e 3a 65 78 74 72 61 63 74 (session:extract
2db0: 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c -session-key sel
2dc0: 66 29 29 0a 20 20 20 20 20 20 20 20 20 28 73 69 f)). (si
2dd0: 64 20 28 69 66 20 73 6b 20 28 73 65 73 73 69 6f d (if sk (sessio
2de0: 6e 3a 67 65 74 2d 69 64 20 73 65 6c 66 20 73 6b n:get-id self sk
2df0: 29 20 23 66 29 29 29 0a 20 20 20 20 28 69 66 20 ) #f))). (if
2e00: 28 6e 6f 74 20 73 69 64 29 20 3b 3b 20 6e 65 65 (not sid) ;; nee
2e10: 64 20 61 20 6e 65 77 20 6b 65 79 0a 20 20 20 20 d a new key.
2e20: 20 20 20 20 28 6c 65 74 2a 20 28 28 6e 65 77 2d (let* ((new-
2e30: 6b 65 79 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 key (session:get
2e40: 2d 6e 65 77 2d 6b 65 79 20 73 65 6c 66 29 29 0a -new-key self)).
2e50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
2e60: 6e 65 77 2d 73 69 64 20 28 73 65 73 73 69 6f 6e new-sid (session
2e70: 3a 67 65 74 2d 69 64 20 73 65 6c 66 20 6e 65 77 :get-id self new
2e80: 2d 6b 65 79 29 29 29 0a 20 20 20 20 20 20 20 20 -key))).
2e90: 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 (sdat-set-sess
2ea0: 69 6f 6e 2d 6b 65 79 21 20 73 65 6c 66 20 6e 65 ion-key! self ne
2eb0: 77 2d 6b 65 79 29 0a 20 20 20 20 20 20 20 20 20 w-key).
2ec0: 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 (sdat-set-sessi
2ed0: 6f 6e 2d 69 64 21 20 73 65 6c 66 20 6e 65 77 2d on-id! self new-
2ee0: 73 69 64 29 0a 20 20 20 20 20 20 20 20 20 20 28 sid). (
2ef0: 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e sdat-set-session
2f00: 2d 63 6f 6f 6b 69 65 21 20 73 65 6c 66 20 28 73 -cookie! self (s
2f10: 65 73 73 69 6f 6e 3a 6d 61 6b 65 2d 63 6f 6f 6b ession:make-cook
2f20: 69 65 20 73 65 6c 66 29 29 29 0a 20 20 20 20 20 ie self))).
2f30: 20 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 (sdat-set-ses
2f40: 73 69 6f 6e 2d 69 64 21 20 73 65 6c 66 20 73 69 sion-id! self si
2f50: 64 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 d))))..(define (
2f60: 73 65 73 73 69 6f 6e 3a 6d 61 6b 65 2d 63 6f 6f session:make-coo
2f70: 6b 69 65 20 73 65 6c 66 29 0a 20 20 3b 3b 20 28 kie self). ;; (
2f80: 6c 69 73 74 20 28 63 6f 6e 63 20 22 73 65 73 73 list (conc "sess
2f90: 69 6f 6e 5f 6b 65 79 3d 22 20 28 73 64 61 74 2d ion_key=" (sdat-
2fa0: 67 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 get-session-key
2fb0: 73 65 6c 66 29 20 22 3b 20 50 61 74 68 3d 2f 3b self) "; Path=/;
2fc0: 20 44 6f 6d 61 69 6e 3d 2e 22 20 28 73 64 61 74 Domain=." (sdat
2fd0: 2d 67 65 74 2d 64 6f 6d 61 69 6e 20 73 65 6c 66 -get-domain self
2fe0: 29 20 22 3b 20 4d 61 78 2d 41 67 65 3d 22 20 28 ) "; Max-Age=" (
2ff0: 2a 20 38 36 34 30 30 20 31 34 29 20 22 3b 20 56 * 86400 14) "; V
3000: 65 72 73 69 6f 6e 3d 31 22 29 29 29 20 0a 20 20 ersion=1"))) .
3010: 3b 3b 20 41 63 63 6f 72 64 69 6e 67 20 74 6f 20 ;; According to
3020: 0a 20 20 3b 3b 20 20 20 20 68 74 74 70 3a 2f 2f . ;; http://
3030: 77 77 77 2e 63 6f 64 65 6d 61 72 76 65 6c 73 2e www.codemarvels.
3040: 63 6f 6d 2f 32 30 31 30 2f 31 31 2f 61 70 61 63 com/2010/11/apac
3050: 68 65 2d 72 65 77 72 69 74 65 72 75 6c 65 2d 73 he-rewriterule-s
3060: 65 74 2d 61 2d 63 6f 6f 6b 69 65 2d 6f 6e 2d 6c et-a-cookie-on-l
3070: 6f 63 61 6c 68 6f 73 74 2f 0a 0a 20 20 3b 3b 20 ocalhost/.. ;;
3080: 20 48 65 72 65 20 61 72 65 20 74 68 65 20 32 20 Here are the 2
3090: 28 6f 66 74 65 6e 20 6c 65 66 74 20 6f 75 74 29 (often left out)
30a0: 20 72 65 71 75 69 72 65 6d 65 6e 74 73 20 74 6f requirements to
30b0: 20 73 65 74 20 61 20 63 6f 6f 6b 69 65 20 75 73 set a cookie us
30c0: 69 6e 67 0a 20 20 3b 3b 20 20 68 74 74 70 64 1b ing. ;; httpd.
30d0: 2d 46 a2 73 20 72 65 77 72 69 74 65 20 72 75 6c -F˘s rewrite rul
30e0: 65 20 28 6d 6f 64 5f 72 65 77 72 69 74 65 29 2c e (mod_rewrite),
30f0: 20 77 68 69 6c 65 20 77 6f 72 6b 69 6e 67 20 6f while working o
3100: 6e 20 6c 6f 63 61 6c 68 6f 73 74 3a 1b 2d 41 0a n localhost:.-A.
3110: 20 20 3b 3b 0a 20 20 3b 3b 20 20 55 73 65 20 74 ;;. ;; Use t
3120: 68 65 20 49 50 20 31 32 37 2e 30 2e 30 2e 31 20 he IP 127.0.0.1
3130: 69 6e 73 74 65 61 64 20 6f 66 20 6c 6f 63 61 6c instead of local
3140: 68 6f 73 74 2f 6d 61 63 68 69 6e 65 2d 6e 61 6d host/machine-nam
3150: 65 20 61 73 20 74 68 65 0a 20 20 3b 3b 20 20 64 e as the. ;; d
3160: 6f 6d 61 69 6e 3b 20 65 2e 67 2e 20 5b 43 4f 3d omain; e.g. [CO=
3170: 73 6f 6d 65 43 6f 6f 6b 69 65 3a 73 6f 6d 65 56 someCookie:someV
3180: 61 6c 75 65 3a 31 32 37 2e 30 2e 30 2e 31 3a 32 alue:127.0.0.1:2
3190: 3a 2f 5d 2c 20 77 68 69 63 68 20 73 61 79 73 0a :/], which says.
31a0: 20 20 3b 3b 20 20 63 72 65 61 74 65 20 61 20 63 ;; create a c
31b0: 6f 6f 6b 69 65 20 1b 2d 59 b4 73 6f 6d 65 43 6f ookie .-Y´someCo
31c0: 6f 6b 69 65 a1 20 77 69 74 68 20 76 61 6c 75 65 okieˇ with value
31d0: 20 b4 73 6f 6d 65 56 61 6c 75 65 a1 20 66 6f 72 ´someValueˇ for
31e0: 20 74 68 65 0a 20 20 3b 3b 20 20 64 6f 6d 61 69 the. ;; domai
31f0: 6e 20 b4 31 32 37 2e 30 2e 30 2e 31 1b 24 42 21 n ´127.0.0.1.$B!
3200: 6d 1b 28 42 20 68 61 76 69 6e 67 20 61 20 6c 69 m.(B having a li
3210: 66 65 20 74 69 6d 65 20 6f 66 20 32 20 6d 69 6e fe time of 2 min
3220: 73 2c 20 66 6f 72 20 61 6e 79 20 70 61 74 68 20 s, for any path
3230: 69 6e 0a 20 20 3b 3b 20 20 74 68 65 20 64 6f 6d in. ;; the dom
3240: 61 69 6e 20 28 70 61 74 68 3d 2f 29 2e 20 28 4f ain (path=/). (O
3250: 62 76 69 6f 75 73 6c 79 20 79 6f 75 20 77 69 6c bviously you wil
3260: 6c 20 68 61 76 65 20 74 6f 20 72 75 6e 20 74 68 l have to run th
3270: 65 0a 20 20 3b 3b 20 20 61 70 70 6c 69 63 61 74 e. ;; applicat
3280: 69 6f 6e 20 77 69 74 68 20 74 68 69 73 20 76 61 ion with this va
3290: 6c 75 65 20 69 6e 20 74 68 65 20 55 52 4c 29 0a lue in the URL).
32a0: 20 20 3b 3b 0a 20 20 3b 3b 20 20 54 6f 20 6d 61 ;;. ;; To ma
32b0: 6b 65 20 61 20 73 65 73 73 69 6f 6e 20 63 6f 6f ke a session coo
32c0: 6b 69 65 2c 20 6c 69 6d 69 74 20 74 68 65 20 66 kie, limit the f
32d0: 6c 61 67 20 73 74 61 74 65 6d 65 6e 74 20 74 6f lag statement to
32e0: 20 6a 75 73 74 20 74 68 72 65 65 0a 20 20 3b 3b just three. ;;
32f0: 20 20 61 74 74 72 69 62 75 74 65 73 3a 20 6e 61 attributes: na
3300: 6d 65 2c 20 76 61 6c 75 65 20 61 6e 64 20 64 6f me, value and do
3310: 6d 61 69 6e 2e 20 65 2e 67 0a 20 20 3b 3b 20 20 main. e.g. ;;
3320: 5b 43 4f 3d 73 6f 6d 65 43 6f 6f 6b 69 65 3a 73 [CO=someCookie:s
3330: 6f 6d 65 56 61 6c 75 65 3a 31 32 37 2e 30 2e 30 omeValue:127.0.0
3340: 2e 31 5d 20 1b 25 47 e2 80 93 1b 25 40 20 41 6e .1] .%G–.%@ An
3350: 79 20 66 75 72 74 68 65 72 0a 20 20 3b 3b 20 20 y further. ;;
3360: 73 65 74 74 69 6e 67 73 2c 20 61 70 61 63 68 65 settings, apache
3370: 20 77 72 69 74 65 73 20 61 6e a1 20 65 78 70 69 writes anˇ expi
3380: 72 65 73 a1 20 61 74 74 72 69 62 75 74 65 20 66 resˇ attribute f
3390: 6f 72 20 74 68 65 20 73 65 74 2d 63 6f 6f 6b 69 or the set-cooki
33a0: 65 0a 20 20 3b 3b 20 20 68 65 61 64 65 72 2c 20 e. ;; header,
33b0: 77 68 69 63 68 20 6d 61 6b 65 73 20 74 68 65 20 which makes the
33c0: 63 6f 6f 6b 69 65 20 61 20 70 65 72 73 69 73 74 cookie a persist
33d0: 65 6e 74 20 6f 6e 65 20 28 6e 6f 74 20 72 65 61 ent one (not rea
33e0: 6c 6c 79 0a 20 20 3b 3b 20 20 70 65 72 73 69 73 lly. ;; persis
33f0: 74 65 6e 74 2c 20 61 73 20 74 68 65 20 65 78 70 tent, as the exp
3400: 69 72 65 73 20 76 61 6c 75 65 20 73 65 74 20 69 ires value set i
3410: 73 20 74 68 65 20 63 75 72 72 65 6e 74 20 73 65 s the current se
3420: 72 76 65 72 20 74 69 6d 65 0a 20 20 3b 3b 20 20 rver time. ;;
3430: 1b 25 47 e2 80 93 1b 25 40 20 73 6f 20 79 6f 75 .%G–.%@ so you
3440: 20 64 6f 6e 1b 2d 46 1b 2d 46 a2 74 20 65 76 65 don.-F.-F˘t eve
3450: 6e 20 67 65 74 20 74 6f 20 73 65 65 20 79 6f 75 n get to see you
3460: 72 20 63 6f 6f 6b 69 65 21 29 1b 2d 41 0a 20 20 r cookie!).-A.
3470: 28 6c 69 73 74 20 28 73 74 72 69 6e 67 2d 73 75 (list (string-su
3480: 62 73 74 69 74 75 74 65 20 0a 09 20 22 3b 22 20 bstitute .. ";"
3490: 22 3b 20 22 20 0a 09 20 28 63 61 72 20 28 63 6f "; " .. (car (co
34a0: 6e 73 74 72 75 63 74 2d 63 6f 6f 6b 69 65 2d 73 nstruct-cookie-s
34b0: 74 72 69 6e 67 20 0a 09 20 20 20 20 20 20 20 3b tring .. ;
34c0: 3b 20 77 61 72 6e 69 6e 67 21 20 6d 65 73 73 69 ; warning! messi
34d0: 6e 67 20 75 70 20 74 68 69 73 20 69 74 74 79 20 ng up this itty
34e0: 62 69 74 74 79 20 62 69 74 20 6f 66 20 63 6f 64 bitty bit of cod
34f0: 65 20 77 69 6c 6c 20 63 6f 73 74 20 6d 75 63 68 e will cost much
3500: 20 74 69 6d 65 21 0a 09 20 20 20 20 20 20 20 60 time!.. `
3510: 28 28 22 73 65 73 73 69 6f 6e 5f 6b 65 79 22 20 (("session_key"
3520: 2c 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 ,(sdat-get-sessi
3530: 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 0a 09 09 20 on-key self)...
3540: 20 65 78 70 69 72 65 73 3a 20 2c 28 2b 20 28 63 expires: ,(+ (c
3550: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 urrent-seconds)
3560: 28 2a 20 31 34 20 38 36 34 30 30 29 29 20 0a 09 (* 14 86400)) ..
3570: 09 20 20 3b 3b 20 6d 61 78 2d 61 67 65 3a 20 28 . ;; max-age: (
3580: 2a 20 31 34 20 38 36 34 30 30 29 0a 09 09 20 20 * 14 86400)...
3590: 70 61 74 68 3a 20 22 2f 22 20 3b 3b 20 0a 09 09 path: "/" ;; ...
35a0: 20 20 64 6f 6d 61 69 6e 3a 20 2c 28 73 74 72 69 domain: ,(stri
35b0: 6e 67 2d 61 70 70 65 6e 64 20 22 2e 22 20 28 73 ng-append "." (s
35c0: 64 61 74 2d 67 65 74 2d 64 6f 6d 61 69 6e 20 73 dat-get-domain s
35d0: 65 6c 66 29 29 0a 09 09 20 20 76 65 72 73 69 6f elf))... versio
35e0: 6e 3a 20 31 29 29 20 30 29 29 29 29 29 0a 0a 3b n: 1)) 0)))))..;
35f0: 3b 20 6c 6f 6f 6b 20 75 70 20 61 20 67 69 76 65 ; look up a give
3600: 6e 20 73 65 73 73 69 6f 6e 20 6b 65 79 20 61 6e n session key an
3610: 64 20 72 65 74 75 72 6e 20 74 68 65 20 69 64 20 d return the id
3620: 69 66 20 66 6f 75 6e 64 2c 20 23 66 20 69 66 20 if found, #f if
3630: 6e 6f 74 20 66 6f 75 6e 64 0a 28 64 65 66 69 6e not found.(defin
3640: 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 69 e (session:get-i
3650: 64 20 73 65 6c 66 20 73 65 73 73 69 6f 6e 2d 6b d self session-k
3660: 65 79 29 0a 20 20 3b 3b 20 28 6c 65 74 20 28 28 ey). ;; (let ((
3670: 73 65 73 73 69 6f 6e 2d 6b 65 79 20 28 73 64 61 session-key (sda
3680: 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 t-get-session-ke
3690: 79 20 73 65 6c 66 29 29 29 0a 20 20 28 69 66 20 y self))). (if
36a0: 73 65 73 73 69 6f 6e 2d 6b 65 79 0a 20 20 20 20 session-key.
36b0: 20 20 28 6c 65 74 20 28 28 71 75 65 72 79 20 28 (let ((query (
36c0: 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 22 53 string-append "S
36d0: 45 4c 45 43 54 20 69 64 20 46 52 4f 4d 20 73 65 ELECT id FROM se
36e0: 73 73 69 6f 6e 73 20 57 48 45 52 45 20 73 65 73 ssions WHERE ses
36f0: 73 69 6f 6e 5f 6b 65 79 3d 27 22 20 73 65 73 73 sion_key='" sess
3700: 69 6f 6e 2d 6b 65 79 20 22 27 22 29 29 0a 20 20 ion-key "'")).
3710: 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 6e 20 (conn
3720: 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 (sdat-get-conn s
3730: 65 6c 66 29 29 0a 20 20 20 20 20 20 20 20 20 20 elf)).
3740: 20 20 28 72 65 73 75 6c 74 20 23 66 29 29 0a 09 (result #f))..
3750: 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f (dbi:for-each-ro
3760: 77 20 0a 09 20 28 6c 61 6d 62 64 61 20 28 74 75 w .. (lambda (tu
3770: 70 6c 65 29 0a 09 20 20 20 28 73 65 74 21 20 72 ple).. (set! r
3780: 65 73 75 6c 74 20 28 76 65 63 74 6f 72 2d 72 65 esult (vector-re
3790: 66 20 74 75 70 6c 65 20 30 29 29 29 0a 09 20 63 f tuple 0))).. c
37a0: 6f 6e 6e 20 71 75 65 72 79 29 0a 09 28 69 66 20 onn query)..(if
37b0: 72 65 73 75 6c 74 20 28 64 62 69 3a 65 78 65 63 result (dbi:exec
37c0: 20 63 6f 6e 6e 20 28 63 6f 6e 63 20 22 55 50 44 conn (conc "UPD
37d0: 41 54 45 20 73 65 73 73 69 6f 6e 73 20 53 45 54 ATE sessions SET
37e0: 20 6c 61 73 74 5f 75 73 65 64 3d 22 20 28 64 62 last_used=" (db
37f0: 69 3a 6e 6f 77 20 63 6f 6e 6e 29 20 22 20 57 48 i:now conn) " WH
3800: 45 52 45 20 73 65 73 73 69 6f 6e 5f 6b 65 79 3d ERE session_key=
3810: 3f 3b 22 29 20 73 65 73 73 69 6f 6e 2d 6b 65 79 ?;") session-key
3820: 29 29 0a 20 20 20 20 20 20 20 20 72 65 73 75 6c )). resul
3830: 74 29 0a 20 20 20 20 20 20 23 66 29 29 0a 0a 3b t). #f))..;
3840: 3b 20 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 ; .(define (sess
3850: 69 6f 6e 3a 70 72 6f 63 65 73 73 2d 75 72 6c 2d ion:process-url-
3860: 70 61 74 68 20 73 65 6c 66 29 0a 20 20 28 6c 65 path self). (le
3870: 74 20 28 28 70 61 74 68 2d 69 6e 66 6f 20 20 20 t ((path-info
3880: 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e (get-environmen
3890: 74 2d 76 61 72 69 61 62 6c 65 20 22 50 41 54 48 t-variable "PATH
38a0: 5f 49 4e 46 4f 22 29 29 0a 09 28 71 75 65 72 79 _INFO"))..(query
38b0: 2d 73 74 72 69 6e 67 20 28 67 65 74 2d 65 6e 76 -string (get-env
38c0: 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c ironment-variabl
38d0: 65 20 22 51 55 45 52 59 5f 53 54 52 49 4e 47 22 e "QUERY_STRING"
38e0: 29 29 29 0a 20 20 20 20 3b 3b 20 28 73 65 73 73 ))). ;; (sess
38f0: 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 70 61 ion:log self "pa
3900: 74 68 2d 69 6e 66 6f 3d 22 20 70 61 74 68 2d 69 th-info=" path-i
3910: 6e 66 6f 20 22 20 71 75 65 72 79 2d 73 74 72 69 nfo " query-stri
3920: 6e 67 3d 22 20 71 75 65 72 79 2d 73 74 72 69 6e ng=" query-strin
3930: 67 29 0a 20 20 20 20 28 69 66 20 70 61 74 68 2d g). (if path-
3940: 69 6e 66 6f 0a 09 28 6c 65 74 2a 20 28 28 70 61 info..(let* ((pa
3950: 72 74 73 20 20 20 20 28 73 74 72 69 6e 67 2d 73 rts (string-s
3960: 70 6c 69 74 20 70 61 74 68 2d 69 6e 66 6f 20 22 plit path-info "
3970: 2f 22 29 29 0a 09 20 20 20 20 20 20 20 28 6e 75 /")).. (nu
3980: 6d 70 61 72 74 73 20 28 6c 65 6e 67 74 68 20 70 mparts (length p
3990: 61 72 74 73 29 29 29 0a 09 20 20 28 69 66 20 28 arts))).. (if (
39a0: 3e 20 6e 75 6d 70 61 72 74 73 20 30 29 0a 09 20 > numparts 0)..
39b0: 20 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d 70 (sdat-set-p
39c0: 61 67 65 21 20 73 65 6c 66 20 28 63 61 72 20 70 age! self (car p
39d0: 61 72 74 73 29 29 29 0a 09 20 20 3b 3b 20 28 73 arts))).. ;; (s
39e0: 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 ession:log self
39f0: 22 75 72 6c 2d 70 61 74 68 3d 22 20 75 72 6c 2d "url-path=" url-
3a00: 70 61 74 68 20 22 20 70 61 72 74 73 3d 22 20 70 path " parts=" p
3a10: 61 72 74 73 29 0a 09 20 20 28 69 66 20 28 3e 20 arts).. (if (>
3a20: 6e 75 6d 70 61 72 74 73 20 31 29 0a 09 20 20 20 numparts 1)..
3a30: 20 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 74 (sdat-set-pat
3a40: 68 2d 70 61 72 61 6d 73 21 20 73 65 6c 66 20 28 h-params! self (
3a50: 63 64 72 20 70 61 72 74 73 29 29 29 0a 20 20 20 cdr parts))).
3a60: 20 20 20 20 20 20 20 28 69 66 20 71 75 65 72 79 (if query
3a70: 2d 73 74 72 69 6e 67 0a 20 20 20 20 20 20 20 20 -string.
3a80: 20 20 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d (sdat-set-
3a90: 70 61 72 61 6d 73 21 20 73 65 6c 66 20 28 73 74 params! self (st
3aa0: 72 69 6e 67 2d 73 70 6c 69 74 20 71 75 65 72 79 ring-split query
3ab0: 2d 73 74 72 69 6e 67 20 22 26 22 29 29 29 29 29 -string "&")))))
3ac0: 29 29 0a 0a 3b 3b 20 42 55 47 47 59 21 0a 28 64 ))..;; BUGGY!.(d
3ad0: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 efine (session:g
3ae0: 65 74 2d 6e 65 77 2d 6b 65 79 20 73 65 6c 66 29 et-new-key self)
3af0: 0a 20 20 28 6c 65 74 20 28 28 63 6f 6e 6e 20 20 . (let ((conn
3b00: 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 (sdat-get-conn
3b10: 73 65 6c 66 29 29 0a 20 20 20 20 20 20 20 20 28 self)). (
3b20: 74 6d 70 6b 65 79 20 28 73 65 73 73 69 6f 6e 3a tmpkey (session:
3b30: 6d 61 6b 65 2d 72 61 6e 64 2d 73 74 72 69 6e 67 make-rand-string
3b40: 20 32 30 29 29 0a 20 20 20 20 20 20 20 20 28 73 20)). (s
3b50: 74 61 74 75 73 20 23 66 29 29 0a 20 20 20 20 28 tatus #f)). (
3b60: 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 dbi:for-each-row
3b70: 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 29 (lambda (tuple)
3b80: 0a 09 09 09 28 73 65 74 21 20 73 74 61 74 75 73 ....(set! status
3b90: 20 23 74 29 29 0a 09 09 20 20 20 20 20 20 63 6f #t))... co
3ba0: 6e 6e 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e nn (string-appen
3bb0: 64 20 22 49 4e 53 45 52 54 20 49 4e 54 4f 20 73 d "INSERT INTO s
3bc0: 65 73 73 69 6f 6e 73 20 28 73 65 73 73 69 6f 6e essions (session
3bd0: 5f 6b 65 79 29 20 56 41 4c 55 45 53 20 28 27 22 _key) VALUES ('"
3be0: 20 74 6d 70 6b 65 79 20 22 27 29 22 29 29 0a 20 tmpkey "')")).
3bf0: 20 20 20 74 6d 70 6b 65 79 29 29 0a 0a 3b 3b 20 tmpkey))..;;
3c00: 72 65 74 75 72 6e 73 20 73 65 73 73 69 6f 6e 20 returns session
3c10: 6b 65 79 20 49 46 46 20 69 74 20 69 73 20 69 6e key IFF it is in
3c20: 20 74 68 65 20 48 54 54 50 5f 43 4f 4f 4b 49 45 the HTTP_COOKIE
3c30: 20 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 .(define (sessi
3c40: 6f 6e 3a 65 78 74 72 61 63 74 2d 73 65 73 73 69 on:extract-sessi
3c50: 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 0a 20 20 28 on-key self). (
3c60: 6c 65 74 20 28 28 68 74 74 70 2d 63 6f 6f 6b 69 let ((http-cooki
3c70: 65 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 e (get-environme
3c80: 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 48 54 54 nt-variable "HTT
3c90: 50 5f 43 4f 4f 4b 49 45 22 29 29 29 0a 20 20 20 P_COOKIE"))).
3ca0: 20 3b 3b 20 28 65 72 72 3a 6c 6f 67 20 22 68 74 ;; (err:log "ht
3cb0: 74 70 2d 63 6f 6f 6b 69 65 3a 20 22 20 68 74 74 tp-cookie: " htt
3cc0: 70 2d 63 6f 6f 6b 69 65 29 0a 20 20 20 20 28 69 p-cookie). (i
3cd0: 66 20 68 74 74 70 2d 63 6f 6f 6b 69 65 0a 20 20 f http-cookie.
3ce0: 20 20 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 65 (session:e
3cf0: 78 74 72 61 63 74 2d 6b 65 79 2d 66 72 6f 6d 2d xtract-key-from-
3d00: 70 61 72 61 6d 20 73 65 6c 66 20 28 73 74 72 69 param self (stri
3d10: 6e 67 2d 73 70 6c 69 74 2d 66 69 65 6c 64 73 20 ng-split-fields
3d20: 20 22 3b 5c 5c 73 2b 22 20 68 74 74 70 2d 63 6f ";\\s+" http-co
3d30: 6f 6b 69 65 20 69 6e 66 69 78 3a 29 20 22 73 65 okie infix:) "se
3d40: 73 73 69 6f 6e 5f 6b 65 79 22 29 0a 20 20 20 20 ssion_key").
3d50: 20 20 20 20 23 66 29 29 29 0a 0a 28 64 65 66 69 #f)))..(defi
3d60: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d ne (session:get-
3d70: 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 20 session-id self
3d80: 73 65 73 73 69 6f 6e 2d 6b 65 79 29 0a 20 20 28 session-key). (
3d90: 6c 65 74 20 28 28 71 75 65 72 79 20 22 53 45 4c let ((query "SEL
3da0: 45 43 54 20 69 64 20 46 52 4f 4d 20 73 65 73 73 ECT id FROM sess
3db0: 69 6f 6e 73 20 57 48 45 52 45 20 73 65 73 73 69 ions WHERE sessi
3dc0: 6f 6e 5f 6b 65 79 3d 3f 3b 22 29 0a 20 20 20 20 on_key=?;").
3dd0: 20 20 20 20 28 72 65 73 75 6c 74 20 23 66 29 29 (result #f))
3de0: 0a 20 20 20 20 3b 3b 20 20 20 20 20 28 70 67 3a . ;; (pg:
3df0: 71 75 65 72 79 2d 66 6f 72 2d 65 61 63 68 20 28 query-for-each (
3e00: 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 29 0a 20 lambda (tuple).
3e10: 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 ;;
3e20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
3e30: 73 65 74 21 20 72 65 73 75 6c 74 20 28 76 65 63 set! result (vec
3e40: 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 30 29 tor-ref tuple 0)
3e50: 29 29 20 3b 3b 20 28 76 65 63 74 6f 72 2d 72 65 )) ;; (vector-re
3e60: 66 20 74 75 70 6c 65 20 30 29 29 29 0a 20 20 20 f tuple 0))).
3e70: 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
3e80: 20 20 20 20 20 20 20 20 20 20 20 28 73 3a 73 71 (s:sq
3e90: 6c 70 61 72 61 6d 20 71 75 65 72 79 20 73 65 73 lparam query ses
3ea0: 73 69 6f 6e 2d 6b 65 79 29 0a 20 20 20 20 3b 3b sion-key). ;;
3eb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3ec0: 20 20 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 (sdat-ge
3ed0: 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 0a 20 20 t-conn self)).
3ee0: 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 ;;
3ef0: 20 20 20 20 20 20 20 20 20 20 20 20 63 6f 6e 6e conn
3f00: 29 0a 20 20 20 20 28 64 62 69 3a 66 6f 72 2d 65 ). (dbi:for-e
3f10: 61 63 68 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 ach-row (lambda
3f20: 28 74 75 70 6c 65 29 0a 09 09 09 28 73 65 74 21 (tuple)....(set!
3f30: 20 72 65 73 75 6c 74 20 28 76 65 63 74 6f 72 2d result (vector-
3f40: 72 65 66 20 74 75 70 6c 65 20 30 29 29 29 20 3b ref tuple 0))) ;
3f50: 3b 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 75 ; (vector-ref tu
3f60: 70 6c 65 20 30 29 29 29 0a 09 09 20 20 20 20 20 ple 0)))...
3f70: 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 (sdat-get-conn
3f80: 73 65 6c 66 29 0a 09 09 20 20 20 20 20 20 28 73 self)... (s
3f90: 3a 73 71 6c 70 61 72 61 6d 20 71 75 65 72 79 20 :sqlparam query
3fa0: 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 0a 20 20 session-key)).
3fb0: 20 20 72 65 73 75 6c 74 29 29 0a 0a 3b 3b 20 64 result))..;; d
3fc0: 65 6c 65 74 65 20 61 6c 6c 20 72 65 63 6f 72 64 elete all record
3fd0: 73 20 66 6f 72 20 61 20 73 65 73 73 69 6f 6e 0a s for a session.
3fe0: 3b 3b 20 0a 3b 3b 20 4e 45 45 44 53 20 54 4f 20 ;; .;; NEEDS TO
3ff0: 42 45 20 54 52 41 4e 53 41 43 54 49 4f 4e 49 5a BE TRANSACTIONIZ
4000: 45 44 21 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 ED!.;;.(define (
4010: 73 65 73 73 69 6f 6e 3a 64 65 6c 65 74 65 2d 73 session:delete-s
4020: 65 73 73 69 6f 6e 20 73 65 6c 66 20 73 65 73 73 ession self sess
4030: 69 6f 6e 2d 6b 65 79 29 0a 20 20 28 6c 65 74 20 ion-key). (let
4040: 28 28 73 65 73 73 69 6f 6e 2d 69 64 20 28 73 65 ((session-id (se
4050: 73 73 69 6f 6e 3a 67 65 74 2d 73 65 73 73 69 6f ssion:get-sessio
4060: 6e 2d 69 64 20 73 65 6c 66 20 73 65 73 73 69 6f n-id self sessio
4070: 6e 2d 6b 65 79 29 29 0a 20 20 20 20 20 20 20 20 n-key)).
4080: 28 71 72 79 31 20 20 20 20 20 20 20 20 3b 3b 20 (qry1 ;;
4090: 28 63 6f 6e 63 20 22 42 45 47 49 4e 3b 22 0a 09 (conc "BEGIN;"..
40a0: 09 09 20 20 22 44 45 4c 45 54 45 20 46 52 4f 4d .. "DELETE FROM
40b0: 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 57 48 session_vars WH
40c0: 45 52 45 20 73 65 73 73 69 6f 6e 5f 69 64 3d 3f ERE session_id=?
40d0: 3b 22 29 0a 09 28 71 72 79 32 20 20 20 20 20 20 ;")..(qry2
40e0: 20 20 20 20 20 20 20 22 44 45 4c 45 54 45 20 46 "DELETE F
40f0: 52 4f 4d 20 73 65 73 73 69 6f 6e 73 20 57 48 45 ROM sessions WHE
4100: 52 45 20 69 64 3d 3f 3b 22 29 0a 09 09 20 20 20 RE id=?;")...
4110: 20 20 3b 3b 20 20 22 43 4f 4d 4d 49 54 3b 22 29 ;; "COMMIT;")
4120: 29 0a 20 20 20 20 20 20 20 20 28 63 6f 6e 6e 20 ). (conn
4130: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 64 (sd
4140: 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 at-get-conn self
4150: 29 29 29 0a 20 20 20 20 28 69 66 20 73 65 73 73 ))). (if sess
4160: 69 6f 6e 2d 69 64 0a 20 20 20 20 20 20 20 20 28 ion-id. (
4170: 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 begin.
4180: 28 64 62 69 3a 65 78 65 63 20 63 6f 6e 6e 20 71 (dbi:exec conn q
4190: 72 79 31 20 73 65 73 73 69 6f 6e 2d 69 64 29 20 ry1 session-id)
41a0: 3b 3b 20 73 65 73 73 69 6f 6e 2d 69 64 29 0a 09 ;; session-id)..
41b0: 20 20 28 64 62 69 3a 65 78 65 63 20 63 6f 6e 6e (dbi:exec conn
41c0: 20 71 72 79 32 20 73 65 73 73 69 6f 6e 2d 69 64 qry2 session-id
41d0: 29 0a 09 20 20 28 73 65 73 73 69 6f 6e 3a 69 6e ).. (session:in
41e0: 69 74 69 61 6c 69 7a 65 20 73 65 6c 66 29 0a 09 itialize self)..
41f0: 20 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 (session:setup
4200: 20 73 65 6c 66 29 29 29 0a 20 20 20 20 28 6e 6f self))). (no
4210: 74 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 73 t (session:get-s
4220: 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 20 73 ession-id self s
4230: 65 73 73 69 6f 6e 2d 6b 65 79 29 29 29 29 0a 0a ession-key))))..
4240: 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 65 73 73 ;; (define (sess
4250: 69 6f 6e 3a 64 65 6c 65 74 65 2d 73 65 73 73 69 ion:delete-sessi
4260: 6f 6e 20 73 65 6c 66 20 73 65 73 73 69 6f 6e 2d on self session-
4270: 6b 65 79 29 0a 3b 3b 20 20 20 28 6c 65 74 20 28 key).;; (let (
4280: 28 73 65 73 73 69 6f 6e 2d 69 64 20 28 73 65 73 (session-id (ses
4290: 73 69 6f 6e 3a 67 65 74 2d 73 65 73 73 69 6f 6e sion:get-session
42a0: 2d 69 64 20 73 65 6c 66 20 73 65 73 73 69 6f 6e -id self session
42b0: 2d 6b 65 79 29 29 0a 3b 3b 20 20 20 20 20 20 20 -key)).;;
42c0: 20 20 28 71 75 65 72 69 65 73 20 20 20 20 28 6c (queries (l
42d0: 69 73 74 20 22 42 45 47 49 4e 3b 22 0a 3b 3b 20 ist "BEGIN;".;;
42e0: 09 09 09 20 20 22 44 45 4c 45 54 45 20 46 52 4f ... "DELETE FRO
42f0: 4d 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 57 M session_vars W
4300: 48 45 52 45 20 73 65 73 73 69 6f 6e 5f 69 64 3d HERE session_id=
4310: 3f 3b 22 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 ?;".;;
4320: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4330: 20 22 44 45 4c 45 54 45 20 46 52 4f 4d 20 73 65 "DELETE FROM se
4340: 73 73 69 6f 6e 73 20 57 48 45 52 45 20 69 64 3d ssions WHERE id=
4350: 3f 3b 22 0a 3b 3b 20 09 09 09 20 20 22 43 4f 4d ?;".;; ... "COM
4360: 4d 49 54 3b 22 29 29 0a 3b 3b 20 20 20 20 20 20 MIT;")).;;
4370: 20 20 20 28 63 6f 6e 6e 20 20 20 20 20 20 20 20 (conn
4380: 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d (sdat-get-
4390: 63 6f 6e 6e 20 73 65 6c 66 29 29 29 0a 3b 3b 20 conn self))).;;
43a0: 20 20 20 20 28 69 66 20 73 65 73 73 69 6f 6e 2d (if session-
43b0: 69 64 0a 3b 3b 20 20 20 20 20 20 20 20 20 28 62 id.;; (b
43c0: 65 67 69 6e 0a 3b 3b 20 20 20 20 20 20 20 20 20 egin.;;
43d0: 20 20 28 66 6f 72 2d 65 61 63 68 0a 3b 3b 20 20 (for-each.;;
43e0: 20 20 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 (lambd
43f0: 61 20 28 71 75 65 72 79 29 0a 3b 3b 20 20 20 20 a (query).;;
4400: 20 20 20 20 20 20 20 20 20 20 28 64 62 69 3a 65 (dbi:e
4410: 78 65 63 20 63 6f 6e 6e 20 71 75 65 72 79 20 73 xec conn query s
4420: 65 73 73 69 6f 6e 2d 69 64 29 29 0a 3b 3b 20 09 ession-id)).;; .
4430: 20 20 20 71 75 65 72 69 65 73 29 0a 3b 3b 20 09 queries).;; .
4440: 20 20 28 69 6e 69 74 69 61 6c 69 7a 65 20 73 65 (initialize se
4450: 6c 66 20 27 28 29 29 0a 3b 3b 20 09 20 20 28 73 lf '()).;; . (s
4460: 65 73 73 69 6f 6e 3a 73 65 74 75 70 20 73 65 6c ession:setup sel
4470: 66 29 29 29 0a 3b 3b 20 20 20 20 20 28 6e 6f 74 f))).;; (not
4480: 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 73 65 (session:get-se
4490: 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 20 73 65 ssion-id self se
44a0: 73 73 69 6f 6e 2d 6b 65 79 29 29 29 29 0a 0a 28 ssion-key))))..(
44b0: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
44c0: 65 78 74 72 61 63 74 2d 6b 65 79 20 73 65 6c 66 extract-key self
44d0: 20 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 28 70 key). (let ((p
44e0: 61 72 61 6d 73 20 28 73 64 61 74 2d 67 65 74 2d arams (sdat-get-
44f0: 70 61 72 61 6d 73 20 73 65 6c 66 29 29 29 0a 20 params self))).
4500: 20 20 20 28 73 65 73 73 69 6f 6e 3a 65 78 74 72 (session:extr
4510: 61 63 74 2d 6b 65 79 2d 66 72 6f 6d 2d 70 61 72 act-key-from-par
4520: 61 6d 20 73 65 6c 66 20 70 61 72 61 6d 73 20 6b am self params k
4530: 65 79 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 ey)))..(define (
4540: 73 65 73 73 69 6f 6e 3a 65 78 74 72 61 63 74 2d session:extract-
4550: 6b 65 79 2d 66 72 6f 6d 2d 70 61 72 61 6d 20 73 key-from-param s
4560: 65 6c 66 20 70 61 72 61 6d 73 20 6b 65 79 29 0a elf params key).
4570: 20 20 28 6c 65 74 20 28 28 72 31 20 20 20 20 20 (let ((r1
4580: 28 72 65 67 65 78 70 20 28 73 74 72 69 6e 67 2d (regexp (string-
4590: 61 70 70 65 6e 64 20 22 5e 22 20 6b 65 79 20 22 append "^" key "
45a0: 3d 28 5b 5e 3d 5d 2b 29 24 22 29 29 29 29 0a 20 =([^=]+)$")))).
45b0: 20 20 20 28 65 72 72 3a 6c 6f 67 20 22 49 4e 46 (err:log "INF
45c0: 4f 3a 20 4c 6f 6f 6b 69 6e 67 20 66 6f 72 20 22 O: Looking for "
45d0: 20 6b 65 79 20 22 20 69 6e 20 22 20 70 61 72 61 key " in " para
45e0: 6d 73 29 0a 20 20 20 20 28 69 66 20 28 3c 20 28 ms). (if (< (
45f0: 6c 65 6e 67 74 68 20 70 61 72 61 6d 73 29 20 31 length params) 1
4600: 29 20 23 66 0a 09 28 6c 65 74 20 6c 6f 6f 70 20 ) #f..(let loop
4610: 28 28 68 65 61 64 20 20 20 28 63 61 72 20 70 61 ((head (car pa
4620: 72 61 6d 73 29 29 0a 09 09 20 20 20 28 74 61 69 rams))... (tai
4630: 6c 20 20 20 28 63 64 72 20 70 61 72 61 6d 73 29 l (cdr params)
4640: 29 29 0a 09 20 20 28 6c 65 74 20 28 28 6d 61 74 )).. (let ((mat
4650: 63 68 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 ch (string-match
4660: 20 72 31 20 68 65 61 64 29 29 29 0a 09 20 20 20 r1 head)))..
4670: 20 28 63 6f 6e 64 0a 09 20 20 20 20 20 28 6d 61 (cond.. (ma
4680: 74 63 68 0a 09 20 20 20 20 20 20 28 6c 65 74 20 tch.. (let
4690: 28 28 73 65 73 73 69 6f 6e 2d 6b 65 79 20 28 6c ((session-key (l
46a0: 69 73 74 2d 72 65 66 20 6d 61 74 63 68 20 31 29 ist-ref match 1)
46b0: 29 29 0a 09 09 28 65 72 72 3a 6c 6f 67 20 22 49 ))...(err:log "I
46c0: 4e 46 4f 3a 20 46 6f 75 6e 64 20 73 65 73 73 69 NFO: Found sessi
46d0: 6f 6e 20 6b 65 79 3d 22 20 73 65 73 73 69 6f 6e on key=" session
46e0: 2d 6b 65 79 29 0a 09 09 28 73 64 61 74 2d 73 65 -key)...(sdat-se
46f0: 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 21 20 73 t-session-key! s
4700: 65 6c 66 20 28 6c 69 73 74 2d 72 65 66 20 6d 61 elf (list-ref ma
4710: 74 63 68 20 31 29 29 0a 09 09 73 65 73 73 69 6f tch 1))...sessio
4720: 6e 2d 6b 65 79 29 29 0a 09 20 20 20 20 20 28 28 n-key)).. ((
4730: 6e 75 6c 6c 3f 20 74 61 69 6c 29 0a 09 20 20 20 null? tail)..
4740: 20 20 20 23 66 29 0a 09 20 20 20 20 20 28 65 6c #f).. (el
4750: 73 65 0a 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 se.. (loop
4760: 28 63 61 72 20 74 61 69 6c 29 0a 09 09 20 20 20 (car tail)...
4770: 20 28 63 64 72 20 74 61 69 6c 29 29 29 29 29 29 (cdr tail))))))
4780: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 )))..(define (se
4790: 73 73 69 6f 6e 3a 73 65 74 2d 70 61 67 65 21 20 ssion:set-page!
47a0: 73 65 6c 66 20 70 61 67 65 5f 6e 61 6d 65 29 0a self page_name).
47b0: 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 (sdat-set-page
47c0: 21 20 73 65 6c 66 20 70 61 67 65 5f 6e 61 6d 65 ! self page_name
47d0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 ))..(define (ses
47e0: 73 69 6f 6e 3a 63 6c 6f 73 65 20 73 65 6c 66 29 sion:close self)
47f0: 0a 20 20 28 64 62 69 3a 63 6c 6f 73 65 20 28 73 . (dbi:close (s
4800: 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c dat-get-conn sel
4810: 66 29 29 29 0a 3b 3b 20 28 63 6c 6f 73 65 2d 6f f))).;; (close-o
4820: 75 74 70 75 74 2d 70 6f 72 74 20 28 73 64 61 74 utput-port (sdat
4830: 2d 67 65 74 2d 6c 6f 67 70 74 20 73 65 6c 66 29 -get-logpt self)
4840: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 )..(define (sess
4850: 69 6f 6e 3a 65 72 72 2d 6d 73 67 20 73 65 6c 66 ion:err-msg self
4860: 20 6d 73 67 29 0a 20 20 28 68 61 73 68 2d 74 61 msg). (hash-ta
4870: 62 6c 65 2d 73 65 74 21 20 28 73 64 61 74 2d 67 ble-set! (sdat-g
4880: 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 20 73 et-sessionvars s
4890: 65 6c 66 29 20 22 45 52 52 4f 52 5f 4d 53 47 22 elf) "ERROR_MSG"
48a0: 0a 09 09 20 20 20 28 73 74 72 69 6e 67 2d 69 6e ... (string-in
48b0: 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 20 73 tersperse (map s
48c0: 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6d 73 67 :any->string msg
48d0: 29 20 22 20 22 29 29 29 0a 0a 28 64 65 66 69 6e ) " ")))..(defin
48e0: 65 20 28 73 65 73 73 69 6f 6e 3a 70 72 65 76 2d e (session:prev-
48f0: 65 72 72 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 err self). (let
4900: 20 28 28 70 72 65 76 2d 65 72 72 20 28 68 61 73 ((prev-err (has
4910: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
4920: 75 6c 74 20 28 73 64 61 74 2d 67 65 74 2d 73 65 ult (sdat-get-se
4930: 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 ssionvars-before
4940: 20 73 65 6c 66 29 20 22 45 52 52 4f 52 5f 4d 53 self) "ERROR_MS
4950: 47 22 20 23 66 29 29 0a 09 28 63 75 72 72 2d 65 G" #f))..(curr-e
4960: 72 72 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 rr (hash-table-r
4970: 65 66 2f 64 65 66 61 75 6c 74 20 28 73 64 61 74 ef/default (sdat
4980: 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 -get-sessionvars
4990: 20 73 65 6c 66 29 20 22 45 52 52 4f 52 5f 4d 53 self) "ERROR_MS
49a0: 47 22 20 23 66 29 29 29 0a 20 20 20 20 28 69 66 G" #f))). (if
49b0: 20 70 72 65 76 2d 65 72 72 20 70 72 65 76 2d 65 prev-err prev-e
49c0: 72 72 0a 09 28 69 66 20 63 75 72 72 2d 65 72 72 rr..(if curr-err
49d0: 20 63 75 72 72 2d 65 72 72 20 23 66 29 29 29 29 curr-err #f))))
49e0: 0a 0a 3b 3b 20 73 65 73 73 69 6f 6e 20 76 61 72 ..;; session var
49f0: 73 0a 3b 3b 20 31 2e 20 6b 65 79 73 20 61 72 65 s.;; 1. keys are
4a00: 20 61 6c 77 61 79 73 20 61 20 73 74 72 69 6e 67 always a string
4a10: 20 4e 4f 54 20 61 20 73 79 6d 62 6f 6c 0a 3b 3b NOT a symbol.;;
4a20: 20 32 2e 20 76 61 6c 75 65 73 20 61 72 65 20 61 2. values are a
4a30: 6c 77 61 79 73 20 61 20 73 74 72 69 6e 67 20 63 lways a string c
4a40: 6f 6e 76 65 72 73 69 6f 6e 20 69 73 20 74 68 65 onversion is the
4a50: 20 72 65 73 70 6f 6e 73 69 62 69 6c 69 74 79 20 responsibility
4a60: 6f 66 20 74 68 65 20 0a 3b 3b 20 20 20 20 63 6f of the .;; co
4a70: 6e 73 75 6d 69 6e 67 20 66 75 6e 63 74 69 6f 6e nsuming function
4a80: 20 28 61 74 20 6c 65 61 73 74 20 66 6f 72 20 6e (at least for n
4a90: 6f 77 2c 20 49 27 64 20 6c 69 6b 65 20 74 6f 20 ow, I'd like to
4aa0: 63 68 61 6e 67 65 20 74 68 69 73 29 0a 0a 3b 3b change this)..;;
4ab0: 20 73 65 74 20 61 20 73 65 73 73 69 6f 6e 20 76 set a session v
4ac0: 61 72 20 66 6f 72 20 74 68 65 20 63 75 72 72 65 ar for the curre
4ad0: 6e 74 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 69 nt page.;;.(defi
4ae0: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 63 75 72 72 ne (session:curr
4af0: 2d 70 61 67 65 2d 73 65 74 21 20 73 65 6c 66 20 -page-set! self
4b00: 6b 65 79 20 76 61 6c 75 65 29 0a 20 20 28 68 61 key value). (ha
4b10: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 28 73 sh-table-set! (s
4b20: 64 61 74 2d 67 65 74 2d 70 61 67 65 76 61 72 73 dat-get-pagevars
4b30: 20 73 65 6c 66 29 20 28 73 3a 61 6e 79 2d 3e 73 self) (s:any->s
4b40: 74 72 69 6e 67 20 6b 65 79 29 20 28 73 3a 61 6e tring key) (s:an
4b50: 79 2d 3e 73 74 72 69 6e 67 20 76 61 6c 75 65 29 y->string value)
4b60: 29 29 0a 0a 3b 3b 20 64 65 6c 20 61 20 76 61 72 ))..;; del a var
4b70: 20 66 6f 72 20 74 68 65 20 63 75 72 72 65 6e 74 for the current
4b80: 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 page.;;.(define
4b90: 20 28 73 65 73 73 69 6f 6e 3a 70 61 67 65 2d 76 (session:page-v
4ba0: 61 72 2d 64 65 6c 21 20 73 65 6c 66 20 6b 65 79 ar-del! self key
4bb0: 29 0a 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ). (hash-table-
4bc0: 64 65 6c 65 74 65 21 20 28 73 64 61 74 2d 67 65 delete! (sdat-ge
4bd0: 74 2d 70 61 67 65 76 61 72 73 20 73 65 6c 66 29 t-pagevars self)
4be0: 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 (s:any->string
4bf0: 6b 65 79 29 29 29 0a 0a 3b 3b 20 67 65 74 20 74 key)))..;; get t
4c00: 68 65 20 61 70 70 72 6f 70 72 69 61 74 65 20 68 he appropriate h
4c10: 61 73 68 20 67 69 76 65 6e 20 61 20 70 61 67 65 ash given a page
4c20: 20 22 2a 73 65 73 73 69 6f 6e 76 61 72 73 2a 2c "*sessionvars*,
4c30: 20 2a 67 6c 6f 62 61 6c 76 61 72 73 2a 20 6f 72 *globalvars* or
4c40: 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 page.;;.(define
4c50: 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 (session:get-pa
4c60: 67 65 2d 68 61 73 68 20 73 65 6c 66 20 70 61 67 ge-hash self pag
4c70: 65 29 0a 20 20 28 69 66 20 28 73 74 72 69 6e 67 e). (if (string
4c80: 3d 3f 20 70 61 67 65 20 22 2a 73 65 73 73 69 6f =? page "*sessio
4c90: 6e 76 61 72 73 2a 22 29 0a 20 20 20 20 20 20 28 nvars*"). (
4ca0: 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e sdat-get-session
4cb0: 76 61 72 73 20 73 65 6c 66 29 0a 20 20 20 20 20 vars self).
4cc0: 20 28 69 66 20 28 73 74 72 69 6e 67 3d 3f 20 70 (if (string=? p
4cd0: 61 67 65 20 22 2a 67 6c 6f 62 61 6c 76 61 72 73 age "*globalvars
4ce0: 2a 22 29 0a 09 20 20 28 73 64 61 74 2d 67 65 74 *").. (sdat-get
4cf0: 2d 67 6c 6f 62 61 6c 76 61 72 73 20 73 65 6c 66 -globalvars self
4d00: 29 0a 09 20 20 28 73 64 61 74 2d 67 65 74 2d 70 ).. (sdat-get-p
4d10: 61 67 65 76 61 72 73 20 73 65 6c 66 29 29 29 29 agevars self))))
4d20: 0a 0a 3b 3b 20 73 65 74 20 61 20 73 65 73 73 69 ..;; set a sessi
4d30: 6f 6e 20 76 61 72 20 66 6f 72 20 61 20 67 69 76 on var for a giv
4d40: 65 6e 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 69 en page.;;.(defi
4d50: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 21 ne (session:set!
4d60: 20 73 65 6c 66 20 70 61 67 65 20 6b 65 79 20 76 self page key v
4d70: 61 6c 75 65 29 0a 20 20 28 6c 65 74 20 28 28 68 alue). (let ((h
4d80: 74 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 t (session:get-p
4d90: 61 67 65 2d 68 61 73 68 20 73 65 6c 66 20 70 61 age-hash self pa
4da0: 67 65 29 29 29 0a 20 20 20 20 28 68 61 73 68 2d ge))). (hash-
4db0: 74 61 62 6c 65 2d 73 65 74 21 20 68 74 20 28 73 table-set! ht (s
4dc0: 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6b 65 79 :any->string key
4dd0: 29 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 ) (s:any->string
4de0: 20 76 61 6c 75 65 29 29 29 29 0a 0a 3b 3b 20 67 value))))..;; g
4df0: 65 74 20 73 65 73 73 69 6f 6e 20 76 61 72 73 20 et session vars
4e00: 66 6f 72 20 74 68 65 20 63 75 72 72 65 6e 74 20 for the current
4e10: 70 61 67 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 page.;;.(define
4e20: 28 73 65 73 73 69 6f 6e 3a 70 61 67 65 2d 67 65 (session:page-ge
4e30: 74 20 73 65 6c 66 20 6b 65 79 29 0a 20 20 28 68 t self key). (h
4e40: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
4e50: 66 61 75 6c 74 20 28 73 64 61 74 2d 67 65 74 2d fault (sdat-get-
4e60: 70 61 67 65 76 61 72 73 20 73 65 6c 66 29 20 6b pagevars self) k
4e70: 65 79 20 23 66 29 29 0a 0a 3b 3b 20 67 65 74 20 ey #f))..;; get
4e80: 73 65 73 73 69 6f 6e 20 76 61 72 73 20 66 6f 72 session vars for
4e90: 20 61 20 73 70 65 63 69 66 69 65 64 20 70 61 67 a specified pag
4ea0: 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 e.;;.(define (se
4eb0: 73 73 69 6f 6e 3a 67 65 74 20 73 65 6c 66 20 70 ssion:get self p
4ec0: 61 67 65 20 6b 65 79 29 0a 20 20 28 6c 65 74 20 age key). (let
4ed0: 28 28 68 74 20 28 73 65 73 73 69 6f 6e 3a 67 65 ((ht (session:ge
4ee0: 74 2d 70 61 67 65 2d 68 61 73 68 20 73 65 6c 66 t-page-hash self
4ef0: 20 70 61 67 65 29 29 29 0a 20 20 20 20 28 68 61 page))). (ha
4f00: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
4f10: 61 75 6c 74 20 68 74 20 28 73 3a 61 6e 79 2d 3e ault ht (s:any->
4f20: 73 74 72 69 6e 67 20 6b 65 79 29 20 23 66 29 29 string key) #f))
4f30: 29 0a 0a 3b 3b 20 64 65 6c 65 74 65 20 61 20 73 )..;; delete a s
4f40: 65 73 73 69 6f 6e 20 76 61 72 20 66 6f 72 20 61 ession var for a
4f50: 20 73 70 65 63 69 66 69 65 64 20 70 61 67 65 0a specified page.
4f60: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 ;;.(define (sess
4f70: 69 6f 6e 3a 64 65 6c 21 20 73 65 6c 66 20 70 61 ion:del! self pa
4f80: 67 65 20 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 ge key). (let (
4f90: 28 68 74 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 (ht (session:get
4fa0: 2d 70 61 67 65 2d 68 61 73 68 20 73 65 6c 66 20 -page-hash self
4fb0: 70 61 67 65 29 29 29 0a 20 20 20 20 28 68 61 73 page))). (has
4fc0: 68 2d 74 61 62 6c 65 2d 64 65 6c 65 74 65 21 20 h-table-delete!
4fd0: 68 74 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e ht (s:any->strin
4fe0: 67 20 6b 65 79 29 29 29 29 0a 0a 3b 3b 20 67 65 g key))))..;; ge
4ff0: 74 20 41 4c 4c 20 6b 65 79 73 20 66 6f 72 20 74 t ALL keys for t
5000: 68 69 73 20 70 61 67 65 20 61 6e 64 20 73 74 6f his page and sto
5010: 72 65 20 69 6e 20 74 68 65 20 73 65 73 73 69 6f re in the sessio
5020: 6e 20 70 61 67 65 76 61 72 73 20 68 61 73 68 0a n pagevars hash.
5030: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 ;;.(define (sess
5040: 69 6f 6e 3a 67 65 74 2d 76 61 72 73 20 73 65 6c ion:get-vars sel
5050: 66 29 0a 20 20 28 6c 65 74 20 28 28 73 65 73 73 f). (let ((sess
5060: 69 6f 6e 2d 69 64 20 20 28 73 64 61 74 2d 67 65 ion-id (sdat-ge
5070: 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c t-session-id sel
5080: 66 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f f))). (if (no
5090: 74 20 73 65 73 73 69 6f 6e 2d 69 64 29 0a 09 28 t session-id)..(
50a0: 65 72 72 3a 6c 6f 67 20 22 45 52 52 4f 52 3a 20 err:log "ERROR:
50b0: 4e 6f 20 73 65 73 73 69 6f 6e 20 69 64 20 69 6e No session id in
50c0: 20 73 65 73 73 69 6f 6e 20 6f 62 6a 65 63 74 21 session object!
50d0: 20 73 65 73 73 69 6f 6e 3a 67 65 74 2d 76 61 72 session:get-var
50e0: 73 22 29 0a 09 28 6c 65 74 2a 20 28 28 72 65 73 s")..(let* ((res
50f0: 75 6c 74 20 20 20 20 20 20 20 20 20 20 20 20 20 ult
5100: 23 66 29 0a 09 20 20 20 20 20 20 20 28 63 6f 6e #f).. (con
5110: 6e 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 n
5120: 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 (sdat-get-conn s
5130: 65 6c 66 29 29 0a 09 20 20 20 20 20 20 20 28 70 elf)).. (p
5140: 61 67 65 76 61 72 73 2d 62 65 66 6f 72 65 20 20 agevars-before
5150: 20 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 (sdat-get-page
5160: 76 61 72 73 2d 62 65 66 6f 72 65 20 73 65 6c 66 vars-before self
5170: 29 29 0a 09 20 20 20 20 20 20 20 28 73 65 73 73 )).. (sess
5180: 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 20 28 ionvars-before (
5190: 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e sdat-get-session
51a0: 76 61 72 73 2d 62 65 66 6f 72 65 20 73 65 6c 66 vars-before self
51b0: 29 29 0a 09 20 20 20 20 20 20 20 28 67 6c 6f 62 )).. (glob
51c0: 61 6c 76 61 72 73 2d 62 65 66 6f 72 65 20 20 28 alvars-before (
51d0: 73 64 61 74 2d 67 65 74 2d 67 6c 6f 62 61 6c 76 sdat-get-globalv
51e0: 61 72 73 2d 62 65 66 6f 72 65 20 73 65 6c 66 29 ars-before self)
51f0: 29 0a 09 20 20 20 20 20 20 20 28 70 61 67 65 76 ).. (pagev
5200: 61 72 73 20 20 20 20 20 20 20 20 20 20 20 28 73 ars (s
5210: 64 61 74 2d 67 65 74 2d 70 61 67 65 76 61 72 73 dat-get-pagevars
5220: 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 20 20 self))..
5230: 28 73 65 73 73 69 6f 6e 76 61 72 73 20 20 20 20 (sessionvars
5240: 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d 73 65 (sdat-get-se
5250: 73 73 69 6f 6e 76 61 72 73 20 73 65 6c 66 29 29 ssionvars self))
5260: 0a 09 20 20 20 20 20 20 20 28 67 6c 6f 62 61 6c .. (global
5270: 76 61 72 73 20 20 20 20 20 20 20 20 20 28 73 64 vars (sd
5280: 61 74 2d 67 65 74 2d 67 6c 6f 62 61 6c 76 61 72 at-get-globalvar
5290: 73 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 20 s self))..
52a0: 20 28 70 61 67 65 2d 6e 61 6d 65 20 20 20 20 20 (page-name
52b0: 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d 70 (sdat-get-p
52c0: 61 67 65 20 73 65 6c 66 29 29 0a 09 20 20 20 20 age self))..
52d0: 20 20 20 28 73 65 73 73 69 6f 6e 2d 6b 65 79 20 (session-key
52e0: 20 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 (sdat-get
52f0: 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c -session-key sel
5300: 66 29 29 0a 09 20 20 20 20 20 20 20 28 71 75 65 f)).. (que
5310: 72 79 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ry
5320: 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 0a 09 (string-append..
5330: 09 09 09 20 20 20 20 22 53 45 4c 45 43 54 20 6b ... "SELECT k
5340: 65 79 2c 76 61 6c 75 65 20 46 52 4f 4d 20 73 65 ey,value FROM se
5350: 73 73 69 6f 6e 5f 76 61 72 73 20 49 4e 4e 45 52 ssion_vars INNER
5360: 20 4a 4f 49 4e 20 73 65 73 73 69 6f 6e 73 20 4f JOIN sessions O
5370: 4e 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 2e 73 N session_vars.s
5380: 65 73 73 69 6f 6e 5f 69 64 3d 73 65 73 73 69 6f ession_id=sessio
5390: 6e 73 2e 69 64 20 22 0a 09 09 09 09 20 20 20 20 ns.id ".....
53a0: 22 57 48 45 52 45 20 73 65 73 73 69 6f 6e 5f 6b "WHERE session_k
53b0: 65 79 3d 3f 20 41 4e 44 20 70 61 67 65 3d 3f 3b ey=? AND page=?;
53c0: 22 29 29 29 0a 09 20 20 3b 3b 20 66 69 72 73 74 "))).. ;; first
53d0: 20 74 68 65 20 70 61 67 65 20 73 70 65 63 69 66 the page specif
53e0: 69 63 20 76 61 72 73 0a 09 20 20 28 64 62 69 3a ic vars.. (dbi:
53f0: 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 for-each-row (la
5400: 6d 62 64 61 20 28 74 75 70 6c 65 29 0a 09 09 09 mbda (tuple)....
5410: 20 20 20 20 20 20 28 6c 65 74 20 28 28 6b 20 28 (let ((k (
5420: 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 vector-ref tuple
5430: 20 30 29 29 0a 09 09 09 09 20 20 20 20 28 76 20 0))..... (v
5440: 28 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c (vector-ref tupl
5450: 65 20 31 29 29 29 0a 09 09 09 09 28 68 61 73 68 e 1))).....(hash
5460: 2d 74 61 62 6c 65 2d 73 65 74 21 20 70 61 67 65 -table-set! page
5470: 76 61 72 73 2d 62 65 66 6f 72 65 20 6b 20 76 29 vars-before k v)
5480: 0a 09 09 09 09 28 68 61 73 68 2d 74 61 62 6c 65 .....(hash-table
5490: 2d 73 65 74 21 20 70 61 67 65 76 61 72 73 20 20 -set! pagevars
54a0: 20 20 20 20 20 20 6b 20 76 29 29 29 0a 09 09 09 k v)))....
54b0: 20 20 20 20 63 6f 6e 6e 0a 09 09 09 20 20 20 20 conn....
54c0: 28 73 3a 73 71 6c 70 61 72 61 6d 20 71 75 65 72 (s:sqlparam quer
54d0: 79 20 73 65 73 73 69 6f 6e 2d 6b 65 79 20 70 61 y session-key pa
54e0: 67 65 2d 6e 61 6d 65 29 29 0a 09 20 20 3b 3b 20 ge-name)).. ;;
54f0: 74 68 65 6e 20 74 68 65 20 73 65 73 73 69 6f 6e then the session
5500: 20 73 70 65 63 69 66 69 63 20 76 61 72 73 0a 09 specific vars..
5510: 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d (dbi:for-each-
5520: 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 75 70 row (lambda (tup
5530: 6c 65 29 0a 09 09 09 20 20 20 20 20 20 28 6c 65 le).... (le
5540: 74 20 28 28 6b 20 28 76 65 63 74 6f 72 2d 72 65 t ((k (vector-re
5550: 66 20 74 75 70 6c 65 20 30 29 29 0a 09 09 09 09 f tuple 0)).....
5560: 20 20 20 20 28 76 20 28 76 65 63 74 6f 72 2d 72 (v (vector-r
5570: 65 66 20 74 75 70 6c 65 20 31 29 29 29 0a 09 09 ef tuple 1)))...
5580: 09 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 ..(hash-table-se
5590: 74 21 20 73 65 73 73 69 6f 6e 76 61 72 73 2d 62 t! sessionvars-b
55a0: 65 66 6f 72 65 20 6b 20 76 29 0a 09 09 09 09 28 efore k v).....(
55b0: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
55c0: 73 65 73 73 69 6f 6e 76 61 72 73 20 20 20 20 20 sessionvars
55d0: 20 20 20 6b 20 76 29 29 29 0a 09 09 09 20 20 20 k v)))....
55e0: 20 63 6f 6e 6e 0a 09 09 09 20 20 20 20 28 73 3a conn.... (s:
55f0: 73 71 6c 70 61 72 61 6d 20 71 75 65 72 79 20 73 sqlparam query s
5600: 65 73 73 69 6f 6e 2d 6b 65 79 20 22 2a 73 65 73 ession-key "*ses
5610: 73 69 6f 6e 76 61 72 73 2a 22 29 29 0a 09 20 20 sionvars*"))..
5620: 3b 3b 20 61 6e 64 20 66 69 6e 61 6c 6c 79 20 74 ;; and finally t
5630: 68 65 20 67 6c 6f 62 61 6c 20 76 61 72 73 0a 09 he global vars..
5640: 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d (dbi:for-each-
5650: 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 75 70 row (lambda (tup
5660: 6c 65 29 0a 09 09 09 20 20 20 20 20 20 28 6c 65 le).... (le
5670: 74 20 28 28 6b 20 28 76 65 63 74 6f 72 2d 72 65 t ((k (vector-re
5680: 66 20 74 75 70 6c 65 20 30 29 29 0a 09 09 09 09 f tuple 0)).....
5690: 20 20 20 20 28 76 20 28 76 65 63 74 6f 72 2d 72 (v (vector-r
56a0: 65 66 20 74 75 70 6c 65 20 31 29 29 29 0a 09 09 ef tuple 1)))...
56b0: 09 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 ..(hash-table-se
56c0: 74 21 20 67 6c 6f 62 61 6c 76 61 72 73 2d 62 65 t! globalvars-be
56d0: 66 6f 72 65 20 6b 20 76 29 0a 09 09 09 09 28 68 fore k v).....(h
56e0: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 67 ash-table-set! g
56f0: 6c 6f 62 61 6c 76 61 72 73 20 20 20 20 20 20 20 lobalvars
5700: 20 6b 20 76 29 29 29 0a 09 09 09 20 20 20 20 63 k v))).... c
5710: 6f 6e 6e 0a 09 09 09 20 20 20 20 28 73 3a 73 71 onn.... (s:sq
5720: 6c 70 61 72 61 6d 20 71 75 65 72 79 20 73 65 73 lparam query ses
5730: 73 69 6f 6e 2d 6b 65 79 20 22 2a 67 6c 6f 62 61 sion-key "*globa
5740: 6c 76 61 72 73 22 29 29 0a 09 20 20 29 29 29 29 lvars")).. ))))
5750: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ..(define (sessi
5760: 6f 6e 3a 73 61 76 65 2d 76 61 72 73 20 73 65 6c on:save-vars sel
5770: 66 29 0a 20 20 28 6c 65 74 20 28 28 73 65 73 73 f). (let ((sess
5780: 69 6f 6e 2d 69 64 20 20 28 73 64 61 74 2d 67 65 ion-id (sdat-ge
5790: 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c t-session-id sel
57a0: 66 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f f))). (if (no
57b0: 74 20 73 65 73 73 69 6f 6e 2d 69 64 29 0a 09 28 t session-id)..(
57c0: 65 72 72 3a 6c 6f 67 20 22 45 52 52 4f 52 3a 20 err:log "ERROR:
57d0: 4e 6f 20 73 65 73 73 69 6f 6e 20 69 64 20 69 6e No session id in
57e0: 20 73 65 73 73 69 6f 6e 20 6f 62 6a 65 63 74 21 session object!
57f0: 20 73 65 73 73 69 6f 6e 3a 67 65 74 2d 76 61 72 session:get-var
5800: 73 22 29 0a 09 28 6c 65 74 2a 20 28 28 73 74 61 s")..(let* ((sta
5810: 74 75 73 20 20 20 20 20 20 23 66 29 0a 09 20 20 tus #f)..
5820: 20 20 20 20 20 28 63 6f 6e 6e 20 20 20 20 20 20 (conn
5830: 20 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e (sdat-get-conn
5840: 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 20 20 self))..
5850: 28 70 61 67 65 2d 6e 61 6d 65 20 20 20 28 73 64 (page-name (sd
5860: 61 74 2d 67 65 74 2d 70 61 67 65 20 73 65 6c 66 at-get-page self
5870: 29 29 0a 09 20 20 20 20 20 20 20 28 64 65 6c 2d )).. (del-
5880: 71 75 65 72 79 20 20 20 22 44 45 4c 45 54 45 20 query "DELETE
5890: 46 52 4f 4d 20 73 65 73 73 69 6f 6e 5f 76 61 72 FROM session_var
58a0: 73 20 57 48 45 52 45 20 73 65 73 73 69 6f 6e 5f s WHERE session_
58b0: 69 64 3d 3f 20 41 4e 44 20 70 61 67 65 3d 3f 20 id=? AND page=?
58c0: 41 4e 44 20 6b 65 79 3d 3f 3b 22 29 0a 09 20 20 AND key=?;")..
58d0: 20 20 20 20 20 28 69 6e 73 2d 71 75 65 72 79 20 (ins-query
58e0: 20 20 22 49 4e 53 45 52 54 20 49 4e 54 4f 20 73 "INSERT INTO s
58f0: 65 73 73 69 6f 6e 5f 76 61 72 73 20 28 73 65 73 ession_vars (ses
5900: 73 69 6f 6e 5f 69 64 2c 70 61 67 65 2c 6b 65 79 sion_id,page,key
5910: 2c 76 61 6c 75 65 29 20 56 41 4c 55 45 53 28 3f ,value) VALUES(?
5920: 2c 3f 2c 3f 2c 3f 29 3b 22 29 0a 09 20 20 20 20 ,?,?,?);")..
5930: 20 20 20 28 75 70 64 2d 71 75 65 72 79 20 20 20 (upd-query
5940: 22 55 50 44 41 54 45 20 73 65 73 73 69 6f 6e 5f "UPDATE session_
5950: 76 61 72 73 20 73 65 74 20 76 61 6c 75 65 3d 3f vars set value=?
5960: 20 57 48 45 52 45 20 6b 65 79 3d 3f 20 41 4e 44 WHERE key=? AND
5970: 20 73 65 73 73 69 6f 6e 5f 69 64 3d 3f 20 41 4e session_id=? AN
5980: 44 20 70 61 67 65 3d 3f 3b 22 29 0a 09 20 20 20 D page=?;")..
5990: 20 20 20 20 28 63 68 61 6e 67 65 64 2d 63 6f 75 (changed-cou
59a0: 6e 74 20 30 29 29 0a 09 20 20 3b 3b 20 73 61 76 nt 0)).. ;; sav
59b0: 65 20 74 68 65 20 64 65 6c 74 61 20 6f 6e 6c 79 e the delta only
59c0: 0a 09 20 20 28 66 6f 72 2d 65 61 63 68 0a 09 20 .. (for-each..
59d0: 20 20 28 6c 61 6d 62 64 61 20 28 70 61 67 65 29 (lambda (page)
59e0: 20 3b 3b 20 70 61 67 65 20 69 73 3a 20 22 2a 67 ;; page is: "*g
59f0: 6c 6f 62 61 6c 76 61 72 73 2a 22 20 22 2a 73 65 lobalvars*" "*se
5a00: 73 73 69 6f 6e 76 61 72 73 2a 22 20 6f 72 20 6f ssionvars*" or o
5a10: 74 68 65 72 73 74 72 69 6e 67 0a 09 20 20 20 20 therstring..
5a20: 20 28 6c 65 74 2a 20 28 28 62 65 66 6f 72 65 2d (let* ((before-
5a30: 61 66 74 65 72 2d 68 74 20 28 63 6f 6e 64 0a 09 after-ht (cond..
5a40: 09 09 09 20 20 20 20 20 20 28 28 73 74 72 69 6e ... ((strin
5a50: 67 3d 3f 20 70 61 67 65 20 22 2a 73 65 73 73 69 g=? page "*sessi
5a60: 6f 6e 76 61 72 73 2a 22 29 0a 09 09 09 09 20 20 onvars*").....
5a70: 20 20 20 20 20 28 76 65 63 74 6f 72 20 28 73 64 (vector (sd
5a80: 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 at-get-sessionva
5a90: 72 73 20 73 65 6c 66 29 0a 09 09 09 09 09 20 20 rs self)......
5aa0: 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d 73 (sdat-get-s
5ab0: 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 essionvars-befor
5ac0: 65 20 73 65 6c 66 29 29 29 0a 09 09 09 09 20 20 e self))).....
5ad0: 20 20 20 20 20 28 28 73 74 72 69 6e 67 3d 3f 20 ((string=?
5ae0: 70 61 67 65 20 22 2a 67 6c 6f 62 61 6c 76 61 72 page "*globalvar
5af0: 73 2a 22 29 0a 09 09 09 09 09 28 76 65 63 74 6f s*")......(vecto
5b00: 72 20 28 73 64 61 74 2d 67 65 74 2d 67 6c 6f 62 r (sdat-get-glob
5b10: 61 6c 76 61 72 73 20 73 65 6c 66 29 0a 09 09 09 alvars self)....
5b20: 09 09 09 28 73 64 61 74 2d 67 65 74 2d 67 6c 6f ...(sdat-get-glo
5b30: 62 61 6c 76 61 72 73 2d 62 65 66 6f 72 65 20 73 balvars-before s
5b40: 65 6c 66 29 29 29 0a 09 09 09 09 20 20 20 20 20 elf))).....
5b50: 20 20 28 65 6c 73 65 20 0a 09 09 09 09 09 28 76 (else ......(v
5b60: 65 63 74 6f 72 20 28 73 64 61 74 2d 67 65 74 2d ector (sdat-get-
5b70: 70 61 67 65 76 61 72 73 20 73 65 6c 66 29 0a 09 pagevars self)..
5b80: 09 09 09 09 09 28 73 64 61 74 2d 67 65 74 2d 70 .....(sdat-get-p
5b90: 61 67 65 76 61 72 73 2d 62 65 66 6f 72 65 20 73 agevars-before s
5ba0: 65 6c 66 29 29 29 29 29 0a 09 09 20 20 20 20 28 elf)))))... (
5bb0: 6d 61 73 74 65 72 2d 68 74 20 20 20 28 76 65 63 master-ht (vec
5bc0: 74 6f 72 2d 72 65 66 20 62 65 66 6f 72 65 2d 61 tor-ref before-a
5bd0: 66 74 65 72 2d 68 74 20 30 29 29 0a 09 09 20 20 fter-ht 0))...
5be0: 20 20 28 62 65 66 6f 72 65 2d 68 74 20 20 20 28 (before-ht (
5bf0: 76 65 63 74 6f 72 2d 72 65 66 20 62 65 66 6f 72 vector-ref befor
5c00: 65 2d 61 66 74 65 72 2d 68 74 20 31 29 29 0a 09 e-after-ht 1))..
5c10: 09 20 20 20 20 28 6d 61 73 74 65 72 2d 6b 65 79 . (master-key
5c20: 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 s (hash-table-ke
5c30: 79 73 20 6d 61 73 74 65 72 2d 68 74 29 29 0a 09 ys master-ht))..
5c40: 09 20 20 20 20 28 62 65 66 6f 72 65 2d 6b 65 79 . (before-key
5c50: 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 s (hash-table-ke
5c60: 79 73 20 62 65 66 6f 72 65 2d 68 74 29 29 0a 09 ys before-ht))..
5c70: 09 20 20 20 20 28 61 6c 6c 2d 6b 65 79 73 20 28 . (all-keys (
5c80: 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 65 delete-duplicate
5c90: 73 20 28 61 70 70 65 6e 64 20 6d 61 73 74 65 72 s (append master
5ca0: 2d 6b 65 79 73 20 62 65 66 6f 72 65 2d 6b 65 79 -keys before-key
5cb0: 73 29 29 29 29 0a 09 20 20 20 20 20 20 20 28 66 s)))).. (f
5cc0: 6f 72 2d 65 61 63 68 20 0a 09 09 28 6c 61 6d 62 or-each ...(lamb
5cd0: 64 61 20 28 6b 65 79 29 0a 09 09 20 20 28 6c 65 da (key)... (le
5ce0: 74 20 28 28 6d 61 73 74 65 72 2d 76 61 6c 75 65 t ((master-value
5cf0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
5d00: 2f 64 65 66 61 75 6c 74 20 6d 61 73 74 65 72 2d /default master-
5d10: 68 74 20 6b 65 79 20 23 66 29 29 0a 09 09 09 28 ht key #f))....(
5d20: 62 65 66 6f 72 65 2d 76 61 6c 75 65 20 28 68 61 before-value (ha
5d30: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
5d40: 61 75 6c 74 20 62 65 66 6f 72 65 2d 68 74 20 6b ault before-ht k
5d50: 65 79 20 23 66 29 29 29 0a 09 09 20 20 20 20 28 ey #f)))... (
5d60: 63 6f 6e 64 0a 09 09 20 20 20 20 20 3b 3b 20 62 cond... ;; b
5d70: 65 66 6f 72 65 20 61 6e 64 20 61 66 74 65 72 20 efore and after
5d80: 65 78 69 73 74 20 61 6e 64 20 76 61 6c 75 65 20 exist and value
5d90: 75 6e 63 68 61 6e 67 65 64 20 2d 20 64 6f 20 6e unchanged - do n
5da0: 6f 74 68 69 6e 67 0a 09 09 20 20 20 20 20 28 28 othing... ((
5db0: 61 6e 64 20 6d 61 73 74 65 72 2d 76 61 6c 75 65 and master-value
5dc0: 20 62 65 66 6f 72 65 2d 76 61 6c 75 65 20 28 65 before-value (e
5dd0: 71 75 61 6c 3f 20 6d 61 73 74 65 72 2d 76 61 6c qual? master-val
5de0: 75 65 20 62 65 66 6f 72 65 2d 76 61 6c 75 65 29 ue before-value)
5df0: 29 29 0a 09 09 20 20 20 20 20 3b 3b 20 62 65 66 ))... ;; bef
5e00: 6f 72 65 20 61 6e 64 20 61 66 74 65 72 20 65 78 ore and after ex
5e10: 69 73 74 20 62 75 74 20 61 72 65 20 63 68 61 6e ist but are chan
5e20: 67 65 64 0a 09 09 20 20 20 20 20 28 28 61 6e 64 ged... ((and
5e30: 20 6d 61 73 74 65 72 2d 76 61 6c 75 65 20 62 65 master-value be
5e40: 66 6f 72 65 2d 76 61 6c 75 65 29 0a 09 09 20 20 fore-value)...
5e50: 20 20 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 (dbi:for-eac
5e60: 68 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 h-row (lambda (t
5e70: 75 70 6c 65 29 0a 09 09 09 09 09 20 20 28 73 65 uple)...... (se
5e80: 74 21 20 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 t! changed-count
5e90: 20 28 2b 20 63 68 61 6e 67 65 64 2d 63 6f 75 6e (+ changed-coun
5ea0: 74 20 31 29 29 29 0a 09 09 09 09 09 63 6f 6e 6e t 1)))......conn
5eb0: 0a 09 09 09 09 09 28 73 3a 73 71 6c 70 61 72 61 ......(s:sqlpara
5ec0: 6d 20 75 70 64 2d 71 75 65 72 79 20 6d 61 73 74 m upd-query mast
5ed0: 65 72 2d 76 61 6c 75 65 20 6b 65 79 20 73 65 73 er-value key ses
5ee0: 73 69 6f 6e 2d 69 64 20 70 61 67 65 29 29 29 0a sion-id page))).
5ef0: 09 09 20 20 20 20 20 3b 3b 20 6d 61 73 74 65 72 .. ;; master
5f00: 2d 76 61 6c 75 65 20 6e 6f 20 6c 6f 6e 67 65 72 -value no longer
5f10: 20 65 78 69 73 74 73 20 28 69 2e 65 2e 20 23 66 exists (i.e. #f
5f20: 29 20 2d 20 72 65 6d 6f 76 65 20 69 74 65 6d 0a ) - remove item.
5f30: 09 09 20 20 20 20 20 28 28 6e 6f 74 20 6d 61 73 .. ((not mas
5f40: 74 65 72 2d 76 61 6c 75 65 29 0a 09 09 20 20 20 ter-value)...
5f50: 20 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 (dbi:for-each
5f60: 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 75 -row (lambda (tu
5f70: 70 6c 65 29 0a 09 09 09 09 09 20 20 28 73 65 74 ple)...... (set
5f80: 21 20 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 ! changed-count
5f90: 28 2b 20 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 (+ changed-count
5fa0: 20 31 29 29 29 0a 09 09 09 09 09 63 6f 6e 6e 0a 1)))......conn.
5fb0: 09 09 09 09 09 28 73 3a 73 71 6c 70 61 72 61 6d .....(s:sqlparam
5fc0: 20 64 65 6c 2d 71 75 65 72 79 20 73 65 73 73 69 del-query sessi
5fd0: 6f 6e 2d 69 64 20 70 61 67 65 20 6b 65 79 29 29 on-id page key))
5fe0: 29 0a 09 09 20 20 20 20 20 3b 3b 20 62 65 66 6f )... ;; befo
5ff0: 72 65 2d 76 61 6c 75 65 20 64 6f 65 73 6e 27 74 re-value doesn't
6000: 20 65 78 69 73 74 20 2d 20 69 6e 73 65 72 74 20 exist - insert
6010: 61 20 6e 65 77 20 76 61 6c 75 65 0a 09 09 20 20 a new value...
6020: 20 20 20 28 28 6e 6f 74 20 62 65 66 6f 72 65 2d ((not before-
6030: 76 61 6c 75 65 29 0a 09 09 20 20 20 20 20 20 28 value)... (
6040: 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 dbi:for-each-row
6050: 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 29 (lambda (tuple)
6060: 0a 09 09 09 09 09 20 20 28 73 65 74 21 20 63 68 ...... (set! ch
6070: 61 6e 67 65 64 2d 63 6f 75 6e 74 20 28 2b 20 63 anged-count (+ c
6080: 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 31 29 29 hanged-count 1))
6090: 29 0a 09 09 09 09 09 63 6f 6e 6e 0a 09 09 09 09 )......conn.....
60a0: 09 28 73 3a 73 71 6c 70 61 72 61 6d 20 69 6e 73 .(s:sqlparam ins
60b0: 2d 71 75 65 72 79 20 73 65 73 73 69 6f 6e 2d 69 -query session-i
60c0: 64 20 70 61 67 65 20 6b 65 79 20 6d 61 73 74 65 d page key maste
60d0: 72 2d 76 61 6c 75 65 29 29 29 0a 09 09 20 20 20 r-value)))...
60e0: 20 20 28 65 6c 73 65 20 28 65 72 72 3a 6c 6f 67 (else (err:log
60f0: 20 22 53 68 6f 75 6c 64 6e 27 74 20 67 65 74 20 "Shouldn't get
6100: 68 65 72 65 22 29 29 29 29 29 0a 09 09 61 6c 6c here")))))...all
6110: 2d 6b 65 79 73 29 29 29 20 3b 3b 20 70 72 6f 63 -keys))) ;; proc
6120: 65 73 73 20 61 6c 6c 20 6b 65 79 73 0a 09 20 20 ess all keys..
6130: 20 28 6c 69 73 74 20 22 2a 73 65 73 73 69 6f 6e (list "*session
6140: 76 61 72 73 2a 22 20 22 2a 67 6c 6f 62 61 6c 76 vars*" "*globalv
6150: 61 72 73 2a 22 20 70 61 67 65 2d 6e 61 6d 65 29 ars*" page-name)
6160: 29 29 29 29 29 0a 0a 3b 3b 20 28 70 67 3a 73 71 )))))..;; (pg:sq
6170: 6c 2d 6e 75 6c 6c 2d 6f 62 6a 65 63 74 3f 20 65 l-null-object? e
6180: 6c 65 6d 65 6e 74 29 0a 28 64 65 66 69 6e 65 20 lement).(define
6190: 28 73 65 73 73 69 6f 6e 3a 72 65 61 64 2d 63 6f (session:read-co
61a0: 6e 66 69 67 20 73 65 6c 66 29 0a 20 20 28 6c 65 nfig self). (le
61b0: 74 2a 20 28 28 63 67 69 2d 70 61 74 68 20 28 70 t* ((cgi-path (p
61c0: 61 74 68 6e 61 6d 65 2d 64 69 72 65 63 74 6f 72 athname-director
61d0: 79 20 28 63 61 72 20 28 61 72 67 76 29 29 29 29 y (car (argv))))
61e0: 0a 20 20 20 20 20 20 20 20 20 28 6e 61 6d 65 20 . (name
61f0: 20 20 20 20 28 73 74 72 69 6e 67 2d 61 70 70 65 (string-appe
6200: 6e 64 20 28 69 66 20 63 67 69 2d 70 61 74 68 20 nd (if cgi-path
6210: 28 63 6f 6e 63 20 63 67 69 2d 70 61 74 68 20 22 (conc cgi-path "
6220: 2f 22 29 20 22 22 29 20 22 2e 22 20 28 70 61 74 /") "") "." (pat
6230: 68 6e 61 6d 65 2d 66 69 6c 65 20 28 63 61 72 20 hname-file (car
6240: 28 61 72 67 76 29 29 29 20 22 2e 63 6f 6e 66 69 (argv))) ".confi
6250: 67 22 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e g"))). (if (n
6260: 6f 74 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f ot (file-exists?
6270: 20 6e 61 6d 65 29 29 0a 09 28 70 72 69 6e 74 20 name))..(print
6280: 6e 61 6d 65 20 22 20 6e 6f 74 20 66 6f 75 6e 64 name " not found
6290: 20 61 74 20 22 20 28 63 75 72 72 65 6e 74 2d 64 at " (current-d
62a0: 69 72 65 63 74 6f 72 79 29 29 0a 09 28 6c 65 74 irectory))..(let
62b0: 2a 20 28 28 66 70 20 28 6f 70 65 6e 2d 69 6e 70 * ((fp (open-inp
62c0: 75 74 2d 66 69 6c 65 20 6e 61 6d 65 29 29 0a 09 ut-file name))..
62d0: 20 20 20 20 20 20 20 28 69 6e 69 74 61 72 67 73 (initargs
62e0: 20 28 72 65 61 64 20 66 70 29 29 29 0a 09 20 20 (read fp)))..
62f0: 28 63 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 6f 72 (close-input-por
6300: 74 20 66 70 29 0a 09 20 20 69 6e 69 74 61 72 67 t fp).. initarg
6310: 73 29 29 29 29 0a 0a 3b 3b 20 63 61 6c 6c 20 74 s))))..;; call t
6320: 68 65 20 63 6f 6e 74 72 6f 6c 6c 65 72 20 69 66 he controller if
6330: 20 69 74 20 65 78 69 73 74 73 0a 3b 3b 20 0a 3b it exists.;; .;
6340: 3b 20 57 41 52 4e 49 4e 47 20 2d 20 74 68 69 73 ; WARNING - this
6350: 20 63 6f 64 65 20 6e 65 65 64 73 20 61 20 64 65 code needs a de
6360: 66 65 6e 63 65 20 61 67 61 69 6e 73 20 72 65 63 fence agains rec
6370: 75 72 73 69 76 65 20 63 61 6c 6c 69 6e 67 21 21 ursive calling!!
6380: 21 21 21 0a 3b 3b 0a 3b 3b 20 20 20 49 20 73 75 !!!.;;.;; I su
6390: 67 67 65 73 74 20 61 20 6c 69 6d 69 74 20 6f 66 ggest a limit of
63a0: 20 31 30 30 20 63 61 6c 6c 73 2e 20 50 6c 65 6e 100 calls. Plen
63b0: 74 79 20 66 6f 72 20 61 6c 6c 6f 77 69 6e 67 20 ty for allowing
63c0: 6d 75 6c 74 69 70 6c 65 20 69 6e 73 74 61 6e 63 multiple instanc
63d0: 65 73 0a 3b 3b 20 20 20 6f 66 20 61 20 70 61 67 es.;; of a pag
63e0: 65 20 69 6e 73 69 64 65 20 61 6e 6f 74 68 65 72 e inside another
63f0: 20 70 61 67 65 2e 20 0a 3b 3b 0a 3b 3b 20 70 61 page. .;;.;; pa
6400: 72 74 73 20 3d 20 27 62 6f 74 68 20 7c 20 27 63 rts = 'both | 'c
6410: 6f 6e 74 72 6f 6c 20 7c 20 27 76 69 65 77 0a 3b ontrol | 'view.;
6420: 3b 0a 0a 28 64 65 66 69 6e 65 20 28 66 69 6c 65 ;..(define (file
6430: 73 2d 72 65 61 64 2d 3e 73 74 72 69 6e 67 20 2e s-read->string .
6440: 20 66 69 6c 65 73 29 0a 20 20 28 73 74 72 69 6e files). (strin
6450: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 0a 20 g-intersperse .
6460: 20 20 28 61 70 70 6c 79 20 61 70 70 65 6e 64 20 (apply append
6470: 28 6d 61 70 20 66 69 6c 65 2d 72 65 61 64 2d 3e (map file-read->
6480: 73 74 72 69 6e 67 20 66 69 6c 65 73 29 29 20 22 string files)) "
6490: 5c 6e 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 \n"))..(define (
64a0: 66 69 6c 65 2d 72 65 61 64 2d 3e 73 74 72 69 6e file-read->strin
64b0: 67 20 66 29 20 0a 20 20 28 6c 65 74 20 28 28 70 g f) . (let ((p
64c0: 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 66 69 6c (open-input-fil
64d0: 65 20 66 29 29 29 0a 20 20 20 20 28 6c 65 74 20 e f))). (let
64e0: 6c 6f 6f 70 20 28 28 68 65 64 20 28 72 65 61 64 loop ((hed (read
64f0: 2d 6c 69 6e 65 20 70 29 29 0a 09 20 20 20 20 20 -line p))..
6500: 20 20 28 72 65 73 20 27 28 29 29 29 0a 20 20 20 (res '())).
6510: 20 20 20 28 69 66 20 28 65 6f 66 2d 6f 62 6a 65 (if (eof-obje
6520: 63 74 3f 20 68 65 64 29 0a 09 20 20 72 65 73 0a ct? hed).. res.
6530: 09 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d 6c . (loop (read-l
6540: 69 6e 65 20 70 29 28 61 70 70 65 6e 64 20 72 65 ine p)(append re
6550: 73 20 28 6c 69 73 74 20 68 65 64 29 29 29 29 29 s (list hed)))))
6560: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 70 72 6f ))..(define (pro
6570: 63 65 73 73 2d 70 6f 72 74 20 70 29 0a 20 20 28 cess-port p). (
6580: 6c 65 74 20 28 28 65 20 28 69 6e 74 65 72 61 63 let ((e (interac
6590: 74 69 6f 6e 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 tion-environment
65a0: 29 29 29 0a 20 20 20 20 28 6d 61 70 20 0a 20 20 ))). (map .
65b0: 20 20 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 20 (lambda (x).
65c0: 20 20 20 20 20 20 28 63 6f 6e 64 0a 09 28 28 6c (cond..((l
65d0: 69 73 74 3f 20 78 29 20 78 29 0a 09 28 28 73 74 ist? x) x)..((st
65e0: 72 69 6e 67 3f 20 78 29 20 78 29 0a 09 28 65 6c ring? x) x)..(el
65f0: 73 65 20 27 28 29 29 29 29 0a 20 20 20 20 20 28 se '()))). (
6600: 70 6f 72 74 2d 6d 61 70 20 28 6c 61 6d 62 64 61 port-map (lambda
6610: 20 28 73 29 0a 09 09 20 28 65 76 61 6c 20 73 20 (s)... (eval s
6620: 65 29 29 0a 09 20 20 20 20 20 20 20 28 6c 61 6d e)).. (lam
6630: 62 64 61 20 28 29 28 72 65 61 64 20 70 29 29 29 bda ()(read p)))
6640: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 )))..(define (se
6650: 73 73 69 6f 6e 3a 70 72 6f 63 65 73 73 2d 66 69 ssion:process-fi
6660: 6c 65 20 66 29 0a 20 20 28 6c 65 74 2a 20 28 28 le f). (let* ((
6670: 70 20 20 20 20 28 6f 70 65 6e 2d 69 6e 70 75 74 p (open-input
6680: 2d 66 69 6c 65 20 66 29 29 0a 09 20 28 64 61 74 -file f)).. (dat
6690: 20 20 28 70 72 6f 63 65 73 73 2d 70 6f 72 74 20 (process-port
66a0: 70 29 29 29 0a 20 20 20 20 28 63 6c 6f 73 65 2d p))). (close-
66b0: 69 6e 70 75 74 2d 70 6f 72 74 20 70 29 0a 20 20 input-port p).
66c0: 20 20 64 61 74 29 29 0a 0a 3b 3b 20 4d 61 79 20 dat))..;; May
66d0: 32 30 31 31 2c 20 70 75 74 74 69 6e 67 20 61 6c 2011, putting al
66e0: 6c 20 70 61 67 65 73 20 69 6e 74 6f 20 6f 6e 65 l pages into one
66f0: 20 64 69 72 65 63 74 6f 72 79 20 66 6f 72 20 74 directory for t
6700: 68 65 20 66 6f 6c 6c 6f 77 69 6e 67 20 72 65 61 he following rea
6710: 73 6f 6e 73 3a 0a 3b 3b 20 20 20 31 2e 20 77 61 sons:.;; 1. wa
6720: 6e 74 20 66 69 6c 65 6e 61 6d 65 20 74 6f 20 72 nt filename to r
6730: 65 66 6c 65 63 74 20 70 61 67 65 20 6e 61 6d 65 eflect page name
6740: 20 28 65 6d 61 63 73 20 6c 69 6d 69 74 61 74 69 (emacs limitati
6750: 6f 6e 29 0a 3b 3b 20 20 20 32 2e 20 74 68 61 74 on).;; 2. that
6760: 27 73 20 69 74 21 20 6e 6f 20 6f 74 68 65 72 20 's it! no other
6770: 72 65 61 73 6f 6e 2e 20 63 6f 75 6c 64 20 6d 61 reason. could ma
6780: 6b 65 20 69 74 20 63 6f 6e 66 69 67 75 72 61 62 ke it configurab
6790: 6c 65 20 2e 2e 2e 0a 3b 3b 20 70 61 67 65 2d 64 le ....;; page-d
67a0: 69 72 2d 73 74 79 6c 65 20 69 73 3a 0a 3b 3b 20 ir-style is:.;;
67b0: 20 27 73 74 6f 72 65 64 20 20 20 3d 3e 20 73 74 'stored => st
67c0: 6f 72 65 64 20 69 6e 20 65 78 65 63 75 74 61 62 ored in executab
67d0: 6c 65 0a 3b 3b 20 20 27 66 6c 61 74 20 20 20 20 le.;; 'flat
67e0: 20 3d 3e 20 70 61 67 65 73 20 66 6c 61 74 20 64 => pages flat d
67f0: 69 72 65 63 74 6f 72 79 0a 3b 3b 20 20 27 64 69 irectory.;; 'di
6800: 72 20 20 20 20 20 20 3d 3e 20 64 69 72 65 63 74 r => direct
6810: 6f 72 79 20 74 72 65 65 20 70 61 67 65 73 2f 3c ory tree pages/<
6820: 70 61 67 65 6e 61 6d 65 3e 2f 7b 76 69 65 77 2c pagename>/{view,
6830: 63 6f 6e 74 72 6f 6c 7d 2e 73 63 6d 0a 3b 3b 20 control}.scm.;;
6840: 70 61 72 74 73 3a 0a 3b 3b 20 20 27 62 6f 74 68 parts:.;; 'both
6850: 20 20 20 20 20 3d 3e 20 6c 6f 61 64 20 63 6f 6e => load con
6860: 74 72 6f 6c 20 61 6e 64 20 76 69 65 77 20 28 61 trol and view (a
6870: 6e 79 74 68 69 6e 67 20 6f 74 68 65 72 20 74 68 nything other th
6880: 61 6e 20 76 69 65 77 20 6f 72 20 63 6f 6e 74 72 an view or contr
6890: 6f 6c 0a 3b 3b 20 20 27 76 69 65 77 20 20 20 20 ol.;; 'view
68a0: 20 3d 3e 20 6c 6f 61 64 20 76 69 65 77 20 6f 6e => load view on
68b0: 6c 79 0a 3b 3b 20 20 27 63 6f 6e 74 72 6f 6c 20 ly.;; 'control
68c0: 20 3d 3e 20 6c 6f 61 64 20 63 6f 6e 74 72 6f 6c => load control
68d0: 20 6f 6e 6c 79 0a 28 64 65 66 69 6e 65 20 28 73 only.(define (s
68e0: 65 73 73 69 6f 6e 3a 63 61 6c 6c 2d 70 61 72 74 ession:call-part
68f0: 73 20 73 65 6c 66 20 70 61 67 65 20 23 21 6b 65 s self page #!ke
6900: 79 20 28 70 61 72 74 73 20 27 62 6f 74 68 29 29 y (parts 'both))
6910: 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 63 75 72 . (sdat-set-cur
6920: 72 2d 70 61 67 65 21 20 73 65 6c 66 20 70 61 67 r-page! self pag
6930: 65 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 69 72 e). (let* ((dir
6940: 2d 73 74 79 6c 65 20 20 20 20 28 73 64 61 74 2d -style (sdat-
6950: 67 65 74 2d 70 61 67 65 2d 64 69 72 2d 73 74 79 get-page-dir-sty
6960: 6c 65 20 73 65 6c 66 29 29 3b 3b 20 28 65 71 75 le self));; (equ
6970: 61 6c 3f 20 28 73 64 61 74 2d 67 65 74 2d 70 61 al? (sdat-get-pa
6980: 67 65 2d 64 69 72 2d 73 74 79 6c 65 20 73 65 6c ge-dir-style sel
6990: 66 29 20 22 6f 6e 65 64 69 72 22 29 29 20 3b 3b f) "onedir")) ;;
69a0: 20 66 6c 61 67 20 23 74 20 66 6f 72 20 6f 6e 65 flag #t for one
69b0: 64 69 72 2c 20 23 66 20 66 6f 72 20 6f 6c 64 20 dir, #f for old
69c0: 73 74 79 6c 65 0a 09 20 28 64 69 72 20 20 20 20 style.. (dir
69d0: 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 61 70 (string-ap
69e0: 70 65 6e 64 20 28 73 64 61 74 2d 67 65 74 2d 73 pend (sdat-get-s
69f0: 72 6f 6f 74 20 73 65 6c 66 29 20 0a 09 09 09 09 root self) .....
6a00: 20 20 20 20 20 20 28 69 66 20 64 69 72 2d 73 74 (if dir-st
6a10: 79 6c 65 20 0a 09 09 09 09 09 20 20 28 63 6f 6e yle ...... (con
6a20: 63 20 22 2f 70 61 67 65 73 2f 22 29 0a 09 09 09 c "/pages/")....
6a30: 09 09 20 20 28 63 6f 6e 63 20 22 2f 70 61 67 65 .. (conc "/page
6a40: 73 2f 22 20 70 61 67 65 29 29 29 29 29 0a 20 20 s/" page))))).
6a50: 20 20 28 63 61 73 65 20 64 69 72 2d 73 74 79 6c (case dir-styl
6a60: 65 0a 20 20 20 20 20 20 3b 3b 20 4e 42 2f 2f 20 e. ;; NB//
6a70: 53 74 6f 72 65 64 20 61 6c 77 61 79 73 20 6c 6f Stored always lo
6a80: 61 64 73 20 62 6f 74 68 20 63 6f 6e 74 72 6f 6c ads both control
6a90: 20 61 6e 64 20 76 69 65 77 0a 20 20 20 20 20 20 and view.
6aa0: 28 28 73 74 6f 72 65 64 29 0a 20 20 20 20 20 20 ((stored).
6ab0: 20 28 28 65 76 61 6c 20 28 73 74 72 69 6e 67 2d ((eval (string-
6ac0: 3e 73 79 6d 62 6f 6c 20 28 63 6f 6e 63 20 22 70 >symbol (conc "p
6ad0: 61 67 65 73 3a 22 20 70 61 67 65 29 29 29 20 0a ages:" page))) .
6ae0: 09 73 65 6c 66 20 20 20 20 20 20 20 20 20 20 20 .self
6af0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ;;
6b00: 20 74 68 65 20 73 65 73 73 69 6f 6e 0a 09 28 73 the session..(s
6b10: 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c dat-get-conn sel
6b20: 66 29 20 20 20 20 20 20 20 20 20 3b 3b 20 74 68 f) ;; th
6b30: 65 20 64 62 20 63 6f 6e 6e 65 63 74 69 6f 6e 0a e db connection.
6b40: 09 28 73 64 61 74 2d 67 65 74 2d 73 68 61 72 65 .(sdat-get-share
6b50: 64 2d 68 61 73 68 20 73 65 6c 66 29 20 20 3b 3b d-hash self) ;;
6b60: 20 61 20 73 68 61 72 65 64 20 68 61 73 68 20 74 a shared hash t
6b70: 61 62 6c 65 20 66 6f 72 20 70 61 73 73 69 6e 67 able for passing
6b80: 20 64 61 74 61 20 74 6f 2f 66 72 6f 6d 20 70 61 data to/from pa
6b90: 67 65 20 63 61 6c 6c 73 0a 09 29 29 0a 20 20 20 ge calls..)).
6ba0: 20 20 20 28 28 66 6c 61 74 29 20 20 20 0a 20 20 ((flat) .
6bb0: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 73 6f 2d (let* ((so-
6bc0: 66 69 6c 65 20 20 28 63 6f 6e 63 20 64 69 72 20 file (conc dir
6bd0: 70 61 67 65 20 22 2e 73 6f 22 29 29 0a 09 20 20 page ".so"))..
6be0: 20 20 20 20 28 73 63 6d 2d 66 69 6c 65 20 28 63 (scm-file (c
6bf0: 6f 6e 63 20 64 69 72 20 70 61 67 65 20 22 2e 73 onc dir page ".s
6c00: 63 6d 22 29 29 0a 09 20 20 20 20 20 20 28 73 72 cm")).. (sr
6c10: 63 2d 66 69 6c 65 20 28 6f 72 20 28 66 69 6c 65 c-file (or (file
6c20: 2d 65 78 69 73 74 73 3f 20 73 6f 2d 66 69 6c 65 -exists? so-file
6c30: 29 0a 09 09 09 20 20 20 20 28 66 69 6c 65 2d 65 ).... (file-e
6c40: 78 69 73 74 73 3f 20 73 63 6d 2d 66 69 6c 65 29 xists? scm-file)
6c50: 29 29 29 0a 09 20 28 69 66 20 73 72 63 2d 66 69 ))).. (if src-fi
6c60: 6c 65 0a 09 20 20 20 20 20 28 62 65 67 69 6e 0a le.. (begin.
6c70: 09 20 20 20 20 20 20 20 28 6c 6f 61 64 20 73 72 . (load sr
6c80: 63 2d 66 69 6c 65 29 0a 09 20 20 20 20 20 20 20 c-file)..
6c90: 28 28 65 76 61 6c 20 28 73 74 72 69 6e 67 2d 3e ((eval (string->
6ca0: 73 79 6d 62 6f 6c 20 28 63 6f 6e 63 20 22 70 61 symbol (conc "pa
6cb0: 67 65 73 3a 22 20 70 61 67 65 29 29 29 20 0a 09 ges:" page))) ..
6cc0: 09 73 65 6c 66 20 20 20 20 20 20 20 20 20 20 20 .self
6cd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ;;
6ce0: 20 74 68 65 20 73 65 73 73 69 6f 6e 0a 09 09 28 the session...(
6cf0: 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 sdat-get-conn se
6d00: 6c 66 29 20 20 20 20 20 20 20 20 20 3b 3b 20 74 lf) ;; t
6d10: 68 65 20 64 62 20 63 6f 6e 6e 65 63 74 69 6f 6e he db connection
6d20: 0a 09 09 28 73 64 61 74 2d 67 65 74 2d 73 68 61 ...(sdat-get-sha
6d30: 72 65 64 2d 68 61 73 68 20 73 65 6c 66 29 20 20 red-hash self)
6d40: 3b 3b 20 61 20 73 68 61 72 65 64 20 68 61 73 68 ;; a shared hash
6d50: 20 74 61 62 6c 65 20 66 6f 72 20 70 61 73 73 69 table for passi
6d60: 6e 67 20 64 61 74 61 20 74 6f 2f 66 72 6f 6d 20 ng data to/from
6d70: 70 61 67 65 20 63 61 6c 6c 73 0a 09 09 29 29 0a page calls...)).
6d80: 09 20 20 20 20 20 28 6c 69 73 74 20 22 3c 70 3e . (list "<p>
6d90: 50 61 67 65 20 6e 6f 74 20 66 6f 75 6e 64 20 22 Page not found "
6da0: 20 70 61 67 65 20 22 20 3c 2f 70 3e 22 29 29 29 page " </p>")))
6db0: 29 0a 20 20 20 20 20 20 20 3b 3b 20 66 69 72 73 ). ;; firs
6dc0: 74 20 74 68 65 20 63 6f 6e 74 72 6f 6c 0a 20 20 t the control.
6dd0: 20 20 20 20 20 3b 3b 20 28 6c 65 74 20 28 28 63 ;; (let ((c
6de0: 6f 6e 74 72 6f 6c 2d 66 69 6c 65 20 28 63 6f 6e ontrol-file (con
6df0: 63 20 22 70 61 67 65 73 2f 22 20 70 61 67 65 20 c "pages/" page
6e00: 22 5f 63 74 72 6c 2e 73 63 6d 22 29 29 0a 20 20 "_ctrl.scm")).
6e10: 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 28 76 ;; (v
6e20: 69 65 77 2d 66 69 6c 65 20 20 20 20 28 63 6f 6e iew-file (con
6e30: 63 20 22 70 61 67 65 73 2f 22 20 70 61 67 65 20 c "pages/" page
6e40: 22 5f 76 69 65 77 2e 73 63 6d 22 29 29 29 0a 20 "_view.scm"))).
6e50: 20 20 20 20 20 20 3b 3b 20 20 20 28 69 66 20 28 ;; (if (
6e60: 61 6e 64 20 28 66 69 6c 65 2d 65 78 69 73 74 73 and (file-exists
6e70: 3f 20 63 6f 6e 74 72 6f 6c 2d 66 69 6c 65 29 0a ? control-file).
6e80: 20 20 20 20 20 20 20 3b 3b 20 20 09 20 20 28 6e ;; . (n
6e90: 6f 74 20 28 65 71 3f 20 70 61 72 74 73 20 27 76 ot (eq? parts 'v
6ea0: 69 65 77 29 29 29 0a 20 20 20 20 20 20 20 3b 3b iew))). ;;
6eb0: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 (begin.
6ec0: 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 ;;
6ed0: 28 73 65 73 73 69 6f 6e 3a 73 65 74 2d 63 61 6c (session:set-cal
6ee0: 6c 65 64 21 20 73 65 6c 66 20 70 61 67 65 29 0a led! self page).
6ef0: 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 ;;
6f00: 20 20 28 6c 6f 61 64 20 63 6f 6e 74 72 6f 6c 2d (load control-
6f10: 66 69 6c 65 29 29 29 0a 20 20 20 20 20 20 20 3b file))). ;
6f20: 3b 20 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 ; (if (file-ex
6f30: 69 73 74 73 3f 20 76 69 65 77 2d 66 69 6c 65 29 ists? view-file)
6f40: 0a 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 . ;;
6f50: 20 28 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 70 (if (not (eq? p
6f60: 61 72 74 73 20 27 63 6f 6e 74 72 6f 6c 29 29 0a arts 'control)).
6f70: 20 20 20 20 20 20 20 3b 3b 20 20 09 20 28 73 65 ;; . (se
6f80: 73 73 69 6f 6e 3a 70 72 6f 63 65 73 73 2d 66 69 ssion:process-fi
6f90: 6c 65 20 76 69 65 77 2d 66 69 6c 65 29 29 0a 20 le view-file)).
6fa0: 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 28 ;; (
6fb0: 6c 69 73 74 20 22 3c 70 3e 50 61 67 65 20 6e 6f list "<p>Page no
6fc0: 74 20 66 6f 75 6e 64 20 22 20 70 61 67 65 20 22 t found " page "
6fd0: 20 3c 2f 70 3e 22 29 29 29 0a 20 20 20 20 20 20 </p>"))).
6fe0: 28 28 64 69 72 29 20 22 45 52 52 4f 52 3a 20 20 ((dir) "ERROR:
6ff0: 64 69 72 20 73 74 79 6c 65 20 6e 6f 74 20 79 65 dir style not ye
7000: 74 20 72 65 2d 69 6d 70 6c 65 6d 65 6e 74 65 64 t re-implemented
7010: 22 29 0a 20 20 20 20 20 20 28 65 6c 73 65 0a 20 "). (else.
7020: 20 20 20 20 20 20 28 6c 69 73 74 20 22 45 52 52 (list "ERR
7030: 4f 52 3a 20 70 61 67 65 2d 64 69 72 2d 73 74 79 OR: page-dir-sty
7040: 6c 65 20 6d 75 73 74 20 62 65 20 73 74 6f 72 65 le must be store
7050: 64 2c 20 64 69 72 20 6f 72 20 66 6c 61 74 2c 20 d, dir or flat,
7060: 67 6f 74 20 22 20 64 69 72 2d 73 74 79 6c 65 29 got " dir-style)
7070: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 ))))..(define (s
7080: 65 73 73 69 6f 6e 3a 63 61 6c 6c 20 73 65 6c 66 ession:call self
7090: 20 70 61 67 65 20 70 61 72 74 73 29 0a 20 20 28 page parts). (
70a0: 73 65 73 73 69 6f 6e 3a 63 61 6c 6c 2d 70 61 72 session:call-par
70b0: 74 73 20 73 65 6c 66 20 70 61 67 65 20 27 62 6f ts self page 'bo
70c0: 74 68 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 th))..;; (define
70d0: 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 61 64 2d 6d (session:load-m
70e0: 6f 64 65 6c 20 73 65 6c 66 20 6d 6f 64 65 6c 29 odel self model)
70f0: 0a 3b 3b 20 20 20 28 6c 65 74 20 28 28 6d 6f 64 .;; (let ((mod
7100: 65 6c 2e 73 63 6d 20 28 73 74 72 69 6e 67 2d 61 el.scm (string-a
7110: 70 70 65 6e 64 20 28 73 64 61 74 2d 67 65 74 2d ppend (sdat-get-
7120: 73 72 6f 6f 74 20 73 65 6c 66 29 20 22 2f 6d 6f sroot self) "/mo
7130: 64 65 6c 73 2f 22 20 6d 6f 64 65 6c 20 22 2e 73 dels/" model ".s
7140: 63 6d 22 29 29 0a 3b 3b 20 09 28 6d 6f 64 65 6c cm")).;; .(model
7150: 2e 73 6f 20 20 28 73 74 72 69 6e 67 2d 61 70 70 .so (string-app
7160: 65 6e 64 20 28 73 64 61 74 2d 67 65 74 2d 73 72 end (sdat-get-sr
7170: 6f 6f 74 20 73 65 6c 66 29 20 22 2f 6d 6f 64 65 oot self) "/mode
7180: 6c 73 2f 22 20 6d 6f 64 65 6c 20 22 2e 73 6f 22 ls/" model ".so"
7190: 29 29 29 0a 3b 3b 20 20 20 20 20 28 69 66 20 28 ))).;; (if (
71a0: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 6d 6f 64 file-exists? mod
71b0: 65 6c 2e 73 6f 29 0a 3b 3b 20 09 28 6c 6f 61 64 el.so).;; .(load
71c0: 20 6d 6f 64 65 6c 2e 73 6f 29 0a 3b 3b 20 09 28 model.so).;; .(
71d0: 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f if (file-exists?
71e0: 20 6d 6f 64 65 6c 2e 73 63 6d 29 0a 3b 3b 20 09 model.scm).;; .
71f0: 20 20 20 20 28 6c 6f 61 64 20 6d 6f 64 65 6c 2e (load model.
7200: 73 63 6d 29 0a 3b 3b 20 09 20 20 20 20 28 73 3a scm).;; . (s:
7210: 6c 6f 67 20 22 45 52 52 4f 52 3a 20 6d 6f 64 65 log "ERROR: mode
7220: 6c 20 22 20 6d 6f 64 65 6c 2e 73 63 6d 20 22 20 l " model.scm "
7230: 6e 6f 74 20 66 6f 75 6e 64 22 29 29 29 29 29 0a not found"))))).
7240: 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 65 73 .;; (define (ses
7250: 73 69 6f 6e 3a 6d 6f 64 65 6c 2d 70 61 74 68 20 sion:model-path
7260: 73 65 6c 66 20 6d 6f 64 65 6c 29 0a 3b 3b 20 20 self model).;;
7270: 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 (string-append
7280: 28 73 64 61 74 2d 67 65 74 2d 73 72 6f 6f 74 20 (sdat-get-sroot
7290: 73 65 6c 66 29 20 22 2f 6d 6f 64 65 6c 73 2f 22 self) "/models/"
72a0: 20 6d 6f 64 65 6c 20 22 2e 73 63 6d 22 29 29 0a model ".scm")).
72b0: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
72c0: 6e 3a 70 70 2d 66 6f 72 6d 64 61 74 20 73 65 6c n:pp-formdat sel
72d0: 66 29 0a 20 20 28 6c 65 74 20 28 28 64 61 74 20 f). (let ((dat
72e0: 28 66 6f 72 6d 64 61 74 3a 61 6c 6c 2d 3e 73 74 (formdat:all->st
72f0: 72 69 6e 67 73 20 28 73 64 61 74 2d 67 65 74 2d rings (sdat-get-
7300: 66 6f 72 6d 64 61 74 20 73 65 6c 66 29 29 29 29 formdat self))))
7310: 0a 20 20 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 . (string-int
7320: 65 72 73 70 65 72 73 65 20 64 61 74 20 22 3c 62 ersperse dat "<b
7330: 72 3e 20 22 29 29 29 0a 0a 28 64 65 66 69 6e 65 r> ")))..(define
7340: 20 28 73 65 73 73 69 6f 6e 3a 70 61 72 61 6d 2d (session:param-
7350: 3e 73 74 72 69 6e 67 20 70 61 72 61 6d 73 29 0a >string params).
7360: 20 20 3b 3b 20 28 65 72 72 3a 6c 6f 67 20 22 70 ;; (err:log "p
7370: 61 72 61 6d 73 3d 22 20 70 61 72 61 6d 73 29 0a arams=" params).
7380: 20 20 28 69 66 20 28 3c 20 28 6c 65 6e 67 74 68 (if (< (length
7390: 20 70 61 72 61 6d 73 29 20 31 29 0a 20 20 20 20 params) 1).
73a0: 20 20 22 22 0a 20 20 20 20 20 20 28 6c 65 74 20 "". (let
73b0: 6c 6f 6f 70 20 28 28 6b 65 79 20 28 63 61 72 20 loop ((key (car
73c0: 70 61 72 61 6d 73 29 29 0a 09 09 20 28 76 61 6c params))... (val
73d0: 20 28 63 61 64 72 20 70 61 72 61 6d 73 29 29 0a (cadr params)).
73e0: 09 09 20 28 74 61 69 6c 20 28 63 64 64 72 20 70 .. (tail (cddr p
73f0: 61 72 61 6d 73 29 29 0a 09 09 20 28 72 65 73 75 arams))... (resu
7400: 6c 74 20 27 28 29 29 29 0a 09 28 6c 65 74 20 28 lt '()))..(let (
7410: 28 6e 65 77 72 65 73 75 6c 74 20 28 63 6f 6e 73 (newresult (cons
7420: 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 (string-append
7430: 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6b (s:any->string k
7440: 65 79 29 20 22 3d 22 20 28 73 3a 61 6e 79 2d 3e ey) "=" (s:any->
7450: 73 74 72 69 6e 67 20 76 61 6c 29 29 0a 09 09 09 string val))....
7460: 20 20 20 20 20 20 20 72 65 73 75 6c 74 29 29 29 result)))
7470: 0a 09 20 20 28 69 66 20 28 3c 20 28 6c 65 6e 67 .. (if (< (leng
7480: 74 68 20 74 61 69 6c 29 20 31 29 20 3b 3b 20 74 th tail) 1) ;; t
7490: 72 75 65 20 69 66 20 64 6f 6e 65 0a 09 20 20 20 rue if done..
74a0: 20 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 (string-inter
74b0: 73 70 65 72 73 65 20 6e 65 77 72 65 73 75 6c 74 sperse newresult
74c0: 20 22 26 22 29 0a 09 20 20 20 20 20 20 28 6c 6f "&").. (lo
74d0: 6f 70 20 28 63 61 72 20 74 61 69 6c 29 28 63 61 op (car tail)(ca
74e0: 64 72 20 74 61 69 6c 29 28 63 64 64 72 20 74 61 dr tail)(cddr ta
74f0: 69 6c 29 20 6e 65 77 72 65 73 75 6c 74 29 29 29 il) newresult)))
7500: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 )))..(define (se
7510: 73 73 69 6f 6e 3a 6c 69 6e 6b 2d 74 6f 20 73 65 ssion:link-to se
7520: 6c 66 20 70 61 67 65 20 70 61 72 61 6d 73 29 0a lf page params).
7530: 20 20 28 6c 65 74 2a 20 28 28 73 65 72 76 65 72 (let* ((server
7540: 20 20 20 20 28 69 66 20 28 67 65 74 2d 65 6e 76 (if (get-env
7550: 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c ironment-variabl
7560: 65 20 22 48 54 54 50 5f 48 4f 53 54 22 29 0a 09 e "HTTP_HOST")..
7570: 09 09 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 ..(get-environme
7580: 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 48 54 54 nt-variable "HTT
7590: 50 5f 48 4f 53 54 22 29 0a 09 09 09 28 67 65 74 P_HOST")....(get
75a0: 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 -environment-var
75b0: 69 61 62 6c 65 20 22 53 45 52 56 45 52 5f 4e 41 iable "SERVER_NA
75c0: 4d 45 22 29 29 29 0a 09 20 28 73 63 72 69 70 74 ME"))).. (script
75d0: 20 28 6c 65 74 20 28 28 73 63 72 69 70 74 2d 6e (let ((script-n
75e0: 61 6d 65 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 ame (string-spli
75f0: 74 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 t (get-environme
7600: 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 53 43 52 nt-variable "SCR
7610: 49 50 54 5f 4e 41 4d 45 22 29 20 22 2f 22 29 29 IPT_NAME") "/"))
7620: 29 0a 09 09 20 20 20 28 69 66 20 28 3e 20 28 6c )... (if (> (l
7630: 65 6e 67 74 68 20 73 63 72 69 70 74 2d 6e 61 6d ength script-nam
7640: 65 29 20 31 29 0a 09 09 20 20 20 20 20 20 20 28 e) 1)... (
7650: 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 28 63 string-append (c
7660: 61 72 20 73 63 72 69 70 74 2d 6e 61 6d 65 29 20 ar script-name)
7670: 22 2f 22 20 28 63 61 64 72 20 73 63 72 69 70 74 "/" (cadr script
7680: 2d 6e 61 6d 65 29 29 0a 09 09 20 20 20 20 20 20 -name))...
7690: 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e (get-environmen
76a0: 74 2d 76 61 72 69 61 62 6c 65 20 22 53 43 52 49 t-variable "SCRI
76b0: 50 54 5f 4e 41 4d 45 22 29 29 29 29 20 3b 3b 20 PT_NAME")))) ;;
76c0: 62 75 69 6c 64 20 73 63 72 69 70 74 20 6e 61 6d build script nam
76d0: 65 20 66 72 6f 6d 20 66 69 72 73 74 20 74 77 6f e from first two
76e0: 20 65 6c 65 6d 65 6e 74 73 2e 20 54 68 69 73 20 elements. This
76f0: 69 73 20 61 20 68 61 6e 67 6f 76 65 72 20 66 72 is a hangover fr
7700: 6f 6d 20 62 65 66 6f 72 65 20 49 20 75 73 65 64 om before I used
7710: 20 3f 20 69 6e 20 74 68 65 20 55 52 4c 2e 0a 09 ? in the URL...
7720: 20 28 73 65 73 73 69 6f 6e 2d 6b 65 79 20 28 73 (session-key (s
7730: 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 2d dat-get-session-
7740: 6b 65 79 20 73 65 6c 66 29 29 0a 09 20 28 70 61 key self)).. (pa
7750: 72 61 6d 73 74 72 20 28 73 65 73 73 69 6f 6e 3a ramstr (session:
7760: 70 61 72 61 6d 2d 3e 73 74 72 69 6e 67 20 70 61 param->string pa
7770: 72 61 6d 73 29 29 29 0a 20 20 20 20 3b 3b 20 28 rams))). ;; (
7780: 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 session:log self
7790: 20 22 73 65 72 76 65 72 3d 22 20 73 65 72 76 65 "server=" serve
77a0: 72 20 22 20 73 63 72 69 70 74 3d 22 20 73 63 72 r " script=" scr
77b0: 69 70 74 20 22 20 70 61 67 65 3d 22 20 70 61 67 ipt " page=" pag
77c0: 65 29 0a 20 20 20 20 28 73 74 72 69 6e 67 2d 61 e). (string-a
77d0: 70 70 65 6e 64 20 22 68 74 74 70 3a 2f 2f 22 20 ppend "http://"
77e0: 73 65 72 76 65 72 20 22 2f 22 20 73 63 72 69 70 server "/" scrip
77f0: 74 20 22 2f 22 20 70 61 67 65 20 22 3f 22 20 70 t "/" page "?" p
7800: 61 72 61 6d 73 74 72 29 29 29 20 3b 3b 20 22 2f aramstr))) ;; "/
7810: 73 6e 3d 22 20 73 65 73 73 69 6f 6e 2d 6b 65 79 sn=" session-key
7820: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 )))..(define (se
7830: 73 73 69 6f 6e 3a 63 67 69 2d 6f 75 74 20 73 65 ssion:cgi-out se
7840: 6c 66 29 0a 20 20 28 6c 65 74 2a 20 28 28 63 6f lf). (let* ((co
7850: 6e 74 65 6e 74 20 20 28 6c 69 73 74 20 28 73 64 ntent (list (sd
7860: 61 74 2d 67 65 74 2d 63 6f 6e 74 65 6e 74 2d 74 at-get-content-t
7870: 79 70 65 20 73 65 6c 66 29 29 29 20 3b 3b 20 27 ype self))) ;; '
7880: 28 22 43 6f 6e 74 65 6e 74 2d 74 79 70 65 3a 20 ("Content-type:
7890: 74 65 78 74 2f 68 74 6d 6c 3b 20 63 68 61 72 73 text/html; chars
78a0: 65 74 3d 69 73 6f 2d 38 38 35 39 2d 31 5c 6e 5c et=iso-8859-1\n\
78b0: 6e 22 29 29 0a 09 20 28 68 65 61 64 65 72 20 20 n")).. (header
78c0: 20 28 6c 65 74 20 28 28 63 6f 6f 6b 69 65 20 28 (let ((cookie (
78d0: 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e sdat-get-session
78e0: 2d 63 6f 6f 6b 69 65 20 73 65 6c 66 29 29 29 0a -cookie self))).
78f0: 09 09 20 20 20 20 20 28 69 66 20 63 6f 6f 6b 69 .. (if cooki
7900: 65 0a 09 09 09 20 28 63 6f 6e 73 20 28 73 74 72 e.... (cons (str
7910: 69 6e 67 2d 61 70 70 65 6e 64 20 22 53 65 74 2d ing-append "Set-
7920: 43 6f 6f 6b 69 65 3a 20 22 20 28 63 61 72 20 63 Cookie: " (car c
7930: 6f 6f 6b 69 65 29 29 0a 09 09 09 20 20 20 20 20 ookie))....
7940: 20 20 63 6f 6e 74 65 6e 74 29 0a 09 09 09 20 63 content).... c
7950: 6f 6e 74 65 6e 74 29 29 29 0a 09 20 28 70 61 67 ontent))).. (pag
7960: 65 64 61 74 20 20 28 73 64 61 74 2d 67 65 74 2d edat (sdat-get-
7970: 70 61 67 65 64 61 74 20 73 65 6c 66 29 29 29 0a pagedat self))).
7980: 20 20 20 20 28 73 3a 63 67 69 2d 6f 75 74 20 0a (s:cgi-out .
7990: 20 20 20 20 20 28 63 6f 6e 73 20 68 65 61 64 65 (cons heade
79a0: 72 20 70 61 67 65 64 61 74 29 29 29 29 0a 0a 28 r pagedat))))..(
79b0: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
79c0: 6c 6f 67 20 73 65 6c 66 20 2e 20 6d 73 67 29 0a log self . msg).
79d0: 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 (with-output-t
79e0: 6f 2d 70 6f 72 74 20 28 73 64 61 74 2d 67 65 74 o-port (sdat-get
79f0: 2d 6c 6f 67 2d 70 6f 72 74 20 73 65 6c 66 29 20 -log-port self)
7a00: 3b 3b 20 28 73 64 61 74 2d 67 65 74 2d 6c 6f 67 ;; (sdat-get-log
7a10: 70 74 20 73 65 6c 66 29 0a 20 20 20 20 28 6c 61 pt self). (la
7a20: 6d 62 64 61 20 28 29 20 0a 20 20 20 20 20 20 28 mbda () . (
7a30: 61 70 70 6c 79 20 70 72 69 6e 74 20 6d 73 67 29 apply print msg)
7a40: 29 29 29 0a 0a 3b 3b 20 65 73 63 61 70 65 2c 20 )))..;; escape,
7a50: 63 6f 6e 76 65 72 74 20 6f 72 20 72 65 74 75 72 convert or retur
7a60: 6e 20 72 61 77 20 77 68 65 6e 20 67 69 76 65 6e n raw when given
7a70: 20 75 73 65 72 20 69 6e 70 75 74 20 64 61 74 61 user input data
7a80: 20 74 68 61 74 20 70 6f 74 65 6e 74 69 61 6c 6c that potentiall
7a90: 79 0a 3b 3b 20 63 6f 75 6c 64 20 62 65 20 6d 61 y.;; could be ma
7aa0: 6c 69 63 69 6f 75 73 0a 3b 3b 0a 28 64 65 66 69 licious.;;.(defi
7ab0: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 61 70 70 6c ne (session:appl
7ac0: 79 2d 74 79 70 65 2d 70 72 65 66 65 72 65 6e 63 y-type-preferenc
7ad0: 65 20 72 65 73 20 70 61 72 61 6d 73 29 0a 20 20 e res params).
7ae0: 28 6c 65 74 2a 20 28 28 64 74 79 70 65 20 20 20 (let* ((dtype
7af0: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 70 61 72 61 (if (null? para
7b00: 6d 73 29 0a 09 09 20 20 20 20 20 20 20 27 65 73 ms)... 'es
7b10: 63 61 70 65 64 0a 09 09 20 20 20 20 20 20 20 28 caped... (
7b20: 63 61 72 20 70 61 72 61 6d 73 29 29 29 0a 09 20 car params)))..
7b30: 28 74 61 67 73 20 20 20 20 28 69 66 20 28 6e 75 (tags (if (nu
7b40: 6c 6c 3f 20 70 61 72 61 6d 73 29 0a 09 09 20 20 ll? params)...
7b50: 20 20 20 20 27 28 29 0a 09 09 20 20 20 20 20 20 '()...
7b60: 28 63 64 72 20 70 61 72 61 6d 73 29 29 29 29 0a (cdr params)))).
7b70: 20 20 20 20 28 63 61 73 65 20 64 74 79 70 65 0a (case dtype.
7b80: 20 20 20 20 20 20 28 28 72 61 77 29 20 20 20 20 ((raw)
7b90: 20 72 65 73 29 0a 20 20 20 20 20 20 28 28 6e 75 res). ((nu
7ba0: 6d 62 65 72 29 20 20 28 69 66 20 28 73 74 72 69 mber) (if (stri
7bb0: 6e 67 3f 20 72 65 73 29 28 73 74 72 69 6e 67 2d ng? res)(string-
7bc0: 3e 6e 75 6d 62 65 72 20 72 65 73 29 20 23 66 29 >number res) #f)
7bd0: 29 0a 20 20 20 20 20 20 28 28 65 73 63 61 70 65 ). ((escape
7be0: 64 29 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 d) (if (string?
7bf0: 72 65 73 29 0a 09 09 20 20 20 20 20 28 73 3a 68 res)... (s:h
7c00: 74 6d 6c 2d 66 69 6c 74 65 72 2d 3e 73 74 72 69 tml-filter->stri
7c10: 6e 67 20 72 65 73 20 74 61 67 73 29 0a 09 09 20 ng res tags)...
7c20: 20 20 20 20 72 65 73 29 29 0a 20 20 20 20 20 20 res)).
7c30: 28 65 6c 73 65 20 20 20 20 20 20 28 69 66 20 28 (else (if (
7c40: 73 74 72 69 6e 67 3f 20 72 65 73 29 0a 09 09 20 string? res)...
7c50: 20 20 20 20 28 73 3a 68 74 6d 6c 2d 66 69 6c 74 (s:html-filt
7c60: 65 72 2d 3e 73 74 72 69 6e 67 20 72 65 73 20 27 er->string res '
7c70: 28 29 29 0a 09 09 20 20 20 20 20 72 65 73 29 29 ())... res))
7c80: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 )))..(define (se
7c90: 73 73 69 6f 6e 3a 67 65 74 2d 70 61 72 61 6d 20 ssion:get-param
7ca0: 73 65 6c 66 20 6b 65 79 20 74 79 70 65 2d 70 61 self key type-pa
7cb0: 72 61 6d 73 29 0a 20 20 3b 3b 20 28 73 65 73 73 rams). ;; (sess
7cc0: 69 6f 6e 3a 6c 6f 67 20 73 3a 73 65 73 73 69 6f ion:log s:sessio
7cd0: 6e 20 22 70 61 72 61 6d 73 3d 22 20 28 73 6c 6f n "params=" (slo
7ce0: 74 2d 72 65 66 20 73 3a 73 65 73 73 69 6f 6e 20 t-ref s:session
7cf0: 27 70 61 72 61 6d 73 29 29 0a 20 20 28 6c 65 74 'params)). (let
7d00: 2a 20 28 28 70 61 72 61 6d 73 20 28 73 64 61 74 * ((params (sdat
7d10: 2d 67 65 74 2d 70 61 72 61 6d 73 20 73 65 6c 66 -get-params self
7d20: 29 29 0a 09 20 28 72 65 73 20 20 20 20 28 73 65 )).. (res (se
7d30: 73 73 69 6f 6e 3a 67 65 74 2d 70 61 72 61 6d 2d ssion:get-param-
7d40: 66 72 6f 6d 20 70 61 72 61 6d 73 20 6b 65 79 29 from params key)
7d50: 29 29 0a 20 20 20 20 28 73 65 73 73 69 6f 6e 3a )). (session:
7d60: 61 70 70 6c 79 2d 74 79 70 65 2d 70 72 65 66 65 apply-type-prefe
7d70: 72 65 6e 63 65 20 72 65 73 20 74 79 70 65 2d 70 rence res type-p
7d80: 61 72 61 6d 73 29 29 29 0a 0a 3b 3b 20 54 68 69 arams)))..;; Thi
7d90: 73 20 6f 6e 65 20 77 69 6c 6c 20 67 65 74 20 74 s one will get t
7da0: 68 65 20 66 69 72 73 74 20 76 61 6c 75 65 20 66 he first value f
7db0: 6f 75 6e 64 20 72 65 67 61 72 64 6c 65 73 73 20 ound regardless
7dc0: 6f 66 20 66 6f 72 6d 0a 3b 3b 20 70 61 72 61 6d of form.;; param
7dd0: 3a 20 28 64 74 79 70 65 20 5b 74 61 67 31 20 74 : (dtype [tag1 t
7de0: 61 67 32 20 2e 2e 2e 5d 29 0a 3b 3b 20 64 74 79 ag2 ...]).;; dty
7df0: 70 65 3a 0a 3b 3b 20 20 20 20 27 72 61 77 20 20 pe:.;; 'raw
7e00: 20 20 20 3a 20 64 6f 20 6e 6f 20 63 6f 6e 76 65 : do no conve
7e10: 72 73 69 6f 6e 0a 3b 3b 20 20 20 20 27 6e 75 6d rsion.;; 'num
7e20: 62 65 72 20 20 3a 20 63 6f 6e 76 65 72 74 20 74 ber : convert t
7e30: 6f 20 6e 75 6d 62 65 72 2c 20 72 65 74 75 72 6e o number, return
7e40: 20 23 66 20 69 66 20 66 61 69 6c 73 0a 3b 3b 20 #f if fails.;;
7e50: 20 20 20 27 65 73 63 61 70 65 64 20 3a 20 75 73 'escaped : us
7e60: 65 20 68 74 6d 6c 2d 65 73 63 61 70 65 20 74 6f e html-escape to
7e70: 20 70 72 6f 74 65 63 74 20 74 68 65 20 69 6e 70 protect the inp
7e80: 75 74 20 2d 2d 20 74 68 69 73 20 69 73 20 74 68 ut -- this is th
7e90: 65 20 64 65 66 61 75 6c 74 0a 3b 3b 0a 28 64 65 e default.;;.(de
7ea0: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 fine (session:ge
7eb0: 74 2d 69 6e 70 75 74 20 73 65 6c 66 20 6b 65 79 t-input self key
7ec0: 20 70 61 72 61 6d 73 29 0a 20 20 28 6c 65 74 2a params). (let*
7ed0: 20 28 28 64 74 79 70 65 20 20 20 20 28 69 66 20 ((dtype (if
7ee0: 28 6e 75 6c 6c 3f 20 70 61 72 61 6d 73 29 0a 09 (null? params)..
7ef0: 09 20 20 20 20 20 20 20 27 65 73 63 61 70 65 64 . 'escaped
7f00: 0a 09 09 20 20 20 20 20 20 20 28 63 61 72 20 70 ... (car p
7f10: 61 72 61 6d 73 29 29 29 0a 09 20 28 74 61 67 73 arams))).. (tags
7f20: 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 70 (if (null? p
7f30: 61 72 61 6d 73 29 0a 09 09 20 20 20 20 20 20 27 arams)... '
7f40: 28 29 0a 09 09 20 20 20 20 20 20 28 63 64 72 20 ()... (cdr
7f50: 70 61 72 61 6d 73 29 29 29 0a 09 20 28 66 6f 72 params))).. (for
7f60: 6d 64 61 74 20 28 73 64 61 74 2d 67 65 74 2d 66 mdat (sdat-get-f
7f70: 6f 72 6d 64 61 74 20 73 65 6c 66 29 29 0a 09 20 ormdat self))..
7f80: 28 72 65 73 20 20 20 20 20 28 69 66 20 28 6e 6f (res (if (no
7f90: 74 20 66 6f 72 6d 64 61 74 29 20 23 66 0a 09 09 t formdat) #f...
7fa0: 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 28 73 (if (or (s
7fb0: 74 72 69 6e 67 3f 20 6b 65 79 29 28 6e 75 6d 62 tring? key)(numb
7fc0: 65 72 3f 20 6b 65 79 29 28 73 79 6d 62 6f 6c 3f er? key)(symbol?
7fd0: 20 6b 65 79 29 29 0a 09 09 09 20 20 28 69 66 20 key)).... (if
7fe0: 28 61 6e 64 20 28 76 65 63 74 6f 72 3f 20 66 6f (and (vector? fo
7ff0: 72 6d 64 61 74 29 28 65 71 3f 20 28 76 65 63 74 rmdat)(eq? (vect
8000: 6f 72 2d 6c 65 6e 67 74 68 20 66 6f 72 6d 64 61 or-length formda
8010: 74 29 20 31 29 28 68 61 73 68 2d 74 61 62 6c 65 t) 1)(hash-table
8020: 3f 20 28 76 65 63 74 6f 72 2d 72 65 66 20 66 6f ? (vector-ref fo
8030: 72 6d 64 61 74 20 30 29 29 29 0a 09 09 09 20 20 rmdat 0)))....
8040: 20 20 20 20 28 66 6f 72 6d 64 61 74 3a 67 65 74 (formdat:get
8050: 20 66 6f 72 6d 64 61 74 20 6b 65 79 29 0a 09 09 formdat key)...
8060: 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 . (begin...
8070: 09 09 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 ..(session:log s
8080: 65 6c 66 20 22 45 52 52 4f 52 3a 20 66 6f 72 6d elf "ERROR: form
8090: 64 61 74 3a 20 22 20 66 6f 72 6d 64 61 74 20 22 dat: " formdat "
80a0: 20 69 73 20 6e 6f 74 20 6f 66 20 63 6c 61 73 73 is not of class
80b0: 20 3c 66 6f 72 6d 64 61 74 3e 22 29 0a 09 09 09 <formdat>")....
80c0: 09 23 66 29 29 0a 09 09 09 20 20 28 62 65 67 69 .#f)).... (begi
80d0: 6e 0a 09 09 09 20 20 20 20 28 73 65 73 73 69 6f n.... (sessio
80e0: 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 45 52 52 4f n:log self "ERRO
80f0: 52 3a 20 62 61 64 20 6b 65 79 20 22 20 6b 65 79 R: bad key " key
8100: 29 0a 09 09 09 20 20 20 20 23 66 29 29 29 29 29 ).... #f)))))
8110: 0a 20 20 20 20 28 63 61 73 65 20 64 74 79 70 65 . (case dtype
8120: 0a 20 20 20 20 20 20 28 28 72 61 77 29 20 20 20 . ((raw)
8130: 20 20 72 65 73 29 0a 20 20 20 20 20 20 28 28 6e res). ((n
8140: 75 6d 62 65 72 29 20 20 28 69 66 20 28 73 74 72 umber) (if (str
8150: 69 6e 67 3f 20 72 65 73 29 28 73 74 72 69 6e 67 ing? res)(string
8160: 2d 3e 6e 75 6d 62 65 72 20 72 65 73 29 20 23 66 ->number res) #f
8170: 29 29 0a 20 20 20 20 20 20 28 28 65 73 63 61 70 )). ((escap
8180: 65 64 29 20 28 69 66 20 28 73 74 72 69 6e 67 3f ed) (if (string?
8190: 20 72 65 73 29 0a 09 09 20 20 20 20 20 28 73 3a res)... (s:
81a0: 68 74 6d 6c 2d 66 69 6c 74 65 72 2d 3e 73 74 72 html-filter->str
81b0: 69 6e 67 20 72 65 73 20 74 61 67 73 29 0a 09 09 ing res tags)...
81c0: 20 20 20 20 20 72 65 73 29 29 0a 20 20 20 20 20 res)).
81d0: 20 28 65 6c 73 65 20 20 20 20 20 20 28 69 66 20 (else (if
81e0: 28 73 74 72 69 6e 67 3f 20 72 65 73 29 0a 09 09 (string? res)...
81f0: 20 20 20 20 20 28 73 3a 68 74 6d 6c 2d 66 69 6c (s:html-fil
8200: 74 65 72 2d 3e 73 74 72 69 6e 67 20 72 65 73 20 ter->string res
8210: 27 28 29 29 0a 09 09 20 20 20 20 20 72 65 73 29 '())... res)
8220: 29 29 29 29 0a 0a 3b 3b 20 54 68 69 73 20 6f 6e ))))..;; This on
8230: 65 20 77 69 6c 6c 20 67 65 74 20 74 68 65 20 66 e will get the f
8240: 69 72 73 74 20 76 61 6c 75 65 20 66 6f 75 6e 64 irst value found
8250: 20 72 65 67 61 72 64 6c 65 73 73 20 6f 66 20 66 regardless of f
8260: 6f 72 6d 0a 28 64 65 66 69 6e 65 20 28 73 65 73 orm.(define (ses
8270: 73 69 6f 6e 3a 67 65 74 2d 69 6e 70 75 74 2d 6b sion:get-input-k
8280: 65 79 73 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 eys self). (let
8290: 2a 20 28 28 66 6f 72 6d 64 61 74 20 28 73 64 61 * ((formdat (sda
82a0: 74 2d 67 65 74 2d 66 6f 72 6d 64 61 74 20 73 65 t-get-formdat se
82b0: 6c 66 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e lf))). (if (n
82c0: 6f 74 20 66 6f 72 6d 64 61 74 29 20 23 66 0a 09 ot formdat) #f..
82d0: 28 69 66 20 28 61 6e 64 20 28 76 65 63 74 6f 72 (if (and (vector
82e0: 3f 20 66 6f 72 6d 64 61 74 29 28 65 71 3f 20 28 ? formdat)(eq? (
82f0: 76 65 63 74 6f 72 2d 6c 65 6e 67 74 68 20 66 6f vector-length fo
8300: 72 6d 64 61 74 29 20 31 29 28 68 61 73 68 2d 74 rmdat) 1)(hash-t
8310: 61 62 6c 65 3f 20 28 76 65 63 74 6f 72 2d 72 65 able? (vector-re
8320: 66 20 66 6f 72 6d 64 61 74 20 30 29 29 29 0a 09 f formdat 0)))..
8330: 20 20 20 20 28 66 6f 72 6d 64 61 74 3a 6b 65 79 (formdat:key
8340: 73 20 66 6f 72 6d 64 61 74 29 0a 09 20 20 20 20 s formdat)..
8350: 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 73 (begin.. (s
8360: 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 ession:log self
8370: 22 45 52 52 4f 52 3a 20 66 6f 72 6d 64 61 74 3a "ERROR: formdat:
8380: 20 22 20 66 6f 72 6d 64 61 74 20 22 20 69 73 20 " formdat " is
8390: 6e 6f 74 20 6f 66 20 63 6c 61 73 73 20 3c 66 6f not of class <fo
83a0: 72 6d 64 61 74 3e 22 29 0a 09 20 20 20 20 20 20 rmdat>")..
83b0: 23 66 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 #f)))))..(define
83c0: 20 28 73 65 73 73 69 6f 6e 3a 72 75 6e 2d 61 63 (session:run-ac
83d0: 74 69 6f 6e 73 20 73 65 6c 66 29 0a 20 20 28 6c tions self). (l
83e0: 65 74 2a 20 28 28 61 63 74 69 6f 6e 20 20 20 20 et* ((action
83f0: 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 72 (session:get-par
8400: 61 6d 20 73 65 6c 66 20 27 61 63 74 69 6f 6e 20 am self 'action
8410: 27 28 72 61 77 29 29 29 0a 09 20 28 70 61 67 65 '(raw))).. (page
8420: 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d (sdat-get-
8430: 70 61 67 65 20 73 65 6c 66 29 29 29 0a 20 20 20 page self))).
8440: 20 3b 3b 20 28 70 72 69 6e 74 20 22 61 63 74 69 ;; (print "acti
8450: 6f 6e 3d 22 20 61 63 74 69 6f 6e 20 22 20 70 61 on=" action " pa
8460: 67 65 3d 22 20 70 61 67 65 29 0a 20 20 20 20 28 ge=" page). (
8470: 69 66 20 61 63 74 69 6f 6e 0a 09 28 6c 65 74 20 if action..(let
8480: 28 28 61 63 74 69 6f 6e 2d 6c 73 74 20 20 28 73 ((action-lst (s
8490: 74 72 69 6e 67 2d 73 70 6c 69 74 20 61 63 74 69 tring-split acti
84a0: 6f 6e 20 22 2e 22 29 29 29 0a 09 20 20 3b 3b 20 on "."))).. ;;
84b0: 28 70 72 69 6e 74 20 22 61 63 74 69 6f 6e 2d 6c (print "action-l
84c0: 73 74 3d 22 20 61 63 74 69 6f 6e 2d 6c 73 74 29 st=" action-lst)
84d0: 0a 09 20 20 28 69 66 20 28 6e 6f 74 20 28 3d 20 .. (if (not (=
84e0: 28 6c 65 6e 67 74 68 20 61 63 74 69 6f 6e 2d 6c (length action-l
84f0: 73 74 29 20 32 29 29 20 0a 09 20 20 20 20 20 20 st) 2)) ..
8500: 28 65 72 72 3a 6c 6f 67 20 22 41 63 74 69 6f 6e (err:log "Action
8510: 20 73 68 6f 75 6c 64 20 62 65 20 6f 66 20 66 6f should be of fo
8520: 72 6d 3a 20 6d 6f 64 75 6c 65 2e 61 63 74 69 6f rm: module.actio
8530: 6e 22 29 0a 09 20 20 20 20 20 20 28 6c 65 74 2a n").. (let*
8540: 20 28 28 74 61 72 67 2d 70 61 67 65 20 20 20 28 ((targ-page (
8550: 63 61 72 20 61 63 74 69 6f 6e 2d 6c 73 74 29 29 car action-lst))
8560: 0a 09 09 20 20 20 20 20 28 70 72 6f 63 2d 6e 61 ... (proc-na
8570: 6d 65 20 20 20 28 73 74 72 69 6e 67 2d 61 70 70 me (string-app
8580: 65 6e 64 20 74 61 72 67 2d 70 61 67 65 20 22 2d end targ-page "-
8590: 61 63 74 69 6f 6e 22 29 29 0a 09 09 20 20 20 20 action"))...
85a0: 20 28 74 61 72 67 2d 61 63 74 69 6f 6e 20 28 63 (targ-action (c
85b0: 61 64 72 20 61 63 74 69 6f 6e 2d 6c 73 74 29 29 adr action-lst))
85c0: 29 0a 09 09 3b 3b 20 28 65 72 72 3a 6c 6f 67 20 )...;; (err:log
85d0: 22 74 61 72 67 2d 70 61 67 65 3d 22 20 74 61 72 "targ-page=" tar
85e0: 67 2d 70 61 67 65 20 22 20 70 72 6f 63 2d 6e 61 g-page " proc-na
85f0: 6d 65 3d 22 20 70 72 6f 63 2d 6e 61 6d 65 20 22 me=" proc-name "
8600: 20 74 61 72 67 2d 61 63 74 69 6f 6e 3d 22 20 74 targ-action=" t
8610: 61 72 67 2d 61 63 74 69 6f 6e 29 0a 0a 09 09 3b arg-action)....;
8620: 3b 20 63 61 6c 6c 20 68 65 72 65 20 6f 6e 6c 79 ; call here only
8630: 20 69 66 20 6e 65 76 65 72 20 63 61 6c 6c 65 64 if never called
8640: 20 62 65 66 6f 72 65 0a 09 09 28 69 66 20 28 73 before...(if (s
8650: 65 73 73 69 6f 6e 3a 6e 65 76 65 72 2d 63 61 6c ession:never-cal
8660: 6c 65 64 2d 70 61 67 65 3f 20 73 65 6c 66 20 74 led-page? self t
8670: 61 72 67 2d 70 61 67 65 29 0a 09 09 20 20 20 20 arg-page)...
8680: 28 73 65 73 73 69 6f 6e 3a 63 61 6c 6c 2d 70 61 (session:call-pa
8690: 72 74 73 20 73 65 6c 66 20 74 61 72 67 2d 70 61 rts self targ-pa
86a0: 67 65 20 27 63 6f 6e 74 72 6f 6c 29 29 0a 09 09 ge 'control))...
86b0: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
86c0: 20 20 20 20 20 20 70 72 6f 63 20 20 20 20 20 20 proc
86d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
86e0: 20 20 20 61 63 74 69 6f 6e 20 20 20 20 0a 0a 09 action ...
86f0: 09 28 69 66 20 23 74 20 3b 3b 20 73 65 74 20 74 .(if #t ;; set t
8700: 6f 20 23 74 20 74 6f 20 73 65 65 20 62 65 74 74 o #t to see bett
8710: 65 72 20 65 72 72 6f 72 20 6d 65 73 73 61 67 65 er error message
8720: 73 20 64 75 72 69 6e 67 20 64 65 62 75 67 67 69 s during debuggi
8730: 6e 20 3a 2d 29 0a 09 09 20 20 20 20 28 28 65 76 n :-)... ((ev
8740: 61 6c 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 al (string->symb
8750: 6f 6c 20 70 72 6f 63 2d 6e 61 6d 65 29 29 20 74 ol proc-name)) t
8760: 61 72 67 2d 61 63 74 69 6f 6e 29 20 3b 3b 20 75 arg-action) ;; u
8770: 6e 73 61 66 65 20 65 78 65 63 75 74 69 6f 6e 0a nsafe execution.
8780: 09 09 20 20 20 20 28 63 6f 6e 64 69 74 69 6f 6e .. (condition
8790: 2d 63 61 73 65 20 28 28 65 76 61 6c 20 28 73 74 -case ((eval (st
87a0: 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 70 72 6f ring->symbol pro
87b0: 63 2d 6e 61 6d 65 29 29 20 74 61 72 67 2d 61 63 c-name)) targ-ac
87c0: 74 69 6f 6e 29 0a 09 09 09 09 20 20 20 20 28 28 tion)..... ((
87d0: 65 78 6e 20 66 69 6c 65 29 20 28 73 3a 6c 6f 67 exn file) (s:log
87e0: 20 22 66 69 6c 65 20 65 72 72 6f 72 22 29 29 0a "file error")).
87f0: 09 09 09 09 20 20 20 20 28 28 65 78 6e 20 69 2f .... ((exn i/
8800: 6f 29 20 20 28 73 3a 6c 6f 67 20 22 69 2f 6f 20 o) (s:log "i/o
8810: 65 72 72 6f 72 22 29 29 0a 09 09 09 09 20 20 20 error")).....
8820: 20 28 28 65 78 6e 20 29 20 20 20 20 20 28 73 3a ((exn ) (s:
8830: 6c 6f 67 20 22 41 63 74 69 6f 6e 20 6e 6f 74 20 log "Action not
8840: 69 6d 70 6c 65 6d 65 6e 74 65 64 3a 20 22 20 70 implemented: " p
8850: 72 6f 63 2d 6e 61 6d 65 20 22 20 61 63 74 69 6f roc-name " actio
8860: 6e 3a 20 22 20 74 61 72 67 2d 61 63 74 69 6f 6e n: " targ-action
8870: 29 29 0a 09 09 09 09 20 20 20 20 28 76 61 72 20 ))..... (var
8880: 28 29 20 20 20 20 20 28 73 3a 6c 6f 67 20 22 55 () (s:log "U
8890: 6e 6b 6e 6f 77 6e 20 45 72 72 6f 72 22 29 29 29 nknown Error")))
88a0: 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 )))))))..(define
88b0: 20 28 73 65 73 73 69 6f 6e 3a 6e 65 76 65 72 2d (session:never-
88c0: 63 61 6c 6c 65 64 2d 70 61 67 65 3f 20 73 65 6c called-page? sel
88d0: 66 20 70 61 67 65 29 0a 20 20 28 73 65 73 73 69 f page). (sessi
88e0: 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 43 68 65 on:log self "Che
88f0: 63 6b 69 6e 67 20 66 6f 72 20 70 61 67 65 3a 20 cking for page:
8900: 22 20 70 61 67 65 29 0a 20 20 28 6e 6f 74 20 28 " page). (not (
8910: 6d 65 6d 62 65 72 20 70 61 67 65 20 28 73 64 61 member page (sda
8920: 74 2d 67 65 74 2d 73 65 65 6e 2d 70 61 67 65 73 t-get-seen-pages
8930: 20 73 65 6c 66 29 29 29 29 0a 0a 28 64 65 66 69 self))))..(defi
8940: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 2d ne (session:set-
8950: 63 61 6c 6c 65 64 21 20 73 65 6c 66 20 70 61 67 called! self pag
8960: 65 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 73 e). (sdat-set-s
8970: 65 65 6e 2d 70 61 67 65 73 21 20 73 65 6c 66 20 een-pages! self
8980: 28 63 6f 6e 73 20 70 61 67 65 20 28 73 64 61 74 (cons page (sdat
8990: 2d 67 65 74 2d 73 65 65 6e 2d 70 61 67 65 73 20 -get-seen-pages
89a0: 73 65 6c 66 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d self))))..;;====
89b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
89c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
89d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
89e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
89f0: 3d 3d 0a 3b 3b 20 41 6c 74 65 72 6e 61 74 69 76 ==.;; Alternativ
8a00: 65 20 64 61 74 61 20 74 79 70 65 20 64 65 6c 69 e data type deli
8a10: 76 65 72 79 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d very.;;=========
8a20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8a30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8a40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8a50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 =============..(
8a60: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
8a70: 61 6c 74 2d 6f 75 74 20 73 65 6c 66 29 0a 20 20 alt-out self).
8a80: 28 6c 65 74 20 28 28 64 61 74 20 28 73 64 61 74 (let ((dat (sdat
8a90: 2d 67 65 74 2d 61 6c 74 2d 70 61 67 65 2d 64 61 -get-alt-page-da
8aa0: 74 20 73 65 6c 66 29 29 29 0a 20 20 20 20 3b 3b t self))). ;;
8ab0: 20 28 73 3a 6c 6f 67 20 22 64 61 74 20 69 73 3a (s:log "dat is:
8ac0: 20 22 20 64 61 74 29 0a 20 20 20 20 3b 3b 20 28 " dat). ;; (
8ad0: 70 72 69 6e 74 20 22 48 54 54 50 2f 31 2e 31 20 print "HTTP/1.1
8ae0: 32 30 30 20 4f 4b 22 29 0a 20 20 20 20 28 70 72 200 OK"). (pr
8af0: 69 6e 74 20 22 44 61 74 65 3a 20 22 20 28 74 69 int "Date: " (ti
8b00: 6d 65 2d 3e 73 74 72 69 6e 67 20 28 73 65 63 6f me->string (seco
8b10: 6e 64 73 2d 3e 75 74 63 2d 74 69 6d 65 20 28 63 nds->utc-time (c
8b20: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 urrent-seconds))
8b30: 29 29 0a 20 20 20 20 28 70 72 69 6e 74 20 22 43 )). (print "C
8b40: 6f 6e 74 65 6e 74 2d 54 79 70 65 3a 20 22 20 28 ontent-Type: " (
8b50: 73 64 61 74 2d 67 65 74 2d 63 6f 6e 74 65 6e 74 sdat-get-content
8b60: 2d 74 79 70 65 20 73 65 6c 66 29 29 0a 20 20 20 -type self)).
8b70: 20 28 70 72 69 6e 74 20 22 41 63 63 65 70 74 2d (print "Accept-
8b80: 52 61 6e 67 65 73 3a 20 62 79 74 65 73 22 29 0a Ranges: bytes").
8b90: 20 20 20 20 28 70 72 69 6e 74 20 22 43 6f 6e 74 (print "Cont
8ba0: 65 6e 74 2d 4c 65 6e 67 74 68 3a 20 22 20 28 69 ent-Length: " (i
8bb0: 66 20 28 62 6c 6f 62 3f 20 64 61 74 29 0a 09 09 f (blob? dat)...
8bc0: 09 09 20 20 28 62 6c 6f 62 2d 73 69 7a 65 20 64 .. (blob-size d
8bd0: 61 74 29 0a 09 09 09 09 20 20 30 29 29 0a 20 20 at)..... 0)).
8be0: 20 20 28 70 72 69 6e 74 20 22 4b 65 65 70 2d 41 (print "Keep-A
8bf0: 6c 69 76 65 3a 20 74 69 6d 65 6f 75 74 3d 31 35 live: timeout=15
8c00: 2c 20 6d 61 78 3d 31 30 30 22 29 0a 20 20 20 20 , max=100").
8c10: 28 70 72 69 6e 74 20 22 43 6f 6e 6e 65 63 74 69 (print "Connecti
8c20: 6f 6e 3a 20 4b 65 65 70 2d 41 6c 69 76 65 22 29 on: Keep-Alive")
8c30: 0a 20 20 20 20 28 70 72 69 6e 74 20 22 22 29 0a . (print "").
8c40: 20 20 20 20 28 77 72 69 74 65 2d 73 74 72 69 6e (write-strin
8c50: 67 20 28 62 6c 6f 62 2d 3e 73 74 72 69 6e 67 20 g (blob->string
8c60: 64 61 74 29 20 23 66 20 28 63 75 72 72 65 6e 74 dat) #f (current
8c70: 2d 6f 75 74 70 75 74 2d 70 6f 72 74 29 29 29 29 -output-port))))
8c80: 0a .