mailfilter-parse/mailfilter-parse.lisp

;;;;Copyright (c) 2015, Lily Carpenter
;;;;All rights reserved.
;;;;
;;;;Redistribution and use in source and binary forms, with or without modification,
;;;;are permitted provided that the following conditions are met:
;;;;
;;;;* Redistributions of source code must retain the above copyright notice, this
;;;;  list of conditions and the following disclaimer.
;;;;
;;;;* Redistributions in binary form must reproduce the above copyright notice, this
;;;;  list of conditions and the following disclaimer in the documentation and/or
;;;;  other materials provided with the distribution.
;;;;
;;;;* Neither the name of the Lily Carpenter nor the names of its
;;;;  contributors may be used to endorse or promote products derived from
;;;;  this software without specific prior written permission.
;;;;
;;;;THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
;;;;ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;;;WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;;;;DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR
;;;;ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;;;;(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
;;;;LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
;;;;ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;;;;(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;;;SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(defvar *commands* '("to"))
(defvar *maildir* nil)

;; This function is pretty ugly but I was tired when I wrote it and just wanted it to work.
;; TODO: Clean this up
(defun split-quoted (str)
  (let ((my-list nil)
        (my-string (make-array 0 :element-type 'character :fill-pointer 0 :adjustable t))
        (encountered-quote nil))
    (loop for c across str do
         (if (eq c #\")
             (setf encountered-quote (not encountered-quote)))
         (if (or (not (eq c #\Space)) encountered-quote)
             (vector-push-extend c my-string)
             (progn (setf my-list (append my-list (list my-string)))
                    (setf my-string (make-array 0 :element-type 'character :fill-pointer 0 :adjustable t)))))
    (setf my-list (append my-list (list my-string)))))

(defun empty-string? (str)
  (string= "" str))

(defun check-start (line expected seperator)
  (if (or (empty-string? line) (empty-string? seperator))
      nil
      (string= expected (first (split-sequence:split-sequence seperator line)))))

(defun test-for-maildir (line)
  (check-start line "MAILDIR" #\=))

(defun test-for-if (line)
  (check-start line "if" #\())

(defun test-for-end-if (line)
  (check-start line "}" #\newline))

(defun loop-file-until (s test-func worker-func hash)
  (loop for line = (read-line s nil)
        while (and line (not (funcall test-func line)))
        do
           (funcall worker-func s line hash)))

(defun convert-maildir-value (value)
  (pathname (remove #\" (cl-ppcre:regex-replace-all "\\${HOME}" value (namestring (user-homedir-pathname))))))

(defun set-maildir (line hash)
  (let ((maildir (convert-maildir-value (car (last (split-sequence:split-sequence #\= line))))))
    (setf (gethash "maildir" hash) maildir)
    (setf *maildir* maildir)))

(defun parse-line (s line hash)
  (if (test-for-if line)
      (read-mailfilter-if s line hash)
      (if (test-for-maildir line)
          (set-maildir line hash))))

(defun test-for-command (line)
  (member (first(split-quoted (string-trim '(#\Space #\Tab) line))) *commands* :test #'equal))

(defun clean-line (line)
  (let ((cleaned-line (string-trim '(#\Space #\Tab) line)))
    (cl-ppcre:regex-replace-all "\\$MAILDIR" cleaned-line (namestring *maildir*))))

(defun hash-add-command (line hash)
  (let* ((cleaned-line (clean-line line))
         (line-list (split-quoted cleaned-line)))
    (setf (gethash "command" hash) (first line-list))
    (setf (gethash "args" hash) (subseq line-list 1))
    hash))

(defun get-regex (line)
  (second (split-sequence:split-sequence #\/ line)))

(defun make-regex-hash (regex scanner)
  (let ((regex-hash (make-hash-table :test 'equal)))
    (setf (gethash "regex" regex-hash) (list regex scanner))
    regex-hash))

(defun parse-if-line (line hash)
  (if (test-for-if line)
      (let* ((regex (get-regex line))
             (scanner (cl-ppcre:create-scanner regex))
             (regex-hash (make-regex-hash regex scanner)))
        (setf (gethash "patterns" hash) (append (gethash "patterns" hash) (list regex-hash)))
        regex-hash)))

(defun parse-inner-if-line (s line hash)
  (declare (ignore s) )
  (if (test-for-command line)
      (hash-add-command line hash)))

(defun read-mailfilter-if (s line hash)
  (let ((if-hash (parse-if-line line hash)))
    (loop-file-until s #'test-for-end-if #'parse-inner-if-line if-hash)))

(defun read-mailfilter-file (file)
  (let ((hash (make-hash-table :test 'equal)))
    (with-open-file (s file)
      (loop-file-until s (lambda (x) (declare (ignore x)))  #'parse-line hash))
    hash))

(defun end-of-headers-p (line)
  (= (length line) 0))

(defun message-match (message pattern)
  (let* ((scanner (cadr (gethash "regex" pattern)))
         (regex (car (gethash "regex" pattern)))
         (sb-impl::*default-external-format* :latin-1)
         (test))
    (with-open-stream (message-stream (mel:message-header-stream message))
      (loop for line = (read-line message-stream nil)
            while (and line (not test) (not (end-of-headers-p line)))
            do
               (setf test (cl-ppcre:scan scanner line))))
    test))

(defun handle-command (command args message)
  (when (string= command "to")
    (let* ((pathname (pathname (concatenate 'string (remove #\" (car args)) "/")))
           (new-folder (mel:make-maildir-folder pathname :if-does-not-exist :create))
           (sb-impl::*default-external-format* :latin-1))
      (mel:move-message message new-folder))))

(defun handle-message (message patterns)
  (labels ((my-message-match (pattern) (message-match message pattern)))
    (let ((result (find-if #'my-message-match patterns)))
      (when result
        (let ((command (gethash "command" result))
              (args (gethash "args" result)))
          (handle-command command args message))))))

(defun filter-maildir-folder (mailfilter &optional src-folder)
  (let* ((mailfilter-rules (read-mailfilter-file mailfilter))
         (maildir (mel:make-maildir-folder (gethash "maildir" mailfilter-rules)))
         (src-folder (if src-folder
                         (mel:make-maildir-folder src-folder)
                         maildir))
         (patterns (gethash "patterns" mailfilter-rules))
         (messages (mel:messages src-folder)))
    (dolist (message messages)
      (handle-message message patterns))))