blob: b158d936808635118703361fa28495aa8a9ede53 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
|
(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
tags-with-new
query-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 (tags-with-new rule new)
(if new (string-append (car rule) " -new") (car rule)))
(define (query-with-new rule new)
(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)))
|
