suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

more formatting etc

Browse Source 
svn: r5048
This commit is contained in:
Eli Barzilay 2006-12-06 21:44:21 +00:00
parent f17f7bc479
commit 680c0f419a
5 changed files with 741 additions and 815 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -146,72 +146,67 @@
;; get-headers : input-port -> string ;; get-headers : input-port -> string
;; returns the header part of a message/part conforming to rfc822, and ;; returns the header part of a message/part conforming to rfc822, and
;; rfc2045. ;; rfc2045.
(define get-headers (define (get-headers in)
(lambda (in) (let loop ([headers ""] [ln (read-line in 'any)])
(let loop ([headers ""] [ln (read-line in 'any)]) (cond [(eof-object? ln)
(cond [(eof-object? ln) ;; (raise (make-unexpected-termination "eof reached! while parsing headers"))
;; (raise (make-unexpected-termination "eof reached! while parsing headers")) (warning "premature eof while parsing headers")
(warning "premature eof while parsing headers") headers]
headers] [(string=? ln "") headers]
[(string=? ln "") headers] [else
[else ;; Quoting rfc822:
;; Quoting rfc822: ;; " Headers occur before the message body and are
;; " Headers occur before the message body and are ;; terminated by a null line (i.e., two contiguous
;; terminated by a null line (i.e., two contiguous ;; CRLFs)."
;; CRLFs)." ;; That is: Two empty lines. But most MUAs seem to count
;; That is: Two empty lines. But most MUAs seem to count ;; the CRLF ending the last field (header) as the first
;; the CRLF ending the last field (header) as the first ;; CRLF of the null line.
;; CRLF of the null line. (loop (string-append headers ln CRLF)
(loop (string-append headers ln CRLF) (read-line in 'any))])))
(read-line in 'any))]))))
(define make-default-disposition (define (make-default-disposition)
(lambda () (make-disposition
(make-disposition 'inline ;; type
'inline ;; type "" ;; filename
"" ;; filename #f ;; creation
#f ;; creation #f ;; modification
#f ;; modification #f ;; read
#f ;; read #f ;; size
#f ;; size null ;; params
null ;; params ))
)))
(define make-default-entity (define (make-default-entity)
(lambda () (make-entity
(make-entity 'text ;; type
'text ;; type 'plain ;; subtype
'plain ;; subtype 'us-ascii ;; charset
'us-ascii ;; charset '7bit ;; encoding
'7bit ;; encoding (make-default-disposition) ;; disposition
(make-default-disposition) ;; disposition null ;; params
null ;; params "" ;; id
"" ;; id "" ;; description
"" ;; description null ;; other MIME fields (MIME-extension-fields)
null ;; other MIME fields (MIME-extension-fields) null ;; fields
null ;; fields null ;; parts
null ;; parts null ;; body
null ;; body ))
)))
(define make-default-message (define (make-default-message)
(lambda () (make-message 1.0 (make-default-entity) null))
(make-message 1.0 (make-default-entity) null)))
(define mime-decode (define (mime-decode entity input)
(lambda (entity input) (set-entity-body!
(set-entity-body! entity
entity (case (entity-encoding entity)
(case (entity-encoding entity) [(quoted-printable)
[(quoted-printable) (lambda (output)
(lambda (output) (qp-decode-stream input output))]
(qp-decode-stream input output))] [(base64)
[(base64) (lambda (output)
(lambda (output) (base64-decode-stream input output))]
(base64-decode-stream input output))] [else ;; 7bit, 8bit, binary
[else ;; 7bit, 8bit, binary (lambda (output)
(lambda (output) (copy-port input output))])))
(copy-port input output))]))))
(define mime-analyze (define mime-analyze
(opt-lambda (input (part #f)) (opt-lambda (input (part #f))
@ -245,11 +240,10 @@
;; return mime structure ;; return mime structure
msg))) msg)))
(define entity-boundary (define (entity-boundary entity)
(lambda (entity) (let* ([params (entity-params entity)]
(let* ([params (entity-params entity)] [ans (assoc "boundary" params)])
[ans (assoc "boundary" params)]) (and ans (cdr ans))))
(and ans (cdr ans)))))
;; ************************************************* ;; *************************************************
;; MIME Specific: rfc2045-2049, and rfc0822, rfc2183 ;; MIME Specific: rfc2045-2049, and rfc0822, rfc2183
@ -261,38 +255,37 @@
;; close-delimiter transport-padding ;; close-delimiter transport-padding
;; [CRLF epilogue] ;; [CRLF epilogue]
;; Returns a list of input ports, each one containing the correspongind part. ;; Returns a list of input ports, each one containing the correspongind part.
(define multipart-body (define (multipart-body input boundary)
(lambda (input boundary) (let* ([make-re (lambda (prefix)
(let* ([make-re (lambda (prefix) (regexp (string-append prefix "--" (regexp-quote boundary) "(--)?\r\n")))]
(regexp (string-append prefix "--" (regexp-quote boundary) "(--)?\r\n")))] [re (make-re "\r\n")])
[re (make-re "\r\n")]) (letrec ([eat-part (lambda ()
(letrec ([eat-part (lambda () (let-values ([(pin pout) (make-pipe)])
(let-values ([(pin pout) (make-pipe)]) (let ([m (regexp-match re input 0 #f pout)])
(let ([m (regexp-match re input 0 #f pout)]) (cond
(cond [(not m)
[(not m) (close-output-port pout)
(close-output-port pout) (values pin ;; part
(values pin ;; part #f ;; close-delimiter?
#f ;; close-delimiter? #t ;; eof reached?
#t ;; eof reached? )]
)] [(cadr m)
[(cadr m) (close-output-port pout)
(close-output-port pout) (values pin #t #f)]
(values pin #t #f)] [else
[else (close-output-port pout)
(close-output-port pout) (values pin #f #f)]))))])
(values pin #f #f)]))))]) ;; pre-amble is allowed to be completely empty:
;; pre-amble is allowed to be completely empty: (if (regexp-match-peek (make-re "^") input)
(if (regexp-match-peek (make-re "^") input) ;; No \r\f before first separator:
;; No \r\f before first separator: (read-line input)
(read-line input) ;; non-empty preamble:
;; non-empty preamble: (eat-part))
(eat-part)) (let loop ()
(let loop () (let-values ([(part close? eof?) (eat-part)])
(let-values ([(part close? eof?) (eat-part)]) (cond [close? (list part)]
(cond (close? (list part)) [eof? (list part)]
(eof? (list part)) [else (cons part (loop))]))))))
(else (cons part (loop))))))))))
;; MIME-message-headers := entity-headers ;; MIME-message-headers := entity-headers
;; fields ;; fields
@ -300,11 +293,10 @@
;; ; The ordering of the header ;; ; The ordering of the header
;; ; fields implied by this BNF ;; ; fields implied by this BNF
;; ; definition should be ignored. ;; ; definition should be ignored.
(define MIME-message-headers (define (MIME-message-headers headers)
(lambda (headers) (let ([message (make-default-message)])
(let ([message (make-default-message)]) (entity-headers headers message #t)
(entity-headers headers message #t) message))
message)))
;; MIME-part-headers := entity-headers ;; MIME-part-headers := entity-headers
;; [ fields ] ;; [ fields ]
@ -314,63 +306,59 @@
;; ; The ordering of the header ;; ; The ordering of the header
;; ; fields implied by this BNF ;; ; fields implied by this BNF
;; ; definition should be ignored. ;; ; definition should be ignored.
(define MIME-part-headers (define (MIME-part-headers headers)
(lambda (headers) (let ([message (make-default-message)])
(let ([message (make-default-message)]) (entity-headers headers message #f)
(entity-headers headers message #f) message))
message)))
;; entity-headers := [ content CRLF ] ;; entity-headers := [ content CRLF ]
;; [ encoding CRLF ] ;; [ encoding CRLF ]
;; [ id CRLF ] ;; [ id CRLF ]
;; [ description CRLF ] ;; [ description CRLF ]
;; *( MIME-extension-field CRLF ) ;; *( MIME-extension-field CRLF )
(define entity-headers (define (entity-headers headers message version?)
(lambda (headers message version?) (let ([entity (message-entity message)])
(let ([entity (message-entity message)]) (let-values ([(mime non-mime) (get-fields headers)])
(let-values ([(mime non-mime) (get-fields headers)]) (let loop ([fields mime])
(let loop ([fields mime]) (unless (null? fields)
(unless (null? fields) ;; Process MIME field
;; Process MIME field (let ([trimmed-h (trim-comments (car fields))])
(let ([trimmed-h (trim-comments (car fields))]) (or (and version? (version trimmed-h message))
(or (and version? (version trimmed-h message)) (content trimmed-h entity)
(content trimmed-h entity) (encoding trimmed-h entity)
(encoding trimmed-h entity) (dispositione trimmed-h entity)
(dispositione trimmed-h entity) (id trimmed-h entity)
(id trimmed-h entity) (description trimmed-h entity)
(description trimmed-h entity) (MIME-extension-field trimmed-h entity))
(MIME-extension-field trimmed-h entity)) ;; keep going
;; keep going (loop (cdr fields)))))
(loop (cdr fields))))) ;; NON-mime headers (or semantically incorrect). In order to make
;; NON-mime headers (or semantically incorrect). In order to make ;; this implementation of rfc2045 robuts, we will save the header in
;; this implementation of rfc2045 robuts, we will save the header in ;; the fields field of the message struct:
;; the fields field of the message struct: (set-message-fields! message non-mime)
(set-message-fields! message non-mime) ;; Return message
;; Return message message)))
message))))
(define get-fields (define (get-fields headers)
(lambda (headers) (let ([mime null] [non-mime null])
(let ([mime null] [non-mime null]) (letrec ([store-field
(letrec ([store-field (lambda (f)
(lambda (f) (unless (string=? f "")
(unless (string=? f "") (if (mime-header? f)
(if (mime-header? f) (set! mime (append mime (list (trim-spaces f))))
(set! mime (append mime (list (trim-spaces f)))) (set! non-mime (append non-mime (list (trim-spaces f)))))))])
(set! non-mime (append non-mime (list (trim-spaces f)))))))]) (let ([fields (extract-all-fields headers)])
(let ([fields (extract-all-fields headers)]) (for-each (lambda (p)
(for-each (lambda (p) (store-field (format "~a: ~a" (car p) (cdr p))))
(store-field (format "~a: ~a" (car p) (cdr p)))) fields))
fields)) (values mime non-mime))))
(values mime non-mime)))))
(define re:content (regexp (format "^~a" (regexp-quote "content-" #f)))) (define re:content (regexp (format "^~a" (regexp-quote "content-" #f))))
(define re:mime (regexp (format "^~a:" (regexp-quote "mime-version" #f)))) (define re:mime (regexp (format "^~a:" (regexp-quote "mime-version" #f))))
(define mime-header? (define (mime-header? h)
(lambda (h) (or (regexp-match? re:content h)
(or (regexp-match re:content h) (regexp-match? re:mime h)))
(regexp-match re:mime h))))
;;; Headers ;;; Headers
;;; Content-type follows this BNF syntax: ;;; Content-type follows this BNF syntax:
@ -380,103 +368,97 @@
;; ; is ALWAYS case-insensitive. ;; ; is ALWAYS case-insensitive.
(define re:content-type (define re:content-type
(regexp (format "^~a:([^/]+)/([^/]+)$" (regexp-quote "content-type" #f)))) (regexp (format "^~a:([^/]+)/([^/]+)$" (regexp-quote "content-type" #f))))
(define content (define (content header entity)
(lambda (header entity) (let* ([params (string-tokenizer #\; header)]
(let* ([params (string-tokenizer #\; header)] [one re:content-type]
[one re:content-type] [h (trim-all-spaces (car params))]
[h (trim-all-spaces (car params))] [target (regexp-match one h)]
[target (regexp-match one h)] [old-param (entity-params entity)])
[old-param (entity-params entity)]) (and target
(and target (set-entity-type! entity
(set-entity-type! entity (type (regexp-replace one h "\\1"))) ;; type
(type (regexp-replace one h "\\1"))) ;; type (set-entity-subtype! entity
(set-entity-subtype! entity (subtype (regexp-replace one h "\\2"))) ;; subtype
(subtype (regexp-replace one h "\\2"))) ;; subtype (set-entity-params!
(set-entity-params! entity
entity (append old-param
(append old-param (let loop ([p (cdr params)] ;; parameters
(let loop ([p (cdr params)] ;; parameters [ans null])
[ans null]) (cond [(null? p) ans]
(cond [(null? p) ans] [else
[else (let ([par-pair (parameter (trim-all-spaces (car p)))])
(let ([par-pair (parameter (trim-all-spaces (car p)))]) (cond [par-pair
(cond [par-pair (when (string=? (car par-pair) "charset")
(when (string=? (car par-pair) "charset") (set-entity-charset! entity (cdr par-pair)))
(set-entity-charset! entity (cdr par-pair))) (loop (cdr p)
(loop (cdr p) (append ans
(append ans (list par-pair)))]
(list par-pair)))] [else
[else (warning "Invalid parameter for Content-Type: `~a'" (car p))
(warning "Invalid parameter for Content-Type: `~a'" (car p)) ;; go on...
;; go on... (loop (cdr p) ans)]))])))))))
(loop (cdr p) ans)]))]))))))))
;; From rfc2183 Content-Disposition ;; From rfc2183 Content-Disposition
;; disposition := "Content-Disposition" ":" ;; disposition := "Content-Disposition" ":"
;; disposition-type ;; disposition-type
;; *(";" disposition-parm) ;; *(";" disposition-parm)
(define re:content-disposition (regexp (format "^~a:(.+)$" (regexp-quote "content-disposition" #f)))) (define re:content-disposition (regexp (format "^~a:(.+)$" (regexp-quote "content-disposition" #f))))
(define dispositione (define (dispositione header entity)
(lambda (header entity) (let* ([params (string-tokenizer #\; header)]
(let* ([params (string-tokenizer #\; header)] [reg re:content-disposition]
[reg re:content-disposition] [h (trim-all-spaces (car params))]
[h (trim-all-spaces (car params))] [target (regexp-match reg h)]
[target (regexp-match reg h)] [disp-struct (entity-disposition entity)])
[disp-struct (entity-disposition entity)]) (and target
(and target (set-disposition-type!
(set-disposition-type! disp-struct
disp-struct (disp-type (regexp-replace reg h "\\1")))
(disp-type (regexp-replace reg h "\\1"))) (disp-params (cdr params) disp-struct))))
(disp-params (cdr params) disp-struct)))))
;; version := "MIME-Version" ":" 1*DIGIT "." 1*DIGIT ;; version := "MIME-Version" ":" 1*DIGIT "." 1*DIGIT
(define re:mime-version (define re:mime-version
(regexp (format "^~a:([0-9]+)\\.([0-9]+)$" (regexp-quote "MIME-Version" #f)))) (regexp (format "^~a:([0-9]+)\\.([0-9]+)$" (regexp-quote "MIME-Version" #f))))
(define version (define (version header message)
(lambda (header message) (let* ([reg re:mime-version]
(let* ([reg re:mime-version] [h (trim-all-spaces header)]
[h (trim-all-spaces header)] [target (regexp-match reg h)])
[target (regexp-match reg h)]) (and target
(and target (set-message-version!
(set-message-version! message
message (string->number (regexp-replace reg h "\\1.\\2"))))))
(string->number (regexp-replace reg h "\\1.\\2")))))))
;; description := "Content-Description" ":" *text ;; description := "Content-Description" ":" *text
(define re:content-description (define re:content-description
(regexp (format "^~a:[ \t\r\n]*(.*)$" (regexp-quote "content-description" #f)))) (regexp (format "^~a:[ \t\r\n]*(.*)$" (regexp-quote "content-description" #f))))
(define description (define (description header entity)
(lambda (header entity) (let* ([reg re:content-description]
(let* ([reg re:content-description] [target (regexp-match reg header)])
[target (regexp-match reg header)]) (and target
(and target (set-entity-description!
(set-entity-description! entity
entity (trim-spaces (regexp-replace reg header "\\1"))))))
(trim-spaces (regexp-replace reg header "\\1")))))))
;; encoding := "Content-Transfer-Encoding" ":" mechanism ;; encoding := "Content-Transfer-Encoding" ":" mechanism
(define re:content-transfer-encoding (regexp (format "^~a:(.+)$" (regexp-quote "content-transfer-encoding" #f)))) (define re:content-transfer-encoding (regexp (format "^~a:(.+)$" (regexp-quote "content-transfer-encoding" #f))))
(define encoding (define (encoding header entity)
(lambda (header entity) (let* ([reg re:content-transfer-encoding]
(let* ([reg re:content-transfer-encoding] [h (trim-all-spaces header)]
[h (trim-all-spaces header)] [target (regexp-match reg h)])
[target (regexp-match reg h)]) (and target
(and target (set-entity-encoding!
(set-entity-encoding! entity
entity (mechanism (regexp-replace reg h "\\1"))))))
(mechanism (regexp-replace reg h "\\1")))))))
;; id := "Content-ID" ":" msg-id ;; id := "Content-ID" ":" msg-id
(define re:content-id (regexp (format "^~a:(.+)$" (regexp-quote "content-id" #f)))) (define re:content-id (regexp (format "^~a:(.+)$" (regexp-quote "content-id" #f))))
(define id (define (id header entity)
(lambda (header entity) (let* ([reg re:content-id]
(let* ([reg re:content-id] [h (trim-all-spaces header)]
[h (trim-all-spaces header)] [target (regexp-match reg h)])
[target (regexp-match reg h)]) (and target
(and target (set-entity-id!
(set-entity-id! entity
entity (msg-id (regexp-replace reg h "\\1"))))))
(msg-id (regexp-replace reg h "\\1")))))))
;; From rfc822: ;; From rfc822:
;; msg-id = "<" addr-spec ">" ; Unique message id ;; msg-id = "<" addr-spec ">" ; Unique message id
@ -487,84 +469,75 @@
;; sub-domain = domain-ref / domain-literal ;; sub-domain = domain-ref / domain-literal
;; domain-literal = "[" *(dtext / quoted-pair) "]" ;; domain-literal = "[" *(dtext / quoted-pair) "]"
;; domain-ref = atom ; symbolic reference ;; domain-ref = atom ; symbolic reference
(define msg-id (define (msg-id str)
(lambda (str) (let* ([r (regexp "^<[^@>]+@[^.]+(\\.[^.]+)*>$")]
(let* ([r (regexp "^<[^@>]+@[^.]+(\\.[^.]+)*>$")] [ans (regexp-match r str)])
[ans (regexp-match r str)]) (if ans
(if ans str
str (begin (warning "Invalid msg-id: ~a" str) str))))
(begin (warning "Invalid msg-id: ~a" str) str)))))
;; mechanism := "7bit" / "8bit" / "binary" / ;; mechanism := "7bit" / "8bit" / "binary" /
;; "quoted-printable" / "base64" / ;; "quoted-printable" / "base64" /
;; ietf-token / x-token ;; ietf-token / x-token
(define mechanism (define (mechanism mech)
(lambda (mech) (if (not mech)
(if (not mech) (raise (make-empty-mechanism))
(raise (make-empty-mechanism)) (let ([val (assoc (lowercase mech) mechanism-alist)])
(let ([val (assoc (lowercase mech) mechanism-alist)]) (or (and val (cdr val))
(or (and val (cdr val)) (ietf-token mech)
(ietf-token mech) (x-token mech)))))
(x-token mech))))))
;; MIME-extension-field := <Any RFC 822 header field which ;; MIME-extension-field := <Any RFC 822 header field which
;; begins with the string ;; begins with the string
;; "Content-"> ;; "Content-">
;; ;;
(define MIME-extension-field (define (MIME-extension-field header entity)
(lambda (header entity) (let* ([reg (regexp "^[Cc]ontent-(.+):[ \t]*(.+)$")]
(let* ([reg (regexp "^[Cc]ontent-(.+):[ \t]*(.+)$")] [target (regexp-match reg header)])
[target (regexp-match reg header)]) (and target
(and target (set-entity-other!
(set-entity-other! entity
entity (append (entity-other entity)
(append (entity-other entity) (list
(list (cons (regexp-replace reg header "\\1")
(cons (regexp-replace reg header "\\1") (trim-spaces (regexp-replace reg header "\\2")))))))))
(trim-spaces (regexp-replace reg header "\\2"))))))))))
;; type := discrete-type / composite-type ;; type := discrete-type / composite-type
(define type (define (type value)
(lambda (value) (if (not value)
(if (not value) (raise (make-empty-type))
(raise (make-empty-type)) (or (discrete-type value)
(or (discrete-type value) (composite-type value))))
(composite-type value)))))
;; disposition-type := "inline" / "attachment" / extension-token ;; disposition-type := "inline" / "attachment" / extension-token
(define disp-type (define (disp-type value)
(lambda (value) (if (not value)
(if (not value) (raise (make-empty-disposition-type))
(raise (make-empty-disposition-type)) (let ([val (assoc (lowercase (trim-spaces value)) disposition-alist)])
(let ([val (assoc (lowercase (trim-spaces value)) disposition-alist)]) (if val (cdr val) (extension-token value)))))
(if val (cdr val) (extension-token value))))))
;; discrete-type := "text" / "image" / "audio" / "video" / ;; discrete-type := "text" / "image" / "audio" / "video" /
;; "application" / extension-token ;; "application" / extension-token
(define discrete-type (define (discrete-type value)
(lambda (value) (let ([val (assoc (lowercase (trim-spaces value)) discrete-alist)])
(let ([val (assoc (lowercase (trim-spaces value)) discrete-alist)]) (if val (cdr val) (extension-token value))))
(if val (cdr val) (extension-token value)))))
;; composite-type := "message" / "multipart" / extension-token ;; composite-type := "message" / "multipart" / extension-token
(define composite-type (define (composite-type value)
(lambda (value) (let ([val (assoc (lowercase (trim-spaces value)) composite-alist)])
(let ([val (assoc (lowercase (trim-spaces value)) composite-alist)]) (if val (cdr val) (extension-token value))))
(if val (cdr val) (extension-token value)))))
;; extension-token := ietf-token / x-token ;; extension-token := ietf-token / x-token
(define extension-token (define (extension-token value)
(lambda (value) (or (ietf-token value)
(or (ietf-token value) (x-token value)))
(x-token value))))
;; ietf-token := <An extension token defined by a ;; ietf-token := <An extension token defined by a
;; standards-track RFC and registered ;; standards-track RFC and registered
;; with IANA.> ;; with IANA.>
(define ietf-token (define (ietf-token value)
(lambda (value) (let ([ans (assoc (lowercase (trim-spaces value)) ietf-extensions)])
(let ([ans (assoc (lowercase (trim-spaces value)) ietf-extensions)]) (and ans (cdr ans))))
(and ans (cdr ans)))))
;; Directly from RFC 1700: ;; Directly from RFC 1700:
;; Type Subtype Description Reference ;; Type Subtype Description Reference
@ -619,48 +592,43 @@
;; x-token := <The two characters "X-" or "x-" followed, with ;; x-token := <The two characters "X-" or "x-" followed, with
;; no intervening white space, by any token> ;; no intervening white space, by any token>
(define x-token (define (x-token value)
(lambda (value) (let* ([r #rx"^[xX]-(.*)"]
(let* ([r #rx"^[xX]-(.*)"] [h (trim-spaces value)]
[h (trim-spaces value)] [ans (regexp-match r h)])
[ans (regexp-match r h)]) (and ans
(and ans (token (regexp-replace r h "\\1"))
(token (regexp-replace r h "\\1")) h)))
h))))
;; subtype := extension-token / iana-token ;; subtype := extension-token / iana-token
(define subtype (define (subtype value)
(lambda (value) (if (not value)
(if (not value) (raise (make-empty-subtype))
(raise (make-empty-subtype)) (or (extension-token value)
(or (extension-token value) (iana-token value))))
(iana-token value)))))
;; iana-token := <A publicly-defined extension token. Tokens ;; iana-token := <A publicly-defined extension token. Tokens
;; of this form must be registered with IANA ;; of this form must be registered with IANA
;; as specified in RFC 2048.> ;; as specified in RFC 2048.>
(define iana-token (define (iana-token value)
(lambda (value) (let ([ans (assoc (lowercase (trim-spaces value)) iana-extensions)])
(let ([ans (assoc (lowercase (trim-spaces value)) iana-extensions)]) (and ans (cdr ans))))
(and ans (cdr ans)))))
;; parameter := attribute "=" value ;; parameter := attribute "=" value
(define re:parameter (regexp "([^=]+)=(.+)")) (define re:parameter (regexp "([^=]+)=(.+)"))
(define parameter (define (parameter par)
(lambda (par) (let* ([r re:parameter]
(let* ([r re:parameter] [att (attribute (regexp-replace r par "\\1"))]
[att (attribute (regexp-replace r par "\\1"))] [val (value (regexp-replace r par "\\2"))])
[val (value (regexp-replace r par "\\2"))]) (if (regexp-match r par)
(if (regexp-match r par) (cons (if att (lowercase att) "???") val)
(cons (if att (lowercase att) "???") val) (cons "???" par))))
(cons "???" par)))))
;; value := token / quoted-string ;; value := token / quoted-string
(define value (define (value val)
(lambda (val) (or (token val)
(or (token val) (quoted-string val)
(quoted-string val) val))
val)))
;; token := 1*<any (US-ASCII) CHAR except SPACE, CTLs, ;; token := 1*<any (US-ASCII) CHAR except SPACE, CTLs,
;; or tspecials> ;; or tspecials>
@ -669,13 +637,12 @@
;; "/" / "[" / "]" / "?" / "=" ;; "/" / "[" / "]" / "?" / "="
;; ; Must be in quoted-string, ;; ; Must be in quoted-string,
;; ; to use within parameter values ;; ; to use within parameter values
(define token (define (token value)
(lambda (value) (let* ([tspecials (regexp "[^][()<>@,;:\\\"/?= ]+")]
(let* ([tspecials (regexp "[^][()<>@,;:\\\"/?= ]+")] [ans (regexp-match tspecials value)])
[ans (regexp-match tspecials value)]) (and ans
(and ans (string=? value (car ans))
(string=? value (car ans)) (car ans))))
(car ans)))))
;; attribute := token ;; attribute := token
;; ; Matching of attributes ;; ; Matching of attributes
@ -683,11 +650,10 @@
(define attribute token) (define attribute token)
(define re:quotes (regexp "\"(.+)\"")) (define re:quotes (regexp "\"(.+)\""))
(define quoted-string (define (quoted-string str)
(lambda (str) (let* ([quotes re:quotes]
(let* ([quotes re:quotes] [ans (regexp-match quotes str)])
[ans (regexp-match quotes str)]) (and ans (regexp-replace quotes str "\\1"))))
(and ans (regexp-replace quotes str "\\1")))))
;; disposition-parm := filename-parm ;; disposition-parm := filename-parm
;; / creation-date-parm ;; / creation-date-parm
@ -705,36 +671,35 @@
;; read-date-parm := "read-date" "=" quoted-date-time ;; read-date-parm := "read-date" "=" quoted-date-time
;; ;;
;; size-parm := "size" "=" 1*DIGIT ;; size-parm := "size" "=" 1*DIGIT
(define disp-params (define (disp-params lst disp)
(lambda (lst disp) (let loop ([lst lst])
(let loop ([lst lst]) (unless (null? lst)
(unless (null? lst) (let* ([p (parameter (trim-all-spaces (car lst)))]
(let* ([p (parameter (trim-all-spaces (car lst)))] [parm (car p)]
[parm (car p)] [value (cdr p)])
[value (cdr p)]) (cond [(string=? parm "filename")
(cond [(string=? parm "filename") (set-disposition-filename! disp value)]
(set-disposition-filename! disp value)] [(string=? parm "creation-date")
[(string=? parm "creation-date") (set-disposition-creation!
(set-disposition-creation! disp
disp (disp-quoted-data-time value))]
(disp-quoted-data-time value))] [(string=? parm "modification-date")
[(string=? parm "modification-date") (set-disposition-modification!
(set-disposition-modification! disp
disp (disp-quoted-data-time value))]
(disp-quoted-data-time value))] [(string=? parm "read-date")
[(string=? parm "read-date") (set-disposition-read!
(set-disposition-read! disp
disp (disp-quoted-data-time value))]
(disp-quoted-data-time value))] [(string=? parm "size")
[(string=? parm "size") (set-disposition-size!
(set-disposition-size! disp
disp (string->number value))]
(string->number value))] [else
[else (set-disposition-params!
(set-disposition-params! disp
disp (append (disposition-params disp) (list p)))])
(append (disposition-params disp) (list p)))]) (loop (cdr lst))))))
(loop (cdr lst)))))))
;; date-time = [ day "," ] date time ; dd mm yy ;; date-time = [ day "," ] date time ; dd mm yy
;; ; hh:mm:ss zzz ;; ; hh:mm:ss zzz

134
collects/net/mime-util.ss
View File

@ -38,92 +38,84 @@
;; 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 (define (string-index s c)
(lambda (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 (define (string-tokenizer c s)
(lambda (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 (define (trim-all-spaces str)
(lambda (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 (define (trim-spaces str)
(lambda (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 (define (trim-left str)
(lambda (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 (define (trim-right str)
(lambda (str) (regexp-replace re:right-spaces str ""))
(regexp-replace re:right-spaces str "")))
(define re:comments (regexp "^[^\"]*(\"[^\"]*\")*[^\"]*(\\(.*\\))")) (define re:comments (regexp "^[^\"]*(\"[^\"]*\")*[^\"]*(\\(.*\\))"))
(define trim-comments (define (trim-comments str)
(lambda (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 (define (lowercase str)
(lambda (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 (define warning
void void

352
collects/net/nntp-unit.ss
View File

@ -35,13 +35,12 @@
;; - throws an exception ;; - throws an exception
(define signal-error (define (signal-error constructor format-string . args)
(lambda (constructor format-string . args) (lambda exn-args
(lambda exn-args (raise (apply constructor
(raise (apply constructor (string->immutable-string (apply format format-string args))
(string->immutable-string (apply format format-string args)) (current-continuation-marks)
(current-continuation-marks) exn-args))))
exn-args)))))
;; default-nntpd-port-number : ;; default-nntpd-port-number :
;; number ;; number
@ -80,120 +79,112 @@
;; close-communicator : ;; close-communicator :
;; communicator -> () ;; communicator -> ()
(define close-communicator (define (close-communicator communicator)
(lambda (communicator) (close-input-port (communicator-receiver communicator))
(close-input-port (communicator-receiver communicator)) (close-output-port (communicator-sender communicator)))
(close-output-port (communicator-sender communicator))))
;; disconnect-from-server : ;; disconnect-from-server :
;; communicator -> () ;; communicator -> ()
(define disconnect-from-server (define (disconnect-from-server communicator)
(lambda (communicator) (send-to-server communicator "QUIT")
(send-to-server communicator "QUIT") (let-values ([(code response)
(let-values ([(code response) (get-single-line-response communicator)])
(get-single-line-response communicator)]) (case code
(case code [(205)
[(205) (close-communicator communicator)]
(close-communicator communicator)] [else
[else ((signal-error make-unexpected-response
((signal-error make-unexpected-response "unexpected dis-connect response: ~s ~s"
"unexpected dis-connect response: ~s ~s" code response)
code response) code response)])))
code response)]))))
;; authenticate-user : ;; authenticate-user :
;; communicator x user-name x password -> () ;; communicator x user-name x password -> ()
;; the password is not used if the server does not ask for it. ;; the password is not used if the server does not ask for it.
(define authenticate-user (define (authenticate-user communicator user password)
(lambda (communicator user password) (define (reject code response)
(define (reject code response) ((signal-error make-authentication-rejected
((signal-error make-authentication-rejected "authentication rejected (~s ~s)"
"authentication rejected (~s ~s)" code response)))
code response))) (define (unexpected code response)
(define (unexpected code response) ((signal-error make-unexpected-response
((signal-error make-unexpected-response "unexpected response for authentication: ~s ~s"
"unexpected response for authentication: ~s ~s" code response)
code response) code response))
code response)) (send-to-server communicator "AUTHINFO USER ~a" user)
(send-to-server communicator "AUTHINFO USER ~a" user) (let-values ([(code response) (get-single-line-response communicator)])
(let-values ([(code response) (get-single-line-response communicator)]) (case code
(case code [(281) (void)] ; server doesn't ask for a password
[(281) (void)] ; server doesn't ask for a password [(381)
[(381) (send-to-server communicator "AUTHINFO PASS ~a" password)
(send-to-server communicator "AUTHINFO PASS ~a" password) (let-values ([(code response)
(let-values ([(code response) (get-single-line-response communicator)])
(get-single-line-response communicator)]) (case code
(case code [(281) (void)] ; done
[(281) (void)] ; done [(502) (reject code response)]
[(502) (reject code response)] [else (unexpected code response)]))]
[else (unexpected code response)]))] [(502) (reject code response)]
[(502) (reject code response)] [else (reject code response)
[else (reject code response) (unexpected code response)])))
(unexpected code response)]))))
;; send-to-server : ;; send-to-server :
;; communicator x format-string x list (values) -> () ;; communicator x format-string x list (values) -> ()
(define send-to-server (define (send-to-server communicator message-template . rest)
(lambda (communicator message-template . rest) (let ([sender (communicator-sender communicator)])
(let ([sender (communicator-sender communicator)]) (apply fprintf sender
(apply fprintf sender (string-append message-template "\r\n")
(string-append message-template "\r\n") rest)
rest) (flush-output sender)))
(flush-output sender))))
;; parse-status-line : ;; parse-status-line :
;; string -> number x string ;; string -> number x string
(define parse-status-line (define (parse-status-line line)
(lambda (line) (if (eof-object? line)
(if (eof-object? line) ((signal-error make-bad-status-line "eof instead of a status line")
((signal-error make-bad-status-line "eof instead of a status line") line)
line) (let ([match (cdr (or (regexp-match #rx"([0-9]+) (.*)" line)
(let ([match (cdr (or (regexp-match #rx"([0-9]+) (.*)" line) ((signal-error make-bad-status-line
((signal-error make-bad-status-line "malformed status line: ~s" line)
"malformed status line: ~s" line) line)))])
line)))]) (values (string->number (car match))
(values (string->number (car match)) (cadr match)))))
(cadr match))))))
;; get-one-line-from-server : ;; get-one-line-from-server :
;; iport -> string ;; iport -> string
(define get-one-line-from-server (define (get-one-line-from-server server->client-port)
(lambda (server->client-port) (read-line server->client-port 'return-linefeed))
(read-line server->client-port 'return-linefeed)))
;; get-single-line-response : ;; get-single-line-response :
;; communicator -> number x string ;; communicator -> number x string
(define get-single-line-response (define (get-single-line-response communicator)
(lambda (communicator) (let* ([receiver (communicator-receiver communicator)]
(let ([receiver (communicator-receiver communicator)]) [status-line (get-one-line-from-server receiver)])
(let ([status-line (get-one-line-from-server receiver)]) (parse-status-line status-line)))
(parse-status-line status-line)))))
;; get-rest-of-multi-line-response : ;; get-rest-of-multi-line-response :
;; communicator -> list (string) ;; communicator -> list (string)
(define get-rest-of-multi-line-response (define (get-rest-of-multi-line-response communicator)
(lambda (communicator) (let ([receiver (communicator-receiver communicator)])
(let ([receiver (communicator-receiver communicator)]) (let loop ()
(let loop () (let ([l (get-one-line-from-server receiver)])
(let ([l (get-one-line-from-server receiver)]) (cond
(cond [(eof-object? l)
[(eof-object? l) ((signal-error make-premature-close
((signal-error make-premature-close "port prematurely closed during multi-line response")
"port prematurely closed during multi-line response") communicator)]
communicator)] [(string=? l ".")
[(string=? l ".") '()]
'()] [(string=? l "..")
[(string=? l "..") (cons "." (loop))]
(cons "." (loop))] [else
[else (cons l (loop))])))))
(cons l (loop))]))))))
;; get-multi-line-response : ;; get-multi-line-response :
;; communicator -> number x string x list (string) ;; communicator -> number x string x list (string)
@ -201,13 +192,12 @@
;; -- The returned values are the status code, the rest of the status ;; -- The returned values are the status code, the rest of the status
;; response line, and the remaining lines. ;; response line, and the remaining lines.
(define get-multi-line-response (define (get-multi-line-response communicator)
(lambda (communicator) (let* ([receiver (communicator-receiver communicator)]
(let* ([receiver (communicator-receiver communicator)] [status-line (get-one-line-from-server receiver)])
[status-line (get-one-line-from-server receiver)]) (let-values ([(code rest-of-line)
(let-values ([(code rest-of-line) (parse-status-line status-line)])
(parse-status-line status-line)]) (values code rest-of-line (get-rest-of-multi-line-response)))))
(values code rest-of-line (get-rest-of-multi-line-response))))))
;; open-news-group : ;; open-news-group :
;; communicator x string -> number x number x number ;; communicator x string -> number x number x number
@ -215,66 +205,64 @@
;; -- The returned values are the number of articles, the first ;; -- The returned values are the number of articles, the first
;; article number, and the last article number for that group. ;; article number, and the last article number for that group.
(define open-news-group (define (open-news-group communicator group-name)
(lambda (communicator group-name) (send-to-server communicator "GROUP ~a" group-name)
(send-to-server communicator "GROUP ~a" group-name) (let-values ([(code rest-of-line)
(let-values ([(code rest-of-line) (get-single-line-response communicator)])
(get-single-line-response communicator)]) (case code
(case code [(211)
[(211) (let ([match (map string->number
(let ([match (map string->number (cdr
(cdr (or (regexp-match #rx"([0-9]+) ([0-9]+) ([0-9]+)" rest-of-line)
(or (regexp-match #rx"([0-9]+) ([0-9]+) ([0-9]+)" rest-of-line) ((signal-error make-bad-newsgroup-line
((signal-error make-bad-newsgroup-line "malformed newsgroup open response: ~s"
"malformed newsgroup open response: ~s" rest-of-line)
rest-of-line) rest-of-line))))])
rest-of-line))))]) (let ([number-of-articles (car match)]
(let ([number-of-articles (car match)] [first-article-number (cadr match)]
[first-article-number (cadr match)] [last-article-number (caddr match)])
[last-article-number (caddr match)]) (values number-of-articles
(values number-of-articles first-article-number
first-article-number last-article-number)))]
last-article-number)))] [(411)
[(411) ((signal-error make-non-existent-group
((signal-error make-non-existent-group "group ~s does not exist on server ~s"
"group ~s does not exist on server ~s" group-name (communicator-server communicator))
group-name (communicator-server communicator)) group-name)]
group-name)] [else
[else ((signal-error make-unexpected-response
((signal-error make-unexpected-response "unexpected group opening response: ~s" code)
"unexpected group opening response: ~s" code) code rest-of-line)])))
code rest-of-line)]))))
;; generic-message-command : ;; generic-message-command :
;; string x number -> communicator x (number U string) -> list (string) ;; string x number -> communicator x (number U string) -> list (string)
(define generic-message-command (define (generic-message-command command ok-code)
(lambda (command ok-code) (lambda (communicator message-index)
(lambda (communicator message-index) (send-to-server communicator (string-append command " ~a")
(send-to-server communicator (string-append command " ~a") (if (number? message-index)
(if (number? message-index) (number->string message-index)
(number->string message-index) message-index))
message-index)) (let-values ([(code response)
(let-values ([(code response) (get-single-line-response communicator)])
(get-single-line-response communicator)]) (if (= code ok-code)
(if (= code ok-code) (get-rest-of-multi-line-response communicator)
(get-rest-of-multi-line-response communicator) (case code
(case code [(423)
[(423) ((signal-error make-article-not-in-group
((signal-error make-article-not-in-group "article id ~s not in group" message-index)
"article id ~s not in group" message-index) message-index)]
message-index)] [(412)
[(412) ((signal-error make-no-group-selected
((signal-error make-no-group-selected "no group selected"))]
"no group selected"))] [(430)
[(430) ((signal-error make-article-not-found
((signal-error make-article-not-found "no article id ~s found" message-index)
"no article id ~s found" message-index) message-index)]
message-index)] [else
[else ((signal-error make-unexpected-response
((signal-error make-unexpected-response "unexpected message access response: ~s" code)
"unexpected message access response: ~s" code) code response)])))))
code response)]))))))
;; head-of-message : ;; head-of-message :
;; communicator x (number U string) -> list (string) ;; communicator x (number U string) -> list (string)
@ -297,35 +285,33 @@
;; make-desired-header : ;; make-desired-header :
;; string -> desired ;; string -> desired
(define make-desired-header (define (make-desired-header raw-header)
(lambda (raw-header) (regexp
(regexp (string-append
(string-append "^"
"^" (list->string
(list->string (apply append
(apply append (map (lambda (c)
(map (lambda (c) (cond
(cond [(char-lower-case? c)
[(char-lower-case? c) (list #\[ (char-upcase c) c #\])]
(list #\[ (char-upcase c) c #\])] [(char-upper-case? c)
[(char-upper-case? c) (list #\[ c (char-downcase c) #\])]
(list #\[ c (char-downcase c) #\])] [else
[else (list c)]))
(list c)])) (string->list raw-header))))
(string->list raw-header)))) ":")))
":"))))
;; extract-desired-headers : ;; extract-desired-headers :
;; list (string) x list (desired) -> list (string) ;; list (string) x list (desired) -> list (string)
(define extract-desired-headers (define (extract-desired-headers headers desireds)
(lambda (headers desireds) (let loop ([headers headers])
(let loop ([headers headers]) (if (null? headers) null
(if (null? headers) null (let ([first (car headers)]
(let ([first (car headers)] [rest (cdr headers)])
[rest (cdr headers)]) (if (ormap (lambda (matcher)
(if (ormap (lambda (matcher) (regexp-match matcher first))
(regexp-match matcher first)) desireds)
desireds) (cons first (loop rest))
(cons first (loop rest)) (loop rest)))))))
(loop rest))))))))

381
collects/net/pop3-unit.ss
View File

@ -29,14 +29,13 @@
;; (exn-args ... -> exn) x format-string x values ... -> ;; (exn-args ... -> exn) x format-string x values ... ->
;; exn-args -> () ;; exn-args -> ()
(define signal-error (define (signal-error constructor format-string . args)
(lambda (constructor format-string . args) (lambda exn-args
(lambda exn-args (raise (apply constructor
(raise (apply constructor (string->immutable-string
(string->immutable-string (apply format format-string args))
(apply format format-string args)) (current-continuation-marks)
(current-continuation-marks) exn-args))))
exn-args)))))
;; signal-malformed-response-error : ;; signal-malformed-response-error :
;; exn-args -> () ;; exn-args -> ()
@ -52,11 +51,10 @@
;; -- signals an error otherwise. ;; -- signals an error otherwise.
(define confirm-transaction-mode (define (confirm-transaction-mode communicator error-message)
(lambda (communicator error-message) (unless (eq? (communicator-state communicator) 'transaction)
(unless (eq? (communicator-state communicator) 'transaction) ((signal-error make-not-ready-for-transaction error-message)
((signal-error make-not-ready-for-transaction error-message) communicator)))
communicator))))
;; default-pop-port-number : ;; default-pop-port-number :
;; number ;; number
@ -98,122 +96,118 @@
;; -- if authentication succeeds, sets the communicator's state to ;; -- if authentication succeeds, sets the communicator's state to
;; transaction. ;; transaction.
(define authenticate/plain-text (define (authenticate/plain-text username password communicator)
(lambda (username password communicator) (let ([sender (communicator-sender communicator)])
(let ([sender (communicator-sender communicator)]) (send-to-server communicator "USER ~a" username)
(send-to-server communicator "USER ~a" username) (let ([status (get-status-response/basic communicator)])
(let ([status (get-status-response/basic communicator)]) (cond
(cond [(+ok? status)
[(+ok? status) (send-to-server communicator "PASS ~a" password)
(send-to-server communicator "PASS ~a" password) (let ([status (get-status-response/basic communicator)])
(let ([status (get-status-response/basic communicator)]) (cond
(cond [(+ok? status)
[(+ok? status) (set-communicator-state! communicator 'transaction)]
(set-communicator-state! communicator 'transaction)] [(-err? status)
[(-err? status) ((signal-error make-password-rejected
((signal-error make-password-rejected "password was rejected"))]))]
"password was rejected"))]))] [(-err? status)
[(-err? status) ((signal-error make-username-rejected
((signal-error make-username-rejected "username was rejected"))]))))
"username was rejected"))])))))
;; get-mailbox-status : ;; get-mailbox-status :
;; communicator -> number x number ;; communicator -> number x number
;; -- returns number of messages and number of octets. ;; -- returns number of messages and number of octets.
(define get-mailbox-status (define (get-mailbox-status communicator)
(lambda (communicator) (confirm-transaction-mode
(confirm-transaction-mode communicator
communicator "cannot get mailbox status unless in transaction mode")
"cannot get mailbox status unless in transaction mode") (send-to-server communicator "STAT")
(send-to-server communicator "STAT") (apply values
(apply values (map string->number
(map string->number (let-values ([(status result)
(let-values ([(status result) (get-status-response/match
(get-status-response/match communicator
communicator #rx"([0-9]+) ([0-9]+)"
#rx"([0-9]+) ([0-9]+)" #f)])
#f)]) result))))
result)))))
;; get-message/complete : ;; get-message/complete :
;; communicator x number -> list (string) x list (string) ;; communicator x number -> list (string) x list (string)
(define get-message/complete (define (get-message/complete communicator message)
(lambda (communicator message) (confirm-transaction-mode
(confirm-transaction-mode communicator communicator
"cannot get message headers unless in transaction state") "cannot get message headers unless in transaction state")
(send-to-server communicator "RETR ~a" message) (send-to-server communicator "RETR ~a" message)
(let ([status (get-status-response/basic communicator)]) (let ([status (get-status-response/basic communicator)])
(cond (cond
[(+ok? status) [(+ok? status)
(split-header/body (get-multi-line-response communicator))] (split-header/body (get-multi-line-response communicator))]
[(-err? status) [(-err? status)
((signal-error make-illegal-message-number ((signal-error make-illegal-message-number
"not given message ~a" message) "not given message ~a" message)
communicator message)])))) communicator message)])))
;; get-message/headers : ;; get-message/headers :
;; communicator x number -> list (string) ;; communicator x number -> list (string)
(define get-message/headers (define (get-message/headers communicator message)
(lambda (communicator message) (confirm-transaction-mode
(confirm-transaction-mode communicator communicator
"cannot get message headers unless in transaction state") "cannot get message headers unless in transaction state")
(send-to-server communicator "TOP ~a 0" message) (send-to-server communicator "TOP ~a 0" message)
(let ([status (get-status-response/basic communicator)]) (let ([status (get-status-response/basic communicator)])
(cond (cond
[(+ok? status) [(+ok? status)
(let-values ([(headers body) (let-values ([(headers body)
(split-header/body (split-header/body
(get-multi-line-response communicator))]) (get-multi-line-response communicator))])
headers)] headers)]
[(-err? status) [(-err? status)
((signal-error make-not-given-headers ((signal-error make-not-given-headers
"not given headers to message ~a" message) "not given headers to message ~a" message)
communicator message)])))) communicator message)])))
;; get-message/body : ;; get-message/body :
;; communicator x number -> list (string) ;; communicator x number -> list (string)
(define get-message/body (define (get-message/body communicator message)
(lambda (communicator message) (let-values ([(headers body) (get-message/complete communicator message)])
(let-values ([(headers body) (get-message/complete communicator message)]) body))
body)))
;; split-header/body : ;; split-header/body :
;; list (string) -> list (string) x list (string) ;; list (string) -> list (string) x list (string)
;; -- returns list of headers and list of body lines. ;; -- returns list of headers and list of body lines.
(define split-header/body (define (split-header/body lines)
(lambda (lines) (let loop ([lines lines] [header null])
(let loop ([lines lines] [header null]) (if (null? lines)
(if (null? lines) (values (reverse header) null)
(values (reverse header) null) (let ([first (car lines)]
(let ([first (car lines)] [rest (cdr lines)])
[rest (cdr lines)]) (if (string=? first "")
(if (string=? first "") (values (reverse header) rest)
(values (reverse header) rest) (loop rest (cons first header)))))))
(loop rest (cons first header))))))))
;; delete-message : ;; delete-message :
;; communicator x number -> () ;; communicator x number -> ()
(define delete-message (define (delete-message communicator message)
(lambda (communicator message) (confirm-transaction-mode
(confirm-transaction-mode communicator communicator
"cannot delete message unless in transaction state") "cannot delete message unless in transaction state")
(send-to-server communicator "DELE ~a" message) (send-to-server communicator "DELE ~a" message)
(let ([status (get-status-response/basic communicator)]) (let ([status (get-status-response/basic communicator)])
(cond (cond
[(-err? status) [(-err? status)
((signal-error make-cannot-delete-message ((signal-error make-cannot-delete-message
"no message numbered ~a available to be deleted" message) "no message numbered ~a available to be deleted" message)
communicator message)] communicator message)]
[(+ok? status) [(+ok? status)
'deleted])))) 'deleted])))
;; regexp for UIDL responses ;; regexp for UIDL responses
@ -223,8 +217,9 @@
;; communicator x number -> string ;; communicator x number -> string
(define (get-unique-id/single communicator message) (define (get-unique-id/single communicator message)
(confirm-transaction-mode communicator (confirm-transaction-mode
"cannot get unique message id unless in transaction state") communicator
"cannot get unique message id unless in transaction state")
(send-to-server communicator "UIDL ~a" message) (send-to-server communicator "UIDL ~a" message)
(let-values ([(status result) (let-values ([(status result)
(get-status-response/match communicator uidl-regexp ".*")]) (get-status-response/match communicator uidl-regexp ".*")])
@ -259,43 +254,39 @@
;; close-communicator : ;; close-communicator :
;; communicator -> () ;; communicator -> ()
(define close-communicator (define (close-communicator communicator)
(lambda (communicator) (close-input-port (communicator-receiver communicator))
(close-input-port (communicator-receiver communicator)) (close-output-port (communicator-sender communicator)))
(close-output-port (communicator-sender communicator))))
;; disconnect-from-server : ;; disconnect-from-server :
;; communicator -> () ;; communicator -> ()
(define disconnect-from-server (define (disconnect-from-server communicator)
(lambda (communicator) (send-to-server communicator "QUIT")
(send-to-server communicator "QUIT") (set-communicator-state! communicator 'disconnected)
(set-communicator-state! communicator 'disconnected) (let ([response (get-status-response/basic communicator)])
(let ([response (get-status-response/basic communicator)]) (close-communicator communicator)
(close-communicator communicator) (cond
(cond [(+ok? response) (void)]
[(+ok? response) (void)] [(-err? response)
[(-err? response) ((signal-error make-disconnect-not-quiet
((signal-error make-disconnect-not-quiet "got error status upon disconnect")
"got error status upon disconnect") communicator)])))
communicator)]))))
;; send-to-server : ;; send-to-server :
;; communicator x format-string x list (values) -> () ;; communicator x format-string x list (values) -> ()
(define send-to-server (define (send-to-server communicator message-template . rest)
(lambda (communicator message-template . rest) (apply fprintf (communicator-sender communicator)
(apply fprintf (communicator-sender communicator) (string-append message-template "\r\n")
(string-append message-template "\r\n") rest)
rest) (flush-output (communicator-sender communicator)))
(flush-output (communicator-sender communicator))))
;; get-one-line-from-server : ;; get-one-line-from-server :
;; iport -> string ;; iport -> string
(define get-one-line-from-server (define (get-one-line-from-server server->client-port)
(lambda (server->client-port) (read-line server->client-port 'return-linefeed))
(read-line server->client-port 'return-linefeed)))
;; get-server-status-response : ;; get-server-status-response :
;; communicator -> server-responses x string ;; communicator -> server-responses x string
@ -305,17 +296,16 @@
;; rest of the status response as a string to be used for further ;; rest of the status response as a string to be used for further
;; parsing, if necessary. ;; parsing, if necessary.
(define get-server-status-response (define (get-server-status-response communicator)
(lambda (communicator) (let* ([receiver (communicator-receiver communicator)]
(let* ([receiver (communicator-receiver communicator)] [status-line (get-one-line-from-server receiver)]
[status-line (get-one-line-from-server receiver)] [r (regexp-match #rx"^\\+OK(.*)" status-line)])
[r (regexp-match #rx"^\\+OK(.*)" status-line)]) (if r
(if r (values (make-+ok) (cadr r))
(values (make-+ok) (cadr r)) (let ([r (regexp-match #rx"^\\-ERR(.*)" status-line)])
(let ([r (regexp-match #rx"^\\-ERR(.*)" status-line)]) (if r
(if r (values (make--err) (cadr r))
(values (make--err) (cadr r)) (signal-malformed-response-error communicator))))))
(signal-malformed-response-error communicator)))))))
;; get-status-response/basic : ;; get-status-response/basic :
;; communicator -> server-responses ;; communicator -> server-responses
@ -323,11 +313,10 @@
;; -- when the only thing to determine is whether the response ;; -- when the only thing to determine is whether the response
;; was +OK or -ERR. ;; was +OK or -ERR.
(define get-status-response/basic (define (get-status-response/basic communicator)
(lambda (communicator) (let-values ([(response rest)
(let-values ([(response rest) (get-server-status-response communicator)])
(get-server-status-response communicator)]) response))
response)))
;; get-status-response/match : ;; get-status-response/match :
;; communicator x regexp x regexp -> (status x list (string)) ;; communicator x regexp x regexp -> (status x list (string))
@ -335,71 +324,67 @@
;; -- when further parsing of the status response is necessary. ;; -- when further parsing of the status response is necessary.
;; Strips off the car of response from regexp-match. ;; Strips off the car of response from regexp-match.
(define get-status-response/match (define (get-status-response/match communicator +regexp -regexp)
(lambda (communicator +regexp -regexp) (let-values ([(response rest)
(let-values ([(response rest) (get-server-status-response communicator)])
(get-server-status-response communicator)]) (if (and +regexp (+ok? response))
(if (and +regexp (+ok? response)) (let ([r (regexp-match +regexp rest)])
(let ([r (regexp-match +regexp rest)]) (if r (values response (cdr r))
(signal-malformed-response-error communicator)))
(if (and -regexp (-err? response))
(let ([r (regexp-match -regexp rest)])
(if r (values response (cdr r)) (if r (values response (cdr r))
(signal-malformed-response-error communicator))) (signal-malformed-response-error communicator)))
(if (and -regexp (-err? response)) (signal-malformed-response-error communicator)))))
(let ([r (regexp-match -regexp rest)])
(if r (values response (cdr r))
(signal-malformed-response-error communicator)))
(signal-malformed-response-error communicator))))))
;; get-multi-line-response : ;; get-multi-line-response :
;; communicator -> list (string) ;; communicator -> list (string)
(define get-multi-line-response (define (get-multi-line-response communicator)
(lambda (communicator) (let ([receiver (communicator-receiver communicator)])
(let ([receiver (communicator-receiver communicator)]) (let loop ()
(let loop () (let ([l (get-one-line-from-server receiver)])
(let ([l (get-one-line-from-server receiver)]) (cond
(cond [(eof-object? l)
[(eof-object? l) (signal-malformed-response-error communicator)]
(signal-malformed-response-error communicator)] [(string=? l ".")
[(string=? l ".") '()]
'()] [(and (> (string-length l) 1)
[(and (> (string-length l) 1) (char=? (string-ref l 0) #\.))
(char=? (string-ref l 0) #\.)) (cons (substring l 1 (string-length l)) (loop))]
(cons (substring l 1 (string-length l)) (loop))] [else
[else (cons l (loop))])))))
(cons l (loop))]))))))
;; make-desired-header : ;; make-desired-header :
;; string -> desired ;; string -> desired
(define make-desired-header (define (make-desired-header raw-header)
(lambda (raw-header) (regexp
(regexp (string-append
(string-append "^"
"^" (list->string
(list->string (apply append
(apply append (map (lambda (c)
(map (lambda (c) (cond
(cond [(char-lower-case? c)
[(char-lower-case? c) (list #\[ (char-upcase c) c #\])]
(list #\[ (char-upcase c) c #\])] [(char-upper-case? c)
[(char-upper-case? c) (list #\[ c (char-downcase c) #\])]
(list #\[ c (char-downcase c) #\])] [else
[else (list c)]))
(list c)])) (string->list raw-header))))
(string->list raw-header)))) ":")))
":"))))
;; extract-desired-headers : ;; extract-desired-headers :
;; list (string) x list (desired) -> list (string) ;; list (string) x list (desired) -> list (string)
(define extract-desired-headers (define (extract-desired-headers headers desireds)
(lambda (headers desireds) (let loop ([headers headers])
(let loop ([headers headers]) (if (null? headers) null
(if (null? headers) null (let ([first (car headers)]
(let ([first (car headers)] [rest (cdr headers)])
[rest (cdr headers)]) (if (ormap (lambda (matcher)
(if (ormap (lambda (matcher) (regexp-match matcher first))
(regexp-match matcher first)) desireds)
desireds) (cons first (loop rest))
(cons first (loop rest)) (loop rest)))))))
(loop rest))))))))

16
collects/net/smtp-unit.ss
View File

@ -8,8 +8,6 @@
(define debug-via-stdio? #f) (define debug-via-stdio? #f)
(define crlf (string #\return #\linefeed))
(define (log . args) (define (log . args)
;; (apply printf args) ;; (apply printf args)
(void)) (void))
@ -61,7 +59,7 @@
(raise x))]) (raise x))])
(check-reply r 220 w) (check-reply r 220 w)
(log "hello\n") (log "hello\n")
(fprintf w "EHLO ~a~a" (smtp-sending-server) crlf) (fprintf w "EHLO ~a\r\n" (smtp-sending-server))
(check-reply r 250 w) (check-reply r 250 w)
(when auth-user (when auth-user
@ -74,36 +72,36 @@
(check-reply r 235 w)) (check-reply r 235 w))
(log "from\n") (log "from\n")
(fprintf w "MAIL FROM:<~a>~a" sender crlf) (fprintf w "MAIL FROM:<~a>\r\n" sender)
(check-reply r 250 w) (check-reply r 250 w)
(log "to\n") (log "to\n")
(for-each (for-each
(lambda (dest) (lambda (dest)
(fprintf w "RCPT TO:<~a>~a" dest crlf) (fprintf w "RCPT TO:<~a>\r\n" dest)
(check-reply r 250 w)) (check-reply r 250 w))
recipients) recipients)
(log "header\n") (log "header\n")
(fprintf w "DATA~a" crlf) (fprintf w "DATA\r\n")
(check-reply r 354 w) (check-reply r 354 w)
(fprintf w "~a" header) (fprintf w "~a" header)
(for-each (for-each
(lambda (l) (lambda (l)
(log "body: ~a\n" l) (log "body: ~a\n" l)
(fprintf w "~a~a" (protect-line l) crlf)) (fprintf w "~a\r\n" (protect-line l)))
message-lines) message-lines)
;; After we send the ".", then only break in an emergency ;; After we send the ".", then only break in an emergency
((smtp-sending-end-of-message)) ((smtp-sending-end-of-message))
(log "dot\n") (log "dot\n")
(fprintf w ".~a" crlf) (fprintf w ".\r\n")
(flush-output w) (flush-output w)
(check-reply r 250 w) (check-reply r 250 w)
(log "quit\n") (log "quit\n")
(fprintf w "QUIT~a" crlf) (fprintf w "QUIT\r\n")
(check-reply r 221 w) (check-reply r 221 w)
(close-output-port w) (close-output-port w)