Artifact
e1ef9f09551d2c97198314fd82819b0c9dca6c58:
0000: 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 30 ;; Copyright 200
0010: 37 2d 32 30 30 38 2c 20 4d 61 74 74 68 65 77 20 7-2008, Matthew
0020: 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b 20 Welland..;; .;;
0030: 20 54 68 69 73 20 70 72 6f 67 72 61 6d 20 69 73 This program is
0040: 20 6d 61 64 65 20 61 76 61 69 6c 61 62 6c 65 20 made available
0050: 75 6e 64 65 72 20 74 68 65 20 47 4e 55 20 47 50 under the GNU GP
0060: 4c 20 76 65 72 73 69 6f 6e 20 32 2e 30 20 6f 72 L version 2.0 or
0070: 0a 3b 3b 20 20 67 72 65 61 74 65 72 2e 20 53 65 .;; greater. Se
0080: 65 20 74 68 65 20 61 63 63 6f 6d 70 61 6e 79 69 e the accompanyi
0090: 6e 67 20 66 69 6c 65 20 43 4f 50 59 49 4e 47 20 ng file COPYING
00a0: 66 6f 72 20 64 65 74 61 69 6c 73 2e 0a 3b 3b 20 for details..;;
00b0: 0a 3b 3b 20 20 54 68 69 73 20 70 72 6f 67 72 61 .;; This progra
00c0: 6d 20 69 73 20 64 69 73 74 72 69 62 75 74 65 64 m is distributed
00d0: 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 52 WITHOUT ANY WAR
00e0: 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 65 RANTY; without e
00f0: 76 65 6e 20 74 68 65 0a 3b 3b 20 20 69 6d 70 6c ven the.;; impl
0100: 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 20 ied warranty of
0110: 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 20 MERCHANTABILITY
0120: 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 41 or FITNESS FOR A
0130: 20 50 41 52 54 49 43 55 4c 41 52 0a 3b 3b 20 20 PARTICULAR.;;
0140: 50 55 52 50 4f 53 45 2e 0a 0a 28 69 6e 63 6c 75 PURPOSE...(inclu
0150: 64 65 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 de "requirements
0160: 2e 73 63 6d 22 29 0a 0a 3b 3b 20 73 65 73 73 69 .scm")..;; sessi
0170: 6f 6e 73 20 74 61 62 6c 65 0a 3b 3b 20 69 64 20 ons table.;; id
0180: 73 65 73 73 69 6f 6e 5f 69 64 20 73 65 73 73 69 session_id sessi
0190: 6f 6e 5f 6b 65 79 0a 3b 3b 20 63 72 65 61 74 65 on_key.;; create
01a0: 20 74 61 62 6c 65 20 73 65 73 73 69 6f 6e 73 20 table sessions
01b0: 28 69 64 20 73 65 72 69 61 6c 20 6e 6f 74 20 6e (id serial not n
01c0: 75 6c 6c 2c 73 65 73 73 69 6f 6e 2d 6b 65 79 20 ull,session-key
01d0: 74 65 78 74 29 3b 0a 0a 3b 3b 20 73 65 73 73 69 text);..;; sessi
01e0: 6f 6e 5f 76 61 72 73 20 74 61 62 6c 65 0a 3b 3b on_vars table.;;
01f0: 20 69 64 20 73 65 73 73 69 6f 6e 5f 69 64 20 70 id session_id p
0200: 61 67 65 5f 69 64 20 6b 65 79 20 76 61 6c 75 65 age_id key value
0210: 0a 3b 3b 20 63 72 65 61 74 65 20 74 61 62 6c 65 .;; create table
0220: 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 28 69 session_vars (i
0230: 64 20 73 65 72 69 61 6c 20 6e 6f 74 20 6e 75 6c d serial not nul
0240: 6c 2c 73 65 73 73 69 6f 6e 5f 69 64 20 69 6e 74 l,session_id int
0250: 65 67 65 72 2c 70 61 67 65 20 74 65 78 74 2c 6b eger,page text,k
0260: 65 79 20 74 65 78 74 2c 76 61 6c 75 65 20 74 65 ey text,value te
0270: 78 74 29 3b 0a 0a 3b 3b 20 54 4f 44 4f 0a 3b 3b xt);..;; TODO.;;
0280: 20 20 43 6f 6e 63 65 70 74 20 6f 66 20 6f 72 64 Concept of ord
0290: 65 72 20 6e 75 6d 20 69 6e 63 72 65 6d 65 6e 74 er num increment
02a0: 65 64 20 77 69 74 68 20 65 61 63 68 20 70 61 67 ed with each pag
02b0: 65 20 61 63 63 65 73 73 0a 3b 3b 20 20 20 20 20 e access.;;
02c0: 69 66 20 61 20 62 72 61 6e 63 68 20 69 73 20 74 if a branch is t
02d0: 61 6b 65 6e 20 74 68 65 6e 20 61 20 6e 65 77 20 aken then a new
02e0: 73 65 73 73 69 6f 6e 20 77 6f 75 6c 64 20 6e 65 session would ne
02f0: 65 64 20 74 6f 20 62 65 20 63 72 65 61 74 65 64 ed to be created
0300: 0a 3b 3b 0a 0a 3b 3b 20 6d 61 6b 65 2d 76 65 63 .;;..;; make-vec
0310: 74 6f 72 2d 72 65 63 6f 72 64 20 73 65 73 73 69 tor-record sessi
0320: 6f 6e 20 73 65 73 73 69 6f 6e 20 64 62 74 79 70 on session dbtyp
0330: 65 20 64 62 69 6e 69 74 20 63 6f 6e 6e 20 70 61 e dbinit conn pa
0340: 72 61 6d 73 20 70 61 74 68 2d 70 61 72 61 6d 73 rams path-params
0350: 20 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 73 session-key ses
0360: 73 69 6f 6e 2d 69 64 20 64 6f 6d 61 69 6e 20 74 sion-id domain t
0370: 6f 70 70 61 67 65 20 70 61 67 65 20 63 75 72 72 oppage page curr
0380: 2d 70 61 67 65 20 63 6f 6e 74 65 6e 74 2d 74 79 -page content-ty
0390: 70 65 20 70 61 67 65 2d 74 79 70 65 20 73 72 6f pe page-type sro
03a0: 6f 74 20 74 77 69 6b 69 64 69 72 20 70 61 67 65 ot twikidir page
03b0: 64 61 74 20 61 6c 74 2d 70 61 67 65 2d 64 61 74 dat alt-page-dat
03c0: 20 70 61 67 65 76 61 72 73 20 70 61 67 65 76 61 pagevars pageva
03d0: 72 73 2d 62 65 66 6f 72 65 20 73 65 73 73 69 6f rs-before sessio
03e0: 6e 76 61 72 73 20 73 65 73 73 69 6f 6e 76 61 72 nvars sessionvar
03f0: 73 2d 62 65 66 6f 72 65 20 67 6c 6f 62 61 6c 76 s-before globalv
0400: 61 72 73 20 67 6c 6f 62 61 6c 76 61 72 73 2d 62 ars globalvars-b
0410: 65 66 6f 72 65 20 6c 6f 67 70 74 20 66 6f 72 6d efore logpt form
0420: 64 61 74 20 72 65 71 75 65 73 74 2d 6d 65 74 68 dat request-meth
0430: 6f 64 20 73 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 od session-cooki
0440: 65 20 63 75 72 72 2d 65 72 72 20 6c 6f 67 2d 70 e curr-err log-p
0450: 6f 72 74 20 6c 6f 67 66 69 6c 65 20 73 65 65 6e ort logfile seen
0460: 2d 70 61 67 65 73 20 70 61 67 65 2d 64 69 72 2d -pages page-dir-
0470: 73 74 79 6c 65 20 64 65 62 75 67 6d 6f 64 65 0a style debugmode.
0480: 28 64 65 66 69 6e 65 20 28 6d 61 6b 65 2d 73 64 (define (make-sd
0490: 61 74 29 28 6d 61 6b 65 2d 76 65 63 74 6f 72 20 at)(make-vector
04a0: 33 33 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 33)).(define (sd
04b0: 61 74 2d 67 65 74 2d 64 62 74 79 70 65 20 20 20 at-get-dbtype
04c0: 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 29 vec)
04d0: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
04e0: 20 76 65 63 20 30 29 29 0a 28 64 65 66 69 6e 65 vec 0)).(define
04f0: 20 28 73 64 61 74 2d 67 65 74 2d 64 62 69 6e 69 (sdat-get-dbini
0500: 74 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 t
0510: 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d vec) (vector-
0520: 72 65 66 20 20 76 65 63 20 31 29 29 0a 28 64 65 ref vec 1)).(de
0530: 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 63 fine (sdat-get-c
0540: 6f 6e 6e 20 20 20 20 20 20 20 20 20 20 20 20 20 onn
0550: 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 vec) (vec
0560: 74 6f 72 2d 72 65 66 20 20 76 65 63 20 32 29 29 tor-ref vec 2))
0570: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 .(define (sdat-g
0580: 65 74 2d 70 61 72 61 6d 73 20 20 20 20 20 20 20 et-params
0590: 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 vec)
05a0: 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 (vector-ref vec
05b0: 20 33 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 3)).(define (sd
05c0: 61 74 2d 67 65 74 2d 70 61 74 68 2d 70 61 72 61 at-get-path-para
05d0: 6d 73 20 20 20 20 20 20 20 20 20 20 76 65 63 29 ms vec)
05e0: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
05f0: 20 76 65 63 20 34 29 29 0a 28 64 65 66 69 6e 65 vec 4)).(define
0600: 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 (sdat-get-sessi
0610: 6f 6e 2d 6b 65 79 20 20 20 20 20 20 20 20 20 20 on-key
0620: 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d vec) (vector-
0630: 72 65 66 20 20 76 65 63 20 35 29 29 0a 28 64 65 ref vec 5)).(de
0640: 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 73 fine (sdat-get-s
0650: 65 73 73 69 6f 6e 2d 69 64 20 20 20 20 20 20 20 ession-id
0660: 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 vec) (vec
0670: 74 6f 72 2d 72 65 66 20 20 76 65 63 20 36 29 29 tor-ref vec 6))
0680: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 .(define (sdat-g
0690: 65 74 2d 64 6f 6d 61 69 6e 20 20 20 20 20 20 20 et-domain
06a0: 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 vec)
06b0: 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 (vector-ref vec
06c0: 20 37 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 7)).(define (sd
06d0: 61 74 2d 67 65 74 2d 74 6f 70 70 61 67 65 20 20 at-get-toppage
06e0: 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 29 vec)
06f0: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
0700: 20 76 65 63 20 38 29 29 0a 28 64 65 66 69 6e 65 vec 8)).(define
0710: 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 20 (sdat-get-page
0720: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0730: 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d vec) (vector-
0740: 72 65 66 20 20 76 65 63 20 39 29 29 0a 28 64 65 ref vec 9)).(de
0750: 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 63 fine (sdat-get-c
0760: 75 72 72 2d 70 61 67 65 20 20 20 20 20 20 20 20 urr-page
0770: 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 vec) (vec
0780: 74 6f 72 2d 72 65 66 20 20 76 65 63 20 31 30 29 tor-ref vec 10)
0790: 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d ).(define (sdat-
07a0: 67 65 74 2d 63 6f 6e 74 65 6e 74 2d 74 79 70 65 get-content-type
07b0: 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 vec)
07c0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 (vector-ref ve
07d0: 63 20 31 31 29 29 0a 28 64 65 66 69 6e 65 20 28 c 11)).(define (
07e0: 73 64 61 74 2d 67 65 74 2d 70 61 67 65 2d 74 79 sdat-get-page-ty
07f0: 70 65 20 20 20 20 20 20 20 20 20 20 20 20 76 65 pe ve
0800: 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 c) (vector-re
0810: 66 20 20 76 65 63 20 31 32 29 29 0a 28 64 65 66 f vec 12)).(def
0820: 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 73 72 ine (sdat-get-sr
0830: 6f 6f 74 20 20 20 20 20 20 20 20 20 20 20 20 20 oot
0840: 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 vec) (vect
0850: 6f 72 2d 72 65 66 20 20 76 65 63 20 31 33 29 29 or-ref vec 13))
0860: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 .(define (sdat-g
0870: 65 74 2d 74 77 69 6b 69 64 69 72 20 20 20 20 20 et-twikidir
0880: 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 vec)
0890: 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 (vector-ref vec
08a0: 20 31 34 29 29 0a 28 64 65 66 69 6e 65 20 28 73 14)).(define (s
08b0: 64 61 74 2d 67 65 74 2d 70 61 67 65 64 61 74 20 dat-get-pagedat
08c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 vec
08d0: 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 ) (vector-ref
08e0: 20 20 76 65 63 20 31 35 29 29 0a 28 64 65 66 69 vec 15)).(defi
08f0: 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 61 6c 74 ne (sdat-get-alt
0900: 2d 70 61 67 65 2d 64 61 74 20 20 20 20 20 20 20 -page-dat
0910: 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f vec) (vecto
0920: 72 2d 72 65 66 20 20 76 65 63 20 31 36 29 29 0a r-ref vec 16)).
0930: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 (define (sdat-ge
0940: 74 2d 70 61 67 65 76 61 72 73 20 20 20 20 20 20 t-pagevars
0950: 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 vec) (
0960: 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 vector-ref vec
0970: 31 37 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 17)).(define (sd
0980: 61 74 2d 67 65 74 2d 70 61 67 65 76 61 72 73 2d at-get-pagevars-
0990: 62 65 66 6f 72 65 20 20 20 20 20 20 76 65 63 29 before vec)
09a0: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
09b0: 20 76 65 63 20 31 38 29 29 0a 28 64 65 66 69 6e vec 18)).(defin
09c0: 65 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 e (sdat-get-sess
09d0: 69 6f 6e 76 61 72 73 20 20 20 20 20 20 20 20 20 ionvars
09e0: 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 vec) (vector
09f0: 2d 72 65 66 20 20 76 65 63 20 31 39 29 29 0a 28 -ref vec 19)).(
0a00: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 define (sdat-get
0a10: 2d 73 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 -sessionvars-bef
0a20: 6f 72 65 20 20 20 76 65 63 29 20 20 20 20 28 76 ore vec) (v
0a30: 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 32 ector-ref vec 2
0a40: 30 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 0)).(define (sda
0a50: 74 2d 67 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 t-get-globalvars
0a60: 20 20 20 20 20 20 20 20 20 20 20 76 65 63 29 20 vec)
0a70: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 (vector-ref
0a80: 76 65 63 20 32 31 29 29 0a 28 64 65 66 69 6e 65 vec 21)).(define
0a90: 20 28 73 64 61 74 2d 67 65 74 2d 67 6c 6f 62 61 (sdat-get-globa
0aa0: 6c 76 61 72 73 2d 62 65 66 6f 72 65 20 20 20 20 lvars-before
0ab0: 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d vec) (vector-
0ac0: 72 65 66 20 20 76 65 63 20 32 32 29 29 0a 28 64 ref vec 22)).(d
0ad0: 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d efine (sdat-get-
0ae0: 6c 6f 67 70 74 20 20 20 20 20 20 20 20 20 20 20 logpt
0af0: 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 vec) (ve
0b00: 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 32 33 ctor-ref vec 23
0b10: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
0b20: 2d 67 65 74 2d 66 6f 72 6d 64 61 74 20 20 20 20 -get-formdat
0b30: 20 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 vec)
0b40: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 (vector-ref v
0b50: 65 63 20 32 34 29 29 0a 28 64 65 66 69 6e 65 20 ec 24)).(define
0b60: 28 73 64 61 74 2d 67 65 74 2d 72 65 71 75 65 73 (sdat-get-reques
0b70: 74 2d 6d 65 74 68 6f 64 20 20 20 20 20 20 20 76 t-method v
0b80: 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 ec) (vector-r
0b90: 65 66 20 20 76 65 63 20 32 35 29 29 0a 28 64 65 ef vec 25)).(de
0ba0: 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 73 fine (sdat-get-s
0bb0: 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 20 20 20 ession-cookie
0bc0: 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 vec) (vec
0bd0: 74 6f 72 2d 72 65 66 20 20 76 65 63 20 32 36 29 tor-ref vec 26)
0be0: 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d ).(define (sdat-
0bf0: 67 65 74 2d 63 75 72 72 2d 65 72 72 20 20 20 20 get-curr-err
0c00: 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 vec)
0c10: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 (vector-ref ve
0c20: 63 20 32 37 29 29 0a 28 64 65 66 69 6e 65 20 28 c 27)).(define (
0c30: 73 64 61 74 2d 67 65 74 2d 6c 6f 67 2d 70 6f 72 sdat-get-log-por
0c40: 74 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 t ve
0c50: 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 c) (vector-re
0c60: 66 20 20 76 65 63 20 32 38 29 29 0a 28 64 65 66 f vec 28)).(def
0c70: 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 6c 6f ine (sdat-get-lo
0c80: 67 66 69 6c 65 20 20 20 20 20 20 20 20 20 20 20 gfile
0c90: 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 vec) (vect
0ca0: 6f 72 2d 72 65 66 20 20 76 65 63 20 32 39 29 29 or-ref vec 29))
0cb0: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 .(define (sdat-g
0cc0: 65 74 2d 73 65 65 6e 2d 70 61 67 65 73 20 20 20 et-seen-pages
0cd0: 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 vec)
0ce0: 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 (vector-ref vec
0cf0: 20 33 30 29 29 0a 28 64 65 66 69 6e 65 20 28 73 30)).(define (s
0d00: 64 61 74 2d 67 65 74 2d 70 61 67 65 2d 64 69 72 dat-get-page-dir
0d10: 2d 73 74 79 6c 65 20 20 20 20 20 20 20 76 65 63 -style vec
0d20: 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 ) (vector-ref
0d30: 20 20 76 65 63 20 33 31 29 29 0a 28 64 65 66 69 vec 31)).(defi
0d40: 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 64 65 62 ne (sdat-get-deb
0d50: 75 67 6d 6f 64 65 20 20 20 20 20 20 20 20 20 20 ugmode
0d60: 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f vec) (vecto
0d70: 72 2d 72 65 66 20 20 76 65 63 20 33 32 29 29 0a r-ref vec 32)).
0d80: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 (define (sdat-se
0d90: 74 2d 64 62 74 79 70 65 21 20 20 20 20 20 20 20 t-dbtype!
0da0: 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 vec val)(
0db0: 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 vector-set! vec
0dc0: 30 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 0 val)).(define
0dd0: 28 73 64 61 74 2d 73 65 74 2d 64 62 69 6e 69 74 (sdat-set-dbinit
0de0: 21 20 20 20 20 20 20 20 20 20 20 20 20 20 20 76 ! v
0df0: 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 ec val)(vector-s
0e00: 65 74 21 20 76 65 63 20 31 20 76 61 6c 29 29 0a et! vec 1 val)).
0e10: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 (define (sdat-se
0e20: 74 2d 63 6f 6e 6e 21 20 20 20 20 20 20 20 20 20 t-conn!
0e30: 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 vec val)(
0e40: 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 vector-set! vec
0e50: 32 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 2 val)).(define
0e60: 28 73 64 61 74 2d 73 65 74 2d 70 61 72 61 6d 73 (sdat-set-params
0e70: 21 20 20 20 20 20 20 20 20 20 20 20 20 20 20 76 ! v
0e80: 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 ec val)(vector-s
0e90: 65 74 21 20 76 65 63 20 33 20 76 61 6c 29 29 0a et! vec 3 val)).
0ea0: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 (define (sdat-se
0eb0: 74 2d 70 61 74 68 2d 70 61 72 61 6d 73 21 20 20 t-path-params!
0ec0: 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 vec val)(
0ed0: 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 vector-set! vec
0ee0: 34 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 4 val)).(define
0ef0: 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f (sdat-set-sessio
0f00: 6e 2d 6b 65 79 21 20 20 20 20 20 20 20 20 20 76 n-key! v
0f10: 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 ec val)(vector-s
0f20: 65 74 21 20 76 65 63 20 35 20 76 61 6c 29 29 0a et! vec 5 val)).
0f30: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 (define (sdat-se
0f40: 74 2d 73 65 73 73 69 6f 6e 2d 69 64 21 20 20 20 t-session-id!
0f50: 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 vec val)(
0f60: 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 vector-set! vec
0f70: 36 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 6 val)).(define
0f80: 28 73 64 61 74 2d 73 65 74 2d 64 6f 6d 61 69 6e (sdat-set-domain
0f90: 21 20 20 20 20 20 20 20 20 20 20 20 20 20 20 76 ! v
0fa0: 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 ec val)(vector-s
0fb0: 65 74 21 20 76 65 63 20 37 20 76 61 6c 29 29 0a et! vec 7 val)).
0fc0: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 (define (sdat-se
0fd0: 74 2d 74 6f 70 70 61 67 65 21 20 20 20 20 20 20 t-toppage!
0fe0: 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 vec val)(
0ff0: 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 vector-set! vec
1000: 38 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 8 val)).(define
1010: 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 21 20 (sdat-set-page!
1020: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 76 v
1030: 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 ec val)(vector-s
1040: 65 74 21 20 76 65 63 20 39 20 76 61 6c 29 29 0a et! vec 9 val)).
1050: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 (define (sdat-se
1060: 74 2d 63 75 72 72 2d 70 61 67 65 21 20 20 20 20 t-curr-page!
1070: 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 vec val)(
1080: 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 vector-set! vec
1090: 31 30 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 10 val)).(define
10a0: 20 28 73 64 61 74 2d 73 65 74 2d 63 6f 6e 74 65 (sdat-set-conte
10b0: 6e 74 2d 74 79 70 65 21 20 20 20 20 20 20 20 20 nt-type!
10c0: 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d vec val)(vector-
10d0: 73 65 74 21 20 76 65 63 20 31 31 20 76 61 6c 29 set! vec 11 val)
10e0: 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d ).(define (sdat-
10f0: 73 65 74 2d 70 61 67 65 2d 74 79 70 65 21 20 20 set-page-type!
1100: 20 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c vec val
1110: 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 )(vector-set! ve
1120: 63 20 31 32 20 76 61 6c 29 29 0a 28 64 65 66 69 c 12 val)).(defi
1130: 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 73 72 6f ne (sdat-set-sro
1140: 6f 74 21 20 20 20 20 20 20 20 20 20 20 20 20 20 ot!
1150: 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f vec val)(vecto
1160: 72 2d 73 65 74 21 20 76 65 63 20 31 33 20 76 61 r-set! vec 13 va
1170: 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 l)).(define (sda
1180: 74 2d 73 65 74 2d 74 77 69 6b 69 64 69 72 21 20 t-set-twikidir!
1190: 20 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 vec v
11a0: 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 al)(vector-set!
11b0: 76 65 63 20 31 34 20 76 61 6c 29 29 0a 28 64 65 vec 14 val)).(de
11c0: 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 70 fine (sdat-set-p
11d0: 61 67 65 64 61 74 21 20 20 20 20 20 20 20 20 20 agedat!
11e0: 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 vec val)(vec
11f0: 74 6f 72 2d 73 65 74 21 20 76 65 63 20 31 35 20 tor-set! vec 15
1200: 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 val)).(define (s
1210: 64 61 74 2d 73 65 74 2d 61 6c 74 2d 70 61 67 65 dat-set-alt-page
1220: 2d 64 61 74 21 20 20 20 20 20 20 20 20 76 65 63 -dat! vec
1230: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
1240: 21 20 76 65 63 20 31 36 20 76 61 6c 29 29 0a 28 ! vec 16 val)).(
1250: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 define (sdat-set
1260: 2d 70 61 67 65 76 61 72 73 21 20 20 20 20 20 20 -pagevars!
1270: 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 vec val)(v
1280: 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 31 ector-set! vec 1
1290: 37 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 7 val)).(define
12a0: 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 76 61 (sdat-set-pageva
12b0: 72 73 2d 62 65 66 6f 72 65 21 20 20 20 20 20 76 rs-before! v
12c0: 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 ec val)(vector-s
12d0: 65 74 21 20 76 65 63 20 31 38 20 76 61 6c 29 29 et! vec 18 val))
12e0: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 .(define (sdat-s
12f0: 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 21 20 et-sessionvars!
1300: 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 vec val)
1310: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 (vector-set! vec
1320: 20 31 39 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 19 val)).(defin
1330: 65 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 e (sdat-set-sess
1340: 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 21 20 ionvars-before!
1350: 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 vec val)(vector
1360: 2d 73 65 74 21 20 76 65 63 20 32 30 20 76 61 6c -set! vec 20 val
1370: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
1380: 2d 73 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 21 -set-globalvars!
1390: 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 61 vec va
13a0: 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 l)(vector-set! v
13b0: 65 63 20 32 31 20 76 61 6c 29 29 0a 28 64 65 66 ec 21 val)).(def
13c0: 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 67 6c ine (sdat-set-gl
13d0: 6f 62 61 6c 76 61 72 73 2d 62 65 66 6f 72 65 21 obalvars-before!
13e0: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
13f0: 6f 72 2d 73 65 74 21 20 76 65 63 20 32 32 20 76 or-set! vec 22 v
1400: 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 al)).(define (sd
1410: 61 74 2d 73 65 74 2d 6c 6f 67 70 74 21 20 20 20 at-set-logpt!
1420: 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 20 vec
1430: 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 val)(vector-set!
1440: 20 76 65 63 20 32 33 20 76 61 6c 29 29 0a 28 64 vec 23 val)).(d
1450: 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d efine (sdat-set-
1460: 66 6f 72 6d 64 61 74 21 20 20 20 20 20 20 20 20 formdat!
1470: 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 vec val)(ve
1480: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 32 34 ctor-set! vec 24
1490: 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 val)).(define (
14a0: 73 64 61 74 2d 73 65 74 2d 72 65 71 75 65 73 74 sdat-set-request
14b0: 2d 6d 65 74 68 6f 64 21 20 20 20 20 20 20 76 65 -method! ve
14c0: 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 c val)(vector-se
14d0: 74 21 20 76 65 63 20 32 35 20 76 61 6c 29 29 0a t! vec 25 val)).
14e0: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 (define (sdat-se
14f0: 74 2d 73 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 t-session-cookie
1500: 21 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 ! vec val)(
1510: 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 vector-set! vec
1520: 32 36 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 26 val)).(define
1530: 20 28 73 64 61 74 2d 73 65 74 2d 63 75 72 72 2d (sdat-set-curr-
1540: 65 72 72 21 20 20 20 20 20 20 20 20 20 20 20 20 err!
1550: 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d vec val)(vector-
1560: 73 65 74 21 20 76 65 63 20 32 37 20 76 61 6c 29 set! vec 27 val)
1570: 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d ).(define (sdat-
1580: 73 65 74 2d 6c 6f 67 2d 70 6f 72 74 21 20 20 20 set-log-port!
1590: 20 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c vec val
15a0: 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 )(vector-set! ve
15b0: 63 20 32 38 20 76 61 6c 29 29 0a 28 64 65 66 69 c 28 val)).(defi
15c0: 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 6c 6f 67 ne (sdat-set-log
15d0: 66 69 6c 65 21 20 20 20 20 20 20 20 20 20 20 20 file!
15e0: 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f vec val)(vecto
15f0: 72 2d 73 65 74 21 20 76 65 63 20 32 39 20 76 61 r-set! vec 29 va
1600: 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 l)).(define (sda
1610: 74 2d 73 65 74 2d 73 65 65 6e 2d 70 61 67 65 73 t-set-seen-pages
1620: 21 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 ! vec v
1630: 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 al)(vector-set!
1640: 76 65 63 20 33 30 20 76 61 6c 29 29 0a 28 64 65 vec 30 val)).(de
1650: 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 70 fine (sdat-set-p
1660: 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 21 20 20 age-dir-style!
1670: 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 vec val)(vec
1680: 74 6f 72 2d 73 65 74 21 20 76 65 63 20 33 31 20 tor-set! vec 31
1690: 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 val)).(define (s
16a0: 64 61 74 2d 73 65 74 2d 64 65 62 75 67 6d 6f 64 dat-set-debugmod
16b0: 65 21 20 20 20 20 20 20 20 20 20 20 20 76 65 63 e! vec
16c0: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
16d0: 21 20 76 65 63 20 33 32 20 76 61 6c 29 29 0a 0a ! vec 32 val))..
16e0: 3b 3b 20 28 64 65 66 69 6e 65 2d 63 6c 61 73 73 ;; (define-class
16f0: 20 3c 73 65 73 73 69 6f 6e 3e 20 28 29 0a 3b 3b <session> ().;;
1700: 20 20 20 28 64 62 74 79 70 65 20 20 20 20 20 20 (dbtype
1710: 20 3b 3b 20 27 70 67 20 6f 72 20 27 73 71 6c 69 ;; 'pg or 'sqli
1720: 74 65 33 0a 3b 3b 20 20 20 20 64 62 69 6e 69 74 te3.;; dbinit
1730: 0a 3b 3b 20 20 20 20 63 6f 6e 6e 0a 3b 3b 20 20 .;; conn.;;
1740: 20 20 70 61 72 61 6d 73 20 20 20 20 20 20 20 3b params ;
1750: 3b 20 70 61 72 61 6d 73 20 66 72 6f 6d 20 74 68 ; params from th
1760: 65 20 6b 65 79 3d 76 61 6c 26 6b 65 79 31 3d 76 e key=val&key1=v
1770: 61 6c 32 20 73 74 72 69 6e 67 0a 3b 3b 20 20 20 al2 string.;;
1780: 20 70 61 74 68 2d 70 61 72 61 6d 73 20 20 3b 3b path-params ;;
1790: 20 72 65 6d 61 69 6e 69 6e 67 20 70 61 72 61 6d remaining param
17a0: 73 20 66 72 6f 6d 20 74 68 65 20 70 61 74 68 0a s from the path.
17b0: 3b 3b 20 20 20 20 73 65 73 73 69 6f 6e 2d 6b 65 ;; session-ke
17c0: 79 0a 3b 3b 20 20 20 20 73 65 73 73 69 6f 6e 2d y.;; session-
17d0: 69 64 0a 3b 3b 20 20 20 20 64 6f 6d 61 69 6e 0a id.;; domain.
17e0: 3b 3b 20 20 20 20 74 6f 70 70 61 67 65 20 20 20 ;; toppage
17f0: 20 20 20 3b 3b 20 64 65 66 61 75 6c 74 73 20 74 ;; defaults t
1800: 6f 20 22 69 6e 64 65 78 22 20 2d 20 6f 76 65 72 o "index" - over
1810: 72 69 64 65 20 69 6e 20 2e 73 74 6d 6c 2e 63 6f ride in .stml.co
1820: 6e 66 69 67 20 69 66 20 64 65 73 69 72 65 64 0a nfig if desired.
1830: 3b 3b 20 20 20 20 70 61 67 65 20 20 20 20 20 20 ;; page
1840: 20 20 20 3b 3b 20 74 68 65 20 70 61 67 65 20 6e ;; the page n
1850: 61 6d 65 20 2d 20 64 65 66 61 75 6c 74 73 20 74 ame - defaults t
1860: 6f 20 68 6f 6d 65 0a 3b 3b 20 20 20 20 63 75 72 o home.;; cur
1870: 72 2d 70 61 67 65 20 20 20 20 3b 3b 20 74 68 65 r-page ;; the
1880: 20 63 75 72 72 65 6e 74 20 70 61 67 65 20 62 65 current page be
1890: 69 6e 67 20 65 76 61 6c 75 61 74 65 64 0a 3b 3b ing evaluated.;;
18a0: 20 20 20 20 63 6f 6e 74 65 6e 74 2d 74 79 70 65 content-type
18b0: 20 3b 3b 20 74 68 65 20 64 65 66 61 75 6c 74 20 ;; the default
18c0: 63 6f 6e 74 65 6e 74 20 74 79 70 65 20 69 73 20 content type is
18d0: 74 65 78 74 2f 68 74 6d 6c 2c 20 6f 76 65 72 72 text/html, overr
18e0: 69 64 65 20 74 6f 20 64 65 6c 69 76 65 72 20 6f ide to deliver o
18f0: 74 68 65 72 20 73 74 75 66 66 0a 3b 3b 20 20 20 ther stuff.;;
1900: 20 70 61 67 65 2d 74 79 70 65 20 20 20 20 3b 3b page-type ;;
1910: 20 75 73 65 20 69 6e 20 63 6f 6e 6a 75 6e 63 74 use in conjunct
1920: 69 6f 6e 20 77 69 74 68 20 63 6f 6e 74 65 6e 74 ion with content
1930: 2d 74 79 70 65 20 74 6f 20 64 65 6c 69 76 65 72 -type to deliver
1940: 20 6f 74 68 65 72 20 70 61 79 6c 6f 61 64 73 0a other payloads.
1950: 3b 3b 20 20 20 20 73 72 6f 6f 74 0a 3b 3b 20 20 ;; sroot.;;
1960: 20 20 74 77 69 6b 69 64 69 72 20 20 20 20 20 3b twikidir ;
1970: 3b 20 6c 6f 63 61 74 69 6f 6e 20 66 6f 72 20 74 ; location for t
1980: 77 69 6b 69 73 20 2d 20 6e 65 65 64 73 20 74 6f wikis - needs to
1990: 20 62 65 20 66 75 6c 6c 79 20 77 72 69 74 61 62 be fully writab
19a0: 6c 65 20 62 79 20 77 65 62 20 73 65 72 76 65 72 le by web server
19b0: 0a 3b 3b 20 20 20 20 70 61 67 65 64 61 74 0a 3b .;; pagedat.;
19c0: 3b 20 20 20 20 61 6c 74 2d 70 61 67 65 2d 64 61 ; alt-page-da
19d0: 74 0a 3b 3b 20 20 20 20 70 61 67 65 76 61 72 73 t.;; pagevars
19e0: 20 20 20 20 20 3b 3b 20 73 65 73 73 69 6f 6e 20 ;; session
19f0: 76 61 72 73 20 73 70 65 63 69 66 69 63 20 74 6f vars specific to
1a00: 20 74 68 69 73 20 70 61 67 65 0a 3b 3b 20 20 20 this page.;;
1a10: 20 70 61 67 65 76 61 72 73 2d 62 65 66 6f 72 65 pagevars-before
1a20: 0a 3b 3b 20 20 20 20 73 65 73 73 69 6f 6e 76 61 .;; sessionva
1a30: 72 73 20 20 3b 3b 20 73 65 73 73 69 6f 6e 20 76 rs ;; session v
1a40: 61 72 73 20 76 69 73 69 62 6c 65 20 74 6f 20 61 ars visible to a
1a50: 6c 6c 20 70 61 67 65 73 0a 3b 3b 20 20 20 20 73 ll pages.;; s
1a60: 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 essionvars-befor
1a70: 65 0a 3b 3b 20 20 20 20 67 6c 6f 62 61 6c 76 61 e.;; globalva
1a80: 72 73 20 20 20 3b 3b 20 67 6c 6f 62 61 6c 20 76 rs ;; global v
1a90: 61 72 73 20 76 69 73 69 62 6c 65 20 74 6f 20 61 ars visible to a
1aa0: 6c 6c 20 73 65 73 73 69 6f 6e 73 0a 3b 3b 20 20 ll sessions.;;
1ab0: 20 20 67 6c 6f 62 61 6c 76 61 72 73 2d 62 65 66 globalvars-bef
1ac0: 6f 72 65 0a 3b 3b 20 20 20 20 6c 6f 67 70 74 0a ore.;; logpt.
1ad0: 3b 3b 20 20 20 20 66 6f 72 6d 64 61 74 0a 3b 3b ;; formdat.;;
1ae0: 20 20 20 20 72 65 71 75 65 73 74 2d 6d 65 74 68 request-meth
1af0: 6f 64 0a 3b 3b 20 20 20 20 73 65 73 73 69 6f 6e od.;; session
1b00: 2d 63 6f 6f 6b 69 65 0a 3b 3b 20 20 20 20 63 75 -cookie.;; cu
1b10: 72 72 2d 65 72 72 0a 3b 3b 20 20 20 20 6c 6f 67 rr-err.;; log
1b20: 2d 70 6f 72 74 0a 3b 3b 20 20 20 20 6c 6f 67 66 -port.;; logf
1b30: 69 6c 65 0a 3b 3b 20 20 20 20 73 65 65 6e 2d 70 ile.;; seen-p
1b40: 61 67 65 73 0a 3b 3b 20 20 20 20 70 61 67 65 2d ages.;; page-
1b50: 64 69 72 2d 73 74 79 6c 65 20 20 3b 3b 20 23 74 dir-style ;; #t
1b60: 20 3d 20 6e 65 77 20 73 74 79 6c 65 2c 20 23 66 = new style, #f
1b70: 20 3d 20 6f 6c 64 20 73 74 79 6c 65 0a 3b 3b 20 = old style.;;
1b80: 20 20 20 64 65 62 75 67 6d 6f 64 65 29 29 0a 0a debugmode))..
1b90: 3b 3b 20 53 50 4c 49 54 20 49 4e 54 4f 20 53 54 ;; SPLIT INTO ST
1ba0: 52 41 49 47 48 54 20 46 4f 52 57 41 52 44 20 49 RAIGHT FORWARD I
1bb0: 4e 49 54 20 41 4e 44 20 43 4f 4d 50 4c 45 58 20 NIT AND COMPLEX
1bc0: 49 4e 49 54 0a 28 64 65 66 69 6e 65 20 28 73 65 INIT.(define (se
1bd0: 73 73 69 6f 6e 3a 69 6e 69 74 69 61 6c 69 7a 65 ssion:initialize
1be0: 20 73 65 6c 66 29 0a 20 20 28 73 64 61 74 2d 73 self). (sdat-s
1bf0: 65 74 2d 64 62 74 79 70 65 21 20 73 65 6c 66 20 et-dbtype! self
1c00: 20 20 20 20 20 27 70 67 29 0a 20 20 28 73 64 61 'pg). (sda
1c10: 74 2d 73 65 74 2d 70 61 67 65 21 20 73 65 6c 66 t-set-page! self
1c20: 20 20 20 20 20 20 20 20 22 68 6f 6d 65 22 29 20 "home")
1c30: 20 20 20 20 20 20 20 3b 3b 20 74 68 65 73 65 20 ;; these
1c40: 61 72 65 20 64 65 66 61 75 6c 74 73 0a 20 20 28 are defaults. (
1c50: 73 64 61 74 2d 73 65 74 2d 63 75 72 72 2d 70 61 sdat-set-curr-pa
1c60: 67 65 21 20 73 65 6c 66 20 20 20 22 68 6f 6d 65 ge! self "home
1c70: 22 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 63 "). (sdat-set-c
1c80: 6f 6e 74 65 6e 74 2d 74 79 70 65 21 20 73 65 6c ontent-type! sel
1c90: 66 20 22 43 6f 6e 74 65 6e 74 2d 74 79 70 65 3a f "Content-type:
1ca0: 20 74 65 78 74 2f 68 74 6d 6c 3b 20 63 68 61 72 text/html; char
1cb0: 73 65 74 3d 69 73 6f 2d 38 38 35 39 2d 31 5c 6e set=iso-8859-1\n
1cc0: 5c 6e 22 29 0a 20 20 28 73 64 61 74 2d 73 65 74 \n"). (sdat-set
1cd0: 2d 70 61 67 65 2d 74 79 70 65 21 20 73 65 6c 66 -page-type! self
1ce0: 20 20 20 27 68 74 6d 6c 29 0a 20 20 28 73 64 61 'html). (sda
1cf0: 74 2d 73 65 74 2d 74 6f 70 70 61 67 65 21 20 73 t-set-toppage! s
1d00: 65 6c 66 20 20 20 20 20 22 69 6e 64 65 78 22 29 elf "index")
1d10: 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 72 . (sdat-set-par
1d20: 61 6d 73 21 20 73 65 6c 66 20 20 20 20 20 20 27 ams! self '
1d30: 28 29 29 20 20 20 20 20 20 20 20 20 20 20 3b 3b ()) ;;
1d40: 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 74 . (sdat-set-pat
1d50: 68 2d 70 61 72 61 6d 73 21 20 73 65 6c 66 20 27 h-params! self '
1d60: 28 29 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d ()). (sdat-set-
1d70: 73 65 73 73 69 6f 6e 2d 6b 65 79 21 20 73 65 6c session-key! sel
1d80: 66 20 23 66 29 0a 20 20 28 73 64 61 74 2d 73 65 f #f). (sdat-se
1d90: 74 2d 70 61 67 65 64 61 74 21 20 73 65 6c 66 20 t-pagedat! self
1da0: 20 20 20 20 27 28 29 29 0a 20 20 28 73 64 61 74 '()). (sdat
1db0: 2d 73 65 74 2d 61 6c 74 2d 70 61 67 65 2d 64 61 -set-alt-page-da
1dc0: 74 21 20 73 65 6c 66 20 23 66 29 0a 20 20 28 73 t! self #f). (s
1dd0: 64 61 74 2d 73 65 74 2d 73 72 6f 6f 74 21 20 73 dat-set-sroot! s
1de0: 65 6c 66 20 20 20 20 20 20 20 22 2e 2f 22 29 0a elf "./").
1df0: 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 (sdat-set-sess
1e00: 69 6f 6e 2d 63 6f 6f 6b 69 65 21 20 73 65 6c 66 ion-cookie! self
1e10: 20 23 66 29 0a 20 20 28 73 64 61 74 2d 73 65 74 #f). (sdat-set
1e20: 2d 63 75 72 72 2d 65 72 72 21 20 73 65 6c 66 20 -curr-err! self
1e30: 23 66 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d #f). (sdat-set-
1e40: 6c 6f 67 2d 70 6f 72 74 21 20 73 65 6c 66 20 28 log-port! self (
1e50: 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f current-error-po
1e60: 72 74 29 29 0a 20 20 28 73 64 61 74 2d 73 65 74 rt)). (sdat-set
1e70: 2d 73 65 65 6e 2d 70 61 67 65 73 21 20 73 65 6c -seen-pages! sel
1e80: 66 20 27 28 29 29 0a 20 20 28 73 64 61 74 2d 73 f '()). (sdat-s
1e90: 65 74 2d 70 61 67 65 2d 64 69 72 2d 73 74 79 6c et-page-dir-styl
1ea0: 65 21 20 73 65 6c 66 20 23 74 29 20 3b 3b 20 23 e! self #t) ;; #
1eb0: 74 20 3a 20 70 61 67 65 73 2f 3c 70 61 67 65 6e t : pages/<pagen
1ec0: 61 6d 65 3e 5f 28 76 69 65 77 7c 63 6e 74 6c 29 ame>_(view|cntl)
1ed0: 2e 73 63 6d 0a 20 20 20 20 20 20 20 20 20 20 20 .scm.
1ee0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1ef0: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 23 66 ;; #f
1f00: 20 3a 20 70 61 67 65 73 2f 3c 70 61 67 65 6e 61 : pages/<pagena
1f10: 6d 65 3e 2f 28 76 69 65 77 7c 63 6f 6e 74 72 6f me>/(view|contro
1f20: 6c 29 2e 73 63 6d 20 0a 20 20 28 73 64 61 74 2d l).scm . (sdat-
1f30: 73 65 74 2d 64 65 62 75 67 6d 6f 64 65 21 20 20 set-debugmode!
1f40: 20 20 20 20 20 20 20 20 73 65 6c 66 20 23 66 29 self #f)
1f50: 0a 20 20 09 09 09 20 20 20 20 20 0a 20 20 28 73 . ... . (s
1f60: 64 61 74 2d 73 65 74 2d 70 61 67 65 76 61 72 73 dat-set-pagevars
1f70: 21 20 20 20 20 20 20 20 20 20 20 20 73 65 6c 66 ! self
1f80: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
1f90: 65 29 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d e)). (sdat-set-
1fa0: 73 65 73 73 69 6f 6e 76 61 72 73 21 20 20 20 20 sessionvars!
1fb0: 20 20 20 20 73 65 6c 66 20 28 6d 61 6b 65 2d 68 self (make-h
1fc0: 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 73 ash-table)). (s
1fd0: 64 61 74 2d 73 65 74 2d 67 6c 6f 62 61 6c 76 61 dat-set-globalva
1fe0: 72 73 21 20 20 20 20 20 20 20 20 20 73 65 6c 66 rs! self
1ff0: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
2000: 65 29 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d e)). (sdat-set-
2010: 70 61 67 65 76 61 72 73 2d 62 65 66 6f 72 65 21 pagevars-before!
2020: 20 20 20 20 73 65 6c 66 20 28 6d 61 6b 65 2d 68 self (make-h
2030: 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 73 ash-table)). (s
2040: 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e 76 dat-set-sessionv
2050: 61 72 73 2d 62 65 66 6f 72 65 21 20 73 65 6c 66 ars-before! self
2060: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
2070: 65 29 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d e)). (sdat-set-
2080: 67 6c 6f 62 61 6c 76 61 72 73 2d 62 65 66 6f 72 globalvars-befor
2090: 65 21 20 20 73 65 6c 66 20 28 6d 61 6b 65 2d 68 e! self (make-h
20a0: 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 73 ash-table)). (s
20b0: 64 61 74 2d 73 65 74 2d 64 6f 6d 61 69 6e 21 20 dat-set-domain!
20c0: 20 20 20 20 20 20 20 20 20 20 20 20 73 65 6c 66 self
20d0: 20 22 6c 6f 63 61 68 6f 73 74 22 29 20 20 20 3b "locahost") ;
20e0: 3b 20 65 6e 64 20 6f 66 20 64 65 66 61 75 6c 74 ; end of default
20f0: 73 0a 20 20 28 6c 65 74 2a 20 28 28 72 61 77 63 s. (let* ((rawc
2100: 6f 6e 66 69 67 64 61 74 20 28 73 65 73 73 69 6f onfigdat (sessio
2110: 6e 3a 72 65 61 64 2d 63 6f 6e 66 69 67 20 73 65 n:read-config se
2120: 6c 66 29 29 0a 09 20 28 63 6f 6e 66 69 67 64 61 lf)).. (configda
2130: 74 20 28 69 66 20 72 61 77 63 6f 6e 66 69 67 64 t (if rawconfigd
2140: 61 74 20 28 65 76 61 6c 20 72 61 77 63 6f 6e 66 at (eval rawconf
2150: 69 67 64 61 74 29 20 27 28 29 29 29 0a 09 20 28 igdat) '())).. (
2160: 73 72 6f 6f 74 20 20 20 20 20 28 73 3a 66 69 6e sroot (s:fin
2170: 64 2d 70 61 72 61 6d 20 27 73 72 6f 6f 74 20 20 d-param 'sroot
2180: 20 20 63 6f 6e 66 69 67 64 61 74 29 29 0a 09 20 configdat))..
2190: 28 6c 6f 67 66 69 6c 65 20 20 20 28 73 3a 66 69 (logfile (s:fi
21a0: 6e 64 2d 70 61 72 61 6d 20 27 6c 6f 67 66 69 6c nd-param 'logfil
21b0: 65 20 20 63 6f 6e 66 69 67 64 61 74 29 29 0a 09 e configdat))..
21c0: 20 28 64 62 74 79 70 65 20 20 20 20 28 73 3a 66 (dbtype (s:f
21d0: 69 6e 64 2d 70 61 72 61 6d 20 27 64 62 74 79 70 ind-param 'dbtyp
21e0: 65 20 20 20 63 6f 6e 66 69 67 64 61 74 29 29 0a e configdat)).
21f0: 09 20 28 64 62 69 6e 69 74 20 20 20 20 28 73 3a . (dbinit (s:
2200: 66 69 6e 64 2d 70 61 72 61 6d 20 27 64 62 69 6e find-param 'dbin
2210: 69 74 20 20 20 63 6f 6e 66 69 67 64 61 74 29 29 it configdat))
2220: 0a 09 20 28 64 6f 6d 61 69 6e 20 20 20 20 28 73 .. (domain (s
2230: 3a 66 69 6e 64 2d 70 61 72 61 6d 20 27 64 6f 6d :find-param 'dom
2240: 61 69 6e 20 20 20 63 6f 6e 66 69 67 64 61 74 29 ain configdat)
2250: 29 29 0a 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 )). ;; (print
2260: 20 22 63 6f 6e 66 69 67 64 61 74 3a 20 22 29 28 "configdat: ")(
2270: 70 70 20 63 6f 6e 66 69 67 64 61 74 29 0a 20 20 pp configdat).
2280: 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 73 72 6f ;; (print "sro
2290: 6f 74 3a 20 22 20 73 72 6f 6f 74 20 22 20 6c 6f ot: " sroot " lo
22a0: 67 66 69 6c 65 3a 20 22 20 6c 6f 67 66 69 6c 65 gfile: " logfile
22b0: 20 22 20 64 62 74 79 70 65 3a 20 22 20 64 62 74 " dbtype: " dbt
22c0: 79 70 65 20 22 20 64 62 69 6e 69 74 3a 20 22 20 ype " dbinit: "
22d0: 64 62 69 6e 69 74 20 22 20 64 6f 6d 61 69 6e 3a dbinit " domain:
22e0: 20 22 20 64 6f 6d 61 69 6e 29 0a 20 20 20 20 28 " domain). (
22f0: 69 66 20 73 72 6f 6f 74 20 20 20 28 73 64 61 74 if sroot (sdat
2300: 2d 73 65 74 2d 73 72 6f 6f 74 21 20 20 20 73 65 -set-sroot! se
2310: 6c 66 20 73 72 6f 6f 74 29 29 0a 20 20 20 20 28 lf sroot)). (
2320: 69 66 20 6c 6f 67 66 69 6c 65 20 28 73 64 61 74 if logfile (sdat
2330: 2d 73 65 74 2d 6c 6f 67 66 69 6c 65 21 20 73 65 -set-logfile! se
2340: 6c 66 20 6c 6f 67 66 69 6c 65 29 29 0a 20 20 20 lf logfile)).
2350: 20 28 69 66 20 64 62 74 79 70 65 20 20 28 73 64 (if dbtype (sd
2360: 61 74 2d 73 65 74 2d 64 62 74 79 70 65 21 20 20 at-set-dbtype!
2370: 73 65 6c 66 20 64 62 74 79 70 65 29 29 0a 20 20 self dbtype)).
2380: 20 20 28 69 66 20 64 62 69 6e 69 74 20 20 28 73 (if dbinit (s
2390: 64 61 74 2d 73 65 74 2d 64 62 69 6e 69 74 21 20 dat-set-dbinit!
23a0: 20 73 65 6c 66 20 64 62 69 6e 69 74 29 29 0a 20 self dbinit)).
23b0: 20 20 20 28 69 66 20 64 6f 6d 61 69 6e 20 20 28 (if domain (
23c0: 73 64 61 74 2d 73 65 74 2d 64 6f 6d 61 69 6e 21 sdat-set-domain!
23d0: 20 20 73 65 6c 66 20 64 6f 6d 61 69 6e 29 29 29 self domain)))
23e0: 29 0a 3b 3b 20 20 20 28 6c 65 74 20 28 28 64 62 ).;; (let ((db
23f0: 74 79 70 65 20 28 73 64 61 74 2d 67 65 74 2d 64 type (sdat-get-d
2400: 62 74 79 70 65 20 73 65 6c 66 29 29 29 0a 3b 3b btype self))).;;
2410: 20 20 20 20 20 28 70 72 69 6e 74 20 22 64 62 74 (print "dbt
2420: 79 70 65 3a 20 22 20 64 62 74 79 70 65 29 0a 3b ype: " dbtype).;
2430: 3b 20 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d ; (sdat-set-
2440: 64 62 74 79 70 65 21 20 73 65 6c 66 20 28 65 76 dbtype! self (ev
2450: 61 6c 20 64 62 74 79 70 65 29 29 29 29 0a 0a 28 al dbtype))))..(
2460: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
2470: 73 65 74 75 70 20 73 65 6c 66 29 0a 20 20 28 6c setup self). (l
2480: 65 74 20 28 28 64 62 74 79 70 65 20 28 73 64 61 et ((dbtype (sda
2490: 74 2d 67 65 74 2d 64 62 74 79 70 65 20 73 65 6c t-get-dbtype sel
24a0: 66 29 29 0a 09 28 64 62 69 6e 69 74 20 28 65 76 f))..(dbinit (ev
24b0: 61 6c 20 28 73 64 61 74 2d 67 65 74 2d 64 62 69 al (sdat-get-dbi
24c0: 6e 69 74 20 73 65 6c 66 29 29 29 0a 09 28 64 62 nit self)))..(db
24d0: 65 78 69 73 74 73 20 23 66 29 29 0a 20 20 20 20 exists #f)).
24e0: 28 6c 65 74 20 28 28 64 62 66 6e 61 6d 65 20 28 (let ((dbfname (
24f0: 61 6c 69 73 74 2d 72 65 66 20 27 64 62 6e 61 6d alist-ref 'dbnam
2500: 65 20 64 62 69 6e 69 74 29 29 29 0a 20 20 20 20 e dbinit))).
2510: 20 20 28 69 66 20 28 65 71 3f 20 64 62 74 79 70 (if (eq? dbtyp
2520: 65 20 27 73 71 6c 69 74 65 33 29 0a 09 20 20 28 e 'sqlite3).. (
2530: 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f if (file-exists?
2540: 20 64 62 66 6e 61 6d 65 29 0a 09 20 20 20 20 20 dbfname)..
2550: 20 28 62 65 67 69 6e 0a 09 09 3b 3b 20 28 73 65 (begin...;; (se
2560: 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 ssion:log self "
2570: 73 65 74 74 69 6e 67 20 64 62 65 78 69 73 74 73 setting dbexists
2580: 20 74 6f 20 23 74 22 29 0a 09 09 28 73 65 74 21 to #t")...(set!
2590: 20 64 62 65 78 69 73 74 73 20 23 74 29 29 29 29 dbexists #t))))
25a0: 0a 20 20 20 20 20 20 3b 3b 20 28 73 65 73 73 69 . ;; (sessi
25b0: 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 64 62 74 on:log self "dbt
25c0: 79 70 65 3a 20 22 20 64 62 74 79 70 65 20 22 20 ype: " dbtype "
25d0: 64 62 66 6e 61 6d 65 3a 20 22 20 64 62 66 6e 61 dbfname: " dbfna
25e0: 6d 65 20 22 20 64 62 65 78 69 73 74 73 3a 20 22 me " dbexists: "
25f0: 20 64 62 65 78 69 73 74 73 29 29 0a 20 20 20 20 dbexists)).
2600: 20 20 29 0a 20 20 20 20 28 73 64 61 74 2d 73 65 ). (sdat-se
2610: 74 2d 63 6f 6e 6e 21 20 73 65 6c 66 20 28 64 62 t-conn! self (db
2620: 69 3a 6f 70 65 6e 20 64 62 74 79 70 65 20 64 62 i:open dbtype db
2630: 69 6e 69 74 29 29 0a 20 20 20 20 28 69 66 20 28 init)). (if (
2640: 61 6e 64 20 28 6e 6f 74 20 64 62 65 78 69 73 74 and (not dbexist
2650: 73 29 28 65 71 3f 20 64 62 74 79 70 65 20 27 73 s)(eq? dbtype 's
2660: 71 6c 69 74 65 33 29 29 0a 20 09 28 62 65 67 69 qlite3)). .(begi
2670: 6e 0a 09 20 20 28 70 72 69 6e 74 20 22 57 41 52 n.. (print "WAR
2680: 4e 49 4e 47 3a 20 53 65 74 74 69 6e 67 20 75 70 NING: Setting up
2690: 20 73 65 73 73 69 6f 6e 20 64 62 20 77 69 74 68 session db with
26a0: 20 73 71 6c 69 74 65 33 22 29 0a 09 20 20 28 73 sqlite3").. (s
26b0: 65 73 73 69 6f 6e 3a 73 65 74 75 70 2d 64 62 20 ession:setup-db
26c0: 73 65 6c 66 29 29 29 0a 20 20 20 20 28 73 65 73 self))). (ses
26d0: 73 69 6f 6e 3a 70 72 6f 63 65 73 73 2d 75 72 6c sion:process-url
26e0: 2d 70 61 74 68 20 73 65 6c 66 29 0a 20 20 20 20 -path self).
26f0: 28 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 2d 73 (session:setup-s
2700: 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 ession-key self)
2710: 0a 20 20 20 20 3b 3b 20 63 61 70 74 75 72 65 20 . ;; capture
2720: 73 74 64 69 6e 20 69 66 20 74 68 69 73 20 69 73 stdin if this is
2730: 20 61 20 50 4f 53 54 0a 20 20 20 20 28 73 64 61 a POST. (sda
2740: 74 2d 73 65 74 2d 72 65 71 75 65 73 74 2d 6d 65 t-set-request-me
2750: 74 68 6f 64 21 20 73 65 6c 66 20 28 67 65 74 2d thod! self (get-
2760: 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 environment-vari
2770: 61 62 6c 65 20 22 52 45 51 55 45 53 54 5f 4d 45 able "REQUEST_ME
2780: 54 48 4f 44 22 29 29 0a 20 20 20 20 28 73 64 61 THOD")). (sda
2790: 74 2d 73 65 74 2d 66 6f 72 6d 64 61 74 21 20 73 t-set-formdat! s
27a0: 65 6c 66 20 28 66 6f 72 6d 64 61 74 3a 6c 6f 61 elf (formdat:loa
27b0: 64 2d 61 6c 6c 29 29 29 29 0a 0a 3b 3b 20 73 65 d-all))))..;; se
27c0: 74 75 70 20 74 68 65 20 64 62 20 77 69 74 68 20 tup the db with
27d0: 73 65 73 73 69 6f 6e 20 74 61 62 6c 65 73 2c 20 session tables,
27e0: 77 6f 72 6b 73 20 66 6f 72 20 73 71 6c 69 74 65 works for sqlite
27f0: 20 6f 6e 6c 79 20 72 69 67 68 74 20 6e 6f 77 0a only right now.
2800: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
2810: 3a 73 65 74 75 70 2d 64 62 20 73 65 6c 66 29 0a :setup-db self).
2820: 20 20 28 6c 65 74 20 28 28 63 6f 6e 6e 20 28 73 (let ((conn (s
2830: 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c dat-get-conn sel
2840: 66 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 f))). (for-ea
2850: 63 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 ch . (lambda
2860: 20 28 73 74 6d 74 29 0a 20 20 20 20 20 20 20 28 (stmt). (
2870: 64 62 69 3a 65 78 65 63 20 63 6f 6e 6e 20 73 74 dbi:exec conn st
2880: 6d 74 29 29 0a 20 20 20 20 20 28 6c 69 73 74 20 mt)). (list
2890: 22 43 52 45 41 54 45 20 54 41 42 4c 45 20 73 65 "CREATE TABLE se
28a0: 73 73 69 6f 6e 5f 76 61 72 73 20 28 69 64 20 49 ssion_vars (id I
28b0: 4e 54 45 47 45 52 20 50 52 49 4d 41 52 59 20 4b NTEGER PRIMARY K
28c0: 45 59 2c 73 65 73 73 69 6f 6e 5f 69 64 20 49 4e EY,session_id IN
28d0: 54 45 47 45 52 2c 70 61 67 65 20 54 45 58 54 2c TEGER,page TEXT,
28e0: 6b 65 79 20 54 45 58 54 2c 76 61 6c 75 65 20 54 key TEXT,value T
28f0: 45 58 54 29 3b 22 0a 09 20 20 20 22 43 52 45 41 EXT);".. "CREA
2900: 54 45 20 54 41 42 4c 45 20 73 65 73 73 69 6f 6e TE TABLE session
2910: 73 20 28 69 64 20 49 4e 54 45 47 45 52 20 50 52 s (id INTEGER PR
2920: 49 4d 41 52 59 20 4b 45 59 2c 73 65 73 73 69 6f IMARY KEY,sessio
2930: 6e 5f 6b 65 79 20 54 45 58 54 2c 6c 61 73 74 5f n_key TEXT,last_
2940: 75 73 65 64 20 54 49 4d 45 53 54 41 4d 50 29 3b used TIMESTAMP);
2950: 22 0a 20 20 20 20 20 20 20 20 20 20 20 22 43 52 ". "CR
2960: 45 41 54 45 20 54 41 42 4c 45 20 6d 65 74 61 64 EATE TABLE metad
2970: 61 74 61 20 28 69 64 20 49 4e 54 45 47 45 52 20 ata (id INTEGER
2980: 50 52 49 4d 41 52 59 20 4b 45 59 2c 6b 65 79 20 PRIMARY KEY,key
2990: 54 45 58 54 2c 76 61 6c 75 65 20 54 45 58 54 29 TEXT,value TEXT)
29a0: 3b 22 29 29 29 29 0a 3b 3b 20 20 3b 3b 20 69 66 ;")))).;; ;; if
29b0: 20 77 65 20 68 61 76 65 20 61 20 73 65 73 73 69 we have a sessi
29c0: 6f 6e 5f 6b 65 79 20 6c 6f 6f 6b 20 75 70 20 74 on_key look up t
29d0: 68 65 20 73 65 73 73 69 6f 6e 2d 69 64 20 61 6e he session-id an
29e0: 64 20 73 74 6f 72 65 20 69 74 0a 3b 3b 20 20 28 d store it.;; (
29f0: 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e sdat-set-session
2a00: 2d 69 64 21 20 73 65 6c 66 20 28 73 65 73 73 69 -id! self (sessi
2a10: 6f 6e 3a 67 65 74 2d 69 64 20 73 65 6c 66 29 29 on:get-id self))
2a20: 29 0a 0a 3b 3b 20 6f 6e 6c 79 20 73 65 74 20 73 )..;; only set s
2a30: 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 20 77 68 ession-cookie wh
2a40: 65 6e 20 61 20 6e 65 77 20 73 65 73 73 69 6f 6e en a new session
2a50: 20 69 73 20 63 72 65 61 74 65 64 0a 28 64 65 66 is created.(def
2a60: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 ine (session:set
2a70: 75 70 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 up-session-key s
2a80: 65 6c 66 29 20 20 0a 20 20 28 6c 65 74 2a 20 28 elf) . (let* (
2a90: 28 73 6b 20 20 28 73 65 73 73 69 6f 6e 3a 65 78 (sk (session:ex
2aa0: 74 72 61 63 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 tract-session-ke
2ab0: 79 20 73 65 6c 66 29 29 0a 20 20 20 20 20 20 20 y self)).
2ac0: 20 20 28 73 69 64 20 28 69 66 20 73 6b 20 28 73 (sid (if sk (s
2ad0: 65 73 73 69 6f 6e 3a 67 65 74 2d 69 64 20 73 65 ession:get-id se
2ae0: 6c 66 20 73 6b 29 20 23 66 29 29 29 0a 20 20 20 lf sk) #f))).
2af0: 20 28 69 66 20 28 6e 6f 74 20 73 69 64 29 20 3b (if (not sid) ;
2b00: 3b 20 6e 65 65 64 20 61 20 6e 65 77 20 6b 65 79 ; need a new key
2b10: 0a 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 . (let* (
2b20: 28 6e 65 77 2d 6b 65 79 20 28 73 65 73 73 69 6f (new-key (sessio
2b30: 6e 3a 67 65 74 2d 6e 65 77 2d 6b 65 79 20 73 65 n:get-new-key se
2b40: 6c 66 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 lf)).
2b50: 20 20 20 20 28 6e 65 77 2d 73 69 64 20 28 73 65 (new-sid (se
2b60: 73 73 69 6f 6e 3a 67 65 74 2d 69 64 20 73 65 6c ssion:get-id sel
2b70: 66 20 6e 65 77 2d 6b 65 79 29 29 29 0a 20 20 20 f new-key))).
2b80: 20 20 20 20 20 20 20 28 73 64 61 74 2d 73 65 74 (sdat-set
2b90: 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 21 20 73 65 -session-key! se
2ba0: 6c 66 20 6e 65 77 2d 6b 65 79 29 0a 20 20 20 20 lf new-key).
2bb0: 20 20 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d (sdat-set-
2bc0: 73 65 73 73 69 6f 6e 2d 69 64 21 20 73 65 6c 66 session-id! self
2bd0: 20 6e 65 77 2d 73 69 64 29 0a 20 20 20 20 20 20 new-sid).
2be0: 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 (sdat-set-se
2bf0: 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 21 20 73 65 ssion-cookie! se
2c00: 6c 66 20 28 73 65 73 73 69 6f 6e 3a 6d 61 6b 65 lf (session:make
2c10: 2d 63 6f 6f 6b 69 65 20 73 65 6c 66 29 29 29 0a -cookie self))).
2c20: 20 20 20 20 20 20 20 20 28 73 64 61 74 2d 73 65 (sdat-se
2c30: 74 2d 73 65 73 73 69 6f 6e 2d 69 64 21 20 73 65 t-session-id! se
2c40: 6c 66 20 73 69 64 29 29 29 29 0a 0a 28 64 65 66 lf sid))))..(def
2c50: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 6d 61 6b ine (session:mak
2c60: 65 2d 63 6f 6f 6b 69 65 20 73 65 6c 66 29 0a 20 e-cookie self).
2c70: 20 3b 3b 20 28 6c 69 73 74 20 28 63 6f 6e 63 20 ;; (list (conc
2c80: 22 73 65 73 73 69 6f 6e 5f 6b 65 79 3d 22 20 28 "session_key=" (
2c90: 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e sdat-get-session
2ca0: 2d 6b 65 79 20 73 65 6c 66 29 20 22 3b 20 50 61 -key self) "; Pa
2cb0: 74 68 3d 2f 3b 20 44 6f 6d 61 69 6e 3d 2e 22 20 th=/; Domain=."
2cc0: 28 73 64 61 74 2d 67 65 74 2d 64 6f 6d 61 69 6e (sdat-get-domain
2cd0: 20 73 65 6c 66 29 20 22 3b 20 4d 61 78 2d 41 67 self) "; Max-Ag
2ce0: 65 3d 22 20 28 2a 20 38 36 34 30 30 20 31 34 29 e=" (* 86400 14)
2cf0: 20 22 3b 20 56 65 72 73 69 6f 6e 3d 31 22 29 29 "; Version=1"))
2d00: 29 20 0a 20 20 28 6c 69 73 74 20 28 73 74 72 69 ) . (list (stri
2d10: 6e 67 2d 73 75 62 73 74 69 74 75 74 65 20 0a 09 ng-substitute ..
2d20: 20 22 3b 22 20 22 3b 20 22 20 0a 09 20 28 63 61 ";" "; " .. (ca
2d30: 72 20 28 63 6f 6e 73 74 72 75 63 74 2d 63 6f 6f r (construct-coo
2d40: 6b 69 65 2d 73 74 72 69 6e 67 20 0a 09 20 20 20 kie-string ..
2d50: 20 20 20 20 3b 3b 20 77 61 72 6e 69 6e 67 21 20 ;; warning!
2d60: 6d 65 73 73 69 6e 67 20 75 70 20 74 68 69 73 20 messing up this
2d70: 69 74 74 79 20 62 69 74 74 79 20 62 69 74 20 6f itty bitty bit o
2d80: 66 20 63 6f 64 65 20 77 69 6c 6c 20 63 6f 73 74 f code will cost
2d90: 20 6d 75 63 68 20 74 69 6d 65 21 0a 09 20 20 20 much time!..
2da0: 20 20 20 20 60 28 28 22 73 65 73 73 69 6f 6e 5f `(("session_
2db0: 6b 65 79 22 20 2c 28 73 64 61 74 2d 67 65 74 2d key" ,(sdat-get-
2dc0: 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 session-key self
2dd0: 29 0a 09 09 20 20 65 78 70 69 72 65 73 3a 20 2c )... expires: ,
2de0: 28 2b 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f (+ (current-seco
2df0: 6e 64 73 29 20 28 2a 20 31 34 20 38 36 34 30 30 nds) (* 14 86400
2e00: 29 29 20 0a 09 09 20 20 6d 61 78 2d 61 67 65 3a )) ... max-age:
2e10: 20 28 2a 20 31 34 20 38 36 34 30 30 29 0a 09 09 (* 14 86400)...
2e20: 20 20 70 61 74 68 3a 20 22 2f 22 20 3b 3b 20 0a path: "/" ;; .
2e30: 09 09 20 20 64 6f 6d 61 69 6e 3a 20 2c 28 73 74 .. domain: ,(st
2e40: 72 69 6e 67 2d 61 70 70 65 6e 64 20 22 2e 22 20 ring-append "."
2e50: 28 73 64 61 74 2d 67 65 74 2d 64 6f 6d 61 69 6e (sdat-get-domain
2e60: 20 73 65 6c 66 29 29 0a 09 09 20 20 76 65 72 73 self))... vers
2e70: 69 6f 6e 3a 20 31 29 29 20 30 29 29 29 29 29 0a ion: 1)) 0))))).
2e80: 0a 3b 3b 20 6c 6f 6f 6b 20 75 70 20 61 20 67 69 .;; look up a gi
2e90: 76 65 6e 20 73 65 73 73 69 6f 6e 20 6b 65 79 20 ven session key
2ea0: 61 6e 64 20 72 65 74 75 72 6e 20 74 68 65 20 69 and return the i
2eb0: 64 20 69 66 20 66 6f 75 6e 64 2c 20 23 66 20 69 d if found, #f i
2ec0: 66 20 6e 6f 74 20 66 6f 75 6e 64 0a 28 64 65 66 f not found.(def
2ed0: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 ine (session:get
2ee0: 2d 69 64 20 73 65 6c 66 20 73 65 73 73 69 6f 6e -id self session
2ef0: 2d 6b 65 79 29 0a 20 20 3b 3b 20 28 6c 65 74 20 -key). ;; (let
2f00: 28 28 73 65 73 73 69 6f 6e 2d 6b 65 79 20 28 73 ((session-key (s
2f10: 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 2d dat-get-session-
2f20: 6b 65 79 20 73 65 6c 66 29 29 29 0a 20 20 28 69 key self))). (i
2f30: 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 0a 20 20 f session-key.
2f40: 20 20 20 20 28 6c 65 74 20 28 28 71 75 65 72 79 (let ((query
2f50: 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 (string-append
2f60: 22 53 45 4c 45 43 54 20 69 64 20 46 52 4f 4d 20 "SELECT id FROM
2f70: 73 65 73 73 69 6f 6e 73 20 57 48 45 52 45 20 73 sessions WHERE s
2f80: 65 73 73 69 6f 6e 5f 6b 65 79 3d 27 22 20 73 65 ession_key='" se
2f90: 73 73 69 6f 6e 2d 6b 65 79 20 22 27 22 29 29 0a ssion-key "'")).
2fa0: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e (con
2fb0: 6e 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e n (sdat-get-conn
2fc0: 20 73 65 6c 66 29 29 0a 20 20 20 20 20 20 20 20 self)).
2fd0: 20 20 20 20 28 72 65 73 75 6c 74 20 23 66 29 29 (result #f))
2fe0: 0a 09 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d ..(dbi:for-each-
2ff0: 72 6f 77 20 0a 09 20 28 6c 61 6d 62 64 61 20 28 row .. (lambda (
3000: 74 75 70 6c 65 29 0a 09 20 20 20 28 73 65 74 21 tuple).. (set!
3010: 20 72 65 73 75 6c 74 20 28 76 65 63 74 6f 72 2d result (vector-
3020: 72 65 66 20 74 75 70 6c 65 20 30 29 29 29 0a 09 ref tuple 0)))..
3030: 20 63 6f 6e 6e 20 71 75 65 72 79 29 0a 09 28 69 conn query)..(i
3040: 66 20 72 65 73 75 6c 74 20 28 64 62 69 3a 65 78 f result (dbi:ex
3050: 65 63 20 63 6f 6e 6e 20 28 63 6f 6e 63 20 22 55 ec conn (conc "U
3060: 50 44 41 54 45 20 73 65 73 73 69 6f 6e 73 20 53 PDATE sessions S
3070: 45 54 20 6c 61 73 74 5f 75 73 65 64 3d 22 20 28 ET last_used=" (
3080: 64 62 69 3a 6e 6f 77 20 63 6f 6e 6e 29 20 22 20 dbi:now conn) "
3090: 57 48 45 52 45 20 73 65 73 73 69 6f 6e 5f 6b 65 WHERE session_ke
30a0: 79 3d 3f 3b 22 29 20 73 65 73 73 69 6f 6e 2d 6b y=?;") session-k
30b0: 65 79 29 29 0a 20 20 20 20 20 20 20 20 72 65 73 ey)). res
30c0: 75 6c 74 29 0a 20 20 20 20 20 20 23 66 29 29 0a ult). #f)).
30d0: 0a 3b 3b 20 0a 28 64 65 66 69 6e 65 20 28 73 65 .;; .(define (se
30e0: 73 73 69 6f 6e 3a 70 72 6f 63 65 73 73 2d 75 72 ssion:process-ur
30f0: 6c 2d 70 61 74 68 20 73 65 6c 66 29 0a 20 20 28 l-path self). (
3100: 6c 65 74 20 28 28 70 61 74 68 2d 69 6e 66 6f 20 let ((path-info
3110: 20 20 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d (get-environm
3120: 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 50 41 ent-variable "PA
3130: 54 48 5f 49 4e 46 4f 22 29 29 0a 09 28 71 75 65 TH_INFO"))..(que
3140: 72 79 2d 73 74 72 69 6e 67 20 28 67 65 74 2d 65 ry-string (get-e
3150: 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 nvironment-varia
3160: 62 6c 65 20 22 51 55 45 52 59 5f 53 54 52 49 4e ble "QUERY_STRIN
3170: 47 22 29 29 29 0a 20 20 20 20 3b 3b 20 28 73 65 G"))). ;; (se
3180: 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 ssion:log self "
3190: 70 61 74 68 2d 69 6e 66 6f 3d 22 20 70 61 74 68 path-info=" path
31a0: 2d 69 6e 66 6f 20 22 20 71 75 65 72 79 2d 73 74 -info " query-st
31b0: 72 69 6e 67 3d 22 20 71 75 65 72 79 2d 73 74 72 ring=" query-str
31c0: 69 6e 67 29 0a 20 20 20 20 28 69 66 20 70 61 74 ing). (if pat
31d0: 68 2d 69 6e 66 6f 0a 09 28 6c 65 74 2a 20 28 28 h-info..(let* ((
31e0: 70 61 72 74 73 20 20 20 20 28 73 74 72 69 6e 67 parts (string
31f0: 2d 73 70 6c 69 74 20 70 61 74 68 2d 69 6e 66 6f -split path-info
3200: 20 22 2f 22 29 29 0a 09 20 20 20 20 20 20 20 28 "/")).. (
3210: 6e 75 6d 70 61 72 74 73 20 28 6c 65 6e 67 74 68 numparts (length
3220: 20 70 61 72 74 73 29 29 29 0a 09 20 20 28 69 66 parts))).. (if
3230: 20 28 3e 20 6e 75 6d 70 61 72 74 73 20 30 29 0a (> numparts 0).
3240: 09 20 20 20 20 20 20 28 73 64 61 74 2d 73 65 74 . (sdat-set
3250: 2d 70 61 67 65 21 20 73 65 6c 66 20 28 63 61 72 -page! self (car
3260: 20 70 61 72 74 73 29 29 29 0a 09 20 20 3b 3b 20 parts))).. ;;
3270: 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c (session:log sel
3280: 66 20 22 75 72 6c 2d 70 61 74 68 3d 22 20 75 72 f "url-path=" ur
3290: 6c 2d 70 61 74 68 20 22 20 70 61 72 74 73 3d 22 l-path " parts="
32a0: 20 70 61 72 74 73 29 0a 09 20 20 28 69 66 20 28 parts).. (if (
32b0: 3e 20 6e 75 6d 70 61 72 74 73 20 31 29 0a 09 20 > numparts 1)..
32c0: 20 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d 70 (sdat-set-p
32d0: 61 74 68 2d 70 61 72 61 6d 73 21 20 73 65 6c 66 ath-params! self
32e0: 20 28 63 64 72 20 70 61 72 74 73 29 29 29 0a 20 (cdr parts))).
32f0: 20 20 20 20 20 20 20 20 20 28 69 66 20 71 75 65 (if que
3300: 72 79 2d 73 74 72 69 6e 67 0a 20 20 20 20 20 20 ry-string.
3310: 20 20 20 20 20 20 20 20 28 73 64 61 74 2d 73 65 (sdat-se
3320: 74 2d 70 61 72 61 6d 73 21 20 73 65 6c 66 20 28 t-params! self (
3330: 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 71 75 65 string-split que
3340: 72 79 2d 73 74 72 69 6e 67 20 22 26 22 29 29 29 ry-string "&")))
3350: 29 29 29 29 0a 0a 3b 3b 20 42 55 47 47 59 21 0a ))))..;; BUGGY!.
3360: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
3370: 3a 67 65 74 2d 6e 65 77 2d 6b 65 79 20 73 65 6c :get-new-key sel
3380: 66 29 0a 20 20 28 6c 65 74 20 28 28 63 6f 6e 6e f). (let ((conn
3390: 20 20 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e (sdat-get-con
33a0: 6e 20 73 65 6c 66 29 29 0a 20 20 20 20 20 20 20 n self)).
33b0: 20 28 74 6d 70 6b 65 79 20 28 73 65 73 73 69 6f (tmpkey (sessio
33c0: 6e 3a 6d 61 6b 65 2d 72 61 6e 64 2d 73 74 72 69 n:make-rand-stri
33d0: 6e 67 20 32 30 29 29 0a 20 20 20 20 20 20 20 20 ng 20)).
33e0: 28 73 74 61 74 75 73 20 23 66 29 29 0a 20 20 20 (status #f)).
33f0: 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 (dbi:for-each-r
3400: 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c ow (lambda (tupl
3410: 65 29 0a 09 09 09 28 73 65 74 21 20 73 74 61 74 e)....(set! stat
3420: 75 73 20 23 74 29 29 0a 09 09 20 20 20 20 20 20 us #t))...
3430: 63 6f 6e 6e 20 28 73 74 72 69 6e 67 2d 61 70 70 conn (string-app
3440: 65 6e 64 20 22 49 4e 53 45 52 54 20 49 4e 54 4f end "INSERT INTO
3450: 20 73 65 73 73 69 6f 6e 73 20 28 73 65 73 73 69 sessions (sessi
3460: 6f 6e 5f 6b 65 79 29 20 56 41 4c 55 45 53 20 28 on_key) VALUES (
3470: 27 22 20 74 6d 70 6b 65 79 20 22 27 29 22 29 29 '" tmpkey "')"))
3480: 0a 20 20 20 20 74 6d 70 6b 65 79 29 29 0a 0a 3b . tmpkey))..;
3490: 3b 20 72 65 74 75 72 6e 73 20 73 65 73 73 69 6f ; returns sessio
34a0: 6e 20 6b 65 79 20 49 46 46 20 69 74 20 69 73 20 n key IFF it is
34b0: 69 6e 20 74 68 65 20 48 54 54 50 5f 43 4f 4f 4b in the HTTP_COOK
34c0: 49 45 20 0a 28 64 65 66 69 6e 65 20 28 73 65 73 IE .(define (ses
34d0: 73 69 6f 6e 3a 65 78 74 72 61 63 74 2d 73 65 73 sion:extract-ses
34e0: 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 0a 20 sion-key self).
34f0: 20 28 6c 65 74 20 28 28 68 74 74 70 2d 73 65 73 (let ((http-ses
3500: 73 69 6f 6e 20 28 67 65 74 2d 65 6e 76 69 72 6f sion (get-enviro
3510: 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 nment-variable "
3520: 48 54 54 50 5f 43 4f 4f 4b 49 45 22 29 29 29 0a HTTP_COOKIE"))).
3530: 20 20 20 20 28 69 66 20 68 74 74 70 2d 73 65 73 (if http-ses
3540: 73 69 6f 6e 20 0a 20 20 20 20 20 20 20 20 28 73 sion . (s
3550: 65 73 73 69 6f 6e 3a 65 78 74 72 61 63 74 2d 6b ession:extract-k
3560: 65 79 2d 66 72 6f 6d 2d 70 61 72 61 6d 20 73 65 ey-from-param se
3570: 6c 66 20 28 6c 69 73 74 20 68 74 74 70 2d 73 65 lf (list http-se
3580: 73 73 69 6f 6e 29 20 22 73 65 73 73 69 6f 6e 5f ssion) "session_
3590: 6b 65 79 22 29 0a 20 20 20 20 20 20 20 20 23 66 key"). #f
35a0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 )))..(define (se
35b0: 73 73 69 6f 6e 3a 67 65 74 2d 73 65 73 73 69 6f ssion:get-sessio
35c0: 6e 2d 69 64 20 73 65 6c 66 20 73 65 73 73 69 6f n-id self sessio
35d0: 6e 2d 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 28 n-key). (let ((
35e0: 71 75 65 72 79 20 22 53 45 4c 45 43 54 20 69 64 query "SELECT id
35f0: 20 46 52 4f 4d 20 73 65 73 73 69 6f 6e 73 20 57 FROM sessions W
3600: 48 45 52 45 20 73 65 73 73 69 6f 6e 5f 6b 65 79 HERE session_key
3610: 3d 3f 3b 22 29 0a 20 20 20 20 20 20 20 20 28 72 =?;"). (r
3620: 65 73 75 6c 74 20 23 66 29 29 0a 20 20 20 20 3b esult #f)). ;
3630: 3b 20 20 20 20 20 28 70 67 3a 71 75 65 72 79 2d ; (pg:query-
3640: 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 for-each (lambda
3650: 20 28 74 75 70 6c 65 29 0a 20 20 20 20 3b 3b 20 (tuple). ;;
3660: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3670: 20 20 20 20 20 20 20 20 20 28 73 65 74 21 20 72 (set! r
3680: 65 73 75 6c 74 20 28 76 65 63 74 6f 72 2d 72 65 esult (vector-re
3690: 66 20 74 75 70 6c 65 20 30 29 29 29 20 3b 3b 20 f tuple 0))) ;;
36a0: 28 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c (vector-ref tupl
36b0: 65 20 30 29 29 29 0a 20 20 20 20 3b 3b 20 20 20 e 0))). ;;
36c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
36d0: 20 20 20 20 20 28 73 3a 73 71 6c 70 61 72 61 6d (s:sqlparam
36e0: 20 71 75 65 72 79 20 73 65 73 73 69 6f 6e 2d 6b query session-k
36f0: 65 79 29 0a 20 20 20 20 3b 3b 20 20 20 20 20 20 ey). ;;
3700: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3710: 20 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e (sdat-get-conn
3720: 20 73 65 6c 66 29 29 0a 20 20 20 20 3b 3b 20 20 self)). ;;
3730: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3740: 20 20 20 20 20 20 63 6f 6e 6e 29 0a 20 20 20 20 conn).
3750: 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f (dbi:for-each-ro
3760: 77 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 w (lambda (tuple
3770: 29 0a 09 09 09 28 73 65 74 21 20 72 65 73 75 6c )....(set! resul
3780: 74 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 75 t (vector-ref tu
3790: 70 6c 65 20 30 29 29 29 20 3b 3b 20 28 76 65 63 ple 0))) ;; (vec
37a0: 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 30 29 tor-ref tuple 0)
37b0: 29 29 0a 09 09 20 20 20 20 20 20 28 73 64 61 74 ))... (sdat
37c0: 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 0a -get-conn self).
37d0: 09 09 20 20 20 20 20 20 28 73 3a 73 71 6c 70 61 .. (s:sqlpa
37e0: 72 61 6d 20 71 75 65 72 79 20 73 65 73 73 69 6f ram query sessio
37f0: 6e 2d 6b 65 79 29 29 0a 20 20 20 20 72 65 73 75 n-key)). resu
3800: 6c 74 29 29 0a 0a 3b 3b 20 64 65 6c 65 74 65 20 lt))..;; delete
3810: 61 6c 6c 20 72 65 63 6f 72 64 73 20 66 6f 72 20 all records for
3820: 61 20 73 65 73 73 69 6f 6e 0a 3b 3b 0a 28 64 65 a session.;;.(de
3830: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 64 65 fine (session:de
3840: 6c 65 74 65 2d 73 65 73 73 69 6f 6e 20 73 65 6c lete-session sel
3850: 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 0a 20 f session-key).
3860: 20 28 6c 65 74 20 28 28 73 65 73 73 69 6f 6e 2d (let ((session-
3870: 69 64 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d id (session:get-
3880: 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 20 session-id self
3890: 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 0a 20 20 session-key)).
38a0: 20 20 20 20 20 20 28 71 72 79 20 20 20 20 20 20 (qry
38b0: 20 20 28 63 6f 6e 63 20 22 42 45 47 49 4e 3b 22 (conc "BEGIN;"
38c0: 0a 09 09 09 20 20 22 44 45 4c 45 54 45 20 46 52 .... "DELETE FR
38d0: 4f 4d 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 OM session_vars
38e0: 57 48 45 52 45 20 73 65 73 73 69 6f 6e 5f 69 64 WHERE session_id
38f0: 3d 3f 3b 22 0a 20 20 20 20 20 20 20 20 20 20 20 =?;".
3900: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 22 "
3910: 44 45 4c 45 54 45 20 46 52 4f 4d 20 73 65 73 73 DELETE FROM sess
3920: 69 6f 6e 73 20 57 48 45 52 45 20 69 64 3d 3f 3b ions WHERE id=?;
3930: 22 0a 09 09 09 20 20 22 43 4f 4d 4d 49 54 3b 22 ".... "COMMIT;"
3940: 29 29 0a 20 20 20 20 20 20 20 20 28 63 6f 6e 6e )). (conn
3950: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
3960: 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c dat-get-conn sel
3970: 66 29 29 29 0a 20 20 20 20 28 69 66 20 73 65 73 f))). (if ses
3980: 73 69 6f 6e 2d 69 64 0a 20 20 20 20 20 20 20 20 sion-id.
3990: 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 (begin.
39a0: 20 28 64 62 69 3a 65 78 65 63 20 63 6f 6e 6e 20 (dbi:exec conn
39b0: 71 72 79 20 73 65 73 73 69 6f 6e 2d 69 64 20 73 qry session-id s
39c0: 65 73 73 69 6f 6e 2d 69 64 29 0a 09 20 20 28 73 ession-id).. (s
39d0: 65 73 73 69 6f 6e 3a 69 6e 69 74 69 61 6c 69 7a ession:initializ
39e0: 65 20 73 65 6c 66 29 0a 09 20 20 28 73 65 73 73 e self).. (sess
39f0: 69 6f 6e 3a 73 65 74 75 70 20 73 65 6c 66 29 29 ion:setup self))
3a00: 29 0a 20 20 20 20 28 6e 6f 74 20 28 73 65 73 73 ). (not (sess
3a10: 69 6f 6e 3a 67 65 74 2d 73 65 73 73 69 6f 6e 2d ion:get-session-
3a20: 69 64 20 73 65 6c 66 20 73 65 73 73 69 6f 6e 2d id self session-
3a30: 6b 65 79 29 29 29 29 0a 0a 3b 3b 20 28 64 65 66 key))))..;; (def
3a40: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 64 65 6c ine (session:del
3a50: 65 74 65 2d 73 65 73 73 69 6f 6e 20 73 65 6c 66 ete-session self
3a60: 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 0a 3b 3b session-key).;;
3a70: 20 20 20 28 6c 65 74 20 28 28 73 65 73 73 69 6f (let ((sessio
3a80: 6e 2d 69 64 20 28 73 65 73 73 69 6f 6e 3a 67 65 n-id (session:ge
3a90: 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c t-session-id sel
3aa0: 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 0a f session-key)).
3ab0: 3b 3b 20 20 20 20 20 20 20 20 20 28 71 75 65 72 ;; (quer
3ac0: 69 65 73 20 20 20 20 28 6c 69 73 74 20 22 42 45 ies (list "BE
3ad0: 47 49 4e 3b 22 0a 3b 3b 20 09 09 09 20 20 22 44 GIN;".;; ... "D
3ae0: 45 4c 45 54 45 20 46 52 4f 4d 20 73 65 73 73 69 ELETE FROM sessi
3af0: 6f 6e 5f 76 61 72 73 20 57 48 45 52 45 20 73 65 on_vars WHERE se
3b00: 73 73 69 6f 6e 5f 69 64 3d 3f 3b 22 0a 3b 3b 20 ssion_id=?;".;;
3b10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3b20: 20 20 20 20 20 20 20 20 20 20 22 44 45 4c 45 54 "DELET
3b30: 45 20 46 52 4f 4d 20 73 65 73 73 69 6f 6e 73 20 E FROM sessions
3b40: 57 48 45 52 45 20 69 64 3d 3f 3b 22 0a 3b 3b 20 WHERE id=?;".;;
3b50: 09 09 09 20 20 22 43 4f 4d 4d 49 54 3b 22 29 29 ... "COMMIT;"))
3b60: 0a 3b 3b 20 20 20 20 20 20 20 20 20 28 63 6f 6e .;; (con
3b70: 6e 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 n (
3b80: 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 sdat-get-conn se
3b90: 6c 66 29 29 29 0a 3b 3b 20 20 20 20 20 28 69 66 lf))).;; (if
3ba0: 20 73 65 73 73 69 6f 6e 2d 69 64 0a 3b 3b 20 20 session-id.;;
3bb0: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 3b 3b (begin.;;
3bc0: 20 20 20 20 20 20 20 20 20 20 20 28 66 6f 72 2d (for-
3bd0: 65 61 63 68 0a 3b 3b 20 20 20 20 20 20 20 20 20 each.;;
3be0: 20 20 20 28 6c 61 6d 62 64 61 20 28 71 75 65 72 (lambda (quer
3bf0: 79 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 y).;;
3c00: 20 20 20 28 64 62 69 3a 65 78 65 63 20 63 6f 6e (dbi:exec con
3c10: 6e 20 71 75 65 72 79 20 73 65 73 73 69 6f 6e 2d n query session-
3c20: 69 64 29 29 0a 3b 3b 20 09 20 20 20 71 75 65 72 id)).;; . quer
3c30: 69 65 73 29 0a 3b 3b 20 09 20 20 28 69 6e 69 74 ies).;; . (init
3c40: 69 61 6c 69 7a 65 20 73 65 6c 66 20 27 28 29 29 ialize self '())
3c50: 0a 3b 3b 20 09 20 20 28 73 65 73 73 69 6f 6e 3a .;; . (session:
3c60: 73 65 74 75 70 20 73 65 6c 66 29 29 29 0a 3b 3b setup self))).;;
3c70: 20 20 20 20 20 28 6e 6f 74 20 28 73 65 73 73 69 (not (sessi
3c80: 6f 6e 3a 67 65 74 2d 73 65 73 73 69 6f 6e 2d 69 on:get-session-i
3c90: 64 20 73 65 6c 66 20 73 65 73 73 69 6f 6e 2d 6b d self session-k
3ca0: 65 79 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ey))))..(define
3cb0: 28 73 65 73 73 69 6f 6e 3a 65 78 74 72 61 63 74 (session:extract
3cc0: 2d 6b 65 79 20 73 65 6c 66 20 6b 65 79 29 0a 20 -key self key).
3cd0: 20 28 6c 65 74 20 28 28 70 61 72 61 6d 73 20 28 (let ((params (
3ce0: 73 64 61 74 2d 67 65 74 2d 70 61 72 61 6d 73 20 sdat-get-params
3cf0: 73 65 6c 66 29 29 29 0a 20 20 20 20 28 73 65 73 self))). (ses
3d00: 73 69 6f 6e 3a 65 78 74 72 61 63 74 2d 6b 65 79 sion:extract-key
3d10: 2d 66 72 6f 6d 2d 70 61 72 61 6d 20 73 65 6c 66 -from-param self
3d20: 20 70 61 72 61 6d 73 20 6b 65 79 29 29 29 0a 0a params key)))..
3d30: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
3d40: 3a 65 78 74 72 61 63 74 2d 6b 65 79 2d 66 72 6f :extract-key-fro
3d50: 6d 2d 70 61 72 61 6d 20 73 65 6c 66 20 70 61 72 m-param self par
3d60: 61 6d 73 20 6b 65 79 29 0a 20 20 28 6c 65 74 20 ams key). (let
3d70: 28 28 72 31 20 20 20 20 20 28 72 65 67 65 78 70 ((r1 (regexp
3d80: 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 (string-append
3d90: 22 5e 22 20 6b 65 79 20 22 3d 28 5b 5e 3d 5d 2b "^" key "=([^=]+
3da0: 29 24 22 29 29 29 29 0a 20 20 20 20 28 69 66 20 )$")))). (if
3db0: 28 3c 20 28 6c 65 6e 67 74 68 20 70 61 72 61 6d (< (length param
3dc0: 73 29 20 31 29 20 23 66 0a 09 28 6c 65 74 20 6c s) 1) #f..(let l
3dd0: 6f 6f 70 20 28 28 68 65 61 64 20 20 20 28 63 61 oop ((head (ca
3de0: 72 20 70 61 72 61 6d 73 29 29 0a 09 09 20 20 20 r params))...
3df0: 28 74 61 69 6c 20 20 20 28 63 64 72 20 70 61 72 (tail (cdr par
3e00: 61 6d 73 29 29 29 0a 09 20 20 28 6c 65 74 20 28 ams))).. (let (
3e10: 28 6d 61 74 63 68 20 28 73 74 72 69 6e 67 2d 6d (match (string-m
3e20: 61 74 63 68 20 72 31 20 68 65 61 64 29 29 29 0a atch r1 head))).
3e30: 09 20 20 20 20 28 63 6f 6e 64 0a 09 20 20 20 20 . (cond..
3e40: 20 28 6d 61 74 63 68 0a 09 20 20 20 20 20 20 28 (match.. (
3e50: 6c 65 74 20 28 28 73 65 73 73 69 6f 6e 2d 6b 65 let ((session-ke
3e60: 79 20 28 6c 69 73 74 2d 72 65 66 20 6d 61 74 63 y (list-ref matc
3e70: 68 20 31 29 29 29 0a 09 09 28 73 64 61 74 2d 73 h 1)))...(sdat-s
3e80: 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 21 20 et-session-key!
3e90: 73 65 6c 66 20 28 6c 69 73 74 2d 72 65 66 20 6d self (list-ref m
3ea0: 61 74 63 68 20 31 29 29 0a 09 09 73 65 73 73 69 atch 1))...sessi
3eb0: 6f 6e 2d 6b 65 79 29 29 0a 09 20 20 20 20 20 28 on-key)).. (
3ec0: 28 6e 75 6c 6c 3f 20 74 61 69 6c 29 0a 09 20 20 (null? tail)..
3ed0: 20 20 20 20 23 66 29 0a 09 20 20 20 20 20 28 65 #f).. (e
3ee0: 6c 73 65 0a 09 20 20 20 20 20 20 28 6c 6f 6f 70 lse.. (loop
3ef0: 20 28 63 61 72 20 74 61 69 6c 29 0a 09 09 20 20 (car tail)...
3f00: 20 20 28 63 64 72 20 74 61 69 6c 29 29 29 29 29 (cdr tail)))))
3f10: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 ))))..(define (s
3f20: 65 73 73 69 6f 6e 3a 73 65 74 2d 70 61 67 65 21 ession:set-page!
3f30: 20 73 65 6c 66 20 70 61 67 65 5f 6e 61 6d 65 29 self page_name)
3f40: 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 67 . (sdat-set-pag
3f50: 65 21 20 73 65 6c 66 20 70 61 67 65 5f 6e 61 6d e! self page_nam
3f60: 65 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 e))..(define (se
3f70: 73 73 69 6f 6e 3a 63 6c 6f 73 65 20 73 65 6c 66 ssion:close self
3f80: 29 0a 20 20 28 64 62 69 3a 63 6c 6f 73 65 20 28 ). (dbi:close (
3f90: 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 sdat-get-conn se
3fa0: 6c 66 29 29 29 0a 3b 3b 20 28 63 6c 6f 73 65 2d lf))).;; (close-
3fb0: 6f 75 74 70 75 74 2d 70 6f 72 74 20 28 73 64 61 output-port (sda
3fc0: 74 2d 67 65 74 2d 6c 6f 67 70 74 20 73 65 6c 66 t-get-logpt self
3fd0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 ))..(define (ses
3fe0: 73 69 6f 6e 3a 65 72 72 2d 6d 73 67 20 73 65 6c sion:err-msg sel
3ff0: 66 20 6d 73 67 29 0a 20 20 28 68 61 73 68 2d 74 f msg). (hash-t
4000: 61 62 6c 65 2d 73 65 74 21 20 28 73 64 61 74 2d able-set! (sdat-
4010: 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 20 get-sessionvars
4020: 73 65 6c 66 29 20 22 45 52 52 4f 52 5f 4d 53 47 self) "ERROR_MSG
4030: 22 0a 09 09 20 20 20 28 73 74 72 69 6e 67 2d 69 "... (string-i
4040: 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 20 ntersperse (map
4050: 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6d 73 s:any->string ms
4060: 67 29 20 22 20 22 29 29 29 0a 0a 28 64 65 66 69 g) " ")))..(defi
4070: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 70 72 65 76 ne (session:prev
4080: 2d 65 72 72 20 73 65 6c 66 29 0a 20 20 28 6c 65 -err self). (le
4090: 74 20 28 28 70 72 65 76 2d 65 72 72 20 28 68 61 t ((prev-err (ha
40a0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
40b0: 61 75 6c 74 20 28 73 64 61 74 2d 67 65 74 2d 73 ault (sdat-get-s
40c0: 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 essionvars-befor
40d0: 65 20 73 65 6c 66 29 20 22 45 52 52 4f 52 5f 4d e self) "ERROR_M
40e0: 53 47 22 20 23 66 29 29 0a 09 28 63 75 72 72 2d SG" #f))..(curr-
40f0: 65 72 72 20 28 68 61 73 68 2d 74 61 62 6c 65 2d err (hash-table-
4100: 72 65 66 2f 64 65 66 61 75 6c 74 20 28 73 64 61 ref/default (sda
4110: 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 t-get-sessionvar
4120: 73 20 73 65 6c 66 29 20 22 45 52 52 4f 52 5f 4d s self) "ERROR_M
4130: 53 47 22 20 23 66 29 29 29 0a 20 20 20 20 28 69 SG" #f))). (i
4140: 66 20 70 72 65 76 2d 65 72 72 20 70 72 65 76 2d f prev-err prev-
4150: 65 72 72 0a 09 28 69 66 20 63 75 72 72 2d 65 72 err..(if curr-er
4160: 72 20 63 75 72 72 2d 65 72 72 20 23 66 29 29 29 r curr-err #f)))
4170: 29 0a 0a 3b 3b 20 73 65 73 73 69 6f 6e 20 76 61 )..;; session va
4180: 72 73 0a 3b 3b 20 31 2e 20 6b 65 79 73 20 61 72 rs.;; 1. keys ar
4190: 65 20 61 6c 77 61 79 73 20 61 20 73 74 72 69 6e e always a strin
41a0: 67 20 4e 4f 54 20 61 20 73 79 6d 62 6f 6c 0a 3b g NOT a symbol.;
41b0: 3b 20 32 2e 20 76 61 6c 75 65 73 20 61 72 65 20 ; 2. values are
41c0: 61 6c 77 61 79 73 20 61 20 73 74 72 69 6e 67 20 always a string
41d0: 63 6f 6e 76 65 72 73 69 6f 6e 20 69 73 20 74 68 conversion is th
41e0: 65 20 72 65 73 70 6f 6e 73 69 62 69 6c 69 74 79 e responsibility
41f0: 20 6f 66 20 74 68 65 20 0a 3b 3b 20 20 20 20 63 of the .;; c
4200: 6f 6e 73 75 6d 69 6e 67 20 66 75 6e 63 74 69 6f onsuming functio
4210: 6e 20 28 61 74 20 6c 65 61 73 74 20 66 6f 72 20 n (at least for
4220: 6e 6f 77 2c 20 49 27 64 20 6c 69 6b 65 20 74 6f now, I'd like to
4230: 20 63 68 61 6e 67 65 20 74 68 69 73 29 0a 0a 3b change this)..;
4240: 3b 20 73 65 74 20 61 20 73 65 73 73 69 6f 6e 20 ; set a session
4250: 76 61 72 20 66 6f 72 20 74 68 65 20 63 75 72 72 var for the curr
4260: 65 6e 74 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 ent page.;;.(def
4270: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 ine (session:set
4280: 21 20 73 65 6c 66 20 6b 65 79 20 76 61 6c 75 65 ! self key value
4290: 29 0a 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ). (hash-table-
42a0: 73 65 74 21 20 28 73 64 61 74 2d 67 65 74 2d 70 set! (sdat-get-p
42b0: 61 67 65 76 61 72 73 20 73 65 6c 66 29 20 28 73 agevars self) (s
42c0: 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6b 65 79 :any->string key
42d0: 29 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 ) (s:any->string
42e0: 20 76 61 6c 75 65 29 29 29 0a 0a 3b 3b 20 64 65 value)))..;; de
42f0: 6c 20 61 20 76 61 72 20 66 6f 72 20 74 68 65 20 l a var for the
4300: 63 75 72 72 65 6e 74 20 70 61 67 65 0a 3b 3b 0a current page.;;.
4310: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
4320: 3a 64 65 6c 21 20 73 65 6c 66 20 6b 65 79 29 0a :del! self key).
4330: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 64 65 (hash-table-de
4340: 6c 65 74 65 21 20 28 73 64 61 74 2d 67 65 74 2d lete! (sdat-get-
4350: 70 61 67 65 76 61 72 73 20 73 65 6c 66 29 20 28 pagevars self) (
4360: 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6b 65 s:any->string ke
4370: 79 29 29 29 0a 0a 3b 3b 20 67 65 74 20 74 68 65 y)))..;; get the
4380: 20 61 70 70 72 6f 70 72 69 61 74 65 20 68 61 73 appropriate has
4390: 68 20 67 69 76 65 6e 20 61 20 70 61 67 65 20 22 h given a page "
43a0: 2a 73 65 73 73 69 6f 6e 76 61 72 73 2a 2c 20 2a *sessionvars*, *
43b0: 67 6c 6f 62 61 6c 76 61 72 73 2a 20 6f 72 20 70 globalvars* or p
43c0: 61 67 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 age.;;.(define (
43d0: 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 67 65 session:get-page
43e0: 2d 68 61 73 68 20 73 65 6c 66 20 70 61 67 65 29 -hash self page)
43f0: 0a 20 20 28 69 66 20 28 73 74 72 69 6e 67 3d 3f . (if (string=?
4400: 20 70 61 67 65 20 22 2a 73 65 73 73 69 6f 6e 76 page "*sessionv
4410: 61 72 73 2a 22 29 0a 20 20 20 20 20 20 28 73 64 ars*"). (sd
4420: 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 at-get-sessionva
4430: 72 73 20 73 65 6c 66 29 0a 20 20 20 20 20 20 28 rs self). (
4440: 69 66 20 28 73 74 72 69 6e 67 3d 3f 20 70 61 67 if (string=? pag
4450: 65 20 22 2a 67 6c 6f 62 61 6c 76 61 72 73 2a 22 e "*globalvars*"
4460: 29 0a 09 20 20 28 73 64 61 74 2d 67 65 74 2d 67 ).. (sdat-get-g
4470: 6c 6f 62 61 6c 76 61 72 73 20 73 65 6c 66 29 0a lobalvars self).
4480: 09 20 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 . (sdat-get-pag
4490: 65 76 61 72 73 20 73 65 6c 66 29 29 29 29 0a 0a evars self))))..
44a0: 3b 3b 20 73 65 74 20 61 20 73 65 73 73 69 6f 6e ;; set a session
44b0: 20 76 61 72 20 66 6f 72 20 61 20 67 69 76 65 6e var for a given
44c0: 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 page.;;.(define
44d0: 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 21 20 73 (session:set! s
44e0: 65 6c 66 20 70 61 67 65 20 6b 65 79 20 76 61 6c elf page key val
44f0: 75 65 29 0a 20 20 28 6c 65 74 20 28 28 68 74 20 ue). (let ((ht
4500: 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 67 (session:get-pag
4510: 65 2d 68 61 73 68 20 73 65 6c 66 20 70 61 67 65 e-hash self page
4520: 29 29 29 0a 20 20 20 20 28 68 61 73 68 2d 74 61 ))). (hash-ta
4530: 62 6c 65 2d 73 65 74 21 20 68 74 20 28 73 3a 61 ble-set! ht (s:a
4540: 6e 79 2d 3e 73 74 72 69 6e 67 20 6b 65 79 29 20 ny->string key)
4550: 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 76 (s:any->string v
4560: 61 6c 75 65 29 29 29 29 0a 0a 3b 3b 20 67 65 74 alue))))..;; get
4570: 20 73 65 73 73 69 6f 6e 20 76 61 72 73 20 66 6f session vars fo
4580: 72 20 74 68 65 20 63 75 72 72 65 6e 74 20 70 61 r the current pa
4590: 67 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 ge.;;.(define (s
45a0: 65 73 73 69 6f 6e 3a 67 65 74 20 73 65 6c 66 20 ession:get self
45b0: 6b 65 79 29 0a 20 20 28 68 61 73 68 2d 74 61 62 key). (hash-tab
45c0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 28 le-ref/default (
45d0: 73 64 61 74 2d 67 65 74 2d 70 61 67 65 76 61 72 sdat-get-pagevar
45e0: 73 20 73 65 6c 66 29 20 6b 65 79 20 23 66 29 29 s self) key #f))
45f0: 0a 0a 3b 3b 20 67 65 74 20 73 65 73 73 69 6f 6e ..;; get session
4600: 20 76 61 72 73 20 66 6f 72 20 61 20 73 70 65 63 vars for a spec
4610: 69 66 69 65 64 20 70 61 67 65 0a 3b 3b 0a 28 64 ified page.;;.(d
4620: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 efine (session:g
4630: 65 74 20 73 65 6c 66 20 70 61 67 65 20 6b 65 79 et self page key
4640: 29 0a 20 20 28 6c 65 74 20 28 28 68 74 20 28 73 ). (let ((ht (s
4650: 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 67 65 2d ession:get-page-
4660: 68 61 73 68 20 73 65 6c 66 20 70 61 67 65 29 29 hash self page))
4670: 29 0a 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c ). (hash-tabl
4680: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 68 74 e-ref/default ht
4690: 20 6b 65 79 20 23 66 29 29 29 0a 0a 3b 3b 20 64 key #f)))..;; d
46a0: 65 6c 65 74 65 20 61 20 73 65 73 73 69 6f 6e 20 elete a session
46b0: 76 61 72 20 66 6f 72 20 61 20 73 70 65 63 69 66 var for a specif
46c0: 69 65 64 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 ied page.;;.(def
46d0: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 64 65 6c ine (session:del
46e0: 21 20 73 65 6c 66 20 70 61 67 65 20 6b 65 79 29 ! self page key)
46f0: 0a 20 20 28 6c 65 74 20 28 28 68 74 20 28 73 65 . (let ((ht (se
4700: 73 73 69 6f 6e 3a 67 65 74 2d 70 61 67 65 2d 68 ssion:get-page-h
4710: 61 73 68 20 73 65 6c 66 20 70 61 67 65 29 29 29 ash self page)))
4720: 0a 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 . (hash-table
4730: 2d 64 65 6c 65 74 65 21 20 68 74 20 6b 65 79 29 -delete! ht key)
4740: 29 29 0a 0a 3b 3b 20 67 65 74 20 41 4c 4c 20 6b ))..;; get ALL k
4750: 65 79 73 20 66 6f 72 20 74 68 69 73 20 70 61 67 eys for this pag
4760: 65 20 61 6e 64 20 73 74 6f 72 65 20 69 6e 20 74 e and store in t
4770: 68 65 20 73 65 73 73 69 6f 6e 20 70 61 67 65 76 he session pagev
4780: 61 72 73 20 68 61 73 68 0a 3b 3b 0a 28 64 65 66 ars hash.;;.(def
4790: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 ine (session:get
47a0: 2d 76 61 72 73 20 73 65 6c 66 29 0a 20 20 28 6c -vars self). (l
47b0: 65 74 20 28 28 73 65 73 73 69 6f 6e 2d 69 64 20 et ((session-id
47c0: 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 (sdat-get-sessi
47d0: 6f 6e 2d 69 64 20 73 65 6c 66 29 29 29 0a 20 20 on-id self))).
47e0: 20 20 28 69 66 20 28 6e 6f 74 20 73 65 73 73 69 (if (not sessi
47f0: 6f 6e 2d 69 64 29 0a 09 28 65 72 72 3a 6c 6f 67 on-id)..(err:log
4800: 20 22 45 52 52 4f 52 3a 20 4e 6f 20 73 65 73 73 "ERROR: No sess
4810: 69 6f 6e 20 69 64 20 69 6e 20 73 65 73 73 69 6f ion id in sessio
4820: 6e 20 6f 62 6a 65 63 74 21 20 73 65 73 73 69 6f n object! sessio
4830: 6e 3a 67 65 74 2d 76 61 72 73 22 29 0a 09 28 6c n:get-vars")..(l
4840: 65 74 2a 20 28 28 72 65 73 75 6c 74 20 20 20 20 et* ((result
4850: 20 20 20 20 20 20 20 20 20 23 66 29 0a 09 20 20 #f)..
4860: 20 20 20 20 20 28 63 6f 6e 6e 20 20 20 20 20 20 (conn
4870: 20 20 20 20 20 20 20 20 20 28 73 64 61 74 2d 67 (sdat-g
4880: 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 0a 09 et-conn self))..
4890: 20 20 20 20 20 20 20 28 70 61 67 65 76 61 72 73 (pagevars
48a0: 2d 62 65 66 6f 72 65 20 20 20 20 28 73 64 61 74 -before (sdat
48b0: 2d 67 65 74 2d 70 61 67 65 76 61 72 73 2d 62 65 -get-pagevars-be
48c0: 66 6f 72 65 20 73 65 6c 66 29 29 0a 09 20 20 20 fore self))..
48d0: 20 20 20 20 28 73 65 73 73 69 6f 6e 76 61 72 73 (sessionvars
48e0: 2d 62 65 66 6f 72 65 20 28 73 64 61 74 2d 67 65 -before (sdat-ge
48f0: 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 t-sessionvars-be
4900: 66 6f 72 65 20 73 65 6c 66 29 29 0a 09 20 20 20 fore self))..
4910: 20 20 20 20 28 67 6c 6f 62 61 6c 76 61 72 73 2d (globalvars-
4920: 62 65 66 6f 72 65 20 20 28 73 64 61 74 2d 67 65 before (sdat-ge
4930: 74 2d 67 6c 6f 62 61 6c 76 61 72 73 2d 62 65 66 t-globalvars-bef
4940: 6f 72 65 20 73 65 6c 66 29 29 0a 09 20 20 20 20 ore self))..
4950: 20 20 20 28 70 61 67 65 76 61 72 73 20 20 20 20 (pagevars
4960: 20 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 (sdat-get
4970: 2d 70 61 67 65 76 61 72 73 20 73 65 6c 66 29 29 -pagevars self))
4980: 0a 09 20 20 20 20 20 20 20 28 73 65 73 73 69 6f .. (sessio
4990: 6e 76 61 72 73 20 20 20 20 20 20 20 20 28 73 64 nvars (sd
49a0: 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 at-get-sessionva
49b0: 72 73 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 rs self))..
49c0: 20 20 28 67 6c 6f 62 61 6c 76 61 72 73 20 20 20 (globalvars
49d0: 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d (sdat-get-
49e0: 67 6c 6f 62 61 6c 76 61 72 73 20 73 65 6c 66 29 globalvars self)
49f0: 29 0a 09 20 20 20 20 20 20 20 28 70 61 67 65 2d ).. (page-
4a00: 6e 61 6d 65 20 20 20 20 20 20 20 20 20 20 28 73 name (s
4a10: 64 61 74 2d 67 65 74 2d 70 61 67 65 20 73 65 6c dat-get-page sel
4a20: 66 29 29 0a 09 20 20 20 20 20 20 20 28 73 65 73 f)).. (ses
4a30: 73 69 6f 6e 2d 6b 65 79 20 20 20 20 20 20 20 20 sion-key
4a40: 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f (sdat-get-sessio
4a50: 6e 2d 6b 65 79 20 73 65 6c 66 29 29 0a 09 20 20 n-key self))..
4a60: 20 20 20 20 20 28 71 75 65 72 79 20 20 20 20 20 (query
4a70: 20 20 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 (string
4a80: 2d 61 70 70 65 6e 64 0a 09 09 09 09 20 20 20 20 -append.....
4a90: 22 53 45 4c 45 43 54 20 6b 65 79 2c 76 61 6c 75 "SELECT key,valu
4aa0: 65 20 46 52 4f 4d 20 73 65 73 73 69 6f 6e 5f 76 e FROM session_v
4ab0: 61 72 73 20 49 4e 4e 45 52 20 4a 4f 49 4e 20 73 ars INNER JOIN s
4ac0: 65 73 73 69 6f 6e 73 20 4f 4e 20 73 65 73 73 69 essions ON sessi
4ad0: 6f 6e 5f 76 61 72 73 2e 73 65 73 73 69 6f 6e 5f on_vars.session_
4ae0: 69 64 3d 73 65 73 73 69 6f 6e 73 2e 69 64 20 22 id=sessions.id "
4af0: 0a 09 09 09 09 20 20 20 20 22 57 48 45 52 45 20 ..... "WHERE
4b00: 73 65 73 73 69 6f 6e 5f 6b 65 79 3d 3f 20 41 4e session_key=? AN
4b10: 44 20 70 61 67 65 3d 3f 3b 22 29 29 29 0a 09 20 D page=?;")))..
4b20: 20 3b 3b 20 66 69 72 73 74 20 74 68 65 20 70 61 ;; first the pa
4b30: 67 65 20 73 70 65 63 69 66 69 63 20 76 61 72 73 ge specific vars
4b40: 0a 09 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 .. (dbi:for-eac
4b50: 68 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 h-row (lambda (t
4b60: 75 70 6c 65 29 0a 09 09 09 20 20 20 20 20 20 28 uple).... (
4b70: 6c 65 74 20 28 28 6b 20 28 76 65 63 74 6f 72 2d let ((k (vector-
4b80: 72 65 66 20 74 75 70 6c 65 20 30 29 29 0a 09 09 ref tuple 0))...
4b90: 09 09 20 20 20 20 28 76 20 28 76 65 63 74 6f 72 .. (v (vector
4ba0: 2d 72 65 66 20 74 75 70 6c 65 20 31 29 29 29 0a -ref tuple 1))).
4bb0: 09 09 09 09 28 68 61 73 68 2d 74 61 62 6c 65 2d ....(hash-table-
4bc0: 73 65 74 21 20 70 61 67 65 76 61 72 73 2d 62 65 set! pagevars-be
4bd0: 66 6f 72 65 20 6b 20 76 29 0a 09 09 09 09 28 68 fore k v).....(h
4be0: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 70 ash-table-set! p
4bf0: 61 67 65 76 61 72 73 20 20 20 20 20 20 20 20 6b agevars k
4c00: 20 76 29 29 29 0a 09 09 09 20 20 20 20 63 6f 6e v))).... con
4c10: 6e 0a 09 09 09 20 20 20 20 28 73 3a 73 71 6c 70 n.... (s:sqlp
4c20: 61 72 61 6d 20 71 75 65 72 79 20 73 65 73 73 69 aram query sessi
4c30: 6f 6e 2d 6b 65 79 20 70 61 67 65 2d 6e 61 6d 65 on-key page-name
4c40: 29 29 0a 09 20 20 3b 3b 20 74 68 65 6e 20 74 68 )).. ;; then th
4c50: 65 20 73 65 73 73 69 6f 6e 20 73 70 65 63 69 66 e session specif
4c60: 69 63 20 76 61 72 73 0a 09 20 20 28 64 62 69 3a ic vars.. (dbi:
4c70: 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 for-each-row (la
4c80: 6d 62 64 61 20 28 74 75 70 6c 65 29 0a 09 09 09 mbda (tuple)....
4c90: 20 20 20 20 20 20 28 6c 65 74 20 28 28 6b 20 28 (let ((k (
4ca0: 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 vector-ref tuple
4cb0: 20 30 29 29 0a 09 09 09 09 20 20 20 20 28 76 20 0))..... (v
4cc0: 28 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c (vector-ref tupl
4cd0: 65 20 31 29 29 29 0a 09 09 09 09 28 68 61 73 68 e 1))).....(hash
4ce0: 2d 74 61 62 6c 65 2d 73 65 74 21 20 73 65 73 73 -table-set! sess
4cf0: 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 20 6b ionvars-before k
4d00: 20 76 29 0a 09 09 09 09 28 68 61 73 68 2d 74 61 v).....(hash-ta
4d10: 62 6c 65 2d 73 65 74 21 20 73 65 73 73 69 6f 6e ble-set! session
4d20: 76 61 72 73 20 20 20 20 20 20 20 20 6b 20 76 29 vars k v)
4d30: 29 29 0a 09 09 09 20 20 20 20 63 6f 6e 6e 0a 09 )).... conn..
4d40: 09 09 20 20 20 20 28 73 3a 73 71 6c 70 61 72 61 .. (s:sqlpara
4d50: 6d 20 71 75 65 72 79 20 73 65 73 73 69 6f 6e 2d m query session-
4d60: 6b 65 79 20 22 2a 73 65 73 73 69 6f 6e 76 61 72 key "*sessionvar
4d70: 73 2a 22 29 29 0a 09 20 20 3b 3b 20 61 6e 64 20 s*")).. ;; and
4d80: 66 69 6e 61 6c 6c 79 20 74 68 65 20 67 6c 6f 62 finally the glob
4d90: 61 6c 20 76 61 72 73 0a 09 20 20 28 64 62 69 3a al vars.. (dbi:
4da0: 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 for-each-row (la
4db0: 6d 62 64 61 20 28 74 75 70 6c 65 29 0a 09 09 09 mbda (tuple)....
4dc0: 20 20 20 20 20 20 28 6c 65 74 20 28 28 6b 20 28 (let ((k (
4dd0: 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 vector-ref tuple
4de0: 20 30 29 29 0a 09 09 09 09 20 20 20 20 28 76 20 0))..... (v
4df0: 28 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c (vector-ref tupl
4e00: 65 20 31 29 29 29 0a 09 09 09 09 28 68 61 73 68 e 1))).....(hash
4e10: 2d 74 61 62 6c 65 2d 73 65 74 21 20 67 6c 6f 62 -table-set! glob
4e20: 61 6c 76 61 72 73 2d 62 65 66 6f 72 65 20 6b 20 alvars-before k
4e30: 76 29 0a 09 09 09 09 28 68 61 73 68 2d 74 61 62 v).....(hash-tab
4e40: 6c 65 2d 73 65 74 21 20 67 6c 6f 62 61 6c 76 61 le-set! globalva
4e50: 72 73 20 20 20 20 20 20 20 20 6b 20 76 29 29 29 rs k v)))
4e60: 0a 09 09 09 20 20 20 20 63 6f 6e 6e 0a 09 09 09 .... conn....
4e70: 20 20 20 20 28 73 3a 73 71 6c 70 61 72 61 6d 20 (s:sqlparam
4e80: 71 75 65 72 79 20 73 65 73 73 69 6f 6e 2d 6b 65 query session-ke
4e90: 79 20 22 2a 67 6c 6f 62 61 6c 76 61 72 73 22 29 y "*globalvars")
4ea0: 29 0a 09 20 20 29 29 29 29 0a 0a 28 64 65 66 69 ).. ))))..(defi
4eb0: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 61 76 65 ne (session:save
4ec0: 2d 76 61 72 73 20 73 65 6c 66 29 0a 20 20 28 6c -vars self). (l
4ed0: 65 74 20 28 28 73 65 73 73 69 6f 6e 2d 69 64 20 et ((session-id
4ee0: 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 (sdat-get-sessi
4ef0: 6f 6e 2d 69 64 20 73 65 6c 66 29 29 29 0a 20 20 on-id self))).
4f00: 20 20 28 69 66 20 28 6e 6f 74 20 73 65 73 73 69 (if (not sessi
4f10: 6f 6e 2d 69 64 29 0a 09 28 65 72 72 3a 6c 6f 67 on-id)..(err:log
4f20: 20 22 45 52 52 4f 52 3a 20 4e 6f 20 73 65 73 73 "ERROR: No sess
4f30: 69 6f 6e 20 69 64 20 69 6e 20 73 65 73 73 69 6f ion id in sessio
4f40: 6e 20 6f 62 6a 65 63 74 21 20 73 65 73 73 69 6f n object! sessio
4f50: 6e 3a 67 65 74 2d 76 61 72 73 22 29 0a 09 28 6c n:get-vars")..(l
4f60: 65 74 2a 20 28 28 73 74 61 74 75 73 20 20 20 20 et* ((status
4f70: 20 20 23 66 29 0a 09 20 20 20 20 20 20 20 28 63 #f).. (c
4f80: 6f 6e 6e 20 20 20 20 20 20 20 20 28 73 64 61 74 onn (sdat
4f90: 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 -get-conn self))
4fa0: 0a 09 20 20 20 20 20 20 20 28 70 61 67 65 2d 6e .. (page-n
4fb0: 61 6d 65 20 20 20 28 73 64 61 74 2d 67 65 74 2d ame (sdat-get-
4fc0: 70 61 67 65 20 73 65 6c 66 29 29 0a 09 20 20 20 page self))..
4fd0: 20 20 20 20 28 64 65 6c 2d 71 75 65 72 79 20 20 (del-query
4fe0: 20 22 44 45 4c 45 54 45 20 46 52 4f 4d 20 73 65 "DELETE FROM se
4ff0: 73 73 69 6f 6e 5f 76 61 72 73 20 57 48 45 52 45 ssion_vars WHERE
5000: 20 73 65 73 73 69 6f 6e 5f 69 64 3d 3f 20 41 4e session_id=? AN
5010: 44 20 70 61 67 65 3d 3f 20 41 4e 44 20 6b 65 79 D page=? AND key
5020: 3d 3f 3b 22 29 0a 09 20 20 20 20 20 20 20 28 69 =?;").. (i
5030: 6e 73 2d 71 75 65 72 79 20 20 20 22 49 4e 53 45 ns-query "INSE
5040: 52 54 20 49 4e 54 4f 20 73 65 73 73 69 6f 6e 5f RT INTO session_
5050: 76 61 72 73 20 28 73 65 73 73 69 6f 6e 5f 69 64 vars (session_id
5060: 2c 70 61 67 65 2c 6b 65 79 2c 76 61 6c 75 65 29 ,page,key,value)
5070: 20 56 41 4c 55 45 53 28 3f 2c 3f 2c 3f 2c 3f 29 VALUES(?,?,?,?)
5080: 3b 22 29 0a 09 20 20 20 20 20 20 20 28 75 70 64 ;").. (upd
5090: 2d 71 75 65 72 79 20 20 20 22 55 50 44 41 54 45 -query "UPDATE
50a0: 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 73 65 session_vars se
50b0: 74 20 76 61 6c 75 65 3d 3f 20 57 48 45 52 45 20 t value=? WHERE
50c0: 6b 65 79 3d 3f 20 41 4e 44 20 73 65 73 73 69 6f key=? AND sessio
50d0: 6e 5f 69 64 3d 3f 20 41 4e 44 20 70 61 67 65 3d n_id=? AND page=
50e0: 3f 3b 22 29 0a 09 20 20 20 20 20 20 20 28 63 68 ?;").. (ch
50f0: 61 6e 67 65 64 2d 63 6f 75 6e 74 20 30 29 29 0a anged-count 0)).
5100: 09 20 20 3b 3b 20 73 61 76 65 20 74 68 65 20 64 . ;; save the d
5110: 65 6c 74 61 20 6f 6e 6c 79 0a 09 20 20 28 66 6f elta only.. (fo
5120: 72 2d 65 61 63 68 0a 09 20 20 20 28 6c 61 6d 62 r-each.. (lamb
5130: 64 61 20 28 70 61 67 65 29 20 3b 3b 20 70 61 67 da (page) ;; pag
5140: 65 20 69 73 3a 20 22 2a 67 6c 6f 62 61 6c 76 61 e is: "*globalva
5150: 72 73 2a 22 20 22 2a 73 65 73 73 69 6f 6e 76 61 rs*" "*sessionva
5160: 72 73 2a 22 20 6f 72 20 6f 74 68 65 72 73 74 72 rs*" or otherstr
5170: 69 6e 67 0a 09 20 20 20 20 20 28 6c 65 74 2a 20 ing.. (let*
5180: 28 28 62 65 66 6f 72 65 2d 61 66 74 65 72 2d 68 ((before-after-h
5190: 74 20 28 63 6f 6e 64 0a 09 09 09 09 20 20 20 20 t (cond.....
51a0: 20 20 28 28 73 74 72 69 6e 67 3d 3f 20 70 61 67 ((string=? pag
51b0: 65 20 22 2a 73 65 73 73 69 6f 6e 76 61 72 73 2a e "*sessionvars*
51c0: 22 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 76 ")..... (v
51d0: 65 63 74 6f 72 20 28 73 64 61 74 2d 67 65 74 2d ector (sdat-get-
51e0: 73 65 73 73 69 6f 6e 76 61 72 73 20 73 65 6c 66 sessionvars self
51f0: 29 0a 09 09 09 09 09 20 20 20 20 20 20 20 28 73 )...... (s
5200: 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 dat-get-sessionv
5210: 61 72 73 2d 62 65 66 6f 72 65 20 73 65 6c 66 29 ars-before self)
5220: 29 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 28 ))..... ((
5230: 73 74 72 69 6e 67 3d 3f 20 70 61 67 65 20 22 2a string=? page "*
5240: 67 6c 6f 62 61 6c 76 61 72 73 2a 22 29 0a 09 09 globalvars*")...
5250: 09 09 09 28 76 65 63 74 6f 72 20 28 73 64 61 74 ...(vector (sdat
5260: 2d 67 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 20 -get-globalvars
5270: 73 65 6c 66 29 0a 09 09 09 09 09 09 28 73 64 61 self).......(sda
5280: 74 2d 67 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 t-get-globalvars
5290: 2d 62 65 66 6f 72 65 20 73 65 6c 66 29 29 29 0a -before self))).
52a0: 09 09 09 09 20 20 20 20 20 20 20 28 65 6c 73 65 .... (else
52b0: 20 0a 09 09 09 09 09 28 76 65 63 74 6f 72 20 28 ......(vector (
52c0: 73 64 61 74 2d 67 65 74 2d 70 61 67 65 76 61 72 sdat-get-pagevar
52d0: 73 20 73 65 6c 66 29 0a 09 09 09 09 09 09 28 73 s self).......(s
52e0: 64 61 74 2d 67 65 74 2d 70 61 67 65 76 61 72 73 dat-get-pagevars
52f0: 2d 62 65 66 6f 72 65 20 73 65 6c 66 29 29 29 29 -before self))))
5300: 29 0a 09 09 20 20 20 20 28 6d 61 73 74 65 72 2d )... (master-
5310: 68 74 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 ht (vector-ref
5320: 20 62 65 66 6f 72 65 2d 61 66 74 65 72 2d 68 74 before-after-ht
5330: 20 30 29 29 0a 09 09 20 20 20 20 28 62 65 66 6f 0))... (befo
5340: 72 65 2d 68 74 20 20 20 28 76 65 63 74 6f 72 2d re-ht (vector-
5350: 72 65 66 20 62 65 66 6f 72 65 2d 61 66 74 65 72 ref before-after
5360: 2d 68 74 20 31 29 29 0a 09 09 20 20 20 20 28 6d -ht 1))... (m
5370: 61 73 74 65 72 2d 6b 65 79 73 20 28 68 61 73 68 aster-keys (hash
5380: 2d 74 61 62 6c 65 2d 6b 65 79 73 20 6d 61 73 74 -table-keys mast
5390: 65 72 2d 68 74 29 29 0a 09 09 20 20 20 20 28 62 er-ht))... (b
53a0: 65 66 6f 72 65 2d 6b 65 79 73 20 28 68 61 73 68 efore-keys (hash
53b0: 2d 74 61 62 6c 65 2d 6b 65 79 73 20 62 65 66 6f -table-keys befo
53c0: 72 65 2d 68 74 29 29 0a 09 09 20 20 20 20 28 61 re-ht))... (a
53d0: 6c 6c 2d 6b 65 79 73 20 28 64 65 6c 65 74 65 2d ll-keys (delete-
53e0: 64 75 70 6c 69 63 61 74 65 73 20 28 61 70 70 65 duplicates (appe
53f0: 6e 64 20 6d 61 73 74 65 72 2d 6b 65 79 73 20 62 nd master-keys b
5400: 65 66 6f 72 65 2d 6b 65 79 73 29 29 29 29 0a 09 efore-keys))))..
5410: 20 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 (for-each
5420: 20 0a 09 09 28 6c 61 6d 62 64 61 20 28 6b 65 79 ...(lambda (key
5430: 29 0a 09 09 20 20 28 6c 65 74 20 28 28 6d 61 73 )... (let ((mas
5440: 74 65 72 2d 76 61 6c 75 65 20 28 68 61 73 68 2d ter-value (hash-
5450: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
5460: 74 20 6d 61 73 74 65 72 2d 68 74 20 6b 65 79 20 t master-ht key
5470: 23 66 29 29 0a 09 09 09 28 62 65 66 6f 72 65 2d #f))....(before-
5480: 76 61 6c 75 65 20 28 68 61 73 68 2d 74 61 62 6c value (hash-tabl
5490: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 62 65 e-ref/default be
54a0: 66 6f 72 65 2d 68 74 20 6b 65 79 20 23 66 29 29 fore-ht key #f))
54b0: 29 0a 09 09 20 20 20 20 28 63 6f 6e 64 0a 09 09 )... (cond...
54c0: 20 20 20 20 20 3b 3b 20 62 65 66 6f 72 65 20 61 ;; before a
54d0: 6e 64 20 61 66 74 65 72 20 65 78 69 73 74 20 61 nd after exist a
54e0: 6e 64 20 76 61 6c 75 65 20 75 6e 63 68 61 6e 67 nd value unchang
54f0: 65 64 20 2d 20 64 6f 20 6e 6f 74 68 69 6e 67 0a ed - do nothing.
5500: 09 09 20 20 20 20 20 28 28 61 6e 64 20 6d 61 73 .. ((and mas
5510: 74 65 72 2d 76 61 6c 75 65 20 62 65 66 6f 72 65 ter-value before
5520: 2d 76 61 6c 75 65 20 28 65 71 75 61 6c 3f 20 6d -value (equal? m
5530: 61 73 74 65 72 2d 76 61 6c 75 65 20 62 65 66 6f aster-value befo
5540: 72 65 2d 76 61 6c 75 65 29 29 29 0a 09 09 20 20 re-value)))...
5550: 20 20 20 3b 3b 20 62 65 66 6f 72 65 20 61 6e 64 ;; before and
5560: 20 61 66 74 65 72 20 65 78 69 73 74 20 62 75 74 after exist but
5570: 20 61 72 65 20 63 68 61 6e 67 65 64 0a 09 09 20 are changed...
5580: 20 20 20 20 28 28 61 6e 64 20 6d 61 73 74 65 72 ((and master
5590: 2d 76 61 6c 75 65 20 62 65 66 6f 72 65 2d 76 61 -value before-va
55a0: 6c 75 65 29 0a 09 09 20 20 20 20 20 20 28 64 62 lue)... (db
55b0: 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 28 i:for-each-row (
55c0: 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 29 0a 09 lambda (tuple)..
55d0: 09 09 09 09 20 20 28 73 65 74 21 20 63 68 61 6e .... (set! chan
55e0: 67 65 64 2d 63 6f 75 6e 74 20 28 2b 20 63 68 61 ged-count (+ cha
55f0: 6e 67 65 64 2d 63 6f 75 6e 74 20 31 29 29 29 0a nged-count 1))).
5600: 09 09 09 09 09 63 6f 6e 6e 0a 09 09 09 09 09 28 .....conn......(
5610: 73 3a 73 71 6c 70 61 72 61 6d 20 75 70 64 2d 71 s:sqlparam upd-q
5620: 75 65 72 79 20 6d 61 73 74 65 72 2d 76 61 6c 75 uery master-valu
5630: 65 20 6b 65 79 20 73 65 73 73 69 6f 6e 2d 69 64 e key session-id
5640: 20 70 61 67 65 29 29 29 0a 09 09 20 20 20 20 20 page)))...
5650: 3b 3b 20 6d 61 73 74 65 72 2d 76 61 6c 75 65 20 ;; master-value
5660: 6e 6f 20 6c 6f 6e 67 65 72 20 65 78 69 73 74 73 no longer exists
5670: 20 28 69 2e 65 2e 20 23 66 29 20 2d 20 72 65 6d (i.e. #f) - rem
5680: 6f 76 65 20 69 74 65 6d 0a 09 09 20 20 20 20 20 ove item...
5690: 28 28 6e 6f 74 20 6d 61 73 74 65 72 2d 76 61 6c ((not master-val
56a0: 75 65 29 0a 09 09 20 20 20 20 20 20 28 64 62 69 ue)... (dbi
56b0: 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 28 6c :for-each-row (l
56c0: 61 6d 62 64 61 20 28 74 75 70 6c 65 29 0a 09 09 ambda (tuple)...
56d0: 09 09 09 20 20 28 73 65 74 21 20 63 68 61 6e 67 ... (set! chang
56e0: 65 64 2d 63 6f 75 6e 74 20 28 2b 20 63 68 61 6e ed-count (+ chan
56f0: 67 65 64 2d 63 6f 75 6e 74 20 31 29 29 29 0a 09 ged-count 1)))..
5700: 09 09 09 09 63 6f 6e 6e 0a 09 09 09 09 09 28 73 ....conn......(s
5710: 3a 73 71 6c 70 61 72 61 6d 20 64 65 6c 2d 71 75 :sqlparam del-qu
5720: 65 72 79 20 73 65 73 73 69 6f 6e 2d 69 64 20 70 ery session-id p
5730: 61 67 65 20 6b 65 79 29 29 29 0a 09 09 20 20 20 age key)))...
5740: 20 20 3b 3b 20 62 65 66 6f 72 65 2d 76 61 6c 75 ;; before-valu
5750: 65 20 64 6f 65 73 6e 27 74 20 65 78 69 73 74 20 e doesn't exist
5760: 2d 20 69 6e 73 65 72 74 20 61 20 6e 65 77 20 76 - insert a new v
5770: 61 6c 75 65 0a 09 09 20 20 20 20 20 28 28 6e 6f alue... ((no
5780: 74 20 62 65 66 6f 72 65 2d 76 61 6c 75 65 29 0a t before-value).
5790: 09 09 20 20 20 20 20 20 28 64 62 69 3a 66 6f 72 .. (dbi:for
57a0: 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 6d 62 64 -each-row (lambd
57b0: 61 20 28 74 75 70 6c 65 29 0a 09 09 09 09 09 20 a (tuple)......
57c0: 20 28 73 65 74 21 20 63 68 61 6e 67 65 64 2d 63 (set! changed-c
57d0: 6f 75 6e 74 20 28 2b 20 63 68 61 6e 67 65 64 2d ount (+ changed-
57e0: 63 6f 75 6e 74 20 31 29 29 29 0a 09 09 09 09 09 count 1)))......
57f0: 63 6f 6e 6e 0a 09 09 09 09 09 28 73 3a 73 71 6c conn......(s:sql
5800: 70 61 72 61 6d 20 69 6e 73 2d 71 75 65 72 79 20 param ins-query
5810: 73 65 73 73 69 6f 6e 2d 69 64 20 70 61 67 65 20 session-id page
5820: 6b 65 79 20 6d 61 73 74 65 72 2d 76 61 6c 75 65 key master-value
5830: 29 29 29 0a 09 09 20 20 20 20 20 28 65 6c 73 65 )))... (else
5840: 20 28 65 72 72 3a 6c 6f 67 20 22 53 68 6f 75 6c (err:log "Shoul
5850: 64 6e 27 74 20 67 65 74 20 68 65 72 65 22 29 29 dn't get here"))
5860: 29 29 29 0a 09 09 61 6c 6c 2d 6b 65 79 73 29 29 )))...all-keys))
5870: 29 20 3b 3b 20 70 72 6f 63 65 73 73 20 61 6c 6c ) ;; process all
5880: 20 6b 65 79 73 0a 09 20 20 20 28 6c 69 73 74 20 keys.. (list
5890: 22 2a 73 65 73 73 69 6f 6e 76 61 72 73 2a 22 20 "*sessionvars*"
58a0: 22 2a 67 6c 6f 62 61 6c 76 61 72 73 2a 22 20 70 "*globalvars*" p
58b0: 61 67 65 2d 6e 61 6d 65 29 29 29 29 29 29 0a 0a age-name))))))..
58c0: 3b 3b 20 28 70 67 3a 73 71 6c 2d 6e 75 6c 6c 2d ;; (pg:sql-null-
58d0: 6f 62 6a 65 63 74 3f 20 65 6c 65 6d 65 6e 74 29 object? element)
58e0: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
58f0: 6e 3a 72 65 61 64 2d 63 6f 6e 66 69 67 20 73 65 n:read-config se
5900: 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 6e 61 6d lf). (let ((nam
5910: 65 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 e (string-append
5920: 20 22 2e 22 20 28 70 61 74 68 6e 61 6d 65 2d 66 "." (pathname-f
5930: 69 6c 65 20 28 63 61 72 20 28 61 72 67 76 29 29 ile (car (argv))
5940: 29 20 22 2e 63 6f 6e 66 69 67 22 29 29 29 0a 20 ) ".config"))).
5950: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 66 69 6c (if (not (fil
5960: 65 2d 65 78 69 73 74 73 3f 20 6e 61 6d 65 29 29 e-exists? name))
5970: 0a 09 28 70 72 69 6e 74 20 6e 61 6d 65 20 22 20 ..(print name "
5980: 6e 6f 74 20 66 6f 75 6e 64 20 61 74 20 22 20 28 not found at " (
5990: 63 75 72 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 current-director
59a0: 79 29 29 0a 09 28 6c 65 74 2a 20 28 28 66 70 20 y))..(let* ((fp
59b0: 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 66 69 6c 65 (open-input-file
59c0: 20 6e 61 6d 65 29 29 0a 09 20 20 20 20 20 20 20 name))..
59d0: 28 69 6e 69 74 61 72 67 73 20 28 72 65 61 64 20 (initargs (read
59e0: 66 70 29 29 29 0a 09 20 20 28 63 6c 6f 73 65 2d fp))).. (close-
59f0: 69 6e 70 75 74 2d 70 6f 72 74 20 66 70 29 0a 09 input-port fp)..
5a00: 20 20 69 6e 69 74 61 72 67 73 29 29 29 29 0a 0a initargs))))..
5a10: 3b 3b 20 63 61 6c 6c 20 74 68 65 20 63 6f 6e 74 ;; call the cont
5a20: 72 6f 6c 6c 65 72 20 69 66 20 69 74 20 65 78 69 roller if it exi
5a30: 73 74 73 0a 3b 3b 20 0a 3b 3b 20 57 41 52 4e 49 sts.;; .;; WARNI
5a40: 4e 47 20 2d 20 74 68 69 73 20 63 6f 64 65 20 6e NG - this code n
5a50: 65 65 64 73 20 61 20 64 65 66 65 6e 63 65 20 61 eeds a defence a
5a60: 67 61 69 6e 73 20 72 65 63 75 72 73 69 76 65 20 gains recursive
5a70: 63 61 6c 6c 69 6e 67 21 21 21 21 21 0a 3b 3b 0a calling!!!!!.;;.
5a80: 3b 3b 20 20 20 49 20 73 75 67 67 65 73 74 20 61 ;; I suggest a
5a90: 20 6c 69 6d 69 74 20 6f 66 20 31 30 30 20 63 61 limit of 100 ca
5aa0: 6c 6c 73 2e 20 50 6c 65 6e 74 79 20 66 6f 72 20 lls. Plenty for
5ab0: 61 6c 6c 6f 77 69 6e 67 20 6d 75 6c 74 69 70 6c allowing multipl
5ac0: 65 20 69 6e 73 74 61 6e 63 65 73 0a 3b 3b 20 20 e instances.;;
5ad0: 20 6f 66 20 61 20 70 61 67 65 20 69 6e 73 69 64 of a page insid
5ae0: 65 20 61 6e 6f 74 68 65 72 20 70 61 67 65 2e 20 e another page.
5af0: 0a 3b 3b 0a 3b 3b 20 70 61 72 74 73 20 3d 20 27 .;;.;; parts = '
5b00: 62 6f 74 68 20 7c 20 27 63 6f 6e 74 72 6f 6c 20 both | 'control
5b10: 7c 20 27 76 69 65 77 0a 3b 3b 0a 0a 28 64 65 66 | 'view.;;..(def
5b20: 69 6e 65 20 28 66 69 6c 65 73 2d 72 65 61 64 2d ine (files-read-
5b30: 3e 73 74 72 69 6e 67 20 2e 20 66 69 6c 65 73 29 >string . files)
5b40: 0a 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 . (string-inter
5b50: 73 70 65 72 73 65 20 0a 20 20 20 28 61 70 70 6c sperse . (appl
5b60: 79 20 61 70 70 65 6e 64 20 28 6d 61 70 20 66 69 y append (map fi
5b70: 6c 65 2d 72 65 61 64 2d 3e 73 74 72 69 6e 67 20 le-read->string
5b80: 66 69 6c 65 73 29 29 20 22 5c 6e 22 29 29 0a 0a files)) "\n"))..
5b90: 28 64 65 66 69 6e 65 20 28 66 69 6c 65 2d 72 65 (define (file-re
5ba0: 61 64 2d 3e 73 74 72 69 6e 67 20 66 29 20 0a 20 ad->string f) .
5bb0: 20 28 6c 65 74 20 28 28 70 20 28 6f 70 65 6e 2d (let ((p (open-
5bc0: 69 6e 70 75 74 2d 66 69 6c 65 20 66 29 29 29 0a input-file f))).
5bd0: 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 (let loop ((
5be0: 68 65 64 20 28 72 65 61 64 2d 6c 69 6e 65 20 70 hed (read-line p
5bf0: 29 29 0a 09 20 20 20 20 20 20 20 28 72 65 73 20 )).. (res
5c00: 27 28 29 29 29 0a 20 20 20 20 20 20 28 69 66 20 '())). (if
5c10: 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 68 65 64 (eof-object? hed
5c20: 29 0a 09 20 20 72 65 73 0a 09 20 20 28 6c 6f 6f ).. res.. (loo
5c30: 70 20 28 72 65 61 64 2d 6c 69 6e 65 20 70 29 28 p (read-line p)(
5c40: 61 70 70 65 6e 64 20 72 65 73 20 28 6c 69 73 74 append res (list
5c50: 20 68 65 64 29 29 29 29 29 29 29 0a 0a 3b 3b 20 hed)))))))..;;
5c60: 4d 61 79 20 32 30 31 31 2c 20 70 75 74 74 69 6e May 2011, puttin
5c70: 67 20 61 6c 6c 20 70 61 67 65 73 20 69 6e 74 6f g all pages into
5c80: 20 6f 6e 65 20 64 69 72 65 63 74 6f 72 79 20 66 one directory f
5c90: 6f 72 20 74 68 65 20 66 6f 6c 6c 6f 77 69 6e 67 or the following
5ca0: 20 72 65 61 73 6f 6e 73 3a 0a 3b 3b 20 20 20 31 reasons:.;; 1
5cb0: 2e 20 77 61 6e 74 20 66 69 6c 65 6e 61 6d 65 20 . want filename
5cc0: 74 6f 20 72 65 66 6c 65 63 74 20 70 61 67 65 20 to reflect page
5cd0: 6e 61 6d 65 20 28 65 6d 61 63 73 20 6c 69 6d 69 name (emacs limi
5ce0: 74 61 74 69 6f 6e 29 0a 3b 3b 20 20 20 32 2e 20 tation).;; 2.
5cf0: 74 68 61 74 27 73 20 69 74 21 20 6e 6f 20 6f 74 that's it! no ot
5d00: 68 65 72 20 72 65 61 73 6f 6e 2e 20 63 6f 75 6c her reason. coul
5d10: 64 20 6d 61 6b 65 20 69 74 20 63 6f 6e 66 69 67 d make it config
5d20: 75 72 61 62 6c 65 20 2e 2e 2e 0a 28 64 65 66 69 urable ....(defi
5d30: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 63 61 6c 6c ne (session:call
5d40: 2d 70 61 72 74 73 20 73 65 6c 66 20 70 61 67 65 -parts self page
5d50: 20 70 61 72 74 73 29 0a 20 20 28 73 64 61 74 2d parts). (sdat-
5d60: 73 65 74 2d 63 75 72 72 2d 70 61 67 65 21 20 73 set-curr-page! s
5d70: 65 6c 66 20 70 61 67 65 29 0a 20 20 3b 3b 20 28 elf page). ;; (
5d80: 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 session:log self
5d90: 20 22 70 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 "page-dir-style
5da0: 3a 20 22 20 28 73 64 61 74 2d 67 65 74 2d 70 61 : " (sdat-get-pa
5db0: 67 65 2d 64 69 72 2d 73 74 79 6c 65 20 73 65 6c ge-dir-style sel
5dc0: 66 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 69 f)). (let* ((di
5dd0: 72 2d 73 74 79 6c 65 20 3b 3b 20 28 65 71 75 61 r-style ;; (equa
5de0: 6c 3f 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 l? (sdat-get-pag
5df0: 65 2d 64 69 72 2d 73 74 79 6c 65 20 73 65 6c 66 e-dir-style self
5e00: 29 20 22 6f 6e 65 64 69 72 22 29 29 20 3b 3b 20 ) "onedir")) ;;
5e10: 66 6c 61 67 20 23 74 20 66 6f 72 20 6f 6e 65 64 flag #t for oned
5e20: 69 72 2c 20 23 66 20 66 6f 72 20 6f 6c 64 20 73 ir, #f for old s
5e30: 74 79 6c 65 0a 09 20 20 28 73 64 61 74 2d 67 65 tyle.. (sdat-ge
5e40: 74 2d 70 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 t-page-dir-style
5e50: 20 73 65 6c 66 29 29 0a 09 20 28 64 69 72 20 20 self)).. (dir
5e60: 20 20 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e (string-appen
5e70: 64 20 28 73 64 61 74 2d 67 65 74 2d 73 72 6f 6f d (sdat-get-sroo
5e80: 74 20 73 65 6c 66 29 20 0a 09 09 09 09 20 28 69 t self) ..... (i
5e90: 66 20 64 69 72 2d 73 74 79 6c 65 20 0a 09 09 09 f dir-style ....
5ea0: 09 20 20 20 20 20 28 63 6f 6e 63 20 22 2f 70 61 . (conc "/pa
5eb0: 67 65 73 2f 22 29 0a 09 09 09 09 20 20 20 20 20 ges/").....
5ec0: 28 63 6f 6e 63 20 22 2f 70 61 67 65 73 2f 22 20 (conc "/pages/"
5ed0: 70 61 67 65 29 29 29 29 0a 09 20 28 63 6f 6e 74 page)))).. (cont
5ee0: 72 6f 6c 20 28 73 74 72 69 6e 67 2d 61 70 70 65 rol (string-appe
5ef0: 6e 64 20 64 69 72 20 28 69 66 20 64 69 72 2d 73 nd dir (if dir-s
5f00: 74 79 6c 65 20 0a 09 09 09 09 09 20 28 63 6f 6e tyle ...... (con
5f10: 63 20 70 61 67 65 20 22 5f 63 74 72 6c 2e 73 63 c page "_ctrl.sc
5f20: 6d 22 29 0a 09 09 09 09 09 20 22 2f 63 6f 6e 74 m")...... "/cont
5f30: 72 6f 6c 2e 73 63 6d 22 29 29 29 0a 09 20 28 76 rol.scm"))).. (v
5f40: 69 65 77 20 20 20 20 28 73 74 72 69 6e 67 2d 61 iew (string-a
5f50: 70 70 65 6e 64 20 64 69 72 20 28 69 66 20 64 69 ppend dir (if di
5f60: 72 2d 73 74 79 6c 65 20 0a 09 09 09 09 09 20 28 r-style ...... (
5f70: 63 6f 6e 63 20 70 61 67 65 20 22 5f 76 69 65 77 conc page "_view
5f80: 2e 73 63 6d 22 29 0a 09 09 09 09 09 20 22 2f 76 .scm")...... "/v
5f90: 69 65 77 2e 73 63 6d 22 29 29 29 0a 09 20 28 6c iew.scm"))).. (l
5fa0: 6f 61 64 2d 76 69 65 77 20 20 20 20 28 61 6e 64 oad-view (and
5fb0: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 76 (file-exists? v
5fc0: 69 65 77 29 0a 09 09 09 20 20 20 20 28 6f 72 20 iew).... (or
5fd0: 28 65 71 3f 20 70 61 72 74 73 20 27 62 6f 74 68 (eq? parts 'both
5fe0: 29 28 65 71 3f 20 70 61 72 74 73 20 27 76 69 65 )(eq? parts 'vie
5ff0: 77 29 29 29 29 0a 09 20 28 6c 6f 61 64 2d 63 6f w)))).. (load-co
6000: 6e 74 72 6f 6c 20 28 61 6e 64 20 28 66 69 6c 65 ntrol (and (file
6010: 2d 65 78 69 73 74 73 3f 20 63 6f 6e 74 72 6f 6c -exists? control
6020: 29 0a 09 09 09 20 20 20 20 28 6f 72 20 28 65 71 ).... (or (eq
6030: 3f 20 70 61 72 74 73 20 27 62 6f 74 68 29 28 65 ? parts 'both)(e
6040: 71 3f 20 70 61 72 74 73 20 27 63 6f 6e 74 72 6f q? parts 'contro
6050: 6c 29 29 29 29 0a 09 20 28 76 69 65 77 2d 64 61 l)))).. (view-da
6060: 74 20 20 20 27 28 29 29 29 0a 20 20 20 20 3b 3b t '())). ;;
6070: 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 (session:log se
6080: 6c 66 20 22 64 69 72 2d 73 74 79 6c 65 3a 20 22 lf "dir-style: "
6090: 20 64 69 72 2d 73 74 79 6c 65 29 0a 20 3b 3b 20 dir-style). ;;
60a0: 20 20 28 73 75 67 61 72 20 22 2f 68 6f 6d 65 2f (sugar "/home/
60b0: 6d 61 74 74 2f 6b 69 61 74 6f 61 2f 73 74 6d 6c matt/kiatoa/stml
60c0: 2f 73 75 67 61 72 2e 73 63 6d 22 20 29 29 0a 20 /sugar.scm" )).
60d0: 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 64 69 ;; (print "di
60e0: 72 3d 22 20 64 69 72 20 22 20 63 6f 6e 74 72 6f r=" dir " contro
60f0: 6c 3d 22 20 63 6f 6e 74 72 6f 6c 20 22 20 76 69 l=" control " vi
6100: 65 77 3d 22 20 76 69 65 77 20 22 20 6c 6f 61 64 ew=" view " load
6110: 2d 76 69 65 77 3d 22 20 6c 6f 61 64 2d 76 69 65 -view=" load-vie
6120: 77 20 22 20 6c 6f 61 64 3d 63 6f 6e 74 72 6f 6c w " load=control
6130: 3d 22 20 6c 6f 61 64 2d 63 6f 6e 74 72 6f 6c 29 =" load-control)
6140: 0a 20 20 20 20 28 69 66 20 6c 6f 61 64 2d 63 6f . (if load-co
6150: 6e 74 72 6f 6c 0a 09 28 62 65 67 69 6e 0a 09 20 ntrol..(begin..
6160: 20 28 6c 6f 61 64 20 63 6f 6e 74 72 6f 6c 29 0a (load control).
6170: 09 20 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 2d . (session:set-
6180: 63 61 6c 6c 65 64 21 20 73 65 6c 66 20 70 61 67 called! self pag
6190: 65 29 29 29 0a 20 20 20 20 3b 3b 20 6d 6f 76 65 e))). ;; move
61a0: 20 74 68 69 73 20 74 6f 20 77 68 65 72 65 20 69 this to where i
61b0: 74 20 67 65 74 73 20 65 78 65 63 74 75 74 65 64 t gets exectuted
61c0: 20 6f 6e 6c 79 20 6f 6e 63 65 0a 20 20 20 20 3b only once. ;
61d0: 3b 0a 20 20 20 20 28 69 66 20 6c 6f 61 64 2d 76 ;. (if load-v
61e0: 69 65 77 0a 09 3b 3b 20 6f 70 74 69 6f 6e 20 6f iew..;; option o
61f0: 6e 65 2e 3a 0a 09 3b 3b 0a 09 3b 3b 20 28 6c 65 ne.:..;;..;; (le
6200: 74 20 28 28 69 6e 70 20 28 6f 70 65 6e 2d 69 6e t ((inp (open-in
6210: 70 75 74 2d 73 74 72 69 6e 67 20 0a 09 3b 3b 20 put-string ..;;
6220: 09 20 20 20 20 28 66 69 6c 65 73 2d 72 65 61 64 . (files-read
6230: 2d 3e 73 74 72 69 6e 67 20 22 2f 68 6f 6d 65 2f ->string "/home/
6240: 6d 61 74 74 2f 6b 69 61 74 6f 61 2f 73 74 6d 6c matt/kiatoa/stml
6250: 2f 73 75 67 61 72 2e 73 63 6d 22 20 0a 09 3b 3b /sugar.scm" ..;;
6260: 20 09 09 09 09 76 69 65 77 29 29 29 29 0a 09 3b ....view))))..;
6270: 3b 20 20 20 28 6d 61 70 20 0a 09 3b 3b 20 20 20 ; (map ..;;
6280: 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 3b 3b (lambda (x)..;;
6290: 20 20 20 20 20 20 28 63 6f 6e 64 0a 09 3b 3b 20 (cond..;;
62a0: 20 20 20 20 20 20 28 28 6c 69 73 74 3f 20 78 29 ((list? x)
62b0: 20 78 29 0a 09 3b 3b 20 20 20 20 20 20 20 28 28 x)..;; ((
62c0: 73 74 72 69 6e 67 3f 20 78 29 20 78 29 0a 09 3b string? x) x)..;
62d0: 3b 20 20 20 20 20 20 20 28 65 6c 73 65 20 27 28 ; (else '(
62e0: 29 29 29 29 0a 09 3b 3b 20 20 20 20 28 70 6f 72 ))))..;; (por
62f0: 74 2d 6d 61 70 20 65 76 61 6c 20 28 6c 61 6d 62 t-map eval (lamb
6300: 64 61 20 28 29 0a 09 3b 3b 20 09 09 20 28 72 65 da ()..;; .. (re
6310: 61 64 20 69 6e 70 29 29 29 29 29 0a 09 3b 3b 0a ad inp)))))..;;.
6320: 09 3b 3b 20 6f 70 74 69 6f 6e 20 74 77 6f 3a 0a .;; option two:.
6330: 09 3b 3b 0a 09 28 6c 65 74 2a 20 28 3b 3b 20 28 .;;..(let* (;; (
6340: 69 6e 70 73 20 28 6d 61 70 20 6f 70 65 6e 2d 69 inps (map open-i
6350: 6e 70 75 74 2d 66 69 6c 65 20 28 6c 69 73 74 20 nput-file (list
6360: 76 69 65 77 29 29 29 20 3b 3b 20 73 75 67 61 72 view))) ;; sugar
6370: 20 76 69 65 77 29 29 29 0a 09 20 20 20 20 20 20 view)))..
6380: 20 28 70 20 20 20 20 28 6f 70 65 6e 2d 69 6e 70 (p (open-inp
6390: 75 74 2d 66 69 6c 65 20 76 69 65 77 29 29 20 3b ut-file view)) ;
63a0: 3b 20 28 61 70 70 6c 79 20 6d 61 6b 65 2d 63 6f ; (apply make-co
63b0: 6e 63 61 74 65 6e 61 74 65 64 2d 70 6f 72 74 20 ncatenated-port
63c0: 69 6e 70 73 29 29 0a 09 20 20 20 20 20 20 20 28 inps)).. (
63d0: 64 61 74 20 20 28 6d 61 70 20 0a 09 09 20 20 20 dat (map ...
63e0: 20 20 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 (lambda (x)..
63f0: 09 09 28 63 6f 6e 64 0a 09 09 09 20 28 28 6c 69 ..(cond.... ((li
6400: 73 74 3f 20 78 29 20 78 29 0a 09 09 09 20 28 28 st? x) x).... ((
6410: 73 74 72 69 6e 67 3f 20 78 29 20 78 29 0a 09 09 string? x) x)...
6420: 09 20 28 65 6c 73 65 20 27 28 29 29 29 29 0a 09 . (else '())))..
6430: 09 20 20 20 20 20 20 28 70 6f 72 74 2d 6d 61 70 . (port-map
6440: 20 65 76 61 6c 20 28 6c 61 6d 62 64 61 20 28 29 eval (lambda ()
6450: 28 72 65 61 64 20 70 29 29 29 29 29 29 0a 09 20 (read p))))))..
6460: 20 3b 3b 20 28 6d 61 70 20 63 6c 6f 73 65 2d 69 ;; (map close-i
6470: 6e 70 75 74 2d 70 6f 72 74 20 69 6e 70 73 29 0a nput-port inps).
6480: 09 20 20 28 63 6c 6f 73 65 2d 69 6e 70 75 74 2d . (close-input-
6490: 70 6f 72 74 20 70 29 0a 09 20 20 64 61 74 29 0a port p).. dat).
64a0: 09 28 6c 69 73 74 20 22 3c 70 3e 50 61 67 65 20 .(list "<p>Page
64b0: 6e 6f 74 20 66 6f 75 6e 64 20 22 20 70 61 67 65 not found " page
64c0: 20 22 20 3c 2f 70 3e 22 29 29 29 29 0a 0a 28 64 " </p>"))))..(d
64d0: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 63 efine (session:c
64e0: 61 6c 6c 20 73 65 6c 66 20 70 61 67 65 29 0a 20 all self page).
64f0: 20 28 73 65 73 73 69 6f 6e 3a 63 61 6c 6c 2d 70 (session:call-p
6500: 61 72 74 73 20 73 65 6c 66 20 70 61 67 65 20 27 arts self page '
6510: 62 6f 74 68 29 29 0a 0a 28 64 65 66 69 6e 65 20 both))..(define
6520: 28 73 65 73 73 69 6f 6e 3a 63 61 6c 6c 20 73 65 (session:call se
6530: 6c 66 20 70 61 67 65 20 70 61 72 74 73 29 0a 20 lf page parts).
6540: 20 28 73 65 73 73 69 6f 6e 3a 63 61 6c 6c 2d 70 (session:call-p
6550: 61 72 74 73 20 73 65 6c 66 20 70 61 67 65 20 27 arts self page '
6560: 62 6f 74 68 29 29 0a 0a 28 64 65 66 69 6e 65 20 both))..(define
6570: 28 73 65 73 73 69 6f 6e 3a 6c 6f 61 64 2d 6d 6f (session:load-mo
6580: 64 65 6c 20 73 65 6c 66 20 6d 6f 64 65 6c 29 0a del self model).
6590: 20 20 28 6c 65 74 20 28 28 6d 6f 64 65 6c 2e 73 (let ((model.s
65a0: 63 6d 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e cm (string-appen
65b0: 64 20 28 73 64 61 74 2d 67 65 74 2d 73 72 6f 6f d (sdat-get-sroo
65c0: 74 20 73 65 6c 66 29 20 22 2f 6d 6f 64 65 6c 73 t self) "/models
65d0: 2f 22 20 6d 6f 64 65 6c 20 22 2e 73 63 6d 22 29 /" model ".scm")
65e0: 29 0a 09 28 6d 6f 64 65 6c 2e 73 6f 20 20 28 73 )..(model.so (s
65f0: 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 28 73 64 tring-append (sd
6600: 61 74 2d 67 65 74 2d 73 72 6f 6f 74 20 73 65 6c at-get-sroot sel
6610: 66 29 20 22 2f 6d 6f 64 65 6c 73 2f 22 20 6d 6f f) "/models/" mo
6620: 64 65 6c 20 22 2e 73 6f 22 29 29 29 0a 20 20 20 del ".so"))).
6630: 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 (if (file-exist
6640: 73 3f 20 6d 6f 64 65 6c 2e 73 6f 29 0a 09 28 6c s? model.so)..(l
6650: 6f 61 64 20 6d 6f 64 65 6c 2e 73 6f 29 0a 09 28 oad model.so)..(
6660: 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f if (file-exists?
6670: 20 6d 6f 64 65 6c 2e 73 63 6d 29 0a 09 20 20 20 model.scm)..
6680: 20 28 6c 6f 61 64 20 6d 6f 64 65 6c 2e 73 63 6d (load model.scm
6690: 29 0a 09 20 20 20 20 28 73 3a 6c 6f 67 20 22 45 ).. (s:log "E
66a0: 52 52 4f 52 3a 20 6d 6f 64 65 6c 20 22 20 6d 6f RROR: model " mo
66b0: 64 65 6c 2e 73 63 6d 20 22 20 6e 6f 74 20 66 6f del.scm " not fo
66c0: 75 6e 64 22 29 29 29 29 29 0a 0a 28 64 65 66 69 und")))))..(defi
66d0: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 6d 6f 64 65 ne (session:mode
66e0: 6c 2d 70 61 74 68 20 73 65 6c 66 20 6d 6f 64 65 l-path self mode
66f0: 6c 29 0a 20 20 28 73 74 72 69 6e 67 2d 61 70 70 l). (string-app
6700: 65 6e 64 20 28 73 64 61 74 2d 67 65 74 2d 73 72 end (sdat-get-sr
6710: 6f 6f 74 20 73 65 6c 66 29 20 22 2f 6d 6f 64 65 oot self) "/mode
6720: 6c 73 2f 22 20 6d 6f 64 65 6c 20 22 2e 73 63 6d ls/" model ".scm
6730: 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 "))..(define (se
6740: 73 73 69 6f 6e 3a 70 70 2d 66 6f 72 6d 64 61 74 ssion:pp-formdat
6750: 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 self). (let ((
6760: 64 61 74 20 28 66 6f 72 6d 64 61 74 3a 61 6c 6c dat (formdat:all
6770: 2d 3e 73 74 72 69 6e 67 73 20 28 73 64 61 74 2d ->strings (sdat-
6780: 67 65 74 2d 66 6f 72 6d 64 61 74 20 73 65 6c 66 get-formdat self
6790: 29 29 29 29 0a 20 20 20 20 28 73 74 72 69 6e 67 )))). (string
67a0: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 64 61 74 -intersperse dat
67b0: 20 22 3c 62 72 3e 20 22 29 29 29 0a 0a 28 64 65 "<br> ")))..(de
67c0: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 70 61 fine (session:pa
67d0: 72 61 6d 2d 3e 73 74 72 69 6e 67 20 70 61 72 61 ram->string para
67e0: 6d 73 29 0a 20 20 3b 3b 20 28 65 72 72 3a 6c 6f ms). ;; (err:lo
67f0: 67 20 22 70 61 72 61 6d 73 3d 22 20 70 61 72 61 g "params=" para
6800: 6d 73 29 0a 20 20 28 69 66 20 28 3c 20 28 6c 65 ms). (if (< (le
6810: 6e 67 74 68 20 70 61 72 61 6d 73 29 20 31 29 0a ngth params) 1).
6820: 20 20 20 20 20 20 22 22 0a 20 20 20 20 20 20 28 "". (
6830: 6c 65 74 20 6c 6f 6f 70 20 28 28 6b 65 79 20 28 let loop ((key (
6840: 63 61 72 20 70 61 72 61 6d 73 29 29 0a 09 09 20 car params))...
6850: 28 76 61 6c 20 28 63 61 64 72 20 70 61 72 61 6d (val (cadr param
6860: 73 29 29 0a 09 09 20 28 74 61 69 6c 20 28 63 64 s))... (tail (cd
6870: 64 72 20 70 61 72 61 6d 73 29 29 0a 09 09 20 28 dr params))... (
6880: 72 65 73 75 6c 74 20 27 28 29 29 29 0a 09 28 6c result '()))..(l
6890: 65 74 20 28 28 6e 65 77 72 65 73 75 6c 74 20 28 et ((newresult (
68a0: 63 6f 6e 73 20 28 73 74 72 69 6e 67 2d 61 70 70 cons (string-app
68b0: 65 6e 64 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 end (s:any->stri
68c0: 6e 67 20 6b 65 79 29 20 22 3d 22 20 28 73 3a 61 ng key) "=" (s:a
68d0: 6e 79 2d 3e 73 74 72 69 6e 67 20 76 61 6c 29 29 ny->string val))
68e0: 0a 09 09 09 20 20 20 20 20 20 20 72 65 73 75 6c .... resul
68f0: 74 29 29 29 0a 09 20 20 28 69 66 20 28 3c 20 28 t))).. (if (< (
6900: 6c 65 6e 67 74 68 20 74 61 69 6c 29 20 31 29 20 length tail) 1)
6910: 3b 3b 20 74 72 75 65 20 69 66 20 64 6f 6e 65 0a ;; true if done.
6920: 09 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 69 . (string-i
6930: 6e 74 65 72 73 70 65 72 73 65 20 6e 65 77 72 65 ntersperse newre
6940: 73 75 6c 74 20 22 26 22 29 0a 09 20 20 20 20 20 sult "&")..
6950: 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 69 6c (loop (car tail
6960: 29 28 63 61 64 72 20 74 61 69 6c 29 28 63 64 64 )(cadr tail)(cdd
6970: 72 20 74 61 69 6c 29 20 6e 65 77 72 65 73 75 6c r tail) newresul
6980: 74 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 t))))))..(define
6990: 20 28 73 65 73 73 69 6f 6e 3a 6c 69 6e 6b 2d 74 (session:link-t
69a0: 6f 20 73 65 6c 66 20 70 61 67 65 20 70 61 72 61 o self page para
69b0: 6d 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 73 65 ms). (let* ((se
69c0: 72 76 65 72 20 20 20 20 28 69 66 20 28 67 65 74 rver (if (get
69d0: 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 -environment-var
69e0: 69 61 62 6c 65 20 22 48 54 54 50 5f 48 4f 53 54 iable "HTTP_HOST
69f0: 22 29 0a 09 09 09 28 67 65 74 2d 65 6e 76 69 72 ")....(get-envir
6a00: 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 onment-variable
6a10: 22 48 54 54 50 5f 48 4f 53 54 22 29 0a 09 09 09 "HTTP_HOST")....
6a20: 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 (get-environment
6a30: 2d 76 61 72 69 61 62 6c 65 20 22 53 45 52 56 45 -variable "SERVE
6a40: 52 5f 4e 41 4d 45 22 29 29 29 0a 09 20 28 73 63 R_NAME"))).. (sc
6a50: 72 69 70 74 20 28 6c 65 74 20 28 28 73 63 72 69 ript (let ((scri
6a60: 70 74 2d 6e 61 6d 65 20 28 73 74 72 69 6e 67 2d pt-name (string-
6a70: 73 70 6c 69 74 20 28 67 65 74 2d 65 6e 76 69 72 split (get-envir
6a80: 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 onment-variable
6a90: 22 53 43 52 49 50 54 5f 4e 41 4d 45 22 29 20 22 "SCRIPT_NAME") "
6aa0: 2f 22 29 29 29 0a 09 09 20 20 20 28 69 66 20 28 /")))... (if (
6ab0: 3e 20 28 6c 65 6e 67 74 68 20 73 63 72 69 70 74 > (length script
6ac0: 2d 6e 61 6d 65 29 20 31 29 0a 09 09 20 20 20 20 -name) 1)...
6ad0: 20 20 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e (string-appen
6ae0: 64 20 28 63 61 72 20 73 63 72 69 70 74 2d 6e 61 d (car script-na
6af0: 6d 65 29 20 22 2f 22 20 28 63 61 64 72 20 73 63 me) "/" (cadr sc
6b00: 72 69 70 74 2d 6e 61 6d 65 29 29 0a 09 09 20 20 ript-name))...
6b10: 20 20 20 20 20 28 67 65 74 2d 65 6e 76 69 72 6f (get-enviro
6b20: 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 nment-variable "
6b30: 53 43 52 49 50 54 5f 4e 41 4d 45 22 29 29 29 29 SCRIPT_NAME"))))
6b40: 20 3b 3b 20 62 75 69 6c 64 20 73 63 72 69 70 74 ;; build script
6b50: 20 6e 61 6d 65 20 66 72 6f 6d 20 66 69 72 73 74 name from first
6b60: 20 74 77 6f 20 65 6c 65 6d 65 6e 74 73 2e 20 54 two elements. T
6b70: 68 69 73 20 69 73 20 61 20 68 61 6e 67 6f 76 65 his is a hangove
6b80: 72 20 66 72 6f 6d 20 62 65 66 6f 72 65 20 49 20 r from before I
6b90: 75 73 65 64 20 3f 20 69 6e 20 74 68 65 20 55 52 used ? in the UR
6ba0: 4c 2e 0a 09 20 28 73 65 73 73 69 6f 6e 2d 6b 65 L... (session-ke
6bb0: 79 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 y (sdat-get-sess
6bc0: 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 29 0a 09 ion-key self))..
6bd0: 20 28 70 61 72 61 6d 73 74 72 20 28 73 65 73 73 (paramstr (sess
6be0: 69 6f 6e 3a 70 61 72 61 6d 2d 3e 73 74 72 69 6e ion:param->strin
6bf0: 67 20 70 61 72 61 6d 73 29 29 29 0a 20 20 20 20 g params))).
6c00: 3b 3b 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 ;; (session:log
6c10: 73 65 6c 66 20 22 73 65 72 76 65 72 3d 22 20 73 self "server=" s
6c20: 65 72 76 65 72 20 22 20 73 63 72 69 70 74 3d 22 erver " script="
6c30: 20 73 63 72 69 70 74 20 22 20 70 61 67 65 3d 22 script " page="
6c40: 20 70 61 67 65 29 0a 20 20 20 20 28 73 74 72 69 page). (stri
6c50: 6e 67 2d 61 70 70 65 6e 64 20 22 68 74 74 70 3a ng-append "http:
6c60: 2f 2f 22 20 73 65 72 76 65 72 20 22 2f 22 20 73 //" server "/" s
6c70: 63 72 69 70 74 20 22 2f 22 20 70 61 67 65 20 22 cript "/" page "
6c80: 3f 22 20 70 61 72 61 6d 73 74 72 29 29 29 20 3b ?" paramstr))) ;
6c90: 3b 20 22 2f 73 6e 3d 22 20 73 65 73 73 69 6f 6e ; "/sn=" session
6ca0: 2d 6b 65 79 29 29 29 0a 0a 28 64 65 66 69 6e 65 -key)))..(define
6cb0: 20 28 73 65 73 73 69 6f 6e 3a 63 67 69 2d 6f 75 (session:cgi-ou
6cc0: 74 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 2a 20 t self). (let*
6cd0: 28 28 63 6f 6e 74 65 6e 74 20 20 28 6c 69 73 74 ((content (list
6ce0: 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 74 65 (sdat-get-conte
6cf0: 6e 74 2d 74 79 70 65 20 73 65 6c 66 29 29 29 20 nt-type self)))
6d00: 3b 3b 20 27 28 22 43 6f 6e 74 65 6e 74 2d 74 79 ;; '("Content-ty
6d10: 70 65 3a 20 74 65 78 74 2f 68 74 6d 6c 3b 20 63 pe: text/html; c
6d20: 68 61 72 73 65 74 3d 69 73 6f 2d 38 38 35 39 2d harset=iso-8859-
6d30: 31 5c 6e 5c 6e 22 29 29 0a 09 20 28 68 65 61 64 1\n\n")).. (head
6d40: 65 72 20 20 20 28 6c 65 74 20 28 28 63 6f 6f 6b er (let ((cook
6d50: 69 65 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 ie (sdat-get-ses
6d60: 73 69 6f 6e 2d 63 6f 6f 6b 69 65 20 73 65 6c 66 sion-cookie self
6d70: 29 29 29 0a 09 09 20 20 20 20 20 28 69 66 20 63 )))... (if c
6d80: 6f 6f 6b 69 65 0a 09 09 09 20 28 63 6f 6e 73 20 ookie.... (cons
6d90: 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 22 (string-append "
6da0: 53 65 74 2d 43 6f 6f 6b 69 65 3a 20 22 20 28 63 Set-Cookie: " (c
6db0: 61 72 20 63 6f 6f 6b 69 65 29 29 0a 09 09 09 20 ar cookie))....
6dc0: 20 20 20 20 20 20 63 6f 6e 74 65 6e 74 29 0a 09 content)..
6dd0: 09 09 20 63 6f 6e 74 65 6e 74 29 29 29 0a 09 20 .. content)))..
6de0: 28 70 61 67 65 64 61 74 20 20 28 73 64 61 74 2d (pagedat (sdat-
6df0: 67 65 74 2d 70 61 67 65 64 61 74 20 73 65 6c 66 get-pagedat self
6e00: 29 29 29 0a 20 20 20 20 28 73 3a 63 67 69 2d 6f ))). (s:cgi-o
6e10: 75 74 20 0a 20 20 20 20 20 28 63 6f 6e 73 20 68 ut . (cons h
6e20: 65 61 64 65 72 20 70 61 67 65 64 61 74 29 29 29 eader pagedat)))
6e30: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 )..(define (sess
6e40: 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 2e 20 6d ion:log self . m
6e50: 73 67 29 0a 20 20 28 77 69 74 68 2d 6f 75 74 70 sg). (with-outp
6e60: 75 74 2d 74 6f 2d 70 6f 72 74 20 28 73 64 61 74 ut-to-port (sdat
6e70: 2d 67 65 74 2d 6c 6f 67 2d 70 6f 72 74 20 73 65 -get-log-port se
6e80: 6c 66 29 20 3b 3b 20 28 73 64 61 74 2d 67 65 74 lf) ;; (sdat-get
6e90: 2d 6c 6f 67 70 74 20 73 65 6c 66 29 0a 20 20 20 -logpt self).
6ea0: 20 28 6c 61 6d 62 64 61 20 28 29 20 0a 20 20 20 (lambda () .
6eb0: 20 20 20 28 61 70 70 6c 79 20 70 72 69 6e 74 20 (apply print
6ec0: 6d 73 67 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 msg))))..(define
6ed0: 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 (session:get-pa
6ee0: 72 61 6d 20 73 65 6c 66 20 6b 65 79 29 0a 20 20 ram self key).
6ef0: 3b 3b 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 ;; (session:log
6f00: 73 3a 73 65 73 73 69 6f 6e 20 22 70 61 72 61 6d s:session "param
6f10: 73 3d 22 20 28 73 6c 6f 74 2d 72 65 66 20 73 3a s=" (slot-ref s:
6f20: 73 65 73 73 69 6f 6e 20 27 70 61 72 61 6d 73 29 session 'params)
6f30: 29 0a 20 20 28 6c 65 74 20 28 28 70 61 72 61 6d ). (let ((param
6f40: 73 20 28 73 64 61 74 2d 67 65 74 2d 70 61 72 61 s (sdat-get-para
6f50: 6d 73 20 73 65 6c 66 29 29 29 0a 20 20 20 20 28 ms self))). (
6f60: 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 72 61 session:get-para
6f70: 6d 2d 66 72 6f 6d 20 70 61 72 61 6d 73 20 6b 65 m-from params ke
6f80: 79 29 29 29 0a 0a 3b 3b 20 54 68 69 73 20 6f 6e y)))..;; This on
6f90: 65 20 77 69 6c 6c 20 67 65 74 20 74 68 65 20 66 e will get the f
6fa0: 69 72 73 74 20 76 61 6c 75 65 20 66 6f 75 6e 64 irst value found
6fb0: 20 72 65 67 61 72 64 6c 65 73 73 20 6f 66 20 66 regardless of f
6fc0: 6f 72 6d 0a 28 64 65 66 69 6e 65 20 28 73 65 73 orm.(define (ses
6fd0: 73 69 6f 6e 3a 67 65 74 2d 69 6e 70 75 74 20 73 sion:get-input s
6fe0: 65 6c 66 20 6b 65 79 29 0a 20 20 28 6c 65 74 2a elf key). (let*
6ff0: 20 28 28 66 6f 72 6d 64 61 74 20 28 73 64 61 74 ((formdat (sdat
7000: 2d 67 65 74 2d 66 6f 72 6d 64 61 74 20 73 65 6c -get-formdat sel
7010: 66 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f f))). (if (no
7020: 74 20 66 6f 72 6d 64 61 74 29 20 23 66 0a 09 28 t formdat) #f..(
7030: 69 66 20 28 6f 72 20 28 73 74 72 69 6e 67 3f 20 if (or (string?
7040: 6b 65 79 29 28 6e 75 6d 62 65 72 3f 20 6b 65 79 key)(number? key
7050: 29 28 73 79 6d 62 6f 6c 3f 20 6b 65 79 29 29 0a )(symbol? key)).
7060: 09 20 20 20 20 28 69 66 20 28 65 71 3f 20 28 63 . (if (eq? (c
7070: 6c 61 73 73 2d 6f 66 20 66 6f 72 6d 64 61 74 29 lass-of formdat)
7080: 20 3c 66 6f 72 6d 64 61 74 3e 29 0a 09 09 28 66 <formdat>)...(f
7090: 6f 72 6d 64 61 74 3a 67 65 74 20 66 6f 72 6d 64 ormdat:get formd
70a0: 61 74 20 6b 65 79 29 0a 09 09 28 62 65 67 69 6e at key)...(begin
70b0: 0a 09 09 20 20 28 73 65 73 73 69 6f 6e 3a 6c 6f ... (session:lo
70c0: 67 20 73 65 6c 66 20 22 45 52 52 4f 52 3a 20 66 g self "ERROR: f
70d0: 6f 72 6d 64 61 74 3a 20 22 20 66 6f 72 6d 64 61 ormdat: " formda
70e0: 74 20 22 20 69 73 20 6e 6f 74 20 6f 66 20 63 6c t " is not of cl
70f0: 61 73 73 20 3c 66 6f 72 6d 64 61 74 3e 22 29 0a ass <formdat>").
7100: 09 09 20 20 23 66 29 29 0a 09 20 20 20 20 28 73 .. #f)).. (s
7110: 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 ession:log self
7120: 22 45 52 52 4f 52 3a 20 62 61 64 20 6b 65 79 20 "ERROR: bad key
7130: 22 20 6b 65 79 29 29 29 29 29 0a 0a 28 64 65 66 " key)))))..(def
7140: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 72 75 6e ine (session:run
7150: 2d 61 63 74 69 6f 6e 73 20 73 65 6c 66 29 0a 20 -actions self).
7160: 20 28 6c 65 74 2a 20 28 28 61 63 74 69 6f 6e 20 (let* ((action
7170: 20 20 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d (session:get-
7180: 70 61 72 61 6d 20 73 65 6c 66 20 27 61 63 74 69 param self 'acti
7190: 6f 6e 29 29 0a 09 20 28 70 61 67 65 20 20 20 20 on)).. (page
71a0: 20 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 (sdat-get-page
71b0: 20 73 65 6c 66 29 29 29 0a 20 20 20 20 3b 3b 20 self))). ;;
71c0: 28 70 72 69 6e 74 20 22 61 63 74 69 6f 6e 3d 22 (print "action="
71d0: 20 61 63 74 69 6f 6e 20 22 20 70 61 67 65 3d 22 action " page="
71e0: 20 70 61 67 65 29 0a 20 20 20 20 28 69 66 20 61 page). (if a
71f0: 63 74 69 6f 6e 0a 09 28 6c 65 74 20 28 28 61 63 ction..(let ((ac
7200: 74 69 6f 6e 2d 6c 73 74 20 20 28 73 74 72 69 6e tion-lst (strin
7210: 67 2d 73 70 6c 69 74 20 61 63 74 69 6f 6e 20 22 g-split action "
7220: 2e 22 29 29 29 0a 09 20 20 3b 3b 20 28 70 72 69 ."))).. ;; (pri
7230: 6e 74 20 22 61 63 74 69 6f 6e 2d 6c 73 74 3d 22 nt "action-lst="
7240: 20 61 63 74 69 6f 6e 2d 6c 73 74 29 0a 09 20 20 action-lst)..
7250: 28 69 66 20 28 6e 6f 74 20 28 3d 20 28 6c 65 6e (if (not (= (len
7260: 67 74 68 20 61 63 74 69 6f 6e 2d 6c 73 74 29 20 gth action-lst)
7270: 32 29 29 20 0a 09 20 20 20 20 20 20 28 65 72 72 2)) .. (err
7280: 3a 6c 6f 67 20 22 41 63 74 69 6f 6e 20 73 68 6f :log "Action sho
7290: 75 6c 64 20 62 65 20 6f 66 20 66 6f 72 6d 3a 20 uld be of form:
72a0: 6d 6f 64 75 6c 65 2e 61 63 74 69 6f 6e 22 29 0a module.action").
72b0: 09 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 . (let* ((t
72c0: 61 72 67 2d 70 61 67 65 20 20 20 28 63 61 72 20 arg-page (car
72d0: 61 63 74 69 6f 6e 2d 6c 73 74 29 29 0a 09 09 20 action-lst))...
72e0: 20 20 20 20 28 70 72 6f 63 2d 6e 61 6d 65 20 20 (proc-name
72f0: 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 (string-append
7300: 74 61 72 67 2d 70 61 67 65 20 22 2d 61 63 74 69 targ-page "-acti
7310: 6f 6e 22 29 29 0a 09 09 20 20 20 20 20 28 74 61 on"))... (ta
7320: 72 67 2d 61 63 74 69 6f 6e 20 28 63 61 64 72 20 rg-action (cadr
7330: 61 63 74 69 6f 6e 2d 6c 73 74 29 29 29 0a 09 09 action-lst)))...
7340: 3b 3b 20 28 65 72 72 3a 6c 6f 67 20 22 74 61 72 ;; (err:log "tar
7350: 67 2d 70 61 67 65 3d 22 20 74 61 72 67 2d 70 61 g-page=" targ-pa
7360: 67 65 20 22 20 70 72 6f 63 2d 6e 61 6d 65 3d 22 ge " proc-name="
7370: 20 70 72 6f 63 2d 6e 61 6d 65 20 22 20 74 61 72 proc-name " tar
7380: 67 2d 61 63 74 69 6f 6e 3d 22 20 74 61 72 67 2d g-action=" targ-
7390: 61 63 74 69 6f 6e 29 0a 0a 09 09 3b 3b 20 63 61 action)....;; ca
73a0: 6c 6c 20 68 65 72 65 20 6f 6e 6c 79 20 69 66 20 ll here only if
73b0: 6e 65 76 65 72 20 63 61 6c 6c 65 64 20 62 65 66 never called bef
73c0: 6f 72 65 0a 09 09 28 69 66 20 28 73 65 73 73 69 ore...(if (sessi
73d0: 6f 6e 3a 6e 65 76 65 72 2d 63 61 6c 6c 65 64 2d on:never-called-
73e0: 70 61 67 65 3f 20 73 65 6c 66 20 74 61 72 67 2d page? self targ-
73f0: 70 61 67 65 29 0a 09 09 20 20 20 20 28 73 65 73 page)... (ses
7400: 73 69 6f 6e 3a 63 61 6c 6c 2d 70 61 72 74 73 20 sion:call-parts
7410: 73 65 6c 66 20 74 61 72 67 2d 70 61 67 65 20 27 self targ-page '
7420: 63 6f 6e 74 72 6f 6c 29 29 0a 09 09 3b 3b 20 20 control))...;;
7430: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7440: 20 20 70 72 6f 63 20 20 20 20 20 20 20 20 20 20 proc
7450: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 61 a
7460: 63 74 69 6f 6e 20 20 20 20 0a 0a 09 09 28 69 66 ction ....(if
7470: 20 23 74 20 3b 3b 20 73 65 74 20 74 6f 20 23 74 #t ;; set to #t
7480: 20 74 6f 20 73 65 65 20 62 65 74 74 65 72 20 65 to see better e
7490: 72 72 6f 72 20 6d 65 73 73 61 67 65 73 20 64 75 rror messages du
74a0: 72 69 6e 67 20 64 65 62 75 67 67 69 6e 20 3a 2d ring debuggin :-
74b0: 29 0a 09 09 20 20 20 20 28 28 65 76 61 6c 20 28 )... ((eval (
74c0: 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 70 string->symbol p
74d0: 72 6f 63 2d 6e 61 6d 65 29 29 20 74 61 72 67 2d roc-name)) targ-
74e0: 61 63 74 69 6f 6e 29 20 3b 3b 20 75 6e 73 61 66 action) ;; unsaf
74f0: 65 20 65 78 65 63 75 74 69 6f 6e 0a 09 09 20 20 e execution...
7500: 20 20 28 63 6f 6e 64 69 74 69 6f 6e 2d 63 61 73 (condition-cas
7510: 65 20 28 28 65 76 61 6c 20 28 73 74 72 69 6e 67 e ((eval (string
7520: 2d 3e 73 79 6d 62 6f 6c 20 70 72 6f 63 2d 6e 61 ->symbol proc-na
7530: 6d 65 29 29 20 74 61 72 67 2d 61 63 74 69 6f 6e me)) targ-action
7540: 29 0a 09 09 09 09 20 20 20 20 28 28 65 78 6e 20 )..... ((exn
7550: 66 69 6c 65 29 20 28 73 3a 6c 6f 67 20 22 66 69 file) (s:log "fi
7560: 6c 65 20 65 72 72 6f 72 22 29 29 0a 09 09 09 09 le error")).....
7570: 20 20 20 20 28 28 65 78 6e 20 69 2f 6f 29 20 20 ((exn i/o)
7580: 28 73 3a 6c 6f 67 20 22 69 2f 6f 20 65 72 72 6f (s:log "i/o erro
7590: 72 22 29 29 0a 09 09 09 09 20 20 20 20 28 28 65 r"))..... ((e
75a0: 78 6e 20 29 20 20 20 20 20 28 73 3a 6c 6f 67 20 xn ) (s:log
75b0: 22 41 63 74 69 6f 6e 20 6e 6f 74 20 69 6d 70 6c "Action not impl
75c0: 65 6d 65 6e 74 65 64 3a 20 22 20 70 72 6f 63 2d emented: " proc-
75d0: 6e 61 6d 65 20 22 20 61 63 74 69 6f 6e 3a 20 22 name " action: "
75e0: 20 74 61 72 67 2d 61 63 74 69 6f 6e 29 29 0a 09 targ-action))..
75f0: 09 09 09 20 20 20 20 28 76 61 72 20 28 29 20 20 ... (var ()
7600: 20 20 20 28 73 3a 6c 6f 67 20 22 55 6e 6b 6e 6f (s:log "Unkno
7610: 77 6e 20 45 72 72 6f 72 22 29 29 29 29 29 29 29 wn Error")))))))
7620: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 )))..(define (se
7630: 73 73 69 6f 6e 3a 6e 65 76 65 72 2d 63 61 6c 6c ssion:never-call
7640: 65 64 2d 70 61 67 65 3f 20 73 65 6c 66 20 70 61 ed-page? self pa
7650: 67 65 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a 6c ge). (session:l
7660: 6f 67 20 73 65 6c 66 20 22 43 68 65 63 6b 69 6e og self "Checkin
7670: 67 20 66 6f 72 20 70 61 67 65 3a 20 22 20 70 61 g for page: " pa
7680: 67 65 29 0a 20 20 28 6e 6f 74 20 28 6d 65 6d 62 ge). (not (memb
7690: 65 72 20 70 61 67 65 20 28 73 64 61 74 2d 67 65 er page (sdat-ge
76a0: 74 2d 73 65 65 6e 2d 70 61 67 65 73 20 73 65 6c t-seen-pages sel
76b0: 66 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 f))))..(define (
76c0: 73 65 73 73 69 6f 6e 3a 73 65 74 2d 63 61 6c 6c session:set-call
76d0: 65 64 21 20 73 65 6c 66 20 70 61 67 65 29 0a 20 ed! self page).
76e0: 20 28 73 64 61 74 2d 73 65 74 2d 73 65 65 6e 2d (sdat-set-seen-
76f0: 70 61 67 65 73 21 20 73 65 6c 66 20 28 63 6f 6e pages! self (con
7700: 73 20 70 61 67 65 20 28 73 64 61 74 2d 67 65 74 s page (sdat-get
7710: 2d 73 65 65 6e 2d 70 61 67 65 73 20 73 65 6c 66 -seen-pages self
7720: 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ))))..;;========
7730: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7740: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7750: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7760: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
7770: 3b 20 41 6c 74 65 72 6e 61 74 69 76 65 20 64 61 ; Alternative da
7780: 74 61 20 74 79 70 65 20 64 65 6c 69 76 65 72 79 ta type delivery
7790: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
77a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
77b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
77c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
77d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 =========..(defi
77e0: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 61 6c 74 2d ne (session:alt-
77f0: 6f 75 74 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 out self). (let
7800: 20 28 28 64 61 74 20 28 73 64 61 74 2d 67 65 74 ((dat (sdat-get
7810: 2d 61 6c 74 2d 70 61 67 65 2d 64 61 74 20 73 65 -alt-page-dat se
7820: 6c 66 29 29 29 0a 20 20 20 20 3b 3b 20 28 73 3a lf))). ;; (s:
7830: 6c 6f 67 20 22 64 61 74 20 69 73 3a 20 22 20 64 log "dat is: " d
7840: 61 74 29 0a 20 20 20 20 3b 3b 20 28 70 72 69 6e at). ;; (prin
7850: 74 20 22 48 54 54 50 2f 31 2e 31 20 32 30 30 20 t "HTTP/1.1 200
7860: 4f 4b 22 29 0a 20 20 20 20 28 70 72 69 6e 74 20 OK"). (print
7870: 22 44 61 74 65 3a 20 22 20 28 74 69 6d 65 2d 3e "Date: " (time->
7880: 73 74 72 69 6e 67 20 28 73 65 63 6f 6e 64 73 2d string (seconds-
7890: 3e 75 74 63 2d 74 69 6d 65 20 28 63 75 72 72 65 >utc-time (curre
78a0: 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 29 0a 20 nt-seconds)))).
78b0: 20 20 20 28 70 72 69 6e 74 20 22 43 6f 6e 74 65 (print "Conte
78c0: 6e 74 2d 54 79 70 65 3a 20 22 20 28 73 64 61 74 nt-Type: " (sdat
78d0: 2d 67 65 74 2d 63 6f 6e 74 65 6e 74 2d 74 79 70 -get-content-typ
78e0: 65 20 73 65 6c 66 29 29 0a 20 20 20 20 28 70 72 e self)). (pr
78f0: 69 6e 74 20 22 41 63 63 65 70 74 2d 52 61 6e 67 int "Accept-Rang
7900: 65 73 3a 20 62 79 74 65 73 22 29 0a 20 20 20 20 es: bytes").
7910: 28 70 72 69 6e 74 20 22 43 6f 6e 74 65 6e 74 2d (print "Content-
7920: 4c 65 6e 67 74 68 3a 20 22 20 28 69 66 20 28 62 Length: " (if (b
7930: 6c 6f 62 3f 20 64 61 74 29 0a 09 09 09 09 20 20 lob? dat).....
7940: 28 62 6c 6f 62 2d 73 69 7a 65 20 64 61 74 29 0a (blob-size dat).
7950: 09 09 09 09 20 20 30 29 29 0a 20 20 20 20 28 70 .... 0)). (p
7960: 72 69 6e 74 20 22 4b 65 65 70 2d 41 6c 69 76 65 rint "Keep-Alive
7970: 3a 20 74 69 6d 65 6f 75 74 3d 31 35 2c 20 6d 61 : timeout=15, ma
7980: 78 3d 31 30 30 22 29 0a 20 20 20 20 28 70 72 69 x=100"). (pri
7990: 6e 74 20 22 43 6f 6e 6e 65 63 74 69 6f 6e 3a 20 nt "Connection:
79a0: 4b 65 65 70 2d 41 6c 69 76 65 22 29 0a 20 20 20 Keep-Alive").
79b0: 20 28 70 72 69 6e 74 20 22 22 29 0a 20 20 20 20 (print "").
79c0: 28 77 72 69 74 65 2d 73 74 72 69 6e 67 20 28 62 (write-string (b
79d0: 6c 6f 62 2d 3e 73 74 72 69 6e 67 20 64 61 74 29 lob->string dat)
79e0: 20 23 66 20 28 63 75 72 72 65 6e 74 2d 6f 75 74 #f (current-out
79f0: 70 75 74 2d 70 6f 72 74 29 29 29 29 0a put-port)))).