reformatting
svn: r9853 original commit: 0d41afdb6d470299616dd1db944ce4577c5a64bf
This commit is contained in:
Eli Barzilay
parent
db624416dd
commit
ec81ffebfc
|
|
@ -1,4 +1,3 @@
|
||||||
|
|
||||||
#lang scheme/signature
|
#lang scheme/signature
|
||||||
|
|
||||||
base64-filename-safe
|
base64-filename-safe
|
||||||
|
|
|
||||||
|
|
@ -1,47 +1,44 @@
|
||||||
#lang scheme/unit
|
#lang scheme/unit
|
||||||
|
(require "cgi-sig.ss" "uri-codec.ss")
|
||||||
|
|
||||||
(require mzlib/etc
|
(import)
|
||||||
"cgi-sig.ss"
|
(export cgi^)
|
||||||
"uri-codec.ss")
|
|
||||||
|
|
||||||
(import)
|
;; type bindings = list ((symbol . string))
|
||||||
(export cgi^)
|
|
||||||
|
|
||||||
;; 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)
|
(define-struct (incomplete-%-suffix cgi-error) (chars))
|
||||||
;; -- gives the suffix which is invalid, not including the `%'
|
|
||||||
|
|
||||||
(define-struct (incomplete-%-suffix cgi-error) (chars))
|
;; char : char
|
||||||
|
;; -- an invalid character in a hex string
|
||||||
|
|
||||||
;; char : char
|
(define-struct (invalid-%-suffix cgi-error) (char))
|
||||||
;; -- an invalid character in a hex string
|
|
||||||
|
|
||||||
(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
|
(define (query-chars->string chars)
|
||||||
;; 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)
|
|
||||||
(form-urlencoded-decode (list->string chars)))
|
(form-urlencoded-decode (list->string chars)))
|
||||||
|
|
||||||
;; string->html : string -> string
|
;; string->html : string -> string
|
||||||
;; -- the input is raw text, the output is HTML appropriately quoted
|
;; -- the input is raw text, the output is HTML appropriately quoted
|
||||||
|
|
||||||
(define (string->html s)
|
(define (string->html s)
|
||||||
(apply string-append
|
(apply string-append
|
||||||
(map (lambda (c)
|
(map (lambda (c)
|
||||||
(case c
|
(case c
|
||||||
|
|
@ -51,26 +48,23 @@
|
||||||
[else (string c)]))
|
[else (string c)]))
|
||||||
(string->list s))))
|
(string->list s))))
|
||||||
|
|
||||||
(define default-text-color "#000000")
|
(define default-text-color "#000000")
|
||||||
(define default-bg-color "#ffffff")
|
(define default-bg-color "#ffffff")
|
||||||
(define default-link-color "#cc2200")
|
(define default-link-color "#cc2200")
|
||||||
(define default-vlink-color "#882200")
|
(define default-vlink-color "#882200")
|
||||||
(define default-alink-color "#444444")
|
(define default-alink-color "#444444")
|
||||||
|
|
||||||
;; generate-html-output :
|
;; generate-html-output :
|
||||||
;; html-string x list (html-string) x ... -> ()
|
;; html-string x list (html-string) x ... -> ()
|
||||||
|
|
||||||
(define generate-html-output
|
(define (generate-html-output title body-lines
|
||||||
(opt-lambda (title body-lines
|
|
||||||
[text-color default-text-color]
|
[text-color default-text-color]
|
||||||
[bg-color default-bg-color]
|
[bg-color default-bg-color]
|
||||||
[link-color default-link-color]
|
[link-color default-link-color]
|
||||||
[vlink-color default-vlink-color]
|
[vlink-color default-vlink-color]
|
||||||
[alink-color default-alink-color])
|
[alink-color default-alink-color])
|
||||||
(let ([sa string-append])
|
(let ([sa string-append])
|
||||||
(for-each
|
(for ([l `("Content-type: text/html"
|
||||||
(lambda (l) (display l) (newline))
|
|
||||||
`("Content-type: text/html"
|
|
||||||
""
|
""
|
||||||
"<html>"
|
"<html>"
|
||||||
"<!-- The form was processed, and this document was generated,"
|
"<!-- The form was processed, and this document was generated,"
|
||||||
|
|
@ -90,34 +84,36 @@
|
||||||
,@body-lines
|
,@body-lines
|
||||||
""
|
""
|
||||||
"</body>"
|
"</body>"
|
||||||
"</html>")))))
|
"</html>")])
|
||||||
|
(display l)
|
||||||
|
(newline))))
|
||||||
|
|
||||||
;; output-http-headers : -> void
|
;; output-http-headers : -> void
|
||||||
(define (output-http-headers)
|
(define (output-http-headers)
|
||||||
(printf "Content-type: text/html\r\n\r\n"))
|
(printf "Content-type: text/html\r\n\r\n"))
|
||||||
|
|
||||||
;; read-until-char : iport x char -> list (char) x bool
|
;; read-until-char : iport x char -> list (char) x bool
|
||||||
;; -- operates on the default input port; the second value indicates whether
|
;; -- operates on the default input port; the second value indicates whether
|
||||||
;; reading stopped because an EOF was hit (as opposed to the delimiter being
|
;; reading stopped because an EOF was hit (as opposed to the delimiter being
|
||||||
;; seen); the delimiter is not part of the result
|
;; seen); the delimiter is not part of the result
|
||||||
(define (read-until-char ip delimiter)
|
(define (read-until-char ip delimiter)
|
||||||
(let loop ([chars '()])
|
(let loop ([chars '()])
|
||||||
(let ([c (read-char ip)])
|
(let ([c (read-char ip)])
|
||||||
(cond [(eof-object? c) (values (reverse chars) #t)]
|
(cond [(eof-object? c) (values (reverse chars) #t)]
|
||||||
[(char=? c delimiter) (values (reverse chars) #f)]
|
[(char=? c delimiter) (values (reverse chars) #f)]
|
||||||
[else (loop (cons c chars))]))))
|
[else (loop (cons c chars))]))))
|
||||||
|
|
||||||
;; read-name+value : iport -> (symbol + bool) x (string + bool) x bool
|
;; 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,
|
;; -- 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
|
;; indicating EOF was reached without any input seen. Otherwise, the first
|
||||||
;; and second values contain strings and the third is either true or false
|
;; 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
|
;; 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
|
;; 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,
|
;; 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
|
;; 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
|
;; look like this matters. It would also introduce needless modality and
|
||||||
;; reduce flexibility.
|
;; reduce flexibility.
|
||||||
(define (read-name+value ip)
|
(define (read-name+value ip)
|
||||||
(let-values ([(name eof?) (read-until-char ip #\=)])
|
(let-values ([(name eof?) (read-until-char ip #\=)])
|
||||||
(cond [(and eof? (null? name)) (values #f #f #t)]
|
(cond [(and eof? (null? name)) (values #f #f #t)]
|
||||||
[eof?
|
[eof?
|
||||||
|
|
@ -130,15 +126,15 @@
|
||||||
(query-chars->string value)
|
(query-chars->string value)
|
||||||
eof?))])))
|
eof?))])))
|
||||||
|
|
||||||
;; get-bindings/post : () -> bindings
|
;; get-bindings/post : () -> bindings
|
||||||
(define (get-bindings/post)
|
(define (get-bindings/post)
|
||||||
(let-values ([(name value eof?) (read-name+value (current-input-port))])
|
(let-values ([(name value eof?) (read-name+value (current-input-port))])
|
||||||
(cond [(and eof? (not name)) null]
|
(cond [(and eof? (not name)) null]
|
||||||
[(and eof? name) (list (cons name value))]
|
[(and eof? name) (list (cons name value))]
|
||||||
[else (cons (cons name value) (get-bindings/post))])))
|
[else (cons (cons name value) (get-bindings/post))])))
|
||||||
|
|
||||||
;; get-bindings/get : () -> bindings
|
;; get-bindings/get : () -> bindings
|
||||||
(define (get-bindings/get)
|
(define (get-bindings/get)
|
||||||
(let ([p (open-input-string (getenv "QUERY_STRING"))])
|
(let ([p (open-input-string (getenv "QUERY_STRING"))])
|
||||||
(let loop ()
|
(let loop ()
|
||||||
(let-values ([(name value eof?) (read-name+value p)])
|
(let-values ([(name value eof?) (read-name+value p)])
|
||||||
|
|
@ -146,20 +142,20 @@
|
||||||
[(and eof? name) (list (cons name value))]
|
[(and eof? name) (list (cons name value))]
|
||||||
[else (cons (cons name value) (loop))])))))
|
[else (cons (cons name value) (loop))])))))
|
||||||
|
|
||||||
;; get-bindings : () -> bindings
|
;; get-bindings : () -> bindings
|
||||||
(define (get-bindings)
|
(define (get-bindings)
|
||||||
(if (string=? (get-cgi-method) "POST")
|
(if (string=? (get-cgi-method) "POST")
|
||||||
(get-bindings/post)
|
(get-bindings/post)
|
||||||
(get-bindings/get)))
|
(get-bindings/get)))
|
||||||
|
|
||||||
;; generate-error-output : list (html-string) -> <exit>
|
;; generate-error-output : list (html-string) -> <exit>
|
||||||
(define (generate-error-output error-message-lines)
|
(define (generate-error-output error-message-lines)
|
||||||
(generate-html-output "Internal Error" error-message-lines)
|
(generate-html-output "Internal Error" error-message-lines)
|
||||||
(exit))
|
(exit))
|
||||||
|
|
||||||
;; bindings-as-html : bindings -> list (html-string)
|
;; bindings-as-html : bindings -> list (html-string)
|
||||||
;; -- formats name-value bindings as HTML appropriate for displaying
|
;; -- formats name-value bindings as HTML appropriate for displaying
|
||||||
(define (bindings-as-html bindings)
|
(define (bindings-as-html bindings)
|
||||||
`("<code>"
|
`("<code>"
|
||||||
,@(map (lambda (bind)
|
,@(map (lambda (bind)
|
||||||
(string-append (symbol->string (car bind))
|
(string-append (symbol->string (car bind))
|
||||||
|
|
@ -169,12 +165,12 @@
|
||||||
bindings)
|
bindings)
|
||||||
"</code>"))
|
"</code>"))
|
||||||
|
|
||||||
;; extract-bindings : (string + symbol) x bindings -> list (string)
|
;; extract-bindings : (string + symbol) x bindings -> list (string)
|
||||||
;; -- Extracts the bindings associated with a given name. The semantics of
|
;; -- Extracts the bindings associated with a given name. The semantics of
|
||||||
;; forms states that a CHECKBOX may use the same NAME field multiple times.
|
;; 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
|
;; Hence, a list of strings is returned. Note that the result may be the
|
||||||
;; empty list.
|
;; empty list.
|
||||||
(define (extract-bindings field-name bindings)
|
(define (extract-bindings field-name bindings)
|
||||||
(let ([field-name (if (symbol? field-name)
|
(let ([field-name (if (symbol? field-name)
|
||||||
field-name (string->symbol field-name))])
|
field-name (string->symbol field-name))])
|
||||||
(let loop ([found null] [bindings bindings])
|
(let loop ([found null] [bindings bindings])
|
||||||
|
|
@ -184,9 +180,9 @@
|
||||||
(loop (cons (cdar bindings) found) (cdr bindings))
|
(loop (cons (cdar bindings) found) (cdr bindings))
|
||||||
(loop found (cdr bindings)))))))
|
(loop found (cdr bindings)))))))
|
||||||
|
|
||||||
;; extract-binding/single : (string + symbol) x bindings -> string
|
;; extract-binding/single : (string + symbol) x bindings -> string
|
||||||
;; -- used in cases where only one binding is supposed to occur
|
;; -- used in cases where only one binding is supposed to occur
|
||||||
(define (extract-binding/single field-name bindings)
|
(define (extract-binding/single field-name bindings)
|
||||||
(let* ([field-name (if (symbol? field-name)
|
(let* ([field-name (if (symbol? field-name)
|
||||||
field-name (string->symbol field-name))]
|
field-name (string->symbol field-name))]
|
||||||
[result (extract-bindings field-name bindings)])
|
[result (extract-bindings field-name bindings)])
|
||||||
|
|
@ -203,12 +199,12 @@
|
||||||
field-name)
|
field-name)
|
||||||
(bindings-as-html bindings)))])))
|
(bindings-as-html bindings)))])))
|
||||||
|
|
||||||
;; get-cgi-method : () -> string
|
;; get-cgi-method : () -> string
|
||||||
;; -- string is either GET or POST (though future extension is possible)
|
;; -- string is either GET or POST (though future extension is possible)
|
||||||
(define (get-cgi-method)
|
(define (get-cgi-method)
|
||||||
(or (getenv "REQUEST_METHOD")
|
(or (getenv "REQUEST_METHOD")
|
||||||
(error 'get-cgi-method "no REQUEST_METHOD environment variable")))
|
(error 'get-cgi-method "no REQUEST_METHOD environment variable")))
|
||||||
|
|
||||||
;; generate-link-text : string x html-string -> html-string
|
;; generate-link-text : string x html-string -> html-string
|
||||||
(define (generate-link-text url anchor-text)
|
(define (generate-link-text url anchor-text)
|
||||||
(string-append "<a href=\"" url "\">" anchor-text "</a>"))
|
(string-append "<a href=\"" url "\">" anchor-text "</a>"))
|
||||||
|
|
|
||||||
|
|
@ -50,38 +50,35 @@
|
||||||
|
|
||||||
#lang scheme/unit
|
#lang scheme/unit
|
||||||
|
|
||||||
(require mzlib/etc
|
(require srfi/13/string srfi/14/char-set "cookie-sig.ss")
|
||||||
mzlib/list
|
|
||||||
srfi/13/string
|
|
||||||
srfi/14/char-set
|
|
||||||
"cookie-sig.ss")
|
|
||||||
|
|
||||||
(import)
|
(import)
|
||||||
(export cookie^)
|
(export cookie^)
|
||||||
|
|
||||||
(define-struct cookie (name value comment domain max-age path secure version) #:mutable)
|
(define-struct cookie
|
||||||
(define-struct (cookie-error exn:fail) ())
|
(name value comment domain max-age path secure version) #:mutable)
|
||||||
|
(define-struct (cookie-error exn:fail) ())
|
||||||
|
|
||||||
;; error* : string args ... -> raises a cookie-error exception
|
;; error* : string args ... -> raises a cookie-error exception
|
||||||
;; constructs a cookie-error struct from the given error message
|
;; constructs a cookie-error struct from the given error message
|
||||||
;; (added to fix exceptions-must-take-immutable-strings bug)
|
;; (added to fix exceptions-must-take-immutable-strings bug)
|
||||||
(define (error* fmt . args)
|
(define (error* fmt . args)
|
||||||
(raise (make-cookie-error (apply format fmt args)
|
(raise (make-cookie-error (apply format fmt args)
|
||||||
(current-continuation-marks))))
|
(current-continuation-marks))))
|
||||||
|
|
||||||
;; The syntax for the Set-Cookie response header is
|
;; The syntax for the Set-Cookie response header is
|
||||||
;; set-cookie = "Set-Cookie:" cookies
|
;; set-cookie = "Set-Cookie:" cookies
|
||||||
;; cookies = 1#cookie
|
;; cookies = 1#cookie
|
||||||
;; cookie = NAME "=" VALUE *(";" cookie-av)
|
;; cookie = NAME "=" VALUE *(";" cookie-av)
|
||||||
;; NAME = attr
|
;; NAME = attr
|
||||||
;; VALUE = value
|
;; VALUE = value
|
||||||
;; cookie-av = "Comment" "=" value
|
;; cookie-av = "Comment" "=" value
|
||||||
;; | "Domain" "=" value
|
;; | "Domain" "=" value
|
||||||
;; | "Max-Age" "=" value
|
;; | "Max-Age" "=" value
|
||||||
;; | "Path" "=" value
|
;; | "Path" "=" value
|
||||||
;; | "Secure"
|
;; | "Secure"
|
||||||
;; | "Version" "=" 1*DIGIT
|
;; | "Version" "=" 1*DIGIT
|
||||||
(define (set-cookie name pre-value)
|
(define (set-cookie name pre-value)
|
||||||
(let ([value (to-rfc2109:value pre-value)])
|
(let ([value (to-rfc2109:value pre-value)])
|
||||||
(unless (rfc2068:token? name)
|
(unless (rfc2068:token? name)
|
||||||
(error* "invalid cookie name: ~a / ~a" name value))
|
(error* "invalid cookie name: ~a / ~a" name value))
|
||||||
|
|
@ -94,36 +91,36 @@
|
||||||
#f ; default version
|
#f ; default version
|
||||||
)))
|
)))
|
||||||
|
|
||||||
;;!
|
;;!
|
||||||
;;
|
;;
|
||||||
;; (function (print-cookie cookie))
|
;; (function (print-cookie cookie))
|
||||||
;;
|
;;
|
||||||
;; (param cookie Cookie-structure "The cookie to return as a string")
|
;; (param cookie Cookie-structure "The cookie to return as a string")
|
||||||
;;
|
;;
|
||||||
;; Formats the cookie contents in a string ready to be appended to a
|
;; Formats the cookie contents in a string ready to be appended to a
|
||||||
;; "Set-Cookie: " header, and sent to a client (browser).
|
;; "Set-Cookie: " header, and sent to a client (browser).
|
||||||
(define (print-cookie cookie)
|
(define (print-cookie cookie)
|
||||||
(unless (cookie? cookie)
|
(define (format-if fmt val) (and val (format fmt val)))
|
||||||
(error* "cookie expected, received: ~a" cookie))
|
(unless (cookie? cookie) (error* "cookie expected, received: ~a" cookie))
|
||||||
(string-join
|
(string-join
|
||||||
(filter (lambda (s) (not (string-null? s)))
|
(filter values
|
||||||
(list (format "~a=~a" (cookie-name cookie) (cookie-value cookie))
|
(list (format "~a=~a" (cookie-name cookie) (cookie-value cookie))
|
||||||
(let ([c (cookie-comment cookie)]) (if c (format "Comment=~a" c) ""))
|
(format-if "Comment=~a" (cookie-comment cookie))
|
||||||
(let ([d (cookie-domain cookie)]) (if d (format "Domain=~a" d) ""))
|
(format-if "Domain=~a" (cookie-domain cookie))
|
||||||
(let ([age (cookie-max-age cookie)]) (if age (format "Max-Age=~a" age) ""))
|
(format-if "Max-Age=~a" (cookie-max-age cookie))
|
||||||
(let ([p (cookie-path cookie)]) (if p (format "Path=~a" p) ""))
|
(format-if "Path=~a" (cookie-path cookie))
|
||||||
(let ([s (cookie-secure cookie)]) (if s "Secure" ""))
|
(and (cookie-secure cookie) "Secure")
|
||||||
(let ([v (cookie-version cookie)]) (format "Version=~a" (if v v 1)))))
|
(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)])
|
(let ([comment (to-rfc2109:value pre-comment)])
|
||||||
(unless (cookie? cookie)
|
(unless (cookie? cookie)
|
||||||
(error* "cookie expected, received: ~a" cookie))
|
(error* "cookie expected, received: ~a" cookie))
|
||||||
(set-cookie-comment! cookie comment)
|
(set-cookie-comment! cookie comment)
|
||||||
cookie))
|
cookie))
|
||||||
|
|
||||||
(define (cookie:add-domain cookie domain)
|
(define (cookie:add-domain cookie domain)
|
||||||
(unless (valid-domain? domain)
|
(unless (valid-domain? domain)
|
||||||
(error* "invalid domain: ~a" domain))
|
(error* "invalid domain: ~a" domain))
|
||||||
(unless (cookie? cookie)
|
(unless (cookie? cookie)
|
||||||
|
|
@ -131,7 +128,7 @@
|
||||||
(set-cookie-domain! cookie domain)
|
(set-cookie-domain! cookie domain)
|
||||||
cookie)
|
cookie)
|
||||||
|
|
||||||
(define (cookie:add-max-age cookie seconds)
|
(define (cookie:add-max-age cookie seconds)
|
||||||
(unless (and (integer? seconds) (not (negative? seconds)))
|
(unless (and (integer? seconds) (not (negative? seconds)))
|
||||||
(error* "invalid Max-Age for cookie: ~a" seconds))
|
(error* "invalid Max-Age for cookie: ~a" seconds))
|
||||||
(unless (cookie? cookie)
|
(unless (cookie? cookie)
|
||||||
|
|
@ -139,14 +136,14 @@
|
||||||
(set-cookie-max-age! cookie seconds)
|
(set-cookie-max-age! cookie seconds)
|
||||||
cookie)
|
cookie)
|
||||||
|
|
||||||
(define (cookie:add-path cookie pre-path)
|
(define (cookie:add-path cookie pre-path)
|
||||||
(let ([path (to-rfc2109:value pre-path)])
|
(let ([path (to-rfc2109:value pre-path)])
|
||||||
(unless (cookie? cookie)
|
(unless (cookie? cookie)
|
||||||
(error* "cookie expected, received: ~a" cookie))
|
(error* "cookie expected, received: ~a" cookie))
|
||||||
(set-cookie-path! cookie path)
|
(set-cookie-path! cookie path)
|
||||||
cookie))
|
cookie))
|
||||||
|
|
||||||
(define (cookie:secure cookie secure?)
|
(define (cookie:secure cookie secure?)
|
||||||
(unless (boolean? secure?)
|
(unless (boolean? secure?)
|
||||||
(error* "invalid argument (boolean expected), received: ~a" secure?))
|
(error* "invalid argument (boolean expected), received: ~a" secure?))
|
||||||
(unless (cookie? cookie)
|
(unless (cookie? cookie)
|
||||||
|
|
@ -154,7 +151,7 @@
|
||||||
(set-cookie-secure! cookie secure?)
|
(set-cookie-secure! cookie secure?)
|
||||||
cookie)
|
cookie)
|
||||||
|
|
||||||
(define (cookie:version cookie version)
|
(define (cookie:version cookie version)
|
||||||
(unless (integer? version)
|
(unless (integer? version)
|
||||||
(error* "unsupported version: ~a" version))
|
(error* "unsupported version: ~a" version))
|
||||||
(unless (cookie? cookie)
|
(unless (cookie? cookie)
|
||||||
|
|
@ -163,21 +160,21 @@
|
||||||
cookie)
|
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 "=")))
|
(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 ";")))
|
(char-set-difference char-set:full (string->char-set ";")))
|
||||||
|
|
||||||
;;!
|
;;!
|
||||||
;;
|
;;
|
||||||
;; (function (get-all-results name cookies))
|
;; (function (get-all-results name cookies))
|
||||||
;;
|
;;
|
||||||
;; Auxiliar procedure that returns all values associated with
|
;; Auxiliar procedure that returns all values associated with
|
||||||
;; `name' in the association list (cookies).
|
;; `name' in the association list (cookies).
|
||||||
(define (get-all-results name cookies)
|
(define (get-all-results name cookies)
|
||||||
(let loop ([c cookies])
|
(let loop ([c cookies])
|
||||||
(if (null? c)
|
(if (null? c)
|
||||||
'()
|
'()
|
||||||
|
|
@ -187,94 +184,93 @@
|
||||||
(cons (cadr pair) (loop (cdr c)))
|
(cons (cadr pair) (loop (cdr c)))
|
||||||
(loop (cdr c)))))))
|
(loop (cdr c)))))))
|
||||||
|
|
||||||
;; which typically looks like:
|
;; which typically looks like:
|
||||||
;; (cookie . "test5=\"5\"; test1=\"1\"; test0=\"0\"; test1=\"20\"")
|
;; (cookie . "test5=\"5\"; test1=\"1\"; test0=\"0\"; test1=\"20\"")
|
||||||
;; note that it can be multi-valued: `test1' has values: "1", and "20". Of
|
;; 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".
|
;; course, in the same spirit, we only receive the "string content".
|
||||||
(define (get-cookie name cookies)
|
(define (get-cookie name cookies)
|
||||||
(let ([cookies (map (lambda (p)
|
(let ([cookies (map (lambda (p)
|
||||||
(map string-trim-both
|
(map string-trim-both
|
||||||
(string-tokenize p char-set:all-but=)))
|
(string-tokenize p char-set:all-but=)))
|
||||||
(string-tokenize cookies char-set:all-but-semicolon))])
|
(string-tokenize cookies char-set:all-but-semicolon))])
|
||||||
(get-all-results name cookies)))
|
(get-all-results name cookies)))
|
||||||
|
|
||||||
;;!
|
;;!
|
||||||
;;
|
;;
|
||||||
;; (function (get-cookie/single name cookies))
|
;; (function (get-cookie/single name cookies))
|
||||||
;;
|
;;
|
||||||
;; (param name String "The name of the cookie we are looking for")
|
;; (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.")
|
;; (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.
|
;; Returns the first name associated with the cookie named `name', if any, or #f.
|
||||||
(define (get-cookie/single name cookies)
|
(define (get-cookie/single name cookies)
|
||||||
(let ([cookies (get-cookie name cookies)])
|
(let ([cookies (get-cookie name cookies)])
|
||||||
(and (not (null? cookies)) (car cookies))))
|
(and (not (null? cookies)) (car cookies))))
|
||||||
|
|
||||||
|
|
||||||
;;;;;
|
;;;;;
|
||||||
;; Auxiliary procedures
|
;; Auxiliary procedures
|
||||||
;;;;;
|
;;;;;
|
||||||
|
|
||||||
;; token = 1*<any CHAR except CTLs or tspecials>
|
;; token = 1*<any CHAR except CTLs or tspecials>
|
||||||
;;
|
;;
|
||||||
;; tspecials = "(" | ")" | "<" | ">" | "@"
|
;; tspecials = "(" | ")" | "<" | ">" | "@"
|
||||||
;; | "," | ";" | ":" | "\" | <">
|
;; | "," | ";" | ":" | "\" | <">
|
||||||
;; | "/" | "[" | "]" | "?" | "="
|
;; | "/" | "[" | "]" | "?" | "="
|
||||||
;; | "{" | "}" | SP | HT
|
;; | "{" | "}" | SP | HT
|
||||||
(define char-set:tspecials
|
(define char-set:tspecials
|
||||||
(char-set-union (string->char-set "()<>@,;:\\\"/[]?={}")
|
(char-set-union (string->char-set "()<>@,;:\\\"/[]?={}")
|
||||||
char-set:whitespace
|
char-set:whitespace
|
||||||
(char-set #\tab)))
|
(char-set #\tab)))
|
||||||
|
|
||||||
(define char-set:control
|
(define char-set:control
|
||||||
(char-set-union char-set:iso-control
|
(char-set-union char-set:iso-control
|
||||||
(char-set (integer->char 127))));; DEL
|
(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))
|
(char-set-difference char-set:ascii char-set:tspecials char-set:control))
|
||||||
|
|
||||||
;; token? : string -> boolean
|
;; token? : string -> boolean
|
||||||
;;
|
;;
|
||||||
;; returns #t if s is an RFC 2068 token (see definition above), #f otherwise.
|
;; returns #t if s is an RFC 2068 token (see definition above), #f otherwise.
|
||||||
(define (rfc2068:token? s)
|
(define (rfc2068:token? s)
|
||||||
(string-every char-set:token s))
|
(string-every char-set:token s))
|
||||||
|
|
||||||
;;!
|
;;!
|
||||||
;;
|
;;
|
||||||
;; (function (quoted-string? s))
|
;; (function (quoted-string? s))
|
||||||
;;
|
;;
|
||||||
;; (param s String "The string to check")
|
;; (param s String "The string to check")
|
||||||
;;
|
;;
|
||||||
;; Returns s if the string is an RFC 2068 quoted-string, #f otherwise. As in:
|
;; Returns s if the string is an RFC 2068 quoted-string, #f otherwise. As in:
|
||||||
;; quoted-string = ( <"> *(qdtext) <"> )
|
;; quoted-string = ( <"> *(qdtext) <"> )
|
||||||
;; qdtext = <any TEXT except <">>
|
;; qdtext = <any TEXT except <">>
|
||||||
;;
|
;;
|
||||||
;; The backslash character ("\") may be used as a single-character quoting
|
;; The backslash character ("\") may be used as a single-character quoting
|
||||||
;; mechanism only within quoted-string and comment constructs.
|
;; mechanism only within quoted-string and comment constructs.
|
||||||
;;
|
;;
|
||||||
;; quoted-pair = "\" CHAR
|
;; quoted-pair = "\" CHAR
|
||||||
;;
|
;;
|
||||||
;; implementation note: I have chosen to use a regular expression rather than
|
;; implementation note: I have chosen to use a regular expression rather than
|
||||||
;; a character set for this definition because of two dependencies: CRLF must
|
;; a character set for this definition because of two dependencies: CRLF must
|
||||||
;; appear as a block to be legal, and " may only appear as \"
|
;; appear as a block to be legal, and " may only appear as \"
|
||||||
(define (rfc2068:quoted-string? s)
|
(define (rfc2068:quoted-string? s)
|
||||||
(if (regexp-match
|
(and (regexp-match?
|
||||||
#rx"^\"([^\"#\u0000-#\u001F]| |#\return#\newline|#\tab|\\\\\")*\"$"
|
#rx"^\"([^\"#\u0000-#\u001F]| |#\return#\newline|#\tab|\\\\\")*\"$"
|
||||||
s)
|
s)
|
||||||
s
|
s))
|
||||||
#f))
|
|
||||||
|
|
||||||
;; value: token | quoted-string
|
;; value: token | quoted-string
|
||||||
(define (rfc2109:value? s)
|
(define (rfc2109:value? s)
|
||||||
(or (rfc2068:token? s) (rfc2068:quoted-string? s)))
|
(or (rfc2068:token? s) (rfc2068:quoted-string? s)))
|
||||||
|
|
||||||
;; convert-to-quoted : string -> quoted-string?
|
;; convert-to-quoted : string -> quoted-string?
|
||||||
;; takes the given string as a particular message, and converts the given
|
;; takes the given string as a particular message, and converts the given
|
||||||
;; string to that representatation
|
;; string to that representatation
|
||||||
(define (convert-to-quoted str)
|
(define (convert-to-quoted str)
|
||||||
(string-append "\"" (regexp-replace* #rx"\"" str "\\\\\"") "\""))
|
(string-append "\"" (regexp-replace* #rx"\"" str "\\\\\"") "\""))
|
||||||
|
|
||||||
;; string -> rfc2109:value?
|
;; string -> rfc2109:value?
|
||||||
(define (to-rfc2109:value s)
|
(define (to-rfc2109:value s)
|
||||||
(cond
|
(cond
|
||||||
[(not (string? s))
|
[(not (string? s))
|
||||||
(error* "expected string, given: ~e" s)]
|
(error* "expected string, given: ~e" s)]
|
||||||
|
|
@ -290,39 +286,38 @@
|
||||||
[else
|
[else
|
||||||
(error* "could not convert the given string to an acceptable RFC 2109 value: ~s" s)]))
|
(error* "could not convert the given string to an acceptable RFC 2109 value: ~s" s)]))
|
||||||
|
|
||||||
;;!
|
;;!
|
||||||
;;
|
;;
|
||||||
;; (function (cookie-string? s))
|
;; (function (cookie-string? s))
|
||||||
;;
|
;;
|
||||||
;; (param s String "String to check")
|
;; (param s String "String to check")
|
||||||
;;
|
;;
|
||||||
;; Returns whether this is a valid string to use as the value or the
|
;; Returns whether this is a valid string to use as the value or the
|
||||||
;; name (depending on value?) of an HTTP cookie.
|
;; name (depending on value?) of an HTTP cookie.
|
||||||
(define cookie-string?
|
(define (cookie-string? s [value? #t])
|
||||||
(opt-lambda (s (value? #t))
|
|
||||||
(unless (string? s)
|
(unless (string? s)
|
||||||
(error* "string expected, received: ~a" s))
|
(error* "string expected, received: ~a" s))
|
||||||
(if value?
|
(if value?
|
||||||
(rfc2109:value? s)
|
(rfc2109:value? s)
|
||||||
;; name: token
|
;; name: token
|
||||||
(rfc2068:token? s))))
|
(rfc2068:token? s)))
|
||||||
|
|
||||||
;; Host names as per RFC 1123 and RFC952, more or less, anyway. :-)
|
;; Host names as per RFC 1123 and RFC952, more or less, anyway. :-)
|
||||||
(define char-set:hostname
|
(define char-set:hostname
|
||||||
(let ([a-z-lowercase (ucs-range->char-set #x61 #x7B)]
|
(let ([a-z-lowercase (ucs-range->char-set #x61 #x7B)]
|
||||||
[a-z-uppercase (ucs-range->char-set #x41 #x5B)])
|
[a-z-uppercase (ucs-range->char-set #x41 #x5B)])
|
||||||
(char-set-adjoin!
|
(char-set-adjoin!
|
||||||
(char-set-union char-set:digit a-z-lowercase a-z-uppercase)
|
(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 (.)
|
(and ;; Domain must start with a dot (.)
|
||||||
(string=? (string-take dom 1) ".")
|
(string=? (string-take dom 1) ".")
|
||||||
;; The rest are tokens-like strings separated by dots
|
;; The rest are tokens-like strings separated by dots
|
||||||
(string-every char-set:hostname dom)
|
(string-every char-set:hostname dom)
|
||||||
(<= (string-length dom) 76)))
|
(<= (string-length dom) 76)))
|
||||||
|
|
||||||
(define (valid-path? v)
|
(define (valid-path? v)
|
||||||
(and (string? v) (rfc2109:value? v)))
|
(and (string? v) (rfc2109:value? v)))
|
||||||
|
|
||||||
;;; cookie-unit.ss ends here
|
;;; cookie-unit.ss ends here
|
||||||
|
|
|
||||||
|
|
@ -1,15 +1,14 @@
|
||||||
#lang scheme/unit
|
#lang scheme/unit
|
||||||
|
|
||||||
(require mzlib/list mzlib/process "dns-sig.ss"
|
(require "dns-sig.ss" scheme/system scheme/udp)
|
||||||
scheme/udp)
|
|
||||||
|
|
||||||
(import)
|
(import)
|
||||||
(export dns^)
|
(export dns^)
|
||||||
|
|
||||||
;; UDP retry timeout:
|
;; UDP retry timeout:
|
||||||
(define INIT-TIMEOUT 50)
|
(define INIT-TIMEOUT 50)
|
||||||
|
|
||||||
(define types
|
(define types
|
||||||
'((a 1)
|
'((a 1)
|
||||||
(ns 2)
|
(ns 2)
|
||||||
(md 3)
|
(md 3)
|
||||||
|
|
@ -27,40 +26,39 @@
|
||||||
(mx 15)
|
(mx 15)
|
||||||
(txt 16)))
|
(txt 16)))
|
||||||
|
|
||||||
(define classes
|
(define classes
|
||||||
'((in 1)
|
'((in 1)
|
||||||
(cs 2)
|
(cs 2)
|
||||||
(ch 3)
|
(ch 3)
|
||||||
(hs 4)))
|
(hs 4)))
|
||||||
|
|
||||||
(define (cossa i l)
|
(define (cossa i l)
|
||||||
(cond [(null? l) #f]
|
(cond [(null? l) #f]
|
||||||
[(equal? (cadar l) i) (car l)]
|
[(equal? (cadar l) i) (car l)]
|
||||||
[else (cossa i (cdr l))]))
|
[else (cossa i (cdr l))]))
|
||||||
|
|
||||||
(define (number->octet-pair n)
|
(define (number->octet-pair n)
|
||||||
(list (arithmetic-shift n -8)
|
(list (arithmetic-shift n -8)
|
||||||
(modulo n 256)))
|
(modulo n 256)))
|
||||||
|
|
||||||
(define (octet-pair->number a b)
|
(define (octet-pair->number a b)
|
||||||
(+ (arithmetic-shift a 8) 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 a 24)
|
||||||
(arithmetic-shift b 16)
|
(arithmetic-shift b 16)
|
||||||
(arithmetic-shift c 8)
|
(arithmetic-shift c 8)
|
||||||
d))
|
d))
|
||||||
|
|
||||||
(define (name->octets s)
|
(define (name->octets s)
|
||||||
(let ([do-one (lambda (s)
|
(let ([do-one (lambda (s) (cons (bytes-length s) (bytes->list s)))])
|
||||||
(cons (bytes-length s) (bytes->list s)))])
|
|
||||||
(let loop ([s s])
|
(let loop ([s s])
|
||||||
(let ([m (regexp-match #rx#"^([^.]*)[.](.*)" s)])
|
(let ([m (regexp-match #rx#"^([^.]*)[.](.*)" s)])
|
||||||
(if m
|
(if m
|
||||||
(append (do-one (cadr m)) (loop (caddr m)))
|
(append (do-one (cadr m)) (loop (caddr m)))
|
||||||
(append (do-one s) (list 0)))))))
|
(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)
|
(append (number->octet-pair id)
|
||||||
(list 1 0) ; Opcode & flags (recusive flag set)
|
(list 1 0) ; Opcode & flags (recusive flag set)
|
||||||
(number->octet-pair question-count)
|
(number->octet-pair question-count)
|
||||||
|
|
@ -68,25 +66,25 @@
|
||||||
(number->octet-pair 0)
|
(number->octet-pair 0)
|
||||||
(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)
|
(append (make-std-query-header id 1)
|
||||||
(name->octets name)
|
(name->octets name)
|
||||||
(number->octet-pair (cadr (assoc type types)))
|
(number->octet-pair (cadr (assoc type types)))
|
||||||
(number->octet-pair (cadr (assoc class classes)))))
|
(number->octet-pair (cadr (assoc class classes)))))
|
||||||
|
|
||||||
(define (add-size-tag m)
|
(define (add-size-tag m)
|
||||||
(append (number->octet-pair (length m)) m))
|
(append (number->octet-pair (length m)) m))
|
||||||
|
|
||||||
(define (rr-data rr)
|
(define (rr-data rr)
|
||||||
(cadddr (cdr rr)))
|
(cadddr (cdr rr)))
|
||||||
|
|
||||||
(define (rr-type rr)
|
(define (rr-type rr)
|
||||||
(cadr rr))
|
(cadr rr))
|
||||||
|
|
||||||
(define (rr-name rr)
|
(define (rr-name rr)
|
||||||
(car rr))
|
(car rr))
|
||||||
|
|
||||||
(define (parse-name start reply)
|
(define (parse-name start reply)
|
||||||
(let ([v (car start)])
|
(let ([v (car start)])
|
||||||
(cond
|
(cond
|
||||||
[(zero? v)
|
[(zero? v)
|
||||||
|
|
@ -95,13 +93,12 @@
|
||||||
[(zero? (bitwise-and #xc0 v))
|
[(zero? (bitwise-and #xc0 v))
|
||||||
;; Normal label
|
;; Normal label
|
||||||
(let loop ([len v][start (cdr start)][accum null])
|
(let loop ([len v][start (cdr start)][accum null])
|
||||||
(cond
|
(if (zero? len)
|
||||||
[(zero? len)
|
|
||||||
(let-values ([(s start) (parse-name start reply)])
|
(let-values ([(s start) (parse-name start reply)])
|
||||||
(let ([s0 (list->bytes (reverse accum))])
|
(let ([s0 (list->bytes (reverse accum))])
|
||||||
(values (if s (bytes-append s0 #"." s) s0)
|
(values (if s (bytes-append s0 #"." s) s0)
|
||||||
start)))]
|
start)))
|
||||||
[else (loop (sub1 len) (cdr start) (cons (car start) accum))]))]
|
(loop (sub1 len) (cdr start) (cons (car start) accum))))]
|
||||||
[else
|
[else
|
||||||
;; Compression offset
|
;; Compression offset
|
||||||
(let ([offset (+ (arithmetic-shift (bitwise-and #x3f v) 8)
|
(let ([offset (+ (arithmetic-shift (bitwise-and #x3f v) 8)
|
||||||
|
|
@ -110,7 +107,7 @@
|
||||||
(parse-name (list-tail reply offset) reply)])
|
(parse-name (list-tail reply offset) reply)])
|
||||||
(values s (cddr start))))])))
|
(values s (cddr start))))])))
|
||||||
|
|
||||||
(define (parse-rr start reply)
|
(define (parse-rr start reply)
|
||||||
(let-values ([(name start) (parse-name start reply)])
|
(let-values ([(name start) (parse-name start reply)])
|
||||||
(let* ([type (car (cossa (octet-pair->number (car start) (cadr start))
|
(let* ([type (car (cossa (octet-pair->number (car start) (cadr start))
|
||||||
types))]
|
types))]
|
||||||
|
|
@ -133,7 +130,7 @@
|
||||||
start)
|
start)
|
||||||
(loop (sub1 len) (cdr start) (cons (car start) accum)))))))
|
(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-values ([(name start) (parse-name start reply)])
|
||||||
(let* ([type (car (cossa (octet-pair->number (car start) (cadr start))
|
(let* ([type (car (cossa (octet-pair->number (car start) (cadr start))
|
||||||
types))]
|
types))]
|
||||||
|
|
@ -144,14 +141,14 @@
|
||||||
[start (cddr start)])
|
[start (cddr start)])
|
||||||
(values (list name type class) 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])
|
(let loop ([n n][start start][accum null])
|
||||||
(if (zero? n)
|
(if (zero? n)
|
||||||
(values (reverse accum) start)
|
(values (reverse accum) start)
|
||||||
(let-values ([(rr start) (parse start reply)])
|
(let-values ([(rr start) (parse start reply)])
|
||||||
(loop (sub1 n) start (cons rr accum))))))
|
(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)
|
(unless (assoc type types)
|
||||||
(raise-type-error 'dns-query "DNS query type" type))
|
(raise-type-error 'dns-query "DNS query type" type))
|
||||||
(unless (assoc class classes)
|
(unless (assoc class classes)
|
||||||
|
|
@ -167,12 +164,10 @@
|
||||||
(let ([s (make-bytes 512)])
|
(let ([s (make-bytes 512)])
|
||||||
(let retry ([timeout INIT-TIMEOUT])
|
(let retry ([timeout INIT-TIMEOUT])
|
||||||
(udp-send-to udp nameserver 53 (list->bytes query))
|
(udp-send-to udp nameserver 53 (list->bytes query))
|
||||||
(sync (handle-evt
|
(sync (handle-evt (udp-receive!-evt udp s)
|
||||||
(udp-receive!-evt udp s)
|
|
||||||
(lambda (r)
|
(lambda (r)
|
||||||
(bytes->list (subbytes s 0 (car r)))))
|
(bytes->list (subbytes s 0 (car r)))))
|
||||||
(handle-evt
|
(handle-evt (alarm-evt (+ (current-inexact-milliseconds)
|
||||||
(alarm-evt (+ (current-inexact-milliseconds)
|
|
||||||
timeout))
|
timeout))
|
||||||
(lambda (v)
|
(lambda (v)
|
||||||
(retry (* timeout 2))))))))
|
(retry (* timeout 2))))))))
|
||||||
|
|
@ -211,21 +206,22 @@
|
||||||
(values (positive? (bitwise-and #x4 v0))
|
(values (positive? (bitwise-and #x4 v0))
|
||||||
qds ans nss ars reply)))))))
|
qds ans nss ars reply)))))))
|
||||||
|
|
||||||
(define cache (make-hasheq))
|
(define cache (make-hasheq))
|
||||||
(define (dns-query/cache nameserver addr type class)
|
(define (dns-query/cache nameserver addr type class)
|
||||||
(let ([key (string->symbol (format "~a;~a;~a;~a" 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))])
|
(let ([v (hash-ref cache key (lambda () #f))])
|
||||||
(if v
|
(if v
|
||||||
(apply values 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))
|
(hash-set! cache key (list auth? qds ans nss ars reply))
|
||||||
(values 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"
|
(format "~a.~a.~a.~a"
|
||||||
(list-ref s 0) (list-ref s 1) (list-ref s 2) (list-ref s 3)))
|
(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)])
|
(let loop ([nameserver nameserver][tried (list nameserver)])
|
||||||
;; Normally the recusion is done for us, but it's technically optional
|
;; Normally the recusion is done for us, but it's technically optional
|
||||||
(let-values ([(v ars auth?) (k nameserver)])
|
(let-values ([(v ars auth?) (k nameserver)])
|
||||||
|
|
@ -239,7 +235,7 @@
|
||||||
(not (member ns tried))
|
(not (member ns tried))
|
||||||
(loop ns (cons 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]+)$"
|
(let ([result (regexp-match #rx"^([0-9]+)\\.([0-9]+)\\.([0-9]+)\\.([0-9]+)$"
|
||||||
ip)])
|
ip)])
|
||||||
(format "~a.~a.~a.~a.in-addr.arpa"
|
(format "~a.~a.~a.~a.in-addr.arpa"
|
||||||
|
|
@ -248,11 +244,10 @@
|
||||||
(list-ref result 2)
|
(list-ref result 2)
|
||||||
(list-ref result 1))))
|
(list-ref result 1))))
|
||||||
|
|
||||||
(define (get-ptr-list-from-ans ans)
|
(define (get-ptr-list-from-ans ans)
|
||||||
(filter (lambda (ans-entry) (eq? (list-ref ans-entry 1) 'ptr))
|
(filter (lambda (ans-entry) (eq? (list-ref ans-entry 1) 'ptr)) ans))
|
||||||
ans))
|
|
||||||
|
|
||||||
(define (dns-get-name nameserver ip)
|
(define (dns-get-name nameserver ip)
|
||||||
(or (try-forwarding
|
(or (try-forwarding
|
||||||
(lambda (nameserver)
|
(lambda (nameserver)
|
||||||
(let-values ([(auth? qds ans nss ars reply)
|
(let-values ([(auth? qds ans nss ars reply)
|
||||||
|
|
@ -265,11 +260,11 @@
|
||||||
nameserver)
|
nameserver)
|
||||||
(error 'dns-get-name "bad ip address")))
|
(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))
|
(filter (lambda (ans-entry) (eq? (list-ref ans-entry 1) 'a))
|
||||||
ans))
|
ans))
|
||||||
|
|
||||||
(define (dns-get-address nameserver addr)
|
(define (dns-get-address nameserver addr)
|
||||||
(or (try-forwarding
|
(or (try-forwarding
|
||||||
(lambda (nameserver)
|
(lambda (nameserver)
|
||||||
(let-values ([(auth? qds ans nss ars reply) (dns-query/cache nameserver addr 'a 'in)])
|
(let-values ([(auth? qds ans nss ars reply) (dns-query/cache nameserver addr 'a 'in)])
|
||||||
|
|
@ -280,7 +275,7 @@
|
||||||
nameserver)
|
nameserver)
|
||||||
(error 'dns-get-address "bad address")))
|
(error 'dns-get-address "bad address")))
|
||||||
|
|
||||||
(define (dns-get-mail-exchanger nameserver addr)
|
(define (dns-get-mail-exchanger nameserver addr)
|
||||||
(or (try-forwarding
|
(or (try-forwarding
|
||||||
(lambda (nameserver)
|
(lambda (nameserver)
|
||||||
(let-values ([(auth? qds ans nss ars reply) (dns-query/cache nameserver addr 'mx 'in)])
|
(let-values ([(auth? qds ans nss ars reply) (dns-query/cache nameserver addr 'mx 'in)])
|
||||||
|
|
@ -303,7 +298,7 @@
|
||||||
nameserver)
|
nameserver)
|
||||||
(error 'dns-get-mail-exchanger "bad address")))
|
(error 'dns-get-mail-exchanger "bad address")))
|
||||||
|
|
||||||
(define (dns-find-nameserver)
|
(define (dns-find-nameserver)
|
||||||
(case (system-type)
|
(case (system-type)
|
||||||
[(unix macosx)
|
[(unix macosx)
|
||||||
(with-handlers ([void (lambda (x) #f)])
|
(with-handlers ([void (lambda (x) #f)])
|
||||||
|
|
@ -327,19 +322,17 @@
|
||||||
(process/ports
|
(process/ports
|
||||||
#f (open-input-file "NUL") (current-error-port)
|
#f (open-input-file "NUL") (current-error-port)
|
||||||
nslookup))])
|
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)])
|
(let ([line (read-line pin 'any)])
|
||||||
(cond [(eof-object? line)
|
(cond [(eof-object? line)
|
||||||
(close-input-port pin)
|
(close-input-port pin)
|
||||||
(proc 'wait)
|
(proc 'wait)
|
||||||
(or ip name)]
|
(or ip name)]
|
||||||
[(and (not name)
|
[(and (not name)
|
||||||
(regexp-match #rx"^Default Server: +(.*)$"
|
(regexp-match #rx"^Default Server: +(.*)$" line))
|
||||||
line))
|
|
||||||
=> (lambda (m) (loop (cadr m) #f #t))]
|
=> (lambda (m) (loop (cadr m) #f #t))]
|
||||||
[(and try-ip?
|
[(and try-ip?
|
||||||
(regexp-match #rx"^Address: +(.*)$"
|
(regexp-match #rx"^Address: +(.*)$" line))
|
||||||
line))
|
|
||||||
=> (lambda (m) (loop name (cadr m) #f))]
|
=> (lambda (m) (loop name (cadr m) #f))]
|
||||||
[else (loop name ip #f)]))))))]
|
[else (loop name ip #f)]))))))]
|
||||||
[else #f]))
|
[else #f]))
|
||||||
|
|
|
||||||
|
|
@ -1,30 +1,30 @@
|
||||||
#lang scheme/unit
|
#lang scheme/unit
|
||||||
|
|
||||||
(require mzlib/date mzlib/string "head-sig.ss")
|
(require mzlib/date mzlib/string "head-sig.ss")
|
||||||
|
|
||||||
(import)
|
(import)
|
||||||
(export head^)
|
(export head^)
|
||||||
|
|
||||||
;; NB: I've done a copied-code adaptation of a number of these definitions
|
;; NB: I've done a copied-code adaptation of a number of these definitions
|
||||||
;; into "bytes-compatible" versions. Finishing the rest will require some
|
;; into "bytes-compatible" versions. Finishing the rest will require some
|
||||||
;; kind of interface decision---that is, when you don't supply a header,
|
;; kind of interface decision---that is, when you don't supply a header,
|
||||||
;; should the resulting operation be string-centric or bytes-centric?
|
;; should the resulting operation be string-centric or bytes-centric?
|
||||||
;; Easiest just to stop here.
|
;; Easiest just to stop here.
|
||||||
;; -- JBC 2006-07-31
|
;; -- JBC 2006-07-31
|
||||||
|
|
||||||
(define CRLF (string #\return #\newline))
|
(define CRLF (string #\return #\newline))
|
||||||
(define CRLF/bytes #"\r\n")
|
(define CRLF/bytes #"\r\n")
|
||||||
|
|
||||||
(define empty-header CRLF)
|
(define empty-header CRLF)
|
||||||
(define empty-header/bytes CRLF/bytes)
|
(define empty-header/bytes CRLF/bytes)
|
||||||
|
|
||||||
(define re:field-start (regexp "^[^ \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:field-start/bytes #rx#"^[^ \t\n\r\v:\001-\032\"]*:")
|
||||||
|
|
||||||
(define re:continue (regexp "^[ \t\v]"))
|
(define re:continue (regexp "^[ \t\v]"))
|
||||||
(define re:continue/bytes #rx#"^[ \t\v]")
|
(define re:continue/bytes #rx#"^[ \t\v]")
|
||||||
|
|
||||||
(define (validate-header s)
|
(define (validate-header s)
|
||||||
(if (bytes? s)
|
(if (bytes? s)
|
||||||
;; legal char check not needed per rfc 2822, IIUC.
|
;; legal char check not needed per rfc 2822, IIUC.
|
||||||
(let ([len (bytes-length s)])
|
(let ([len (bytes-length s)])
|
||||||
|
|
@ -63,13 +63,13 @@
|
||||||
[else (error 'validate-header "ill-formed header at ~s"
|
[else (error 'validate-header "ill-formed header at ~s"
|
||||||
(substring s offset (string-length 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))))
|
(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) #": *)")))
|
(byte-regexp (bytes-append #"(^|[\r][\n])("(regexp-quote field #f) #": *)")))
|
||||||
|
|
||||||
(define (extract-field field header)
|
(define (extract-field field header)
|
||||||
(if (bytes? header)
|
(if (bytes? header)
|
||||||
(let ([m (regexp-match-positions (make-field-start-regexp/bytes field)
|
(let ([m (regexp-match-positions (make-field-start-regexp/bytes field)
|
||||||
header)])
|
header)])
|
||||||
|
|
@ -95,8 +95,7 @@
|
||||||
;; Rest of header is this field, but strip trailing CRLFCRLF:
|
;; Rest of header is this field, but strip trailing CRLFCRLF:
|
||||||
(regexp-replace #rx"\r\n\r\n$" s ""))))))))
|
(regexp-replace #rx"\r\n\r\n$" s ""))))))))
|
||||||
|
|
||||||
|
(define (replace-field field data header)
|
||||||
(define (replace-field field data header)
|
|
||||||
(if (bytes? header)
|
(if (bytes? header)
|
||||||
(let ([m (regexp-match-positions (make-field-start-regexp/bytes field)
|
(let ([m (regexp-match-positions (make-field-start-regexp/bytes field)
|
||||||
header)])
|
header)])
|
||||||
|
|
@ -108,8 +107,7 @@
|
||||||
(bytes-append pre (if data (insert-field field data rest) rest)))
|
(bytes-append pre (if data (insert-field field data rest) rest)))
|
||||||
(if data (insert-field field data header) header)))
|
(if data (insert-field field data header) header)))
|
||||||
;; otherwise header & field & data should be strings:
|
;; otherwise header & field & data should be strings:
|
||||||
(let ([m (regexp-match-positions (make-field-start-regexp field)
|
(let ([m (regexp-match-positions (make-field-start-regexp field) header)])
|
||||||
header)])
|
|
||||||
(if m
|
(if m
|
||||||
(let* ([pre (substring header 0 (caaddr m))]
|
(let* ([pre (substring header 0 (caaddr m))]
|
||||||
[s (substring header (cdaddr m))]
|
[s (substring header (cdaddr m))]
|
||||||
|
|
@ -118,10 +116,10 @@
|
||||||
(string-append pre (if data (insert-field field data rest) rest)))
|
(string-append pre (if data (insert-field field data rest) rest)))
|
||||||
(if data (insert-field field data header) header)))))
|
(if data (insert-field field data header) header)))))
|
||||||
|
|
||||||
(define (remove-field field header)
|
(define (remove-field field header)
|
||||||
(replace-field field #f header))
|
(replace-field field #f header))
|
||||||
|
|
||||||
(define (insert-field field data header)
|
(define (insert-field field data header)
|
||||||
(if (bytes? header)
|
(if (bytes? header)
|
||||||
(let ([field (bytes-append field #": "data #"\r\n")])
|
(let ([field (bytes-append field #": "data #"\r\n")])
|
||||||
(bytes-append field header))
|
(bytes-append field header))
|
||||||
|
|
@ -129,7 +127,7 @@
|
||||||
(let ([field (format "~a: ~a\r\n" field data)])
|
(let ([field (format "~a: ~a\r\n" field data)])
|
||||||
(string-append field header))))
|
(string-append field header))))
|
||||||
|
|
||||||
(define (append-headers a b)
|
(define (append-headers a b)
|
||||||
(if (bytes? a)
|
(if (bytes? a)
|
||||||
(let ([alen (bytes-length a)])
|
(let ([alen (bytes-length a)])
|
||||||
(if (> alen 1)
|
(if (> alen 1)
|
||||||
|
|
@ -141,7 +139,7 @@
|
||||||
(string-append (substring a 0 (- alen 2)) b)
|
(string-append (substring a 0 (- alen 2)) b)
|
||||||
(error 'append-headers "first argument is not a header: ~a" a)))))
|
(error 'append-headers "first argument is not a header: ~a" a)))))
|
||||||
|
|
||||||
(define (extract-all-fields header)
|
(define (extract-all-fields header)
|
||||||
(if (bytes? header)
|
(if (bytes? header)
|
||||||
(let ([re #rx#"(^|[\r][\n])(([^\r\n:\"]*): *)"])
|
(let ([re #rx#"(^|[\r][\n])(([^\r\n:\"]*): *)"])
|
||||||
(let loop ([start 0])
|
(let loop ([start 0])
|
||||||
|
|
@ -188,11 +186,11 @@
|
||||||
;; malformed header:
|
;; malformed header:
|
||||||
null))))))
|
null))))))
|
||||||
|
|
||||||
;; It's slightly less obvious how to generalize the functions that don't
|
;; 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),
|
;; 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
|
;; 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
|
(let ([h (insert-field
|
||||||
"Subject" subject
|
"Subject" subject
|
||||||
(insert-field
|
(insert-field
|
||||||
|
|
@ -208,7 +206,7 @@
|
||||||
(insert-field "To" (assemble-address-field tos) h))])
|
(insert-field "To" (assemble-address-field tos) h))])
|
||||||
(insert-field "From" from h)))))
|
(insert-field "From" from h)))))
|
||||||
|
|
||||||
(define (splice l sep)
|
(define (splice l sep)
|
||||||
(if (null? l)
|
(if (null? l)
|
||||||
""
|
""
|
||||||
(format "~a~a"
|
(format "~a~a"
|
||||||
|
|
@ -217,20 +215,20 @@
|
||||||
(map (lambda (n) (format "~a~a" sep n))
|
(map (lambda (n) (format "~a~a" sep n))
|
||||||
(cdr l))))))
|
(cdr l))))))
|
||||||
|
|
||||||
(define (data-lines->data datas)
|
(define (data-lines->data datas)
|
||||||
(splice datas "\r\n\t"))
|
(splice datas "\r\n\t"))
|
||||||
|
|
||||||
;; Extracting Addresses ;;
|
;; Extracting Addresses ;;
|
||||||
|
|
||||||
(define blank "[ \t\n\r\v]")
|
(define blank "[ \t\n\r\v]")
|
||||||
(define nonblank "[^ \t\n\r\v]")
|
(define nonblank "[^ \t\n\r\v]")
|
||||||
(define re:all-blank (regexp (format "^~a*$" blank)))
|
(define re:all-blank (regexp (format "^~a*$" blank)))
|
||||||
(define re:quoted (regexp "\"[^\"]*\""))
|
(define re:quoted (regexp "\"[^\"]*\""))
|
||||||
(define re:parened (regexp "[(][^)]*[)]"))
|
(define re:parened (regexp "[(][^)]*[)]"))
|
||||||
(define re:comma (regexp ","))
|
(define re:comma (regexp ","))
|
||||||
(define re:comma-separated (regexp "([^,]*),(.*)"))
|
(define re:comma-separated (regexp "([^,]*),(.*)"))
|
||||||
|
|
||||||
(define (extract-addresses s form)
|
(define (extract-addresses s form)
|
||||||
(unless (memq form '(name address full all))
|
(unless (memq form '(name address full all))
|
||||||
(raise-type-error 'extract-addresses
|
(raise-type-error 'extract-addresses
|
||||||
"form: 'name, 'address, 'full, or 'all"
|
"form: 'name, 'address, 'full, or 'all"
|
||||||
|
|
@ -242,9 +240,7 @@
|
||||||
(let* ([mq1 (regexp-match-positions re:quoted s)]
|
(let* ([mq1 (regexp-match-positions re:quoted s)]
|
||||||
[mq2 (regexp-match-positions re:parened s)]
|
[mq2 (regexp-match-positions re:parened s)]
|
||||||
[mq (if (and mq1 mq2)
|
[mq (if (and mq1 mq2)
|
||||||
(if (< (caar mq1) (caar mq2))
|
(if (< (caar mq1) (caar mq2)) mq1 mq2)
|
||||||
mq1
|
|
||||||
mq2)
|
|
||||||
(or mq1 mq2))]
|
(or mq1 mq2))]
|
||||||
[mc (regexp-match-positions re:comma s)])
|
[mc (regexp-match-positions re:comma s)])
|
||||||
(if (and mq mc (< (caar mq) (caar mc) (cdar mq)))
|
(if (and mq mc (< (caar mq) (caar mc) (cdar mq)))
|
||||||
|
|
@ -262,27 +258,27 @@
|
||||||
(let ([n (extract-one-name (string-append prefix s) form)])
|
(let ([n (extract-one-name (string-append prefix s) form)])
|
||||||
(list n)))))))))
|
(list n)))))))))
|
||||||
|
|
||||||
(define (select-result form name addr full)
|
(define (select-result form name addr full)
|
||||||
(case form
|
(case form
|
||||||
[(name) name]
|
[(name) name]
|
||||||
[(address) addr]
|
[(address) addr]
|
||||||
[(full) full]
|
[(full) full]
|
||||||
[(all) (list name addr full)]))
|
[(all) (list name addr full)]))
|
||||||
|
|
||||||
(define (one-result form s)
|
(define (one-result form s)
|
||||||
(select-result form s s s))
|
(select-result form s s s))
|
||||||
|
|
||||||
(define re:quoted-name (regexp (format "^~a*(\"[^\"]*\")(.*)" blank)))
|
(define re:quoted-name (regexp (format "^~a*(\"[^\"]*\")(.*)" blank)))
|
||||||
(define re:parened-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:simple-name (regexp (format "^~a*(~a.*)(<.*>)~a*$" blank nonblank blank)))
|
||||||
(define re:normal-name (regexp (format "~a*<([^>]*)>~a*" blank blank)))
|
(define re:normal-name (regexp (format "~a*<([^>]*)>~a*" blank blank)))
|
||||||
(define re:double-less (regexp "<.*<"))
|
(define re:double-less (regexp "<.*<"))
|
||||||
(define re:double-greater (regexp ">.*>"))
|
(define re:double-greater (regexp ">.*>"))
|
||||||
(define re:bad-chars (regexp "[,\"()<>]"))
|
(define re:bad-chars (regexp "[,\"()<>]"))
|
||||||
(define re:tail-blanks (regexp (format "~a+$" blank)))
|
(define re:tail-blanks (regexp (format "~a+$" blank)))
|
||||||
(define re:head-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])
|
(let loop ([s orig][form form])
|
||||||
(cond
|
(cond
|
||||||
;; ?!?!? Where does the "addr (name)" standard come from ?!?!?
|
;; ?!?!? Where does the "addr (name)" standard come from ?!?!?
|
||||||
|
|
@ -311,7 +307,7 @@
|
||||||
(one-result form (extract-angle-addr s orig))]
|
(one-result form (extract-angle-addr s orig))]
|
||||||
[else (one-result form (extract-simple-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))
|
(if (or (regexp-match re:double-less s) (regexp-match re:double-greater s))
|
||||||
(error 'extract-address "too many angle brackets: ~a" s)
|
(error 'extract-address "too many angle brackets: ~a" s)
|
||||||
(let ([m (regexp-match re:normal-name s)])
|
(let ([m (regexp-match re:normal-name s)])
|
||||||
|
|
@ -319,7 +315,7 @@
|
||||||
(extract-simple-addr (cadr m) orig)
|
(extract-simple-addr (cadr m) orig)
|
||||||
(error 'extract-address "cannot parse address: ~a" 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)
|
(cond [(regexp-match re:bad-chars s)
|
||||||
(error 'extract-address "cannot parse address: ~a" orig)]
|
(error 'extract-address "cannot parse address: ~a" orig)]
|
||||||
[else
|
[else
|
||||||
|
|
@ -328,7 +324,7 @@
|
||||||
(regexp-replace re:head-blanks s "")
|
(regexp-replace re:head-blanks s "")
|
||||||
"")]))
|
"")]))
|
||||||
|
|
||||||
(define (assemble-address-field addresses)
|
(define (assemble-address-field addresses)
|
||||||
(if (null? addresses)
|
(if (null? addresses)
|
||||||
""
|
""
|
||||||
(let loop ([addresses (cdr addresses)]
|
(let loop ([addresses (cdr addresses)]
|
||||||
|
|
|
||||||
|
|
@ -1,30 +1,30 @@
|
||||||
#lang scheme/unit
|
#lang scheme/unit
|
||||||
|
|
||||||
(require scheme/tcp
|
(require scheme/tcp
|
||||||
"imap-sig.ss"
|
"imap-sig.ss"
|
||||||
"private/rbtree.ss")
|
"private/rbtree.ss")
|
||||||
|
|
||||||
(import)
|
(import)
|
||||||
(export imap^)
|
(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)
|
(or (eq? a b)
|
||||||
(and (symbol? a)
|
(and (symbol? a)
|
||||||
(symbol? b)
|
(symbol? b)
|
||||||
(string-ci=? (symbol->string a) (symbol->string b)))))
|
(string-ci=? (symbol->string a) (symbol->string b)))))
|
||||||
|
|
||||||
(define field-names
|
(define field-names
|
||||||
(list (list 'uid (string->symbol "UID"))
|
(list (list 'uid (string->symbol "UID"))
|
||||||
(list 'header (string->symbol "RFC822.HEADER"))
|
(list 'header (string->symbol "RFC822.HEADER"))
|
||||||
(list 'body (string->symbol "RFC822.TEXT"))
|
(list 'body (string->symbol "RFC822.TEXT"))
|
||||||
(list 'size (string->symbol "RFC822.SIZE"))
|
(list 'size (string->symbol "RFC822.SIZE"))
|
||||||
(list 'flags (string->symbol "FLAGS"))))
|
(list 'flags (string->symbol "FLAGS"))))
|
||||||
|
|
||||||
(define flag-names
|
(define flag-names
|
||||||
(list (list 'seen (string->symbol "\\Seen"))
|
(list (list 'seen (string->symbol "\\Seen"))
|
||||||
(list 'answered (string->symbol "\\Answered"))
|
(list 'answered (string->symbol "\\Answered"))
|
||||||
(list 'flagged (string->symbol "\\Flagged"))
|
(list 'flagged (string->symbol "\\Flagged"))
|
||||||
|
|
@ -40,32 +40,32 @@
|
||||||
(list 'hasnochildren (string->symbol "\\HasNoChildren"))
|
(list 'hasnochildren (string->symbol "\\HasNoChildren"))
|
||||||
(list 'haschildren (string->symbol "\\HasChildren"))))
|
(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)
|
(or (ormap (lambda (a) (and (tag-eq? f (cadr a)) (car a))) flag-names)
|
||||||
f))
|
f))
|
||||||
|
|
||||||
(define (symbol->imap-flag s)
|
(define (symbol->imap-flag s)
|
||||||
(cond [(assoc s flag-names) => cadr] [else s]))
|
(cond [(assoc s flag-names) => cadr] [else s]))
|
||||||
|
|
||||||
(define (log-warning . args)
|
(define (log-warning . args)
|
||||||
;; (apply printf args)
|
;; (apply printf args)
|
||||||
(void))
|
(void))
|
||||||
(define log log-warning)
|
(define log log-warning)
|
||||||
|
|
||||||
(define make-msg-id
|
(define make-msg-id
|
||||||
(let ([id 0])
|
(let ([id 0])
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(begin0 (string->bytes/latin-1 (format "a~a " id))
|
(begin0 (string->bytes/latin-1 (format "a~a " id))
|
||||||
(set! id (add1 id))))))
|
(set! id (add1 id))))))
|
||||||
|
|
||||||
(define (starts-with? l n)
|
(define (starts-with? l n)
|
||||||
(and (>= (bytes-length l) (bytes-length n))
|
(and (>= (bytes-length l) (bytes-length n))
|
||||||
(bytes=? n (subbytes l 0 (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))))
|
(subbytes s (if (number? n) n (bytes-length n))))
|
||||||
|
|
||||||
(define (splice l sep)
|
(define (splice l sep)
|
||||||
(if (null? l)
|
(if (null? l)
|
||||||
""
|
""
|
||||||
(format "~a~a"
|
(format "~a~a"
|
||||||
|
|
@ -73,7 +73,7 @@
|
||||||
(apply string-append
|
(apply string-append
|
||||||
(map (lambda (n) (format "~a~a" sep n)) (cdr l))))))
|
(map (lambda (n) (format "~a~a" sep n)) (cdr l))))))
|
||||||
|
|
||||||
(define (imap-read s r)
|
(define (imap-read s r)
|
||||||
(let loop ([s s]
|
(let loop ([s s]
|
||||||
[r r]
|
[r r]
|
||||||
[accum null]
|
[accum null]
|
||||||
|
|
@ -127,7 +127,7 @@
|
||||||
eol-k eop-k)
|
eol-k eop-k)
|
||||||
(error 'imap-read "failure reading atom: ~a" s)))])])))
|
(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 loop ()
|
||||||
(let ([l (read-bytes-line r eol)])
|
(let ([l (read-bytes-line r eol)])
|
||||||
(log "raw-reply: ~s\n" l)
|
(log "raw-reply: ~s\n" l)
|
||||||
|
|
@ -141,8 +141,7 @@
|
||||||
(let ([info (imap-read (skip l 2) r)])
|
(let ([info (imap-read (skip l 2) r)])
|
||||||
(log "info: ~s\n" info)
|
(log "info: ~s\n" info)
|
||||||
(info-handler info))
|
(info-handler info))
|
||||||
(when id
|
(when id (loop))]
|
||||||
(loop))]
|
|
||||||
[(starts-with? l #"+ ")
|
[(starts-with? l #"+ ")
|
||||||
(if (null? continuation-handler)
|
(if (null? continuation-handler)
|
||||||
(error 'imap-send "unexpected continuation request: ~a" l)
|
(error 'imap-send "unexpected continuation request: ~a" l)
|
||||||
|
|
@ -151,13 +150,13 @@
|
||||||
(log-warning "warning: unexpected response for ~a: ~a\n" id l)
|
(log-warning "warning: unexpected response for ~a: ~a\n" id l)
|
||||||
(when id (loop))]))))
|
(when id (loop))]))))
|
||||||
|
|
||||||
;; A cmd is
|
;; A cmd is
|
||||||
;; * (box v) - send v literally via ~a
|
;; * (box v) - send v literally via ~a
|
||||||
;; * string or bytes - protect as necessary
|
;; * string or bytes - protect as necessary
|
||||||
;; * (cons cmd null) - same as cmd
|
;; * (cons cmd null) - same as cmd
|
||||||
;; * (cons cmd cmd) - send cmd, space, 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)]
|
(let ([r (imap-r imap)]
|
||||||
[w (imap-w imap)]
|
[w (imap-w imap)]
|
||||||
[id (make-msg-id)])
|
[id (make-msg-id)])
|
||||||
|
|
@ -190,23 +189,23 @@
|
||||||
(get-response r id (wrap-info-handler imap info-handler)
|
(get-response r id (wrap-info-handler imap info-handler)
|
||||||
continuation-handler)))
|
continuation-handler)))
|
||||||
|
|
||||||
(define (check-ok reply)
|
(define (check-ok reply)
|
||||||
(unless (and (pair? reply) (tag-eq? (car reply) 'OK))
|
(unless (and (pair? reply) (tag-eq? (car reply) 'OK))
|
||||||
(error 'check-ok "server error: ~s" reply)))
|
(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)
|
(and (tag-eq? (car i) 'OK)
|
||||||
((length i) . >= . 3)
|
((length i) . >= . 3)
|
||||||
(tag-eq? (cadr i) (string->symbol (format "[~a" t)))))
|
(tag-eq? (cadr i) (string->symbol (format "[~a" t)))))
|
||||||
|
|
||||||
(define (ok-tag-val i)
|
(define (ok-tag-val i)
|
||||||
(let ([v (caddr i)])
|
(let ([v (caddr i)])
|
||||||
(and (symbol? v)
|
(and (symbol? v)
|
||||||
(let ([v (symbol->string v)])
|
(let ([v (symbol->string v)])
|
||||||
(regexp-match #rx"[]]$" v)
|
(regexp-match #rx"[]]$" v)
|
||||||
(string->number (substring v 0 (sub1 (string-length 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)
|
(lambda (i)
|
||||||
(when (and (list? i) ((length i) . >= . 2))
|
(when (and (list? i) ((length i) . >= . 2))
|
||||||
(cond
|
(cond
|
||||||
|
|
@ -253,12 +252,12 @@
|
||||||
(set-imap-uidvalidity! imap (ok-tag-val i))]))
|
(set-imap-uidvalidity! imap (ok-tag-val i))]))
|
||||||
(info-handler 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?)
|
expunges fetches new?)
|
||||||
#:mutable)
|
#:mutable)
|
||||||
(define (imap-connection? v) (imap? v))
|
(define (imap-connection? v) (imap? v))
|
||||||
|
|
||||||
(define imap-port-number
|
(define imap-port-number
|
||||||
(make-parameter 143
|
(make-parameter 143
|
||||||
(lambda (v)
|
(lambda (v)
|
||||||
(unless (and (number? v)
|
(unless (and (number? v)
|
||||||
|
|
@ -270,7 +269,7 @@
|
||||||
v))
|
v))
|
||||||
v)))
|
v)))
|
||||||
|
|
||||||
(define (imap-connect* r w username password inbox)
|
(define (imap-connect* r w username password inbox)
|
||||||
(with-handlers ([void
|
(with-handlers ([void
|
||||||
(lambda (x)
|
(lambda (x)
|
||||||
(close-input-port r)
|
(close-input-port r)
|
||||||
|
|
@ -288,7 +287,7 @@
|
||||||
(let-values ([(init-count init-recent) (imap-reselect imap inbox)])
|
(let-values ([(init-count init-recent) (imap-reselect imap inbox)])
|
||||||
(values imap init-count init-recent)))))
|
(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
|
;; => imap count-k recent-k
|
||||||
(let-values ([(r w)
|
(let-values ([(r w)
|
||||||
(if debug-via-stdio?
|
(if debug-via-stdio?
|
||||||
|
|
@ -298,17 +297,17 @@
|
||||||
(tcp-connect server (imap-port-number)))])
|
(tcp-connect server (imap-port-number)))])
|
||||||
(imap-connect* r w username password inbox)))
|
(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))
|
(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))
|
(imap-selectish-command imap (list "EXAMINE" inbox) #t))
|
||||||
|
|
||||||
;; Used to return (values #f #f) if no change since last check?
|
;; Used to return (values #f #f) if no change since last check?
|
||||||
(define (imap-noop imap)
|
(define (imap-noop imap)
|
||||||
(imap-selectish-command imap "NOOP" #f))
|
(imap-selectish-command imap "NOOP" #f))
|
||||||
|
|
||||||
(define (imap-selectish-command imap cmd reset?)
|
(define (imap-selectish-command imap cmd reset?)
|
||||||
(let ([init-count #f]
|
(let ([init-count #f]
|
||||||
[init-recent #f])
|
[init-recent #f])
|
||||||
(check-ok (imap-send imap cmd void))
|
(check-ok (imap-send imap cmd void))
|
||||||
|
|
@ -318,7 +317,7 @@
|
||||||
(set-imap-new?! imap #f))
|
(set-imap-new?! imap #f))
|
||||||
(values (imap-exists imap) (imap-recent imap))))
|
(values (imap-exists imap) (imap-recent imap))))
|
||||||
|
|
||||||
(define (imap-status imap inbox flags)
|
(define (imap-status imap inbox flags)
|
||||||
(unless (and (list? flags)
|
(unless (and (list? flags)
|
||||||
(andmap (lambda (s)
|
(andmap (lambda (s)
|
||||||
(memq s '(messages recent uidnext uidvalidity unseen)))
|
(memq s '(messages recent uidnext uidvalidity unseen)))
|
||||||
|
|
@ -338,7 +337,7 @@
|
||||||
[else (loop (cdr l))])))
|
[else (loop (cdr l))])))
|
||||||
flags)))
|
flags)))
|
||||||
|
|
||||||
(define (imap-poll imap)
|
(define (imap-poll imap)
|
||||||
(when (and ;; Check for async messages from the server
|
(when (and ;; Check for async messages from the server
|
||||||
(char-ready? (imap-r imap))
|
(char-ready? (imap-r imap))
|
||||||
;; It has better start with "*"...
|
;; It has better start with "*"...
|
||||||
|
|
@ -347,47 +346,47 @@
|
||||||
(get-response (imap-r imap) #f (wrap-info-handler imap void) null)
|
(get-response (imap-r imap) #f (wrap-info-handler imap void) null)
|
||||||
(void)))
|
(void)))
|
||||||
|
|
||||||
(define (imap-get-updates imap)
|
(define (imap-get-updates imap)
|
||||||
(no-expunges 'imap-updates imap)
|
(no-expunges 'imap-updates imap)
|
||||||
(let ([l (fetch-tree->list (imap-fetches imap))])
|
(let ([l (fetch-tree->list (imap-fetches imap))])
|
||||||
(set-imap-fetches! imap (new-tree))
|
(set-imap-fetches! imap (new-tree))
|
||||||
l))
|
l))
|
||||||
|
|
||||||
(define (imap-pending-updates? imap)
|
(define (imap-pending-updates? imap)
|
||||||
(not (tree-empty? (imap-fetches 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))])
|
(let ([l (expunge-tree->list (imap-expunges imap))])
|
||||||
(set-imap-expunges! imap (new-tree))
|
(set-imap-expunges! imap (new-tree))
|
||||||
l))
|
l))
|
||||||
|
|
||||||
(define (imap-pending-expunges? imap)
|
(define (imap-pending-expunges? imap)
|
||||||
(not (tree-empty? (imap-expunges imap))))
|
(not (tree-empty? (imap-expunges imap))))
|
||||||
|
|
||||||
(define (imap-reset-new! imap)
|
(define (imap-reset-new! imap)
|
||||||
(set-imap-new?! imap #f))
|
(set-imap-new?! imap #f))
|
||||||
|
|
||||||
(define (imap-messages imap)
|
(define (imap-messages imap)
|
||||||
(imap-exists imap))
|
(imap-exists imap))
|
||||||
|
|
||||||
(define (imap-disconnect imap)
|
(define (imap-disconnect imap)
|
||||||
(let ([r (imap-r imap)]
|
(let ([r (imap-r imap)]
|
||||||
[w (imap-w imap)])
|
[w (imap-w imap)])
|
||||||
(check-ok (imap-send imap "LOGOUT" void))
|
(check-ok (imap-send imap "LOGOUT" void))
|
||||||
(close-input-port r)
|
(close-input-port r)
|
||||||
(close-output-port w)))
|
(close-output-port w)))
|
||||||
|
|
||||||
(define (imap-force-disconnect imap)
|
(define (imap-force-disconnect imap)
|
||||||
(let ([r (imap-r imap)]
|
(let ([r (imap-r imap)]
|
||||||
[w (imap-w imap)])
|
[w (imap-w imap)])
|
||||||
(close-input-port r)
|
(close-input-port r)
|
||||||
(close-output-port w)))
|
(close-output-port w)))
|
||||||
|
|
||||||
(define (no-expunges who imap)
|
(define (no-expunges who imap)
|
||||||
(unless (tree-empty? (imap-expunges imap))
|
(unless (tree-empty? (imap-expunges imap))
|
||||||
(raise-mismatch-error who "session has pending expunge reports: " imap)))
|
(raise-mismatch-error who "session has pending expunge reports: " imap)))
|
||||||
|
|
||||||
(define (msg-set msgs)
|
(define (msg-set msgs)
|
||||||
(apply
|
(apply
|
||||||
string-append
|
string-append
|
||||||
(let loop ([prev #f][msgs msgs])
|
(let loop ([prev #f][msgs msgs])
|
||||||
|
|
@ -406,7 +405,7 @@
|
||||||
[else (cons (format "~a," (car msgs))
|
[else (cons (format "~a," (car msgs))
|
||||||
(loop #f (cdr 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)
|
(no-expunges 'imap-get-messages imap)
|
||||||
(when (or (not (list? msgs))
|
(when (or (not (list? msgs))
|
||||||
(not (andmap integer? msgs)))
|
(not (andmap integer? msgs)))
|
||||||
|
|
@ -452,7 +451,7 @@
|
||||||
(loop (cdr flds) (if a (remq a m) m))))]))))
|
(loop (cdr flds) (if a (remq a m) m))))]))))
|
||||||
msgs))))))
|
msgs))))))
|
||||||
|
|
||||||
(define (imap-store imap mode msgs flags)
|
(define (imap-store imap mode msgs flags)
|
||||||
(no-expunges 'imap-store imap)
|
(no-expunges 'imap-store imap)
|
||||||
(check-ok
|
(check-ok
|
||||||
(imap-send imap
|
(imap-send imap
|
||||||
|
|
@ -462,22 +461,19 @@
|
||||||
[(+) "+FLAGS.SILENT"]
|
[(+) "+FLAGS.SILENT"]
|
||||||
[(-) "-FLAGS.SILENT"]
|
[(-) "-FLAGS.SILENT"]
|
||||||
[(!) "FLAGS.SILENT"]
|
[(!) "FLAGS.SILENT"]
|
||||||
[else (raise-type-error
|
[else (raise-type-error 'imap-store
|
||||||
'imap-store "mode: '!, '+, or '-" mode)])
|
"mode: '!, '+, or '-" mode)])
|
||||||
(box (format "~a" flags)))
|
(box (format "~a" flags)))
|
||||||
void)))
|
void)))
|
||||||
|
|
||||||
(define (imap-copy imap msgs dest-mailbox)
|
(define (imap-copy imap msgs dest-mailbox)
|
||||||
(no-expunges 'imap-copy imap)
|
(no-expunges 'imap-copy imap)
|
||||||
(check-ok
|
(check-ok
|
||||||
(imap-send imap (list "COPY" (box (msg-set msgs)) dest-mailbox)
|
(imap-send imap (list "COPY" (box (msg-set msgs)) dest-mailbox) void)))
|
||||||
void)))
|
|
||||||
|
|
||||||
(define (imap-append imap dest-mailbox msg)
|
(define (imap-append imap dest-mailbox msg)
|
||||||
(no-expunges 'imap-append imap)
|
(no-expunges 'imap-append imap)
|
||||||
(let ([msg (if (bytes? msg)
|
(let ([msg (if (bytes? msg) msg (string->bytes/utf-8 msg))])
|
||||||
msg
|
|
||||||
(string->bytes/utf-8 msg))])
|
|
||||||
(check-ok
|
(check-ok
|
||||||
(imap-send imap (list "APPEND"
|
(imap-send imap (list "APPEND"
|
||||||
dest-mailbox
|
dest-mailbox
|
||||||
|
|
@ -488,24 +484,23 @@
|
||||||
(fprintf (imap-w imap) "~a\r\n" msg)
|
(fprintf (imap-w imap) "~a\r\n" msg)
|
||||||
(loop))))))
|
(loop))))))
|
||||||
|
|
||||||
(define (imap-expunge imap)
|
(define (imap-expunge imap)
|
||||||
(check-ok (imap-send imap "EXPUNGE" void)))
|
(check-ok (imap-send imap "EXPUNGE" void)))
|
||||||
|
|
||||||
(define (imap-mailbox-exists? imap mailbox)
|
(define (imap-mailbox-exists? imap mailbox)
|
||||||
(let ([exists? #f])
|
(let ([exists? #f])
|
||||||
(check-ok (imap-send imap
|
(check-ok (imap-send imap
|
||||||
(list "LIST" "" mailbox)
|
(list "LIST" "" mailbox)
|
||||||
(lambda (i)
|
(lambda (i)
|
||||||
(when (and (pair? i)
|
(when (and (pair? i) (tag-eq? (car i) 'LIST))
|
||||||
(tag-eq? (car i) 'LIST))
|
|
||||||
(set! exists? #t)))))
|
(set! exists? #t)))))
|
||||||
exists?))
|
exists?))
|
||||||
|
|
||||||
(define (imap-create-mailbox imap mailbox)
|
(define (imap-create-mailbox imap mailbox)
|
||||||
(check-ok (imap-send imap (list "CREATE" mailbox) void)))
|
(check-ok (imap-send imap (list "CREATE" mailbox) void)))
|
||||||
|
|
||||||
(define (imap-get-hierarchy-delimiter imap)
|
(define (imap-get-hierarchy-delimiter imap)
|
||||||
(let* ([result #f])
|
(let ([result #f])
|
||||||
(check-ok
|
(check-ok
|
||||||
(imap-send imap (list "LIST" "" "")
|
(imap-send imap (list "LIST" "" "")
|
||||||
(lambda (i)
|
(lambda (i)
|
||||||
|
|
@ -513,7 +508,7 @@
|
||||||
(set! result (caddr i))))))
|
(set! result (caddr i))))))
|
||||||
result))
|
result))
|
||||||
|
|
||||||
(define imap-list-child-mailboxes
|
(define imap-list-child-mailboxes
|
||||||
(case-lambda
|
(case-lambda
|
||||||
[(imap mailbox)
|
[(imap mailbox)
|
||||||
(imap-list-child-mailboxes imap mailbox #f)]
|
(imap-list-child-mailboxes imap mailbox #f)]
|
||||||
|
|
@ -534,7 +529,7 @@
|
||||||
(cadr p)])))
|
(cadr p)])))
|
||||||
(imap-list-mailboxes imap pattern mailbox-name)))]))
|
(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)])
|
(let ([r (imap-list-mailboxes imap mailbox #f)])
|
||||||
(if (= (length r) 1)
|
(if (= (length r) 1)
|
||||||
(caar r)
|
(caar r)
|
||||||
|
|
@ -542,7 +537,7 @@
|
||||||
mailbox
|
mailbox
|
||||||
(if (null? r) "no matches" "multiple matches")))))
|
(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])
|
(let* ([sub-folders null])
|
||||||
(check-ok
|
(check-ok
|
||||||
(imap-send imap (list "LIST" "" pattern)
|
(imap-send imap (list "LIST" "" pattern)
|
||||||
|
|
|
||||||
|
|
@ -12,16 +12,13 @@
|
||||||
|
|
||||||
;; -- basic mime structures --
|
;; -- basic mime structures --
|
||||||
(struct message (version entity fields))
|
(struct message (version entity fields))
|
||||||
(struct entity
|
(struct entity (type subtype charset encoding
|
||||||
(type subtype charset encoding
|
|
||||||
disposition params id
|
disposition params id
|
||||||
description other fields
|
description other fields
|
||||||
parts body))
|
parts body))
|
||||||
(struct disposition
|
(struct disposition (type filename creation
|
||||||
(type filename creation
|
|
||||||
modification read
|
modification read
|
||||||
size params))
|
size params))
|
||||||
|
|
||||||
;; -- mime methods --
|
;; -- mime methods --
|
||||||
mime-analyze
|
mime-analyze
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -29,27 +29,25 @@
|
||||||
|
|
||||||
#lang scheme/unit
|
#lang scheme/unit
|
||||||
|
|
||||||
(require "mime-sig.ss"
|
(require "mime-sig.ss"
|
||||||
"qp-sig.ss"
|
"qp-sig.ss"
|
||||||
"base64-sig.ss"
|
"base64-sig.ss"
|
||||||
"head-sig.ss"
|
"head-sig.ss"
|
||||||
"mime-util.ss"
|
"mime-util.ss"
|
||||||
mzlib/etc
|
scheme/port)
|
||||||
mzlib/string
|
|
||||||
mzlib/port)
|
|
||||||
|
|
||||||
(import base64^ qp^ head^)
|
(import base64^ qp^ head^)
|
||||||
(export mime^)
|
(export mime^)
|
||||||
|
|
||||||
;; Constants:
|
;; Constants:
|
||||||
(define discrete-alist
|
(define discrete-alist
|
||||||
'(("text" . text)
|
'(("text" . text)
|
||||||
("image" . image)
|
("image" . image)
|
||||||
("audio" . audio)
|
("audio" . audio)
|
||||||
("video" . video)
|
("video" . video)
|
||||||
("application" . application)))
|
("application" . application)))
|
||||||
|
|
||||||
(define disposition-alist
|
(define disposition-alist
|
||||||
'(("inline" . inline)
|
'(("inline" . inline)
|
||||||
("attachment" . attachment)
|
("attachment" . attachment)
|
||||||
("file" . attachment) ;; This is used (don't know why) by
|
("file" . attachment) ;; This is used (don't know why) by
|
||||||
|
|
@ -57,19 +55,19 @@
|
||||||
("messagetext" . inline)
|
("messagetext" . inline)
|
||||||
("form-data" . form-data)))
|
("form-data" . form-data)))
|
||||||
|
|
||||||
(define composite-alist
|
(define composite-alist
|
||||||
'(("message" . message)
|
'(("message" . message)
|
||||||
("multipart" . multipart)))
|
("multipart" . multipart)))
|
||||||
|
|
||||||
(define mechanism-alist
|
(define mechanism-alist
|
||||||
'(("7bit" . 7bit)
|
'(("7bit" . 7bit)
|
||||||
("8bit" . 8bit)
|
("8bit" . 8bit)
|
||||||
("binary" . binary)
|
("binary" . binary)
|
||||||
("quoted-printable" . quoted-printable)
|
("quoted-printable" . quoted-printable)
|
||||||
("base64" . base64)))
|
("base64" . base64)))
|
||||||
|
|
||||||
(define ietf-extensions '())
|
(define ietf-extensions '())
|
||||||
(define iana-extensions
|
(define iana-extensions
|
||||||
'(;; text
|
'(;; text
|
||||||
("plain" . plain)
|
("plain" . plain)
|
||||||
("html" . html)
|
("html" . html)
|
||||||
|
|
@ -120,37 +118,37 @@
|
||||||
("mpeg" . mpeg)
|
("mpeg" . mpeg)
|
||||||
("quicktime" . quicktime)))
|
("quicktime" . quicktime)))
|
||||||
|
|
||||||
;; Basic structures
|
;; Basic structures
|
||||||
(define-struct message (version entity fields)
|
(define-struct message (version entity fields)
|
||||||
#:mutable)
|
#:mutable)
|
||||||
(define-struct entity
|
(define-struct entity
|
||||||
(type subtype charset encoding disposition params id description other
|
(type subtype charset encoding disposition params id description other
|
||||||
fields parts body)
|
fields parts body)
|
||||||
#:mutable)
|
#:mutable)
|
||||||
(define-struct disposition
|
(define-struct disposition
|
||||||
(type filename creation modification read size params)
|
(type filename creation modification read size params)
|
||||||
#:mutable)
|
#:mutable)
|
||||||
|
|
||||||
;; Exceptions
|
;; Exceptions
|
||||||
(define-struct mime-error ())
|
(define-struct mime-error ())
|
||||||
(define-struct (unexpected-termination mime-error) (msg))
|
(define-struct (unexpected-termination mime-error) (msg))
|
||||||
(define-struct (missing-multipart-boundary-parameter mime-error) ())
|
(define-struct (missing-multipart-boundary-parameter mime-error) ())
|
||||||
(define-struct (malformed-multipart-entity mime-error) (msg))
|
(define-struct (malformed-multipart-entity mime-error) (msg))
|
||||||
(define-struct (empty-mechanism mime-error) ())
|
(define-struct (empty-mechanism mime-error) ())
|
||||||
(define-struct (empty-type mime-error) ())
|
(define-struct (empty-type mime-error) ())
|
||||||
(define-struct (empty-subtype mime-error) ())
|
(define-struct (empty-subtype mime-error) ())
|
||||||
(define-struct (empty-disposition-type mime-error) ())
|
(define-struct (empty-disposition-type mime-error) ())
|
||||||
|
|
||||||
;; *************************************
|
;; *************************************
|
||||||
;; Practical stuff, aka MIME in action:
|
;; Practical stuff, aka MIME in action:
|
||||||
;; *************************************
|
;; *************************************
|
||||||
(define CRLF (format "~a~a" #\return #\newline))
|
(define CRLF (format "~a~a" #\return #\newline))
|
||||||
(define CRLF-binary "=0D=0A") ;; quoted printable representation
|
(define CRLF-binary "=0D=0A") ;; quoted printable representation
|
||||||
|
|
||||||
;; get-headers : input-port -> string
|
;; get-headers : input-port -> string
|
||||||
;; returns the header part of a message/part conforming to rfc822, and
|
;; returns the header part of a message/part conforming to rfc822, and
|
||||||
;; rfc2045.
|
;; rfc2045.
|
||||||
(define (get-headers in)
|
(define (get-headers in)
|
||||||
(let loop ([headers ""] [ln (read-line in 'any)])
|
(let loop ([headers ""] [ln (read-line in 'any)])
|
||||||
(cond [(eof-object? ln)
|
(cond [(eof-object? ln)
|
||||||
;; (raise (make-unexpected-termination "eof reached! while parsing headers"))
|
;; (raise (make-unexpected-termination "eof reached! while parsing headers"))
|
||||||
|
|
@ -168,7 +166,7 @@
|
||||||
(loop (string-append headers ln CRLF)
|
(loop (string-append headers ln CRLF)
|
||||||
(read-line in 'any))])))
|
(read-line in 'any))])))
|
||||||
|
|
||||||
(define (make-default-disposition)
|
(define (make-default-disposition)
|
||||||
(make-disposition
|
(make-disposition
|
||||||
'inline ;; type
|
'inline ;; type
|
||||||
"" ;; filename
|
"" ;; filename
|
||||||
|
|
@ -179,7 +177,7 @@
|
||||||
null ;; params
|
null ;; params
|
||||||
))
|
))
|
||||||
|
|
||||||
(define (make-default-entity)
|
(define (make-default-entity)
|
||||||
(make-entity
|
(make-entity
|
||||||
'text ;; type
|
'text ;; type
|
||||||
'plain ;; subtype
|
'plain ;; subtype
|
||||||
|
|
@ -195,10 +193,10 @@
|
||||||
null ;; body
|
null ;; body
|
||||||
))
|
))
|
||||||
|
|
||||||
(define (make-default-message)
|
(define (make-default-message)
|
||||||
(make-message 1.0 (make-default-entity) null))
|
(make-message 1.0 (make-default-entity) null))
|
||||||
|
|
||||||
(define (mime-decode entity input)
|
(define (mime-decode entity input)
|
||||||
(set-entity-body!
|
(set-entity-body!
|
||||||
entity
|
entity
|
||||||
(case (entity-encoding entity)
|
(case (entity-encoding entity)
|
||||||
|
|
@ -212,8 +210,7 @@
|
||||||
(lambda (output)
|
(lambda (output)
|
||||||
(copy-port input output))])))
|
(copy-port input output))])))
|
||||||
|
|
||||||
(define mime-analyze
|
(define (mime-analyze input [part #f])
|
||||||
(opt-lambda (input (part #f))
|
|
||||||
(let* ([iport (if (bytes? input)
|
(let* ([iport (if (bytes? input)
|
||||||
(open-input-bytes input)
|
(open-input-bytes input)
|
||||||
input)]
|
input)]
|
||||||
|
|
@ -242,24 +239,24 @@
|
||||||
;; Unrecognized type, you're on your own! (sorry)
|
;; Unrecognized type, you're on your own! (sorry)
|
||||||
(mime-decode entity iport)])
|
(mime-decode entity iport)])
|
||||||
;; return mime structure
|
;; return mime structure
|
||||||
msg)))
|
msg))
|
||||||
|
|
||||||
(define (entity-boundary entity)
|
(define (entity-boundary entity)
|
||||||
(let* ([params (entity-params entity)]
|
(let* ([params (entity-params entity)]
|
||||||
[ans (assoc "boundary" params)])
|
[ans (assoc "boundary" params)])
|
||||||
(and ans (cdr ans))))
|
(and ans (cdr ans))))
|
||||||
|
|
||||||
;; *************************************************
|
;; *************************************************
|
||||||
;; MIME Specific: rfc2045-2049, and rfc0822, rfc2183
|
;; MIME Specific: rfc2045-2049, and rfc0822, rfc2183
|
||||||
;; *************************************************
|
;; *************************************************
|
||||||
|
|
||||||
;;multipart-body := [preamble CRLF]
|
;;multipart-body := [preamble CRLF]
|
||||||
;; dash-boundary transport-padding CRLF
|
;; dash-boundary transport-padding CRLF
|
||||||
;; body-part *encapsulation
|
;; body-part *encapsulation
|
||||||
;; close-delimiter transport-padding
|
;; close-delimiter transport-padding
|
||||||
;; [CRLF epilogue]
|
;; [CRLF epilogue]
|
||||||
;; Returns a list of input ports, each one containing the correspongind part.
|
;; Returns a list of input ports, each one containing the correspongind part.
|
||||||
(define (multipart-body input boundary)
|
(define (multipart-body input boundary)
|
||||||
(let* ([make-re (lambda (prefix)
|
(let* ([make-re (lambda (prefix)
|
||||||
(regexp (string-append prefix "--" (regexp-quote boundary) "(--)?\r\n")))]
|
(regexp (string-append prefix "--" (regexp-quote boundary) "(--)?\r\n")))]
|
||||||
[re (make-re "\r\n")])
|
[re (make-re "\r\n")])
|
||||||
|
|
@ -291,36 +288,36 @@
|
||||||
[eof? (list part)]
|
[eof? (list part)]
|
||||||
[else (cons part (loop))]))))))
|
[else (cons part (loop))]))))))
|
||||||
|
|
||||||
;; MIME-message-headers := entity-headers
|
;; MIME-message-headers := entity-headers
|
||||||
;; fields
|
;; fields
|
||||||
;; version CRLF
|
;; version CRLF
|
||||||
;; ; The ordering of the header
|
;; ; The ordering of the header
|
||||||
;; ; fields implied by this BNF
|
;; ; fields implied by this BNF
|
||||||
;; ; definition should be ignored.
|
;; ; definition should be ignored.
|
||||||
(define (MIME-message-headers headers)
|
(define (MIME-message-headers headers)
|
||||||
(let ([message (make-default-message)])
|
(let ([message (make-default-message)])
|
||||||
(entity-headers headers message #t)
|
(entity-headers headers message #t)
|
||||||
message))
|
message))
|
||||||
|
|
||||||
;; MIME-part-headers := entity-headers
|
;; MIME-part-headers := entity-headers
|
||||||
;; [ fields ]
|
;; [ fields ]
|
||||||
;; ; Any field not beginning with
|
;; ; Any field not beginning with
|
||||||
;; ; "content-" can have no defined
|
;; ; "content-" can have no defined
|
||||||
;; ; meaning and may be ignored.
|
;; ; meaning and may be ignored.
|
||||||
;; ; The ordering of the header
|
;; ; The ordering of the header
|
||||||
;; ; fields implied by this BNF
|
;; ; fields implied by this BNF
|
||||||
;; ; definition should be ignored.
|
;; ; definition should be ignored.
|
||||||
(define (MIME-part-headers headers)
|
(define (MIME-part-headers headers)
|
||||||
(let ([message (make-default-message)])
|
(let ([message (make-default-message)])
|
||||||
(entity-headers headers message #f)
|
(entity-headers headers message #f)
|
||||||
message))
|
message))
|
||||||
|
|
||||||
;; entity-headers := [ content CRLF ]
|
;; entity-headers := [ content CRLF ]
|
||||||
;; [ encoding CRLF ]
|
;; [ encoding CRLF ]
|
||||||
;; [ id CRLF ]
|
;; [ id CRLF ]
|
||||||
;; [ description CRLF ]
|
;; [ description CRLF ]
|
||||||
;; *( MIME-extension-field CRLF )
|
;; *( MIME-extension-field CRLF )
|
||||||
(define (entity-headers headers message version?)
|
(define (entity-headers headers message version?)
|
||||||
(let ([entity (message-entity message)])
|
(let ([entity (message-entity message)])
|
||||||
(let-values ([(mime non-mime) (get-fields headers)])
|
(let-values ([(mime non-mime) (get-fields headers)])
|
||||||
(let loop ([fields mime])
|
(let loop ([fields mime])
|
||||||
|
|
@ -343,7 +340,7 @@
|
||||||
;; Return message
|
;; Return message
|
||||||
message)))
|
message)))
|
||||||
|
|
||||||
(define (get-fields headers)
|
(define (get-fields headers)
|
||||||
(let ([mime null] [non-mime null])
|
(let ([mime null] [non-mime null])
|
||||||
(letrec ([store-field
|
(letrec ([store-field
|
||||||
(lambda (f)
|
(lambda (f)
|
||||||
|
|
@ -357,22 +354,21 @@
|
||||||
fields))
|
fields))
|
||||||
(values mime non-mime))))
|
(values mime non-mime))))
|
||||||
|
|
||||||
(define re:content (regexp (format "^~a" (regexp-quote "content-" #f))))
|
(define re:content #rx"^(?i:content-)")
|
||||||
(define re:mime (regexp (format "^~a:" (regexp-quote "mime-version" #f))))
|
(define re:mime #rx"^(?i:mime-version):")
|
||||||
|
|
||||||
(define (mime-header? h)
|
(define (mime-header? h)
|
||||||
(or (regexp-match? re:content h)
|
(or (regexp-match? re:content h)
|
||||||
(regexp-match? re:mime h)))
|
(regexp-match? re:mime h)))
|
||||||
|
|
||||||
;;; Headers
|
;;; Headers
|
||||||
;;; Content-type follows this BNF syntax:
|
;;; Content-type follows this BNF syntax:
|
||||||
;; content := "Content-Type" ":" type "/" subtype
|
;; content := "Content-Type" ":" type "/" subtype
|
||||||
;; *(";" parameter)
|
;; *(";" parameter)
|
||||||
;; ; Matching of media type and subtype
|
;; ; Matching of media type and subtype
|
||||||
;; ; is ALWAYS case-insensitive.
|
;; ; is ALWAYS case-insensitive.
|
||||||
(define re:content-type
|
(define re:content-type #rx"^(?i:content-type):([^/]+)/([^/]+)$")
|
||||||
(regexp (format "^~a:([^/]+)/([^/]+)$" (regexp-quote "content-type" #f))))
|
(define (content header entity)
|
||||||
(define (content header entity)
|
|
||||||
(let* ([params (string-tokenizer #\; header)]
|
(let* ([params (string-tokenizer #\; header)]
|
||||||
[one re:content-type]
|
[one re:content-type]
|
||||||
[h (trim-all-spaces (car params))]
|
[h (trim-all-spaces (car params))]
|
||||||
|
|
@ -394,20 +390,18 @@
|
||||||
(cond [par-pair
|
(cond [par-pair
|
||||||
(when (string=? (car par-pair) "charset")
|
(when (string=? (car par-pair) "charset")
|
||||||
(set-entity-charset! entity (cdr par-pair)))
|
(set-entity-charset! entity (cdr par-pair)))
|
||||||
(loop (cdr p)
|
(loop (cdr p) (append ans (list par-pair)))]
|
||||||
(append ans
|
|
||||||
(list par-pair)))]
|
|
||||||
[else
|
[else
|
||||||
(warning "Invalid parameter for Content-Type: `~a'" (car p))
|
(warning "Invalid parameter for Content-Type: `~a'" (car p))
|
||||||
;; go on...
|
;; go on...
|
||||||
(loop (cdr p) ans)]))])))))))
|
(loop (cdr p) ans)]))])))))))
|
||||||
|
|
||||||
;; From rfc2183 Content-Disposition
|
;; From rfc2183 Content-Disposition
|
||||||
;; disposition := "Content-Disposition" ":"
|
;; disposition := "Content-Disposition" ":"
|
||||||
;; disposition-type
|
;; disposition-type
|
||||||
;; *(";" disposition-parm)
|
;; *(";" disposition-parm)
|
||||||
(define re:content-disposition (regexp (format "^~a:(.+)$" (regexp-quote "content-disposition" #f))))
|
(define re:content-disposition #rx"^(?i:content-disposition):(.+)$")
|
||||||
(define (dispositione header entity)
|
(define (dispositione header entity)
|
||||||
(let* ([params (string-tokenizer #\; header)]
|
(let* ([params (string-tokenizer #\; header)]
|
||||||
[reg re:content-disposition]
|
[reg re:content-disposition]
|
||||||
[h (trim-all-spaces (car params))]
|
[h (trim-all-spaces (car params))]
|
||||||
|
|
@ -419,10 +413,9 @@
|
||||||
(disp-type (regexp-replace reg h "\\1")))
|
(disp-type (regexp-replace reg h "\\1")))
|
||||||
(disp-params (cdr params) disp-struct))))
|
(disp-params (cdr params) disp-struct))))
|
||||||
|
|
||||||
;; version := "MIME-Version" ":" 1*DIGIT "." 1*DIGIT
|
;; version := "MIME-Version" ":" 1*DIGIT "." 1*DIGIT
|
||||||
(define re:mime-version
|
(define re:mime-version #rx"^(?i:MIME-Version):([0-9]+)\\.([0-9]+)$")
|
||||||
(regexp (format "^~a:([0-9]+)\\.([0-9]+)$" (regexp-quote "MIME-Version" #f))))
|
(define (version header message)
|
||||||
(define (version header message)
|
|
||||||
(let* ([reg re:mime-version]
|
(let* ([reg re:mime-version]
|
||||||
[h (trim-all-spaces header)]
|
[h (trim-all-spaces header)]
|
||||||
[target (regexp-match reg h)])
|
[target (regexp-match reg h)])
|
||||||
|
|
@ -431,10 +424,9 @@
|
||||||
message
|
message
|
||||||
(string->number (regexp-replace reg h "\\1.\\2"))))))
|
(string->number (regexp-replace reg h "\\1.\\2"))))))
|
||||||
|
|
||||||
;; description := "Content-Description" ":" *text
|
;; description := "Content-Description" ":" *text
|
||||||
(define re:content-description
|
(define re:content-description #rx"^(?i:content-description):[ \t\r\n]*(.*)$")
|
||||||
(regexp (format "^~a:[ \t\r\n]*(.*)$" (regexp-quote "content-description" #f))))
|
(define (description header entity)
|
||||||
(define (description header entity)
|
|
||||||
(let* ([reg re:content-description]
|
(let* ([reg re:content-description]
|
||||||
[target (regexp-match reg header)])
|
[target (regexp-match reg header)])
|
||||||
(and target
|
(and target
|
||||||
|
|
@ -442,9 +434,9 @@
|
||||||
entity
|
entity
|
||||||
(trim-spaces (regexp-replace reg header "\\1"))))))
|
(trim-spaces (regexp-replace reg header "\\1"))))))
|
||||||
|
|
||||||
;; encoding := "Content-Transfer-Encoding" ":" mechanism
|
;; encoding := "Content-Transfer-Encoding" ":" mechanism
|
||||||
(define re:content-transfer-encoding (regexp (format "^~a:(.+)$" (regexp-quote "content-transfer-encoding" #f))))
|
(define re:content-transfer-encoding #rx"^(?i:content-transfer-encoding):(.+)$")
|
||||||
(define (encoding header entity)
|
(define (encoding header entity)
|
||||||
(let* ([reg re:content-transfer-encoding]
|
(let* ([reg re:content-transfer-encoding]
|
||||||
[h (trim-all-spaces header)]
|
[h (trim-all-spaces header)]
|
||||||
[target (regexp-match reg h)])
|
[target (regexp-match reg h)])
|
||||||
|
|
@ -453,9 +445,9 @@
|
||||||
entity
|
entity
|
||||||
(mechanism (regexp-replace reg h "\\1"))))))
|
(mechanism (regexp-replace reg h "\\1"))))))
|
||||||
|
|
||||||
;; id := "Content-ID" ":" msg-id
|
;; id := "Content-ID" ":" msg-id
|
||||||
(define re:content-id (regexp (format "^~a:(.+)$" (regexp-quote "content-id" #f))))
|
(define re:content-id #rx"^(?i:content-id):(.+)$")
|
||||||
(define (id header entity)
|
(define (id header entity)
|
||||||
(let* ([reg re:content-id]
|
(let* ([reg re:content-id]
|
||||||
[h (trim-all-spaces header)]
|
[h (trim-all-spaces header)]
|
||||||
[target (regexp-match reg h)])
|
[target (regexp-match reg h)])
|
||||||
|
|
@ -464,26 +456,26 @@
|
||||||
entity
|
entity
|
||||||
(msg-id (regexp-replace reg h "\\1"))))))
|
(msg-id (regexp-replace reg h "\\1"))))))
|
||||||
|
|
||||||
;; From rfc822:
|
;; From rfc822:
|
||||||
;; msg-id = "<" addr-spec ">" ; Unique message id
|
;; msg-id = "<" addr-spec ">" ; Unique message id
|
||||||
;; addr-spec = local-part "@" domain ; global address
|
;; addr-spec = local-part "@" domain ; global address
|
||||||
;; local-part = word *("." word) ; uninterpreted
|
;; local-part = word *("." word) ; uninterpreted
|
||||||
;; ; case-preserved
|
;; ; case-preserved
|
||||||
;; domain = sub-domain *("." sub-domain)
|
;; domain = sub-domain *("." sub-domain)
|
||||||
;; sub-domain = domain-ref / domain-literal
|
;; sub-domain = domain-ref / domain-literal
|
||||||
;; domain-literal = "[" *(dtext / quoted-pair) "]"
|
;; domain-literal = "[" *(dtext / quoted-pair) "]"
|
||||||
;; domain-ref = atom ; symbolic reference
|
;; domain-ref = atom ; symbolic reference
|
||||||
(define (msg-id str)
|
(define (msg-id str)
|
||||||
(let* ([r (regexp "^<[^@>]+@[^.]+(\\.[^.]+)*>$")]
|
(let* ([r (regexp "^<[^@>]+@[^.]+(\\.[^.]+)*>$")]
|
||||||
[ans (regexp-match r str)])
|
[ans (regexp-match r str)])
|
||||||
(if ans
|
(if ans
|
||||||
str
|
str
|
||||||
(begin (warning "Invalid msg-id: ~a" str) str))))
|
(begin (warning "Invalid msg-id: ~a" str) str))))
|
||||||
|
|
||||||
;; mechanism := "7bit" / "8bit" / "binary" /
|
;; mechanism := "7bit" / "8bit" / "binary" /
|
||||||
;; "quoted-printable" / "base64" /
|
;; "quoted-printable" / "base64" /
|
||||||
;; ietf-token / x-token
|
;; ietf-token / x-token
|
||||||
(define (mechanism mech)
|
(define (mechanism mech)
|
||||||
(if (not mech)
|
(if (not mech)
|
||||||
(raise (make-empty-mechanism))
|
(raise (make-empty-mechanism))
|
||||||
(let ([val (assoc (lowercase mech) mechanism-alist)])
|
(let ([val (assoc (lowercase mech) mechanism-alist)])
|
||||||
|
|
@ -491,112 +483,111 @@
|
||||||
(ietf-token mech)
|
(ietf-token mech)
|
||||||
(x-token mech)))))
|
(x-token mech)))))
|
||||||
|
|
||||||
;; MIME-extension-field := <Any RFC 822 header field which
|
;; MIME-extension-field := <Any RFC 822 header field which
|
||||||
;; begins with the string
|
;; begins with the string
|
||||||
;; "Content-">
|
;; "Content-">
|
||||||
;;
|
;;
|
||||||
(define (MIME-extension-field header entity)
|
(define (MIME-extension-field header entity)
|
||||||
(let* ([reg (regexp "^[Cc]ontent-(.+):[ \t]*(.+)$")]
|
(let* ([reg (regexp "^[Cc]ontent-(.+):[ \t]*(.+)$")]
|
||||||
[target (regexp-match reg header)])
|
[target (regexp-match reg header)])
|
||||||
(and target
|
(and target
|
||||||
(set-entity-other!
|
(set-entity-other!
|
||||||
entity
|
entity
|
||||||
(append (entity-other entity)
|
(append (entity-other entity)
|
||||||
(list
|
(list (cons (regexp-replace reg header "\\1")
|
||||||
(cons (regexp-replace reg header "\\1")
|
|
||||||
(trim-spaces (regexp-replace reg header "\\2")))))))))
|
(trim-spaces (regexp-replace reg header "\\2")))))))))
|
||||||
|
|
||||||
;; type := discrete-type / composite-type
|
;; type := discrete-type / composite-type
|
||||||
(define (type value)
|
(define (type value)
|
||||||
(if (not value)
|
(if (not value)
|
||||||
(raise (make-empty-type))
|
(raise (make-empty-type))
|
||||||
(or (discrete-type value)
|
(or (discrete-type value)
|
||||||
(composite-type value))))
|
(composite-type value))))
|
||||||
|
|
||||||
;; disposition-type := "inline" / "attachment" / extension-token
|
;; disposition-type := "inline" / "attachment" / extension-token
|
||||||
(define (disp-type value)
|
(define (disp-type value)
|
||||||
(if (not value)
|
(if (not value)
|
||||||
(raise (make-empty-disposition-type))
|
(raise (make-empty-disposition-type))
|
||||||
(let ([val (assoc (lowercase (trim-spaces value)) disposition-alist)])
|
(let ([val (assoc (lowercase (trim-spaces value)) disposition-alist)])
|
||||||
(if val (cdr val) (extension-token value)))))
|
(if val (cdr val) (extension-token value)))))
|
||||||
|
|
||||||
;; discrete-type := "text" / "image" / "audio" / "video" /
|
;; discrete-type := "text" / "image" / "audio" / "video" /
|
||||||
;; "application" / extension-token
|
;; "application" / extension-token
|
||||||
(define (discrete-type value)
|
(define (discrete-type value)
|
||||||
(let ([val (assoc (lowercase (trim-spaces value)) discrete-alist)])
|
(let ([val (assoc (lowercase (trim-spaces value)) discrete-alist)])
|
||||||
(if val (cdr val) (extension-token value))))
|
(if val (cdr val) (extension-token value))))
|
||||||
|
|
||||||
;; composite-type := "message" / "multipart" / extension-token
|
;; composite-type := "message" / "multipart" / extension-token
|
||||||
(define (composite-type value)
|
(define (composite-type value)
|
||||||
(let ([val (assoc (lowercase (trim-spaces value)) composite-alist)])
|
(let ([val (assoc (lowercase (trim-spaces value)) composite-alist)])
|
||||||
(if val (cdr val) (extension-token value))))
|
(if val (cdr val) (extension-token value))))
|
||||||
|
|
||||||
;; extension-token := ietf-token / x-token
|
;; extension-token := ietf-token / x-token
|
||||||
(define (extension-token value)
|
(define (extension-token value)
|
||||||
(or (ietf-token value)
|
(or (ietf-token value)
|
||||||
(x-token value)))
|
(x-token value)))
|
||||||
|
|
||||||
;; ietf-token := <An extension token defined by a
|
;; ietf-token := <An extension token defined by a
|
||||||
;; standards-track RFC and registered
|
;; standards-track RFC and registered
|
||||||
;; with IANA.>
|
;; with IANA.>
|
||||||
(define (ietf-token value)
|
(define (ietf-token value)
|
||||||
(let ([ans (assoc (lowercase (trim-spaces value)) ietf-extensions)])
|
(let ([ans (assoc (lowercase (trim-spaces value)) ietf-extensions)])
|
||||||
(and ans (cdr ans))))
|
(and ans (cdr ans))))
|
||||||
|
|
||||||
;; Directly from RFC 1700:
|
;; Directly from RFC 1700:
|
||||||
;; Type Subtype Description Reference
|
;; Type Subtype Description Reference
|
||||||
;; ---- ------- ----------- ---------
|
;; ---- ------- ----------- ---------
|
||||||
;; text plain [RFC1521,NSB]
|
;; text plain [RFC1521,NSB]
|
||||||
;; richtext [RFC1521,NSB]
|
;; richtext [RFC1521,NSB]
|
||||||
;; tab-separated-values [Paul Lindner]
|
;; tab-separated-values [Paul Lindner]
|
||||||
;;
|
;;
|
||||||
;; multipart mixed [RFC1521,NSB]
|
;; multipart mixed [RFC1521,NSB]
|
||||||
;; alternative [RFC1521,NSB]
|
;; alternative [RFC1521,NSB]
|
||||||
;; digest [RFC1521,NSB]
|
;; digest [RFC1521,NSB]
|
||||||
;; parallel [RFC1521,NSB]
|
;; parallel [RFC1521,NSB]
|
||||||
;; appledouble [MacMime,Patrik Faltstrom]
|
;; appledouble [MacMime,Patrik Faltstrom]
|
||||||
;; header-set [Dave Crocker]
|
;; header-set [Dave Crocker]
|
||||||
;;
|
;;
|
||||||
;; message rfc822 [RFC1521,NSB]
|
;; message rfc822 [RFC1521,NSB]
|
||||||
;; partial [RFC1521,NSB]
|
;; partial [RFC1521,NSB]
|
||||||
;; external-body [RFC1521,NSB]
|
;; external-body [RFC1521,NSB]
|
||||||
;; news [RFC 1036, Henry Spencer]
|
;; news [RFC 1036, Henry Spencer]
|
||||||
;;
|
;;
|
||||||
;; application octet-stream [RFC1521,NSB]
|
;; application octet-stream [RFC1521,NSB]
|
||||||
;; postscript [RFC1521,NSB]
|
;; postscript [RFC1521,NSB]
|
||||||
;; oda [RFC1521,NSB]
|
;; oda [RFC1521,NSB]
|
||||||
;; atomicmail [atomicmail,NSB]
|
;; atomicmail [atomicmail,NSB]
|
||||||
;; andrew-inset [andrew-inset,NSB]
|
;; andrew-inset [andrew-inset,NSB]
|
||||||
;; slate [slate,terry crowley]
|
;; slate [slate,terry crowley]
|
||||||
;; wita [Wang Info Transfer,Larry Campbell]
|
;; wita [Wang Info Transfer,Larry Campbell]
|
||||||
;; dec-dx [Digital Doc Trans, Larry Campbell]
|
;; dec-dx [Digital Doc Trans, Larry Campbell]
|
||||||
;; dca-rft [IBM Doc Content Arch, Larry Campbell]
|
;; dca-rft [IBM Doc Content Arch, Larry Campbell]
|
||||||
;; activemessage [Ehud Shapiro]
|
;; activemessage [Ehud Shapiro]
|
||||||
;; rtf [Paul Lindner]
|
;; rtf [Paul Lindner]
|
||||||
;; applefile [MacMime,Patrik Faltstrom]
|
;; applefile [MacMime,Patrik Faltstrom]
|
||||||
;; mac-binhex40 [MacMime,Patrik Faltstrom]
|
;; mac-binhex40 [MacMime,Patrik Faltstrom]
|
||||||
;; news-message-id [RFC1036, Henry Spencer]
|
;; news-message-id [RFC1036, Henry Spencer]
|
||||||
;; news-transmission [RFC1036, Henry Spencer]
|
;; news-transmission [RFC1036, Henry Spencer]
|
||||||
;; wordperfect5.1 [Paul Lindner]
|
;; wordperfect5.1 [Paul Lindner]
|
||||||
;; pdf [Paul Lindner]
|
;; pdf [Paul Lindner]
|
||||||
;; zip [Paul Lindner]
|
;; zip [Paul Lindner]
|
||||||
;; macwriteii [Paul Lindner]
|
;; macwriteii [Paul Lindner]
|
||||||
;; msword [Paul Lindner]
|
;; msword [Paul Lindner]
|
||||||
;; remote-printing [RFC1486,MTR]
|
;; remote-printing [RFC1486,MTR]
|
||||||
;;
|
;;
|
||||||
;; image jpeg [RFC1521,NSB]
|
;; image jpeg [RFC1521,NSB]
|
||||||
;; gif [RFC1521,NSB]
|
;; gif [RFC1521,NSB]
|
||||||
;; ief Image Exchange Format [RFC1314]
|
;; ief Image Exchange Format [RFC1314]
|
||||||
;; tiff Tag Image File Format [MTR]
|
;; tiff Tag Image File Format [MTR]
|
||||||
;;
|
;;
|
||||||
;; audio basic [RFC1521,NSB]
|
;; audio basic [RFC1521,NSB]
|
||||||
;;
|
;;
|
||||||
;; video mpeg [RFC1521,NSB]
|
;; video mpeg [RFC1521,NSB]
|
||||||
;; quicktime [Paul Lindner]
|
;; quicktime [Paul Lindner]
|
||||||
|
|
||||||
;; x-token := <The two characters "X-" or "x-" followed, with
|
;; x-token := <The two characters "X-" or "x-" followed, with
|
||||||
;; no intervening white space, by any token>
|
;; no intervening white space, by any token>
|
||||||
(define (x-token value)
|
(define (x-token value)
|
||||||
(let* ([r #rx"^[xX]-(.*)"]
|
(let* ([r #rx"^[xX]-(.*)"]
|
||||||
[h (trim-spaces value)]
|
[h (trim-spaces value)]
|
||||||
[ans (regexp-match r h)])
|
[ans (regexp-match r h)])
|
||||||
|
|
@ -604,23 +595,23 @@
|
||||||
(token (regexp-replace r h "\\1"))
|
(token (regexp-replace r h "\\1"))
|
||||||
h)))
|
h)))
|
||||||
|
|
||||||
;; subtype := extension-token / iana-token
|
;; subtype := extension-token / iana-token
|
||||||
(define (subtype value)
|
(define (subtype value)
|
||||||
(if (not value)
|
(if (not value)
|
||||||
(raise (make-empty-subtype))
|
(raise (make-empty-subtype))
|
||||||
(or (extension-token value)
|
(or (extension-token value)
|
||||||
(iana-token value))))
|
(iana-token value))))
|
||||||
|
|
||||||
;; iana-token := <A publicly-defined extension token. Tokens
|
;; iana-token := <A publicly-defined extension token. Tokens
|
||||||
;; of this form must be registered with IANA
|
;; of this form must be registered with IANA
|
||||||
;; as specified in RFC 2048.>
|
;; as specified in RFC 2048.>
|
||||||
(define (iana-token value)
|
(define (iana-token value)
|
||||||
(let ([ans (assoc (lowercase (trim-spaces value)) iana-extensions)])
|
(let ([ans (assoc (lowercase (trim-spaces value)) iana-extensions)])
|
||||||
(and ans (cdr ans))))
|
(and ans (cdr ans))))
|
||||||
|
|
||||||
;; parameter := attribute "=" value
|
;; parameter := attribute "=" value
|
||||||
(define re:parameter (regexp "([^=]+)=(.+)"))
|
(define re:parameter (regexp "([^=]+)=(.+)"))
|
||||||
(define (parameter par)
|
(define (parameter par)
|
||||||
(let* ([r re:parameter]
|
(let* ([r re:parameter]
|
||||||
[att (attribute (regexp-replace r par "\\1"))]
|
[att (attribute (regexp-replace r par "\\1"))]
|
||||||
[val (value (regexp-replace r par "\\2"))])
|
[val (value (regexp-replace r par "\\2"))])
|
||||||
|
|
@ -628,54 +619,54 @@
|
||||||
(cons (if att (lowercase att) "???") val)
|
(cons (if att (lowercase att) "???") val)
|
||||||
(cons "???" par))))
|
(cons "???" par))))
|
||||||
|
|
||||||
;; value := token / quoted-string
|
;; value := token / quoted-string
|
||||||
(define (value val)
|
(define (value val)
|
||||||
(or (token val)
|
(or (token val)
|
||||||
(quoted-string val)
|
(quoted-string val)
|
||||||
val))
|
val))
|
||||||
|
|
||||||
;; token := 1*<any (US-ASCII) CHAR except SPACE, CTLs,
|
;; token := 1*<any (US-ASCII) CHAR except SPACE, CTLs,
|
||||||
;; or tspecials>
|
;; or tspecials>
|
||||||
;; tspecials := "(" / ")" / "<" / ">" / "@" /
|
;; tspecials := "(" / ")" / "<" / ">" / "@" /
|
||||||
;; "," / ";" / ":" / "\" / <">
|
;; "," / ";" / ":" / "\" / <">
|
||||||
;; "/" / "[" / "]" / "?" / "="
|
;; "/" / "[" / "]" / "?" / "="
|
||||||
;; ; Must be in quoted-string,
|
;; ; Must be in quoted-string,
|
||||||
;; ; to use within parameter values
|
;; ; to use within parameter values
|
||||||
(define (token value)
|
(define (token value)
|
||||||
(let* ([tspecials (regexp "[^][()<>@,;:\\\"/?= ]+")]
|
(let* ([tspecials (regexp "[^][()<>@,;:\\\"/?= ]+")]
|
||||||
[ans (regexp-match tspecials value)])
|
[ans (regexp-match tspecials value)])
|
||||||
(and ans
|
(and ans
|
||||||
(string=? value (car ans))
|
(string=? value (car ans))
|
||||||
(car ans))))
|
(car ans))))
|
||||||
|
|
||||||
;; attribute := token
|
;; attribute := token
|
||||||
;; ; Matching of attributes
|
;; ; Matching of attributes
|
||||||
;; ; is ALWAYS case-insensitive.
|
;; ; is ALWAYS case-insensitive.
|
||||||
(define attribute token)
|
(define attribute token)
|
||||||
|
|
||||||
(define re:quotes (regexp "\"(.+)\""))
|
(define re:quotes (regexp "\"(.+)\""))
|
||||||
(define (quoted-string str)
|
(define (quoted-string str)
|
||||||
(let* ([quotes re:quotes]
|
(let* ([quotes re:quotes]
|
||||||
[ans (regexp-match quotes str)])
|
[ans (regexp-match quotes str)])
|
||||||
(and ans (regexp-replace quotes str "\\1"))))
|
(and ans (regexp-replace quotes str "\\1"))))
|
||||||
|
|
||||||
;; disposition-parm := filename-parm
|
;; disposition-parm := filename-parm
|
||||||
;; / creation-date-parm
|
;; / creation-date-parm
|
||||||
;; / modification-date-parm
|
;; / modification-date-parm
|
||||||
;; / read-date-parm
|
;; / read-date-parm
|
||||||
;; / size-parm
|
;; / size-parm
|
||||||
;; / parameter
|
;; / parameter
|
||||||
;;
|
;;
|
||||||
;; filename-parm := "filename" "=" value
|
;; filename-parm := "filename" "=" value
|
||||||
;;
|
;;
|
||||||
;; creation-date-parm := "creation-date" "=" quoted-date-time
|
;; creation-date-parm := "creation-date" "=" quoted-date-time
|
||||||
;;
|
;;
|
||||||
;; modification-date-parm := "modification-date" "=" quoted-date-time
|
;; modification-date-parm := "modification-date" "=" quoted-date-time
|
||||||
;;
|
;;
|
||||||
;; read-date-parm := "read-date" "=" quoted-date-time
|
;; read-date-parm := "read-date" "=" quoted-date-time
|
||||||
;;
|
;;
|
||||||
;; size-parm := "size" "=" 1*DIGIT
|
;; size-parm := "size" "=" 1*DIGIT
|
||||||
(define (disp-params lst disp)
|
(define (disp-params lst disp)
|
||||||
(let loop ([lst lst])
|
(let loop ([lst lst])
|
||||||
(unless (null? lst)
|
(unless (null? lst)
|
||||||
(let* ([p (parameter (trim-all-spaces (car lst)))]
|
(let* ([p (parameter (trim-all-spaces (car lst)))]
|
||||||
|
|
@ -705,42 +696,42 @@
|
||||||
(append (disposition-params disp) (list p)))])
|
(append (disposition-params disp) (list p)))])
|
||||||
(loop (cdr lst))))))
|
(loop (cdr lst))))))
|
||||||
|
|
||||||
;; date-time = [ day "," ] date time ; dd mm yy
|
;; date-time = [ day "," ] date time ; dd mm yy
|
||||||
;; ; hh:mm:ss zzz
|
;; ; hh:mm:ss zzz
|
||||||
;;
|
;;
|
||||||
;; day = "Mon" / "Tue" / "Wed" / "Thu"
|
;; day = "Mon" / "Tue" / "Wed" / "Thu"
|
||||||
;; / "Fri" / "Sat" / "Sun"
|
;; / "Fri" / "Sat" / "Sun"
|
||||||
;;
|
;;
|
||||||
;; date = 1*2DIGIT month 2DIGIT ; day month year
|
;; date = 1*2DIGIT month 2DIGIT ; day month year
|
||||||
;; ; e.g. 20 Jun 82
|
;; ; e.g. 20 Jun 82
|
||||||
;;
|
;;
|
||||||
;; month = "Jan" / "Feb" / "Mar" / "Apr"
|
;; month = "Jan" / "Feb" / "Mar" / "Apr"
|
||||||
;; / "May" / "Jun" / "Jul" / "Aug"
|
;; / "May" / "Jun" / "Jul" / "Aug"
|
||||||
;; / "Sep" / "Oct" / "Nov" / "Dec"
|
;; / "Sep" / "Oct" / "Nov" / "Dec"
|
||||||
;;
|
;;
|
||||||
;; time = hour zone ; ANSI and Military
|
;; time = hour zone ; ANSI and Military
|
||||||
;;
|
;;
|
||||||
;; hour = 2DIGIT ":" 2DIGIT [":" 2DIGIT]
|
;; hour = 2DIGIT ":" 2DIGIT [":" 2DIGIT]
|
||||||
;; ; 00:00:00 - 23:59:59
|
;; ; 00:00:00 - 23:59:59
|
||||||
;;
|
;;
|
||||||
;; zone = "UT" / "GMT" ; Universal Time
|
;; zone = "UT" / "GMT" ; Universal Time
|
||||||
;; ; North American : UT
|
;; ; North American : UT
|
||||||
;; / "EST" / "EDT" ; Eastern: - 5/ - 4
|
;; / "EST" / "EDT" ; Eastern: - 5/ - 4
|
||||||
;; / "CST" / "CDT" ; Central: - 6/ - 5
|
;; / "CST" / "CDT" ; Central: - 6/ - 5
|
||||||
;; / "MST" / "MDT" ; Mountain: - 7/ - 6
|
;; / "MST" / "MDT" ; Mountain: - 7/ - 6
|
||||||
;; / "PST" / "PDT" ; Pacific: - 8/ - 7
|
;; / "PST" / "PDT" ; Pacific: - 8/ - 7
|
||||||
;; / 1ALPHA ; Military: Z = UT;
|
;; / 1ALPHA ; Military: Z = UT;
|
||||||
;; ; A:-1; (J not used)
|
;; ; A:-1; (J not used)
|
||||||
;; ; M:-12; N:+1; Y:+12
|
;; ; M:-12; N:+1; Y:+12
|
||||||
;; / ( ("+" / "-") 4DIGIT ) ; Local differential
|
;; / ( ("+" / "-") 4DIGIT ) ; Local differential
|
||||||
;; ; hours+min. (HHMM)
|
;; ; hours+min. (HHMM)
|
||||||
(define date-time
|
(define date-time
|
||||||
(lambda (str)
|
(lambda (str)
|
||||||
;; Fix Me: I have to return a date structure, or time in seconds.
|
;; Fix Me: I have to return a date structure, or time in seconds.
|
||||||
str))
|
str))
|
||||||
|
|
||||||
;; quoted-date-time := quoted-string
|
;; quoted-date-time := quoted-string
|
||||||
;; ; contents MUST be an RFC 822 `date-time'
|
;; ; contents MUST be an RFC 822 `date-time'
|
||||||
;; ; numeric timezones (+HHMM or -HHMM) MUST be used
|
;; ; numeric timezones (+HHMM or -HHMM) MUST be used
|
||||||
|
|
||||||
(define disp-quoted-data-time date-time)
|
(define disp-quoted-data-time date-time)
|
||||||
|
|
|
||||||
|
|
@ -28,36 +28,32 @@
|
||||||
|
|
||||||
#lang scheme/unit
|
#lang scheme/unit
|
||||||
|
|
||||||
(require "qp-sig.ss"
|
(require "qp-sig.ss")
|
||||||
mzlib/etc)
|
|
||||||
|
|
||||||
(import)
|
(import)
|
||||||
(export qp^)
|
(export qp^)
|
||||||
|
|
||||||
;; Exceptions:
|
;; Exceptions:
|
||||||
;; String or input-port expected:
|
;; String or input-port expected:
|
||||||
(define-struct qp-error ())
|
(define-struct qp-error ())
|
||||||
(define-struct (qp-wrong-input qp-error) ())
|
(define-struct (qp-wrong-input qp-error) ())
|
||||||
(define-struct (qp-wrong-line-size qp-error) (size))
|
(define-struct (qp-wrong-line-size qp-error) (size))
|
||||||
|
|
||||||
;; qp-encode : bytes -> bytes
|
;; qp-encode : bytes -> bytes
|
||||||
;; returns the quoted printable representation of STR.
|
;; returns the quoted printable representation of STR.
|
||||||
(define qp-encode
|
(define (qp-encode str)
|
||||||
(lambda (str)
|
|
||||||
(let ([out (open-output-bytes)])
|
(let ([out (open-output-bytes)])
|
||||||
(qp-encode-stream (open-input-bytes str) out #"\r\n")
|
(qp-encode-stream (open-input-bytes str) out #"\r\n")
|
||||||
(get-output-bytes out))))
|
(get-output-bytes out)))
|
||||||
|
|
||||||
;; qp-decode : string -> string
|
;; qp-decode : string -> string
|
||||||
;; returns STR unqp.
|
;; returns STR unqp.
|
||||||
(define qp-decode
|
(define (qp-decode str)
|
||||||
(lambda (str)
|
|
||||||
(let ([out (open-output-bytes)])
|
(let ([out (open-output-bytes)])
|
||||||
(qp-decode-stream (open-input-bytes str) out)
|
(qp-decode-stream (open-input-bytes str) out)
|
||||||
(get-output-bytes out))))
|
(get-output-bytes out)))
|
||||||
|
|
||||||
(define qp-decode-stream
|
(define (qp-decode-stream in out)
|
||||||
(lambda (in out)
|
|
||||||
(let loop ([ch (read-byte in)])
|
(let loop ([ch (read-byte in)])
|
||||||
(unless (eof-object? ch)
|
(unless (eof-object? ch)
|
||||||
(case ch
|
(case ch
|
||||||
|
|
@ -98,33 +94,27 @@
|
||||||
(loop (read-byte in)))]
|
(loop (read-byte in)))]
|
||||||
[else
|
[else
|
||||||
(write-byte ch out)
|
(write-byte ch out)
|
||||||
(loop (read-byte in))])))))
|
(loop (read-byte in))]))))
|
||||||
|
|
||||||
(define warning
|
(define (warning msg . args)
|
||||||
(lambda (msg . args)
|
|
||||||
(when #f
|
(when #f
|
||||||
(fprintf (current-error-port)
|
(fprintf (current-error-port)
|
||||||
(apply format msg args))
|
(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))
|
(vector-ref hex-values i))
|
||||||
|
|
||||||
(define hex-bytes->byte
|
(define (hex-bytes->byte b1 b2)
|
||||||
(lambda (b1 b2)
|
|
||||||
(+ (* 16 (vector-ref hex-values b1))
|
(+ (* 16 (vector-ref hex-values b1))
|
||||||
(vector-ref hex-values b2))))
|
(vector-ref hex-values b2)))
|
||||||
|
|
||||||
(define write-hex-bytes
|
(define (write-hex-bytes byte p)
|
||||||
(lambda (byte p)
|
|
||||||
(write-byte 61 p)
|
(write-byte 61 p)
|
||||||
(write-byte (vector-ref hex-bytes (arithmetic-shift byte -4)) 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 in out [newline-string #"\n"])
|
||||||
|
|
||||||
(define qp-encode-stream
|
|
||||||
(opt-lambda (in out [newline-string #"\n"])
|
|
||||||
(let loop ([col 0])
|
(let loop ([col 0])
|
||||||
(if (= col 75)
|
(if (= col 75)
|
||||||
(begin
|
(begin
|
||||||
|
|
@ -155,17 +145,17 @@
|
||||||
[else
|
[else
|
||||||
;; an octect
|
;; an octect
|
||||||
(write-hex-bytes i out)
|
(write-hex-bytes i out)
|
||||||
(loop (+ col 3))]))))))
|
(loop (+ col 3))])))))
|
||||||
|
|
||||||
;; Tables
|
;; Tables
|
||||||
(define hex-values (make-vector 256 #f))
|
(define hex-values (make-vector 256 #f))
|
||||||
(define hex-bytes (make-vector 16))
|
(define hex-bytes (make-vector 16))
|
||||||
(let loop ([i 0])
|
(let loop ([i 0])
|
||||||
(unless (= i 10)
|
(unless (= i 10)
|
||||||
(vector-set! hex-values (+ i 48) i)
|
(vector-set! hex-values (+ i 48) i)
|
||||||
(vector-set! hex-bytes i (+ i 48))
|
(vector-set! hex-bytes i (+ i 48))
|
||||||
(loop (add1 i))))
|
(loop (add1 i))))
|
||||||
(let loop ([i 0])
|
(let loop ([i 0])
|
||||||
(unless (= i 6)
|
(unless (= i 6)
|
||||||
(vector-set! hex-values (+ i 65) (+ 10 i))
|
(vector-set! hex-values (+ i 65) (+ 10 i))
|
||||||
(vector-set! hex-values (+ i 97) (+ 10 i))
|
(vector-set! hex-values (+ i 97) (+ 10 i))
|
||||||
|
|
|
||||||
|
|
@ -1,16 +1,16 @@
|
||||||
#lang scheme/unit
|
#lang scheme/unit
|
||||||
|
|
||||||
(require mzlib/process "sendmail-sig.ss")
|
(require mzlib/process "sendmail-sig.ss")
|
||||||
|
|
||||||
(import)
|
(import)
|
||||||
(export sendmail^)
|
(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"))
|
'("/usr/lib" "/usr/sbin"))
|
||||||
|
|
||||||
(define sendmail-program-file
|
(define sendmail-program-file
|
||||||
(if (or (eq? (system-type) 'unix)
|
(if (or (eq? (system-type) 'unix)
|
||||||
(eq? (system-type) 'macosx))
|
(eq? (system-type) 'macosx))
|
||||||
(let loop ([paths sendmail-search-path])
|
(let loop ([paths sendmail-search-path])
|
||||||
|
|
@ -27,20 +27,20 @@
|
||||||
"sendmail only available under Unix"
|
"sendmail only available under Unix"
|
||||||
(current-continuation-marks)))))
|
(current-continuation-marks)))))
|
||||||
|
|
||||||
;; send-mail-message/port :
|
;; send-mail-message/port :
|
||||||
;; string x string x list (string) x list (string) x list (string)
|
;; string x string x list (string) x list (string) x list (string)
|
||||||
;; [x list (string)] -> oport
|
;; [x list (string)] -> oport
|
||||||
|
|
||||||
;; -- sender can be anything, though spoofing is not recommended.
|
;; -- sender can be anything, though spoofing is not recommended.
|
||||||
;; The recipients must all be pure email addresses. Note that
|
;; The recipients must all be pure email addresses. Note that
|
||||||
;; everything is expected to follow RFC conventions. If any other
|
;; everything is expected to follow RFC conventions. If any other
|
||||||
;; headers are specified, they are expected to be completely
|
;; headers are specified, they are expected to be completely
|
||||||
;; formatted already. Clients are urged to use close-output-port on
|
;; formatted already. Clients are urged to use close-output-port on
|
||||||
;; the port returned by this procedure as soon as the necessary text
|
;; the port returned by this procedure as soon as the necessary text
|
||||||
;; has been written, so that the sendmail process can complete.
|
;; has been written, so that the sendmail process can complete.
|
||||||
|
|
||||||
(define send-mail-message/port
|
(define (send-mail-message/port
|
||||||
(lambda (sender subject to-recipients cc-recipients bcc-recipients
|
sender subject to-recipients cc-recipients bcc-recipients
|
||||||
. other-headers)
|
. other-headers)
|
||||||
(when (and (null? to-recipients) (null? cc-recipients)
|
(when (and (null? to-recipients) (null? cc-recipients)
|
||||||
(null? bcc-recipients))
|
(null? bcc-recipients))
|
||||||
|
|
@ -94,20 +94,20 @@
|
||||||
(newline writer))
|
(newline writer))
|
||||||
other-headers)
|
other-headers)
|
||||||
(newline writer)
|
(newline writer)
|
||||||
writer))))
|
writer)))
|
||||||
|
|
||||||
;; send-mail-message :
|
;; send-mail-message :
|
||||||
;; string x string x list (string) x list (string) x list (string) x
|
;; string x string x list (string) x list (string) x list (string) x
|
||||||
;; list (string) [x list (string)] -> ()
|
;; list (string) [x list (string)] -> ()
|
||||||
|
|
||||||
;; -- sender can be anything, though spoofing is not recommended. The
|
;; -- sender can be anything, though spoofing is not recommended. The
|
||||||
;; recipients must all be pure email addresses. The text is expected
|
;; recipients must all be pure email addresses. The text is expected
|
||||||
;; to be pre-formatted. Note that everything is expected to follow
|
;; to be pre-formatted. Note that everything is expected to follow
|
||||||
;; RFC conventions. If any other headers are specified, they are
|
;; RFC conventions. If any other headers are specified, they are
|
||||||
;; expected to be completely formatted already.
|
;; expected to be completely formatted already.
|
||||||
|
|
||||||
(define send-mail-message
|
(define (send-mail-message
|
||||||
(lambda (sender subject to-recipients cc-recipients bcc-recipients text
|
sender subject to-recipients cc-recipients bcc-recipients text
|
||||||
. other-headers)
|
. other-headers)
|
||||||
(let ([writer (apply send-mail-message/port sender subject
|
(let ([writer (apply send-mail-message/port sender subject
|
||||||
to-recipients cc-recipients bcc-recipients
|
to-recipients cc-recipients bcc-recipients
|
||||||
|
|
@ -116,4 +116,4 @@
|
||||||
(display s writer) ; We use -i, so "." is not a problem
|
(display s writer) ; We use -i, so "." is not a problem
|
||||||
(newline writer))
|
(newline writer))
|
||||||
text)
|
text)
|
||||||
(close-output-port writer))))
|
(close-output-port writer)))
|
||||||
|
|
|
||||||
|
|
@ -9,28 +9,21 @@
|
||||||
;; "impure" = they have text waiting
|
;; "impure" = they have text waiting
|
||||||
;; "pure" = the MIME headers have been read
|
;; "pure" = the MIME headers have been read
|
||||||
|
|
||||||
(module url-unit scheme/base
|
#lang scheme/unit
|
||||||
(require mzlib/file
|
(require scheme/port
|
||||||
mzlib/unit
|
|
||||||
mzlib/port
|
|
||||||
mzlib/list
|
|
||||||
mzlib/string
|
|
||||||
mzlib/kw
|
|
||||||
"url-structs.ss"
|
"url-structs.ss"
|
||||||
"uri-codec.ss"
|
"uri-codec.ss"
|
||||||
"url-sig.ss"
|
"url-sig.ss"
|
||||||
"tcp-sig.ss")
|
"tcp-sig.ss")
|
||||||
(provide url@)
|
|
||||||
|
|
||||||
(define-unit url@
|
(import tcp^)
|
||||||
(import tcp^)
|
(export url^)
|
||||||
(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
|
(make-parameter null
|
||||||
(lambda (v)
|
(lambda (v)
|
||||||
(unless (and (list? v)
|
(unless (and (list? v)
|
||||||
|
|
@ -54,14 +47,14 @@
|
||||||
(caddr v)))
|
(caddr v)))
|
||||||
v))))
|
v))))
|
||||||
|
|
||||||
(define (url-error fmt . args)
|
(define (url-error fmt . args)
|
||||||
(raise (make-url-exception
|
(raise (make-url-exception
|
||||||
(apply format fmt
|
(apply format fmt
|
||||||
(map (lambda (arg) (if (url? arg) (url->string arg) arg))
|
(map (lambda (arg) (if (url? arg) (url->string arg) arg))
|
||||||
args))
|
args))
|
||||||
(current-continuation-marks))))
|
(current-continuation-marks))))
|
||||||
|
|
||||||
(define (url->string url)
|
(define (url->string url)
|
||||||
(let ([scheme (url-scheme url)]
|
(let ([scheme (url-scheme url)]
|
||||||
[user (url-user url)]
|
[user (url-user url)]
|
||||||
[host (url-host url)]
|
[host (url-host url)]
|
||||||
|
|
@ -92,24 +85,24 @@
|
||||||
(if (null? query) "" (sa "?" (alist->form-urlencoded query)))
|
(if (null? query) "" (sa "?" (alist->form-urlencoded query)))
|
||||||
(if fragment (sa "#" (uri-encode fragment)) ""))))
|
(if fragment (sa "#" (uri-encode fragment)) ""))))
|
||||||
|
|
||||||
;; url->default-port : url -> num
|
;; url->default-port : url -> num
|
||||||
(define (url->default-port url)
|
(define (url->default-port url)
|
||||||
(let ([scheme (url-scheme url)])
|
(let ([scheme (url-scheme url)])
|
||||||
(cond [(not scheme) 80]
|
(cond [(not scheme) 80]
|
||||||
[(string=? scheme "http") 80]
|
[(string=? scheme "http") 80]
|
||||||
[(string=? scheme "https") 443]
|
[(string=? scheme "https") 443]
|
||||||
[else (url-error "Scheme ~a not supported" (url-scheme url))])))
|
[else (url-error "Scheme ~a not supported" (url-scheme url))])))
|
||||||
|
|
||||||
;; make-ports : url -> in-port x out-port
|
;; make-ports : url -> in-port x out-port
|
||||||
(define (make-ports url proxy)
|
(define (make-ports url proxy)
|
||||||
(let ([port-number (if proxy
|
(let ([port-number (if proxy
|
||||||
(caddr proxy)
|
(caddr proxy)
|
||||||
(or (url-port url) (url->default-port url)))]
|
(or (url-port url) (url->default-port url)))]
|
||||||
[host (if proxy (cadr proxy) (url-host url))])
|
[host (if proxy (cadr proxy) (url-host url))])
|
||||||
(tcp-connect host port-number)))
|
(tcp-connect host port-number)))
|
||||||
|
|
||||||
;; http://getpost-impure-port : bool x url x union (str, #f) x list (str) -> in-port
|
;; 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)
|
(define (http://getpost-impure-port get? url post-data strings)
|
||||||
(let*-values
|
(let*-values
|
||||||
([(proxy) (assoc (url-scheme url) (current-proxy-servers))]
|
([(proxy) (assoc (url-scheme url) (current-proxy-servers))]
|
||||||
[(server->client client->server) (make-ports url proxy)]
|
[(server->client client->server) (make-ports url proxy)]
|
||||||
|
|
@ -135,7 +128,7 @@
|
||||||
(tcp-abandon-port client->server)
|
(tcp-abandon-port client->server)
|
||||||
server->client))
|
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))]
|
(let ([strs (map path/param-path (url-path url))]
|
||||||
[string->path-element/same
|
[string->path-element/same
|
||||||
(lambda (e)
|
(lambda (e)
|
||||||
|
|
@ -167,35 +160,34 @@
|
||||||
(apply build-path (bytes->path #"/" 'unix) elems)
|
(apply build-path (bytes->path #"/" 'unix) elems)
|
||||||
(apply build-path elems))))))
|
(apply build-path elems))))))
|
||||||
|
|
||||||
;; file://get-pure-port : url -> in-port
|
;; file://get-pure-port : url -> in-port
|
||||||
(define (file://get-pure-port url)
|
(define (file://get-pure-port url)
|
||||||
(open-input-file (file://->path 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))
|
(url-error "Missing protocol (usually \"http:\") at the beginning of URL: ~a" url))
|
||||||
|
|
||||||
;; getpost-impure-port : bool x url x list (str) -> in-port
|
;; getpost-impure-port : bool x url x list (str) -> in-port
|
||||||
(define (getpost-impure-port get? url post-data strings)
|
(define (getpost-impure-port get? url post-data strings)
|
||||||
(let ([scheme (url-scheme url)])
|
(let ([scheme (url-scheme url)])
|
||||||
(cond [(not scheme)
|
(cond [(not scheme)
|
||||||
(schemeless-url url)]
|
(schemeless-url url)]
|
||||||
[(or (string=? scheme "http")
|
[(or (string=? scheme "http") (string=? scheme "https"))
|
||||||
(string=? scheme "https"))
|
|
||||||
(http://getpost-impure-port get? url post-data strings)]
|
(http://getpost-impure-port get? url post-data strings)]
|
||||||
[(string=? scheme "file")
|
[(string=? scheme "file")
|
||||||
(url-error "There are no impure file: ports")]
|
(url-error "There are no impure file: ports")]
|
||||||
[else (url-error "Scheme ~a unsupported" scheme)])))
|
[else (url-error "Scheme ~a unsupported" scheme)])))
|
||||||
|
|
||||||
;; get-impure-port : url [x list (str)] -> in-port
|
;; get-impure-port : url [x list (str)] -> in-port
|
||||||
(define/kw (get-impure-port url #:optional [strings '()])
|
(define (get-impure-port url [strings '()])
|
||||||
(getpost-impure-port #t url #f strings))
|
(getpost-impure-port #t url #f strings))
|
||||||
|
|
||||||
;; post-impure-port : url x bytes [x list (str)] -> in-port
|
;; post-impure-port : url x bytes [x list (str)] -> in-port
|
||||||
(define/kw (post-impure-port url post-data #:optional [strings '()])
|
(define (post-impure-port url post-data [strings '()])
|
||||||
(getpost-impure-port #f url post-data strings))
|
(getpost-impure-port #f url post-data strings))
|
||||||
|
|
||||||
;; getpost-pure-port : bool x url x list (str) -> in-port
|
;; getpost-pure-port : bool x url x list (str) -> in-port
|
||||||
(define (getpost-pure-port get? url post-data strings)
|
(define (getpost-pure-port get? url post-data strings)
|
||||||
(let ([scheme (url-scheme url)])
|
(let ([scheme (url-scheme url)])
|
||||||
(cond [(not scheme)
|
(cond [(not scheme)
|
||||||
(schemeless-url url)]
|
(schemeless-url url)]
|
||||||
|
|
@ -212,21 +204,21 @@
|
||||||
(file://get-pure-port url)]
|
(file://get-pure-port url)]
|
||||||
[else (url-error "Scheme ~a unsupported" scheme)])))
|
[else (url-error "Scheme ~a unsupported" scheme)])))
|
||||||
|
|
||||||
;; get-pure-port : url [x list (str)] -> in-port
|
;; get-pure-port : url [x list (str)] -> in-port
|
||||||
(define/kw (get-pure-port url #:optional [strings '()])
|
(define (get-pure-port url [strings '()])
|
||||||
(getpost-pure-port #t url #f strings))
|
(getpost-pure-port #t url #f strings))
|
||||||
|
|
||||||
;; post-pure-port : url bytes [x list (str)] -> in-port
|
;; post-pure-port : url bytes [x list (str)] -> in-port
|
||||||
(define/kw (post-pure-port url post-data #:optional [strings '()])
|
(define (post-pure-port url post-data [strings '()])
|
||||||
(getpost-pure-port #f url post-data strings))
|
(getpost-pure-port #f url post-data strings))
|
||||||
|
|
||||||
;; display-pure-port : in-port -> ()
|
;; display-pure-port : in-port -> ()
|
||||||
(define (display-pure-port server->client)
|
(define (display-pure-port server->client)
|
||||||
(copy-port server->client (current-output-port))
|
(copy-port server->client (current-output-port))
|
||||||
(close-input-port server->client))
|
(close-input-port server->client))
|
||||||
|
|
||||||
;; transliteration of code in rfc 3986, section 5.2.2
|
;; transliteration of code in rfc 3986, section 5.2.2
|
||||||
(define (combine-url/relative Base string)
|
(define (combine-url/relative Base string)
|
||||||
(let ([R (string->url string)]
|
(let ([R (string->url string)]
|
||||||
[T (make-url #f #f #f #f #f '() '() #f)])
|
[T (make-url #f #f #f #f #f '() '() #f)])
|
||||||
(if (url-scheme R)
|
(if (url-scheme R)
|
||||||
|
|
@ -277,16 +269,16 @@
|
||||||
(set-url-fragment! T (url-fragment R))
|
(set-url-fragment! T (url-fragment R))
|
||||||
T))
|
T))
|
||||||
|
|
||||||
(define (all-but-last lst)
|
(define (all-but-last lst)
|
||||||
(cond [(null? lst) null]
|
(cond [(null? lst) null]
|
||||||
[(null? (cdr lst)) null]
|
[(null? (cdr lst)) null]
|
||||||
[else (cons (car lst) (all-but-last (cdr lst)))]))
|
[else (cons (car lst) (all-but-last (cdr lst)))]))
|
||||||
|
|
||||||
;; cribbed from 5.2.4 in rfc 3986
|
;; cribbed from 5.2.4 in rfc 3986
|
||||||
;; the strange [*] cases implicitly change urls
|
;; the strange [*] cases implicitly change urls
|
||||||
;; with paths segments "." and ".." at the end
|
;; with paths segments "." and ".." at the end
|
||||||
;; into "./" and "../" respectively
|
;; into "./" and "../" respectively
|
||||||
(define (remove-dot-segments path)
|
(define (remove-dot-segments path)
|
||||||
(let loop ([path path] [result '()])
|
(let loop ([path path] [result '()])
|
||||||
(if (null? path)
|
(if (null? path)
|
||||||
(reverse result)
|
(reverse result)
|
||||||
|
|
@ -308,9 +300,9 @@
|
||||||
[else
|
[else
|
||||||
(cons (car path) result)]))))))
|
(cons (car path) result)]))))))
|
||||||
|
|
||||||
;; call/input-url : url x (url -> in-port) x (in-port -> T)
|
;; call/input-url : url x (url -> in-port) x (in-port -> T)
|
||||||
;; [x list (str)] -> T
|
;; [x list (str)] -> T
|
||||||
(define call/input-url
|
(define call/input-url
|
||||||
(let ([handle-port
|
(let ([handle-port
|
||||||
(lambda (server->client handler)
|
(lambda (server->client handler)
|
||||||
(dynamic-wind (lambda () 'do-nothing)
|
(dynamic-wind (lambda () 'do-nothing)
|
||||||
|
|
@ -322,16 +314,16 @@
|
||||||
[(url getter handler params)
|
[(url getter handler params)
|
||||||
(handle-port (getter url params) handler)])))
|
(handle-port (getter url params) handler)])))
|
||||||
|
|
||||||
;; purify-port : in-port -> header-string
|
;; purify-port : in-port -> header-string
|
||||||
(define (purify-port port)
|
(define (purify-port port)
|
||||||
(let ([m (regexp-match-peek-positions
|
(let ([m (regexp-match-peek-positions
|
||||||
#rx"^HTTP/.*?(?:\r\n\r\n|\n\n|\r\r)" port)])
|
#rx"^HTTP/.*?(?:\r\n\r\n|\n\n|\r\r)" port)])
|
||||||
(if m (read-string (cdar m) port) "")))
|
(if m (read-string (cdar m) port) "")))
|
||||||
|
|
||||||
(define character-set-size 256)
|
(define character-set-size 256)
|
||||||
|
|
||||||
;; netscape/string->url : str -> url
|
;; netscape/string->url : str -> url
|
||||||
(define (netscape/string->url string)
|
(define (netscape/string->url string)
|
||||||
(let ([url (string->url string)])
|
(let ([url (string->url string)])
|
||||||
(cond [(url-scheme url) url]
|
(cond [(url-scheme url) url]
|
||||||
[(string=? string "")
|
[(string=? string "")
|
||||||
|
|
@ -340,12 +332,12 @@
|
||||||
(if (char=? (string-ref string 0) #\/) "file" "http"))
|
(if (char=? (string-ref string 0) #\/) "file" "http"))
|
||||||
url])))
|
url])))
|
||||||
|
|
||||||
;; URL parsing regexp
|
;; URL parsing regexp
|
||||||
;; this is following the regexp in Appendix B of rfc 3986, except for using
|
;; 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
|
;; `*' 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
|
;; we don't want to parse it as a path element), and the user@host:port is
|
||||||
;; parsed here.
|
;; parsed here.
|
||||||
(define url-rx
|
(define url-rx
|
||||||
(regexp (string-append
|
(regexp (string-append
|
||||||
"^"
|
"^"
|
||||||
"(?:" ; / scheme-colon-opt
|
"(?:" ; / scheme-colon-opt
|
||||||
|
|
@ -369,17 +361,16 @@
|
||||||
")?" ; \
|
")?" ; \
|
||||||
"$")))
|
"$")))
|
||||||
|
|
||||||
;; string->url : str -> url
|
;; string->url : str -> url
|
||||||
;; Original version by Neil Van Dyke
|
;; Original version by Neil Van Dyke
|
||||||
(define (string->url str)
|
(define (string->url str)
|
||||||
(apply
|
(apply
|
||||||
(lambda (scheme user host port path query fragment)
|
(lambda (scheme user host port path query fragment)
|
||||||
(when (and scheme (not (regexp-match? #rx"^[a-zA-Z][a-zA-Z0-9+.-]*$"
|
(when (and scheme (not (regexp-match? #rx"^[a-zA-Z][a-zA-Z0-9+.-]*$"
|
||||||
scheme)))
|
scheme)))
|
||||||
(url-error "Invalid URL string; bad scheme ~e: ~e" scheme str))
|
(url-error "Invalid URL string; bad scheme ~e: ~e" scheme str))
|
||||||
;; Windows => "file://xxx:/...." specifies a "xxx:/..." path
|
;; Windows => "file://xxx:/...." specifies a "xxx:/..." path
|
||||||
(let ([win-file? (and (or (equal? "" port)
|
(let ([win-file? (and (or (equal? "" port) (not port))
|
||||||
(not port))
|
|
||||||
(equal? "file" scheme)
|
(equal? "file" scheme)
|
||||||
(eq? 'windows (file-url-path-convention-type))
|
(eq? 'windows (file-url-path-convention-type))
|
||||||
(not (equal? host "")))])
|
(not (equal? host "")))])
|
||||||
|
|
@ -408,46 +399,46 @@
|
||||||
(cdr (or (regexp-match url-rx str)
|
(cdr (or (regexp-match url-rx str)
|
||||||
(url-error "Invalid URL string: ~e" 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 #f, and leave unmolested any % that is followed by hex digit
|
||||||
;; if a % is not followed by a hex digit, replace it with %25
|
;; if a % is not followed by a hex digit, replace it with %25
|
||||||
;; in an attempt to be "friendly"
|
;; in an attempt to be "friendly"
|
||||||
(and f (uri-decode (regexp-replace* #rx"%([^0-9a-fA-F])" f "%25\\1"))))
|
(and f (uri-decode (regexp-replace* #rx"%([^0-9a-fA-F])" f "%25\\1"))))
|
||||||
|
|
||||||
;; separate-path-strings : string[starting with /] -> (listof path/param)
|
;; separate-path-strings : string[starting with /] -> (listof path/param)
|
||||||
(define (separate-path-strings str)
|
(define (separate-path-strings str)
|
||||||
(let ([strs (regexp-split #rx"/" str)])
|
(let ([strs (regexp-split #rx"/" str)])
|
||||||
(map separate-params (if (string=? "" (car strs)) (cdr strs) strs))))
|
(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))))
|
(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))])
|
(let ([lst (map path-segment-decode (regexp-split #rx";" s))])
|
||||||
(make-path/param (car lst) (cdr lst))))
|
(make-path/param (car lst) (cdr lst))))
|
||||||
|
|
||||||
(define (path-segment-decode p)
|
(define (path-segment-decode p)
|
||||||
(cond [(string=? p "..") 'up]
|
(cond [(string=? p "..") 'up]
|
||||||
[(string=? p ".") 'same]
|
[(string=? p ".") 'same]
|
||||||
[else (uri-path-segment-decode p)]))
|
[else (uri-path-segment-decode p)]))
|
||||||
|
|
||||||
(define (path-segment-encode p)
|
(define (path-segment-encode p)
|
||||||
(cond [(eq? p 'up) ".."]
|
(cond [(eq? p 'up) ".."]
|
||||||
[(eq? p 'same) "."]
|
[(eq? p 'same) "."]
|
||||||
[(equal? p "..") "%2e%2e"]
|
[(equal? p "..") "%2e%2e"]
|
||||||
[(equal? p ".") "%2e"]
|
[(equal? p ".") "%2e"]
|
||||||
[else (uri-path-segment-encode p)]))
|
[else (uri-path-segment-encode p)]))
|
||||||
|
|
||||||
(define (combine-path-strings absolute? path/params)
|
(define (combine-path-strings absolute? path/params)
|
||||||
(cond [(null? path/params) ""]
|
(cond [(null? path/params) ""]
|
||||||
[else (let ([p (join "/" (map join-params path/params))])
|
[else (let ([p (join "/" (map join-params path/params))])
|
||||||
(if absolute? (string-append "/" p) p))]))
|
(if absolute? (string-append "/" p) p))]))
|
||||||
|
|
||||||
(define (join-params s)
|
(define (join-params s)
|
||||||
(join ";" (map path-segment-encode
|
(join ";" (map path-segment-encode
|
||||||
(cons (path/param-path s) (path/param-param s)))))
|
(cons (path/param-path s) (path/param-param s)))))
|
||||||
|
|
||||||
(define (join sep strings)
|
(define (join sep strings)
|
||||||
(cond [(null? strings) ""]
|
(cond [(null? strings) ""]
|
||||||
[(null? (cdr strings)) (car strings)]
|
[(null? (cdr strings)) (car strings)]
|
||||||
[else
|
[else
|
||||||
|
|
@ -456,8 +447,9 @@
|
||||||
(apply string-append (reverse r))
|
(apply string-append (reverse r))
|
||||||
(loop (cdr strings) (list* (car strings) sep r))))]))
|
(loop (cdr strings) (list* (car strings) sep r))))]))
|
||||||
|
|
||||||
(define (path->url path)
|
(define (path->url path)
|
||||||
(let ([url-path (let loop ([path (simplify-path path #f)][accum null])
|
(let ([url-path
|
||||||
|
(let loop ([path (simplify-path path #f)][accum null])
|
||||||
(let-values ([(base name dir?) (split-path path)])
|
(let-values ([(base name dir?) (split-path path)])
|
||||||
(cond
|
(cond
|
||||||
[(not base)
|
[(not base)
|
||||||
|
|
@ -468,8 +460,7 @@
|
||||||
;; For Windows, massage the root:
|
;; For Windows, massage the root:
|
||||||
(let ([s (regexp-replace
|
(let ([s (regexp-replace
|
||||||
#rx"[/\\\\]$"
|
#rx"[/\\\\]$"
|
||||||
(bytes->string/utf-8
|
(bytes->string/utf-8 (path->bytes name))
|
||||||
(path->bytes name))
|
|
||||||
"")])
|
"")])
|
||||||
(cond
|
(cond
|
||||||
[(regexp-match? #rx"^\\\\\\\\[?]\\\\[a-zA-Z]:" s)
|
[(regexp-match? #rx"^\\\\\\\\[?]\\\\[a-zA-Z]:" s)
|
||||||
|
|
@ -499,52 +490,50 @@
|
||||||
(loop base accum)))])))])
|
(loop base accum)))])))])
|
||||||
(make-url "file" #f "" #f (absolute-path? path) url-path '() #f)))
|
(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))
|
(file://->path url kind))
|
||||||
|
|
||||||
;; delete-pure-port : url [x list (str)] -> in-port
|
;; delete-pure-port : url [x list (str)] -> in-port
|
||||||
(define/kw (delete-pure-port url #:optional [strings '()])
|
(define (delete-pure-port url [strings '()])
|
||||||
(method-pure-port 'delete url #f strings))
|
(method-pure-port 'delete url #f strings))
|
||||||
|
|
||||||
;; delete-impure-port : url [x list (str)] -> in-port
|
;; delete-impure-port : url [x list (str)] -> in-port
|
||||||
(define/kw (delete-impure-port url #:optional [strings '()])
|
(define (delete-impure-port url [strings '()])
|
||||||
(method-impure-port 'delete url #f strings))
|
(method-impure-port 'delete url #f strings))
|
||||||
|
|
||||||
;; head-pure-port : url [x list (str)] -> in-port
|
;; head-pure-port : url [x list (str)] -> in-port
|
||||||
(define/kw (head-pure-port url #:optional [strings '()])
|
(define (head-pure-port url [strings '()])
|
||||||
(method-pure-port 'head url #f strings))
|
(method-pure-port 'head url #f strings))
|
||||||
|
|
||||||
;; head-impure-port : url [x list (str)] -> in-port
|
;; head-impure-port : url [x list (str)] -> in-port
|
||||||
(define/kw (head-impure-port url #:optional [strings '()])
|
(define (head-impure-port url [strings '()])
|
||||||
(method-impure-port 'head url #f strings))
|
(method-impure-port 'head url #f strings))
|
||||||
|
|
||||||
;; put-pure-port : url bytes [x list (str)] -> in-port
|
;; put-pure-port : url bytes [x list (str)] -> in-port
|
||||||
(define/kw (put-pure-port url put-data #:optional [strings '()])
|
(define (put-pure-port url put-data [strings '()])
|
||||||
(method-pure-port 'put url put-data strings))
|
(method-pure-port 'put url put-data strings))
|
||||||
|
|
||||||
;; put-impure-port : url x bytes [x list (str)] -> in-port
|
;; put-impure-port : url x bytes [x list (str)] -> in-port
|
||||||
(define/kw (put-impure-port url put-data #:optional [strings '()])
|
(define (put-impure-port url put-data [strings '()])
|
||||||
(method-impure-port 'put url put-data strings))
|
(method-impure-port 'put url put-data strings))
|
||||||
|
|
||||||
;; method-impure-port : symbol x url x list (str) -> in-port
|
;; method-impure-port : symbol x url x list (str) -> in-port
|
||||||
(define (method-impure-port method url data strings)
|
(define (method-impure-port method url data strings)
|
||||||
(let ([scheme (url-scheme url)])
|
(let ([scheme (url-scheme url)])
|
||||||
(cond [(not scheme)
|
(cond [(not scheme)
|
||||||
(schemeless-url url)]
|
(schemeless-url url)]
|
||||||
[(or (string=? scheme "http")
|
[(or (string=? scheme "http") (string=? scheme "https"))
|
||||||
(string=? scheme "https"))
|
|
||||||
(http://method-impure-port method url data strings)]
|
(http://method-impure-port method url data strings)]
|
||||||
[(string=? scheme "file")
|
[(string=? scheme "file")
|
||||||
(url-error "There are no impure file: ports")]
|
(url-error "There are no impure file: ports")]
|
||||||
[else (url-error "Scheme ~a unsupported" scheme)])))
|
[else (url-error "Scheme ~a unsupported" scheme)])))
|
||||||
|
|
||||||
;; method-pure-port : symbol x url x list (str) -> in-port
|
;; method-pure-port : symbol x url x list (str) -> in-port
|
||||||
(define (method-pure-port method url data strings)
|
(define (method-pure-port method url data strings)
|
||||||
(let ([scheme (url-scheme url)])
|
(let ([scheme (url-scheme url)])
|
||||||
(cond [(not scheme)
|
(cond [(not scheme)
|
||||||
(schemeless-url url)]
|
(schemeless-url url)]
|
||||||
[(or (string=? scheme "http")
|
[(or (string=? scheme "http") (string=? scheme "https"))
|
||||||
(string=? scheme "https"))
|
|
||||||
(let ([port (http://method-impure-port
|
(let ([port (http://method-impure-port
|
||||||
method url data strings)])
|
method url data strings)])
|
||||||
(with-handlers ([void (lambda (exn)
|
(with-handlers ([void (lambda (exn)
|
||||||
|
|
@ -556,8 +545,8 @@
|
||||||
(file://get-pure-port url)]
|
(file://get-pure-port url)]
|
||||||
[else (url-error "Scheme ~a unsupported" scheme)])))
|
[else (url-error "Scheme ~a unsupported" scheme)])))
|
||||||
|
|
||||||
;; http://metod-impure-port : symbol x url x union (str, #f) x list (str) -> in-port
|
;; 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)
|
(define (http://method-impure-port method url data strings)
|
||||||
(let*-values
|
(let*-values
|
||||||
([(method) (case method
|
([(method) (case method
|
||||||
[(get) "GET"] [(post) "POST"] [(head) "HEAD"]
|
[(get) "GET"] [(post) "POST"] [(head) "HEAD"]
|
||||||
|
|
@ -586,5 +575,3 @@
|
||||||
(flush-output client->server)
|
(flush-output client->server)
|
||||||
(tcp-abandon-port client->server)
|
(tcp-abandon-port client->server)
|
||||||
server->client))
|
server->client))
|
||||||
|
|
||||||
))
|
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user