Artifact fb9cd2423493160b267e1c04c0be2cfbb19dc08d:
- File
misc-stml.scm
— part of check-in
[1b5a5d3a6e]
at
2016-10-20 17:53:01
on branch crypt
— Replace external openssl call with "crypt" egg.
The OpenSSL call was using the old UNIX crypt DES password hashing, which is very weak. Crypt will default to a more sensible mechanism (Blowfish, but in the future could transparently switch).
Old passwords will continue to work, because the crypt egg detects DES salts and happily hashes them. When creating new passwords, they will be hashed using the modern algorithm.
The OpenSSL call passed the password to the shell, so an onlooker on the server could see it in plaintext. It also neglected to escape the password for the shell, resulting in a command injection vulnerability. (user: sjamaan, size: 9930) [annotate] [blame] [check-ins using] [more...]
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 3d 3d 3d 3d PURPOSE...;;====
0150: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0160: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0170: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0180: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0190: 3d 3d 0a 3b 3b 20 64 75 6d 62 6f 62 6a 20 68 65 ==.;; dumbobj he
01a0: 6c 70 65 72 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d lpers.;;========
01b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
01f0: 28 64 65 63 6c 61 72 65 20 28 75 6e 69 74 20 6d (declare (unit m
0200: 69 73 63 2d 73 74 6d 6c 29 29 0a 28 75 73 65 20 isc-stml)).(use
0210: 28 70 72 65 66 69 78 20 63 72 79 70 74 20 63 3a (prefix crypt c:
0220: 29 29 0a 28 75 73 65 20 72 65 67 65 78 29 0a 0a )).(use regex)..
0230: 3b 3b 20 67 69 76 65 6e 20 61 20 6c 69 73 74 20 ;; given a list
0240: 6f 66 20 73 79 6d 62 6f 6c 73 20 67 69 76 65 20 of symbols give
0250: 74 68 65 20 63 6f 75 6e 74 20 6f 66 20 74 68 65 the count of the
0260: 20 6d 61 74 63 68 69 6e 67 20 73 79 6d 62 6f 6c matching symbol
0270: 0a 3b 3b 20 6c 20 3d 3e 20 27 28 61 20 62 20 63 .;; l => '(a b c
0280: 29 20 20 28 64 75 6d 6f 62 6a 3a 69 6e 64 78 20 ) (dumobj:indx
0290: 61 20 27 62 29 20 3d 3e 20 31 0a 28 64 65 66 69 a 'b) => 1.(defi
02a0: 6e 65 20 28 73 3a 67 65 74 2d 66 69 65 6c 64 6e ne (s:get-fieldn
02b0: 75 6d 20 6c 73 74 20 66 69 65 6c 64 2d 6e 61 6d um lst field-nam
02c0: 65 29 0a 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 e). (let loop (
02d0: 28 68 65 61 64 20 28 63 61 72 20 6c 73 74 29 29 (head (car lst))
02e0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 . (t
02f0: 61 69 6c 20 28 63 64 72 20 6c 73 74 29 29 0a 20 ail (cdr lst)).
0300: 20 20 20 20 20 20 20 20 20 20 20 20 28 66 6e 75 (fnu
0310: 6d 20 30 29 29 0a 20 20 20 20 28 69 66 20 28 65 m 0)). (if (e
0320: 71 3f 20 68 65 61 64 20 66 69 65 6c 64 2d 6e 61 q? head field-na
0330: 6d 65 29 20 66 6e 75 6d 0a 20 20 20 20 20 20 20 me) fnum.
0340: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 69 6c (if (null? tail
0350: 29 20 23 66 0a 20 20 20 20 20 20 20 20 20 20 20 ) #f.
0360: 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 69 6c (loop (car tail
0370: 29 28 63 64 72 20 74 61 69 6c 29 28 2b 20 66 6e )(cdr tail)(+ fn
0380: 75 6d 20 31 29 29 29 29 29 29 0a 0a 28 64 65 66 um 1))))))..(def
0390: 69 6e 65 20 28 73 3a 66 69 65 6c 64 73 2d 3e 73 ine (s:fields->s
03a0: 74 72 69 6e 67 20 6c 73 74 29 0a 20 20 28 73 74 tring lst). (st
03b0: 72 69 6e 67 2d 6a 6f 69 6e 20 28 6d 61 70 20 73 ring-join (map s
03c0: 79 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 6c 73 ymbol->string ls
03d0: 74 29 20 22 2c 22 29 29 0a 0a 28 64 65 66 69 6e t) ","))..(defin
03e0: 65 20 28 73 3a 76 65 63 74 6f 72 2d 67 65 74 2d e (s:vector-get-
03f0: 66 69 65 6c 64 20 76 65 63 20 66 69 65 6c 64 20 field vec field
0400: 66 69 65 6c 64 2d 6c 69 73 74 29 0a 20 20 28 76 field-list). (v
0410: 65 63 74 6f 72 2d 72 65 66 20 76 65 63 20 28 73 ector-ref vec (s
0420: 3a 67 65 74 2d 66 69 65 6c 64 6e 75 6d 20 66 69 :get-fieldnum fi
0430: 65 6c 64 2d 6c 69 73 74 20 66 69 65 6c 64 29 29 eld-list field))
0440: 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
0450: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0460: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0470: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0480: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 0a 3b ===========.;;.;
0490: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
04a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04d0: 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 =======..(define
04e0: 20 28 65 72 72 3a 6c 6f 67 20 2e 20 6d 73 67 29 (err:log . msg)
04f0: 0a 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d . (with-output-
0500: 74 6f 2d 70 6f 72 74 20 28 63 75 72 72 65 6e 74 to-port (current
0510: 2d 65 72 72 6f 72 2d 70 6f 72 74 29 20 3b 3b 20 -error-port) ;;
0520: 28 73 6c 6f 74 2d 72 65 66 20 73 65 6c 66 20 27 (slot-ref self '
0530: 6c 6f 67 70 74 29 0a 20 20 20 20 28 6c 61 6d 62 logpt). (lamb
0540: 64 61 20 28 29 20 0a 20 20 20 20 20 20 28 61 70 da () . (ap
0550: 70 6c 79 20 70 72 69 6e 74 20 6d 73 67 29 29 29 ply print msg)))
0560: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 3a 74 69 )..(define (s:ti
0570: 64 79 2d 75 72 6c 20 75 72 6c 29 0a 20 20 28 69 dy-url url). (i
0580: 66 20 75 72 6c 0a 20 20 20 20 20 20 28 6c 65 74 f url. (let
0590: 20 28 28 72 31 20 28 72 65 67 65 78 70 20 22 5e ((r1 (regexp "^
05a0: 68 74 74 70 3a 5c 5c 2f 5c 5c 2f 22 29 29 0a 20 http:\\/\\/")).
05b0: 20 20 20 20 20 20 20 20 20 20 20 28 72 32 20 28 (r2 (
05c0: 72 65 67 65 78 70 20 22 5e 5b 20 5c 5c 74 5d 2a regexp "^[ \\t]*
05d0: 24 22 29 29 29 20 3b 3b 20 62 6c 61 6e 6b 0a 20 $"))) ;; blank.
05e0: 20 20 20 20 20 20 20 28 69 66 20 28 73 74 72 69 (if (stri
05f0: 6e 67 2d 6d 61 74 63 68 20 72 31 20 75 72 6c 29 ng-match r1 url)
0600: 20 75 72 6c 0a 20 20 20 20 20 20 20 20 20 20 20 url.
0610: 20 28 69 66 20 28 73 74 72 69 6e 67 2d 6d 61 74 (if (string-mat
0620: 63 68 20 72 32 20 75 72 6c 29 20 23 66 20 3b 3b ch r2 url) #f ;;
0630: 20 63 6f 6e 76 65 72 74 20 61 20 62 6c 61 6e 6b convert a blank
0640: 20 74 6f 20 23 66 0a 20 20 20 20 20 20 20 20 20 to #f.
0650: 20 20 20 20 20 20 20 28 63 6f 6e 63 20 22 68 74 (conc "ht
0660: 74 70 3a 2f 2f 22 20 75 72 6c 29 29 29 29 0a 20 tp://" url)))).
0670: 20 20 20 20 20 75 72 6c 29 29 0a 0a 28 64 65 66 url))..(def
0680: 69 6e 65 20 28 73 3a 6c 61 7a 79 2d 3e 6e 75 6d ine (s:lazy->num
0690: 20 6e 75 6d 29 0a 20 20 28 69 66 20 28 6e 75 6d num). (if (num
06a0: 62 65 72 3f 20 6e 75 6d 29 20 6e 75 6d 0a 20 20 ber? num) num.
06b0: 20 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 2d (if (string-
06c0: 3e 6e 75 6d 62 65 72 20 6e 75 6d 29 20 28 73 74 >number num) (st
06d0: 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 6e 75 6d ring->number num
06e0: 29 0a 09 20 20 20 20 28 69 66 20 6e 75 6d 20 31 ).. (if num 1
06f0: 20 30 29 29 29 29 20 3b 3b 20 77 69 65 72 64 20 0)))) ;; wierd
0700: 65 68 21 20 79 65 70 2c 20 23 66 3d 3e 30 20 23 eh! yep, #f=>0 #
0710: 74 3d 3e 31 20 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d t=>1 ..;;=======
0720: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0730: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0740: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0750: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
0760: 3b 3b 20 44 20 42 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d ;; D B.;;=======
0770: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0780: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0790: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
07b0: 0a 3b 3b 20 63 6f 6e 76 65 72 74 20 76 61 6c 75 .;; convert valu
07c0: 65 73 20 74 6f 20 61 70 70 72 6f 70 72 69 61 74 es to appropriat
07d0: 65 20 73 74 72 69 6e 67 73 0a 3b 3b 0a 28 64 65 e strings.;;.(de
07e0: 66 69 6e 65 20 28 73 3a 73 71 6c 70 61 72 61 6d fine (s:sqlparam
07f0: 2d 76 61 6c 2d 3e 73 74 72 69 6e 67 20 76 61 6c -val->string val
0800: 29 0a 20 20 28 63 6f 6e 64 0a 20 20 20 28 28 6c ). (cond. ((l
0810: 69 73 74 3f 20 20 20 76 61 6c 29 28 73 74 72 69 ist? val)(stri
0820: 6e 67 2d 6a 6f 69 6e 20 28 6d 61 70 20 73 79 6d ng-join (map sym
0830: 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 76 61 6c 29 bol->string val)
0840: 20 22 2c 22 29 29 20 3b 3b 20 28 61 20 62 20 63 ",")) ;; (a b c
0850: 29 20 3d 3e 20 61 2c 62 2c 63 0a 20 20 20 28 28 ) => a,b,c. ((
0860: 73 74 72 69 6e 67 3f 20 76 61 6c 29 28 63 6f 6e string? val)(con
0870: 63 20 22 27 22 20 28 64 62 69 3a 65 73 63 61 70 c "'" (dbi:escap
0880: 65 2d 73 74 72 69 6e 67 20 76 61 6c 29 20 22 27 e-string val) "'
0890: 22 29 29 0a 20 20 20 28 28 6e 75 6d 62 65 72 3f ")). ((number?
08a0: 20 76 61 6c 29 28 6e 75 6d 62 65 72 2d 3e 73 74 val)(number->st
08b0: 72 69 6e 67 20 76 61 6c 29 29 0a 20 20 20 28 28 ring val)). ((
08c0: 73 79 6d 62 6f 6c 3f 20 76 61 6c 29 28 64 62 69 symbol? val)(dbi
08d0: 3a 65 73 63 61 70 65 2d 73 74 72 69 6e 67 20 28 :escape-string (
08e0: 73 79 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 76 symbol->string v
08f0: 61 6c 29 29 29 0a 20 20 20 28 28 62 6f 6f 6c 65 al))). ((boole
0900: 61 6e 3f 20 76 61 6c 29 0a 20 20 20 20 28 69 66 an? val). (if
0910: 20 76 61 6c 20 22 54 52 55 45 22 20 22 46 41 4c val "TRUE" "FAL
0920: 53 45 22 29 29 20 20 3b 3b 20 73 68 6f 75 6c 64 SE")) ;; should
0930: 20 74 68 69 73 20 62 65 20 22 54 52 55 45 22 20 this be "TRUE"
0940: 6f 72 20 31 3f 0a 20 20 20 20 20 20 20 20 20 20 or 1?.
0950: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0960: 20 20 20 20 3b 3b 20 73 68 6f 75 6c 64 20 74 68 ;; should th
0970: 69 73 20 62 65 20 22 46 41 4c 53 45 22 20 6f 72 is be "FALSE" or
0980: 20 30 20 6f 72 20 4e 55 4c 4c 3f 0a 20 20 20 28 0 or NULL?. (
0990: 65 6c 73 65 0a 20 20 20 20 28 65 72 72 3a 6c 6f else. (err:lo
09a0: 67 20 22 73 71 6c 70 61 72 61 6d 3a 20 75 6e 6b g "sqlparam: unk
09b0: 6e 6f 77 6e 20 74 79 70 65 20 66 6f 72 20 76 61 nown type for va
09c0: 6c 75 65 3a 20 22 20 76 61 6c 29 0a 20 20 20 20 lue: " val).
09d0: 22 22 29 29 29 0a 0a 3b 3b 20 28 73 71 6c 70 61 "")))..;; (sqlpa
09e0: 72 61 6d 20 22 49 4e 53 45 52 54 20 49 4e 54 4f ram "INSERT INTO
09f0: 20 66 6f 6f 28 6e 61 6d 65 2c 61 67 65 29 20 56 foo(name,age) V
0a00: 41 4c 55 45 53 28 3f 2c 3f 29 3b 22 20 22 62 6f ALUES(?,?);" "bo
0a10: 62 22 20 32 30 29 0a 3b 3b 20 4e 42 2f 2f 20 31 b" 20).;; NB// 1
0a20: 2e 20 76 61 6c 75 65 73 20 6f 6e 6c 79 21 21 20 . values only!!
0a30: 0a 3b 3b 20 20 20 20 20 20 32 2e 20 74 65 72 6d .;; 2. term
0a40: 69 6e 61 74 69 6e 67 20 73 65 6d 69 63 6f 6c 6f inating semicolo
0a50: 6e 20 72 65 71 75 69 72 65 64 20 28 75 73 65 64 n required (used
0a60: 20 61 73 20 70 61 72 74 20 6f 66 20 6c 6f 67 69 as part of logi
0a70: 63 29 0a 3b 3b 0a 3b 3b 20 61 3d 3f 20 31 20 28 c).;;.;; a=? 1 (
0a80: 6e 75 6d 62 65 72 29 20 3d 3e 20 61 3d 31 0a 3b number) => a=1.;
0a90: 3b 20 61 3d 3f 20 31 20 28 73 74 72 69 6e 67 29 ; a=? 1 (string)
0aa0: 20 3d 3e 20 61 3d 27 31 27 0a 3b 3b 20 61 3d 3f => a='1'.;; a=?
0ab0: 20 23 66 20 20 20 20 20 20 20 20 20 3d 3e 20 61 #f => a
0ac0: 3d 46 41 4c 53 45 20 0a 3b 3b 20 61 3d 3f 20 61 =FALSE .;; a=? a
0ad0: 20 28 73 79 6d 62 6f 6c 29 20 3d 3e 20 61 3d 61 (symbol) => a=a
0ae0: 20 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 3a .;;.(define (s:
0af0: 73 71 6c 70 61 72 61 6d 20 71 75 65 72 79 20 2e sqlparam query .
0b00: 20 61 72 67 73 29 0a 20 20 28 6c 65 74 2a 20 28 args). (let* (
0b10: 28 71 75 65 72 79 2d 70 61 72 74 73 20 28 73 74 (query-parts (st
0b20: 72 69 6e 67 2d 73 70 6c 69 74 20 71 75 65 72 79 ring-split query
0b30: 20 22 3f 22 29 29 0a 20 20 20 20 20 20 20 20 20 "?")).
0b40: 28 6e 75 6d 2d 70 61 72 74 73 20 20 20 20 28 6c (num-parts (l
0b50: 65 6e 67 74 68 20 71 75 65 72 79 2d 70 61 72 74 ength query-part
0b60: 73 29 29 0a 20 20 20 20 20 20 20 20 20 28 6e 75 s)). (nu
0b70: 6d 2d 61 72 67 73 20 20 20 20 28 6c 65 6e 67 74 m-args (lengt
0b80: 68 20 61 72 67 73 29 29 29 0a 20 20 20 20 28 69 h args))). (i
0b90: 66 20 28 6e 6f 74 20 28 3d 20 28 2b 20 6e 75 6d f (not (= (+ num
0ba0: 2d 61 72 67 73 20 31 29 20 6e 75 6d 2d 70 61 72 -args 1) num-par
0bb0: 74 73 29 29 0a 20 20 20 20 20 20 20 20 28 65 72 ts)). (er
0bc0: 72 3a 6c 6f 67 20 22 45 52 52 4f 52 2c 20 73 71 r:log "ERROR, sq
0bd0: 6c 70 61 72 61 6d 3a 20 77 72 6f 6e 67 20 6e 75 lparam: wrong nu
0be0: 6d 62 65 72 20 6f 66 20 61 72 67 75 6d 65 6e 74 mber of argument
0bf0: 73 20 6f 72 20 6d 69 73 73 69 6e 67 20 73 65 6d s or missing sem
0c00: 69 63 6f 6c 6f 6e 2c 20 22 20 6e 75 6d 2d 61 72 icolon, " num-ar
0c10: 67 73 20 22 20 66 6f 72 20 71 75 65 72 79 20 22 gs " for query "
0c20: 20 71 75 65 72 79 29 0a 20 20 20 20 20 20 20 20 query).
0c30: 28 69 66 20 28 3d 20 6e 75 6d 2d 61 72 67 73 20 (if (= num-args
0c40: 30 29 20 71 75 65 72 79 0a 20 20 20 20 20 20 20 0) query.
0c50: 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 (let loop (
0c60: 28 73 65 63 74 69 6f 6e 20 28 63 61 72 20 71 75 (section (car qu
0c70: 65 72 79 2d 70 61 72 74 73 29 29 0a 20 20 20 20 ery-parts)).
0c80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0c90: 20 20 20 28 74 61 69 6c 20 20 20 20 28 63 64 72 (tail (cdr
0ca0: 20 71 75 65 72 79 2d 70 61 72 74 73 29 29 0a 20 query-parts)).
0cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0cc0: 20 20 20 20 20 20 28 72 65 73 75 6c 74 20 20 22 (result "
0cd0: 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ").
0ce0: 20 20 20 20 20 20 20 20 20 20 28 61 72 67 20 20 (arg
0cf0: 20 20 20 28 63 61 72 20 61 72 67 73 29 29 0a 20 (car args)).
0d00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0d10: 20 20 20 20 20 20 28 61 72 67 74 61 69 6c 20 28 (argtail (
0d20: 63 64 72 20 61 72 67 73 29 29 29 0a 20 20 20 20 cdr args))).
0d30: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 (let*
0d40: 28 28 76 61 6c 73 74 72 20 20 20 20 28 73 3a 73 ((valstr (s:s
0d50: 71 6c 70 61 72 61 6d 2d 76 61 6c 2d 3e 73 74 72 qlparam-val->str
0d60: 69 6e 67 20 61 72 67 29 29 0a 20 20 20 20 20 20 ing arg)).
0d70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
0d80: 6e 65 77 72 65 73 75 6c 74 20 28 63 6f 6e 63 20 newresult (conc
0d90: 72 65 73 75 6c 74 20 73 65 63 74 69 6f 6e 20 76 result section v
0da0: 61 6c 73 74 72 29 29 29 0a 20 20 20 20 20 20 20 alstr))).
0db0: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 75 (if (nu
0dc0: 6c 6c 3f 20 61 72 67 74 61 69 6c 29 20 3b 3b 20 ll? argtail) ;;
0dd0: 77 65 20 61 72 65 20 64 6f 6e 65 0a 20 20 20 20 we are done.
0de0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0df0: 28 63 6f 6e 63 20 6e 65 77 72 65 73 75 6c 74 20 (conc newresult
0e00: 28 63 61 72 20 74 61 69 6c 29 29 0a 20 20 20 20 (car tail)).
0e10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0e20: 28 6c 6f 6f 70 0a 20 20 20 20 20 20 20 20 20 20 (loop.
0e30: 20 20 20 20 20 20 20 20 20 20 20 28 63 61 72 20 (car
0e40: 74 61 69 6c 29 0a 20 20 20 20 20 20 20 20 20 20 tail).
0e50: 20 20 20 20 20 20 20 20 20 20 20 28 63 64 72 20 (cdr
0e60: 74 61 69 6c 29 0a 20 20 20 20 20 20 20 20 20 20 tail).
0e70: 20 20 20 20 20 20 20 20 20 20 20 6e 65 77 72 65 newre
0e80: 73 75 6c 74 0a 20 20 20 20 20 20 20 20 20 20 20 sult.
0e90: 20 20 20 20 20 20 20 20 20 20 28 63 61 72 20 61 (car a
0ea0: 72 67 74 61 69 6c 29 0a 20 20 20 20 20 20 20 20 rgtail).
0eb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 64 (cd
0ec0: 72 20 61 72 67 74 61 69 6c 29 29 29 29 29 29 29 r argtail)))))))
0ed0: 29 29 0a 0a 3b 3b 20 72 61 6e 64 6f 6d 20 73 74 ))..;; random st
0ee0: 72 69 6e 67 20 73 74 75 66 66 0a 28 64 65 66 69 ring stuff.(defi
0ef0: 6e 65 20 28 73 3a 73 74 72 69 6e 67 2d 64 6f 77 ne (s:string-dow
0f00: 6e 63 61 73 65 20 73 74 72 29 0a 20 20 28 69 66 ncase str). (if
0f10: 20 28 73 74 72 69 6e 67 3f 20 73 74 72 29 0a 20 (string? str).
0f20: 20 20 20 20 20 28 73 74 72 69 6e 67 2d 74 72 61 (string-tra
0f30: 6e 73 6c 61 74 65 20 73 74 72 20 22 41 42 43 44 nslate str "ABCD
0f40: 45 46 47 48 49 4a 4b 4c 4d 4e 4f 50 51 52 53 54 EFGHIJKLMNOPQRST
0f50: 55 56 57 58 59 5a 22 20 22 61 62 63 64 65 66 67 UVWXYZ" "abcdefg
0f60: 68 69 6a 6b 6c 6d 6e 6f 70 71 72 73 74 75 76 77 hijklmnopqrstuvw
0f70: 78 79 7a 22 29 0a 20 20 20 20 20 20 73 74 72 29 xyz"). str)
0f80: 29 20 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 73 ) ..;; (define s
0f90: 65 73 73 69 6f 6e 3a 76 61 6c 69 64 2d 63 68 61 ession:valid-cha
0fa0: 72 73 20 22 61 62 63 64 65 66 67 68 69 6a 6b 6c rs "abcdefghijkl
0fb0: 6d 6e 6f 70 71 72 73 74 75 76 77 78 79 7a 41 42 mnopqrstuvwxyzAB
0fc0: 43 44 45 46 47 48 49 4a 4b 4c 4d 4e 4f 50 51 52 CDEFGHIJKLMNOPQR
0fd0: 53 54 55 56 57 58 59 5a 30 31 32 33 34 35 36 37 STUVWXYZ01234567
0fe0: 38 39 22 29 0a 28 64 65 66 69 6e 65 20 73 65 73 89").(define ses
0ff0: 73 69 6f 6e 3a 76 61 6c 69 64 2d 63 68 61 72 73 sion:valid-chars
1000: 20 22 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e "abcdefghijklmn
1010: 6f 70 71 72 73 74 75 76 77 78 79 7a 30 31 32 33 opqrstuvwxyz0123
1020: 34 35 36 37 38 39 22 29 20 3b 3b 20 63 6f 6f 6b 456789") ;; cook
1030: 69 65 73 20 61 72 65 20 63 61 73 65 20 69 6e 73 ies are case ins
1040: 65 6e 73 69 74 69 76 65 2e 0a 28 64 65 66 69 6e ensitive..(defin
1050: 65 20 73 65 73 73 69 6f 6e 3a 6e 75 6d 2d 76 61 e session:num-va
1060: 6c 69 64 2d 63 68 61 72 73 20 28 73 74 72 69 6e lid-chars (strin
1070: 67 2d 6c 65 6e 67 74 68 20 73 65 73 73 69 6f 6e g-length session
1080: 3a 76 61 6c 69 64 2d 63 68 61 72 73 29 29 0a 0a :valid-chars))..
1090: 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
10a0: 3a 67 65 74 2d 6e 74 68 2d 63 68 61 72 20 6e 74 :get-nth-char nt
10b0: 68 29 0a 20 20 28 73 75 62 73 74 72 69 6e 67 20 h). (substring
10c0: 73 65 73 73 69 6f 6e 3a 76 61 6c 69 64 2d 63 68 session:valid-ch
10d0: 61 72 73 20 6e 74 68 20 20 28 2b 20 6e 74 68 20 ars nth (+ nth
10e0: 31 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 1)))..(define (s
10f0: 65 73 73 69 6f 6e 3a 67 65 74 2d 72 61 6e 64 2d ession:get-rand-
1100: 63 68 61 72 29 0a 20 20 28 73 65 73 73 69 6f 6e char). (session
1110: 3a 67 65 74 2d 6e 74 68 2d 63 68 61 72 20 28 72 :get-nth-char (r
1120: 61 6e 64 6f 6d 20 73 65 73 73 69 6f 6e 3a 6e 75 andom session:nu
1130: 6d 2d 76 61 6c 69 64 2d 63 68 61 72 73 29 29 29 m-valid-chars)))
1140: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ..(define (sessi
1150: 6f 6e 3a 6d 61 6b 65 2d 72 61 6e 64 2d 73 74 72 on:make-rand-str
1160: 69 6e 67 20 6c 65 6e 29 0a 20 20 28 6c 65 74 20 ing len). (let
1170: 6c 6f 6f 70 20 28 28 72 65 73 20 22 22 29 0a 20 loop ((res "").
1180: 20 20 20 20 20 20 20 20 20 20 20 20 28 6e 20 20 (n
1190: 20 31 29 29 0a 20 20 20 20 28 69 66 20 28 3e 20 1)). (if (>
11a0: 6e 20 6c 65 6e 29 20 72 65 73 0a 20 20 20 20 20 n len) res.
11b0: 20 20 20 28 6c 6f 6f 70 20 28 73 74 72 69 6e 67 (loop (string
11c0: 2d 61 70 70 65 6e 64 20 72 65 73 20 28 73 65 73 -append res (ses
11d0: 73 69 6f 6e 3a 67 65 74 2d 72 61 6e 64 2d 63 68 sion:get-rand-ch
11e0: 61 72 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 ar)).
11f0: 20 20 20 28 2b 20 6e 20 31 29 29 29 29 29 0a 0a (+ n 1)))))..
1200: 3b 3b 20 52 65 6c 79 20 6f 6e 20 63 72 79 70 74 ;; Rely on crypt
1210: 20 65 67 67 27 73 20 64 65 66 61 75 6c 74 20 73 egg's default s
1220: 65 74 74 69 6e 67 73 20 62 65 69 6e 67 20 73 65 ettings being se
1230: 63 75 72 65 20 65 6e 6f 75 67 68 2c 20 61 63 63 cure enough, acc
1240: 65 70 74 0a 3b 3b 20 62 61 63 6b 77 61 72 64 73 ept.;; backwards
1250: 2d 63 6f 6d 70 61 74 69 62 6c 65 20 4f 70 65 6e -compatible Open
1260: 53 53 4c 20 63 72 79 70 74 20 70 61 73 73 77 6f SSL crypt passwo
1270: 72 64 73 20 74 6f 6f 2e 0a 3b 3b 0a 28 64 65 66 rds too..;;.(def
1280: 69 6e 65 20 28 73 3a 63 72 79 70 74 2d 70 61 73 ine (s:crypt-pas
1290: 73 77 64 20 70 77 20 73 29 0a 20 20 28 63 3a 63 swd pw s). (c:c
12a0: 72 79 70 74 20 70 77 20 28 6f 72 20 73 20 28 63 rypt pw (or s (c
12b0: 3a 63 72 79 70 74 2d 67 65 6e 73 61 6c 74 29 29 :crypt-gensalt))
12c0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 3a 70 ))..(define (s:p
12d0: 61 73 73 77 6f 72 64 2d 6d 61 74 63 68 3f 20 70 assword-match? p
12e0: 61 73 73 77 6f 72 64 20 63 72 79 70 74 65 64 29 assword crypted)
12f0: 0a 20 20 28 6c 65 74 2a 20 28 28 73 61 6c 74 20 . (let* ((salt
1300: 28 73 75 62 73 74 72 69 6e 67 20 63 72 79 70 74 (substring crypt
1310: 65 64 20 30 20 32 29 29 0a 20 20 20 20 20 20 20 ed 0 2)).
1320: 20 20 28 70 63 72 79 70 74 65 64 20 28 73 3a 63 (pcrypted (s:c
1330: 72 79 70 74 2d 70 61 73 73 77 64 20 70 61 73 73 rypt-passwd pass
1340: 77 6f 72 64 20 73 61 6c 74 29 29 29 0a 20 20 20 word salt))).
1350: 20 28 73 3a 6c 6f 67 20 22 49 4e 46 4f 3a 20 70 (s:log "INFO: p
1360: 63 72 79 70 74 65 64 3d 22 20 70 63 72 79 70 74 crypted=" pcrypt
1370: 65 64 20 22 20 63 72 79 70 74 65 64 3d 22 20 63 ed " crypted=" c
1380: 72 79 70 74 65 64 29 0a 20 20 20 20 28 61 6e 64 rypted). (and
1390: 20 28 73 74 72 69 6e 67 3f 20 70 61 73 73 77 6f (string? passwo
13a0: 72 64 29 0a 20 20 20 20 20 20 20 20 20 28 73 74 rd). (st
13b0: 72 69 6e 67 3f 20 70 63 72 79 70 74 65 64 29 0a ring? pcrypted).
13c0: 20 20 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 (string
13d0: 3d 3f 20 70 63 72 79 70 74 65 64 20 63 72 79 70 =? pcrypted cryp
13e0: 74 65 64 29 29 29 29 0a 0a 3b 3b 20 28 72 65 61 ted))))..;; (rea
13f0: 64 2d 6c 69 6e 65 20 28 6f 70 65 6e 2d 69 6e 70 d-line (open-inp
1400: 75 74 2d 70 69 70 65 20 22 65 63 68 6f 20 66 6f ut-pipe "echo fo
1410: 6f 20 7c 20 6d 6b 70 61 73 73 77 64 20 2d 53 20 o | mkpasswd -S
1420: 61 62 20 2d 73 22 29 29 0a 0a 28 64 65 66 69 6e ab -s"))..(defin
1430: 65 20 28 73 3a 65 72 72 6f 72 2d 70 61 67 65 20 e (s:error-page
1440: 2e 20 65 72 72 29 0a 20 20 28 73 3a 63 67 69 2d . err). (s:cgi-
1450: 6f 75 74 20 28 63 6f 6e 73 20 22 43 6f 6e 74 65 out (cons "Conte
1460: 6e 74 2d 74 79 70 65 3a 20 74 65 78 74 2f 68 74 nt-type: text/ht
1470: 6d 6c 3b 20 63 68 61 72 73 65 74 3d 69 73 6f 2d ml; charset=iso-
1480: 38 38 35 39 2d 31 5c 6e 5c 6e 22 0a 09 09 20 20 8859-1\n\n"...
1490: 20 28 73 3a 68 74 6d 6c 20 28 73 3a 68 65 61 64 (s:html (s:head
14a0: 20 0a 09 09 09 20 20 20 20 28 73 3a 74 69 74 6c .... (s:titl
14b0: 65 20 65 72 72 29 0a 09 09 09 20 20 20 20 28 73 e err).... (s
14c0: 3a 62 6f 64 79 0a 09 09 09 20 20 20 20 20 28 73 :body.... (s
14d0: 3a 68 31 20 22 45 52 52 4f 52 22 29 0a 09 09 09 :h1 "ERROR")....
14e0: 20 20 20 20 20 28 73 3a 70 20 65 72 72 29 29 29 (s:p err)))
14f0: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 ))))..(define (s
1500: 3a 76 61 6c 69 64 61 74 65 2d 75 72 69 29 0a 20 :validate-uri).
1510: 20 28 6c 65 74 20 28 28 75 72 69 20 28 67 65 74 (let ((uri (get
1520: 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 -environment-var
1530: 69 61 62 6c 65 20 22 52 45 51 55 45 53 54 5f 55 iable "REQUEST_U
1540: 52 49 22 29 29 0a 09 28 71 72 73 20 28 67 65 74 RI"))..(qrs (get
1550: 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 -environment-var
1560: 69 61 62 6c 65 20 22 51 55 45 52 59 5f 53 54 52 iable "QUERY_STR
1570: 49 4e 47 22 29 29 29 0a 20 20 20 20 28 69 66 20 ING"))). (if
1580: 28 6e 6f 74 20 75 72 69 29 0a 09 28 73 65 74 21 (not uri)..(set!
1590: 20 75 72 69 20 71 72 73 29 29 0a 20 20 20 20 28 uri qrs)). (
15a0: 69 66 20 75 72 69 0a 09 28 73 74 72 69 6e 67 2d if uri..(string-
15b0: 6d 61 74 63 68 20 0a 09 20 28 72 65 67 65 78 70 match .. (regexp
15c0: 20 22 5e 28 2f 5b 61 2d 7a 5c 5c 2d 5c 5c 2e 5f "^(/[a-z\\-\\._
15d0: 3a 30 2d 39 5d 2a 29 2a 28 7c 5c 5c 3f 28 5b 41 :0-9]*)*(|\\?([A
15e0: 2d 5a 61 2d 7a 30 2d 39 5f 5c 5c 2d 5c 5c 2b 5d -Za-z0-9_\\-\\+]
15f0: 2b 3d 5b 41 2d 5a 61 2d 7a 30 2d 39 5f 5c 5c 2d +=[A-Za-z0-9_\\-
1600: 5c 5c 2e 5c 5c 2b 5d 2a 26 7b 30 2c 31 7d 29 2a \\.\\+]*&{0,1})*
1610: 29 24 22 29 20 75 72 69 29 0a 09 28 62 65 67 69 )$") uri)..(begi
1620: 6e 0a 09 20 20 28 73 3a 6c 6f 67 20 22 52 45 51 n.. (s:log "REQ
1630: 55 45 53 54 20 55 52 49 20 4e 4f 54 20 41 56 41 UEST URI NOT AVA
1640: 49 4c 41 42 4c 45 21 22 29 0a 09 20 20 28 6c 65 ILABLE!").. (le
1650: 74 20 28 28 70 20 28 6f 70 65 6e 2d 69 6e 70 75 t ((p (open-inpu
1660: 74 2d 70 69 70 65 20 22 65 6e 76 22 29 29 29 0a t-pipe "env"))).
1670: 09 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 . (let loop (
1680: 28 6c 20 28 72 65 61 64 2d 6c 69 6e 65 20 70 29 (l (read-line p)
1690: 29 0a 09 09 20 20 20 20 20 20 20 28 72 65 73 20 )... (res
16a0: 27 28 29 29 29 0a 09 20 20 20 20 20 20 28 69 66 '())).. (if
16b0: 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 6c 29 (eof-object? l)
16c0: 0a 09 09 20 20 28 73 3a 6c 6f 67 20 72 65 73 29 ... (s:log res)
16d0: 0a 09 09 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 ... (loop (read
16e0: 2d 6c 69 6e 65 20 70 29 28 63 6f 6e 73 20 28 6c -line p)(cons (l
16f0: 69 73 74 20 6c 20 22 3c 42 52 3e 22 29 20 72 65 ist l "<BR>") re
1700: 73 29 29 29 29 29 0a 09 20 20 23 74 29 29 29 29 s))))).. #t))))
1710: 0a 0a 28 64 65 66 69 6e 65 20 28 73 3a 76 61 6c ..(define (s:val
1720: 69 64 61 74 65 2d 69 6e 70 75 74 73 29 0a 20 20 idate-inputs).
1730: 28 69 66 20 28 6e 6f 74 20 28 73 3a 76 61 6c 69 (if (not (s:vali
1740: 64 61 74 65 2d 75 72 69 29 29 0a 20 20 20 20 20 date-uri)).
1750: 20 28 62 65 67 69 6e 20 28 73 3a 65 72 72 6f 72 (begin (s:error
1760: 2d 70 61 67 65 20 22 42 61 64 20 55 52 49 22 20 -page "Bad URI"
1770: 28 6c 65 74 20 28 28 72 65 66 20 28 67 65 74 2d (let ((ref (get-
1780: 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 environment-vari
1790: 61 62 6c 65 20 22 48 54 54 50 5f 52 45 46 45 52 able "HTTP_REFER
17a0: 45 52 22 29 29 29 0a 09 09 09 09 20 20 20 20 20 ER"))).....
17b0: 20 20 28 69 66 20 72 65 66 0a 09 09 09 09 09 20 (if ref......
17c0: 20 20 28 6c 69 73 74 20 22 72 65 66 65 72 72 65 (list "referre
17d0: 64 20 66 72 6f 6d 22 20 72 65 66 29 0a 09 09 09 d from" ref)....
17e0: 09 09 20 20 20 22 22 29 29 29 0a 09 20 20 20 20 .. "")))..
17f0: 20 28 65 78 69 74 29 29 29 29 0a 0a 3b 3b 20 61 (exit))))..;; a
1800: 6e 79 74 68 69 6e 67 20 65 78 63 65 70 74 20 61 nything except a
1810: 20 6c 69 73 74 20 69 73 20 63 6f 6e 76 65 72 74 list is convert
1820: 65 64 20 74 6f 20 61 20 73 74 72 69 6e 67 21 21 ed to a string!!
1830: 21 0a 28 64 65 66 69 6e 65 20 28 73 3a 61 6e 79 !.(define (s:any
1840: 2d 3e 73 74 72 69 6e 67 20 76 61 6c 29 0a 20 20 ->string val).
1850: 28 63 6f 6e 64 0a 20 20 20 28 28 73 74 72 69 6e (cond. ((strin
1860: 67 3f 20 76 61 6c 29 20 76 61 6c 29 0a 20 20 20 g? val) val).
1870: 28 28 6e 75 6d 62 65 72 3f 20 76 61 6c 29 20 28 ((number? val) (
1880: 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e 67 20 76 number->string v
1890: 61 6c 29 29 0a 20 20 20 28 28 73 79 6d 62 6f 6c al)). ((symbol
18a0: 3f 20 76 61 6c 29 20 28 73 79 6d 62 6f 6c 2d 3e ? val) (symbol->
18b0: 73 74 72 69 6e 67 20 76 61 6c 29 29 0a 20 20 20 string val)).
18c0: 28 28 65 71 3f 20 76 61 6c 20 23 66 29 20 22 22 ((eq? val #f) ""
18d0: 29 0a 20 20 20 28 28 65 71 3f 20 76 61 6c 20 23 ). ((eq? val #
18e0: 74 29 20 22 54 52 55 45 22 29 0a 20 20 20 28 28 t) "TRUE"). ((
18f0: 6c 69 73 74 3f 20 76 61 6c 29 20 76 61 6c 29 0a list? val) val).
1900: 20 20 20 28 65 6c 73 65 20 0a 20 20 20 20 28 6c (else . (l
1910: 65 74 20 28 28 6f 73 74 72 20 28 6f 70 65 6e 2d et ((ostr (open-
1920: 6f 75 74 70 75 74 2d 73 74 72 69 6e 67 29 29 29 output-string)))
1930: 0a 20 20 20 20 20 20 28 77 69 74 68 2d 6f 75 74 . (with-out
1940: 70 75 74 2d 74 6f 2d 70 6f 72 74 20 6f 73 74 72 put-to-port ostr
1950: 0a 09 28 6c 61 6d 62 64 61 20 28 29 0a 09 20 20 ..(lambda ()..
1960: 28 64 69 73 70 6c 61 79 20 76 61 6c 29 29 29 0a (display val))).
1970: 20 20 20 20 20 20 28 67 65 74 2d 6f 75 74 70 75 (get-outpu
1980: 74 2d 73 74 72 69 6e 67 20 6f 73 74 72 29 29 29 t-string ostr)))
1990: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 3a 61 ))..(define (s:a
19a0: 6e 79 2d 3e 6e 75 6d 62 65 72 20 76 61 6c 29 0a ny->number val).
19b0: 20 20 28 63 6f 6e 64 0a 20 20 20 28 28 6e 75 6d (cond. ((num
19c0: 62 65 72 3f 20 76 61 6c 29 20 20 76 61 6c 29 0a ber? val) val).
19d0: 20 20 20 28 28 73 74 72 69 6e 67 3f 20 76 61 6c ((string? val
19e0: 29 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 ) (string->numb
19f0: 65 72 20 76 61 6c 29 29 0a 20 20 20 28 28 73 79 er val)). ((sy
1a00: 6d 62 6f 6c 3f 20 76 61 6c 29 20 20 28 73 74 72 mbol? val) (str
1a10: 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 73 79 6d ing->number (sym
1a20: 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 76 61 6c 29 bol->string val)
1a30: 29 29 0a 20 20 20 28 65 6c 73 65 20 20 20 20 20 )). (else
1a40: 23 66 29 29 29 0a 0a 3b 3b 20 4e 42 2f 2f 20 74 #f)))..;; NB// t
1a50: 68 69 73 20 69 73 20 2a 69 6c 6c 65 67 61 6c 2a his is *illegal*
1a60: 20 70 67 69 6e 74 0a 28 64 65 66 69 6e 65 20 28 pgint.(define (
1a70: 73 3a 69 6c 6c 65 67 61 6c 2d 70 67 69 6e 74 20 s:illegal-pgint
1a80: 76 61 6c 29 0a 20 20 28 63 6f 6e 64 0a 20 20 20 val). (cond.
1a90: 28 28 3e 20 76 61 6c 20 32 31 34 37 34 38 33 36 ((> val 21474836
1aa0: 34 37 29 20 31 29 0a 20 20 20 28 28 3c 20 76 61 47) 1). ((< va
1ab0: 6c 20 2d 32 31 34 37 34 38 33 36 34 38 29 20 2d l -2147483648) -
1ac0: 31 29 0a 20 20 20 28 65 6c 73 65 20 23 66 29 29 1). (else #f))
1ad0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 3a 61 6e )..(define (s:an
1ae0: 79 2d 3e 70 67 69 6e 74 20 76 61 6c 29 0a 20 20 y->pgint val).
1af0: 28 6c 65 74 20 28 28 6e 20 28 73 3a 61 6e 79 2d (let ((n (s:any-
1b00: 3e 6e 75 6d 62 65 72 20 76 61 6c 29 29 29 0a 20 >number val))).
1b10: 20 20 20 28 69 66 20 6e 0a 09 28 69 66 20 28 73 (if n..(if (s
1b20: 3a 69 6c 6c 65 67 61 6c 2d 70 67 69 6e 74 20 6e :illegal-pgint n
1b30: 29 0a 09 20 20 20 20 23 66 0a 09 20 20 20 20 6e ).. #f.. n
1b40: 29 0a 09 6e 29 29 29 0a 0a 3b 3b 20 73 74 72 69 )..n)))..;; stri
1b50: 6e 67 20 69 73 20 61 20 73 74 72 69 6e 67 20 61 ng is a string a
1b60: 6e 64 20 6e 6f 6e 2d 7a 65 72 6f 20 6c 65 6e 67 nd non-zero leng
1b70: 74 68 0a 28 64 65 66 69 6e 65 20 28 6d 69 73 63 th.(define (misc
1b80: 3a 6e 6f 6e 2d 7a 65 72 6f 2d 73 74 72 69 6e 67 :non-zero-string
1b90: 20 73 74 72 29 0a 20 20 28 69 66 20 28 61 6e 64 str). (if (and
1ba0: 20 28 73 74 72 69 6e 67 3f 20 73 74 72 29 0a 20 (string? str).
1bb0: 20 20 20 20 20 20 20 20 20 20 28 3e 20 28 73 74 (> (st
1bc0: 72 69 6e 67 2d 6c 65 6e 67 74 68 20 73 74 72 29 ring-length str)
1bd0: 20 30 29 29 0a 20 20 20 20 20 20 73 74 72 0a 20 0)). str.
1be0: 20 20 20 20 20 23 66 29 29 0a 0a 3b 3b 3d 3d 3d #f))..;;===
1bf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1c00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1c10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1c20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1c30: 3d 3d 3d 0a 3b 3b 20 50 20 41 20 52 20 41 20 4d ===.;; P A R A M
1c40: 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d S.;;===========
1c50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1c60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1c70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1c80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 ===========..;;
1c90: 69 6e 70 75 74 3a 20 27 61 20 28 27 61 20 22 76 input: 'a ('a "v
1ca0: 61 6c 20 61 22 20 27 62 20 22 76 61 6c 20 62 22 al a" 'b "val b"
1cb0: 29 20 3d 3e 20 22 76 61 6c 20 61 22 0a 28 64 65 ) => "val a".(de
1cc0: 66 69 6e 65 20 28 73 3a 66 69 6e 64 2d 70 61 72 fine (s:find-par
1cd0: 61 6d 20 6b 65 79 20 70 61 72 61 6d 2d 6c 73 74 am key param-lst
1ce0: 29 0a 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 ). (let loop ((
1cf0: 68 65 61 64 20 28 63 61 72 20 70 61 72 61 6d 2d head (car param-
1d00: 6c 73 74 29 29 0a 09 20 20 20 20 20 28 74 61 69 lst)).. (tai
1d10: 6c 20 28 63 64 72 20 70 61 72 61 6d 2d 6c 73 74 l (cdr param-lst
1d20: 29 29 29 0a 20 20 20 20 28 69 66 20 28 65 71 3f ))). (if (eq?
1d30: 20 68 65 61 64 20 6b 65 79 29 0a 09 28 63 61 72 head key)..(car
1d40: 20 74 61 69 6c 29 0a 09 28 69 66 20 28 3c 20 28 tail)..(if (< (
1d50: 6c 65 6e 67 74 68 20 74 61 69 6c 29 20 32 29 20 length tail) 2)
1d60: 23 66 0a 09 20 20 20 20 28 6c 6f 6f 70 20 28 63 #f.. (loop (c
1d70: 61 64 72 20 74 61 69 6c 29 28 63 64 64 72 20 74 adr tail)(cddr t
1d80: 61 69 6c 29 29 29 29 29 29 0a 0a 28 64 65 66 69 ail))))))..(defi
1d90: 6e 65 20 28 73 3a 70 61 72 61 6d 2d 3e 73 74 72 ne (s:param->str
1da0: 69 6e 67 20 70 61 72 61 6d 29 0a 20 20 28 63 6f ing param). (co
1db0: 6e 63 20 28 73 79 6d 62 6f 6c 2d 3e 73 74 72 69 nc (symbol->stri
1dc0: 6e 67 20 28 63 61 72 20 70 61 72 61 6d 29 29 20 ng (car param))
1dd0: 22 3d 22 20 22 5c 22 22 20 28 63 61 64 72 20 70 "=" "\"" (cadr p
1de0: 61 72 61 6d 29 20 22 5c 22 22 29 29 0a 0a 3b 3b aram) "\""))..;;
1df0: 20 72 65 6d 6f 76 65 20 27 66 6f 6f 20 22 62 61 remove 'foo "ba
1e00: 72 22 20 66 72 6f 6d 20 28 27 66 6f 6f 20 22 62 r" from ('foo "b
1e10: 61 72 22 20 27 62 61 72 20 22 66 6f 6f 22 29 0a ar" 'bar "foo").
1e20: 28 64 65 66 69 6e 65 20 28 73 3a 72 65 6d 6f 76 (define (s:remov
1e30: 65 2d 70 61 72 61 6d 2d 6d 61 74 63 68 69 6e 67 e-param-matching
1e40: 20 70 61 72 61 6d 73 20 6b 65 79 29 0a 20 20 28 params key). (
1e50: 69 66 20 28 3d 20 28 6c 65 6e 67 74 68 20 70 61 if (= (length pa
1e60: 72 61 6d 73 29 20 30 29 27 28 29 20 3b 3b 20 20 rams) 0)'() ;;
1e70: 70 72 6f 70 65 72 20 70 61 72 61 6d 73 20 6c 69 proper params li
1e80: 73 74 20 3e 3d 20 32 20 69 74 65 6d 73 0a 20 20 st >= 2 items.
1e90: 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 (let loop ((
1ea0: 68 65 61 64 20 20 20 20 20 28 63 61 72 20 70 61 head (car pa
1eb0: 72 61 6d 73 29 29 0a 20 20 20 20 20 20 20 20 20 rams)).
1ec0: 20 20 20 20 20 20 20 20 28 74 61 69 6c 20 20 20 (tail
1ed0: 20 20 28 63 64 72 20 70 61 72 61 6d 73 29 29 0a (cdr params)).
1ee0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1ef0: 20 28 72 65 73 75 6c 74 20 20 20 27 28 29 29 29 (result '()))
1f00: 0a 20 20 20 20 20 20 20 20 28 69 66 20 28 73 79 . (if (sy
1f10: 6d 62 6f 6c 3f 20 68 65 61 64 29 20 3b 3b 20 73 mbol? head) ;; s
1f20: 79 6d 62 6f 6c 73 20 68 61 76 65 20 70 61 72 61 ymbols have para
1f30: 6d 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 ms. (
1f40: 6c 65 74 20 28 28 76 61 6c 20 20 20 20 20 28 63 let ((val (c
1f50: 61 72 20 74 61 69 6c 29 29 0a 20 20 20 20 20 20 ar tail)).
1f60: 20 20 20 20 20 20 20 20 20 20 20 20 28 6e 65 77 (new
1f70: 74 61 69 6c 20 28 63 64 72 20 74 61 69 6c 29 29 tail (cdr tail))
1f80: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
1f90: 28 69 66 20 28 65 71 3f 20 68 65 61 64 20 6b 65 (if (eq? head ke
1fa0: 79 29 20 20 3b 3b 20 67 65 74 20 72 69 64 20 6f y) ;; get rid o
1fb0: 66 20 74 68 69 73 20 6f 6e 65 0a 20 20 20 20 20 f this one.
1fc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
1fd0: 20 28 6e 75 6c 6c 3f 20 6e 65 77 74 61 69 6c 29 (null? newtail)
1fe0: 20 72 65 73 75 6c 74 0a 20 20 20 20 20 20 20 20 result.
1ff0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
2000: 6f 6f 70 20 28 63 61 72 20 6e 65 77 74 61 69 6c oop (car newtail
2010: 29 28 63 64 72 20 6e 65 77 74 61 69 6c 29 20 72 )(cdr newtail) r
2020: 65 73 75 6c 74 29 29 0a 20 20 20 20 20 20 20 20 esult)).
2030: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 (let (
2040: 28 6e 65 77 72 65 73 75 6c 74 20 28 61 70 70 65 (newresult (appe
2050: 6e 64 20 72 65 73 75 6c 74 20 28 6c 69 73 74 20 nd result (list
2060: 68 65 61 64 20 76 61 6c 29 29 29 29 0a 20 20 20 head val)))).
2070: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2080: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 6e 65 77 74 (if (null? newt
2090: 61 69 6c 29 20 6e 65 77 72 65 73 75 6c 74 0a 20 ail) newresult.
20a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
20b0: 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 (loop (ca
20c0: 72 20 6e 65 77 74 61 69 6c 29 28 63 64 72 20 6e r newtail)(cdr n
20d0: 65 77 74 61 69 6c 29 20 6e 65 77 72 65 73 75 6c ewtail) newresul
20e0: 74 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 t))))).
20f0: 20 20 20 28 6c 65 74 20 28 28 6e 65 77 72 65 73 (let ((newres
2100: 75 6c 74 20 28 61 70 70 65 6e 64 20 72 65 73 75 ult (append resu
2110: 6c 74 20 28 6c 69 73 74 20 68 65 61 64 29 29 29 lt (list head)))
2120: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
2130: 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 69 6c 29 (if (null? tail)
2140: 20 6e 65 77 72 65 73 75 6c 74 0a 20 20 20 20 20 newresult.
2150: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 6f (lo
2160: 6f 70 20 28 63 61 72 20 74 61 69 6c 29 28 63 64 op (car tail)(cd
2170: 72 20 74 61 69 6c 29 20 6e 65 77 72 65 73 75 6c r tail) newresul
2180: 74 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e t)))))))..(defin
2190: 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 e (session:get-p
21a0: 61 72 61 6d 2d 66 72 6f 6d 20 70 61 72 61 6d 73 aram-from params
21b0: 20 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 28 72 key). (let ((r
21c0: 31 20 28 72 65 67 65 78 70 20 28 63 6f 6e 63 20 1 (regexp (conc
21d0: 22 5e 22 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 "^" (s:any->stri
21e0: 6e 67 20 6b 65 79 29 20 22 3d 28 2e 2a 29 24 22 ng key) "=(.*)$"
21f0: 29 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 75 )))). (if (nu
2200: 6c 6c 3f 20 70 61 72 61 6d 73 29 20 23 66 0a 20 ll? params) #f.
2210: 20 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 (let loop
2220: 20 28 28 68 65 61 64 20 28 63 61 72 20 70 61 72 ((head (car par
2230: 61 6d 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 ams)).
2240: 20 20 20 20 20 20 20 20 20 28 74 61 69 6c 20 28 (tail (
2250: 63 64 72 20 70 61 72 61 6d 73 29 29 29 0a 20 20 cdr params))).
2260: 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 6d (let ((m
2270: 61 74 63 68 20 28 73 74 72 69 6e 67 2d 6d 61 74 atch (string-mat
2280: 63 68 20 72 31 20 68 65 61 64 29 29 29 0a 20 20 ch r1 head))).
2290: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 6d 61 (if ma
22a0: 74 63 68 0a 20 20 20 20 20 20 20 20 20 20 20 20 tch.
22b0: 20 20 20 20 28 6c 69 73 74 2d 72 65 66 20 6d 61 (list-ref ma
22c0: 74 63 68 20 31 29 0a 20 20 20 20 20 20 20 20 20 tch 1).
22d0: 20 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c (if (null
22e0: 3f 20 74 61 69 6c 29 20 23 66 0a 20 20 20 20 20 ? tail) #f.
22f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
2300: 6c 6f 6f 70 20 28 63 61 72 20 74 61 69 6c 29 28 loop (car tail)(
2310: 63 64 72 20 74 61 69 6c 29 29 29 29 29 29 29 29 cdr tail))))))))
2320: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 3a 70 72 )..(define (s:pr
2330: 6f 63 65 73 73 2d 70 61 72 61 6d 73 20 70 61 72 ocess-params par
2340: 61 6d 73 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c ams). (if (null
2350: 3f 20 70 61 72 61 6d 73 29 20 22 22 0a 20 20 20 ? params) "".
2360: 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 72 (let loop ((r
2370: 65 73 20 22 22 29 0a 20 20 20 20 20 20 20 20 20 es "").
2380: 20 20 20 20 20 20 20 20 28 68 65 61 64 20 28 63 (head (c
2390: 61 72 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 ar params)).
23a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 61 (ta
23b0: 69 6c 20 28 63 64 72 20 70 61 72 61 6d 73 29 29 il (cdr params))
23c0: 29 0a 20 20 20 20 20 20 20 20 28 69 66 20 28 6e ). (if (n
23d0: 75 6c 6c 3f 20 74 61 69 6c 29 0a 20 20 20 20 20 ull? tail).
23e0: 20 20 20 20 20 20 20 28 63 6f 6e 63 20 72 65 73 (conc res
23f0: 20 22 20 22 20 28 73 3a 70 61 72 61 6d 2d 3e 73 " " (s:param->s
2400: 74 72 69 6e 67 20 68 65 61 64 29 29 0a 20 20 20 tring head)).
2410: 20 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 0a 20 (loop.
2420: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e (con
2430: 63 20 72 65 73 20 22 20 22 20 28 73 3a 70 61 72 c res " " (s:par
2440: 61 6d 2d 3e 73 74 72 69 6e 67 20 68 65 61 64 29 am->string head)
2450: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ). (
2460: 63 61 72 20 74 61 69 6c 29 0a 20 20 20 20 20 20 car tail).
2470: 20 20 20 20 20 20 20 28 63 64 72 20 74 61 69 6c (cdr tail
2480: 29 29 29 29 29 29 0a 0a 3b 3b 20 72 65 6d 6f 76 ))))))..;; remov
2490: 65 20 6b 65 79 3d 76 61 72 20 66 72 6f 6d 20 28 e key=var from (
24a0: 6b 65 79 3d 76 61 72 20 6b 65 79 31 3d 76 61 72 key=var key1=var
24b0: 31 20 6b 65 79 32 3d 76 61 72 32 20 2e 2e 2e 29 1 key2=var2 ...)
24c0: 0a 28 64 65 66 69 6e 65 20 28 6b 3d 76 2d 70 61 .(define (k=v-pa
24d0: 72 61 6d 73 3a 72 65 6d 6f 76 65 2d 6d 61 74 63 rams:remove-matc
24e0: 68 69 6e 67 20 70 61 72 61 6d 73 20 6b 65 79 29 hing params key)
24f0: 0a 20 20 28 69 66 20 28 3d 20 28 6c 65 6e 67 74 . (if (= (lengt
2500: 68 20 70 61 72 61 6d 73 29 20 30 29 20 70 61 72 h params) 0) par
2510: 61 6d 73 0a 20 20 20 20 20 20 28 6c 65 74 20 28 ams. (let (
2520: 28 72 31 20 28 72 65 67 65 78 70 20 28 63 6f 6e (r1 (regexp (con
2530: 63 20 22 5e 22 20 6b 65 79 20 22 3d 22 29 29 29 c "^" key "=")))
2540: 29 0a 20 20 20 20 20 20 20 20 28 6c 65 74 20 6c ). (let l
2550: 6f 6f 70 20 28 28 68 65 61 64 20 28 63 61 72 20 oop ((head (car
2560: 70 61 72 61 6d 73 29 29 0a 20 20 20 20 20 20 20 params)).
2570: 20 20 20 20 20 20 20 20 20 20 20 20 28 74 61 69 (tai
2580: 6c 20 28 63 64 72 20 70 61 72 61 6d 73 29 29 0a l (cdr params)).
2590: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
25a0: 20 20 20 28 72 65 73 75 6c 74 20 27 28 29 29 29 (result '()))
25b0: 0a 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 . (if (
25c0: 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 72 31 20 string-match r1
25d0: 68 65 61 64 29 0a 20 20 20 20 20 20 20 20 20 20 head).
25e0: 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 (if (null? t
25f0: 61 69 6c 29 20 72 65 73 75 6c 74 0a 20 20 20 20 ail) result.
2600: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
2610: 6f 6f 70 20 28 63 61 72 20 74 61 69 6c 29 28 63 oop (car tail)(c
2620: 64 72 20 74 61 69 6c 29 20 72 65 73 75 6c 74 29 dr tail) result)
2630: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
2640: 28 6c 65 74 20 28 28 6e 65 77 6c 73 74 20 28 63 (let ((newlst (c
2650: 6f 6e 73 20 68 65 61 64 20 72 65 73 75 6c 74 29 ons head result)
2660: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
2670: 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 (if (null? ta
2680: 69 6c 29 20 6e 65 77 6c 73 74 0a 20 20 20 20 20 il) newlst.
2690: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
26a0: 6c 6f 6f 70 20 28 63 61 72 20 74 61 69 6c 29 28 loop (car tail)(
26b0: 63 64 72 20 74 61 69 6c 29 20 6e 65 77 6c 73 74 cdr tail) newlst
26c0: 29 29 29 29 29 29 29 29 0a 0a ))))))))..