summaryrefslogtreecommitdiff
path: root/scripts/read-rfc822
blob: 0904d61d1df91186455e8ee1f2f22e083e65d2ea (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
main='(module-ref (resolve-module '\''(scripts read-rfc822)) '\'main')'
exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
!#
;;; read-rfc822 --- Validate RFC822 file by displaying it to stdout

;; 	Copyright (C) 2002, 2004, 2006 Free Software Foundation, Inc.
;;
;; This program 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, or
;; (at your option) any later version.
;;
;; This program 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 this software; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301 USA

;;; Author: Thien-Thi Nguyen <ttn@gnu.org>

;;; Commentary:

;; Usage: read-rfc822 FILE
;;
;; Read FILE, assumed to be in RFC822 format, and display it to stdout.
;; This is not very interesting, admittedly.
;;
;; For Scheme programming, this module exports two procs:
;;   (read-rfc822 . args)               ; only first arg used
;;   (read-rfc822-silently port)
;;
;; Parse FILE (a string) or PORT, respectively, and return a query proc that
;; takes a symbol COMP, and returns the message component COMP.  Supported
;; values for COMP (and the associated query return values) are:
;;   from       -- #f (reserved for future mbox support)
;;   headers    -- alist of (HEADER-SYMBOL . "VALUE-STRING") pairs, in order
;;   body       -- rest of the mail message, a string
;;   body-lines -- rest of the mail message, as a list of lines
;; Any other query results in a "bad component" error.
;;
;; TODO: Add "-m" option (mbox support).

;;; Code:

(define-module (scripts read-rfc822)
  :use-module (ice-9 regex)
  :use-module (ice-9 rdelim)
  :autoload (srfi srfi-13) (string-join)
  :export (read-rfc822 read-rfc822-silently))

(define from-line-rx   (make-regexp "^From "))
(define header-name-rx (make-regexp "^([^:]+):[ \t]*"))
(define header-cont-rx (make-regexp "^[ \t]+"))

(define option #f)                      ; for future "-m"

(define (drain-message port)
  (let loop ((line (read-line port)) (acc '()))
    (cond ((eof-object? line)
           (reverse acc))
          ((and option (regexp-exec from-line-rx line))
           (for-each (lambda (c)
                       (unread-char c port))
                     (cons #\newline
                           (reverse (string->list line))))
           (reverse acc))
          (else
           (loop (read-line port) (cons line acc))))))

(define (parse-message port)
  (let* ((from (and option
                    (match:suffix (regexp-exec from-line-rx
                                               (read-line port)))))
         (body-lines #f)
         (body #f)
         (headers '())
         (add-header! (lambda (reversed-hlines)
                        (let* ((hlines (reverse reversed-hlines))
                               (first (car hlines))
                               (m (regexp-exec header-name-rx first))
                               (name (string->symbol (match:substring m 1)))
                               (data (string-join
                                      (cons (substring first (match:end m))
                                            (cdr hlines))
                                      " ")))
                          (set! headers (acons name data headers))))))
    ;; "From " is only one line
    (let loop ((line (read-line port)) (current-header #f))
      (cond ((string-null? line)
             (and current-header (add-header! current-header))
             (set! body-lines (drain-message port)))
            ((regexp-exec header-cont-rx line)
             => (lambda (m)
                  (loop (read-line port)
                        (cons (match:suffix m) current-header))))
            (else
             (and current-header (add-header! current-header))
             (loop (read-line port) (list line)))))
    (set! headers (reverse headers))
    (lambda (component)
      (case component
        ((from) from)
        ((body-lines) body-lines)
        ((headers) headers)
        ((body) (or body
                    (begin (set! body (string-join body-lines "\n" 'suffix))
                           body)))
        (else (error "bad component:" component))))))

(define (read-rfc822-silently port)
  (parse-message port))

(define (display-rfc822 parse)
  (cond ((parse 'from) => (lambda (from) (format #t "From ~A\n" from))))
  (for-each (lambda (header)
              (format #t "~A: ~A\n" (car header) (cdr header)))
            (parse 'headers))
  (format #t "\n~A" (parse 'body)))

(define (read-rfc822 . args)
  (let ((parse (read-rfc822-silently (open-file (car args) OPEN_READ))))
    (display-rfc822 parse))
  #t)

(define main read-rfc822)

;;; read-rfc822 ends here