reformatting
svn: r9853 original commit: 0d41afdb6d470299616dd1db944ce4577c5a64bf
This commit is contained in:
Eli Barzilay
parent
db624416dd
commit
ec81ffebfc
|
|
@ -1,4 +1,3 @@
|
|||
|
||||
#lang scheme/signature
|
||||
|
||||
base64-filename-safe
|
||||
|
|
|
|||
|
|
@ -1,214 +1,210 @@
|
|||
#lang scheme/unit
|
||||
(require "cgi-sig.ss" "uri-codec.ss")
|
||||
|
||||
(require mzlib/etc
|
||||
"cgi-sig.ss"
|
||||
"uri-codec.ss")
|
||||
(import)
|
||||
(export cgi^)
|
||||
|
||||
(import)
|
||||
(export cgi^)
|
||||
;; type bindings = list ((symbol . string))
|
||||
|
||||
;; type bindings = list ((symbol . string))
|
||||
;; --------------------------------------------------------------------
|
||||
|
||||
;; --------------------------------------------------------------------
|
||||
;; Exceptions:
|
||||
|
||||
;; Exceptions:
|
||||
(define-struct cgi-error ())
|
||||
|
||||
(define-struct cgi-error ())
|
||||
;; chars : list (char)
|
||||
;; -- gives the suffix which is invalid, not including the `%'
|
||||
|
||||
;; chars : list (char)
|
||||
;; -- gives the suffix which is invalid, not including the `%'
|
||||
(define-struct (incomplete-%-suffix cgi-error) (chars))
|
||||
|
||||
(define-struct (incomplete-%-suffix cgi-error) (chars))
|
||||
;; char : char
|
||||
;; -- an invalid character in a hex string
|
||||
|
||||
;; char : char
|
||||
;; -- an invalid character in a hex string
|
||||
(define-struct (invalid-%-suffix cgi-error) (char))
|
||||
|
||||
(define-struct (invalid-%-suffix cgi-error) (char))
|
||||
;; --------------------------------------------------------------------
|
||||
|
||||
;; --------------------------------------------------------------------
|
||||
;; query-chars->string : list (char) -> string
|
||||
|
||||
;; query-chars->string : list (char) -> string
|
||||
;; -- The input is the characters post-processed as per Web specs, which
|
||||
;; is as follows:
|
||||
;; spaces are turned into "+"es and lots of things are turned into %XX, where
|
||||
;; XX are hex digits, eg, %E7 for ~. The output is a regular Scheme string
|
||||
;; with all the characters converted back.
|
||||
|
||||
;; -- The input is the characters post-processed as per Web specs, which
|
||||
;; is as follows:
|
||||
;; spaces are turned into "+"es and lots of things are turned into %XX, where
|
||||
;; XX are hex digits, eg, %E7 for ~. The output is a regular Scheme string
|
||||
;; with all the characters converted back.
|
||||
(define (query-chars->string chars)
|
||||
(form-urlencoded-decode (list->string chars)))
|
||||
|
||||
(define (query-chars->string chars)
|
||||
(form-urlencoded-decode (list->string chars)))
|
||||
;; string->html : string -> string
|
||||
;; -- the input is raw text, the output is HTML appropriately quoted
|
||||
|
||||
;; string->html : string -> string
|
||||
;; -- the input is raw text, the output is HTML appropriately quoted
|
||||
(define (string->html s)
|
||||
(apply string-append
|
||||
(map (lambda (c)
|
||||
(case c
|
||||
[(#\<) "<"]
|
||||
[(#\>) ">"]
|
||||
[(#\&) "&"]
|
||||
[else (string c)]))
|
||||
(string->list s))))
|
||||
|
||||
(define (string->html s)
|
||||
(apply string-append
|
||||
(map (lambda (c)
|
||||
(case c
|
||||
[(#\<) "<"]
|
||||
[(#\>) ">"]
|
||||
[(#\&) "&"]
|
||||
[else (string c)]))
|
||||
(string->list s))))
|
||||
(define default-text-color "#000000")
|
||||
(define default-bg-color "#ffffff")
|
||||
(define default-link-color "#cc2200")
|
||||
(define default-vlink-color "#882200")
|
||||
(define default-alink-color "#444444")
|
||||
|
||||
(define default-text-color "#000000")
|
||||
(define default-bg-color "#ffffff")
|
||||
(define default-link-color "#cc2200")
|
||||
(define default-vlink-color "#882200")
|
||||
(define default-alink-color "#444444")
|
||||
;; generate-html-output :
|
||||
;; html-string x list (html-string) x ... -> ()
|
||||
|
||||
;; generate-html-output :
|
||||
;; html-string x list (html-string) x ... -> ()
|
||||
(define (generate-html-output title body-lines
|
||||
[text-color default-text-color]
|
||||
[bg-color default-bg-color]
|
||||
[link-color default-link-color]
|
||||
[vlink-color default-vlink-color]
|
||||
[alink-color default-alink-color])
|
||||
(let ([sa string-append])
|
||||
(for ([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
|
||||
(opt-lambda (title body-lines
|
||||
[text-color default-text-color]
|
||||
[bg-color default-bg-color]
|
||||
[link-color default-link-color]
|
||||
[vlink-color default-vlink-color]
|
||||
[alink-color default-alink-color])
|
||||
(let ([sa string-append])
|
||||
(for-each
|
||||
(lambda (l) (display l) (newline))
|
||||
`("Content-type: text/html"
|
||||
""
|
||||
"<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
|
||||
(define (output-http-headers)
|
||||
(printf "Content-type: text/html\r\n\r\n"))
|
||||
|
||||
;; output-http-headers : -> void
|
||||
(define (output-http-headers)
|
||||
(printf "Content-type: text/html\r\n\r\n"))
|
||||
;; read-until-char : iport x char -> list (char) x bool
|
||||
;; -- operates on the default input port; the second value indicates whether
|
||||
;; reading stopped because an EOF was hit (as opposed to the delimiter being
|
||||
;; seen); the delimiter is not part of the result
|
||||
(define (read-until-char ip delimiter)
|
||||
(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
|
||||
;; -- operates on the default input port; the second value indicates whether
|
||||
;; reading stopped because an EOF was hit (as opposed to the delimiter being
|
||||
;; seen); the delimiter is not part of the result
|
||||
(define (read-until-char ip delimiter)
|
||||
(let loop ([chars '()])
|
||||
(let ([c (read-char ip)])
|
||||
(cond [(eof-object? c) (values (reverse chars) #t)]
|
||||
[(char=? c delimiter) (values (reverse chars) #f)]
|
||||
[else (loop (cons c chars))]))))
|
||||
;; read-name+value : iport -> (symbol + bool) x (string + bool) x bool
|
||||
;; -- If the first value is false, so is the second, and the third is true,
|
||||
;; indicating EOF was reached without any input seen. Otherwise, the first
|
||||
;; and second values contain strings and the third is either true or false
|
||||
;; depending on whether the EOF has been reached. The strings are processed
|
||||
;; to remove the CGI spec "escape"s. This code is _slightly_ lax: it allows
|
||||
;; an input to end in `&'. It's not clear this is legal by the CGI spec,
|
||||
;; which suggests that the last value binding must end in an EOF. It doesn't
|
||||
;; look like this matters. It would also introduce needless modality and
|
||||
;; reduce flexibility.
|
||||
(define (read-name+value ip)
|
||||
(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
|
||||
;; -- If the first value is false, so is the second, and the third is true,
|
||||
;; indicating EOF was reached without any input seen. Otherwise, the first
|
||||
;; and second values contain strings and the third is either true or false
|
||||
;; depending on whether the EOF has been reached. The strings are processed
|
||||
;; to remove the CGI spec "escape"s. This code is _slightly_ lax: it allows
|
||||
;; an input to end in `&'. It's not clear this is legal by the CGI spec,
|
||||
;; which suggests that the last value binding must end in an EOF. It doesn't
|
||||
;; look like this matters. It would also introduce needless modality and
|
||||
;; reduce flexibility.
|
||||
(define (read-name+value ip)
|
||||
(let-values ([(name eof?) (read-until-char ip #\=)])
|
||||
(cond [(and eof? (null? name)) (values #f #f #t)]
|
||||
[eof?
|
||||
(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
|
||||
(define (get-bindings/post)
|
||||
(let-values ([(name value eof?) (read-name+value (current-input-port))])
|
||||
(cond [(and eof? (not name)) null]
|
||||
[(and eof? name) (list (cons name value))]
|
||||
[else (cons (cons name value) (get-bindings/post))])))
|
||||
|
||||
;; get-bindings/post : () -> bindings
|
||||
(define (get-bindings/post)
|
||||
(let-values ([(name value eof?) (read-name+value (current-input-port))])
|
||||
(cond [(and eof? (not name)) null]
|
||||
[(and eof? name) (list (cons name value))]
|
||||
[else (cons (cons name value) (get-bindings/post))])))
|
||||
;; get-bindings/get : () -> bindings
|
||||
(define (get-bindings/get)
|
||||
(let ([p (open-input-string (getenv "QUERY_STRING"))])
|
||||
(let loop ()
|
||||
(let-values ([(name value eof?) (read-name+value p)])
|
||||
(cond [(and eof? (not name)) null]
|
||||
[(and eof? name) (list (cons name value))]
|
||||
[else (cons (cons name value) (loop))])))))
|
||||
|
||||
;; get-bindings/get : () -> bindings
|
||||
(define (get-bindings/get)
|
||||
(let ([p (open-input-string (getenv "QUERY_STRING"))])
|
||||
(let loop ()
|
||||
(let-values ([(name value eof?) (read-name+value p)])
|
||||
(cond [(and eof? (not name)) null]
|
||||
[(and eof? name) (list (cons name value))]
|
||||
[else (cons (cons name value) (loop))])))))
|
||||
;; get-bindings : () -> bindings
|
||||
(define (get-bindings)
|
||||
(if (string=? (get-cgi-method) "POST")
|
||||
(get-bindings/post)
|
||||
(get-bindings/get)))
|
||||
|
||||
;; get-bindings : () -> bindings
|
||||
(define (get-bindings)
|
||||
(if (string=? (get-cgi-method) "POST")
|
||||
(get-bindings/post)
|
||||
(get-bindings/get)))
|
||||
;; generate-error-output : list (html-string) -> <exit>
|
||||
(define (generate-error-output error-message-lines)
|
||||
(generate-html-output "Internal Error" error-message-lines)
|
||||
(exit))
|
||||
|
||||
;; generate-error-output : list (html-string) -> <exit>
|
||||
(define (generate-error-output error-message-lines)
|
||||
(generate-html-output "Internal Error" error-message-lines)
|
||||
(exit))
|
||||
;; bindings-as-html : bindings -> list (html-string)
|
||||
;; -- formats name-value bindings as HTML appropriate for displaying
|
||||
(define (bindings-as-html bindings)
|
||||
`("<code>"
|
||||
,@(map (lambda (bind)
|
||||
(string-append (symbol->string (car bind))
|
||||
" --> "
|
||||
(cdr bind)
|
||||
"<br>"))
|
||||
bindings)
|
||||
"</code>"))
|
||||
|
||||
;; bindings-as-html : bindings -> list (html-string)
|
||||
;; -- formats name-value bindings as HTML appropriate for displaying
|
||||
(define (bindings-as-html bindings)
|
||||
`("<code>"
|
||||
,@(map (lambda (bind)
|
||||
(string-append (symbol->string (car bind))
|
||||
" --> "
|
||||
(cdr bind)
|
||||
"<br>"))
|
||||
bindings)
|
||||
"</code>"))
|
||||
;; extract-bindings : (string + symbol) x bindings -> list (string)
|
||||
;; -- Extracts the bindings associated with a given name. The semantics of
|
||||
;; forms states that a CHECKBOX may use the same NAME field multiple times.
|
||||
;; Hence, a list of strings is returned. Note that the result may be the
|
||||
;; empty list.
|
||||
(define (extract-bindings field-name bindings)
|
||||
(let ([field-name (if (symbol? field-name)
|
||||
field-name (string->symbol field-name))])
|
||||
(let loop ([found null] [bindings bindings])
|
||||
(if (null? bindings)
|
||||
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)
|
||||
;; -- Extracts the bindings associated with a given name. The semantics of
|
||||
;; forms states that a CHECKBOX may use the same NAME field multiple times.
|
||||
;; Hence, a list of strings is returned. Note that the result may be the
|
||||
;; empty list.
|
||||
(define (extract-bindings field-name bindings)
|
||||
(let ([field-name (if (symbol? field-name)
|
||||
field-name (string->symbol field-name))])
|
||||
(let loop ([found null] [bindings bindings])
|
||||
(if (null? bindings)
|
||||
found
|
||||
(if (equal? field-name (caar bindings))
|
||||
(loop (cons (cdar bindings) found) (cdr bindings))
|
||||
(loop found (cdr bindings)))))))
|
||||
;; extract-binding/single : (string + symbol) x bindings -> string
|
||||
;; -- used in cases where only one binding is supposed to occur
|
||||
(define (extract-binding/single field-name bindings)
|
||||
(let* ([field-name (if (symbol? field-name)
|
||||
field-name (string->symbol field-name))]
|
||||
[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)))])))
|
||||
|
||||
;; extract-binding/single : (string + symbol) x bindings -> string
|
||||
;; -- used in cases where only one binding is supposed to occur
|
||||
(define (extract-binding/single field-name bindings)
|
||||
(let* ([field-name (if (symbol? field-name)
|
||||
field-name (string->symbol field-name))]
|
||||
[result (extract-bindings field-name bindings)])
|
||||
(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
|
||||
;; -- string is either GET or POST (though future extension is possible)
|
||||
(define (get-cgi-method)
|
||||
(or (getenv "REQUEST_METHOD")
|
||||
(error 'get-cgi-method "no REQUEST_METHOD environment variable")))
|
||||
|
||||
;; get-cgi-method : () -> string
|
||||
;; -- string is either GET or POST (though future extension is possible)
|
||||
(define (get-cgi-method)
|
||||
(or (getenv "REQUEST_METHOD")
|
||||
(error 'get-cgi-method "no REQUEST_METHOD environment variable")))
|
||||
|
||||
;; generate-link-text : string x html-string -> html-string
|
||||
(define (generate-link-text url anchor-text)
|
||||
(string-append "<a href=\"" url "\">" anchor-text "</a>"))
|
||||
;; 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
|
||||
|
||||
(require mzlib/etc
|
||||
mzlib/list
|
||||
srfi/13/string
|
||||
srfi/14/char-set
|
||||
"cookie-sig.ss")
|
||||
(require srfi/13/string srfi/14/char-set "cookie-sig.ss")
|
||||
|
||||
(import)
|
||||
(export cookie^)
|
||||
(import)
|
||||
(export cookie^)
|
||||
|
||||
(define-struct cookie (name value comment domain max-age path secure version) #:mutable)
|
||||
(define-struct (cookie-error exn:fail) ())
|
||||
(define-struct cookie
|
||||
(name value comment domain max-age path secure version) #:mutable)
|
||||
(define-struct (cookie-error exn:fail) ())
|
||||
|
||||
;; error* : string args ... -> raises a cookie-error exception
|
||||
;; constructs a cookie-error struct from the given error message
|
||||
;; (added to fix exceptions-must-take-immutable-strings bug)
|
||||
(define (error* fmt . args)
|
||||
(raise (make-cookie-error (apply format fmt args)
|
||||
(current-continuation-marks))))
|
||||
;; error* : string args ... -> raises a cookie-error exception
|
||||
;; constructs a cookie-error struct from the given error message
|
||||
;; (added to fix exceptions-must-take-immutable-strings bug)
|
||||
(define (error* fmt . args)
|
||||
(raise (make-cookie-error (apply format fmt args)
|
||||
(current-continuation-marks))))
|
||||
|
||||
;; The syntax for the Set-Cookie response header is
|
||||
;; set-cookie = "Set-Cookie:" cookies
|
||||
;; cookies = 1#cookie
|
||||
;; cookie = NAME "=" VALUE *(";" cookie-av)
|
||||
;; NAME = attr
|
||||
;; VALUE = value
|
||||
;; cookie-av = "Comment" "=" value
|
||||
;; | "Domain" "=" value
|
||||
;; | "Max-Age" "=" value
|
||||
;; | "Path" "=" value
|
||||
;; | "Secure"
|
||||
;; | "Version" "=" 1*DIGIT
|
||||
(define (set-cookie name pre-value)
|
||||
(let ([value (to-rfc2109:value pre-value)])
|
||||
(unless (rfc2068:token? name)
|
||||
(error* "invalid cookie name: ~a / ~a" name value))
|
||||
(make-cookie name value
|
||||
#f ; comment
|
||||
#f ; current domain
|
||||
#f ; at the end of session
|
||||
#f ; current path
|
||||
#f ; normal (non SSL)
|
||||
#f ; default version
|
||||
)))
|
||||
;; The syntax for the Set-Cookie response header is
|
||||
;; set-cookie = "Set-Cookie:" cookies
|
||||
;; cookies = 1#cookie
|
||||
;; cookie = NAME "=" VALUE *(";" cookie-av)
|
||||
;; NAME = attr
|
||||
;; VALUE = value
|
||||
;; cookie-av = "Comment" "=" value
|
||||
;; | "Domain" "=" value
|
||||
;; | "Max-Age" "=" value
|
||||
;; | "Path" "=" value
|
||||
;; | "Secure"
|
||||
;; | "Version" "=" 1*DIGIT
|
||||
(define (set-cookie name pre-value)
|
||||
(let ([value (to-rfc2109:value pre-value)])
|
||||
(unless (rfc2068:token? name)
|
||||
(error* "invalid cookie name: ~a / ~a" name value))
|
||||
(make-cookie name value
|
||||
#f ; comment
|
||||
#f ; current domain
|
||||
#f ; at the end of session
|
||||
#f ; current path
|
||||
#f ; normal (non SSL)
|
||||
#f ; default version
|
||||
)))
|
||||
|
||||
;;!
|
||||
;;
|
||||
;; (function (print-cookie cookie))
|
||||
;;
|
||||
;; (param cookie Cookie-structure "The cookie to return as a string")
|
||||
;;
|
||||
;; Formats the cookie contents in a string ready to be appended to a
|
||||
;; "Set-Cookie: " header, and sent to a client (browser).
|
||||
(define (print-cookie cookie)
|
||||
;;!
|
||||
;;
|
||||
;; (function (print-cookie cookie))
|
||||
;;
|
||||
;; (param cookie Cookie-structure "The cookie to return as a string")
|
||||
;;
|
||||
;; Formats the cookie contents in a string ready to be appended to a
|
||||
;; "Set-Cookie: " header, and sent to a client (browser).
|
||||
(define (print-cookie cookie)
|
||||
(define (format-if fmt val) (and val (format fmt val)))
|
||||
(unless (cookie? cookie) (error* "cookie expected, received: ~a" cookie))
|
||||
(string-join
|
||||
(filter 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)
|
||||
(error* "cookie expected, received: ~a" cookie))
|
||||
(string-join
|
||||
(filter (lambda (s) (not (string-null? s)))
|
||||
(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)))))
|
||||
"; "))
|
||||
(set-cookie-comment! cookie comment)
|
||||
cookie))
|
||||
|
||||
(define (cookie:add-comment cookie pre-comment)
|
||||
(let ([comment (to-rfc2109:value pre-comment)])
|
||||
(unless (cookie? cookie)
|
||||
(error* "cookie expected, received: ~a" cookie))
|
||||
(set-cookie-comment! cookie comment)
|
||||
cookie))
|
||||
(define (cookie:add-domain cookie domain)
|
||||
(unless (valid-domain? domain)
|
||||
(error* "invalid domain: ~a" domain))
|
||||
(unless (cookie? cookie)
|
||||
(error* "cookie expected, received: ~a" cookie))
|
||||
(set-cookie-domain! cookie domain)
|
||||
cookie)
|
||||
|
||||
(define (cookie:add-domain cookie domain)
|
||||
(unless (valid-domain? domain)
|
||||
(error* "invalid domain: ~a" domain))
|
||||
(define (cookie:add-max-age cookie seconds)
|
||||
(unless (and (integer? seconds) (not (negative? seconds)))
|
||||
(error* "invalid Max-Age for cookie: ~a" seconds))
|
||||
(unless (cookie? cookie)
|
||||
(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)
|
||||
(error* "cookie expected, received: ~a" cookie))
|
||||
(set-cookie-domain! cookie domain)
|
||||
cookie)
|
||||
(set-cookie-path! cookie path)
|
||||
cookie))
|
||||
|
||||
(define (cookie:add-max-age cookie seconds)
|
||||
(unless (and (integer? seconds) (not (negative? seconds)))
|
||||
(error* "invalid Max-Age for cookie: ~a" seconds))
|
||||
(unless (cookie? cookie)
|
||||
(error* "cookie expected, received: ~a" cookie))
|
||||
(set-cookie-max-age! cookie seconds)
|
||||
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:add-path cookie pre-path)
|
||||
(let ([path (to-rfc2109:value pre-path)])
|
||||
(unless (cookie? cookie)
|
||||
(error* "cookie expected, received: ~a" cookie))
|
||||
(set-cookie-path! cookie path)
|
||||
cookie))
|
||||
|
||||
(define (cookie:secure cookie secure?)
|
||||
(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)
|
||||
(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=
|
||||
(char-set-difference char-set:full (string->char-set "=")))
|
||||
(define char-set:all-but=
|
||||
(char-set-difference char-set:full (string->char-set "=")))
|
||||
|
||||
(define char-set:all-but-semicolon
|
||||
(char-set-difference char-set:full (string->char-set ";")))
|
||||
(define char-set:all-but-semicolon
|
||||
(char-set-difference char-set:full (string->char-set ";")))
|
||||
|
||||
;;!
|
||||
;;
|
||||
;; (function (get-all-results name cookies))
|
||||
;;
|
||||
;; Auxiliar procedure that returns all values associated with
|
||||
;; `name' in the association list (cookies).
|
||||
(define (get-all-results name cookies)
|
||||
(let loop ([c cookies])
|
||||
(if (null? c)
|
||||
'()
|
||||
(let ([pair (car c)])
|
||||
(if (string=? name (car pair))
|
||||
;; found an instance of cookie named `name'
|
||||
(cons (cadr pair) (loop (cdr c)))
|
||||
(loop (cdr c)))))))
|
||||
;;!
|
||||
;;
|
||||
;; (function (get-all-results name cookies))
|
||||
;;
|
||||
;; Auxiliar procedure that returns all values associated with
|
||||
;; `name' in the association list (cookies).
|
||||
(define (get-all-results name cookies)
|
||||
(let loop ([c cookies])
|
||||
(if (null? c)
|
||||
'()
|
||||
(let ([pair (car c)])
|
||||
(if (string=? name (car pair))
|
||||
;; found an instance of cookie named `name'
|
||||
(cons (cadr pair) (loop (cdr c)))
|
||||
(loop (cdr c)))))))
|
||||
|
||||
;; which typically looks like:
|
||||
;; (cookie . "test5=\"5\"; test1=\"1\"; test0=\"0\"; test1=\"20\"")
|
||||
;; note that it can be multi-valued: `test1' has values: "1", and "20". Of
|
||||
;; course, in the same spirit, we only receive the "string content".
|
||||
(define (get-cookie name cookies)
|
||||
(let ([cookies (map (lambda (p)
|
||||
(map string-trim-both
|
||||
(string-tokenize p char-set:all-but=)))
|
||||
(string-tokenize cookies char-set:all-but-semicolon))])
|
||||
(get-all-results name cookies)))
|
||||
;; which typically looks like:
|
||||
;; (cookie . "test5=\"5\"; test1=\"1\"; test0=\"0\"; test1=\"20\"")
|
||||
;; note that it can be multi-valued: `test1' has values: "1", and "20". Of
|
||||
;; course, in the same spirit, we only receive the "string content".
|
||||
(define (get-cookie name cookies)
|
||||
(let ([cookies (map (lambda (p)
|
||||
(map string-trim-both
|
||||
(string-tokenize p char-set:all-but=)))
|
||||
(string-tokenize cookies char-set:all-but-semicolon))])
|
||||
(get-all-results name cookies)))
|
||||
|
||||
;;!
|
||||
;;
|
||||
;; (function (get-cookie/single name cookies))
|
||||
;;
|
||||
;; (param name String "The name of the cookie we are looking for")
|
||||
;; (param cookies String "The string (from the environment) with the content of the cookie header.")
|
||||
;;
|
||||
;; Returns the first name associated with the cookie named `name', if any, or #f.
|
||||
(define (get-cookie/single name cookies)
|
||||
(let ([cookies (get-cookie name cookies)])
|
||||
(and (not (null? cookies)) (car cookies))))
|
||||
;;!
|
||||
;;
|
||||
;; (function (get-cookie/single name cookies))
|
||||
;;
|
||||
;; (param name String "The name of the cookie we are looking for")
|
||||
;; (param cookies String "The string (from the environment) with the content of the cookie header.")
|
||||
;;
|
||||
;; Returns the first name associated with the cookie named `name', if any, or #f.
|
||||
(define (get-cookie/single name cookies)
|
||||
(let ([cookies (get-cookie name cookies)])
|
||||
(and (not (null? cookies)) (car cookies))))
|
||||
|
||||
|
||||
;;;;;
|
||||
;; Auxiliary procedures
|
||||
;;;;;
|
||||
;;;;;
|
||||
;; Auxiliary procedures
|
||||
;;;;;
|
||||
|
||||
;; token = 1*<any CHAR except CTLs or tspecials>
|
||||
;;
|
||||
;; tspecials = "(" | ")" | "<" | ">" | "@"
|
||||
;; | "," | ";" | ":" | "\" | <">
|
||||
;; | "/" | "[" | "]" | "?" | "="
|
||||
;; | "{" | "}" | SP | HT
|
||||
(define char-set:tspecials
|
||||
(char-set-union (string->char-set "()<>@,;:\\\"/[]?={}")
|
||||
char-set:whitespace
|
||||
(char-set #\tab)))
|
||||
;; token = 1*<any CHAR except CTLs or tspecials>
|
||||
;;
|
||||
;; tspecials = "(" | ")" | "<" | ">" | "@"
|
||||
;; | "," | ";" | ":" | "\" | <">
|
||||
;; | "/" | "[" | "]" | "?" | "="
|
||||
;; | "{" | "}" | SP | HT
|
||||
(define char-set:tspecials
|
||||
(char-set-union (string->char-set "()<>@,;:\\\"/[]?={}")
|
||||
char-set:whitespace
|
||||
(char-set #\tab)))
|
||||
|
||||
(define char-set:control
|
||||
(char-set-union char-set:iso-control
|
||||
(char-set (integer->char 127))));; DEL
|
||||
(define char-set:token
|
||||
(char-set-difference char-set:ascii char-set:tspecials char-set:control))
|
||||
(define char-set:control
|
||||
(char-set-union char-set:iso-control
|
||||
(char-set (integer->char 127))));; DEL
|
||||
(define char-set:token
|
||||
(char-set-difference char-set:ascii char-set:tspecials char-set:control))
|
||||
|
||||
;; token? : string -> boolean
|
||||
;;
|
||||
;; returns #t if s is an RFC 2068 token (see definition above), #f otherwise.
|
||||
(define (rfc2068:token? s)
|
||||
(string-every char-set:token s))
|
||||
;; token? : string -> boolean
|
||||
;;
|
||||
;; returns #t if s is an RFC 2068 token (see definition above), #f otherwise.
|
||||
(define (rfc2068:token? s)
|
||||
(string-every char-set:token s))
|
||||
|
||||
;;!
|
||||
;;
|
||||
;; (function (quoted-string? s))
|
||||
;;
|
||||
;; (param s String "The string to check")
|
||||
;;
|
||||
;; Returns s if the string is an RFC 2068 quoted-string, #f otherwise. As in:
|
||||
;; quoted-string = ( <"> *(qdtext) <"> )
|
||||
;; qdtext = <any TEXT except <">>
|
||||
;;
|
||||
;; The backslash character ("\") may be used as a single-character quoting
|
||||
;; mechanism only within quoted-string and comment constructs.
|
||||
;;
|
||||
;; quoted-pair = "\" CHAR
|
||||
;;
|
||||
;; implementation note: I have chosen to use a regular expression rather than
|
||||
;; a character set for this definition because of two dependencies: CRLF must
|
||||
;; appear as a block to be legal, and " may only appear as \"
|
||||
(define (rfc2068:quoted-string? s)
|
||||
(if (regexp-match
|
||||
#rx"^\"([^\"#\u0000-#\u001F]| |#\return#\newline|#\tab|\\\\\")*\"$"
|
||||
s)
|
||||
s
|
||||
#f))
|
||||
;;!
|
||||
;;
|
||||
;; (function (quoted-string? s))
|
||||
;;
|
||||
;; (param s String "The string to check")
|
||||
;;
|
||||
;; Returns s if the string is an RFC 2068 quoted-string, #f otherwise. As in:
|
||||
;; quoted-string = ( <"> *(qdtext) <"> )
|
||||
;; qdtext = <any TEXT except <">>
|
||||
;;
|
||||
;; The backslash character ("\") may be used as a single-character quoting
|
||||
;; mechanism only within quoted-string and comment constructs.
|
||||
;;
|
||||
;; quoted-pair = "\" CHAR
|
||||
;;
|
||||
;; implementation note: I have chosen to use a regular expression rather than
|
||||
;; a character set for this definition because of two dependencies: CRLF must
|
||||
;; appear as a block to be legal, and " may only appear as \"
|
||||
(define (rfc2068:quoted-string? s)
|
||||
(and (regexp-match?
|
||||
#rx"^\"([^\"#\u0000-#\u001F]| |#\return#\newline|#\tab|\\\\\")*\"$"
|
||||
s)
|
||||
s))
|
||||
|
||||
;; value: token | quoted-string
|
||||
(define (rfc2109:value? s)
|
||||
(or (rfc2068:token? s) (rfc2068:quoted-string? s)))
|
||||
;; value: token | quoted-string
|
||||
(define (rfc2109:value? s)
|
||||
(or (rfc2068:token? s) (rfc2068:quoted-string? s)))
|
||||
|
||||
;; convert-to-quoted : string -> quoted-string?
|
||||
;; takes the given string as a particular message, and converts the given
|
||||
;; string to that representatation
|
||||
(define (convert-to-quoted str)
|
||||
(string-append "\"" (regexp-replace* #rx"\"" str "\\\\\"") "\""))
|
||||
;; convert-to-quoted : string -> quoted-string?
|
||||
;; takes the given string as a particular message, and converts the given
|
||||
;; string to that representatation
|
||||
(define (convert-to-quoted str)
|
||||
(string-append "\"" (regexp-replace* #rx"\"" str "\\\\\"") "\""))
|
||||
|
||||
;; string -> rfc2109:value?
|
||||
(define (to-rfc2109:value s)
|
||||
(cond
|
||||
[(not (string? s))
|
||||
(error* "expected string, given: ~e" s)]
|
||||
;; string -> rfc2109:value?
|
||||
(define (to-rfc2109:value s)
|
||||
(cond
|
||||
[(not (string? s))
|
||||
(error* "expected string, given: ~e" s)]
|
||||
|
||||
;; for backwards compatibility, just use the given string if it will work
|
||||
[(rfc2068:token? s) s]
|
||||
[(rfc2068:quoted-string? s) s]
|
||||
;; for backwards compatibility, just use the given string if it will work
|
||||
[(rfc2068:token? s) s]
|
||||
[(rfc2068:quoted-string? s) s]
|
||||
|
||||
;; ... 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
|
||||
[(rfc2068:quoted-string? (convert-to-quoted s))
|
||||
=> (λ (x) x)]
|
||||
[else
|
||||
(error* "could not convert the given string to an acceptable RFC 2109 value: ~s" s)]))
|
||||
;; ... 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
|
||||
[(rfc2068:quoted-string? (convert-to-quoted s))
|
||||
=> (λ (x) x)]
|
||||
[else
|
||||
(error* "could not convert the given string to an acceptable RFC 2109 value: ~s" s)]))
|
||||
|
||||
;;!
|
||||
;;
|
||||
;; (function (cookie-string? s))
|
||||
;;
|
||||
;; (param s String "String to check")
|
||||
;;
|
||||
;; Returns whether this is a valid string to use as the value or the
|
||||
;; name (depending on value?) of an HTTP cookie.
|
||||
(define cookie-string?
|
||||
(opt-lambda (s (value? #t))
|
||||
(unless (string? s)
|
||||
(error* "string expected, received: ~a" s))
|
||||
(if value?
|
||||
(rfc2109:value? s)
|
||||
;; name: token
|
||||
(rfc2068:token? s))))
|
||||
;;!
|
||||
;;
|
||||
;; (function (cookie-string? s))
|
||||
;;
|
||||
;; (param s String "String to check")
|
||||
;;
|
||||
;; Returns whether this is a valid string to use as the value or the
|
||||
;; name (depending on value?) of an HTTP cookie.
|
||||
(define (cookie-string? s [value? #t])
|
||||
(unless (string? s)
|
||||
(error* "string expected, received: ~a" s))
|
||||
(if value?
|
||||
(rfc2109:value? s)
|
||||
;; name: token
|
||||
(rfc2068:token? s)))
|
||||
|
||||
;; Host names as per RFC 1123 and RFC952, more or less, anyway. :-)
|
||||
(define char-set:hostname
|
||||
(let ([a-z-lowercase (ucs-range->char-set #x61 #x7B)]
|
||||
[a-z-uppercase (ucs-range->char-set #x41 #x5B)])
|
||||
(char-set-adjoin!
|
||||
(char-set-union char-set:digit a-z-lowercase a-z-uppercase)
|
||||
#\.)))
|
||||
;; Host names as per RFC 1123 and RFC952, more or less, anyway. :-)
|
||||
(define char-set:hostname
|
||||
(let ([a-z-lowercase (ucs-range->char-set #x61 #x7B)]
|
||||
[a-z-uppercase (ucs-range->char-set #x41 #x5B)])
|
||||
(char-set-adjoin!
|
||||
(char-set-union char-set:digit a-z-lowercase a-z-uppercase)
|
||||
#\.)))
|
||||
|
||||
(define (valid-domain? dom)
|
||||
(and ;; Domain must start with a dot (.)
|
||||
(string=? (string-take dom 1) ".")
|
||||
;; The rest are tokens-like strings separated by dots
|
||||
(string-every char-set:hostname dom)
|
||||
(<= (string-length dom) 76)))
|
||||
(define (valid-domain? dom)
|
||||
(and ;; Domain must start with a dot (.)
|
||||
(string=? (string-take dom 1) ".")
|
||||
;; The rest are tokens-like strings separated by dots
|
||||
(string-every char-set:hostname dom)
|
||||
(<= (string-length dom) 76)))
|
||||
|
||||
(define (valid-path? v)
|
||||
(and (string? v) (rfc2109:value? v)))
|
||||
(define (valid-path? v)
|
||||
(and (string? v) (rfc2109:value? v)))
|
||||
|
||||
;;; cookie-unit.ss ends here
|
||||
|
|
|
|||
|
|
@ -1,345 +1,338 @@
|
|||
#lang scheme/unit
|
||||
|
||||
(require mzlib/list mzlib/process "dns-sig.ss"
|
||||
scheme/udp)
|
||||
(require "dns-sig.ss" scheme/system scheme/udp)
|
||||
|
||||
(import)
|
||||
(export dns^)
|
||||
(import)
|
||||
(export dns^)
|
||||
|
||||
;; UDP retry timeout:
|
||||
(define INIT-TIMEOUT 50)
|
||||
;; UDP retry timeout:
|
||||
(define INIT-TIMEOUT 50)
|
||||
|
||||
(define types
|
||||
'((a 1)
|
||||
(ns 2)
|
||||
(md 3)
|
||||
(mf 4)
|
||||
(cname 5)
|
||||
(soa 6)
|
||||
(mb 7)
|
||||
(mg 8)
|
||||
(mr 9)
|
||||
(null 10)
|
||||
(wks 11)
|
||||
(ptr 12)
|
||||
(hinfo 13)
|
||||
(minfo 14)
|
||||
(mx 15)
|
||||
(txt 16)))
|
||||
(define types
|
||||
'((a 1)
|
||||
(ns 2)
|
||||
(md 3)
|
||||
(mf 4)
|
||||
(cname 5)
|
||||
(soa 6)
|
||||
(mb 7)
|
||||
(mg 8)
|
||||
(mr 9)
|
||||
(null 10)
|
||||
(wks 11)
|
||||
(ptr 12)
|
||||
(hinfo 13)
|
||||
(minfo 14)
|
||||
(mx 15)
|
||||
(txt 16)))
|
||||
|
||||
(define classes
|
||||
'((in 1)
|
||||
(cs 2)
|
||||
(ch 3)
|
||||
(hs 4)))
|
||||
(define classes
|
||||
'((in 1)
|
||||
(cs 2)
|
||||
(ch 3)
|
||||
(hs 4)))
|
||||
|
||||
(define (cossa i l)
|
||||
(cond [(null? l) #f]
|
||||
[(equal? (cadar l) i) (car l)]
|
||||
[else (cossa i (cdr l))]))
|
||||
(define (cossa i l)
|
||||
(cond [(null? l) #f]
|
||||
[(equal? (cadar l) i) (car l)]
|
||||
[else (cossa i (cdr l))]))
|
||||
|
||||
(define (number->octet-pair n)
|
||||
(list (arithmetic-shift n -8)
|
||||
(modulo n 256)))
|
||||
(define (number->octet-pair n)
|
||||
(list (arithmetic-shift n -8)
|
||||
(modulo n 256)))
|
||||
|
||||
(define (octet-pair->number a b)
|
||||
(+ (arithmetic-shift a 8) b))
|
||||
(define (octet-pair->number a b)
|
||||
(+ (arithmetic-shift a 8) b))
|
||||
|
||||
(define (octet-quad->number a b c d)
|
||||
(+ (arithmetic-shift a 24)
|
||||
(arithmetic-shift b 16)
|
||||
(arithmetic-shift c 8)
|
||||
d))
|
||||
(define (octet-quad->number a b c d)
|
||||
(+ (arithmetic-shift a 24)
|
||||
(arithmetic-shift b 16)
|
||||
(arithmetic-shift c 8)
|
||||
d))
|
||||
|
||||
(define (name->octets s)
|
||||
(let ([do-one (lambda (s)
|
||||
(cons (bytes-length s) (bytes->list s)))])
|
||||
(let loop ([s s])
|
||||
(let ([m (regexp-match #rx#"^([^.]*)[.](.*)" s)])
|
||||
(if m
|
||||
(append (do-one (cadr m)) (loop (caddr m)))
|
||||
(append (do-one s) (list 0)))))))
|
||||
(define (name->octets s)
|
||||
(let ([do-one (lambda (s) (cons (bytes-length s) (bytes->list s)))])
|
||||
(let loop ([s s])
|
||||
(let ([m (regexp-match #rx#"^([^.]*)[.](.*)" s)])
|
||||
(if m
|
||||
(append (do-one (cadr m)) (loop (caddr m)))
|
||||
(append (do-one s) (list 0)))))))
|
||||
|
||||
(define (make-std-query-header id question-count)
|
||||
(append (number->octet-pair id)
|
||||
(list 1 0) ; Opcode & flags (recusive flag set)
|
||||
(number->octet-pair question-count)
|
||||
(number->octet-pair 0)
|
||||
(number->octet-pair 0)
|
||||
(number->octet-pair 0)))
|
||||
(define (make-std-query-header id question-count)
|
||||
(append (number->octet-pair id)
|
||||
(list 1 0) ; Opcode & flags (recusive flag set)
|
||||
(number->octet-pair question-count)
|
||||
(number->octet-pair 0)
|
||||
(number->octet-pair 0)
|
||||
(number->octet-pair 0)))
|
||||
|
||||
(define (make-query id name type class)
|
||||
(append (make-std-query-header id 1)
|
||||
(name->octets name)
|
||||
(number->octet-pair (cadr (assoc type types)))
|
||||
(number->octet-pair (cadr (assoc class classes)))))
|
||||
(define (make-query id name type class)
|
||||
(append (make-std-query-header id 1)
|
||||
(name->octets name)
|
||||
(number->octet-pair (cadr (assoc type types)))
|
||||
(number->octet-pair (cadr (assoc class classes)))))
|
||||
|
||||
(define (add-size-tag m)
|
||||
(append (number->octet-pair (length m)) m))
|
||||
(define (add-size-tag m)
|
||||
(append (number->octet-pair (length m)) m))
|
||||
|
||||
(define (rr-data rr)
|
||||
(cadddr (cdr rr)))
|
||||
(define (rr-data rr)
|
||||
(cadddr (cdr rr)))
|
||||
|
||||
(define (rr-type rr)
|
||||
(cadr rr))
|
||||
(define (rr-type rr)
|
||||
(cadr rr))
|
||||
|
||||
(define (rr-name rr)
|
||||
(car rr))
|
||||
(define (rr-name rr)
|
||||
(car rr))
|
||||
|
||||
(define (parse-name start reply)
|
||||
(let ([v (car start)])
|
||||
(cond
|
||||
[(zero? v)
|
||||
;; End of name
|
||||
(values #f (cdr start))]
|
||||
[(zero? (bitwise-and #xc0 v))
|
||||
;; Normal label
|
||||
(let loop ([len v][start (cdr start)][accum null])
|
||||
(cond
|
||||
[(zero? len)
|
||||
(let-values ([(s start) (parse-name start reply)])
|
||||
(let ([s0 (list->bytes (reverse accum))])
|
||||
(values (if s (bytes-append s0 #"." s) s0)
|
||||
start)))]
|
||||
[else (loop (sub1 len) (cdr start) (cons (car start) accum))]))]
|
||||
[else
|
||||
;; Compression offset
|
||||
(let ([offset (+ (arithmetic-shift (bitwise-and #x3f v) 8)
|
||||
(cadr start))])
|
||||
(let-values ([(s ignore-start)
|
||||
(parse-name (list-tail reply offset) reply)])
|
||||
(values s (cddr start))))])))
|
||||
(define (parse-name start reply)
|
||||
(let ([v (car start)])
|
||||
(cond
|
||||
[(zero? v)
|
||||
;; End of name
|
||||
(values #f (cdr start))]
|
||||
[(zero? (bitwise-and #xc0 v))
|
||||
;; Normal label
|
||||
(let loop ([len v][start (cdr start)][accum null])
|
||||
(if (zero? len)
|
||||
(let-values ([(s start) (parse-name start reply)])
|
||||
(let ([s0 (list->bytes (reverse accum))])
|
||||
(values (if s (bytes-append s0 #"." s) s0)
|
||||
start)))
|
||||
(loop (sub1 len) (cdr start) (cons (car start) accum))))]
|
||||
[else
|
||||
;; Compression offset
|
||||
(let ([offset (+ (arithmetic-shift (bitwise-and #x3f v) 8)
|
||||
(cadr start))])
|
||||
(let-values ([(s ignore-start)
|
||||
(parse-name (list-tail reply offset) reply)])
|
||||
(values s (cddr start))))])))
|
||||
|
||||
(define (parse-rr start reply)
|
||||
(let-values ([(name start) (parse-name start reply)])
|
||||
(let* ([type (car (cossa (octet-pair->number (car start) (cadr start))
|
||||
types))]
|
||||
[start (cddr start)]
|
||||
;;
|
||||
[class (car (cossa (octet-pair->number (car start) (cadr start))
|
||||
classes))]
|
||||
[start (cddr start)]
|
||||
;;
|
||||
[ttl (octet-quad->number (car start) (cadr start)
|
||||
(caddr start) (cadddr start))]
|
||||
[start (cddddr start)]
|
||||
;;
|
||||
[len (octet-pair->number (car start) (cadr start))]
|
||||
[start (cddr start)])
|
||||
;; Extract next len bytes for data:
|
||||
(let loop ([len len] [start start] [accum null])
|
||||
(if (zero? len)
|
||||
(values (list name type class ttl (reverse accum))
|
||||
start)
|
||||
(loop (sub1 len) (cdr start) (cons (car start) accum)))))))
|
||||
(define (parse-rr start reply)
|
||||
(let-values ([(name start) (parse-name start reply)])
|
||||
(let* ([type (car (cossa (octet-pair->number (car start) (cadr start))
|
||||
types))]
|
||||
[start (cddr start)]
|
||||
;;
|
||||
[class (car (cossa (octet-pair->number (car start) (cadr start))
|
||||
classes))]
|
||||
[start (cddr start)]
|
||||
;;
|
||||
[ttl (octet-quad->number (car start) (cadr start)
|
||||
(caddr start) (cadddr start))]
|
||||
[start (cddddr start)]
|
||||
;;
|
||||
[len (octet-pair->number (car start) (cadr start))]
|
||||
[start (cddr start)])
|
||||
;; Extract next len bytes for data:
|
||||
(let loop ([len len] [start start] [accum null])
|
||||
(if (zero? len)
|
||||
(values (list name type class ttl (reverse accum))
|
||||
start)
|
||||
(loop (sub1 len) (cdr start) (cons (car start) accum)))))))
|
||||
|
||||
(define (parse-ques start reply)
|
||||
(let-values ([(name start) (parse-name start reply)])
|
||||
(let* ([type (car (cossa (octet-pair->number (car start) (cadr start))
|
||||
types))]
|
||||
[start (cddr start)]
|
||||
;;
|
||||
[class (car (cossa (octet-pair->number (car start) (cadr start))
|
||||
classes))]
|
||||
[start (cddr start)])
|
||||
(values (list name type class) start))))
|
||||
(define (parse-ques start reply)
|
||||
(let-values ([(name start) (parse-name start reply)])
|
||||
(let* ([type (car (cossa (octet-pair->number (car start) (cadr start))
|
||||
types))]
|
||||
[start (cddr start)]
|
||||
;;
|
||||
[class (car (cossa (octet-pair->number (car start) (cadr start))
|
||||
classes))]
|
||||
[start (cddr start)])
|
||||
(values (list name type class) start))))
|
||||
|
||||
(define (parse-n parse start reply n)
|
||||
(let loop ([n n][start start][accum null])
|
||||
(if (zero? n)
|
||||
(values (reverse accum) start)
|
||||
(let-values ([(rr start) (parse start reply)])
|
||||
(loop (sub1 n) start (cons rr accum))))))
|
||||
(define (parse-n parse start reply n)
|
||||
(let loop ([n n][start start][accum null])
|
||||
(if (zero? n)
|
||||
(values (reverse accum) start)
|
||||
(let-values ([(rr start) (parse start reply)])
|
||||
(loop (sub1 n) start (cons rr accum))))))
|
||||
|
||||
(define (dns-query nameserver addr type class)
|
||||
(unless (assoc type types)
|
||||
(raise-type-error 'dns-query "DNS query type" type))
|
||||
(unless (assoc class classes)
|
||||
(raise-type-error 'dns-query "DNS query class" class))
|
||||
(define (dns-query nameserver addr type class)
|
||||
(unless (assoc type types)
|
||||
(raise-type-error 'dns-query "DNS query type" type))
|
||||
(unless (assoc class classes)
|
||||
(raise-type-error 'dns-query "DNS query class" class))
|
||||
|
||||
(let* ([query (make-query (random 256) (string->bytes/latin-1 addr)
|
||||
type class)]
|
||||
[udp (udp-open-socket)]
|
||||
[reply
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda ()
|
||||
(let ([s (make-bytes 512)])
|
||||
(let retry ([timeout INIT-TIMEOUT])
|
||||
(udp-send-to udp nameserver 53 (list->bytes query))
|
||||
(sync (handle-evt
|
||||
(udp-receive!-evt udp s)
|
||||
(lambda (r)
|
||||
(bytes->list (subbytes s 0 (car r)))))
|
||||
(handle-evt
|
||||
(alarm-evt (+ (current-inexact-milliseconds)
|
||||
timeout))
|
||||
(lambda (v)
|
||||
(retry (* timeout 2))))))))
|
||||
(lambda () (udp-close udp)))])
|
||||
(let* ([query (make-query (random 256) (string->bytes/latin-1 addr)
|
||||
type class)]
|
||||
[udp (udp-open-socket)]
|
||||
[reply
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda ()
|
||||
(let ([s (make-bytes 512)])
|
||||
(let retry ([timeout INIT-TIMEOUT])
|
||||
(udp-send-to udp nameserver 53 (list->bytes query))
|
||||
(sync (handle-evt (udp-receive!-evt udp s)
|
||||
(lambda (r)
|
||||
(bytes->list (subbytes s 0 (car r)))))
|
||||
(handle-evt (alarm-evt (+ (current-inexact-milliseconds)
|
||||
timeout))
|
||||
(lambda (v)
|
||||
(retry (* timeout 2))))))))
|
||||
(lambda () (udp-close udp)))])
|
||||
|
||||
;; First two bytes must match sent message id:
|
||||
(unless (and (= (car reply) (car query))
|
||||
(= (cadr reply) (cadr query)))
|
||||
(error 'dns-query "bad reply id from server"))
|
||||
;; First two bytes must match sent message id:
|
||||
(unless (and (= (car reply) (car query))
|
||||
(= (cadr reply) (cadr query)))
|
||||
(error 'dns-query "bad reply id from server"))
|
||||
|
||||
(let ([v0 (caddr reply)]
|
||||
[v1 (cadddr reply)])
|
||||
;; Check for error code:
|
||||
(let ([rcode (bitwise-and #xf v1)])
|
||||
(unless (zero? rcode)
|
||||
(error 'dns-query "error from server: ~a"
|
||||
(case rcode
|
||||
[(1) "format error"]
|
||||
[(2) "server failure"]
|
||||
[(3) "name error"]
|
||||
[(4) "not implemented"]
|
||||
[(5) "refused"]))))
|
||||
(let ([v0 (caddr reply)]
|
||||
[v1 (cadddr reply)])
|
||||
;; Check for error code:
|
||||
(let ([rcode (bitwise-and #xf v1)])
|
||||
(unless (zero? rcode)
|
||||
(error 'dns-query "error from server: ~a"
|
||||
(case rcode
|
||||
[(1) "format error"]
|
||||
[(2) "server failure"]
|
||||
[(3) "name error"]
|
||||
[(4) "not implemented"]
|
||||
[(5) "refused"]))))
|
||||
|
||||
(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))]
|
||||
[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))])
|
||||
(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))]
|
||||
[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))])
|
||||
|
||||
(let ([start (list-tail reply 12)])
|
||||
(let*-values ([(qds start) (parse-n parse-ques start reply qd-count)]
|
||||
[(ans start) (parse-n parse-rr start reply an-count)]
|
||||
[(nss start) (parse-n parse-rr start reply ns-count)]
|
||||
[(ars start) (parse-n parse-rr start reply ar-count)])
|
||||
(unless (null? start)
|
||||
(error 'dns-query "error parsing server reply"))
|
||||
(values (positive? (bitwise-and #x4 v0))
|
||||
qds ans nss ars reply)))))))
|
||||
(let ([start (list-tail reply 12)])
|
||||
(let*-values ([(qds start) (parse-n parse-ques start reply qd-count)]
|
||||
[(ans start) (parse-n parse-rr start reply an-count)]
|
||||
[(nss start) (parse-n parse-rr start reply ns-count)]
|
||||
[(ars start) (parse-n parse-rr start reply ar-count)])
|
||||
(unless (null? start)
|
||||
(error 'dns-query "error parsing server reply"))
|
||||
(values (positive? (bitwise-and #x4 v0))
|
||||
qds ans nss ars reply)))))))
|
||||
|
||||
(define cache (make-hasheq))
|
||||
(define (dns-query/cache nameserver addr type class)
|
||||
(let ([key (string->symbol (format "~a;~a;~a;~a" nameserver addr type class))])
|
||||
(let ([v (hash-ref cache key (lambda () #f))])
|
||||
(if v
|
||||
(apply values v)
|
||||
(let-values ([(auth? qds ans nss ars reply) (dns-query nameserver addr type class)])
|
||||
(hash-set! cache key (list auth? qds ans nss ars reply))
|
||||
(values auth? qds ans nss ars reply))))))
|
||||
(define cache (make-hasheq))
|
||||
(define (dns-query/cache nameserver addr type class)
|
||||
(let ([key (string->symbol (format "~a;~a;~a;~a" nameserver addr type class))])
|
||||
(let ([v (hash-ref cache key (lambda () #f))])
|
||||
(if v
|
||||
(apply values v)
|
||||
(let-values ([(auth? qds ans nss ars reply)
|
||||
(dns-query nameserver addr type class)])
|
||||
(hash-set! cache key (list auth? qds ans nss ars reply))
|
||||
(values auth? qds ans nss ars reply))))))
|
||||
|
||||
(define (ip->string s)
|
||||
(format "~a.~a.~a.~a"
|
||||
(list-ref s 0) (list-ref s 1) (list-ref s 2) (list-ref s 3)))
|
||||
(define (ip->string s)
|
||||
(format "~a.~a.~a.~a"
|
||||
(list-ref s 0) (list-ref s 1) (list-ref s 2) (list-ref s 3)))
|
||||
|
||||
(define (try-forwarding k nameserver)
|
||||
(let loop ([nameserver nameserver][tried (list nameserver)])
|
||||
;; Normally the recusion is done for us, but it's technically optional
|
||||
(let-values ([(v ars auth?) (k nameserver)])
|
||||
(or v
|
||||
(and (not auth?)
|
||||
(let* ([ns (ormap (lambda (ar)
|
||||
(and (eq? (rr-type ar) 'a)
|
||||
(ip->string (rr-data ar))))
|
||||
ars)])
|
||||
(and ns
|
||||
(not (member ns tried))
|
||||
(loop ns (cons ns tried)))))))))
|
||||
(define (try-forwarding k nameserver)
|
||||
(let loop ([nameserver nameserver][tried (list nameserver)])
|
||||
;; Normally the recusion is done for us, but it's technically optional
|
||||
(let-values ([(v ars auth?) (k nameserver)])
|
||||
(or v
|
||||
(and (not auth?)
|
||||
(let* ([ns (ormap (lambda (ar)
|
||||
(and (eq? (rr-type ar) 'a)
|
||||
(ip->string (rr-data ar))))
|
||||
ars)])
|
||||
(and ns
|
||||
(not (member ns tried))
|
||||
(loop ns (cons ns tried)))))))))
|
||||
|
||||
(define (ip->in-addr.arpa ip)
|
||||
(let ([result (regexp-match #rx"^([0-9]+)\\.([0-9]+)\\.([0-9]+)\\.([0-9]+)$"
|
||||
ip)])
|
||||
(format "~a.~a.~a.~a.in-addr.arpa"
|
||||
(list-ref result 4)
|
||||
(list-ref result 3)
|
||||
(list-ref result 2)
|
||||
(list-ref result 1))))
|
||||
(define (ip->in-addr.arpa ip)
|
||||
(let ([result (regexp-match #rx"^([0-9]+)\\.([0-9]+)\\.([0-9]+)\\.([0-9]+)$"
|
||||
ip)])
|
||||
(format "~a.~a.~a.~a.in-addr.arpa"
|
||||
(list-ref result 4)
|
||||
(list-ref result 3)
|
||||
(list-ref result 2)
|
||||
(list-ref result 1))))
|
||||
|
||||
(define (get-ptr-list-from-ans ans)
|
||||
(filter (lambda (ans-entry) (eq? (list-ref ans-entry 1) 'ptr))
|
||||
ans))
|
||||
(define (get-ptr-list-from-ans ans)
|
||||
(filter (lambda (ans-entry) (eq? (list-ref ans-entry 1) 'ptr)) ans))
|
||||
|
||||
(define (dns-get-name nameserver ip)
|
||||
(or (try-forwarding
|
||||
(lambda (nameserver)
|
||||
(let-values ([(auth? qds ans nss ars reply)
|
||||
(dns-query/cache nameserver (ip->in-addr.arpa ip) 'ptr 'in)])
|
||||
(values (and (positive? (length (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)])
|
||||
(bytes->string/latin-1 name))))
|
||||
ars auth?)))
|
||||
nameserver)
|
||||
(error 'dns-get-name "bad ip address")))
|
||||
(define (dns-get-name nameserver ip)
|
||||
(or (try-forwarding
|
||||
(lambda (nameserver)
|
||||
(let-values ([(auth? qds ans nss ars reply)
|
||||
(dns-query/cache nameserver (ip->in-addr.arpa ip) 'ptr 'in)])
|
||||
(values (and (positive? (length (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)])
|
||||
(bytes->string/latin-1 name))))
|
||||
ars auth?)))
|
||||
nameserver)
|
||||
(error 'dns-get-name "bad ip address")))
|
||||
|
||||
(define (get-a-list-from-ans ans)
|
||||
(filter (lambda (ans-entry) (eq? (list-ref ans-entry 1) 'a))
|
||||
ans))
|
||||
(define (get-a-list-from-ans ans)
|
||||
(filter (lambda (ans-entry) (eq? (list-ref ans-entry 1) 'a))
|
||||
ans))
|
||||
|
||||
(define (dns-get-address nameserver addr)
|
||||
(or (try-forwarding
|
||||
(lambda (nameserver)
|
||||
(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)))
|
||||
(let ([s (rr-data (car (get-a-list-from-ans ans)))])
|
||||
(ip->string s)))
|
||||
ars auth?)))
|
||||
nameserver)
|
||||
(error 'dns-get-address "bad address")))
|
||||
(define (dns-get-address nameserver addr)
|
||||
(or (try-forwarding
|
||||
(lambda (nameserver)
|
||||
(let-values ([(auth? qds ans nss ars reply) (dns-query/cache nameserver addr 'a 'in)])
|
||||
(values (and (positive? (length (get-a-list-from-ans ans)))
|
||||
(let ([s (rr-data (car (get-a-list-from-ans ans)))])
|
||||
(ip->string s)))
|
||||
ars auth?)))
|
||||
nameserver)
|
||||
(error 'dns-get-address "bad address")))
|
||||
|
||||
(define (dns-get-mail-exchanger nameserver addr)
|
||||
(or (try-forwarding
|
||||
(lambda (nameserver)
|
||||
(let-values ([(auth? qds ans nss ars reply) (dns-query/cache nameserver addr 'mx 'in)])
|
||||
(values (let loop ([ans ans][best-pref +inf.0][exchanger #f])
|
||||
(cond
|
||||
[(null? ans)
|
||||
(or exchanger
|
||||
;; Does 'soa mean that the input address is fine?
|
||||
(and (ormap (lambda (ns) (eq? (rr-type ns) 'soa))
|
||||
nss)
|
||||
addr))]
|
||||
[else
|
||||
(let ([d (rr-data (car ans))])
|
||||
(let ([pref (octet-pair->number (car d) (cadr d))])
|
||||
(if (< pref best-pref)
|
||||
(let-values ([(name start) (parse-name (cddr d) reply)])
|
||||
(loop (cdr ans) pref name))
|
||||
(loop (cdr ans) best-pref exchanger))))]))
|
||||
ars auth?)))
|
||||
nameserver)
|
||||
(error 'dns-get-mail-exchanger "bad address")))
|
||||
(define (dns-get-mail-exchanger nameserver addr)
|
||||
(or (try-forwarding
|
||||
(lambda (nameserver)
|
||||
(let-values ([(auth? qds ans nss ars reply) (dns-query/cache nameserver addr 'mx 'in)])
|
||||
(values (let loop ([ans ans][best-pref +inf.0][exchanger #f])
|
||||
(cond
|
||||
[(null? ans)
|
||||
(or exchanger
|
||||
;; Does 'soa mean that the input address is fine?
|
||||
(and (ormap (lambda (ns) (eq? (rr-type ns) 'soa))
|
||||
nss)
|
||||
addr))]
|
||||
[else
|
||||
(let ([d (rr-data (car ans))])
|
||||
(let ([pref (octet-pair->number (car d) (cadr d))])
|
||||
(if (< pref best-pref)
|
||||
(let-values ([(name start) (parse-name (cddr d) reply)])
|
||||
(loop (cdr ans) pref name))
|
||||
(loop (cdr ans) best-pref exchanger))))]))
|
||||
ars auth?)))
|
||||
nameserver)
|
||||
(error 'dns-get-mail-exchanger "bad address")))
|
||||
|
||||
(define (dns-find-nameserver)
|
||||
(case (system-type)
|
||||
[(unix macosx)
|
||||
(with-handlers ([void (lambda (x) #f)])
|
||||
(with-input-from-file "/etc/resolv.conf"
|
||||
(lambda ()
|
||||
(let loop ()
|
||||
(let ([l (read-line)])
|
||||
(or (and (string? l)
|
||||
(let ([m (regexp-match
|
||||
#rx"nameserver[ \t]+([0-9]+[.][0-9]+[.][0-9]+[.][0-9]+)"
|
||||
l)])
|
||||
(and m (cadr m))))
|
||||
(and (not (eof-object? l))
|
||||
(loop))))))))]
|
||||
[(windows)
|
||||
(let ([nslookup (find-executable-path "nslookup.exe" #f)])
|
||||
(and nslookup
|
||||
(let-values ([(pin pout pid perr proc)
|
||||
(apply
|
||||
values
|
||||
(process/ports
|
||||
#f (open-input-file "NUL") (current-error-port)
|
||||
nslookup))])
|
||||
(let loop ([name #f][ip #f][try-ip? #f])
|
||||
(let ([line (read-line pin 'any)])
|
||||
(cond [(eof-object? line)
|
||||
(close-input-port pin)
|
||||
(proc 'wait)
|
||||
(or ip name)]
|
||||
[(and (not name)
|
||||
(regexp-match #rx"^Default Server: +(.*)$"
|
||||
line))
|
||||
=> (lambda (m) (loop (cadr m) #f #t))]
|
||||
[(and try-ip?
|
||||
(regexp-match #rx"^Address: +(.*)$"
|
||||
line))
|
||||
=> (lambda (m) (loop name (cadr m) #f))]
|
||||
[else (loop name ip #f)]))))))]
|
||||
[else #f]))
|
||||
(define (dns-find-nameserver)
|
||||
(case (system-type)
|
||||
[(unix macosx)
|
||||
(with-handlers ([void (lambda (x) #f)])
|
||||
(with-input-from-file "/etc/resolv.conf"
|
||||
(lambda ()
|
||||
(let loop ()
|
||||
(let ([l (read-line)])
|
||||
(or (and (string? l)
|
||||
(let ([m (regexp-match
|
||||
#rx"nameserver[ \t]+([0-9]+[.][0-9]+[.][0-9]+[.][0-9]+)"
|
||||
l)])
|
||||
(and m (cadr m))))
|
||||
(and (not (eof-object? l))
|
||||
(loop))))))))]
|
||||
[(windows)
|
||||
(let ([nslookup (find-executable-path "nslookup.exe" #f)])
|
||||
(and nslookup
|
||||
(let-values ([(pin pout pid perr proc)
|
||||
(apply
|
||||
values
|
||||
(process/ports
|
||||
#f (open-input-file "NUL") (current-error-port)
|
||||
nslookup))])
|
||||
(let loop ([name #f] [ip #f] [try-ip? #f])
|
||||
(let ([line (read-line pin 'any)])
|
||||
(cond [(eof-object? line)
|
||||
(close-input-port pin)
|
||||
(proc 'wait)
|
||||
(or ip name)]
|
||||
[(and (not name)
|
||||
(regexp-match #rx"^Default Server: +(.*)$" line))
|
||||
=> (lambda (m) (loop (cadr m) #f #t))]
|
||||
[(and try-ip?
|
||||
(regexp-match #rx"^Address: +(.*)$" line))
|
||||
=> (lambda (m) (loop name (cadr m) #f))]
|
||||
[else (loop name ip #f)]))))))]
|
||||
[else #f]))
|
||||
|
|
|
|||
|
|
@ -1,349 +1,345 @@
|
|||
#lang scheme/unit
|
||||
|
||||
(require mzlib/date mzlib/string "head-sig.ss")
|
||||
(require mzlib/date mzlib/string "head-sig.ss")
|
||||
|
||||
(import)
|
||||
(export head^)
|
||||
(import)
|
||||
(export head^)
|
||||
|
||||
;; NB: I've done a copied-code adaptation of a number of these definitions
|
||||
;; into "bytes-compatible" versions. Finishing the rest will require some
|
||||
;; kind of interface decision---that is, when you don't supply a header,
|
||||
;; should the resulting operation be string-centric or bytes-centric?
|
||||
;; Easiest just to stop here.
|
||||
;; -- JBC 2006-07-31
|
||||
;; NB: I've done a copied-code adaptation of a number of these definitions
|
||||
;; into "bytes-compatible" versions. Finishing the rest will require some
|
||||
;; kind of interface decision---that is, when you don't supply a header,
|
||||
;; should the resulting operation be string-centric or bytes-centric?
|
||||
;; Easiest just to stop here.
|
||||
;; -- JBC 2006-07-31
|
||||
|
||||
(define CRLF (string #\return #\newline))
|
||||
(define CRLF/bytes #"\r\n")
|
||||
(define CRLF (string #\return #\newline))
|
||||
(define CRLF/bytes #"\r\n")
|
||||
|
||||
(define empty-header CRLF)
|
||||
(define empty-header/bytes CRLF/bytes)
|
||||
(define empty-header CRLF)
|
||||
(define empty-header/bytes CRLF/bytes)
|
||||
|
||||
(define re:field-start (regexp "^[^ \t\n\r\v:\001-\032\"]*:"))
|
||||
(define re:field-start/bytes #rx#"^[^ \t\n\r\v:\001-\032\"]*:")
|
||||
(define re:field-start (regexp "^[^ \t\n\r\v:\001-\032\"]*:"))
|
||||
(define re:field-start/bytes #rx#"^[^ \t\n\r\v:\001-\032\"]*:")
|
||||
|
||||
(define re:continue (regexp "^[ \t\v]"))
|
||||
(define re:continue/bytes #rx#"^[ \t\v]")
|
||||
(define re:continue (regexp "^[ \t\v]"))
|
||||
(define re:continue/bytes #rx#"^[ \t\v]")
|
||||
|
||||
(define (validate-header s)
|
||||
(if (bytes? s)
|
||||
;; legal char check not needed per rfc 2822, IIUC.
|
||||
(let ([len (bytes-length s)])
|
||||
(define (validate-header s)
|
||||
(if (bytes? s)
|
||||
;; legal char check not needed per rfc 2822, IIUC.
|
||||
(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])
|
||||
(cond
|
||||
[(and (= (+ offset 2) len)
|
||||
(bytes=? CRLF/bytes (subbytes s offset len)))
|
||||
(string=? CRLF (substring 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)])
|
||||
[(= 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/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])
|
||||
(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)))]))))))
|
||||
(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)
|
||||
(regexp (format "(^|[\r][\n])(~a: *)" (regexp-quote field #f))))
|
||||
(define (make-field-start-regexp field)
|
||||
(regexp (format "(^|[\r][\n])(~a: *)" (regexp-quote field #f))))
|
||||
|
||||
(define (make-field-start-regexp/bytes field)
|
||||
(byte-regexp (bytes-append #"(^|[\r][\n])("(regexp-quote field #f) #": *)")))
|
||||
(define (make-field-start-regexp/bytes field)
|
||||
(byte-regexp (bytes-append #"(^|[\r][\n])("(regexp-quote field #f) #": *)")))
|
||||
|
||||
(define (extract-field field header)
|
||||
(if (bytes? header)
|
||||
(let ([m (regexp-match-positions (make-field-start-regexp/bytes field)
|
||||
header)])
|
||||
(and m
|
||||
(let ([s (subbytes header
|
||||
(cdaddr m)
|
||||
(bytes-length header))])
|
||||
(let ([m (regexp-match-positions #rx#"[\r][\n][^: \r\n\"]*:" s)])
|
||||
(if m
|
||||
(subbytes s 0 (caar m))
|
||||
;; Rest of header is this field, but strip trailing CRLFCRLF:
|
||||
(regexp-replace #rx#"\r\n\r\n$" s ""))))))
|
||||
;; otherwise header & field should be strings:
|
||||
(let ([m (regexp-match-positions (make-field-start-regexp field)
|
||||
header)])
|
||||
(and m
|
||||
(let ([s (substring header
|
||||
(cdaddr m)
|
||||
(string-length header))])
|
||||
(let ([m (regexp-match-positions #rx"[\r][\n][^: \r\n\"]*:" s)])
|
||||
(if m
|
||||
(substring s 0 (caar m))
|
||||
;; Rest of header is this field, but strip trailing CRLFCRLF:
|
||||
(regexp-replace #rx"\r\n\r\n$" s ""))))))))
|
||||
(define (extract-field field header)
|
||||
(if (bytes? header)
|
||||
(let ([m (regexp-match-positions (make-field-start-regexp/bytes field)
|
||||
header)])
|
||||
(and m
|
||||
(let ([s (subbytes header
|
||||
(cdaddr m)
|
||||
(bytes-length header))])
|
||||
(let ([m (regexp-match-positions #rx#"[\r][\n][^: \r\n\"]*:" s)])
|
||||
(if m
|
||||
(subbytes s 0 (caar m))
|
||||
;; Rest of header is this field, but strip trailing CRLFCRLF:
|
||||
(regexp-replace #rx#"\r\n\r\n$" s ""))))))
|
||||
;; otherwise header & field should be strings:
|
||||
(let ([m (regexp-match-positions (make-field-start-regexp field)
|
||||
header)])
|
||||
(and m
|
||||
(let ([s (substring header
|
||||
(cdaddr m)
|
||||
(string-length header))])
|
||||
(let ([m (regexp-match-positions #rx"[\r][\n][^: \r\n\"]*:" s)])
|
||||
(if m
|
||||
(substring s 0 (caar m))
|
||||
;; Rest of header is this field, but strip trailing CRLFCRLF:
|
||||
(regexp-replace #rx"\r\n\r\n$" s ""))))))))
|
||||
|
||||
(define (replace-field field data header)
|
||||
(if (bytes? header)
|
||||
(let ([m (regexp-match-positions (make-field-start-regexp/bytes field)
|
||||
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)
|
||||
(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 (remove-field field header)
|
||||
(replace-field field #f header))
|
||||
|
||||
(define (remove-field field header)
|
||||
(replace-field field #f header))
|
||||
(define (insert-field field data 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)
|
||||
(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 (append-headers a b)
|
||||
(if (bytes? a)
|
||||
(let ([alen (bytes-length a)])
|
||||
(if (> alen 1)
|
||||
(bytes-append (subbytes a 0 (- alen 2)) b)
|
||||
(error 'append-headers "first argument is not a header: ~a" a)))
|
||||
;; 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)
|
||||
(if (bytes? a)
|
||||
(let ([alen (bytes-length a)])
|
||||
(if (> alen 1)
|
||||
(bytes-append (subbytes a 0 (- alen 2)) b)
|
||||
(error 'append-headers "first argument is not a header: ~a" a)))
|
||||
;; 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 (extract-all-fields header)
|
||||
(if (bytes? header)
|
||||
(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 (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))))))
|
||||
|
||||
(define (extract-all-fields header)
|
||||
(if (bytes? header)
|
||||
(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 (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
|
||||
;; accept a header as input; for lack of an obvious solution (and free time),
|
||||
;; I'm stopping the string->bytes translation here. -- JBC, 2006-07-31
|
||||
|
||||
;; It's slightly less obvious how to generalize the functions that don't
|
||||
;; accept a header as input; for lack of an obvious solution (and free time),
|
||||
;; I'm stopping the string->bytes translation here. -- JBC, 2006-07-31
|
||||
|
||||
(define (standard-message-header from tos ccs bccs subject)
|
||||
(let ([h (insert-field
|
||||
"Subject" subject
|
||||
(insert-field
|
||||
"Date" (parameterize ([date-display-format 'rfc2822])
|
||||
(date->string (seconds->date (current-seconds)) #t))
|
||||
CRLF))])
|
||||
;; NOTE: bccs don't go into the header; that's why they're "blind"
|
||||
(let ([h (if (null? ccs)
|
||||
(define (standard-message-header from tos ccs bccs subject)
|
||||
(let ([h (insert-field
|
||||
"Subject" subject
|
||||
(insert-field
|
||||
"Date" (parameterize ([date-display-format 'rfc2822])
|
||||
(date->string (seconds->date (current-seconds)) #t))
|
||||
CRLF))])
|
||||
;; NOTE: bccs don't go into the header; that's why they're "blind"
|
||||
(let ([h (if (null? ccs)
|
||||
h
|
||||
(insert-field "CC" (assemble-address-field ccs) h))])
|
||||
(let ([h (if (null? tos)
|
||||
h
|
||||
(insert-field "CC" (assemble-address-field ccs) h))])
|
||||
(let ([h (if (null? tos)
|
||||
h
|
||||
(insert-field "To" (assemble-address-field tos) h))])
|
||||
(insert-field "From" from h)))))
|
||||
(insert-field "To" (assemble-address-field tos) h))])
|
||||
(insert-field "From" from h)))))
|
||||
|
||||
(define (splice l sep)
|
||||
(if (null? l)
|
||||
""
|
||||
(format "~a~a"
|
||||
(car l)
|
||||
(apply string-append
|
||||
(map (lambda (n) (format "~a~a" sep n))
|
||||
(cdr l))))))
|
||||
(define (splice l sep)
|
||||
(if (null? l)
|
||||
""
|
||||
(format "~a~a"
|
||||
(car l)
|
||||
(apply string-append
|
||||
(map (lambda (n) (format "~a~a" sep n))
|
||||
(cdr l))))))
|
||||
|
||||
(define (data-lines->data datas)
|
||||
(splice datas "\r\n\t"))
|
||||
(define (data-lines->data datas)
|
||||
(splice datas "\r\n\t"))
|
||||
|
||||
;; Extracting Addresses ;;
|
||||
;; Extracting Addresses ;;
|
||||
|
||||
(define blank "[ \t\n\r\v]")
|
||||
(define nonblank "[^ \t\n\r\v]")
|
||||
(define re:all-blank (regexp (format "^~a*$" blank)))
|
||||
(define re:quoted (regexp "\"[^\"]*\""))
|
||||
(define re:parened (regexp "[(][^)]*[)]"))
|
||||
(define re:comma (regexp ","))
|
||||
(define re:comma-separated (regexp "([^,]*),(.*)"))
|
||||
(define blank "[ \t\n\r\v]")
|
||||
(define nonblank "[^ \t\n\r\v]")
|
||||
(define re:all-blank (regexp (format "^~a*$" blank)))
|
||||
(define re:quoted (regexp "\"[^\"]*\""))
|
||||
(define re:parened (regexp "[(][^)]*[)]"))
|
||||
(define re:comma (regexp ","))
|
||||
(define re:comma-separated (regexp "([^,]*),(.*)"))
|
||||
|
||||
(define (extract-addresses s form)
|
||||
(unless (memq form '(name address full all))
|
||||
(raise-type-error 'extract-addresses
|
||||
"form: 'name, 'address, 'full, or 'all"
|
||||
form))
|
||||
(if (or (not s) (regexp-match re:all-blank s))
|
||||
null
|
||||
(let loop ([prefix ""][s s])
|
||||
;; Which comes first - a quote or a comma?
|
||||
(let* ([mq1 (regexp-match-positions re:quoted s)]
|
||||
[mq2 (regexp-match-positions re:parened s)]
|
||||
[mq (if (and mq1 mq2)
|
||||
(if (< (caar mq1) (caar mq2))
|
||||
mq1
|
||||
mq2)
|
||||
(or mq1 mq2))]
|
||||
[mc (regexp-match-positions re:comma s)])
|
||||
(if (and mq mc (< (caar mq) (caar mc) (cdar mq)))
|
||||
;; Quote contains a comma
|
||||
(loop (string-append
|
||||
prefix
|
||||
(substring s 0 (cdar mq)))
|
||||
(substring s (cdar mq) (string-length s)))
|
||||
;; Normal comma parsing:
|
||||
(let ([m (regexp-match re:comma-separated s)])
|
||||
(if m
|
||||
(let ([n (extract-one-name (string-append prefix (cadr m)) form)]
|
||||
[rest (extract-addresses (caddr m) form)])
|
||||
(cons n rest))
|
||||
(let ([n (extract-one-name (string-append prefix s) form)])
|
||||
(list n)))))))))
|
||||
(define (extract-addresses s form)
|
||||
(unless (memq form '(name address full all))
|
||||
(raise-type-error 'extract-addresses
|
||||
"form: 'name, 'address, 'full, or 'all"
|
||||
form))
|
||||
(if (or (not s) (regexp-match re:all-blank s))
|
||||
null
|
||||
(let loop ([prefix ""][s s])
|
||||
;; Which comes first - a quote or a comma?
|
||||
(let* ([mq1 (regexp-match-positions re:quoted s)]
|
||||
[mq2 (regexp-match-positions re:parened s)]
|
||||
[mq (if (and mq1 mq2)
|
||||
(if (< (caar mq1) (caar mq2)) mq1 mq2)
|
||||
(or mq1 mq2))]
|
||||
[mc (regexp-match-positions re:comma s)])
|
||||
(if (and mq mc (< (caar mq) (caar mc) (cdar mq)))
|
||||
;; Quote contains a comma
|
||||
(loop (string-append
|
||||
prefix
|
||||
(substring s 0 (cdar mq)))
|
||||
(substring s (cdar mq) (string-length s)))
|
||||
;; Normal comma parsing:
|
||||
(let ([m (regexp-match re:comma-separated s)])
|
||||
(if m
|
||||
(let ([n (extract-one-name (string-append prefix (cadr m)) form)]
|
||||
[rest (extract-addresses (caddr m) form)])
|
||||
(cons n rest))
|
||||
(let ([n (extract-one-name (string-append prefix s) form)])
|
||||
(list n)))))))))
|
||||
|
||||
(define (select-result form name addr full)
|
||||
(case form
|
||||
[(name) name]
|
||||
[(address) addr]
|
||||
[(full) full]
|
||||
[(all) (list name addr full)]))
|
||||
(define (select-result form name addr full)
|
||||
(case form
|
||||
[(name) name]
|
||||
[(address) addr]
|
||||
[(full) full]
|
||||
[(all) (list name addr full)]))
|
||||
|
||||
(define (one-result form s)
|
||||
(select-result form s s s))
|
||||
(define (one-result form s)
|
||||
(select-result form s s s))
|
||||
|
||||
(define re:quoted-name (regexp (format "^~a*(\"[^\"]*\")(.*)" blank)))
|
||||
(define re:parened-name (regexp (format "(.*)[(]([^)]*)[)]~a*$" blank)))
|
||||
(define re:simple-name (regexp (format "^~a*(~a.*)(<.*>)~a*$" blank nonblank blank)))
|
||||
(define re:normal-name (regexp (format "~a*<([^>]*)>~a*" blank blank)))
|
||||
(define re:double-less (regexp "<.*<"))
|
||||
(define re:double-greater (regexp ">.*>"))
|
||||
(define re:bad-chars (regexp "[,\"()<>]"))
|
||||
(define re:tail-blanks (regexp (format "~a+$" blank)))
|
||||
(define re:head-blanks (regexp (format "^~a+" blank)))
|
||||
(define re:quoted-name (regexp (format "^~a*(\"[^\"]*\")(.*)" blank)))
|
||||
(define re:parened-name (regexp (format "(.*)[(]([^)]*)[)]~a*$" blank)))
|
||||
(define re:simple-name (regexp (format "^~a*(~a.*)(<.*>)~a*$" blank nonblank blank)))
|
||||
(define re:normal-name (regexp (format "~a*<([^>]*)>~a*" blank blank)))
|
||||
(define re:double-less (regexp "<.*<"))
|
||||
(define re:double-greater (regexp ">.*>"))
|
||||
(define re:bad-chars (regexp "[,\"()<>]"))
|
||||
(define re:tail-blanks (regexp (format "~a+$" blank)))
|
||||
(define re:head-blanks (regexp (format "^~a+" blank)))
|
||||
|
||||
(define (extract-one-name orig form)
|
||||
(let loop ([s orig][form form])
|
||||
(cond
|
||||
;; ?!?!? Where does the "addr (name)" standard come from ?!?!?
|
||||
[(regexp-match re:parened-name s)
|
||||
=> (lambda (m)
|
||||
(let ([name (caddr m)]
|
||||
[all (loop (cadr m) 'all)])
|
||||
(select-result
|
||||
form
|
||||
(if (string=? (car all) (cadr all)) name (car all))
|
||||
(cadr all)
|
||||
(format "~a (~a)" (caddr all) name))))]
|
||||
[(regexp-match re:quoted-name s)
|
||||
=> (lambda (m)
|
||||
(let ([name (cadr m)]
|
||||
[addr (extract-angle-addr (caddr m) s)])
|
||||
(select-result form name addr
|
||||
(format "~a <~a>" name addr))))]
|
||||
[(regexp-match re:simple-name s)
|
||||
=> (lambda (m)
|
||||
(let ([name (regexp-replace (format "~a*$" blank) (cadr m) "")]
|
||||
[addr (extract-angle-addr (caddr m) s)])
|
||||
(select-result form name addr
|
||||
(format "~a <~a>" name addr))))]
|
||||
[(or (regexp-match "<" s) (regexp-match ">" s))
|
||||
(one-result form (extract-angle-addr s orig))]
|
||||
[else (one-result form (extract-simple-addr s orig))])))
|
||||
(define (extract-one-name orig form)
|
||||
(let loop ([s orig][form form])
|
||||
(cond
|
||||
;; ?!?!? Where does the "addr (name)" standard come from ?!?!?
|
||||
[(regexp-match re:parened-name s)
|
||||
=> (lambda (m)
|
||||
(let ([name (caddr m)]
|
||||
[all (loop (cadr m) 'all)])
|
||||
(select-result
|
||||
form
|
||||
(if (string=? (car all) (cadr all)) name (car all))
|
||||
(cadr all)
|
||||
(format "~a (~a)" (caddr all) name))))]
|
||||
[(regexp-match re:quoted-name s)
|
||||
=> (lambda (m)
|
||||
(let ([name (cadr m)]
|
||||
[addr (extract-angle-addr (caddr m) s)])
|
||||
(select-result form name addr
|
||||
(format "~a <~a>" name addr))))]
|
||||
[(regexp-match re:simple-name s)
|
||||
=> (lambda (m)
|
||||
(let ([name (regexp-replace (format "~a*$" blank) (cadr m) "")]
|
||||
[addr (extract-angle-addr (caddr m) s)])
|
||||
(select-result form name addr
|
||||
(format "~a <~a>" name addr))))]
|
||||
[(or (regexp-match "<" s) (regexp-match ">" s))
|
||||
(one-result form (extract-angle-addr s orig))]
|
||||
[else (one-result form (extract-simple-addr s orig))])))
|
||||
|
||||
(define (extract-angle-addr s orig)
|
||||
(if (or (regexp-match re:double-less s) (regexp-match re:double-greater s))
|
||||
(error 'extract-address "too many angle brackets: ~a" s)
|
||||
(let ([m (regexp-match re:normal-name s)])
|
||||
(if m
|
||||
(extract-simple-addr (cadr m) orig)
|
||||
(error 'extract-address "cannot parse address: ~a" orig)))))
|
||||
(define (extract-angle-addr s orig)
|
||||
(if (or (regexp-match re:double-less s) (regexp-match re:double-greater s))
|
||||
(error 'extract-address "too many angle brackets: ~a" s)
|
||||
(let ([m (regexp-match re:normal-name s)])
|
||||
(if m
|
||||
(extract-simple-addr (cadr m) orig)
|
||||
(error 'extract-address "cannot parse address: ~a" orig)))))
|
||||
|
||||
(define (extract-simple-addr s orig)
|
||||
(cond [(regexp-match re:bad-chars s)
|
||||
(error 'extract-address "cannot parse address: ~a" orig)]
|
||||
[else
|
||||
;; final whitespace strip
|
||||
(regexp-replace re:tail-blanks
|
||||
(regexp-replace re:head-blanks s "")
|
||||
"")]))
|
||||
(define (extract-simple-addr s orig)
|
||||
(cond [(regexp-match re:bad-chars s)
|
||||
(error 'extract-address "cannot parse address: ~a" orig)]
|
||||
[else
|
||||
;; final whitespace strip
|
||||
(regexp-replace re:tail-blanks
|
||||
(regexp-replace re:head-blanks s "")
|
||||
"")]))
|
||||
|
||||
(define (assemble-address-field addresses)
|
||||
(if (null? addresses)
|
||||
""
|
||||
(let loop ([addresses (cdr addresses)]
|
||||
[s (car addresses)]
|
||||
[len (string-length (car addresses))])
|
||||
(if (null? addresses)
|
||||
s
|
||||
(let* ([addr (car addresses)]
|
||||
[alen (string-length addr)])
|
||||
(if (<= 72 (+ len alen))
|
||||
(loop (cdr addresses)
|
||||
(format "~a,~a~a~a~a"
|
||||
s #\return #\linefeed
|
||||
#\tab addr)
|
||||
alen)
|
||||
(loop (cdr addresses)
|
||||
(format "~a, ~a" s addr)
|
||||
(+ len alen 2))))))))
|
||||
(define (assemble-address-field addresses)
|
||||
(if (null? addresses)
|
||||
""
|
||||
(let loop ([addresses (cdr addresses)]
|
||||
[s (car addresses)]
|
||||
[len (string-length (car addresses))])
|
||||
(if (null? addresses)
|
||||
s
|
||||
(let* ([addr (car addresses)]
|
||||
[alen (string-length addr)])
|
||||
(if (<= 72 (+ len alen))
|
||||
(loop (cdr addresses)
|
||||
(format "~a,~a~a~a~a"
|
||||
s #\return #\linefeed
|
||||
#\tab addr)
|
||||
alen)
|
||||
(loop (cdr addresses)
|
||||
(format "~a, ~a" s addr)
|
||||
(+ len alen 2))))))))
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -12,16 +12,13 @@
|
|||
|
||||
;; -- basic mime structures --
|
||||
(struct message (version entity fields))
|
||||
(struct entity
|
||||
(type subtype charset encoding
|
||||
disposition params id
|
||||
description other fields
|
||||
parts body))
|
||||
(struct disposition
|
||||
(type filename creation
|
||||
modification read
|
||||
size params))
|
||||
(struct entity (type subtype charset encoding
|
||||
disposition params id
|
||||
description other fields
|
||||
parts body))
|
||||
(struct disposition (type filename creation
|
||||
modification read
|
||||
size params))
|
||||
|
||||
;; -- mime methods --
|
||||
mime-analyze
|
||||
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -28,148 +28,138 @@
|
|||
|
||||
#lang scheme/unit
|
||||
|
||||
(require "qp-sig.ss"
|
||||
mzlib/etc)
|
||||
(require "qp-sig.ss")
|
||||
|
||||
(import)
|
||||
(export qp^)
|
||||
(import)
|
||||
(export qp^)
|
||||
|
||||
;; Exceptions:
|
||||
;; String or input-port expected:
|
||||
(define-struct qp-error ())
|
||||
(define-struct (qp-wrong-input qp-error) ())
|
||||
(define-struct (qp-wrong-line-size qp-error) (size))
|
||||
;; Exceptions:
|
||||
;; String or input-port expected:
|
||||
(define-struct qp-error ())
|
||||
(define-struct (qp-wrong-input qp-error) ())
|
||||
(define-struct (qp-wrong-line-size qp-error) (size))
|
||||
|
||||
;; qp-encode : bytes -> bytes
|
||||
;; returns the quoted printable representation of STR.
|
||||
(define qp-encode
|
||||
(lambda (str)
|
||||
(let ([out (open-output-bytes)])
|
||||
(qp-encode-stream (open-input-bytes str) out #"\r\n")
|
||||
(get-output-bytes out))))
|
||||
;; qp-encode : bytes -> bytes
|
||||
;; returns the quoted printable representation of STR.
|
||||
(define (qp-encode str)
|
||||
(let ([out (open-output-bytes)])
|
||||
(qp-encode-stream (open-input-bytes str) out #"\r\n")
|
||||
(get-output-bytes out)))
|
||||
|
||||
;; qp-decode : string -> string
|
||||
;; returns STR unqp.
|
||||
(define qp-decode
|
||||
(lambda (str)
|
||||
(let ([out (open-output-bytes)])
|
||||
(qp-decode-stream (open-input-bytes str) out)
|
||||
(get-output-bytes out))))
|
||||
;; qp-decode : string -> string
|
||||
;; returns STR unqp.
|
||||
(define (qp-decode str)
|
||||
(let ([out (open-output-bytes)])
|
||||
(qp-decode-stream (open-input-bytes str) out)
|
||||
(get-output-bytes out)))
|
||||
|
||||
(define qp-decode-stream
|
||||
(lambda (in out)
|
||||
(let loop ([ch (read-byte in)])
|
||||
(unless (eof-object? ch)
|
||||
(case ch
|
||||
[(61) ;; A "=", which is quoted-printable stuff
|
||||
(let ([next (read-byte in)])
|
||||
(cond
|
||||
[(eq? next 10)
|
||||
;; Soft-newline -- drop it
|
||||
(void)]
|
||||
[(eq? next 13)
|
||||
;; Expect a newline for a soft CRLF...
|
||||
(let ([next-next (read-byte in)])
|
||||
(if (eq? next-next 10)
|
||||
;; Good.
|
||||
(loop (read-byte in))
|
||||
;; Not a LF? Well, ok.
|
||||
(loop next-next)))]
|
||||
[(hex-digit? next)
|
||||
(let ([next-next (read-byte in)])
|
||||
(cond [(eof-object? next-next)
|
||||
(warning "Illegal qp sequence: `=~a'" next)
|
||||
(display "=" out)
|
||||
(display next out)]
|
||||
[(hex-digit? next-next)
|
||||
;; qp-encoded
|
||||
(write-byte (hex-bytes->byte next next-next)
|
||||
out)]
|
||||
[else
|
||||
(warning "Illegal qp sequence: `=~a~a'" next next-next)
|
||||
(write-byte 61 out)
|
||||
(write-byte next out)
|
||||
(write-byte next-next out)]))]
|
||||
[else
|
||||
;; Warning: invalid
|
||||
(warning "Illegal qp sequence: `=~a'" next)
|
||||
(write-byte 61 out)
|
||||
(write-byte next out)])
|
||||
(loop (read-byte in)))]
|
||||
[else
|
||||
(write-byte ch out)
|
||||
(loop (read-byte in))])))))
|
||||
(define (qp-decode-stream in out)
|
||||
(let loop ([ch (read-byte in)])
|
||||
(unless (eof-object? ch)
|
||||
(case ch
|
||||
[(61) ;; A "=", which is quoted-printable stuff
|
||||
(let ([next (read-byte in)])
|
||||
(cond
|
||||
[(eq? next 10)
|
||||
;; Soft-newline -- drop it
|
||||
(void)]
|
||||
[(eq? next 13)
|
||||
;; Expect a newline for a soft CRLF...
|
||||
(let ([next-next (read-byte in)])
|
||||
(if (eq? next-next 10)
|
||||
;; Good.
|
||||
(loop (read-byte in))
|
||||
;; Not a LF? Well, ok.
|
||||
(loop next-next)))]
|
||||
[(hex-digit? next)
|
||||
(let ([next-next (read-byte in)])
|
||||
(cond [(eof-object? next-next)
|
||||
(warning "Illegal qp sequence: `=~a'" next)
|
||||
(display "=" out)
|
||||
(display next out)]
|
||||
[(hex-digit? next-next)
|
||||
;; qp-encoded
|
||||
(write-byte (hex-bytes->byte next next-next)
|
||||
out)]
|
||||
[else
|
||||
(warning "Illegal qp sequence: `=~a~a'" next next-next)
|
||||
(write-byte 61 out)
|
||||
(write-byte next out)
|
||||
(write-byte next-next out)]))]
|
||||
[else
|
||||
;; Warning: invalid
|
||||
(warning "Illegal qp sequence: `=~a'" next)
|
||||
(write-byte 61 out)
|
||||
(write-byte next out)])
|
||||
(loop (read-byte in)))]
|
||||
[else
|
||||
(write-byte ch out)
|
||||
(loop (read-byte in))]))))
|
||||
|
||||
(define warning
|
||||
(lambda (msg . args)
|
||||
(when #f
|
||||
(fprintf (current-error-port)
|
||||
(apply format msg args))
|
||||
(newline (current-error-port)))))
|
||||
(define (warning msg . args)
|
||||
(when #f
|
||||
(fprintf (current-error-port)
|
||||
(apply format msg args))
|
||||
(newline (current-error-port))))
|
||||
|
||||
(define (hex-digit? i)
|
||||
(vector-ref hex-values i))
|
||||
(define (hex-digit? i)
|
||||
(vector-ref hex-values i))
|
||||
|
||||
(define hex-bytes->byte
|
||||
(lambda (b1 b2)
|
||||
(+ (* 16 (vector-ref hex-values b1))
|
||||
(vector-ref hex-values b2))))
|
||||
(define (hex-bytes->byte b1 b2)
|
||||
(+ (* 16 (vector-ref hex-values b1))
|
||||
(vector-ref hex-values b2)))
|
||||
|
||||
(define write-hex-bytes
|
||||
(lambda (byte p)
|
||||
(write-byte 61 p)
|
||||
(write-byte (vector-ref hex-bytes (arithmetic-shift byte -4)) p)
|
||||
(write-byte (vector-ref hex-bytes (bitwise-and byte 15)) p)))
|
||||
(define (write-hex-bytes byte p)
|
||||
(write-byte 61 p)
|
||||
(write-byte (vector-ref hex-bytes (arithmetic-shift byte -4)) p)
|
||||
(write-byte (vector-ref hex-bytes (bitwise-and byte 15)) p))
|
||||
|
||||
(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
|
||||
(opt-lambda (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))]))))))
|
||||
|
||||
;; 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))))
|
||||
;; 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
|
||||
|
|
|
|||
|
|
@ -1,119 +1,119 @@
|
|||
#lang scheme/unit
|
||||
|
||||
(require mzlib/process "sendmail-sig.ss")
|
||||
(require mzlib/process "sendmail-sig.ss")
|
||||
|
||||
(import)
|
||||
(export sendmail^)
|
||||
(import)
|
||||
(export sendmail^)
|
||||
|
||||
(define-struct (no-mail-recipients exn) ())
|
||||
(define-struct (no-mail-recipients exn) ())
|
||||
|
||||
(define sendmail-search-path
|
||||
'("/usr/lib" "/usr/sbin"))
|
||||
(define sendmail-search-path
|
||||
'("/usr/lib" "/usr/sbin"))
|
||||
|
||||
(define sendmail-program-file
|
||||
(if (or (eq? (system-type) 'unix)
|
||||
(eq? (system-type) 'macosx))
|
||||
(let loop ([paths sendmail-search-path])
|
||||
(if (null? paths)
|
||||
(raise (make-exn:fail:unsupported
|
||||
"unable to find sendmail on this Unix variant"
|
||||
(current-continuation-marks)))
|
||||
(let ([p (build-path (car paths) "sendmail")])
|
||||
(if (and (file-exists? p)
|
||||
(memq 'execute (file-or-directory-permissions p)))
|
||||
p
|
||||
(loop (cdr paths))))))
|
||||
(raise (make-exn:fail:unsupported
|
||||
"sendmail only available under Unix"
|
||||
(current-continuation-marks)))))
|
||||
(define sendmail-program-file
|
||||
(if (or (eq? (system-type) 'unix)
|
||||
(eq? (system-type) 'macosx))
|
||||
(let loop ([paths sendmail-search-path])
|
||||
(if (null? paths)
|
||||
(raise (make-exn:fail:unsupported
|
||||
"unable to find sendmail on this Unix variant"
|
||||
(current-continuation-marks)))
|
||||
(let ([p (build-path (car paths) "sendmail")])
|
||||
(if (and (file-exists? p)
|
||||
(memq 'execute (file-or-directory-permissions p)))
|
||||
p
|
||||
(loop (cdr paths))))))
|
||||
(raise (make-exn:fail:unsupported
|
||||
"sendmail only available under Unix"
|
||||
(current-continuation-marks)))))
|
||||
|
||||
;; send-mail-message/port :
|
||||
;; string x string x list (string) x list (string) x list (string)
|
||||
;; [x list (string)] -> oport
|
||||
;; send-mail-message/port :
|
||||
;; string x string x list (string) x list (string) x list (string)
|
||||
;; [x list (string)] -> oport
|
||||
|
||||
;; -- sender can be anything, though spoofing is not recommended.
|
||||
;; The recipients must all be pure email addresses. Note that
|
||||
;; everything is expected to follow RFC conventions. If any other
|
||||
;; headers are specified, they are expected to be completely
|
||||
;; formatted already. Clients are urged to use close-output-port on
|
||||
;; the port returned by this procedure as soon as the necessary text
|
||||
;; has been written, so that the sendmail process can complete.
|
||||
;; -- sender can be anything, though spoofing is not recommended.
|
||||
;; The recipients must all be pure email addresses. Note that
|
||||
;; everything is expected to follow RFC conventions. If any other
|
||||
;; headers are specified, they are expected to be completely
|
||||
;; formatted already. Clients are urged to use close-output-port on
|
||||
;; the port returned by this procedure as soon as the necessary text
|
||||
;; has been written, so that the sendmail process can complete.
|
||||
|
||||
(define send-mail-message/port
|
||||
(lambda (sender subject to-recipients cc-recipients bcc-recipients
|
||||
. other-headers)
|
||||
(when (and (null? to-recipients) (null? cc-recipients)
|
||||
(null? bcc-recipients))
|
||||
(raise (make-no-mail-recipients
|
||||
"no mail recipients were specified"
|
||||
(current-continuation-marks))))
|
||||
(let ([return (apply process* sendmail-program-file "-i"
|
||||
(append to-recipients cc-recipients bcc-recipients))])
|
||||
(let ([reader (car return)]
|
||||
[writer (cadr return)]
|
||||
[pid (caddr return)]
|
||||
[error-reader (cadddr return)])
|
||||
(close-input-port reader)
|
||||
(close-input-port error-reader)
|
||||
(fprintf writer "From: ~a\n" sender)
|
||||
(letrec ([write-recipient-header
|
||||
(lambda (header-string recipients)
|
||||
(let ([header-space
|
||||
(+ (string-length header-string) 2)])
|
||||
(fprintf writer "~a: " header-string)
|
||||
(let loop ([to recipients] [indent header-space])
|
||||
(if (null? to)
|
||||
(newline writer)
|
||||
(let ([first (car to)]
|
||||
[rest (cdr to)])
|
||||
(let ([len (string-length first)])
|
||||
(if (>= (+ len indent) 80)
|
||||
(begin
|
||||
(fprintf writer
|
||||
(if (null? rest)
|
||||
"\n ~a"
|
||||
"\n ~a, ")
|
||||
first)
|
||||
(loop (cdr to)
|
||||
(+ len header-space 2)))
|
||||
(begin
|
||||
(fprintf writer
|
||||
(if (null? rest)
|
||||
"~a "
|
||||
"~a, ")
|
||||
first)
|
||||
(loop (cdr to)
|
||||
(+ len indent 2))))))))))])
|
||||
(write-recipient-header "To" to-recipients)
|
||||
(unless (null? cc-recipients)
|
||||
(write-recipient-header "CC" cc-recipients)))
|
||||
(fprintf writer "Subject: ~a\n" subject)
|
||||
(fprintf writer "X-Mailer: MzScheme: see www.plt-scheme.org\n")
|
||||
(for-each (lambda (s)
|
||||
(display s writer)
|
||||
(newline writer))
|
||||
other-headers)
|
||||
(newline writer)
|
||||
writer))))
|
||||
(define (send-mail-message/port
|
||||
sender subject to-recipients cc-recipients bcc-recipients
|
||||
. other-headers)
|
||||
(when (and (null? to-recipients) (null? cc-recipients)
|
||||
(null? bcc-recipients))
|
||||
(raise (make-no-mail-recipients
|
||||
"no mail recipients were specified"
|
||||
(current-continuation-marks))))
|
||||
(let ([return (apply process* sendmail-program-file "-i"
|
||||
(append to-recipients cc-recipients bcc-recipients))])
|
||||
(let ([reader (car return)]
|
||||
[writer (cadr return)]
|
||||
[pid (caddr return)]
|
||||
[error-reader (cadddr return)])
|
||||
(close-input-port reader)
|
||||
(close-input-port error-reader)
|
||||
(fprintf writer "From: ~a\n" sender)
|
||||
(letrec ([write-recipient-header
|
||||
(lambda (header-string recipients)
|
||||
(let ([header-space
|
||||
(+ (string-length header-string) 2)])
|
||||
(fprintf writer "~a: " header-string)
|
||||
(let loop ([to recipients] [indent header-space])
|
||||
(if (null? to)
|
||||
(newline writer)
|
||||
(let ([first (car to)]
|
||||
[rest (cdr to)])
|
||||
(let ([len (string-length first)])
|
||||
(if (>= (+ len indent) 80)
|
||||
(begin
|
||||
(fprintf writer
|
||||
(if (null? rest)
|
||||
"\n ~a"
|
||||
"\n ~a, ")
|
||||
first)
|
||||
(loop (cdr to)
|
||||
(+ len header-space 2)))
|
||||
(begin
|
||||
(fprintf writer
|
||||
(if (null? rest)
|
||||
"~a "
|
||||
"~a, ")
|
||||
first)
|
||||
(loop (cdr to)
|
||||
(+ len indent 2))))))))))])
|
||||
(write-recipient-header "To" to-recipients)
|
||||
(unless (null? cc-recipients)
|
||||
(write-recipient-header "CC" cc-recipients)))
|
||||
(fprintf writer "Subject: ~a\n" subject)
|
||||
(fprintf writer "X-Mailer: MzScheme: see www.plt-scheme.org\n")
|
||||
(for-each (lambda (s)
|
||||
(display s writer)
|
||||
(newline writer))
|
||||
other-headers)
|
||||
(newline writer)
|
||||
writer)))
|
||||
|
||||
;; send-mail-message :
|
||||
;; string x string x list (string) x list (string) x list (string) x
|
||||
;; list (string) [x list (string)] -> ()
|
||||
;; send-mail-message :
|
||||
;; string x string x list (string) x list (string) x list (string) x
|
||||
;; list (string) [x list (string)] -> ()
|
||||
|
||||
;; -- sender can be anything, though spoofing is not recommended. The
|
||||
;; recipients must all be pure email addresses. The text is expected
|
||||
;; to be pre-formatted. Note that everything is expected to follow
|
||||
;; RFC conventions. If any other headers are specified, they are
|
||||
;; expected to be completely formatted already.
|
||||
;; -- sender can be anything, though spoofing is not recommended. The
|
||||
;; recipients must all be pure email addresses. The text is expected
|
||||
;; to be pre-formatted. Note that everything is expected to follow
|
||||
;; RFC conventions. If any other headers are specified, they are
|
||||
;; expected to be completely formatted already.
|
||||
|
||||
(define send-mail-message
|
||||
(lambda (sender subject to-recipients cc-recipients bcc-recipients text
|
||||
. other-headers)
|
||||
(let ([writer (apply send-mail-message/port sender subject
|
||||
to-recipients cc-recipients bcc-recipients
|
||||
other-headers)])
|
||||
(for-each (lambda (s)
|
||||
(display s writer) ; We use -i, so "." is not a problem
|
||||
(newline writer))
|
||||
text)
|
||||
(close-output-port writer))))
|
||||
(define (send-mail-message
|
||||
sender subject to-recipients cc-recipients bcc-recipients text
|
||||
. other-headers)
|
||||
(let ([writer (apply send-mail-message/port sender subject
|
||||
to-recipients cc-recipients bcc-recipients
|
||||
other-headers)])
|
||||
(for-each (lambda (s)
|
||||
(display s writer) ; We use -i, so "." is not a problem
|
||||
(newline writer))
|
||||
text)
|
||||
(close-output-port writer)))
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
Loading…
Reference in New Issue
Block a user