reformatting
svn: r9853
This commit is contained in:
Eli Barzilay
parent
e62d2bf9ea
commit
0d41afdb6d
|
|
@ -1,4 +1,3 @@
|
||||||
|
|
||||||
#lang scheme/signature
|
#lang scheme/signature
|
||||||
|
|
||||||
base64-filename-safe
|
base64-filename-safe
|
||||||
|
|
|
||||||
|
|
@ -1,8 +1,6 @@
|
||||||
(module base64 mzscheme
|
#lang scheme/base
|
||||||
(require mzlib/unit
|
(require scheme/unit "base64-sig.ss" "base64-unit.ss")
|
||||||
"base64-sig.ss"
|
|
||||||
"base64-unit.ss")
|
|
||||||
|
|
||||||
(define-values/invoke-unit/infer base64@)
|
(define-values/invoke-unit/infer base64@)
|
||||||
|
|
||||||
(provide-signature-elements base64^))
|
(provide-signature-elements base64^)
|
||||||
|
|
|
||||||
|
|
@ -1,214 +1,210 @@
|
||||||
#lang scheme/unit
|
#lang scheme/unit
|
||||||
|
(require "cgi-sig.ss" "uri-codec.ss")
|
||||||
|
|
||||||
(require mzlib/etc
|
(import)
|
||||||
"cgi-sig.ss"
|
(export cgi^)
|
||||||
"uri-codec.ss")
|
|
||||||
|
|
||||||
(import)
|
;; type bindings = list ((symbol . string))
|
||||||
(export cgi^)
|
|
||||||
|
|
||||||
;; type bindings = list ((symbol . string))
|
;; --------------------------------------------------------------------
|
||||||
|
|
||||||
;; --------------------------------------------------------------------
|
;; Exceptions:
|
||||||
|
|
||||||
;; Exceptions:
|
(define-struct cgi-error ())
|
||||||
|
|
||||||
(define-struct cgi-error ())
|
;; chars : list (char)
|
||||||
|
;; -- gives the suffix which is invalid, not including the `%'
|
||||||
|
|
||||||
;; chars : list (char)
|
(define-struct (incomplete-%-suffix cgi-error) (chars))
|
||||||
;; -- gives the suffix which is invalid, not including the `%'
|
|
||||||
|
|
||||||
(define-struct (incomplete-%-suffix cgi-error) (chars))
|
;; char : char
|
||||||
|
;; -- an invalid character in a hex string
|
||||||
|
|
||||||
;; char : char
|
(define-struct (invalid-%-suffix cgi-error) (char))
|
||||||
;; -- an invalid character in a hex string
|
|
||||||
|
|
||||||
(define-struct (invalid-%-suffix cgi-error) (char))
|
;; --------------------------------------------------------------------
|
||||||
|
|
||||||
;; --------------------------------------------------------------------
|
;; query-chars->string : list (char) -> string
|
||||||
|
|
||||||
;; query-chars->string : list (char) -> string
|
;; -- The input is the characters post-processed as per Web specs, which
|
||||||
|
;; is as follows:
|
||||||
|
;; spaces are turned into "+"es and lots of things are turned into %XX, where
|
||||||
|
;; XX are hex digits, eg, %E7 for ~. The output is a regular Scheme string
|
||||||
|
;; with all the characters converted back.
|
||||||
|
|
||||||
;; -- The input is the characters post-processed as per Web specs, which
|
(define (query-chars->string chars)
|
||||||
;; is as follows:
|
(form-urlencoded-decode (list->string chars)))
|
||||||
;; spaces are turned into "+"es and lots of things are turned into %XX, where
|
|
||||||
;; XX are hex digits, eg, %E7 for ~. The output is a regular Scheme string
|
|
||||||
;; with all the characters converted back.
|
|
||||||
|
|
||||||
(define (query-chars->string chars)
|
;; string->html : string -> string
|
||||||
(form-urlencoded-decode (list->string chars)))
|
;; -- the input is raw text, the output is HTML appropriately quoted
|
||||||
|
|
||||||
;; string->html : string -> string
|
(define (string->html s)
|
||||||
;; -- the input is raw text, the output is HTML appropriately quoted
|
(apply string-append
|
||||||
|
(map (lambda (c)
|
||||||
|
(case c
|
||||||
|
[(#\<) "<"]
|
||||||
|
[(#\>) ">"]
|
||||||
|
[(#\&) "&"]
|
||||||
|
[else (string c)]))
|
||||||
|
(string->list s))))
|
||||||
|
|
||||||
(define (string->html s)
|
(define default-text-color "#000000")
|
||||||
(apply string-append
|
(define default-bg-color "#ffffff")
|
||||||
(map (lambda (c)
|
(define default-link-color "#cc2200")
|
||||||
(case c
|
(define default-vlink-color "#882200")
|
||||||
[(#\<) "<"]
|
(define default-alink-color "#444444")
|
||||||
[(#\>) ">"]
|
|
||||||
[(#\&) "&"]
|
|
||||||
[else (string c)]))
|
|
||||||
(string->list s))))
|
|
||||||
|
|
||||||
(define default-text-color "#000000")
|
;; generate-html-output :
|
||||||
(define default-bg-color "#ffffff")
|
;; html-string x list (html-string) x ... -> ()
|
||||||
(define default-link-color "#cc2200")
|
|
||||||
(define default-vlink-color "#882200")
|
|
||||||
(define default-alink-color "#444444")
|
|
||||||
|
|
||||||
;; generate-html-output :
|
(define (generate-html-output title body-lines
|
||||||
;; html-string x list (html-string) x ... -> ()
|
[text-color default-text-color]
|
||||||
|
[bg-color default-bg-color]
|
||||||
|
[link-color default-link-color]
|
||||||
|
[vlink-color default-vlink-color]
|
||||||
|
[alink-color default-alink-color])
|
||||||
|
(let ([sa string-append])
|
||||||
|
(for ([l `("Content-type: text/html"
|
||||||
|
""
|
||||||
|
"<html>"
|
||||||
|
"<!-- The form was processed, and this document was generated,"
|
||||||
|
" using the CGI utilities for MzScheme. For more information"
|
||||||
|
" on MzScheme, see"
|
||||||
|
" http://www.plt-scheme.org/software/mzscheme/"
|
||||||
|
" and for the CGI utilities, contact"
|
||||||
|
" (sk@cs.brown.edu). -->"
|
||||||
|
"<head>"
|
||||||
|
,(sa "<title>" title "</title>")
|
||||||
|
"</head>"
|
||||||
|
""
|
||||||
|
,(sa "<body bgcolor=\"" bg-color "\" text=\"" text-color "\"")
|
||||||
|
,(sa " link=\"" link-color "\"")
|
||||||
|
,(sa " vlink=\"" vlink-color "\" alink=\"" alink-color "\">")
|
||||||
|
""
|
||||||
|
,@body-lines
|
||||||
|
""
|
||||||
|
"</body>"
|
||||||
|
"</html>")])
|
||||||
|
(display l)
|
||||||
|
(newline))))
|
||||||
|
|
||||||
(define generate-html-output
|
;; output-http-headers : -> void
|
||||||
(opt-lambda (title body-lines
|
(define (output-http-headers)
|
||||||
[text-color default-text-color]
|
(printf "Content-type: text/html\r\n\r\n"))
|
||||||
[bg-color default-bg-color]
|
|
||||||
[link-color default-link-color]
|
|
||||||
[vlink-color default-vlink-color]
|
|
||||||
[alink-color default-alink-color])
|
|
||||||
(let ([sa string-append])
|
|
||||||
(for-each
|
|
||||||
(lambda (l) (display l) (newline))
|
|
||||||
`("Content-type: text/html"
|
|
||||||
""
|
|
||||||
"<html>"
|
|
||||||
"<!-- The form was processed, and this document was generated,"
|
|
||||||
" using the CGI utilities for MzScheme. For more information"
|
|
||||||
" on MzScheme, see"
|
|
||||||
" http://www.plt-scheme.org/software/mzscheme/"
|
|
||||||
" and for the CGI utilities, contact"
|
|
||||||
" (sk@cs.brown.edu). -->"
|
|
||||||
"<head>"
|
|
||||||
,(sa "<title>" title "</title>")
|
|
||||||
"</head>"
|
|
||||||
""
|
|
||||||
,(sa "<body bgcolor=\"" bg-color "\" text=\"" text-color "\"")
|
|
||||||
,(sa " link=\"" link-color "\"")
|
|
||||||
,(sa " vlink=\"" vlink-color "\" alink=\"" alink-color "\">")
|
|
||||||
""
|
|
||||||
,@body-lines
|
|
||||||
""
|
|
||||||
"</body>"
|
|
||||||
"</html>")))))
|
|
||||||
|
|
||||||
;; output-http-headers : -> void
|
;; read-until-char : iport x char -> list (char) x bool
|
||||||
(define (output-http-headers)
|
;; -- operates on the default input port; the second value indicates whether
|
||||||
(printf "Content-type: text/html\r\n\r\n"))
|
;; reading stopped because an EOF was hit (as opposed to the delimiter being
|
||||||
|
;; seen); the delimiter is not part of the result
|
||||||
|
(define (read-until-char ip delimiter)
|
||||||
|
(let loop ([chars '()])
|
||||||
|
(let ([c (read-char ip)])
|
||||||
|
(cond [(eof-object? c) (values (reverse chars) #t)]
|
||||||
|
[(char=? c delimiter) (values (reverse chars) #f)]
|
||||||
|
[else (loop (cons c chars))]))))
|
||||||
|
|
||||||
;; read-until-char : iport x char -> list (char) x bool
|
;; read-name+value : iport -> (symbol + bool) x (string + bool) x bool
|
||||||
;; -- operates on the default input port; the second value indicates whether
|
;; -- If the first value is false, so is the second, and the third is true,
|
||||||
;; reading stopped because an EOF was hit (as opposed to the delimiter being
|
;; indicating EOF was reached without any input seen. Otherwise, the first
|
||||||
;; seen); the delimiter is not part of the result
|
;; and second values contain strings and the third is either true or false
|
||||||
(define (read-until-char ip delimiter)
|
;; depending on whether the EOF has been reached. The strings are processed
|
||||||
(let loop ([chars '()])
|
;; to remove the CGI spec "escape"s. This code is _slightly_ lax: it allows
|
||||||
(let ([c (read-char ip)])
|
;; an input to end in `&'. It's not clear this is legal by the CGI spec,
|
||||||
(cond [(eof-object? c) (values (reverse chars) #t)]
|
;; which suggests that the last value binding must end in an EOF. It doesn't
|
||||||
[(char=? c delimiter) (values (reverse chars) #f)]
|
;; look like this matters. It would also introduce needless modality and
|
||||||
[else (loop (cons c chars))]))))
|
;; reduce flexibility.
|
||||||
|
(define (read-name+value ip)
|
||||||
|
(let-values ([(name eof?) (read-until-char ip #\=)])
|
||||||
|
(cond [(and eof? (null? name)) (values #f #f #t)]
|
||||||
|
[eof?
|
||||||
|
(generate-error-output
|
||||||
|
(list "Server generated malformed input for POST method:"
|
||||||
|
(string-append
|
||||||
|
"No binding for `" (list->string name) "' field.")))]
|
||||||
|
[else (let-values ([(value eof?) (read-until-char ip #\&)])
|
||||||
|
(values (string->symbol (query-chars->string name))
|
||||||
|
(query-chars->string value)
|
||||||
|
eof?))])))
|
||||||
|
|
||||||
;; read-name+value : iport -> (symbol + bool) x (string + bool) x bool
|
;; get-bindings/post : () -> bindings
|
||||||
;; -- If the first value is false, so is the second, and the third is true,
|
(define (get-bindings/post)
|
||||||
;; indicating EOF was reached without any input seen. Otherwise, the first
|
(let-values ([(name value eof?) (read-name+value (current-input-port))])
|
||||||
;; and second values contain strings and the third is either true or false
|
(cond [(and eof? (not name)) null]
|
||||||
;; depending on whether the EOF has been reached. The strings are processed
|
[(and eof? name) (list (cons name value))]
|
||||||
;; to remove the CGI spec "escape"s. This code is _slightly_ lax: it allows
|
[else (cons (cons name value) (get-bindings/post))])))
|
||||||
;; an input to end in `&'. It's not clear this is legal by the CGI spec,
|
|
||||||
;; which suggests that the last value binding must end in an EOF. It doesn't
|
|
||||||
;; look like this matters. It would also introduce needless modality and
|
|
||||||
;; reduce flexibility.
|
|
||||||
(define (read-name+value ip)
|
|
||||||
(let-values ([(name eof?) (read-until-char ip #\=)])
|
|
||||||
(cond [(and eof? (null? name)) (values #f #f #t)]
|
|
||||||
[eof?
|
|
||||||
(generate-error-output
|
|
||||||
(list "Server generated malformed input for POST method:"
|
|
||||||
(string-append
|
|
||||||
"No binding for `" (list->string name) "' field.")))]
|
|
||||||
[else (let-values ([(value eof?) (read-until-char ip #\&)])
|
|
||||||
(values (string->symbol (query-chars->string name))
|
|
||||||
(query-chars->string value)
|
|
||||||
eof?))])))
|
|
||||||
|
|
||||||
;; get-bindings/post : () -> bindings
|
;; get-bindings/get : () -> bindings
|
||||||
(define (get-bindings/post)
|
(define (get-bindings/get)
|
||||||
(let-values ([(name value eof?) (read-name+value (current-input-port))])
|
(let ([p (open-input-string (getenv "QUERY_STRING"))])
|
||||||
(cond [(and eof? (not name)) null]
|
(let loop ()
|
||||||
[(and eof? name) (list (cons name value))]
|
(let-values ([(name value eof?) (read-name+value p)])
|
||||||
[else (cons (cons name value) (get-bindings/post))])))
|
(cond [(and eof? (not name)) null]
|
||||||
|
[(and eof? name) (list (cons name value))]
|
||||||
|
[else (cons (cons name value) (loop))])))))
|
||||||
|
|
||||||
;; get-bindings/get : () -> bindings
|
;; get-bindings : () -> bindings
|
||||||
(define (get-bindings/get)
|
(define (get-bindings)
|
||||||
(let ([p (open-input-string (getenv "QUERY_STRING"))])
|
(if (string=? (get-cgi-method) "POST")
|
||||||
(let loop ()
|
(get-bindings/post)
|
||||||
(let-values ([(name value eof?) (read-name+value p)])
|
(get-bindings/get)))
|
||||||
(cond [(and eof? (not name)) null]
|
|
||||||
[(and eof? name) (list (cons name value))]
|
|
||||||
[else (cons (cons name value) (loop))])))))
|
|
||||||
|
|
||||||
;; get-bindings : () -> bindings
|
;; generate-error-output : list (html-string) -> <exit>
|
||||||
(define (get-bindings)
|
(define (generate-error-output error-message-lines)
|
||||||
(if (string=? (get-cgi-method) "POST")
|
(generate-html-output "Internal Error" error-message-lines)
|
||||||
(get-bindings/post)
|
(exit))
|
||||||
(get-bindings/get)))
|
|
||||||
|
|
||||||
;; generate-error-output : list (html-string) -> <exit>
|
;; bindings-as-html : bindings -> list (html-string)
|
||||||
(define (generate-error-output error-message-lines)
|
;; -- formats name-value bindings as HTML appropriate for displaying
|
||||||
(generate-html-output "Internal Error" error-message-lines)
|
(define (bindings-as-html bindings)
|
||||||
(exit))
|
`("<code>"
|
||||||
|
,@(map (lambda (bind)
|
||||||
|
(string-append (symbol->string (car bind))
|
||||||
|
" --> "
|
||||||
|
(cdr bind)
|
||||||
|
"<br>"))
|
||||||
|
bindings)
|
||||||
|
"</code>"))
|
||||||
|
|
||||||
;; bindings-as-html : bindings -> list (html-string)
|
;; extract-bindings : (string + symbol) x bindings -> list (string)
|
||||||
;; -- formats name-value bindings as HTML appropriate for displaying
|
;; -- Extracts the bindings associated with a given name. The semantics of
|
||||||
(define (bindings-as-html bindings)
|
;; forms states that a CHECKBOX may use the same NAME field multiple times.
|
||||||
`("<code>"
|
;; Hence, a list of strings is returned. Note that the result may be the
|
||||||
,@(map (lambda (bind)
|
;; empty list.
|
||||||
(string-append (symbol->string (car bind))
|
(define (extract-bindings field-name bindings)
|
||||||
" --> "
|
(let ([field-name (if (symbol? field-name)
|
||||||
(cdr bind)
|
field-name (string->symbol field-name))])
|
||||||
"<br>"))
|
(let loop ([found null] [bindings bindings])
|
||||||
bindings)
|
(if (null? bindings)
|
||||||
"</code>"))
|
found
|
||||||
|
(if (equal? field-name (caar bindings))
|
||||||
|
(loop (cons (cdar bindings) found) (cdr bindings))
|
||||||
|
(loop found (cdr bindings)))))))
|
||||||
|
|
||||||
;; extract-bindings : (string + symbol) x bindings -> list (string)
|
;; extract-binding/single : (string + symbol) x bindings -> string
|
||||||
;; -- Extracts the bindings associated with a given name. The semantics of
|
;; -- used in cases where only one binding is supposed to occur
|
||||||
;; forms states that a CHECKBOX may use the same NAME field multiple times.
|
(define (extract-binding/single field-name bindings)
|
||||||
;; Hence, a list of strings is returned. Note that the result may be the
|
(let* ([field-name (if (symbol? field-name)
|
||||||
;; empty list.
|
field-name (string->symbol field-name))]
|
||||||
(define (extract-bindings field-name bindings)
|
[result (extract-bindings field-name bindings)])
|
||||||
(let ([field-name (if (symbol? field-name)
|
(cond
|
||||||
field-name (string->symbol field-name))])
|
[(null? result)
|
||||||
(let loop ([found null] [bindings bindings])
|
(generate-error-output
|
||||||
(if (null? bindings)
|
(cons (format "No binding for field `~a':<br>" field-name)
|
||||||
found
|
(bindings-as-html bindings)))]
|
||||||
(if (equal? field-name (caar bindings))
|
[(null? (cdr result))
|
||||||
(loop (cons (cdar bindings) found) (cdr bindings))
|
(car result)]
|
||||||
(loop found (cdr bindings)))))))
|
[else
|
||||||
|
(generate-error-output
|
||||||
|
(cons (format "Multiple bindings for field `~a' where one expected:<br>"
|
||||||
|
field-name)
|
||||||
|
(bindings-as-html bindings)))])))
|
||||||
|
|
||||||
;; extract-binding/single : (string + symbol) x bindings -> string
|
;; get-cgi-method : () -> string
|
||||||
;; -- used in cases where only one binding is supposed to occur
|
;; -- string is either GET or POST (though future extension is possible)
|
||||||
(define (extract-binding/single field-name bindings)
|
(define (get-cgi-method)
|
||||||
(let* ([field-name (if (symbol? field-name)
|
(or (getenv "REQUEST_METHOD")
|
||||||
field-name (string->symbol field-name))]
|
(error 'get-cgi-method "no REQUEST_METHOD environment variable")))
|
||||||
[result (extract-bindings field-name bindings)])
|
|
||||||
(cond
|
|
||||||
[(null? result)
|
|
||||||
(generate-error-output
|
|
||||||
(cons (format "No binding for field `~a':<br>" field-name)
|
|
||||||
(bindings-as-html bindings)))]
|
|
||||||
[(null? (cdr result))
|
|
||||||
(car result)]
|
|
||||||
[else
|
|
||||||
(generate-error-output
|
|
||||||
(cons (format "Multiple bindings for field `~a' where one expected:<br>"
|
|
||||||
field-name)
|
|
||||||
(bindings-as-html bindings)))])))
|
|
||||||
|
|
||||||
;; get-cgi-method : () -> string
|
;; generate-link-text : string x html-string -> html-string
|
||||||
;; -- string is either GET or POST (though future extension is possible)
|
(define (generate-link-text url anchor-text)
|
||||||
(define (get-cgi-method)
|
(string-append "<a href=\"" url "\">" anchor-text "</a>"))
|
||||||
(or (getenv "REQUEST_METHOD")
|
|
||||||
(error 'get-cgi-method "no REQUEST_METHOD environment variable")))
|
|
||||||
|
|
||||||
;; generate-link-text : string x html-string -> html-string
|
|
||||||
(define (generate-link-text url anchor-text)
|
|
||||||
(string-append "<a href=\"" url "\">" anchor-text "</a>"))
|
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
(module cgi mzscheme
|
#lang scheme/base
|
||||||
(require mzlib/unit "cgi-sig.ss" "cgi-unit.ss")
|
(require scheme/unit "cgi-sig.ss" "cgi-unit.ss")
|
||||||
|
|
||||||
(define-values/invoke-unit/infer cgi@)
|
(define-values/invoke-unit/infer cgi@)
|
||||||
|
|
||||||
(provide-signature-elements cgi^))
|
(provide-signature-elements cgi^)
|
||||||
|
|
|
||||||
|
|
@ -50,279 +50,274 @@
|
||||||
|
|
||||||
#lang scheme/unit
|
#lang scheme/unit
|
||||||
|
|
||||||
(require mzlib/etc
|
(require srfi/13/string srfi/14/char-set "cookie-sig.ss")
|
||||||
mzlib/list
|
|
||||||
srfi/13/string
|
|
||||||
srfi/14/char-set
|
|
||||||
"cookie-sig.ss")
|
|
||||||
|
|
||||||
(import)
|
(import)
|
||||||
(export cookie^)
|
(export cookie^)
|
||||||
|
|
||||||
(define-struct cookie (name value comment domain max-age path secure version) #:mutable)
|
(define-struct cookie
|
||||||
(define-struct (cookie-error exn:fail) ())
|
(name value comment domain max-age path secure version) #:mutable)
|
||||||
|
(define-struct (cookie-error exn:fail) ())
|
||||||
|
|
||||||
;; error* : string args ... -> raises a cookie-error exception
|
;; error* : string args ... -> raises a cookie-error exception
|
||||||
;; constructs a cookie-error struct from the given error message
|
;; constructs a cookie-error struct from the given error message
|
||||||
;; (added to fix exceptions-must-take-immutable-strings bug)
|
;; (added to fix exceptions-must-take-immutable-strings bug)
|
||||||
(define (error* fmt . args)
|
(define (error* fmt . args)
|
||||||
(raise (make-cookie-error (apply format fmt args)
|
(raise (make-cookie-error (apply format fmt args)
|
||||||
(current-continuation-marks))))
|
(current-continuation-marks))))
|
||||||
|
|
||||||
;; The syntax for the Set-Cookie response header is
|
;; The syntax for the Set-Cookie response header is
|
||||||
;; set-cookie = "Set-Cookie:" cookies
|
;; set-cookie = "Set-Cookie:" cookies
|
||||||
;; cookies = 1#cookie
|
;; cookies = 1#cookie
|
||||||
;; cookie = NAME "=" VALUE *(";" cookie-av)
|
;; cookie = NAME "=" VALUE *(";" cookie-av)
|
||||||
;; NAME = attr
|
;; NAME = attr
|
||||||
;; VALUE = value
|
;; VALUE = value
|
||||||
;; cookie-av = "Comment" "=" value
|
;; cookie-av = "Comment" "=" value
|
||||||
;; | "Domain" "=" value
|
;; | "Domain" "=" value
|
||||||
;; | "Max-Age" "=" value
|
;; | "Max-Age" "=" value
|
||||||
;; | "Path" "=" value
|
;; | "Path" "=" value
|
||||||
;; | "Secure"
|
;; | "Secure"
|
||||||
;; | "Version" "=" 1*DIGIT
|
;; | "Version" "=" 1*DIGIT
|
||||||
(define (set-cookie name pre-value)
|
(define (set-cookie name pre-value)
|
||||||
(let ([value (to-rfc2109:value pre-value)])
|
(let ([value (to-rfc2109:value pre-value)])
|
||||||
(unless (rfc2068:token? name)
|
(unless (rfc2068:token? name)
|
||||||
(error* "invalid cookie name: ~a / ~a" name value))
|
(error* "invalid cookie name: ~a / ~a" name value))
|
||||||
(make-cookie name value
|
(make-cookie name value
|
||||||
#f ; comment
|
#f ; comment
|
||||||
#f ; current domain
|
#f ; current domain
|
||||||
#f ; at the end of session
|
#f ; at the end of session
|
||||||
#f ; current path
|
#f ; current path
|
||||||
#f ; normal (non SSL)
|
#f ; normal (non SSL)
|
||||||
#f ; default version
|
#f ; default version
|
||||||
)))
|
)))
|
||||||
|
|
||||||
;;!
|
;;!
|
||||||
;;
|
;;
|
||||||
;; (function (print-cookie cookie))
|
;; (function (print-cookie cookie))
|
||||||
;;
|
;;
|
||||||
;; (param cookie Cookie-structure "The cookie to return as a string")
|
;; (param cookie Cookie-structure "The cookie to return as a string")
|
||||||
;;
|
;;
|
||||||
;; Formats the cookie contents in a string ready to be appended to a
|
;; Formats the cookie contents in a string ready to be appended to a
|
||||||
;; "Set-Cookie: " header, and sent to a client (browser).
|
;; "Set-Cookie: " header, and sent to a client (browser).
|
||||||
(define (print-cookie cookie)
|
(define (print-cookie cookie)
|
||||||
|
(define (format-if fmt val) (and val (format fmt val)))
|
||||||
|
(unless (cookie? cookie) (error* "cookie expected, received: ~a" cookie))
|
||||||
|
(string-join
|
||||||
|
(filter values
|
||||||
|
(list (format "~a=~a" (cookie-name cookie) (cookie-value cookie))
|
||||||
|
(format-if "Comment=~a" (cookie-comment cookie))
|
||||||
|
(format-if "Domain=~a" (cookie-domain cookie))
|
||||||
|
(format-if "Max-Age=~a" (cookie-max-age cookie))
|
||||||
|
(format-if "Path=~a" (cookie-path cookie))
|
||||||
|
(and (cookie-secure cookie) "Secure")
|
||||||
|
(format "Version=~a" (or (cookie-version cookie) 1))))
|
||||||
|
"; "))
|
||||||
|
|
||||||
|
(define (cookie:add-comment cookie pre-comment)
|
||||||
|
(let ([comment (to-rfc2109:value pre-comment)])
|
||||||
(unless (cookie? cookie)
|
(unless (cookie? cookie)
|
||||||
(error* "cookie expected, received: ~a" cookie))
|
(error* "cookie expected, received: ~a" cookie))
|
||||||
(string-join
|
(set-cookie-comment! cookie comment)
|
||||||
(filter (lambda (s) (not (string-null? s)))
|
cookie))
|
||||||
(list (format "~a=~a" (cookie-name cookie) (cookie-value cookie))
|
|
||||||
(let ([c (cookie-comment cookie)]) (if c (format "Comment=~a" c) ""))
|
|
||||||
(let ([d (cookie-domain cookie)]) (if d (format "Domain=~a" d) ""))
|
|
||||||
(let ([age (cookie-max-age cookie)]) (if age (format "Max-Age=~a" age) ""))
|
|
||||||
(let ([p (cookie-path cookie)]) (if p (format "Path=~a" p) ""))
|
|
||||||
(let ([s (cookie-secure cookie)]) (if s "Secure" ""))
|
|
||||||
(let ([v (cookie-version cookie)]) (format "Version=~a" (if v v 1)))))
|
|
||||||
"; "))
|
|
||||||
|
|
||||||
(define (cookie:add-comment cookie pre-comment)
|
(define (cookie:add-domain cookie domain)
|
||||||
(let ([comment (to-rfc2109:value pre-comment)])
|
(unless (valid-domain? domain)
|
||||||
(unless (cookie? cookie)
|
(error* "invalid domain: ~a" domain))
|
||||||
(error* "cookie expected, received: ~a" cookie))
|
(unless (cookie? cookie)
|
||||||
(set-cookie-comment! cookie comment)
|
(error* "cookie expected, received: ~a" cookie))
|
||||||
cookie))
|
(set-cookie-domain! cookie domain)
|
||||||
|
cookie)
|
||||||
|
|
||||||
(define (cookie:add-domain cookie domain)
|
(define (cookie:add-max-age cookie seconds)
|
||||||
(unless (valid-domain? domain)
|
(unless (and (integer? seconds) (not (negative? seconds)))
|
||||||
(error* "invalid domain: ~a" domain))
|
(error* "invalid Max-Age for cookie: ~a" seconds))
|
||||||
|
(unless (cookie? cookie)
|
||||||
|
(error* "cookie expected, received: ~a" cookie))
|
||||||
|
(set-cookie-max-age! cookie seconds)
|
||||||
|
cookie)
|
||||||
|
|
||||||
|
(define (cookie:add-path cookie pre-path)
|
||||||
|
(let ([path (to-rfc2109:value pre-path)])
|
||||||
(unless (cookie? cookie)
|
(unless (cookie? cookie)
|
||||||
(error* "cookie expected, received: ~a" cookie))
|
(error* "cookie expected, received: ~a" cookie))
|
||||||
(set-cookie-domain! cookie domain)
|
(set-cookie-path! cookie path)
|
||||||
cookie)
|
cookie))
|
||||||
|
|
||||||
(define (cookie:add-max-age cookie seconds)
|
(define (cookie:secure cookie secure?)
|
||||||
(unless (and (integer? seconds) (not (negative? seconds)))
|
(unless (boolean? secure?)
|
||||||
(error* "invalid Max-Age for cookie: ~a" seconds))
|
(error* "invalid argument (boolean expected), received: ~a" secure?))
|
||||||
(unless (cookie? cookie)
|
(unless (cookie? cookie)
|
||||||
(error* "cookie expected, received: ~a" cookie))
|
(error* "cookie expected, received: ~a" cookie))
|
||||||
(set-cookie-max-age! cookie seconds)
|
(set-cookie-secure! cookie secure?)
|
||||||
cookie)
|
cookie)
|
||||||
|
|
||||||
(define (cookie:add-path cookie pre-path)
|
(define (cookie:version cookie version)
|
||||||
(let ([path (to-rfc2109:value pre-path)])
|
(unless (integer? version)
|
||||||
(unless (cookie? cookie)
|
(error* "unsupported version: ~a" version))
|
||||||
(error* "cookie expected, received: ~a" cookie))
|
(unless (cookie? cookie)
|
||||||
(set-cookie-path! cookie path)
|
(error* "cookie expected, received: ~a" cookie))
|
||||||
cookie))
|
(set-cookie-version! cookie version)
|
||||||
|
cookie)
|
||||||
(define (cookie:secure cookie secure?)
|
|
||||||
(unless (boolean? secure?)
|
|
||||||
(error* "invalid argument (boolean expected), received: ~a" secure?))
|
|
||||||
(unless (cookie? cookie)
|
|
||||||
(error* "cookie expected, received: ~a" cookie))
|
|
||||||
(set-cookie-secure! cookie secure?)
|
|
||||||
cookie)
|
|
||||||
|
|
||||||
(define (cookie:version cookie version)
|
|
||||||
(unless (integer? version)
|
|
||||||
(error* "unsupported version: ~a" version))
|
|
||||||
(unless (cookie? cookie)
|
|
||||||
(error* "cookie expected, received: ~a" cookie))
|
|
||||||
(set-cookie-version! cookie version)
|
|
||||||
cookie)
|
|
||||||
|
|
||||||
|
|
||||||
;; Parsing the Cookie header:
|
;; Parsing the Cookie header:
|
||||||
|
|
||||||
(define char-set:all-but=
|
(define char-set:all-but=
|
||||||
(char-set-difference char-set:full (string->char-set "=")))
|
(char-set-difference char-set:full (string->char-set "=")))
|
||||||
|
|
||||||
(define char-set:all-but-semicolon
|
(define char-set:all-but-semicolon
|
||||||
(char-set-difference char-set:full (string->char-set ";")))
|
(char-set-difference char-set:full (string->char-set ";")))
|
||||||
|
|
||||||
;;!
|
;;!
|
||||||
;;
|
;;
|
||||||
;; (function (get-all-results name cookies))
|
;; (function (get-all-results name cookies))
|
||||||
;;
|
;;
|
||||||
;; Auxiliar procedure that returns all values associated with
|
;; Auxiliar procedure that returns all values associated with
|
||||||
;; `name' in the association list (cookies).
|
;; `name' in the association list (cookies).
|
||||||
(define (get-all-results name cookies)
|
(define (get-all-results name cookies)
|
||||||
(let loop ([c cookies])
|
(let loop ([c cookies])
|
||||||
(if (null? c)
|
(if (null? c)
|
||||||
'()
|
'()
|
||||||
(let ([pair (car c)])
|
(let ([pair (car c)])
|
||||||
(if (string=? name (car pair))
|
(if (string=? name (car pair))
|
||||||
;; found an instance of cookie named `name'
|
;; found an instance of cookie named `name'
|
||||||
(cons (cadr pair) (loop (cdr c)))
|
(cons (cadr pair) (loop (cdr c)))
|
||||||
(loop (cdr c)))))))
|
(loop (cdr c)))))))
|
||||||
|
|
||||||
;; which typically looks like:
|
;; which typically looks like:
|
||||||
;; (cookie . "test5=\"5\"; test1=\"1\"; test0=\"0\"; test1=\"20\"")
|
;; (cookie . "test5=\"5\"; test1=\"1\"; test0=\"0\"; test1=\"20\"")
|
||||||
;; note that it can be multi-valued: `test1' has values: "1", and "20". Of
|
;; note that it can be multi-valued: `test1' has values: "1", and "20". Of
|
||||||
;; course, in the same spirit, we only receive the "string content".
|
;; course, in the same spirit, we only receive the "string content".
|
||||||
(define (get-cookie name cookies)
|
(define (get-cookie name cookies)
|
||||||
(let ([cookies (map (lambda (p)
|
(let ([cookies (map (lambda (p)
|
||||||
(map string-trim-both
|
(map string-trim-both
|
||||||
(string-tokenize p char-set:all-but=)))
|
(string-tokenize p char-set:all-but=)))
|
||||||
(string-tokenize cookies char-set:all-but-semicolon))])
|
(string-tokenize cookies char-set:all-but-semicolon))])
|
||||||
(get-all-results name cookies)))
|
(get-all-results name cookies)))
|
||||||
|
|
||||||
;;!
|
;;!
|
||||||
;;
|
;;
|
||||||
;; (function (get-cookie/single name cookies))
|
;; (function (get-cookie/single name cookies))
|
||||||
;;
|
;;
|
||||||
;; (param name String "The name of the cookie we are looking for")
|
;; (param name String "The name of the cookie we are looking for")
|
||||||
;; (param cookies String "The string (from the environment) with the content of the cookie header.")
|
;; (param cookies String "The string (from the environment) with the content of the cookie header.")
|
||||||
;;
|
;;
|
||||||
;; Returns the first name associated with the cookie named `name', if any, or #f.
|
;; Returns the first name associated with the cookie named `name', if any, or #f.
|
||||||
(define (get-cookie/single name cookies)
|
(define (get-cookie/single name cookies)
|
||||||
(let ([cookies (get-cookie name cookies)])
|
(let ([cookies (get-cookie name cookies)])
|
||||||
(and (not (null? cookies)) (car cookies))))
|
(and (not (null? cookies)) (car cookies))))
|
||||||
|
|
||||||
|
|
||||||
;;;;;
|
;;;;;
|
||||||
;; Auxiliary procedures
|
;; Auxiliary procedures
|
||||||
;;;;;
|
;;;;;
|
||||||
|
|
||||||
;; token = 1*<any CHAR except CTLs or tspecials>
|
;; token = 1*<any CHAR except CTLs or tspecials>
|
||||||
;;
|
;;
|
||||||
;; tspecials = "(" | ")" | "<" | ">" | "@"
|
;; tspecials = "(" | ")" | "<" | ">" | "@"
|
||||||
;; | "," | ";" | ":" | "\" | <">
|
;; | "," | ";" | ":" | "\" | <">
|
||||||
;; | "/" | "[" | "]" | "?" | "="
|
;; | "/" | "[" | "]" | "?" | "="
|
||||||
;; | "{" | "}" | SP | HT
|
;; | "{" | "}" | SP | HT
|
||||||
(define char-set:tspecials
|
(define char-set:tspecials
|
||||||
(char-set-union (string->char-set "()<>@,;:\\\"/[]?={}")
|
(char-set-union (string->char-set "()<>@,;:\\\"/[]?={}")
|
||||||
char-set:whitespace
|
char-set:whitespace
|
||||||
(char-set #\tab)))
|
(char-set #\tab)))
|
||||||
|
|
||||||
(define char-set:control
|
(define char-set:control
|
||||||
(char-set-union char-set:iso-control
|
(char-set-union char-set:iso-control
|
||||||
(char-set (integer->char 127))));; DEL
|
(char-set (integer->char 127))));; DEL
|
||||||
(define char-set:token
|
(define char-set:token
|
||||||
(char-set-difference char-set:ascii char-set:tspecials char-set:control))
|
(char-set-difference char-set:ascii char-set:tspecials char-set:control))
|
||||||
|
|
||||||
;; token? : string -> boolean
|
;; token? : string -> boolean
|
||||||
;;
|
;;
|
||||||
;; returns #t if s is an RFC 2068 token (see definition above), #f otherwise.
|
;; returns #t if s is an RFC 2068 token (see definition above), #f otherwise.
|
||||||
(define (rfc2068:token? s)
|
(define (rfc2068:token? s)
|
||||||
(string-every char-set:token s))
|
(string-every char-set:token s))
|
||||||
|
|
||||||
;;!
|
;;!
|
||||||
;;
|
;;
|
||||||
;; (function (quoted-string? s))
|
;; (function (quoted-string? s))
|
||||||
;;
|
;;
|
||||||
;; (param s String "The string to check")
|
;; (param s String "The string to check")
|
||||||
;;
|
;;
|
||||||
;; Returns s if the string is an RFC 2068 quoted-string, #f otherwise. As in:
|
;; Returns s if the string is an RFC 2068 quoted-string, #f otherwise. As in:
|
||||||
;; quoted-string = ( <"> *(qdtext) <"> )
|
;; quoted-string = ( <"> *(qdtext) <"> )
|
||||||
;; qdtext = <any TEXT except <">>
|
;; qdtext = <any TEXT except <">>
|
||||||
;;
|
;;
|
||||||
;; The backslash character ("\") may be used as a single-character quoting
|
;; The backslash character ("\") may be used as a single-character quoting
|
||||||
;; mechanism only within quoted-string and comment constructs.
|
;; mechanism only within quoted-string and comment constructs.
|
||||||
;;
|
;;
|
||||||
;; quoted-pair = "\" CHAR
|
;; quoted-pair = "\" CHAR
|
||||||
;;
|
;;
|
||||||
;; implementation note: I have chosen to use a regular expression rather than
|
;; implementation note: I have chosen to use a regular expression rather than
|
||||||
;; a character set for this definition because of two dependencies: CRLF must
|
;; a character set for this definition because of two dependencies: CRLF must
|
||||||
;; appear as a block to be legal, and " may only appear as \"
|
;; appear as a block to be legal, and " may only appear as \"
|
||||||
(define (rfc2068:quoted-string? s)
|
(define (rfc2068:quoted-string? s)
|
||||||
(if (regexp-match
|
(and (regexp-match?
|
||||||
#rx"^\"([^\"#\u0000-#\u001F]| |#\return#\newline|#\tab|\\\\\")*\"$"
|
#rx"^\"([^\"#\u0000-#\u001F]| |#\return#\newline|#\tab|\\\\\")*\"$"
|
||||||
s)
|
s)
|
||||||
s
|
s))
|
||||||
#f))
|
|
||||||
|
|
||||||
;; value: token | quoted-string
|
;; value: token | quoted-string
|
||||||
(define (rfc2109:value? s)
|
(define (rfc2109:value? s)
|
||||||
(or (rfc2068:token? s) (rfc2068:quoted-string? s)))
|
(or (rfc2068:token? s) (rfc2068:quoted-string? s)))
|
||||||
|
|
||||||
;; convert-to-quoted : string -> quoted-string?
|
;; convert-to-quoted : string -> quoted-string?
|
||||||
;; takes the given string as a particular message, and converts the given
|
;; takes the given string as a particular message, and converts the given
|
||||||
;; string to that representatation
|
;; string to that representatation
|
||||||
(define (convert-to-quoted str)
|
(define (convert-to-quoted str)
|
||||||
(string-append "\"" (regexp-replace* #rx"\"" str "\\\\\"") "\""))
|
(string-append "\"" (regexp-replace* #rx"\"" str "\\\\\"") "\""))
|
||||||
|
|
||||||
;; string -> rfc2109:value?
|
;; string -> rfc2109:value?
|
||||||
(define (to-rfc2109:value s)
|
(define (to-rfc2109:value s)
|
||||||
(cond
|
(cond
|
||||||
[(not (string? s))
|
[(not (string? s))
|
||||||
(error* "expected string, given: ~e" s)]
|
(error* "expected string, given: ~e" s)]
|
||||||
|
|
||||||
;; for backwards compatibility, just use the given string if it will work
|
;; for backwards compatibility, just use the given string if it will work
|
||||||
[(rfc2068:token? s) s]
|
[(rfc2068:token? s) s]
|
||||||
[(rfc2068:quoted-string? s) s]
|
[(rfc2068:quoted-string? s) s]
|
||||||
|
|
||||||
;; ... but if it doesn't work (i.e., it's just a normal message) then try
|
;; ... but if it doesn't work (i.e., it's just a normal message) then try
|
||||||
;; to convert it into a representation that will work
|
;; to convert it into a representation that will work
|
||||||
[(rfc2068:quoted-string? (convert-to-quoted s))
|
[(rfc2068:quoted-string? (convert-to-quoted s))
|
||||||
=> (λ (x) x)]
|
=> (λ (x) x)]
|
||||||
[else
|
[else
|
||||||
(error* "could not convert the given string to an acceptable RFC 2109 value: ~s" s)]))
|
(error* "could not convert the given string to an acceptable RFC 2109 value: ~s" s)]))
|
||||||
|
|
||||||
;;!
|
;;!
|
||||||
;;
|
;;
|
||||||
;; (function (cookie-string? s))
|
;; (function (cookie-string? s))
|
||||||
;;
|
;;
|
||||||
;; (param s String "String to check")
|
;; (param s String "String to check")
|
||||||
;;
|
;;
|
||||||
;; Returns whether this is a valid string to use as the value or the
|
;; Returns whether this is a valid string to use as the value or the
|
||||||
;; name (depending on value?) of an HTTP cookie.
|
;; name (depending on value?) of an HTTP cookie.
|
||||||
(define cookie-string?
|
(define (cookie-string? s [value? #t])
|
||||||
(opt-lambda (s (value? #t))
|
(unless (string? s)
|
||||||
(unless (string? s)
|
(error* "string expected, received: ~a" s))
|
||||||
(error* "string expected, received: ~a" s))
|
(if value?
|
||||||
(if value?
|
(rfc2109:value? s)
|
||||||
(rfc2109:value? s)
|
;; name: token
|
||||||
;; name: token
|
(rfc2068:token? s)))
|
||||||
(rfc2068:token? s))))
|
|
||||||
|
|
||||||
;; Host names as per RFC 1123 and RFC952, more or less, anyway. :-)
|
;; Host names as per RFC 1123 and RFC952, more or less, anyway. :-)
|
||||||
(define char-set:hostname
|
(define char-set:hostname
|
||||||
(let ([a-z-lowercase (ucs-range->char-set #x61 #x7B)]
|
(let ([a-z-lowercase (ucs-range->char-set #x61 #x7B)]
|
||||||
[a-z-uppercase (ucs-range->char-set #x41 #x5B)])
|
[a-z-uppercase (ucs-range->char-set #x41 #x5B)])
|
||||||
(char-set-adjoin!
|
(char-set-adjoin!
|
||||||
(char-set-union char-set:digit a-z-lowercase a-z-uppercase)
|
(char-set-union char-set:digit a-z-lowercase a-z-uppercase)
|
||||||
#\.)))
|
#\.)))
|
||||||
|
|
||||||
(define (valid-domain? dom)
|
(define (valid-domain? dom)
|
||||||
(and ;; Domain must start with a dot (.)
|
(and ;; Domain must start with a dot (.)
|
||||||
(string=? (string-take dom 1) ".")
|
(string=? (string-take dom 1) ".")
|
||||||
;; The rest are tokens-like strings separated by dots
|
;; The rest are tokens-like strings separated by dots
|
||||||
(string-every char-set:hostname dom)
|
(string-every char-set:hostname dom)
|
||||||
(<= (string-length dom) 76)))
|
(<= (string-length dom) 76)))
|
||||||
|
|
||||||
(define (valid-path? v)
|
(define (valid-path? v)
|
||||||
(and (string? v) (rfc2109:value? v)))
|
(and (string? v) (rfc2109:value? v)))
|
||||||
|
|
||||||
;;; cookie-unit.ss ends here
|
;;; cookie-unit.ss ends here
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
(module cookie mzscheme
|
#lang scheme/base
|
||||||
(require mzlib/unit "cookie-sig.ss" "cookie-unit.ss")
|
(require scheme/unit "cookie-sig.ss" "cookie-unit.ss")
|
||||||
|
|
||||||
(provide-signature-elements cookie^)
|
(provide-signature-elements cookie^)
|
||||||
|
|
||||||
(define-values/invoke-unit/infer cookie@))
|
(define-values/invoke-unit/infer cookie@)
|
||||||
|
|
|
||||||
|
|
@ -1,345 +1,338 @@
|
||||||
#lang scheme/unit
|
#lang scheme/unit
|
||||||
|
|
||||||
(require mzlib/list mzlib/process "dns-sig.ss"
|
(require "dns-sig.ss" scheme/system scheme/udp)
|
||||||
scheme/udp)
|
|
||||||
|
|
||||||
(import)
|
(import)
|
||||||
(export dns^)
|
(export dns^)
|
||||||
|
|
||||||
;; UDP retry timeout:
|
;; UDP retry timeout:
|
||||||
(define INIT-TIMEOUT 50)
|
(define INIT-TIMEOUT 50)
|
||||||
|
|
||||||
(define types
|
(define types
|
||||||
'((a 1)
|
'((a 1)
|
||||||
(ns 2)
|
(ns 2)
|
||||||
(md 3)
|
(md 3)
|
||||||
(mf 4)
|
(mf 4)
|
||||||
(cname 5)
|
(cname 5)
|
||||||
(soa 6)
|
(soa 6)
|
||||||
(mb 7)
|
(mb 7)
|
||||||
(mg 8)
|
(mg 8)
|
||||||
(mr 9)
|
(mr 9)
|
||||||
(null 10)
|
(null 10)
|
||||||
(wks 11)
|
(wks 11)
|
||||||
(ptr 12)
|
(ptr 12)
|
||||||
(hinfo 13)
|
(hinfo 13)
|
||||||
(minfo 14)
|
(minfo 14)
|
||||||
(mx 15)
|
(mx 15)
|
||||||
(txt 16)))
|
(txt 16)))
|
||||||
|
|
||||||
(define classes
|
(define classes
|
||||||
'((in 1)
|
'((in 1)
|
||||||
(cs 2)
|
(cs 2)
|
||||||
(ch 3)
|
(ch 3)
|
||||||
(hs 4)))
|
(hs 4)))
|
||||||
|
|
||||||
(define (cossa i l)
|
(define (cossa i l)
|
||||||
(cond [(null? l) #f]
|
(cond [(null? l) #f]
|
||||||
[(equal? (cadar l) i) (car l)]
|
[(equal? (cadar l) i) (car l)]
|
||||||
[else (cossa i (cdr l))]))
|
[else (cossa i (cdr l))]))
|
||||||
|
|
||||||
(define (number->octet-pair n)
|
(define (number->octet-pair n)
|
||||||
(list (arithmetic-shift n -8)
|
(list (arithmetic-shift n -8)
|
||||||
(modulo n 256)))
|
(modulo n 256)))
|
||||||
|
|
||||||
(define (octet-pair->number a b)
|
(define (octet-pair->number a b)
|
||||||
(+ (arithmetic-shift a 8) b))
|
(+ (arithmetic-shift a 8) b))
|
||||||
|
|
||||||
(define (octet-quad->number a b c d)
|
(define (octet-quad->number a b c d)
|
||||||
(+ (arithmetic-shift a 24)
|
(+ (arithmetic-shift a 24)
|
||||||
(arithmetic-shift b 16)
|
(arithmetic-shift b 16)
|
||||||
(arithmetic-shift c 8)
|
(arithmetic-shift c 8)
|
||||||
d))
|
d))
|
||||||
|
|
||||||
(define (name->octets s)
|
(define (name->octets s)
|
||||||
(let ([do-one (lambda (s)
|
(let ([do-one (lambda (s) (cons (bytes-length s) (bytes->list s)))])
|
||||||
(cons (bytes-length s) (bytes->list s)))])
|
(let loop ([s s])
|
||||||
(let loop ([s s])
|
(let ([m (regexp-match #rx#"^([^.]*)[.](.*)" s)])
|
||||||
(let ([m (regexp-match #rx#"^([^.]*)[.](.*)" s)])
|
(if m
|
||||||
(if m
|
(append (do-one (cadr m)) (loop (caddr m)))
|
||||||
(append (do-one (cadr m)) (loop (caddr m)))
|
(append (do-one s) (list 0)))))))
|
||||||
(append (do-one s) (list 0)))))))
|
|
||||||
|
|
||||||
(define (make-std-query-header id question-count)
|
(define (make-std-query-header id question-count)
|
||||||
(append (number->octet-pair id)
|
(append (number->octet-pair id)
|
||||||
(list 1 0) ; Opcode & flags (recusive flag set)
|
(list 1 0) ; Opcode & flags (recusive flag set)
|
||||||
(number->octet-pair question-count)
|
(number->octet-pair question-count)
|
||||||
(number->octet-pair 0)
|
(number->octet-pair 0)
|
||||||
(number->octet-pair 0)
|
(number->octet-pair 0)
|
||||||
(number->octet-pair 0)))
|
(number->octet-pair 0)))
|
||||||
|
|
||||||
(define (make-query id name type class)
|
(define (make-query id name type class)
|
||||||
(append (make-std-query-header id 1)
|
(append (make-std-query-header id 1)
|
||||||
(name->octets name)
|
(name->octets name)
|
||||||
(number->octet-pair (cadr (assoc type types)))
|
(number->octet-pair (cadr (assoc type types)))
|
||||||
(number->octet-pair (cadr (assoc class classes)))))
|
(number->octet-pair (cadr (assoc class classes)))))
|
||||||
|
|
||||||
(define (add-size-tag m)
|
(define (add-size-tag m)
|
||||||
(append (number->octet-pair (length m)) m))
|
(append (number->octet-pair (length m)) m))
|
||||||
|
|
||||||
(define (rr-data rr)
|
(define (rr-data rr)
|
||||||
(cadddr (cdr rr)))
|
(cadddr (cdr rr)))
|
||||||
|
|
||||||
(define (rr-type rr)
|
(define (rr-type rr)
|
||||||
(cadr rr))
|
(cadr rr))
|
||||||
|
|
||||||
(define (rr-name rr)
|
(define (rr-name rr)
|
||||||
(car rr))
|
(car rr))
|
||||||
|
|
||||||
(define (parse-name start reply)
|
(define (parse-name start reply)
|
||||||
(let ([v (car start)])
|
(let ([v (car start)])
|
||||||
(cond
|
(cond
|
||||||
[(zero? v)
|
[(zero? v)
|
||||||
;; End of name
|
;; End of name
|
||||||
(values #f (cdr start))]
|
(values #f (cdr start))]
|
||||||
[(zero? (bitwise-and #xc0 v))
|
[(zero? (bitwise-and #xc0 v))
|
||||||
;; Normal label
|
;; Normal label
|
||||||
(let loop ([len v][start (cdr start)][accum null])
|
(let loop ([len v][start (cdr start)][accum null])
|
||||||
(cond
|
(if (zero? len)
|
||||||
[(zero? len)
|
(let-values ([(s start) (parse-name start reply)])
|
||||||
(let-values ([(s start) (parse-name start reply)])
|
(let ([s0 (list->bytes (reverse accum))])
|
||||||
(let ([s0 (list->bytes (reverse accum))])
|
(values (if s (bytes-append s0 #"." s) s0)
|
||||||
(values (if s (bytes-append s0 #"." s) s0)
|
start)))
|
||||||
start)))]
|
(loop (sub1 len) (cdr start) (cons (car start) accum))))]
|
||||||
[else (loop (sub1 len) (cdr start) (cons (car start) accum))]))]
|
[else
|
||||||
[else
|
;; Compression offset
|
||||||
;; Compression offset
|
(let ([offset (+ (arithmetic-shift (bitwise-and #x3f v) 8)
|
||||||
(let ([offset (+ (arithmetic-shift (bitwise-and #x3f v) 8)
|
(cadr start))])
|
||||||
(cadr start))])
|
(let-values ([(s ignore-start)
|
||||||
(let-values ([(s ignore-start)
|
(parse-name (list-tail reply offset) reply)])
|
||||||
(parse-name (list-tail reply offset) reply)])
|
(values s (cddr start))))])))
|
||||||
(values s (cddr start))))])))
|
|
||||||
|
|
||||||
(define (parse-rr start reply)
|
(define (parse-rr start reply)
|
||||||
(let-values ([(name start) (parse-name start reply)])
|
(let-values ([(name start) (parse-name start reply)])
|
||||||
(let* ([type (car (cossa (octet-pair->number (car start) (cadr start))
|
(let* ([type (car (cossa (octet-pair->number (car start) (cadr start))
|
||||||
types))]
|
types))]
|
||||||
[start (cddr start)]
|
[start (cddr start)]
|
||||||
;;
|
;;
|
||||||
[class (car (cossa (octet-pair->number (car start) (cadr start))
|
[class (car (cossa (octet-pair->number (car start) (cadr start))
|
||||||
classes))]
|
classes))]
|
||||||
[start (cddr start)]
|
[start (cddr start)]
|
||||||
;;
|
;;
|
||||||
[ttl (octet-quad->number (car start) (cadr start)
|
[ttl (octet-quad->number (car start) (cadr start)
|
||||||
(caddr start) (cadddr start))]
|
(caddr start) (cadddr start))]
|
||||||
[start (cddddr start)]
|
[start (cddddr start)]
|
||||||
;;
|
;;
|
||||||
[len (octet-pair->number (car start) (cadr start))]
|
[len (octet-pair->number (car start) (cadr start))]
|
||||||
[start (cddr start)])
|
[start (cddr start)])
|
||||||
;; Extract next len bytes for data:
|
;; Extract next len bytes for data:
|
||||||
(let loop ([len len] [start start] [accum null])
|
(let loop ([len len] [start start] [accum null])
|
||||||
(if (zero? len)
|
(if (zero? len)
|
||||||
(values (list name type class ttl (reverse accum))
|
(values (list name type class ttl (reverse accum))
|
||||||
start)
|
start)
|
||||||
(loop (sub1 len) (cdr start) (cons (car start) accum)))))))
|
(loop (sub1 len) (cdr start) (cons (car start) accum)))))))
|
||||||
|
|
||||||
(define (parse-ques start reply)
|
(define (parse-ques start reply)
|
||||||
(let-values ([(name start) (parse-name start reply)])
|
(let-values ([(name start) (parse-name start reply)])
|
||||||
(let* ([type (car (cossa (octet-pair->number (car start) (cadr start))
|
(let* ([type (car (cossa (octet-pair->number (car start) (cadr start))
|
||||||
types))]
|
types))]
|
||||||
[start (cddr start)]
|
[start (cddr start)]
|
||||||
;;
|
;;
|
||||||
[class (car (cossa (octet-pair->number (car start) (cadr start))
|
[class (car (cossa (octet-pair->number (car start) (cadr start))
|
||||||
classes))]
|
classes))]
|
||||||
[start (cddr start)])
|
[start (cddr start)])
|
||||||
(values (list name type class) start))))
|
(values (list name type class) start))))
|
||||||
|
|
||||||
(define (parse-n parse start reply n)
|
(define (parse-n parse start reply n)
|
||||||
(let loop ([n n][start start][accum null])
|
(let loop ([n n][start start][accum null])
|
||||||
(if (zero? n)
|
(if (zero? n)
|
||||||
(values (reverse accum) start)
|
(values (reverse accum) start)
|
||||||
(let-values ([(rr start) (parse start reply)])
|
(let-values ([(rr start) (parse start reply)])
|
||||||
(loop (sub1 n) start (cons rr accum))))))
|
(loop (sub1 n) start (cons rr accum))))))
|
||||||
|
|
||||||
(define (dns-query nameserver addr type class)
|
(define (dns-query nameserver addr type class)
|
||||||
(unless (assoc type types)
|
(unless (assoc type types)
|
||||||
(raise-type-error 'dns-query "DNS query type" type))
|
(raise-type-error 'dns-query "DNS query type" type))
|
||||||
(unless (assoc class classes)
|
(unless (assoc class classes)
|
||||||
(raise-type-error 'dns-query "DNS query class" class))
|
(raise-type-error 'dns-query "DNS query class" class))
|
||||||
|
|
||||||
(let* ([query (make-query (random 256) (string->bytes/latin-1 addr)
|
(let* ([query (make-query (random 256) (string->bytes/latin-1 addr)
|
||||||
type class)]
|
type class)]
|
||||||
[udp (udp-open-socket)]
|
[udp (udp-open-socket)]
|
||||||
[reply
|
[reply
|
||||||
(dynamic-wind
|
(dynamic-wind
|
||||||
void
|
void
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(let ([s (make-bytes 512)])
|
(let ([s (make-bytes 512)])
|
||||||
(let retry ([timeout INIT-TIMEOUT])
|
(let retry ([timeout INIT-TIMEOUT])
|
||||||
(udp-send-to udp nameserver 53 (list->bytes query))
|
(udp-send-to udp nameserver 53 (list->bytes query))
|
||||||
(sync (handle-evt
|
(sync (handle-evt (udp-receive!-evt udp s)
|
||||||
(udp-receive!-evt udp s)
|
(lambda (r)
|
||||||
(lambda (r)
|
(bytes->list (subbytes s 0 (car r)))))
|
||||||
(bytes->list (subbytes s 0 (car r)))))
|
(handle-evt (alarm-evt (+ (current-inexact-milliseconds)
|
||||||
(handle-evt
|
timeout))
|
||||||
(alarm-evt (+ (current-inexact-milliseconds)
|
(lambda (v)
|
||||||
timeout))
|
(retry (* timeout 2))))))))
|
||||||
(lambda (v)
|
(lambda () (udp-close udp)))])
|
||||||
(retry (* timeout 2))))))))
|
|
||||||
(lambda () (udp-close udp)))])
|
|
||||||
|
|
||||||
;; First two bytes must match sent message id:
|
;; First two bytes must match sent message id:
|
||||||
(unless (and (= (car reply) (car query))
|
(unless (and (= (car reply) (car query))
|
||||||
(= (cadr reply) (cadr query)))
|
(= (cadr reply) (cadr query)))
|
||||||
(error 'dns-query "bad reply id from server"))
|
(error 'dns-query "bad reply id from server"))
|
||||||
|
|
||||||
(let ([v0 (caddr reply)]
|
(let ([v0 (caddr reply)]
|
||||||
[v1 (cadddr reply)])
|
[v1 (cadddr reply)])
|
||||||
;; Check for error code:
|
;; Check for error code:
|
||||||
(let ([rcode (bitwise-and #xf v1)])
|
(let ([rcode (bitwise-and #xf v1)])
|
||||||
(unless (zero? rcode)
|
(unless (zero? rcode)
|
||||||
(error 'dns-query "error from server: ~a"
|
(error 'dns-query "error from server: ~a"
|
||||||
(case rcode
|
(case rcode
|
||||||
[(1) "format error"]
|
[(1) "format error"]
|
||||||
[(2) "server failure"]
|
[(2) "server failure"]
|
||||||
[(3) "name error"]
|
[(3) "name error"]
|
||||||
[(4) "not implemented"]
|
[(4) "not implemented"]
|
||||||
[(5) "refused"]))))
|
[(5) "refused"]))))
|
||||||
|
|
||||||
(let ([qd-count (octet-pair->number (list-ref reply 4) (list-ref reply 5))]
|
(let ([qd-count (octet-pair->number (list-ref reply 4) (list-ref reply 5))]
|
||||||
[an-count (octet-pair->number (list-ref reply 6) (list-ref reply 7))]
|
[an-count (octet-pair->number (list-ref reply 6) (list-ref reply 7))]
|
||||||
[ns-count (octet-pair->number (list-ref reply 8) (list-ref reply 9))]
|
[ns-count (octet-pair->number (list-ref reply 8) (list-ref reply 9))]
|
||||||
[ar-count (octet-pair->number (list-ref reply 10) (list-ref reply 11))])
|
[ar-count (octet-pair->number (list-ref reply 10) (list-ref reply 11))])
|
||||||
|
|
||||||
(let ([start (list-tail reply 12)])
|
(let ([start (list-tail reply 12)])
|
||||||
(let*-values ([(qds start) (parse-n parse-ques start reply qd-count)]
|
(let*-values ([(qds start) (parse-n parse-ques start reply qd-count)]
|
||||||
[(ans start) (parse-n parse-rr start reply an-count)]
|
[(ans start) (parse-n parse-rr start reply an-count)]
|
||||||
[(nss start) (parse-n parse-rr start reply ns-count)]
|
[(nss start) (parse-n parse-rr start reply ns-count)]
|
||||||
[(ars start) (parse-n parse-rr start reply ar-count)])
|
[(ars start) (parse-n parse-rr start reply ar-count)])
|
||||||
(unless (null? start)
|
(unless (null? start)
|
||||||
(error 'dns-query "error parsing server reply"))
|
(error 'dns-query "error parsing server reply"))
|
||||||
(values (positive? (bitwise-and #x4 v0))
|
(values (positive? (bitwise-and #x4 v0))
|
||||||
qds ans nss ars reply)))))))
|
qds ans nss ars reply)))))))
|
||||||
|
|
||||||
(define cache (make-hasheq))
|
(define cache (make-hasheq))
|
||||||
(define (dns-query/cache nameserver addr type class)
|
(define (dns-query/cache nameserver addr type class)
|
||||||
(let ([key (string->symbol (format "~a;~a;~a;~a" nameserver addr type class))])
|
(let ([key (string->symbol (format "~a;~a;~a;~a" nameserver addr type class))])
|
||||||
(let ([v (hash-ref cache key (lambda () #f))])
|
(let ([v (hash-ref cache key (lambda () #f))])
|
||||||
(if v
|
(if v
|
||||||
(apply values v)
|
(apply values v)
|
||||||
(let-values ([(auth? qds ans nss ars reply) (dns-query nameserver addr type class)])
|
(let-values ([(auth? qds ans nss ars reply)
|
||||||
(hash-set! cache key (list auth? qds ans nss ars reply))
|
(dns-query nameserver addr type class)])
|
||||||
(values auth? qds ans nss ars reply))))))
|
(hash-set! cache key (list auth? qds ans nss ars reply))
|
||||||
|
(values auth? qds ans nss ars reply))))))
|
||||||
|
|
||||||
(define (ip->string s)
|
(define (ip->string s)
|
||||||
(format "~a.~a.~a.~a"
|
(format "~a.~a.~a.~a"
|
||||||
(list-ref s 0) (list-ref s 1) (list-ref s 2) (list-ref s 3)))
|
(list-ref s 0) (list-ref s 1) (list-ref s 2) (list-ref s 3)))
|
||||||
|
|
||||||
(define (try-forwarding k nameserver)
|
(define (try-forwarding k nameserver)
|
||||||
(let loop ([nameserver nameserver][tried (list nameserver)])
|
(let loop ([nameserver nameserver][tried (list nameserver)])
|
||||||
;; Normally the recusion is done for us, but it's technically optional
|
;; Normally the recusion is done for us, but it's technically optional
|
||||||
(let-values ([(v ars auth?) (k nameserver)])
|
(let-values ([(v ars auth?) (k nameserver)])
|
||||||
(or v
|
(or v
|
||||||
(and (not auth?)
|
(and (not auth?)
|
||||||
(let* ([ns (ormap (lambda (ar)
|
(let* ([ns (ormap (lambda (ar)
|
||||||
(and (eq? (rr-type ar) 'a)
|
(and (eq? (rr-type ar) 'a)
|
||||||
(ip->string (rr-data ar))))
|
(ip->string (rr-data ar))))
|
||||||
ars)])
|
ars)])
|
||||||
(and ns
|
(and ns
|
||||||
(not (member ns tried))
|
(not (member ns tried))
|
||||||
(loop ns (cons ns tried)))))))))
|
(loop ns (cons ns tried)))))))))
|
||||||
|
|
||||||
(define (ip->in-addr.arpa ip)
|
(define (ip->in-addr.arpa ip)
|
||||||
(let ([result (regexp-match #rx"^([0-9]+)\\.([0-9]+)\\.([0-9]+)\\.([0-9]+)$"
|
(let ([result (regexp-match #rx"^([0-9]+)\\.([0-9]+)\\.([0-9]+)\\.([0-9]+)$"
|
||||||
ip)])
|
ip)])
|
||||||
(format "~a.~a.~a.~a.in-addr.arpa"
|
(format "~a.~a.~a.~a.in-addr.arpa"
|
||||||
(list-ref result 4)
|
(list-ref result 4)
|
||||||
(list-ref result 3)
|
(list-ref result 3)
|
||||||
(list-ref result 2)
|
(list-ref result 2)
|
||||||
(list-ref result 1))))
|
(list-ref result 1))))
|
||||||
|
|
||||||
(define (get-ptr-list-from-ans ans)
|
(define (get-ptr-list-from-ans ans)
|
||||||
(filter (lambda (ans-entry) (eq? (list-ref ans-entry 1) 'ptr))
|
(filter (lambda (ans-entry) (eq? (list-ref ans-entry 1) 'ptr)) ans))
|
||||||
ans))
|
|
||||||
|
|
||||||
(define (dns-get-name nameserver ip)
|
(define (dns-get-name nameserver ip)
|
||||||
(or (try-forwarding
|
(or (try-forwarding
|
||||||
(lambda (nameserver)
|
(lambda (nameserver)
|
||||||
(let-values ([(auth? qds ans nss ars reply)
|
(let-values ([(auth? qds ans nss ars reply)
|
||||||
(dns-query/cache nameserver (ip->in-addr.arpa ip) 'ptr 'in)])
|
(dns-query/cache nameserver (ip->in-addr.arpa ip) 'ptr 'in)])
|
||||||
(values (and (positive? (length (get-ptr-list-from-ans ans)))
|
(values (and (positive? (length (get-ptr-list-from-ans ans)))
|
||||||
(let ([s (rr-data (car (get-ptr-list-from-ans ans)))])
|
(let ([s (rr-data (car (get-ptr-list-from-ans ans)))])
|
||||||
(let-values ([(name null) (parse-name s reply)])
|
(let-values ([(name null) (parse-name s reply)])
|
||||||
(bytes->string/latin-1 name))))
|
(bytes->string/latin-1 name))))
|
||||||
ars auth?)))
|
ars auth?)))
|
||||||
nameserver)
|
nameserver)
|
||||||
(error 'dns-get-name "bad ip address")))
|
(error 'dns-get-name "bad ip address")))
|
||||||
|
|
||||||
(define (get-a-list-from-ans ans)
|
(define (get-a-list-from-ans ans)
|
||||||
(filter (lambda (ans-entry) (eq? (list-ref ans-entry 1) 'a))
|
(filter (lambda (ans-entry) (eq? (list-ref ans-entry 1) 'a))
|
||||||
ans))
|
ans))
|
||||||
|
|
||||||
(define (dns-get-address nameserver addr)
|
(define (dns-get-address nameserver addr)
|
||||||
(or (try-forwarding
|
(or (try-forwarding
|
||||||
(lambda (nameserver)
|
(lambda (nameserver)
|
||||||
(let-values ([(auth? qds ans nss ars reply) (dns-query/cache nameserver addr 'a 'in)])
|
(let-values ([(auth? qds ans nss ars reply) (dns-query/cache nameserver addr 'a 'in)])
|
||||||
(values (and (positive? (length (get-a-list-from-ans ans)))
|
(values (and (positive? (length (get-a-list-from-ans ans)))
|
||||||
(let ([s (rr-data (car (get-a-list-from-ans ans)))])
|
(let ([s (rr-data (car (get-a-list-from-ans ans)))])
|
||||||
(ip->string s)))
|
(ip->string s)))
|
||||||
ars auth?)))
|
ars auth?)))
|
||||||
nameserver)
|
nameserver)
|
||||||
(error 'dns-get-address "bad address")))
|
(error 'dns-get-address "bad address")))
|
||||||
|
|
||||||
(define (dns-get-mail-exchanger nameserver addr)
|
(define (dns-get-mail-exchanger nameserver addr)
|
||||||
(or (try-forwarding
|
(or (try-forwarding
|
||||||
(lambda (nameserver)
|
(lambda (nameserver)
|
||||||
(let-values ([(auth? qds ans nss ars reply) (dns-query/cache nameserver addr 'mx 'in)])
|
(let-values ([(auth? qds ans nss ars reply) (dns-query/cache nameserver addr 'mx 'in)])
|
||||||
(values (let loop ([ans ans][best-pref +inf.0][exchanger #f])
|
(values (let loop ([ans ans][best-pref +inf.0][exchanger #f])
|
||||||
(cond
|
(cond
|
||||||
[(null? ans)
|
[(null? ans)
|
||||||
(or exchanger
|
(or exchanger
|
||||||
;; Does 'soa mean that the input address is fine?
|
;; Does 'soa mean that the input address is fine?
|
||||||
(and (ormap (lambda (ns) (eq? (rr-type ns) 'soa))
|
(and (ormap (lambda (ns) (eq? (rr-type ns) 'soa))
|
||||||
nss)
|
nss)
|
||||||
addr))]
|
addr))]
|
||||||
[else
|
[else
|
||||||
(let ([d (rr-data (car ans))])
|
(let ([d (rr-data (car ans))])
|
||||||
(let ([pref (octet-pair->number (car d) (cadr d))])
|
(let ([pref (octet-pair->number (car d) (cadr d))])
|
||||||
(if (< pref best-pref)
|
(if (< pref best-pref)
|
||||||
(let-values ([(name start) (parse-name (cddr d) reply)])
|
(let-values ([(name start) (parse-name (cddr d) reply)])
|
||||||
(loop (cdr ans) pref name))
|
(loop (cdr ans) pref name))
|
||||||
(loop (cdr ans) best-pref exchanger))))]))
|
(loop (cdr ans) best-pref exchanger))))]))
|
||||||
ars auth?)))
|
ars auth?)))
|
||||||
nameserver)
|
nameserver)
|
||||||
(error 'dns-get-mail-exchanger "bad address")))
|
(error 'dns-get-mail-exchanger "bad address")))
|
||||||
|
|
||||||
(define (dns-find-nameserver)
|
(define (dns-find-nameserver)
|
||||||
(case (system-type)
|
(case (system-type)
|
||||||
[(unix macosx)
|
[(unix macosx)
|
||||||
(with-handlers ([void (lambda (x) #f)])
|
(with-handlers ([void (lambda (x) #f)])
|
||||||
(with-input-from-file "/etc/resolv.conf"
|
(with-input-from-file "/etc/resolv.conf"
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(let loop ()
|
(let loop ()
|
||||||
(let ([l (read-line)])
|
(let ([l (read-line)])
|
||||||
(or (and (string? l)
|
(or (and (string? l)
|
||||||
(let ([m (regexp-match
|
(let ([m (regexp-match
|
||||||
#rx"nameserver[ \t]+([0-9]+[.][0-9]+[.][0-9]+[.][0-9]+)"
|
#rx"nameserver[ \t]+([0-9]+[.][0-9]+[.][0-9]+[.][0-9]+)"
|
||||||
l)])
|
l)])
|
||||||
(and m (cadr m))))
|
(and m (cadr m))))
|
||||||
(and (not (eof-object? l))
|
(and (not (eof-object? l))
|
||||||
(loop))))))))]
|
(loop))))))))]
|
||||||
[(windows)
|
[(windows)
|
||||||
(let ([nslookup (find-executable-path "nslookup.exe" #f)])
|
(let ([nslookup (find-executable-path "nslookup.exe" #f)])
|
||||||
(and nslookup
|
(and nslookup
|
||||||
(let-values ([(pin pout pid perr proc)
|
(let-values ([(pin pout pid perr proc)
|
||||||
(apply
|
(apply
|
||||||
values
|
values
|
||||||
(process/ports
|
(process/ports
|
||||||
#f (open-input-file "NUL") (current-error-port)
|
#f (open-input-file "NUL") (current-error-port)
|
||||||
nslookup))])
|
nslookup))])
|
||||||
(let loop ([name #f][ip #f][try-ip? #f])
|
(let loop ([name #f] [ip #f] [try-ip? #f])
|
||||||
(let ([line (read-line pin 'any)])
|
(let ([line (read-line pin 'any)])
|
||||||
(cond [(eof-object? line)
|
(cond [(eof-object? line)
|
||||||
(close-input-port pin)
|
(close-input-port pin)
|
||||||
(proc 'wait)
|
(proc 'wait)
|
||||||
(or ip name)]
|
(or ip name)]
|
||||||
[(and (not name)
|
[(and (not name)
|
||||||
(regexp-match #rx"^Default Server: +(.*)$"
|
(regexp-match #rx"^Default Server: +(.*)$" line))
|
||||||
line))
|
=> (lambda (m) (loop (cadr m) #f #t))]
|
||||||
=> (lambda (m) (loop (cadr m) #f #t))]
|
[(and try-ip?
|
||||||
[(and try-ip?
|
(regexp-match #rx"^Address: +(.*)$" line))
|
||||||
(regexp-match #rx"^Address: +(.*)$"
|
=> (lambda (m) (loop name (cadr m) #f))]
|
||||||
line))
|
[else (loop name ip #f)]))))))]
|
||||||
=> (lambda (m) (loop name (cadr m) #f))]
|
[else #f]))
|
||||||
[else (loop name ip #f)]))))))]
|
|
||||||
[else #f]))
|
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
(module dns mzscheme
|
#lang scheme/base
|
||||||
(require mzlib/unit "dns-sig.ss" "dns-unit.ss")
|
(require scheme/unit "dns-sig.ss" "dns-unit.ss")
|
||||||
|
|
||||||
(define-values/invoke-unit/infer dns@)
|
(define-values/invoke-unit/infer dns@)
|
||||||
|
|
||||||
(provide-signature-elements dns^))
|
(provide-signature-elements dns^)
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
(module ftp mzscheme
|
#lang scheme/base
|
||||||
(require mzlib/unit "ftp-sig.ss" "ftp-unit.ss")
|
(require scheme/unit "ftp-sig.ss" "ftp-unit.ss")
|
||||||
|
|
||||||
(define-values/invoke-unit/infer ftp@)
|
(define-values/invoke-unit/infer ftp@)
|
||||||
|
|
||||||
(provide-signature-elements ftp^))
|
(provide-signature-elements ftp^)
|
||||||
|
|
|
||||||
|
|
@ -1,349 +1,345 @@
|
||||||
#lang scheme/unit
|
#lang scheme/unit
|
||||||
|
|
||||||
(require mzlib/date mzlib/string "head-sig.ss")
|
(require mzlib/date mzlib/string "head-sig.ss")
|
||||||
|
|
||||||
(import)
|
(import)
|
||||||
(export head^)
|
(export head^)
|
||||||
|
|
||||||
;; NB: I've done a copied-code adaptation of a number of these definitions
|
;; NB: I've done a copied-code adaptation of a number of these definitions
|
||||||
;; into "bytes-compatible" versions. Finishing the rest will require some
|
;; into "bytes-compatible" versions. Finishing the rest will require some
|
||||||
;; kind of interface decision---that is, when you don't supply a header,
|
;; kind of interface decision---that is, when you don't supply a header,
|
||||||
;; should the resulting operation be string-centric or bytes-centric?
|
;; should the resulting operation be string-centric or bytes-centric?
|
||||||
;; Easiest just to stop here.
|
;; Easiest just to stop here.
|
||||||
;; -- JBC 2006-07-31
|
;; -- JBC 2006-07-31
|
||||||
|
|
||||||
(define CRLF (string #\return #\newline))
|
(define CRLF (string #\return #\newline))
|
||||||
(define CRLF/bytes #"\r\n")
|
(define CRLF/bytes #"\r\n")
|
||||||
|
|
||||||
(define empty-header CRLF)
|
(define empty-header CRLF)
|
||||||
(define empty-header/bytes CRLF/bytes)
|
(define empty-header/bytes CRLF/bytes)
|
||||||
|
|
||||||
(define re:field-start (regexp "^[^ \t\n\r\v:\001-\032\"]*:"))
|
(define re:field-start (regexp "^[^ \t\n\r\v:\001-\032\"]*:"))
|
||||||
(define re:field-start/bytes #rx#"^[^ \t\n\r\v:\001-\032\"]*:")
|
(define re:field-start/bytes #rx#"^[^ \t\n\r\v:\001-\032\"]*:")
|
||||||
|
|
||||||
(define re:continue (regexp "^[ \t\v]"))
|
(define re:continue (regexp "^[ \t\v]"))
|
||||||
(define re:continue/bytes #rx#"^[ \t\v]")
|
(define re:continue/bytes #rx#"^[ \t\v]")
|
||||||
|
|
||||||
(define (validate-header s)
|
(define (validate-header s)
|
||||||
(if (bytes? s)
|
(if (bytes? s)
|
||||||
;; legal char check not needed per rfc 2822, IIUC.
|
;; legal char check not needed per rfc 2822, IIUC.
|
||||||
(let ([len (bytes-length s)])
|
(let ([len (bytes-length s)])
|
||||||
|
(let loop ([offset 0])
|
||||||
|
(cond
|
||||||
|
[(and (= (+ offset 2) len)
|
||||||
|
(bytes=? CRLF/bytes (subbytes s offset len)))
|
||||||
|
(void)] ; validated
|
||||||
|
[(= offset len) (error 'validate-header/bytes "missing ending CRLF")]
|
||||||
|
[(or (regexp-match re:field-start/bytes s offset)
|
||||||
|
(regexp-match re:continue/bytes s offset))
|
||||||
|
(let ([m (regexp-match-positions #rx#"\r\n" s offset)])
|
||||||
|
(if m
|
||||||
|
(loop (cdar m))
|
||||||
|
(error 'validate-header/bytes "missing ending CRLF")))]
|
||||||
|
[else (error 'validate-header/bytes "ill-formed header at ~s"
|
||||||
|
(subbytes s offset (string-length s)))])))
|
||||||
|
;; otherwise it should be a string:
|
||||||
|
(begin
|
||||||
|
(let ([m (regexp-match #rx"[^\000-\377]" s)])
|
||||||
|
(when m
|
||||||
|
(error 'validate-header "non-Latin-1 character in string: ~v" (car m))))
|
||||||
|
(let ([len (string-length s)])
|
||||||
(let loop ([offset 0])
|
(let loop ([offset 0])
|
||||||
(cond
|
(cond
|
||||||
[(and (= (+ offset 2) len)
|
[(and (= (+ offset 2) len)
|
||||||
(bytes=? CRLF/bytes (subbytes s offset len)))
|
(string=? CRLF (substring s offset len)))
|
||||||
(void)] ; validated
|
(void)] ; validated
|
||||||
[(= offset len) (error 'validate-header/bytes "missing ending CRLF")]
|
[(= offset len) (error 'validate-header "missing ending CRLF")]
|
||||||
[(or (regexp-match re:field-start/bytes s offset)
|
[(or (regexp-match re:field-start s offset)
|
||||||
(regexp-match re:continue/bytes s offset))
|
(regexp-match re:continue s offset))
|
||||||
(let ([m (regexp-match-positions #rx#"\r\n" s offset)])
|
(let ([m (regexp-match-positions #rx"\r\n" s offset)])
|
||||||
(if m
|
(if m
|
||||||
(loop (cdar m))
|
(loop (cdar m))
|
||||||
(error 'validate-header/bytes "missing ending CRLF")))]
|
(error 'validate-header "missing ending CRLF")))]
|
||||||
[else (error 'validate-header/bytes "ill-formed header at ~s"
|
[else (error 'validate-header "ill-formed header at ~s"
|
||||||
(subbytes s offset (string-length s)))])))
|
(substring s offset (string-length s)))]))))))
|
||||||
;; otherwise it should be a string:
|
|
||||||
(begin
|
|
||||||
(let ([m (regexp-match #rx"[^\000-\377]" s)])
|
|
||||||
(when m
|
|
||||||
(error 'validate-header "non-Latin-1 character in string: ~v" (car m))))
|
|
||||||
(let ([len (string-length s)])
|
|
||||||
(let loop ([offset 0])
|
|
||||||
(cond
|
|
||||||
[(and (= (+ offset 2) len)
|
|
||||||
(string=? CRLF (substring s offset len)))
|
|
||||||
(void)] ; validated
|
|
||||||
[(= offset len) (error 'validate-header "missing ending CRLF")]
|
|
||||||
[(or (regexp-match re:field-start s offset)
|
|
||||||
(regexp-match re:continue s offset))
|
|
||||||
(let ([m (regexp-match-positions #rx"\r\n" s offset)])
|
|
||||||
(if m
|
|
||||||
(loop (cdar m))
|
|
||||||
(error 'validate-header "missing ending CRLF")))]
|
|
||||||
[else (error 'validate-header "ill-formed header at ~s"
|
|
||||||
(substring s offset (string-length s)))]))))))
|
|
||||||
|
|
||||||
(define (make-field-start-regexp field)
|
(define (make-field-start-regexp field)
|
||||||
(regexp (format "(^|[\r][\n])(~a: *)" (regexp-quote field #f))))
|
(regexp (format "(^|[\r][\n])(~a: *)" (regexp-quote field #f))))
|
||||||
|
|
||||||
(define (make-field-start-regexp/bytes field)
|
(define (make-field-start-regexp/bytes field)
|
||||||
(byte-regexp (bytes-append #"(^|[\r][\n])("(regexp-quote field #f) #": *)")))
|
(byte-regexp (bytes-append #"(^|[\r][\n])("(regexp-quote field #f) #": *)")))
|
||||||
|
|
||||||
(define (extract-field field header)
|
(define (extract-field field header)
|
||||||
(if (bytes? header)
|
(if (bytes? header)
|
||||||
(let ([m (regexp-match-positions (make-field-start-regexp/bytes field)
|
(let ([m (regexp-match-positions (make-field-start-regexp/bytes field)
|
||||||
header)])
|
header)])
|
||||||
(and m
|
(and m
|
||||||
(let ([s (subbytes header
|
(let ([s (subbytes header
|
||||||
(cdaddr m)
|
(cdaddr m)
|
||||||
(bytes-length header))])
|
(bytes-length header))])
|
||||||
(let ([m (regexp-match-positions #rx#"[\r][\n][^: \r\n\"]*:" s)])
|
(let ([m (regexp-match-positions #rx#"[\r][\n][^: \r\n\"]*:" s)])
|
||||||
(if m
|
(if m
|
||||||
(subbytes s 0 (caar m))
|
(subbytes s 0 (caar m))
|
||||||
;; Rest of header is this field, but strip trailing CRLFCRLF:
|
;; Rest of header is this field, but strip trailing CRLFCRLF:
|
||||||
(regexp-replace #rx#"\r\n\r\n$" s ""))))))
|
(regexp-replace #rx#"\r\n\r\n$" s ""))))))
|
||||||
;; otherwise header & field should be strings:
|
;; otherwise header & field should be strings:
|
||||||
(let ([m (regexp-match-positions (make-field-start-regexp field)
|
(let ([m (regexp-match-positions (make-field-start-regexp field)
|
||||||
header)])
|
header)])
|
||||||
(and m
|
(and m
|
||||||
(let ([s (substring header
|
(let ([s (substring header
|
||||||
(cdaddr m)
|
(cdaddr m)
|
||||||
(string-length header))])
|
(string-length header))])
|
||||||
(let ([m (regexp-match-positions #rx"[\r][\n][^: \r\n\"]*:" s)])
|
(let ([m (regexp-match-positions #rx"[\r][\n][^: \r\n\"]*:" s)])
|
||||||
(if m
|
(if m
|
||||||
(substring s 0 (caar m))
|
(substring s 0 (caar m))
|
||||||
;; Rest of header is this field, but strip trailing CRLFCRLF:
|
;; Rest of header is this field, but strip trailing CRLFCRLF:
|
||||||
(regexp-replace #rx"\r\n\r\n$" s ""))))))))
|
(regexp-replace #rx"\r\n\r\n$" s ""))))))))
|
||||||
|
|
||||||
|
(define (replace-field field data header)
|
||||||
|
(if (bytes? header)
|
||||||
|
(let ([m (regexp-match-positions (make-field-start-regexp/bytes field)
|
||||||
|
header)])
|
||||||
|
(if m
|
||||||
|
(let* ([pre (subbytes header 0 (caaddr m))]
|
||||||
|
[s (subbytes header (cdaddr m))]
|
||||||
|
[m (regexp-match-positions #rx#"[\r][\n][^: \r\n\"]*:" s)]
|
||||||
|
[rest (if m (subbytes s (+ 2 (caar m))) empty-header/bytes)])
|
||||||
|
(bytes-append pre (if data (insert-field field data rest) rest)))
|
||||||
|
(if data (insert-field field data header) header)))
|
||||||
|
;; otherwise header & field & data should be strings:
|
||||||
|
(let ([m (regexp-match-positions (make-field-start-regexp field) header)])
|
||||||
|
(if m
|
||||||
|
(let* ([pre (substring header 0 (caaddr m))]
|
||||||
|
[s (substring header (cdaddr m))]
|
||||||
|
[m (regexp-match-positions #rx"[\r][\n][^: \r\n\"]*:" s)]
|
||||||
|
[rest (if m (substring s (+ 2 (caar m))) empty-header)])
|
||||||
|
(string-append pre (if data (insert-field field data rest) rest)))
|
||||||
|
(if data (insert-field field data header) header)))))
|
||||||
|
|
||||||
(define (replace-field field data header)
|
(define (remove-field field header)
|
||||||
(if (bytes? header)
|
(replace-field field #f header))
|
||||||
(let ([m (regexp-match-positions (make-field-start-regexp/bytes field)
|
|
||||||
header)])
|
|
||||||
(if m
|
|
||||||
(let* ([pre (subbytes header 0 (caaddr m))]
|
|
||||||
[s (subbytes header (cdaddr m))]
|
|
||||||
[m (regexp-match-positions #rx#"[\r][\n][^: \r\n\"]*:" s)]
|
|
||||||
[rest (if m (subbytes s (+ 2 (caar m))) empty-header/bytes)])
|
|
||||||
(bytes-append pre (if data (insert-field field data rest) rest)))
|
|
||||||
(if data (insert-field field data header) header)))
|
|
||||||
;; otherwise header & field & data should be strings:
|
|
||||||
(let ([m (regexp-match-positions (make-field-start-regexp field)
|
|
||||||
header)])
|
|
||||||
(if m
|
|
||||||
(let* ([pre (substring header 0 (caaddr m))]
|
|
||||||
[s (substring header (cdaddr m))]
|
|
||||||
[m (regexp-match-positions #rx"[\r][\n][^: \r\n\"]*:" s)]
|
|
||||||
[rest (if m (substring s (+ 2 (caar m))) empty-header)])
|
|
||||||
(string-append pre (if data (insert-field field data rest) rest)))
|
|
||||||
(if data (insert-field field data header) header)))))
|
|
||||||
|
|
||||||
(define (remove-field field header)
|
(define (insert-field field data header)
|
||||||
(replace-field field #f header))
|
(if (bytes? header)
|
||||||
|
(let ([field (bytes-append field #": "data #"\r\n")])
|
||||||
|
(bytes-append field header))
|
||||||
|
;; otherwise field, data, & header should be strings:
|
||||||
|
(let ([field (format "~a: ~a\r\n" field data)])
|
||||||
|
(string-append field header))))
|
||||||
|
|
||||||
(define (insert-field field data header)
|
(define (append-headers a b)
|
||||||
(if (bytes? header)
|
(if (bytes? a)
|
||||||
(let ([field (bytes-append field #": "data #"\r\n")])
|
(let ([alen (bytes-length a)])
|
||||||
(bytes-append field header))
|
(if (> alen 1)
|
||||||
;; otherwise field, data, & header should be strings:
|
(bytes-append (subbytes a 0 (- alen 2)) b)
|
||||||
(let ([field (format "~a: ~a\r\n" field data)])
|
(error 'append-headers "first argument is not a header: ~a" a)))
|
||||||
(string-append field header))))
|
;; otherwise, a & b should be strings:
|
||||||
|
(let ([alen (string-length a)])
|
||||||
|
(if (> alen 1)
|
||||||
|
(string-append (substring a 0 (- alen 2)) b)
|
||||||
|
(error 'append-headers "first argument is not a header: ~a" a)))))
|
||||||
|
|
||||||
(define (append-headers a b)
|
(define (extract-all-fields header)
|
||||||
(if (bytes? a)
|
(if (bytes? header)
|
||||||
(let ([alen (bytes-length a)])
|
(let ([re #rx#"(^|[\r][\n])(([^\r\n:\"]*): *)"])
|
||||||
(if (> alen 1)
|
(let loop ([start 0])
|
||||||
(bytes-append (subbytes a 0 (- alen 2)) b)
|
(let ([m (regexp-match-positions re header start)])
|
||||||
(error 'append-headers "first argument is not a header: ~a" a)))
|
(if m
|
||||||
;; otherwise, a & b should be strings:
|
(let ([start (cdaddr m)]
|
||||||
(let ([alen (string-length a)])
|
[field-name (subbytes header (caaddr (cdr m))
|
||||||
(if (> alen 1)
|
(cdaddr (cdr m)))])
|
||||||
(string-append (substring a 0 (- alen 2)) b)
|
(let ([m2 (regexp-match-positions
|
||||||
(error 'append-headers "first argument is not a header: ~a" a)))))
|
#rx#"\r\n[^: \r\n\"]*:"
|
||||||
|
header
|
||||||
|
start)])
|
||||||
|
(if m2
|
||||||
|
(cons (cons field-name
|
||||||
|
(subbytes header start (caar m2)))
|
||||||
|
(loop (caar m2)))
|
||||||
|
;; Rest of header is this field, but strip trailing CRLFCRLF:
|
||||||
|
(list
|
||||||
|
(cons field-name
|
||||||
|
(regexp-replace #rx#"\r\n\r\n$"
|
||||||
|
(subbytes header start (bytes-length header))
|
||||||
|
""))))))
|
||||||
|
;; malformed header:
|
||||||
|
null))))
|
||||||
|
;; otherwise, header should be a string:
|
||||||
|
(let ([re #rx"(^|[\r][\n])(([^\r\n:\"]*): *)"])
|
||||||
|
(let loop ([start 0])
|
||||||
|
(let ([m (regexp-match-positions re header start)])
|
||||||
|
(if m
|
||||||
|
(let ([start (cdaddr m)]
|
||||||
|
[field-name (substring header (caaddr (cdr m)) (cdaddr (cdr m)))])
|
||||||
|
(let ([m2 (regexp-match-positions
|
||||||
|
#rx"\r\n[^: \r\n\"]*:" header start)])
|
||||||
|
(if m2
|
||||||
|
(cons (cons field-name
|
||||||
|
(substring header start (caar m2)))
|
||||||
|
(loop (caar m2)))
|
||||||
|
;; Rest of header is this field, but strip trailing CRLFCRLF:
|
||||||
|
(list
|
||||||
|
(cons field-name
|
||||||
|
(regexp-replace #rx"\r\n\r\n$"
|
||||||
|
(substring header start (string-length header))
|
||||||
|
""))))))
|
||||||
|
;; malformed header:
|
||||||
|
null))))))
|
||||||
|
|
||||||
(define (extract-all-fields header)
|
;; It's slightly less obvious how to generalize the functions that don't
|
||||||
(if (bytes? header)
|
;; accept a header as input; for lack of an obvious solution (and free time),
|
||||||
(let ([re #rx#"(^|[\r][\n])(([^\r\n:\"]*): *)"])
|
;; I'm stopping the string->bytes translation here. -- JBC, 2006-07-31
|
||||||
(let loop ([start 0])
|
|
||||||
(let ([m (regexp-match-positions re header start)])
|
|
||||||
(if m
|
|
||||||
(let ([start (cdaddr m)]
|
|
||||||
[field-name (subbytes header (caaddr (cdr m))
|
|
||||||
(cdaddr (cdr m)))])
|
|
||||||
(let ([m2 (regexp-match-positions
|
|
||||||
#rx#"\r\n[^: \r\n\"]*:"
|
|
||||||
header
|
|
||||||
start)])
|
|
||||||
(if m2
|
|
||||||
(cons (cons field-name
|
|
||||||
(subbytes header start (caar m2)))
|
|
||||||
(loop (caar m2)))
|
|
||||||
;; Rest of header is this field, but strip trailing CRLFCRLF:
|
|
||||||
(list
|
|
||||||
(cons field-name
|
|
||||||
(regexp-replace #rx#"\r\n\r\n$"
|
|
||||||
(subbytes header start (bytes-length header))
|
|
||||||
""))))))
|
|
||||||
;; malformed header:
|
|
||||||
null))))
|
|
||||||
;; otherwise, header should be a string:
|
|
||||||
(let ([re #rx"(^|[\r][\n])(([^\r\n:\"]*): *)"])
|
|
||||||
(let loop ([start 0])
|
|
||||||
(let ([m (regexp-match-positions re header start)])
|
|
||||||
(if m
|
|
||||||
(let ([start (cdaddr m)]
|
|
||||||
[field-name (substring header (caaddr (cdr m)) (cdaddr (cdr m)))])
|
|
||||||
(let ([m2 (regexp-match-positions
|
|
||||||
#rx"\r\n[^: \r\n\"]*:" header start)])
|
|
||||||
(if m2
|
|
||||||
(cons (cons field-name
|
|
||||||
(substring header start (caar m2)))
|
|
||||||
(loop (caar m2)))
|
|
||||||
;; Rest of header is this field, but strip trailing CRLFCRLF:
|
|
||||||
(list
|
|
||||||
(cons field-name
|
|
||||||
(regexp-replace #rx"\r\n\r\n$"
|
|
||||||
(substring header start (string-length header))
|
|
||||||
""))))))
|
|
||||||
;; malformed header:
|
|
||||||
null))))))
|
|
||||||
|
|
||||||
;; It's slightly less obvious how to generalize the functions that don't
|
(define (standard-message-header from tos ccs bccs subject)
|
||||||
;; accept a header as input; for lack of an obvious solution (and free time),
|
(let ([h (insert-field
|
||||||
;; I'm stopping the string->bytes translation here. -- JBC, 2006-07-31
|
"Subject" subject
|
||||||
|
(insert-field
|
||||||
(define (standard-message-header from tos ccs bccs subject)
|
"Date" (parameterize ([date-display-format 'rfc2822])
|
||||||
(let ([h (insert-field
|
(date->string (seconds->date (current-seconds)) #t))
|
||||||
"Subject" subject
|
CRLF))])
|
||||||
(insert-field
|
;; NOTE: bccs don't go into the header; that's why they're "blind"
|
||||||
"Date" (parameterize ([date-display-format 'rfc2822])
|
(let ([h (if (null? ccs)
|
||||||
(date->string (seconds->date (current-seconds)) #t))
|
h
|
||||||
CRLF))])
|
(insert-field "CC" (assemble-address-field ccs) h))])
|
||||||
;; NOTE: bccs don't go into the header; that's why they're "blind"
|
(let ([h (if (null? tos)
|
||||||
(let ([h (if (null? ccs)
|
|
||||||
h
|
h
|
||||||
(insert-field "CC" (assemble-address-field ccs) h))])
|
(insert-field "To" (assemble-address-field tos) h))])
|
||||||
(let ([h (if (null? tos)
|
(insert-field "From" from h)))))
|
||||||
h
|
|
||||||
(insert-field "To" (assemble-address-field tos) h))])
|
|
||||||
(insert-field "From" from h)))))
|
|
||||||
|
|
||||||
(define (splice l sep)
|
(define (splice l sep)
|
||||||
(if (null? l)
|
(if (null? l)
|
||||||
""
|
""
|
||||||
(format "~a~a"
|
(format "~a~a"
|
||||||
(car l)
|
(car l)
|
||||||
(apply string-append
|
(apply string-append
|
||||||
(map (lambda (n) (format "~a~a" sep n))
|
(map (lambda (n) (format "~a~a" sep n))
|
||||||
(cdr l))))))
|
(cdr l))))))
|
||||||
|
|
||||||
(define (data-lines->data datas)
|
(define (data-lines->data datas)
|
||||||
(splice datas "\r\n\t"))
|
(splice datas "\r\n\t"))
|
||||||
|
|
||||||
;; Extracting Addresses ;;
|
;; Extracting Addresses ;;
|
||||||
|
|
||||||
(define blank "[ \t\n\r\v]")
|
(define blank "[ \t\n\r\v]")
|
||||||
(define nonblank "[^ \t\n\r\v]")
|
(define nonblank "[^ \t\n\r\v]")
|
||||||
(define re:all-blank (regexp (format "^~a*$" blank)))
|
(define re:all-blank (regexp (format "^~a*$" blank)))
|
||||||
(define re:quoted (regexp "\"[^\"]*\""))
|
(define re:quoted (regexp "\"[^\"]*\""))
|
||||||
(define re:parened (regexp "[(][^)]*[)]"))
|
(define re:parened (regexp "[(][^)]*[)]"))
|
||||||
(define re:comma (regexp ","))
|
(define re:comma (regexp ","))
|
||||||
(define re:comma-separated (regexp "([^,]*),(.*)"))
|
(define re:comma-separated (regexp "([^,]*),(.*)"))
|
||||||
|
|
||||||
(define (extract-addresses s form)
|
(define (extract-addresses s form)
|
||||||
(unless (memq form '(name address full all))
|
(unless (memq form '(name address full all))
|
||||||
(raise-type-error 'extract-addresses
|
(raise-type-error 'extract-addresses
|
||||||
"form: 'name, 'address, 'full, or 'all"
|
"form: 'name, 'address, 'full, or 'all"
|
||||||
form))
|
form))
|
||||||
(if (or (not s) (regexp-match re:all-blank s))
|
(if (or (not s) (regexp-match re:all-blank s))
|
||||||
null
|
null
|
||||||
(let loop ([prefix ""][s s])
|
(let loop ([prefix ""][s s])
|
||||||
;; Which comes first - a quote or a comma?
|
;; Which comes first - a quote or a comma?
|
||||||
(let* ([mq1 (regexp-match-positions re:quoted s)]
|
(let* ([mq1 (regexp-match-positions re:quoted s)]
|
||||||
[mq2 (regexp-match-positions re:parened s)]
|
[mq2 (regexp-match-positions re:parened s)]
|
||||||
[mq (if (and mq1 mq2)
|
[mq (if (and mq1 mq2)
|
||||||
(if (< (caar mq1) (caar mq2))
|
(if (< (caar mq1) (caar mq2)) mq1 mq2)
|
||||||
mq1
|
(or mq1 mq2))]
|
||||||
mq2)
|
[mc (regexp-match-positions re:comma s)])
|
||||||
(or mq1 mq2))]
|
(if (and mq mc (< (caar mq) (caar mc) (cdar mq)))
|
||||||
[mc (regexp-match-positions re:comma s)])
|
;; Quote contains a comma
|
||||||
(if (and mq mc (< (caar mq) (caar mc) (cdar mq)))
|
(loop (string-append
|
||||||
;; Quote contains a comma
|
prefix
|
||||||
(loop (string-append
|
(substring s 0 (cdar mq)))
|
||||||
prefix
|
(substring s (cdar mq) (string-length s)))
|
||||||
(substring s 0 (cdar mq)))
|
;; Normal comma parsing:
|
||||||
(substring s (cdar mq) (string-length s)))
|
(let ([m (regexp-match re:comma-separated s)])
|
||||||
;; Normal comma parsing:
|
(if m
|
||||||
(let ([m (regexp-match re:comma-separated s)])
|
(let ([n (extract-one-name (string-append prefix (cadr m)) form)]
|
||||||
(if m
|
[rest (extract-addresses (caddr m) form)])
|
||||||
(let ([n (extract-one-name (string-append prefix (cadr m)) form)]
|
(cons n rest))
|
||||||
[rest (extract-addresses (caddr m) form)])
|
(let ([n (extract-one-name (string-append prefix s) form)])
|
||||||
(cons n rest))
|
(list n)))))))))
|
||||||
(let ([n (extract-one-name (string-append prefix s) form)])
|
|
||||||
(list n)))))))))
|
|
||||||
|
|
||||||
(define (select-result form name addr full)
|
(define (select-result form name addr full)
|
||||||
(case form
|
(case form
|
||||||
[(name) name]
|
[(name) name]
|
||||||
[(address) addr]
|
[(address) addr]
|
||||||
[(full) full]
|
[(full) full]
|
||||||
[(all) (list name addr full)]))
|
[(all) (list name addr full)]))
|
||||||
|
|
||||||
(define (one-result form s)
|
(define (one-result form s)
|
||||||
(select-result form s s s))
|
(select-result form s s s))
|
||||||
|
|
||||||
(define re:quoted-name (regexp (format "^~a*(\"[^\"]*\")(.*)" blank)))
|
(define re:quoted-name (regexp (format "^~a*(\"[^\"]*\")(.*)" blank)))
|
||||||
(define re:parened-name (regexp (format "(.*)[(]([^)]*)[)]~a*$" blank)))
|
(define re:parened-name (regexp (format "(.*)[(]([^)]*)[)]~a*$" blank)))
|
||||||
(define re:simple-name (regexp (format "^~a*(~a.*)(<.*>)~a*$" blank nonblank blank)))
|
(define re:simple-name (regexp (format "^~a*(~a.*)(<.*>)~a*$" blank nonblank blank)))
|
||||||
(define re:normal-name (regexp (format "~a*<([^>]*)>~a*" blank blank)))
|
(define re:normal-name (regexp (format "~a*<([^>]*)>~a*" blank blank)))
|
||||||
(define re:double-less (regexp "<.*<"))
|
(define re:double-less (regexp "<.*<"))
|
||||||
(define re:double-greater (regexp ">.*>"))
|
(define re:double-greater (regexp ">.*>"))
|
||||||
(define re:bad-chars (regexp "[,\"()<>]"))
|
(define re:bad-chars (regexp "[,\"()<>]"))
|
||||||
(define re:tail-blanks (regexp (format "~a+$" blank)))
|
(define re:tail-blanks (regexp (format "~a+$" blank)))
|
||||||
(define re:head-blanks (regexp (format "^~a+" blank)))
|
(define re:head-blanks (regexp (format "^~a+" blank)))
|
||||||
|
|
||||||
(define (extract-one-name orig form)
|
(define (extract-one-name orig form)
|
||||||
(let loop ([s orig][form form])
|
(let loop ([s orig][form form])
|
||||||
(cond
|
(cond
|
||||||
;; ?!?!? Where does the "addr (name)" standard come from ?!?!?
|
;; ?!?!? Where does the "addr (name)" standard come from ?!?!?
|
||||||
[(regexp-match re:parened-name s)
|
[(regexp-match re:parened-name s)
|
||||||
=> (lambda (m)
|
=> (lambda (m)
|
||||||
(let ([name (caddr m)]
|
(let ([name (caddr m)]
|
||||||
[all (loop (cadr m) 'all)])
|
[all (loop (cadr m) 'all)])
|
||||||
(select-result
|
(select-result
|
||||||
form
|
form
|
||||||
(if (string=? (car all) (cadr all)) name (car all))
|
(if (string=? (car all) (cadr all)) name (car all))
|
||||||
(cadr all)
|
(cadr all)
|
||||||
(format "~a (~a)" (caddr all) name))))]
|
(format "~a (~a)" (caddr all) name))))]
|
||||||
[(regexp-match re:quoted-name s)
|
[(regexp-match re:quoted-name s)
|
||||||
=> (lambda (m)
|
=> (lambda (m)
|
||||||
(let ([name (cadr m)]
|
(let ([name (cadr m)]
|
||||||
[addr (extract-angle-addr (caddr m) s)])
|
[addr (extract-angle-addr (caddr m) s)])
|
||||||
(select-result form name addr
|
(select-result form name addr
|
||||||
(format "~a <~a>" name addr))))]
|
(format "~a <~a>" name addr))))]
|
||||||
[(regexp-match re:simple-name s)
|
[(regexp-match re:simple-name s)
|
||||||
=> (lambda (m)
|
=> (lambda (m)
|
||||||
(let ([name (regexp-replace (format "~a*$" blank) (cadr m) "")]
|
(let ([name (regexp-replace (format "~a*$" blank) (cadr m) "")]
|
||||||
[addr (extract-angle-addr (caddr m) s)])
|
[addr (extract-angle-addr (caddr m) s)])
|
||||||
(select-result form name addr
|
(select-result form name addr
|
||||||
(format "~a <~a>" name addr))))]
|
(format "~a <~a>" name addr))))]
|
||||||
[(or (regexp-match "<" s) (regexp-match ">" s))
|
[(or (regexp-match "<" s) (regexp-match ">" s))
|
||||||
(one-result form (extract-angle-addr s orig))]
|
(one-result form (extract-angle-addr s orig))]
|
||||||
[else (one-result form (extract-simple-addr s orig))])))
|
[else (one-result form (extract-simple-addr s orig))])))
|
||||||
|
|
||||||
(define (extract-angle-addr s orig)
|
(define (extract-angle-addr s orig)
|
||||||
(if (or (regexp-match re:double-less s) (regexp-match re:double-greater s))
|
(if (or (regexp-match re:double-less s) (regexp-match re:double-greater s))
|
||||||
(error 'extract-address "too many angle brackets: ~a" s)
|
(error 'extract-address "too many angle brackets: ~a" s)
|
||||||
(let ([m (regexp-match re:normal-name s)])
|
(let ([m (regexp-match re:normal-name s)])
|
||||||
(if m
|
(if m
|
||||||
(extract-simple-addr (cadr m) orig)
|
(extract-simple-addr (cadr m) orig)
|
||||||
(error 'extract-address "cannot parse address: ~a" orig)))))
|
(error 'extract-address "cannot parse address: ~a" orig)))))
|
||||||
|
|
||||||
(define (extract-simple-addr s orig)
|
(define (extract-simple-addr s orig)
|
||||||
(cond [(regexp-match re:bad-chars s)
|
(cond [(regexp-match re:bad-chars s)
|
||||||
(error 'extract-address "cannot parse address: ~a" orig)]
|
(error 'extract-address "cannot parse address: ~a" orig)]
|
||||||
[else
|
[else
|
||||||
;; final whitespace strip
|
;; final whitespace strip
|
||||||
(regexp-replace re:tail-blanks
|
(regexp-replace re:tail-blanks
|
||||||
(regexp-replace re:head-blanks s "")
|
(regexp-replace re:head-blanks s "")
|
||||||
"")]))
|
"")]))
|
||||||
|
|
||||||
(define (assemble-address-field addresses)
|
(define (assemble-address-field addresses)
|
||||||
(if (null? addresses)
|
(if (null? addresses)
|
||||||
""
|
""
|
||||||
(let loop ([addresses (cdr addresses)]
|
(let loop ([addresses (cdr addresses)]
|
||||||
[s (car addresses)]
|
[s (car addresses)]
|
||||||
[len (string-length (car addresses))])
|
[len (string-length (car addresses))])
|
||||||
(if (null? addresses)
|
(if (null? addresses)
|
||||||
s
|
s
|
||||||
(let* ([addr (car addresses)]
|
(let* ([addr (car addresses)]
|
||||||
[alen (string-length addr)])
|
[alen (string-length addr)])
|
||||||
(if (<= 72 (+ len alen))
|
(if (<= 72 (+ len alen))
|
||||||
(loop (cdr addresses)
|
(loop (cdr addresses)
|
||||||
(format "~a,~a~a~a~a"
|
(format "~a,~a~a~a~a"
|
||||||
s #\return #\linefeed
|
s #\return #\linefeed
|
||||||
#\tab addr)
|
#\tab addr)
|
||||||
alen)
|
alen)
|
||||||
(loop (cdr addresses)
|
(loop (cdr addresses)
|
||||||
(format "~a, ~a" s addr)
|
(format "~a, ~a" s addr)
|
||||||
(+ len alen 2))))))))
|
(+ len alen 2))))))))
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
(module head mzscheme
|
#lang scheme/base
|
||||||
(require mzlib/unit "head-sig.ss" "head-unit.ss")
|
(require scheme/unit "head-sig.ss" "head-unit.ss")
|
||||||
|
|
||||||
(define-values/invoke-unit/infer head@)
|
(define-values/invoke-unit/infer head@)
|
||||||
|
|
||||||
(provide-signature-elements head^))
|
(provide-signature-elements head^)
|
||||||
|
|
|
||||||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,49 +1,50 @@
|
||||||
(module imap mzscheme
|
#lang scheme/base
|
||||||
(require mzlib/unit mzlib/contract "imap-sig.ss" "imap-unit.ss")
|
(require scheme/unit scheme/contract "imap-sig.ss" "imap-unit.ss")
|
||||||
|
|
||||||
(define-values/invoke-unit/infer imap@)
|
(define-values/invoke-unit/infer imap@)
|
||||||
|
|
||||||
(provide/contract
|
(provide/contract
|
||||||
[imap-get-hierarchy-delimiter (imap-connection? . -> . bytes?)]
|
[imap-get-hierarchy-delimiter (imap-connection? . -> . bytes?)]
|
||||||
[imap-list-child-mailboxes
|
[imap-list-child-mailboxes
|
||||||
(case->
|
(case->
|
||||||
(imap-connection? (or/c false/c bytes?) . -> . (listof (list/c (listof symbol?) bytes?)))
|
(imap-connection? (or/c false/c bytes?)
|
||||||
(imap-connection? (or/c false/c bytes?) (or/c false/c bytes?)
|
. -> . (listof (list/c (listof symbol?) bytes?)))
|
||||||
. -> .
|
(imap-connection? (or/c false/c bytes?) (or/c false/c bytes?)
|
||||||
(listof (list/c (listof symbol?) bytes?))))])
|
. -> .
|
||||||
|
(listof (list/c (listof symbol?) bytes?))))])
|
||||||
|
|
||||||
(provide
|
(provide
|
||||||
imap-connection?
|
imap-connection?
|
||||||
imap-connect imap-connect*
|
imap-connect imap-connect*
|
||||||
imap-disconnect
|
imap-disconnect
|
||||||
imap-force-disconnect
|
imap-force-disconnect
|
||||||
imap-reselect
|
imap-reselect
|
||||||
imap-examine
|
imap-examine
|
||||||
imap-noop
|
imap-noop
|
||||||
imap-poll
|
imap-poll
|
||||||
imap-status
|
imap-status
|
||||||
|
|
||||||
imap-port-number ; a parameter
|
imap-port-number ; a parameter
|
||||||
|
|
||||||
imap-new?
|
imap-new?
|
||||||
imap-messages
|
imap-messages
|
||||||
imap-recent
|
imap-recent
|
||||||
imap-uidnext
|
imap-uidnext
|
||||||
imap-uidvalidity
|
imap-uidvalidity
|
||||||
imap-unseen
|
imap-unseen
|
||||||
imap-reset-new!
|
imap-reset-new!
|
||||||
|
|
||||||
imap-get-expunges
|
imap-get-expunges
|
||||||
imap-pending-expunges?
|
imap-pending-expunges?
|
||||||
imap-get-updates
|
imap-get-updates
|
||||||
imap-pending-updates?
|
imap-pending-updates?
|
||||||
|
|
||||||
imap-get-messages
|
imap-get-messages
|
||||||
imap-copy imap-append
|
imap-copy imap-append
|
||||||
imap-store imap-flag->symbol symbol->imap-flag
|
imap-store imap-flag->symbol symbol->imap-flag
|
||||||
imap-expunge
|
imap-expunge
|
||||||
|
|
||||||
imap-mailbox-exists?
|
imap-mailbox-exists?
|
||||||
imap-create-mailbox
|
imap-create-mailbox
|
||||||
|
|
||||||
imap-mailbox-flags))
|
imap-mailbox-flags)
|
||||||
|
|
|
||||||
|
|
@ -12,16 +12,13 @@
|
||||||
|
|
||||||
;; -- basic mime structures --
|
;; -- basic mime structures --
|
||||||
(struct message (version entity fields))
|
(struct message (version entity fields))
|
||||||
(struct entity
|
(struct entity (type subtype charset encoding
|
||||||
(type subtype charset encoding
|
disposition params id
|
||||||
disposition params id
|
description other fields
|
||||||
description other fields
|
parts body))
|
||||||
parts body))
|
(struct disposition (type filename creation
|
||||||
(struct disposition
|
modification read
|
||||||
(type filename creation
|
size params))
|
||||||
modification read
|
|
||||||
size params))
|
|
||||||
|
|
||||||
;; -- mime methods --
|
;; -- mime methods --
|
||||||
mime-analyze
|
mime-analyze
|
||||||
|
|
||||||
|
|
|
||||||
File diff suppressed because it is too large
Load Diff
|
|
@ -26,116 +26,111 @@
|
||||||
;;
|
;;
|
||||||
;; Commentary:
|
;; Commentary:
|
||||||
|
|
||||||
(module mime-util mzscheme
|
#lang scheme/base
|
||||||
(require mzlib/etc)
|
|
||||||
|
|
||||||
(provide string-tokenizer
|
(provide string-tokenizer
|
||||||
trim-all-spaces
|
trim-all-spaces
|
||||||
trim-spaces
|
trim-spaces
|
||||||
trim-comments
|
trim-comments
|
||||||
lowercase
|
lowercase
|
||||||
warning
|
warning
|
||||||
cat)
|
cat)
|
||||||
|
|
||||||
;; string-index returns the leftmost index in string s
|
;; string-index returns the leftmost index in string s
|
||||||
;; that has character c
|
;; that has character c
|
||||||
(define (string-index s c)
|
(define (string-index s c)
|
||||||
(let ([n (string-length s)])
|
(let ([n (string-length s)])
|
||||||
(let loop ([i 0])
|
(let loop ([i 0])
|
||||||
(cond [(>= i n) #f]
|
(cond [(>= i n) #f]
|
||||||
[(char=? (string-ref s i) c) i]
|
[(char=? (string-ref s i) c) i]
|
||||||
[else (loop (+ i 1))]))))
|
[else (loop (+ i 1))]))))
|
||||||
|
|
||||||
;; string-tokenizer breaks string s into substrings separated by character c
|
;; string-tokenizer breaks string s into substrings separated by character c
|
||||||
(define (string-tokenizer c s)
|
(define (string-tokenizer c s)
|
||||||
(let loop ([s s])
|
(let loop ([s s])
|
||||||
(if (string=? s "") '()
|
(if (string=? s "") '()
|
||||||
(let ([i (string-index s c)])
|
(let ([i (string-index s c)])
|
||||||
(if i (cons (substring s 0 i)
|
(if i (cons (substring s 0 i)
|
||||||
(loop (substring s (+ i 1)
|
(loop (substring s (+ i 1) (string-length s))))
|
||||||
(string-length s))))
|
(list s))))))
|
||||||
(list s))))))
|
|
||||||
|
|
||||||
;; Trim all spaces, except those in quoted strings.
|
;; Trim all spaces, except those in quoted strings.
|
||||||
(define re:quote-start (regexp "\""))
|
(define re:quote-start (regexp "\""))
|
||||||
(define re:space (regexp "[ \t\n\r\v]"))
|
(define re:space (regexp "[ \t\n\r\v]"))
|
||||||
(define (trim-all-spaces str)
|
(define (trim-all-spaces str)
|
||||||
;; Break out alternate quoted and unquoted parts.
|
;; Break out alternate quoted and unquoted parts.
|
||||||
;; Initial and final string are unquoted.
|
;; Initial and final string are unquoted.
|
||||||
(let-values ([(unquoted quoted)
|
(let-values ([(unquoted quoted)
|
||||||
(let loop ([str str] [unquoted null] [quoted null])
|
(let loop ([str str] [unquoted null] [quoted null])
|
||||||
(let ([m (regexp-match-positions re:quote-start str)])
|
(let ([m (regexp-match-positions re:quote-start str)])
|
||||||
(if m
|
(if m
|
||||||
(let ([prefix (substring str 0 (caar m))]
|
(let ([prefix (substring str 0 (caar m))]
|
||||||
[rest (substring str (add1 (caar m)) (string-length str))])
|
[rest (substring str (add1 (caar m)) (string-length str))])
|
||||||
;; Find closing quote
|
;; Find closing quote
|
||||||
(let ([m (regexp-match-positions re:quote-start rest)])
|
(let ([m (regexp-match-positions re:quote-start rest)])
|
||||||
(if m
|
(if m
|
||||||
(let ([inside (substring rest 0 (caar m))]
|
(let ([inside (substring rest 0 (caar m))]
|
||||||
[rest (substring rest (add1 (caar m)) (string-length rest))])
|
[rest (substring rest (add1 (caar m)) (string-length rest))])
|
||||||
(loop rest (cons prefix unquoted) (cons (format "\"~a\"" inside) quoted)))
|
(loop rest (cons prefix unquoted) (cons (format "\"~a\"" inside) quoted)))
|
||||||
;; No closing quote!
|
;; No closing quote!
|
||||||
(loop "" (cons prefix unquoted) (cons (format "\"~a" rest) quoted)))))
|
(loop "" (cons prefix unquoted) (cons (format "\"~a" rest) quoted)))))
|
||||||
(values (reverse (cons str unquoted)) (reverse quoted)))))])
|
(values (reverse (cons str unquoted)) (reverse quoted)))))])
|
||||||
;; Put the pieces back together, stripping spaces for unquoted parts:
|
;; Put the pieces back together, stripping spaces for unquoted parts:
|
||||||
(apply
|
(apply
|
||||||
string-append
|
string-append
|
||||||
(let loop ([unquoted unquoted][quoted quoted])
|
(let loop ([unquoted unquoted][quoted quoted])
|
||||||
(let ([clean (regexp-replace* re:space (car unquoted) "")])
|
(let ([clean (regexp-replace* re:space (car unquoted) "")])
|
||||||
(if (null? quoted)
|
(if (null? quoted)
|
||||||
(list clean)
|
(list clean)
|
||||||
(list* clean
|
(list* clean
|
||||||
(car quoted)
|
(car quoted)
|
||||||
(loop (cdr unquoted) (cdr quoted)))))))))
|
(loop (cdr unquoted) (cdr quoted)))))))))
|
||||||
|
|
||||||
;; Only trims left and right spaces:
|
;; Only trims left and right spaces:
|
||||||
(define (trim-spaces str)
|
(define (trim-spaces str)
|
||||||
(trim-right (trim-left str)))
|
(trim-right (trim-left str)))
|
||||||
|
|
||||||
(define re:left-spaces (regexp "^[ \t\r\n\v]+"))
|
(define re:left-spaces (regexp "^[ \t\r\n\v]+"))
|
||||||
(define (trim-left str)
|
(define (trim-left str)
|
||||||
(regexp-replace re:left-spaces str ""))
|
(regexp-replace re:left-spaces str ""))
|
||||||
|
|
||||||
(define re:right-spaces (regexp "[ \t\r\n\v]+$"))
|
(define re:right-spaces (regexp "[ \t\r\n\v]+$"))
|
||||||
(define (trim-right str)
|
(define (trim-right str)
|
||||||
(regexp-replace re:right-spaces str ""))
|
(regexp-replace re:right-spaces str ""))
|
||||||
|
|
||||||
(define re:comments (regexp "^[^\"]*(\"[^\"]*\")*[^\"]*(\\(.*\\))"))
|
(define re:comments (regexp "^[^\"]*(\"[^\"]*\")*[^\"]*(\\(.*\\))"))
|
||||||
(define (trim-comments str)
|
(define (trim-comments str)
|
||||||
(let ([positions (regexp-match-positions re:comments str)])
|
(let ([positions (regexp-match-positions re:comments str)])
|
||||||
(if positions
|
(if positions
|
||||||
(string-append (substring str 0 (caaddr positions))
|
(string-append (substring str 0 (caaddr positions))
|
||||||
(substring str (cdaddr positions) (string-length str)))
|
(substring str (cdaddr positions) (string-length str)))
|
||||||
str)))
|
str)))
|
||||||
|
|
||||||
(define (lowercase str)
|
(define (lowercase str)
|
||||||
(let loop ([out ""] [rest str] [size (string-length str)])
|
(let loop ([out ""] [rest str] [size (string-length str)])
|
||||||
(cond [(zero? size) out]
|
(cond [(zero? size) out]
|
||||||
[else
|
[else
|
||||||
(loop (string-append out (string
|
(loop (string-append out (string
|
||||||
(char-downcase
|
(char-downcase
|
||||||
(string-ref rest 0))))
|
(string-ref rest 0))))
|
||||||
(substring rest 1 size)
|
(substring rest 1 size)
|
||||||
(sub1 size))])))
|
(sub1 size))])))
|
||||||
|
|
||||||
(define warning
|
|
||||||
void
|
|
||||||
#;
|
|
||||||
(lambda (msg . args)
|
|
||||||
(fprintf (current-error-port)
|
|
||||||
(apply format (cons msg args)))
|
|
||||||
(newline (current-error-port)))
|
|
||||||
)
|
|
||||||
|
|
||||||
;; Copies its input `in' to its ouput port if given, it uses
|
|
||||||
;; current-output-port if out is not provided.
|
|
||||||
(define cat
|
|
||||||
(opt-lambda (in (out (current-output-port)))
|
|
||||||
(let loop ([ln (read-line in)])
|
|
||||||
(unless (eof-object? ln)
|
|
||||||
(fprintf out "~a\n" ln)
|
|
||||||
(loop (read-line in))))))
|
|
||||||
|
|
||||||
|
(define warning
|
||||||
|
void
|
||||||
|
#;
|
||||||
|
(lambda (msg . args)
|
||||||
|
(fprintf (current-error-port)
|
||||||
|
(apply format (cons msg args)))
|
||||||
|
(newline (current-error-port)))
|
||||||
)
|
)
|
||||||
|
|
||||||
|
;; Copies its input `in' to its ouput port if given, it uses
|
||||||
|
;; current-output-port if out is not provided.
|
||||||
|
(define (cat in [out (current-output-port)])
|
||||||
|
(let loop ([ln (read-line in)])
|
||||||
|
(unless (eof-object? ln)
|
||||||
|
(fprintf out "~a\n" ln)
|
||||||
|
(loop (read-line in)))))
|
||||||
|
|
||||||
;;; mime-util.ss ends here
|
;;; mime-util.ss ends here
|
||||||
|
|
|
||||||
|
|
@ -26,26 +26,26 @@
|
||||||
;;
|
;;
|
||||||
;; Commentary:
|
;; Commentary:
|
||||||
|
|
||||||
(module mime mzscheme
|
#lang scheme/base
|
||||||
(require mzlib/unit
|
(require scheme/unit
|
||||||
"mime-sig.ss"
|
"mime-sig.ss"
|
||||||
"mime-unit.ss"
|
"mime-unit.ss"
|
||||||
"qp-sig.ss"
|
"qp-sig.ss"
|
||||||
"qp.ss"
|
"qp.ss"
|
||||||
"base64-sig.ss"
|
"base64-sig.ss"
|
||||||
"base64.ss"
|
"base64.ss"
|
||||||
"head-sig.ss"
|
"head-sig.ss"
|
||||||
"head.ss")
|
"head.ss")
|
||||||
|
|
||||||
(define-unit-from-context base64@ base64^)
|
(define-unit-from-context base64@ base64^)
|
||||||
(define-unit-from-context qp@ qp^)
|
(define-unit-from-context qp@ qp^)
|
||||||
(define-unit-from-context head@ head^)
|
(define-unit-from-context head@ head^)
|
||||||
|
|
||||||
(define-compound-unit/infer mime@2 (import) (export mime^)
|
(define-compound-unit/infer mime@2 (import) (export mime^)
|
||||||
(link base64@ qp@ head@ mime@))
|
(link base64@ qp@ head@ mime@))
|
||||||
|
|
||||||
(define-values/invoke-unit/infer mime@2)
|
(define-values/invoke-unit/infer mime@2)
|
||||||
|
|
||||||
(provide-signature-elements mime^))
|
(provide-signature-elements mime^)
|
||||||
|
|
||||||
;;; mime.ss ends here
|
;;; mime.ss ends here
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
(module nntp mzscheme
|
#lang scheme/base
|
||||||
(require mzlib/unit "nntp-sig.ss" "nntp-unit.ss")
|
(require scheme/unit "nntp-sig.ss" "nntp-unit.ss")
|
||||||
|
|
||||||
(define-values/invoke-unit/infer nntp@)
|
(define-values/invoke-unit/infer nntp@)
|
||||||
|
|
||||||
(provide-signature-elements nntp^))
|
(provide-signature-elements nntp^)
|
||||||
|
|
|
||||||
|
|
@ -1,9 +1,9 @@
|
||||||
(module pop3 mzscheme
|
#lang scheme/base
|
||||||
(require mzlib/unit "pop3-sig.ss" "pop3-unit.ss")
|
(require scheme/unit "pop3-sig.ss" "pop3-unit.ss")
|
||||||
|
|
||||||
(define-values/invoke-unit/infer pop3@)
|
(define-values/invoke-unit/infer pop3@)
|
||||||
|
|
||||||
(provide-signature-elements pop3^))
|
(provide-signature-elements pop3^)
|
||||||
|
|
||||||
#|
|
#|
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -28,148 +28,138 @@
|
||||||
|
|
||||||
#lang scheme/unit
|
#lang scheme/unit
|
||||||
|
|
||||||
(require "qp-sig.ss"
|
(require "qp-sig.ss")
|
||||||
mzlib/etc)
|
|
||||||
|
|
||||||
(import)
|
(import)
|
||||||
(export qp^)
|
(export qp^)
|
||||||
|
|
||||||
;; Exceptions:
|
;; Exceptions:
|
||||||
;; String or input-port expected:
|
;; String or input-port expected:
|
||||||
(define-struct qp-error ())
|
(define-struct qp-error ())
|
||||||
(define-struct (qp-wrong-input qp-error) ())
|
(define-struct (qp-wrong-input qp-error) ())
|
||||||
(define-struct (qp-wrong-line-size qp-error) (size))
|
(define-struct (qp-wrong-line-size qp-error) (size))
|
||||||
|
|
||||||
;; qp-encode : bytes -> bytes
|
;; qp-encode : bytes -> bytes
|
||||||
;; returns the quoted printable representation of STR.
|
;; returns the quoted printable representation of STR.
|
||||||
(define qp-encode
|
(define (qp-encode str)
|
||||||
(lambda (str)
|
(let ([out (open-output-bytes)])
|
||||||
(let ([out (open-output-bytes)])
|
(qp-encode-stream (open-input-bytes str) out #"\r\n")
|
||||||
(qp-encode-stream (open-input-bytes str) out #"\r\n")
|
(get-output-bytes out)))
|
||||||
(get-output-bytes out))))
|
|
||||||
|
|
||||||
;; qp-decode : string -> string
|
;; qp-decode : string -> string
|
||||||
;; returns STR unqp.
|
;; returns STR unqp.
|
||||||
(define qp-decode
|
(define (qp-decode str)
|
||||||
(lambda (str)
|
(let ([out (open-output-bytes)])
|
||||||
(let ([out (open-output-bytes)])
|
(qp-decode-stream (open-input-bytes str) out)
|
||||||
(qp-decode-stream (open-input-bytes str) out)
|
(get-output-bytes out)))
|
||||||
(get-output-bytes out))))
|
|
||||||
|
|
||||||
(define qp-decode-stream
|
(define (qp-decode-stream in out)
|
||||||
(lambda (in out)
|
(let loop ([ch (read-byte in)])
|
||||||
(let loop ([ch (read-byte in)])
|
(unless (eof-object? ch)
|
||||||
(unless (eof-object? ch)
|
(case ch
|
||||||
(case ch
|
[(61) ;; A "=", which is quoted-printable stuff
|
||||||
[(61) ;; A "=", which is quoted-printable stuff
|
(let ([next (read-byte in)])
|
||||||
(let ([next (read-byte in)])
|
(cond
|
||||||
(cond
|
[(eq? next 10)
|
||||||
[(eq? next 10)
|
;; Soft-newline -- drop it
|
||||||
;; Soft-newline -- drop it
|
(void)]
|
||||||
(void)]
|
[(eq? next 13)
|
||||||
[(eq? next 13)
|
;; Expect a newline for a soft CRLF...
|
||||||
;; Expect a newline for a soft CRLF...
|
(let ([next-next (read-byte in)])
|
||||||
(let ([next-next (read-byte in)])
|
(if (eq? next-next 10)
|
||||||
(if (eq? next-next 10)
|
;; Good.
|
||||||
;; Good.
|
(loop (read-byte in))
|
||||||
(loop (read-byte in))
|
;; Not a LF? Well, ok.
|
||||||
;; Not a LF? Well, ok.
|
(loop next-next)))]
|
||||||
(loop next-next)))]
|
[(hex-digit? next)
|
||||||
[(hex-digit? next)
|
(let ([next-next (read-byte in)])
|
||||||
(let ([next-next (read-byte in)])
|
(cond [(eof-object? next-next)
|
||||||
(cond [(eof-object? next-next)
|
(warning "Illegal qp sequence: `=~a'" next)
|
||||||
(warning "Illegal qp sequence: `=~a'" next)
|
(display "=" out)
|
||||||
(display "=" out)
|
(display next out)]
|
||||||
(display next out)]
|
[(hex-digit? next-next)
|
||||||
[(hex-digit? next-next)
|
;; qp-encoded
|
||||||
;; qp-encoded
|
(write-byte (hex-bytes->byte next next-next)
|
||||||
(write-byte (hex-bytes->byte next next-next)
|
out)]
|
||||||
out)]
|
[else
|
||||||
[else
|
(warning "Illegal qp sequence: `=~a~a'" next next-next)
|
||||||
(warning "Illegal qp sequence: `=~a~a'" next next-next)
|
(write-byte 61 out)
|
||||||
(write-byte 61 out)
|
(write-byte next out)
|
||||||
(write-byte next out)
|
(write-byte next-next out)]))]
|
||||||
(write-byte next-next out)]))]
|
[else
|
||||||
[else
|
;; Warning: invalid
|
||||||
;; Warning: invalid
|
(warning "Illegal qp sequence: `=~a'" next)
|
||||||
(warning "Illegal qp sequence: `=~a'" next)
|
(write-byte 61 out)
|
||||||
(write-byte 61 out)
|
(write-byte next out)])
|
||||||
(write-byte next out)])
|
(loop (read-byte in)))]
|
||||||
(loop (read-byte in)))]
|
[else
|
||||||
[else
|
(write-byte ch out)
|
||||||
(write-byte ch out)
|
(loop (read-byte in))]))))
|
||||||
(loop (read-byte in))])))))
|
|
||||||
|
|
||||||
(define warning
|
(define (warning msg . args)
|
||||||
(lambda (msg . args)
|
(when #f
|
||||||
(when #f
|
(fprintf (current-error-port)
|
||||||
(fprintf (current-error-port)
|
(apply format msg args))
|
||||||
(apply format msg args))
|
(newline (current-error-port))))
|
||||||
(newline (current-error-port)))))
|
|
||||||
|
|
||||||
(define (hex-digit? i)
|
(define (hex-digit? i)
|
||||||
(vector-ref hex-values i))
|
(vector-ref hex-values i))
|
||||||
|
|
||||||
(define hex-bytes->byte
|
(define (hex-bytes->byte b1 b2)
|
||||||
(lambda (b1 b2)
|
(+ (* 16 (vector-ref hex-values b1))
|
||||||
(+ (* 16 (vector-ref hex-values b1))
|
(vector-ref hex-values b2)))
|
||||||
(vector-ref hex-values b2))))
|
|
||||||
|
|
||||||
(define write-hex-bytes
|
(define (write-hex-bytes byte p)
|
||||||
(lambda (byte p)
|
(write-byte 61 p)
|
||||||
(write-byte 61 p)
|
(write-byte (vector-ref hex-bytes (arithmetic-shift byte -4)) p)
|
||||||
(write-byte (vector-ref hex-bytes (arithmetic-shift byte -4)) p)
|
(write-byte (vector-ref hex-bytes (bitwise-and byte 15)) p))
|
||||||
(write-byte (vector-ref hex-bytes (bitwise-and byte 15)) p)))
|
|
||||||
|
|
||||||
(define re:blanks #rx#"[ \t]+$")
|
(define (qp-encode-stream in out [newline-string #"\n"])
|
||||||
|
(let loop ([col 0])
|
||||||
|
(if (= col 75)
|
||||||
|
(begin
|
||||||
|
;; Soft newline:
|
||||||
|
(write-byte 61 out)
|
||||||
|
(display newline-string out)
|
||||||
|
(loop 0))
|
||||||
|
(let ([i (read-byte in)])
|
||||||
|
(cond
|
||||||
|
[(eof-object? i) (void)]
|
||||||
|
[(or (= i 10) (= i 13))
|
||||||
|
(write-byte i out)
|
||||||
|
(loop 0)]
|
||||||
|
[(or (<= 33 i 60) (<= 62 i 126)
|
||||||
|
(and (or (= i 32) (= i 9))
|
||||||
|
(not (let ([next (peek-byte in)])
|
||||||
|
(or (eof-object? next) (= next 10) (= next 13))))))
|
||||||
|
;; single-byte mode:
|
||||||
|
(write-byte i out)
|
||||||
|
(loop (add1 col))]
|
||||||
|
[(>= col 73)
|
||||||
|
;; need a soft newline first
|
||||||
|
(write-byte 61 out)
|
||||||
|
(display newline-string out)
|
||||||
|
;; now the octect
|
||||||
|
(write-hex-bytes i out)
|
||||||
|
(loop 3)]
|
||||||
|
[else
|
||||||
|
;; an octect
|
||||||
|
(write-hex-bytes i out)
|
||||||
|
(loop (+ col 3))])))))
|
||||||
|
|
||||||
(define qp-encode-stream
|
;; Tables
|
||||||
(opt-lambda (in out [newline-string #"\n"])
|
(define hex-values (make-vector 256 #f))
|
||||||
(let loop ([col 0])
|
(define hex-bytes (make-vector 16))
|
||||||
(if (= col 75)
|
(let loop ([i 0])
|
||||||
(begin
|
(unless (= i 10)
|
||||||
;; Soft newline:
|
(vector-set! hex-values (+ i 48) i)
|
||||||
(write-byte 61 out)
|
(vector-set! hex-bytes i (+ i 48))
|
||||||
(display newline-string out)
|
(loop (add1 i))))
|
||||||
(loop 0))
|
(let loop ([i 0])
|
||||||
(let ([i (read-byte in)])
|
(unless (= i 6)
|
||||||
(cond
|
(vector-set! hex-values (+ i 65) (+ 10 i))
|
||||||
[(eof-object? i) (void)]
|
(vector-set! hex-values (+ i 97) (+ 10 i))
|
||||||
[(or (= i 10) (= i 13))
|
(vector-set! hex-bytes (+ 10 i) (+ i 65))
|
||||||
(write-byte i out)
|
(loop (add1 i))))
|
||||||
(loop 0)]
|
|
||||||
[(or (<= 33 i 60) (<= 62 i 126)
|
|
||||||
(and (or (= i 32) (= i 9))
|
|
||||||
(not (let ([next (peek-byte in)])
|
|
||||||
(or (eof-object? next) (= next 10) (= next 13))))))
|
|
||||||
;; single-byte mode:
|
|
||||||
(write-byte i out)
|
|
||||||
(loop (add1 col))]
|
|
||||||
[(>= col 73)
|
|
||||||
;; need a soft newline first
|
|
||||||
(write-byte 61 out)
|
|
||||||
(display newline-string out)
|
|
||||||
;; now the octect
|
|
||||||
(write-hex-bytes i out)
|
|
||||||
(loop 3)]
|
|
||||||
[else
|
|
||||||
;; an octect
|
|
||||||
(write-hex-bytes i out)
|
|
||||||
(loop (+ col 3))]))))))
|
|
||||||
|
|
||||||
;; Tables
|
|
||||||
(define hex-values (make-vector 256 #f))
|
|
||||||
(define hex-bytes (make-vector 16))
|
|
||||||
(let loop ([i 0])
|
|
||||||
(unless (= i 10)
|
|
||||||
(vector-set! hex-values (+ i 48) i)
|
|
||||||
(vector-set! hex-bytes i (+ i 48))
|
|
||||||
(loop (add1 i))))
|
|
||||||
(let loop ([i 0])
|
|
||||||
(unless (= i 6)
|
|
||||||
(vector-set! hex-values (+ i 65) (+ 10 i))
|
|
||||||
(vector-set! hex-values (+ i 97) (+ 10 i))
|
|
||||||
(vector-set! hex-bytes (+ 10 i) (+ i 65))
|
|
||||||
(loop (add1 i))))
|
|
||||||
|
|
||||||
;;; qp-unit.ss ends here
|
;;; qp-unit.ss ends here
|
||||||
|
|
|
||||||
|
|
@ -26,11 +26,11 @@
|
||||||
;;
|
;;
|
||||||
;; Commentary:
|
;; Commentary:
|
||||||
|
|
||||||
(module qp mzscheme
|
#lang scheme/base
|
||||||
(require mzlib/unit "qp-sig.ss" "qp-unit.ss")
|
(require mzlib/unit "qp-sig.ss" "qp-unit.ss")
|
||||||
|
|
||||||
(define-values/invoke-unit/infer qp@)
|
(define-values/invoke-unit/infer qp@)
|
||||||
|
|
||||||
(provide-signature-elements qp^))
|
(provide-signature-elements qp^)
|
||||||
|
|
||||||
;;; qp.ss ends here
|
;;; qp.ss ends here
|
||||||
|
|
|
||||||
|
|
@ -1,119 +1,119 @@
|
||||||
#lang scheme/unit
|
#lang scheme/unit
|
||||||
|
|
||||||
(require mzlib/process "sendmail-sig.ss")
|
(require mzlib/process "sendmail-sig.ss")
|
||||||
|
|
||||||
(import)
|
(import)
|
||||||
(export sendmail^)
|
(export sendmail^)
|
||||||
|
|
||||||
(define-struct (no-mail-recipients exn) ())
|
(define-struct (no-mail-recipients exn) ())
|
||||||
|
|
||||||
(define sendmail-search-path
|
(define sendmail-search-path
|
||||||
'("/usr/lib" "/usr/sbin"))
|
'("/usr/lib" "/usr/sbin"))
|
||||||
|
|
||||||
(define sendmail-program-file
|
(define sendmail-program-file
|
||||||
(if (or (eq? (system-type) 'unix)
|
(if (or (eq? (system-type) 'unix)
|
||||||
(eq? (system-type) 'macosx))
|
(eq? (system-type) 'macosx))
|
||||||
(let loop ([paths sendmail-search-path])
|
(let loop ([paths sendmail-search-path])
|
||||||
(if (null? paths)
|
(if (null? paths)
|
||||||
(raise (make-exn:fail:unsupported
|
(raise (make-exn:fail:unsupported
|
||||||
"unable to find sendmail on this Unix variant"
|
"unable to find sendmail on this Unix variant"
|
||||||
(current-continuation-marks)))
|
(current-continuation-marks)))
|
||||||
(let ([p (build-path (car paths) "sendmail")])
|
(let ([p (build-path (car paths) "sendmail")])
|
||||||
(if (and (file-exists? p)
|
(if (and (file-exists? p)
|
||||||
(memq 'execute (file-or-directory-permissions p)))
|
(memq 'execute (file-or-directory-permissions p)))
|
||||||
p
|
p
|
||||||
(loop (cdr paths))))))
|
(loop (cdr paths))))))
|
||||||
(raise (make-exn:fail:unsupported
|
(raise (make-exn:fail:unsupported
|
||||||
"sendmail only available under Unix"
|
"sendmail only available under Unix"
|
||||||
(current-continuation-marks)))))
|
(current-continuation-marks)))))
|
||||||
|
|
||||||
;; send-mail-message/port :
|
;; send-mail-message/port :
|
||||||
;; string x string x list (string) x list (string) x list (string)
|
;; string x string x list (string) x list (string) x list (string)
|
||||||
;; [x list (string)] -> oport
|
;; [x list (string)] -> oport
|
||||||
|
|
||||||
;; -- sender can be anything, though spoofing is not recommended.
|
;; -- sender can be anything, though spoofing is not recommended.
|
||||||
;; The recipients must all be pure email addresses. Note that
|
;; The recipients must all be pure email addresses. Note that
|
||||||
;; everything is expected to follow RFC conventions. If any other
|
;; everything is expected to follow RFC conventions. If any other
|
||||||
;; headers are specified, they are expected to be completely
|
;; headers are specified, they are expected to be completely
|
||||||
;; formatted already. Clients are urged to use close-output-port on
|
;; formatted already. Clients are urged to use close-output-port on
|
||||||
;; the port returned by this procedure as soon as the necessary text
|
;; the port returned by this procedure as soon as the necessary text
|
||||||
;; has been written, so that the sendmail process can complete.
|
;; has been written, so that the sendmail process can complete.
|
||||||
|
|
||||||
(define send-mail-message/port
|
(define (send-mail-message/port
|
||||||
(lambda (sender subject to-recipients cc-recipients bcc-recipients
|
sender subject to-recipients cc-recipients bcc-recipients
|
||||||
. other-headers)
|
. other-headers)
|
||||||
(when (and (null? to-recipients) (null? cc-recipients)
|
(when (and (null? to-recipients) (null? cc-recipients)
|
||||||
(null? bcc-recipients))
|
(null? bcc-recipients))
|
||||||
(raise (make-no-mail-recipients
|
(raise (make-no-mail-recipients
|
||||||
"no mail recipients were specified"
|
"no mail recipients were specified"
|
||||||
(current-continuation-marks))))
|
(current-continuation-marks))))
|
||||||
(let ([return (apply process* sendmail-program-file "-i"
|
(let ([return (apply process* sendmail-program-file "-i"
|
||||||
(append to-recipients cc-recipients bcc-recipients))])
|
(append to-recipients cc-recipients bcc-recipients))])
|
||||||
(let ([reader (car return)]
|
(let ([reader (car return)]
|
||||||
[writer (cadr return)]
|
[writer (cadr return)]
|
||||||
[pid (caddr return)]
|
[pid (caddr return)]
|
||||||
[error-reader (cadddr return)])
|
[error-reader (cadddr return)])
|
||||||
(close-input-port reader)
|
(close-input-port reader)
|
||||||
(close-input-port error-reader)
|
(close-input-port error-reader)
|
||||||
(fprintf writer "From: ~a\n" sender)
|
(fprintf writer "From: ~a\n" sender)
|
||||||
(letrec ([write-recipient-header
|
(letrec ([write-recipient-header
|
||||||
(lambda (header-string recipients)
|
(lambda (header-string recipients)
|
||||||
(let ([header-space
|
(let ([header-space
|
||||||
(+ (string-length header-string) 2)])
|
(+ (string-length header-string) 2)])
|
||||||
(fprintf writer "~a: " header-string)
|
(fprintf writer "~a: " header-string)
|
||||||
(let loop ([to recipients] [indent header-space])
|
(let loop ([to recipients] [indent header-space])
|
||||||
(if (null? to)
|
(if (null? to)
|
||||||
(newline writer)
|
(newline writer)
|
||||||
(let ([first (car to)]
|
(let ([first (car to)]
|
||||||
[rest (cdr to)])
|
[rest (cdr to)])
|
||||||
(let ([len (string-length first)])
|
(let ([len (string-length first)])
|
||||||
(if (>= (+ len indent) 80)
|
(if (>= (+ len indent) 80)
|
||||||
(begin
|
(begin
|
||||||
(fprintf writer
|
(fprintf writer
|
||||||
(if (null? rest)
|
(if (null? rest)
|
||||||
"\n ~a"
|
"\n ~a"
|
||||||
"\n ~a, ")
|
"\n ~a, ")
|
||||||
first)
|
first)
|
||||||
(loop (cdr to)
|
(loop (cdr to)
|
||||||
(+ len header-space 2)))
|
(+ len header-space 2)))
|
||||||
(begin
|
(begin
|
||||||
(fprintf writer
|
(fprintf writer
|
||||||
(if (null? rest)
|
(if (null? rest)
|
||||||
"~a "
|
"~a "
|
||||||
"~a, ")
|
"~a, ")
|
||||||
first)
|
first)
|
||||||
(loop (cdr to)
|
(loop (cdr to)
|
||||||
(+ len indent 2))))))))))])
|
(+ len indent 2))))))))))])
|
||||||
(write-recipient-header "To" to-recipients)
|
(write-recipient-header "To" to-recipients)
|
||||||
(unless (null? cc-recipients)
|
(unless (null? cc-recipients)
|
||||||
(write-recipient-header "CC" cc-recipients)))
|
(write-recipient-header "CC" cc-recipients)))
|
||||||
(fprintf writer "Subject: ~a\n" subject)
|
(fprintf writer "Subject: ~a\n" subject)
|
||||||
(fprintf writer "X-Mailer: MzScheme: see www.plt-scheme.org\n")
|
(fprintf writer "X-Mailer: MzScheme: see www.plt-scheme.org\n")
|
||||||
(for-each (lambda (s)
|
(for-each (lambda (s)
|
||||||
(display s writer)
|
(display s writer)
|
||||||
(newline writer))
|
(newline writer))
|
||||||
other-headers)
|
other-headers)
|
||||||
(newline writer)
|
(newline writer)
|
||||||
writer))))
|
writer)))
|
||||||
|
|
||||||
;; send-mail-message :
|
;; send-mail-message :
|
||||||
;; string x string x list (string) x list (string) x list (string) x
|
;; string x string x list (string) x list (string) x list (string) x
|
||||||
;; list (string) [x list (string)] -> ()
|
;; list (string) [x list (string)] -> ()
|
||||||
|
|
||||||
;; -- sender can be anything, though spoofing is not recommended. The
|
;; -- sender can be anything, though spoofing is not recommended. The
|
||||||
;; recipients must all be pure email addresses. The text is expected
|
;; recipients must all be pure email addresses. The text is expected
|
||||||
;; to be pre-formatted. Note that everything is expected to follow
|
;; to be pre-formatted. Note that everything is expected to follow
|
||||||
;; RFC conventions. If any other headers are specified, they are
|
;; RFC conventions. If any other headers are specified, they are
|
||||||
;; expected to be completely formatted already.
|
;; expected to be completely formatted already.
|
||||||
|
|
||||||
(define send-mail-message
|
(define (send-mail-message
|
||||||
(lambda (sender subject to-recipients cc-recipients bcc-recipients text
|
sender subject to-recipients cc-recipients bcc-recipients text
|
||||||
. other-headers)
|
. other-headers)
|
||||||
(let ([writer (apply send-mail-message/port sender subject
|
(let ([writer (apply send-mail-message/port sender subject
|
||||||
to-recipients cc-recipients bcc-recipients
|
to-recipients cc-recipients bcc-recipients
|
||||||
other-headers)])
|
other-headers)])
|
||||||
(for-each (lambda (s)
|
(for-each (lambda (s)
|
||||||
(display s writer) ; We use -i, so "." is not a problem
|
(display s writer) ; We use -i, so "." is not a problem
|
||||||
(newline writer))
|
(newline writer))
|
||||||
text)
|
text)
|
||||||
(close-output-port writer))))
|
(close-output-port writer)))
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
(module sendmail mzscheme
|
#lang scheme/base
|
||||||
(require mzlib/unit "sendmail-sig.ss" "sendmail-unit.ss")
|
(require scheme/unit "sendmail-sig.ss" "sendmail-unit.ss")
|
||||||
|
|
||||||
(define-values/invoke-unit/infer sendmail@)
|
(define-values/invoke-unit/infer sendmail@)
|
||||||
|
|
||||||
(provide-signature-elements sendmail^))
|
(provide-signature-elements sendmail^)
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
(module smtp mzscheme
|
#lang scheme/base
|
||||||
(require mzlib/unit "smtp-sig.ss" "smtp-unit.ss")
|
(require scheme/unit "smtp-sig.ss" "smtp-unit.ss")
|
||||||
|
|
||||||
(define-values/invoke-unit/infer smtp@)
|
(define-values/invoke-unit/infer smtp@)
|
||||||
|
|
||||||
(provide-signature-elements smtp^))
|
(provide-signature-elements smtp^)
|
||||||
|
|
|
||||||
|
|
@ -1,63 +1,59 @@
|
||||||
(module ssl-tcp-unit mzscheme
|
#lang scheme/base
|
||||||
(provide make-ssl-tcp@)
|
(provide make-ssl-tcp@)
|
||||||
(require mzlib/unit
|
(require scheme/unit
|
||||||
"tcp-sig.ss"
|
"tcp-sig.ss"
|
||||||
(lib "mzssl.ss" "openssl")
|
openssl/mzssl)
|
||||||
mzlib/etc)
|
|
||||||
|
|
||||||
(define (make-ssl-tcp@
|
(define (make-ssl-tcp@
|
||||||
server-cert-file server-key-file server-root-cert-files server-suggest-auth-file
|
server-cert-file server-key-file server-root-cert-files server-suggest-auth-file
|
||||||
client-cert-file client-key-file client-root-cert-files)
|
client-cert-file client-key-file client-root-cert-files)
|
||||||
(unit
|
(unit
|
||||||
(import)
|
(import)
|
||||||
(export tcp^)
|
(export tcp^)
|
||||||
|
|
||||||
(define ctx (ssl-make-client-context))
|
(define ctx (ssl-make-client-context))
|
||||||
(when client-cert-file
|
(when client-cert-file
|
||||||
(ssl-load-certificate-chain! ctx client-cert-file))
|
(ssl-load-certificate-chain! ctx client-cert-file))
|
||||||
(when client-key-file
|
(when client-key-file
|
||||||
(ssl-load-private-key! ctx client-key-file))
|
(ssl-load-private-key! ctx client-key-file))
|
||||||
(when client-root-cert-files
|
(when client-root-cert-files
|
||||||
(ssl-set-verify! ctx #t)
|
(ssl-set-verify! ctx #t)
|
||||||
(map (lambda (f)
|
(map (lambda (f)
|
||||||
(ssl-load-verify-root-certificates! ctx f))
|
(ssl-load-verify-root-certificates! ctx f))
|
||||||
client-root-cert-files))
|
client-root-cert-files))
|
||||||
|
|
||||||
(define (tcp-abandon-port p)
|
(define (tcp-abandon-port p)
|
||||||
(if (input-port? p)
|
(if (input-port? p)
|
||||||
(close-input-port p)
|
(close-input-port p)
|
||||||
(close-output-port p)))
|
(close-output-port p)))
|
||||||
|
|
||||||
(define tcp-accept ssl-accept)
|
(define tcp-accept ssl-accept)
|
||||||
(define tcp-accept/enable-break ssl-accept/enable-break)
|
(define tcp-accept/enable-break ssl-accept/enable-break)
|
||||||
|
|
||||||
;; accept-ready? doesn't really work for SSL:
|
;; accept-ready? doesn't really work for SSL:
|
||||||
(define (tcp-accept-ready? p)
|
(define (tcp-accept-ready? p)
|
||||||
#f)
|
#f)
|
||||||
|
|
||||||
(define tcp-addresses ssl-addresses)
|
(define tcp-addresses ssl-addresses)
|
||||||
(define tcp-close ssl-close)
|
(define tcp-close ssl-close)
|
||||||
(define tcp-connect
|
(define (tcp-connect hostname port-k)
|
||||||
(opt-lambda (hostname port-k)
|
(ssl-connect hostname port-k ctx))
|
||||||
(ssl-connect hostname port-k ctx)))
|
(define (tcp-connect/enable-break hostname port-k)
|
||||||
(define tcp-connect/enable-break
|
(ssl-connect/enable-break hostname port-k ctx))
|
||||||
(opt-lambda (hostname port-k)
|
|
||||||
(ssl-connect/enable-break hostname port-k ctx)))
|
|
||||||
|
|
||||||
(define tcp-listen
|
(define (tcp-listen port [allow-k 4] [reuse? #f] [hostname #f])
|
||||||
(opt-lambda (port [allow-k 4] [reuse? #f] [hostname #f])
|
(let ([l (ssl-listen port allow-k reuse? hostname)])
|
||||||
(let ([l (ssl-listen port allow-k reuse? hostname)])
|
(when server-cert-file
|
||||||
(when server-cert-file
|
(ssl-load-certificate-chain! l server-cert-file))
|
||||||
(ssl-load-certificate-chain! l server-cert-file))
|
(when server-key-file
|
||||||
(when server-key-file
|
(ssl-load-private-key! l server-key-file))
|
||||||
(ssl-load-private-key! l server-key-file))
|
(when server-root-cert-files
|
||||||
(when server-root-cert-files
|
(ssl-set-verify! l #t)
|
||||||
(ssl-set-verify! l #t)
|
(map (lambda (f)
|
||||||
(map (lambda (f)
|
(ssl-load-verify-root-certificates! l f))
|
||||||
(ssl-load-verify-root-certificates! l f))
|
server-root-cert-files))
|
||||||
server-root-cert-files))
|
(when server-suggest-auth-file
|
||||||
(when server-suggest-auth-file
|
(ssl-load-suggested-certificate-authorities! l server-suggest-auth-file))
|
||||||
(ssl-load-suggested-certificate-authorities! l server-suggest-auth-file))
|
l))
|
||||||
l)))
|
|
||||||
|
|
||||||
(define tcp-listener? ssl-listener?))))
|
(define tcp-listener? ssl-listener?)))
|
||||||
|
|
|
||||||
|
|
@ -1,138 +1,133 @@
|
||||||
(module tcp-redirect mzscheme
|
#lang scheme/base
|
||||||
(provide tcp-redirect)
|
(provide tcp-redirect)
|
||||||
|
|
||||||
(require mzlib/unit
|
(require scheme/unit
|
||||||
mzlib/async-channel
|
scheme/tcp
|
||||||
mzlib/etc
|
scheme/async-channel
|
||||||
"tcp-sig.ss")
|
"tcp-sig.ss")
|
||||||
|
|
||||||
(define raw:tcp-abandon-port tcp-abandon-port)
|
(define raw:tcp-abandon-port tcp-abandon-port)
|
||||||
(define raw:tcp-accept tcp-accept)
|
(define raw:tcp-accept tcp-accept)
|
||||||
(define raw:tcp-accept/enable-break tcp-accept/enable-break)
|
(define raw:tcp-accept/enable-break tcp-accept/enable-break)
|
||||||
(define raw:tcp-accept-ready? tcp-accept-ready?)
|
(define raw:tcp-accept-ready? tcp-accept-ready?)
|
||||||
(define raw:tcp-addresses tcp-addresses)
|
(define raw:tcp-addresses tcp-addresses)
|
||||||
(define raw:tcp-close tcp-close)
|
(define raw:tcp-close tcp-close)
|
||||||
(define raw:tcp-connect tcp-connect)
|
(define raw:tcp-connect tcp-connect)
|
||||||
(define raw:tcp-connect/enable-break tcp-connect/enable-break)
|
(define raw:tcp-connect/enable-break tcp-connect/enable-break)
|
||||||
(define raw:tcp-listen tcp-listen)
|
(define raw:tcp-listen tcp-listen)
|
||||||
(define raw:tcp-listener? tcp-listener?)
|
(define raw:tcp-listener? tcp-listener?)
|
||||||
|
|
||||||
; For tcp-listeners, we use an else branch in the conds since
|
;; For tcp-listeners, we use an else branch in the conds since
|
||||||
; (instead of a contract) I want the same error message as the raw
|
;; (instead of a contract) I want the same error message as the raw
|
||||||
; primitive for bad inputs.
|
;; primitive for bad inputs.
|
||||||
|
|
||||||
; : (listof nat) -> (unit/sig () -> net:tcp^)
|
;; : (listof nat) -> (unit/sig () -> net:tcp^)
|
||||||
(define tcp-redirect
|
(define (tcp-redirect redirected-ports [redirected-address "127.0.0.1"])
|
||||||
(opt-lambda (redirected-ports [redirected-address "127.0.0.1"])
|
(unit
|
||||||
(unit
|
(import)
|
||||||
(import)
|
(export tcp^)
|
||||||
(export tcp^)
|
;; : (make-pipe-listener nat (channel (cons iport oport)))
|
||||||
; : (make-pipe-listener nat (channel (cons iport oport)))
|
(define-struct pipe-listener (port channel))
|
||||||
(define-struct pipe-listener (port channel))
|
|
||||||
|
|
||||||
; : port -> void
|
;; : port -> void
|
||||||
(define (tcp-abandon-port tcp-port)
|
(define (tcp-abandon-port tcp-port)
|
||||||
(when (tcp-port? tcp-port)
|
(when (tcp-port? tcp-port)
|
||||||
(raw:tcp-abandon-port tcp-port)))
|
(raw:tcp-abandon-port tcp-port)))
|
||||||
|
|
||||||
; : listener -> iport oport
|
;; : listener -> iport oport
|
||||||
(define (tcp-accept tcp-listener)
|
(define (tcp-accept tcp-listener)
|
||||||
(cond
|
(cond
|
||||||
[(pipe-listener? tcp-listener)
|
[(pipe-listener? tcp-listener)
|
||||||
(let ([in-out (async-channel-get (pipe-listener-channel tcp-listener))])
|
(let ([in-out (async-channel-get (pipe-listener-channel tcp-listener))])
|
||||||
(values (car in-out) (cdr in-out)))]
|
(values (car in-out) (cdr in-out)))]
|
||||||
[else (raw:tcp-accept tcp-listener)]))
|
[else (raw:tcp-accept tcp-listener)]))
|
||||||
|
|
||||||
; : listener -> iport oport
|
;; : listener -> iport oport
|
||||||
(define (tcp-accept/enable-break tcp-listener)
|
(define (tcp-accept/enable-break tcp-listener)
|
||||||
(cond
|
(cond
|
||||||
[(pipe-listener? tcp-listener)
|
[(pipe-listener? tcp-listener)
|
||||||
; XXX put this into async-channel.ss as async-channel-get/enable-break
|
;; XXX put this into async-channel.ss as async-channel-get/enable-break
|
||||||
(sync/enable-break
|
(sync/enable-break
|
||||||
(handle-evt
|
(handle-evt
|
||||||
(pipe-listener-channel tcp-listener)
|
(pipe-listener-channel tcp-listener)
|
||||||
(lambda (in-out)
|
(lambda (in-out)
|
||||||
(values (car in-out) (cdr in-out)))))]
|
(values (car in-out) (cdr in-out)))))]
|
||||||
#;(let ([in-out (async-channel-get (pipe-listener-channel tcp-listener))])
|
#;(let ([in-out (async-channel-get (pipe-listener-channel tcp-listener))])
|
||||||
(values (car in-out) (cdr in-out)))
|
(values (car in-out) (cdr in-out)))
|
||||||
[else (raw:tcp-accept/enable-break tcp-listener)]))
|
[else (raw:tcp-accept/enable-break tcp-listener)]))
|
||||||
|
|
||||||
; : tcp-listener -> iport oport
|
;; : tcp-listener -> iport oport
|
||||||
; FIX - check channel queue size
|
;; FIX - check channel queue size
|
||||||
(define (tcp-accept-ready? tcp-listener)
|
(define (tcp-accept-ready? tcp-listener)
|
||||||
(cond
|
(cond
|
||||||
[(pipe-listener? tcp-listener) #t]
|
[(pipe-listener? tcp-listener) #t]
|
||||||
[else (raw:tcp-accept-ready? tcp-listener)]))
|
[else (raw:tcp-accept-ready? tcp-listener)]))
|
||||||
|
|
||||||
; : tcp-port -> str str
|
;; : tcp-port -> str str
|
||||||
(define (tcp-addresses tcp-port)
|
(define (tcp-addresses tcp-port)
|
||||||
(if (tcp-port? tcp-port)
|
(if (tcp-port? tcp-port)
|
||||||
(raw:tcp-addresses tcp-port)
|
(raw:tcp-addresses tcp-port)
|
||||||
(values redirected-address redirected-address)))
|
(values redirected-address redirected-address)))
|
||||||
|
|
||||||
; : port -> void
|
;; : port -> void
|
||||||
(define (tcp-close tcp-listener)
|
(define (tcp-close tcp-listener)
|
||||||
(if (tcp-listener? tcp-listener)
|
(if (tcp-listener? tcp-listener)
|
||||||
(raw:tcp-close tcp-listener)
|
(raw:tcp-close tcp-listener)
|
||||||
(hash-table-remove!
|
(hash-remove! port-table (pipe-listener-port tcp-listener))))
|
||||||
port-table
|
|
||||||
(pipe-listener-port tcp-listener))))
|
|
||||||
|
|
||||||
; : (str nat -> iport oport) -> str nat -> iport oport
|
;; : (str nat -> iport oport) -> str nat -> iport oport
|
||||||
(define (gen-tcp-connect raw)
|
(define (gen-tcp-connect raw)
|
||||||
(lambda (hostname-string port)
|
(lambda (hostname-string port)
|
||||||
(if (and (string=? redirected-address hostname-string)
|
(if (and (string=? redirected-address hostname-string)
|
||||||
(redirect? port))
|
(redirect? port))
|
||||||
(let-values ([(to-in from-out) (make-pipe)]
|
(let-values ([(to-in from-out) (make-pipe)]
|
||||||
[(from-in to-out) (make-pipe)])
|
[(from-in to-out) (make-pipe)])
|
||||||
(async-channel-put
|
(async-channel-put
|
||||||
(pipe-listener-channel
|
(pipe-listener-channel
|
||||||
(hash-table-get
|
(hash-ref port-table port
|
||||||
port-table
|
(lambda ()
|
||||||
port
|
(raise (make-exn:fail:network
|
||||||
(lambda ()
|
(format "tcp-connect: connection to ~a, port ~a failed (nobody is listening)"
|
||||||
(raise (make-exn:fail:network
|
hostname-string port)
|
||||||
(format "tcp-connect: connection to ~a, port ~a failed (nobody is listening)"
|
(current-continuation-marks))))))
|
||||||
hostname-string port)
|
(cons to-in to-out))
|
||||||
(current-continuation-marks))))))
|
(values from-in from-out))
|
||||||
(cons to-in to-out))
|
(raw hostname-string port))))
|
||||||
(values from-in from-out))
|
|
||||||
(raw hostname-string port))))
|
|
||||||
|
|
||||||
; : str nat -> iport oport
|
;; : str nat -> iport oport
|
||||||
(define tcp-connect (gen-tcp-connect raw:tcp-connect))
|
(define tcp-connect (gen-tcp-connect raw:tcp-connect))
|
||||||
|
|
||||||
; : str nat -> iport oport
|
;; : str nat -> iport oport
|
||||||
(define tcp-connect/enable-break (gen-tcp-connect raw:tcp-connect/enable-break))
|
(define tcp-connect/enable-break
|
||||||
|
(gen-tcp-connect raw:tcp-connect/enable-break))
|
||||||
|
|
||||||
; FIX - support the reuse? flag.
|
;; FIX - support the reuse? flag.
|
||||||
(define tcp-listen
|
(define (tcp-listen port [max-allow-wait 4] [reuse? #f] [hostname-string #f])
|
||||||
(opt-lambda (port [max-allow-wait 4] [reuse? #f] [hostname-string #f])
|
(hash-ref port-table port
|
||||||
(hash-table-get
|
(lambda ()
|
||||||
port-table
|
(if (redirect? port)
|
||||||
port
|
(let ([listener (make-pipe-listener port (make-async-channel))])
|
||||||
(lambda ()
|
(hash-set! port-table port listener)
|
||||||
(if (redirect? port)
|
listener)
|
||||||
(let ([listener (make-pipe-listener port (make-async-channel))])
|
(raw:tcp-listen port max-allow-wait reuse? hostname-string)))))
|
||||||
(hash-table-put! port-table port listener)
|
|
||||||
listener)
|
|
||||||
(raw:tcp-listen port max-allow-wait reuse? hostname-string))))))
|
|
||||||
|
|
||||||
; : tst -> bool
|
;; : tst -> bool
|
||||||
(define (tcp-listener? x)
|
(define (tcp-listener? x)
|
||||||
(or (pipe-listener? x) (raw:tcp-listener? x)))
|
(or (pipe-listener? x) (raw:tcp-listener? x)))
|
||||||
|
|
||||||
; ---------- private ----------
|
;; ---------- private ----------
|
||||||
|
|
||||||
; : (hash-table nat[port] -> tcp-listener)
|
;; : (hash nat[port] -> tcp-listener)
|
||||||
(define port-table (make-hash-table))
|
(define port-table (make-hasheq))
|
||||||
|
|
||||||
(define redirect-table
|
(define redirect-table
|
||||||
(let ([table (make-hash-table)])
|
(let ([table (make-hasheq)])
|
||||||
(for-each (lambda (x) (hash-table-put! table x #t))
|
(for-each (lambda (x) (hash-set! table x #t))
|
||||||
redirected-ports)
|
redirected-ports)
|
||||||
table))
|
table))
|
||||||
|
|
||||||
; : nat -> bool
|
;; : nat -> bool
|
||||||
(define (redirect? port)
|
(define (redirect? port)
|
||||||
(hash-table-get redirect-table port (lambda () #f)))))))
|
(hash-ref redirect-table port #f))
|
||||||
|
|
||||||
|
))
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
(module tcp-unit mzscheme
|
#lang scheme/base
|
||||||
(provide tcp@)
|
(provide tcp@)
|
||||||
|
|
||||||
(require mzlib/unit "tcp-sig.ss")
|
(require scheme/unit scheme/tcp "tcp-sig.ss")
|
||||||
|
|
||||||
(define-unit-from-context tcp@ tcp^))
|
(define-unit-from-context tcp@ tcp^)
|
||||||
|
|
|
||||||
|
|
@ -1,118 +1,118 @@
|
||||||
(module unihead mzscheme
|
#lang mzscheme
|
||||||
(require net/base64
|
(require net/base64
|
||||||
net/qp
|
net/qp
|
||||||
mzlib/string)
|
mzlib/string)
|
||||||
|
|
||||||
(provide encode-for-header
|
(provide encode-for-header
|
||||||
decode-for-header
|
decode-for-header
|
||||||
generalize-encoding)
|
generalize-encoding)
|
||||||
|
|
||||||
(define re:ascii #rx"^[\u0-\u7F]*$")
|
(define re:ascii #rx"^[\u0-\u7F]*$")
|
||||||
|
|
||||||
(define (encode-for-header s)
|
(define (encode-for-header s)
|
||||||
(if (regexp-match? re:ascii s)
|
(if (regexp-match? re:ascii s)
|
||||||
s
|
s
|
||||||
(let ([l (regexp-split #rx"\r\n" s)])
|
(let ([l (regexp-split #rx"\r\n" s)])
|
||||||
(apply string-append
|
(apply string-append
|
||||||
(map encode-line-for-header l)))))
|
(map encode-line-for-header l)))))
|
||||||
|
|
||||||
(define (encode-line-for-header s)
|
(define (encode-line-for-header s)
|
||||||
(define (loop s string->bytes charset encode encoding)
|
(define (loop s string->bytes charset encode encoding)
|
||||||
;; Find ASCII (and no "=") prefix before a space
|
;; Find ASCII (and no "=") prefix before a space
|
||||||
(let ([m (regexp-match #rx"^([\u0-\u3c\u3e-\u7F]* )(.*)$" s)])
|
(let ([m (regexp-match #rx"^([\u0-\u3c\u3e-\u7F]* )(.*)$" s)])
|
||||||
(if m
|
(if m
|
||||||
(string-append
|
(string-append
|
||||||
(cadr m)
|
(cadr m)
|
||||||
(loop (caddr m) string->bytes charset encode encoding))
|
(loop (caddr m) string->bytes charset encode encoding))
|
||||||
;; Find ASCII (and no "=") suffix after a space
|
;; Find ASCII (and no "=") suffix after a space
|
||||||
(let ([m (regexp-match #rx"^(.*?)( [\u0-\u3c\u3e-\u7F]*)$" s)])
|
(let ([m (regexp-match #rx"^(.*?)( [\u0-\u3c\u3e-\u7F]*)$" s)])
|
||||||
(if m
|
(if m
|
||||||
(string-append
|
(string-append
|
||||||
(loop (cadr m) string->bytes charset encode encoding)
|
(loop (cadr m) string->bytes charset encode encoding)
|
||||||
(caddr m))
|
(caddr m))
|
||||||
(format "=?~a?~a?~a?="
|
(format "=?~a?~a?~a?="
|
||||||
charset encoding
|
charset encoding
|
||||||
(regexp-replace* #rx#"[\r\n]+$"
|
(regexp-replace* #rx#"[\r\n]+$"
|
||||||
(encode (string->bytes s))
|
(encode (string->bytes s))
|
||||||
#"")))))))
|
#"")))))))
|
||||||
(cond
|
(cond
|
||||||
[(regexp-match? re:ascii s)
|
[(regexp-match? re:ascii s)
|
||||||
;; ASCII - do nothing
|
;; ASCII - do nothing
|
||||||
s]
|
s]
|
||||||
[(regexp-match? #rx"[^\u0-\uFF]" s)
|
[(regexp-match? #rx"[^\u0-\uFF]" s)
|
||||||
;; Not Latin-1, so use UTF-8
|
;; Not Latin-1, so use UTF-8
|
||||||
(loop s string->bytes/utf-8 "UTF-8" base64-encode "B")]
|
(loop s string->bytes/utf-8 "UTF-8" base64-encode "B")]
|
||||||
[else
|
[else
|
||||||
;; use Latin-1
|
;; use Latin-1
|
||||||
(loop s string->bytes/latin-1 "ISO-8859-1"
|
(loop s string->bytes/latin-1 "ISO-8859-1"
|
||||||
(lambda (s)
|
(lambda (s)
|
||||||
(regexp-replace #rx#" " (qp-encode s) #"_"))
|
(regexp-replace #rx#" " (qp-encode s) #"_"))
|
||||||
"Q")]))
|
"Q")]))
|
||||||
|
|
||||||
;; ----------------------------------------
|
;; ----------------------------------------
|
||||||
|
|
||||||
(define re:us-ascii #rx#"^(?i:us-ascii)$")
|
(define re:us-ascii #rx#"^(?i:us-ascii)$")
|
||||||
(define re:iso #rx#"^(?i:iso-8859-1)$")
|
(define re:iso #rx#"^(?i:iso-8859-1)$")
|
||||||
(define re:gb #rx#"^(?i:gb(?:2312)?)$")
|
(define re:gb #rx#"^(?i:gb(?:2312)?)$")
|
||||||
(define re:ks_c #rx#"^(?i:ks_c_5601-1987)$")
|
(define re:ks_c #rx#"^(?i:ks_c_5601-1987)$")
|
||||||
(define re:utf-8 #rx#"^(?i:utf-8)$")
|
(define re:utf-8 #rx#"^(?i:utf-8)$")
|
||||||
|
|
||||||
(define re:encoded #rx#"^(.*?)=[?]([^?]+)[?]([qQbB])[?](.*?)[?]=(.*)$")
|
(define re:encoded #rx#"^(.*?)=[?]([^?]+)[?]([qQbB])[?](.*?)[?]=(.*)$")
|
||||||
|
|
||||||
(define (generalize-encoding encoding)
|
(define (generalize-encoding encoding)
|
||||||
;; Treat Latin-1 as Windows-1252 and also threat GB and GB2312
|
;; Treat Latin-1 as Windows-1252 and also threat GB and GB2312
|
||||||
;; as GBK, because some mailers are broken.
|
;; as GBK, because some mailers are broken.
|
||||||
(cond [(or (regexp-match? re:iso encoding)
|
(cond [(or (regexp-match? re:iso encoding)
|
||||||
(regexp-match? re:us-ascii encoding))
|
(regexp-match? re:us-ascii encoding))
|
||||||
(if (bytes? encoding) #"WINDOWS-1252" "WINDOWS-1252")]
|
(if (bytes? encoding) #"WINDOWS-1252" "WINDOWS-1252")]
|
||||||
[(regexp-match? re:gb encoding)
|
[(regexp-match? re:gb encoding)
|
||||||
(if (bytes? encoding) #"GBK" "GBK")]
|
(if (bytes? encoding) #"GBK" "GBK")]
|
||||||
[(regexp-match? re:ks_c encoding)
|
[(regexp-match? re:ks_c encoding)
|
||||||
(if (bytes? encoding) #"CP949" "CP949")]
|
(if (bytes? encoding) #"CP949" "CP949")]
|
||||||
[else encoding]))
|
[else encoding]))
|
||||||
|
|
||||||
(define (decode-for-header s)
|
(define (decode-for-header s)
|
||||||
(and s
|
(and s
|
||||||
(let ([m (regexp-match re:encoded
|
(let ([m (regexp-match re:encoded
|
||||||
(string->bytes/latin-1 s (char->integer #\?)))])
|
(string->bytes/latin-1 s (char->integer #\?)))])
|
||||||
(if m
|
(if m
|
||||||
(let ([s ((if (member (cadddr m) '(#"q" #"Q"))
|
(let ([s ((if (member (cadddr m) '(#"q" #"Q"))
|
||||||
;; quoted-printable, with special _ handling
|
;; quoted-printable, with special _ handling
|
||||||
(lambda (x)
|
(lambda (x)
|
||||||
(qp-decode (regexp-replace* #rx#"_" x #" ")))
|
(qp-decode (regexp-replace* #rx#"_" x #" ")))
|
||||||
;; base64:
|
;; base64:
|
||||||
base64-decode)
|
base64-decode)
|
||||||
(cadddr (cdr m)))]
|
(cadddr (cdr m)))]
|
||||||
[encoding (caddr m)])
|
[encoding (caddr m)])
|
||||||
(string-append
|
(string-append
|
||||||
(decode-for-header (bytes->string/latin-1 (cadr m)))
|
(decode-for-header (bytes->string/latin-1 (cadr m)))
|
||||||
(let ([encoding (generalize-encoding encoding)])
|
(let ([encoding (generalize-encoding encoding)])
|
||||||
(cond
|
(cond
|
||||||
[(regexp-match? re:utf-8 encoding)
|
[(regexp-match? re:utf-8 encoding)
|
||||||
(bytes->string/utf-8 s #\?)]
|
(bytes->string/utf-8 s #\?)]
|
||||||
[else (let ([c (bytes-open-converter
|
[else (let ([c (bytes-open-converter
|
||||||
(bytes->string/latin-1 encoding)
|
(bytes->string/latin-1 encoding)
|
||||||
"UTF-8")])
|
"UTF-8")])
|
||||||
(if c
|
(if c
|
||||||
(let-values ([(r got status)
|
(let-values ([(r got status)
|
||||||
(bytes-convert c s)])
|
(bytes-convert c s)])
|
||||||
(bytes-close-converter c)
|
(bytes-close-converter c)
|
||||||
(if (eq? status 'complete)
|
(if (eq? status 'complete)
|
||||||
(bytes->string/utf-8 r #\?)
|
(bytes->string/utf-8 r #\?)
|
||||||
(bytes->string/latin-1 s)))
|
(bytes->string/latin-1 s)))
|
||||||
(bytes->string/latin-1 s)))]))
|
(bytes->string/latin-1 s)))]))
|
||||||
(let ([rest (cadddr (cddr m))])
|
(let ([rest (cadddr (cddr m))])
|
||||||
(let ([rest
|
(let ([rest
|
||||||
;; A CR-LF-space-encoding sequence means that we
|
;; A CR-LF-space-encoding sequence means that we
|
||||||
;; should drop the space.
|
;; should drop the space.
|
||||||
(if (and (> (bytes-length rest) 4)
|
(if (and (> (bytes-length rest) 4)
|
||||||
(= 13 (bytes-ref rest 0))
|
(= 13 (bytes-ref rest 0))
|
||||||
(= 10 (bytes-ref rest 1))
|
(= 10 (bytes-ref rest 1))
|
||||||
(= 32 (bytes-ref rest 2))
|
(= 32 (bytes-ref rest 2))
|
||||||
(let ([m (regexp-match-positions
|
(let ([m (regexp-match-positions
|
||||||
re:encoded rest)])
|
re:encoded rest)])
|
||||||
(and m (= (caaddr m) 5))))
|
(and m (= (caaddr m) 5))))
|
||||||
(subbytes rest 3)
|
(subbytes rest 3)
|
||||||
rest)])
|
rest)])
|
||||||
(decode-for-header (bytes->string/latin-1 rest))))))
|
(decode-for-header (bytes->string/latin-1 rest))))))
|
||||||
s)))))
|
s))))
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
(module uri-codec mzscheme
|
#lang scheme/base
|
||||||
(require mzlib/unit "uri-codec-sig.ss" "uri-codec-unit.ss")
|
(require mzlib/unit "uri-codec-sig.ss" "uri-codec-unit.ss")
|
||||||
|
|
||||||
(provide-signature-elements uri-codec^)
|
(provide-signature-elements uri-codec^)
|
||||||
|
|
||||||
(define-values/invoke-unit/infer uri-codec@))
|
(define-values/invoke-unit/infer uri-codec@)
|
||||||
|
|
|
||||||
|
|
@ -1,18 +1,20 @@
|
||||||
(module url-structs mzscheme
|
#lang scheme/base
|
||||||
(require mzlib/contract
|
(require scheme/contract
|
||||||
mzlib/serialize)
|
scheme/serialize)
|
||||||
|
|
||||||
(define-serializable-struct url (scheme user host port path-absolute? path query fragment))
|
(define-serializable-struct url
|
||||||
(define-serializable-struct path/param (path param))
|
(scheme user host port path-absolute? path query fragment)
|
||||||
|
#:mutable)
|
||||||
|
(define-serializable-struct path/param (path param))
|
||||||
|
|
||||||
(provide/contract
|
(provide/contract
|
||||||
(struct url ([scheme (or/c false/c string?)]
|
(struct url ([scheme (or/c false/c string?)]
|
||||||
[user (or/c false/c string?)]
|
[user (or/c false/c string?)]
|
||||||
[host (or/c false/c string?)]
|
[host (or/c false/c string?)]
|
||||||
[port (or/c false/c number?)]
|
[port (or/c false/c number?)]
|
||||||
[path-absolute? boolean?]
|
[path-absolute? boolean?]
|
||||||
[path (listof path/param?)]
|
[path (listof path/param?)]
|
||||||
[query (listof (cons/c symbol? (or/c string? false/c)))]
|
[query (listof (cons/c symbol? (or/c string? false/c)))]
|
||||||
[fragment (or/c false/c string?)]))
|
[fragment (or/c false/c string?)]))
|
||||||
(struct path/param ([path (or/c string? (symbols 'up 'same))]
|
(struct path/param ([path (or/c string? (symbols 'up 'same))]
|
||||||
[param (listof string?)]))))
|
[param (listof string?)])))
|
||||||
|
|
|
||||||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,63 +1,53 @@
|
||||||
(module url mzscheme
|
#lang scheme/base
|
||||||
(require mzlib/unit
|
(require scheme/unit
|
||||||
mzlib/contract
|
scheme/contract
|
||||||
"url-structs.ss"
|
(only-in mzlib/contract opt->)
|
||||||
"url-sig.ss"
|
"url-structs.ss"
|
||||||
"url-unit.ss"
|
"url-sig.ss"
|
||||||
"tcp-sig.ss"
|
"url-unit.ss"
|
||||||
"tcp-unit.ss")
|
"tcp-sig.ss"
|
||||||
|
"tcp-unit.ss")
|
||||||
|
|
||||||
(define-compound-unit/infer url+tcp@
|
(define-compound-unit/infer url+tcp@
|
||||||
(import) (export url^)
|
(import) (export url^)
|
||||||
(link tcp@ url@))
|
(link tcp@ url@))
|
||||||
|
|
||||||
(define-values/invoke-unit/infer url+tcp@)
|
(define-values/invoke-unit/infer url+tcp@)
|
||||||
|
|
||||||
(provide
|
(provide (struct-out url) (struct-out path/param))
|
||||||
(struct url (scheme
|
|
||||||
user
|
|
||||||
host
|
|
||||||
port
|
|
||||||
path-absolute?
|
|
||||||
path
|
|
||||||
query
|
|
||||||
fragment))
|
|
||||||
(struct path/param (path param)))
|
|
||||||
|
|
||||||
(provide/contract
|
(provide/contract
|
||||||
(string->url ((or/c bytes? string?) . -> . url?))
|
(string->url ((or/c bytes? string?) . -> . url?))
|
||||||
(path->url ((or/c path-string? path-for-some-system?) . -> . url?))
|
(path->url ((or/c path-string? path-for-some-system?) . -> . url?))
|
||||||
(url->string (url? . -> . string?))
|
(url->string (url? . -> . string?))
|
||||||
(url->path ((url?) ((one-of/c 'unix 'windows)) . opt-> . path-for-some-system?))
|
(url->path ((url?) ((one-of/c 'unix 'windows)) . opt-> . path-for-some-system?))
|
||||||
|
|
||||||
(get-pure-port (opt-> (url?) ((listof string?)) input-port?))
|
|
||||||
(get-impure-port (opt-> (url?) ((listof string?)) input-port?))
|
|
||||||
(post-pure-port (opt-> (url? (or/c false/c bytes?)) ((listof string?)) input-port?))
|
|
||||||
(post-impure-port (opt-> (url? bytes?) ((listof string?)) input-port?))
|
|
||||||
(head-pure-port (opt-> (url?) ((listof string?)) input-port?))
|
|
||||||
(head-impure-port (opt-> (url?) ((listof string?)) input-port?))
|
|
||||||
(delete-pure-port (opt-> (url?) ((listof string?)) input-port?))
|
|
||||||
(delete-impure-port (opt-> (url?) ((listof string?)) input-port?))
|
|
||||||
(put-pure-port (opt-> (url? (or/c false/c bytes?)) ((listof string?)) input-port?))
|
|
||||||
(put-impure-port (opt-> (url? bytes?) ((listof string?)) input-port?))
|
|
||||||
(display-pure-port (input-port? . -> . void?))
|
|
||||||
(purify-port (input-port? . -> . string?))
|
|
||||||
(netscape/string->url (string? . -> . url?))
|
|
||||||
(call/input-url (case->
|
|
||||||
(-> url?
|
|
||||||
(-> url? input-port?)
|
|
||||||
(-> input-port? any)
|
|
||||||
any)
|
|
||||||
(-> url?
|
|
||||||
(-> url? (listof string?) input-port?)
|
|
||||||
(-> input-port? any)
|
|
||||||
(listof string?)
|
|
||||||
any)))
|
|
||||||
(combine-url/relative (url? string? . -> . url?))
|
|
||||||
(url-exception? (any/c . -> . boolean?))
|
|
||||||
(current-proxy-servers
|
|
||||||
(parameter/c (or/c false/c (listof (list/c string? string? number?)))))
|
|
||||||
(file-url-path-convention-type
|
|
||||||
(parameter/c (one-of/c 'unix 'windows))))
|
|
||||||
)
|
|
||||||
|
|
||||||
|
(get-pure-port (opt-> (url?) ((listof string?)) input-port?))
|
||||||
|
(get-impure-port (opt-> (url?) ((listof string?)) input-port?))
|
||||||
|
(post-pure-port (opt-> (url? (or/c false/c bytes?)) ((listof string?)) input-port?))
|
||||||
|
(post-impure-port (opt-> (url? bytes?) ((listof string?)) input-port?))
|
||||||
|
(head-pure-port (opt-> (url?) ((listof string?)) input-port?))
|
||||||
|
(head-impure-port (opt-> (url?) ((listof string?)) input-port?))
|
||||||
|
(delete-pure-port (opt-> (url?) ((listof string?)) input-port?))
|
||||||
|
(delete-impure-port (opt-> (url?) ((listof string?)) input-port?))
|
||||||
|
(put-pure-port (opt-> (url? (or/c false/c bytes?)) ((listof string?)) input-port?))
|
||||||
|
(put-impure-port (opt-> (url? bytes?) ((listof string?)) input-port?))
|
||||||
|
(display-pure-port (input-port? . -> . void?))
|
||||||
|
(purify-port (input-port? . -> . string?))
|
||||||
|
(netscape/string->url (string? . -> . url?))
|
||||||
|
(call/input-url (case->
|
||||||
|
(-> url?
|
||||||
|
(-> url? input-port?)
|
||||||
|
(-> input-port? any)
|
||||||
|
any)
|
||||||
|
(-> url?
|
||||||
|
(-> url? (listof string?) input-port?)
|
||||||
|
(-> input-port? any)
|
||||||
|
(listof string?)
|
||||||
|
any)))
|
||||||
|
(combine-url/relative (url? string? . -> . url?))
|
||||||
|
(url-exception? (any/c . -> . boolean?))
|
||||||
|
(current-proxy-servers
|
||||||
|
(parameter/c (or/c false/c (listof (list/c string? string? number?)))))
|
||||||
|
(file-url-path-convention-type
|
||||||
|
(parameter/c (one-of/c 'unix 'windows))))
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user