Artifact
4981000328b7551602c9898d9bc3f35ff1960345:
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 3b 3b 20 28 ibrary dbi).;; (
0180: 75 73 65 20 64 62 69 29 0a 28 75 73 65 20 28 70 use dbi).(use (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 35 29 29 make-vector 35))
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 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
0e90: 2d 67 65 74 2d 73 63 72 69 70 74 20 20 20 20 20 -get-script
0ea0: 20 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 vec)
0eb0: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 (vector-ref v
0ec0: 65 63 20 33 34 29 29 0a 0a 28 64 65 66 69 6e 65 ec 34))..(define
0ed0: 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 73 68 (session:get-sh
0ee0: 61 72 65 64 20 76 65 63 20 76 61 72 6e 61 6d 65 ared vec varname
0ef0: 29 0a 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ). (hash-table-
0f00: 72 65 66 2f 64 65 66 61 75 6c 74 20 28 76 65 63 ref/default (vec
0f10: 74 6f 72 2d 72 65 66 20 76 65 63 20 33 33 29 20 tor-ref vec 33)
0f20: 76 61 72 6e 61 6d 65 20 23 66 29 29 0a 0a 28 64 varname #f))..(d
0f30: 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d efine (sdat-set-
0f40: 64 62 74 79 70 65 21 20 20 20 20 20 20 20 20 20 dbtype!
0f50: 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 vec val)(ve
0f60: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 30 20 ctor-set! vec 0
0f70: 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 val)).(define (s
0f80: 64 61 74 2d 73 65 74 2d 64 62 69 6e 69 74 21 20 dat-set-dbinit!
0f90: 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 vec
0fa0: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
0fb0: 21 20 76 65 63 20 31 20 76 61 6c 29 29 0a 28 64 ! vec 1 val)).(d
0fc0: 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d efine (sdat-set-
0fd0: 63 6f 6e 6e 21 20 20 20 20 20 20 20 20 20 20 20 conn!
0fe0: 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 vec val)(ve
0ff0: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 32 20 ctor-set! vec 2
1000: 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 val)).(define (s
1010: 64 61 74 2d 73 65 74 2d 70 61 72 61 6d 73 21 20 dat-set-params!
1020: 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 vec
1030: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
1040: 21 20 76 65 63 20 33 20 76 61 6c 29 29 0a 28 64 ! vec 3 val)).(d
1050: 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d efine (sdat-set-
1060: 70 61 74 68 2d 70 61 72 61 6d 73 21 20 20 20 20 path-params!
1070: 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 vec val)(ve
1080: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 34 20 ctor-set! vec 4
1090: 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 val)).(define (s
10a0: 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e 2d dat-set-session-
10b0: 6b 65 79 21 20 20 20 20 20 20 20 20 20 76 65 63 key! vec
10c0: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
10d0: 21 20 76 65 63 20 35 20 76 61 6c 29 29 0a 28 64 ! vec 5 val)).(d
10e0: 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d efine (sdat-set-
10f0: 73 65 73 73 69 6f 6e 2d 69 64 21 20 20 20 20 20 session-id!
1100: 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 vec val)(ve
1110: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 36 20 ctor-set! vec 6
1120: 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 val)).(define (s
1130: 64 61 74 2d 73 65 74 2d 64 6f 6d 61 69 6e 21 20 dat-set-domain!
1140: 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 vec
1150: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
1160: 21 20 76 65 63 20 37 20 76 61 6c 29 29 0a 28 64 ! vec 7 val)).(d
1170: 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d efine (sdat-set-
1180: 74 6f 70 70 61 67 65 21 20 20 20 20 20 20 20 20 toppage!
1190: 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 vec val)(ve
11a0: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 38 20 ctor-set! vec 8
11b0: 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 val)).(define (s
11c0: 64 61 74 2d 73 65 74 2d 70 61 67 65 21 20 20 20 dat-set-page!
11d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 vec
11e0: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
11f0: 21 20 76 65 63 20 39 20 76 61 6c 29 29 0a 28 64 ! vec 9 val)).(d
1200: 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d efine (sdat-set-
1210: 63 75 72 72 2d 70 61 67 65 21 20 20 20 20 20 20 curr-page!
1220: 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 vec val)(ve
1230: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 31 30 ctor-set! vec 10
1240: 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 val)).(define (
1250: 73 64 61 74 2d 73 65 74 2d 63 6f 6e 74 65 6e 74 sdat-set-content
1260: 2d 74 79 70 65 21 20 20 20 20 20 20 20 20 76 65 -type! ve
1270: 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 c val)(vector-se
1280: 74 21 20 76 65 63 20 31 31 20 76 61 6c 29 29 0a t! vec 11 val)).
1290: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 (define (sdat-se
12a0: 74 2d 70 61 67 65 2d 74 79 70 65 21 20 20 20 20 t-page-type!
12b0: 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 vec val)(
12c0: 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 vector-set! vec
12d0: 31 32 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 12 val)).(define
12e0: 20 28 73 64 61 74 2d 73 65 74 2d 73 72 6f 6f 74 (sdat-set-sroot
12f0: 21 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 !
1300: 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d vec val)(vector-
1310: 73 65 74 21 20 76 65 63 20 31 33 20 76 61 6c 29 set! vec 13 val)
1320: 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d ).(define (sdat-
1330: 73 65 74 2d 74 77 69 6b 69 64 69 72 21 20 20 20 set-twikidir!
1340: 20 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c vec val
1350: 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 )(vector-set! ve
1360: 63 20 31 34 20 76 61 6c 29 29 0a 28 64 65 66 69 c 14 val)).(defi
1370: 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 70 61 67 ne (sdat-set-pag
1380: 65 64 61 74 21 20 20 20 20 20 20 20 20 20 20 20 edat!
1390: 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f vec val)(vecto
13a0: 72 2d 73 65 74 21 20 76 65 63 20 31 35 20 76 61 r-set! vec 15 va
13b0: 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 l)).(define (sda
13c0: 74 2d 73 65 74 2d 61 6c 74 2d 70 61 67 65 2d 64 t-set-alt-page-d
13d0: 61 74 21 20 20 20 20 20 20 20 20 76 65 63 20 76 at! vec v
13e0: 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 al)(vector-set!
13f0: 76 65 63 20 31 36 20 76 61 6c 29 29 0a 28 64 65 vec 16 val)).(de
1400: 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 70 fine (sdat-set-p
1410: 61 67 65 76 61 72 73 21 20 20 20 20 20 20 20 20 agevars!
1420: 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 vec val)(vec
1430: 74 6f 72 2d 73 65 74 21 20 76 65 63 20 31 37 20 tor-set! vec 17
1440: 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 val)).(define (s
1450: 64 61 74 2d 73 65 74 2d 70 61 67 65 76 61 72 73 dat-set-pagevars
1460: 2d 62 65 66 6f 72 65 21 20 20 20 20 20 76 65 63 -before! vec
1470: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
1480: 21 20 76 65 63 20 31 38 20 76 61 6c 29 29 0a 28 ! vec 18 val)).(
1490: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 define (sdat-set
14a0: 2d 73 65 73 73 69 6f 6e 76 61 72 73 21 20 20 20 -sessionvars!
14b0: 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 vec val)(v
14c0: 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 31 ector-set! vec 1
14d0: 39 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 9 val)).(define
14e0: 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f (sdat-set-sessio
14f0: 6e 76 61 72 73 2d 62 65 66 6f 72 65 21 20 20 76 nvars-before! v
1500: 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 ec val)(vector-s
1510: 65 74 21 20 76 65 63 20 32 30 20 76 61 6c 29 29 et! vec 20 val))
1520: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 .(define (sdat-s
1530: 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 21 20 20 et-globalvars!
1540: 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 vec val)
1550: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 (vector-set! vec
1560: 20 32 31 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 21 val)).(defin
1570: 65 20 28 73 64 61 74 2d 73 65 74 2d 67 6c 6f 62 e (sdat-set-glob
1580: 61 6c 76 61 72 73 2d 62 65 66 6f 72 65 21 20 20 alvars-before!
1590: 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 vec val)(vector
15a0: 2d 73 65 74 21 20 76 65 63 20 32 32 20 76 61 6c -set! vec 22 val
15b0: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
15c0: 2d 73 65 74 2d 6c 6f 67 70 74 21 20 20 20 20 20 -set-logpt!
15d0: 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 61 vec va
15e0: 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 l)(vector-set! v
15f0: 65 63 20 32 33 20 76 61 6c 29 29 0a 28 64 65 66 ec 23 val)).(def
1600: 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 66 6f ine (sdat-set-fo
1610: 72 6d 64 61 74 21 20 20 20 20 20 20 20 20 20 20 rmdat!
1620: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
1630: 6f 72 2d 73 65 74 21 20 76 65 63 20 32 34 20 76 or-set! vec 24 v
1640: 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 al)).(define (sd
1650: 61 74 2d 73 65 74 2d 72 65 71 75 65 73 74 2d 6d at-set-request-m
1660: 65 74 68 6f 64 21 20 20 20 20 20 20 76 65 63 20 ethod! vec
1670: 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 val)(vector-set!
1680: 20 76 65 63 20 32 35 20 76 61 6c 29 29 0a 28 64 vec 25 val)).(d
1690: 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d efine (sdat-set-
16a0: 73 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 21 20 session-cookie!
16b0: 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 vec val)(ve
16c0: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 32 36 ctor-set! vec 26
16d0: 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 val)).(define (
16e0: 73 64 61 74 2d 73 65 74 2d 63 75 72 72 2d 65 72 sdat-set-curr-er
16f0: 72 21 20 20 20 20 20 20 20 20 20 20 20 20 76 65 r! ve
1700: 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 c val)(vector-se
1710: 74 21 20 76 65 63 20 32 37 20 76 61 6c 29 29 0a t! vec 27 val)).
1720: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 (define (sdat-se
1730: 74 2d 6c 6f 67 2d 70 6f 72 74 21 20 20 20 20 20 t-log-port!
1740: 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 vec val)(
1750: 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 vector-set! vec
1760: 32 38 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 28 val)).(define
1770: 20 28 73 64 61 74 2d 73 65 74 2d 6c 6f 67 66 69 (sdat-set-logfi
1780: 6c 65 21 20 20 20 20 20 20 20 20 20 20 20 20 20 le!
1790: 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d vec val)(vector-
17a0: 73 65 74 21 20 76 65 63 20 32 39 20 76 61 6c 29 set! vec 29 val)
17b0: 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d ).(define (sdat-
17c0: 73 65 74 2d 73 65 65 6e 2d 70 61 67 65 73 21 20 set-seen-pages!
17d0: 20 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c vec val
17e0: 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 )(vector-set! ve
17f0: 63 20 33 30 20 76 61 6c 29 29 0a 28 64 65 66 69 c 30 val)).(defi
1800: 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 70 61 67 ne (sdat-set-pag
1810: 65 2d 64 69 72 2d 73 74 79 6c 65 21 20 20 20 20 e-dir-style!
1820: 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f vec val)(vecto
1830: 72 2d 73 65 74 21 20 76 65 63 20 33 31 20 76 61 r-set! vec 31 va
1840: 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 l)).(define (sda
1850: 74 2d 73 65 74 2d 64 65 62 75 67 6d 6f 64 65 21 t-set-debugmode!
1860: 20 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 vec v
1870: 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 al)(vector-set!
1880: 76 65 63 20 33 32 20 76 61 6c 29 29 0a 28 64 65 vec 32 val)).(de
1890: 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 73 fine (sdat-set-s
18a0: 68 61 72 65 64 2d 68 61 73 68 21 20 20 20 20 20 hared-hash!
18b0: 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 vec val)(vec
18c0: 74 6f 72 2d 73 65 74 21 20 76 65 63 20 33 33 20 tor-set! vec 33
18d0: 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 val)).(define (s
18e0: 64 61 74 2d 73 65 74 2d 73 63 72 69 70 74 21 20 dat-set-script!
18f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 vec
1900: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
1910: 21 20 76 65 63 20 33 34 20 76 61 6c 29 29 0a 0a ! vec 34 val))..
1920: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
1930: 3a 73 65 74 2d 73 68 61 72 65 64 21 20 76 65 63 :set-shared! vec
1940: 20 76 61 72 6e 61 6d 65 20 76 61 6c 29 0a 20 20 varname val).
1950: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
1960: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 76 65 63 (vector-ref vec
1970: 20 33 33 29 20 76 61 72 6e 61 6d 65 20 76 61 6c 33) varname val
1980: 29 29 0a 0a 3b 3b 20 54 68 65 20 67 6c 6f 62 61 ))..;; The globa
1990: 6c 20 73 65 73 73 69 6f 6e 0a 28 64 65 66 69 6e l session.(defin
19a0: 65 20 73 3a 73 65 73 73 69 6f 6e 20 28 6d 61 6b e s:session (mak
19b0: 65 2d 73 64 61 74 29 29 0a 0a 3b 3b 20 53 50 4c e-sdat))..;; SPL
19c0: 49 54 20 49 4e 54 4f 20 53 54 52 41 49 47 48 54 IT INTO STRAIGHT
19d0: 20 46 4f 52 57 41 52 44 20 49 4e 49 54 20 41 4e FORWARD INIT AN
19e0: 44 20 43 4f 4d 50 4c 45 58 20 49 4e 49 54 0a 28 D COMPLEX INIT.(
19f0: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
1a00: 69 6e 69 74 69 61 6c 69 7a 65 20 73 65 6c 66 29 initialize self)
1a10: 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 64 62 74 . (sdat-set-dbt
1a20: 79 70 65 21 20 73 65 6c 66 20 20 20 20 20 20 27 ype! self '
1a30: 70 67 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d pg). (sdat-set-
1a40: 70 61 67 65 21 20 73 65 6c 66 20 20 20 20 20 20 page! self
1a50: 20 20 22 68 6f 6d 65 22 29 20 20 20 20 20 20 20 "home")
1a60: 20 3b 3b 20 74 68 65 73 65 20 61 72 65 20 64 65 ;; these are de
1a70: 66 61 75 6c 74 73 0a 20 20 28 73 64 61 74 2d 73 faults. (sdat-s
1a80: 65 74 2d 63 75 72 72 2d 70 61 67 65 21 20 73 65 et-curr-page! se
1a90: 6c 66 20 20 20 22 68 6f 6d 65 22 29 0a 20 20 28 lf "home"). (
1aa0: 73 64 61 74 2d 73 65 74 2d 63 6f 6e 74 65 6e 74 sdat-set-content
1ab0: 2d 74 79 70 65 21 20 73 65 6c 66 20 22 43 6f 6e -type! self "Con
1ac0: 74 65 6e 74 2d 74 79 70 65 3a 20 74 65 78 74 2f tent-type: text/
1ad0: 68 74 6d 6c 3b 20 63 68 61 72 73 65 74 3d 69 73 html; charset=is
1ae0: 6f 2d 38 38 35 39 2d 31 5c 6e 5c 6e 22 29 0a 20 o-8859-1\n\n").
1af0: 20 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 2d (sdat-set-page-
1b00: 74 79 70 65 21 20 73 65 6c 66 20 20 20 27 68 74 type! self 'ht
1b10: 6d 6c 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d ml). (sdat-set-
1b20: 74 6f 70 70 61 67 65 21 20 73 65 6c 66 20 20 20 toppage! self
1b30: 20 20 22 69 6e 64 65 78 22 29 0a 20 20 28 73 64 "index"). (sd
1b40: 61 74 2d 73 65 74 2d 70 61 72 61 6d 73 21 20 73 at-set-params! s
1b50: 65 6c 66 20 20 20 20 20 20 27 28 29 29 20 20 20 elf '())
1b60: 20 20 20 20 20 20 20 20 3b 3b 0a 20 20 28 73 64 ;;. (sd
1b70: 61 74 2d 73 65 74 2d 70 61 74 68 2d 70 61 72 61 at-set-path-para
1b80: 6d 73 21 20 73 65 6c 66 20 27 28 29 29 0a 20 20 ms! self '()).
1b90: 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f (sdat-set-sessio
1ba0: 6e 2d 6b 65 79 21 20 73 65 6c 66 20 23 66 29 0a n-key! self #f).
1bb0: 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 (sdat-set-page
1bc0: 64 61 74 21 20 73 65 6c 66 20 20 20 20 20 27 28 dat! self '(
1bd0: 29 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 61 )). (sdat-set-a
1be0: 6c 74 2d 70 61 67 65 2d 64 61 74 21 20 73 65 6c lt-page-dat! sel
1bf0: 66 20 23 66 29 0a 20 20 28 73 64 61 74 2d 73 65 f #f). (sdat-se
1c00: 74 2d 73 72 6f 6f 74 21 20 73 65 6c 66 20 20 20 t-sroot! self
1c10: 20 20 20 20 22 2e 2f 22 29 0a 20 20 28 73 64 61 "./"). (sda
1c20: 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e 2d 63 6f t-set-session-co
1c30: 6f 6b 69 65 21 20 73 65 6c 66 20 23 66 29 0a 20 okie! self #f).
1c40: 20 28 73 64 61 74 2d 73 65 74 2d 63 75 72 72 2d (sdat-set-curr-
1c50: 65 72 72 21 20 73 65 6c 66 20 23 66 29 0a 20 20 err! self #f).
1c60: 28 73 64 61 74 2d 73 65 74 2d 6c 6f 67 2d 70 6f (sdat-set-log-po
1c70: 72 74 21 20 73 65 6c 66 20 28 63 75 72 72 65 6e rt! self (curren
1c80: 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a 20 t-error-port)).
1c90: 20 28 73 64 61 74 2d 73 65 74 2d 73 65 65 6e 2d (sdat-set-seen-
1ca0: 70 61 67 65 73 21 20 73 65 6c 66 20 27 28 29 29 pages! self '())
1cb0: 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 67 . (sdat-set-pag
1cc0: 65 2d 64 69 72 2d 73 74 79 6c 65 21 20 73 65 6c e-dir-style! sel
1cd0: 66 20 23 74 29 20 3b 3b 20 23 74 20 3a 20 70 61 f #t) ;; #t : pa
1ce0: 67 65 73 2f 3c 70 61 67 65 6e 61 6d 65 3e 5f 28 ges/<pagename>_(
1cf0: 76 69 65 77 7c 63 6e 74 6c 29 2e 73 63 6d 0a 20 view|cntl).scm.
1d00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1d10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1d20: 20 20 20 20 20 3b 3b 20 23 66 20 3a 20 70 61 67 ;; #f : pag
1d30: 65 73 2f 3c 70 61 67 65 6e 61 6d 65 3e 2f 28 76 es/<pagename>/(v
1d40: 69 65 77 7c 63 6f 6e 74 72 6f 6c 29 2e 73 63 6d iew|control).scm
1d50: 20 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 64 65 . (sdat-set-de
1d60: 62 75 67 6d 6f 64 65 21 20 20 20 20 20 20 20 20 bugmode!
1d70: 20 20 73 65 6c 66 20 23 66 29 0a 20 20 09 09 09 self #f). ...
1d80: 20 20 20 20 20 0a 20 20 28 73 64 61 74 2d 73 65 . (sdat-se
1d90: 74 2d 70 61 67 65 76 61 72 73 21 20 20 20 20 20 t-pagevars!
1da0: 20 20 20 20 20 20 73 65 6c 66 20 28 6d 61 6b 65 self (make
1db0: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 -hash-table)).
1dc0: 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f (sdat-set-sessio
1dd0: 6e 76 61 72 73 21 20 20 20 20 20 20 20 20 73 65 nvars! se
1de0: 6c 66 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 lf (make-hash-ta
1df0: 62 6c 65 29 29 0a 20 20 28 73 64 61 74 2d 73 65 ble)). (sdat-se
1e00: 74 2d 67 6c 6f 62 61 6c 76 61 72 73 21 20 20 20 t-globalvars!
1e10: 20 20 20 20 20 20 73 65 6c 66 20 28 6d 61 6b 65 self (make
1e20: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 -hash-table)).
1e30: 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 76 61 (sdat-set-pageva
1e40: 72 73 2d 62 65 66 6f 72 65 21 20 20 20 20 73 65 rs-before! se
1e50: 6c 66 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 lf (make-hash-ta
1e60: 62 6c 65 29 29 0a 20 20 28 73 64 61 74 2d 73 65 ble)). (sdat-se
1e70: 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 t-sessionvars-be
1e80: 66 6f 72 65 21 20 73 65 6c 66 20 28 6d 61 6b 65 fore! self (make
1e90: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 -hash-table)).
1ea0: 28 73 64 61 74 2d 73 65 74 2d 67 6c 6f 62 61 6c (sdat-set-global
1eb0: 76 61 72 73 2d 62 65 66 6f 72 65 21 20 20 73 65 vars-before! se
1ec0: 6c 66 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 lf (make-hash-ta
1ed0: 62 6c 65 29 29 0a 20 20 28 73 64 61 74 2d 73 65 ble)). (sdat-se
1ee0: 74 2d 64 6f 6d 61 69 6e 21 20 20 20 20 20 20 20 t-domain!
1ef0: 20 20 20 20 20 20 73 65 6c 66 20 22 6c 6f 63 61 self "loca
1f00: 68 6f 73 74 22 29 20 20 20 3b 3b 20 65 6e 64 20 host") ;; end
1f10: 6f 66 20 64 65 66 61 75 6c 74 73 0a 20 20 28 73 of defaults. (s
1f20: 64 61 74 2d 73 65 74 2d 73 63 72 69 70 74 21 20 dat-set-script!
1f30: 20 20 20 20 20 20 20 20 20 20 20 20 73 65 6c 66 self
1f40: 20 23 66 29 0a 20 20 28 6c 65 74 2a 20 28 28 72 #f). (let* ((r
1f50: 61 77 63 6f 6e 66 69 67 64 61 74 20 28 73 65 73 awconfigdat (ses
1f60: 73 69 6f 6e 3a 72 65 61 64 2d 63 6f 6e 66 69 67 sion:read-config
1f70: 20 73 65 6c 66 29 29 0a 09 20 28 63 6f 6e 66 69 self)).. (confi
1f80: 67 64 61 74 20 28 69 66 20 72 61 77 63 6f 6e 66 gdat (if rawconf
1f90: 69 67 64 61 74 20 28 65 76 61 6c 20 72 61 77 63 igdat (eval rawc
1fa0: 6f 6e 66 69 67 64 61 74 29 20 27 28 29 29 29 0a onfigdat) '())).
1fb0: 09 20 28 73 72 6f 6f 74 20 20 20 20 20 28 73 3a . (sroot (s:
1fc0: 66 69 6e 64 2d 70 61 72 61 6d 20 27 73 72 6f 6f find-param 'sroo
1fd0: 74 20 20 20 20 63 6f 6e 66 69 67 64 61 74 29 29 t configdat))
1fe0: 0a 09 20 28 6c 6f 67 66 69 6c 65 20 20 20 28 73 .. (logfile (s
1ff0: 3a 66 69 6e 64 2d 70 61 72 61 6d 20 27 6c 6f 67 :find-param 'log
2000: 66 69 6c 65 20 20 63 6f 6e 66 69 67 64 61 74 29 file configdat)
2010: 29 0a 09 20 28 64 62 74 79 70 65 20 20 20 20 28 ).. (dbtype (
2020: 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 27 64 62 s:find-param 'db
2030: 74 79 70 65 20 20 20 63 6f 6e 66 69 67 64 61 74 type configdat
2040: 29 29 0a 09 20 28 64 62 69 6e 69 74 20 20 20 20 )).. (dbinit
2050: 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 27 64 (s:find-param 'd
2060: 62 69 6e 69 74 20 20 20 63 6f 6e 66 69 67 64 61 binit configda
2070: 74 29 29 0a 09 20 28 64 6f 6d 61 69 6e 20 20 20 t)).. (domain
2080: 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 27 (s:find-param '
2090: 64 6f 6d 61 69 6e 20 20 20 63 6f 6e 66 69 67 64 domain configd
20a0: 61 74 29 29 0a 09 20 28 74 77 69 6b 69 64 69 72 at)).. (twikidir
20b0: 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 (s:find-param
20c0: 27 74 77 69 6b 69 64 69 72 20 63 6f 6e 66 69 67 'twikidir config
20d0: 64 61 74 29 29 0a 09 20 28 70 61 67 65 2d 64 69 dat)).. (page-di
20e0: 72 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d r (s:find-param
20f0: 20 27 70 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 'page-dir-style
2100: 20 63 6f 6e 66 69 67 64 61 74 29 29 0a 09 20 28 configdat)).. (
2110: 64 65 62 75 67 6d 6f 64 65 20 28 73 3a 66 69 6e debugmode (s:fin
2120: 64 2d 70 61 72 61 6d 20 27 64 65 62 75 67 6d 6f d-param 'debugmo
2130: 64 65 20 63 6f 6e 66 69 67 64 61 74 29 29 0a 20 de configdat)).
2140: 20 20 20 20 20 20 20 20 28 73 63 72 69 70 74 20 (script
2150: 20 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d (s:find-param
2160: 20 27 73 63 72 69 70 74 20 20 20 20 63 6f 6e 66 'script conf
2170: 69 67 64 61 74 29 29 29 0a 20 20 20 20 28 69 66 igdat))). (if
2180: 20 73 72 6f 6f 74 20 20 20 20 28 73 64 61 74 2d sroot (sdat-
2190: 73 65 74 2d 73 72 6f 6f 74 21 20 20 20 20 73 65 set-sroot! se
21a0: 6c 66 20 73 72 6f 6f 74 29 29 0a 20 20 20 20 28 lf sroot)). (
21b0: 69 66 20 6c 6f 67 66 69 6c 65 20 20 28 73 64 61 if logfile (sda
21c0: 74 2d 73 65 74 2d 6c 6f 67 66 69 6c 65 21 20 20 t-set-logfile!
21d0: 73 65 6c 66 20 6c 6f 67 66 69 6c 65 29 29 0a 20 self logfile)).
21e0: 20 20 20 28 69 66 20 64 62 74 79 70 65 20 20 20 (if dbtype
21f0: 28 73 64 61 74 2d 73 65 74 2d 64 62 74 79 70 65 (sdat-set-dbtype
2200: 21 20 20 20 73 65 6c 66 20 64 62 74 79 70 65 29 ! self dbtype)
2210: 29 0a 20 20 20 20 28 69 66 20 64 62 69 6e 69 74 ). (if dbinit
2220: 20 20 20 28 73 64 61 74 2d 73 65 74 2d 64 62 69 (sdat-set-dbi
2230: 6e 69 74 21 20 20 20 73 65 6c 66 20 64 62 69 6e nit! self dbin
2240: 69 74 29 29 0a 20 20 20 20 28 69 66 20 64 6f 6d it)). (if dom
2250: 61 69 6e 20 20 20 28 73 64 61 74 2d 73 65 74 2d ain (sdat-set-
2260: 64 6f 6d 61 69 6e 21 20 20 20 73 65 6c 66 20 64 domain! self d
2270: 6f 6d 61 69 6e 29 29 0a 20 20 20 20 28 69 66 20 omain)). (if
2280: 74 77 69 6b 69 64 69 72 20 28 73 64 61 74 2d 73 twikidir (sdat-s
2290: 65 74 2d 74 77 69 6b 69 64 69 72 21 20 73 65 6c et-twikidir! sel
22a0: 66 20 74 77 69 6b 69 64 69 72 29 29 0a 20 20 20 f twikidir)).
22b0: 20 28 69 66 20 64 65 62 75 67 6d 6f 64 65 20 28 (if debugmode (
22c0: 73 64 61 74 2d 73 65 74 2d 64 65 62 75 67 6d 6f sdat-set-debugmo
22d0: 64 65 21 20 73 65 6c 66 20 64 65 62 75 67 6d 6f de! self debugmo
22e0: 64 65 29 29 0a 20 20 20 20 28 69 66 20 73 63 72 de)). (if scr
22f0: 69 70 74 20 20 20 20 28 73 64 61 74 2d 73 65 74 ipt (sdat-set
2300: 2d 73 63 72 69 70 74 21 20 20 20 20 73 65 6c 66 -script! self
2310: 20 73 63 72 69 70 74 29 29 0a 20 20 20 20 28 73 script)). (s
2320: 64 61 74 2d 73 65 74 2d 70 61 67 65 2d 64 69 72 dat-set-page-dir
2330: 2d 73 74 79 6c 65 21 20 73 65 6c 66 20 70 61 67 -style! self pag
2340: 65 2d 64 69 72 29 0a 20 20 20 20 3b 3b 20 28 70 e-dir). ;; (p
2350: 72 69 6e 74 20 22 63 6f 6e 66 69 67 64 61 74 3a rint "configdat:
2360: 20 22 29 28 70 70 20 63 6f 6e 66 69 67 64 61 74 ")(pp configdat
2370: 29 0a 20 20 20 20 28 69 66 20 64 65 62 75 67 6d ). (if debugm
2380: 6f 64 65 0a 09 28 73 65 73 73 69 6f 6e 3a 6c 6f ode..(session:lo
2390: 67 20 73 65 6c 66 20 22 73 72 6f 6f 74 3a 20 22 g self "sroot: "
23a0: 20 73 72 6f 6f 74 20 22 20 6c 6f 67 66 69 6c 65 sroot " logfile
23b0: 3a 20 22 20 6c 6f 67 66 69 6c 65 20 22 20 64 62 : " logfile " db
23c0: 74 79 70 65 3a 20 22 20 64 62 74 79 70 65 20 0a type: " dbtype .
23d0: 09 09 20 20 20 20 20 22 20 64 62 69 6e 69 74 3a .. " dbinit:
23e0: 20 22 20 64 62 69 6e 69 74 20 22 20 64 6f 6d 61 " dbinit " doma
23f0: 69 6e 3a 20 22 20 64 6f 6d 61 69 6e 20 22 20 70 in: " domain " p
2400: 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 3a 20 22 age-dir-style: "
2410: 20 70 61 67 65 2d 64 69 72 29 29 0a 20 20 20 20 page-dir)).
2420: 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 73 68 ). (sdat-set-sh
2430: 61 72 65 64 2d 68 61 73 68 21 20 73 65 6c 66 20 ared-hash! self
2440: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
2450: 29 29 0a 20 20 29 0a 0a 3b 3b 20 55 73 65 64 20 )). )..;; Used
2460: 66 6f 72 20 74 68 65 20 73 74 72 61 6e 67 65 6c for the strangel
2470: 79 20 69 6e 63 6f 6e 73 69 73 74 65 6e 74 20 68 y inconsistent h
2480: 61 6e 64 6c 69 6e 67 20 6f 66 20 74 68 65 20 63 andling of the c
2490: 6f 6e 66 69 67 20 66 69 6c 65 2e 20 41 20 62 65 onfig file. A be
24a0: 74 74 65 72 20 77 61 79 20 69 73 20 6e 65 65 64 tter way is need
24b0: 65 64 2e 0a 3b 3b 0a 3b 3b 20 20 20 28 6c 65 74 ed..;;.;; (let
24c0: 20 28 28 64 62 74 79 70 65 20 28 73 64 61 74 2d ((dbtype (sdat-
24d0: 67 65 74 2d 64 62 74 79 70 65 20 73 65 6c 66 29 get-dbtype self)
24e0: 29 29 0a 3b 3b 20 20 20 20 20 28 70 72 69 6e 74 )).;; (print
24f0: 20 22 64 62 74 79 70 65 3a 20 22 20 64 62 74 79 "dbtype: " dbty
2500: 70 65 29 0a 3b 3b 20 20 20 20 20 28 73 64 61 74 pe).;; (sdat
2510: 2d 73 65 74 2d 64 62 74 79 70 65 21 20 73 65 6c -set-dbtype! sel
2520: 66 20 28 65 76 61 6c 20 64 62 74 79 70 65 29 29 f (eval dbtype))
2530: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 ))..(define (ses
2540: 73 69 6f 6e 3a 73 65 74 75 70 20 73 65 6c 66 29 sion:setup self)
2550: 0a 20 20 28 6c 65 74 20 28 28 64 62 74 79 70 65 . (let ((dbtype
2560: 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d 64 62 (sdat-get-db
2570: 74 79 70 65 20 73 65 6c 66 29 29 0a 09 28 64 65 type self))..(de
2580: 62 75 67 6d 6f 64 65 20 28 73 64 61 74 2d 67 65 bugmode (sdat-ge
2590: 74 2d 64 65 62 75 67 6d 6f 64 65 20 73 65 6c 66 t-debugmode self
25a0: 29 29 0a 09 28 64 62 69 6e 69 74 20 20 20 20 28 ))..(dbinit (
25b0: 65 76 61 6c 20 28 73 64 61 74 2d 67 65 74 2d 64 eval (sdat-get-d
25c0: 62 69 6e 69 74 20 73 65 6c 66 29 29 29 0a 09 28 binit self)))..(
25d0: 64 62 65 78 69 73 74 73 20 20 23 66 29 29 0a 20 dbexists #f)).
25e0: 20 20 20 28 6c 65 74 20 28 28 64 62 66 6e 61 6d (let ((dbfnam
25f0: 65 20 28 61 6c 69 73 74 2d 72 65 66 20 27 64 62 e (alist-ref 'db
2600: 6e 61 6d 65 20 64 62 69 6e 69 74 29 29 29 0a 20 name dbinit))).
2610: 20 20 20 20 20 28 69 66 20 64 65 62 75 67 6d 6f (if debugmo
2620: 64 65 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 de (session:log
2630: 73 65 6c 66 20 22 73 65 73 73 69 6f 6e 3a 73 65 self "session:se
2640: 74 75 70 20 64 62 66 6e 61 6d 65 3d 22 20 64 62 tup dbfname=" db
2650: 66 6e 61 6d 65 20 22 2c 20 64 62 74 79 70 65 3d fname ", dbtype=
2660: 22 20 64 62 74 79 70 65 20 22 2c 20 64 62 69 6e " dbtype ", dbin
2670: 69 74 3d 22 20 64 62 69 6e 69 74 29 29 0a 20 20 it=" dbinit)).
2680: 20 20 20 20 28 69 66 20 28 65 71 3f 20 64 62 74 (if (eq? dbt
2690: 79 70 65 20 27 73 71 6c 69 74 65 33 29 0a 09 20 ype 'sqlite3)..
26a0: 20 3b 3b 20 54 68 65 20 27 61 75 74 6f 20 6d 65 ;; The 'auto me
26b0: 74 68 6f 64 20 77 69 6c 6c 20 64 69 73 74 72 69 thod will distri
26c0: 62 75 74 65 20 64 62 73 20 61 63 72 6f 73 73 20 bute dbs across
26d0: 74 68 65 20 64 69 73 6b 20 75 73 69 6e 67 20 68 the disk using h
26e0: 61 73 68 0a 09 20 20 3b 3b 20 6f 66 20 75 73 65 ash.. ;; of use
26f0: 72 20 68 6f 73 74 20 61 6e 64 20 75 73 65 72 2e r host and user.
2700: 20 54 4f 44 4f 0a 09 20 20 3b 3b 20 28 69 66 20 TODO.. ;; (if
2710: 28 65 71 3f 20 64 62 66 6e 61 6d 65 20 27 61 75 (eq? dbfname 'au
2720: 74 6f 29 20 3b 3b 20 54 68 69 73 20 69 73 20 74 to) ;; This is t
2730: 68 65 20 61 75 74 6f 20 61 73 73 69 67 6e 6d 65 he auto assignme
2740: 6e 74 20 6f 66 20 61 20 64 62 20 62 61 73 65 64 nt of a db based
2750: 20 6f 6e 20 68 61 73 68 20 6f 66 20 49 50 0a 09 on hash of IP..
2760: 20 20 28 6c 65 74 20 28 28 64 62 70 61 74 68 20 (let ((dbpath
2770: 28 70 61 74 68 6e 61 6d 65 2d 64 69 72 65 63 74 (pathname-direct
2780: 6f 72 79 20 64 62 66 6e 61 6d 65 29 29 29 20 20 ory dbfname)))
2790: 3b 3b 20 64 6f 20 61 20 63 6f 75 70 6c 65 20 73 ;; do a couple s
27a0: 61 6e 69 74 79 20 63 68 65 63 6b 73 20 68 65 72 anity checks her
27b0: 65 20 74 6f 20 6d 61 6b 65 20 73 65 74 74 69 6e e to make settin
27c0: 67 20 75 70 20 65 61 73 69 65 72 0a 09 20 20 20 g up easier..
27d0: 20 28 69 66 20 64 65 62 75 67 6d 6f 64 65 20 28 (if debugmode (
27e0: 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 session:log self
27f0: 20 22 49 4e 46 4f 3a 20 73 65 74 74 69 6e 67 20 "INFO: setting
2800: 75 70 20 66 6f 72 20 73 71 6c 69 74 65 33 20 64 up for sqlite3 d
2810: 62 20 61 63 63 65 73 73 20 74 6f 20 22 20 64 62 b access to " db
2820: 66 6e 61 6d 65 29 29 0a 09 20 20 20 20 28 69 66 fname)).. (if
2830: 20 28 6e 6f 74 20 28 66 69 6c 65 2d 77 72 69 74 (not (file-writ
2840: 65 2d 61 63 63 65 73 73 3f 20 64 62 70 61 74 68 e-access? dbpath
2850: 29 29 0a 09 09 28 73 65 73 73 69 6f 6e 3a 6c 6f ))...(session:lo
2860: 67 20 73 65 6c 66 20 22 57 41 52 4e 49 4e 47 3a g self "WARNING:
2870: 20 43 61 6e 6e 6f 74 20 77 72 69 74 65 20 74 6f Cannot write to
2880: 20 22 20 64 62 70 61 74 68 29 0a 09 09 28 69 66 " dbpath)...(if
2890: 20 64 65 62 75 67 6d 6f 64 65 20 28 73 65 73 73 debugmode (sess
28a0: 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 49 4e ion:log self "IN
28b0: 46 4f 3a 20 22 20 64 62 70 61 74 68 20 22 20 69 FO: " dbpath " i
28c0: 73 20 77 72 69 74 65 61 62 6c 65 22 29 29 29 0a s writeable"))).
28d0: 09 20 20 20 20 28 69 66 20 28 66 69 6c 65 2d 65 . (if (file-e
28e0: 78 69 73 74 73 3f 20 64 62 66 6e 61 6d 65 29 0a xists? dbfname).
28f0: 09 09 28 62 65 67 69 6e 0a 09 09 20 20 3b 3b 20 ..(begin... ;;
2900: 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c (session:log sel
2910: 66 20 22 73 65 74 74 69 6e 67 20 64 62 65 78 69 f "setting dbexi
2920: 73 74 73 20 74 6f 20 23 74 22 29 0a 09 09 20 20 sts to #t")...
2930: 28 73 65 74 21 20 64 62 65 78 69 73 74 73 20 23 (set! dbexists #
2940: 74 29 29 29 29 0a 09 20 20 28 69 66 20 64 65 62 t)))).. (if deb
2950: 75 67 6d 6f 64 65 20 28 73 65 73 73 69 6f 6e 3a ugmode (session:
2960: 6c 6f 67 20 73 65 6c 66 20 22 49 4e 46 4f 3a 20 log self "INFO:
2970: 73 65 74 74 69 6e 67 20 75 70 20 66 6f 72 20 70 setting up for p
2980: 67 20 64 62 20 61 63 63 65 73 73 20 74 6f 20 61 g db access to a
2990: 63 63 6f 75 6e 74 20 69 6e 66 6f 20 22 20 64 62 ccount info " db
29a0: 69 6e 69 74 29 29 29 0a 20 20 20 20 20 20 28 69 init))). (i
29b0: 66 20 64 65 62 75 67 6d 6f 64 65 20 28 73 65 73 f debugmode (ses
29c0: 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 64 sion:log self "d
29d0: 62 74 79 70 65 3a 20 22 20 64 62 74 79 70 65 20 btype: " dbtype
29e0: 22 20 64 62 66 6e 61 6d 65 3a 20 22 20 64 62 66 " dbfname: " dbf
29f0: 6e 61 6d 65 20 22 20 64 62 65 78 69 73 74 73 3a name " dbexists:
2a00: 20 22 20 64 62 65 78 69 73 74 73 29 29 29 0a 20 " dbexists))).
2a10: 20 20 20 28 73 64 61 74 2d 73 65 74 2d 63 6f 6e (sdat-set-con
2a20: 6e 21 20 73 65 6c 66 20 28 64 62 69 3a 6f 70 65 n! self (dbi:ope
2a30: 6e 20 64 62 74 79 70 65 20 64 62 69 6e 69 74 29 n dbtype dbinit)
2a40: 29 0a 20 20 20 20 28 73 65 74 21 20 2a 64 62 2a ). (set! *db*
2a50: 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 (sdat-get-conn
2a60: 73 65 6c 66 29 29 0a 20 20 20 20 28 69 66 20 28 self)). (if (
2a70: 61 6e 64 20 28 6e 6f 74 20 64 62 65 78 69 73 74 and (not dbexist
2a80: 73 29 28 65 71 3f 20 64 62 74 79 70 65 20 27 73 s)(eq? dbtype 's
2a90: 71 6c 69 74 65 33 29 29 0a 20 09 28 62 65 67 69 qlite3)). .(begi
2aa0: 6e 0a 09 20 20 28 70 72 69 6e 74 20 22 57 41 52 n.. (print "WAR
2ab0: 4e 49 4e 47 3a 20 53 65 74 74 69 6e 67 20 75 70 NING: Setting up
2ac0: 20 73 65 73 73 69 6f 6e 20 64 62 20 77 69 74 68 session db with
2ad0: 20 73 71 6c 69 74 65 33 22 29 0a 09 20 20 28 73 sqlite3").. (s
2ae0: 65 73 73 69 6f 6e 3a 73 65 74 75 70 2d 64 62 20 ession:setup-db
2af0: 73 65 6c 66 29 29 29 0a 20 20 20 20 28 73 65 73 self))). (ses
2b00: 73 69 6f 6e 3a 70 72 6f 63 65 73 73 2d 75 72 6c sion:process-url
2b10: 2d 70 61 74 68 20 73 65 6c 66 29 0a 20 20 20 20 -path self).
2b20: 28 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 2d 73 (session:setup-s
2b30: 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 ession-key self)
2b40: 0a 20 20 20 20 3b 3b 20 63 61 70 74 75 72 65 20 . ;; capture
2b50: 73 74 64 69 6e 20 69 66 20 74 68 69 73 20 69 73 stdin if this is
2b60: 20 61 20 50 4f 53 54 0a 20 20 20 20 28 73 64 61 a POST. (sda
2b70: 74 2d 73 65 74 2d 72 65 71 75 65 73 74 2d 6d 65 t-set-request-me
2b80: 74 68 6f 64 21 20 73 65 6c 66 20 28 67 65 74 2d thod! self (get-
2b90: 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 environment-vari
2ba0: 61 62 6c 65 20 22 52 45 51 55 45 53 54 5f 4d 45 able "REQUEST_ME
2bb0: 54 48 4f 44 22 29 29 0a 20 20 20 20 28 73 64 61 THOD")). (sda
2bc0: 74 2d 73 65 74 2d 66 6f 72 6d 64 61 74 21 20 73 t-set-formdat! s
2bd0: 65 6c 66 20 28 66 6f 72 6d 64 61 74 3a 6c 6f 61 elf (formdat:loa
2be0: 64 2d 61 6c 6c 29 29 29 29 0a 0a 3b 3b 20 73 65 d-all))))..;; se
2bf0: 74 75 70 20 74 68 65 20 64 62 20 77 69 74 68 20 tup the db with
2c00: 73 65 73 73 69 6f 6e 20 74 61 62 6c 65 73 2c 20 session tables,
2c10: 77 6f 72 6b 73 20 66 6f 72 20 73 71 6c 69 74 65 works for sqlite
2c20: 20 6f 6e 6c 79 20 72 69 67 68 74 20 6e 6f 77 0a only right now.
2c30: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
2c40: 3a 73 65 74 75 70 2d 64 62 20 73 65 6c 66 29 0a :setup-db self).
2c50: 20 20 28 6c 65 74 20 28 28 63 6f 6e 6e 20 28 73 (let ((conn (s
2c60: 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c dat-get-conn sel
2c70: 66 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 f))). (for-ea
2c80: 63 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 ch . (lambda
2c90: 20 28 73 74 6d 74 29 0a 20 20 20 20 20 20 20 28 (stmt). (
2ca0: 64 62 69 3a 65 78 65 63 20 63 6f 6e 6e 20 73 74 dbi:exec conn st
2cb0: 6d 74 29 29 0a 20 20 20 20 20 28 6c 69 73 74 20 mt)). (list
2cc0: 22 43 52 45 41 54 45 20 54 41 42 4c 45 20 73 65 "CREATE TABLE se
2cd0: 73 73 69 6f 6e 5f 76 61 72 73 20 28 69 64 20 49 ssion_vars (id I
2ce0: 4e 54 45 47 45 52 20 50 52 49 4d 41 52 59 20 4b NTEGER PRIMARY K
2cf0: 45 59 2c 73 65 73 73 69 6f 6e 5f 69 64 20 49 4e EY,session_id IN
2d00: 54 45 47 45 52 2c 70 61 67 65 20 54 45 58 54 2c TEGER,page TEXT,
2d10: 6b 65 79 20 54 45 58 54 2c 76 61 6c 75 65 20 54 key TEXT,value T
2d20: 45 58 54 29 3b 22 0a 09 20 20 20 22 43 52 45 41 EXT);".. "CREA
2d30: 54 45 20 54 41 42 4c 45 20 73 65 73 73 69 6f 6e TE TABLE session
2d40: 73 20 28 69 64 20 49 4e 54 45 47 45 52 20 50 52 s (id INTEGER PR
2d50: 49 4d 41 52 59 20 4b 45 59 2c 73 65 73 73 69 6f IMARY KEY,sessio
2d60: 6e 5f 6b 65 79 20 54 45 58 54 2c 6c 61 73 74 5f n_key TEXT,last_
2d70: 75 73 65 64 20 54 49 4d 45 53 54 41 4d 50 29 3b used TIMESTAMP);
2d80: 22 0a 20 20 20 20 20 20 20 20 20 20 20 22 43 52 ". "CR
2d90: 45 41 54 45 20 54 41 42 4c 45 20 6d 65 74 61 64 EATE TABLE metad
2da0: 61 74 61 20 28 69 64 20 49 4e 54 45 47 45 52 20 ata (id INTEGER
2db0: 50 52 49 4d 41 52 59 20 4b 45 59 2c 6b 65 79 20 PRIMARY KEY,key
2dc0: 54 45 58 54 2c 76 61 6c 75 65 20 54 45 58 54 29 TEXT,value TEXT)
2dd0: 3b 22 29 29 29 29 0a 3b 3b 20 20 3b 3b 20 69 66 ;")))).;; ;; if
2de0: 20 77 65 20 68 61 76 65 20 61 20 73 65 73 73 69 we have a sessi
2df0: 6f 6e 5f 6b 65 79 20 6c 6f 6f 6b 20 75 70 20 74 on_key look up t
2e00: 68 65 20 73 65 73 73 69 6f 6e 2d 69 64 20 61 6e he session-id an
2e10: 64 20 73 74 6f 72 65 20 69 74 0a 3b 3b 20 20 28 d store it.;; (
2e20: 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e sdat-set-session
2e30: 2d 69 64 21 20 73 65 6c 66 20 28 73 65 73 73 69 -id! self (sessi
2e40: 6f 6e 3a 67 65 74 2d 69 64 20 73 65 6c 66 29 29 on:get-id self))
2e50: 29 0a 0a 3b 3b 20 6f 6e 6c 79 20 73 65 74 20 73 )..;; only set s
2e60: 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 20 77 68 ession-cookie wh
2e70: 65 6e 20 61 20 6e 65 77 20 73 65 73 73 69 6f 6e en a new session
2e80: 20 69 73 20 63 72 65 61 74 65 64 0a 28 64 65 66 is created.(def
2e90: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 ine (session:set
2ea0: 75 70 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 up-session-key s
2eb0: 65 6c 66 29 20 20 0a 20 20 28 6c 65 74 2a 20 28 elf) . (let* (
2ec0: 28 73 6b 20 20 28 73 65 73 73 69 6f 6e 3a 65 78 (sk (session:ex
2ed0: 74 72 61 63 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 tract-session-ke
2ee0: 79 20 73 65 6c 66 29 29 0a 20 20 20 20 20 20 20 y self)).
2ef0: 20 20 28 73 69 64 20 28 69 66 20 73 6b 20 28 73 (sid (if sk (s
2f00: 65 73 73 69 6f 6e 3a 67 65 74 2d 69 64 20 73 65 ession:get-id se
2f10: 6c 66 20 73 6b 29 20 23 66 29 29 29 0a 20 20 20 lf sk) #f))).
2f20: 20 28 69 66 20 28 6e 6f 74 20 73 69 64 29 20 3b (if (not sid) ;
2f30: 3b 20 6e 65 65 64 20 61 20 6e 65 77 20 6b 65 79 ; need a new key
2f40: 0a 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 . (let* (
2f50: 28 6e 65 77 2d 6b 65 79 20 28 73 65 73 73 69 6f (new-key (sessio
2f60: 6e 3a 67 65 74 2d 6e 65 77 2d 6b 65 79 20 73 65 n:get-new-key se
2f70: 6c 66 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 lf)).
2f80: 20 20 20 20 28 6e 65 77 2d 73 69 64 20 28 73 65 (new-sid (se
2f90: 73 73 69 6f 6e 3a 67 65 74 2d 69 64 20 73 65 6c ssion:get-id sel
2fa0: 66 20 6e 65 77 2d 6b 65 79 29 29 29 0a 20 20 20 f new-key))).
2fb0: 20 20 20 20 20 20 20 28 73 64 61 74 2d 73 65 74 (sdat-set
2fc0: 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 21 20 73 65 -session-key! se
2fd0: 6c 66 20 6e 65 77 2d 6b 65 79 29 0a 20 20 20 20 lf new-key).
2fe0: 20 20 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d (sdat-set-
2ff0: 73 65 73 73 69 6f 6e 2d 69 64 21 20 73 65 6c 66 session-id! self
3000: 20 6e 65 77 2d 73 69 64 29 0a 20 20 20 20 20 20 new-sid).
3010: 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 (sdat-set-se
3020: 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 21 20 73 65 ssion-cookie! se
3030: 6c 66 20 28 73 65 73 73 69 6f 6e 3a 6d 61 6b 65 lf (session:make
3040: 2d 63 6f 6f 6b 69 65 20 73 65 6c 66 29 29 29 0a -cookie self))).
3050: 20 20 20 20 20 20 20 20 28 73 64 61 74 2d 73 65 (sdat-se
3060: 74 2d 73 65 73 73 69 6f 6e 2d 69 64 21 20 73 65 t-session-id! se
3070: 6c 66 20 73 69 64 29 29 29 29 0a 0a 28 64 65 66 lf sid))))..(def
3080: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 6d 61 6b ine (session:mak
3090: 65 2d 63 6f 6f 6b 69 65 20 73 65 6c 66 29 0a 20 e-cookie self).
30a0: 20 3b 3b 20 28 6c 69 73 74 20 28 63 6f 6e 63 20 ;; (list (conc
30b0: 22 73 65 73 73 69 6f 6e 5f 6b 65 79 3d 22 20 28 "session_key=" (
30c0: 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e sdat-get-session
30d0: 2d 6b 65 79 20 73 65 6c 66 29 20 22 3b 20 50 61 -key self) "; Pa
30e0: 74 68 3d 2f 3b 20 44 6f 6d 61 69 6e 3d 2e 22 20 th=/; Domain=."
30f0: 28 73 64 61 74 2d 67 65 74 2d 64 6f 6d 61 69 6e (sdat-get-domain
3100: 20 73 65 6c 66 29 20 22 3b 20 4d 61 78 2d 41 67 self) "; Max-Ag
3110: 65 3d 22 20 28 2a 20 38 36 34 30 30 20 31 34 29 e=" (* 86400 14)
3120: 20 22 3b 20 56 65 72 73 69 6f 6e 3d 31 22 29 29 "; Version=1"))
3130: 29 20 0a 20 20 3b 3b 20 41 63 63 6f 72 64 69 6e ) . ;; Accordin
3140: 67 20 74 6f 20 0a 20 20 3b 3b 20 20 20 20 68 74 g to . ;; ht
3150: 74 70 3a 2f 2f 77 77 77 2e 63 6f 64 65 6d 61 72 tp://www.codemar
3160: 76 65 6c 73 2e 63 6f 6d 2f 32 30 31 30 2f 31 31 vels.com/2010/11
3170: 2f 61 70 61 63 68 65 2d 72 65 77 72 69 74 65 72 /apache-rewriter
3180: 75 6c 65 2d 73 65 74 2d 61 2d 63 6f 6f 6b 69 65 ule-set-a-cookie
3190: 2d 6f 6e 2d 6c 6f 63 61 6c 68 6f 73 74 2f 0a 0a -on-localhost/..
31a0: 20 20 3b 3b 20 20 48 65 72 65 20 61 72 65 20 74 ;; Here are t
31b0: 68 65 20 32 20 28 6f 66 74 65 6e 20 6c 65 66 74 he 2 (often left
31c0: 20 6f 75 74 29 20 72 65 71 75 69 72 65 6d 65 6e out) requiremen
31d0: 74 73 20 74 6f 20 73 65 74 20 61 20 63 6f 6f 6b ts to set a cook
31e0: 69 65 20 75 73 69 6e 67 0a 20 20 3b 3b 20 20 68 ie using. ;; h
31f0: 74 74 70 64 1b 2d 46 a2 73 20 72 65 77 72 69 74 ttpd.-F˘s rewrit
3200: 65 20 72 75 6c 65 20 28 6d 6f 64 5f 72 65 77 72 e rule (mod_rewr
3210: 69 74 65 29 2c 20 77 68 69 6c 65 20 77 6f 72 6b ite), while work
3220: 69 6e 67 20 6f 6e 20 6c 6f 63 61 6c 68 6f 73 74 ing on localhost
3230: 3a 1b 2d 41 0a 20 20 3b 3b 0a 20 20 3b 3b 20 20 :.-A. ;;. ;;
3240: 55 73 65 20 74 68 65 20 49 50 20 31 32 37 2e 30 Use the IP 127.0
3250: 2e 30 2e 31 20 69 6e 73 74 65 61 64 20 6f 66 20 .0.1 instead of
3260: 6c 6f 63 61 6c 68 6f 73 74 2f 6d 61 63 68 69 6e localhost/machin
3270: 65 2d 6e 61 6d 65 20 61 73 20 74 68 65 0a 20 20 e-name as the.
3280: 3b 3b 20 20 64 6f 6d 61 69 6e 3b 20 65 2e 67 2e ;; domain; e.g.
3290: 20 5b 43 4f 3d 73 6f 6d 65 43 6f 6f 6b 69 65 3a [CO=someCookie:
32a0: 73 6f 6d 65 56 61 6c 75 65 3a 31 32 37 2e 30 2e someValue:127.0.
32b0: 30 2e 31 3a 32 3a 2f 5d 2c 20 77 68 69 63 68 20 0.1:2:/], which
32c0: 73 61 79 73 0a 20 20 3b 3b 20 20 63 72 65 61 74 says. ;; creat
32d0: 65 20 61 20 63 6f 6f 6b 69 65 20 1b 2d 59 b4 73 e a cookie .-Y´s
32e0: 6f 6d 65 43 6f 6f 6b 69 65 a1 20 77 69 74 68 20 omeCookieˇ with
32f0: 76 61 6c 75 65 20 b4 73 6f 6d 65 56 61 6c 75 65 value ´someValue
3300: a1 20 66 6f 72 20 74 68 65 0a 20 20 3b 3b 20 20 ˇ for the. ;;
3310: 64 6f 6d 61 69 6e 20 b4 31 32 37 2e 30 2e 30 2e domain ´127.0.0.
3320: 31 1b 24 42 21 6d 1b 28 42 20 68 61 76 69 6e 67 1.$B!m.(B having
3330: 20 61 20 6c 69 66 65 20 74 69 6d 65 20 6f 66 20 a life time of
3340: 32 20 6d 69 6e 73 2c 20 66 6f 72 20 61 6e 79 20 2 mins, for any
3350: 70 61 74 68 20 69 6e 0a 20 20 3b 3b 20 20 74 68 path in. ;; th
3360: 65 20 64 6f 6d 61 69 6e 20 28 70 61 74 68 3d 2f e domain (path=/
3370: 29 2e 20 28 4f 62 76 69 6f 75 73 6c 79 20 79 6f ). (Obviously yo
3380: 75 20 77 69 6c 6c 20 68 61 76 65 20 74 6f 20 72 u will have to r
3390: 75 6e 20 74 68 65 0a 20 20 3b 3b 20 20 61 70 70 un the. ;; app
33a0: 6c 69 63 61 74 69 6f 6e 20 77 69 74 68 20 74 68 lication with th
33b0: 69 73 20 76 61 6c 75 65 20 69 6e 20 74 68 65 20 is value in the
33c0: 55 52 4c 29 0a 20 20 3b 3b 0a 20 20 3b 3b 20 20 URL). ;;. ;;
33d0: 54 6f 20 6d 61 6b 65 20 61 20 73 65 73 73 69 6f To make a sessio
33e0: 6e 20 63 6f 6f 6b 69 65 2c 20 6c 69 6d 69 74 20 n cookie, limit
33f0: 74 68 65 20 66 6c 61 67 20 73 74 61 74 65 6d 65 the flag stateme
3400: 6e 74 20 74 6f 20 6a 75 73 74 20 74 68 72 65 65 nt to just three
3410: 0a 20 20 3b 3b 20 20 61 74 74 72 69 62 75 74 65 . ;; attribute
3420: 73 3a 20 6e 61 6d 65 2c 20 76 61 6c 75 65 20 61 s: name, value a
3430: 6e 64 20 64 6f 6d 61 69 6e 2e 20 65 2e 67 0a 20 nd domain. e.g.
3440: 20 3b 3b 20 20 5b 43 4f 3d 73 6f 6d 65 43 6f 6f ;; [CO=someCoo
3450: 6b 69 65 3a 73 6f 6d 65 56 61 6c 75 65 3a 31 32 kie:someValue:12
3460: 37 2e 30 2e 30 2e 31 5d 20 1b 25 47 e2 80 93 1b 7.0.0.1] .%G–.
3470: 25 40 20 41 6e 79 20 66 75 72 74 68 65 72 0a 20 %@ Any further.
3480: 20 3b 3b 20 20 73 65 74 74 69 6e 67 73 2c 20 61 ;; settings, a
3490: 70 61 63 68 65 20 77 72 69 74 65 73 20 61 6e a1 pache writes anˇ
34a0: 20 65 78 70 69 72 65 73 a1 20 61 74 74 72 69 62 expiresˇ attrib
34b0: 75 74 65 20 66 6f 72 20 74 68 65 20 73 65 74 2d ute for the set-
34c0: 63 6f 6f 6b 69 65 0a 20 20 3b 3b 20 20 68 65 61 cookie. ;; hea
34d0: 64 65 72 2c 20 77 68 69 63 68 20 6d 61 6b 65 73 der, which makes
34e0: 20 74 68 65 20 63 6f 6f 6b 69 65 20 61 20 70 65 the cookie a pe
34f0: 72 73 69 73 74 65 6e 74 20 6f 6e 65 20 28 6e 6f rsistent one (no
3500: 74 20 72 65 61 6c 6c 79 0a 20 20 3b 3b 20 20 70 t really. ;; p
3510: 65 72 73 69 73 74 65 6e 74 2c 20 61 73 20 74 68 ersistent, as th
3520: 65 20 65 78 70 69 72 65 73 20 76 61 6c 75 65 20 e expires value
3530: 73 65 74 20 69 73 20 74 68 65 20 63 75 72 72 65 set is the curre
3540: 6e 74 20 73 65 72 76 65 72 20 74 69 6d 65 0a 20 nt server time.
3550: 20 3b 3b 20 20 1b 25 47 e2 80 93 1b 25 40 20 73 ;; .%G–.%@ s
3560: 6f 20 79 6f 75 20 64 6f 6e 1b 2d 46 1b 2d 46 a2 o you don.-F.-F˘
3570: 74 20 65 76 65 6e 20 67 65 74 20 74 6f 20 73 65 t even get to se
3580: 65 20 79 6f 75 72 20 63 6f 6f 6b 69 65 21 29 1b e your cookie!).
3590: 2d 41 0a 20 20 28 6c 69 73 74 20 28 73 74 72 69 -A. (list (stri
35a0: 6e 67 2d 73 75 62 73 74 69 74 75 74 65 20 0a 09 ng-substitute ..
35b0: 20 22 3b 22 20 22 3b 20 22 20 0a 09 20 28 63 61 ";" "; " .. (ca
35c0: 72 20 28 63 6f 6e 73 74 72 75 63 74 2d 63 6f 6f r (construct-coo
35d0: 6b 69 65 2d 73 74 72 69 6e 67 20 0a 09 20 20 20 kie-string ..
35e0: 20 20 20 20 3b 3b 20 77 61 72 6e 69 6e 67 21 20 ;; warning!
35f0: 6d 65 73 73 69 6e 67 20 75 70 20 74 68 69 73 20 messing up this
3600: 69 74 74 79 20 62 69 74 74 79 20 62 69 74 20 6f itty bitty bit o
3610: 66 20 63 6f 64 65 20 77 69 6c 6c 20 63 6f 73 74 f code will cost
3620: 20 6d 75 63 68 20 74 69 6d 65 21 0a 09 20 20 20 much time!..
3630: 20 20 20 20 60 28 28 22 73 65 73 73 69 6f 6e 5f `(("session_
3640: 6b 65 79 22 20 2c 28 73 64 61 74 2d 67 65 74 2d key" ,(sdat-get-
3650: 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 session-key self
3660: 29 0a 09 09 20 20 65 78 70 69 72 65 73 3a 20 2c )... expires: ,
3670: 28 2b 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f (+ (current-seco
3680: 6e 64 73 29 20 28 2a 20 31 34 20 38 36 34 30 30 nds) (* 14 86400
3690: 29 29 20 0a 09 09 20 20 3b 3b 20 6d 61 78 2d 61 )) ... ;; max-a
36a0: 67 65 3a 20 28 2a 20 31 34 20 38 36 34 30 30 29 ge: (* 14 86400)
36b0: 0a 09 09 20 20 70 61 74 68 3a 20 22 2f 22 20 3b ... path: "/" ;
36c0: 3b 20 0a 09 09 20 20 64 6f 6d 61 69 6e 3a 20 2c ; ... domain: ,
36d0: 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 22 (string-append "
36e0: 2e 22 20 28 73 64 61 74 2d 67 65 74 2d 64 6f 6d ." (sdat-get-dom
36f0: 61 69 6e 20 73 65 6c 66 29 29 0a 09 09 20 20 76 ain self))... v
3700: 65 72 73 69 6f 6e 3a 20 31 29 29 20 30 29 29 29 ersion: 1)) 0)))
3710: 29 29 0a 0a 3b 3b 20 6c 6f 6f 6b 20 75 70 20 61 ))..;; look up a
3720: 20 67 69 76 65 6e 20 73 65 73 73 69 6f 6e 20 6b given session k
3730: 65 79 20 61 6e 64 20 72 65 74 75 72 6e 20 74 68 ey and return th
3740: 65 20 69 64 20 69 66 20 66 6f 75 6e 64 2c 20 23 e id if found, #
3750: 66 20 69 66 20 6e 6f 74 20 66 6f 75 6e 64 0a 28 f if not found.(
3760: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
3770: 67 65 74 2d 69 64 20 73 65 6c 66 20 73 65 73 73 get-id self sess
3780: 69 6f 6e 2d 6b 65 79 29 0a 20 20 3b 3b 20 28 6c ion-key). ;; (l
3790: 65 74 20 28 28 73 65 73 73 69 6f 6e 2d 6b 65 79 et ((session-key
37a0: 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 (sdat-get-sessi
37b0: 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 29 29 0a 20 on-key self))).
37c0: 20 28 69 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 (if session-key
37d0: 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 71 75 . (let ((qu
37e0: 65 72 79 20 28 73 74 72 69 6e 67 2d 61 70 70 65 ery (string-appe
37f0: 6e 64 20 22 53 45 4c 45 43 54 20 69 64 20 46 52 nd "SELECT id FR
3800: 4f 4d 20 73 65 73 73 69 6f 6e 73 20 57 48 45 52 OM sessions WHER
3810: 45 20 73 65 73 73 69 6f 6e 5f 6b 65 79 3d 27 22 E session_key='"
3820: 20 73 65 73 73 69 6f 6e 2d 6b 65 79 20 22 27 22 session-key "'"
3830: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 )). (
3840: 63 6f 6e 6e 20 28 73 64 61 74 2d 67 65 74 2d 63 conn (sdat-get-c
3850: 6f 6e 6e 20 73 65 6c 66 29 29 0a 20 20 20 20 20 onn self)).
3860: 20 20 20 20 20 20 20 28 72 65 73 75 6c 74 20 23 (result #
3870: 66 29 29 0a 09 28 64 62 69 3a 66 6f 72 2d 65 61 f))..(dbi:for-ea
3880: 63 68 2d 72 6f 77 20 0a 09 20 28 6c 61 6d 62 64 ch-row .. (lambd
3890: 61 20 28 74 75 70 6c 65 29 0a 09 20 20 20 28 73 a (tuple).. (s
38a0: 65 74 21 20 72 65 73 75 6c 74 20 28 76 65 63 74 et! result (vect
38b0: 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 30 29 29 or-ref tuple 0))
38c0: 29 0a 09 20 63 6f 6e 6e 20 71 75 65 72 79 29 0a ).. conn query).
38d0: 09 28 69 66 20 72 65 73 75 6c 74 20 28 64 62 69 .(if result (dbi
38e0: 3a 65 78 65 63 20 63 6f 6e 6e 20 28 63 6f 6e 63 :exec conn (conc
38f0: 20 22 55 50 44 41 54 45 20 73 65 73 73 69 6f 6e "UPDATE session
3900: 73 20 53 45 54 20 6c 61 73 74 5f 75 73 65 64 3d s SET last_used=
3910: 22 20 28 64 62 69 3a 6e 6f 77 20 63 6f 6e 6e 29 " (dbi:now conn)
3920: 20 22 20 57 48 45 52 45 20 73 65 73 73 69 6f 6e " WHERE session
3930: 5f 6b 65 79 3d 3f 3b 22 29 20 73 65 73 73 69 6f _key=?;") sessio
3940: 6e 2d 6b 65 79 29 29 0a 20 20 20 20 20 20 20 20 n-key)).
3950: 72 65 73 75 6c 74 29 0a 20 20 20 20 20 20 23 66 result). #f
3960: 29 29 0a 0a 3b 3b 20 0a 28 64 65 66 69 6e 65 20 ))..;; .(define
3970: 28 73 65 73 73 69 6f 6e 3a 70 72 6f 63 65 73 73 (session:process
3980: 2d 75 72 6c 2d 70 61 74 68 20 73 65 6c 66 29 0a -url-path self).
3990: 20 20 28 6c 65 74 20 28 28 70 61 74 68 2d 69 6e (let ((path-in
39a0: 66 6f 20 20 20 20 28 67 65 74 2d 65 6e 76 69 72 fo (get-envir
39b0: 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 onment-variable
39c0: 22 50 41 54 48 5f 49 4e 46 4f 22 29 29 0a 09 28 "PATH_INFO"))..(
39d0: 71 75 65 72 79 2d 73 74 72 69 6e 67 20 28 67 65 query-string (ge
39e0: 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 t-environment-va
39f0: 72 69 61 62 6c 65 20 22 51 55 45 52 59 5f 53 54 riable "QUERY_ST
3a00: 52 49 4e 47 22 29 29 29 0a 20 20 20 20 3b 3b 20 RING"))). ;;
3a10: 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c (session:log sel
3a20: 66 20 22 70 61 74 68 2d 69 6e 66 6f 3d 22 20 70 f "path-info=" p
3a30: 61 74 68 2d 69 6e 66 6f 20 22 20 71 75 65 72 79 ath-info " query
3a40: 2d 73 74 72 69 6e 67 3d 22 20 71 75 65 72 79 2d -string=" query-
3a50: 73 74 72 69 6e 67 29 0a 20 20 20 20 28 69 66 20 string). (if
3a60: 70 61 74 68 2d 69 6e 66 6f 0a 09 28 6c 65 74 2a path-info..(let*
3a70: 20 28 28 70 61 72 74 73 20 20 20 20 28 73 74 72 ((parts (str
3a80: 69 6e 67 2d 73 70 6c 69 74 20 70 61 74 68 2d 69 ing-split path-i
3a90: 6e 66 6f 20 22 2f 22 29 29 0a 09 20 20 20 20 20 nfo "/"))..
3aa0: 20 20 28 6e 75 6d 70 61 72 74 73 20 28 6c 65 6e (numparts (len
3ab0: 67 74 68 20 70 61 72 74 73 29 29 29 0a 09 20 20 gth parts)))..
3ac0: 28 69 66 20 28 3e 20 6e 75 6d 70 61 72 74 73 20 (if (> numparts
3ad0: 30 29 0a 09 20 20 20 20 20 20 28 73 64 61 74 2d 0).. (sdat-
3ae0: 73 65 74 2d 70 61 67 65 21 20 73 65 6c 66 20 28 set-page! self (
3af0: 63 61 72 20 70 61 72 74 73 29 29 29 0a 09 20 20 car parts)))..
3b00: 3b 3b 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 ;; (session:log
3b10: 73 65 6c 66 20 22 75 72 6c 2d 70 61 74 68 3d 22 self "url-path="
3b20: 20 75 72 6c 2d 70 61 74 68 20 22 20 70 61 72 74 url-path " part
3b30: 73 3d 22 20 70 61 72 74 73 29 0a 09 20 20 28 69 s=" parts).. (i
3b40: 66 20 28 3e 20 6e 75 6d 70 61 72 74 73 20 31 29 f (> numparts 1)
3b50: 0a 09 20 20 20 20 20 20 28 73 64 61 74 2d 73 65 .. (sdat-se
3b60: 74 2d 70 61 74 68 2d 70 61 72 61 6d 73 21 20 73 t-path-params! s
3b70: 65 6c 66 20 28 63 64 72 20 70 61 72 74 73 29 29 elf (cdr parts))
3b80: 29 0a 20 20 20 20 20 20 20 20 20 20 28 69 66 20 ). (if
3b90: 71 75 65 72 79 2d 73 74 72 69 6e 67 0a 20 20 20 query-string.
3ba0: 20 20 20 20 20 20 20 20 20 20 20 28 73 64 61 74 (sdat
3bb0: 2d 73 65 74 2d 70 61 72 61 6d 73 21 20 73 65 6c -set-params! sel
3bc0: 66 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 f (string-split
3bd0: 71 75 65 72 79 2d 73 74 72 69 6e 67 20 22 26 22 query-string "&"
3be0: 29 29 29 29 29 29 29 0a 0a 3b 3b 20 42 55 47 47 )))))))..;; BUGG
3bf0: 59 21 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 Y!.(define (sess
3c00: 69 6f 6e 3a 67 65 74 2d 6e 65 77 2d 6b 65 79 20 ion:get-new-key
3c10: 73 65 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 63 self). (let ((c
3c20: 6f 6e 6e 20 20 20 28 73 64 61 74 2d 67 65 74 2d onn (sdat-get-
3c30: 63 6f 6e 6e 20 73 65 6c 66 29 29 0a 20 20 20 20 conn self)).
3c40: 20 20 20 20 28 74 6d 70 6b 65 79 20 28 73 65 73 (tmpkey (ses
3c50: 73 69 6f 6e 3a 6d 61 6b 65 2d 72 61 6e 64 2d 73 sion:make-rand-s
3c60: 74 72 69 6e 67 20 32 30 29 29 0a 20 20 20 20 20 tring 20)).
3c70: 20 20 20 28 73 74 61 74 75 73 20 23 66 29 29 0a (status #f)).
3c80: 20 20 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 (dbi:for-eac
3c90: 68 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 h-row (lambda (t
3ca0: 75 70 6c 65 29 0a 09 09 09 28 73 65 74 21 20 73 uple)....(set! s
3cb0: 74 61 74 75 73 20 23 74 29 29 0a 09 09 20 20 20 tatus #t))...
3cc0: 20 20 20 63 6f 6e 6e 20 28 73 74 72 69 6e 67 2d conn (string-
3cd0: 61 70 70 65 6e 64 20 22 49 4e 53 45 52 54 20 49 append "INSERT I
3ce0: 4e 54 4f 20 73 65 73 73 69 6f 6e 73 20 28 73 65 NTO sessions (se
3cf0: 73 73 69 6f 6e 5f 6b 65 79 29 20 56 41 4c 55 45 ssion_key) VALUE
3d00: 53 20 28 27 22 20 74 6d 70 6b 65 79 20 22 27 29 S ('" tmpkey "')
3d10: 22 29 29 0a 20 20 20 20 74 6d 70 6b 65 79 29 29 ")). tmpkey))
3d20: 0a 0a 3b 3b 20 72 65 74 75 72 6e 73 20 73 65 73 ..;; returns ses
3d30: 73 69 6f 6e 20 6b 65 79 20 49 46 46 20 69 74 20 sion key IFF it
3d40: 69 73 20 69 6e 20 74 68 65 20 48 54 54 50 5f 43 is in the HTTP_C
3d50: 4f 4f 4b 49 45 20 0a 28 64 65 66 69 6e 65 20 28 OOKIE .(define (
3d60: 73 65 73 73 69 6f 6e 3a 65 78 74 72 61 63 74 2d session:extract-
3d70: 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 session-key self
3d80: 29 0a 20 20 28 6c 65 74 20 28 28 68 74 74 70 2d ). (let ((http-
3d90: 63 6f 6f 6b 69 65 20 28 67 65 74 2d 65 6e 76 69 cookie (get-envi
3da0: 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 ronment-variable
3db0: 20 22 48 54 54 50 5f 43 4f 4f 4b 49 45 22 29 29 "HTTP_COOKIE"))
3dc0: 29 0a 20 20 20 20 3b 3b 20 28 65 72 72 3a 6c 6f ). ;; (err:lo
3dd0: 67 20 22 68 74 74 70 2d 63 6f 6f 6b 69 65 3a 20 g "http-cookie:
3de0: 22 20 68 74 74 70 2d 63 6f 6f 6b 69 65 29 0a 20 " http-cookie).
3df0: 20 20 20 28 69 66 20 68 74 74 70 2d 63 6f 6f 6b (if http-cook
3e00: 69 65 0a 20 20 20 20 20 20 20 20 28 73 65 73 73 ie. (sess
3e10: 69 6f 6e 3a 65 78 74 72 61 63 74 2d 6b 65 79 2d ion:extract-key-
3e20: 66 72 6f 6d 2d 70 61 72 61 6d 20 73 65 6c 66 20 from-param self
3e30: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 2d 66 69 (string-split-fi
3e40: 65 6c 64 73 20 20 22 3b 5c 5c 73 2b 22 20 68 74 elds ";\\s+" ht
3e50: 74 70 2d 63 6f 6f 6b 69 65 20 69 6e 66 69 78 3a tp-cookie infix:
3e60: 29 20 22 73 65 73 73 69 6f 6e 5f 6b 65 79 22 29 ) "session_key")
3e70: 0a 20 20 20 20 20 20 20 20 23 66 29 29 29 0a 0a . #f)))..
3e80: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
3e90: 3a 67 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 :get-session-id
3ea0: 73 65 6c 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 self session-key
3eb0: 29 0a 20 20 28 6c 65 74 20 28 28 71 75 65 72 79 ). (let ((query
3ec0: 20 22 53 45 4c 45 43 54 20 69 64 20 46 52 4f 4d "SELECT id FROM
3ed0: 20 73 65 73 73 69 6f 6e 73 20 57 48 45 52 45 20 sessions WHERE
3ee0: 73 65 73 73 69 6f 6e 5f 6b 65 79 3d 3f 3b 22 29 session_key=?;")
3ef0: 0a 20 20 20 20 20 20 20 20 28 72 65 73 75 6c 74 . (result
3f00: 20 23 66 29 29 0a 20 20 20 20 3b 3b 20 20 20 20 #f)). ;;
3f10: 20 28 70 67 3a 71 75 65 72 79 2d 66 6f 72 2d 65 (pg:query-for-e
3f20: 61 63 68 20 28 6c 61 6d 62 64 61 20 28 74 75 70 ach (lambda (tup
3f30: 6c 65 29 0a 20 20 20 20 3b 3b 20 20 20 20 20 20 le). ;;
3f40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3f50: 20 20 20 20 28 73 65 74 21 20 72 65 73 75 6c 74 (set! result
3f60: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 (vector-ref tup
3f70: 6c 65 20 30 29 29 29 20 3b 3b 20 28 76 65 63 74 le 0))) ;; (vect
3f80: 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 30 29 29 or-ref tuple 0))
3f90: 29 0a 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 ). ;;
3fa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3fb0: 28 73 3a 73 71 6c 70 61 72 61 6d 20 71 75 65 72 (s:sqlparam quer
3fc0: 79 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 0a 20 y session-key).
3fd0: 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 ;;
3fe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 64 (sd
3ff0: 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 at-get-conn self
4000: 29 29 0a 20 20 20 20 3b 3b 20 20 20 20 20 20 20 )). ;;
4010: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4020: 20 63 6f 6e 6e 29 0a 20 20 20 20 28 64 62 69 3a conn). (dbi:
4030: 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 for-each-row (la
4040: 6d 62 64 61 20 28 74 75 70 6c 65 29 0a 09 09 09 mbda (tuple)....
4050: 28 73 65 74 21 20 72 65 73 75 6c 74 20 28 76 65 (set! result (ve
4060: 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 30 ctor-ref tuple 0
4070: 29 29 29 20 3b 3b 20 28 76 65 63 74 6f 72 2d 72 ))) ;; (vector-r
4080: 65 66 20 74 75 70 6c 65 20 30 29 29 29 0a 09 09 ef tuple 0)))...
4090: 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d (sdat-get-
40a0: 63 6f 6e 6e 20 73 65 6c 66 29 0a 09 09 20 20 20 conn self)...
40b0: 20 20 20 28 73 3a 73 71 6c 70 61 72 61 6d 20 71 (s:sqlparam q
40c0: 75 65 72 79 20 73 65 73 73 69 6f 6e 2d 6b 65 79 uery session-key
40d0: 29 29 0a 20 20 20 20 72 65 73 75 6c 74 29 29 0a )). result)).
40e0: 0a 3b 3b 20 64 65 6c 65 74 65 20 61 6c 6c 20 72 .;; delete all r
40f0: 65 63 6f 72 64 73 20 66 6f 72 20 61 20 73 65 73 ecords for a ses
4100: 73 69 6f 6e 0a 3b 3b 20 0a 3b 3b 20 4e 45 45 44 sion.;; .;; NEED
4110: 53 20 54 4f 20 42 45 20 54 52 41 4e 53 41 43 54 S TO BE TRANSACT
4120: 49 4f 4e 49 5a 45 44 21 0a 3b 3b 0a 28 64 65 66 IONIZED!.;;.(def
4130: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 64 65 6c ine (session:del
4140: 65 74 65 2d 73 65 73 73 69 6f 6e 20 73 65 6c 66 ete-session self
4150: 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 0a 20 20 session-key).
4160: 28 6c 65 74 20 28 28 73 65 73 73 69 6f 6e 2d 69 (let ((session-i
4170: 64 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 73 d (session:get-s
4180: 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 20 73 ession-id self s
4190: 65 73 73 69 6f 6e 2d 6b 65 79 29 29 0a 20 20 20 ession-key)).
41a0: 20 20 20 20 20 28 71 72 79 31 20 20 20 20 20 20 (qry1
41b0: 20 20 3b 3b 20 28 63 6f 6e 63 20 22 42 45 47 49 ;; (conc "BEGI
41c0: 4e 3b 22 0a 09 09 09 20 20 22 44 45 4c 45 54 45 N;".... "DELETE
41d0: 20 46 52 4f 4d 20 73 65 73 73 69 6f 6e 5f 76 61 FROM session_va
41e0: 72 73 20 57 48 45 52 45 20 73 65 73 73 69 6f 6e rs WHERE session
41f0: 5f 69 64 3d 3f 3b 22 29 0a 09 28 71 72 79 32 20 _id=?;")..(qry2
4200: 20 20 20 20 20 20 20 20 20 20 20 20 22 44 45 4c "DEL
4210: 45 54 45 20 46 52 4f 4d 20 73 65 73 73 69 6f 6e ETE FROM session
4220: 73 20 57 48 45 52 45 20 69 64 3d 3f 3b 22 29 0a s WHERE id=?;").
4230: 09 09 20 20 20 20 20 3b 3b 20 20 22 43 4f 4d 4d .. ;; "COMM
4240: 49 54 3b 22 29 29 0a 20 20 20 20 20 20 20 20 28 IT;")). (
4250: 63 6f 6e 6e 20 20 20 20 20 20 20 20 20 20 20 20 conn
4260: 20 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e (sdat-get-conn
4270: 20 73 65 6c 66 29 29 29 0a 20 20 20 20 28 69 66 self))). (if
4280: 20 73 65 73 73 69 6f 6e 2d 69 64 0a 20 20 20 20 session-id.
4290: 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 (begin.
42a0: 20 20 20 20 20 28 64 62 69 3a 65 78 65 63 20 63 (dbi:exec c
42b0: 6f 6e 6e 20 71 72 79 31 20 73 65 73 73 69 6f 6e onn qry1 session
42c0: 2d 69 64 29 20 3b 3b 20 73 65 73 73 69 6f 6e 2d -id) ;; session-
42d0: 69 64 29 0a 09 20 20 28 64 62 69 3a 65 78 65 63 id).. (dbi:exec
42e0: 20 63 6f 6e 6e 20 71 72 79 32 20 73 65 73 73 69 conn qry2 sessi
42f0: 6f 6e 2d 69 64 29 0a 09 20 20 28 73 65 73 73 69 on-id).. (sessi
4300: 6f 6e 3a 69 6e 69 74 69 61 6c 69 7a 65 20 73 65 on:initialize se
4310: 6c 66 29 0a 09 20 20 28 73 65 73 73 69 6f 6e 3a lf).. (session:
4320: 73 65 74 75 70 20 73 65 6c 66 29 29 29 0a 20 20 setup self))).
4330: 20 20 28 6e 6f 74 20 28 73 65 73 73 69 6f 6e 3a (not (session:
4340: 67 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 get-session-id s
4350: 65 6c 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 elf session-key)
4360: 29 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 )))..;; (define
4370: 28 73 65 73 73 69 6f 6e 3a 64 65 6c 65 74 65 2d (session:delete-
4380: 73 65 73 73 69 6f 6e 20 73 65 6c 66 20 73 65 73 session self ses
4390: 73 69 6f 6e 2d 6b 65 79 29 0a 3b 3b 20 20 20 28 sion-key).;; (
43a0: 6c 65 74 20 28 28 73 65 73 73 69 6f 6e 2d 69 64 let ((session-id
43b0: 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 73 65 (session:get-se
43c0: 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 20 73 65 ssion-id self se
43d0: 73 73 69 6f 6e 2d 6b 65 79 29 29 0a 3b 3b 20 20 ssion-key)).;;
43e0: 20 20 20 20 20 20 20 28 71 75 65 72 69 65 73 20 (queries
43f0: 20 20 20 28 6c 69 73 74 20 22 42 45 47 49 4e 3b (list "BEGIN;
4400: 22 0a 3b 3b 20 09 09 09 20 20 22 44 45 4c 45 54 ".;; ... "DELET
4410: 45 20 46 52 4f 4d 20 73 65 73 73 69 6f 6e 5f 76 E FROM session_v
4420: 61 72 73 20 57 48 45 52 45 20 73 65 73 73 69 6f ars WHERE sessio
4430: 6e 5f 69 64 3d 3f 3b 22 0a 3b 3b 20 20 20 20 20 n_id=?;".;;
4440: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4450: 20 20 20 20 20 20 22 44 45 4c 45 54 45 20 46 52 "DELETE FR
4460: 4f 4d 20 73 65 73 73 69 6f 6e 73 20 57 48 45 52 OM sessions WHER
4470: 45 20 69 64 3d 3f 3b 22 0a 3b 3b 20 09 09 09 20 E id=?;".;; ...
4480: 20 22 43 4f 4d 4d 49 54 3b 22 29 29 0a 3b 3b 20 "COMMIT;")).;;
4490: 20 20 20 20 20 20 20 20 28 63 6f 6e 6e 20 20 20 (conn
44a0: 20 20 20 20 20 20 20 20 20 20 20 28 73 64 61 74 (sdat
44b0: 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 -get-conn self))
44c0: 29 0a 3b 3b 20 20 20 20 20 28 69 66 20 73 65 73 ).;; (if ses
44d0: 73 69 6f 6e 2d 69 64 0a 3b 3b 20 20 20 20 20 20 sion-id.;;
44e0: 20 20 20 28 62 65 67 69 6e 0a 3b 3b 20 20 20 20 (begin.;;
44f0: 20 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 (for-each
4500: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 28 .;; (
4510: 6c 61 6d 62 64 61 20 28 71 75 65 72 79 29 0a 3b lambda (query).;
4520: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ; (
4530: 64 62 69 3a 65 78 65 63 20 63 6f 6e 6e 20 71 75 dbi:exec conn qu
4540: 65 72 79 20 73 65 73 73 69 6f 6e 2d 69 64 29 29 ery session-id))
4550: 0a 3b 3b 20 09 20 20 20 71 75 65 72 69 65 73 29 .;; . queries)
4560: 0a 3b 3b 20 09 20 20 28 69 6e 69 74 69 61 6c 69 .;; . (initiali
4570: 7a 65 20 73 65 6c 66 20 27 28 29 29 0a 3b 3b 20 ze self '()).;;
4580: 09 20 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 75 . (session:setu
4590: 70 20 73 65 6c 66 29 29 29 0a 3b 3b 20 20 20 20 p self))).;;
45a0: 20 28 6e 6f 74 20 28 73 65 73 73 69 6f 6e 3a 67 (not (session:g
45b0: 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 et-session-id se
45c0: 6c 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 lf session-key))
45d0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 ))..(define (ses
45e0: 73 69 6f 6e 3a 65 78 74 72 61 63 74 2d 6b 65 79 sion:extract-key
45f0: 20 73 65 6c 66 20 6b 65 79 29 0a 20 20 28 6c 65 self key). (le
4600: 74 20 28 28 70 61 72 61 6d 73 20 28 73 64 61 74 t ((params (sdat
4610: 2d 67 65 74 2d 70 61 72 61 6d 73 20 73 65 6c 66 -get-params self
4620: 29 29 29 0a 20 20 20 20 28 73 65 73 73 69 6f 6e ))). (session
4630: 3a 65 78 74 72 61 63 74 2d 6b 65 79 2d 66 72 6f :extract-key-fro
4640: 6d 2d 70 61 72 61 6d 20 73 65 6c 66 20 70 61 72 m-param self par
4650: 61 6d 73 20 6b 65 79 29 29 29 0a 0a 28 64 65 66 ams key)))..(def
4660: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 65 78 74 ine (session:ext
4670: 72 61 63 74 2d 6b 65 79 2d 66 72 6f 6d 2d 70 61 ract-key-from-pa
4680: 72 61 6d 20 73 65 6c 66 20 70 61 72 61 6d 73 20 ram self params
4690: 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 28 72 31 key). (let ((r1
46a0: 20 20 20 20 20 28 72 65 67 65 78 70 20 28 73 74 (regexp (st
46b0: 72 69 6e 67 2d 61 70 70 65 6e 64 20 22 5e 22 20 ring-append "^"
46c0: 6b 65 79 20 22 3d 28 5b 5e 3d 5d 2b 29 24 22 29 key "=([^=]+)$")
46d0: 29 29 29 0a 20 20 20 20 28 65 72 72 3a 6c 6f 67 ))). (err:log
46e0: 20 22 49 4e 46 4f 3a 20 4c 6f 6f 6b 69 6e 67 20 "INFO: Looking
46f0: 66 6f 72 20 22 20 6b 65 79 20 22 20 69 6e 20 22 for " key " in "
4700: 20 70 61 72 61 6d 73 29 0a 20 20 20 20 28 69 66 params). (if
4710: 20 28 3c 20 28 6c 65 6e 67 74 68 20 70 61 72 61 (< (length para
4720: 6d 73 29 20 31 29 20 23 66 0a 09 28 6c 65 74 20 ms) 1) #f..(let
4730: 6c 6f 6f 70 20 28 28 68 65 61 64 20 20 20 28 63 loop ((head (c
4740: 61 72 20 70 61 72 61 6d 73 29 29 0a 09 09 20 20 ar params))...
4750: 20 28 74 61 69 6c 20 20 20 28 63 64 72 20 70 61 (tail (cdr pa
4760: 72 61 6d 73 29 29 29 0a 09 20 20 28 6c 65 74 20 rams))).. (let
4770: 28 28 6d 61 74 63 68 20 28 73 74 72 69 6e 67 2d ((match (string-
4780: 6d 61 74 63 68 20 72 31 20 68 65 61 64 29 29 29 match r1 head)))
4790: 0a 09 20 20 20 20 28 63 6f 6e 64 0a 09 20 20 20 .. (cond..
47a0: 20 20 28 6d 61 74 63 68 0a 09 20 20 20 20 20 20 (match..
47b0: 28 6c 65 74 20 28 28 73 65 73 73 69 6f 6e 2d 6b (let ((session-k
47c0: 65 79 20 28 6c 69 73 74 2d 72 65 66 20 6d 61 74 ey (list-ref mat
47d0: 63 68 20 31 29 29 29 0a 09 09 28 65 72 72 3a 6c ch 1)))...(err:l
47e0: 6f 67 20 22 49 4e 46 4f 3a 20 46 6f 75 6e 64 20 og "INFO: Found
47f0: 73 65 73 73 69 6f 6e 20 6b 65 79 3d 22 20 73 65 session key=" se
4800: 73 73 69 6f 6e 2d 6b 65 79 29 0a 09 09 28 73 64 ssion-key)...(sd
4810: 61 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e 2d 6b at-set-session-k
4820: 65 79 21 20 73 65 6c 66 20 28 6c 69 73 74 2d 72 ey! self (list-r
4830: 65 66 20 6d 61 74 63 68 20 31 29 29 0a 09 09 73 ef match 1))...s
4840: 65 73 73 69 6f 6e 2d 6b 65 79 29 29 0a 09 20 20 ession-key))..
4850: 20 20 20 28 28 6e 75 6c 6c 3f 20 74 61 69 6c 29 ((null? tail)
4860: 0a 09 20 20 20 20 20 20 23 66 29 0a 09 20 20 20 .. #f)..
4870: 20 20 28 65 6c 73 65 0a 09 20 20 20 20 20 20 28 (else.. (
4880: 6c 6f 6f 70 20 28 63 61 72 20 74 61 69 6c 29 0a loop (car tail).
4890: 09 09 20 20 20 20 28 63 64 72 20 74 61 69 6c 29 .. (cdr tail)
48a0: 29 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e ))))))))..(defin
48b0: 65 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 2d 70 e (session:set-p
48c0: 61 67 65 21 20 73 65 6c 66 20 70 61 67 65 5f 6e age! self page_n
48d0: 61 6d 65 29 0a 20 20 28 73 64 61 74 2d 73 65 74 ame). (sdat-set
48e0: 2d 70 61 67 65 21 20 73 65 6c 66 20 70 61 67 65 -page! self page
48f0: 5f 6e 61 6d 65 29 29 0a 0a 28 64 65 66 69 6e 65 _name))..(define
4900: 20 28 73 65 73 73 69 6f 6e 3a 63 6c 6f 73 65 20 (session:close
4910: 73 65 6c 66 29 0a 20 20 28 64 62 69 3a 63 6c 6f self). (dbi:clo
4920: 73 65 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e se (sdat-get-con
4930: 6e 20 73 65 6c 66 29 29 29 0a 3b 3b 20 28 63 6c n self))).;; (cl
4940: 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 ose-output-port
4950: 28 73 64 61 74 2d 67 65 74 2d 6c 6f 67 70 74 20 (sdat-get-logpt
4960: 73 65 6c 66 29 29 0a 0a 28 64 65 66 69 6e 65 20 self))..(define
4970: 28 73 65 73 73 69 6f 6e 3a 65 72 72 2d 6d 73 67 (session:err-msg
4980: 20 73 65 6c 66 20 6d 73 67 29 0a 20 20 28 68 61 self msg). (ha
4990: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 28 73 sh-table-set! (s
49a0: 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 dat-get-sessionv
49b0: 61 72 73 20 73 65 6c 66 29 20 22 45 52 52 4f 52 ars self) "ERROR
49c0: 5f 4d 53 47 22 0a 09 09 20 20 20 28 73 74 72 69 _MSG"... (stri
49d0: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 ng-intersperse (
49e0: 6d 61 70 20 73 3a 61 6e 79 2d 3e 73 74 72 69 6e map s:any->strin
49f0: 67 20 6d 73 67 29 20 22 20 22 29 29 29 0a 0a 28 g msg) " ")))..(
4a00: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
4a10: 70 72 65 76 2d 65 72 72 20 73 65 6c 66 29 0a 20 prev-err self).
4a20: 20 28 6c 65 74 20 28 28 70 72 65 76 2d 65 72 72 (let ((prev-err
4a30: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
4a40: 2f 64 65 66 61 75 6c 74 20 28 73 64 61 74 2d 67 /default (sdat-g
4a50: 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 2d 62 et-sessionvars-b
4a60: 65 66 6f 72 65 20 73 65 6c 66 29 20 22 45 52 52 efore self) "ERR
4a70: 4f 52 5f 4d 53 47 22 20 23 66 29 29 0a 09 28 63 OR_MSG" #f))..(c
4a80: 75 72 72 2d 65 72 72 20 28 68 61 73 68 2d 74 61 urr-err (hash-ta
4a90: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
4aa0: 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f (sdat-get-sessio
4ab0: 6e 76 61 72 73 20 73 65 6c 66 29 20 22 45 52 52 nvars self) "ERR
4ac0: 4f 52 5f 4d 53 47 22 20 23 66 29 29 29 0a 20 20 OR_MSG" #f))).
4ad0: 20 20 28 69 66 20 70 72 65 76 2d 65 72 72 20 70 (if prev-err p
4ae0: 72 65 76 2d 65 72 72 0a 09 28 69 66 20 63 75 72 rev-err..(if cur
4af0: 72 2d 65 72 72 20 63 75 72 72 2d 65 72 72 20 23 r-err curr-err #
4b00: 66 29 29 29 29 0a 0a 3b 3b 20 73 65 73 73 69 6f f))))..;; sessio
4b10: 6e 20 76 61 72 73 0a 3b 3b 20 31 2e 20 6b 65 79 n vars.;; 1. key
4b20: 73 20 61 72 65 20 61 6c 77 61 79 73 20 61 20 73 s are always a s
4b30: 74 72 69 6e 67 20 4e 4f 54 20 61 20 73 79 6d 62 tring NOT a symb
4b40: 6f 6c 0a 3b 3b 20 32 2e 20 76 61 6c 75 65 73 20 ol.;; 2. values
4b50: 61 72 65 20 61 6c 77 61 79 73 20 61 20 73 74 72 are always a str
4b60: 69 6e 67 20 63 6f 6e 76 65 72 73 69 6f 6e 20 69 ing conversion i
4b70: 73 20 74 68 65 20 72 65 73 70 6f 6e 73 69 62 69 s the responsibi
4b80: 6c 69 74 79 20 6f 66 20 74 68 65 20 0a 3b 3b 20 lity of the .;;
4b90: 20 20 20 63 6f 6e 73 75 6d 69 6e 67 20 66 75 6e consuming fun
4ba0: 63 74 69 6f 6e 20 28 61 74 20 6c 65 61 73 74 20 ction (at least
4bb0: 66 6f 72 20 6e 6f 77 2c 20 49 27 64 20 6c 69 6b for now, I'd lik
4bc0: 65 20 74 6f 20 63 68 61 6e 67 65 20 74 68 69 73 e to change this
4bd0: 29 0a 0a 3b 3b 20 73 65 74 20 61 20 73 65 73 73 )..;; set a sess
4be0: 69 6f 6e 20 76 61 72 20 66 6f 72 20 74 68 65 20 ion var for the
4bf0: 63 75 72 72 65 6e 74 20 70 61 67 65 0a 3b 3b 0a current page.;;.
4c00: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
4c10: 3a 63 75 72 72 2d 70 61 67 65 2d 73 65 74 21 20 :curr-page-set!
4c20: 73 65 6c 66 20 6b 65 79 20 76 61 6c 75 65 29 0a self key value).
4c30: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
4c40: 74 21 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 t! (sdat-get-pag
4c50: 65 76 61 72 73 20 73 65 6c 66 29 20 28 73 3a 61 evars self) (s:a
4c60: 6e 79 2d 3e 73 74 72 69 6e 67 20 6b 65 79 29 20 ny->string key)
4c70: 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 76 (s:any->string v
4c80: 61 6c 75 65 29 29 29 0a 0a 3b 3b 20 64 65 6c 20 alue)))..;; del
4c90: 61 20 76 61 72 20 66 6f 72 20 74 68 65 20 63 75 a var for the cu
4ca0: 72 72 65 6e 74 20 70 61 67 65 0a 3b 3b 0a 28 64 rrent page.;;.(d
4cb0: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 70 efine (session:p
4cc0: 61 67 65 2d 76 61 72 2d 64 65 6c 21 20 73 65 6c age-var-del! sel
4cd0: 66 20 6b 65 79 29 0a 20 20 28 68 61 73 68 2d 74 f key). (hash-t
4ce0: 61 62 6c 65 2d 64 65 6c 65 74 65 21 20 28 73 64 able-delete! (sd
4cf0: 61 74 2d 67 65 74 2d 70 61 67 65 76 61 72 73 20 at-get-pagevars
4d00: 73 65 6c 66 29 20 28 73 3a 61 6e 79 2d 3e 73 74 self) (s:any->st
4d10: 72 69 6e 67 20 6b 65 79 29 29 29 0a 0a 3b 3b 20 ring key)))..;;
4d20: 67 65 74 20 74 68 65 20 61 70 70 72 6f 70 72 69 get the appropri
4d30: 61 74 65 20 68 61 73 68 20 67 69 76 65 6e 20 61 ate hash given a
4d40: 20 70 61 67 65 20 22 2a 73 65 73 73 69 6f 6e 76 page "*sessionv
4d50: 61 72 73 2a 2c 20 2a 67 6c 6f 62 61 6c 76 61 72 ars*, *globalvar
4d60: 73 2a 20 6f 72 20 70 61 67 65 0a 3b 3b 0a 28 64 s* or page.;;.(d
4d70: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 efine (session:g
4d80: 65 74 2d 70 61 67 65 2d 68 61 73 68 20 73 65 6c et-page-hash sel
4d90: 66 20 70 61 67 65 29 0a 20 20 28 69 66 20 28 73 f page). (if (s
4da0: 74 72 69 6e 67 3d 3f 20 70 61 67 65 20 22 2a 73 tring=? page "*s
4db0: 65 73 73 69 6f 6e 76 61 72 73 2a 22 29 0a 20 20 essionvars*").
4dc0: 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d 73 65 (sdat-get-se
4dd0: 73 73 69 6f 6e 76 61 72 73 20 73 65 6c 66 29 0a ssionvars self).
4de0: 20 20 20 20 20 20 28 69 66 20 28 73 74 72 69 6e (if (strin
4df0: 67 3d 3f 20 70 61 67 65 20 22 2a 67 6c 6f 62 61 g=? page "*globa
4e00: 6c 76 61 72 73 2a 22 29 0a 09 20 20 28 73 64 61 lvars*").. (sda
4e10: 74 2d 67 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 t-get-globalvars
4e20: 20 73 65 6c 66 29 0a 09 20 20 28 73 64 61 74 2d self).. (sdat-
4e30: 67 65 74 2d 70 61 67 65 76 61 72 73 20 73 65 6c get-pagevars sel
4e40: 66 29 29 29 29 0a 0a 3b 3b 20 73 65 74 20 61 20 f))))..;; set a
4e50: 73 65 73 73 69 6f 6e 20 76 61 72 20 66 6f 72 20 session var for
4e60: 61 20 67 69 76 65 6e 20 70 61 67 65 0a 3b 3b 0a a given page.;;.
4e70: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
4e80: 3a 73 65 74 21 20 73 65 6c 66 20 70 61 67 65 20 :set! self page
4e90: 6b 65 79 20 76 61 6c 75 65 29 0a 20 20 28 6c 65 key value). (le
4ea0: 74 20 28 28 68 74 20 28 73 65 73 73 69 6f 6e 3a t ((ht (session:
4eb0: 67 65 74 2d 70 61 67 65 2d 68 61 73 68 20 73 65 get-page-hash se
4ec0: 6c 66 20 70 61 67 65 29 29 29 0a 20 20 20 20 28 lf page))). (
4ed0: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
4ee0: 68 74 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e ht (s:any->strin
4ef0: 67 20 6b 65 79 29 20 28 73 3a 61 6e 79 2d 3e 73 g key) (s:any->s
4f00: 74 72 69 6e 67 20 76 61 6c 75 65 29 29 29 29 0a tring value)))).
4f10: 0a 3b 3b 20 67 65 74 20 73 65 73 73 69 6f 6e 20 .;; get session
4f20: 76 61 72 73 20 66 6f 72 20 74 68 65 20 63 75 72 vars for the cur
4f30: 72 65 6e 74 20 70 61 67 65 0a 3b 3b 0a 28 64 65 rent page.;;.(de
4f40: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 70 61 fine (session:pa
4f50: 67 65 2d 67 65 74 20 73 65 6c 66 20 6b 65 79 29 ge-get self key)
4f60: 0a 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 . (hash-table-r
4f70: 65 66 2f 64 65 66 61 75 6c 74 20 28 73 64 61 74 ef/default (sdat
4f80: 2d 67 65 74 2d 70 61 67 65 76 61 72 73 20 73 65 -get-pagevars se
4f90: 6c 66 29 20 6b 65 79 20 23 66 29 29 0a 0a 3b 3b lf) key #f))..;;
4fa0: 20 67 65 74 20 73 65 73 73 69 6f 6e 20 76 61 72 get session var
4fb0: 73 20 66 6f 72 20 61 20 73 70 65 63 69 66 69 65 s for a specifie
4fc0: 64 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 69 6e d page.;;.(defin
4fd0: 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 20 73 e (session:get s
4fe0: 65 6c 66 20 70 61 67 65 20 6b 65 79 20 70 61 72 elf page key par
4ff0: 61 6d 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 68 ams). (let* ((h
5000: 74 20 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d t (session:get-
5010: 70 61 67 65 2d 68 61 73 68 20 73 65 6c 66 20 70 page-hash self p
5020: 61 67 65 29 29 0a 09 20 28 72 65 73 20 28 68 61 age)).. (res (ha
5030: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
5040: 61 75 6c 74 20 68 74 20 28 73 3a 61 6e 79 2d 3e ault ht (s:any->
5050: 73 74 72 69 6e 67 20 6b 65 79 29 20 23 66 29 29 string key) #f))
5060: 29 0a 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 61 ). (session:a
5070: 70 70 6c 79 2d 74 79 70 65 2d 70 72 65 66 65 72 pply-type-prefer
5080: 65 6e 63 65 20 72 65 73 20 70 61 72 61 6d 73 29 ence res params)
5090: 29 29 0a 0a 3b 3b 20 64 65 6c 65 74 65 20 61 20 ))..;; delete a
50a0: 73 65 73 73 69 6f 6e 20 76 61 72 20 66 6f 72 20 session var for
50b0: 61 20 73 70 65 63 69 66 69 65 64 20 70 61 67 65 a specified page
50c0: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 73 .;;.(define (ses
50d0: 73 69 6f 6e 3a 64 65 6c 21 20 73 65 6c 66 20 70 sion:del! self p
50e0: 61 67 65 20 6b 65 79 29 0a 20 20 28 6c 65 74 20 age key). (let
50f0: 28 28 68 74 20 28 73 65 73 73 69 6f 6e 3a 67 65 ((ht (session:ge
5100: 74 2d 70 61 67 65 2d 68 61 73 68 20 73 65 6c 66 t-page-hash self
5110: 20 70 61 67 65 29 29 29 0a 20 20 20 20 28 68 61 page))). (ha
5120: 73 68 2d 74 61 62 6c 65 2d 64 65 6c 65 74 65 21 sh-table-delete!
5130: 20 68 74 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 ht (s:any->stri
5140: 6e 67 20 6b 65 79 29 29 29 29 0a 0a 3b 3b 20 67 ng key))))..;; g
5150: 65 74 20 41 4c 4c 20 6b 65 79 73 20 66 6f 72 20 et ALL keys for
5160: 74 68 69 73 20 70 61 67 65 20 61 6e 64 20 73 74 this page and st
5170: 6f 72 65 20 69 6e 20 74 68 65 20 73 65 73 73 69 ore in the sessi
5180: 6f 6e 20 70 61 67 65 76 61 72 73 20 68 61 73 68 on pagevars hash
5190: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 73 .;;.(define (ses
51a0: 73 69 6f 6e 3a 67 65 74 2d 76 61 72 73 20 73 65 sion:get-vars se
51b0: 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 73 65 73 lf). (let ((ses
51c0: 73 69 6f 6e 2d 69 64 20 20 28 73 64 61 74 2d 67 sion-id (sdat-g
51d0: 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 et-session-id se
51e0: 6c 66 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e lf))). (if (n
51f0: 6f 74 20 73 65 73 73 69 6f 6e 2d 69 64 29 0a 09 ot session-id)..
5200: 28 65 72 72 3a 6c 6f 67 20 22 45 52 52 4f 52 3a (err:log "ERROR:
5210: 20 4e 6f 20 73 65 73 73 69 6f 6e 20 69 64 20 69 No session id i
5220: 6e 20 73 65 73 73 69 6f 6e 20 6f 62 6a 65 63 74 n session object
5230: 21 20 73 65 73 73 69 6f 6e 3a 67 65 74 2d 76 61 ! session:get-va
5240: 72 73 22 29 0a 09 28 6c 65 74 2a 20 28 28 72 65 rs")..(let* ((re
5250: 73 75 6c 74 20 20 20 20 20 20 20 20 20 20 20 20 sult
5260: 20 23 66 29 0a 09 20 20 20 20 20 20 20 28 63 6f #f).. (co
5270: 6e 6e 20 20 20 20 20 20 20 20 20 20 20 20 20 20 nn
5280: 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 (sdat-get-conn
5290: 73 65 6c 66 29 29 0a 09 20 20 20 20 20 20 20 28 self)).. (
52a0: 70 61 67 65 76 61 72 73 2d 62 65 66 6f 72 65 20 pagevars-before
52b0: 20 20 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 (sdat-get-pag
52c0: 65 76 61 72 73 2d 62 65 66 6f 72 65 20 73 65 6c evars-before sel
52d0: 66 29 29 0a 09 20 20 20 20 20 20 20 28 73 65 73 f)).. (ses
52e0: 73 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 20 sionvars-before
52f0: 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f (sdat-get-sessio
5300: 6e 76 61 72 73 2d 62 65 66 6f 72 65 20 73 65 6c nvars-before sel
5310: 66 29 29 0a 09 20 20 20 20 20 20 20 28 67 6c 6f f)).. (glo
5320: 62 61 6c 76 61 72 73 2d 62 65 66 6f 72 65 20 20 balvars-before
5330: 28 73 64 61 74 2d 67 65 74 2d 67 6c 6f 62 61 6c (sdat-get-global
5340: 76 61 72 73 2d 62 65 66 6f 72 65 20 73 65 6c 66 vars-before self
5350: 29 29 0a 09 20 20 20 20 20 20 20 28 70 61 67 65 )).. (page
5360: 76 61 72 73 20 20 20 20 20 20 20 20 20 20 20 28 vars (
5370: 73 64 61 74 2d 67 65 74 2d 70 61 67 65 76 61 72 sdat-get-pagevar
5380: 73 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 20 s self))..
5390: 20 28 73 65 73 73 69 6f 6e 76 61 72 73 20 20 20 (sessionvars
53a0: 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d 73 (sdat-get-s
53b0: 65 73 73 69 6f 6e 76 61 72 73 20 73 65 6c 66 29 essionvars self)
53c0: 29 0a 09 20 20 20 20 20 20 20 28 67 6c 6f 62 61 ).. (globa
53d0: 6c 76 61 72 73 20 20 20 20 20 20 20 20 20 28 73 lvars (s
53e0: 64 61 74 2d 67 65 74 2d 67 6c 6f 62 61 6c 76 61 dat-get-globalva
53f0: 72 73 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 rs self))..
5400: 20 20 28 70 61 67 65 2d 6e 61 6d 65 20 20 20 20 (page-name
5410: 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d (sdat-get-
5420: 70 61 67 65 20 73 65 6c 66 29 29 0a 09 20 20 20 page self))..
5430: 20 20 20 20 28 73 65 73 73 69 6f 6e 2d 6b 65 79 (session-key
5440: 20 20 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 (sdat-ge
5450: 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 t-session-key se
5460: 6c 66 29 29 0a 09 20 20 20 20 20 20 20 28 71 75 lf)).. (qu
5470: 65 72 79 20 20 20 20 20 20 20 20 20 20 20 20 20 ery
5480: 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 0a (string-append.
5490: 09 09 09 09 20 20 20 20 22 53 45 4c 45 43 54 20 .... "SELECT
54a0: 6b 65 79 2c 76 61 6c 75 65 20 46 52 4f 4d 20 73 key,value FROM s
54b0: 65 73 73 69 6f 6e 5f 76 61 72 73 20 49 4e 4e 45 ession_vars INNE
54c0: 52 20 4a 4f 49 4e 20 73 65 73 73 69 6f 6e 73 20 R JOIN sessions
54d0: 4f 4e 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 2e ON session_vars.
54e0: 73 65 73 73 69 6f 6e 5f 69 64 3d 73 65 73 73 69 session_id=sessi
54f0: 6f 6e 73 2e 69 64 20 22 0a 09 09 09 09 20 20 20 ons.id ".....
5500: 20 22 57 48 45 52 45 20 73 65 73 73 69 6f 6e 5f "WHERE session_
5510: 6b 65 79 3d 3f 20 41 4e 44 20 70 61 67 65 3d 3f key=? AND page=?
5520: 3b 22 29 29 29 0a 09 20 20 3b 3b 20 66 69 72 73 ;"))).. ;; firs
5530: 74 20 74 68 65 20 70 61 67 65 20 73 70 65 63 69 t the page speci
5540: 66 69 63 20 76 61 72 73 0a 09 20 20 28 64 62 69 fic vars.. (dbi
5550: 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 28 6c :for-each-row (l
5560: 61 6d 62 64 61 20 28 74 75 70 6c 65 29 0a 09 09 ambda (tuple)...
5570: 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 6b 20 . (let ((k
5580: 28 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c (vector-ref tupl
5590: 65 20 30 29 29 0a 09 09 09 09 20 20 20 20 28 76 e 0))..... (v
55a0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 (vector-ref tup
55b0: 6c 65 20 31 29 29 29 0a 09 09 09 09 28 68 61 73 le 1))).....(has
55c0: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 70 61 67 h-table-set! pag
55d0: 65 76 61 72 73 2d 62 65 66 6f 72 65 20 6b 20 76 evars-before k v
55e0: 29 0a 09 09 09 09 28 68 61 73 68 2d 74 61 62 6c ).....(hash-tabl
55f0: 65 2d 73 65 74 21 20 70 61 67 65 76 61 72 73 20 e-set! pagevars
5600: 20 20 20 20 20 20 20 6b 20 76 29 29 29 0a 09 09 k v)))...
5610: 09 20 20 20 20 63 6f 6e 6e 0a 09 09 09 20 20 20 . conn....
5620: 20 28 73 3a 73 71 6c 70 61 72 61 6d 20 71 75 65 (s:sqlparam que
5630: 72 79 20 73 65 73 73 69 6f 6e 2d 6b 65 79 20 70 ry session-key p
5640: 61 67 65 2d 6e 61 6d 65 29 29 0a 09 20 20 3b 3b age-name)).. ;;
5650: 20 74 68 65 6e 20 74 68 65 20 73 65 73 73 69 6f then the sessio
5660: 6e 20 73 70 65 63 69 66 69 63 20 76 61 72 73 0a n specific vars.
5670: 09 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 . (dbi:for-each
5680: 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 75 -row (lambda (tu
5690: 70 6c 65 29 0a 09 09 09 20 20 20 20 20 20 28 6c ple).... (l
56a0: 65 74 20 28 28 6b 20 28 76 65 63 74 6f 72 2d 72 et ((k (vector-r
56b0: 65 66 20 74 75 70 6c 65 20 30 29 29 0a 09 09 09 ef tuple 0))....
56c0: 09 20 20 20 20 28 76 20 28 76 65 63 74 6f 72 2d . (v (vector-
56d0: 72 65 66 20 74 75 70 6c 65 20 31 29 29 29 0a 09 ref tuple 1)))..
56e0: 09 09 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 ...(hash-table-s
56f0: 65 74 21 20 73 65 73 73 69 6f 6e 76 61 72 73 2d et! sessionvars-
5700: 62 65 66 6f 72 65 20 6b 20 76 29 0a 09 09 09 09 before k v).....
5710: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
5720: 20 73 65 73 73 69 6f 6e 76 61 72 73 20 20 20 20 sessionvars
5730: 20 20 20 20 6b 20 76 29 29 29 0a 09 09 09 20 20 k v)))....
5740: 20 20 63 6f 6e 6e 0a 09 09 09 20 20 20 20 28 73 conn.... (s
5750: 3a 73 71 6c 70 61 72 61 6d 20 71 75 65 72 79 20 :sqlparam query
5760: 73 65 73 73 69 6f 6e 2d 6b 65 79 20 22 2a 73 65 session-key "*se
5770: 73 73 69 6f 6e 76 61 72 73 2a 22 29 29 0a 09 20 ssionvars*"))..
5780: 20 3b 3b 20 61 6e 64 20 66 69 6e 61 6c 6c 79 20 ;; and finally
5790: 74 68 65 20 67 6c 6f 62 61 6c 20 76 61 72 73 0a the global vars.
57a0: 09 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 . (dbi:for-each
57b0: 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 75 -row (lambda (tu
57c0: 70 6c 65 29 0a 09 09 09 20 20 20 20 20 20 28 6c ple).... (l
57d0: 65 74 20 28 28 6b 20 28 76 65 63 74 6f 72 2d 72 et ((k (vector-r
57e0: 65 66 20 74 75 70 6c 65 20 30 29 29 0a 09 09 09 ef tuple 0))....
57f0: 09 20 20 20 20 28 76 20 28 76 65 63 74 6f 72 2d . (v (vector-
5800: 72 65 66 20 74 75 70 6c 65 20 31 29 29 29 0a 09 ref tuple 1)))..
5810: 09 09 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 ...(hash-table-s
5820: 65 74 21 20 67 6c 6f 62 61 6c 76 61 72 73 2d 62 et! globalvars-b
5830: 65 66 6f 72 65 20 6b 20 76 29 0a 09 09 09 09 28 efore k v).....(
5840: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
5850: 67 6c 6f 62 61 6c 76 61 72 73 20 20 20 20 20 20 globalvars
5860: 20 20 6b 20 76 29 29 29 0a 09 09 09 20 20 20 20 k v)))....
5870: 63 6f 6e 6e 0a 09 09 09 20 20 20 20 28 73 3a 73 conn.... (s:s
5880: 71 6c 70 61 72 61 6d 20 71 75 65 72 79 20 73 65 qlparam query se
5890: 73 73 69 6f 6e 2d 6b 65 79 20 22 2a 67 6c 6f 62 ssion-key "*glob
58a0: 61 6c 76 61 72 73 22 29 29 0a 09 20 20 29 29 29 alvars")).. )))
58b0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 )..(define (sess
58c0: 69 6f 6e 3a 73 61 76 65 2d 76 61 72 73 20 73 65 ion:save-vars se
58d0: 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 73 65 73 lf). (let ((ses
58e0: 73 69 6f 6e 2d 69 64 20 20 28 73 64 61 74 2d 67 sion-id (sdat-g
58f0: 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 et-session-id se
5900: 6c 66 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e lf))). (if (n
5910: 6f 74 20 73 65 73 73 69 6f 6e 2d 69 64 29 0a 09 ot session-id)..
5920: 28 65 72 72 3a 6c 6f 67 20 22 45 52 52 4f 52 3a (err:log "ERROR:
5930: 20 4e 6f 20 73 65 73 73 69 6f 6e 20 69 64 20 69 No session id i
5940: 6e 20 73 65 73 73 69 6f 6e 20 6f 62 6a 65 63 74 n session object
5950: 21 20 73 65 73 73 69 6f 6e 3a 67 65 74 2d 76 61 ! session:get-va
5960: 72 73 22 29 0a 09 28 6c 65 74 2a 20 28 28 73 74 rs")..(let* ((st
5970: 61 74 75 73 20 20 20 20 20 20 23 66 29 0a 09 20 atus #f)..
5980: 20 20 20 20 20 20 28 63 6f 6e 6e 20 20 20 20 20 (conn
5990: 20 20 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e (sdat-get-con
59a0: 6e 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 20 n self))..
59b0: 20 28 70 61 67 65 2d 6e 61 6d 65 20 20 20 28 73 (page-name (s
59c0: 64 61 74 2d 67 65 74 2d 70 61 67 65 20 73 65 6c dat-get-page sel
59d0: 66 29 29 0a 09 20 20 20 20 20 20 20 28 64 65 6c f)).. (del
59e0: 2d 71 75 65 72 79 20 20 20 22 44 45 4c 45 54 45 -query "DELETE
59f0: 20 46 52 4f 4d 20 73 65 73 73 69 6f 6e 5f 76 61 FROM session_va
5a00: 72 73 20 57 48 45 52 45 20 73 65 73 73 69 6f 6e rs WHERE session
5a10: 5f 69 64 3d 3f 20 41 4e 44 20 70 61 67 65 3d 3f _id=? AND page=?
5a20: 20 41 4e 44 20 6b 65 79 3d 3f 3b 22 29 0a 09 20 AND key=?;")..
5a30: 20 20 20 20 20 20 28 69 6e 73 2d 71 75 65 72 79 (ins-query
5a40: 20 20 20 22 49 4e 53 45 52 54 20 49 4e 54 4f 20 "INSERT INTO
5a50: 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 28 73 65 session_vars (se
5a60: 73 73 69 6f 6e 5f 69 64 2c 70 61 67 65 2c 6b 65 ssion_id,page,ke
5a70: 79 2c 76 61 6c 75 65 29 20 56 41 4c 55 45 53 28 y,value) VALUES(
5a80: 3f 2c 3f 2c 3f 2c 3f 29 3b 22 29 0a 09 20 20 20 ?,?,?,?);")..
5a90: 20 20 20 20 28 75 70 64 2d 71 75 65 72 79 20 20 (upd-query
5aa0: 20 22 55 50 44 41 54 45 20 73 65 73 73 69 6f 6e "UPDATE session
5ab0: 5f 76 61 72 73 20 73 65 74 20 76 61 6c 75 65 3d _vars set value=
5ac0: 3f 20 57 48 45 52 45 20 6b 65 79 3d 3f 20 41 4e ? WHERE key=? AN
5ad0: 44 20 73 65 73 73 69 6f 6e 5f 69 64 3d 3f 20 41 D session_id=? A
5ae0: 4e 44 20 70 61 67 65 3d 3f 3b 22 29 0a 09 20 20 ND page=?;")..
5af0: 20 20 20 20 20 28 63 68 61 6e 67 65 64 2d 63 6f (changed-co
5b00: 75 6e 74 20 30 29 29 0a 09 20 20 3b 3b 20 73 61 unt 0)).. ;; sa
5b10: 76 65 20 74 68 65 20 64 65 6c 74 61 20 6f 6e 6c ve the delta onl
5b20: 79 0a 09 20 20 28 66 6f 72 2d 65 61 63 68 0a 09 y.. (for-each..
5b30: 20 20 20 28 6c 61 6d 62 64 61 20 28 70 61 67 65 (lambda (page
5b40: 29 20 3b 3b 20 70 61 67 65 20 69 73 3a 20 22 2a ) ;; page is: "*
5b50: 67 6c 6f 62 61 6c 76 61 72 73 2a 22 20 22 2a 73 globalvars*" "*s
5b60: 65 73 73 69 6f 6e 76 61 72 73 2a 22 20 6f 72 20 essionvars*" or
5b70: 6f 74 68 65 72 73 74 72 69 6e 67 0a 09 20 20 20 otherstring..
5b80: 20 20 28 6c 65 74 2a 20 28 28 62 65 66 6f 72 65 (let* ((before
5b90: 2d 61 66 74 65 72 2d 68 74 20 28 63 6f 6e 64 0a -after-ht (cond.
5ba0: 09 09 09 09 20 20 20 20 20 20 28 28 73 74 72 69 .... ((stri
5bb0: 6e 67 3d 3f 20 70 61 67 65 20 22 2a 73 65 73 73 ng=? page "*sess
5bc0: 69 6f 6e 76 61 72 73 2a 22 29 0a 09 09 09 09 20 ionvars*").....
5bd0: 20 20 20 20 20 20 28 76 65 63 74 6f 72 20 28 73 (vector (s
5be0: 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 dat-get-sessionv
5bf0: 61 72 73 20 73 65 6c 66 29 0a 09 09 09 09 09 20 ars self)......
5c00: 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d (sdat-get-
5c10: 73 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 6f sessionvars-befo
5c20: 72 65 20 73 65 6c 66 29 29 29 0a 09 09 09 09 20 re self))).....
5c30: 20 20 20 20 20 20 28 28 73 74 72 69 6e 67 3d 3f ((string=?
5c40: 20 70 61 67 65 20 22 2a 67 6c 6f 62 61 6c 76 61 page "*globalva
5c50: 72 73 2a 22 29 0a 09 09 09 09 09 28 76 65 63 74 rs*")......(vect
5c60: 6f 72 20 28 73 64 61 74 2d 67 65 74 2d 67 6c 6f or (sdat-get-glo
5c70: 62 61 6c 76 61 72 73 20 73 65 6c 66 29 0a 09 09 balvars self)...
5c80: 09 09 09 09 28 73 64 61 74 2d 67 65 74 2d 67 6c ....(sdat-get-gl
5c90: 6f 62 61 6c 76 61 72 73 2d 62 65 66 6f 72 65 20 obalvars-before
5ca0: 73 65 6c 66 29 29 29 0a 09 09 09 09 20 20 20 20 self))).....
5cb0: 20 20 20 28 65 6c 73 65 20 0a 09 09 09 09 09 28 (else ......(
5cc0: 76 65 63 74 6f 72 20 28 73 64 61 74 2d 67 65 74 vector (sdat-get
5cd0: 2d 70 61 67 65 76 61 72 73 20 73 65 6c 66 29 0a -pagevars self).
5ce0: 09 09 09 09 09 09 28 73 64 61 74 2d 67 65 74 2d ......(sdat-get-
5cf0: 70 61 67 65 76 61 72 73 2d 62 65 66 6f 72 65 20 pagevars-before
5d00: 73 65 6c 66 29 29 29 29 29 0a 09 09 20 20 20 20 self)))))...
5d10: 28 6d 61 73 74 65 72 2d 68 74 20 20 20 28 76 65 (master-ht (ve
5d20: 63 74 6f 72 2d 72 65 66 20 62 65 66 6f 72 65 2d ctor-ref before-
5d30: 61 66 74 65 72 2d 68 74 20 30 29 29 0a 09 09 20 after-ht 0))...
5d40: 20 20 20 28 62 65 66 6f 72 65 2d 68 74 20 20 20 (before-ht
5d50: 28 76 65 63 74 6f 72 2d 72 65 66 20 62 65 66 6f (vector-ref befo
5d60: 72 65 2d 61 66 74 65 72 2d 68 74 20 31 29 29 0a re-after-ht 1)).
5d70: 09 09 20 20 20 20 28 6d 61 73 74 65 72 2d 6b 65 .. (master-ke
5d80: 79 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b ys (hash-table-k
5d90: 65 79 73 20 6d 61 73 74 65 72 2d 68 74 29 29 0a eys master-ht)).
5da0: 09 09 20 20 20 20 28 62 65 66 6f 72 65 2d 6b 65 .. (before-ke
5db0: 79 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b ys (hash-table-k
5dc0: 65 79 73 20 62 65 66 6f 72 65 2d 68 74 29 29 0a eys before-ht)).
5dd0: 09 09 20 20 20 20 28 61 6c 6c 2d 6b 65 79 73 20 .. (all-keys
5de0: 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 (delete-duplicat
5df0: 65 73 20 28 61 70 70 65 6e 64 20 6d 61 73 74 65 es (append maste
5e00: 72 2d 6b 65 79 73 20 62 65 66 6f 72 65 2d 6b 65 r-keys before-ke
5e10: 79 73 29 29 29 29 0a 09 20 20 20 20 20 20 20 28 ys)))).. (
5e20: 66 6f 72 2d 65 61 63 68 20 0a 09 09 28 6c 61 6d for-each ...(lam
5e30: 62 64 61 20 28 6b 65 79 29 0a 09 09 20 20 28 6c bda (key)... (l
5e40: 65 74 20 28 28 6d 61 73 74 65 72 2d 76 61 6c 75 et ((master-valu
5e50: 65 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 e (hash-table-re
5e60: 66 2f 64 65 66 61 75 6c 74 20 6d 61 73 74 65 72 f/default master
5e70: 2d 68 74 20 6b 65 79 20 23 66 29 29 0a 09 09 09 -ht key #f))....
5e80: 28 62 65 66 6f 72 65 2d 76 61 6c 75 65 20 28 68 (before-value (h
5e90: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
5ea0: 66 61 75 6c 74 20 62 65 66 6f 72 65 2d 68 74 20 fault before-ht
5eb0: 6b 65 79 20 23 66 29 29 29 0a 09 09 20 20 20 20 key #f)))...
5ec0: 28 63 6f 6e 64 0a 09 09 20 20 20 20 20 3b 3b 20 (cond... ;;
5ed0: 62 65 66 6f 72 65 20 61 6e 64 20 61 66 74 65 72 before and after
5ee0: 20 65 78 69 73 74 20 61 6e 64 20 76 61 6c 75 65 exist and value
5ef0: 20 75 6e 63 68 61 6e 67 65 64 20 2d 20 64 6f 20 unchanged - do
5f00: 6e 6f 74 68 69 6e 67 0a 09 09 20 20 20 20 20 28 nothing... (
5f10: 28 61 6e 64 20 6d 61 73 74 65 72 2d 76 61 6c 75 (and master-valu
5f20: 65 20 62 65 66 6f 72 65 2d 76 61 6c 75 65 20 28 e before-value (
5f30: 65 71 75 61 6c 3f 20 6d 61 73 74 65 72 2d 76 61 equal? master-va
5f40: 6c 75 65 20 62 65 66 6f 72 65 2d 76 61 6c 75 65 lue before-value
5f50: 29 29 29 0a 09 09 20 20 20 20 20 3b 3b 20 62 65 )))... ;; be
5f60: 66 6f 72 65 20 61 6e 64 20 61 66 74 65 72 20 65 fore and after e
5f70: 78 69 73 74 20 62 75 74 20 61 72 65 20 63 68 61 xist but are cha
5f80: 6e 67 65 64 0a 09 09 20 20 20 20 20 28 28 61 6e nged... ((an
5f90: 64 20 6d 61 73 74 65 72 2d 76 61 6c 75 65 20 62 d master-value b
5fa0: 65 66 6f 72 65 2d 76 61 6c 75 65 29 0a 09 09 20 efore-value)...
5fb0: 20 20 20 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 (dbi:for-ea
5fc0: 63 68 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 ch-row (lambda (
5fd0: 74 75 70 6c 65 29 0a 09 09 09 09 09 20 20 28 73 tuple)...... (s
5fe0: 65 74 21 20 63 68 61 6e 67 65 64 2d 63 6f 75 6e et! changed-coun
5ff0: 74 20 28 2b 20 63 68 61 6e 67 65 64 2d 63 6f 75 t (+ changed-cou
6000: 6e 74 20 31 29 29 29 0a 09 09 09 09 09 63 6f 6e nt 1)))......con
6010: 6e 0a 09 09 09 09 09 28 73 3a 73 71 6c 70 61 72 n......(s:sqlpar
6020: 61 6d 20 75 70 64 2d 71 75 65 72 79 20 6d 61 73 am upd-query mas
6030: 74 65 72 2d 76 61 6c 75 65 20 6b 65 79 20 73 65 ter-value key se
6040: 73 73 69 6f 6e 2d 69 64 20 70 61 67 65 29 29 29 ssion-id page)))
6050: 0a 09 09 20 20 20 20 20 3b 3b 20 6d 61 73 74 65 ... ;; maste
6060: 72 2d 76 61 6c 75 65 20 6e 6f 20 6c 6f 6e 67 65 r-value no longe
6070: 72 20 65 78 69 73 74 73 20 28 69 2e 65 2e 20 23 r exists (i.e. #
6080: 66 29 20 2d 20 72 65 6d 6f 76 65 20 69 74 65 6d f) - remove item
6090: 0a 09 09 20 20 20 20 20 28 28 6e 6f 74 20 6d 61 ... ((not ma
60a0: 73 74 65 72 2d 76 61 6c 75 65 29 0a 09 09 20 20 ster-value)...
60b0: 20 20 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 (dbi:for-eac
60c0: 68 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 h-row (lambda (t
60d0: 75 70 6c 65 29 0a 09 09 09 09 09 20 20 28 73 65 uple)...... (se
60e0: 74 21 20 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 t! changed-count
60f0: 20 28 2b 20 63 68 61 6e 67 65 64 2d 63 6f 75 6e (+ changed-coun
6100: 74 20 31 29 29 29 0a 09 09 09 09 09 63 6f 6e 6e t 1)))......conn
6110: 0a 09 09 09 09 09 28 73 3a 73 71 6c 70 61 72 61 ......(s:sqlpara
6120: 6d 20 64 65 6c 2d 71 75 65 72 79 20 73 65 73 73 m del-query sess
6130: 69 6f 6e 2d 69 64 20 70 61 67 65 20 6b 65 79 29 ion-id page key)
6140: 29 29 0a 09 09 20 20 20 20 20 3b 3b 20 62 65 66 ))... ;; bef
6150: 6f 72 65 2d 76 61 6c 75 65 20 64 6f 65 73 6e 27 ore-value doesn'
6160: 74 20 65 78 69 73 74 20 2d 20 69 6e 73 65 72 74 t exist - insert
6170: 20 61 20 6e 65 77 20 76 61 6c 75 65 0a 09 09 20 a new value...
6180: 20 20 20 20 28 28 6e 6f 74 20 62 65 66 6f 72 65 ((not before
6190: 2d 76 61 6c 75 65 29 0a 09 09 20 20 20 20 20 20 -value)...
61a0: 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f (dbi:for-each-ro
61b0: 77 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 w (lambda (tuple
61c0: 29 0a 09 09 09 09 09 20 20 28 73 65 74 21 20 63 )...... (set! c
61d0: 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 28 2b 20 hanged-count (+
61e0: 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 31 29 changed-count 1)
61f0: 29 29 0a 09 09 09 09 09 63 6f 6e 6e 0a 09 09 09 ))......conn....
6200: 09 09 28 73 3a 73 71 6c 70 61 72 61 6d 20 69 6e ..(s:sqlparam in
6210: 73 2d 71 75 65 72 79 20 73 65 73 73 69 6f 6e 2d s-query session-
6220: 69 64 20 70 61 67 65 20 6b 65 79 20 6d 61 73 74 id page key mast
6230: 65 72 2d 76 61 6c 75 65 29 29 29 0a 09 09 20 20 er-value)))...
6240: 20 20 20 28 65 6c 73 65 20 28 65 72 72 3a 6c 6f (else (err:lo
6250: 67 20 22 53 68 6f 75 6c 64 6e 27 74 20 67 65 74 g "Shouldn't get
6260: 20 68 65 72 65 22 29 29 29 29 29 0a 09 09 61 6c here")))))...al
6270: 6c 2d 6b 65 79 73 29 29 29 20 3b 3b 20 70 72 6f l-keys))) ;; pro
6280: 63 65 73 73 20 61 6c 6c 20 6b 65 79 73 0a 09 20 cess all keys..
6290: 20 20 28 6c 69 73 74 20 22 2a 73 65 73 73 69 6f (list "*sessio
62a0: 6e 76 61 72 73 2a 22 20 22 2a 67 6c 6f 62 61 6c nvars*" "*global
62b0: 76 61 72 73 2a 22 20 70 61 67 65 2d 6e 61 6d 65 vars*" page-name
62c0: 29 29 29 29 29 29 0a 0a 3b 3b 20 28 70 67 3a 73 ))))))..;; (pg:s
62d0: 71 6c 2d 6e 75 6c 6c 2d 6f 62 6a 65 63 74 3f 20 ql-null-object?
62e0: 65 6c 65 6d 65 6e 74 29 0a 28 64 65 66 69 6e 65 element).(define
62f0: 20 28 73 65 73 73 69 6f 6e 3a 72 65 61 64 2d 63 (session:read-c
6300: 6f 6e 66 69 67 20 73 65 6c 66 29 0a 20 20 28 6c onfig self). (l
6310: 65 74 2a 20 28 28 63 67 69 2d 70 61 74 68 20 28 et* ((cgi-path (
6320: 70 61 74 68 6e 61 6d 65 2d 64 69 72 65 63 74 6f pathname-directo
6330: 72 79 20 28 63 61 72 20 28 61 72 67 76 29 29 29 ry (car (argv)))
6340: 29 0a 20 20 20 20 20 20 20 20 20 28 6e 61 6d 65 ). (name
6350: 20 20 20 20 20 28 73 74 72 69 6e 67 2d 61 70 70 (string-app
6360: 65 6e 64 20 28 69 66 20 63 67 69 2d 70 61 74 68 end (if cgi-path
6370: 20 28 63 6f 6e 63 20 63 67 69 2d 70 61 74 68 20 (conc cgi-path
6380: 22 2f 22 29 20 22 22 29 20 22 2e 22 20 28 70 61 "/") "") "." (pa
6390: 74 68 6e 61 6d 65 2d 66 69 6c 65 20 28 63 61 72 thname-file (car
63a0: 20 28 61 72 67 76 29 29 29 20 22 2e 63 6f 6e 66 (argv))) ".conf
63b0: 69 67 22 29 29 29 0a 20 20 20 20 28 69 66 20 28 ig"))). (if (
63c0: 6e 6f 74 20 28 66 69 6c 65 2d 65 78 69 73 74 73 not (file-exists
63d0: 3f 20 6e 61 6d 65 29 29 0a 09 28 70 72 69 6e 74 ? name))..(print
63e0: 20 6e 61 6d 65 20 22 20 6e 6f 74 20 66 6f 75 6e name " not foun
63f0: 64 20 61 74 20 22 20 28 63 75 72 72 65 6e 74 2d d at " (current-
6400: 64 69 72 65 63 74 6f 72 79 29 29 0a 09 28 6c 65 directory))..(le
6410: 74 2a 20 28 28 66 70 20 28 6f 70 65 6e 2d 69 6e t* ((fp (open-in
6420: 70 75 74 2d 66 69 6c 65 20 6e 61 6d 65 29 29 0a put-file name)).
6430: 09 20 20 20 20 20 20 20 28 69 6e 69 74 61 72 67 . (initarg
6440: 73 20 28 72 65 61 64 20 66 70 29 29 29 0a 09 20 s (read fp)))..
6450: 20 28 63 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 6f (close-input-po
6460: 72 74 20 66 70 29 0a 09 20 20 69 6e 69 74 61 72 rt fp).. initar
6470: 67 73 29 29 29 29 0a 0a 3b 3b 20 63 61 6c 6c 20 gs))))..;; call
6480: 74 68 65 20 63 6f 6e 74 72 6f 6c 6c 65 72 20 69 the controller i
6490: 66 20 69 74 20 65 78 69 73 74 73 0a 3b 3b 20 0a f it exists.;; .
64a0: 3b 3b 20 57 41 52 4e 49 4e 47 20 2d 20 74 68 69 ;; WARNING - thi
64b0: 73 20 63 6f 64 65 20 6e 65 65 64 73 20 61 20 64 s code needs a d
64c0: 65 66 65 6e 63 65 20 61 67 61 69 6e 73 20 72 65 efence agains re
64d0: 63 75 72 73 69 76 65 20 63 61 6c 6c 69 6e 67 21 cursive calling!
64e0: 21 21 21 21 0a 3b 3b 0a 3b 3b 20 20 20 49 20 73 !!!!.;;.;; I s
64f0: 75 67 67 65 73 74 20 61 20 6c 69 6d 69 74 20 6f uggest a limit o
6500: 66 20 31 30 30 20 63 61 6c 6c 73 2e 20 50 6c 65 f 100 calls. Ple
6510: 6e 74 79 20 66 6f 72 20 61 6c 6c 6f 77 69 6e 67 nty for allowing
6520: 20 6d 75 6c 74 69 70 6c 65 20 69 6e 73 74 61 6e multiple instan
6530: 63 65 73 0a 3b 3b 20 20 20 6f 66 20 61 20 70 61 ces.;; of a pa
6540: 67 65 20 69 6e 73 69 64 65 20 61 6e 6f 74 68 65 ge inside anothe
6550: 72 20 70 61 67 65 2e 20 0a 3b 3b 0a 3b 3b 20 70 r page. .;;.;; p
6560: 61 72 74 73 20 3d 20 27 62 6f 74 68 20 7c 20 27 arts = 'both | '
6570: 63 6f 6e 74 72 6f 6c 20 7c 20 27 76 69 65 77 0a control | 'view.
6580: 3b 3b 0a 0a 28 64 65 66 69 6e 65 20 28 66 69 6c ;;..(define (fil
6590: 65 73 2d 72 65 61 64 2d 3e 73 74 72 69 6e 67 20 es-read->string
65a0: 2e 20 66 69 6c 65 73 29 0a 20 20 28 73 74 72 69 . files). (stri
65b0: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 0a ng-intersperse .
65c0: 20 20 20 28 61 70 70 6c 79 20 61 70 70 65 6e 64 (apply append
65d0: 20 28 6d 61 70 20 66 69 6c 65 2d 72 65 61 64 2d (map file-read-
65e0: 3e 73 74 72 69 6e 67 20 66 69 6c 65 73 29 29 20 >string files))
65f0: 22 5c 6e 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 "\n"))..(define
6600: 28 66 69 6c 65 2d 72 65 61 64 2d 3e 73 74 72 69 (file-read->stri
6610: 6e 67 20 66 29 20 0a 20 20 28 6c 65 74 20 28 28 ng f) . (let ((
6620: 70 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 66 69 p (open-input-fi
6630: 6c 65 20 66 29 29 29 0a 20 20 20 20 28 6c 65 74 le f))). (let
6640: 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 72 65 61 loop ((hed (rea
6650: 64 2d 6c 69 6e 65 20 70 29 29 0a 09 20 20 20 20 d-line p))..
6660: 20 20 20 28 72 65 73 20 27 28 29 29 29 0a 20 20 (res '())).
6670: 20 20 20 20 28 69 66 20 28 65 6f 66 2d 6f 62 6a (if (eof-obj
6680: 65 63 74 3f 20 68 65 64 29 0a 09 20 20 72 65 73 ect? hed).. res
6690: 0a 09 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d .. (loop (read-
66a0: 6c 69 6e 65 20 70 29 28 61 70 70 65 6e 64 20 72 line p)(append r
66b0: 65 73 20 28 6c 69 73 74 20 68 65 64 29 29 29 29 es (list hed))))
66c0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 70 72 )))..(define (pr
66d0: 6f 63 65 73 73 2d 70 6f 72 74 20 70 29 0a 20 20 ocess-port p).
66e0: 28 6c 65 74 20 28 28 65 20 28 69 6e 74 65 72 61 (let ((e (intera
66f0: 63 74 69 6f 6e 2d 65 6e 76 69 72 6f 6e 6d 65 6e ction-environmen
6700: 74 29 29 29 0a 20 20 20 20 28 6d 61 70 20 0a 20 t))). (map .
6710: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 78 29 0a (lambda (x).
6720: 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 09 28 28 (cond..((
6730: 6c 69 73 74 3f 20 78 29 20 78 29 0a 09 28 28 73 list? x) x)..((s
6740: 74 72 69 6e 67 3f 20 78 29 20 78 29 0a 09 28 65 tring? x) x)..(e
6750: 6c 73 65 20 27 28 29 29 29 29 0a 20 20 20 20 20 lse '()))).
6760: 28 70 6f 72 74 2d 6d 61 70 20 28 6c 61 6d 62 64 (port-map (lambd
6770: 61 20 28 73 29 0a 09 09 20 28 65 76 61 6c 20 73 a (s)... (eval s
6780: 20 65 29 29 0a 09 20 20 20 20 20 20 20 28 6c 61 e)).. (la
6790: 6d 62 64 61 20 28 29 28 72 65 61 64 20 70 29 29 mbda ()(read p))
67a0: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 ))))..(define (s
67b0: 65 73 73 69 6f 6e 3a 70 72 6f 63 65 73 73 2d 66 ession:process-f
67c0: 69 6c 65 20 66 29 0a 20 20 28 6c 65 74 2a 20 28 ile f). (let* (
67d0: 28 70 20 20 20 20 28 6f 70 65 6e 2d 69 6e 70 75 (p (open-inpu
67e0: 74 2d 66 69 6c 65 20 66 29 29 0a 09 20 28 64 61 t-file f)).. (da
67f0: 74 20 20 28 70 72 6f 63 65 73 73 2d 70 6f 72 74 t (process-port
6800: 20 70 29 29 29 0a 20 20 20 20 28 63 6c 6f 73 65 p))). (close
6810: 2d 69 6e 70 75 74 2d 70 6f 72 74 20 70 29 0a 20 -input-port p).
6820: 20 20 20 64 61 74 29 29 0a 0a 3b 3b 20 4d 61 79 dat))..;; May
6830: 20 32 30 31 31 2c 20 70 75 74 74 69 6e 67 20 61 2011, putting a
6840: 6c 6c 20 70 61 67 65 73 20 69 6e 74 6f 20 6f 6e ll pages into on
6850: 65 20 64 69 72 65 63 74 6f 72 79 20 66 6f 72 20 e directory for
6860: 74 68 65 20 66 6f 6c 6c 6f 77 69 6e 67 20 72 65 the following re
6870: 61 73 6f 6e 73 3a 0a 3b 3b 20 20 20 31 2e 20 77 asons:.;; 1. w
6880: 61 6e 74 20 66 69 6c 65 6e 61 6d 65 20 74 6f 20 ant filename to
6890: 72 65 66 6c 65 63 74 20 70 61 67 65 20 6e 61 6d reflect page nam
68a0: 65 20 28 65 6d 61 63 73 20 6c 69 6d 69 74 61 74 e (emacs limitat
68b0: 69 6f 6e 29 0a 3b 3b 20 20 20 32 2e 20 74 68 61 ion).;; 2. tha
68c0: 74 27 73 20 69 74 21 20 6e 6f 20 6f 74 68 65 72 t's it! no other
68d0: 20 72 65 61 73 6f 6e 2e 20 63 6f 75 6c 64 20 6d reason. could m
68e0: 61 6b 65 20 69 74 20 63 6f 6e 66 69 67 75 72 61 ake it configura
68f0: 62 6c 65 20 2e 2e 2e 0a 3b 3b 20 70 61 67 65 2d ble ....;; page-
6900: 64 69 72 2d 73 74 79 6c 65 20 69 73 3a 0a 3b 3b dir-style is:.;;
6910: 20 20 27 73 74 6f 72 65 64 20 20 20 3d 3e 20 73 'stored => s
6920: 74 6f 72 65 64 20 69 6e 20 65 78 65 63 75 74 61 tored in executa
6930: 62 6c 65 0a 3b 3b 20 20 27 66 6c 61 74 20 20 20 ble.;; 'flat
6940: 20 20 3d 3e 20 70 61 67 65 73 20 66 6c 61 74 20 => pages flat
6950: 64 69 72 65 63 74 6f 72 79 0a 3b 3b 20 20 27 64 directory.;; 'd
6960: 69 72 20 20 20 20 20 20 3d 3e 20 64 69 72 65 63 ir => direc
6970: 74 6f 72 79 20 74 72 65 65 20 70 61 67 65 73 2f tory tree pages/
6980: 3c 70 61 67 65 6e 61 6d 65 3e 2f 7b 76 69 65 77 <pagename>/{view
6990: 2c 63 6f 6e 74 72 6f 6c 7d 2e 73 63 6d 0a 3b 3b ,control}.scm.;;
69a0: 20 70 61 72 74 73 3a 0a 3b 3b 20 20 27 62 6f 74 parts:.;; 'bot
69b0: 68 20 20 20 20 20 3d 3e 20 6c 6f 61 64 20 63 6f h => load co
69c0: 6e 74 72 6f 6c 20 61 6e 64 20 76 69 65 77 20 28 ntrol and view (
69d0: 61 6e 79 74 68 69 6e 67 20 6f 74 68 65 72 20 74 anything other t
69e0: 68 61 6e 20 76 69 65 77 20 6f 72 20 63 6f 6e 74 han view or cont
69f0: 72 6f 6c 0a 3b 3b 20 20 27 76 69 65 77 20 20 20 rol.;; 'view
6a00: 20 20 3d 3e 20 6c 6f 61 64 20 76 69 65 77 20 6f => load view o
6a10: 6e 6c 79 0a 3b 3b 20 20 27 63 6f 6e 74 72 6f 6c nly.;; 'control
6a20: 20 20 3d 3e 20 6c 6f 61 64 20 63 6f 6e 74 72 6f => load contro
6a30: 6c 20 6f 6e 6c 79 0a 28 64 65 66 69 6e 65 20 28 l only.(define (
6a40: 73 65 73 73 69 6f 6e 3a 63 61 6c 6c 2d 70 61 72 session:call-par
6a50: 74 73 20 73 65 6c 66 20 70 61 67 65 20 23 21 6b ts self page #!k
6a60: 65 79 20 28 70 61 72 74 73 20 27 62 6f 74 68 29 ey (parts 'both)
6a70: 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 63 75 ). (sdat-set-cu
6a80: 72 72 2d 70 61 67 65 21 20 73 65 6c 66 20 70 61 rr-page! self pa
6a90: 67 65 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 69 ge). (let* ((di
6aa0: 72 2d 73 74 79 6c 65 20 20 20 20 28 73 64 61 74 r-style (sdat
6ab0: 2d 67 65 74 2d 70 61 67 65 2d 64 69 72 2d 73 74 -get-page-dir-st
6ac0: 79 6c 65 20 73 65 6c 66 29 29 3b 3b 20 28 65 71 yle self));; (eq
6ad0: 75 61 6c 3f 20 28 73 64 61 74 2d 67 65 74 2d 70 ual? (sdat-get-p
6ae0: 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 20 73 65 age-dir-style se
6af0: 6c 66 29 20 22 6f 6e 65 64 69 72 22 29 29 20 3b lf) "onedir")) ;
6b00: 3b 20 66 6c 61 67 20 23 74 20 66 6f 72 20 6f 6e ; flag #t for on
6b10: 65 64 69 72 2c 20 23 66 20 66 6f 72 20 6f 6c 64 edir, #f for old
6b20: 20 73 74 79 6c 65 0a 09 20 28 64 69 72 20 20 20 style.. (dir
6b30: 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 61 (string-a
6b40: 70 70 65 6e 64 20 28 73 64 61 74 2d 67 65 74 2d ppend (sdat-get-
6b50: 73 72 6f 6f 74 20 73 65 6c 66 29 20 0a 09 09 09 sroot self) ....
6b60: 09 20 20 20 20 20 20 28 69 66 20 64 69 72 2d 73 . (if dir-s
6b70: 74 79 6c 65 20 0a 09 09 09 09 09 20 20 28 63 6f tyle ...... (co
6b80: 6e 63 20 22 2f 70 61 67 65 73 2f 22 29 0a 09 09 nc "/pages/")...
6b90: 09 09 09 20 20 28 63 6f 6e 63 20 22 2f 70 61 67 ... (conc "/pag
6ba0: 65 73 2f 22 20 70 61 67 65 29 29 29 29 29 0a 20 es/" page))))).
6bb0: 20 20 20 28 63 61 73 65 20 64 69 72 2d 73 74 79 (case dir-sty
6bc0: 6c 65 0a 20 20 20 20 20 20 3b 3b 20 4e 42 2f 2f le. ;; NB//
6bd0: 20 53 74 6f 72 65 64 20 61 6c 77 61 79 73 20 6c Stored always l
6be0: 6f 61 64 73 20 62 6f 74 68 20 63 6f 6e 74 72 6f oads both contro
6bf0: 6c 20 61 6e 64 20 76 69 65 77 0a 20 20 20 20 20 l and view.
6c00: 20 28 28 73 74 6f 72 65 64 29 0a 20 20 20 20 20 ((stored).
6c10: 20 20 28 28 65 76 61 6c 20 28 73 74 72 69 6e 67 ((eval (string
6c20: 2d 3e 73 79 6d 62 6f 6c 20 28 63 6f 6e 63 20 22 ->symbol (conc "
6c30: 70 61 67 65 73 3a 22 20 70 61 67 65 29 29 29 20 pages:" page)))
6c40: 0a 09 73 65 6c 66 20 20 20 20 20 20 20 20 20 20 ..self
6c50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
6c60: 3b 20 74 68 65 20 73 65 73 73 69 6f 6e 0a 09 28 ; the session..(
6c70: 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 sdat-get-conn se
6c80: 6c 66 29 20 20 20 20 20 20 20 20 20 3b 3b 20 74 lf) ;; t
6c90: 68 65 20 64 62 20 63 6f 6e 6e 65 63 74 69 6f 6e he db connection
6ca0: 0a 09 28 73 64 61 74 2d 67 65 74 2d 73 68 61 72 ..(sdat-get-shar
6cb0: 65 64 2d 68 61 73 68 20 73 65 6c 66 29 20 20 3b ed-hash self) ;
6cc0: 3b 20 61 20 73 68 61 72 65 64 20 68 61 73 68 20 ; a shared hash
6cd0: 74 61 62 6c 65 20 66 6f 72 20 70 61 73 73 69 6e table for passin
6ce0: 67 20 64 61 74 61 20 74 6f 2f 66 72 6f 6d 20 70 g data to/from p
6cf0: 61 67 65 20 63 61 6c 6c 73 0a 09 29 29 0a 20 20 age calls..)).
6d00: 20 20 20 20 28 28 66 6c 61 74 29 20 20 20 0a 20 ((flat) .
6d10: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 73 6f (let* ((so
6d20: 2d 66 69 6c 65 20 20 28 63 6f 6e 63 20 64 69 72 -file (conc dir
6d30: 20 70 61 67 65 20 22 2e 73 6f 22 29 29 0a 09 20 page ".so"))..
6d40: 20 20 20 20 20 28 73 63 6d 2d 66 69 6c 65 20 28 (scm-file (
6d50: 63 6f 6e 63 20 64 69 72 20 70 61 67 65 20 22 2e conc dir page ".
6d60: 73 63 6d 22 29 29 0a 09 20 20 20 20 20 20 28 73 scm")).. (s
6d70: 72 63 2d 66 69 6c 65 20 28 6f 72 20 28 66 69 6c rc-file (or (fil
6d80: 65 2d 65 78 69 73 74 73 3f 20 73 6f 2d 66 69 6c e-exists? so-fil
6d90: 65 29 0a 09 09 09 20 20 20 20 28 66 69 6c 65 2d e).... (file-
6da0: 65 78 69 73 74 73 3f 20 73 63 6d 2d 66 69 6c 65 exists? scm-file
6db0: 29 29 29 29 0a 09 20 28 69 66 20 73 72 63 2d 66 )))).. (if src-f
6dc0: 69 6c 65 0a 09 20 20 20 20 20 28 62 65 67 69 6e ile.. (begin
6dd0: 0a 09 20 20 20 20 20 20 20 28 6c 6f 61 64 20 73 .. (load s
6de0: 72 63 2d 66 69 6c 65 29 0a 09 20 20 20 20 20 20 rc-file)..
6df0: 20 28 28 65 76 61 6c 20 28 73 74 72 69 6e 67 2d ((eval (string-
6e00: 3e 73 79 6d 62 6f 6c 20 28 63 6f 6e 63 20 22 70 >symbol (conc "p
6e10: 61 67 65 73 3a 22 20 70 61 67 65 29 29 29 20 0a ages:" page))) .
6e20: 09 09 73 65 6c 66 20 20 20 20 20 20 20 20 20 20 ..self
6e30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
6e40: 3b 20 74 68 65 20 73 65 73 73 69 6f 6e 0a 09 09 ; the session...
6e50: 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 (sdat-get-conn s
6e60: 65 6c 66 29 20 20 20 20 20 20 20 20 20 3b 3b 20 elf) ;;
6e70: 74 68 65 20 64 62 20 63 6f 6e 6e 65 63 74 69 6f the db connectio
6e80: 6e 0a 09 09 28 73 64 61 74 2d 67 65 74 2d 73 68 n...(sdat-get-sh
6e90: 61 72 65 64 2d 68 61 73 68 20 73 65 6c 66 29 20 ared-hash self)
6ea0: 20 3b 3b 20 61 20 73 68 61 72 65 64 20 68 61 73 ;; a shared has
6eb0: 68 20 74 61 62 6c 65 20 66 6f 72 20 70 61 73 73 h table for pass
6ec0: 69 6e 67 20 64 61 74 61 20 74 6f 2f 66 72 6f 6d ing data to/from
6ed0: 20 70 61 67 65 20 63 61 6c 6c 73 0a 09 09 29 29 page calls...))
6ee0: 0a 09 20 20 20 20 20 28 6c 69 73 74 20 22 3c 70 .. (list "<p
6ef0: 3e 50 61 67 65 20 6e 6f 74 20 66 6f 75 6e 64 20 >Page not found
6f00: 22 20 70 61 67 65 20 22 20 3c 2f 70 3e 22 29 29 " page " </p>"))
6f10: 29 29 0a 20 20 20 20 20 20 20 3b 3b 20 66 69 72 )). ;; fir
6f20: 73 74 20 74 68 65 20 63 6f 6e 74 72 6f 6c 0a 20 st the control.
6f30: 20 20 20 20 20 20 3b 3b 20 28 6c 65 74 20 28 28 ;; (let ((
6f40: 63 6f 6e 74 72 6f 6c 2d 66 69 6c 65 20 28 63 6f control-file (co
6f50: 6e 63 20 22 70 61 67 65 73 2f 22 20 70 61 67 65 nc "pages/" page
6f60: 20 22 5f 63 74 72 6c 2e 73 63 6d 22 29 29 0a 20 "_ctrl.scm")).
6f70: 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 28 ;; (
6f80: 76 69 65 77 2d 66 69 6c 65 20 20 20 20 28 63 6f view-file (co
6f90: 6e 63 20 22 70 61 67 65 73 2f 22 20 70 61 67 65 nc "pages/" page
6fa0: 20 22 5f 76 69 65 77 2e 73 63 6d 22 29 29 29 0a "_view.scm"))).
6fb0: 20 20 20 20 20 20 20 3b 3b 20 20 20 28 69 66 20 ;; (if
6fc0: 28 61 6e 64 20 28 66 69 6c 65 2d 65 78 69 73 74 (and (file-exist
6fd0: 73 3f 20 63 6f 6e 74 72 6f 6c 2d 66 69 6c 65 29 s? control-file)
6fe0: 0a 20 20 20 20 20 20 20 3b 3b 20 20 09 20 20 28 . ;; . (
6ff0: 6e 6f 74 20 28 65 71 3f 20 70 61 72 74 73 20 27 not (eq? parts '
7000: 76 69 65 77 29 29 29 0a 20 20 20 20 20 20 20 3b view))). ;
7010: 3b 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 ; (begin.
7020: 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 ;;
7030: 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 2d 63 61 (session:set-ca
7040: 6c 6c 65 64 21 20 73 65 6c 66 20 70 61 67 65 29 lled! self page)
7050: 0a 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 . ;;
7060: 20 20 20 28 6c 6f 61 64 20 63 6f 6e 74 72 6f 6c (load control
7070: 2d 66 69 6c 65 29 29 29 0a 20 20 20 20 20 20 20 -file))).
7080: 3b 3b 20 20 20 28 69 66 20 28 66 69 6c 65 2d 65 ;; (if (file-e
7090: 78 69 73 74 73 3f 20 76 69 65 77 2d 66 69 6c 65 xists? view-file
70a0: 29 0a 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 ). ;;
70b0: 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 (if (not (eq?
70c0: 70 61 72 74 73 20 27 63 6f 6e 74 72 6f 6c 29 29 parts 'control))
70d0: 0a 20 20 20 20 20 20 20 3b 3b 20 20 09 20 28 73 . ;; . (s
70e0: 65 73 73 69 6f 6e 3a 70 72 6f 63 65 73 73 2d 66 ession:process-f
70f0: 69 6c 65 20 76 69 65 77 2d 66 69 6c 65 29 29 0a ile view-file)).
7100: 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 ;;
7110: 28 6c 69 73 74 20 22 3c 70 3e 50 61 67 65 20 6e (list "<p>Page n
7120: 6f 74 20 66 6f 75 6e 64 20 22 20 70 61 67 65 20 ot found " page
7130: 22 20 3c 2f 70 3e 22 29 29 29 0a 20 20 20 20 20 " </p>"))).
7140: 20 28 28 64 69 72 29 20 22 45 52 52 4f 52 3a 20 ((dir) "ERROR:
7150: 20 64 69 72 20 73 74 79 6c 65 20 6e 6f 74 20 79 dir style not y
7160: 65 74 20 72 65 2d 69 6d 70 6c 65 6d 65 6e 74 65 et re-implemente
7170: 64 22 29 0a 20 20 20 20 20 20 28 65 6c 73 65 0a d"). (else.
7180: 20 20 20 20 20 20 20 28 6c 69 73 74 20 22 45 52 (list "ER
7190: 52 4f 52 3a 20 70 61 67 65 2d 64 69 72 2d 73 74 ROR: page-dir-st
71a0: 79 6c 65 20 6d 75 73 74 20 62 65 20 73 74 6f 72 yle must be stor
71b0: 65 64 2c 20 64 69 72 20 6f 72 20 66 6c 61 74 2c ed, dir or flat,
71c0: 20 67 6f 74 20 22 20 64 69 72 2d 73 74 79 6c 65 got " dir-style
71d0: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define (
71e0: 73 65 73 73 69 6f 6e 3a 63 61 6c 6c 20 73 65 6c session:call sel
71f0: 66 20 70 61 67 65 20 70 61 72 74 73 29 0a 20 20 f page parts).
7200: 28 73 65 73 73 69 6f 6e 3a 63 61 6c 6c 2d 70 61 (session:call-pa
7210: 72 74 73 20 73 65 6c 66 20 70 61 67 65 20 27 62 rts self page 'b
7220: 6f 74 68 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e oth))..;; (defin
7230: 65 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 61 64 2d e (session:load-
7240: 6d 6f 64 65 6c 20 73 65 6c 66 20 6d 6f 64 65 6c model self model
7250: 29 0a 3b 3b 20 20 20 28 6c 65 74 20 28 28 6d 6f ).;; (let ((mo
7260: 64 65 6c 2e 73 63 6d 20 28 73 74 72 69 6e 67 2d del.scm (string-
7270: 61 70 70 65 6e 64 20 28 73 64 61 74 2d 67 65 74 append (sdat-get
7280: 2d 73 72 6f 6f 74 20 73 65 6c 66 29 20 22 2f 6d -sroot self) "/m
7290: 6f 64 65 6c 73 2f 22 20 6d 6f 64 65 6c 20 22 2e odels/" model ".
72a0: 73 63 6d 22 29 29 0a 3b 3b 20 09 28 6d 6f 64 65 scm")).;; .(mode
72b0: 6c 2e 73 6f 20 20 28 73 74 72 69 6e 67 2d 61 70 l.so (string-ap
72c0: 70 65 6e 64 20 28 73 64 61 74 2d 67 65 74 2d 73 pend (sdat-get-s
72d0: 72 6f 6f 74 20 73 65 6c 66 29 20 22 2f 6d 6f 64 root self) "/mod
72e0: 65 6c 73 2f 22 20 6d 6f 64 65 6c 20 22 2e 73 6f els/" model ".so
72f0: 22 29 29 29 0a 3b 3b 20 20 20 20 20 28 69 66 20 "))).;; (if
7300: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 6d 6f (file-exists? mo
7310: 64 65 6c 2e 73 6f 29 0a 3b 3b 20 09 28 6c 6f 61 del.so).;; .(loa
7320: 64 20 6d 6f 64 65 6c 2e 73 6f 29 0a 3b 3b 20 09 d model.so).;; .
7330: 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 (if (file-exists
7340: 3f 20 6d 6f 64 65 6c 2e 73 63 6d 29 0a 3b 3b 20 ? model.scm).;;
7350: 09 20 20 20 20 28 6c 6f 61 64 20 6d 6f 64 65 6c . (load model
7360: 2e 73 63 6d 29 0a 3b 3b 20 09 20 20 20 20 28 73 .scm).;; . (s
7370: 3a 6c 6f 67 20 22 45 52 52 4f 52 3a 20 6d 6f 64 :log "ERROR: mod
7380: 65 6c 20 22 20 6d 6f 64 65 6c 2e 73 63 6d 20 22 el " model.scm "
7390: 20 6e 6f 74 20 66 6f 75 6e 64 22 29 29 29 29 29 not found")))))
73a0: 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 65 ..;; (define (se
73b0: 73 73 69 6f 6e 3a 6d 6f 64 65 6c 2d 70 61 74 68 ssion:model-path
73c0: 20 73 65 6c 66 20 6d 6f 64 65 6c 29 0a 3b 3b 20 self model).;;
73d0: 20 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 (string-append
73e0: 20 28 73 64 61 74 2d 67 65 74 2d 73 72 6f 6f 74 (sdat-get-sroot
73f0: 20 73 65 6c 66 29 20 22 2f 6d 6f 64 65 6c 73 2f self) "/models/
7400: 22 20 6d 6f 64 65 6c 20 22 2e 73 63 6d 22 29 29 " model ".scm"))
7410: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ..(define (sessi
7420: 6f 6e 3a 70 70 2d 66 6f 72 6d 64 61 74 20 73 65 on:pp-formdat se
7430: 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 64 61 74 lf). (let ((dat
7440: 20 28 66 6f 72 6d 64 61 74 3a 61 6c 6c 2d 3e 73 (formdat:all->s
7450: 74 72 69 6e 67 73 20 28 73 64 61 74 2d 67 65 74 trings (sdat-get
7460: 2d 66 6f 72 6d 64 61 74 20 73 65 6c 66 29 29 29 -formdat self)))
7470: 29 0a 20 20 20 20 28 73 74 72 69 6e 67 2d 69 6e ). (string-in
7480: 74 65 72 73 70 65 72 73 65 20 64 61 74 20 22 3c tersperse dat "<
7490: 62 72 3e 20 22 29 29 29 0a 0a 28 64 65 66 69 6e br> ")))..(defin
74a0: 65 20 28 73 65 73 73 69 6f 6e 3a 70 61 72 61 6d e (session:param
74b0: 2d 3e 73 74 72 69 6e 67 20 70 61 72 61 6d 73 29 ->string params)
74c0: 0a 20 20 3b 3b 20 28 65 72 72 3a 6c 6f 67 20 22 . ;; (err:log "
74d0: 70 61 72 61 6d 73 3d 22 20 70 61 72 61 6d 73 29 params=" params)
74e0: 0a 20 20 28 69 66 20 28 3c 20 28 6c 65 6e 67 74 . (if (< (lengt
74f0: 68 20 70 61 72 61 6d 73 29 20 31 29 0a 20 20 20 h params) 1).
7500: 20 20 20 22 22 0a 20 20 20 20 20 20 28 6c 65 74 "". (let
7510: 20 6c 6f 6f 70 20 28 28 6b 65 79 20 28 63 61 72 loop ((key (car
7520: 20 70 61 72 61 6d 73 29 29 0a 09 09 20 28 76 61 params))... (va
7530: 6c 20 28 63 61 64 72 20 70 61 72 61 6d 73 29 29 l (cadr params))
7540: 0a 09 09 20 28 74 61 69 6c 20 28 63 64 64 72 20 ... (tail (cddr
7550: 70 61 72 61 6d 73 29 29 0a 09 09 20 28 72 65 73 params))... (res
7560: 75 6c 74 20 27 28 29 29 29 0a 09 28 6c 65 74 20 ult '()))..(let
7570: 28 28 6e 65 77 72 65 73 75 6c 74 20 28 63 6f 6e ((newresult (con
7580: 73 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 s (string-append
7590: 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 (s:any->string
75a0: 6b 65 79 29 20 22 3d 22 20 28 73 3a 61 6e 79 2d key) "=" (s:any-
75b0: 3e 73 74 72 69 6e 67 20 76 61 6c 29 29 0a 09 09 >string val))...
75c0: 09 20 20 20 20 20 20 20 72 65 73 75 6c 74 29 29 . result))
75d0: 29 0a 09 20 20 28 69 66 20 28 3c 20 28 6c 65 6e ).. (if (< (len
75e0: 67 74 68 20 74 61 69 6c 29 20 31 29 20 3b 3b 20 gth tail) 1) ;;
75f0: 74 72 75 65 20 69 66 20 64 6f 6e 65 0a 09 20 20 true if done..
7600: 20 20 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 (string-inte
7610: 72 73 70 65 72 73 65 20 6e 65 77 72 65 73 75 6c rsperse newresul
7620: 74 20 22 26 22 29 0a 09 20 20 20 20 20 20 28 6c t "&").. (l
7630: 6f 6f 70 20 28 63 61 72 20 74 61 69 6c 29 28 63 oop (car tail)(c
7640: 61 64 72 20 74 61 69 6c 29 28 63 64 64 72 20 74 adr tail)(cddr t
7650: 61 69 6c 29 20 6e 65 77 72 65 73 75 6c 74 29 29 ail) newresult))
7660: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 ))))..(define (s
7670: 65 73 73 69 6f 6e 3a 6c 69 6e 6b 2d 74 6f 20 73 ession:link-to s
7680: 65 6c 66 20 70 61 67 65 20 70 61 72 61 6d 73 29 elf page params)
7690: 0a 20 20 28 6c 65 74 2a 20 28 28 73 65 72 76 65 . (let* ((serve
76a0: 72 20 20 20 20 28 69 66 20 28 67 65 74 2d 65 6e r (if (get-en
76b0: 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 vironment-variab
76c0: 6c 65 20 22 48 54 54 50 5f 48 4f 53 54 22 29 0a le "HTTP_HOST").
76d0: 09 09 09 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d ...(get-environm
76e0: 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 48 54 ent-variable "HT
76f0: 54 50 5f 48 4f 53 54 22 29 0a 09 09 09 28 67 65 TP_HOST")....(ge
7700: 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 t-environment-va
7710: 72 69 61 62 6c 65 20 22 53 45 52 56 45 52 5f 4e riable "SERVER_N
7720: 41 4d 45 22 29 29 29 0a 20 20 20 20 20 20 20 20 AME"))).
7730: 20 28 66 6f 72 63 65 2d 73 63 72 69 70 74 20 20 (force-script
7740: 28 73 64 61 74 2d 67 65 74 2d 73 63 72 69 70 74 (sdat-get-script
7750: 20 73 65 6c 66 29 29 0a 09 20 28 73 63 72 69 70 self)).. (scrip
7760: 74 20 28 6f 72 20 66 6f 72 63 65 2d 73 63 72 69 t (or force-scri
7770: 70 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 pt.
7780: 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 73 (let ((s
7790: 63 72 69 70 74 2d 6e 61 6d 65 20 28 73 74 72 69 cript-name (stri
77a0: 6e 67 2d 73 70 6c 69 74 20 28 67 65 74 2d 65 6e ng-split (get-en
77b0: 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 vironment-variab
77c0: 6c 65 20 22 53 43 52 49 50 54 5f 4e 41 4d 45 22 le "SCRIPT_NAME"
77d0: 29 20 22 2f 22 29 29 29 0a 20 20 20 20 20 20 20 ) "/"))).
77e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
77f0: 28 69 66 20 28 3e 20 28 6c 65 6e 67 74 68 20 73 (if (> (length s
7800: 63 72 69 70 74 2d 6e 61 6d 65 29 20 31 29 0a 20 cript-name) 1).
7810: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7820: 20 20 20 20 20 20 20 20 20 20 28 73 74 72 69 6e (strin
7830: 67 2d 61 70 70 65 6e 64 20 28 63 61 72 20 73 63 g-append (car sc
7840: 72 69 70 74 2d 6e 61 6d 65 29 20 22 2f 22 20 28 ript-name) "/" (
7850: 63 61 64 72 20 73 63 72 69 70 74 2d 6e 61 6d 65 cadr script-name
7860: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
7870: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 67 (g
7880: 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 et-environment-v
7890: 61 72 69 61 62 6c 65 20 22 53 43 52 49 50 54 5f ariable "SCRIPT_
78a0: 4e 41 4d 45 22 29 29 29 29 29 20 3b 3b 20 62 75 NAME"))))) ;; bu
78b0: 69 6c 64 20 73 63 72 69 70 74 20 6e 61 6d 65 20 ild script name
78c0: 66 72 6f 6d 20 66 69 72 73 74 20 74 77 6f 20 65 from first two e
78d0: 6c 65 6d 65 6e 74 73 2e 20 54 68 69 73 20 69 73 lements. This is
78e0: 20 61 20 68 61 6e 67 6f 76 65 72 20 66 72 6f 6d a hangover from
78f0: 20 62 65 66 6f 72 65 20 49 20 75 73 65 64 20 3f before I used ?
7900: 20 69 6e 20 74 68 65 20 55 52 4c 2e 29 0a 20 20 in the URL.).
7910: 20 20 20 20 20 20 20 28 73 65 73 73 69 6f 6e 2d (session-
7920: 6b 65 79 20 28 73 64 61 74 2d 67 65 74 2d 73 65 key (sdat-get-se
7930: 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 29 ssion-key self))
7940: 0a 09 20 28 70 61 72 61 6d 73 74 72 20 28 73 65 .. (paramstr (se
7950: 73 73 69 6f 6e 3a 70 61 72 61 6d 2d 3e 73 74 72 ssion:param->str
7960: 69 6e 67 20 70 61 72 61 6d 73 29 29 29 0a 20 20 ing params))).
7970: 20 20 3b 3b 20 28 73 65 73 73 69 6f 6e 3a 6c 6f ;; (session:lo
7980: 67 20 73 65 6c 66 20 22 73 65 72 76 65 72 3d 22 g self "server="
7990: 20 73 65 72 76 65 72 20 22 20 73 63 72 69 70 74 server " script
79a0: 3d 22 20 73 63 72 69 70 74 20 22 20 70 61 67 65 =" script " page
79b0: 3d 22 20 70 61 67 65 29 0a 20 20 20 20 28 73 74 =" page). (st
79c0: 72 69 6e 67 2d 61 70 70 65 6e 64 20 22 68 74 74 ring-append "htt
79d0: 70 3a 2f 2f 22 20 73 65 72 76 65 72 20 22 2f 22 p://" server "/"
79e0: 20 73 63 72 69 70 74 20 22 2f 22 20 70 61 67 65 script "/" page
79f0: 20 22 3f 22 20 70 61 72 61 6d 73 74 72 29 29 29 "?" paramstr)))
7a00: 20 3b 3b 20 22 2f 73 6e 3d 22 20 73 65 73 73 69 ;; "/sn=" sessi
7a10: 6f 6e 2d 6b 65 79 29 29 29 0a 0a 28 64 65 66 69 on-key)))..(defi
7a20: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 63 67 69 2d ne (session:cgi-
7a30: 6f 75 74 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 out self). (let
7a40: 2a 20 28 28 63 6f 6e 74 65 6e 74 20 20 28 6c 69 * ((content (li
7a50: 73 74 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e st (sdat-get-con
7a60: 74 65 6e 74 2d 74 79 70 65 20 73 65 6c 66 29 29 tent-type self))
7a70: 29 20 3b 3b 20 27 28 22 43 6f 6e 74 65 6e 74 2d ) ;; '("Content-
7a80: 74 79 70 65 3a 20 74 65 78 74 2f 68 74 6d 6c 3b type: text/html;
7a90: 20 63 68 61 72 73 65 74 3d 69 73 6f 2d 38 38 35 charset=iso-885
7aa0: 39 2d 31 5c 6e 5c 6e 22 29 29 0a 09 20 28 68 65 9-1\n\n")).. (he
7ab0: 61 64 65 72 20 20 20 28 6c 65 74 20 28 28 63 6f ader (let ((co
7ac0: 6f 6b 69 65 20 28 73 64 61 74 2d 67 65 74 2d 73 okie (sdat-get-s
7ad0: 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 20 73 65 ession-cookie se
7ae0: 6c 66 29 29 29 0a 09 09 20 20 20 20 20 28 69 66 lf)))... (if
7af0: 20 63 6f 6f 6b 69 65 0a 09 09 09 20 28 63 6f 6e cookie.... (con
7b00: 73 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 s (string-append
7b10: 20 22 53 65 74 2d 43 6f 6f 6b 69 65 3a 20 22 20 "Set-Cookie: "
7b20: 28 63 61 72 20 63 6f 6f 6b 69 65 29 29 0a 09 09 (car cookie))...
7b30: 09 20 20 20 20 20 20 20 63 6f 6e 74 65 6e 74 29 . content)
7b40: 0a 09 09 09 20 63 6f 6e 74 65 6e 74 29 29 29 0a .... content))).
7b50: 09 20 28 70 61 67 65 64 61 74 20 20 28 73 64 61 . (pagedat (sda
7b60: 74 2d 67 65 74 2d 70 61 67 65 64 61 74 20 73 65 t-get-pagedat se
7b70: 6c 66 29 29 29 0a 20 20 20 20 28 73 3a 63 67 69 lf))). (s:cgi
7b80: 2d 6f 75 74 20 0a 20 20 20 20 20 28 63 6f 6e 73 -out . (cons
7b90: 20 68 65 61 64 65 72 20 70 61 67 65 64 61 74 29 header pagedat)
7ba0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 )))..(define (se
7bb0: 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 2e ssion:log self .
7bc0: 20 6d 73 67 29 0a 20 20 28 77 69 74 68 2d 6f 75 msg). (with-ou
7bd0: 74 70 75 74 2d 74 6f 2d 70 6f 72 74 20 28 73 64 tput-to-port (sd
7be0: 61 74 2d 67 65 74 2d 6c 6f 67 2d 70 6f 72 74 20 at-get-log-port
7bf0: 73 65 6c 66 29 20 3b 3b 20 28 73 64 61 74 2d 67 self) ;; (sdat-g
7c00: 65 74 2d 6c 6f 67 70 74 20 73 65 6c 66 29 0a 20 et-logpt self).
7c10: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 20 0a 20 (lambda () .
7c20: 20 20 20 20 20 28 61 70 70 6c 79 20 70 72 69 6e (apply prin
7c30: 74 20 6d 73 67 29 29 29 29 0a 0a 3b 3b 20 65 73 t msg))))..;; es
7c40: 63 61 70 65 2c 20 63 6f 6e 76 65 72 74 20 6f 72 cape, convert or
7c50: 20 72 65 74 75 72 6e 20 72 61 77 20 77 68 65 6e return raw when
7c60: 20 67 69 76 65 6e 20 75 73 65 72 20 69 6e 70 75 given user inpu
7c70: 74 20 64 61 74 61 20 74 68 61 74 20 70 6f 74 65 t data that pote
7c80: 6e 74 69 61 6c 6c 79 0a 3b 3b 20 63 6f 75 6c 64 ntially.;; could
7c90: 20 62 65 20 6d 61 6c 69 63 69 6f 75 73 0a 3b 3b be malicious.;;
7ca0: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
7cb0: 6e 3a 61 70 70 6c 79 2d 74 79 70 65 2d 70 72 65 n:apply-type-pre
7cc0: 66 65 72 65 6e 63 65 20 72 65 73 20 70 61 72 61 ference res para
7cd0: 6d 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 74 ms). (let* ((dt
7ce0: 79 70 65 20 20 20 20 28 69 66 20 28 6e 75 6c 6c ype (if (null
7cf0: 3f 20 70 61 72 61 6d 73 29 0a 09 09 20 20 20 20 ? params)...
7d00: 20 20 20 27 65 73 63 61 70 65 64 0a 09 09 20 20 'escaped...
7d10: 20 20 20 20 20 28 63 61 72 20 70 61 72 61 6d 73 (car params
7d20: 29 29 29 0a 09 20 28 74 61 67 73 20 20 20 20 28 ))).. (tags (
7d30: 69 66 20 28 6e 75 6c 6c 3f 20 70 61 72 61 6d 73 if (null? params
7d40: 29 0a 09 09 20 20 20 20 20 20 27 28 29 0a 09 09 )... '()...
7d50: 20 20 20 20 20 20 28 63 64 72 20 70 61 72 61 6d (cdr param
7d60: 73 29 29 29 29 0a 20 20 20 20 28 63 61 73 65 20 s)))). (case
7d70: 64 74 79 70 65 0a 20 20 20 20 20 20 28 28 72 61 dtype. ((ra
7d80: 77 29 20 20 20 20 20 72 65 73 29 0a 20 20 20 20 w) res).
7d90: 20 20 28 28 6e 75 6d 62 65 72 29 20 20 28 69 66 ((number) (if
7da0: 20 28 73 74 72 69 6e 67 3f 20 72 65 73 29 28 73 (string? res)(s
7db0: 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 72 65 tring->number re
7dc0: 73 29 20 23 66 29 29 0a 20 20 20 20 20 20 28 28 s) #f)). ((
7dd0: 65 73 63 61 70 65 64 29 20 28 69 66 20 28 73 74 escaped) (if (st
7de0: 72 69 6e 67 3f 20 72 65 73 29 0a 09 09 20 20 20 ring? res)...
7df0: 20 20 28 73 3a 68 74 6d 6c 2d 66 69 6c 74 65 72 (s:html-filter
7e00: 2d 3e 73 74 72 69 6e 67 20 72 65 73 20 74 61 67 ->string res tag
7e10: 73 29 0a 09 09 20 20 20 20 20 72 65 73 29 29 0a s)... res)).
7e20: 20 20 20 20 20 20 28 28 65 73 63 61 70 65 64 2d ((escaped-
7e30: 6e 6c 29 20 28 69 66 20 28 73 74 72 69 6e 67 3f nl) (if (string?
7e40: 20 72 65 73 29 20 3b 3b 20 65 73 63 61 70 65 20 res) ;; escape
7e50: 5c 6e 20 61 6e 64 20 5c 72 0a 09 09 09 28 73 74 \n and \r....(st
7e60: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
7e70: 0a 09 09 09 20 28 73 74 72 69 6e 67 2d 73 70 6c .... (string-spl
7e80: 69 74 0a 09 09 09 20 20 28 73 74 72 69 6e 67 2d it.... (string-
7e90: 69 6e 74 65 72 73 70 65 72 73 65 0a 09 09 09 20 intersperse....
7ea0: 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 (string-split
7eb0: 28 73 3a 68 74 6d 6c 2d 66 69 6c 74 65 72 2d 3e (s:html-filter->
7ec0: 73 74 72 69 6e 67 20 72 65 73 20 74 61 67 73 29 string res tags)
7ed0: 20 22 5c 6e 22 29 0a 09 09 09 20 20 20 22 5c 5c "\n").... "\\
7ee0: 6e 22 29 0a 09 09 09 20 20 22 5c 72 22 29 0a 09 n").... "\r")..
7ef0: 09 09 20 22 5c 5c 72 22 29 0a 09 09 09 72 65 73 .. "\\r")....res
7f00: 29 29 20 3b 3b 20 73 68 6f 75 6c 64 20 72 65 74 )) ;; should ret
7f10: 75 72 6e 20 23 66 20 69 66 20 6e 6f 74 20 61 20 urn #f if not a
7f20: 73 74 72 69 6e 67 20 61 6e 64 20 63 61 6e 27 74 string and can't
7f30: 20 65 73 63 61 70 65 20 69 74 3f 0a 20 20 20 20 escape it?.
7f40: 20 20 28 65 6c 73 65 20 20 20 20 20 20 28 69 66 (else (if
7f50: 20 28 73 74 72 69 6e 67 3f 20 72 65 73 29 0a 09 (string? res)..
7f60: 09 20 20 20 20 20 28 73 3a 68 74 6d 6c 2d 66 69 . (s:html-fi
7f70: 6c 74 65 72 2d 3e 73 74 72 69 6e 67 20 72 65 73 lter->string res
7f80: 20 27 28 29 29 0a 09 09 20 20 20 20 20 72 65 73 '())... res
7f90: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define (
7fa0: 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 72 61 session:get-para
7fb0: 6d 20 73 65 6c 66 20 6b 65 79 20 74 79 70 65 2d m self key type-
7fc0: 70 61 72 61 6d 73 29 0a 20 20 3b 3b 20 28 73 65 params). ;; (se
7fd0: 73 73 69 6f 6e 3a 6c 6f 67 20 73 3a 73 65 73 73 ssion:log s:sess
7fe0: 69 6f 6e 20 22 70 61 72 61 6d 73 3d 22 20 28 73 ion "params=" (s
7ff0: 6c 6f 74 2d 72 65 66 20 73 3a 73 65 73 73 69 6f lot-ref s:sessio
8000: 6e 20 27 70 61 72 61 6d 73 29 29 0a 20 20 28 6c n 'params)). (l
8010: 65 74 2a 20 28 28 70 61 72 61 6d 73 20 28 73 64 et* ((params (sd
8020: 61 74 2d 67 65 74 2d 70 61 72 61 6d 73 20 73 65 at-get-params se
8030: 6c 66 29 29 0a 09 20 28 72 65 73 20 20 20 20 28 lf)).. (res (
8040: 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 72 61 session:get-para
8050: 6d 2d 66 72 6f 6d 20 70 61 72 61 6d 73 20 6b 65 m-from params ke
8060: 79 29 29 29 0a 20 20 20 20 28 73 65 73 73 69 6f y))). (sessio
8070: 6e 3a 61 70 70 6c 79 2d 74 79 70 65 2d 70 72 65 n:apply-type-pre
8080: 66 65 72 65 6e 63 65 20 72 65 73 20 74 79 70 65 ference res type
8090: 2d 70 61 72 61 6d 73 29 29 29 0a 0a 3b 3b 20 54 -params)))..;; T
80a0: 68 69 73 20 6f 6e 65 20 77 69 6c 6c 20 67 65 74 his one will get
80b0: 20 74 68 65 20 66 69 72 73 74 20 76 61 6c 75 65 the first value
80c0: 20 66 6f 75 6e 64 20 72 65 67 61 72 64 6c 65 73 found regardles
80d0: 73 20 6f 66 20 66 6f 72 6d 0a 3b 3b 20 70 61 72 s of form.;; par
80e0: 61 6d 3a 20 28 64 74 79 70 65 20 5b 74 61 67 31 am: (dtype [tag1
80f0: 20 74 61 67 32 20 2e 2e 2e 5d 29 0a 3b 3b 20 64 tag2 ...]).;; d
8100: 74 79 70 65 3a 0a 3b 3b 20 20 20 20 27 72 61 77 type:.;; 'raw
8110: 20 20 20 20 20 3a 20 64 6f 20 6e 6f 20 63 6f 6e : do no con
8120: 76 65 72 73 69 6f 6e 0a 3b 3b 20 20 20 20 27 6e version.;; 'n
8130: 75 6d 62 65 72 20 20 3a 20 63 6f 6e 76 65 72 74 umber : convert
8140: 20 74 6f 20 6e 75 6d 62 65 72 2c 20 72 65 74 75 to number, retu
8150: 72 6e 20 23 66 20 69 66 20 66 61 69 6c 73 0a 3b rn #f if fails.;
8160: 3b 20 20 20 20 27 65 73 63 61 70 65 64 20 3a 20 ; 'escaped :
8170: 75 73 65 20 68 74 6d 6c 2d 65 73 63 61 70 65 20 use html-escape
8180: 74 6f 20 70 72 6f 74 65 63 74 20 74 68 65 20 69 to protect the i
8190: 6e 70 75 74 20 2d 2d 20 74 68 69 73 20 69 73 20 nput -- this is
81a0: 74 68 65 20 64 65 66 61 75 6c 74 0a 3b 3b 0a 28 the default.;;.(
81b0: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
81c0: 67 65 74 2d 69 6e 70 75 74 20 73 65 6c 66 20 6b get-input self k
81d0: 65 79 20 70 61 72 61 6d 73 29 0a 20 20 28 6c 65 ey params). (le
81e0: 74 2a 20 28 28 64 74 79 70 65 20 20 20 20 28 69 t* ((dtype (i
81f0: 66 20 28 6e 75 6c 6c 3f 20 70 61 72 61 6d 73 29 f (null? params)
8200: 0a 09 09 20 20 20 20 20 20 20 27 65 73 63 61 70 ... 'escap
8210: 65 64 0a 09 09 20 20 20 20 20 20 20 28 63 61 72 ed... (car
8220: 20 70 61 72 61 6d 73 29 29 29 0a 09 20 28 74 61 params))).. (ta
8230: 67 73 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f gs (if (null?
8240: 20 70 61 72 61 6d 73 29 0a 09 09 20 20 20 20 20 params)...
8250: 20 27 28 29 0a 09 09 20 20 20 20 20 20 28 63 64 '()... (cd
8260: 72 20 70 61 72 61 6d 73 29 29 29 0a 09 20 28 66 r params))).. (f
8270: 6f 72 6d 64 61 74 20 28 73 64 61 74 2d 67 65 74 ormdat (sdat-get
8280: 2d 66 6f 72 6d 64 61 74 20 73 65 6c 66 29 29 0a -formdat self)).
8290: 09 20 28 72 65 73 20 20 20 20 20 28 69 66 20 28 . (res (if (
82a0: 6e 6f 74 20 66 6f 72 6d 64 61 74 29 20 23 66 0a not formdat) #f.
82b0: 09 09 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 .. (if (or
82c0: 28 73 74 72 69 6e 67 3f 20 6b 65 79 29 28 6e 75 (string? key)(nu
82d0: 6d 62 65 72 3f 20 6b 65 79 29 28 73 79 6d 62 6f mber? key)(symbo
82e0: 6c 3f 20 6b 65 79 29 29 0a 09 09 09 20 20 28 69 l? key)).... (i
82f0: 66 20 28 61 6e 64 20 28 76 65 63 74 6f 72 3f 20 f (and (vector?
8300: 66 6f 72 6d 64 61 74 29 28 65 71 3f 20 28 76 65 formdat)(eq? (ve
8310: 63 74 6f 72 2d 6c 65 6e 67 74 68 20 66 6f 72 6d ctor-length form
8320: 64 61 74 29 20 31 29 28 68 61 73 68 2d 74 61 62 dat) 1)(hash-tab
8330: 6c 65 3f 20 28 76 65 63 74 6f 72 2d 72 65 66 20 le? (vector-ref
8340: 66 6f 72 6d 64 61 74 20 30 29 29 29 0a 09 09 09 formdat 0)))....
8350: 20 20 20 20 20 20 28 66 6f 72 6d 64 61 74 3a 67 (formdat:g
8360: 65 74 20 66 6f 72 6d 64 61 74 20 6b 65 79 29 0a et formdat key).
8370: 09 09 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a ... (begin.
8380: 09 09 09 09 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 ....(session:log
8390: 20 73 65 6c 66 20 22 45 52 52 4f 52 3a 20 66 6f self "ERROR: fo
83a0: 72 6d 64 61 74 3a 20 22 20 66 6f 72 6d 64 61 74 rmdat: " formdat
83b0: 20 22 20 69 73 20 6e 6f 74 20 6f 66 20 63 6c 61 " is not of cla
83c0: 73 73 20 3c 66 6f 72 6d 64 61 74 3e 22 29 0a 09 ss <formdat>")..
83d0: 09 09 09 23 66 29 29 0a 09 09 09 20 20 28 62 65 ...#f)).... (be
83e0: 67 69 6e 0a 09 09 09 20 20 20 20 28 73 65 73 73 gin.... (sess
83f0: 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 45 52 ion:log self "ER
8400: 52 4f 52 3a 20 62 61 64 20 6b 65 79 20 22 20 6b ROR: bad key " k
8410: 65 79 29 0a 09 09 09 20 20 20 20 23 66 29 29 29 ey).... #f)))
8420: 29 29 0a 20 20 20 20 28 63 61 73 65 20 64 74 79 )). (case dty
8430: 70 65 0a 20 20 20 20 20 20 28 28 72 61 77 29 20 pe. ((raw)
8440: 20 20 20 20 72 65 73 29 0a 20 20 20 20 20 20 28 res). (
8450: 28 6e 75 6d 62 65 72 29 20 20 28 69 66 20 28 73 (number) (if (s
8460: 74 72 69 6e 67 3f 20 72 65 73 29 28 73 74 72 69 tring? res)(stri
8470: 6e 67 2d 3e 6e 75 6d 62 65 72 20 72 65 73 29 20 ng->number res)
8480: 23 66 29 29 0a 20 20 20 20 20 20 28 28 65 73 63 #f)). ((esc
8490: 61 70 65 64 29 20 28 69 66 20 28 73 74 72 69 6e aped) (if (strin
84a0: 67 3f 20 72 65 73 29 0a 09 09 20 20 20 20 20 28 g? res)... (
84b0: 73 3a 68 74 6d 6c 2d 66 69 6c 74 65 72 2d 3e 73 s:html-filter->s
84c0: 74 72 69 6e 67 20 72 65 73 20 74 61 67 73 29 0a tring res tags).
84d0: 09 09 20 20 20 20 20 72 65 73 29 29 0a 20 20 20 .. res)).
84e0: 20 20 20 28 65 6c 73 65 20 20 20 20 20 20 28 69 (else (i
84f0: 66 20 28 73 74 72 69 6e 67 3f 20 72 65 73 29 0a f (string? res).
8500: 09 09 20 20 20 20 20 28 73 3a 68 74 6d 6c 2d 66 .. (s:html-f
8510: 69 6c 74 65 72 2d 3e 73 74 72 69 6e 67 20 72 65 ilter->string re
8520: 73 20 27 28 29 29 0a 09 09 20 20 20 20 20 72 65 s '())... re
8530: 73 29 29 29 29 29 0a 0a 3b 3b 20 54 68 69 73 20 s)))))..;; This
8540: 6f 6e 65 20 77 69 6c 6c 20 67 65 74 20 74 68 65 one will get the
8550: 20 66 69 72 73 74 20 76 61 6c 75 65 20 66 6f 75 first value fou
8560: 6e 64 20 72 65 67 61 72 64 6c 65 73 73 20 6f 66 nd regardless of
8570: 20 66 6f 72 6d 0a 28 64 65 66 69 6e 65 20 28 73 form.(define (s
8580: 65 73 73 69 6f 6e 3a 67 65 74 2d 69 6e 70 75 74 ession:get-input
8590: 2d 6b 65 79 73 20 73 65 6c 66 29 0a 20 20 28 6c -keys self). (l
85a0: 65 74 2a 20 28 28 66 6f 72 6d 64 61 74 20 28 73 et* ((formdat (s
85b0: 64 61 74 2d 67 65 74 2d 66 6f 72 6d 64 61 74 20 dat-get-formdat
85c0: 73 65 6c 66 29 29 29 0a 20 20 20 20 28 69 66 20 self))). (if
85d0: 28 6e 6f 74 20 66 6f 72 6d 64 61 74 29 20 23 66 (not formdat) #f
85e0: 0a 09 28 69 66 20 28 61 6e 64 20 28 76 65 63 74 ..(if (and (vect
85f0: 6f 72 3f 20 66 6f 72 6d 64 61 74 29 28 65 71 3f or? formdat)(eq?
8600: 20 28 76 65 63 74 6f 72 2d 6c 65 6e 67 74 68 20 (vector-length
8610: 66 6f 72 6d 64 61 74 29 20 31 29 28 68 61 73 68 formdat) 1)(hash
8620: 2d 74 61 62 6c 65 3f 20 28 76 65 63 74 6f 72 2d -table? (vector-
8630: 72 65 66 20 66 6f 72 6d 64 61 74 20 30 29 29 29 ref formdat 0)))
8640: 0a 09 20 20 20 20 28 66 6f 72 6d 64 61 74 3a 6b .. (formdat:k
8650: 65 79 73 20 66 6f 72 6d 64 61 74 29 0a 09 20 20 eys formdat)..
8660: 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 (begin..
8670: 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c (session:log sel
8680: 66 20 22 45 52 52 4f 52 3a 20 66 6f 72 6d 64 61 f "ERROR: formda
8690: 74 3a 20 22 20 66 6f 72 6d 64 61 74 20 22 20 69 t: " formdat " i
86a0: 73 20 6e 6f 74 20 6f 66 20 63 6c 61 73 73 20 3c s not of class <
86b0: 66 6f 72 6d 64 61 74 3e 22 29 0a 09 20 20 20 20 formdat>")..
86c0: 20 20 23 66 29 29 29 29 29 0a 0a 28 64 65 66 69 #f)))))..(defi
86d0: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 72 75 6e 2d ne (session:run-
86e0: 61 63 74 69 6f 6e 73 20 73 65 6c 66 29 0a 20 20 actions self).
86f0: 28 6c 65 74 2a 20 28 28 61 63 74 69 6f 6e 20 20 (let* ((action
8700: 20 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 (session:get-p
8710: 61 72 61 6d 20 73 65 6c 66 20 27 61 63 74 69 6f aram self 'actio
8720: 6e 20 27 28 72 61 77 29 29 29 0a 09 20 28 70 61 n '(raw))).. (pa
8730: 67 65 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 ge (sdat-ge
8740: 74 2d 70 61 67 65 20 73 65 6c 66 29 29 29 0a 20 t-page self))).
8750: 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 61 63 ;; (print "ac
8760: 74 69 6f 6e 3d 22 20 61 63 74 69 6f 6e 20 22 20 tion=" action "
8770: 70 61 67 65 3d 22 20 70 61 67 65 29 0a 20 20 20 page=" page).
8780: 20 28 69 66 20 61 63 74 69 6f 6e 0a 09 28 6c 65 (if action..(le
8790: 74 20 28 28 61 63 74 69 6f 6e 2d 6c 73 74 20 20 t ((action-lst
87a0: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 61 63 (string-split ac
87b0: 74 69 6f 6e 20 22 2e 22 29 29 29 0a 09 20 20 3b tion "."))).. ;
87c0: 3b 20 28 70 72 69 6e 74 20 22 61 63 74 69 6f 6e ; (print "action
87d0: 2d 6c 73 74 3d 22 20 61 63 74 69 6f 6e 2d 6c 73 -lst=" action-ls
87e0: 74 29 0a 09 20 20 28 69 66 20 28 6e 6f 74 20 28 t).. (if (not (
87f0: 3d 20 28 6c 65 6e 67 74 68 20 61 63 74 69 6f 6e = (length action
8800: 2d 6c 73 74 29 20 32 29 29 20 0a 09 20 20 20 20 -lst) 2)) ..
8810: 20 20 28 65 72 72 3a 6c 6f 67 20 22 41 63 74 69 (err:log "Acti
8820: 6f 6e 20 73 68 6f 75 6c 64 20 62 65 20 6f 66 20 on should be of
8830: 66 6f 72 6d 3a 20 6d 6f 64 75 6c 65 2e 61 63 74 form: module.act
8840: 69 6f 6e 22 29 0a 09 20 20 20 20 20 20 28 6c 65 ion").. (le
8850: 74 2a 20 28 28 74 61 72 67 2d 70 61 67 65 20 20 t* ((targ-page
8860: 20 28 63 61 72 20 61 63 74 69 6f 6e 2d 6c 73 74 (car action-lst
8870: 29 29 0a 09 09 20 20 20 20 20 28 70 72 6f 63 2d ))... (proc-
8880: 6e 61 6d 65 20 20 20 28 73 74 72 69 6e 67 2d 61 name (string-a
8890: 70 70 65 6e 64 20 74 61 72 67 2d 70 61 67 65 20 ppend targ-page
88a0: 22 2d 61 63 74 69 6f 6e 22 29 29 0a 09 09 20 20 "-action"))...
88b0: 20 20 20 28 74 61 72 67 2d 61 63 74 69 6f 6e 20 (targ-action
88c0: 28 63 61 64 72 20 61 63 74 69 6f 6e 2d 6c 73 74 (cadr action-lst
88d0: 29 29 29 0a 09 09 3b 3b 20 28 65 72 72 3a 6c 6f )))...;; (err:lo
88e0: 67 20 22 74 61 72 67 2d 70 61 67 65 3d 22 20 74 g "targ-page=" t
88f0: 61 72 67 2d 70 61 67 65 20 22 20 70 72 6f 63 2d arg-page " proc-
8900: 6e 61 6d 65 3d 22 20 70 72 6f 63 2d 6e 61 6d 65 name=" proc-name
8910: 20 22 20 74 61 72 67 2d 61 63 74 69 6f 6e 3d 22 " targ-action="
8920: 20 74 61 72 67 2d 61 63 74 69 6f 6e 29 0a 0a 09 targ-action)...
8930: 09 3b 3b 20 63 61 6c 6c 20 68 65 72 65 20 6f 6e .;; call here on
8940: 6c 79 20 69 66 20 6e 65 76 65 72 20 63 61 6c 6c ly if never call
8950: 65 64 20 62 65 66 6f 72 65 0a 09 09 28 69 66 20 ed before...(if
8960: 28 73 65 73 73 69 6f 6e 3a 6e 65 76 65 72 2d 63 (session:never-c
8970: 61 6c 6c 65 64 2d 70 61 67 65 3f 20 73 65 6c 66 alled-page? self
8980: 20 74 61 72 67 2d 70 61 67 65 29 0a 09 09 20 20 targ-page)...
8990: 20 20 28 73 65 73 73 69 6f 6e 3a 63 61 6c 6c 2d (session:call-
89a0: 70 61 72 74 73 20 73 65 6c 66 20 74 61 72 67 2d parts self targ-
89b0: 70 61 67 65 20 27 63 6f 6e 74 72 6f 6c 29 29 0a page 'control)).
89c0: 09 09 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 ..;;
89d0: 20 20 20 20 20 20 20 20 70 72 6f 63 20 20 20 20 proc
89e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
89f0: 20 20 20 20 20 61 63 74 69 6f 6e 20 20 20 20 0a action .
8a00: 0a 09 09 28 69 66 20 23 74 20 3b 3b 20 73 65 74 ...(if #t ;; set
8a10: 20 74 6f 20 23 74 20 74 6f 20 73 65 65 20 62 65 to #t to see be
8a20: 74 74 65 72 20 65 72 72 6f 72 20 6d 65 73 73 61 tter error messa
8a30: 67 65 73 20 64 75 72 69 6e 67 20 64 65 62 75 67 ges during debug
8a40: 67 69 6e 20 3a 2d 29 0a 09 09 20 20 20 20 28 28 gin :-)... ((
8a50: 65 76 61 6c 20 28 73 74 72 69 6e 67 2d 3e 73 79 eval (string->sy
8a60: 6d 62 6f 6c 20 70 72 6f 63 2d 6e 61 6d 65 29 29 mbol proc-name))
8a70: 20 74 61 72 67 2d 61 63 74 69 6f 6e 29 20 3b 3b targ-action) ;;
8a80: 20 75 6e 73 61 66 65 20 65 78 65 63 75 74 69 6f unsafe executio
8a90: 6e 0a 09 09 20 20 20 20 28 63 6f 6e 64 69 74 69 n... (conditi
8aa0: 6f 6e 2d 63 61 73 65 20 28 28 65 76 61 6c 20 28 on-case ((eval (
8ab0: 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 70 string->symbol p
8ac0: 72 6f 63 2d 6e 61 6d 65 29 29 20 74 61 72 67 2d roc-name)) targ-
8ad0: 61 63 74 69 6f 6e 29 0a 09 09 09 09 20 20 20 20 action).....
8ae0: 28 28 65 78 6e 20 66 69 6c 65 29 20 28 73 3a 6c ((exn file) (s:l
8af0: 6f 67 20 22 66 69 6c 65 20 65 72 72 6f 72 22 29 og "file error")
8b00: 29 0a 09 09 09 09 20 20 20 20 28 28 65 78 6e 20 )..... ((exn
8b10: 69 2f 6f 29 20 20 28 73 3a 6c 6f 67 20 22 69 2f i/o) (s:log "i/
8b20: 6f 20 65 72 72 6f 72 22 29 29 0a 09 09 09 09 20 o error")).....
8b30: 20 20 20 28 28 65 78 6e 20 29 20 20 20 20 20 28 ((exn ) (
8b40: 73 3a 6c 6f 67 20 22 41 63 74 69 6f 6e 20 6e 6f s:log "Action no
8b50: 74 20 69 6d 70 6c 65 6d 65 6e 74 65 64 3a 20 22 t implemented: "
8b60: 20 70 72 6f 63 2d 6e 61 6d 65 20 22 20 61 63 74 proc-name " act
8b70: 69 6f 6e 3a 20 22 20 74 61 72 67 2d 61 63 74 69 ion: " targ-acti
8b80: 6f 6e 29 29 0a 09 09 09 09 20 20 20 20 28 76 61 on))..... (va
8b90: 72 20 28 29 20 20 20 20 20 28 73 3a 6c 6f 67 20 r () (s:log
8ba0: 22 55 6e 6b 6e 6f 77 6e 20 45 72 72 6f 72 22 29 "Unknown Error")
8bb0: 29 29 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 )))))))))..(defi
8bc0: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 6e 65 76 65 ne (session:neve
8bd0: 72 2d 63 61 6c 6c 65 64 2d 70 61 67 65 3f 20 73 r-called-page? s
8be0: 65 6c 66 20 70 61 67 65 29 0a 20 20 28 73 65 73 elf page). (ses
8bf0: 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 43 sion:log self "C
8c00: 68 65 63 6b 69 6e 67 20 66 6f 72 20 70 61 67 65 hecking for page
8c10: 3a 20 22 20 70 61 67 65 29 0a 20 20 28 6e 6f 74 : " page). (not
8c20: 20 28 6d 65 6d 62 65 72 20 70 61 67 65 20 28 73 (member page (s
8c30: 64 61 74 2d 67 65 74 2d 73 65 65 6e 2d 70 61 67 dat-get-seen-pag
8c40: 65 73 20 73 65 6c 66 29 29 29 29 0a 0a 28 64 65 es self))))..(de
8c50: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 65 fine (session:se
8c60: 74 2d 63 61 6c 6c 65 64 21 20 73 65 6c 66 20 70 t-called! self p
8c70: 61 67 65 29 0a 20 20 28 73 64 61 74 2d 73 65 74 age). (sdat-set
8c80: 2d 73 65 65 6e 2d 70 61 67 65 73 21 20 73 65 6c -seen-pages! sel
8c90: 66 20 28 63 6f 6e 73 20 70 61 67 65 20 28 73 64 f (cons page (sd
8ca0: 61 74 2d 67 65 74 2d 73 65 65 6e 2d 70 61 67 65 at-get-seen-page
8cb0: 73 20 73 65 6c 66 29 29 29 29 0a 0a 3b 3b 3d 3d s self))))..;;==
8cc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8cd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8ce0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8cf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8d00: 3d 3d 3d 3d 0a 3b 3b 20 41 6c 74 65 72 6e 61 74 ====.;; Alternat
8d10: 69 76 65 20 64 61 74 61 20 74 79 70 65 20 64 65 ive data type de
8d20: 6c 69 76 65 72 79 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d livery.;;=======
8d30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8d40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8d50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8d60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
8d70: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
8d80: 6e 3a 61 6c 74 2d 6f 75 74 20 73 65 6c 66 29 0a n:alt-out self).
8d90: 20 20 28 6c 65 74 20 28 28 64 61 74 20 28 73 64 (let ((dat (sd
8da0: 61 74 2d 67 65 74 2d 61 6c 74 2d 70 61 67 65 2d at-get-alt-page-
8db0: 64 61 74 20 73 65 6c 66 29 29 29 0a 20 20 20 20 dat self))).
8dc0: 3b 3b 20 28 73 3a 6c 6f 67 20 22 64 61 74 20 69 ;; (s:log "dat i
8dd0: 73 3a 20 22 20 64 61 74 29 0a 20 20 20 20 3b 3b s: " dat). ;;
8de0: 20 28 70 72 69 6e 74 20 22 48 54 54 50 2f 31 2e (print "HTTP/1.
8df0: 31 20 32 30 30 20 4f 4b 22 29 0a 20 20 20 20 28 1 200 OK"). (
8e00: 70 72 69 6e 74 20 22 44 61 74 65 3a 20 22 20 28 print "Date: " (
8e10: 74 69 6d 65 2d 3e 73 74 72 69 6e 67 20 28 73 65 time->string (se
8e20: 63 6f 6e 64 73 2d 3e 75 74 63 2d 74 69 6d 65 20 conds->utc-time
8e30: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
8e40: 29 29 29 29 0a 20 20 20 20 28 70 72 69 6e 74 20 )))). (print
8e50: 22 43 6f 6e 74 65 6e 74 2d 54 79 70 65 3a 20 22 "Content-Type: "
8e60: 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 74 65 (sdat-get-conte
8e70: 6e 74 2d 74 79 70 65 20 73 65 6c 66 29 29 0a 20 nt-type self)).
8e80: 20 20 20 28 70 72 69 6e 74 20 22 41 63 63 65 70 (print "Accep
8e90: 74 2d 52 61 6e 67 65 73 3a 20 62 79 74 65 73 22 t-Ranges: bytes"
8ea0: 29 0a 20 20 20 20 28 70 72 69 6e 74 20 22 43 6f ). (print "Co
8eb0: 6e 74 65 6e 74 2d 4c 65 6e 67 74 68 3a 20 22 20 ntent-Length: "
8ec0: 28 69 66 20 28 62 6c 6f 62 3f 20 64 61 74 29 0a (if (blob? dat).
8ed0: 09 09 09 09 20 20 28 62 6c 6f 62 2d 73 69 7a 65 .... (blob-size
8ee0: 20 64 61 74 29 0a 09 09 09 09 20 20 30 29 29 0a dat)..... 0)).
8ef0: 20 20 20 20 28 70 72 69 6e 74 20 22 4b 65 65 70 (print "Keep
8f00: 2d 41 6c 69 76 65 3a 20 74 69 6d 65 6f 75 74 3d -Alive: timeout=
8f10: 31 35 2c 20 6d 61 78 3d 31 30 30 22 29 0a 20 20 15, max=100").
8f20: 20 20 28 70 72 69 6e 74 20 22 43 6f 6e 6e 65 63 (print "Connec
8f30: 74 69 6f 6e 3a 20 4b 65 65 70 2d 41 6c 69 76 65 tion: Keep-Alive
8f40: 22 29 0a 20 20 20 20 28 70 72 69 6e 74 20 22 22 "). (print ""
8f50: 29 0a 20 20 20 20 28 77 72 69 74 65 2d 73 74 72 ). (write-str
8f60: 69 6e 67 20 28 62 6c 6f 62 2d 3e 73 74 72 69 6e ing (blob->strin
8f70: 67 20 64 61 74 29 20 23 66 20 28 63 75 72 72 65 g dat) #f (curre
8f80: 6e 74 2d 6f 75 74 70 75 74 2d 70 6f 72 74 29 29 nt-output-port))
8f90: 29 29 0a )).