1;;; 2;;; remailer.scm 3;;; 4;;; This file is part of GNU Anubis. 5;;; Copyright (C) 2003-2014 The Anubis Team. 6;;; 7;;; GNU Anubis is free software; you can redistribute it and/or modify it 8;;; under the terms of the GNU General Public License as published by the 9;;; Free Software Foundation; either version 3 of the License, or (at your 10;;; option) any later version. 11;;; 12;;; GNU Anubis is distributed in the hope that it will be useful, 13;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 14;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15;;; GNU General Public License for more details. 16;;; 17;;; You should have received a copy of the GNU General Public License along 18;;; with GNU Anubis. If not, see <http://www.gnu.org/licenses/>. 19 20(define (get-opt-arg opt-args tag) 21 (cond 22 ((member tag opt-args) => 23 (lambda (x) 24 (car (cdr x)))) 25 (else 26 #f))) 27 28(define (remailer-I hdr body . rest) 29 "Reformat the body of the message so it can be used with type-I remailers. 30Keyword arguments are: 31 #:rrt address -- Add Anon-To: header 32 #:post address -- Add Anon-Post-To: header 33 #:latent time -- Add Latent-Time: header 34 #:random -- Add random suffix to the latent time. 35 #:header header -- Add remailer header" 36 (let* ((pfx (string-append 37 (cond 38 ((get-opt-arg rest #:rrt) => 39 (lambda (x) 40 (string-append "Anon-To: " x "\n"))) 41 (else 42 "")) 43 (cond 44 ((get-opt-arg rest #:post) => 45 (lambda (x) 46 (string-append "Anon-Post-To: " x "\n"))) 47 (else 48 "")) 49 (cond 50 ((get-opt-arg rest #:latent) => 51 (lambda (x) 52 (string-append "Latent-Time: +" x 53 (if (member #:random rest) "r" "") "\n"))) 54 (else 55 "")) 56 (cond 57 ((get-opt-arg rest #:header) => 58 (lambda (x) 59 (string-append "##\n" x "\n"))) 60 (else 61 ""))))) 62 (if (string-null? pfx) 63 (cons #t #t) 64 (cons #t (string-append "::\n" pfx "\n" body))))) 65 66;;;; End of remailer.scm 67