Artifact
2fc2bb77c1124ab74b5553da04c93fec9f4b6135:
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 20 70 61 72 61 6d 73 29 0a age key params).
4ed0: 20 20 28 6c 65 74 2a 20 28 28 68 74 20 20 28 73 (let* ((ht (s
4ee0: 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 67 65 2d ession:get-page-
4ef0: 68 61 73 68 20 73 65 6c 66 20 70 61 67 65 29 29 hash self page))
4f00: 0a 09 20 28 72 65 73 20 28 68 61 73 68 2d 74 61 .. (res (hash-ta
4f10: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
4f20: 68 74 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e ht (s:any->strin
4f30: 67 20 6b 65 79 29 20 23 66 29 29 29 0a 20 20 20 g key) #f))).
4f40: 20 28 73 65 73 73 69 6f 6e 3a 61 70 70 6c 79 2d (session:apply-
4f50: 74 79 70 65 2d 70 72 65 66 65 72 65 6e 63 65 20 type-preference
4f60: 72 65 73 20 70 61 72 61 6d 73 29 29 29 0a 0a 3b res params)))..;
4f70: 3b 20 64 65 6c 65 74 65 20 61 20 73 65 73 73 69 ; delete a sessi
4f80: 6f 6e 20 76 61 72 20 66 6f 72 20 61 20 73 70 65 on var for a spe
4f90: 63 69 66 69 65 64 20 70 61 67 65 0a 3b 3b 0a 28 cified page.;;.(
4fa0: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
4fb0: 64 65 6c 21 20 73 65 6c 66 20 70 61 67 65 20 6b del! self page k
4fc0: 65 79 29 0a 20 20 28 6c 65 74 20 28 28 68 74 20 ey). (let ((ht
4fd0: 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 67 (session:get-pag
4fe0: 65 2d 68 61 73 68 20 73 65 6c 66 20 70 61 67 65 e-hash self page
4ff0: 29 29 29 0a 20 20 20 20 28 68 61 73 68 2d 74 61 ))). (hash-ta
5000: 62 6c 65 2d 64 65 6c 65 74 65 21 20 68 74 20 28 ble-delete! ht (
5010: 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6b 65 s:any->string ke
5020: 79 29 29 29 29 0a 0a 3b 3b 20 67 65 74 20 41 4c y))))..;; get AL
5030: 4c 20 6b 65 79 73 20 66 6f 72 20 74 68 69 73 20 L keys for this
5040: 70 61 67 65 20 61 6e 64 20 73 74 6f 72 65 20 69 page and store i
5050: 6e 20 74 68 65 20 73 65 73 73 69 6f 6e 20 70 61 n the session pa
5060: 67 65 76 61 72 73 20 68 61 73 68 0a 3b 3b 0a 28 gevars hash.;;.(
5070: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
5080: 67 65 74 2d 76 61 72 73 20 73 65 6c 66 29 0a 20 get-vars self).
5090: 20 28 6c 65 74 20 28 28 73 65 73 73 69 6f 6e 2d (let ((session-
50a0: 69 64 20 20 28 73 64 61 74 2d 67 65 74 2d 73 65 id (sdat-get-se
50b0: 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 29 29 29 ssion-id self)))
50c0: 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 73 65 . (if (not se
50d0: 73 73 69 6f 6e 2d 69 64 29 0a 09 28 65 72 72 3a ssion-id)..(err:
50e0: 6c 6f 67 20 22 45 52 52 4f 52 3a 20 4e 6f 20 73 log "ERROR: No s
50f0: 65 73 73 69 6f 6e 20 69 64 20 69 6e 20 73 65 73 ession id in ses
5100: 73 69 6f 6e 20 6f 62 6a 65 63 74 21 20 73 65 73 sion object! ses
5110: 73 69 6f 6e 3a 67 65 74 2d 76 61 72 73 22 29 0a sion:get-vars").
5120: 09 28 6c 65 74 2a 20 28 28 72 65 73 75 6c 74 20 .(let* ((result
5130: 20 20 20 20 20 20 20 20 20 20 20 20 23 66 29 0a #f).
5140: 09 20 20 20 20 20 20 20 28 63 6f 6e 6e 20 20 20 . (conn
5150: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 64 61 (sda
5160: 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 t-get-conn self)
5170: 29 0a 09 20 20 20 20 20 20 20 28 70 61 67 65 76 ).. (pagev
5180: 61 72 73 2d 62 65 66 6f 72 65 20 20 20 20 28 73 ars-before (s
5190: 64 61 74 2d 67 65 74 2d 70 61 67 65 76 61 72 73 dat-get-pagevars
51a0: 2d 62 65 66 6f 72 65 20 73 65 6c 66 29 29 0a 09 -before self))..
51b0: 20 20 20 20 20 20 20 28 73 65 73 73 69 6f 6e 76 (sessionv
51c0: 61 72 73 2d 62 65 66 6f 72 65 20 28 73 64 61 74 ars-before (sdat
51d0: 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 -get-sessionvars
51e0: 2d 62 65 66 6f 72 65 20 73 65 6c 66 29 29 0a 09 -before self))..
51f0: 20 20 20 20 20 20 20 28 67 6c 6f 62 61 6c 76 61 (globalva
5200: 72 73 2d 62 65 66 6f 72 65 20 20 28 73 64 61 74 rs-before (sdat
5210: 2d 67 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 2d -get-globalvars-
5220: 62 65 66 6f 72 65 20 73 65 6c 66 29 29 0a 09 20 before self))..
5230: 20 20 20 20 20 20 28 70 61 67 65 76 61 72 73 20 (pagevars
5240: 20 20 20 20 20 20 20 20 20 20 28 73 64 61 74 2d (sdat-
5250: 67 65 74 2d 70 61 67 65 76 61 72 73 20 73 65 6c get-pagevars sel
5260: 66 29 29 0a 09 20 20 20 20 20 20 20 28 73 65 73 f)).. (ses
5270: 73 69 6f 6e 76 61 72 73 20 20 20 20 20 20 20 20 sionvars
5280: 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f (sdat-get-sessio
5290: 6e 76 61 72 73 20 73 65 6c 66 29 29 0a 09 20 20 nvars self))..
52a0: 20 20 20 20 20 28 67 6c 6f 62 61 6c 76 61 72 73 (globalvars
52b0: 20 20 20 20 20 20 20 20 20 28 73 64 61 74 2d 67 (sdat-g
52c0: 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 20 73 65 et-globalvars se
52d0: 6c 66 29 29 0a 09 20 20 20 20 20 20 20 28 70 61 lf)).. (pa
52e0: 67 65 2d 6e 61 6d 65 20 20 20 20 20 20 20 20 20 ge-name
52f0: 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 20 (sdat-get-page
5300: 73 65 6c 66 29 29 0a 09 20 20 20 20 20 20 20 28 self)).. (
5310: 73 65 73 73 69 6f 6e 2d 6b 65 79 20 20 20 20 20 session-key
5320: 20 20 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 (sdat-get-ses
5330: 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 29 0a sion-key self)).
5340: 09 20 20 20 20 20 20 20 28 71 75 65 72 79 20 20 . (query
5350: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 74 72 (str
5360: 69 6e 67 2d 61 70 70 65 6e 64 0a 09 09 09 09 20 ing-append.....
5370: 20 20 20 22 53 45 4c 45 43 54 20 6b 65 79 2c 76 "SELECT key,v
5380: 61 6c 75 65 20 46 52 4f 4d 20 73 65 73 73 69 6f alue FROM sessio
5390: 6e 5f 76 61 72 73 20 49 4e 4e 45 52 20 4a 4f 49 n_vars INNER JOI
53a0: 4e 20 73 65 73 73 69 6f 6e 73 20 4f 4e 20 73 65 N sessions ON se
53b0: 73 73 69 6f 6e 5f 76 61 72 73 2e 73 65 73 73 69 ssion_vars.sessi
53c0: 6f 6e 5f 69 64 3d 73 65 73 73 69 6f 6e 73 2e 69 on_id=sessions.i
53d0: 64 20 22 0a 09 09 09 09 20 20 20 20 22 57 48 45 d "..... "WHE
53e0: 52 45 20 73 65 73 73 69 6f 6e 5f 6b 65 79 3d 3f RE session_key=?
53f0: 20 41 4e 44 20 70 61 67 65 3d 3f 3b 22 29 29 29 AND page=?;")))
5400: 0a 09 20 20 3b 3b 20 66 69 72 73 74 20 74 68 65 .. ;; first the
5410: 20 70 61 67 65 20 73 70 65 63 69 66 69 63 20 76 page specific v
5420: 61 72 73 0a 09 20 20 28 64 62 69 3a 66 6f 72 2d ars.. (dbi:for-
5430: 65 61 63 68 2d 72 6f 77 20 28 6c 61 6d 62 64 61 each-row (lambda
5440: 20 28 74 75 70 6c 65 29 0a 09 09 09 20 20 20 20 (tuple)....
5450: 20 20 28 6c 65 74 20 28 28 6b 20 28 76 65 63 74 (let ((k (vect
5460: 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 30 29 29 or-ref tuple 0))
5470: 0a 09 09 09 09 20 20 20 20 28 76 20 28 76 65 63 ..... (v (vec
5480: 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 31 29 tor-ref tuple 1)
5490: 29 29 0a 09 09 09 09 28 68 61 73 68 2d 74 61 62 )).....(hash-tab
54a0: 6c 65 2d 73 65 74 21 20 70 61 67 65 76 61 72 73 le-set! pagevars
54b0: 2d 62 65 66 6f 72 65 20 6b 20 76 29 0a 09 09 09 -before k v)....
54c0: 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 .(hash-table-set
54d0: 21 20 70 61 67 65 76 61 72 73 20 20 20 20 20 20 ! pagevars
54e0: 20 20 6b 20 76 29 29 29 0a 09 09 09 20 20 20 20 k v)))....
54f0: 63 6f 6e 6e 0a 09 09 09 20 20 20 20 28 73 3a 73 conn.... (s:s
5500: 71 6c 70 61 72 61 6d 20 71 75 65 72 79 20 73 65 qlparam query se
5510: 73 73 69 6f 6e 2d 6b 65 79 20 70 61 67 65 2d 6e ssion-key page-n
5520: 61 6d 65 29 29 0a 09 20 20 3b 3b 20 74 68 65 6e ame)).. ;; then
5530: 20 74 68 65 20 73 65 73 73 69 6f 6e 20 73 70 65 the session spe
5540: 63 69 66 69 63 20 76 61 72 73 0a 09 20 20 28 64 cific vars.. (d
5550: 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 bi:for-each-row
5560: 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 29 0a (lambda (tuple).
5570: 09 09 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 ... (let ((
5580: 6b 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 75 k (vector-ref tu
5590: 70 6c 65 20 30 29 29 0a 09 09 09 09 20 20 20 20 ple 0)).....
55a0: 28 76 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 (v (vector-ref t
55b0: 75 70 6c 65 20 31 29 29 29 0a 09 09 09 09 28 68 uple 1))).....(h
55c0: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 73 ash-table-set! s
55d0: 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 essionvars-befor
55e0: 65 20 6b 20 76 29 0a 09 09 09 09 28 68 61 73 68 e k v).....(hash
55f0: 2d 74 61 62 6c 65 2d 73 65 74 21 20 73 65 73 73 -table-set! sess
5600: 69 6f 6e 76 61 72 73 20 20 20 20 20 20 20 20 6b ionvars k
5610: 20 76 29 29 29 0a 09 09 09 20 20 20 20 63 6f 6e v))).... con
5620: 6e 0a 09 09 09 20 20 20 20 28 73 3a 73 71 6c 70 n.... (s:sqlp
5630: 61 72 61 6d 20 71 75 65 72 79 20 73 65 73 73 69 aram query sessi
5640: 6f 6e 2d 6b 65 79 20 22 2a 73 65 73 73 69 6f 6e on-key "*session
5650: 76 61 72 73 2a 22 29 29 0a 09 20 20 3b 3b 20 61 vars*")).. ;; a
5660: 6e 64 20 66 69 6e 61 6c 6c 79 20 74 68 65 20 67 nd finally the g
5670: 6c 6f 62 61 6c 20 76 61 72 73 0a 09 20 20 28 64 lobal vars.. (d
5680: 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 bi:for-each-row
5690: 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 29 0a (lambda (tuple).
56a0: 09 09 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 ... (let ((
56b0: 6b 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 75 k (vector-ref tu
56c0: 70 6c 65 20 30 29 29 0a 09 09 09 09 20 20 20 20 ple 0)).....
56d0: 28 76 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 (v (vector-ref t
56e0: 75 70 6c 65 20 31 29 29 29 0a 09 09 09 09 28 68 uple 1))).....(h
56f0: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 67 ash-table-set! g
5700: 6c 6f 62 61 6c 76 61 72 73 2d 62 65 66 6f 72 65 lobalvars-before
5710: 20 6b 20 76 29 0a 09 09 09 09 28 68 61 73 68 2d k v).....(hash-
5720: 74 61 62 6c 65 2d 73 65 74 21 20 67 6c 6f 62 61 table-set! globa
5730: 6c 76 61 72 73 20 20 20 20 20 20 20 20 6b 20 76 lvars k v
5740: 29 29 29 0a 09 09 09 20 20 20 20 63 6f 6e 6e 0a ))).... conn.
5750: 09 09 09 20 20 20 20 28 73 3a 73 71 6c 70 61 72 ... (s:sqlpar
5760: 61 6d 20 71 75 65 72 79 20 73 65 73 73 69 6f 6e am query session
5770: 2d 6b 65 79 20 22 2a 67 6c 6f 62 61 6c 76 61 72 -key "*globalvar
5780: 73 22 29 29 0a 09 20 20 29 29 29 29 0a 0a 28 64 s")).. ))))..(d
5790: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 efine (session:s
57a0: 61 76 65 2d 76 61 72 73 20 73 65 6c 66 29 0a 20 ave-vars self).
57b0: 20 28 6c 65 74 20 28 28 73 65 73 73 69 6f 6e 2d (let ((session-
57c0: 69 64 20 20 28 73 64 61 74 2d 67 65 74 2d 73 65 id (sdat-get-se
57d0: 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 29 29 29 ssion-id self)))
57e0: 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 73 65 . (if (not se
57f0: 73 73 69 6f 6e 2d 69 64 29 0a 09 28 65 72 72 3a ssion-id)..(err:
5800: 6c 6f 67 20 22 45 52 52 4f 52 3a 20 4e 6f 20 73 log "ERROR: No s
5810: 65 73 73 69 6f 6e 20 69 64 20 69 6e 20 73 65 73 ession id in ses
5820: 73 69 6f 6e 20 6f 62 6a 65 63 74 21 20 73 65 73 sion object! ses
5830: 73 69 6f 6e 3a 67 65 74 2d 76 61 72 73 22 29 0a sion:get-vars").
5840: 09 28 6c 65 74 2a 20 28 28 73 74 61 74 75 73 20 .(let* ((status
5850: 20 20 20 20 20 23 66 29 0a 09 20 20 20 20 20 20 #f)..
5860: 20 28 63 6f 6e 6e 20 20 20 20 20 20 20 20 28 73 (conn (s
5870: 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c dat-get-conn sel
5880: 66 29 29 0a 09 20 20 20 20 20 20 20 28 70 61 67 f)).. (pag
5890: 65 2d 6e 61 6d 65 20 20 20 28 73 64 61 74 2d 67 e-name (sdat-g
58a0: 65 74 2d 70 61 67 65 20 73 65 6c 66 29 29 0a 09 et-page self))..
58b0: 20 20 20 20 20 20 20 28 64 65 6c 2d 71 75 65 72 (del-quer
58c0: 79 20 20 20 22 44 45 4c 45 54 45 20 46 52 4f 4d y "DELETE FROM
58d0: 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 57 48 session_vars WH
58e0: 45 52 45 20 73 65 73 73 69 6f 6e 5f 69 64 3d 3f ERE session_id=?
58f0: 20 41 4e 44 20 70 61 67 65 3d 3f 20 41 4e 44 20 AND page=? AND
5900: 6b 65 79 3d 3f 3b 22 29 0a 09 20 20 20 20 20 20 key=?;")..
5910: 20 28 69 6e 73 2d 71 75 65 72 79 20 20 20 22 49 (ins-query "I
5920: 4e 53 45 52 54 20 49 4e 54 4f 20 73 65 73 73 69 NSERT INTO sessi
5930: 6f 6e 5f 76 61 72 73 20 28 73 65 73 73 69 6f 6e on_vars (session
5940: 5f 69 64 2c 70 61 67 65 2c 6b 65 79 2c 76 61 6c _id,page,key,val
5950: 75 65 29 20 56 41 4c 55 45 53 28 3f 2c 3f 2c 3f ue) VALUES(?,?,?
5960: 2c 3f 29 3b 22 29 0a 09 20 20 20 20 20 20 20 28 ,?);").. (
5970: 75 70 64 2d 71 75 65 72 79 20 20 20 22 55 50 44 upd-query "UPD
5980: 41 54 45 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 ATE session_vars
5990: 20 73 65 74 20 76 61 6c 75 65 3d 3f 20 57 48 45 set value=? WHE
59a0: 52 45 20 6b 65 79 3d 3f 20 41 4e 44 20 73 65 73 RE key=? AND ses
59b0: 73 69 6f 6e 5f 69 64 3d 3f 20 41 4e 44 20 70 61 sion_id=? AND pa
59c0: 67 65 3d 3f 3b 22 29 0a 09 20 20 20 20 20 20 20 ge=?;")..
59d0: 28 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 30 (changed-count 0
59e0: 29 29 0a 09 20 20 3b 3b 20 73 61 76 65 20 74 68 )).. ;; save th
59f0: 65 20 64 65 6c 74 61 20 6f 6e 6c 79 0a 09 20 20 e delta only..
5a00: 28 66 6f 72 2d 65 61 63 68 0a 09 20 20 20 28 6c (for-each.. (l
5a10: 61 6d 62 64 61 20 28 70 61 67 65 29 20 3b 3b 20 ambda (page) ;;
5a20: 70 61 67 65 20 69 73 3a 20 22 2a 67 6c 6f 62 61 page is: "*globa
5a30: 6c 76 61 72 73 2a 22 20 22 2a 73 65 73 73 69 6f lvars*" "*sessio
5a40: 6e 76 61 72 73 2a 22 20 6f 72 20 6f 74 68 65 72 nvars*" or other
5a50: 73 74 72 69 6e 67 0a 09 20 20 20 20 20 28 6c 65 string.. (le
5a60: 74 2a 20 28 28 62 65 66 6f 72 65 2d 61 66 74 65 t* ((before-afte
5a70: 72 2d 68 74 20 28 63 6f 6e 64 0a 09 09 09 09 20 r-ht (cond.....
5a80: 20 20 20 20 20 28 28 73 74 72 69 6e 67 3d 3f 20 ((string=?
5a90: 70 61 67 65 20 22 2a 73 65 73 73 69 6f 6e 76 61 page "*sessionva
5aa0: 72 73 2a 22 29 0a 09 09 09 09 20 20 20 20 20 20 rs*").....
5ab0: 20 28 76 65 63 74 6f 72 20 28 73 64 61 74 2d 67 (vector (sdat-g
5ac0: 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 20 73 et-sessionvars s
5ad0: 65 6c 66 29 0a 09 09 09 09 09 20 20 20 20 20 20 elf)......
5ae0: 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 (sdat-get-sessi
5af0: 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 20 73 65 onvars-before se
5b00: 6c 66 29 29 29 0a 09 09 09 09 20 20 20 20 20 20 lf))).....
5b10: 20 28 28 73 74 72 69 6e 67 3d 3f 20 70 61 67 65 ((string=? page
5b20: 20 22 2a 67 6c 6f 62 61 6c 76 61 72 73 2a 22 29 "*globalvars*")
5b30: 0a 09 09 09 09 09 28 76 65 63 74 6f 72 20 28 73 ......(vector (s
5b40: 64 61 74 2d 67 65 74 2d 67 6c 6f 62 61 6c 76 61 dat-get-globalva
5b50: 72 73 20 73 65 6c 66 29 0a 09 09 09 09 09 09 28 rs self).......(
5b60: 73 64 61 74 2d 67 65 74 2d 67 6c 6f 62 61 6c 76 sdat-get-globalv
5b70: 61 72 73 2d 62 65 66 6f 72 65 20 73 65 6c 66 29 ars-before self)
5b80: 29 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 65 ))..... (e
5b90: 6c 73 65 20 0a 09 09 09 09 09 28 76 65 63 74 6f lse ......(vecto
5ba0: 72 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 r (sdat-get-page
5bb0: 76 61 72 73 20 73 65 6c 66 29 0a 09 09 09 09 09 vars self)......
5bc0: 09 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 76 .(sdat-get-pagev
5bd0: 61 72 73 2d 62 65 66 6f 72 65 20 73 65 6c 66 29 ars-before self)
5be0: 29 29 29 29 0a 09 09 20 20 20 20 28 6d 61 73 74 ))))... (mast
5bf0: 65 72 2d 68 74 20 20 20 28 76 65 63 74 6f 72 2d er-ht (vector-
5c00: 72 65 66 20 62 65 66 6f 72 65 2d 61 66 74 65 72 ref before-after
5c10: 2d 68 74 20 30 29 29 0a 09 09 20 20 20 20 28 62 -ht 0))... (b
5c20: 65 66 6f 72 65 2d 68 74 20 20 20 28 76 65 63 74 efore-ht (vect
5c30: 6f 72 2d 72 65 66 20 62 65 66 6f 72 65 2d 61 66 or-ref before-af
5c40: 74 65 72 2d 68 74 20 31 29 29 0a 09 09 20 20 20 ter-ht 1))...
5c50: 20 28 6d 61 73 74 65 72 2d 6b 65 79 73 20 28 68 (master-keys (h
5c60: 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 6d ash-table-keys m
5c70: 61 73 74 65 72 2d 68 74 29 29 0a 09 09 20 20 20 aster-ht))...
5c80: 20 28 62 65 66 6f 72 65 2d 6b 65 79 73 20 28 68 (before-keys (h
5c90: 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 62 ash-table-keys b
5ca0: 65 66 6f 72 65 2d 68 74 29 29 0a 09 09 20 20 20 efore-ht))...
5cb0: 20 28 61 6c 6c 2d 6b 65 79 73 20 28 64 65 6c 65 (all-keys (dele
5cc0: 74 65 2d 64 75 70 6c 69 63 61 74 65 73 20 28 61 te-duplicates (a
5cd0: 70 70 65 6e 64 20 6d 61 73 74 65 72 2d 6b 65 79 ppend master-key
5ce0: 73 20 62 65 66 6f 72 65 2d 6b 65 79 73 29 29 29 s before-keys)))
5cf0: 29 0a 09 20 20 20 20 20 20 20 28 66 6f 72 2d 65 ).. (for-e
5d00: 61 63 68 20 0a 09 09 28 6c 61 6d 62 64 61 20 28 ach ...(lambda (
5d10: 6b 65 79 29 0a 09 09 20 20 28 6c 65 74 20 28 28 key)... (let ((
5d20: 6d 61 73 74 65 72 2d 76 61 6c 75 65 20 28 68 61 master-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 6d 61 73 74 65 72 2d 68 74 20 6b ault master-ht k
5d50: 65 79 20 23 66 29 29 0a 09 09 09 28 62 65 66 6f ey #f))....(befo
5d60: 72 65 2d 76 61 6c 75 65 20 28 68 61 73 68 2d 74 re-value (hash-t
5d70: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
5d80: 20 62 65 66 6f 72 65 2d 68 74 20 6b 65 79 20 23 before-ht key #
5d90: 66 29 29 29 0a 09 09 20 20 20 20 28 63 6f 6e 64 f)))... (cond
5da0: 0a 09 09 20 20 20 20 20 3b 3b 20 62 65 66 6f 72 ... ;; befor
5db0: 65 20 61 6e 64 20 61 66 74 65 72 20 65 78 69 73 e and after exis
5dc0: 74 20 61 6e 64 20 76 61 6c 75 65 20 75 6e 63 68 t and value unch
5dd0: 61 6e 67 65 64 20 2d 20 64 6f 20 6e 6f 74 68 69 anged - do nothi
5de0: 6e 67 0a 09 09 20 20 20 20 20 28 28 61 6e 64 20 ng... ((and
5df0: 6d 61 73 74 65 72 2d 76 61 6c 75 65 20 62 65 66 master-value bef
5e00: 6f 72 65 2d 76 61 6c 75 65 20 28 65 71 75 61 6c ore-value (equal
5e10: 3f 20 6d 61 73 74 65 72 2d 76 61 6c 75 65 20 62 ? master-value b
5e20: 65 66 6f 72 65 2d 76 61 6c 75 65 29 29 29 0a 09 efore-value)))..
5e30: 09 20 20 20 20 20 3b 3b 20 62 65 66 6f 72 65 20 . ;; before
5e40: 61 6e 64 20 61 66 74 65 72 20 65 78 69 73 74 20 and after exist
5e50: 62 75 74 20 61 72 65 20 63 68 61 6e 67 65 64 0a but are changed.
5e60: 09 09 20 20 20 20 20 28 28 61 6e 64 20 6d 61 73 .. ((and mas
5e70: 74 65 72 2d 76 61 6c 75 65 20 62 65 66 6f 72 65 ter-value before
5e80: 2d 76 61 6c 75 65 29 0a 09 09 20 20 20 20 20 20 -value)...
5e90: 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f (dbi:for-each-ro
5ea0: 77 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 w (lambda (tuple
5eb0: 29 0a 09 09 09 09 09 20 20 28 73 65 74 21 20 63 )...... (set! c
5ec0: 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 28 2b 20 hanged-count (+
5ed0: 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 31 29 changed-count 1)
5ee0: 29 29 0a 09 09 09 09 09 63 6f 6e 6e 0a 09 09 09 ))......conn....
5ef0: 09 09 28 73 3a 73 71 6c 70 61 72 61 6d 20 75 70 ..(s:sqlparam up
5f00: 64 2d 71 75 65 72 79 20 6d 61 73 74 65 72 2d 76 d-query master-v
5f10: 61 6c 75 65 20 6b 65 79 20 73 65 73 73 69 6f 6e alue key session
5f20: 2d 69 64 20 70 61 67 65 29 29 29 0a 09 09 20 20 -id page)))...
5f30: 20 20 20 3b 3b 20 6d 61 73 74 65 72 2d 76 61 6c ;; master-val
5f40: 75 65 20 6e 6f 20 6c 6f 6e 67 65 72 20 65 78 69 ue no longer exi
5f50: 73 74 73 20 28 69 2e 65 2e 20 23 66 29 20 2d 20 sts (i.e. #f) -
5f60: 72 65 6d 6f 76 65 20 69 74 65 6d 0a 09 09 20 20 remove item...
5f70: 20 20 20 28 28 6e 6f 74 20 6d 61 73 74 65 72 2d ((not master-
5f80: 76 61 6c 75 65 29 0a 09 09 20 20 20 20 20 20 28 value)... (
5f90: 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 dbi:for-each-row
5fa0: 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 29 (lambda (tuple)
5fb0: 0a 09 09 09 09 09 20 20 28 73 65 74 21 20 63 68 ...... (set! ch
5fc0: 61 6e 67 65 64 2d 63 6f 75 6e 74 20 28 2b 20 63 anged-count (+ c
5fd0: 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 31 29 29 hanged-count 1))
5fe0: 29 0a 09 09 09 09 09 63 6f 6e 6e 0a 09 09 09 09 )......conn.....
5ff0: 09 28 73 3a 73 71 6c 70 61 72 61 6d 20 64 65 6c .(s:sqlparam del
6000: 2d 71 75 65 72 79 20 73 65 73 73 69 6f 6e 2d 69 -query session-i
6010: 64 20 70 61 67 65 20 6b 65 79 29 29 29 0a 09 09 d page key)))...
6020: 20 20 20 20 20 3b 3b 20 62 65 66 6f 72 65 2d 76 ;; before-v
6030: 61 6c 75 65 20 64 6f 65 73 6e 27 74 20 65 78 69 alue doesn't exi
6040: 73 74 20 2d 20 69 6e 73 65 72 74 20 61 20 6e 65 st - insert a ne
6050: 77 20 76 61 6c 75 65 0a 09 09 20 20 20 20 20 28 w value... (
6060: 28 6e 6f 74 20 62 65 66 6f 72 65 2d 76 61 6c 75 (not before-valu
6070: 65 29 0a 09 09 20 20 20 20 20 20 28 64 62 69 3a e)... (dbi:
6080: 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 for-each-row (la
6090: 6d 62 64 61 20 28 74 75 70 6c 65 29 0a 09 09 09 mbda (tuple)....
60a0: 09 09 20 20 28 73 65 74 21 20 63 68 61 6e 67 65 .. (set! change
60b0: 64 2d 63 6f 75 6e 74 20 28 2b 20 63 68 61 6e 67 d-count (+ chang
60c0: 65 64 2d 63 6f 75 6e 74 20 31 29 29 29 0a 09 09 ed-count 1)))...
60d0: 09 09 09 63 6f 6e 6e 0a 09 09 09 09 09 28 73 3a ...conn......(s:
60e0: 73 71 6c 70 61 72 61 6d 20 69 6e 73 2d 71 75 65 sqlparam ins-que
60f0: 72 79 20 73 65 73 73 69 6f 6e 2d 69 64 20 70 61 ry session-id pa
6100: 67 65 20 6b 65 79 20 6d 61 73 74 65 72 2d 76 61 ge key master-va
6110: 6c 75 65 29 29 29 0a 09 09 20 20 20 20 20 28 65 lue)))... (e
6120: 6c 73 65 20 28 65 72 72 3a 6c 6f 67 20 22 53 68 lse (err:log "Sh
6130: 6f 75 6c 64 6e 27 74 20 67 65 74 20 68 65 72 65 ouldn't get here
6140: 22 29 29 29 29 29 0a 09 09 61 6c 6c 2d 6b 65 79 ")))))...all-key
6150: 73 29 29 29 20 3b 3b 20 70 72 6f 63 65 73 73 20 s))) ;; process
6160: 61 6c 6c 20 6b 65 79 73 0a 09 20 20 20 28 6c 69 all keys.. (li
6170: 73 74 20 22 2a 73 65 73 73 69 6f 6e 76 61 72 73 st "*sessionvars
6180: 2a 22 20 22 2a 67 6c 6f 62 61 6c 76 61 72 73 2a *" "*globalvars*
6190: 22 20 70 61 67 65 2d 6e 61 6d 65 29 29 29 29 29 " page-name)))))
61a0: 29 0a 0a 3b 3b 20 28 70 67 3a 73 71 6c 2d 6e 75 )..;; (pg:sql-nu
61b0: 6c 6c 2d 6f 62 6a 65 63 74 3f 20 65 6c 65 6d 65 ll-object? eleme
61c0: 6e 74 29 0a 28 64 65 66 69 6e 65 20 28 73 65 73 nt).(define (ses
61d0: 73 69 6f 6e 3a 72 65 61 64 2d 63 6f 6e 66 69 67 sion:read-config
61e0: 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 2a 20 28 self). (let* (
61f0: 28 63 67 69 2d 70 61 74 68 20 28 70 61 74 68 6e (cgi-path (pathn
6200: 61 6d 65 2d 64 69 72 65 63 74 6f 72 79 20 28 63 ame-directory (c
6210: 61 72 20 28 61 72 67 76 29 29 29 29 0a 20 20 20 ar (argv)))).
6220: 20 20 20 20 20 20 28 6e 61 6d 65 20 20 20 20 20 (name
6230: 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 28 (string-append (
6240: 69 66 20 63 67 69 2d 70 61 74 68 20 28 63 6f 6e if cgi-path (con
6250: 63 20 63 67 69 2d 70 61 74 68 20 22 2f 22 29 20 c cgi-path "/")
6260: 22 22 29 20 22 2e 22 20 28 70 61 74 68 6e 61 6d "") "." (pathnam
6270: 65 2d 66 69 6c 65 20 28 63 61 72 20 28 61 72 67 e-file (car (arg
6280: 76 29 29 29 20 22 2e 63 6f 6e 66 69 67 22 29 29 v))) ".config"))
6290: 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 ). (if (not (
62a0: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 6e 61 6d file-exists? nam
62b0: 65 29 29 0a 09 28 70 72 69 6e 74 20 6e 61 6d 65 e))..(print name
62c0: 20 22 20 6e 6f 74 20 66 6f 75 6e 64 20 61 74 20 " not found at
62d0: 22 20 28 63 75 72 72 65 6e 74 2d 64 69 72 65 63 " (current-direc
62e0: 74 6f 72 79 29 29 0a 09 28 6c 65 74 2a 20 28 28 tory))..(let* ((
62f0: 66 70 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 66 fp (open-input-f
6300: 69 6c 65 20 6e 61 6d 65 29 29 0a 09 20 20 20 20 ile name))..
6310: 20 20 20 28 69 6e 69 74 61 72 67 73 20 28 72 65 (initargs (re
6320: 61 64 20 66 70 29 29 29 0a 09 20 20 28 63 6c 6f ad fp))).. (clo
6330: 73 65 2d 69 6e 70 75 74 2d 70 6f 72 74 20 66 70 se-input-port fp
6340: 29 0a 09 20 20 69 6e 69 74 61 72 67 73 29 29 29 ).. initargs)))
6350: 29 0a 0a 3b 3b 20 63 61 6c 6c 20 74 68 65 20 63 )..;; call the c
6360: 6f 6e 74 72 6f 6c 6c 65 72 20 69 66 20 69 74 20 ontroller if it
6370: 65 78 69 73 74 73 0a 3b 3b 20 0a 3b 3b 20 57 41 exists.;; .;; WA
6380: 52 4e 49 4e 47 20 2d 20 74 68 69 73 20 63 6f 64 RNING - this cod
6390: 65 20 6e 65 65 64 73 20 61 20 64 65 66 65 6e 63 e needs a defenc
63a0: 65 20 61 67 61 69 6e 73 20 72 65 63 75 72 73 69 e agains recursi
63b0: 76 65 20 63 61 6c 6c 69 6e 67 21 21 21 21 21 0a ve calling!!!!!.
63c0: 3b 3b 0a 3b 3b 20 20 20 49 20 73 75 67 67 65 73 ;;.;; I sugges
63d0: 74 20 61 20 6c 69 6d 69 74 20 6f 66 20 31 30 30 t a limit of 100
63e0: 20 63 61 6c 6c 73 2e 20 50 6c 65 6e 74 79 20 66 calls. Plenty f
63f0: 6f 72 20 61 6c 6c 6f 77 69 6e 67 20 6d 75 6c 74 or allowing mult
6400: 69 70 6c 65 20 69 6e 73 74 61 6e 63 65 73 0a 3b iple instances.;
6410: 3b 20 20 20 6f 66 20 61 20 70 61 67 65 20 69 6e ; of a page in
6420: 73 69 64 65 20 61 6e 6f 74 68 65 72 20 70 61 67 side another pag
6430: 65 2e 20 0a 3b 3b 0a 3b 3b 20 70 61 72 74 73 20 e. .;;.;; parts
6440: 3d 20 27 62 6f 74 68 20 7c 20 27 63 6f 6e 74 72 = 'both | 'contr
6450: 6f 6c 20 7c 20 27 76 69 65 77 0a 3b 3b 0a 0a 28 ol | 'view.;;..(
6460: 64 65 66 69 6e 65 20 28 66 69 6c 65 73 2d 72 65 define (files-re
6470: 61 64 2d 3e 73 74 72 69 6e 67 20 2e 20 66 69 6c ad->string . fil
6480: 65 73 29 0a 20 20 28 73 74 72 69 6e 67 2d 69 6e es). (string-in
6490: 74 65 72 73 70 65 72 73 65 20 0a 20 20 20 28 61 tersperse . (a
64a0: 70 70 6c 79 20 61 70 70 65 6e 64 20 28 6d 61 70 pply append (map
64b0: 20 66 69 6c 65 2d 72 65 61 64 2d 3e 73 74 72 69 file-read->stri
64c0: 6e 67 20 66 69 6c 65 73 29 29 20 22 5c 6e 22 29 ng files)) "\n")
64d0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 66 69 6c 65 )..(define (file
64e0: 2d 72 65 61 64 2d 3e 73 74 72 69 6e 67 20 66 29 -read->string f)
64f0: 20 0a 20 20 28 6c 65 74 20 28 28 70 20 28 6f 70 . (let ((p (op
6500: 65 6e 2d 69 6e 70 75 74 2d 66 69 6c 65 20 66 29 en-input-file f)
6510: 29 29 0a 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 )). (let loop
6520: 20 28 28 68 65 64 20 28 72 65 61 64 2d 6c 69 6e ((hed (read-lin
6530: 65 20 70 29 29 0a 09 20 20 20 20 20 20 20 28 72 e p)).. (r
6540: 65 73 20 27 28 29 29 29 0a 20 20 20 20 20 20 28 es '())). (
6550: 69 66 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 if (eof-object?
6560: 68 65 64 29 0a 09 20 20 72 65 73 0a 09 20 20 28 hed).. res.. (
6570: 6c 6f 6f 70 20 28 72 65 61 64 2d 6c 69 6e 65 20 loop (read-line
6580: 70 29 28 61 70 70 65 6e 64 20 72 65 73 20 28 6c p)(append res (l
6590: 69 73 74 20 68 65 64 29 29 29 29 29 29 29 0a 0a ist hed)))))))..
65a0: 28 64 65 66 69 6e 65 20 28 70 72 6f 63 65 73 73 (define (process
65b0: 2d 70 6f 72 74 20 70 29 0a 20 20 28 6c 65 74 20 -port p). (let
65c0: 28 28 65 20 28 69 6e 74 65 72 61 63 74 69 6f 6e ((e (interaction
65d0: 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 29 29 29 0a -environment))).
65e0: 20 20 20 20 28 6d 61 70 20 0a 20 20 20 20 20 28 (map . (
65f0: 6c 61 6d 62 64 61 20 28 78 29 0a 20 20 20 20 20 lambda (x).
6600: 20 20 28 63 6f 6e 64 0a 09 28 28 6c 69 73 74 3f (cond..((list?
6610: 20 78 29 20 78 29 0a 09 28 28 73 74 72 69 6e 67 x) x)..((string
6620: 3f 20 78 29 20 78 29 0a 09 28 65 6c 73 65 20 27 ? x) x)..(else '
6630: 28 29 29 29 29 0a 20 20 20 20 20 28 70 6f 72 74 ()))). (port
6640: 2d 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 73 29 -map (lambda (s)
6650: 0a 09 09 20 28 65 76 61 6c 20 73 20 65 29 29 0a ... (eval s e)).
6660: 09 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 . (lambda
6670: 28 29 28 72 65 61 64 20 70 29 29 29 29 29 29 0a ()(read p)))))).
6680: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
6690: 6e 3a 70 72 6f 63 65 73 73 2d 66 69 6c 65 20 66 n:process-file f
66a0: 29 0a 20 20 28 6c 65 74 2a 20 28 28 70 20 20 20 ). (let* ((p
66b0: 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 66 69 6c (open-input-fil
66c0: 65 20 66 29 29 0a 09 20 28 64 61 74 20 20 28 70 e f)).. (dat (p
66d0: 72 6f 63 65 73 73 2d 70 6f 72 74 20 70 29 29 29 rocess-port p)))
66e0: 0a 20 20 20 20 28 63 6c 6f 73 65 2d 69 6e 70 75 . (close-inpu
66f0: 74 2d 70 6f 72 74 20 70 29 0a 20 20 20 20 64 61 t-port p). da
6700: 74 29 29 0a 0a 3b 3b 20 4d 61 79 20 32 30 31 31 t))..;; May 2011
6710: 2c 20 70 75 74 74 69 6e 67 20 61 6c 6c 20 70 61 , putting all pa
6720: 67 65 73 20 69 6e 74 6f 20 6f 6e 65 20 64 69 72 ges into one dir
6730: 65 63 74 6f 72 79 20 66 6f 72 20 74 68 65 20 66 ectory for the f
6740: 6f 6c 6c 6f 77 69 6e 67 20 72 65 61 73 6f 6e 73 ollowing reasons
6750: 3a 0a 3b 3b 20 20 20 31 2e 20 77 61 6e 74 20 66 :.;; 1. want f
6760: 69 6c 65 6e 61 6d 65 20 74 6f 20 72 65 66 6c 65 ilename to refle
6770: 63 74 20 70 61 67 65 20 6e 61 6d 65 20 28 65 6d ct page name (em
6780: 61 63 73 20 6c 69 6d 69 74 61 74 69 6f 6e 29 0a acs limitation).
6790: 3b 3b 20 20 20 32 2e 20 74 68 61 74 27 73 20 69 ;; 2. that's i
67a0: 74 21 20 6e 6f 20 6f 74 68 65 72 20 72 65 61 73 t! no other reas
67b0: 6f 6e 2e 20 63 6f 75 6c 64 20 6d 61 6b 65 20 69 on. could make i
67c0: 74 20 63 6f 6e 66 69 67 75 72 61 62 6c 65 20 2e t configurable .
67d0: 2e 2e 0a 3b 3b 20 70 61 67 65 2d 64 69 72 2d 73 ...;; page-dir-s
67e0: 74 79 6c 65 20 69 73 3a 0a 3b 3b 20 20 27 73 74 tyle is:.;; 'st
67f0: 6f 72 65 64 20 20 20 3d 3e 20 73 74 6f 72 65 64 ored => stored
6800: 20 69 6e 20 65 78 65 63 75 74 61 62 6c 65 0a 3b in executable.;
6810: 3b 20 20 27 66 6c 61 74 20 20 20 20 20 3d 3e 20 ; 'flat =>
6820: 70 61 67 65 73 20 66 6c 61 74 20 64 69 72 65 63 pages flat direc
6830: 74 6f 72 79 0a 3b 3b 20 20 27 64 69 72 20 20 20 tory.;; 'dir
6840: 20 20 20 3d 3e 20 64 69 72 65 63 74 6f 72 79 20 => directory
6850: 74 72 65 65 20 70 61 67 65 73 2f 3c 70 61 67 65 tree pages/<page
6860: 6e 61 6d 65 3e 2f 7b 76 69 65 77 2c 63 6f 6e 74 name>/{view,cont
6870: 72 6f 6c 7d 2e 73 63 6d 0a 3b 3b 20 70 61 72 74 rol}.scm.;; part
6880: 73 3a 0a 3b 3b 20 20 27 62 6f 74 68 20 20 20 20 s:.;; 'both
6890: 20 3d 3e 20 6c 6f 61 64 20 63 6f 6e 74 72 6f 6c => load control
68a0: 20 61 6e 64 20 76 69 65 77 20 28 61 6e 79 74 68 and view (anyth
68b0: 69 6e 67 20 6f 74 68 65 72 20 74 68 61 6e 20 76 ing other than v
68c0: 69 65 77 20 6f 72 20 63 6f 6e 74 72 6f 6c 0a 3b iew or control.;
68d0: 3b 20 20 27 76 69 65 77 20 20 20 20 20 3d 3e 20 ; 'view =>
68e0: 6c 6f 61 64 20 76 69 65 77 20 6f 6e 6c 79 0a 3b load view only.;
68f0: 3b 20 20 27 63 6f 6e 74 72 6f 6c 20 20 3d 3e 20 ; 'control =>
6900: 6c 6f 61 64 20 63 6f 6e 74 72 6f 6c 20 6f 6e 6c load control onl
6910: 79 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 y.(define (sessi
6920: 6f 6e 3a 63 61 6c 6c 2d 70 61 72 74 73 20 73 65 on:call-parts se
6930: 6c 66 20 70 61 67 65 20 23 21 6b 65 79 20 28 70 lf page #!key (p
6940: 61 72 74 73 20 27 62 6f 74 68 29 29 0a 20 20 28 arts 'both)). (
6950: 73 64 61 74 2d 73 65 74 2d 63 75 72 72 2d 70 61 sdat-set-curr-pa
6960: 67 65 21 20 73 65 6c 66 20 70 61 67 65 29 0a 20 ge! self page).
6970: 20 28 6c 65 74 2a 20 28 28 64 69 72 2d 73 74 79 (let* ((dir-sty
6980: 6c 65 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d le (sdat-get-
6990: 70 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 20 73 page-dir-style s
69a0: 65 6c 66 29 29 3b 3b 20 28 65 71 75 61 6c 3f 20 elf));; (equal?
69b0: 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 2d 64 (sdat-get-page-d
69c0: 69 72 2d 73 74 79 6c 65 20 73 65 6c 66 29 20 22 ir-style self) "
69d0: 6f 6e 65 64 69 72 22 29 29 20 3b 3b 20 66 6c 61 onedir")) ;; fla
69e0: 67 20 23 74 20 66 6f 72 20 6f 6e 65 64 69 72 2c g #t for onedir,
69f0: 20 23 66 20 66 6f 72 20 6f 6c 64 20 73 74 79 6c #f for old styl
6a00: 65 0a 09 20 28 64 69 72 20 20 20 20 20 20 20 20 e.. (dir
6a10: 20 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 (string-append
6a20: 20 28 73 64 61 74 2d 67 65 74 2d 73 72 6f 6f 74 (sdat-get-sroot
6a30: 20 73 65 6c 66 29 20 0a 09 09 09 09 20 20 20 20 self) .....
6a40: 20 20 28 69 66 20 64 69 72 2d 73 74 79 6c 65 20 (if dir-style
6a50: 0a 09 09 09 09 09 20 20 28 63 6f 6e 63 20 22 2f ...... (conc "/
6a60: 70 61 67 65 73 2f 22 29 0a 09 09 09 09 09 20 20 pages/")......
6a70: 28 63 6f 6e 63 20 22 2f 70 61 67 65 73 2f 22 20 (conc "/pages/"
6a80: 70 61 67 65 29 29 29 29 29 0a 20 20 20 20 28 63 page))))). (c
6a90: 61 73 65 20 64 69 72 2d 73 74 79 6c 65 0a 20 20 ase dir-style.
6aa0: 20 20 20 20 3b 3b 20 4e 42 2f 2f 20 53 74 6f 72 ;; NB// Stor
6ab0: 65 64 20 61 6c 77 61 79 73 20 6c 6f 61 64 73 20 ed always loads
6ac0: 62 6f 74 68 20 63 6f 6e 74 72 6f 6c 20 61 6e 64 both control and
6ad0: 20 76 69 65 77 0a 20 20 20 20 20 20 28 28 73 74 view. ((st
6ae0: 6f 72 65 64 29 0a 20 20 20 20 20 20 20 28 28 65 ored). ((e
6af0: 76 61 6c 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d val (string->sym
6b00: 62 6f 6c 20 28 63 6f 6e 63 20 22 70 61 67 65 73 bol (conc "pages
6b10: 3a 22 20 70 61 67 65 29 29 29 20 0a 09 73 65 6c :" page))) ..sel
6b20: 66 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 f
6b30: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 74 68 65 ;; the
6b40: 20 73 65 73 73 69 6f 6e 0a 09 28 73 64 61 74 2d session..(sdat-
6b50: 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 20 20 get-conn self)
6b60: 20 20 20 20 20 20 20 3b 3b 20 74 68 65 20 64 62 ;; the db
6b70: 20 63 6f 6e 6e 65 63 74 69 6f 6e 0a 09 28 73 64 connection..(sd
6b80: 61 74 2d 67 65 74 2d 73 68 61 72 65 64 2d 68 61 at-get-shared-ha
6b90: 73 68 20 73 65 6c 66 29 20 20 3b 3b 20 61 20 73 sh self) ;; a s
6ba0: 68 61 72 65 64 20 68 61 73 68 20 74 61 62 6c 65 hared hash table
6bb0: 20 66 6f 72 20 70 61 73 73 69 6e 67 20 64 61 74 for passing dat
6bc0: 61 20 74 6f 2f 66 72 6f 6d 20 70 61 67 65 20 63 a to/from page c
6bd0: 61 6c 6c 73 0a 09 29 29 0a 20 20 20 20 20 20 28 alls..)). (
6be0: 28 66 6c 61 74 29 20 20 20 0a 20 20 20 20 20 20 (flat) .
6bf0: 20 28 6c 65 74 2a 20 28 28 73 6f 2d 66 69 6c 65 (let* ((so-file
6c00: 20 20 28 63 6f 6e 63 20 64 69 72 20 70 61 67 65 (conc dir page
6c10: 20 22 2e 73 6f 22 29 29 0a 09 20 20 20 20 20 20 ".so"))..
6c20: 28 73 63 6d 2d 66 69 6c 65 20 28 63 6f 6e 63 20 (scm-file (conc
6c30: 64 69 72 20 70 61 67 65 20 22 2e 73 63 6d 22 29 dir page ".scm")
6c40: 29 0a 09 20 20 20 20 20 20 28 73 72 63 2d 66 69 ).. (src-fi
6c50: 6c 65 20 28 6f 72 20 28 66 69 6c 65 2d 65 78 69 le (or (file-exi
6c60: 73 74 73 3f 20 73 6f 2d 66 69 6c 65 29 0a 09 09 sts? so-file)...
6c70: 09 20 20 20 20 28 66 69 6c 65 2d 65 78 69 73 74 . (file-exist
6c80: 73 3f 20 73 63 6d 2d 66 69 6c 65 29 29 29 29 0a s? scm-file)))).
6c90: 09 20 28 69 66 20 73 72 63 2d 66 69 6c 65 0a 09 . (if src-file..
6ca0: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 (begin..
6cb0: 20 20 20 20 28 6c 6f 61 64 20 73 72 63 2d 66 69 (load src-fi
6cc0: 6c 65 29 0a 09 20 20 20 20 20 20 20 28 28 65 76 le).. ((ev
6cd0: 61 6c 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 al (string->symb
6ce0: 6f 6c 20 28 63 6f 6e 63 20 22 70 61 67 65 73 3a ol (conc "pages:
6cf0: 22 20 70 61 67 65 29 29 29 20 0a 09 09 73 65 6c " page))) ...sel
6d00: 66 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 f
6d10: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 74 68 65 ;; the
6d20: 20 73 65 73 73 69 6f 6e 0a 09 09 28 73 64 61 74 session...(sdat
6d30: 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 20 -get-conn self)
6d40: 20 20 20 20 20 20 20 20 3b 3b 20 74 68 65 20 64 ;; the d
6d50: 62 20 63 6f 6e 6e 65 63 74 69 6f 6e 0a 09 09 28 b connection...(
6d60: 73 64 61 74 2d 67 65 74 2d 73 68 61 72 65 64 2d sdat-get-shared-
6d70: 68 61 73 68 20 73 65 6c 66 29 20 20 3b 3b 20 61 hash self) ;; a
6d80: 20 73 68 61 72 65 64 20 68 61 73 68 20 74 61 62 shared hash tab
6d90: 6c 65 20 66 6f 72 20 70 61 73 73 69 6e 67 20 64 le for passing d
6da0: 61 74 61 20 74 6f 2f 66 72 6f 6d 20 70 61 67 65 ata to/from page
6db0: 20 63 61 6c 6c 73 0a 09 09 29 29 0a 09 20 20 20 calls...))..
6dc0: 20 20 28 6c 69 73 74 20 22 3c 70 3e 50 61 67 65 (list "<p>Page
6dd0: 20 6e 6f 74 20 66 6f 75 6e 64 20 22 20 70 61 67 not found " pag
6de0: 65 20 22 20 3c 2f 70 3e 22 29 29 29 29 0a 20 20 e " </p>")))).
6df0: 20 20 20 20 20 3b 3b 20 66 69 72 73 74 20 74 68 ;; first th
6e00: 65 20 63 6f 6e 74 72 6f 6c 0a 20 20 20 20 20 20 e control.
6e10: 20 3b 3b 20 28 6c 65 74 20 28 28 63 6f 6e 74 72 ;; (let ((contr
6e20: 6f 6c 2d 66 69 6c 65 20 28 63 6f 6e 63 20 22 70 ol-file (conc "p
6e30: 61 67 65 73 2f 22 20 70 61 67 65 20 22 5f 63 74 ages/" page "_ct
6e40: 72 6c 2e 73 63 6d 22 29 29 0a 20 20 20 20 20 20 rl.scm")).
6e50: 20 3b 3b 20 20 20 20 20 20 20 28 76 69 65 77 2d ;; (view-
6e60: 66 69 6c 65 20 20 20 20 28 63 6f 6e 63 20 22 70 file (conc "p
6e70: 61 67 65 73 2f 22 20 70 61 67 65 20 22 5f 76 69 ages/" page "_vi
6e80: 65 77 2e 73 63 6d 22 29 29 29 0a 20 20 20 20 20 ew.scm"))).
6e90: 20 20 3b 3b 20 20 20 28 69 66 20 28 61 6e 64 20 ;; (if (and
6ea0: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 63 6f (file-exists? co
6eb0: 6e 74 72 6f 6c 2d 66 69 6c 65 29 0a 20 20 20 20 ntrol-file).
6ec0: 20 20 20 3b 3b 20 20 09 20 20 28 6e 6f 74 20 28 ;; . (not (
6ed0: 65 71 3f 20 70 61 72 74 73 20 27 76 69 65 77 29 eq? parts 'view)
6ee0: 29 29 0a 20 20 20 20 20 20 20 3b 3b 20 20 20 20 )). ;;
6ef0: 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 (begin.
6f00: 20 3b 3b 20 20 20 20 20 20 20 20 20 28 73 65 73 ;; (ses
6f10: 73 69 6f 6e 3a 73 65 74 2d 63 61 6c 6c 65 64 21 sion:set-called!
6f20: 20 73 65 6c 66 20 70 61 67 65 29 0a 20 20 20 20 self page).
6f30: 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 28 6c ;; (l
6f40: 6f 61 64 20 63 6f 6e 74 72 6f 6c 2d 66 69 6c 65 oad control-file
6f50: 29 29 29 0a 20 20 20 20 20 20 20 3b 3b 20 20 20 ))). ;;
6f60: 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 (if (file-exists
6f70: 3f 20 76 69 65 77 2d 66 69 6c 65 29 0a 20 20 20 ? view-file).
6f80: 20 20 20 20 3b 3b 20 20 20 20 20 20 20 28 69 66 ;; (if
6f90: 20 28 6e 6f 74 20 28 65 71 3f 20 70 61 72 74 73 (not (eq? parts
6fa0: 20 27 63 6f 6e 74 72 6f 6c 29 29 0a 20 20 20 20 'control)).
6fb0: 20 20 20 3b 3b 20 20 09 20 28 73 65 73 73 69 6f ;; . (sessio
6fc0: 6e 3a 70 72 6f 63 65 73 73 2d 66 69 6c 65 20 76 n:process-file v
6fd0: 69 65 77 2d 66 69 6c 65 29 29 0a 20 20 20 20 20 iew-file)).
6fe0: 20 20 3b 3b 20 20 20 20 20 20 20 28 6c 69 73 74 ;; (list
6ff0: 20 22 3c 70 3e 50 61 67 65 20 6e 6f 74 20 66 6f "<p>Page not fo
7000: 75 6e 64 20 22 20 70 61 67 65 20 22 20 3c 2f 70 und " page " </p
7010: 3e 22 29 29 29 0a 20 20 20 20 20 20 28 28 64 69 >"))). ((di
7020: 72 29 20 22 45 52 52 4f 52 3a 20 20 64 69 72 20 r) "ERROR: dir
7030: 73 74 79 6c 65 20 6e 6f 74 20 79 65 74 20 72 65 style not yet re
7040: 2d 69 6d 70 6c 65 6d 65 6e 74 65 64 22 29 0a 20 -implemented").
7050: 20 20 20 20 20 28 65 6c 73 65 0a 20 20 20 20 20 (else.
7060: 20 20 28 6c 69 73 74 20 22 45 52 52 4f 52 3a 20 (list "ERROR:
7070: 70 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 20 6d page-dir-style m
7080: 75 73 74 20 62 65 20 73 74 6f 72 65 64 2c 20 64 ust be stored, d
7090: 69 72 20 6f 72 20 66 6c 61 74 2c 20 67 6f 74 20 ir or flat, got
70a0: 22 20 64 69 72 2d 73 74 79 6c 65 29 29 29 29 29 " dir-style)))))
70b0: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ..(define (sessi
70c0: 6f 6e 3a 63 61 6c 6c 20 73 65 6c 66 20 70 61 67 on:call self pag
70d0: 65 20 70 61 72 74 73 29 0a 20 20 28 73 65 73 73 e parts). (sess
70e0: 69 6f 6e 3a 63 61 6c 6c 2d 70 61 72 74 73 20 73 ion:call-parts s
70f0: 65 6c 66 20 70 61 67 65 20 27 62 6f 74 68 29 29 elf page 'both))
7100: 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 65 ..;; (define (se
7110: 73 73 69 6f 6e 3a 6c 6f 61 64 2d 6d 6f 64 65 6c ssion:load-model
7120: 20 73 65 6c 66 20 6d 6f 64 65 6c 29 0a 3b 3b 20 self model).;;
7130: 20 20 28 6c 65 74 20 28 28 6d 6f 64 65 6c 2e 73 (let ((model.s
7140: 63 6d 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e cm (string-appen
7150: 64 20 28 73 64 61 74 2d 67 65 74 2d 73 72 6f 6f d (sdat-get-sroo
7160: 74 20 73 65 6c 66 29 20 22 2f 6d 6f 64 65 6c 73 t self) "/models
7170: 2f 22 20 6d 6f 64 65 6c 20 22 2e 73 63 6d 22 29 /" model ".scm")
7180: 29 0a 3b 3b 20 09 28 6d 6f 64 65 6c 2e 73 6f 20 ).;; .(model.so
7190: 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 (string-append
71a0: 28 73 64 61 74 2d 67 65 74 2d 73 72 6f 6f 74 20 (sdat-get-sroot
71b0: 73 65 6c 66 29 20 22 2f 6d 6f 64 65 6c 73 2f 22 self) "/models/"
71c0: 20 6d 6f 64 65 6c 20 22 2e 73 6f 22 29 29 29 0a model ".so"))).
71d0: 3b 3b 20 20 20 20 20 28 69 66 20 28 66 69 6c 65 ;; (if (file
71e0: 2d 65 78 69 73 74 73 3f 20 6d 6f 64 65 6c 2e 73 -exists? model.s
71f0: 6f 29 0a 3b 3b 20 09 28 6c 6f 61 64 20 6d 6f 64 o).;; .(load mod
7200: 65 6c 2e 73 6f 29 0a 3b 3b 20 09 28 69 66 20 28 el.so).;; .(if (
7210: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 6d 6f 64 file-exists? mod
7220: 65 6c 2e 73 63 6d 29 0a 3b 3b 20 09 20 20 20 20 el.scm).;; .
7230: 28 6c 6f 61 64 20 6d 6f 64 65 6c 2e 73 63 6d 29 (load model.scm)
7240: 0a 3b 3b 20 09 20 20 20 20 28 73 3a 6c 6f 67 20 .;; . (s:log
7250: 22 45 52 52 4f 52 3a 20 6d 6f 64 65 6c 20 22 20 "ERROR: model "
7260: 6d 6f 64 65 6c 2e 73 63 6d 20 22 20 6e 6f 74 20 model.scm " not
7270: 66 6f 75 6e 64 22 29 29 29 29 29 0a 0a 3b 3b 20 found")))))..;;
7280: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
7290: 3a 6d 6f 64 65 6c 2d 70 61 74 68 20 73 65 6c 66 :model-path self
72a0: 20 6d 6f 64 65 6c 29 0a 3b 3b 20 20 20 28 73 74 model).;; (st
72b0: 72 69 6e 67 2d 61 70 70 65 6e 64 20 28 73 64 61 ring-append (sda
72c0: 74 2d 67 65 74 2d 73 72 6f 6f 74 20 73 65 6c 66 t-get-sroot self
72d0: 29 20 22 2f 6d 6f 64 65 6c 73 2f 22 20 6d 6f 64 ) "/models/" mod
72e0: 65 6c 20 22 2e 73 63 6d 22 29 29 0a 0a 28 64 65 el ".scm"))..(de
72f0: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 70 70 fine (session:pp
7300: 2d 66 6f 72 6d 64 61 74 20 73 65 6c 66 29 0a 20 -formdat self).
7310: 20 28 6c 65 74 20 28 28 64 61 74 20 28 66 6f 72 (let ((dat (for
7320: 6d 64 61 74 3a 61 6c 6c 2d 3e 73 74 72 69 6e 67 mdat:all->string
7330: 73 20 28 73 64 61 74 2d 67 65 74 2d 66 6f 72 6d s (sdat-get-form
7340: 64 61 74 20 73 65 6c 66 29 29 29 29 0a 20 20 20 dat self)))).
7350: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
7360: 65 72 73 65 20 64 61 74 20 22 3c 62 72 3e 20 22 erse dat "<br> "
7370: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 )))..(define (se
7380: 73 73 69 6f 6e 3a 70 61 72 61 6d 2d 3e 73 74 72 ssion:param->str
7390: 69 6e 67 20 70 61 72 61 6d 73 29 0a 20 20 3b 3b ing params). ;;
73a0: 20 28 65 72 72 3a 6c 6f 67 20 22 70 61 72 61 6d (err:log "param
73b0: 73 3d 22 20 70 61 72 61 6d 73 29 0a 20 20 28 69 s=" params). (i
73c0: 66 20 28 3c 20 28 6c 65 6e 67 74 68 20 70 61 72 f (< (length par
73d0: 61 6d 73 29 20 31 29 0a 20 20 20 20 20 20 22 22 ams) 1). ""
73e0: 0a 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 . (let loop
73f0: 20 28 28 6b 65 79 20 28 63 61 72 20 70 61 72 61 ((key (car para
7400: 6d 73 29 29 0a 09 09 20 28 76 61 6c 20 28 63 61 ms))... (val (ca
7410: 64 72 20 70 61 72 61 6d 73 29 29 0a 09 09 20 28 dr params))... (
7420: 74 61 69 6c 20 28 63 64 64 72 20 70 61 72 61 6d tail (cddr param
7430: 73 29 29 0a 09 09 20 28 72 65 73 75 6c 74 20 27 s))... (result '
7440: 28 29 29 29 0a 09 28 6c 65 74 20 28 28 6e 65 77 ()))..(let ((new
7450: 72 65 73 75 6c 74 20 28 63 6f 6e 73 20 28 73 74 result (cons (st
7460: 72 69 6e 67 2d 61 70 70 65 6e 64 20 28 73 3a 61 ring-append (s:a
7470: 6e 79 2d 3e 73 74 72 69 6e 67 20 6b 65 79 29 20 ny->string key)
7480: 22 3d 22 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 "=" (s:any->stri
7490: 6e 67 20 76 61 6c 29 29 0a 09 09 09 20 20 20 20 ng val))....
74a0: 20 20 20 72 65 73 75 6c 74 29 29 29 0a 09 20 20 result)))..
74b0: 28 69 66 20 28 3c 20 28 6c 65 6e 67 74 68 20 74 (if (< (length t
74c0: 61 69 6c 29 20 31 29 20 3b 3b 20 74 72 75 65 20 ail) 1) ;; true
74d0: 69 66 20 64 6f 6e 65 0a 09 20 20 20 20 20 20 28 if done.. (
74e0: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
74f0: 73 65 20 6e 65 77 72 65 73 75 6c 74 20 22 26 22 se newresult "&"
7500: 29 0a 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 ).. (loop (
7510: 63 61 72 20 74 61 69 6c 29 28 63 61 64 72 20 74 car tail)(cadr t
7520: 61 69 6c 29 28 63 64 64 72 20 74 61 69 6c 29 20 ail)(cddr tail)
7530: 6e 65 77 72 65 73 75 6c 74 29 29 29 29 29 29 0a newresult)))))).
7540: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
7550: 6e 3a 6c 69 6e 6b 2d 74 6f 20 73 65 6c 66 20 70 n:link-to self p
7560: 61 67 65 20 70 61 72 61 6d 73 29 0a 20 20 28 6c age params). (l
7570: 65 74 2a 20 28 28 73 65 72 76 65 72 20 20 20 20 et* ((server
7580: 28 69 66 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e (if (get-environ
7590: 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 48 ment-variable "H
75a0: 54 54 50 5f 48 4f 53 54 22 29 0a 09 09 09 28 67 TTP_HOST")....(g
75b0: 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 et-environment-v
75c0: 61 72 69 61 62 6c 65 20 22 48 54 54 50 5f 48 4f ariable "HTTP_HO
75d0: 53 54 22 29 0a 09 09 09 28 67 65 74 2d 65 6e 76 ST")....(get-env
75e0: 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c ironment-variabl
75f0: 65 20 22 53 45 52 56 45 52 5f 4e 41 4d 45 22 29 e "SERVER_NAME")
7600: 29 29 0a 09 20 28 73 63 72 69 70 74 20 28 6c 65 )).. (script (le
7610: 74 20 28 28 73 63 72 69 70 74 2d 6e 61 6d 65 20 t ((script-name
7620: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 28 67 (string-split (g
7630: 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 et-environment-v
7640: 61 72 69 61 62 6c 65 20 22 53 43 52 49 50 54 5f ariable "SCRIPT_
7650: 4e 41 4d 45 22 29 20 22 2f 22 29 29 29 0a 09 09 NAME") "/")))...
7660: 20 20 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 74 (if (> (lengt
7670: 68 20 73 63 72 69 70 74 2d 6e 61 6d 65 29 20 31 h script-name) 1
7680: 29 0a 09 09 20 20 20 20 20 20 20 28 73 74 72 69 )... (stri
7690: 6e 67 2d 61 70 70 65 6e 64 20 28 63 61 72 20 73 ng-append (car s
76a0: 63 72 69 70 74 2d 6e 61 6d 65 29 20 22 2f 22 20 cript-name) "/"
76b0: 28 63 61 64 72 20 73 63 72 69 70 74 2d 6e 61 6d (cadr script-nam
76c0: 65 29 29 0a 09 09 20 20 20 20 20 20 20 28 67 65 e))... (ge
76d0: 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 t-environment-va
76e0: 72 69 61 62 6c 65 20 22 53 43 52 49 50 54 5f 4e riable "SCRIPT_N
76f0: 41 4d 45 22 29 29 29 29 20 3b 3b 20 62 75 69 6c AME")))) ;; buil
7700: 64 20 73 63 72 69 70 74 20 6e 61 6d 65 20 66 72 d script name fr
7710: 6f 6d 20 66 69 72 73 74 20 74 77 6f 20 65 6c 65 om first two ele
7720: 6d 65 6e 74 73 2e 20 54 68 69 73 20 69 73 20 61 ments. This is a
7730: 20 68 61 6e 67 6f 76 65 72 20 66 72 6f 6d 20 62 hangover from b
7740: 65 66 6f 72 65 20 49 20 75 73 65 64 20 3f 20 69 efore I used ? i
7750: 6e 20 74 68 65 20 55 52 4c 2e 0a 09 20 28 73 65 n the URL... (se
7760: 73 73 69 6f 6e 2d 6b 65 79 20 28 73 64 61 74 2d ssion-key (sdat-
7770: 67 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 get-session-key
7780: 73 65 6c 66 29 29 0a 09 20 28 70 61 72 61 6d 73 self)).. (params
7790: 74 72 20 28 73 65 73 73 69 6f 6e 3a 70 61 72 61 tr (session:para
77a0: 6d 2d 3e 73 74 72 69 6e 67 20 70 61 72 61 6d 73 m->string params
77b0: 29 29 29 0a 20 20 20 20 3b 3b 20 28 73 65 73 73 ))). ;; (sess
77c0: 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 73 65 ion:log self "se
77d0: 72 76 65 72 3d 22 20 73 65 72 76 65 72 20 22 20 rver=" server "
77e0: 73 63 72 69 70 74 3d 22 20 73 63 72 69 70 74 20 script=" script
77f0: 22 20 70 61 67 65 3d 22 20 70 61 67 65 29 0a 20 " page=" page).
7800: 20 20 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e (string-appen
7810: 64 20 22 68 74 74 70 3a 2f 2f 22 20 73 65 72 76 d "http://" serv
7820: 65 72 20 22 2f 22 20 73 63 72 69 70 74 20 22 2f er "/" script "/
7830: 22 20 70 61 67 65 20 22 3f 22 20 70 61 72 61 6d " page "?" param
7840: 73 74 72 29 29 29 20 3b 3b 20 22 2f 73 6e 3d 22 str))) ;; "/sn="
7850: 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 29 0a session-key))).
7860: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
7870: 6e 3a 63 67 69 2d 6f 75 74 20 73 65 6c 66 29 0a n:cgi-out self).
7880: 20 20 28 6c 65 74 2a 20 28 28 63 6f 6e 74 65 6e (let* ((conten
7890: 74 20 20 28 6c 69 73 74 20 28 73 64 61 74 2d 67 t (list (sdat-g
78a0: 65 74 2d 63 6f 6e 74 65 6e 74 2d 74 79 70 65 20 et-content-type
78b0: 73 65 6c 66 29 29 29 20 3b 3b 20 27 28 22 43 6f self))) ;; '("Co
78c0: 6e 74 65 6e 74 2d 74 79 70 65 3a 20 74 65 78 74 ntent-type: text
78d0: 2f 68 74 6d 6c 3b 20 63 68 61 72 73 65 74 3d 69 /html; charset=i
78e0: 73 6f 2d 38 38 35 39 2d 31 5c 6e 5c 6e 22 29 29 so-8859-1\n\n"))
78f0: 0a 09 20 28 68 65 61 64 65 72 20 20 20 28 6c 65 .. (header (le
7900: 74 20 28 28 63 6f 6f 6b 69 65 20 28 73 64 61 74 t ((cookie (sdat
7910: 2d 67 65 74 2d 73 65 73 73 69 6f 6e 2d 63 6f 6f -get-session-coo
7920: 6b 69 65 20 73 65 6c 66 29 29 29 0a 09 09 20 20 kie self)))...
7930: 20 20 20 28 69 66 20 63 6f 6f 6b 69 65 0a 09 09 (if cookie...
7940: 09 20 28 63 6f 6e 73 20 28 73 74 72 69 6e 67 2d . (cons (string-
7950: 61 70 70 65 6e 64 20 22 53 65 74 2d 43 6f 6f 6b append "Set-Cook
7960: 69 65 3a 20 22 20 28 63 61 72 20 63 6f 6f 6b 69 ie: " (car cooki
7970: 65 29 29 0a 09 09 09 20 20 20 20 20 20 20 63 6f e)).... co
7980: 6e 74 65 6e 74 29 0a 09 09 09 20 63 6f 6e 74 65 ntent).... conte
7990: 6e 74 29 29 29 0a 09 20 28 70 61 67 65 64 61 74 nt))).. (pagedat
79a0: 20 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 (sdat-get-page
79b0: 64 61 74 20 73 65 6c 66 29 29 29 0a 20 20 20 20 dat self))).
79c0: 28 73 3a 63 67 69 2d 6f 75 74 20 0a 20 20 20 20 (s:cgi-out .
79d0: 20 28 63 6f 6e 73 20 68 65 61 64 65 72 20 70 61 (cons header pa
79e0: 67 65 64 61 74 29 29 29 29 0a 0a 28 64 65 66 69 gedat))))..(defi
79f0: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 ne (session:log
7a00: 73 65 6c 66 20 2e 20 6d 73 67 29 0a 20 20 28 77 self . msg). (w
7a10: 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 70 6f ith-output-to-po
7a20: 72 74 20 28 73 64 61 74 2d 67 65 74 2d 6c 6f 67 rt (sdat-get-log
7a30: 2d 70 6f 72 74 20 73 65 6c 66 29 20 3b 3b 20 28 -port self) ;; (
7a40: 73 64 61 74 2d 67 65 74 2d 6c 6f 67 70 74 20 73 sdat-get-logpt s
7a50: 65 6c 66 29 0a 20 20 20 20 28 6c 61 6d 62 64 61 elf). (lambda
7a60: 20 28 29 20 0a 20 20 20 20 20 20 28 61 70 70 6c () . (appl
7a70: 79 20 70 72 69 6e 74 20 6d 73 67 29 29 29 29 0a y print msg)))).
7a80: 0a 3b 3b 20 65 73 63 61 70 65 2c 20 63 6f 6e 76 .;; escape, conv
7a90: 65 72 74 20 6f 72 20 72 65 74 75 72 6e 20 72 61 ert or return ra
7aa0: 77 20 77 68 65 6e 20 67 69 76 65 6e 20 75 73 65 w when given use
7ab0: 72 20 69 6e 70 75 74 20 64 61 74 61 20 74 68 61 r input data tha
7ac0: 74 20 70 6f 74 65 6e 74 69 61 6c 6c 79 0a 3b 3b t potentially.;;
7ad0: 20 63 6f 75 6c 64 20 62 65 20 6d 61 6c 69 63 69 could be malici
7ae0: 6f 75 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 ous.;;.(define (
7af0: 73 65 73 73 69 6f 6e 3a 61 70 70 6c 79 2d 74 79 session:apply-ty
7b00: 70 65 2d 70 72 65 66 65 72 65 6e 63 65 20 72 65 pe-preference re
7b10: 73 20 70 61 72 61 6d 73 29 0a 20 20 28 6c 65 74 s params). (let
7b20: 2a 20 28 28 64 74 79 70 65 20 20 20 20 28 69 66 * ((dtype (if
7b30: 20 28 6e 75 6c 6c 3f 20 70 61 72 61 6d 73 29 0a (null? params).
7b40: 09 09 20 20 20 20 20 20 20 27 65 73 63 61 70 65 .. 'escape
7b50: 64 0a 09 09 20 20 20 20 20 20 20 28 63 61 72 20 d... (car
7b60: 70 61 72 61 6d 73 29 29 29 0a 09 20 28 74 61 67 params))).. (tag
7b70: 73 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 s (if (null?
7b80: 70 61 72 61 6d 73 29 0a 09 09 20 20 20 20 20 20 params)...
7b90: 27 28 29 0a 09 09 20 20 20 20 20 20 28 63 64 72 '()... (cdr
7ba0: 20 70 61 72 61 6d 73 29 29 29 29 0a 20 20 20 20 params)))).
7bb0: 28 63 61 73 65 20 64 74 79 70 65 0a 20 20 20 20 (case dtype.
7bc0: 20 20 28 28 72 61 77 29 20 20 20 20 20 72 65 73 ((raw) res
7bd0: 29 0a 20 20 20 20 20 20 28 28 6e 75 6d 62 65 72 ). ((number
7be0: 29 20 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 ) (if (string?
7bf0: 72 65 73 29 28 73 74 72 69 6e 67 2d 3e 6e 75 6d res)(string->num
7c00: 62 65 72 20 72 65 73 29 20 23 66 29 29 0a 20 20 ber res) #f)).
7c10: 20 20 20 20 28 28 65 73 63 61 70 65 64 29 20 28 ((escaped) (
7c20: 69 66 20 28 73 74 72 69 6e 67 3f 20 72 65 73 29 if (string? res)
7c30: 0a 09 09 20 20 20 20 20 28 73 3a 68 74 6d 6c 2d ... (s:html-
7c40: 66 69 6c 74 65 72 2d 3e 73 74 72 69 6e 67 20 72 filter->string r
7c50: 65 73 20 74 61 67 73 29 0a 09 09 20 20 20 20 20 es tags)...
7c60: 72 65 73 29 29 0a 20 20 20 20 20 20 28 28 65 73 res)). ((es
7c70: 63 61 70 65 64 2d 6e 6c 29 20 28 69 66 20 28 73 caped-nl) (if (s
7c80: 74 72 69 6e 67 3f 20 72 65 73 29 20 3b 3b 20 65 tring? res) ;; e
7c90: 73 63 61 70 65 20 5c 6e 20 61 6e 64 20 5c 72 0a scape \n and \r.
7ca0: 09 09 09 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 ...(string-inter
7cb0: 73 70 65 72 73 65 0a 09 09 09 20 28 73 74 72 69 sperse.... (stri
7cc0: 6e 67 2d 73 70 6c 69 74 0a 09 09 09 20 20 28 73 ng-split.... (s
7cd0: 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
7ce0: 65 0a 09 09 09 20 20 20 28 73 74 72 69 6e 67 2d e.... (string-
7cf0: 73 70 6c 69 74 20 28 73 3a 68 74 6d 6c 2d 66 69 split (s:html-fi
7d00: 6c 74 65 72 2d 3e 73 74 72 69 6e 67 20 72 65 73 lter->string res
7d10: 20 74 61 67 73 29 20 22 5c 6e 22 29 0a 09 09 09 tags) "\n")....
7d20: 20 20 20 22 5c 5c 6e 22 29 0a 09 09 09 20 20 22 "\\n").... "
7d30: 5c 72 22 29 0a 09 09 09 20 22 5c 5c 72 22 29 0a \r").... "\\r").
7d40: 09 09 09 72 65 73 29 29 0a 20 20 20 20 20 20 28 ...res)). (
7d50: 65 6c 73 65 20 20 20 20 20 20 28 69 66 20 28 73 else (if (s
7d60: 74 72 69 6e 67 3f 20 72 65 73 29 0a 09 09 20 20 tring? res)...
7d70: 20 20 20 28 73 3a 68 74 6d 6c 2d 66 69 6c 74 65 (s:html-filte
7d80: 72 2d 3e 73 74 72 69 6e 67 20 72 65 73 20 27 28 r->string res '(
7d90: 29 29 0a 09 09 20 20 20 20 20 72 65 73 29 29 29 ))... res)))
7da0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 ))..(define (ses
7db0: 73 69 6f 6e 3a 67 65 74 2d 70 61 72 61 6d 20 73 sion:get-param s
7dc0: 65 6c 66 20 6b 65 79 20 74 79 70 65 2d 70 61 72 elf key type-par
7dd0: 61 6d 73 29 0a 20 20 3b 3b 20 28 73 65 73 73 69 ams). ;; (sessi
7de0: 6f 6e 3a 6c 6f 67 20 73 3a 73 65 73 73 69 6f 6e on:log s:session
7df0: 20 22 70 61 72 61 6d 73 3d 22 20 28 73 6c 6f 74 "params=" (slot
7e00: 2d 72 65 66 20 73 3a 73 65 73 73 69 6f 6e 20 27 -ref s:session '
7e10: 70 61 72 61 6d 73 29 29 0a 20 20 28 6c 65 74 2a params)). (let*
7e20: 20 28 28 70 61 72 61 6d 73 20 28 73 64 61 74 2d ((params (sdat-
7e30: 67 65 74 2d 70 61 72 61 6d 73 20 73 65 6c 66 29 get-params self)
7e40: 29 0a 09 20 28 72 65 73 20 20 20 20 28 73 65 73 ).. (res (ses
7e50: 73 69 6f 6e 3a 67 65 74 2d 70 61 72 61 6d 2d 66 sion:get-param-f
7e60: 72 6f 6d 20 70 61 72 61 6d 73 20 6b 65 79 29 29 rom params key))
7e70: 29 0a 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 61 ). (session:a
7e80: 70 70 6c 79 2d 74 79 70 65 2d 70 72 65 66 65 72 pply-type-prefer
7e90: 65 6e 63 65 20 72 65 73 20 74 79 70 65 2d 70 61 ence res type-pa
7ea0: 72 61 6d 73 29 29 29 0a 0a 3b 3b 20 54 68 69 73 rams)))..;; This
7eb0: 20 6f 6e 65 20 77 69 6c 6c 20 67 65 74 20 74 68 one will get th
7ec0: 65 20 66 69 72 73 74 20 76 61 6c 75 65 20 66 6f e first value fo
7ed0: 75 6e 64 20 72 65 67 61 72 64 6c 65 73 73 20 6f und regardless o
7ee0: 66 20 66 6f 72 6d 0a 3b 3b 20 70 61 72 61 6d 3a f form.;; param:
7ef0: 20 28 64 74 79 70 65 20 5b 74 61 67 31 20 74 61 (dtype [tag1 ta
7f00: 67 32 20 2e 2e 2e 5d 29 0a 3b 3b 20 64 74 79 70 g2 ...]).;; dtyp
7f10: 65 3a 0a 3b 3b 20 20 20 20 27 72 61 77 20 20 20 e:.;; 'raw
7f20: 20 20 3a 20 64 6f 20 6e 6f 20 63 6f 6e 76 65 72 : do no conver
7f30: 73 69 6f 6e 0a 3b 3b 20 20 20 20 27 6e 75 6d 62 sion.;; 'numb
7f40: 65 72 20 20 3a 20 63 6f 6e 76 65 72 74 20 74 6f er : convert to
7f50: 20 6e 75 6d 62 65 72 2c 20 72 65 74 75 72 6e 20 number, return
7f60: 23 66 20 69 66 20 66 61 69 6c 73 0a 3b 3b 20 20 #f if fails.;;
7f70: 20 20 27 65 73 63 61 70 65 64 20 3a 20 75 73 65 'escaped : use
7f80: 20 68 74 6d 6c 2d 65 73 63 61 70 65 20 74 6f 20 html-escape to
7f90: 70 72 6f 74 65 63 74 20 74 68 65 20 69 6e 70 75 protect the inpu
7fa0: 74 20 2d 2d 20 74 68 69 73 20 69 73 20 74 68 65 t -- this is the
7fb0: 20 64 65 66 61 75 6c 74 0a 3b 3b 0a 28 64 65 66 default.;;.(def
7fc0: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 ine (session:get
7fd0: 2d 69 6e 70 75 74 20 73 65 6c 66 20 6b 65 79 20 -input self key
7fe0: 70 61 72 61 6d 73 29 0a 20 20 28 6c 65 74 2a 20 params). (let*
7ff0: 28 28 64 74 79 70 65 20 20 20 20 28 69 66 20 28 ((dtype (if (
8000: 6e 75 6c 6c 3f 20 70 61 72 61 6d 73 29 0a 09 09 null? params)...
8010: 20 20 20 20 20 20 20 27 65 73 63 61 70 65 64 0a 'escaped.
8020: 09 09 20 20 20 20 20 20 20 28 63 61 72 20 70 61 .. (car pa
8030: 72 61 6d 73 29 29 29 0a 09 20 28 74 61 67 73 20 rams))).. (tags
8040: 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 70 61 (if (null? pa
8050: 72 61 6d 73 29 0a 09 09 20 20 20 20 20 20 27 28 rams)... '(
8060: 29 0a 09 09 20 20 20 20 20 20 28 63 64 72 20 70 )... (cdr p
8070: 61 72 61 6d 73 29 29 29 0a 09 20 28 66 6f 72 6d arams))).. (form
8080: 64 61 74 20 28 73 64 61 74 2d 67 65 74 2d 66 6f dat (sdat-get-fo
8090: 72 6d 64 61 74 20 73 65 6c 66 29 29 0a 09 20 28 rmdat self)).. (
80a0: 72 65 73 20 20 20 20 20 28 69 66 20 28 6e 6f 74 res (if (not
80b0: 20 66 6f 72 6d 64 61 74 29 20 23 66 0a 09 09 20 formdat) #f...
80c0: 20 20 20 20 20 28 69 66 20 28 6f 72 20 28 73 74 (if (or (st
80d0: 72 69 6e 67 3f 20 6b 65 79 29 28 6e 75 6d 62 65 ring? key)(numbe
80e0: 72 3f 20 6b 65 79 29 28 73 79 6d 62 6f 6c 3f 20 r? key)(symbol?
80f0: 6b 65 79 29 29 0a 09 09 09 20 20 28 69 66 20 28 key)).... (if (
8100: 61 6e 64 20 28 76 65 63 74 6f 72 3f 20 66 6f 72 and (vector? for
8110: 6d 64 61 74 29 28 65 71 3f 20 28 76 65 63 74 6f mdat)(eq? (vecto
8120: 72 2d 6c 65 6e 67 74 68 20 66 6f 72 6d 64 61 74 r-length formdat
8130: 29 20 31 29 28 68 61 73 68 2d 74 61 62 6c 65 3f ) 1)(hash-table?
8140: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 66 6f 72 (vector-ref for
8150: 6d 64 61 74 20 30 29 29 29 0a 09 09 09 20 20 20 mdat 0)))....
8160: 20 20 20 28 66 6f 72 6d 64 61 74 3a 67 65 74 20 (formdat:get
8170: 66 6f 72 6d 64 61 74 20 6b 65 79 29 0a 09 09 09 formdat key)....
8180: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 (begin....
8190: 09 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 .(session:log se
81a0: 6c 66 20 22 45 52 52 4f 52 3a 20 66 6f 72 6d 64 lf "ERROR: formd
81b0: 61 74 3a 20 22 20 66 6f 72 6d 64 61 74 20 22 20 at: " formdat "
81c0: 69 73 20 6e 6f 74 20 6f 66 20 63 6c 61 73 73 20 is not of class
81d0: 3c 66 6f 72 6d 64 61 74 3e 22 29 0a 09 09 09 09 <formdat>").....
81e0: 23 66 29 29 0a 09 09 09 20 20 28 62 65 67 69 6e #f)).... (begin
81f0: 0a 09 09 09 20 20 20 20 28 73 65 73 73 69 6f 6e .... (session
8200: 3a 6c 6f 67 20 73 65 6c 66 20 22 45 52 52 4f 52 :log self "ERROR
8210: 3a 20 62 61 64 20 6b 65 79 20 22 20 6b 65 79 29 : bad key " key)
8220: 0a 09 09 09 20 20 20 20 23 66 29 29 29 29 29 0a .... #f))))).
8230: 20 20 20 20 28 63 61 73 65 20 64 74 79 70 65 0a (case dtype.
8240: 20 20 20 20 20 20 28 28 72 61 77 29 20 20 20 20 ((raw)
8250: 20 72 65 73 29 0a 20 20 20 20 20 20 28 28 6e 75 res). ((nu
8260: 6d 62 65 72 29 20 20 28 69 66 20 28 73 74 72 69 mber) (if (stri
8270: 6e 67 3f 20 72 65 73 29 28 73 74 72 69 6e 67 2d ng? res)(string-
8280: 3e 6e 75 6d 62 65 72 20 72 65 73 29 20 23 66 29 >number res) #f)
8290: 29 0a 20 20 20 20 20 20 28 28 65 73 63 61 70 65 ). ((escape
82a0: 64 29 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 d) (if (string?
82b0: 72 65 73 29 0a 09 09 20 20 20 20 20 28 73 3a 68 res)... (s:h
82c0: 74 6d 6c 2d 66 69 6c 74 65 72 2d 3e 73 74 72 69 tml-filter->stri
82d0: 6e 67 20 72 65 73 20 74 61 67 73 29 0a 09 09 20 ng res tags)...
82e0: 20 20 20 20 72 65 73 29 29 0a 20 20 20 20 20 20 res)).
82f0: 28 65 6c 73 65 20 20 20 20 20 20 28 69 66 20 28 (else (if (
8300: 73 74 72 69 6e 67 3f 20 72 65 73 29 0a 09 09 20 string? res)...
8310: 20 20 20 20 28 73 3a 68 74 6d 6c 2d 66 69 6c 74 (s:html-filt
8320: 65 72 2d 3e 73 74 72 69 6e 67 20 72 65 73 20 27 er->string res '
8330: 28 29 29 0a 09 09 20 20 20 20 20 72 65 73 29 29 ())... res))
8340: 29 29 29 0a 0a 3b 3b 20 54 68 69 73 20 6f 6e 65 )))..;; This one
8350: 20 77 69 6c 6c 20 67 65 74 20 74 68 65 20 66 69 will get the fi
8360: 72 73 74 20 76 61 6c 75 65 20 66 6f 75 6e 64 20 rst value found
8370: 72 65 67 61 72 64 6c 65 73 73 20 6f 66 20 66 6f regardless of fo
8380: 72 6d 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 rm.(define (sess
8390: 69 6f 6e 3a 67 65 74 2d 69 6e 70 75 74 2d 6b 65 ion:get-input-ke
83a0: 79 73 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 2a ys self). (let*
83b0: 20 28 28 66 6f 72 6d 64 61 74 20 28 73 64 61 74 ((formdat (sdat
83c0: 2d 67 65 74 2d 66 6f 72 6d 64 61 74 20 73 65 6c -get-formdat sel
83d0: 66 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f f))). (if (no
83e0: 74 20 66 6f 72 6d 64 61 74 29 20 23 66 0a 09 28 t formdat) #f..(
83f0: 69 66 20 28 61 6e 64 20 28 76 65 63 74 6f 72 3f if (and (vector?
8400: 20 66 6f 72 6d 64 61 74 29 28 65 71 3f 20 28 76 formdat)(eq? (v
8410: 65 63 74 6f 72 2d 6c 65 6e 67 74 68 20 66 6f 72 ector-length for
8420: 6d 64 61 74 29 20 31 29 28 68 61 73 68 2d 74 61 mdat) 1)(hash-ta
8430: 62 6c 65 3f 20 28 76 65 63 74 6f 72 2d 72 65 66 ble? (vector-ref
8440: 20 66 6f 72 6d 64 61 74 20 30 29 29 29 0a 09 20 formdat 0)))..
8450: 20 20 20 28 66 6f 72 6d 64 61 74 3a 6b 65 79 73 (formdat:keys
8460: 20 66 6f 72 6d 64 61 74 29 0a 09 20 20 20 20 28 formdat).. (
8470: 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 73 65 begin.. (se
8480: 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 ssion:log self "
8490: 45 52 52 4f 52 3a 20 66 6f 72 6d 64 61 74 3a 20 ERROR: formdat:
84a0: 22 20 66 6f 72 6d 64 61 74 20 22 20 69 73 20 6e " formdat " is n
84b0: 6f 74 20 6f 66 20 63 6c 61 73 73 20 3c 66 6f 72 ot of class <for
84c0: 6d 64 61 74 3e 22 29 0a 09 20 20 20 20 20 20 23 mdat>").. #
84d0: 66 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 f)))))..(define
84e0: 28 73 65 73 73 69 6f 6e 3a 72 75 6e 2d 61 63 74 (session:run-act
84f0: 69 6f 6e 73 20 73 65 6c 66 29 0a 20 20 28 6c 65 ions self). (le
8500: 74 2a 20 28 28 61 63 74 69 6f 6e 20 20 20 20 28 t* ((action (
8510: 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 72 61 session:get-para
8520: 6d 20 73 65 6c 66 20 27 61 63 74 69 6f 6e 20 27 m self 'action '
8530: 28 72 61 77 29 29 29 0a 09 20 28 70 61 67 65 20 (raw))).. (page
8540: 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d 70 (sdat-get-p
8550: 61 67 65 20 73 65 6c 66 29 29 29 0a 20 20 20 20 age self))).
8560: 3b 3b 20 28 70 72 69 6e 74 20 22 61 63 74 69 6f ;; (print "actio
8570: 6e 3d 22 20 61 63 74 69 6f 6e 20 22 20 70 61 67 n=" action " pag
8580: 65 3d 22 20 70 61 67 65 29 0a 20 20 20 20 28 69 e=" page). (i
8590: 66 20 61 63 74 69 6f 6e 0a 09 28 6c 65 74 20 28 f action..(let (
85a0: 28 61 63 74 69 6f 6e 2d 6c 73 74 20 20 28 73 74 (action-lst (st
85b0: 72 69 6e 67 2d 73 70 6c 69 74 20 61 63 74 69 6f ring-split actio
85c0: 6e 20 22 2e 22 29 29 29 0a 09 20 20 3b 3b 20 28 n "."))).. ;; (
85d0: 70 72 69 6e 74 20 22 61 63 74 69 6f 6e 2d 6c 73 print "action-ls
85e0: 74 3d 22 20 61 63 74 69 6f 6e 2d 6c 73 74 29 0a t=" action-lst).
85f0: 09 20 20 28 69 66 20 28 6e 6f 74 20 28 3d 20 28 . (if (not (= (
8600: 6c 65 6e 67 74 68 20 61 63 74 69 6f 6e 2d 6c 73 length action-ls
8610: 74 29 20 32 29 29 20 0a 09 20 20 20 20 20 20 28 t) 2)) .. (
8620: 65 72 72 3a 6c 6f 67 20 22 41 63 74 69 6f 6e 20 err:log "Action
8630: 73 68 6f 75 6c 64 20 62 65 20 6f 66 20 66 6f 72 should be of for
8640: 6d 3a 20 6d 6f 64 75 6c 65 2e 61 63 74 69 6f 6e m: module.action
8650: 22 29 0a 09 20 20 20 20 20 20 28 6c 65 74 2a 20 ").. (let*
8660: 28 28 74 61 72 67 2d 70 61 67 65 20 20 20 28 63 ((targ-page (c
8670: 61 72 20 61 63 74 69 6f 6e 2d 6c 73 74 29 29 0a ar action-lst)).
8680: 09 09 20 20 20 20 20 28 70 72 6f 63 2d 6e 61 6d .. (proc-nam
8690: 65 20 20 20 28 73 74 72 69 6e 67 2d 61 70 70 65 e (string-appe
86a0: 6e 64 20 74 61 72 67 2d 70 61 67 65 20 22 2d 61 nd targ-page "-a
86b0: 63 74 69 6f 6e 22 29 29 0a 09 09 20 20 20 20 20 ction"))...
86c0: 28 74 61 72 67 2d 61 63 74 69 6f 6e 20 28 63 61 (targ-action (ca
86d0: 64 72 20 61 63 74 69 6f 6e 2d 6c 73 74 29 29 29 dr action-lst)))
86e0: 0a 09 09 3b 3b 20 28 65 72 72 3a 6c 6f 67 20 22 ...;; (err:log "
86f0: 74 61 72 67 2d 70 61 67 65 3d 22 20 74 61 72 67 targ-page=" targ
8700: 2d 70 61 67 65 20 22 20 70 72 6f 63 2d 6e 61 6d -page " proc-nam
8710: 65 3d 22 20 70 72 6f 63 2d 6e 61 6d 65 20 22 20 e=" proc-name "
8720: 74 61 72 67 2d 61 63 74 69 6f 6e 3d 22 20 74 61 targ-action=" ta
8730: 72 67 2d 61 63 74 69 6f 6e 29 0a 0a 09 09 3b 3b rg-action)....;;
8740: 20 63 61 6c 6c 20 68 65 72 65 20 6f 6e 6c 79 20 call here only
8750: 69 66 20 6e 65 76 65 72 20 63 61 6c 6c 65 64 20 if never called
8760: 62 65 66 6f 72 65 0a 09 09 28 69 66 20 28 73 65 before...(if (se
8770: 73 73 69 6f 6e 3a 6e 65 76 65 72 2d 63 61 6c 6c ssion:never-call
8780: 65 64 2d 70 61 67 65 3f 20 73 65 6c 66 20 74 61 ed-page? self ta
8790: 72 67 2d 70 61 67 65 29 0a 09 09 20 20 20 20 28 rg-page)... (
87a0: 73 65 73 73 69 6f 6e 3a 63 61 6c 6c 2d 70 61 72 session:call-par
87b0: 74 73 20 73 65 6c 66 20 74 61 72 67 2d 70 61 67 ts self targ-pag
87c0: 65 20 27 63 6f 6e 74 72 6f 6c 29 29 0a 09 09 3b e 'control))...;
87d0: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
87e0: 20 20 20 20 20 70 72 6f 63 20 20 20 20 20 20 20 proc
87f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8800: 20 20 61 63 74 69 6f 6e 20 20 20 20 0a 0a 09 09 action ....
8810: 28 69 66 20 23 74 20 3b 3b 20 73 65 74 20 74 6f (if #t ;; set to
8820: 20 23 74 20 74 6f 20 73 65 65 20 62 65 74 74 65 #t to see bette
8830: 72 20 65 72 72 6f 72 20 6d 65 73 73 61 67 65 73 r error messages
8840: 20 64 75 72 69 6e 67 20 64 65 62 75 67 67 69 6e during debuggin
8850: 20 3a 2d 29 0a 09 09 20 20 20 20 28 28 65 76 61 :-)... ((eva
8860: 6c 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f l (string->symbo
8870: 6c 20 70 72 6f 63 2d 6e 61 6d 65 29 29 20 74 61 l proc-name)) ta
8880: 72 67 2d 61 63 74 69 6f 6e 29 20 3b 3b 20 75 6e rg-action) ;; un
8890: 73 61 66 65 20 65 78 65 63 75 74 69 6f 6e 0a 09 safe execution..
88a0: 09 20 20 20 20 28 63 6f 6e 64 69 74 69 6f 6e 2d . (condition-
88b0: 63 61 73 65 20 28 28 65 76 61 6c 20 28 73 74 72 case ((eval (str
88c0: 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 70 72 6f 63 ing->symbol proc
88d0: 2d 6e 61 6d 65 29 29 20 74 61 72 67 2d 61 63 74 -name)) targ-act
88e0: 69 6f 6e 29 0a 09 09 09 09 20 20 20 20 28 28 65 ion)..... ((e
88f0: 78 6e 20 66 69 6c 65 29 20 28 73 3a 6c 6f 67 20 xn file) (s:log
8900: 22 66 69 6c 65 20 65 72 72 6f 72 22 29 29 0a 09 "file error"))..
8910: 09 09 09 20 20 20 20 28 28 65 78 6e 20 69 2f 6f ... ((exn i/o
8920: 29 20 20 28 73 3a 6c 6f 67 20 22 69 2f 6f 20 65 ) (s:log "i/o e
8930: 72 72 6f 72 22 29 29 0a 09 09 09 09 20 20 20 20 rror")).....
8940: 28 28 65 78 6e 20 29 20 20 20 20 20 28 73 3a 6c ((exn ) (s:l
8950: 6f 67 20 22 41 63 74 69 6f 6e 20 6e 6f 74 20 69 og "Action not i
8960: 6d 70 6c 65 6d 65 6e 74 65 64 3a 20 22 20 70 72 mplemented: " pr
8970: 6f 63 2d 6e 61 6d 65 20 22 20 61 63 74 69 6f 6e oc-name " action
8980: 3a 20 22 20 74 61 72 67 2d 61 63 74 69 6f 6e 29 : " targ-action)
8990: 29 0a 09 09 09 09 20 20 20 20 28 76 61 72 20 28 )..... (var (
89a0: 29 20 20 20 20 20 28 73 3a 6c 6f 67 20 22 55 6e ) (s:log "Un
89b0: 6b 6e 6f 77 6e 20 45 72 72 6f 72 22 29 29 29 29 known Error"))))
89c0: 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ))))))..(define
89d0: 28 73 65 73 73 69 6f 6e 3a 6e 65 76 65 72 2d 63 (session:never-c
89e0: 61 6c 6c 65 64 2d 70 61 67 65 3f 20 73 65 6c 66 alled-page? self
89f0: 20 70 61 67 65 29 0a 20 20 28 73 65 73 73 69 6f page). (sessio
8a00: 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 43 68 65 63 n:log self "Chec
8a10: 6b 69 6e 67 20 66 6f 72 20 70 61 67 65 3a 20 22 king for page: "
8a20: 20 70 61 67 65 29 0a 20 20 28 6e 6f 74 20 28 6d page). (not (m
8a30: 65 6d 62 65 72 20 70 61 67 65 20 28 73 64 61 74 ember page (sdat
8a40: 2d 67 65 74 2d 73 65 65 6e 2d 70 61 67 65 73 20 -get-seen-pages
8a50: 73 65 6c 66 29 29 29 29 0a 0a 28 64 65 66 69 6e self))))..(defin
8a60: 65 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 2d 63 e (session:set-c
8a70: 61 6c 6c 65 64 21 20 73 65 6c 66 20 70 61 67 65 alled! self page
8a80: 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 ). (sdat-set-se
8a90: 65 6e 2d 70 61 67 65 73 21 20 73 65 6c 66 20 28 en-pages! self (
8aa0: 63 6f 6e 73 20 70 61 67 65 20 28 73 64 61 74 2d cons page (sdat-
8ab0: 67 65 74 2d 73 65 65 6e 2d 70 61 67 65 73 20 73 get-seen-pages s
8ac0: 65 6c 66 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d elf))))..;;=====
8ad0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8ae0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8af0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8b00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8b10: 3d 0a 3b 3b 20 41 6c 74 65 72 6e 61 74 69 76 65 =.;; Alternative
8b20: 20 64 61 74 61 20 74 79 70 65 20 64 65 6c 69 76 data type deliv
8b30: 65 72 79 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ery.;;==========
8b40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8b50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8b60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8b70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 ============..(d
8b80: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 61 efine (session:a
8b90: 6c 74 2d 6f 75 74 20 73 65 6c 66 29 0a 20 20 28 lt-out self). (
8ba0: 6c 65 74 20 28 28 64 61 74 20 28 73 64 61 74 2d let ((dat (sdat-
8bb0: 67 65 74 2d 61 6c 74 2d 70 61 67 65 2d 64 61 74 get-alt-page-dat
8bc0: 20 73 65 6c 66 29 29 29 0a 20 20 20 20 3b 3b 20 self))). ;;
8bd0: 28 73 3a 6c 6f 67 20 22 64 61 74 20 69 73 3a 20 (s:log "dat is:
8be0: 22 20 64 61 74 29 0a 20 20 20 20 3b 3b 20 28 70 " dat). ;; (p
8bf0: 72 69 6e 74 20 22 48 54 54 50 2f 31 2e 31 20 32 rint "HTTP/1.1 2
8c00: 30 30 20 4f 4b 22 29 0a 20 20 20 20 28 70 72 69 00 OK"). (pri
8c10: 6e 74 20 22 44 61 74 65 3a 20 22 20 28 74 69 6d nt "Date: " (tim
8c20: 65 2d 3e 73 74 72 69 6e 67 20 28 73 65 63 6f 6e e->string (secon
8c30: 64 73 2d 3e 75 74 63 2d 74 69 6d 65 20 28 63 75 ds->utc-time (cu
8c40: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 rrent-seconds)))
8c50: 29 0a 20 20 20 20 28 70 72 69 6e 74 20 22 43 6f ). (print "Co
8c60: 6e 74 65 6e 74 2d 54 79 70 65 3a 20 22 20 28 73 ntent-Type: " (s
8c70: 64 61 74 2d 67 65 74 2d 63 6f 6e 74 65 6e 74 2d dat-get-content-
8c80: 74 79 70 65 20 73 65 6c 66 29 29 0a 20 20 20 20 type self)).
8c90: 28 70 72 69 6e 74 20 22 41 63 63 65 70 74 2d 52 (print "Accept-R
8ca0: 61 6e 67 65 73 3a 20 62 79 74 65 73 22 29 0a 20 anges: bytes").
8cb0: 20 20 20 28 70 72 69 6e 74 20 22 43 6f 6e 74 65 (print "Conte
8cc0: 6e 74 2d 4c 65 6e 67 74 68 3a 20 22 20 28 69 66 nt-Length: " (if
8cd0: 20 28 62 6c 6f 62 3f 20 64 61 74 29 0a 09 09 09 (blob? dat)....
8ce0: 09 20 20 28 62 6c 6f 62 2d 73 69 7a 65 20 64 61 . (blob-size da
8cf0: 74 29 0a 09 09 09 09 20 20 30 29 29 0a 20 20 20 t)..... 0)).
8d00: 20 28 70 72 69 6e 74 20 22 4b 65 65 70 2d 41 6c (print "Keep-Al
8d10: 69 76 65 3a 20 74 69 6d 65 6f 75 74 3d 31 35 2c ive: timeout=15,
8d20: 20 6d 61 78 3d 31 30 30 22 29 0a 20 20 20 20 28 max=100"). (
8d30: 70 72 69 6e 74 20 22 43 6f 6e 6e 65 63 74 69 6f print "Connectio
8d40: 6e 3a 20 4b 65 65 70 2d 41 6c 69 76 65 22 29 0a n: Keep-Alive").
8d50: 20 20 20 20 28 70 72 69 6e 74 20 22 22 29 0a 20 (print "").
8d60: 20 20 20 28 77 72 69 74 65 2d 73 74 72 69 6e 67 (write-string
8d70: 20 28 62 6c 6f 62 2d 3e 73 74 72 69 6e 67 20 64 (blob->string d
8d80: 61 74 29 20 23 66 20 28 63 75 72 72 65 6e 74 2d at) #f (current-
8d90: 6f 75 74 70 75 74 2d 70 6f 72 74 29 29 29 29 0a output-port)))).