From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 15 May 2000 17:47:54 +0000 (+0000)
Subject: Add support for parsing "Received" headers. Break out some
X-Git-Tag: 20090517-FFI~3878
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=34997a5d9afea798d85d18c17c20951c150db072;p=mit-scheme.git
Add support for parsing "Received" headers. Break out some
lower-level parsing code.
---
diff --git a/v7/src/imail/imail.pkg b/v7/src/imail/imail.pkg
index e7381583c..63a065cb6 100644
--- a/v7/src/imail/imail.pkg
+++ b/v7/src/imail/imail.pkg
@@ -1,6 +1,6 @@
;;; -*-Scheme-*-
;;;
-;;; $Id: imail.pkg,v 1.29 2000/05/08 19:55:55 cph Exp $
+;;; $Id: imail.pkg,v 1.30 2000/05/15 17:47:54 cph Exp $
;;;
;;; Copyright (c) 2000 Massachusetts Institute of Technology
;;;
@@ -114,6 +114,12 @@
rfc822:addresses->string
rfc822:first-address
rfc822:header-field-name?
+ rfc822:parse-addr-spec
+ rfc822:parse-domain
+ rfc822:parse-list
+ rfc822:parse-msg-id
+ rfc822:parse-word
+ rfc822:received-header-components
rfc822:string->addresses
rfc822:string->tokens
rfc822:strip-quoted-names))
diff --git a/v7/src/imail/rfc822.scm b/v7/src/imail/rfc822.scm
index 554969318..c6321bf20 100644
--- a/v7/src/imail/rfc822.scm
+++ b/v7/src/imail/rfc822.scm
@@ -1,6 +1,6 @@
;;; -*-Scheme-*-
;;;
-;;; $Id: rfc822.scm,v 1.5 2000/05/02 21:07:59 cph Exp $
+;;; $Id: rfc822.scm,v 1.6 2000/05/15 17:47:50 cph Exp $
;;;
;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
;;;
@@ -61,70 +61,29 @@
(if (and address-list (null? (cdr address-list)))
(car address-list)
(map string-trim (burst-string string #\, #f)))))
-
-(define (rfc822:strip-quoted-names tokens)
- (define (parse-list tokens separator parse-element)
- (let ((first (parse-element tokens)))
- (and first
- (let loop ((tokens (cdr first)) (words (list (car first))))
- (let ((next
- (and (pair? tokens)
- (eqv? separator (car tokens))
- (parse-element (cdr tokens)))))
- (if next
- (loop (cdr next) (cons (car next) words))
- (cons (reverse! words) tokens)))))))
-
- (define (parse-addr-spec tokens)
- (let ((local-part (parse-list tokens #\. parse-word)))
- (and local-part
- (pair? (cdr local-part))
- (eqv? #\@ (cadr local-part))
- (let ((domain (parse-domain (cddr local-part))))
- (and domain
- (cons (string-append
- (decorated-string-append "" "." ""
- (car local-part))
- "@"
- (decorated-string-append "" "." ""
- (car domain)))
- (cdr domain)))))))
-
- (define (parse-domain tokens)
- (parse-list tokens #\.
- (lambda (tokens)
- (and (pair? tokens)
- (string? (car tokens))
- (not (eqv? #\" (string-ref (car tokens) 0)))
- tokens))))
- (define (parse-word tokens)
- (and (pair? tokens)
- (string? (car tokens))
- (not (eqv? #\[ (string-ref (car tokens) 0)))
- tokens))
-
- (parse-list tokens #\,
+(define (rfc822:strip-quoted-names tokens)
+ (rfc822:parse-list tokens #\,
(lambda (tokens)
- (or (parse-addr-spec tokens)
- (let ((word (parse-word tokens)))
+ (or (rfc822:parse-addr-spec tokens)
+ (let ((word (rfc822:parse-word tokens)))
(and word
(let ((tokens
(let loop ((tokens (cdr word)))
- (let ((word (parse-word tokens)))
+ (let ((word (rfc822:parse-word tokens)))
(if word
(loop (cdr word))
tokens)))))
(and (pair? tokens)
(eqv? #\< (car tokens))
(let ((addr-spec
- (parse-addr-spec
+ (rfc822:parse-addr-spec
(let ((domains
- (parse-list (cdr tokens) #\,
+ (rfc822:parse-list (cdr tokens) #\,
(lambda (tokens)
(and (pair? tokens)
(eqv? #\@ (car tokens))
- (parse-domain
+ (rfc822:parse-domain
(cdr tokens)))))))
(if (and domains
(pair? (cdr domains))
@@ -137,6 +96,120 @@
(cons (car addr-spec)
(cddr addr-spec))))))))))))
+(define (rfc822:received-header-components string)
+ (let ((from #f)
+ (by #f)
+ (via #f)
+ (with '())
+ (id #f)
+ (for #f)
+ (lose (lambda () (error "Malformed Received header:" string))))
+ (let loop ((tokens (rfc822:string->tokens string)))
+ (cond ((not (pair? tokens))
+ (lose))
+ ((eqv? #\: (car tokens))
+ (values from by via (reverse! with) id for
+ (string->universal-time (rfc822:tokens->string tokens))))
+ ((not (string? (car tokens)))
+ (lose))
+ ((string-ci=? "from" (car tokens))
+ (let ((tokens (rfc822:parse-domain (cdr tokens))))
+ (if (not tokens)
+ (lose))
+ (set! from (car tokens))
+ (loop (cdr tokens))))
+ ((string-ci=? "by" (car tokens))
+ (let ((tokens (rfc822:parse-domain (cdr tokens))))
+ (if (not tokens)
+ (lose))
+ (set! from (car tokens))
+ (loop (cdr tokens))))
+ ((string-ci=? "via" (car tokens))
+ (if (not (pair? (cdr tokens)))
+ (lose))
+ (set! from (cadr tokens))
+ (loop (cddr tokens)))
+ ((string-ci=? "with" (car tokens))
+ (if (not (pair? (cdr tokens)))
+ (lose))
+ (set! with (cons (cadr tokens) with))
+ (loop (cddr tokens)))
+ ((string-ci=? "id" (car tokens))
+ (let ((tokens (rfc822:parse-msg-id (cdr tokens))))
+ (if (not tokens)
+ (lose))
+ (set! id (car tokens))
+ (loop (cdr tokens))))
+ ((string-ci=? "for" (car tokens))
+ (let ((tokens (rfc822:parse-addr-spec (cdr tokens))))
+ (if (not tokens)
+ (lose))
+ (set! for (car tokens))
+ (loop (cdr tokens))))
+ (else (lose))))))
+
+(define (rfc822:parse-msg-id tokens)
+ (and (pair? tokens)
+ (eqv? #\< (car tokens))
+ (let ((addr-spec (rfc822:parse-addr-spec (cdr tokens))))
+ (and (pair? addr-spec)
+ (pair? (cdr addr-spec))
+ (eqv? #\> (cadr addr-spec))
+ (cons (car addr-spec) (cddr addr-spec))))))
+
+(define (rfc822:parse-addr-spec tokens)
+ (let ((local-part (rfc822:parse-list tokens #\. rfc822:parse-word)))
+ (and (pair? local-part)
+ (pair? (cdr local-part))
+ (eqv? #\@ (cadr local-part))
+ (let ((domain (rfc822:parse-domain (cddr local-part))))
+ (and (pair? domain)
+ (cons (string-append
+ (decorated-string-append "" "." "" (car local-part))
+ "@"
+ (decorated-string-append "" "." "" (car domain)))
+ (cdr domain)))))))
+
+(define (rfc822:parse-domain tokens)
+ (rfc822:parse-list tokens #\.
+ (lambda (tokens)
+ (and (pair? tokens)
+ (string? (car tokens))
+ (not (char=? #\" (string-ref (car tokens) 0)))
+ tokens))))
+
+(define (rfc822:parse-word tokens)
+ (and (pair? tokens)
+ (string? (car tokens))
+ (not (char=? #\[ (string-ref (car tokens) 0)))
+ tokens))
+
+(define (rfc822:parse-list tokens separator parse-element)
+ (let ((first (parse-element tokens)))
+ (and first
+ (let loop ((tokens (cdr first)) (words (list (car first))))
+ (let ((next
+ (and (pair? tokens)
+ (eqv? separator (car tokens))
+ (parse-element (cdr tokens)))))
+ (if next
+ (loop (cdr next) (cons (car next) words))
+ (cons (reverse! words) tokens)))))))
+
+(define (rfc822:tokens->string tokens)
+ (let ((port (make-accumulator-output-port)))
+ (do ((tokens tokens (cdr tokens)))
+ ((not (pair? tokens)))
+ (cond ((char? (car tokens))
+ (write-char (car tokens) port))
+ ((string? (car tokens))
+ (write-string (car tokens) port))
+ ((and (pair? (car tokens))
+ (eq? 'ILLEGAL (caar tokens)))
+ (write-char (cdar tokens) port))
+ (else
+ (error "Malformed RFC-822 token stream:" tokens))))))
+
;;;; Parser
(define rfc822:string->tokens