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

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

@ -1,47 +1,44 @@
#lang scheme/unit
(require "cgi-sig.ss" "uri-codec.ss")
(require mzlib/etc
"cgi-sig.ss"
"uri-codec.ss")
(import)
(export cgi^)
(import)
(export cgi^)
;; type bindings = list ((symbol . string))
;; type bindings = list ((symbol . string))
;; --------------------------------------------------------------------
;; --------------------------------------------------------------------
;; Exceptions:
;; Exceptions:
(define-struct cgi-error ())
(define-struct cgi-error ())
;; chars : list (char)
;; -- gives the suffix which is invalid, not including the `%'
;; chars : list (char)
;; -- gives the suffix which is invalid, not including the `%'
(define-struct (incomplete-%-suffix cgi-error) (chars))
(define-struct (incomplete-%-suffix cgi-error) (chars))
;; char : char
;; -- an invalid character in a hex string
;; char : char
;; -- an invalid character in a hex string
(define-struct (invalid-%-suffix cgi-error) (char))
(define-struct (invalid-%-suffix cgi-error) (char))
;; --------------------------------------------------------------------
;; --------------------------------------------------------------------
;; query-chars->string : list (char) -> string
;; query-chars->string : list (char) -> string
;; -- The input is the characters post-processed as per Web specs, which
;; is as follows:
;; spaces are turned into "+"es and lots of things are turned into %XX, where
;; XX are hex digits, eg, %E7 for ~. The output is a regular Scheme string
;; with all the characters converted back.
;; -- The input is the characters post-processed as per Web specs, which
;; is as follows:
;; spaces are turned into "+"es and lots of things are turned into %XX, where
;; XX are hex digits, eg, %E7 for ~. The output is a regular Scheme string
;; with all the characters converted back.
(define (query-chars->string chars)
(define (query-chars->string chars)
(form-urlencoded-decode (list->string chars)))
;; string->html : string -> string
;; -- the input is raw text, the output is HTML appropriately quoted
;; string->html : string -> string
;; -- the input is raw text, the output is HTML appropriately quoted
(define (string->html s)
(define (string->html s)
(apply string-append
(map (lambda (c)
(case c
@ -51,26 +48,23 @@
[else (string c)]))
(string->list s))))
(define default-text-color "#000000")
(define default-bg-color "#ffffff")
(define default-link-color "#cc2200")
(define default-vlink-color "#882200")
(define default-alink-color "#444444")
(define default-text-color "#000000")
(define default-bg-color "#ffffff")
(define default-link-color "#cc2200")
(define default-vlink-color "#882200")
(define default-alink-color "#444444")
;; generate-html-output :
;; html-string x list (html-string) x ... -> ()
;; 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,34 +84,36 @@
,@body-lines
""
"</body>"
"</html>")))))
"</html>")])
(display l)
(newline))))
;; output-http-headers : -> void
(define (output-http-headers)
;; output-http-headers : -> void
(define (output-http-headers)
(printf "Content-type: text/html\r\n\r\n"))
;; read-until-char : iport x char -> list (char) x bool
;; -- operates on the default input port; the second value indicates whether
;; reading stopped because an EOF was hit (as opposed to the delimiter being
;; seen); the delimiter is not part of the result
(define (read-until-char ip delimiter)
;; read-until-char : iport x char -> list (char) x bool
;; -- operates on the default input port; the second value indicates whether
;; reading stopped because an EOF was hit (as opposed to the delimiter being
;; seen); the delimiter is not part of the result
(define (read-until-char ip delimiter)
(let loop ([chars '()])
(let ([c (read-char ip)])
(cond [(eof-object? c) (values (reverse chars) #t)]
[(char=? c delimiter) (values (reverse chars) #f)]
[else (loop (cons c chars))]))))
;; read-name+value : iport -> (symbol + bool) x (string + bool) x bool
;; -- If the first value is false, so is the second, and the third is true,
;; indicating EOF was reached without any input seen. Otherwise, the first
;; and second values contain strings and the third is either true or false
;; depending on whether the EOF has been reached. The strings are processed
;; to remove the CGI spec "escape"s. This code is _slightly_ lax: it allows
;; an input to end in `&'. It's not clear this is legal by the CGI spec,
;; which suggests that the last value binding must end in an EOF. It doesn't
;; look like this matters. It would also introduce needless modality and
;; reduce flexibility.
(define (read-name+value ip)
;; read-name+value : iport -> (symbol + bool) x (string + bool) x bool
;; -- If the first value is false, so is the second, and the third is true,
;; indicating EOF was reached without any input seen. Otherwise, the first
;; and second values contain strings and the third is either true or false
;; depending on whether the EOF has been reached. The strings are processed
;; to remove the CGI spec "escape"s. This code is _slightly_ lax: it allows
;; an input to end in `&'. It's not clear this is legal by the CGI spec,
;; which suggests that the last value binding must end in an EOF. It doesn't
;; look like this matters. It would also introduce needless modality and
;; reduce flexibility.
(define (read-name+value ip)
(let-values ([(name eof?) (read-until-char ip #\=)])
(cond [(and eof? (null? name)) (values #f #f #t)]
[eof?
@ -130,15 +126,15 @@
(query-chars->string value)
eof?))])))
;; get-bindings/post : () -> bindings
(define (get-bindings/post)
;; get-bindings/post : () -> bindings
(define (get-bindings/post)
(let-values ([(name value eof?) (read-name+value (current-input-port))])
(cond [(and eof? (not name)) null]
[(and eof? name) (list (cons name value))]
[else (cons (cons name value) (get-bindings/post))])))
;; get-bindings/get : () -> bindings
(define (get-bindings/get)
;; get-bindings/get : () -> bindings
(define (get-bindings/get)
(let ([p (open-input-string (getenv "QUERY_STRING"))])
(let loop ()
(let-values ([(name value eof?) (read-name+value p)])
@ -146,20 +142,20 @@
[(and eof? name) (list (cons name value))]
[else (cons (cons name value) (loop))])))))
;; get-bindings : () -> bindings
(define (get-bindings)
;; get-bindings : () -> bindings
(define (get-bindings)
(if (string=? (get-cgi-method) "POST")
(get-bindings/post)
(get-bindings/get)))
;; generate-error-output : list (html-string) -> <exit>
(define (generate-error-output error-message-lines)
;; generate-error-output : list (html-string) -> <exit>
(define (generate-error-output error-message-lines)
(generate-html-output "Internal Error" error-message-lines)
(exit))
;; bindings-as-html : bindings -> list (html-string)
;; -- formats name-value bindings as HTML appropriate for displaying
(define (bindings-as-html bindings)
;; bindings-as-html : bindings -> list (html-string)
;; -- formats name-value bindings as HTML appropriate for displaying
(define (bindings-as-html bindings)
`("<code>"
,@(map (lambda (bind)
(string-append (symbol->string (car bind))
@ -169,12 +165,12 @@
bindings)
"</code>"))
;; extract-bindings : (string + symbol) x bindings -> list (string)
;; -- Extracts the bindings associated with a given name. The semantics of
;; forms states that a CHECKBOX may use the same NAME field multiple times.
;; Hence, a list of strings is returned. Note that the result may be the
;; empty list.
(define (extract-bindings field-name bindings)
;; extract-bindings : (string + symbol) x bindings -> list (string)
;; -- Extracts the bindings associated with a given name. The semantics of
;; forms states that a CHECKBOX may use the same NAME field multiple times.
;; Hence, a list of strings is returned. Note that the result may be the
;; empty list.
(define (extract-bindings field-name bindings)
(let ([field-name (if (symbol? field-name)
field-name (string->symbol field-name))])
(let loop ([found null] [bindings bindings])
@ -184,9 +180,9 @@
(loop (cons (cdar bindings) found) (cdr bindings))
(loop found (cdr bindings)))))))
;; extract-binding/single : (string + symbol) x bindings -> string
;; -- used in cases where only one binding is supposed to occur
(define (extract-binding/single field-name bindings)
;; extract-binding/single : (string + symbol) x bindings -> string
;; -- used in cases where only one binding is supposed to occur
(define (extract-binding/single field-name bindings)
(let* ([field-name (if (symbol? field-name)
field-name (string->symbol field-name))]
[result (extract-bindings field-name bindings)])
@ -203,12 +199,12 @@
field-name)
(bindings-as-html bindings)))])))
;; get-cgi-method : () -> string
;; -- string is either GET or POST (though future extension is possible)
(define (get-cgi-method)
;; get-cgi-method : () -> string
;; -- string is either GET or POST (though future extension is possible)
(define (get-cgi-method)
(or (getenv "REQUEST_METHOD")
(error 'get-cgi-method "no REQUEST_METHOD environment variable")))
;; generate-link-text : string x html-string -> html-string
(define (generate-link-text url anchor-text)
;; generate-link-text : string x html-string -> html-string
(define (generate-link-text url anchor-text)
(string-append "<a href=\"" url "\">" anchor-text "</a>"))

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

@ -50,38 +50,35 @@
#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^)
(import)
(export cookie^)
(define-struct cookie (name value comment domain max-age path secure version) #:mutable)
(define-struct (cookie-error exn:fail) ())
(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
;; constructs a cookie-error struct from the given error message
;; (added to fix exceptions-must-take-immutable-strings bug)
(define (error* fmt . args)
;; error* : string args ... -> raises a cookie-error exception
;; constructs a cookie-error struct from the given error message
;; (added to fix exceptions-must-take-immutable-strings bug)
(define (error* fmt . args)
(raise (make-cookie-error (apply format fmt args)
(current-continuation-marks))))
;; The syntax for the Set-Cookie response header is
;; set-cookie = "Set-Cookie:" cookies
;; cookies = 1#cookie
;; cookie = NAME "=" VALUE *(";" cookie-av)
;; NAME = attr
;; VALUE = value
;; cookie-av = "Comment" "=" value
;; | "Domain" "=" value
;; | "Max-Age" "=" value
;; | "Path" "=" value
;; | "Secure"
;; | "Version" "=" 1*DIGIT
(define (set-cookie name pre-value)
;; The syntax for the Set-Cookie response header is
;; set-cookie = "Set-Cookie:" cookies
;; cookies = 1#cookie
;; cookie = NAME "=" VALUE *(";" cookie-av)
;; NAME = attr
;; VALUE = value
;; cookie-av = "Comment" "=" value
;; | "Domain" "=" value
;; | "Max-Age" "=" value
;; | "Path" "=" value
;; | "Secure"
;; | "Version" "=" 1*DIGIT
(define (set-cookie name pre-value)
(let ([value (to-rfc2109:value pre-value)])
(unless (rfc2068:token? name)
(error* "invalid cookie name: ~a / ~a" name value))
@ -94,36 +91,36 @@
#f ; default version
)))
;;!
;;
;; (function (print-cookie cookie))
;;
;; (param cookie Cookie-structure "The cookie to return as a string")
;;
;; 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))
;;!
;;
;; (function (print-cookie cookie))
;;
;; (param cookie Cookie-structure "The cookie to return as a string")
;;
;; 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)
(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)
(define (cookie:add-comment cookie pre-comment)
(let ([comment (to-rfc2109:value pre-comment)])
(unless (cookie? cookie)
(error* "cookie expected, received: ~a" cookie))
(set-cookie-comment! cookie comment)
cookie))
(define (cookie:add-domain cookie domain)
(define (cookie:add-domain cookie domain)
(unless (valid-domain? domain)
(error* "invalid domain: ~a" domain))
(unless (cookie? cookie)
@ -131,7 +128,7 @@
(set-cookie-domain! cookie domain)
cookie)
(define (cookie:add-max-age cookie seconds)
(define (cookie:add-max-age cookie seconds)
(unless (and (integer? seconds) (not (negative? seconds)))
(error* "invalid Max-Age for cookie: ~a" seconds))
(unless (cookie? cookie)
@ -139,14 +136,14 @@
(set-cookie-max-age! cookie seconds)
cookie)
(define (cookie:add-path cookie pre-path)
(define (cookie:add-path cookie pre-path)
(let ([path (to-rfc2109:value pre-path)])
(unless (cookie? cookie)
(error* "cookie expected, received: ~a" cookie))
(set-cookie-path! cookie path)
cookie))
(define (cookie:secure cookie secure?)
(define (cookie:secure cookie secure?)
(unless (boolean? secure?)
(error* "invalid argument (boolean expected), received: ~a" secure?))
(unless (cookie? cookie)
@ -154,7 +151,7 @@
(set-cookie-secure! cookie secure?)
cookie)
(define (cookie:version cookie version)
(define (cookie:version cookie version)
(unless (integer? version)
(error* "unsupported version: ~a" version))
(unless (cookie? cookie)
@ -163,21 +160,21 @@
cookie)
;; Parsing the Cookie header:
;; Parsing the Cookie header:
(define char-set:all-but=
(define char-set:all-but=
(char-set-difference char-set:full (string->char-set "=")))
(define char-set:all-but-semicolon
(define char-set:all-but-semicolon
(char-set-difference char-set:full (string->char-set ";")))
;;!
;;
;; (function (get-all-results name cookies))
;;
;; Auxiliar procedure that returns all values associated with
;; `name' in the association list (cookies).
(define (get-all-results name cookies)
;;!
;;
;; (function (get-all-results name cookies))
;;
;; Auxiliar procedure that returns all values associated with
;; `name' in the association list (cookies).
(define (get-all-results name cookies)
(let loop ([c cookies])
(if (null? c)
'()
@ -187,94 +184,93 @@
(cons (cadr pair) (loop (cdr c)))
(loop (cdr c)))))))
;; which typically looks like:
;; (cookie . "test5=\"5\"; test1=\"1\"; test0=\"0\"; test1=\"20\"")
;; note that it can be multi-valued: `test1' has values: "1", and "20". Of
;; course, in the same spirit, we only receive the "string content".
(define (get-cookie name cookies)
;; which typically looks like:
;; (cookie . "test5=\"5\"; test1=\"1\"; test0=\"0\"; test1=\"20\"")
;; note that it can be multi-valued: `test1' has values: "1", and "20". Of
;; course, in the same spirit, we only receive the "string content".
(define (get-cookie name cookies)
(let ([cookies (map (lambda (p)
(map string-trim-both
(string-tokenize p char-set:all-but=)))
(string-tokenize cookies char-set:all-but-semicolon))])
(get-all-results name cookies)))
;;!
;;
;; (function (get-cookie/single name cookies))
;;
;; (param name String "The name of the cookie we are looking for")
;; (param cookies String "The string (from the environment) with the content of the cookie header.")
;;
;; Returns the first name associated with the cookie named `name', if any, or #f.
(define (get-cookie/single name cookies)
;;!
;;
;; (function (get-cookie/single name cookies))
;;
;; (param name String "The name of the cookie we are looking for")
;; (param cookies String "The string (from the environment) with the content of the cookie header.")
;;
;; Returns the first name associated with the cookie named `name', if any, or #f.
(define (get-cookie/single name cookies)
(let ([cookies (get-cookie name cookies)])
(and (not (null? cookies)) (car cookies))))
;;;;;
;; Auxiliary procedures
;;;;;
;;;;;
;; Auxiliary procedures
;;;;;
;; token = 1*<any CHAR except CTLs or tspecials>
;;
;; tspecials = "(" | ")" | "<" | ">" | "@"
;; | "," | ";" | ":" | "\" | <">
;; | "/" | "[" | "]" | "?" | "="
;; | "{" | "}" | SP | HT
(define char-set:tspecials
;; token = 1*<any CHAR except CTLs or tspecials>
;;
;; tspecials = "(" | ")" | "<" | ">" | "@"
;; | "," | ";" | ":" | "\" | <">
;; | "/" | "[" | "]" | "?" | "="
;; | "{" | "}" | SP | HT
(define char-set:tspecials
(char-set-union (string->char-set "()<>@,;:\\\"/[]?={}")
char-set:whitespace
(char-set #\tab)))
(define char-set:control
(define char-set:control
(char-set-union char-set:iso-control
(char-set (integer->char 127))));; DEL
(define char-set:token
(define char-set:token
(char-set-difference char-set:ascii char-set:tspecials char-set:control))
;; token? : string -> boolean
;;
;; returns #t if s is an RFC 2068 token (see definition above), #f otherwise.
(define (rfc2068:token? s)
;; token? : string -> boolean
;;
;; returns #t if s is an RFC 2068 token (see definition above), #f otherwise.
(define (rfc2068:token? s)
(string-every char-set:token s))
;;!
;;
;; (function (quoted-string? s))
;;
;; (param s String "The string to check")
;;
;; Returns s if the string is an RFC 2068 quoted-string, #f otherwise. As in:
;; quoted-string = ( <"> *(qdtext) <"> )
;; qdtext = <any TEXT except <">>
;;
;; The backslash character ("\") may be used as a single-character quoting
;; mechanism only within quoted-string and comment constructs.
;;
;; quoted-pair = "\" CHAR
;;
;; implementation note: I have chosen to use a regular expression rather than
;; 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
;;!
;;
;; (function (quoted-string? s))
;;
;; (param s String "The string to check")
;;
;; Returns s if the string is an RFC 2068 quoted-string, #f otherwise. As in:
;; quoted-string = ( <"> *(qdtext) <"> )
;; qdtext = <any TEXT except <">>
;;
;; The backslash character ("\") may be used as a single-character quoting
;; mechanism only within quoted-string and comment constructs.
;;
;; quoted-pair = "\" CHAR
;;
;; implementation note: I have chosen to use a regular expression rather than
;; 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)
(and (regexp-match?
#rx"^\"([^\"#\u0000-#\u001F]| |#\return#\newline|#\tab|\\\\\")*\"$"
s)
s
#f))
s))
;; value: token | quoted-string
(define (rfc2109:value? s)
;; value: token | quoted-string
(define (rfc2109:value? s)
(or (rfc2068:token? s) (rfc2068:quoted-string? s)))
;; convert-to-quoted : string -> quoted-string?
;; takes the given string as a particular message, and converts the given
;; string to that representatation
(define (convert-to-quoted str)
;; convert-to-quoted : string -> quoted-string?
;; takes the given string as a particular message, and converts the given
;; string to that representatation
(define (convert-to-quoted str)
(string-append "\"" (regexp-replace* #rx"\"" str "\\\\\"") "\""))
;; string -> rfc2109:value?
(define (to-rfc2109:value s)
;; string -> rfc2109:value?
(define (to-rfc2109:value s)
(cond
[(not (string? s))
(error* "expected string, given: ~e" s)]
@ -290,39 +286,38 @@
[else
(error* "could not convert the given string to an acceptable RFC 2109 value: ~s" s)]))
;;!
;;
;; (function (cookie-string? s))
;;
;; (param s String "String to check")
;;
;; 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))
;;!
;;
;; (function (cookie-string? s))
;;
;; (param s String "String to check")
;;
;; 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? 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
;; Host names as per RFC 1123 and RFC952, more or less, anyway. :-)
(define char-set:hostname
(let ([a-z-lowercase (ucs-range->char-set #x61 #x7B)]
[a-z-uppercase (ucs-range->char-set #x41 #x5B)])
(char-set-adjoin!
(char-set-union char-set:digit a-z-lowercase a-z-uppercase)
#\.)))
(define (valid-domain? dom)
(define (valid-domain? dom)
(and ;; Domain must start with a dot (.)
(string=? (string-take dom 1) ".")
;; The rest are tokens-like strings separated by dots
(string-every char-set:hostname dom)
(<= (string-length dom) 76)))
(define (valid-path? v)
(define (valid-path? v)
(and (string? v) (rfc2109:value? v)))
;;; cookie-unit.ss ends here

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

@ -1,15 +1,14 @@
#lang scheme/unit
(require mzlib/list mzlib/process "dns-sig.ss"
scheme/udp)
(require "dns-sig.ss" scheme/system scheme/udp)
(import)
(export dns^)
(import)
(export dns^)
;; UDP retry timeout:
(define INIT-TIMEOUT 50)
;; UDP retry timeout:
(define INIT-TIMEOUT 50)
(define types
(define types
'((a 1)
(ns 2)
(md 3)
@ -27,40 +26,39 @@
(mx 15)
(txt 16)))
(define classes
(define classes
'((in 1)
(cs 2)
(ch 3)
(hs 4)))
(define (cossa i l)
(define (cossa i l)
(cond [(null? l) #f]
[(equal? (cadar l) i) (car l)]
[else (cossa i (cdr l))]))
(define (number->octet-pair n)
(define (number->octet-pair n)
(list (arithmetic-shift n -8)
(modulo n 256)))
(define (octet-pair->number a b)
(define (octet-pair->number a b)
(+ (arithmetic-shift a 8) b))
(define (octet-quad->number a b c d)
(define (octet-quad->number a b c d)
(+ (arithmetic-shift a 24)
(arithmetic-shift b 16)
(arithmetic-shift c 8)
d))
(define (name->octets s)
(let ([do-one (lambda (s)
(cons (bytes-length s) (bytes->list s)))])
(define (name->octets 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
(append (do-one (cadr m)) (loop (caddr m)))
(append (do-one s) (list 0)))))))
(define (make-std-query-header id question-count)
(define (make-std-query-header id question-count)
(append (number->octet-pair id)
(list 1 0) ; Opcode & flags (recusive flag set)
(number->octet-pair question-count)
@ -68,25 +66,25 @@
(number->octet-pair 0)
(number->octet-pair 0)))
(define (make-query id name type class)
(define (make-query id name type class)
(append (make-std-query-header id 1)
(name->octets name)
(number->octet-pair (cadr (assoc type types)))
(number->octet-pair (cadr (assoc class classes)))))
(define (add-size-tag m)
(define (add-size-tag m)
(append (number->octet-pair (length m)) m))
(define (rr-data rr)
(define (rr-data rr)
(cadddr (cdr rr)))
(define (rr-type rr)
(define (rr-type rr)
(cadr rr))
(define (rr-name rr)
(define (rr-name rr)
(car rr))
(define (parse-name start reply)
(define (parse-name start reply)
(let ([v (car start)])
(cond
[(zero? v)
@ -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)
@ -110,7 +107,7 @@
(parse-name (list-tail reply offset) reply)])
(values s (cddr start))))])))
(define (parse-rr start reply)
(define (parse-rr start reply)
(let-values ([(name start) (parse-name start reply)])
(let* ([type (car (cossa (octet-pair->number (car start) (cadr start))
types))]
@ -133,7 +130,7 @@
start)
(loop (sub1 len) (cdr start) (cons (car start) accum)))))))
(define (parse-ques start reply)
(define (parse-ques start reply)
(let-values ([(name start) (parse-name start reply)])
(let* ([type (car (cossa (octet-pair->number (car start) (cadr start))
types))]
@ -144,14 +141,14 @@
[start (cddr start)])
(values (list name type class) start))))
(define (parse-n parse start reply n)
(define (parse-n parse start reply n)
(let loop ([n n][start start][accum null])
(if (zero? n)
(values (reverse accum) start)
(let-values ([(rr start) (parse start reply)])
(loop (sub1 n) start (cons rr accum))))))
(define (dns-query nameserver addr type class)
(define (dns-query nameserver addr type class)
(unless (assoc type types)
(raise-type-error 'dns-query "DNS query type" type))
(unless (assoc class classes)
@ -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))))))))
@ -211,21 +206,22 @@
(values (positive? (bitwise-and #x4 v0))
qds ans nss ars reply)))))))
(define cache (make-hasheq))
(define (dns-query/cache nameserver addr type class)
(define cache (make-hasheq))
(define (dns-query/cache nameserver addr type class)
(let ([key (string->symbol (format "~a;~a;~a;~a" nameserver addr type class))])
(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))))))
(define (ip->string s)
(define (ip->string s)
(format "~a.~a.~a.~a"
(list-ref s 0) (list-ref s 1) (list-ref s 2) (list-ref s 3)))
(define (try-forwarding k nameserver)
(define (try-forwarding k nameserver)
(let loop ([nameserver nameserver][tried (list nameserver)])
;; Normally the recusion is done for us, but it's technically optional
(let-values ([(v ars auth?) (k nameserver)])
@ -239,7 +235,7 @@
(not (member ns tried))
(loop ns (cons ns tried)))))))))
(define (ip->in-addr.arpa ip)
(define (ip->in-addr.arpa ip)
(let ([result (regexp-match #rx"^([0-9]+)\\.([0-9]+)\\.([0-9]+)\\.([0-9]+)$"
ip)])
(format "~a.~a.~a.~a.in-addr.arpa"
@ -248,11 +244,10 @@
(list-ref result 2)
(list-ref result 1))))
(define (get-ptr-list-from-ans ans)
(filter (lambda (ans-entry) (eq? (list-ref ans-entry 1) 'ptr))
ans))
(define (get-ptr-list-from-ans ans)
(filter (lambda (ans-entry) (eq? (list-ref ans-entry 1) 'ptr)) ans))
(define (dns-get-name nameserver ip)
(define (dns-get-name nameserver ip)
(or (try-forwarding
(lambda (nameserver)
(let-values ([(auth? qds ans nss ars reply)
@ -265,11 +260,11 @@
nameserver)
(error 'dns-get-name "bad ip address")))
(define (get-a-list-from-ans ans)
(define (get-a-list-from-ans ans)
(filter (lambda (ans-entry) (eq? (list-ref ans-entry 1) 'a))
ans))
(define (dns-get-address nameserver addr)
(define (dns-get-address nameserver addr)
(or (try-forwarding
(lambda (nameserver)
(let-values ([(auth? qds ans nss ars reply) (dns-query/cache nameserver addr 'a 'in)])
@ -280,7 +275,7 @@
nameserver)
(error 'dns-get-address "bad address")))
(define (dns-get-mail-exchanger nameserver addr)
(define (dns-get-mail-exchanger nameserver addr)
(or (try-forwarding
(lambda (nameserver)
(let-values ([(auth? qds ans nss ars reply) (dns-query/cache nameserver addr 'mx 'in)])
@ -303,7 +298,7 @@
nameserver)
(error 'dns-get-mail-exchanger "bad address")))
(define (dns-find-nameserver)
(define (dns-find-nameserver)
(case (system-type)
[(unix macosx)
(with-handlers ([void (lambda (x) #f)])
@ -327,19 +322,17 @@
(process/ports
#f (open-input-file "NUL") (current-error-port)
nslookup))])
(let loop ([name #f][ip #f][try-ip? #f])
(let loop ([name #f] [ip #f] [try-ip? #f])
(let ([line (read-line pin 'any)])
(cond [(eof-object? line)
(close-input-port pin)
(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]))

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

@ -1,30 +1,30 @@
#lang scheme/unit
(require mzlib/date mzlib/string "head-sig.ss")
(require mzlib/date mzlib/string "head-sig.ss")
(import)
(export head^)
(import)
(export head^)
;; NB: I've done a copied-code adaptation of a number of these definitions
;; into "bytes-compatible" versions. Finishing the rest will require some
;; kind of interface decision---that is, when you don't supply a header,
;; should the resulting operation be string-centric or bytes-centric?
;; Easiest just to stop here.
;; -- JBC 2006-07-31
;; NB: I've done a copied-code adaptation of a number of these definitions
;; into "bytes-compatible" versions. Finishing the rest will require some
;; kind of interface decision---that is, when you don't supply a header,
;; should the resulting operation be string-centric or bytes-centric?
;; Easiest just to stop here.
;; -- JBC 2006-07-31
(define CRLF (string #\return #\newline))
(define CRLF/bytes #"\r\n")
(define CRLF (string #\return #\newline))
(define CRLF/bytes #"\r\n")
(define empty-header CRLF)
(define empty-header/bytes CRLF/bytes)
(define empty-header CRLF)
(define empty-header/bytes CRLF/bytes)
(define re:field-start (regexp "^[^ \t\n\r\v:\001-\032\"]*:"))
(define re:field-start/bytes #rx#"^[^ \t\n\r\v:\001-\032\"]*:")
(define re:field-start (regexp "^[^ \t\n\r\v:\001-\032\"]*:"))
(define re:field-start/bytes #rx#"^[^ \t\n\r\v:\001-\032\"]*:")
(define re:continue (regexp "^[ \t\v]"))
(define re:continue/bytes #rx#"^[ \t\v]")
(define re:continue (regexp "^[ \t\v]"))
(define re:continue/bytes #rx#"^[ \t\v]")
(define (validate-header s)
(define (validate-header s)
(if (bytes? s)
;; legal char check not needed per rfc 2822, IIUC.
(let ([len (bytes-length s)])
@ -63,13 +63,13 @@
[else (error 'validate-header "ill-formed header at ~s"
(substring s offset (string-length s)))]))))))
(define (make-field-start-regexp field)
(define (make-field-start-regexp field)
(regexp (format "(^|[\r][\n])(~a: *)" (regexp-quote field #f))))
(define (make-field-start-regexp/bytes field)
(define (make-field-start-regexp/bytes field)
(byte-regexp (bytes-append #"(^|[\r][\n])("(regexp-quote field #f) #": *)")))
(define (extract-field field header)
(define (extract-field field header)
(if (bytes? header)
(let ([m (regexp-match-positions (make-field-start-regexp/bytes field)
header)])
@ -95,8 +95,7 @@
;; Rest of header is this field, but strip trailing CRLFCRLF:
(regexp-replace #rx"\r\n\r\n$" s ""))))))))
(define (replace-field field data header)
(define (replace-field field data header)
(if (bytes? header)
(let ([m (regexp-match-positions (make-field-start-regexp/bytes field)
header)])
@ -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))]
@ -118,10 +116,10 @@
(string-append pre (if data (insert-field field data rest) rest)))
(if data (insert-field field data header) header)))))
(define (remove-field field header)
(define (remove-field field header)
(replace-field field #f header))
(define (insert-field field data header)
(define (insert-field field data header)
(if (bytes? header)
(let ([field (bytes-append field #": "data #"\r\n")])
(bytes-append field header))
@ -129,7 +127,7 @@
(let ([field (format "~a: ~a\r\n" field data)])
(string-append field header))))
(define (append-headers a b)
(define (append-headers a b)
(if (bytes? a)
(let ([alen (bytes-length a)])
(if (> alen 1)
@ -141,7 +139,7 @@
(string-append (substring a 0 (- alen 2)) b)
(error 'append-headers "first argument is not a header: ~a" a)))))
(define (extract-all-fields header)
(define (extract-all-fields header)
(if (bytes? header)
(let ([re #rx#"(^|[\r][\n])(([^\r\n:\"]*): *)"])
(let loop ([start 0])
@ -188,11 +186,11 @@
;; malformed header:
null))))))
;; It's slightly less obvious how to generalize the functions that don't
;; accept a header as input; for lack of an obvious solution (and free time),
;; I'm stopping the string->bytes translation here. -- JBC, 2006-07-31
;; It's slightly less obvious how to generalize the functions that don't
;; accept a header as input; for lack of an obvious solution (and free time),
;; I'm stopping the string->bytes translation here. -- JBC, 2006-07-31
(define (standard-message-header from tos ccs bccs subject)
(define (standard-message-header from tos ccs bccs subject)
(let ([h (insert-field
"Subject" subject
(insert-field
@ -208,7 +206,7 @@
(insert-field "To" (assemble-address-field tos) h))])
(insert-field "From" from h)))))
(define (splice l sep)
(define (splice l sep)
(if (null? l)
""
(format "~a~a"
@ -217,20 +215,20 @@
(map (lambda (n) (format "~a~a" sep n))
(cdr l))))))
(define (data-lines->data datas)
(define (data-lines->data datas)
(splice datas "\r\n\t"))
;; Extracting Addresses ;;
;; Extracting Addresses ;;
(define blank "[ \t\n\r\v]")
(define nonblank "[^ \t\n\r\v]")
(define re:all-blank (regexp (format "^~a*$" blank)))
(define re:quoted (regexp "\"[^\"]*\""))
(define re:parened (regexp "[(][^)]*[)]"))
(define re:comma (regexp ","))
(define re:comma-separated (regexp "([^,]*),(.*)"))
(define blank "[ \t\n\r\v]")
(define nonblank "[^ \t\n\r\v]")
(define re:all-blank (regexp (format "^~a*$" blank)))
(define re:quoted (regexp "\"[^\"]*\""))
(define re:parened (regexp "[(][^)]*[)]"))
(define re:comma (regexp ","))
(define re:comma-separated (regexp "([^,]*),(.*)"))
(define (extract-addresses s form)
(define (extract-addresses s form)
(unless (memq form '(name address full all))
(raise-type-error 'extract-addresses
"form: 'name, 'address, 'full, or 'all"
@ -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)))
@ -262,27 +258,27 @@
(let ([n (extract-one-name (string-append prefix s) form)])
(list n)))))))))
(define (select-result form name addr full)
(define (select-result form name addr full)
(case form
[(name) name]
[(address) addr]
[(full) full]
[(all) (list name addr full)]))
(define (one-result form s)
(define (one-result form s)
(select-result form s s s))
(define re:quoted-name (regexp (format "^~a*(\"[^\"]*\")(.*)" blank)))
(define re:parened-name (regexp (format "(.*)[(]([^)]*)[)]~a*$" blank)))
(define re:simple-name (regexp (format "^~a*(~a.*)(<.*>)~a*$" blank nonblank blank)))
(define re:normal-name (regexp (format "~a*<([^>]*)>~a*" blank blank)))
(define re:double-less (regexp "<.*<"))
(define re:double-greater (regexp ">.*>"))
(define re:bad-chars (regexp "[,\"()<>]"))
(define re:tail-blanks (regexp (format "~a+$" blank)))
(define re:head-blanks (regexp (format "^~a+" blank)))
(define re:quoted-name (regexp (format "^~a*(\"[^\"]*\")(.*)" blank)))
(define re:parened-name (regexp (format "(.*)[(]([^)]*)[)]~a*$" blank)))
(define re:simple-name (regexp (format "^~a*(~a.*)(<.*>)~a*$" blank nonblank blank)))
(define re:normal-name (regexp (format "~a*<([^>]*)>~a*" blank blank)))
(define re:double-less (regexp "<.*<"))
(define re:double-greater (regexp ">.*>"))
(define re:bad-chars (regexp "[,\"()<>]"))
(define re:tail-blanks (regexp (format "~a+$" blank)))
(define re:head-blanks (regexp (format "^~a+" blank)))
(define (extract-one-name orig form)
(define (extract-one-name orig form)
(let loop ([s orig][form form])
(cond
;; ?!?!? Where does the "addr (name)" standard come from ?!?!?
@ -311,7 +307,7 @@
(one-result form (extract-angle-addr s orig))]
[else (one-result form (extract-simple-addr s orig))])))
(define (extract-angle-addr s orig)
(define (extract-angle-addr s orig)
(if (or (regexp-match re:double-less s) (regexp-match re:double-greater s))
(error 'extract-address "too many angle brackets: ~a" s)
(let ([m (regexp-match re:normal-name s)])
@ -319,7 +315,7 @@
(extract-simple-addr (cadr m) orig)
(error 'extract-address "cannot parse address: ~a" orig)))))
(define (extract-simple-addr s orig)
(define (extract-simple-addr s orig)
(cond [(regexp-match re:bad-chars s)
(error 'extract-address "cannot parse address: ~a" orig)]
[else
@ -328,7 +324,7 @@
(regexp-replace re:head-blanks s "")
"")]))
(define (assemble-address-field addresses)
(define (assemble-address-field addresses)
(if (null? addresses)
""
(let loop ([addresses (cdr addresses)]

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

@ -1,30 +1,30 @@
#lang scheme/unit
(require scheme/tcp
(require scheme/tcp
"imap-sig.ss"
"private/rbtree.ss")
(import)
(export imap^)
(import)
(export imap^)
(define debug-via-stdio? #f)
(define debug-via-stdio? #f)
(define eol (if debug-via-stdio? 'linefeed 'return-linefeed))
(define eol (if debug-via-stdio? 'linefeed 'return-linefeed))
(define (tag-eq? a b)
(define (tag-eq? a b)
(or (eq? a b)
(and (symbol? a)
(symbol? b)
(string-ci=? (symbol->string a) (symbol->string b)))))
(define field-names
(define field-names
(list (list 'uid (string->symbol "UID"))
(list 'header (string->symbol "RFC822.HEADER"))
(list 'body (string->symbol "RFC822.TEXT"))
(list 'size (string->symbol "RFC822.SIZE"))
(list 'flags (string->symbol "FLAGS"))))
(define flag-names
(define flag-names
(list (list 'seen (string->symbol "\\Seen"))
(list 'answered (string->symbol "\\Answered"))
(list 'flagged (string->symbol "\\Flagged"))
@ -40,32 +40,32 @@
(list 'hasnochildren (string->symbol "\\HasNoChildren"))
(list 'haschildren (string->symbol "\\HasChildren"))))
(define (imap-flag->symbol f)
(define (imap-flag->symbol f)
(or (ormap (lambda (a) (and (tag-eq? f (cadr a)) (car a))) flag-names)
f))
(define (symbol->imap-flag s)
(define (symbol->imap-flag s)
(cond [(assoc s flag-names) => cadr] [else s]))
(define (log-warning . args)
(define (log-warning . args)
;; (apply printf args)
(void))
(define log log-warning)
(define log log-warning)
(define make-msg-id
(define make-msg-id
(let ([id 0])
(lambda ()
(begin0 (string->bytes/latin-1 (format "a~a " id))
(set! id (add1 id))))))
(define (starts-with? l n)
(define (starts-with? l n)
(and (>= (bytes-length l) (bytes-length n))
(bytes=? n (subbytes l 0 (bytes-length n)))))
(define (skip s n)
(define (skip s n)
(subbytes s (if (number? n) n (bytes-length n))))
(define (splice l sep)
(define (splice l sep)
(if (null? l)
""
(format "~a~a"
@ -73,7 +73,7 @@
(apply string-append
(map (lambda (n) (format "~a~a" sep n)) (cdr l))))))
(define (imap-read s r)
(define (imap-read s r)
(let loop ([s s]
[r r]
[accum null]
@ -127,7 +127,7 @@
eol-k eop-k)
(error 'imap-read "failure reading atom: ~a" s)))])])))
(define (get-response r id info-handler continuation-handler)
(define (get-response r id info-handler continuation-handler)
(let loop ()
(let ([l (read-bytes-line r eol)])
(log "raw-reply: ~s\n" l)
@ -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)
@ -151,13 +150,13 @@
(log-warning "warning: unexpected response for ~a: ~a\n" id l)
(when id (loop))]))))
;; A cmd is
;; * (box v) - send v literally via ~a
;; * string or bytes - protect as necessary
;; * (cons cmd null) - same as cmd
;; * (cons cmd cmd) - send cmd, space, cmd
;; A cmd is
;; * (box v) - send v literally via ~a
;; * string or bytes - protect as necessary
;; * (cons cmd null) - same as cmd
;; * (cons cmd cmd) - send cmd, space, cmd
(define (imap-send imap cmd info-handler . continuation-handler)
(define (imap-send imap cmd info-handler . continuation-handler)
(let ([r (imap-r imap)]
[w (imap-w imap)]
[id (make-msg-id)])
@ -190,23 +189,23 @@
(get-response r id (wrap-info-handler imap info-handler)
continuation-handler)))
(define (check-ok reply)
(define (check-ok reply)
(unless (and (pair? reply) (tag-eq? (car reply) 'OK))
(error 'check-ok "server error: ~s" reply)))
(define (ok-tag-eq? i t)
(define (ok-tag-eq? i t)
(and (tag-eq? (car i) 'OK)
((length i) . >= . 3)
(tag-eq? (cadr i) (string->symbol (format "[~a" t)))))
(define (ok-tag-val i)
(define (ok-tag-val i)
(let ([v (caddr i)])
(and (symbol? v)
(let ([v (symbol->string v)])
(regexp-match #rx"[]]$" v)
(string->number (substring v 0 (sub1 (string-length v))))))))
(define (wrap-info-handler imap info-handler)
(define (wrap-info-handler imap info-handler)
(lambda (i)
(when (and (list? i) ((length i) . >= . 2))
(cond
@ -253,12 +252,12 @@
(set-imap-uidvalidity! imap (ok-tag-val i))]))
(info-handler i)))
(define-struct imap (r w exists recent unseen uidnext uidvalidity
(define-struct imap (r w exists recent unseen uidnext uidvalidity
expunges fetches new?)
#:mutable)
(define (imap-connection? v) (imap? v))
(define (imap-connection? v) (imap? v))
(define imap-port-number
(define imap-port-number
(make-parameter 143
(lambda (v)
(unless (and (number? v)
@ -270,7 +269,7 @@
v))
v)))
(define (imap-connect* r w username password inbox)
(define (imap-connect* r w username password inbox)
(with-handlers ([void
(lambda (x)
(close-input-port r)
@ -288,7 +287,7 @@
(let-values ([(init-count init-recent) (imap-reselect imap inbox)])
(values imap init-count init-recent)))))
(define (imap-connect server username password inbox)
(define (imap-connect server username password inbox)
;; => imap count-k recent-k
(let-values ([(r w)
(if debug-via-stdio?
@ -298,17 +297,17 @@
(tcp-connect server (imap-port-number)))])
(imap-connect* r w username password inbox)))
(define (imap-reselect imap inbox)
(define (imap-reselect imap inbox)
(imap-selectish-command imap (list "SELECT" inbox) #t))
(define (imap-examine imap inbox)
(define (imap-examine imap inbox)
(imap-selectish-command imap (list "EXAMINE" inbox) #t))
;; Used to return (values #f #f) if no change since last check?
(define (imap-noop imap)
;; Used to return (values #f #f) if no change since last check?
(define (imap-noop imap)
(imap-selectish-command imap "NOOP" #f))
(define (imap-selectish-command imap cmd reset?)
(define (imap-selectish-command imap cmd reset?)
(let ([init-count #f]
[init-recent #f])
(check-ok (imap-send imap cmd void))
@ -318,7 +317,7 @@
(set-imap-new?! imap #f))
(values (imap-exists imap) (imap-recent imap))))
(define (imap-status imap inbox flags)
(define (imap-status imap inbox flags)
(unless (and (list? flags)
(andmap (lambda (s)
(memq s '(messages recent uidnext uidvalidity unseen)))
@ -338,7 +337,7 @@
[else (loop (cdr l))])))
flags)))
(define (imap-poll imap)
(define (imap-poll imap)
(when (and ;; Check for async messages from the server
(char-ready? (imap-r imap))
;; It has better start with "*"...
@ -347,47 +346,47 @@
(get-response (imap-r imap) #f (wrap-info-handler imap void) null)
(void)))
(define (imap-get-updates imap)
(define (imap-get-updates imap)
(no-expunges 'imap-updates imap)
(let ([l (fetch-tree->list (imap-fetches imap))])
(set-imap-fetches! imap (new-tree))
l))
(define (imap-pending-updates? imap)
(define (imap-pending-updates? imap)
(not (tree-empty? (imap-fetches imap))))
(define (imap-get-expunges imap)
(define (imap-get-expunges imap)
(let ([l (expunge-tree->list (imap-expunges imap))])
(set-imap-expunges! imap (new-tree))
l))
(define (imap-pending-expunges? imap)
(define (imap-pending-expunges? imap)
(not (tree-empty? (imap-expunges imap))))
(define (imap-reset-new! imap)
(define (imap-reset-new! imap)
(set-imap-new?! imap #f))
(define (imap-messages imap)
(define (imap-messages imap)
(imap-exists imap))
(define (imap-disconnect imap)
(define (imap-disconnect imap)
(let ([r (imap-r imap)]
[w (imap-w imap)])
(check-ok (imap-send imap "LOGOUT" void))
(close-input-port r)
(close-output-port w)))
(define (imap-force-disconnect imap)
(define (imap-force-disconnect imap)
(let ([r (imap-r imap)]
[w (imap-w imap)])
(close-input-port r)
(close-output-port w)))
(define (no-expunges who imap)
(define (no-expunges who imap)
(unless (tree-empty? (imap-expunges imap))
(raise-mismatch-error who "session has pending expunge reports: " imap)))
(define (msg-set msgs)
(define (msg-set msgs)
(apply
string-append
(let loop ([prev #f][msgs msgs])
@ -406,7 +405,7 @@
[else (cons (format "~a," (car msgs))
(loop #f (cdr msgs)))]))))
(define (imap-get-messages imap msgs field-list)
(define (imap-get-messages imap msgs field-list)
(no-expunges 'imap-get-messages imap)
(when (or (not (list? msgs))
(not (andmap integer? msgs)))
@ -452,7 +451,7 @@
(loop (cdr flds) (if a (remq a m) m))))]))))
msgs))))))
(define (imap-store imap mode msgs flags)
(define (imap-store imap mode msgs flags)
(no-expunges 'imap-store imap)
(check-ok
(imap-send imap
@ -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)
(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)
(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
@ -488,24 +484,23 @@
(fprintf (imap-w imap) "~a\r\n" msg)
(loop))))))
(define (imap-expunge imap)
(define (imap-expunge imap)
(check-ok (imap-send imap "EXPUNGE" void)))
(define (imap-mailbox-exists? imap mailbox)
(define (imap-mailbox-exists? imap mailbox)
(let ([exists? #f])
(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?))
(define (imap-create-mailbox imap mailbox)
(define (imap-create-mailbox imap mailbox)
(check-ok (imap-send imap (list "CREATE" mailbox) void)))
(define (imap-get-hierarchy-delimiter imap)
(let* ([result #f])
(define (imap-get-hierarchy-delimiter imap)
(let ([result #f])
(check-ok
(imap-send imap (list "LIST" "" "")
(lambda (i)
@ -513,7 +508,7 @@
(set! result (caddr i))))))
result))
(define imap-list-child-mailboxes
(define imap-list-child-mailboxes
(case-lambda
[(imap mailbox)
(imap-list-child-mailboxes imap mailbox #f)]
@ -534,7 +529,7 @@
(cadr p)])))
(imap-list-mailboxes imap pattern mailbox-name)))]))
(define (imap-mailbox-flags imap mailbox)
(define (imap-mailbox-flags imap mailbox)
(let ([r (imap-list-mailboxes imap mailbox #f)])
(if (= (length r) 1)
(caar r)
@ -542,7 +537,7 @@
mailbox
(if (null? r) "no matches" "multiple matches")))))
(define (imap-list-mailboxes imap pattern except)
(define (imap-list-mailboxes imap pattern except)
(let* ([sub-folders null])
(check-ok
(imap-send imap (list "LIST" "" pattern)

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

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

@ -29,27 +29,25 @@
#lang scheme/unit
(require "mime-sig.ss"
(require "mime-sig.ss"
"qp-sig.ss"
"base64-sig.ss"
"head-sig.ss"
"mime-util.ss"
mzlib/etc
mzlib/string
mzlib/port)
scheme/port)
(import base64^ qp^ head^)
(export mime^)
(import base64^ qp^ head^)
(export mime^)
;; Constants:
(define discrete-alist
;; Constants:
(define discrete-alist
'(("text" . text)
("image" . image)
("audio" . audio)
("video" . video)
("application" . application)))
(define disposition-alist
(define disposition-alist
'(("inline" . inline)
("attachment" . attachment)
("file" . attachment) ;; This is used (don't know why) by
@ -57,19 +55,19 @@
("messagetext" . inline)
("form-data" . form-data)))
(define composite-alist
(define composite-alist
'(("message" . message)
("multipart" . multipart)))
(define mechanism-alist
(define mechanism-alist
'(("7bit" . 7bit)
("8bit" . 8bit)
("binary" . binary)
("quoted-printable" . quoted-printable)
("base64" . base64)))
(define ietf-extensions '())
(define iana-extensions
(define ietf-extensions '())
(define iana-extensions
'(;; text
("plain" . plain)
("html" . html)
@ -120,37 +118,37 @@
("mpeg" . mpeg)
("quicktime" . quicktime)))
;; Basic structures
(define-struct message (version entity fields)
;; Basic structures
(define-struct message (version entity fields)
#:mutable)
(define-struct entity
(define-struct entity
(type subtype charset encoding disposition params id description other
fields parts body)
#:mutable)
(define-struct disposition
(define-struct disposition
(type filename creation modification read size params)
#:mutable)
;; Exceptions
(define-struct mime-error ())
(define-struct (unexpected-termination mime-error) (msg))
(define-struct (missing-multipart-boundary-parameter mime-error) ())
(define-struct (malformed-multipart-entity mime-error) (msg))
(define-struct (empty-mechanism mime-error) ())
(define-struct (empty-type mime-error) ())
(define-struct (empty-subtype mime-error) ())
(define-struct (empty-disposition-type mime-error) ())
;; Exceptions
(define-struct mime-error ())
(define-struct (unexpected-termination mime-error) (msg))
(define-struct (missing-multipart-boundary-parameter mime-error) ())
(define-struct (malformed-multipart-entity mime-error) (msg))
(define-struct (empty-mechanism mime-error) ())
(define-struct (empty-type mime-error) ())
(define-struct (empty-subtype mime-error) ())
(define-struct (empty-disposition-type mime-error) ())
;; *************************************
;; Practical stuff, aka MIME in action:
;; *************************************
(define CRLF (format "~a~a" #\return #\newline))
(define CRLF-binary "=0D=0A") ;; quoted printable representation
;; *************************************
;; Practical stuff, aka MIME in action:
;; *************************************
(define CRLF (format "~a~a" #\return #\newline))
(define CRLF-binary "=0D=0A") ;; quoted printable representation
;; get-headers : input-port -> string
;; returns the header part of a message/part conforming to rfc822, and
;; rfc2045.
(define (get-headers in)
;; get-headers : input-port -> string
;; returns the header part of a message/part conforming to rfc822, and
;; rfc2045.
(define (get-headers in)
(let loop ([headers ""] [ln (read-line in 'any)])
(cond [(eof-object? ln)
;; (raise (make-unexpected-termination "eof reached! while parsing headers"))
@ -168,7 +166,7 @@
(loop (string-append headers ln CRLF)
(read-line in 'any))])))
(define (make-default-disposition)
(define (make-default-disposition)
(make-disposition
'inline ;; type
"" ;; filename
@ -179,7 +177,7 @@
null ;; params
))
(define (make-default-entity)
(define (make-default-entity)
(make-entity
'text ;; type
'plain ;; subtype
@ -195,10 +193,10 @@
null ;; body
))
(define (make-default-message)
(define (make-default-message)
(make-message 1.0 (make-default-entity) null))
(define (mime-decode entity input)
(define (mime-decode entity input)
(set-entity-body!
entity
(case (entity-encoding entity)
@ -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,24 +239,24 @@
;; Unrecognized type, you're on your own! (sorry)
(mime-decode entity iport)])
;; return mime structure
msg)))
msg))
(define (entity-boundary entity)
(define (entity-boundary entity)
(let* ([params (entity-params entity)]
[ans (assoc "boundary" params)])
(and ans (cdr ans))))
;; *************************************************
;; MIME Specific: rfc2045-2049, and rfc0822, rfc2183
;; *************************************************
;; *************************************************
;; MIME Specific: rfc2045-2049, and rfc0822, rfc2183
;; *************************************************
;;multipart-body := [preamble CRLF]
;; dash-boundary transport-padding CRLF
;; body-part *encapsulation
;; close-delimiter transport-padding
;; [CRLF epilogue]
;; Returns a list of input ports, each one containing the correspongind part.
(define (multipart-body input boundary)
;;multipart-body := [preamble CRLF]
;; dash-boundary transport-padding CRLF
;; body-part *encapsulation
;; close-delimiter transport-padding
;; [CRLF epilogue]
;; Returns a list of input ports, each one containing the correspongind part.
(define (multipart-body input boundary)
(let* ([make-re (lambda (prefix)
(regexp (string-append prefix "--" (regexp-quote boundary) "(--)?\r\n")))]
[re (make-re "\r\n")])
@ -291,36 +288,36 @@
[eof? (list part)]
[else (cons part (loop))]))))))
;; MIME-message-headers := entity-headers
;; fields
;; version CRLF
;; ; The ordering of the header
;; ; fields implied by this BNF
;; ; definition should be ignored.
(define (MIME-message-headers headers)
;; MIME-message-headers := entity-headers
;; fields
;; version CRLF
;; ; The ordering of the header
;; ; fields implied by this BNF
;; ; definition should be ignored.
(define (MIME-message-headers headers)
(let ([message (make-default-message)])
(entity-headers headers message #t)
message))
;; MIME-part-headers := entity-headers
;; [ fields ]
;; ; Any field not beginning with
;; ; "content-" can have no defined
;; ; meaning and may be ignored.
;; ; The ordering of the header
;; ; fields implied by this BNF
;; ; definition should be ignored.
(define (MIME-part-headers headers)
;; MIME-part-headers := entity-headers
;; [ fields ]
;; ; Any field not beginning with
;; ; "content-" can have no defined
;; ; meaning and may be ignored.
;; ; The ordering of the header
;; ; fields implied by this BNF
;; ; definition should be ignored.
(define (MIME-part-headers headers)
(let ([message (make-default-message)])
(entity-headers headers message #f)
message))
;; entity-headers := [ content CRLF ]
;; [ encoding CRLF ]
;; [ id CRLF ]
;; [ description CRLF ]
;; *( MIME-extension-field CRLF )
(define (entity-headers headers message version?)
;; entity-headers := [ content CRLF ]
;; [ encoding CRLF ]
;; [ id CRLF ]
;; [ description CRLF ]
;; *( MIME-extension-field CRLF )
(define (entity-headers headers message version?)
(let ([entity (message-entity message)])
(let-values ([(mime non-mime) (get-fields headers)])
(let loop ([fields mime])
@ -343,7 +340,7 @@
;; Return message
message)))
(define (get-fields headers)
(define (get-fields headers)
(let ([mime null] [non-mime null])
(letrec ([store-field
(lambda (f)
@ -357,22 +354,21 @@
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)
(define (mime-header? h)
(or (regexp-match? re:content h)
(regexp-match? re:mime h)))
;;; Headers
;;; Content-type follows this BNF syntax:
;; content := "Content-Type" ":" type "/" subtype
;; *(";" parameter)
;; ; Matching of media type and subtype
;; ; is ALWAYS case-insensitive.
(define re:content-type
(regexp (format "^~a:([^/]+)/([^/]+)$" (regexp-quote "content-type" #f))))
(define (content header entity)
;;; Headers
;;; Content-type follows this BNF syntax:
;; content := "Content-Type" ":" type "/" subtype
;; *(";" parameter)
;; ; Matching of media type and subtype
;; ; is ALWAYS case-insensitive.
(define re:content-type #rx"^(?i:content-type):([^/]+)/([^/]+)$")
(define (content header entity)
(let* ([params (string-tokenizer #\; header)]
[one re:content-type]
[h (trim-all-spaces (car params))]
@ -394,20 +390,18 @@
(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...
(loop (cdr p) ans)]))])))))))
;; From rfc2183 Content-Disposition
;; disposition := "Content-Disposition" ":"
;; disposition-type
;; *(";" disposition-parm)
(define re:content-disposition (regexp (format "^~a:(.+)$" (regexp-quote "content-disposition" #f))))
(define (dispositione header entity)
;; From rfc2183 Content-Disposition
;; disposition := "Content-Disposition" ":"
;; disposition-type
;; *(";" disposition-parm)
(define re:content-disposition #rx"^(?i:content-disposition):(.+)$")
(define (dispositione header entity)
(let* ([params (string-tokenizer #\; header)]
[reg re:content-disposition]
[h (trim-all-spaces (car params))]
@ -419,10 +413,9 @@
(disp-type (regexp-replace reg h "\\1")))
(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 (version header message)
;; version := "MIME-Version" ":" 1*DIGIT "." 1*DIGIT
(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)]
[target (regexp-match reg h)])
@ -431,10 +424,9 @@
message
(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 (description header entity)
;; description := "Content-Description" ":" *text
(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)])
(and target
@ -442,9 +434,9 @@
entity
(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 (encoding header entity)
;; encoding := "Content-Transfer-Encoding" ":" mechanism
(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)]
[target (regexp-match reg h)])
@ -453,9 +445,9 @@
entity
(mechanism (regexp-replace reg h "\\1"))))))
;; id := "Content-ID" ":" msg-id
(define re:content-id (regexp (format "^~a:(.+)$" (regexp-quote "content-id" #f))))
(define (id header entity)
;; id := "Content-ID" ":" msg-id
(define re:content-id #rx"^(?i:content-id):(.+)$")
(define (id header entity)
(let* ([reg re:content-id]
[h (trim-all-spaces header)]
[target (regexp-match reg h)])
@ -464,26 +456,26 @@
entity
(msg-id (regexp-replace reg h "\\1"))))))
;; From rfc822:
;; msg-id = "<" addr-spec ">" ; Unique message id
;; addr-spec = local-part "@" domain ; global address
;; local-part = word *("." word) ; uninterpreted
;; ; case-preserved
;; domain = sub-domain *("." sub-domain)
;; sub-domain = domain-ref / domain-literal
;; domain-literal = "[" *(dtext / quoted-pair) "]"
;; domain-ref = atom ; symbolic reference
(define (msg-id str)
;; From rfc822:
;; msg-id = "<" addr-spec ">" ; Unique message id
;; addr-spec = local-part "@" domain ; global address
;; local-part = word *("." word) ; uninterpreted
;; ; case-preserved
;; domain = sub-domain *("." sub-domain)
;; sub-domain = domain-ref / domain-literal
;; domain-literal = "[" *(dtext / quoted-pair) "]"
;; domain-ref = atom ; symbolic reference
(define (msg-id str)
(let* ([r (regexp "^<[^@>]+@[^.]+(\\.[^.]+)*>$")]
[ans (regexp-match r str)])
(if ans
str
(begin (warning "Invalid msg-id: ~a" str) str))))
;; mechanism := "7bit" / "8bit" / "binary" /
;; "quoted-printable" / "base64" /
;; ietf-token / x-token
(define (mechanism mech)
;; mechanism := "7bit" / "8bit" / "binary" /
;; "quoted-printable" / "base64" /
;; ietf-token / x-token
(define (mechanism mech)
(if (not mech)
(raise (make-empty-mechanism))
(let ([val (assoc (lowercase mech) mechanism-alist)])
@ -491,112 +483,111 @@
(ietf-token mech)
(x-token mech)))))
;; MIME-extension-field := <Any RFC 822 header field which
;; begins with the string
;; "Content-">
;;
(define (MIME-extension-field header entity)
;; MIME-extension-field := <Any RFC 822 header field which
;; begins with the string
;; "Content-">
;;
(define (MIME-extension-field header entity)
(let* ([reg (regexp "^[Cc]ontent-(.+):[ \t]*(.+)$")]
[target (regexp-match reg header)])
(and target
(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
(define (type value)
;; type := discrete-type / composite-type
(define (type value)
(if (not value)
(raise (make-empty-type))
(or (discrete-type value)
(composite-type value))))
;; disposition-type := "inline" / "attachment" / extension-token
(define (disp-type value)
;; disposition-type := "inline" / "attachment" / extension-token
(define (disp-type value)
(if (not value)
(raise (make-empty-disposition-type))
(let ([val (assoc (lowercase (trim-spaces value)) disposition-alist)])
(if val (cdr val) (extension-token value)))))
;; discrete-type := "text" / "image" / "audio" / "video" /
;; "application" / extension-token
(define (discrete-type value)
;; discrete-type := "text" / "image" / "audio" / "video" /
;; "application" / extension-token
(define (discrete-type value)
(let ([val (assoc (lowercase (trim-spaces value)) discrete-alist)])
(if val (cdr val) (extension-token value))))
;; composite-type := "message" / "multipart" / extension-token
(define (composite-type value)
;; composite-type := "message" / "multipart" / extension-token
(define (composite-type value)
(let ([val (assoc (lowercase (trim-spaces value)) composite-alist)])
(if val (cdr val) (extension-token value))))
;; extension-token := ietf-token / x-token
(define (extension-token value)
;; extension-token := ietf-token / x-token
(define (extension-token value)
(or (ietf-token value)
(x-token value)))
;; ietf-token := <An extension token defined by a
;; standards-track RFC and registered
;; with IANA.>
(define (ietf-token value)
;; ietf-token := <An extension token defined by a
;; standards-track RFC and registered
;; with IANA.>
(define (ietf-token value)
(let ([ans (assoc (lowercase (trim-spaces value)) ietf-extensions)])
(and ans (cdr ans))))
;; Directly from RFC 1700:
;; Type Subtype Description Reference
;; ---- ------- ----------- ---------
;; text plain [RFC1521,NSB]
;; richtext [RFC1521,NSB]
;; tab-separated-values [Paul Lindner]
;;
;; multipart mixed [RFC1521,NSB]
;; alternative [RFC1521,NSB]
;; digest [RFC1521,NSB]
;; parallel [RFC1521,NSB]
;; appledouble [MacMime,Patrik Faltstrom]
;; header-set [Dave Crocker]
;;
;; message rfc822 [RFC1521,NSB]
;; partial [RFC1521,NSB]
;; external-body [RFC1521,NSB]
;; news [RFC 1036, Henry Spencer]
;;
;; application octet-stream [RFC1521,NSB]
;; postscript [RFC1521,NSB]
;; oda [RFC1521,NSB]
;; atomicmail [atomicmail,NSB]
;; andrew-inset [andrew-inset,NSB]
;; slate [slate,terry crowley]
;; wita [Wang Info Transfer,Larry Campbell]
;; dec-dx [Digital Doc Trans, Larry Campbell]
;; dca-rft [IBM Doc Content Arch, Larry Campbell]
;; activemessage [Ehud Shapiro]
;; rtf [Paul Lindner]
;; applefile [MacMime,Patrik Faltstrom]
;; mac-binhex40 [MacMime,Patrik Faltstrom]
;; news-message-id [RFC1036, Henry Spencer]
;; news-transmission [RFC1036, Henry Spencer]
;; wordperfect5.1 [Paul Lindner]
;; pdf [Paul Lindner]
;; zip [Paul Lindner]
;; macwriteii [Paul Lindner]
;; msword [Paul Lindner]
;; remote-printing [RFC1486,MTR]
;;
;; image jpeg [RFC1521,NSB]
;; gif [RFC1521,NSB]
;; ief Image Exchange Format [RFC1314]
;; tiff Tag Image File Format [MTR]
;;
;; audio basic [RFC1521,NSB]
;;
;; video mpeg [RFC1521,NSB]
;; quicktime [Paul Lindner]
;; Directly from RFC 1700:
;; Type Subtype Description Reference
;; ---- ------- ----------- ---------
;; text plain [RFC1521,NSB]
;; richtext [RFC1521,NSB]
;; tab-separated-values [Paul Lindner]
;;
;; multipart mixed [RFC1521,NSB]
;; alternative [RFC1521,NSB]
;; digest [RFC1521,NSB]
;; parallel [RFC1521,NSB]
;; appledouble [MacMime,Patrik Faltstrom]
;; header-set [Dave Crocker]
;;
;; message rfc822 [RFC1521,NSB]
;; partial [RFC1521,NSB]
;; external-body [RFC1521,NSB]
;; news [RFC 1036, Henry Spencer]
;;
;; application octet-stream [RFC1521,NSB]
;; postscript [RFC1521,NSB]
;; oda [RFC1521,NSB]
;; atomicmail [atomicmail,NSB]
;; andrew-inset [andrew-inset,NSB]
;; slate [slate,terry crowley]
;; wita [Wang Info Transfer,Larry Campbell]
;; dec-dx [Digital Doc Trans, Larry Campbell]
;; dca-rft [IBM Doc Content Arch, Larry Campbell]
;; activemessage [Ehud Shapiro]
;; rtf [Paul Lindner]
;; applefile [MacMime,Patrik Faltstrom]
;; mac-binhex40 [MacMime,Patrik Faltstrom]
;; news-message-id [RFC1036, Henry Spencer]
;; news-transmission [RFC1036, Henry Spencer]
;; wordperfect5.1 [Paul Lindner]
;; pdf [Paul Lindner]
;; zip [Paul Lindner]
;; macwriteii [Paul Lindner]
;; msword [Paul Lindner]
;; remote-printing [RFC1486,MTR]
;;
;; image jpeg [RFC1521,NSB]
;; gif [RFC1521,NSB]
;; ief Image Exchange Format [RFC1314]
;; tiff Tag Image File Format [MTR]
;;
;; audio basic [RFC1521,NSB]
;;
;; video mpeg [RFC1521,NSB]
;; quicktime [Paul Lindner]
;; x-token := <The two characters "X-" or "x-" followed, with
;; no intervening white space, by any token>
(define (x-token value)
;; x-token := <The two characters "X-" or "x-" followed, with
;; no intervening white space, by any token>
(define (x-token value)
(let* ([r #rx"^[xX]-(.*)"]
[h (trim-spaces value)]
[ans (regexp-match r h)])
@ -604,23 +595,23 @@
(token (regexp-replace r h "\\1"))
h)))
;; subtype := extension-token / iana-token
(define (subtype value)
;; subtype := extension-token / iana-token
(define (subtype value)
(if (not value)
(raise (make-empty-subtype))
(or (extension-token value)
(iana-token value))))
;; iana-token := <A publicly-defined extension token. Tokens
;; of this form must be registered with IANA
;; as specified in RFC 2048.>
(define (iana-token value)
;; iana-token := <A publicly-defined extension token. Tokens
;; of this form must be registered with IANA
;; as specified in RFC 2048.>
(define (iana-token value)
(let ([ans (assoc (lowercase (trim-spaces value)) iana-extensions)])
(and ans (cdr ans))))
;; parameter := attribute "=" value
(define re:parameter (regexp "([^=]+)=(.+)"))
(define (parameter par)
;; parameter := attribute "=" value
(define re:parameter (regexp "([^=]+)=(.+)"))
(define (parameter par)
(let* ([r re:parameter]
[att (attribute (regexp-replace r par "\\1"))]
[val (value (regexp-replace r par "\\2"))])
@ -628,54 +619,54 @@
(cons (if att (lowercase att) "???") val)
(cons "???" par))))
;; value := token / quoted-string
(define (value val)
;; value := token / quoted-string
(define (value val)
(or (token val)
(quoted-string val)
val))
;; token := 1*<any (US-ASCII) CHAR except SPACE, CTLs,
;; or tspecials>
;; tspecials := "(" / ")" / "<" / ">" / "@" /
;; "," / ";" / ":" / "\" / <">
;; "/" / "[" / "]" / "?" / "="
;; ; Must be in quoted-string,
;; ; to use within parameter values
(define (token value)
;; token := 1*<any (US-ASCII) CHAR except SPACE, CTLs,
;; or tspecials>
;; tspecials := "(" / ")" / "<" / ">" / "@" /
;; "," / ";" / ":" / "\" / <">
;; "/" / "[" / "]" / "?" / "="
;; ; Must be in quoted-string,
;; ; to use within parameter values
(define (token value)
(let* ([tspecials (regexp "[^][()<>@,;:\\\"/?= ]+")]
[ans (regexp-match tspecials value)])
(and ans
(string=? value (car ans))
(car ans))))
;; attribute := token
;; ; Matching of attributes
;; ; is ALWAYS case-insensitive.
(define attribute token)
;; attribute := token
;; ; Matching of attributes
;; ; is ALWAYS case-insensitive.
(define attribute token)
(define re:quotes (regexp "\"(.+)\""))
(define (quoted-string str)
(define re:quotes (regexp "\"(.+)\""))
(define (quoted-string str)
(let* ([quotes re:quotes]
[ans (regexp-match quotes str)])
(and ans (regexp-replace quotes str "\\1"))))
;; disposition-parm := filename-parm
;; / creation-date-parm
;; / modification-date-parm
;; / read-date-parm
;; / size-parm
;; / parameter
;;
;; filename-parm := "filename" "=" value
;;
;; creation-date-parm := "creation-date" "=" quoted-date-time
;;
;; modification-date-parm := "modification-date" "=" quoted-date-time
;;
;; read-date-parm := "read-date" "=" quoted-date-time
;;
;; size-parm := "size" "=" 1*DIGIT
(define (disp-params lst disp)
;; disposition-parm := filename-parm
;; / creation-date-parm
;; / modification-date-parm
;; / read-date-parm
;; / size-parm
;; / parameter
;;
;; filename-parm := "filename" "=" value
;;
;; creation-date-parm := "creation-date" "=" quoted-date-time
;;
;; modification-date-parm := "modification-date" "=" quoted-date-time
;;
;; read-date-parm := "read-date" "=" quoted-date-time
;;
;; size-parm := "size" "=" 1*DIGIT
(define (disp-params lst disp)
(let loop ([lst lst])
(unless (null? lst)
(let* ([p (parameter (trim-all-spaces (car lst)))]
@ -705,42 +696,42 @@
(append (disposition-params disp) (list p)))])
(loop (cdr lst))))))
;; date-time = [ day "," ] date time ; dd mm yy
;; ; hh:mm:ss zzz
;;
;; day = "Mon" / "Tue" / "Wed" / "Thu"
;; / "Fri" / "Sat" / "Sun"
;;
;; date = 1*2DIGIT month 2DIGIT ; day month year
;; ; e.g. 20 Jun 82
;;
;; month = "Jan" / "Feb" / "Mar" / "Apr"
;; / "May" / "Jun" / "Jul" / "Aug"
;; / "Sep" / "Oct" / "Nov" / "Dec"
;;
;; time = hour zone ; ANSI and Military
;;
;; hour = 2DIGIT ":" 2DIGIT [":" 2DIGIT]
;; ; 00:00:00 - 23:59:59
;;
;; zone = "UT" / "GMT" ; Universal Time
;; ; North American : UT
;; / "EST" / "EDT" ; Eastern: - 5/ - 4
;; / "CST" / "CDT" ; Central: - 6/ - 5
;; / "MST" / "MDT" ; Mountain: - 7/ - 6
;; / "PST" / "PDT" ; Pacific: - 8/ - 7
;; / 1ALPHA ; Military: Z = UT;
;; ; A:-1; (J not used)
;; ; M:-12; N:+1; Y:+12
;; / ( ("+" / "-") 4DIGIT ) ; Local differential
;; ; hours+min. (HHMM)
(define date-time
;; date-time = [ day "," ] date time ; dd mm yy
;; ; hh:mm:ss zzz
;;
;; day = "Mon" / "Tue" / "Wed" / "Thu"
;; / "Fri" / "Sat" / "Sun"
;;
;; date = 1*2DIGIT month 2DIGIT ; day month year
;; ; e.g. 20 Jun 82
;;
;; month = "Jan" / "Feb" / "Mar" / "Apr"
;; / "May" / "Jun" / "Jul" / "Aug"
;; / "Sep" / "Oct" / "Nov" / "Dec"
;;
;; time = hour zone ; ANSI and Military
;;
;; hour = 2DIGIT ":" 2DIGIT [":" 2DIGIT]
;; ; 00:00:00 - 23:59:59
;;
;; zone = "UT" / "GMT" ; Universal Time
;; ; North American : UT
;; / "EST" / "EDT" ; Eastern: - 5/ - 4
;; / "CST" / "CDT" ; Central: - 6/ - 5
;; / "MST" / "MDT" ; Mountain: - 7/ - 6
;; / "PST" / "PDT" ; Pacific: - 8/ - 7
;; / 1ALPHA ; Military: Z = UT;
;; ; A:-1; (J not used)
;; ; M:-12; N:+1; Y:+12
;; / ( ("+" / "-") 4DIGIT ) ; Local differential
;; ; hours+min. (HHMM)
(define date-time
(lambda (str)
;; Fix Me: I have to return a date structure, or time in seconds.
str))
;; quoted-date-time := quoted-string
;; ; contents MUST be an RFC 822 `date-time'
;; ; numeric timezones (+HHMM or -HHMM) MUST be used
;; quoted-date-time := quoted-string
;; ; contents MUST be an RFC 822 `date-time'
;; ; numeric timezones (+HHMM or -HHMM) MUST be used
(define disp-quoted-data-time date-time)
(define disp-quoted-data-time date-time)

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

@ -28,36 +28,32 @@
#lang scheme/unit
(require "qp-sig.ss"
mzlib/etc)
(require "qp-sig.ss")
(import)
(export qp^)
(import)
(export qp^)
;; Exceptions:
;; String or input-port expected:
(define-struct qp-error ())
(define-struct (qp-wrong-input qp-error) ())
(define-struct (qp-wrong-line-size qp-error) (size))
;; Exceptions:
;; String or input-port expected:
(define-struct qp-error ())
(define-struct (qp-wrong-input qp-error) ())
(define-struct (qp-wrong-line-size qp-error) (size))
;; qp-encode : bytes -> bytes
;; returns the quoted printable representation of STR.
(define qp-encode
(lambda (str)
;; qp-encode : bytes -> bytes
;; returns the quoted printable representation of 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)
;; qp-decode : string -> string
;; returns STR unqp.
(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)
(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,17 +145,17 @@
[else
;; an octect
(write-hex-bytes i out)
(loop (+ col 3))]))))))
(loop (+ col 3))])))))
;; Tables
(define hex-values (make-vector 256 #f))
(define hex-bytes (make-vector 16))
(let loop ([i 0])
;; Tables
(define hex-values (make-vector 256 #f))
(define hex-bytes (make-vector 16))
(let loop ([i 0])
(unless (= i 10)
(vector-set! hex-values (+ i 48) i)
(vector-set! hex-bytes i (+ i 48))
(loop (add1 i))))
(let loop ([i 0])
(let loop ([i 0])
(unless (= i 6)
(vector-set! hex-values (+ i 65) (+ 10 i))
(vector-set! hex-values (+ i 97) (+ 10 i))

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

@ -1,16 +1,16 @@
#lang scheme/unit
(require mzlib/process "sendmail-sig.ss")
(require mzlib/process "sendmail-sig.ss")
(import)
(export sendmail^)
(import)
(export sendmail^)
(define-struct (no-mail-recipients exn) ())
(define-struct (no-mail-recipients exn) ())
(define sendmail-search-path
(define sendmail-search-path
'("/usr/lib" "/usr/sbin"))
(define sendmail-program-file
(define sendmail-program-file
(if (or (eq? (system-type) 'unix)
(eq? (system-type) 'macosx))
(let loop ([paths sendmail-search-path])
@ -27,20 +27,20 @@
"sendmail only available under Unix"
(current-continuation-marks)))))
;; send-mail-message/port :
;; string x string x list (string) x list (string) x list (string)
;; [x list (string)] -> oport
;; send-mail-message/port :
;; string x string x list (string) x list (string) x list (string)
;; [x list (string)] -> oport
;; -- sender can be anything, though spoofing is not recommended.
;; The recipients must all be pure email addresses. Note that
;; everything is expected to follow RFC conventions. If any other
;; headers are specified, they are expected to be completely
;; formatted already. Clients are urged to use close-output-port on
;; the port returned by this procedure as soon as the necessary text
;; has been written, so that the sendmail process can complete.
;; -- sender can be anything, though spoofing is not recommended.
;; The recipients must all be pure email addresses. Note that
;; everything is expected to follow RFC conventions. If any other
;; headers are specified, they are expected to be completely
;; formatted already. Clients are urged to use close-output-port on
;; 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,20 +94,20 @@
(newline writer))
other-headers)
(newline writer)
writer))))
writer)))
;; send-mail-message :
;; string x string x list (string) x list (string) x list (string) x
;; list (string) [x list (string)] -> ()
;; send-mail-message :
;; string x string x list (string) x list (string) x list (string) x
;; list (string) [x list (string)] -> ()
;; -- sender can be anything, though spoofing is not recommended. The
;; recipients must all be pure email addresses. The text is expected
;; to be pre-formatted. Note that everything is expected to follow
;; RFC conventions. If any other headers are specified, they are
;; expected to be completely formatted already.
;; -- sender can be anything, though spoofing is not recommended. The
;; recipients must all be pure email addresses. The text is expected
;; to be pre-formatted. Note that everything is expected to follow
;; 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)))

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

@ -9,28 +9,21 @@
;; "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^)
(import tcp^)
(export url^)
(define-struct (url-exception exn:fail) ())
(define-struct (url-exception exn:fail) ())
(define file-url-path-convention-type (make-parameter (system-path-convention-type)))
(define file-url-path-convention-type (make-parameter (system-path-convention-type)))
(define current-proxy-servers
(define current-proxy-servers
(make-parameter null
(lambda (v)
(unless (and (list? v)
@ -54,14 +47,14 @@
(caddr v)))
v))))
(define (url-error fmt . args)
(define (url-error fmt . args)
(raise (make-url-exception
(apply format fmt
(map (lambda (arg) (if (url? arg) (url->string arg) arg))
args))
(current-continuation-marks))))
(define (url->string url)
(define (url->string url)
(let ([scheme (url-scheme url)]
[user (url-user url)]
[host (url-host url)]
@ -92,24 +85,24 @@
(if (null? query) "" (sa "?" (alist->form-urlencoded query)))
(if fragment (sa "#" (uri-encode fragment)) ""))))
;; url->default-port : url -> num
(define (url->default-port url)
;; url->default-port : url -> num
(define (url->default-port url)
(let ([scheme (url-scheme url)])
(cond [(not scheme) 80]
[(string=? scheme "http") 80]
[(string=? scheme "https") 443]
[else (url-error "Scheme ~a not supported" (url-scheme url))])))
;; make-ports : url -> in-port x out-port
(define (make-ports url proxy)
;; make-ports : url -> in-port x out-port
(define (make-ports url proxy)
(let ([port-number (if proxy
(caddr proxy)
(or (url-port url) (url->default-port url)))]
[host (if proxy (cadr proxy) (url-host url))])
(tcp-connect host port-number)))
;; http://getpost-impure-port : bool x url x union (str, #f) x list (str) -> in-port
(define (http://getpost-impure-port get? url post-data strings)
;; http://getpost-impure-port : bool x url x union (str, #f) x list (str) -> in-port
(define (http://getpost-impure-port get? url post-data strings)
(let*-values
([(proxy) (assoc (url-scheme url) (current-proxy-servers))]
[(server->client client->server) (make-ports url proxy)]
@ -135,7 +128,7 @@
(tcp-abandon-port client->server)
server->client))
(define (file://->path url [kind (system-path-convention-type)])
(define (file://->path url [kind (system-path-convention-type)])
(let ([strs (map path/param-path (url-path url))]
[string->path-element/same
(lambda (e)
@ -167,35 +160,34 @@
(apply build-path (bytes->path #"/" 'unix) elems)
(apply build-path elems))))))
;; file://get-pure-port : url -> in-port
(define (file://get-pure-port url)
;; file://get-pure-port : url -> in-port
(define (file://get-pure-port url)
(open-input-file (file://->path url)))
(define (schemeless-url url)
(define (schemeless-url url)
(url-error "Missing protocol (usually \"http:\") at the beginning of URL: ~a" url))
;; getpost-impure-port : bool x url x list (str) -> in-port
(define (getpost-impure-port get? url post-data strings)
;; getpost-impure-port : bool x url x list (str) -> in-port
(define (getpost-impure-port get? url post-data strings)
(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 '()])
;; get-impure-port : url [x list (str)] -> in-port
(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 '()])
;; post-impure-port : url x bytes [x list (str)] -> in-port
(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
(define (getpost-pure-port get? url post-data strings)
;; getpost-pure-port : bool x url x list (str) -> in-port
(define (getpost-pure-port get? url post-data strings)
(let ([scheme (url-scheme url)])
(cond [(not scheme)
(schemeless-url url)]
@ -212,21 +204,21 @@
(file://get-pure-port url)]
[else (url-error "Scheme ~a unsupported" scheme)])))
;; get-pure-port : url [x list (str)] -> in-port
(define/kw (get-pure-port url #:optional [strings '()])
;; get-pure-port : url [x list (str)] -> in-port
(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 '()])
;; post-pure-port : url bytes [x list (str)] -> in-port
(define (post-pure-port url post-data [strings '()])
(getpost-pure-port #f url post-data strings))
;; display-pure-port : in-port -> ()
(define (display-pure-port server->client)
;; display-pure-port : in-port -> ()
(define (display-pure-port server->client)
(copy-port server->client (current-output-port))
(close-input-port server->client))
;; transliteration of code in rfc 3986, section 5.2.2
(define (combine-url/relative Base string)
;; transliteration of code in rfc 3986, section 5.2.2
(define (combine-url/relative Base string)
(let ([R (string->url string)]
[T (make-url #f #f #f #f #f '() '() #f)])
(if (url-scheme R)
@ -277,16 +269,16 @@
(set-url-fragment! T (url-fragment R))
T))
(define (all-but-last lst)
(define (all-but-last lst)
(cond [(null? lst) null]
[(null? (cdr lst)) null]
[else (cons (car lst) (all-but-last (cdr lst)))]))
;; cribbed from 5.2.4 in rfc 3986
;; the strange [*] cases implicitly change urls
;; with paths segments "." and ".." at the end
;; into "./" and "../" respectively
(define (remove-dot-segments path)
;; cribbed from 5.2.4 in rfc 3986
;; the strange [*] cases implicitly change urls
;; with paths segments "." and ".." at the end
;; into "./" and "../" respectively
(define (remove-dot-segments path)
(let loop ([path path] [result '()])
(if (null? path)
(reverse result)
@ -308,9 +300,9 @@
[else
(cons (car path) result)]))))))
;; call/input-url : url x (url -> in-port) x (in-port -> T)
;; [x list (str)] -> T
(define call/input-url
;; call/input-url : url x (url -> in-port) x (in-port -> T)
;; [x list (str)] -> T
(define call/input-url
(let ([handle-port
(lambda (server->client handler)
(dynamic-wind (lambda () 'do-nothing)
@ -322,16 +314,16 @@
[(url getter handler params)
(handle-port (getter url params) handler)])))
;; purify-port : in-port -> header-string
(define (purify-port port)
;; purify-port : in-port -> header-string
(define (purify-port port)
(let ([m (regexp-match-peek-positions
#rx"^HTTP/.*?(?:\r\n\r\n|\n\n|\r\r)" port)])
(if m (read-string (cdar m) port) "")))
(define character-set-size 256)
(define character-set-size 256)
;; netscape/string->url : str -> url
(define (netscape/string->url string)
;; netscape/string->url : str -> url
(define (netscape/string->url string)
(let ([url (string->url string)])
(cond [(url-scheme url) url]
[(string=? string "")
@ -340,12 +332,12 @@
(if (char=? (string-ref string 0) #\/) "file" "http"))
url])))
;; URL parsing regexp
;; this is following the regexp in Appendix B of rfc 3986, except for using
;; `*' instead of `+' for the scheme part (it is checked later anyway, and
;; we don't want to parse it as a path element), and the user@host:port is
;; parsed here.
(define url-rx
;; URL parsing regexp
;; this is following the regexp in Appendix B of rfc 3986, except for using
;; `*' instead of `+' for the scheme part (it is checked later anyway, and
;; we don't want to parse it as a path element), and the user@host:port is
;; parsed here.
(define url-rx
(regexp (string-append
"^"
"(?:" ; / scheme-colon-opt
@ -369,17 +361,16 @@
")?" ; \
"$")))
;; string->url : str -> url
;; Original version by Neil Van Dyke
(define (string->url str)
;; string->url : str -> url
;; Original version by Neil Van Dyke
(define (string->url str)
(apply
(lambda (scheme user host port path query fragment)
(when (and scheme (not (regexp-match? #rx"^[a-zA-Z][a-zA-Z0-9+.-]*$"
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 "")))])
@ -408,46 +399,46 @@
(cdr (or (regexp-match url-rx str)
(url-error "Invalid URL string: ~e" str)))))
(define (uri-decode/maybe f)
(define (uri-decode/maybe f)
;; If #f, and leave unmolested any % that is followed by hex digit
;; if a % is not followed by a hex digit, replace it with %25
;; in an attempt to be "friendly"
(and f (uri-decode (regexp-replace* #rx"%([^0-9a-fA-F])" f "%25\\1"))))
;; separate-path-strings : string[starting with /] -> (listof path/param)
(define (separate-path-strings str)
;; separate-path-strings : string[starting with /] -> (listof path/param)
(define (separate-path-strings str)
(let ([strs (regexp-split #rx"/" str)])
(map separate-params (if (string=? "" (car strs)) (cdr strs) strs))))
(define (separate-windows-path-strings str)
(define (separate-windows-path-strings str)
(url-path (path->url (bytes->path (string->bytes/utf-8 str) 'windows))))
(define (separate-params s)
(define (separate-params s)
(let ([lst (map path-segment-decode (regexp-split #rx";" s))])
(make-path/param (car lst) (cdr lst))))
(define (path-segment-decode p)
(define (path-segment-decode p)
(cond [(string=? p "..") 'up]
[(string=? p ".") 'same]
[else (uri-path-segment-decode p)]))
(define (path-segment-encode p)
(define (path-segment-encode p)
(cond [(eq? p 'up) ".."]
[(eq? p 'same) "."]
[(equal? p "..") "%2e%2e"]
[(equal? p ".") "%2e"]
[else (uri-path-segment-encode p)]))
(define (combine-path-strings absolute? path/params)
(define (combine-path-strings absolute? path/params)
(cond [(null? path/params) ""]
[else (let ([p (join "/" (map join-params path/params))])
(if absolute? (string-append "/" p) p))]))
(define (join-params s)
(define (join-params s)
(join ";" (map path-segment-encode
(cons (path/param-path s) (path/param-param s)))))
(define (join sep strings)
(define (join sep strings)
(cond [(null? strings) ""]
[(null? (cdr strings)) (car strings)]
[else
@ -456,8 +447,9 @@
(apply string-append (reverse r))
(loop (cdr strings) (list* (car strings) sep r))))]))
(define (path->url path)
(let ([url-path (let loop ([path (simplify-path path #f)][accum null])
(define (path->url path)
(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)
@ -499,52 +490,50 @@
(loop base accum)))])))])
(make-url "file" #f "" #f (absolute-path? path) url-path '() #f)))
(define (url->path url [kind (system-path-convention-type)])
(define (url->path url [kind (system-path-convention-type)])
(file://->path url kind))
;; delete-pure-port : url [x list (str)] -> in-port
(define/kw (delete-pure-port url #:optional [strings '()])
;; delete-pure-port : url [x list (str)] -> in-port
(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 '()])
;; delete-impure-port : url [x list (str)] -> in-port
(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 '()])
;; head-pure-port : url [x list (str)] -> in-port
(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 '()])
;; head-impure-port : url [x list (str)] -> in-port
(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 '()])
;; put-pure-port : url bytes [x list (str)] -> in-port
(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 '()])
;; put-impure-port : url x bytes [x list (str)] -> in-port
(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
(define (method-impure-port method url data strings)
;; method-impure-port : symbol x url x list (str) -> in-port
(define (method-impure-port method url data strings)
(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")]
[else (url-error "Scheme ~a unsupported" scheme)])))
;; method-pure-port : symbol x url x list (str) -> in-port
(define (method-pure-port method url data strings)
;; method-pure-port : symbol x url x list (str) -> in-port
(define (method-pure-port method url data strings)
(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)
@ -556,8 +545,8 @@
(file://get-pure-port url)]
[else (url-error "Scheme ~a unsupported" scheme)])))
;; http://metod-impure-port : symbol x url x union (str, #f) x list (str) -> in-port
(define (http://method-impure-port method url data strings)
;; http://metod-impure-port : symbol x url x union (str, #f) x list (str) -> in-port
(define (http://method-impure-port method url data strings)
(let*-values
([(method) (case method
[(get) "GET"] [(post) "POST"] [(head) "HEAD"]
@ -586,5 +575,3 @@
(flush-output client->server)
(tcp-abandon-port client->server)
server->client))
))