Artifact
95d05735887160abf33fea15cc0a61d9a497e07a:
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 69 6e INIT.(define (in
1bd0: 69 74 69 61 6c 69 7a 65 20 73 65 6c 66 29 0a 20 itialize self).
1be0: 20 28 73 64 61 74 2d 73 65 74 2d 64 62 74 79 70 (sdat-set-dbtyp
1bf0: 65 21 20 73 65 6c 66 20 20 20 20 20 20 27 70 67 e! self 'pg
1c00: 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 ). (sdat-set-pa
1c10: 67 65 21 20 73 65 6c 66 20 20 20 20 20 20 20 20 ge! self
1c20: 22 68 6f 6d 65 22 29 20 20 20 20 20 20 20 20 3b "home") ;
1c30: 3b 20 74 68 65 73 65 20 61 72 65 20 64 65 66 61 ; these are defa
1c40: 75 6c 74 73 0a 20 20 28 73 64 61 74 2d 73 65 74 ults. (sdat-set
1c50: 2d 63 75 72 72 2d 70 61 67 65 21 20 73 65 6c 66 -curr-page! self
1c60: 20 20 20 22 68 6f 6d 65 22 29 0a 20 20 28 73 64 "home"). (sd
1c70: 61 74 2d 73 65 74 2d 63 6f 6e 74 65 6e 74 2d 74 at-set-content-t
1c80: 79 70 65 21 20 73 65 6c 66 20 22 43 6f 6e 74 65 ype! self "Conte
1c90: 6e 74 2d 74 79 70 65 3a 20 74 65 78 74 2f 68 74 nt-type: text/ht
1ca0: 6d 6c 3b 20 63 68 61 72 73 65 74 3d 69 73 6f 2d ml; charset=iso-
1cb0: 38 38 35 39 2d 31 5c 6e 5c 6e 22 29 0a 20 20 28 8859-1\n\n"). (
1cc0: 73 64 61 74 2d 73 65 74 2d 70 61 67 65 2d 74 79 sdat-set-page-ty
1cd0: 70 65 21 20 73 65 6c 66 20 20 20 27 68 74 6d 6c pe! self 'html
1ce0: 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 74 6f ). (sdat-set-to
1cf0: 70 70 61 67 65 21 20 73 65 6c 66 20 20 20 20 20 ppage! self
1d00: 22 69 6e 64 65 78 22 29 0a 20 20 28 73 64 61 74 "index"). (sdat
1d10: 2d 73 65 74 2d 70 61 72 61 6d 73 21 20 73 65 6c -set-params! sel
1d20: 66 20 20 20 20 20 20 27 28 29 29 20 20 20 20 20 f '())
1d30: 20 20 20 20 20 20 3b 3b 0a 20 20 28 73 64 61 74 ;;. (sdat
1d40: 2d 73 65 74 2d 70 61 74 68 2d 70 61 72 61 6d 73 -set-path-params
1d50: 21 20 73 65 6c 66 20 27 28 29 29 0a 20 20 28 73 ! self '()). (s
1d60: 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e 2d dat-set-session-
1d70: 6b 65 79 21 20 73 65 6c 66 20 23 66 29 0a 20 20 key! self #f).
1d80: 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 64 61 (sdat-set-pageda
1d90: 74 21 20 73 65 6c 66 20 20 20 20 20 27 28 29 29 t! self '())
1da0: 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 61 6c 74 . (sdat-set-alt
1db0: 2d 70 61 67 65 2d 64 61 74 21 20 73 65 6c 66 20 -page-dat! self
1dc0: 23 66 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d #f). (sdat-set-
1dd0: 73 72 6f 6f 74 21 20 73 65 6c 66 20 20 20 20 20 sroot! self
1de0: 20 20 22 2e 2f 22 29 0a 20 20 28 73 64 61 74 2d "./"). (sdat-
1df0: 73 65 74 2d 73 65 73 73 69 6f 6e 2d 63 6f 6f 6b set-session-cook
1e00: 69 65 21 20 73 65 6c 66 20 23 66 29 0a 20 20 28 ie! self #f). (
1e10: 73 64 61 74 2d 73 65 74 2d 63 75 72 72 2d 65 72 sdat-set-curr-er
1e20: 72 21 20 73 65 6c 66 20 23 66 29 0a 20 20 28 73 r! self #f). (s
1e30: 64 61 74 2d 73 65 74 2d 6c 6f 67 2d 70 6f 72 74 dat-set-log-port
1e40: 21 20 73 65 6c 66 20 28 63 75 72 72 65 6e 74 2d ! self (current-
1e50: 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a 20 20 28 error-port)). (
1e60: 73 64 61 74 2d 73 65 74 2d 73 65 65 6e 2d 70 61 sdat-set-seen-pa
1e70: 67 65 73 21 20 73 65 6c 66 20 27 28 29 29 0a 20 ges! self '()).
1e80: 20 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 2d (sdat-set-page-
1e90: 64 69 72 2d 73 74 79 6c 65 21 20 73 65 6c 66 20 dir-style! self
1ea0: 23 74 29 20 3b 3b 20 23 74 20 3a 20 70 61 67 65 #t) ;; #t : page
1eb0: 73 2f 3c 70 61 67 65 6e 61 6d 65 3e 5f 28 76 69 s/<pagename>_(vi
1ec0: 65 77 7c 63 6e 74 6c 29 2e 73 63 6d 0a 20 20 20 ew|cntl).scm.
1ed0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1ee0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1ef0: 20 20 20 3b 3b 20 23 66 20 3a 20 70 61 67 65 73 ;; #f : pages
1f00: 2f 3c 70 61 67 65 6e 61 6d 65 3e 2f 28 76 69 65 /<pagename>/(vie
1f10: 77 7c 63 6f 6e 74 72 6f 6c 29 2e 73 63 6d 20 0a w|control).scm .
1f20: 20 20 28 73 64 61 74 2d 73 65 74 2d 64 65 62 75 (sdat-set-debu
1f30: 67 6d 6f 64 65 21 20 20 20 20 20 20 20 20 20 20 gmode!
1f40: 73 65 6c 66 20 23 66 29 0a 20 20 09 09 09 20 20 self #f). ...
1f50: 20 20 20 0a 20 20 28 73 64 61 74 2d 73 65 74 2d . (sdat-set-
1f60: 70 61 67 65 76 61 72 73 21 20 20 20 20 20 20 20 pagevars!
1f70: 20 20 20 20 73 65 6c 66 20 28 6d 61 6b 65 2d 68 self (make-h
1f80: 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 73 ash-table)). (s
1f90: 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e 76 dat-set-sessionv
1fa0: 61 72 73 21 20 20 20 20 20 20 20 20 73 65 6c 66 ars! self
1fb0: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
1fc0: 65 29 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d e)). (sdat-set-
1fd0: 67 6c 6f 62 61 6c 76 61 72 73 21 20 20 20 20 20 globalvars!
1fe0: 20 20 20 20 73 65 6c 66 20 28 6d 61 6b 65 2d 68 self (make-h
1ff0: 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 73 ash-table)). (s
2000: 64 61 74 2d 73 65 74 2d 70 61 67 65 76 61 72 73 dat-set-pagevars
2010: 2d 62 65 66 6f 72 65 21 20 20 20 20 73 65 6c 66 -before! self
2020: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
2030: 65 29 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d e)). (sdat-set-
2040: 73 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 6f sessionvars-befo
2050: 72 65 21 20 73 65 6c 66 20 28 6d 61 6b 65 2d 68 re! self (make-h
2060: 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 73 ash-table)). (s
2070: 64 61 74 2d 73 65 74 2d 67 6c 6f 62 61 6c 76 61 dat-set-globalva
2080: 72 73 2d 62 65 66 6f 72 65 21 20 20 73 65 6c 66 rs-before! self
2090: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
20a0: 65 29 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d e)). (sdat-set-
20b0: 64 6f 6d 61 69 6e 21 20 20 20 20 20 20 20 20 20 domain!
20c0: 20 20 20 20 73 65 6c 66 20 22 6c 6f 63 61 68 6f self "locaho
20d0: 73 74 22 29 20 20 20 3b 3b 20 65 6e 64 20 6f 66 st") ;; end of
20e0: 20 64 65 66 61 75 6c 74 73 0a 20 20 28 6c 65 74 defaults. (let
20f0: 2a 20 28 28 72 61 77 63 6f 6e 66 69 67 64 61 74 * ((rawconfigdat
2100: 20 28 73 65 73 73 69 6f 6e 3a 72 65 61 64 2d 63 (session:read-c
2110: 6f 6e 66 69 67 20 73 65 6c 66 29 29 0a 09 20 28 onfig self)).. (
2120: 63 6f 6e 66 69 67 64 61 74 20 28 69 66 20 72 61 configdat (if ra
2130: 77 63 6f 6e 66 69 67 64 61 74 20 28 65 76 61 6c wconfigdat (eval
2140: 20 72 61 77 63 6f 6e 66 69 67 64 61 74 29 20 27 rawconfigdat) '
2150: 28 29 29 29 0a 09 20 28 73 72 6f 6f 74 20 20 20 ())).. (sroot
2160: 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 (s:find-param
2170: 27 73 72 6f 6f 74 20 20 20 20 63 6f 6e 66 69 67 'sroot config
2180: 64 61 74 29 29 0a 09 20 28 6c 6f 67 66 69 6c 65 dat)).. (logfile
2190: 20 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d (s:find-param
21a0: 20 27 6c 6f 67 66 69 6c 65 20 20 63 6f 6e 66 69 'logfile confi
21b0: 67 64 61 74 29 29 0a 09 20 28 64 62 74 79 70 65 gdat)).. (dbtype
21c0: 20 20 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 (s:find-para
21d0: 6d 20 27 64 62 74 79 70 65 20 20 20 63 6f 6e 66 m 'dbtype conf
21e0: 69 67 64 61 74 29 29 0a 09 20 28 64 62 69 6e 69 igdat)).. (dbini
21f0: 74 20 20 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 t (s:find-par
2200: 61 6d 20 27 64 62 69 6e 69 74 20 20 20 63 6f 6e am 'dbinit con
2210: 66 69 67 64 61 74 29 29 0a 09 20 28 64 6f 6d 61 figdat)).. (doma
2220: 69 6e 20 20 20 20 28 73 3a 66 69 6e 64 2d 70 61 in (s:find-pa
2230: 72 61 6d 20 27 64 6f 6d 61 69 6e 20 20 20 63 6f ram 'domain co
2240: 6e 66 69 67 64 61 74 29 29 29 0a 20 20 20 20 3b nfigdat))). ;
2250: 3b 20 28 70 72 69 6e 74 20 22 63 6f 6e 66 69 67 ; (print "config
2260: 64 61 74 3a 20 22 29 28 70 70 20 63 6f 6e 66 69 dat: ")(pp confi
2270: 67 64 61 74 29 0a 20 20 20 20 3b 3b 20 28 70 72 gdat). ;; (pr
2280: 69 6e 74 20 22 73 72 6f 6f 74 3a 20 22 20 73 72 int "sroot: " sr
2290: 6f 6f 74 20 22 20 6c 6f 67 66 69 6c 65 3a 20 22 oot " logfile: "
22a0: 20 6c 6f 67 66 69 6c 65 20 22 20 64 62 74 79 70 logfile " dbtyp
22b0: 65 3a 20 22 20 64 62 74 79 70 65 20 22 20 64 62 e: " dbtype " db
22c0: 69 6e 69 74 3a 20 22 20 64 62 69 6e 69 74 20 22 init: " dbinit "
22d0: 20 64 6f 6d 61 69 6e 3a 20 22 20 64 6f 6d 61 69 domain: " domai
22e0: 6e 29 0a 20 20 20 20 28 69 66 20 73 72 6f 6f 74 n). (if sroot
22f0: 20 20 20 28 73 64 61 74 2d 73 65 74 2d 73 72 6f (sdat-set-sro
2300: 6f 74 21 20 20 20 73 65 6c 66 20 73 72 6f 6f 74 ot! self sroot
2310: 29 29 0a 20 20 20 20 28 69 66 20 6c 6f 67 66 69 )). (if logfi
2320: 6c 65 20 28 73 64 61 74 2d 73 65 74 2d 6c 6f 67 le (sdat-set-log
2330: 66 69 6c 65 21 20 73 65 6c 66 20 6c 6f 67 66 69 file! self logfi
2340: 6c 65 29 29 0a 20 20 20 20 28 69 66 20 64 62 74 le)). (if dbt
2350: 79 70 65 20 20 28 73 64 61 74 2d 73 65 74 2d 64 ype (sdat-set-d
2360: 62 74 79 70 65 21 20 20 73 65 6c 66 20 64 62 74 btype! self dbt
2370: 79 70 65 29 29 0a 20 20 20 20 28 69 66 20 64 62 ype)). (if db
2380: 69 6e 69 74 20 20 28 73 64 61 74 2d 73 65 74 2d init (sdat-set-
2390: 64 62 69 6e 69 74 21 20 20 73 65 6c 66 20 64 62 dbinit! self db
23a0: 69 6e 69 74 29 29 0a 20 20 20 20 28 69 66 20 64 init)). (if d
23b0: 6f 6d 61 69 6e 20 20 28 73 64 61 74 2d 73 65 74 omain (sdat-set
23c0: 2d 64 6f 6d 61 69 6e 21 20 20 73 65 6c 66 20 64 -domain! self d
23d0: 6f 6d 61 69 6e 29 29 29 29 0a 3b 3b 20 20 20 28 omain)))).;; (
23e0: 6c 65 74 20 28 28 64 62 74 79 70 65 20 28 73 64 let ((dbtype (sd
23f0: 61 74 2d 67 65 74 2d 64 62 74 79 70 65 20 73 65 at-get-dbtype se
2400: 6c 66 29 29 29 0a 3b 3b 20 20 20 20 20 28 70 72 lf))).;; (pr
2410: 69 6e 74 20 22 64 62 74 79 70 65 3a 20 22 20 64 int "dbtype: " d
2420: 62 74 79 70 65 29 0a 3b 3b 20 20 20 20 20 28 73 btype).;; (s
2430: 64 61 74 2d 73 65 74 2d 64 62 74 79 70 65 21 20 dat-set-dbtype!
2440: 73 65 6c 66 20 28 65 76 61 6c 20 64 62 74 79 70 self (eval dbtyp
2450: 65 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 e))))..(define (
2460: 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 20 73 65 session:setup se
2470: 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 64 62 74 lf). (let ((dbt
2480: 79 70 65 20 28 73 64 61 74 2d 67 65 74 2d 64 62 ype (sdat-get-db
2490: 74 79 70 65 20 73 65 6c 66 29 29 0a 09 28 64 62 type self))..(db
24a0: 69 6e 69 74 20 28 65 76 61 6c 20 28 73 64 61 74 init (eval (sdat
24b0: 2d 67 65 74 2d 64 62 69 6e 69 74 20 73 65 6c 66 -get-dbinit self
24c0: 29 29 29 0a 09 28 64 62 65 78 69 73 74 73 20 23 )))..(dbexists #
24d0: 66 29 29 0a 20 20 20 20 28 6c 65 74 20 28 28 64 f)). (let ((d
24e0: 62 66 6e 61 6d 65 20 28 61 6c 69 73 74 2d 72 65 bfname (alist-re
24f0: 66 20 27 64 62 6e 61 6d 65 20 64 62 69 6e 69 74 f 'dbname dbinit
2500: 29 29 29 0a 20 20 20 20 20 20 28 69 66 20 28 65 ))). (if (e
2510: 71 3f 20 64 62 74 79 70 65 20 27 73 71 6c 69 74 q? dbtype 'sqlit
2520: 65 33 29 0a 09 20 20 28 69 66 20 28 66 69 6c 65 e3).. (if (file
2530: 2d 65 78 69 73 74 73 3f 20 64 62 66 6e 61 6d 65 -exists? dbfname
2540: 29 0a 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a ).. (begin.
2550: 09 09 3b 3b 20 28 73 65 73 73 69 6f 6e 3a 6c 6f ..;; (session:lo
2560: 67 20 73 65 6c 66 20 22 73 65 74 74 69 6e 67 20 g self "setting
2570: 64 62 65 78 69 73 74 73 20 74 6f 20 23 74 22 29 dbexists to #t")
2580: 0a 09 09 28 73 65 74 21 20 64 62 65 78 69 73 74 ...(set! dbexist
2590: 73 20 23 74 29 29 29 29 0a 20 20 20 20 20 20 3b s #t)))). ;
25a0: 3b 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 ; (session:log s
25b0: 65 6c 66 20 22 64 62 74 79 70 65 3a 20 22 20 64 elf "dbtype: " d
25c0: 62 74 79 70 65 20 22 20 64 62 66 6e 61 6d 65 3a btype " dbfname:
25d0: 20 22 20 64 62 66 6e 61 6d 65 20 22 20 64 62 65 " dbfname " dbe
25e0: 78 69 73 74 73 3a 20 22 20 64 62 65 78 69 73 74 xists: " dbexist
25f0: 73 29 29 0a 20 20 20 20 20 20 29 0a 20 20 20 20 s)). ).
2600: 28 73 64 61 74 2d 73 65 74 2d 63 6f 6e 6e 21 20 (sdat-set-conn!
2610: 73 65 6c 66 20 28 64 62 69 3a 6f 70 65 6e 20 64 self (dbi:open d
2620: 62 74 79 70 65 20 64 62 69 6e 69 74 29 29 0a 20 btype dbinit)).
2630: 20 20 20 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 (if (and (not
2640: 20 64 62 65 78 69 73 74 73 29 28 65 71 3f 20 64 dbexists)(eq? d
2650: 62 74 79 70 65 20 27 73 71 6c 69 74 65 33 29 29 btype 'sqlite3))
2660: 0a 20 09 28 62 65 67 69 6e 0a 09 20 20 28 70 72 . .(begin.. (pr
2670: 69 6e 74 20 22 57 41 52 4e 49 4e 47 3a 20 53 65 int "WARNING: Se
2680: 74 74 69 6e 67 20 75 70 20 73 65 73 73 69 6f 6e tting up session
2690: 20 64 62 20 77 69 74 68 20 73 71 6c 69 74 65 33 db with sqlite3
26a0: 22 29 0a 09 20 20 28 73 65 73 73 69 6f 6e 3a 73 ").. (session:s
26b0: 65 74 75 70 2d 64 62 20 73 65 6c 66 29 29 29 0a etup-db self))).
26c0: 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 70 72 6f (session:pro
26d0: 63 65 73 73 2d 75 72 6c 2d 70 61 74 68 20 73 65 cess-url-path se
26e0: 6c 66 29 0a 20 20 20 20 28 73 65 73 73 69 6f 6e lf). (session
26f0: 3a 73 65 74 75 70 2d 73 65 73 73 69 6f 6e 2d 6b :setup-session-k
2700: 65 79 20 73 65 6c 66 29 0a 20 20 20 20 3b 3b 20 ey self). ;;
2710: 63 61 70 74 75 72 65 20 73 74 64 69 6e 20 69 66 capture stdin if
2720: 20 74 68 69 73 20 69 73 20 61 20 50 4f 53 54 0a this is a POST.
2730: 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d 72 65 (sdat-set-re
2740: 71 75 65 73 74 2d 6d 65 74 68 6f 64 21 20 73 65 quest-method! se
2750: 6c 66 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d lf (get-environm
2760: 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 52 45 ent-variable "RE
2770: 51 55 45 53 54 5f 4d 45 54 48 4f 44 22 29 29 0a QUEST_METHOD")).
2780: 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d 66 6f (sdat-set-fo
2790: 72 6d 64 61 74 21 20 73 65 6c 66 20 28 66 6f 72 rmdat! self (for
27a0: 6d 64 61 74 3a 6c 6f 61 64 2d 61 6c 6c 29 29 29 mdat:load-all)))
27b0: 29 0a 0a 3b 3b 20 73 65 74 75 70 20 74 68 65 20 )..;; setup the
27c0: 64 62 20 77 69 74 68 20 73 65 73 73 69 6f 6e 20 db with session
27d0: 74 61 62 6c 65 73 2c 20 77 6f 72 6b 73 20 66 6f tables, works fo
27e0: 72 20 73 71 6c 69 74 65 20 6f 6e 6c 79 20 72 69 r sqlite only ri
27f0: 67 68 74 20 6e 6f 77 0a 28 64 65 66 69 6e 65 20 ght now.(define
2800: 28 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 2d 64 (session:setup-d
2810: 62 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 20 28 b self). (let (
2820: 28 63 6f 6e 6e 20 28 73 64 61 74 2d 67 65 74 2d (conn (sdat-get-
2830: 63 6f 6e 6e 20 73 65 6c 66 29 29 29 0a 20 20 20 conn self))).
2840: 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 (for-each .
2850: 20 28 6c 61 6d 62 64 61 20 28 73 74 6d 74 29 0a (lambda (stmt).
2860: 20 20 20 20 20 20 20 28 64 62 69 3a 65 78 65 63 (dbi:exec
2870: 20 63 6f 6e 6e 20 73 74 6d 74 29 29 0a 20 20 20 conn stmt)).
2880: 20 20 28 6c 69 73 74 20 22 43 52 45 41 54 45 20 (list "CREATE
2890: 54 41 42 4c 45 20 73 65 73 73 69 6f 6e 5f 76 61 TABLE session_va
28a0: 72 73 20 28 69 64 20 49 4e 54 45 47 45 52 20 50 rs (id INTEGER P
28b0: 52 49 4d 41 52 59 20 4b 45 59 2c 73 65 73 73 69 RIMARY KEY,sessi
28c0: 6f 6e 5f 69 64 20 49 4e 54 45 47 45 52 2c 70 61 on_id INTEGER,pa
28d0: 67 65 20 54 45 58 54 2c 6b 65 79 20 54 45 58 54 ge TEXT,key TEXT
28e0: 2c 76 61 6c 75 65 20 54 45 58 54 29 3b 22 0a 09 ,value TEXT);"..
28f0: 20 20 20 22 43 52 45 41 54 45 20 54 41 42 4c 45 "CREATE TABLE
2900: 20 73 65 73 73 69 6f 6e 73 20 28 69 64 20 49 4e sessions (id IN
2910: 54 45 47 45 52 20 50 52 49 4d 41 52 59 20 4b 45 TEGER PRIMARY KE
2920: 59 2c 73 65 73 73 69 6f 6e 5f 6b 65 79 20 54 45 Y,session_key TE
2930: 58 54 2c 6c 61 73 74 5f 75 73 65 64 20 54 49 4d XT,last_used TIM
2940: 45 53 54 41 4d 50 29 3b 22 0a 20 20 20 20 20 20 ESTAMP);".
2950: 20 20 20 20 20 22 43 52 45 41 54 45 20 54 41 42 "CREATE TAB
2960: 4c 45 20 6d 65 74 61 64 61 74 61 20 28 69 64 20 LE metadata (id
2970: 49 4e 54 45 47 45 52 20 50 52 49 4d 41 52 59 20 INTEGER PRIMARY
2980: 4b 45 59 2c 6b 65 79 20 54 45 58 54 2c 76 61 6c KEY,key TEXT,val
2990: 75 65 20 54 45 58 54 29 3b 22 29 29 29 29 0a 3b ue TEXT);")))).;
29a0: 3b 20 20 3b 3b 20 69 66 20 77 65 20 68 61 76 65 ; ;; if we have
29b0: 20 61 20 73 65 73 73 69 6f 6e 5f 6b 65 79 20 6c a session_key l
29c0: 6f 6f 6b 20 75 70 20 74 68 65 20 73 65 73 73 69 ook up the sessi
29d0: 6f 6e 2d 69 64 20 61 6e 64 20 73 74 6f 72 65 20 on-id and store
29e0: 69 74 0a 3b 3b 20 20 28 73 64 61 74 2d 73 65 74 it.;; (sdat-set
29f0: 2d 73 65 73 73 69 6f 6e 2d 69 64 21 20 73 65 6c -session-id! sel
2a00: 66 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 69 f (session:get-i
2a10: 64 20 73 65 6c 66 29 29 29 0a 0a 3b 3b 20 6f 6e d self)))..;; on
2a20: 6c 79 20 73 65 74 20 73 65 73 73 69 6f 6e 2d 63 ly set session-c
2a30: 6f 6f 6b 69 65 20 77 68 65 6e 20 61 20 6e 65 77 ookie when a new
2a40: 20 73 65 73 73 69 6f 6e 20 69 73 20 63 72 65 61 session is crea
2a50: 74 65 64 0a 28 64 65 66 69 6e 65 20 28 73 65 73 ted.(define (ses
2a60: 73 69 6f 6e 3a 73 65 74 75 70 2d 73 65 73 73 69 sion:setup-sessi
2a70: 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 20 20 0a 20 on-key self) .
2a80: 20 28 6c 65 74 2a 20 28 28 73 6b 20 20 28 73 65 (let* ((sk (se
2a90: 73 73 69 6f 6e 3a 65 78 74 72 61 63 74 2d 73 65 ssion:extract-se
2aa0: 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 29 ssion-key self))
2ab0: 0a 20 20 20 20 20 20 20 20 20 28 73 69 64 20 28 . (sid (
2ac0: 69 66 20 73 6b 20 28 73 65 73 73 69 6f 6e 3a 67 if sk (session:g
2ad0: 65 74 2d 69 64 20 73 65 6c 66 20 73 6b 29 20 23 et-id self sk) #
2ae0: 66 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f f))). (if (no
2af0: 74 20 73 69 64 29 20 3b 3b 20 6e 65 65 64 20 61 t sid) ;; need a
2b00: 20 6e 65 77 20 6b 65 79 0a 20 20 20 20 20 20 20 new key.
2b10: 20 28 6c 65 74 2a 20 28 28 6e 65 77 2d 6b 65 79 (let* ((new-key
2b20: 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 6e 65 (session:get-ne
2b30: 77 2d 6b 65 79 20 73 65 6c 66 29 29 0a 20 20 20 w-key self)).
2b40: 20 20 20 20 20 20 20 20 20 20 20 20 28 6e 65 77 (new
2b50: 2d 73 69 64 20 28 73 65 73 73 69 6f 6e 3a 67 65 -sid (session:ge
2b60: 74 2d 69 64 20 73 65 6c 66 20 6e 65 77 2d 6b 65 t-id self new-ke
2b70: 79 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 y))). (
2b80: 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e sdat-set-session
2b90: 2d 6b 65 79 21 20 73 65 6c 66 20 6e 65 77 2d 6b -key! self new-k
2ba0: 65 79 29 0a 20 20 20 20 20 20 20 20 20 20 28 73 ey). (s
2bb0: 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e 2d dat-set-session-
2bc0: 69 64 21 20 73 65 6c 66 20 6e 65 77 2d 73 69 64 id! self new-sid
2bd0: 29 0a 20 20 20 20 20 20 20 20 20 20 28 73 64 61 ). (sda
2be0: 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e 2d 63 6f t-set-session-co
2bf0: 6f 6b 69 65 21 20 73 65 6c 66 20 28 73 65 73 73 okie! self (sess
2c00: 69 6f 6e 3a 6d 61 6b 65 2d 63 6f 6f 6b 69 65 20 ion:make-cookie
2c10: 73 65 6c 66 29 29 29 0a 20 20 20 20 20 20 20 20 self))).
2c20: 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f (sdat-set-sessio
2c30: 6e 2d 69 64 21 20 73 65 6c 66 20 73 69 64 29 29 n-id! self sid))
2c40: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 ))..(define (ses
2c50: 73 69 6f 6e 3a 6d 61 6b 65 2d 63 6f 6f 6b 69 65 sion:make-cookie
2c60: 20 73 65 6c 66 29 0a 20 20 3b 3b 20 28 6c 69 73 self). ;; (lis
2c70: 74 20 28 63 6f 6e 63 20 22 73 65 73 73 69 6f 6e t (conc "session
2c80: 5f 6b 65 79 3d 22 20 28 73 64 61 74 2d 67 65 74 _key=" (sdat-get
2c90: 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c -session-key sel
2ca0: 66 29 20 22 3b 20 50 61 74 68 3d 2f 3b 20 44 6f f) "; Path=/; Do
2cb0: 6d 61 69 6e 3d 2e 22 20 28 73 64 61 74 2d 67 65 main=." (sdat-ge
2cc0: 74 2d 64 6f 6d 61 69 6e 20 73 65 6c 66 29 20 22 t-domain self) "
2cd0: 3b 20 4d 61 78 2d 41 67 65 3d 22 20 28 2a 20 38 ; Max-Age=" (* 8
2ce0: 36 34 30 30 20 31 34 29 20 22 3b 20 56 65 72 73 6400 14) "; Vers
2cf0: 69 6f 6e 3d 31 22 29 29 29 20 0a 20 20 28 6c 69 ion=1"))) . (li
2d00: 73 74 20 28 73 74 72 69 6e 67 2d 73 75 62 73 74 st (string-subst
2d10: 69 74 75 74 65 20 0a 09 20 22 3b 22 20 22 3b 20 itute .. ";" ";
2d20: 22 20 0a 09 20 28 63 61 72 20 28 63 6f 6e 73 74 " .. (car (const
2d30: 72 75 63 74 2d 63 6f 6f 6b 69 65 2d 73 74 72 69 ruct-cookie-stri
2d40: 6e 67 20 0a 09 20 20 20 20 20 20 20 3b 3b 20 77 ng .. ;; w
2d50: 61 72 6e 69 6e 67 21 20 6d 65 73 73 69 6e 67 20 arning! messing
2d60: 75 70 20 74 68 69 73 20 69 74 74 79 20 62 69 74 up this itty bit
2d70: 74 79 20 62 69 74 20 6f 66 20 63 6f 64 65 20 77 ty bit of code w
2d80: 69 6c 6c 20 63 6f 73 74 20 6d 75 63 68 20 74 69 ill cost much ti
2d90: 6d 65 21 0a 09 20 20 20 20 20 20 20 60 28 28 22 me!.. `(("
2da0: 73 65 73 73 69 6f 6e 5f 6b 65 79 22 20 2c 28 73 session_key" ,(s
2db0: 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 2d dat-get-session-
2dc0: 6b 65 79 20 73 65 6c 66 29 0a 09 09 20 20 65 78 key self)... ex
2dd0: 70 69 72 65 73 3a 20 2c 28 2b 20 28 63 75 72 72 pires: ,(+ (curr
2de0: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 28 2a 20 ent-seconds) (*
2df0: 31 34 20 38 36 34 30 30 29 29 20 0a 09 09 20 20 14 86400)) ...
2e00: 6d 61 78 2d 61 67 65 3a 20 28 2a 20 31 34 20 38 max-age: (* 14 8
2e10: 36 34 30 30 29 0a 09 09 20 20 70 61 74 68 3a 20 6400)... path:
2e20: 22 2f 22 20 3b 3b 20 0a 09 09 20 20 64 6f 6d 61 "/" ;; ... doma
2e30: 69 6e 3a 20 2c 28 73 74 72 69 6e 67 2d 61 70 70 in: ,(string-app
2e40: 65 6e 64 20 22 2e 22 20 28 73 64 61 74 2d 67 65 end "." (sdat-ge
2e50: 74 2d 64 6f 6d 61 69 6e 20 73 65 6c 66 29 29 0a t-domain self)).
2e60: 09 09 20 20 76 65 72 73 69 6f 6e 3a 20 31 29 29 .. version: 1))
2e70: 20 30 29 29 29 29 29 0a 0a 3b 3b 20 6c 6f 6f 6b 0)))))..;; look
2e80: 20 75 70 20 61 20 67 69 76 65 6e 20 73 65 73 73 up a given sess
2e90: 69 6f 6e 20 6b 65 79 20 61 6e 64 20 72 65 74 75 ion key and retu
2ea0: 72 6e 20 74 68 65 20 69 64 20 69 66 20 66 6f 75 rn the id if fou
2eb0: 6e 64 2c 20 23 66 20 69 66 20 6e 6f 74 20 66 6f nd, #f if not fo
2ec0: 75 6e 64 0a 28 64 65 66 69 6e 65 20 28 73 65 73 und.(define (ses
2ed0: 73 69 6f 6e 3a 67 65 74 2d 69 64 20 73 65 6c 66 sion:get-id self
2ee0: 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 0a 20 20 session-key).
2ef0: 3b 3b 20 28 6c 65 74 20 28 28 73 65 73 73 69 6f ;; (let ((sessio
2f00: 6e 2d 6b 65 79 20 28 73 64 61 74 2d 67 65 74 2d n-key (sdat-get-
2f10: 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 session-key self
2f20: 29 29 29 0a 20 20 28 69 66 20 73 65 73 73 69 6f ))). (if sessio
2f30: 6e 2d 6b 65 79 0a 20 20 20 20 20 20 28 6c 65 74 n-key. (let
2f40: 20 28 28 71 75 65 72 79 20 28 73 74 72 69 6e 67 ((query (string
2f50: 2d 61 70 70 65 6e 64 20 22 53 45 4c 45 43 54 20 -append "SELECT
2f60: 69 64 20 46 52 4f 4d 20 73 65 73 73 69 6f 6e 73 id FROM sessions
2f70: 20 57 48 45 52 45 20 73 65 73 73 69 6f 6e 5f 6b WHERE session_k
2f80: 65 79 3d 27 22 20 73 65 73 73 69 6f 6e 2d 6b 65 ey='" session-ke
2f90: 79 20 22 27 22 29 29 0a 20 20 20 20 20 20 20 20 y "'")).
2fa0: 20 20 20 20 28 63 6f 6e 6e 20 28 73 64 61 74 2d (conn (sdat-
2fb0: 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 0a get-conn self)).
2fc0: 20 20 20 20 20 20 20 20 20 20 20 20 28 72 65 73 (res
2fd0: 75 6c 74 20 23 66 29 29 0a 09 28 64 62 69 3a 66 ult #f))..(dbi:f
2fe0: 6f 72 2d 65 61 63 68 2d 72 6f 77 20 0a 09 20 28 or-each-row .. (
2ff0: 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 29 0a 09 lambda (tuple)..
3000: 20 20 20 28 73 65 74 21 20 72 65 73 75 6c 74 20 (set! result
3010: 28 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c (vector-ref tupl
3020: 65 20 30 29 29 29 0a 09 20 63 6f 6e 6e 20 71 75 e 0))).. conn qu
3030: 65 72 79 29 0a 09 28 69 66 20 72 65 73 75 6c 74 ery)..(if result
3040: 20 28 64 62 69 3a 65 78 65 63 20 63 6f 6e 6e 20 (dbi:exec conn
3050: 28 63 6f 6e 63 20 22 55 50 44 41 54 45 20 73 65 (conc "UPDATE se
3060: 73 73 69 6f 6e 73 20 53 45 54 20 6c 61 73 74 5f ssions SET last_
3070: 75 73 65 64 3d 22 20 28 64 62 69 3a 6e 6f 77 20 used=" (dbi:now
3080: 63 6f 6e 6e 29 20 22 20 57 48 45 52 45 20 73 65 conn) " WHERE se
3090: 73 73 69 6f 6e 5f 6b 65 79 3d 3f 3b 22 29 20 73 ssion_key=?;") s
30a0: 65 73 73 69 6f 6e 2d 6b 65 79 29 29 0a 20 20 20 ession-key)).
30b0: 20 20 20 20 20 72 65 73 75 6c 74 29 0a 20 20 20 result).
30c0: 20 20 20 23 66 29 29 0a 0a 3b 3b 20 0a 28 64 65 #f))..;; .(de
30d0: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 70 72 fine (session:pr
30e0: 6f 63 65 73 73 2d 75 72 6c 2d 70 61 74 68 20 73 ocess-url-path s
30f0: 65 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 70 61 elf). (let ((pa
3100: 74 68 2d 69 6e 66 6f 20 20 20 20 28 67 65 74 2d th-info (get-
3110: 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 environment-vari
3120: 61 62 6c 65 20 22 50 41 54 48 5f 49 4e 46 4f 22 able "PATH_INFO"
3130: 29 29 0a 09 28 71 75 65 72 79 2d 73 74 72 69 6e ))..(query-strin
3140: 67 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 g (get-environme
3150: 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 51 55 45 nt-variable "QUE
3160: 52 59 5f 53 54 52 49 4e 47 22 29 29 29 0a 20 20 RY_STRING"))).
3170: 20 20 3b 3b 20 28 73 65 73 73 69 6f 6e 3a 6c 6f ;; (session:lo
3180: 67 20 73 65 6c 66 20 22 70 61 74 68 2d 69 6e 66 g self "path-inf
3190: 6f 3d 22 20 70 61 74 68 2d 69 6e 66 6f 20 22 20 o=" path-info "
31a0: 71 75 65 72 79 2d 73 74 72 69 6e 67 3d 22 20 71 query-string=" q
31b0: 75 65 72 79 2d 73 74 72 69 6e 67 29 0a 20 20 20 uery-string).
31c0: 20 28 69 66 20 70 61 74 68 2d 69 6e 66 6f 0a 09 (if path-info..
31d0: 28 6c 65 74 2a 20 28 28 70 61 72 74 73 20 20 20 (let* ((parts
31e0: 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 70 (string-split p
31f0: 61 74 68 2d 69 6e 66 6f 20 22 2f 22 29 29 0a 09 ath-info "/"))..
3200: 20 20 20 20 20 20 20 28 6e 75 6d 70 61 72 74 73 (numparts
3210: 20 28 6c 65 6e 67 74 68 20 70 61 72 74 73 29 29 (length parts))
3220: 29 0a 09 20 20 28 69 66 20 28 3e 20 6e 75 6d 70 ).. (if (> nump
3230: 61 72 74 73 20 30 29 0a 09 20 20 20 20 20 20 28 arts 0).. (
3240: 73 64 61 74 2d 73 65 74 2d 70 61 67 65 21 20 73 sdat-set-page! s
3250: 65 6c 66 20 28 63 61 72 20 70 61 72 74 73 29 29 elf (car parts))
3260: 29 0a 09 20 20 3b 3b 20 28 73 65 73 73 69 6f 6e ).. ;; (session
3270: 3a 6c 6f 67 20 73 65 6c 66 20 22 75 72 6c 2d 70 :log self "url-p
3280: 61 74 68 3d 22 20 75 72 6c 2d 70 61 74 68 20 22 ath=" url-path "
3290: 20 70 61 72 74 73 3d 22 20 70 61 72 74 73 29 0a parts=" parts).
32a0: 09 20 20 28 69 66 20 28 3e 20 6e 75 6d 70 61 72 . (if (> numpar
32b0: 74 73 20 31 29 0a 09 20 20 20 20 20 20 28 73 64 ts 1).. (sd
32c0: 61 74 2d 73 65 74 2d 70 61 74 68 2d 70 61 72 61 at-set-path-para
32d0: 6d 73 21 20 73 65 6c 66 20 28 63 64 72 20 70 61 ms! self (cdr pa
32e0: 72 74 73 29 29 29 0a 20 20 20 20 20 20 20 20 20 rts))).
32f0: 20 28 69 66 20 71 75 65 72 79 2d 73 74 72 69 6e (if query-strin
3300: 67 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 g.
3310: 28 73 64 61 74 2d 73 65 74 2d 70 61 72 61 6d 73 (sdat-set-params
3320: 21 20 73 65 6c 66 20 28 73 74 72 69 6e 67 2d 73 ! self (string-s
3330: 70 6c 69 74 20 71 75 65 72 79 2d 73 74 72 69 6e plit query-strin
3340: 67 20 22 26 22 29 29 29 29 29 29 29 0a 0a 3b 3b g "&")))))))..;;
3350: 20 42 55 47 47 59 21 0a 28 64 65 66 69 6e 65 20 BUGGY!.(define
3360: 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 6e 65 77 (session:get-new
3370: 2d 6b 65 79 20 73 65 6c 66 29 0a 20 20 28 6c 65 -key self). (le
3380: 74 20 28 28 63 6f 6e 6e 20 20 20 28 73 64 61 74 t ((conn (sdat
3390: 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 -get-conn self))
33a0: 0a 20 20 20 20 20 20 20 20 28 74 6d 70 6b 65 79 . (tmpkey
33b0: 20 28 73 65 73 73 69 6f 6e 3a 6d 61 6b 65 2d 72 (session:make-r
33c0: 61 6e 64 2d 73 74 72 69 6e 67 20 32 30 29 29 0a and-string 20)).
33d0: 20 20 20 20 20 20 20 20 28 73 74 61 74 75 73 20 (status
33e0: 23 66 29 29 0a 20 20 20 20 28 64 62 69 3a 66 6f #f)). (dbi:fo
33f0: 72 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 6d 62 r-each-row (lamb
3400: 64 61 20 28 74 75 70 6c 65 29 0a 09 09 09 28 73 da (tuple)....(s
3410: 65 74 21 20 73 74 61 74 75 73 20 23 74 29 29 0a et! status #t)).
3420: 09 09 20 20 20 20 20 20 63 6f 6e 6e 20 28 73 74 .. conn (st
3430: 72 69 6e 67 2d 61 70 70 65 6e 64 20 22 49 4e 53 ring-append "INS
3440: 45 52 54 20 49 4e 54 4f 20 73 65 73 73 69 6f 6e ERT INTO session
3450: 73 20 28 73 65 73 73 69 6f 6e 5f 6b 65 79 29 20 s (session_key)
3460: 56 41 4c 55 45 53 20 28 27 22 20 74 6d 70 6b 65 VALUES ('" tmpke
3470: 79 20 22 27 29 22 29 29 0a 20 20 20 20 74 6d 70 y "')")). tmp
3480: 6b 65 79 29 29 0a 0a 3b 3b 20 72 65 74 75 72 6e key))..;; return
3490: 73 20 73 65 73 73 69 6f 6e 20 6b 65 79 20 49 46 s session key IF
34a0: 46 20 69 74 20 69 73 20 69 6e 20 74 68 65 20 48 F it is in the H
34b0: 54 54 50 5f 43 4f 4f 4b 49 45 20 0a 28 64 65 66 TTP_COOKIE .(def
34c0: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 65 78 74 ine (session:ext
34d0: 72 61 63 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 ract-session-key
34e0: 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 self). (let ((
34f0: 68 74 74 70 2d 73 65 73 73 69 6f 6e 20 28 67 65 http-session (ge
3500: 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 t-environment-va
3510: 72 69 61 62 6c 65 20 22 48 54 54 50 5f 43 4f 4f riable "HTTP_COO
3520: 4b 49 45 22 29 29 29 0a 20 20 20 20 28 69 66 20 KIE"))). (if
3530: 68 74 74 70 2d 73 65 73 73 69 6f 6e 20 0a 20 20 http-session .
3540: 20 20 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 65 (session:e
3550: 78 74 72 61 63 74 2d 6b 65 79 2d 66 72 6f 6d 2d xtract-key-from-
3560: 70 61 72 61 6d 20 73 65 6c 66 20 28 6c 69 73 74 param self (list
3570: 20 68 74 74 70 2d 73 65 73 73 69 6f 6e 29 20 22 http-session) "
3580: 73 65 73 73 69 6f 6e 5f 6b 65 79 22 29 0a 20 20 session_key").
3590: 20 20 20 20 20 20 23 66 29 29 29 0a 0a 28 64 65 #f)))..(de
35a0: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 fine (session:ge
35b0: 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c t-session-id sel
35c0: 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 0a 20 f session-key).
35d0: 20 28 6c 65 74 20 28 28 71 75 65 72 79 20 22 53 (let ((query "S
35e0: 45 4c 45 43 54 20 69 64 20 46 52 4f 4d 20 73 65 ELECT id FROM se
35f0: 73 73 69 6f 6e 73 20 57 48 45 52 45 20 73 65 73 ssions WHERE ses
3600: 73 69 6f 6e 5f 6b 65 79 3d 3f 3b 22 29 0a 20 20 sion_key=?;").
3610: 20 20 20 20 20 20 28 72 65 73 75 6c 74 20 23 66 (result #f
3620: 29 29 0a 20 20 20 20 3b 3b 20 20 20 20 20 28 70 )). ;; (p
3630: 67 3a 71 75 65 72 79 2d 66 6f 72 2d 65 61 63 68 g:query-for-each
3640: 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 29 (lambda (tuple)
3650: 0a 20 20 20 20 3b 3b 20 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 28 73 65 74 21 20 72 65 73 75 6c 74 20 28 76 (set! result (v
3680: 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 ector-ref tuple
3690: 30 29 29 29 20 3b 3b 20 28 76 65 63 74 6f 72 2d 0))) ;; (vector-
36a0: 72 65 66 20 74 75 70 6c 65 20 30 29 29 29 0a 20 ref tuple 0))).
36b0: 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 ;;
36c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 3a (s:
36d0: 73 71 6c 70 61 72 61 6d 20 71 75 65 72 79 20 73 sqlparam query s
36e0: 65 73 73 69 6f 6e 2d 6b 65 79 29 0a 20 20 20 20 ession-key).
36f0: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
3700: 20 20 20 20 20 20 20 20 20 20 28 73 64 61 74 2d (sdat-
3710: 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 0a get-conn self)).
3720: 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 ;;
3730: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 63 6f co
3740: 6e 6e 29 0a 20 20 20 20 28 64 62 69 3a 66 6f 72 nn). (dbi:for
3750: 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 6d 62 64 -each-row (lambd
3760: 61 20 28 74 75 70 6c 65 29 0a 09 09 09 28 73 65 a (tuple)....(se
3770: 74 21 20 72 65 73 75 6c 74 20 28 76 65 63 74 6f t! result (vecto
3780: 72 2d 72 65 66 20 74 75 70 6c 65 20 30 29 29 29 r-ref tuple 0)))
3790: 20 3b 3b 20 28 76 65 63 74 6f 72 2d 72 65 66 20 ;; (vector-ref
37a0: 74 75 70 6c 65 20 30 29 29 29 0a 09 09 20 20 20 tuple 0)))...
37b0: 20 20 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e (sdat-get-con
37c0: 6e 20 73 65 6c 66 29 0a 09 09 20 20 20 20 20 20 n self)...
37d0: 28 73 3a 73 71 6c 70 61 72 61 6d 20 71 75 65 72 (s:sqlparam quer
37e0: 79 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 0a y session-key)).
37f0: 20 20 20 20 72 65 73 75 6c 74 29 29 0a 0a 3b 3b result))..;;
3800: 20 64 65 6c 65 74 65 20 61 6c 6c 20 72 65 63 6f delete all reco
3810: 72 64 73 20 66 6f 72 20 61 20 73 65 73 73 69 6f rds for a sessio
3820: 6e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 n.;;.(define (se
3830: 73 73 69 6f 6e 3a 64 65 6c 65 74 65 2d 73 65 73 ssion:delete-ses
3840: 73 69 6f 6e 20 73 65 6c 66 20 73 65 73 73 69 6f sion self sessio
3850: 6e 2d 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 28 n-key). (let ((
3860: 73 65 73 73 69 6f 6e 2d 69 64 20 28 73 65 73 73 session-id (sess
3870: 69 6f 6e 3a 67 65 74 2d 73 65 73 73 69 6f 6e 2d ion:get-session-
3880: 69 64 20 73 65 6c 66 20 73 65 73 73 69 6f 6e 2d id self session-
3890: 6b 65 79 29 29 0a 20 20 20 20 20 20 20 20 28 71 key)). (q
38a0: 72 79 20 20 20 20 20 20 20 20 28 63 6f 6e 63 20 ry (conc
38b0: 22 42 45 47 49 4e 3b 22 0a 09 09 09 20 20 22 44 "BEGIN;".... "D
38c0: 45 4c 45 54 45 20 46 52 4f 4d 20 73 65 73 73 69 ELETE FROM sessi
38d0: 6f 6e 5f 76 61 72 73 20 57 48 45 52 45 20 73 65 on_vars WHERE se
38e0: 73 73 69 6f 6e 5f 69 64 3d 3f 3b 22 0a 20 20 20 ssion_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 22 44 45 4c 45 54 45 20 46 "DELETE F
3910: 52 4f 4d 20 73 65 73 73 69 6f 6e 73 20 57 48 45 ROM sessions WHE
3920: 52 45 20 69 64 3d 3f 3b 22 0a 09 09 09 20 20 22 RE id=?;".... "
3930: 43 4f 4d 4d 49 54 3b 22 29 29 0a 20 20 20 20 20 COMMIT;")).
3940: 20 20 20 28 63 6f 6e 6e 20 20 20 20 20 20 20 20 (conn
3950: 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d (sdat-get-
3960: 63 6f 6e 6e 20 73 65 6c 66 29 29 29 0a 20 20 20 conn self))).
3970: 20 28 69 66 20 73 65 73 73 69 6f 6e 2d 69 64 0a (if session-id.
3980: 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 (begin.
3990: 20 20 20 20 20 20 20 20 20 28 64 62 69 3a 65 78 (dbi:ex
39a0: 65 63 20 63 6f 6e 6e 20 71 72 79 20 73 65 73 73 ec conn qry sess
39b0: 69 6f 6e 2d 69 64 20 73 65 73 73 69 6f 6e 2d 69 ion-id session-i
39c0: 64 29 0a 09 20 20 28 69 6e 69 74 69 61 6c 69 7a d).. (initializ
39d0: 65 20 73 65 6c 66 20 27 28 29 29 0a 09 20 20 28 e self '()).. (
39e0: 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 20 73 65 session:setup se
39f0: 6c 66 29 29 29 0a 20 20 20 20 28 6e 6f 74 20 28 lf))). (not (
3a00: 73 65 73 73 69 6f 6e 3a 67 65 74 2d 73 65 73 73 session:get-sess
3a10: 69 6f 6e 2d 69 64 20 73 65 6c 66 20 73 65 73 73 ion-id self sess
3a20: 69 6f 6e 2d 6b 65 79 29 29 29 29 0a 0a 3b 3b 20 ion-key))))..;;
3a30: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
3a40: 3a 64 65 6c 65 74 65 2d 73 65 73 73 69 6f 6e 20 :delete-session
3a50: 73 65 6c 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 self session-key
3a60: 29 0a 3b 3b 20 20 20 28 6c 65 74 20 28 28 73 65 ).;; (let ((se
3a70: 73 73 69 6f 6e 2d 69 64 20 28 73 65 73 73 69 6f ssion-id (sessio
3a80: 6e 3a 67 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 n:get-session-id
3a90: 20 73 65 6c 66 20 73 65 73 73 69 6f 6e 2d 6b 65 self session-ke
3aa0: 79 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 28 y)).;; (
3ab0: 71 75 65 72 69 65 73 20 20 20 20 28 6c 69 73 74 queries (list
3ac0: 20 22 42 45 47 49 4e 3b 22 0a 3b 3b 20 09 09 09 "BEGIN;".;; ...
3ad0: 20 20 22 44 45 4c 45 54 45 20 46 52 4f 4d 20 73 "DELETE FROM s
3ae0: 65 73 73 69 6f 6e 5f 76 61 72 73 20 57 48 45 52 ession_vars WHER
3af0: 45 20 73 65 73 73 69 6f 6e 5f 69 64 3d 3f 3b 22 E session_id=?;"
3b00: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 .;;
3b10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 22 44 "D
3b20: 45 4c 45 54 45 20 46 52 4f 4d 20 73 65 73 73 69 ELETE FROM sessi
3b30: 6f 6e 73 20 57 48 45 52 45 20 69 64 3d 3f 3b 22 ons WHERE id=?;"
3b40: 0a 3b 3b 20 09 09 09 20 20 22 43 4f 4d 4d 49 54 .;; ... "COMMIT
3b50: 3b 22 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 ;")).;;
3b60: 28 63 6f 6e 6e 20 20 20 20 20 20 20 20 20 20 20 (conn
3b70: 20 20 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e (sdat-get-con
3b80: 6e 20 73 65 6c 66 29 29 29 0a 3b 3b 20 20 20 20 n self))).;;
3b90: 20 28 69 66 20 73 65 73 73 69 6f 6e 2d 69 64 0a (if session-id.
3ba0: 3b 3b 20 20 20 20 20 20 20 20 20 28 62 65 67 69 ;; (begi
3bb0: 6e 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 28 n.;; (
3bc0: 66 6f 72 2d 65 61 63 68 0a 3b 3b 20 20 20 20 20 for-each.;;
3bd0: 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 (lambda (
3be0: 71 75 65 72 79 29 0a 3b 3b 20 20 20 20 20 20 20 query).;;
3bf0: 20 20 20 20 20 20 20 28 64 62 69 3a 65 78 65 63 (dbi:exec
3c00: 20 63 6f 6e 6e 20 71 75 65 72 79 20 73 65 73 73 conn query sess
3c10: 69 6f 6e 2d 69 64 29 29 0a 3b 3b 20 09 20 20 20 ion-id)).;; .
3c20: 71 75 65 72 69 65 73 29 0a 3b 3b 20 09 20 20 28 queries).;; . (
3c30: 69 6e 69 74 69 61 6c 69 7a 65 20 73 65 6c 66 20 initialize self
3c40: 27 28 29 29 0a 3b 3b 20 09 20 20 28 73 65 73 73 '()).;; . (sess
3c50: 69 6f 6e 3a 73 65 74 75 70 20 73 65 6c 66 29 29 ion:setup self))
3c60: 29 0a 3b 3b 20 20 20 20 20 28 6e 6f 74 20 28 73 ).;; (not (s
3c70: 65 73 73 69 6f 6e 3a 67 65 74 2d 73 65 73 73 69 ession:get-sessi
3c80: 6f 6e 2d 69 64 20 73 65 6c 66 20 73 65 73 73 69 on-id self sessi
3c90: 6f 6e 2d 6b 65 79 29 29 29 29 0a 0a 28 64 65 66 on-key))))..(def
3ca0: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 65 78 74 ine (session:ext
3cb0: 72 61 63 74 2d 6b 65 79 20 73 65 6c 66 20 6b 65 ract-key self ke
3cc0: 79 29 0a 20 20 28 6c 65 74 20 28 28 70 61 72 61 y). (let ((para
3cd0: 6d 73 20 28 73 64 61 74 2d 67 65 74 2d 70 61 72 ms (sdat-get-par
3ce0: 61 6d 73 20 73 65 6c 66 29 29 29 0a 20 20 20 20 ams self))).
3cf0: 28 73 65 73 73 69 6f 6e 3a 65 78 74 72 61 63 74 (session:extract
3d00: 2d 6b 65 79 2d 66 72 6f 6d 2d 70 61 72 61 6d 20 -key-from-param
3d10: 73 65 6c 66 20 70 61 72 61 6d 73 20 6b 65 79 29 self params key)
3d20: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 ))..(define (ses
3d30: 73 69 6f 6e 3a 65 78 74 72 61 63 74 2d 6b 65 79 sion:extract-key
3d40: 2d 66 72 6f 6d 2d 70 61 72 61 6d 20 73 65 6c 66 -from-param self
3d50: 20 70 61 72 61 6d 73 20 6b 65 79 29 0a 20 20 28 params key). (
3d60: 6c 65 74 20 28 28 72 31 20 20 20 20 20 28 72 65 let ((r1 (re
3d70: 67 65 78 70 20 28 73 74 72 69 6e 67 2d 61 70 70 gexp (string-app
3d80: 65 6e 64 20 22 5e 22 20 6b 65 79 20 22 3d 28 5b end "^" key "=([
3d90: 5e 3d 5d 2b 29 24 22 29 29 29 29 0a 20 20 20 20 ^=]+)$")))).
3da0: 28 69 66 20 28 3c 20 28 6c 65 6e 67 74 68 20 70 (if (< (length p
3db0: 61 72 61 6d 73 29 20 31 29 20 23 66 0a 09 28 6c arams) 1) #f..(l
3dc0: 65 74 20 6c 6f 6f 70 20 28 28 68 65 61 64 20 20 et loop ((head
3dd0: 20 28 63 61 72 20 70 61 72 61 6d 73 29 29 0a 09 (car params))..
3de0: 09 20 20 20 28 74 61 69 6c 20 20 20 28 63 64 72 . (tail (cdr
3df0: 20 70 61 72 61 6d 73 29 29 29 0a 09 20 20 28 6c params))).. (l
3e00: 65 74 20 28 28 6d 61 74 63 68 20 28 73 74 72 69 et ((match (stri
3e10: 6e 67 2d 6d 61 74 63 68 20 72 31 20 68 65 61 64 ng-match r1 head
3e20: 29 29 29 0a 09 20 20 20 20 28 63 6f 6e 64 0a 09 ))).. (cond..
3e30: 20 20 20 20 20 28 6d 61 74 63 68 0a 09 20 20 20 (match..
3e40: 20 20 20 28 6c 65 74 20 28 28 73 65 73 73 69 6f (let ((sessio
3e50: 6e 2d 6b 65 79 20 28 6c 69 73 74 2d 72 65 66 20 n-key (list-ref
3e60: 6d 61 74 63 68 20 31 29 29 29 0a 09 09 28 73 64 match 1)))...(sd
3e70: 61 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e 2d 6b at-set-session-k
3e80: 65 79 21 20 73 65 6c 66 20 28 6c 69 73 74 2d 72 ey! self (list-r
3e90: 65 66 20 6d 61 74 63 68 20 31 29 29 0a 09 09 73 ef match 1))...s
3ea0: 65 73 73 69 6f 6e 2d 6b 65 79 29 29 0a 09 20 20 ession-key))..
3eb0: 20 20 20 28 28 6e 75 6c 6c 3f 20 74 61 69 6c 29 ((null? tail)
3ec0: 0a 09 20 20 20 20 20 20 23 66 29 0a 09 20 20 20 .. #f)..
3ed0: 20 20 28 65 6c 73 65 0a 09 20 20 20 20 20 20 28 (else.. (
3ee0: 6c 6f 6f 70 20 28 63 61 72 20 74 61 69 6c 29 0a loop (car tail).
3ef0: 09 09 20 20 20 20 28 63 64 72 20 74 61 69 6c 29 .. (cdr tail)
3f00: 29 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e ))))))))..(defin
3f10: 65 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 2d 70 e (session:set-p
3f20: 61 67 65 21 20 73 65 6c 66 20 70 61 67 65 5f 6e age! self page_n
3f30: 61 6d 65 29 0a 20 20 28 73 64 61 74 2d 73 65 74 ame). (sdat-set
3f40: 2d 70 61 67 65 21 20 73 65 6c 66 20 70 61 67 65 -page! self page
3f50: 5f 6e 61 6d 65 29 29 0a 0a 28 64 65 66 69 6e 65 _name))..(define
3f60: 20 28 73 65 73 73 69 6f 6e 3a 63 6c 6f 73 65 20 (session:close
3f70: 73 65 6c 66 29 0a 20 20 28 64 62 69 3a 63 6c 6f self). (dbi:clo
3f80: 73 65 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e se (sdat-get-con
3f90: 6e 20 73 65 6c 66 29 29 29 0a 3b 3b 20 28 63 6c n self))).;; (cl
3fa0: 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 ose-output-port
3fb0: 28 73 64 61 74 2d 67 65 74 2d 6c 6f 67 70 74 20 (sdat-get-logpt
3fc0: 73 65 6c 66 29 29 0a 0a 28 64 65 66 69 6e 65 20 self))..(define
3fd0: 28 73 65 73 73 69 6f 6e 3a 65 72 72 2d 6d 73 67 (session:err-msg
3fe0: 20 73 65 6c 66 20 6d 73 67 29 0a 20 20 28 68 61 self msg). (ha
3ff0: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 28 73 sh-table-set! (s
4000: 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 dat-get-sessionv
4010: 61 72 73 20 73 65 6c 66 29 20 22 45 52 52 4f 52 ars self) "ERROR
4020: 5f 4d 53 47 22 0a 09 09 20 20 20 28 73 74 72 69 _MSG"... (stri
4030: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 ng-intersperse (
4040: 6d 61 70 20 73 3a 61 6e 79 2d 3e 73 74 72 69 6e map s:any->strin
4050: 67 20 6d 73 67 29 20 22 20 22 29 29 29 0a 0a 28 g msg) " ")))..(
4060: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
4070: 70 72 65 76 2d 65 72 72 20 73 65 6c 66 29 0a 20 prev-err self).
4080: 20 28 6c 65 74 20 28 28 70 72 65 76 2d 65 72 72 (let ((prev-err
4090: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
40a0: 2f 64 65 66 61 75 6c 74 20 28 73 64 61 74 2d 67 /default (sdat-g
40b0: 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 2d 62 et-sessionvars-b
40c0: 65 66 6f 72 65 20 73 65 6c 66 29 20 22 45 52 52 efore self) "ERR
40d0: 4f 52 5f 4d 53 47 22 20 23 66 29 29 0a 09 28 63 OR_MSG" #f))..(c
40e0: 75 72 72 2d 65 72 72 20 28 68 61 73 68 2d 74 61 urr-err (hash-ta
40f0: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
4100: 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f (sdat-get-sessio
4110: 6e 76 61 72 73 20 73 65 6c 66 29 20 22 45 52 52 nvars self) "ERR
4120: 4f 52 5f 4d 53 47 22 20 23 66 29 29 29 0a 20 20 OR_MSG" #f))).
4130: 20 20 28 69 66 20 70 72 65 76 2d 65 72 72 20 70 (if prev-err p
4140: 72 65 76 2d 65 72 72 0a 09 28 69 66 20 63 75 72 rev-err..(if cur
4150: 72 2d 65 72 72 20 63 75 72 72 2d 65 72 72 20 23 r-err curr-err #
4160: 66 29 29 29 29 0a 0a 3b 3b 20 73 65 73 73 69 6f f))))..;; sessio
4170: 6e 20 76 61 72 73 0a 3b 3b 20 31 2e 20 6b 65 79 n vars.;; 1. key
4180: 73 20 61 72 65 20 61 6c 77 61 79 73 20 61 20 73 s are always a s
4190: 74 72 69 6e 67 20 4e 4f 54 20 61 20 73 79 6d 62 tring NOT a symb
41a0: 6f 6c 0a 3b 3b 20 32 2e 20 76 61 6c 75 65 73 20 ol.;; 2. values
41b0: 61 72 65 20 61 6c 77 61 79 73 20 61 20 73 74 72 are always a str
41c0: 69 6e 67 20 63 6f 6e 76 65 72 73 69 6f 6e 20 69 ing conversion i
41d0: 73 20 74 68 65 20 72 65 73 70 6f 6e 73 69 62 69 s the responsibi
41e0: 6c 69 74 79 20 6f 66 20 74 68 65 20 0a 3b 3b 20 lity of the .;;
41f0: 20 20 20 63 6f 6e 73 75 6d 69 6e 67 20 66 75 6e consuming fun
4200: 63 74 69 6f 6e 20 28 61 74 20 6c 65 61 73 74 20 ction (at least
4210: 66 6f 72 20 6e 6f 77 2c 20 49 27 64 20 6c 69 6b for now, I'd lik
4220: 65 20 74 6f 20 63 68 61 6e 67 65 20 74 68 69 73 e to change this
4230: 29 0a 0a 3b 3b 20 73 65 74 20 61 20 73 65 73 73 )..;; set a sess
4240: 69 6f 6e 20 76 61 72 20 66 6f 72 20 74 68 65 20 ion var for the
4250: 63 75 72 72 65 6e 74 20 70 61 67 65 0a 3b 3b 0a current page.;;.
4260: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
4270: 3a 73 65 74 21 20 73 65 6c 66 20 6b 65 79 20 76 :set! self key v
4280: 61 6c 75 65 29 0a 20 20 28 68 61 73 68 2d 74 61 alue). (hash-ta
4290: 62 6c 65 2d 73 65 74 21 20 28 73 64 61 74 2d 67 ble-set! (sdat-g
42a0: 65 74 2d 70 61 67 65 76 61 72 73 20 73 65 6c 66 et-pagevars self
42b0: 29 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 ) (s:any->string
42c0: 20 6b 65 79 29 20 28 73 3a 61 6e 79 2d 3e 73 74 key) (s:any->st
42d0: 72 69 6e 67 20 76 61 6c 75 65 29 29 29 0a 0a 3b ring value)))..;
42e0: 3b 20 64 65 6c 20 61 20 76 61 72 20 66 6f 72 20 ; del a var for
42f0: 74 68 65 20 63 75 72 72 65 6e 74 20 70 61 67 65 the current page
4300: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 73 .;;.(define (ses
4310: 73 69 6f 6e 3a 64 65 6c 21 20 73 65 6c 66 20 6b sion:del! self k
4320: 65 79 29 0a 20 20 28 68 61 73 68 2d 74 61 62 6c ey). (hash-tabl
4330: 65 2d 64 65 6c 65 74 65 21 20 28 73 64 61 74 2d e-delete! (sdat-
4340: 67 65 74 2d 70 61 67 65 76 61 72 73 20 73 65 6c get-pagevars sel
4350: 66 29 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e f) (s:any->strin
4360: 67 20 6b 65 79 29 29 29 0a 0a 3b 3b 20 67 65 74 g key)))..;; get
4370: 20 74 68 65 20 61 70 70 72 6f 70 72 69 61 74 65 the appropriate
4380: 20 68 61 73 68 20 67 69 76 65 6e 20 61 20 70 61 hash given a pa
4390: 67 65 20 22 2a 73 65 73 73 69 6f 6e 76 61 72 73 ge "*sessionvars
43a0: 2a 2c 20 2a 67 6c 6f 62 61 6c 76 61 72 73 2a 20 *, *globalvars*
43b0: 6f 72 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 69 or page.;;.(defi
43c0: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d ne (session:get-
43d0: 70 61 67 65 2d 68 61 73 68 20 73 65 6c 66 20 70 page-hash self p
43e0: 61 67 65 29 0a 20 20 28 69 66 20 28 73 74 72 69 age). (if (stri
43f0: 6e 67 3d 3f 20 70 61 67 65 20 22 2a 73 65 73 73 ng=? page "*sess
4400: 69 6f 6e 76 61 72 73 2a 22 29 0a 20 20 20 20 20 ionvars*").
4410: 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 (sdat-get-sessi
4420: 6f 6e 76 61 72 73 20 73 65 6c 66 29 0a 20 20 20 onvars self).
4430: 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 3d 3f (if (string=?
4440: 20 70 61 67 65 20 22 2a 67 6c 6f 62 61 6c 76 61 page "*globalva
4450: 72 73 2a 22 29 0a 09 20 20 28 73 64 61 74 2d 67 rs*").. (sdat-g
4460: 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 20 73 65 et-globalvars se
4470: 6c 66 29 0a 09 20 20 28 73 64 61 74 2d 67 65 74 lf).. (sdat-get
4480: 2d 70 61 67 65 76 61 72 73 20 73 65 6c 66 29 29 -pagevars self))
4490: 29 29 0a 0a 3b 3b 20 73 65 74 20 61 20 73 65 73 ))..;; set a ses
44a0: 73 69 6f 6e 20 76 61 72 20 66 6f 72 20 61 20 67 sion var for a g
44b0: 69 76 65 6e 20 70 61 67 65 0a 3b 3b 0a 28 64 65 iven page.;;.(de
44c0: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 65 fine (session:se
44d0: 74 21 20 73 65 6c 66 20 70 61 67 65 20 6b 65 79 t! self page key
44e0: 20 76 61 6c 75 65 29 0a 20 20 28 6c 65 74 20 28 value). (let (
44f0: 28 68 74 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 (ht (session:get
4500: 2d 70 61 67 65 2d 68 61 73 68 20 73 65 6c 66 20 -page-hash self
4510: 70 61 67 65 29 29 29 0a 20 20 20 20 28 68 61 73 page))). (has
4520: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 68 74 20 h-table-set! ht
4530: 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6b (s:any->string k
4540: 65 79 29 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 ey) (s:any->stri
4550: 6e 67 20 76 61 6c 75 65 29 29 29 29 0a 0a 3b 3b ng value))))..;;
4560: 20 67 65 74 20 73 65 73 73 69 6f 6e 20 76 61 72 get session var
4570: 73 20 66 6f 72 20 74 68 65 20 63 75 72 72 65 6e s for the curren
4580: 74 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 69 6e t page.;;.(defin
4590: 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 20 73 e (session:get s
45a0: 65 6c 66 20 6b 65 79 29 0a 20 20 28 68 61 73 68 elf key). (hash
45b0: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
45c0: 6c 74 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 lt (sdat-get-pag
45d0: 65 76 61 72 73 20 73 65 6c 66 29 20 6b 65 79 20 evars self) key
45e0: 23 66 29 29 0a 0a 3b 3b 20 67 65 74 20 73 65 73 #f))..;; get ses
45f0: 73 69 6f 6e 20 76 61 72 73 20 66 6f 72 20 61 20 sion vars for a
4600: 73 70 65 63 69 66 69 65 64 20 70 61 67 65 0a 3b specified page.;
4610: 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ;.(define (sessi
4620: 6f 6e 3a 67 65 74 20 73 65 6c 66 20 70 61 67 65 on:get self page
4630: 20 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 28 68 key). (let ((h
4640: 74 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 t (session:get-p
4650: 61 67 65 2d 68 61 73 68 20 73 65 6c 66 20 70 61 age-hash self pa
4660: 67 65 29 29 29 0a 20 20 20 20 28 68 61 73 68 2d ge))). (hash-
4670: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
4680: 74 20 68 74 20 6b 65 79 20 23 66 29 29 29 0a 0a t ht key #f)))..
4690: 3b 3b 20 64 65 6c 65 74 65 20 61 20 73 65 73 73 ;; delete a sess
46a0: 69 6f 6e 20 76 61 72 20 66 6f 72 20 61 20 73 70 ion var for a sp
46b0: 65 63 69 66 69 65 64 20 70 61 67 65 0a 3b 3b 0a ecified page.;;.
46c0: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
46d0: 3a 64 65 6c 21 20 73 65 6c 66 20 70 61 67 65 20 :del! self page
46e0: 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 28 68 74 key). (let ((ht
46f0: 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 (session:get-pa
4700: 67 65 2d 68 61 73 68 20 73 65 6c 66 20 70 61 67 ge-hash self pag
4710: 65 29 29 29 0a 20 20 20 20 28 68 61 73 68 2d 74 e))). (hash-t
4720: 61 62 6c 65 2d 64 65 6c 65 74 65 21 20 68 74 20 able-delete! ht
4730: 6b 65 79 29 29 29 0a 0a 3b 3b 20 67 65 74 20 41 key)))..;; get A
4740: 4c 4c 20 6b 65 79 73 20 66 6f 72 20 74 68 69 73 LL keys for this
4750: 20 70 61 67 65 20 61 6e 64 20 73 74 6f 72 65 20 page and store
4760: 69 6e 20 74 68 65 20 73 65 73 73 69 6f 6e 20 70 in the session p
4770: 61 67 65 76 61 72 73 20 68 61 73 68 0a 3b 3b 0a agevars hash.;;.
4780: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
4790: 3a 67 65 74 2d 76 61 72 73 20 73 65 6c 66 29 0a :get-vars self).
47a0: 20 20 28 6c 65 74 20 28 28 73 65 73 73 69 6f 6e (let ((session
47b0: 2d 69 64 20 20 28 73 64 61 74 2d 67 65 74 2d 73 -id (sdat-get-s
47c0: 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 29 29 ession-id self))
47d0: 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 73 ). (if (not s
47e0: 65 73 73 69 6f 6e 2d 69 64 29 0a 09 28 65 72 72 ession-id)..(err
47f0: 3a 6c 6f 67 20 22 45 52 52 4f 52 3a 20 4e 6f 20 :log "ERROR: No
4800: 73 65 73 73 69 6f 6e 20 69 64 20 69 6e 20 73 65 session id in se
4810: 73 73 69 6f 6e 20 6f 62 6a 65 63 74 21 20 73 65 ssion object! se
4820: 73 73 69 6f 6e 3a 67 65 74 2d 76 61 72 73 22 29 ssion:get-vars")
4830: 0a 09 28 6c 65 74 2a 20 28 28 72 65 73 75 6c 74 ..(let* ((result
4840: 20 20 20 20 20 20 20 20 20 20 20 20 20 23 66 29 #f)
4850: 0a 09 20 20 20 20 20 20 20 28 63 6f 6e 6e 20 20 .. (conn
4860: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 64 (sd
4870: 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 at-get-conn self
4880: 29 29 0a 09 20 20 20 20 20 20 20 28 70 61 67 65 )).. (page
4890: 76 61 72 73 2d 62 65 66 6f 72 65 20 20 20 20 28 vars-before (
48a0: 73 64 61 74 2d 67 65 74 2d 70 61 67 65 76 61 72 sdat-get-pagevar
48b0: 73 2d 62 65 66 6f 72 65 20 73 65 6c 66 29 29 0a s-before self)).
48c0: 09 20 20 20 20 20 20 20 28 73 65 73 73 69 6f 6e . (session
48d0: 76 61 72 73 2d 62 65 66 6f 72 65 20 28 73 64 61 vars-before (sda
48e0: 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 t-get-sessionvar
48f0: 73 2d 62 65 66 6f 72 65 20 73 65 6c 66 29 29 0a s-before self)).
4900: 09 20 20 20 20 20 20 20 28 67 6c 6f 62 61 6c 76 . (globalv
4910: 61 72 73 2d 62 65 66 6f 72 65 20 20 28 73 64 61 ars-before (sda
4920: 74 2d 67 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 t-get-globalvars
4930: 2d 62 65 66 6f 72 65 20 73 65 6c 66 29 29 0a 09 -before self))..
4940: 20 20 20 20 20 20 20 28 70 61 67 65 76 61 72 73 (pagevars
4950: 20 20 20 20 20 20 20 20 20 20 20 28 73 64 61 74 (sdat
4960: 2d 67 65 74 2d 70 61 67 65 76 61 72 73 20 73 65 -get-pagevars se
4970: 6c 66 29 29 0a 09 20 20 20 20 20 20 20 28 73 65 lf)).. (se
4980: 73 73 69 6f 6e 76 61 72 73 20 20 20 20 20 20 20 ssionvars
4990: 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 (sdat-get-sessi
49a0: 6f 6e 76 61 72 73 20 73 65 6c 66 29 29 0a 09 20 onvars self))..
49b0: 20 20 20 20 20 20 28 67 6c 6f 62 61 6c 76 61 72 (globalvar
49c0: 73 20 20 20 20 20 20 20 20 20 28 73 64 61 74 2d s (sdat-
49d0: 67 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 20 73 get-globalvars s
49e0: 65 6c 66 29 29 0a 09 20 20 20 20 20 20 20 28 70 elf)).. (p
49f0: 61 67 65 2d 6e 61 6d 65 20 20 20 20 20 20 20 20 age-name
4a00: 20 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 (sdat-get-page
4a10: 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 20 20 self))..
4a20: 28 73 65 73 73 69 6f 6e 2d 6b 65 79 20 20 20 20 (session-key
4a30: 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d 73 65 (sdat-get-se
4a40: 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 29 ssion-key self))
4a50: 0a 09 20 20 20 20 20 20 20 28 71 75 65 72 79 20 .. (query
4a60: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 74 (st
4a70: 72 69 6e 67 2d 61 70 70 65 6e 64 0a 09 09 09 09 ring-append.....
4a80: 20 20 20 20 22 53 45 4c 45 43 54 20 6b 65 79 2c "SELECT key,
4a90: 76 61 6c 75 65 20 46 52 4f 4d 20 73 65 73 73 69 value FROM sessi
4aa0: 6f 6e 5f 76 61 72 73 20 49 4e 4e 45 52 20 4a 4f on_vars INNER JO
4ab0: 49 4e 20 73 65 73 73 69 6f 6e 73 20 4f 4e 20 73 IN sessions ON s
4ac0: 65 73 73 69 6f 6e 5f 76 61 72 73 2e 73 65 73 73 ession_vars.sess
4ad0: 69 6f 6e 5f 69 64 3d 73 65 73 73 69 6f 6e 73 2e ion_id=sessions.
4ae0: 69 64 20 22 0a 09 09 09 09 20 20 20 20 22 57 48 id "..... "WH
4af0: 45 52 45 20 73 65 73 73 69 6f 6e 5f 6b 65 79 3d ERE session_key=
4b00: 3f 20 41 4e 44 20 70 61 67 65 3d 3f 3b 22 29 29 ? AND page=?;"))
4b10: 29 0a 09 20 20 3b 3b 20 66 69 72 73 74 20 74 68 ).. ;; first th
4b20: 65 20 70 61 67 65 20 73 70 65 63 69 66 69 63 20 e page specific
4b30: 76 61 72 73 0a 09 20 20 28 64 62 69 3a 66 6f 72 vars.. (dbi:for
4b40: 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 6d 62 64 -each-row (lambd
4b50: 61 20 28 74 75 70 6c 65 29 0a 09 09 09 20 20 20 a (tuple)....
4b60: 20 20 20 28 6c 65 74 20 28 28 6b 20 28 76 65 63 (let ((k (vec
4b70: 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 30 29 tor-ref tuple 0)
4b80: 29 0a 09 09 09 09 20 20 20 20 28 76 20 28 76 65 )..... (v (ve
4b90: 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 31 ctor-ref tuple 1
4ba0: 29 29 29 0a 09 09 09 09 28 68 61 73 68 2d 74 61 ))).....(hash-ta
4bb0: 62 6c 65 2d 73 65 74 21 20 70 61 67 65 76 61 72 ble-set! pagevar
4bc0: 73 2d 62 65 66 6f 72 65 20 6b 20 76 29 0a 09 09 s-before k v)...
4bd0: 09 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 ..(hash-table-se
4be0: 74 21 20 70 61 67 65 76 61 72 73 20 20 20 20 20 t! pagevars
4bf0: 20 20 20 6b 20 76 29 29 29 0a 09 09 09 20 20 20 k v)))....
4c00: 20 63 6f 6e 6e 0a 09 09 09 20 20 20 20 28 73 3a conn.... (s:
4c10: 73 71 6c 70 61 72 61 6d 20 71 75 65 72 79 20 73 sqlparam query s
4c20: 65 73 73 69 6f 6e 2d 6b 65 79 20 70 61 67 65 2d ession-key page-
4c30: 6e 61 6d 65 29 29 0a 09 20 20 3b 3b 20 74 68 65 name)).. ;; the
4c40: 6e 20 74 68 65 20 73 65 73 73 69 6f 6e 20 73 70 n the session sp
4c50: 65 63 69 66 69 63 20 76 61 72 73 0a 09 20 20 28 ecific vars.. (
4c60: 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 dbi:for-each-row
4c70: 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 29 (lambda (tuple)
4c80: 0a 09 09 09 20 20 20 20 20 20 28 6c 65 74 20 28 .... (let (
4c90: 28 6b 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 (k (vector-ref t
4ca0: 75 70 6c 65 20 30 29 29 0a 09 09 09 09 20 20 20 uple 0)).....
4cb0: 20 28 76 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (v (vector-ref
4cc0: 74 75 70 6c 65 20 31 29 29 29 0a 09 09 09 09 28 tuple 1))).....(
4cd0: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
4ce0: 73 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 6f sessionvars-befo
4cf0: 72 65 20 6b 20 76 29 0a 09 09 09 09 28 68 61 73 re k v).....(has
4d00: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 73 65 73 h-table-set! ses
4d10: 73 69 6f 6e 76 61 72 73 20 20 20 20 20 20 20 20 sionvars
4d20: 6b 20 76 29 29 29 0a 09 09 09 20 20 20 20 63 6f k v))).... co
4d30: 6e 6e 0a 09 09 09 20 20 20 20 28 73 3a 73 71 6c nn.... (s:sql
4d40: 70 61 72 61 6d 20 71 75 65 72 79 20 73 65 73 73 param query sess
4d50: 69 6f 6e 2d 6b 65 79 20 22 2a 73 65 73 73 69 6f ion-key "*sessio
4d60: 6e 76 61 72 73 2a 22 29 29 0a 09 20 20 3b 3b 20 nvars*")).. ;;
4d70: 61 6e 64 20 66 69 6e 61 6c 6c 79 20 74 68 65 20 and finally the
4d80: 67 6c 6f 62 61 6c 20 76 61 72 73 0a 09 20 20 28 global vars.. (
4d90: 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 dbi:for-each-row
4da0: 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 29 (lambda (tuple)
4db0: 0a 09 09 09 20 20 20 20 20 20 28 6c 65 74 20 28 .... (let (
4dc0: 28 6b 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 (k (vector-ref t
4dd0: 75 70 6c 65 20 30 29 29 0a 09 09 09 09 20 20 20 uple 0)).....
4de0: 20 28 76 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (v (vector-ref
4df0: 74 75 70 6c 65 20 31 29 29 29 0a 09 09 09 09 28 tuple 1))).....(
4e00: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
4e10: 67 6c 6f 62 61 6c 76 61 72 73 2d 62 65 66 6f 72 globalvars-befor
4e20: 65 20 6b 20 76 29 0a 09 09 09 09 28 68 61 73 68 e k v).....(hash
4e30: 2d 74 61 62 6c 65 2d 73 65 74 21 20 67 6c 6f 62 -table-set! glob
4e40: 61 6c 76 61 72 73 20 20 20 20 20 20 20 20 6b 20 alvars k
4e50: 76 29 29 29 0a 09 09 09 20 20 20 20 63 6f 6e 6e v))).... conn
4e60: 0a 09 09 09 20 20 20 20 28 73 3a 73 71 6c 70 61 .... (s:sqlpa
4e70: 72 61 6d 20 71 75 65 72 79 20 73 65 73 73 69 6f ram query sessio
4e80: 6e 2d 6b 65 79 20 22 2a 67 6c 6f 62 61 6c 76 61 n-key "*globalva
4e90: 72 73 22 29 29 0a 09 20 20 29 29 29 29 0a 0a 28 rs")).. ))))..(
4ea0: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
4eb0: 73 61 76 65 2d 76 61 72 73 20 73 65 6c 66 29 0a save-vars self).
4ec0: 20 20 28 6c 65 74 20 28 28 73 65 73 73 69 6f 6e (let ((session
4ed0: 2d 69 64 20 20 28 73 64 61 74 2d 67 65 74 2d 73 -id (sdat-get-s
4ee0: 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 29 29 ession-id self))
4ef0: 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 73 ). (if (not s
4f00: 65 73 73 69 6f 6e 2d 69 64 29 0a 09 28 65 72 72 ession-id)..(err
4f10: 3a 6c 6f 67 20 22 45 52 52 4f 52 3a 20 4e 6f 20 :log "ERROR: No
4f20: 73 65 73 73 69 6f 6e 20 69 64 20 69 6e 20 73 65 session id in se
4f30: 73 73 69 6f 6e 20 6f 62 6a 65 63 74 21 20 73 65 ssion object! se
4f40: 73 73 69 6f 6e 3a 67 65 74 2d 76 61 72 73 22 29 ssion:get-vars")
4f50: 0a 09 28 6c 65 74 2a 20 28 28 73 74 61 74 75 73 ..(let* ((status
4f60: 20 20 20 20 20 20 23 66 29 0a 09 20 20 20 20 20 #f)..
4f70: 20 20 28 63 6f 6e 6e 20 20 20 20 20 20 20 20 28 (conn (
4f80: 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 sdat-get-conn se
4f90: 6c 66 29 29 0a 09 20 20 20 20 20 20 20 28 70 61 lf)).. (pa
4fa0: 67 65 2d 6e 61 6d 65 20 20 20 28 73 64 61 74 2d ge-name (sdat-
4fb0: 67 65 74 2d 70 61 67 65 20 73 65 6c 66 29 29 0a get-page self)).
4fc0: 09 20 20 20 20 20 20 20 28 64 65 6c 2d 71 75 65 . (del-que
4fd0: 72 79 20 20 20 22 44 45 4c 45 54 45 20 46 52 4f ry "DELETE FRO
4fe0: 4d 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 57 M session_vars W
4ff0: 48 45 52 45 20 73 65 73 73 69 6f 6e 5f 69 64 3d HERE session_id=
5000: 3f 20 41 4e 44 20 70 61 67 65 3d 3f 20 41 4e 44 ? AND page=? AND
5010: 20 6b 65 79 3d 3f 3b 22 29 0a 09 20 20 20 20 20 key=?;")..
5020: 20 20 28 69 6e 73 2d 71 75 65 72 79 20 20 20 22 (ins-query "
5030: 49 4e 53 45 52 54 20 49 4e 54 4f 20 73 65 73 73 INSERT INTO sess
5040: 69 6f 6e 5f 76 61 72 73 20 28 73 65 73 73 69 6f ion_vars (sessio
5050: 6e 5f 69 64 2c 70 61 67 65 2c 6b 65 79 2c 76 61 n_id,page,key,va
5060: 6c 75 65 29 20 56 41 4c 55 45 53 28 3f 2c 3f 2c lue) VALUES(?,?,
5070: 3f 2c 3f 29 3b 22 29 0a 09 20 20 20 20 20 20 20 ?,?);")..
5080: 28 75 70 64 2d 71 75 65 72 79 20 20 20 22 55 50 (upd-query "UP
5090: 44 41 54 45 20 73 65 73 73 69 6f 6e 5f 76 61 72 DATE session_var
50a0: 73 20 73 65 74 20 76 61 6c 75 65 3d 3f 20 57 48 s set value=? WH
50b0: 45 52 45 20 6b 65 79 3d 3f 20 41 4e 44 20 73 65 ERE key=? AND se
50c0: 73 73 69 6f 6e 5f 69 64 3d 3f 20 41 4e 44 20 70 ssion_id=? AND p
50d0: 61 67 65 3d 3f 3b 22 29 0a 09 20 20 20 20 20 20 age=?;")..
50e0: 20 28 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 (changed-count
50f0: 30 29 29 0a 09 20 20 3b 3b 20 73 61 76 65 20 74 0)).. ;; save t
5100: 68 65 20 64 65 6c 74 61 20 6f 6e 6c 79 0a 09 20 he delta only..
5110: 20 28 66 6f 72 2d 65 61 63 68 0a 09 20 20 20 28 (for-each.. (
5120: 6c 61 6d 62 64 61 20 28 70 61 67 65 29 20 3b 3b lambda (page) ;;
5130: 20 70 61 67 65 20 69 73 3a 20 22 2a 67 6c 6f 62 page is: "*glob
5140: 61 6c 76 61 72 73 2a 22 20 22 2a 73 65 73 73 69 alvars*" "*sessi
5150: 6f 6e 76 61 72 73 2a 22 20 6f 72 20 6f 74 68 65 onvars*" or othe
5160: 72 73 74 72 69 6e 67 0a 09 20 20 20 20 20 28 6c rstring.. (l
5170: 65 74 2a 20 28 28 62 65 66 6f 72 65 2d 61 66 74 et* ((before-aft
5180: 65 72 2d 68 74 20 28 63 6f 6e 64 0a 09 09 09 09 er-ht (cond.....
5190: 20 20 20 20 20 20 28 28 73 74 72 69 6e 67 3d 3f ((string=?
51a0: 20 70 61 67 65 20 22 2a 73 65 73 73 69 6f 6e 76 page "*sessionv
51b0: 61 72 73 2a 22 29 0a 09 09 09 09 20 20 20 20 20 ars*").....
51c0: 20 20 28 76 65 63 74 6f 72 20 28 73 64 61 74 2d (vector (sdat-
51d0: 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 20 get-sessionvars
51e0: 73 65 6c 66 29 0a 09 09 09 09 09 20 20 20 20 20 self)......
51f0: 20 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 (sdat-get-sess
5200: 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 20 73 ionvars-before s
5210: 65 6c 66 29 29 29 0a 09 09 09 09 20 20 20 20 20 elf))).....
5220: 20 20 28 28 73 74 72 69 6e 67 3d 3f 20 70 61 67 ((string=? pag
5230: 65 20 22 2a 67 6c 6f 62 61 6c 76 61 72 73 2a 22 e "*globalvars*"
5240: 29 0a 09 09 09 09 09 28 76 65 63 74 6f 72 20 28 )......(vector (
5250: 73 64 61 74 2d 67 65 74 2d 67 6c 6f 62 61 6c 76 sdat-get-globalv
5260: 61 72 73 20 73 65 6c 66 29 0a 09 09 09 09 09 09 ars self).......
5270: 28 73 64 61 74 2d 67 65 74 2d 67 6c 6f 62 61 6c (sdat-get-global
5280: 76 61 72 73 2d 62 65 66 6f 72 65 20 73 65 6c 66 vars-before self
5290: 29 29 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 )))..... (
52a0: 65 6c 73 65 20 0a 09 09 09 09 09 28 76 65 63 74 else ......(vect
52b0: 6f 72 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 or (sdat-get-pag
52c0: 65 76 61 72 73 20 73 65 6c 66 29 0a 09 09 09 09 evars self).....
52d0: 09 09 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 ..(sdat-get-page
52e0: 76 61 72 73 2d 62 65 66 6f 72 65 20 73 65 6c 66 vars-before self
52f0: 29 29 29 29 29 0a 09 09 20 20 20 20 28 6d 61 73 )))))... (mas
5300: 74 65 72 2d 68 74 20 20 20 28 76 65 63 74 6f 72 ter-ht (vector
5310: 2d 72 65 66 20 62 65 66 6f 72 65 2d 61 66 74 65 -ref before-afte
5320: 72 2d 68 74 20 30 29 29 0a 09 09 20 20 20 20 28 r-ht 0))... (
5330: 62 65 66 6f 72 65 2d 68 74 20 20 20 28 76 65 63 before-ht (vec
5340: 74 6f 72 2d 72 65 66 20 62 65 66 6f 72 65 2d 61 tor-ref before-a
5350: 66 74 65 72 2d 68 74 20 31 29 29 0a 09 09 20 20 fter-ht 1))...
5360: 20 20 28 6d 61 73 74 65 72 2d 6b 65 79 73 20 28 (master-keys (
5370: 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 hash-table-keys
5380: 6d 61 73 74 65 72 2d 68 74 29 29 0a 09 09 20 20 master-ht))...
5390: 20 20 28 62 65 66 6f 72 65 2d 6b 65 79 73 20 28 (before-keys (
53a0: 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 hash-table-keys
53b0: 62 65 66 6f 72 65 2d 68 74 29 29 0a 09 09 20 20 before-ht))...
53c0: 20 20 28 61 6c 6c 2d 6b 65 79 73 20 28 64 65 6c (all-keys (del
53d0: 65 74 65 2d 64 75 70 6c 69 63 61 74 65 73 20 28 ete-duplicates (
53e0: 61 70 70 65 6e 64 20 6d 61 73 74 65 72 2d 6b 65 append master-ke
53f0: 79 73 20 62 65 66 6f 72 65 2d 6b 65 79 73 29 29 ys before-keys))
5400: 29 29 0a 09 20 20 20 20 20 20 20 28 66 6f 72 2d )).. (for-
5410: 65 61 63 68 20 0a 09 09 28 6c 61 6d 62 64 61 20 each ...(lambda
5420: 28 6b 65 79 29 0a 09 09 20 20 28 6c 65 74 20 28 (key)... (let (
5430: 28 6d 61 73 74 65 72 2d 76 61 6c 75 65 20 28 68 (master-value (h
5440: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
5450: 66 61 75 6c 74 20 6d 61 73 74 65 72 2d 68 74 20 fault master-ht
5460: 6b 65 79 20 23 66 29 29 0a 09 09 09 28 62 65 66 key #f))....(bef
5470: 6f 72 65 2d 76 61 6c 75 65 20 28 68 61 73 68 2d ore-value (hash-
5480: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
5490: 74 20 62 65 66 6f 72 65 2d 68 74 20 6b 65 79 20 t before-ht key
54a0: 23 66 29 29 29 0a 09 09 20 20 20 20 28 63 6f 6e #f)))... (con
54b0: 64 0a 09 09 20 20 20 20 20 3b 3b 20 62 65 66 6f d... ;; befo
54c0: 72 65 20 61 6e 64 20 61 66 74 65 72 20 65 78 69 re and after exi
54d0: 73 74 20 61 6e 64 20 76 61 6c 75 65 20 75 6e 63 st and value unc
54e0: 68 61 6e 67 65 64 20 2d 20 64 6f 20 6e 6f 74 68 hanged - do noth
54f0: 69 6e 67 0a 09 09 20 20 20 20 20 28 28 61 6e 64 ing... ((and
5500: 20 6d 61 73 74 65 72 2d 76 61 6c 75 65 20 62 65 master-value be
5510: 66 6f 72 65 2d 76 61 6c 75 65 20 28 65 71 75 61 fore-value (equa
5520: 6c 3f 20 6d 61 73 74 65 72 2d 76 61 6c 75 65 20 l? master-value
5530: 62 65 66 6f 72 65 2d 76 61 6c 75 65 29 29 29 0a before-value))).
5540: 09 09 20 20 20 20 20 3b 3b 20 62 65 66 6f 72 65 .. ;; before
5550: 20 61 6e 64 20 61 66 74 65 72 20 65 78 69 73 74 and after exist
5560: 20 62 75 74 20 61 72 65 20 63 68 61 6e 67 65 64 but are changed
5570: 0a 09 09 20 20 20 20 20 28 28 61 6e 64 20 6d 61 ... ((and ma
5580: 73 74 65 72 2d 76 61 6c 75 65 20 62 65 66 6f 72 ster-value befor
5590: 65 2d 76 61 6c 75 65 29 0a 09 09 20 20 20 20 20 e-value)...
55a0: 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 (dbi:for-each-r
55b0: 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c ow (lambda (tupl
55c0: 65 29 0a 09 09 09 09 09 20 20 28 73 65 74 21 20 e)...... (set!
55d0: 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 28 2b changed-count (+
55e0: 20 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 31 changed-count 1
55f0: 29 29 29 0a 09 09 09 09 09 63 6f 6e 6e 0a 09 09 )))......conn...
5600: 09 09 09 28 73 3a 73 71 6c 70 61 72 61 6d 20 75 ...(s:sqlparam u
5610: 70 64 2d 71 75 65 72 79 20 6d 61 73 74 65 72 2d pd-query master-
5620: 76 61 6c 75 65 20 6b 65 79 20 73 65 73 73 69 6f value key sessio
5630: 6e 2d 69 64 20 70 61 67 65 29 29 29 0a 09 09 20 n-id page)))...
5640: 20 20 20 20 3b 3b 20 6d 61 73 74 65 72 2d 76 61 ;; master-va
5650: 6c 75 65 20 6e 6f 20 6c 6f 6e 67 65 72 20 65 78 lue no longer ex
5660: 69 73 74 73 20 28 69 2e 65 2e 20 23 66 29 20 2d ists (i.e. #f) -
5670: 20 72 65 6d 6f 76 65 20 69 74 65 6d 0a 09 09 20 remove item...
5680: 20 20 20 20 28 28 6e 6f 74 20 6d 61 73 74 65 72 ((not master
5690: 2d 76 61 6c 75 65 29 0a 09 09 20 20 20 20 20 20 -value)...
56a0: 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f (dbi:for-each-ro
56b0: 77 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 w (lambda (tuple
56c0: 29 0a 09 09 09 09 09 20 20 28 73 65 74 21 20 63 )...... (set! c
56d0: 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 28 2b 20 hanged-count (+
56e0: 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 31 29 changed-count 1)
56f0: 29 29 0a 09 09 09 09 09 63 6f 6e 6e 0a 09 09 09 ))......conn....
5700: 09 09 28 73 3a 73 71 6c 70 61 72 61 6d 20 64 65 ..(s:sqlparam de
5710: 6c 2d 71 75 65 72 79 20 73 65 73 73 69 6f 6e 2d l-query session-
5720: 69 64 20 70 61 67 65 20 6b 65 79 29 29 29 0a 09 id page key)))..
5730: 09 20 20 20 20 20 3b 3b 20 62 65 66 6f 72 65 2d . ;; before-
5740: 76 61 6c 75 65 20 64 6f 65 73 6e 27 74 20 65 78 value doesn't ex
5750: 69 73 74 20 2d 20 69 6e 73 65 72 74 20 61 20 6e ist - insert a n
5760: 65 77 20 76 61 6c 75 65 0a 09 09 20 20 20 20 20 ew value...
5770: 28 28 6e 6f 74 20 62 65 66 6f 72 65 2d 76 61 6c ((not before-val
5780: 75 65 29 0a 09 09 20 20 20 20 20 20 28 64 62 69 ue)... (dbi
5790: 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 28 6c :for-each-row (l
57a0: 61 6d 62 64 61 20 28 74 75 70 6c 65 29 0a 09 09 ambda (tuple)...
57b0: 09 09 09 20 20 28 73 65 74 21 20 63 68 61 6e 67 ... (set! chang
57c0: 65 64 2d 63 6f 75 6e 74 20 28 2b 20 63 68 61 6e ed-count (+ chan
57d0: 67 65 64 2d 63 6f 75 6e 74 20 31 29 29 29 0a 09 ged-count 1)))..
57e0: 09 09 09 09 63 6f 6e 6e 0a 09 09 09 09 09 28 73 ....conn......(s
57f0: 3a 73 71 6c 70 61 72 61 6d 20 69 6e 73 2d 71 75 :sqlparam ins-qu
5800: 65 72 79 20 73 65 73 73 69 6f 6e 2d 69 64 20 70 ery session-id p
5810: 61 67 65 20 6b 65 79 20 6d 61 73 74 65 72 2d 76 age key master-v
5820: 61 6c 75 65 29 29 29 0a 09 09 20 20 20 20 20 28 alue)))... (
5830: 65 6c 73 65 20 28 65 72 72 3a 6c 6f 67 20 22 53 else (err:log "S
5840: 68 6f 75 6c 64 6e 27 74 20 67 65 74 20 68 65 72 houldn't get her
5850: 65 22 29 29 29 29 29 0a 09 09 61 6c 6c 2d 6b 65 e")))))...all-ke
5860: 79 73 29 29 29 20 3b 3b 20 70 72 6f 63 65 73 73 ys))) ;; process
5870: 20 61 6c 6c 20 6b 65 79 73 0a 09 20 20 20 28 6c all keys.. (l
5880: 69 73 74 20 22 2a 73 65 73 73 69 6f 6e 76 61 72 ist "*sessionvar
5890: 73 2a 22 20 22 2a 67 6c 6f 62 61 6c 76 61 72 73 s*" "*globalvars
58a0: 2a 22 20 70 61 67 65 2d 6e 61 6d 65 29 29 29 29 *" page-name))))
58b0: 29 29 0a 0a 3b 3b 20 28 70 67 3a 73 71 6c 2d 6e ))..;; (pg:sql-n
58c0: 75 6c 6c 2d 6f 62 6a 65 63 74 3f 20 65 6c 65 6d ull-object? elem
58d0: 65 6e 74 29 0a 28 64 65 66 69 6e 65 20 28 73 65 ent).(define (se
58e0: 73 73 69 6f 6e 3a 72 65 61 64 2d 63 6f 6e 66 69 ssion:read-confi
58f0: 67 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 20 28 g self). (let (
5900: 28 6e 61 6d 65 20 28 73 74 72 69 6e 67 2d 61 70 (name (string-ap
5910: 70 65 6e 64 20 22 2e 22 20 28 70 61 74 68 6e 61 pend "." (pathna
5920: 6d 65 2d 66 69 6c 65 20 28 63 61 72 20 28 61 72 me-file (car (ar
5930: 67 76 29 29 29 20 22 2e 63 6f 6e 66 69 67 22 29 gv))) ".config")
5940: 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 )). (if (not
5950: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 6e 61 (file-exists? na
5960: 6d 65 29 29 0a 09 28 70 72 69 6e 74 20 6e 61 6d me))..(print nam
5970: 65 20 22 20 6e 6f 74 20 66 6f 75 6e 64 20 61 74 e " not found at
5980: 20 22 20 28 63 75 72 72 65 6e 74 2d 64 69 72 65 " (current-dire
5990: 63 74 6f 72 79 29 29 0a 09 28 6c 65 74 2a 20 28 ctory))..(let* (
59a0: 28 66 70 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d (fp (open-input-
59b0: 66 69 6c 65 20 6e 61 6d 65 29 29 0a 09 20 20 20 file name))..
59c0: 20 20 20 20 28 69 6e 69 74 61 72 67 73 20 28 72 (initargs (r
59d0: 65 61 64 20 66 70 29 29 29 0a 09 20 20 28 63 6c ead fp))).. (cl
59e0: 6f 73 65 2d 69 6e 70 75 74 2d 70 6f 72 74 20 66 ose-input-port f
59f0: 70 29 0a 09 20 20 69 6e 69 74 61 72 67 73 29 29 p).. initargs))
5a00: 29 29 0a 0a 3b 3b 20 63 61 6c 6c 20 74 68 65 20 ))..;; call the
5a10: 63 6f 6e 74 72 6f 6c 6c 65 72 20 69 66 20 69 74 controller if it
5a20: 20 65 78 69 73 74 73 0a 3b 3b 20 0a 3b 3b 20 57 exists.;; .;; W
5a30: 41 52 4e 49 4e 47 20 2d 20 74 68 69 73 20 63 6f ARNING - this co
5a40: 64 65 20 6e 65 65 64 73 20 61 20 64 65 66 65 6e de needs a defen
5a50: 63 65 20 61 67 61 69 6e 73 20 72 65 63 75 72 73 ce agains recurs
5a60: 69 76 65 20 63 61 6c 6c 69 6e 67 21 21 21 21 21 ive calling!!!!!
5a70: 0a 3b 3b 0a 3b 3b 20 20 20 49 20 73 75 67 67 65 .;;.;; I sugge
5a80: 73 74 20 61 20 6c 69 6d 69 74 20 6f 66 20 31 30 st a limit of 10
5a90: 30 20 63 61 6c 6c 73 2e 20 50 6c 65 6e 74 79 20 0 calls. Plenty
5aa0: 66 6f 72 20 61 6c 6c 6f 77 69 6e 67 20 6d 75 6c for allowing mul
5ab0: 74 69 70 6c 65 20 69 6e 73 74 61 6e 63 65 73 0a tiple instances.
5ac0: 3b 3b 20 20 20 6f 66 20 61 20 70 61 67 65 20 69 ;; of a page i
5ad0: 6e 73 69 64 65 20 61 6e 6f 74 68 65 72 20 70 61 nside another pa
5ae0: 67 65 2e 20 0a 3b 3b 0a 3b 3b 20 70 61 72 74 73 ge. .;;.;; parts
5af0: 20 3d 20 27 62 6f 74 68 20 7c 20 27 63 6f 6e 74 = 'both | 'cont
5b00: 72 6f 6c 20 7c 20 27 76 69 65 77 0a 3b 3b 0a 0a rol | 'view.;;..
5b10: 28 64 65 66 69 6e 65 20 28 66 69 6c 65 73 2d 72 (define (files-r
5b20: 65 61 64 2d 3e 73 74 72 69 6e 67 20 2e 20 66 69 ead->string . fi
5b30: 6c 65 73 29 0a 20 20 28 73 74 72 69 6e 67 2d 69 les). (string-i
5b40: 6e 74 65 72 73 70 65 72 73 65 20 0a 20 20 20 28 ntersperse . (
5b50: 61 70 70 6c 79 20 61 70 70 65 6e 64 20 28 6d 61 apply append (ma
5b60: 70 20 66 69 6c 65 2d 72 65 61 64 2d 3e 73 74 72 p file-read->str
5b70: 69 6e 67 20 66 69 6c 65 73 29 29 20 22 5c 6e 22 ing files)) "\n"
5b80: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 66 69 6c ))..(define (fil
5b90: 65 2d 72 65 61 64 2d 3e 73 74 72 69 6e 67 20 66 e-read->string f
5ba0: 29 20 0a 20 20 28 6c 65 74 20 28 28 70 20 28 6f ) . (let ((p (o
5bb0: 70 65 6e 2d 69 6e 70 75 74 2d 66 69 6c 65 20 66 pen-input-file f
5bc0: 29 29 29 0a 20 20 20 20 28 6c 65 74 20 6c 6f 6f ))). (let loo
5bd0: 70 20 28 28 68 65 64 20 28 72 65 61 64 2d 6c 69 p ((hed (read-li
5be0: 6e 65 20 70 29 29 0a 09 20 20 20 20 20 20 20 28 ne p)).. (
5bf0: 72 65 73 20 27 28 29 29 29 0a 20 20 20 20 20 20 res '())).
5c00: 28 69 66 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f (if (eof-object?
5c10: 20 68 65 64 29 0a 09 20 20 72 65 73 0a 09 20 20 hed).. res..
5c20: 28 6c 6f 6f 70 20 28 72 65 61 64 2d 6c 69 6e 65 (loop (read-line
5c30: 20 70 29 28 61 70 70 65 6e 64 20 72 65 73 20 28 p)(append res (
5c40: 6c 69 73 74 20 68 65 64 29 29 29 29 29 29 29 0a list hed))))))).
5c50: 0a 3b 3b 20 4d 61 79 20 32 30 31 31 2c 20 70 75 .;; May 2011, pu
5c60: 74 74 69 6e 67 20 61 6c 6c 20 70 61 67 65 73 20 tting all pages
5c70: 69 6e 74 6f 20 6f 6e 65 20 64 69 72 65 63 74 6f into one directo
5c80: 72 79 20 66 6f 72 20 74 68 65 20 66 6f 6c 6c 6f ry for the follo
5c90: 77 69 6e 67 20 72 65 61 73 6f 6e 73 3a 0a 3b 3b wing reasons:.;;
5ca0: 20 20 20 31 2e 20 77 61 6e 74 20 66 69 6c 65 6e 1. want filen
5cb0: 61 6d 65 20 74 6f 20 72 65 66 6c 65 63 74 20 70 ame to reflect p
5cc0: 61 67 65 20 6e 61 6d 65 20 28 65 6d 61 63 73 20 age name (emacs
5cd0: 6c 69 6d 69 74 61 74 69 6f 6e 29 0a 3b 3b 20 20 limitation).;;
5ce0: 20 32 2e 20 74 68 61 74 27 73 20 69 74 21 20 6e 2. that's it! n
5cf0: 6f 20 6f 74 68 65 72 20 72 65 61 73 6f 6e 2e 20 o other reason.
5d00: 63 6f 75 6c 64 20 6d 61 6b 65 20 69 74 20 63 6f could make it co
5d10: 6e 66 69 67 75 72 61 62 6c 65 20 2e 2e 2e 0a 28 nfigurable ....(
5d20: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
5d30: 63 61 6c 6c 2d 70 61 72 74 73 20 73 65 6c 66 20 call-parts self
5d40: 70 61 67 65 20 70 61 72 74 73 29 0a 20 20 28 73 page parts). (s
5d50: 64 61 74 2d 73 65 74 2d 63 75 72 72 2d 70 61 67 dat-set-curr-pag
5d60: 65 21 20 73 65 6c 66 20 70 61 67 65 29 0a 20 20 e! self page).
5d70: 3b 3b 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 ;; (session:log
5d80: 73 65 6c 66 20 22 70 61 67 65 2d 64 69 72 2d 73 self "page-dir-s
5d90: 74 79 6c 65 3a 20 22 20 28 73 64 61 74 2d 67 65 tyle: " (sdat-ge
5da0: 74 2d 70 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 t-page-dir-style
5db0: 20 73 65 6c 66 29 29 0a 20 20 28 6c 65 74 2a 20 self)). (let*
5dc0: 28 28 64 69 72 2d 73 74 79 6c 65 20 3b 3b 20 28 ((dir-style ;; (
5dd0: 65 71 75 61 6c 3f 20 28 73 64 61 74 2d 67 65 74 equal? (sdat-get
5de0: 2d 70 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 20 -page-dir-style
5df0: 73 65 6c 66 29 20 22 6f 6e 65 64 69 72 22 29 29 self) "onedir"))
5e00: 20 3b 3b 20 66 6c 61 67 20 23 74 20 66 6f 72 20 ;; flag #t for
5e10: 6f 6e 65 64 69 72 2c 20 23 66 20 66 6f 72 20 6f onedir, #f for o
5e20: 6c 64 20 73 74 79 6c 65 0a 09 20 20 28 73 64 61 ld style.. (sda
5e30: 74 2d 67 65 74 2d 70 61 67 65 2d 64 69 72 2d 73 t-get-page-dir-s
5e40: 74 79 6c 65 20 73 65 6c 66 29 29 0a 09 20 28 64 tyle self)).. (d
5e50: 69 72 20 20 20 20 20 28 73 74 72 69 6e 67 2d 61 ir (string-a
5e60: 70 70 65 6e 64 20 28 73 64 61 74 2d 67 65 74 2d ppend (sdat-get-
5e70: 73 72 6f 6f 74 20 73 65 6c 66 29 20 0a 09 09 09 sroot self) ....
5e80: 09 20 28 69 66 20 64 69 72 2d 73 74 79 6c 65 20 . (if dir-style
5e90: 0a 09 09 09 09 20 20 20 20 20 28 63 6f 6e 63 20 ..... (conc
5ea0: 22 2f 70 61 67 65 73 2f 22 29 0a 09 09 09 09 20 "/pages/").....
5eb0: 20 20 20 20 28 63 6f 6e 63 20 22 2f 70 61 67 65 (conc "/page
5ec0: 73 2f 22 20 70 61 67 65 29 29 29 29 0a 09 20 28 s/" page)))).. (
5ed0: 63 6f 6e 74 72 6f 6c 20 28 73 74 72 69 6e 67 2d control (string-
5ee0: 61 70 70 65 6e 64 20 64 69 72 20 28 69 66 20 64 append dir (if d
5ef0: 69 72 2d 73 74 79 6c 65 20 0a 09 09 09 09 09 20 ir-style ......
5f00: 28 63 6f 6e 63 20 70 61 67 65 20 22 5f 63 74 72 (conc page "_ctr
5f10: 6c 2e 73 63 6d 22 29 0a 09 09 09 09 09 20 22 2f l.scm")...... "/
5f20: 63 6f 6e 74 72 6f 6c 2e 73 63 6d 22 29 29 29 0a control.scm"))).
5f30: 09 20 28 76 69 65 77 20 20 20 20 28 73 74 72 69 . (view (stri
5f40: 6e 67 2d 61 70 70 65 6e 64 20 64 69 72 20 28 69 ng-append dir (i
5f50: 66 20 64 69 72 2d 73 74 79 6c 65 20 0a 09 09 09 f dir-style ....
5f60: 09 09 20 28 63 6f 6e 63 20 70 61 67 65 20 22 5f .. (conc page "_
5f70: 76 69 65 77 2e 73 63 6d 22 29 0a 09 09 09 09 09 view.scm")......
5f80: 20 22 2f 76 69 65 77 2e 73 63 6d 22 29 29 29 0a "/view.scm"))).
5f90: 09 20 28 6c 6f 61 64 2d 76 69 65 77 20 20 20 20 . (load-view
5fa0: 28 61 6e 64 20 28 66 69 6c 65 2d 65 78 69 73 74 (and (file-exist
5fb0: 73 3f 20 76 69 65 77 29 0a 09 09 09 20 20 20 20 s? view)....
5fc0: 28 6f 72 20 28 65 71 3f 20 70 61 72 74 73 20 27 (or (eq? parts '
5fd0: 62 6f 74 68 29 28 65 71 3f 20 70 61 72 74 73 20 both)(eq? parts
5fe0: 27 76 69 65 77 29 29 29 29 0a 09 20 28 6c 6f 61 'view)))).. (loa
5ff0: 64 2d 63 6f 6e 74 72 6f 6c 20 28 61 6e 64 20 28 d-control (and (
6000: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 63 6f 6e file-exists? con
6010: 74 72 6f 6c 29 0a 09 09 09 20 20 20 20 28 6f 72 trol).... (or
6020: 20 28 65 71 3f 20 70 61 72 74 73 20 27 62 6f 74 (eq? parts 'bot
6030: 68 29 28 65 71 3f 20 70 61 72 74 73 20 27 63 6f h)(eq? parts 'co
6040: 6e 74 72 6f 6c 29 29 29 29 0a 09 20 28 76 69 65 ntrol)))).. (vie
6050: 77 2d 64 61 74 20 20 20 27 28 29 29 29 0a 20 20 w-dat '())).
6060: 20 20 3b 3b 20 28 73 65 73 73 69 6f 6e 3a 6c 6f ;; (session:lo
6070: 67 20 73 65 6c 66 20 22 64 69 72 2d 73 74 79 6c g self "dir-styl
6080: 65 3a 20 22 20 64 69 72 2d 73 74 79 6c 65 29 0a e: " dir-style).
6090: 20 3b 3b 20 20 20 28 73 75 67 61 72 20 22 2f 68 ;; (sugar "/h
60a0: 6f 6d 65 2f 6d 61 74 74 2f 6b 69 61 74 6f 61 2f ome/matt/kiatoa/
60b0: 73 74 6d 6c 2f 73 75 67 61 72 2e 73 63 6d 22 20 stml/sugar.scm"
60c0: 29 29 0a 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 )). ;; (print
60d0: 20 22 64 69 72 3d 22 20 64 69 72 20 22 20 63 6f "dir=" dir " co
60e0: 6e 74 72 6f 6c 3d 22 20 63 6f 6e 74 72 6f 6c 20 ntrol=" control
60f0: 22 20 76 69 65 77 3d 22 20 76 69 65 77 20 22 20 " view=" view "
6100: 6c 6f 61 64 2d 76 69 65 77 3d 22 20 6c 6f 61 64 load-view=" load
6110: 2d 76 69 65 77 20 22 20 6c 6f 61 64 3d 63 6f 6e -view " load=con
6120: 74 72 6f 6c 3d 22 20 6c 6f 61 64 2d 63 6f 6e 74 trol=" load-cont
6130: 72 6f 6c 29 0a 20 20 20 20 28 69 66 20 6c 6f 61 rol). (if loa
6140: 64 2d 63 6f 6e 74 72 6f 6c 0a 09 28 62 65 67 69 d-control..(begi
6150: 6e 0a 09 20 20 28 6c 6f 61 64 20 63 6f 6e 74 72 n.. (load contr
6160: 6f 6c 29 0a 09 20 20 28 73 65 73 73 69 6f 6e 3a ol).. (session:
6170: 73 65 74 2d 63 61 6c 6c 65 64 21 20 73 65 6c 66 set-called! self
6180: 20 70 61 67 65 29 29 29 0a 20 20 20 20 3b 3b 20 page))). ;;
6190: 6d 6f 76 65 20 74 68 69 73 20 74 6f 20 77 68 65 move this to whe
61a0: 72 65 20 69 74 20 67 65 74 73 20 65 78 65 63 74 re it gets exect
61b0: 75 74 65 64 20 6f 6e 6c 79 20 6f 6e 63 65 0a 20 uted only once.
61c0: 20 20 20 3b 3b 0a 20 20 20 20 28 69 66 20 6c 6f ;;. (if lo
61d0: 61 64 2d 76 69 65 77 0a 09 3b 3b 20 6f 70 74 69 ad-view..;; opti
61e0: 6f 6e 20 6f 6e 65 2e 3a 0a 09 3b 3b 0a 09 3b 3b on one.:..;;..;;
61f0: 20 28 6c 65 74 20 28 28 69 6e 70 20 28 6f 70 65 (let ((inp (ope
6200: 6e 2d 69 6e 70 75 74 2d 73 74 72 69 6e 67 20 0a n-input-string .
6210: 09 3b 3b 20 09 20 20 20 20 28 66 69 6c 65 73 2d .;; . (files-
6220: 72 65 61 64 2d 3e 73 74 72 69 6e 67 20 22 2f 68 read->string "/h
6230: 6f 6d 65 2f 6d 61 74 74 2f 6b 69 61 74 6f 61 2f ome/matt/kiatoa/
6240: 73 74 6d 6c 2f 73 75 67 61 72 2e 73 63 6d 22 20 stml/sugar.scm"
6250: 0a 09 3b 3b 20 09 09 09 09 76 69 65 77 29 29 29 ..;; ....view)))
6260: 29 0a 09 3b 3b 20 20 20 28 6d 61 70 20 0a 09 3b )..;; (map ..;
6270: 3b 20 20 20 20 28 6c 61 6d 62 64 61 20 28 78 29 ; (lambda (x)
6280: 0a 09 3b 3b 20 20 20 20 20 20 28 63 6f 6e 64 0a ..;; (cond.
6290: 09 3b 3b 20 20 20 20 20 20 20 28 28 6c 69 73 74 .;; ((list
62a0: 3f 20 78 29 20 78 29 0a 09 3b 3b 20 20 20 20 20 ? x) x)..;;
62b0: 20 20 28 28 73 74 72 69 6e 67 3f 20 78 29 20 78 ((string? x) x
62c0: 29 0a 09 3b 3b 20 20 20 20 20 20 20 28 65 6c 73 )..;; (els
62d0: 65 20 27 28 29 29 29 29 0a 09 3b 3b 20 20 20 20 e '())))..;;
62e0: 28 70 6f 72 74 2d 6d 61 70 20 65 76 61 6c 20 28 (port-map eval (
62f0: 6c 61 6d 62 64 61 20 28 29 0a 09 3b 3b 20 09 09 lambda ()..;; ..
6300: 20 28 72 65 61 64 20 69 6e 70 29 29 29 29 29 0a (read inp))))).
6310: 09 3b 3b 0a 09 3b 3b 20 6f 70 74 69 6f 6e 20 74 .;;..;; option t
6320: 77 6f 3a 0a 09 3b 3b 0a 09 28 6c 65 74 2a 20 28 wo:..;;..(let* (
6330: 3b 3b 20 28 69 6e 70 73 20 28 6d 61 70 20 6f 70 ;; (inps (map op
6340: 65 6e 2d 69 6e 70 75 74 2d 66 69 6c 65 20 28 6c en-input-file (l
6350: 69 73 74 20 76 69 65 77 29 29 29 20 3b 3b 20 73 ist view))) ;; s
6360: 75 67 61 72 20 76 69 65 77 29 29 29 0a 09 20 20 ugar view)))..
6370: 20 20 20 20 20 28 70 20 20 20 20 28 6f 70 65 6e (p (open
6380: 2d 69 6e 70 75 74 2d 66 69 6c 65 20 76 69 65 77 -input-file view
6390: 29 29 20 3b 3b 20 28 61 70 70 6c 79 20 6d 61 6b )) ;; (apply mak
63a0: 65 2d 63 6f 6e 63 61 74 65 6e 61 74 65 64 2d 70 e-concatenated-p
63b0: 6f 72 74 20 69 6e 70 73 29 29 0a 09 20 20 20 20 ort inps))..
63c0: 20 20 20 28 64 61 74 20 20 28 6d 61 70 20 0a 09 (dat (map ..
63d0: 09 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 . (lambda (
63e0: 78 29 0a 09 09 09 28 63 6f 6e 64 0a 09 09 09 20 x)....(cond....
63f0: 28 28 6c 69 73 74 3f 20 78 29 20 78 29 0a 09 09 ((list? x) x)...
6400: 09 20 28 28 73 74 72 69 6e 67 3f 20 78 29 20 78 . ((string? x) x
6410: 29 0a 09 09 09 20 28 65 6c 73 65 20 27 28 29 29 ).... (else '())
6420: 29 29 0a 09 09 20 20 20 20 20 20 28 70 6f 72 74 ))... (port
6430: 2d 6d 61 70 20 65 76 61 6c 20 28 6c 61 6d 62 64 -map eval (lambd
6440: 61 20 28 29 28 72 65 61 64 20 70 29 29 29 29 29 a ()(read p)))))
6450: 29 0a 09 20 20 3b 3b 20 28 6d 61 70 20 63 6c 6f ).. ;; (map clo
6460: 73 65 2d 69 6e 70 75 74 2d 70 6f 72 74 20 69 6e se-input-port in
6470: 70 73 29 0a 09 20 20 28 63 6c 6f 73 65 2d 69 6e ps).. (close-in
6480: 70 75 74 2d 70 6f 72 74 20 70 29 0a 09 20 20 64 put-port p).. d
6490: 61 74 29 0a 09 28 6c 69 73 74 20 22 3c 70 3e 50 at)..(list "<p>P
64a0: 61 67 65 20 6e 6f 74 20 66 6f 75 6e 64 20 22 20 age not found "
64b0: 70 61 67 65 20 22 20 3c 2f 70 3e 22 29 29 29 29 page " </p>"))))
64c0: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ..(define (sessi
64d0: 6f 6e 3a 63 61 6c 6c 20 73 65 6c 66 20 70 61 67 on:call self pag
64e0: 65 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a 63 61 e). (session:ca
64f0: 6c 6c 2d 70 61 72 74 73 20 73 65 6c 66 20 70 61 ll-parts self pa
6500: 67 65 20 27 62 6f 74 68 29 29 0a 0a 28 64 65 66 ge 'both))..(def
6510: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 63 61 6c ine (session:cal
6520: 6c 20 73 65 6c 66 20 70 61 67 65 20 70 61 72 74 l self page part
6530: 73 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a 63 61 s). (session:ca
6540: 6c 6c 2d 70 61 72 74 73 20 73 65 6c 66 20 70 61 ll-parts self pa
6550: 67 65 20 27 62 6f 74 68 29 29 0a 0a 28 64 65 66 ge 'both))..(def
6560: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 61 ine (session:loa
6570: 64 2d 6d 6f 64 65 6c 20 73 65 6c 66 20 6d 6f 64 d-model self mod
6580: 65 6c 29 0a 20 20 28 6c 65 74 20 28 28 6d 6f 64 el). (let ((mod
6590: 65 6c 2e 73 63 6d 20 28 73 74 72 69 6e 67 2d 61 el.scm (string-a
65a0: 70 70 65 6e 64 20 28 73 64 61 74 2d 67 65 74 2d ppend (sdat-get-
65b0: 73 72 6f 6f 74 20 73 65 6c 66 29 20 22 2f 6d 6f sroot self) "/mo
65c0: 64 65 6c 73 2f 22 20 6d 6f 64 65 6c 20 22 2e 73 dels/" model ".s
65d0: 63 6d 22 29 29 0a 09 28 6d 6f 64 65 6c 2e 73 6f cm"))..(model.so
65e0: 20 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 (string-append
65f0: 20 28 73 64 61 74 2d 67 65 74 2d 73 72 6f 6f 74 (sdat-get-sroot
6600: 20 73 65 6c 66 29 20 22 2f 6d 6f 64 65 6c 73 2f self) "/models/
6610: 22 20 6d 6f 64 65 6c 20 22 2e 73 6f 22 29 29 29 " model ".so")))
6620: 0a 20 20 20 20 28 69 66 20 28 66 69 6c 65 2d 65 . (if (file-e
6630: 78 69 73 74 73 3f 20 6d 6f 64 65 6c 2e 73 6f 29 xists? model.so)
6640: 0a 09 28 6c 6f 61 64 20 6d 6f 64 65 6c 2e 73 6f ..(load model.so
6650: 29 0a 09 28 69 66 20 28 66 69 6c 65 2d 65 78 69 )..(if (file-exi
6660: 73 74 73 3f 20 6d 6f 64 65 6c 2e 73 63 6d 29 0a sts? model.scm).
6670: 09 20 20 20 20 28 6c 6f 61 64 20 6d 6f 64 65 6c . (load model
6680: 2e 73 63 6d 29 0a 09 20 20 20 20 28 73 3a 6c 6f .scm).. (s:lo
6690: 67 20 22 45 52 52 4f 52 3a 20 6d 6f 64 65 6c 20 g "ERROR: model
66a0: 22 20 6d 6f 64 65 6c 2e 73 63 6d 20 22 20 6e 6f " model.scm " no
66b0: 74 20 66 6f 75 6e 64 22 29 29 29 29 29 0a 0a 28 t found")))))..(
66c0: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
66d0: 6d 6f 64 65 6c 2d 70 61 74 68 20 73 65 6c 66 20 model-path self
66e0: 6d 6f 64 65 6c 29 0a 20 20 28 73 74 72 69 6e 67 model). (string
66f0: 2d 61 70 70 65 6e 64 20 28 73 64 61 74 2d 67 65 -append (sdat-ge
6700: 74 2d 73 72 6f 6f 74 20 73 65 6c 66 29 20 22 2f t-sroot self) "/
6710: 6d 6f 64 65 6c 73 2f 22 20 6d 6f 64 65 6c 20 22 models/" model "
6720: 2e 73 63 6d 22 29 29 0a 0a 28 64 65 66 69 6e 65 .scm"))..(define
6730: 20 28 73 65 73 73 69 6f 6e 3a 70 70 2d 66 6f 72 (session:pp-for
6740: 6d 64 61 74 20 73 65 6c 66 29 0a 20 20 28 6c 65 mdat self). (le
6750: 74 20 28 28 64 61 74 20 28 66 6f 72 6d 64 61 74 t ((dat (formdat
6760: 3a 61 6c 6c 2d 3e 73 74 72 69 6e 67 73 20 28 73 :all->strings (s
6770: 64 61 74 2d 67 65 74 2d 66 6f 72 6d 64 61 74 20 dat-get-formdat
6780: 73 65 6c 66 29 29 29 29 0a 20 20 20 20 28 73 74 self)))). (st
6790: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
67a0: 20 64 61 74 20 22 3c 62 72 3e 20 22 29 29 29 0a dat "<br> "))).
67b0: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
67c0: 6e 3a 70 61 72 61 6d 2d 3e 73 74 72 69 6e 67 20 n:param->string
67d0: 70 61 72 61 6d 73 29 0a 20 20 3b 3b 20 28 65 72 params). ;; (er
67e0: 72 3a 6c 6f 67 20 22 70 61 72 61 6d 73 3d 22 20 r:log "params="
67f0: 70 61 72 61 6d 73 29 0a 20 20 28 69 66 20 28 3c params). (if (<
6800: 20 28 6c 65 6e 67 74 68 20 70 61 72 61 6d 73 29 (length params)
6810: 20 31 29 0a 20 20 20 20 20 20 22 22 0a 20 20 20 1). "".
6820: 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 6b (let loop ((k
6830: 65 79 20 28 63 61 72 20 70 61 72 61 6d 73 29 29 ey (car params))
6840: 0a 09 09 20 28 76 61 6c 20 28 63 61 64 72 20 70 ... (val (cadr p
6850: 61 72 61 6d 73 29 29 0a 09 09 20 28 74 61 69 6c arams))... (tail
6860: 20 28 63 64 64 72 20 70 61 72 61 6d 73 29 29 0a (cddr params)).
6870: 09 09 20 28 72 65 73 75 6c 74 20 27 28 29 29 29 .. (result '()))
6880: 0a 09 28 6c 65 74 20 28 28 6e 65 77 72 65 73 75 ..(let ((newresu
6890: 6c 74 20 28 63 6f 6e 73 20 28 73 74 72 69 6e 67 lt (cons (string
68a0: 2d 61 70 70 65 6e 64 20 28 73 3a 61 6e 79 2d 3e -append (s:any->
68b0: 73 74 72 69 6e 67 20 6b 65 79 29 20 22 3d 22 20 string key) "="
68c0: 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 76 (s:any->string v
68d0: 61 6c 29 29 0a 09 09 09 20 20 20 20 20 20 20 72 al)).... r
68e0: 65 73 75 6c 74 29 29 29 0a 09 20 20 28 69 66 20 esult))).. (if
68f0: 28 3c 20 28 6c 65 6e 67 74 68 20 74 61 69 6c 29 (< (length tail)
6900: 20 31 29 20 3b 3b 20 74 72 75 65 20 69 66 20 64 1) ;; true if d
6910: 6f 6e 65 0a 09 20 20 20 20 20 20 28 73 74 72 69 one.. (stri
6920: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 6e ng-intersperse n
6930: 65 77 72 65 73 75 6c 74 20 22 26 22 29 0a 09 20 ewresult "&")..
6940: 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 (loop (car
6950: 74 61 69 6c 29 28 63 61 64 72 20 74 61 69 6c 29 tail)(cadr tail)
6960: 28 63 64 64 72 20 74 61 69 6c 29 20 6e 65 77 72 (cddr tail) newr
6970: 65 73 75 6c 74 29 29 29 29 29 29 0a 0a 28 64 65 esult))))))..(de
6980: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 6c 69 fine (session:li
6990: 6e 6b 2d 74 6f 20 73 65 6c 66 20 70 61 67 65 20 nk-to self page
69a0: 70 61 72 61 6d 73 29 0a 20 20 28 6c 65 74 2a 20 params). (let*
69b0: 28 28 73 65 72 76 65 72 20 20 20 20 28 69 66 20 ((server (if
69c0: 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 (get-environment
69d0: 2d 76 61 72 69 61 62 6c 65 20 22 48 54 54 50 5f -variable "HTTP_
69e0: 48 4f 53 54 22 29 0a 09 09 09 28 67 65 74 2d 65 HOST")....(get-e
69f0: 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 nvironment-varia
6a00: 62 6c 65 20 22 48 54 54 50 5f 48 4f 53 54 22 29 ble "HTTP_HOST")
6a10: 0a 09 09 09 28 67 65 74 2d 65 6e 76 69 72 6f 6e ....(get-environ
6a20: 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 53 ment-variable "S
6a30: 45 52 56 45 52 5f 4e 41 4d 45 22 29 29 29 0a 09 ERVER_NAME")))..
6a40: 20 28 73 63 72 69 70 74 20 28 6c 65 74 20 28 28 (script (let ((
6a50: 73 63 72 69 70 74 2d 6e 61 6d 65 20 28 73 74 72 script-name (str
6a60: 69 6e 67 2d 73 70 6c 69 74 20 28 67 65 74 2d 65 ing-split (get-e
6a70: 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 nvironment-varia
6a80: 62 6c 65 20 22 53 43 52 49 50 54 5f 4e 41 4d 45 ble "SCRIPT_NAME
6a90: 22 29 20 22 2f 22 29 29 29 0a 09 09 20 20 20 28 ") "/")))... (
6aa0: 69 66 20 28 3e 20 28 6c 65 6e 67 74 68 20 73 63 if (> (length sc
6ab0: 72 69 70 74 2d 6e 61 6d 65 29 20 31 29 0a 09 09 ript-name) 1)...
6ac0: 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 61 (string-a
6ad0: 70 70 65 6e 64 20 28 63 61 72 20 73 63 72 69 70 ppend (car scrip
6ae0: 74 2d 6e 61 6d 65 29 20 22 2f 22 20 28 63 61 64 t-name) "/" (cad
6af0: 72 20 73 63 72 69 70 74 2d 6e 61 6d 65 29 29 0a r script-name)).
6b00: 09 09 20 20 20 20 20 20 20 28 67 65 74 2d 65 6e .. (get-en
6b10: 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 vironment-variab
6b20: 6c 65 20 22 53 43 52 49 50 54 5f 4e 41 4d 45 22 le "SCRIPT_NAME"
6b30: 29 29 29 29 20 3b 3b 20 62 75 69 6c 64 20 73 63 )))) ;; build sc
6b40: 72 69 70 74 20 6e 61 6d 65 20 66 72 6f 6d 20 66 ript name from f
6b50: 69 72 73 74 20 74 77 6f 20 65 6c 65 6d 65 6e 74 irst two element
6b60: 73 2e 20 54 68 69 73 20 69 73 20 61 20 68 61 6e s. This is a han
6b70: 67 6f 76 65 72 20 66 72 6f 6d 20 62 65 66 6f 72 gover from befor
6b80: 65 20 49 20 75 73 65 64 20 3f 20 69 6e 20 74 68 e I used ? in th
6b90: 65 20 55 52 4c 2e 0a 09 20 28 73 65 73 73 69 6f e URL... (sessio
6ba0: 6e 2d 6b 65 79 20 28 73 64 61 74 2d 67 65 74 2d n-key (sdat-get-
6bb0: 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 session-key self
6bc0: 29 29 0a 09 20 28 70 61 72 61 6d 73 74 72 20 28 )).. (paramstr (
6bd0: 73 65 73 73 69 6f 6e 3a 70 61 72 61 6d 2d 3e 73 session:param->s
6be0: 74 72 69 6e 67 20 70 61 72 61 6d 73 29 29 29 0a tring params))).
6bf0: 20 20 20 20 3b 3b 20 28 73 65 73 73 69 6f 6e 3a ;; (session:
6c00: 6c 6f 67 20 73 65 6c 66 20 22 73 65 72 76 65 72 log self "server
6c10: 3d 22 20 73 65 72 76 65 72 20 22 20 73 63 72 69 =" server " scri
6c20: 70 74 3d 22 20 73 63 72 69 70 74 20 22 20 70 61 pt=" script " pa
6c30: 67 65 3d 22 20 70 61 67 65 29 0a 20 20 20 20 28 ge=" page). (
6c40: 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 22 68 string-append "h
6c50: 74 74 70 3a 2f 2f 22 20 73 65 72 76 65 72 20 22 ttp://" server "
6c60: 2f 22 20 73 63 72 69 70 74 20 22 2f 22 20 70 61 /" script "/" pa
6c70: 67 65 20 22 3f 22 20 70 61 72 61 6d 73 74 72 29 ge "?" paramstr)
6c80: 29 29 20 3b 3b 20 22 2f 73 6e 3d 22 20 73 65 73 )) ;; "/sn=" ses
6c90: 73 69 6f 6e 2d 6b 65 79 29 29 29 0a 0a 28 64 65 sion-key)))..(de
6ca0: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 63 67 fine (session:cg
6cb0: 69 2d 6f 75 74 20 73 65 6c 66 29 0a 20 20 28 6c i-out self). (l
6cc0: 65 74 2a 20 28 28 63 6f 6e 74 65 6e 74 20 20 28 et* ((content (
6cd0: 6c 69 73 74 20 28 73 64 61 74 2d 67 65 74 2d 63 list (sdat-get-c
6ce0: 6f 6e 74 65 6e 74 2d 74 79 70 65 20 73 65 6c 66 ontent-type self
6cf0: 29 29 29 20 3b 3b 20 27 28 22 43 6f 6e 74 65 6e ))) ;; '("Conten
6d00: 74 2d 74 79 70 65 3a 20 74 65 78 74 2f 68 74 6d t-type: text/htm
6d10: 6c 3b 20 63 68 61 72 73 65 74 3d 69 73 6f 2d 38 l; charset=iso-8
6d20: 38 35 39 2d 31 5c 6e 5c 6e 22 29 29 0a 09 20 28 859-1\n\n")).. (
6d30: 68 65 61 64 65 72 20 20 20 28 6c 65 74 20 28 28 header (let ((
6d40: 63 6f 6f 6b 69 65 20 28 73 64 61 74 2d 67 65 74 cookie (sdat-get
6d50: 2d 73 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 20 -session-cookie
6d60: 73 65 6c 66 29 29 29 0a 09 09 20 20 20 20 20 28 self)))... (
6d70: 69 66 20 63 6f 6f 6b 69 65 0a 09 09 09 20 28 63 if cookie.... (c
6d80: 6f 6e 73 20 28 73 74 72 69 6e 67 2d 61 70 70 65 ons (string-appe
6d90: 6e 64 20 22 53 65 74 2d 43 6f 6f 6b 69 65 3a 20 nd "Set-Cookie:
6da0: 22 20 28 63 61 72 20 63 6f 6f 6b 69 65 29 29 0a " (car cookie)).
6db0: 09 09 09 20 20 20 20 20 20 20 63 6f 6e 74 65 6e ... conten
6dc0: 74 29 0a 09 09 09 20 63 6f 6e 74 65 6e 74 29 29 t).... content))
6dd0: 29 0a 09 20 28 70 61 67 65 64 61 74 20 20 28 73 ).. (pagedat (s
6de0: 64 61 74 2d 67 65 74 2d 70 61 67 65 64 61 74 20 dat-get-pagedat
6df0: 73 65 6c 66 29 29 29 0a 20 20 20 20 28 73 3a 63 self))). (s:c
6e00: 67 69 2d 6f 75 74 20 0a 20 20 20 20 20 28 63 6f gi-out . (co
6e10: 6e 73 20 68 65 61 64 65 72 20 70 61 67 65 64 61 ns header pageda
6e20: 74 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 t))))..(define (
6e30: 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 session:log self
6e40: 20 2e 20 6d 73 67 29 0a 20 20 28 77 69 74 68 2d . msg). (with-
6e50: 6f 75 74 70 75 74 2d 74 6f 2d 70 6f 72 74 20 28 output-to-port (
6e60: 73 64 61 74 2d 67 65 74 2d 6c 6f 67 2d 70 6f 72 sdat-get-log-por
6e70: 74 20 73 65 6c 66 29 20 3b 3b 20 28 73 64 61 74 t self) ;; (sdat
6e80: 2d 67 65 74 2d 6c 6f 67 70 74 20 73 65 6c 66 29 -get-logpt self)
6e90: 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 20 . (lambda ()
6ea0: 0a 20 20 20 20 20 20 28 61 70 70 6c 79 20 70 72 . (apply pr
6eb0: 69 6e 74 20 6d 73 67 29 29 29 29 0a 0a 28 64 65 int msg))))..(de
6ec0: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 fine (session:ge
6ed0: 74 2d 70 61 72 61 6d 20 73 65 6c 66 20 6b 65 79 t-param self key
6ee0: 29 0a 20 20 3b 3b 20 28 73 65 73 73 69 6f 6e 3a ). ;; (session:
6ef0: 6c 6f 67 20 73 3a 73 65 73 73 69 6f 6e 20 22 70 log s:session "p
6f00: 61 72 61 6d 73 3d 22 20 28 73 6c 6f 74 2d 72 65 arams=" (slot-re
6f10: 66 20 73 3a 73 65 73 73 69 6f 6e 20 27 70 61 72 f s:session 'par
6f20: 61 6d 73 29 29 0a 20 20 28 6c 65 74 20 28 28 70 ams)). (let ((p
6f30: 61 72 61 6d 73 20 28 73 64 61 74 2d 67 65 74 2d arams (sdat-get-
6f40: 70 61 72 61 6d 73 20 73 65 6c 66 29 29 29 0a 20 params self))).
6f50: 20 20 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d (session:get-
6f60: 70 61 72 61 6d 2d 66 72 6f 6d 20 70 61 72 61 6d param-from param
6f70: 73 20 6b 65 79 29 29 29 0a 0a 3b 3b 20 54 68 69 s key)))..;; Thi
6f80: 73 20 6f 6e 65 20 77 69 6c 6c 20 67 65 74 20 74 s one will get t
6f90: 68 65 20 66 69 72 73 74 20 76 61 6c 75 65 20 66 he first value f
6fa0: 6f 75 6e 64 20 72 65 67 61 72 64 6c 65 73 73 20 ound regardless
6fb0: 6f 66 20 66 6f 72 6d 0a 28 64 65 66 69 6e 65 20 of form.(define
6fc0: 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 69 6e 70 (session:get-inp
6fd0: 75 74 20 73 65 6c 66 20 6b 65 79 29 0a 20 20 28 ut self key). (
6fe0: 6c 65 74 2a 20 28 28 66 6f 72 6d 64 61 74 20 28 let* ((formdat (
6ff0: 73 64 61 74 2d 67 65 74 2d 66 6f 72 6d 64 61 74 sdat-get-formdat
7000: 20 73 65 6c 66 29 29 29 0a 20 20 20 20 28 69 66 self))). (if
7010: 20 28 6e 6f 74 20 66 6f 72 6d 64 61 74 29 20 23 (not formdat) #
7020: 66 0a 09 28 69 66 20 28 6f 72 20 28 73 74 72 69 f..(if (or (stri
7030: 6e 67 3f 20 6b 65 79 29 28 6e 75 6d 62 65 72 3f ng? key)(number?
7040: 20 6b 65 79 29 28 73 79 6d 62 6f 6c 3f 20 6b 65 key)(symbol? ke
7050: 79 29 29 0a 09 20 20 20 20 28 69 66 20 28 65 71 y)).. (if (eq
7060: 3f 20 28 63 6c 61 73 73 2d 6f 66 20 66 6f 72 6d ? (class-of form
7070: 64 61 74 29 20 3c 66 6f 72 6d 64 61 74 3e 29 0a dat) <formdat>).
7080: 09 09 28 66 6f 72 6d 64 61 74 3a 67 65 74 20 66 ..(formdat:get f
7090: 6f 72 6d 64 61 74 20 6b 65 79 29 0a 09 09 28 62 ormdat key)...(b
70a0: 65 67 69 6e 0a 09 09 20 20 28 73 65 73 73 69 6f egin... (sessio
70b0: 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 45 52 52 4f n:log self "ERRO
70c0: 52 3a 20 66 6f 72 6d 64 61 74 3a 20 22 20 66 6f R: formdat: " fo
70d0: 72 6d 64 61 74 20 22 20 69 73 20 6e 6f 74 20 6f rmdat " is not o
70e0: 66 20 63 6c 61 73 73 20 3c 66 6f 72 6d 64 61 74 f class <formdat
70f0: 3e 22 29 0a 09 09 20 20 23 66 29 29 0a 09 20 20 >")... #f))..
7100: 20 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 (session:log s
7110: 65 6c 66 20 22 45 52 52 4f 52 3a 20 62 61 64 20 elf "ERROR: bad
7120: 6b 65 79 20 22 20 6b 65 79 29 29 29 29 29 0a 0a key " key)))))..
7130: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
7140: 3a 72 75 6e 2d 61 63 74 69 6f 6e 73 20 73 65 6c :run-actions sel
7150: 66 29 0a 20 20 28 6c 65 74 2a 20 28 28 61 63 74 f). (let* ((act
7160: 69 6f 6e 20 20 20 20 28 73 65 73 73 69 6f 6e 3a ion (session:
7170: 67 65 74 2d 70 61 72 61 6d 20 73 65 6c 66 20 27 get-param self '
7180: 61 63 74 69 6f 6e 29 29 0a 09 20 28 70 61 67 65 action)).. (page
7190: 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d (sdat-get-
71a0: 70 61 67 65 20 73 65 6c 66 29 29 29 0a 20 20 20 page self))).
71b0: 20 3b 3b 20 28 70 72 69 6e 74 20 22 61 63 74 69 ;; (print "acti
71c0: 6f 6e 3d 22 20 61 63 74 69 6f 6e 20 22 20 70 61 on=" action " pa
71d0: 67 65 3d 22 20 70 61 67 65 29 0a 20 20 20 20 28 ge=" page). (
71e0: 69 66 20 61 63 74 69 6f 6e 0a 09 28 6c 65 74 20 if action..(let
71f0: 28 28 61 63 74 69 6f 6e 2d 6c 73 74 20 20 28 73 ((action-lst (s
7200: 74 72 69 6e 67 2d 73 70 6c 69 74 20 61 63 74 69 tring-split acti
7210: 6f 6e 20 22 2e 22 29 29 29 0a 09 20 20 3b 3b 20 on "."))).. ;;
7220: 28 70 72 69 6e 74 20 22 61 63 74 69 6f 6e 2d 6c (print "action-l
7230: 73 74 3d 22 20 61 63 74 69 6f 6e 2d 6c 73 74 29 st=" action-lst)
7240: 0a 09 20 20 28 69 66 20 28 6e 6f 74 20 28 3d 20 .. (if (not (=
7250: 28 6c 65 6e 67 74 68 20 61 63 74 69 6f 6e 2d 6c (length action-l
7260: 73 74 29 20 32 29 29 20 0a 09 20 20 20 20 20 20 st) 2)) ..
7270: 28 65 72 72 3a 6c 6f 67 20 22 41 63 74 69 6f 6e (err:log "Action
7280: 20 73 68 6f 75 6c 64 20 62 65 20 6f 66 20 66 6f should be of fo
7290: 72 6d 3a 20 6d 6f 64 75 6c 65 2e 61 63 74 69 6f rm: module.actio
72a0: 6e 22 29 0a 09 20 20 20 20 20 20 28 6c 65 74 2a n").. (let*
72b0: 20 28 28 74 61 72 67 2d 70 61 67 65 20 20 20 28 ((targ-page (
72c0: 63 61 72 20 61 63 74 69 6f 6e 2d 6c 73 74 29 29 car action-lst))
72d0: 0a 09 09 20 20 20 20 20 28 70 72 6f 63 2d 6e 61 ... (proc-na
72e0: 6d 65 20 20 20 28 73 74 72 69 6e 67 2d 61 70 70 me (string-app
72f0: 65 6e 64 20 74 61 72 67 2d 70 61 67 65 20 22 2d end targ-page "-
7300: 61 63 74 69 6f 6e 22 29 29 0a 09 09 20 20 20 20 action"))...
7310: 20 28 74 61 72 67 2d 61 63 74 69 6f 6e 20 28 63 (targ-action (c
7320: 61 64 72 20 61 63 74 69 6f 6e 2d 6c 73 74 29 29 adr action-lst))
7330: 29 0a 09 09 3b 3b 20 28 65 72 72 3a 6c 6f 67 20 )...;; (err:log
7340: 22 74 61 72 67 2d 70 61 67 65 3d 22 20 74 61 72 "targ-page=" tar
7350: 67 2d 70 61 67 65 20 22 20 70 72 6f 63 2d 6e 61 g-page " proc-na
7360: 6d 65 3d 22 20 70 72 6f 63 2d 6e 61 6d 65 20 22 me=" proc-name "
7370: 20 74 61 72 67 2d 61 63 74 69 6f 6e 3d 22 20 74 targ-action=" t
7380: 61 72 67 2d 61 63 74 69 6f 6e 29 0a 0a 09 09 3b arg-action)....;
7390: 3b 20 63 61 6c 6c 20 68 65 72 65 20 6f 6e 6c 79 ; call here only
73a0: 20 69 66 20 6e 65 76 65 72 20 63 61 6c 6c 65 64 if never called
73b0: 20 62 65 66 6f 72 65 0a 09 09 28 69 66 20 28 73 before...(if (s
73c0: 65 73 73 69 6f 6e 3a 6e 65 76 65 72 2d 63 61 6c ession:never-cal
73d0: 6c 65 64 2d 70 61 67 65 3f 20 73 65 6c 66 20 74 led-page? self t
73e0: 61 72 67 2d 70 61 67 65 29 0a 09 09 20 20 20 20 arg-page)...
73f0: 28 73 65 73 73 69 6f 6e 3a 63 61 6c 6c 2d 70 61 (session:call-pa
7400: 72 74 73 20 73 65 6c 66 20 74 61 72 67 2d 70 61 rts self targ-pa
7410: 67 65 20 27 63 6f 6e 74 72 6f 6c 29 29 0a 09 09 ge 'control))...
7420: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
7430: 20 20 20 20 20 20 70 72 6f 63 20 20 20 20 20 20 proc
7440: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7450: 20 20 20 61 63 74 69 6f 6e 20 20 20 20 0a 0a 09 action ...
7460: 09 28 69 66 20 23 74 20 3b 3b 20 73 65 74 20 74 .(if #t ;; set t
7470: 6f 20 23 74 20 74 6f 20 73 65 65 20 62 65 74 74 o #t to see bett
7480: 65 72 20 65 72 72 6f 72 20 6d 65 73 73 61 67 65 er error message
7490: 73 20 64 75 72 69 6e 67 20 64 65 62 75 67 67 69 s during debuggi
74a0: 6e 20 3a 2d 29 0a 09 09 20 20 20 20 28 28 65 76 n :-)... ((ev
74b0: 61 6c 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 al (string->symb
74c0: 6f 6c 20 70 72 6f 63 2d 6e 61 6d 65 29 29 20 74 ol proc-name)) t
74d0: 61 72 67 2d 61 63 74 69 6f 6e 29 20 3b 3b 20 75 arg-action) ;; u
74e0: 6e 73 61 66 65 20 65 78 65 63 75 74 69 6f 6e 0a nsafe execution.
74f0: 09 09 20 20 20 20 28 63 6f 6e 64 69 74 69 6f 6e .. (condition
7500: 2d 63 61 73 65 20 28 28 65 76 61 6c 20 28 73 74 -case ((eval (st
7510: 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 70 72 6f ring->symbol pro
7520: 63 2d 6e 61 6d 65 29 29 20 74 61 72 67 2d 61 63 c-name)) targ-ac
7530: 74 69 6f 6e 29 0a 09 09 09 09 20 20 20 20 28 28 tion)..... ((
7540: 65 78 6e 20 66 69 6c 65 29 20 28 73 3a 6c 6f 67 exn file) (s:log
7550: 20 22 66 69 6c 65 20 65 72 72 6f 72 22 29 29 0a "file error")).
7560: 09 09 09 09 20 20 20 20 28 28 65 78 6e 20 69 2f .... ((exn i/
7570: 6f 29 20 20 28 73 3a 6c 6f 67 20 22 69 2f 6f 20 o) (s:log "i/o
7580: 65 72 72 6f 72 22 29 29 0a 09 09 09 09 20 20 20 error")).....
7590: 20 28 28 65 78 6e 20 29 20 20 20 20 20 28 73 3a ((exn ) (s:
75a0: 6c 6f 67 20 22 41 63 74 69 6f 6e 20 6e 6f 74 20 log "Action not
75b0: 69 6d 70 6c 65 6d 65 6e 74 65 64 3a 20 22 20 70 implemented: " p
75c0: 72 6f 63 2d 6e 61 6d 65 20 22 20 61 63 74 69 6f roc-name " actio
75d0: 6e 3a 20 22 20 74 61 72 67 2d 61 63 74 69 6f 6e n: " targ-action
75e0: 29 29 0a 09 09 09 09 20 20 20 20 28 76 61 72 20 ))..... (var
75f0: 28 29 20 20 20 20 20 28 73 3a 6c 6f 67 20 22 55 () (s:log "U
7600: 6e 6b 6e 6f 77 6e 20 45 72 72 6f 72 22 29 29 29 nknown Error")))
7610: 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 )))))))..(define
7620: 20 28 73 65 73 73 69 6f 6e 3a 6e 65 76 65 72 2d (session:never-
7630: 63 61 6c 6c 65 64 2d 70 61 67 65 3f 20 73 65 6c called-page? sel
7640: 66 20 70 61 67 65 29 0a 20 20 28 73 65 73 73 69 f page). (sessi
7650: 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 43 68 65 on:log self "Che
7660: 63 6b 69 6e 67 20 66 6f 72 20 70 61 67 65 3a 20 cking for page:
7670: 22 20 70 61 67 65 29 0a 20 20 28 6e 6f 74 20 28 " page). (not (
7680: 6d 65 6d 62 65 72 20 70 61 67 65 20 28 73 64 61 member page (sda
7690: 74 2d 67 65 74 2d 73 65 65 6e 2d 70 61 67 65 73 t-get-seen-pages
76a0: 20 73 65 6c 66 29 29 29 29 0a 0a 28 64 65 66 69 self))))..(defi
76b0: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 2d ne (session:set-
76c0: 63 61 6c 6c 65 64 21 20 73 65 6c 66 20 70 61 67 called! self pag
76d0: 65 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 73 e). (sdat-set-s
76e0: 65 65 6e 2d 70 61 67 65 73 21 20 73 65 6c 66 20 een-pages! self
76f0: 28 63 6f 6e 73 20 70 61 67 65 20 28 73 64 61 74 (cons page (sdat
7700: 2d 67 65 74 2d 73 65 65 6e 2d 70 61 67 65 73 20 -get-seen-pages
7710: 73 65 6c 66 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d self))))..;;====
7720: 3d 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 0a 3b 3b 20 41 6c 74 65 72 6e 61 74 69 76 ==.;; Alternativ
7770: 65 20 64 61 74 61 20 74 79 70 65 20 64 65 6c 69 e data type deli
7780: 76 65 72 79 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d very.;;=========
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 0a 0a 28 =============..(
77d0: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
77e0: 61 6c 74 2d 6f 75 74 20 73 65 6c 66 29 0a 20 20 alt-out self).
77f0: 28 6c 65 74 20 28 28 64 61 74 20 28 73 64 61 74 (let ((dat (sdat
7800: 2d 67 65 74 2d 61 6c 74 2d 70 61 67 65 2d 64 61 -get-alt-page-da
7810: 74 20 73 65 6c 66 29 29 29 0a 20 20 20 20 3b 3b t self))). ;;
7820: 20 28 73 3a 6c 6f 67 20 22 64 61 74 20 69 73 3a (s:log "dat is:
7830: 20 22 20 64 61 74 29 0a 20 20 20 20 3b 3b 20 28 " dat). ;; (
7840: 70 72 69 6e 74 20 22 48 54 54 50 2f 31 2e 31 20 print "HTTP/1.1
7850: 32 30 30 20 4f 4b 22 29 0a 20 20 20 20 28 70 72 200 OK"). (pr
7860: 69 6e 74 20 22 44 61 74 65 3a 20 22 20 28 74 69 int "Date: " (ti
7870: 6d 65 2d 3e 73 74 72 69 6e 67 20 28 73 65 63 6f me->string (seco
7880: 6e 64 73 2d 3e 75 74 63 2d 74 69 6d 65 20 28 63 nds->utc-time (c
7890: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 urrent-seconds))
78a0: 29 29 0a 20 20 20 20 28 70 72 69 6e 74 20 22 43 )). (print "C
78b0: 6f 6e 74 65 6e 74 2d 54 79 70 65 3a 20 22 20 28 ontent-Type: " (
78c0: 73 64 61 74 2d 67 65 74 2d 63 6f 6e 74 65 6e 74 sdat-get-content
78d0: 2d 74 79 70 65 20 73 65 6c 66 29 29 0a 20 20 20 -type self)).
78e0: 20 28 70 72 69 6e 74 20 22 41 63 63 65 70 74 2d (print "Accept-
78f0: 52 61 6e 67 65 73 3a 20 62 79 74 65 73 22 29 0a Ranges: bytes").
7900: 20 20 20 20 28 70 72 69 6e 74 20 22 43 6f 6e 74 (print "Cont
7910: 65 6e 74 2d 4c 65 6e 67 74 68 3a 20 22 20 28 69 ent-Length: " (i
7920: 66 20 28 62 6c 6f 62 3f 20 64 61 74 29 0a 09 09 f (blob? dat)...
7930: 09 09 20 20 28 62 6c 6f 62 2d 73 69 7a 65 20 64 .. (blob-size d
7940: 61 74 29 0a 09 09 09 09 20 20 30 29 29 0a 20 20 at)..... 0)).
7950: 20 20 28 70 72 69 6e 74 20 22 4b 65 65 70 2d 41 (print "Keep-A
7960: 6c 69 76 65 3a 20 74 69 6d 65 6f 75 74 3d 31 35 live: timeout=15
7970: 2c 20 6d 61 78 3d 31 30 30 22 29 0a 20 20 20 20 , max=100").
7980: 28 70 72 69 6e 74 20 22 43 6f 6e 6e 65 63 74 69 (print "Connecti
7990: 6f 6e 3a 20 4b 65 65 70 2d 41 6c 69 76 65 22 29 on: Keep-Alive")
79a0: 0a 20 20 20 20 28 70 72 69 6e 74 20 22 22 29 0a . (print "").
79b0: 20 20 20 20 28 77 72 69 74 65 2d 73 74 72 69 6e (write-strin
79c0: 67 20 28 62 6c 6f 62 2d 3e 73 74 72 69 6e 67 20 g (blob->string
79d0: 64 61 74 29 20 23 66 20 28 63 75 72 72 65 6e 74 dat) #f (current
79e0: 2d 6f 75 74 70 75 74 2d 70 6f 72 74 29 29 29 29 -output-port))))
79f0: 0a .