diff options
| -rwxr-xr-x | bin/tagmail | 45 | ||||
| -rw-r--r-- | lib/guile/mail-tools.scm | 20 |
2 files changed, 31 insertions, 34 deletions
diff --git a/bin/tagmail b/bin/tagmail index 02e5d6e..611d2f6 100755 --- a/bin/tagmail +++ b/bin/tagmail @@ -18,7 +18,6 @@ LD_LIBRARY_PATH=$HOME/.guix-profile/lib exec guile -e main -s "$0" "$@" (ice-9 ftw) (ice-9 format) (ice-9 getopt-long) - (ice-9 match) (ice-9 popen) (ice-9 ports) (ice-9 rdelim) @@ -31,26 +30,20 @@ LD_LIBRARY_PATH=$HOME/.guix-profile/lib exec guile -e main -s "$0" "$@" (system foreign) (term ansi-color)) -(define (pcmd dry-run str) - (apply colorize-string - (if dry-run - `(,str BOLD) - `(,str RED BOLD)))) - -(define (on-all-messages-filenames query proc proc-name dry-run) +(define (on-all-messages-filenames query proc) (nm-iter messages (nm-result-messages query) (lambda (message*) - (let ((subject (nm-header message* "subject")) - (files (nm-iter filenames (notmuch_message_get_filenames message*) - pointer->string))) - (simple-format #t "~a~a~%" - (pcmd dry-run (simple-format #f " [~a] " proc-name)) - subject) - (unless dry-run - (map proc files)) - (list subject files))))) + (simple-format #t " ~a~%" (nm-header message* "subject")) + (map proc (nm-iter filenames (notmuch_message_get_filenames message*) + pointer->string))))) (define (delete-email-files! options) + (define (logged-delete file-path) + (let ((do? (not (option-ref options 'dry-run #f)))) + (simple-format #t " [~a] ~a~%" + (colorize-string "rm" 'BOLD (if do? 'RED 'NONE)) + file-path) + (if do? (delete-file file-path)))) (with-nm-database (ffi-db (assq-ref options 'mail-repo) 0) (with-nm-query @@ -59,14 +52,15 @@ LD_LIBRARY_PATH=$HOME/.guix-profile/lib exec guile -e main -s "$0" "$@" (colorize-string "[DELETE] " 'BOLD 'YELLOW) (number->string (nm-count-messages to-delete)) " files marked\n")) - (on-all-messages-filenames to-delete delete-file "rm" (option-ref options 'dry-run #f))))) + (on-all-messages-filenames to-delete logged-delete)))) (define (move-mail! options account query start-dir end-dir) (define (move-file uidvalidity target-folder) (lambda (file) (let* ((target-file (new-path (rename-higher file uidvalidity) target-folder)) (sub-len (string-prefix-length file target-file))) - (simple-format #t " ~a -> ~a~%" + (simple-format #t " [~a] ~a -> ~a~%" + (colorize-string "mv" 'BOLD (if do? 'RED 'NONE)) (substring file sub-len) (substring target-file sub-len)) (unless (option-ref options 'dry-run #f) @@ -85,8 +79,7 @@ LD_LIBRARY_PATH=$HOME/.guix-profile/lib exec guile -e main -s "$0" "$@" " messages marked in " (colorize-string account 'GREEN 'BOLD) "\n")) - (on-all-messages-filenames to-move (move-file uidvalidity target-folder) "mv" - (option-ref options 'dry-run #f))))))) + (on-all-messages-filenames to-move (move-file uidvalidity target-folder))))))) (define (apply-tags-to-message options tags) (lambda (message) @@ -96,8 +89,9 @@ LD_LIBRARY_PATH=$HOME/.guix-profile/lib exec guile -e main -s "$0" "$@" (define (notmuch-tag options ffi-db rules new) (map (lambda (rule) - (match-let* (((tags query-str) (with-new rule new)) - (info (if (null? (cddr rule)) query-str (caddr rule)))) + (let* ((query-str (query-with-new rule new)) + (tags (tags-with-new rule new)) + (info (if (null? (cddr rule)) query-str (caddr rule)))) (with-nm-query (ffi-db query query-str) (simple-format #t " ~a messages: ~a~a~%" @@ -110,8 +104,9 @@ LD_LIBRARY_PATH=$HOME/.guix-profile/lib exec guile -e main -s "$0" "$@" (define (list-tag options ffi-db new) (display (colorize-string "[LISTS filters]\n" 'BOLD 'YELLOW)) - (match-let* (((tags-str query-str) (with-new '("+lists" "not tag:lists") new)) - (reg (make-regexp "<([a-z0-9=_-]+)\\." regexp/icase))) + (let ((query-str (query-with-new '("+lists" "not tag:lists") new)) + (tags-str (tags-with-new '("+lists" "not tag:lists") new)) + (reg (make-regexp "<([a-z0-9=_-]+)\\." regexp/icase))) (with-nm-query (ffi-db query query-str) (->> (lambda (msg*) diff --git a/lib/guile/mail-tools.scm b/lib/guile/mail-tools.scm index d496c5b..b158d93 100644 --- a/lib/guile/mail-tools.scm +++ b/lib/guile/mail-tools.scm @@ -9,7 +9,8 @@ get-uidvalidity get-folder-uidvalidity new-path - with-new + tags-with-new + query-with-new nm-open-database nm-query-db nm-result-messages @@ -39,14 +40,15 @@ (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)))) +(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) |