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