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) |
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") |