Artifact
b5a2e5332954595dc33c6374b953037ac9b46990:
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 23 74 age-dir-style #t
0a80: 29 20 3b 3b 20 23 74 20 3a 20 70 61 67 65 73 2f ) ;; #t : pages/
0a90: 3c 70 61 67 65 6e 61 6d 65 3e 5f 28 76 69 65 77 <pagename>_(view
0aa0: 7c 63 6f 6e 74 72 6f 6c 29 2e 73 63 6d 0a 20 20 |control).scm.
0ab0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0ac0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0ad0: 20 20 20 20 3b 3b 20 23 66 20 3a 20 70 61 67 65 ;; #f : page
0ae0: 73 2f 3c 70 61 67 65 6e 61 6d 65 3e 2f 28 76 69 s/<pagename>/(vi
0af0: 65 77 7c 63 6f 6e 74 72 6f 6c 29 2e 73 63 6d 20 ew|control).scm
0b00: 0a 20 20 28 73 6c 6f 74 2d 73 65 74 21 20 73 65 . (slot-set! se
0b10: 6c 66 20 27 64 65 62 75 67 6d 6f 64 65 20 23 66 lf 'debugmode #f
0b20: 29 0a 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c ). (for-each (l
0b30: 61 6d 62 64 61 20 28 73 6c 6f 74 2d 6e 61 6d 65 ambda (slot-name
0b40: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
0b50: 28 73 6c 6f 74 2d 73 65 74 21 20 73 65 6c 66 20 (slot-set! self
0b60: 73 6c 6f 74 2d 6e 61 6d 65 20 28 6d 61 6b 65 2d slot-name (make-
0b70: 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 hash-table))).
0b80: 20 20 20 20 20 20 20 20 20 20 28 6c 69 73 74 20 (list
0b90: 27 70 61 67 65 76 61 72 73 20 27 73 65 73 73 69 'pagevars 'sessi
0ba0: 6f 6e 76 61 72 73 20 27 67 6c 6f 62 61 6c 76 61 onvars 'globalva
0bb0: 72 73 20 27 70 61 67 65 76 61 72 73 2d 62 65 66 rs 'pagevars-bef
0bc0: 6f 72 65 20 0a 09 09 20 20 27 73 65 73 73 69 6f ore ... 'sessio
0bd0: 6e 76 61 72 73 2d 62 65 66 6f 72 65 20 27 67 6c nvars-before 'gl
0be0: 6f 62 61 6c 76 61 72 73 2d 62 65 66 6f 72 65 29 obalvars-before)
0bf0: 29 0a 20 20 28 73 6c 6f 74 2d 73 65 74 21 20 73 ). (slot-set! s
0c00: 65 6c 66 20 27 64 6f 6d 61 69 6e 20 22 6c 6f 63 elf 'domain "loc
0c10: 61 68 6f 73 74 22 29 20 20 20 3b 3b 20 65 6e 64 ahost") ;; end
0c20: 20 6f 66 20 64 65 66 61 75 6c 74 73 0a 20 20 28 of defaults. (
0c30: 69 6e 69 74 69 61 6c 69 7a 65 2d 73 6c 6f 74 73 initialize-slots
0c40: 20 73 65 6c 66 20 28 73 65 73 73 69 6f 6e 3a 72 self (session:r
0c50: 65 61 64 2d 63 6f 6e 66 69 67 20 73 65 6c 66 29 ead-config self)
0c60: 29 0a 20 20 3b 3b 20 73 6f 6d 65 20 76 61 6c 75 ). ;; some valu
0c70: 65 73 20 72 65 61 64 20 69 6e 20 66 72 6f 6d 20 es read in from
0c80: 74 68 65 20 63 6f 6e 66 69 67 20 66 69 6c 65 20 the config file
0c90: 6e 65 65 64 20 74 6f 20 62 65 20 65 76 61 6c 65 need to be evale
0ca0: 64 0a 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c d. (for-each (l
0cb0: 61 6d 62 64 61 20 28 73 6c 6f 74 2d 6e 61 6d 65 ambda (slot-name
0cc0: 29 0a 09 20 20 20 20 20 20 28 73 6c 6f 74 2d 73 ).. (slot-s
0cd0: 65 74 21 20 73 65 6c 66 20 73 6c 6f 74 2d 6e 61 et! self slot-na
0ce0: 6d 65 20 28 65 76 61 6c 20 28 73 6c 6f 74 2d 72 me (eval (slot-r
0cf0: 65 66 20 73 65 6c 66 20 73 6c 6f 74 2d 6e 61 6d ef self slot-nam
0d00: 65 29 29 29 29 0a 09 20 20 20 20 28 6c 69 73 74 e)))).. (list
0d10: 20 27 64 62 74 79 70 65 29 29 0a 20 20 28 69 6e 'dbtype)). (in
0d20: 69 74 69 61 6c 69 7a 65 2d 73 6c 6f 74 73 20 73 itialize-slots s
0d30: 65 6c 66 20 69 6e 69 74 61 72 67 73 29 29 0a 0a elf initargs))..
0d40: 28 64 65 66 69 6e 65 2d 6d 65 74 68 6f 64 20 28 (define-method (
0d50: 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 20 28 73 session:setup (s
0d60: 65 6c 66 20 3c 73 65 73 73 69 6f 6e 3e 29 29 0a elf <session>)).
0d70: 20 20 28 6c 65 74 20 28 28 64 62 74 79 70 65 20 (let ((dbtype
0d80: 28 73 6c 6f 74 2d 72 65 66 20 73 65 6c 66 20 27 (slot-ref self '
0d90: 64 62 74 79 70 65 29 29 0a 09 28 64 62 69 6e 69 dbtype))..(dbini
0da0: 74 20 28 65 76 61 6c 20 28 73 6c 6f 74 2d 72 65 t (eval (slot-re
0db0: 66 20 73 65 6c 66 20 27 64 62 69 6e 69 74 29 29 f self 'dbinit))
0dc0: 29 0a 09 28 64 62 65 78 69 73 74 73 20 23 66 29 )..(dbexists #f)
0dd0: 29 0a 20 20 20 20 28 6c 65 74 20 28 28 64 62 66 ). (let ((dbf
0de0: 6e 61 6d 65 20 28 61 6c 69 73 74 2d 72 65 66 20 name (alist-ref
0df0: 27 64 62 6e 61 6d 65 20 64 62 69 6e 69 74 29 29 'dbname dbinit))
0e00: 29 0a 20 20 20 20 20 20 28 69 66 20 28 65 71 3f ). (if (eq?
0e10: 20 64 62 74 79 70 65 20 27 73 71 6c 69 74 65 33 dbtype 'sqlite3
0e20: 29 0a 09 20 20 28 69 66 20 28 66 69 6c 65 2d 65 ).. (if (file-e
0e30: 78 69 73 74 73 3f 20 64 62 66 6e 61 6d 65 29 0a xists? dbfname).
0e40: 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 . (begin...
0e50: 3b 3b 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 ;; (session:log
0e60: 73 65 6c 66 20 22 73 65 74 74 69 6e 67 20 64 62 self "setting db
0e70: 65 78 69 73 74 73 20 74 6f 20 23 74 22 29 0a 09 exists to #t")..
0e80: 09 28 73 65 74 21 20 64 62 65 78 69 73 74 73 20 .(set! dbexists
0e90: 23 74 29 29 29 29 0a 20 20 20 20 20 20 3b 3b 20 #t)))). ;;
0ea0: 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c (session:log sel
0eb0: 66 20 22 64 62 74 79 70 65 3a 20 22 20 64 62 74 f "dbtype: " dbt
0ec0: 79 70 65 20 22 20 64 62 66 6e 61 6d 65 3a 20 22 ype " dbfname: "
0ed0: 20 64 62 66 6e 61 6d 65 20 22 20 64 62 65 78 69 dbfname " dbexi
0ee0: 73 74 73 3a 20 22 20 64 62 65 78 69 73 74 73 29 sts: " dbexists)
0ef0: 29 0a 20 20 20 20 20 20 29 0a 20 20 20 20 28 73 ). ). (s
0f00: 6c 6f 74 2d 73 65 74 21 20 73 65 6c 66 20 27 63 lot-set! self 'c
0f10: 6f 6e 6e 20 28 64 62 69 3a 6f 70 65 6e 20 64 62 onn (dbi:open db
0f20: 74 79 70 65 20 64 62 69 6e 69 74 29 29 0a 20 20 type dbinit)).
0f30: 20 20 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 (if (and (not
0f40: 64 62 65 78 69 73 74 73 29 28 65 71 3f 20 64 62 dbexists)(eq? db
0f50: 74 79 70 65 20 27 73 71 6c 69 74 65 33 29 29 0a type 'sqlite3)).
0f60: 20 09 28 62 65 67 69 6e 0a 09 20 20 28 70 72 69 .(begin.. (pri
0f70: 6e 74 20 22 57 41 52 4e 49 4e 47 3a 20 53 65 74 nt "WARNING: Set
0f80: 74 69 6e 67 20 75 70 20 73 65 73 73 69 6f 6e 20 ting up session
0f90: 64 62 20 77 69 74 68 20 73 71 6c 69 74 65 33 22 db with sqlite3"
0fa0: 29 0a 09 20 20 28 73 65 73 73 69 6f 6e 3a 73 65 ).. (session:se
0fb0: 74 75 70 2d 64 62 20 73 65 6c 66 29 29 29 0a 20 tup-db self))).
0fc0: 20 20 20 28 73 65 73 73 69 6f 6e 3a 70 72 6f 63 (session:proc
0fd0: 65 73 73 2d 75 72 6c 2d 70 61 74 68 20 73 65 6c ess-url-path sel
0fe0: 66 29 0a 20 20 20 20 28 73 65 73 73 69 6f 6e 3a f). (session:
0ff0: 73 65 74 75 70 2d 73 65 73 73 69 6f 6e 2d 6b 65 setup-session-ke
1000: 79 20 73 65 6c 66 29 0a 20 20 20 20 3b 3b 20 63 y self). ;; c
1010: 61 70 74 75 72 65 20 73 74 64 69 6e 20 69 66 20 apture stdin if
1020: 74 68 69 73 20 69 73 20 61 20 50 4f 53 54 0a 20 this is a POST.
1030: 20 20 20 28 73 6c 6f 74 2d 73 65 74 21 20 73 65 (slot-set! se
1040: 6c 66 20 27 72 65 71 75 65 73 74 2d 6d 65 74 68 lf 'request-meth
1050: 6f 64 20 28 67 65 74 65 6e 76 20 22 52 45 51 55 od (getenv "REQU
1060: 45 53 54 5f 4d 45 54 48 4f 44 22 29 29 0a 20 20 EST_METHOD")).
1070: 20 20 28 73 6c 6f 74 2d 73 65 74 21 20 73 65 6c (slot-set! sel
1080: 66 20 27 66 6f 72 6d 64 61 74 20 28 66 6f 72 6d f 'formdat (form
1090: 64 61 74 3a 6c 6f 61 64 2d 61 6c 6c 29 29 29 29 dat:load-all))))
10a0: 0a 0a 3b 3b 20 73 65 74 75 70 20 74 68 65 20 64 ..;; setup the d
10b0: 62 20 77 69 74 68 20 73 65 73 73 69 6f 6e 20 74 b with session t
10c0: 61 62 6c 65 73 2c 20 77 6f 72 6b 73 20 66 6f 72 ables, works for
10d0: 20 73 71 6c 69 74 65 20 6f 6e 6c 79 20 72 69 67 sqlite only rig
10e0: 68 74 20 6e 6f 77 0a 28 64 65 66 69 6e 65 2d 6d ht now.(define-m
10f0: 65 74 68 6f 64 20 28 73 65 73 73 69 6f 6e 3a 73 ethod (session:s
1100: 65 74 75 70 2d 64 62 20 28 73 65 6c 66 20 3c 73 etup-db (self <s
1110: 65 73 73 69 6f 6e 3e 29 29 0a 20 20 28 6c 65 74 ession>)). (let
1120: 20 28 28 63 6f 6e 6e 20 28 73 6c 6f 74 2d 72 65 ((conn (slot-re
1130: 66 20 73 65 6c 66 20 27 63 6f 6e 6e 29 29 29 0a f self 'conn))).
1140: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 (for-each .
1150: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 73 74 6d (lambda (stm
1160: 74 29 0a 20 20 20 20 20 20 20 28 64 62 69 3a 65 t). (dbi:e
1170: 78 65 63 20 63 6f 6e 6e 20 73 74 6d 74 29 29 0a xec conn stmt)).
1180: 20 20 20 20 20 28 6c 69 73 74 20 22 43 52 45 41 (list "CREA
1190: 54 45 20 54 41 42 4c 45 20 73 65 73 73 69 6f 6e TE TABLE session
11a0: 5f 76 61 72 73 20 28 69 64 20 49 4e 54 45 47 45 _vars (id INTEGE
11b0: 52 20 50 52 49 4d 41 52 59 20 4b 45 59 2c 73 65 R PRIMARY KEY,se
11c0: 73 73 69 6f 6e 5f 69 64 20 49 4e 54 45 47 45 52 ssion_id INTEGER
11d0: 2c 70 61 67 65 20 54 45 58 54 2c 6b 65 79 20 54 ,page TEXT,key T
11e0: 45 58 54 2c 76 61 6c 75 65 20 54 45 58 54 29 3b EXT,value TEXT);
11f0: 22 0a 09 20 20 20 22 43 52 45 41 54 45 20 54 41 ".. "CREATE TA
1200: 42 4c 45 20 73 65 73 73 69 6f 6e 73 20 28 69 64 BLE sessions (id
1210: 20 49 4e 54 45 47 45 52 20 50 52 49 4d 41 52 59 INTEGER PRIMARY
1220: 20 4b 45 59 2c 73 65 73 73 69 6f 6e 5f 6b 65 79 KEY,session_key
1230: 20 54 45 58 54 2c 6c 61 73 74 5f 75 73 65 64 20 TEXT,last_used
1240: 54 49 4d 45 53 54 41 4d 50 29 3b 22 0a 20 20 20 TIMESTAMP);".
1250: 20 20 20 20 20 20 20 20 22 43 52 45 41 54 45 20 "CREATE
1260: 54 41 42 4c 45 20 6d 65 74 61 64 61 74 61 20 28 TABLE metadata (
1270: 69 64 20 49 4e 54 45 47 45 52 20 50 52 49 4d 41 id INTEGER PRIMA
1280: 52 59 20 4b 45 59 2c 6b 65 79 20 54 45 58 54 2c RY KEY,key TEXT,
1290: 76 61 6c 75 65 20 54 45 58 54 29 3b 22 29 29 29 value TEXT);")))
12a0: 29 0a 3b 3b 20 20 3b 3b 20 69 66 20 77 65 20 68 ).;; ;; if we h
12b0: 61 76 65 20 61 20 73 65 73 73 69 6f 6e 5f 6b 65 ave a session_ke
12c0: 79 20 6c 6f 6f 6b 20 75 70 20 74 68 65 20 73 65 y look up the se
12d0: 73 73 69 6f 6e 2d 69 64 20 61 6e 64 20 73 74 6f ssion-id and sto
12e0: 72 65 20 69 74 0a 3b 3b 20 20 28 73 6c 6f 74 2d re it.;; (slot-
12f0: 73 65 74 21 20 73 65 6c 66 20 27 73 65 73 73 69 set! self 'sessi
1300: 6f 6e 2d 69 64 20 28 73 65 73 73 69 6f 6e 3a 67 on-id (session:g
1310: 65 74 2d 69 64 20 73 65 6c 66 29 29 29 0a 0a 3b et-id self)))..;
1320: 3b 20 6f 6e 6c 79 20 73 65 74 20 73 65 73 73 69 ; only set sessi
1330: 6f 6e 2d 63 6f 6f 6b 69 65 20 77 68 65 6e 20 61 on-cookie when a
1340: 20 6e 65 77 20 73 65 73 73 69 6f 6e 20 69 73 20 new session is
1350: 63 72 65 61 74 65 64 0a 28 64 65 66 69 6e 65 2d created.(define-
1360: 6d 65 74 68 6f 64 20 28 73 65 73 73 69 6f 6e 3a method (session:
1370: 73 65 74 75 70 2d 73 65 73 73 69 6f 6e 2d 6b 65 setup-session-ke
1380: 79 20 28 73 65 6c 66 20 3c 73 65 73 73 69 6f 6e y (self <session
1390: 3e 29 29 20 20 0a 20 20 28 6c 65 74 2a 20 28 28 >)) . (let* ((
13a0: 73 6b 20 20 28 73 65 73 73 69 6f 6e 3a 65 78 74 sk (session:ext
13b0: 72 61 63 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 ract-session-key
13c0: 20 73 65 6c 66 29 29 0a 20 20 20 20 20 20 20 20 self)).
13d0: 20 28 73 69 64 20 28 69 66 20 73 6b 20 28 73 65 (sid (if sk (se
13e0: 73 73 69 6f 6e 3a 67 65 74 2d 69 64 20 73 65 6c ssion:get-id sel
13f0: 66 20 73 6b 29 20 23 66 29 29 29 0a 20 20 20 20 f sk) #f))).
1400: 28 69 66 20 28 6e 6f 74 20 73 69 64 29 20 3b 3b (if (not sid) ;;
1410: 20 6e 65 65 64 20 61 20 6e 65 77 20 6b 65 79 0a need a new key.
1420: 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 (let* ((
1430: 6e 65 77 2d 6b 65 79 20 28 73 65 73 73 69 6f 6e new-key (session
1440: 3a 67 65 74 2d 6e 65 77 2d 6b 65 79 20 73 65 6c :get-new-key sel
1450: 66 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 f)).
1460: 20 20 20 28 6e 65 77 2d 73 69 64 20 28 73 65 73 (new-sid (ses
1470: 73 69 6f 6e 3a 67 65 74 2d 69 64 20 73 65 6c 66 sion:get-id self
1480: 20 6e 65 77 2d 6b 65 79 29 29 29 0a 20 20 20 20 new-key))).
1490: 20 20 20 20 20 20 28 73 6c 6f 74 2d 73 65 74 21 (slot-set!
14a0: 20 73 65 6c 66 20 27 73 65 73 73 69 6f 6e 2d 6b self 'session-k
14b0: 65 79 20 6e 65 77 2d 6b 65 79 29 0a 20 20 20 20 ey new-key).
14c0: 20 20 20 20 20 20 28 73 6c 6f 74 2d 73 65 74 21 (slot-set!
14d0: 20 73 65 6c 66 20 27 73 65 73 73 69 6f 6e 2d 69 self 'session-i
14e0: 64 20 6e 65 77 2d 73 69 64 29 0a 20 20 20 20 20 d new-sid).
14f0: 20 20 20 20 20 28 73 6c 6f 74 2d 73 65 74 21 20 (slot-set!
1500: 73 65 6c 66 20 27 73 65 73 73 69 6f 6e 2d 63 6f self 'session-co
1510: 6f 6b 69 65 20 28 73 65 73 73 69 6f 6e 3a 6d 61 okie (session:ma
1520: 6b 65 2d 63 6f 6f 6b 69 65 20 73 65 6c 66 29 29 ke-cookie self))
1530: 29 0a 20 20 20 20 20 20 20 20 28 73 6c 6f 74 2d ). (slot-
1540: 73 65 74 21 20 73 65 6c 66 20 27 73 65 73 73 69 set! self 'sessi
1550: 6f 6e 2d 69 64 20 73 69 64 29 29 29 29 0a 0a 28 on-id sid))))..(
1560: 64 65 66 69 6e 65 2d 6d 65 74 68 6f 64 20 28 73 define-method (s
1570: 65 73 73 69 6f 6e 3a 6d 61 6b 65 2d 63 6f 6f 6b ession:make-cook
1580: 69 65 20 28 73 65 6c 66 20 3c 73 65 73 73 69 6f ie (self <sessio
1590: 6e 3e 29 29 0a 20 20 3b 3b 20 28 6c 69 73 74 20 n>)). ;; (list
15a0: 28 63 6f 6e 63 20 22 73 65 73 73 69 6f 6e 5f 6b (conc "session_k
15b0: 65 79 3d 22 20 28 73 6c 6f 74 2d 72 65 66 20 73 ey=" (slot-ref s
15c0: 65 6c 66 20 27 73 65 73 73 69 6f 6e 2d 6b 65 79 elf 'session-key
15d0: 29 20 22 3b 20 50 61 74 68 3d 2f 3b 20 44 6f 6d ) "; Path=/; Dom
15e0: 61 69 6e 3d 2e 22 20 28 73 6c 6f 74 2d 72 65 66 ain=." (slot-ref
15f0: 20 73 65 6c 66 20 27 64 6f 6d 61 69 6e 29 20 22 self 'domain) "
1600: 3b 20 4d 61 78 2d 41 67 65 3d 22 20 28 2a 20 38 ; Max-Age=" (* 8
1610: 36 34 30 30 20 31 34 29 20 22 3b 20 56 65 72 73 6400 14) "; Vers
1620: 69 6f 6e 3d 31 22 29 29 29 20 0a 20 20 28 6c 69 ion=1"))) . (li
1630: 73 74 20 28 73 74 72 69 6e 67 2d 73 75 62 73 74 st (string-subst
1640: 69 74 75 74 65 20 0a 09 20 22 3b 22 20 22 3b 20 itute .. ";" ";
1650: 22 20 0a 09 20 28 63 61 72 20 28 63 6f 6e 73 74 " .. (car (const
1660: 72 75 63 74 2d 63 6f 6f 6b 69 65 2d 73 74 72 69 ruct-cookie-stri
1670: 6e 67 20 0a 09 20 20 20 20 20 20 20 3b 3b 20 77 ng .. ;; w
1680: 61 72 6e 69 6e 67 21 20 6d 65 73 73 69 6e 67 20 arning! messing
1690: 75 70 20 74 68 69 73 20 69 74 74 79 20 62 69 74 up this itty bit
16a0: 74 79 20 62 69 74 20 6f 66 20 63 6f 64 65 20 77 ty bit of code w
16b0: 69 6c 6c 20 63 6f 73 74 20 6d 75 63 68 20 74 69 ill cost much ti
16c0: 6d 65 21 0a 09 20 20 20 20 20 20 20 60 28 28 22 me!.. `(("
16d0: 73 65 73 73 69 6f 6e 5f 6b 65 79 22 20 2c 28 73 session_key" ,(s
16e0: 6c 6f 74 2d 72 65 66 20 73 65 6c 66 20 27 73 65 lot-ref self 'se
16f0: 73 73 69 6f 6e 2d 6b 65 79 29 0a 09 09 20 20 65 ssion-key)... e
1700: 78 70 69 72 65 73 3a 20 2c 28 2b 20 28 63 75 72 xpires: ,(+ (cur
1710: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 28 2a rent-seconds) (*
1720: 20 31 34 20 38 36 34 30 30 29 29 20 0a 09 09 20 14 86400)) ...
1730: 20 6d 61 78 2d 61 67 65 3a 20 28 2a 20 31 34 20 max-age: (* 14
1740: 38 36 34 30 30 29 0a 09 09 20 20 70 61 74 68 3a 86400)... path:
1750: 20 22 2f 22 20 3b 3b 20 0a 09 09 20 20 64 6f 6d "/" ;; ... dom
1760: 61 69 6e 3a 20 2c 28 73 74 72 69 6e 67 2d 61 70 ain: ,(string-ap
1770: 70 65 6e 64 20 22 2e 22 20 28 73 6c 6f 74 2d 72 pend "." (slot-r
1780: 65 66 20 73 65 6c 66 20 27 64 6f 6d 61 69 6e 29 ef self 'domain)
1790: 29 0a 09 09 20 20 76 65 72 73 69 6f 6e 3a 20 31 )... version: 1
17a0: 29 29 20 30 29 29 29 29 29 0a 0a 3b 3b 20 6c 6f )) 0)))))..;; lo
17b0: 6f 6b 20 75 70 20 61 20 67 69 76 65 6e 20 73 65 ok up a given se
17c0: 73 73 69 6f 6e 20 6b 65 79 20 61 6e 64 20 72 65 ssion key and re
17d0: 74 75 72 6e 20 74 68 65 20 69 64 20 69 66 20 66 turn the id if f
17e0: 6f 75 6e 64 2c 20 23 66 20 69 66 20 6e 6f 74 20 ound, #f if not
17f0: 66 6f 75 6e 64 0a 28 64 65 66 69 6e 65 2d 6d 65 found.(define-me
1800: 74 68 6f 64 20 28 73 65 73 73 69 6f 6e 3a 67 65 thod (session:ge
1810: 74 2d 69 64 20 28 73 65 6c 66 20 3c 73 65 73 73 t-id (self <sess
1820: 69 6f 6e 3e 29 20 73 65 73 73 69 6f 6e 2d 6b 65 ion>) session-ke
1830: 79 29 0a 20 20 3b 3b 20 28 6c 65 74 20 28 28 73 y). ;; (let ((s
1840: 65 73 73 69 6f 6e 2d 6b 65 79 20 28 73 6c 6f 74 ession-key (slot
1850: 2d 72 65 66 20 73 65 6c 66 20 27 73 65 73 73 69 -ref self 'sessi
1860: 6f 6e 2d 6b 65 79 29 29 29 0a 20 20 28 69 66 20 on-key))). (if
1870: 73 65 73 73 69 6f 6e 2d 6b 65 79 0a 20 20 20 20 session-key.
1880: 20 20 28 6c 65 74 20 28 28 71 75 65 72 79 20 28 (let ((query (
1890: 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 22 53 string-append "S
18a0: 45 4c 45 43 54 20 69 64 20 46 52 4f 4d 20 73 65 ELECT id FROM se
18b0: 73 73 69 6f 6e 73 20 57 48 45 52 45 20 73 65 73 ssions WHERE ses
18c0: 73 69 6f 6e 5f 6b 65 79 3d 27 22 20 73 65 73 73 sion_key='" sess
18d0: 69 6f 6e 2d 6b 65 79 20 22 27 22 29 29 0a 20 20 ion-key "'")).
18e0: 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 6e 20 (conn
18f0: 28 73 6c 6f 74 2d 72 65 66 20 73 65 6c 66 20 27 (slot-ref self '
1900: 63 6f 6e 6e 29 29 0a 20 20 20 20 20 20 20 20 20 conn)).
1910: 20 20 20 28 72 65 73 75 6c 74 20 23 66 29 29 0a (result #f)).
1920: 09 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 .(dbi:for-each-r
1930: 6f 77 20 0a 09 20 28 6c 61 6d 62 64 61 20 28 74 ow .. (lambda (t
1940: 75 70 6c 65 29 0a 09 20 20 20 28 73 65 74 21 20 uple).. (set!
1950: 72 65 73 75 6c 74 20 28 76 65 63 74 6f 72 2d 72 result (vector-r
1960: 65 66 20 74 75 70 6c 65 20 30 29 29 29 0a 09 20 ef tuple 0)))..
1970: 63 6f 6e 6e 20 71 75 65 72 79 29 0a 09 28 69 66 conn query)..(if
1980: 20 72 65 73 75 6c 74 20 28 64 62 69 3a 65 78 65 result (dbi:exe
1990: 63 20 63 6f 6e 6e 20 28 63 6f 6e 63 20 22 55 50 c conn (conc "UP
19a0: 44 41 54 45 20 73 65 73 73 69 6f 6e 73 20 53 45 DATE sessions SE
19b0: 54 20 6c 61 73 74 5f 75 73 65 64 3d 22 20 28 64 T last_used=" (d
19c0: 62 69 3a 6e 6f 77 20 63 6f 6e 6e 29 20 22 20 57 bi:now conn) " W
19d0: 48 45 52 45 20 73 65 73 73 69 6f 6e 5f 6b 65 79 HERE session_key
19e0: 3d 3f 3b 22 29 20 73 65 73 73 69 6f 6e 2d 6b 65 =?;") session-ke
19f0: 79 29 29 0a 20 20 20 20 20 20 20 20 72 65 73 75 y)). resu
1a00: 6c 74 29 0a 20 20 20 20 20 20 23 66 29 29 0a 0a lt). #f))..
1a10: 3b 3b 20 0a 28 64 65 66 69 6e 65 2d 6d 65 74 68 ;; .(define-meth
1a20: 6f 64 20 28 73 65 73 73 69 6f 6e 3a 70 72 6f 63 od (session:proc
1a30: 65 73 73 2d 75 72 6c 2d 70 61 74 68 20 28 73 65 ess-url-path (se
1a40: 6c 66 20 3c 73 65 73 73 69 6f 6e 3e 29 29 0a 20 lf <session>)).
1a50: 20 28 6c 65 74 20 28 28 70 61 74 68 2d 69 6e 66 (let ((path-inf
1a60: 6f 20 20 20 20 28 67 65 74 65 6e 76 20 22 50 41 o (getenv "PA
1a70: 54 48 5f 49 4e 46 4f 22 29 29 0a 09 28 71 75 65 TH_INFO"))..(que
1a80: 72 79 2d 73 74 72 69 6e 67 20 28 67 65 74 65 6e ry-string (geten
1a90: 76 20 22 51 55 45 52 59 5f 53 54 52 49 4e 47 22 v "QUERY_STRING"
1aa0: 29 29 29 0a 20 20 20 20 3b 3b 20 28 73 65 73 73 ))). ;; (sess
1ab0: 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 70 61 ion:log self "pa
1ac0: 74 68 2d 69 6e 66 6f 3d 22 20 70 61 74 68 2d 69 th-info=" path-i
1ad0: 6e 66 6f 20 22 20 71 75 65 72 79 2d 73 74 72 69 nfo " query-stri
1ae0: 6e 67 3d 22 20 71 75 65 72 79 2d 73 74 72 69 6e ng=" query-strin
1af0: 67 29 0a 20 20 20 20 28 69 66 20 70 61 74 68 2d g). (if path-
1b00: 69 6e 66 6f 0a 09 28 6c 65 74 2a 20 28 28 70 61 info..(let* ((pa
1b10: 72 74 73 20 20 20 20 28 73 74 72 69 6e 67 2d 73 rts (string-s
1b20: 70 6c 69 74 20 70 61 74 68 2d 69 6e 66 6f 20 22 plit path-info "
1b30: 2f 22 29 29 0a 09 20 20 20 20 20 20 20 28 6e 75 /")).. (nu
1b40: 6d 70 61 72 74 73 20 28 6c 65 6e 67 74 68 20 70 mparts (length p
1b50: 61 72 74 73 29 29 29 0a 09 20 20 28 69 66 20 28 arts))).. (if (
1b60: 3e 20 6e 75 6d 70 61 72 74 73 20 30 29 0a 09 20 > numparts 0)..
1b70: 20 20 20 20 20 28 73 6c 6f 74 2d 73 65 74 21 20 (slot-set!
1b80: 73 65 6c 66 20 27 70 61 67 65 20 28 63 61 72 20 self 'page (car
1b90: 70 61 72 74 73 29 29 29 0a 09 20 20 3b 3b 20 28 parts))).. ;; (
1ba0: 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 session:log self
1bb0: 20 22 75 72 6c 2d 70 61 74 68 3d 22 20 75 72 6c "url-path=" url
1bc0: 2d 70 61 74 68 20 22 20 70 61 72 74 73 3d 22 20 -path " parts="
1bd0: 70 61 72 74 73 29 0a 09 20 20 28 69 66 20 28 3e parts).. (if (>
1be0: 20 6e 75 6d 70 61 72 74 73 20 31 29 0a 09 20 20 numparts 1)..
1bf0: 20 20 20 20 28 73 6c 6f 74 2d 73 65 74 21 20 73 (slot-set! s
1c00: 65 6c 66 20 27 70 61 74 68 2d 70 61 72 61 6d 73 elf 'path-params
1c10: 20 28 63 64 72 20 70 61 72 74 73 29 29 29 0a 20 (cdr parts))).
1c20: 20 20 20 20 20 20 20 20 20 28 69 66 20 71 75 65 (if que
1c30: 72 79 2d 73 74 72 69 6e 67 0a 20 20 20 20 20 20 ry-string.
1c40: 20 20 20 20 20 20 20 20 28 73 6c 6f 74 2d 73 65 (slot-se
1c50: 74 21 20 73 65 6c 66 20 27 70 61 72 61 6d 73 20 t! self 'params
1c60: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 71 75 (string-split qu
1c70: 65 72 79 2d 73 74 72 69 6e 67 20 22 26 22 29 29 ery-string "&"))
1c80: 29 29 29 29 29 0a 0a 3b 3b 20 42 55 47 47 59 21 )))))..;; BUGGY!
1c90: 0a 28 64 65 66 69 6e 65 2d 6d 65 74 68 6f 64 20 .(define-method
1ca0: 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 6e 65 77 (session:get-new
1cb0: 2d 6b 65 79 20 28 73 65 6c 66 20 3c 73 65 73 73 -key (self <sess
1cc0: 69 6f 6e 3e 29 29 0a 20 20 28 6c 65 74 20 28 28 ion>)). (let ((
1cd0: 63 6f 6e 6e 20 20 20 28 73 6c 6f 74 2d 72 65 66 conn (slot-ref
1ce0: 20 73 65 6c 66 20 27 63 6f 6e 6e 29 29 0a 20 20 self 'conn)).
1cf0: 20 20 20 20 20 20 28 74 6d 70 6b 65 79 20 28 73 (tmpkey (s
1d00: 65 73 73 69 6f 6e 3a 6d 61 6b 65 2d 72 61 6e 64 ession:make-rand
1d10: 2d 73 74 72 69 6e 67 20 32 30 29 29 0a 20 20 20 -string 20)).
1d20: 20 20 20 20 20 28 73 74 61 74 75 73 20 23 66 29 (status #f)
1d30: 29 0a 20 20 20 20 28 64 62 69 3a 66 6f 72 2d 65 ). (dbi:for-e
1d40: 61 63 68 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 ach-row (lambda
1d50: 28 74 75 70 6c 65 29 0a 09 09 09 28 73 65 74 21 (tuple)....(set!
1d60: 20 73 74 61 74 75 73 20 23 74 29 29 0a 09 09 20 status #t))...
1d70: 20 20 20 20 20 63 6f 6e 6e 20 28 73 74 72 69 6e conn (strin
1d80: 67 2d 61 70 70 65 6e 64 20 22 49 4e 53 45 52 54 g-append "INSERT
1d90: 20 49 4e 54 4f 20 73 65 73 73 69 6f 6e 73 20 28 INTO sessions (
1da0: 73 65 73 73 69 6f 6e 5f 6b 65 79 29 20 56 41 4c session_key) VAL
1db0: 55 45 53 20 28 27 22 20 74 6d 70 6b 65 79 20 22 UES ('" tmpkey "
1dc0: 27 29 22 29 29 0a 20 20 20 20 74 6d 70 6b 65 79 ')")). tmpkey
1dd0: 29 29 0a 0a 3b 3b 20 72 65 74 75 72 6e 73 20 73 ))..;; returns s
1de0: 65 73 73 69 6f 6e 20 6b 65 79 20 49 46 46 20 69 ession key IFF i
1df0: 74 20 69 73 20 69 6e 20 74 68 65 20 48 54 54 50 t is in the HTTP
1e00: 5f 43 4f 4f 4b 49 45 20 0a 28 64 65 66 69 6e 65 _COOKIE .(define
1e10: 2d 6d 65 74 68 6f 64 20 28 73 65 73 73 69 6f 6e -method (session
1e20: 3a 65 78 74 72 61 63 74 2d 73 65 73 73 69 6f 6e :extract-session
1e30: 2d 6b 65 79 20 28 73 65 6c 66 20 3c 73 65 73 73 -key (self <sess
1e40: 69 6f 6e 3e 29 29 0a 20 20 28 6c 65 74 20 28 28 ion>)). (let ((
1e50: 68 74 74 70 2d 73 65 73 73 69 6f 6e 20 28 67 65 http-session (ge
1e60: 74 65 6e 76 20 22 48 54 54 50 5f 43 4f 4f 4b 49 tenv "HTTP_COOKI
1e70: 45 22 29 29 29 0a 20 20 20 20 28 69 66 20 68 74 E"))). (if ht
1e80: 74 70 2d 73 65 73 73 69 6f 6e 20 0a 20 20 20 20 tp-session .
1e90: 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 65 78 74 (session:ext
1ea0: 72 61 63 74 2d 6b 65 79 2d 66 72 6f 6d 2d 70 61 ract-key-from-pa
1eb0: 72 61 6d 20 73 65 6c 66 20 28 6c 69 73 74 20 68 ram self (list h
1ec0: 74 74 70 2d 73 65 73 73 69 6f 6e 29 20 22 73 65 ttp-session) "se
1ed0: 73 73 69 6f 6e 5f 6b 65 79 22 29 0a 20 20 20 20 ssion_key").
1ee0: 20 20 20 20 23 66 29 29 29 0a 0a 28 64 65 66 69 #f)))..(defi
1ef0: 6e 65 2d 6d 65 74 68 6f 64 20 28 73 65 73 73 69 ne-method (sessi
1f00: 6f 6e 3a 67 65 74 2d 73 65 73 73 69 6f 6e 2d 69 on:get-session-i
1f10: 64 20 28 73 65 6c 66 20 3c 73 65 73 73 69 6f 6e d (self <session
1f20: 3e 29 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 0a >) session-key).
1f30: 20 20 28 6c 65 74 20 28 28 71 75 65 72 79 20 22 (let ((query "
1f40: 53 45 4c 45 43 54 20 69 64 20 46 52 4f 4d 20 73 SELECT id FROM s
1f50: 65 73 73 69 6f 6e 73 20 57 48 45 52 45 20 73 65 essions WHERE se
1f60: 73 73 69 6f 6e 5f 6b 65 79 3d 3f 3b 22 29 0a 20 ssion_key=?;").
1f70: 20 20 20 20 20 20 20 28 72 65 73 75 6c 74 20 23 (result #
1f80: 66 29 29 0a 20 20 20 20 3b 3b 20 20 20 20 20 28 f)). ;; (
1f90: 70 67 3a 71 75 65 72 79 2d 66 6f 72 2d 65 61 63 pg:query-for-eac
1fa0: 68 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 h (lambda (tuple
1fb0: 29 0a 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 ). ;;
1fc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1fd0: 20 20 28 73 65 74 21 20 72 65 73 75 6c 74 20 28 (set! result (
1fe0: 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 vector-ref tuple
1ff0: 20 30 29 29 29 20 3b 3b 20 28 76 65 63 74 6f 72 0))) ;; (vector
2000: 2d 72 65 66 20 74 75 70 6c 65 20 30 29 29 29 0a -ref tuple 0))).
2010: 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 ;;
2020: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
2030: 3a 73 71 6c 70 61 72 61 6d 20 71 75 65 72 79 20 :sqlparam query
2040: 73 65 73 73 69 6f 6e 2d 6b 65 79 29 0a 20 20 20 session-key).
2050: 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
2060: 20 20 20 20 20 20 20 20 20 20 20 28 73 6c 6f 74 (slot
2070: 2d 72 65 66 20 73 65 6c 66 20 27 63 6f 6e 6e 29 -ref self 'conn)
2080: 29 0a 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 ). ;;
2090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
20a0: 63 6f 6e 6e 29 0a 20 20 20 20 28 64 62 69 3a 66 conn). (dbi:f
20b0: 6f 72 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 6d or-each-row (lam
20c0: 62 64 61 20 28 74 75 70 6c 65 29 0a 09 09 09 28 bda (tuple)....(
20d0: 73 65 74 21 20 72 65 73 75 6c 74 20 28 76 65 63 set! result (vec
20e0: 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 30 29 tor-ref tuple 0)
20f0: 29 29 20 3b 3b 20 28 76 65 63 74 6f 72 2d 72 65 )) ;; (vector-re
2100: 66 20 74 75 70 6c 65 20 30 29 29 29 0a 09 09 20 f tuple 0)))...
2110: 20 20 20 20 20 28 73 6c 6f 74 2d 72 65 66 20 73 (slot-ref s
2120: 65 6c 66 20 27 63 6f 6e 6e 29 0a 09 09 20 20 20 elf 'conn)...
2130: 20 20 20 28 73 3a 73 71 6c 70 61 72 61 6d 20 71 (s:sqlparam q
2140: 75 65 72 79 20 73 65 73 73 69 6f 6e 2d 6b 65 79 uery session-key
2150: 29 29 0a 20 20 20 20 72 65 73 75 6c 74 29 29 0a )). result)).
2160: 0a 3b 3b 20 64 65 6c 65 74 65 20 61 6c 6c 20 72 .;; delete all r
2170: 65 63 6f 72 64 73 20 66 6f 72 20 61 20 73 65 73 ecords for a ses
2180: 73 69 6f 6e 0a 3b 3b 0a 28 64 65 66 69 6e 65 2d sion.;;.(define-
2190: 6d 65 74 68 6f 64 20 28 73 65 73 73 69 6f 6e 3a method (session:
21a0: 64 65 6c 65 74 65 2d 73 65 73 73 69 6f 6e 20 28 delete-session (
21b0: 73 65 6c 66 20 3c 73 65 73 73 69 6f 6e 3e 29 20 self <session>)
21c0: 73 65 73 73 69 6f 6e 2d 6b 65 79 29 0a 20 20 28 session-key). (
21d0: 6c 65 74 20 28 28 73 65 73 73 69 6f 6e 2d 69 64 let ((session-id
21e0: 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 73 65 (session:get-se
21f0: 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 20 73 65 ssion-id self se
2200: 73 73 69 6f 6e 2d 6b 65 79 29 29 0a 20 20 20 20 ssion-key)).
2210: 20 20 20 20 28 71 72 79 20 20 20 20 20 20 20 20 (qry
2220: 28 63 6f 6e 63 20 22 42 45 47 49 4e 3b 22 0a 09 (conc "BEGIN;"..
2230: 09 09 20 20 22 44 45 4c 45 54 45 20 46 52 4f 4d .. "DELETE FROM
2240: 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 57 48 session_vars WH
2250: 45 52 45 20 73 65 73 73 69 6f 6e 5f 69 64 3d 3f ERE session_id=?
2260: 3b 22 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ;".
2270: 20 20 20 20 20 20 20 20 20 20 20 20 20 22 44 45 "DE
2280: 4c 45 54 45 20 46 52 4f 4d 20 73 65 73 73 69 6f LETE FROM sessio
2290: 6e 73 20 57 48 45 52 45 20 69 64 3d 3f 3b 22 0a ns WHERE id=?;".
22a0: 09 09 09 20 20 22 43 4f 4d 4d 49 54 3b 22 29 29 ... "COMMIT;"))
22b0: 0a 20 20 20 20 20 20 20 20 28 63 6f 6e 6e 20 20 . (conn
22c0: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 6c 6f (slo
22d0: 74 2d 72 65 66 20 73 65 6c 66 20 27 63 6f 6e 6e t-ref self 'conn
22e0: 29 29 29 0a 20 20 20 20 28 69 66 20 73 65 73 73 ))). (if sess
22f0: 69 6f 6e 2d 69 64 0a 20 20 20 20 20 20 20 20 28 ion-id. (
2300: 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 begin.
2310: 28 64 62 69 3a 65 78 65 63 20 63 6f 6e 6e 20 71 (dbi:exec conn q
2320: 72 79 20 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 ry session-id se
2330: 73 73 69 6f 6e 2d 69 64 29 0a 09 20 20 28 69 6e ssion-id).. (in
2340: 69 74 69 61 6c 69 7a 65 20 73 65 6c 66 20 27 28 itialize self '(
2350: 29 29 0a 09 20 20 28 73 65 73 73 69 6f 6e 3a 73 )).. (session:s
2360: 65 74 75 70 20 73 65 6c 66 29 29 29 0a 20 20 20 etup self))).
2370: 20 28 6e 6f 74 20 28 73 65 73 73 69 6f 6e 3a 67 (not (session:g
2380: 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 et-session-id se
2390: 6c 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 lf session-key))
23a0: 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 2d 6d ))..;; (define-m
23b0: 65 74 68 6f 64 20 28 73 65 73 73 69 6f 6e 3a 64 ethod (session:d
23c0: 65 6c 65 74 65 2d 73 65 73 73 69 6f 6e 20 28 73 elete-session (s
23d0: 65 6c 66 20 3c 73 65 73 73 69 6f 6e 3e 29 20 73 elf <session>) s
23e0: 65 73 73 69 6f 6e 2d 6b 65 79 29 0a 3b 3b 20 20 ession-key).;;
23f0: 20 28 6c 65 74 20 28 28 73 65 73 73 69 6f 6e 2d (let ((session-
2400: 69 64 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d id (session:get-
2410: 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 20 session-id self
2420: 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 0a 3b 3b session-key)).;;
2430: 20 20 20 20 20 20 20 20 20 28 71 75 65 72 69 65 (querie
2440: 73 20 20 20 20 28 6c 69 73 74 20 22 42 45 47 49 s (list "BEGI
2450: 4e 3b 22 0a 3b 3b 20 09 09 09 20 20 22 44 45 4c N;".;; ... "DEL
2460: 45 54 45 20 46 52 4f 4d 20 73 65 73 73 69 6f 6e ETE FROM session
2470: 5f 76 61 72 73 20 57 48 45 52 45 20 73 65 73 73 _vars WHERE sess
2480: 69 6f 6e 5f 69 64 3d 3f 3b 22 0a 3b 3b 20 20 20 ion_id=?;".;;
2490: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
24a0: 20 20 20 20 20 20 20 20 22 44 45 4c 45 54 45 20 "DELETE
24b0: 46 52 4f 4d 20 73 65 73 73 69 6f 6e 73 20 57 48 FROM sessions WH
24c0: 45 52 45 20 69 64 3d 3f 3b 22 0a 3b 3b 20 09 09 ERE id=?;".;; ..
24d0: 09 20 20 22 43 4f 4d 4d 49 54 3b 22 29 29 0a 3b . "COMMIT;")).;
24e0: 3b 20 20 20 20 20 20 20 20 20 28 63 6f 6e 6e 20 ; (conn
24f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 6c (sl
2500: 6f 74 2d 72 65 66 20 73 65 6c 66 20 27 63 6f 6e ot-ref self 'con
2510: 6e 29 29 29 0a 3b 3b 20 20 20 20 20 28 69 66 20 n))).;; (if
2520: 73 65 73 73 69 6f 6e 2d 69 64 0a 3b 3b 20 20 20 session-id.;;
2530: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 3b 3b 20 (begin.;;
2540: 20 20 20 20 20 20 20 20 20 20 28 66 6f 72 2d 65 (for-e
2550: 61 63 68 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 ach.;;
2560: 20 20 28 6c 61 6d 62 64 61 20 28 71 75 65 72 79 (lambda (query
2570: 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 ).;;
2580: 20 20 28 64 62 69 3a 65 78 65 63 20 63 6f 6e 6e (dbi:exec conn
2590: 20 71 75 65 72 79 20 73 65 73 73 69 6f 6e 2d 69 query session-i
25a0: 64 29 29 0a 3b 3b 20 09 20 20 20 71 75 65 72 69 d)).;; . queri
25b0: 65 73 29 0a 3b 3b 20 09 20 20 28 69 6e 69 74 69 es).;; . (initi
25c0: 61 6c 69 7a 65 20 73 65 6c 66 20 27 28 29 29 0a alize self '()).
25d0: 3b 3b 20 09 20 20 28 73 65 73 73 69 6f 6e 3a 73 ;; . (session:s
25e0: 65 74 75 70 20 73 65 6c 66 29 29 29 0a 3b 3b 20 etup self))).;;
25f0: 20 20 20 20 28 6e 6f 74 20 28 73 65 73 73 69 6f (not (sessio
2600: 6e 3a 67 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 n:get-session-id
2610: 20 73 65 6c 66 20 73 65 73 73 69 6f 6e 2d 6b 65 self session-ke
2620: 79 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 2d 6d y))))..(define-m
2630: 65 74 68 6f 64 20 28 73 65 73 73 69 6f 6e 3a 65 ethod (session:e
2640: 78 74 72 61 63 74 2d 6b 65 79 20 28 73 65 6c 66 xtract-key (self
2650: 20 3c 73 65 73 73 69 6f 6e 3e 29 20 6b 65 79 29 <session>) key)
2660: 0a 20 20 28 6c 65 74 20 28 28 70 61 72 61 6d 73 . (let ((params
2670: 20 28 73 6c 6f 74 2d 72 65 66 20 73 65 6c 66 20 (slot-ref self
2680: 27 70 61 72 61 6d 73 29 29 29 0a 20 20 20 20 28 'params))). (
2690: 73 65 73 73 69 6f 6e 3a 65 78 74 72 61 63 74 2d session:extract-
26a0: 6b 65 79 2d 66 72 6f 6d 2d 70 61 72 61 6d 20 73 key-from-param s
26b0: 65 6c 66 20 70 61 72 61 6d 73 20 6b 65 79 29 29 elf params key))
26c0: 29 0a 0a 28 64 65 66 69 6e 65 2d 6d 65 74 68 6f )..(define-metho
26d0: 64 20 28 73 65 73 73 69 6f 6e 3a 65 78 74 72 61 d (session:extra
26e0: 63 74 2d 6b 65 79 2d 66 72 6f 6d 2d 70 61 72 61 ct-key-from-para
26f0: 6d 20 28 73 65 6c 66 20 3c 73 65 73 73 69 6f 6e m (self <session
2700: 3e 29 20 70 61 72 61 6d 73 20 6b 65 79 29 0a 20 >) params key).
2710: 20 28 6c 65 74 20 28 28 72 31 20 20 20 20 20 28 (let ((r1 (
2720: 72 65 67 65 78 70 20 28 73 74 72 69 6e 67 2d 61 regexp (string-a
2730: 70 70 65 6e 64 20 22 5e 22 20 6b 65 79 20 22 3d ppend "^" key "=
2740: 28 5b 5e 3d 5d 2b 29 24 22 29 29 29 29 0a 20 20 ([^=]+)$")))).
2750: 20 20 28 69 66 20 28 3c 20 28 6c 65 6e 67 74 68 (if (< (length
2760: 20 70 61 72 61 6d 73 29 20 31 29 20 23 66 0a 09 params) 1) #f..
2770: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 61 64 (let loop ((head
2780: 20 20 20 28 63 61 72 20 70 61 72 61 6d 73 29 29 (car params))
2790: 0a 09 09 20 20 20 28 74 61 69 6c 20 20 20 28 63 ... (tail (c
27a0: 64 72 20 70 61 72 61 6d 73 29 29 29 0a 09 20 20 dr params)))..
27b0: 28 6c 65 74 20 28 28 6d 61 74 63 68 20 28 73 74 (let ((match (st
27c0: 72 69 6e 67 2d 6d 61 74 63 68 20 72 31 20 68 65 ring-match r1 he
27d0: 61 64 29 29 29 0a 09 20 20 20 20 28 63 6f 6e 64 ad))).. (cond
27e0: 0a 09 20 20 20 20 20 28 6d 61 74 63 68 0a 09 20 .. (match..
27f0: 20 20 20 20 20 28 6c 65 74 20 28 28 73 65 73 73 (let ((sess
2800: 69 6f 6e 2d 6b 65 79 20 28 6c 69 73 74 2d 72 65 ion-key (list-re
2810: 66 20 6d 61 74 63 68 20 31 29 29 29 0a 09 09 28 f match 1)))...(
2820: 73 6c 6f 74 2d 73 65 74 21 20 73 65 6c 66 20 27 slot-set! self '
2830: 73 65 73 73 69 6f 6e 2d 6b 65 79 20 28 6c 69 73 session-key (lis
2840: 74 2d 72 65 66 20 6d 61 74 63 68 20 31 29 29 0a t-ref match 1)).
2850: 09 09 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 0a ..session-key)).
2860: 09 20 20 20 20 20 28 28 6e 75 6c 6c 3f 20 74 61 . ((null? ta
2870: 69 6c 29 0a 09 20 20 20 20 20 20 23 66 29 0a 09 il).. #f)..
2880: 20 20 20 20 20 28 65 6c 73 65 0a 09 20 20 20 20 (else..
2890: 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 69 (loop (car tai
28a0: 6c 29 0a 09 09 20 20 20 20 28 63 64 72 20 74 61 l)... (cdr ta
28b0: 69 6c 29 29 29 29 29 29 29 29 29 0a 0a 28 64 65 il)))))))))..(de
28c0: 66 69 6e 65 2d 6d 65 74 68 6f 64 20 28 73 65 73 fine-method (ses
28d0: 73 69 6f 6e 3a 73 65 74 2d 70 61 67 65 21 20 28 sion:set-page! (
28e0: 73 65 6c 66 20 3c 73 65 73 73 69 6f 6e 3e 29 20 self <session>)
28f0: 70 61 67 65 5f 6e 61 6d 65 29 0a 20 20 28 73 6c page_name). (sl
2900: 6f 74 2d 73 65 74 21 20 73 65 6c 66 20 27 70 61 ot-set! self 'pa
2910: 67 65 20 70 61 67 65 5f 6e 61 6d 65 29 29 0a 0a ge page_name))..
2920: 28 64 65 66 69 6e 65 2d 6d 65 74 68 6f 64 20 28 (define-method (
2930: 73 65 73 73 69 6f 6e 3a 63 6c 6f 73 65 20 28 73 session:close (s
2940: 65 6c 66 20 3c 73 65 73 73 69 6f 6e 3e 29 29 0a elf <session>)).
2950: 20 20 28 64 62 69 3a 63 6c 6f 73 65 20 28 73 6c (dbi:close (sl
2960: 6f 74 2d 72 65 66 20 73 65 6c 66 20 27 63 6f 6e ot-ref self 'con
2970: 6e 29 29 29 0a 3b 3b 20 28 63 6c 6f 73 65 2d 6f n))).;; (close-o
2980: 75 74 70 75 74 2d 70 6f 72 74 20 28 73 6c 6f 74 utput-port (slot
2990: 2d 72 65 66 20 73 65 6c 66 20 27 6c 6f 67 70 74 -ref self 'logpt
29a0: 29 29 0a 0a 28 64 65 66 69 6e 65 2d 6d 65 74 68 ))..(define-meth
29b0: 6f 64 20 28 73 65 73 73 69 6f 6e 3a 65 72 72 2d od (session:err-
29c0: 6d 73 67 20 28 73 65 6c 66 20 3c 73 65 73 73 69 msg (self <sessi
29d0: 6f 6e 3e 29 20 6d 73 67 29 0a 20 20 28 68 61 73 on>) msg). (has
29e0: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 28 73 6c h-table-set! (sl
29f0: 6f 74 2d 72 65 66 20 73 65 6c 66 20 27 73 65 73 ot-ref self 'ses
2a00: 73 69 6f 6e 76 61 72 73 29 20 22 45 52 52 4f 52 sionvars) "ERROR
2a10: 5f 4d 53 47 22 0a 09 09 20 20 20 28 73 74 72 69 _MSG"... (stri
2a20: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 ng-intersperse (
2a30: 6d 61 70 20 73 3a 61 6e 79 2d 3e 73 74 72 69 6e map s:any->strin
2a40: 67 20 6d 73 67 29 20 22 20 22 29 29 29 0a 0a 28 g msg) " ")))..(
2a50: 64 65 66 69 6e 65 2d 6d 65 74 68 6f 64 20 28 73 define-method (s
2a60: 65 73 73 69 6f 6e 3a 70 72 65 76 2d 65 72 72 20 ession:prev-err
2a70: 28 73 65 6c 66 20 3c 73 65 73 73 69 6f 6e 3e 29 (self <session>)
2a80: 29 0a 20 20 28 6c 65 74 20 28 28 70 72 65 76 2d ). (let ((prev-
2a90: 65 72 72 20 28 68 61 73 68 2d 74 61 62 6c 65 2d err (hash-table-
2aa0: 72 65 66 2f 64 65 66 61 75 6c 74 20 28 73 6c 6f ref/default (slo
2ab0: 74 2d 72 65 66 20 73 65 6c 66 20 27 73 65 73 73 t-ref self 'sess
2ac0: 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 29 20 ionvars-before)
2ad0: 22 45 52 52 4f 52 5f 4d 53 47 22 20 23 66 29 29 "ERROR_MSG" #f))
2ae0: 0a 09 28 63 75 72 72 2d 65 72 72 20 28 68 61 73 ..(curr-err (has
2af0: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
2b00: 75 6c 74 20 28 73 6c 6f 74 2d 72 65 66 20 73 65 ult (slot-ref se
2b10: 6c 66 20 27 73 65 73 73 69 6f 6e 76 61 72 73 29 lf 'sessionvars)
2b20: 20 22 45 52 52 4f 52 5f 4d 53 47 22 20 23 66 29 "ERROR_MSG" #f)
2b30: 29 29 0a 20 20 20 20 28 69 66 20 70 72 65 76 2d )). (if prev-
2b40: 65 72 72 20 70 72 65 76 2d 65 72 72 0a 09 28 69 err prev-err..(i
2b50: 66 20 63 75 72 72 2d 65 72 72 20 63 75 72 72 2d f curr-err curr-
2b60: 65 72 72 20 23 66 29 29 29 29 0a 0a 3b 3b 20 73 err #f))))..;; s
2b70: 65 73 73 69 6f 6e 20 76 61 72 73 0a 3b 3b 20 31 ession vars.;; 1
2b80: 2e 20 6b 65 79 73 20 61 72 65 20 61 6c 77 61 79 . keys are alway
2b90: 73 20 61 20 73 74 72 69 6e 67 20 4e 4f 54 20 61 s a string NOT a
2ba0: 20 73 79 6d 62 6f 6c 0a 3b 3b 20 32 2e 20 76 61 symbol.;; 2. va
2bb0: 6c 75 65 73 20 61 72 65 20 61 6c 77 61 79 73 20 lues are always
2bc0: 61 20 73 74 72 69 6e 67 20 63 6f 6e 76 65 72 73 a string convers
2bd0: 69 6f 6e 20 69 73 20 74 68 65 20 72 65 73 70 6f ion is the respo
2be0: 6e 73 69 62 69 6c 69 74 79 20 6f 66 20 74 68 65 nsibility of the
2bf0: 20 0a 3b 3b 20 20 20 20 63 6f 6e 73 75 6d 69 6e .;; consumin
2c00: 67 20 66 75 6e 63 74 69 6f 6e 20 28 61 74 20 6c g function (at l
2c10: 65 61 73 74 20 66 6f 72 20 6e 6f 77 2c 20 49 27 east for now, I'
2c20: 64 20 6c 69 6b 65 20 74 6f 20 63 68 61 6e 67 65 d like to change
2c30: 20 74 68 69 73 29 0a 0a 3b 3b 20 73 65 74 20 61 this)..;; set a
2c40: 20 73 65 73 73 69 6f 6e 20 76 61 72 20 66 6f 72 session var for
2c50: 20 74 68 65 20 63 75 72 72 65 6e 74 20 70 61 67 the current pag
2c60: 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 2d 6d 65 74 e.;;.(define-met
2c70: 68 6f 64 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 hod (session:set
2c80: 21 20 28 73 65 6c 66 20 3c 73 65 73 73 69 6f 6e ! (self <session
2c90: 3e 29 20 6b 65 79 20 76 61 6c 75 65 29 0a 20 20 >) key value).
2ca0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
2cb0: 20 28 73 6c 6f 74 2d 72 65 66 20 73 65 6c 66 20 (slot-ref self
2cc0: 27 70 61 67 65 76 61 72 73 29 20 28 73 3a 61 6e 'pagevars) (s:an
2cd0: 79 2d 3e 73 74 72 69 6e 67 20 6b 65 79 29 20 28 y->string key) (
2ce0: 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 76 61 s:any->string va
2cf0: 6c 75 65 29 29 29 0a 0a 3b 3b 20 64 65 6c 20 61 lue)))..;; del a
2d00: 20 76 61 72 20 66 6f 72 20 74 68 65 20 63 75 72 var for the cur
2d10: 72 65 6e 74 20 70 61 67 65 0a 3b 3b 0a 28 64 65 rent page.;;.(de
2d20: 66 69 6e 65 2d 6d 65 74 68 6f 64 20 28 73 65 73 fine-method (ses
2d30: 73 69 6f 6e 3a 64 65 6c 21 20 28 73 65 6c 66 20 sion:del! (self
2d40: 3c 73 65 73 73 69 6f 6e 3e 29 20 6b 65 79 29 0a <session>) key).
2d50: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 64 65 (hash-table-de
2d60: 6c 65 74 65 21 20 28 73 6c 6f 74 2d 72 65 66 20 lete! (slot-ref
2d70: 73 65 6c 66 20 27 70 61 67 65 76 61 72 73 29 20 self 'pagevars)
2d80: 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6b (s:any->string k
2d90: 65 79 29 29 29 0a 0a 3b 3b 20 67 65 74 20 74 68 ey)))..;; get th
2da0: 65 20 61 70 70 72 6f 70 72 69 61 74 65 20 68 61 e appropriate ha
2db0: 73 68 20 67 69 76 65 6e 20 61 20 70 61 67 65 20 sh given a page
2dc0: 22 2a 73 65 73 73 69 6f 6e 76 61 72 73 2a 2c 20 "*sessionvars*,
2dd0: 2a 67 6c 6f 62 61 6c 76 61 72 73 2a 20 6f 72 20 *globalvars* or
2de0: 70 61 67 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 2d page.;;.(define-
2df0: 6d 65 74 68 6f 64 20 28 73 65 73 73 69 6f 6e 3a method (session:
2e00: 67 65 74 2d 70 61 67 65 2d 68 61 73 68 20 28 73 get-page-hash (s
2e10: 65 6c 66 20 3c 73 65 73 73 69 6f 6e 3e 29 20 70 elf <session>) p
2e20: 61 67 65 29 0a 20 20 28 69 66 20 28 73 74 72 69 age). (if (stri
2e30: 6e 67 3d 3f 20 70 61 67 65 20 22 2a 73 65 73 73 ng=? page "*sess
2e40: 69 6f 6e 76 61 72 73 2a 22 29 0a 20 20 20 20 20 ionvars*").
2e50: 20 28 73 6c 6f 74 2d 72 65 66 20 73 65 6c 66 20 (slot-ref self
2e60: 27 73 65 73 73 69 6f 6e 76 61 72 73 29 0a 20 20 'sessionvars).
2e70: 20 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 3d (if (string=
2e80: 3f 20 70 61 67 65 20 22 2a 67 6c 6f 62 61 6c 76 ? page "*globalv
2e90: 61 72 73 2a 22 29 0a 09 20 20 28 73 6c 6f 74 2d ars*").. (slot-
2ea0: 72 65 66 20 73 65 6c 66 20 27 67 6c 6f 62 61 6c ref self 'global
2eb0: 76 61 72 73 29 0a 09 20 20 28 73 6c 6f 74 2d 72 vars).. (slot-r
2ec0: 65 66 20 73 65 6c 66 20 27 70 61 67 65 76 61 72 ef self 'pagevar
2ed0: 73 29 29 29 29 0a 0a 3b 3b 20 73 65 74 20 61 20 s))))..;; set a
2ee0: 73 65 73 73 69 6f 6e 20 76 61 72 20 66 6f 72 20 session var for
2ef0: 61 20 67 69 76 65 6e 20 70 61 67 65 0a 3b 3b 0a a given page.;;.
2f00: 28 64 65 66 69 6e 65 2d 6d 65 74 68 6f 64 20 28 (define-method (
2f10: 73 65 73 73 69 6f 6e 3a 73 65 74 21 20 28 73 65 session:set! (se
2f20: 6c 66 20 3c 73 65 73 73 69 6f 6e 3e 29 20 70 61 lf <session>) pa
2f30: 67 65 20 6b 65 79 20 76 61 6c 75 65 29 0a 20 20 ge key value).
2f40: 28 6c 65 74 20 28 28 68 74 20 28 73 65 73 73 69 (let ((ht (sessi
2f50: 6f 6e 3a 67 65 74 2d 70 61 67 65 2d 68 61 73 68 on:get-page-hash
2f60: 20 73 65 6c 66 20 70 61 67 65 29 29 29 0a 20 20 self page))).
2f70: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
2f80: 74 21 20 68 74 20 28 73 3a 61 6e 79 2d 3e 73 74 t! ht (s:any->st
2f90: 72 69 6e 67 20 6b 65 79 29 20 28 73 3a 61 6e 79 ring key) (s:any
2fa0: 2d 3e 73 74 72 69 6e 67 20 76 61 6c 75 65 29 29 ->string value))
2fb0: 29 29 0a 0a 3b 3b 20 67 65 74 20 73 65 73 73 69 ))..;; get sessi
2fc0: 6f 6e 20 76 61 72 73 20 66 6f 72 20 74 68 65 20 on vars for the
2fd0: 63 75 72 72 65 6e 74 20 70 61 67 65 0a 3b 3b 0a current page.;;.
2fe0: 28 64 65 66 69 6e 65 2d 6d 65 74 68 6f 64 20 28 (define-method (
2ff0: 73 65 73 73 69 6f 6e 3a 67 65 74 20 28 73 65 6c session:get (sel
3000: 66 20 3c 73 65 73 73 69 6f 6e 3e 29 20 6b 65 79 f <session>) key
3010: 29 0a 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ). (hash-table-
3020: 72 65 66 2f 64 65 66 61 75 6c 74 20 28 73 6c 6f ref/default (slo
3030: 74 2d 72 65 66 20 73 65 6c 66 20 27 70 61 67 65 t-ref self 'page
3040: 76 61 72 73 29 20 6b 65 79 20 23 66 29 29 0a 0a vars) key #f))..
3050: 3b 3b 20 67 65 74 20 73 65 73 73 69 6f 6e 20 76 ;; get session v
3060: 61 72 73 20 66 6f 72 20 61 20 73 70 65 63 69 66 ars for a specif
3070: 69 65 64 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 ied page.;;.(def
3080: 69 6e 65 2d 6d 65 74 68 6f 64 20 28 73 65 73 73 ine-method (sess
3090: 69 6f 6e 3a 67 65 74 20 28 73 65 6c 66 20 3c 73 ion:get (self <s
30a0: 65 73 73 69 6f 6e 3e 29 20 70 61 67 65 20 6b 65 ession>) page ke
30b0: 79 29 0a 20 20 28 6c 65 74 20 28 28 68 74 20 28 y). (let ((ht (
30c0: 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 67 65 session:get-page
30d0: 2d 68 61 73 68 20 73 65 6c 66 20 70 61 67 65 29 -hash self page)
30e0: 29 29 0a 20 20 20 20 28 68 61 73 68 2d 74 61 62 )). (hash-tab
30f0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 68 le-ref/default h
3100: 74 20 6b 65 79 20 23 66 29 29 29 0a 0a 3b 3b 20 t key #f)))..;;
3110: 64 65 6c 65 74 65 20 61 20 73 65 73 73 69 6f 6e delete a session
3120: 20 76 61 72 20 66 6f 72 20 61 20 73 70 65 63 69 var for a speci
3130: 66 69 65 64 20 70 61 67 65 0a 3b 3b 0a 28 64 65 fied page.;;.(de
3140: 66 69 6e 65 2d 6d 65 74 68 6f 64 20 28 73 65 73 fine-method (ses
3150: 73 69 6f 6e 3a 64 65 6c 21 20 28 73 65 6c 66 20 sion:del! (self
3160: 3c 73 65 73 73 69 6f 6e 3e 29 20 70 61 67 65 20 <session>) page
3170: 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 28 68 74 key). (let ((ht
3180: 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 (session:get-pa
3190: 67 65 2d 68 61 73 68 20 73 65 6c 66 20 70 61 67 ge-hash self pag
31a0: 65 29 29 29 0a 20 20 20 20 28 68 61 73 68 2d 74 e))). (hash-t
31b0: 61 62 6c 65 2d 64 65 6c 65 74 65 21 20 68 74 20 able-delete! ht
31c0: 6b 65 79 29 29 29 0a 0a 3b 3b 20 67 65 74 20 41 key)))..;; get A
31d0: 4c 4c 20 6b 65 79 73 20 66 6f 72 20 74 68 69 73 LL keys for this
31e0: 20 70 61 67 65 20 61 6e 64 20 73 74 6f 72 65 20 page and store
31f0: 69 6e 20 74 68 65 20 73 65 73 73 69 6f 6e 20 70 in the session p
3200: 61 67 65 76 61 72 73 20 68 61 73 68 0a 3b 3b 0a agevars hash.;;.
3210: 28 64 65 66 69 6e 65 2d 6d 65 74 68 6f 64 20 28 (define-method (
3220: 73 65 73 73 69 6f 6e 3a 67 65 74 2d 76 61 72 73 session:get-vars
3230: 20 28 73 65 6c 66 20 3c 73 65 73 73 69 6f 6e 3e (self <session>
3240: 29 29 0a 20 20 28 6c 65 74 20 28 28 73 65 73 73 )). (let ((sess
3250: 69 6f 6e 2d 69 64 20 20 28 73 6c 6f 74 2d 72 65 ion-id (slot-re
3260: 66 20 73 65 6c 66 20 27 73 65 73 73 69 6f 6e 2d f self 'session-
3270: 69 64 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e id))). (if (n
3280: 6f 74 20 73 65 73 73 69 6f 6e 2d 69 64 29 0a 09 ot session-id)..
3290: 28 65 72 72 3a 6c 6f 67 20 22 45 52 52 4f 52 3a (err:log "ERROR:
32a0: 20 4e 6f 20 73 65 73 73 69 6f 6e 20 69 64 20 69 No session id i
32b0: 6e 20 73 65 73 73 69 6f 6e 20 6f 62 6a 65 63 74 n session object
32c0: 21 20 73 65 73 73 69 6f 6e 3a 67 65 74 2d 76 61 ! session:get-va
32d0: 72 73 22 29 0a 09 28 6c 65 74 2a 20 28 28 72 65 rs")..(let* ((re
32e0: 73 75 6c 74 20 20 20 20 20 20 20 20 20 20 20 20 sult
32f0: 20 23 66 29 0a 09 20 20 20 20 20 20 20 28 63 6f #f).. (co
3300: 6e 6e 20 20 20 20 20 20 20 20 20 20 20 20 20 20 nn
3310: 20 28 73 6c 6f 74 2d 72 65 66 20 73 65 6c 66 20 (slot-ref self
3320: 27 63 6f 6e 6e 29 29 0a 09 20 20 20 20 20 20 20 'conn))..
3330: 28 70 61 67 65 76 61 72 73 2d 62 65 66 6f 72 65 (pagevars-before
3340: 20 20 20 20 28 73 6c 6f 74 2d 72 65 66 20 73 65 (slot-ref se
3350: 6c 66 20 27 70 61 67 65 76 61 72 73 2d 62 65 66 lf 'pagevars-bef
3360: 6f 72 65 29 29 0a 09 20 20 20 20 20 20 20 28 73 ore)).. (s
3370: 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 essionvars-befor
3380: 65 20 28 73 6c 6f 74 2d 72 65 66 20 73 65 6c 66 e (slot-ref self
3390: 20 27 73 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 'sessionvars-be
33a0: 66 6f 72 65 29 29 0a 09 20 20 20 20 20 20 20 28 fore)).. (
33b0: 67 6c 6f 62 61 6c 76 61 72 73 2d 62 65 66 6f 72 globalvars-befor
33c0: 65 20 20 28 73 6c 6f 74 2d 72 65 66 20 73 65 6c e (slot-ref sel
33d0: 66 20 27 67 6c 6f 62 61 6c 76 61 72 73 2d 62 65 f 'globalvars-be
33e0: 66 6f 72 65 29 29 0a 09 20 20 20 20 20 20 20 28 fore)).. (
33f0: 70 61 67 65 76 61 72 73 20 20 20 20 20 20 20 20 pagevars
3400: 20 20 20 28 73 6c 6f 74 2d 72 65 66 20 73 65 6c (slot-ref sel
3410: 66 20 27 70 61 67 65 76 61 72 73 29 29 0a 09 20 f 'pagevars))..
3420: 20 20 20 20 20 20 28 73 65 73 73 69 6f 6e 76 61 (sessionva
3430: 72 73 20 20 20 20 20 20 20 20 28 73 6c 6f 74 2d rs (slot-
3440: 72 65 66 20 73 65 6c 66 20 27 73 65 73 73 69 6f ref self 'sessio
3450: 6e 76 61 72 73 29 29 0a 09 20 20 20 20 20 20 20 nvars))..
3460: 28 67 6c 6f 62 61 6c 76 61 72 73 20 20 20 20 20 (globalvars
3470: 20 20 20 20 28 73 6c 6f 74 2d 72 65 66 20 73 65 (slot-ref se
3480: 6c 66 20 27 67 6c 6f 62 61 6c 76 61 72 73 29 29 lf 'globalvars))
3490: 0a 09 20 20 20 20 20 20 20 28 70 61 67 65 2d 6e .. (page-n
34a0: 61 6d 65 20 20 20 20 20 20 20 20 20 20 28 73 6c ame (sl
34b0: 6f 74 2d 72 65 66 20 73 65 6c 66 20 27 70 61 67 ot-ref self 'pag
34c0: 65 29 29 0a 09 20 20 20 20 20 20 20 28 73 65 73 e)).. (ses
34d0: 73 69 6f 6e 2d 6b 65 79 20 20 20 20 20 20 20 20 sion-key
34e0: 28 73 6c 6f 74 2d 72 65 66 20 73 65 6c 66 20 27 (slot-ref self '
34f0: 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 0a 09 20 session-key))..
3500: 20 20 20 20 20 20 28 71 75 65 72 79 20 20 20 20 (query
3510: 20 20 20 20 20 20 20 20 20 20 28 73 74 72 69 6e (strin
3520: 67 2d 61 70 70 65 6e 64 0a 09 09 09 09 20 20 20 g-append.....
3530: 20 22 53 45 4c 45 43 54 20 6b 65 79 2c 76 61 6c "SELECT key,val
3540: 75 65 20 46 52 4f 4d 20 73 65 73 73 69 6f 6e 5f ue FROM session_
3550: 76 61 72 73 20 49 4e 4e 45 52 20 4a 4f 49 4e 20 vars INNER JOIN
3560: 73 65 73 73 69 6f 6e 73 20 4f 4e 20 73 65 73 73 sessions ON sess
3570: 69 6f 6e 5f 76 61 72 73 2e 73 65 73 73 69 6f 6e ion_vars.session
3580: 5f 69 64 3d 73 65 73 73 69 6f 6e 73 2e 69 64 20 _id=sessions.id
3590: 22 0a 09 09 09 09 20 20 20 20 22 57 48 45 52 45 "..... "WHERE
35a0: 20 73 65 73 73 69 6f 6e 5f 6b 65 79 3d 3f 20 41 session_key=? A
35b0: 4e 44 20 70 61 67 65 3d 3f 3b 22 29 29 29 0a 09 ND page=?;")))..
35c0: 20 20 3b 3b 20 66 69 72 73 74 20 74 68 65 20 70 ;; first the p
35d0: 61 67 65 20 73 70 65 63 69 66 69 63 20 76 61 72 age specific var
35e0: 73 0a 09 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 s.. (dbi:for-ea
35f0: 63 68 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 ch-row (lambda (
3600: 74 75 70 6c 65 29 0a 09 09 09 20 20 20 20 20 20 tuple)....
3610: 28 6c 65 74 20 28 28 6b 20 28 76 65 63 74 6f 72 (let ((k (vector
3620: 2d 72 65 66 20 74 75 70 6c 65 20 30 29 29 0a 09 -ref tuple 0))..
3630: 09 09 09 20 20 20 20 28 76 20 28 76 65 63 74 6f ... (v (vecto
3640: 72 2d 72 65 66 20 74 75 70 6c 65 20 31 29 29 29 r-ref tuple 1)))
3650: 0a 09 09 09 09 28 68 61 73 68 2d 74 61 62 6c 65 .....(hash-table
3660: 2d 73 65 74 21 20 70 61 67 65 76 61 72 73 2d 62 -set! pagevars-b
3670: 65 66 6f 72 65 20 6b 20 76 29 0a 09 09 09 09 28 efore k v).....(
3680: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
3690: 70 61 67 65 76 61 72 73 20 20 20 20 20 20 20 20 pagevars
36a0: 6b 20 76 29 29 29 0a 09 09 09 20 20 20 20 63 6f k v))).... co
36b0: 6e 6e 0a 09 09 09 20 20 20 20 28 73 3a 73 71 6c nn.... (s:sql
36c0: 70 61 72 61 6d 20 71 75 65 72 79 20 73 65 73 73 param query sess
36d0: 69 6f 6e 2d 6b 65 79 20 70 61 67 65 2d 6e 61 6d ion-key page-nam
36e0: 65 29 29 0a 09 20 20 3b 3b 20 74 68 65 6e 20 74 e)).. ;; then t
36f0: 68 65 20 73 65 73 73 69 6f 6e 20 73 70 65 63 69 he session speci
3700: 66 69 63 20 76 61 72 73 0a 09 20 20 28 64 62 69 fic vars.. (dbi
3710: 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 28 6c :for-each-row (l
3720: 61 6d 62 64 61 20 28 74 75 70 6c 65 29 0a 09 09 ambda (tuple)...
3730: 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 6b 20 . (let ((k
3740: 28 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c (vector-ref tupl
3750: 65 20 30 29 29 0a 09 09 09 09 20 20 20 20 28 76 e 0))..... (v
3760: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 (vector-ref tup
3770: 6c 65 20 31 29 29 29 0a 09 09 09 09 28 68 61 73 le 1))).....(has
3780: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 73 65 73 h-table-set! ses
3790: 73 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 20 sionvars-before
37a0: 6b 20 76 29 0a 09 09 09 09 28 68 61 73 68 2d 74 k v).....(hash-t
37b0: 61 62 6c 65 2d 73 65 74 21 20 73 65 73 73 69 6f able-set! sessio
37c0: 6e 76 61 72 73 20 20 20 20 20 20 20 20 6b 20 76 nvars k v
37d0: 29 29 29 0a 09 09 09 20 20 20 20 63 6f 6e 6e 0a ))).... conn.
37e0: 09 09 09 20 20 20 20 28 73 3a 73 71 6c 70 61 72 ... (s:sqlpar
37f0: 61 6d 20 71 75 65 72 79 20 73 65 73 73 69 6f 6e am query session
3800: 2d 6b 65 79 20 22 2a 73 65 73 73 69 6f 6e 76 61 -key "*sessionva
3810: 72 73 2a 22 29 29 0a 09 20 20 3b 3b 20 61 6e 64 rs*")).. ;; and
3820: 20 66 69 6e 61 6c 6c 79 20 74 68 65 20 67 6c 6f finally the glo
3830: 62 61 6c 20 76 61 72 73 0a 09 20 20 28 64 62 69 bal vars.. (dbi
3840: 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 28 6c :for-each-row (l
3850: 61 6d 62 64 61 20 28 74 75 70 6c 65 29 0a 09 09 ambda (tuple)...
3860: 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 6b 20 . (let ((k
3870: 28 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c (vector-ref tupl
3880: 65 20 30 29 29 0a 09 09 09 09 20 20 20 20 28 76 e 0))..... (v
3890: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 (vector-ref tup
38a0: 6c 65 20 31 29 29 29 0a 09 09 09 09 28 68 61 73 le 1))).....(has
38b0: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 67 6c 6f h-table-set! glo
38c0: 62 61 6c 76 61 72 73 2d 62 65 66 6f 72 65 20 6b balvars-before k
38d0: 20 76 29 0a 09 09 09 09 28 68 61 73 68 2d 74 61 v).....(hash-ta
38e0: 62 6c 65 2d 73 65 74 21 20 67 6c 6f 62 61 6c 76 ble-set! globalv
38f0: 61 72 73 20 20 20 20 20 20 20 20 6b 20 76 29 29 ars k v))
3900: 29 0a 09 09 09 20 20 20 20 63 6f 6e 6e 0a 09 09 ).... conn...
3910: 09 20 20 20 20 28 73 3a 73 71 6c 70 61 72 61 6d . (s:sqlparam
3920: 20 71 75 65 72 79 20 73 65 73 73 69 6f 6e 2d 6b query session-k
3930: 65 79 20 22 2a 67 6c 6f 62 61 6c 76 61 72 73 22 ey "*globalvars"
3940: 29 29 0a 09 20 20 29 29 29 29 0a 0a 28 64 65 66 )).. ))))..(def
3950: 69 6e 65 2d 6d 65 74 68 6f 64 20 28 73 65 73 73 ine-method (sess
3960: 69 6f 6e 3a 73 61 76 65 2d 76 61 72 73 20 28 73 ion:save-vars (s
3970: 65 6c 66 20 3c 73 65 73 73 69 6f 6e 3e 29 29 0a elf <session>)).
3980: 20 20 28 6c 65 74 20 28 28 73 65 73 73 69 6f 6e (let ((session
3990: 2d 69 64 20 20 28 73 6c 6f 74 2d 72 65 66 20 73 -id (slot-ref s
39a0: 65 6c 66 20 27 73 65 73 73 69 6f 6e 2d 69 64 29 elf 'session-id)
39b0: 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 )). (if (not
39c0: 73 65 73 73 69 6f 6e 2d 69 64 29 0a 09 28 65 72 session-id)..(er
39d0: 72 3a 6c 6f 67 20 22 45 52 52 4f 52 3a 20 4e 6f r:log "ERROR: No
39e0: 20 73 65 73 73 69 6f 6e 20 69 64 20 69 6e 20 73 session id in s
39f0: 65 73 73 69 6f 6e 20 6f 62 6a 65 63 74 21 20 73 ession object! s
3a00: 65 73 73 69 6f 6e 3a 67 65 74 2d 76 61 72 73 22 ession:get-vars"
3a10: 29 0a 09 28 6c 65 74 2a 20 28 28 73 74 61 74 75 )..(let* ((statu
3a20: 73 20 20 20 20 20 20 23 66 29 0a 09 20 20 20 20 s #f)..
3a30: 20 20 20 28 63 6f 6e 6e 20 20 20 20 20 20 20 20 (conn
3a40: 28 73 6c 6f 74 2d 72 65 66 20 73 65 6c 66 20 27 (slot-ref self '
3a50: 63 6f 6e 6e 29 29 0a 09 20 20 20 20 20 20 20 28 conn)).. (
3a60: 70 61 67 65 2d 6e 61 6d 65 20 20 20 28 73 6c 6f page-name (slo
3a70: 74 2d 72 65 66 20 73 65 6c 66 20 27 70 61 67 65 t-ref self 'page
3a80: 29 29 0a 09 20 20 20 20 20 20 20 28 64 65 6c 2d )).. (del-
3a90: 71 75 65 72 79 20 20 20 22 44 45 4c 45 54 45 20 query "DELETE
3aa0: 46 52 4f 4d 20 73 65 73 73 69 6f 6e 5f 76 61 72 FROM session_var
3ab0: 73 20 57 48 45 52 45 20 73 65 73 73 69 6f 6e 5f s WHERE session_
3ac0: 69 64 3d 3f 20 41 4e 44 20 70 61 67 65 3d 3f 20 id=? AND page=?
3ad0: 41 4e 44 20 6b 65 79 3d 3f 3b 22 29 0a 09 20 20 AND key=?;")..
3ae0: 20 20 20 20 20 28 69 6e 73 2d 71 75 65 72 79 20 (ins-query
3af0: 20 20 22 49 4e 53 45 52 54 20 49 4e 54 4f 20 73 "INSERT INTO s
3b00: 65 73 73 69 6f 6e 5f 76 61 72 73 20 28 73 65 73 ession_vars (ses
3b10: 73 69 6f 6e 5f 69 64 2c 70 61 67 65 2c 6b 65 79 sion_id,page,key
3b20: 2c 76 61 6c 75 65 29 20 56 41 4c 55 45 53 28 3f ,value) VALUES(?
3b30: 2c 3f 2c 3f 2c 3f 29 3b 22 29 0a 09 20 20 20 20 ,?,?,?);")..
3b40: 20 20 20 28 75 70 64 2d 71 75 65 72 79 20 20 20 (upd-query
3b50: 22 55 50 44 41 54 45 20 73 65 73 73 69 6f 6e 5f "UPDATE session_
3b60: 76 61 72 73 20 73 65 74 20 76 61 6c 75 65 3d 3f vars set value=?
3b70: 20 57 48 45 52 45 20 6b 65 79 3d 3f 20 41 4e 44 WHERE key=? AND
3b80: 20 73 65 73 73 69 6f 6e 5f 69 64 3d 3f 20 41 4e session_id=? AN
3b90: 44 20 70 61 67 65 3d 3f 3b 22 29 0a 09 20 20 20 D page=?;")..
3ba0: 20 20 20 20 28 63 68 61 6e 67 65 64 2d 63 6f 75 (changed-cou
3bb0: 6e 74 20 30 29 29 0a 09 20 20 3b 3b 20 73 61 76 nt 0)).. ;; sav
3bc0: 65 20 74 68 65 20 64 65 6c 74 61 20 6f 6e 6c 79 e the delta only
3bd0: 0a 09 20 20 28 66 6f 72 2d 65 61 63 68 0a 09 20 .. (for-each..
3be0: 20 20 28 6c 61 6d 62 64 61 20 28 70 61 67 65 29 (lambda (page)
3bf0: 20 3b 3b 20 70 61 67 65 20 69 73 3a 20 22 2a 67 ;; page is: "*g
3c00: 6c 6f 62 61 6c 76 61 72 73 2a 22 20 22 2a 73 65 lobalvars*" "*se
3c10: 73 73 69 6f 6e 76 61 72 73 2a 22 20 6f 72 20 6f ssionvars*" or o
3c20: 74 68 65 72 73 74 72 69 6e 67 0a 09 20 20 20 20 therstring..
3c30: 20 28 6c 65 74 2a 20 28 28 6d 61 73 74 65 72 2d (let* ((master-
3c40: 73 6c 6f 74 2d 6e 61 6d 65 20 28 63 6f 6e 64 0a slot-name (cond.
3c50: 09 09 09 09 20 20 20 20 20 20 20 28 28 73 74 72 .... ((str
3c60: 69 6e 67 3d 3f 20 70 61 67 65 20 22 2a 73 65 73 ing=? page "*ses
3c70: 73 69 6f 6e 76 61 72 73 2a 22 29 20 27 73 65 73 sionvars*") 'ses
3c80: 73 69 6f 6e 76 61 72 73 29 0a 09 09 09 09 20 20 sionvars).....
3c90: 20 20 20 20 20 28 28 73 74 72 69 6e 67 3d 3f 20 ((string=?
3ca0: 70 61 67 65 20 22 2a 67 6c 6f 62 61 6c 76 61 72 page "*globalvar
3cb0: 73 2a 22 29 20 20 27 67 6c 6f 62 61 6c 76 61 72 s*") 'globalvar
3cc0: 73 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 65 s)..... (e
3cd0: 6c 73 65 20 27 70 61 67 65 76 61 72 73 29 29 29 lse 'pagevars)))
3ce0: 0a 09 09 20 20 20 20 28 62 65 66 6f 72 65 2d 73 ... (before-s
3cf0: 6c 6f 74 2d 6e 61 6d 65 20 28 73 74 72 69 6e 67 lot-name (string
3d00: 2d 3e 73 79 6d 62 6f 6c 20 28 73 74 72 69 6e 67 ->symbol (string
3d10: 2d 61 70 70 65 6e 64 20 28 73 79 6d 62 6f 6c 2d -append (symbol-
3d20: 3e 73 74 72 69 6e 67 20 6d 61 73 74 65 72 2d 73 >string master-s
3d30: 6c 6f 74 2d 6e 61 6d 65 29 0a 09 09 09 09 09 09 lot-name).......
3d40: 09 09 20 20 20 20 20 22 2d 62 65 66 6f 72 65 22 .. "-before"
3d50: 29 29 29 0a 09 09 20 20 20 20 28 6d 61 73 74 65 )))... (maste
3d60: 72 2d 68 74 20 20 20 28 73 6c 6f 74 2d 72 65 66 r-ht (slot-ref
3d70: 20 73 65 6c 66 20 6d 61 73 74 65 72 2d 73 6c 6f self master-slo
3d80: 74 2d 6e 61 6d 65 29 29 0a 09 09 20 20 20 20 28 t-name))... (
3d90: 62 65 66 6f 72 65 2d 68 74 20 20 20 28 73 6c 6f before-ht (slo
3da0: 74 2d 72 65 66 20 73 65 6c 66 20 62 65 66 6f 72 t-ref self befor
3db0: 65 2d 73 6c 6f 74 2d 6e 61 6d 65 29 29 0a 09 09 e-slot-name))...
3dc0: 20 20 20 20 28 6d 61 73 74 65 72 2d 6b 65 79 73 (master-keys
3dd0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 (hash-table-key
3de0: 73 20 6d 61 73 74 65 72 2d 68 74 29 29 0a 09 09 s master-ht))...
3df0: 20 20 20 20 28 62 65 66 6f 72 65 2d 6b 65 79 73 (before-keys
3e00: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 (hash-table-key
3e10: 73 20 62 65 66 6f 72 65 2d 68 74 29 29 0a 09 09 s before-ht))...
3e20: 20 20 20 20 28 61 6c 6c 2d 6b 65 79 73 20 28 64 (all-keys (d
3e30: 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 65 73 elete-duplicates
3e40: 20 28 61 70 70 65 6e 64 20 6d 61 73 74 65 72 2d (append master-
3e50: 6b 65 79 73 20 62 65 66 6f 72 65 2d 6b 65 79 73 keys before-keys
3e60: 29 29 29 29 0a 09 20 20 20 20 20 20 20 28 66 6f )))).. (fo
3e70: 72 2d 65 61 63 68 20 0a 09 09 28 6c 61 6d 62 64 r-each ...(lambd
3e80: 61 20 28 6b 65 79 29 0a 09 09 20 20 28 6c 65 74 a (key)... (let
3e90: 20 28 28 6d 61 73 74 65 72 2d 76 61 6c 75 65 20 ((master-value
3ea0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
3eb0: 64 65 66 61 75 6c 74 20 6d 61 73 74 65 72 2d 68 default master-h
3ec0: 74 20 6b 65 79 20 23 66 29 29 0a 09 09 09 28 62 t key #f))....(b
3ed0: 65 66 6f 72 65 2d 76 61 6c 75 65 20 28 68 61 73 efore-value (has
3ee0: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
3ef0: 75 6c 74 20 62 65 66 6f 72 65 2d 68 74 20 6b 65 ult before-ht ke
3f00: 79 20 23 66 29 29 29 0a 09 09 20 20 20 20 28 63 y #f)))... (c
3f10: 6f 6e 64 0a 09 09 20 20 20 20 20 3b 3b 20 62 65 ond... ;; be
3f20: 66 6f 72 65 20 61 6e 64 20 61 66 74 65 72 20 65 fore and after e
3f30: 78 69 73 74 20 61 6e 64 20 76 61 6c 75 65 20 75 xist and value u
3f40: 6e 63 68 61 6e 67 65 64 20 2d 20 64 6f 20 6e 6f nchanged - do no
3f50: 74 68 69 6e 67 0a 09 09 20 20 20 20 20 28 28 61 thing... ((a
3f60: 6e 64 20 6d 61 73 74 65 72 2d 76 61 6c 75 65 20 nd master-value
3f70: 62 65 66 6f 72 65 2d 76 61 6c 75 65 20 28 65 71 before-value (eq
3f80: 75 61 6c 3f 20 6d 61 73 74 65 72 2d 76 61 6c 75 ual? master-valu
3f90: 65 20 62 65 66 6f 72 65 2d 76 61 6c 75 65 29 29 e before-value))
3fa0: 29 0a 09 09 20 20 20 20 20 3b 3b 20 62 65 66 6f )... ;; befo
3fb0: 72 65 20 61 6e 64 20 61 66 74 65 72 20 65 78 69 re and after exi
3fc0: 73 74 20 62 75 74 20 61 72 65 20 63 68 61 6e 67 st but are chang
3fd0: 65 64 0a 09 09 20 20 20 20 20 28 28 61 6e 64 20 ed... ((and
3fe0: 6d 61 73 74 65 72 2d 76 61 6c 75 65 20 62 65 66 master-value bef
3ff0: 6f 72 65 2d 76 61 6c 75 65 29 0a 09 09 20 20 20 ore-value)...
4000: 20 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 (dbi:for-each
4010: 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 75 -row (lambda (tu
4020: 70 6c 65 29 0a 09 09 09 09 09 20 20 28 73 65 74 ple)...... (set
4030: 21 20 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 ! changed-count
4040: 28 2b 20 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 (+ changed-count
4050: 20 31 29 29 29 0a 09 09 09 09 09 63 6f 6e 6e 0a 1)))......conn.
4060: 09 09 09 09 09 28 73 3a 73 71 6c 70 61 72 61 6d .....(s:sqlparam
4070: 20 75 70 64 2d 71 75 65 72 79 20 6d 61 73 74 65 upd-query maste
4080: 72 2d 76 61 6c 75 65 20 6b 65 79 20 73 65 73 73 r-value key sess
4090: 69 6f 6e 2d 69 64 20 70 61 67 65 29 29 29 0a 09 ion-id page)))..
40a0: 09 20 20 20 20 20 3b 3b 20 6d 61 73 74 65 72 2d . ;; master-
40b0: 76 61 6c 75 65 20 6e 6f 20 6c 6f 6e 67 65 72 20 value no longer
40c0: 65 78 69 73 74 73 20 28 69 2e 65 2e 20 23 66 29 exists (i.e. #f)
40d0: 20 2d 20 72 65 6d 6f 76 65 20 69 74 65 6d 0a 09 - remove item..
40e0: 09 20 20 20 20 20 28 28 6e 6f 74 20 6d 61 73 74 . ((not mast
40f0: 65 72 2d 76 61 6c 75 65 29 0a 09 09 20 20 20 20 er-value)...
4100: 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d (dbi:for-each-
4110: 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 75 70 row (lambda (tup
4120: 6c 65 29 0a 09 09 09 09 09 20 20 28 73 65 74 21 le)...... (set!
4130: 20 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 28 changed-count (
4140: 2b 20 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 + changed-count
4150: 31 29 29 29 0a 09 09 09 09 09 63 6f 6e 6e 0a 09 1)))......conn..
4160: 09 09 09 09 28 73 3a 73 71 6c 70 61 72 61 6d 20 ....(s:sqlparam
4170: 64 65 6c 2d 71 75 65 72 79 20 73 65 73 73 69 6f del-query sessio
4180: 6e 2d 69 64 20 70 61 67 65 20 6b 65 79 29 29 29 n-id page key)))
4190: 0a 09 09 20 20 20 20 20 3b 3b 20 62 65 66 6f 72 ... ;; befor
41a0: 65 2d 76 61 6c 75 65 20 64 6f 65 73 6e 27 74 20 e-value doesn't
41b0: 65 78 69 73 74 20 2d 20 69 6e 73 65 72 74 20 61 exist - insert a
41c0: 20 6e 65 77 20 76 61 6c 75 65 0a 09 09 20 20 20 new value...
41d0: 20 20 28 28 6e 6f 74 20 62 65 66 6f 72 65 2d 76 ((not before-v
41e0: 61 6c 75 65 29 0a 09 09 20 20 20 20 20 20 28 64 alue)... (d
41f0: 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 bi:for-each-row
4200: 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 29 0a (lambda (tuple).
4210: 09 09 09 09 09 20 20 28 73 65 74 21 20 63 68 61 ..... (set! cha
4220: 6e 67 65 64 2d 63 6f 75 6e 74 20 28 2b 20 63 68 nged-count (+ ch
4230: 61 6e 67 65 64 2d 63 6f 75 6e 74 20 31 29 29 29 anged-count 1)))
4240: 0a 09 09 09 09 09 63 6f 6e 6e 0a 09 09 09 09 09 ......conn......
4250: 28 73 3a 73 71 6c 70 61 72 61 6d 20 69 6e 73 2d (s:sqlparam ins-
4260: 71 75 65 72 79 20 73 65 73 73 69 6f 6e 2d 69 64 query session-id
4270: 20 70 61 67 65 20 6b 65 79 20 6d 61 73 74 65 72 page key master
4280: 2d 76 61 6c 75 65 29 29 29 0a 09 09 20 20 20 20 -value)))...
4290: 20 28 65 6c 73 65 20 28 65 72 72 3a 6c 6f 67 20 (else (err:log
42a0: 22 53 68 6f 75 6c 64 6e 27 74 20 67 65 74 20 68 "Shouldn't get h
42b0: 65 72 65 22 29 29 29 29 29 0a 09 09 61 6c 6c 2d ere")))))...all-
42c0: 6b 65 79 73 29 29 29 20 3b 3b 20 70 72 6f 63 65 keys))) ;; proce
42d0: 73 73 20 61 6c 6c 20 6b 65 79 73 0a 09 20 20 20 ss all keys..
42e0: 28 6c 69 73 74 20 22 2a 73 65 73 73 69 6f 6e 76 (list "*sessionv
42f0: 61 72 73 2a 22 20 22 2a 67 6c 6f 62 61 6c 76 61 ars*" "*globalva
4300: 72 73 2a 22 20 70 61 67 65 2d 6e 61 6d 65 29 29 rs*" page-name))
4310: 29 29 29 29 0a 0a 3b 3b 20 09 20 20 3b 3b 20 28 ))))..;; . ;; (
4320: 70 72 69 6e 74 20 64 65 6c 2d 71 75 65 72 79 29 print del-query)
4330: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 28 66 .;; (f
4340: 6f 72 2d 65 61 63 68 0a 3b 3b 20 20 20 20 20 20 or-each.;;
4350: 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 70 (lambda (p
4360: 61 67 65 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 age).;;
4370: 20 20 20 20 20 28 70 67 3a 71 75 65 72 79 2d 66 (pg:query-f
4380: 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 or-each (lambda
4390: 28 74 75 70 6c 65 29 0a 3b 3b 20 20 20 20 20 20 (tuple).;;
43a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
43b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 65 (se
43c0: 74 21 20 73 74 61 74 75 73 20 23 74 29 29 0a 3b t! status #t)).;
43d0: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
43e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
43f0: 20 20 28 73 3a 73 71 6c 70 61 72 61 6d 20 64 65 (s:sqlparam de
4400: 6c 2d 71 75 65 72 79 20 73 65 73 73 69 6f 6e 2d l-query session-
4410: 69 64 20 70 61 67 65 2d 6e 61 6d 65 29 0a 3b 3b id page-name).;;
4420: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4430: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4440: 20 63 6f 6e 6e 29 29 0a 3b 3b 20 20 20 20 20 20 conn)).;;
4450: 20 20 20 20 20 20 28 6c 69 73 74 20 70 61 67 65 (list page
4460: 2d 6e 61 6d 65 20 22 2a 73 65 73 73 69 6f 6e 76 -name "*sessionv
4470: 61 72 73 22 29 29 0a 3b 3b 20 20 20 20 20 20 20 ars")).;;
4480: 20 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 54 68 65 ;; NOTE: The
4490: 20 66 6f 6c 6c 6f 77 69 6e 67 20 61 70 70 72 6f following appro
44a0: 61 63 68 20 69 73 20 69 6e 65 66 66 69 63 69 65 ach is inefficie
44b0: 6e 74 20 61 6e 64 20 61 20 6c 69 74 74 6c 65 20 nt and a little
44c0: 64 61 6e 67 65 72 6f 75 73 2e 20 4e 65 65 64 20 dangerous. Need
44d0: 74 6f 20 6b 65 65 70 0a 3b 3b 20 20 20 20 20 20 to keep.;;
44e0: 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 74 77 ;; tw
44f0: 6f 20 68 61 73 68 65 73 2c 20 62 65 66 6f 72 65 o hashes, before
4500: 20 61 6e 64 20 61 66 74 65 72 20 61 6e 64 20 75 and after and u
4510: 73 65 20 74 68 65 20 64 65 6c 74 61 20 74 6f 20 se the delta to
4520: 64 72 69 76 65 20 75 70 64 61 74 69 6e 67 20 74 drive updating t
4530: 68 65 20 64 62 20 4f 52 0a 3b 3b 20 20 20 20 20 he db OR.;;
4540: 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 65 ;; e
4550: 76 65 6e 20 62 65 74 74 65 72 20 6d 6f 76 65 20 ven better move
4560: 74 6f 20 75 73 69 6e 67 20 72 70 63 20 77 69 74 to using rpc wit
4570: 68 20 61 20 63 65 6e 74 72 61 6c 20 70 72 6f 63 h a central proc
4580: 65 73 73 20 66 6f 72 20 6d 61 69 6e 74 61 69 6e ess for maintain
4590: 69 6e 67 20 73 74 61 74 65 0a 3b 3b 20 20 20 20 ing state.;;
45a0: 20 20 20 20 20 20 20 3b 3b 20 77 72 69 74 65 20 ;; write
45b0: 74 68 65 20 73 65 73 73 69 6f 6e 20 70 61 67 65 the session page
45c0: 20 73 70 65 63 69 66 69 63 20 76 61 72 73 20 74 specific vars t
45d0: 6f 20 74 68 65 20 64 62 0a 3b 3b 20 09 20 20 28 o the db.;; . (
45e0: 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 for-each (lambda
45f0: 20 28 6b 65 79 29 0a 3b 3b 20 09 09 20 20 20 20 (key).;; ..
4600: 20 20 28 70 67 3a 71 75 65 72 79 2d 66 6f 72 2d (pg:query-for-
4610: 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 74 75 each (lambda (tu
4620: 70 6c 65 29 0a 3b 3b 20 09 09 09 09 09 20 20 20 ple).;; .....
4630: 28 73 65 74 21 20 73 74 61 74 75 73 20 23 74 29 (set! status #t)
4640: 29 0a 3b 3b 20 09 09 09 09 09 20 28 73 3a 73 71 ).;; ..... (s:sq
4650: 6c 70 61 72 61 6d 20 69 6e 73 2d 71 75 65 72 79 lparam ins-query
4660: 20 73 65 73 73 69 6f 6e 2d 69 64 20 70 61 67 65 session-id page
4670: 2d 6e 61 6d 65 0a 3b 3b 20 20 20 20 20 20 20 20 -name.;;
4680: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4690: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
46a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
46b0: 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6b 65 79 :any->string key
46c0: 29 20 3b 3b 20 6a 75 73 74 20 69 6e 20 63 61 73 ) ;; just in cas
46d0: 65 20 69 74 20 69 73 20 61 20 73 79 6d 62 6f 6c e it is a symbol
46e0: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 .;;
46f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4700: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4710: 20 20 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 (hash-t
4720: 61 62 6c 65 2d 72 65 66 20 70 61 67 65 76 61 72 able-ref pagevar
4730: 73 20 6b 65 79 29 29 0a 3b 3b 20 09 09 09 09 09 s key)).;; .....
4740: 20 63 6f 6e 6e 29 29 0a 3b 3b 20 09 09 20 20 20 conn)).;; ..
4750: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 (hash-table-key
4760: 73 20 70 61 67 65 76 61 72 73 29 29 0a 3b 3b 20 s pagevars)).;;
4770: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 77 72 69 ;; wri
4780: 74 65 20 74 68 65 20 73 65 73 73 69 6f 6e 20 73 te the session s
4790: 70 65 63 69 66 69 63 20 76 61 72 73 20 74 6f 20 pecific vars to
47a0: 74 68 65 20 64 62 0a 3b 3b 20 20 20 20 20 20 20 the db.;;
47b0: 20 20 20 20 3b 3b 20 42 55 47 21 21 21 20 54 48 ;; BUG!!! TH
47c0: 49 53 20 49 53 20 4c 41 5a 59 20 41 4e 44 20 57 IS IS LAZY AND W
47d0: 49 4c 4c 20 42 52 45 41 4b 20 46 4f 52 20 53 4f ILL BREAK FOR SO
47e0: 4d 45 4f 4e 45 20 41 43 43 45 53 53 49 4e 47 20 MEONE ACCESSING
47f0: 54 48 45 20 53 41 4d 45 20 53 45 53 53 49 4f 4e THE SAME SESSION
4800: 20 46 52 4f 4d 20 54 57 4f 20 57 49 4e 44 4f 57 FROM TWO WINDOW
4810: 53 21 21 21 0a 3b 3b 20 09 20 20 28 66 6f 72 2d S!!!.;; . (for-
4820: 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 6b 65 each (lambda (ke
4830: 79 29 0a 3b 3b 20 09 09 20 20 20 20 20 20 28 70 y).;; .. (p
4840: 67 3a 71 75 65 72 79 2d 66 6f 72 2d 65 61 63 68 g:query-for-each
4850: 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 29 (lambda (tuple)
4860: 0a 3b 3b 20 09 09 09 09 09 20 20 20 28 73 65 74 .;; ..... (set
4870: 21 20 73 74 61 74 75 73 20 23 74 29 29 0a 3b 3b ! status #t)).;;
4880: 20 09 09 09 09 09 20 28 73 3a 73 71 6c 70 61 72 ..... (s:sqlpar
4890: 61 6d 20 69 6e 73 2d 71 75 65 72 79 20 73 65 73 am ins-query ses
48a0: 73 69 6f 6e 2d 69 64 20 22 2a 73 65 73 73 69 6f sion-id "*sessio
48b0: 6e 76 61 72 73 2a 22 0a 3b 3b 20 20 20 20 20 20 nvars*".;;
48c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
48d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
48e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
48f0: 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6b (s:any->string k
4900: 65 79 29 20 3b 3b 20 6a 75 73 74 20 69 6e 20 63 ey) ;; just in c
4910: 61 73 65 20 69 74 20 69 73 20 61 20 73 79 6d 62 ase it is a symb
4920: 6f 6c 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 ol.;;
4930: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4940: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4950: 20 20 20 20 20 20 20 20 20 20 20 28 68 61 73 68 (hash
4960: 2d 74 61 62 6c 65 2d 72 65 66 20 73 65 73 73 69 -table-ref sessi
4970: 6f 6e 76 61 72 73 20 6b 65 79 29 29 0a 3b 3b 20 onvars key)).;;
4980: 09 09 09 09 09 20 63 6f 6e 6e 29 29 0a 3b 3b 20 ..... conn)).;;
4990: 09 09 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c .. (hash-tabl
49a0: 65 2d 6b 65 79 73 20 73 65 73 73 69 6f 6e 76 61 e-keys sessionva
49b0: 72 73 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 rs)).;;
49c0: 20 20 3b 3b 20 67 6c 6f 62 61 6c 20 76 61 72 73 ;; global vars
49d0: 20 77 69 6c 6c 20 72 65 71 75 69 72 65 20 61 20 will require a
49e0: 6c 69 74 74 6c 65 20 6d 6f 72 65 20 63 61 72 65 little more care
49f0: 20 2d 20 64 65 6c 61 79 69 6e 67 20 66 6f 72 20 - delaying for
4a00: 6e 6f 77 2e 0a 3b 3b 20 20 20 20 20 20 20 20 20 now..;;
4a10: 20 20 29 29 29 29 0a 0a 3b 3b 20 28 70 67 3a 73 ))))..;; (pg:s
4a20: 71 6c 2d 6e 75 6c 6c 2d 6f 62 6a 65 63 74 3f 20 ql-null-object?
4a30: 65 6c 65 6d 65 6e 74 29 0a 28 64 65 66 69 6e 65 element).(define
4a40: 2d 6d 65 74 68 6f 64 20 28 73 65 73 73 69 6f 6e -method (session
4a50: 3a 72 65 61 64 2d 63 6f 6e 66 69 67 20 28 73 65 :read-config (se
4a60: 6c 66 20 3c 73 65 73 73 69 6f 6e 3e 29 29 0a 20 lf <session>)).
4a70: 20 28 6c 65 74 20 28 28 6e 61 6d 65 20 28 73 74 (let ((name (st
4a80: 72 69 6e 67 2d 61 70 70 65 6e 64 20 22 2e 22 20 ring-append "."
4a90: 28 70 61 74 68 6e 61 6d 65 2d 66 69 6c 65 20 28 (pathname-file (
4aa0: 63 61 72 20 28 61 72 67 76 29 29 29 20 22 2e 63 car (argv))) ".c
4ab0: 6f 6e 66 69 67 22 29 29 29 0a 20 20 20 20 28 69 onfig"))). (i
4ac0: 66 20 28 6e 6f 74 20 28 66 69 6c 65 2d 65 78 69 f (not (file-exi
4ad0: 73 74 73 3f 20 6e 61 6d 65 29 29 0a 09 28 70 72 sts? name))..(pr
4ae0: 69 6e 74 20 6e 61 6d 65 20 22 20 6e 6f 74 20 66 int name " not f
4af0: 6f 75 6e 64 20 61 74 20 22 20 28 63 75 72 72 65 ound at " (curre
4b00: 6e 74 2d 64 69 72 65 63 74 6f 72 79 29 29 0a 09 nt-directory))..
4b10: 28 6c 65 74 2a 20 28 28 66 70 20 28 6f 70 65 6e (let* ((fp (open
4b20: 2d 69 6e 70 75 74 2d 66 69 6c 65 20 6e 61 6d 65 -input-file name
4b30: 29 29 0a 09 20 20 20 20 20 20 20 28 69 6e 69 74 )).. (init
4b40: 61 72 67 73 20 28 72 65 61 64 20 66 70 29 29 29 args (read fp)))
4b50: 0a 09 20 20 28 63 6c 6f 73 65 2d 69 6e 70 75 74 .. (close-input
4b60: 2d 70 6f 72 74 20 66 70 29 0a 09 20 20 69 6e 69 -port fp).. ini
4b70: 74 61 72 67 73 29 29 29 29 0a 0a 3b 3b 20 63 61 targs))))..;; ca
4b80: 6c 6c 20 74 68 65 20 63 6f 6e 74 72 6f 6c 6c 65 ll the controlle
4b90: 72 20 69 66 20 69 74 20 65 78 69 73 74 73 0a 3b r if it exists.;
4ba0: 3b 20 0a 3b 3b 20 57 41 52 4e 49 4e 47 20 2d 20 ; .;; WARNING -
4bb0: 74 68 69 73 20 63 6f 64 65 20 6e 65 65 64 73 20 this code needs
4bc0: 61 20 64 65 66 65 6e 63 65 20 61 67 61 69 6e 73 a defence agains
4bd0: 20 72 65 63 75 72 73 69 76 65 20 63 61 6c 6c 69 recursive calli
4be0: 6e 67 21 21 21 21 21 0a 3b 3b 0a 3b 3b 20 20 20 ng!!!!!.;;.;;
4bf0: 49 20 73 75 67 67 65 73 74 20 61 20 6c 69 6d 69 I suggest a limi
4c00: 74 20 6f 66 20 31 30 30 20 63 61 6c 6c 73 2e 20 t of 100 calls.
4c10: 50 6c 65 6e 74 79 20 66 6f 72 20 61 6c 6c 6f 77 Plenty for allow
4c20: 69 6e 67 20 6d 75 6c 74 69 70 6c 65 20 69 6e 73 ing multiple ins
4c30: 74 61 6e 63 65 73 0a 3b 3b 20 20 20 6f 66 20 61 tances.;; of a
4c40: 20 70 61 67 65 20 69 6e 73 69 64 65 20 61 6e 6f page inside ano
4c50: 74 68 65 72 20 70 61 67 65 2e 20 0a 3b 3b 0a 3b ther page. .;;.;
4c60: 3b 20 70 61 72 74 73 20 3d 20 27 62 6f 74 68 20 ; parts = 'both
4c70: 7c 20 27 63 6f 6e 74 72 6f 6c 20 7c 20 27 76 69 | 'control | 'vi
4c80: 65 77 0a 3b 3b 0a 0a 28 64 65 66 69 6e 65 20 28 ew.;;..(define (
4c90: 66 69 6c 65 73 2d 72 65 61 64 2d 3e 73 74 72 69 files-read->stri
4ca0: 6e 67 20 2e 20 66 69 6c 65 73 29 0a 20 20 28 73 ng . files). (s
4cb0: 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
4cc0: 65 20 0a 20 20 20 28 61 70 70 6c 79 20 61 70 70 e . (apply app
4cd0: 65 6e 64 20 28 6d 61 70 20 66 69 6c 65 2d 72 65 end (map file-re
4ce0: 61 64 2d 3e 73 74 72 69 6e 67 20 66 69 6c 65 73 ad->string files
4cf0: 29 29 20 22 5c 6e 22 29 29 0a 0a 28 64 65 66 69 )) "\n"))..(defi
4d00: 6e 65 20 28 66 69 6c 65 2d 72 65 61 64 2d 3e 73 ne (file-read->s
4d10: 74 72 69 6e 67 20 66 29 20 0a 20 20 28 6c 65 74 tring f) . (let
4d20: 20 28 28 70 20 28 6f 70 65 6e 2d 69 6e 70 75 74 ((p (open-input
4d30: 2d 66 69 6c 65 20 66 29 29 29 0a 20 20 20 20 28 -file f))). (
4d40: 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 let loop ((hed (
4d50: 72 65 61 64 2d 6c 69 6e 65 20 70 29 29 0a 09 20 read-line p))..
4d60: 20 20 20 20 20 20 28 72 65 73 20 27 28 29 29 29 (res '()))
4d70: 0a 20 20 20 20 20 20 28 69 66 20 28 65 6f 66 2d . (if (eof-
4d80: 6f 62 6a 65 63 74 3f 20 68 65 64 29 0a 09 20 20 object? hed)..
4d90: 72 65 73 0a 09 20 20 28 6c 6f 6f 70 20 28 72 65 res.. (loop (re
4da0: 61 64 2d 6c 69 6e 65 20 70 29 28 61 70 70 65 6e ad-line p)(appen
4db0: 64 20 72 65 73 20 28 6c 69 73 74 20 68 65 64 29 d res (list hed)
4dc0: 29 29 29 29 29 29 0a 0a 3b 3b 20 4d 61 79 20 32 ))))))..;; May 2
4dd0: 30 31 31 2c 20 70 75 74 74 69 6e 67 20 61 6c 6c 011, putting all
4de0: 20 70 61 67 65 73 20 69 6e 74 6f 20 6f 6e 65 20 pages into one
4df0: 64 69 72 65 63 74 6f 72 79 20 66 6f 72 20 74 68 directory for th
4e00: 65 20 66 6f 6c 6c 6f 77 69 6e 67 20 72 65 61 73 e following reas
4e10: 6f 6e 73 3a 0a 3b 3b 20 20 20 31 2e 20 77 61 6e ons:.;; 1. wan
4e20: 74 20 66 69 6c 65 6e 61 6d 65 20 74 6f 20 72 65 t filename to re
4e30: 66 6c 65 63 74 20 70 61 67 65 20 6e 61 6d 65 20 flect page name
4e40: 28 65 6d 61 63 73 20 6c 69 6d 69 74 61 74 69 6f (emacs limitatio
4e50: 6e 29 0a 3b 3b 20 20 20 32 2e 20 74 68 61 74 27 n).;; 2. that'
4e60: 73 20 69 74 21 20 6e 6f 20 6f 74 68 65 72 20 72 s it! no other r
4e70: 65 61 73 6f 6e 2e 20 63 6f 75 6c 64 20 6d 61 6b eason. could mak
4e80: 65 20 69 74 20 63 6f 6e 66 69 67 75 72 61 62 6c e it configurabl
4e90: 65 20 2e 2e 2e 0a 28 64 65 66 69 6e 65 2d 6d 65 e ....(define-me
4ea0: 74 68 6f 64 20 28 73 65 73 73 69 6f 6e 3a 63 61 thod (session:ca
4eb0: 6c 6c 2d 70 61 72 74 73 20 28 73 65 6c 66 20 3c ll-parts (self <
4ec0: 73 65 73 73 69 6f 6e 3e 29 20 70 61 67 65 20 70 session>) page p
4ed0: 61 72 74 73 29 0a 20 20 28 73 6c 6f 74 2d 73 65 arts). (slot-se
4ee0: 74 21 20 73 65 6c 66 20 27 63 75 72 72 2d 70 61 t! self 'curr-pa
4ef0: 67 65 20 70 61 67 65 29 0a 20 20 28 73 65 73 73 ge page). (sess
4f00: 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 70 61 ion:log self "pa
4f10: 67 65 2d 64 69 72 2d 73 74 79 6c 65 3a 20 22 20 ge-dir-style: "
4f20: 28 73 6c 6f 74 2d 72 65 66 20 73 65 6c 66 20 27 (slot-ref self '
4f30: 70 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 29 29 page-dir-style))
4f40: 0a 20 20 28 6c 65 74 2a 20 28 28 64 69 72 2d 73 . (let* ((dir-s
4f50: 74 79 6c 65 20 3b 3b 20 28 65 71 75 61 6c 3f 20 tyle ;; (equal?
4f60: 28 73 6c 6f 74 2d 72 65 66 20 73 65 6c 66 20 27 (slot-ref self '
4f70: 70 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 29 20 page-dir-style)
4f80: 22 6f 6e 65 64 69 72 22 29 29 20 3b 3b 20 66 6c "onedir")) ;; fl
4f90: 61 67 20 23 74 20 66 6f 72 20 6f 6e 65 64 69 72 ag #t for onedir
4fa0: 2c 20 23 66 20 66 6f 72 20 6f 6c 64 20 73 74 79 , #f for old sty
4fb0: 6c 65 0a 09 20 20 28 73 6c 6f 74 2d 72 65 66 20 le.. (slot-ref
4fc0: 73 65 6c 66 20 27 70 61 67 65 2d 64 69 72 2d 73 self 'page-dir-s
4fd0: 74 79 6c 65 29 29 0a 09 20 28 64 69 72 20 20 20 tyle)).. (dir
4fe0: 20 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 (string-append
4ff0: 20 28 73 6c 6f 74 2d 72 65 66 20 73 65 6c 66 20 (slot-ref self
5000: 27 73 72 6f 6f 74 29 20 0a 09 09 09 09 20 28 69 'sroot) ..... (i
5010: 66 20 64 69 72 2d 73 74 79 6c 65 20 0a 09 09 09 f dir-style ....
5020: 09 20 20 20 20 20 28 63 6f 6e 63 20 22 2f 70 61 . (conc "/pa
5030: 67 65 73 2f 22 29 0a 09 09 09 09 20 20 20 20 20 ges/").....
5040: 28 63 6f 6e 63 20 22 2f 70 61 67 65 73 2f 22 20 (conc "/pages/"
5050: 70 61 67 65 29 29 29 29 0a 09 20 28 63 6f 6e 74 page)))).. (cont
5060: 72 6f 6c 20 28 73 74 72 69 6e 67 2d 61 70 70 65 rol (string-appe
5070: 6e 64 20 64 69 72 20 28 69 66 20 64 69 72 2d 73 nd dir (if dir-s
5080: 74 79 6c 65 20 0a 09 09 09 09 09 20 28 63 6f 6e tyle ...... (con
5090: 63 20 70 61 67 65 20 22 5f 63 74 72 6c 2e 73 63 c page "_ctrl.sc
50a0: 6d 22 29 0a 09 09 09 09 09 20 22 2f 63 6f 6e 74 m")...... "/cont
50b0: 72 6f 6c 2e 73 63 6d 22 29 29 29 0a 09 20 28 76 rol.scm"))).. (v
50c0: 69 65 77 20 20 20 20 28 73 74 72 69 6e 67 2d 61 iew (string-a
50d0: 70 70 65 6e 64 20 64 69 72 20 28 69 66 20 64 69 ppend dir (if di
50e0: 72 2d 73 74 79 6c 65 20 0a 09 09 09 09 09 20 28 r-style ...... (
50f0: 63 6f 6e 63 20 70 61 67 65 20 22 5f 76 69 65 77 conc page "_view
5100: 2e 73 63 6d 22 29 0a 09 09 09 09 09 20 22 2f 76 .scm")...... "/v
5110: 69 65 77 2e 73 63 6d 22 29 29 29 0a 09 20 28 6c iew.scm"))).. (l
5120: 6f 61 64 2d 76 69 65 77 20 20 20 20 28 61 6e 64 oad-view (and
5130: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 76 (file-exists? v
5140: 69 65 77 29 0a 09 09 09 20 20 20 20 28 6f 72 20 iew).... (or
5150: 28 65 71 3f 20 70 61 72 74 73 20 27 62 6f 74 68 (eq? parts 'both
5160: 29 28 65 71 3f 20 70 61 72 74 73 20 27 76 69 65 )(eq? parts 'vie
5170: 77 29 29 29 29 0a 09 20 28 6c 6f 61 64 2d 63 6f w)))).. (load-co
5180: 6e 74 72 6f 6c 20 28 61 6e 64 20 28 66 69 6c 65 ntrol (and (file
5190: 2d 65 78 69 73 74 73 3f 20 63 6f 6e 74 72 6f 6c -exists? control
51a0: 29 0a 09 09 09 20 20 20 20 28 6f 72 20 28 65 71 ).... (or (eq
51b0: 3f 20 70 61 72 74 73 20 27 62 6f 74 68 29 28 65 ? parts 'both)(e
51c0: 71 3f 20 70 61 72 74 73 20 27 63 6f 6e 74 72 6f q? parts 'contro
51d0: 6c 29 29 29 29 0a 09 20 28 76 69 65 77 2d 64 61 l)))).. (view-da
51e0: 74 20 20 20 27 28 29 29 29 0a 20 20 20 20 28 73 t '())). (s
51f0: 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 ession:log self
5200: 22 64 69 72 2d 73 74 79 6c 65 3a 20 22 20 64 69 "dir-style: " di
5210: 72 2d 73 74 79 6c 65 29 0a 20 3b 3b 20 20 20 28 r-style). ;; (
5220: 73 75 67 61 72 20 22 2f 68 6f 6d 65 2f 6d 61 74 sugar "/home/mat
5230: 74 2f 6b 69 61 74 6f 61 2f 73 74 6d 6c 2f 73 75 t/kiatoa/stml/su
5240: 67 61 72 2e 73 63 6d 22 20 29 29 0a 20 20 20 20 gar.scm" )).
5250: 3b 3b 20 28 70 72 69 6e 74 20 22 64 69 72 3d 22 ;; (print "dir="
5260: 20 64 69 72 20 22 20 63 6f 6e 74 72 6f 6c 3d 22 dir " control="
5270: 20 63 6f 6e 74 72 6f 6c 20 22 20 76 69 65 77 3d control " view=
5280: 22 20 76 69 65 77 20 22 20 6c 6f 61 64 2d 76 69 " view " load-vi
5290: 65 77 3d 22 20 6c 6f 61 64 2d 76 69 65 77 20 22 ew=" load-view "
52a0: 20 6c 6f 61 64 3d 63 6f 6e 74 72 6f 6c 3d 22 20 load=control="
52b0: 6c 6f 61 64 2d 63 6f 6e 74 72 6f 6c 29 0a 20 20 load-control).
52c0: 20 20 28 69 66 20 6c 6f 61 64 2d 63 6f 6e 74 72 (if load-contr
52d0: 6f 6c 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 6c ol..(begin.. (l
52e0: 6f 61 64 20 63 6f 6e 74 72 6f 6c 29 0a 09 20 20 oad control)..
52f0: 28 73 65 73 73 69 6f 6e 3a 73 65 74 2d 63 61 6c (session:set-cal
5300: 6c 65 64 21 20 73 65 6c 66 20 70 61 67 65 29 29 led! self page))
5310: 29 0a 20 20 20 20 3b 3b 20 6d 6f 76 65 20 74 68 ). ;; move th
5320: 69 73 20 74 6f 20 77 68 65 72 65 20 69 74 20 67 is to where it g
5330: 65 74 73 20 65 78 65 63 74 75 74 65 64 20 6f 6e ets exectuted on
5340: 6c 79 20 6f 6e 63 65 0a 20 20 20 20 3b 3b 0a 20 ly once. ;;.
5350: 20 20 20 28 69 66 20 6c 6f 61 64 2d 76 69 65 77 (if load-view
5360: 0a 09 3b 3b 20 6f 70 74 69 6f 6e 20 6f 6e 65 2e ..;; option one.
5370: 3a 0a 09 3b 3b 0a 09 3b 3b 20 28 6c 65 74 20 28 :..;;..;; (let (
5380: 28 69 6e 70 20 28 6f 70 65 6e 2d 69 6e 70 75 74 (inp (open-input
5390: 2d 73 74 72 69 6e 67 20 0a 09 3b 3b 20 09 20 20 -string ..;; .
53a0: 20 20 28 66 69 6c 65 73 2d 72 65 61 64 2d 3e 73 (files-read->s
53b0: 74 72 69 6e 67 20 22 2f 68 6f 6d 65 2f 6d 61 74 tring "/home/mat
53c0: 74 2f 6b 69 61 74 6f 61 2f 73 74 6d 6c 2f 73 75 t/kiatoa/stml/su
53d0: 67 61 72 2e 73 63 6d 22 20 0a 09 3b 3b 20 09 09 gar.scm" ..;; ..
53e0: 09 09 76 69 65 77 29 29 29 29 0a 09 3b 3b 20 20 ..view))))..;;
53f0: 20 28 6d 61 70 20 0a 09 3b 3b 20 20 20 20 28 6c (map ..;; (l
5400: 61 6d 62 64 61 20 28 78 29 0a 09 3b 3b 20 20 20 ambda (x)..;;
5410: 20 20 20 28 63 6f 6e 64 0a 09 3b 3b 20 20 20 20 (cond..;;
5420: 20 20 20 28 28 6c 69 73 74 3f 20 78 29 20 78 29 ((list? x) x)
5430: 0a 09 3b 3b 20 20 20 20 20 20 20 28 28 73 74 72 ..;; ((str
5440: 69 6e 67 3f 20 78 29 20 78 29 0a 09 3b 3b 20 20 ing? x) x)..;;
5450: 20 20 20 20 20 28 65 6c 73 65 20 27 28 29 29 29 (else '()))
5460: 29 0a 09 3b 3b 20 20 20 20 28 70 6f 72 74 2d 6d )..;; (port-m
5470: 61 70 20 65 76 61 6c 20 28 6c 61 6d 62 64 61 20 ap eval (lambda
5480: 28 29 0a 09 3b 3b 20 09 09 20 28 72 65 61 64 20 ()..;; .. (read
5490: 69 6e 70 29 29 29 29 29 0a 09 3b 3b 0a 09 3b 3b inp)))))..;;..;;
54a0: 20 6f 70 74 69 6f 6e 20 74 77 6f 3a 0a 09 3b 3b option two:..;;
54b0: 0a 09 28 6c 65 74 2a 20 28 3b 3b 20 28 69 6e 70 ..(let* (;; (inp
54c0: 73 20 28 6d 61 70 20 6f 70 65 6e 2d 69 6e 70 75 s (map open-inpu
54d0: 74 2d 66 69 6c 65 20 28 6c 69 73 74 20 76 69 65 t-file (list vie
54e0: 77 29 29 29 20 3b 3b 20 73 75 67 61 72 20 76 69 w))) ;; sugar vi
54f0: 65 77 29 29 29 0a 09 20 20 20 20 20 20 20 28 70 ew))).. (p
5500: 20 20 20 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d (open-input-
5510: 66 69 6c 65 20 76 69 65 77 29 29 20 3b 3b 20 28 file view)) ;; (
5520: 61 70 70 6c 79 20 6d 61 6b 65 2d 63 6f 6e 63 61 apply make-conca
5530: 74 65 6e 61 74 65 64 2d 70 6f 72 74 20 69 6e 70 tenated-port inp
5540: 73 29 29 0a 09 20 20 20 20 20 20 20 28 64 61 74 s)).. (dat
5550: 20 20 28 6d 61 70 20 0a 09 09 20 20 20 20 20 20 (map ...
5560: 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 09 28 (lambda (x)....(
5570: 63 6f 6e 64 0a 09 09 09 20 28 28 6c 69 73 74 3f cond.... ((list?
5580: 20 78 29 20 78 29 0a 09 09 09 20 28 28 73 74 72 x) x).... ((str
5590: 69 6e 67 3f 20 78 29 20 78 29 0a 09 09 09 20 28 ing? x) x).... (
55a0: 65 6c 73 65 20 27 28 29 29 29 29 0a 09 09 20 20 else '())))...
55b0: 20 20 20 20 28 70 6f 72 74 2d 6d 61 70 20 65 76 (port-map ev
55c0: 61 6c 20 28 6c 61 6d 62 64 61 20 28 29 28 72 65 al (lambda ()(re
55d0: 61 64 20 70 29 29 29 29 29 29 0a 09 20 20 3b 3b ad p)))))).. ;;
55e0: 20 28 6d 61 70 20 63 6c 6f 73 65 2d 69 6e 70 75 (map close-inpu
55f0: 74 2d 70 6f 72 74 20 69 6e 70 73 29 0a 09 20 20 t-port inps)..
5600: 28 63 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 6f 72 (close-input-por
5610: 74 20 70 29 0a 09 20 20 64 61 74 29 0a 09 28 6c t p).. dat)..(l
5620: 69 73 74 20 22 3c 70 3e 50 61 67 65 20 6e 6f 74 ist "<p>Page not
5630: 20 66 6f 75 6e 64 20 22 20 70 61 67 65 20 22 20 found " page "
5640: 3c 2f 70 3e 22 29 29 29 29 0a 0a 28 64 65 66 69 </p>"))))..(defi
5650: 6e 65 2d 6d 65 74 68 6f 64 20 28 73 65 73 73 69 ne-method (sessi
5660: 6f 6e 3a 63 61 6c 6c 20 28 73 65 6c 66 20 3c 73 on:call (self <s
5670: 65 73 73 69 6f 6e 3e 29 20 70 61 67 65 29 0a 20 ession>) page).
5680: 20 28 73 65 73 73 69 6f 6e 3a 63 61 6c 6c 2d 70 (session:call-p
5690: 61 72 74 73 20 73 65 6c 66 20 70 61 67 65 20 27 arts self page '
56a0: 62 6f 74 68 29 29 0a 0a 28 64 65 66 69 6e 65 2d both))..(define-
56b0: 6d 65 74 68 6f 64 20 28 73 65 73 73 69 6f 6e 3a method (session:
56c0: 63 61 6c 6c 20 28 73 65 6c 66 20 3c 73 65 73 73 call (self <sess
56d0: 69 6f 6e 3e 29 20 70 61 67 65 20 70 61 72 74 73 ion>) page parts
56e0: 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a 63 61 6c ). (session:cal
56f0: 6c 2d 70 61 72 74 73 20 73 65 6c 66 20 70 61 67 l-parts self pag
5700: 65 20 27 62 6f 74 68 29 29 0a 0a 28 64 65 66 69 e 'both))..(defi
5710: 6e 65 2d 6d 65 74 68 6f 64 20 28 73 65 73 73 69 ne-method (sessi
5720: 6f 6e 3a 6c 6f 61 64 2d 6d 6f 64 65 6c 20 28 73 on:load-model (s
5730: 65 6c 66 20 3c 73 65 73 73 69 6f 6e 3e 29 20 6d elf <session>) m
5740: 6f 64 65 6c 29 0a 20 20 28 6c 65 74 20 28 28 6d odel). (let ((m
5750: 6f 64 65 6c 2e 73 63 6d 20 28 73 74 72 69 6e 67 odel.scm (string
5760: 2d 61 70 70 65 6e 64 20 28 73 6c 6f 74 2d 72 65 -append (slot-re
5770: 66 20 73 65 6c 66 20 27 73 72 6f 6f 74 29 20 22 f self 'sroot) "
5780: 2f 6d 6f 64 65 6c 73 2f 22 20 6d 6f 64 65 6c 20 /models/" model
5790: 22 2e 73 63 6d 22 29 29 0a 09 28 6d 6f 64 65 6c ".scm"))..(model
57a0: 2e 73 6f 20 20 28 73 74 72 69 6e 67 2d 61 70 70 .so (string-app
57b0: 65 6e 64 20 28 73 6c 6f 74 2d 72 65 66 20 73 65 end (slot-ref se
57c0: 6c 66 20 27 73 72 6f 6f 74 29 20 22 2f 6d 6f 64 lf 'sroot) "/mod
57d0: 65 6c 73 2f 22 20 6d 6f 64 65 6c 20 22 2e 73 6f els/" model ".so
57e0: 22 29 29 29 0a 20 20 20 20 28 69 66 20 28 66 69 "))). (if (fi
57f0: 6c 65 2d 65 78 69 73 74 73 3f 20 6d 6f 64 65 6c le-exists? model
5800: 2e 73 6f 29 0a 09 28 6c 6f 61 64 20 6d 6f 64 65 .so)..(load mode
5810: 6c 2e 73 6f 29 0a 09 28 69 66 20 28 66 69 6c 65 l.so)..(if (file
5820: 2d 65 78 69 73 74 73 3f 20 6d 6f 64 65 6c 2e 73 -exists? model.s
5830: 63 6d 29 0a 09 20 20 20 20 28 6c 6f 61 64 20 6d cm).. (load m
5840: 6f 64 65 6c 2e 73 63 6d 29 0a 09 20 20 20 20 28 odel.scm).. (
5850: 73 3a 6c 6f 67 20 22 45 52 52 4f 52 3a 20 6d 6f s:log "ERROR: mo
5860: 64 65 6c 20 22 20 6d 6f 64 65 6c 2e 73 63 6d 20 del " model.scm
5870: 22 20 6e 6f 74 20 66 6f 75 6e 64 22 29 29 29 29 " not found"))))
5880: 29 0a 0a 28 64 65 66 69 6e 65 2d 6d 65 74 68 6f )..(define-metho
5890: 64 20 28 73 65 73 73 69 6f 6e 3a 6d 6f 64 65 6c d (session:model
58a0: 2d 70 61 74 68 20 28 73 65 6c 66 20 3c 73 65 73 -path (self <ses
58b0: 73 69 6f 6e 3e 29 20 6d 6f 64 65 6c 29 0a 20 20 sion>) model).
58c0: 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 28 (string-append (
58d0: 73 6c 6f 74 2d 72 65 66 20 73 65 6c 66 20 27 73 slot-ref self 's
58e0: 72 6f 6f 74 29 20 22 2f 6d 6f 64 65 6c 73 2f 22 root) "/models/"
58f0: 20 6d 6f 64 65 6c 20 22 2e 73 63 6d 22 29 29 0a model ".scm")).
5900: 0a 28 64 65 66 69 6e 65 2d 6d 65 74 68 6f 64 20 .(define-method
5910: 28 73 65 73 73 69 6f 6e 3a 70 70 2d 66 6f 72 6d (session:pp-form
5920: 64 61 74 20 28 73 65 6c 66 20 3c 73 65 73 73 69 dat (self <sessi
5930: 6f 6e 3e 29 29 0a 20 20 28 6c 65 74 20 28 28 64 on>)). (let ((d
5940: 61 74 20 28 66 6f 72 6d 64 61 74 3a 61 6c 6c 2d at (formdat:all-
5950: 3e 73 74 72 69 6e 67 73 20 28 73 6c 6f 74 2d 72 >strings (slot-r
5960: 65 66 20 73 65 6c 66 20 27 66 6f 72 6d 64 61 74 ef self 'formdat
5970: 29 29 29 29 0a 20 20 20 20 28 73 74 72 69 6e 67 )))). (string
5980: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 64 61 74 -intersperse dat
5990: 20 22 3c 62 72 3e 20 22 29 29 29 0a 0a 28 64 65 "<br> ")))..(de
59a0: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 70 61 fine (session:pa
59b0: 72 61 6d 2d 3e 73 74 72 69 6e 67 20 70 61 72 61 ram->string para
59c0: 6d 73 29 0a 20 20 3b 3b 20 28 65 72 72 3a 6c 6f ms). ;; (err:lo
59d0: 67 20 22 70 61 72 61 6d 73 3d 22 20 70 61 72 61 g "params=" para
59e0: 6d 73 29 0a 20 20 28 69 66 20 28 3c 20 28 6c 65 ms). (if (< (le
59f0: 6e 67 74 68 20 70 61 72 61 6d 73 29 20 31 29 0a ngth params) 1).
5a00: 20 20 20 20 20 20 22 22 0a 20 20 20 20 20 20 28 "". (
5a10: 6c 65 74 20 6c 6f 6f 70 20 28 28 6b 65 79 20 28 let loop ((key (
5a20: 63 61 72 20 70 61 72 61 6d 73 29 29 0a 09 09 20 car params))...
5a30: 28 76 61 6c 20 28 63 61 64 72 20 70 61 72 61 6d (val (cadr param
5a40: 73 29 29 0a 09 09 20 28 74 61 69 6c 20 28 63 64 s))... (tail (cd
5a50: 64 72 20 70 61 72 61 6d 73 29 29 0a 09 09 20 28 dr params))... (
5a60: 72 65 73 75 6c 74 20 27 28 29 29 29 0a 09 28 6c result '()))..(l
5a70: 65 74 20 28 28 6e 65 77 72 65 73 75 6c 74 20 28 et ((newresult (
5a80: 63 6f 6e 73 20 28 73 74 72 69 6e 67 2d 61 70 70 cons (string-app
5a90: 65 6e 64 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 end (s:any->stri
5aa0: 6e 67 20 6b 65 79 29 20 22 3d 22 20 28 73 3a 61 ng key) "=" (s:a
5ab0: 6e 79 2d 3e 73 74 72 69 6e 67 20 76 61 6c 29 29 ny->string val))
5ac0: 0a 09 09 09 20 20 20 20 20 20 20 72 65 73 75 6c .... resul
5ad0: 74 29 29 29 0a 09 20 20 28 69 66 20 28 3c 20 28 t))).. (if (< (
5ae0: 6c 65 6e 67 74 68 20 74 61 69 6c 29 20 31 29 20 length tail) 1)
5af0: 3b 3b 20 74 72 75 65 20 69 66 20 64 6f 6e 65 0a ;; true if done.
5b00: 09 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 69 . (string-i
5b10: 6e 74 65 72 73 70 65 72 73 65 20 6e 65 77 72 65 ntersperse newre
5b20: 73 75 6c 74 20 22 26 22 29 0a 09 20 20 20 20 20 sult "&")..
5b30: 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 69 6c (loop (car tail
5b40: 29 28 63 61 64 72 20 74 61 69 6c 29 28 63 64 64 )(cadr tail)(cdd
5b50: 72 20 74 61 69 6c 29 20 6e 65 77 72 65 73 75 6c r tail) newresul
5b60: 74 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 t))))))..(define
5b70: 2d 6d 65 74 68 6f 64 20 28 73 65 73 73 69 6f 6e -method (session
5b80: 3a 6c 69 6e 6b 2d 74 6f 20 28 73 65 6c 66 20 3c :link-to (self <
5b90: 73 65 73 73 69 6f 6e 3e 29 20 70 61 67 65 20 70 session>) page p
5ba0: 61 72 61 6d 73 29 0a 20 20 28 6c 65 74 2a 20 28 arams). (let* (
5bb0: 28 73 65 72 76 65 72 20 20 20 20 28 69 66 20 28 (server (if (
5bc0: 67 65 74 65 6e 76 20 22 48 54 54 50 5f 48 4f 53 getenv "HTTP_HOS
5bd0: 54 22 29 0a 09 09 09 28 67 65 74 65 6e 76 20 22 T")....(getenv "
5be0: 48 54 54 50 5f 48 4f 53 54 22 29 0a 09 09 09 28 HTTP_HOST")....(
5bf0: 67 65 74 65 6e 76 20 22 53 45 52 56 45 52 5f 4e getenv "SERVER_N
5c00: 41 4d 45 22 29 29 29 0a 09 20 28 73 63 72 69 70 AME"))).. (scrip
5c10: 74 20 28 6c 65 74 20 28 28 73 63 72 69 70 74 2d t (let ((script-
5c20: 6e 61 6d 65 20 28 73 74 72 69 6e 67 2d 73 70 6c name (string-spl
5c30: 69 74 20 28 67 65 74 65 6e 76 20 22 53 43 52 49 it (getenv "SCRI
5c40: 50 54 5f 4e 41 4d 45 22 29 20 22 2f 22 29 29 29 PT_NAME") "/")))
5c50: 0a 09 09 20 20 20 28 69 66 20 28 3e 20 28 6c 65 ... (if (> (le
5c60: 6e 67 74 68 20 73 63 72 69 70 74 2d 6e 61 6d 65 ngth script-name
5c70: 29 20 31 29 0a 09 09 20 20 20 20 20 20 20 28 73 ) 1)... (s
5c80: 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 28 63 61 tring-append (ca
5c90: 72 20 73 63 72 69 70 74 2d 6e 61 6d 65 29 20 22 r script-name) "
5ca0: 2f 22 20 28 63 61 64 72 20 73 63 72 69 70 74 2d /" (cadr script-
5cb0: 6e 61 6d 65 29 29 0a 09 09 20 20 20 20 20 20 20 name))...
5cc0: 28 67 65 74 65 6e 76 20 22 53 43 52 49 50 54 5f (getenv "SCRIPT_
5cd0: 4e 41 4d 45 22 29 29 29 29 20 3b 3b 20 62 75 69 NAME")))) ;; bui
5ce0: 6c 64 20 73 63 72 69 70 74 20 6e 61 6d 65 20 66 ld script name f
5cf0: 72 6f 6d 20 66 69 72 73 74 20 74 77 6f 20 65 6c rom first two el
5d00: 65 6d 65 6e 74 73 2e 20 54 68 69 73 20 69 73 20 ements. This is
5d10: 61 20 68 61 6e 67 6f 76 65 72 20 66 72 6f 6d 20 a hangover from
5d20: 62 65 66 6f 72 65 20 49 20 75 73 65 64 20 3f 20 before I used ?
5d30: 69 6e 20 74 68 65 20 55 52 4c 2e 0a 09 20 28 73 in the URL... (s
5d40: 65 73 73 69 6f 6e 2d 6b 65 79 20 28 73 6c 6f 74 ession-key (slot
5d50: 2d 72 65 66 20 73 65 6c 66 20 27 73 65 73 73 69 -ref self 'sessi
5d60: 6f 6e 2d 6b 65 79 29 29 0a 09 20 28 70 61 72 61 on-key)).. (para
5d70: 6d 73 74 72 20 28 73 65 73 73 69 6f 6e 3a 70 61 mstr (session:pa
5d80: 72 61 6d 2d 3e 73 74 72 69 6e 67 20 70 61 72 61 ram->string para
5d90: 6d 73 29 29 29 0a 20 20 20 20 3b 3b 20 28 73 65 ms))). ;; (se
5da0: 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 ssion:log self "
5db0: 73 65 72 76 65 72 3d 22 20 73 65 72 76 65 72 20 server=" server
5dc0: 22 20 73 63 72 69 70 74 3d 22 20 73 63 72 69 70 " script=" scrip
5dd0: 74 20 22 20 70 61 67 65 3d 22 20 70 61 67 65 29 t " page=" page)
5de0: 0a 20 20 20 20 28 73 74 72 69 6e 67 2d 61 70 70 . (string-app
5df0: 65 6e 64 20 22 68 74 74 70 3a 2f 2f 22 20 73 65 end "http://" se
5e00: 72 76 65 72 20 22 2f 22 20 73 63 72 69 70 74 20 rver "/" script
5e10: 22 2f 22 20 70 61 67 65 20 22 3f 22 20 70 61 72 "/" page "?" par
5e20: 61 6d 73 74 72 29 29 29 20 3b 3b 20 22 2f 73 6e amstr))) ;; "/sn
5e30: 3d 22 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 =" session-key))
5e40: 29 0a 0a 28 64 65 66 69 6e 65 2d 6d 65 74 68 6f )..(define-metho
5e50: 64 20 28 73 65 73 73 69 6f 6e 3a 63 67 69 2d 6f d (session:cgi-o
5e60: 75 74 20 28 73 65 6c 66 20 3c 73 65 73 73 69 6f ut (self <sessio
5e70: 6e 3e 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 63 n>)). (let* ((c
5e80: 6f 6e 74 65 6e 74 20 20 28 6c 69 73 74 20 28 73 ontent (list (s
5e90: 6c 6f 74 2d 72 65 66 20 73 65 6c 66 20 27 63 6f lot-ref self 'co
5ea0: 6e 74 65 6e 74 2d 74 79 70 65 29 29 29 20 3b 3b ntent-type))) ;;
5eb0: 20 27 28 22 43 6f 6e 74 65 6e 74 2d 74 79 70 65 '("Content-type
5ec0: 3a 20 74 65 78 74 2f 68 74 6d 6c 3b 20 63 68 61 : text/html; cha
5ed0: 72 73 65 74 3d 69 73 6f 2d 38 38 35 39 2d 31 5c rset=iso-8859-1\
5ee0: 6e 5c 6e 22 29 29 0a 09 20 28 68 65 61 64 65 72 n\n")).. (header
5ef0: 20 20 20 28 6c 65 74 20 28 28 63 6f 6f 6b 69 65 (let ((cookie
5f00: 20 28 73 6c 6f 74 2d 72 65 66 20 73 65 6c 66 20 (slot-ref self
5f10: 27 73 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 29 'session-cookie)
5f20: 29 29 0a 09 09 20 20 20 20 20 28 69 66 20 63 6f ))... (if co
5f30: 6f 6b 69 65 0a 09 09 09 20 28 63 6f 6e 73 20 28 okie.... (cons (
5f40: 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 22 53 string-append "S
5f50: 65 74 2d 43 6f 6f 6b 69 65 3a 20 22 20 28 63 61 et-Cookie: " (ca
5f60: 72 20 63 6f 6f 6b 69 65 29 29 0a 09 09 09 20 20 r cookie))....
5f70: 20 20 20 20 20 63 6f 6e 74 65 6e 74 29 0a 09 09 content)...
5f80: 09 20 63 6f 6e 74 65 6e 74 29 29 29 0a 09 20 28 . content))).. (
5f90: 70 61 67 65 64 61 74 20 20 28 73 6c 6f 74 2d 72 pagedat (slot-r
5fa0: 65 66 20 73 65 6c 66 20 27 70 61 67 65 64 61 74 ef self 'pagedat
5fb0: 29 29 29 0a 20 20 20 20 28 73 3a 63 67 69 2d 6f ))). (s:cgi-o
5fc0: 75 74 20 0a 20 20 20 20 20 28 63 6f 6e 73 20 68 ut . (cons h
5fd0: 65 61 64 65 72 20 70 61 67 65 64 61 74 29 29 29 eader pagedat)))
5fe0: 29 0a 0a 28 64 65 66 69 6e 65 2d 6d 65 74 68 6f )..(define-metho
5ff0: 64 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 28 d (session:log (
6000: 73 65 6c 66 20 3c 73 65 73 73 69 6f 6e 3e 29 20 self <session>)
6010: 2e 20 6d 73 67 29 0a 20 20 28 77 69 74 68 2d 6f . msg). (with-o
6020: 75 74 70 75 74 2d 74 6f 2d 70 6f 72 74 20 28 73 utput-to-port (s
6030: 6c 6f 74 2d 72 65 66 20 73 65 6c 66 20 27 6c 6f lot-ref self 'lo
6040: 67 2d 70 6f 72 74 29 20 3b 3b 20 28 73 6c 6f 74 g-port) ;; (slot
6050: 2d 72 65 66 20 73 65 6c 66 20 27 6c 6f 67 70 74 -ref self 'logpt
6060: 29 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 ). (lambda ()
6070: 20 0a 20 20 20 20 20 20 28 61 70 70 6c 79 20 70 . (apply p
6080: 72 69 6e 74 20 6d 73 67 29 29 29 29 0a 0a 28 64 rint msg))))..(d
6090: 65 66 69 6e 65 2d 6d 65 74 68 6f 64 20 28 73 65 efine-method (se
60a0: 73 73 69 6f 6e 3a 67 65 74 2d 70 61 72 61 6d 20 ssion:get-param
60b0: 28 73 65 6c 66 20 3c 73 65 73 73 69 6f 6e 3e 29 (self <session>)
60c0: 20 6b 65 79 29 0a 20 20 3b 3b 20 28 73 65 73 73 key). ;; (sess
60d0: 69 6f 6e 3a 6c 6f 67 20 73 3a 73 65 73 73 69 6f ion:log s:sessio
60e0: 6e 20 22 70 61 72 61 6d 73 3d 22 20 28 73 6c 6f n "params=" (slo
60f0: 74 2d 72 65 66 20 73 3a 73 65 73 73 69 6f 6e 20 t-ref s:session
6100: 27 70 61 72 61 6d 73 29 29 0a 20 20 28 6c 65 74 'params)). (let
6110: 20 28 28 70 61 72 61 6d 73 20 28 73 6c 6f 74 2d ((params (slot-
6120: 72 65 66 20 73 65 6c 66 20 27 70 61 72 61 6d 73 ref self 'params
6130: 29 29 29 0a 20 20 20 20 28 73 65 73 73 69 6f 6e ))). (session
6140: 3a 67 65 74 2d 70 61 72 61 6d 2d 66 72 6f 6d 20 :get-param-from
6150: 70 61 72 61 6d 73 20 6b 65 79 29 29 29 0a 0a 3b params key)))..;
6160: 3b 20 54 68 69 73 20 6f 6e 65 20 77 69 6c 6c 20 ; This one will
6170: 67 65 74 20 74 68 65 20 66 69 72 73 74 20 76 61 get the first va
6180: 6c 75 65 20 66 6f 75 6e 64 20 72 65 67 61 72 64 lue found regard
6190: 6c 65 73 73 20 6f 66 20 66 6f 72 6d 0a 28 64 65 less of form.(de
61a0: 66 69 6e 65 2d 6d 65 74 68 6f 64 20 28 73 65 73 fine-method (ses
61b0: 73 69 6f 6e 3a 67 65 74 2d 69 6e 70 75 74 20 28 sion:get-input (
61c0: 73 65 6c 66 20 3c 73 65 73 73 69 6f 6e 3e 29 20 self <session>)
61d0: 6b 65 79 29 0a 20 20 28 6c 65 74 2a 20 28 28 66 key). (let* ((f
61e0: 6f 72 6d 64 61 74 20 28 73 6c 6f 74 2d 72 65 66 ormdat (slot-ref
61f0: 20 73 65 6c 66 20 27 66 6f 72 6d 64 61 74 29 29 self 'formdat))
6200: 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 66 ). (if (not f
6210: 6f 72 6d 64 61 74 29 20 23 66 0a 09 28 69 66 20 ormdat) #f..(if
6220: 28 6f 72 20 28 73 74 72 69 6e 67 3f 20 6b 65 79 (or (string? key
6230: 29 28 6e 75 6d 62 65 72 3f 20 6b 65 79 29 28 73 )(number? key)(s
6240: 79 6d 62 6f 6c 3f 20 6b 65 79 29 29 0a 09 20 20 ymbol? key))..
6250: 20 20 28 69 66 20 28 65 71 3f 20 28 63 6c 61 73 (if (eq? (clas
6260: 73 2d 6f 66 20 66 6f 72 6d 64 61 74 29 20 3c 66 s-of formdat) <f
6270: 6f 72 6d 64 61 74 3e 29 0a 09 09 28 66 6f 72 6d ormdat>)...(form
6280: 64 61 74 3a 67 65 74 20 66 6f 72 6d 64 61 74 20 dat:get formdat
6290: 6b 65 79 29 0a 09 09 28 62 65 67 69 6e 0a 09 09 key)...(begin...
62a0: 20 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 (session:log s
62b0: 65 6c 66 20 22 45 52 52 4f 52 3a 20 66 6f 72 6d elf "ERROR: form
62c0: 64 61 74 3a 20 22 20 66 6f 72 6d 64 61 74 20 22 dat: " formdat "
62d0: 20 69 73 20 6e 6f 74 20 6f 66 20 63 6c 61 73 73 is not of class
62e0: 20 3c 66 6f 72 6d 64 61 74 3e 22 29 0a 09 09 20 <formdat>")...
62f0: 20 23 66 29 29 0a 09 20 20 20 20 28 73 65 73 73 #f)).. (sess
6300: 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 45 52 ion:log self "ER
6310: 52 4f 52 3a 20 62 61 64 20 6b 65 79 20 22 20 6b ROR: bad key " k
6320: 65 79 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 ey)))))..(define
6330: 2d 6d 65 74 68 6f 64 20 28 73 65 73 73 69 6f 6e -method (session
6340: 3a 72 75 6e 2d 61 63 74 69 6f 6e 73 20 28 73 65 :run-actions (se
6350: 6c 66 20 3c 73 65 73 73 69 6f 6e 3e 29 29 0a 20 lf <session>)).
6360: 20 28 6c 65 74 2a 20 28 28 61 63 74 69 6f 6e 20 (let* ((action
6370: 20 20 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d (session:get-
6380: 70 61 72 61 6d 20 73 65 6c 66 20 27 61 63 74 69 param self 'acti
6390: 6f 6e 29 29 0a 09 20 28 70 61 67 65 20 20 20 20 on)).. (page
63a0: 20 20 28 73 6c 6f 74 2d 72 65 66 20 73 65 6c 66 (slot-ref self
63b0: 20 27 70 61 67 65 29 29 29 0a 20 20 20 20 3b 3b 'page))). ;;
63c0: 20 28 70 72 69 6e 74 20 22 61 63 74 69 6f 6e 3d (print "action=
63d0: 22 20 61 63 74 69 6f 6e 20 22 20 70 61 67 65 3d " action " page=
63e0: 22 20 70 61 67 65 29 0a 20 20 20 20 28 69 66 20 " page). (if
63f0: 61 63 74 69 6f 6e 0a 09 28 6c 65 74 20 28 28 61 action..(let ((a
6400: 63 74 69 6f 6e 2d 6c 73 74 20 20 28 73 74 72 69 ction-lst (stri
6410: 6e 67 2d 73 70 6c 69 74 20 61 63 74 69 6f 6e 20 ng-split action
6420: 22 2e 22 29 29 29 0a 09 20 20 3b 3b 20 28 70 72 "."))).. ;; (pr
6430: 69 6e 74 20 22 61 63 74 69 6f 6e 2d 6c 73 74 3d int "action-lst=
6440: 22 20 61 63 74 69 6f 6e 2d 6c 73 74 29 0a 09 20 " action-lst)..
6450: 20 28 69 66 20 28 6e 6f 74 20 28 3d 20 28 6c 65 (if (not (= (le
6460: 6e 67 74 68 20 61 63 74 69 6f 6e 2d 6c 73 74 29 ngth action-lst)
6470: 20 32 29 29 20 0a 09 20 20 20 20 20 20 28 65 72 2)) .. (er
6480: 72 3a 6c 6f 67 20 22 41 63 74 69 6f 6e 20 73 68 r:log "Action sh
6490: 6f 75 6c 64 20 62 65 20 6f 66 20 66 6f 72 6d 3a ould be of form:
64a0: 20 6d 6f 64 75 6c 65 2e 61 63 74 69 6f 6e 22 29 module.action")
64b0: 0a 09 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 .. (let* ((
64c0: 74 61 72 67 2d 70 61 67 65 20 20 20 28 63 61 72 targ-page (car
64d0: 20 61 63 74 69 6f 6e 2d 6c 73 74 29 29 0a 09 09 action-lst))...
64e0: 20 20 20 20 20 28 70 72 6f 63 2d 6e 61 6d 65 20 (proc-name
64f0: 20 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 (string-append
6500: 20 74 61 72 67 2d 70 61 67 65 20 22 2d 61 63 74 targ-page "-act
6510: 69 6f 6e 22 29 29 0a 09 09 20 20 20 20 20 28 74 ion"))... (t
6520: 61 72 67 2d 61 63 74 69 6f 6e 20 28 63 61 64 72 arg-action (cadr
6530: 20 61 63 74 69 6f 6e 2d 6c 73 74 29 29 29 0a 09 action-lst)))..
6540: 09 3b 3b 20 28 65 72 72 3a 6c 6f 67 20 22 74 61 .;; (err:log "ta
6550: 72 67 2d 70 61 67 65 3d 22 20 74 61 72 67 2d 70 rg-page=" targ-p
6560: 61 67 65 20 22 20 70 72 6f 63 2d 6e 61 6d 65 3d age " proc-name=
6570: 22 20 70 72 6f 63 2d 6e 61 6d 65 20 22 20 74 61 " proc-name " ta
6580: 72 67 2d 61 63 74 69 6f 6e 3d 22 20 74 61 72 67 rg-action=" targ
6590: 2d 61 63 74 69 6f 6e 29 0a 0a 09 09 3b 3b 20 63 -action)....;; c
65a0: 61 6c 6c 20 68 65 72 65 20 6f 6e 6c 79 20 69 66 all here only if
65b0: 20 6e 65 76 65 72 20 63 61 6c 6c 65 64 20 62 65 never called be
65c0: 66 6f 72 65 0a 09 09 28 69 66 20 28 73 65 73 73 fore...(if (sess
65d0: 69 6f 6e 3a 6e 65 76 65 72 2d 63 61 6c 6c 65 64 ion:never-called
65e0: 2d 70 61 67 65 3f 20 73 65 6c 66 20 74 61 72 67 -page? self targ
65f0: 2d 70 61 67 65 29 0a 09 09 20 20 20 20 28 73 65 -page)... (se
6600: 73 73 69 6f 6e 3a 63 61 6c 6c 2d 70 61 72 74 73 ssion:call-parts
6610: 20 73 65 6c 66 20 74 61 72 67 2d 70 61 67 65 20 self targ-page
6620: 27 63 6f 6e 74 72 6f 6c 29 29 0a 09 09 3b 3b 20 'control))...;;
6630: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6640: 20 20 20 70 72 6f 63 20 20 20 20 20 20 20 20 20 proc
6650: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6660: 61 63 74 69 6f 6e 20 20 20 20 0a 0a 09 09 28 69 action ....(i
6670: 66 20 23 74 20 3b 3b 20 73 65 74 20 74 6f 20 23 f #t ;; set to #
6680: 74 20 74 6f 20 73 65 65 20 62 65 74 74 65 72 20 t to see better
6690: 65 72 72 6f 72 20 6d 65 73 73 61 67 65 73 20 64 error messages d
66a0: 75 72 69 6e 67 20 64 65 62 75 67 67 69 6e 20 3a uring debuggin :
66b0: 2d 29 0a 09 09 20 20 20 20 28 28 65 76 61 6c 20 -)... ((eval
66c0: 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 (string->symbol
66d0: 70 72 6f 63 2d 6e 61 6d 65 29 29 20 74 61 72 67 proc-name)) targ
66e0: 2d 61 63 74 69 6f 6e 29 20 3b 3b 20 75 6e 73 61 -action) ;; unsa
66f0: 66 65 20 65 78 65 63 75 74 69 6f 6e 0a 09 09 20 fe execution...
6700: 20 20 20 28 63 6f 6e 64 69 74 69 6f 6e 2d 63 61 (condition-ca
6710: 73 65 20 28 28 65 76 61 6c 20 28 73 74 72 69 6e se ((eval (strin
6720: 67 2d 3e 73 79 6d 62 6f 6c 20 70 72 6f 63 2d 6e g->symbol proc-n
6730: 61 6d 65 29 29 20 74 61 72 67 2d 61 63 74 69 6f ame)) targ-actio
6740: 6e 29 0a 09 09 09 09 20 20 20 20 28 28 65 78 6e n)..... ((exn
6750: 20 66 69 6c 65 29 20 28 73 3a 6c 6f 67 20 22 66 file) (s:log "f
6760: 69 6c 65 20 65 72 72 6f 72 22 29 29 0a 09 09 09 ile error"))....
6770: 09 20 20 20 20 28 28 65 78 6e 20 69 2f 6f 29 20 . ((exn i/o)
6780: 20 28 73 3a 6c 6f 67 20 22 69 2f 6f 20 65 72 72 (s:log "i/o err
6790: 6f 72 22 29 29 0a 09 09 09 09 20 20 20 20 28 28 or"))..... ((
67a0: 65 78 6e 20 29 20 20 20 20 20 28 73 3a 6c 6f 67 exn ) (s:log
67b0: 20 22 41 63 74 69 6f 6e 20 6e 6f 74 20 69 6d 70 "Action not imp
67c0: 6c 65 6d 65 6e 74 65 64 3a 20 22 20 70 72 6f 63 lemented: " proc
67d0: 2d 6e 61 6d 65 20 22 20 61 63 74 69 6f 6e 3a 20 -name " action:
67e0: 22 20 74 61 72 67 2d 61 63 74 69 6f 6e 29 29 0a " targ-action)).
67f0: 09 09 09 09 20 20 20 20 28 76 61 72 20 28 29 20 .... (var ()
6800: 20 20 20 20 28 73 3a 6c 6f 67 20 22 55 6e 6b 6e (s:log "Unkn
6810: 6f 77 6e 20 45 72 72 6f 72 22 29 29 29 29 29 29 own Error"))))))
6820: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 2d 6d 65 ))))..(define-me
6830: 74 68 6f 64 20 28 73 65 73 73 69 6f 6e 3a 6e 65 thod (session:ne
6840: 76 65 72 2d 63 61 6c 6c 65 64 2d 70 61 67 65 3f ver-called-page?
6850: 20 28 73 65 6c 66 20 3c 73 65 73 73 69 6f 6e 3e (self <session>
6860: 29 20 70 61 67 65 29 0a 20 20 28 73 65 73 73 69 ) page). (sessi
6870: 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 43 68 65 on:log self "Che
6880: 63 6b 69 6e 67 20 66 6f 72 20 70 61 67 65 3a 20 cking for page:
6890: 22 20 70 61 67 65 29 0a 20 20 28 6e 6f 74 20 28 " page). (not (
68a0: 6d 65 6d 62 65 72 20 70 61 67 65 20 28 73 6c 6f member page (slo
68b0: 74 2d 72 65 66 20 73 65 6c 66 20 27 73 65 65 6e t-ref self 'seen
68c0: 2d 70 61 67 65 73 29 29 29 29 0a 0a 28 64 65 66 -pages))))..(def
68d0: 69 6e 65 2d 6d 65 74 68 6f 64 20 28 73 65 73 73 ine-method (sess
68e0: 69 6f 6e 3a 73 65 74 2d 63 61 6c 6c 65 64 21 20 ion:set-called!
68f0: 28 73 65 6c 66 20 3c 73 65 73 73 69 6f 6e 3e 29 (self <session>)
6900: 20 70 61 67 65 29 0a 20 20 28 73 6c 6f 74 2d 73 page). (slot-s
6910: 65 74 21 20 73 65 6c 66 20 27 73 65 65 6e 2d 70 et! self 'seen-p
6920: 61 67 65 73 20 28 63 6f 6e 73 20 70 61 67 65 20 ages (cons page
6930: 28 73 6c 6f 74 2d 72 65 66 20 73 65 6c 66 20 27 (slot-ref self '
6940: 73 65 65 6e 2d 70 61 67 65 73 29 29 29 29 0a 0a seen-pages))))..
6950: 3b 3b 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 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6990: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 41 6c 74 65 ========.;; Alte
69a0: 72 6e 61 74 69 76 65 20 64 61 74 61 20 74 79 70 rnative data typ
69b0: 65 20 64 65 6c 69 76 65 72 79 0a 3b 3b 3d 3d 3d e delivery.;;===
69c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
69d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
69e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
69f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6a00: 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 2d 6d 65 74 ===..(define-met
6a10: 68 6f 64 20 28 73 65 73 73 69 6f 6e 3a 61 6c 74 hod (session:alt
6a20: 2d 6f 75 74 20 28 73 65 6c 66 20 3c 73 65 73 73 -out (self <sess
6a30: 69 6f 6e 3e 29 29 0a 20 20 28 6c 65 74 20 28 28 ion>)). (let ((
6a40: 64 61 74 20 28 73 6c 6f 74 2d 72 65 66 20 73 65 dat (slot-ref se
6a50: 6c 66 20 27 61 6c 74 2d 70 61 67 65 2d 64 61 74 lf 'alt-page-dat
6a60: 29 29 29 0a 20 20 20 20 3b 3b 20 28 73 3a 6c 6f ))). ;; (s:lo
6a70: 67 20 22 64 61 74 20 69 73 3a 20 22 20 64 61 74 g "dat is: " dat
6a80: 29 0a 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 ). ;; (print
6a90: 22 48 54 54 50 2f 31 2e 31 20 32 30 30 20 4f 4b "HTTP/1.1 200 OK
6aa0: 22 29 0a 20 20 20 20 28 70 72 69 6e 74 20 22 44 "). (print "D
6ab0: 61 74 65 3a 20 22 20 28 74 69 6d 65 2d 3e 73 74 ate: " (time->st
6ac0: 72 69 6e 67 20 28 73 65 63 6f 6e 64 73 2d 3e 75 ring (seconds->u
6ad0: 74 63 2d 74 69 6d 65 20 28 63 75 72 72 65 6e 74 tc-time (current
6ae0: 2d 73 65 63 6f 6e 64 73 29 29 29 29 0a 20 20 20 -seconds)))).
6af0: 20 28 70 72 69 6e 74 20 22 43 6f 6e 74 65 6e 74 (print "Content
6b00: 2d 54 79 70 65 3a 20 22 20 28 73 6c 6f 74 2d 72 -Type: " (slot-r
6b10: 65 66 20 73 65 6c 66 20 27 63 6f 6e 74 65 6e 74 ef self 'content
6b20: 2d 74 79 70 65 29 29 0a 20 20 20 20 28 70 72 69 -type)). (pri
6b30: 6e 74 20 22 41 63 63 65 70 74 2d 52 61 6e 67 65 nt "Accept-Range
6b40: 73 3a 20 62 79 74 65 73 22 29 0a 20 20 20 20 28 s: bytes"). (
6b50: 70 72 69 6e 74 20 22 43 6f 6e 74 65 6e 74 2d 4c print "Content-L
6b60: 65 6e 67 74 68 3a 20 22 20 28 69 66 20 28 62 6c ength: " (if (bl
6b70: 6f 62 3f 20 64 61 74 29 0a 09 09 09 09 20 20 28 ob? dat)..... (
6b80: 62 6c 6f 62 2d 73 69 7a 65 20 64 61 74 29 0a 09 blob-size dat)..
6b90: 09 09 09 20 20 30 29 29 0a 20 20 20 20 28 70 72 ... 0)). (pr
6ba0: 69 6e 74 20 22 4b 65 65 70 2d 41 6c 69 76 65 3a int "Keep-Alive:
6bb0: 20 74 69 6d 65 6f 75 74 3d 31 35 2c 20 6d 61 78 timeout=15, max
6bc0: 3d 31 30 30 22 29 0a 20 20 20 20 28 70 72 69 6e =100"). (prin
6bd0: 74 20 22 43 6f 6e 6e 65 63 74 69 6f 6e 3a 20 4b t "Connection: K
6be0: 65 65 70 2d 41 6c 69 76 65 22 29 0a 20 20 20 20 eep-Alive").
6bf0: 28 70 72 69 6e 74 20 22 22 29 0a 20 20 20 20 28 (print ""). (
6c00: 77 72 69 74 65 2d 73 74 72 69 6e 67 20 28 62 6c write-string (bl
6c10: 6f 62 2d 3e 73 74 72 69 6e 67 20 64 61 74 29 20 ob->string dat)
6c20: 23 66 20 28 63 75 72 72 65 6e 74 2d 6f 75 74 70 #f (current-outp
6c30: 75 74 2d 70 6f 72 74 29 29 29 29 0a ut-port)))).