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

reformatting

Browse Source 
svn: r9853

original commit: 0d41afdb6d470299616dd1db944ce4577c5a64bf
This commit is contained in:
Eli Barzilay 2008-05-15 16:55:15 +00:00
parent db624416dd
commit ec81ffebfc
11 changed files with 2950 additions and 3011 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/net/base64-sig.ss
View File

@ -1,4 +1,3 @@
#lang scheme/signature
base64-filename-safe

16
collects/net/cgi-unit.ss
View File

@ -1,8 +1,5 @@
#lang scheme/unit
(require mzlib/etc
"cgi-sig.ss"
"uri-codec.ss")
(require "cgi-sig.ss" "uri-codec.ss")
(import)
(export cgi^)
@ -60,17 +57,14 @@
;; generate-html-output :
;; html-string x list (html-string) x ... -> ()
(define generate-html-output
(opt-lambda (title body-lines
(define (generate-html-output title body-lines
[text-color default-text-color]
[bg-color default-bg-color]
[link-color default-link-color]
[vlink-color default-vlink-color]
[alink-color default-alink-color])
(let ([sa string-append])
(for-each
(lambda (l) (display l) (newline))
`("Content-type: text/html"
(for ([l `("Content-type: text/html"
""
"<html>"
"<!-- The form was processed, and this document was generated,"
@ -90,7 +84,9 @@
,@body-lines
""
"</body>"
"</html>")))))
"</html>")])
(display l)
(newline))))
;; output-http-headers : -> void
(define (output-http-headers)

37
collects/net/cookie-unit.ss
View File

@ -50,16 +50,13 @@
#lang scheme/unit
(require mzlib/etc
mzlib/list
srfi/13/string
srfi/14/char-set
"cookie-sig.ss")
(require srfi/13/string srfi/14/char-set "cookie-sig.ss")
(import)
(export cookie^)
(define-struct cookie (name value comment domain max-age path secure version) #:mutable)
(define-struct cookie
(name value comment domain max-age path secure version) #:mutable)
(define-struct (cookie-error exn:fail) ())
;; error* : string args ... -> raises a cookie-error exception
@ -103,17 +100,17 @@
;; Formats the cookie contents in a string ready to be appended to a
;; "Set-Cookie: " header, and sent to a client (browser).
(define (print-cookie cookie)
(unless (cookie? cookie)
(error* "cookie expected, received: ~a" cookie))
(define (format-if fmt val) (and val (format fmt val)))
(unless (cookie? cookie) (error* "cookie expected, received: ~a" cookie))
(string-join
(filter (lambda (s) (not (string-null? s)))
(filter values
(list (format "~a=~a" (cookie-name cookie) (cookie-value cookie))
(let ([c (cookie-comment cookie)]) (if c (format "Comment=~a" c) ""))
(let ([d (cookie-domain cookie)]) (if d (format "Domain=~a" d) ""))
(let ([age (cookie-max-age cookie)]) (if age (format "Max-Age=~a" age) ""))
(let ([p (cookie-path cookie)]) (if p (format "Path=~a" p) ""))
(let ([s (cookie-secure cookie)]) (if s "Secure" ""))
(let ([v (cookie-version cookie)]) (format "Version=~a" (if v v 1)))))
(format-if "Comment=~a" (cookie-comment cookie))
(format-if "Domain=~a" (cookie-domain cookie))
(format-if "Max-Age=~a" (cookie-max-age cookie))
(format-if "Path=~a" (cookie-path cookie))
(and (cookie-secure cookie) "Secure")
(format "Version=~a" (or (cookie-version cookie) 1))))
"; "))
(define (cookie:add-comment cookie pre-comment)
@ -257,11 +254,10 @@
;; a character set for this definition because of two dependencies: CRLF must
;; appear as a block to be legal, and " may only appear as \"
(define (rfc2068:quoted-string? s)
(if (regexp-match
(and (regexp-match?
#rx"^\"([^\"#\u0000-#\u001F]| |#\return#\newline|#\tab|\\\\\")*\"$"
s)
s
#f))
s))
;; value: token | quoted-string
(define (rfc2109:value? s)
@ -298,14 +294,13 @@
;;
;; Returns whether this is a valid string to use as the value or the
;; name (depending on value?) of an HTTP cookie.
(define cookie-string?
(opt-lambda (s (value? #t))
(define (cookie-string? s [value? #t])
(unless (string? s)
(error* "string expected, received: ~a" s))
(if value?
(rfc2109:value? s)
;; name: token
(rfc2068:token? s))))
(rfc2068:token? s)))
;; Host names as per RFC 1123 and RFC952, more or less, anyway. :-)
(define char-set:hostname

31
collects/net/dns-unit.ss
View File

@ -1,7 +1,6 @@
#lang scheme/unit
(require mzlib/list mzlib/process "dns-sig.ss"
scheme/udp)
(require "dns-sig.ss" scheme/system scheme/udp)
(import)
(export dns^)
@ -52,8 +51,7 @@
d))
(define (name->octets s)
(let ([do-one (lambda (s)
(cons (bytes-length s) (bytes->list s)))])
(let ([do-one (lambda (s) (cons (bytes-length s) (bytes->list s)))])
(let loop ([s s])
(let ([m (regexp-match #rx#"^([^.]*)[.](.*)" s)])
(if m
@ -95,13 +93,12 @@
[(zero? (bitwise-and #xc0 v))
;; Normal label
(let loop ([len v][start (cdr start)][accum null])
(cond
[(zero? len)
(if (zero? len)
(let-values ([(s start) (parse-name start reply)])
(let ([s0 (list->bytes (reverse accum))])
(values (if s (bytes-append s0 #"." s) s0)
start)))]
[else (loop (sub1 len) (cdr start) (cons (car start) accum))]))]
start)))
(loop (sub1 len) (cdr start) (cons (car start) accum))))]
[else
;; Compression offset
(let ([offset (+ (arithmetic-shift (bitwise-and #x3f v) 8)
@ -167,12 +164,10 @@
(let ([s (make-bytes 512)])
(let retry ([timeout INIT-TIMEOUT])
(udp-send-to udp nameserver 53 (list->bytes query))
(sync (handle-evt
(udp-receive!-evt udp s)
(sync (handle-evt (udp-receive!-evt udp s)
(lambda (r)
(bytes->list (subbytes s 0 (car r)))))
(handle-evt
(alarm-evt (+ (current-inexact-milliseconds)
(handle-evt (alarm-evt (+ (current-inexact-milliseconds)
timeout))
(lambda (v)
(retry (* timeout 2))))))))
@ -217,7 +212,8 @@
(let ([v (hash-ref cache key (lambda () #f))])
(if v
(apply values v)
(let-values ([(auth? qds ans nss ars reply) (dns-query nameserver addr type class)])
(let-values ([(auth? qds ans nss ars reply)
(dns-query nameserver addr type class)])
(hash-set! cache key (list auth? qds ans nss ars reply))
(values auth? qds ans nss ars reply))))))
@ -249,8 +245,7 @@
(list-ref result 1))))
(define (get-ptr-list-from-ans ans)
(filter (lambda (ans-entry) (eq? (list-ref ans-entry 1) 'ptr))
ans))
(filter (lambda (ans-entry) (eq? (list-ref ans-entry 1) 'ptr)) ans))
(define (dns-get-name nameserver ip)
(or (try-forwarding
@ -334,12 +329,10 @@
(proc 'wait)
(or ip name)]
[(and (not name)
(regexp-match #rx"^Default Server: +(.*)$"
line))
(regexp-match #rx"^Default Server: +(.*)$" line))
=> (lambda (m) (loop (cadr m) #f #t))]
[(and try-ip?
(regexp-match #rx"^Address: +(.*)$"
line))
(regexp-match #rx"^Address: +(.*)$" line))
=> (lambda (m) (loop name (cadr m) #f))]
[else (loop name ip #f)]))))))]
[else #f]))

8
collects/net/head-unit.ss
View File

@ -95,7 +95,6 @@
;; Rest of header is this field, but strip trailing CRLFCRLF:
(regexp-replace #rx"\r\n\r\n$" s ""))))))))
(define (replace-field field data header)
(if (bytes? header)
(let ([m (regexp-match-positions (make-field-start-regexp/bytes field)
@ -108,8 +107,7 @@
(bytes-append pre (if data (insert-field field data rest) rest)))
(if data (insert-field field data header) header)))
;; otherwise header & field & data should be strings:
(let ([m (regexp-match-positions (make-field-start-regexp field)
header)])
(let ([m (regexp-match-positions (make-field-start-regexp field) header)])
(if m
(let* ([pre (substring header 0 (caaddr m))]
[s (substring header (cdaddr m))]
@ -242,9 +240,7 @@
(let* ([mq1 (regexp-match-positions re:quoted s)]
[mq2 (regexp-match-positions re:parened s)]
[mq (if (and mq1 mq2)
(if (< (caar mq1) (caar mq2))
mq1
mq2)
(if (< (caar mq1) (caar mq2)) mq1 mq2)
(or mq1 mq2))]
[mc (regexp-match-positions re:comma s)])
(if (and mq mc (< (caar mq) (caar mc) (cdar mq)))

19
collects/net/imap-unit.ss
View File

@ -141,8 +141,7 @@
(let ([info (imap-read (skip l 2) r)])
(log "info: ~s\n" info)
(info-handler info))
(when id
(loop))]
(when id (loop))]
[(starts-with? l #"+ ")
(if (null? continuation-handler)
(error 'imap-send "unexpected continuation request: ~a" l)
@ -462,22 +461,19 @@
[(+) "+FLAGS.SILENT"]
[(-) "-FLAGS.SILENT"]
[(!) "FLAGS.SILENT"]
[else (raise-type-error
'imap-store "mode: '!, '+, or '-" mode)])
[else (raise-type-error 'imap-store
"mode: '!, '+, or '-" mode)])
(box (format "~a" flags)))
void)))
(define (imap-copy imap msgs dest-mailbox)
(no-expunges 'imap-copy imap)
(check-ok
(imap-send imap (list "COPY" (box (msg-set msgs)) dest-mailbox)
void)))
(imap-send imap (list "COPY" (box (msg-set msgs)) dest-mailbox) void)))
(define (imap-append imap dest-mailbox msg)
(no-expunges 'imap-append imap)
(let ([msg (if (bytes? msg)
msg
(string->bytes/utf-8 msg))])
(let ([msg (if (bytes? msg) msg (string->bytes/utf-8 msg))])
(check-ok
(imap-send imap (list "APPEND"
dest-mailbox
@ -496,8 +492,7 @@
(check-ok (imap-send imap
(list "LIST" "" mailbox)
(lambda (i)
(when (and (pair? i)
(tag-eq? (car i) 'LIST))
(when (and (pair? i) (tag-eq? (car i) 'LIST))
(set! exists? #t)))))
exists?))
@ -505,7 +500,7 @@
(check-ok (imap-send imap (list "CREATE" mailbox) void)))
(define (imap-get-hierarchy-delimiter imap)
(let* ([result #f])
(let ([result #f])
(check-ok
(imap-send imap (list "LIST" "" "")
(lambda (i)

7
collects/net/mime-sig.ss
View File

@ -12,16 +12,13 @@
;; -- basic mime structures --
(struct message (version entity fields))
(struct entity
(type subtype charset encoding
(struct entity (type subtype charset encoding
disposition params id
description other fields
parts body))
(struct disposition
(type filename creation
(struct disposition (type filename creation
modification read
size params))
;; -- mime methods --
mime-analyze

35
collects/net/mime-unit.ss
View File

@ -34,9 +34,7 @@
"base64-sig.ss"
"head-sig.ss"
"mime-util.ss"
mzlib/etc
mzlib/string
mzlib/port)
scheme/port)
(import base64^ qp^ head^)
(export mime^)
@ -212,8 +210,7 @@
(lambda (output)
(copy-port input output))])))
(define mime-analyze
(opt-lambda (input (part #f))
(define (mime-analyze input [part #f])
(let* ([iport (if (bytes? input)
(open-input-bytes input)
input)]
@ -242,7 +239,7 @@
;; Unrecognized type, you're on your own! (sorry)
(mime-decode entity iport)])
;; return mime structure
msg)))
msg))
(define (entity-boundary entity)
(let* ([params (entity-params entity)]
@ -357,8 +354,8 @@
fields))
(values mime non-mime))))
(define re:content (regexp (format "^~a" (regexp-quote "content-" #f))))
(define re:mime (regexp (format "^~a:" (regexp-quote "mime-version" #f))))
(define re:content #rx"^(?i:content-)")
(define re:mime #rx"^(?i:mime-version):")
(define (mime-header? h)
(or (regexp-match? re:content h)
@ -370,8 +367,7 @@
;; *(";" parameter)
;; ; Matching of media type and subtype
;; ; is ALWAYS case-insensitive.
(define re:content-type
(regexp (format "^~a:([^/]+)/([^/]+)$" (regexp-quote "content-type" #f))))
(define re:content-type #rx"^(?i:content-type):([^/]+)/([^/]+)$")
(define (content header entity)
(let* ([params (string-tokenizer #\; header)]
[one re:content-type]
@ -394,9 +390,7 @@
(cond [par-pair
(when (string=? (car par-pair) "charset")
(set-entity-charset! entity (cdr par-pair)))
(loop (cdr p)
(append ans
(list par-pair)))]
(loop (cdr p) (append ans (list par-pair)))]
[else
(warning "Invalid parameter for Content-Type: `~a'" (car p))
;; go on...
@ -406,7 +400,7 @@
;; disposition := "Content-Disposition" ":"
;; disposition-type
;; *(";" disposition-parm)
(define re:content-disposition (regexp (format "^~a:(.+)$" (regexp-quote "content-disposition" #f))))
(define re:content-disposition #rx"^(?i:content-disposition):(.+)$")
(define (dispositione header entity)
(let* ([params (string-tokenizer #\; header)]
[reg re:content-disposition]
@ -420,8 +414,7 @@
(disp-params (cdr params) disp-struct))))
;; version := "MIME-Version" ":" 1*DIGIT "." 1*DIGIT
(define re:mime-version
(regexp (format "^~a:([0-9]+)\\.([0-9]+)$" (regexp-quote "MIME-Version" #f))))
(define re:mime-version #rx"^(?i:MIME-Version):([0-9]+)\\.([0-9]+)$")
(define (version header message)
(let* ([reg re:mime-version]
[h (trim-all-spaces header)]
@ -432,8 +425,7 @@
(string->number (regexp-replace reg h "\\1.\\2"))))))
;; description := "Content-Description" ":" *text
(define re:content-description
(regexp (format "^~a:[ \t\r\n]*(.*)$" (regexp-quote "content-description" #f))))
(define re:content-description #rx"^(?i:content-description):[ \t\r\n]*(.*)$")
(define (description header entity)
(let* ([reg re:content-description]
[target (regexp-match reg header)])
@ -443,7 +435,7 @@
(trim-spaces (regexp-replace reg header "\\1"))))))
;; encoding := "Content-Transfer-Encoding" ":" mechanism
(define re:content-transfer-encoding (regexp (format "^~a:(.+)$" (regexp-quote "content-transfer-encoding" #f))))
(define re:content-transfer-encoding #rx"^(?i:content-transfer-encoding):(.+)$")
(define (encoding header entity)
(let* ([reg re:content-transfer-encoding]
[h (trim-all-spaces header)]
@ -454,7 +446,7 @@
(mechanism (regexp-replace reg h "\\1"))))))
;; id := "Content-ID" ":" msg-id
(define re:content-id (regexp (format "^~a:(.+)$" (regexp-quote "content-id" #f))))
(define re:content-id #rx"^(?i:content-id):(.+)$")
(define (id header entity)
(let* ([reg re:content-id]
[h (trim-all-spaces header)]
@ -502,8 +494,7 @@
(set-entity-other!
entity
(append (entity-other entity)
(list
(cons (regexp-replace reg header "\\1")
(list (cons (regexp-replace reg header "\\1")
(trim-spaces (regexp-replace reg header "\\2")))))))))
;; type := discrete-type / composite-type

40
collects/net/qp-unit.ss
View File

@ -28,8 +28,7 @@
#lang scheme/unit
(require "qp-sig.ss"
mzlib/etc)
(require "qp-sig.ss")
(import)
(export qp^)
@ -42,22 +41,19 @@
;; qp-encode : bytes -> bytes
;; returns the quoted printable representation of STR.
(define qp-encode
(lambda (str)
(define (qp-encode str)
(let ([out (open-output-bytes)])
(qp-encode-stream (open-input-bytes str) out #"\r\n")
(get-output-bytes out))))
(get-output-bytes out)))
;; qp-decode : string -> string
;; returns STR unqp.
(define qp-decode
(lambda (str)
(define (qp-decode str)
(let ([out (open-output-bytes)])
(qp-decode-stream (open-input-bytes str) out)
(get-output-bytes out))))
(get-output-bytes out)))
(define qp-decode-stream
(lambda (in out)
(define (qp-decode-stream in out)
(let loop ([ch (read-byte in)])
(unless (eof-object? ch)
(case ch
@ -98,33 +94,27 @@
(loop (read-byte in)))]
[else
(write-byte ch out)
(loop (read-byte in))])))))
(loop (read-byte in))]))))
(define warning
(lambda (msg . args)
(define (warning msg . args)
(when #f
(fprintf (current-error-port)
(apply format msg args))
(newline (current-error-port)))))
(newline (current-error-port))))
(define (hex-digit? i)
(vector-ref hex-values i))
(define hex-bytes->byte
(lambda (b1 b2)
(define (hex-bytes->byte b1 b2)
(+ (* 16 (vector-ref hex-values b1))
(vector-ref hex-values b2))))
(vector-ref hex-values b2)))
(define write-hex-bytes
(lambda (byte p)
(define (write-hex-bytes byte p)
(write-byte 61 p)
(write-byte (vector-ref hex-bytes (arithmetic-shift byte -4)) p)
(write-byte (vector-ref hex-bytes (bitwise-and byte 15)) p)))
(write-byte (vector-ref hex-bytes (bitwise-and byte 15)) p))
(define re:blanks #rx#"[ \t]+$")
(define qp-encode-stream
(opt-lambda (in out [newline-string #"\n"])
(define (qp-encode-stream in out [newline-string #"\n"])
(let loop ([col 0])
(if (= col 75)
(begin
@ -155,7 +145,7 @@
[else
;; an octect
(write-hex-bytes i out)
(loop (+ col 3))]))))))
(loop (+ col 3))])))))
;; Tables
(define hex-values (make-vector 256 #f))

12
collects/net/sendmail-unit.ss
View File

@ -39,8 +39,8 @@
;; the port returned by this procedure as soon as the necessary text
;; has been written, so that the sendmail process can complete.
(define send-mail-message/port
(lambda (sender subject to-recipients cc-recipients bcc-recipients
(define (send-mail-message/port
sender subject to-recipients cc-recipients bcc-recipients
. other-headers)
(when (and (null? to-recipients) (null? cc-recipients)
(null? bcc-recipients))
@ -94,7 +94,7 @@
(newline writer))
other-headers)
(newline writer)
writer))))
writer)))
;; send-mail-message :
;; string x string x list (string) x list (string) x list (string) x
@ -106,8 +106,8 @@
;; RFC conventions. If any other headers are specified, they are
;; expected to be completely formatted already.
(define send-mail-message
(lambda (sender subject to-recipients cc-recipients bcc-recipients text
(define (send-mail-message
sender subject to-recipients cc-recipients bcc-recipients text
. other-headers)
(let ([writer (apply send-mail-message/port sender subject
to-recipients cc-recipients bcc-recipients
@ -116,4 +116,4 @@
(display s writer) ; We use -i, so "." is not a problem
(newline writer))
text)
(close-output-port writer))))
(close-output-port writer)))

51
collects/net/url-unit.ss
View File

@ -9,20 +9,13 @@
;; "impure" = they have text waiting
;; "pure" = the MIME headers have been read
(module url-unit scheme/base
(require mzlib/file
mzlib/unit
mzlib/port
mzlib/list
mzlib/string
mzlib/kw
#lang scheme/unit
(require scheme/port
"url-structs.ss"
"uri-codec.ss"
"url-sig.ss"
"tcp-sig.ss")
(provide url@)
(define-unit url@
(import tcp^)
(export url^)
@ -179,19 +172,18 @@
(let ([scheme (url-scheme url)])
(cond [(not scheme)
(schemeless-url url)]
[(or (string=? scheme "http")
(string=? scheme "https"))
[(or (string=? scheme "http") (string=? scheme "https"))
(http://getpost-impure-port get? url post-data strings)]
[(string=? scheme "file")
(url-error "There are no impure file: ports")]
[else (url-error "Scheme ~a unsupported" scheme)])))
;; get-impure-port : url [x list (str)] -> in-port
(define/kw (get-impure-port url #:optional [strings '()])
(define (get-impure-port url [strings '()])
(getpost-impure-port #t url #f strings))
;; post-impure-port : url x bytes [x list (str)] -> in-port
(define/kw (post-impure-port url post-data #:optional [strings '()])
(define (post-impure-port url post-data [strings '()])
(getpost-impure-port #f url post-data strings))
;; getpost-pure-port : bool x url x list (str) -> in-port
@ -213,11 +205,11 @@
[else (url-error "Scheme ~a unsupported" scheme)])))
;; get-pure-port : url [x list (str)] -> in-port
(define/kw (get-pure-port url #:optional [strings '()])
(define (get-pure-port url [strings '()])
(getpost-pure-port #t url #f strings))
;; post-pure-port : url bytes [x list (str)] -> in-port
(define/kw (post-pure-port url post-data #:optional [strings '()])
(define (post-pure-port url post-data [strings '()])
(getpost-pure-port #f url post-data strings))
;; display-pure-port : in-port -> ()
@ -378,8 +370,7 @@
scheme)))
(url-error "Invalid URL string; bad scheme ~e: ~e" scheme str))
;; Windows => "file://xxx:/...." specifies a "xxx:/..." path
(let ([win-file? (and (or (equal? "" port)
(not port))
(let ([win-file? (and (or (equal? "" port) (not port))
(equal? "file" scheme)
(eq? 'windows (file-url-path-convention-type))
(not (equal? host "")))])
@ -457,7 +448,8 @@
(loop (cdr strings) (list* (car strings) sep r))))]))
(define (path->url path)
(let ([url-path (let loop ([path (simplify-path path #f)][accum null])
(let ([url-path
(let loop ([path (simplify-path path #f)][accum null])
(let-values ([(base name dir?) (split-path path)])
(cond
[(not base)
@ -468,8 +460,7 @@
;; For Windows, massage the root:
(let ([s (regexp-replace
#rx"[/\\\\]$"
(bytes->string/utf-8
(path->bytes name))
(bytes->string/utf-8 (path->bytes name))
"")])
(cond
[(regexp-match? #rx"^\\\\\\\\[?]\\\\[a-zA-Z]:" s)
@ -503,27 +494,27 @@
(file://->path url kind))
;; delete-pure-port : url [x list (str)] -> in-port
(define/kw (delete-pure-port url #:optional [strings '()])
(define (delete-pure-port url [strings '()])
(method-pure-port 'delete url #f strings))
;; delete-impure-port : url [x list (str)] -> in-port
(define/kw (delete-impure-port url #:optional [strings '()])
(define (delete-impure-port url [strings '()])
(method-impure-port 'delete url #f strings))
;; head-pure-port : url [x list (str)] -> in-port
(define/kw (head-pure-port url #:optional [strings '()])
(define (head-pure-port url [strings '()])
(method-pure-port 'head url #f strings))
;; head-impure-port : url [x list (str)] -> in-port
(define/kw (head-impure-port url #:optional [strings '()])
(define (head-impure-port url [strings '()])
(method-impure-port 'head url #f strings))
;; put-pure-port : url bytes [x list (str)] -> in-port
(define/kw (put-pure-port url put-data #:optional [strings '()])
(define (put-pure-port url put-data [strings '()])
(method-pure-port 'put url put-data strings))
;; put-impure-port : url x bytes [x list (str)] -> in-port
(define/kw (put-impure-port url put-data #:optional [strings '()])
(define (put-impure-port url put-data [strings '()])
(method-impure-port 'put url put-data strings))
;; method-impure-port : symbol x url x list (str) -> in-port
@ -531,8 +522,7 @@
(let ([scheme (url-scheme url)])
(cond [(not scheme)
(schemeless-url url)]
[(or (string=? scheme "http")
(string=? scheme "https"))
[(or (string=? scheme "http") (string=? scheme "https"))
(http://method-impure-port method url data strings)]
[(string=? scheme "file")
(url-error "There are no impure file: ports")]
@ -543,8 +533,7 @@
(let ([scheme (url-scheme url)])
(cond [(not scheme)
(schemeless-url url)]
[(or (string=? scheme "http")
(string=? scheme "https"))
[(or (string=? scheme "http") (string=? scheme "https"))
(let ([port (http://method-impure-port
method url data strings)])
(with-handlers ([void (lambda (exn)
@ -586,5 +575,3 @@
(flush-output client->server)
(tcp-abandon-port client->server)
server->client))
))