mu4e/scm/mu-scm.scm

;; Copyright (C) 2025 Dirk-Jan C. Binnema <djcb@djcbsoftware.nl>
;;
;; 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 3, 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.

;; Note: this Scheme code depends on being loaded as part of "mu scm"
;; which does so automatically. It is not a general Guile module.
(define-module (mu)
  :use-module (oop goops)
  :use-module (system foreign)
  :use-module (rnrs bytevectors)
  :use-module (ice-9 optargs)
  :use-module (ice-9 binary-ports)
  #:export (
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	    ;; Mime-parts
	    <mime-part>
	    mime-part->alist
	    make-port
	    filename
	    write-to-file
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	    ;; Message
	    <message>
	    make-message

	    date
	    last-change

	    message-id
	    path
	    priority
	    subject

	    references
	    thread-id

	    mailing-list

	    language
	    size

	    ;; message flags / predicates
	    flags
	    flag?
	    draft?
	    flagged?
	    passed?
	    replied?
	    seen?
	    trashed?
	    new?
	    signed?
	    encrypted?
	    attach?
	    unread?
	    list?
	    personal?
	    calendar?

	    ;; contact fields
	    from
	    to
	    cc
	    bcc

	    ;; message-body
	    body
	    header

	    mime-parts

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	    ;; Store
	    <store>
	    mfind
	    mcount
	    cfind
	    store->alist

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	    ;; Other

	    ;; misc
	    %options
	    ;;	    %preferences

	    ;; helpers
	    string->time
	    time->string))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;

(define (set-documentation! symbol docstring)
  "Set the docstring for symbol in current module to docstring.
This is useful for symbols that do not support docstrings directly, such
add
  (define foo 123)
"
  ;; https://git.wolfsden.cz/guile-wolfsden/tree/wolfsden/documentation.scm
  (set-object-property! (module-ref (current-module) symbol)
			'documentation docstring))

;; some helpers for dealing with plists / alists
(define (plist-for-each func plist)
  "Call FUNC for each key/value in the PLIST.
PLIST is a property-list with alternating key and value.
Stops when FUNC returns #f."
  (when (and (not (null? plist))
	     (func (car plist) (cadr plist)))
    (plist-for-each func (cddr plist))))

(define (plist-find plist key)
  "Find the value for the first occurrence of KEY in PLIST.
If not found, return #f."
  (let ((val #f))
    (plist-for-each
     (lambda (k v)
       (if (eq? k key)
	   (begin
	     (set! val v) #f)
	   #t))
     plist)
    val))

(define (decolonize-symbol sym)
  "Remove :-prefix from symbol."
  (let ((name (symbol->string sym)))
    (if (string-prefix? ":" name)
	(string->symbol (string-drop name 1))
	sym)))

(define (plist->alist plist)
  "Convert a plist into an alist."
  (let ((alist '()))
    (plist-for-each
     (lambda (k v)
       (set! alist
	     (append! alist
		      (list (cons (decolonize-symbol k)
				  v)))))
     plist)
    alist))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; MIME-parts
(define-class <mime-part> ()
  (cc-mimepart  #:init-value #f #:init-keyword #:mimepart #:getter cc-mimepart)
  (alist        #:init-value #f #:init-keyword #:alist #:getter mime-part->alist))

(set-documentation!
 '<mime-part>
 "A <mime-part> represents the information about a message's MIME-part.
It has a few slots:
  - cc-mimepart: a 'foreign object' wrapping a GMimePart*
  - alist: the association-list representation of the MIME-part.")

(define* (make-port mime-part #:key (content-only? #t) (decode? #t))
  "Create a read port for MIME-PART.
If CONTENT-ONLY? is #t, only include the contents, not headers.
If DECODE? is #t, decode the content (from e.g., base64); in that case,
CONTENT-ONLY? is implied to be #t."
  (cc-mime-make-stream-port (slot-ref mime-part 'mimepart) content-only? decode?))

(define-method (filename (mime-part <mime-part>))
  "Determine the file-name for MIME-part.
Either the 'filename' field in the mime-part and if that does not exist, use
'mime-part-<index>' with <index> being the number of the mime-part."
  (let ((alist (mime-part->alist mime-part)))
    (or (assoc-ref  alist 'filename)
	(format #f "mime-part-~d" (assoc-ref alist 'index)))))

(define* (make-output-file mime-part #:key (path #f) (overwrite? #f))
  "Create a port for the file to write MIME-PART to.

PATH is file-name or path to the file name. If not specified, use the 'filename'
field in the mime-part and if that does not exist, use 'mime-part-<index>' with
<index> being the number of the mime-part.

OVERWRITE? specifies whether existing files by the same name or overwritten.
Otherwise, trying to overwrite an existing file raises an error."
  (let* ((alist (mime-part->alist mime-part))
	 (path (or path (filename mime-part))))
    ;; we need an fd-based port since we want to support overwrite?
    (open path
	  (logior O_WRONLY O_CREAT O_TRUNC (if overwrite? O_EXCL 0)) #o644)))

(define* (write-to-file mime-part #:key (path #f) (overwrite? #f))
  "Write MIME-PART to a file.

PATH is the path/filename for the file. If not specified, use the 'filename'
field in the mime-part and if that does not exist, use 'mime-part-<index>' with
<index> being the number of the mime-part.

OVERWRITE? specifies whether existing files by the same name or overwritten.
Otherwise, trying to overwrite an existing file raises an error."
  (let* ((input (make-port mime-part))
	 (output (make-output-file mime-part
				   #:path path #:overwrite? overwrite?))
	 (buf (make-bytevector 4096)) ;; just a guess...
	 (bytes 0))
    (while (not (eof-object? bytes)) ;; XXX do this in a more elegant way.
      (set! bytes (get-bytevector-n! input buf 0 (bytevector-length buf)))
      (put-bytevector output buf 0 (if (eof-object? bytes) 0 bytes)))
    (close input)
    (close output)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Message
(define-class <message> ()
  (object #:init-value #f #:init-keyword #:object)
  (plist #:init-value #f #:init-keyword #:plist)
  (parts #:init-value #f #:init-keyword #:parts))
(set-documentation!
 '<message>
 "A <message> represents the information about a message.

Exactly what information depends on how the object came to be;
these are the slots:

- cc-message: this is a foreign-object representing the mu
  message object, and needs to be passed to some 'cc-' methods.
- parts: a list of <mime-part> objects
- plist: this is an Emacs-style property list which is cached
  for each message in the store; this was originally added
  for use in mu4e, but we re-use it here.
- alist: an association list; this is just more 'scheme-like'
  version of the plist, it is created on-demand (message->alist).

A message that came from a search such as 'mfind' initially only
has the plist, but when a message is loaded from file, either
through make-message or by calling a function that needs a
full message, such as header or body, the cc-message is initialized.

Only having a plist is cheaper.")

(define (make-message path)
  "Create a <message> from file at PATH."
  (make <message> #:object (cc-message-make path)))

(define-method (plist (message <message>))
  "Get the PLIST for this MESSAGE."
  (when (not (slot-ref message 'plist))
    (slot-set! message 'plist (cc-message-plist (object message))))
  (slot-ref message 'plist))

(define-method (object (message <message>))
  "Get the foreign object for this MESSAGE.
If MESSAGE does not have such an object yet, create it from the
path of the message."
  (if (not (slot-ref message 'object))
      (slot-set! message 'object (cc-message-make (path message))))
  (slot-ref message 'object))

(define-method (find-field (message <message>) field)
  (plist-find (plist message) field))

(define-method (sexp (message <message>))
  "Get the s-expression (plist) for this MESSAGE.

This is an internal data-structure, originally for use with mu4e, but useful
here as well. However, the precise details are not part of mu-scm API."
  (plist message))

(define (emacs-time->epoch-secs lst)
  "Convert emacs-style timestamp LST to a number of seconds since epoch.
If LST is #f, return #f."
  (if lst
      (+ (ash (car lst) 16) (cadr lst))
      #f))

;; Accessors for the fields

(define-method (subject (message <message>))
  "Get the subject for MESSAGE or #f if not found."
  (find-field message ':subject))

(define-method (maildir (message <message>))
  "Get the maildir for MESSAGE or #f if not found."
  (find-field message ':maildir))

(define-method (message-id (message <message>))
  "Get the message-id for MESSAGE or #f if not found."
  (find-field message ':message-id))

(define-method (date (message <message>))
  "Get the date for MESSAGE was sent.
This is the number of seconds since epoch; #f if not found."
  (emacs-time->epoch-secs (find-field message ':date)))

(define-method (last-change (message <message>))
  "Get the date for the last change to MESSAGE.
This is the number of seconds since epoch; #f if not found."
  (emacs-time->epoch-secs (find-field message ':changed)))

(define-method (path (message <message>))
  "Get the file-system path for MESSAGE.
A symbol, either 'high, 'low or 'normal, or #f if not found."
  (find-field message ':path))

(define-method (priority (message <message>))
  "Get the priority for MESSAGE.
A symbol, either 'high, 'low or 'normal, or #f if not found."
  (find-field message ':priority))

(define-method (language (message <message>))
  "Get the ISO-639-1 language code for the MESSAGE as a symbol, if detected.
Return #f otherwise."
  (let ((lang (find-field message ':language)))
    (if lang
	(string->symbol lang)
	#f)))
;; if-let would be nice!

(define-method (size (message <message>))
  "Get the size of the MESSAGE in bytes or #f if not available."
  (find-field message ':size))

(define-method (references (message <message>))
  "Get the list of reference of MESSAGE or #f if not available.
 with the oldest first and the direct parent as the last one. Note, any
reference (message-id) will appear at most once, duplicates and
fake-message-id (see impls) are filtered out. If there are no references, return
#f."
  (find-field message ':references))

(define-method (thread-id (message <message>))
  "Get the oldest (first) reference for MESSAGE, or message-id if there are none.
If neither are available, return #f.
This is method is useful to determine the thread a message is in."
  (let ((refs (references message)))
    (if (and refs (not (null? refs)))
	(car refs)
	(message-id message))))

(define-method (mailing-list (message <message>))
  "Get the mailing-list id for MESSAGE or #f if not available."
  (find-field message ':list))

;;  Flags.

(define-method (flags (message <message>))
  "Get the size of the MESSAGE in bytes or #f if not available."
  (find-field message ':flags))

(define-method (flag? (message <message>) flag)
  "Does MESSAGE have FLAG?"
  (let ((flags
	 (find-field message ':flags)))
    (if flags
	(if (member flag flags) #t #f)
	#f)))

(define-method (draft? (message <message>))
  "Is MESSAGE a draft message?"
  (flag? message 'draft))

(define-method (flagged? (message <message>))
  "Is MESSAGE flagged?"
  (flag? message 'flagged))

(define-method (passed? (message <message>))
  "Has MESSAGE message been 'passed' (forwarded)?"
  (flag? message 'passed))

(define-method (replied? (message <message>))
  "Has MESSAGE been replied to?"
  (flag? message 'replied))

(define-method (seen? (message <message>))
  "Does MESSAGE been 'seen' (read)?"
  (flag? message 'seen))

(define-method (trashed? (message <message>))
  "Has MESSAGE been trashed?"
  (flag? message 'trashed))

(define-method (new? (message <message>))
  "Is MESSAGE new?"
  (flag? message 'new))

(define-method (signed? (message <message>))
  "Has MESSAGE been cryptographically signed?"
  (flag? message 'signed))

(define-method (encrypted? (message <message>))
  "Has MESSAGE been encrypted?"
  (flag? message 'encrypted))

(define-method (attach? (message <message>))
  "Does MESSAGE have an attachment?"
  (flag? message 'attach))

(define-method (unread? (message <message>))
  "Is MESSAGE unread?"
  (flag? message 'unread))

(define-method (list? (message <message>))
  "Is MESSAGE from some mailing-list?"
  (flag? message 'list))

(define-method (personal? (message <message>))
  "Is MESSAGE personal?"
  (flag? message 'personal))

(define-method (calendar? (message <message>))
  "Does MESSAGE have a calender invitation?"
  (flag? message 'calendar))

(define-method (find-contact-field (message <message>) field)
  "Get contact FIELD from MESSAGE as an alist.
Helper method "
  (let ((cs (find-field message field)))
    (if cs
	(map plist->alist cs)
	#f)))

(define-method (from (message <message>))
  "Get the sender (the From: field) for MESSAGE or #f if not found."
  (find-contact-field message ':from))

(define-method (to (message <message>))
  "Get the (intended) recipient for MESSAGE (the To: field) or #f if not found."
  (find-contact-field message ':to))

(define-method (cc (message <message>))
  "Get the (intended) carbon-copy recipient for MESSAGE (the Cc: field) or #f if
not found."
  (find-contact-field message ':cc))

(define-method (bcc (message <message>))
  "Get the (intended) blind carbon-copy recipient for MESSAGE (the Bcc: field) or
#f if not found."
  (find-contact-field message ':bcc))

(define* (body message #:key (html? #f))
  "Get the MESSAGE body or #f if not found
If #:html is non-#f, instead search for the HTML body.
Requires the full message."
  (cc-message-body (object message) html?))

(define-method (header (message <message>) (field <string>))
  "Get the raw MESSAGE header FIELD or #f if not found.
FIELD is case-insensitive and should not have the ':' suffix.
Requires the full message."
  (cc-message-header (object message) field))

(define-method (mime-parts (message <message>))
  "Get the MIME-parts for this message.
This is a list of <mime-part> objects."
  (let ((msgobj (object message)))
    (map (lambda (mimepart-alist)
	   (make <mime-part>
	     #:mimepart (car mimepart-alist)
	     #:alist (cdr mimepart-alist)))
	 (cc-message-parts msgobj))))

;; Store
;;
;; Note: we have a %default-store, which is the store we opened during
;; startup; for now that's the only store supported, but we keep things
;; open.
;;
;; Since it's the default store, we'd like to call the methods without
;; explicitly using %default-store; with GOOPS, we cannot pass a default for
;; that, nor can we use keyword arguments (I think?). So use define* for that.

;; the 'store-object' is a foreign object wrapping a const Store*.
(define-class <store> ()
  (store-object #:init-keyword #:store-object #:getter store-object)
  (alist #:init-value #f))

(set-documentation!
 '<store>
 "A <store> represents mu's message store (database).

It has a few slots:
- cc-store: this is a foreign-object for a Mu::Store*.
  It needs to be passed to some 'cc-' methods.
- alist: an association list; this is the cached representation
  of some store properties.")

;;  not exported
(define-method (make-store store-object)
  "Make a store from some STORE-OBJECT."
  (make <store> #:store-object store-object))

(define %default-store
  ;; %default-store-object is defined in mu-scm-store.cc
  (make-store %default-store-object))
(set-documentation! '%default-store  "Default store.")

(set-documentation! '%cc-default-store
 "Default store object.
This is defined in the C++ code, and represents a \"foreign\" Store* object.")

(define* (store->alist #:key (store %default-store))
  "Get an alist-representation for some store.
Keyword arguments:
    #:store       %default-store. Leave at default."
  (when (not (slot-ref store 'alist))
    (slot-set! store 'alist (cc-store-alist (store-object store))))
  (slot-ref store 'alist))

(define* (mfind query
		#:key
		(store %default-store)
		(related? #f)
		(skip-dups? #f)
		(sort-field 'date)
		(reverse? #f)
		(max-results #f))
  "Find messages matching some query.

The query is mandatory, the other (keyword) arguments are optional.
(mfind QUERY
    #:store       %default-store. Leave at default.
    #:related?    include related messages?  Default: false
    #:skip-dups?  skip duplicates? Default: false
    #:sort-field? field to sort by, a symbol. Default: date
    #:reverse?    sort in descending order (z-a)
    #:max-results max. number of matches. Default: false (unlimited))."
  (map (lambda (plist)
	 (make <message> #:plist plist))
       (cc-store-mfind (store-object store) query
		       related? skip-dups? sort-field reverse? max-results)))

(define* (mcount
	  #:key
	  (store %default-store))
  "Get the number of messages."
  (cc-store-mcount (store-object store)))

(define* (cfind pattern
		#:key
		(store %default-store)
		(personal? #f)
		(after #f)
		(max-results #f))
  "Find contacts matching some regex pattern, similar to mu-cfind(1).

The pattern is mandatory; the other (keyword) arguments are optional.
(cfind PATTERN
    #:store       %default-store. Leave at default.
    #:personal?   only include 'personal' contacts. Default: all
    #:after       only include contacts last seen time_t: Default all
    #:max-results max. number of matches. Default: false (unlimited))."
  (cc-store-cfind (store-object store) pattern personal? after max-results))

;;; Misc

;; Get an alist with the general options this instance of \"mu\" started with.
;; These are based on the command-line arguments, environment etc., see the
;; mu-scm(1) manpage for details.
;;
;; The alist maps symbols to values; a value of #f indicates that the value is at
;; its default.
%options ;; defined in c++
(set-documentation! '%options
		    "Alist with the command-line parameters.")

(define %preferences
  '( (short-date  . "%F %T")
     (utc?        . #f)))
;; XXX; not exposed yet. Perhaps we need a "fluid" here?
(set-documentation! '%preferences
  "Alist with user-preferences.
- short-date: a strftime-compatibie string for the display
	      format of short dates.
- utc?       : whether to assume use UTC for dates/times")

(define (value-or-preference val key)
  "If VAL is the symbol 'preference, return the value for KEY from %preferences.
Otherwise, return VAL."
  (if (eq? val 'preference)
      (assoc-ref %preferences key)
      val))

;;; Helpers

(define* (string->time datestr #:key (utc? 'preference))
  "Convert an ISO-8601-style DATESTR to a number of seconds since epoch.
(like time_t, (current-time).

ISODATE is a string with the strftime format \"%FT%T\", i.e.,
yyyy-mm-ddThh:mm:ss or any prefix there of. The 'T', ':', '-' or any non-numeric
characters re optional.

UTC? determines whether ISODATE should be interpreted as an UTC time.

The input date format is fixed."
 ;; XXX If not set, read the default from the %preferences variable.
  (let* ((utc? (value-or-preference utc? 'utc?))
	 (tmpl "00000101000000")
	 (datestr (string-filter char-numeric? datestr)) ;; filter out 'T' ':' '-' etc
	 (datestr					 ;; fill out datestr
	  (if (> (string-length tmpl) (string-length datestr))
	      (string-append datestr (substring tmpl (string-length datestr)))
	      datestr))
	 (sbdtime (car (strptime "%Y%m%d%H%M%S" datestr))))
    (car (if utc?
	     (mktime sbdtime "UTC")
	     (mktime sbdtime)))))

(define* (time->string time-t #:key (format 'preference) (utc? 'preference))
  "Convert a time_t (second-since-epoch) value TIME-T into a string.

FORMAT is the strftime-compatible format-string UTC? determines whether to use
UTC time.

 If TIME-T is #f, return #f."
;; If not specified, both are determined from %preferences ('short-date
;; and 'utc?, respectively).
  (let* ((format (value-or-preference format 'short-date))
	 (utc? (value-or-preference utc? 'utc?)))
    (if time-t
	(let ((t (if utc? (gmtime time-t) (localtime time-t))))
	  (strftime format t))
	#f)))