From 2cb5bf997bfa81df0290e0496a15f1f39a569e78 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?=C3=93scar=20N=C3=A1jera?= <hi@oscarnajera.com>
Date: Thu, 5 May 2022 14:42:32 +0200
Subject: Import my guile libraries

---
 lib/guile/mail-tools.scm | 126 +++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 126 insertions(+)
 create mode 100644 lib/guile/mail-tools.scm

(limited to 'lib/guile/mail-tools.scm')

diff --git a/lib/guile/mail-tools.scm b/lib/guile/mail-tools.scm
new file mode 100644
index 0000000..d496c5b
--- /dev/null
+++ b/lib/guile/mail-tools.scm
@@ -0,0 +1,126 @@
+(define-module (mail-tools)
+  #:use-module (ffi notmuch)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 regex)
+  #:use-module (srfi srfi-1)
+  #:use-module (system ffi-help-rt)
+  #:use-module (system foreign)
+  #:export (rename-higher
+            get-uidvalidity
+            get-folder-uidvalidity
+            new-path
+            with-new
+            nm-open-database
+            nm-query-db
+            nm-result-messages
+            nm-header
+            nm-count-messages
+            nm-apply-tags
+            nm-iter
+            with-nm-database
+            with-nm-query))
+
+(define (rename-higher name limit)
+  (let ((mat (string-match ",U=[0-9]+" name)))
+    (if (and mat (< limit (string->number (substring (match:substring mat) 3))))
+        (string-append (match:prefix mat) (match:suffix mat))
+        name)))
+
+(define (get-uidvalidity port)
+  (read-line port)
+  (string->number (read-line port)))
+
+(define (get-folder-uidvalidity folder)
+  (call-with-input-file (string-append folder "/.uidvalidity") get-uidvalidity))
+
+(define (new-path path destination)
+  (let ((filename (basename path))
+        (submaildir (basename (dirname path))))
+    (string-join (list destination submaildir filename)
+                 file-name-separator-string)))
+
+(define (with-new rule new)
+  (list
+   (if new (string-append (car rule) " -new") (car rule))
+   (if new
+       (if (string=? (cadr rule) "*")
+           "tag:new"
+           (simple-format #f "(~a) and ~a" (cadr rule) "tag:new"))
+       (cadr rule))))
+
+;; NOTMUCH interface
+(define (nm-open-database path mode)
+  (let ((ffi-db (make-notmuch_database_t*)))
+    (notmuch_database_open (string->pointer path) mode (pointer-to ffi-db))
+    ffi-db))
+
+(define (nm-query-db db str)
+  (let ((query (notmuch_query_create db (string->pointer str))))
+    (for-each (lambda (tag)
+                (notmuch_query_add_tag_exclude query (string->pointer tag)))
+              (list "deleted" "spam"))
+    query))
+
+(define (nm-result-messages query)
+  (let ((messages (make-notmuch_messages_t*)))
+    (notmuch_query_search_messages query (pointer-to messages))
+    messages))
+
+(define (nm-header message label)
+  (pointer->string (notmuch_message_get_header message (string->pointer label))))
+
+(define (nm-count-messages query)
+  (let ((counter (make-int32)))
+    (notmuch_query_count_messages query (pointer-to counter))
+    (fh-object-ref counter)))
+
+(eval-when (expand load eval)
+  (define (stx->str stx) (symbol->string (syntax->datum stx)))
+  (define (singular stx) (string-drop-right (stx->str stx) 1))
+  (define (nm-symbols tmpl-id . args)
+    (datum->syntax
+     tmpl-id
+     (string->symbol
+      (apply string-append
+             (map (lambda (ss) (if (string? ss) ss (stx->str ss))) args))))))
+
+(define-syntax nm-iter
+  (lambda (x)
+    (syntax-case x ()
+      ((_ type query proc)
+       (with-syntax ((valid? (nm-symbols #'type "notmuch_" #'type "_valid"))
+                     (destroy (nm-symbols #'type "notmuch_" #'type "_destroy"))
+                     (get (nm-symbols #'type "notmuch_" #'type "_get"))
+                     (next (nm-symbols #'type "notmuch_" #'type "_move_to_next"))
+                     (item-destroy (nm-symbols #'type "notmuch_" (singular #'type) "_destroy")))
+         #'(let ((obj query))
+             (let loop ((item (get obj))
+                        (acc '()))
+               (if (= 0 (valid? obj))
+                   (begin
+                     (destroy obj)
+                     acc)
+                   (let ((result (proc item)))
+                     (when (defined? (quote item-destroy))
+                       (item-destroy item))
+                     (next obj)
+                     (loop (get obj) (cons result acc)))))))))))
+
+(define (nm-apply-tags message tags)
+  (let loop ((rest (string-tokenize tags)))
+    (unless (null-list? rest)
+      (let ((tag (string->pointer (substring (car rest) 1))))
+        (if (string-prefix? "-" (car rest))
+            (notmuch_message_remove_tag message tag)
+            (notmuch_message_add_tag message tag)))
+      (loop (cdr rest)))))
+
+(define-syntax-rule (with-nm-database (db path mode) body body* ...)
+  (let ((db (nm-open-database path mode)))
+    body body* ...
+    (notmuch_database_destroy db)))
+
+(define-syntax-rule (with-nm-query (db qobj query) body body* ...)
+  (let ((qobj (nm-query-db db query)))
+    body body* ...
+    (notmuch_query_destroy qobj)))
-- 
cgit v1.2.3