#!/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) (ice-9 receive) (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))) (simple-format #t "~a~a~%" (pcmd dry-run (simple-format #f " [~a] " proc-name)) subject) (unless dry-run (map proc files)) (list subject files))))) (define (delete-email-files! options) (with-nm-database (ffi-db (assq-ref options 'mail-repo) 0) (with-nm-query (ffi-db to-delete "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))))) (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))) (with-nm-database (ffi-db mail-repo 0) (let* ((target-folder (format #f "~a~a/~a" mail-repo account end-dir)) (uidvalidity (get-folder-uidvalidity target-folder))) (with-nm-query (ffi-db to-move (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))))))) (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))))) (receive vals (proc (cdr p2c) port) (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 and not subject:\"mentioned you\")") ("+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 "(~{from:~a~^ OR ~}) AND NOT (~:*~{to:~a~^ OR ~})" my-emails))) (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 (cons 'mail-repo (string-append (passwd:dir (getpwuid (geteuid))) "/.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")) (with-nm-database (ffi-db (assq-ref options 'mail-repo) 1) (let ((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")))))