diff options
Diffstat (limited to 'bin')
| -rwxr-xr-x | bin/tagmail | 230 |
1 files changed, 230 insertions, 0 deletions
diff --git a/bin/tagmail b/bin/tagmail new file mode 100755 index 0000000..e6b4c50 --- /dev/null +++ b/bin/tagmail @@ -0,0 +1,230 @@ +#!/usr/bin/guile \ +-e main -s +!# +;; TODO +;; - Check for bogofilter installation +;; - Check for compilation a notmuch dev package or package all or learn just to compile without the guild call +;; - Spam moving check on other folders like work +;; - individual tag-rules testing take the ones with [] subject + +(add-to-load-path + (string-append + (passwd:dir (getpwuid (geteuid))) + "/dev/helpful_scripts/guile/" )) + +(use-modules + (ffi notmuch) + (ice-9 and-let-star) + (ice-9 ftw) + (ice-9 getopt-long) + (ice-9 match) + (ice-9 popen) + (ice-9 ports) + (ice-9 rdelim) + (ice-9 regex) + (mail-tools) + (srfi srfi-1) + (system ffi-help-rt) + (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) + (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))) + (display (string-append + (pcmd dry-run (format #f " [~a] " proc-name)) + subject + "\n")) + (unless dry-run + (map proc files)) + (list subject files))))) + +(define (delete-email-files! options) + (let* ((ffi-db (nm-open-database (assq-ref options 'mail-repo) 0)) + (to-delete (nm-query-db ffi-db "tag:deleted"))) + (display (string-append + (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)) + (notmuch_query_destroy to-delete) + (notmuch_database_destroy ffi-db))) + +(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~%" + (substring file sub-len) + (substring target-file sub-len)) + (unless (option-ref options 'dry-run #f) + (rename-file file target-file))))) + + (let* ((mail-repo (assq-ref options 'mail-repo)) + (ffi-db (nm-open-database mail-repo 0)) + (target-folder (format #f "~a~a/~a" mail-repo account end-dir)) + (uidvalidity (get-folder-uidvalidity target-folder)) + (to-move (nm-query-db ffi-db + (format #f "~a and folder:~a/~a" query account start-dir)))) + (display (string-append + (colorize-string "[MOVE] " 'BOLD 'YELLOW) + (number->string (nm-count-messages to-move)) + " 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)) + (notmuch_query_destroy to-move) + (notmuch_database_destroy ffi-db))) + +(define (apply-tags-to-message options tags) + (lambda (message) + (simple-format #t " ~a~%" (nm-header message "subject")) + (unless (option-ref options 'dry-run #f) + (nm-apply-tags message tags)) #t)) + +(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))) + (query (nm-query-db ffi-db query-str))) + (simple-format #t " ~a messages: ~a~a~%" + (nm-count-messages query) + (if (string=? info query-str) "" + (string-append info " | ")) + tags) + (nm-iter messages (nm-result-messages query) (apply-tags-to-message options tags)) + (notmuch_query_destroy query))) + rules)) + +(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)) + (query (nm-query-db ffi-db query-str)) + (result (nm-iter + messages (nm-result-messages query) + (lambda (msg*) + (and-let* ((list-id (regexp-exec reg (nm-header msg* "list-id"))) + (tags (format #f "~a +lists/~a" tags-str + (string-downcase (match:substring list-id 1))))) + ((apply-tags-to-message options tags) msg*)))))) + (simple-format #t " ~a messages belonging to lists~%" + (length (filter identity result))) + (notmuch_query_destroy query))) + +(define (spam-channel push result) + (setvbuf push 'line) + (lambda (path) + (display path push) + (unless (string-suffix? "\n" path) + (newline push)) + (string=? "S" (cadr (string-split (read-line result) #\space))))) + +(define (call-with-pipe cmd proc) + (let* ((p2c (pipe)) + (port (with-input-from-port (car p2c) + (lambda () + (open-input-pipe cmd))))) + (call-with-values + (lambda () + (proc (cdr p2c) port)) + (lambda vals + (close-port (cdr p2c)) + (close-pipe port) + (apply values vals))))) + +(define (tag-spam options ffi-db query-str) + (call-with-pipe + "bogofilter -bTv" + (lambda (push result) + (display (colorize-string "[SPAM Flag]\n" 'BOLD 'YELLOW)) + (let* ((spam? (spam-channel push result)) + (query (nm-query-db ffi-db query-str)) + (result (nm-iter messages (nm-result-messages query) + (lambda (message) + (when (spam? (pointer->string (notmuch_message_get_filename message))) + ((apply-tags-to-message options "+spam -inbox") message)))))) + (format #t " ~a messages added to spam~%" + (length (filter boolean? result))) + (notmuch_query_destroy query))))) + +(define tag-rules + '(("+ci" "from:travis-ci.com or from:travis-ci.org or from:appveyor.com or from:circleci.com or from:mg.gitlab.com and subject:Pipeline") + ("+CMK-JIRA -inbox" "from:infra@mathias-kettner.de or from:jira@tribe29.com") + ("+slack" "from:slack.com") + ("+alle-mk" "to:alle@mathias-kettner.de to:technik@tribe29.com") + ("+cmk-commits" "to:cmk-internal-commits@mathias-kettner.de") + ("+cma-commits" "to:cma-commits@mathias-kettner.de") + ("+immonews" "from:immobilienscout24.de") + ("+immonews/communications" "from:nachrichten.immobilienscout24.de or subject:Kontaktaufnahme and tag:immonews") + ("+socialnews" "from:facebookmail.com or from:mail.instagram.com") + ("+promotions" "from:newsletter") + ("+linkedin +socialnews" "from:linkedin.com" "Linkedin") + ("+meetups" "from:info@meetup.com" "Meetups info mails") + ("+ingrid" "from:postmaster@oscarnajera.com or from:root@oscarnajera.com" "Reports from ingrid") + ("+fail2ban" "subject:Fail2Ban from:oscarnajera.com" "Fail2ban report") + ("+toastmasters" "toastmaster NOT from:info@meetup.com") + ("+sms" "folder:hi_pers/SMS") + ("+calls" "folder:hi_pers/Calls"))) + +(define (clear-inbox options ffi-db) + (display (colorize-string "[Inbox]\n" 'BOLD 'YELLOW)) + (let* ((my-emails (list "hi@oscarnajera.com" "hello@oscarnajera.com" "najera.oscar@gmail.com" + "on@mathias-kettner.de" "oscar.najera@tribe29.com")) + (sent (format #f "~?" "(~A) AND NOT (~A)" + (map (lambda (header) + (string-join + (map (lambda (address) + (format #f "~a:~a" header address)) + my-emails) + " OR ")) + (list "from" "to"))))) + (notmuch-tag options ffi-db `(("+sent" ,sent "Emails I have sent") + ("+inbox" "*" "Inbox for the rest")) #t))) + +(define (main args) + (let* ((option-spec '((version (single-char #\V) (value #f)) + (help (single-char #\h) (value #f)) + (all (value #f)) + (dry-run (single-char #\n) (value #f)))) + (options (cons '(mail-repo . "/home/titan/.mail/") + (getopt-long args option-spec))) + (account (if (null? (assq-ref options '())) "hi_pers" (car (assq-ref options '()))))) + (delete-email-files! options) + (if (string=? account "hi_pers") + (move-mail! options account "tag:spam" "Inbox" "Junk")) + + + (unless (option-ref options 'dry-run #f) + (display (colorize-string "[SYNC]\n" 'BOLD 'YELLOW)) + (system (string-append "mbsync " (if (null? (assq-ref options '())) " -a" account))) + (display (colorize-string "[notmuch new]\n" 'BOLD 'YELLOW)) + (system "notmuch new")) + + (let ((ffi-db (nm-open-database (assq-ref options 'mail-repo) 1)) + (new (not (option-ref options 'all #f)))) + (list-tag options ffi-db new) + (display (colorize-string "[TAG rules]\n" 'BOLD 'YELLOW)) + (notmuch-tag options ffi-db tag-rules new) + (clear-inbox options ffi-db) + (tag-spam options ffi-db "tag:inbox") + (notmuch_database_destroy ffi-db)))) + +(let* ((ffi-db (nm-open-database "/home/titan/.mail/" 0)) + (query (nm-query-db ffi-db "subject:^.FYI")) + (subjects (nm-iter messages (nm-result-messages query) + (lambda (msg) (nm-header msg "subject"))))) + + (notmuch_database_destroy ffi-db) + subjects) |