Artifact
7c09cb436b9e04dde78789564718763021e4f5c9:
0000: 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 30 ;; Copyright 200
0010: 37 2d 32 30 30 38 2c 20 4d 61 74 74 68 65 77 20 7-2008, Matthew
0020: 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b 20 Welland..;; .;;
0030: 20 54 68 69 73 20 70 72 6f 67 72 61 6d 20 69 73 This program is
0040: 20 6d 61 64 65 20 61 76 61 69 6c 61 62 6c 65 20 made available
0050: 75 6e 64 65 72 20 74 68 65 20 47 4e 55 20 47 50 under the GNU GP
0060: 4c 20 76 65 72 73 69 6f 6e 20 32 2e 30 20 6f 72 L version 2.0 or
0070: 0a 3b 3b 20 20 67 72 65 61 74 65 72 2e 20 53 65 .;; greater. Se
0080: 65 20 74 68 65 20 61 63 63 6f 6d 70 61 6e 79 69 e the accompanyi
0090: 6e 67 20 66 69 6c 65 20 43 4f 50 59 49 4e 47 20 ng file COPYING
00a0: 66 6f 72 20 64 65 74 61 69 6c 73 2e 0a 3b 3b 20 for details..;;
00b0: 0a 3b 3b 20 20 54 68 69 73 20 70 72 6f 67 72 61 .;; This progra
00c0: 6d 20 69 73 20 64 69 73 74 72 69 62 75 74 65 64 m is distributed
00d0: 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 52 WITHOUT ANY WAR
00e0: 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 65 RANTY; without e
00f0: 76 65 6e 20 74 68 65 0a 3b 3b 20 20 69 6d 70 6c ven the.;; impl
0100: 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 20 ied warranty of
0110: 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 20 MERCHANTABILITY
0120: 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 41 or FITNESS FOR A
0130: 20 50 41 52 54 49 43 55 4c 41 52 0a 3b 3b 20 20 PARTICULAR.;;
0140: 50 55 52 50 4f 53 45 2e 0a 0a 28 69 6e 63 6c 75 PURPOSE...(inclu
0150: 64 65 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 de "requirements
0160: 2e 73 63 6d 22 29 0a 0a 3b 3b 20 73 65 73 73 69 .scm")..;; sessi
0170: 6f 6e 73 20 74 61 62 6c 65 0a 3b 3b 20 69 64 20 ons table.;; id
0180: 73 65 73 73 69 6f 6e 5f 69 64 20 73 65 73 73 69 session_id sessi
0190: 6f 6e 5f 6b 65 79 0a 3b 3b 20 63 72 65 61 74 65 on_key.;; create
01a0: 20 74 61 62 6c 65 20 73 65 73 73 69 6f 6e 73 20 table sessions
01b0: 28 69 64 20 73 65 72 69 61 6c 20 6e 6f 74 20 6e (id serial not n
01c0: 75 6c 6c 2c 73 65 73 73 69 6f 6e 2d 6b 65 79 20 ull,session-key
01d0: 74 65 78 74 29 3b 0a 0a 3b 3b 20 73 65 73 73 69 text);..;; sessi
01e0: 6f 6e 5f 76 61 72 73 20 74 61 62 6c 65 0a 3b 3b on_vars table.;;
01f0: 20 69 64 20 73 65 73 73 69 6f 6e 5f 69 64 20 70 id session_id p
0200: 61 67 65 5f 69 64 20 6b 65 79 20 76 61 6c 75 65 age_id key value
0210: 0a 3b 3b 20 63 72 65 61 74 65 20 74 61 62 6c 65 .;; create table
0220: 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 28 69 session_vars (i
0230: 64 20 73 65 72 69 61 6c 20 6e 6f 74 20 6e 75 6c d serial not nul
0240: 6c 2c 73 65 73 73 69 6f 6e 5f 69 64 20 69 6e 74 l,session_id int
0250: 65 67 65 72 2c 70 61 67 65 20 74 65 78 74 2c 6b eger,page text,k
0260: 65 79 20 74 65 78 74 2c 76 61 6c 75 65 20 74 65 ey text,value te
0270: 78 74 29 3b 0a 0a 3b 3b 20 54 4f 44 4f 0a 3b 3b xt);..;; TODO.;;
0280: 20 20 43 6f 6e 63 65 70 74 20 6f 66 20 6f 72 64 Concept of ord
0290: 65 72 20 6e 75 6d 20 69 6e 63 72 65 6d 65 6e 74 er num increment
02a0: 65 64 20 77 69 74 68 20 65 61 63 68 20 70 61 67 ed with each pag
02b0: 65 20 61 63 63 65 73 73 0a 3b 3b 20 20 20 20 20 e access.;;
02c0: 69 66 20 61 20 62 72 61 6e 63 68 20 69 73 20 74 if a branch is t
02d0: 61 6b 65 6e 20 74 68 65 6e 20 61 20 6e 65 77 20 aken then a new
02e0: 73 65 73 73 69 6f 6e 20 77 6f 75 6c 64 20 6e 65 session would ne
02f0: 65 64 20 74 6f 20 62 65 20 63 72 65 61 74 65 64 ed to be created
0300: 0a 3b 3b 0a 0a 28 64 65 66 69 6e 65 2d 63 6c 61 .;;..(define-cla
0310: 73 73 20 3c 73 65 73 73 69 6f 6e 3e 20 28 29 0a ss <session> ().
0320: 20 20 28 64 62 74 79 70 65 20 20 20 20 20 20 20 (dbtype
0330: 3b 3b 20 27 70 67 20 6f 72 20 27 73 71 6c 69 74 ;; 'pg or 'sqlit
0340: 65 33 0a 20 20 20 64 62 69 6e 69 74 0a 20 20 20 e3. dbinit.
0350: 63 6f 6e 6e 0a 20 20 20 70 61 72 61 6d 73 20 20 conn. params
0360: 20 20 20 20 20 3b 3b 20 70 61 72 61 6d 73 20 66 ;; params f
0370: 72 6f 6d 20 74 68 65 20 6b 65 79 3d 76 61 6c 26 rom the key=val&
0380: 6b 65 79 31 3d 76 61 6c 32 20 73 74 72 69 6e 67 key1=val2 string
0390: 0a 20 20 20 70 61 74 68 2d 70 61 72 61 6d 73 20 . path-params
03a0: 20 3b 3b 20 72 65 6d 61 69 6e 69 6e 67 20 70 61 ;; remaining pa
03b0: 72 61 6d 73 20 66 72 6f 6d 20 74 68 65 20 70 61 rams from the pa
03c0: 74 68 0a 20 20 20 73 65 73 73 69 6f 6e 2d 6b 65 th. session-ke
03d0: 79 0a 20 20 20 73 65 73 73 69 6f 6e 2d 69 64 0a y. session-id.
03e0: 20 20 20 64 6f 6d 61 69 6e 0a 20 20 20 74 6f 70 domain. top
03f0: 70 61 67 65 20 20 20 20 20 20 3b 3b 20 64 65 66 page ;; def
0400: 61 75 6c 74 73 20 74 6f 20 22 69 6e 64 65 78 22 aults to "index"
0410: 20 2d 20 6f 76 65 72 72 69 64 65 20 69 6e 20 2e - override in .
0420: 73 74 6d 6c 2e 63 6f 6e 66 69 67 20 69 66 20 64 stml.config if d
0430: 65 73 69 72 65 64 0a 20 20 20 70 61 67 65 20 20 esired. page
0440: 20 20 20 20 20 20 20 3b 3b 20 74 68 65 20 70 61 ;; the pa
0450: 67 65 20 6e 61 6d 65 20 2d 20 64 65 66 61 75 6c ge name - defaul
0460: 74 73 20 74 6f 20 68 6f 6d 65 0a 20 20 20 63 75 ts to home. cu
0470: 72 72 2d 70 61 67 65 20 20 20 20 3b 3b 20 74 68 rr-page ;; th
0480: 65 20 63 75 72 72 65 6e 74 20 70 61 67 65 20 62 e current page b
0490: 65 69 6e 67 20 65 76 61 6c 75 61 74 65 64 0a 20 eing evaluated.
04a0: 20 20 63 6f 6e 74 65 6e 74 2d 74 79 70 65 20 3b content-type ;
04b0: 3b 20 74 68 65 20 64 65 66 61 75 6c 74 20 63 6f ; the default co
04c0: 6e 74 65 6e 74 20 74 79 70 65 20 69 73 20 74 65 ntent type is te
04d0: 78 74 2f 68 74 6d 6c 2c 20 6f 76 65 72 72 69 64 xt/html, overrid
04e0: 65 20 74 6f 20 64 65 6c 69 76 65 72 20 6f 74 68 e to deliver oth
04f0: 65 72 20 73 74 75 66 66 0a 20 20 20 70 61 67 65 er stuff. page
0500: 2d 74 79 70 65 20 20 20 20 3b 3b 20 75 73 65 20 -type ;; use
0510: 69 6e 20 63 6f 6e 6a 75 6e 63 74 69 6f 6e 20 77 in conjunction w
0520: 69 74 68 20 63 6f 6e 74 65 6e 74 2d 74 79 70 65 ith content-type
0530: 20 74 6f 20 64 65 6c 69 76 65 72 20 6f 74 68 65 to deliver othe
0540: 72 20 70 61 79 6c 6f 61 64 73 0a 20 20 20 73 72 r payloads. sr
0550: 6f 6f 74 0a 20 20 20 74 77 69 6b 69 64 69 72 20 oot. twikidir
0560: 20 20 20 20 3b 3b 20 6c 6f 63 61 74 69 6f 6e 20 ;; location
0570: 66 6f 72 20 74 77 69 6b 69 73 20 2d 20 6e 65 65 for twikis - nee
0580: 64 73 20 74 6f 20 62 65 20 66 75 6c 6c 79 20 77 ds to be fully w
0590: 72 69 74 61 62 6c 65 20 62 79 20 77 65 62 20 73 ritable by web s
05a0: 65 72 76 65 72 0a 20 20 20 70 61 67 65 64 61 74 erver. pagedat
05b0: 0a 20 20 20 61 6c 74 2d 70 61 67 65 2d 64 61 74 . alt-page-dat
05c0: 0a 20 20 20 70 61 67 65 76 61 72 73 20 20 20 20 . pagevars
05d0: 20 3b 3b 20 73 65 73 73 69 6f 6e 20 76 61 72 73 ;; session vars
05e0: 20 73 70 65 63 69 66 69 63 20 74 6f 20 74 68 69 specific to thi
05f0: 73 20 70 61 67 65 0a 20 20 20 70 61 67 65 76 61 s page. pageva
0600: 72 73 2d 62 65 66 6f 72 65 0a 20 20 20 73 65 73 rs-before. ses
0610: 73 69 6f 6e 76 61 72 73 20 20 3b 3b 20 73 65 73 sionvars ;; ses
0620: 73 69 6f 6e 20 76 61 72 73 20 76 69 73 69 62 6c sion vars visibl
0630: 65 20 74 6f 20 61 6c 6c 20 70 61 67 65 73 0a 20 e to all pages.
0640: 20 20 73 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 sessionvars-be
0650: 66 6f 72 65 0a 20 20 20 67 6c 6f 62 61 6c 76 61 fore. globalva
0660: 72 73 20 20 20 3b 3b 20 67 6c 6f 62 61 6c 20 76 rs ;; global v
0670: 61 72 73 20 76 69 73 69 62 6c 65 20 74 6f 20 61 ars visible to a
0680: 6c 6c 20 73 65 73 73 69 6f 6e 73 0a 20 20 20 67 ll sessions. g
0690: 6c 6f 62 61 6c 76 61 72 73 2d 62 65 66 6f 72 65 lobalvars-before
06a0: 0a 20 20 20 6c 6f 67 70 74 0a 20 20 20 66 6f 72 . logpt. for
06b0: 6d 64 61 74 0a 20 20 20 72 65 71 75 65 73 74 2d mdat. request-
06c0: 6d 65 74 68 6f 64 0a 20 20 20 73 65 73 73 69 6f method. sessio
06d0: 6e 2d 63 6f 6f 6b 69 65 0a 20 20 20 63 75 72 72 n-cookie. curr
06e0: 2d 65 72 72 0a 20 20 20 6c 6f 67 2d 70 6f 72 74 -err. log-port
06f0: 0a 20 20 20 6c 6f 67 66 69 6c 65 0a 20 20 20 73 . logfile. s
0700: 65 65 6e 2d 70 61 67 65 73 0a 20 20 20 70 61 67 een-pages. pag
0710: 65 2d 64 69 72 2d 73 74 79 6c 65 0a 20 20 20 64 e-dir-style. d
0720: 65 62 75 67 6d 6f 64 65 29 29 0a 0a 3b 3b 20 53 ebugmode))..;; S
0730: 50 4c 49 54 20 49 4e 54 4f 20 53 54 52 41 49 47 PLIT INTO STRAIG
0740: 48 54 20 46 4f 52 57 41 52 44 20 49 4e 49 54 20 HT FORWARD INIT
0750: 41 4e 44 20 43 4f 4d 50 4c 45 58 20 49 4e 49 54 AND COMPLEX INIT
0760: 0a 28 64 65 66 69 6e 65 2d 6d 65 74 68 6f 64 20 .(define-method
0770: 28 69 6e 69 74 69 61 6c 69 7a 65 20 28 73 65 6c (initialize (sel
0780: 66 20 3c 73 65 73 73 69 6f 6e 3e 29 20 69 6e 69 f <session>) ini
0790: 74 61 72 67 73 29 0a 20 20 28 63 61 6c 6c 2d 6e targs). (call-n
07a0: 65 78 74 2d 6d 65 74 68 6f 64 29 0a 20 20 28 73 ext-method). (s
07b0: 6c 6f 74 2d 73 65 74 21 20 73 65 6c 66 20 27 64 lot-set! self 'd
07c0: 62 74 79 70 65 20 20 20 20 20 20 27 70 67 29 0a btype 'pg).
07d0: 20 20 28 73 6c 6f 74 2d 73 65 74 21 20 73 65 6c (slot-set! sel
07e0: 66 20 27 70 61 67 65 20 20 20 20 20 20 20 20 22 f 'page "
07f0: 68 6f 6d 65 22 29 20 20 20 20 20 20 20 20 3b 3b home") ;;
0800: 20 74 68 65 73 65 20 61 72 65 20 64 65 66 61 75 these are defau
0810: 6c 74 73 0a 20 20 28 73 6c 6f 74 2d 73 65 74 21 lts. (slot-set!
0820: 20 73 65 6c 66 20 27 63 75 72 72 2d 70 61 67 65 self 'curr-page
0830: 20 20 20 22 68 6f 6d 65 22 29 0a 20 20 28 73 6c "home"). (sl
0840: 6f 74 2d 73 65 74 21 20 73 65 6c 66 20 27 63 6f ot-set! self 'co
0850: 6e 74 65 6e 74 2d 74 79 70 65 20 22 43 6f 6e 74 ntent-type "Cont
0860: 65 6e 74 2d 74 79 70 65 3a 20 74 65 78 74 2f 68 ent-type: text/h
0870: 74 6d 6c 3b 20 63 68 61 72 73 65 74 3d 69 73 6f tml; charset=iso
0880: 2d 38 38 35 39 2d 31 5c 6e 5c 6e 22 29 0a 20 20 -8859-1\n\n").
0890: 28 73 6c 6f 74 2d 73 65 74 21 20 73 65 6c 66 20 (slot-set! self
08a0: 27 70 61 67 65 2d 74 79 70 65 20 20 20 27 68 74 'page-type 'ht
08b0: 6d 6c 29 0a 20 20 28 73 6c 6f 74 2d 73 65 74 21 ml). (slot-set!
08c0: 20 73 65 6c 66 20 27 74 6f 70 70 61 67 65 20 20 self 'toppage
08d0: 20 20 20 22 69 6e 64 65 78 22 29 0a 20 20 28 73 "index"). (s
08e0: 6c 6f 74 2d 73 65 74 21 20 73 65 6c 66 20 27 70 lot-set! self 'p
08f0: 61 72 61 6d 73 20 20 20 20 20 20 27 28 29 29 20 arams '())
0900: 20 20 20 20 20 20 20 20 20 20 3b 3b 0a 20 20 28 ;;. (
0910: 73 6c 6f 74 2d 73 65 74 21 20 73 65 6c 66 20 27 slot-set! self '
0920: 70 61 74 68 2d 70 61 72 61 6d 73 20 27 28 29 29 path-params '())
0930: 0a 20 20 28 73 6c 6f 74 2d 73 65 74 21 20 73 65 . (slot-set! se
0940: 6c 66 20 27 73 65 73 73 69 6f 6e 2d 6b 65 79 20 lf 'session-key
0950: 23 66 29 0a 20 20 28 73 6c 6f 74 2d 73 65 74 21 #f). (slot-set!
0960: 20 73 65 6c 66 20 27 70 61 67 65 64 61 74 20 20 self 'pagedat
0970: 20 20 20 27 28 29 29 0a 20 20 28 73 6c 6f 74 2d '()). (slot-
0980: 73 65 74 21 20 73 65 6c 66 20 27 61 6c 74 2d 70 set! self 'alt-p
0990: 61 67 65 2d 64 61 74 20 23 66 29 0a 20 20 28 73 age-dat #f). (s
09a0: 6c 6f 74 2d 73 65 74 21 20 73 65 6c 66 20 27 73 lot-set! self 's
09b0: 72 6f 6f 74 20 20 20 20 20 20 20 22 2e 2f 22 29 root "./")
09c0: 0a 20 20 28 73 6c 6f 74 2d 73 65 74 21 20 73 65 . (slot-set! se
09d0: 6c 66 20 27 73 65 73 73 69 6f 6e 2d 63 6f 6f 6b lf 'session-cook
09e0: 69 65 20 23 66 29 0a 20 20 28 73 6c 6f 74 2d 73 ie #f). (slot-s
09f0: 65 74 21 20 73 65 6c 66 20 27 63 75 72 72 2d 65 et! self 'curr-e
0a00: 72 72 20 23 66 29 0a 20 20 28 73 6c 6f 74 2d 73 rr #f). (slot-s
0a10: 65 74 21 20 73 65 6c 66 20 27 6c 6f 67 2d 70 6f et! self 'log-po
0a20: 72 74 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f rt (current-erro
0a30: 72 2d 70 6f 72 74 29 29 0a 20 20 28 73 6c 6f 74 r-port)). (slot
0a40: 2d 73 65 74 21 20 73 65 6c 66 20 27 73 65 65 6e -set! self 'seen
0a50: 2d 70 61 67 65 73 20 27 28 29 29 0a 20 20 28 73 -pages '()). (s
0a60: 6c 6f 74 2d 73 65 74 21 20 73 65 6c 66 20 27 70 lot-set! self 'p
0a70: 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 20 27 6f age-dir-style 'o
0a80: 6c 64 73 74 79 6c 65 29 20 3b 3b 20 6f 6e 65 64 ldstyle) ;; oned
0a90: 69 72 3a 20 20 20 20 20 20 20 20 70 61 67 65 73 ir: pages
0aa0: 2f 3c 70 61 67 65 6e 61 6d 65 3e 5f 28 76 69 65 /<pagename>_(vie
0ab0: 77 7c 63 6f 6e 74 72 6f 6c 29 2e 73 63 6d 0a 20 w|control).scm.
0ac0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0ad0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0ae0: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 61 ;; a
0af0: 6e 79 74 68 69 6e 67 20 65 6c 73 65 3a 20 70 61 nything else: pa
0b00: 67 65 73 2f 3c 70 61 67 65 6e 61 6d 65 3e 2f 28 ges/<pagename>/(
0b10: 76 69 65 77 7c 63 6f 6e 74 72 6f 6c 29 2e 73 63 view|control).sc
0b20: 6d 20 0a 20 20 28 73 6c 6f 74 2d 73 65 74 21 20 m . (slot-set!
0b30: 73 65 6c 66 20 27 64 65 62 75 67 6d 6f 64 65 20 self 'debugmode
0b40: 23 66 29 0a 20 20 28 66 6f 72 2d 65 61 63 68 20 #f). (for-each
0b50: 28 6c 61 6d 62 64 61 20 28 73 6c 6f 74 2d 6e 61 (lambda (slot-na
0b60: 6d 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 me).
0b70: 20 20 28 73 6c 6f 74 2d 73 65 74 21 20 73 65 6c (slot-set! sel
0b80: 66 20 73 6c 6f 74 2d 6e 61 6d 65 20 28 6d 61 6b f slot-name (mak
0b90: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a e-hash-table))).
0ba0: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 69 73 (lis
0bb0: 74 20 27 70 61 67 65 76 61 72 73 20 27 73 65 73 t 'pagevars 'ses
0bc0: 73 69 6f 6e 76 61 72 73 20 27 67 6c 6f 62 61 6c sionvars 'global
0bd0: 76 61 72 73 20 27 70 61 67 65 76 61 72 73 2d 62 vars 'pagevars-b
0be0: 65 66 6f 72 65 20 0a 09 09 20 20 27 73 65 73 73 efore ... 'sess
0bf0: 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 20 27 ionvars-before '
0c00: 67 6c 6f 62 61 6c 76 61 72 73 2d 62 65 66 6f 72 globalvars-befor
0c10: 65 29 29 0a 20 20 28 73 6c 6f 74 2d 73 65 74 21 e)). (slot-set!
0c20: 20 73 65 6c 66 20 27 64 6f 6d 61 69 6e 20 22 6c self 'domain "l
0c30: 6f 63 61 68 6f 73 74 22 29 20 20 20 3b 3b 20 65 ocahost") ;; e
0c40: 6e 64 20 6f 66 20 64 65 66 61 75 6c 74 73 0a 20 nd of defaults.
0c50: 20 28 69 6e 69 74 69 61 6c 69 7a 65 2d 73 6c 6f (initialize-slo
0c60: 74 73 20 73 65 6c 66 20 28 73 65 73 73 69 6f 6e ts self (session
0c70: 3a 72 65 61 64 2d 63 6f 6e 66 69 67 20 73 65 6c :read-config sel
0c80: 66 29 29 0a 20 20 3b 3b 20 73 6f 6d 65 20 76 61 f)). ;; some va
0c90: 6c 75 65 73 20 72 65 61 64 20 69 6e 20 66 72 6f lues read in fro
0ca0: 6d 20 74 68 65 20 63 6f 6e 66 69 67 20 66 69 6c m the config fil
0cb0: 65 20 6e 65 65 64 20 74 6f 20 62 65 20 65 76 61 e need to be eva
0cc0: 6c 65 64 0a 20 20 28 66 6f 72 2d 65 61 63 68 20 led. (for-each
0cd0: 28 6c 61 6d 62 64 61 20 28 73 6c 6f 74 2d 6e 61 (lambda (slot-na
0ce0: 6d 65 29 0a 09 20 20 20 20 20 20 28 73 6c 6f 74 me).. (slot
0cf0: 2d 73 65 74 21 20 73 65 6c 66 20 73 6c 6f 74 2d -set! self slot-
0d00: 6e 61 6d 65 20 28 65 76 61 6c 20 28 73 6c 6f 74 name (eval (slot
0d10: 2d 72 65 66 20 73 65 6c 66 20 73 6c 6f 74 2d 6e -ref self slot-n
0d20: 61 6d 65 29 29 29 29 0a 09 20 20 20 20 28 6c 69 ame)))).. (li
0d30: 73 74 20 27 64 62 74 79 70 65 29 29 0a 20 20 28 st 'dbtype)). (
0d40: 69 6e 69 74 69 61 6c 69 7a 65 2d 73 6c 6f 74 73 initialize-slots
0d50: 20 73 65 6c 66 20 69 6e 69 74 61 72 67 73 29 29 self initargs))
0d60: 0a 0a 28 64 65 66 69 6e 65 2d 6d 65 74 68 6f 64 ..(define-method
0d70: 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 20 (session:setup
0d80: 28 73 65 6c 66 20 3c 73 65 73 73 69 6f 6e 3e 29 (self <session>)
0d90: 29 0a 20 20 28 6c 65 74 20 28 28 64 62 74 79 70 ). (let ((dbtyp
0da0: 65 20 28 73 6c 6f 74 2d 72 65 66 20 73 65 6c 66 e (slot-ref self
0db0: 20 27 64 62 74 79 70 65 29 29 0a 09 28 64 62 69 'dbtype))..(dbi
0dc0: 6e 69 74 20 28 65 76 61 6c 20 28 73 6c 6f 74 2d nit (eval (slot-
0dd0: 72 65 66 20 73 65 6c 66 20 27 64 62 69 6e 69 74 ref self 'dbinit
0de0: 29 29 29 0a 09 28 64 62 65 78 69 73 74 73 20 23 )))..(dbexists #
0df0: 66 29 29 0a 20 20 20 20 28 6c 65 74 20 28 28 64 f)). (let ((d
0e00: 62 66 6e 61 6d 65 20 28 61 6c 69 73 74 2d 72 65 bfname (alist-re
0e10: 66 20 27 64 62 6e 61 6d 65 20 64 62 69 6e 69 74 f 'dbname dbinit
0e20: 29 29 29 0a 20 20 20 20 20 20 28 69 66 20 28 65 ))). (if (e
0e30: 71 3f 20 64 62 74 79 70 65 20 27 73 71 6c 69 74 q? dbtype 'sqlit
0e40: 65 33 29 0a 09 20 20 28 69 66 20 28 66 69 6c 65 e3).. (if (file
0e50: 2d 65 78 69 73 74 73 3f 20 64 62 66 6e 61 6d 65 -exists? dbfname
0e60: 29 0a 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a ).. (begin.
0e70: 09 09 3b 3b 20 28 73 65 73 73 69 6f 6e 3a 6c 6f ..;; (session:lo
0e80: 67 20 73 65 6c 66 20 22 73 65 74 74 69 6e 67 20 g self "setting
0e90: 64 62 65 78 69 73 74 73 20 74 6f 20 23 74 22 29 dbexists to #t")
0ea0: 0a 09 09 28 73 65 74 21 20 64 62 65 78 69 73 74 ...(set! dbexist
0eb0: 73 20 23 74 29 29 29 29 0a 20 20 20 20 20 20 3b s #t)))). ;
0ec0: 3b 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 ; (session:log s
0ed0: 65 6c 66 20 22 64 62 74 79 70 65 3a 20 22 20 64 elf "dbtype: " d
0ee0: 62 74 79 70 65 20 22 20 64 62 66 6e 61 6d 65 3a btype " dbfname:
0ef0: 20 22 20 64 62 66 6e 61 6d 65 20 22 20 64 62 65 " dbfname " dbe
0f00: 78 69 73 74 73 3a 20 22 20 64 62 65 78 69 73 74 xists: " dbexist
0f10: 73 29 29 0a 20 20 20 20 20 20 29 0a 20 20 20 20 s)). ).
0f20: 28 73 6c 6f 74 2d 73 65 74 21 20 73 65 6c 66 20 (slot-set! self
0f30: 27 63 6f 6e 6e 20 28 64 62 69 3a 6f 70 65 6e 20 'conn (dbi:open
0f40: 64 62 74 79 70 65 20 64 62 69 6e 69 74 29 29 0a dbtype dbinit)).
0f50: 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 6e 6f (if (and (no
0f60: 74 20 64 62 65 78 69 73 74 73 29 28 65 71 3f 20 t dbexists)(eq?
0f70: 64 62 74 79 70 65 20 27 73 71 6c 69 74 65 33 29 dbtype 'sqlite3)
0f80: 29 0a 20 09 28 62 65 67 69 6e 0a 09 20 20 28 70 ). .(begin.. (p
0f90: 72 69 6e 74 20 22 57 41 52 4e 49 4e 47 3a 20 53 rint "WARNING: S
0fa0: 65 74 74 69 6e 67 20 75 70 20 73 65 73 73 69 6f etting up sessio
0fb0: 6e 20 64 62 20 77 69 74 68 20 73 71 6c 69 74 65 n db with sqlite
0fc0: 33 22 29 0a 09 20 20 28 73 65 73 73 69 6f 6e 3a 3").. (session:
0fd0: 73 65 74 75 70 2d 64 62 20 73 65 6c 66 29 29 29 setup-db self)))
0fe0: 0a 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 70 72 . (session:pr
0ff0: 6f 63 65 73 73 2d 75 72 6c 2d 70 61 74 68 20 73 ocess-url-path s
1000: 65 6c 66 29 0a 20 20 20 20 28 73 65 73 73 69 6f elf). (sessio
1010: 6e 3a 73 65 74 75 70 2d 73 65 73 73 69 6f 6e 2d n:setup-session-
1020: 6b 65 79 20 73 65 6c 66 29 0a 20 20 20 20 3b 3b key self). ;;
1030: 20 63 61 70 74 75 72 65 20 73 74 64 69 6e 20 69 capture stdin i
1040: 66 20 74 68 69 73 20 69 73 20 61 20 50 4f 53 54 f this is a POST
1050: 0a 20 20 20 20 28 73 6c 6f 74 2d 73 65 74 21 20 . (slot-set!
1060: 73 65 6c 66 20 27 72 65 71 75 65 73 74 2d 6d 65 self 'request-me
1070: 74 68 6f 64 20 28 67 65 74 65 6e 76 20 22 52 45 thod (getenv "RE
1080: 51 55 45 53 54 5f 4d 45 54 48 4f 44 22 29 29 0a QUEST_METHOD")).
1090: 20 20 20 20 28 73 6c 6f 74 2d 73 65 74 21 20 73 (slot-set! s
10a0: 65 6c 66 20 27 66 6f 72 6d 64 61 74 20 28 66 6f elf 'formdat (fo
10b0: 72 6d 64 61 74 3a 6c 6f 61 64 2d 61 6c 6c 29 29 rmdat:load-all))
10c0: 29 29 0a 0a 3b 3b 20 73 65 74 75 70 20 74 68 65 ))..;; setup the
10d0: 20 64 62 20 77 69 74 68 20 73 65 73 73 69 6f 6e db with session
10e0: 20 74 61 62 6c 65 73 2c 20 77 6f 72 6b 73 20 66 tables, works f
10f0: 6f 72 20 73 71 6c 69 74 65 20 6f 6e 6c 79 20 72 or sqlite only r
1100: 69 67 68 74 20 6e 6f 77 0a 28 64 65 66 69 6e 65 ight now.(define
1110: 2d 6d 65 74 68 6f 64 20 28 73 65 73 73 69 6f 6e -method (session
1120: 3a 73 65 74 75 70 2d 64 62 20 28 73 65 6c 66 20 :setup-db (self
1130: 3c 73 65 73 73 69 6f 6e 3e 29 29 0a 20 20 28 6c <session>)). (l
1140: 65 74 20 28 28 63 6f 6e 6e 20 28 73 6c 6f 74 2d et ((conn (slot-
1150: 72 65 66 20 73 65 6c 66 20 27 63 6f 6e 6e 29 29 ref self 'conn))
1160: 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 ). (for-each
1170: 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 73 . (lambda (s
1180: 74 6d 74 29 0a 20 20 20 20 20 20 20 28 64 62 69 tmt). (dbi
1190: 3a 65 78 65 63 20 63 6f 6e 6e 20 73 74 6d 74 29 :exec conn stmt)
11a0: 29 0a 20 20 20 20 20 28 6c 69 73 74 20 22 43 52 ). (list "CR
11b0: 45 41 54 45 20 54 41 42 4c 45 20 73 65 73 73 69 EATE TABLE sessi
11c0: 6f 6e 5f 76 61 72 73 20 28 69 64 20 49 4e 54 45 on_vars (id INTE
11d0: 47 45 52 20 50 52 49 4d 41 52 59 20 4b 45 59 2c GER PRIMARY KEY,
11e0: 73 65 73 73 69 6f 6e 5f 69 64 20 49 4e 54 45 47 session_id INTEG
11f0: 45 52 2c 70 61 67 65 20 54 45 58 54 2c 6b 65 79 ER,page TEXT,key
1200: 20 54 45 58 54 2c 76 61 6c 75 65 20 54 45 58 54 TEXT,value TEXT
1210: 29 3b 22 0a 09 20 20 20 22 43 52 45 41 54 45 20 );".. "CREATE
1220: 54 41 42 4c 45 20 73 65 73 73 69 6f 6e 73 20 28 TABLE sessions (
1230: 69 64 20 49 4e 54 45 47 45 52 20 50 52 49 4d 41 id INTEGER PRIMA
1240: 52 59 20 4b 45 59 2c 73 65 73 73 69 6f 6e 5f 6b RY KEY,session_k
1250: 65 79 20 54 45 58 54 2c 6c 61 73 74 5f 75 73 65 ey TEXT,last_use
1260: 64 20 54 49 4d 45 53 54 41 4d 50 29 3b 22 0a 20 d TIMESTAMP);".
1270: 20 20 20 20 20 20 20 20 20 20 22 43 52 45 41 54 "CREAT
1280: 45 20 54 41 42 4c 45 20 6d 65 74 61 64 61 74 61 E TABLE metadata
1290: 20 28 69 64 20 49 4e 54 45 47 45 52 20 50 52 49 (id INTEGER PRI
12a0: 4d 41 52 59 20 4b 45 59 2c 6b 65 79 20 54 45 58 MARY KEY,key TEX
12b0: 54 2c 76 61 6c 75 65 20 54 45 58 54 29 3b 22 29 T,value TEXT);")
12c0: 29 29 29 0a 3b 3b 20 20 3b 3b 20 69 66 20 77 65 ))).;; ;; if we
12d0: 20 68 61 76 65 20 61 20 73 65 73 73 69 6f 6e 5f have a session_
12e0: 6b 65 79 20 6c 6f 6f 6b 20 75 70 20 74 68 65 20 key look up the
12f0: 73 65 73 73 69 6f 6e 2d 69 64 20 61 6e 64 20 73 session-id and s
1300: 74 6f 72 65 20 69 74 0a 3b 3b 20 20 28 73 6c 6f tore it.;; (slo
1310: 74 2d 73 65 74 21 20 73 65 6c 66 20 27 73 65 73 t-set! self 'ses
1320: 73 69 6f 6e 2d 69 64 20 28 73 65 73 73 69 6f 6e sion-id (session
1330: 3a 67 65 74 2d 69 64 20 73 65 6c 66 29 29 29 0a :get-id self))).
1340: 0a 3b 3b 20 6f 6e 6c 79 20 73 65 74 20 73 65 73 .;; only set ses
1350: 73 69 6f 6e 2d 63 6f 6f 6b 69 65 20 77 68 65 6e sion-cookie when
1360: 20 61 20 6e 65 77 20 73 65 73 73 69 6f 6e 20 69 a new session i
1370: 73 20 63 72 65 61 74 65 64 0a 28 64 65 66 69 6e s created.(defin
1380: 65 2d 6d 65 74 68 6f 64 20 28 73 65 73 73 69 6f e-method (sessio
1390: 6e 3a 73 65 74 75 70 2d 73 65 73 73 69 6f 6e 2d n:setup-session-
13a0: 6b 65 79 20 28 73 65 6c 66 20 3c 73 65 73 73 69 key (self <sessi
13b0: 6f 6e 3e 29 29 20 20 0a 20 20 28 6c 65 74 2a 20 on>)) . (let*
13c0: 28 28 73 6b 20 20 28 73 65 73 73 69 6f 6e 3a 65 ((sk (session:e
13d0: 78 74 72 61 63 74 2d 73 65 73 73 69 6f 6e 2d 6b xtract-session-k
13e0: 65 79 20 73 65 6c 66 29 29 0a 20 20 20 20 20 20 ey self)).
13f0: 20 20 20 28 73 69 64 20 28 69 66 20 73 6b 20 28 (sid (if sk (
1400: 73 65 73 73 69 6f 6e 3a 67 65 74 2d 69 64 20 73 session:get-id s
1410: 65 6c 66 20 73 6b 29 20 23 66 29 29 29 0a 20 20 elf sk) #f))).
1420: 20 20 28 69 66 20 28 6e 6f 74 20 73 69 64 29 20 (if (not sid)
1430: 3b 3b 20 6e 65 65 64 20 61 20 6e 65 77 20 6b 65 ;; need a new ke
1440: 79 0a 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 y. (let*
1450: 28 28 6e 65 77 2d 6b 65 79 20 28 73 65 73 73 69 ((new-key (sessi
1460: 6f 6e 3a 67 65 74 2d 6e 65 77 2d 6b 65 79 20 73 on:get-new-key s
1470: 65 6c 66 29 29 0a 20 20 20 20 20 20 20 20 20 20 elf)).
1480: 20 20 20 20 20 28 6e 65 77 2d 73 69 64 20 28 73 (new-sid (s
1490: 65 73 73 69 6f 6e 3a 67 65 74 2d 69 64 20 73 65 ession:get-id se
14a0: 6c 66 20 6e 65 77 2d 6b 65 79 29 29 29 0a 20 20 lf new-key))).
14b0: 20 20 20 20 20 20 20 20 28 73 6c 6f 74 2d 73 65 (slot-se
14c0: 74 21 20 73 65 6c 66 20 27 73 65 73 73 69 6f 6e t! self 'session
14d0: 2d 6b 65 79 20 6e 65 77 2d 6b 65 79 29 0a 20 20 -key new-key).
14e0: 20 20 20 20 20 20 20 20 28 73 6c 6f 74 2d 73 65 (slot-se
14f0: 74 21 20 73 65 6c 66 20 27 73 65 73 73 69 6f 6e t! self 'session
1500: 2d 69 64 20 6e 65 77 2d 73 69 64 29 0a 20 20 20 -id new-sid).
1510: 20 20 20 20 20 20 20 28 73 6c 6f 74 2d 73 65 74 (slot-set
1520: 21 20 73 65 6c 66 20 27 73 65 73 73 69 6f 6e 2d ! self 'session-
1530: 63 6f 6f 6b 69 65 20 28 73 65 73 73 69 6f 6e 3a cookie (session:
1540: 6d 61 6b 65 2d 63 6f 6f 6b 69 65 20 73 65 6c 66 make-cookie self
1550: 29 29 29 0a 20 20 20 20 20 20 20 20 28 73 6c 6f ))). (slo
1560: 74 2d 73 65 74 21 20 73 65 6c 66 20 27 73 65 73 t-set! self 'ses
1570: 73 69 6f 6e 2d 69 64 20 73 69 64 29 29 29 29 0a sion-id sid)))).
1580: 0a 28 64 65 66 69 6e 65 2d 6d 65 74 68 6f 64 20 .(define-method
1590: 28 73 65 73 73 69 6f 6e 3a 6d 61 6b 65 2d 63 6f (session:make-co
15a0: 6f 6b 69 65 20 28 73 65 6c 66 20 3c 73 65 73 73 okie (self <sess
15b0: 69 6f 6e 3e 29 29 0a 20 20 3b 3b 20 28 6c 69 73 ion>)). ;; (lis
15c0: 74 20 28 63 6f 6e 63 20 22 73 65 73 73 69 6f 6e t (conc "session
15d0: 5f 6b 65 79 3d 22 20 28 73 6c 6f 74 2d 72 65 66 _key=" (slot-ref
15e0: 20 73 65 6c 66 20 27 73 65 73 73 69 6f 6e 2d 6b self 'session-k
15f0: 65 79 29 20 22 3b 20 50 61 74 68 3d 2f 3b 20 44 ey) "; Path=/; D
1600: 6f 6d 61 69 6e 3d 2e 22 20 28 73 6c 6f 74 2d 72 omain=." (slot-r
1610: 65 66 20 73 65 6c 66 20 27 64 6f 6d 61 69 6e 29 ef self 'domain)
1620: 20 22 3b 20 4d 61 78 2d 41 67 65 3d 22 20 28 2a "; Max-Age=" (*
1630: 20 38 36 34 30 30 20 31 34 29 20 22 3b 20 56 65 86400 14) "; Ve
1640: 72 73 69 6f 6e 3d 31 22 29 29 29 20 0a 20 20 28 rsion=1"))) . (
1650: 6c 69 73 74 20 28 73 74 72 69 6e 67 2d 73 75 62 list (string-sub
1660: 73 74 69 74 75 74 65 20 0a 09 20 22 3b 22 20 22 stitute .. ";" "
1670: 3b 20 22 20 0a 09 20 28 63 61 72 20 28 63 6f 6e ; " .. (car (con
1680: 73 74 72 75 63 74 2d 63 6f 6f 6b 69 65 2d 73 74 struct-cookie-st
1690: 72 69 6e 67 20 0a 09 20 20 20 20 20 20 20 3b 3b ring .. ;;
16a0: 20 77 61 72 6e 69 6e 67 21 20 6d 65 73 73 69 6e warning! messin
16b0: 67 20 75 70 20 74 68 69 73 20 69 74 74 79 20 62 g up this itty b
16c0: 69 74 74 79 20 62 69 74 20 6f 66 20 63 6f 64 65 itty bit of code
16d0: 20 77 69 6c 6c 20 63 6f 73 74 20 6d 75 63 68 20 will cost much
16e0: 74 69 6d 65 21 0a 09 20 20 20 20 20 20 20 60 28 time!.. `(
16f0: 28 22 73 65 73 73 69 6f 6e 5f 6b 65 79 22 20 2c ("session_key" ,
1700: 28 73 6c 6f 74 2d 72 65 66 20 73 65 6c 66 20 27 (slot-ref self '
1710: 73 65 73 73 69 6f 6e 2d 6b 65 79 29 0a 09 09 20 session-key)...
1720: 20 65 78 70 69 72 65 73 3a 20 2c 28 2b 20 28 63 expires: ,(+ (c
1730: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 urrent-seconds)
1740: 28 2a 20 31 34 20 38 36 34 30 30 29 29 20 0a 09 (* 14 86400)) ..
1750: 09 20 20 6d 61 78 2d 61 67 65 3a 20 28 2a 20 31 . max-age: (* 1
1760: 34 20 38 36 34 30 30 29 0a 09 09 20 20 70 61 74 4 86400)... pat
1770: 68 3a 20 22 2f 22 20 3b 3b 20 0a 09 09 20 20 64 h: "/" ;; ... d
1780: 6f 6d 61 69 6e 3a 20 2c 28 73 74 72 69 6e 67 2d omain: ,(string-
1790: 61 70 70 65 6e 64 20 22 2e 22 20 28 73 6c 6f 74 append "." (slot
17a0: 2d 72 65 66 20 73 65 6c 66 20 27 64 6f 6d 61 69 -ref self 'domai
17b0: 6e 29 29 0a 09 09 20 20 76 65 72 73 69 6f 6e 3a n))... version:
17c0: 20 31 29 29 20 30 29 29 29 29 29 0a 0a 3b 3b 20 1)) 0)))))..;;
17d0: 6c 6f 6f 6b 20 75 70 20 61 20 67 69 76 65 6e 20 look up a given
17e0: 73 65 73 73 69 6f 6e 20 6b 65 79 20 61 6e 64 20 session key and
17f0: 72 65 74 75 72 6e 20 74 68 65 20 69 64 20 69 66 return the id if
1800: 20 66 6f 75 6e 64 2c 20 23 66 20 69 66 20 6e 6f found, #f if no
1810: 74 20 66 6f 75 6e 64 0a 28 64 65 66 69 6e 65 2d t found.(define-
1820: 6d 65 74 68 6f 64 20 28 73 65 73 73 69 6f 6e 3a method (session:
1830: 67 65 74 2d 69 64 20 28 73 65 6c 66 20 3c 73 65 get-id (self <se
1840: 73 73 69 6f 6e 3e 29 20 73 65 73 73 69 6f 6e 2d ssion>) session-
1850: 6b 65 79 29 0a 20 20 3b 3b 20 28 6c 65 74 20 28 key). ;; (let (
1860: 28 73 65 73 73 69 6f 6e 2d 6b 65 79 20 28 73 6c (session-key (sl
1870: 6f 74 2d 72 65 66 20 73 65 6c 66 20 27 73 65 73 ot-ref self 'ses
1880: 73 69 6f 6e 2d 6b 65 79 29 29 29 0a 20 20 28 69 sion-key))). (i
1890: 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 0a 20 20 f session-key.
18a0: 20 20 20 20 28 6c 65 74 20 28 28 71 75 65 72 79 (let ((query
18b0: 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 (string-append
18c0: 22 53 45 4c 45 43 54 20 69 64 20 46 52 4f 4d 20 "SELECT id FROM
18d0: 73 65 73 73 69 6f 6e 73 20 57 48 45 52 45 20 73 sessions WHERE s
18e0: 65 73 73 69 6f 6e 5f 6b 65 79 3d 27 22 20 73 65 ession_key='" se
18f0: 73 73 69 6f 6e 2d 6b 65 79 20 22 27 22 29 29 0a ssion-key "'")).
1900: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e (con
1910: 6e 20 28 73 6c 6f 74 2d 72 65 66 20 73 65 6c 66 n (slot-ref self
1920: 20 27 63 6f 6e 6e 29 29 0a 20 20 20 20 20 20 20 'conn)).
1930: 20 20 20 20 20 28 72 65 73 75 6c 74 20 23 66 29 (result #f)
1940: 29 0a 09 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 )..(dbi:for-each
1950: 2d 72 6f 77 20 0a 09 20 28 6c 61 6d 62 64 61 20 -row .. (lambda
1960: 28 74 75 70 6c 65 29 0a 09 20 20 20 28 73 65 74 (tuple).. (set
1970: 21 20 72 65 73 75 6c 74 20 28 76 65 63 74 6f 72 ! result (vector
1980: 2d 72 65 66 20 74 75 70 6c 65 20 30 29 29 29 0a -ref tuple 0))).
1990: 09 20 63 6f 6e 6e 20 71 75 65 72 79 29 0a 09 28 . conn query)..(
19a0: 69 66 20 72 65 73 75 6c 74 20 28 64 62 69 3a 65 if result (dbi:e
19b0: 78 65 63 20 63 6f 6e 6e 20 28 63 6f 6e 63 20 22 xec conn (conc "
19c0: 55 50 44 41 54 45 20 73 65 73 73 69 6f 6e 73 20 UPDATE sessions
19d0: 53 45 54 20 6c 61 73 74 5f 75 73 65 64 3d 22 20 SET last_used="
19e0: 28 64 62 69 3a 6e 6f 77 20 63 6f 6e 6e 29 20 22 (dbi:now conn) "
19f0: 20 57 48 45 52 45 20 73 65 73 73 69 6f 6e 5f 6b WHERE session_k
1a00: 65 79 3d 3f 3b 22 29 20 73 65 73 73 69 6f 6e 2d ey=?;") session-
1a10: 6b 65 79 29 29 0a 20 20 20 20 20 20 20 20 72 65 key)). re
1a20: 73 75 6c 74 29 0a 20 20 20 20 20 20 23 66 29 29 sult). #f))
1a30: 0a 0a 3b 3b 20 0a 28 64 65 66 69 6e 65 2d 6d 65 ..;; .(define-me
1a40: 74 68 6f 64 20 28 73 65 73 73 69 6f 6e 3a 70 72 thod (session:pr
1a50: 6f 63 65 73 73 2d 75 72 6c 2d 70 61 74 68 20 28 ocess-url-path (
1a60: 73 65 6c 66 20 3c 73 65 73 73 69 6f 6e 3e 29 29 self <session>))
1a70: 0a 20 20 28 6c 65 74 20 28 28 70 61 74 68 2d 69 . (let ((path-i
1a80: 6e 66 6f 20 20 20 20 28 67 65 74 65 6e 76 20 22 nfo (getenv "
1a90: 50 41 54 48 5f 49 4e 46 4f 22 29 29 0a 09 28 71 PATH_INFO"))..(q
1aa0: 75 65 72 79 2d 73 74 72 69 6e 67 20 28 67 65 74 uery-string (get
1ab0: 65 6e 76 20 22 51 55 45 52 59 5f 53 54 52 49 4e env "QUERY_STRIN
1ac0: 47 22 29 29 29 0a 20 20 20 20 3b 3b 20 28 73 65 G"))). ;; (se
1ad0: 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 ssion:log self "
1ae0: 70 61 74 68 2d 69 6e 66 6f 3d 22 20 70 61 74 68 path-info=" path
1af0: 2d 69 6e 66 6f 20 22 20 71 75 65 72 79 2d 73 74 -info " query-st
1b00: 72 69 6e 67 3d 22 20 71 75 65 72 79 2d 73 74 72 ring=" query-str
1b10: 69 6e 67 29 0a 20 20 20 20 28 69 66 20 70 61 74 ing). (if pat
1b20: 68 2d 69 6e 66 6f 0a 09 28 6c 65 74 2a 20 28 28 h-info..(let* ((
1b30: 70 61 72 74 73 20 20 20 20 28 73 74 72 69 6e 67 parts (string
1b40: 2d 73 70 6c 69 74 20 70 61 74 68 2d 69 6e 66 6f -split path-info
1b50: 20 22 2f 22 29 29 0a 09 20 20 20 20 20 20 20 28 "/")).. (
1b60: 6e 75 6d 70 61 72 74 73 20 28 6c 65 6e 67 74 68 numparts (length
1b70: 20 70 61 72 74 73 29 29 29 0a 09 20 20 28 69 66 parts))).. (if
1b80: 20 28 3e 20 6e 75 6d 70 61 72 74 73 20 30 29 0a (> numparts 0).
1b90: 09 20 20 20 20 20 20 28 73 6c 6f 74 2d 73 65 74 . (slot-set
1ba0: 21 20 73 65 6c 66 20 27 70 61 67 65 20 28 63 61 ! self 'page (ca
1bb0: 72 20 70 61 72 74 73 29 29 29 0a 09 20 20 3b 3b r parts))).. ;;
1bc0: 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 (session:log se
1bd0: 6c 66 20 22 75 72 6c 2d 70 61 74 68 3d 22 20 75 lf "url-path=" u
1be0: 72 6c 2d 70 61 74 68 20 22 20 70 61 72 74 73 3d rl-path " parts=
1bf0: 22 20 70 61 72 74 73 29 0a 09 20 20 28 69 66 20 " parts).. (if
1c00: 28 3e 20 6e 75 6d 70 61 72 74 73 20 31 29 0a 09 (> numparts 1)..
1c10: 20 20 20 20 20 20 28 73 6c 6f 74 2d 73 65 74 21 (slot-set!
1c20: 20 73 65 6c 66 20 27 70 61 74 68 2d 70 61 72 61 self 'path-para
1c30: 6d 73 20 28 63 64 72 20 70 61 72 74 73 29 29 29 ms (cdr parts)))
1c40: 0a 20 20 20 20 20 20 20 20 20 20 28 69 66 20 71 . (if q
1c50: 75 65 72 79 2d 73 74 72 69 6e 67 0a 20 20 20 20 uery-string.
1c60: 20 20 20 20 20 20 20 20 20 20 28 73 6c 6f 74 2d (slot-
1c70: 73 65 74 21 20 73 65 6c 66 20 27 70 61 72 61 6d set! self 'param
1c80: 73 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 s (string-split
1c90: 71 75 65 72 79 2d 73 74 72 69 6e 67 20 22 26 22 query-string "&"
1ca0: 29 29 29 29 29 29 29 0a 0a 3b 3b 20 42 55 47 47 )))))))..;; BUGG
1cb0: 59 21 0a 28 64 65 66 69 6e 65 2d 6d 65 74 68 6f Y!.(define-metho
1cc0: 64 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 6e d (session:get-n
1cd0: 65 77 2d 6b 65 79 20 28 73 65 6c 66 20 3c 73 65 ew-key (self <se
1ce0: 73 73 69 6f 6e 3e 29 29 0a 20 20 28 6c 65 74 20 ssion>)). (let
1cf0: 28 28 63 6f 6e 6e 20 20 20 28 73 6c 6f 74 2d 72 ((conn (slot-r
1d00: 65 66 20 73 65 6c 66 20 27 63 6f 6e 6e 29 29 0a ef self 'conn)).
1d10: 20 20 20 20 20 20 20 20 28 74 6d 70 6b 65 79 20 (tmpkey
1d20: 28 73 65 73 73 69 6f 6e 3a 6d 61 6b 65 2d 72 61 (session:make-ra
1d30: 6e 64 2d 73 74 72 69 6e 67 20 32 30 29 29 0a 20 nd-string 20)).
1d40: 20 20 20 20 20 20 20 28 73 74 61 74 75 73 20 23 (status #
1d50: 66 29 29 0a 20 20 20 20 28 64 62 69 3a 66 6f 72 f)). (dbi:for
1d60: 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 6d 62 64 -each-row (lambd
1d70: 61 20 28 74 75 70 6c 65 29 0a 09 09 09 28 73 65 a (tuple)....(se
1d80: 74 21 20 73 74 61 74 75 73 20 23 74 29 29 0a 09 t! status #t))..
1d90: 09 20 20 20 20 20 20 63 6f 6e 6e 20 28 73 74 72 . conn (str
1da0: 69 6e 67 2d 61 70 70 65 6e 64 20 22 49 4e 53 45 ing-append "INSE
1db0: 52 54 20 49 4e 54 4f 20 73 65 73 73 69 6f 6e 73 RT INTO sessions
1dc0: 20 28 73 65 73 73 69 6f 6e 5f 6b 65 79 29 20 56 (session_key) V
1dd0: 41 4c 55 45 53 20 28 27 22 20 74 6d 70 6b 65 79 ALUES ('" tmpkey
1de0: 20 22 27 29 22 29 29 0a 20 20 20 20 74 6d 70 6b "')")). tmpk
1df0: 65 79 29 29 0a 0a 3b 3b 20 72 65 74 75 72 6e 73 ey))..;; returns
1e00: 20 73 65 73 73 69 6f 6e 20 6b 65 79 20 49 46 46 session key IFF
1e10: 20 69 74 20 69 73 20 69 6e 20 74 68 65 20 48 54 it is in the HT
1e20: 54 50 5f 43 4f 4f 4b 49 45 20 0a 28 64 65 66 69 TP_COOKIE .(defi
1e30: 6e 65 2d 6d 65 74 68 6f 64 20 28 73 65 73 73 69 ne-method (sessi
1e40: 6f 6e 3a 65 78 74 72 61 63 74 2d 73 65 73 73 69 on:extract-sessi
1e50: 6f 6e 2d 6b 65 79 20 28 73 65 6c 66 20 3c 73 65 on-key (self <se
1e60: 73 73 69 6f 6e 3e 29 29 0a 20 20 28 6c 65 74 20 ssion>)). (let
1e70: 28 28 68 74 74 70 2d 73 65 73 73 69 6f 6e 20 28 ((http-session (
1e80: 67 65 74 65 6e 76 20 22 48 54 54 50 5f 43 4f 4f getenv "HTTP_COO
1e90: 4b 49 45 22 29 29 29 0a 20 20 20 20 28 69 66 20 KIE"))). (if
1ea0: 68 74 74 70 2d 73 65 73 73 69 6f 6e 20 0a 20 20 http-session .
1eb0: 20 20 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 65 (session:e
1ec0: 78 74 72 61 63 74 2d 6b 65 79 2d 66 72 6f 6d 2d xtract-key-from-
1ed0: 70 61 72 61 6d 20 73 65 6c 66 20 28 6c 69 73 74 param self (list
1ee0: 20 68 74 74 70 2d 73 65 73 73 69 6f 6e 29 20 22 http-session) "
1ef0: 73 65 73 73 69 6f 6e 5f 6b 65 79 22 29 0a 20 20 session_key").
1f00: 20 20 20 20 20 20 23 66 29 29 29 0a 0a 28 64 65 #f)))..(de
1f10: 66 69 6e 65 2d 6d 65 74 68 6f 64 20 28 73 65 73 fine-method (ses
1f20: 73 69 6f 6e 3a 67 65 74 2d 73 65 73 73 69 6f 6e sion:get-session
1f30: 2d 69 64 20 28 73 65 6c 66 20 3c 73 65 73 73 69 -id (self <sessi
1f40: 6f 6e 3e 29 20 73 65 73 73 69 6f 6e 2d 6b 65 79 on>) session-key
1f50: 29 0a 20 20 28 6c 65 74 20 28 28 71 75 65 72 79 ). (let ((query
1f60: 20 22 53 45 4c 45 43 54 20 69 64 20 46 52 4f 4d "SELECT id FROM
1f70: 20 73 65 73 73 69 6f 6e 73 20 57 48 45 52 45 20 sessions WHERE
1f80: 73 65 73 73 69 6f 6e 5f 6b 65 79 3d 3f 3b 22 29 session_key=?;")
1f90: 0a 20 20 20 20 20 20 20 20 28 72 65 73 75 6c 74 . (result
1fa0: 20 23 66 29 29 0a 20 20 20 20 3b 3b 20 20 20 20 #f)). ;;
1fb0: 20 28 70 67 3a 71 75 65 72 79 2d 66 6f 72 2d 65 (pg:query-for-e
1fc0: 61 63 68 20 28 6c 61 6d 62 64 61 20 28 74 75 70 ach (lambda (tup
1fd0: 6c 65 29 0a 20 20 20 20 3b 3b 20 20 20 20 20 20 le). ;;
1fe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1ff0: 20 20 20 20 28 73 65 74 21 20 72 65 73 75 6c 74 (set! result
2000: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 (vector-ref tup
2010: 6c 65 20 30 29 29 29 20 3b 3b 20 28 76 65 63 74 le 0))) ;; (vect
2020: 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 30 29 29 or-ref tuple 0))
2030: 29 0a 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 ). ;;
2040: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2050: 28 73 3a 73 71 6c 70 61 72 61 6d 20 71 75 65 72 (s:sqlparam quer
2060: 79 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 0a 20 y session-key).
2070: 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 ;;
2080: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 6c (sl
2090: 6f 74 2d 72 65 66 20 73 65 6c 66 20 27 63 6f 6e ot-ref self 'con
20a0: 6e 29 29 0a 20 20 20 20 3b 3b 20 20 20 20 20 20 n)). ;;
20b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
20c0: 20 20 63 6f 6e 6e 29 0a 20 20 20 20 28 64 62 69 conn). (dbi
20d0: 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 28 6c :for-each-row (l
20e0: 61 6d 62 64 61 20 28 74 75 70 6c 65 29 0a 09 09 ambda (tuple)...
20f0: 09 28 73 65 74 21 20 72 65 73 75 6c 74 20 28 76 .(set! result (v
2100: 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 ector-ref tuple
2110: 30 29 29 29 20 3b 3b 20 28 76 65 63 74 6f 72 2d 0))) ;; (vector-
2120: 72 65 66 20 74 75 70 6c 65 20 30 29 29 29 0a 09 ref tuple 0)))..
2130: 09 20 20 20 20 20 20 28 73 6c 6f 74 2d 72 65 66 . (slot-ref
2140: 20 73 65 6c 66 20 27 63 6f 6e 6e 29 0a 09 09 20 self 'conn)...
2150: 20 20 20 20 20 28 73 3a 73 71 6c 70 61 72 61 6d (s:sqlparam
2160: 20 71 75 65 72 79 20 73 65 73 73 69 6f 6e 2d 6b query session-k
2170: 65 79 29 29 0a 20 20 20 20 72 65 73 75 6c 74 29 ey)). result)
2180: 29 0a 0a 3b 3b 20 64 65 6c 65 74 65 20 61 6c 6c )..;; delete all
2190: 20 72 65 63 6f 72 64 73 20 66 6f 72 20 61 20 73 records for a s
21a0: 65 73 73 69 6f 6e 0a 3b 3b 0a 28 64 65 66 69 6e ession.;;.(defin
21b0: 65 2d 6d 65 74 68 6f 64 20 28 73 65 73 73 69 6f e-method (sessio
21c0: 6e 3a 64 65 6c 65 74 65 2d 73 65 73 73 69 6f 6e n:delete-session
21d0: 20 28 73 65 6c 66 20 3c 73 65 73 73 69 6f 6e 3e (self <session>
21e0: 29 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 0a 20 ) session-key).
21f0: 20 28 6c 65 74 20 28 28 73 65 73 73 69 6f 6e 2d (let ((session-
2200: 69 64 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d id (session:get-
2210: 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 20 session-id self
2220: 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 0a 20 20 session-key)).
2230: 20 20 20 20 20 20 28 71 72 79 20 20 20 20 20 20 (qry
2240: 20 20 28 63 6f 6e 63 20 22 42 45 47 49 4e 3b 22 (conc "BEGIN;"
2250: 0a 09 09 09 20 20 22 44 45 4c 45 54 45 20 46 52 .... "DELETE FR
2260: 4f 4d 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 OM session_vars
2270: 57 48 45 52 45 20 73 65 73 73 69 6f 6e 5f 69 64 WHERE session_id
2280: 3d 3f 3b 22 0a 20 20 20 20 20 20 20 20 20 20 20 =?;".
2290: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 22 "
22a0: 44 45 4c 45 54 45 20 46 52 4f 4d 20 73 65 73 73 DELETE FROM sess
22b0: 69 6f 6e 73 20 57 48 45 52 45 20 69 64 3d 3f 3b ions WHERE id=?;
22c0: 22 0a 09 09 09 20 20 22 43 4f 4d 4d 49 54 3b 22 ".... "COMMIT;"
22d0: 29 29 0a 20 20 20 20 20 20 20 20 28 63 6f 6e 6e )). (conn
22e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
22f0: 6c 6f 74 2d 72 65 66 20 73 65 6c 66 20 27 63 6f lot-ref self 'co
2300: 6e 6e 29 29 29 0a 20 20 20 20 28 69 66 20 73 65 nn))). (if se
2310: 73 73 69 6f 6e 2d 69 64 0a 20 20 20 20 20 20 20 ssion-id.
2320: 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 (begin.
2330: 20 20 28 64 62 69 3a 65 78 65 63 20 63 6f 6e 6e (dbi:exec conn
2340: 20 71 72 79 20 73 65 73 73 69 6f 6e 2d 69 64 20 qry session-id
2350: 73 65 73 73 69 6f 6e 2d 69 64 29 0a 09 20 20 28 session-id).. (
2360: 69 6e 69 74 69 61 6c 69 7a 65 20 73 65 6c 66 20 initialize self
2370: 27 28 29 29 0a 09 20 20 28 73 65 73 73 69 6f 6e '()).. (session
2380: 3a 73 65 74 75 70 20 73 65 6c 66 29 29 29 0a 20 :setup self))).
2390: 20 20 20 28 6e 6f 74 20 28 73 65 73 73 69 6f 6e (not (session
23a0: 3a 67 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 :get-session-id
23b0: 73 65 6c 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 self session-key
23c0: 29 29 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 ))))..;; (define
23d0: 2d 6d 65 74 68 6f 64 20 28 73 65 73 73 69 6f 6e -method (session
23e0: 3a 64 65 6c 65 74 65 2d 73 65 73 73 69 6f 6e 20 :delete-session
23f0: 28 73 65 6c 66 20 3c 73 65 73 73 69 6f 6e 3e 29 (self <session>)
2400: 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 0a 3b 3b session-key).;;
2410: 20 20 20 28 6c 65 74 20 28 28 73 65 73 73 69 6f (let ((sessio
2420: 6e 2d 69 64 20 28 73 65 73 73 69 6f 6e 3a 67 65 n-id (session:ge
2430: 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c t-session-id sel
2440: 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 0a f session-key)).
2450: 3b 3b 20 20 20 20 20 20 20 20 20 28 71 75 65 72 ;; (quer
2460: 69 65 73 20 20 20 20 28 6c 69 73 74 20 22 42 45 ies (list "BE
2470: 47 49 4e 3b 22 0a 3b 3b 20 09 09 09 20 20 22 44 GIN;".;; ... "D
2480: 45 4c 45 54 45 20 46 52 4f 4d 20 73 65 73 73 69 ELETE FROM sessi
2490: 6f 6e 5f 76 61 72 73 20 57 48 45 52 45 20 73 65 on_vars WHERE se
24a0: 73 73 69 6f 6e 5f 69 64 3d 3f 3b 22 0a 3b 3b 20 ssion_id=?;".;;
24b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
24c0: 20 20 20 20 20 20 20 20 20 20 22 44 45 4c 45 54 "DELET
24d0: 45 20 46 52 4f 4d 20 73 65 73 73 69 6f 6e 73 20 E FROM sessions
24e0: 57 48 45 52 45 20 69 64 3d 3f 3b 22 0a 3b 3b 20 WHERE id=?;".;;
24f0: 09 09 09 20 20 22 43 4f 4d 4d 49 54 3b 22 29 29 ... "COMMIT;"))
2500: 0a 3b 3b 20 20 20 20 20 20 20 20 20 28 63 6f 6e .;; (con
2510: 6e 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 n (
2520: 73 6c 6f 74 2d 72 65 66 20 73 65 6c 66 20 27 63 slot-ref self 'c
2530: 6f 6e 6e 29 29 29 0a 3b 3b 20 20 20 20 20 28 69 onn))).;; (i
2540: 66 20 73 65 73 73 69 6f 6e 2d 69 64 0a 3b 3b 20 f session-id.;;
2550: 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 3b (begin.;
2560: 3b 20 20 20 20 20 20 20 20 20 20 20 28 66 6f 72 ; (for
2570: 2d 65 61 63 68 0a 3b 3b 20 20 20 20 20 20 20 20 -each.;;
2580: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 71 75 65 (lambda (que
2590: 72 79 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 ry).;;
25a0: 20 20 20 20 28 64 62 69 3a 65 78 65 63 20 63 6f (dbi:exec co
25b0: 6e 6e 20 71 75 65 72 79 20 73 65 73 73 69 6f 6e nn query session
25c0: 2d 69 64 29 29 0a 3b 3b 20 09 20 20 20 71 75 65 -id)).;; . que
25d0: 72 69 65 73 29 0a 3b 3b 20 09 20 20 28 69 6e 69 ries).;; . (ini
25e0: 74 69 61 6c 69 7a 65 20 73 65 6c 66 20 27 28 29 tialize self '()
25f0: 29 0a 3b 3b 20 09 20 20 28 73 65 73 73 69 6f 6e ).;; . (session
2600: 3a 73 65 74 75 70 20 73 65 6c 66 29 29 29 0a 3b :setup self))).;
2610: 3b 20 20 20 20 20 28 6e 6f 74 20 28 73 65 73 73 ; (not (sess
2620: 69 6f 6e 3a 67 65 74 2d 73 65 73 73 69 6f 6e 2d ion:get-session-
2630: 69 64 20 73 65 6c 66 20 73 65 73 73 69 6f 6e 2d id self session-
2640: 6b 65 79 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 key))))..(define
2650: 2d 6d 65 74 68 6f 64 20 28 73 65 73 73 69 6f 6e -method (session
2660: 3a 65 78 74 72 61 63 74 2d 6b 65 79 20 28 73 65 :extract-key (se
2670: 6c 66 20 3c 73 65 73 73 69 6f 6e 3e 29 20 6b 65 lf <session>) ke
2680: 79 29 0a 20 20 28 6c 65 74 20 28 28 70 61 72 61 y). (let ((para
2690: 6d 73 20 28 73 6c 6f 74 2d 72 65 66 20 73 65 6c ms (slot-ref sel
26a0: 66 20 27 70 61 72 61 6d 73 29 29 29 0a 20 20 20 f 'params))).
26b0: 20 28 73 65 73 73 69 6f 6e 3a 65 78 74 72 61 63 (session:extrac
26c0: 74 2d 6b 65 79 2d 66 72 6f 6d 2d 70 61 72 61 6d t-key-from-param
26d0: 20 73 65 6c 66 20 70 61 72 61 6d 73 20 6b 65 79 self params key
26e0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 2d 6d 65 74 )))..(define-met
26f0: 68 6f 64 20 28 73 65 73 73 69 6f 6e 3a 65 78 74 hod (session:ext
2700: 72 61 63 74 2d 6b 65 79 2d 66 72 6f 6d 2d 70 61 ract-key-from-pa
2710: 72 61 6d 20 28 73 65 6c 66 20 3c 73 65 73 73 69 ram (self <sessi
2720: 6f 6e 3e 29 20 70 61 72 61 6d 73 20 6b 65 79 29 on>) params key)
2730: 0a 20 20 28 6c 65 74 20 28 28 72 31 20 20 20 20 . (let ((r1
2740: 20 28 72 65 67 65 78 70 20 28 73 74 72 69 6e 67 (regexp (string
2750: 2d 61 70 70 65 6e 64 20 22 5e 22 20 6b 65 79 20 -append "^" key
2760: 22 3d 28 5b 5e 3d 5d 2b 29 24 22 29 29 29 29 0a "=([^=]+)$")))).
2770: 20 20 20 20 28 69 66 20 28 3c 20 28 6c 65 6e 67 (if (< (leng
2780: 74 68 20 70 61 72 61 6d 73 29 20 31 29 20 23 66 th params) 1) #f
2790: 0a 09 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 ..(let loop ((he
27a0: 61 64 20 20 20 28 63 61 72 20 70 61 72 61 6d 73 ad (car params
27b0: 29 29 0a 09 09 20 20 20 28 74 61 69 6c 20 20 20 ))... (tail
27c0: 28 63 64 72 20 70 61 72 61 6d 73 29 29 29 0a 09 (cdr params)))..
27d0: 20 20 28 6c 65 74 20 28 28 6d 61 74 63 68 20 28 (let ((match (
27e0: 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 72 31 20 string-match r1
27f0: 68 65 61 64 29 29 29 0a 09 20 20 20 20 28 63 6f head))).. (co
2800: 6e 64 0a 09 20 20 20 20 20 28 6d 61 74 63 68 0a nd.. (match.
2810: 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 73 65 . (let ((se
2820: 73 73 69 6f 6e 2d 6b 65 79 20 28 6c 69 73 74 2d ssion-key (list-
2830: 72 65 66 20 6d 61 74 63 68 20 31 29 29 29 0a 09 ref match 1)))..
2840: 09 28 73 6c 6f 74 2d 73 65 74 21 20 73 65 6c 66 .(slot-set! self
2850: 20 27 73 65 73 73 69 6f 6e 2d 6b 65 79 20 28 6c 'session-key (l
2860: 69 73 74 2d 72 65 66 20 6d 61 74 63 68 20 31 29 ist-ref match 1)
2870: 29 0a 09 09 73 65 73 73 69 6f 6e 2d 6b 65 79 29 )...session-key)
2880: 29 0a 09 20 20 20 20 20 28 28 6e 75 6c 6c 3f 20 ).. ((null?
2890: 74 61 69 6c 29 0a 09 20 20 20 20 20 20 23 66 29 tail).. #f)
28a0: 0a 09 20 20 20 20 20 28 65 6c 73 65 0a 09 20 20 .. (else..
28b0: 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 (loop (car t
28c0: 61 69 6c 29 0a 09 09 20 20 20 20 28 63 64 72 20 ail)... (cdr
28d0: 74 61 69 6c 29 29 29 29 29 29 29 29 29 0a 0a 28 tail)))))))))..(
28e0: 64 65 66 69 6e 65 2d 6d 65 74 68 6f 64 20 28 73 define-method (s
28f0: 65 73 73 69 6f 6e 3a 73 65 74 2d 70 61 67 65 21 ession:set-page!
2900: 20 28 73 65 6c 66 20 3c 73 65 73 73 69 6f 6e 3e (self <session>
2910: 29 20 70 61 67 65 5f 6e 61 6d 65 29 0a 20 20 28 ) page_name). (
2920: 73 6c 6f 74 2d 73 65 74 21 20 73 65 6c 66 20 27 slot-set! self '
2930: 70 61 67 65 20 70 61 67 65 5f 6e 61 6d 65 29 29 page page_name))
2940: 0a 0a 28 64 65 66 69 6e 65 2d 6d 65 74 68 6f 64 ..(define-method
2950: 20 28 73 65 73 73 69 6f 6e 3a 63 6c 6f 73 65 20 (session:close
2960: 28 73 65 6c 66 20 3c 73 65 73 73 69 6f 6e 3e 29 (self <session>)
2970: 29 0a 20 20 28 64 62 69 3a 63 6c 6f 73 65 20 28 ). (dbi:close (
2980: 73 6c 6f 74 2d 72 65 66 20 73 65 6c 66 20 27 63 slot-ref self 'c
2990: 6f 6e 6e 29 29 29 0a 3b 3b 20 28 63 6c 6f 73 65 onn))).;; (close
29a0: 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 28 73 6c -output-port (sl
29b0: 6f 74 2d 72 65 66 20 73 65 6c 66 20 27 6c 6f 67 ot-ref self 'log
29c0: 70 74 29 29 0a 0a 28 64 65 66 69 6e 65 2d 6d 65 pt))..(define-me
29d0: 74 68 6f 64 20 28 73 65 73 73 69 6f 6e 3a 65 72 thod (session:er
29e0: 72 2d 6d 73 67 20 28 73 65 6c 66 20 3c 73 65 73 r-msg (self <ses
29f0: 73 69 6f 6e 3e 29 20 6d 73 67 29 0a 20 20 28 68 sion>) msg). (h
2a00: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 28 ash-table-set! (
2a10: 73 6c 6f 74 2d 72 65 66 20 73 65 6c 66 20 27 73 slot-ref self 's
2a20: 65 73 73 69 6f 6e 76 61 72 73 29 20 22 45 52 52 essionvars) "ERR
2a30: 4f 52 5f 4d 53 47 22 0a 09 09 20 20 20 28 73 74 OR_MSG"... (st
2a40: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
2a50: 20 28 6d 61 70 20 73 3a 61 6e 79 2d 3e 73 74 72 (map s:any->str
2a60: 69 6e 67 20 6d 73 67 29 20 22 20 22 29 29 29 0a ing msg) " "))).
2a70: 0a 28 64 65 66 69 6e 65 2d 6d 65 74 68 6f 64 20 .(define-method
2a80: 28 73 65 73 73 69 6f 6e 3a 70 72 65 76 2d 65 72 (session:prev-er
2a90: 72 20 28 73 65 6c 66 20 3c 73 65 73 73 69 6f 6e r (self <session
2aa0: 3e 29 29 0a 20 20 28 6c 65 74 20 28 28 70 72 65 >)). (let ((pre
2ab0: 76 2d 65 72 72 20 28 68 61 73 68 2d 74 61 62 6c v-err (hash-tabl
2ac0: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 28 73 e-ref/default (s
2ad0: 6c 6f 74 2d 72 65 66 20 73 65 6c 66 20 27 73 65 lot-ref self 'se
2ae0: 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 ssionvars-before
2af0: 29 20 22 45 52 52 4f 52 5f 4d 53 47 22 20 23 66 ) "ERROR_MSG" #f
2b00: 29 29 0a 09 28 63 75 72 72 2d 65 72 72 20 28 68 ))..(curr-err (h
2b10: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
2b20: 66 61 75 6c 74 20 28 73 6c 6f 74 2d 72 65 66 20 fault (slot-ref
2b30: 73 65 6c 66 20 27 73 65 73 73 69 6f 6e 76 61 72 self 'sessionvar
2b40: 73 29 20 22 45 52 52 4f 52 5f 4d 53 47 22 20 23 s) "ERROR_MSG" #
2b50: 66 29 29 29 0a 20 20 20 20 28 69 66 20 70 72 65 f))). (if pre
2b60: 76 2d 65 72 72 20 70 72 65 76 2d 65 72 72 0a 09 v-err prev-err..
2b70: 28 69 66 20 63 75 72 72 2d 65 72 72 20 63 75 72 (if curr-err cur
2b80: 72 2d 65 72 72 20 23 66 29 29 29 29 0a 0a 3b 3b r-err #f))))..;;
2b90: 20 73 65 73 73 69 6f 6e 20 76 61 72 73 0a 3b 3b session vars.;;
2ba0: 20 31 2e 20 6b 65 79 73 20 61 72 65 20 61 6c 77 1. keys are alw
2bb0: 61 79 73 20 61 20 73 74 72 69 6e 67 20 4e 4f 54 ays a string NOT
2bc0: 20 61 20 73 79 6d 62 6f 6c 0a 3b 3b 20 32 2e 20 a symbol.;; 2.
2bd0: 76 61 6c 75 65 73 20 61 72 65 20 61 6c 77 61 79 values are alway
2be0: 73 20 61 20 73 74 72 69 6e 67 20 63 6f 6e 76 65 s a string conve
2bf0: 72 73 69 6f 6e 20 69 73 20 74 68 65 20 72 65 73 rsion is the res
2c00: 70 6f 6e 73 69 62 69 6c 69 74 79 20 6f 66 20 74 ponsibility of t
2c10: 68 65 20 0a 3b 3b 20 20 20 20 63 6f 6e 73 75 6d he .;; consum
2c20: 69 6e 67 20 66 75 6e 63 74 69 6f 6e 20 28 61 74 ing function (at
2c30: 20 6c 65 61 73 74 20 66 6f 72 20 6e 6f 77 2c 20 least for now,
2c40: 49 27 64 20 6c 69 6b 65 20 74 6f 20 63 68 61 6e I'd like to chan
2c50: 67 65 20 74 68 69 73 29 0a 0a 3b 3b 20 73 65 74 ge this)..;; set
2c60: 20 61 20 73 65 73 73 69 6f 6e 20 76 61 72 20 66 a session var f
2c70: 6f 72 20 74 68 65 20 63 75 72 72 65 6e 74 20 70 or the current p
2c80: 61 67 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 2d 6d age.;;.(define-m
2c90: 65 74 68 6f 64 20 28 73 65 73 73 69 6f 6e 3a 73 ethod (session:s
2ca0: 65 74 21 20 28 73 65 6c 66 20 3c 73 65 73 73 69 et! (self <sessi
2cb0: 6f 6e 3e 29 20 6b 65 79 20 76 61 6c 75 65 29 0a on>) key value).
2cc0: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
2cd0: 74 21 20 28 73 6c 6f 74 2d 72 65 66 20 73 65 6c t! (slot-ref sel
2ce0: 66 20 27 70 61 67 65 76 61 72 73 29 20 28 73 3a f 'pagevars) (s:
2cf0: 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6b 65 79 29 any->string key)
2d00: 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 (s:any->string
2d10: 76 61 6c 75 65 29 29 29 0a 0a 3b 3b 20 64 65 6c value)))..;; del
2d20: 20 61 20 76 61 72 20 66 6f 72 20 74 68 65 20 63 a var for the c
2d30: 75 72 72 65 6e 74 20 70 61 67 65 0a 3b 3b 0a 28 urrent page.;;.(
2d40: 64 65 66 69 6e 65 2d 6d 65 74 68 6f 64 20 28 73 define-method (s
2d50: 65 73 73 69 6f 6e 3a 64 65 6c 21 20 28 73 65 6c ession:del! (sel
2d60: 66 20 3c 73 65 73 73 69 6f 6e 3e 29 20 6b 65 79 f <session>) key
2d70: 29 0a 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ). (hash-table-
2d80: 64 65 6c 65 74 65 21 20 28 73 6c 6f 74 2d 72 65 delete! (slot-re
2d90: 66 20 73 65 6c 66 20 27 70 61 67 65 76 61 72 73 f self 'pagevars
2da0: 29 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 ) (s:any->string
2db0: 20 6b 65 79 29 29 29 0a 0a 3b 3b 20 67 65 74 20 key)))..;; get
2dc0: 74 68 65 20 61 70 70 72 6f 70 72 69 61 74 65 20 the appropriate
2dd0: 68 61 73 68 20 67 69 76 65 6e 20 61 20 70 61 67 hash given a pag
2de0: 65 20 22 2a 73 65 73 73 69 6f 6e 76 61 72 73 2a e "*sessionvars*
2df0: 2c 20 2a 67 6c 6f 62 61 6c 76 61 72 73 2a 20 6f , *globalvars* o
2e00: 72 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 69 6e r page.;;.(defin
2e10: 65 2d 6d 65 74 68 6f 64 20 28 73 65 73 73 69 6f e-method (sessio
2e20: 6e 3a 67 65 74 2d 70 61 67 65 2d 68 61 73 68 20 n:get-page-hash
2e30: 28 73 65 6c 66 20 3c 73 65 73 73 69 6f 6e 3e 29 (self <session>)
2e40: 20 70 61 67 65 29 0a 20 20 28 69 66 20 28 73 74 page). (if (st
2e50: 72 69 6e 67 3d 3f 20 70 61 67 65 20 22 2a 73 65 ring=? page "*se
2e60: 73 73 69 6f 6e 76 61 72 73 2a 22 29 0a 20 20 20 ssionvars*").
2e70: 20 20 20 28 73 6c 6f 74 2d 72 65 66 20 73 65 6c (slot-ref sel
2e80: 66 20 27 73 65 73 73 69 6f 6e 76 61 72 73 29 0a f 'sessionvars).
2e90: 20 20 20 20 20 20 28 69 66 20 28 73 74 72 69 6e (if (strin
2ea0: 67 3d 3f 20 70 61 67 65 20 22 2a 67 6c 6f 62 61 g=? page "*globa
2eb0: 6c 76 61 72 73 2a 22 29 0a 09 20 20 28 73 6c 6f lvars*").. (slo
2ec0: 74 2d 72 65 66 20 73 65 6c 66 20 27 67 6c 6f 62 t-ref self 'glob
2ed0: 61 6c 76 61 72 73 29 0a 09 20 20 28 73 6c 6f 74 alvars).. (slot
2ee0: 2d 72 65 66 20 73 65 6c 66 20 27 70 61 67 65 76 -ref self 'pagev
2ef0: 61 72 73 29 29 29 29 0a 0a 3b 3b 20 73 65 74 20 ars))))..;; set
2f00: 61 20 73 65 73 73 69 6f 6e 20 76 61 72 20 66 6f a session var fo
2f10: 72 20 61 20 67 69 76 65 6e 20 70 61 67 65 0a 3b r a given page.;
2f20: 3b 0a 28 64 65 66 69 6e 65 2d 6d 65 74 68 6f 64 ;.(define-method
2f30: 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 21 20 28 (session:set! (
2f40: 73 65 6c 66 20 3c 73 65 73 73 69 6f 6e 3e 29 20 self <session>)
2f50: 70 61 67 65 20 6b 65 79 20 76 61 6c 75 65 29 0a page key value).
2f60: 20 20 28 6c 65 74 20 28 28 68 74 20 28 73 65 73 (let ((ht (ses
2f70: 73 69 6f 6e 3a 67 65 74 2d 70 61 67 65 2d 68 61 sion:get-page-ha
2f80: 73 68 20 73 65 6c 66 20 70 61 67 65 29 29 29 0a sh self page))).
2f90: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
2fa0: 73 65 74 21 20 68 74 20 28 73 3a 61 6e 79 2d 3e set! ht (s:any->
2fb0: 73 74 72 69 6e 67 20 6b 65 79 29 20 28 73 3a 61 string key) (s:a
2fc0: 6e 79 2d 3e 73 74 72 69 6e 67 20 76 61 6c 75 65 ny->string value
2fd0: 29 29 29 29 0a 0a 3b 3b 20 67 65 74 20 73 65 73 ))))..;; get ses
2fe0: 73 69 6f 6e 20 76 61 72 73 20 66 6f 72 20 74 68 sion vars for th
2ff0: 65 20 63 75 72 72 65 6e 74 20 70 61 67 65 0a 3b e current page.;
3000: 3b 0a 28 64 65 66 69 6e 65 2d 6d 65 74 68 6f 64 ;.(define-method
3010: 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 20 28 73 (session:get (s
3020: 65 6c 66 20 3c 73 65 73 73 69 6f 6e 3e 29 20 6b elf <session>) k
3030: 65 79 29 0a 20 20 28 68 61 73 68 2d 74 61 62 6c ey). (hash-tabl
3040: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 28 73 e-ref/default (s
3050: 6c 6f 74 2d 72 65 66 20 73 65 6c 66 20 27 70 61 lot-ref self 'pa
3060: 67 65 76 61 72 73 29 20 6b 65 79 20 23 66 29 29 gevars) key #f))
3070: 0a 0a 3b 3b 20 67 65 74 20 73 65 73 73 69 6f 6e ..;; get session
3080: 20 76 61 72 73 20 66 6f 72 20 61 20 73 70 65 63 vars for a spec
3090: 69 66 69 65 64 20 70 61 67 65 0a 3b 3b 0a 28 64 ified page.;;.(d
30a0: 65 66 69 6e 65 2d 6d 65 74 68 6f 64 20 28 73 65 efine-method (se
30b0: 73 73 69 6f 6e 3a 67 65 74 20 28 73 65 6c 66 20 ssion:get (self
30c0: 3c 73 65 73 73 69 6f 6e 3e 29 20 70 61 67 65 20 <session>) page
30d0: 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 28 68 74 key). (let ((ht
30e0: 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 (session:get-pa
30f0: 67 65 2d 68 61 73 68 20 73 65 6c 66 20 70 61 67 ge-hash self pag
3100: 65 29 29 29 0a 20 20 20 20 28 68 61 73 68 2d 74 e))). (hash-t
3110: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
3120: 20 68 74 20 6b 65 79 20 23 66 29 29 29 0a 0a 3b ht key #f)))..;
3130: 3b 20 64 65 6c 65 74 65 20 61 20 73 65 73 73 69 ; delete a sessi
3140: 6f 6e 20 76 61 72 20 66 6f 72 20 61 20 73 70 65 on var for a spe
3150: 63 69 66 69 65 64 20 70 61 67 65 0a 3b 3b 0a 28 cified page.;;.(
3160: 64 65 66 69 6e 65 2d 6d 65 74 68 6f 64 20 28 73 define-method (s
3170: 65 73 73 69 6f 6e 3a 64 65 6c 21 20 28 73 65 6c ession:del! (sel
3180: 66 20 3c 73 65 73 73 69 6f 6e 3e 29 20 70 61 67 f <session>) pag
3190: 65 20 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 28 e key). (let ((
31a0: 68 74 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d ht (session:get-
31b0: 70 61 67 65 2d 68 61 73 68 20 73 65 6c 66 20 70 page-hash self p
31c0: 61 67 65 29 29 29 0a 20 20 20 20 28 68 61 73 68 age))). (hash
31d0: 2d 74 61 62 6c 65 2d 64 65 6c 65 74 65 21 20 68 -table-delete! h
31e0: 74 20 6b 65 79 29 29 29 0a 0a 3b 3b 20 67 65 74 t key)))..;; get
31f0: 20 41 4c 4c 20 6b 65 79 73 20 66 6f 72 20 74 68 ALL keys for th
3200: 69 73 20 70 61 67 65 20 61 6e 64 20 73 74 6f 72 is page and stor
3210: 65 20 69 6e 20 74 68 65 20 73 65 73 73 69 6f 6e e in the session
3220: 20 70 61 67 65 76 61 72 73 20 68 61 73 68 0a 3b pagevars hash.;
3230: 3b 0a 28 64 65 66 69 6e 65 2d 6d 65 74 68 6f 64 ;.(define-method
3240: 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 76 61 (session:get-va
3250: 72 73 20 28 73 65 6c 66 20 3c 73 65 73 73 69 6f rs (self <sessio
3260: 6e 3e 29 29 0a 20 20 28 6c 65 74 20 28 28 73 65 n>)). (let ((se
3270: 73 73 69 6f 6e 2d 69 64 20 20 28 73 6c 6f 74 2d ssion-id (slot-
3280: 72 65 66 20 73 65 6c 66 20 27 73 65 73 73 69 6f ref self 'sessio
3290: 6e 2d 69 64 29 29 29 0a 20 20 20 20 28 69 66 20 n-id))). (if
32a0: 28 6e 6f 74 20 73 65 73 73 69 6f 6e 2d 69 64 29 (not session-id)
32b0: 0a 09 28 65 72 72 3a 6c 6f 67 20 22 45 52 52 4f ..(err:log "ERRO
32c0: 52 3a 20 4e 6f 20 73 65 73 73 69 6f 6e 20 69 64 R: No session id
32d0: 20 69 6e 20 73 65 73 73 69 6f 6e 20 6f 62 6a 65 in session obje
32e0: 63 74 21 20 73 65 73 73 69 6f 6e 3a 67 65 74 2d ct! session:get-
32f0: 76 61 72 73 22 29 0a 09 28 6c 65 74 2a 20 28 28 vars")..(let* ((
3300: 72 65 73 75 6c 74 20 20 20 20 20 20 20 20 20 20 result
3310: 20 20 20 23 66 29 0a 09 20 20 20 20 20 20 20 28 #f).. (
3320: 63 6f 6e 6e 20 20 20 20 20 20 20 20 20 20 20 20 conn
3330: 20 20 20 28 73 6c 6f 74 2d 72 65 66 20 73 65 6c (slot-ref sel
3340: 66 20 27 63 6f 6e 6e 29 29 0a 09 20 20 20 20 20 f 'conn))..
3350: 20 20 28 70 61 67 65 76 61 72 73 2d 62 65 66 6f (pagevars-befo
3360: 72 65 20 20 20 20 28 73 6c 6f 74 2d 72 65 66 20 re (slot-ref
3370: 73 65 6c 66 20 27 70 61 67 65 76 61 72 73 2d 62 self 'pagevars-b
3380: 65 66 6f 72 65 29 29 0a 09 20 20 20 20 20 20 20 efore))..
3390: 28 73 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 (sessionvars-bef
33a0: 6f 72 65 20 28 73 6c 6f 74 2d 72 65 66 20 73 65 ore (slot-ref se
33b0: 6c 66 20 27 73 65 73 73 69 6f 6e 76 61 72 73 2d lf 'sessionvars-
33c0: 62 65 66 6f 72 65 29 29 0a 09 20 20 20 20 20 20 before))..
33d0: 20 28 67 6c 6f 62 61 6c 76 61 72 73 2d 62 65 66 (globalvars-bef
33e0: 6f 72 65 20 20 28 73 6c 6f 74 2d 72 65 66 20 73 ore (slot-ref s
33f0: 65 6c 66 20 27 67 6c 6f 62 61 6c 76 61 72 73 2d elf 'globalvars-
3400: 62 65 66 6f 72 65 29 29 0a 09 20 20 20 20 20 20 before))..
3410: 20 28 70 61 67 65 76 61 72 73 20 20 20 20 20 20 (pagevars
3420: 20 20 20 20 20 28 73 6c 6f 74 2d 72 65 66 20 73 (slot-ref s
3430: 65 6c 66 20 27 70 61 67 65 76 61 72 73 29 29 0a elf 'pagevars)).
3440: 09 20 20 20 20 20 20 20 28 73 65 73 73 69 6f 6e . (session
3450: 76 61 72 73 20 20 20 20 20 20 20 20 28 73 6c 6f vars (slo
3460: 74 2d 72 65 66 20 73 65 6c 66 20 27 73 65 73 73 t-ref self 'sess
3470: 69 6f 6e 76 61 72 73 29 29 0a 09 20 20 20 20 20 ionvars))..
3480: 20 20 28 67 6c 6f 62 61 6c 76 61 72 73 20 20 20 (globalvars
3490: 20 20 20 20 20 20 28 73 6c 6f 74 2d 72 65 66 20 (slot-ref
34a0: 73 65 6c 66 20 27 67 6c 6f 62 61 6c 76 61 72 73 self 'globalvars
34b0: 29 29 0a 09 20 20 20 20 20 20 20 28 70 61 67 65 )).. (page
34c0: 2d 6e 61 6d 65 20 20 20 20 20 20 20 20 20 20 28 -name (
34d0: 73 6c 6f 74 2d 72 65 66 20 73 65 6c 66 20 27 70 slot-ref self 'p
34e0: 61 67 65 29 29 0a 09 20 20 20 20 20 20 20 28 73 age)).. (s
34f0: 65 73 73 69 6f 6e 2d 6b 65 79 20 20 20 20 20 20 ession-key
3500: 20 20 28 73 6c 6f 74 2d 72 65 66 20 73 65 6c 66 (slot-ref self
3510: 20 27 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 0a 'session-key)).
3520: 09 20 20 20 20 20 20 20 28 71 75 65 72 79 20 20 . (query
3530: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 74 72 (str
3540: 69 6e 67 2d 61 70 70 65 6e 64 0a 09 09 09 09 20 ing-append.....
3550: 20 20 20 22 53 45 4c 45 43 54 20 6b 65 79 2c 76 "SELECT key,v
3560: 61 6c 75 65 20 46 52 4f 4d 20 73 65 73 73 69 6f alue FROM sessio
3570: 6e 5f 76 61 72 73 20 49 4e 4e 45 52 20 4a 4f 49 n_vars INNER JOI
3580: 4e 20 73 65 73 73 69 6f 6e 73 20 4f 4e 20 73 65 N sessions ON se
3590: 73 73 69 6f 6e 5f 76 61 72 73 2e 73 65 73 73 69 ssion_vars.sessi
35a0: 6f 6e 5f 69 64 3d 73 65 73 73 69 6f 6e 73 2e 69 on_id=sessions.i
35b0: 64 20 22 0a 09 09 09 09 20 20 20 20 22 57 48 45 d "..... "WHE
35c0: 52 45 20 73 65 73 73 69 6f 6e 5f 6b 65 79 3d 3f RE session_key=?
35d0: 20 41 4e 44 20 70 61 67 65 3d 3f 3b 22 29 29 29 AND page=?;")))
35e0: 0a 09 20 20 3b 3b 20 66 69 72 73 74 20 74 68 65 .. ;; first the
35f0: 20 70 61 67 65 20 73 70 65 63 69 66 69 63 20 76 page specific v
3600: 61 72 73 0a 09 20 20 28 64 62 69 3a 66 6f 72 2d ars.. (dbi:for-
3610: 65 61 63 68 2d 72 6f 77 20 28 6c 61 6d 62 64 61 each-row (lambda
3620: 20 28 74 75 70 6c 65 29 0a 09 09 09 20 20 20 20 (tuple)....
3630: 20 20 28 6c 65 74 20 28 28 6b 20 28 76 65 63 74 (let ((k (vect
3640: 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 30 29 29 or-ref tuple 0))
3650: 0a 09 09 09 09 20 20 20 20 28 76 20 28 76 65 63 ..... (v (vec
3660: 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 31 29 tor-ref tuple 1)
3670: 29 29 0a 09 09 09 09 28 68 61 73 68 2d 74 61 62 )).....(hash-tab
3680: 6c 65 2d 73 65 74 21 20 70 61 67 65 76 61 72 73 le-set! pagevars
3690: 2d 62 65 66 6f 72 65 20 6b 20 76 29 0a 09 09 09 -before k v)....
36a0: 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 .(hash-table-set
36b0: 21 20 70 61 67 65 76 61 72 73 20 20 20 20 20 20 ! pagevars
36c0: 20 20 6b 20 76 29 29 29 0a 09 09 09 20 20 20 20 k v)))....
36d0: 63 6f 6e 6e 0a 09 09 09 20 20 20 20 28 73 3a 73 conn.... (s:s
36e0: 71 6c 70 61 72 61 6d 20 71 75 65 72 79 20 73 65 qlparam query se
36f0: 73 73 69 6f 6e 2d 6b 65 79 20 70 61 67 65 2d 6e ssion-key page-n
3700: 61 6d 65 29 29 0a 09 20 20 3b 3b 20 74 68 65 6e ame)).. ;; then
3710: 20 74 68 65 20 73 65 73 73 69 6f 6e 20 73 70 65 the session spe
3720: 63 69 66 69 63 20 76 61 72 73 0a 09 20 20 28 64 cific vars.. (d
3730: 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 bi:for-each-row
3740: 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 29 0a (lambda (tuple).
3750: 09 09 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 ... (let ((
3760: 6b 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 75 k (vector-ref tu
3770: 70 6c 65 20 30 29 29 0a 09 09 09 09 20 20 20 20 ple 0)).....
3780: 28 76 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 (v (vector-ref t
3790: 75 70 6c 65 20 31 29 29 29 0a 09 09 09 09 28 68 uple 1))).....(h
37a0: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 73 ash-table-set! s
37b0: 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 essionvars-befor
37c0: 65 20 6b 20 76 29 0a 09 09 09 09 28 68 61 73 68 e k v).....(hash
37d0: 2d 74 61 62 6c 65 2d 73 65 74 21 20 73 65 73 73 -table-set! sess
37e0: 69 6f 6e 76 61 72 73 20 20 20 20 20 20 20 20 6b ionvars k
37f0: 20 76 29 29 29 0a 09 09 09 20 20 20 20 63 6f 6e v))).... con
3800: 6e 0a 09 09 09 20 20 20 20 28 73 3a 73 71 6c 70 n.... (s:sqlp
3810: 61 72 61 6d 20 71 75 65 72 79 20 73 65 73 73 69 aram query sessi
3820: 6f 6e 2d 6b 65 79 20 22 2a 73 65 73 73 69 6f 6e on-key "*session
3830: 76 61 72 73 2a 22 29 29 0a 09 20 20 3b 3b 20 61 vars*")).. ;; a
3840: 6e 64 20 66 69 6e 61 6c 6c 79 20 74 68 65 20 67 nd finally the g
3850: 6c 6f 62 61 6c 20 76 61 72 73 0a 09 20 20 28 64 lobal vars.. (d
3860: 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 bi:for-each-row
3870: 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 29 0a (lambda (tuple).
3880: 09 09 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 ... (let ((
3890: 6b 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 75 k (vector-ref tu
38a0: 70 6c 65 20 30 29 29 0a 09 09 09 09 20 20 20 20 ple 0)).....
38b0: 28 76 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 (v (vector-ref t
38c0: 75 70 6c 65 20 31 29 29 29 0a 09 09 09 09 28 68 uple 1))).....(h
38d0: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 67 ash-table-set! g
38e0: 6c 6f 62 61 6c 76 61 72 73 2d 62 65 66 6f 72 65 lobalvars-before
38f0: 20 6b 20 76 29 0a 09 09 09 09 28 68 61 73 68 2d k v).....(hash-
3900: 74 61 62 6c 65 2d 73 65 74 21 20 67 6c 6f 62 61 table-set! globa
3910: 6c 76 61 72 73 20 20 20 20 20 20 20 20 6b 20 76 lvars k v
3920: 29 29 29 0a 09 09 09 20 20 20 20 63 6f 6e 6e 0a ))).... conn.
3930: 09 09 09 20 20 20 20 28 73 3a 73 71 6c 70 61 72 ... (s:sqlpar
3940: 61 6d 20 71 75 65 72 79 20 73 65 73 73 69 6f 6e am query session
3950: 2d 6b 65 79 20 22 2a 67 6c 6f 62 61 6c 76 61 72 -key "*globalvar
3960: 73 22 29 29 0a 09 20 20 29 29 29 29 0a 0a 28 64 s")).. ))))..(d
3970: 65 66 69 6e 65 2d 6d 65 74 68 6f 64 20 28 73 65 efine-method (se
3980: 73 73 69 6f 6e 3a 73 61 76 65 2d 76 61 72 73 20 ssion:save-vars
3990: 28 73 65 6c 66 20 3c 73 65 73 73 69 6f 6e 3e 29 (self <session>)
39a0: 29 0a 20 20 28 6c 65 74 20 28 28 73 65 73 73 69 ). (let ((sessi
39b0: 6f 6e 2d 69 64 20 20 28 73 6c 6f 74 2d 72 65 66 on-id (slot-ref
39c0: 20 73 65 6c 66 20 27 73 65 73 73 69 6f 6e 2d 69 self 'session-i
39d0: 64 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f d))). (if (no
39e0: 74 20 73 65 73 73 69 6f 6e 2d 69 64 29 0a 09 28 t session-id)..(
39f0: 65 72 72 3a 6c 6f 67 20 22 45 52 52 4f 52 3a 20 err:log "ERROR:
3a00: 4e 6f 20 73 65 73 73 69 6f 6e 20 69 64 20 69 6e No session id in
3a10: 20 73 65 73 73 69 6f 6e 20 6f 62 6a 65 63 74 21 session object!
3a20: 20 73 65 73 73 69 6f 6e 3a 67 65 74 2d 76 61 72 session:get-var
3a30: 73 22 29 0a 09 28 6c 65 74 2a 20 28 28 73 74 61 s")..(let* ((sta
3a40: 74 75 73 20 20 20 20 20 20 23 66 29 0a 09 20 20 tus #f)..
3a50: 20 20 20 20 20 28 63 6f 6e 6e 20 20 20 20 20 20 (conn
3a60: 20 20 28 73 6c 6f 74 2d 72 65 66 20 73 65 6c 66 (slot-ref self
3a70: 20 27 63 6f 6e 6e 29 29 0a 09 20 20 20 20 20 20 'conn))..
3a80: 20 28 70 61 67 65 2d 6e 61 6d 65 20 20 20 28 73 (page-name (s
3a90: 6c 6f 74 2d 72 65 66 20 73 65 6c 66 20 27 70 61 lot-ref self 'pa
3aa0: 67 65 29 29 0a 09 20 20 20 20 20 20 20 28 64 65 ge)).. (de
3ab0: 6c 2d 71 75 65 72 79 20 20 20 22 44 45 4c 45 54 l-query "DELET
3ac0: 45 20 46 52 4f 4d 20 73 65 73 73 69 6f 6e 5f 76 E FROM session_v
3ad0: 61 72 73 20 57 48 45 52 45 20 73 65 73 73 69 6f ars WHERE sessio
3ae0: 6e 5f 69 64 3d 3f 20 41 4e 44 20 70 61 67 65 3d n_id=? AND page=
3af0: 3f 20 41 4e 44 20 6b 65 79 3d 3f 3b 22 29 0a 09 ? AND key=?;")..
3b00: 20 20 20 20 20 20 20 28 69 6e 73 2d 71 75 65 72 (ins-quer
3b10: 79 20 20 20 22 49 4e 53 45 52 54 20 49 4e 54 4f y "INSERT INTO
3b20: 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 28 73 session_vars (s
3b30: 65 73 73 69 6f 6e 5f 69 64 2c 70 61 67 65 2c 6b ession_id,page,k
3b40: 65 79 2c 76 61 6c 75 65 29 20 56 41 4c 55 45 53 ey,value) VALUES
3b50: 28 3f 2c 3f 2c 3f 2c 3f 29 3b 22 29 0a 09 20 20 (?,?,?,?);")..
3b60: 20 20 20 20 20 28 75 70 64 2d 71 75 65 72 79 20 (upd-query
3b70: 20 20 22 55 50 44 41 54 45 20 73 65 73 73 69 6f "UPDATE sessio
3b80: 6e 5f 76 61 72 73 20 73 65 74 20 76 61 6c 75 65 n_vars set value
3b90: 3d 3f 20 57 48 45 52 45 20 6b 65 79 3d 3f 20 41 =? WHERE key=? A
3ba0: 4e 44 20 73 65 73 73 69 6f 6e 5f 69 64 3d 3f 20 ND session_id=?
3bb0: 41 4e 44 20 70 61 67 65 3d 3f 3b 22 29 0a 09 20 AND page=?;")..
3bc0: 20 20 20 20 20 20 28 63 68 61 6e 67 65 64 2d 63 (changed-c
3bd0: 6f 75 6e 74 20 30 29 29 0a 09 20 20 3b 3b 20 73 ount 0)).. ;; s
3be0: 61 76 65 20 74 68 65 20 64 65 6c 74 61 20 6f 6e ave the delta on
3bf0: 6c 79 0a 09 20 20 28 66 6f 72 2d 65 61 63 68 0a ly.. (for-each.
3c00: 09 20 20 20 28 6c 61 6d 62 64 61 20 28 70 61 67 . (lambda (pag
3c10: 65 29 20 3b 3b 20 70 61 67 65 20 69 73 3a 20 22 e) ;; page is: "
3c20: 2a 67 6c 6f 62 61 6c 76 61 72 73 2a 22 20 22 2a *globalvars*" "*
3c30: 73 65 73 73 69 6f 6e 76 61 72 73 2a 22 20 6f 72 sessionvars*" or
3c40: 20 6f 74 68 65 72 73 74 72 69 6e 67 0a 09 20 20 otherstring..
3c50: 20 20 20 28 6c 65 74 2a 20 28 28 6d 61 73 74 65 (let* ((maste
3c60: 72 2d 73 6c 6f 74 2d 6e 61 6d 65 20 28 63 6f 6e r-slot-name (con
3c70: 64 0a 09 09 09 09 20 20 20 20 20 20 20 28 28 73 d..... ((s
3c80: 74 72 69 6e 67 3d 3f 20 70 61 67 65 20 22 2a 73 tring=? page "*s
3c90: 65 73 73 69 6f 6e 76 61 72 73 2a 22 29 20 27 73 essionvars*") 's
3ca0: 65 73 73 69 6f 6e 76 61 72 73 29 0a 09 09 09 09 essionvars).....
3cb0: 20 20 20 20 20 20 20 28 28 73 74 72 69 6e 67 3d ((string=
3cc0: 3f 20 70 61 67 65 20 22 2a 67 6c 6f 62 61 6c 76 ? page "*globalv
3cd0: 61 72 73 2a 22 29 20 20 27 67 6c 6f 62 61 6c 76 ars*") 'globalv
3ce0: 61 72 73 29 0a 09 09 09 09 20 20 20 20 20 20 20 ars).....
3cf0: 28 65 6c 73 65 20 27 70 61 67 65 76 61 72 73 29 (else 'pagevars)
3d00: 29 29 0a 09 09 20 20 20 20 28 62 65 66 6f 72 65 ))... (before
3d10: 2d 73 6c 6f 74 2d 6e 61 6d 65 20 28 73 74 72 69 -slot-name (stri
3d20: 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 73 74 72 69 ng->symbol (stri
3d30: 6e 67 2d 61 70 70 65 6e 64 20 28 73 79 6d 62 6f ng-append (symbo
3d40: 6c 2d 3e 73 74 72 69 6e 67 20 6d 61 73 74 65 72 l->string master
3d50: 2d 73 6c 6f 74 2d 6e 61 6d 65 29 0a 09 09 09 09 -slot-name).....
3d60: 09 09 09 09 20 20 20 20 20 22 2d 62 65 66 6f 72 .... "-befor
3d70: 65 22 29 29 29 0a 09 09 20 20 20 20 28 6d 61 73 e")))... (mas
3d80: 74 65 72 2d 68 74 20 20 20 28 73 6c 6f 74 2d 72 ter-ht (slot-r
3d90: 65 66 20 73 65 6c 66 20 6d 61 73 74 65 72 2d 73 ef self master-s
3da0: 6c 6f 74 2d 6e 61 6d 65 29 29 0a 09 09 20 20 20 lot-name))...
3db0: 20 28 62 65 66 6f 72 65 2d 68 74 20 20 20 28 73 (before-ht (s
3dc0: 6c 6f 74 2d 72 65 66 20 73 65 6c 66 20 62 65 66 lot-ref self bef
3dd0: 6f 72 65 2d 73 6c 6f 74 2d 6e 61 6d 65 29 29 0a ore-slot-name)).
3de0: 09 09 20 20 20 20 28 6d 61 73 74 65 72 2d 6b 65 .. (master-ke
3df0: 79 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b ys (hash-table-k
3e00: 65 79 73 20 6d 61 73 74 65 72 2d 68 74 29 29 0a eys master-ht)).
3e10: 09 09 20 20 20 20 28 62 65 66 6f 72 65 2d 6b 65 .. (before-ke
3e20: 79 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b ys (hash-table-k
3e30: 65 79 73 20 62 65 66 6f 72 65 2d 68 74 29 29 0a eys before-ht)).
3e40: 09 09 20 20 20 20 28 61 6c 6c 2d 6b 65 79 73 20 .. (all-keys
3e50: 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 (delete-duplicat
3e60: 65 73 20 28 61 70 70 65 6e 64 20 6d 61 73 74 65 es (append maste
3e70: 72 2d 6b 65 79 73 20 62 65 66 6f 72 65 2d 6b 65 r-keys before-ke
3e80: 79 73 29 29 29 29 0a 09 20 20 20 20 20 20 20 28 ys)))).. (
3e90: 66 6f 72 2d 65 61 63 68 20 0a 09 09 28 6c 61 6d for-each ...(lam
3ea0: 62 64 61 20 28 6b 65 79 29 0a 09 09 20 20 28 6c bda (key)... (l
3eb0: 65 74 20 28 28 6d 61 73 74 65 72 2d 76 61 6c 75 et ((master-valu
3ec0: 65 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 e (hash-table-re
3ed0: 66 2f 64 65 66 61 75 6c 74 20 6d 61 73 74 65 72 f/default master
3ee0: 2d 68 74 20 6b 65 79 20 23 66 29 29 0a 09 09 09 -ht key #f))....
3ef0: 28 62 65 66 6f 72 65 2d 76 61 6c 75 65 20 28 68 (before-value (h
3f00: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
3f10: 66 61 75 6c 74 20 62 65 66 6f 72 65 2d 68 74 20 fault before-ht
3f20: 6b 65 79 20 23 66 29 29 29 0a 09 09 20 20 20 20 key #f)))...
3f30: 28 63 6f 6e 64 0a 09 09 20 20 20 20 20 3b 3b 20 (cond... ;;
3f40: 62 65 66 6f 72 65 20 61 6e 64 20 61 66 74 65 72 before and after
3f50: 20 65 78 69 73 74 20 61 6e 64 20 76 61 6c 75 65 exist and value
3f60: 20 75 6e 63 68 61 6e 67 65 64 20 2d 20 64 6f 20 unchanged - do
3f70: 6e 6f 74 68 69 6e 67 0a 09 09 20 20 20 20 20 28 nothing... (
3f80: 28 61 6e 64 20 6d 61 73 74 65 72 2d 76 61 6c 75 (and master-valu
3f90: 65 20 62 65 66 6f 72 65 2d 76 61 6c 75 65 20 28 e before-value (
3fa0: 65 71 75 61 6c 3f 20 6d 61 73 74 65 72 2d 76 61 equal? master-va
3fb0: 6c 75 65 20 62 65 66 6f 72 65 2d 76 61 6c 75 65 lue before-value
3fc0: 29 29 29 0a 09 09 20 20 20 20 20 3b 3b 20 62 65 )))... ;; be
3fd0: 66 6f 72 65 20 61 6e 64 20 61 66 74 65 72 20 65 fore and after e
3fe0: 78 69 73 74 20 62 75 74 20 61 72 65 20 63 68 61 xist but are cha
3ff0: 6e 67 65 64 0a 09 09 20 20 20 20 20 28 28 61 6e nged... ((an
4000: 64 20 6d 61 73 74 65 72 2d 76 61 6c 75 65 20 62 d master-value b
4010: 65 66 6f 72 65 2d 76 61 6c 75 65 29 0a 09 09 20 efore-value)...
4020: 20 20 20 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 (dbi:for-ea
4030: 63 68 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 ch-row (lambda (
4040: 74 75 70 6c 65 29 0a 09 09 09 09 09 20 20 28 73 tuple)...... (s
4050: 65 74 21 20 63 68 61 6e 67 65 64 2d 63 6f 75 6e et! changed-coun
4060: 74 20 28 2b 20 63 68 61 6e 67 65 64 2d 63 6f 75 t (+ changed-cou
4070: 6e 74 20 31 29 29 29 0a 09 09 09 09 09 63 6f 6e nt 1)))......con
4080: 6e 0a 09 09 09 09 09 28 73 3a 73 71 6c 70 61 72 n......(s:sqlpar
4090: 61 6d 20 75 70 64 2d 71 75 65 72 79 20 6d 61 73 am upd-query mas
40a0: 74 65 72 2d 76 61 6c 75 65 20 6b 65 79 20 73 65 ter-value key se
40b0: 73 73 69 6f 6e 2d 69 64 20 70 61 67 65 29 29 29 ssion-id page)))
40c0: 0a 09 09 20 20 20 20 20 3b 3b 20 6d 61 73 74 65 ... ;; maste
40d0: 72 2d 76 61 6c 75 65 20 6e 6f 20 6c 6f 6e 67 65 r-value no longe
40e0: 72 20 65 78 69 73 74 73 20 28 69 2e 65 2e 20 23 r exists (i.e. #
40f0: 66 29 20 2d 20 72 65 6d 6f 76 65 20 69 74 65 6d f) - remove item
4100: 0a 09 09 20 20 20 20 20 28 28 6e 6f 74 20 6d 61 ... ((not ma
4110: 73 74 65 72 2d 76 61 6c 75 65 29 0a 09 09 20 20 ster-value)...
4120: 20 20 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 (dbi:for-eac
4130: 68 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 h-row (lambda (t
4140: 75 70 6c 65 29 0a 09 09 09 09 09 20 20 28 73 65 uple)...... (se
4150: 74 21 20 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 t! changed-count
4160: 20 28 2b 20 63 68 61 6e 67 65 64 2d 63 6f 75 6e (+ changed-coun
4170: 74 20 31 29 29 29 0a 09 09 09 09 09 63 6f 6e 6e t 1)))......conn
4180: 0a 09 09 09 09 09 28 73 3a 73 71 6c 70 61 72 61 ......(s:sqlpara
4190: 6d 20 64 65 6c 2d 71 75 65 72 79 20 73 65 73 73 m del-query sess
41a0: 69 6f 6e 2d 69 64 20 70 61 67 65 20 6b 65 79 29 ion-id page key)
41b0: 29 29 0a 09 09 20 20 20 20 20 3b 3b 20 62 65 66 ))... ;; bef
41c0: 6f 72 65 2d 76 61 6c 75 65 20 64 6f 65 73 6e 27 ore-value doesn'
41d0: 74 20 65 78 69 73 74 20 2d 20 69 6e 73 65 72 74 t exist - insert
41e0: 20 61 20 6e 65 77 20 76 61 6c 75 65 0a 09 09 20 a new value...
41f0: 20 20 20 20 28 28 6e 6f 74 20 62 65 66 6f 72 65 ((not before
4200: 2d 76 61 6c 75 65 29 0a 09 09 20 20 20 20 20 20 -value)...
4210: 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f (dbi:for-each-ro
4220: 77 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 w (lambda (tuple
4230: 29 0a 09 09 09 09 09 20 20 28 73 65 74 21 20 63 )...... (set! c
4240: 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 28 2b 20 hanged-count (+
4250: 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 31 29 changed-count 1)
4260: 29 29 0a 09 09 09 09 09 63 6f 6e 6e 0a 09 09 09 ))......conn....
4270: 09 09 28 73 3a 73 71 6c 70 61 72 61 6d 20 69 6e ..(s:sqlparam in
4280: 73 2d 71 75 65 72 79 20 73 65 73 73 69 6f 6e 2d s-query session-
4290: 69 64 20 70 61 67 65 20 6b 65 79 20 6d 61 73 74 id page key mast
42a0: 65 72 2d 76 61 6c 75 65 29 29 29 0a 09 09 20 20 er-value)))...
42b0: 20 20 20 28 65 6c 73 65 20 28 65 72 72 3a 6c 6f (else (err:lo
42c0: 67 20 22 53 68 6f 75 6c 64 6e 27 74 20 67 65 74 g "Shouldn't get
42d0: 20 68 65 72 65 22 29 29 29 29 29 0a 09 09 61 6c here")))))...al
42e0: 6c 2d 6b 65 79 73 29 29 29 20 3b 3b 20 70 72 6f l-keys))) ;; pro
42f0: 63 65 73 73 20 61 6c 6c 20 6b 65 79 73 0a 09 20 cess all keys..
4300: 20 20 28 6c 69 73 74 20 22 2a 73 65 73 73 69 6f (list "*sessio
4310: 6e 76 61 72 73 2a 22 20 22 2a 67 6c 6f 62 61 6c nvars*" "*global
4320: 76 61 72 73 2a 22 20 70 61 67 65 2d 6e 61 6d 65 vars*" page-name
4330: 29 29 29 29 29 29 0a 0a 3b 3b 20 09 20 20 3b 3b ))))))..;; . ;;
4340: 20 28 70 72 69 6e 74 20 64 65 6c 2d 71 75 65 72 (print del-quer
4350: 79 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 y).;;
4360: 28 66 6f 72 2d 65 61 63 68 0a 3b 3b 20 20 20 20 (for-each.;;
4370: 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 (lambda
4380: 28 70 61 67 65 29 0a 3b 3b 20 20 20 20 20 20 20 (page).;;
4390: 20 20 20 20 20 20 20 28 70 67 3a 71 75 65 72 79 (pg:query
43a0: 2d 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 -for-each (lambd
43b0: 61 20 28 74 75 70 6c 65 29 0a 3b 3b 20 20 20 20 a (tuple).;;
43c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
43d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
43e0: 73 65 74 21 20 73 74 61 74 75 73 20 23 74 29 29 set! status #t))
43f0: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 .;;
4400: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4410: 20 20 20 20 28 73 3a 73 71 6c 70 61 72 61 6d 20 (s:sqlparam
4420: 64 65 6c 2d 71 75 65 72 79 20 73 65 73 73 69 6f del-query sessio
4430: 6e 2d 69 64 20 70 61 67 65 2d 6e 61 6d 65 29 0a n-id page-name).
4440: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
4450: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4460: 20 20 20 63 6f 6e 6e 29 29 0a 3b 3b 20 20 20 20 conn)).;;
4470: 20 20 20 20 20 20 20 20 28 6c 69 73 74 20 70 61 (list pa
4480: 67 65 2d 6e 61 6d 65 20 22 2a 73 65 73 73 69 6f ge-name "*sessio
4490: 6e 76 61 72 73 22 29 29 0a 3b 3b 20 20 20 20 20 nvars")).;;
44a0: 20 20 20 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 54 ;; NOTE: T
44b0: 68 65 20 66 6f 6c 6c 6f 77 69 6e 67 20 61 70 70 he following app
44c0: 72 6f 61 63 68 20 69 73 20 69 6e 65 66 66 69 63 roach is ineffic
44d0: 69 65 6e 74 20 61 6e 64 20 61 20 6c 69 74 74 6c ient and a littl
44e0: 65 20 64 61 6e 67 65 72 6f 75 73 2e 20 4e 65 65 e dangerous. Nee
44f0: 64 20 74 6f 20 6b 65 65 70 0a 3b 3b 20 20 20 20 d to keep.;;
4500: 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 ;;
4510: 74 77 6f 20 68 61 73 68 65 73 2c 20 62 65 66 6f two hashes, befo
4520: 72 65 20 61 6e 64 20 61 66 74 65 72 20 61 6e 64 re and after and
4530: 20 75 73 65 20 74 68 65 20 64 65 6c 74 61 20 74 use the delta t
4540: 6f 20 64 72 69 76 65 20 75 70 64 61 74 69 6e 67 o drive updating
4550: 20 74 68 65 20 64 62 20 4f 52 0a 3b 3b 20 20 20 the db OR.;;
4560: 20 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 ;;
4570: 20 65 76 65 6e 20 62 65 74 74 65 72 20 6d 6f 76 even better mov
4580: 65 20 74 6f 20 75 73 69 6e 67 20 72 70 63 20 77 e to using rpc w
4590: 69 74 68 20 61 20 63 65 6e 74 72 61 6c 20 70 72 ith a central pr
45a0: 6f 63 65 73 73 20 66 6f 72 20 6d 61 69 6e 74 61 ocess for mainta
45b0: 69 6e 69 6e 67 20 73 74 61 74 65 0a 3b 3b 20 20 ining state.;;
45c0: 20 20 20 20 20 20 20 20 20 3b 3b 20 77 72 69 74 ;; writ
45d0: 65 20 74 68 65 20 73 65 73 73 69 6f 6e 20 70 61 e the session pa
45e0: 67 65 20 73 70 65 63 69 66 69 63 20 76 61 72 73 ge specific vars
45f0: 20 74 6f 20 74 68 65 20 64 62 0a 3b 3b 20 09 20 to the db.;; .
4600: 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 (for-each (lamb
4610: 64 61 20 28 6b 65 79 29 0a 3b 3b 20 09 09 20 20 da (key).;; ..
4620: 20 20 20 20 28 70 67 3a 71 75 65 72 79 2d 66 6f (pg:query-fo
4630: 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 r-each (lambda (
4640: 74 75 70 6c 65 29 0a 3b 3b 20 09 09 09 09 09 20 tuple).;; .....
4650: 20 20 28 73 65 74 21 20 73 74 61 74 75 73 20 23 (set! status #
4660: 74 29 29 0a 3b 3b 20 09 09 09 09 09 20 28 73 3a t)).;; ..... (s:
4670: 73 71 6c 70 61 72 61 6d 20 69 6e 73 2d 71 75 65 sqlparam ins-que
4680: 72 79 20 73 65 73 73 69 6f 6e 2d 69 64 20 70 61 ry session-id pa
4690: 67 65 2d 6e 61 6d 65 0a 3b 3b 20 20 20 20 20 20 ge-name.;;
46a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
46b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
46c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
46d0: 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6b (s:any->string k
46e0: 65 79 29 20 3b 3b 20 6a 75 73 74 20 69 6e 20 63 ey) ;; just in c
46f0: 61 73 65 20 69 74 20 69 73 20 61 20 73 79 6d 62 ase it is a symb
4700: 6f 6c 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 ol.;;
4710: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4720: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4730: 20 20 20 20 20 20 20 20 20 20 20 28 68 61 73 68 (hash
4740: 2d 74 61 62 6c 65 2d 72 65 66 20 70 61 67 65 76 -table-ref pagev
4750: 61 72 73 20 6b 65 79 29 29 0a 3b 3b 20 09 09 09 ars key)).;; ...
4760: 09 09 20 63 6f 6e 6e 29 29 0a 3b 3b 20 09 09 20 .. conn)).;; ..
4770: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b (hash-table-k
4780: 65 79 73 20 70 61 67 65 76 61 72 73 29 29 0a 3b eys pagevars)).;
4790: 3b 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 77 ; ;; w
47a0: 72 69 74 65 20 74 68 65 20 73 65 73 73 69 6f 6e rite the session
47b0: 20 73 70 65 63 69 66 69 63 20 76 61 72 73 20 74 specific vars t
47c0: 6f 20 74 68 65 20 64 62 0a 3b 3b 20 20 20 20 20 o the db.;;
47d0: 20 20 20 20 20 20 3b 3b 20 42 55 47 21 21 21 20 ;; BUG!!!
47e0: 54 48 49 53 20 49 53 20 4c 41 5a 59 20 41 4e 44 THIS IS LAZY AND
47f0: 20 57 49 4c 4c 20 42 52 45 41 4b 20 46 4f 52 20 WILL BREAK FOR
4800: 53 4f 4d 45 4f 4e 45 20 41 43 43 45 53 53 49 4e SOMEONE ACCESSIN
4810: 47 20 54 48 45 20 53 41 4d 45 20 53 45 53 53 49 G THE SAME SESSI
4820: 4f 4e 20 46 52 4f 4d 20 54 57 4f 20 57 49 4e 44 ON FROM TWO WIND
4830: 4f 57 53 21 21 21 0a 3b 3b 20 09 20 20 28 66 6f OWS!!!.;; . (fo
4840: 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 r-each (lambda (
4850: 6b 65 79 29 0a 3b 3b 20 09 09 20 20 20 20 20 20 key).;; ..
4860: 28 70 67 3a 71 75 65 72 79 2d 66 6f 72 2d 65 61 (pg:query-for-ea
4870: 63 68 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c ch (lambda (tupl
4880: 65 29 0a 3b 3b 20 09 09 09 09 09 20 20 20 28 73 e).;; ..... (s
4890: 65 74 21 20 73 74 61 74 75 73 20 23 74 29 29 0a et! status #t)).
48a0: 3b 3b 20 09 09 09 09 09 20 28 73 3a 73 71 6c 70 ;; ..... (s:sqlp
48b0: 61 72 61 6d 20 69 6e 73 2d 71 75 65 72 79 20 73 aram ins-query s
48c0: 65 73 73 69 6f 6e 2d 69 64 20 22 2a 73 65 73 73 ession-id "*sess
48d0: 69 6f 6e 76 61 72 73 2a 22 0a 3b 3b 20 20 20 20 ionvars*".;;
48e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
48f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4900: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4910: 20 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 (s:any->string
4920: 20 6b 65 79 29 20 3b 3b 20 6a 75 73 74 20 69 6e key) ;; just in
4930: 20 63 61 73 65 20 69 74 20 69 73 20 61 20 73 79 case it is a sy
4940: 6d 62 6f 6c 0a 3b 3b 20 20 20 20 20 20 20 20 20 mbol.;;
4950: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4960: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4970: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 68 61 (ha
4980: 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 73 65 73 sh-table-ref ses
4990: 73 69 6f 6e 76 61 72 73 20 6b 65 79 29 29 0a 3b sionvars key)).;
49a0: 3b 20 09 09 09 09 09 20 63 6f 6e 6e 29 29 0a 3b ; ..... conn)).;
49b0: 3b 20 09 09 20 20 20 20 28 68 61 73 68 2d 74 61 ; .. (hash-ta
49c0: 62 6c 65 2d 6b 65 79 73 20 73 65 73 73 69 6f 6e ble-keys session
49d0: 76 61 72 73 29 29 0a 3b 3b 20 20 20 20 20 20 20 vars)).;;
49e0: 20 20 20 20 3b 3b 20 67 6c 6f 62 61 6c 20 76 61 ;; global va
49f0: 72 73 20 77 69 6c 6c 20 72 65 71 75 69 72 65 20 rs will require
4a00: 61 20 6c 69 74 74 6c 65 20 6d 6f 72 65 20 63 61 a little more ca
4a10: 72 65 20 2d 20 64 65 6c 61 79 69 6e 67 20 66 6f re - delaying fo
4a20: 72 20 6e 6f 77 2e 0a 3b 3b 20 20 20 20 20 20 20 r now..;;
4a30: 20 20 20 20 29 29 29 29 0a 0a 3b 3b 20 28 70 67 ))))..;; (pg
4a40: 3a 73 71 6c 2d 6e 75 6c 6c 2d 6f 62 6a 65 63 74 :sql-null-object
4a50: 3f 20 65 6c 65 6d 65 6e 74 29 0a 28 64 65 66 69 ? element).(defi
4a60: 6e 65 2d 6d 65 74 68 6f 64 20 28 73 65 73 73 69 ne-method (sessi
4a70: 6f 6e 3a 72 65 61 64 2d 63 6f 6e 66 69 67 20 28 on:read-config (
4a80: 73 65 6c 66 20 3c 73 65 73 73 69 6f 6e 3e 29 29 self <session>))
4a90: 0a 20 20 28 6c 65 74 20 28 28 6e 61 6d 65 20 28 . (let ((name (
4aa0: 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 22 2e string-append ".
4ab0: 22 20 28 70 61 74 68 6e 61 6d 65 2d 66 69 6c 65 " (pathname-file
4ac0: 20 28 63 61 72 20 28 61 72 67 76 29 29 29 20 22 (car (argv))) "
4ad0: 2e 63 6f 6e 66 69 67 22 29 29 29 0a 20 20 20 20 .config"))).
4ae0: 28 69 66 20 28 6e 6f 74 20 28 66 69 6c 65 2d 65 (if (not (file-e
4af0: 78 69 73 74 73 3f 20 6e 61 6d 65 29 29 0a 09 28 xists? name))..(
4b00: 70 72 69 6e 74 20 6e 61 6d 65 20 22 20 6e 6f 74 print name " not
4b10: 20 66 6f 75 6e 64 20 61 74 20 22 20 28 63 75 72 found at " (cur
4b20: 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 79 29 29 rent-directory))
4b30: 0a 09 28 6c 65 74 2a 20 28 28 66 70 20 28 6f 70 ..(let* ((fp (op
4b40: 65 6e 2d 69 6e 70 75 74 2d 66 69 6c 65 20 6e 61 en-input-file na
4b50: 6d 65 29 29 0a 09 20 20 20 20 20 20 20 28 69 6e me)).. (in
4b60: 69 74 61 72 67 73 20 28 72 65 61 64 20 66 70 29 itargs (read fp)
4b70: 29 29 0a 09 20 20 28 63 6c 6f 73 65 2d 69 6e 70 )).. (close-inp
4b80: 75 74 2d 70 6f 72 74 20 66 70 29 0a 09 20 20 69 ut-port fp).. i
4b90: 6e 69 74 61 72 67 73 29 29 29 29 0a 0a 3b 3b 20 nitargs))))..;;
4ba0: 63 61 6c 6c 20 74 68 65 20 63 6f 6e 74 72 6f 6c call the control
4bb0: 6c 65 72 20 69 66 20 69 74 20 65 78 69 73 74 73 ler if it exists
4bc0: 0a 3b 3b 20 0a 3b 3b 20 57 41 52 4e 49 4e 47 20 .;; .;; WARNING
4bd0: 2d 20 74 68 69 73 20 63 6f 64 65 20 6e 65 65 64 - this code need
4be0: 73 20 61 20 64 65 66 65 6e 63 65 20 61 67 61 69 s a defence agai
4bf0: 6e 73 20 72 65 63 75 72 73 69 76 65 20 63 61 6c ns recursive cal
4c00: 6c 69 6e 67 21 21 21 21 21 0a 3b 3b 0a 3b 3b 20 ling!!!!!.;;.;;
4c10: 20 20 49 20 73 75 67 67 65 73 74 20 61 20 6c 69 I suggest a li
4c20: 6d 69 74 20 6f 66 20 31 30 30 20 63 61 6c 6c 73 mit of 100 calls
4c30: 2e 20 50 6c 65 6e 74 79 20 66 6f 72 20 61 6c 6c . Plenty for all
4c40: 6f 77 69 6e 67 20 6d 75 6c 74 69 70 6c 65 20 69 owing multiple i
4c50: 6e 73 74 61 6e 63 65 73 0a 3b 3b 20 20 20 6f 66 nstances.;; of
4c60: 20 61 20 70 61 67 65 20 69 6e 73 69 64 65 20 61 a page inside a
4c70: 6e 6f 74 68 65 72 20 70 61 67 65 2e 20 0a 3b 3b nother page. .;;
4c80: 0a 3b 3b 20 70 61 72 74 73 20 3d 20 27 62 6f 74 .;; parts = 'bot
4c90: 68 20 7c 20 27 63 6f 6e 74 72 6f 6c 20 7c 20 27 h | 'control | '
4ca0: 76 69 65 77 0a 3b 3b 0a 0a 28 64 65 66 69 6e 65 view.;;..(define
4cb0: 20 28 66 69 6c 65 73 2d 72 65 61 64 2d 3e 73 74 (files-read->st
4cc0: 72 69 6e 67 20 2e 20 66 69 6c 65 73 29 0a 20 20 ring . files).
4cd0: 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
4ce0: 72 73 65 20 0a 20 20 20 28 61 70 70 6c 79 20 61 rse . (apply a
4cf0: 70 70 65 6e 64 20 28 6d 61 70 20 66 69 6c 65 2d ppend (map file-
4d00: 72 65 61 64 2d 3e 73 74 72 69 6e 67 20 66 69 6c read->string fil
4d10: 65 73 29 29 20 22 5c 6e 22 29 29 0a 0a 28 64 65 es)) "\n"))..(de
4d20: 66 69 6e 65 20 28 66 69 6c 65 2d 72 65 61 64 2d fine (file-read-
4d30: 3e 73 74 72 69 6e 67 20 66 29 20 0a 20 20 28 6c >string f) . (l
4d40: 65 74 20 28 28 70 20 28 6f 70 65 6e 2d 69 6e 70 et ((p (open-inp
4d50: 75 74 2d 66 69 6c 65 20 66 29 29 29 0a 20 20 20 ut-file f))).
4d60: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 (let loop ((hed
4d70: 20 28 72 65 61 64 2d 6c 69 6e 65 20 70 29 29 0a (read-line p)).
4d80: 09 20 20 20 20 20 20 20 28 72 65 73 20 27 28 29 . (res '()
4d90: 29 29 0a 20 20 20 20 20 20 28 69 66 20 28 65 6f )). (if (eo
4da0: 66 2d 6f 62 6a 65 63 74 3f 20 68 65 64 29 0a 09 f-object? hed)..
4db0: 20 20 72 65 73 0a 09 20 20 28 6c 6f 6f 70 20 28 res.. (loop (
4dc0: 72 65 61 64 2d 6c 69 6e 65 20 70 29 28 61 70 70 read-line p)(app
4dd0: 65 6e 64 20 72 65 73 20 28 6c 69 73 74 20 68 65 end res (list he
4de0: 64 29 29 29 29 29 29 29 0a 0a 3b 3b 20 4d 61 79 d)))))))..;; May
4df0: 20 32 30 31 31 2c 20 70 75 74 74 69 6e 67 20 61 2011, putting a
4e00: 6c 6c 20 70 61 67 65 73 20 69 6e 74 6f 20 6f 6e ll pages into on
4e10: 65 20 64 69 72 65 63 74 6f 72 79 20 66 6f 72 20 e directory for
4e20: 74 68 65 20 66 6f 6c 6c 6f 77 69 6e 67 20 72 65 the following re
4e30: 61 73 6f 6e 73 3a 0a 3b 3b 20 20 20 31 2e 20 77 asons:.;; 1. w
4e40: 61 6e 74 20 66 69 6c 65 6e 61 6d 65 20 74 6f 20 ant filename to
4e50: 72 65 66 6c 65 63 74 20 70 61 67 65 20 6e 61 6d reflect page nam
4e60: 65 20 28 65 6d 61 63 73 20 6c 69 6d 69 74 61 74 e (emacs limitat
4e70: 69 6f 6e 29 0a 3b 3b 20 20 20 32 2e 20 74 68 61 ion).;; 2. tha
4e80: 74 27 73 20 69 74 21 20 6e 6f 20 6f 74 68 65 72 t's it! no other
4e90: 20 72 65 61 73 6f 6e 2e 20 63 6f 75 6c 64 20 6d reason. could m
4ea0: 61 6b 65 20 69 74 20 63 6f 6e 66 69 67 75 72 61 ake it configura
4eb0: 62 6c 65 20 2e 2e 2e 0a 28 64 65 66 69 6e 65 2d ble ....(define-
4ec0: 6d 65 74 68 6f 64 20 28 73 65 73 73 69 6f 6e 3a method (session:
4ed0: 63 61 6c 6c 2d 70 61 72 74 73 20 28 73 65 6c 66 call-parts (self
4ee0: 20 3c 73 65 73 73 69 6f 6e 3e 29 20 70 61 67 65 <session>) page
4ef0: 20 70 61 72 74 73 29 0a 20 20 28 73 6c 6f 74 2d parts). (slot-
4f00: 73 65 74 21 20 73 65 6c 66 20 27 63 75 72 72 2d set! self 'curr-
4f10: 70 61 67 65 20 70 61 67 65 29 0a 20 20 28 6c 65 page page). (le
4f20: 74 2a 20 28 28 64 69 72 2d 73 74 79 6c 65 20 28 t* ((dir-style (
4f30: 65 71 3f 20 28 73 6c 6f 74 2d 72 65 66 20 73 65 eq? (slot-ref se
4f40: 6c 66 20 27 70 61 67 65 2d 64 69 72 2d 73 74 79 lf 'page-dir-sty
4f50: 6c 65 29 20 27 6f 6e 65 64 69 72 29 29 20 3b 3b le) 'onedir)) ;;
4f60: 20 66 6c 61 67 20 23 74 20 66 6f 72 20 6f 6e 65 flag #t for one
4f70: 64 69 72 2c 20 23 66 20 66 6f 72 20 6f 6c 64 20 dir, #f for old
4f80: 73 74 79 6c 65 0a 09 20 28 64 69 72 20 20 20 20 style.. (dir
4f90: 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 (string-append
4fa0: 28 73 6c 6f 74 2d 72 65 66 20 73 65 6c 66 20 27 (slot-ref self '
4fb0: 73 72 6f 6f 74 29 20 0a 09 09 09 09 20 28 69 66 sroot) ..... (if
4fc0: 20 64 69 72 2d 73 74 79 6c 65 20 0a 09 09 09 09 dir-style .....
4fd0: 20 20 20 20 20 28 63 6f 6e 63 20 22 2f 70 61 67 (conc "/pag
4fe0: 65 73 2f 22 29 0a 09 09 09 09 20 20 20 20 20 28 es/")..... (
4ff0: 63 6f 6e 63 20 22 2f 70 61 67 65 73 2f 22 20 70 conc "/pages/" p
5000: 61 67 65 29 29 29 29 0a 09 20 28 63 6f 6e 74 72 age)))).. (contr
5010: 6f 6c 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e ol (string-appen
5020: 64 20 64 69 72 20 28 69 66 20 64 69 72 2d 73 74 d dir (if dir-st
5030: 79 6c 65 20 0a 09 09 09 09 09 20 28 63 6f 6e 63 yle ...... (conc
5040: 20 70 61 67 65 20 22 5f 63 74 72 6c 2e 73 63 6d page "_ctrl.scm
5050: 22 29 0a 09 09 09 09 09 20 22 2f 63 6f 6e 74 72 ")...... "/contr
5060: 6f 6c 2e 73 63 6d 22 29 29 29 0a 09 20 28 76 69 ol.scm"))).. (vi
5070: 65 77 20 20 20 20 28 73 74 72 69 6e 67 2d 61 70 ew (string-ap
5080: 70 65 6e 64 20 64 69 72 20 28 69 66 20 64 69 72 pend dir (if dir
5090: 2d 73 74 79 6c 65 20 0a 09 09 09 09 09 20 28 63 -style ...... (c
50a0: 6f 6e 63 20 70 61 67 65 20 22 5f 76 69 65 77 2e onc page "_view.
50b0: 73 63 6d 22 29 0a 09 09 09 09 09 20 22 2f 76 69 scm")...... "/vi
50c0: 65 77 2e 73 63 6d 22 29 29 29 0a 09 20 28 6c 6f ew.scm"))).. (lo
50d0: 61 64 2d 76 69 65 77 20 20 20 20 28 61 6e 64 20 ad-view (and
50e0: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 76 69 (file-exists? vi
50f0: 65 77 29 0a 09 09 09 20 20 20 20 28 6f 72 20 28 ew).... (or (
5100: 65 71 3f 20 70 61 72 74 73 20 27 62 6f 74 68 29 eq? parts 'both)
5110: 28 65 71 3f 20 70 61 72 74 73 20 27 76 69 65 77 (eq? parts 'view
5120: 29 29 29 29 0a 09 20 28 6c 6f 61 64 2d 63 6f 6e )))).. (load-con
5130: 74 72 6f 6c 20 28 61 6e 64 20 28 66 69 6c 65 2d trol (and (file-
5140: 65 78 69 73 74 73 3f 20 63 6f 6e 74 72 6f 6c 29 exists? control)
5150: 0a 09 09 09 20 20 20 20 28 6f 72 20 28 65 71 3f .... (or (eq?
5160: 20 70 61 72 74 73 20 27 62 6f 74 68 29 28 65 71 parts 'both)(eq
5170: 3f 20 70 61 72 74 73 20 27 63 6f 6e 74 72 6f 6c ? parts 'control
5180: 29 29 29 29 0a 09 20 28 76 69 65 77 2d 64 61 74 )))).. (view-dat
5190: 20 20 20 27 28 29 29 29 0a 20 20 20 20 3b 3b 20 '())). ;;
51a0: 20 20 28 73 75 67 61 72 20 22 2f 68 6f 6d 65 2f (sugar "/home/
51b0: 6d 61 74 74 2f 6b 69 61 74 6f 61 2f 73 74 6d 6c matt/kiatoa/stml
51c0: 2f 73 75 67 61 72 2e 73 63 6d 22 20 29 29 0a 20 /sugar.scm" )).
51d0: 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 64 69 ;; (print "di
51e0: 72 3d 22 20 64 69 72 20 22 20 63 6f 6e 74 72 6f r=" dir " contro
51f0: 6c 3d 22 20 63 6f 6e 74 72 6f 6c 20 22 20 76 69 l=" control " vi
5200: 65 77 3d 22 20 76 69 65 77 20 22 20 6c 6f 61 64 ew=" view " load
5210: 2d 76 69 65 77 3d 22 20 6c 6f 61 64 2d 76 69 65 -view=" load-vie
5220: 77 20 22 20 6c 6f 61 64 3d 63 6f 6e 74 72 6f 6c w " load=control
5230: 3d 22 20 6c 6f 61 64 2d 63 6f 6e 74 72 6f 6c 29 =" load-control)
5240: 0a 20 20 20 20 28 69 66 20 6c 6f 61 64 2d 63 6f . (if load-co
5250: 6e 74 72 6f 6c 0a 09 28 62 65 67 69 6e 0a 09 20 ntrol..(begin..
5260: 20 28 6c 6f 61 64 20 63 6f 6e 74 72 6f 6c 29 0a (load control).
5270: 09 20 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 2d . (session:set-
5280: 63 61 6c 6c 65 64 21 20 73 65 6c 66 20 70 61 67 called! self pag
5290: 65 29 29 29 0a 20 20 20 20 3b 3b 20 6d 6f 76 65 e))). ;; move
52a0: 20 74 68 69 73 20 74 6f 20 77 68 65 72 65 20 69 this to where i
52b0: 74 20 67 65 74 73 20 65 78 65 63 74 75 74 65 64 t gets exectuted
52c0: 20 6f 6e 6c 79 20 6f 6e 63 65 0a 20 20 20 20 3b only once. ;
52d0: 3b 0a 20 20 20 20 28 69 66 20 6c 6f 61 64 2d 76 ;. (if load-v
52e0: 69 65 77 0a 09 3b 3b 20 6f 70 74 69 6f 6e 20 6f iew..;; option o
52f0: 6e 65 2e 3a 0a 09 3b 3b 0a 09 3b 3b 20 28 6c 65 ne.:..;;..;; (le
5300: 74 20 28 28 69 6e 70 20 28 6f 70 65 6e 2d 69 6e t ((inp (open-in
5310: 70 75 74 2d 73 74 72 69 6e 67 20 0a 09 3b 3b 20 put-string ..;;
5320: 09 20 20 20 20 28 66 69 6c 65 73 2d 72 65 61 64 . (files-read
5330: 2d 3e 73 74 72 69 6e 67 20 22 2f 68 6f 6d 65 2f ->string "/home/
5340: 6d 61 74 74 2f 6b 69 61 74 6f 61 2f 73 74 6d 6c matt/kiatoa/stml
5350: 2f 73 75 67 61 72 2e 73 63 6d 22 20 0a 09 3b 3b /sugar.scm" ..;;
5360: 20 09 09 09 09 76 69 65 77 29 29 29 29 0a 09 3b ....view))))..;
5370: 3b 20 20 20 28 6d 61 70 20 0a 09 3b 3b 20 20 20 ; (map ..;;
5380: 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 3b 3b (lambda (x)..;;
5390: 20 20 20 20 20 20 28 63 6f 6e 64 0a 09 3b 3b 20 (cond..;;
53a0: 20 20 20 20 20 20 28 28 6c 69 73 74 3f 20 78 29 ((list? x)
53b0: 20 78 29 0a 09 3b 3b 20 20 20 20 20 20 20 28 28 x)..;; ((
53c0: 73 74 72 69 6e 67 3f 20 78 29 20 78 29 0a 09 3b string? x) x)..;
53d0: 3b 20 20 20 20 20 20 20 28 65 6c 73 65 20 27 28 ; (else '(
53e0: 29 29 29 29 0a 09 3b 3b 20 20 20 20 28 70 6f 72 ))))..;; (por
53f0: 74 2d 6d 61 70 20 65 76 61 6c 20 28 6c 61 6d 62 t-map eval (lamb
5400: 64 61 20 28 29 0a 09 3b 3b 20 09 09 20 28 72 65 da ()..;; .. (re
5410: 61 64 20 69 6e 70 29 29 29 29 29 0a 09 3b 3b 0a ad inp)))))..;;.
5420: 09 3b 3b 20 6f 70 74 69 6f 6e 20 74 77 6f 3a 0a .;; option two:.
5430: 09 3b 3b 0a 09 28 6c 65 74 2a 20 28 3b 3b 20 28 .;;..(let* (;; (
5440: 69 6e 70 73 20 28 6d 61 70 20 6f 70 65 6e 2d 69 inps (map open-i
5450: 6e 70 75 74 2d 66 69 6c 65 20 28 6c 69 73 74 20 nput-file (list
5460: 76 69 65 77 29 29 29 20 3b 3b 20 73 75 67 61 72 view))) ;; sugar
5470: 20 76 69 65 77 29 29 29 0a 09 20 20 20 20 20 20 view)))..
5480: 20 28 70 20 20 20 20 28 6f 70 65 6e 2d 69 6e 70 (p (open-inp
5490: 75 74 2d 66 69 6c 65 20 76 69 65 77 29 29 20 3b ut-file view)) ;
54a0: 3b 20 28 61 70 70 6c 79 20 6d 61 6b 65 2d 63 6f ; (apply make-co
54b0: 6e 63 61 74 65 6e 61 74 65 64 2d 70 6f 72 74 20 ncatenated-port
54c0: 69 6e 70 73 29 29 0a 09 20 20 20 20 20 20 20 28 inps)).. (
54d0: 64 61 74 20 20 28 6d 61 70 20 0a 09 09 20 20 20 dat (map ...
54e0: 20 20 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 (lambda (x)..
54f0: 09 09 28 63 6f 6e 64 0a 09 09 09 20 28 28 6c 69 ..(cond.... ((li
5500: 73 74 3f 20 78 29 20 78 29 0a 09 09 09 20 28 28 st? x) x).... ((
5510: 73 74 72 69 6e 67 3f 20 78 29 20 78 29 0a 09 09 string? x) x)...
5520: 09 20 28 65 6c 73 65 20 27 28 29 29 29 29 0a 09 . (else '())))..
5530: 09 20 20 20 20 20 20 28 70 6f 72 74 2d 6d 61 70 . (port-map
5540: 20 65 76 61 6c 20 28 6c 61 6d 62 64 61 20 28 29 eval (lambda ()
5550: 28 72 65 61 64 20 70 29 29 29 29 29 29 0a 09 20 (read p))))))..
5560: 20 3b 3b 20 28 6d 61 70 20 63 6c 6f 73 65 2d 69 ;; (map close-i
5570: 6e 70 75 74 2d 70 6f 72 74 20 69 6e 70 73 29 0a nput-port inps).
5580: 09 20 20 28 63 6c 6f 73 65 2d 69 6e 70 75 74 2d . (close-input-
5590: 70 6f 72 74 20 70 29 0a 09 20 20 64 61 74 29 0a port p).. dat).
55a0: 09 28 6c 69 73 74 20 22 3c 70 3e 50 61 67 65 20 .(list "<p>Page
55b0: 6e 6f 74 20 66 6f 75 6e 64 20 22 20 70 61 67 65 not found " page
55c0: 20 22 20 3c 2f 70 3e 22 29 29 29 29 0a 0a 28 64 " </p>"))))..(d
55d0: 65 66 69 6e 65 2d 6d 65 74 68 6f 64 20 28 73 65 efine-method (se
55e0: 73 73 69 6f 6e 3a 63 61 6c 6c 20 28 73 65 6c 66 ssion:call (self
55f0: 20 3c 73 65 73 73 69 6f 6e 3e 29 20 70 61 67 65 <session>) page
5600: 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a 63 61 6c ). (session:cal
5610: 6c 2d 70 61 72 74 73 20 73 65 6c 66 20 70 61 67 l-parts self pag
5620: 65 20 27 62 6f 74 68 29 29 0a 0a 28 64 65 66 69 e 'both))..(defi
5630: 6e 65 2d 6d 65 74 68 6f 64 20 28 73 65 73 73 69 ne-method (sessi
5640: 6f 6e 3a 63 61 6c 6c 20 28 73 65 6c 66 20 3c 73 on:call (self <s
5650: 65 73 73 69 6f 6e 3e 29 20 70 61 67 65 20 70 61 ession>) page pa
5660: 72 74 73 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a rts). (session:
5670: 63 61 6c 6c 2d 70 61 72 74 73 20 73 65 6c 66 20 call-parts self
5680: 70 61 67 65 20 27 62 6f 74 68 29 29 0a 0a 28 64 page 'both))..(d
5690: 65 66 69 6e 65 2d 6d 65 74 68 6f 64 20 28 73 65 efine-method (se
56a0: 73 73 69 6f 6e 3a 6c 6f 61 64 2d 6d 6f 64 65 6c ssion:load-model
56b0: 20 28 73 65 6c 66 20 3c 73 65 73 73 69 6f 6e 3e (self <session>
56c0: 29 20 6d 6f 64 65 6c 29 0a 20 20 28 6c 65 74 20 ) model). (let
56d0: 28 28 6d 6f 64 65 6c 2e 73 63 6d 20 28 73 74 72 ((model.scm (str
56e0: 69 6e 67 2d 61 70 70 65 6e 64 20 28 73 6c 6f 74 ing-append (slot
56f0: 2d 72 65 66 20 73 65 6c 66 20 27 73 72 6f 6f 74 -ref self 'sroot
5700: 29 20 22 2f 6d 6f 64 65 6c 73 2f 22 20 6d 6f 64 ) "/models/" mod
5710: 65 6c 20 22 2e 73 63 6d 22 29 29 0a 09 28 6d 6f el ".scm"))..(mo
5720: 64 65 6c 2e 73 6f 20 20 28 73 74 72 69 6e 67 2d del.so (string-
5730: 61 70 70 65 6e 64 20 28 73 6c 6f 74 2d 72 65 66 append (slot-ref
5740: 20 73 65 6c 66 20 27 73 72 6f 6f 74 29 20 22 2f self 'sroot) "/
5750: 6d 6f 64 65 6c 73 2f 22 20 6d 6f 64 65 6c 20 22 models/" model "
5760: 2e 73 6f 22 29 29 29 0a 20 20 20 20 28 69 66 20 .so"))). (if
5770: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 6d 6f (file-exists? mo
5780: 64 65 6c 2e 73 6f 29 0a 09 28 6c 6f 61 64 20 6d del.so)..(load m
5790: 6f 64 65 6c 2e 73 6f 29 0a 09 28 69 66 20 28 66 odel.so)..(if (f
57a0: 69 6c 65 2d 65 78 69 73 74 73 3f 20 6d 6f 64 65 ile-exists? mode
57b0: 6c 2e 73 63 6d 29 0a 09 20 20 20 20 28 6c 6f 61 l.scm).. (loa
57c0: 64 20 6d 6f 64 65 6c 2e 73 63 6d 29 0a 09 20 20 d model.scm)..
57d0: 20 20 28 73 3a 6c 6f 67 20 22 45 52 52 4f 52 3a (s:log "ERROR:
57e0: 20 6d 6f 64 65 6c 20 22 20 6d 6f 64 65 6c 2e 73 model " model.s
57f0: 63 6d 20 22 20 6e 6f 74 20 66 6f 75 6e 64 22 29 cm " not found")
5800: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 2d 6d 65 ))))..(define-me
5810: 74 68 6f 64 20 28 73 65 73 73 69 6f 6e 3a 6d 6f thod (session:mo
5820: 64 65 6c 2d 70 61 74 68 20 28 73 65 6c 66 20 3c del-path (self <
5830: 73 65 73 73 69 6f 6e 3e 29 20 6d 6f 64 65 6c 29 session>) model)
5840: 0a 20 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e . (string-appen
5850: 64 20 28 73 6c 6f 74 2d 72 65 66 20 73 65 6c 66 d (slot-ref self
5860: 20 27 73 72 6f 6f 74 29 20 22 2f 6d 6f 64 65 6c 'sroot) "/model
5870: 73 2f 22 20 6d 6f 64 65 6c 20 22 2e 73 63 6d 22 s/" model ".scm"
5880: 29 29 0a 0a 28 64 65 66 69 6e 65 2d 6d 65 74 68 ))..(define-meth
5890: 6f 64 20 28 73 65 73 73 69 6f 6e 3a 70 70 2d 66 od (session:pp-f
58a0: 6f 72 6d 64 61 74 20 28 73 65 6c 66 20 3c 73 65 ormdat (self <se
58b0: 73 73 69 6f 6e 3e 29 29 0a 20 20 28 6c 65 74 20 ssion>)). (let
58c0: 28 28 64 61 74 20 28 66 6f 72 6d 64 61 74 3a 61 ((dat (formdat:a
58d0: 6c 6c 2d 3e 73 74 72 69 6e 67 73 20 28 73 6c 6f ll->strings (slo
58e0: 74 2d 72 65 66 20 73 65 6c 66 20 27 66 6f 72 6d t-ref self 'form
58f0: 64 61 74 29 29 29 29 0a 20 20 20 20 28 73 74 72 dat)))). (str
5900: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
5910: 64 61 74 20 22 3c 62 72 3e 20 22 29 29 29 0a 0a dat "<br> ")))..
5920: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
5930: 3a 70 61 72 61 6d 2d 3e 73 74 72 69 6e 67 20 70 :param->string p
5940: 61 72 61 6d 73 29 0a 20 20 3b 3b 20 28 65 72 72 arams). ;; (err
5950: 3a 6c 6f 67 20 22 70 61 72 61 6d 73 3d 22 20 70 :log "params=" p
5960: 61 72 61 6d 73 29 0a 20 20 28 69 66 20 28 3c 20 arams). (if (<
5970: 28 6c 65 6e 67 74 68 20 70 61 72 61 6d 73 29 20 (length params)
5980: 31 29 0a 20 20 20 20 20 20 22 22 0a 20 20 20 20 1). "".
5990: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 6b 65 (let loop ((ke
59a0: 79 20 28 63 61 72 20 70 61 72 61 6d 73 29 29 0a y (car params)).
59b0: 09 09 20 28 76 61 6c 20 28 63 61 64 72 20 70 61 .. (val (cadr pa
59c0: 72 61 6d 73 29 29 0a 09 09 20 28 74 61 69 6c 20 rams))... (tail
59d0: 28 63 64 64 72 20 70 61 72 61 6d 73 29 29 0a 09 (cddr params))..
59e0: 09 20 28 72 65 73 75 6c 74 20 27 28 29 29 29 0a . (result '())).
59f0: 09 28 6c 65 74 20 28 28 6e 65 77 72 65 73 75 6c .(let ((newresul
5a00: 74 20 28 63 6f 6e 73 20 28 73 74 72 69 6e 67 2d t (cons (string-
5a10: 61 70 70 65 6e 64 20 28 73 3a 61 6e 79 2d 3e 73 append (s:any->s
5a20: 74 72 69 6e 67 20 6b 65 79 29 20 22 3d 22 20 28 tring key) "=" (
5a30: 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 76 61 s:any->string va
5a40: 6c 29 29 0a 09 09 09 20 20 20 20 20 20 20 72 65 l)).... re
5a50: 73 75 6c 74 29 29 29 0a 09 20 20 28 69 66 20 28 sult))).. (if (
5a60: 3c 20 28 6c 65 6e 67 74 68 20 74 61 69 6c 29 20 < (length tail)
5a70: 31 29 20 3b 3b 20 74 72 75 65 20 69 66 20 64 6f 1) ;; true if do
5a80: 6e 65 0a 09 20 20 20 20 20 20 28 73 74 72 69 6e ne.. (strin
5a90: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 6e 65 g-intersperse ne
5aa0: 77 72 65 73 75 6c 74 20 22 26 22 29 0a 09 20 20 wresult "&")..
5ab0: 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 (loop (car t
5ac0: 61 69 6c 29 28 63 61 64 72 20 74 61 69 6c 29 28 ail)(cadr tail)(
5ad0: 63 64 64 72 20 74 61 69 6c 29 20 6e 65 77 72 65 cddr tail) newre
5ae0: 73 75 6c 74 29 29 29 29 29 29 0a 0a 28 64 65 66 sult))))))..(def
5af0: 69 6e 65 2d 6d 65 74 68 6f 64 20 28 73 65 73 73 ine-method (sess
5b00: 69 6f 6e 3a 6c 69 6e 6b 2d 74 6f 20 28 73 65 6c ion:link-to (sel
5b10: 66 20 3c 73 65 73 73 69 6f 6e 3e 29 20 70 61 67 f <session>) pag
5b20: 65 20 70 61 72 61 6d 73 29 0a 20 20 28 6c 65 74 e params). (let
5b30: 2a 20 28 28 73 65 72 76 65 72 20 20 20 20 28 69 * ((server (i
5b40: 66 20 28 67 65 74 65 6e 76 20 22 48 54 54 50 5f f (getenv "HTTP_
5b50: 48 4f 53 54 22 29 0a 09 09 09 28 67 65 74 65 6e HOST")....(geten
5b60: 76 20 22 48 54 54 50 5f 48 4f 53 54 22 29 0a 09 v "HTTP_HOST")..
5b70: 09 09 28 67 65 74 65 6e 76 20 22 53 45 52 56 45 ..(getenv "SERVE
5b80: 52 5f 4e 41 4d 45 22 29 29 29 0a 09 20 28 73 63 R_NAME"))).. (sc
5b90: 72 69 70 74 20 28 6c 65 74 20 28 28 73 63 72 69 ript (let ((scri
5ba0: 70 74 2d 6e 61 6d 65 20 28 73 74 72 69 6e 67 2d pt-name (string-
5bb0: 73 70 6c 69 74 20 28 67 65 74 65 6e 76 20 22 53 split (getenv "S
5bc0: 43 52 49 50 54 5f 4e 41 4d 45 22 29 20 22 2f 22 CRIPT_NAME") "/"
5bd0: 29 29 29 0a 09 09 20 20 20 28 69 66 20 28 3e 20 )))... (if (>
5be0: 28 6c 65 6e 67 74 68 20 73 63 72 69 70 74 2d 6e (length script-n
5bf0: 61 6d 65 29 20 31 29 0a 09 09 20 20 20 20 20 20 ame) 1)...
5c00: 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 (string-append
5c10: 28 63 61 72 20 73 63 72 69 70 74 2d 6e 61 6d 65 (car script-name
5c20: 29 20 22 2f 22 20 28 63 61 64 72 20 73 63 72 69 ) "/" (cadr scri
5c30: 70 74 2d 6e 61 6d 65 29 29 0a 09 09 20 20 20 20 pt-name))...
5c40: 20 20 20 28 67 65 74 65 6e 76 20 22 53 43 52 49 (getenv "SCRI
5c50: 50 54 5f 4e 41 4d 45 22 29 29 29 29 20 3b 3b 20 PT_NAME")))) ;;
5c60: 62 75 69 6c 64 20 73 63 72 69 70 74 20 6e 61 6d build script nam
5c70: 65 20 66 72 6f 6d 20 66 69 72 73 74 20 74 77 6f e from first two
5c80: 20 65 6c 65 6d 65 6e 74 73 2e 20 54 68 69 73 20 elements. This
5c90: 69 73 20 61 20 68 61 6e 67 6f 76 65 72 20 66 72 is a hangover fr
5ca0: 6f 6d 20 62 65 66 6f 72 65 20 49 20 75 73 65 64 om before I used
5cb0: 20 3f 20 69 6e 20 74 68 65 20 55 52 4c 2e 0a 09 ? in the URL...
5cc0: 20 28 73 65 73 73 69 6f 6e 2d 6b 65 79 20 28 73 (session-key (s
5cd0: 6c 6f 74 2d 72 65 66 20 73 65 6c 66 20 27 73 65 lot-ref self 'se
5ce0: 73 73 69 6f 6e 2d 6b 65 79 29 29 0a 09 20 28 70 ssion-key)).. (p
5cf0: 61 72 61 6d 73 74 72 20 28 73 65 73 73 69 6f 6e aramstr (session
5d00: 3a 70 61 72 61 6d 2d 3e 73 74 72 69 6e 67 20 70 :param->string p
5d10: 61 72 61 6d 73 29 29 29 0a 20 20 20 20 3b 3b 20 arams))). ;;
5d20: 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c (session:log sel
5d30: 66 20 22 73 65 72 76 65 72 3d 22 20 73 65 72 76 f "server=" serv
5d40: 65 72 20 22 20 73 63 72 69 70 74 3d 22 20 73 63 er " script=" sc
5d50: 72 69 70 74 20 22 20 70 61 67 65 3d 22 20 70 61 ript " page=" pa
5d60: 67 65 29 0a 20 20 20 20 28 73 74 72 69 6e 67 2d ge). (string-
5d70: 61 70 70 65 6e 64 20 22 68 74 74 70 3a 2f 2f 22 append "http://"
5d80: 20 73 65 72 76 65 72 20 22 2f 22 20 73 63 72 69 server "/" scri
5d90: 70 74 20 22 2f 22 20 70 61 67 65 20 22 3f 22 20 pt "/" page "?"
5da0: 70 61 72 61 6d 73 74 72 29 29 29 20 3b 3b 20 22 paramstr))) ;; "
5db0: 2f 73 6e 3d 22 20 73 65 73 73 69 6f 6e 2d 6b 65 /sn=" session-ke
5dc0: 79 29 29 29 0a 0a 28 64 65 66 69 6e 65 2d 6d 65 y)))..(define-me
5dd0: 74 68 6f 64 20 28 73 65 73 73 69 6f 6e 3a 63 67 thod (session:cg
5de0: 69 2d 6f 75 74 20 28 73 65 6c 66 20 3c 73 65 73 i-out (self <ses
5df0: 73 69 6f 6e 3e 29 29 0a 20 20 28 6c 65 74 2a 20 sion>)). (let*
5e00: 28 28 63 6f 6e 74 65 6e 74 20 20 28 6c 69 73 74 ((content (list
5e10: 20 28 73 6c 6f 74 2d 72 65 66 20 73 65 6c 66 20 (slot-ref self
5e20: 27 63 6f 6e 74 65 6e 74 2d 74 79 70 65 29 29 29 'content-type)))
5e30: 20 3b 3b 20 27 28 22 43 6f 6e 74 65 6e 74 2d 74 ;; '("Content-t
5e40: 79 70 65 3a 20 74 65 78 74 2f 68 74 6d 6c 3b 20 ype: text/html;
5e50: 63 68 61 72 73 65 74 3d 69 73 6f 2d 38 38 35 39 charset=iso-8859
5e60: 2d 31 5c 6e 5c 6e 22 29 29 0a 09 20 28 68 65 61 -1\n\n")).. (hea
5e70: 64 65 72 20 20 20 28 6c 65 74 20 28 28 63 6f 6f der (let ((coo
5e80: 6b 69 65 20 28 73 6c 6f 74 2d 72 65 66 20 73 65 kie (slot-ref se
5e90: 6c 66 20 27 73 65 73 73 69 6f 6e 2d 63 6f 6f 6b lf 'session-cook
5ea0: 69 65 29 29 29 0a 09 09 20 20 20 20 20 28 69 66 ie)))... (if
5eb0: 20 63 6f 6f 6b 69 65 0a 09 09 09 20 28 63 6f 6e cookie.... (con
5ec0: 73 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 s (string-append
5ed0: 20 22 53 65 74 2d 43 6f 6f 6b 69 65 3a 20 22 20 "Set-Cookie: "
5ee0: 28 63 61 72 20 63 6f 6f 6b 69 65 29 29 0a 09 09 (car cookie))...
5ef0: 09 20 20 20 20 20 20 20 63 6f 6e 74 65 6e 74 29 . content)
5f00: 0a 09 09 09 20 63 6f 6e 74 65 6e 74 29 29 29 0a .... content))).
5f10: 09 20 28 70 61 67 65 64 61 74 20 20 28 73 6c 6f . (pagedat (slo
5f20: 74 2d 72 65 66 20 73 65 6c 66 20 27 70 61 67 65 t-ref self 'page
5f30: 64 61 74 29 29 29 0a 20 20 20 20 28 73 3a 63 67 dat))). (s:cg
5f40: 69 2d 6f 75 74 20 0a 20 20 20 20 20 28 63 6f 6e i-out . (con
5f50: 73 20 68 65 61 64 65 72 20 70 61 67 65 64 61 74 s header pagedat
5f60: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 2d 6d 65 ))))..(define-me
5f70: 74 68 6f 64 20 28 73 65 73 73 69 6f 6e 3a 6c 6f thod (session:lo
5f80: 67 20 28 73 65 6c 66 20 3c 73 65 73 73 69 6f 6e g (self <session
5f90: 3e 29 20 2e 20 6d 73 67 29 0a 20 20 28 77 69 74 >) . msg). (wit
5fa0: 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 70 6f 72 74 h-output-to-port
5fb0: 20 28 73 6c 6f 74 2d 72 65 66 20 73 65 6c 66 20 (slot-ref self
5fc0: 27 6c 6f 67 2d 70 6f 72 74 29 20 3b 3b 20 28 73 'log-port) ;; (s
5fd0: 6c 6f 74 2d 72 65 66 20 73 65 6c 66 20 27 6c 6f lot-ref self 'lo
5fe0: 67 70 74 29 0a 20 20 20 20 28 6c 61 6d 62 64 61 gpt). (lambda
5ff0: 20 28 29 20 0a 20 20 20 20 20 20 28 61 70 70 6c () . (appl
6000: 79 20 70 72 69 6e 74 20 6d 73 67 29 29 29 29 0a y print msg)))).
6010: 0a 28 64 65 66 69 6e 65 2d 6d 65 74 68 6f 64 20 .(define-method
6020: 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 72 (session:get-par
6030: 61 6d 20 28 73 65 6c 66 20 3c 73 65 73 73 69 6f am (self <sessio
6040: 6e 3e 29 20 6b 65 79 29 0a 20 20 3b 3b 20 28 73 n>) key). ;; (s
6050: 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 3a 73 65 73 ession:log s:ses
6060: 73 69 6f 6e 20 22 70 61 72 61 6d 73 3d 22 20 28 sion "params=" (
6070: 73 6c 6f 74 2d 72 65 66 20 73 3a 73 65 73 73 69 slot-ref s:sessi
6080: 6f 6e 20 27 70 61 72 61 6d 73 29 29 0a 20 20 28 on 'params)). (
6090: 6c 65 74 20 28 28 70 61 72 61 6d 73 20 28 73 6c let ((params (sl
60a0: 6f 74 2d 72 65 66 20 73 65 6c 66 20 27 70 61 72 ot-ref self 'par
60b0: 61 6d 73 29 29 29 0a 20 20 20 20 28 73 65 73 73 ams))). (sess
60c0: 69 6f 6e 3a 67 65 74 2d 70 61 72 61 6d 2d 66 72 ion:get-param-fr
60d0: 6f 6d 20 70 61 72 61 6d 73 20 6b 65 79 29 29 29 om params key)))
60e0: 0a 0a 3b 3b 20 54 68 69 73 20 6f 6e 65 20 77 69 ..;; This one wi
60f0: 6c 6c 20 67 65 74 20 74 68 65 20 66 69 72 73 74 ll get the first
6100: 20 76 61 6c 75 65 20 66 6f 75 6e 64 20 72 65 67 value found reg
6110: 61 72 64 6c 65 73 73 20 6f 66 20 66 6f 72 6d 0a ardless of form.
6120: 28 64 65 66 69 6e 65 2d 6d 65 74 68 6f 64 20 28 (define-method (
6130: 73 65 73 73 69 6f 6e 3a 67 65 74 2d 69 6e 70 75 session:get-inpu
6140: 74 20 28 73 65 6c 66 20 3c 73 65 73 73 69 6f 6e t (self <session
6150: 3e 29 20 6b 65 79 29 0a 20 20 28 6c 65 74 2a 20 >) key). (let*
6160: 28 28 66 6f 72 6d 64 61 74 20 28 73 6c 6f 74 2d ((formdat (slot-
6170: 72 65 66 20 73 65 6c 66 20 27 66 6f 72 6d 64 61 ref self 'formda
6180: 74 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f t))). (if (no
6190: 74 20 66 6f 72 6d 64 61 74 29 20 23 66 0a 09 28 t formdat) #f..(
61a0: 69 66 20 28 6f 72 20 28 73 74 72 69 6e 67 3f 20 if (or (string?
61b0: 6b 65 79 29 28 6e 75 6d 62 65 72 3f 20 6b 65 79 key)(number? key
61c0: 29 28 73 79 6d 62 6f 6c 3f 20 6b 65 79 29 29 0a )(symbol? key)).
61d0: 09 20 20 20 20 28 69 66 20 28 65 71 3f 20 28 63 . (if (eq? (c
61e0: 6c 61 73 73 2d 6f 66 20 66 6f 72 6d 64 61 74 29 lass-of formdat)
61f0: 20 3c 66 6f 72 6d 64 61 74 3e 29 0a 09 09 28 66 <formdat>)...(f
6200: 6f 72 6d 64 61 74 3a 67 65 74 20 66 6f 72 6d 64 ormdat:get formd
6210: 61 74 20 6b 65 79 29 0a 09 09 28 62 65 67 69 6e at key)...(begin
6220: 0a 09 09 20 20 28 73 65 73 73 69 6f 6e 3a 6c 6f ... (session:lo
6230: 67 20 73 65 6c 66 20 22 45 52 52 4f 52 3a 20 66 g self "ERROR: f
6240: 6f 72 6d 64 61 74 3a 20 22 20 66 6f 72 6d 64 61 ormdat: " formda
6250: 74 20 22 20 69 73 20 6e 6f 74 20 6f 66 20 63 6c t " is not of cl
6260: 61 73 73 20 3c 66 6f 72 6d 64 61 74 3e 22 29 0a ass <formdat>").
6270: 09 09 20 20 23 66 29 29 0a 09 20 20 20 20 28 73 .. #f)).. (s
6280: 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 ession:log self
6290: 22 45 52 52 4f 52 3a 20 62 61 64 20 6b 65 79 20 "ERROR: bad key
62a0: 22 20 6b 65 79 29 29 29 29 29 0a 0a 28 64 65 66 " key)))))..(def
62b0: 69 6e 65 2d 6d 65 74 68 6f 64 20 28 73 65 73 73 ine-method (sess
62c0: 69 6f 6e 3a 72 75 6e 2d 61 63 74 69 6f 6e 73 20 ion:run-actions
62d0: 28 73 65 6c 66 20 3c 73 65 73 73 69 6f 6e 3e 29 (self <session>)
62e0: 29 0a 20 20 28 6c 65 74 2a 20 28 28 61 63 74 69 ). (let* ((acti
62f0: 6f 6e 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 67 on (session:g
6300: 65 74 2d 70 61 72 61 6d 20 73 65 6c 66 20 27 61 et-param self 'a
6310: 63 74 69 6f 6e 29 29 0a 09 20 28 70 61 67 65 20 ction)).. (page
6320: 20 20 20 20 20 28 73 6c 6f 74 2d 72 65 66 20 73 (slot-ref s
6330: 65 6c 66 20 27 70 61 67 65 29 29 29 0a 20 20 20 elf 'page))).
6340: 20 3b 3b 20 28 70 72 69 6e 74 20 22 61 63 74 69 ;; (print "acti
6350: 6f 6e 3d 22 20 61 63 74 69 6f 6e 20 22 20 70 61 on=" action " pa
6360: 67 65 3d 22 20 70 61 67 65 29 0a 20 20 20 20 28 ge=" page). (
6370: 69 66 20 61 63 74 69 6f 6e 0a 09 28 6c 65 74 20 if action..(let
6380: 28 28 61 63 74 69 6f 6e 2d 6c 73 74 20 20 28 73 ((action-lst (s
6390: 74 72 69 6e 67 2d 73 70 6c 69 74 20 61 63 74 69 tring-split acti
63a0: 6f 6e 20 22 2e 22 29 29 29 0a 09 20 20 3b 3b 20 on "."))).. ;;
63b0: 28 70 72 69 6e 74 20 22 61 63 74 69 6f 6e 2d 6c (print "action-l
63c0: 73 74 3d 22 20 61 63 74 69 6f 6e 2d 6c 73 74 29 st=" action-lst)
63d0: 0a 09 20 20 28 69 66 20 28 6e 6f 74 20 28 3d 20 .. (if (not (=
63e0: 28 6c 65 6e 67 74 68 20 61 63 74 69 6f 6e 2d 6c (length action-l
63f0: 73 74 29 20 32 29 29 20 0a 09 20 20 20 20 20 20 st) 2)) ..
6400: 28 65 72 72 3a 6c 6f 67 20 22 41 63 74 69 6f 6e (err:log "Action
6410: 20 73 68 6f 75 6c 64 20 62 65 20 6f 66 20 66 6f should be of fo
6420: 72 6d 3a 20 6d 6f 64 75 6c 65 2e 61 63 74 69 6f rm: module.actio
6430: 6e 22 29 0a 09 20 20 20 20 20 20 28 6c 65 74 2a n").. (let*
6440: 20 28 28 74 61 72 67 2d 70 61 67 65 20 20 20 28 ((targ-page (
6450: 63 61 72 20 61 63 74 69 6f 6e 2d 6c 73 74 29 29 car action-lst))
6460: 0a 09 09 20 20 20 20 20 28 70 72 6f 63 2d 6e 61 ... (proc-na
6470: 6d 65 20 20 20 28 73 74 72 69 6e 67 2d 61 70 70 me (string-app
6480: 65 6e 64 20 74 61 72 67 2d 70 61 67 65 20 22 2d end targ-page "-
6490: 61 63 74 69 6f 6e 22 29 29 0a 09 09 20 20 20 20 action"))...
64a0: 20 28 74 61 72 67 2d 61 63 74 69 6f 6e 20 28 63 (targ-action (c
64b0: 61 64 72 20 61 63 74 69 6f 6e 2d 6c 73 74 29 29 adr action-lst))
64c0: 29 0a 09 09 3b 3b 20 28 65 72 72 3a 6c 6f 67 20 )...;; (err:log
64d0: 22 74 61 72 67 2d 70 61 67 65 3d 22 20 74 61 72 "targ-page=" tar
64e0: 67 2d 70 61 67 65 20 22 20 70 72 6f 63 2d 6e 61 g-page " proc-na
64f0: 6d 65 3d 22 20 70 72 6f 63 2d 6e 61 6d 65 20 22 me=" proc-name "
6500: 20 74 61 72 67 2d 61 63 74 69 6f 6e 3d 22 20 74 targ-action=" t
6510: 61 72 67 2d 61 63 74 69 6f 6e 29 0a 0a 09 09 3b arg-action)....;
6520: 3b 20 63 61 6c 6c 20 68 65 72 65 20 6f 6e 6c 79 ; call here only
6530: 20 69 66 20 6e 65 76 65 72 20 63 61 6c 6c 65 64 if never called
6540: 20 62 65 66 6f 72 65 0a 09 09 28 69 66 20 28 73 before...(if (s
6550: 65 73 73 69 6f 6e 3a 6e 65 76 65 72 2d 63 61 6c ession:never-cal
6560: 6c 65 64 2d 70 61 67 65 3f 20 73 65 6c 66 20 74 led-page? self t
6570: 61 72 67 2d 70 61 67 65 29 0a 09 09 20 20 20 20 arg-page)...
6580: 28 73 65 73 73 69 6f 6e 3a 63 61 6c 6c 2d 70 61 (session:call-pa
6590: 72 74 73 20 73 65 6c 66 20 74 61 72 67 2d 70 61 rts self targ-pa
65a0: 67 65 20 27 63 6f 6e 74 72 6f 6c 29 29 0a 09 09 ge 'control))...
65b0: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
65c0: 20 20 20 20 20 20 70 72 6f 63 20 20 20 20 20 20 proc
65d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
65e0: 20 20 20 61 63 74 69 6f 6e 20 20 20 20 0a 0a 09 action ...
65f0: 09 28 69 66 20 23 74 20 3b 3b 20 73 65 74 20 74 .(if #t ;; set t
6600: 6f 20 23 74 20 74 6f 20 73 65 65 20 62 65 74 74 o #t to see bett
6610: 65 72 20 65 72 72 6f 72 20 6d 65 73 73 61 67 65 er error message
6620: 73 20 64 75 72 69 6e 67 20 64 65 62 75 67 67 69 s during debuggi
6630: 6e 20 3a 2d 29 0a 09 09 20 20 20 20 28 28 65 76 n :-)... ((ev
6640: 61 6c 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 al (string->symb
6650: 6f 6c 20 70 72 6f 63 2d 6e 61 6d 65 29 29 20 74 ol proc-name)) t
6660: 61 72 67 2d 61 63 74 69 6f 6e 29 20 3b 3b 20 75 arg-action) ;; u
6670: 6e 73 61 66 65 20 65 78 65 63 75 74 69 6f 6e 0a nsafe execution.
6680: 09 09 20 20 20 20 28 63 6f 6e 64 69 74 69 6f 6e .. (condition
6690: 2d 63 61 73 65 20 28 28 65 76 61 6c 20 28 73 74 -case ((eval (st
66a0: 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 70 72 6f ring->symbol pro
66b0: 63 2d 6e 61 6d 65 29 29 20 74 61 72 67 2d 61 63 c-name)) targ-ac
66c0: 74 69 6f 6e 29 0a 09 09 09 09 20 20 20 20 28 28 tion)..... ((
66d0: 65 78 6e 20 66 69 6c 65 29 20 28 73 3a 6c 6f 67 exn file) (s:log
66e0: 20 22 66 69 6c 65 20 65 72 72 6f 72 22 29 29 0a "file error")).
66f0: 09 09 09 09 20 20 20 20 28 28 65 78 6e 20 69 2f .... ((exn i/
6700: 6f 29 20 20 28 73 3a 6c 6f 67 20 22 69 2f 6f 20 o) (s:log "i/o
6710: 65 72 72 6f 72 22 29 29 0a 09 09 09 09 20 20 20 error")).....
6720: 20 28 28 65 78 6e 20 29 20 20 20 20 20 28 73 3a ((exn ) (s:
6730: 6c 6f 67 20 22 41 63 74 69 6f 6e 20 6e 6f 74 20 log "Action not
6740: 69 6d 70 6c 65 6d 65 6e 74 65 64 3a 20 22 20 70 implemented: " p
6750: 72 6f 63 2d 6e 61 6d 65 20 22 20 61 63 74 69 6f roc-name " actio
6760: 6e 3a 20 22 20 74 61 72 67 2d 61 63 74 69 6f 6e n: " targ-action
6770: 29 29 0a 09 09 09 09 20 20 20 20 28 76 61 72 20 ))..... (var
6780: 28 29 20 20 20 20 20 28 73 3a 6c 6f 67 20 22 55 () (s:log "U
6790: 6e 6b 6e 6f 77 6e 20 45 72 72 6f 72 22 29 29 29 nknown Error")))
67a0: 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 )))))))..(define
67b0: 2d 6d 65 74 68 6f 64 20 28 73 65 73 73 69 6f 6e -method (session
67c0: 3a 6e 65 76 65 72 2d 63 61 6c 6c 65 64 2d 70 61 :never-called-pa
67d0: 67 65 3f 20 28 73 65 6c 66 20 3c 73 65 73 73 69 ge? (self <sessi
67e0: 6f 6e 3e 29 20 70 61 67 65 29 0a 20 20 28 73 65 on>) page). (se
67f0: 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 ssion:log self "
6800: 43 68 65 63 6b 69 6e 67 20 66 6f 72 20 70 61 67 Checking for pag
6810: 65 3a 20 22 20 70 61 67 65 29 0a 20 20 28 6e 6f e: " page). (no
6820: 74 20 28 6d 65 6d 62 65 72 20 70 61 67 65 20 28 t (member page (
6830: 73 6c 6f 74 2d 72 65 66 20 73 65 6c 66 20 27 73 slot-ref self 's
6840: 65 65 6e 2d 70 61 67 65 73 29 29 29 29 0a 0a 28 een-pages))))..(
6850: 64 65 66 69 6e 65 2d 6d 65 74 68 6f 64 20 28 73 define-method (s
6860: 65 73 73 69 6f 6e 3a 73 65 74 2d 63 61 6c 6c 65 ession:set-calle
6870: 64 21 20 28 73 65 6c 66 20 3c 73 65 73 73 69 6f d! (self <sessio
6880: 6e 3e 29 20 70 61 67 65 29 0a 20 20 28 73 6c 6f n>) page). (slo
6890: 74 2d 73 65 74 21 20 73 65 6c 66 20 27 73 65 65 t-set! self 'see
68a0: 6e 2d 70 61 67 65 73 20 28 63 6f 6e 73 20 70 61 n-pages (cons pa
68b0: 67 65 20 28 73 6c 6f 74 2d 72 65 66 20 73 65 6c ge (slot-ref sel
68c0: 66 20 27 73 65 65 6e 2d 70 61 67 65 73 29 29 29 f 'seen-pages)))
68d0: 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
68e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
68f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6900: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6910: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 41 ===========.;; A
6920: 6c 74 65 72 6e 61 74 69 76 65 20 64 61 74 61 20 lternative data
6930: 74 79 70 65 20 64 65 6c 69 76 65 72 79 0a 3b 3b type delivery.;;
6940: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6950: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6960: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6970: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6980: 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 2d ======..(define-
6990: 6d 65 74 68 6f 64 20 28 73 65 73 73 69 6f 6e 3a method (session:
69a0: 61 6c 74 2d 6f 75 74 20 28 73 65 6c 66 20 3c 73 alt-out (self <s
69b0: 65 73 73 69 6f 6e 3e 29 29 0a 20 20 28 6c 65 74 ession>)). (let
69c0: 20 28 28 64 61 74 20 28 73 6c 6f 74 2d 72 65 66 ((dat (slot-ref
69d0: 20 73 65 6c 66 20 27 61 6c 74 2d 70 61 67 65 2d self 'alt-page-
69e0: 64 61 74 29 29 29 0a 20 20 20 20 3b 3b 20 28 73 dat))). ;; (s
69f0: 3a 6c 6f 67 20 22 64 61 74 20 69 73 3a 20 22 20 :log "dat is: "
6a00: 64 61 74 29 0a 20 20 20 20 3b 3b 20 28 70 72 69 dat). ;; (pri
6a10: 6e 74 20 22 48 54 54 50 2f 31 2e 31 20 32 30 30 nt "HTTP/1.1 200
6a20: 20 4f 4b 22 29 0a 20 20 20 20 28 70 72 69 6e 74 OK"). (print
6a30: 20 22 44 61 74 65 3a 20 22 20 28 74 69 6d 65 2d "Date: " (time-
6a40: 3e 73 74 72 69 6e 67 20 28 73 65 63 6f 6e 64 73 >string (seconds
6a50: 2d 3e 75 74 63 2d 74 69 6d 65 20 28 63 75 72 72 ->utc-time (curr
6a60: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 29 0a ent-seconds)))).
6a70: 20 20 20 20 28 70 72 69 6e 74 20 22 43 6f 6e 74 (print "Cont
6a80: 65 6e 74 2d 54 79 70 65 3a 20 22 20 28 73 6c 6f ent-Type: " (slo
6a90: 74 2d 72 65 66 20 73 65 6c 66 20 27 63 6f 6e 74 t-ref self 'cont
6aa0: 65 6e 74 2d 74 79 70 65 29 29 0a 20 20 20 20 28 ent-type)). (
6ab0: 70 72 69 6e 74 20 22 41 63 63 65 70 74 2d 52 61 print "Accept-Ra
6ac0: 6e 67 65 73 3a 20 62 79 74 65 73 22 29 0a 20 20 nges: bytes").
6ad0: 20 20 28 70 72 69 6e 74 20 22 43 6f 6e 74 65 6e (print "Conten
6ae0: 74 2d 4c 65 6e 67 74 68 3a 20 22 20 28 69 66 20 t-Length: " (if
6af0: 28 62 6c 6f 62 3f 20 64 61 74 29 0a 09 09 09 09 (blob? dat).....
6b00: 20 20 28 62 6c 6f 62 2d 73 69 7a 65 20 64 61 74 (blob-size dat
6b10: 29 0a 09 09 09 09 20 20 30 29 29 0a 20 20 20 20 )..... 0)).
6b20: 28 70 72 69 6e 74 20 22 4b 65 65 70 2d 41 6c 69 (print "Keep-Ali
6b30: 76 65 3a 20 74 69 6d 65 6f 75 74 3d 31 35 2c 20 ve: timeout=15,
6b40: 6d 61 78 3d 31 30 30 22 29 0a 20 20 20 20 28 70 max=100"). (p
6b50: 72 69 6e 74 20 22 43 6f 6e 6e 65 63 74 69 6f 6e rint "Connection
6b60: 3a 20 4b 65 65 70 2d 41 6c 69 76 65 22 29 0a 20 : Keep-Alive").
6b70: 20 20 20 28 70 72 69 6e 74 20 22 22 29 0a 20 20 (print "").
6b80: 20 20 28 77 72 69 74 65 2d 73 74 72 69 6e 67 20 (write-string
6b90: 28 62 6c 6f 62 2d 3e 73 74 72 69 6e 67 20 64 61 (blob->string da
6ba0: 74 29 20 23 66 20 28 63 75 72 72 65 6e 74 2d 6f t) #f (current-o
6bb0: 75 74 70 75 74 2d 70 6f 72 74 29 29 29 29 0a utput-port)))).