home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / imail / imail-rmail.scm < prev    next >
Text File  |  2001-06-11  |  14KB  |  400 lines
  1. ;;; -*-Scheme-*-
  2. ;;;
  3. ;;; $Id: imail-rmail.scm,v 1.68 2001/06/12 00:47:36 cph Exp $
  4. ;;;
  5. ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
  6. ;;;
  7. ;;; This program is free software; you can redistribute it and/or
  8. ;;; modify it under the terms of the GNU General Public License as
  9. ;;; published by the Free Software Foundation; either version 2 of the
  10. ;;; License, or (at your option) any later version.
  11. ;;;
  12. ;;; This program 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 GNU
  15. ;;; General Public License for more details.
  16. ;;;
  17. ;;; You should have received a copy of the GNU General Public License
  18. ;;; along with this program; if not, write to the Free Software
  19. ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  20. ;;; 02111-1307, USA.
  21.  
  22. ;;;; IMAIL mail reader: RMAIL back end
  23.  
  24. (declare (usual-integrations))
  25.  
  26. ;;;; URL
  27.  
  28. (define-class <rmail-url> (<file-url>))
  29. (define make-rmail-url (pathname-url-constructor <rmail-url>))
  30.  
  31. (define-pathname-url-predicates <rmail-url>
  32.   (lambda (pathname) (check-file-prefix pathname "BABYL OPTIONS:"))
  33.   (lambda (pathname) pathname #f)
  34.   (lambda (pathname)
  35.     (or (equal? (pathname-type pathname) "rmail")
  36.     (and (equal? (pathname-name pathname) "RMAIL")
  37.          (not (pathname-type pathname))))))
  38.  
  39. ;;;; Server operations
  40.  
  41. (define-method %create-resource ((url <rmail-url>))
  42.   (if (file-exists? (pathname-url-pathname url))
  43.       (error:bad-range-argument url 'CREATE-RESOURCE))
  44.   (let ((folder (make-rmail-folder url)))
  45.     (set-file-folder-messages! folder '#())
  46.     (set-rmail-folder-header-fields!
  47.      folder
  48.      (compute-rmail-folder-header-fields folder))
  49.     (set-file-folder-file-modification-time! folder (get-universal-time))
  50.     (set-file-folder-file-modification-count!
  51.      folder
  52.      (object-modification-count folder))
  53.     (save-resource folder)))
  54.  
  55. ;;;; Folder
  56.  
  57. (define-class (<rmail-folder> (constructor (locator))) (<file-folder>)
  58.   (header-fields define standard))
  59.  
  60. (define-method rmail-folder-header-fields ((folder <folder>))
  61.   (compute-rmail-folder-header-fields folder))
  62.  
  63. (define (compute-rmail-folder-header-fields folder)
  64.   (make-rmail-folder-header-fields (folder-flags folder)))
  65.  
  66. (define (make-rmail-folder-header-fields flags)
  67.   (list (make-header-field "Version" "5")
  68.     (make-header-field "Labels"
  69.                (decorated-string-append
  70.                 "" "," ""
  71.                 (flags->rmail-labels flags)))
  72.     (make-header-field "Note" "This is the header of an rmail file.")
  73.     (make-header-field "Note" "If you are seeing it in rmail,")
  74.     (make-header-field "Note" "it means the file has no messages in it.")))
  75.  
  76. (define-method open-resource ((url <rmail-url>))
  77.   (if (file-readable? (pathname-url-pathname url))
  78.       (maybe-make-resource url make-rmail-folder)
  79.       (begin
  80.     (unmemoize-resource url)
  81.     (error:bad-range-argument url 'OPEN-RESOURCE))))
  82.  
  83. ;;;; Message
  84.  
  85. (define-class (<rmail-message>
  86.            (constructor (header-fields body flags
  87.                        displayed-header-fields
  88.                        internal-time)))
  89.     (<file-message>)
  90.   displayed-header-fields
  91.   internal-time)
  92.  
  93. (define-generic rmail-message-displayed-header-fields (message))
  94.  
  95. (define-file-external-message-method rmail-message-displayed-header-fields
  96.   <rmail-message>
  97.   'DISPLAYED-HEADER-FIELDS
  98.   string->header-fields)
  99.  
  100. (define-method rmail-message-displayed-header-fields ((message <message>))
  101.   message
  102.   'UNDEFINED)
  103.  
  104. (let ((accessor (slot-accessor <rmail-message> 'INTERNAL-TIME)))
  105.   (define-method message-internal-time ((message <rmail-message>))
  106.     (or (accessor message)
  107.     (call-next-method message))))
  108.  
  109. (define-method make-message-copy ((message <message>) (folder <rmail-folder>))
  110.   folder
  111.   (make-rmail-message (message-header-fields message)
  112.               (file-message-body message)
  113.               (list-copy (message-flags message))
  114.               (rmail-message-displayed-header-fields message)
  115.               (message-internal-time message)))
  116.  
  117. ;;;; Read RMAIL file
  118.  
  119. (define-method revert-file-folder ((folder <rmail-folder>))
  120.   (read-file-folder-contents folder
  121.     (lambda (port)
  122.       (set-rmail-folder-header-fields! folder (read-rmail-prolog port))
  123.       (let loop ((line #f) (index 0) (messages '()))
  124.     (if (= 0 (remainder index 100))
  125.         (imail-ui:progress-meter index #f))
  126.     (call-with-values (lambda () (read-rmail-message folder port line))
  127.       (lambda (message line)
  128.         (if message
  129.         (begin
  130.           (attach-message! message folder index)
  131.           (loop line (+ index 1) (cons message messages)))
  132.         (list->vector (reverse! messages)))))))))
  133.  
  134. (define (read-rmail-prolog port)
  135.   (if (not (rmail-prolog-start-line? (read-required-line port)))
  136.       (error "Not an RMAIL file:" port))
  137.   (lines->header-fields (read-lines-to-eom port)))
  138.  
  139. (define (read-rmail-message folder port read-ahead-line)
  140.   (let ((line (or read-ahead-line (read-line port))))
  141.     (cond ((eof-object? line)
  142.        (values #f #f))
  143.       ((rmail-prolog-start-line? line)
  144.        (discard-to-eom port)
  145.        (read-rmail-message folder port #f))
  146.       ((rmail-message-start-line? line)
  147.        (values (read-rmail-message-1 folder port) #f))
  148.       ((umail-delimiter? line)
  149.        (read-umail-message folder line port
  150.          (lambda (line)
  151.            (or (rmail-prolog-start-line? line)
  152.            (rmail-message-start-line? line)
  153.            (umail-delimiter? line)))))
  154.       (else
  155.        (error "Malformed RMAIL file:" port)))))
  156.  
  157. (define (read-rmail-message-1 folder port)
  158.   (call-with-values (lambda () (read-rmail-attributes-line port))
  159.     (lambda (formatted? flags)
  160.       (let* ((headers (read-rmail-alternate-headers port))
  161.          (displayed-headers (read-rmail-displayed-headers port))
  162.          (body (read-rmail-body port))
  163.          (finish
  164.           (lambda (headers displayed-headers)
  165.         (call-with-values
  166.             (lambda ()
  167.               (parse-rmail-internal-time-header folder headers))
  168.           (lambda (headers time)
  169.             (make-rmail-message headers
  170.                     body
  171.                     flags
  172.                     displayed-headers
  173.                     time))))))
  174.     (if formatted?
  175.         (finish headers displayed-headers)
  176.         (finish displayed-headers 'UNDEFINED))))))
  177.  
  178. (define (read-rmail-attributes-line port)
  179.   (let ((line (read-required-line port)))
  180.     (let ((n (string-length line))
  181.       (lose
  182.        (lambda ()
  183.          (error "Malformed RMAIL message-attributes line:" line))))
  184.       (if (not (and (fix:>= n 3)
  185.             (char=? (string-ref line 1) #\,)))
  186.       (lose))
  187.       (values (cond ((char=? (string-ref line 0) #\0) #f)
  188.             ((char=? (string-ref line 0) #\1) #t)
  189.             (else (lose)))
  190.           (let loop ((i 2) (flags '()) (unseen? #f))
  191.         (if (fix:< i n)
  192.             (if (or (char=? (string-ref line i) #\space)
  193.                 (char=? (string-ref line i) #\,))
  194.             (loop (fix:+ i 1) flags unseen?)
  195.             (let scan-token ((i* (fix:+ i 1)))
  196.               (if (or (fix:= i* n)
  197.                   (char=? (string-ref line i*) #\space)
  198.                   (char=? (string-ref line i*) #\,))
  199.                   (let ((flag (substring line i i*)))
  200.                 (if (string-ci=? flag "unseen")
  201.                     (loop i* flags #t)
  202.                     (loop i* (cons flag flags) unseen?)))
  203.                   (scan-token (fix:+ i* 1)))))
  204.             (if unseen?
  205.             (reverse! flags)
  206.             (cons "seen" (reverse! flags)))))))))
  207.  
  208. (define (read-rmail-alternate-headers port)
  209.   (let ((start (xstring-port/position port)))
  210.     (make-file-external-ref
  211.      start
  212.      (let* ((separator rmail-message:headers-separator)
  213.         (s0 (string-ref separator 0))
  214.         (sl (string-length separator)))
  215.        (let loop ()
  216.      (let ((char (read-required-char port)))
  217.        (cond ((char=? char #\newline)
  218.           (let ((end (- (xstring-port/position port) 1)))
  219.             (if (not (string=? separator (read-required-line port)))
  220.             (error "Missing RMAIL headers-separator string:" port))
  221.             end))
  222.          ((char=? char s0)
  223.           (let ((line (read-required-line port)))
  224.             (if (substring=? line 0 (string-length line)
  225.                      separator 1 sl)
  226.             (- (xstring-port/position port)
  227.                (+ (string-length line) 1))
  228.             (loop))))
  229.          (else
  230.           (skip-to-line-start port)
  231.           (loop)))))))))
  232.  
  233. (define (read-rmail-displayed-headers port)
  234.   (let ((start (xstring-port/position port)))
  235.     (skip-past-blank-line port)
  236.     (make-file-external-ref start (- (xstring-port/position port) 1))))
  237.  
  238. (define (read-rmail-body port)
  239.   (let ((start (xstring-port/position port)))
  240.     (input-port/discard-chars port rmail-message:end-char-set)
  241.     (input-port/discard-char port)
  242.     (make-file-external-ref start (- (xstring-port/position port) 1))))
  243.  
  244. (define (parse-rmail-internal-time-header folder headers)
  245.   (call-with-values
  246.       (lambda () (file-folder-strip-internal-headers folder headers))
  247.     (lambda (headers internal-headers)
  248.       (values headers
  249.           (let ((v
  250.              (get-first-header-field internal-headers
  251.                          "X-IMAIL-INTERNAL-TIME"
  252.                          #f)))
  253.         (and v
  254.              (parse-header-field-date v)))))))
  255.  
  256. ;;;; Write RMAIL file
  257.  
  258. (define-method write-file-folder ((folder <rmail-folder>) pathname)
  259.   (call-with-binary-output-file pathname
  260.     (lambda (port)
  261.       (write-rmail-file-header (rmail-folder-header-fields folder) port)
  262.       (for-each-vector-element (file-folder-messages folder)
  263.     (lambda (message)
  264.       (write-rmail-message message port))))))
  265.  
  266. (define-method append-message-to-file ((message <message>) (url <rmail-url>))
  267.   (let ((pathname (pathname-url-pathname url)))
  268.     (let ((exists? (file-exists? pathname)))
  269.       (if exists?
  270.       (call-with-binary-append-file pathname
  271.         (lambda (port)
  272.           (write-rmail-message message port)))
  273.       (call-with-binary-output-file pathname
  274.         (lambda (port)
  275.           (write-rmail-file-header (make-rmail-folder-header-fields '())
  276.                        port)
  277.           (write-rmail-message message port))))
  278.       (not exists?))))
  279.  
  280. (define (write-rmail-file-header header-fields port)
  281.   (write-string "BABYL OPTIONS: -*- rmail -*-" port)
  282.   (newline port)
  283.   (write-header-fields header-fields port)
  284.   (write-char rmail-message:end-char port))
  285.  
  286. (define (write-rmail-message message port)
  287.   (write-char rmail-message:start-char port)
  288.   (newline port)
  289.   (let ((headers
  290.      (let ((headers (message-header-fields message))
  291.            (time (message-internal-time message)))
  292.        (if time
  293.            (cons (make-header-field "X-IMAIL-INTERNAL-TIME"
  294.                     (universal-time->string time))
  295.              headers)
  296.            headers)))
  297.     (displayed-headers (rmail-message-displayed-header-fields message)))
  298.     (let ((formatted? (not (eq? 'UNDEFINED displayed-headers))))
  299.       (write-rmail-attributes-line message formatted? port)
  300.       (if formatted? (write-header-fields headers port))
  301.       (write-string rmail-message:headers-separator port)
  302.       (newline port)
  303.       (write-header-fields (if formatted? displayed-headers headers) port)
  304.       (write-message-body message port)
  305.       (fresh-line port)
  306.       (write-char rmail-message:end-char port))))
  307.  
  308. (define (write-rmail-attributes-line message formatted? port)
  309.   (write-char (if formatted? #\1 #\0) port)
  310.   (write-char #\, port)
  311.   (call-with-values (lambda () (flags->rmail-markers (message-flags message)))
  312.     (lambda (attributes labels)
  313.       (let ((write-markers
  314.          (lambda (markers)
  315.            (for-each (lambda (marker)
  316.                (write-char #\space port)
  317.                (write-string marker port)
  318.                (write-char #\, port))
  319.              markers))))
  320.     (write-markers attributes)
  321.     (write-char #\, port)
  322.     (write-markers labels))))
  323.   (newline port))
  324.  
  325. ;;;; Attributes and labels
  326.  
  327. (define (rmail-markers->flags attributes labels)
  328.   (let loop ((strings (append attributes labels)) (flags '()))
  329.     (if (pair? strings)
  330.     (loop (cdr strings) (cons (car strings) flags))
  331.     (reverse!
  332.      (if (flags-member? "unseen" flags)
  333.          (flags-delete! "unseen" flags)
  334.          (cons "seen" flags))))))
  335.  
  336. (define (flags->rmail-markers flags)
  337.   (let loop
  338.       ((flags
  339.     (if (flags-member? "seen" flags)
  340.         (flags-delete "seen" flags)
  341.         (cons "unseen" flags)))
  342.        (attributes '())
  343.        (labels '()))
  344.     (if (pair? flags)
  345.     (if (member (car flags) rmail-attributes)
  346.         (loop (cdr flags) (cons (car flags) attributes) labels)
  347.         (loop (cdr flags) attributes (cons (car flags) labels)))
  348.     (values (reverse! attributes) (reverse! labels)))))
  349.  
  350. (define (flags->rmail-labels flags)
  351.   (call-with-values (lambda () (flags->rmail-markers flags))
  352.     (lambda (attributes labels)
  353.       attributes
  354.       labels)))
  355.  
  356. ;;;; Syntactic Markers
  357.  
  358. (define (rmail-prolog-start-line? line)
  359.   (string-prefix? "BABYL OPTIONS:" line))
  360.  
  361. (define (rmail-prolog-end-line? line)
  362.   (string-prefix? "\037" line))
  363.  
  364. (define (rmail-message-start-line? line)
  365.   (string=? "\f" line))
  366.  
  367. (define rmail-message:headers-separator
  368.   "*** EOOH ***")
  369.  
  370. (define rmail-message:start-char
  371.   #\page)
  372.  
  373. (define rmail-message:end-char
  374.   (integer->char #x1f))
  375.  
  376. (define rmail-message:end-char-set
  377.   (char-set rmail-message:end-char))
  378.  
  379. (define rmail-attributes
  380.   '("deleted" "answered" "unseen" "filed" "forwarded" "edited" "resent"))
  381.  
  382. (define (read-lines-to-eom port)
  383.   (source->list
  384.    (lambda ()
  385.      (if (eqv? rmail-message:end-char (peek-char port))
  386.      (begin
  387.        (read-char port)        ;discard
  388.        (make-eof-object port))
  389.      (read-required-line port)))))
  390.  
  391. (define (read-to-eom port)
  392.   (let ((string (read-string rmail-message:end-char-set port)))
  393.     (if (or (eof-object? string)
  394.         (eof-object? (read-char port)))
  395.     (error "EOF while reading RMAIL message body:" port))
  396.     string))
  397.  
  398. (define (discard-to-eom port)
  399.   (input-port/discard-chars port rmail-message:end-char-set)
  400.   (input-port/discard-char port))