Artifact
d4b9e2295659943305f912a6f4c97a813b7215d8:
0000: 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 30 ;; Copyright 200
0010: 37 2d 32 30 30 38 2c 20 4d 61 74 74 68 65 77 20 7-2008, 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 69 6e 63 6c 75 PURPOSE...(inclu
0150: 64 65 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 de "requirements
0160: 2e 73 63 6d 22 29 0a 0a 3b 3b 20 73 65 73 73 69 .scm")..;; sessi
0170: 6f 6e 73 20 74 61 62 6c 65 0a 3b 3b 20 69 64 20 ons table.;; id
0180: 73 65 73 73 69 6f 6e 5f 69 64 20 73 65 73 73 69 session_id sessi
0190: 6f 6e 5f 6b 65 79 0a 3b 3b 20 63 72 65 61 74 65 on_key.;; create
01a0: 20 74 61 62 6c 65 20 73 65 73 73 69 6f 6e 73 20 table sessions
01b0: 28 69 64 20 73 65 72 69 61 6c 20 6e 6f 74 20 6e (id serial not n
01c0: 75 6c 6c 2c 73 65 73 73 69 6f 6e 2d 6b 65 79 20 ull,session-key
01d0: 74 65 78 74 29 3b 0a 0a 3b 3b 20 73 65 73 73 69 text);..;; sessi
01e0: 6f 6e 5f 76 61 72 73 20 74 61 62 6c 65 0a 3b 3b on_vars table.;;
01f0: 20 69 64 20 73 65 73 73 69 6f 6e 5f 69 64 20 70 id session_id p
0200: 61 67 65 5f 69 64 20 6b 65 79 20 76 61 6c 75 65 age_id key value
0210: 0a 3b 3b 20 63 72 65 61 74 65 20 74 61 62 6c 65 .;; create table
0220: 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 28 69 session_vars (i
0230: 64 20 73 65 72 69 61 6c 20 6e 6f 74 20 6e 75 6c d serial not nul
0240: 6c 2c 73 65 73 73 69 6f 6e 5f 69 64 20 69 6e 74 l,session_id int
0250: 65 67 65 72 2c 70 61 67 65 20 74 65 78 74 2c 6b eger,page text,k
0260: 65 79 20 74 65 78 74 2c 76 61 6c 75 65 20 74 65 ey text,value te
0270: 78 74 29 3b 0a 0a 3b 3b 20 54 4f 44 4f 0a 3b 3b xt);..;; TODO.;;
0280: 20 20 43 6f 6e 63 65 70 74 20 6f 66 20 6f 72 64 Concept of ord
0290: 65 72 20 6e 75 6d 20 69 6e 63 72 65 6d 65 6e 74 er num increment
02a0: 65 64 20 77 69 74 68 20 65 61 63 68 20 70 61 67 ed with each pag
02b0: 65 20 61 63 63 65 73 73 0a 3b 3b 20 20 20 20 20 e access.;;
02c0: 69 66 20 61 20 62 72 61 6e 63 68 20 69 73 20 74 if a branch is t
02d0: 61 6b 65 6e 20 74 68 65 6e 20 61 20 6e 65 77 20 aken then a new
02e0: 73 65 73 73 69 6f 6e 20 77 6f 75 6c 64 20 6e 65 session would ne
02f0: 65 64 20 74 6f 20 62 65 20 63 72 65 61 74 65 64 ed to be created
0300: 0a 3b 3b 0a 0a 3b 3b 20 6d 61 6b 65 2d 76 65 63 .;;..;; make-vec
0310: 74 6f 72 2d 72 65 63 6f 72 64 20 73 65 73 73 69 tor-record sessi
0320: 6f 6e 20 73 65 73 73 69 6f 6e 20 64 62 74 79 70 on session dbtyp
0330: 65 20 64 62 69 6e 69 74 20 63 6f 6e 6e 20 70 61 e dbinit conn pa
0340: 72 61 6d 73 20 70 61 74 68 2d 70 61 72 61 6d 73 rams path-params
0350: 20 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 73 session-key ses
0360: 73 69 6f 6e 2d 69 64 20 64 6f 6d 61 69 6e 20 74 sion-id domain t
0370: 6f 70 70 61 67 65 20 70 61 67 65 20 63 75 72 72 oppage page curr
0380: 2d 70 61 67 65 20 63 6f 6e 74 65 6e 74 2d 74 79 -page content-ty
0390: 70 65 20 70 61 67 65 2d 74 79 70 65 20 73 72 6f pe page-type sro
03a0: 6f 74 20 74 77 69 6b 69 64 69 72 20 70 61 67 65 ot twikidir page
03b0: 64 61 74 20 61 6c 74 2d 70 61 67 65 2d 64 61 74 dat alt-page-dat
03c0: 20 70 61 67 65 76 61 72 73 20 70 61 67 65 76 61 pagevars pageva
03d0: 72 73 2d 62 65 66 6f 72 65 20 73 65 73 73 69 6f rs-before sessio
03e0: 6e 76 61 72 73 20 73 65 73 73 69 6f 6e 76 61 72 nvars sessionvar
03f0: 73 2d 62 65 66 6f 72 65 20 67 6c 6f 62 61 6c 76 s-before globalv
0400: 61 72 73 20 67 6c 6f 62 61 6c 76 61 72 73 2d 62 ars globalvars-b
0410: 65 66 6f 72 65 20 6c 6f 67 70 74 20 66 6f 72 6d efore logpt form
0420: 64 61 74 20 72 65 71 75 65 73 74 2d 6d 65 74 68 dat request-meth
0430: 6f 64 20 73 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 od session-cooki
0440: 65 20 63 75 72 72 2d 65 72 72 20 6c 6f 67 2d 70 e curr-err log-p
0450: 6f 72 74 20 6c 6f 67 66 69 6c 65 20 73 65 65 6e ort logfile seen
0460: 2d 70 61 67 65 73 20 70 61 67 65 2d 64 69 72 2d -pages page-dir-
0470: 73 74 79 6c 65 20 64 65 62 75 67 6d 6f 64 65 0a style debugmode.
0480: 28 64 65 66 69 6e 65 20 28 6d 61 6b 65 2d 73 64 (define (make-sd
0490: 61 74 29 28 6d 61 6b 65 2d 76 65 63 74 6f 72 20 at)(make-vector
04a0: 33 33 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 33)).(define (sd
04b0: 61 74 2d 67 65 74 2d 64 62 74 79 70 65 20 20 20 at-get-dbtype
04c0: 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 29 vec)
04d0: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
04e0: 20 76 65 63 20 30 29 29 0a 28 64 65 66 69 6e 65 vec 0)).(define
04f0: 20 28 73 64 61 74 2d 67 65 74 2d 64 62 69 6e 69 (sdat-get-dbini
0500: 74 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 t
0510: 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d vec) (vector-
0520: 72 65 66 20 20 76 65 63 20 31 29 29 0a 28 64 65 ref vec 1)).(de
0530: 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 63 fine (sdat-get-c
0540: 6f 6e 6e 20 20 20 20 20 20 20 20 20 20 20 20 20 onn
0550: 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 vec) (vec
0560: 74 6f 72 2d 72 65 66 20 20 76 65 63 20 32 29 29 tor-ref vec 2))
0570: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 .(define (sdat-g
0580: 65 74 2d 70 61 72 61 6d 73 20 20 20 20 20 20 20 et-params
0590: 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 vec)
05a0: 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 (vector-ref vec
05b0: 20 33 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 3)).(define (sd
05c0: 61 74 2d 67 65 74 2d 70 61 74 68 2d 70 61 72 61 at-get-path-para
05d0: 6d 73 20 20 20 20 20 20 20 20 20 20 76 65 63 29 ms vec)
05e0: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
05f0: 20 76 65 63 20 34 29 29 0a 28 64 65 66 69 6e 65 vec 4)).(define
0600: 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 (sdat-get-sessi
0610: 6f 6e 2d 6b 65 79 20 20 20 20 20 20 20 20 20 20 on-key
0620: 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d vec) (vector-
0630: 72 65 66 20 20 76 65 63 20 35 29 29 0a 28 64 65 ref vec 5)).(de
0640: 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 73 fine (sdat-get-s
0650: 65 73 73 69 6f 6e 2d 69 64 20 20 20 20 20 20 20 ession-id
0660: 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 vec) (vec
0670: 74 6f 72 2d 72 65 66 20 20 76 65 63 20 36 29 29 tor-ref vec 6))
0680: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 .(define (sdat-g
0690: 65 74 2d 64 6f 6d 61 69 6e 20 20 20 20 20 20 20 et-domain
06a0: 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 vec)
06b0: 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 (vector-ref vec
06c0: 20 37 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 7)).(define (sd
06d0: 61 74 2d 67 65 74 2d 74 6f 70 70 61 67 65 20 20 at-get-toppage
06e0: 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 29 vec)
06f0: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
0700: 20 76 65 63 20 38 29 29 0a 28 64 65 66 69 6e 65 vec 8)).(define
0710: 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 20 (sdat-get-page
0720: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0730: 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d vec) (vector-
0740: 72 65 66 20 20 76 65 63 20 39 29 29 0a 28 64 65 ref vec 9)).(de
0750: 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 63 fine (sdat-get-c
0760: 75 72 72 2d 70 61 67 65 20 20 20 20 20 20 20 20 urr-page
0770: 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 vec) (vec
0780: 74 6f 72 2d 72 65 66 20 20 76 65 63 20 31 30 29 tor-ref vec 10)
0790: 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d ).(define (sdat-
07a0: 67 65 74 2d 63 6f 6e 74 65 6e 74 2d 74 79 70 65 get-content-type
07b0: 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 vec)
07c0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 (vector-ref ve
07d0: 63 20 31 31 29 29 0a 28 64 65 66 69 6e 65 20 28 c 11)).(define (
07e0: 73 64 61 74 2d 67 65 74 2d 70 61 67 65 2d 74 79 sdat-get-page-ty
07f0: 70 65 20 20 20 20 20 20 20 20 20 20 20 20 76 65 pe ve
0800: 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 c) (vector-re
0810: 66 20 20 76 65 63 20 31 32 29 29 0a 28 64 65 66 f vec 12)).(def
0820: 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 73 72 ine (sdat-get-sr
0830: 6f 6f 74 20 20 20 20 20 20 20 20 20 20 20 20 20 oot
0840: 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 vec) (vect
0850: 6f 72 2d 72 65 66 20 20 76 65 63 20 31 33 29 29 or-ref vec 13))
0860: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 .(define (sdat-g
0870: 65 74 2d 74 77 69 6b 69 64 69 72 20 20 20 20 20 et-twikidir
0880: 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 vec)
0890: 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 (vector-ref vec
08a0: 20 31 34 29 29 0a 28 64 65 66 69 6e 65 20 28 73 14)).(define (s
08b0: 64 61 74 2d 67 65 74 2d 70 61 67 65 64 61 74 20 dat-get-pagedat
08c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 vec
08d0: 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 ) (vector-ref
08e0: 20 20 76 65 63 20 31 35 29 29 0a 28 64 65 66 69 vec 15)).(defi
08f0: 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 61 6c 74 ne (sdat-get-alt
0900: 2d 70 61 67 65 2d 64 61 74 20 20 20 20 20 20 20 -page-dat
0910: 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f vec) (vecto
0920: 72 2d 72 65 66 20 20 76 65 63 20 31 36 29 29 0a r-ref vec 16)).
0930: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 (define (sdat-ge
0940: 74 2d 70 61 67 65 76 61 72 73 20 20 20 20 20 20 t-pagevars
0950: 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 vec) (
0960: 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 vector-ref vec
0970: 31 37 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 17)).(define (sd
0980: 61 74 2d 67 65 74 2d 70 61 67 65 76 61 72 73 2d at-get-pagevars-
0990: 62 65 66 6f 72 65 20 20 20 20 20 20 76 65 63 29 before vec)
09a0: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
09b0: 20 76 65 63 20 31 38 29 29 0a 28 64 65 66 69 6e vec 18)).(defin
09c0: 65 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 e (sdat-get-sess
09d0: 69 6f 6e 76 61 72 73 20 20 20 20 20 20 20 20 20 ionvars
09e0: 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 vec) (vector
09f0: 2d 72 65 66 20 20 76 65 63 20 31 39 29 29 0a 28 -ref vec 19)).(
0a00: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 define (sdat-get
0a10: 2d 73 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 -sessionvars-bef
0a20: 6f 72 65 20 20 20 76 65 63 29 20 20 20 20 28 76 ore vec) (v
0a30: 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 32 ector-ref vec 2
0a40: 30 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 0)).(define (sda
0a50: 74 2d 67 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 t-get-globalvars
0a60: 20 20 20 20 20 20 20 20 20 20 20 76 65 63 29 20 vec)
0a70: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 (vector-ref
0a80: 76 65 63 20 32 31 29 29 0a 28 64 65 66 69 6e 65 vec 21)).(define
0a90: 20 28 73 64 61 74 2d 67 65 74 2d 67 6c 6f 62 61 (sdat-get-globa
0aa0: 6c 76 61 72 73 2d 62 65 66 6f 72 65 20 20 20 20 lvars-before
0ab0: 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d vec) (vector-
0ac0: 72 65 66 20 20 76 65 63 20 32 32 29 29 0a 28 64 ref vec 22)).(d
0ad0: 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d efine (sdat-get-
0ae0: 6c 6f 67 70 74 20 20 20 20 20 20 20 20 20 20 20 logpt
0af0: 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 vec) (ve
0b00: 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 32 33 ctor-ref vec 23
0b10: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
0b20: 2d 67 65 74 2d 66 6f 72 6d 64 61 74 20 20 20 20 -get-formdat
0b30: 20 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 vec)
0b40: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 (vector-ref v
0b50: 65 63 20 32 34 29 29 0a 28 64 65 66 69 6e 65 20 ec 24)).(define
0b60: 28 73 64 61 74 2d 67 65 74 2d 72 65 71 75 65 73 (sdat-get-reques
0b70: 74 2d 6d 65 74 68 6f 64 20 20 20 20 20 20 20 76 t-method v
0b80: 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 ec) (vector-r
0b90: 65 66 20 20 76 65 63 20 32 35 29 29 0a 28 64 65 ef vec 25)).(de
0ba0: 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 73 fine (sdat-get-s
0bb0: 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 20 20 20 ession-cookie
0bc0: 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 vec) (vec
0bd0: 74 6f 72 2d 72 65 66 20 20 76 65 63 20 32 36 29 tor-ref vec 26)
0be0: 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d ).(define (sdat-
0bf0: 67 65 74 2d 63 75 72 72 2d 65 72 72 20 20 20 20 get-curr-err
0c00: 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 vec)
0c10: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 (vector-ref ve
0c20: 63 20 32 37 29 29 0a 28 64 65 66 69 6e 65 20 28 c 27)).(define (
0c30: 73 64 61 74 2d 67 65 74 2d 6c 6f 67 2d 70 6f 72 sdat-get-log-por
0c40: 74 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 t ve
0c50: 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 c) (vector-re
0c60: 66 20 20 76 65 63 20 32 38 29 29 0a 28 64 65 66 f vec 28)).(def
0c70: 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 6c 6f ine (sdat-get-lo
0c80: 67 66 69 6c 65 20 20 20 20 20 20 20 20 20 20 20 gfile
0c90: 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 vec) (vect
0ca0: 6f 72 2d 72 65 66 20 20 76 65 63 20 32 39 29 29 or-ref vec 29))
0cb0: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 .(define (sdat-g
0cc0: 65 74 2d 73 65 65 6e 2d 70 61 67 65 73 20 20 20 et-seen-pages
0cd0: 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 vec)
0ce0: 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 (vector-ref vec
0cf0: 20 33 30 29 29 0a 28 64 65 66 69 6e 65 20 28 73 30)).(define (s
0d00: 64 61 74 2d 67 65 74 2d 70 61 67 65 2d 64 69 72 dat-get-page-dir
0d10: 2d 73 74 79 6c 65 20 20 20 20 20 20 20 76 65 63 -style vec
0d20: 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 ) (vector-ref
0d30: 20 20 76 65 63 20 33 31 29 29 0a 28 64 65 66 69 vec 31)).(defi
0d40: 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 64 65 62 ne (sdat-get-deb
0d50: 75 67 6d 6f 64 65 20 20 20 20 20 20 20 20 20 20 ugmode
0d60: 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f vec) (vecto
0d70: 72 2d 72 65 66 20 20 76 65 63 20 33 32 29 29 0a r-ref vec 32)).
0d80: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 (define (sdat-se
0d90: 74 2d 64 62 74 79 70 65 21 20 20 20 20 20 20 20 t-dbtype!
0da0: 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 vec val)(
0db0: 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 vector-set! vec
0dc0: 30 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 0 val)).(define
0dd0: 28 73 64 61 74 2d 73 65 74 2d 64 62 69 6e 69 74 (sdat-set-dbinit
0de0: 21 20 20 20 20 20 20 20 20 20 20 20 20 20 20 76 ! v
0df0: 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 ec val)(vector-s
0e00: 65 74 21 20 76 65 63 20 31 20 76 61 6c 29 29 0a et! vec 1 val)).
0e10: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 (define (sdat-se
0e20: 74 2d 63 6f 6e 6e 21 20 20 20 20 20 20 20 20 20 t-conn!
0e30: 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 vec val)(
0e40: 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 vector-set! vec
0e50: 32 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 2 val)).(define
0e60: 28 73 64 61 74 2d 73 65 74 2d 70 61 72 61 6d 73 (sdat-set-params
0e70: 21 20 20 20 20 20 20 20 20 20 20 20 20 20 20 76 ! v
0e80: 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 ec val)(vector-s
0e90: 65 74 21 20 76 65 63 20 33 20 76 61 6c 29 29 0a et! vec 3 val)).
0ea0: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 (define (sdat-se
0eb0: 74 2d 70 61 74 68 2d 70 61 72 61 6d 73 21 20 20 t-path-params!
0ec0: 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 vec val)(
0ed0: 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 vector-set! vec
0ee0: 34 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 4 val)).(define
0ef0: 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f (sdat-set-sessio
0f00: 6e 2d 6b 65 79 21 20 20 20 20 20 20 20 20 20 76 n-key! v
0f10: 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 ec val)(vector-s
0f20: 65 74 21 20 76 65 63 20 35 20 76 61 6c 29 29 0a et! vec 5 val)).
0f30: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 (define (sdat-se
0f40: 74 2d 73 65 73 73 69 6f 6e 2d 69 64 21 20 20 20 t-session-id!
0f50: 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 vec val)(
0f60: 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 vector-set! vec
0f70: 36 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 6 val)).(define
0f80: 28 73 64 61 74 2d 73 65 74 2d 64 6f 6d 61 69 6e (sdat-set-domain
0f90: 21 20 20 20 20 20 20 20 20 20 20 20 20 20 20 76 ! v
0fa0: 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 ec val)(vector-s
0fb0: 65 74 21 20 76 65 63 20 37 20 76 61 6c 29 29 0a et! vec 7 val)).
0fc0: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 (define (sdat-se
0fd0: 74 2d 74 6f 70 70 61 67 65 21 20 20 20 20 20 20 t-toppage!
0fe0: 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 vec val)(
0ff0: 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 vector-set! vec
1000: 38 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 8 val)).(define
1010: 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 21 20 (sdat-set-page!
1020: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 76 v
1030: 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 ec val)(vector-s
1040: 65 74 21 20 76 65 63 20 39 20 76 61 6c 29 29 0a et! vec 9 val)).
1050: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 (define (sdat-se
1060: 74 2d 63 75 72 72 2d 70 61 67 65 21 20 20 20 20 t-curr-page!
1070: 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 vec val)(
1080: 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 vector-set! vec
1090: 31 30 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 10 val)).(define
10a0: 20 28 73 64 61 74 2d 73 65 74 2d 63 6f 6e 74 65 (sdat-set-conte
10b0: 6e 74 2d 74 79 70 65 21 20 20 20 20 20 20 20 20 nt-type!
10c0: 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d vec val)(vector-
10d0: 73 65 74 21 20 76 65 63 20 31 31 20 76 61 6c 29 set! vec 11 val)
10e0: 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d ).(define (sdat-
10f0: 73 65 74 2d 70 61 67 65 2d 74 79 70 65 21 20 20 set-page-type!
1100: 20 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c vec val
1110: 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 )(vector-set! ve
1120: 63 20 31 32 20 76 61 6c 29 29 0a 28 64 65 66 69 c 12 val)).(defi
1130: 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 73 72 6f ne (sdat-set-sro
1140: 6f 74 21 20 20 20 20 20 20 20 20 20 20 20 20 20 ot!
1150: 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f vec val)(vecto
1160: 72 2d 73 65 74 21 20 76 65 63 20 31 33 20 76 61 r-set! vec 13 va
1170: 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 l)).(define (sda
1180: 74 2d 73 65 74 2d 74 77 69 6b 69 64 69 72 21 20 t-set-twikidir!
1190: 20 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 vec v
11a0: 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 al)(vector-set!
11b0: 76 65 63 20 31 34 20 76 61 6c 29 29 0a 28 64 65 vec 14 val)).(de
11c0: 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 70 fine (sdat-set-p
11d0: 61 67 65 64 61 74 21 20 20 20 20 20 20 20 20 20 agedat!
11e0: 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 vec val)(vec
11f0: 74 6f 72 2d 73 65 74 21 20 76 65 63 20 31 35 20 tor-set! vec 15
1200: 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 val)).(define (s
1210: 64 61 74 2d 73 65 74 2d 61 6c 74 2d 70 61 67 65 dat-set-alt-page
1220: 2d 64 61 74 21 20 20 20 20 20 20 20 20 76 65 63 -dat! vec
1230: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
1240: 21 20 76 65 63 20 31 36 20 76 61 6c 29 29 0a 28 ! vec 16 val)).(
1250: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 define (sdat-set
1260: 2d 70 61 67 65 76 61 72 73 21 20 20 20 20 20 20 -pagevars!
1270: 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 vec val)(v
1280: 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 31 ector-set! vec 1
1290: 37 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 7 val)).(define
12a0: 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 76 61 (sdat-set-pageva
12b0: 72 73 2d 62 65 66 6f 72 65 21 20 20 20 20 20 76 rs-before! v
12c0: 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 ec val)(vector-s
12d0: 65 74 21 20 76 65 63 20 31 38 20 76 61 6c 29 29 et! vec 18 val))
12e0: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 .(define (sdat-s
12f0: 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 21 20 et-sessionvars!
1300: 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 vec val)
1310: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 (vector-set! vec
1320: 20 31 39 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 19 val)).(defin
1330: 65 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 e (sdat-set-sess
1340: 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 21 20 ionvars-before!
1350: 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 vec val)(vector
1360: 2d 73 65 74 21 20 76 65 63 20 32 30 20 76 61 6c -set! vec 20 val
1370: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
1380: 2d 73 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 21 -set-globalvars!
1390: 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 61 vec va
13a0: 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 l)(vector-set! v
13b0: 65 63 20 32 31 20 76 61 6c 29 29 0a 28 64 65 66 ec 21 val)).(def
13c0: 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 67 6c ine (sdat-set-gl
13d0: 6f 62 61 6c 76 61 72 73 2d 62 65 66 6f 72 65 21 obalvars-before!
13e0: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
13f0: 6f 72 2d 73 65 74 21 20 76 65 63 20 32 32 20 76 or-set! vec 22 v
1400: 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 al)).(define (sd
1410: 61 74 2d 73 65 74 2d 6c 6f 67 70 74 21 20 20 20 at-set-logpt!
1420: 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 20 vec
1430: 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 val)(vector-set!
1440: 20 76 65 63 20 32 33 20 76 61 6c 29 29 0a 28 64 vec 23 val)).(d
1450: 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d efine (sdat-set-
1460: 66 6f 72 6d 64 61 74 21 20 20 20 20 20 20 20 20 formdat!
1470: 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 vec val)(ve
1480: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 32 34 ctor-set! vec 24
1490: 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 val)).(define (
14a0: 73 64 61 74 2d 73 65 74 2d 72 65 71 75 65 73 74 sdat-set-request
14b0: 2d 6d 65 74 68 6f 64 21 20 20 20 20 20 20 76 65 -method! ve
14c0: 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 c val)(vector-se
14d0: 74 21 20 76 65 63 20 32 35 20 76 61 6c 29 29 0a t! vec 25 val)).
14e0: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 (define (sdat-se
14f0: 74 2d 73 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 t-session-cookie
1500: 21 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 ! vec val)(
1510: 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 vector-set! vec
1520: 32 36 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 26 val)).(define
1530: 20 28 73 64 61 74 2d 73 65 74 2d 63 75 72 72 2d (sdat-set-curr-
1540: 65 72 72 21 20 20 20 20 20 20 20 20 20 20 20 20 err!
1550: 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d vec val)(vector-
1560: 73 65 74 21 20 76 65 63 20 32 37 20 76 61 6c 29 set! vec 27 val)
1570: 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d ).(define (sdat-
1580: 73 65 74 2d 6c 6f 67 2d 70 6f 72 74 21 20 20 20 set-log-port!
1590: 20 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c vec val
15a0: 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 )(vector-set! ve
15b0: 63 20 32 38 20 76 61 6c 29 29 0a 28 64 65 66 69 c 28 val)).(defi
15c0: 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 6c 6f 67 ne (sdat-set-log
15d0: 66 69 6c 65 21 20 20 20 20 20 20 20 20 20 20 20 file!
15e0: 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f vec val)(vecto
15f0: 72 2d 73 65 74 21 20 76 65 63 20 32 39 20 76 61 r-set! vec 29 va
1600: 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 l)).(define (sda
1610: 74 2d 73 65 74 2d 73 65 65 6e 2d 70 61 67 65 73 t-set-seen-pages
1620: 21 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 ! vec v
1630: 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 al)(vector-set!
1640: 76 65 63 20 33 30 20 76 61 6c 29 29 0a 28 64 65 vec 30 val)).(de
1650: 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 70 fine (sdat-set-p
1660: 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 21 20 20 age-dir-style!
1670: 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 vec val)(vec
1680: 74 6f 72 2d 73 65 74 21 20 76 65 63 20 33 31 20 tor-set! vec 31
1690: 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 val)).(define (s
16a0: 64 61 74 2d 73 65 74 2d 64 65 62 75 67 6d 6f 64 dat-set-debugmod
16b0: 65 21 20 20 20 20 20 20 20 20 20 20 20 76 65 63 e! vec
16c0: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
16d0: 21 20 76 65 63 20 33 32 20 76 61 6c 29 29 0a 0a ! vec 32 val))..
16e0: 3b 3b 20 28 64 65 66 69 6e 65 2d 63 6c 61 73 73 ;; (define-class
16f0: 20 3c 73 65 73 73 69 6f 6e 3e 20 28 29 0a 3b 3b <session> ().;;
1700: 20 20 20 28 64 62 74 79 70 65 20 20 20 20 20 20 (dbtype
1710: 20 3b 3b 20 27 70 67 20 6f 72 20 27 73 71 6c 69 ;; 'pg or 'sqli
1720: 74 65 33 0a 3b 3b 20 20 20 20 64 62 69 6e 69 74 te3.;; dbinit
1730: 0a 3b 3b 20 20 20 20 63 6f 6e 6e 0a 3b 3b 20 20 .;; conn.;;
1740: 20 20 70 61 72 61 6d 73 20 20 20 20 20 20 20 3b params ;
1750: 3b 20 70 61 72 61 6d 73 20 66 72 6f 6d 20 74 68 ; params from th
1760: 65 20 6b 65 79 3d 76 61 6c 26 6b 65 79 31 3d 76 e key=val&key1=v
1770: 61 6c 32 20 73 74 72 69 6e 67 0a 3b 3b 20 20 20 al2 string.;;
1780: 20 70 61 74 68 2d 70 61 72 61 6d 73 20 20 3b 3b path-params ;;
1790: 20 72 65 6d 61 69 6e 69 6e 67 20 70 61 72 61 6d remaining param
17a0: 73 20 66 72 6f 6d 20 74 68 65 20 70 61 74 68 0a s from the path.
17b0: 3b 3b 20 20 20 20 73 65 73 73 69 6f 6e 2d 6b 65 ;; session-ke
17c0: 79 0a 3b 3b 20 20 20 20 73 65 73 73 69 6f 6e 2d y.;; session-
17d0: 69 64 0a 3b 3b 20 20 20 20 64 6f 6d 61 69 6e 0a id.;; domain.
17e0: 3b 3b 20 20 20 20 74 6f 70 70 61 67 65 20 20 20 ;; toppage
17f0: 20 20 20 3b 3b 20 64 65 66 61 75 6c 74 73 20 74 ;; defaults t
1800: 6f 20 22 69 6e 64 65 78 22 20 2d 20 6f 76 65 72 o "index" - over
1810: 72 69 64 65 20 69 6e 20 2e 73 74 6d 6c 2e 63 6f ride in .stml.co
1820: 6e 66 69 67 20 69 66 20 64 65 73 69 72 65 64 0a nfig if desired.
1830: 3b 3b 20 20 20 20 70 61 67 65 20 20 20 20 20 20 ;; page
1840: 20 20 20 3b 3b 20 74 68 65 20 70 61 67 65 20 6e ;; the page n
1850: 61 6d 65 20 2d 20 64 65 66 61 75 6c 74 73 20 74 ame - defaults t
1860: 6f 20 68 6f 6d 65 0a 3b 3b 20 20 20 20 63 75 72 o home.;; cur
1870: 72 2d 70 61 67 65 20 20 20 20 3b 3b 20 74 68 65 r-page ;; the
1880: 20 63 75 72 72 65 6e 74 20 70 61 67 65 20 62 65 current page be
1890: 69 6e 67 20 65 76 61 6c 75 61 74 65 64 0a 3b 3b ing evaluated.;;
18a0: 20 20 20 20 63 6f 6e 74 65 6e 74 2d 74 79 70 65 content-type
18b0: 20 3b 3b 20 74 68 65 20 64 65 66 61 75 6c 74 20 ;; the default
18c0: 63 6f 6e 74 65 6e 74 20 74 79 70 65 20 69 73 20 content type is
18d0: 74 65 78 74 2f 68 74 6d 6c 2c 20 6f 76 65 72 72 text/html, overr
18e0: 69 64 65 20 74 6f 20 64 65 6c 69 76 65 72 20 6f ide to deliver o
18f0: 74 68 65 72 20 73 74 75 66 66 0a 3b 3b 20 20 20 ther stuff.;;
1900: 20 70 61 67 65 2d 74 79 70 65 20 20 20 20 3b 3b page-type ;;
1910: 20 75 73 65 20 69 6e 20 63 6f 6e 6a 75 6e 63 74 use in conjunct
1920: 69 6f 6e 20 77 69 74 68 20 63 6f 6e 74 65 6e 74 ion with content
1930: 2d 74 79 70 65 20 74 6f 20 64 65 6c 69 76 65 72 -type to deliver
1940: 20 6f 74 68 65 72 20 70 61 79 6c 6f 61 64 73 0a other payloads.
1950: 3b 3b 20 20 20 20 73 72 6f 6f 74 0a 3b 3b 20 20 ;; sroot.;;
1960: 20 20 74 77 69 6b 69 64 69 72 20 20 20 20 20 3b twikidir ;
1970: 3b 20 6c 6f 63 61 74 69 6f 6e 20 66 6f 72 20 74 ; location for t
1980: 77 69 6b 69 73 20 2d 20 6e 65 65 64 73 20 74 6f wikis - needs to
1990: 20 62 65 20 66 75 6c 6c 79 20 77 72 69 74 61 62 be fully writab
19a0: 6c 65 20 62 79 20 77 65 62 20 73 65 72 76 65 72 le by web server
19b0: 0a 3b 3b 20 20 20 20 70 61 67 65 64 61 74 0a 3b .;; pagedat.;
19c0: 3b 20 20 20 20 61 6c 74 2d 70 61 67 65 2d 64 61 ; alt-page-da
19d0: 74 0a 3b 3b 20 20 20 20 70 61 67 65 76 61 72 73 t.;; pagevars
19e0: 20 20 20 20 20 3b 3b 20 73 65 73 73 69 6f 6e 20 ;; session
19f0: 76 61 72 73 20 73 70 65 63 69 66 69 63 20 74 6f vars specific to
1a00: 20 74 68 69 73 20 70 61 67 65 0a 3b 3b 20 20 20 this page.;;
1a10: 20 70 61 67 65 76 61 72 73 2d 62 65 66 6f 72 65 pagevars-before
1a20: 0a 3b 3b 20 20 20 20 73 65 73 73 69 6f 6e 76 61 .;; sessionva
1a30: 72 73 20 20 3b 3b 20 73 65 73 73 69 6f 6e 20 76 rs ;; session v
1a40: 61 72 73 20 76 69 73 69 62 6c 65 20 74 6f 20 61 ars visible to a
1a50: 6c 6c 20 70 61 67 65 73 0a 3b 3b 20 20 20 20 73 ll pages.;; s
1a60: 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 essionvars-befor
1a70: 65 0a 3b 3b 20 20 20 20 67 6c 6f 62 61 6c 76 61 e.;; globalva
1a80: 72 73 20 20 20 3b 3b 20 67 6c 6f 62 61 6c 20 76 rs ;; global v
1a90: 61 72 73 20 76 69 73 69 62 6c 65 20 74 6f 20 61 ars visible to a
1aa0: 6c 6c 20 73 65 73 73 69 6f 6e 73 0a 3b 3b 20 20 ll sessions.;;
1ab0: 20 20 67 6c 6f 62 61 6c 76 61 72 73 2d 62 65 66 globalvars-bef
1ac0: 6f 72 65 0a 3b 3b 20 20 20 20 6c 6f 67 70 74 0a ore.;; logpt.
1ad0: 3b 3b 20 20 20 20 66 6f 72 6d 64 61 74 0a 3b 3b ;; formdat.;;
1ae0: 20 20 20 20 72 65 71 75 65 73 74 2d 6d 65 74 68 request-meth
1af0: 6f 64 0a 3b 3b 20 20 20 20 73 65 73 73 69 6f 6e od.;; session
1b00: 2d 63 6f 6f 6b 69 65 0a 3b 3b 20 20 20 20 63 75 -cookie.;; cu
1b10: 72 72 2d 65 72 72 0a 3b 3b 20 20 20 20 6c 6f 67 rr-err.;; log
1b20: 2d 70 6f 72 74 0a 3b 3b 20 20 20 20 6c 6f 67 66 -port.;; logf
1b30: 69 6c 65 0a 3b 3b 20 20 20 20 73 65 65 6e 2d 70 ile.;; seen-p
1b40: 61 67 65 73 0a 3b 3b 20 20 20 20 70 61 67 65 2d ages.;; page-
1b50: 64 69 72 2d 73 74 79 6c 65 20 20 3b 3b 20 23 74 dir-style ;; #t
1b60: 20 3d 20 6e 65 77 20 73 74 79 6c 65 2c 20 23 66 = new style, #f
1b70: 20 3d 20 6f 6c 64 20 73 74 79 6c 65 0a 3b 3b 20 = old style.;;
1b80: 20 20 20 64 65 62 75 67 6d 6f 64 65 29 29 0a 0a debugmode))..
1b90: 3b 3b 20 53 50 4c 49 54 20 49 4e 54 4f 20 53 54 ;; SPLIT INTO ST
1ba0: 52 41 49 47 48 54 20 46 4f 52 57 41 52 44 20 49 RAIGHT FORWARD I
1bb0: 4e 49 54 20 41 4e 44 20 43 4f 4d 50 4c 45 58 20 NIT AND COMPLEX
1bc0: 49 4e 49 54 0a 28 64 65 66 69 6e 65 20 28 73 65 INIT.(define (se
1bd0: 73 73 69 6f 6e 3a 69 6e 69 74 69 61 6c 69 7a 65 ssion:initialize
1be0: 20 73 65 6c 66 29 0a 20 20 28 73 64 61 74 2d 73 self). (sdat-s
1bf0: 65 74 2d 64 62 74 79 70 65 21 20 73 65 6c 66 20 et-dbtype! self
1c00: 20 20 20 20 20 27 70 67 29 0a 20 20 28 73 64 61 'pg). (sda
1c10: 74 2d 73 65 74 2d 70 61 67 65 21 20 73 65 6c 66 t-set-page! self
1c20: 20 20 20 20 20 20 20 20 22 68 6f 6d 65 22 29 20 "home")
1c30: 20 20 20 20 20 20 20 3b 3b 20 74 68 65 73 65 20 ;; these
1c40: 61 72 65 20 64 65 66 61 75 6c 74 73 0a 20 20 28 are defaults. (
1c50: 73 64 61 74 2d 73 65 74 2d 63 75 72 72 2d 70 61 sdat-set-curr-pa
1c60: 67 65 21 20 73 65 6c 66 20 20 20 22 68 6f 6d 65 ge! self "home
1c70: 22 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 63 "). (sdat-set-c
1c80: 6f 6e 74 65 6e 74 2d 74 79 70 65 21 20 73 65 6c ontent-type! sel
1c90: 66 20 22 43 6f 6e 74 65 6e 74 2d 74 79 70 65 3a f "Content-type:
1ca0: 20 74 65 78 74 2f 68 74 6d 6c 3b 20 63 68 61 72 text/html; char
1cb0: 73 65 74 3d 69 73 6f 2d 38 38 35 39 2d 31 5c 6e set=iso-8859-1\n
1cc0: 5c 6e 22 29 0a 20 20 28 73 64 61 74 2d 73 65 74 \n"). (sdat-set
1cd0: 2d 70 61 67 65 2d 74 79 70 65 21 20 73 65 6c 66 -page-type! self
1ce0: 20 20 20 27 68 74 6d 6c 29 0a 20 20 28 73 64 61 'html). (sda
1cf0: 74 2d 73 65 74 2d 74 6f 70 70 61 67 65 21 20 73 t-set-toppage! s
1d00: 65 6c 66 20 20 20 20 20 22 69 6e 64 65 78 22 29 elf "index")
1d10: 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 72 . (sdat-set-par
1d20: 61 6d 73 21 20 73 65 6c 66 20 20 20 20 20 20 27 ams! self '
1d30: 28 29 29 20 20 20 20 20 20 20 20 20 20 20 3b 3b ()) ;;
1d40: 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 74 . (sdat-set-pat
1d50: 68 2d 70 61 72 61 6d 73 21 20 73 65 6c 66 20 27 h-params! self '
1d60: 28 29 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d ()). (sdat-set-
1d70: 73 65 73 73 69 6f 6e 2d 6b 65 79 21 20 73 65 6c session-key! sel
1d80: 66 20 23 66 29 0a 20 20 28 73 64 61 74 2d 73 65 f #f). (sdat-se
1d90: 74 2d 70 61 67 65 64 61 74 21 20 73 65 6c 66 20 t-pagedat! self
1da0: 20 20 20 20 27 28 29 29 0a 20 20 28 73 64 61 74 '()). (sdat
1db0: 2d 73 65 74 2d 61 6c 74 2d 70 61 67 65 2d 64 61 -set-alt-page-da
1dc0: 74 21 20 73 65 6c 66 20 23 66 29 0a 20 20 28 73 t! self #f). (s
1dd0: 64 61 74 2d 73 65 74 2d 73 72 6f 6f 74 21 20 73 dat-set-sroot! s
1de0: 65 6c 66 20 20 20 20 20 20 20 22 2e 2f 22 29 0a elf "./").
1df0: 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 (sdat-set-sess
1e00: 69 6f 6e 2d 63 6f 6f 6b 69 65 21 20 73 65 6c 66 ion-cookie! self
1e10: 20 23 66 29 0a 20 20 28 73 64 61 74 2d 73 65 74 #f). (sdat-set
1e20: 2d 63 75 72 72 2d 65 72 72 21 20 73 65 6c 66 20 -curr-err! self
1e30: 23 66 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d #f). (sdat-set-
1e40: 6c 6f 67 2d 70 6f 72 74 21 20 73 65 6c 66 20 28 log-port! self (
1e50: 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f current-error-po
1e60: 72 74 29 29 0a 20 20 28 73 64 61 74 2d 73 65 74 rt)). (sdat-set
1e70: 2d 73 65 65 6e 2d 70 61 67 65 73 21 20 73 65 6c -seen-pages! sel
1e80: 66 20 27 28 29 29 0a 20 20 28 73 64 61 74 2d 73 f '()). (sdat-s
1e90: 65 74 2d 70 61 67 65 2d 64 69 72 2d 73 74 79 6c et-page-dir-styl
1ea0: 65 21 20 73 65 6c 66 20 23 74 29 20 3b 3b 20 23 e! self #t) ;; #
1eb0: 74 20 3a 20 70 61 67 65 73 2f 3c 70 61 67 65 6e t : pages/<pagen
1ec0: 61 6d 65 3e 5f 28 76 69 65 77 7c 63 6e 74 6c 29 ame>_(view|cntl)
1ed0: 2e 73 63 6d 0a 20 20 20 20 20 20 20 20 20 20 20 .scm.
1ee0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1ef0: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 23 66 ;; #f
1f00: 20 3a 20 70 61 67 65 73 2f 3c 70 61 67 65 6e 61 : pages/<pagena
1f10: 6d 65 3e 2f 28 76 69 65 77 7c 63 6f 6e 74 72 6f me>/(view|contro
1f20: 6c 29 2e 73 63 6d 20 0a 20 20 28 73 64 61 74 2d l).scm . (sdat-
1f30: 73 65 74 2d 64 65 62 75 67 6d 6f 64 65 21 20 20 set-debugmode!
1f40: 20 20 20 20 20 20 20 20 73 65 6c 66 20 23 66 29 self #f)
1f50: 0a 20 20 09 09 09 20 20 20 20 20 0a 20 20 28 73 . ... . (s
1f60: 64 61 74 2d 73 65 74 2d 70 61 67 65 76 61 72 73 dat-set-pagevars
1f70: 21 20 20 20 20 20 20 20 20 20 20 20 73 65 6c 66 ! self
1f80: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
1f90: 65 29 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d e)). (sdat-set-
1fa0: 73 65 73 73 69 6f 6e 76 61 72 73 21 20 20 20 20 sessionvars!
1fb0: 20 20 20 20 73 65 6c 66 20 28 6d 61 6b 65 2d 68 self (make-h
1fc0: 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 73 ash-table)). (s
1fd0: 64 61 74 2d 73 65 74 2d 67 6c 6f 62 61 6c 76 61 dat-set-globalva
1fe0: 72 73 21 20 20 20 20 20 20 20 20 20 73 65 6c 66 rs! self
1ff0: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
2000: 65 29 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d e)). (sdat-set-
2010: 70 61 67 65 76 61 72 73 2d 62 65 66 6f 72 65 21 pagevars-before!
2020: 20 20 20 20 73 65 6c 66 20 28 6d 61 6b 65 2d 68 self (make-h
2030: 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 73 ash-table)). (s
2040: 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e 76 dat-set-sessionv
2050: 61 72 73 2d 62 65 66 6f 72 65 21 20 73 65 6c 66 ars-before! self
2060: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
2070: 65 29 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d e)). (sdat-set-
2080: 67 6c 6f 62 61 6c 76 61 72 73 2d 62 65 66 6f 72 globalvars-befor
2090: 65 21 20 20 73 65 6c 66 20 28 6d 61 6b 65 2d 68 e! self (make-h
20a0: 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 73 ash-table)). (s
20b0: 64 61 74 2d 73 65 74 2d 64 6f 6d 61 69 6e 21 20 dat-set-domain!
20c0: 20 20 20 20 20 20 20 20 20 20 20 20 73 65 6c 66 self
20d0: 20 22 6c 6f 63 61 68 6f 73 74 22 29 20 20 20 3b "locahost") ;
20e0: 3b 20 65 6e 64 20 6f 66 20 64 65 66 61 75 6c 74 ; end of default
20f0: 73 0a 20 20 28 6c 65 74 2a 20 28 28 72 61 77 63 s. (let* ((rawc
2100: 6f 6e 66 69 67 64 61 74 20 28 73 65 73 73 69 6f onfigdat (sessio
2110: 6e 3a 72 65 61 64 2d 63 6f 6e 66 69 67 20 73 65 n:read-config se
2120: 6c 66 29 29 0a 09 20 28 63 6f 6e 66 69 67 64 61 lf)).. (configda
2130: 74 20 28 69 66 20 72 61 77 63 6f 6e 66 69 67 64 t (if rawconfigd
2140: 61 74 20 28 65 76 61 6c 20 72 61 77 63 6f 6e 66 at (eval rawconf
2150: 69 67 64 61 74 29 20 27 28 29 29 29 0a 09 20 28 igdat) '())).. (
2160: 73 72 6f 6f 74 20 20 20 20 20 28 73 3a 66 69 6e sroot (s:fin
2170: 64 2d 70 61 72 61 6d 20 27 73 72 6f 6f 74 20 20 d-param 'sroot
2180: 20 20 63 6f 6e 66 69 67 64 61 74 29 29 0a 09 20 configdat))..
2190: 28 6c 6f 67 66 69 6c 65 20 20 20 28 73 3a 66 69 (logfile (s:fi
21a0: 6e 64 2d 70 61 72 61 6d 20 27 6c 6f 67 66 69 6c nd-param 'logfil
21b0: 65 20 20 63 6f 6e 66 69 67 64 61 74 29 29 0a 09 e configdat))..
21c0: 20 28 64 62 74 79 70 65 20 20 20 20 28 73 3a 66 (dbtype (s:f
21d0: 69 6e 64 2d 70 61 72 61 6d 20 27 64 62 74 79 70 ind-param 'dbtyp
21e0: 65 20 20 20 63 6f 6e 66 69 67 64 61 74 29 29 0a e configdat)).
21f0: 09 20 28 64 62 69 6e 69 74 20 20 20 20 28 73 3a . (dbinit (s:
2200: 66 69 6e 64 2d 70 61 72 61 6d 20 27 64 62 69 6e find-param 'dbin
2210: 69 74 20 20 20 63 6f 6e 66 69 67 64 61 74 29 29 it configdat))
2220: 0a 09 20 28 64 6f 6d 61 69 6e 20 20 20 20 28 73 .. (domain (s
2230: 3a 66 69 6e 64 2d 70 61 72 61 6d 20 27 64 6f 6d :find-param 'dom
2240: 61 69 6e 20 20 20 63 6f 6e 66 69 67 64 61 74 29 ain configdat)
2250: 29 29 0a 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 )). ;; (print
2260: 20 22 63 6f 6e 66 69 67 64 61 74 3a 20 22 29 28 "configdat: ")(
2270: 70 70 20 63 6f 6e 66 69 67 64 61 74 29 0a 20 20 pp configdat).
2280: 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 73 72 6f ;; (print "sro
2290: 6f 74 3a 20 22 20 73 72 6f 6f 74 20 22 20 6c 6f ot: " sroot " lo
22a0: 67 66 69 6c 65 3a 20 22 20 6c 6f 67 66 69 6c 65 gfile: " logfile
22b0: 20 22 20 64 62 74 79 70 65 3a 20 22 20 64 62 74 " dbtype: " dbt
22c0: 79 70 65 20 22 20 64 62 69 6e 69 74 3a 20 22 20 ype " dbinit: "
22d0: 64 62 69 6e 69 74 20 22 20 64 6f 6d 61 69 6e 3a dbinit " domain:
22e0: 20 22 20 64 6f 6d 61 69 6e 29 0a 20 20 20 20 28 " domain). (
22f0: 69 66 20 73 72 6f 6f 74 20 20 20 28 73 64 61 74 if sroot (sdat
2300: 2d 73 65 74 2d 73 72 6f 6f 74 21 20 20 20 73 65 -set-sroot! se
2310: 6c 66 20 73 72 6f 6f 74 29 29 0a 20 20 20 20 28 lf sroot)). (
2320: 69 66 20 6c 6f 67 66 69 6c 65 20 28 73 64 61 74 if logfile (sdat
2330: 2d 73 65 74 2d 6c 6f 67 66 69 6c 65 21 20 73 65 -set-logfile! se
2340: 6c 66 20 6c 6f 67 66 69 6c 65 29 29 0a 20 20 20 lf logfile)).
2350: 20 28 69 66 20 64 62 74 79 70 65 20 20 28 73 64 (if dbtype (sd
2360: 61 74 2d 73 65 74 2d 64 62 74 79 70 65 21 20 20 at-set-dbtype!
2370: 73 65 6c 66 20 64 62 74 79 70 65 29 29 0a 20 20 self dbtype)).
2380: 20 20 28 69 66 20 64 62 69 6e 69 74 20 20 28 73 (if dbinit (s
2390: 64 61 74 2d 73 65 74 2d 64 62 69 6e 69 74 21 20 dat-set-dbinit!
23a0: 20 73 65 6c 66 20 64 62 69 6e 69 74 29 29 0a 20 self dbinit)).
23b0: 20 20 20 28 69 66 20 64 6f 6d 61 69 6e 20 20 28 (if domain (
23c0: 73 64 61 74 2d 73 65 74 2d 64 6f 6d 61 69 6e 21 sdat-set-domain!
23d0: 20 20 73 65 6c 66 20 64 6f 6d 61 69 6e 29 29 29 self domain)))
23e0: 29 0a 3b 3b 20 20 20 28 6c 65 74 20 28 28 64 62 ).;; (let ((db
23f0: 74 79 70 65 20 28 73 64 61 74 2d 67 65 74 2d 64 type (sdat-get-d
2400: 62 74 79 70 65 20 73 65 6c 66 29 29 29 0a 3b 3b btype self))).;;
2410: 20 20 20 20 20 28 70 72 69 6e 74 20 22 64 62 74 (print "dbt
2420: 79 70 65 3a 20 22 20 64 62 74 79 70 65 29 0a 3b ype: " dbtype).;
2430: 3b 20 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d ; (sdat-set-
2440: 64 62 74 79 70 65 21 20 73 65 6c 66 20 28 65 76 dbtype! self (ev
2450: 61 6c 20 64 62 74 79 70 65 29 29 29 29 0a 0a 28 al dbtype))))..(
2460: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
2470: 73 65 74 75 70 20 73 65 6c 66 29 0a 20 20 28 6c setup self). (l
2480: 65 74 20 28 28 64 62 74 79 70 65 20 28 73 64 61 et ((dbtype (sda
2490: 74 2d 67 65 74 2d 64 62 74 79 70 65 20 73 65 6c t-get-dbtype sel
24a0: 66 29 29 0a 09 28 64 62 69 6e 69 74 20 28 73 64 f))..(dbinit (sd
24b0: 61 74 2d 67 65 74 2d 64 62 69 6e 69 74 20 73 65 at-get-dbinit se
24c0: 6c 66 29 29 0a 09 28 64 62 65 78 69 73 74 73 20 lf))..(dbexists
24d0: 23 66 29 29 0a 20 20 20 20 28 6c 65 74 20 28 28 #f)). (let ((
24e0: 64 62 66 6e 61 6d 65 20 28 61 6c 69 73 74 2d 72 dbfname (alist-r
24f0: 65 66 20 27 64 62 6e 61 6d 65 20 64 62 69 6e 69 ef 'dbname dbini
2500: 74 29 29 29 0a 20 20 20 20 20 20 28 69 66 20 28 t))). (if (
2510: 65 71 3f 20 64 62 74 79 70 65 20 27 73 71 6c 69 eq? dbtype 'sqli
2520: 74 65 33 29 0a 09 20 20 28 69 66 20 28 66 69 6c te3).. (if (fil
2530: 65 2d 65 78 69 73 74 73 3f 20 64 62 66 6e 61 6d e-exists? dbfnam
2540: 65 29 0a 09 20 20 20 20 20 20 28 62 65 67 69 6e e).. (begin
2550: 0a 09 09 3b 3b 20 28 73 65 73 73 69 6f 6e 3a 6c ...;; (session:l
2560: 6f 67 20 73 65 6c 66 20 22 73 65 74 74 69 6e 67 og self "setting
2570: 20 64 62 65 78 69 73 74 73 20 74 6f 20 23 74 22 dbexists to #t"
2580: 29 0a 09 09 28 73 65 74 21 20 64 62 65 78 69 73 )...(set! dbexis
2590: 74 73 20 23 74 29 29 29 29 0a 20 20 20 20 20 20 ts #t)))).
25a0: 3b 3b 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 ;; (session:log
25b0: 73 65 6c 66 20 22 64 62 74 79 70 65 3a 20 22 20 self "dbtype: "
25c0: 64 62 74 79 70 65 20 22 20 64 62 66 6e 61 6d 65 dbtype " dbfname
25d0: 3a 20 22 20 64 62 66 6e 61 6d 65 20 22 20 64 62 : " dbfname " db
25e0: 65 78 69 73 74 73 3a 20 22 20 64 62 65 78 69 73 exists: " dbexis
25f0: 74 73 29 29 0a 20 20 20 20 20 20 29 0a 20 20 20 ts)). ).
2600: 20 28 73 64 61 74 2d 73 65 74 2d 63 6f 6e 6e 21 (sdat-set-conn!
2610: 20 73 65 6c 66 20 28 64 62 69 3a 6f 70 65 6e 20 self (dbi:open
2620: 64 62 74 79 70 65 20 64 62 69 6e 69 74 29 29 0a dbtype dbinit)).
2630: 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 6e 6f (if (and (no
2640: 74 20 64 62 65 78 69 73 74 73 29 28 65 71 3f 20 t dbexists)(eq?
2650: 64 62 74 79 70 65 20 27 73 71 6c 69 74 65 33 29 dbtype 'sqlite3)
2660: 29 0a 20 09 28 62 65 67 69 6e 0a 09 20 20 28 70 ). .(begin.. (p
2670: 72 69 6e 74 20 22 57 41 52 4e 49 4e 47 3a 20 53 rint "WARNING: S
2680: 65 74 74 69 6e 67 20 75 70 20 73 65 73 73 69 6f etting up sessio
2690: 6e 20 64 62 20 77 69 74 68 20 73 71 6c 69 74 65 n db with sqlite
26a0: 33 22 29 0a 09 20 20 28 73 65 73 73 69 6f 6e 3a 3").. (session:
26b0: 73 65 74 75 70 2d 64 62 20 73 65 6c 66 29 29 29 setup-db self)))
26c0: 0a 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 70 72 . (session:pr
26d0: 6f 63 65 73 73 2d 75 72 6c 2d 70 61 74 68 20 73 ocess-url-path s
26e0: 65 6c 66 29 0a 20 20 20 20 28 73 65 73 73 69 6f elf). (sessio
26f0: 6e 3a 73 65 74 75 70 2d 73 65 73 73 69 6f 6e 2d n:setup-session-
2700: 6b 65 79 20 73 65 6c 66 29 0a 20 20 20 20 3b 3b key self). ;;
2710: 20 63 61 70 74 75 72 65 20 73 74 64 69 6e 20 69 capture stdin i
2720: 66 20 74 68 69 73 20 69 73 20 61 20 50 4f 53 54 f this is a POST
2730: 0a 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d 72 . (sdat-set-r
2740: 65 71 75 65 73 74 2d 6d 65 74 68 6f 64 21 20 73 equest-method! s
2750: 65 6c 66 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e elf (get-environ
2760: 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 52 ment-variable "R
2770: 45 51 55 45 53 54 5f 4d 45 54 48 4f 44 22 29 29 EQUEST_METHOD"))
2780: 0a 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d 66 . (sdat-set-f
2790: 6f 72 6d 64 61 74 21 20 73 65 6c 66 20 28 66 6f ormdat! self (fo
27a0: 72 6d 64 61 74 3a 6c 6f 61 64 2d 61 6c 6c 29 29 rmdat:load-all))
27b0: 29 29 0a 0a 3b 3b 20 73 65 74 75 70 20 74 68 65 ))..;; setup the
27c0: 20 64 62 20 77 69 74 68 20 73 65 73 73 69 6f 6e db with session
27d0: 20 74 61 62 6c 65 73 2c 20 77 6f 72 6b 73 20 66 tables, works f
27e0: 6f 72 20 73 71 6c 69 74 65 20 6f 6e 6c 79 20 72 or sqlite only r
27f0: 69 67 68 74 20 6e 6f 77 0a 28 64 65 66 69 6e 65 ight now.(define
2800: 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 2d (session:setup-
2810: 64 62 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 20 db self). (let
2820: 28 28 63 6f 6e 6e 20 28 73 64 61 74 2d 67 65 74 ((conn (sdat-get
2830: 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 29 0a 20 20 -conn self))).
2840: 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 (for-each .
2850: 20 20 28 6c 61 6d 62 64 61 20 28 73 74 6d 74 29 (lambda (stmt)
2860: 0a 20 20 20 20 20 20 20 28 64 62 69 3a 65 78 65 . (dbi:exe
2870: 63 20 63 6f 6e 6e 20 73 74 6d 74 29 29 0a 20 20 c conn stmt)).
2880: 20 20 20 28 6c 69 73 74 20 22 43 52 45 41 54 45 (list "CREATE
2890: 20 54 41 42 4c 45 20 73 65 73 73 69 6f 6e 5f 76 TABLE session_v
28a0: 61 72 73 20 28 69 64 20 49 4e 54 45 47 45 52 20 ars (id INTEGER
28b0: 50 52 49 4d 41 52 59 20 4b 45 59 2c 73 65 73 73 PRIMARY KEY,sess
28c0: 69 6f 6e 5f 69 64 20 49 4e 54 45 47 45 52 2c 70 ion_id INTEGER,p
28d0: 61 67 65 20 54 45 58 54 2c 6b 65 79 20 54 45 58 age TEXT,key TEX
28e0: 54 2c 76 61 6c 75 65 20 54 45 58 54 29 3b 22 0a T,value TEXT);".
28f0: 09 20 20 20 22 43 52 45 41 54 45 20 54 41 42 4c . "CREATE TABL
2900: 45 20 73 65 73 73 69 6f 6e 73 20 28 69 64 20 49 E sessions (id I
2910: 4e 54 45 47 45 52 20 50 52 49 4d 41 52 59 20 4b NTEGER PRIMARY K
2920: 45 59 2c 73 65 73 73 69 6f 6e 5f 6b 65 79 20 54 EY,session_key T
2930: 45 58 54 2c 6c 61 73 74 5f 75 73 65 64 20 54 49 EXT,last_used TI
2940: 4d 45 53 54 41 4d 50 29 3b 22 0a 20 20 20 20 20 MESTAMP);".
2950: 20 20 20 20 20 20 22 43 52 45 41 54 45 20 54 41 "CREATE TA
2960: 42 4c 45 20 6d 65 74 61 64 61 74 61 20 28 69 64 BLE metadata (id
2970: 20 49 4e 54 45 47 45 52 20 50 52 49 4d 41 52 59 INTEGER PRIMARY
2980: 20 4b 45 59 2c 6b 65 79 20 54 45 58 54 2c 76 61 KEY,key TEXT,va
2990: 6c 75 65 20 54 45 58 54 29 3b 22 29 29 29 29 0a lue TEXT);")))).
29a0: 3b 3b 20 20 3b 3b 20 69 66 20 77 65 20 68 61 76 ;; ;; if we hav
29b0: 65 20 61 20 73 65 73 73 69 6f 6e 5f 6b 65 79 20 e a session_key
29c0: 6c 6f 6f 6b 20 75 70 20 74 68 65 20 73 65 73 73 look up the sess
29d0: 69 6f 6e 2d 69 64 20 61 6e 64 20 73 74 6f 72 65 ion-id and store
29e0: 20 69 74 0a 3b 3b 20 20 28 73 64 61 74 2d 73 65 it.;; (sdat-se
29f0: 74 2d 73 65 73 73 69 6f 6e 2d 69 64 21 20 73 65 t-session-id! se
2a00: 6c 66 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d lf (session:get-
2a10: 69 64 20 73 65 6c 66 29 29 29 0a 0a 3b 3b 20 6f id self)))..;; o
2a20: 6e 6c 79 20 73 65 74 20 73 65 73 73 69 6f 6e 2d nly set session-
2a30: 63 6f 6f 6b 69 65 20 77 68 65 6e 20 61 20 6e 65 cookie when a ne
2a40: 77 20 73 65 73 73 69 6f 6e 20 69 73 20 63 72 65 w session is cre
2a50: 61 74 65 64 0a 28 64 65 66 69 6e 65 20 28 73 65 ated.(define (se
2a60: 73 73 69 6f 6e 3a 73 65 74 75 70 2d 73 65 73 73 ssion:setup-sess
2a70: 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 20 20 0a ion-key self) .
2a80: 20 20 28 6c 65 74 2a 20 28 28 73 6b 20 20 28 73 (let* ((sk (s
2a90: 65 73 73 69 6f 6e 3a 65 78 74 72 61 63 74 2d 73 ession:extract-s
2aa0: 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 ession-key self)
2ab0: 29 0a 20 20 20 20 20 20 20 20 20 28 73 69 64 20 ). (sid
2ac0: 28 69 66 20 73 6b 20 28 73 65 73 73 69 6f 6e 3a (if sk (session:
2ad0: 67 65 74 2d 69 64 20 73 65 6c 66 20 73 6b 29 20 get-id self sk)
2ae0: 23 66 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e #f))). (if (n
2af0: 6f 74 20 73 69 64 29 20 3b 3b 20 6e 65 65 64 20 ot sid) ;; need
2b00: 61 20 6e 65 77 20 6b 65 79 0a 20 20 20 20 20 20 a new key.
2b10: 20 20 28 6c 65 74 2a 20 28 28 6e 65 77 2d 6b 65 (let* ((new-ke
2b20: 79 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 6e y (session:get-n
2b30: 65 77 2d 6b 65 79 20 73 65 6c 66 29 29 0a 20 20 ew-key self)).
2b40: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6e 65 (ne
2b50: 77 2d 73 69 64 20 28 73 65 73 73 69 6f 6e 3a 67 w-sid (session:g
2b60: 65 74 2d 69 64 20 73 65 6c 66 20 6e 65 77 2d 6b et-id self new-k
2b70: 65 79 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 ey))).
2b80: 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f (sdat-set-sessio
2b90: 6e 2d 6b 65 79 21 20 73 65 6c 66 20 6e 65 77 2d n-key! self new-
2ba0: 6b 65 79 29 0a 20 20 20 20 20 20 20 20 20 20 28 key). (
2bb0: 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e sdat-set-session
2bc0: 2d 69 64 21 20 73 65 6c 66 20 6e 65 77 2d 73 69 -id! self new-si
2bd0: 64 29 0a 20 20 20 20 20 20 20 20 20 20 28 73 64 d). (sd
2be0: 61 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e 2d 63 at-set-session-c
2bf0: 6f 6f 6b 69 65 21 20 73 65 6c 66 20 28 73 65 73 ookie! self (ses
2c00: 73 69 6f 6e 3a 6d 61 6b 65 2d 63 6f 6f 6b 69 65 sion:make-cookie
2c10: 20 73 65 6c 66 29 29 29 0a 20 20 20 20 20 20 20 self))).
2c20: 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 (sdat-set-sessi
2c30: 6f 6e 2d 69 64 21 20 73 65 6c 66 20 73 69 64 29 on-id! self sid)
2c40: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 )))..(define (se
2c50: 73 73 69 6f 6e 3a 6d 61 6b 65 2d 63 6f 6f 6b 69 ssion:make-cooki
2c60: 65 20 73 65 6c 66 29 0a 20 20 3b 3b 20 28 6c 69 e self). ;; (li
2c70: 73 74 20 28 63 6f 6e 63 20 22 73 65 73 73 69 6f st (conc "sessio
2c80: 6e 5f 6b 65 79 3d 22 20 28 73 64 61 74 2d 67 65 n_key=" (sdat-ge
2c90: 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 t-session-key se
2ca0: 6c 66 29 20 22 3b 20 50 61 74 68 3d 2f 3b 20 44 lf) "; Path=/; D
2cb0: 6f 6d 61 69 6e 3d 2e 22 20 28 73 64 61 74 2d 67 omain=." (sdat-g
2cc0: 65 74 2d 64 6f 6d 61 69 6e 20 73 65 6c 66 29 20 et-domain self)
2cd0: 22 3b 20 4d 61 78 2d 41 67 65 3d 22 20 28 2a 20 "; Max-Age=" (*
2ce0: 38 36 34 30 30 20 31 34 29 20 22 3b 20 56 65 72 86400 14) "; Ver
2cf0: 73 69 6f 6e 3d 31 22 29 29 29 20 0a 20 20 28 6c sion=1"))) . (l
2d00: 69 73 74 20 28 73 74 72 69 6e 67 2d 73 75 62 73 ist (string-subs
2d10: 74 69 74 75 74 65 20 0a 09 20 22 3b 22 20 22 3b titute .. ";" ";
2d20: 20 22 20 0a 09 20 28 63 61 72 20 28 63 6f 6e 73 " .. (car (cons
2d30: 74 72 75 63 74 2d 63 6f 6f 6b 69 65 2d 73 74 72 truct-cookie-str
2d40: 69 6e 67 20 0a 09 20 20 20 20 20 20 20 3b 3b 20 ing .. ;;
2d50: 77 61 72 6e 69 6e 67 21 20 6d 65 73 73 69 6e 67 warning! messing
2d60: 20 75 70 20 74 68 69 73 20 69 74 74 79 20 62 69 up this itty bi
2d70: 74 74 79 20 62 69 74 20 6f 66 20 63 6f 64 65 20 tty bit of code
2d80: 77 69 6c 6c 20 63 6f 73 74 20 6d 75 63 68 20 74 will cost much t
2d90: 69 6d 65 21 0a 09 20 20 20 20 20 20 20 60 28 28 ime!.. `((
2da0: 22 73 65 73 73 69 6f 6e 5f 6b 65 79 22 20 2c 28 "session_key" ,(
2db0: 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e sdat-get-session
2dc0: 2d 6b 65 79 20 73 65 6c 66 29 0a 09 09 20 20 65 -key self)... e
2dd0: 78 70 69 72 65 73 3a 20 2c 28 2b 20 28 63 75 72 xpires: ,(+ (cur
2de0: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 28 2a rent-seconds) (*
2df0: 20 31 34 20 38 36 34 30 30 29 29 20 0a 09 09 20 14 86400)) ...
2e00: 20 6d 61 78 2d 61 67 65 3a 20 28 2a 20 31 34 20 max-age: (* 14
2e10: 38 36 34 30 30 29 0a 09 09 20 20 70 61 74 68 3a 86400)... path:
2e20: 20 22 2f 22 20 3b 3b 20 0a 09 09 20 20 64 6f 6d "/" ;; ... dom
2e30: 61 69 6e 3a 20 2c 28 73 74 72 69 6e 67 2d 61 70 ain: ,(string-ap
2e40: 70 65 6e 64 20 22 2e 22 20 28 73 64 61 74 2d 67 pend "." (sdat-g
2e50: 65 74 2d 64 6f 6d 61 69 6e 20 73 65 6c 66 29 29 et-domain self))
2e60: 0a 09 09 20 20 76 65 72 73 69 6f 6e 3a 20 31 29 ... version: 1)
2e70: 29 20 30 29 29 29 29 29 0a 0a 3b 3b 20 6c 6f 6f ) 0)))))..;; loo
2e80: 6b 20 75 70 20 61 20 67 69 76 65 6e 20 73 65 73 k up a given ses
2e90: 73 69 6f 6e 20 6b 65 79 20 61 6e 64 20 72 65 74 sion key and ret
2ea0: 75 72 6e 20 74 68 65 20 69 64 20 69 66 20 66 6f urn the id if fo
2eb0: 75 6e 64 2c 20 23 66 20 69 66 20 6e 6f 74 20 66 und, #f if not f
2ec0: 6f 75 6e 64 0a 28 64 65 66 69 6e 65 20 28 73 65 ound.(define (se
2ed0: 73 73 69 6f 6e 3a 67 65 74 2d 69 64 20 73 65 6c ssion:get-id sel
2ee0: 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 0a 20 f session-key).
2ef0: 20 3b 3b 20 28 6c 65 74 20 28 28 73 65 73 73 69 ;; (let ((sessi
2f00: 6f 6e 2d 6b 65 79 20 28 73 64 61 74 2d 67 65 74 on-key (sdat-get
2f10: 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c -session-key sel
2f20: 66 29 29 29 0a 20 20 28 69 66 20 73 65 73 73 69 f))). (if sessi
2f30: 6f 6e 2d 6b 65 79 0a 20 20 20 20 20 20 28 6c 65 on-key. (le
2f40: 74 20 28 28 71 75 65 72 79 20 28 73 74 72 69 6e t ((query (strin
2f50: 67 2d 61 70 70 65 6e 64 20 22 53 45 4c 45 43 54 g-append "SELECT
2f60: 20 69 64 20 46 52 4f 4d 20 73 65 73 73 69 6f 6e id FROM session
2f70: 73 20 57 48 45 52 45 20 73 65 73 73 69 6f 6e 5f s WHERE session_
2f80: 6b 65 79 3d 27 22 20 73 65 73 73 69 6f 6e 2d 6b key='" session-k
2f90: 65 79 20 22 27 22 29 29 0a 20 20 20 20 20 20 20 ey "'")).
2fa0: 20 20 20 20 20 28 63 6f 6e 6e 20 28 73 64 61 74 (conn (sdat
2fb0: 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 -get-conn self))
2fc0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 72 65 . (re
2fd0: 73 75 6c 74 20 23 66 29 29 0a 09 28 64 62 69 3a sult #f))..(dbi:
2fe0: 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 0a 09 20 for-each-row ..
2ff0: 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 29 0a (lambda (tuple).
3000: 09 20 20 20 28 73 65 74 21 20 72 65 73 75 6c 74 . (set! result
3010: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 (vector-ref tup
3020: 6c 65 20 30 29 29 29 0a 09 20 63 6f 6e 6e 20 71 le 0))).. conn q
3030: 75 65 72 79 29 0a 09 28 69 66 20 72 65 73 75 6c uery)..(if resul
3040: 74 20 28 64 62 69 3a 65 78 65 63 20 63 6f 6e 6e t (dbi:exec conn
3050: 20 28 63 6f 6e 63 20 22 55 50 44 41 54 45 20 73 (conc "UPDATE s
3060: 65 73 73 69 6f 6e 73 20 53 45 54 20 6c 61 73 74 essions SET last
3070: 5f 75 73 65 64 3d 22 20 28 64 62 69 3a 6e 6f 77 _used=" (dbi:now
3080: 20 63 6f 6e 6e 29 20 22 20 57 48 45 52 45 20 73 conn) " WHERE s
3090: 65 73 73 69 6f 6e 5f 6b 65 79 3d 3f 3b 22 29 20 ession_key=?;")
30a0: 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 0a 20 20 session-key)).
30b0: 20 20 20 20 20 20 72 65 73 75 6c 74 29 0a 20 20 result).
30c0: 20 20 20 20 23 66 29 29 0a 0a 3b 3b 20 0a 28 64 #f))..;; .(d
30d0: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 70 efine (session:p
30e0: 72 6f 63 65 73 73 2d 75 72 6c 2d 70 61 74 68 20 rocess-url-path
30f0: 73 65 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 70 self). (let ((p
3100: 61 74 68 2d 69 6e 66 6f 20 20 20 20 28 67 65 74 ath-info (get
3110: 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 -environment-var
3120: 69 61 62 6c 65 20 22 50 41 54 48 5f 49 4e 46 4f iable "PATH_INFO
3130: 22 29 29 0a 09 28 71 75 65 72 79 2d 73 74 72 69 "))..(query-stri
3140: 6e 67 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d ng (get-environm
3150: 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 51 55 ent-variable "QU
3160: 45 52 59 5f 53 54 52 49 4e 47 22 29 29 29 0a 20 ERY_STRING"))).
3170: 20 20 20 3b 3b 20 28 73 65 73 73 69 6f 6e 3a 6c ;; (session:l
3180: 6f 67 20 73 65 6c 66 20 22 70 61 74 68 2d 69 6e og self "path-in
3190: 66 6f 3d 22 20 70 61 74 68 2d 69 6e 66 6f 20 22 fo=" path-info "
31a0: 20 71 75 65 72 79 2d 73 74 72 69 6e 67 3d 22 20 query-string="
31b0: 71 75 65 72 79 2d 73 74 72 69 6e 67 29 0a 20 20 query-string).
31c0: 20 20 28 69 66 20 70 61 74 68 2d 69 6e 66 6f 0a (if path-info.
31d0: 09 28 6c 65 74 2a 20 28 28 70 61 72 74 73 20 20 .(let* ((parts
31e0: 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 (string-split
31f0: 70 61 74 68 2d 69 6e 66 6f 20 22 2f 22 29 29 0a path-info "/")).
3200: 09 20 20 20 20 20 20 20 28 6e 75 6d 70 61 72 74 . (numpart
3210: 73 20 28 6c 65 6e 67 74 68 20 70 61 72 74 73 29 s (length parts)
3220: 29 29 0a 09 20 20 28 69 66 20 28 3e 20 6e 75 6d )).. (if (> num
3230: 70 61 72 74 73 20 30 29 0a 09 20 20 20 20 20 20 parts 0)..
3240: 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 21 20 (sdat-set-page!
3250: 73 65 6c 66 20 28 63 61 72 20 70 61 72 74 73 29 self (car parts)
3260: 29 29 0a 09 20 20 3b 3b 20 28 73 65 73 73 69 6f )).. ;; (sessio
3270: 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 75 72 6c 2d n:log self "url-
3280: 70 61 74 68 3d 22 20 75 72 6c 2d 70 61 74 68 20 path=" url-path
3290: 22 20 70 61 72 74 73 3d 22 20 70 61 72 74 73 29 " parts=" parts)
32a0: 0a 09 20 20 28 69 66 20 28 3e 20 6e 75 6d 70 61 .. (if (> numpa
32b0: 72 74 73 20 31 29 0a 09 20 20 20 20 20 20 28 73 rts 1).. (s
32c0: 64 61 74 2d 73 65 74 2d 70 61 74 68 2d 70 61 72 dat-set-path-par
32d0: 61 6d 73 21 20 73 65 6c 66 20 28 63 64 72 20 70 ams! self (cdr p
32e0: 61 72 74 73 29 29 29 0a 20 20 20 20 20 20 20 20 arts))).
32f0: 20 20 28 69 66 20 71 75 65 72 79 2d 73 74 72 69 (if query-stri
3300: 6e 67 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ng.
3310: 20 28 73 64 61 74 2d 73 65 74 2d 70 61 72 61 6d (sdat-set-param
3320: 73 21 20 73 65 6c 66 20 28 73 74 72 69 6e 67 2d s! self (string-
3330: 73 70 6c 69 74 20 71 75 65 72 79 2d 73 74 72 69 split query-stri
3340: 6e 67 20 22 26 22 29 29 29 29 29 29 29 0a 0a 3b ng "&")))))))..;
3350: 3b 20 42 55 47 47 59 21 0a 28 64 65 66 69 6e 65 ; BUGGY!.(define
3360: 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 6e 65 (session:get-ne
3370: 77 2d 6b 65 79 20 73 65 6c 66 29 0a 20 20 28 6c w-key self). (l
3380: 65 74 20 28 28 63 6f 6e 6e 20 20 20 28 73 64 61 et ((conn (sda
3390: 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 t-get-conn self)
33a0: 29 0a 20 20 20 20 20 20 20 20 28 74 6d 70 6b 65 ). (tmpke
33b0: 79 20 28 73 65 73 73 69 6f 6e 3a 6d 61 6b 65 2d y (session:make-
33c0: 72 61 6e 64 2d 73 74 72 69 6e 67 20 32 30 29 29 rand-string 20))
33d0: 0a 20 20 20 20 20 20 20 20 28 73 74 61 74 75 73 . (status
33e0: 20 23 66 29 29 0a 20 20 20 20 28 64 62 69 3a 66 #f)). (dbi:f
33f0: 6f 72 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 6d or-each-row (lam
3400: 62 64 61 20 28 74 75 70 6c 65 29 0a 09 09 09 28 bda (tuple)....(
3410: 73 65 74 21 20 73 74 61 74 75 73 20 23 74 29 29 set! status #t))
3420: 0a 09 09 20 20 20 20 20 20 63 6f 6e 6e 20 28 73 ... conn (s
3430: 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 22 49 4e tring-append "IN
3440: 53 45 52 54 20 49 4e 54 4f 20 73 65 73 73 69 6f SERT INTO sessio
3450: 6e 73 20 28 73 65 73 73 69 6f 6e 5f 6b 65 79 29 ns (session_key)
3460: 20 56 41 4c 55 45 53 20 28 27 22 20 74 6d 70 6b VALUES ('" tmpk
3470: 65 79 20 22 27 29 22 29 29 0a 20 20 20 20 74 6d ey "')")). tm
3480: 70 6b 65 79 29 29 0a 0a 3b 3b 20 72 65 74 75 72 pkey))..;; retur
3490: 6e 73 20 73 65 73 73 69 6f 6e 20 6b 65 79 20 49 ns session key I
34a0: 46 46 20 69 74 20 69 73 20 69 6e 20 74 68 65 20 FF it is in the
34b0: 48 54 54 50 5f 43 4f 4f 4b 49 45 20 0a 28 64 65 HTTP_COOKIE .(de
34c0: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 65 78 fine (session:ex
34d0: 74 72 61 63 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 tract-session-ke
34e0: 79 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 20 28 y self). (let (
34f0: 28 68 74 74 70 2d 73 65 73 73 69 6f 6e 20 28 67 (http-session (g
3500: 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 et-environment-v
3510: 61 72 69 61 62 6c 65 20 22 48 54 54 50 5f 43 4f ariable "HTTP_CO
3520: 4f 4b 49 45 22 29 29 29 0a 20 20 20 20 28 69 66 OKIE"))). (if
3530: 20 68 74 74 70 2d 73 65 73 73 69 6f 6e 20 0a 20 http-session .
3540: 20 20 20 20 20 20 20 28 73 65 73 73 69 6f 6e 3a (session:
3550: 65 78 74 72 61 63 74 2d 6b 65 79 2d 66 72 6f 6d extract-key-from
3560: 2d 70 61 72 61 6d 20 73 65 6c 66 20 28 6c 69 73 -param self (lis
3570: 74 20 68 74 74 70 2d 73 65 73 73 69 6f 6e 29 20 t http-session)
3580: 22 73 65 73 73 69 6f 6e 5f 6b 65 79 22 29 0a 20 "session_key").
3590: 20 20 20 20 20 20 20 23 66 29 29 29 0a 0a 28 64 #f)))..(d
35a0: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 efine (session:g
35b0: 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 et-session-id se
35c0: 6c 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 0a lf session-key).
35d0: 20 20 28 6c 65 74 20 28 28 71 75 65 72 79 20 22 (let ((query "
35e0: 53 45 4c 45 43 54 20 69 64 20 46 52 4f 4d 20 73 SELECT id FROM s
35f0: 65 73 73 69 6f 6e 73 20 57 48 45 52 45 20 73 65 essions WHERE se
3600: 73 73 69 6f 6e 5f 6b 65 79 3d 3f 3b 22 29 0a 20 ssion_key=?;").
3610: 20 20 20 20 20 20 20 28 72 65 73 75 6c 74 20 23 (result #
3620: 66 29 29 0a 20 20 20 20 3b 3b 20 20 20 20 20 28 f)). ;; (
3630: 70 67 3a 71 75 65 72 79 2d 66 6f 72 2d 65 61 63 pg:query-for-eac
3640: 68 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 h (lambda (tuple
3650: 29 0a 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 ). ;;
3660: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3670: 20 20 28 73 65 74 21 20 72 65 73 75 6c 74 20 28 (set! result (
3680: 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 vector-ref tuple
3690: 20 30 29 29 29 20 3b 3b 20 28 76 65 63 74 6f 72 0))) ;; (vector
36a0: 2d 72 65 66 20 74 75 70 6c 65 20 30 29 29 29 0a -ref tuple 0))).
36b0: 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 ;;
36c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
36d0: 3a 73 71 6c 70 61 72 61 6d 20 71 75 65 72 79 20 :sqlparam query
36e0: 73 65 73 73 69 6f 6e 2d 6b 65 79 29 0a 20 20 20 session-key).
36f0: 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
3700: 20 20 20 20 20 20 20 20 20 20 20 28 73 64 61 74 (sdat
3710: 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 -get-conn self))
3720: 0a 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 . ;;
3730: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 63 c
3740: 6f 6e 6e 29 0a 20 20 20 20 28 64 62 69 3a 66 6f onn). (dbi:fo
3750: 72 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 6d 62 r-each-row (lamb
3760: 64 61 20 28 74 75 70 6c 65 29 0a 09 09 09 28 73 da (tuple)....(s
3770: 65 74 21 20 72 65 73 75 6c 74 20 28 76 65 63 74 et! result (vect
3780: 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 30 29 29 or-ref tuple 0))
3790: 29 20 3b 3b 20 28 76 65 63 74 6f 72 2d 72 65 66 ) ;; (vector-ref
37a0: 20 74 75 70 6c 65 20 30 29 29 29 0a 09 09 20 20 tuple 0)))...
37b0: 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d 63 6f (sdat-get-co
37c0: 6e 6e 20 73 65 6c 66 29 0a 09 09 20 20 20 20 20 nn self)...
37d0: 20 28 73 3a 73 71 6c 70 61 72 61 6d 20 71 75 65 (s:sqlparam que
37e0: 72 79 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 ry session-key))
37f0: 0a 20 20 20 20 72 65 73 75 6c 74 29 29 0a 0a 3b . result))..;
3800: 3b 20 64 65 6c 65 74 65 20 61 6c 6c 20 72 65 63 ; delete all rec
3810: 6f 72 64 73 20 66 6f 72 20 61 20 73 65 73 73 69 ords for a sessi
3820: 6f 6e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 on.;;.(define (s
3830: 65 73 73 69 6f 6e 3a 64 65 6c 65 74 65 2d 73 65 ession:delete-se
3840: 73 73 69 6f 6e 20 73 65 6c 66 20 73 65 73 73 69 ssion self sessi
3850: 6f 6e 2d 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 on-key). (let (
3860: 28 73 65 73 73 69 6f 6e 2d 69 64 20 28 73 65 73 (session-id (ses
3870: 73 69 6f 6e 3a 67 65 74 2d 73 65 73 73 69 6f 6e sion:get-session
3880: 2d 69 64 20 73 65 6c 66 20 73 65 73 73 69 6f 6e -id self session
3890: 2d 6b 65 79 29 29 0a 20 20 20 20 20 20 20 20 28 -key)). (
38a0: 71 72 79 20 20 20 20 20 20 20 20 28 63 6f 6e 63 qry (conc
38b0: 20 22 42 45 47 49 4e 3b 22 0a 09 09 09 20 20 22 "BEGIN;".... "
38c0: 44 45 4c 45 54 45 20 46 52 4f 4d 20 73 65 73 73 DELETE FROM sess
38d0: 69 6f 6e 5f 76 61 72 73 20 57 48 45 52 45 20 73 ion_vars WHERE s
38e0: 65 73 73 69 6f 6e 5f 69 64 3d 3f 3b 22 0a 20 20 ession_id=?;".
38f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3900: 20 20 20 20 20 20 20 20 22 44 45 4c 45 54 45 20 "DELETE
3910: 46 52 4f 4d 20 73 65 73 73 69 6f 6e 73 20 57 48 FROM sessions WH
3920: 45 52 45 20 69 64 3d 3f 3b 22 0a 09 09 09 20 20 ERE id=?;"....
3930: 22 43 4f 4d 4d 49 54 3b 22 29 29 0a 20 20 20 20 "COMMIT;")).
3940: 20 20 20 20 28 63 6f 6e 6e 20 20 20 20 20 20 20 (conn
3950: 20 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 (sdat-get
3960: 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 29 0a 20 20 -conn self))).
3970: 20 20 28 69 66 20 73 65 73 73 69 6f 6e 2d 69 64 (if session-id
3980: 0a 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a . (begin.
3990: 20 20 20 20 20 20 20 20 20 20 28 64 62 69 3a 65 (dbi:e
39a0: 78 65 63 20 63 6f 6e 6e 20 71 72 79 20 73 65 73 xec conn qry ses
39b0: 73 69 6f 6e 2d 69 64 20 73 65 73 73 69 6f 6e 2d sion-id session-
39c0: 69 64 29 0a 09 20 20 28 73 65 73 73 69 6f 6e 3a id).. (session:
39d0: 69 6e 69 74 69 61 6c 69 7a 65 20 73 65 6c 66 29 initialize self)
39e0: 0a 09 20 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 .. (session:set
39f0: 75 70 20 73 65 6c 66 29 29 29 0a 20 20 20 20 28 up self))). (
3a00: 6e 6f 74 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 not (session:get
3a10: 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 -session-id self
3a20: 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 29 29 session-key))))
3a30: 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 65 ..;; (define (se
3a40: 73 73 69 6f 6e 3a 64 65 6c 65 74 65 2d 73 65 73 ssion:delete-ses
3a50: 73 69 6f 6e 20 73 65 6c 66 20 73 65 73 73 69 6f sion self sessio
3a60: 6e 2d 6b 65 79 29 0a 3b 3b 20 20 20 28 6c 65 74 n-key).;; (let
3a70: 20 28 28 73 65 73 73 69 6f 6e 2d 69 64 20 28 73 ((session-id (s
3a80: 65 73 73 69 6f 6e 3a 67 65 74 2d 73 65 73 73 69 ession:get-sessi
3a90: 6f 6e 2d 69 64 20 73 65 6c 66 20 73 65 73 73 69 on-id self sessi
3aa0: 6f 6e 2d 6b 65 79 29 29 0a 3b 3b 20 20 20 20 20 on-key)).;;
3ab0: 20 20 20 20 28 71 75 65 72 69 65 73 20 20 20 20 (queries
3ac0: 28 6c 69 73 74 20 22 42 45 47 49 4e 3b 22 0a 3b (list "BEGIN;".;
3ad0: 3b 20 09 09 09 20 20 22 44 45 4c 45 54 45 20 46 ; ... "DELETE F
3ae0: 52 4f 4d 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 ROM session_vars
3af0: 20 57 48 45 52 45 20 73 65 73 73 69 6f 6e 5f 69 WHERE session_i
3b00: 64 3d 3f 3b 22 0a 3b 3b 20 20 20 20 20 20 20 20 d=?;".;;
3b10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3b20: 20 20 20 22 44 45 4c 45 54 45 20 46 52 4f 4d 20 "DELETE FROM
3b30: 73 65 73 73 69 6f 6e 73 20 57 48 45 52 45 20 69 sessions WHERE i
3b40: 64 3d 3f 3b 22 0a 3b 3b 20 09 09 09 20 20 22 43 d=?;".;; ... "C
3b50: 4f 4d 4d 49 54 3b 22 29 29 0a 3b 3b 20 20 20 20 OMMIT;")).;;
3b60: 20 20 20 20 20 28 63 6f 6e 6e 20 20 20 20 20 20 (conn
3b70: 20 20 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 (sdat-ge
3b80: 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 29 0a 3b t-conn self))).;
3b90: 3b 20 20 20 20 20 28 69 66 20 73 65 73 73 69 6f ; (if sessio
3ba0: 6e 2d 69 64 0a 3b 3b 20 20 20 20 20 20 20 20 20 n-id.;;
3bb0: 28 62 65 67 69 6e 0a 3b 3b 20 20 20 20 20 20 20 (begin.;;
3bc0: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 3b 3b (for-each.;;
3bd0: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 61 6d (lam
3be0: 62 64 61 20 28 71 75 65 72 79 29 0a 3b 3b 20 20 bda (query).;;
3bf0: 20 20 20 20 20 20 20 20 20 20 20 20 28 64 62 69 (dbi
3c00: 3a 65 78 65 63 20 63 6f 6e 6e 20 71 75 65 72 79 :exec conn query
3c10: 20 73 65 73 73 69 6f 6e 2d 69 64 29 29 0a 3b 3b session-id)).;;
3c20: 20 09 20 20 20 71 75 65 72 69 65 73 29 0a 3b 3b . queries).;;
3c30: 20 09 20 20 28 69 6e 69 74 69 61 6c 69 7a 65 20 . (initialize
3c40: 73 65 6c 66 20 27 28 29 29 0a 3b 3b 20 09 20 20 self '()).;; .
3c50: 28 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 20 73 (session:setup s
3c60: 65 6c 66 29 29 29 0a 3b 3b 20 20 20 20 20 28 6e elf))).;; (n
3c70: 6f 74 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d ot (session:get-
3c80: 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 20 session-id self
3c90: 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 29 29 0a session-key)))).
3ca0: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
3cb0: 6e 3a 65 78 74 72 61 63 74 2d 6b 65 79 20 73 65 n:extract-key se
3cc0: 6c 66 20 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 lf key). (let (
3cd0: 28 70 61 72 61 6d 73 20 28 73 64 61 74 2d 67 65 (params (sdat-ge
3ce0: 74 2d 70 61 72 61 6d 73 20 73 65 6c 66 29 29 29 t-params self)))
3cf0: 0a 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 65 78 . (session:ex
3d00: 74 72 61 63 74 2d 6b 65 79 2d 66 72 6f 6d 2d 70 tract-key-from-p
3d10: 61 72 61 6d 20 73 65 6c 66 20 70 61 72 61 6d 73 aram self params
3d20: 20 6b 65 79 29 29 29 0a 0a 28 64 65 66 69 6e 65 key)))..(define
3d30: 20 28 73 65 73 73 69 6f 6e 3a 65 78 74 72 61 63 (session:extrac
3d40: 74 2d 6b 65 79 2d 66 72 6f 6d 2d 70 61 72 61 6d t-key-from-param
3d50: 20 73 65 6c 66 20 70 61 72 61 6d 73 20 6b 65 79 self params key
3d60: 29 0a 20 20 28 6c 65 74 20 28 28 72 31 20 20 20 ). (let ((r1
3d70: 20 20 28 72 65 67 65 78 70 20 28 73 74 72 69 6e (regexp (strin
3d80: 67 2d 61 70 70 65 6e 64 20 22 5e 22 20 6b 65 79 g-append "^" key
3d90: 20 22 3d 28 5b 5e 3d 5d 2b 29 24 22 29 29 29 29 "=([^=]+)$"))))
3da0: 0a 20 20 20 20 28 69 66 20 28 3c 20 28 6c 65 6e . (if (< (len
3db0: 67 74 68 20 70 61 72 61 6d 73 29 20 31 29 20 23 gth params) 1) #
3dc0: 66 0a 09 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 f..(let loop ((h
3dd0: 65 61 64 20 20 20 28 63 61 72 20 70 61 72 61 6d ead (car param
3de0: 73 29 29 0a 09 09 20 20 20 28 74 61 69 6c 20 20 s))... (tail
3df0: 20 28 63 64 72 20 70 61 72 61 6d 73 29 29 29 0a (cdr params))).
3e00: 09 20 20 28 6c 65 74 20 28 28 6d 61 74 63 68 20 . (let ((match
3e10: 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 72 31 (string-match r1
3e20: 20 68 65 61 64 29 29 29 0a 09 20 20 20 20 28 63 head))).. (c
3e30: 6f 6e 64 0a 09 20 20 20 20 20 28 6d 61 74 63 68 ond.. (match
3e40: 0a 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 73 .. (let ((s
3e50: 65 73 73 69 6f 6e 2d 6b 65 79 20 28 6c 69 73 74 ession-key (list
3e60: 2d 72 65 66 20 6d 61 74 63 68 20 31 29 29 29 0a -ref match 1))).
3e70: 09 09 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 ..(sdat-set-sess
3e80: 69 6f 6e 2d 6b 65 79 21 20 73 65 6c 66 20 28 6c ion-key! self (l
3e90: 69 73 74 2d 72 65 66 20 6d 61 74 63 68 20 31 29 ist-ref match 1)
3ea0: 29 0a 09 09 73 65 73 73 69 6f 6e 2d 6b 65 79 29 )...session-key)
3eb0: 29 0a 09 20 20 20 20 20 28 28 6e 75 6c 6c 3f 20 ).. ((null?
3ec0: 74 61 69 6c 29 0a 09 20 20 20 20 20 20 23 66 29 tail).. #f)
3ed0: 0a 09 20 20 20 20 20 28 65 6c 73 65 0a 09 20 20 .. (else..
3ee0: 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 (loop (car t
3ef0: 61 69 6c 29 0a 09 09 20 20 20 20 28 63 64 72 20 ail)... (cdr
3f00: 74 61 69 6c 29 29 29 29 29 29 29 29 29 0a 0a 28 tail)))))))))..(
3f10: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
3f20: 73 65 74 2d 70 61 67 65 21 20 73 65 6c 66 20 70 set-page! self p
3f30: 61 67 65 5f 6e 61 6d 65 29 0a 20 20 28 73 64 61 age_name). (sda
3f40: 74 2d 73 65 74 2d 70 61 67 65 21 20 73 65 6c 66 t-set-page! self
3f50: 20 70 61 67 65 5f 6e 61 6d 65 29 29 0a 0a 28 64 page_name))..(d
3f60: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 63 efine (session:c
3f70: 6c 6f 73 65 20 73 65 6c 66 29 0a 20 20 28 64 62 lose self). (db
3f80: 69 3a 63 6c 6f 73 65 20 28 73 64 61 74 2d 67 65 i:close (sdat-ge
3f90: 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 29 0a 3b t-conn self))).;
3fa0: 3b 20 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d ; (close-output-
3fb0: 70 6f 72 74 20 28 73 64 61 74 2d 67 65 74 2d 6c port (sdat-get-l
3fc0: 6f 67 70 74 20 73 65 6c 66 29 29 0a 0a 28 64 65 ogpt self))..(de
3fd0: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 65 72 fine (session:er
3fe0: 72 2d 6d 73 67 20 73 65 6c 66 20 6d 73 67 29 0a r-msg self msg).
3ff0: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
4000: 74 21 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 t! (sdat-get-ses
4010: 73 69 6f 6e 76 61 72 73 20 73 65 6c 66 29 20 22 sionvars self) "
4020: 45 52 52 4f 52 5f 4d 53 47 22 0a 09 09 20 20 20 ERROR_MSG"...
4030: 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
4040: 72 73 65 20 28 6d 61 70 20 73 3a 61 6e 79 2d 3e rse (map s:any->
4050: 73 74 72 69 6e 67 20 6d 73 67 29 20 22 20 22 29 string msg) " ")
4060: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 ))..(define (ses
4070: 73 69 6f 6e 3a 70 72 65 76 2d 65 72 72 20 73 65 sion:prev-err se
4080: 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 70 72 65 lf). (let ((pre
4090: 76 2d 65 72 72 20 28 68 61 73 68 2d 74 61 62 6c v-err (hash-tabl
40a0: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 28 73 e-ref/default (s
40b0: 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 dat-get-sessionv
40c0: 61 72 73 2d 62 65 66 6f 72 65 20 73 65 6c 66 29 ars-before self)
40d0: 20 22 45 52 52 4f 52 5f 4d 53 47 22 20 23 66 29 "ERROR_MSG" #f)
40e0: 29 0a 09 28 63 75 72 72 2d 65 72 72 20 28 68 61 )..(curr-err (ha
40f0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
4100: 61 75 6c 74 20 28 73 64 61 74 2d 67 65 74 2d 73 ault (sdat-get-s
4110: 65 73 73 69 6f 6e 76 61 72 73 20 73 65 6c 66 29 essionvars self)
4120: 20 22 45 52 52 4f 52 5f 4d 53 47 22 20 23 66 29 "ERROR_MSG" #f)
4130: 29 29 0a 20 20 20 20 28 69 66 20 70 72 65 76 2d )). (if prev-
4140: 65 72 72 20 70 72 65 76 2d 65 72 72 0a 09 28 69 err prev-err..(i
4150: 66 20 63 75 72 72 2d 65 72 72 20 63 75 72 72 2d f curr-err curr-
4160: 65 72 72 20 23 66 29 29 29 29 0a 0a 3b 3b 20 73 err #f))))..;; s
4170: 65 73 73 69 6f 6e 20 76 61 72 73 0a 3b 3b 20 31 ession vars.;; 1
4180: 2e 20 6b 65 79 73 20 61 72 65 20 61 6c 77 61 79 . keys are alway
4190: 73 20 61 20 73 74 72 69 6e 67 20 4e 4f 54 20 61 s a string NOT a
41a0: 20 73 79 6d 62 6f 6c 0a 3b 3b 20 32 2e 20 76 61 symbol.;; 2. va
41b0: 6c 75 65 73 20 61 72 65 20 61 6c 77 61 79 73 20 lues are always
41c0: 61 20 73 74 72 69 6e 67 20 63 6f 6e 76 65 72 73 a string convers
41d0: 69 6f 6e 20 69 73 20 74 68 65 20 72 65 73 70 6f ion is the respo
41e0: 6e 73 69 62 69 6c 69 74 79 20 6f 66 20 74 68 65 nsibility of the
41f0: 20 0a 3b 3b 20 20 20 20 63 6f 6e 73 75 6d 69 6e .;; consumin
4200: 67 20 66 75 6e 63 74 69 6f 6e 20 28 61 74 20 6c g function (at l
4210: 65 61 73 74 20 66 6f 72 20 6e 6f 77 2c 20 49 27 east for now, I'
4220: 64 20 6c 69 6b 65 20 74 6f 20 63 68 61 6e 67 65 d like to change
4230: 20 74 68 69 73 29 0a 0a 3b 3b 20 73 65 74 20 61 this)..;; set a
4240: 20 73 65 73 73 69 6f 6e 20 76 61 72 20 66 6f 72 session var for
4250: 20 74 68 65 20 63 75 72 72 65 6e 74 20 70 61 67 the current pag
4260: 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 e.;;.(define (se
4270: 73 73 69 6f 6e 3a 73 65 74 21 20 73 65 6c 66 20 ssion:set! self
4280: 6b 65 79 20 76 61 6c 75 65 29 0a 20 20 28 68 61 key value). (ha
4290: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 28 73 sh-table-set! (s
42a0: 64 61 74 2d 67 65 74 2d 70 61 67 65 76 61 72 73 dat-get-pagevars
42b0: 20 73 65 6c 66 29 20 28 73 3a 61 6e 79 2d 3e 73 self) (s:any->s
42c0: 74 72 69 6e 67 20 6b 65 79 29 20 28 73 3a 61 6e tring key) (s:an
42d0: 79 2d 3e 73 74 72 69 6e 67 20 76 61 6c 75 65 29 y->string value)
42e0: 29 29 0a 0a 3b 3b 20 64 65 6c 20 61 20 76 61 72 ))..;; del a var
42f0: 20 66 6f 72 20 74 68 65 20 63 75 72 72 65 6e 74 for the current
4300: 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 page.;;.(define
4310: 20 28 73 65 73 73 69 6f 6e 3a 64 65 6c 21 20 73 (session:del! s
4320: 65 6c 66 20 6b 65 79 29 0a 20 20 28 68 61 73 68 elf key). (hash
4330: 2d 74 61 62 6c 65 2d 64 65 6c 65 74 65 21 20 28 -table-delete! (
4340: 73 64 61 74 2d 67 65 74 2d 70 61 67 65 76 61 72 sdat-get-pagevar
4350: 73 20 73 65 6c 66 29 20 28 73 3a 61 6e 79 2d 3e s self) (s:any->
4360: 73 74 72 69 6e 67 20 6b 65 79 29 29 29 0a 0a 3b string key)))..;
4370: 3b 20 67 65 74 20 74 68 65 20 61 70 70 72 6f 70 ; get the approp
4380: 72 69 61 74 65 20 68 61 73 68 20 67 69 76 65 6e riate hash given
4390: 20 61 20 70 61 67 65 20 22 2a 73 65 73 73 69 6f a page "*sessio
43a0: 6e 76 61 72 73 2a 2c 20 2a 67 6c 6f 62 61 6c 76 nvars*, *globalv
43b0: 61 72 73 2a 20 6f 72 20 70 61 67 65 0a 3b 3b 0a ars* or page.;;.
43c0: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
43d0: 3a 67 65 74 2d 70 61 67 65 2d 68 61 73 68 20 73 :get-page-hash s
43e0: 65 6c 66 20 70 61 67 65 29 0a 20 20 28 69 66 20 elf page). (if
43f0: 28 73 74 72 69 6e 67 3d 3f 20 70 61 67 65 20 22 (string=? page "
4400: 2a 73 65 73 73 69 6f 6e 76 61 72 73 2a 22 29 0a *sessionvars*").
4410: 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d (sdat-get-
4420: 73 65 73 73 69 6f 6e 76 61 72 73 20 73 65 6c 66 sessionvars self
4430: 29 0a 20 20 20 20 20 20 28 69 66 20 28 73 74 72 ). (if (str
4440: 69 6e 67 3d 3f 20 70 61 67 65 20 22 2a 67 6c 6f ing=? page "*glo
4450: 62 61 6c 76 61 72 73 2a 22 29 0a 09 20 20 28 73 balvars*").. (s
4460: 64 61 74 2d 67 65 74 2d 67 6c 6f 62 61 6c 76 61 dat-get-globalva
4470: 72 73 20 73 65 6c 66 29 0a 09 20 20 28 73 64 61 rs self).. (sda
4480: 74 2d 67 65 74 2d 70 61 67 65 76 61 72 73 20 73 t-get-pagevars s
4490: 65 6c 66 29 29 29 29 0a 0a 3b 3b 20 73 65 74 20 elf))))..;; set
44a0: 61 20 73 65 73 73 69 6f 6e 20 76 61 72 20 66 6f a session var fo
44b0: 72 20 61 20 67 69 76 65 6e 20 70 61 67 65 0a 3b r a given page.;
44c0: 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ;.(define (sessi
44d0: 6f 6e 3a 73 65 74 21 20 73 65 6c 66 20 70 61 67 on:set! self pag
44e0: 65 20 6b 65 79 20 76 61 6c 75 65 29 0a 20 20 28 e key value). (
44f0: 6c 65 74 20 28 28 68 74 20 28 73 65 73 73 69 6f let ((ht (sessio
4500: 6e 3a 67 65 74 2d 70 61 67 65 2d 68 61 73 68 20 n:get-page-hash
4510: 73 65 6c 66 20 70 61 67 65 29 29 29 0a 20 20 20 self page))).
4520: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
4530: 21 20 68 74 20 28 73 3a 61 6e 79 2d 3e 73 74 72 ! ht (s:any->str
4540: 69 6e 67 20 6b 65 79 29 20 28 73 3a 61 6e 79 2d ing key) (s:any-
4550: 3e 73 74 72 69 6e 67 20 76 61 6c 75 65 29 29 29 >string value)))
4560: 29 0a 0a 3b 3b 20 67 65 74 20 73 65 73 73 69 6f )..;; get sessio
4570: 6e 20 76 61 72 73 20 66 6f 72 20 74 68 65 20 63 n vars for the c
4580: 75 72 72 65 6e 74 20 70 61 67 65 0a 3b 3b 0a 28 urrent page.;;.(
4590: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
45a0: 67 65 74 20 73 65 6c 66 20 6b 65 79 29 0a 20 20 get self key).
45b0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
45c0: 64 65 66 61 75 6c 74 20 28 73 64 61 74 2d 67 65 default (sdat-ge
45d0: 74 2d 70 61 67 65 76 61 72 73 20 73 65 6c 66 29 t-pagevars self)
45e0: 20 6b 65 79 20 23 66 29 29 0a 0a 3b 3b 20 67 65 key #f))..;; ge
45f0: 74 20 73 65 73 73 69 6f 6e 20 76 61 72 73 20 66 t session vars f
4600: 6f 72 20 61 20 73 70 65 63 69 66 69 65 64 20 70 or a specified p
4610: 61 67 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 age.;;.(define (
4620: 73 65 73 73 69 6f 6e 3a 67 65 74 20 73 65 6c 66 session:get self
4630: 20 70 61 67 65 20 6b 65 79 29 0a 20 20 28 6c 65 page key). (le
4640: 74 20 28 28 68 74 20 28 73 65 73 73 69 6f 6e 3a t ((ht (session:
4650: 67 65 74 2d 70 61 67 65 2d 68 61 73 68 20 73 65 get-page-hash se
4660: 6c 66 20 70 61 67 65 29 29 29 0a 20 20 20 20 28 lf page))). (
4670: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
4680: 65 66 61 75 6c 74 20 68 74 20 6b 65 79 20 23 66 efault ht key #f
4690: 29 29 29 0a 0a 3b 3b 20 64 65 6c 65 74 65 20 61 )))..;; delete a
46a0: 20 73 65 73 73 69 6f 6e 20 76 61 72 20 66 6f 72 session var for
46b0: 20 61 20 73 70 65 63 69 66 69 65 64 20 70 61 67 a specified pag
46c0: 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 e.;;.(define (se
46d0: 73 73 69 6f 6e 3a 64 65 6c 21 20 73 65 6c 66 20 ssion:del! self
46e0: 70 61 67 65 20 6b 65 79 29 0a 20 20 28 6c 65 74 page key). (let
46f0: 20 28 28 68 74 20 28 73 65 73 73 69 6f 6e 3a 67 ((ht (session:g
4700: 65 74 2d 70 61 67 65 2d 68 61 73 68 20 73 65 6c et-page-hash sel
4710: 66 20 70 61 67 65 29 29 29 0a 20 20 20 20 28 68 f page))). (h
4720: 61 73 68 2d 74 61 62 6c 65 2d 64 65 6c 65 74 65 ash-table-delete
4730: 21 20 68 74 20 6b 65 79 29 29 29 0a 0a 3b 3b 20 ! ht key)))..;;
4740: 67 65 74 20 41 4c 4c 20 6b 65 79 73 20 66 6f 72 get ALL keys for
4750: 20 74 68 69 73 20 70 61 67 65 20 61 6e 64 20 73 this page and s
4760: 74 6f 72 65 20 69 6e 20 74 68 65 20 73 65 73 73 tore in the sess
4770: 69 6f 6e 20 70 61 67 65 76 61 72 73 20 68 61 73 ion pagevars has
4780: 68 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 h.;;.(define (se
4790: 73 73 69 6f 6e 3a 67 65 74 2d 76 61 72 73 20 73 ssion:get-vars s
47a0: 65 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 73 65 elf). (let ((se
47b0: 73 73 69 6f 6e 2d 69 64 20 20 28 73 64 61 74 2d ssion-id (sdat-
47c0: 67 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 get-session-id s
47d0: 65 6c 66 29 29 29 0a 20 20 20 20 28 69 66 20 28 elf))). (if (
47e0: 6e 6f 74 20 73 65 73 73 69 6f 6e 2d 69 64 29 0a not session-id).
47f0: 09 28 65 72 72 3a 6c 6f 67 20 22 45 52 52 4f 52 .(err:log "ERROR
4800: 3a 20 4e 6f 20 73 65 73 73 69 6f 6e 20 69 64 20 : No session id
4810: 69 6e 20 73 65 73 73 69 6f 6e 20 6f 62 6a 65 63 in session objec
4820: 74 21 20 73 65 73 73 69 6f 6e 3a 67 65 74 2d 76 t! session:get-v
4830: 61 72 73 22 29 0a 09 28 6c 65 74 2a 20 28 28 72 ars")..(let* ((r
4840: 65 73 75 6c 74 20 20 20 20 20 20 20 20 20 20 20 esult
4850: 20 20 23 66 29 0a 09 20 20 20 20 20 20 20 28 63 #f).. (c
4860: 6f 6e 6e 20 20 20 20 20 20 20 20 20 20 20 20 20 onn
4870: 20 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e (sdat-get-conn
4880: 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 20 20 self))..
4890: 28 70 61 67 65 76 61 72 73 2d 62 65 66 6f 72 65 (pagevars-before
48a0: 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d 70 61 (sdat-get-pa
48b0: 67 65 76 61 72 73 2d 62 65 66 6f 72 65 20 73 65 gevars-before se
48c0: 6c 66 29 29 0a 09 20 20 20 20 20 20 20 28 73 65 lf)).. (se
48d0: 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 ssionvars-before
48e0: 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 (sdat-get-sessi
48f0: 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 20 73 65 onvars-before se
4900: 6c 66 29 29 0a 09 20 20 20 20 20 20 20 28 67 6c lf)).. (gl
4910: 6f 62 61 6c 76 61 72 73 2d 62 65 66 6f 72 65 20 obalvars-before
4920: 20 28 73 64 61 74 2d 67 65 74 2d 67 6c 6f 62 61 (sdat-get-globa
4930: 6c 76 61 72 73 2d 62 65 66 6f 72 65 20 73 65 6c lvars-before sel
4940: 66 29 29 0a 09 20 20 20 20 20 20 20 28 70 61 67 f)).. (pag
4950: 65 76 61 72 73 20 20 20 20 20 20 20 20 20 20 20 evars
4960: 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 76 61 (sdat-get-pageva
4970: 72 73 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 rs self))..
4980: 20 20 28 73 65 73 73 69 6f 6e 76 61 72 73 20 20 (sessionvars
4990: 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d (sdat-get-
49a0: 73 65 73 73 69 6f 6e 76 61 72 73 20 73 65 6c 66 sessionvars self
49b0: 29 29 0a 09 20 20 20 20 20 20 20 28 67 6c 6f 62 )).. (glob
49c0: 61 6c 76 61 72 73 20 20 20 20 20 20 20 20 20 28 alvars (
49d0: 73 64 61 74 2d 67 65 74 2d 67 6c 6f 62 61 6c 76 sdat-get-globalv
49e0: 61 72 73 20 73 65 6c 66 29 29 0a 09 20 20 20 20 ars self))..
49f0: 20 20 20 28 70 61 67 65 2d 6e 61 6d 65 20 20 20 (page-name
4a00: 20 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 (sdat-get
4a10: 2d 70 61 67 65 20 73 65 6c 66 29 29 0a 09 20 20 -page self))..
4a20: 20 20 20 20 20 28 73 65 73 73 69 6f 6e 2d 6b 65 (session-ke
4a30: 79 20 20 20 20 20 20 20 20 28 73 64 61 74 2d 67 y (sdat-g
4a40: 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 et-session-key s
4a50: 65 6c 66 29 29 0a 09 20 20 20 20 20 20 20 28 71 elf)).. (q
4a60: 75 65 72 79 20 20 20 20 20 20 20 20 20 20 20 20 uery
4a70: 20 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 (string-append
4a80: 0a 09 09 09 09 20 20 20 20 22 53 45 4c 45 43 54 ..... "SELECT
4a90: 20 6b 65 79 2c 76 61 6c 75 65 20 46 52 4f 4d 20 key,value FROM
4aa0: 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 49 4e 4e session_vars INN
4ab0: 45 52 20 4a 4f 49 4e 20 73 65 73 73 69 6f 6e 73 ER JOIN sessions
4ac0: 20 4f 4e 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 ON session_vars
4ad0: 2e 73 65 73 73 69 6f 6e 5f 69 64 3d 73 65 73 73 .session_id=sess
4ae0: 69 6f 6e 73 2e 69 64 20 22 0a 09 09 09 09 20 20 ions.id ".....
4af0: 20 20 22 57 48 45 52 45 20 73 65 73 73 69 6f 6e "WHERE session
4b00: 5f 6b 65 79 3d 3f 20 41 4e 44 20 70 61 67 65 3d _key=? AND page=
4b10: 3f 3b 22 29 29 29 0a 09 20 20 3b 3b 20 66 69 72 ?;"))).. ;; fir
4b20: 73 74 20 74 68 65 20 70 61 67 65 20 73 70 65 63 st the page spec
4b30: 69 66 69 63 20 76 61 72 73 0a 09 20 20 28 64 62 ific vars.. (db
4b40: 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 28 i:for-each-row (
4b50: 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 29 0a 09 lambda (tuple)..
4b60: 09 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 6b .. (let ((k
4b70: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 (vector-ref tup
4b80: 6c 65 20 30 29 29 0a 09 09 09 09 20 20 20 20 28 le 0))..... (
4b90: 76 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 75 v (vector-ref tu
4ba0: 70 6c 65 20 31 29 29 29 0a 09 09 09 09 28 68 61 ple 1))).....(ha
4bb0: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 70 61 sh-table-set! pa
4bc0: 67 65 76 61 72 73 2d 62 65 66 6f 72 65 20 6b 20 gevars-before k
4bd0: 76 29 0a 09 09 09 09 28 68 61 73 68 2d 74 61 62 v).....(hash-tab
4be0: 6c 65 2d 73 65 74 21 20 70 61 67 65 76 61 72 73 le-set! pagevars
4bf0: 20 20 20 20 20 20 20 20 6b 20 76 29 29 29 0a 09 k v)))..
4c00: 09 09 20 20 20 20 63 6f 6e 6e 0a 09 09 09 20 20 .. conn....
4c10: 20 20 28 73 3a 73 71 6c 70 61 72 61 6d 20 71 75 (s:sqlparam qu
4c20: 65 72 79 20 73 65 73 73 69 6f 6e 2d 6b 65 79 20 ery session-key
4c30: 70 61 67 65 2d 6e 61 6d 65 29 29 0a 09 20 20 3b page-name)).. ;
4c40: 3b 20 74 68 65 6e 20 74 68 65 20 73 65 73 73 69 ; then the sessi
4c50: 6f 6e 20 73 70 65 63 69 66 69 63 20 76 61 72 73 on specific vars
4c60: 0a 09 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 .. (dbi:for-eac
4c70: 68 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 h-row (lambda (t
4c80: 75 70 6c 65 29 0a 09 09 09 20 20 20 20 20 20 28 uple).... (
4c90: 6c 65 74 20 28 28 6b 20 28 76 65 63 74 6f 72 2d let ((k (vector-
4ca0: 72 65 66 20 74 75 70 6c 65 20 30 29 29 0a 09 09 ref tuple 0))...
4cb0: 09 09 20 20 20 20 28 76 20 28 76 65 63 74 6f 72 .. (v (vector
4cc0: 2d 72 65 66 20 74 75 70 6c 65 20 31 29 29 29 0a -ref tuple 1))).
4cd0: 09 09 09 09 28 68 61 73 68 2d 74 61 62 6c 65 2d ....(hash-table-
4ce0: 73 65 74 21 20 73 65 73 73 69 6f 6e 76 61 72 73 set! sessionvars
4cf0: 2d 62 65 66 6f 72 65 20 6b 20 76 29 0a 09 09 09 -before k v)....
4d00: 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 .(hash-table-set
4d10: 21 20 73 65 73 73 69 6f 6e 76 61 72 73 20 20 20 ! sessionvars
4d20: 20 20 20 20 20 6b 20 76 29 29 29 0a 09 09 09 20 k v)))....
4d30: 20 20 20 63 6f 6e 6e 0a 09 09 09 20 20 20 20 28 conn.... (
4d40: 73 3a 73 71 6c 70 61 72 61 6d 20 71 75 65 72 79 s:sqlparam query
4d50: 20 73 65 73 73 69 6f 6e 2d 6b 65 79 20 22 2a 73 session-key "*s
4d60: 65 73 73 69 6f 6e 76 61 72 73 2a 22 29 29 0a 09 essionvars*"))..
4d70: 20 20 3b 3b 20 61 6e 64 20 66 69 6e 61 6c 6c 79 ;; and finally
4d80: 20 74 68 65 20 67 6c 6f 62 61 6c 20 76 61 72 73 the global vars
4d90: 0a 09 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 .. (dbi:for-eac
4da0: 68 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 h-row (lambda (t
4db0: 75 70 6c 65 29 0a 09 09 09 20 20 20 20 20 20 28 uple).... (
4dc0: 6c 65 74 20 28 28 6b 20 28 76 65 63 74 6f 72 2d let ((k (vector-
4dd0: 72 65 66 20 74 75 70 6c 65 20 30 29 29 0a 09 09 ref tuple 0))...
4de0: 09 09 20 20 20 20 28 76 20 28 76 65 63 74 6f 72 .. (v (vector
4df0: 2d 72 65 66 20 74 75 70 6c 65 20 31 29 29 29 0a -ref tuple 1))).
4e00: 09 09 09 09 28 68 61 73 68 2d 74 61 62 6c 65 2d ....(hash-table-
4e10: 73 65 74 21 20 67 6c 6f 62 61 6c 76 61 72 73 2d set! globalvars-
4e20: 62 65 66 6f 72 65 20 6b 20 76 29 0a 09 09 09 09 before k v).....
4e30: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
4e40: 20 67 6c 6f 62 61 6c 76 61 72 73 20 20 20 20 20 globalvars
4e50: 20 20 20 6b 20 76 29 29 29 0a 09 09 09 20 20 20 k v)))....
4e60: 20 63 6f 6e 6e 0a 09 09 09 20 20 20 20 28 73 3a conn.... (s:
4e70: 73 71 6c 70 61 72 61 6d 20 71 75 65 72 79 20 73 sqlparam query s
4e80: 65 73 73 69 6f 6e 2d 6b 65 79 20 22 2a 67 6c 6f ession-key "*glo
4e90: 62 61 6c 76 61 72 73 22 29 29 0a 09 20 20 29 29 balvars")).. ))
4ea0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 ))..(define (ses
4eb0: 73 69 6f 6e 3a 73 61 76 65 2d 76 61 72 73 20 73 sion:save-vars s
4ec0: 65 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 73 65 elf). (let ((se
4ed0: 73 73 69 6f 6e 2d 69 64 20 20 28 73 64 61 74 2d ssion-id (sdat-
4ee0: 67 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 get-session-id s
4ef0: 65 6c 66 29 29 29 0a 20 20 20 20 28 69 66 20 28 elf))). (if (
4f00: 6e 6f 74 20 73 65 73 73 69 6f 6e 2d 69 64 29 0a not session-id).
4f10: 09 28 65 72 72 3a 6c 6f 67 20 22 45 52 52 4f 52 .(err:log "ERROR
4f20: 3a 20 4e 6f 20 73 65 73 73 69 6f 6e 20 69 64 20 : No session id
4f30: 69 6e 20 73 65 73 73 69 6f 6e 20 6f 62 6a 65 63 in session objec
4f40: 74 21 20 73 65 73 73 69 6f 6e 3a 67 65 74 2d 76 t! session:get-v
4f50: 61 72 73 22 29 0a 09 28 6c 65 74 2a 20 28 28 73 ars")..(let* ((s
4f60: 74 61 74 75 73 20 20 20 20 20 20 23 66 29 0a 09 tatus #f)..
4f70: 20 20 20 20 20 20 20 28 63 6f 6e 6e 20 20 20 20 (conn
4f80: 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d 63 6f (sdat-get-co
4f90: 6e 6e 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 nn self))..
4fa0: 20 20 28 70 61 67 65 2d 6e 61 6d 65 20 20 20 28 (page-name (
4fb0: 73 64 61 74 2d 67 65 74 2d 70 61 67 65 20 73 65 sdat-get-page se
4fc0: 6c 66 29 29 0a 09 20 20 20 20 20 20 20 28 64 65 lf)).. (de
4fd0: 6c 2d 71 75 65 72 79 20 20 20 22 44 45 4c 45 54 l-query "DELET
4fe0: 45 20 46 52 4f 4d 20 73 65 73 73 69 6f 6e 5f 76 E FROM session_v
4ff0: 61 72 73 20 57 48 45 52 45 20 73 65 73 73 69 6f ars WHERE sessio
5000: 6e 5f 69 64 3d 3f 20 41 4e 44 20 70 61 67 65 3d n_id=? AND page=
5010: 3f 20 41 4e 44 20 6b 65 79 3d 3f 3b 22 29 0a 09 ? AND key=?;")..
5020: 20 20 20 20 20 20 20 28 69 6e 73 2d 71 75 65 72 (ins-quer
5030: 79 20 20 20 22 49 4e 53 45 52 54 20 49 4e 54 4f y "INSERT INTO
5040: 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 28 73 session_vars (s
5050: 65 73 73 69 6f 6e 5f 69 64 2c 70 61 67 65 2c 6b ession_id,page,k
5060: 65 79 2c 76 61 6c 75 65 29 20 56 41 4c 55 45 53 ey,value) VALUES
5070: 28 3f 2c 3f 2c 3f 2c 3f 29 3b 22 29 0a 09 20 20 (?,?,?,?);")..
5080: 20 20 20 20 20 28 75 70 64 2d 71 75 65 72 79 20 (upd-query
5090: 20 20 22 55 50 44 41 54 45 20 73 65 73 73 69 6f "UPDATE sessio
50a0: 6e 5f 76 61 72 73 20 73 65 74 20 76 61 6c 75 65 n_vars set value
50b0: 3d 3f 20 57 48 45 52 45 20 6b 65 79 3d 3f 20 41 =? WHERE key=? A
50c0: 4e 44 20 73 65 73 73 69 6f 6e 5f 69 64 3d 3f 20 ND session_id=?
50d0: 41 4e 44 20 70 61 67 65 3d 3f 3b 22 29 0a 09 20 AND page=?;")..
50e0: 20 20 20 20 20 20 28 63 68 61 6e 67 65 64 2d 63 (changed-c
50f0: 6f 75 6e 74 20 30 29 29 0a 09 20 20 3b 3b 20 73 ount 0)).. ;; s
5100: 61 76 65 20 74 68 65 20 64 65 6c 74 61 20 6f 6e ave the delta on
5110: 6c 79 0a 09 20 20 28 66 6f 72 2d 65 61 63 68 0a ly.. (for-each.
5120: 09 20 20 20 28 6c 61 6d 62 64 61 20 28 70 61 67 . (lambda (pag
5130: 65 29 20 3b 3b 20 70 61 67 65 20 69 73 3a 20 22 e) ;; page is: "
5140: 2a 67 6c 6f 62 61 6c 76 61 72 73 2a 22 20 22 2a *globalvars*" "*
5150: 73 65 73 73 69 6f 6e 76 61 72 73 2a 22 20 6f 72 sessionvars*" or
5160: 20 6f 74 68 65 72 73 74 72 69 6e 67 0a 09 20 20 otherstring..
5170: 20 20 20 28 6c 65 74 2a 20 28 28 62 65 66 6f 72 (let* ((befor
5180: 65 2d 61 66 74 65 72 2d 68 74 20 28 63 6f 6e 64 e-after-ht (cond
5190: 0a 09 09 09 09 20 20 20 20 20 20 28 28 73 74 72 ..... ((str
51a0: 69 6e 67 3d 3f 20 70 61 67 65 20 22 2a 73 65 73 ing=? page "*ses
51b0: 73 69 6f 6e 76 61 72 73 2a 22 29 0a 09 09 09 09 sionvars*").....
51c0: 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 20 28 (vector (
51d0: 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e sdat-get-session
51e0: 76 61 72 73 20 73 65 6c 66 29 0a 09 09 09 09 09 vars self)......
51f0: 20 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 (sdat-get
5200: 2d 73 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 -sessionvars-bef
5210: 6f 72 65 20 73 65 6c 66 29 29 29 0a 09 09 09 09 ore self))).....
5220: 20 20 20 20 20 20 20 28 28 73 74 72 69 6e 67 3d ((string=
5230: 3f 20 70 61 67 65 20 22 2a 67 6c 6f 62 61 6c 76 ? page "*globalv
5240: 61 72 73 2a 22 29 0a 09 09 09 09 09 28 76 65 63 ars*")......(vec
5250: 74 6f 72 20 28 73 64 61 74 2d 67 65 74 2d 67 6c tor (sdat-get-gl
5260: 6f 62 61 6c 76 61 72 73 20 73 65 6c 66 29 0a 09 obalvars self)..
5270: 09 09 09 09 09 28 73 64 61 74 2d 67 65 74 2d 67 .....(sdat-get-g
5280: 6c 6f 62 61 6c 76 61 72 73 2d 62 65 66 6f 72 65 lobalvars-before
5290: 20 73 65 6c 66 29 29 29 0a 09 09 09 09 20 20 20 self))).....
52a0: 20 20 20 20 28 65 6c 73 65 20 0a 09 09 09 09 09 (else ......
52b0: 28 76 65 63 74 6f 72 20 28 73 64 61 74 2d 67 65 (vector (sdat-ge
52c0: 74 2d 70 61 67 65 76 61 72 73 20 73 65 6c 66 29 t-pagevars self)
52d0: 0a 09 09 09 09 09 09 28 73 64 61 74 2d 67 65 74 .......(sdat-get
52e0: 2d 70 61 67 65 76 61 72 73 2d 62 65 66 6f 72 65 -pagevars-before
52f0: 20 73 65 6c 66 29 29 29 29 29 0a 09 09 20 20 20 self)))))...
5300: 20 28 6d 61 73 74 65 72 2d 68 74 20 20 20 28 76 (master-ht (v
5310: 65 63 74 6f 72 2d 72 65 66 20 62 65 66 6f 72 65 ector-ref before
5320: 2d 61 66 74 65 72 2d 68 74 20 30 29 29 0a 09 09 -after-ht 0))...
5330: 20 20 20 20 28 62 65 66 6f 72 65 2d 68 74 20 20 (before-ht
5340: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 62 65 66 (vector-ref bef
5350: 6f 72 65 2d 61 66 74 65 72 2d 68 74 20 31 29 29 ore-after-ht 1))
5360: 0a 09 09 20 20 20 20 28 6d 61 73 74 65 72 2d 6b ... (master-k
5370: 65 79 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d eys (hash-table-
5380: 6b 65 79 73 20 6d 61 73 74 65 72 2d 68 74 29 29 keys master-ht))
5390: 0a 09 09 20 20 20 20 28 62 65 66 6f 72 65 2d 6b ... (before-k
53a0: 65 79 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d eys (hash-table-
53b0: 6b 65 79 73 20 62 65 66 6f 72 65 2d 68 74 29 29 keys before-ht))
53c0: 0a 09 09 20 20 20 20 28 61 6c 6c 2d 6b 65 79 73 ... (all-keys
53d0: 20 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 (delete-duplica
53e0: 74 65 73 20 28 61 70 70 65 6e 64 20 6d 61 73 74 tes (append mast
53f0: 65 72 2d 6b 65 79 73 20 62 65 66 6f 72 65 2d 6b er-keys before-k
5400: 65 79 73 29 29 29 29 0a 09 20 20 20 20 20 20 20 eys))))..
5410: 28 66 6f 72 2d 65 61 63 68 20 0a 09 09 28 6c 61 (for-each ...(la
5420: 6d 62 64 61 20 28 6b 65 79 29 0a 09 09 20 20 28 mbda (key)... (
5430: 6c 65 74 20 28 28 6d 61 73 74 65 72 2d 76 61 6c let ((master-val
5440: 75 65 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 ue (hash-table-r
5450: 65 66 2f 64 65 66 61 75 6c 74 20 6d 61 73 74 65 ef/default maste
5460: 72 2d 68 74 20 6b 65 79 20 23 66 29 29 0a 09 09 r-ht key #f))...
5470: 09 28 62 65 66 6f 72 65 2d 76 61 6c 75 65 20 28 .(before-value (
5480: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
5490: 65 66 61 75 6c 74 20 62 65 66 6f 72 65 2d 68 74 efault before-ht
54a0: 20 6b 65 79 20 23 66 29 29 29 0a 09 09 20 20 20 key #f)))...
54b0: 20 28 63 6f 6e 64 0a 09 09 20 20 20 20 20 3b 3b (cond... ;;
54c0: 20 62 65 66 6f 72 65 20 61 6e 64 20 61 66 74 65 before and afte
54d0: 72 20 65 78 69 73 74 20 61 6e 64 20 76 61 6c 75 r exist and valu
54e0: 65 20 75 6e 63 68 61 6e 67 65 64 20 2d 20 64 6f e unchanged - do
54f0: 20 6e 6f 74 68 69 6e 67 0a 09 09 20 20 20 20 20 nothing...
5500: 28 28 61 6e 64 20 6d 61 73 74 65 72 2d 76 61 6c ((and master-val
5510: 75 65 20 62 65 66 6f 72 65 2d 76 61 6c 75 65 20 ue before-value
5520: 28 65 71 75 61 6c 3f 20 6d 61 73 74 65 72 2d 76 (equal? master-v
5530: 61 6c 75 65 20 62 65 66 6f 72 65 2d 76 61 6c 75 alue before-valu
5540: 65 29 29 29 0a 09 09 20 20 20 20 20 3b 3b 20 62 e)))... ;; b
5550: 65 66 6f 72 65 20 61 6e 64 20 61 66 74 65 72 20 efore and after
5560: 65 78 69 73 74 20 62 75 74 20 61 72 65 20 63 68 exist but are ch
5570: 61 6e 67 65 64 0a 09 09 20 20 20 20 20 28 28 61 anged... ((a
5580: 6e 64 20 6d 61 73 74 65 72 2d 76 61 6c 75 65 20 nd master-value
5590: 62 65 66 6f 72 65 2d 76 61 6c 75 65 29 0a 09 09 before-value)...
55a0: 20 20 20 20 20 20 28 64 62 69 3a 66 6f 72 2d 65 (dbi:for-e
55b0: 61 63 68 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 ach-row (lambda
55c0: 28 74 75 70 6c 65 29 0a 09 09 09 09 09 20 20 28 (tuple)...... (
55d0: 73 65 74 21 20 63 68 61 6e 67 65 64 2d 63 6f 75 set! changed-cou
55e0: 6e 74 20 28 2b 20 63 68 61 6e 67 65 64 2d 63 6f nt (+ changed-co
55f0: 75 6e 74 20 31 29 29 29 0a 09 09 09 09 09 63 6f unt 1)))......co
5600: 6e 6e 0a 09 09 09 09 09 28 73 3a 73 71 6c 70 61 nn......(s:sqlpa
5610: 72 61 6d 20 75 70 64 2d 71 75 65 72 79 20 6d 61 ram upd-query ma
5620: 73 74 65 72 2d 76 61 6c 75 65 20 6b 65 79 20 73 ster-value key s
5630: 65 73 73 69 6f 6e 2d 69 64 20 70 61 67 65 29 29 ession-id page))
5640: 29 0a 09 09 20 20 20 20 20 3b 3b 20 6d 61 73 74 )... ;; mast
5650: 65 72 2d 76 61 6c 75 65 20 6e 6f 20 6c 6f 6e 67 er-value no long
5660: 65 72 20 65 78 69 73 74 73 20 28 69 2e 65 2e 20 er exists (i.e.
5670: 23 66 29 20 2d 20 72 65 6d 6f 76 65 20 69 74 65 #f) - remove ite
5680: 6d 0a 09 09 20 20 20 20 20 28 28 6e 6f 74 20 6d m... ((not m
5690: 61 73 74 65 72 2d 76 61 6c 75 65 29 0a 09 09 20 aster-value)...
56a0: 20 20 20 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 (dbi:for-ea
56b0: 63 68 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 ch-row (lambda (
56c0: 74 75 70 6c 65 29 0a 09 09 09 09 09 20 20 28 73 tuple)...... (s
56d0: 65 74 21 20 63 68 61 6e 67 65 64 2d 63 6f 75 6e et! changed-coun
56e0: 74 20 28 2b 20 63 68 61 6e 67 65 64 2d 63 6f 75 t (+ changed-cou
56f0: 6e 74 20 31 29 29 29 0a 09 09 09 09 09 63 6f 6e nt 1)))......con
5700: 6e 0a 09 09 09 09 09 28 73 3a 73 71 6c 70 61 72 n......(s:sqlpar
5710: 61 6d 20 64 65 6c 2d 71 75 65 72 79 20 73 65 73 am del-query ses
5720: 73 69 6f 6e 2d 69 64 20 70 61 67 65 20 6b 65 79 sion-id page key
5730: 29 29 29 0a 09 09 20 20 20 20 20 3b 3b 20 62 65 )))... ;; be
5740: 66 6f 72 65 2d 76 61 6c 75 65 20 64 6f 65 73 6e fore-value doesn
5750: 27 74 20 65 78 69 73 74 20 2d 20 69 6e 73 65 72 't exist - inser
5760: 74 20 61 20 6e 65 77 20 76 61 6c 75 65 0a 09 09 t a new value...
5770: 20 20 20 20 20 28 28 6e 6f 74 20 62 65 66 6f 72 ((not befor
5780: 65 2d 76 61 6c 75 65 29 0a 09 09 20 20 20 20 20 e-value)...
5790: 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 (dbi:for-each-r
57a0: 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c ow (lambda (tupl
57b0: 65 29 0a 09 09 09 09 09 20 20 28 73 65 74 21 20 e)...... (set!
57c0: 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 28 2b changed-count (+
57d0: 20 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 31 changed-count 1
57e0: 29 29 29 0a 09 09 09 09 09 63 6f 6e 6e 0a 09 09 )))......conn...
57f0: 09 09 09 28 73 3a 73 71 6c 70 61 72 61 6d 20 69 ...(s:sqlparam i
5800: 6e 73 2d 71 75 65 72 79 20 73 65 73 73 69 6f 6e ns-query session
5810: 2d 69 64 20 70 61 67 65 20 6b 65 79 20 6d 61 73 -id page key mas
5820: 74 65 72 2d 76 61 6c 75 65 29 29 29 0a 09 09 20 ter-value)))...
5830: 20 20 20 20 28 65 6c 73 65 20 28 65 72 72 3a 6c (else (err:l
5840: 6f 67 20 22 53 68 6f 75 6c 64 6e 27 74 20 67 65 og "Shouldn't ge
5850: 74 20 68 65 72 65 22 29 29 29 29 29 0a 09 09 61 t here")))))...a
5860: 6c 6c 2d 6b 65 79 73 29 29 29 20 3b 3b 20 70 72 ll-keys))) ;; pr
5870: 6f 63 65 73 73 20 61 6c 6c 20 6b 65 79 73 0a 09 ocess all keys..
5880: 20 20 20 28 6c 69 73 74 20 22 2a 73 65 73 73 69 (list "*sessi
5890: 6f 6e 76 61 72 73 2a 22 20 22 2a 67 6c 6f 62 61 onvars*" "*globa
58a0: 6c 76 61 72 73 2a 22 20 70 61 67 65 2d 6e 61 6d lvars*" page-nam
58b0: 65 29 29 29 29 29 29 0a 0a 3b 3b 20 28 70 67 3a e))))))..;; (pg:
58c0: 73 71 6c 2d 6e 75 6c 6c 2d 6f 62 6a 65 63 74 3f sql-null-object?
58d0: 20 65 6c 65 6d 65 6e 74 29 0a 28 64 65 66 69 6e element).(defin
58e0: 65 20 28 73 65 73 73 69 6f 6e 3a 72 65 61 64 2d e (session:read-
58f0: 63 6f 6e 66 69 67 20 73 65 6c 66 29 0a 20 20 28 config self). (
5900: 6c 65 74 20 28 28 6e 61 6d 65 20 28 73 74 72 69 let ((name (stri
5910: 6e 67 2d 61 70 70 65 6e 64 20 22 2e 22 20 28 70 ng-append "." (p
5920: 61 74 68 6e 61 6d 65 2d 66 69 6c 65 20 28 63 61 athname-file (ca
5930: 72 20 28 61 72 67 76 29 29 29 20 22 2e 63 6f 6e r (argv))) ".con
5940: 66 69 67 22 29 29 29 0a 20 20 20 20 28 69 66 20 fig"))). (if
5950: 28 6e 6f 74 20 28 66 69 6c 65 2d 65 78 69 73 74 (not (file-exist
5960: 73 3f 20 6e 61 6d 65 29 29 0a 09 28 70 72 69 6e s? name))..(prin
5970: 74 20 6e 61 6d 65 20 22 20 6e 6f 74 20 66 6f 75 t name " not fou
5980: 6e 64 20 61 74 20 22 20 28 63 75 72 72 65 6e 74 nd at " (current
5990: 2d 64 69 72 65 63 74 6f 72 79 29 29 0a 09 28 6c -directory))..(l
59a0: 65 74 2a 20 28 28 66 70 20 28 6f 70 65 6e 2d 69 et* ((fp (open-i
59b0: 6e 70 75 74 2d 66 69 6c 65 20 6e 61 6d 65 29 29 nput-file name))
59c0: 0a 09 20 20 20 20 20 20 20 28 69 6e 69 74 61 72 .. (initar
59d0: 67 73 20 28 72 65 61 64 20 66 70 29 29 29 0a 09 gs (read fp)))..
59e0: 20 20 28 63 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 (close-input-p
59f0: 6f 72 74 20 66 70 29 0a 09 20 20 69 6e 69 74 61 ort fp).. inita
5a00: 72 67 73 29 29 29 29 0a 0a 3b 3b 20 63 61 6c 6c rgs))))..;; call
5a10: 20 74 68 65 20 63 6f 6e 74 72 6f 6c 6c 65 72 20 the controller
5a20: 69 66 20 69 74 20 65 78 69 73 74 73 0a 3b 3b 20 if it exists.;;
5a30: 0a 3b 3b 20 57 41 52 4e 49 4e 47 20 2d 20 74 68 .;; WARNING - th
5a40: 69 73 20 63 6f 64 65 20 6e 65 65 64 73 20 61 20 is code needs a
5a50: 64 65 66 65 6e 63 65 20 61 67 61 69 6e 73 20 72 defence agains r
5a60: 65 63 75 72 73 69 76 65 20 63 61 6c 6c 69 6e 67 ecursive calling
5a70: 21 21 21 21 21 0a 3b 3b 0a 3b 3b 20 20 20 49 20 !!!!!.;;.;; I
5a80: 73 75 67 67 65 73 74 20 61 20 6c 69 6d 69 74 20 suggest a limit
5a90: 6f 66 20 31 30 30 20 63 61 6c 6c 73 2e 20 50 6c of 100 calls. Pl
5aa0: 65 6e 74 79 20 66 6f 72 20 61 6c 6c 6f 77 69 6e enty for allowin
5ab0: 67 20 6d 75 6c 74 69 70 6c 65 20 69 6e 73 74 61 g multiple insta
5ac0: 6e 63 65 73 0a 3b 3b 20 20 20 6f 66 20 61 20 70 nces.;; of a p
5ad0: 61 67 65 20 69 6e 73 69 64 65 20 61 6e 6f 74 68 age inside anoth
5ae0: 65 72 20 70 61 67 65 2e 20 0a 3b 3b 0a 3b 3b 20 er page. .;;.;;
5af0: 70 61 72 74 73 20 3d 20 27 62 6f 74 68 20 7c 20 parts = 'both |
5b00: 27 63 6f 6e 74 72 6f 6c 20 7c 20 27 76 69 65 77 'control | 'view
5b10: 0a 3b 3b 0a 0a 28 64 65 66 69 6e 65 20 28 66 69 .;;..(define (fi
5b20: 6c 65 73 2d 72 65 61 64 2d 3e 73 74 72 69 6e 67 les-read->string
5b30: 20 2e 20 66 69 6c 65 73 29 0a 20 20 28 73 74 72 . files). (str
5b40: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
5b50: 0a 20 20 20 28 61 70 70 6c 79 20 61 70 70 65 6e . (apply appen
5b60: 64 20 28 6d 61 70 20 66 69 6c 65 2d 72 65 61 64 d (map file-read
5b70: 2d 3e 73 74 72 69 6e 67 20 66 69 6c 65 73 29 29 ->string files))
5b80: 20 22 5c 6e 22 29 29 0a 0a 28 64 65 66 69 6e 65 "\n"))..(define
5b90: 20 28 66 69 6c 65 2d 72 65 61 64 2d 3e 73 74 72 (file-read->str
5ba0: 69 6e 67 20 66 29 20 0a 20 20 28 6c 65 74 20 28 ing f) . (let (
5bb0: 28 70 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 66 (p (open-input-f
5bc0: 69 6c 65 20 66 29 29 29 0a 20 20 20 20 28 6c 65 ile f))). (le
5bd0: 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 72 65 t loop ((hed (re
5be0: 61 64 2d 6c 69 6e 65 20 70 29 29 0a 09 20 20 20 ad-line p))..
5bf0: 20 20 20 20 28 72 65 73 20 27 28 29 29 29 0a 20 (res '())).
5c00: 20 20 20 20 20 28 69 66 20 28 65 6f 66 2d 6f 62 (if (eof-ob
5c10: 6a 65 63 74 3f 20 68 65 64 29 0a 09 20 20 72 65 ject? hed).. re
5c20: 73 0a 09 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 s.. (loop (read
5c30: 2d 6c 69 6e 65 20 70 29 28 61 70 70 65 6e 64 20 -line p)(append
5c40: 72 65 73 20 28 6c 69 73 74 20 68 65 64 29 29 29 res (list hed)))
5c50: 29 29 29 29 0a 0a 3b 3b 20 4d 61 79 20 32 30 31 ))))..;; May 201
5c60: 31 2c 20 70 75 74 74 69 6e 67 20 61 6c 6c 20 70 1, putting all p
5c70: 61 67 65 73 20 69 6e 74 6f 20 6f 6e 65 20 64 69 ages into one di
5c80: 72 65 63 74 6f 72 79 20 66 6f 72 20 74 68 65 20 rectory for the
5c90: 66 6f 6c 6c 6f 77 69 6e 67 20 72 65 61 73 6f 6e following reason
5ca0: 73 3a 0a 3b 3b 20 20 20 31 2e 20 77 61 6e 74 20 s:.;; 1. want
5cb0: 66 69 6c 65 6e 61 6d 65 20 74 6f 20 72 65 66 6c filename to refl
5cc0: 65 63 74 20 70 61 67 65 20 6e 61 6d 65 20 28 65 ect page name (e
5cd0: 6d 61 63 73 20 6c 69 6d 69 74 61 74 69 6f 6e 29 macs limitation)
5ce0: 0a 3b 3b 20 20 20 32 2e 20 74 68 61 74 27 73 20 .;; 2. that's
5cf0: 69 74 21 20 6e 6f 20 6f 74 68 65 72 20 72 65 61 it! no other rea
5d00: 73 6f 6e 2e 20 63 6f 75 6c 64 20 6d 61 6b 65 20 son. could make
5d10: 69 74 20 63 6f 6e 66 69 67 75 72 61 62 6c 65 20 it configurable
5d20: 2e 2e 2e 0a 28 64 65 66 69 6e 65 20 28 73 65 73 ....(define (ses
5d30: 73 69 6f 6e 3a 63 61 6c 6c 2d 70 61 72 74 73 20 sion:call-parts
5d40: 73 65 6c 66 20 70 61 67 65 20 70 61 72 74 73 29 self page parts)
5d50: 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 63 75 72 . (sdat-set-cur
5d60: 72 2d 70 61 67 65 21 20 73 65 6c 66 20 70 61 67 r-page! self pag
5d70: 65 29 0a 20 20 3b 3b 20 28 73 65 73 73 69 6f 6e e). ;; (session
5d80: 3a 6c 6f 67 20 73 65 6c 66 20 22 70 61 67 65 2d :log self "page-
5d90: 64 69 72 2d 73 74 79 6c 65 3a 20 22 20 28 73 64 dir-style: " (sd
5da0: 61 74 2d 67 65 74 2d 70 61 67 65 2d 64 69 72 2d at-get-page-dir-
5db0: 73 74 79 6c 65 20 73 65 6c 66 29 29 0a 20 20 28 style self)). (
5dc0: 6c 65 74 2a 20 28 28 64 69 72 2d 73 74 79 6c 65 let* ((dir-style
5dd0: 20 3b 3b 20 28 65 71 75 61 6c 3f 20 28 73 64 61 ;; (equal? (sda
5de0: 74 2d 67 65 74 2d 70 61 67 65 2d 64 69 72 2d 73 t-get-page-dir-s
5df0: 74 79 6c 65 20 73 65 6c 66 29 20 22 6f 6e 65 64 tyle self) "oned
5e00: 69 72 22 29 29 20 3b 3b 20 66 6c 61 67 20 23 74 ir")) ;; flag #t
5e10: 20 66 6f 72 20 6f 6e 65 64 69 72 2c 20 23 66 20 for onedir, #f
5e20: 66 6f 72 20 6f 6c 64 20 73 74 79 6c 65 0a 09 20 for old style..
5e30: 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 2d (sdat-get-page-
5e40: 64 69 72 2d 73 74 79 6c 65 20 73 65 6c 66 29 29 dir-style self))
5e50: 0a 09 20 28 64 69 72 20 20 20 20 20 28 73 74 72 .. (dir (str
5e60: 69 6e 67 2d 61 70 70 65 6e 64 20 28 73 64 61 74 ing-append (sdat
5e70: 2d 67 65 74 2d 73 72 6f 6f 74 20 73 65 6c 66 29 -get-sroot self)
5e80: 20 0a 09 09 09 09 20 28 69 66 20 64 69 72 2d 73 ..... (if dir-s
5e90: 74 79 6c 65 20 0a 09 09 09 09 20 20 20 20 20 28 tyle ..... (
5ea0: 63 6f 6e 63 20 22 2f 70 61 67 65 73 2f 22 29 0a conc "/pages/").
5eb0: 09 09 09 09 20 20 20 20 20 28 63 6f 6e 63 20 22 .... (conc "
5ec0: 2f 70 61 67 65 73 2f 22 20 70 61 67 65 29 29 29 /pages/" page)))
5ed0: 29 0a 09 20 28 63 6f 6e 74 72 6f 6c 20 28 73 74 ).. (control (st
5ee0: 72 69 6e 67 2d 61 70 70 65 6e 64 20 64 69 72 20 ring-append dir
5ef0: 28 69 66 20 64 69 72 2d 73 74 79 6c 65 20 0a 09 (if dir-style ..
5f00: 09 09 09 09 20 28 63 6f 6e 63 20 70 61 67 65 20 .... (conc page
5f10: 22 5f 63 74 72 6c 2e 73 63 6d 22 29 0a 09 09 09 "_ctrl.scm")....
5f20: 09 09 20 22 2f 63 6f 6e 74 72 6f 6c 2e 73 63 6d .. "/control.scm
5f30: 22 29 29 29 0a 09 20 28 76 69 65 77 20 20 20 20 "))).. (view
5f40: 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 64 (string-append d
5f50: 69 72 20 28 69 66 20 64 69 72 2d 73 74 79 6c 65 ir (if dir-style
5f60: 20 0a 09 09 09 09 09 20 28 63 6f 6e 63 20 70 61 ...... (conc pa
5f70: 67 65 20 22 5f 76 69 65 77 2e 73 63 6d 22 29 0a ge "_view.scm").
5f80: 09 09 09 09 09 20 22 2f 76 69 65 77 2e 73 63 6d ..... "/view.scm
5f90: 22 29 29 29 0a 09 20 28 6c 6f 61 64 2d 76 69 65 "))).. (load-vie
5fa0: 77 20 20 20 20 28 61 6e 64 20 28 66 69 6c 65 2d w (and (file-
5fb0: 65 78 69 73 74 73 3f 20 76 69 65 77 29 0a 09 09 exists? view)...
5fc0: 09 20 20 20 20 28 6f 72 20 28 65 71 3f 20 70 61 . (or (eq? pa
5fd0: 72 74 73 20 27 62 6f 74 68 29 28 65 71 3f 20 70 rts 'both)(eq? p
5fe0: 61 72 74 73 20 27 76 69 65 77 29 29 29 29 0a 09 arts 'view))))..
5ff0: 20 28 6c 6f 61 64 2d 63 6f 6e 74 72 6f 6c 20 28 (load-control (
6000: 61 6e 64 20 28 66 69 6c 65 2d 65 78 69 73 74 73 and (file-exists
6010: 3f 20 63 6f 6e 74 72 6f 6c 29 0a 09 09 09 20 20 ? control)....
6020: 20 20 28 6f 72 20 28 65 71 3f 20 70 61 72 74 73 (or (eq? parts
6030: 20 27 62 6f 74 68 29 28 65 71 3f 20 70 61 72 74 'both)(eq? part
6040: 73 20 27 63 6f 6e 74 72 6f 6c 29 29 29 29 0a 09 s 'control))))..
6050: 20 28 76 69 65 77 2d 64 61 74 20 20 20 27 28 29 (view-dat '()
6060: 29 29 0a 20 20 20 20 3b 3b 20 28 73 65 73 73 69 )). ;; (sessi
6070: 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 64 69 72 on:log self "dir
6080: 2d 73 74 79 6c 65 3a 20 22 20 64 69 72 2d 73 74 -style: " dir-st
6090: 79 6c 65 29 0a 20 3b 3b 20 20 20 28 73 75 67 61 yle). ;; (suga
60a0: 72 20 22 2f 68 6f 6d 65 2f 6d 61 74 74 2f 6b 69 r "/home/matt/ki
60b0: 61 74 6f 61 2f 73 74 6d 6c 2f 73 75 67 61 72 2e atoa/stml/sugar.
60c0: 73 63 6d 22 20 29 29 0a 20 20 20 20 3b 3b 20 28 scm" )). ;; (
60d0: 70 72 69 6e 74 20 22 64 69 72 3d 22 20 64 69 72 print "dir=" dir
60e0: 20 22 20 63 6f 6e 74 72 6f 6c 3d 22 20 63 6f 6e " control=" con
60f0: 74 72 6f 6c 20 22 20 76 69 65 77 3d 22 20 76 69 trol " view=" vi
6100: 65 77 20 22 20 6c 6f 61 64 2d 76 69 65 77 3d 22 ew " load-view="
6110: 20 6c 6f 61 64 2d 76 69 65 77 20 22 20 6c 6f 61 load-view " loa
6120: 64 3d 63 6f 6e 74 72 6f 6c 3d 22 20 6c 6f 61 64 d=control=" load
6130: 2d 63 6f 6e 74 72 6f 6c 29 0a 20 20 20 20 28 69 -control). (i
6140: 66 20 6c 6f 61 64 2d 63 6f 6e 74 72 6f 6c 0a 09 f load-control..
6150: 28 62 65 67 69 6e 0a 09 20 20 28 6c 6f 61 64 20 (begin.. (load
6160: 63 6f 6e 74 72 6f 6c 29 0a 09 20 20 28 73 65 73 control).. (ses
6170: 73 69 6f 6e 3a 73 65 74 2d 63 61 6c 6c 65 64 21 sion:set-called!
6180: 20 73 65 6c 66 20 70 61 67 65 29 29 29 0a 20 20 self page))).
6190: 20 20 3b 3b 20 6d 6f 76 65 20 74 68 69 73 20 74 ;; move this t
61a0: 6f 20 77 68 65 72 65 20 69 74 20 67 65 74 73 20 o where it gets
61b0: 65 78 65 63 74 75 74 65 64 20 6f 6e 6c 79 20 6f exectuted only o
61c0: 6e 63 65 0a 20 20 20 20 3b 3b 0a 20 20 20 20 28 nce. ;;. (
61d0: 69 66 20 6c 6f 61 64 2d 76 69 65 77 0a 09 3b 3b if load-view..;;
61e0: 20 6f 70 74 69 6f 6e 20 6f 6e 65 2e 3a 0a 09 3b option one.:..;
61f0: 3b 0a 09 3b 3b 20 28 6c 65 74 20 28 28 69 6e 70 ;..;; (let ((inp
6200: 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 73 74 72 (open-input-str
6210: 69 6e 67 20 0a 09 3b 3b 20 09 20 20 20 20 28 66 ing ..;; . (f
6220: 69 6c 65 73 2d 72 65 61 64 2d 3e 73 74 72 69 6e iles-read->strin
6230: 67 20 22 2f 68 6f 6d 65 2f 6d 61 74 74 2f 6b 69 g "/home/matt/ki
6240: 61 74 6f 61 2f 73 74 6d 6c 2f 73 75 67 61 72 2e atoa/stml/sugar.
6250: 73 63 6d 22 20 0a 09 3b 3b 20 09 09 09 09 76 69 scm" ..;; ....vi
6260: 65 77 29 29 29 29 0a 09 3b 3b 20 20 20 28 6d 61 ew))))..;; (ma
6270: 70 20 0a 09 3b 3b 20 20 20 20 28 6c 61 6d 62 64 p ..;; (lambd
6280: 61 20 28 78 29 0a 09 3b 3b 20 20 20 20 20 20 28 a (x)..;; (
6290: 63 6f 6e 64 0a 09 3b 3b 20 20 20 20 20 20 20 28 cond..;; (
62a0: 28 6c 69 73 74 3f 20 78 29 20 78 29 0a 09 3b 3b (list? x) x)..;;
62b0: 20 20 20 20 20 20 20 28 28 73 74 72 69 6e 67 3f ((string?
62c0: 20 78 29 20 78 29 0a 09 3b 3b 20 20 20 20 20 20 x) x)..;;
62d0: 20 28 65 6c 73 65 20 27 28 29 29 29 29 0a 09 3b (else '())))..;
62e0: 3b 20 20 20 20 28 70 6f 72 74 2d 6d 61 70 20 65 ; (port-map e
62f0: 76 61 6c 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 val (lambda ()..
6300: 3b 3b 20 09 09 20 28 72 65 61 64 20 69 6e 70 29 ;; .. (read inp)
6310: 29 29 29 29 0a 09 3b 3b 0a 09 3b 3b 20 6f 70 74 ))))..;;..;; opt
6320: 69 6f 6e 20 74 77 6f 3a 0a 09 3b 3b 0a 09 28 6c ion two:..;;..(l
6330: 65 74 2a 20 28 3b 3b 20 28 69 6e 70 73 20 28 6d et* (;; (inps (m
6340: 61 70 20 6f 70 65 6e 2d 69 6e 70 75 74 2d 66 69 ap open-input-fi
6350: 6c 65 20 28 6c 69 73 74 20 76 69 65 77 29 29 29 le (list view)))
6360: 20 3b 3b 20 73 75 67 61 72 20 76 69 65 77 29 29 ;; sugar view))
6370: 29 0a 09 20 20 20 20 20 20 20 28 70 20 20 20 20 ).. (p
6380: 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 66 69 6c 65 (open-input-file
6390: 20 76 69 65 77 29 29 20 3b 3b 20 28 61 70 70 6c view)) ;; (appl
63a0: 79 20 6d 61 6b 65 2d 63 6f 6e 63 61 74 65 6e 61 y make-concatena
63b0: 74 65 64 2d 70 6f 72 74 20 69 6e 70 73 29 29 0a ted-port inps)).
63c0: 09 20 20 20 20 20 20 20 28 64 61 74 20 20 28 6d . (dat (m
63d0: 61 70 20 0a 09 09 20 20 20 20 20 20 28 6c 61 6d ap ... (lam
63e0: 62 64 61 20 28 78 29 0a 09 09 09 28 63 6f 6e 64 bda (x)....(cond
63f0: 0a 09 09 09 20 28 28 6c 69 73 74 3f 20 78 29 20 .... ((list? x)
6400: 78 29 0a 09 09 09 20 28 28 73 74 72 69 6e 67 3f x).... ((string?
6410: 20 78 29 20 78 29 0a 09 09 09 20 28 65 6c 73 65 x) x).... (else
6420: 20 27 28 29 29 29 29 0a 09 09 20 20 20 20 20 20 '())))...
6430: 28 70 6f 72 74 2d 6d 61 70 20 65 76 61 6c 20 28 (port-map eval (
6440: 6c 61 6d 62 64 61 20 28 29 28 72 65 61 64 20 70 lambda ()(read p
6450: 29 29 29 29 29 29 0a 09 20 20 3b 3b 20 28 6d 61 )))))).. ;; (ma
6460: 70 20 63 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 6f p close-input-po
6470: 72 74 20 69 6e 70 73 29 0a 09 20 20 28 63 6c 6f rt inps).. (clo
6480: 73 65 2d 69 6e 70 75 74 2d 70 6f 72 74 20 70 29 se-input-port p)
6490: 0a 09 20 20 64 61 74 29 0a 09 28 6c 69 73 74 20 .. dat)..(list
64a0: 22 3c 70 3e 50 61 67 65 20 6e 6f 74 20 66 6f 75 "<p>Page not fou
64b0: 6e 64 20 22 20 70 61 67 65 20 22 20 3c 2f 70 3e nd " page " </p>
64c0: 22 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 "))))..(define (
64d0: 73 65 73 73 69 6f 6e 3a 63 61 6c 6c 20 73 65 6c session:call sel
64e0: 66 20 70 61 67 65 29 0a 20 20 28 73 65 73 73 69 f page). (sessi
64f0: 6f 6e 3a 63 61 6c 6c 2d 70 61 72 74 73 20 73 65 on:call-parts se
6500: 6c 66 20 70 61 67 65 20 27 62 6f 74 68 29 29 0a lf page 'both)).
6510: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
6520: 6e 3a 63 61 6c 6c 20 73 65 6c 66 20 70 61 67 65 n:call self page
6530: 20 70 61 72 74 73 29 0a 20 20 28 73 65 73 73 69 parts). (sessi
6540: 6f 6e 3a 63 61 6c 6c 2d 70 61 72 74 73 20 73 65 on:call-parts se
6550: 6c 66 20 70 61 67 65 20 27 62 6f 74 68 29 29 0a lf page 'both)).
6560: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
6570: 6e 3a 6c 6f 61 64 2d 6d 6f 64 65 6c 20 73 65 6c n:load-model sel
6580: 66 20 6d 6f 64 65 6c 29 0a 20 20 28 6c 65 74 20 f model). (let
6590: 28 28 6d 6f 64 65 6c 2e 73 63 6d 20 28 73 74 72 ((model.scm (str
65a0: 69 6e 67 2d 61 70 70 65 6e 64 20 28 73 64 61 74 ing-append (sdat
65b0: 2d 67 65 74 2d 73 72 6f 6f 74 20 73 65 6c 66 29 -get-sroot self)
65c0: 20 22 2f 6d 6f 64 65 6c 73 2f 22 20 6d 6f 64 65 "/models/" mode
65d0: 6c 20 22 2e 73 63 6d 22 29 29 0a 09 28 6d 6f 64 l ".scm"))..(mod
65e0: 65 6c 2e 73 6f 20 20 28 73 74 72 69 6e 67 2d 61 el.so (string-a
65f0: 70 70 65 6e 64 20 28 73 64 61 74 2d 67 65 74 2d ppend (sdat-get-
6600: 73 72 6f 6f 74 20 73 65 6c 66 29 20 22 2f 6d 6f sroot self) "/mo
6610: 64 65 6c 73 2f 22 20 6d 6f 64 65 6c 20 22 2e 73 dels/" model ".s
6620: 6f 22 29 29 29 0a 20 20 20 20 28 69 66 20 28 66 o"))). (if (f
6630: 69 6c 65 2d 65 78 69 73 74 73 3f 20 6d 6f 64 65 ile-exists? mode
6640: 6c 2e 73 6f 29 0a 09 28 6c 6f 61 64 20 6d 6f 64 l.so)..(load mod
6650: 65 6c 2e 73 6f 29 0a 09 28 69 66 20 28 66 69 6c el.so)..(if (fil
6660: 65 2d 65 78 69 73 74 73 3f 20 6d 6f 64 65 6c 2e e-exists? model.
6670: 73 63 6d 29 0a 09 20 20 20 20 28 6c 6f 61 64 20 scm).. (load
6680: 6d 6f 64 65 6c 2e 73 63 6d 29 0a 09 20 20 20 20 model.scm)..
6690: 28 73 3a 6c 6f 67 20 22 45 52 52 4f 52 3a 20 6d (s:log "ERROR: m
66a0: 6f 64 65 6c 20 22 20 6d 6f 64 65 6c 2e 73 63 6d odel " model.scm
66b0: 20 22 20 6e 6f 74 20 66 6f 75 6e 64 22 29 29 29 " not found")))
66c0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 ))..(define (ses
66d0: 73 69 6f 6e 3a 6d 6f 64 65 6c 2d 70 61 74 68 20 sion:model-path
66e0: 73 65 6c 66 20 6d 6f 64 65 6c 29 0a 20 20 28 73 self model). (s
66f0: 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 28 73 64 tring-append (sd
6700: 61 74 2d 67 65 74 2d 73 72 6f 6f 74 20 73 65 6c at-get-sroot sel
6710: 66 29 20 22 2f 6d 6f 64 65 6c 73 2f 22 20 6d 6f f) "/models/" mo
6720: 64 65 6c 20 22 2e 73 63 6d 22 29 29 0a 0a 28 64 del ".scm"))..(d
6730: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 70 efine (session:p
6740: 70 2d 66 6f 72 6d 64 61 74 20 73 65 6c 66 29 0a p-formdat self).
6750: 20 20 28 6c 65 74 20 28 28 64 61 74 20 28 66 6f (let ((dat (fo
6760: 72 6d 64 61 74 3a 61 6c 6c 2d 3e 73 74 72 69 6e rmdat:all->strin
6770: 67 73 20 28 73 64 61 74 2d 67 65 74 2d 66 6f 72 gs (sdat-get-for
6780: 6d 64 61 74 20 73 65 6c 66 29 29 29 29 0a 20 20 mdat self)))).
6790: 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 (string-inters
67a0: 70 65 72 73 65 20 64 61 74 20 22 3c 62 72 3e 20 perse dat "<br>
67b0: 22 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 ")))..(define (s
67c0: 65 73 73 69 6f 6e 3a 70 61 72 61 6d 2d 3e 73 74 ession:param->st
67d0: 72 69 6e 67 20 70 61 72 61 6d 73 29 0a 20 20 3b ring params). ;
67e0: 3b 20 28 65 72 72 3a 6c 6f 67 20 22 70 61 72 61 ; (err:log "para
67f0: 6d 73 3d 22 20 70 61 72 61 6d 73 29 0a 20 20 28 ms=" params). (
6800: 69 66 20 28 3c 20 28 6c 65 6e 67 74 68 20 70 61 if (< (length pa
6810: 72 61 6d 73 29 20 31 29 0a 20 20 20 20 20 20 22 rams) 1). "
6820: 22 0a 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f ". (let loo
6830: 70 20 28 28 6b 65 79 20 28 63 61 72 20 70 61 72 p ((key (car par
6840: 61 6d 73 29 29 0a 09 09 20 28 76 61 6c 20 28 63 ams))... (val (c
6850: 61 64 72 20 70 61 72 61 6d 73 29 29 0a 09 09 20 adr params))...
6860: 28 74 61 69 6c 20 28 63 64 64 72 20 70 61 72 61 (tail (cddr para
6870: 6d 73 29 29 0a 09 09 20 28 72 65 73 75 6c 74 20 ms))... (result
6880: 27 28 29 29 29 0a 09 28 6c 65 74 20 28 28 6e 65 '()))..(let ((ne
6890: 77 72 65 73 75 6c 74 20 28 63 6f 6e 73 20 28 73 wresult (cons (s
68a0: 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 28 73 3a tring-append (s:
68b0: 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6b 65 79 29 any->string key)
68c0: 20 22 3d 22 20 28 73 3a 61 6e 79 2d 3e 73 74 72 "=" (s:any->str
68d0: 69 6e 67 20 76 61 6c 29 29 0a 09 09 09 20 20 20 ing val))....
68e0: 20 20 20 20 72 65 73 75 6c 74 29 29 29 0a 09 20 result)))..
68f0: 20 28 69 66 20 28 3c 20 28 6c 65 6e 67 74 68 20 (if (< (length
6900: 74 61 69 6c 29 20 31 29 20 3b 3b 20 74 72 75 65 tail) 1) ;; true
6910: 20 69 66 20 64 6f 6e 65 0a 09 20 20 20 20 20 20 if done..
6920: 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
6930: 72 73 65 20 6e 65 77 72 65 73 75 6c 74 20 22 26 rse newresult "&
6940: 22 29 0a 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 ").. (loop
6950: 28 63 61 72 20 74 61 69 6c 29 28 63 61 64 72 20 (car tail)(cadr
6960: 74 61 69 6c 29 28 63 64 64 72 20 74 61 69 6c 29 tail)(cddr tail)
6970: 20 6e 65 77 72 65 73 75 6c 74 29 29 29 29 29 29 newresult))))))
6980: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ..(define (sessi
6990: 6f 6e 3a 6c 69 6e 6b 2d 74 6f 20 73 65 6c 66 20 on:link-to self
69a0: 70 61 67 65 20 70 61 72 61 6d 73 29 0a 20 20 28 page params). (
69b0: 6c 65 74 2a 20 28 28 73 65 72 76 65 72 20 20 20 let* ((server
69c0: 20 28 69 66 20 28 67 65 74 2d 65 6e 76 69 72 6f (if (get-enviro
69d0: 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 nment-variable "
69e0: 48 54 54 50 5f 48 4f 53 54 22 29 0a 09 09 09 28 HTTP_HOST")....(
69f0: 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d get-environment-
6a00: 76 61 72 69 61 62 6c 65 20 22 48 54 54 50 5f 48 variable "HTTP_H
6a10: 4f 53 54 22 29 0a 09 09 09 28 67 65 74 2d 65 6e OST")....(get-en
6a20: 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 vironment-variab
6a30: 6c 65 20 22 53 45 52 56 45 52 5f 4e 41 4d 45 22 le "SERVER_NAME"
6a40: 29 29 29 0a 09 20 28 73 63 72 69 70 74 20 28 6c ))).. (script (l
6a50: 65 74 20 28 28 73 63 72 69 70 74 2d 6e 61 6d 65 et ((script-name
6a60: 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 28 (string-split (
6a70: 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d get-environment-
6a80: 76 61 72 69 61 62 6c 65 20 22 53 43 52 49 50 54 variable "SCRIPT
6a90: 5f 4e 41 4d 45 22 29 20 22 2f 22 29 29 29 0a 09 _NAME") "/")))..
6aa0: 09 20 20 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 . (if (> (leng
6ab0: 74 68 20 73 63 72 69 70 74 2d 6e 61 6d 65 29 20 th script-name)
6ac0: 31 29 0a 09 09 20 20 20 20 20 20 20 28 73 74 72 1)... (str
6ad0: 69 6e 67 2d 61 70 70 65 6e 64 20 28 63 61 72 20 ing-append (car
6ae0: 73 63 72 69 70 74 2d 6e 61 6d 65 29 20 22 2f 22 script-name) "/"
6af0: 20 28 63 61 64 72 20 73 63 72 69 70 74 2d 6e 61 (cadr script-na
6b00: 6d 65 29 29 0a 09 09 20 20 20 20 20 20 20 28 67 me))... (g
6b10: 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 et-environment-v
6b20: 61 72 69 61 62 6c 65 20 22 53 43 52 49 50 54 5f ariable "SCRIPT_
6b30: 4e 41 4d 45 22 29 29 29 29 20 3b 3b 20 62 75 69 NAME")))) ;; bui
6b40: 6c 64 20 73 63 72 69 70 74 20 6e 61 6d 65 20 66 ld script name f
6b50: 72 6f 6d 20 66 69 72 73 74 20 74 77 6f 20 65 6c rom first two el
6b60: 65 6d 65 6e 74 73 2e 20 54 68 69 73 20 69 73 20 ements. This is
6b70: 61 20 68 61 6e 67 6f 76 65 72 20 66 72 6f 6d 20 a hangover from
6b80: 62 65 66 6f 72 65 20 49 20 75 73 65 64 20 3f 20 before I used ?
6b90: 69 6e 20 74 68 65 20 55 52 4c 2e 0a 09 20 28 73 in the URL... (s
6ba0: 65 73 73 69 6f 6e 2d 6b 65 79 20 28 73 64 61 74 ession-key (sdat
6bb0: 2d 67 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 -get-session-key
6bc0: 20 73 65 6c 66 29 29 0a 09 20 28 70 61 72 61 6d self)).. (param
6bd0: 73 74 72 20 28 73 65 73 73 69 6f 6e 3a 70 61 72 str (session:par
6be0: 61 6d 2d 3e 73 74 72 69 6e 67 20 70 61 72 61 6d am->string param
6bf0: 73 29 29 29 0a 20 20 20 20 3b 3b 20 28 73 65 73 s))). ;; (ses
6c00: 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 73 sion:log self "s
6c10: 65 72 76 65 72 3d 22 20 73 65 72 76 65 72 20 22 erver=" server "
6c20: 20 73 63 72 69 70 74 3d 22 20 73 63 72 69 70 74 script=" script
6c30: 20 22 20 70 61 67 65 3d 22 20 70 61 67 65 29 0a " page=" page).
6c40: 20 20 20 20 28 73 74 72 69 6e 67 2d 61 70 70 65 (string-appe
6c50: 6e 64 20 22 68 74 74 70 3a 2f 2f 22 20 73 65 72 nd "http://" ser
6c60: 76 65 72 20 22 2f 22 20 73 63 72 69 70 74 20 22 ver "/" script "
6c70: 2f 22 20 70 61 67 65 20 22 3f 22 20 70 61 72 61 /" page "?" para
6c80: 6d 73 74 72 29 29 29 20 3b 3b 20 22 2f 73 6e 3d mstr))) ;; "/sn=
6c90: 22 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 29 " session-key)))
6ca0: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ..(define (sessi
6cb0: 6f 6e 3a 63 67 69 2d 6f 75 74 20 73 65 6c 66 29 on:cgi-out self)
6cc0: 0a 20 20 28 6c 65 74 2a 20 28 28 63 6f 6e 74 65 . (let* ((conte
6cd0: 6e 74 20 20 28 6c 69 73 74 20 28 73 64 61 74 2d nt (list (sdat-
6ce0: 67 65 74 2d 63 6f 6e 74 65 6e 74 2d 74 79 70 65 get-content-type
6cf0: 20 73 65 6c 66 29 29 29 20 3b 3b 20 27 28 22 43 self))) ;; '("C
6d00: 6f 6e 74 65 6e 74 2d 74 79 70 65 3a 20 74 65 78 ontent-type: tex
6d10: 74 2f 68 74 6d 6c 3b 20 63 68 61 72 73 65 74 3d t/html; charset=
6d20: 69 73 6f 2d 38 38 35 39 2d 31 5c 6e 5c 6e 22 29 iso-8859-1\n\n")
6d30: 29 0a 09 20 28 68 65 61 64 65 72 20 20 20 28 6c ).. (header (l
6d40: 65 74 20 28 28 63 6f 6f 6b 69 65 20 28 73 64 61 et ((cookie (sda
6d50: 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 2d 63 6f t-get-session-co
6d60: 6f 6b 69 65 20 73 65 6c 66 29 29 29 0a 09 09 20 okie self)))...
6d70: 20 20 20 20 28 69 66 20 63 6f 6f 6b 69 65 0a 09 (if cookie..
6d80: 09 09 20 28 63 6f 6e 73 20 28 73 74 72 69 6e 67 .. (cons (string
6d90: 2d 61 70 70 65 6e 64 20 22 53 65 74 2d 43 6f 6f -append "Set-Coo
6da0: 6b 69 65 3a 20 22 20 28 63 61 72 20 63 6f 6f 6b kie: " (car cook
6db0: 69 65 29 29 0a 09 09 09 20 20 20 20 20 20 20 63 ie)).... c
6dc0: 6f 6e 74 65 6e 74 29 0a 09 09 09 20 63 6f 6e 74 ontent).... cont
6dd0: 65 6e 74 29 29 29 0a 09 20 28 70 61 67 65 64 61 ent))).. (pageda
6de0: 74 20 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 t (sdat-get-pag
6df0: 65 64 61 74 20 73 65 6c 66 29 29 29 0a 20 20 20 edat self))).
6e00: 20 28 73 3a 63 67 69 2d 6f 75 74 20 0a 20 20 20 (s:cgi-out .
6e10: 20 20 28 63 6f 6e 73 20 68 65 61 64 65 72 20 70 (cons header p
6e20: 61 67 65 64 61 74 29 29 29 29 0a 0a 28 64 65 66 agedat))))..(def
6e30: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 ine (session:log
6e40: 20 73 65 6c 66 20 2e 20 6d 73 67 29 0a 20 20 28 self . msg). (
6e50: 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 70 with-output-to-p
6e60: 6f 72 74 20 28 73 64 61 74 2d 67 65 74 2d 6c 6f ort (sdat-get-lo
6e70: 67 2d 70 6f 72 74 20 73 65 6c 66 29 20 3b 3b 20 g-port self) ;;
6e80: 28 73 64 61 74 2d 67 65 74 2d 6c 6f 67 70 74 20 (sdat-get-logpt
6e90: 73 65 6c 66 29 0a 20 20 20 20 28 6c 61 6d 62 64 self). (lambd
6ea0: 61 20 28 29 20 0a 20 20 20 20 20 20 28 61 70 70 a () . (app
6eb0: 6c 79 20 70 72 69 6e 74 20 6d 73 67 29 29 29 29 ly print msg))))
6ec0: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ..(define (sessi
6ed0: 6f 6e 3a 67 65 74 2d 70 61 72 61 6d 20 73 65 6c on:get-param sel
6ee0: 66 20 6b 65 79 29 0a 20 20 3b 3b 20 28 73 65 73 f key). ;; (ses
6ef0: 73 69 6f 6e 3a 6c 6f 67 20 73 3a 73 65 73 73 69 sion:log s:sessi
6f00: 6f 6e 20 22 70 61 72 61 6d 73 3d 22 20 28 73 6c on "params=" (sl
6f10: 6f 74 2d 72 65 66 20 73 3a 73 65 73 73 69 6f 6e ot-ref s:session
6f20: 20 27 70 61 72 61 6d 73 29 29 0a 20 20 28 6c 65 'params)). (le
6f30: 74 20 28 28 70 61 72 61 6d 73 20 28 73 64 61 74 t ((params (sdat
6f40: 2d 67 65 74 2d 70 61 72 61 6d 73 20 73 65 6c 66 -get-params self
6f50: 29 29 29 0a 20 20 20 20 28 73 65 73 73 69 6f 6e ))). (session
6f60: 3a 67 65 74 2d 70 61 72 61 6d 2d 66 72 6f 6d 20 :get-param-from
6f70: 70 61 72 61 6d 73 20 6b 65 79 29 29 29 0a 0a 3b params key)))..;
6f80: 3b 20 54 68 69 73 20 6f 6e 65 20 77 69 6c 6c 20 ; This one will
6f90: 67 65 74 20 74 68 65 20 66 69 72 73 74 20 76 61 get the first va
6fa0: 6c 75 65 20 66 6f 75 6e 64 20 72 65 67 61 72 64 lue found regard
6fb0: 6c 65 73 73 20 6f 66 20 66 6f 72 6d 0a 28 64 65 less of form.(de
6fc0: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 fine (session:ge
6fd0: 74 2d 69 6e 70 75 74 20 73 65 6c 66 20 6b 65 79 t-input self key
6fe0: 29 0a 20 20 28 6c 65 74 2a 20 28 28 66 6f 72 6d ). (let* ((form
6ff0: 64 61 74 20 28 73 64 61 74 2d 67 65 74 2d 66 6f dat (sdat-get-fo
7000: 72 6d 64 61 74 20 73 65 6c 66 29 29 29 0a 20 20 rmdat self))).
7010: 20 20 28 69 66 20 28 6e 6f 74 20 66 6f 72 6d 64 (if (not formd
7020: 61 74 29 20 23 66 0a 09 28 69 66 20 28 6f 72 20 at) #f..(if (or
7030: 28 73 74 72 69 6e 67 3f 20 6b 65 79 29 28 6e 75 (string? key)(nu
7040: 6d 62 65 72 3f 20 6b 65 79 29 28 73 79 6d 62 6f mber? key)(symbo
7050: 6c 3f 20 6b 65 79 29 29 0a 09 20 20 20 20 28 69 l? key)).. (i
7060: 66 20 28 65 71 3f 20 28 63 6c 61 73 73 2d 6f 66 f (eq? (class-of
7070: 20 66 6f 72 6d 64 61 74 29 20 3c 66 6f 72 6d 64 formdat) <formd
7080: 61 74 3e 29 0a 09 09 28 66 6f 72 6d 64 61 74 3a at>)...(formdat:
7090: 67 65 74 20 66 6f 72 6d 64 61 74 20 6b 65 79 29 get formdat key)
70a0: 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 20 28 73 ...(begin... (s
70b0: 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 ession:log self
70c0: 22 45 52 52 4f 52 3a 20 66 6f 72 6d 64 61 74 3a "ERROR: formdat:
70d0: 20 22 20 66 6f 72 6d 64 61 74 20 22 20 69 73 20 " formdat " is
70e0: 6e 6f 74 20 6f 66 20 63 6c 61 73 73 20 3c 66 6f not of class <fo
70f0: 72 6d 64 61 74 3e 22 29 0a 09 09 20 20 23 66 29 rmdat>")... #f)
7100: 29 0a 09 20 20 20 20 28 73 65 73 73 69 6f 6e 3a ).. (session:
7110: 6c 6f 67 20 73 65 6c 66 20 22 45 52 52 4f 52 3a log self "ERROR:
7120: 20 62 61 64 20 6b 65 79 20 22 20 6b 65 79 29 29 bad key " key))
7130: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 )))..(define (se
7140: 73 73 69 6f 6e 3a 72 75 6e 2d 61 63 74 69 6f 6e ssion:run-action
7150: 73 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 2a 20 s self). (let*
7160: 28 28 61 63 74 69 6f 6e 20 20 20 20 28 73 65 73 ((action (ses
7170: 73 69 6f 6e 3a 67 65 74 2d 70 61 72 61 6d 20 73 sion:get-param s
7180: 65 6c 66 20 27 61 63 74 69 6f 6e 29 29 0a 09 20 elf 'action))..
7190: 28 70 61 67 65 20 20 20 20 20 20 28 73 64 61 74 (page (sdat
71a0: 2d 67 65 74 2d 70 61 67 65 20 73 65 6c 66 29 29 -get-page self))
71b0: 29 0a 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 ). ;; (print
71c0: 22 61 63 74 69 6f 6e 3d 22 20 61 63 74 69 6f 6e "action=" action
71d0: 20 22 20 70 61 67 65 3d 22 20 70 61 67 65 29 0a " page=" page).
71e0: 20 20 20 20 28 69 66 20 61 63 74 69 6f 6e 0a 09 (if action..
71f0: 28 6c 65 74 20 28 28 61 63 74 69 6f 6e 2d 6c 73 (let ((action-ls
7200: 74 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 t (string-split
7210: 20 61 63 74 69 6f 6e 20 22 2e 22 29 29 29 0a 09 action ".")))..
7220: 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 61 63 74 ;; (print "act
7230: 69 6f 6e 2d 6c 73 74 3d 22 20 61 63 74 69 6f 6e ion-lst=" action
7240: 2d 6c 73 74 29 0a 09 20 20 28 69 66 20 28 6e 6f -lst).. (if (no
7250: 74 20 28 3d 20 28 6c 65 6e 67 74 68 20 61 63 74 t (= (length act
7260: 69 6f 6e 2d 6c 73 74 29 20 32 29 29 20 0a 09 20 ion-lst) 2)) ..
7270: 20 20 20 20 20 28 65 72 72 3a 6c 6f 67 20 22 41 (err:log "A
7280: 63 74 69 6f 6e 20 73 68 6f 75 6c 64 20 62 65 20 ction should be
7290: 6f 66 20 66 6f 72 6d 3a 20 6d 6f 64 75 6c 65 2e of form: module.
72a0: 61 63 74 69 6f 6e 22 29 0a 09 20 20 20 20 20 20 action")..
72b0: 28 6c 65 74 2a 20 28 28 74 61 72 67 2d 70 61 67 (let* ((targ-pag
72c0: 65 20 20 20 28 63 61 72 20 61 63 74 69 6f 6e 2d e (car action-
72d0: 6c 73 74 29 29 0a 09 09 20 20 20 20 20 28 70 72 lst))... (pr
72e0: 6f 63 2d 6e 61 6d 65 20 20 20 28 73 74 72 69 6e oc-name (strin
72f0: 67 2d 61 70 70 65 6e 64 20 74 61 72 67 2d 70 61 g-append targ-pa
7300: 67 65 20 22 2d 61 63 74 69 6f 6e 22 29 29 0a 09 ge "-action"))..
7310: 09 20 20 20 20 20 28 74 61 72 67 2d 61 63 74 69 . (targ-acti
7320: 6f 6e 20 28 63 61 64 72 20 61 63 74 69 6f 6e 2d on (cadr action-
7330: 6c 73 74 29 29 29 0a 09 09 3b 3b 20 28 65 72 72 lst)))...;; (err
7340: 3a 6c 6f 67 20 22 74 61 72 67 2d 70 61 67 65 3d :log "targ-page=
7350: 22 20 74 61 72 67 2d 70 61 67 65 20 22 20 70 72 " targ-page " pr
7360: 6f 63 2d 6e 61 6d 65 3d 22 20 70 72 6f 63 2d 6e oc-name=" proc-n
7370: 61 6d 65 20 22 20 74 61 72 67 2d 61 63 74 69 6f ame " targ-actio
7380: 6e 3d 22 20 74 61 72 67 2d 61 63 74 69 6f 6e 29 n=" targ-action)
7390: 0a 0a 09 09 3b 3b 20 63 61 6c 6c 20 68 65 72 65 ....;; call here
73a0: 20 6f 6e 6c 79 20 69 66 20 6e 65 76 65 72 20 63 only if never c
73b0: 61 6c 6c 65 64 20 62 65 66 6f 72 65 0a 09 09 28 alled before...(
73c0: 69 66 20 28 73 65 73 73 69 6f 6e 3a 6e 65 76 65 if (session:neve
73d0: 72 2d 63 61 6c 6c 65 64 2d 70 61 67 65 3f 20 73 r-called-page? s
73e0: 65 6c 66 20 74 61 72 67 2d 70 61 67 65 29 0a 09 elf targ-page)..
73f0: 09 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 63 61 . (session:ca
7400: 6c 6c 2d 70 61 72 74 73 20 73 65 6c 66 20 74 61 ll-parts self ta
7410: 72 67 2d 70 61 67 65 20 27 63 6f 6e 74 72 6f 6c rg-page 'control
7420: 29 29 0a 09 09 3b 3b 20 20 20 20 20 20 20 20 20 ))...;;
7430: 20 20 20 20 20 20 20 20 20 20 20 70 72 6f 63 20 proc
7440: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7450: 20 20 20 20 20 20 20 20 61 63 74 69 6f 6e 20 20 action
7460: 20 20 0a 0a 09 09 28 69 66 20 23 74 20 3b 3b 20 ....(if #t ;;
7470: 73 65 74 20 74 6f 20 23 74 20 74 6f 20 73 65 65 set to #t to see
7480: 20 62 65 74 74 65 72 20 65 72 72 6f 72 20 6d 65 better error me
7490: 73 73 61 67 65 73 20 64 75 72 69 6e 67 20 64 65 ssages during de
74a0: 62 75 67 67 69 6e 20 3a 2d 29 0a 09 09 20 20 20 buggin :-)...
74b0: 20 28 28 65 76 61 6c 20 28 73 74 72 69 6e 67 2d ((eval (string-
74c0: 3e 73 79 6d 62 6f 6c 20 70 72 6f 63 2d 6e 61 6d >symbol proc-nam
74d0: 65 29 29 20 74 61 72 67 2d 61 63 74 69 6f 6e 29 e)) targ-action)
74e0: 20 3b 3b 20 75 6e 73 61 66 65 20 65 78 65 63 75 ;; unsafe execu
74f0: 74 69 6f 6e 0a 09 09 20 20 20 20 28 63 6f 6e 64 tion... (cond
7500: 69 74 69 6f 6e 2d 63 61 73 65 20 28 28 65 76 61 ition-case ((eva
7510: 6c 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f l (string->symbo
7520: 6c 20 70 72 6f 63 2d 6e 61 6d 65 29 29 20 74 61 l proc-name)) ta
7530: 72 67 2d 61 63 74 69 6f 6e 29 0a 09 09 09 09 20 rg-action).....
7540: 20 20 20 28 28 65 78 6e 20 66 69 6c 65 29 20 28 ((exn file) (
7550: 73 3a 6c 6f 67 20 22 66 69 6c 65 20 65 72 72 6f s:log "file erro
7560: 72 22 29 29 0a 09 09 09 09 20 20 20 20 28 28 65 r"))..... ((e
7570: 78 6e 20 69 2f 6f 29 20 20 28 73 3a 6c 6f 67 20 xn i/o) (s:log
7580: 22 69 2f 6f 20 65 72 72 6f 72 22 29 29 0a 09 09 "i/o error"))...
7590: 09 09 20 20 20 20 28 28 65 78 6e 20 29 20 20 20 .. ((exn )
75a0: 20 20 28 73 3a 6c 6f 67 20 22 41 63 74 69 6f 6e (s:log "Action
75b0: 20 6e 6f 74 20 69 6d 70 6c 65 6d 65 6e 74 65 64 not implemented
75c0: 3a 20 22 20 70 72 6f 63 2d 6e 61 6d 65 20 22 20 : " proc-name "
75d0: 61 63 74 69 6f 6e 3a 20 22 20 74 61 72 67 2d 61 action: " targ-a
75e0: 63 74 69 6f 6e 29 29 0a 09 09 09 09 20 20 20 20 ction)).....
75f0: 28 76 61 72 20 28 29 20 20 20 20 20 28 73 3a 6c (var () (s:l
7600: 6f 67 20 22 55 6e 6b 6e 6f 77 6e 20 45 72 72 6f og "Unknown Erro
7610: 72 22 29 29 29 29 29 29 29 29 29 29 0a 0a 28 64 r"))))))))))..(d
7620: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 6e efine (session:n
7630: 65 76 65 72 2d 63 61 6c 6c 65 64 2d 70 61 67 65 ever-called-page
7640: 3f 20 73 65 6c 66 20 70 61 67 65 29 0a 20 20 28 ? self page). (
7650: 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 session:log self
7660: 20 22 43 68 65 63 6b 69 6e 67 20 66 6f 72 20 70 "Checking for p
7670: 61 67 65 3a 20 22 20 70 61 67 65 29 0a 20 20 28 age: " page). (
7680: 6e 6f 74 20 28 6d 65 6d 62 65 72 20 70 61 67 65 not (member page
7690: 20 28 73 64 61 74 2d 67 65 74 2d 73 65 65 6e 2d (sdat-get-seen-
76a0: 70 61 67 65 73 20 73 65 6c 66 29 29 29 29 0a 0a pages self))))..
76b0: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
76c0: 3a 73 65 74 2d 63 61 6c 6c 65 64 21 20 73 65 6c :set-called! sel
76d0: 66 20 70 61 67 65 29 0a 20 20 28 73 64 61 74 2d f page). (sdat-
76e0: 73 65 74 2d 73 65 65 6e 2d 70 61 67 65 73 21 20 set-seen-pages!
76f0: 73 65 6c 66 20 28 63 6f 6e 73 20 70 61 67 65 20 self (cons page
7700: 28 73 64 61 74 2d 67 65 74 2d 73 65 65 6e 2d 70 (sdat-get-seen-p
7710: 61 67 65 73 20 73 65 6c 66 29 29 29 29 0a 0a 3b ages self))))..;
7720: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
7730: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7740: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7750: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7760: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 41 6c 74 65 72 =======.;; Alter
7770: 6e 61 74 69 76 65 20 64 61 74 61 20 74 79 70 65 native data type
7780: 20 64 65 6c 69 76 65 72 79 0a 3b 3b 3d 3d 3d 3d delivery.;;====
7790: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
77a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
77b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
77c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
77d0: 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 ==..(define (ses
77e0: 73 69 6f 6e 3a 61 6c 74 2d 6f 75 74 20 73 65 6c sion:alt-out sel
77f0: 66 29 0a 20 20 28 6c 65 74 20 28 28 64 61 74 20 f). (let ((dat
7800: 28 73 64 61 74 2d 67 65 74 2d 61 6c 74 2d 70 61 (sdat-get-alt-pa
7810: 67 65 2d 64 61 74 20 73 65 6c 66 29 29 29 0a 20 ge-dat self))).
7820: 20 20 20 3b 3b 20 28 73 3a 6c 6f 67 20 22 64 61 ;; (s:log "da
7830: 74 20 69 73 3a 20 22 20 64 61 74 29 0a 20 20 20 t is: " dat).
7840: 20 3b 3b 20 28 70 72 69 6e 74 20 22 48 54 54 50 ;; (print "HTTP
7850: 2f 31 2e 31 20 32 30 30 20 4f 4b 22 29 0a 20 20 /1.1 200 OK").
7860: 20 20 28 70 72 69 6e 74 20 22 44 61 74 65 3a 20 (print "Date:
7870: 22 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 20 " (time->string
7880: 28 73 65 63 6f 6e 64 73 2d 3e 75 74 63 2d 74 69 (seconds->utc-ti
7890: 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f me (current-seco
78a0: 6e 64 73 29 29 29 29 0a 20 20 20 20 28 70 72 69 nds)))). (pri
78b0: 6e 74 20 22 43 6f 6e 74 65 6e 74 2d 54 79 70 65 nt "Content-Type
78c0: 3a 20 22 20 28 73 64 61 74 2d 67 65 74 2d 63 6f : " (sdat-get-co
78d0: 6e 74 65 6e 74 2d 74 79 70 65 20 73 65 6c 66 29 ntent-type self)
78e0: 29 0a 20 20 20 20 28 70 72 69 6e 74 20 22 41 63 ). (print "Ac
78f0: 63 65 70 74 2d 52 61 6e 67 65 73 3a 20 62 79 74 cept-Ranges: byt
7900: 65 73 22 29 0a 20 20 20 20 28 70 72 69 6e 74 20 es"). (print
7910: 22 43 6f 6e 74 65 6e 74 2d 4c 65 6e 67 74 68 3a "Content-Length:
7920: 20 22 20 28 69 66 20 28 62 6c 6f 62 3f 20 64 61 " (if (blob? da
7930: 74 29 0a 09 09 09 09 20 20 28 62 6c 6f 62 2d 73 t)..... (blob-s
7940: 69 7a 65 20 64 61 74 29 0a 09 09 09 09 20 20 30 ize dat)..... 0
7950: 29 29 0a 20 20 20 20 28 70 72 69 6e 74 20 22 4b )). (print "K
7960: 65 65 70 2d 41 6c 69 76 65 3a 20 74 69 6d 65 6f eep-Alive: timeo
7970: 75 74 3d 31 35 2c 20 6d 61 78 3d 31 30 30 22 29 ut=15, max=100")
7980: 0a 20 20 20 20 28 70 72 69 6e 74 20 22 43 6f 6e . (print "Con
7990: 6e 65 63 74 69 6f 6e 3a 20 4b 65 65 70 2d 41 6c nection: Keep-Al
79a0: 69 76 65 22 29 0a 20 20 20 20 28 70 72 69 6e 74 ive"). (print
79b0: 20 22 22 29 0a 20 20 20 20 28 77 72 69 74 65 2d ""). (write-
79c0: 73 74 72 69 6e 67 20 28 62 6c 6f 62 2d 3e 73 74 string (blob->st
79d0: 72 69 6e 67 20 64 61 74 29 20 23 66 20 28 63 75 ring dat) #f (cu
79e0: 72 72 65 6e 74 2d 6f 75 74 70 75 74 2d 70 6f 72 rrent-output-por
79f0: 74 29 29 29 29 0a t)))).