more formatting etc
svn: r5048
This commit is contained in:
Eli Barzilay
parent
f17f7bc479
commit
680c0f419a
|
|
@ -146,72 +146,67 @@
|
|||
;; get-headers : input-port -> string
|
||||
;; returns the header part of a message/part conforming to rfc822, and
|
||||
;; rfc2045.
|
||||
(define get-headers
|
||||
(lambda (in)
|
||||
(let loop ([headers ""] [ln (read-line in 'any)])
|
||||
(cond [(eof-object? ln)
|
||||
;; (raise (make-unexpected-termination "eof reached! while parsing headers"))
|
||||
(warning "premature eof while parsing headers")
|
||||
headers]
|
||||
[(string=? ln "") headers]
|
||||
[else
|
||||
;; Quoting rfc822:
|
||||
;; " Headers occur before the message body and are
|
||||
;; terminated by a null line (i.e., two contiguous
|
||||
;; CRLFs)."
|
||||
;; That is: Two empty lines. But most MUAs seem to count
|
||||
;; the CRLF ending the last field (header) as the first
|
||||
;; CRLF of the null line.
|
||||
(loop (string-append headers ln CRLF)
|
||||
(read-line in 'any))]))))
|
||||
(define (get-headers in)
|
||||
(let loop ([headers ""] [ln (read-line in 'any)])
|
||||
(cond [(eof-object? ln)
|
||||
;; (raise (make-unexpected-termination "eof reached! while parsing headers"))
|
||||
(warning "premature eof while parsing headers")
|
||||
headers]
|
||||
[(string=? ln "") headers]
|
||||
[else
|
||||
;; Quoting rfc822:
|
||||
;; " Headers occur before the message body and are
|
||||
;; terminated by a null line (i.e., two contiguous
|
||||
;; CRLFs)."
|
||||
;; That is: Two empty lines. But most MUAs seem to count
|
||||
;; the CRLF ending the last field (header) as the first
|
||||
;; CRLF of the null line.
|
||||
(loop (string-append headers ln CRLF)
|
||||
(read-line in 'any))])))
|
||||
|
||||
(define make-default-disposition
|
||||
(lambda ()
|
||||
(make-disposition
|
||||
'inline ;; type
|
||||
"" ;; filename
|
||||
#f ;; creation
|
||||
#f ;; modification
|
||||
#f ;; read
|
||||
#f ;; size
|
||||
null ;; params
|
||||
)))
|
||||
(define (make-default-disposition)
|
||||
(make-disposition
|
||||
'inline ;; type
|
||||
"" ;; filename
|
||||
#f ;; creation
|
||||
#f ;; modification
|
||||
#f ;; read
|
||||
#f ;; size
|
||||
null ;; params
|
||||
))
|
||||
|
||||
(define make-default-entity
|
||||
(lambda ()
|
||||
(make-entity
|
||||
'text ;; type
|
||||
'plain ;; subtype
|
||||
'us-ascii ;; charset
|
||||
'7bit ;; encoding
|
||||
(make-default-disposition) ;; disposition
|
||||
null ;; params
|
||||
"" ;; id
|
||||
"" ;; description
|
||||
null ;; other MIME fields (MIME-extension-fields)
|
||||
null ;; fields
|
||||
null ;; parts
|
||||
null ;; body
|
||||
)))
|
||||
(define (make-default-entity)
|
||||
(make-entity
|
||||
'text ;; type
|
||||
'plain ;; subtype
|
||||
'us-ascii ;; charset
|
||||
'7bit ;; encoding
|
||||
(make-default-disposition) ;; disposition
|
||||
null ;; params
|
||||
"" ;; id
|
||||
"" ;; description
|
||||
null ;; other MIME fields (MIME-extension-fields)
|
||||
null ;; fields
|
||||
null ;; parts
|
||||
null ;; body
|
||||
))
|
||||
|
||||
(define make-default-message
|
||||
(lambda ()
|
||||
(make-message 1.0 (make-default-entity) null)))
|
||||
(define (make-default-message)
|
||||
(make-message 1.0 (make-default-entity) null))
|
||||
|
||||
(define mime-decode
|
||||
(lambda (entity input)
|
||||
(set-entity-body!
|
||||
entity
|
||||
(case (entity-encoding entity)
|
||||
[(quoted-printable)
|
||||
(lambda (output)
|
||||
(qp-decode-stream input output))]
|
||||
[(base64)
|
||||
(lambda (output)
|
||||
(base64-decode-stream input output))]
|
||||
[else ;; 7bit, 8bit, binary
|
||||
(lambda (output)
|
||||
(copy-port input output))]))))
|
||||
(define (mime-decode entity input)
|
||||
(set-entity-body!
|
||||
entity
|
||||
(case (entity-encoding entity)
|
||||
[(quoted-printable)
|
||||
(lambda (output)
|
||||
(qp-decode-stream input output))]
|
||||
[(base64)
|
||||
(lambda (output)
|
||||
(base64-decode-stream input output))]
|
||||
[else ;; 7bit, 8bit, binary
|
||||
(lambda (output)
|
||||
(copy-port input output))])))
|
||||
|
||||
(define mime-analyze
|
||||
(opt-lambda (input (part #f))
|
||||
|
|
@ -245,11 +240,10 @@
|
|||
;; return mime structure
|
||||
msg)))
|
||||
|
||||
(define entity-boundary
|
||||
(lambda (entity)
|
||||
(let* ([params (entity-params entity)]
|
||||
[ans (assoc "boundary" params)])
|
||||
(and ans (cdr ans)))))
|
||||
(define (entity-boundary entity)
|
||||
(let* ([params (entity-params entity)]
|
||||
[ans (assoc "boundary" params)])
|
||||
(and ans (cdr ans))))
|
||||
|
||||
;; *************************************************
|
||||
;; MIME Specific: rfc2045-2049, and rfc0822, rfc2183
|
||||
|
|
@ -261,38 +255,37 @@
|
|||
;; close-delimiter transport-padding
|
||||
;; [CRLF epilogue]
|
||||
;; Returns a list of input ports, each one containing the correspongind part.
|
||||
(define multipart-body
|
||||
(lambda (input boundary)
|
||||
(let* ([make-re (lambda (prefix)
|
||||
(regexp (string-append prefix "--" (regexp-quote boundary) "(--)?\r\n")))]
|
||||
[re (make-re "\r\n")])
|
||||
(letrec ([eat-part (lambda ()
|
||||
(let-values ([(pin pout) (make-pipe)])
|
||||
(let ([m (regexp-match re input 0 #f pout)])
|
||||
(cond
|
||||
[(not m)
|
||||
(close-output-port pout)
|
||||
(values pin ;; part
|
||||
#f ;; close-delimiter?
|
||||
#t ;; eof reached?
|
||||
)]
|
||||
[(cadr m)
|
||||
(close-output-port pout)
|
||||
(values pin #t #f)]
|
||||
[else
|
||||
(close-output-port pout)
|
||||
(values pin #f #f)]))))])
|
||||
;; pre-amble is allowed to be completely empty:
|
||||
(if (regexp-match-peek (make-re "^") input)
|
||||
;; No \r\f before first separator:
|
||||
(read-line input)
|
||||
;; non-empty preamble:
|
||||
(eat-part))
|
||||
(let loop ()
|
||||
(let-values ([(part close? eof?) (eat-part)])
|
||||
(cond (close? (list part))
|
||||
(eof? (list part))
|
||||
(else (cons part (loop))))))))))
|
||||
(define (multipart-body input boundary)
|
||||
(let* ([make-re (lambda (prefix)
|
||||
(regexp (string-append prefix "--" (regexp-quote boundary) "(--)?\r\n")))]
|
||||
[re (make-re "\r\n")])
|
||||
(letrec ([eat-part (lambda ()
|
||||
(let-values ([(pin pout) (make-pipe)])
|
||||
(let ([m (regexp-match re input 0 #f pout)])
|
||||
(cond
|
||||
[(not m)
|
||||
(close-output-port pout)
|
||||
(values pin ;; part
|
||||
#f ;; close-delimiter?
|
||||
#t ;; eof reached?
|
||||
)]
|
||||
[(cadr m)
|
||||
(close-output-port pout)
|
||||
(values pin #t #f)]
|
||||
[else
|
||||
(close-output-port pout)
|
||||
(values pin #f #f)]))))])
|
||||
;; pre-amble is allowed to be completely empty:
|
||||
(if (regexp-match-peek (make-re "^") input)
|
||||
;; No \r\f before first separator:
|
||||
(read-line input)
|
||||
;; non-empty preamble:
|
||||
(eat-part))
|
||||
(let loop ()
|
||||
(let-values ([(part close? eof?) (eat-part)])
|
||||
(cond [close? (list part)]
|
||||
[eof? (list part)]
|
||||
[else (cons part (loop))]))))))
|
||||
|
||||
;; MIME-message-headers := entity-headers
|
||||
;; fields
|
||||
|
|
@ -300,11 +293,10 @@
|
|||
;; ; The ordering of the header
|
||||
;; ; fields implied by this BNF
|
||||
;; ; definition should be ignored.
|
||||
(define MIME-message-headers
|
||||
(lambda (headers)
|
||||
(let ([message (make-default-message)])
|
||||
(entity-headers headers message #t)
|
||||
message)))
|
||||
(define (MIME-message-headers headers)
|
||||
(let ([message (make-default-message)])
|
||||
(entity-headers headers message #t)
|
||||
message))
|
||||
|
||||
;; MIME-part-headers := entity-headers
|
||||
;; [ fields ]
|
||||
|
|
@ -314,63 +306,59 @@
|
|||
;; ; The ordering of the header
|
||||
;; ; fields implied by this BNF
|
||||
;; ; definition should be ignored.
|
||||
(define MIME-part-headers
|
||||
(lambda (headers)
|
||||
(let ([message (make-default-message)])
|
||||
(entity-headers headers message #f)
|
||||
message)))
|
||||
(define (MIME-part-headers headers)
|
||||
(let ([message (make-default-message)])
|
||||
(entity-headers headers message #f)
|
||||
message))
|
||||
|
||||
;; entity-headers := [ content CRLF ]
|
||||
;; [ encoding CRLF ]
|
||||
;; [ id CRLF ]
|
||||
;; [ description CRLF ]
|
||||
;; *( MIME-extension-field CRLF )
|
||||
(define entity-headers
|
||||
(lambda (headers message version?)
|
||||
(let ([entity (message-entity message)])
|
||||
(let-values ([(mime non-mime) (get-fields headers)])
|
||||
(let loop ([fields mime])
|
||||
(unless (null? fields)
|
||||
;; Process MIME field
|
||||
(let ([trimmed-h (trim-comments (car fields))])
|
||||
(or (and version? (version trimmed-h message))
|
||||
(content trimmed-h entity)
|
||||
(encoding trimmed-h entity)
|
||||
(dispositione trimmed-h entity)
|
||||
(id trimmed-h entity)
|
||||
(description trimmed-h entity)
|
||||
(MIME-extension-field trimmed-h entity))
|
||||
;; keep going
|
||||
(loop (cdr fields)))))
|
||||
;; NON-mime headers (or semantically incorrect). In order to make
|
||||
;; this implementation of rfc2045 robuts, we will save the header in
|
||||
;; the fields field of the message struct:
|
||||
(set-message-fields! message non-mime)
|
||||
;; Return message
|
||||
message))))
|
||||
(define (entity-headers headers message version?)
|
||||
(let ([entity (message-entity message)])
|
||||
(let-values ([(mime non-mime) (get-fields headers)])
|
||||
(let loop ([fields mime])
|
||||
(unless (null? fields)
|
||||
;; Process MIME field
|
||||
(let ([trimmed-h (trim-comments (car fields))])
|
||||
(or (and version? (version trimmed-h message))
|
||||
(content trimmed-h entity)
|
||||
(encoding trimmed-h entity)
|
||||
(dispositione trimmed-h entity)
|
||||
(id trimmed-h entity)
|
||||
(description trimmed-h entity)
|
||||
(MIME-extension-field trimmed-h entity))
|
||||
;; keep going
|
||||
(loop (cdr fields)))))
|
||||
;; NON-mime headers (or semantically incorrect). In order to make
|
||||
;; this implementation of rfc2045 robuts, we will save the header in
|
||||
;; the fields field of the message struct:
|
||||
(set-message-fields! message non-mime)
|
||||
;; Return message
|
||||
message)))
|
||||
|
||||
(define get-fields
|
||||
(lambda (headers)
|
||||
(let ([mime null] [non-mime null])
|
||||
(letrec ([store-field
|
||||
(lambda (f)
|
||||
(unless (string=? f "")
|
||||
(if (mime-header? f)
|
||||
(set! mime (append mime (list (trim-spaces f))))
|
||||
(set! non-mime (append non-mime (list (trim-spaces f)))))))])
|
||||
(let ([fields (extract-all-fields headers)])
|
||||
(for-each (lambda (p)
|
||||
(store-field (format "~a: ~a" (car p) (cdr p))))
|
||||
fields))
|
||||
(values mime non-mime)))))
|
||||
(define (get-fields headers)
|
||||
(let ([mime null] [non-mime null])
|
||||
(letrec ([store-field
|
||||
(lambda (f)
|
||||
(unless (string=? f "")
|
||||
(if (mime-header? f)
|
||||
(set! mime (append mime (list (trim-spaces f))))
|
||||
(set! non-mime (append non-mime (list (trim-spaces f)))))))])
|
||||
(let ([fields (extract-all-fields headers)])
|
||||
(for-each (lambda (p)
|
||||
(store-field (format "~a: ~a" (car p) (cdr p))))
|
||||
fields))
|
||||
(values mime non-mime))))
|
||||
|
||||
(define re:content (regexp (format "^~a" (regexp-quote "content-" #f))))
|
||||
(define re:mime (regexp (format "^~a:" (regexp-quote "mime-version" #f))))
|
||||
|
||||
(define mime-header?
|
||||
(lambda (h)
|
||||
(or (regexp-match re:content h)
|
||||
(regexp-match re:mime h))))
|
||||
(define (mime-header? h)
|
||||
(or (regexp-match? re:content h)
|
||||
(regexp-match? re:mime h)))
|
||||
|
||||
;;; Headers
|
||||
;;; Content-type follows this BNF syntax:
|
||||
|
|
@ -380,103 +368,97 @@
|
|||
;; ; is ALWAYS case-insensitive.
|
||||
(define re:content-type
|
||||
(regexp (format "^~a:([^/]+)/([^/]+)$" (regexp-quote "content-type" #f))))
|
||||
(define content
|
||||
(lambda (header entity)
|
||||
(let* ([params (string-tokenizer #\; header)]
|
||||
[one re:content-type]
|
||||
[h (trim-all-spaces (car params))]
|
||||
[target (regexp-match one h)]
|
||||
[old-param (entity-params entity)])
|
||||
(and target
|
||||
(set-entity-type! entity
|
||||
(type (regexp-replace one h "\\1"))) ;; type
|
||||
(set-entity-subtype! entity
|
||||
(subtype (regexp-replace one h "\\2"))) ;; subtype
|
||||
(set-entity-params!
|
||||
entity
|
||||
(append old-param
|
||||
(let loop ([p (cdr params)] ;; parameters
|
||||
[ans null])
|
||||
(cond [(null? p) ans]
|
||||
[else
|
||||
(let ([par-pair (parameter (trim-all-spaces (car p)))])
|
||||
(cond [par-pair
|
||||
(when (string=? (car par-pair) "charset")
|
||||
(set-entity-charset! entity (cdr par-pair)))
|
||||
(loop (cdr p)
|
||||
(append ans
|
||||
(list par-pair)))]
|
||||
[else
|
||||
(warning "Invalid parameter for Content-Type: `~a'" (car p))
|
||||
;; go on...
|
||||
(loop (cdr p) ans)]))]))))))))
|
||||
(define (content header entity)
|
||||
(let* ([params (string-tokenizer #\; header)]
|
||||
[one re:content-type]
|
||||
[h (trim-all-spaces (car params))]
|
||||
[target (regexp-match one h)]
|
||||
[old-param (entity-params entity)])
|
||||
(and target
|
||||
(set-entity-type! entity
|
||||
(type (regexp-replace one h "\\1"))) ;; type
|
||||
(set-entity-subtype! entity
|
||||
(subtype (regexp-replace one h "\\2"))) ;; subtype
|
||||
(set-entity-params!
|
||||
entity
|
||||
(append old-param
|
||||
(let loop ([p (cdr params)] ;; parameters
|
||||
[ans null])
|
||||
(cond [(null? p) ans]
|
||||
[else
|
||||
(let ([par-pair (parameter (trim-all-spaces (car p)))])
|
||||
(cond [par-pair
|
||||
(when (string=? (car par-pair) "charset")
|
||||
(set-entity-charset! entity (cdr par-pair)))
|
||||
(loop (cdr p)
|
||||
(append ans
|
||||
(list par-pair)))]
|
||||
[else
|
||||
(warning "Invalid parameter for Content-Type: `~a'" (car p))
|
||||
;; go on...
|
||||
(loop (cdr p) ans)]))])))))))
|
||||
|
||||
;; From rfc2183 Content-Disposition
|
||||
;; disposition := "Content-Disposition" ":"
|
||||
;; disposition-type
|
||||
;; *(";" disposition-parm)
|
||||
(define re:content-disposition (regexp (format "^~a:(.+)$" (regexp-quote "content-disposition" #f))))
|
||||
(define dispositione
|
||||
(lambda (header entity)
|
||||
(let* ([params (string-tokenizer #\; header)]
|
||||
[reg re:content-disposition]
|
||||
[h (trim-all-spaces (car params))]
|
||||
[target (regexp-match reg h)]
|
||||
[disp-struct (entity-disposition entity)])
|
||||
(and target
|
||||
(set-disposition-type!
|
||||
disp-struct
|
||||
(disp-type (regexp-replace reg h "\\1")))
|
||||
(disp-params (cdr params) disp-struct)))))
|
||||
(define (dispositione header entity)
|
||||
(let* ([params (string-tokenizer #\; header)]
|
||||
[reg re:content-disposition]
|
||||
[h (trim-all-spaces (car params))]
|
||||
[target (regexp-match reg h)]
|
||||
[disp-struct (entity-disposition entity)])
|
||||
(and target
|
||||
(set-disposition-type!
|
||||
disp-struct
|
||||
(disp-type (regexp-replace reg h "\\1")))
|
||||
(disp-params (cdr params) disp-struct))))
|
||||
|
||||
;; version := "MIME-Version" ":" 1*DIGIT "." 1*DIGIT
|
||||
(define re:mime-version
|
||||
(regexp (format "^~a:([0-9]+)\\.([0-9]+)$" (regexp-quote "MIME-Version" #f))))
|
||||
(define version
|
||||
(lambda (header message)
|
||||
(let* ([reg re:mime-version]
|
||||
[h (trim-all-spaces header)]
|
||||
[target (regexp-match reg h)])
|
||||
(and target
|
||||
(set-message-version!
|
||||
message
|
||||
(string->number (regexp-replace reg h "\\1.\\2")))))))
|
||||
(define (version header message)
|
||||
(let* ([reg re:mime-version]
|
||||
[h (trim-all-spaces header)]
|
||||
[target (regexp-match reg h)])
|
||||
(and target
|
||||
(set-message-version!
|
||||
message
|
||||
(string->number (regexp-replace reg h "\\1.\\2"))))))
|
||||
|
||||
;; description := "Content-Description" ":" *text
|
||||
(define re:content-description
|
||||
(regexp (format "^~a:[ \t\r\n]*(.*)$" (regexp-quote "content-description" #f))))
|
||||
(define description
|
||||
(lambda (header entity)
|
||||
(let* ([reg re:content-description]
|
||||
[target (regexp-match reg header)])
|
||||
(and target
|
||||
(set-entity-description!
|
||||
entity
|
||||
(trim-spaces (regexp-replace reg header "\\1")))))))
|
||||
(define (description header entity)
|
||||
(let* ([reg re:content-description]
|
||||
[target (regexp-match reg header)])
|
||||
(and target
|
||||
(set-entity-description!
|
||||
entity
|
||||
(trim-spaces (regexp-replace reg header "\\1"))))))
|
||||
|
||||
;; encoding := "Content-Transfer-Encoding" ":" mechanism
|
||||
(define re:content-transfer-encoding (regexp (format "^~a:(.+)$" (regexp-quote "content-transfer-encoding" #f))))
|
||||
(define encoding
|
||||
(lambda (header entity)
|
||||
(let* ([reg re:content-transfer-encoding]
|
||||
[h (trim-all-spaces header)]
|
||||
[target (regexp-match reg h)])
|
||||
(and target
|
||||
(set-entity-encoding!
|
||||
entity
|
||||
(mechanism (regexp-replace reg h "\\1")))))))
|
||||
(define (encoding header entity)
|
||||
(let* ([reg re:content-transfer-encoding]
|
||||
[h (trim-all-spaces header)]
|
||||
[target (regexp-match reg h)])
|
||||
(and target
|
||||
(set-entity-encoding!
|
||||
entity
|
||||
(mechanism (regexp-replace reg h "\\1"))))))
|
||||
|
||||
;; id := "Content-ID" ":" msg-id
|
||||
(define re:content-id (regexp (format "^~a:(.+)$" (regexp-quote "content-id" #f))))
|
||||
(define id
|
||||
(lambda (header entity)
|
||||
(let* ([reg re:content-id]
|
||||
[h (trim-all-spaces header)]
|
||||
[target (regexp-match reg h)])
|
||||
(and target
|
||||
(set-entity-id!
|
||||
entity
|
||||
(msg-id (regexp-replace reg h "\\1")))))))
|
||||
(define (id header entity)
|
||||
(let* ([reg re:content-id]
|
||||
[h (trim-all-spaces header)]
|
||||
[target (regexp-match reg h)])
|
||||
(and target
|
||||
(set-entity-id!
|
||||
entity
|
||||
(msg-id (regexp-replace reg h "\\1"))))))
|
||||
|
||||
;; From rfc822:
|
||||
;; msg-id = "<" addr-spec ">" ; Unique message id
|
||||
|
|
@ -487,84 +469,75 @@
|
|||
;; sub-domain = domain-ref / domain-literal
|
||||
;; domain-literal = "[" *(dtext / quoted-pair) "]"
|
||||
;; domain-ref = atom ; symbolic reference
|
||||
(define msg-id
|
||||
(lambda (str)
|
||||
(let* ([r (regexp "^<[^@>]+@[^.]+(\\.[^.]+)*>$")]
|
||||
[ans (regexp-match r str)])
|
||||
(if ans
|
||||
str
|
||||
(begin (warning "Invalid msg-id: ~a" str) str)))))
|
||||
(define (msg-id str)
|
||||
(let* ([r (regexp "^<[^@>]+@[^.]+(\\.[^.]+)*>$")]
|
||||
[ans (regexp-match r str)])
|
||||
(if ans
|
||||
str
|
||||
(begin (warning "Invalid msg-id: ~a" str) str))))
|
||||
|
||||
;; mechanism := "7bit" / "8bit" / "binary" /
|
||||
;; "quoted-printable" / "base64" /
|
||||
;; ietf-token / x-token
|
||||
(define mechanism
|
||||
(lambda (mech)
|
||||
(if (not mech)
|
||||
(raise (make-empty-mechanism))
|
||||
(let ([val (assoc (lowercase mech) mechanism-alist)])
|
||||
(or (and val (cdr val))
|
||||
(ietf-token mech)
|
||||
(x-token mech))))))
|
||||
(define (mechanism mech)
|
||||
(if (not mech)
|
||||
(raise (make-empty-mechanism))
|
||||
(let ([val (assoc (lowercase mech) mechanism-alist)])
|
||||
(or (and val (cdr val))
|
||||
(ietf-token mech)
|
||||
(x-token mech)))))
|
||||
|
||||
;; MIME-extension-field := <Any RFC 822 header field which
|
||||
;; begins with the string
|
||||
;; "Content-">
|
||||
;;
|
||||
(define MIME-extension-field
|
||||
(lambda (header entity)
|
||||
(let* ([reg (regexp "^[Cc]ontent-(.+):[ \t]*(.+)$")]
|
||||
[target (regexp-match reg header)])
|
||||
(and target
|
||||
(set-entity-other!
|
||||
entity
|
||||
(append (entity-other entity)
|
||||
(list
|
||||
(cons (regexp-replace reg header "\\1")
|
||||
(trim-spaces (regexp-replace reg header "\\2"))))))))))
|
||||
(define (MIME-extension-field header entity)
|
||||
(let* ([reg (regexp "^[Cc]ontent-(.+):[ \t]*(.+)$")]
|
||||
[target (regexp-match reg header)])
|
||||
(and target
|
||||
(set-entity-other!
|
||||
entity
|
||||
(append (entity-other entity)
|
||||
(list
|
||||
(cons (regexp-replace reg header "\\1")
|
||||
(trim-spaces (regexp-replace reg header "\\2")))))))))
|
||||
|
||||
;; type := discrete-type / composite-type
|
||||
(define type
|
||||
(lambda (value)
|
||||
(if (not value)
|
||||
(raise (make-empty-type))
|
||||
(or (discrete-type value)
|
||||
(composite-type value)))))
|
||||
(define (type value)
|
||||
(if (not value)
|
||||
(raise (make-empty-type))
|
||||
(or (discrete-type value)
|
||||
(composite-type value))))
|
||||
|
||||
;; disposition-type := "inline" / "attachment" / extension-token
|
||||
(define disp-type
|
||||
(lambda (value)
|
||||
(if (not value)
|
||||
(raise (make-empty-disposition-type))
|
||||
(let ([val (assoc (lowercase (trim-spaces value)) disposition-alist)])
|
||||
(if val (cdr val) (extension-token value))))))
|
||||
(define (disp-type value)
|
||||
(if (not value)
|
||||
(raise (make-empty-disposition-type))
|
||||
(let ([val (assoc (lowercase (trim-spaces value)) disposition-alist)])
|
||||
(if val (cdr val) (extension-token value)))))
|
||||
|
||||
;; discrete-type := "text" / "image" / "audio" / "video" /
|
||||
;; "application" / extension-token
|
||||
(define discrete-type
|
||||
(lambda (value)
|
||||
(let ([val (assoc (lowercase (trim-spaces value)) discrete-alist)])
|
||||
(if val (cdr val) (extension-token value)))))
|
||||
(define (discrete-type value)
|
||||
(let ([val (assoc (lowercase (trim-spaces value)) discrete-alist)])
|
||||
(if val (cdr val) (extension-token value))))
|
||||
|
||||
;; composite-type := "message" / "multipart" / extension-token
|
||||
(define composite-type
|
||||
(lambda (value)
|
||||
(let ([val (assoc (lowercase (trim-spaces value)) composite-alist)])
|
||||
(if val (cdr val) (extension-token value)))))
|
||||
(define (composite-type value)
|
||||
(let ([val (assoc (lowercase (trim-spaces value)) composite-alist)])
|
||||
(if val (cdr val) (extension-token value))))
|
||||
|
||||
;; extension-token := ietf-token / x-token
|
||||
(define extension-token
|
||||
(lambda (value)
|
||||
(or (ietf-token value)
|
||||
(x-token value))))
|
||||
(define (extension-token value)
|
||||
(or (ietf-token value)
|
||||
(x-token value)))
|
||||
|
||||
;; ietf-token := <An extension token defined by a
|
||||
;; standards-track RFC and registered
|
||||
;; with IANA.>
|
||||
(define ietf-token
|
||||
(lambda (value)
|
||||
(let ([ans (assoc (lowercase (trim-spaces value)) ietf-extensions)])
|
||||
(and ans (cdr ans)))))
|
||||
(define (ietf-token value)
|
||||
(let ([ans (assoc (lowercase (trim-spaces value)) ietf-extensions)])
|
||||
(and ans (cdr ans))))
|
||||
|
||||
;; Directly from RFC 1700:
|
||||
;; Type Subtype Description Reference
|
||||
|
|
@ -619,48 +592,43 @@
|
|||
|
||||
;; x-token := <The two characters "X-" or "x-" followed, with
|
||||
;; no intervening white space, by any token>
|
||||
(define x-token
|
||||
(lambda (value)
|
||||
(let* ([r #rx"^[xX]-(.*)"]
|
||||
[h (trim-spaces value)]
|
||||
[ans (regexp-match r h)])
|
||||
(and ans
|
||||
(token (regexp-replace r h "\\1"))
|
||||
h))))
|
||||
(define (x-token value)
|
||||
(let* ([r #rx"^[xX]-(.*)"]
|
||||
[h (trim-spaces value)]
|
||||
[ans (regexp-match r h)])
|
||||
(and ans
|
||||
(token (regexp-replace r h "\\1"))
|
||||
h)))
|
||||
|
||||
;; subtype := extension-token / iana-token
|
||||
(define subtype
|
||||
(lambda (value)
|
||||
(if (not value)
|
||||
(raise (make-empty-subtype))
|
||||
(or (extension-token value)
|
||||
(iana-token value)))))
|
||||
(define (subtype value)
|
||||
(if (not value)
|
||||
(raise (make-empty-subtype))
|
||||
(or (extension-token value)
|
||||
(iana-token value))))
|
||||
|
||||
;; iana-token := <A publicly-defined extension token. Tokens
|
||||
;; of this form must be registered with IANA
|
||||
;; as specified in RFC 2048.>
|
||||
(define iana-token
|
||||
(lambda (value)
|
||||
(let ([ans (assoc (lowercase (trim-spaces value)) iana-extensions)])
|
||||
(and ans (cdr ans)))))
|
||||
(define (iana-token value)
|
||||
(let ([ans (assoc (lowercase (trim-spaces value)) iana-extensions)])
|
||||
(and ans (cdr ans))))
|
||||
|
||||
;; parameter := attribute "=" value
|
||||
(define re:parameter (regexp "([^=]+)=(.+)"))
|
||||
(define parameter
|
||||
(lambda (par)
|
||||
(let* ([r re:parameter]
|
||||
[att (attribute (regexp-replace r par "\\1"))]
|
||||
[val (value (regexp-replace r par "\\2"))])
|
||||
(if (regexp-match r par)
|
||||
(cons (if att (lowercase att) "???") val)
|
||||
(cons "???" par)))))
|
||||
(define (parameter par)
|
||||
(let* ([r re:parameter]
|
||||
[att (attribute (regexp-replace r par "\\1"))]
|
||||
[val (value (regexp-replace r par "\\2"))])
|
||||
(if (regexp-match r par)
|
||||
(cons (if att (lowercase att) "???") val)
|
||||
(cons "???" par))))
|
||||
|
||||
;; value := token / quoted-string
|
||||
(define value
|
||||
(lambda (val)
|
||||
(or (token val)
|
||||
(quoted-string val)
|
||||
val)))
|
||||
(define (value val)
|
||||
(or (token val)
|
||||
(quoted-string val)
|
||||
val))
|
||||
|
||||
;; token := 1*<any (US-ASCII) CHAR except SPACE, CTLs,
|
||||
;; or tspecials>
|
||||
|
|
@ -669,13 +637,12 @@
|
|||
;; "/" / "[" / "]" / "?" / "="
|
||||
;; ; Must be in quoted-string,
|
||||
;; ; to use within parameter values
|
||||
(define token
|
||||
(lambda (value)
|
||||
(let* ([tspecials (regexp "[^][()<>@,;:\\\"/?= ]+")]
|
||||
[ans (regexp-match tspecials value)])
|
||||
(and ans
|
||||
(string=? value (car ans))
|
||||
(car ans)))))
|
||||
(define (token value)
|
||||
(let* ([tspecials (regexp "[^][()<>@,;:\\\"/?= ]+")]
|
||||
[ans (regexp-match tspecials value)])
|
||||
(and ans
|
||||
(string=? value (car ans))
|
||||
(car ans))))
|
||||
|
||||
;; attribute := token
|
||||
;; ; Matching of attributes
|
||||
|
|
@ -683,11 +650,10 @@
|
|||
(define attribute token)
|
||||
|
||||
(define re:quotes (regexp "\"(.+)\""))
|
||||
(define quoted-string
|
||||
(lambda (str)
|
||||
(let* ([quotes re:quotes]
|
||||
[ans (regexp-match quotes str)])
|
||||
(and ans (regexp-replace quotes str "\\1")))))
|
||||
(define (quoted-string str)
|
||||
(let* ([quotes re:quotes]
|
||||
[ans (regexp-match quotes str)])
|
||||
(and ans (regexp-replace quotes str "\\1"))))
|
||||
|
||||
;; disposition-parm := filename-parm
|
||||
;; / creation-date-parm
|
||||
|
|
@ -705,36 +671,35 @@
|
|||
;; read-date-parm := "read-date" "=" quoted-date-time
|
||||
;;
|
||||
;; size-parm := "size" "=" 1*DIGIT
|
||||
(define disp-params
|
||||
(lambda (lst disp)
|
||||
(let loop ([lst lst])
|
||||
(unless (null? lst)
|
||||
(let* ([p (parameter (trim-all-spaces (car lst)))]
|
||||
[parm (car p)]
|
||||
[value (cdr p)])
|
||||
(cond [(string=? parm "filename")
|
||||
(set-disposition-filename! disp value)]
|
||||
[(string=? parm "creation-date")
|
||||
(set-disposition-creation!
|
||||
disp
|
||||
(disp-quoted-data-time value))]
|
||||
[(string=? parm "modification-date")
|
||||
(set-disposition-modification!
|
||||
disp
|
||||
(disp-quoted-data-time value))]
|
||||
[(string=? parm "read-date")
|
||||
(set-disposition-read!
|
||||
disp
|
||||
(disp-quoted-data-time value))]
|
||||
[(string=? parm "size")
|
||||
(set-disposition-size!
|
||||
disp
|
||||
(string->number value))]
|
||||
[else
|
||||
(set-disposition-params!
|
||||
disp
|
||||
(append (disposition-params disp) (list p)))])
|
||||
(loop (cdr lst)))))))
|
||||
(define (disp-params lst disp)
|
||||
(let loop ([lst lst])
|
||||
(unless (null? lst)
|
||||
(let* ([p (parameter (trim-all-spaces (car lst)))]
|
||||
[parm (car p)]
|
||||
[value (cdr p)])
|
||||
(cond [(string=? parm "filename")
|
||||
(set-disposition-filename! disp value)]
|
||||
[(string=? parm "creation-date")
|
||||
(set-disposition-creation!
|
||||
disp
|
||||
(disp-quoted-data-time value))]
|
||||
[(string=? parm "modification-date")
|
||||
(set-disposition-modification!
|
||||
disp
|
||||
(disp-quoted-data-time value))]
|
||||
[(string=? parm "read-date")
|
||||
(set-disposition-read!
|
||||
disp
|
||||
(disp-quoted-data-time value))]
|
||||
[(string=? parm "size")
|
||||
(set-disposition-size!
|
||||
disp
|
||||
(string->number value))]
|
||||
[else
|
||||
(set-disposition-params!
|
||||
disp
|
||||
(append (disposition-params disp) (list p)))])
|
||||
(loop (cdr lst))))))
|
||||
|
||||
;; date-time = [ day "," ] date time ; dd mm yy
|
||||
;; ; hh:mm:ss zzz
|
||||
|
|
|
|||
|
|
@ -38,92 +38,84 @@
|
|||
|
||||
;; string-index returns the leftmost index in string s
|
||||
;; that has character c
|
||||
(define string-index
|
||||
(lambda (s c)
|
||||
(let ([n (string-length s)])
|
||||
(let loop ([i 0])
|
||||
(cond [(>= i n) #f]
|
||||
[(char=? (string-ref s i) c) i]
|
||||
[else (loop (+ i 1))])))))
|
||||
(define (string-index s c)
|
||||
(let ([n (string-length s)])
|
||||
(let loop ([i 0])
|
||||
(cond [(>= i n) #f]
|
||||
[(char=? (string-ref s i) c) i]
|
||||
[else (loop (+ i 1))]))))
|
||||
|
||||
;; string-tokenizer breaks string s into substrings separated by character c
|
||||
(define string-tokenizer
|
||||
(lambda (c s)
|
||||
(let loop ([s s])
|
||||
(if (string=? s "") '()
|
||||
(let ([i (string-index s c)])
|
||||
(if i (cons (substring s 0 i)
|
||||
(loop (substring s (+ i 1)
|
||||
(string-length s))))
|
||||
(list s)))))))
|
||||
(define (string-tokenizer c s)
|
||||
(let loop ([s s])
|
||||
(if (string=? s "") '()
|
||||
(let ([i (string-index s c)])
|
||||
(if i (cons (substring s 0 i)
|
||||
(loop (substring s (+ i 1)
|
||||
(string-length s))))
|
||||
(list s))))))
|
||||
|
||||
;; Trim all spaces, except those in quoted strings.
|
||||
(define re:quote-start (regexp "\""))
|
||||
(define re:space (regexp "[ \t\n\r\v]"))
|
||||
(define trim-all-spaces
|
||||
(lambda (str)
|
||||
;; Break out alternate quoted and unquoted parts.
|
||||
;; Initial and final string are unquoted.
|
||||
(let-values ([(unquoted quoted)
|
||||
(let loop ([str str] [unquoted null] [quoted null])
|
||||
(let ([m (regexp-match-positions re:quote-start str)])
|
||||
(if m
|
||||
(let ([prefix (substring str 0 (caar m))]
|
||||
[rest (substring str (add1 (caar m)) (string-length str))])
|
||||
;; Find closing quote
|
||||
(let ([m (regexp-match-positions re:quote-start rest)])
|
||||
(if m
|
||||
(let ([inside (substring rest 0 (caar m))]
|
||||
[rest (substring rest (add1 (caar m)) (string-length rest))])
|
||||
(loop rest (cons prefix unquoted) (cons (format "\"~a\"" inside) quoted)))
|
||||
;; No closing quote!
|
||||
(loop "" (cons prefix unquoted) (cons (format "\"~a" rest) quoted)))))
|
||||
(values (reverse! (cons str unquoted)) (reverse! quoted)))))])
|
||||
;; Put the pieces back together, stripping spaces for unquoted parts:
|
||||
(apply
|
||||
string-append
|
||||
(let loop ([unquoted unquoted][quoted quoted])
|
||||
(let ([clean (regexp-replace* re:space (car unquoted) "")])
|
||||
(if (null? quoted)
|
||||
(list clean)
|
||||
(list* clean
|
||||
(car quoted)
|
||||
(loop (cdr unquoted) (cdr quoted))))))))))
|
||||
(define (trim-all-spaces str)
|
||||
;; Break out alternate quoted and unquoted parts.
|
||||
;; Initial and final string are unquoted.
|
||||
(let-values ([(unquoted quoted)
|
||||
(let loop ([str str] [unquoted null] [quoted null])
|
||||
(let ([m (regexp-match-positions re:quote-start str)])
|
||||
(if m
|
||||
(let ([prefix (substring str 0 (caar m))]
|
||||
[rest (substring str (add1 (caar m)) (string-length str))])
|
||||
;; Find closing quote
|
||||
(let ([m (regexp-match-positions re:quote-start rest)])
|
||||
(if m
|
||||
(let ([inside (substring rest 0 (caar m))]
|
||||
[rest (substring rest (add1 (caar m)) (string-length rest))])
|
||||
(loop rest (cons prefix unquoted) (cons (format "\"~a\"" inside) quoted)))
|
||||
;; No closing quote!
|
||||
(loop "" (cons prefix unquoted) (cons (format "\"~a" rest) quoted)))))
|
||||
(values (reverse! (cons str unquoted)) (reverse! quoted)))))])
|
||||
;; Put the pieces back together, stripping spaces for unquoted parts:
|
||||
(apply
|
||||
string-append
|
||||
(let loop ([unquoted unquoted][quoted quoted])
|
||||
(let ([clean (regexp-replace* re:space (car unquoted) "")])
|
||||
(if (null? quoted)
|
||||
(list clean)
|
||||
(list* clean
|
||||
(car quoted)
|
||||
(loop (cdr unquoted) (cdr quoted)))))))))
|
||||
|
||||
;; Only trims left and right spaces:
|
||||
(define trim-spaces
|
||||
(lambda (str)
|
||||
(trim-right (trim-left str))))
|
||||
(define (trim-spaces str)
|
||||
(trim-right (trim-left str)))
|
||||
|
||||
(define re:left-spaces (regexp "^[ \t\r\n\v]+"))
|
||||
(define trim-left
|
||||
(lambda (str)
|
||||
(regexp-replace re:left-spaces str "")))
|
||||
(define (trim-left str)
|
||||
(regexp-replace re:left-spaces str ""))
|
||||
|
||||
(define re:right-spaces (regexp "[ \t\r\n\v]+$"))
|
||||
(define trim-right
|
||||
(lambda (str)
|
||||
(regexp-replace re:right-spaces str "")))
|
||||
(define (trim-right str)
|
||||
(regexp-replace re:right-spaces str ""))
|
||||
|
||||
(define re:comments (regexp "^[^\"]*(\"[^\"]*\")*[^\"]*(\\(.*\\))"))
|
||||
(define trim-comments
|
||||
(lambda (str)
|
||||
(let ([positions (regexp-match-positions re:comments str)])
|
||||
(if positions
|
||||
(string-append (substring str 0 (caaddr positions))
|
||||
(substring str (cdaddr positions) (string-length str)))
|
||||
str))))
|
||||
(define (trim-comments str)
|
||||
(let ([positions (regexp-match-positions re:comments str)])
|
||||
(if positions
|
||||
(string-append (substring str 0 (caaddr positions))
|
||||
(substring str (cdaddr positions) (string-length str)))
|
||||
str)))
|
||||
|
||||
(define lowercase
|
||||
(lambda (str)
|
||||
(let loop ([out ""] [rest str] [size (string-length str)])
|
||||
(cond [(zero? size) out]
|
||||
[else
|
||||
(loop (string-append out (string
|
||||
(char-downcase
|
||||
(string-ref rest 0))))
|
||||
(substring rest 1 size)
|
||||
(sub1 size))]))))
|
||||
(define (lowercase str)
|
||||
(let loop ([out ""] [rest str] [size (string-length str)])
|
||||
(cond [(zero? size) out]
|
||||
[else
|
||||
(loop (string-append out (string
|
||||
(char-downcase
|
||||
(string-ref rest 0))))
|
||||
(substring rest 1 size)
|
||||
(sub1 size))])))
|
||||
|
||||
(define warning
|
||||
void
|
||||
|
|
|
|||
|
|
@ -35,13 +35,12 @@
|
|||
|
||||
;; - throws an exception
|
||||
|
||||
(define signal-error
|
||||
(lambda (constructor format-string . args)
|
||||
(lambda exn-args
|
||||
(raise (apply constructor
|
||||
(string->immutable-string (apply format format-string args))
|
||||
(current-continuation-marks)
|
||||
exn-args)))))
|
||||
(define (signal-error constructor format-string . args)
|
||||
(lambda exn-args
|
||||
(raise (apply constructor
|
||||
(string->immutable-string (apply format format-string args))
|
||||
(current-continuation-marks)
|
||||
exn-args))))
|
||||
|
||||
;; default-nntpd-port-number :
|
||||
;; number
|
||||
|
|
@ -80,120 +79,112 @@
|
|||
;; close-communicator :
|
||||
;; communicator -> ()
|
||||
|
||||
(define close-communicator
|
||||
(lambda (communicator)
|
||||
(close-input-port (communicator-receiver communicator))
|
||||
(close-output-port (communicator-sender communicator))))
|
||||
(define (close-communicator communicator)
|
||||
(close-input-port (communicator-receiver communicator))
|
||||
(close-output-port (communicator-sender communicator)))
|
||||
|
||||
;; disconnect-from-server :
|
||||
;; communicator -> ()
|
||||
|
||||
(define disconnect-from-server
|
||||
(lambda (communicator)
|
||||
(send-to-server communicator "QUIT")
|
||||
(let-values ([(code response)
|
||||
(get-single-line-response communicator)])
|
||||
(case code
|
||||
[(205)
|
||||
(close-communicator communicator)]
|
||||
[else
|
||||
((signal-error make-unexpected-response
|
||||
"unexpected dis-connect response: ~s ~s"
|
||||
code response)
|
||||
code response)]))))
|
||||
(define (disconnect-from-server communicator)
|
||||
(send-to-server communicator "QUIT")
|
||||
(let-values ([(code response)
|
||||
(get-single-line-response communicator)])
|
||||
(case code
|
||||
[(205)
|
||||
(close-communicator communicator)]
|
||||
[else
|
||||
((signal-error make-unexpected-response
|
||||
"unexpected dis-connect response: ~s ~s"
|
||||
code response)
|
||||
code response)])))
|
||||
|
||||
;; authenticate-user :
|
||||
;; communicator x user-name x password -> ()
|
||||
;; the password is not used if the server does not ask for it.
|
||||
|
||||
(define authenticate-user
|
||||
(lambda (communicator user password)
|
||||
(define (reject code response)
|
||||
((signal-error make-authentication-rejected
|
||||
"authentication rejected (~s ~s)"
|
||||
code response)))
|
||||
(define (unexpected code response)
|
||||
((signal-error make-unexpected-response
|
||||
"unexpected response for authentication: ~s ~s"
|
||||
code response)
|
||||
code response))
|
||||
(send-to-server communicator "AUTHINFO USER ~a" user)
|
||||
(let-values ([(code response) (get-single-line-response communicator)])
|
||||
(case code
|
||||
[(281) (void)] ; server doesn't ask for a password
|
||||
[(381)
|
||||
(send-to-server communicator "AUTHINFO PASS ~a" password)
|
||||
(let-values ([(code response)
|
||||
(get-single-line-response communicator)])
|
||||
(case code
|
||||
[(281) (void)] ; done
|
||||
[(502) (reject code response)]
|
||||
[else (unexpected code response)]))]
|
||||
[(502) (reject code response)]
|
||||
[else (reject code response)
|
||||
(unexpected code response)]))))
|
||||
(define (authenticate-user communicator user password)
|
||||
(define (reject code response)
|
||||
((signal-error make-authentication-rejected
|
||||
"authentication rejected (~s ~s)"
|
||||
code response)))
|
||||
(define (unexpected code response)
|
||||
((signal-error make-unexpected-response
|
||||
"unexpected response for authentication: ~s ~s"
|
||||
code response)
|
||||
code response))
|
||||
(send-to-server communicator "AUTHINFO USER ~a" user)
|
||||
(let-values ([(code response) (get-single-line-response communicator)])
|
||||
(case code
|
||||
[(281) (void)] ; server doesn't ask for a password
|
||||
[(381)
|
||||
(send-to-server communicator "AUTHINFO PASS ~a" password)
|
||||
(let-values ([(code response)
|
||||
(get-single-line-response communicator)])
|
||||
(case code
|
||||
[(281) (void)] ; done
|
||||
[(502) (reject code response)]
|
||||
[else (unexpected code response)]))]
|
||||
[(502) (reject code response)]
|
||||
[else (reject code response)
|
||||
(unexpected code response)])))
|
||||
|
||||
;; send-to-server :
|
||||
;; communicator x format-string x list (values) -> ()
|
||||
|
||||
(define send-to-server
|
||||
(lambda (communicator message-template . rest)
|
||||
(let ([sender (communicator-sender communicator)])
|
||||
(apply fprintf sender
|
||||
(string-append message-template "\r\n")
|
||||
rest)
|
||||
(flush-output sender))))
|
||||
(define (send-to-server communicator message-template . rest)
|
||||
(let ([sender (communicator-sender communicator)])
|
||||
(apply fprintf sender
|
||||
(string-append message-template "\r\n")
|
||||
rest)
|
||||
(flush-output sender)))
|
||||
|
||||
;; parse-status-line :
|
||||
;; string -> number x string
|
||||
|
||||
(define parse-status-line
|
||||
(lambda (line)
|
||||
(if (eof-object? line)
|
||||
((signal-error make-bad-status-line "eof instead of a status line")
|
||||
line)
|
||||
(let ([match (cdr (or (regexp-match #rx"([0-9]+) (.*)" line)
|
||||
((signal-error make-bad-status-line
|
||||
"malformed status line: ~s" line)
|
||||
line)))])
|
||||
(values (string->number (car match))
|
||||
(cadr match))))))
|
||||
(define (parse-status-line line)
|
||||
(if (eof-object? line)
|
||||
((signal-error make-bad-status-line "eof instead of a status line")
|
||||
line)
|
||||
(let ([match (cdr (or (regexp-match #rx"([0-9]+) (.*)" line)
|
||||
((signal-error make-bad-status-line
|
||||
"malformed status line: ~s" line)
|
||||
line)))])
|
||||
(values (string->number (car match))
|
||||
(cadr match)))))
|
||||
|
||||
;; get-one-line-from-server :
|
||||
;; iport -> string
|
||||
|
||||
(define get-one-line-from-server
|
||||
(lambda (server->client-port)
|
||||
(read-line server->client-port 'return-linefeed)))
|
||||
(define (get-one-line-from-server server->client-port)
|
||||
(read-line server->client-port 'return-linefeed))
|
||||
|
||||
;; get-single-line-response :
|
||||
;; communicator -> number x string
|
||||
|
||||
(define get-single-line-response
|
||||
(lambda (communicator)
|
||||
(let ([receiver (communicator-receiver communicator)])
|
||||
(let ([status-line (get-one-line-from-server receiver)])
|
||||
(parse-status-line status-line)))))
|
||||
(define (get-single-line-response communicator)
|
||||
(let* ([receiver (communicator-receiver communicator)]
|
||||
[status-line (get-one-line-from-server receiver)])
|
||||
(parse-status-line status-line)))
|
||||
|
||||
;; get-rest-of-multi-line-response :
|
||||
;; communicator -> list (string)
|
||||
|
||||
(define get-rest-of-multi-line-response
|
||||
(lambda (communicator)
|
||||
(let ([receiver (communicator-receiver communicator)])
|
||||
(let loop ()
|
||||
(let ([l (get-one-line-from-server receiver)])
|
||||
(cond
|
||||
[(eof-object? l)
|
||||
((signal-error make-premature-close
|
||||
"port prematurely closed during multi-line response")
|
||||
communicator)]
|
||||
[(string=? l ".")
|
||||
'()]
|
||||
[(string=? l "..")
|
||||
(cons "." (loop))]
|
||||
[else
|
||||
(cons l (loop))]))))))
|
||||
(define (get-rest-of-multi-line-response communicator)
|
||||
(let ([receiver (communicator-receiver communicator)])
|
||||
(let loop ()
|
||||
(let ([l (get-one-line-from-server receiver)])
|
||||
(cond
|
||||
[(eof-object? l)
|
||||
((signal-error make-premature-close
|
||||
"port prematurely closed during multi-line response")
|
||||
communicator)]
|
||||
[(string=? l ".")
|
||||
'()]
|
||||
[(string=? l "..")
|
||||
(cons "." (loop))]
|
||||
[else
|
||||
(cons l (loop))])))))
|
||||
|
||||
;; get-multi-line-response :
|
||||
;; communicator -> number x string x list (string)
|
||||
|
|
@ -201,13 +192,12 @@
|
|||
;; -- The returned values are the status code, the rest of the status
|
||||
;; response line, and the remaining lines.
|
||||
|
||||
(define get-multi-line-response
|
||||
(lambda (communicator)
|
||||
(let* ([receiver (communicator-receiver communicator)]
|
||||
[status-line (get-one-line-from-server receiver)])
|
||||
(let-values ([(code rest-of-line)
|
||||
(parse-status-line status-line)])
|
||||
(values code rest-of-line (get-rest-of-multi-line-response))))))
|
||||
(define (get-multi-line-response communicator)
|
||||
(let* ([receiver (communicator-receiver communicator)]
|
||||
[status-line (get-one-line-from-server receiver)])
|
||||
(let-values ([(code rest-of-line)
|
||||
(parse-status-line status-line)])
|
||||
(values code rest-of-line (get-rest-of-multi-line-response)))))
|
||||
|
||||
;; open-news-group :
|
||||
;; communicator x string -> number x number x number
|
||||
|
|
@ -215,66 +205,64 @@
|
|||
;; -- The returned values are the number of articles, the first
|
||||
;; article number, and the last article number for that group.
|
||||
|
||||
(define open-news-group
|
||||
(lambda (communicator group-name)
|
||||
(send-to-server communicator "GROUP ~a" group-name)
|
||||
(let-values ([(code rest-of-line)
|
||||
(get-single-line-response communicator)])
|
||||
(case code
|
||||
[(211)
|
||||
(let ([match (map string->number
|
||||
(cdr
|
||||
(or (regexp-match #rx"([0-9]+) ([0-9]+) ([0-9]+)" rest-of-line)
|
||||
((signal-error make-bad-newsgroup-line
|
||||
"malformed newsgroup open response: ~s"
|
||||
rest-of-line)
|
||||
rest-of-line))))])
|
||||
(let ([number-of-articles (car match)]
|
||||
[first-article-number (cadr match)]
|
||||
[last-article-number (caddr match)])
|
||||
(values number-of-articles
|
||||
first-article-number
|
||||
last-article-number)))]
|
||||
[(411)
|
||||
((signal-error make-non-existent-group
|
||||
"group ~s does not exist on server ~s"
|
||||
group-name (communicator-server communicator))
|
||||
group-name)]
|
||||
[else
|
||||
((signal-error make-unexpected-response
|
||||
"unexpected group opening response: ~s" code)
|
||||
code rest-of-line)]))))
|
||||
(define (open-news-group communicator group-name)
|
||||
(send-to-server communicator "GROUP ~a" group-name)
|
||||
(let-values ([(code rest-of-line)
|
||||
(get-single-line-response communicator)])
|
||||
(case code
|
||||
[(211)
|
||||
(let ([match (map string->number
|
||||
(cdr
|
||||
(or (regexp-match #rx"([0-9]+) ([0-9]+) ([0-9]+)" rest-of-line)
|
||||
((signal-error make-bad-newsgroup-line
|
||||
"malformed newsgroup open response: ~s"
|
||||
rest-of-line)
|
||||
rest-of-line))))])
|
||||
(let ([number-of-articles (car match)]
|
||||
[first-article-number (cadr match)]
|
||||
[last-article-number (caddr match)])
|
||||
(values number-of-articles
|
||||
first-article-number
|
||||
last-article-number)))]
|
||||
[(411)
|
||||
((signal-error make-non-existent-group
|
||||
"group ~s does not exist on server ~s"
|
||||
group-name (communicator-server communicator))
|
||||
group-name)]
|
||||
[else
|
||||
((signal-error make-unexpected-response
|
||||
"unexpected group opening response: ~s" code)
|
||||
code rest-of-line)])))
|
||||
|
||||
;; generic-message-command :
|
||||
;; string x number -> communicator x (number U string) -> list (string)
|
||||
|
||||
(define generic-message-command
|
||||
(lambda (command ok-code)
|
||||
(lambda (communicator message-index)
|
||||
(send-to-server communicator (string-append command " ~a")
|
||||
(if (number? message-index)
|
||||
(number->string message-index)
|
||||
message-index))
|
||||
(let-values ([(code response)
|
||||
(get-single-line-response communicator)])
|
||||
(if (= code ok-code)
|
||||
(get-rest-of-multi-line-response communicator)
|
||||
(case code
|
||||
[(423)
|
||||
((signal-error make-article-not-in-group
|
||||
"article id ~s not in group" message-index)
|
||||
message-index)]
|
||||
[(412)
|
||||
((signal-error make-no-group-selected
|
||||
"no group selected"))]
|
||||
[(430)
|
||||
((signal-error make-article-not-found
|
||||
"no article id ~s found" message-index)
|
||||
message-index)]
|
||||
[else
|
||||
((signal-error make-unexpected-response
|
||||
"unexpected message access response: ~s" code)
|
||||
code response)]))))))
|
||||
(define (generic-message-command command ok-code)
|
||||
(lambda (communicator message-index)
|
||||
(send-to-server communicator (string-append command " ~a")
|
||||
(if (number? message-index)
|
||||
(number->string message-index)
|
||||
message-index))
|
||||
(let-values ([(code response)
|
||||
(get-single-line-response communicator)])
|
||||
(if (= code ok-code)
|
||||
(get-rest-of-multi-line-response communicator)
|
||||
(case code
|
||||
[(423)
|
||||
((signal-error make-article-not-in-group
|
||||
"article id ~s not in group" message-index)
|
||||
message-index)]
|
||||
[(412)
|
||||
((signal-error make-no-group-selected
|
||||
"no group selected"))]
|
||||
[(430)
|
||||
((signal-error make-article-not-found
|
||||
"no article id ~s found" message-index)
|
||||
message-index)]
|
||||
[else
|
||||
((signal-error make-unexpected-response
|
||||
"unexpected message access response: ~s" code)
|
||||
code response)])))))
|
||||
|
||||
;; head-of-message :
|
||||
;; communicator x (number U string) -> list (string)
|
||||
|
|
@ -297,35 +285,33 @@
|
|||
;; make-desired-header :
|
||||
;; string -> desired
|
||||
|
||||
(define make-desired-header
|
||||
(lambda (raw-header)
|
||||
(regexp
|
||||
(string-append
|
||||
"^"
|
||||
(list->string
|
||||
(apply append
|
||||
(map (lambda (c)
|
||||
(cond
|
||||
[(char-lower-case? c)
|
||||
(list #\[ (char-upcase c) c #\])]
|
||||
[(char-upper-case? c)
|
||||
(list #\[ c (char-downcase c) #\])]
|
||||
[else
|
||||
(list c)]))
|
||||
(string->list raw-header))))
|
||||
":"))))
|
||||
(define (make-desired-header raw-header)
|
||||
(regexp
|
||||
(string-append
|
||||
"^"
|
||||
(list->string
|
||||
(apply append
|
||||
(map (lambda (c)
|
||||
(cond
|
||||
[(char-lower-case? c)
|
||||
(list #\[ (char-upcase c) c #\])]
|
||||
[(char-upper-case? c)
|
||||
(list #\[ c (char-downcase c) #\])]
|
||||
[else
|
||||
(list c)]))
|
||||
(string->list raw-header))))
|
||||
":")))
|
||||
|
||||
;; extract-desired-headers :
|
||||
;; list (string) x list (desired) -> list (string)
|
||||
|
||||
(define extract-desired-headers
|
||||
(lambda (headers desireds)
|
||||
(let loop ([headers headers])
|
||||
(if (null? headers) null
|
||||
(let ([first (car headers)]
|
||||
[rest (cdr headers)])
|
||||
(if (ormap (lambda (matcher)
|
||||
(regexp-match matcher first))
|
||||
desireds)
|
||||
(cons first (loop rest))
|
||||
(loop rest))))))))
|
||||
(define (extract-desired-headers headers desireds)
|
||||
(let loop ([headers headers])
|
||||
(if (null? headers) null
|
||||
(let ([first (car headers)]
|
||||
[rest (cdr headers)])
|
||||
(if (ormap (lambda (matcher)
|
||||
(regexp-match matcher first))
|
||||
desireds)
|
||||
(cons first (loop rest))
|
||||
(loop rest)))))))
|
||||
|
|
|
|||
|
|
@ -29,14 +29,13 @@
|
|||
;; (exn-args ... -> exn) x format-string x values ... ->
|
||||
;; exn-args -> ()
|
||||
|
||||
(define signal-error
|
||||
(lambda (constructor format-string . args)
|
||||
(lambda exn-args
|
||||
(raise (apply constructor
|
||||
(string->immutable-string
|
||||
(apply format format-string args))
|
||||
(current-continuation-marks)
|
||||
exn-args)))))
|
||||
(define (signal-error constructor format-string . args)
|
||||
(lambda exn-args
|
||||
(raise (apply constructor
|
||||
(string->immutable-string
|
||||
(apply format format-string args))
|
||||
(current-continuation-marks)
|
||||
exn-args))))
|
||||
|
||||
;; signal-malformed-response-error :
|
||||
;; exn-args -> ()
|
||||
|
|
@ -52,11 +51,10 @@
|
|||
|
||||
;; -- signals an error otherwise.
|
||||
|
||||
(define confirm-transaction-mode
|
||||
(lambda (communicator error-message)
|
||||
(unless (eq? (communicator-state communicator) 'transaction)
|
||||
((signal-error make-not-ready-for-transaction error-message)
|
||||
communicator))))
|
||||
(define (confirm-transaction-mode communicator error-message)
|
||||
(unless (eq? (communicator-state communicator) 'transaction)
|
||||
((signal-error make-not-ready-for-transaction error-message)
|
||||
communicator)))
|
||||
|
||||
;; default-pop-port-number :
|
||||
;; number
|
||||
|
|
@ -98,122 +96,118 @@
|
|||
;; -- if authentication succeeds, sets the communicator's state to
|
||||
;; transaction.
|
||||
|
||||
(define authenticate/plain-text
|
||||
(lambda (username password communicator)
|
||||
(let ([sender (communicator-sender communicator)])
|
||||
(send-to-server communicator "USER ~a" username)
|
||||
(let ([status (get-status-response/basic communicator)])
|
||||
(cond
|
||||
[(+ok? status)
|
||||
(send-to-server communicator "PASS ~a" password)
|
||||
(let ([status (get-status-response/basic communicator)])
|
||||
(cond
|
||||
[(+ok? status)
|
||||
(set-communicator-state! communicator 'transaction)]
|
||||
[(-err? status)
|
||||
((signal-error make-password-rejected
|
||||
"password was rejected"))]))]
|
||||
[(-err? status)
|
||||
((signal-error make-username-rejected
|
||||
"username was rejected"))])))))
|
||||
(define (authenticate/plain-text username password communicator)
|
||||
(let ([sender (communicator-sender communicator)])
|
||||
(send-to-server communicator "USER ~a" username)
|
||||
(let ([status (get-status-response/basic communicator)])
|
||||
(cond
|
||||
[(+ok? status)
|
||||
(send-to-server communicator "PASS ~a" password)
|
||||
(let ([status (get-status-response/basic communicator)])
|
||||
(cond
|
||||
[(+ok? status)
|
||||
(set-communicator-state! communicator 'transaction)]
|
||||
[(-err? status)
|
||||
((signal-error make-password-rejected
|
||||
"password was rejected"))]))]
|
||||
[(-err? status)
|
||||
((signal-error make-username-rejected
|
||||
"username was rejected"))]))))
|
||||
|
||||
;; get-mailbox-status :
|
||||
;; communicator -> number x number
|
||||
|
||||
;; -- returns number of messages and number of octets.
|
||||
|
||||
(define get-mailbox-status
|
||||
(lambda (communicator)
|
||||
(confirm-transaction-mode
|
||||
communicator
|
||||
"cannot get mailbox status unless in transaction mode")
|
||||
(send-to-server communicator "STAT")
|
||||
(apply values
|
||||
(map string->number
|
||||
(let-values ([(status result)
|
||||
(get-status-response/match
|
||||
communicator
|
||||
#rx"([0-9]+) ([0-9]+)"
|
||||
#f)])
|
||||
result)))))
|
||||
(define (get-mailbox-status communicator)
|
||||
(confirm-transaction-mode
|
||||
communicator
|
||||
"cannot get mailbox status unless in transaction mode")
|
||||
(send-to-server communicator "STAT")
|
||||
(apply values
|
||||
(map string->number
|
||||
(let-values ([(status result)
|
||||
(get-status-response/match
|
||||
communicator
|
||||
#rx"([0-9]+) ([0-9]+)"
|
||||
#f)])
|
||||
result))))
|
||||
|
||||
;; get-message/complete :
|
||||
;; communicator x number -> list (string) x list (string)
|
||||
|
||||
(define get-message/complete
|
||||
(lambda (communicator message)
|
||||
(confirm-transaction-mode communicator
|
||||
"cannot get message headers unless in transaction state")
|
||||
(send-to-server communicator "RETR ~a" message)
|
||||
(let ([status (get-status-response/basic communicator)])
|
||||
(cond
|
||||
[(+ok? status)
|
||||
(split-header/body (get-multi-line-response communicator))]
|
||||
[(-err? status)
|
||||
((signal-error make-illegal-message-number
|
||||
"not given message ~a" message)
|
||||
communicator message)]))))
|
||||
(define (get-message/complete communicator message)
|
||||
(confirm-transaction-mode
|
||||
communicator
|
||||
"cannot get message headers unless in transaction state")
|
||||
(send-to-server communicator "RETR ~a" message)
|
||||
(let ([status (get-status-response/basic communicator)])
|
||||
(cond
|
||||
[(+ok? status)
|
||||
(split-header/body (get-multi-line-response communicator))]
|
||||
[(-err? status)
|
||||
((signal-error make-illegal-message-number
|
||||
"not given message ~a" message)
|
||||
communicator message)])))
|
||||
|
||||
;; get-message/headers :
|
||||
;; communicator x number -> list (string)
|
||||
|
||||
(define get-message/headers
|
||||
(lambda (communicator message)
|
||||
(confirm-transaction-mode communicator
|
||||
"cannot get message headers unless in transaction state")
|
||||
(send-to-server communicator "TOP ~a 0" message)
|
||||
(let ([status (get-status-response/basic communicator)])
|
||||
(cond
|
||||
[(+ok? status)
|
||||
(let-values ([(headers body)
|
||||
(split-header/body
|
||||
(get-multi-line-response communicator))])
|
||||
headers)]
|
||||
[(-err? status)
|
||||
((signal-error make-not-given-headers
|
||||
"not given headers to message ~a" message)
|
||||
communicator message)]))))
|
||||
(define (get-message/headers communicator message)
|
||||
(confirm-transaction-mode
|
||||
communicator
|
||||
"cannot get message headers unless in transaction state")
|
||||
(send-to-server communicator "TOP ~a 0" message)
|
||||
(let ([status (get-status-response/basic communicator)])
|
||||
(cond
|
||||
[(+ok? status)
|
||||
(let-values ([(headers body)
|
||||
(split-header/body
|
||||
(get-multi-line-response communicator))])
|
||||
headers)]
|
||||
[(-err? status)
|
||||
((signal-error make-not-given-headers
|
||||
"not given headers to message ~a" message)
|
||||
communicator message)])))
|
||||
|
||||
;; get-message/body :
|
||||
;; communicator x number -> list (string)
|
||||
|
||||
(define get-message/body
|
||||
(lambda (communicator message)
|
||||
(let-values ([(headers body) (get-message/complete communicator message)])
|
||||
body)))
|
||||
(define (get-message/body communicator message)
|
||||
(let-values ([(headers body) (get-message/complete communicator message)])
|
||||
body))
|
||||
|
||||
;; split-header/body :
|
||||
;; list (string) -> list (string) x list (string)
|
||||
|
||||
;; -- returns list of headers and list of body lines.
|
||||
|
||||
(define split-header/body
|
||||
(lambda (lines)
|
||||
(let loop ([lines lines] [header null])
|
||||
(if (null? lines)
|
||||
(values (reverse header) null)
|
||||
(let ([first (car lines)]
|
||||
[rest (cdr lines)])
|
||||
(if (string=? first "")
|
||||
(values (reverse header) rest)
|
||||
(loop rest (cons first header))))))))
|
||||
(define (split-header/body lines)
|
||||
(let loop ([lines lines] [header null])
|
||||
(if (null? lines)
|
||||
(values (reverse header) null)
|
||||
(let ([first (car lines)]
|
||||
[rest (cdr lines)])
|
||||
(if (string=? first "")
|
||||
(values (reverse header) rest)
|
||||
(loop rest (cons first header)))))))
|
||||
|
||||
;; delete-message :
|
||||
;; communicator x number -> ()
|
||||
|
||||
(define delete-message
|
||||
(lambda (communicator message)
|
||||
(confirm-transaction-mode communicator
|
||||
"cannot delete message unless in transaction state")
|
||||
(send-to-server communicator "DELE ~a" message)
|
||||
(let ([status (get-status-response/basic communicator)])
|
||||
(cond
|
||||
[(-err? status)
|
||||
((signal-error make-cannot-delete-message
|
||||
"no message numbered ~a available to be deleted" message)
|
||||
communicator message)]
|
||||
[(+ok? status)
|
||||
'deleted]))))
|
||||
(define (delete-message communicator message)
|
||||
(confirm-transaction-mode
|
||||
communicator
|
||||
"cannot delete message unless in transaction state")
|
||||
(send-to-server communicator "DELE ~a" message)
|
||||
(let ([status (get-status-response/basic communicator)])
|
||||
(cond
|
||||
[(-err? status)
|
||||
((signal-error make-cannot-delete-message
|
||||
"no message numbered ~a available to be deleted" message)
|
||||
communicator message)]
|
||||
[(+ok? status)
|
||||
'deleted])))
|
||||
|
||||
;; regexp for UIDL responses
|
||||
|
||||
|
|
@ -223,8 +217,9 @@
|
|||
;; communicator x number -> string
|
||||
|
||||
(define (get-unique-id/single communicator message)
|
||||
(confirm-transaction-mode communicator
|
||||
"cannot get unique message id unless in transaction state")
|
||||
(confirm-transaction-mode
|
||||
communicator
|
||||
"cannot get unique message id unless in transaction state")
|
||||
(send-to-server communicator "UIDL ~a" message)
|
||||
(let-values ([(status result)
|
||||
(get-status-response/match communicator uidl-regexp ".*")])
|
||||
|
|
@ -259,43 +254,39 @@
|
|||
;; close-communicator :
|
||||
;; communicator -> ()
|
||||
|
||||
(define close-communicator
|
||||
(lambda (communicator)
|
||||
(close-input-port (communicator-receiver communicator))
|
||||
(close-output-port (communicator-sender communicator))))
|
||||
(define (close-communicator communicator)
|
||||
(close-input-port (communicator-receiver communicator))
|
||||
(close-output-port (communicator-sender communicator)))
|
||||
|
||||
;; disconnect-from-server :
|
||||
;; communicator -> ()
|
||||
|
||||
(define disconnect-from-server
|
||||
(lambda (communicator)
|
||||
(send-to-server communicator "QUIT")
|
||||
(set-communicator-state! communicator 'disconnected)
|
||||
(let ([response (get-status-response/basic communicator)])
|
||||
(close-communicator communicator)
|
||||
(cond
|
||||
[(+ok? response) (void)]
|
||||
[(-err? response)
|
||||
((signal-error make-disconnect-not-quiet
|
||||
"got error status upon disconnect")
|
||||
communicator)]))))
|
||||
(define (disconnect-from-server communicator)
|
||||
(send-to-server communicator "QUIT")
|
||||
(set-communicator-state! communicator 'disconnected)
|
||||
(let ([response (get-status-response/basic communicator)])
|
||||
(close-communicator communicator)
|
||||
(cond
|
||||
[(+ok? response) (void)]
|
||||
[(-err? response)
|
||||
((signal-error make-disconnect-not-quiet
|
||||
"got error status upon disconnect")
|
||||
communicator)])))
|
||||
|
||||
;; send-to-server :
|
||||
;; communicator x format-string x list (values) -> ()
|
||||
|
||||
(define send-to-server
|
||||
(lambda (communicator message-template . rest)
|
||||
(apply fprintf (communicator-sender communicator)
|
||||
(string-append message-template "\r\n")
|
||||
rest)
|
||||
(flush-output (communicator-sender communicator))))
|
||||
(define (send-to-server communicator message-template . rest)
|
||||
(apply fprintf (communicator-sender communicator)
|
||||
(string-append message-template "\r\n")
|
||||
rest)
|
||||
(flush-output (communicator-sender communicator)))
|
||||
|
||||
;; get-one-line-from-server :
|
||||
;; iport -> string
|
||||
|
||||
(define get-one-line-from-server
|
||||
(lambda (server->client-port)
|
||||
(read-line server->client-port 'return-linefeed)))
|
||||
(define (get-one-line-from-server server->client-port)
|
||||
(read-line server->client-port 'return-linefeed))
|
||||
|
||||
;; get-server-status-response :
|
||||
;; communicator -> server-responses x string
|
||||
|
|
@ -305,17 +296,16 @@
|
|||
;; rest of the status response as a string to be used for further
|
||||
;; parsing, if necessary.
|
||||
|
||||
(define get-server-status-response
|
||||
(lambda (communicator)
|
||||
(let* ([receiver (communicator-receiver communicator)]
|
||||
[status-line (get-one-line-from-server receiver)]
|
||||
[r (regexp-match #rx"^\\+OK(.*)" status-line)])
|
||||
(if r
|
||||
(values (make-+ok) (cadr r))
|
||||
(let ([r (regexp-match #rx"^\\-ERR(.*)" status-line)])
|
||||
(if r
|
||||
(values (make--err) (cadr r))
|
||||
(signal-malformed-response-error communicator)))))))
|
||||
(define (get-server-status-response communicator)
|
||||
(let* ([receiver (communicator-receiver communicator)]
|
||||
[status-line (get-one-line-from-server receiver)]
|
||||
[r (regexp-match #rx"^\\+OK(.*)" status-line)])
|
||||
(if r
|
||||
(values (make-+ok) (cadr r))
|
||||
(let ([r (regexp-match #rx"^\\-ERR(.*)" status-line)])
|
||||
(if r
|
||||
(values (make--err) (cadr r))
|
||||
(signal-malformed-response-error communicator))))))
|
||||
|
||||
;; get-status-response/basic :
|
||||
;; communicator -> server-responses
|
||||
|
|
@ -323,11 +313,10 @@
|
|||
;; -- when the only thing to determine is whether the response
|
||||
;; was +OK or -ERR.
|
||||
|
||||
(define get-status-response/basic
|
||||
(lambda (communicator)
|
||||
(let-values ([(response rest)
|
||||
(get-server-status-response communicator)])
|
||||
response)))
|
||||
(define (get-status-response/basic communicator)
|
||||
(let-values ([(response rest)
|
||||
(get-server-status-response communicator)])
|
||||
response))
|
||||
|
||||
;; get-status-response/match :
|
||||
;; communicator x regexp x regexp -> (status x list (string))
|
||||
|
|
@ -335,71 +324,67 @@
|
|||
;; -- when further parsing of the status response is necessary.
|
||||
;; Strips off the car of response from regexp-match.
|
||||
|
||||
(define get-status-response/match
|
||||
(lambda (communicator +regexp -regexp)
|
||||
(let-values ([(response rest)
|
||||
(get-server-status-response communicator)])
|
||||
(if (and +regexp (+ok? response))
|
||||
(let ([r (regexp-match +regexp rest)])
|
||||
(define (get-status-response/match communicator +regexp -regexp)
|
||||
(let-values ([(response rest)
|
||||
(get-server-status-response communicator)])
|
||||
(if (and +regexp (+ok? response))
|
||||
(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))
|
||||
(signal-malformed-response-error communicator)))
|
||||
(if (and -regexp (-err? response))
|
||||
(let ([r (regexp-match -regexp rest)])
|
||||
(if r (values response (cdr r))
|
||||
(signal-malformed-response-error communicator)))
|
||||
(signal-malformed-response-error communicator))))))
|
||||
(signal-malformed-response-error communicator)))))
|
||||
|
||||
;; get-multi-line-response :
|
||||
;; communicator -> list (string)
|
||||
|
||||
(define get-multi-line-response
|
||||
(lambda (communicator)
|
||||
(let ([receiver (communicator-receiver communicator)])
|
||||
(let loop ()
|
||||
(let ([l (get-one-line-from-server receiver)])
|
||||
(cond
|
||||
[(eof-object? l)
|
||||
(signal-malformed-response-error communicator)]
|
||||
[(string=? l ".")
|
||||
'()]
|
||||
[(and (> (string-length l) 1)
|
||||
(char=? (string-ref l 0) #\.))
|
||||
(cons (substring l 1 (string-length l)) (loop))]
|
||||
[else
|
||||
(cons l (loop))]))))))
|
||||
(define (get-multi-line-response communicator)
|
||||
(let ([receiver (communicator-receiver communicator)])
|
||||
(let loop ()
|
||||
(let ([l (get-one-line-from-server receiver)])
|
||||
(cond
|
||||
[(eof-object? l)
|
||||
(signal-malformed-response-error communicator)]
|
||||
[(string=? l ".")
|
||||
'()]
|
||||
[(and (> (string-length l) 1)
|
||||
(char=? (string-ref l 0) #\.))
|
||||
(cons (substring l 1 (string-length l)) (loop))]
|
||||
[else
|
||||
(cons l (loop))])))))
|
||||
|
||||
;; make-desired-header :
|
||||
;; string -> desired
|
||||
|
||||
(define make-desired-header
|
||||
(lambda (raw-header)
|
||||
(regexp
|
||||
(string-append
|
||||
"^"
|
||||
(list->string
|
||||
(apply append
|
||||
(map (lambda (c)
|
||||
(cond
|
||||
[(char-lower-case? c)
|
||||
(list #\[ (char-upcase c) c #\])]
|
||||
[(char-upper-case? c)
|
||||
(list #\[ c (char-downcase c) #\])]
|
||||
[else
|
||||
(list c)]))
|
||||
(string->list raw-header))))
|
||||
":"))))
|
||||
(define (make-desired-header raw-header)
|
||||
(regexp
|
||||
(string-append
|
||||
"^"
|
||||
(list->string
|
||||
(apply append
|
||||
(map (lambda (c)
|
||||
(cond
|
||||
[(char-lower-case? c)
|
||||
(list #\[ (char-upcase c) c #\])]
|
||||
[(char-upper-case? c)
|
||||
(list #\[ c (char-downcase c) #\])]
|
||||
[else
|
||||
(list c)]))
|
||||
(string->list raw-header))))
|
||||
":")))
|
||||
|
||||
;; extract-desired-headers :
|
||||
;; list (string) x list (desired) -> list (string)
|
||||
|
||||
(define extract-desired-headers
|
||||
(lambda (headers desireds)
|
||||
(let loop ([headers headers])
|
||||
(if (null? headers) null
|
||||
(let ([first (car headers)]
|
||||
[rest (cdr headers)])
|
||||
(if (ormap (lambda (matcher)
|
||||
(regexp-match matcher first))
|
||||
desireds)
|
||||
(cons first (loop rest))
|
||||
(loop rest))))))))
|
||||
(define (extract-desired-headers headers desireds)
|
||||
(let loop ([headers headers])
|
||||
(if (null? headers) null
|
||||
(let ([first (car headers)]
|
||||
[rest (cdr headers)])
|
||||
(if (ormap (lambda (matcher)
|
||||
(regexp-match matcher first))
|
||||
desireds)
|
||||
(cons first (loop rest))
|
||||
(loop rest)))))))
|
||||
|
|
|
|||
|
|
@ -8,8 +8,6 @@
|
|||
|
||||
(define debug-via-stdio? #f)
|
||||
|
||||
(define crlf (string #\return #\linefeed))
|
||||
|
||||
(define (log . args)
|
||||
;; (apply printf args)
|
||||
(void))
|
||||
|
|
@ -61,7 +59,7 @@
|
|||
(raise x))])
|
||||
(check-reply r 220 w)
|
||||
(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)
|
||||
|
||||
(when auth-user
|
||||
|
|
@ -74,36 +72,36 @@
|
|||
(check-reply r 235 w))
|
||||
|
||||
(log "from\n")
|
||||
(fprintf w "MAIL FROM:<~a>~a" sender crlf)
|
||||
(fprintf w "MAIL FROM:<~a>\r\n" sender)
|
||||
(check-reply r 250 w)
|
||||
|
||||
(log "to\n")
|
||||
(for-each
|
||||
(lambda (dest)
|
||||
(fprintf w "RCPT TO:<~a>~a" dest crlf)
|
||||
(fprintf w "RCPT TO:<~a>\r\n" dest)
|
||||
(check-reply r 250 w))
|
||||
recipients)
|
||||
|
||||
(log "header\n")
|
||||
(fprintf w "DATA~a" crlf)
|
||||
(fprintf w "DATA\r\n")
|
||||
(check-reply r 354 w)
|
||||
(fprintf w "~a" header)
|
||||
(for-each
|
||||
(lambda (l)
|
||||
(log "body: ~a\n" l)
|
||||
(fprintf w "~a~a" (protect-line l) crlf))
|
||||
(fprintf w "~a\r\n" (protect-line l)))
|
||||
message-lines)
|
||||
|
||||
;; After we send the ".", then only break in an emergency
|
||||
((smtp-sending-end-of-message))
|
||||
|
||||
(log "dot\n")
|
||||
(fprintf w ".~a" crlf)
|
||||
(fprintf w ".\r\n")
|
||||
(flush-output w)
|
||||
(check-reply r 250 w)
|
||||
|
||||
(log "quit\n")
|
||||
(fprintf w "QUIT~a" crlf)
|
||||
(fprintf w "QUIT\r\n")
|
||||
(check-reply r 221 w)
|
||||
|
||||
(close-output-port w)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user