summaryrefslogtreecommitdiffabout
path: root/guile
authorSergey Poznyakoff <gray@gnu.org.ua>2004-04-22 14:00:13 (GMT)
committer Sergey Poznyakoff <gray@gnu.org.ua>2004-04-22 14:00:13 (GMT)
commit98ee91e1be0aeb2770d97b3fc5d33331acac3755 (patch) (side-by-side diff)
treed974814b23f4c9c397563f8a9d69a4827703843d /guile
parentb6c1517702dfa975f06c3e473dba828b6b5e653f (diff)
downloadanubis-98ee91e1be0aeb2770d97b3fc5d33331acac3755.tar.gz
anubis-98ee91e1be0aeb2770d97b3fc5d33331acac3755.tar.bz2
Added to the repository
Diffstat (limited to 'guile') (more/less context) (ignore whitespace changes)
-rw-r--r--guile/entire-msg.scm224
1 files changed, 224 insertions, 0 deletions
diff --git a/guile/entire-msg.scm b/guile/entire-msg.scm
new file mode 100644
index 0000000..c72ae61
--- a/dev/null
+++ b/guile/entire-msg.scm
@@ -0,0 +1,224 @@
+;;;; GNU Anubis -- an outgoing mail processor and the SMTP tunnel.
+;;;; Copyright (C) 2003, 2004 The Anubis Team.
+;;;;
+;;;; GNU Anubis is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2 of the License, or
+;;;; (at your option) any later version.
+;;;;
+;;;; GNU Anubis is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with GNU Anubis; if not, write to the Free Software
+;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+;;;;
+;;;; GNU Anubis is released under the GPL with the additional exemption that
+;;;; compiling, linking, and/or using OpenSSL is allowed.
+
+(use-modules (ice-9 popen))
+
+;; Starts program PROG with arguments ARGS
+;; Returns a list:
+;; (PID OUTPUT-PORT INPUT-PORT)
+;; Where
+;; PID -- pid of the program
+;; OUTPUT-PORT -- output port connected to the stdin of the program
+;; INPUT-PORT -- input port connected to the stdout of the program
+;; Note:
+;; When no longer needed, the returned list must be fed to
+;; (close-subprocess). See below.
+(define (create-subprocess prog args)
+ (let ((inp (pipe))
+ (outp (pipe))
+ (pid (primitive-fork)))
+ (setvbuf (cdr inp) _IONBF)
+ (setvbuf (cdr outp) _IONBF)
+ ;; (car inp) -> child current-input-port
+ ;; (cdr inp) -> parent write port
+ ;; (car outp) -> parent read port
+ ;; (cdr outp) -> child current-output-port
+ (cond
+ ((= pid 0)
+ ;; Child
+ (let ((in-fd (fileno (car inp)))
+ (out-fd (fileno (cdr outp)))
+ (err-fd (fileno (current-error-port))))
+ (port-for-each (lambda (pt-entry)
+ (false-if-exception
+ (let ((pt-fileno (fileno pt-entry)))
+ (if (not (or (= pt-fileno in-fd)
+ (= pt-fileno out-fd)
+ (= pt-fileno err-fd)))
+ (close-fdes pt-fileno))))))
+ ;; copy the three selected descriptors to the standard
+ ;; descriptors 0, 1, 2.
+
+ (cond ((not (= in-fd 0))
+ (if (= out-fd 0)
+ (set! out-fd (dup->fdes 0)))
+ (if (= err-fd 0)
+ (set! err-fd (dup->fdes 0)))
+ (dup2 in-fd 0)))
+
+ (cond ((not (= out-fd 1))
+ (if (= err-fd 1)
+ (set! err-fd (dup->fdes 1)))
+ (dup2 out-fd 1)))
+
+ (dup2 err-fd 2)
+
+ (apply execlp prog prog args)))
+ (else
+ ;; Parent
+ (close-port (car inp))
+ (close-port (cdr outp))
+ (list pid (cdr inp) (car outp))))))
+
+;; Closes the communication channels and destroys the subprocess created
+;; by (create-subprocess)
+(define (close-subprocess p)
+ (close-port (list-ref p 1))
+ (close-port (list-ref p 2))
+ (silent-waitpid (car p)))
+
+;; Auxiliary function. Asynchronously feeds data to external program.
+;; Returns pid of the feeder process.
+(define (writer outport hdr body)
+ (let ((pid (primitive-fork)))
+ (cond
+ ((= pid 0)
+ (with-output-to-port
+ outport
+ (lambda ()
+ (for-each
+ (lambda (x)
+ (display (car x))
+ (display ": ")
+ (display (cdr x))
+ (newline))
+ hdr)
+ (newline)
+ (display body)))
+ (port-for-each close-port)
+ (primitive-exit 0))
+ (else
+ ;; Parent
+ (close-port outport)
+ pid))))
+
+;; Auxiliary function. Returns #t if LINE is an empty line.
+(define (empty-line? line)
+ (or (eof-object? line)
+ (string-null? line)))
+
+;; Read RFC822 headers from current input port and convert them
+;; to the form understandable by Anubis
+(define (read-headers port)
+ (let ((hdr-list '())
+ (header-name #f)
+ (header-value ""))
+ (do ((line (read-line port) (read-line port)))
+ ((empty-line? line) #t)
+ (cond
+ ((char-whitespace? (string-ref line 0))
+ (set! header-value (string-append header-value line)))
+ (else
+ (if header-name
+ (set! hdr-list (append hdr-list
+ (list (cons header-name header-value)))))
+ (let ((off (string-index line #\:)))
+ (set! header-name (substring line 0 off))
+ (set! header-value (substring
+ line
+ (do ((i (1+ off) (1+ i)))
+ ((not (char-whitespace?
+ (string-ref line i))) i))))))))
+ (if header-name
+ (set! hdr-list (append hdr-list
+ (list (cons header-name header-value)))))
+ hdr-list))
+
+;; Read message body from the current input port
+(define (read-body port)
+ (let ((text-list '()))
+ (do ((line (read-line port) (read-line port)))
+ ((eof-object? line) #t)
+ (set! text-list (append text-list (list line "\n"))))
+ (apply string-append text-list)))
+
+;; Auxiliary function. Reads output from the external program and
+;; converts it to the internal Anubis representation.
+(define (reader inport)
+ (cons (read-headers inport) (read-body inport)))
+
+(define (optarg-value opt-args tag)
+ (cond
+ ((member tag opt-args) =>
+ (lambda (x)
+ (car (cdr x))))
+ (else
+ #f)))
+
+(define (silent-waitpid pid)
+ (catch #t
+ (lambda ()
+ (waitpid pid))
+ (lambda args
+ #t)))
+
+;; A Guile interface for feeding entire message (including headers)
+;; to an external program.
+;;
+;; Usage:
+;; BEGIN GUILE
+;; guile-load-program entire-msg.scm
+;; END
+;;
+;; SECTION RULE
+;; guile-process entire-msg-filter PROGNAME [ARGS...]
+
+(define (entire-msg-filter hdr body . rest)
+ (let ((progname (car rest))
+ (args (cdr rest)))
+ (let* ((p (create-subprocess progname args))
+ (wrpid (writer (list-ref p 1) hdr body)))
+ (let ((ret (reader (list-ref p 2))))
+ (silent-waitpid wrpid)
+ (close-subprocess p)
+ ret))))
+
+;; Openssl version 0.9.7d exhibits strange lossage: it attempts to
+;; rewind the input stream even if it is a pipe. To overcome this,
+;; we have to use a temporary file.
+;;
+;; Usage:
+;; BEGIN GUILE
+;; guile-load-program entire-msg.scm
+;; END
+;;
+;; BEGIN RULE
+;; guile-process openssl-filter /path/to/openssl smime -sign -signer FILE
+;; END
+
+(define (openssl-filter hdr body . rest)
+ (let ((progname (car rest))
+ (args (cdr rest))
+ (tempfile "/tmp/ANXXXXXX"))
+
+ (mkstemp! tempfile)
+ (with-output-to-file
+ tempfile
+ (lambda ()
+ (display body)))
+
+ (let* ((p (create-subprocess progname
+ (append args (list "-in" tempfile)))))
+ (let ((ret (reader (list-ref p 2))))
+ (close-subprocess p)
+ (delete-file tempfile)
+ (cons (append hdr (car ret)) (cdr ret))))))
+
+;; End of entire-msg.scm

Return to:

Send suggestions and report system problems to the System administrator.