From 2da3c37ea0926b2941a7942ed6a8382016c2907f Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Tue, 4 Jan 2000 22:52:21 +0000 Subject: [PATCH] Initial revision --- v7/src/imail/imail-core.scm | 603 +++++++++++++++++++++++++++++++++++ v7/src/imail/imail-file.scm | 111 +++++++ v7/src/imail/imail-rmail.scm | 445 ++++++++++++++++++++++++++ v7/src/imail/imail-top.scm | 89 ++++++ v7/src/imail/imail-umail.scm | 175 ++++++++++ v7/src/imail/imail-util.scm | 185 +++++++++++ v7/src/imail/load.scm | 29 ++ v7/src/imail/print.sh | 21 ++ v7/src/imail/rfc822.scm | 261 +++++++++++++++ 9 files changed, 1919 insertions(+) create mode 100644 v7/src/imail/imail-core.scm create mode 100644 v7/src/imail/imail-file.scm create mode 100644 v7/src/imail/imail-rmail.scm create mode 100644 v7/src/imail/imail-top.scm create mode 100644 v7/src/imail/imail-umail.scm create mode 100644 v7/src/imail/imail-util.scm create mode 100644 v7/src/imail/load.scm create mode 100755 v7/src/imail/print.sh create mode 100644 v7/src/imail/rfc822.scm diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm new file mode 100644 index 000000000..2dc45cf37 --- /dev/null +++ b/v7/src/imail/imail-core.scm @@ -0,0 +1,603 @@ +;;; -*-Scheme-*- +;;; +;;; $Id: imail-core.scm,v 1.1 2000/01/04 22:50:53 cph Exp $ +;;; +;;; Copyright (c) 1999 Massachusetts Institute of Technology +;;; +;;; 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 of the +;;; License, 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 program; if not, write to the Free Software +;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +;;;; IMAIL mail reader: core definitions + +;;; **** Implement file backup. +;;; **** Strip IMAIL headers when importing or exporting messages. +;;; (What does that mean, precisely?) + +(declare (usual-integrations)) + +;;;; URL type + +(define-class ()) + +;; Return the canonical name of URL's protocol as a string. +(define-generic url-protocol (url)) + +;; Return the body of URL as a string. +(define-generic url-body (url)) + +(define (guarantee-url url procedure) + (if (not (url? url)) + (error:wrong-type-argument url "IMAIL url" procedure))) + +(define-method write-instance ((url ) port) + (write-instance-helper 'URL url port + (lambda () + (write-char #\space port) + (write (url->string url) port)))) + +(define (make-url protocol body) + (string->url (string-append protocol ":" body))) + +(define (->url object) + (cond ((url? object) object) + ((string? object) (string->url object)) + (else (error:wrong-type-argument object "URL" '->URL)))) + +(define (string->url string) + (or (hash-table/get saved-urls string #f) + (let ((url + (let ((colon (string-find-next-char string #\:))) + (if (not colon) + (error "Malformed URL string:" string)) + ((get-url-protocol-parser (string-head string colon)) + (string-tail string (fix:+ colon 1)))))) + (hash-table/put! saved-urls string url) + url))) + +(define saved-urls + (make-string-hash-table)) + +(define (url->string url) + (string-append (url-protocol url) ":" (url-body url))) + +(define (define-url-protocol name class parser) + (define-method url-protocol ((url class)) url name) + (hash-table/put! url-protocol-parsers (string-downcase name) parser)) + +(define (get-url-protocol-parser name) + (let ((parser + (hash-table/get url-protocol-parsers (string-downcase name) #f))) + (if (not parser) + (error:bad-range-argument name 'GET-URL-PROTOCOL-PARSER)) + parser)) + +(define url-protocol-parsers + (make-string-hash-table)) + +(define (get-memoized-folder url) + (let ((folder (hash-table/get memoized-folders url #f))) + (and folder + (if (%folder-valid? folder) + folder + (begin + (unmemoize-folder url) + #f))))) + +(define (memoize-folder folder) + (hash-table/put! memoized-folders (folder-url folder) folder) + folder) + +(define (unmemoize-folder url) + (hash-table/remove! memoized-folders url)) + +(define memoized-folders + (make-eq-hash-table)) + +;;;; Server operations + +;; Open the folder named URL. +(define (open-folder url) + (let ((url (->url url))) + (or (get-memoized-folder url) + (memoize-folder (%open-folder url))))) + +(define-generic %open-folder (url)) + +;; Create a new folder named URL. Signal an error if the folder +;; already exists or can't be created. +(define (new-folder url) + (let ((url (->url url))) + (if (get-memoized-folder url) + (error "Folder already exists:" url) + (memoize-folder (%new-folder url))))) + +(define-generic %new-folder (url)) + +;; Delete the folder named URL. Signal an error if the folder doesn't +;; exist or if it can't be deleted. +(define (delete-folder url) + (let ((url (->url url))) + (unmemoize-folder url) + (%delete-folder url))) + +(define-generic %delete-folder (url)) + +;; Move the folder named URL to NEW-URL. Signal an error if the +;; folder doesn't exist, if NEW-URL already refers to a folder, or if +;; the move can't be performed for some reason. This operation can be +;; also be used to convert between protocols, e.g. to move a folder +;; from a server to a file. +(define (move-folder url new-url) + (let ((url (->url url)) + (new-url (->url new-url))) + (unmemoize-folder url) + (%move-folder url new-url))) + +(define-generic %move-folder (url new-url)) + +(define-method %move-folder ((url ) (new-url )) + (%copy-folder url new-url) + (%delete-folder url)) + +;; Copy the folder named URL to be NEW-URL. Signal an error if the +;; folder doesn't exist, if NEW-URL already refers to a folder, or if +;; the copy can't be performed for some reason. +(define (copy-folder url new-url) + (%copy-folder (->url url) (->url new-url))) + +(define-generic %copy-folder (url new-url)) + +(define-method %copy-folder ((url ) (new-url )) + (%write-folder (open-folder url) new-url)) + +;; Return a list of URLs for folders that match URL-PATTERN. +;; URL-PATTERN can contain wildcards. +(define-generic available-folder-names (url-pattern)) + +;; [This is an IMAP command that appears to be designed to support +;; delivery of usenet news.] +(define-generic subscribed-folder-names (url-pattern)) + +;; Define AUTHENTICATOR to be the authenticator to use in the dynamic +;; extent of THUNK. + +;; AUTHENTICATOR is a procedure that performs authentication, for +;; protocols that require it. AUTHENTICATOR is called with URL as its +;; only argument and must return the authentication information, +;; usually a username/password, as multiple values. + +;; For protocols that don't require authentication, AUTHENTICATOR is +;; not called, and BIND-AUTHENTICATOR need not be used. + +;; [AUTHENTICATOR can be called at a variety of times; these will be +;; made more explicit when known.] + +(define (bind-authenticator authenticator thunk) + (fluid-let ((authenticate authenticator)) + (thunk))) + +(define authenticate) + +;;;; Folder type + +(define-class ()) + +(define (guarantee-folder folder procedure) + (if (not (folder? folder)) + (error:wrong-type-argument folder "IMAIL folder" procedure))) + +;; Return the URL of FOLDER. +(define-generic folder-url (folder)) + +;; Return #T if FOLDER represents a real folder, i.e. has a +;; corresponding file or server entry. +(define (folder-valid? folder) + (eq? folder (get-memoized-folder (folder-url folder)))) + +(define-generic %folder-valid? (folder)) + +;; Return the number of messages in FOLDER. +(define-generic count-messages (folder)) + +;; Get the INDEX'th message in FOLDER and return it. Signal an +;; error for invalid INDEX. +(define (get-message folder index) + (guarantee-index index 'GET-MESSAGE) + (if (not (fix:< index (length (count-messages folder)))) + (error:bad-range-argument index 'GET-MESSAGE)) + (%get-message folder index)) + +(define-generic %get-message (folder index)) + +;; Insert a copy of MESSAGE in FOLDER at INDEX; pre-existing messages +;; with indices of INDEX or higher have their indices incremented. +;; Unspecified result. +(define (insert-message folder index message) + (guarantee-index index 'INSERT-MESSAGE) + (if (not (fix:<= index (length (count-messages folder)))) + (error:bad-range-argument index 'INSERT-MESSAGE)) + (guarantee-message message 'INSERT-MESSAGE) + (%insert-message folder index message)) + +(define-generic %insert-message (folder index message)) + +;;; Insert a copy of MESSAGE in FOLDER at the end of the existing +;;; messages. Unspecified result. +(define (append-message folder message) + (guarantee-message message 'APPEND-MESSAGE) + (%append-message folder message)) + +(define-generic %append-message (folder message)) + +;; Remove all messages in FOLDER that are marked for deletion. +;; Unspecified result. +(define-generic expunge-deleted-messages (folder)) + +;; Search FOLDER for messages matching CRITERIA, returning them in a +;; list. [Possible values for CRITERIA not yet defined.] Returns a +;; list of messages. +(define-generic search-folder (folder criteria)) + +;; Poll the inbox associated with FOLDER to see if there is new mail. +;; If so, the mail is appended to FOLDER. Return the number of new +;; messages. Return #F if FOLDER has no associated inbox. +(define-generic poll-folder (folder)) + +;; Synchronize the local copy of FOLDER with the server's copy. +;; Unspecified result. Meaningless for file-based protocols. +(define-generic synchronize-folder (folder)) + +;; Save any changes made to FOLDER. This permits the use of caches +;; for improved performance. +(define (save-folder folder) + (%save-folder folder)) + +(define-generic %save-folder (folder)) + +(define-method %save-folder ((folder )) + (%write-folder folder (folder-url folder))) + +;; Write the contents of FOLDER to URL. +(define-generic %write-folder (folder url)) + +;; [These are IMAP commands that appear to be designed to support +;; delivery of usenet news.] +(define-generic subscribe-folder (folder)) +(define-generic unsubscribe-folder (folder)) + +;;;; Message type + +(define-structure (message (type-descriptor message-rtd) + (safe-accessors #t)) + header-fields + body + flags + properties) + +(define (guarantee-message message procedure) + (if (not (message? message)) + (error:wrong-type-argument message "IMAIL message" procedure))) + +(define-generic header-fields (object)) + +(define-method header-fields ((message message-rtd)) + (message-header-fields message)) + +(define (copy-message message) + (make-message (map copy-header-field (message-header-fields message)) + (message-body message) + (list-copy (message-flags message)) + (alist-copy (message-properties message)))) + +(define (make-standard-message headers body) + (let loop ((headers headers) (headers* '()) (flags '()) (properties '())) + (cond ((not (pair? headers)) + (make-message (reverse! headers*) + body + (reverse! flags) + (reverse! properties))) + ((header-field->message-flags (car headers)) + => (lambda (flags*) + (loop (cdr headers) + headers* + (append! (reverse! (cdr flags*)) flags) + properties))) + ((header-field->message-property header) + => (lambda (property) + (loop (cdr headers) + headers* + flags + (cons property properties)))) + (else + (loop (cdr headers) + (cons (car headers) headers*) + flags + properties))))) + +;;;; Message flags + +;;; Flags are markers that can be attached to messages. They indicate +;;; state about the message, such as whether it has been deleted, +;;; seen, etc. A flag is represented by a symbol or a string; symbols +;;; represent standard flags with predefined meanings, while strings +;;; represent user-defined flags. + +(define (message-flagged? message flag) + (guarantee-message-flag flag 'MESSAGE-FLAGGED?) + (if (member flag (message-flags message)) #t #f)) + +(define (set-message-flag message flag) + (guarantee-message-flag flag 'SET-MESSAGE-FLAG) + (let ((flags (message-flags message))) + (if (not (member flag flags)) + (set-message-flags! message (cons flag flags))))) + +(define (clear-message-flag message flag) + (set-message-flags! message (delete flag (message-flags message)))) + +(define (message-flag? object) + (or (memq object standard-message-flags) + (header-field-name? object))) + +(define (guarantee-message-flag object procedure) + (if (not (message-flag? object)) + (error:wrong-type-argument object "message flag" procedure))) + +(define standard-message-flags + ;; **** Use SEEN rather than UNSEEN? + '(DELETED ANSWERED UNSEEN FILED FORWARDED EDITED RESENT)) + +(define (message-deleted? message) + (message-flagged? message 'DELETED)) + +(define (delete-message message) + (set-message-flag message 'DELETED)) + +(define (undelete-message message) + (clear-message-flag message 'DELETED)) + +(define (message-flags->header-field flags) + (make-header-field + message-flags:name + (apply string-append + (map (lambda (flag) + (if (symbol? flag) + (string-append " :" (symbol->string flag)) + (string-append " " flag))) + flags)))) + +(define (header-field->message-flags header) + (and (string-ci=? message-flags:name (header-field-name header)) + ;; Extra pair needed to distinguish #F from (). + (cons 'YUK + (map (lambda (token) + (if (char=? #\: (string-ref token 0)) + (intern (string-tail token 1)) + token)) + (burst-string (header-field-value header) + char-set:lwsp + #t))))) + +(define message-flags:name "X-IMAIL-FLAGS") + +;;;; Message properties + +;;; Properties are used to associate information with a message. A +;;; property is a distinguished header field that carries information +;;; intended for the mail reader rather than the user. + +(define (get-message-property message name default) + (guarantee-message-property-name name 'GET-MESSAGE-PROPERTY) + (let loop ((headers (message-properties message))) + (if (pair? headers) + (if (string-ci=? name (caar headers)) + (cdar headers) + (loop (cdr headers))) + default))) + +(define (set-message-property message name value) + (guarantee-message-property-name name 'SET-MESSAGE-PROPERTY) + (guarantee-message-property-value value 'SET-MESSAGE-PROPERTY) + (let ((headers (message-properties message))) + (let loop ((headers headers)) + (if (pair? headers) + (if (string-ci=? name (caar headers)) + (set-cdr! (car headers) value) + (loop (cdr headers))) + (set-message-properties! message + (cons (cons name value) headers)))))) + +(define (message-property-name? object) + (header-field-name? object)) + +(define (message-property-value? object) + (or (header-field-value? object) + (and (list? object) + (for-all? object header-field?)))) + +(define (guarantee-message-property-name name procedure) + (if (not (message-property-name? name)) + (error:wrong-type-argument name "message-property name" procedure))) + +(define (guarantee-message-property-value value procedure) + (if (not (message-property-value? value)) + (error:wrong-type-argument value "message-property value" procedure))) + +(define (message-property->header-field name value) + (make-header-field + (string-append message-property:prefix name) + (if (header-field-value? value) + (string-append message-property:single-marker value) + (apply string-append + message-property:multiple-marker + (map (lambda (line) + (string-append "\n" line)) + (quote-lines + (append-map (lambda (header) + (header-field->lines header)) + value))))))) + +(define (header-field->message-property header) + (and (string-prefix-ci? message-property:prefix (header-field-name header)) + (cons (string-tail (header-field-name header) + (string-length message-property:prefix)) + (let ((value (header-field-value header))) + (cond ((string-prefix? message-property:single-marker value) + (string-tail + value + (string-length message-property:single-marker))) + ((string-prefix? message-property:multiple-marker value) + (lines->header-fields + (unquote-lines + (cdr (burst-string value #\newline #f))))) + (else + (error "Malformed message-property value:" value))))))) + +(define message-property:prefix "X-IMAIL-PROPERTY-") +(define message-property:single-marker "[single]") +(define message-property:multiple-marker "[multiple]") + +;;;; Header fields + +(define-structure (header-field + (type-descriptor header-field-rtd) + (safe-accessors #t) + (constructor #f) + (print-procedure + (standard-unparser-method 'HEADER-FIELD + (lambda (header port) + (write-char #\space port) + (write (header-field-name header) port))))) + (name #f read-only #t) + (value #f read-only #t)) + +(define make-header-field + (let ((constructor (record-constructor header-field-rtd))) + (lambda (name value) + (guarantee-header-field-name name 'MAKE-HEADER-FIELD) + (guarantee-header-field-value value 'MAKE-HEADER-FIELD) + (constructor name value)))) + +(define (copy-header-field header) + (record-copy header)) + +(define (get-first-header-field headers name error?) + (let loop + ((headers + (if (or (pair? headers) (null? headers)) + headers + (header-fields headers)))) + (cond ((pair? headers) + (if (string-ci=? name (header-field-name (car headers))) + (car headers) + (loop (cdr headers)))) + (error? (error:bad-range-argument name 'GET-FIRST-HEADER-FIELD)) + (else #f)))) + +(define (get-last-header-field headers name error?) + (let loop + ((headers + (if (or (pair? headers) (null? headers)) + headers + (header-fields headers))) + (winner #f)) + (cond ((pair? headers) + (loop (cdr headers) + (if (string-ci=? name (header-field-name (car headers))) + (car headers) + winner))) + ((and (not winner) error?) + (error:bad-range-argument name 'GET-LAST-HEADER-FIELD)) + (else winner)))) + +(define (get-all-header-fields headers name) + (list-transform-positive headers + (lambda (header) + (string-ci=? name (header-field-name header))))) + +(define (get-first-header-field-value headers name error?) + (let ((header (get-first-header-field headers name error?))) + (and header + (header-field-value header)))) + +(define (get-last-header-field-value headers name error?) + (let ((header (get-last-header-field headers name error?))) + (and header + (header-field-value header)))) + +(define (get-all-header-field-values headers name) + (map header-field-value (get-all-header-fields headers name))) + +(define (header-field-name? object) + (and (string? object) + (%header-field-name? object 0 (string-length object)))) + +(define %header-field-name? + (let ((excluded-chars + (char-set-invert + (char-set-difference (ascii-range->char-set 33 127) + (char-set #\:))))) + (lambda (string start end) + (and (fix:< start end) + (not (substring-find-next-char-in-set string start end + excluded-chars)))))) + +(define (header-field-value? object) + (and (string? object) + (let ((end (string-length object))) + (let loop ((index 0)) + (let ((nl (substring-find-next-char object index end #\newline))) + (or (not nl) + (and (fix:< (fix:+ nl 1) end) + (char-lwsp? (string-ref object (fix:+ nl 1))) + (loop (fix:+ nl 2))))))))) + +(define (guarantee-header-field-name object procedure) + (if (not (header-field-name? object)) + (error:wrong-type-argument object "header-field name" procedure))) + +(define (guarantee-header-field-value object procedure) + (if (not (header-field-value? object)) + (error:wrong-type-argument object "header-field value" procedure))) + +(define (header-field->lines header) + (let ((lines (string->lines (header-field-value header)))) + (cons (string-append (header-field-name header) ":" (car lines)) + (cdr lines)))) + +(define (lines->header-field lines) + (let ((colon + (and (pair? lines) + (string-find-next-char (car lines) #\:)))) + (if (not colon) + (error "Malformed header-field lines:" lines)) + (make-header-field (string-head (car lines) colon) + (apply string-append + (string-tail (car lines) (fix:+ colon 1)) + (map (lambda (line) + (string-append "\n" line)) + (cdr lines)))))) + +(define (lines->header-fields lines) + (map lines->header-field + (burst-list lines header-field-initial-line?))) + +(define (header-field-initial-line? line) + (let ((colon (string-find-next-char line #\:))) + (and colon + (%header-field-name? line 0 colon)))) + +(define (header-field-continuation-line? line) + (and (not (string-null? line)) + (char-lwsp? (string-ref line 0)))) \ No newline at end of file diff --git a/v7/src/imail/imail-file.scm b/v7/src/imail/imail-file.scm new file mode 100644 index 000000000..2fb69fffe --- /dev/null +++ b/v7/src/imail/imail-file.scm @@ -0,0 +1,111 @@ +;;; -*-Scheme-*- +;;; +;;; $Id: imail-file.scm,v 1.1 2000/01/04 22:50:56 cph Exp $ +;;; +;;; Copyright (c) 1999 Massachusetts Institute of Technology +;;; +;;; 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 of the +;;; License, 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 program; if not, write to the Free Software +;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +;;;; IMAIL mail reader: file-based folder support + +(declare (usual-integrations)) + +;;;; URL + +(define-class () + (pathname define accessor)) + +(define-method url-body ((url )) + (pathname->short-name (file-url-pathname url))) + +;;;; Server operations + +(define-method %delete-folder ((url )) + (delete-file (file-url-pathname url))) + +;;; The next two methods only work when operating on two URLs of the +;;; same class. Otherwise, it's necessary to do format conversions; +;;; this is handled at a higher level in the class heirarchy. + +(define-computed-method %move-folder ((uc1 ) (uc2 )) + (and (eq? uc1 uc2) + (lambda (url new-url) + ;; **** Not really correct -- must handle cases where RENAME-FILE + ;; fails, such as moving across file systems under unix. + (rename-file (file-url-pathname url) (file-url-pathname new-url))))) + +(define-computed-method %copy-folder ((uc1 ) (uc2 )) + (and (eq? uc1 uc2) + (lambda (url new-url) + (copy-file (file-url-pathname url) (file-url-pathname new-url))))) + +(define-method available-folder-names ((url )) + url + (error "Unimplemented operation:" 'AVAILABLE-FOLDER-NAMES)) + +(define-method subscribed-folder-names ((url )) + url + (error "Unimplemented operation:" 'SUBSCRIBED-FOLDER-NAMES)) + +;;;; Folder + +(define-class () + (url accessor folder-url) + (messages define standard)) + +(define-method %folder-valid? ((folder )) + (file-exists? (file-url-pathname (folder-url folder)))) + +(define-method count-messages ((folder )) + (length (file-folder-messages folder))) + +(define-method %get-message ((folder ) index) + (list-ref (file-folder-messages folder) index)) + +(define-method %insert-message ((folder ) index message) + (let ((message (copy-message message)) + (messages (file-folder-messages folder))) + (if (fix:= 0 index) + (set-file-folder-messages! folder (cons message messages)) + (let loop ((index* 1) (prev messages) (this (cdr messages))) + (if (fix:= index index*) + (set-cdr! prev (cons message this)) + (loop (fix:+ index* 1) this (cdr this))))))) + +(define-method %append-message ((folder ) message) + (set-file-folder-messages! folder + (append! (file-folder-messages folder) + (list (copy-message message))))) + +(define-method expunge-deleted-messages ((folder )) + (set-file-folder-messages! + folder + (list-transform-negative (file-folder-messages folder) message-deleted?))) + +(define-method search-folder ((folder ) criteria) + folder criteria + (error "Unimplemented operation:" 'SEARCH-FOLDER)) + +(define-method synchronize-folder ((folder )) + folder + unspecific) + +(define-method subscribe-folder ((folder )) + folder + (error "Unimplemented operation:" 'SUBSCRIBE-FOLDER)) + +(define-method unsubscribe-folder ((folder )) + folder + (error "Unimplemented operation:" 'UNSUBSCRIBE-FOLDER)) \ No newline at end of file diff --git a/v7/src/imail/imail-rmail.scm b/v7/src/imail/imail-rmail.scm new file mode 100644 index 000000000..6cdde14c1 --- /dev/null +++ b/v7/src/imail/imail-rmail.scm @@ -0,0 +1,445 @@ +;;; -*-Scheme-*- +;;; +;;; $Id: imail-rmail.scm,v 1.1 2000/01/04 22:51:02 cph Exp $ +;;; +;;; Copyright (c) 1999 Massachusetts Institute of Technology +;;; +;;; 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 of the +;;; License, 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 program; if not, write to the Free Software +;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +;;;; IMAIL mail reader: RMAIL back end + +(declare (usual-integrations)) + +;;;; URL + +(define-class ( (constructor (pathname))) ()) + +(define-url-protocol "rmail" + (lambda (string) + (make-rmail-url (short-name->pathname string)))) + +;;;; Server operations + +(define-method %open-folder ((url )) + (read-rmail-file url)) + +(define-method %new-folder ((url )) + (let ((folder (make-rmail-folder url 'COMPUTE '()))) + (save-folder folder) + folder)) + +;;;; Folder + +(define-class ( (constructor (url header-fields messages))) + () + (header-fields define standard accessor header-fields)) + +(define-method %write-folder ((folder ) (url )) + (write-rmail-file folder (file-url-pathname url))) + +(define-method poll-folder ((folder )) + (rmail-get-new-mail folder)) + +(define-method initialize-instance ((folder )) + (if (eq? 'COMPUTE (header-fields folder)) + (set-rmail-folder-header-fields! + folder + (compute-rmail-folder-header-fields folder)))) + +(define-method header-fields ((folder )) + (compute-rmail-folder-header-fields folder)) + +(define (compute-rmail-folder-header-fields folder) + (list (make-header-field "Version" " 5") + (make-header-field + "Labels" + (let ((labels (compute-rmail-folder-labels folder))) + (if (pair? labels) + (apply string-append + (car labels) + (map (lambda (label) (string-append "," label)) + (cdr labels))) + ""))) + (make-header-field "Note" " This is the header of an rmail file.") + (make-header-field "Note" " If you are seeing it in rmail,") + (make-header-field "Note" + " it means the file has no messages in it."))) + +(define (compute-rmail-folder-labels folder) + (flags->rmail-labels + (let ((n (count-messages folder))) + (let loop ((index 0) (flags '())) + (if (fix:< index n) + (loop (fix:+ index 1) + (union-of-lists (message-flags (get-message folder index)) + flags)) + flags))))) + +;;;; Read RMAIL file + +(define (read-rmail-file url) + (let* ((pathname (file-url-pathname url)) + (namestring (->namestring pathname))) + (call-with-input-file pathname + (lambda (port) + (let ((folder-headers (read-rmail-prolog port))) + (make-rmail-folder url + folder-headers + (read-rmail-messages port))))))) + +(define (read-rmail-prolog port) + (if (not (string-prefix? "BABYL OPTIONS:" (read-required-line port))) + (error "Not an RMAIL file:" port)) + (lines->header-fields (read-lines-to-eom port))) + +(define (read-rmail-messages port) + (source->list (lambda () (read-rmail-message port)))) + +(define (read-rmail-message port) + ;; **** This must be generalized to recognize an RMAIL file that has + ;; unix-mail format messages appended to it. + (let ((line (read-line port))) + (cond ((eof-object? line) + line) + ((and (fix:= 1 (string-length line)) + (char=? rmail-message:start-char (string-ref line 0))) + (read-rmail-message-1 port)) + (else + (error "Malformed RMAIL file:" port))))) + +(define (read-rmail-message-1 port) + (call-with-values + (lambda () (parse-attributes-line (read-required-line port))) + (lambda (formatted? flags) + (let* ((headers (read-rmail-header-fields port)) + (displayed-headers + (lines->header-fields (read-header-lines port))) + (body (read-to-eom port)) + (finish + (lambda (headers) + (let ((message (make-standard-message headers body))) + (for-each (lambda (flag) + (set-message-flag message flag)) + flags) + (let ((headers (message-header-fields message))) + (if (and (pair? headers) + (string-ci=? "summary-line" + (header-field-name (car headers)))) + (begin + (set-message-property + message + (header-field-name (car headers)) + (header-field-value (car headers))) + (set-message-header-fields! message (cdr headers))))) + message)))) + (if formatted? + (let ((message (finish headers))) + (set-message-property message + "displayed-header-fields" + displayed-headers) + message) + (finish displayed-headers)))))) + +(define (parse-attributes-line line) + (let ((parts (map string-trim (burst-string line #\, #f)))) + (if (not (and (fix:= 2 (count-matching-items parts string-null?)) + (or (string=? "0" (car parts)) + (string=? "1" (car parts))) + (string-null? (car (last-pair parts))))) + (error "Malformed RMAIL message-attributes line:" line)) + (call-with-values + (lambda () (cut-list! (except-last-pair (cdr parts)) string-null?)) + (lambda (attributes labels) + (values (string=? "1" (car parts)) + (rmail-markers->flags attributes + (if (pair? labels) + (cdr labels) + labels))))))) + +(define (read-rmail-header-fields port) + (lines->header-fields + (source->list + (lambda () + (let ((line (read-required-line port))) + (cond ((string-null? line) + (if (not (string=? rmail-message:headers-separator + (read-required-line port))) + (error "Missing RMAIL message-header separator string:" + port)) + (make-eof-object port)) + ((string=? rmail-message:headers-separator line) + (make-eof-object port)) + (else line))))))) + +;;;; Write RMAIL file + +(define (write-rmail-file folder url) + ;; **** Do backup of file here. + (call-with-output-file (file-url-pathname url) + (lambda (port) + (write-rmail-prolog (header-fields folder) port) + (write-rmail-messages (file-folder-messages folder) port)))) + +(define (write-rmail-prolog header-fields port) + (write-string "BABYL OPTIONS: -*- rmail -*-" port) + (newline port) + (write-header-fields header-fields port) + (write-char rmail-message:end-char port)) + +(define (write-rmail-messages messages port) + (for-each (lambda (message) (write-rmail-message message port)) messages)) + +(define (write-rmail-message message port) + (write-char rmail-message:start-char port) + (newline port) + (let ((headers (message-header-fields message)) + (displayed-headers + (get-message-property message "displayed-header-fields" 'NONE))) + (write-rmail-attributes-line message displayed-headers port) + (if (not (eq? 'NONE displayed-headers)) + (begin + (write-rmail-properties message port) + (write-header-fields headers port) + (newline port))) + (write-string rmail-message:headers-separator port) + (newline port) + (if (eq? 'NONE displayed-headers) + (begin + (write-rmail-properties message port) + (write-header-fields headers port)) + (write-header-fields displayed-headers port)) + (newline port) + (write-string (message-body message) port) + (fresh-line port) + (write-char rmail-message:end-char port))) + +(define (write-rmail-attributes-line message formatted? port) + (write-char (if formatted? #\1 #\0) port) + (write-char #\, port) + (call-with-values (lambda () (flags->rmail-markers (message-flags message))) + (lambda (attributes labels) + (let ((write-markers + (lambda (markers) + (for-each (lambda (marker) + (write-char #\space port) + (write-string marker port) + (write-char #\, port)) + markers)))) + (write-markers attributes) + (write-char #\, port) + (write-markers labels)))) + (newline port)) + +(define (write-rmail-properties message port) + (let ((alist (message-properties message))) + (let ((summary-line + (list-search-positive alist + (lambda (n.v) + (string-ci=? "summary-line" (car n.v)))))) + (if summary-line + (%write-header-field (car n.v) (cdr n.v) port))) + (for-each + (lambda (n.v) + (if (not (or (string-ci=? "summary-line" (car n.v)) + (string-ci=? "displayed-header-fields" (car n.v)))) + (write-header-field + (message-property->header-field (car n.v) (cdr n.v)) + port))) + alist))) + +;;;; Get new mail + +(define (rmail-get-new-mail folder) + (let ((pathnames (rmail-folder-inbox-list folder))) + (if (null? pathnames) + #f + (let ((initial-count (count-messages folder))) + (let ((inbox-folders + (map (lambda (pathname) + (let ((inbox (read-rmail-inbox folder pathname #t))) + (let ((n (count-messages inbox))) + (do ((index 0 (fix:+ index 1))) + ((fix:= i n)) + (append-message folder + (get-message inbox index)))) + inbox)) + pathnames))) + (save-folder folder) + (for-each (lambda (folder) + (if folder + (delete-folder (folder-url folder)))) + inbox-folders)) + (fix:- (count-messages folder) initial-count))))) + +(define (rmail-folder-inbox-list folder) + (let ((url (folder-url folder)) + (inboxes (get-first-header-field-value folder "mail" #f))) + (cond (inboxes + (map (let ((directory + (directory-pathname (file-url-pathname url)))) + (lambda (filename) + (merge-pathnames (string-trim filename) directory))) + (burst-string inboxes #\, #f))) + ((pathname=? (rmail-primary-folder-name) (url-body url)) + (rmail-primary-inbox-list)) + (else '())))) + +(define (rmail-primary-folder-name) + "RMAIL") + +(define (rmail-primary-inbox-list) + (error "Unimplemented procedure:" 'RMAIL-PRIMARY-INBOX-LIST)) + +(define (rmail-spool-directory) + (error "Unimplemented procedure:" 'RMAIL-SPOOL-DIRECTORY)) + +(define (read-rmail-inbox folder pathname rename?) + (let ((pathname + (cond ((not rename?) + pathname) + ((pathname=? (rmail-spool-directory) + (directory-pathname pathname)) + (rename-inbox-using-movemail + pathname + (directory-pathname + (file-url-pathname (folder-url folder))))) + (else + (rename-inbox-using-rename pathname))))) + (and (file-exists? pathname) + (open-folder (make-url "umail" (pathname->short-name pathname)))))) + +(define (rename-inbox-using-movemail pathname directory) + (let ((pathname + ;; On some systems, /usr/spool/mail/foo is a directory and + ;; the actual inbox is /usr/spool/mail/foo/foo. + (if (file-directory? pathname) + (merge-pathnames (file-pathname pathname) + (pathname-as-directory pathname)) + pathname)) + (target (merge-pathnames ".newmail" directory))) + (if (and (file-exists? pathname) + (not (file-exists? target))) + (let ((port (make-accumulator-output-port))) + (let ((result + (run-shell-command + (string-append "movemail " + (->namestring pathname) + " " + (->namestring target)) + 'OUTPUT port))) + (if (not (= 0 result)) + (error "Movemail failure:" + (get-output-from-accumulator port)))))) + target)) + +(define (rename-inbox-using-rename pathname) + (let ((target + (merge-pathnames (string-append (file-namestring pathname) "+") + (directory-pathname pathname)))) + (if (and (file-exists? pathname) + (not (file-exists? target))) + (rename-file pathname target)) + target)) + +;;;; Attributes and labels + +(define (rmail-markers->flags attributes labels) + (let loop + ((strings (remove-equal-duplicates (append attributes labels))) + (flags '())) + (if (pair? strings) + (loop (cdr strings) + (cons (if (list-search-positive rmail-attributes + (lambda (attribute) + (string-ci=? attribute (car strings)))) + (rmail-attribute->flag (car strings)) + (rmail-label->flag (car strings))) + flags)) + (reverse! flags)))) + +(define (flags->rmail-markers flags) + (let loop ((flags flags) (attributes '()) (labels '())) + (if (pair? flags) + (if (flag-is-rmail-attribute? (car flags)) + (loop (cdr flags) + (cons (flag->rmail-attribute (car flags)) attributes) + labels) + (loop (cdr flags) + attributes + (cons (flag->rmail-label (car flags)) labels))) + (values (reverse! attributes) (reverse! labels))))) + +(define (flags->rmail-labels flags) + (call-with-values (lambda () (flags->rmail-markers flags)) + (lambda (attributes labels) + attributes + labels))) + +(define (flag-is-rmail-attribute? flag) + (memq flag rmail-attribute-flags)) + +(define (flag->rmail-attribute flag) + (symbol->string flag)) + +(define (rmail-attribute->flag attribute) + (intern attribute)) + +(define (flag->rmail-label flag) + (if (symbol? flag) + (string-append "standard:" (symbol->string flag)) + flag)) + +(define (rmail-label->flag label) + (if (string-prefix? "standard:" label) + (intern (string-tail label 9)) + label)) + +;;;; Syntactic Markers + +(define rmail-message:headers-separator + "*** EOOH ***") + +(define rmail-message:start-char + #\page) + +(define rmail-message:end-char + (integer->char #x1f)) + +(define rmail-message:end-char-set + (char-set rmail-message:end-char)) + +(define rmail-attributes + '("deleted" "answered" "unseen" "filed" "forwarded" "edited" "resent")) + +(define rmail-attribute-flags + (map intern rmail-attributes)) + +;;;; Utilities + +(define (read-lines-to-eom port) + (source->list + (lambda () + (if (eqv? rmail-message:end-char (peek-char port)) + (begin + (read-char port) ;discard + (make-eof-object port)) + (read-required-line port))))) + +(define (read-to-eom port) + (let ((string (read-string rmail-message:end-char-set port))) + (if (or (eof-object? string) + (eof-object? (read-char port))) + (error "EOF while reading RMAIL message body:" port)) + string)) \ No newline at end of file diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm new file mode 100644 index 000000000..c7e610795 --- /dev/null +++ b/v7/src/imail/imail-top.scm @@ -0,0 +1,89 @@ +;;; -*-Scheme-*- +;;; +;;; $Id: imail-top.scm,v 1.1 2000/01/04 22:51:05 cph Exp $ +;;; +;;; Copyright (c) 1999 Massachusetts Institute of Technology +;;; +;;; 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 of the +;;; License, 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 program; if not, write to the Free Software +;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +;;;; IMAIL mail reader: top level + +(declare (usual-integrations)) + +(define-command imail + "Read and edit incoming mail." + () + (lambda () + (let ((connection + (let ((backend (get-backend (ref-variable imail-backend-type)))) + (open-connection + backend + (and (backend-requires-hostname? backend) + (ref-variable imail-backend-server)))))) + (authenticate-connection connection + (or (ref-variable imail-user-name) + (current-user-name)) + (lambda (prompt-string) + (call-with-pass-phrase prompt-string string-copy))) + (let ((name (ref-variable imail-primary-folder))) + (let ((folder (get-folder connection name))) + (let ((buffer + (or (imail-folder->buffer folder) + (let ((buffer + (new-buffer + (imail-folder-name->buffer-name name)))) + (buffer-put! buffer 'IMAIL-FOLDER folder) + (select-message + buffer + (let ((count (count-messages folder))) + (if (= 0 count) + count + (- count 1)))) + buffer)))) + (select-buffer buffer))))) + ((ref-command imail-get-new-mail) #f))) + +(define (imail-folder->buffer folder) + ) + +(define (imail-folder-name->buffer-name folder) + ) + +(define-command imail-get-new-mail + "Get new mail from this folder's inbox." + () + (lambda () + (let ((buffer (current-buffer))) + (rmail-find-file-revert buffer) + (let ((n-messages + (let ((memo (buffer-msg-memo buffer))) + (if (msg-memo? memo) + (msg-memo/number (msg-memo/last memo)) + 0)))) + (with-buffer-open buffer + (lambda () + (with-buffer-undo-disabled buffer + (lambda () + (get-new-mail buffer + (ref-variable rmail-inbox-list) + #t))))) + (show-message + buffer + (let ((memo (buffer-msg-memo buffer))) + (cond ((not (msg-memo? memo)) 0) + ((> (msg-memo/number (msg-memo/last memo)) n-messages) + (+ n-messages 1)) + (else (msg-memo/number memo))))) + (event-distributor/invoke! (ref-variable rmail-new-mail-hook)))))) \ No newline at end of file diff --git a/v7/src/imail/imail-umail.scm b/v7/src/imail/imail-umail.scm new file mode 100644 index 000000000..d8c39e4f3 --- /dev/null +++ b/v7/src/imail/imail-umail.scm @@ -0,0 +1,175 @@ +;;; -*-Scheme-*- +;;; +;;; $Id: imail-umail.scm,v 1.1 2000/01/04 22:51:09 cph Exp $ +;;; +;;; Copyright (c) 1999 Massachusetts Institute of Technology +;;; +;;; 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 of the +;;; License, 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 program; if not, write to the Free Software +;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +;;;; IMAIL mail reader: RMAIL back end + +(declare (usual-integrations)) + +;;;; URL + +(define-class ( (constructor (pathname))) ()) + +(define-url-protocol "umail" + (lambda (string) + (make-umail-url (short-name->pathname string)))) + +;;;; Server operations + +(define-method %open-folder ((url )) + (read-umail-file url)) + +(define-method %new-folder ((url )) + (let ((folder (make-umail-folder url '()))) + (save-folder folder) + folder)) + +;;;; Folder + +(define-class ( (constructor (url messages))) ()) + +(define-method %write-folder ((folder ) (url )) + (write-umail-file folder (file-url-pathname url))) + +(define-method poll-folder ((folder )) + folder + #f) + +;;;; Read unix mail file + +(define (read-umail-file url) + (let* ((pathname (file-url-pathname url)) + (namestring (->namestring pathname))) + (call-with-input-file pathname + (lambda (port) + (make-umail-folder url (read-umail-messages port namestring)))))) + +(define (read-umail-messages port namestring) + (map (lambda (lines) + (parse-umail-message lines namestring)) + (let ((groups + (burst-list (read-lines port) + (lambda (line) + (re-string-match unix-mail-delimiter line))))) + (if (and (pair? groups) + (not (null? (caar groups)))) + (error "Malformed unix mail file:" namestring)) + groups))) + +(define (parse-umail-message lines namestring) + (let loop ((ls (cdr lines)) (header-lines '())) + (if (pair? ls) + (if (string-null? (car ls)) + (let ((message + (make-standard-message headers (lines->string (cdr ls))))) + (set-message-property message "umail-from-line" (car lines)) + message) + (loop (cdr ls) (cons (car ls) header-lines))) + (error "Malformed unix mail file:" namestring)))) + +;;;; Write unix mail file + +(define (write-umail-file folder pathname) + (call-with-output-file (file-url-pathname url) + (lambda (port) + (write-umail-messages (file-folder-messages folder) port)))) + +(define (write-umail-messages messages port) + (for-each (lambda (message) (write-umail-message message port)) messages)) + +(define (write-umail-message message port) + (write-string + (let ((header (get-first-header-field message "umail-from-line" #f))) + (if header + (string-trim (header-field-value header)) + (string-append "From " + (or (rfc822-first-address + (get-first-header-field message "from" #t)) + "unknown") + " " + (universal-time->string (get-universal-time))))) + port) + (newline port) + (write-header-field (message-flags->header-field (message-flags message)) + port) + (for-each (lambda (n.v) + (if (not (string-ci=? "umail-from-line" (car n.v))) + (write-header-field + (message-property->header-field (car n.v) (cdr n.v)) + port))) + (message-properties message)) + (write-header-fields (message-header-fields message) port) + (newline port) + (write-string (message-body message) port) + (fresh-line port)) + +;;;; Detection of unix "from" lines. + +(define unix-mail-delimiter + ;; This very complex regular expression taken from Emacs 20. + (let ((time-zone-regexp + (string-append + (regexp-group "[A-Z]?[A-Z]?[A-Z][A-Z]\\( DST\\)?" + "[-+]?[0-9][0-9][0-9][0-9]" + "") + " *"))) + (string-append + "^From " + + ;; Many things can happen to an RFC 822 mailbox before it is put into + ;; a `From' line. The leading phrase can be stripped, e.g. + ;; `Joe <@w.x:joe@y.z>' -> `<@w.x:joe@y.z>'. The <> can be stripped, e.g. + ;; `<@x.y:joe@y.z>' -> `@x.y:joe@y.z'. Everything starting with a CRLF + ;; can be removed, e.g. + ;; From: joe@y.z (Joe K + ;; User) + ;; can yield `From joe@y.z (Joe K Fri Mar 22 08:11:15 1996', and + ;; From: Joe User + ;; + ;; can yield `From Joe User Fri Mar 22 08:11:15 1996'. + ;; The mailbox can be removed or be replaced by white space, e.g. + ;; From: "Joe User"{space}{tab} + ;; + ;; can yield `From {space}{tab} Fri Mar 22 08:11:15 1996', + ;; where {space} and {tab} represent the Ascii space and tab characters. + ;; We want to match the results of any of these manglings. + ;; The following regexp rejects names whose first characters are + ;; obviously bogus, but after that anything goes. + "\\([^\0-\b\n-\r\^?].*\\)? " + + ;; The time the message was sent. + "\\([^\0-\r \^?]+\\) +" ; day of the week + "\\([^\0-\r \^?]+\\) +" ; month + "\\([0-3]?[0-9]\\) +" ; day of month + "\\([0-2][0-9]:[0-5][0-9]\\(:[0-6][0-9]\\)?\\) *" ; time of day + + ;; Perhaps a time zone, specified by an abbreviation, or by a + ;; numeric offset. + time-zone-regexp + + ;; The year. + " \\([0-9][0-9]+\\) *" + + ;; On some systems the time zone can appear after the year, too. + time-zone-regexp + + ;; Old uucp cruft. + "\\(remote from .*\\)?" + + "$"))) \ No newline at end of file diff --git a/v7/src/imail/imail-util.scm b/v7/src/imail/imail-util.scm new file mode 100644 index 000000000..a45a96039 --- /dev/null +++ b/v7/src/imail/imail-util.scm @@ -0,0 +1,185 @@ +;;; -*-Scheme-*- +;;; +;;; $Id: imail-util.scm,v 1.1 2000/01/04 22:51:15 cph Exp $ +;;; +;;; Copyright (c) 1999 Massachusetts Institute of Technology +;;; +;;; 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 of the +;;; License, 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 program; if not, write to the Free Software +;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +;;;; IMAIL mail reader: utilities + +(declare (usual-integrations)) + +(define (guarantee-index index procedure) + (if (not (index-fixnum? index)) + (error:wrong-type-argument index "index" procedure))) + +(define (union-of-lists l1 l2) + (let loop ((l1 l1) (l2 l2)) + (if (pair? l1) + (loop (cdr l1) + (if (member (car l1) l2) + l2 + (cons (car l1) l2))) + l2))) + +(define (source->list source) + (let ((item (source))) + (if (eof-object? item) + '() + (let ((head (list item))) + (let loop ((prev head)) + (let ((item (source))) + (if (eof-object? item) + head + (let ((this (list item))) + (set-cdr! prev this) + (loop this))))))))) + +(define (list->source items) + (lambda () + (if (pair? items) + (let ((item (car items))) + (set! items (cdr items)) + item) + (make-eof-object #f)))) + +(define (cut-list items predicate) + (if (or (not (pair? items)) (predicate (car items))) + (values '() items) + (let ((head (list (car items)))) + (values head + (let loop ((prev head) (this (cdr items))) + (if (or (not (pair? this)) (predicate (car this))) + this + (let ((next (list (car this)))) + (set-cdr! prev next) + (loop next (cdr this))))))))) + +(define (cut-list! items predicate) + (if (or (not (pair? items)) (predicate (car items))) + (values '() items) + (let loop ((prev items) (this (cdr items))) + (if (or (not (pair? this)) (predicate (car this))) + (begin + (set-cdr! prev '()) + (values items this)) + (loop this (cdr this)))))) + +(define (burst-list items predicate) + (let loop ((items items) (groups '())) + (if (pair? items) + (let find-next ((items (cdr items)) (group (list (car items)))) + (if (and (pair? items) (not (predicate (car items)))) + (find-next (cdr items) (cons (car items) group)) + (loop items (cons (reverse! group) groups)))) + (reverse! groups)))) + +;; The cryptic LWSP means Linear White SPace. We use it because it +;; is the terminology from RFC 822. + +(define (char-lwsp? char) + (or (char=? #\space char) + (char=? #\tab char))) + +(define char-set:lwsp + (char-set #\space #\tab)) + +(define (quote-lines lines) + (map (lambda (line) + (string-append "\t" line)) + lines)) + +(define (unquote-lines lines) + (map (lambda (line) + (if (and (fix:> (string-length line) 0) + (char=? #\tab (string-ref line 0))) + (string-tail line 1) + (error "Unquoted line:" line))) + lines)) + +(define (string->lines string) + (let ((lines (burst-string string #\newline #f))) + (if (string-null? (car (last-pair lines))) + (except-last-pair! lines) + lines))) + +(define (lines->string lines) + (apply string-append + (map (lambda (line) + (string-append line "\n")) + lines))) + +(define (short-name->pathname name) + (merge-pathnames name (current-home-directory))) + +(define (pathname->short-name pathname) + (enough-namestring pathname (current-home-directory))) + +(define (write-header-fields headers port) + (for-each (lambda (header) + (write-header-field header port)) + headers)) + +(define (write-header-field header port) + (%write-header-field (header-field-name header) + (header-field-value header) + port)) + +(define (%write-header-field name value port) + (write-string name port) + (write-char #\: port) + (write-string value port) + (newline port)) + +(define (separated-append tokens separator) + (if (pair? tokens) + (if (pair? (cdr tokens)) + (let loop ((tokens (cdr tokens)) (tokens* (list (car tokens)))) + (if (pair? tokens) + (loop (cdr tokens) (cons* (car tokens) separator tokens*)) + (apply string-append (reverse! tokens*)))) + (car tokens)) + "")) + +(define (read-header-lines port) + (source->list + (lambda () + (let ((line (read-required-line port))) + (if (string-null? line) + (make-eof-object port) + line))))) + +(define (read-required-line port) + (let ((line (read-line port))) + (if (eof-object? line) + (error "Premature end of file:" port)) + line)) + +(define (remove-equal-duplicates items) + (if (pair? items) + (if (member (car items) (cdr items)) + (remove-equal-duplicates (cdr items)) + (cons (car items) (remove-equal-duplicates (cdr items)))) + '())) + +(define (count-matching-items items predicate) + (let loop ((items items) (count 0)) + (if (pair? items) + (loop (cdr items) + (if (predicate (car items)) + (fix:+ count 1) + count)) + count))) \ No newline at end of file diff --git a/v7/src/imail/load.scm b/v7/src/imail/load.scm new file mode 100644 index 000000000..9c6ba2813 --- /dev/null +++ b/v7/src/imail/load.scm @@ -0,0 +1,29 @@ +;;; -*-Scheme-*- +;;; +;;; $Id: load.scm,v 1.1 2000/01/04 22:51:42 cph Exp $ +;;; +;;; Copyright (c) 1999 Massachusetts Institute of Technology +;;; +;;; 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 of the +;;; License, 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 program; if not, write to the Free Software +;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +;;;; IMAIL mail reader: loader + +(load-option 'SOS) +(load "imail-util") +(load "rfc822") +(load "imail-core") +(load "imail-file") +(load "imail-rmail") +(load "imail-umail") \ No newline at end of file diff --git a/v7/src/imail/print.sh b/v7/src/imail/print.sh new file mode 100755 index 000000000..b3640b8a8 --- /dev/null +++ b/v7/src/imail/print.sh @@ -0,0 +1,21 @@ +#!/bin/sh +# +# $Id: print.sh,v 1.1 2000/01/04 22:52:21 cph Exp $ +# +# Copyright (c) 1999 Massachusetts Institute of Technology +# +# 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 of the +# License, 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 program; if not, write to the Free Software +# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +prlist imail-core.scm imail-file.scm imail-rmail.scm imail-umail.scm rfc822.scm imail-util.scm diff --git a/v7/src/imail/rfc822.scm b/v7/src/imail/rfc822.scm new file mode 100644 index 000000000..4ceb4abe8 --- /dev/null +++ b/v7/src/imail/rfc822.scm @@ -0,0 +1,261 @@ +;;; -*-Scheme-*- +;;; +;;; $Id: rfc822.scm,v 1.1 2000/01/04 22:51:45 cph Exp $ +;;; +;;; Copyright (c) 1999 Massachusetts Institute of Technology +;;; +;;; 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 of the +;;; License, 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 program; if not, write to the Free Software +;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +;;;; IMAIL mail reader: RFC-822 support + +(declare (usual-integrations)) + +(define (rfc822-first-address field) + (let ((addresses (rfc822-strip-quoted-names field))) + (and (pair? addresses) + (car addresses)))) + +(define (rfc822-addresses->string addresses) + (if (null? addresses) + "" + (separated-append addresses ", "))) + +;;;; Address extractor + +(define (rfc822-strip-quoted-names string) + (let ((address-list + (rfc822-strip-quoted-names-1 (string->rfc822-tokens string)))) + (if (and address-list (null? (cdr address-list))) + (car address-list) + (map string-trim (burst-string string #\, #f))))) + +(define (rfc822-strip-quoted-names-1 tokens) + (define (parse-addr-spec tokens) + (let ((local-part (parse-list tokens parse-word #\.))) + (and local-part + (not (null? (cdr local-part))) + (eqv? #\@ (cadr local-part)) + (let ((domain (parse-domain (cddr local-part)))) + (and domain + (cons (string-append (separated-append (car local-part) ".") + "@" + (separated-append (car domain) ".")) + (cdr domain))))))) + (define (parse-domain tokens) + (parse-list tokens + (lambda (tokens) + (and (not (null? tokens)) + (string? (car tokens)) + (not (eqv? #\" (string-ref (car tokens) 0))) + tokens)) + #\.)) + (define (parse-list tokens parse-element separator) + (let ((first (parse-element tokens))) + (and first + (let loop ((tokens (cdr first)) (words (list (car first)))) + (let ((next + (and (not (null? tokens)) + (eqv? separator (car tokens)) + (parse-element (cdr tokens))))) + (if next + (loop (cdr next) (cons (car next) words)) + (cons (reverse! words) tokens))))))) + (define (parse-word tokens) + (and (not (null? tokens)) + (string? (car tokens)) + (not (eqv? #\[ (string-ref (car tokens) 0))) + tokens)) + (parse-list + tokens + (lambda (tokens) + (or (parse-addr-spec tokens) + (let ((word (parse-word tokens))) + (and word + (let ((tokens + (let loop ((tokens (cdr word))) + (let ((word (parse-word tokens))) + (if word + (loop (cdr word)) + tokens))))) + (and (not (null? tokens)) + (eqv? #\< (car tokens)) + (let ((addr-spec + (parse-addr-spec + (let ((domains + (parse-list + (cdr tokens) + (lambda (tokens) + (and (not (null? tokens)) + (eqv? #\@ (car tokens)) + (parse-domain (cdr tokens)))) + #\,))) + (if (and domains + (not (null? (cdr domains))) + (eqv? #\: (cadr domains))) + (cddr domains) + (cdr tokens)))))) + (and addr-spec + (not (null? (cdr addr-spec))) + (eqv? #\> (cadr addr-spec)) + (cons (car addr-spec) (cddr addr-spec)))))))))) + #\,)) + +;;;; Parser + +(define (string->rfc822-tokens string) + (rfc822-clean-tokens (rfc822-read-tokens (string->input-port string)))) + +(define (rfc822-clean-tokens tokens) + (let loop ((tokens tokens)) + (if (null? tokens) + '() + (let ((rest (loop (cdr tokens)))) + (if (cond ((char? (car tokens)) + (eqv? #\space (car tokens))) + ((string? (car tokens)) + (char=? #\( (string-ref (car tokens) 0))) + (else true)) + rest + (cons (car tokens) rest)))))) + +(define rfc822-read-tokens + (let* ((special-chars + (char-set #\( #\) #\[ #\] #\< #\> #\@ #\, #\; #\: #\\ #\" #\.)) + (atom-chars + (char-set-difference (ascii-range->char-set #x21 #x7F) + special-chars))) + (lambda (port) + (let ((special-char? + (lambda (char) (char-set-member? special-chars char))) + (atom-char? (lambda (char) (char-set-member? atom-chars char))) + (lwsp? + (lambda (char) (or (char=? #\space char) (char=? #\tab char)))) + (loser + (lambda (chars) + (list (cons 'UNTERMINATED (apply string (reverse! chars))))))) + (let dispatch () + (let ((char (input-port/read-char port))) + (cond ((eof-object? char) + '()) + ((lwsp? char) + (do () + ((not (lwsp? (input-port/peek-char port)))) + (input-port/discard-char port)) + (cons #\space (dispatch))) + ((atom-char? char) + ;; atom + (let loop ((chars (list char))) + (let ((char (input-port/peek-char port))) + (if (and (not (eof-object? char)) + (atom-char? char)) + (begin + (input-port/discard-char port) + (loop (cons char chars))) + (cons (apply string (reverse! chars)) + (dispatch)))))) + ((char=? #\" char) + ;; quoted string + (let loop ((chars (list char))) + (let ((char (input-port/read-char port))) + (cond ((eof-object? char) + (loser chars)) + ((char=? #\" char) + (cons (apply string (reverse! (cons char chars))) + (dispatch))) + ((char=? #\\ char) + (let ((char (input-port/read-char port)) + (chars (cons char chars))) + (if (eof-object? char) + (loser chars) + (loop (cons char chars))))) + ((char=? #\newline char) + (let ((char (input-port/peek-char port))) + (if (lwsp? char) + (begin + (input-port/discard-char port) + (loop (cons char chars))) + (loser chars)))) + (else + (loop (cons char chars))))))) + + ((char=? #\( char) + ;; comment + (let loop ((level 1) (chars (list char))) + (let ((char (input-port/read-char port))) + (cond ((eof-object? char) + (loser chars)) + ((char=? #\( char) + (loop (+ level 1) (cons char chars))) + ((char=? #\) char) + (let ((chars (cons char chars))) + (if (= level 1) + (cons (apply string (reverse! chars)) + (dispatch)) + (loop (- level 1) chars)))) + ((char=? #\\ char) + (let ((char (input-port/read-char port)) + (chars (cons char chars))) + (if (eof-object? char) + (loser chars) + (loop level (cons char chars))))) + ((char=? #\newline char) + (let ((char (input-port/peek-char port))) + (if (lwsp? char) + (begin + (input-port/discard-char port) + (loop level (cons char chars))) + (loser chars)))) + (else + (loop level (cons char chars))))))) + ((char=? #\[ char) + ;; domain literal + (let loop ((chars (list char))) + (let ((char (input-port/peek-char port))) + (cond ((or (eof-object? char) + (char=? #\[ char)) + (loser chars)) + ((char=? #\] char) + (input-port/discard-char port) + (cons (apply string (reverse! (cons char chars))) + (dispatch))) + ((char=? #\\ char) + (input-port/discard-char port) + (let ((char (input-port/read-char port)) + (chars (cons char chars))) + (if (eof-object? char) + (loser chars) + (loop (cons char chars))))) + ((char=? #\newline char) + (input-port/discard-char port) + (let ((char (input-port/peek-char port))) + (if (lwsp? char) + (begin + (input-port/discard-char port) + (loop (cons char chars))) + (loser chars)))) + (else + (input-port/discard-char port) + (loop (cons char chars))))))) + ((char=? #\newline char) + (let ((char (input-port/peek-char port))) + (if (and (not (eof-object? char)) + (lwsp? char)) + (dispatch) + '()))) + (else + (cons (if (special-char? char) + char + (cons 'ILLEGAL char)) + (dispatch)))))))))) \ No newline at end of file -- 2.25.1