Artifact
42f79a48ef3b89f2a91c89515593f55fbe786510:
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 65 (define (make-se
0490: 73 73 69 6f 6e 3a 73 64 61 74 29 28 6d 61 6b 65 ssion:sdat)(make
04a0: 2d 76 65 63 74 6f 72 20 33 33 29 29 0a 28 64 65 -vector 33)).(de
04b0: 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 73 65 73 fine-inline (ses
04c0: 73 69 6f 6e 3a 73 64 61 74 2d 67 65 74 2d 64 62 sion:sdat-get-db
04d0: 74 79 70 65 20 20 20 20 20 20 20 20 20 20 20 20 type
04e0: 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 vec) (vect
04f0: 6f 72 2d 72 65 66 20 20 76 65 63 20 30 29 29 0a or-ref vec 0)).
0500: 28 64 65 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 (define-inline (
0510: 73 65 73 73 69 6f 6e 3a 73 64 61 74 2d 67 65 74 session:sdat-get
0520: 2d 64 62 69 6e 69 74 20 20 20 20 20 20 20 20 20 -dbinit
0530: 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 vec) (v
0540: 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 31 ector-ref vec 1
0550: 29 29 0a 28 64 65 66 69 6e 65 2d 69 6e 6c 69 6e )).(define-inlin
0560: 65 20 28 73 65 73 73 69 6f 6e 3a 73 64 61 74 2d e (session:sdat-
0570: 67 65 74 2d 63 6f 6e 6e 20 20 20 20 20 20 20 20 get-conn
0580: 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 vec)
0590: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 (vector-ref ve
05a0: 63 20 32 29 29 0a 28 64 65 66 69 6e 65 2d 69 6e c 2)).(define-in
05b0: 6c 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 64 line (session:sd
05c0: 61 74 2d 67 65 74 2d 70 61 72 61 6d 73 20 20 20 at-get-params
05d0: 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 29 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 33 29 29 0a 28 64 65 66 69 6e 65 vec 3)).(define
0600: 2d 69 6e 6c 69 6e 65 20 28 73 65 73 73 69 6f 6e -inline (session
0610: 3a 73 64 61 74 2d 67 65 74 2d 70 61 74 68 2d 70 :sdat-get-path-p
0620: 61 72 61 6d 73 20 20 20 20 20 20 20 20 20 20 76 arams v
0630: 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 ec) (vector-r
0640: 65 66 20 20 76 65 63 20 34 29 29 0a 28 64 65 66 ef vec 4)).(def
0650: 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 73 65 73 73 ine-inline (sess
0660: 69 6f 6e 3a 73 64 61 74 2d 67 65 74 2d 73 65 73 ion:sdat-get-ses
0670: 73 69 6f 6e 2d 6b 65 79 20 20 20 20 20 20 20 20 sion-key
0680: 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f vec) (vecto
0690: 72 2d 72 65 66 20 20 76 65 63 20 35 29 29 0a 28 r-ref vec 5)).(
06a0: 64 65 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 73 define-inline (s
06b0: 65 73 73 69 6f 6e 3a 73 64 61 74 2d 67 65 74 2d ession:sdat-get-
06c0: 73 65 73 73 69 6f 6e 2d 69 64 20 20 20 20 20 20 session-id
06d0: 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 vec) (ve
06e0: 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 36 29 ctor-ref vec 6)
06f0: 29 0a 28 64 65 66 69 6e 65 2d 69 6e 6c 69 6e 65 ).(define-inline
0700: 20 28 73 65 73 73 69 6f 6e 3a 73 64 61 74 2d 67 (session:sdat-g
0710: 65 74 2d 64 6f 6d 61 69 6e 20 20 20 20 20 20 20 et-domain
0720: 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 vec)
0730: 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 (vector-ref vec
0740: 20 37 29 29 0a 28 64 65 66 69 6e 65 2d 69 6e 6c 7)).(define-inl
0750: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 64 61 ine (session:sda
0760: 74 2d 67 65 74 2d 74 6f 70 70 61 67 65 20 20 20 t-get-toppage
0770: 20 20 20 20 20 20 20 20 20 20 20 76 65 63 29 20 vec)
0780: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 (vector-ref
0790: 76 65 63 20 38 29 29 0a 28 64 65 66 69 6e 65 2d vec 8)).(define-
07a0: 69 6e 6c 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a inline (session:
07b0: 73 64 61 74 2d 67 65 74 2d 70 61 67 65 20 20 20 sdat-get-page
07c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 ve
07d0: 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 c) (vector-re
07e0: 66 20 20 76 65 63 20 39 29 29 0a 28 64 65 66 69 f vec 9)).(defi
07f0: 6e 65 2d 69 6e 6c 69 6e 65 20 28 73 65 73 73 69 ne-inline (sessi
0800: 6f 6e 3a 73 64 61 74 2d 67 65 74 2d 63 75 72 72 on:sdat-get-curr
0810: 2d 70 61 67 65 20 20 20 20 20 20 20 20 20 20 20 -page
0820: 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 vec) (vector
0830: 2d 72 65 66 20 20 76 65 63 20 31 30 29 29 0a 28 -ref vec 10)).(
0840: 64 65 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 73 define-inline (s
0850: 65 73 73 69 6f 6e 3a 73 64 61 74 2d 67 65 74 2d ession:sdat-get-
0860: 63 6f 6e 74 65 6e 74 2d 74 79 70 65 20 20 20 20 content-type
0870: 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 vec) (ve
0880: 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 31 31 ctor-ref vec 11
0890: 29 29 0a 28 64 65 66 69 6e 65 2d 69 6e 6c 69 6e )).(define-inlin
08a0: 65 20 28 73 65 73 73 69 6f 6e 3a 73 64 61 74 2d e (session:sdat-
08b0: 67 65 74 2d 70 61 67 65 2d 74 79 70 65 20 20 20 get-page-type
08c0: 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 vec)
08d0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 (vector-ref ve
08e0: 63 20 31 32 29 29 0a 28 64 65 66 69 6e 65 2d 69 c 12)).(define-i
08f0: 6e 6c 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 nline (session:s
0900: 64 61 74 2d 67 65 74 2d 73 72 6f 6f 74 20 20 20 dat-get-sroot
0910: 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 vec
0920: 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 ) (vector-ref
0930: 20 20 76 65 63 20 31 33 29 29 0a 28 64 65 66 69 vec 13)).(defi
0940: 6e 65 2d 69 6e 6c 69 6e 65 20 28 73 65 73 73 69 ne-inline (sessi
0950: 6f 6e 3a 73 64 61 74 2d 67 65 74 2d 74 77 69 6b on:sdat-get-twik
0960: 69 64 69 72 20 20 20 20 20 20 20 20 20 20 20 20 idir
0970: 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 vec) (vector
0980: 2d 72 65 66 20 20 76 65 63 20 31 34 29 29 0a 28 -ref vec 14)).(
0990: 64 65 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 73 define-inline (s
09a0: 65 73 73 69 6f 6e 3a 73 64 61 74 2d 67 65 74 2d ession:sdat-get-
09b0: 70 61 67 65 64 61 74 20 20 20 20 20 20 20 20 20 pagedat
09c0: 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 vec) (ve
09d0: 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 31 35 ctor-ref vec 15
09e0: 29 29 0a 28 64 65 66 69 6e 65 2d 69 6e 6c 69 6e )).(define-inlin
09f0: 65 20 28 73 65 73 73 69 6f 6e 3a 73 64 61 74 2d e (session:sdat-
0a00: 67 65 74 2d 61 6c 74 2d 70 61 67 65 2d 64 61 74 get-alt-page-dat
0a10: 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 vec)
0a20: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 (vector-ref ve
0a30: 63 20 31 36 29 29 0a 28 64 65 66 69 6e 65 2d 69 c 16)).(define-i
0a40: 6e 6c 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 nline (session:s
0a50: 64 61 74 2d 67 65 74 2d 70 61 67 65 76 61 72 73 dat-get-pagevars
0a60: 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 vec
0a70: 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 ) (vector-ref
0a80: 20 20 76 65 63 20 31 37 29 29 0a 28 64 65 66 69 vec 17)).(defi
0a90: 6e 65 2d 69 6e 6c 69 6e 65 20 28 73 65 73 73 69 ne-inline (sessi
0aa0: 6f 6e 3a 73 64 61 74 2d 67 65 74 2d 70 61 67 65 on:sdat-get-page
0ab0: 76 61 72 73 2d 62 65 66 6f 72 65 20 20 20 20 20 vars-before
0ac0: 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 vec) (vector
0ad0: 2d 72 65 66 20 20 76 65 63 20 31 38 29 29 0a 28 -ref vec 18)).(
0ae0: 64 65 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 73 define-inline (s
0af0: 65 73 73 69 6f 6e 3a 73 64 61 74 2d 67 65 74 2d ession:sdat-get-
0b00: 73 65 73 73 69 6f 6e 76 61 72 73 20 20 20 20 20 sessionvars
0b10: 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 vec) (ve
0b20: 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 31 39 ctor-ref vec 19
0b30: 29 29 0a 28 64 65 66 69 6e 65 2d 69 6e 6c 69 6e )).(define-inlin
0b40: 65 20 28 73 65 73 73 69 6f 6e 3a 73 64 61 74 2d e (session:sdat-
0b50: 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 2d get-sessionvars-
0b60: 62 65 66 6f 72 65 20 20 20 76 65 63 29 20 20 20 before vec)
0b70: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 (vector-ref ve
0b80: 63 20 32 30 29 29 0a 28 64 65 66 69 6e 65 2d 69 c 20)).(define-i
0b90: 6e 6c 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 nline (session:s
0ba0: 64 61 74 2d 67 65 74 2d 67 6c 6f 62 61 6c 76 61 dat-get-globalva
0bb0: 72 73 20 20 20 20 20 20 20 20 20 20 20 76 65 63 rs vec
0bc0: 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 ) (vector-ref
0bd0: 20 20 76 65 63 20 32 31 29 29 0a 28 64 65 66 69 vec 21)).(defi
0be0: 6e 65 2d 69 6e 6c 69 6e 65 20 28 73 65 73 73 69 ne-inline (sessi
0bf0: 6f 6e 3a 73 64 61 74 2d 67 65 74 2d 67 6c 6f 62 on:sdat-get-glob
0c00: 61 6c 76 61 72 73 2d 62 65 66 6f 72 65 20 20 20 alvars-before
0c10: 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 vec) (vector
0c20: 2d 72 65 66 20 20 76 65 63 20 32 32 29 29 0a 28 -ref vec 22)).(
0c30: 64 65 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 73 define-inline (s
0c40: 65 73 73 69 6f 6e 3a 73 64 61 74 2d 67 65 74 2d ession:sdat-get-
0c50: 6c 6f 67 70 74 20 20 20 20 20 20 20 20 20 20 20 logpt
0c60: 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 vec) (ve
0c70: 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 32 33 ctor-ref vec 23
0c80: 29 29 0a 28 64 65 66 69 6e 65 2d 69 6e 6c 69 6e )).(define-inlin
0c90: 65 20 28 73 65 73 73 69 6f 6e 3a 73 64 61 74 2d e (session:sdat-
0ca0: 67 65 74 2d 66 6f 72 6d 64 61 74 20 20 20 20 20 get-formdat
0cb0: 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 vec)
0cc0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 (vector-ref ve
0cd0: 63 20 32 34 29 29 0a 28 64 65 66 69 6e 65 2d 69 c 24)).(define-i
0ce0: 6e 6c 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 nline (session:s
0cf0: 64 61 74 2d 67 65 74 2d 72 65 71 75 65 73 74 2d dat-get-request-
0d00: 6d 65 74 68 6f 64 20 20 20 20 20 20 20 76 65 63 method vec
0d10: 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 ) (vector-ref
0d20: 20 20 76 65 63 20 32 35 29 29 0a 28 64 65 66 69 vec 25)).(defi
0d30: 6e 65 2d 69 6e 6c 69 6e 65 20 28 73 65 73 73 69 ne-inline (sessi
0d40: 6f 6e 3a 73 64 61 74 2d 67 65 74 2d 73 65 73 73 on:sdat-get-sess
0d50: 69 6f 6e 2d 63 6f 6f 6b 69 65 20 20 20 20 20 20 ion-cookie
0d60: 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 vec) (vector
0d70: 2d 72 65 66 20 20 76 65 63 20 32 36 29 29 0a 28 -ref vec 26)).(
0d80: 64 65 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 73 define-inline (s
0d90: 65 73 73 69 6f 6e 3a 73 64 61 74 2d 67 65 74 2d ession:sdat-get-
0da0: 63 75 72 72 2d 65 72 72 20 20 20 20 20 20 20 20 curr-err
0db0: 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 vec) (ve
0dc0: 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 32 37 ctor-ref vec 27
0dd0: 29 29 0a 28 64 65 66 69 6e 65 2d 69 6e 6c 69 6e )).(define-inlin
0de0: 65 20 28 73 65 73 73 69 6f 6e 3a 73 64 61 74 2d e (session:sdat-
0df0: 67 65 74 2d 6c 6f 67 2d 70 6f 72 74 20 20 20 20 get-log-port
0e00: 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 vec)
0e10: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 (vector-ref ve
0e20: 63 20 32 38 29 29 0a 28 64 65 66 69 6e 65 2d 69 c 28)).(define-i
0e30: 6e 6c 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 nline (session:s
0e40: 64 61 74 2d 67 65 74 2d 6c 6f 67 66 69 6c 65 20 dat-get-logfile
0e50: 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 vec
0e60: 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 ) (vector-ref
0e70: 20 20 76 65 63 20 32 39 29 29 0a 28 64 65 66 69 vec 29)).(defi
0e80: 6e 65 2d 69 6e 6c 69 6e 65 20 28 73 65 73 73 69 ne-inline (sessi
0e90: 6f 6e 3a 73 64 61 74 2d 67 65 74 2d 73 65 65 6e on:sdat-get-seen
0ea0: 2d 70 61 67 65 73 20 20 20 20 20 20 20 20 20 20 -pages
0eb0: 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 vec) (vector
0ec0: 2d 72 65 66 20 20 76 65 63 20 33 30 29 29 0a 28 -ref vec 30)).(
0ed0: 64 65 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 73 define-inline (s
0ee0: 65 73 73 69 6f 6e 3a 73 64 61 74 2d 67 65 74 2d ession:sdat-get-
0ef0: 70 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 20 20 page-dir-style
0f00: 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 vec) (ve
0f10: 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 33 31 ctor-ref vec 31
0f20: 29 29 0a 28 64 65 66 69 6e 65 2d 69 6e 6c 69 6e )).(define-inlin
0f30: 65 20 28 73 65 73 73 69 6f 6e 3a 73 64 61 74 2d e (session:sdat-
0f40: 67 65 74 2d 64 65 62 75 67 6d 6f 64 65 20 20 20 get-debugmode
0f50: 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 vec)
0f60: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 (vector-ref ve
0f70: 63 20 33 32 29 29 0a 28 64 65 66 69 6e 65 2d 69 c 32)).(define-i
0f80: 6e 6c 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 nline (session:s
0f90: 64 61 74 2d 73 65 74 2d 64 62 74 79 70 65 21 20 dat-set-dbtype!
0fa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 vec
0fb0: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
0fc0: 21 20 76 65 63 20 30 20 76 61 6c 29 29 0a 28 64 ! vec 0 val)).(d
0fd0: 65 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 73 65 efine-inline (se
0fe0: 73 73 69 6f 6e 3a 73 64 61 74 2d 73 65 74 2d 64 ssion:sdat-set-d
0ff0: 62 69 6e 69 74 21 20 20 20 20 20 20 20 20 20 20 binit!
1000: 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 vec val)(vec
1010: 74 6f 72 2d 73 65 74 21 20 76 65 63 20 31 20 76 tor-set! vec 1 v
1020: 61 6c 29 29 0a 28 64 65 66 69 6e 65 2d 69 6e 6c al)).(define-inl
1030: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 64 61 ine (session:sda
1040: 74 2d 73 65 74 2d 63 6f 6e 6e 21 20 20 20 20 20 t-set-conn!
1050: 20 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 vec v
1060: 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 al)(vector-set!
1070: 76 65 63 20 32 20 76 61 6c 29 29 0a 28 64 65 66 vec 2 val)).(def
1080: 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 73 65 73 73 ine-inline (sess
1090: 69 6f 6e 3a 73 64 61 74 2d 73 65 74 2d 70 61 72 ion:sdat-set-par
10a0: 61 6d 73 21 20 20 20 20 20 20 20 20 20 20 20 20 ams!
10b0: 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f vec val)(vecto
10c0: 72 2d 73 65 74 21 20 76 65 63 20 33 20 76 61 6c r-set! vec 3 val
10d0: 29 29 0a 28 64 65 66 69 6e 65 2d 69 6e 6c 69 6e )).(define-inlin
10e0: 65 20 28 73 65 73 73 69 6f 6e 3a 73 64 61 74 2d e (session:sdat-
10f0: 73 65 74 2d 70 61 74 68 2d 70 61 72 61 6d 73 21 set-path-params!
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 34 20 76 61 6c 29 29 0a 28 64 65 66 69 6e c 4 val)).(defin
1130: 65 2d 69 6e 6c 69 6e 65 20 28 73 65 73 73 69 6f e-inline (sessio
1140: 6e 3a 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 n:sdat-set-sessi
1150: 6f 6e 2d 6b 65 79 21 20 20 20 20 20 20 20 20 20 on-key!
1160: 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d vec val)(vector-
1170: 73 65 74 21 20 76 65 63 20 35 20 76 61 6c 29 29 set! vec 5 val))
1180: 0a 28 64 65 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 .(define-inline
1190: 28 73 65 73 73 69 6f 6e 3a 73 64 61 74 2d 73 65 (session:sdat-se
11a0: 74 2d 73 65 73 73 69 6f 6e 2d 69 64 21 20 20 20 t-session-id!
11b0: 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 vec val)(
11c0: 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 vector-set! vec
11d0: 36 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 2d 6 val)).(define-
11e0: 69 6e 6c 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a inline (session:
11f0: 73 64 61 74 2d 73 65 74 2d 64 6f 6d 61 69 6e 21 sdat-set-domain!
1200: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 ve
1210: 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 c val)(vector-se
1220: 74 21 20 76 65 63 20 37 20 76 61 6c 29 29 0a 28 t! vec 7 val)).(
1230: 64 65 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 73 define-inline (s
1240: 65 73 73 69 6f 6e 3a 73 64 61 74 2d 73 65 74 2d ession:sdat-set-
1250: 74 6f 70 70 61 67 65 21 20 20 20 20 20 20 20 20 toppage!
1260: 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 vec val)(ve
1270: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 38 20 ctor-set! vec 8
1280: 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 2d 69 6e val)).(define-in
1290: 6c 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 64 line (session:sd
12a0: 61 74 2d 73 65 74 2d 70 61 67 65 21 20 20 20 20 at-set-page!
12b0: 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 20 vec
12c0: 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 val)(vector-set!
12d0: 20 76 65 63 20 39 20 76 61 6c 29 29 0a 28 64 65 vec 9 val)).(de
12e0: 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 73 65 73 fine-inline (ses
12f0: 73 69 6f 6e 3a 73 64 61 74 2d 73 65 74 2d 63 75 sion:sdat-set-cu
1300: 72 72 2d 70 61 67 65 21 20 20 20 20 20 20 20 20 rr-page!
1310: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
1320: 6f 72 2d 73 65 74 21 20 76 65 63 20 31 30 20 76 or-set! vec 10 v
1330: 61 6c 29 29 0a 28 64 65 66 69 6e 65 2d 69 6e 6c al)).(define-inl
1340: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 64 61 ine (session:sda
1350: 74 2d 73 65 74 2d 63 6f 6e 74 65 6e 74 2d 74 79 t-set-content-ty
1360: 70 65 21 20 20 20 20 20 20 20 20 76 65 63 20 76 pe! vec v
1370: 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 al)(vector-set!
1380: 76 65 63 20 31 31 20 76 61 6c 29 29 0a 28 64 65 vec 11 val)).(de
1390: 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 73 65 73 fine-inline (ses
13a0: 73 69 6f 6e 3a 73 64 61 74 2d 73 65 74 2d 70 61 sion:sdat-set-pa
13b0: 67 65 2d 74 79 70 65 21 20 20 20 20 20 20 20 20 ge-type!
13c0: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
13d0: 6f 72 2d 73 65 74 21 20 76 65 63 20 31 32 20 76 or-set! vec 12 v
13e0: 61 6c 29 29 0a 28 64 65 66 69 6e 65 2d 69 6e 6c al)).(define-inl
13f0: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 64 61 ine (session:sda
1400: 74 2d 73 65 74 2d 73 72 6f 6f 74 21 20 20 20 20 t-set-sroot!
1410: 20 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 vec v
1420: 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 al)(vector-set!
1430: 76 65 63 20 31 33 20 76 61 6c 29 29 0a 28 64 65 vec 13 val)).(de
1440: 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 73 65 73 fine-inline (ses
1450: 73 69 6f 6e 3a 73 64 61 74 2d 73 65 74 2d 74 77 sion:sdat-set-tw
1460: 69 6b 69 64 69 72 21 20 20 20 20 20 20 20 20 20 ikidir!
1470: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
1480: 6f 72 2d 73 65 74 21 20 76 65 63 20 31 34 20 76 or-set! vec 14 v
1490: 61 6c 29 29 0a 28 64 65 66 69 6e 65 2d 69 6e 6c al)).(define-inl
14a0: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 64 61 ine (session:sda
14b0: 74 2d 73 65 74 2d 70 61 67 65 64 61 74 21 20 20 t-set-pagedat!
14c0: 20 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 vec v
14d0: 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 al)(vector-set!
14e0: 76 65 63 20 31 35 20 76 61 6c 29 29 0a 28 64 65 vec 15 val)).(de
14f0: 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 73 65 73 fine-inline (ses
1500: 73 69 6f 6e 3a 73 64 61 74 2d 73 65 74 2d 61 6c sion:sdat-set-al
1510: 74 2d 70 61 67 65 2d 64 61 74 21 20 20 20 20 20 t-page-dat!
1520: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
1530: 6f 72 2d 73 65 74 21 20 76 65 63 20 31 36 20 76 or-set! vec 16 v
1540: 61 6c 29 29 0a 28 64 65 66 69 6e 65 2d 69 6e 6c al)).(define-inl
1550: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 64 61 ine (session:sda
1560: 74 2d 73 65 74 2d 70 61 67 65 76 61 72 73 21 20 t-set-pagevars!
1570: 20 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 vec v
1580: 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 al)(vector-set!
1590: 76 65 63 20 31 37 20 76 61 6c 29 29 0a 28 64 65 vec 17 val)).(de
15a0: 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 73 65 73 fine-inline (ses
15b0: 73 69 6f 6e 3a 73 64 61 74 2d 73 65 74 2d 70 61 sion:sdat-set-pa
15c0: 67 65 76 61 72 73 2d 62 65 66 6f 72 65 21 20 20 gevars-before!
15d0: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
15e0: 6f 72 2d 73 65 74 21 20 76 65 63 20 31 38 20 76 or-set! vec 18 v
15f0: 61 6c 29 29 0a 28 64 65 66 69 6e 65 2d 69 6e 6c al)).(define-inl
1600: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 64 61 ine (session:sda
1610: 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 t-set-sessionvar
1620: 73 21 20 20 20 20 20 20 20 20 20 76 65 63 20 76 s! 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 31 39 20 76 61 6c 29 29 0a 28 64 65 vec 19 val)).(de
1650: 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 73 65 73 fine-inline (ses
1660: 73 69 6f 6e 3a 73 64 61 74 2d 73 65 74 2d 73 65 sion:sdat-set-se
1670: 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 ssionvars-before
1680: 21 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 ! vec val)(vect
1690: 6f 72 2d 73 65 74 21 20 76 65 63 20 32 30 20 76 or-set! vec 20 v
16a0: 61 6c 29 29 0a 28 64 65 66 69 6e 65 2d 69 6e 6c al)).(define-inl
16b0: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 64 61 ine (session:sda
16c0: 74 2d 73 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 t-set-globalvars
16d0: 21 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 ! vec v
16e0: 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 al)(vector-set!
16f0: 76 65 63 20 32 31 20 76 61 6c 29 29 0a 28 64 65 vec 21 val)).(de
1700: 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 73 65 73 fine-inline (ses
1710: 73 69 6f 6e 3a 73 64 61 74 2d 73 65 74 2d 67 6c sion:sdat-set-gl
1720: 6f 62 61 6c 76 61 72 73 2d 62 65 66 6f 72 65 21 obalvars-before!
1730: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
1740: 6f 72 2d 73 65 74 21 20 76 65 63 20 32 32 20 76 or-set! vec 22 v
1750: 61 6c 29 29 0a 28 64 65 66 69 6e 65 2d 69 6e 6c al)).(define-inl
1760: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 64 61 ine (session:sda
1770: 74 2d 73 65 74 2d 6c 6f 67 70 74 21 20 20 20 20 t-set-logpt!
1780: 20 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 vec v
1790: 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 al)(vector-set!
17a0: 76 65 63 20 32 33 20 76 61 6c 29 29 0a 28 64 65 vec 23 val)).(de
17b0: 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 73 65 73 fine-inline (ses
17c0: 73 69 6f 6e 3a 73 64 61 74 2d 73 65 74 2d 66 6f sion:sdat-set-fo
17d0: 72 6d 64 61 74 21 20 20 20 20 20 20 20 20 20 20 rmdat!
17e0: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
17f0: 6f 72 2d 73 65 74 21 20 76 65 63 20 32 34 20 76 or-set! vec 24 v
1800: 61 6c 29 29 0a 28 64 65 66 69 6e 65 2d 69 6e 6c al)).(define-inl
1810: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 64 61 ine (session:sda
1820: 74 2d 73 65 74 2d 72 65 71 75 65 73 74 2d 6d 65 t-set-request-me
1830: 74 68 6f 64 21 20 20 20 20 20 20 76 65 63 20 76 thod! vec v
1840: 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 al)(vector-set!
1850: 76 65 63 20 32 35 20 76 61 6c 29 29 0a 28 64 65 vec 25 val)).(de
1860: 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 73 65 73 fine-inline (ses
1870: 73 69 6f 6e 3a 73 64 61 74 2d 73 65 74 2d 73 65 sion:sdat-set-se
1880: 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 21 20 20 20 ssion-cookie!
1890: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
18a0: 6f 72 2d 73 65 74 21 20 76 65 63 20 32 36 20 76 or-set! vec 26 v
18b0: 61 6c 29 29 0a 28 64 65 66 69 6e 65 2d 69 6e 6c al)).(define-inl
18c0: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 64 61 ine (session:sda
18d0: 74 2d 73 65 74 2d 63 75 72 72 2d 65 72 72 21 20 t-set-curr-err!
18e0: 20 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 vec v
18f0: 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 al)(vector-set!
1900: 76 65 63 20 32 37 20 76 61 6c 29 29 0a 28 64 65 vec 27 val)).(de
1910: 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 73 65 73 fine-inline (ses
1920: 73 69 6f 6e 3a 73 64 61 74 2d 73 65 74 2d 6c 6f sion:sdat-set-lo
1930: 67 2d 70 6f 72 74 21 20 20 20 20 20 20 20 20 20 g-port!
1940: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
1950: 6f 72 2d 73 65 74 21 20 76 65 63 20 32 38 20 76 or-set! vec 28 v
1960: 61 6c 29 29 0a 28 64 65 66 69 6e 65 2d 69 6e 6c al)).(define-inl
1970: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 64 61 ine (session:sda
1980: 74 2d 73 65 74 2d 6c 6f 67 66 69 6c 65 21 20 20 t-set-logfile!
1990: 20 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 vec v
19a0: 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 al)(vector-set!
19b0: 76 65 63 20 32 39 20 76 61 6c 29 29 0a 28 64 65 vec 29 val)).(de
19c0: 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 73 65 73 fine-inline (ses
19d0: 73 69 6f 6e 3a 73 64 61 74 2d 73 65 74 2d 73 65 sion:sdat-set-se
19e0: 65 6e 2d 70 61 67 65 73 21 20 20 20 20 20 20 20 en-pages!
19f0: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
1a00: 6f 72 2d 73 65 74 21 20 76 65 63 20 33 30 20 76 or-set! vec 30 v
1a10: 61 6c 29 29 0a 28 64 65 66 69 6e 65 2d 69 6e 6c al)).(define-inl
1a20: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 64 61 ine (session:sda
1a30: 74 2d 73 65 74 2d 70 61 67 65 2d 64 69 72 2d 73 t-set-page-dir-s
1a40: 74 79 6c 65 21 20 20 20 20 20 20 76 65 63 20 76 tyle! vec v
1a50: 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 al)(vector-set!
1a60: 76 65 63 20 33 31 20 76 61 6c 29 29 0a 28 64 65 vec 31 val)).(de
1a70: 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 73 65 73 fine-inline (ses
1a80: 73 69 6f 6e 3a 73 64 61 74 2d 73 65 74 2d 64 65 sion:sdat-set-de
1a90: 62 75 67 6d 6f 64 65 21 20 20 20 20 20 20 20 20 bugmode!
1aa0: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
1ab0: 6f 72 2d 73 65 74 21 20 76 65 63 20 33 32 20 76 or-set! vec 32 v
1ac0: 61 6c 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 al))..;; (define
1ad0: 2d 63 6c 61 73 73 20 3c 73 65 73 73 69 6f 6e 3e -class <session>
1ae0: 20 28 29 0a 3b 3b 20 20 20 28 64 62 74 79 70 65 ().;; (dbtype
1af0: 20 20 20 20 20 20 20 3b 3b 20 27 70 67 20 6f 72 ;; 'pg or
1b00: 20 27 73 71 6c 69 74 65 33 0a 3b 3b 20 20 20 20 'sqlite3.;;
1b10: 64 62 69 6e 69 74 0a 3b 3b 20 20 20 20 63 6f 6e dbinit.;; con
1b20: 6e 0a 3b 3b 20 20 20 20 70 61 72 61 6d 73 20 20 n.;; params
1b30: 20 20 20 20 20 3b 3b 20 70 61 72 61 6d 73 20 66 ;; params f
1b40: 72 6f 6d 20 74 68 65 20 6b 65 79 3d 76 61 6c 26 rom the key=val&
1b50: 6b 65 79 31 3d 76 61 6c 32 20 73 74 72 69 6e 67 key1=val2 string
1b60: 0a 3b 3b 20 20 20 20 70 61 74 68 2d 70 61 72 61 .;; path-para
1b70: 6d 73 20 20 3b 3b 20 72 65 6d 61 69 6e 69 6e 67 ms ;; remaining
1b80: 20 70 61 72 61 6d 73 20 66 72 6f 6d 20 74 68 65 params from the
1b90: 20 70 61 74 68 0a 3b 3b 20 20 20 20 73 65 73 73 path.;; sess
1ba0: 69 6f 6e 2d 6b 65 79 0a 3b 3b 20 20 20 20 73 65 ion-key.;; se
1bb0: 73 73 69 6f 6e 2d 69 64 0a 3b 3b 20 20 20 20 64 ssion-id.;; d
1bc0: 6f 6d 61 69 6e 0a 3b 3b 20 20 20 20 74 6f 70 70 omain.;; topp
1bd0: 61 67 65 20 20 20 20 20 20 3b 3b 20 64 65 66 61 age ;; defa
1be0: 75 6c 74 73 20 74 6f 20 22 69 6e 64 65 78 22 20 ults to "index"
1bf0: 2d 20 6f 76 65 72 72 69 64 65 20 69 6e 20 2e 73 - override in .s
1c00: 74 6d 6c 2e 63 6f 6e 66 69 67 20 69 66 20 64 65 tml.config if de
1c10: 73 69 72 65 64 0a 3b 3b 20 20 20 20 70 61 67 65 sired.;; page
1c20: 20 20 20 20 20 20 20 20 20 3b 3b 20 74 68 65 20 ;; the
1c30: 70 61 67 65 20 6e 61 6d 65 20 2d 20 64 65 66 61 page name - defa
1c40: 75 6c 74 73 20 74 6f 20 68 6f 6d 65 0a 3b 3b 20 ults to home.;;
1c50: 20 20 20 63 75 72 72 2d 70 61 67 65 20 20 20 20 curr-page
1c60: 3b 3b 20 74 68 65 20 63 75 72 72 65 6e 74 20 70 ;; the current p
1c70: 61 67 65 20 62 65 69 6e 67 20 65 76 61 6c 75 61 age being evalua
1c80: 74 65 64 0a 3b 3b 20 20 20 20 63 6f 6e 74 65 6e ted.;; conten
1c90: 74 2d 74 79 70 65 20 3b 3b 20 74 68 65 20 64 65 t-type ;; the de
1ca0: 66 61 75 6c 74 20 63 6f 6e 74 65 6e 74 20 74 79 fault content ty
1cb0: 70 65 20 69 73 20 74 65 78 74 2f 68 74 6d 6c 2c pe is text/html,
1cc0: 20 6f 76 65 72 72 69 64 65 20 74 6f 20 64 65 6c override to del
1cd0: 69 76 65 72 20 6f 74 68 65 72 20 73 74 75 66 66 iver other stuff
1ce0: 0a 3b 3b 20 20 20 20 70 61 67 65 2d 74 79 70 65 .;; page-type
1cf0: 20 20 20 20 3b 3b 20 75 73 65 20 69 6e 20 63 6f ;; use in co
1d00: 6e 6a 75 6e 63 74 69 6f 6e 20 77 69 74 68 20 63 njunction with c
1d10: 6f 6e 74 65 6e 74 2d 74 79 70 65 20 74 6f 20 64 ontent-type to d
1d20: 65 6c 69 76 65 72 20 6f 74 68 65 72 20 70 61 79 eliver other pay
1d30: 6c 6f 61 64 73 0a 3b 3b 20 20 20 20 73 72 6f 6f loads.;; sroo
1d40: 74 0a 3b 3b 20 20 20 20 74 77 69 6b 69 64 69 72 t.;; twikidir
1d50: 20 20 20 20 20 3b 3b 20 6c 6f 63 61 74 69 6f 6e ;; location
1d60: 20 66 6f 72 20 74 77 69 6b 69 73 20 2d 20 6e 65 for twikis - ne
1d70: 65 64 73 20 74 6f 20 62 65 20 66 75 6c 6c 79 20 eds to be fully
1d80: 77 72 69 74 61 62 6c 65 20 62 79 20 77 65 62 20 writable by web
1d90: 73 65 72 76 65 72 0a 3b 3b 20 20 20 20 70 61 67 server.;; pag
1da0: 65 64 61 74 0a 3b 3b 20 20 20 20 61 6c 74 2d 70 edat.;; alt-p
1db0: 61 67 65 2d 64 61 74 0a 3b 3b 20 20 20 20 70 61 age-dat.;; pa
1dc0: 67 65 76 61 72 73 20 20 20 20 20 3b 3b 20 73 65 gevars ;; se
1dd0: 73 73 69 6f 6e 20 76 61 72 73 20 73 70 65 63 69 ssion vars speci
1de0: 66 69 63 20 74 6f 20 74 68 69 73 20 70 61 67 65 fic to this page
1df0: 0a 3b 3b 20 20 20 20 70 61 67 65 76 61 72 73 2d .;; pagevars-
1e00: 62 65 66 6f 72 65 0a 3b 3b 20 20 20 20 73 65 73 before.;; ses
1e10: 73 69 6f 6e 76 61 72 73 20 20 3b 3b 20 73 65 73 sionvars ;; ses
1e20: 73 69 6f 6e 20 76 61 72 73 20 76 69 73 69 62 6c sion vars visibl
1e30: 65 20 74 6f 20 61 6c 6c 20 70 61 67 65 73 0a 3b e to all pages.;
1e40: 3b 20 20 20 20 73 65 73 73 69 6f 6e 76 61 72 73 ; sessionvars
1e50: 2d 62 65 66 6f 72 65 0a 3b 3b 20 20 20 20 67 6c -before.;; gl
1e60: 6f 62 61 6c 76 61 72 73 20 20 20 3b 3b 20 67 6c obalvars ;; gl
1e70: 6f 62 61 6c 20 76 61 72 73 20 76 69 73 69 62 6c obal vars visibl
1e80: 65 20 74 6f 20 61 6c 6c 20 73 65 73 73 69 6f 6e e to all session
1e90: 73 0a 3b 3b 20 20 20 20 67 6c 6f 62 61 6c 76 61 s.;; globalva
1ea0: 72 73 2d 62 65 66 6f 72 65 0a 3b 3b 20 20 20 20 rs-before.;;
1eb0: 6c 6f 67 70 74 0a 3b 3b 20 20 20 20 66 6f 72 6d logpt.;; form
1ec0: 64 61 74 0a 3b 3b 20 20 20 20 72 65 71 75 65 73 dat.;; reques
1ed0: 74 2d 6d 65 74 68 6f 64 0a 3b 3b 20 20 20 20 73 t-method.;; s
1ee0: 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 0a 3b 3b ession-cookie.;;
1ef0: 20 20 20 20 63 75 72 72 2d 65 72 72 0a 3b 3b 20 curr-err.;;
1f00: 20 20 20 6c 6f 67 2d 70 6f 72 74 0a 3b 3b 20 20 log-port.;;
1f10: 20 20 6c 6f 67 66 69 6c 65 0a 3b 3b 20 20 20 20 logfile.;;
1f20: 73 65 65 6e 2d 70 61 67 65 73 0a 3b 3b 20 20 20 seen-pages.;;
1f30: 20 70 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 20 page-dir-style
1f40: 20 3b 3b 20 23 74 20 3d 20 6e 65 77 20 73 74 79 ;; #t = new sty
1f50: 6c 65 2c 20 23 66 20 3d 20 6f 6c 64 20 73 74 79 le, #f = old sty
1f60: 6c 65 0a 3b 3b 20 20 20 20 64 65 62 75 67 6d 6f le.;; debugmo
1f70: 64 65 29 29 0a 0a 3b 3b 20 53 50 4c 49 54 20 49 de))..;; SPLIT I
1f80: 4e 54 4f 20 53 54 52 41 49 47 48 54 20 46 4f 52 NTO STRAIGHT FOR
1f90: 57 41 52 44 20 49 4e 49 54 20 41 4e 44 20 43 4f WARD INIT AND CO
1fa0: 4d 50 4c 45 58 20 49 4e 49 54 0a 28 64 65 66 69 MPLEX INIT.(defi
1fb0: 6e 65 20 28 69 6e 69 74 69 61 6c 69 7a 65 20 73 ne (initialize s
1fc0: 65 6c 66 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a elf). (session:
1fd0: 73 64 61 74 2d 73 65 74 2d 64 62 74 79 70 65 21 sdat-set-dbtype!
1fe0: 20 73 65 6c 66 20 20 20 20 20 20 27 70 67 29 0a self 'pg).
1ff0: 20 20 28 73 65 73 73 69 6f 6e 3a 73 64 61 74 2d (session:sdat-
2000: 73 65 74 2d 70 61 67 65 21 20 73 65 6c 66 20 20 set-page! self
2010: 20 20 20 20 20 20 22 68 6f 6d 65 22 29 20 20 20 "home")
2020: 20 20 20 20 20 3b 3b 20 74 68 65 73 65 20 61 72 ;; these ar
2030: 65 20 64 65 66 61 75 6c 74 73 0a 20 20 28 73 65 e defaults. (se
2040: 73 73 69 6f 6e 3a 73 64 61 74 2d 73 65 74 2d 63 ssion:sdat-set-c
2050: 75 72 72 2d 70 61 67 65 21 20 73 65 6c 66 20 20 urr-page! self
2060: 20 22 68 6f 6d 65 22 29 0a 20 20 28 73 65 73 73 "home"). (sess
2070: 69 6f 6e 3a 73 64 61 74 2d 73 65 74 2d 63 6f 6e ion:sdat-set-con
2080: 74 65 6e 74 2d 74 79 70 65 21 20 73 65 6c 66 20 tent-type! self
2090: 22 43 6f 6e 74 65 6e 74 2d 74 79 70 65 3a 20 74 "Content-type: t
20a0: 65 78 74 2f 68 74 6d 6c 3b 20 63 68 61 72 73 65 ext/html; charse
20b0: 74 3d 69 73 6f 2d 38 38 35 39 2d 31 5c 6e 5c 6e t=iso-8859-1\n\n
20c0: 22 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a 73 64 "). (session:sd
20d0: 61 74 2d 73 65 74 2d 70 61 67 65 2d 74 79 70 65 at-set-page-type
20e0: 21 20 73 65 6c 66 20 20 20 27 68 74 6d 6c 29 0a ! self 'html).
20f0: 20 20 28 73 65 73 73 69 6f 6e 3a 73 64 61 74 2d (session:sdat-
2100: 73 65 74 2d 74 6f 70 70 61 67 65 21 20 73 65 6c set-toppage! sel
2110: 66 20 20 20 20 20 22 69 6e 64 65 78 22 29 0a 20 f "index").
2120: 20 28 73 65 73 73 69 6f 6e 3a 73 64 61 74 2d 73 (session:sdat-s
2130: 65 74 2d 70 61 72 61 6d 73 21 20 73 65 6c 66 20 et-params! self
2140: 20 20 20 20 20 27 28 29 29 20 20 20 20 20 20 20 '())
2150: 20 20 20 20 3b 3b 0a 20 20 28 73 65 73 73 69 6f ;;. (sessio
2160: 6e 3a 73 64 61 74 2d 73 65 74 2d 70 61 74 68 2d n:sdat-set-path-
2170: 70 61 72 61 6d 73 21 20 73 65 6c 66 20 27 28 29 params! self '()
2180: 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a 73 64 61 ). (session:sda
2190: 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 t-set-session-ke
21a0: 79 21 20 73 65 6c 66 20 23 66 29 0a 20 20 28 73 y! self #f). (s
21b0: 65 73 73 69 6f 6e 3a 73 64 61 74 2d 73 65 74 2d ession:sdat-set-
21c0: 70 61 67 65 64 61 74 21 20 73 65 6c 66 20 20 20 pagedat! self
21d0: 20 20 27 28 29 29 0a 20 20 28 73 65 73 73 69 6f '()). (sessio
21e0: 6e 3a 73 64 61 74 2d 73 65 74 2d 61 6c 74 2d 70 n:sdat-set-alt-p
21f0: 61 67 65 2d 64 61 74 21 20 73 65 6c 66 20 23 66 age-dat! self #f
2200: 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a 73 64 61 ). (session:sda
2210: 74 2d 73 65 74 2d 73 72 6f 6f 74 21 20 73 65 6c t-set-sroot! sel
2220: 66 20 20 20 20 20 20 20 22 2e 2f 22 29 0a 20 20 f "./").
2230: 28 73 65 73 73 69 6f 6e 3a 73 64 61 74 2d 73 65 (session:sdat-se
2240: 74 2d 73 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 t-session-cookie
2250: 21 20 73 65 6c 66 20 23 66 29 0a 20 20 28 73 65 ! self #f). (se
2260: 73 73 69 6f 6e 3a 73 64 61 74 2d 73 65 74 2d 63 ssion:sdat-set-c
2270: 75 72 72 2d 65 72 72 21 20 73 65 6c 66 20 23 66 urr-err! self #f
2280: 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a 73 64 61 ). (session:sda
2290: 74 2d 73 65 74 2d 6c 6f 67 2d 70 6f 72 74 21 20 t-set-log-port!
22a0: 73 65 6c 66 20 28 63 75 72 72 65 6e 74 2d 65 72 self (current-er
22b0: 72 6f 72 2d 70 6f 72 74 29 29 0a 20 20 28 73 65 ror-port)). (se
22c0: 73 73 69 6f 6e 3a 73 64 61 74 2d 73 65 74 2d 73 ssion:sdat-set-s
22d0: 65 65 6e 2d 70 61 67 65 73 21 20 73 65 6c 66 20 een-pages! self
22e0: 27 28 29 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a '()). (session:
22f0: 73 64 61 74 2d 73 65 74 2d 70 61 67 65 2d 64 69 sdat-set-page-di
2300: 72 2d 73 74 79 6c 65 21 20 73 65 6c 66 20 23 74 r-style! self #t
2310: 29 20 3b 3b 20 23 74 20 3a 20 70 61 67 65 73 2f ) ;; #t : pages/
2320: 3c 70 61 67 65 6e 61 6d 65 3e 5f 28 76 69 65 77 <pagename>_(view
2330: 7c 63 6e 74 6c 29 2e 73 63 6d 0a 20 20 20 20 20 |cntl).scm.
2340: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2350: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2360: 20 3b 3b 20 23 66 20 3a 20 70 61 67 65 73 2f 3c ;; #f : pages/<
2370: 70 61 67 65 6e 61 6d 65 3e 2f 28 76 69 65 77 7c pagename>/(view|
2380: 63 6f 6e 74 72 6f 6c 29 2e 73 63 6d 20 0a 20 20 control).scm .
2390: 28 73 65 73 73 69 6f 6e 3a 73 64 61 74 2d 73 65 (session:sdat-se
23a0: 74 2d 64 65 62 75 67 6d 6f 64 65 21 20 73 65 6c t-debugmode! sel
23b0: 66 20 23 66 29 0a 20 20 28 66 6f 72 2d 65 61 63 f #f). (for-eac
23c0: 68 20 28 6c 61 6d 62 64 61 20 28 73 6c 6f 74 2d h (lambda (slot-
23d0: 6e 61 6d 65 29 0a 20 20 20 20 20 20 20 20 20 20 name).
23e0: 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 73 64 61 (session:sda
23f0: 74 2d 73 65 74 2d 6c 6f 74 2d 6e 61 6d 65 21 20 t-set-lot-name!
2400: 73 65 6c 66 20 28 6d 61 6b 65 2d 68 61 73 68 2d self (make-hash-
2410: 74 61 62 6c 65 29 29 29 0a 20 20 20 20 20 20 20 table))).
2420: 20 20 20 20 20 28 6c 69 73 74 20 27 70 61 67 65 (list 'page
2430: 76 61 72 73 20 27 73 65 73 73 69 6f 6e 76 61 72 vars 'sessionvar
2440: 73 20 27 67 6c 6f 62 61 6c 76 61 72 73 20 27 70 s 'globalvars 'p
2450: 61 67 65 76 61 72 73 2d 62 65 66 6f 72 65 20 0a agevars-before .
2460: 09 09 20 20 27 73 65 73 73 69 6f 6e 76 61 72 73 .. 'sessionvars
2470: 2d 62 65 66 6f 72 65 20 27 67 6c 6f 62 61 6c 76 -before 'globalv
2480: 61 72 73 2d 62 65 66 6f 72 65 29 29 0a 20 20 28 ars-before)). (
2490: 73 65 73 73 69 6f 6e 3a 73 64 61 74 2d 73 65 74 session:sdat-set
24a0: 2d 64 6f 6d 61 69 6e 21 20 73 65 6c 66 20 22 6c -domain! self "l
24b0: 6f 63 61 68 6f 73 74 22 29 20 20 20 3b 3b 20 65 ocahost") ;; e
24c0: 6e 64 20 6f 66 20 64 65 66 61 75 6c 74 73 0a 20 nd of defaults.
24d0: 20 28 69 6e 69 74 69 61 6c 69 7a 65 2d 73 6c 6f (initialize-slo
24e0: 74 73 20 73 65 6c 66 20 28 73 65 73 73 69 6f 6e ts self (session
24f0: 3a 72 65 61 64 2d 63 6f 6e 66 69 67 20 73 65 6c :read-config sel
2500: 66 29 29 0a 0a 20 20 3b 3b 20 46 49 58 4d 45 20 f)).. ;; FIXME
2510: 2d 20 4e 4f 54 20 41 55 54 4f 4d 41 54 49 43 41 - NOT AUTOMATICA
2520: 4c 4c 59 20 54 52 41 4e 53 4c 41 54 45 44 0a 20 LLY TRANSLATED.
2530: 20 3b 3b 20 73 6f 6d 65 20 76 61 6c 75 65 73 20 ;; some values
2540: 72 65 61 64 20 69 6e 20 66 72 6f 6d 20 74 68 65 read in from the
2550: 20 63 6f 6e 66 69 67 20 66 69 6c 65 20 6e 65 65 config file nee
2560: 64 20 74 6f 20 62 65 20 65 76 61 6c 65 64 0a 20 d to be evaled.
2570: 20 28 73 65 73 73 69 6f 6e 3a 73 64 61 74 2d 73 (session:sdat-s
2580: 65 74 2d 64 62 74 79 70 65 21 20 73 65 6c 66 20 et-dbtype! self
2590: 28 65 76 61 6c 20 28 73 65 73 73 69 6f 6e 3a 73 (eval (session:s
25a0: 64 61 74 2d 67 65 74 2d 64 62 74 79 70 65 20 73 dat-get-dbtype s
25b0: 65 6c 66 29 29 29 29 0a 0a 0a 28 64 65 66 69 6e elf))))...(defin
25c0: 65 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 e (session:setup
25d0: 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 self). (let ((
25e0: 64 62 74 79 70 65 20 28 73 65 73 73 69 6f 6e 3a dbtype (session:
25f0: 73 64 61 74 2d 67 65 74 2d 64 62 74 79 70 65 20 sdat-get-dbtype
2600: 73 65 6c 66 29 29 0a 09 28 64 62 69 6e 69 74 20 self))..(dbinit
2610: 28 65 76 61 6c 20 28 73 65 73 73 69 6f 6e 3a 73 (eval (session:s
2620: 64 61 74 2d 67 65 74 2d 64 62 69 6e 69 74 20 73 dat-get-dbinit s
2630: 65 6c 66 29 29 29 0a 09 28 64 62 65 78 69 73 74 elf)))..(dbexist
2640: 73 20 23 66 29 29 0a 20 20 20 20 28 6c 65 74 20 s #f)). (let
2650: 28 28 64 62 66 6e 61 6d 65 20 28 61 6c 69 73 74 ((dbfname (alist
2660: 2d 72 65 66 20 27 64 62 6e 61 6d 65 20 64 62 69 -ref 'dbname dbi
2670: 6e 69 74 29 29 29 0a 20 20 20 20 20 20 28 69 66 nit))). (if
2680: 20 28 65 71 3f 20 64 62 74 79 70 65 20 27 73 71 (eq? dbtype 'sq
2690: 6c 69 74 65 33 29 0a 09 20 20 28 69 66 20 28 66 lite3).. (if (f
26a0: 69 6c 65 2d 65 78 69 73 74 73 3f 20 64 62 66 6e ile-exists? dbfn
26b0: 61 6d 65 29 0a 09 20 20 20 20 20 20 28 62 65 67 ame).. (beg
26c0: 69 6e 0a 09 09 3b 3b 20 28 73 65 73 73 69 6f 6e in...;; (session
26d0: 3a 6c 6f 67 20 73 65 6c 66 20 22 73 65 74 74 69 :log self "setti
26e0: 6e 67 20 64 62 65 78 69 73 74 73 20 74 6f 20 23 ng dbexists to #
26f0: 74 22 29 0a 09 09 28 73 65 74 21 20 64 62 65 78 t")...(set! dbex
2700: 69 73 74 73 20 23 74 29 29 29 29 0a 20 20 20 20 ists #t)))).
2710: 20 20 3b 3b 20 28 73 65 73 73 69 6f 6e 3a 6c 6f ;; (session:lo
2720: 67 20 73 65 6c 66 20 22 64 62 74 79 70 65 3a 20 g self "dbtype:
2730: 22 20 64 62 74 79 70 65 20 22 20 64 62 66 6e 61 " dbtype " dbfna
2740: 6d 65 3a 20 22 20 64 62 66 6e 61 6d 65 20 22 20 me: " dbfname "
2750: 64 62 65 78 69 73 74 73 3a 20 22 20 64 62 65 78 dbexists: " dbex
2760: 69 73 74 73 29 29 0a 20 20 20 20 20 20 29 0a 20 ists)). ).
2770: 20 20 20 28 73 65 73 73 69 6f 6e 3a 73 64 61 74 (session:sdat
2780: 2d 73 65 74 2d 63 6f 6e 6e 21 20 73 65 6c 66 20 -set-conn! self
2790: 28 64 62 69 3a 6f 70 65 6e 20 64 62 74 79 70 65 (dbi:open dbtype
27a0: 20 64 62 69 6e 69 74 29 29 0a 20 20 20 20 28 69 dbinit)). (i
27b0: 66 20 28 61 6e 64 20 28 6e 6f 74 20 64 62 65 78 f (and (not dbex
27c0: 69 73 74 73 29 28 65 71 3f 20 64 62 74 79 70 65 ists)(eq? dbtype
27d0: 20 27 73 71 6c 69 74 65 33 29 29 0a 20 09 28 62 'sqlite3)). .(b
27e0: 65 67 69 6e 0a 09 20 20 28 70 72 69 6e 74 20 22 egin.. (print "
27f0: 57 41 52 4e 49 4e 47 3a 20 53 65 74 74 69 6e 67 WARNING: Setting
2800: 20 75 70 20 73 65 73 73 69 6f 6e 20 64 62 20 77 up session db w
2810: 69 74 68 20 73 71 6c 69 74 65 33 22 29 0a 09 20 ith sqlite3")..
2820: 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 2d (session:setup-
2830: 64 62 20 73 65 6c 66 29 29 29 0a 20 20 20 20 28 db self))). (
2840: 73 65 73 73 69 6f 6e 3a 70 72 6f 63 65 73 73 2d session:process-
2850: 75 72 6c 2d 70 61 74 68 20 73 65 6c 66 29 0a 20 url-path self).
2860: 20 20 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 75 (session:setu
2870: 70 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 p-session-key se
2880: 6c 66 29 0a 20 20 20 20 3b 3b 20 63 61 70 74 75 lf). ;; captu
2890: 72 65 20 73 74 64 69 6e 20 69 66 20 74 68 69 73 re stdin if this
28a0: 20 69 73 20 61 20 50 4f 53 54 0a 20 20 20 20 28 is a POST. (
28b0: 73 65 73 73 69 6f 6e 3a 73 64 61 74 2d 73 65 74 session:sdat-set
28c0: 2d 72 65 71 75 65 73 74 2d 6d 65 74 68 6f 64 21 -request-method!
28d0: 20 73 65 6c 66 20 28 67 65 74 65 6e 76 20 22 52 self (getenv "R
28e0: 45 51 55 45 53 54 5f 4d 45 54 48 4f 44 22 29 29 EQUEST_METHOD"))
28f0: 0a 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 73 64 . (session:sd
2900: 61 74 2d 73 65 74 2d 66 6f 72 6d 64 61 74 21 20 at-set-formdat!
2910: 73 65 6c 66 20 28 66 6f 72 6d 64 61 74 3a 6c 6f self (formdat:lo
2920: 61 64 2d 61 6c 6c 29 29 29 29 0a 0a 3b 3b 20 73 ad-all))))..;; s
2930: 65 74 75 70 20 74 68 65 20 64 62 20 77 69 74 68 etup the db with
2940: 20 73 65 73 73 69 6f 6e 20 74 61 62 6c 65 73 2c session tables,
2950: 20 77 6f 72 6b 73 20 66 6f 72 20 73 71 6c 69 74 works for sqlit
2960: 65 20 6f 6e 6c 79 20 72 69 67 68 74 20 6e 6f 77 e only right now
2970: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
2980: 6e 3a 73 65 74 75 70 2d 64 62 20 73 65 6c 66 29 n:setup-db self)
2990: 0a 20 20 28 6c 65 74 20 28 28 63 6f 6e 6e 20 28 . (let ((conn (
29a0: 73 65 73 73 69 6f 6e 3a 73 64 61 74 2d 67 65 74 session:sdat-get
29b0: 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 29 0a 20 20 -conn self))).
29c0: 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 (for-each .
29d0: 20 20 28 6c 61 6d 62 64 61 20 28 73 74 6d 74 29 (lambda (stmt)
29e0: 0a 20 20 20 20 20 20 20 28 64 62 69 3a 65 78 65 . (dbi:exe
29f0: 63 20 63 6f 6e 6e 20 73 74 6d 74 29 29 0a 20 20 c conn stmt)).
2a00: 20 20 20 28 6c 69 73 74 20 22 43 52 45 41 54 45 (list "CREATE
2a10: 20 54 41 42 4c 45 20 73 65 73 73 69 6f 6e 5f 76 TABLE session_v
2a20: 61 72 73 20 28 69 64 20 49 4e 54 45 47 45 52 20 ars (id INTEGER
2a30: 50 52 49 4d 41 52 59 20 4b 45 59 2c 73 65 73 73 PRIMARY KEY,sess
2a40: 69 6f 6e 5f 69 64 20 49 4e 54 45 47 45 52 2c 70 ion_id INTEGER,p
2a50: 61 67 65 20 54 45 58 54 2c 6b 65 79 20 54 45 58 age TEXT,key TEX
2a60: 54 2c 76 61 6c 75 65 20 54 45 58 54 29 3b 22 0a T,value TEXT);".
2a70: 09 20 20 20 22 43 52 45 41 54 45 20 54 41 42 4c . "CREATE TABL
2a80: 45 20 73 65 73 73 69 6f 6e 73 20 28 69 64 20 49 E sessions (id I
2a90: 4e 54 45 47 45 52 20 50 52 49 4d 41 52 59 20 4b NTEGER PRIMARY K
2aa0: 45 59 2c 73 65 73 73 69 6f 6e 5f 6b 65 79 20 54 EY,session_key T
2ab0: 45 58 54 2c 6c 61 73 74 5f 75 73 65 64 20 54 49 EXT,last_used TI
2ac0: 4d 45 53 54 41 4d 50 29 3b 22 0a 20 20 20 20 20 MESTAMP);".
2ad0: 20 20 20 20 20 20 22 43 52 45 41 54 45 20 54 41 "CREATE TA
2ae0: 42 4c 45 20 6d 65 74 61 64 61 74 61 20 28 69 64 BLE metadata (id
2af0: 20 49 4e 54 45 47 45 52 20 50 52 49 4d 41 52 59 INTEGER PRIMARY
2b00: 20 4b 45 59 2c 6b 65 79 20 54 45 58 54 2c 76 61 KEY,key TEXT,va
2b10: 6c 75 65 20 54 45 58 54 29 3b 22 29 29 29 29 0a lue TEXT);")))).
2b20: 3b 3b 20 20 3b 3b 20 69 66 20 77 65 20 68 61 76 ;; ;; if we hav
2b30: 65 20 61 20 73 65 73 73 69 6f 6e 5f 6b 65 79 20 e a session_key
2b40: 6c 6f 6f 6b 20 75 70 20 74 68 65 20 73 65 73 73 look up the sess
2b50: 69 6f 6e 2d 69 64 20 61 6e 64 20 73 74 6f 72 65 ion-id and store
2b60: 20 69 74 0a 3b 3b 20 20 28 73 65 73 73 69 6f 6e it.;; (session
2b70: 3a 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f :sdat-set-sessio
2b80: 6e 2d 69 64 21 20 73 65 6c 66 20 28 73 65 73 73 n-id! self (sess
2b90: 69 6f 6e 3a 67 65 74 2d 69 64 20 73 65 6c 66 29 ion:get-id self)
2ba0: 29 29 0a 0a 3b 3b 20 6f 6e 6c 79 20 73 65 74 20 ))..;; only set
2bb0: 73 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 20 77 session-cookie w
2bc0: 68 65 6e 20 61 20 6e 65 77 20 73 65 73 73 69 6f hen a new sessio
2bd0: 6e 20 69 73 20 63 72 65 61 74 65 64 0a 28 64 65 n is created.(de
2be0: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 65 fine (session:se
2bf0: 74 75 70 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 tup-session-key
2c00: 73 65 6c 66 29 20 20 0a 20 20 28 6c 65 74 2a 20 self) . (let*
2c10: 28 28 73 6b 20 20 28 73 65 73 73 69 6f 6e 3a 65 ((sk (session:e
2c20: 78 74 72 61 63 74 2d 73 65 73 73 69 6f 6e 2d 6b xtract-session-k
2c30: 65 79 20 73 65 6c 66 29 29 0a 20 20 20 20 20 20 ey self)).
2c40: 20 20 20 28 73 69 64 20 28 69 66 20 73 6b 20 28 (sid (if sk (
2c50: 73 65 73 73 69 6f 6e 3a 67 65 74 2d 69 64 20 73 session:get-id s
2c60: 65 6c 66 20 73 6b 29 20 23 66 29 29 29 0a 20 20 elf sk) #f))).
2c70: 20 20 28 69 66 20 28 6e 6f 74 20 73 69 64 29 20 (if (not sid)
2c80: 3b 3b 20 6e 65 65 64 20 61 20 6e 65 77 20 6b 65 ;; need a new ke
2c90: 79 0a 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 y. (let*
2ca0: 28 28 6e 65 77 2d 6b 65 79 20 28 73 65 73 73 69 ((new-key (sessi
2cb0: 6f 6e 3a 67 65 74 2d 6e 65 77 2d 6b 65 79 20 73 on:get-new-key s
2cc0: 65 6c 66 29 29 0a 20 20 20 20 20 20 20 20 20 20 elf)).
2cd0: 20 20 20 20 20 28 6e 65 77 2d 73 69 64 20 28 73 (new-sid (s
2ce0: 65 73 73 69 6f 6e 3a 67 65 74 2d 69 64 20 73 65 ession:get-id se
2cf0: 6c 66 20 6e 65 77 2d 6b 65 79 29 29 29 0a 20 20 lf new-key))).
2d00: 20 20 20 20 20 20 20 20 28 73 65 73 73 69 6f 6e (session
2d10: 3a 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f :sdat-set-sessio
2d20: 6e 2d 6b 65 79 21 20 73 65 6c 66 20 6e 65 77 2d n-key! self new-
2d30: 6b 65 79 29 0a 20 20 20 20 20 20 20 20 20 20 28 key). (
2d40: 73 65 73 73 69 6f 6e 3a 73 64 61 74 2d 73 65 74 session:sdat-set
2d50: 2d 73 65 73 73 69 6f 6e 2d 69 64 21 20 73 65 6c -session-id! sel
2d60: 66 20 6e 65 77 2d 73 69 64 29 0a 20 20 20 20 20 f new-sid).
2d70: 20 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 73 64 (session:sd
2d80: 61 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e 2d 63 at-set-session-c
2d90: 6f 6f 6b 69 65 21 20 73 65 6c 66 20 28 73 65 73 ookie! self (ses
2da0: 73 69 6f 6e 3a 6d 61 6b 65 2d 63 6f 6f 6b 69 65 sion:make-cookie
2db0: 20 73 65 6c 66 29 29 29 0a 20 20 20 20 20 20 20 self))).
2dc0: 20 28 73 65 73 73 69 6f 6e 3a 73 64 61 74 2d 73 (session:sdat-s
2dd0: 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 21 20 73 et-session-id! s
2de0: 65 6c 66 20 73 69 64 29 29 29 29 0a 0a 28 64 65 elf sid))))..(de
2df0: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 6d 61 fine (session:ma
2e00: 6b 65 2d 63 6f 6f 6b 69 65 20 73 65 6c 66 29 0a ke-cookie self).
2e10: 20 20 3b 3b 20 28 6c 69 73 74 20 28 63 6f 6e 63 ;; (list (conc
2e20: 20 22 73 65 73 73 69 6f 6e 5f 6b 65 79 3d 22 20 "session_key="
2e30: 28 73 65 73 73 69 6f 6e 3a 73 64 61 74 2d 67 65 (session:sdat-ge
2e40: 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 t-session-key se
2e50: 6c 66 29 20 22 3b 20 50 61 74 68 3d 2f 3b 20 44 lf) "; Path=/; D
2e60: 6f 6d 61 69 6e 3d 2e 22 20 28 73 65 73 73 69 6f omain=." (sessio
2e70: 6e 3a 73 64 61 74 2d 67 65 74 2d 64 6f 6d 61 69 n:sdat-get-domai
2e80: 6e 20 73 65 6c 66 29 20 22 3b 20 4d 61 78 2d 41 n self) "; Max-A
2e90: 67 65 3d 22 20 28 2a 20 38 36 34 30 30 20 31 34 ge=" (* 86400 14
2ea0: 29 20 22 3b 20 56 65 72 73 69 6f 6e 3d 31 22 29 ) "; Version=1")
2eb0: 29 29 20 0a 20 20 28 6c 69 73 74 20 28 73 74 72 )) . (list (str
2ec0: 69 6e 67 2d 73 75 62 73 74 69 74 75 74 65 20 0a ing-substitute .
2ed0: 09 20 22 3b 22 20 22 3b 20 22 20 0a 09 20 28 63 . ";" "; " .. (c
2ee0: 61 72 20 28 63 6f 6e 73 74 72 75 63 74 2d 63 6f ar (construct-co
2ef0: 6f 6b 69 65 2d 73 74 72 69 6e 67 20 0a 09 20 20 okie-string ..
2f00: 20 20 20 20 20 3b 3b 20 77 61 72 6e 69 6e 67 21 ;; warning!
2f10: 20 6d 65 73 73 69 6e 67 20 75 70 20 74 68 69 73 messing up this
2f20: 20 69 74 74 79 20 62 69 74 74 79 20 62 69 74 20 itty bitty bit
2f30: 6f 66 20 63 6f 64 65 20 77 69 6c 6c 20 63 6f 73 of code will cos
2f40: 74 20 6d 75 63 68 20 74 69 6d 65 21 0a 09 20 20 t much time!..
2f50: 20 20 20 20 20 60 28 28 22 73 65 73 73 69 6f 6e `(("session
2f60: 5f 6b 65 79 22 20 2c 28 73 65 73 73 69 6f 6e 3a _key" ,(session:
2f70: 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e sdat-get-session
2f80: 2d 6b 65 79 20 73 65 6c 66 29 0a 09 09 20 20 65 -key self)... e
2f90: 78 70 69 72 65 73 3a 20 2c 28 2b 20 28 63 75 72 xpires: ,(+ (cur
2fa0: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 28 2a rent-seconds) (*
2fb0: 20 31 34 20 38 36 34 30 30 29 29 20 0a 09 09 20 14 86400)) ...
2fc0: 20 6d 61 78 2d 61 67 65 3a 20 28 2a 20 31 34 20 max-age: (* 14
2fd0: 38 36 34 30 30 29 0a 09 09 20 20 70 61 74 68 3a 86400)... path:
2fe0: 20 22 2f 22 20 3b 3b 20 0a 09 09 20 20 64 6f 6d "/" ;; ... dom
2ff0: 61 69 6e 3a 20 2c 28 73 74 72 69 6e 67 2d 61 70 ain: ,(string-ap
3000: 70 65 6e 64 20 22 2e 22 20 28 73 65 73 73 69 6f pend "." (sessio
3010: 6e 3a 73 64 61 74 2d 67 65 74 2d 64 6f 6d 61 69 n:sdat-get-domai
3020: 6e 20 73 65 6c 66 29 29 0a 09 09 20 20 76 65 72 n self))... ver
3030: 73 69 6f 6e 3a 20 31 29 29 20 30 29 29 29 29 29 sion: 1)) 0)))))
3040: 0a 0a 3b 3b 20 6c 6f 6f 6b 20 75 70 20 61 20 67 ..;; look up a g
3050: 69 76 65 6e 20 73 65 73 73 69 6f 6e 20 6b 65 79 iven session key
3060: 20 61 6e 64 20 72 65 74 75 72 6e 20 74 68 65 20 and return the
3070: 69 64 20 69 66 20 66 6f 75 6e 64 2c 20 23 66 20 id if found, #f
3080: 69 66 20 6e 6f 74 20 66 6f 75 6e 64 0a 28 64 65 if not found.(de
3090: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 fine (session:ge
30a0: 74 2d 69 64 20 73 65 6c 66 20 73 65 73 73 69 6f t-id self sessio
30b0: 6e 2d 6b 65 79 29 0a 20 20 3b 3b 20 28 6c 65 74 n-key). ;; (let
30c0: 20 28 28 73 65 73 73 69 6f 6e 2d 6b 65 79 20 28 ((session-key (
30d0: 73 65 73 73 69 6f 6e 3a 73 64 61 74 2d 67 65 74 session:sdat-get
30e0: 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c -session-key sel
30f0: 66 29 29 29 0a 20 20 28 69 66 20 73 65 73 73 69 f))). (if sessi
3100: 6f 6e 2d 6b 65 79 0a 20 20 20 20 20 20 28 6c 65 on-key. (le
3110: 74 20 28 28 71 75 65 72 79 20 28 73 74 72 69 6e t ((query (strin
3120: 67 2d 61 70 70 65 6e 64 20 22 53 45 4c 45 43 54 g-append "SELECT
3130: 20 69 64 20 46 52 4f 4d 20 73 65 73 73 69 6f 6e id FROM session
3140: 73 20 57 48 45 52 45 20 73 65 73 73 69 6f 6e 5f s WHERE session_
3150: 6b 65 79 3d 27 22 20 73 65 73 73 69 6f 6e 2d 6b key='" session-k
3160: 65 79 20 22 27 22 29 29 0a 20 20 20 20 20 20 20 ey "'")).
3170: 20 20 20 20 20 28 63 6f 6e 6e 20 28 73 65 73 73 (conn (sess
3180: 69 6f 6e 3a 73 64 61 74 2d 67 65 74 2d 63 6f 6e ion:sdat-get-con
3190: 6e 20 73 65 6c 66 29 29 0a 20 20 20 20 20 20 20 n self)).
31a0: 20 20 20 20 20 28 72 65 73 75 6c 74 20 23 66 29 (result #f)
31b0: 29 0a 09 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 )..(dbi:for-each
31c0: 2d 72 6f 77 20 0a 09 20 28 6c 61 6d 62 64 61 20 -row .. (lambda
31d0: 28 74 75 70 6c 65 29 0a 09 20 20 20 28 73 65 74 (tuple).. (set
31e0: 21 20 72 65 73 75 6c 74 20 28 76 65 63 74 6f 72 ! result (vector
31f0: 2d 72 65 66 20 74 75 70 6c 65 20 30 29 29 29 0a -ref tuple 0))).
3200: 09 20 63 6f 6e 6e 20 71 75 65 72 79 29 0a 09 28 . conn query)..(
3210: 69 66 20 72 65 73 75 6c 74 20 28 64 62 69 3a 65 if result (dbi:e
3220: 78 65 63 20 63 6f 6e 6e 20 28 63 6f 6e 63 20 22 xec conn (conc "
3230: 55 50 44 41 54 45 20 73 65 73 73 69 6f 6e 73 20 UPDATE sessions
3240: 53 45 54 20 6c 61 73 74 5f 75 73 65 64 3d 22 20 SET last_used="
3250: 28 64 62 69 3a 6e 6f 77 20 63 6f 6e 6e 29 20 22 (dbi:now conn) "
3260: 20 57 48 45 52 45 20 73 65 73 73 69 6f 6e 5f 6b WHERE session_k
3270: 65 79 3d 3f 3b 22 29 20 73 65 73 73 69 6f 6e 2d ey=?;") session-
3280: 6b 65 79 29 29 0a 20 20 20 20 20 20 20 20 72 65 key)). re
3290: 73 75 6c 74 29 0a 20 20 20 20 20 20 23 66 29 29 sult). #f))
32a0: 0a 0a 3b 3b 20 0a 28 64 65 66 69 6e 65 20 28 73 ..;; .(define (s
32b0: 65 73 73 69 6f 6e 3a 70 72 6f 63 65 73 73 2d 75 ession:process-u
32c0: 72 6c 2d 70 61 74 68 20 73 65 6c 66 29 0a 20 20 rl-path self).
32d0: 28 6c 65 74 20 28 28 70 61 74 68 2d 69 6e 66 6f (let ((path-info
32e0: 20 20 20 20 28 67 65 74 65 6e 76 20 22 50 41 54 (getenv "PAT
32f0: 48 5f 49 4e 46 4f 22 29 29 0a 09 28 71 75 65 72 H_INFO"))..(quer
3300: 79 2d 73 74 72 69 6e 67 20 28 67 65 74 65 6e 76 y-string (getenv
3310: 20 22 51 55 45 52 59 5f 53 54 52 49 4e 47 22 29 "QUERY_STRING")
3320: 29 29 0a 20 20 20 20 3b 3b 20 28 73 65 73 73 69 )). ;; (sessi
3330: 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 70 61 74 on:log self "pat
3340: 68 2d 69 6e 66 6f 3d 22 20 70 61 74 68 2d 69 6e h-info=" path-in
3350: 66 6f 20 22 20 71 75 65 72 79 2d 73 74 72 69 6e fo " query-strin
3360: 67 3d 22 20 71 75 65 72 79 2d 73 74 72 69 6e 67 g=" query-string
3370: 29 0a 20 20 20 20 28 69 66 20 70 61 74 68 2d 69 ). (if path-i
3380: 6e 66 6f 0a 09 28 6c 65 74 2a 20 28 28 70 61 72 nfo..(let* ((par
3390: 74 73 20 20 20 20 28 73 74 72 69 6e 67 2d 73 70 ts (string-sp
33a0: 6c 69 74 20 70 61 74 68 2d 69 6e 66 6f 20 22 2f lit path-info "/
33b0: 22 29 29 0a 09 20 20 20 20 20 20 20 28 6e 75 6d ")).. (num
33c0: 70 61 72 74 73 20 28 6c 65 6e 67 74 68 20 70 61 parts (length pa
33d0: 72 74 73 29 29 29 0a 09 20 20 28 69 66 20 28 3e rts))).. (if (>
33e0: 20 6e 75 6d 70 61 72 74 73 20 30 29 0a 09 20 20 numparts 0)..
33f0: 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 73 64 61 (session:sda
3400: 74 2d 73 65 74 2d 70 61 67 65 21 20 73 65 6c 66 t-set-page! self
3410: 20 28 63 61 72 20 70 61 72 74 73 29 29 29 0a 09 (car parts)))..
3420: 20 20 3b 3b 20 28 73 65 73 73 69 6f 6e 3a 6c 6f ;; (session:lo
3430: 67 20 73 65 6c 66 20 22 75 72 6c 2d 70 61 74 68 g self "url-path
3440: 3d 22 20 75 72 6c 2d 70 61 74 68 20 22 20 70 61 =" url-path " pa
3450: 72 74 73 3d 22 20 70 61 72 74 73 29 0a 09 20 20 rts=" parts)..
3460: 28 69 66 20 28 3e 20 6e 75 6d 70 61 72 74 73 20 (if (> numparts
3470: 31 29 0a 09 20 20 20 20 20 20 28 73 65 73 73 69 1).. (sessi
3480: 6f 6e 3a 73 64 61 74 2d 73 65 74 2d 70 61 74 68 on:sdat-set-path
3490: 2d 70 61 72 61 6d 73 21 20 73 65 6c 66 20 28 63 -params! self (c
34a0: 64 72 20 70 61 72 74 73 29 29 29 0a 20 20 20 20 dr parts))).
34b0: 20 20 20 20 20 20 28 69 66 20 71 75 65 72 79 2d (if query-
34c0: 73 74 72 69 6e 67 0a 20 20 20 20 20 20 20 20 20 string.
34d0: 20 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 73 64 (session:sd
34e0: 61 74 2d 73 65 74 2d 70 61 72 61 6d 73 21 20 73 at-set-params! s
34f0: 65 6c 66 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 elf (string-spli
3500: 74 20 71 75 65 72 79 2d 73 74 72 69 6e 67 20 22 t query-string "
3510: 26 22 29 29 29 29 29 29 29 0a 0a 3b 3b 20 42 55 &")))))))..;; BU
3520: 47 47 59 21 0a 28 64 65 66 69 6e 65 20 28 73 65 GGY!.(define (se
3530: 73 73 69 6f 6e 3a 67 65 74 2d 6e 65 77 2d 6b 65 ssion:get-new-ke
3540: 79 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 20 28 y self). (let (
3550: 28 63 6f 6e 6e 20 20 20 28 73 65 73 73 69 6f 6e (conn (session
3560: 3a 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 :sdat-get-conn s
3570: 65 6c 66 29 29 0a 20 20 20 20 20 20 20 20 28 74 elf)). (t
3580: 6d 70 6b 65 79 20 28 73 65 73 73 69 6f 6e 3a 6d mpkey (session:m
3590: 61 6b 65 2d 72 61 6e 64 2d 73 74 72 69 6e 67 20 ake-rand-string
35a0: 32 30 29 29 0a 20 20 20 20 20 20 20 20 28 73 74 20)). (st
35b0: 61 74 75 73 20 23 66 29 29 0a 20 20 20 20 28 64 atus #f)). (d
35c0: 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 bi:for-each-row
35d0: 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 29 0a (lambda (tuple).
35e0: 09 09 09 28 73 65 74 21 20 73 74 61 74 75 73 20 ...(set! status
35f0: 23 74 29 29 0a 09 09 20 20 20 20 20 20 63 6f 6e #t))... con
3600: 6e 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 n (string-append
3610: 20 22 49 4e 53 45 52 54 20 49 4e 54 4f 20 73 65 "INSERT INTO se
3620: 73 73 69 6f 6e 73 20 28 73 65 73 73 69 6f 6e 5f ssions (session_
3630: 6b 65 79 29 20 56 41 4c 55 45 53 20 28 27 22 20 key) VALUES ('"
3640: 74 6d 70 6b 65 79 20 22 27 29 22 29 29 0a 20 20 tmpkey "')")).
3650: 20 20 74 6d 70 6b 65 79 29 29 0a 0a 3b 3b 20 72 tmpkey))..;; r
3660: 65 74 75 72 6e 73 20 73 65 73 73 69 6f 6e 20 6b eturns session k
3670: 65 79 20 49 46 46 20 69 74 20 69 73 20 69 6e 20 ey IFF it is in
3680: 74 68 65 20 48 54 54 50 5f 43 4f 4f 4b 49 45 20 the HTTP_COOKIE
3690: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
36a0: 6e 3a 65 78 74 72 61 63 74 2d 73 65 73 73 69 6f n:extract-sessio
36b0: 6e 2d 6b 65 79 20 73 65 6c 66 29 0a 20 20 28 6c n-key self). (l
36c0: 65 74 20 28 28 68 74 74 70 2d 73 65 73 73 69 6f et ((http-sessio
36d0: 6e 20 28 67 65 74 65 6e 76 20 22 48 54 54 50 5f n (getenv "HTTP_
36e0: 43 4f 4f 4b 49 45 22 29 29 29 0a 20 20 20 20 28 COOKIE"))). (
36f0: 69 66 20 68 74 74 70 2d 73 65 73 73 69 6f 6e 20 if http-session
3700: 0a 20 20 20 20 20 20 20 20 28 73 65 73 73 69 6f . (sessio
3710: 6e 3a 65 78 74 72 61 63 74 2d 6b 65 79 2d 66 72 n:extract-key-fr
3720: 6f 6d 2d 70 61 72 61 6d 20 73 65 6c 66 20 28 6c om-param self (l
3730: 69 73 74 20 68 74 74 70 2d 73 65 73 73 69 6f 6e ist http-session
3740: 29 20 22 73 65 73 73 69 6f 6e 5f 6b 65 79 22 29 ) "session_key")
3750: 0a 20 20 20 20 20 20 20 20 23 66 29 29 29 0a 0a . #f)))..
3760: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
3770: 3a 67 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 :get-session-id
3780: 73 65 6c 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 self session-key
3790: 29 0a 20 20 28 6c 65 74 20 28 28 71 75 65 72 79 ). (let ((query
37a0: 20 22 53 45 4c 45 43 54 20 69 64 20 46 52 4f 4d "SELECT id FROM
37b0: 20 73 65 73 73 69 6f 6e 73 20 57 48 45 52 45 20 sessions WHERE
37c0: 73 65 73 73 69 6f 6e 5f 6b 65 79 3d 3f 3b 22 29 session_key=?;")
37d0: 0a 20 20 20 20 20 20 20 20 28 72 65 73 75 6c 74 . (result
37e0: 20 23 66 29 29 0a 20 20 20 20 3b 3b 20 20 20 20 #f)). ;;
37f0: 20 28 70 67 3a 71 75 65 72 79 2d 66 6f 72 2d 65 (pg:query-for-e
3800: 61 63 68 20 28 6c 61 6d 62 64 61 20 28 74 75 70 ach (lambda (tup
3810: 6c 65 29 0a 20 20 20 20 3b 3b 20 20 20 20 20 20 le). ;;
3820: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3830: 20 20 20 20 28 73 65 74 21 20 72 65 73 75 6c 74 (set! result
3840: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 (vector-ref tup
3850: 6c 65 20 30 29 29 29 20 3b 3b 20 28 76 65 63 74 le 0))) ;; (vect
3860: 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 30 29 29 or-ref tuple 0))
3870: 29 0a 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 ). ;;
3880: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3890: 28 73 3a 73 71 6c 70 61 72 61 6d 20 71 75 65 72 (s:sqlparam quer
38a0: 79 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 0a 20 y session-key).
38b0: 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 ;;
38c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 65 (se
38d0: 73 73 69 6f 6e 3a 73 64 61 74 2d 67 65 74 2d 63 ssion:sdat-get-c
38e0: 6f 6e 6e 20 73 65 6c 66 29 29 0a 20 20 20 20 3b onn self)). ;
38f0: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
3900: 20 20 20 20 20 20 20 20 20 63 6f 6e 6e 29 0a 20 conn).
3910: 20 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 (dbi:for-each
3920: 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 75 -row (lambda (tu
3930: 70 6c 65 29 0a 09 09 09 28 73 65 74 21 20 72 65 ple)....(set! re
3940: 73 75 6c 74 20 28 76 65 63 74 6f 72 2d 72 65 66 sult (vector-ref
3950: 20 74 75 70 6c 65 20 30 29 29 29 20 3b 3b 20 28 tuple 0))) ;; (
3960: 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 vector-ref tuple
3970: 20 30 29 29 29 0a 09 09 20 20 20 20 20 20 28 73 0)))... (s
3980: 65 73 73 69 6f 6e 3a 73 64 61 74 2d 67 65 74 2d ession:sdat-get-
3990: 63 6f 6e 6e 20 73 65 6c 66 29 0a 09 09 20 20 20 conn self)...
39a0: 20 20 20 28 73 3a 73 71 6c 70 61 72 61 6d 20 71 (s:sqlparam q
39b0: 75 65 72 79 20 73 65 73 73 69 6f 6e 2d 6b 65 79 uery session-key
39c0: 29 29 0a 20 20 20 20 72 65 73 75 6c 74 29 29 0a )). result)).
39d0: 0a 3b 3b 20 64 65 6c 65 74 65 20 61 6c 6c 20 72 .;; delete all r
39e0: 65 63 6f 72 64 73 20 66 6f 72 20 61 20 73 65 73 ecords for a ses
39f0: 73 69 6f 6e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 sion.;;.(define
3a00: 28 73 65 73 73 69 6f 6e 3a 64 65 6c 65 74 65 2d (session:delete-
3a10: 73 65 73 73 69 6f 6e 20 73 65 6c 66 20 73 65 73 session self ses
3a20: 73 69 6f 6e 2d 6b 65 79 29 0a 20 20 28 6c 65 74 sion-key). (let
3a30: 20 28 28 73 65 73 73 69 6f 6e 2d 69 64 20 28 73 ((session-id (s
3a40: 65 73 73 69 6f 6e 3a 67 65 74 2d 73 65 73 73 69 ession:get-sessi
3a50: 6f 6e 2d 69 64 20 73 65 6c 66 20 73 65 73 73 69 on-id self sessi
3a60: 6f 6e 2d 6b 65 79 29 29 0a 20 20 20 20 20 20 20 on-key)).
3a70: 20 28 71 72 79 20 20 20 20 20 20 20 20 28 63 6f (qry (co
3a80: 6e 63 20 22 42 45 47 49 4e 3b 22 0a 09 09 09 20 nc "BEGIN;"....
3a90: 20 22 44 45 4c 45 54 45 20 46 52 4f 4d 20 73 65 "DELETE FROM se
3aa0: 73 73 69 6f 6e 5f 76 61 72 73 20 57 48 45 52 45 ssion_vars WHERE
3ab0: 20 73 65 73 73 69 6f 6e 5f 69 64 3d 3f 3b 22 0a session_id=?;".
3ac0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3ad0: 20 20 20 20 20 20 20 20 20 20 22 44 45 4c 45 54 "DELET
3ae0: 45 20 46 52 4f 4d 20 73 65 73 73 69 6f 6e 73 20 E FROM sessions
3af0: 57 48 45 52 45 20 69 64 3d 3f 3b 22 0a 09 09 09 WHERE id=?;"....
3b00: 20 20 22 43 4f 4d 4d 49 54 3b 22 29 29 0a 20 20 "COMMIT;")).
3b10: 20 20 20 20 20 20 28 63 6f 6e 6e 20 20 20 20 20 (conn
3b20: 20 20 20 20 20 20 20 20 20 28 73 65 73 73 69 6f (sessio
3b30: 6e 3a 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 n:sdat-get-conn
3b40: 73 65 6c 66 29 29 29 0a 20 20 20 20 28 69 66 20 self))). (if
3b50: 73 65 73 73 69 6f 6e 2d 69 64 0a 20 20 20 20 20 session-id.
3b60: 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 (begin.
3b70: 20 20 20 20 28 64 62 69 3a 65 78 65 63 20 63 6f (dbi:exec co
3b80: 6e 6e 20 71 72 79 20 73 65 73 73 69 6f 6e 2d 69 nn qry session-i
3b90: 64 20 73 65 73 73 69 6f 6e 2d 69 64 29 0a 09 20 d session-id)..
3ba0: 20 28 69 6e 69 74 69 61 6c 69 7a 65 20 73 65 6c (initialize sel
3bb0: 66 20 27 28 29 29 0a 09 20 20 28 73 65 73 73 69 f '()).. (sessi
3bc0: 6f 6e 3a 73 65 74 75 70 20 73 65 6c 66 29 29 29 on:setup self)))
3bd0: 0a 20 20 20 20 28 6e 6f 74 20 28 73 65 73 73 69 . (not (sessi
3be0: 6f 6e 3a 67 65 74 2d 73 65 73 73 69 6f 6e 2d 69 on:get-session-i
3bf0: 64 20 73 65 6c 66 20 73 65 73 73 69 6f 6e 2d 6b d self session-k
3c00: 65 79 29 29 29 29 0a 0a 3b 3b 20 28 64 65 66 69 ey))))..;; (defi
3c10: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 64 65 6c 65 ne (session:dele
3c20: 74 65 2d 73 65 73 73 69 6f 6e 20 73 65 6c 66 20 te-session self
3c30: 73 65 73 73 69 6f 6e 2d 6b 65 79 29 0a 3b 3b 20 session-key).;;
3c40: 20 20 28 6c 65 74 20 28 28 73 65 73 73 69 6f 6e (let ((session
3c50: 2d 69 64 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 -id (session:get
3c60: 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 -session-id self
3c70: 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 0a 3b session-key)).;
3c80: 3b 20 20 20 20 20 20 20 20 20 28 71 75 65 72 69 ; (queri
3c90: 65 73 20 20 20 20 28 6c 69 73 74 20 22 42 45 47 es (list "BEG
3ca0: 49 4e 3b 22 0a 3b 3b 20 09 09 09 20 20 22 44 45 IN;".;; ... "DE
3cb0: 4c 45 54 45 20 46 52 4f 4d 20 73 65 73 73 69 6f LETE FROM sessio
3cc0: 6e 5f 76 61 72 73 20 57 48 45 52 45 20 73 65 73 n_vars WHERE ses
3cd0: 73 69 6f 6e 5f 69 64 3d 3f 3b 22 0a 3b 3b 20 20 sion_id=?;".;;
3ce0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3cf0: 20 20 20 20 20 20 20 20 20 22 44 45 4c 45 54 45 "DELETE
3d00: 20 46 52 4f 4d 20 73 65 73 73 69 6f 6e 73 20 57 FROM sessions W
3d10: 48 45 52 45 20 69 64 3d 3f 3b 22 0a 3b 3b 20 09 HERE id=?;".;; .
3d20: 09 09 20 20 22 43 4f 4d 4d 49 54 3b 22 29 29 0a .. "COMMIT;")).
3d30: 3b 3b 20 20 20 20 20 20 20 20 20 28 63 6f 6e 6e ;; (conn
3d40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
3d50: 65 73 73 69 6f 6e 3a 73 64 61 74 2d 67 65 74 2d ession:sdat-get-
3d60: 63 6f 6e 6e 20 73 65 6c 66 29 29 29 0a 3b 3b 20 conn self))).;;
3d70: 20 20 20 20 28 69 66 20 73 65 73 73 69 6f 6e 2d (if session-
3d80: 69 64 0a 3b 3b 20 20 20 20 20 20 20 20 20 28 62 id.;; (b
3d90: 65 67 69 6e 0a 3b 3b 20 20 20 20 20 20 20 20 20 egin.;;
3da0: 20 20 28 66 6f 72 2d 65 61 63 68 0a 3b 3b 20 20 (for-each.;;
3db0: 20 20 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 (lambd
3dc0: 61 20 28 71 75 65 72 79 29 0a 3b 3b 20 20 20 20 a (query).;;
3dd0: 20 20 20 20 20 20 20 20 20 20 28 64 62 69 3a 65 (dbi:e
3de0: 78 65 63 20 63 6f 6e 6e 20 71 75 65 72 79 20 73 xec conn query s
3df0: 65 73 73 69 6f 6e 2d 69 64 29 29 0a 3b 3b 20 09 ession-id)).;; .
3e00: 20 20 20 71 75 65 72 69 65 73 29 0a 3b 3b 20 09 queries).;; .
3e10: 20 20 28 69 6e 69 74 69 61 6c 69 7a 65 20 73 65 (initialize se
3e20: 6c 66 20 27 28 29 29 0a 3b 3b 20 09 20 20 28 73 lf '()).;; . (s
3e30: 65 73 73 69 6f 6e 3a 73 65 74 75 70 20 73 65 6c ession:setup sel
3e40: 66 29 29 29 0a 3b 3b 20 20 20 20 20 28 6e 6f 74 f))).;; (not
3e50: 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 73 65 (session:get-se
3e60: 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 20 73 65 ssion-id self se
3e70: 73 73 69 6f 6e 2d 6b 65 79 29 29 29 29 0a 0a 28 ssion-key))))..(
3e80: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
3e90: 65 78 74 72 61 63 74 2d 6b 65 79 20 73 65 6c 66 extract-key self
3ea0: 20 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 28 70 key). (let ((p
3eb0: 61 72 61 6d 73 20 28 73 65 73 73 69 6f 6e 3a 73 arams (session:s
3ec0: 64 61 74 2d 67 65 74 2d 70 61 72 61 6d 73 20 73 dat-get-params s
3ed0: 65 6c 66 29 29 29 0a 20 20 20 20 28 73 65 73 73 elf))). (sess
3ee0: 69 6f 6e 3a 65 78 74 72 61 63 74 2d 6b 65 79 2d ion:extract-key-
3ef0: 66 72 6f 6d 2d 70 61 72 61 6d 20 73 65 6c 66 20 from-param self
3f00: 70 61 72 61 6d 73 20 6b 65 79 29 29 29 0a 0a 28 params key)))..(
3f10: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
3f20: 65 78 74 72 61 63 74 2d 6b 65 79 2d 66 72 6f 6d extract-key-from
3f30: 2d 70 61 72 61 6d 20 73 65 6c 66 20 70 61 72 61 -param self para
3f40: 6d 73 20 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 ms key). (let (
3f50: 28 72 31 20 20 20 20 20 28 72 65 67 65 78 70 20 (r1 (regexp
3f60: 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 22 (string-append "
3f70: 5e 22 20 6b 65 79 20 22 3d 28 5b 5e 3d 5d 2b 29 ^" key "=([^=]+)
3f80: 24 22 29 29 29 29 0a 20 20 20 20 28 69 66 20 28 $")))). (if (
3f90: 3c 20 28 6c 65 6e 67 74 68 20 70 61 72 61 6d 73 < (length params
3fa0: 29 20 31 29 20 23 66 0a 09 28 6c 65 74 20 6c 6f ) 1) #f..(let lo
3fb0: 6f 70 20 28 28 68 65 61 64 20 20 20 28 63 61 72 op ((head (car
3fc0: 20 70 61 72 61 6d 73 29 29 0a 09 09 20 20 20 28 params))... (
3fd0: 74 61 69 6c 20 20 20 28 63 64 72 20 70 61 72 61 tail (cdr para
3fe0: 6d 73 29 29 29 0a 09 20 20 28 6c 65 74 20 28 28 ms))).. (let ((
3ff0: 6d 61 74 63 68 20 28 73 74 72 69 6e 67 2d 6d 61 match (string-ma
4000: 74 63 68 20 72 31 20 68 65 61 64 29 29 29 0a 09 tch r1 head)))..
4010: 20 20 20 20 28 63 6f 6e 64 0a 09 20 20 20 20 20 (cond..
4020: 28 6d 61 74 63 68 0a 09 20 20 20 20 20 20 28 6c (match.. (l
4030: 65 74 20 28 28 73 65 73 73 69 6f 6e 2d 6b 65 79 et ((session-key
4040: 20 28 6c 69 73 74 2d 72 65 66 20 6d 61 74 63 68 (list-ref match
4050: 20 31 29 29 29 0a 09 09 28 73 65 73 73 69 6f 6e 1)))...(session
4060: 3a 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f :sdat-set-sessio
4070: 6e 2d 6b 65 79 21 20 73 65 6c 66 20 28 6c 69 73 n-key! self (lis
4080: 74 2d 72 65 66 20 6d 61 74 63 68 20 31 29 29 0a t-ref match 1)).
4090: 09 09 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 0a ..session-key)).
40a0: 09 20 20 20 20 20 28 28 6e 75 6c 6c 3f 20 74 61 . ((null? ta
40b0: 69 6c 29 0a 09 20 20 20 20 20 20 23 66 29 0a 09 il).. #f)..
40c0: 20 20 20 20 20 28 65 6c 73 65 0a 09 20 20 20 20 (else..
40d0: 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 69 (loop (car tai
40e0: 6c 29 0a 09 09 20 20 20 20 28 63 64 72 20 74 61 l)... (cdr ta
40f0: 69 6c 29 29 29 29 29 29 29 29 29 0a 0a 28 64 65 il)))))))))..(de
4100: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 65 fine (session:se
4110: 74 2d 70 61 67 65 21 20 73 65 6c 66 20 70 61 67 t-page! self pag
4120: 65 5f 6e 61 6d 65 29 0a 20 20 28 73 65 73 73 69 e_name). (sessi
4130: 6f 6e 3a 73 64 61 74 2d 73 65 74 2d 70 61 67 65 on:sdat-set-page
4140: 21 20 73 65 6c 66 20 70 61 67 65 5f 6e 61 6d 65 ! self page_name
4150: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 ))..(define (ses
4160: 73 69 6f 6e 3a 63 6c 6f 73 65 20 73 65 6c 66 29 sion:close self)
4170: 0a 20 20 28 64 62 69 3a 63 6c 6f 73 65 20 28 73 . (dbi:close (s
4180: 65 73 73 69 6f 6e 3a 73 64 61 74 2d 67 65 74 2d ession:sdat-get-
4190: 63 6f 6e 6e 20 73 65 6c 66 29 29 29 0a 3b 3b 20 conn self))).;;
41a0: 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f (close-output-po
41b0: 72 74 20 28 73 65 73 73 69 6f 6e 3a 73 64 61 74 rt (session:sdat
41c0: 2d 67 65 74 2d 6c 6f 67 70 74 20 73 65 6c 66 29 -get-logpt self)
41d0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 )..(define (sess
41e0: 69 6f 6e 3a 65 72 72 2d 6d 73 67 20 73 65 6c 66 ion:err-msg self
41f0: 20 6d 73 67 29 0a 20 20 28 68 61 73 68 2d 74 61 msg). (hash-ta
4200: 62 6c 65 2d 73 65 74 21 20 28 73 65 73 73 69 6f ble-set! (sessio
4210: 6e 3a 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 n:sdat-get-sessi
4220: 6f 6e 76 61 72 73 20 73 65 6c 66 29 20 22 45 52 onvars self) "ER
4230: 52 4f 52 5f 4d 53 47 22 0a 09 09 20 20 20 28 73 ROR_MSG"... (s
4240: 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
4250: 65 20 28 6d 61 70 20 73 3a 61 6e 79 2d 3e 73 74 e (map s:any->st
4260: 72 69 6e 67 20 6d 73 67 29 20 22 20 22 29 29 29 ring msg) " ")))
4270: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ..(define (sessi
4280: 6f 6e 3a 70 72 65 76 2d 65 72 72 20 73 65 6c 66 on:prev-err self
4290: 29 0a 20 20 28 6c 65 74 20 28 28 70 72 65 76 2d ). (let ((prev-
42a0: 65 72 72 20 28 68 61 73 68 2d 74 61 62 6c 65 2d err (hash-table-
42b0: 72 65 66 2f 64 65 66 61 75 6c 74 20 28 73 65 73 ref/default (ses
42c0: 73 69 6f 6e 3a 73 64 61 74 2d 67 65 74 2d 73 65 sion:sdat-get-se
42d0: 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 ssionvars-before
42e0: 20 73 65 6c 66 29 20 22 45 52 52 4f 52 5f 4d 53 self) "ERROR_MS
42f0: 47 22 20 23 66 29 29 0a 09 28 63 75 72 72 2d 65 G" #f))..(curr-e
4300: 72 72 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 rr (hash-table-r
4310: 65 66 2f 64 65 66 61 75 6c 74 20 28 73 65 73 73 ef/default (sess
4320: 69 6f 6e 3a 73 64 61 74 2d 67 65 74 2d 73 65 73 ion:sdat-get-ses
4330: 73 69 6f 6e 76 61 72 73 20 73 65 6c 66 29 20 22 sionvars self) "
4340: 45 52 52 4f 52 5f 4d 53 47 22 20 23 66 29 29 29 ERROR_MSG" #f)))
4350: 0a 20 20 20 20 28 69 66 20 70 72 65 76 2d 65 72 . (if prev-er
4360: 72 20 70 72 65 76 2d 65 72 72 0a 09 28 69 66 20 r prev-err..(if
4370: 63 75 72 72 2d 65 72 72 20 63 75 72 72 2d 65 72 curr-err curr-er
4380: 72 20 23 66 29 29 29 29 0a 0a 3b 3b 20 73 65 73 r #f))))..;; ses
4390: 73 69 6f 6e 20 76 61 72 73 0a 3b 3b 20 31 2e 20 sion vars.;; 1.
43a0: 6b 65 79 73 20 61 72 65 20 61 6c 77 61 79 73 20 keys are always
43b0: 61 20 73 74 72 69 6e 67 20 4e 4f 54 20 61 20 73 a string NOT a s
43c0: 79 6d 62 6f 6c 0a 3b 3b 20 32 2e 20 76 61 6c 75 ymbol.;; 2. valu
43d0: 65 73 20 61 72 65 20 61 6c 77 61 79 73 20 61 20 es are always a
43e0: 73 74 72 69 6e 67 20 63 6f 6e 76 65 72 73 69 6f string conversio
43f0: 6e 20 69 73 20 74 68 65 20 72 65 73 70 6f 6e 73 n is the respons
4400: 69 62 69 6c 69 74 79 20 6f 66 20 74 68 65 20 0a ibility of the .
4410: 3b 3b 20 20 20 20 63 6f 6e 73 75 6d 69 6e 67 20 ;; consuming
4420: 66 75 6e 63 74 69 6f 6e 20 28 61 74 20 6c 65 61 function (at lea
4430: 73 74 20 66 6f 72 20 6e 6f 77 2c 20 49 27 64 20 st for now, I'd
4440: 6c 69 6b 65 20 74 6f 20 63 68 61 6e 67 65 20 74 like to change t
4450: 68 69 73 29 0a 0a 3b 3b 20 73 65 74 20 61 20 73 his)..;; set a s
4460: 65 73 73 69 6f 6e 20 76 61 72 20 66 6f 72 20 74 ession var for t
4470: 68 65 20 63 75 72 72 65 6e 74 20 70 61 67 65 0a he current page.
4480: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 ;;.(define (sess
4490: 69 6f 6e 3a 73 65 74 21 20 73 65 6c 66 20 6b 65 ion:set! self ke
44a0: 79 20 76 61 6c 75 65 29 0a 20 20 28 68 61 73 68 y value). (hash
44b0: 2d 74 61 62 6c 65 2d 73 65 74 21 20 28 73 65 73 -table-set! (ses
44c0: 73 69 6f 6e 3a 73 64 61 74 2d 67 65 74 2d 70 61 sion:sdat-get-pa
44d0: 67 65 76 61 72 73 20 73 65 6c 66 29 20 28 73 3a gevars self) (s:
44e0: 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6b 65 79 29 any->string key)
44f0: 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 (s:any->string
4500: 76 61 6c 75 65 29 29 29 0a 0a 3b 3b 20 64 65 6c value)))..;; del
4510: 20 61 20 76 61 72 20 66 6f 72 20 74 68 65 20 63 a var for the c
4520: 75 72 72 65 6e 74 20 70 61 67 65 0a 3b 3b 0a 28 urrent page.;;.(
4530: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
4540: 64 65 6c 21 20 73 65 6c 66 20 6b 65 79 29 0a 20 del! self key).
4550: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 64 65 6c (hash-table-del
4560: 65 74 65 21 20 28 73 65 73 73 69 6f 6e 3a 73 64 ete! (session:sd
4570: 61 74 2d 67 65 74 2d 70 61 67 65 76 61 72 73 20 at-get-pagevars
4580: 73 65 6c 66 29 20 28 73 3a 61 6e 79 2d 3e 73 74 self) (s:any->st
4590: 72 69 6e 67 20 6b 65 79 29 29 29 0a 0a 3b 3b 20 ring key)))..;;
45a0: 67 65 74 20 74 68 65 20 61 70 70 72 6f 70 72 69 get the appropri
45b0: 61 74 65 20 68 61 73 68 20 67 69 76 65 6e 20 61 ate hash given a
45c0: 20 70 61 67 65 20 22 2a 73 65 73 73 69 6f 6e 76 page "*sessionv
45d0: 61 72 73 2a 2c 20 2a 67 6c 6f 62 61 6c 76 61 72 ars*, *globalvar
45e0: 73 2a 20 6f 72 20 70 61 67 65 0a 3b 3b 0a 28 64 s* or page.;;.(d
45f0: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 efine (session:g
4600: 65 74 2d 70 61 67 65 2d 68 61 73 68 20 73 65 6c et-page-hash sel
4610: 66 20 70 61 67 65 29 0a 20 20 28 69 66 20 28 73 f page). (if (s
4620: 74 72 69 6e 67 3d 3f 20 70 61 67 65 20 22 2a 73 tring=? page "*s
4630: 65 73 73 69 6f 6e 76 61 72 73 2a 22 29 0a 20 20 essionvars*").
4640: 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 73 64 61 (session:sda
4650: 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 t-get-sessionvar
4660: 73 20 73 65 6c 66 29 0a 20 20 20 20 20 20 28 69 s self). (i
4670: 66 20 28 73 74 72 69 6e 67 3d 3f 20 70 61 67 65 f (string=? page
4680: 20 22 2a 67 6c 6f 62 61 6c 76 61 72 73 2a 22 29 "*globalvars*")
4690: 0a 09 20 20 28 73 65 73 73 69 6f 6e 3a 73 64 61 .. (session:sda
46a0: 74 2d 67 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 t-get-globalvars
46b0: 20 73 65 6c 66 29 0a 09 20 20 28 73 65 73 73 69 self).. (sessi
46c0: 6f 6e 3a 73 64 61 74 2d 67 65 74 2d 70 61 67 65 on:sdat-get-page
46d0: 76 61 72 73 20 73 65 6c 66 29 29 29 29 0a 0a 3b vars self))))..;
46e0: 3b 20 73 65 74 20 61 20 73 65 73 73 69 6f 6e 20 ; set a session
46f0: 76 61 72 20 66 6f 72 20 61 20 67 69 76 65 6e 20 var for a given
4700: 70 61 67 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 page.;;.(define
4710: 28 73 65 73 73 69 6f 6e 3a 73 65 74 21 20 73 65 (session:set! se
4720: 6c 66 20 70 61 67 65 20 6b 65 79 20 76 61 6c 75 lf page key valu
4730: 65 29 0a 20 20 28 6c 65 74 20 28 28 68 74 20 28 e). (let ((ht (
4740: 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 67 65 session:get-page
4750: 2d 68 61 73 68 20 73 65 6c 66 20 70 61 67 65 29 -hash self page)
4760: 29 29 0a 20 20 20 20 28 68 61 73 68 2d 74 61 62 )). (hash-tab
4770: 6c 65 2d 73 65 74 21 20 68 74 20 28 73 3a 61 6e le-set! ht (s:an
4780: 79 2d 3e 73 74 72 69 6e 67 20 6b 65 79 29 20 28 y->string key) (
4790: 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 76 61 s:any->string va
47a0: 6c 75 65 29 29 29 29 0a 0a 3b 3b 20 67 65 74 20 lue))))..;; get
47b0: 73 65 73 73 69 6f 6e 20 76 61 72 73 20 66 6f 72 session vars for
47c0: 20 74 68 65 20 63 75 72 72 65 6e 74 20 70 61 67 the current pag
47d0: 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 e.;;.(define (se
47e0: 73 73 69 6f 6e 3a 67 65 74 20 73 65 6c 66 20 6b ssion:get self k
47f0: 65 79 29 0a 20 20 28 68 61 73 68 2d 74 61 62 6c ey). (hash-tabl
4800: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 28 73 e-ref/default (s
4810: 65 73 73 69 6f 6e 3a 73 64 61 74 2d 67 65 74 2d ession:sdat-get-
4820: 70 61 67 65 76 61 72 73 20 73 65 6c 66 29 20 6b pagevars self) k
4830: 65 79 20 23 66 29 29 0a 0a 3b 3b 20 67 65 74 20 ey #f))..;; get
4840: 73 65 73 73 69 6f 6e 20 76 61 72 73 20 66 6f 72 session vars for
4850: 20 61 20 73 70 65 63 69 66 69 65 64 20 70 61 67 a specified pag
4860: 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 e.;;.(define (se
4870: 73 73 69 6f 6e 3a 67 65 74 20 73 65 6c 66 20 70 ssion:get self p
4880: 61 67 65 20 6b 65 79 29 0a 20 20 28 6c 65 74 20 age key). (let
4890: 28 28 68 74 20 28 73 65 73 73 69 6f 6e 3a 67 65 ((ht (session:ge
48a0: 74 2d 70 61 67 65 2d 68 61 73 68 20 73 65 6c 66 t-page-hash self
48b0: 20 70 61 67 65 29 29 29 0a 20 20 20 20 28 68 61 page))). (ha
48c0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
48d0: 61 75 6c 74 20 68 74 20 6b 65 79 20 23 66 29 29 ault ht key #f))
48e0: 29 0a 0a 3b 3b 20 64 65 6c 65 74 65 20 61 20 73 )..;; delete a s
48f0: 65 73 73 69 6f 6e 20 76 61 72 20 66 6f 72 20 61 ession var for a
4900: 20 73 70 65 63 69 66 69 65 64 20 70 61 67 65 0a specified page.
4910: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 ;;.(define (sess
4920: 69 6f 6e 3a 64 65 6c 21 20 73 65 6c 66 20 70 61 ion:del! self pa
4930: 67 65 20 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 ge key). (let (
4940: 28 68 74 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 (ht (session:get
4950: 2d 70 61 67 65 2d 68 61 73 68 20 73 65 6c 66 20 -page-hash self
4960: 70 61 67 65 29 29 29 0a 20 20 20 20 28 68 61 73 page))). (has
4970: 68 2d 74 61 62 6c 65 2d 64 65 6c 65 74 65 21 20 h-table-delete!
4980: 68 74 20 6b 65 79 29 29 29 0a 0a 3b 3b 20 67 65 ht key)))..;; ge
4990: 74 20 41 4c 4c 20 6b 65 79 73 20 66 6f 72 20 74 t ALL keys for t
49a0: 68 69 73 20 70 61 67 65 20 61 6e 64 20 73 74 6f his page and sto
49b0: 72 65 20 69 6e 20 74 68 65 20 73 65 73 73 69 6f re in the sessio
49c0: 6e 20 70 61 67 65 76 61 72 73 20 68 61 73 68 0a n pagevars hash.
49d0: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 ;;.(define (sess
49e0: 69 6f 6e 3a 67 65 74 2d 76 61 72 73 20 73 65 6c ion:get-vars sel
49f0: 66 29 0a 20 20 28 6c 65 74 20 28 28 73 65 73 73 f). (let ((sess
4a00: 69 6f 6e 2d 69 64 20 20 28 73 65 73 73 69 6f 6e ion-id (session
4a10: 3a 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f :sdat-get-sessio
4a20: 6e 2d 69 64 20 73 65 6c 66 29 29 29 0a 20 20 20 n-id self))).
4a30: 20 28 69 66 20 28 6e 6f 74 20 73 65 73 73 69 6f (if (not sessio
4a40: 6e 2d 69 64 29 0a 09 28 65 72 72 3a 6c 6f 67 20 n-id)..(err:log
4a50: 22 45 52 52 4f 52 3a 20 4e 6f 20 73 65 73 73 69 "ERROR: No sessi
4a60: 6f 6e 20 69 64 20 69 6e 20 73 65 73 73 69 6f 6e on id in session
4a70: 20 6f 62 6a 65 63 74 21 20 73 65 73 73 69 6f 6e object! session
4a80: 3a 67 65 74 2d 76 61 72 73 22 29 0a 09 28 6c 65 :get-vars")..(le
4a90: 74 2a 20 28 28 72 65 73 75 6c 74 20 20 20 20 20 t* ((result
4aa0: 20 20 20 20 20 20 20 20 23 66 29 0a 09 20 20 20 #f)..
4ab0: 20 20 20 20 28 63 6f 6e 6e 20 20 20 20 20 20 20 (conn
4ac0: 20 20 20 20 20 20 20 20 28 73 65 73 73 69 6f 6e (session
4ad0: 3a 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 :sdat-get-conn s
4ae0: 65 6c 66 29 29 0a 09 20 20 20 20 20 20 20 28 70 elf)).. (p
4af0: 61 67 65 76 61 72 73 2d 62 65 66 6f 72 65 20 20 agevars-before
4b00: 20 20 28 73 65 73 73 69 6f 6e 3a 73 64 61 74 2d (session:sdat-
4b10: 67 65 74 2d 70 61 67 65 76 61 72 73 2d 62 65 66 get-pagevars-bef
4b20: 6f 72 65 20 73 65 6c 66 29 29 0a 09 20 20 20 20 ore self))..
4b30: 20 20 20 28 73 65 73 73 69 6f 6e 76 61 72 73 2d (sessionvars-
4b40: 62 65 66 6f 72 65 20 28 73 65 73 73 69 6f 6e 3a before (session:
4b50: 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e sdat-get-session
4b60: 76 61 72 73 2d 62 65 66 6f 72 65 20 73 65 6c 66 vars-before self
4b70: 29 29 0a 09 20 20 20 20 20 20 20 28 67 6c 6f 62 )).. (glob
4b80: 61 6c 76 61 72 73 2d 62 65 66 6f 72 65 20 20 28 alvars-before (
4b90: 73 65 73 73 69 6f 6e 3a 73 64 61 74 2d 67 65 74 session:sdat-get
4ba0: 2d 67 6c 6f 62 61 6c 76 61 72 73 2d 62 65 66 6f -globalvars-befo
4bb0: 72 65 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 re self))..
4bc0: 20 20 28 70 61 67 65 76 61 72 73 20 20 20 20 20 (pagevars
4bd0: 20 20 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 73 (session:s
4be0: 64 61 74 2d 67 65 74 2d 70 61 67 65 76 61 72 73 dat-get-pagevars
4bf0: 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 20 20 self))..
4c00: 28 73 65 73 73 69 6f 6e 76 61 72 73 20 20 20 20 (sessionvars
4c10: 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 73 64 61 (session:sda
4c20: 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 t-get-sessionvar
4c30: 73 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 20 s self))..
4c40: 20 28 67 6c 6f 62 61 6c 76 61 72 73 20 20 20 20 (globalvars
4c50: 20 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 73 64 (session:sd
4c60: 61 74 2d 67 65 74 2d 67 6c 6f 62 61 6c 76 61 72 at-get-globalvar
4c70: 73 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 20 s self))..
4c80: 20 28 70 61 67 65 2d 6e 61 6d 65 20 20 20 20 20 (page-name
4c90: 20 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 73 64 (session:sd
4ca0: 61 74 2d 67 65 74 2d 70 61 67 65 20 73 65 6c 66 at-get-page self
4cb0: 29 29 0a 09 20 20 20 20 20 20 20 28 73 65 73 73 )).. (sess
4cc0: 69 6f 6e 2d 6b 65 79 20 20 20 20 20 20 20 20 28 ion-key (
4cd0: 73 65 73 73 69 6f 6e 3a 73 64 61 74 2d 67 65 74 session:sdat-get
4ce0: 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c -session-key sel
4cf0: 66 29 29 0a 09 20 20 20 20 20 20 20 28 71 75 65 f)).. (que
4d00: 72 79 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ry
4d10: 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 0a 09 (string-append..
4d20: 09 09 09 20 20 20 20 22 53 45 4c 45 43 54 20 6b ... "SELECT k
4d30: 65 79 2c 76 61 6c 75 65 20 46 52 4f 4d 20 73 65 ey,value FROM se
4d40: 73 73 69 6f 6e 5f 76 61 72 73 20 49 4e 4e 45 52 ssion_vars INNER
4d50: 20 4a 4f 49 4e 20 73 65 73 73 69 6f 6e 73 20 4f JOIN sessions O
4d60: 4e 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 2e 73 N session_vars.s
4d70: 65 73 73 69 6f 6e 5f 69 64 3d 73 65 73 73 69 6f ession_id=sessio
4d80: 6e 73 2e 69 64 20 22 0a 09 09 09 09 20 20 20 20 ns.id ".....
4d90: 22 57 48 45 52 45 20 73 65 73 73 69 6f 6e 5f 6b "WHERE session_k
4da0: 65 79 3d 3f 20 41 4e 44 20 70 61 67 65 3d 3f 3b ey=? AND page=?;
4db0: 22 29 29 29 0a 09 20 20 3b 3b 20 66 69 72 73 74 "))).. ;; first
4dc0: 20 74 68 65 20 70 61 67 65 20 73 70 65 63 69 66 the page specif
4dd0: 69 63 20 76 61 72 73 0a 09 20 20 28 64 62 69 3a ic vars.. (dbi:
4de0: 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 for-each-row (la
4df0: 6d 62 64 61 20 28 74 75 70 6c 65 29 0a 09 09 09 mbda (tuple)....
4e00: 20 20 20 20 20 20 28 6c 65 74 20 28 28 6b 20 28 (let ((k (
4e10: 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 vector-ref tuple
4e20: 20 30 29 29 0a 09 09 09 09 20 20 20 20 28 76 20 0))..... (v
4e30: 28 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c (vector-ref tupl
4e40: 65 20 31 29 29 29 0a 09 09 09 09 28 68 61 73 68 e 1))).....(hash
4e50: 2d 74 61 62 6c 65 2d 73 65 74 21 20 70 61 67 65 -table-set! page
4e60: 76 61 72 73 2d 62 65 66 6f 72 65 20 6b 20 76 29 vars-before k v)
4e70: 0a 09 09 09 09 28 68 61 73 68 2d 74 61 62 6c 65 .....(hash-table
4e80: 2d 73 65 74 21 20 70 61 67 65 76 61 72 73 20 20 -set! pagevars
4e90: 20 20 20 20 20 20 6b 20 76 29 29 29 0a 09 09 09 k v)))....
4ea0: 20 20 20 20 63 6f 6e 6e 0a 09 09 09 20 20 20 20 conn....
4eb0: 28 73 3a 73 71 6c 70 61 72 61 6d 20 71 75 65 72 (s:sqlparam quer
4ec0: 79 20 73 65 73 73 69 6f 6e 2d 6b 65 79 20 70 61 y session-key pa
4ed0: 67 65 2d 6e 61 6d 65 29 29 0a 09 20 20 3b 3b 20 ge-name)).. ;;
4ee0: 74 68 65 6e 20 74 68 65 20 73 65 73 73 69 6f 6e then the session
4ef0: 20 73 70 65 63 69 66 69 63 20 76 61 72 73 0a 09 specific vars..
4f00: 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d (dbi:for-each-
4f10: 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 75 70 row (lambda (tup
4f20: 6c 65 29 0a 09 09 09 20 20 20 20 20 20 28 6c 65 le).... (le
4f30: 74 20 28 28 6b 20 28 76 65 63 74 6f 72 2d 72 65 t ((k (vector-re
4f40: 66 20 74 75 70 6c 65 20 30 29 29 0a 09 09 09 09 f tuple 0)).....
4f50: 20 20 20 20 28 76 20 28 76 65 63 74 6f 72 2d 72 (v (vector-r
4f60: 65 66 20 74 75 70 6c 65 20 31 29 29 29 0a 09 09 ef tuple 1)))...
4f70: 09 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 ..(hash-table-se
4f80: 74 21 20 73 65 73 73 69 6f 6e 76 61 72 73 2d 62 t! sessionvars-b
4f90: 65 66 6f 72 65 20 6b 20 76 29 0a 09 09 09 09 28 efore k v).....(
4fa0: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
4fb0: 73 65 73 73 69 6f 6e 76 61 72 73 20 20 20 20 20 sessionvars
4fc0: 20 20 20 6b 20 76 29 29 29 0a 09 09 09 20 20 20 k v)))....
4fd0: 20 63 6f 6e 6e 0a 09 09 09 20 20 20 20 28 73 3a conn.... (s:
4fe0: 73 71 6c 70 61 72 61 6d 20 71 75 65 72 79 20 73 sqlparam query s
4ff0: 65 73 73 69 6f 6e 2d 6b 65 79 20 22 2a 73 65 73 ession-key "*ses
5000: 73 69 6f 6e 76 61 72 73 2a 22 29 29 0a 09 20 20 sionvars*"))..
5010: 3b 3b 20 61 6e 64 20 66 69 6e 61 6c 6c 79 20 74 ;; and finally t
5020: 68 65 20 67 6c 6f 62 61 6c 20 76 61 72 73 0a 09 he global vars..
5030: 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d (dbi:for-each-
5040: 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 75 70 row (lambda (tup
5050: 6c 65 29 0a 09 09 09 20 20 20 20 20 20 28 6c 65 le).... (le
5060: 74 20 28 28 6b 20 28 76 65 63 74 6f 72 2d 72 65 t ((k (vector-re
5070: 66 20 74 75 70 6c 65 20 30 29 29 0a 09 09 09 09 f tuple 0)).....
5080: 20 20 20 20 28 76 20 28 76 65 63 74 6f 72 2d 72 (v (vector-r
5090: 65 66 20 74 75 70 6c 65 20 31 29 29 29 0a 09 09 ef tuple 1)))...
50a0: 09 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 ..(hash-table-se
50b0: 74 21 20 67 6c 6f 62 61 6c 76 61 72 73 2d 62 65 t! globalvars-be
50c0: 66 6f 72 65 20 6b 20 76 29 0a 09 09 09 09 28 68 fore k v).....(h
50d0: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 67 ash-table-set! g
50e0: 6c 6f 62 61 6c 76 61 72 73 20 20 20 20 20 20 20 lobalvars
50f0: 20 6b 20 76 29 29 29 0a 09 09 09 20 20 20 20 63 k v))).... c
5100: 6f 6e 6e 0a 09 09 09 20 20 20 20 28 73 3a 73 71 onn.... (s:sq
5110: 6c 70 61 72 61 6d 20 71 75 65 72 79 20 73 65 73 lparam query ses
5120: 73 69 6f 6e 2d 6b 65 79 20 22 2a 67 6c 6f 62 61 sion-key "*globa
5130: 6c 76 61 72 73 22 29 29 0a 09 20 20 29 29 29 29 lvars")).. ))))
5140: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ..(define (sessi
5150: 6f 6e 3a 73 61 76 65 2d 76 61 72 73 20 73 65 6c on:save-vars sel
5160: 66 29 0a 20 20 28 6c 65 74 20 28 28 73 65 73 73 f). (let ((sess
5170: 69 6f 6e 2d 69 64 20 20 28 73 65 73 73 69 6f 6e ion-id (session
5180: 3a 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f :sdat-get-sessio
5190: 6e 2d 69 64 20 73 65 6c 66 29 29 29 0a 20 20 20 n-id self))).
51a0: 20 28 69 66 20 28 6e 6f 74 20 73 65 73 73 69 6f (if (not sessio
51b0: 6e 2d 69 64 29 0a 09 28 65 72 72 3a 6c 6f 67 20 n-id)..(err:log
51c0: 22 45 52 52 4f 52 3a 20 4e 6f 20 73 65 73 73 69 "ERROR: No sessi
51d0: 6f 6e 20 69 64 20 69 6e 20 73 65 73 73 69 6f 6e on id in session
51e0: 20 6f 62 6a 65 63 74 21 20 73 65 73 73 69 6f 6e object! session
51f0: 3a 67 65 74 2d 76 61 72 73 22 29 0a 09 28 6c 65 :get-vars")..(le
5200: 74 2a 20 28 28 73 74 61 74 75 73 20 20 20 20 20 t* ((status
5210: 20 23 66 29 0a 09 20 20 20 20 20 20 20 28 63 6f #f).. (co
5220: 6e 6e 20 20 20 20 20 20 20 20 28 73 65 73 73 69 nn (sessi
5230: 6f 6e 3a 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e on:sdat-get-conn
5240: 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 20 20 self))..
5250: 28 70 61 67 65 2d 6e 61 6d 65 20 20 20 28 73 65 (page-name (se
5260: 73 73 69 6f 6e 3a 73 64 61 74 2d 67 65 74 2d 70 ssion:sdat-get-p
5270: 61 67 65 20 73 65 6c 66 29 29 0a 09 20 20 20 20 age self))..
5280: 20 20 20 28 64 65 6c 2d 71 75 65 72 79 20 20 20 (del-query
5290: 22 44 45 4c 45 54 45 20 46 52 4f 4d 20 73 65 73 "DELETE FROM ses
52a0: 73 69 6f 6e 5f 76 61 72 73 20 57 48 45 52 45 20 sion_vars WHERE
52b0: 73 65 73 73 69 6f 6e 5f 69 64 3d 3f 20 41 4e 44 session_id=? AND
52c0: 20 70 61 67 65 3d 3f 20 41 4e 44 20 6b 65 79 3d page=? AND key=
52d0: 3f 3b 22 29 0a 09 20 20 20 20 20 20 20 28 69 6e ?;").. (in
52e0: 73 2d 71 75 65 72 79 20 20 20 22 49 4e 53 45 52 s-query "INSER
52f0: 54 20 49 4e 54 4f 20 73 65 73 73 69 6f 6e 5f 76 T INTO session_v
5300: 61 72 73 20 28 73 65 73 73 69 6f 6e 5f 69 64 2c ars (session_id,
5310: 70 61 67 65 2c 6b 65 79 2c 76 61 6c 75 65 29 20 page,key,value)
5320: 56 41 4c 55 45 53 28 3f 2c 3f 2c 3f 2c 3f 29 3b VALUES(?,?,?,?);
5330: 22 29 0a 09 20 20 20 20 20 20 20 28 75 70 64 2d ").. (upd-
5340: 71 75 65 72 79 20 20 20 22 55 50 44 41 54 45 20 query "UPDATE
5350: 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 73 65 74 session_vars set
5360: 20 76 61 6c 75 65 3d 3f 20 57 48 45 52 45 20 6b value=? WHERE k
5370: 65 79 3d 3f 20 41 4e 44 20 73 65 73 73 69 6f 6e ey=? AND session
5380: 5f 69 64 3d 3f 20 41 4e 44 20 70 61 67 65 3d 3f _id=? AND page=?
5390: 3b 22 29 0a 09 20 20 20 20 20 20 20 28 63 68 61 ;").. (cha
53a0: 6e 67 65 64 2d 63 6f 75 6e 74 20 30 29 29 0a 09 nged-count 0))..
53b0: 20 20 3b 3b 20 73 61 76 65 20 74 68 65 20 64 65 ;; save the de
53c0: 6c 74 61 20 6f 6e 6c 79 0a 09 20 20 28 66 6f 72 lta only.. (for
53d0: 2d 65 61 63 68 0a 09 20 20 20 28 6c 61 6d 62 64 -each.. (lambd
53e0: 61 20 28 70 61 67 65 29 20 3b 3b 20 70 61 67 65 a (page) ;; page
53f0: 20 69 73 3a 20 22 2a 67 6c 6f 62 61 6c 76 61 72 is: "*globalvar
5400: 73 2a 22 20 22 2a 73 65 73 73 69 6f 6e 76 61 72 s*" "*sessionvar
5410: 73 2a 22 20 6f 72 20 6f 74 68 65 72 73 74 72 69 s*" or otherstri
5420: 6e 67 0a 09 20 20 20 20 20 28 6c 65 74 2a 20 28 ng.. (let* (
5430: 28 6d 61 73 74 65 72 2d 73 6c 6f 74 2d 6e 61 6d (master-slot-nam
5440: 65 20 28 63 6f 6e 64 0a 09 09 09 09 20 20 20 20 e (cond.....
5450: 20 20 20 28 28 73 74 72 69 6e 67 3d 3f 20 70 61 ((string=? pa
5460: 67 65 20 22 2a 73 65 73 73 69 6f 6e 76 61 72 73 ge "*sessionvars
5470: 2a 22 29 20 27 73 65 73 73 69 6f 6e 76 61 72 73 *") 'sessionvars
5480: 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 28 73 )..... ((s
5490: 74 72 69 6e 67 3d 3f 20 70 61 67 65 20 22 2a 67 tring=? page "*g
54a0: 6c 6f 62 61 6c 76 61 72 73 2a 22 29 20 20 27 67 lobalvars*") 'g
54b0: 6c 6f 62 61 6c 76 61 72 73 29 0a 09 09 09 09 20 lobalvars).....
54c0: 20 20 20 20 20 20 28 65 6c 73 65 20 27 70 61 67 (else 'pag
54d0: 65 76 61 72 73 29 29 29 0a 09 09 20 20 20 20 28 evars)))... (
54e0: 62 65 66 6f 72 65 2d 73 6c 6f 74 2d 6e 61 6d 65 before-slot-name
54f0: 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c (string->symbol
5500: 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 (string-append
5510: 28 73 79 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 (symbol->string
5520: 6d 61 73 74 65 72 2d 73 6c 6f 74 2d 6e 61 6d 65 master-slot-name
5530: 29 0a 09 09 09 09 09 09 09 09 20 20 20 20 20 22 )......... "
5540: 2d 62 65 66 6f 72 65 22 29 29 29 0a 09 09 20 20 -before")))...
5550: 20 20 28 6d 61 73 74 65 72 2d 68 74 20 20 20 28 (master-ht (
5560: 73 65 73 73 69 6f 6e 3a 73 64 61 74 2d 67 65 74 session:sdat-get
5570: 2d 61 73 74 65 72 2d 73 6c 6f 74 2d 6e 61 6d 65 -aster-slot-name
5580: 20 73 65 6c 66 29 29 0a 09 09 20 20 20 20 28 62 self))... (b
5590: 65 66 6f 72 65 2d 68 74 20 20 20 28 73 65 73 73 efore-ht (sess
55a0: 69 6f 6e 3a 73 64 61 74 2d 67 65 74 2d 65 66 6f ion:sdat-get-efo
55b0: 72 65 2d 73 6c 6f 74 2d 6e 61 6d 65 20 73 65 6c re-slot-name sel
55c0: 66 29 29 0a 09 09 20 20 20 20 28 6d 61 73 74 65 f))... (maste
55d0: 72 2d 6b 65 79 73 20 28 68 61 73 68 2d 74 61 62 r-keys (hash-tab
55e0: 6c 65 2d 6b 65 79 73 20 6d 61 73 74 65 72 2d 68 le-keys master-h
55f0: 74 29 29 0a 09 09 20 20 20 20 28 62 65 66 6f 72 t))... (befor
5600: 65 2d 6b 65 79 73 20 28 68 61 73 68 2d 74 61 62 e-keys (hash-tab
5610: 6c 65 2d 6b 65 79 73 20 62 65 66 6f 72 65 2d 68 le-keys before-h
5620: 74 29 29 0a 09 09 20 20 20 20 28 61 6c 6c 2d 6b t))... (all-k
5630: 65 79 73 20 28 64 65 6c 65 74 65 2d 64 75 70 6c eys (delete-dupl
5640: 69 63 61 74 65 73 20 28 61 70 70 65 6e 64 20 6d icates (append m
5650: 61 73 74 65 72 2d 6b 65 79 73 20 62 65 66 6f 72 aster-keys befor
5660: 65 2d 6b 65 79 73 29 29 29 29 0a 09 20 20 20 20 e-keys))))..
5670: 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 09 09 (for-each ...
5680: 28 6c 61 6d 62 64 61 20 28 6b 65 79 29 0a 09 09 (lambda (key)...
5690: 20 20 28 6c 65 74 20 28 28 6d 61 73 74 65 72 2d (let ((master-
56a0: 76 61 6c 75 65 20 28 68 61 73 68 2d 74 61 62 6c value (hash-tabl
56b0: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 6d 61 e-ref/default ma
56c0: 73 74 65 72 2d 68 74 20 6b 65 79 20 23 66 29 29 ster-ht key #f))
56d0: 0a 09 09 09 28 62 65 66 6f 72 65 2d 76 61 6c 75 ....(before-valu
56e0: 65 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 e (hash-table-re
56f0: 66 2f 64 65 66 61 75 6c 74 20 62 65 66 6f 72 65 f/default before
5700: 2d 68 74 20 6b 65 79 20 23 66 29 29 29 0a 09 09 -ht key #f)))...
5710: 20 20 20 20 28 63 6f 6e 64 0a 09 09 20 20 20 20 (cond...
5720: 20 3b 3b 20 62 65 66 6f 72 65 20 61 6e 64 20 61 ;; before and a
5730: 66 74 65 72 20 65 78 69 73 74 20 61 6e 64 20 76 fter exist and v
5740: 61 6c 75 65 20 75 6e 63 68 61 6e 67 65 64 20 2d alue unchanged -
5750: 20 64 6f 20 6e 6f 74 68 69 6e 67 0a 09 09 20 20 do nothing...
5760: 20 20 20 28 28 61 6e 64 20 6d 61 73 74 65 72 2d ((and master-
5770: 76 61 6c 75 65 20 62 65 66 6f 72 65 2d 76 61 6c value before-val
5780: 75 65 20 28 65 71 75 61 6c 3f 20 6d 61 73 74 65 ue (equal? maste
5790: 72 2d 76 61 6c 75 65 20 62 65 66 6f 72 65 2d 76 r-value before-v
57a0: 61 6c 75 65 29 29 29 0a 09 09 20 20 20 20 20 3b alue)))... ;
57b0: 3b 20 62 65 66 6f 72 65 20 61 6e 64 20 61 66 74 ; before and aft
57c0: 65 72 20 65 78 69 73 74 20 62 75 74 20 61 72 65 er exist but are
57d0: 20 63 68 61 6e 67 65 64 0a 09 09 20 20 20 20 20 changed...
57e0: 28 28 61 6e 64 20 6d 61 73 74 65 72 2d 76 61 6c ((and master-val
57f0: 75 65 20 62 65 66 6f 72 65 2d 76 61 6c 75 65 29 ue before-value)
5800: 0a 09 09 20 20 20 20 20 20 28 64 62 69 3a 66 6f ... (dbi:fo
5810: 72 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 6d 62 r-each-row (lamb
5820: 64 61 20 28 74 75 70 6c 65 29 0a 09 09 09 09 09 da (tuple)......
5830: 20 20 28 73 65 74 21 20 63 68 61 6e 67 65 64 2d (set! changed-
5840: 63 6f 75 6e 74 20 28 2b 20 63 68 61 6e 67 65 64 count (+ changed
5850: 2d 63 6f 75 6e 74 20 31 29 29 29 0a 09 09 09 09 -count 1))).....
5860: 09 63 6f 6e 6e 0a 09 09 09 09 09 28 73 3a 73 71 .conn......(s:sq
5870: 6c 70 61 72 61 6d 20 75 70 64 2d 71 75 65 72 79 lparam upd-query
5880: 20 6d 61 73 74 65 72 2d 76 61 6c 75 65 20 6b 65 master-value ke
5890: 79 20 73 65 73 73 69 6f 6e 2d 69 64 20 70 61 67 y session-id pag
58a0: 65 29 29 29 0a 09 09 20 20 20 20 20 3b 3b 20 6d e)))... ;; m
58b0: 61 73 74 65 72 2d 76 61 6c 75 65 20 6e 6f 20 6c aster-value no l
58c0: 6f 6e 67 65 72 20 65 78 69 73 74 73 20 28 69 2e onger exists (i.
58d0: 65 2e 20 23 66 29 20 2d 20 72 65 6d 6f 76 65 20 e. #f) - remove
58e0: 69 74 65 6d 0a 09 09 20 20 20 20 20 28 28 6e 6f item... ((no
58f0: 74 20 6d 61 73 74 65 72 2d 76 61 6c 75 65 29 0a t master-value).
5900: 09 09 20 20 20 20 20 20 28 64 62 69 3a 66 6f 72 .. (dbi:for
5910: 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 6d 62 64 -each-row (lambd
5920: 61 20 28 74 75 70 6c 65 29 0a 09 09 09 09 09 20 a (tuple)......
5930: 20 28 73 65 74 21 20 63 68 61 6e 67 65 64 2d 63 (set! changed-c
5940: 6f 75 6e 74 20 28 2b 20 63 68 61 6e 67 65 64 2d ount (+ changed-
5950: 63 6f 75 6e 74 20 31 29 29 29 0a 09 09 09 09 09 count 1)))......
5960: 63 6f 6e 6e 0a 09 09 09 09 09 28 73 3a 73 71 6c conn......(s:sql
5970: 70 61 72 61 6d 20 64 65 6c 2d 71 75 65 72 79 20 param del-query
5980: 73 65 73 73 69 6f 6e 2d 69 64 20 70 61 67 65 20 session-id page
5990: 6b 65 79 29 29 29 0a 09 09 20 20 20 20 20 3b 3b key)))... ;;
59a0: 20 62 65 66 6f 72 65 2d 76 61 6c 75 65 20 64 6f before-value do
59b0: 65 73 6e 27 74 20 65 78 69 73 74 20 2d 20 69 6e esn't exist - in
59c0: 73 65 72 74 20 61 20 6e 65 77 20 76 61 6c 75 65 sert a new value
59d0: 0a 09 09 20 20 20 20 20 28 28 6e 6f 74 20 62 65 ... ((not be
59e0: 66 6f 72 65 2d 76 61 6c 75 65 29 0a 09 09 20 20 fore-value)...
59f0: 20 20 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 (dbi:for-eac
5a00: 68 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 h-row (lambda (t
5a10: 75 70 6c 65 29 0a 09 09 09 09 09 20 20 28 73 65 uple)...... (se
5a20: 74 21 20 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 t! changed-count
5a30: 20 28 2b 20 63 68 61 6e 67 65 64 2d 63 6f 75 6e (+ changed-coun
5a40: 74 20 31 29 29 29 0a 09 09 09 09 09 63 6f 6e 6e t 1)))......conn
5a50: 0a 09 09 09 09 09 28 73 3a 73 71 6c 70 61 72 61 ......(s:sqlpara
5a60: 6d 20 69 6e 73 2d 71 75 65 72 79 20 73 65 73 73 m ins-query sess
5a70: 69 6f 6e 2d 69 64 20 70 61 67 65 20 6b 65 79 20 ion-id page key
5a80: 6d 61 73 74 65 72 2d 76 61 6c 75 65 29 29 29 0a master-value))).
5a90: 09 09 20 20 20 20 20 28 65 6c 73 65 20 28 65 72 .. (else (er
5aa0: 72 3a 6c 6f 67 20 22 53 68 6f 75 6c 64 6e 27 74 r:log "Shouldn't
5ab0: 20 67 65 74 20 68 65 72 65 22 29 29 29 29 29 0a get here"))))).
5ac0: 09 09 61 6c 6c 2d 6b 65 79 73 29 29 29 20 3b 3b ..all-keys))) ;;
5ad0: 20 70 72 6f 63 65 73 73 20 61 6c 6c 20 6b 65 79 process all key
5ae0: 73 0a 09 20 20 20 28 6c 69 73 74 20 22 2a 73 65 s.. (list "*se
5af0: 73 73 69 6f 6e 76 61 72 73 2a 22 20 22 2a 67 6c ssionvars*" "*gl
5b00: 6f 62 61 6c 76 61 72 73 2a 22 20 70 61 67 65 2d obalvars*" page-
5b10: 6e 61 6d 65 29 29 29 29 29 29 0a 0a 3b 3b 20 09 name))))))..;; .
5b20: 20 20 3b 3b 20 28 70 72 69 6e 74 20 64 65 6c 2d ;; (print del-
5b30: 71 75 65 72 79 29 0a 3b 3b 20 20 20 20 20 20 20 query).;;
5b40: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 3b 3b (for-each.;;
5b50: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 61 6d (lam
5b60: 62 64 61 20 28 70 61 67 65 29 0a 3b 3b 20 20 20 bda (page).;;
5b70: 20 20 20 20 20 20 20 20 20 20 20 28 70 67 3a 71 (pg:q
5b80: 75 65 72 79 2d 66 6f 72 2d 65 61 63 68 20 28 6c uery-for-each (l
5b90: 61 6d 62 64 61 20 28 74 75 70 6c 65 29 0a 3b 3b ambda (tuple).;;
5ba0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5bb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5bc0: 20 20 20 28 73 65 74 21 20 73 74 61 74 75 73 20 (set! status
5bd0: 23 74 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 #t)).;;
5be0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5bf0: 20 20 20 20 20 20 20 20 28 73 3a 73 71 6c 70 61 (s:sqlpa
5c00: 72 61 6d 20 64 65 6c 2d 71 75 65 72 79 20 73 65 ram del-query se
5c10: 73 73 69 6f 6e 2d 69 64 20 70 61 67 65 2d 6e 61 ssion-id page-na
5c20: 6d 65 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 me).;;
5c30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5c40: 20 20 20 20 20 20 20 63 6f 6e 6e 29 29 0a 3b 3b conn)).;;
5c50: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 69 73 (lis
5c60: 74 20 70 61 67 65 2d 6e 61 6d 65 20 22 2a 73 65 t page-name "*se
5c70: 73 73 69 6f 6e 76 61 72 73 22 29 29 0a 3b 3b 20 ssionvars")).;;
5c80: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 4e 4f 54 ;; NOT
5c90: 45 3a 20 54 68 65 20 66 6f 6c 6c 6f 77 69 6e 67 E: The following
5ca0: 20 61 70 70 72 6f 61 63 68 20 69 73 20 69 6e 65 approach is ine
5cb0: 66 66 69 63 69 65 6e 74 20 61 6e 64 20 61 20 6c fficient and a l
5cc0: 69 74 74 6c 65 20 64 61 6e 67 65 72 6f 75 73 2e ittle dangerous.
5cd0: 20 4e 65 65 64 20 74 6f 20 6b 65 65 70 0a 3b 3b Need to keep.;;
5ce0: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 20 20 ;;
5cf0: 20 20 20 20 74 77 6f 20 68 61 73 68 65 73 2c 20 two hashes,
5d00: 62 65 66 6f 72 65 20 61 6e 64 20 61 66 74 65 72 before and after
5d10: 20 61 6e 64 20 75 73 65 20 74 68 65 20 64 65 6c and use the del
5d20: 74 61 20 74 6f 20 64 72 69 76 65 20 75 70 64 61 ta to drive upda
5d30: 74 69 6e 67 20 74 68 65 20 64 62 20 4f 52 0a 3b ting the db OR.;
5d40: 3b 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 20 ; ;;
5d50: 20 20 20 20 20 65 76 65 6e 20 62 65 74 74 65 72 even better
5d60: 20 6d 6f 76 65 20 74 6f 20 75 73 69 6e 67 20 72 move to using r
5d70: 70 63 20 77 69 74 68 20 61 20 63 65 6e 74 72 61 pc with a centra
5d80: 6c 20 70 72 6f 63 65 73 73 20 66 6f 72 20 6d 61 l process for ma
5d90: 69 6e 74 61 69 6e 69 6e 67 20 73 74 61 74 65 0a intaining state.
5da0: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;; ;;
5db0: 77 72 69 74 65 20 74 68 65 20 73 65 73 73 69 6f write the sessio
5dc0: 6e 20 70 61 67 65 20 73 70 65 63 69 66 69 63 20 n page specific
5dd0: 76 61 72 73 20 74 6f 20 74 68 65 20 64 62 0a 3b vars to the db.;
5de0: 3b 20 09 20 20 28 66 6f 72 2d 65 61 63 68 20 28 ; . (for-each (
5df0: 6c 61 6d 62 64 61 20 28 6b 65 79 29 0a 3b 3b 20 lambda (key).;;
5e00: 09 09 20 20 20 20 20 20 28 70 67 3a 71 75 65 72 .. (pg:quer
5e10: 79 2d 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 y-for-each (lamb
5e20: 64 61 20 28 74 75 70 6c 65 29 0a 3b 3b 20 09 09 da (tuple).;; ..
5e30: 09 09 09 20 20 20 28 73 65 74 21 20 73 74 61 74 ... (set! stat
5e40: 75 73 20 23 74 29 29 0a 3b 3b 20 09 09 09 09 09 us #t)).;; .....
5e50: 20 28 73 3a 73 71 6c 70 61 72 61 6d 20 69 6e 73 (s:sqlparam ins
5e60: 2d 71 75 65 72 79 20 73 65 73 73 69 6f 6e 2d 69 -query session-i
5e70: 64 20 70 61 67 65 2d 6e 61 6d 65 0a 3b 3b 20 20 d page-name.;;
5e80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5e90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5ea0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5eb0: 20 20 20 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 (s:any->stri
5ec0: 6e 67 20 6b 65 79 29 20 3b 3b 20 6a 75 73 74 20 ng key) ;; just
5ed0: 69 6e 20 63 61 73 65 20 69 74 20 69 73 20 61 20 in case it is a
5ee0: 73 79 6d 62 6f 6c 0a 3b 3b 20 20 20 20 20 20 20 symbol.;;
5ef0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5f00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5f10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
5f20: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 70 hash-table-ref p
5f30: 61 67 65 76 61 72 73 20 6b 65 79 29 29 0a 3b 3b agevars key)).;;
5f40: 20 09 09 09 09 09 20 63 6f 6e 6e 29 29 0a 3b 3b ..... conn)).;;
5f50: 20 09 09 20 20 20 20 28 68 61 73 68 2d 74 61 62 .. (hash-tab
5f60: 6c 65 2d 6b 65 79 73 20 70 61 67 65 76 61 72 73 le-keys pagevars
5f70: 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 )).;;
5f80: 3b 3b 20 77 72 69 74 65 20 74 68 65 20 73 65 73 ;; write the ses
5f90: 73 69 6f 6e 20 73 70 65 63 69 66 69 63 20 76 61 sion specific va
5fa0: 72 73 20 74 6f 20 74 68 65 20 64 62 0a 3b 3b 20 rs to the db.;;
5fb0: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 42 55 47 ;; BUG
5fc0: 21 21 21 20 54 48 49 53 20 49 53 20 4c 41 5a 59 !!! THIS IS LAZY
5fd0: 20 41 4e 44 20 57 49 4c 4c 20 42 52 45 41 4b 20 AND WILL BREAK
5fe0: 46 4f 52 20 53 4f 4d 45 4f 4e 45 20 41 43 43 45 FOR SOMEONE ACCE
5ff0: 53 53 49 4e 47 20 54 48 45 20 53 41 4d 45 20 53 SSING THE SAME S
6000: 45 53 53 49 4f 4e 20 46 52 4f 4d 20 54 57 4f 20 ESSION FROM TWO
6010: 57 49 4e 44 4f 57 53 21 21 21 0a 3b 3b 20 09 20 WINDOWS!!!.;; .
6020: 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 (for-each (lamb
6030: 64 61 20 28 6b 65 79 29 0a 3b 3b 20 09 09 20 20 da (key).;; ..
6040: 20 20 20 20 28 70 67 3a 71 75 65 72 79 2d 66 6f (pg:query-fo
6050: 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 r-each (lambda (
6060: 74 75 70 6c 65 29 0a 3b 3b 20 09 09 09 09 09 20 tuple).;; .....
6070: 20 20 28 73 65 74 21 20 73 74 61 74 75 73 20 23 (set! status #
6080: 74 29 29 0a 3b 3b 20 09 09 09 09 09 20 28 73 3a t)).;; ..... (s:
6090: 73 71 6c 70 61 72 61 6d 20 69 6e 73 2d 71 75 65 sqlparam ins-que
60a0: 72 79 20 73 65 73 73 69 6f 6e 2d 69 64 20 22 2a ry session-id "*
60b0: 73 65 73 73 69 6f 6e 76 61 72 73 2a 22 0a 3b 3b sessionvars*".;;
60c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
60d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
60e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
60f0: 20 20 20 20 20 20 28 73 3a 61 6e 79 2d 3e 73 74 (s:any->st
6100: 72 69 6e 67 20 6b 65 79 29 20 3b 3b 20 6a 75 73 ring key) ;; jus
6110: 74 20 69 6e 20 63 61 73 65 20 69 74 20 69 73 20 t in case it is
6120: 61 20 73 79 6d 62 6f 6c 0a 3b 3b 20 20 20 20 20 a symbol.;;
6130: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6140: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6150: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6160: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
6170: 20 73 65 73 73 69 6f 6e 76 61 72 73 20 6b 65 79 sessionvars key
6180: 29 29 0a 3b 3b 20 09 09 09 09 09 20 63 6f 6e 6e )).;; ..... conn
6190: 29 29 0a 3b 3b 20 09 09 20 20 20 20 28 68 61 73 )).;; .. (has
61a0: 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 73 65 73 h-table-keys ses
61b0: 73 69 6f 6e 76 61 72 73 29 29 0a 3b 3b 20 20 20 sionvars)).;;
61c0: 20 20 20 20 20 20 20 20 3b 3b 20 67 6c 6f 62 61 ;; globa
61d0: 6c 20 76 61 72 73 20 77 69 6c 6c 20 72 65 71 75 l vars will requ
61e0: 69 72 65 20 61 20 6c 69 74 74 6c 65 20 6d 6f 72 ire a little mor
61f0: 65 20 63 61 72 65 20 2d 20 64 65 6c 61 79 69 6e e care - delayin
6200: 67 20 66 6f 72 20 6e 6f 77 2e 0a 3b 3b 20 20 20 g for now..;;
6210: 20 20 20 20 20 20 20 20 29 29 29 29 0a 0a 3b 3b ))))..;;
6220: 20 28 70 67 3a 73 71 6c 2d 6e 75 6c 6c 2d 6f 62 (pg:sql-null-ob
6230: 6a 65 63 74 3f 20 65 6c 65 6d 65 6e 74 29 0a 28 ject? element).(
6240: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
6250: 72 65 61 64 2d 63 6f 6e 66 69 67 20 73 65 6c 66 read-config self
6260: 29 0a 20 20 28 6c 65 74 20 28 28 6e 61 6d 65 20 ). (let ((name
6270: 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 22 (string-append "
6280: 2e 22 20 28 70 61 74 68 6e 61 6d 65 2d 66 69 6c ." (pathname-fil
6290: 65 20 28 63 61 72 20 28 61 72 67 76 29 29 29 20 e (car (argv)))
62a0: 22 2e 63 6f 6e 66 69 67 22 29 29 29 0a 20 20 20 ".config"))).
62b0: 20 28 69 66 20 28 6e 6f 74 20 28 66 69 6c 65 2d (if (not (file-
62c0: 65 78 69 73 74 73 3f 20 6e 61 6d 65 29 29 0a 09 exists? name))..
62d0: 28 70 72 69 6e 74 20 6e 61 6d 65 20 22 20 6e 6f (print name " no
62e0: 74 20 66 6f 75 6e 64 20 61 74 20 22 20 28 63 75 t found at " (cu
62f0: 72 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 79 29 rrent-directory)
6300: 29 0a 09 28 6c 65 74 2a 20 28 28 66 70 20 28 6f )..(let* ((fp (o
6310: 70 65 6e 2d 69 6e 70 75 74 2d 66 69 6c 65 20 6e pen-input-file n
6320: 61 6d 65 29 29 0a 09 20 20 20 20 20 20 20 28 69 ame)).. (i
6330: 6e 69 74 61 72 67 73 20 28 72 65 61 64 20 66 70 nitargs (read fp
6340: 29 29 29 0a 09 20 20 28 63 6c 6f 73 65 2d 69 6e ))).. (close-in
6350: 70 75 74 2d 70 6f 72 74 20 66 70 29 0a 09 20 20 put-port fp)..
6360: 69 6e 69 74 61 72 67 73 29 29 29 29 0a 0a 3b 3b initargs))))..;;
6370: 20 63 61 6c 6c 20 74 68 65 20 63 6f 6e 74 72 6f call the contro
6380: 6c 6c 65 72 20 69 66 20 69 74 20 65 78 69 73 74 ller if it exist
6390: 73 0a 3b 3b 20 0a 3b 3b 20 57 41 52 4e 49 4e 47 s.;; .;; WARNING
63a0: 20 2d 20 74 68 69 73 20 63 6f 64 65 20 6e 65 65 - this code nee
63b0: 64 73 20 61 20 64 65 66 65 6e 63 65 20 61 67 61 ds a defence aga
63c0: 69 6e 73 20 72 65 63 75 72 73 69 76 65 20 63 61 ins recursive ca
63d0: 6c 6c 69 6e 67 21 21 21 21 21 0a 3b 3b 0a 3b 3b lling!!!!!.;;.;;
63e0: 20 20 20 49 20 73 75 67 67 65 73 74 20 61 20 6c I suggest a l
63f0: 69 6d 69 74 20 6f 66 20 31 30 30 20 63 61 6c 6c imit of 100 call
6400: 73 2e 20 50 6c 65 6e 74 79 20 66 6f 72 20 61 6c s. Plenty for al
6410: 6c 6f 77 69 6e 67 20 6d 75 6c 74 69 70 6c 65 20 lowing multiple
6420: 69 6e 73 74 61 6e 63 65 73 0a 3b 3b 20 20 20 6f instances.;; o
6430: 66 20 61 20 70 61 67 65 20 69 6e 73 69 64 65 20 f a page inside
6440: 61 6e 6f 74 68 65 72 20 70 61 67 65 2e 20 0a 3b another page. .;
6450: 3b 0a 3b 3b 20 70 61 72 74 73 20 3d 20 27 62 6f ;.;; parts = 'bo
6460: 74 68 20 7c 20 27 63 6f 6e 74 72 6f 6c 20 7c 20 th | 'control |
6470: 27 76 69 65 77 0a 3b 3b 0a 0a 28 64 65 66 69 6e 'view.;;..(defin
6480: 65 20 28 66 69 6c 65 73 2d 72 65 61 64 2d 3e 73 e (files-read->s
6490: 74 72 69 6e 67 20 2e 20 66 69 6c 65 73 29 0a 20 tring . files).
64a0: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
64b0: 65 72 73 65 20 0a 20 20 20 28 61 70 70 6c 79 20 erse . (apply
64c0: 61 70 70 65 6e 64 20 28 6d 61 70 20 66 69 6c 65 append (map file
64d0: 2d 72 65 61 64 2d 3e 73 74 72 69 6e 67 20 66 69 -read->string fi
64e0: 6c 65 73 29 29 20 22 5c 6e 22 29 29 0a 0a 28 64 les)) "\n"))..(d
64f0: 65 66 69 6e 65 20 28 66 69 6c 65 2d 72 65 61 64 efine (file-read
6500: 2d 3e 73 74 72 69 6e 67 20 66 29 20 0a 20 20 28 ->string f) . (
6510: 6c 65 74 20 28 28 70 20 28 6f 70 65 6e 2d 69 6e let ((p (open-in
6520: 70 75 74 2d 66 69 6c 65 20 66 29 29 29 0a 20 20 put-file f))).
6530: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 (let loop ((he
6540: 64 20 28 72 65 61 64 2d 6c 69 6e 65 20 70 29 29 d (read-line p))
6550: 0a 09 20 20 20 20 20 20 20 28 72 65 73 20 27 28 .. (res '(
6560: 29 29 29 0a 20 20 20 20 20 20 28 69 66 20 28 65 ))). (if (e
6570: 6f 66 2d 6f 62 6a 65 63 74 3f 20 68 65 64 29 0a of-object? hed).
6580: 09 20 20 72 65 73 0a 09 20 20 28 6c 6f 6f 70 20 . res.. (loop
6590: 28 72 65 61 64 2d 6c 69 6e 65 20 70 29 28 61 70 (read-line p)(ap
65a0: 70 65 6e 64 20 72 65 73 20 28 6c 69 73 74 20 68 pend res (list h
65b0: 65 64 29 29 29 29 29 29 29 0a 0a 3b 3b 20 4d 61 ed)))))))..;; Ma
65c0: 79 20 32 30 31 31 2c 20 70 75 74 74 69 6e 67 20 y 2011, putting
65d0: 61 6c 6c 20 70 61 67 65 73 20 69 6e 74 6f 20 6f all pages into o
65e0: 6e 65 20 64 69 72 65 63 74 6f 72 79 20 66 6f 72 ne directory for
65f0: 20 74 68 65 20 66 6f 6c 6c 6f 77 69 6e 67 20 72 the following r
6600: 65 61 73 6f 6e 73 3a 0a 3b 3b 20 20 20 31 2e 20 easons:.;; 1.
6610: 77 61 6e 74 20 66 69 6c 65 6e 61 6d 65 20 74 6f want filename to
6620: 20 72 65 66 6c 65 63 74 20 70 61 67 65 20 6e 61 reflect page na
6630: 6d 65 20 28 65 6d 61 63 73 20 6c 69 6d 69 74 61 me (emacs limita
6640: 74 69 6f 6e 29 0a 3b 3b 20 20 20 32 2e 20 74 68 tion).;; 2. th
6650: 61 74 27 73 20 69 74 21 20 6e 6f 20 6f 74 68 65 at's it! no othe
6660: 72 20 72 65 61 73 6f 6e 2e 20 63 6f 75 6c 64 20 r reason. could
6670: 6d 61 6b 65 20 69 74 20 63 6f 6e 66 69 67 75 72 make it configur
6680: 61 62 6c 65 20 2e 2e 2e 0a 28 64 65 66 69 6e 65 able ....(define
6690: 20 28 73 65 73 73 69 6f 6e 3a 63 61 6c 6c 2d 70 (session:call-p
66a0: 61 72 74 73 20 73 65 6c 66 20 70 61 67 65 20 70 arts self page p
66b0: 61 72 74 73 29 0a 20 20 28 73 65 73 73 69 6f 6e arts). (session
66c0: 3a 73 64 61 74 2d 73 65 74 2d 63 75 72 72 2d 70 :sdat-set-curr-p
66d0: 61 67 65 21 20 73 65 6c 66 20 70 61 67 65 29 0a age! self page).
66e0: 20 20 3b 3b 20 28 73 65 73 73 69 6f 6e 3a 6c 6f ;; (session:lo
66f0: 67 20 73 65 6c 66 20 22 70 61 67 65 2d 64 69 72 g self "page-dir
6700: 2d 73 74 79 6c 65 3a 20 22 20 28 73 65 73 73 69 -style: " (sessi
6710: 6f 6e 3a 73 64 61 74 2d 67 65 74 2d 70 61 67 65 on:sdat-get-page
6720: 2d 64 69 72 2d 73 74 79 6c 65 20 73 65 6c 66 29 -dir-style self)
6730: 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 69 72 2d ). (let* ((dir-
6740: 73 74 79 6c 65 20 3b 3b 20 28 65 71 75 61 6c 3f style ;; (equal?
6750: 20 28 73 65 73 73 69 6f 6e 3a 73 64 61 74 2d 67 (session:sdat-g
6760: 65 74 2d 70 61 67 65 2d 64 69 72 2d 73 74 79 6c et-page-dir-styl
6770: 65 20 73 65 6c 66 29 20 22 6f 6e 65 64 69 72 22 e self) "onedir"
6780: 29 29 20 3b 3b 20 66 6c 61 67 20 23 74 20 66 6f )) ;; flag #t fo
6790: 72 20 6f 6e 65 64 69 72 2c 20 23 66 20 66 6f 72 r onedir, #f for
67a0: 20 6f 6c 64 20 73 74 79 6c 65 0a 09 20 20 28 73 old style.. (s
67b0: 65 73 73 69 6f 6e 3a 73 64 61 74 2d 67 65 74 2d ession:sdat-get-
67c0: 70 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 20 73 page-dir-style s
67d0: 65 6c 66 29 29 0a 09 20 28 64 69 72 20 20 20 20 elf)).. (dir
67e0: 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 (string-append
67f0: 28 73 65 73 73 69 6f 6e 3a 73 64 61 74 2d 67 65 (session:sdat-ge
6800: 74 2d 73 72 6f 6f 74 20 73 65 6c 66 29 20 0a 09 t-sroot self) ..
6810: 09 09 09 20 28 69 66 20 64 69 72 2d 73 74 79 6c ... (if dir-styl
6820: 65 20 0a 09 09 09 09 20 20 20 20 20 28 63 6f 6e e ..... (con
6830: 63 20 22 2f 70 61 67 65 73 2f 22 29 0a 09 09 09 c "/pages/")....
6840: 09 20 20 20 20 20 28 63 6f 6e 63 20 22 2f 70 61 . (conc "/pa
6850: 67 65 73 2f 22 20 70 61 67 65 29 29 29 29 0a 09 ges/" page))))..
6860: 20 28 63 6f 6e 74 72 6f 6c 20 28 73 74 72 69 6e (control (strin
6870: 67 2d 61 70 70 65 6e 64 20 64 69 72 20 28 69 66 g-append dir (if
6880: 20 64 69 72 2d 73 74 79 6c 65 20 0a 09 09 09 09 dir-style .....
6890: 09 20 28 63 6f 6e 63 20 70 61 67 65 20 22 5f 63 . (conc page "_c
68a0: 74 72 6c 2e 73 63 6d 22 29 0a 09 09 09 09 09 20 trl.scm")......
68b0: 22 2f 63 6f 6e 74 72 6f 6c 2e 73 63 6d 22 29 29 "/control.scm"))
68c0: 29 0a 09 20 28 76 69 65 77 20 20 20 20 28 73 74 ).. (view (st
68d0: 72 69 6e 67 2d 61 70 70 65 6e 64 20 64 69 72 20 ring-append dir
68e0: 28 69 66 20 64 69 72 2d 73 74 79 6c 65 20 0a 09 (if dir-style ..
68f0: 09 09 09 09 20 28 63 6f 6e 63 20 70 61 67 65 20 .... (conc page
6900: 22 5f 76 69 65 77 2e 73 63 6d 22 29 0a 09 09 09 "_view.scm")....
6910: 09 09 20 22 2f 76 69 65 77 2e 73 63 6d 22 29 29 .. "/view.scm"))
6920: 29 0a 09 20 28 6c 6f 61 64 2d 76 69 65 77 20 20 ).. (load-view
6930: 20 20 28 61 6e 64 20 28 66 69 6c 65 2d 65 78 69 (and (file-exi
6940: 73 74 73 3f 20 76 69 65 77 29 0a 09 09 09 20 20 sts? view)....
6950: 20 20 28 6f 72 20 28 65 71 3f 20 70 61 72 74 73 (or (eq? parts
6960: 20 27 62 6f 74 68 29 28 65 71 3f 20 70 61 72 74 'both)(eq? part
6970: 73 20 27 76 69 65 77 29 29 29 29 0a 09 20 28 6c s 'view)))).. (l
6980: 6f 61 64 2d 63 6f 6e 74 72 6f 6c 20 28 61 6e 64 oad-control (and
6990: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 63 (file-exists? c
69a0: 6f 6e 74 72 6f 6c 29 0a 09 09 09 20 20 20 20 28 ontrol).... (
69b0: 6f 72 20 28 65 71 3f 20 70 61 72 74 73 20 27 62 or (eq? parts 'b
69c0: 6f 74 68 29 28 65 71 3f 20 70 61 72 74 73 20 27 oth)(eq? parts '
69d0: 63 6f 6e 74 72 6f 6c 29 29 29 29 0a 09 20 28 76 control)))).. (v
69e0: 69 65 77 2d 64 61 74 20 20 20 27 28 29 29 29 0a iew-dat '())).
69f0: 20 20 20 20 3b 3b 20 28 73 65 73 73 69 6f 6e 3a ;; (session:
6a00: 6c 6f 67 20 73 65 6c 66 20 22 64 69 72 2d 73 74 log self "dir-st
6a10: 79 6c 65 3a 20 22 20 64 69 72 2d 73 74 79 6c 65 yle: " dir-style
6a20: 29 0a 20 3b 3b 20 20 20 28 73 75 67 61 72 20 22 ). ;; (sugar "
6a30: 2f 68 6f 6d 65 2f 6d 61 74 74 2f 6b 69 61 74 6f /home/matt/kiato
6a40: 61 2f 73 74 6d 6c 2f 73 75 67 61 72 2e 73 63 6d a/stml/sugar.scm
6a50: 22 20 29 29 0a 20 20 20 20 3b 3b 20 28 70 72 69 " )). ;; (pri
6a60: 6e 74 20 22 64 69 72 3d 22 20 64 69 72 20 22 20 nt "dir=" dir "
6a70: 63 6f 6e 74 72 6f 6c 3d 22 20 63 6f 6e 74 72 6f control=" contro
6a80: 6c 20 22 20 76 69 65 77 3d 22 20 76 69 65 77 20 l " view=" view
6a90: 22 20 6c 6f 61 64 2d 76 69 65 77 3d 22 20 6c 6f " load-view=" lo
6aa0: 61 64 2d 76 69 65 77 20 22 20 6c 6f 61 64 3d 63 ad-view " load=c
6ab0: 6f 6e 74 72 6f 6c 3d 22 20 6c 6f 61 64 2d 63 6f ontrol=" load-co
6ac0: 6e 74 72 6f 6c 29 0a 20 20 20 20 28 69 66 20 6c ntrol). (if l
6ad0: 6f 61 64 2d 63 6f 6e 74 72 6f 6c 0a 09 28 62 65 oad-control..(be
6ae0: 67 69 6e 0a 09 20 20 28 6c 6f 61 64 20 63 6f 6e gin.. (load con
6af0: 74 72 6f 6c 29 0a 09 20 20 28 73 65 73 73 69 6f trol).. (sessio
6b00: 6e 3a 73 65 74 2d 63 61 6c 6c 65 64 21 20 73 65 n:set-called! se
6b10: 6c 66 20 70 61 67 65 29 29 29 0a 20 20 20 20 3b lf page))). ;
6b20: 3b 20 6d 6f 76 65 20 74 68 69 73 20 74 6f 20 77 ; move this to w
6b30: 68 65 72 65 20 69 74 20 67 65 74 73 20 65 78 65 here it gets exe
6b40: 63 74 75 74 65 64 20 6f 6e 6c 79 20 6f 6e 63 65 ctuted only once
6b50: 0a 20 20 20 20 3b 3b 0a 20 20 20 20 28 69 66 20 . ;;. (if
6b60: 6c 6f 61 64 2d 76 69 65 77 0a 09 3b 3b 20 6f 70 load-view..;; op
6b70: 74 69 6f 6e 20 6f 6e 65 2e 3a 0a 09 3b 3b 0a 09 tion one.:..;;..
6b80: 3b 3b 20 28 6c 65 74 20 28 28 69 6e 70 20 28 6f ;; (let ((inp (o
6b90: 70 65 6e 2d 69 6e 70 75 74 2d 73 74 72 69 6e 67 pen-input-string
6ba0: 20 0a 09 3b 3b 20 09 20 20 20 20 28 66 69 6c 65 ..;; . (file
6bb0: 73 2d 72 65 61 64 2d 3e 73 74 72 69 6e 67 20 22 s-read->string "
6bc0: 2f 68 6f 6d 65 2f 6d 61 74 74 2f 6b 69 61 74 6f /home/matt/kiato
6bd0: 61 2f 73 74 6d 6c 2f 73 75 67 61 72 2e 73 63 6d a/stml/sugar.scm
6be0: 22 20 0a 09 3b 3b 20 09 09 09 09 76 69 65 77 29 " ..;; ....view)
6bf0: 29 29 29 0a 09 3b 3b 20 20 20 28 6d 61 70 20 0a )))..;; (map .
6c00: 09 3b 3b 20 20 20 20 28 6c 61 6d 62 64 61 20 28 .;; (lambda (
6c10: 78 29 0a 09 3b 3b 20 20 20 20 20 20 28 63 6f 6e x)..;; (con
6c20: 64 0a 09 3b 3b 20 20 20 20 20 20 20 28 28 6c 69 d..;; ((li
6c30: 73 74 3f 20 78 29 20 78 29 0a 09 3b 3b 20 20 20 st? x) x)..;;
6c40: 20 20 20 20 28 28 73 74 72 69 6e 67 3f 20 78 29 ((string? x)
6c50: 20 78 29 0a 09 3b 3b 20 20 20 20 20 20 20 28 65 x)..;; (e
6c60: 6c 73 65 20 27 28 29 29 29 29 0a 09 3b 3b 20 20 lse '())))..;;
6c70: 20 20 28 70 6f 72 74 2d 6d 61 70 20 65 76 61 6c (port-map eval
6c80: 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 3b 3b 20 (lambda ()..;;
6c90: 09 09 20 28 72 65 61 64 20 69 6e 70 29 29 29 29 .. (read inp))))
6ca0: 29 0a 09 3b 3b 0a 09 3b 3b 20 6f 70 74 69 6f 6e )..;;..;; option
6cb0: 20 74 77 6f 3a 0a 09 3b 3b 0a 09 28 6c 65 74 2a two:..;;..(let*
6cc0: 20 28 3b 3b 20 28 69 6e 70 73 20 28 6d 61 70 20 (;; (inps (map
6cd0: 6f 70 65 6e 2d 69 6e 70 75 74 2d 66 69 6c 65 20 open-input-file
6ce0: 28 6c 69 73 74 20 76 69 65 77 29 29 29 20 3b 3b (list view))) ;;
6cf0: 20 73 75 67 61 72 20 76 69 65 77 29 29 29 0a 09 sugar view)))..
6d00: 20 20 20 20 20 20 20 28 70 20 20 20 20 28 6f 70 (p (op
6d10: 65 6e 2d 69 6e 70 75 74 2d 66 69 6c 65 20 76 69 en-input-file vi
6d20: 65 77 29 29 20 3b 3b 20 28 61 70 70 6c 79 20 6d ew)) ;; (apply m
6d30: 61 6b 65 2d 63 6f 6e 63 61 74 65 6e 61 74 65 64 ake-concatenated
6d40: 2d 70 6f 72 74 20 69 6e 70 73 29 29 0a 09 20 20 -port inps))..
6d50: 20 20 20 20 20 28 64 61 74 20 20 28 6d 61 70 20 (dat (map
6d60: 0a 09 09 20 20 20 20 20 20 28 6c 61 6d 62 64 61 ... (lambda
6d70: 20 28 78 29 0a 09 09 09 28 63 6f 6e 64 0a 09 09 (x)....(cond...
6d80: 09 20 28 28 6c 69 73 74 3f 20 78 29 20 78 29 0a . ((list? x) x).
6d90: 09 09 09 20 28 28 73 74 72 69 6e 67 3f 20 78 29 ... ((string? x)
6da0: 20 78 29 0a 09 09 09 20 28 65 6c 73 65 20 27 28 x).... (else '(
6db0: 29 29 29 29 0a 09 09 20 20 20 20 20 20 28 70 6f ))))... (po
6dc0: 72 74 2d 6d 61 70 20 65 76 61 6c 20 28 6c 61 6d rt-map eval (lam
6dd0: 62 64 61 20 28 29 28 72 65 61 64 20 70 29 29 29 bda ()(read p)))
6de0: 29 29 29 0a 09 20 20 3b 3b 20 28 6d 61 70 20 63 ))).. ;; (map c
6df0: 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 6f 72 74 20 lose-input-port
6e00: 69 6e 70 73 29 0a 09 20 20 28 63 6c 6f 73 65 2d inps).. (close-
6e10: 69 6e 70 75 74 2d 70 6f 72 74 20 70 29 0a 09 20 input-port p)..
6e20: 20 64 61 74 29 0a 09 28 6c 69 73 74 20 22 3c 70 dat)..(list "<p
6e30: 3e 50 61 67 65 20 6e 6f 74 20 66 6f 75 6e 64 20 >Page not found
6e40: 22 20 70 61 67 65 20 22 20 3c 2f 70 3e 22 29 29 " page " </p>"))
6e50: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 ))..(define (ses
6e60: 73 69 6f 6e 3a 63 61 6c 6c 20 73 65 6c 66 20 70 sion:call self p
6e70: 61 67 65 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a age). (session:
6e80: 63 61 6c 6c 2d 70 61 72 74 73 20 73 65 6c 66 20 call-parts self
6e90: 70 61 67 65 20 27 62 6f 74 68 29 29 0a 0a 28 64 page 'both))..(d
6ea0: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 63 efine (session:c
6eb0: 61 6c 6c 20 73 65 6c 66 20 70 61 67 65 20 70 61 all self page pa
6ec0: 72 74 73 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a rts). (session:
6ed0: 63 61 6c 6c 2d 70 61 72 74 73 20 73 65 6c 66 20 call-parts self
6ee0: 70 61 67 65 20 27 62 6f 74 68 29 29 0a 0a 28 64 page 'both))..(d
6ef0: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 6c efine (session:l
6f00: 6f 61 64 2d 6d 6f 64 65 6c 20 73 65 6c 66 20 6d oad-model self m
6f10: 6f 64 65 6c 29 0a 20 20 28 6c 65 74 20 28 28 6d odel). (let ((m
6f20: 6f 64 65 6c 2e 73 63 6d 20 28 73 74 72 69 6e 67 odel.scm (string
6f30: 2d 61 70 70 65 6e 64 20 28 73 65 73 73 69 6f 6e -append (session
6f40: 3a 73 64 61 74 2d 67 65 74 2d 73 72 6f 6f 74 20 :sdat-get-sroot
6f50: 73 65 6c 66 29 20 22 2f 6d 6f 64 65 6c 73 2f 22 self) "/models/"
6f60: 20 6d 6f 64 65 6c 20 22 2e 73 63 6d 22 29 29 0a model ".scm")).
6f70: 09 28 6d 6f 64 65 6c 2e 73 6f 20 20 28 73 74 72 .(model.so (str
6f80: 69 6e 67 2d 61 70 70 65 6e 64 20 28 73 65 73 73 ing-append (sess
6f90: 69 6f 6e 3a 73 64 61 74 2d 67 65 74 2d 73 72 6f ion:sdat-get-sro
6fa0: 6f 74 20 73 65 6c 66 29 20 22 2f 6d 6f 64 65 6c ot self) "/model
6fb0: 73 2f 22 20 6d 6f 64 65 6c 20 22 2e 73 6f 22 29 s/" model ".so")
6fc0: 29 29 0a 20 20 20 20 28 69 66 20 28 66 69 6c 65 )). (if (file
6fd0: 2d 65 78 69 73 74 73 3f 20 6d 6f 64 65 6c 2e 73 -exists? model.s
6fe0: 6f 29 0a 09 28 6c 6f 61 64 20 6d 6f 64 65 6c 2e o)..(load model.
6ff0: 73 6f 29 0a 09 28 69 66 20 28 66 69 6c 65 2d 65 so)..(if (file-e
7000: 78 69 73 74 73 3f 20 6d 6f 64 65 6c 2e 73 63 6d xists? model.scm
7010: 29 0a 09 20 20 20 20 28 6c 6f 61 64 20 6d 6f 64 ).. (load mod
7020: 65 6c 2e 73 63 6d 29 0a 09 20 20 20 20 28 73 3a el.scm).. (s:
7030: 6c 6f 67 20 22 45 52 52 4f 52 3a 20 6d 6f 64 65 log "ERROR: mode
7040: 6c 20 22 20 6d 6f 64 65 6c 2e 73 63 6d 20 22 20 l " model.scm "
7050: 6e 6f 74 20 66 6f 75 6e 64 22 29 29 29 29 29 0a not found"))))).
7060: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
7070: 6e 3a 6d 6f 64 65 6c 2d 70 61 74 68 20 73 65 6c n:model-path sel
7080: 66 20 6d 6f 64 65 6c 29 0a 20 20 28 73 74 72 69 f model). (stri
7090: 6e 67 2d 61 70 70 65 6e 64 20 28 73 65 73 73 69 ng-append (sessi
70a0: 6f 6e 3a 73 64 61 74 2d 67 65 74 2d 73 72 6f 6f on:sdat-get-sroo
70b0: 74 20 73 65 6c 66 29 20 22 2f 6d 6f 64 65 6c 73 t self) "/models
70c0: 2f 22 20 6d 6f 64 65 6c 20 22 2e 73 63 6d 22 29 /" model ".scm")
70d0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 )..(define (sess
70e0: 69 6f 6e 3a 70 70 2d 66 6f 72 6d 64 61 74 20 73 ion:pp-formdat s
70f0: 65 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 64 61 elf). (let ((da
7100: 74 20 28 66 6f 72 6d 64 61 74 3a 61 6c 6c 2d 3e t (formdat:all->
7110: 73 74 72 69 6e 67 73 20 28 73 65 73 73 69 6f 6e strings (session
7120: 3a 73 64 61 74 2d 67 65 74 2d 66 6f 72 6d 64 61 :sdat-get-formda
7130: 74 20 73 65 6c 66 29 29 29 29 0a 20 20 20 20 28 t self)))). (
7140: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
7150: 73 65 20 64 61 74 20 22 3c 62 72 3e 20 22 29 29 se dat "<br> "))
7160: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 )..(define (sess
7170: 69 6f 6e 3a 70 61 72 61 6d 2d 3e 73 74 72 69 6e ion:param->strin
7180: 67 20 70 61 72 61 6d 73 29 0a 20 20 3b 3b 20 28 g params). ;; (
7190: 65 72 72 3a 6c 6f 67 20 22 70 61 72 61 6d 73 3d err:log "params=
71a0: 22 20 70 61 72 61 6d 73 29 0a 20 20 28 69 66 20 " params). (if
71b0: 28 3c 20 28 6c 65 6e 67 74 68 20 70 61 72 61 6d (< (length param
71c0: 73 29 20 31 29 0a 20 20 20 20 20 20 22 22 0a 20 s) 1). "".
71d0: 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 (let loop (
71e0: 28 6b 65 79 20 28 63 61 72 20 70 61 72 61 6d 73 (key (car params
71f0: 29 29 0a 09 09 20 28 76 61 6c 20 28 63 61 64 72 ))... (val (cadr
7200: 20 70 61 72 61 6d 73 29 29 0a 09 09 20 28 74 61 params))... (ta
7210: 69 6c 20 28 63 64 64 72 20 70 61 72 61 6d 73 29 il (cddr params)
7220: 29 0a 09 09 20 28 72 65 73 75 6c 74 20 27 28 29 )... (result '()
7230: 29 29 0a 09 28 6c 65 74 20 28 28 6e 65 77 72 65 ))..(let ((newre
7240: 73 75 6c 74 20 28 63 6f 6e 73 20 28 73 74 72 69 sult (cons (stri
7250: 6e 67 2d 61 70 70 65 6e 64 20 28 73 3a 61 6e 79 ng-append (s:any
7260: 2d 3e 73 74 72 69 6e 67 20 6b 65 79 29 20 22 3d ->string key) "=
7270: 22 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 " (s:any->string
7280: 20 76 61 6c 29 29 0a 09 09 09 20 20 20 20 20 20 val))....
7290: 20 72 65 73 75 6c 74 29 29 29 0a 09 20 20 28 69 result))).. (i
72a0: 66 20 28 3c 20 28 6c 65 6e 67 74 68 20 74 61 69 f (< (length tai
72b0: 6c 29 20 31 29 20 3b 3b 20 74 72 75 65 20 69 66 l) 1) ;; true if
72c0: 20 64 6f 6e 65 0a 09 20 20 20 20 20 20 28 73 74 done.. (st
72d0: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
72e0: 20 6e 65 77 72 65 73 75 6c 74 20 22 26 22 29 0a newresult "&").
72f0: 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 . (loop (ca
7300: 72 20 74 61 69 6c 29 28 63 61 64 72 20 74 61 69 r tail)(cadr tai
7310: 6c 29 28 63 64 64 72 20 74 61 69 6c 29 20 6e 65 l)(cddr tail) ne
7320: 77 72 65 73 75 6c 74 29 29 29 29 29 29 0a 0a 28 wresult))))))..(
7330: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
7340: 6c 69 6e 6b 2d 74 6f 20 73 65 6c 66 20 70 61 67 link-to self pag
7350: 65 20 70 61 72 61 6d 73 29 0a 20 20 28 6c 65 74 e params). (let
7360: 2a 20 28 28 73 65 72 76 65 72 20 20 20 20 28 69 * ((server (i
7370: 66 20 28 67 65 74 65 6e 76 20 22 48 54 54 50 5f f (getenv "HTTP_
7380: 48 4f 53 54 22 29 0a 09 09 09 28 67 65 74 65 6e HOST")....(geten
7390: 76 20 22 48 54 54 50 5f 48 4f 53 54 22 29 0a 09 v "HTTP_HOST")..
73a0: 09 09 28 67 65 74 65 6e 76 20 22 53 45 52 56 45 ..(getenv "SERVE
73b0: 52 5f 4e 41 4d 45 22 29 29 29 0a 09 20 28 73 63 R_NAME"))).. (sc
73c0: 72 69 70 74 20 28 6c 65 74 20 28 28 73 63 72 69 ript (let ((scri
73d0: 70 74 2d 6e 61 6d 65 20 28 73 74 72 69 6e 67 2d pt-name (string-
73e0: 73 70 6c 69 74 20 28 67 65 74 65 6e 76 20 22 53 split (getenv "S
73f0: 43 52 49 50 54 5f 4e 41 4d 45 22 29 20 22 2f 22 CRIPT_NAME") "/"
7400: 29 29 29 0a 09 09 20 20 20 28 69 66 20 28 3e 20 )))... (if (>
7410: 28 6c 65 6e 67 74 68 20 73 63 72 69 70 74 2d 6e (length script-n
7420: 61 6d 65 29 20 31 29 0a 09 09 20 20 20 20 20 20 ame) 1)...
7430: 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 (string-append
7440: 28 63 61 72 20 73 63 72 69 70 74 2d 6e 61 6d 65 (car script-name
7450: 29 20 22 2f 22 20 28 63 61 64 72 20 73 63 72 69 ) "/" (cadr scri
7460: 70 74 2d 6e 61 6d 65 29 29 0a 09 09 20 20 20 20 pt-name))...
7470: 20 20 20 28 67 65 74 65 6e 76 20 22 53 43 52 49 (getenv "SCRI
7480: 50 54 5f 4e 41 4d 45 22 29 29 29 29 20 3b 3b 20 PT_NAME")))) ;;
7490: 62 75 69 6c 64 20 73 63 72 69 70 74 20 6e 61 6d build script nam
74a0: 65 20 66 72 6f 6d 20 66 69 72 73 74 20 74 77 6f e from first two
74b0: 20 65 6c 65 6d 65 6e 74 73 2e 20 54 68 69 73 20 elements. This
74c0: 69 73 20 61 20 68 61 6e 67 6f 76 65 72 20 66 72 is a hangover fr
74d0: 6f 6d 20 62 65 66 6f 72 65 20 49 20 75 73 65 64 om before I used
74e0: 20 3f 20 69 6e 20 74 68 65 20 55 52 4c 2e 0a 09 ? in the URL...
74f0: 20 28 73 65 73 73 69 6f 6e 2d 6b 65 79 20 28 73 (session-key (s
7500: 65 73 73 69 6f 6e 3a 73 64 61 74 2d 67 65 74 2d ession:sdat-get-
7510: 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 session-key self
7520: 29 29 0a 09 20 28 70 61 72 61 6d 73 74 72 20 28 )).. (paramstr (
7530: 73 65 73 73 69 6f 6e 3a 70 61 72 61 6d 2d 3e 73 session:param->s
7540: 74 72 69 6e 67 20 70 61 72 61 6d 73 29 29 29 0a tring params))).
7550: 20 20 20 20 3b 3b 20 28 73 65 73 73 69 6f 6e 3a ;; (session:
7560: 6c 6f 67 20 73 65 6c 66 20 22 73 65 72 76 65 72 log self "server
7570: 3d 22 20 73 65 72 76 65 72 20 22 20 73 63 72 69 =" server " scri
7580: 70 74 3d 22 20 73 63 72 69 70 74 20 22 20 70 61 pt=" script " pa
7590: 67 65 3d 22 20 70 61 67 65 29 0a 20 20 20 20 28 ge=" page). (
75a0: 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 22 68 string-append "h
75b0: 74 74 70 3a 2f 2f 22 20 73 65 72 76 65 72 20 22 ttp://" server "
75c0: 2f 22 20 73 63 72 69 70 74 20 22 2f 22 20 70 61 /" script "/" pa
75d0: 67 65 20 22 3f 22 20 70 61 72 61 6d 73 74 72 29 ge "?" paramstr)
75e0: 29 29 20 3b 3b 20 22 2f 73 6e 3d 22 20 73 65 73 )) ;; "/sn=" ses
75f0: 73 69 6f 6e 2d 6b 65 79 29 29 29 0a 0a 28 64 65 sion-key)))..(de
7600: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 63 67 fine (session:cg
7610: 69 2d 6f 75 74 20 73 65 6c 66 29 0a 20 20 28 6c i-out self). (l
7620: 65 74 2a 20 28 28 63 6f 6e 74 65 6e 74 20 20 28 et* ((content (
7630: 6c 69 73 74 20 28 73 65 73 73 69 6f 6e 3a 73 64 list (session:sd
7640: 61 74 2d 67 65 74 2d 63 6f 6e 74 65 6e 74 2d 74 at-get-content-t
7650: 79 70 65 20 73 65 6c 66 29 29 29 20 3b 3b 20 27 ype self))) ;; '
7660: 28 22 43 6f 6e 74 65 6e 74 2d 74 79 70 65 3a 20 ("Content-type:
7670: 74 65 78 74 2f 68 74 6d 6c 3b 20 63 68 61 72 73 text/html; chars
7680: 65 74 3d 69 73 6f 2d 38 38 35 39 2d 31 5c 6e 5c et=iso-8859-1\n\
7690: 6e 22 29 29 0a 09 20 28 68 65 61 64 65 72 20 20 n")).. (header
76a0: 20 28 6c 65 74 20 28 28 63 6f 6f 6b 69 65 20 28 (let ((cookie (
76b0: 73 65 73 73 69 6f 6e 3a 73 64 61 74 2d 67 65 74 session:sdat-get
76c0: 2d 73 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 20 -session-cookie
76d0: 73 65 6c 66 29 29 29 0a 09 09 20 20 20 20 20 28 self)))... (
76e0: 69 66 20 63 6f 6f 6b 69 65 0a 09 09 09 20 28 63 if cookie.... (c
76f0: 6f 6e 73 20 28 73 74 72 69 6e 67 2d 61 70 70 65 ons (string-appe
7700: 6e 64 20 22 53 65 74 2d 43 6f 6f 6b 69 65 3a 20 nd "Set-Cookie:
7710: 22 20 28 63 61 72 20 63 6f 6f 6b 69 65 29 29 0a " (car cookie)).
7720: 09 09 09 20 20 20 20 20 20 20 63 6f 6e 74 65 6e ... conten
7730: 74 29 0a 09 09 09 20 63 6f 6e 74 65 6e 74 29 29 t).... content))
7740: 29 0a 09 20 28 70 61 67 65 64 61 74 20 20 28 73 ).. (pagedat (s
7750: 65 73 73 69 6f 6e 3a 73 64 61 74 2d 67 65 74 2d ession:sdat-get-
7760: 70 61 67 65 64 61 74 20 73 65 6c 66 29 29 29 0a pagedat self))).
7770: 20 20 20 20 28 73 3a 63 67 69 2d 6f 75 74 20 0a (s:cgi-out .
7780: 20 20 20 20 20 28 63 6f 6e 73 20 68 65 61 64 65 (cons heade
7790: 72 20 70 61 67 65 64 61 74 29 29 29 29 0a 0a 28 r pagedat))))..(
77a0: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
77b0: 6c 6f 67 20 73 65 6c 66 20 2e 20 6d 73 67 29 0a log self . msg).
77c0: 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 (with-output-t
77d0: 6f 2d 70 6f 72 74 20 28 73 65 73 73 69 6f 6e 3a o-port (session:
77e0: 73 64 61 74 2d 67 65 74 2d 6c 6f 67 2d 70 6f 72 sdat-get-log-por
77f0: 74 20 73 65 6c 66 29 20 3b 3b 20 28 73 65 73 73 t self) ;; (sess
7800: 69 6f 6e 3a 73 64 61 74 2d 67 65 74 2d 6c 6f 67 ion:sdat-get-log
7810: 70 74 20 73 65 6c 66 29 0a 20 20 20 20 28 6c 61 pt self). (la
7820: 6d 62 64 61 20 28 29 20 0a 20 20 20 20 20 20 28 mbda () . (
7830: 61 70 70 6c 79 20 70 72 69 6e 74 20 6d 73 67 29 apply print msg)
7840: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 )))..(define (se
7850: 73 73 69 6f 6e 3a 67 65 74 2d 70 61 72 61 6d 20 ssion:get-param
7860: 73 65 6c 66 20 6b 65 79 29 0a 20 20 3b 3b 20 28 self key). ;; (
7870: 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 3a 73 65 session:log s:se
7880: 73 73 69 6f 6e 20 22 70 61 72 61 6d 73 3d 22 20 ssion "params="
7890: 28 73 6c 6f 74 2d 72 65 66 20 73 3a 73 65 73 73 (slot-ref s:sess
78a0: 69 6f 6e 20 27 70 61 72 61 6d 73 29 29 0a 20 20 ion 'params)).
78b0: 28 6c 65 74 20 28 28 70 61 72 61 6d 73 20 28 73 (let ((params (s
78c0: 65 73 73 69 6f 6e 3a 73 64 61 74 2d 67 65 74 2d ession:sdat-get-
78d0: 70 61 72 61 6d 73 20 73 65 6c 66 29 29 29 0a 20 params self))).
78e0: 20 20 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d (session:get-
78f0: 70 61 72 61 6d 2d 66 72 6f 6d 20 70 61 72 61 6d param-from param
7900: 73 20 6b 65 79 29 29 29 0a 0a 3b 3b 20 54 68 69 s key)))..;; Thi
7910: 73 20 6f 6e 65 20 77 69 6c 6c 20 67 65 74 20 74 s one will get t
7920: 68 65 20 66 69 72 73 74 20 76 61 6c 75 65 20 66 he first value f
7930: 6f 75 6e 64 20 72 65 67 61 72 64 6c 65 73 73 20 ound regardless
7940: 6f 66 20 66 6f 72 6d 0a 28 64 65 66 69 6e 65 20 of form.(define
7950: 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 69 6e 70 (session:get-inp
7960: 75 74 20 73 65 6c 66 20 6b 65 79 29 0a 20 20 28 ut self key). (
7970: 6c 65 74 2a 20 28 28 66 6f 72 6d 64 61 74 20 28 let* ((formdat (
7980: 73 65 73 73 69 6f 6e 3a 73 64 61 74 2d 67 65 74 session:sdat-get
7990: 2d 66 6f 72 6d 64 61 74 20 73 65 6c 66 29 29 29 -formdat self)))
79a0: 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 66 6f . (if (not fo
79b0: 72 6d 64 61 74 29 20 23 66 0a 09 28 69 66 20 28 rmdat) #f..(if (
79c0: 6f 72 20 28 73 74 72 69 6e 67 3f 20 6b 65 79 29 or (string? key)
79d0: 28 6e 75 6d 62 65 72 3f 20 6b 65 79 29 28 73 79 (number? key)(sy
79e0: 6d 62 6f 6c 3f 20 6b 65 79 29 29 0a 09 20 20 20 mbol? key))..
79f0: 20 28 69 66 20 28 65 71 3f 20 28 63 6c 61 73 73 (if (eq? (class
7a00: 2d 6f 66 20 66 6f 72 6d 64 61 74 29 20 3c 66 6f -of formdat) <fo
7a10: 72 6d 64 61 74 3e 29 0a 09 09 28 66 6f 72 6d 64 rmdat>)...(formd
7a20: 61 74 3a 67 65 74 20 66 6f 72 6d 64 61 74 20 6b at:get formdat k
7a30: 65 79 29 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 ey)...(begin...
7a40: 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 (session:log se
7a50: 6c 66 20 22 45 52 52 4f 52 3a 20 66 6f 72 6d 64 lf "ERROR: formd
7a60: 61 74 3a 20 22 20 66 6f 72 6d 64 61 74 20 22 20 at: " formdat "
7a70: 69 73 20 6e 6f 74 20 6f 66 20 63 6c 61 73 73 20 is not of class
7a80: 3c 66 6f 72 6d 64 61 74 3e 22 29 0a 09 09 20 20 <formdat>")...
7a90: 23 66 29 29 0a 09 20 20 20 20 28 73 65 73 73 69 #f)).. (sessi
7aa0: 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 45 52 52 on:log self "ERR
7ab0: 4f 52 3a 20 62 61 64 20 6b 65 79 20 22 20 6b 65 OR: bad key " ke
7ac0: 79 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 y)))))..(define
7ad0: 28 73 65 73 73 69 6f 6e 3a 72 75 6e 2d 61 63 74 (session:run-act
7ae0: 69 6f 6e 73 20 73 65 6c 66 29 0a 20 20 28 6c 65 ions self). (le
7af0: 74 2a 20 28 28 61 63 74 69 6f 6e 20 20 20 20 28 t* ((action (
7b00: 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 72 61 session:get-para
7b10: 6d 20 73 65 6c 66 20 27 61 63 74 69 6f 6e 29 29 m self 'action))
7b20: 0a 09 20 28 70 61 67 65 20 20 20 20 20 20 28 73 .. (page (s
7b30: 65 73 73 69 6f 6e 3a 73 64 61 74 2d 67 65 74 2d ession:sdat-get-
7b40: 70 61 67 65 20 73 65 6c 66 29 29 29 0a 20 20 20 page self))).
7b50: 20 3b 3b 20 28 70 72 69 6e 74 20 22 61 63 74 69 ;; (print "acti
7b60: 6f 6e 3d 22 20 61 63 74 69 6f 6e 20 22 20 70 61 on=" action " pa
7b70: 67 65 3d 22 20 70 61 67 65 29 0a 20 20 20 20 28 ge=" page). (
7b80: 69 66 20 61 63 74 69 6f 6e 0a 09 28 6c 65 74 20 if action..(let
7b90: 28 28 61 63 74 69 6f 6e 2d 6c 73 74 20 20 28 73 ((action-lst (s
7ba0: 74 72 69 6e 67 2d 73 70 6c 69 74 20 61 63 74 69 tring-split acti
7bb0: 6f 6e 20 22 2e 22 29 29 29 0a 09 20 20 3b 3b 20 on "."))).. ;;
7bc0: 28 70 72 69 6e 74 20 22 61 63 74 69 6f 6e 2d 6c (print "action-l
7bd0: 73 74 3d 22 20 61 63 74 69 6f 6e 2d 6c 73 74 29 st=" action-lst)
7be0: 0a 09 20 20 28 69 66 20 28 6e 6f 74 20 28 3d 20 .. (if (not (=
7bf0: 28 6c 65 6e 67 74 68 20 61 63 74 69 6f 6e 2d 6c (length action-l
7c00: 73 74 29 20 32 29 29 20 0a 09 20 20 20 20 20 20 st) 2)) ..
7c10: 28 65 72 72 3a 6c 6f 67 20 22 41 63 74 69 6f 6e (err:log "Action
7c20: 20 73 68 6f 75 6c 64 20 62 65 20 6f 66 20 66 6f should be of fo
7c30: 72 6d 3a 20 6d 6f 64 75 6c 65 2e 61 63 74 69 6f rm: module.actio
7c40: 6e 22 29 0a 09 20 20 20 20 20 20 28 6c 65 74 2a n").. (let*
7c50: 20 28 28 74 61 72 67 2d 70 61 67 65 20 20 20 28 ((targ-page (
7c60: 63 61 72 20 61 63 74 69 6f 6e 2d 6c 73 74 29 29 car action-lst))
7c70: 0a 09 09 20 20 20 20 20 28 70 72 6f 63 2d 6e 61 ... (proc-na
7c80: 6d 65 20 20 20 28 73 74 72 69 6e 67 2d 61 70 70 me (string-app
7c90: 65 6e 64 20 74 61 72 67 2d 70 61 67 65 20 22 2d end targ-page "-
7ca0: 61 63 74 69 6f 6e 22 29 29 0a 09 09 20 20 20 20 action"))...
7cb0: 20 28 74 61 72 67 2d 61 63 74 69 6f 6e 20 28 63 (targ-action (c
7cc0: 61 64 72 20 61 63 74 69 6f 6e 2d 6c 73 74 29 29 adr action-lst))
7cd0: 29 0a 09 09 3b 3b 20 28 65 72 72 3a 6c 6f 67 20 )...;; (err:log
7ce0: 22 74 61 72 67 2d 70 61 67 65 3d 22 20 74 61 72 "targ-page=" tar
7cf0: 67 2d 70 61 67 65 20 22 20 70 72 6f 63 2d 6e 61 g-page " proc-na
7d00: 6d 65 3d 22 20 70 72 6f 63 2d 6e 61 6d 65 20 22 me=" proc-name "
7d10: 20 74 61 72 67 2d 61 63 74 69 6f 6e 3d 22 20 74 targ-action=" t
7d20: 61 72 67 2d 61 63 74 69 6f 6e 29 0a 0a 09 09 3b arg-action)....;
7d30: 3b 20 63 61 6c 6c 20 68 65 72 65 20 6f 6e 6c 79 ; call here only
7d40: 20 69 66 20 6e 65 76 65 72 20 63 61 6c 6c 65 64 if never called
7d50: 20 62 65 66 6f 72 65 0a 09 09 28 69 66 20 28 73 before...(if (s
7d60: 65 73 73 69 6f 6e 3a 6e 65 76 65 72 2d 63 61 6c ession:never-cal
7d70: 6c 65 64 2d 70 61 67 65 3f 20 73 65 6c 66 20 74 led-page? self t
7d80: 61 72 67 2d 70 61 67 65 29 0a 09 09 20 20 20 20 arg-page)...
7d90: 28 73 65 73 73 69 6f 6e 3a 63 61 6c 6c 2d 70 61 (session:call-pa
7da0: 72 74 73 20 73 65 6c 66 20 74 61 72 67 2d 70 61 rts self targ-pa
7db0: 67 65 20 27 63 6f 6e 74 72 6f 6c 29 29 0a 09 09 ge 'control))...
7dc0: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
7dd0: 20 20 20 20 20 20 70 72 6f 63 20 20 20 20 20 20 proc
7de0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7df0: 20 20 20 61 63 74 69 6f 6e 20 20 20 20 0a 0a 09 action ...
7e00: 09 28 69 66 20 23 74 20 3b 3b 20 73 65 74 20 74 .(if #t ;; set t
7e10: 6f 20 23 74 20 74 6f 20 73 65 65 20 62 65 74 74 o #t to see bett
7e20: 65 72 20 65 72 72 6f 72 20 6d 65 73 73 61 67 65 er error message
7e30: 73 20 64 75 72 69 6e 67 20 64 65 62 75 67 67 69 s during debuggi
7e40: 6e 20 3a 2d 29 0a 09 09 20 20 20 20 28 28 65 76 n :-)... ((ev
7e50: 61 6c 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 al (string->symb
7e60: 6f 6c 20 70 72 6f 63 2d 6e 61 6d 65 29 29 20 74 ol proc-name)) t
7e70: 61 72 67 2d 61 63 74 69 6f 6e 29 20 3b 3b 20 75 arg-action) ;; u
7e80: 6e 73 61 66 65 20 65 78 65 63 75 74 69 6f 6e 0a nsafe execution.
7e90: 09 09 20 20 20 20 28 63 6f 6e 64 69 74 69 6f 6e .. (condition
7ea0: 2d 63 61 73 65 20 28 28 65 76 61 6c 20 28 73 74 -case ((eval (st
7eb0: 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 70 72 6f ring->symbol pro
7ec0: 63 2d 6e 61 6d 65 29 29 20 74 61 72 67 2d 61 63 c-name)) targ-ac
7ed0: 74 69 6f 6e 29 0a 09 09 09 09 20 20 20 20 28 28 tion)..... ((
7ee0: 65 78 6e 20 66 69 6c 65 29 20 28 73 3a 6c 6f 67 exn file) (s:log
7ef0: 20 22 66 69 6c 65 20 65 72 72 6f 72 22 29 29 0a "file error")).
7f00: 09 09 09 09 20 20 20 20 28 28 65 78 6e 20 69 2f .... ((exn i/
7f10: 6f 29 20 20 28 73 3a 6c 6f 67 20 22 69 2f 6f 20 o) (s:log "i/o
7f20: 65 72 72 6f 72 22 29 29 0a 09 09 09 09 20 20 20 error")).....
7f30: 20 28 28 65 78 6e 20 29 20 20 20 20 20 28 73 3a ((exn ) (s:
7f40: 6c 6f 67 20 22 41 63 74 69 6f 6e 20 6e 6f 74 20 log "Action not
7f50: 69 6d 70 6c 65 6d 65 6e 74 65 64 3a 20 22 20 70 implemented: " p
7f60: 72 6f 63 2d 6e 61 6d 65 20 22 20 61 63 74 69 6f roc-name " actio
7f70: 6e 3a 20 22 20 74 61 72 67 2d 61 63 74 69 6f 6e n: " targ-action
7f80: 29 29 0a 09 09 09 09 20 20 20 20 28 76 61 72 20 ))..... (var
7f90: 28 29 20 20 20 20 20 28 73 3a 6c 6f 67 20 22 55 () (s:log "U
7fa0: 6e 6b 6e 6f 77 6e 20 45 72 72 6f 72 22 29 29 29 nknown Error")))
7fb0: 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 )))))))..(define
7fc0: 20 28 73 65 73 73 69 6f 6e 3a 6e 65 76 65 72 2d (session:never-
7fd0: 63 61 6c 6c 65 64 2d 70 61 67 65 3f 20 73 65 6c called-page? sel
7fe0: 66 20 70 61 67 65 29 0a 20 20 28 73 65 73 73 69 f page). (sessi
7ff0: 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 43 68 65 on:log self "Che
8000: 63 6b 69 6e 67 20 66 6f 72 20 70 61 67 65 3a 20 cking for page:
8010: 22 20 70 61 67 65 29 0a 20 20 28 6e 6f 74 20 28 " page). (not (
8020: 6d 65 6d 62 65 72 20 70 61 67 65 20 28 73 65 73 member page (ses
8030: 73 69 6f 6e 3a 73 64 61 74 2d 67 65 74 2d 73 65 sion:sdat-get-se
8040: 65 6e 2d 70 61 67 65 73 20 73 65 6c 66 29 29 29 en-pages self)))
8050: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 )..(define (sess
8060: 69 6f 6e 3a 73 65 74 2d 63 61 6c 6c 65 64 21 20 ion:set-called!
8070: 73 65 6c 66 20 70 61 67 65 29 0a 20 20 28 73 65 self page). (se
8080: 73 73 69 6f 6e 3a 73 64 61 74 2d 73 65 74 2d 73 ssion:sdat-set-s
8090: 65 65 6e 2d 70 61 67 65 73 21 20 73 65 6c 66 20 een-pages! self
80a0: 28 63 6f 6e 73 20 70 61 67 65 20 28 73 65 73 73 (cons page (sess
80b0: 69 6f 6e 3a 73 64 61 74 2d 67 65 74 2d 73 65 65 ion:sdat-get-see
80c0: 6e 2d 70 61 67 65 73 20 73 65 6c 66 29 29 29 29 n-pages self))))
80d0: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
80e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
80f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8100: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8110: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 41 6c ==========.;; Al
8120: 74 65 72 6e 61 74 69 76 65 20 64 61 74 61 20 74 ternative data t
8130: 79 70 65 20 64 65 6c 69 76 65 72 79 0a 3b 3b 3d ype delivery.;;=
8140: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8150: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8160: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8170: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8180: 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 =====..(define (
8190: 73 65 73 73 69 6f 6e 3a 61 6c 74 2d 6f 75 74 20 session:alt-out
81a0: 73 65 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 64 self). (let ((d
81b0: 61 74 20 28 73 65 73 73 69 6f 6e 3a 73 64 61 74 at (session:sdat
81c0: 2d 67 65 74 2d 61 6c 74 2d 70 61 67 65 2d 64 61 -get-alt-page-da
81d0: 74 20 73 65 6c 66 29 29 29 0a 20 20 20 20 3b 3b t self))). ;;
81e0: 20 28 73 3a 6c 6f 67 20 22 64 61 74 20 69 73 3a (s:log "dat is:
81f0: 20 22 20 64 61 74 29 0a 20 20 20 20 3b 3b 20 28 " dat). ;; (
8200: 70 72 69 6e 74 20 22 48 54 54 50 2f 31 2e 31 20 print "HTTP/1.1
8210: 32 30 30 20 4f 4b 22 29 0a 20 20 20 20 28 70 72 200 OK"). (pr
8220: 69 6e 74 20 22 44 61 74 65 3a 20 22 20 28 74 69 int "Date: " (ti
8230: 6d 65 2d 3e 73 74 72 69 6e 67 20 28 73 65 63 6f me->string (seco
8240: 6e 64 73 2d 3e 75 74 63 2d 74 69 6d 65 20 28 63 nds->utc-time (c
8250: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 urrent-seconds))
8260: 29 29 0a 20 20 20 20 28 70 72 69 6e 74 20 22 43 )). (print "C
8270: 6f 6e 74 65 6e 74 2d 54 79 70 65 3a 20 22 20 28 ontent-Type: " (
8280: 73 65 73 73 69 6f 6e 3a 73 64 61 74 2d 67 65 74 session:sdat-get
8290: 2d 63 6f 6e 74 65 6e 74 2d 74 79 70 65 20 73 65 -content-type se
82a0: 6c 66 29 29 0a 20 20 20 20 28 70 72 69 6e 74 20 lf)). (print
82b0: 22 41 63 63 65 70 74 2d 52 61 6e 67 65 73 3a 20 "Accept-Ranges:
82c0: 62 79 74 65 73 22 29 0a 20 20 20 20 28 70 72 69 bytes"). (pri
82d0: 6e 74 20 22 43 6f 6e 74 65 6e 74 2d 4c 65 6e 67 nt "Content-Leng
82e0: 74 68 3a 20 22 20 28 69 66 20 28 62 6c 6f 62 3f th: " (if (blob?
82f0: 20 64 61 74 29 0a 09 09 09 09 20 20 28 62 6c 6f dat)..... (blo
8300: 62 2d 73 69 7a 65 20 64 61 74 29 0a 09 09 09 09 b-size dat).....
8310: 20 20 30 29 29 0a 20 20 20 20 28 70 72 69 6e 74 0)). (print
8320: 20 22 4b 65 65 70 2d 41 6c 69 76 65 3a 20 74 69 "Keep-Alive: ti
8330: 6d 65 6f 75 74 3d 31 35 2c 20 6d 61 78 3d 31 30 meout=15, max=10
8340: 30 22 29 0a 20 20 20 20 28 70 72 69 6e 74 20 22 0"). (print "
8350: 43 6f 6e 6e 65 63 74 69 6f 6e 3a 20 4b 65 65 70 Connection: Keep
8360: 2d 41 6c 69 76 65 22 29 0a 20 20 20 20 28 70 72 -Alive"). (pr
8370: 69 6e 74 20 22 22 29 0a 20 20 20 20 28 77 72 69 int ""). (wri
8380: 74 65 2d 73 74 72 69 6e 67 20 28 62 6c 6f 62 2d te-string (blob-
8390: 3e 73 74 72 69 6e 67 20 64 61 74 29 20 23 66 20 >string dat) #f
83a0: 28 63 75 72 72 65 6e 74 2d 6f 75 74 70 75 74 2d (current-output-
83b0: 70 6f 72 74 29 29 29 29 0a port)))).