#!/usr/bin/guile \
-e "(scripts read-rfc822)" -s
!#
;;; read-rfc822 --- Validate RFC822 file by displaying it to stdout

;; 	Copyright (C) 2002,2003,2004 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.
;;
;; As a special exception, the Free Software Foundation gives permission
;; for additional uses of the text contained in its release of GUILE.
;;
;; The exception is that, if you link the GUILE library with other files
;; to produce an executable, this does not by itself cause the
;; resulting executable to be covered by the GNU General Public License.
;; Your use of that executable is in no way restricted on account of
;; linking the GUILE library code into it.
;;
;; This exception does not however invalidate any other reasons why
;; the executable file might be covered by the GNU General Public License.
;;
;; This exception applies only to the code released by the
;; Free Software Foundation under the name GUILE.  If you copy
;; code from other Free Software Foundation releases into a copy of
;; GUILE, as the General Public License permits, the exception does
;; not apply to the code that you add in this way.  To avoid misleading
;; anyone as to the status of such modified files, you must delete
;; this exception notice from them.
;;
;; If you write modifications of your own for GUILE, it is your choice
;; whether to permit this exception to apply to your modifications.
;; If you do not wish that, delete this exception notice.

;;; 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
;; COMP (keyword or symbol) 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)
  #:autoload (scripts PROGRAM) (HVQC-MAIN)
  #:autoload (ice-9 regex) (match:suffix match:substring)
  #:autoload (ice-9 rdelim) (read-line)
  #: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 (if (symbol? component)
                (symbol->keyword component)
                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) (simple-format #t "From ~A\n" from))))
  (for-each (lambda (header)
              (simple-format #t "~A: ~A\n" (car header) (cdr header)))
            (parse 'headers))
  (simple-format #t "\n~A" (parse 'body)))

(define (read-rfc822 . args)
  (let* ((inp (open-input-file (car args)))
         (parse (read-rfc822-silently inp)))
    (close-port inp)
    (display-rfc822 parse))
  #t)

(define (main args)
  (HVQC-MAIN args (lambda (args)
                    (apply read-rfc822 (cdr args)))
             '(usage . commentary)
             '(package . "Guile")))

;;; read-rfc822 ends here
