Artifact
b8b75856222c4acb01d2c41492a29170ff1aae4b:
0000: 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 30 ;; Copyright 200
0010: 37 2d 32 30 31 31 2c 20 4d 61 74 74 68 65 77 20 7-2011, Matthew
0020: 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b 20 Welland..;; .;;
0030: 20 54 68 69 73 20 70 72 6f 67 72 61 6d 20 69 73 This program is
0040: 20 6d 61 64 65 20 61 76 61 69 6c 61 62 6c 65 20 made available
0050: 75 6e 64 65 72 20 74 68 65 20 47 4e 55 20 47 50 under the GNU GP
0060: 4c 20 76 65 72 73 69 6f 6e 20 32 2e 30 20 6f 72 L version 2.0 or
0070: 0a 3b 3b 20 20 67 72 65 61 74 65 72 2e 20 53 65 .;; greater. Se
0080: 65 20 74 68 65 20 61 63 63 6f 6d 70 61 6e 79 69 e the accompanyi
0090: 6e 67 20 66 69 6c 65 20 43 4f 50 59 49 4e 47 20 ng file COPYING
00a0: 66 6f 72 20 64 65 74 61 69 6c 73 2e 0a 3b 3b 20 for details..;;
00b0: 0a 3b 3b 20 20 54 68 69 73 20 70 72 6f 67 72 61 .;; This progra
00c0: 6d 20 69 73 20 64 69 73 74 72 69 62 75 74 65 64 m is distributed
00d0: 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 52 WITHOUT ANY WAR
00e0: 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 65 RANTY; without e
00f0: 76 65 6e 20 74 68 65 0a 3b 3b 20 20 69 6d 70 6c ven the.;; impl
0100: 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 20 ied warranty of
0110: 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 20 MERCHANTABILITY
0120: 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 41 or FITNESS FOR A
0130: 20 50 41 52 54 49 43 55 4c 41 52 0a 3b 3b 20 20 PARTICULAR.;;
0140: 50 55 52 50 4f 53 45 2e 0a 0a 3b 3b 20 28 72 65 PURPOSE...;; (re
0150: 71 75 69 72 65 2d 65 78 74 65 6e 73 69 6f 6e 20 quire-extension
0160: 73 79 6e 74 61 78 2d 63 61 73 65 29 0a 3b 3b 20 syntax-case).;;
0170: 28 64 65 63 6c 61 72 65 20 28 72 75 6e 2d 74 69 (declare (run-ti
0180: 6d 65 2d 6d 61 63 72 6f 73 29 29 0a 0a 28 69 6e me-macros))..(in
0190: 63 6c 75 64 65 20 22 72 65 71 75 69 72 65 6d 65 clude "requireme
01a0: 6e 74 73 2e 73 63 6d 22 29 0a 28 64 65 63 6c 61 nts.scm").(decla
01b0: 72 65 20 28 75 73 65 73 20 63 6f 6f 6b 69 65 29 re (uses cookie)
01c0: 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 ).(declare (uses
01d0: 20 68 74 6d 6c 2d 66 69 6c 74 65 72 29 29 0a 28 html-filter)).(
01e0: 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 6d 69 declare (uses mi
01f0: 73 63 2d 73 74 6d 6c 29 29 0a 28 64 65 63 6c 61 sc-stml)).(decla
0200: 72 65 20 28 75 73 65 73 20 66 6f 72 6d 64 61 74 re (uses formdat
0210: 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 )).(declare (use
0220: 73 20 73 74 6d 6c 29 29 0a 28 64 65 63 6c 61 72 s stml)).(declar
0230: 65 20 28 75 73 65 73 20 73 65 73 73 69 6f 6e 29 e (uses session)
0240: 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 ).(declare (uses
0250: 20 73 65 74 75 70 29 29 20 3b 3b 20 73 3a 73 65 setup)) ;; s:se
0260: 73 73 69 6f 6e 20 67 65 74 73 20 63 72 65 61 74 ssion gets creat
0270: 65 64 20 68 65 72 65 0a 28 64 65 63 6c 61 72 65 ed here.(declare
0280: 20 28 75 73 65 73 20 73 71 6c 74 62 6c 29 29 0a (uses sqltbl)).
0290: 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 6b (declare (uses k
02a0: 65 79 73 74 6f 72 65 29 29 0a 0a 28 64 65 66 69 eystore))..(defi
02b0: 6e 65 20 28 73 74 6d 6c 3a 63 67 69 2d 73 65 73 ne (stml:cgi-ses
02c0: 73 69 6f 6e 20 73 65 73 73 69 6f 6e 29 0a 20 20 sion session).
02d0: 28 73 65 73 73 69 6f 6e 3a 69 6e 69 74 69 61 6c (session:initial
02e0: 69 7a 65 20 73 65 73 73 69 6f 6e 29 0a 20 20 28 ize session). (
02f0: 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 20 73 65 session:setup se
0300: 73 73 69 6f 6e 29 0a 20 20 28 73 65 73 73 69 6f ssion). (sessio
0310: 6e 3a 67 65 74 2d 76 61 72 73 20 73 65 73 73 69 n:get-vars sessi
0320: 6f 6e 29 0a 0a 20 20 28 73 64 61 74 2d 73 65 74 on).. (sdat-set
0330: 2d 6c 6f 67 2d 70 6f 72 74 21 20 73 65 73 73 69 -log-port! sessi
0340: 6f 6e 20 3b 3b 20 28 63 75 72 72 65 6e 74 2d 65 on ;; (current-e
0350: 72 72 6f 72 2d 70 6f 72 74 29 29 0a 09 09 20 20 rror-port))...
0360: 20 20 20 20 28 6f 70 65 6e 2d 6f 75 74 70 75 74 (open-output
0370: 2d 66 69 6c 65 20 28 73 64 61 74 2d 67 65 74 2d -file (sdat-get-
0380: 6c 6f 67 66 69 6c 65 20 73 65 73 73 69 6f 6e 29 logfile session)
0390: 20 23 3a 61 70 70 65 6e 64 29 29 0a 20 20 28 73 #:append)). (s
03a0: 3a 76 61 6c 69 64 61 74 65 2d 69 6e 70 75 74 73 :validate-inputs
03b0: 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a 72 75 6e ). (session:run
03c0: 2d 61 63 74 69 6f 6e 73 20 73 65 73 73 69 6f 6e -actions session
03d0: 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 ). (sdat-set-pa
03e0: 67 65 64 61 74 21 20 73 65 73 73 69 6f 6e 0a 09 gedat! session..
03f0: 09 20 20 20 20 20 28 61 70 70 65 6e 64 20 28 73 . (append (s
0400: 64 61 74 2d 67 65 74 2d 70 61 67 65 64 61 74 20 dat-get-pagedat
0410: 73 65 73 73 69 6f 6e 29 0a 09 09 09 20 20 20 20 session)....
0420: 20 28 73 3a 63 61 6c 6c 20 28 73 64 61 74 2d 67 (s:call (sdat-g
0430: 65 74 2d 74 6f 70 70 61 67 65 20 73 65 73 73 69 et-toppage sessi
0440: 6f 6e 29 29 29 29 0a 20 20 28 69 66 20 28 65 71 on)))). (if (eq
0450: 3f 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 ? (sdat-get-page
0460: 2d 74 79 70 65 20 73 65 73 73 69 6f 6e 29 20 27 -type session) '
0470: 68 74 6d 6c 29 20 3b 3b 20 64 65 66 61 75 6c 74 html) ;; default
0480: 20 69 73 20 68 74 6d 6c 2e 20 0a 20 20 20 20 20 is html. .
0490: 20 28 73 65 73 73 69 6f 6e 3a 63 67 69 2d 6f 75 (session:cgi-ou
04a0: 74 20 73 65 73 73 69 6f 6e 29 0a 20 20 20 20 20 t session).
04b0: 20 28 73 65 73 73 69 6f 6e 3a 61 6c 74 2d 6f 75 (session:alt-ou
04c0: 74 20 73 65 73 73 69 6f 6e 29 29 0a 20 20 28 73 t session)). (s
04d0: 65 73 73 69 6f 6e 3a 73 61 76 65 2d 76 61 72 73 ession:save-vars
04e0: 20 73 65 73 73 69 6f 6e 29 0a 20 20 28 73 65 73 session). (ses
04f0: 73 69 6f 6e 3a 63 6c 6f 73 65 20 73 65 73 73 69 sion:close sessi
0500: 6f 6e 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 on))..(define (s
0510: 74 6d 6c 3a 6d 61 69 6e 20 70 72 6f 63 29 0a 20 tml:main proc).
0520: 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 (handle-excepti
0530: 6f 6e 73 0a 20 20 20 65 78 6e 20 20 20 0a 20 20 ons. exn .
0540: 20 28 69 66 20 28 73 64 61 74 2d 67 65 74 2d 64 (if (sdat-get-d
0550: 65 62 75 67 6d 6f 64 65 20 73 3a 73 65 73 73 69 ebugmode s:sessi
0560: 6f 6e 29 0a 20 20 20 20 20 20 20 28 62 65 67 69 on). (begi
0570: 6e 0a 09 20 28 70 72 69 6e 74 20 22 43 6f 6e 74 n.. (print "Cont
0580: 65 6e 74 2d 74 79 70 65 3a 20 74 65 78 74 2f 68 ent-type: text/h
0590: 74 6d 6c 22 29 0a 09 20 28 70 72 69 6e 74 20 22 tml").. (print "
05a0: 22 29 0a 09 20 28 70 72 69 6e 74 20 22 3c 68 74 ").. (print "<ht
05b0: 6d 6c 3e 20 3c 68 65 61 64 3e 20 3c 74 69 74 6c ml> <head> <titl
05c0: 65 3e 45 58 43 45 50 54 49 4f 4e 3c 2f 74 69 74 e>EXCEPTION</tit
05d0: 6c 65 3e 20 3c 2f 68 65 61 64 3e 20 3c 62 6f 64 le> </head> <bod
05e0: 79 3e 22 29 0a 09 20 28 70 72 69 6e 74 20 22 20 y>").. (print "
05f0: 20 20 51 55 45 52 59 5f 53 54 52 49 4e 47 20 69 QUERY_STRING i
0600: 73 3a 20 3c 62 3e 20 22 20 28 67 65 74 2d 65 6e s: <b> " (get-en
0610: 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 vironment-variab
0620: 6c 65 20 22 51 55 45 52 59 5f 53 54 52 49 4e 47 le "QUERY_STRING
0630: 22 29 20 22 20 3c 2f 62 3e 20 3c 62 72 3e 22 29 ") " </b> <br>")
0640: 0a 09 20 28 70 72 69 6e 74 20 22 3c 70 72 65 3e .. (print "<pre>
0650: 22 29 0a 09 20 3b 3b 20 28 70 72 69 6e 74 20 22 ").. ;; (print "
0660: 20 20 20 45 58 43 45 50 54 49 4f 4e 3a 20 22 20 EXCEPTION: "
0670: 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 ((condition-prop
0680: 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 erty-accessor 'e
0690: 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e xn 'message) exn
06a0: 29 29 0a 09 20 28 70 72 69 6e 74 2d 65 72 72 6f )).. (print-erro
06b0: 72 2d 6d 65 73 73 61 67 65 20 65 78 6e 29 0a 09 r-message exn)..
06c0: 20 28 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 (print-call-cha
06d0: 69 6e 29 0a 09 20 28 70 72 69 6e 74 20 22 3c 2f in).. (print "</
06e0: 70 72 65 3e 22 29 0a 09 20 28 70 72 69 6e 74 20 pre>").. (print
06f0: 22 3c 74 61 62 6c 65 3e 22 29 0a 09 20 28 66 6f "<table>").. (fo
0700: 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 r-each (lambda (
0710: 76 61 72 29 0a 09 09 20 20 20 20 20 28 70 72 69 var)... (pri
0720: 6e 74 20 22 3c 74 72 3e 3c 74 64 3e 22 20 28 63 nt "<tr><td>" (c
0730: 61 72 20 76 61 72 29 20 22 3c 2f 74 64 3e 3c 74 ar var) "</td><t
0740: 64 3e 22 20 28 63 64 72 20 76 61 72 29 20 22 3c d>" (cdr var) "<
0750: 2f 74 64 3e 3c 2f 74 72 3e 22 29 29 0a 09 09 20 /td></tr>"))...
0760: 20 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 (get-environme
0770: 6e 74 2d 76 61 72 69 61 62 6c 65 73 29 29 0a 09 nt-variables))..
0780: 20 28 70 72 69 6e 74 20 22 3c 2f 74 61 62 6c 65 (print "</table
0790: 3e 22 29 0a 09 20 28 70 72 69 6e 74 20 22 3c 2f >").. (print "</
07a0: 62 6f 64 79 3e 3c 2f 68 74 6d 6c 3e 22 29 29 0a body></html>")).
07b0: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 20 (begin..
07c0: 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d (with-output-to-
07d0: 66 69 6c 65 20 28 63 6f 6e 63 20 22 2f 74 6d 70 file (conc "/tmp
07e0: 2f 73 74 6d 6c 2d 63 72 61 73 68 2d 22 20 28 63 /stml-crash-" (c
07f0: 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 urrent-process-i
0800: 64 29 20 22 2e 6c 6f 67 22 29 0a 09 20 20 20 28 d) ".log").. (
0810: 6c 61 6d 62 64 61 20 28 29 0a 09 20 20 20 20 20 lambda ()..
0820: 28 70 72 69 6e 74 20 22 45 58 43 45 50 54 49 4f (print "EXCEPTIO
0830: 4e 22 29 0a 09 20 20 20 20 20 28 70 72 69 6e 74 N").. (print
0840: 20 22 20 20 20 51 55 45 52 59 5f 53 54 52 49 4e " QUERY_STRIN
0850: 47 20 69 73 3a 20 22 20 28 67 65 74 2d 65 6e 76 G is: " (get-env
0860: 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c ironment-variabl
0870: 65 20 22 51 55 45 52 59 5f 53 54 52 49 4e 47 22 e "QUERY_STRING"
0880: 29 20 29 0a 09 20 20 20 20 20 28 70 72 69 6e 74 ) ).. (print
0890: 20 22 22 29 0a 09 20 20 20 20 20 3b 3b 20 28 70 "").. ;; (p
08a0: 72 69 6e 74 20 22 20 20 20 45 58 43 45 50 54 49 rint " EXCEPTI
08b0: 4f 4e 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 6f ON: " ((conditio
08c0: 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 n-property-acces
08d0: 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 sor 'exn 'messag
08e0: 65 29 20 65 78 6e 29 29 0a 09 20 20 20 20 20 28 e) exn)).. (
08f0: 70 72 69 6e 74 2d 65 72 72 6f 72 2d 6d 65 73 73 print-error-mess
0900: 61 67 65 20 65 78 6e 29 0a 09 20 20 20 20 20 28 age exn).. (
0910: 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e print-call-chain
0920: 29 0a 09 20 20 20 20 20 28 70 72 69 6e 74 20 22 ).. (print "
0930: 22 29 0a 09 20 20 20 20 20 28 66 6f 72 2d 65 61 ").. (for-ea
0940: 63 68 20 28 6c 61 6d 62 64 61 20 28 76 61 72 29 ch (lambda (var)
0950: 0a 09 09 09 20 28 70 72 69 6e 74 20 28 63 61 72 .... (print (car
0960: 20 76 61 72 29 20 22 5c 74 22 20 28 63 64 72 20 var) "\t" (cdr
0970: 76 61 72 29 29 29 0a 09 09 20 20 20 20 20 20 20 var)))...
0980: 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 (get-environment
0990: 2d 76 61 72 69 61 62 6c 65 73 29 29 29 29 0a 09 -variables))))..
09a0: 20 3b 3b 20 72 65 74 75 72 6e 20 73 6f 6d 65 74 ;; return somet
09b0: 68 69 6e 67 20 75 73 65 66 75 6c 20 74 6f 20 74 hing useful to t
09c0: 68 65 20 75 73 65 72 0a 09 20 28 70 72 69 6e 74 he user.. (print
09d0: 20 22 43 6f 6e 74 65 6e 74 2d 74 79 70 65 3a 20 "Content-type:
09e0: 74 65 78 74 2f 68 74 6d 6c 22 29 0a 09 20 28 70 text/html").. (p
09f0: 72 69 6e 74 20 22 22 29 0a 09 20 28 70 72 69 6e rint "").. (prin
0a00: 74 20 22 3c 68 74 6d 6c 3e 20 3c 68 65 61 64 3e t "<html> <head>
0a10: 20 3c 74 69 74 6c 65 3e 45 58 43 45 50 54 49 4f <title>EXCEPTIO
0a20: 4e 3c 2f 74 69 74 6c 65 3e 20 3c 2f 68 65 61 64 N</title> </head
0a30: 3e 20 3c 62 6f 64 79 3e 22 29 0a 09 20 28 70 72 > <body>").. (pr
0a40: 69 6e 74 20 22 3c 68 31 3e 43 52 41 53 48 21 3c int "<h1>CRASH!<
0a50: 2f 68 31 3e 22 29 0a 09 20 28 70 72 69 6e 74 20 /h1>").. (print
0a60: 22 20 20 20 50 6c 65 61 73 65 20 6e 6f 74 69 66 " Please notif
0a70: 79 20 73 75 70 70 6f 72 74 20 61 74 20 22 20 28 y support at " (
0a80: 73 64 61 74 2d 67 65 74 2d 64 6f 6d 61 69 6e 20 sdat-get-domain
0a90: 73 3a 73 65 73 73 69 6f 6e 29 20 22 20 74 68 61 s:session) " tha
0aa0: 74 20 74 68 65 20 65 72 72 6f 72 20 6c 6f 67 20 t the error log
0ab0: 69 73 20 73 74 6d 6c 63 72 61 73 68 2d 22 20 28 is stmlcrash-" (
0ac0: 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d current-process-
0ad0: 69 64 29 20 22 2e 6c 6f 67 3c 2f 62 3e 20 3c 62 id) ".log</b> <b
0ae0: 72 3e 22 29 0a 09 20 3b 3b 20 28 70 72 69 6e 74 r>").. ;; (print
0af0: 20 22 3c 70 72 65 3e 22 29 0a 09 20 3b 3b 20 3b "<pre>").. ;; ;
0b00: 3b 20 28 70 72 69 6e 74 20 22 20 20 20 45 58 43 ; (print " EXC
0b10: 45 50 54 49 4f 4e 3a 20 22 20 28 28 63 6f 6e 64 EPTION: " ((cond
0b20: 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 ition-property-a
0b30: 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 ccessor 'exn 'me
0b40: 73 73 61 67 65 29 20 65 78 6e 29 29 0a 09 20 3b ssage) exn)).. ;
0b50: 3b 20 3b 3b 20 28 70 72 69 6e 74 2d 65 72 72 6f ; ;; (print-erro
0b60: 72 2d 6d 65 73 73 61 67 65 20 65 78 6e 29 0a 09 r-message exn)..
0b70: 20 3b 3b 20 3b 3b 20 28 70 72 69 6e 74 2d 63 61 ;; ;; (print-ca
0b80: 6c 6c 2d 63 68 61 69 6e 29 0a 09 20 3b 3b 20 28 ll-chain).. ;; (
0b90: 70 72 69 6e 74 20 22 3c 2f 70 72 65 3e 22 29 0a print "</pre>").
0ba0: 09 20 3b 3b 20 28 70 72 69 6e 74 20 22 3c 74 61 . ;; (print "<ta
0bb0: 62 6c 65 3e 22 29 0a 09 20 3b 3b 20 28 66 6f 72 ble>").. ;; (for
0bc0: 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 76 -each (lambda (v
0bd0: 61 72 29 0a 09 20 3b 3b 20 09 20 20 20 20 20 28 ar).. ;; . (
0be0: 70 72 69 6e 74 20 22 3c 74 72 3e 3c 74 64 3e 22 print "<tr><td>"
0bf0: 20 28 63 61 72 20 76 61 72 29 20 22 3c 2f 74 64 (car var) "</td
0c00: 3e 3c 74 64 3e 22 20 28 63 64 72 20 76 61 72 29 ><td>" (cdr var)
0c10: 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e 22 29 29 0a "</td></tr>")).
0c20: 09 20 3b 3b 20 09 20 20 20 28 67 65 74 2d 65 6e . ;; . (get-en
0c30: 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 vironment-variab
0c40: 6c 65 73 29 29 0a 09 20 3b 3b 20 28 70 72 69 6e les)).. ;; (prin
0c50: 74 20 22 3c 2f 74 61 62 6c 65 3e 22 29 0a 09 20 t "</table>")..
0c60: 28 70 72 69 6e 74 20 22 3c 2f 62 6f 64 79 3e 3c (print "</body><
0c70: 2f 68 74 6d 6c 3e 22 29 29 29 0a 20 20 20 28 69 /html>"))). (i
0c80: 66 20 70 72 6f 63 20 28 70 72 6f 63 20 73 3a 73 f proc (proc s:s
0c90: 65 73 73 69 6f 6e 29 20 28 73 74 6d 6c 3a 63 67 ession) (stml:cg
0ca0: 69 2d 73 65 73 73 69 6f 6e 20 73 3a 73 65 73 73 i-session s:sess
0cb0: 69 6f 6e 29 29 0a 20 3b 3b 20 28 72 61 69 73 65 ion)). ;; (raise
0cc0: 2d 65 72 72 6f 72 29 0a 20 3b 3b 20 28 65 78 69 -error). ;; (exi
0cd0: 74 29 0a 20 20 20 29 29 0a t). )).