suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Syncerating the countryside

Browse Source 
Syncerating the peasants
Syncerating all the peoples
in the thatched-roof COTTAGES!
THATCHED-ROOF COTTAGES!

svn: r12578
This commit is contained in:
Stevie Strickland 2008-11-24 17:52:56 +00:00
commit 702c1b7af2
27 changed files with 245 additions and 266 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/repos-time-stamp/stamp.ss
View File

@ -1 +1 @@
#lang scheme/base (provide stamp) (define stamp "21nov2008") #lang scheme/base (provide stamp) (define stamp "24nov2008")

144
collects/scheme/private/string.ss
View File

@ -32,21 +32,7 @@
s))))))) s)))))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Regexp helpers ;; Regexp utilities
(define (bstring-length s)
(if (bytes? s) (bytes-length s) (string-length s)))
(define (bstring->regexp name pattern)
(cond [(regexp? pattern) pattern]
[(byte-regexp? pattern) pattern]
[(string? pattern) (regexp pattern)]
[(bytes? pattern) (byte-regexp pattern)]
[else (raise-type-error
name "regexp, byte regexp, string, or byte string" pattern)]))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Regexp helpers
(define regexp-quote-chars:s #rx"[][.*?+|(){}\\$^]") (define regexp-quote-chars:s #rx"[][.*?+|(){}\\$^]")
(define regexp-quote-chars:b #rx#"[][.*?+|(){}\\$^]") (define regexp-quote-chars:b #rx#"[][.*?+|(){}\\$^]")
@ -69,6 +55,34 @@
[else (raise-type-error 'regexp-replace-quote [else (raise-type-error 'regexp-replace-quote
"string or byte string" s)])) "string or byte string" s)]))
(define (make-regexp-tweaker tweaker)
(let ([t (make-weak-hasheq)])
(lambda (rx)
(define-syntax-rule (->str x) (if (bytes? x) (bytes->string/utf-8 x) x))
(define-syntax-rule (->bts x) (if (bytes? x) x (string->bytes/utf-8 x)))
(define-syntax-rule (tweak unwrap wrap convert)
(let ([tweaked (tweaker (unwrap rx))])
;; the tweaker is allowed to return a regexp
(if (or (regexp? tweaked) (byte-regexp? tweaked))
tweaked
(wrap (convert tweaked)))))
(define (run-tweak)
(cond [(pregexp? rx) (tweak object-name pregexp ->str)]
[(regexp? rx) (tweak object-name regexp ->str)]
[(byte-pregexp? rx) (tweak object-name byte-pregexp ->bts)]
[(byte-regexp? rx) (tweak object-name byte-regexp ->bts)]
;; allow getting a string, so if someone needs to go
;; from a string to a regexp, there's no penalty
;; because of the intermediate regexp being recreated
[(string? rx) (tweak (lambda (x) x) regexp ->str)]
[(bytes? rx) (tweak (lambda (x) x) byte-regexp ->bts)]
[else (raise-type-error
'regexp-tweaker
"regexp, byte regexp, string, or byte string"
rx)]))
(or (hash-ref t rx #f)
(let ([rx* (run-tweak)]) (hash-set! t rx rx*) rx*)))))
(define (regexp-try-match pattern input-port [start-k 0] [end-k #f] [out #f]) (define (regexp-try-match pattern input-port [start-k 0] [end-k #f] [out #f])
(unless (input-port? input-port) (unless (input-port? input-port)
(raise-type-error 'regexp-try-match (raise-type-error 'regexp-try-match
@ -91,10 +105,19 @@
(and p (subbytes s (- (car p) drop) (- (cdr p) drop)))) (and p (subbytes s (- (car p) drop) (- (cdr p) drop))))
(cdr m)))))))) (cdr m))))))))
;; Helper macro for the regexp functions below. ;; Helper macro for the regexp functions below, with some utilities.
(define-syntax regexp-loop (define (bstring-length s)
(syntax-rules () (if (bytes? s) (bytes-length s) (string-length s)))
[(regexp-loop name loop start end rx string (define no-empty-edge-matches
(make-regexp-tweaker (lambda (rx) (format "(?=.)(?:~a)(?<=.)" rx))))
(define (bstring->no-edge-regexp name pattern)
(if (or (regexp? pattern) (byte-regexp? pattern)
(string? pattern) (bytes? pattern))
(no-empty-edge-matches pattern)
(raise-type-error
name "regexp, byte regexp, string, or byte string" pattern)))
(define-syntax-rule (regexp-loop
name loop start end rx string
success-choose failure-k success-choose failure-k
port-success-k port-success-choose port-failure-k port-success-k port-success-choose port-failure-k
need-leftover? peek?) need-leftover? peek?)
@ -121,8 +144,7 @@
start)) start))
(unless (or (not end) (unless (or (not end)
(and (start . <= . end) (and (start . <= . end)
(or (input-port? string) (or (input-port? string) (and len (end . <= . len)))))
(and len (end . <= . len)))))
(raise-mismatch-error (raise-mismatch-error
'name 'name
(format "ending offset index out of range [~a,~a]: " start len) (format "ending offset index out of range [~a,~a]: " start len)
@ -154,21 +176,6 @@
void))] void))]
[end (and end (- end start))] [end (and end (- end start))]
[m (regexp-match rx string 0 end spitout)] [m (regexp-match rx string 0 end spitout)]
;; re-match if we get a zero-length match at the
;; beginning
[m (if (and m ; we have a match
;; and it's an empty one
(zero? (bstring-length (car m)))
;; and it's at the beginning
(zero? (if need-leftover?
(file-position spitout)
discarded/leftovers))
;; and we still have stuff to match
(if end
(< 0 end)
(not (eof-object? (peek-byte string)))))
(regexp-match rx string 1 end spitout)
m)]
[m (and m (car m))] [m (and m (car m))]
[discarded/leftovers (if need-leftover? [discarded/leftovers (if need-leftover?
(get-output-bytes spitout) (get-output-bytes spitout)
@ -178,69 +185,31 @@
(bstring-length discarded/leftovers) (bstring-length discarded/leftovers)
discarded/leftovers) discarded/leftovers)
(bstring-length m)))]) (bstring-length m)))])
;; drop matches that are both empty and at the end (if m
(if (and m (or (< 0 (bstring-length m))
(if end
(< 0 end)
(not (eof-object? (peek-byte string))))))
(loop (cons (port-success-choose m discarded/leftovers) acc) (loop (cons (port-success-choose m discarded/leftovers) acc)
0 end) 0 end)
(port-failure-k acc discarded/leftovers))) (port-failure-k acc discarded/leftovers)))
;; String/port match, get positions ;; String/port match, get positions
(let* ([match (if peek? (let ([m (if peek?
regexp-match-peek-positions (regexp-match-peek-positions rx string start end)
regexp-match-positions)] (regexp-match-positions rx string start end))])
[m (match rx string start end)])
(if (not m) (if (not m)
(failure-k acc start end) (failure-k acc start end)
(let* ([mstart (caar m)] (let ([mstart (caar m)] [mend (cdar m)])
[mend (cdar m)]
;; re-match if we get a zero-length match at the
;; beginning, and we can continue
[m (if (and (= mstart mend start)
(cond
[end (< start end)]
[len (< start len)]
[(input-port? string)
(not (eof-object? (peek-byte string)))]
[else (error "internal error (str)")]))
(if (or peek? (not (input-port? string)))
(match rx string (add1 start) end)
;; rematching on a port requires adding `start'
;; offsets
(let ([m (match rx string 1 end)])
(if (and m (positive? start))
(list (cons (+ start (caar m))
(+ start (cdar m))))
m)))
m)])
;; fail if rematch failed
(if (not m)
(failure-k acc start end)
(let ([mstart (caar m)]
[mend (cdar m)])
;; or if we have a zero-length match at the end
(if (and (= mstart mend)
(cond [end (= mend end)]
[len (= mend len)]
[(input-port? string)
(eof-object?
(peek-byte string (if peek? mend 0)))]
[else (error "internal error (str)")]))
(failure-k acc start end)
(if port-success-k (if port-success-k
(port-success-k (port-success-k
(lambda (acc new-start new-end) (lambda (acc new-start new-end)
(loop acc new-start new-end)) (loop acc new-start new-end))
acc start end mstart mend) acc start end mstart mend)
(loop (cons (success-choose start mstart mend) acc) (loop (cons (success-choose start mstart mend) acc)
mend end))))))))))))])) mend end))))))))))
;; Returns all the positions at which the pattern matched. ;; Returns all the positions at which the pattern matched.
(define (regexp-match-positions* pattern string [start 0] [end #f]) (define (regexp-match-positions* pattern string [start 0] [end #f])
(define rx (bstring->regexp 'regexp-match-positions* pattern)) (regexp-loop
(regexp-loop regexp-match-positions* loop start end rx string regexp-match-positions* loop start end
(bstring->no-edge-regexp 'regexp-match-positions* pattern) string
;; success-choose: ;; success-choose:
(lambda (start mstart mend) (cons mstart mend)) (lambda (start mstart mend) (cons mstart mend))
;; failure-k: ;; failure-k:
@ -262,8 +231,9 @@
;; Returns all the positions at which the pattern matched. ;; Returns all the positions at which the pattern matched.
(define (regexp-match-peek-positions* pattern string [start 0] [end #f]) (define (regexp-match-peek-positions* pattern string [start 0] [end #f])
(define rx (bstring->regexp 'regexp-match-peek-positions* pattern)) (regexp-loop
(regexp-loop regexp-match-peek-positions* loop start end rx string regexp-match-peek-positions* loop start end
(bstring->no-edge-regexp 'regexp-match-peek-positions* pattern) string
;; success-choose: ;; success-choose:
(lambda (start mstart mend) (cons mstart mend)) (lambda (start mstart mend) (cons mstart mend))
;; failure-k: ;; failure-k:
@ -278,7 +248,7 @@
;; Splits a string into a list by removing any piece which matches ;; Splits a string into a list by removing any piece which matches
;; the pattern. ;; the pattern.
(define (regexp-split pattern string [start 0] [end #f]) (define (regexp-split pattern string [start 0] [end #f])
(define rx (bstring->regexp 'regexp-split pattern)) (define rx (bstring->no-edge-regexp 'regexp-split pattern))
(define buf (if (and (string? string) (byte-regexp? rx)) (define buf (if (and (string? string) (byte-regexp? rx))
(string->bytes/utf-8 string (char->integer #\?)) (string->bytes/utf-8 string (char->integer #\?))
string)) string))
@ -300,7 +270,7 @@
;; Returns all the matches for the pattern in the string. ;; Returns all the matches for the pattern in the string.
(define (regexp-match* pattern string [start 0] [end #f]) (define (regexp-match* pattern string [start 0] [end #f])
(define rx (bstring->regexp 'regexp-match* pattern)) (define rx (bstring->no-edge-regexp 'regexp-match* pattern))
(define buf (if (and (string? string) (byte-regexp? rx)) (define buf (if (and (string? string) (byte-regexp? rx))
(string->bytes/utf-8 string (char->integer #\?)) (string->bytes/utf-8 string (char->integer #\?))
string)) string))

10
collects/scribblings/tools/tools.scrbl
View File

@ -165,11 +165,9 @@ setup/infotab
] ]
then the same collection would be expected to contain a then the same collection would be expected to contain a
@File{tool.ss} file. It might contain something like this: @File{tool.ss} file. It might contain something like this:
@schemeblock[ @schememod[
(module tool mzscheme scheme/gui
(require (lib "tool.ss" "drscheme") (require drscheme/tool)
mred
mzlib/unit)
(provide tool@) (provide tool@)
@ -179,7 +177,7 @@ then the same collection would be expected to contain a
(export drscheme:tool-exports^) (export drscheme:tool-exports^)
(define (phase1) (message-box "tool example" "phase1")) (define (phase1) (message-box "tool example" "phase1"))
(define (phase2) (message-box "tool example" "phase2")) (define (phase2) (message-box "tool example" "phase2"))
(message-box "tool example" "unit invoked")))) (message-box "tool example" "unit invoked")))
] ]
This tool just opens a few windows to indicate that it has This tool just opens a few windows to indicate that it has
been loaded and that the @scheme[phase1] and @scheme[phase2] been loaded and that the @scheme[phase1] and @scheme[phase2]

67
collects/tests/mzscheme/string.ss
View File

@ -39,6 +39,7 @@
(define (->b x) (define (->b x)
(cond [(list? x) (map ->b x)] (cond [(list? x) (map ->b x)]
[(string? x) (string->bytes/utf-8 x)] [(string? x) (string->bytes/utf-8 x)]
[(pregexp? x) (byte-pregexp (->b (object-name x)))]
[else x])) [else x]))
(define fun* #f) (define fun* #f)
(define t (define t
@ -126,8 +127,8 @@
(t '((0 . 1) (2 . 3) (4 . 5)) "a b c" "[abc]" "a b c" 0 #f) (t '((0 . 1) (2 . 3) (4 . 5)) "a b c" "[abc]" "a b c" 0 #f)
(t '((0 . 1) (2 . 3) (4 . 5)) "a b c" "[abc]" "a b c" 0 5) (t '((0 . 1) (2 . 3) (4 . 5)) "a b c" "[abc]" "a b c" 0 5)
;; ---------- tests with zero-length matches ---------- ;; ---------- tests with zero-length matches ----------
;; Many of these tests can be repeated with Perl. To try something ;; Many of these tests can be repeated with Perl. To try something in Perl,
;; in Perl, put this code in a file: ;; put this code in a file:
;; #!/usr/bin/perl ;; #!/usr/bin/perl
;; sub test { ;; sub test {
;; my ($rx,$str) = @_; @words = split /$rx/, $str; ;; my ($rx,$str) = @_; @words = split /$rx/, $str;
@ -136,15 +137,16 @@
;; print ") eof \"$rx\" \"$str\")\n"; ;; print ") eof \"$rx\" \"$str\")\n";
;; }; ;; };
;; test("[abc]","1a2b3"); ;; test("[abc]","1a2b3");
;; and it will print a test that does what perl is doing. Tests ;; and it will print a test that does what perl is doing. Tests that differ
;; that differ from Perl have explanations. ;; from Perl have explanations.
;; ;;
(t regexp-split) (t regexp-split)
;; test("a","a"); ;; test("a","a");
;; (t '() eof "a" "a") ;; (t '() eof "a" "a")
;; perl returns an empty list, we return '("" ""), and this is a ;; perl returns an empty list, we return '("" ""), and this is a difference
;; difference that is unrelated to dealing with empty matches, ;; that is unrelated to dealing with empty matches, just the way that
;; just the way that perl's split throws out some empty matches. ;; perl's split throws out some empty matches (it throws empty matches at
;; the end (but not at the beginning for some reason...))
(t '("" "") eof "a" "a") (t '("" "") eof "a" "a")
;; test("3","123"); ;; test("3","123");
;; (t '("12") eof "3" "123") ;; (t '("12") eof "3" "123")
@ -162,49 +164,51 @@
(t '("1" "2" "3" "4") eof " *" "12 34") (t '("1" "2" "3" "4") eof " *" "12 34")
;; test(" *"," 12 34 "); ;; test(" *"," 12 34 ");
;; (t '("" "1" "2" "3" "4") eof " *" " 12 34 ") ;; (t '("" "1" "2" "3" "4") eof " *" " 12 34 ")
;; perl drops the last empty string, we don't -- unrelated to ;; again, perl drops the last empty string but we don't
;; empty matches (same as the <"a","a"> case above)
(t '("" "1" "2" "3" "4" "") eof " *" " 12 34 ") (t '("" "1" "2" "3" "4" "") eof " *" " 12 34 ")
;; test("2|", "1234"); ;; test("2|", "1234");
(t '("1" "3" "4") eof "2|" "1234") (t '("1" "3" "4") eof "2|" "1234")
;; test("1|", "1234"); ;; test("1|", "1234");
(t '("" "2" "3" "4") eof "1|" "1234") (t '("" "2" "3" "4") eof "1|" "1234")
;; test("4|", "1234"); ;; test("4|", "1234");
;; perl drops the last empty string, we don't, same as above ;; (t '("1" "2" "3") eof "4|" "1234")
;; perl perl drops the last empty string again
(t '("1" "2" "3" "") eof "4|" "1234") (t '("1" "2" "3" "") eof "4|" "1234")
;; test("|2", "1234"); ;; test("|2", "1234");
;; (t '("1" "" "3" "4") eof "|2" "1234") (t '("1" "" "3" "4") eof "|2" "1234")
;; perl will find the "2", we can't do that since we'll always
;; find the empty match first, so it's just like using "" (to do
;; the perl thing, we'll need a hook into the matcher's C code, or
;; some way of saying `match this pattern but prefer a non-empty
;; match if possible')
(t '("1" "2" "3" "4") eof "|2" "1234")
;; test("2|3", "1234"); ;; test("2|3", "1234");
(t '("1" "" "4") eof "2|3" "1234") (t '("1" "" "4") eof "2|3" "1234")
;; test("2|3|4", "12345");
(t '("1" "" "" "5") eof "2|3|4" "12345")
;; test("1|2", "1234"); ;; test("1|2", "1234");
(t '("" "" "34") eof "1|2" "1234") (t '("" "" "34") eof "1|2" "1234")
;; test("3|4", "1234"); ;; test("3|4", "1234");
;; (t '("12") eof "3|4" "1234") ;; (t '("12") eof "3|4" "1234")
;; again, perl dumps empty matches at the end, even two ;; perl perl drops the last empty string again -- even two here
(t '("12" "" "") eof "3|4" "1234") (t '("12" "" "") eof "3|4" "1234")
;; test("2|3|4", "1234");
;; (t '("1") eof "2|3|4" "1234")
;; ...and even three in this example
(t '("1" "" "" "") eof "2|3|4" "1234")
;; test('$',"123"); ;; test('$',"123");
(t '("123") eof "$" "123") (t '("123") eof "$" "123")
;; test('^',"123"); ;; test('^',"123");
;; (t '("123") eof "^" "123") ;; (t '("123") eof "^" "123")
;; this is a technicality: perl matches "^" once, but mzscheme ;; this is a technicality: perl matches "^" once, but mzscheme matches on
;; matches on whatever `start' may be; perl is treating it as a ;; whatever `start' may be; perl is treating it as a beginning-of-line
;; beginning-of-line instead of a ...-of-string behind your back ;; instead of a beginning-of-string behind your back "since it isn't much
;; "since it isn't much use otherwise" ;; use otherwise" (http://perldoc.perl.org/functions/split.html); but we
;; (http://perldoc.perl.org/functions/split.html); so our correct ;; don't allow empty matches at the beginning, so a `^' will never match,
;; test is: ;; and we get the same behavior anyway:
(t '("1" "2" "3") eof "^" "123") (t '("123") eof "^" "123")
;; and we can get the same with "(m?:^)": ;; test('^',"123\n456");
(t '("123") eof "(m?:^)" "123") ;; (t '("123\n" "456") eof "^" "123\n456")
;; we can get the same behavior as perl's with "(m?:^)":
(t '("123\n" "456") eof "(?m:^)" "123\n456")
;; test("\\b", "123 456");
(t '("123" " " "456") eof #px"\\b" "123 456")
;; test("^|a", "abc"); ;; test("^|a", "abc");
;; (t '("" "bc") eof "^|a" "abc") (t '("" "bc") eof "^|a" "abc")
;; same deal here, use "(m?:^)":
(t '("" "bc") eof "(m?:^|a)" "abc")
;; some tests with bounds (these have no perl equivalences) ;; some tests with bounds (these have no perl equivalences)
(t '("1" "2" " " "3" "4") eof "" "12 34" 0) (t '("1" "2" " " "3" "4") eof "" "12 34" 0)
(t '("1" "2" " " "3" "4") eof "" "12 34" 0 #f) (t '("1" "2" " " "3" "4") eof "" "12 34" 0 #f)
@ -249,7 +253,8 @@
(t "12 34" #f " *" "12 34") (t "12 34" #f " *" "12 34")
(t " 12 34 " #f " *" " 12 34 ") (t " 12 34 " #f " *" " 12 34 ")
(t "12 34" #f "" "12 34") (t "12 34" #f "" "12 34")
(t " 12 34 " #f "" " 12 34 ")) (t " 12 34 " #f "" " 12 34 ")
)
;; ---------- string-append* ---------- ;; ---------- string-append* ----------
(let () (let ()

2
collects/web-server/dispatchers/dispatch-files.ss
View File

@ -15,7 +15,7 @@
[read-range-header (-> (listof header?) (or/c (listof pair?) false/c))] [read-range-header (-> (listof header?) (or/c (listof pair?) false/c))]
[make [make
(->* (#:url->path url->path/c) (->* (#:url->path url->path/c)
(#:path->mime-type (path? . -> . bytes?) (#:path->mime-type (path-string? . -> . bytes?)
#:indices (listof path-string?)) #:indices (listof path-string?))
dispatcher/c)]) dispatcher/c)])

2
collects/web-server/dispatchers/dispatch-passwords.ss
View File

@ -22,7 +22,7 @@
[make-basic-denied?/path [make-basic-denied?/path
(authorized?/c . -> . denied?/c)] (authorized?/c . -> . denied?/c)]
[password-file->authorized? [password-file->authorized?
(path? . -> . (values (-> void) (path-string? . -> . (values (-> void)
authorized?/c))]) authorized?/c))])
(define interface-version 'v1) (define interface-version 'v1)

2
collects/web-server/dispatchers/filesystem-map.ss
View File

@ -8,7 +8,7 @@
(provide/contract (provide/contract
[url->path/c contract?] [url->path/c contract?]
[make-url->path (path? . -> . url->path/c)] [make-url->path (path-string? . -> . url->path/c)]
[make-url->valid-path (url->path/c . -> . url->path/c)] [make-url->valid-path (url->path/c . -> . url->path/c)]
[filter-url->path (regexp? url->path/c . -> . url->path/c)]) [filter-url->path (regexp? url->path/c . -> . url->path/c)])

2
collects/web-server/http/response.ss
View File

@ -15,7 +15,7 @@
(provide/contract (provide/contract
[rename ext:output-response output-response (connection? response? . -> . void)] [rename ext:output-response output-response (connection? response? . -> . void)]
[rename ext:output-response/method output-response/method (connection? response? symbol? . -> . void)] [rename ext:output-response/method output-response/method (connection? response? symbol? . -> . void)]
[rename ext:output-file output-file (connection? path? symbol? bytes? (or/c pair? false/c) . -> . void)]) [rename ext:output-file output-file (connection? path-string? symbol? bytes? (or/c pair? false/c) . -> . void)])
;; Table 1. head responses: ;; Table 1. head responses:
; ------------------------------------------------------------------------------ ; ------------------------------------------------------------------------------

5
collects/web-server/insta/insta.ss
View File

@ -15,10 +15,7 @@
(provide/contract (provide/contract
[static-files-path (path-string? . -> . void?)]) [static-files-path (path-string? . -> . void?)])
(define (static-files-path path) (define (static-files-path path)
(set! extra-files-path (set! extra-files-path path))
(if (path? path)
path
(string->path path))))
(provide/contract (provide/contract
[no-web-browser (-> void)]) [no-web-browser (-> void)])

2
collects/web-server/lang/file-box.ss
View File

@ -24,7 +24,7 @@
(provide/contract (provide/contract
[file-box? (any/c . -> . boolean?)] [file-box? (any/c . -> . boolean?)]
[file-box (path? serializable? . -> . file-box?)] [file-box (path-string? serializable? . -> . file-box?)]
[file-unbox (file-box? . -> . serializable?)] [file-unbox (file-box? . -> . serializable?)]
[file-box-set? (file-box? . -> . boolean?)] [file-box-set? (file-box? . -> . boolean?)]
[file-box-set! (file-box? serializable? . -> . void)]) [file-box-set! (file-box? serializable? . -> . void)])

2
collects/web-server/private/configure.ss
View File

@ -742,7 +742,7 @@
[copy-conf [copy-conf
(lambda (from to) (lambda (from to)
(let ([to-path (build-path-unless-absolute conf to)]) (let ([to-path (build-path-unless-absolute conf to)])
; more here - check existance of from path? ; more here - check existance of from path
(copy-file* (build-path from-conf from) to-path)))]) (copy-file* (build-path from-conf from) to-path)))])
(copy-conf "passwords-refresh.html" (messages-passwords-refreshed messages)) (copy-conf "passwords-refresh.html" (messages-passwords-refreshed messages))
(copy-conf "servlet-refresh.html" (messages-servlets-refreshed messages)) (copy-conf "servlet-refresh.html" (messages-servlets-refreshed messages))

2
collects/web-server/private/md5-store.ss
View File

@ -2,7 +2,7 @@
(require file/md5) (require file/md5)
(provide/contract (provide/contract
[md5-home (parameter/c path?)] [md5-home (parameter/c path-string?)]
[md5-store (bytes? . -> . bytes?)] [md5-store (bytes? . -> . bytes?)]
[md5-lookup (bytes? . -> . bytes?)]) [md5-lookup (bytes? . -> . bytes?)])

2
collects/web-server/private/servlet.ss
View File

@ -21,7 +21,7 @@
([custodian custodian?] ([custodian custodian?]
[namespace namespace?] [namespace namespace?]
[manager manager?] [manager manager?]
[directory path?] [directory path-string?]
[handler (request? . -> . response?)])] [handler (request? . -> . response?)])]
[struct execution-context [struct execution-context
([request request?])] ([request request?])]

8
collects/web-server/private/util.ss
View File

@ -7,7 +7,7 @@
xml/xml xml/xml
net/url) net/url)
(define path-element? (define path-element?
(or/c string? path? (symbols 'up 'same))) (or/c path-string? (symbols 'up 'same)))
(define port-number? (between/c 1 65535)) (define port-number? (between/c 1 65535))
@ -16,13 +16,13 @@
[port-number? contract?] [port-number? contract?]
[pretty-print-invalid-xexpr (exn:invalid-xexpr? any/c . -> . void)] [pretty-print-invalid-xexpr (exn:invalid-xexpr? any/c . -> . void)]
[url-replace-path (((listof path/param?) . -> . (listof path/param?)) url? . -> . url?)] [url-replace-path (((listof path/param?) . -> . (listof path/param?)) url? . -> . url?)]
[explode-path* (path? . -> . (listof path-element?))] [explode-path* (path-string? . -> . (listof path-element?))]
[path-without-base (path? path? . -> . (listof path-element?))] [path-without-base (path-string? path-string? . -> . (listof path-element?))]
[list-prefix? (list? list? . -> . boolean?)] [list-prefix? (list? list? . -> . boolean?)]
[strip-prefix-ups ((listof path-element?) . -> . (listof path-element?))] [strip-prefix-ups ((listof path-element?) . -> . (listof path-element?))]
[url-path->string ((listof path/param?) . -> . string?)] [url-path->string ((listof path/param?) . -> . string?)]
[network-error ((symbol? string?) (listof any/c) . ->* . (void))] [network-error ((symbol? string?) (listof any/c) . ->* . (void))]
[directory-part (path? . -> . path?)] [directory-part (path-string? . -> . path?)]
[lowercase-symbol! ((or/c string? bytes?) . -> . symbol?)] [lowercase-symbol! ((or/c string? bytes?) . -> . symbol?)]
[exn->string ((or/c exn? any/c) . -> . string?)] [exn->string ((or/c exn? any/c) . -> . string?)]
[build-path-unless-absolute (path-string? path-string? . -> . path?)] [build-path-unless-absolute (path-string? path-string? . -> . path?)]

2
collects/web-server/scribblings/dispatchers.scrbl
View File

@ -99,7 +99,7 @@ URLs to paths on the filesystem.
The returned @scheme[path?] is the path on disk. The list is the list of The returned @scheme[path?] is the path on disk. The list is the list of
path elements that correspond to the path of the URL.} path elements that correspond to the path of the URL.}
@defproc[(make-url->path (base path?)) @defproc[(make-url->path (base path-string?))
url->path/c]{ url->path/c]{
The @scheme[url-path/c] returned by this procedure considers the root The @scheme[url-path/c] returned by this procedure considers the root
URL to be @scheme[base]. It ensures that @scheme[".."]s in the URL URL to be @scheme[base]. It ensures that @scheme[".."]s in the URL

21
collects/web-server/scribblings/private.scrbl
View File

@ -181,6 +181,13 @@ provides the unit that actually implements a dispatching server.
} }
@subsection{Threads and Custodians}
The dispatching server runs in a dedicated thread. Every time a connection is initiated, a new thread is started to handle it.
Connection threads are created inside a dedicated custodian that is a child of the server's custodian. When the server is used to
provide servlets, each servlet also receives a new custodian that is a child of the server's custodian @bold{not} the connection
custodian.
@; ------------------------------------------------------------ @; ------------------------------------------------------------
@section[#:tag "closure.ss"]{Serializable Closures} @section[#:tag "closure.ss"]{Serializable Closures}
@(require (for-label web-server/private/closure) @(require (for-label web-server/private/closure)
@ -293,13 +300,13 @@ functions.
@filepath{private/mime-types.ss} provides function for dealing with @filepath{mime.types} @filepath{private/mime-types.ss} provides function for dealing with @filepath{mime.types}
files. files.
@defproc[(read-mime-types [p path?]) @defproc[(read-mime-types [p path-string?])
(hash-table/c symbol? bytes?)]{ (hash-table/c symbol? bytes?)]{
Reads the @filepath{mime.types} file from @scheme[p] and constructs a Reads the @filepath{mime.types} file from @scheme[p] and constructs a
hash table mapping extensions to MIME types. hash table mapping extensions to MIME types.
} }
@defproc[(make-path->mime-type [p path?]) @defproc[(make-path->mime-type [p path-string?])
(path? . -> . bytes?)]{ (path? . -> . bytes?)]{
Uses a @scheme[read-mime-types] with @scheme[p] and constructs a Uses a @scheme[read-mime-types] with @scheme[p] and constructs a
function from paths to their MIME type. function from paths to their MIME type.
@ -371,7 +378,7 @@ needs. They are provided by @filepath{private/util.ss}.
@subsection{Contracts} @subsection{Contracts}
@defthing[port-number? contract?]{Equivalent to @scheme[(between/c 1 65535)].} @defthing[port-number? contract?]{Equivalent to @scheme[(between/c 1 65535)].}
@defthing[path-element? contract?]{Equivalent to @scheme[(or/c string? path? (symbols 'up 'same))].} @defthing[path-element? contract?]{Equivalent to @scheme[(or/c path-string? (symbols 'up 'same))].}
@subsection{Lists} @subsection{Lists}
@defproc[(list-prefix? [l list?] @defproc[(list-prefix? [l list?]
@ -395,19 +402,19 @@ needs. They are provided by @filepath{private/util.ss}.
} }
@subsection{Paths} @subsection{Paths}
@defproc[(explode-path* [p path?]) @defproc[(explode-path* [p path-string?])
(listof path-element?)]{ (listof path-element?)]{
Like @scheme[normalize-path], but does not resolve symlinks. Like @scheme[normalize-path], but does not resolve symlinks.
} }
@defproc[(path-without-base [base path?] @defproc[(path-without-base [base path-string?]
[p path?]) [p path-string?])
(listof path-element?)]{ (listof path-element?)]{
Returns, as a list, the portion of @scheme[p] after @scheme[base], Returns, as a list, the portion of @scheme[p] after @scheme[base],
assuming @scheme[base] is a prefix of @scheme[p]. assuming @scheme[base] is a prefix of @scheme[p].
} }
@defproc[(directory-part [p path?]) @defproc[(directory-part [p path-string?])
path?]{ path?]{
Returns the directory part of @scheme[p], returning @scheme[(current-directory)] Returns the directory part of @scheme[p], returning @scheme[(current-directory)]
if it is relative. if it is relative.

2
collects/web-server/scribblings/running.scrbl
View File

@ -43,7 +43,7 @@ The following API is provided to customize the server instance:
@onscreen["Run"]. @onscreen["Run"].
} }
@defproc[(static-files-path [path path?]) void]{ @defproc[(static-files-path [path path-string?]) void]{
This instructs the Web server to serve static files, such as stylesheet and images, from @scheme[path]. This instructs the Web server to serve static files, such as stylesheet and images, from @scheme[path].
} }

14
collects/web-server/scribblings/servlet-env.scrbl
View File

@ -98,10 +98,10 @@ If you want to use @scheme[serve/servlet] in a start up script for a Web server,
[#:stateless? stateless? boolean? #f] [#:stateless? stateless? boolean? #f]
[#:manager manager manager? (make-threshold-LRU-manager #f (* 1024 1024 64))] [#:manager manager manager? (make-threshold-LRU-manager #f (* 1024 1024 64))]
[#:servlet-namespace servlet-namespace (listof module-path?) empty] [#:servlet-namespace servlet-namespace (listof module-path?) empty]
[#:server-root-path server-root-path path? default-server-root-path] [#:server-root-path server-root-path path-string? default-server-root-path]
[#:extra-files-paths extra-files-paths (listof path?) (list (build-path server-root-path "htdocs"))] [#:extra-files-paths extra-files-paths (listof path-string?) (list (build-path server-root-path "htdocs"))]
[#:servlets-root servlets-root path? (build-path server-root-path "htdocs")] [#:servlets-root servlets-root path-string? (build-path server-root-path "htdocs")]
[#:servlet-current-directory servlet-current-directory path? servlets-root] [#:servlet-current-directory servlet-current-directory path-string? servlets-root]
[#:file-not-found-responder file-not-found-responder [#:file-not-found-responder file-not-found-responder
(request? . -> . response?) (request? . -> . response?)
(gen-file-not-found-responder (gen-file-not-found-responder
@ -109,9 +109,9 @@ If you want to use @scheme[serve/servlet] in a start up script for a Web server,
server-root-path server-root-path
"conf" "conf"
"not-found.html"))] "not-found.html"))]
[#:mime-types-path mime-types-path path? [#:mime-types-path mime-types-path path-string?
...] ....]
[#:log-file log-file path? #f] [#:log-file log-file (or/c false/c path-string?) #f]
[#:log-format log-format symbol? 'apache-default]) [#:log-format log-format symbol? 'apache-default])
void]{ void]{
This sets up and starts a fairly default server instance. This sets up and starts a fairly default server instance.

8
collects/web-server/scribblings/servlet-setup.scrbl
View File

@ -12,21 +12,21 @@
This module is used internally to build and load servlets. It may be useful to those who are trying to extend the server. This module is used internally to build and load servlets. It may be useful to those who are trying to extend the server.
@defproc[(make-v1.servlet [directory path?] @defproc[(make-v1.servlet [directory path-string?]
[timeout integer?] [timeout integer?]
[start (request? . -> . response?)]) [start (request? . -> . response?)])
servlet?]{ servlet?]{
Creates a version 1 servlet that uses @scheme[directory] as its current directory, a timeout manager with a @scheme[timeout] timeout, and @scheme[start] as the request handler. Creates a version 1 servlet that uses @scheme[directory] as its current directory, a timeout manager with a @scheme[timeout] timeout, and @scheme[start] as the request handler.
} }
@defproc[(make-v2.servlet [directory path?] @defproc[(make-v2.servlet [directory path-string?]
[manager manager?] [manager manager?]
[start (request? . -> . response?)]) [start (request? . -> . response?)])
servlet?]{ servlet?]{
Creates a version 2 servlet that uses @scheme[directory] as its current directory, a @scheme[manager] as the continuation manager, and @scheme[start] as the request handler. Creates a version 2 servlet that uses @scheme[directory] as its current directory, a @scheme[manager] as the continuation manager, and @scheme[start] as the request handler.
} }
@defproc[(make-stateless.servlet [directory path?] @defproc[(make-stateless.servlet [directory path-string?]
[start (request? . -> . response?)]) [start (request? . -> . response?)])
servlet?]{ servlet?]{
Creates a stateless @schememodname[web-server] servlet that uses @scheme[directory] as its current directory and @scheme[start] as the request handler. Creates a stateless @schememodname[web-server] servlet that uses @scheme[directory] as its current directory and @scheme[start] as the request handler.
@ -62,7 +62,7 @@ Equivalent to @scheme[(path? . -> . servlet?)].
@defstruct[servlet ([custodian custodian?] @defstruct[servlet ([custodian custodian?]
[namespace namespace?] [namespace namespace?]
[manager manager?] [manager manager?]
[directory path?] [directory path-string?]
[handler (request? . -> . response?)]) [handler (request? . -> . response?)])
#:mutable]{ #:mutable]{
Instances of this structure hold the necessary parts of a servlet: Instances of this structure hold the necessary parts of a servlet:

4
collects/web-server/scribblings/templates.scrbl
View File

@ -268,7 +268,7 @@ the template to be unescaped, then create a @scheme[cdata] structure:
Expands into Expands into
@schemeblock[ @schemeblock[
(for/list ([x xs]) (for/list ([x xs])
(list e ...)) (begin/text e ...))
] ]
Template Example: Template Example:
@ -466,7 +466,7 @@ The code associated with these templates is very simple as well:
(define-struct post (title body comments)) (define-struct post (title body comments))
(define posts ...) (define posts ....)
(define (template section body) (define (template section body)
(list TEXT/HTML-MIME-TYPE (list TEXT/HTML-MIME-TYPE

2
collects/web-server/scribblings/tutorial/continue.scrbl
View File

@ -615,7 +615,7 @@ To do this, we set aside a path to store these files, and then tell
the web server where that directory is. The function the web server where that directory is. The function
@scheme[static-files-path], @scheme[static-files-path],
@defthing[static-files-path (path? -> void)] @defthing[static-files-path (path-string? -> void)]
tells the web server to look in the given path when it receives a URL tells the web server to look in the given path when it receives a URL
that looks like a static resource request. that looks like a static resource request.

8
collects/web-server/scribblings/web-config-unit.scrbl
View File

@ -58,7 +58,7 @@ Provides contains the following identifiers.
@defmodule[web-server/web-config-unit]{ @defmodule[web-server/web-config-unit]{
@defproc[(configuration-table->web-config@ [path path?] @defproc[(configuration-table->web-config@ [path path-string?]
[#:port port (or/c false/c port-number?) #f] [#:port port (or/c false/c port-number?) #f]
[#:listen-ip listen-ip (or/c false/c string?) #f] [#:listen-ip listen-ip (or/c false/c string?) #f]
[#:make-servlet-namespace make-servlet-namespace make-servlet-namespace/c (make-make-servlet-namespace)]) [#:make-servlet-namespace make-servlet-namespace make-servlet-namespace/c (make-make-servlet-namespace)])
@ -68,10 +68,12 @@ Provides contains the following identifiers.
} }
@defproc[(configuration-table-sexpr->web-config@ [sexpr list?] @defproc[(configuration-table-sexpr->web-config@ [sexpr list?]
[#:web-server-root web-server-root path? (directory-part default-configuration-table-path)] [#:web-server-root web-server-root path-string?
(directory-part default-configuration-table-path)]
[#:port port (or/c false/c port-number?) #f] [#:port port (or/c false/c port-number?) #f]
[#:listen-ip listen-ip (or/c false/c string?) #f] [#:listen-ip listen-ip (or/c false/c string?) #f]
[#:make-servlet-namespace make-servlet-namespace make-servlet-namespace/c (make-make-servlet-namespace)]) [#:make-servlet-namespace make-servlet-namespace make-servlet-namespace/c
(make-make-servlet-namespace)])
(unit? web-config^)]{ (unit? web-config^)]{
Parses @scheme[sexpr] as a configuration-table and constructs a @scheme[web-config^] unit. Parses @scheme[sexpr] as a configuration-table and constructs a @scheme[web-config^] unit.
} }

2
collects/web-server/scribblings/web.scrbl
View File

@ -128,7 +128,7 @@ functions of interest for the servlet developer.
(lambda (req) (lambda (req)
`(html (head (title "Custom Expiration!"))))]) `(html (head (title "Custom Expiration!"))))])
(send/suspend (send/suspend
...)) ....))
] ]
} }

2
collects/web-server/scribblings/writing.scrbl
View File

@ -104,7 +104,7 @@ boxes in a safe way.
@defproc[(file-box? [v any/c]) @defproc[(file-box? [v any/c])
boolean?]{Checks if @scheme[v] is a file-box.} boolean?]{Checks if @scheme[v] is a file-box.}
@defproc[(file-box [p path?] @defproc[(file-box [p path-string?]
[v serializable?]) [v serializable?])
file-box?]{ file-box?]{
Creates a file-box that is stored at @scheme[p], with the default Creates a file-box that is stored at @scheme[p], with the default

10
collects/web-server/servlet-env.ss
View File

@ -52,15 +52,15 @@
#:ssl? boolean? #:ssl? boolean?
#:manager manager? #:manager manager?
#:servlet-namespace (listof module-path?) #:servlet-namespace (listof module-path?)
#:server-root-path path? #:server-root-path path-string?
#:stateless? boolean? #:stateless? boolean?
#:extra-files-paths (listof path?) #:extra-files-paths (listof path-string?)
#:servlets-root path? #:servlets-root path-string?
#:file-not-found-responder (request? . -> . response?) #:file-not-found-responder (request? . -> . response?)
#:mime-types-path path? #:mime-types-path path-string?
#:servlet-path string? #:servlet-path string?
#:servlet-regexp regexp? #:servlet-regexp regexp?
#:log-file (or/c false/c path?)) #:log-file (or/c false/c path-string?))
. ->* . . ->* .
void)]) void)])

6
collects/web-server/servlet/setup.ss
View File

@ -97,9 +97,9 @@
servlet-module-specs servlet-module-specs
lang-module-specs)) lang-module-specs))
(provide/contract (provide/contract
[make-v1.servlet (path? integer? (request? . -> . response?) . -> . servlet?)] [make-v1.servlet (path-string? integer? (request? . -> . response?) . -> . servlet?)]
[make-v2.servlet (path? manager? (request? . -> . response?) . -> . servlet?)] [make-v2.servlet (path-string? manager? (request? . -> . response?) . -> . servlet?)]
[make-stateless.servlet (path? (request? . -> . response?) . -> . servlet?)] [make-stateless.servlet (path-string? (request? . -> . response?) . -> . servlet?)]
[default-module-specs (listof module-path?)]) [default-module-specs (listof module-path?)])
(define (make-default-path->servlet #:make-servlet-namespace [make-servlet-namespace (make-make-servlet-namespace)] (define (make-default-path->servlet #:make-servlet-namespace [make-servlet-namespace (make-make-servlet-namespace)]

2
collects/web-server/templates.ss
View File

@ -25,7 +25,7 @@
(syntax-rules () (syntax-rules ()
[(_ x xs e ...) [(_ x xs e ...)
(for/list ([x xs]) (for/list ([x xs])
(list e ...))])) (begin/text e ...))]))
(provide include-template (provide include-template
in) in)