Artifact
4f8d6422abd61b4d9ba47942ac2094463b1bb2e2:
0000: 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 30 ;; Copyright 200
0010: 37 2d 32 30 31 31 2c 20 4d 61 74 74 68 65 77 20 7-2011, Matthew
0020: 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b 20 Welland..;; .;;
0030: 20 54 68 69 73 20 70 72 6f 67 72 61 6d 20 69 73 This program is
0040: 20 6d 61 64 65 20 61 76 61 69 6c 61 62 6c 65 20 made available
0050: 75 6e 64 65 72 20 74 68 65 20 47 4e 55 20 47 50 under the GNU GP
0060: 4c 20 76 65 72 73 69 6f 6e 20 32 2e 30 20 6f 72 L version 2.0 or
0070: 0a 3b 3b 20 20 67 72 65 61 74 65 72 2e 20 53 65 .;; greater. Se
0080: 65 20 74 68 65 20 61 63 63 6f 6d 70 61 6e 79 69 e the accompanyi
0090: 6e 67 20 66 69 6c 65 20 43 4f 50 59 49 4e 47 20 ng file COPYING
00a0: 66 6f 72 20 64 65 74 61 69 6c 73 2e 0a 3b 3b 20 for details..;;
00b0: 0a 3b 3b 20 20 54 68 69 73 20 70 72 6f 67 72 61 .;; This progra
00c0: 6d 20 69 73 20 64 69 73 74 72 69 62 75 74 65 64 m is distributed
00d0: 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 52 WITHOUT ANY WAR
00e0: 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 65 RANTY; without e
00f0: 76 65 6e 20 74 68 65 0a 3b 3b 20 20 69 6d 70 6c ven the.;; impl
0100: 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 20 ied warranty of
0110: 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 20 MERCHANTABILITY
0120: 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 41 or FITNESS FOR A
0130: 20 50 41 52 54 49 43 55 4c 41 52 0a 3b 3b 20 20 PARTICULAR.;;
0140: 50 55 52 50 4f 53 45 2e 0a 0a 28 64 65 63 6c 61 PURPOSE...(decla
0150: 72 65 20 28 75 6e 69 74 20 73 65 73 73 69 6f 6e re (unit session
0160: 29 29 0a 28 72 65 71 75 69 72 65 2d 6c 69 62 72 )).(require-libr
0170: 61 72 79 20 64 62 69 29 0a 28 72 65 71 75 69 72 ary dbi).(requir
0180: 65 2d 65 78 74 65 6e 73 69 6f 6e 20 72 65 67 65 e-extension rege
0190: 78 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 x).(declare (use
01a0: 73 20 63 6f 6f 6b 69 65 29 29 0a 0a 3b 3b 20 73 s cookie))..;; s
01b0: 65 73 73 69 6f 6e 73 20 74 61 62 6c 65 0a 3b 3b essions table.;;
01c0: 20 69 64 20 73 65 73 73 69 6f 6e 5f 69 64 20 73 id session_id s
01d0: 65 73 73 69 6f 6e 5f 6b 65 79 0a 3b 3b 20 63 72 ession_key.;; cr
01e0: 65 61 74 65 20 74 61 62 6c 65 20 73 65 73 73 69 eate table sessi
01f0: 6f 6e 73 20 28 69 64 20 73 65 72 69 61 6c 20 6e ons (id serial n
0200: 6f 74 20 6e 75 6c 6c 2c 73 65 73 73 69 6f 6e 2d ot null,session-
0210: 6b 65 79 20 74 65 78 74 29 3b 0a 0a 3b 3b 20 73 key text);..;; s
0220: 65 73 73 69 6f 6e 5f 76 61 72 73 20 74 61 62 6c ession_vars tabl
0230: 65 0a 3b 3b 20 69 64 20 73 65 73 73 69 6f 6e 5f e.;; id session_
0240: 69 64 20 70 61 67 65 5f 69 64 20 6b 65 79 20 76 id page_id key v
0250: 61 6c 75 65 0a 3b 3b 20 63 72 65 61 74 65 20 74 alue.;; create t
0260: 61 62 6c 65 20 73 65 73 73 69 6f 6e 5f 76 61 72 able session_var
0270: 73 20 28 69 64 20 73 65 72 69 61 6c 20 6e 6f 74 s (id serial not
0280: 20 6e 75 6c 6c 2c 73 65 73 73 69 6f 6e 5f 69 64 null,session_id
0290: 20 69 6e 74 65 67 65 72 2c 70 61 67 65 20 74 65 integer,page te
02a0: 78 74 2c 6b 65 79 20 74 65 78 74 2c 76 61 6c 75 xt,key text,valu
02b0: 65 20 74 65 78 74 29 3b 0a 0a 3b 3b 20 54 4f 44 e text);..;; TOD
02c0: 4f 0a 3b 3b 20 20 43 6f 6e 63 65 70 74 20 6f 66 O.;; Concept of
02d0: 20 6f 72 64 65 72 20 6e 75 6d 20 69 6e 63 72 65 order num incre
02e0: 6d 65 6e 74 65 64 20 77 69 74 68 20 65 61 63 68 mented with each
02f0: 20 70 61 67 65 20 61 63 63 65 73 73 0a 3b 3b 20 page access.;;
0300: 20 20 20 20 69 66 20 61 20 62 72 61 6e 63 68 20 if a branch
0310: 69 73 20 74 61 6b 65 6e 20 74 68 65 6e 20 61 20 is taken then a
0320: 6e 65 77 20 73 65 73 73 69 6f 6e 20 77 6f 75 6c new session woul
0330: 64 20 6e 65 65 64 20 74 6f 20 62 65 20 63 72 65 d need to be cre
0340: 61 74 65 64 0a 3b 3b 0a 0a 3b 3b 20 6d 61 6b 65 ated.;;..;; make
0350: 2d 76 65 63 74 6f 72 2d 72 65 63 6f 72 64 20 73 -vector-record s
0360: 65 73 73 69 6f 6e 20 73 65 73 73 69 6f 6e 20 64 ession session d
0370: 62 74 79 70 65 20 64 62 69 6e 69 74 20 63 6f 6e btype dbinit con
0380: 6e 20 70 61 72 61 6d 73 20 70 61 74 68 2d 70 61 n params path-pa
0390: 72 61 6d 73 20 73 65 73 73 69 6f 6e 2d 6b 65 79 rams session-key
03a0: 20 73 65 73 73 69 6f 6e 2d 69 64 20 64 6f 6d 61 session-id doma
03b0: 69 6e 20 74 6f 70 70 61 67 65 20 70 61 67 65 20 in toppage page
03c0: 63 75 72 72 2d 70 61 67 65 20 63 6f 6e 74 65 6e curr-page conten
03d0: 74 2d 74 79 70 65 20 70 61 67 65 2d 74 79 70 65 t-type page-type
03e0: 20 73 72 6f 6f 74 20 74 77 69 6b 69 64 69 72 20 sroot twikidir
03f0: 70 61 67 65 64 61 74 20 61 6c 74 2d 70 61 67 65 pagedat alt-page
0400: 2d 64 61 74 20 70 61 67 65 76 61 72 73 20 70 61 -dat pagevars pa
0410: 67 65 76 61 72 73 2d 62 65 66 6f 72 65 20 73 65 gevars-before se
0420: 73 73 69 6f 6e 76 61 72 73 20 73 65 73 73 69 6f ssionvars sessio
0430: 6e 76 61 72 73 2d 62 65 66 6f 72 65 20 67 6c 6f nvars-before glo
0440: 62 61 6c 76 61 72 73 20 67 6c 6f 62 61 6c 76 61 balvars globalva
0450: 72 73 2d 62 65 66 6f 72 65 20 6c 6f 67 70 74 20 rs-before logpt
0460: 66 6f 72 6d 64 61 74 20 72 65 71 75 65 73 74 2d formdat request-
0470: 6d 65 74 68 6f 64 20 73 65 73 73 69 6f 6e 2d 63 method session-c
0480: 6f 6f 6b 69 65 20 63 75 72 72 2d 65 72 72 20 6c ookie curr-err l
0490: 6f 67 2d 70 6f 72 74 20 6c 6f 67 66 69 6c 65 20 og-port logfile
04a0: 73 65 65 6e 2d 70 61 67 65 73 20 70 61 67 65 2d seen-pages page-
04b0: 64 69 72 2d 73 74 79 6c 65 20 64 65 62 75 67 6d dir-style debugm
04c0: 6f 64 65 0a 28 64 65 66 69 6e 65 20 28 6d 61 6b ode.(define (mak
04d0: 65 2d 73 64 61 74 29 28 6d 61 6b 65 2d 76 65 63 e-sdat)(make-vec
04e0: 74 6f 72 20 33 34 29 29 0a 28 64 65 66 69 6e 65 tor 34)).(define
04f0: 20 28 73 64 61 74 2d 67 65 74 2d 64 62 74 79 70 (sdat-get-dbtyp
0500: 65 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 e
0510: 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d vec) (vector-
0520: 72 65 66 20 20 76 65 63 20 30 29 29 0a 28 64 65 ref vec 0)).(de
0530: 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 64 fine (sdat-get-d
0540: 62 69 6e 69 74 20 20 20 20 20 20 20 20 20 20 20 binit
0550: 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 vec) (vec
0560: 74 6f 72 2d 72 65 66 20 20 76 65 63 20 31 29 29 tor-ref vec 1))
0570: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 .(define (sdat-g
0580: 65 74 2d 63 6f 6e 6e 20 20 20 20 20 20 20 20 20 et-conn
0590: 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 vec)
05a0: 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 (vector-ref vec
05b0: 20 32 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 2)).(define (sd
05c0: 61 74 2d 67 65 74 2d 70 67 63 6f 6e 6e 20 20 20 at-get-pgconn
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: 28 76 65 63 74 6f 72 2d 72 65 66 20 76 65 63 20 (vector-ref vec
0600: 32 29 20 31 29 29 0a 28 64 65 66 69 6e 65 20 28 2) 1)).(define (
0610: 73 64 61 74 2d 67 65 74 2d 70 61 72 61 6d 73 20 sdat-get-params
0620: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 ve
0630: 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 c) (vector-re
0640: 66 20 20 76 65 63 20 33 29 29 0a 28 64 65 66 69 f vec 3)).(defi
0650: 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 70 61 74 ne (sdat-get-pat
0660: 68 2d 70 61 72 61 6d 73 20 20 20 20 20 20 20 20 h-params
0670: 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f vec) (vecto
0680: 72 2d 72 65 66 20 20 76 65 63 20 34 29 29 0a 28 r-ref vec 4)).(
0690: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 define (sdat-get
06a0: 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 20 20 20 -session-key
06b0: 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 vec) (v
06c0: 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 35 ector-ref vec 5
06d0: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
06e0: 2d 67 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 -get-session-id
06f0: 20 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 vec)
0700: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 (vector-ref v
0710: 65 63 20 36 29 29 0a 28 64 65 66 69 6e 65 20 28 ec 6)).(define (
0720: 73 64 61 74 2d 67 65 74 2d 64 6f 6d 61 69 6e 20 sdat-get-domain
0730: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 ve
0740: 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 c) (vector-re
0750: 66 20 20 76 65 63 20 37 29 29 0a 28 64 65 66 69 f vec 7)).(defi
0760: 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 74 6f 70 ne (sdat-get-top
0770: 70 61 67 65 20 20 20 20 20 20 20 20 20 20 20 20 page
0780: 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f vec) (vecto
0790: 72 2d 72 65 66 20 20 76 65 63 20 38 29 29 0a 28 r-ref vec 8)).(
07a0: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 define (sdat-get
07b0: 2d 70 61 67 65 20 20 20 20 20 20 20 20 20 20 20 -page
07c0: 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 vec) (v
07d0: 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 39 ector-ref vec 9
07e0: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
07f0: 2d 67 65 74 2d 63 75 72 72 2d 70 61 67 65 20 20 -get-curr-page
0800: 20 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 vec)
0810: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 (vector-ref v
0820: 65 63 20 31 30 29 29 0a 28 64 65 66 69 6e 65 20 ec 10)).(define
0830: 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 74 65 6e (sdat-get-conten
0840: 74 2d 74 79 70 65 20 20 20 20 20 20 20 20 20 76 t-type v
0850: 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 ec) (vector-r
0860: 65 66 20 20 76 65 63 20 31 31 29 29 0a 28 64 65 ef vec 11)).(de
0870: 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 70 fine (sdat-get-p
0880: 61 67 65 2d 74 79 70 65 20 20 20 20 20 20 20 20 age-type
0890: 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 vec) (vec
08a0: 74 6f 72 2d 72 65 66 20 20 76 65 63 20 31 32 29 tor-ref vec 12)
08b0: 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d ).(define (sdat-
08c0: 67 65 74 2d 73 72 6f 6f 74 20 20 20 20 20 20 20 get-sroot
08d0: 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 vec)
08e0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 (vector-ref ve
08f0: 63 20 31 33 29 29 0a 28 64 65 66 69 6e 65 20 28 c 13)).(define (
0900: 73 64 61 74 2d 67 65 74 2d 74 77 69 6b 69 64 69 sdat-get-twikidi
0910: 72 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 r ve
0920: 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 c) (vector-re
0930: 66 20 20 76 65 63 20 31 34 29 29 0a 28 64 65 66 f vec 14)).(def
0940: 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 70 61 ine (sdat-get-pa
0950: 67 65 64 61 74 20 20 20 20 20 20 20 20 20 20 20 gedat
0960: 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 vec) (vect
0970: 6f 72 2d 72 65 66 20 20 76 65 63 20 31 35 29 29 or-ref vec 15))
0980: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 .(define (sdat-g
0990: 65 74 2d 61 6c 74 2d 70 61 67 65 2d 64 61 74 20 et-alt-page-dat
09a0: 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 vec)
09b0: 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 (vector-ref vec
09c0: 20 31 36 29 29 0a 28 64 65 66 69 6e 65 20 28 73 16)).(define (s
09d0: 64 61 74 2d 67 65 74 2d 70 61 67 65 76 61 72 73 dat-get-pagevars
09e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 vec
09f0: 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 ) (vector-ref
0a00: 20 20 76 65 63 20 31 37 29 29 0a 28 64 65 66 69 vec 17)).(defi
0a10: 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 ne (sdat-get-pag
0a20: 65 76 61 72 73 2d 62 65 66 6f 72 65 20 20 20 20 evars-before
0a30: 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f vec) (vecto
0a40: 72 2d 72 65 66 20 20 76 65 63 20 31 38 29 29 0a r-ref vec 18)).
0a50: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 (define (sdat-ge
0a60: 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 20 20 20 t-sessionvars
0a70: 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 vec) (
0a80: 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 vector-ref vec
0a90: 31 39 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 19)).(define (sd
0aa0: 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 at-get-sessionva
0ab0: 72 73 2d 62 65 66 6f 72 65 20 20 20 76 65 63 29 rs-before vec)
0ac0: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
0ad0: 20 76 65 63 20 32 30 29 29 0a 28 64 65 66 69 6e vec 20)).(defin
0ae0: 65 20 28 73 64 61 74 2d 67 65 74 2d 67 6c 6f 62 e (sdat-get-glob
0af0: 61 6c 76 61 72 73 20 20 20 20 20 20 20 20 20 20 alvars
0b00: 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 vec) (vector
0b10: 2d 72 65 66 20 20 76 65 63 20 32 31 29 29 0a 28 -ref vec 21)).(
0b20: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 define (sdat-get
0b30: 2d 67 6c 6f 62 61 6c 76 61 72 73 2d 62 65 66 6f -globalvars-befo
0b40: 72 65 20 20 20 20 76 65 63 29 20 20 20 20 28 76 re vec) (v
0b50: 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 32 ector-ref vec 2
0b60: 32 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 2)).(define (sda
0b70: 74 2d 67 65 74 2d 6c 6f 67 70 74 20 20 20 20 20 t-get-logpt
0b80: 20 20 20 20 20 20 20 20 20 20 20 76 65 63 29 20 vec)
0b90: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 (vector-ref
0ba0: 76 65 63 20 32 33 29 29 0a 28 64 65 66 69 6e 65 vec 23)).(define
0bb0: 20 28 73 64 61 74 2d 67 65 74 2d 66 6f 72 6d 64 (sdat-get-formd
0bc0: 61 74 20 20 20 20 20 20 20 20 20 20 20 20 20 20 at
0bd0: 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d vec) (vector-
0be0: 72 65 66 20 20 76 65 63 20 32 34 29 29 0a 28 64 ref vec 24)).(d
0bf0: 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d efine (sdat-get-
0c00: 72 65 71 75 65 73 74 2d 6d 65 74 68 6f 64 20 20 request-method
0c10: 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 vec) (ve
0c20: 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 32 35 ctor-ref vec 25
0c30: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
0c40: 2d 67 65 74 2d 73 65 73 73 69 6f 6e 2d 63 6f 6f -get-session-coo
0c50: 6b 69 65 20 20 20 20 20 20 20 76 65 63 29 20 20 kie vec)
0c60: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 (vector-ref v
0c70: 65 63 20 32 36 29 29 0a 28 64 65 66 69 6e 65 20 ec 26)).(define
0c80: 28 73 64 61 74 2d 67 65 74 2d 63 75 72 72 2d 65 (sdat-get-curr-e
0c90: 72 72 20 20 20 20 20 20 20 20 20 20 20 20 20 76 rr v
0ca0: 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 ec) (vector-r
0cb0: 65 66 20 20 76 65 63 20 32 37 29 29 0a 28 64 65 ef vec 27)).(de
0cc0: 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 6c fine (sdat-get-l
0cd0: 6f 67 2d 70 6f 72 74 20 20 20 20 20 20 20 20 20 og-port
0ce0: 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 vec) (vec
0cf0: 74 6f 72 2d 72 65 66 20 20 76 65 63 20 32 38 29 tor-ref vec 28)
0d00: 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d ).(define (sdat-
0d10: 67 65 74 2d 6c 6f 67 66 69 6c 65 20 20 20 20 20 get-logfile
0d20: 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 vec)
0d30: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 (vector-ref ve
0d40: 63 20 32 39 29 29 0a 28 64 65 66 69 6e 65 20 28 c 29)).(define (
0d50: 73 64 61 74 2d 67 65 74 2d 73 65 65 6e 2d 70 61 sdat-get-seen-pa
0d60: 67 65 73 20 20 20 20 20 20 20 20 20 20 20 76 65 ges ve
0d70: 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 c) (vector-re
0d80: 66 20 20 76 65 63 20 33 30 29 29 0a 28 64 65 66 f vec 30)).(def
0d90: 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 70 61 ine (sdat-get-pa
0da0: 67 65 2d 64 69 72 2d 73 74 79 6c 65 20 20 20 20 ge-dir-style
0db0: 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 vec) (vect
0dc0: 6f 72 2d 72 65 66 20 20 76 65 63 20 33 31 29 29 or-ref vec 31))
0dd0: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 .(define (sdat-g
0de0: 65 74 2d 64 65 62 75 67 6d 6f 64 65 20 20 20 20 et-debugmode
0df0: 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 vec)
0e00: 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 (vector-ref vec
0e10: 20 33 32 29 29 0a 28 64 65 66 69 6e 65 20 28 73 32)).(define (s
0e20: 64 61 74 2d 67 65 74 2d 73 68 61 72 65 64 2d 68 dat-get-shared-h
0e30: 61 73 68 20 20 20 20 20 20 20 20 20 20 76 65 63 ash vec
0e40: 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 ) (vector-ref
0e50: 20 20 76 65 63 20 33 33 29 29 0a 0a 28 64 65 66 vec 33))..(def
0e60: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 ine (session:get
0e70: 2d 73 68 61 72 65 64 20 76 65 63 20 76 61 72 6e -shared vec varn
0e80: 61 6d 65 29 0a 20 20 28 68 61 73 68 2d 74 61 62 ame). (hash-tab
0e90: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 28 le-ref/default (
0ea0: 76 65 63 74 6f 72 2d 72 65 66 20 76 65 63 20 33 vector-ref vec 3
0eb0: 33 29 20 76 61 72 6e 61 6d 65 20 23 66 29 29 0a 3) varname #f)).
0ec0: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 .(define (sdat-s
0ed0: 65 74 2d 64 62 74 79 70 65 21 20 20 20 20 20 20 et-dbtype!
0ee0: 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 vec val)
0ef0: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 (vector-set! vec
0f00: 20 30 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 0 val)).(define
0f10: 20 28 73 64 61 74 2d 73 65 74 2d 64 62 69 6e 69 (sdat-set-dbini
0f20: 74 21 20 20 20 20 20 20 20 20 20 20 20 20 20 20 t!
0f30: 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d vec val)(vector-
0f40: 73 65 74 21 20 76 65 63 20 31 20 76 61 6c 29 29 set! vec 1 val))
0f50: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 .(define (sdat-s
0f60: 65 74 2d 63 6f 6e 6e 21 20 20 20 20 20 20 20 20 et-conn!
0f70: 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 vec val)
0f80: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 (vector-set! vec
0f90: 20 32 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 2 val)).(define
0fa0: 20 28 73 64 61 74 2d 73 65 74 2d 70 61 72 61 6d (sdat-set-param
0fb0: 73 21 20 20 20 20 20 20 20 20 20 20 20 20 20 20 s!
0fc0: 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d vec val)(vector-
0fd0: 73 65 74 21 20 76 65 63 20 33 20 76 61 6c 29 29 set! vec 3 val))
0fe0: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 .(define (sdat-s
0ff0: 65 74 2d 70 61 74 68 2d 70 61 72 61 6d 73 21 20 et-path-params!
1000: 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 vec val)
1010: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 (vector-set! vec
1020: 20 34 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 4 val)).(define
1030: 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 (sdat-set-sessi
1040: 6f 6e 2d 6b 65 79 21 20 20 20 20 20 20 20 20 20 on-key!
1050: 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d vec val)(vector-
1060: 73 65 74 21 20 76 65 63 20 35 20 76 61 6c 29 29 set! vec 5 val))
1070: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 .(define (sdat-s
1080: 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 21 20 20 et-session-id!
1090: 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 vec val)
10a0: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 (vector-set! vec
10b0: 20 36 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 6 val)).(define
10c0: 20 28 73 64 61 74 2d 73 65 74 2d 64 6f 6d 61 69 (sdat-set-domai
10d0: 6e 21 20 20 20 20 20 20 20 20 20 20 20 20 20 20 n!
10e0: 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d vec val)(vector-
10f0: 73 65 74 21 20 76 65 63 20 37 20 76 61 6c 29 29 set! vec 7 val))
1100: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 .(define (sdat-s
1110: 65 74 2d 74 6f 70 70 61 67 65 21 20 20 20 20 20 et-toppage!
1120: 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 vec val)
1130: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 (vector-set! vec
1140: 20 38 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 8 val)).(define
1150: 20 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 21 (sdat-set-page!
1160: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1170: 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d vec val)(vector-
1180: 73 65 74 21 20 76 65 63 20 39 20 76 61 6c 29 29 set! vec 9 val))
1190: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 .(define (sdat-s
11a0: 65 74 2d 63 75 72 72 2d 70 61 67 65 21 20 20 20 et-curr-page!
11b0: 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 vec val)
11c0: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 (vector-set! vec
11d0: 20 31 30 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 10 val)).(defin
11e0: 65 20 28 73 64 61 74 2d 73 65 74 2d 63 6f 6e 74 e (sdat-set-cont
11f0: 65 6e 74 2d 74 79 70 65 21 20 20 20 20 20 20 20 ent-type!
1200: 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 vec val)(vector
1210: 2d 73 65 74 21 20 76 65 63 20 31 31 20 76 61 6c -set! vec 11 val
1220: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
1230: 2d 73 65 74 2d 70 61 67 65 2d 74 79 70 65 21 20 -set-page-type!
1240: 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 61 vec va
1250: 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 l)(vector-set! v
1260: 65 63 20 31 32 20 76 61 6c 29 29 0a 28 64 65 66 ec 12 val)).(def
1270: 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 73 72 ine (sdat-set-sr
1280: 6f 6f 74 21 20 20 20 20 20 20 20 20 20 20 20 20 oot!
1290: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
12a0: 6f 72 2d 73 65 74 21 20 76 65 63 20 31 33 20 76 or-set! vec 13 v
12b0: 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 al)).(define (sd
12c0: 61 74 2d 73 65 74 2d 74 77 69 6b 69 64 69 72 21 at-set-twikidir!
12d0: 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 20 vec
12e0: 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 val)(vector-set!
12f0: 20 76 65 63 20 31 34 20 76 61 6c 29 29 0a 28 64 vec 14 val)).(d
1300: 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d efine (sdat-set-
1310: 70 61 67 65 64 61 74 21 20 20 20 20 20 20 20 20 pagedat!
1320: 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 vec val)(ve
1330: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 31 35 ctor-set! vec 15
1340: 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 val)).(define (
1350: 73 64 61 74 2d 73 65 74 2d 61 6c 74 2d 70 61 67 sdat-set-alt-pag
1360: 65 2d 64 61 74 21 20 20 20 20 20 20 20 20 76 65 e-dat! ve
1370: 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 c val)(vector-se
1380: 74 21 20 76 65 63 20 31 36 20 76 61 6c 29 29 0a t! vec 16 val)).
1390: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 (define (sdat-se
13a0: 74 2d 70 61 67 65 76 61 72 73 21 20 20 20 20 20 t-pagevars!
13b0: 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 vec val)(
13c0: 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 vector-set! vec
13d0: 31 37 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 17 val)).(define
13e0: 20 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 76 (sdat-set-pagev
13f0: 61 72 73 2d 62 65 66 6f 72 65 21 20 20 20 20 20 ars-before!
1400: 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d vec val)(vector-
1410: 73 65 74 21 20 76 65 63 20 31 38 20 76 61 6c 29 set! vec 18 val)
1420: 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d ).(define (sdat-
1430: 73 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 21 set-sessionvars!
1440: 20 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c vec val
1450: 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 )(vector-set! ve
1460: 63 20 31 39 20 76 61 6c 29 29 0a 28 64 65 66 69 c 19 val)).(defi
1470: 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 ne (sdat-set-ses
1480: 73 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 21 sionvars-before!
1490: 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f vec val)(vecto
14a0: 72 2d 73 65 74 21 20 76 65 63 20 32 30 20 76 61 r-set! vec 20 va
14b0: 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 l)).(define (sda
14c0: 74 2d 73 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 t-set-globalvars
14d0: 21 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 ! vec v
14e0: 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 al)(vector-set!
14f0: 76 65 63 20 32 31 20 76 61 6c 29 29 0a 28 64 65 vec 21 val)).(de
1500: 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 67 fine (sdat-set-g
1510: 6c 6f 62 61 6c 76 61 72 73 2d 62 65 66 6f 72 65 lobalvars-before
1520: 21 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 ! vec val)(vec
1530: 74 6f 72 2d 73 65 74 21 20 76 65 63 20 32 32 20 tor-set! vec 22
1540: 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 val)).(define (s
1550: 64 61 74 2d 73 65 74 2d 6c 6f 67 70 74 21 20 20 dat-set-logpt!
1560: 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 vec
1570: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
1580: 21 20 76 65 63 20 32 33 20 76 61 6c 29 29 0a 28 ! vec 23 val)).(
1590: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 define (sdat-set
15a0: 2d 66 6f 72 6d 64 61 74 21 20 20 20 20 20 20 20 -formdat!
15b0: 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 vec val)(v
15c0: 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 32 ector-set! vec 2
15d0: 34 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 4 val)).(define
15e0: 28 73 64 61 74 2d 73 65 74 2d 72 65 71 75 65 73 (sdat-set-reques
15f0: 74 2d 6d 65 74 68 6f 64 21 20 20 20 20 20 20 76 t-method! v
1600: 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 ec val)(vector-s
1610: 65 74 21 20 76 65 63 20 32 35 20 76 61 6c 29 29 et! vec 25 val))
1620: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 .(define (sdat-s
1630: 65 74 2d 73 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 et-session-cooki
1640: 65 21 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 e! vec val)
1650: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 (vector-set! vec
1660: 20 32 36 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 26 val)).(defin
1670: 65 20 28 73 64 61 74 2d 73 65 74 2d 63 75 72 72 e (sdat-set-curr
1680: 2d 65 72 72 21 20 20 20 20 20 20 20 20 20 20 20 -err!
1690: 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 vec val)(vector
16a0: 2d 73 65 74 21 20 76 65 63 20 32 37 20 76 61 6c -set! vec 27 val
16b0: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
16c0: 2d 73 65 74 2d 6c 6f 67 2d 70 6f 72 74 21 20 20 -set-log-port!
16d0: 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 61 vec va
16e0: 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 l)(vector-set! v
16f0: 65 63 20 32 38 20 76 61 6c 29 29 0a 28 64 65 66 ec 28 val)).(def
1700: 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 6c 6f ine (sdat-set-lo
1710: 67 66 69 6c 65 21 20 20 20 20 20 20 20 20 20 20 gfile!
1720: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
1730: 6f 72 2d 73 65 74 21 20 76 65 63 20 32 39 20 76 or-set! vec 29 v
1740: 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 al)).(define (sd
1750: 61 74 2d 73 65 74 2d 73 65 65 6e 2d 70 61 67 65 at-set-seen-page
1760: 73 21 20 20 20 20 20 20 20 20 20 20 76 65 63 20 s! vec
1770: 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 val)(vector-set!
1780: 20 76 65 63 20 33 30 20 76 61 6c 29 29 0a 28 64 vec 30 val)).(d
1790: 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d efine (sdat-set-
17a0: 70 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 21 20 page-dir-style!
17b0: 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 vec val)(ve
17c0: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 33 31 ctor-set! vec 31
17d0: 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 val)).(define (
17e0: 73 64 61 74 2d 73 65 74 2d 64 65 62 75 67 6d 6f sdat-set-debugmo
17f0: 64 65 21 20 20 20 20 20 20 20 20 20 20 20 76 65 de! ve
1800: 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 c val)(vector-se
1810: 74 21 20 76 65 63 20 33 32 20 76 61 6c 29 29 0a t! vec 32 val)).
1820: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 (define (sdat-se
1830: 74 2d 73 68 61 72 65 64 2d 68 61 73 68 21 20 20 t-shared-hash!
1840: 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 vec val)(
1850: 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 vector-set! vec
1860: 33 33 20 76 61 6c 29 29 0a 0a 28 64 65 66 69 6e 33 val))..(defin
1870: 65 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 2d 73 e (session:set-s
1880: 68 61 72 65 64 21 20 76 65 63 20 76 61 72 6e 61 hared! vec varna
1890: 6d 65 20 76 61 6c 29 0a 20 20 28 68 61 73 68 2d me val). (hash-
18a0: 74 61 62 6c 65 2d 73 65 74 21 20 28 76 65 63 74 table-set! (vect
18b0: 6f 72 2d 72 65 66 20 76 65 63 20 33 33 29 20 76 or-ref vec 33) v
18c0: 61 72 6e 61 6d 65 20 76 61 6c 29 29 0a 0a 3b 3b arname val))..;;
18d0: 20 54 68 65 20 67 6c 6f 62 61 6c 20 73 65 73 73 The global sess
18e0: 69 6f 6e 0a 28 64 65 66 69 6e 65 20 73 3a 73 65 ion.(define s:se
18f0: 73 73 69 6f 6e 20 28 6d 61 6b 65 2d 73 64 61 74 ssion (make-sdat
1900: 29 29 0a 0a 3b 3b 20 53 50 4c 49 54 20 49 4e 54 ))..;; SPLIT INT
1910: 4f 20 53 54 52 41 49 47 48 54 20 46 4f 52 57 41 O STRAIGHT FORWA
1920: 52 44 20 49 4e 49 54 20 41 4e 44 20 43 4f 4d 50 RD INIT AND COMP
1930: 4c 45 58 20 49 4e 49 54 0a 28 64 65 66 69 6e 65 LEX INIT.(define
1940: 20 28 73 65 73 73 69 6f 6e 3a 69 6e 69 74 69 61 (session:initia
1950: 6c 69 7a 65 20 73 65 6c 66 29 0a 20 20 28 73 64 lize self). (sd
1960: 61 74 2d 73 65 74 2d 64 62 74 79 70 65 21 20 73 at-set-dbtype! s
1970: 65 6c 66 20 20 20 20 20 20 27 70 67 29 0a 20 20 elf 'pg).
1980: 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 21 20 (sdat-set-page!
1990: 73 65 6c 66 20 20 20 20 20 20 20 20 22 68 6f 6d self "hom
19a0: 65 22 29 20 20 20 20 20 20 20 20 3b 3b 20 74 68 e") ;; th
19b0: 65 73 65 20 61 72 65 20 64 65 66 61 75 6c 74 73 ese are defaults
19c0: 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 63 75 72 . (sdat-set-cur
19d0: 72 2d 70 61 67 65 21 20 73 65 6c 66 20 20 20 22 r-page! self "
19e0: 68 6f 6d 65 22 29 0a 20 20 28 73 64 61 74 2d 73 home"). (sdat-s
19f0: 65 74 2d 63 6f 6e 74 65 6e 74 2d 74 79 70 65 21 et-content-type!
1a00: 20 73 65 6c 66 20 22 43 6f 6e 74 65 6e 74 2d 74 self "Content-t
1a10: 79 70 65 3a 20 74 65 78 74 2f 68 74 6d 6c 3b 20 ype: text/html;
1a20: 63 68 61 72 73 65 74 3d 69 73 6f 2d 38 38 35 39 charset=iso-8859
1a30: 2d 31 5c 6e 5c 6e 22 29 0a 20 20 28 73 64 61 74 -1\n\n"). (sdat
1a40: 2d 73 65 74 2d 70 61 67 65 2d 74 79 70 65 21 20 -set-page-type!
1a50: 73 65 6c 66 20 20 20 27 68 74 6d 6c 29 0a 20 20 self 'html).
1a60: 28 73 64 61 74 2d 73 65 74 2d 74 6f 70 70 61 67 (sdat-set-toppag
1a70: 65 21 20 73 65 6c 66 20 20 20 20 20 22 69 6e 64 e! self "ind
1a80: 65 78 22 29 0a 20 20 28 73 64 61 74 2d 73 65 74 ex"). (sdat-set
1a90: 2d 70 61 72 61 6d 73 21 20 73 65 6c 66 20 20 20 -params! self
1aa0: 20 20 20 27 28 29 29 20 20 20 20 20 20 20 20 20 '())
1ab0: 20 20 3b 3b 0a 20 20 28 73 64 61 74 2d 73 65 74 ;;. (sdat-set
1ac0: 2d 70 61 74 68 2d 70 61 72 61 6d 73 21 20 73 65 -path-params! se
1ad0: 6c 66 20 27 28 29 29 0a 20 20 28 73 64 61 74 2d lf '()). (sdat-
1ae0: 73 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 21 set-session-key!
1af0: 20 73 65 6c 66 20 23 66 29 0a 20 20 28 73 64 61 self #f). (sda
1b00: 74 2d 73 65 74 2d 70 61 67 65 64 61 74 21 20 73 t-set-pagedat! s
1b10: 65 6c 66 20 20 20 20 20 27 28 29 29 0a 20 20 28 elf '()). (
1b20: 73 64 61 74 2d 73 65 74 2d 61 6c 74 2d 70 61 67 sdat-set-alt-pag
1b30: 65 2d 64 61 74 21 20 73 65 6c 66 20 23 66 29 0a e-dat! self #f).
1b40: 20 20 28 73 64 61 74 2d 73 65 74 2d 73 72 6f 6f (sdat-set-sroo
1b50: 74 21 20 73 65 6c 66 20 20 20 20 20 20 20 22 2e t! self ".
1b60: 2f 22 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d /"). (sdat-set-
1b70: 73 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 21 20 session-cookie!
1b80: 73 65 6c 66 20 23 66 29 0a 20 20 28 73 64 61 74 self #f). (sdat
1b90: 2d 73 65 74 2d 63 75 72 72 2d 65 72 72 21 20 73 -set-curr-err! s
1ba0: 65 6c 66 20 23 66 29 0a 20 20 28 73 64 61 74 2d elf #f). (sdat-
1bb0: 73 65 74 2d 6c 6f 67 2d 70 6f 72 74 21 20 73 65 set-log-port! se
1bc0: 6c 66 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f lf (current-erro
1bd0: 72 2d 70 6f 72 74 29 29 0a 20 20 28 73 64 61 74 r-port)). (sdat
1be0: 2d 73 65 74 2d 73 65 65 6e 2d 70 61 67 65 73 21 -set-seen-pages!
1bf0: 20 73 65 6c 66 20 27 28 29 29 0a 20 20 28 73 64 self '()). (sd
1c00: 61 74 2d 73 65 74 2d 70 61 67 65 2d 64 69 72 2d at-set-page-dir-
1c10: 73 74 79 6c 65 21 20 73 65 6c 66 20 23 74 29 20 style! self #t)
1c20: 3b 3b 20 23 74 20 3a 20 70 61 67 65 73 2f 3c 70 ;; #t : pages/<p
1c30: 61 67 65 6e 61 6d 65 3e 5f 28 76 69 65 77 7c 63 agename>_(view|c
1c40: 6e 74 6c 29 2e 73 63 6d 0a 20 20 20 20 20 20 20 ntl).scm.
1c50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1c60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
1c70: 3b 20 23 66 20 3a 20 70 61 67 65 73 2f 3c 70 61 ; #f : pages/<pa
1c80: 67 65 6e 61 6d 65 3e 2f 28 76 69 65 77 7c 63 6f gename>/(view|co
1c90: 6e 74 72 6f 6c 29 2e 73 63 6d 20 0a 20 20 28 73 ntrol).scm . (s
1ca0: 64 61 74 2d 73 65 74 2d 64 65 62 75 67 6d 6f 64 dat-set-debugmod
1cb0: 65 21 20 20 20 20 20 20 20 20 20 20 73 65 6c 66 e! self
1cc0: 20 23 66 29 0a 20 20 09 09 09 20 20 20 20 20 0a #f). ... .
1cd0: 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 (sdat-set-page
1ce0: 76 61 72 73 21 20 20 20 20 20 20 20 20 20 20 20 vars!
1cf0: 73 65 6c 66 20 28 6d 61 6b 65 2d 68 61 73 68 2d self (make-hash-
1d00: 74 61 62 6c 65 29 29 0a 20 20 28 73 64 61 74 2d table)). (sdat-
1d10: 73 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 21 set-sessionvars!
1d20: 20 20 20 20 20 20 20 20 73 65 6c 66 20 28 6d 61 self (ma
1d30: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
1d40: 20 20 28 73 64 61 74 2d 73 65 74 2d 67 6c 6f 62 (sdat-set-glob
1d50: 61 6c 76 61 72 73 21 20 20 20 20 20 20 20 20 20 alvars!
1d60: 73 65 6c 66 20 28 6d 61 6b 65 2d 68 61 73 68 2d self (make-hash-
1d70: 74 61 62 6c 65 29 29 0a 20 20 28 73 64 61 74 2d table)). (sdat-
1d80: 73 65 74 2d 70 61 67 65 76 61 72 73 2d 62 65 66 set-pagevars-bef
1d90: 6f 72 65 21 20 20 20 20 73 65 6c 66 20 28 6d 61 ore! self (ma
1da0: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
1db0: 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 (sdat-set-sess
1dc0: 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 21 20 ionvars-before!
1dd0: 73 65 6c 66 20 28 6d 61 6b 65 2d 68 61 73 68 2d self (make-hash-
1de0: 74 61 62 6c 65 29 29 0a 20 20 28 73 64 61 74 2d table)). (sdat-
1df0: 73 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 2d 62 set-globalvars-b
1e00: 65 66 6f 72 65 21 20 20 73 65 6c 66 20 28 6d 61 efore! self (ma
1e10: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
1e20: 20 20 28 73 64 61 74 2d 73 65 74 2d 64 6f 6d 61 (sdat-set-doma
1e30: 69 6e 21 20 20 20 20 20 20 20 20 20 20 20 20 20 in!
1e40: 73 65 6c 66 20 22 6c 6f 63 61 68 6f 73 74 22 29 self "locahost")
1e50: 20 20 20 3b 3b 20 65 6e 64 20 6f 66 20 64 65 66 ;; end of def
1e60: 61 75 6c 74 73 0a 20 20 28 6c 65 74 2a 20 28 28 aults. (let* ((
1e70: 72 61 77 63 6f 6e 66 69 67 64 61 74 20 28 73 65 rawconfigdat (se
1e80: 73 73 69 6f 6e 3a 72 65 61 64 2d 63 6f 6e 66 69 ssion:read-confi
1e90: 67 20 73 65 6c 66 29 29 0a 09 20 28 63 6f 6e 66 g self)).. (conf
1ea0: 69 67 64 61 74 20 28 69 66 20 72 61 77 63 6f 6e igdat (if rawcon
1eb0: 66 69 67 64 61 74 20 28 65 76 61 6c 20 72 61 77 figdat (eval raw
1ec0: 63 6f 6e 66 69 67 64 61 74 29 20 27 28 29 29 29 configdat) '()))
1ed0: 0a 09 20 28 73 72 6f 6f 74 20 20 20 20 20 28 73 .. (sroot (s
1ee0: 3a 66 69 6e 64 2d 70 61 72 61 6d 20 27 73 72 6f :find-param 'sro
1ef0: 6f 74 20 20 20 20 63 6f 6e 66 69 67 64 61 74 29 ot configdat)
1f00: 29 0a 09 20 28 6c 6f 67 66 69 6c 65 20 20 20 28 ).. (logfile (
1f10: 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 27 6c 6f s:find-param 'lo
1f20: 67 66 69 6c 65 20 20 63 6f 6e 66 69 67 64 61 74 gfile configdat
1f30: 29 29 0a 09 20 28 64 62 74 79 70 65 20 20 20 20 )).. (dbtype
1f40: 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 27 64 (s:find-param 'd
1f50: 62 74 79 70 65 20 20 20 63 6f 6e 66 69 67 64 61 btype configda
1f60: 74 29 29 0a 09 20 28 64 62 69 6e 69 74 20 20 20 t)).. (dbinit
1f70: 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 27 (s:find-param '
1f80: 64 62 69 6e 69 74 20 20 20 63 6f 6e 66 69 67 64 dbinit configd
1f90: 61 74 29 29 0a 09 20 28 64 6f 6d 61 69 6e 20 20 at)).. (domain
1fa0: 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 (s:find-param
1fb0: 27 64 6f 6d 61 69 6e 20 20 20 63 6f 6e 66 69 67 'domain config
1fc0: 64 61 74 29 29 0a 09 20 28 74 77 69 6b 69 64 69 dat)).. (twikidi
1fd0: 72 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d r (s:find-param
1fe0: 20 27 74 77 69 6b 69 64 69 72 20 63 6f 6e 66 69 'twikidir confi
1ff0: 67 64 61 74 29 29 0a 09 20 28 70 61 67 65 2d 64 gdat)).. (page-d
2000: 69 72 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 ir (s:find-para
2010: 6d 20 27 70 61 67 65 2d 64 69 72 2d 73 74 79 6c m 'page-dir-styl
2020: 65 20 63 6f 6e 66 69 67 64 61 74 29 29 0a 09 20 e configdat))..
2030: 28 64 65 62 75 67 6d 6f 64 65 20 28 73 3a 66 69 (debugmode (s:fi
2040: 6e 64 2d 70 61 72 61 6d 20 27 64 65 62 75 67 6d nd-param 'debugm
2050: 6f 64 65 20 63 6f 6e 66 69 67 64 61 74 29 29 29 ode configdat)))
2060: 0a 20 20 20 20 28 69 66 20 73 72 6f 6f 74 20 20 . (if sroot
2070: 20 20 28 73 64 61 74 2d 73 65 74 2d 73 72 6f 6f (sdat-set-sroo
2080: 74 21 20 20 20 20 73 65 6c 66 20 73 72 6f 6f 74 t! self sroot
2090: 29 29 0a 20 20 20 20 28 69 66 20 6c 6f 67 66 69 )). (if logfi
20a0: 6c 65 20 20 28 73 64 61 74 2d 73 65 74 2d 6c 6f le (sdat-set-lo
20b0: 67 66 69 6c 65 21 20 20 73 65 6c 66 20 6c 6f 67 gfile! self log
20c0: 66 69 6c 65 29 29 0a 20 20 20 20 28 69 66 20 64 file)). (if d
20d0: 62 74 79 70 65 20 20 20 28 73 64 61 74 2d 73 65 btype (sdat-se
20e0: 74 2d 64 62 74 79 70 65 21 20 20 20 73 65 6c 66 t-dbtype! self
20f0: 20 64 62 74 79 70 65 29 29 0a 20 20 20 20 28 69 dbtype)). (i
2100: 66 20 64 62 69 6e 69 74 20 20 20 28 73 64 61 74 f dbinit (sdat
2110: 2d 73 65 74 2d 64 62 69 6e 69 74 21 20 20 20 73 -set-dbinit! s
2120: 65 6c 66 20 64 62 69 6e 69 74 29 29 0a 20 20 20 elf dbinit)).
2130: 20 28 69 66 20 64 6f 6d 61 69 6e 20 20 20 28 73 (if domain (s
2140: 64 61 74 2d 73 65 74 2d 64 6f 6d 61 69 6e 21 20 dat-set-domain!
2150: 20 20 73 65 6c 66 20 64 6f 6d 61 69 6e 29 29 0a self domain)).
2160: 20 20 20 20 28 69 66 20 74 77 69 6b 69 64 69 72 (if twikidir
2170: 20 28 73 64 61 74 2d 73 65 74 2d 74 77 69 6b 69 (sdat-set-twiki
2180: 64 69 72 21 20 73 65 6c 66 20 74 77 69 6b 69 64 dir! self twikid
2190: 69 72 29 29 0a 20 20 20 20 28 69 66 20 64 65 62 ir)). (if deb
21a0: 75 67 6d 6f 64 65 20 28 73 64 61 74 2d 73 65 74 ugmode (sdat-set
21b0: 2d 64 65 62 75 67 6d 6f 64 65 21 20 73 65 6c 66 -debugmode! self
21c0: 20 64 65 62 75 67 6d 6f 64 65 29 29 0a 20 20 20 debugmode)).
21d0: 20 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 2d (sdat-set-page-
21e0: 64 69 72 2d 73 74 79 6c 65 21 20 73 65 6c 66 20 dir-style! self
21f0: 70 61 67 65 2d 64 69 72 29 0a 20 20 20 20 3b 3b page-dir). ;;
2200: 20 28 70 72 69 6e 74 20 22 63 6f 6e 66 69 67 64 (print "configd
2210: 61 74 3a 20 22 29 28 70 70 20 63 6f 6e 66 69 67 at: ")(pp config
2220: 64 61 74 29 0a 20 20 20 20 28 69 66 20 64 65 62 dat). (if deb
2230: 75 67 6d 6f 64 65 0a 09 28 73 65 73 73 69 6f 6e ugmode..(session
2240: 3a 6c 6f 67 20 73 65 6c 66 20 22 73 72 6f 6f 74 :log self "sroot
2250: 3a 20 22 20 73 72 6f 6f 74 20 22 20 6c 6f 67 66 : " sroot " logf
2260: 69 6c 65 3a 20 22 20 6c 6f 67 66 69 6c 65 20 22 ile: " logfile "
2270: 20 64 62 74 79 70 65 3a 20 22 20 64 62 74 79 70 dbtype: " dbtyp
2280: 65 20 0a 09 09 20 20 20 20 20 22 20 64 62 69 6e e ... " dbin
2290: 69 74 3a 20 22 20 64 62 69 6e 69 74 20 22 20 64 it: " dbinit " d
22a0: 6f 6d 61 69 6e 3a 20 22 20 64 6f 6d 61 69 6e 20 omain: " domain
22b0: 22 20 70 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 " page-dir-style
22c0: 3a 20 22 20 70 61 67 65 2d 64 69 72 29 29 0a 20 : " page-dir)).
22d0: 20 20 20 29 0a 20 20 28 73 64 61 74 2d 73 65 74 ). (sdat-set
22e0: 2d 73 68 61 72 65 64 2d 68 61 73 68 21 20 73 65 -shared-hash! se
22f0: 6c 66 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 lf (make-hash-ta
2300: 62 6c 65 29 29 0a 20 20 29 0a 0a 3b 3b 20 55 73 ble)). )..;; Us
2310: 65 64 20 66 6f 72 20 74 68 65 20 73 74 72 61 6e ed for the stran
2320: 67 65 6c 79 20 69 6e 63 6f 6e 73 69 73 74 65 6e gely inconsisten
2330: 74 20 68 61 6e 64 6c 69 6e 67 20 6f 66 20 74 68 t handling of th
2340: 65 20 63 6f 6e 66 69 67 20 66 69 6c 65 2e 20 41 e config file. A
2350: 20 62 65 74 74 65 72 20 77 61 79 20 69 73 20 6e better way is n
2360: 65 65 64 65 64 2e 0a 3b 3b 0a 3b 3b 20 20 20 28 eeded..;;.;; (
2370: 6c 65 74 20 28 28 64 62 74 79 70 65 20 28 73 64 let ((dbtype (sd
2380: 61 74 2d 67 65 74 2d 64 62 74 79 70 65 20 73 65 at-get-dbtype se
2390: 6c 66 29 29 29 0a 3b 3b 20 20 20 20 20 28 70 72 lf))).;; (pr
23a0: 69 6e 74 20 22 64 62 74 79 70 65 3a 20 22 20 64 int "dbtype: " d
23b0: 62 74 79 70 65 29 0a 3b 3b 20 20 20 20 20 28 73 btype).;; (s
23c0: 64 61 74 2d 73 65 74 2d 64 62 74 79 70 65 21 20 dat-set-dbtype!
23d0: 73 65 6c 66 20 28 65 76 61 6c 20 64 62 74 79 70 self (eval dbtyp
23e0: 65 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 e))))..(define (
23f0: 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 20 73 65 session:setup se
2400: 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 64 62 74 lf). (let ((dbt
2410: 79 70 65 20 20 20 20 28 73 64 61 74 2d 67 65 74 ype (sdat-get
2420: 2d 64 62 74 79 70 65 20 73 65 6c 66 29 29 0a 09 -dbtype self))..
2430: 28 64 65 62 75 67 6d 6f 64 65 20 28 73 64 61 74 (debugmode (sdat
2440: 2d 67 65 74 2d 64 65 62 75 67 6d 6f 64 65 20 73 -get-debugmode s
2450: 65 6c 66 29 29 0a 09 28 64 62 69 6e 69 74 20 20 elf))..(dbinit
2460: 20 20 28 65 76 61 6c 20 28 73 64 61 74 2d 67 65 (eval (sdat-ge
2470: 74 2d 64 62 69 6e 69 74 20 73 65 6c 66 29 29 29 t-dbinit self)))
2480: 0a 09 28 64 62 65 78 69 73 74 73 20 20 23 66 29 ..(dbexists #f)
2490: 29 0a 20 20 20 20 28 6c 65 74 20 28 28 64 62 66 ). (let ((dbf
24a0: 6e 61 6d 65 20 28 61 6c 69 73 74 2d 72 65 66 20 name (alist-ref
24b0: 27 64 62 6e 61 6d 65 20 64 62 69 6e 69 74 29 29 'dbname dbinit))
24c0: 29 0a 20 20 20 20 20 20 28 69 66 20 64 65 62 75 ). (if debu
24d0: 67 6d 6f 64 65 20 28 73 65 73 73 69 6f 6e 3a 6c gmode (session:l
24e0: 6f 67 20 73 65 6c 66 20 22 73 65 73 73 69 6f 6e og self "session
24f0: 3a 73 65 74 75 70 20 64 62 66 6e 61 6d 65 3d 22 :setup dbfname="
2500: 20 64 62 66 6e 61 6d 65 20 22 2c 20 64 62 74 79 dbfname ", dbty
2510: 70 65 3d 22 20 64 62 74 79 70 65 20 22 2c 20 64 pe=" dbtype ", d
2520: 62 69 6e 69 74 3d 22 20 64 62 69 6e 69 74 29 29 binit=" dbinit))
2530: 0a 20 20 20 20 20 20 28 69 66 20 28 65 71 3f 20 . (if (eq?
2540: 64 62 74 79 70 65 20 27 73 71 6c 69 74 65 33 29 dbtype 'sqlite3)
2550: 0a 09 20 20 3b 3b 20 54 68 65 20 27 61 75 74 6f .. ;; The 'auto
2560: 20 6d 65 74 68 6f 64 20 77 69 6c 6c 20 64 69 73 method will dis
2570: 74 72 69 62 75 74 65 20 64 62 73 20 61 63 72 6f tribute dbs acro
2580: 73 73 20 74 68 65 20 64 69 73 6b 20 75 73 69 6e ss the disk usin
2590: 67 20 68 61 73 68 0a 09 20 20 3b 3b 20 6f 66 20 g hash.. ;; of
25a0: 75 73 65 72 20 68 6f 73 74 20 61 6e 64 20 75 73 user host and us
25b0: 65 72 2e 20 54 4f 44 4f 0a 09 20 20 3b 3b 20 28 er. TODO.. ;; (
25c0: 69 66 20 28 65 71 3f 20 64 62 66 6e 61 6d 65 20 if (eq? dbfname
25d0: 27 61 75 74 6f 29 20 3b 3b 20 54 68 69 73 20 69 'auto) ;; This i
25e0: 73 20 74 68 65 20 61 75 74 6f 20 61 73 73 69 67 s the auto assig
25f0: 6e 6d 65 6e 74 20 6f 66 20 61 20 64 62 20 62 61 nment of a db ba
2600: 73 65 64 20 6f 6e 20 68 61 73 68 20 6f 66 20 49 sed on hash of I
2610: 50 0a 09 20 20 28 6c 65 74 20 28 28 64 62 70 61 P.. (let ((dbpa
2620: 74 68 20 28 70 61 74 68 6e 61 6d 65 2d 64 69 72 th (pathname-dir
2630: 65 63 74 6f 72 79 20 64 62 66 6e 61 6d 65 29 29 ectory dbfname))
2640: 29 20 20 3b 3b 20 64 6f 20 61 20 63 6f 75 70 6c ) ;; do a coupl
2650: 65 20 73 61 6e 69 74 79 20 63 68 65 63 6b 73 20 e sanity checks
2660: 68 65 72 65 20 74 6f 20 6d 61 6b 65 20 73 65 74 here to make set
2670: 74 69 6e 67 20 75 70 20 65 61 73 69 65 72 0a 09 ting up easier..
2680: 20 20 20 20 28 69 66 20 64 65 62 75 67 6d 6f 64 (if debugmod
2690: 65 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 e (session:log s
26a0: 65 6c 66 20 22 49 4e 46 4f 3a 20 73 65 74 74 69 elf "INFO: setti
26b0: 6e 67 20 75 70 20 66 6f 72 20 73 71 6c 69 74 65 ng up for sqlite
26c0: 33 20 64 62 20 61 63 63 65 73 73 20 74 6f 20 22 3 db access to "
26d0: 20 64 62 66 6e 61 6d 65 29 29 0a 09 20 20 20 20 dbfname))..
26e0: 28 69 66 20 28 6e 6f 74 20 28 66 69 6c 65 2d 77 (if (not (file-w
26f0: 72 69 74 65 2d 61 63 63 65 73 73 3f 20 64 62 70 rite-access? dbp
2700: 61 74 68 29 29 0a 09 09 28 73 65 73 73 69 6f 6e ath))...(session
2710: 3a 6c 6f 67 20 73 65 6c 66 20 22 57 41 52 4e 49 :log self "WARNI
2720: 4e 47 3a 20 43 61 6e 6e 6f 74 20 77 72 69 74 65 NG: Cannot write
2730: 20 74 6f 20 22 20 64 62 70 61 74 68 29 0a 09 09 to " dbpath)...
2740: 28 69 66 20 64 65 62 75 67 6d 6f 64 65 20 28 73 (if debugmode (s
2750: 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 ession:log self
2760: 22 49 4e 46 4f 3a 20 22 20 64 62 70 61 74 68 20 "INFO: " dbpath
2770: 22 20 69 73 20 77 72 69 74 65 61 62 6c 65 22 29 " is writeable")
2780: 29 29 0a 09 20 20 20 20 28 69 66 20 28 66 69 6c )).. (if (fil
2790: 65 2d 65 78 69 73 74 73 3f 20 64 62 66 6e 61 6d e-exists? dbfnam
27a0: 65 29 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 20 e)...(begin...
27b0: 3b 3b 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 ;; (session:log
27c0: 73 65 6c 66 20 22 73 65 74 74 69 6e 67 20 64 62 self "setting db
27d0: 65 78 69 73 74 73 20 74 6f 20 23 74 22 29 0a 09 exists to #t")..
27e0: 09 20 20 28 73 65 74 21 20 64 62 65 78 69 73 74 . (set! dbexist
27f0: 73 20 23 74 29 29 29 29 0a 09 20 20 28 69 66 20 s #t)))).. (if
2800: 64 65 62 75 67 6d 6f 64 65 20 28 73 65 73 73 69 debugmode (sessi
2810: 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 49 4e 46 on:log self "INF
2820: 4f 3a 20 73 65 74 74 69 6e 67 20 75 70 20 66 6f O: setting up fo
2830: 72 20 70 67 20 64 62 20 61 63 63 65 73 73 20 74 r pg db access t
2840: 6f 20 61 63 63 6f 75 6e 74 20 69 6e 66 6f 20 22 o account info "
2850: 20 64 62 69 6e 69 74 29 29 29 0a 20 20 20 20 20 dbinit))).
2860: 20 28 69 66 20 64 65 62 75 67 6d 6f 64 65 20 28 (if debugmode (
2870: 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 session:log self
2880: 20 22 64 62 74 79 70 65 3a 20 22 20 64 62 74 79 "dbtype: " dbty
2890: 70 65 20 22 20 64 62 66 6e 61 6d 65 3a 20 22 20 pe " dbfname: "
28a0: 64 62 66 6e 61 6d 65 20 22 20 64 62 65 78 69 73 dbfname " dbexis
28b0: 74 73 3a 20 22 20 64 62 65 78 69 73 74 73 29 29 ts: " dbexists))
28c0: 29 0a 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d ). (sdat-set-
28d0: 63 6f 6e 6e 21 20 73 65 6c 66 20 28 64 62 69 3a conn! self (dbi:
28e0: 6f 70 65 6e 20 64 62 74 79 70 65 20 64 62 69 6e open dbtype dbin
28f0: 69 74 29 29 0a 20 20 20 20 28 73 65 74 21 20 2a it)). (set! *
2900: 64 62 2a 20 28 73 64 61 74 2d 67 65 74 2d 63 6f db* (sdat-get-co
2910: 6e 6e 20 73 65 6c 66 29 29 0a 20 20 20 20 28 69 nn self)). (i
2920: 66 20 28 61 6e 64 20 28 6e 6f 74 20 64 62 65 78 f (and (not dbex
2930: 69 73 74 73 29 28 65 71 3f 20 64 62 74 79 70 65 ists)(eq? dbtype
2940: 20 27 73 71 6c 69 74 65 33 29 29 0a 20 09 28 62 'sqlite3)). .(b
2950: 65 67 69 6e 0a 09 20 20 28 70 72 69 6e 74 20 22 egin.. (print "
2960: 57 41 52 4e 49 4e 47 3a 20 53 65 74 74 69 6e 67 WARNING: Setting
2970: 20 75 70 20 73 65 73 73 69 6f 6e 20 64 62 20 77 up session db w
2980: 69 74 68 20 73 71 6c 69 74 65 33 22 29 0a 09 20 ith sqlite3")..
2990: 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 2d (session:setup-
29a0: 64 62 20 73 65 6c 66 29 29 29 0a 20 20 20 20 28 db self))). (
29b0: 73 65 73 73 69 6f 6e 3a 70 72 6f 63 65 73 73 2d session:process-
29c0: 75 72 6c 2d 70 61 74 68 20 73 65 6c 66 29 0a 20 url-path self).
29d0: 20 20 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 75 (session:setu
29e0: 70 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 p-session-key se
29f0: 6c 66 29 0a 20 20 20 20 3b 3b 20 63 61 70 74 75 lf). ;; captu
2a00: 72 65 20 73 74 64 69 6e 20 69 66 20 74 68 69 73 re stdin if this
2a10: 20 69 73 20 61 20 50 4f 53 54 0a 20 20 20 20 28 is a POST. (
2a20: 73 64 61 74 2d 73 65 74 2d 72 65 71 75 65 73 74 sdat-set-request
2a30: 2d 6d 65 74 68 6f 64 21 20 73 65 6c 66 20 28 67 -method! self (g
2a40: 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 et-environment-v
2a50: 61 72 69 61 62 6c 65 20 22 52 45 51 55 45 53 54 ariable "REQUEST
2a60: 5f 4d 45 54 48 4f 44 22 29 29 0a 20 20 20 20 28 _METHOD")). (
2a70: 73 64 61 74 2d 73 65 74 2d 66 6f 72 6d 64 61 74 sdat-set-formdat
2a80: 21 20 73 65 6c 66 20 28 66 6f 72 6d 64 61 74 3a ! self (formdat:
2a90: 6c 6f 61 64 2d 61 6c 6c 29 29 29 29 0a 0a 3b 3b load-all))))..;;
2aa0: 20 73 65 74 75 70 20 74 68 65 20 64 62 20 77 69 setup the db wi
2ab0: 74 68 20 73 65 73 73 69 6f 6e 20 74 61 62 6c 65 th session table
2ac0: 73 2c 20 77 6f 72 6b 73 20 66 6f 72 20 73 71 6c s, works for sql
2ad0: 69 74 65 20 6f 6e 6c 79 20 72 69 67 68 74 20 6e ite only right n
2ae0: 6f 77 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 ow.(define (sess
2af0: 69 6f 6e 3a 73 65 74 75 70 2d 64 62 20 73 65 6c ion:setup-db sel
2b00: 66 29 0a 20 20 28 6c 65 74 20 28 28 63 6f 6e 6e f). (let ((conn
2b10: 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 (sdat-get-conn
2b20: 73 65 6c 66 29 29 29 0a 20 20 20 20 28 66 6f 72 self))). (for
2b30: 2d 65 61 63 68 20 0a 20 20 20 20 20 28 6c 61 6d -each . (lam
2b40: 62 64 61 20 28 73 74 6d 74 29 0a 20 20 20 20 20 bda (stmt).
2b50: 20 20 28 64 62 69 3a 65 78 65 63 20 63 6f 6e 6e (dbi:exec conn
2b60: 20 73 74 6d 74 29 29 0a 20 20 20 20 20 28 6c 69 stmt)). (li
2b70: 73 74 20 22 43 52 45 41 54 45 20 54 41 42 4c 45 st "CREATE TABLE
2b80: 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 28 69 session_vars (i
2b90: 64 20 49 4e 54 45 47 45 52 20 50 52 49 4d 41 52 d INTEGER PRIMAR
2ba0: 59 20 4b 45 59 2c 73 65 73 73 69 6f 6e 5f 69 64 Y KEY,session_id
2bb0: 20 49 4e 54 45 47 45 52 2c 70 61 67 65 20 54 45 INTEGER,page TE
2bc0: 58 54 2c 6b 65 79 20 54 45 58 54 2c 76 61 6c 75 XT,key TEXT,valu
2bd0: 65 20 54 45 58 54 29 3b 22 0a 09 20 20 20 22 43 e TEXT);".. "C
2be0: 52 45 41 54 45 20 54 41 42 4c 45 20 73 65 73 73 REATE TABLE sess
2bf0: 69 6f 6e 73 20 28 69 64 20 49 4e 54 45 47 45 52 ions (id INTEGER
2c00: 20 50 52 49 4d 41 52 59 20 4b 45 59 2c 73 65 73 PRIMARY KEY,ses
2c10: 73 69 6f 6e 5f 6b 65 79 20 54 45 58 54 2c 6c 61 sion_key TEXT,la
2c20: 73 74 5f 75 73 65 64 20 54 49 4d 45 53 54 41 4d st_used TIMESTAM
2c30: 50 29 3b 22 0a 20 20 20 20 20 20 20 20 20 20 20 P);".
2c40: 22 43 52 45 41 54 45 20 54 41 42 4c 45 20 6d 65 "CREATE TABLE me
2c50: 74 61 64 61 74 61 20 28 69 64 20 49 4e 54 45 47 tadata (id INTEG
2c60: 45 52 20 50 52 49 4d 41 52 59 20 4b 45 59 2c 6b ER PRIMARY KEY,k
2c70: 65 79 20 54 45 58 54 2c 76 61 6c 75 65 20 54 45 ey TEXT,value TE
2c80: 58 54 29 3b 22 29 29 29 29 0a 3b 3b 20 20 3b 3b XT);")))).;; ;;
2c90: 20 69 66 20 77 65 20 68 61 76 65 20 61 20 73 65 if we have a se
2ca0: 73 73 69 6f 6e 5f 6b 65 79 20 6c 6f 6f 6b 20 75 ssion_key look u
2cb0: 70 20 74 68 65 20 73 65 73 73 69 6f 6e 2d 69 64 p the session-id
2cc0: 20 61 6e 64 20 73 74 6f 72 65 20 69 74 0a 3b 3b and store it.;;
2cd0: 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 (sdat-set-sess
2ce0: 69 6f 6e 2d 69 64 21 20 73 65 6c 66 20 28 73 65 ion-id! self (se
2cf0: 73 73 69 6f 6e 3a 67 65 74 2d 69 64 20 73 65 6c ssion:get-id sel
2d00: 66 29 29 29 0a 0a 3b 3b 20 6f 6e 6c 79 20 73 65 f)))..;; only se
2d10: 74 20 73 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 t session-cookie
2d20: 20 77 68 65 6e 20 61 20 6e 65 77 20 73 65 73 73 when a new sess
2d30: 69 6f 6e 20 69 73 20 63 72 65 61 74 65 64 0a 28 ion is created.(
2d40: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
2d50: 73 65 74 75 70 2d 73 65 73 73 69 6f 6e 2d 6b 65 setup-session-ke
2d60: 79 20 73 65 6c 66 29 20 20 0a 20 20 28 6c 65 74 y self) . (let
2d70: 2a 20 28 28 73 6b 20 20 28 73 65 73 73 69 6f 6e * ((sk (session
2d80: 3a 65 78 74 72 61 63 74 2d 73 65 73 73 69 6f 6e :extract-session
2d90: 2d 6b 65 79 20 73 65 6c 66 29 29 0a 20 20 20 20 -key self)).
2da0: 20 20 20 20 20 28 73 69 64 20 28 69 66 20 73 6b (sid (if sk
2db0: 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 69 64 (session:get-id
2dc0: 20 73 65 6c 66 20 73 6b 29 20 23 66 29 29 29 0a self sk) #f))).
2dd0: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 73 69 64 (if (not sid
2de0: 29 20 3b 3b 20 6e 65 65 64 20 61 20 6e 65 77 20 ) ;; need a new
2df0: 6b 65 79 0a 20 20 20 20 20 20 20 20 28 6c 65 74 key. (let
2e00: 2a 20 28 28 6e 65 77 2d 6b 65 79 20 28 73 65 73 * ((new-key (ses
2e10: 73 69 6f 6e 3a 67 65 74 2d 6e 65 77 2d 6b 65 79 sion:get-new-key
2e20: 20 73 65 6c 66 29 29 0a 20 20 20 20 20 20 20 20 self)).
2e30: 20 20 20 20 20 20 20 28 6e 65 77 2d 73 69 64 20 (new-sid
2e40: 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 69 64 20 (session:get-id
2e50: 73 65 6c 66 20 6e 65 77 2d 6b 65 79 29 29 29 0a self new-key))).
2e60: 20 20 20 20 20 20 20 20 20 20 28 73 64 61 74 2d (sdat-
2e70: 73 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 21 set-session-key!
2e80: 20 73 65 6c 66 20 6e 65 77 2d 6b 65 79 29 0a 20 self new-key).
2e90: 20 20 20 20 20 20 20 20 20 28 73 64 61 74 2d 73 (sdat-s
2ea0: 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 21 20 73 et-session-id! s
2eb0: 65 6c 66 20 6e 65 77 2d 73 69 64 29 0a 20 20 20 elf new-sid).
2ec0: 20 20 20 20 20 20 20 28 73 64 61 74 2d 73 65 74 (sdat-set
2ed0: 2d 73 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 21 -session-cookie!
2ee0: 20 73 65 6c 66 20 28 73 65 73 73 69 6f 6e 3a 6d self (session:m
2ef0: 61 6b 65 2d 63 6f 6f 6b 69 65 20 73 65 6c 66 29 ake-cookie self)
2f00: 29 29 0a 20 20 20 20 20 20 20 20 28 73 64 61 74 )). (sdat
2f10: 2d 73 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 21 -set-session-id!
2f20: 20 73 65 6c 66 20 73 69 64 29 29 29 29 0a 0a 28 self sid))))..(
2f30: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
2f40: 6d 61 6b 65 2d 63 6f 6f 6b 69 65 20 73 65 6c 66 make-cookie self
2f50: 29 0a 20 20 3b 3b 20 28 6c 69 73 74 20 28 63 6f ). ;; (list (co
2f60: 6e 63 20 22 73 65 73 73 69 6f 6e 5f 6b 65 79 3d nc "session_key=
2f70: 22 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 " (sdat-get-sess
2f80: 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 20 22 3b ion-key self) ";
2f90: 20 50 61 74 68 3d 2f 3b 20 44 6f 6d 61 69 6e 3d Path=/; Domain=
2fa0: 2e 22 20 28 73 64 61 74 2d 67 65 74 2d 64 6f 6d ." (sdat-get-dom
2fb0: 61 69 6e 20 73 65 6c 66 29 20 22 3b 20 4d 61 78 ain self) "; Max
2fc0: 2d 41 67 65 3d 22 20 28 2a 20 38 36 34 30 30 20 -Age=" (* 86400
2fd0: 31 34 29 20 22 3b 20 56 65 72 73 69 6f 6e 3d 31 14) "; Version=1
2fe0: 22 29 29 29 20 0a 20 20 3b 3b 20 41 63 63 6f 72 "))) . ;; Accor
2ff0: 64 69 6e 67 20 74 6f 20 0a 20 20 3b 3b 20 20 20 ding to . ;;
3000: 20 68 74 74 70 3a 2f 2f 77 77 77 2e 63 6f 64 65 http://www.code
3010: 6d 61 72 76 65 6c 73 2e 63 6f 6d 2f 32 30 31 30 marvels.com/2010
3020: 2f 31 31 2f 61 70 61 63 68 65 2d 72 65 77 72 69 /11/apache-rewri
3030: 74 65 72 75 6c 65 2d 73 65 74 2d 61 2d 63 6f 6f terule-set-a-coo
3040: 6b 69 65 2d 6f 6e 2d 6c 6f 63 61 6c 68 6f 73 74 kie-on-localhost
3050: 2f 0a 0a 20 20 3b 3b 20 20 48 65 72 65 20 61 72 /.. ;; Here ar
3060: 65 20 74 68 65 20 32 20 28 6f 66 74 65 6e 20 6c e the 2 (often l
3070: 65 66 74 20 6f 75 74 29 20 72 65 71 75 69 72 65 eft out) require
3080: 6d 65 6e 74 73 20 74 6f 20 73 65 74 20 61 20 63 ments to set a c
3090: 6f 6f 6b 69 65 20 75 73 69 6e 67 0a 20 20 3b 3b ookie using. ;;
30a0: 20 20 68 74 74 70 64 1b 2d 46 a2 73 20 72 65 77 httpd.-F˘s rew
30b0: 72 69 74 65 20 72 75 6c 65 20 28 6d 6f 64 5f 72 rite rule (mod_r
30c0: 65 77 72 69 74 65 29 2c 20 77 68 69 6c 65 20 77 ewrite), while w
30d0: 6f 72 6b 69 6e 67 20 6f 6e 20 6c 6f 63 61 6c 68 orking on localh
30e0: 6f 73 74 3a 1b 2d 41 0a 20 20 3b 3b 0a 20 20 3b ost:.-A. ;;. ;
30f0: 3b 20 20 55 73 65 20 74 68 65 20 49 50 20 31 32 ; Use the IP 12
3100: 37 2e 30 2e 30 2e 31 20 69 6e 73 74 65 61 64 20 7.0.0.1 instead
3110: 6f 66 20 6c 6f 63 61 6c 68 6f 73 74 2f 6d 61 63 of localhost/mac
3120: 68 69 6e 65 2d 6e 61 6d 65 20 61 73 20 74 68 65 hine-name as the
3130: 0a 20 20 3b 3b 20 20 64 6f 6d 61 69 6e 3b 20 65 . ;; domain; e
3140: 2e 67 2e 20 5b 43 4f 3d 73 6f 6d 65 43 6f 6f 6b .g. [CO=someCook
3150: 69 65 3a 73 6f 6d 65 56 61 6c 75 65 3a 31 32 37 ie:someValue:127
3160: 2e 30 2e 30 2e 31 3a 32 3a 2f 5d 2c 20 77 68 69 .0.0.1:2:/], whi
3170: 63 68 20 73 61 79 73 0a 20 20 3b 3b 20 20 63 72 ch says. ;; cr
3180: 65 61 74 65 20 61 20 63 6f 6f 6b 69 65 20 1b 2d eate a cookie .-
3190: 59 b4 73 6f 6d 65 43 6f 6f 6b 69 65 a1 20 77 69 Y´someCookieˇ wi
31a0: 74 68 20 76 61 6c 75 65 20 b4 73 6f 6d 65 56 61 th value ´someVa
31b0: 6c 75 65 a1 20 66 6f 72 20 74 68 65 0a 20 20 3b lueˇ for the. ;
31c0: 3b 20 20 64 6f 6d 61 69 6e 20 b4 31 32 37 2e 30 ; domain ´127.0
31d0: 2e 30 2e 31 1b 24 42 21 6d 1b 28 42 20 68 61 76 .0.1.$B!m.(B hav
31e0: 69 6e 67 20 61 20 6c 69 66 65 20 74 69 6d 65 20 ing a life time
31f0: 6f 66 20 32 20 6d 69 6e 73 2c 20 66 6f 72 20 61 of 2 mins, for a
3200: 6e 79 20 70 61 74 68 20 69 6e 0a 20 20 3b 3b 20 ny path in. ;;
3210: 20 74 68 65 20 64 6f 6d 61 69 6e 20 28 70 61 74 the domain (pat
3220: 68 3d 2f 29 2e 20 28 4f 62 76 69 6f 75 73 6c 79 h=/). (Obviously
3230: 20 79 6f 75 20 77 69 6c 6c 20 68 61 76 65 20 74 you will have t
3240: 6f 20 72 75 6e 20 74 68 65 0a 20 20 3b 3b 20 20 o run the. ;;
3250: 61 70 70 6c 69 63 61 74 69 6f 6e 20 77 69 74 68 application with
3260: 20 74 68 69 73 20 76 61 6c 75 65 20 69 6e 20 74 this value in t
3270: 68 65 20 55 52 4c 29 0a 20 20 3b 3b 0a 20 20 3b he URL). ;;. ;
3280: 3b 20 20 54 6f 20 6d 61 6b 65 20 61 20 73 65 73 ; To make a ses
3290: 73 69 6f 6e 20 63 6f 6f 6b 69 65 2c 20 6c 69 6d sion cookie, lim
32a0: 69 74 20 74 68 65 20 66 6c 61 67 20 73 74 61 74 it the flag stat
32b0: 65 6d 65 6e 74 20 74 6f 20 6a 75 73 74 20 74 68 ement to just th
32c0: 72 65 65 0a 20 20 3b 3b 20 20 61 74 74 72 69 62 ree. ;; attrib
32d0: 75 74 65 73 3a 20 6e 61 6d 65 2c 20 76 61 6c 75 utes: name, valu
32e0: 65 20 61 6e 64 20 64 6f 6d 61 69 6e 2e 20 65 2e e and domain. e.
32f0: 67 0a 20 20 3b 3b 20 20 5b 43 4f 3d 73 6f 6d 65 g. ;; [CO=some
3300: 43 6f 6f 6b 69 65 3a 73 6f 6d 65 56 61 6c 75 65 Cookie:someValue
3310: 3a 31 32 37 2e 30 2e 30 2e 31 5d 20 1b 25 47 e2 :127.0.0.1] .%Gâ
3320: 80 93 1b 25 40 20 41 6e 79 20 66 75 72 74 68 65 €“.%@ Any furthe
3330: 72 0a 20 20 3b 3b 20 20 73 65 74 74 69 6e 67 73 r. ;; settings
3340: 2c 20 61 70 61 63 68 65 20 77 72 69 74 65 73 20 , apache writes
3350: 61 6e a1 20 65 78 70 69 72 65 73 a1 20 61 74 74 anˇ expiresˇ att
3360: 72 69 62 75 74 65 20 66 6f 72 20 74 68 65 20 73 ribute for the s
3370: 65 74 2d 63 6f 6f 6b 69 65 0a 20 20 3b 3b 20 20 et-cookie. ;;
3380: 68 65 61 64 65 72 2c 20 77 68 69 63 68 20 6d 61 header, which ma
3390: 6b 65 73 20 74 68 65 20 63 6f 6f 6b 69 65 20 61 kes the cookie a
33a0: 20 70 65 72 73 69 73 74 65 6e 74 20 6f 6e 65 20 persistent one
33b0: 28 6e 6f 74 20 72 65 61 6c 6c 79 0a 20 20 3b 3b (not really. ;;
33c0: 20 20 70 65 72 73 69 73 74 65 6e 74 2c 20 61 73 persistent, as
33d0: 20 74 68 65 20 65 78 70 69 72 65 73 20 76 61 6c the expires val
33e0: 75 65 20 73 65 74 20 69 73 20 74 68 65 20 63 75 ue set is the cu
33f0: 72 72 65 6e 74 20 73 65 72 76 65 72 20 74 69 6d rrent server tim
3400: 65 0a 20 20 3b 3b 20 20 1b 25 47 e2 80 93 1b 25 e. ;; .%G–.%
3410: 40 20 73 6f 20 79 6f 75 20 64 6f 6e 1b 2d 46 1b @ so you don.-F.
3420: 2d 46 a2 74 20 65 76 65 6e 20 67 65 74 20 74 6f -F˘t even get to
3430: 20 73 65 65 20 79 6f 75 72 20 63 6f 6f 6b 69 65 see your cookie
3440: 21 29 1b 2d 41 0a 20 20 28 6c 69 73 74 20 28 73 !).-A. (list (s
3450: 74 72 69 6e 67 2d 73 75 62 73 74 69 74 75 74 65 tring-substitute
3460: 20 0a 09 20 22 3b 22 20 22 3b 20 22 20 0a 09 20 .. ";" "; " ..
3470: 28 63 61 72 20 28 63 6f 6e 73 74 72 75 63 74 2d (car (construct-
3480: 63 6f 6f 6b 69 65 2d 73 74 72 69 6e 67 20 0a 09 cookie-string ..
3490: 20 20 20 20 20 20 20 3b 3b 20 77 61 72 6e 69 6e ;; warnin
34a0: 67 21 20 6d 65 73 73 69 6e 67 20 75 70 20 74 68 g! messing up th
34b0: 69 73 20 69 74 74 79 20 62 69 74 74 79 20 62 69 is itty bitty bi
34c0: 74 20 6f 66 20 63 6f 64 65 20 77 69 6c 6c 20 63 t of code will c
34d0: 6f 73 74 20 6d 75 63 68 20 74 69 6d 65 21 0a 09 ost much time!..
34e0: 20 20 20 20 20 20 20 60 28 28 22 73 65 73 73 69 `(("sessi
34f0: 6f 6e 5f 6b 65 79 22 20 2c 28 73 64 61 74 2d 67 on_key" ,(sdat-g
3500: 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 et-session-key s
3510: 65 6c 66 29 0a 09 09 20 20 65 78 70 69 72 65 73 elf)... expires
3520: 3a 20 2c 28 2b 20 28 63 75 72 72 65 6e 74 2d 73 : ,(+ (current-s
3530: 65 63 6f 6e 64 73 29 20 28 2a 20 31 34 20 38 36 econds) (* 14 86
3540: 34 30 30 29 29 20 0a 09 09 20 20 3b 3b 20 6d 61 400)) ... ;; ma
3550: 78 2d 61 67 65 3a 20 28 2a 20 31 34 20 38 36 34 x-age: (* 14 864
3560: 30 30 29 0a 09 09 20 20 70 61 74 68 3a 20 22 2f 00)... path: "/
3570: 22 20 3b 3b 20 0a 09 09 20 20 64 6f 6d 61 69 6e " ;; ... domain
3580: 3a 20 2c 28 73 74 72 69 6e 67 2d 61 70 70 65 6e : ,(string-appen
3590: 64 20 22 2e 22 20 28 73 64 61 74 2d 67 65 74 2d d "." (sdat-get-
35a0: 64 6f 6d 61 69 6e 20 73 65 6c 66 29 29 0a 09 09 domain self))...
35b0: 20 20 76 65 72 73 69 6f 6e 3a 20 31 29 29 20 30 version: 1)) 0
35c0: 29 29 29 29 29 0a 0a 3b 3b 20 6c 6f 6f 6b 20 75 )))))..;; look u
35d0: 70 20 61 20 67 69 76 65 6e 20 73 65 73 73 69 6f p a given sessio
35e0: 6e 20 6b 65 79 20 61 6e 64 20 72 65 74 75 72 6e n key and return
35f0: 20 74 68 65 20 69 64 20 69 66 20 66 6f 75 6e 64 the id if found
3600: 2c 20 23 66 20 69 66 20 6e 6f 74 20 66 6f 75 6e , #f if not foun
3610: 64 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 d.(define (sessi
3620: 6f 6e 3a 67 65 74 2d 69 64 20 73 65 6c 66 20 73 on:get-id self s
3630: 65 73 73 69 6f 6e 2d 6b 65 79 29 0a 20 20 3b 3b ession-key). ;;
3640: 20 28 6c 65 74 20 28 28 73 65 73 73 69 6f 6e 2d (let ((session-
3650: 6b 65 79 20 28 73 64 61 74 2d 67 65 74 2d 73 65 key (sdat-get-se
3660: 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 29 ssion-key self))
3670: 29 0a 20 20 28 69 66 20 73 65 73 73 69 6f 6e 2d ). (if session-
3680: 6b 65 79 0a 20 20 20 20 20 20 28 6c 65 74 20 28 key. (let (
3690: 28 71 75 65 72 79 20 28 73 74 72 69 6e 67 2d 61 (query (string-a
36a0: 70 70 65 6e 64 20 22 53 45 4c 45 43 54 20 69 64 ppend "SELECT id
36b0: 20 46 52 4f 4d 20 73 65 73 73 69 6f 6e 73 20 57 FROM sessions W
36c0: 48 45 52 45 20 73 65 73 73 69 6f 6e 5f 6b 65 79 HERE session_key
36d0: 3d 27 22 20 73 65 73 73 69 6f 6e 2d 6b 65 79 20 ='" session-key
36e0: 22 27 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 "'")).
36f0: 20 20 28 63 6f 6e 6e 20 28 73 64 61 74 2d 67 65 (conn (sdat-ge
3700: 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 0a 20 20 t-conn self)).
3710: 20 20 20 20 20 20 20 20 20 20 28 72 65 73 75 6c (resul
3720: 74 20 23 66 29 29 0a 09 28 64 62 69 3a 66 6f 72 t #f))..(dbi:for
3730: 2d 65 61 63 68 2d 72 6f 77 20 0a 09 20 28 6c 61 -each-row .. (la
3740: 6d 62 64 61 20 28 74 75 70 6c 65 29 0a 09 20 20 mbda (tuple)..
3750: 20 28 73 65 74 21 20 72 65 73 75 6c 74 20 28 76 (set! result (v
3760: 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 ector-ref tuple
3770: 30 29 29 29 0a 09 20 63 6f 6e 6e 20 71 75 65 72 0))).. conn quer
3780: 79 29 0a 09 28 69 66 20 72 65 73 75 6c 74 20 28 y)..(if result (
3790: 64 62 69 3a 65 78 65 63 20 63 6f 6e 6e 20 28 63 dbi:exec conn (c
37a0: 6f 6e 63 20 22 55 50 44 41 54 45 20 73 65 73 73 onc "UPDATE sess
37b0: 69 6f 6e 73 20 53 45 54 20 6c 61 73 74 5f 75 73 ions SET last_us
37c0: 65 64 3d 22 20 28 64 62 69 3a 6e 6f 77 20 63 6f ed=" (dbi:now co
37d0: 6e 6e 29 20 22 20 57 48 45 52 45 20 73 65 73 73 nn) " WHERE sess
37e0: 69 6f 6e 5f 6b 65 79 3d 3f 3b 22 29 20 73 65 73 ion_key=?;") ses
37f0: 73 69 6f 6e 2d 6b 65 79 29 29 0a 20 20 20 20 20 sion-key)).
3800: 20 20 20 72 65 73 75 6c 74 29 0a 20 20 20 20 20 result).
3810: 20 23 66 29 29 0a 0a 3b 3b 20 0a 28 64 65 66 69 #f))..;; .(defi
3820: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 70 72 6f 63 ne (session:proc
3830: 65 73 73 2d 75 72 6c 2d 70 61 74 68 20 73 65 6c ess-url-path sel
3840: 66 29 0a 20 20 28 6c 65 74 20 28 28 70 61 74 68 f). (let ((path
3850: 2d 69 6e 66 6f 20 20 20 20 28 67 65 74 2d 65 6e -info (get-en
3860: 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 vironment-variab
3870: 6c 65 20 22 50 41 54 48 5f 49 4e 46 4f 22 29 29 le "PATH_INFO"))
3880: 0a 09 28 71 75 65 72 79 2d 73 74 72 69 6e 67 20 ..(query-string
3890: 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 (get-environment
38a0: 2d 76 61 72 69 61 62 6c 65 20 22 51 55 45 52 59 -variable "QUERY
38b0: 5f 53 54 52 49 4e 47 22 29 29 29 0a 20 20 20 20 _STRING"))).
38c0: 3b 3b 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 ;; (session:log
38d0: 73 65 6c 66 20 22 70 61 74 68 2d 69 6e 66 6f 3d self "path-info=
38e0: 22 20 70 61 74 68 2d 69 6e 66 6f 20 22 20 71 75 " path-info " qu
38f0: 65 72 79 2d 73 74 72 69 6e 67 3d 22 20 71 75 65 ery-string=" que
3900: 72 79 2d 73 74 72 69 6e 67 29 0a 20 20 20 20 28 ry-string). (
3910: 69 66 20 70 61 74 68 2d 69 6e 66 6f 0a 09 28 6c if path-info..(l
3920: 65 74 2a 20 28 28 70 61 72 74 73 20 20 20 20 28 et* ((parts (
3930: 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 70 61 74 string-split pat
3940: 68 2d 69 6e 66 6f 20 22 2f 22 29 29 0a 09 20 20 h-info "/"))..
3950: 20 20 20 20 20 28 6e 75 6d 70 61 72 74 73 20 28 (numparts (
3960: 6c 65 6e 67 74 68 20 70 61 72 74 73 29 29 29 0a length parts))).
3970: 09 20 20 28 69 66 20 28 3e 20 6e 75 6d 70 61 72 . (if (> numpar
3980: 74 73 20 30 29 0a 09 20 20 20 20 20 20 28 73 64 ts 0).. (sd
3990: 61 74 2d 73 65 74 2d 70 61 67 65 21 20 73 65 6c at-set-page! sel
39a0: 66 20 28 63 61 72 20 70 61 72 74 73 29 29 29 0a f (car parts))).
39b0: 09 20 20 3b 3b 20 28 73 65 73 73 69 6f 6e 3a 6c . ;; (session:l
39c0: 6f 67 20 73 65 6c 66 20 22 75 72 6c 2d 70 61 74 og self "url-pat
39d0: 68 3d 22 20 75 72 6c 2d 70 61 74 68 20 22 20 70 h=" url-path " p
39e0: 61 72 74 73 3d 22 20 70 61 72 74 73 29 0a 09 20 arts=" parts)..
39f0: 20 28 69 66 20 28 3e 20 6e 75 6d 70 61 72 74 73 (if (> numparts
3a00: 20 31 29 0a 09 20 20 20 20 20 20 28 73 64 61 74 1).. (sdat
3a10: 2d 73 65 74 2d 70 61 74 68 2d 70 61 72 61 6d 73 -set-path-params
3a20: 21 20 73 65 6c 66 20 28 63 64 72 20 70 61 72 74 ! self (cdr part
3a30: 73 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 s))). (
3a40: 69 66 20 71 75 65 72 79 2d 73 74 72 69 6e 67 0a if query-string.
3a50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
3a60: 64 61 74 2d 73 65 74 2d 70 61 72 61 6d 73 21 20 dat-set-params!
3a70: 73 65 6c 66 20 28 73 74 72 69 6e 67 2d 73 70 6c self (string-spl
3a80: 69 74 20 71 75 65 72 79 2d 73 74 72 69 6e 67 20 it query-string
3a90: 22 26 22 29 29 29 29 29 29 29 0a 0a 3b 3b 20 42 "&")))))))..;; B
3aa0: 55 47 47 59 21 0a 28 64 65 66 69 6e 65 20 28 73 UGGY!.(define (s
3ab0: 65 73 73 69 6f 6e 3a 67 65 74 2d 6e 65 77 2d 6b ession:get-new-k
3ac0: 65 79 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 20 ey self). (let
3ad0: 28 28 63 6f 6e 6e 20 20 20 28 73 64 61 74 2d 67 ((conn (sdat-g
3ae0: 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 0a 20 et-conn self)).
3af0: 20 20 20 20 20 20 20 28 74 6d 70 6b 65 79 20 28 (tmpkey (
3b00: 73 65 73 73 69 6f 6e 3a 6d 61 6b 65 2d 72 61 6e session:make-ran
3b10: 64 2d 73 74 72 69 6e 67 20 32 30 29 29 0a 20 20 d-string 20)).
3b20: 20 20 20 20 20 20 28 73 74 61 74 75 73 20 23 66 (status #f
3b30: 29 29 0a 20 20 20 20 28 64 62 69 3a 66 6f 72 2d )). (dbi:for-
3b40: 65 61 63 68 2d 72 6f 77 20 28 6c 61 6d 62 64 61 each-row (lambda
3b50: 20 28 74 75 70 6c 65 29 0a 09 09 09 28 73 65 74 (tuple)....(set
3b60: 21 20 73 74 61 74 75 73 20 23 74 29 29 0a 09 09 ! status #t))...
3b70: 20 20 20 20 20 20 63 6f 6e 6e 20 28 73 74 72 69 conn (stri
3b80: 6e 67 2d 61 70 70 65 6e 64 20 22 49 4e 53 45 52 ng-append "INSER
3b90: 54 20 49 4e 54 4f 20 73 65 73 73 69 6f 6e 73 20 T INTO sessions
3ba0: 28 73 65 73 73 69 6f 6e 5f 6b 65 79 29 20 56 41 (session_key) VA
3bb0: 4c 55 45 53 20 28 27 22 20 74 6d 70 6b 65 79 20 LUES ('" tmpkey
3bc0: 22 27 29 22 29 29 0a 20 20 20 20 74 6d 70 6b 65 "')")). tmpke
3bd0: 79 29 29 0a 0a 3b 3b 20 72 65 74 75 72 6e 73 20 y))..;; returns
3be0: 73 65 73 73 69 6f 6e 20 6b 65 79 20 49 46 46 20 session key IFF
3bf0: 69 74 20 69 73 20 69 6e 20 74 68 65 20 48 54 54 it is in the HTT
3c00: 50 5f 43 4f 4f 4b 49 45 20 0a 28 64 65 66 69 6e P_COOKIE .(defin
3c10: 65 20 28 73 65 73 73 69 6f 6e 3a 65 78 74 72 61 e (session:extra
3c20: 63 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 ct-session-key s
3c30: 65 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 68 74 elf). (let ((ht
3c40: 74 70 2d 63 6f 6f 6b 69 65 20 28 67 65 74 2d 65 tp-cookie (get-e
3c50: 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 nvironment-varia
3c60: 62 6c 65 20 22 48 54 54 50 5f 43 4f 4f 4b 49 45 ble "HTTP_COOKIE
3c70: 22 29 29 29 0a 20 20 20 20 3b 3b 20 28 65 72 72 "))). ;; (err
3c80: 3a 6c 6f 67 20 22 68 74 74 70 2d 63 6f 6f 6b 69 :log "http-cooki
3c90: 65 3a 20 22 20 68 74 74 70 2d 63 6f 6f 6b 69 65 e: " http-cookie
3ca0: 29 0a 20 20 20 20 28 69 66 20 68 74 74 70 2d 63 ). (if http-c
3cb0: 6f 6f 6b 69 65 0a 20 20 20 20 20 20 20 20 28 73 ookie. (s
3cc0: 65 73 73 69 6f 6e 3a 65 78 74 72 61 63 74 2d 6b ession:extract-k
3cd0: 65 79 2d 66 72 6f 6d 2d 70 61 72 61 6d 20 73 65 ey-from-param se
3ce0: 6c 66 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 lf (string-split
3cf0: 2d 66 69 65 6c 64 73 20 20 22 3b 5c 5c 73 2b 22 -fields ";\\s+"
3d00: 20 68 74 74 70 2d 63 6f 6f 6b 69 65 20 69 6e 66 http-cookie inf
3d10: 69 78 3a 29 20 22 73 65 73 73 69 6f 6e 5f 6b 65 ix:) "session_ke
3d20: 79 22 29 0a 20 20 20 20 20 20 20 20 23 66 29 29 y"). #f))
3d30: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 )..(define (sess
3d40: 69 6f 6e 3a 67 65 74 2d 73 65 73 73 69 6f 6e 2d ion:get-session-
3d50: 69 64 20 73 65 6c 66 20 73 65 73 73 69 6f 6e 2d id self session-
3d60: 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 28 71 75 key). (let ((qu
3d70: 65 72 79 20 22 53 45 4c 45 43 54 20 69 64 20 46 ery "SELECT id F
3d80: 52 4f 4d 20 73 65 73 73 69 6f 6e 73 20 57 48 45 ROM sessions WHE
3d90: 52 45 20 73 65 73 73 69 6f 6e 5f 6b 65 79 3d 3f RE session_key=?
3da0: 3b 22 29 0a 20 20 20 20 20 20 20 20 28 72 65 73 ;"). (res
3db0: 75 6c 74 20 23 66 29 29 0a 20 20 20 20 3b 3b 20 ult #f)). ;;
3dc0: 20 20 20 20 28 70 67 3a 71 75 65 72 79 2d 66 6f (pg:query-fo
3dd0: 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 r-each (lambda (
3de0: 74 75 70 6c 65 29 0a 20 20 20 20 3b 3b 20 20 20 tuple). ;;
3df0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3e00: 20 20 20 20 20 20 20 28 73 65 74 21 20 72 65 73 (set! res
3e10: 75 6c 74 20 28 76 65 63 74 6f 72 2d 72 65 66 20 ult (vector-ref
3e20: 74 75 70 6c 65 20 30 29 29 29 20 3b 3b 20 28 76 tuple 0))) ;; (v
3e30: 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 ector-ref tuple
3e40: 30 29 29 29 0a 20 20 20 20 3b 3b 20 20 20 20 20 0))). ;;
3e50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3e60: 20 20 20 28 73 3a 73 71 6c 70 61 72 61 6d 20 71 (s:sqlparam q
3e70: 75 65 72 79 20 73 65 73 73 69 6f 6e 2d 6b 65 79 uery session-key
3e80: 29 0a 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 ). ;;
3e90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3ea0: 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 (sdat-get-conn s
3eb0: 65 6c 66 29 29 0a 20 20 20 20 3b 3b 20 20 20 20 elf)). ;;
3ec0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3ed0: 20 20 20 20 63 6f 6e 6e 29 0a 20 20 20 20 28 64 conn). (d
3ee0: 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 bi:for-each-row
3ef0: 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 29 0a (lambda (tuple).
3f00: 09 09 09 28 73 65 74 21 20 72 65 73 75 6c 74 20 ...(set! result
3f10: 28 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c (vector-ref tupl
3f20: 65 20 30 29 29 29 20 3b 3b 20 28 76 65 63 74 6f e 0))) ;; (vecto
3f30: 72 2d 72 65 66 20 74 75 70 6c 65 20 30 29 29 29 r-ref tuple 0)))
3f40: 0a 09 09 20 20 20 20 20 20 28 73 64 61 74 2d 67 ... (sdat-g
3f50: 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 0a 09 09 et-conn self)...
3f60: 20 20 20 20 20 20 28 73 3a 73 71 6c 70 61 72 61 (s:sqlpara
3f70: 6d 20 71 75 65 72 79 20 73 65 73 73 69 6f 6e 2d m query session-
3f80: 6b 65 79 29 29 0a 20 20 20 20 72 65 73 75 6c 74 key)). result
3f90: 29 29 0a 0a 3b 3b 20 64 65 6c 65 74 65 20 61 6c ))..;; delete al
3fa0: 6c 20 72 65 63 6f 72 64 73 20 66 6f 72 20 61 20 l records for a
3fb0: 73 65 73 73 69 6f 6e 0a 3b 3b 20 0a 3b 3b 20 4e session.;; .;; N
3fc0: 45 45 44 53 20 54 4f 20 42 45 20 54 52 41 4e 53 EEDS TO BE TRANS
3fd0: 41 43 54 49 4f 4e 49 5a 45 44 21 0a 3b 3b 0a 28 ACTIONIZED!.;;.(
3fe0: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
3ff0: 64 65 6c 65 74 65 2d 73 65 73 73 69 6f 6e 20 73 delete-session s
4000: 65 6c 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 elf session-key)
4010: 0a 20 20 28 6c 65 74 20 28 28 73 65 73 73 69 6f . (let ((sessio
4020: 6e 2d 69 64 20 28 73 65 73 73 69 6f 6e 3a 67 65 n-id (session:ge
4030: 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c t-session-id sel
4040: 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 0a f session-key)).
4050: 20 20 20 20 20 20 20 20 28 71 72 79 31 20 20 20 (qry1
4060: 20 20 20 20 20 3b 3b 20 28 63 6f 6e 63 20 22 42 ;; (conc "B
4070: 45 47 49 4e 3b 22 0a 09 09 09 20 20 22 44 45 4c EGIN;".... "DEL
4080: 45 54 45 20 46 52 4f 4d 20 73 65 73 73 69 6f 6e ETE FROM session
4090: 5f 76 61 72 73 20 57 48 45 52 45 20 73 65 73 73 _vars WHERE sess
40a0: 69 6f 6e 5f 69 64 3d 3f 3b 22 29 0a 09 28 71 72 ion_id=?;")..(qr
40b0: 79 32 20 20 20 20 20 20 20 20 20 20 20 20 20 22 y2 "
40c0: 44 45 4c 45 54 45 20 46 52 4f 4d 20 73 65 73 73 DELETE FROM sess
40d0: 69 6f 6e 73 20 57 48 45 52 45 20 69 64 3d 3f 3b ions WHERE id=?;
40e0: 22 29 0a 09 09 20 20 20 20 20 3b 3b 20 20 22 43 ")... ;; "C
40f0: 4f 4d 4d 49 54 3b 22 29 29 0a 20 20 20 20 20 20 OMMIT;")).
4100: 20 20 28 63 6f 6e 6e 20 20 20 20 20 20 20 20 20 (conn
4110: 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d 63 (sdat-get-c
4120: 6f 6e 6e 20 73 65 6c 66 29 29 29 0a 20 20 20 20 onn self))).
4130: 28 69 66 20 73 65 73 73 69 6f 6e 2d 69 64 0a 20 (if session-id.
4140: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 (begin.
4150: 20 20 20 20 20 20 20 20 28 64 62 69 3a 65 78 65 (dbi:exe
4160: 63 20 63 6f 6e 6e 20 71 72 79 31 20 73 65 73 73 c conn qry1 sess
4170: 69 6f 6e 2d 69 64 29 20 3b 3b 20 73 65 73 73 69 ion-id) ;; sessi
4180: 6f 6e 2d 69 64 29 0a 09 20 20 28 64 62 69 3a 65 on-id).. (dbi:e
4190: 78 65 63 20 63 6f 6e 6e 20 71 72 79 32 20 73 65 xec conn qry2 se
41a0: 73 73 69 6f 6e 2d 69 64 29 0a 09 20 20 28 73 65 ssion-id).. (se
41b0: 73 73 69 6f 6e 3a 69 6e 69 74 69 61 6c 69 7a 65 ssion:initialize
41c0: 20 73 65 6c 66 29 0a 09 20 20 28 73 65 73 73 69 self).. (sessi
41d0: 6f 6e 3a 73 65 74 75 70 20 73 65 6c 66 29 29 29 on:setup self)))
41e0: 0a 20 20 20 20 28 6e 6f 74 20 28 73 65 73 73 69 . (not (sessi
41f0: 6f 6e 3a 67 65 74 2d 73 65 73 73 69 6f 6e 2d 69 on:get-session-i
4200: 64 20 73 65 6c 66 20 73 65 73 73 69 6f 6e 2d 6b d self session-k
4210: 65 79 29 29 29 29 0a 0a 3b 3b 20 28 64 65 66 69 ey))))..;; (defi
4220: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 64 65 6c 65 ne (session:dele
4230: 74 65 2d 73 65 73 73 69 6f 6e 20 73 65 6c 66 20 te-session self
4240: 73 65 73 73 69 6f 6e 2d 6b 65 79 29 0a 3b 3b 20 session-key).;;
4250: 20 20 28 6c 65 74 20 28 28 73 65 73 73 69 6f 6e (let ((session
4260: 2d 69 64 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 -id (session:get
4270: 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 -session-id self
4280: 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 0a 3b session-key)).;
4290: 3b 20 20 20 20 20 20 20 20 20 28 71 75 65 72 69 ; (queri
42a0: 65 73 20 20 20 20 28 6c 69 73 74 20 22 42 45 47 es (list "BEG
42b0: 49 4e 3b 22 0a 3b 3b 20 09 09 09 20 20 22 44 45 IN;".;; ... "DE
42c0: 4c 45 54 45 20 46 52 4f 4d 20 73 65 73 73 69 6f LETE FROM sessio
42d0: 6e 5f 76 61 72 73 20 57 48 45 52 45 20 73 65 73 n_vars WHERE ses
42e0: 73 69 6f 6e 5f 69 64 3d 3f 3b 22 0a 3b 3b 20 20 sion_id=?;".;;
42f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4300: 20 20 20 20 20 20 20 20 20 22 44 45 4c 45 54 45 "DELETE
4310: 20 46 52 4f 4d 20 73 65 73 73 69 6f 6e 73 20 57 FROM sessions W
4320: 48 45 52 45 20 69 64 3d 3f 3b 22 0a 3b 3b 20 09 HERE id=?;".;; .
4330: 09 09 20 20 22 43 4f 4d 4d 49 54 3b 22 29 29 0a .. "COMMIT;")).
4340: 3b 3b 20 20 20 20 20 20 20 20 20 28 63 6f 6e 6e ;; (conn
4350: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
4360: 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c dat-get-conn sel
4370: 66 29 29 29 0a 3b 3b 20 20 20 20 20 28 69 66 20 f))).;; (if
4380: 73 65 73 73 69 6f 6e 2d 69 64 0a 3b 3b 20 20 20 session-id.;;
4390: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 3b 3b 20 (begin.;;
43a0: 20 20 20 20 20 20 20 20 20 20 28 66 6f 72 2d 65 (for-e
43b0: 61 63 68 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 ach.;;
43c0: 20 20 28 6c 61 6d 62 64 61 20 28 71 75 65 72 79 (lambda (query
43d0: 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 ).;;
43e0: 20 20 28 64 62 69 3a 65 78 65 63 20 63 6f 6e 6e (dbi:exec conn
43f0: 20 71 75 65 72 79 20 73 65 73 73 69 6f 6e 2d 69 query session-i
4400: 64 29 29 0a 3b 3b 20 09 20 20 20 71 75 65 72 69 d)).;; . queri
4410: 65 73 29 0a 3b 3b 20 09 20 20 28 69 6e 69 74 69 es).;; . (initi
4420: 61 6c 69 7a 65 20 73 65 6c 66 20 27 28 29 29 0a alize self '()).
4430: 3b 3b 20 09 20 20 28 73 65 73 73 69 6f 6e 3a 73 ;; . (session:s
4440: 65 74 75 70 20 73 65 6c 66 29 29 29 0a 3b 3b 20 etup self))).;;
4450: 20 20 20 20 28 6e 6f 74 20 28 73 65 73 73 69 6f (not (sessio
4460: 6e 3a 67 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 n:get-session-id
4470: 20 73 65 6c 66 20 73 65 73 73 69 6f 6e 2d 6b 65 self session-ke
4480: 79 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 y))))..(define (
4490: 73 65 73 73 69 6f 6e 3a 65 78 74 72 61 63 74 2d session:extract-
44a0: 6b 65 79 20 73 65 6c 66 20 6b 65 79 29 0a 20 20 key self key).
44b0: 28 6c 65 74 20 28 28 70 61 72 61 6d 73 20 28 73 (let ((params (s
44c0: 64 61 74 2d 67 65 74 2d 70 61 72 61 6d 73 20 73 dat-get-params s
44d0: 65 6c 66 29 29 29 0a 20 20 20 20 28 73 65 73 73 elf))). (sess
44e0: 69 6f 6e 3a 65 78 74 72 61 63 74 2d 6b 65 79 2d ion:extract-key-
44f0: 66 72 6f 6d 2d 70 61 72 61 6d 20 73 65 6c 66 20 from-param self
4500: 70 61 72 61 6d 73 20 6b 65 79 29 29 29 0a 0a 28 params key)))..(
4510: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
4520: 65 78 74 72 61 63 74 2d 6b 65 79 2d 66 72 6f 6d extract-key-from
4530: 2d 70 61 72 61 6d 20 73 65 6c 66 20 70 61 72 61 -param self para
4540: 6d 73 20 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 ms key). (let (
4550: 28 72 31 20 20 20 20 20 28 72 65 67 65 78 70 20 (r1 (regexp
4560: 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 22 (string-append "
4570: 5e 22 20 6b 65 79 20 22 3d 28 5b 5e 3d 5d 2b 29 ^" key "=([^=]+)
4580: 24 22 29 29 29 29 0a 20 20 20 20 28 65 72 72 3a $")))). (err:
4590: 6c 6f 67 20 22 49 4e 46 4f 3a 20 4c 6f 6f 6b 69 log "INFO: Looki
45a0: 6e 67 20 66 6f 72 20 22 20 6b 65 79 20 22 20 69 ng for " key " i
45b0: 6e 20 22 20 70 61 72 61 6d 73 29 0a 20 20 20 20 n " params).
45c0: 28 69 66 20 28 3c 20 28 6c 65 6e 67 74 68 20 70 (if (< (length p
45d0: 61 72 61 6d 73 29 20 31 29 20 23 66 0a 09 28 6c arams) 1) #f..(l
45e0: 65 74 20 6c 6f 6f 70 20 28 28 68 65 61 64 20 20 et loop ((head
45f0: 20 28 63 61 72 20 70 61 72 61 6d 73 29 29 0a 09 (car params))..
4600: 09 20 20 20 28 74 61 69 6c 20 20 20 28 63 64 72 . (tail (cdr
4610: 20 70 61 72 61 6d 73 29 29 29 0a 09 20 20 28 6c params))).. (l
4620: 65 74 20 28 28 6d 61 74 63 68 20 28 73 74 72 69 et ((match (stri
4630: 6e 67 2d 6d 61 74 63 68 20 72 31 20 68 65 61 64 ng-match r1 head
4640: 29 29 29 0a 09 20 20 20 20 28 63 6f 6e 64 0a 09 ))).. (cond..
4650: 20 20 20 20 20 28 6d 61 74 63 68 0a 09 20 20 20 (match..
4660: 20 20 20 28 6c 65 74 20 28 28 73 65 73 73 69 6f (let ((sessio
4670: 6e 2d 6b 65 79 20 28 6c 69 73 74 2d 72 65 66 20 n-key (list-ref
4680: 6d 61 74 63 68 20 31 29 29 29 0a 09 09 28 65 72 match 1)))...(er
4690: 72 3a 6c 6f 67 20 22 49 4e 46 4f 3a 20 46 6f 75 r:log "INFO: Fou
46a0: 6e 64 20 73 65 73 73 69 6f 6e 20 6b 65 79 3d 22 nd session key="
46b0: 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 0a 09 09 session-key)...
46c0: 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f (sdat-set-sessio
46d0: 6e 2d 6b 65 79 21 20 73 65 6c 66 20 28 6c 69 73 n-key! self (lis
46e0: 74 2d 72 65 66 20 6d 61 74 63 68 20 31 29 29 0a t-ref match 1)).
46f0: 09 09 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 0a ..session-key)).
4700: 09 20 20 20 20 20 28 28 6e 75 6c 6c 3f 20 74 61 . ((null? ta
4710: 69 6c 29 0a 09 20 20 20 20 20 20 23 66 29 0a 09 il).. #f)..
4720: 20 20 20 20 20 28 65 6c 73 65 0a 09 20 20 20 20 (else..
4730: 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 69 (loop (car tai
4740: 6c 29 0a 09 09 20 20 20 20 28 63 64 72 20 74 61 l)... (cdr ta
4750: 69 6c 29 29 29 29 29 29 29 29 29 0a 0a 28 64 65 il)))))))))..(de
4760: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 65 fine (session:se
4770: 74 2d 70 61 67 65 21 20 73 65 6c 66 20 70 61 67 t-page! self pag
4780: 65 5f 6e 61 6d 65 29 0a 20 20 28 73 64 61 74 2d e_name). (sdat-
4790: 73 65 74 2d 70 61 67 65 21 20 73 65 6c 66 20 70 set-page! self p
47a0: 61 67 65 5f 6e 61 6d 65 29 29 0a 0a 28 64 65 66 age_name))..(def
47b0: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 63 6c 6f ine (session:clo
47c0: 73 65 20 73 65 6c 66 29 0a 20 20 28 64 62 69 3a se self). (dbi:
47d0: 63 6c 6f 73 65 20 28 73 64 61 74 2d 67 65 74 2d close (sdat-get-
47e0: 63 6f 6e 6e 20 73 65 6c 66 29 29 29 0a 3b 3b 20 conn self))).;;
47f0: 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f (close-output-po
4800: 72 74 20 28 73 64 61 74 2d 67 65 74 2d 6c 6f 67 rt (sdat-get-log
4810: 70 74 20 73 65 6c 66 29 29 0a 0a 28 64 65 66 69 pt self))..(defi
4820: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 65 72 72 2d ne (session:err-
4830: 6d 73 67 20 73 65 6c 66 20 6d 73 67 29 0a 20 20 msg self msg).
4840: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
4850: 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 (sdat-get-sessi
4860: 6f 6e 76 61 72 73 20 73 65 6c 66 29 20 22 45 52 onvars self) "ER
4870: 52 4f 52 5f 4d 53 47 22 0a 09 09 20 20 20 28 73 ROR_MSG"... (s
4880: 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
4890: 65 20 28 6d 61 70 20 73 3a 61 6e 79 2d 3e 73 74 e (map s:any->st
48a0: 72 69 6e 67 20 6d 73 67 29 20 22 20 22 29 29 29 ring msg) " ")))
48b0: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ..(define (sessi
48c0: 6f 6e 3a 70 72 65 76 2d 65 72 72 20 73 65 6c 66 on:prev-err self
48d0: 29 0a 20 20 28 6c 65 74 20 28 28 70 72 65 76 2d ). (let ((prev-
48e0: 65 72 72 20 28 68 61 73 68 2d 74 61 62 6c 65 2d err (hash-table-
48f0: 72 65 66 2f 64 65 66 61 75 6c 74 20 28 73 64 61 ref/default (sda
4900: 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 t-get-sessionvar
4910: 73 2d 62 65 66 6f 72 65 20 73 65 6c 66 29 20 22 s-before self) "
4920: 45 52 52 4f 52 5f 4d 53 47 22 20 23 66 29 29 0a ERROR_MSG" #f)).
4930: 09 28 63 75 72 72 2d 65 72 72 20 28 68 61 73 68 .(curr-err (hash
4940: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
4950: 6c 74 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 lt (sdat-get-ses
4960: 73 69 6f 6e 76 61 72 73 20 73 65 6c 66 29 20 22 sionvars self) "
4970: 45 52 52 4f 52 5f 4d 53 47 22 20 23 66 29 29 29 ERROR_MSG" #f)))
4980: 0a 20 20 20 20 28 69 66 20 70 72 65 76 2d 65 72 . (if prev-er
4990: 72 20 70 72 65 76 2d 65 72 72 0a 09 28 69 66 20 r prev-err..(if
49a0: 63 75 72 72 2d 65 72 72 20 63 75 72 72 2d 65 72 curr-err curr-er
49b0: 72 20 23 66 29 29 29 29 0a 0a 3b 3b 20 73 65 73 r #f))))..;; ses
49c0: 73 69 6f 6e 20 76 61 72 73 0a 3b 3b 20 31 2e 20 sion vars.;; 1.
49d0: 6b 65 79 73 20 61 72 65 20 61 6c 77 61 79 73 20 keys are always
49e0: 61 20 73 74 72 69 6e 67 20 4e 4f 54 20 61 20 73 a string NOT a s
49f0: 79 6d 62 6f 6c 0a 3b 3b 20 32 2e 20 76 61 6c 75 ymbol.;; 2. valu
4a00: 65 73 20 61 72 65 20 61 6c 77 61 79 73 20 61 20 es are always a
4a10: 73 74 72 69 6e 67 20 63 6f 6e 76 65 72 73 69 6f string conversio
4a20: 6e 20 69 73 20 74 68 65 20 72 65 73 70 6f 6e 73 n is the respons
4a30: 69 62 69 6c 69 74 79 20 6f 66 20 74 68 65 20 0a ibility of the .
4a40: 3b 3b 20 20 20 20 63 6f 6e 73 75 6d 69 6e 67 20 ;; consuming
4a50: 66 75 6e 63 74 69 6f 6e 20 28 61 74 20 6c 65 61 function (at lea
4a60: 73 74 20 66 6f 72 20 6e 6f 77 2c 20 49 27 64 20 st for now, I'd
4a70: 6c 69 6b 65 20 74 6f 20 63 68 61 6e 67 65 20 74 like to change t
4a80: 68 69 73 29 0a 0a 3b 3b 20 73 65 74 20 61 20 73 his)..;; set a s
4a90: 65 73 73 69 6f 6e 20 76 61 72 20 66 6f 72 20 74 ession var for t
4aa0: 68 65 20 63 75 72 72 65 6e 74 20 70 61 67 65 0a he current page.
4ab0: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 ;;.(define (sess
4ac0: 69 6f 6e 3a 63 75 72 72 2d 70 61 67 65 2d 73 65 ion:curr-page-se
4ad0: 74 21 20 73 65 6c 66 20 6b 65 79 20 76 61 6c 75 t! self key valu
4ae0: 65 29 0a 20 20 28 68 61 73 68 2d 74 61 62 6c 65 e). (hash-table
4af0: 2d 73 65 74 21 20 28 73 64 61 74 2d 67 65 74 2d -set! (sdat-get-
4b00: 70 61 67 65 76 61 72 73 20 73 65 6c 66 29 20 28 pagevars self) (
4b10: 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6b 65 s:any->string ke
4b20: 79 29 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e y) (s:any->strin
4b30: 67 20 76 61 6c 75 65 29 29 29 0a 0a 3b 3b 20 64 g value)))..;; d
4b40: 65 6c 20 61 20 76 61 72 20 66 6f 72 20 74 68 65 el a var for the
4b50: 20 63 75 72 72 65 6e 74 20 70 61 67 65 0a 3b 3b current page.;;
4b60: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
4b70: 6e 3a 70 61 67 65 2d 76 61 72 2d 64 65 6c 21 20 n:page-var-del!
4b80: 73 65 6c 66 20 6b 65 79 29 0a 20 20 28 68 61 73 self key). (has
4b90: 68 2d 74 61 62 6c 65 2d 64 65 6c 65 74 65 21 20 h-table-delete!
4ba0: 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 76 61 (sdat-get-pageva
4bb0: 72 73 20 73 65 6c 66 29 20 28 73 3a 61 6e 79 2d rs self) (s:any-
4bc0: 3e 73 74 72 69 6e 67 20 6b 65 79 29 29 29 0a 0a >string key)))..
4bd0: 3b 3b 20 67 65 74 20 74 68 65 20 61 70 70 72 6f ;; get the appro
4be0: 70 72 69 61 74 65 20 68 61 73 68 20 67 69 76 65 priate hash give
4bf0: 6e 20 61 20 70 61 67 65 20 22 2a 73 65 73 73 69 n a page "*sessi
4c00: 6f 6e 76 61 72 73 2a 2c 20 2a 67 6c 6f 62 61 6c onvars*, *global
4c10: 76 61 72 73 2a 20 6f 72 20 70 61 67 65 0a 3b 3b vars* or page.;;
4c20: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
4c30: 6e 3a 67 65 74 2d 70 61 67 65 2d 68 61 73 68 20 n:get-page-hash
4c40: 73 65 6c 66 20 70 61 67 65 29 0a 20 20 28 69 66 self page). (if
4c50: 20 28 73 74 72 69 6e 67 3d 3f 20 70 61 67 65 20 (string=? page
4c60: 22 2a 73 65 73 73 69 6f 6e 76 61 72 73 2a 22 29 "*sessionvars*")
4c70: 0a 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 . (sdat-get
4c80: 2d 73 65 73 73 69 6f 6e 76 61 72 73 20 73 65 6c -sessionvars sel
4c90: 66 29 0a 20 20 20 20 20 20 28 69 66 20 28 73 74 f). (if (st
4ca0: 72 69 6e 67 3d 3f 20 70 61 67 65 20 22 2a 67 6c ring=? page "*gl
4cb0: 6f 62 61 6c 76 61 72 73 2a 22 29 0a 09 20 20 28 obalvars*").. (
4cc0: 73 64 61 74 2d 67 65 74 2d 67 6c 6f 62 61 6c 76 sdat-get-globalv
4cd0: 61 72 73 20 73 65 6c 66 29 0a 09 20 20 28 73 64 ars self).. (sd
4ce0: 61 74 2d 67 65 74 2d 70 61 67 65 76 61 72 73 20 at-get-pagevars
4cf0: 73 65 6c 66 29 29 29 29 0a 0a 3b 3b 20 73 65 74 self))))..;; set
4d00: 20 61 20 73 65 73 73 69 6f 6e 20 76 61 72 20 66 a session var f
4d10: 6f 72 20 61 20 67 69 76 65 6e 20 70 61 67 65 0a or a given page.
4d20: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 ;;.(define (sess
4d30: 69 6f 6e 3a 73 65 74 21 20 73 65 6c 66 20 70 61 ion:set! self pa
4d40: 67 65 20 6b 65 79 20 76 61 6c 75 65 29 0a 20 20 ge key value).
4d50: 28 6c 65 74 20 28 28 68 74 20 28 73 65 73 73 69 (let ((ht (sessi
4d60: 6f 6e 3a 67 65 74 2d 70 61 67 65 2d 68 61 73 68 on:get-page-hash
4d70: 20 73 65 6c 66 20 70 61 67 65 29 29 29 0a 20 20 self page))).
4d80: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
4d90: 74 21 20 68 74 20 28 73 3a 61 6e 79 2d 3e 73 74 t! ht (s:any->st
4da0: 72 69 6e 67 20 6b 65 79 29 20 28 73 3a 61 6e 79 ring key) (s:any
4db0: 2d 3e 73 74 72 69 6e 67 20 76 61 6c 75 65 29 29 ->string value))
4dc0: 29 29 0a 0a 3b 3b 20 67 65 74 20 73 65 73 73 69 ))..;; get sessi
4dd0: 6f 6e 20 76 61 72 73 20 66 6f 72 20 74 68 65 20 on vars for the
4de0: 63 75 72 72 65 6e 74 20 70 61 67 65 0a 3b 3b 0a current page.;;.
4df0: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
4e00: 3a 70 61 67 65 2d 67 65 74 20 73 65 6c 66 20 6b :page-get self k
4e10: 65 79 29 0a 20 20 28 68 61 73 68 2d 74 61 62 6c ey). (hash-tabl
4e20: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 28 73 e-ref/default (s
4e30: 64 61 74 2d 67 65 74 2d 70 61 67 65 76 61 72 73 dat-get-pagevars
4e40: 20 73 65 6c 66 29 20 6b 65 79 20 23 66 29 29 0a self) key #f)).
4e50: 0a 3b 3b 20 67 65 74 20 73 65 73 73 69 6f 6e 20 .;; get session
4e60: 76 61 72 73 20 66 6f 72 20 61 20 73 70 65 63 69 vars for a speci
4e70: 66 69 65 64 20 70 61 67 65 0a 3b 3b 0a 28 64 65 fied page.;;.(de
4e80: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 fine (session:ge
4e90: 74 20 73 65 6c 66 20 70 61 67 65 20 6b 65 79 29 t self page key)
4ea0: 0a 20 20 28 6c 65 74 20 28 28 68 74 20 28 73 65 . (let ((ht (se
4eb0: 73 73 69 6f 6e 3a 67 65 74 2d 70 61 67 65 2d 68 ssion:get-page-h
4ec0: 61 73 68 20 73 65 6c 66 20 70 61 67 65 29 29 29 ash self page)))
4ed0: 0a 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 . (hash-table
4ee0: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 68 74 20 -ref/default ht
4ef0: 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6b (s:any->string k
4f00: 65 79 29 20 23 66 29 29 29 0a 0a 3b 3b 20 64 65 ey) #f)))..;; de
4f10: 6c 65 74 65 20 61 20 73 65 73 73 69 6f 6e 20 76 lete a session v
4f20: 61 72 20 66 6f 72 20 61 20 73 70 65 63 69 66 69 ar for a specifi
4f30: 65 64 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 69 ed page.;;.(defi
4f40: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 64 65 6c 21 ne (session:del!
4f50: 20 73 65 6c 66 20 70 61 67 65 20 6b 65 79 29 0a self page key).
4f60: 20 20 28 6c 65 74 20 28 28 68 74 20 28 73 65 73 (let ((ht (ses
4f70: 73 69 6f 6e 3a 67 65 74 2d 70 61 67 65 2d 68 61 sion:get-page-ha
4f80: 73 68 20 73 65 6c 66 20 70 61 67 65 29 29 29 0a sh self page))).
4f90: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
4fa0: 64 65 6c 65 74 65 21 20 68 74 20 28 73 3a 61 6e delete! ht (s:an
4fb0: 79 2d 3e 73 74 72 69 6e 67 20 6b 65 79 29 29 29 y->string key)))
4fc0: 29 0a 0a 3b 3b 20 67 65 74 20 41 4c 4c 20 6b 65 )..;; get ALL ke
4fd0: 79 73 20 66 6f 72 20 74 68 69 73 20 70 61 67 65 ys for this page
4fe0: 20 61 6e 64 20 73 74 6f 72 65 20 69 6e 20 74 68 and store in th
4ff0: 65 20 73 65 73 73 69 6f 6e 20 70 61 67 65 76 61 e session pageva
5000: 72 73 20 68 61 73 68 0a 3b 3b 0a 28 64 65 66 69 rs hash.;;.(defi
5010: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d ne (session:get-
5020: 76 61 72 73 20 73 65 6c 66 29 0a 20 20 28 6c 65 vars self). (le
5030: 74 20 28 28 73 65 73 73 69 6f 6e 2d 69 64 20 20 t ((session-id
5040: 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f (sdat-get-sessio
5050: 6e 2d 69 64 20 73 65 6c 66 29 29 29 0a 20 20 20 n-id self))).
5060: 20 28 69 66 20 28 6e 6f 74 20 73 65 73 73 69 6f (if (not sessio
5070: 6e 2d 69 64 29 0a 09 28 65 72 72 3a 6c 6f 67 20 n-id)..(err:log
5080: 22 45 52 52 4f 52 3a 20 4e 6f 20 73 65 73 73 69 "ERROR: No sessi
5090: 6f 6e 20 69 64 20 69 6e 20 73 65 73 73 69 6f 6e on id in session
50a0: 20 6f 62 6a 65 63 74 21 20 73 65 73 73 69 6f 6e object! session
50b0: 3a 67 65 74 2d 76 61 72 73 22 29 0a 09 28 6c 65 :get-vars")..(le
50c0: 74 2a 20 28 28 72 65 73 75 6c 74 20 20 20 20 20 t* ((result
50d0: 20 20 20 20 20 20 20 20 23 66 29 0a 09 20 20 20 #f)..
50e0: 20 20 20 20 28 63 6f 6e 6e 20 20 20 20 20 20 20 (conn
50f0: 20 20 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 (sdat-ge
5100: 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 0a 09 20 t-conn self))..
5110: 20 20 20 20 20 20 28 70 61 67 65 76 61 72 73 2d (pagevars-
5120: 62 65 66 6f 72 65 20 20 20 20 28 73 64 61 74 2d before (sdat-
5130: 67 65 74 2d 70 61 67 65 76 61 72 73 2d 62 65 66 get-pagevars-bef
5140: 6f 72 65 20 73 65 6c 66 29 29 0a 09 20 20 20 20 ore self))..
5150: 20 20 20 28 73 65 73 73 69 6f 6e 76 61 72 73 2d (sessionvars-
5160: 62 65 66 6f 72 65 20 28 73 64 61 74 2d 67 65 74 before (sdat-get
5170: 2d 73 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 -sessionvars-bef
5180: 6f 72 65 20 73 65 6c 66 29 29 0a 09 20 20 20 20 ore self))..
5190: 20 20 20 28 67 6c 6f 62 61 6c 76 61 72 73 2d 62 (globalvars-b
51a0: 65 66 6f 72 65 20 20 28 73 64 61 74 2d 67 65 74 efore (sdat-get
51b0: 2d 67 6c 6f 62 61 6c 76 61 72 73 2d 62 65 66 6f -globalvars-befo
51c0: 72 65 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 re self))..
51d0: 20 20 28 70 61 67 65 76 61 72 73 20 20 20 20 20 (pagevars
51e0: 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d (sdat-get-
51f0: 70 61 67 65 76 61 72 73 20 73 65 6c 66 29 29 0a pagevars self)).
5200: 09 20 20 20 20 20 20 20 28 73 65 73 73 69 6f 6e . (session
5210: 76 61 72 73 20 20 20 20 20 20 20 20 28 73 64 61 vars (sda
5220: 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 t-get-sessionvar
5230: 73 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 20 s self))..
5240: 20 28 67 6c 6f 62 61 6c 76 61 72 73 20 20 20 20 (globalvars
5250: 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d 67 (sdat-get-g
5260: 6c 6f 62 61 6c 76 61 72 73 20 73 65 6c 66 29 29 lobalvars self))
5270: 0a 09 20 20 20 20 20 20 20 28 70 61 67 65 2d 6e .. (page-n
5280: 61 6d 65 20 20 20 20 20 20 20 20 20 20 28 73 64 ame (sd
5290: 61 74 2d 67 65 74 2d 70 61 67 65 20 73 65 6c 66 at-get-page self
52a0: 29 29 0a 09 20 20 20 20 20 20 20 28 73 65 73 73 )).. (sess
52b0: 69 6f 6e 2d 6b 65 79 20 20 20 20 20 20 20 20 28 ion-key (
52c0: 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e sdat-get-session
52d0: 2d 6b 65 79 20 73 65 6c 66 29 29 0a 09 20 20 20 -key self))..
52e0: 20 20 20 20 28 71 75 65 72 79 20 20 20 20 20 20 (query
52f0: 20 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d (string-
5300: 61 70 70 65 6e 64 0a 09 09 09 09 20 20 20 20 22 append..... "
5310: 53 45 4c 45 43 54 20 6b 65 79 2c 76 61 6c 75 65 SELECT key,value
5320: 20 46 52 4f 4d 20 73 65 73 73 69 6f 6e 5f 76 61 FROM session_va
5330: 72 73 20 49 4e 4e 45 52 20 4a 4f 49 4e 20 73 65 rs INNER JOIN se
5340: 73 73 69 6f 6e 73 20 4f 4e 20 73 65 73 73 69 6f ssions ON sessio
5350: 6e 5f 76 61 72 73 2e 73 65 73 73 69 6f 6e 5f 69 n_vars.session_i
5360: 64 3d 73 65 73 73 69 6f 6e 73 2e 69 64 20 22 0a d=sessions.id ".
5370: 09 09 09 09 20 20 20 20 22 57 48 45 52 45 20 73 .... "WHERE s
5380: 65 73 73 69 6f 6e 5f 6b 65 79 3d 3f 20 41 4e 44 ession_key=? AND
5390: 20 70 61 67 65 3d 3f 3b 22 29 29 29 0a 09 20 20 page=?;")))..
53a0: 3b 3b 20 66 69 72 73 74 20 74 68 65 20 70 61 67 ;; first the pag
53b0: 65 20 73 70 65 63 69 66 69 63 20 76 61 72 73 0a e specific vars.
53c0: 09 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 . (dbi:for-each
53d0: 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 75 -row (lambda (tu
53e0: 70 6c 65 29 0a 09 09 09 20 20 20 20 20 20 28 6c ple).... (l
53f0: 65 74 20 28 28 6b 20 28 76 65 63 74 6f 72 2d 72 et ((k (vector-r
5400: 65 66 20 74 75 70 6c 65 20 30 29 29 0a 09 09 09 ef tuple 0))....
5410: 09 20 20 20 20 28 76 20 28 76 65 63 74 6f 72 2d . (v (vector-
5420: 72 65 66 20 74 75 70 6c 65 20 31 29 29 29 0a 09 ref tuple 1)))..
5430: 09 09 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 ...(hash-table-s
5440: 65 74 21 20 70 61 67 65 76 61 72 73 2d 62 65 66 et! pagevars-bef
5450: 6f 72 65 20 6b 20 76 29 0a 09 09 09 09 28 68 61 ore k v).....(ha
5460: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 70 61 sh-table-set! pa
5470: 67 65 76 61 72 73 20 20 20 20 20 20 20 20 6b 20 gevars k
5480: 76 29 29 29 0a 09 09 09 20 20 20 20 63 6f 6e 6e v))).... conn
5490: 0a 09 09 09 20 20 20 20 28 73 3a 73 71 6c 70 61 .... (s:sqlpa
54a0: 72 61 6d 20 71 75 65 72 79 20 73 65 73 73 69 6f ram query sessio
54b0: 6e 2d 6b 65 79 20 70 61 67 65 2d 6e 61 6d 65 29 n-key page-name)
54c0: 29 0a 09 20 20 3b 3b 20 74 68 65 6e 20 74 68 65 ).. ;; then the
54d0: 20 73 65 73 73 69 6f 6e 20 73 70 65 63 69 66 69 session specifi
54e0: 63 20 76 61 72 73 0a 09 20 20 28 64 62 69 3a 66 c vars.. (dbi:f
54f0: 6f 72 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 6d or-each-row (lam
5500: 62 64 61 20 28 74 75 70 6c 65 29 0a 09 09 09 20 bda (tuple)....
5510: 20 20 20 20 20 28 6c 65 74 20 28 28 6b 20 28 76 (let ((k (v
5520: 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 ector-ref tuple
5530: 30 29 29 0a 09 09 09 09 20 20 20 20 28 76 20 28 0))..... (v (
5540: 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 vector-ref tuple
5550: 20 31 29 29 29 0a 09 09 09 09 28 68 61 73 68 2d 1))).....(hash-
5560: 74 61 62 6c 65 2d 73 65 74 21 20 73 65 73 73 69 table-set! sessi
5570: 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 20 6b 20 onvars-before k
5580: 76 29 0a 09 09 09 09 28 68 61 73 68 2d 74 61 62 v).....(hash-tab
5590: 6c 65 2d 73 65 74 21 20 73 65 73 73 69 6f 6e 76 le-set! sessionv
55a0: 61 72 73 20 20 20 20 20 20 20 20 6b 20 76 29 29 ars k v))
55b0: 29 0a 09 09 09 20 20 20 20 63 6f 6e 6e 0a 09 09 ).... conn...
55c0: 09 20 20 20 20 28 73 3a 73 71 6c 70 61 72 61 6d . (s:sqlparam
55d0: 20 71 75 65 72 79 20 73 65 73 73 69 6f 6e 2d 6b query session-k
55e0: 65 79 20 22 2a 73 65 73 73 69 6f 6e 76 61 72 73 ey "*sessionvars
55f0: 2a 22 29 29 0a 09 20 20 3b 3b 20 61 6e 64 20 66 *")).. ;; and f
5600: 69 6e 61 6c 6c 79 20 74 68 65 20 67 6c 6f 62 61 inally the globa
5610: 6c 20 76 61 72 73 0a 09 20 20 28 64 62 69 3a 66 l vars.. (dbi:f
5620: 6f 72 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 6d or-each-row (lam
5630: 62 64 61 20 28 74 75 70 6c 65 29 0a 09 09 09 20 bda (tuple)....
5640: 20 20 20 20 20 28 6c 65 74 20 28 28 6b 20 28 76 (let ((k (v
5650: 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 ector-ref tuple
5660: 30 29 29 0a 09 09 09 09 20 20 20 20 28 76 20 28 0))..... (v (
5670: 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 vector-ref tuple
5680: 20 31 29 29 29 0a 09 09 09 09 28 68 61 73 68 2d 1))).....(hash-
5690: 74 61 62 6c 65 2d 73 65 74 21 20 67 6c 6f 62 61 table-set! globa
56a0: 6c 76 61 72 73 2d 62 65 66 6f 72 65 20 6b 20 76 lvars-before k v
56b0: 29 0a 09 09 09 09 28 68 61 73 68 2d 74 61 62 6c ).....(hash-tabl
56c0: 65 2d 73 65 74 21 20 67 6c 6f 62 61 6c 76 61 72 e-set! globalvar
56d0: 73 20 20 20 20 20 20 20 20 6b 20 76 29 29 29 0a s k v))).
56e0: 09 09 09 20 20 20 20 63 6f 6e 6e 0a 09 09 09 20 ... conn....
56f0: 20 20 20 28 73 3a 73 71 6c 70 61 72 61 6d 20 71 (s:sqlparam q
5700: 75 65 72 79 20 73 65 73 73 69 6f 6e 2d 6b 65 79 uery session-key
5710: 20 22 2a 67 6c 6f 62 61 6c 76 61 72 73 22 29 29 "*globalvars"))
5720: 0a 09 20 20 29 29 29 29 0a 0a 28 64 65 66 69 6e .. ))))..(defin
5730: 65 20 28 73 65 73 73 69 6f 6e 3a 73 61 76 65 2d e (session:save-
5740: 76 61 72 73 20 73 65 6c 66 29 0a 20 20 28 6c 65 vars self). (le
5750: 74 20 28 28 73 65 73 73 69 6f 6e 2d 69 64 20 20 t ((session-id
5760: 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f (sdat-get-sessio
5770: 6e 2d 69 64 20 73 65 6c 66 29 29 29 0a 20 20 20 n-id self))).
5780: 20 28 69 66 20 28 6e 6f 74 20 73 65 73 73 69 6f (if (not sessio
5790: 6e 2d 69 64 29 0a 09 28 65 72 72 3a 6c 6f 67 20 n-id)..(err:log
57a0: 22 45 52 52 4f 52 3a 20 4e 6f 20 73 65 73 73 69 "ERROR: No sessi
57b0: 6f 6e 20 69 64 20 69 6e 20 73 65 73 73 69 6f 6e on id in session
57c0: 20 6f 62 6a 65 63 74 21 20 73 65 73 73 69 6f 6e object! session
57d0: 3a 67 65 74 2d 76 61 72 73 22 29 0a 09 28 6c 65 :get-vars")..(le
57e0: 74 2a 20 28 28 73 74 61 74 75 73 20 20 20 20 20 t* ((status
57f0: 20 23 66 29 0a 09 20 20 20 20 20 20 20 28 63 6f #f).. (co
5800: 6e 6e 20 20 20 20 20 20 20 20 28 73 64 61 74 2d nn (sdat-
5810: 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 0a get-conn self)).
5820: 09 20 20 20 20 20 20 20 28 70 61 67 65 2d 6e 61 . (page-na
5830: 6d 65 20 20 20 28 73 64 61 74 2d 67 65 74 2d 70 me (sdat-get-p
5840: 61 67 65 20 73 65 6c 66 29 29 0a 09 20 20 20 20 age self))..
5850: 20 20 20 28 64 65 6c 2d 71 75 65 72 79 20 20 20 (del-query
5860: 22 44 45 4c 45 54 45 20 46 52 4f 4d 20 73 65 73 "DELETE FROM ses
5870: 73 69 6f 6e 5f 76 61 72 73 20 57 48 45 52 45 20 sion_vars WHERE
5880: 73 65 73 73 69 6f 6e 5f 69 64 3d 3f 20 41 4e 44 session_id=? AND
5890: 20 70 61 67 65 3d 3f 20 41 4e 44 20 6b 65 79 3d page=? AND key=
58a0: 3f 3b 22 29 0a 09 20 20 20 20 20 20 20 28 69 6e ?;").. (in
58b0: 73 2d 71 75 65 72 79 20 20 20 22 49 4e 53 45 52 s-query "INSER
58c0: 54 20 49 4e 54 4f 20 73 65 73 73 69 6f 6e 5f 76 T INTO session_v
58d0: 61 72 73 20 28 73 65 73 73 69 6f 6e 5f 69 64 2c ars (session_id,
58e0: 70 61 67 65 2c 6b 65 79 2c 76 61 6c 75 65 29 20 page,key,value)
58f0: 56 41 4c 55 45 53 28 3f 2c 3f 2c 3f 2c 3f 29 3b VALUES(?,?,?,?);
5900: 22 29 0a 09 20 20 20 20 20 20 20 28 75 70 64 2d ").. (upd-
5910: 71 75 65 72 79 20 20 20 22 55 50 44 41 54 45 20 query "UPDATE
5920: 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 73 65 74 session_vars set
5930: 20 76 61 6c 75 65 3d 3f 20 57 48 45 52 45 20 6b value=? WHERE k
5940: 65 79 3d 3f 20 41 4e 44 20 73 65 73 73 69 6f 6e ey=? AND session
5950: 5f 69 64 3d 3f 20 41 4e 44 20 70 61 67 65 3d 3f _id=? AND page=?
5960: 3b 22 29 0a 09 20 20 20 20 20 20 20 28 63 68 61 ;").. (cha
5970: 6e 67 65 64 2d 63 6f 75 6e 74 20 30 29 29 0a 09 nged-count 0))..
5980: 20 20 3b 3b 20 73 61 76 65 20 74 68 65 20 64 65 ;; save the de
5990: 6c 74 61 20 6f 6e 6c 79 0a 09 20 20 28 66 6f 72 lta only.. (for
59a0: 2d 65 61 63 68 0a 09 20 20 20 28 6c 61 6d 62 64 -each.. (lambd
59b0: 61 20 28 70 61 67 65 29 20 3b 3b 20 70 61 67 65 a (page) ;; page
59c0: 20 69 73 3a 20 22 2a 67 6c 6f 62 61 6c 76 61 72 is: "*globalvar
59d0: 73 2a 22 20 22 2a 73 65 73 73 69 6f 6e 76 61 72 s*" "*sessionvar
59e0: 73 2a 22 20 6f 72 20 6f 74 68 65 72 73 74 72 69 s*" or otherstri
59f0: 6e 67 0a 09 20 20 20 20 20 28 6c 65 74 2a 20 28 ng.. (let* (
5a00: 28 62 65 66 6f 72 65 2d 61 66 74 65 72 2d 68 74 (before-after-ht
5a10: 20 28 63 6f 6e 64 0a 09 09 09 09 20 20 20 20 20 (cond.....
5a20: 20 28 28 73 74 72 69 6e 67 3d 3f 20 70 61 67 65 ((string=? page
5a30: 20 22 2a 73 65 73 73 69 6f 6e 76 61 72 73 2a 22 "*sessionvars*"
5a40: 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 76 65 )..... (ve
5a50: 63 74 6f 72 20 28 73 64 61 74 2d 67 65 74 2d 73 ctor (sdat-get-s
5a60: 65 73 73 69 6f 6e 76 61 72 73 20 73 65 6c 66 29 essionvars self)
5a70: 0a 09 09 09 09 09 20 20 20 20 20 20 20 28 73 64 ...... (sd
5a80: 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 at-get-sessionva
5a90: 72 73 2d 62 65 66 6f 72 65 20 73 65 6c 66 29 29 rs-before self))
5aa0: 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 28 73 )..... ((s
5ab0: 74 72 69 6e 67 3d 3f 20 70 61 67 65 20 22 2a 67 tring=? page "*g
5ac0: 6c 6f 62 61 6c 76 61 72 73 2a 22 29 0a 09 09 09 lobalvars*")....
5ad0: 09 09 28 76 65 63 74 6f 72 20 28 73 64 61 74 2d ..(vector (sdat-
5ae0: 67 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 20 73 get-globalvars s
5af0: 65 6c 66 29 0a 09 09 09 09 09 09 28 73 64 61 74 elf).......(sdat
5b00: 2d 67 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 2d -get-globalvars-
5b10: 62 65 66 6f 72 65 20 73 65 6c 66 29 29 29 0a 09 before self)))..
5b20: 09 09 09 20 20 20 20 20 20 20 28 65 6c 73 65 20 ... (else
5b30: 0a 09 09 09 09 09 28 76 65 63 74 6f 72 20 28 73 ......(vector (s
5b40: 64 61 74 2d 67 65 74 2d 70 61 67 65 76 61 72 73 dat-get-pagevars
5b50: 20 73 65 6c 66 29 0a 09 09 09 09 09 09 28 73 64 self).......(sd
5b60: 61 74 2d 67 65 74 2d 70 61 67 65 76 61 72 73 2d at-get-pagevars-
5b70: 62 65 66 6f 72 65 20 73 65 6c 66 29 29 29 29 29 before self)))))
5b80: 0a 09 09 20 20 20 20 28 6d 61 73 74 65 72 2d 68 ... (master-h
5b90: 74 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 t (vector-ref
5ba0: 62 65 66 6f 72 65 2d 61 66 74 65 72 2d 68 74 20 before-after-ht
5bb0: 30 29 29 0a 09 09 20 20 20 20 28 62 65 66 6f 72 0))... (befor
5bc0: 65 2d 68 74 20 20 20 28 76 65 63 74 6f 72 2d 72 e-ht (vector-r
5bd0: 65 66 20 62 65 66 6f 72 65 2d 61 66 74 65 72 2d ef before-after-
5be0: 68 74 20 31 29 29 0a 09 09 20 20 20 20 28 6d 61 ht 1))... (ma
5bf0: 73 74 65 72 2d 6b 65 79 73 20 28 68 61 73 68 2d ster-keys (hash-
5c00: 74 61 62 6c 65 2d 6b 65 79 73 20 6d 61 73 74 65 table-keys maste
5c10: 72 2d 68 74 29 29 0a 09 09 20 20 20 20 28 62 65 r-ht))... (be
5c20: 66 6f 72 65 2d 6b 65 79 73 20 28 68 61 73 68 2d fore-keys (hash-
5c30: 74 61 62 6c 65 2d 6b 65 79 73 20 62 65 66 6f 72 table-keys befor
5c40: 65 2d 68 74 29 29 0a 09 09 20 20 20 20 28 61 6c e-ht))... (al
5c50: 6c 2d 6b 65 79 73 20 28 64 65 6c 65 74 65 2d 64 l-keys (delete-d
5c60: 75 70 6c 69 63 61 74 65 73 20 28 61 70 70 65 6e uplicates (appen
5c70: 64 20 6d 61 73 74 65 72 2d 6b 65 79 73 20 62 65 d master-keys be
5c80: 66 6f 72 65 2d 6b 65 79 73 29 29 29 29 0a 09 20 fore-keys))))..
5c90: 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 (for-each
5ca0: 0a 09 09 28 6c 61 6d 62 64 61 20 28 6b 65 79 29 ...(lambda (key)
5cb0: 0a 09 09 20 20 28 6c 65 74 20 28 28 6d 61 73 74 ... (let ((mast
5cc0: 65 72 2d 76 61 6c 75 65 20 28 68 61 73 68 2d 74 er-value (hash-t
5cd0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
5ce0: 20 6d 61 73 74 65 72 2d 68 74 20 6b 65 79 20 23 master-ht key #
5cf0: 66 29 29 0a 09 09 09 28 62 65 66 6f 72 65 2d 76 f))....(before-v
5d00: 61 6c 75 65 20 28 68 61 73 68 2d 74 61 62 6c 65 alue (hash-table
5d10: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 62 65 66 -ref/default bef
5d20: 6f 72 65 2d 68 74 20 6b 65 79 20 23 66 29 29 29 ore-ht key #f)))
5d30: 0a 09 09 20 20 20 20 28 63 6f 6e 64 0a 09 09 20 ... (cond...
5d40: 20 20 20 20 3b 3b 20 62 65 66 6f 72 65 20 61 6e ;; before an
5d50: 64 20 61 66 74 65 72 20 65 78 69 73 74 20 61 6e d after exist an
5d60: 64 20 76 61 6c 75 65 20 75 6e 63 68 61 6e 67 65 d value unchange
5d70: 64 20 2d 20 64 6f 20 6e 6f 74 68 69 6e 67 0a 09 d - do nothing..
5d80: 09 20 20 20 20 20 28 28 61 6e 64 20 6d 61 73 74 . ((and mast
5d90: 65 72 2d 76 61 6c 75 65 20 62 65 66 6f 72 65 2d er-value before-
5da0: 76 61 6c 75 65 20 28 65 71 75 61 6c 3f 20 6d 61 value (equal? ma
5db0: 73 74 65 72 2d 76 61 6c 75 65 20 62 65 66 6f 72 ster-value befor
5dc0: 65 2d 76 61 6c 75 65 29 29 29 0a 09 09 20 20 20 e-value)))...
5dd0: 20 20 3b 3b 20 62 65 66 6f 72 65 20 61 6e 64 20 ;; before and
5de0: 61 66 74 65 72 20 65 78 69 73 74 20 62 75 74 20 after exist but
5df0: 61 72 65 20 63 68 61 6e 67 65 64 0a 09 09 20 20 are changed...
5e00: 20 20 20 28 28 61 6e 64 20 6d 61 73 74 65 72 2d ((and master-
5e10: 76 61 6c 75 65 20 62 65 66 6f 72 65 2d 76 61 6c value before-val
5e20: 75 65 29 0a 09 09 20 20 20 20 20 20 28 64 62 69 ue)... (dbi
5e30: 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 28 6c :for-each-row (l
5e40: 61 6d 62 64 61 20 28 74 75 70 6c 65 29 0a 09 09 ambda (tuple)...
5e50: 09 09 09 20 20 28 73 65 74 21 20 63 68 61 6e 67 ... (set! chang
5e60: 65 64 2d 63 6f 75 6e 74 20 28 2b 20 63 68 61 6e ed-count (+ chan
5e70: 67 65 64 2d 63 6f 75 6e 74 20 31 29 29 29 0a 09 ged-count 1)))..
5e80: 09 09 09 09 63 6f 6e 6e 0a 09 09 09 09 09 28 73 ....conn......(s
5e90: 3a 73 71 6c 70 61 72 61 6d 20 75 70 64 2d 71 75 :sqlparam upd-qu
5ea0: 65 72 79 20 6d 61 73 74 65 72 2d 76 61 6c 75 65 ery master-value
5eb0: 20 6b 65 79 20 73 65 73 73 69 6f 6e 2d 69 64 20 key session-id
5ec0: 70 61 67 65 29 29 29 0a 09 09 20 20 20 20 20 3b page)))... ;
5ed0: 3b 20 6d 61 73 74 65 72 2d 76 61 6c 75 65 20 6e ; master-value n
5ee0: 6f 20 6c 6f 6e 67 65 72 20 65 78 69 73 74 73 20 o longer exists
5ef0: 28 69 2e 65 2e 20 23 66 29 20 2d 20 72 65 6d 6f (i.e. #f) - remo
5f00: 76 65 20 69 74 65 6d 0a 09 09 20 20 20 20 20 28 ve item... (
5f10: 28 6e 6f 74 20 6d 61 73 74 65 72 2d 76 61 6c 75 (not master-valu
5f20: 65 29 0a 09 09 20 20 20 20 20 20 28 64 62 69 3a e)... (dbi:
5f30: 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 for-each-row (la
5f40: 6d 62 64 61 20 28 74 75 70 6c 65 29 0a 09 09 09 mbda (tuple)....
5f50: 09 09 20 20 28 73 65 74 21 20 63 68 61 6e 67 65 .. (set! change
5f60: 64 2d 63 6f 75 6e 74 20 28 2b 20 63 68 61 6e 67 d-count (+ chang
5f70: 65 64 2d 63 6f 75 6e 74 20 31 29 29 29 0a 09 09 ed-count 1)))...
5f80: 09 09 09 63 6f 6e 6e 0a 09 09 09 09 09 28 73 3a ...conn......(s:
5f90: 73 71 6c 70 61 72 61 6d 20 64 65 6c 2d 71 75 65 sqlparam del-que
5fa0: 72 79 20 73 65 73 73 69 6f 6e 2d 69 64 20 70 61 ry session-id pa
5fb0: 67 65 20 6b 65 79 29 29 29 0a 09 09 20 20 20 20 ge key)))...
5fc0: 20 3b 3b 20 62 65 66 6f 72 65 2d 76 61 6c 75 65 ;; before-value
5fd0: 20 64 6f 65 73 6e 27 74 20 65 78 69 73 74 20 2d doesn't exist -
5fe0: 20 69 6e 73 65 72 74 20 61 20 6e 65 77 20 76 61 insert a new va
5ff0: 6c 75 65 0a 09 09 20 20 20 20 20 28 28 6e 6f 74 lue... ((not
6000: 20 62 65 66 6f 72 65 2d 76 61 6c 75 65 29 0a 09 before-value)..
6010: 09 20 20 20 20 20 20 28 64 62 69 3a 66 6f 72 2d . (dbi:for-
6020: 65 61 63 68 2d 72 6f 77 20 28 6c 61 6d 62 64 61 each-row (lambda
6030: 20 28 74 75 70 6c 65 29 0a 09 09 09 09 09 20 20 (tuple)......
6040: 28 73 65 74 21 20 63 68 61 6e 67 65 64 2d 63 6f (set! changed-co
6050: 75 6e 74 20 28 2b 20 63 68 61 6e 67 65 64 2d 63 unt (+ changed-c
6060: 6f 75 6e 74 20 31 29 29 29 0a 09 09 09 09 09 63 ount 1)))......c
6070: 6f 6e 6e 0a 09 09 09 09 09 28 73 3a 73 71 6c 70 onn......(s:sqlp
6080: 61 72 61 6d 20 69 6e 73 2d 71 75 65 72 79 20 73 aram ins-query s
6090: 65 73 73 69 6f 6e 2d 69 64 20 70 61 67 65 20 6b ession-id page k
60a0: 65 79 20 6d 61 73 74 65 72 2d 76 61 6c 75 65 29 ey master-value)
60b0: 29 29 0a 09 09 20 20 20 20 20 28 65 6c 73 65 20 ))... (else
60c0: 28 65 72 72 3a 6c 6f 67 20 22 53 68 6f 75 6c 64 (err:log "Should
60d0: 6e 27 74 20 67 65 74 20 68 65 72 65 22 29 29 29 n't get here")))
60e0: 29 29 0a 09 09 61 6c 6c 2d 6b 65 79 73 29 29 29 ))...all-keys)))
60f0: 20 3b 3b 20 70 72 6f 63 65 73 73 20 61 6c 6c 20 ;; process all
6100: 6b 65 79 73 0a 09 20 20 20 28 6c 69 73 74 20 22 keys.. (list "
6110: 2a 73 65 73 73 69 6f 6e 76 61 72 73 2a 22 20 22 *sessionvars*" "
6120: 2a 67 6c 6f 62 61 6c 76 61 72 73 2a 22 20 70 61 *globalvars*" pa
6130: 67 65 2d 6e 61 6d 65 29 29 29 29 29 29 0a 0a 3b ge-name))))))..;
6140: 3b 20 28 70 67 3a 73 71 6c 2d 6e 75 6c 6c 2d 6f ; (pg:sql-null-o
6150: 62 6a 65 63 74 3f 20 65 6c 65 6d 65 6e 74 29 0a bject? element).
6160: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
6170: 3a 72 65 61 64 2d 63 6f 6e 66 69 67 20 73 65 6c :read-config sel
6180: 66 29 0a 20 20 28 6c 65 74 20 28 28 6e 61 6d 65 f). (let ((name
6190: 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 (string-append
61a0: 22 2e 22 20 28 70 61 74 68 6e 61 6d 65 2d 66 69 "." (pathname-fi
61b0: 6c 65 20 28 63 61 72 20 28 61 72 67 76 29 29 29 le (car (argv)))
61c0: 20 22 2e 63 6f 6e 66 69 67 22 29 29 29 0a 20 20 ".config"))).
61d0: 20 20 28 69 66 20 28 6e 6f 74 20 28 66 69 6c 65 (if (not (file
61e0: 2d 65 78 69 73 74 73 3f 20 6e 61 6d 65 29 29 0a -exists? name)).
61f0: 09 28 70 72 69 6e 74 20 6e 61 6d 65 20 22 20 6e .(print name " n
6200: 6f 74 20 66 6f 75 6e 64 20 61 74 20 22 20 28 63 ot found at " (c
6210: 75 72 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 79 urrent-directory
6220: 29 29 0a 09 28 6c 65 74 2a 20 28 28 66 70 20 28 ))..(let* ((fp (
6230: 6f 70 65 6e 2d 69 6e 70 75 74 2d 66 69 6c 65 20 open-input-file
6240: 6e 61 6d 65 29 29 0a 09 20 20 20 20 20 20 20 28 name)).. (
6250: 69 6e 69 74 61 72 67 73 20 28 72 65 61 64 20 66 initargs (read f
6260: 70 29 29 29 0a 09 20 20 28 63 6c 6f 73 65 2d 69 p))).. (close-i
6270: 6e 70 75 74 2d 70 6f 72 74 20 66 70 29 0a 09 20 nput-port fp)..
6280: 20 69 6e 69 74 61 72 67 73 29 29 29 29 0a 0a 3b initargs))))..;
6290: 3b 20 63 61 6c 6c 20 74 68 65 20 63 6f 6e 74 72 ; call the contr
62a0: 6f 6c 6c 65 72 20 69 66 20 69 74 20 65 78 69 73 oller if it exis
62b0: 74 73 0a 3b 3b 20 0a 3b 3b 20 57 41 52 4e 49 4e ts.;; .;; WARNIN
62c0: 47 20 2d 20 74 68 69 73 20 63 6f 64 65 20 6e 65 G - this code ne
62d0: 65 64 73 20 61 20 64 65 66 65 6e 63 65 20 61 67 eds a defence ag
62e0: 61 69 6e 73 20 72 65 63 75 72 73 69 76 65 20 63 ains recursive c
62f0: 61 6c 6c 69 6e 67 21 21 21 21 21 0a 3b 3b 0a 3b alling!!!!!.;;.;
6300: 3b 20 20 20 49 20 73 75 67 67 65 73 74 20 61 20 ; I suggest a
6310: 6c 69 6d 69 74 20 6f 66 20 31 30 30 20 63 61 6c limit of 100 cal
6320: 6c 73 2e 20 50 6c 65 6e 74 79 20 66 6f 72 20 61 ls. Plenty for a
6330: 6c 6c 6f 77 69 6e 67 20 6d 75 6c 74 69 70 6c 65 llowing multiple
6340: 20 69 6e 73 74 61 6e 63 65 73 0a 3b 3b 20 20 20 instances.;;
6350: 6f 66 20 61 20 70 61 67 65 20 69 6e 73 69 64 65 of a page inside
6360: 20 61 6e 6f 74 68 65 72 20 70 61 67 65 2e 20 0a another page. .
6370: 3b 3b 0a 3b 3b 20 70 61 72 74 73 20 3d 20 27 62 ;;.;; parts = 'b
6380: 6f 74 68 20 7c 20 27 63 6f 6e 74 72 6f 6c 20 7c oth | 'control |
6390: 20 27 76 69 65 77 0a 3b 3b 0a 0a 28 64 65 66 69 'view.;;..(defi
63a0: 6e 65 20 28 66 69 6c 65 73 2d 72 65 61 64 2d 3e ne (files-read->
63b0: 73 74 72 69 6e 67 20 2e 20 66 69 6c 65 73 29 0a string . files).
63c0: 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 (string-inters
63d0: 70 65 72 73 65 20 0a 20 20 20 28 61 70 70 6c 79 perse . (apply
63e0: 20 61 70 70 65 6e 64 20 28 6d 61 70 20 66 69 6c append (map fil
63f0: 65 2d 72 65 61 64 2d 3e 73 74 72 69 6e 67 20 66 e-read->string f
6400: 69 6c 65 73 29 29 20 22 5c 6e 22 29 29 0a 0a 28 iles)) "\n"))..(
6410: 64 65 66 69 6e 65 20 28 66 69 6c 65 2d 72 65 61 define (file-rea
6420: 64 2d 3e 73 74 72 69 6e 67 20 66 29 20 0a 20 20 d->string f) .
6430: 28 6c 65 74 20 28 28 70 20 28 6f 70 65 6e 2d 69 (let ((p (open-i
6440: 6e 70 75 74 2d 66 69 6c 65 20 66 29 29 29 0a 20 nput-file f))).
6450: 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 (let loop ((h
6460: 65 64 20 28 72 65 61 64 2d 6c 69 6e 65 20 70 29 ed (read-line p)
6470: 29 0a 09 20 20 20 20 20 20 20 28 72 65 73 20 27 ).. (res '
6480: 28 29 29 29 0a 20 20 20 20 20 20 28 69 66 20 28 ())). (if (
6490: 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 68 65 64 29 eof-object? hed)
64a0: 0a 09 20 20 72 65 73 0a 09 20 20 28 6c 6f 6f 70 .. res.. (loop
64b0: 20 28 72 65 61 64 2d 6c 69 6e 65 20 70 29 28 61 (read-line p)(a
64c0: 70 70 65 6e 64 20 72 65 73 20 28 6c 69 73 74 20 ppend res (list
64d0: 68 65 64 29 29 29 29 29 29 29 0a 0a 28 64 65 66 hed)))))))..(def
64e0: 69 6e 65 20 28 70 72 6f 63 65 73 73 2d 70 6f 72 ine (process-por
64f0: 74 20 70 29 0a 20 20 28 6c 65 74 20 28 28 65 20 t p). (let ((e
6500: 28 69 6e 74 65 72 61 63 74 69 6f 6e 2d 65 6e 76 (interaction-env
6510: 69 72 6f 6e 6d 65 6e 74 29 29 29 0a 20 20 20 20 ironment))).
6520: 28 6d 61 70 20 0a 20 20 20 20 20 28 6c 61 6d 62 (map . (lamb
6530: 64 61 20 28 78 29 0a 20 20 20 20 20 20 20 28 63 da (x). (c
6540: 6f 6e 64 0a 09 28 28 6c 69 73 74 3f 20 78 29 20 ond..((list? x)
6550: 78 29 0a 09 28 28 73 74 72 69 6e 67 3f 20 78 29 x)..((string? x)
6560: 20 78 29 0a 09 28 65 6c 73 65 20 27 28 29 29 29 x)..(else '()))
6570: 29 0a 20 20 20 20 20 28 70 6f 72 74 2d 6d 61 70 ). (port-map
6580: 20 28 6c 61 6d 62 64 61 20 28 73 29 0a 09 09 20 (lambda (s)...
6590: 28 65 76 61 6c 20 73 20 65 29 29 0a 09 20 20 20 (eval s e))..
65a0: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 28 72 (lambda ()(r
65b0: 65 61 64 20 70 29 29 29 29 29 29 0a 0a 28 64 65 ead p))))))..(de
65c0: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 70 72 fine (session:pr
65d0: 6f 63 65 73 73 2d 66 69 6c 65 20 66 29 0a 20 20 ocess-file f).
65e0: 28 6c 65 74 2a 20 28 28 70 20 20 20 20 28 6f 70 (let* ((p (op
65f0: 65 6e 2d 69 6e 70 75 74 2d 66 69 6c 65 20 66 29 en-input-file f)
6600: 29 0a 09 20 28 64 61 74 20 20 28 70 72 6f 63 65 ).. (dat (proce
6610: 73 73 2d 70 6f 72 74 20 70 29 29 29 0a 20 20 20 ss-port p))).
6620: 20 28 63 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 6f (close-input-po
6630: 72 74 20 70 29 0a 20 20 20 20 64 61 74 29 29 0a rt p). dat)).
6640: 0a 3b 3b 20 4d 61 79 20 32 30 31 31 2c 20 70 75 .;; May 2011, pu
6650: 74 74 69 6e 67 20 61 6c 6c 20 70 61 67 65 73 20 tting all pages
6660: 69 6e 74 6f 20 6f 6e 65 20 64 69 72 65 63 74 6f into one directo
6670: 72 79 20 66 6f 72 20 74 68 65 20 66 6f 6c 6c 6f ry for the follo
6680: 77 69 6e 67 20 72 65 61 73 6f 6e 73 3a 0a 3b 3b wing reasons:.;;
6690: 20 20 20 31 2e 20 77 61 6e 74 20 66 69 6c 65 6e 1. want filen
66a0: 61 6d 65 20 74 6f 20 72 65 66 6c 65 63 74 20 70 ame to reflect p
66b0: 61 67 65 20 6e 61 6d 65 20 28 65 6d 61 63 73 20 age name (emacs
66c0: 6c 69 6d 69 74 61 74 69 6f 6e 29 0a 3b 3b 20 20 limitation).;;
66d0: 20 32 2e 20 74 68 61 74 27 73 20 69 74 21 20 6e 2. that's it! n
66e0: 6f 20 6f 74 68 65 72 20 72 65 61 73 6f 6e 2e 20 o other reason.
66f0: 63 6f 75 6c 64 20 6d 61 6b 65 20 69 74 20 63 6f could make it co
6700: 6e 66 69 67 75 72 61 62 6c 65 20 2e 2e 2e 0a 3b nfigurable ....;
6710: 3b 20 70 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 ; page-dir-style
6720: 20 69 73 3a 0a 3b 3b 20 20 27 73 74 6f 72 65 64 is:.;; 'stored
6730: 20 20 20 3d 3e 20 73 74 6f 72 65 64 20 69 6e 20 => stored in
6740: 65 78 65 63 75 74 61 62 6c 65 0a 3b 3b 20 20 27 executable.;; '
6750: 66 6c 61 74 20 20 20 20 20 3d 3e 20 70 61 67 65 flat => page
6760: 73 20 66 6c 61 74 20 64 69 72 65 63 74 6f 72 79 s flat directory
6770: 0a 3b 3b 20 20 27 64 69 72 20 20 20 20 20 20 3d .;; 'dir =
6780: 3e 20 64 69 72 65 63 74 6f 72 79 20 74 72 65 65 > directory tree
6790: 20 70 61 67 65 73 2f 3c 70 61 67 65 6e 61 6d 65 pages/<pagename
67a0: 3e 2f 7b 76 69 65 77 2c 63 6f 6e 74 72 6f 6c 7d >/{view,control}
67b0: 2e 73 63 6d 0a 3b 3b 20 70 61 72 74 73 3a 0a 3b .scm.;; parts:.;
67c0: 3b 20 20 27 62 6f 74 68 20 20 20 20 20 3d 3e 20 ; 'both =>
67d0: 6c 6f 61 64 20 63 6f 6e 74 72 6f 6c 20 61 6e 64 load control and
67e0: 20 76 69 65 77 20 28 61 6e 79 74 68 69 6e 67 20 view (anything
67f0: 6f 74 68 65 72 20 74 68 61 6e 20 76 69 65 77 20 other than view
6800: 6f 72 20 63 6f 6e 74 72 6f 6c 0a 3b 3b 20 20 27 or control.;; '
6810: 76 69 65 77 20 20 20 20 20 3d 3e 20 6c 6f 61 64 view => load
6820: 20 76 69 65 77 20 6f 6e 6c 79 0a 3b 3b 20 20 27 view only.;; '
6830: 63 6f 6e 74 72 6f 6c 20 20 3d 3e 20 6c 6f 61 64 control => load
6840: 20 63 6f 6e 74 72 6f 6c 20 6f 6e 6c 79 0a 28 64 control only.(d
6850: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 63 efine (session:c
6860: 61 6c 6c 2d 70 61 72 74 73 20 73 65 6c 66 20 70 all-parts self p
6870: 61 67 65 20 23 21 6b 65 79 20 28 70 61 72 74 73 age #!key (parts
6880: 20 27 62 6f 74 68 29 29 0a 20 20 28 73 64 61 74 'both)). (sdat
6890: 2d 73 65 74 2d 63 75 72 72 2d 70 61 67 65 21 20 -set-curr-page!
68a0: 73 65 6c 66 20 70 61 67 65 29 0a 20 20 28 6c 65 self page). (le
68b0: 74 2a 20 28 28 64 69 72 2d 73 74 79 6c 65 20 20 t* ((dir-style
68c0: 20 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 (sdat-get-page
68d0: 2d 64 69 72 2d 73 74 79 6c 65 20 73 65 6c 66 29 -dir-style self)
68e0: 29 3b 3b 20 28 65 71 75 61 6c 3f 20 28 73 64 61 );; (equal? (sda
68f0: 74 2d 67 65 74 2d 70 61 67 65 2d 64 69 72 2d 73 t-get-page-dir-s
6900: 74 79 6c 65 20 73 65 6c 66 29 20 22 6f 6e 65 64 tyle self) "oned
6910: 69 72 22 29 29 20 3b 3b 20 66 6c 61 67 20 23 74 ir")) ;; flag #t
6920: 20 66 6f 72 20 6f 6e 65 64 69 72 2c 20 23 66 20 for onedir, #f
6930: 66 6f 72 20 6f 6c 64 20 73 74 79 6c 65 0a 09 20 for old style..
6940: 28 64 69 72 20 20 20 20 20 20 20 20 20 20 28 73 (dir (s
6950: 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 28 73 64 tring-append (sd
6960: 61 74 2d 67 65 74 2d 73 72 6f 6f 74 20 73 65 6c at-get-sroot sel
6970: 66 29 20 0a 09 09 09 09 20 20 20 20 20 20 28 69 f) ..... (i
6980: 66 20 64 69 72 2d 73 74 79 6c 65 20 0a 09 09 09 f dir-style ....
6990: 09 09 20 20 28 63 6f 6e 63 20 22 2f 70 61 67 65 .. (conc "/page
69a0: 73 2f 22 29 0a 09 09 09 09 09 20 20 28 63 6f 6e s/")...... (con
69b0: 63 20 22 2f 70 61 67 65 73 2f 22 20 70 61 67 65 c "/pages/" page
69c0: 29 29 29 29 29 0a 20 20 20 20 28 63 61 73 65 20 ))))). (case
69d0: 64 69 72 2d 73 74 79 6c 65 0a 20 20 20 20 20 20 dir-style.
69e0: 3b 3b 20 4e 42 2f 2f 20 53 74 6f 72 65 64 20 61 ;; NB// Stored a
69f0: 6c 77 61 79 73 20 6c 6f 61 64 73 20 62 6f 74 68 lways loads both
6a00: 20 63 6f 6e 74 72 6f 6c 20 61 6e 64 20 76 69 65 control and vie
6a10: 77 0a 20 20 20 20 20 20 28 28 73 74 6f 72 65 64 w. ((stored
6a20: 29 0a 20 20 20 20 20 20 20 28 28 65 76 61 6c 20 ). ((eval
6a30: 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 (string->symbol
6a40: 28 63 6f 6e 63 20 22 70 61 67 65 73 3a 22 20 70 (conc "pages:" p
6a50: 61 67 65 29 29 29 20 0a 09 73 65 6c 66 20 20 20 age))) ..self
6a60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6a70: 20 20 20 20 20 20 3b 3b 20 74 68 65 20 73 65 73 ;; the ses
6a80: 73 69 6f 6e 0a 09 28 73 64 61 74 2d 67 65 74 2d sion..(sdat-get-
6a90: 63 6f 6e 6e 20 73 65 6c 66 29 20 20 20 20 20 20 conn self)
6aa0: 20 20 20 3b 3b 20 74 68 65 20 64 62 20 63 6f 6e ;; the db con
6ab0: 6e 65 63 74 69 6f 6e 0a 09 28 73 64 61 74 2d 67 nection..(sdat-g
6ac0: 65 74 2d 73 68 61 72 65 64 2d 68 61 73 68 20 73 et-shared-hash s
6ad0: 65 6c 66 29 20 20 3b 3b 20 61 20 73 68 61 72 65 elf) ;; a share
6ae0: 64 20 68 61 73 68 20 74 61 62 6c 65 20 66 6f 72 d hash table for
6af0: 20 70 61 73 73 69 6e 67 20 64 61 74 61 20 74 6f passing data to
6b00: 2f 66 72 6f 6d 20 70 61 67 65 20 63 61 6c 6c 73 /from page calls
6b10: 0a 09 29 29 0a 20 20 20 20 20 20 28 28 66 6c 61 ..)). ((fla
6b20: 74 29 20 20 20 0a 20 20 20 20 20 20 20 28 6c 65 t) . (le
6b30: 74 2a 20 28 28 73 6f 2d 66 69 6c 65 20 20 28 63 t* ((so-file (c
6b40: 6f 6e 63 20 64 69 72 20 70 61 67 65 20 22 2e 73 onc dir page ".s
6b50: 6f 22 29 29 0a 09 20 20 20 20 20 20 28 73 63 6d o")).. (scm
6b60: 2d 66 69 6c 65 20 28 63 6f 6e 63 20 64 69 72 20 -file (conc dir
6b70: 70 61 67 65 20 22 2e 73 63 6d 22 29 29 0a 09 20 page ".scm"))..
6b80: 20 20 20 20 20 28 73 72 63 2d 66 69 6c 65 20 28 (src-file (
6b90: 6f 72 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f or (file-exists?
6ba0: 20 73 6f 2d 66 69 6c 65 29 0a 09 09 09 20 20 20 so-file)....
6bb0: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 73 (file-exists? s
6bc0: 63 6d 2d 66 69 6c 65 29 29 29 29 0a 09 20 28 69 cm-file)))).. (i
6bd0: 66 20 73 72 63 2d 66 69 6c 65 0a 09 20 20 20 20 f src-file..
6be0: 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 20 (begin..
6bf0: 28 6c 6f 61 64 20 73 72 63 2d 66 69 6c 65 29 0a (load src-file).
6c00: 09 20 20 20 20 20 20 20 28 28 65 76 61 6c 20 28 . ((eval (
6c10: 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 string->symbol (
6c20: 63 6f 6e 63 20 22 70 61 67 65 73 3a 22 20 70 61 conc "pages:" pa
6c30: 67 65 29 29 29 20 0a 09 09 73 65 6c 66 20 20 20 ge))) ...self
6c40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6c50: 20 20 20 20 20 20 3b 3b 20 74 68 65 20 73 65 73 ;; the ses
6c60: 73 69 6f 6e 0a 09 09 28 73 64 61 74 2d 67 65 74 sion...(sdat-get
6c70: 2d 63 6f 6e 6e 20 73 65 6c 66 29 20 20 20 20 20 -conn self)
6c80: 20 20 20 20 3b 3b 20 74 68 65 20 64 62 20 63 6f ;; the db co
6c90: 6e 6e 65 63 74 69 6f 6e 0a 09 09 28 73 64 61 74 nnection...(sdat
6ca0: 2d 67 65 74 2d 73 68 61 72 65 64 2d 68 61 73 68 -get-shared-hash
6cb0: 20 73 65 6c 66 29 20 20 3b 3b 20 61 20 73 68 61 self) ;; a sha
6cc0: 72 65 64 20 68 61 73 68 20 74 61 62 6c 65 20 66 red hash table f
6cd0: 6f 72 20 70 61 73 73 69 6e 67 20 64 61 74 61 20 or passing data
6ce0: 74 6f 2f 66 72 6f 6d 20 70 61 67 65 20 63 61 6c to/from page cal
6cf0: 6c 73 0a 09 09 29 29 0a 09 20 20 20 20 20 28 6c ls...)).. (l
6d00: 69 73 74 20 22 3c 70 3e 50 61 67 65 20 6e 6f 74 ist "<p>Page not
6d10: 20 66 6f 75 6e 64 20 22 20 70 61 67 65 20 22 20 found " page "
6d20: 3c 2f 70 3e 22 29 29 29 29 0a 20 20 20 20 20 20 </p>")))).
6d30: 20 3b 3b 20 66 69 72 73 74 20 74 68 65 20 63 6f ;; first the co
6d40: 6e 74 72 6f 6c 0a 20 20 20 20 20 20 20 3b 3b 20 ntrol. ;;
6d50: 28 6c 65 74 20 28 28 63 6f 6e 74 72 6f 6c 2d 66 (let ((control-f
6d60: 69 6c 65 20 28 63 6f 6e 63 20 22 70 61 67 65 73 ile (conc "pages
6d70: 2f 22 20 70 61 67 65 20 22 5f 63 74 72 6c 2e 73 /" page "_ctrl.s
6d80: 63 6d 22 29 29 0a 20 20 20 20 20 20 20 3b 3b 20 cm")). ;;
6d90: 20 20 20 20 20 20 28 76 69 65 77 2d 66 69 6c 65 (view-file
6da0: 20 20 20 20 28 63 6f 6e 63 20 22 70 61 67 65 73 (conc "pages
6db0: 2f 22 20 70 61 67 65 20 22 5f 76 69 65 77 2e 73 /" page "_view.s
6dc0: 63 6d 22 29 29 29 0a 20 20 20 20 20 20 20 3b 3b cm"))). ;;
6dd0: 20 20 20 28 69 66 20 28 61 6e 64 20 28 66 69 6c (if (and (fil
6de0: 65 2d 65 78 69 73 74 73 3f 20 63 6f 6e 74 72 6f e-exists? contro
6df0: 6c 2d 66 69 6c 65 29 0a 20 20 20 20 20 20 20 3b l-file). ;
6e00: 3b 20 20 09 20 20 28 6e 6f 74 20 28 65 71 3f 20 ; . (not (eq?
6e10: 70 61 72 74 73 20 27 76 69 65 77 29 29 29 0a 20 parts 'view))).
6e20: 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 28 ;; (
6e30: 62 65 67 69 6e 0a 20 20 20 20 20 20 20 3b 3b 20 begin. ;;
6e40: 20 20 20 20 20 20 20 20 28 73 65 73 73 69 6f 6e (session
6e50: 3a 73 65 74 2d 63 61 6c 6c 65 64 21 20 73 65 6c :set-called! sel
6e60: 66 20 70 61 67 65 29 0a 20 20 20 20 20 20 20 3b f page). ;
6e70: 3b 20 20 20 20 20 20 20 20 20 28 6c 6f 61 64 20 ; (load
6e80: 63 6f 6e 74 72 6f 6c 2d 66 69 6c 65 29 29 29 0a control-file))).
6e90: 20 20 20 20 20 20 20 3b 3b 20 20 20 28 69 66 20 ;; (if
6ea0: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 76 69 (file-exists? vi
6eb0: 65 77 2d 66 69 6c 65 29 0a 20 20 20 20 20 20 20 ew-file).
6ec0: 3b 3b 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f ;; (if (no
6ed0: 74 20 28 65 71 3f 20 70 61 72 74 73 20 27 63 6f t (eq? parts 'co
6ee0: 6e 74 72 6f 6c 29 29 0a 20 20 20 20 20 20 20 3b ntrol)). ;
6ef0: 3b 20 20 09 20 28 73 65 73 73 69 6f 6e 3a 70 72 ; . (session:pr
6f00: 6f 63 65 73 73 2d 66 69 6c 65 20 76 69 65 77 2d ocess-file view-
6f10: 66 69 6c 65 29 29 0a 20 20 20 20 20 20 20 3b 3b file)). ;;
6f20: 20 20 20 20 20 20 20 28 6c 69 73 74 20 22 3c 70 (list "<p
6f30: 3e 50 61 67 65 20 6e 6f 74 20 66 6f 75 6e 64 20 >Page not found
6f40: 22 20 70 61 67 65 20 22 20 3c 2f 70 3e 22 29 29 " page " </p>"))
6f50: 29 0a 20 20 20 20 20 20 28 28 64 69 72 29 20 22 ). ((dir) "
6f60: 45 52 52 4f 52 3a 20 20 64 69 72 20 73 74 79 6c ERROR: dir styl
6f70: 65 20 6e 6f 74 20 79 65 74 20 72 65 2d 69 6d 70 e not yet re-imp
6f80: 6c 65 6d 65 6e 74 65 64 22 29 0a 20 20 20 20 20 lemented").
6f90: 20 28 65 6c 73 65 0a 20 20 20 20 20 20 20 28 6c (else. (l
6fa0: 69 73 74 20 22 45 52 52 4f 52 3a 20 70 61 67 65 ist "ERROR: page
6fb0: 2d 64 69 72 2d 73 74 79 6c 65 20 6d 75 73 74 20 -dir-style must
6fc0: 62 65 20 73 74 6f 72 65 64 2c 20 64 69 72 20 6f be stored, dir o
6fd0: 72 20 66 6c 61 74 2c 20 67 6f 74 20 22 20 64 69 r flat, got " di
6fe0: 72 2d 73 74 79 6c 65 29 29 29 29 29 0a 0a 28 64 r-style)))))..(d
6ff0: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 63 efine (session:c
7000: 61 6c 6c 20 73 65 6c 66 20 70 61 67 65 20 70 61 all self page pa
7010: 72 74 73 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a rts). (session:
7020: 63 61 6c 6c 2d 70 61 72 74 73 20 73 65 6c 66 20 call-parts self
7030: 70 61 67 65 20 27 62 6f 74 68 29 29 0a 0a 3b 3b page 'both))..;;
7040: 20 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f (define (sessio
7050: 6e 3a 6c 6f 61 64 2d 6d 6f 64 65 6c 20 73 65 6c n:load-model sel
7060: 66 20 6d 6f 64 65 6c 29 0a 3b 3b 20 20 20 28 6c f model).;; (l
7070: 65 74 20 28 28 6d 6f 64 65 6c 2e 73 63 6d 20 28 et ((model.scm (
7080: 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 28 73 string-append (s
7090: 64 61 74 2d 67 65 74 2d 73 72 6f 6f 74 20 73 65 dat-get-sroot se
70a0: 6c 66 29 20 22 2f 6d 6f 64 65 6c 73 2f 22 20 6d lf) "/models/" m
70b0: 6f 64 65 6c 20 22 2e 73 63 6d 22 29 29 0a 3b 3b odel ".scm")).;;
70c0: 20 09 28 6d 6f 64 65 6c 2e 73 6f 20 20 28 73 74 .(model.so (st
70d0: 72 69 6e 67 2d 61 70 70 65 6e 64 20 28 73 64 61 ring-append (sda
70e0: 74 2d 67 65 74 2d 73 72 6f 6f 74 20 73 65 6c 66 t-get-sroot self
70f0: 29 20 22 2f 6d 6f 64 65 6c 73 2f 22 20 6d 6f 64 ) "/models/" mod
7100: 65 6c 20 22 2e 73 6f 22 29 29 29 0a 3b 3b 20 20 el ".so"))).;;
7110: 20 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 (if (file-exi
7120: 73 74 73 3f 20 6d 6f 64 65 6c 2e 73 6f 29 0a 3b sts? model.so).;
7130: 3b 20 09 28 6c 6f 61 64 20 6d 6f 64 65 6c 2e 73 ; .(load model.s
7140: 6f 29 0a 3b 3b 20 09 28 69 66 20 28 66 69 6c 65 o).;; .(if (file
7150: 2d 65 78 69 73 74 73 3f 20 6d 6f 64 65 6c 2e 73 -exists? model.s
7160: 63 6d 29 0a 3b 3b 20 09 20 20 20 20 28 6c 6f 61 cm).;; . (loa
7170: 64 20 6d 6f 64 65 6c 2e 73 63 6d 29 0a 3b 3b 20 d model.scm).;;
7180: 09 20 20 20 20 28 73 3a 6c 6f 67 20 22 45 52 52 . (s:log "ERR
7190: 4f 52 3a 20 6d 6f 64 65 6c 20 22 20 6d 6f 64 65 OR: model " mode
71a0: 6c 2e 73 63 6d 20 22 20 6e 6f 74 20 66 6f 75 6e l.scm " not foun
71b0: 64 22 29 29 29 29 29 0a 0a 3b 3b 20 28 64 65 66 d")))))..;; (def
71c0: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 6d 6f 64 ine (session:mod
71d0: 65 6c 2d 70 61 74 68 20 73 65 6c 66 20 6d 6f 64 el-path self mod
71e0: 65 6c 29 0a 3b 3b 20 20 20 28 73 74 72 69 6e 67 el).;; (string
71f0: 2d 61 70 70 65 6e 64 20 28 73 64 61 74 2d 67 65 -append (sdat-ge
7200: 74 2d 73 72 6f 6f 74 20 73 65 6c 66 29 20 22 2f t-sroot self) "/
7210: 6d 6f 64 65 6c 73 2f 22 20 6d 6f 64 65 6c 20 22 models/" model "
7220: 2e 73 63 6d 22 29 29 0a 0a 28 64 65 66 69 6e 65 .scm"))..(define
7230: 20 28 73 65 73 73 69 6f 6e 3a 70 70 2d 66 6f 72 (session:pp-for
7240: 6d 64 61 74 20 73 65 6c 66 29 0a 20 20 28 6c 65 mdat self). (le
7250: 74 20 28 28 64 61 74 20 28 66 6f 72 6d 64 61 74 t ((dat (formdat
7260: 3a 61 6c 6c 2d 3e 73 74 72 69 6e 67 73 20 28 73 :all->strings (s
7270: 64 61 74 2d 67 65 74 2d 66 6f 72 6d 64 61 74 20 dat-get-formdat
7280: 73 65 6c 66 29 29 29 29 0a 20 20 20 20 28 73 74 self)))). (st
7290: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
72a0: 20 64 61 74 20 22 3c 62 72 3e 20 22 29 29 29 0a dat "<br> "))).
72b0: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
72c0: 6e 3a 70 61 72 61 6d 2d 3e 73 74 72 69 6e 67 20 n:param->string
72d0: 70 61 72 61 6d 73 29 0a 20 20 3b 3b 20 28 65 72 params). ;; (er
72e0: 72 3a 6c 6f 67 20 22 70 61 72 61 6d 73 3d 22 20 r:log "params="
72f0: 70 61 72 61 6d 73 29 0a 20 20 28 69 66 20 28 3c params). (if (<
7300: 20 28 6c 65 6e 67 74 68 20 70 61 72 61 6d 73 29 (length params)
7310: 20 31 29 0a 20 20 20 20 20 20 22 22 0a 20 20 20 1). "".
7320: 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 6b (let loop ((k
7330: 65 79 20 28 63 61 72 20 70 61 72 61 6d 73 29 29 ey (car params))
7340: 0a 09 09 20 28 76 61 6c 20 28 63 61 64 72 20 70 ... (val (cadr p
7350: 61 72 61 6d 73 29 29 0a 09 09 20 28 74 61 69 6c arams))... (tail
7360: 20 28 63 64 64 72 20 70 61 72 61 6d 73 29 29 0a (cddr params)).
7370: 09 09 20 28 72 65 73 75 6c 74 20 27 28 29 29 29 .. (result '()))
7380: 0a 09 28 6c 65 74 20 28 28 6e 65 77 72 65 73 75 ..(let ((newresu
7390: 6c 74 20 28 63 6f 6e 73 20 28 73 74 72 69 6e 67 lt (cons (string
73a0: 2d 61 70 70 65 6e 64 20 28 73 3a 61 6e 79 2d 3e -append (s:any->
73b0: 73 74 72 69 6e 67 20 6b 65 79 29 20 22 3d 22 20 string key) "="
73c0: 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 76 (s:any->string v
73d0: 61 6c 29 29 0a 09 09 09 20 20 20 20 20 20 20 72 al)).... r
73e0: 65 73 75 6c 74 29 29 29 0a 09 20 20 28 69 66 20 esult))).. (if
73f0: 28 3c 20 28 6c 65 6e 67 74 68 20 74 61 69 6c 29 (< (length tail)
7400: 20 31 29 20 3b 3b 20 74 72 75 65 20 69 66 20 64 1) ;; true if d
7410: 6f 6e 65 0a 09 20 20 20 20 20 20 28 73 74 72 69 one.. (stri
7420: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 6e ng-intersperse n
7430: 65 77 72 65 73 75 6c 74 20 22 26 22 29 0a 09 20 ewresult "&")..
7440: 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 (loop (car
7450: 74 61 69 6c 29 28 63 61 64 72 20 74 61 69 6c 29 tail)(cadr tail)
7460: 28 63 64 64 72 20 74 61 69 6c 29 20 6e 65 77 72 (cddr tail) newr
7470: 65 73 75 6c 74 29 29 29 29 29 29 0a 0a 28 64 65 esult))))))..(de
7480: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 6c 69 fine (session:li
7490: 6e 6b 2d 74 6f 20 73 65 6c 66 20 70 61 67 65 20 nk-to self page
74a0: 70 61 72 61 6d 73 29 0a 20 20 28 6c 65 74 2a 20 params). (let*
74b0: 28 28 73 65 72 76 65 72 20 20 20 20 28 69 66 20 ((server (if
74c0: 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 (get-environment
74d0: 2d 76 61 72 69 61 62 6c 65 20 22 48 54 54 50 5f -variable "HTTP_
74e0: 48 4f 53 54 22 29 0a 09 09 09 28 67 65 74 2d 65 HOST")....(get-e
74f0: 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 nvironment-varia
7500: 62 6c 65 20 22 48 54 54 50 5f 48 4f 53 54 22 29 ble "HTTP_HOST")
7510: 0a 09 09 09 28 67 65 74 2d 65 6e 76 69 72 6f 6e ....(get-environ
7520: 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 53 ment-variable "S
7530: 45 52 56 45 52 5f 4e 41 4d 45 22 29 29 29 0a 09 ERVER_NAME")))..
7540: 20 28 73 63 72 69 70 74 20 28 6c 65 74 20 28 28 (script (let ((
7550: 73 63 72 69 70 74 2d 6e 61 6d 65 20 28 73 74 72 script-name (str
7560: 69 6e 67 2d 73 70 6c 69 74 20 28 67 65 74 2d 65 ing-split (get-e
7570: 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 nvironment-varia
7580: 62 6c 65 20 22 53 43 52 49 50 54 5f 4e 41 4d 45 ble "SCRIPT_NAME
7590: 22 29 20 22 2f 22 29 29 29 0a 09 09 20 20 20 28 ") "/")))... (
75a0: 69 66 20 28 3e 20 28 6c 65 6e 67 74 68 20 73 63 if (> (length sc
75b0: 72 69 70 74 2d 6e 61 6d 65 29 20 31 29 0a 09 09 ript-name) 1)...
75c0: 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 61 (string-a
75d0: 70 70 65 6e 64 20 28 63 61 72 20 73 63 72 69 70 ppend (car scrip
75e0: 74 2d 6e 61 6d 65 29 20 22 2f 22 20 28 63 61 64 t-name) "/" (cad
75f0: 72 20 73 63 72 69 70 74 2d 6e 61 6d 65 29 29 0a r script-name)).
7600: 09 09 20 20 20 20 20 20 20 28 67 65 74 2d 65 6e .. (get-en
7610: 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 vironment-variab
7620: 6c 65 20 22 53 43 52 49 50 54 5f 4e 41 4d 45 22 le "SCRIPT_NAME"
7630: 29 29 29 29 20 3b 3b 20 62 75 69 6c 64 20 73 63 )))) ;; build sc
7640: 72 69 70 74 20 6e 61 6d 65 20 66 72 6f 6d 20 66 ript name from f
7650: 69 72 73 74 20 74 77 6f 20 65 6c 65 6d 65 6e 74 irst two element
7660: 73 2e 20 54 68 69 73 20 69 73 20 61 20 68 61 6e s. This is a han
7670: 67 6f 76 65 72 20 66 72 6f 6d 20 62 65 66 6f 72 gover from befor
7680: 65 20 49 20 75 73 65 64 20 3f 20 69 6e 20 74 68 e I used ? in th
7690: 65 20 55 52 4c 2e 0a 09 20 28 73 65 73 73 69 6f e URL... (sessio
76a0: 6e 2d 6b 65 79 20 28 73 64 61 74 2d 67 65 74 2d n-key (sdat-get-
76b0: 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 session-key self
76c0: 29 29 0a 09 20 28 70 61 72 61 6d 73 74 72 20 28 )).. (paramstr (
76d0: 73 65 73 73 69 6f 6e 3a 70 61 72 61 6d 2d 3e 73 session:param->s
76e0: 74 72 69 6e 67 20 70 61 72 61 6d 73 29 29 29 0a tring params))).
76f0: 20 20 20 20 3b 3b 20 28 73 65 73 73 69 6f 6e 3a ;; (session:
7700: 6c 6f 67 20 73 65 6c 66 20 22 73 65 72 76 65 72 log self "server
7710: 3d 22 20 73 65 72 76 65 72 20 22 20 73 63 72 69 =" server " scri
7720: 70 74 3d 22 20 73 63 72 69 70 74 20 22 20 70 61 pt=" script " pa
7730: 67 65 3d 22 20 70 61 67 65 29 0a 20 20 20 20 28 ge=" page). (
7740: 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 22 68 string-append "h
7750: 74 74 70 3a 2f 2f 22 20 73 65 72 76 65 72 20 22 ttp://" server "
7760: 2f 22 20 73 63 72 69 70 74 20 22 2f 22 20 70 61 /" script "/" pa
7770: 67 65 20 22 3f 22 20 70 61 72 61 6d 73 74 72 29 ge "?" paramstr)
7780: 29 29 20 3b 3b 20 22 2f 73 6e 3d 22 20 73 65 73 )) ;; "/sn=" ses
7790: 73 69 6f 6e 2d 6b 65 79 29 29 29 0a 0a 28 64 65 sion-key)))..(de
77a0: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 63 67 fine (session:cg
77b0: 69 2d 6f 75 74 20 73 65 6c 66 29 0a 20 20 28 6c i-out self). (l
77c0: 65 74 2a 20 28 28 63 6f 6e 74 65 6e 74 20 20 28 et* ((content (
77d0: 6c 69 73 74 20 28 73 64 61 74 2d 67 65 74 2d 63 list (sdat-get-c
77e0: 6f 6e 74 65 6e 74 2d 74 79 70 65 20 73 65 6c 66 ontent-type self
77f0: 29 29 29 20 3b 3b 20 27 28 22 43 6f 6e 74 65 6e ))) ;; '("Conten
7800: 74 2d 74 79 70 65 3a 20 74 65 78 74 2f 68 74 6d t-type: text/htm
7810: 6c 3b 20 63 68 61 72 73 65 74 3d 69 73 6f 2d 38 l; charset=iso-8
7820: 38 35 39 2d 31 5c 6e 5c 6e 22 29 29 0a 09 20 28 859-1\n\n")).. (
7830: 68 65 61 64 65 72 20 20 20 28 6c 65 74 20 28 28 header (let ((
7840: 63 6f 6f 6b 69 65 20 28 73 64 61 74 2d 67 65 74 cookie (sdat-get
7850: 2d 73 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 20 -session-cookie
7860: 73 65 6c 66 29 29 29 0a 09 09 20 20 20 20 20 28 self)))... (
7870: 69 66 20 63 6f 6f 6b 69 65 0a 09 09 09 20 28 63 if cookie.... (c
7880: 6f 6e 73 20 28 73 74 72 69 6e 67 2d 61 70 70 65 ons (string-appe
7890: 6e 64 20 22 53 65 74 2d 43 6f 6f 6b 69 65 3a 20 nd "Set-Cookie:
78a0: 22 20 28 63 61 72 20 63 6f 6f 6b 69 65 29 29 0a " (car cookie)).
78b0: 09 09 09 20 20 20 20 20 20 20 63 6f 6e 74 65 6e ... conten
78c0: 74 29 0a 09 09 09 20 63 6f 6e 74 65 6e 74 29 29 t).... content))
78d0: 29 0a 09 20 28 70 61 67 65 64 61 74 20 20 28 73 ).. (pagedat (s
78e0: 64 61 74 2d 67 65 74 2d 70 61 67 65 64 61 74 20 dat-get-pagedat
78f0: 73 65 6c 66 29 29 29 0a 20 20 20 20 28 73 3a 63 self))). (s:c
7900: 67 69 2d 6f 75 74 20 0a 20 20 20 20 20 28 63 6f gi-out . (co
7910: 6e 73 20 68 65 61 64 65 72 20 70 61 67 65 64 61 ns header pageda
7920: 74 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 t))))..(define (
7930: 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 session:log self
7940: 20 2e 20 6d 73 67 29 0a 20 20 28 77 69 74 68 2d . msg). (with-
7950: 6f 75 74 70 75 74 2d 74 6f 2d 70 6f 72 74 20 28 output-to-port (
7960: 73 64 61 74 2d 67 65 74 2d 6c 6f 67 2d 70 6f 72 sdat-get-log-por
7970: 74 20 73 65 6c 66 29 20 3b 3b 20 28 73 64 61 74 t self) ;; (sdat
7980: 2d 67 65 74 2d 6c 6f 67 70 74 20 73 65 6c 66 29 -get-logpt self)
7990: 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 20 . (lambda ()
79a0: 0a 20 20 20 20 20 20 28 61 70 70 6c 79 20 70 72 . (apply pr
79b0: 69 6e 74 20 6d 73 67 29 29 29 29 0a 0a 28 64 65 int msg))))..(de
79c0: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 fine (session:ge
79d0: 74 2d 70 61 72 61 6d 20 73 65 6c 66 20 6b 65 79 t-param self key
79e0: 29 0a 20 20 3b 3b 20 28 73 65 73 73 69 6f 6e 3a ). ;; (session:
79f0: 6c 6f 67 20 73 3a 73 65 73 73 69 6f 6e 20 22 70 log s:session "p
7a00: 61 72 61 6d 73 3d 22 20 28 73 6c 6f 74 2d 72 65 arams=" (slot-re
7a10: 66 20 73 3a 73 65 73 73 69 6f 6e 20 27 70 61 72 f s:session 'par
7a20: 61 6d 73 29 29 0a 20 20 28 6c 65 74 20 28 28 70 ams)). (let ((p
7a30: 61 72 61 6d 73 20 28 73 64 61 74 2d 67 65 74 2d arams (sdat-get-
7a40: 70 61 72 61 6d 73 20 73 65 6c 66 29 29 29 0a 20 params self))).
7a50: 20 20 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d (session:get-
7a60: 70 61 72 61 6d 2d 66 72 6f 6d 20 70 61 72 61 6d param-from param
7a70: 73 20 6b 65 79 29 29 29 0a 0a 3b 3b 20 54 68 69 s key)))..;; Thi
7a80: 73 20 6f 6e 65 20 77 69 6c 6c 20 67 65 74 20 74 s one will get t
7a90: 68 65 20 66 69 72 73 74 20 76 61 6c 75 65 20 66 he first value f
7aa0: 6f 75 6e 64 20 72 65 67 61 72 64 6c 65 73 73 20 ound regardless
7ab0: 6f 66 20 66 6f 72 6d 0a 28 64 65 66 69 6e 65 20 of form.(define
7ac0: 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 69 6e 70 (session:get-inp
7ad0: 75 74 20 73 65 6c 66 20 6b 65 79 29 0a 20 20 28 ut self key). (
7ae0: 6c 65 74 2a 20 28 28 66 6f 72 6d 64 61 74 20 28 let* ((formdat (
7af0: 73 64 61 74 2d 67 65 74 2d 66 6f 72 6d 64 61 74 sdat-get-formdat
7b00: 20 73 65 6c 66 29 29 29 0a 20 20 20 20 28 69 66 self))). (if
7b10: 20 28 6e 6f 74 20 66 6f 72 6d 64 61 74 29 20 23 (not formdat) #
7b20: 66 0a 09 28 69 66 20 28 6f 72 20 28 73 74 72 69 f..(if (or (stri
7b30: 6e 67 3f 20 6b 65 79 29 28 6e 75 6d 62 65 72 3f ng? key)(number?
7b40: 20 6b 65 79 29 28 73 79 6d 62 6f 6c 3f 20 6b 65 key)(symbol? ke
7b50: 79 29 29 0a 09 20 20 20 20 28 69 66 20 28 61 6e y)).. (if (an
7b60: 64 20 28 76 65 63 74 6f 72 3f 20 66 6f 72 6d 64 d (vector? formd
7b70: 61 74 29 28 65 71 3f 20 28 76 65 63 74 6f 72 2d at)(eq? (vector-
7b80: 6c 65 6e 67 74 68 20 66 6f 72 6d 64 61 74 29 20 length formdat)
7b90: 31 29 28 68 61 73 68 2d 74 61 62 6c 65 3f 20 28 1)(hash-table? (
7ba0: 76 65 63 74 6f 72 2d 72 65 66 20 66 6f 72 6d 64 vector-ref formd
7bb0: 61 74 20 30 29 29 29 0a 09 09 28 66 6f 72 6d 64 at 0)))...(formd
7bc0: 61 74 3a 67 65 74 20 66 6f 72 6d 64 61 74 20 6b at:get formdat k
7bd0: 65 79 29 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 ey)...(begin...
7be0: 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 (session:log se
7bf0: 6c 66 20 22 45 52 52 4f 52 3a 20 66 6f 72 6d 64 lf "ERROR: formd
7c00: 61 74 3a 20 22 20 66 6f 72 6d 64 61 74 20 22 20 at: " formdat "
7c10: 69 73 20 6e 6f 74 20 6f 66 20 63 6c 61 73 73 20 is not of class
7c20: 3c 66 6f 72 6d 64 61 74 3e 22 29 0a 09 09 20 20 <formdat>")...
7c30: 23 66 29 29 0a 09 20 20 20 20 28 73 65 73 73 69 #f)).. (sessi
7c40: 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 45 52 52 on:log self "ERR
7c50: 4f 52 3a 20 62 61 64 20 6b 65 79 20 22 20 6b 65 OR: bad key " ke
7c60: 79 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 y)))))..(define
7c70: 28 73 65 73 73 69 6f 6e 3a 72 75 6e 2d 61 63 74 (session:run-act
7c80: 69 6f 6e 73 20 73 65 6c 66 29 0a 20 20 28 6c 65 ions self). (le
7c90: 74 2a 20 28 28 61 63 74 69 6f 6e 20 20 20 20 28 t* ((action (
7ca0: 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 72 61 session:get-para
7cb0: 6d 20 73 65 6c 66 20 27 61 63 74 69 6f 6e 29 29 m self 'action))
7cc0: 0a 09 20 28 70 61 67 65 20 20 20 20 20 20 28 73 .. (page (s
7cd0: 64 61 74 2d 67 65 74 2d 70 61 67 65 20 73 65 6c dat-get-page sel
7ce0: 66 29 29 29 0a 20 20 20 20 3b 3b 20 28 70 72 69 f))). ;; (pri
7cf0: 6e 74 20 22 61 63 74 69 6f 6e 3d 22 20 61 63 74 nt "action=" act
7d00: 69 6f 6e 20 22 20 70 61 67 65 3d 22 20 70 61 67 ion " page=" pag
7d10: 65 29 0a 20 20 20 20 28 69 66 20 61 63 74 69 6f e). (if actio
7d20: 6e 0a 09 28 6c 65 74 20 28 28 61 63 74 69 6f 6e n..(let ((action
7d30: 2d 6c 73 74 20 20 28 73 74 72 69 6e 67 2d 73 70 -lst (string-sp
7d40: 6c 69 74 20 61 63 74 69 6f 6e 20 22 2e 22 29 29 lit action "."))
7d50: 29 0a 09 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 ).. ;; (print "
7d60: 61 63 74 69 6f 6e 2d 6c 73 74 3d 22 20 61 63 74 action-lst=" act
7d70: 69 6f 6e 2d 6c 73 74 29 0a 09 20 20 28 69 66 20 ion-lst).. (if
7d80: 28 6e 6f 74 20 28 3d 20 28 6c 65 6e 67 74 68 20 (not (= (length
7d90: 61 63 74 69 6f 6e 2d 6c 73 74 29 20 32 29 29 20 action-lst) 2))
7da0: 0a 09 20 20 20 20 20 20 28 65 72 72 3a 6c 6f 67 .. (err:log
7db0: 20 22 41 63 74 69 6f 6e 20 73 68 6f 75 6c 64 20 "Action should
7dc0: 62 65 20 6f 66 20 66 6f 72 6d 3a 20 6d 6f 64 75 be of form: modu
7dd0: 6c 65 2e 61 63 74 69 6f 6e 22 29 0a 09 20 20 20 le.action")..
7de0: 20 20 20 28 6c 65 74 2a 20 28 28 74 61 72 67 2d (let* ((targ-
7df0: 70 61 67 65 20 20 20 28 63 61 72 20 61 63 74 69 page (car acti
7e00: 6f 6e 2d 6c 73 74 29 29 0a 09 09 20 20 20 20 20 on-lst))...
7e10: 28 70 72 6f 63 2d 6e 61 6d 65 20 20 20 28 73 74 (proc-name (st
7e20: 72 69 6e 67 2d 61 70 70 65 6e 64 20 74 61 72 67 ring-append targ
7e30: 2d 70 61 67 65 20 22 2d 61 63 74 69 6f 6e 22 29 -page "-action")
7e40: 29 0a 09 09 20 20 20 20 20 28 74 61 72 67 2d 61 )... (targ-a
7e50: 63 74 69 6f 6e 20 28 63 61 64 72 20 61 63 74 69 ction (cadr acti
7e60: 6f 6e 2d 6c 73 74 29 29 29 0a 09 09 3b 3b 20 28 on-lst)))...;; (
7e70: 65 72 72 3a 6c 6f 67 20 22 74 61 72 67 2d 70 61 err:log "targ-pa
7e80: 67 65 3d 22 20 74 61 72 67 2d 70 61 67 65 20 22 ge=" targ-page "
7e90: 20 70 72 6f 63 2d 6e 61 6d 65 3d 22 20 70 72 6f proc-name=" pro
7ea0: 63 2d 6e 61 6d 65 20 22 20 74 61 72 67 2d 61 63 c-name " targ-ac
7eb0: 74 69 6f 6e 3d 22 20 74 61 72 67 2d 61 63 74 69 tion=" targ-acti
7ec0: 6f 6e 29 0a 0a 09 09 3b 3b 20 63 61 6c 6c 20 68 on)....;; call h
7ed0: 65 72 65 20 6f 6e 6c 79 20 69 66 20 6e 65 76 65 ere only if neve
7ee0: 72 20 63 61 6c 6c 65 64 20 62 65 66 6f 72 65 0a r called before.
7ef0: 09 09 28 69 66 20 28 73 65 73 73 69 6f 6e 3a 6e ..(if (session:n
7f00: 65 76 65 72 2d 63 61 6c 6c 65 64 2d 70 61 67 65 ever-called-page
7f10: 3f 20 73 65 6c 66 20 74 61 72 67 2d 70 61 67 65 ? self targ-page
7f20: 29 0a 09 09 20 20 20 20 28 73 65 73 73 69 6f 6e )... (session
7f30: 3a 63 61 6c 6c 2d 70 61 72 74 73 20 73 65 6c 66 :call-parts self
7f40: 20 74 61 72 67 2d 70 61 67 65 20 27 63 6f 6e 74 targ-page 'cont
7f50: 72 6f 6c 29 29 0a 09 09 3b 3b 20 20 20 20 20 20 rol))...;;
7f60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 70 72 pr
7f70: 6f 63 20 20 20 20 20 20 20 20 20 20 20 20 20 20 oc
7f80: 20 20 20 20 20 20 20 20 20 20 20 61 63 74 69 6f actio
7f90: 6e 20 20 20 20 0a 0a 09 09 28 69 66 20 23 74 20 n ....(if #t
7fa0: 3b 3b 20 73 65 74 20 74 6f 20 23 74 20 74 6f 20 ;; set to #t to
7fb0: 73 65 65 20 62 65 74 74 65 72 20 65 72 72 6f 72 see better error
7fc0: 20 6d 65 73 73 61 67 65 73 20 64 75 72 69 6e 67 messages during
7fd0: 20 64 65 62 75 67 67 69 6e 20 3a 2d 29 0a 09 09 debuggin :-)...
7fe0: 20 20 20 20 28 28 65 76 61 6c 20 28 73 74 72 69 ((eval (stri
7ff0: 6e 67 2d 3e 73 79 6d 62 6f 6c 20 70 72 6f 63 2d ng->symbol proc-
8000: 6e 61 6d 65 29 29 20 74 61 72 67 2d 61 63 74 69 name)) targ-acti
8010: 6f 6e 29 20 3b 3b 20 75 6e 73 61 66 65 20 65 78 on) ;; unsafe ex
8020: 65 63 75 74 69 6f 6e 0a 09 09 20 20 20 20 28 63 ecution... (c
8030: 6f 6e 64 69 74 69 6f 6e 2d 63 61 73 65 20 28 28 ondition-case ((
8040: 65 76 61 6c 20 28 73 74 72 69 6e 67 2d 3e 73 79 eval (string->sy
8050: 6d 62 6f 6c 20 70 72 6f 63 2d 6e 61 6d 65 29 29 mbol proc-name))
8060: 20 74 61 72 67 2d 61 63 74 69 6f 6e 29 0a 09 09 targ-action)...
8070: 09 09 20 20 20 20 28 28 65 78 6e 20 66 69 6c 65 .. ((exn file
8080: 29 20 28 73 3a 6c 6f 67 20 22 66 69 6c 65 20 65 ) (s:log "file e
8090: 72 72 6f 72 22 29 29 0a 09 09 09 09 20 20 20 20 rror")).....
80a0: 28 28 65 78 6e 20 69 2f 6f 29 20 20 28 73 3a 6c ((exn i/o) (s:l
80b0: 6f 67 20 22 69 2f 6f 20 65 72 72 6f 72 22 29 29 og "i/o error"))
80c0: 0a 09 09 09 09 20 20 20 20 28 28 65 78 6e 20 29 ..... ((exn )
80d0: 20 20 20 20 20 28 73 3a 6c 6f 67 20 22 41 63 74 (s:log "Act
80e0: 69 6f 6e 20 6e 6f 74 20 69 6d 70 6c 65 6d 65 6e ion not implemen
80f0: 74 65 64 3a 20 22 20 70 72 6f 63 2d 6e 61 6d 65 ted: " proc-name
8100: 20 22 20 61 63 74 69 6f 6e 3a 20 22 20 74 61 72 " action: " tar
8110: 67 2d 61 63 74 69 6f 6e 29 29 0a 09 09 09 09 20 g-action)).....
8120: 20 20 20 28 76 61 72 20 28 29 20 20 20 20 20 28 (var () (
8130: 73 3a 6c 6f 67 20 22 55 6e 6b 6e 6f 77 6e 20 45 s:log "Unknown E
8140: 72 72 6f 72 22 29 29 29 29 29 29 29 29 29 29 0a rror")))))))))).
8150: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
8160: 6e 3a 6e 65 76 65 72 2d 63 61 6c 6c 65 64 2d 70 n:never-called-p
8170: 61 67 65 3f 20 73 65 6c 66 20 70 61 67 65 29 0a age? self page).
8180: 20 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 (session:log s
8190: 65 6c 66 20 22 43 68 65 63 6b 69 6e 67 20 66 6f elf "Checking fo
81a0: 72 20 70 61 67 65 3a 20 22 20 70 61 67 65 29 0a r page: " page).
81b0: 20 20 28 6e 6f 74 20 28 6d 65 6d 62 65 72 20 70 (not (member p
81c0: 61 67 65 20 28 73 64 61 74 2d 67 65 74 2d 73 65 age (sdat-get-se
81d0: 65 6e 2d 70 61 67 65 73 20 73 65 6c 66 29 29 29 en-pages self)))
81e0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 )..(define (sess
81f0: 69 6f 6e 3a 73 65 74 2d 63 61 6c 6c 65 64 21 20 ion:set-called!
8200: 73 65 6c 66 20 70 61 67 65 29 0a 20 20 28 73 64 self page). (sd
8210: 61 74 2d 73 65 74 2d 73 65 65 6e 2d 70 61 67 65 at-set-seen-page
8220: 73 21 20 73 65 6c 66 20 28 63 6f 6e 73 20 70 61 s! self (cons pa
8230: 67 65 20 28 73 64 61 74 2d 67 65 74 2d 73 65 65 ge (sdat-get-see
8240: 6e 2d 70 61 67 65 73 20 73 65 6c 66 29 29 29 29 n-pages self))))
8250: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
8260: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8270: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8280: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8290: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 41 6c ==========.;; Al
82a0: 74 65 72 6e 61 74 69 76 65 20 64 61 74 61 20 74 ternative data t
82b0: 79 70 65 20 64 65 6c 69 76 65 72 79 0a 3b 3b 3d ype delivery.;;=
82c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
82d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
82e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
82f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8300: 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 =====..(define (
8310: 73 65 73 73 69 6f 6e 3a 61 6c 74 2d 6f 75 74 20 session:alt-out
8320: 73 65 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 64 self). (let ((d
8330: 61 74 20 28 73 64 61 74 2d 67 65 74 2d 61 6c 74 at (sdat-get-alt
8340: 2d 70 61 67 65 2d 64 61 74 20 73 65 6c 66 29 29 -page-dat self))
8350: 29 0a 20 20 20 20 3b 3b 20 28 73 3a 6c 6f 67 20 ). ;; (s:log
8360: 22 64 61 74 20 69 73 3a 20 22 20 64 61 74 29 0a "dat is: " dat).
8370: 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 48 ;; (print "H
8380: 54 54 50 2f 31 2e 31 20 32 30 30 20 4f 4b 22 29 TTP/1.1 200 OK")
8390: 0a 20 20 20 20 28 70 72 69 6e 74 20 22 44 61 74 . (print "Dat
83a0: 65 3a 20 22 20 28 74 69 6d 65 2d 3e 73 74 72 69 e: " (time->stri
83b0: 6e 67 20 28 73 65 63 6f 6e 64 73 2d 3e 75 74 63 ng (seconds->utc
83c0: 2d 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 -time (current-s
83d0: 65 63 6f 6e 64 73 29 29 29 29 0a 20 20 20 20 28 econds)))). (
83e0: 70 72 69 6e 74 20 22 43 6f 6e 74 65 6e 74 2d 54 print "Content-T
83f0: 79 70 65 3a 20 22 20 28 73 64 61 74 2d 67 65 74 ype: " (sdat-get
8400: 2d 63 6f 6e 74 65 6e 74 2d 74 79 70 65 20 73 65 -content-type se
8410: 6c 66 29 29 0a 20 20 20 20 28 70 72 69 6e 74 20 lf)). (print
8420: 22 41 63 63 65 70 74 2d 52 61 6e 67 65 73 3a 20 "Accept-Ranges:
8430: 62 79 74 65 73 22 29 0a 20 20 20 20 28 70 72 69 bytes"). (pri
8440: 6e 74 20 22 43 6f 6e 74 65 6e 74 2d 4c 65 6e 67 nt "Content-Leng
8450: 74 68 3a 20 22 20 28 69 66 20 28 62 6c 6f 62 3f th: " (if (blob?
8460: 20 64 61 74 29 0a 09 09 09 09 20 20 28 62 6c 6f dat)..... (blo
8470: 62 2d 73 69 7a 65 20 64 61 74 29 0a 09 09 09 09 b-size dat).....
8480: 20 20 30 29 29 0a 20 20 20 20 28 70 72 69 6e 74 0)). (print
8490: 20 22 4b 65 65 70 2d 41 6c 69 76 65 3a 20 74 69 "Keep-Alive: ti
84a0: 6d 65 6f 75 74 3d 31 35 2c 20 6d 61 78 3d 31 30 meout=15, max=10
84b0: 30 22 29 0a 20 20 20 20 28 70 72 69 6e 74 20 22 0"). (print "
84c0: 43 6f 6e 6e 65 63 74 69 6f 6e 3a 20 4b 65 65 70 Connection: Keep
84d0: 2d 41 6c 69 76 65 22 29 0a 20 20 20 20 28 70 72 -Alive"). (pr
84e0: 69 6e 74 20 22 22 29 0a 20 20 20 20 28 77 72 69 int ""). (wri
84f0: 74 65 2d 73 74 72 69 6e 67 20 28 62 6c 6f 62 2d te-string (blob-
8500: 3e 73 74 72 69 6e 67 20 64 61 74 29 20 23 66 20 >string dat) #f
8510: 28 63 75 72 72 65 6e 74 2d 6f 75 74 70 75 74 2d (current-output-
8520: 70 6f 72 74 29 29 29 29 0a port)))).