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,214 +1,210 @@
|
||||||
#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:
|
(form-urlencoded-decode (list->string chars)))
|
||||||
;; 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)
|
;; string->html : string -> string
|
||||||
(form-urlencoded-decode (list->string chars)))
|
;; -- the input is raw text, the output is HTML appropriately quoted
|
||||||
|
|
||||||
;; string->html : string -> string
|
(define (string->html s)
|
||||||
;; -- the input is raw text, the output is HTML appropriately quoted
|
(apply string-append
|
||||||
|
(map (lambda (c)
|
||||||
|
(case c
|
||||||
|
[(#\<) "<"]
|
||||||
|
[(#\>) ">"]
|
||||||
|
[(#\&) "&"]
|
||||||
|
[else (string c)]))
|
||||||
|
(string->list s))))
|
||||||
|
|
||||||
(define (string->html s)
|
(define default-text-color "#000000")
|
||||||
(apply string-append
|
(define default-bg-color "#ffffff")
|
||||||
(map (lambda (c)
|
(define default-link-color "#cc2200")
|
||||||
(case c
|
(define default-vlink-color "#882200")
|
||||||
[(#\<) "<"]
|
(define default-alink-color "#444444")
|
||||||
[(#\>) ">"]
|
|
||||||
[(#\&) "&"]
|
|
||||||
[else (string c)]))
|
|
||||||
(string->list s))))
|
|
||||||
|
|
||||||
(define default-text-color "#000000")
|
;; generate-html-output :
|
||||||
(define default-bg-color "#ffffff")
|
;; html-string x list (html-string) x ... -> ()
|
||||||
(define default-link-color "#cc2200")
|
|
||||||
(define default-vlink-color "#882200")
|
|
||||||
(define default-alink-color "#444444")
|
|
||||||
|
|
||||||
;; generate-html-output :
|
(define (generate-html-output title body-lines
|
||||||
;; html-string x list (html-string) x ... -> ()
|
[text-color default-text-color]
|
||||||
|
[bg-color default-bg-color]
|
||||||
|
[link-color default-link-color]
|
||||||
|
[vlink-color default-vlink-color]
|
||||||
|
[alink-color default-alink-color])
|
||||||
|
(let ([sa string-append])
|
||||||
|
(for ([l `("Content-type: text/html"
|
||||||
|
""
|
||||||
|
"<html>"
|
||||||
|
"<!-- The form was processed, and this document was generated,"
|
||||||
|
" using the CGI utilities for MzScheme. For more information"
|
||||||
|
" on MzScheme, see"
|
||||||
|
" http://www.plt-scheme.org/software/mzscheme/"
|
||||||
|
" and for the CGI utilities, contact"
|
||||||
|
" (sk@cs.brown.edu). -->"
|
||||||
|
"<head>"
|
||||||
|
,(sa "<title>" title "</title>")
|
||||||
|
"</head>"
|
||||||
|
""
|
||||||
|
,(sa "<body bgcolor=\"" bg-color "\" text=\"" text-color "\"")
|
||||||
|
,(sa " link=\"" link-color "\"")
|
||||||
|
,(sa " vlink=\"" vlink-color "\" alink=\"" alink-color "\">")
|
||||||
|
""
|
||||||
|
,@body-lines
|
||||||
|
""
|
||||||
|
"</body>"
|
||||||
|
"</html>")])
|
||||||
|
(display l)
|
||||||
|
(newline))))
|
||||||
|
|
||||||
(define generate-html-output
|
;; output-http-headers : -> void
|
||||||
(opt-lambda (title body-lines
|
(define (output-http-headers)
|
||||||
[text-color default-text-color]
|
(printf "Content-type: text/html\r\n\r\n"))
|
||||||
[bg-color default-bg-color]
|
|
||||||
[link-color default-link-color]
|
|
||||||
[vlink-color default-vlink-color]
|
|
||||||
[alink-color default-alink-color])
|
|
||||||
(let ([sa string-append])
|
|
||||||
(for-each
|
|
||||||
(lambda (l) (display l) (newline))
|
|
||||||
`("Content-type: text/html"
|
|
||||||
""
|
|
||||||
"<html>"
|
|
||||||
"<!-- The form was processed, and this document was generated,"
|
|
||||||
" using the CGI utilities for MzScheme. For more information"
|
|
||||||
" on MzScheme, see"
|
|
||||||
" http://www.plt-scheme.org/software/mzscheme/"
|
|
||||||
" and for the CGI utilities, contact"
|
|
||||||
" (sk@cs.brown.edu). -->"
|
|
||||||
"<head>"
|
|
||||||
,(sa "<title>" title "</title>")
|
|
||||||
"</head>"
|
|
||||||
""
|
|
||||||
,(sa "<body bgcolor=\"" bg-color "\" text=\"" text-color "\"")
|
|
||||||
,(sa " link=\"" link-color "\"")
|
|
||||||
,(sa " vlink=\"" vlink-color "\" alink=\"" alink-color "\">")
|
|
||||||
""
|
|
||||||
,@body-lines
|
|
||||||
""
|
|
||||||
"</body>"
|
|
||||||
"</html>")))))
|
|
||||||
|
|
||||||
;; output-http-headers : -> void
|
;; read-until-char : iport x char -> list (char) x bool
|
||||||
(define (output-http-headers)
|
;; -- operates on the default input port; the second value indicates whether
|
||||||
(printf "Content-type: text/html\r\n\r\n"))
|
;; reading stopped because an EOF was hit (as opposed to the delimiter being
|
||||||
|
;; seen); the delimiter is not part of the result
|
||||||
|
(define (read-until-char ip delimiter)
|
||||||
|
(let loop ([chars '()])
|
||||||
|
(let ([c (read-char ip)])
|
||||||
|
(cond [(eof-object? c) (values (reverse chars) #t)]
|
||||||
|
[(char=? c delimiter) (values (reverse chars) #f)]
|
||||||
|
[else (loop (cons c chars))]))))
|
||||||
|
|
||||||
;; read-until-char : iport x char -> list (char) x bool
|
;; read-name+value : iport -> (symbol + bool) x (string + bool) x bool
|
||||||
;; -- operates on the default input port; the second value indicates whether
|
;; -- If the first value is false, so is the second, and the third is true,
|
||||||
;; reading stopped because an EOF was hit (as opposed to the delimiter being
|
;; indicating EOF was reached without any input seen. Otherwise, the first
|
||||||
;; seen); the delimiter is not part of the result
|
;; and second values contain strings and the third is either true or false
|
||||||
(define (read-until-char ip delimiter)
|
;; depending on whether the EOF has been reached. The strings are processed
|
||||||
(let loop ([chars '()])
|
;; to remove the CGI spec "escape"s. This code is _slightly_ lax: it allows
|
||||||
(let ([c (read-char ip)])
|
;; an input to end in `&'. It's not clear this is legal by the CGI spec,
|
||||||
(cond [(eof-object? c) (values (reverse chars) #t)]
|
;; which suggests that the last value binding must end in an EOF. It doesn't
|
||||||
[(char=? c delimiter) (values (reverse chars) #f)]
|
;; look like this matters. It would also introduce needless modality and
|
||||||
[else (loop (cons c chars))]))))
|
;; reduce flexibility.
|
||||||
|
(define (read-name+value ip)
|
||||||
|
(let-values ([(name eof?) (read-until-char ip #\=)])
|
||||||
|
(cond [(and eof? (null? name)) (values #f #f #t)]
|
||||||
|
[eof?
|
||||||
|
(generate-error-output
|
||||||
|
(list "Server generated malformed input for POST method:"
|
||||||
|
(string-append
|
||||||
|
"No binding for `" (list->string name) "' field.")))]
|
||||||
|
[else (let-values ([(value eof?) (read-until-char ip #\&)])
|
||||||
|
(values (string->symbol (query-chars->string name))
|
||||||
|
(query-chars->string value)
|
||||||
|
eof?))])))
|
||||||
|
|
||||||
;; read-name+value : iport -> (symbol + bool) x (string + bool) x bool
|
;; get-bindings/post : () -> bindings
|
||||||
;; -- If the first value is false, so is the second, and the third is true,
|
(define (get-bindings/post)
|
||||||
;; indicating EOF was reached without any input seen. Otherwise, the first
|
(let-values ([(name value eof?) (read-name+value (current-input-port))])
|
||||||
;; and second values contain strings and the third is either true or false
|
(cond [(and eof? (not name)) null]
|
||||||
;; depending on whether the EOF has been reached. The strings are processed
|
[(and eof? name) (list (cons name value))]
|
||||||
;; to remove the CGI spec "escape"s. This code is _slightly_ lax: it allows
|
[else (cons (cons name value) (get-bindings/post))])))
|
||||||
;; an input to end in `&'. It's not clear this is legal by the CGI spec,
|
|
||||||
;; which suggests that the last value binding must end in an EOF. It doesn't
|
|
||||||
;; look like this matters. It would also introduce needless modality and
|
|
||||||
;; reduce flexibility.
|
|
||||||
(define (read-name+value ip)
|
|
||||||
(let-values ([(name eof?) (read-until-char ip #\=)])
|
|
||||||
(cond [(and eof? (null? name)) (values #f #f #t)]
|
|
||||||
[eof?
|
|
||||||
(generate-error-output
|
|
||||||
(list "Server generated malformed input for POST method:"
|
|
||||||
(string-append
|
|
||||||
"No binding for `" (list->string name) "' field.")))]
|
|
||||||
[else (let-values ([(value eof?) (read-until-char ip #\&)])
|
|
||||||
(values (string->symbol (query-chars->string name))
|
|
||||||
(query-chars->string value)
|
|
||||||
eof?))])))
|
|
||||||
|
|
||||||
;; get-bindings/post : () -> bindings
|
;; get-bindings/get : () -> bindings
|
||||||
(define (get-bindings/post)
|
(define (get-bindings/get)
|
||||||
(let-values ([(name value eof?) (read-name+value (current-input-port))])
|
(let ([p (open-input-string (getenv "QUERY_STRING"))])
|
||||||
(cond [(and eof? (not name)) null]
|
(let loop ()
|
||||||
[(and eof? name) (list (cons name value))]
|
(let-values ([(name value eof?) (read-name+value p)])
|
||||||
[else (cons (cons name value) (get-bindings/post))])))
|
(cond [(and eof? (not name)) null]
|
||||||
|
[(and eof? name) (list (cons name value))]
|
||||||
|
[else (cons (cons name value) (loop))])))))
|
||||||
|
|
||||||
;; get-bindings/get : () -> bindings
|
;; get-bindings : () -> bindings
|
||||||
(define (get-bindings/get)
|
(define (get-bindings)
|
||||||
(let ([p (open-input-string (getenv "QUERY_STRING"))])
|
(if (string=? (get-cgi-method) "POST")
|
||||||
(let loop ()
|
(get-bindings/post)
|
||||||
(let-values ([(name value eof?) (read-name+value p)])
|
(get-bindings/get)))
|
||||||
(cond [(and eof? (not name)) null]
|
|
||||||
[(and eof? name) (list (cons name value))]
|
|
||||||
[else (cons (cons name value) (loop))])))))
|
|
||||||
|
|
||||||
;; get-bindings : () -> bindings
|
;; generate-error-output : list (html-string) -> <exit>
|
||||||
(define (get-bindings)
|
(define (generate-error-output error-message-lines)
|
||||||
(if (string=? (get-cgi-method) "POST")
|
(generate-html-output "Internal Error" error-message-lines)
|
||||||
(get-bindings/post)
|
(exit))
|
||||||
(get-bindings/get)))
|
|
||||||
|
|
||||||
;; generate-error-output : list (html-string) -> <exit>
|
;; bindings-as-html : bindings -> list (html-string)
|
||||||
(define (generate-error-output error-message-lines)
|
;; -- formats name-value bindings as HTML appropriate for displaying
|
||||||
(generate-html-output "Internal Error" error-message-lines)
|
(define (bindings-as-html bindings)
|
||||||
(exit))
|
`("<code>"
|
||||||
|
,@(map (lambda (bind)
|
||||||
|
(string-append (symbol->string (car bind))
|
||||||
|
" --> "
|
||||||
|
(cdr bind)
|
||||||
|
"<br>"))
|
||||||
|
bindings)
|
||||||
|
"</code>"))
|
||||||
|
|
||||||
;; bindings-as-html : bindings -> list (html-string)
|
;; extract-bindings : (string + symbol) x bindings -> list (string)
|
||||||
;; -- formats name-value bindings as HTML appropriate for displaying
|
;; -- Extracts the bindings associated with a given name. The semantics of
|
||||||
(define (bindings-as-html bindings)
|
;; forms states that a CHECKBOX may use the same NAME field multiple times.
|
||||||
`("<code>"
|
;; Hence, a list of strings is returned. Note that the result may be the
|
||||||
,@(map (lambda (bind)
|
;; empty list.
|
||||||
(string-append (symbol->string (car bind))
|
(define (extract-bindings field-name bindings)
|
||||||
" --> "
|
(let ([field-name (if (symbol? field-name)
|
||||||
(cdr bind)
|
field-name (string->symbol field-name))])
|
||||||
"<br>"))
|
(let loop ([found null] [bindings bindings])
|
||||||
bindings)
|
(if (null? bindings)
|
||||||
"</code>"))
|
found
|
||||||
|
(if (equal? field-name (caar bindings))
|
||||||
|
(loop (cons (cdar bindings) found) (cdr bindings))
|
||||||
|
(loop found (cdr bindings)))))))
|
||||||
|
|
||||||
;; extract-bindings : (string + symbol) x bindings -> list (string)
|
;; extract-binding/single : (string + symbol) x bindings -> string
|
||||||
;; -- Extracts the bindings associated with a given name. The semantics of
|
;; -- used in cases where only one binding is supposed to occur
|
||||||
;; forms states that a CHECKBOX may use the same NAME field multiple times.
|
(define (extract-binding/single field-name bindings)
|
||||||
;; Hence, a list of strings is returned. Note that the result may be the
|
(let* ([field-name (if (symbol? field-name)
|
||||||
;; empty list.
|
field-name (string->symbol field-name))]
|
||||||
(define (extract-bindings field-name bindings)
|
[result (extract-bindings field-name bindings)])
|
||||||
(let ([field-name (if (symbol? field-name)
|
(cond
|
||||||
field-name (string->symbol field-name))])
|
[(null? result)
|
||||||
(let loop ([found null] [bindings bindings])
|
(generate-error-output
|
||||||
(if (null? bindings)
|
(cons (format "No binding for field `~a':<br>" field-name)
|
||||||
found
|
(bindings-as-html bindings)))]
|
||||||
(if (equal? field-name (caar bindings))
|
[(null? (cdr result))
|
||||||
(loop (cons (cdar bindings) found) (cdr bindings))
|
(car result)]
|
||||||
(loop found (cdr bindings)))))))
|
[else
|
||||||
|
(generate-error-output
|
||||||
|
(cons (format "Multiple bindings for field `~a' where one expected:<br>"
|
||||||
|
field-name)
|
||||||
|
(bindings-as-html bindings)))])))
|
||||||
|
|
||||||
;; extract-binding/single : (string + symbol) x bindings -> string
|
;; get-cgi-method : () -> string
|
||||||
;; -- used in cases where only one binding is supposed to occur
|
;; -- string is either GET or POST (though future extension is possible)
|
||||||
(define (extract-binding/single field-name bindings)
|
(define (get-cgi-method)
|
||||||
(let* ([field-name (if (symbol? field-name)
|
(or (getenv "REQUEST_METHOD")
|
||||||
field-name (string->symbol field-name))]
|
(error 'get-cgi-method "no REQUEST_METHOD environment variable")))
|
||||||
[result (extract-bindings field-name bindings)])
|
|
||||||
(cond
|
|
||||||
[(null? result)
|
|
||||||
(generate-error-output
|
|
||||||
(cons (format "No binding for field `~a':<br>" field-name)
|
|
||||||
(bindings-as-html bindings)))]
|
|
||||||
[(null? (cdr result))
|
|
||||||
(car result)]
|
|
||||||
[else
|
|
||||||
(generate-error-output
|
|
||||||
(cons (format "Multiple bindings for field `~a' where one expected:<br>"
|
|
||||||
field-name)
|
|
||||||
(bindings-as-html bindings)))])))
|
|
||||||
|
|
||||||
;; get-cgi-method : () -> string
|
;; generate-link-text : string x html-string -> html-string
|
||||||
;; -- string is either GET or POST (though future extension is possible)
|
(define (generate-link-text url anchor-text)
|
||||||
(define (get-cgi-method)
|
(string-append "<a href=\"" url "\">" anchor-text "</a>"))
|
||||||
(or (getenv "REQUEST_METHOD")
|
|
||||||
(error 'get-cgi-method "no REQUEST_METHOD environment variable")))
|
|
||||||
|
|
||||||
;; generate-link-text : string x html-string -> html-string
|
|
||||||
(define (generate-link-text url anchor-text)
|
|
||||||
(string-append "<a href=\"" url "\">" anchor-text "</a>"))
|
|
||||||
|
|
|
||||||
|
|
@ -50,279 +50,274 @@
|
||||||
|
|
||||||
#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))
|
||||||
(make-cookie name value
|
(make-cookie name value
|
||||||
#f ; comment
|
#f ; comment
|
||||||
#f ; current domain
|
#f ; current domain
|
||||||
#f ; at the end of session
|
#f ; at the end of session
|
||||||
#f ; current path
|
#f ; current path
|
||||||
#f ; normal (non SSL)
|
#f ; normal (non SSL)
|
||||||
#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)
|
||||||
|
(define (format-if fmt val) (and val (format fmt val)))
|
||||||
|
(unless (cookie? cookie) (error* "cookie expected, received: ~a" cookie))
|
||||||
|
(string-join
|
||||||
|
(filter values
|
||||||
|
(list (format "~a=~a" (cookie-name cookie) (cookie-value cookie))
|
||||||
|
(format-if "Comment=~a" (cookie-comment cookie))
|
||||||
|
(format-if "Domain=~a" (cookie-domain cookie))
|
||||||
|
(format-if "Max-Age=~a" (cookie-max-age cookie))
|
||||||
|
(format-if "Path=~a" (cookie-path cookie))
|
||||||
|
(and (cookie-secure cookie) "Secure")
|
||||||
|
(format "Version=~a" (or (cookie-version cookie) 1))))
|
||||||
|
"; "))
|
||||||
|
|
||||||
|
(define (cookie:add-comment cookie pre-comment)
|
||||||
|
(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))
|
||||||
(string-join
|
(set-cookie-comment! cookie comment)
|
||||||
(filter (lambda (s) (not (string-null? s)))
|
cookie))
|
||||||
(list (format "~a=~a" (cookie-name cookie) (cookie-value cookie))
|
|
||||||
(let ([c (cookie-comment cookie)]) (if c (format "Comment=~a" c) ""))
|
|
||||||
(let ([d (cookie-domain cookie)]) (if d (format "Domain=~a" d) ""))
|
|
||||||
(let ([age (cookie-max-age cookie)]) (if age (format "Max-Age=~a" age) ""))
|
|
||||||
(let ([p (cookie-path cookie)]) (if p (format "Path=~a" p) ""))
|
|
||||||
(let ([s (cookie-secure cookie)]) (if s "Secure" ""))
|
|
||||||
(let ([v (cookie-version cookie)]) (format "Version=~a" (if v v 1)))))
|
|
||||||
"; "))
|
|
||||||
|
|
||||||
(define (cookie:add-comment cookie pre-comment)
|
(define (cookie:add-domain cookie domain)
|
||||||
(let ([comment (to-rfc2109:value pre-comment)])
|
(unless (valid-domain? domain)
|
||||||
(unless (cookie? cookie)
|
(error* "invalid domain: ~a" domain))
|
||||||
(error* "cookie expected, received: ~a" cookie))
|
(unless (cookie? cookie)
|
||||||
(set-cookie-comment! cookie comment)
|
(error* "cookie expected, received: ~a" cookie))
|
||||||
cookie))
|
(set-cookie-domain! cookie domain)
|
||||||
|
cookie)
|
||||||
|
|
||||||
(define (cookie:add-domain cookie domain)
|
(define (cookie:add-max-age cookie seconds)
|
||||||
(unless (valid-domain? domain)
|
(unless (and (integer? seconds) (not (negative? seconds)))
|
||||||
(error* "invalid domain: ~a" domain))
|
(error* "invalid Max-Age for cookie: ~a" seconds))
|
||||||
|
(unless (cookie? cookie)
|
||||||
|
(error* "cookie expected, received: ~a" cookie))
|
||||||
|
(set-cookie-max-age! cookie seconds)
|
||||||
|
cookie)
|
||||||
|
|
||||||
|
(define (cookie:add-path cookie 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-domain! cookie domain)
|
(set-cookie-path! cookie path)
|
||||||
cookie)
|
cookie))
|
||||||
|
|
||||||
(define (cookie:add-max-age cookie seconds)
|
(define (cookie:secure cookie secure?)
|
||||||
(unless (and (integer? seconds) (not (negative? seconds)))
|
(unless (boolean? secure?)
|
||||||
(error* "invalid Max-Age for cookie: ~a" seconds))
|
(error* "invalid argument (boolean expected), received: ~a" secure?))
|
||||||
(unless (cookie? cookie)
|
(unless (cookie? cookie)
|
||||||
(error* "cookie expected, received: ~a" cookie))
|
(error* "cookie expected, received: ~a" cookie))
|
||||||
(set-cookie-max-age! cookie seconds)
|
(set-cookie-secure! cookie secure?)
|
||||||
cookie)
|
cookie)
|
||||||
|
|
||||||
(define (cookie:add-path cookie pre-path)
|
(define (cookie:version cookie version)
|
||||||
(let ([path (to-rfc2109:value pre-path)])
|
(unless (integer? version)
|
||||||
(unless (cookie? cookie)
|
(error* "unsupported version: ~a" version))
|
||||||
(error* "cookie expected, received: ~a" cookie))
|
(unless (cookie? cookie)
|
||||||
(set-cookie-path! cookie path)
|
(error* "cookie expected, received: ~a" cookie))
|
||||||
cookie))
|
(set-cookie-version! cookie version)
|
||||||
|
cookie)
|
||||||
(define (cookie:secure cookie secure?)
|
|
||||||
(unless (boolean? secure?)
|
|
||||||
(error* "invalid argument (boolean expected), received: ~a" secure?))
|
|
||||||
(unless (cookie? cookie)
|
|
||||||
(error* "cookie expected, received: ~a" cookie))
|
|
||||||
(set-cookie-secure! cookie secure?)
|
|
||||||
cookie)
|
|
||||||
|
|
||||||
(define (cookie:version cookie version)
|
|
||||||
(unless (integer? version)
|
|
||||||
(error* "unsupported version: ~a" version))
|
|
||||||
(unless (cookie? cookie)
|
|
||||||
(error* "cookie expected, received: ~a" cookie))
|
|
||||||
(set-cookie-version! cookie version)
|
|
||||||
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)
|
||||||
'()
|
'()
|
||||||
(let ([pair (car c)])
|
(let ([pair (car c)])
|
||||||
(if (string=? name (car pair))
|
(if (string=? name (car pair))
|
||||||
;; found an instance of cookie named `name'
|
;; found an instance of cookie named `name'
|
||||||
(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)]
|
||||||
|
|
||||||
;; for backwards compatibility, just use the given string if it will work
|
;; for backwards compatibility, just use the given string if it will work
|
||||||
[(rfc2068:token? s) s]
|
[(rfc2068:token? s) s]
|
||||||
[(rfc2068:quoted-string? s) s]
|
[(rfc2068:quoted-string? s) s]
|
||||||
|
|
||||||
;; ... but if it doesn't work (i.e., it's just a normal message) then try
|
;; ... but if it doesn't work (i.e., it's just a normal message) then try
|
||||||
;; to convert it into a representation that will work
|
;; to convert it into a representation that will work
|
||||||
[(rfc2068:quoted-string? (convert-to-quoted s))
|
[(rfc2068:quoted-string? (convert-to-quoted s))
|
||||||
=> (λ (x) x)]
|
=> (λ (x) x)]
|
||||||
[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,345 +1,338 @@
|
||||||
#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)
|
||||||
(mf 4)
|
(mf 4)
|
||||||
(cname 5)
|
(cname 5)
|
||||||
(soa 6)
|
(soa 6)
|
||||||
(mb 7)
|
(mb 7)
|
||||||
(mg 8)
|
(mg 8)
|
||||||
(mr 9)
|
(mr 9)
|
||||||
(null 10)
|
(null 10)
|
||||||
(wks 11)
|
(wks 11)
|
||||||
(ptr 12)
|
(ptr 12)
|
||||||
(hinfo 13)
|
(hinfo 13)
|
||||||
(minfo 14)
|
(minfo 14)
|
||||||
(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)
|
||||||
(number->octet-pair 0)
|
(number->octet-pair 0)
|
||||||
(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)
|
||||||
;; End of name
|
;; End of name
|
||||||
(values #f (cdr start))]
|
(values #f (cdr start))]
|
||||||
[(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)))]
|
(loop (sub1 len) (cdr start) (cons (car start) accum))))]
|
||||||
[else (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)
|
(cadr start))])
|
||||||
(cadr start))])
|
(let-values ([(s ignore-start)
|
||||||
(let-values ([(s ignore-start)
|
(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))]
|
||||||
[start (cddr start)]
|
[start (cddr start)]
|
||||||
;;
|
;;
|
||||||
[class (car (cossa (octet-pair->number (car start) (cadr start))
|
[class (car (cossa (octet-pair->number (car start) (cadr start))
|
||||||
classes))]
|
classes))]
|
||||||
[start (cddr start)]
|
[start (cddr start)]
|
||||||
;;
|
;;
|
||||||
[ttl (octet-quad->number (car start) (cadr start)
|
[ttl (octet-quad->number (car start) (cadr start)
|
||||||
(caddr start) (cadddr start))]
|
(caddr start) (cadddr start))]
|
||||||
[start (cddddr start)]
|
[start (cddddr start)]
|
||||||
;;
|
;;
|
||||||
[len (octet-pair->number (car start) (cadr start))]
|
[len (octet-pair->number (car start) (cadr start))]
|
||||||
[start (cddr start)])
|
[start (cddr start)])
|
||||||
;; Extract next len bytes for data:
|
;; Extract next len bytes for data:
|
||||||
(let loop ([len len] [start start] [accum null])
|
(let loop ([len len] [start start] [accum null])
|
||||||
(if (zero? len)
|
(if (zero? len)
|
||||||
(values (list name type class ttl (reverse accum))
|
(values (list name type class ttl (reverse accum))
|
||||||
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))]
|
||||||
[start (cddr start)]
|
[start (cddr start)]
|
||||||
;;
|
;;
|
||||||
[class (car (cossa (octet-pair->number (car start) (cadr start))
|
[class (car (cossa (octet-pair->number (car start) (cadr start))
|
||||||
classes))]
|
classes))]
|
||||||
[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)
|
||||||
(raise-type-error 'dns-query "DNS query class" class))
|
(raise-type-error 'dns-query "DNS query class" class))
|
||||||
|
|
||||||
(let* ([query (make-query (random 256) (string->bytes/latin-1 addr)
|
(let* ([query (make-query (random 256) (string->bytes/latin-1 addr)
|
||||||
type class)]
|
type class)]
|
||||||
[udp (udp-open-socket)]
|
[udp (udp-open-socket)]
|
||||||
[reply
|
[reply
|
||||||
(dynamic-wind
|
(dynamic-wind
|
||||||
void
|
void
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(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 (alarm-evt (+ (current-inexact-milliseconds)
|
||||||
(handle-evt
|
timeout))
|
||||||
(alarm-evt (+ (current-inexact-milliseconds)
|
(lambda (v)
|
||||||
timeout))
|
(retry (* timeout 2))))))))
|
||||||
(lambda (v)
|
(lambda () (udp-close udp)))])
|
||||||
(retry (* timeout 2))))))))
|
|
||||||
(lambda () (udp-close udp)))])
|
|
||||||
|
|
||||||
;; First two bytes must match sent message id:
|
;; First two bytes must match sent message id:
|
||||||
(unless (and (= (car reply) (car query))
|
(unless (and (= (car reply) (car query))
|
||||||
(= (cadr reply) (cadr query)))
|
(= (cadr reply) (cadr query)))
|
||||||
(error 'dns-query "bad reply id from server"))
|
(error 'dns-query "bad reply id from server"))
|
||||||
|
|
||||||
(let ([v0 (caddr reply)]
|
(let ([v0 (caddr reply)]
|
||||||
[v1 (cadddr reply)])
|
[v1 (cadddr reply)])
|
||||||
;; Check for error code:
|
;; Check for error code:
|
||||||
(let ([rcode (bitwise-and #xf v1)])
|
(let ([rcode (bitwise-and #xf v1)])
|
||||||
(unless (zero? rcode)
|
(unless (zero? rcode)
|
||||||
(error 'dns-query "error from server: ~a"
|
(error 'dns-query "error from server: ~a"
|
||||||
(case rcode
|
(case rcode
|
||||||
[(1) "format error"]
|
[(1) "format error"]
|
||||||
[(2) "server failure"]
|
[(2) "server failure"]
|
||||||
[(3) "name error"]
|
[(3) "name error"]
|
||||||
[(4) "not implemented"]
|
[(4) "not implemented"]
|
||||||
[(5) "refused"]))))
|
[(5) "refused"]))))
|
||||||
|
|
||||||
(let ([qd-count (octet-pair->number (list-ref reply 4) (list-ref reply 5))]
|
(let ([qd-count (octet-pair->number (list-ref reply 4) (list-ref reply 5))]
|
||||||
[an-count (octet-pair->number (list-ref reply 6) (list-ref reply 7))]
|
[an-count (octet-pair->number (list-ref reply 6) (list-ref reply 7))]
|
||||||
[ns-count (octet-pair->number (list-ref reply 8) (list-ref reply 9))]
|
[ns-count (octet-pair->number (list-ref reply 8) (list-ref reply 9))]
|
||||||
[ar-count (octet-pair->number (list-ref reply 10) (list-ref reply 11))])
|
[ar-count (octet-pair->number (list-ref reply 10) (list-ref reply 11))])
|
||||||
|
|
||||||
(let ([start (list-tail reply 12)])
|
(let ([start (list-tail reply 12)])
|
||||||
(let*-values ([(qds start) (parse-n parse-ques start reply qd-count)]
|
(let*-values ([(qds start) (parse-n parse-ques start reply qd-count)]
|
||||||
[(ans start) (parse-n parse-rr start reply an-count)]
|
[(ans start) (parse-n parse-rr start reply an-count)]
|
||||||
[(nss start) (parse-n parse-rr start reply ns-count)]
|
[(nss start) (parse-n parse-rr start reply ns-count)]
|
||||||
[(ars start) (parse-n parse-rr start reply ar-count)])
|
[(ars start) (parse-n parse-rr start reply ar-count)])
|
||||||
(unless (null? start)
|
(unless (null? start)
|
||||||
(error 'dns-query "error parsing server reply"))
|
(error 'dns-query "error parsing server reply"))
|
||||||
(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)
|
||||||
(hash-set! cache key (list auth? qds ans nss ars reply))
|
(dns-query nameserver addr type class)])
|
||||||
(values auth? qds ans nss ars reply))))))
|
(hash-set! cache key (list auth? qds ans nss ars reply))
|
||||||
|
(values auth? qds ans nss ars reply))))))
|
||||||
|
|
||||||
(define (ip->string s)
|
(define (ip->string s)
|
||||||
(format "~a.~a.~a.~a"
|
(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)])
|
||||||
(or v
|
(or v
|
||||||
(and (not auth?)
|
(and (not auth?)
|
||||||
(let* ([ns (ormap (lambda (ar)
|
(let* ([ns (ormap (lambda (ar)
|
||||||
(and (eq? (rr-type ar) 'a)
|
(and (eq? (rr-type ar) 'a)
|
||||||
(ip->string (rr-data ar))))
|
(ip->string (rr-data ar))))
|
||||||
ars)])
|
ars)])
|
||||||
(and ns
|
(and ns
|
||||||
(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"
|
||||||
(list-ref result 4)
|
(list-ref result 4)
|
||||||
(list-ref result 3)
|
(list-ref result 3)
|
||||||
(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)
|
||||||
(dns-query/cache nameserver (ip->in-addr.arpa ip) 'ptr 'in)])
|
(dns-query/cache nameserver (ip->in-addr.arpa ip) 'ptr 'in)])
|
||||||
(values (and (positive? (length (get-ptr-list-from-ans ans)))
|
(values (and (positive? (length (get-ptr-list-from-ans ans)))
|
||||||
(let ([s (rr-data (car (get-ptr-list-from-ans ans)))])
|
(let ([s (rr-data (car (get-ptr-list-from-ans ans)))])
|
||||||
(let-values ([(name null) (parse-name s reply)])
|
(let-values ([(name null) (parse-name s reply)])
|
||||||
(bytes->string/latin-1 name))))
|
(bytes->string/latin-1 name))))
|
||||||
ars auth?)))
|
ars auth?)))
|
||||||
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)])
|
||||||
(values (and (positive? (length (get-a-list-from-ans ans)))
|
(values (and (positive? (length (get-a-list-from-ans ans)))
|
||||||
(let ([s (rr-data (car (get-a-list-from-ans ans)))])
|
(let ([s (rr-data (car (get-a-list-from-ans ans)))])
|
||||||
(ip->string s)))
|
(ip->string s)))
|
||||||
ars auth?)))
|
ars auth?)))
|
||||||
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)])
|
||||||
(values (let loop ([ans ans][best-pref +inf.0][exchanger #f])
|
(values (let loop ([ans ans][best-pref +inf.0][exchanger #f])
|
||||||
(cond
|
(cond
|
||||||
[(null? ans)
|
[(null? ans)
|
||||||
(or exchanger
|
(or exchanger
|
||||||
;; Does 'soa mean that the input address is fine?
|
;; Does 'soa mean that the input address is fine?
|
||||||
(and (ormap (lambda (ns) (eq? (rr-type ns) 'soa))
|
(and (ormap (lambda (ns) (eq? (rr-type ns) 'soa))
|
||||||
nss)
|
nss)
|
||||||
addr))]
|
addr))]
|
||||||
[else
|
[else
|
||||||
(let ([d (rr-data (car ans))])
|
(let ([d (rr-data (car ans))])
|
||||||
(let ([pref (octet-pair->number (car d) (cadr d))])
|
(let ([pref (octet-pair->number (car d) (cadr d))])
|
||||||
(if (< pref best-pref)
|
(if (< pref best-pref)
|
||||||
(let-values ([(name start) (parse-name (cddr d) reply)])
|
(let-values ([(name start) (parse-name (cddr d) reply)])
|
||||||
(loop (cdr ans) pref name))
|
(loop (cdr ans) pref name))
|
||||||
(loop (cdr ans) best-pref exchanger))))]))
|
(loop (cdr ans) best-pref exchanger))))]))
|
||||||
ars auth?)))
|
ars auth?)))
|
||||||
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)])
|
||||||
(with-input-from-file "/etc/resolv.conf"
|
(with-input-from-file "/etc/resolv.conf"
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(let loop ()
|
(let loop ()
|
||||||
(let ([l (read-line)])
|
(let ([l (read-line)])
|
||||||
(or (and (string? l)
|
(or (and (string? l)
|
||||||
(let ([m (regexp-match
|
(let ([m (regexp-match
|
||||||
#rx"nameserver[ \t]+([0-9]+[.][0-9]+[.][0-9]+[.][0-9]+)"
|
#rx"nameserver[ \t]+([0-9]+[.][0-9]+[.][0-9]+[.][0-9]+)"
|
||||||
l)])
|
l)])
|
||||||
(and m (cadr m))))
|
(and m (cadr m))))
|
||||||
(and (not (eof-object? l))
|
(and (not (eof-object? l))
|
||||||
(loop))))))))]
|
(loop))))))))]
|
||||||
[(windows)
|
[(windows)
|
||||||
(let ([nslookup (find-executable-path "nslookup.exe" #f)])
|
(let ([nslookup (find-executable-path "nslookup.exe" #f)])
|
||||||
(and nslookup
|
(and nslookup
|
||||||
(let-values ([(pin pout pid perr proc)
|
(let-values ([(pin pout pid perr proc)
|
||||||
(apply
|
(apply
|
||||||
values
|
values
|
||||||
(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: +(.*)$" line))
|
||||||
(regexp-match #rx"^Address: +(.*)$"
|
=> (lambda (m) (loop name (cadr m) #f))]
|
||||||
line))
|
[else (loop name ip #f)]))))))]
|
||||||
=> (lambda (m) (loop name (cadr m) #f))]
|
[else #f]))
|
||||||
[else (loop name ip #f)]))))))]
|
|
||||||
[else #f]))
|
|
||||||
|
|
|
||||||
|
|
@ -1,349 +1,345 @@
|
||||||
#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)])
|
||||||
|
(let loop ([offset 0])
|
||||||
|
(cond
|
||||||
|
[(and (= (+ offset 2) len)
|
||||||
|
(bytes=? CRLF/bytes (subbytes s offset len)))
|
||||||
|
(void)] ; validated
|
||||||
|
[(= offset len) (error 'validate-header/bytes "missing ending CRLF")]
|
||||||
|
[(or (regexp-match re:field-start/bytes s offset)
|
||||||
|
(regexp-match re:continue/bytes s offset))
|
||||||
|
(let ([m (regexp-match-positions #rx#"\r\n" s offset)])
|
||||||
|
(if m
|
||||||
|
(loop (cdar m))
|
||||||
|
(error 'validate-header/bytes "missing ending CRLF")))]
|
||||||
|
[else (error 'validate-header/bytes "ill-formed header at ~s"
|
||||||
|
(subbytes s offset (string-length s)))])))
|
||||||
|
;; otherwise it should be a string:
|
||||||
|
(begin
|
||||||
|
(let ([m (regexp-match #rx"[^\000-\377]" s)])
|
||||||
|
(when m
|
||||||
|
(error 'validate-header "non-Latin-1 character in string: ~v" (car m))))
|
||||||
|
(let ([len (string-length s)])
|
||||||
(let loop ([offset 0])
|
(let loop ([offset 0])
|
||||||
(cond
|
(cond
|
||||||
[(and (= (+ offset 2) len)
|
[(and (= (+ offset 2) len)
|
||||||
(bytes=? CRLF/bytes (subbytes s offset len)))
|
(string=? CRLF (substring s offset len)))
|
||||||
(void)] ; validated
|
(void)] ; validated
|
||||||
[(= offset len) (error 'validate-header/bytes "missing ending CRLF")]
|
[(= offset len) (error 'validate-header "missing ending CRLF")]
|
||||||
[(or (regexp-match re:field-start/bytes s offset)
|
[(or (regexp-match re:field-start s offset)
|
||||||
(regexp-match re:continue/bytes s offset))
|
(regexp-match re:continue s offset))
|
||||||
(let ([m (regexp-match-positions #rx#"\r\n" s offset)])
|
(let ([m (regexp-match-positions #rx"\r\n" s offset)])
|
||||||
(if m
|
(if m
|
||||||
(loop (cdar m))
|
(loop (cdar m))
|
||||||
(error 'validate-header/bytes "missing ending CRLF")))]
|
(error 'validate-header "missing ending CRLF")))]
|
||||||
[else (error 'validate-header/bytes "ill-formed header at ~s"
|
[else (error 'validate-header "ill-formed header at ~s"
|
||||||
(subbytes s offset (string-length s)))])))
|
(substring s offset (string-length s)))]))))))
|
||||||
;; otherwise it should be a string:
|
|
||||||
(begin
|
|
||||||
(let ([m (regexp-match #rx"[^\000-\377]" s)])
|
|
||||||
(when m
|
|
||||||
(error 'validate-header "non-Latin-1 character in string: ~v" (car m))))
|
|
||||||
(let ([len (string-length s)])
|
|
||||||
(let loop ([offset 0])
|
|
||||||
(cond
|
|
||||||
[(and (= (+ offset 2) len)
|
|
||||||
(string=? CRLF (substring s offset len)))
|
|
||||||
(void)] ; validated
|
|
||||||
[(= offset len) (error 'validate-header "missing ending CRLF")]
|
|
||||||
[(or (regexp-match re:field-start s offset)
|
|
||||||
(regexp-match re:continue s offset))
|
|
||||||
(let ([m (regexp-match-positions #rx"\r\n" s offset)])
|
|
||||||
(if m
|
|
||||||
(loop (cdar m))
|
|
||||||
(error 'validate-header "missing ending CRLF")))]
|
|
||||||
[else (error 'validate-header "ill-formed header at ~s"
|
|
||||||
(substring s offset (string-length s)))]))))))
|
|
||||||
|
|
||||||
(define (make-field-start-regexp field)
|
(define (make-field-start-regexp field)
|
||||||
(regexp (format "(^|[\r][\n])(~a: *)" (regexp-quote field #f))))
|
(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)])
|
||||||
(and m
|
(and m
|
||||||
(let ([s (subbytes header
|
(let ([s (subbytes header
|
||||||
(cdaddr m)
|
(cdaddr m)
|
||||||
(bytes-length header))])
|
(bytes-length header))])
|
||||||
(let ([m (regexp-match-positions #rx#"[\r][\n][^: \r\n\"]*:" s)])
|
(let ([m (regexp-match-positions #rx#"[\r][\n][^: \r\n\"]*:" s)])
|
||||||
(if m
|
(if m
|
||||||
(subbytes s 0 (caar m))
|
(subbytes s 0 (caar m))
|
||||||
;; 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 ""))))))
|
||||||
;; otherwise header & field should be strings:
|
;; otherwise header & field 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)])
|
||||||
(and m
|
(and m
|
||||||
(let ([s (substring header
|
(let ([s (substring header
|
||||||
(cdaddr m)
|
(cdaddr m)
|
||||||
(string-length header))])
|
(string-length header))])
|
||||||
(let ([m (regexp-match-positions #rx"[\r][\n][^: \r\n\"]*:" s)])
|
(let ([m (regexp-match-positions #rx"[\r][\n][^: \r\n\"]*:" s)])
|
||||||
(if m
|
(if m
|
||||||
(substring s 0 (caar m))
|
(substring s 0 (caar m))
|
||||||
;; 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)
|
||||||
|
(if (bytes? header)
|
||||||
|
(let ([m (regexp-match-positions (make-field-start-regexp/bytes field)
|
||||||
|
header)])
|
||||||
|
(if m
|
||||||
|
(let* ([pre (subbytes header 0 (caaddr m))]
|
||||||
|
[s (subbytes header (cdaddr m))]
|
||||||
|
[m (regexp-match-positions #rx#"[\r][\n][^: \r\n\"]*:" s)]
|
||||||
|
[rest (if m (subbytes s (+ 2 (caar m))) empty-header/bytes)])
|
||||||
|
(bytes-append pre (if data (insert-field field data rest) rest)))
|
||||||
|
(if data (insert-field field data header) header)))
|
||||||
|
;; otherwise header & field & data should be strings:
|
||||||
|
(let ([m (regexp-match-positions (make-field-start-regexp field) header)])
|
||||||
|
(if m
|
||||||
|
(let* ([pre (substring header 0 (caaddr m))]
|
||||||
|
[s (substring header (cdaddr m))]
|
||||||
|
[m (regexp-match-positions #rx"[\r][\n][^: \r\n\"]*:" s)]
|
||||||
|
[rest (if m (substring s (+ 2 (caar m))) empty-header)])
|
||||||
|
(string-append pre (if data (insert-field field data rest) rest)))
|
||||||
|
(if data (insert-field field data header) header)))))
|
||||||
|
|
||||||
(define (replace-field field data header)
|
(define (remove-field field header)
|
||||||
(if (bytes? header)
|
(replace-field field #f header))
|
||||||
(let ([m (regexp-match-positions (make-field-start-regexp/bytes field)
|
|
||||||
header)])
|
|
||||||
(if m
|
|
||||||
(let* ([pre (subbytes header 0 (caaddr m))]
|
|
||||||
[s (subbytes header (cdaddr m))]
|
|
||||||
[m (regexp-match-positions #rx#"[\r][\n][^: \r\n\"]*:" s)]
|
|
||||||
[rest (if m (subbytes s (+ 2 (caar m))) empty-header/bytes)])
|
|
||||||
(bytes-append pre (if data (insert-field field data rest) rest)))
|
|
||||||
(if data (insert-field field data header) header)))
|
|
||||||
;; otherwise header & field & data should be strings:
|
|
||||||
(let ([m (regexp-match-positions (make-field-start-regexp field)
|
|
||||||
header)])
|
|
||||||
(if m
|
|
||||||
(let* ([pre (substring header 0 (caaddr m))]
|
|
||||||
[s (substring header (cdaddr m))]
|
|
||||||
[m (regexp-match-positions #rx"[\r][\n][^: \r\n\"]*:" s)]
|
|
||||||
[rest (if m (substring s (+ 2 (caar m))) empty-header)])
|
|
||||||
(string-append pre (if data (insert-field field data rest) rest)))
|
|
||||||
(if data (insert-field field data header) header)))))
|
|
||||||
|
|
||||||
(define (remove-field field header)
|
(define (insert-field field data header)
|
||||||
(replace-field field #f header))
|
(if (bytes? header)
|
||||||
|
(let ([field (bytes-append field #": "data #"\r\n")])
|
||||||
|
(bytes-append field header))
|
||||||
|
;; otherwise field, data, & header should be strings:
|
||||||
|
(let ([field (format "~a: ~a\r\n" field data)])
|
||||||
|
(string-append field header))))
|
||||||
|
|
||||||
(define (insert-field field data header)
|
(define (append-headers a b)
|
||||||
(if (bytes? header)
|
(if (bytes? a)
|
||||||
(let ([field (bytes-append field #": "data #"\r\n")])
|
(let ([alen (bytes-length a)])
|
||||||
(bytes-append field header))
|
(if (> alen 1)
|
||||||
;; otherwise field, data, & header should be strings:
|
(bytes-append (subbytes a 0 (- alen 2)) b)
|
||||||
(let ([field (format "~a: ~a\r\n" field data)])
|
(error 'append-headers "first argument is not a header: ~a" a)))
|
||||||
(string-append field header))))
|
;; otherwise, a & b should be strings:
|
||||||
|
(let ([alen (string-length a)])
|
||||||
|
(if (> alen 1)
|
||||||
|
(string-append (substring a 0 (- alen 2)) b)
|
||||||
|
(error 'append-headers "first argument is not a header: ~a" a)))))
|
||||||
|
|
||||||
(define (append-headers a b)
|
(define (extract-all-fields header)
|
||||||
(if (bytes? a)
|
(if (bytes? header)
|
||||||
(let ([alen (bytes-length a)])
|
(let ([re #rx#"(^|[\r][\n])(([^\r\n:\"]*): *)"])
|
||||||
(if (> alen 1)
|
(let loop ([start 0])
|
||||||
(bytes-append (subbytes a 0 (- alen 2)) b)
|
(let ([m (regexp-match-positions re header start)])
|
||||||
(error 'append-headers "first argument is not a header: ~a" a)))
|
(if m
|
||||||
;; otherwise, a & b should be strings:
|
(let ([start (cdaddr m)]
|
||||||
(let ([alen (string-length a)])
|
[field-name (subbytes header (caaddr (cdr m))
|
||||||
(if (> alen 1)
|
(cdaddr (cdr m)))])
|
||||||
(string-append (substring a 0 (- alen 2)) b)
|
(let ([m2 (regexp-match-positions
|
||||||
(error 'append-headers "first argument is not a header: ~a" a)))))
|
#rx#"\r\n[^: \r\n\"]*:"
|
||||||
|
header
|
||||||
|
start)])
|
||||||
|
(if m2
|
||||||
|
(cons (cons field-name
|
||||||
|
(subbytes header start (caar m2)))
|
||||||
|
(loop (caar m2)))
|
||||||
|
;; Rest of header is this field, but strip trailing CRLFCRLF:
|
||||||
|
(list
|
||||||
|
(cons field-name
|
||||||
|
(regexp-replace #rx#"\r\n\r\n$"
|
||||||
|
(subbytes header start (bytes-length header))
|
||||||
|
""))))))
|
||||||
|
;; malformed header:
|
||||||
|
null))))
|
||||||
|
;; otherwise, header should be a string:
|
||||||
|
(let ([re #rx"(^|[\r][\n])(([^\r\n:\"]*): *)"])
|
||||||
|
(let loop ([start 0])
|
||||||
|
(let ([m (regexp-match-positions re header start)])
|
||||||
|
(if m
|
||||||
|
(let ([start (cdaddr m)]
|
||||||
|
[field-name (substring header (caaddr (cdr m)) (cdaddr (cdr m)))])
|
||||||
|
(let ([m2 (regexp-match-positions
|
||||||
|
#rx"\r\n[^: \r\n\"]*:" header start)])
|
||||||
|
(if m2
|
||||||
|
(cons (cons field-name
|
||||||
|
(substring header start (caar m2)))
|
||||||
|
(loop (caar m2)))
|
||||||
|
;; Rest of header is this field, but strip trailing CRLFCRLF:
|
||||||
|
(list
|
||||||
|
(cons field-name
|
||||||
|
(regexp-replace #rx"\r\n\r\n$"
|
||||||
|
(substring header start (string-length header))
|
||||||
|
""))))))
|
||||||
|
;; malformed header:
|
||||||
|
null))))))
|
||||||
|
|
||||||
(define (extract-all-fields header)
|
;; It's slightly less obvious how to generalize the functions that don't
|
||||||
(if (bytes? header)
|
;; accept a header as input; for lack of an obvious solution (and free time),
|
||||||
(let ([re #rx#"(^|[\r][\n])(([^\r\n:\"]*): *)"])
|
;; I'm stopping the string->bytes translation here. -- JBC, 2006-07-31
|
||||||
(let loop ([start 0])
|
|
||||||
(let ([m (regexp-match-positions re header start)])
|
|
||||||
(if m
|
|
||||||
(let ([start (cdaddr m)]
|
|
||||||
[field-name (subbytes header (caaddr (cdr m))
|
|
||||||
(cdaddr (cdr m)))])
|
|
||||||
(let ([m2 (regexp-match-positions
|
|
||||||
#rx#"\r\n[^: \r\n\"]*:"
|
|
||||||
header
|
|
||||||
start)])
|
|
||||||
(if m2
|
|
||||||
(cons (cons field-name
|
|
||||||
(subbytes header start (caar m2)))
|
|
||||||
(loop (caar m2)))
|
|
||||||
;; Rest of header is this field, but strip trailing CRLFCRLF:
|
|
||||||
(list
|
|
||||||
(cons field-name
|
|
||||||
(regexp-replace #rx#"\r\n\r\n$"
|
|
||||||
(subbytes header start (bytes-length header))
|
|
||||||
""))))))
|
|
||||||
;; malformed header:
|
|
||||||
null))))
|
|
||||||
;; otherwise, header should be a string:
|
|
||||||
(let ([re #rx"(^|[\r][\n])(([^\r\n:\"]*): *)"])
|
|
||||||
(let loop ([start 0])
|
|
||||||
(let ([m (regexp-match-positions re header start)])
|
|
||||||
(if m
|
|
||||||
(let ([start (cdaddr m)]
|
|
||||||
[field-name (substring header (caaddr (cdr m)) (cdaddr (cdr m)))])
|
|
||||||
(let ([m2 (regexp-match-positions
|
|
||||||
#rx"\r\n[^: \r\n\"]*:" header start)])
|
|
||||||
(if m2
|
|
||||||
(cons (cons field-name
|
|
||||||
(substring header start (caar m2)))
|
|
||||||
(loop (caar m2)))
|
|
||||||
;; Rest of header is this field, but strip trailing CRLFCRLF:
|
|
||||||
(list
|
|
||||||
(cons field-name
|
|
||||||
(regexp-replace #rx"\r\n\r\n$"
|
|
||||||
(substring header start (string-length header))
|
|
||||||
""))))))
|
|
||||||
;; malformed header:
|
|
||||||
null))))))
|
|
||||||
|
|
||||||
;; It's slightly less obvious how to generalize the functions that don't
|
(define (standard-message-header from tos ccs bccs subject)
|
||||||
;; accept a header as input; for lack of an obvious solution (and free time),
|
(let ([h (insert-field
|
||||||
;; I'm stopping the string->bytes translation here. -- JBC, 2006-07-31
|
"Subject" subject
|
||||||
|
(insert-field
|
||||||
(define (standard-message-header from tos ccs bccs subject)
|
"Date" (parameterize ([date-display-format 'rfc2822])
|
||||||
(let ([h (insert-field
|
(date->string (seconds->date (current-seconds)) #t))
|
||||||
"Subject" subject
|
CRLF))])
|
||||||
(insert-field
|
;; NOTE: bccs don't go into the header; that's why they're "blind"
|
||||||
"Date" (parameterize ([date-display-format 'rfc2822])
|
(let ([h (if (null? ccs)
|
||||||
(date->string (seconds->date (current-seconds)) #t))
|
h
|
||||||
CRLF))])
|
(insert-field "CC" (assemble-address-field ccs) h))])
|
||||||
;; NOTE: bccs don't go into the header; that's why they're "blind"
|
(let ([h (if (null? tos)
|
||||||
(let ([h (if (null? ccs)
|
|
||||||
h
|
h
|
||||||
(insert-field "CC" (assemble-address-field ccs) h))])
|
(insert-field "To" (assemble-address-field tos) h))])
|
||||||
(let ([h (if (null? tos)
|
(insert-field "From" from h)))))
|
||||||
h
|
|
||||||
(insert-field "To" (assemble-address-field tos) 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"
|
||||||
(car l)
|
(car l)
|
||||||
(apply string-append
|
(apply string-append
|
||||||
(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"
|
||||||
form))
|
form))
|
||||||
(if (or (not s) (regexp-match re:all-blank s))
|
(if (or (not s) (regexp-match re:all-blank s))
|
||||||
null
|
null
|
||||||
(let loop ([prefix ""][s s])
|
(let loop ([prefix ""][s s])
|
||||||
;; Which comes first - a quote or a comma?
|
;; Which comes first - a quote or a comma?
|
||||||
(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
|
(or mq1 mq2))]
|
||||||
mq2)
|
[mc (regexp-match-positions re:comma s)])
|
||||||
(or mq1 mq2))]
|
(if (and mq mc (< (caar mq) (caar mc) (cdar mq)))
|
||||||
[mc (regexp-match-positions re:comma s)])
|
;; Quote contains a comma
|
||||||
(if (and mq mc (< (caar mq) (caar mc) (cdar mq)))
|
(loop (string-append
|
||||||
;; Quote contains a comma
|
prefix
|
||||||
(loop (string-append
|
(substring s 0 (cdar mq)))
|
||||||
prefix
|
(substring s (cdar mq) (string-length s)))
|
||||||
(substring s 0 (cdar mq)))
|
;; Normal comma parsing:
|
||||||
(substring s (cdar mq) (string-length s)))
|
(let ([m (regexp-match re:comma-separated s)])
|
||||||
;; Normal comma parsing:
|
(if m
|
||||||
(let ([m (regexp-match re:comma-separated s)])
|
(let ([n (extract-one-name (string-append prefix (cadr m)) form)]
|
||||||
(if m
|
[rest (extract-addresses (caddr m) form)])
|
||||||
(let ([n (extract-one-name (string-append prefix (cadr m)) form)]
|
(cons n rest))
|
||||||
[rest (extract-addresses (caddr m) form)])
|
(let ([n (extract-one-name (string-append prefix s) form)])
|
||||||
(cons n rest))
|
(list n)))))))))
|
||||||
(let ([n (extract-one-name (string-append prefix s) form)])
|
|
||||||
(list n)))))))))
|
|
||||||
|
|
||||||
(define (select-result form name addr full)
|
(define (select-result form name addr full)
|
||||||
(case form
|
(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 ?!?!?
|
||||||
[(regexp-match re:parened-name s)
|
[(regexp-match re:parened-name s)
|
||||||
=> (lambda (m)
|
=> (lambda (m)
|
||||||
(let ([name (caddr m)]
|
(let ([name (caddr m)]
|
||||||
[all (loop (cadr m) 'all)])
|
[all (loop (cadr m) 'all)])
|
||||||
(select-result
|
(select-result
|
||||||
form
|
form
|
||||||
(if (string=? (car all) (cadr all)) name (car all))
|
(if (string=? (car all) (cadr all)) name (car all))
|
||||||
(cadr all)
|
(cadr all)
|
||||||
(format "~a (~a)" (caddr all) name))))]
|
(format "~a (~a)" (caddr all) name))))]
|
||||||
[(regexp-match re:quoted-name s)
|
[(regexp-match re:quoted-name s)
|
||||||
=> (lambda (m)
|
=> (lambda (m)
|
||||||
(let ([name (cadr m)]
|
(let ([name (cadr m)]
|
||||||
[addr (extract-angle-addr (caddr m) s)])
|
[addr (extract-angle-addr (caddr m) s)])
|
||||||
(select-result form name addr
|
(select-result form name addr
|
||||||
(format "~a <~a>" name addr))))]
|
(format "~a <~a>" name addr))))]
|
||||||
[(regexp-match re:simple-name s)
|
[(regexp-match re:simple-name s)
|
||||||
=> (lambda (m)
|
=> (lambda (m)
|
||||||
(let ([name (regexp-replace (format "~a*$" blank) (cadr m) "")]
|
(let ([name (regexp-replace (format "~a*$" blank) (cadr m) "")]
|
||||||
[addr (extract-angle-addr (caddr m) s)])
|
[addr (extract-angle-addr (caddr m) s)])
|
||||||
(select-result form name addr
|
(select-result form name addr
|
||||||
(format "~a <~a>" name addr))))]
|
(format "~a <~a>" name addr))))]
|
||||||
[(or (regexp-match "<" s) (regexp-match ">" s))
|
[(or (regexp-match "<" s) (regexp-match ">" s))
|
||||||
(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)])
|
||||||
(if m
|
(if m
|
||||||
(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
|
||||||
;; final whitespace strip
|
;; final whitespace strip
|
||||||
(regexp-replace re:tail-blanks
|
(regexp-replace re:tail-blanks
|
||||||
(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)]
|
||||||
[s (car addresses)]
|
[s (car addresses)]
|
||||||
[len (string-length (car addresses))])
|
[len (string-length (car addresses))])
|
||||||
(if (null? addresses)
|
(if (null? addresses)
|
||||||
s
|
s
|
||||||
(let* ([addr (car addresses)]
|
(let* ([addr (car addresses)]
|
||||||
[alen (string-length addr)])
|
[alen (string-length addr)])
|
||||||
(if (<= 72 (+ len alen))
|
(if (<= 72 (+ len alen))
|
||||||
(loop (cdr addresses)
|
(loop (cdr addresses)
|
||||||
(format "~a,~a~a~a~a"
|
(format "~a,~a~a~a~a"
|
||||||
s #\return #\linefeed
|
s #\return #\linefeed
|
||||||
#\tab addr)
|
#\tab addr)
|
||||||
alen)
|
alen)
|
||||||
(loop (cdr addresses)
|
(loop (cdr addresses)
|
||||||
(format "~a, ~a" s addr)
|
(format "~a, ~a" s addr)
|
||||||
(+ len alen 2))))))))
|
(+ len alen 2))))))))
|
||||||
|
|
|
||||||
File diff suppressed because it is too large
Load Diff
|
|
@ -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 (type filename creation
|
||||||
(struct disposition
|
modification read
|
||||||
(type filename creation
|
size params))
|
||||||
modification read
|
|
||||||
size params))
|
|
||||||
|
|
||||||
;; -- mime methods --
|
;; -- mime methods --
|
||||||
mime-analyze
|
mime-analyze
|
||||||
|
|
||||||
|
|
|
||||||
File diff suppressed because it is too large
Load Diff
|
|
@ -28,148 +28,138 @@
|
||||||
|
|
||||||
#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
|
[(61) ;; A "=", which is quoted-printable stuff
|
||||||
[(61) ;; A "=", which is quoted-printable stuff
|
(let ([next (read-byte in)])
|
||||||
(let ([next (read-byte in)])
|
(cond
|
||||||
(cond
|
[(eq? next 10)
|
||||||
[(eq? next 10)
|
;; Soft-newline -- drop it
|
||||||
;; Soft-newline -- drop it
|
(void)]
|
||||||
(void)]
|
[(eq? next 13)
|
||||||
[(eq? next 13)
|
;; Expect a newline for a soft CRLF...
|
||||||
;; Expect a newline for a soft CRLF...
|
(let ([next-next (read-byte in)])
|
||||||
(let ([next-next (read-byte in)])
|
(if (eq? next-next 10)
|
||||||
(if (eq? next-next 10)
|
;; Good.
|
||||||
;; Good.
|
(loop (read-byte in))
|
||||||
(loop (read-byte in))
|
;; Not a LF? Well, ok.
|
||||||
;; Not a LF? Well, ok.
|
(loop next-next)))]
|
||||||
(loop next-next)))]
|
[(hex-digit? next)
|
||||||
[(hex-digit? next)
|
(let ([next-next (read-byte in)])
|
||||||
(let ([next-next (read-byte in)])
|
(cond [(eof-object? next-next)
|
||||||
(cond [(eof-object? next-next)
|
(warning "Illegal qp sequence: `=~a'" next)
|
||||||
(warning "Illegal qp sequence: `=~a'" next)
|
(display "=" out)
|
||||||
(display "=" out)
|
(display next out)]
|
||||||
(display next out)]
|
[(hex-digit? next-next)
|
||||||
[(hex-digit? next-next)
|
;; qp-encoded
|
||||||
;; qp-encoded
|
(write-byte (hex-bytes->byte next next-next)
|
||||||
(write-byte (hex-bytes->byte next next-next)
|
out)]
|
||||||
out)]
|
[else
|
||||||
[else
|
(warning "Illegal qp sequence: `=~a~a'" next next-next)
|
||||||
(warning "Illegal qp sequence: `=~a~a'" next next-next)
|
(write-byte 61 out)
|
||||||
(write-byte 61 out)
|
(write-byte next out)
|
||||||
(write-byte next out)
|
(write-byte next-next out)]))]
|
||||||
(write-byte next-next out)]))]
|
[else
|
||||||
[else
|
;; Warning: invalid
|
||||||
;; Warning: invalid
|
(warning "Illegal qp sequence: `=~a'" next)
|
||||||
(warning "Illegal qp sequence: `=~a'" next)
|
(write-byte 61 out)
|
||||||
(write-byte 61 out)
|
(write-byte next out)])
|
||||||
(write-byte next out)])
|
(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"])
|
||||||
|
(let loop ([col 0])
|
||||||
|
(if (= col 75)
|
||||||
|
(begin
|
||||||
|
;; Soft newline:
|
||||||
|
(write-byte 61 out)
|
||||||
|
(display newline-string out)
|
||||||
|
(loop 0))
|
||||||
|
(let ([i (read-byte in)])
|
||||||
|
(cond
|
||||||
|
[(eof-object? i) (void)]
|
||||||
|
[(or (= i 10) (= i 13))
|
||||||
|
(write-byte i out)
|
||||||
|
(loop 0)]
|
||||||
|
[(or (<= 33 i 60) (<= 62 i 126)
|
||||||
|
(and (or (= i 32) (= i 9))
|
||||||
|
(not (let ([next (peek-byte in)])
|
||||||
|
(or (eof-object? next) (= next 10) (= next 13))))))
|
||||||
|
;; single-byte mode:
|
||||||
|
(write-byte i out)
|
||||||
|
(loop (add1 col))]
|
||||||
|
[(>= col 73)
|
||||||
|
;; need a soft newline first
|
||||||
|
(write-byte 61 out)
|
||||||
|
(display newline-string out)
|
||||||
|
;; now the octect
|
||||||
|
(write-hex-bytes i out)
|
||||||
|
(loop 3)]
|
||||||
|
[else
|
||||||
|
;; an octect
|
||||||
|
(write-hex-bytes i out)
|
||||||
|
(loop (+ col 3))])))))
|
||||||
|
|
||||||
(define qp-encode-stream
|
;; Tables
|
||||||
(opt-lambda (in out [newline-string #"\n"])
|
(define hex-values (make-vector 256 #f))
|
||||||
(let loop ([col 0])
|
(define hex-bytes (make-vector 16))
|
||||||
(if (= col 75)
|
(let loop ([i 0])
|
||||||
(begin
|
(unless (= i 10)
|
||||||
;; Soft newline:
|
(vector-set! hex-values (+ i 48) i)
|
||||||
(write-byte 61 out)
|
(vector-set! hex-bytes i (+ i 48))
|
||||||
(display newline-string out)
|
(loop (add1 i))))
|
||||||
(loop 0))
|
(let loop ([i 0])
|
||||||
(let ([i (read-byte in)])
|
(unless (= i 6)
|
||||||
(cond
|
(vector-set! hex-values (+ i 65) (+ 10 i))
|
||||||
[(eof-object? i) (void)]
|
(vector-set! hex-values (+ i 97) (+ 10 i))
|
||||||
[(or (= i 10) (= i 13))
|
(vector-set! hex-bytes (+ 10 i) (+ i 65))
|
||||||
(write-byte i out)
|
(loop (add1 i))))
|
||||||
(loop 0)]
|
|
||||||
[(or (<= 33 i 60) (<= 62 i 126)
|
|
||||||
(and (or (= i 32) (= i 9))
|
|
||||||
(not (let ([next (peek-byte in)])
|
|
||||||
(or (eof-object? next) (= next 10) (= next 13))))))
|
|
||||||
;; single-byte mode:
|
|
||||||
(write-byte i out)
|
|
||||||
(loop (add1 col))]
|
|
||||||
[(>= col 73)
|
|
||||||
;; need a soft newline first
|
|
||||||
(write-byte 61 out)
|
|
||||||
(display newline-string out)
|
|
||||||
;; now the octect
|
|
||||||
(write-hex-bytes i out)
|
|
||||||
(loop 3)]
|
|
||||||
[else
|
|
||||||
;; an octect
|
|
||||||
(write-hex-bytes i out)
|
|
||||||
(loop (+ col 3))]))))))
|
|
||||||
|
|
||||||
;; Tables
|
|
||||||
(define hex-values (make-vector 256 #f))
|
|
||||||
(define hex-bytes (make-vector 16))
|
|
||||||
(let loop ([i 0])
|
|
||||||
(unless (= i 10)
|
|
||||||
(vector-set! hex-values (+ i 48) i)
|
|
||||||
(vector-set! hex-bytes i (+ i 48))
|
|
||||||
(loop (add1 i))))
|
|
||||||
(let loop ([i 0])
|
|
||||||
(unless (= i 6)
|
|
||||||
(vector-set! hex-values (+ i 65) (+ 10 i))
|
|
||||||
(vector-set! hex-values (+ i 97) (+ 10 i))
|
|
||||||
(vector-set! hex-bytes (+ 10 i) (+ i 65))
|
|
||||||
(loop (add1 i))))
|
|
||||||
|
|
||||||
;;; qp-unit.ss ends here
|
;;; qp-unit.ss ends here
|
||||||
|
|
|
||||||
|
|
@ -1,119 +1,119 @@
|
||||||
#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])
|
||||||
(if (null? paths)
|
(if (null? paths)
|
||||||
(raise (make-exn:fail:unsupported
|
(raise (make-exn:fail:unsupported
|
||||||
"unable to find sendmail on this Unix variant"
|
"unable to find sendmail on this Unix variant"
|
||||||
(current-continuation-marks)))
|
(current-continuation-marks)))
|
||||||
(let ([p (build-path (car paths) "sendmail")])
|
(let ([p (build-path (car paths) "sendmail")])
|
||||||
(if (and (file-exists? p)
|
(if (and (file-exists? p)
|
||||||
(memq 'execute (file-or-directory-permissions p)))
|
(memq 'execute (file-or-directory-permissions p)))
|
||||||
p
|
p
|
||||||
(loop (cdr paths))))))
|
(loop (cdr paths))))))
|
||||||
(raise (make-exn:fail:unsupported
|
(raise (make-exn:fail:unsupported
|
||||||
"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))
|
||||||
(raise (make-no-mail-recipients
|
(raise (make-no-mail-recipients
|
||||||
"no mail recipients were specified"
|
"no mail recipients were specified"
|
||||||
(current-continuation-marks))))
|
(current-continuation-marks))))
|
||||||
(let ([return (apply process* sendmail-program-file "-i"
|
(let ([return (apply process* sendmail-program-file "-i"
|
||||||
(append to-recipients cc-recipients bcc-recipients))])
|
(append to-recipients cc-recipients bcc-recipients))])
|
||||||
(let ([reader (car return)]
|
(let ([reader (car return)]
|
||||||
[writer (cadr return)]
|
[writer (cadr return)]
|
||||||
[pid (caddr return)]
|
[pid (caddr return)]
|
||||||
[error-reader (cadddr return)])
|
[error-reader (cadddr return)])
|
||||||
(close-input-port reader)
|
(close-input-port reader)
|
||||||
(close-input-port error-reader)
|
(close-input-port error-reader)
|
||||||
(fprintf writer "From: ~a\n" sender)
|
(fprintf writer "From: ~a\n" sender)
|
||||||
(letrec ([write-recipient-header
|
(letrec ([write-recipient-header
|
||||||
(lambda (header-string recipients)
|
(lambda (header-string recipients)
|
||||||
(let ([header-space
|
(let ([header-space
|
||||||
(+ (string-length header-string) 2)])
|
(+ (string-length header-string) 2)])
|
||||||
(fprintf writer "~a: " header-string)
|
(fprintf writer "~a: " header-string)
|
||||||
(let loop ([to recipients] [indent header-space])
|
(let loop ([to recipients] [indent header-space])
|
||||||
(if (null? to)
|
(if (null? to)
|
||||||
(newline writer)
|
(newline writer)
|
||||||
(let ([first (car to)]
|
(let ([first (car to)]
|
||||||
[rest (cdr to)])
|
[rest (cdr to)])
|
||||||
(let ([len (string-length first)])
|
(let ([len (string-length first)])
|
||||||
(if (>= (+ len indent) 80)
|
(if (>= (+ len indent) 80)
|
||||||
(begin
|
(begin
|
||||||
(fprintf writer
|
(fprintf writer
|
||||||
(if (null? rest)
|
(if (null? rest)
|
||||||
"\n ~a"
|
"\n ~a"
|
||||||
"\n ~a, ")
|
"\n ~a, ")
|
||||||
first)
|
first)
|
||||||
(loop (cdr to)
|
(loop (cdr to)
|
||||||
(+ len header-space 2)))
|
(+ len header-space 2)))
|
||||||
(begin
|
(begin
|
||||||
(fprintf writer
|
(fprintf writer
|
||||||
(if (null? rest)
|
(if (null? rest)
|
||||||
"~a "
|
"~a "
|
||||||
"~a, ")
|
"~a, ")
|
||||||
first)
|
first)
|
||||||
(loop (cdr to)
|
(loop (cdr to)
|
||||||
(+ len indent 2))))))))))])
|
(+ len indent 2))))))))))])
|
||||||
(write-recipient-header "To" to-recipients)
|
(write-recipient-header "To" to-recipients)
|
||||||
(unless (null? cc-recipients)
|
(unless (null? cc-recipients)
|
||||||
(write-recipient-header "CC" cc-recipients)))
|
(write-recipient-header "CC" cc-recipients)))
|
||||||
(fprintf writer "Subject: ~a\n" subject)
|
(fprintf writer "Subject: ~a\n" subject)
|
||||||
(fprintf writer "X-Mailer: MzScheme: see www.plt-scheme.org\n")
|
(fprintf writer "X-Mailer: MzScheme: see www.plt-scheme.org\n")
|
||||||
(for-each (lambda (s)
|
(for-each (lambda (s)
|
||||||
(display s writer)
|
(display s writer)
|
||||||
(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
|
||||||
other-headers)])
|
other-headers)])
|
||||||
(for-each (lambda (s)
|
(for-each (lambda (s)
|
||||||
(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)))
|
||||||
|
|
|
||||||
File diff suppressed because it is too large
Load Diff
Loading…
Reference in New Issue
Block a user