398 lines
11 KiB
Scheme
398 lines
11 KiB
Scheme
;; 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 (ice-9 optargs)
|
||
#:export (
|
||
;; classes
|
||
<store>
|
||
|
||
mfind
|
||
mcount
|
||
cfind
|
||
|
||
<message>
|
||
sexp
|
||
|
||
date
|
||
iso-date
|
||
last-change
|
||
|
||
message-id
|
||
path
|
||
priority
|
||
subject
|
||
|
||
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
|
||
|
||
;; misc
|
||
options
|
||
|
||
;; helpers
|
||
iso-date->time-t
|
||
time-t->iso-date))
|
||
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
;; 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))
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
||
;; Message
|
||
;;
|
||
;; A <message> is created from a message plist.
|
||
|
||
;; In mu, we have store a plist sexp for each message in the database,
|
||
;; for use with mu4e. But, that very plist is useful here as well.
|
||
(define-class <message> ()
|
||
(plist #:init-keyword #:plist #:getter plist))
|
||
|
||
;; using the plist as-is makes for O(n) access to the various fields
|
||
|
||
(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))
|
||
|
||
;; Accessor 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))
|
||
|
||
;; 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))
|
||
|
||
;; 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))
|
||
|
||
;; 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))
|
||
|
||
(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))
|
||
(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."
|
||
(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))."
|
||
(store-cfind (store-object store) pattern personal? after max-results))
|
||
|
||
;;; Misc
|
||
|
||
(define (options)
|
||
"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)
|
||
|
||
;;; Helpers
|
||
|
||
(define* (iso-date->time-t isodate)
|
||
"Convert an ISO-8601 ISODATE to a number of seconds since epoch.
|
||
|
||
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.
|
||
|
||
ISODATE is assumed to represent some UTC date."
|
||
(let* ((tmpl "00000101000000")
|
||
(isodate (string-filter char-numeric? isodate)) ;; filter out 'T' ':' '-' etc
|
||
(isodate ;; fill out isodate
|
||
(if (> (string-length tmpl) (string-length isodate))
|
||
(string-append isodate (substring tmpl (string-length isodate)))
|
||
isodate)))
|
||
;;(format #t "~a\n" isodate)
|
||
(car (mktime (car (strptime "%Y%m%d%H%M%S" isodate)) "Z"))))
|
||
|
||
(define-method (time-t->iso-date time-t)
|
||
"Convert a time_t (second-since-epoch) value TIME-T to an ISO-8601
|
||
string for the corresponding UTC time.
|
||
|
||
If TIME-T is #f, return an empty string of the same length."
|
||
(if time-t
|
||
(strftime "%FT%T" (gmtime time-t))
|
||
" "))
|