elisp

#!/usr/bin/env sh
LD_LIBRARY_PATH=$HOME/.guix-profile/lib exec guile -e main -s "$0" "$@"
!#
;; 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/dotfiles/lib/guile/" ))

(use-modules
 (ffi notmuch)
 (ice-9 and-let-star)
 (ice-9 ftw)
 (ice-9 format)
 (ice-9 getopt-long)
 (ice-9 popen)
 (ice-9 ports)
 (ice-9 rdelim)
 (ice-9 regex)
 (ice-9 receive)
 (mail-tools)
 (utils)
 (srfi srfi-1)
 (system ffi-help-rt)
 (system foreign))

(define (on-all-messages-filenames query proc)
  (nm-iter messages (nm-result-messages query)
           (lambda (message*)
             (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)
    (simple-format #t " [rm] ~a~%" file-path)
    (unless (option-ref options 'dry-run #f)
      (delete-file file-path)))
  (with-nm-database
   (ffi-db (assq-ref options 'mail-repo) 0)
   (with-nm-query
    (ffi-db to-delete "tag:deleted")
    (display (string-append
              "[DELETE] "
              (number->string (nm-count-messages to-delete))
              " files marked\n"))
    (on-all-messages-filenames to-delete logged-delete))))

(define (move-mail! options account query start-dir end-dir)
  (define (move-file uidvalidity target-folder)
    (let ((dry-run? (option-ref options 'dry-run #f)))
      (lambda (file)
        (let* ((target-file (new-path (rename-higher file uidvalidity) target-folder))
               (sub-len (string-prefix-length file target-file)))
          (simple-format #t " [mv]   ~a -> ~a~%"
                         (substring file sub-len)
                         (substring target-file sub-len))
          (unless dry-run? (rename-file file target-file))))))

  (let* ((mail-repo (assq-ref options 'mail-repo))
         (target-folder (format #f "~a~a/~a" mail-repo account end-dir))
         (uidvalidity (get-folder-uidvalidity target-folder)))
    (with-nm-database
     (ffi-db mail-repo 0)
     (with-nm-query
      (ffi-db to-move (format #f "~a and folder:~a/~a" query account start-dir))
      (display (string-append
                "[MOVE] "
                (number->string (nm-count-messages to-move))
                " messages marked in "
                account
                "\n"))
      (on-all-messages-filenames to-move (move-file uidvalidity target-folder))))))

(define (apply-tags-to-message options tags)
  (let ((dry-run? (option-ref options 'dry-run #f)))
    (lambda (message)
      (simple-format #t "  ~a~%" (nm-header message "subject"))
      (unless dry-run?
        (nm-apply-tags message tags)) #t)))

(define (log-msg-tag count rule new)
  (let* ((query-str (query-with-new rule new))
         (tags (tags-with-new rule new))
         (info (if (null? (cddr rule)) query-str (caddr rule))))
    (when (< 0 count)
      (simple-format #t " ~a messages: ~a~a~%"
                     count
                     (if (string=? info query-str) ""
                         (string-append info " | "))
                     tags))))

(define (notmuch-tag options ffi-db new)
  (lambda (rule)
    (let ((query-str (query-with-new rule new))
          (tags (tags-with-new rule new)))
      (with-nm-query
       (ffi-db query query-str)
       (log-msg-tag (nm-count-messages query) rule new)
       (nm-iter messages (nm-result-messages query) (apply-tags-to-message options tags))))))

(define (list-tag options ffi-db new)
  (display "[LISTS filters]\n")
  (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*)
            (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*)))
          (nm-iter messages (nm-result-messages query))
          (filter identity)
          length
          (simple-format #t " ~a messages belonging to lists~%")))))

(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 "[SPAM Flag]\n")
     (let ((spam? (spam-channel push result)))
       (with-nm-query
        (ffi-db query query-str)
        (->> (lambda (message)
               (when (spam? (pointer->string (notmuch_message_get_filename message)))
                 ((apply-tags-to-message options "+spam -inbox") message)))
             (nm-iter messages (nm-result-messages query))
             (filter boolean?)
             length
             (format #t " ~a messages added to spam~%")))))))

(define tag-rules
  (let* ((my-emails (list "hi@oscarnajera.com" "hello@oscarnajera.com" "najera.oscar@gmail.com"))
         (sent (format #f "(~{from:~a~^ OR ~}) AND NOT (~:*~{to:~a~^ OR ~})" my-emails)))
    `(("+sent" ,sent "Emails I have sent")
      ("+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")
      ("+slack" "from:slack.com")
      ("+immonews/communications" "from:nachrichten.immobilienscout24.de or subject:Kontaktaufnahme and tag:immonews")
      ("+ingrid" "from:postmaster@oscarnajera.com or from:root@oscarnajera.com" "Reports from ingrid")
      ("+Checkm-Alerts" "subject:Check_MK AND from:ingrid")
      ("+fail2ban" "subject:Fail2Ban from:oscarnajera.com" "Fail2ban report")
      ("+arsmagna +inbox" "to:arsmagna.xyz")

      ;; Toastmasters
      ("+NBG-toastmasters" "folder:/nbgtm/")
      ("+sent" "folder:\"/Google Mail]/Sent Mail/\"")
      ("+Isar-Speak" "to:isarspeak@gmail.com")
      ("+toastmasters" "toastmaster NOT from:info@meetup.com NOT from:linkedin.com" )

      ("+iohk" "from:iohk.io" "IOHK Plutus")
      ("+sms" "folder:hi_pers/SMS")
      ("+calls" "folder:hi_pers/Calls")
      ;; clearing up from newsletters
      ("+Indie-Hackers" "from:channing@indiehackers.com")
      ("+socialnews" "from:facebookmail.com or from:mail.instagram.com")
      ("+promotions" "from:newsletter")
      ("+linkedin +socialnews" "from:linkedin.com" "Linkedin")
      ("+meetups" "from:info@meetup.com or from:info@email.meetup.com" "Meetups info mails")
      ("+immonews" "from:immobilienscout24.de")
      ("+newsletter" "from:venturebeat.com")
      ("+zeihan" "from:zeihan.com")
      ("+freecodecamp" "from:freecodecamp.org")
      ;; byteplant
      ("+support" "to:support@byteplant.com")
      ("+admin" "to:admin@byteplant.com")
      ("+AV" "folder:/addressvalidator/")
      ("+EV" "folder:/addressvalidator/")
      ("+PV" "folder:/phonevalidator/")
      ("+sent" "folder:/Sent/"))))

(define (main args)
  (let* ((mail-repo (string-append
                     (passwd:dir (getpwuid (geteuid)))
                     "/.mail/" ))
         (my-emails (list "hi@oscarnajera.com" "hello@oscarnajera.com" "najera.oscar@gmail.com"))
         (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 (append (list (cons 'mail-repo mail-repo)
                                (cons 'my-emails my-emails))
                          (getopt-long args option-spec)))
         (account  (assq-ref options '()) ))
    (delete-email-files! options)

    (when (and (or (null? account) (and (string? account) (string=? account "hi_pers")))
               (access? (string-append mail-repo "hi_pers") W_OK))
      (move-mail! options "hi_pers" "tag:spam" "Inbox" "Junk"))


    (unless (option-ref options 'dry-run #f)
      (display "[SYNC]\n")
      (system (string-append "mbsync " (if (null? account) " -a" (car account))))
      (display "[notmuch new]\n")
      (system "notmuch new"))

    (with-nm-database
     (ffi-db mail-repo 'NOTMUCH_DATABASE_MODE_READ_WRITE)
     (let* ((new (not (option-ref options 'all #f)))
            (tagger (notmuch-tag options ffi-db new)))
       (display "[TAG rules]\n")
       (map  tagger tag-rules)
       (list-tag options ffi-db new)
       (display "[Inbox]\n")
       (tagger '("+inbox" "to:oscar@byteplant.com" "Inbox for the rest"))
       (tag-spam options ffi-db "tag:inbox")))))


;; Local Variables:
;; mode: scheme
;; End:
Mode	Name	Size
-rw-r--r--	borgbackup.el	3118	log stats plain
-rw-r--r--	cmk.el	11346	log stats plain
-rw-r--r--	journalctl.el	8409	log stats plain
-rw-r--r--	shepherd.el	2535	log stats plain