/[anubis]/anubis/examples/anubis.scm
ViewVC logotype

Diff of /anubis/examples/anubis.scm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.5 by gray, Thu Mar 6 18:30:46 2003 UTC revision 1.6 by gray, Fri Mar 7 13:08:46 2003 UTC
# Line 33  Line 33 
33                      rest)                      rest)
34            (newline)))))            (newline)))))
35    
36  ;;; A couple of auxiliary functions  ;;; The function below illustrates the concept of Anubis message
   
 (define (isspace? c)  
   "Return #t if the character is a whitespace one"  
   (case c  
     ((#\space #\tab) #t)  
     (else #f)))  
   
 (define (header->pair x)  
   "Convert RFC822 header string into cons (HEADER-NAME . VALUE),  
 where HEADER-NAME is a Scheme internal symbol representing the header name  
 (all downcase) and VALUE is the string containing the header value"  
   (let ((pos (string-index x #\:)))  
     (if pos  
         (cons  
          (string->symbol (string-downcase (substring x 0 pos)))  
          (let ((len (string-length x)))  
            (do ((i (1+ pos) (1+ i)))  
                ((or (= i len)  
                     (not (isspace? (string-ref x i))))  
                 (substring x i)))))  
         #f)))  
   
 (define (rewrite-subject subj)  
   "Rewrite the subject line. If the value of the subject line begins  
 with \"ODP:\", replace it with \"Re:\". The original value of the subject  
 is preserved in X-Anubis-Preserved-Header header"  
   (DEBUG 1 "rewrite-subject called with " subj)  
   (let ((hdr (header->pair subj)))  
     (cond  
      ((eq? (car hdr) 'subject)  
       (let ((val (header->pair (cdr hdr))))  
         (cond  
          ((not val)  
           #t)  
          ((eq? (car val) 'odp)  
           (list  
            (string-append "Subject: Re: " (cdr val) "\n")  
            (string-append "X-Anubis-Preserved-Header: " (cdr hdr))))  
          (else #t))))  
      (else #t))))  
   
 ;;; The three functions below illustrate the concept of Anubis message  
37  ;;; processing functions.  ;;; processing functions.
38  ;;; A processing function takes two arguments:  ;;; A processing function takes two required and any number of
39    ;;; optional arguments. The required arguments are:
40  ;;;  ;;;
41  ;;;   HDR   -- A list of message headers. Each list element is a cons  ;;;   HDR   -- A list of message headers. Each list element is a cons
42  ;;;            (NAME . VALUE), where NAME is the name of the header field,  ;;;            (NAME . VALUE), where NAME is the name of the header field,
43  ;;;            and VALUE is its VALUE with final CRLF stripped off.  ;;;            and VALUE is its VALUE with final CRLF stripped off.
44  ;;;   BODY  -- The message body.  ;;;   BODY  -- The message body.
45  ;;;  ;;;
46    ;;; The rest of arguments are collected from the invocation string in
47    ;;; the configuration file and passed to the function.
48    ;;;
49  ;;; The function is expected to return cons:  ;;; The function is expected to return cons:
50  ;;;  ;;;
51  ;;;     (NEW-HDR . NEW-BODY)  ;;;     (NEW-HDR . NEW-BODY)
# Line 96  is preserved in X-Anubis-Preserved-Heade Line 58  is preserved in X-Anubis-Preserved-Heade
58  ;;;     #f  --  delete entire body.  ;;;     #f  --  delete entire body.
59  ;;;     #t  --  preserve the body as is.  ;;;     #t  --  preserve the body as is.
60    
61  (define (anubis-rot-13-all hdr body)  (define (sample-process-message hdr body . rest)
62    "Encode the \"Subject\" header and the body using ROT-13. Add    "If the Subject: field starts with characters \"ODP:\", replace
63  X-Processed-By header."  them with \"Re:\".
64    (DEBUG 1 "anubis-rot-13-all called with hdr=" hdr " and body=\"" body "\"")  
65    If REST is not empty, append its car to BODY"
66    
67      (DEBUG 1 "rewrite-subject called with hdr=" hdr " and body=\"" body "\"")
68      (DEBUG 2 "optional args=" rest)
69    (cons (append    (cons (append
70           (map (lambda (x)           (map (lambda (x)
71                  (if (string-ci=? (car x) "subject")                  (if (and (string-ci=? (car x) "subject")
72                      (cons (car x) (rot-13 (cdr x)))                           (string-ci=? (substring (cdr x) 0 4) "ODP:"))
73                        (cons (car x)
74                              (string-append "Re:"
75                                             (substring (cdr x) 4)))
76                      x))                      x))
77                hdr)                hdr)
78           (list (cons "X-Processed-By" "GNU Anubis")))           (list (cons "X-Processed-By" "GNU Anubis")))
79          (rot-13 body)))          (if (null? rest)
80                #t
81  (define (anubis-rot-13-header hdr body . rest)              (string-append body "\n" (car rest)))))
   "Encode the \"Subject\" header using ROT-13."  
   (DEBUG 1 "anubis-rot-13-header called with hdr=" hdr  
          " and body=\"" body "\" and rest=" rest ";")  
   (cons (map (lambda (x)  
                (if (string-ci=? (car x) "subject")  
                    (cons (car x) (rot-13 (cdr x)))  
                    x))  
              hdr)  
          #t))  
   
 (define (anubis-rot-13-body hdr body)  
   "Encode the message body using ROT-13."  
   (DEBUG 1 "anubis-rot-13-body called with hdr=" hdr " and body=\"" body "\"")  
   (cons #t  
         (rot-13 body)))  
82    
83  ;; To test your output redirection:  ;; To test your output redirection:
84  (DEBUG 1 "LOADED anubis.scm")  (DEBUG 1 "LOADED anubis.scm")

Legend:
Removed from v.1.5  
changed lines
  Added in v.1.6

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26