mailfilter-parse/parse-mailfilter.lisp

;;;;Copyright (c) 2013, 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.

(require :asdf)
(require :sigma)
(sigma:use-all-sigma)

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

; Thanks to http://cl-cookbook.sourceforge.net/strings.html#manip
(defun replace-all (string part replacement &key (test #'char=))
"Returns a new string in which all the occurences of the part
is replaced with replacement."
    (with-output-to-string (out)
      (loop with part-length = (length part)
            for old-pos = 0 then (+ pos part-length)
            for pos = (search part string
                              :start2 old-pos
                              :test test)
            do (write-string string out
                             :start old-pos
                             :end (or pos (length string)))
            when pos do (write-string replacement out)
            while pos)))

; 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 line seperator)))))

(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 "}" "\n"))

(defun loop-file-until (s test-func worker-func hash)
  (loop for line = (read-line s nil 'eof) do
            (if (eq line 'eof)
                nil
                (funcall worker-func s line hash))
            until (or (eq line 'eof) (funcall test-func line))))

(defun convert-maildir-value (value)
  (remove #\" (replace-all value "${HOME}" (to-string (user-homedir-pathname)))))

(defun set-maildir (line hash)
  (let ((maildir (convert-maildir-value (car (last (split line "="))))))
  (sethash "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)))
           (replace-all cleaned-line "${MAILDIR}" *maildir*)))

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

(defun get-regex (line)
  (second (split line "/")))

(defun make-regex-hash (regex)
  (let ((regex-hash (make-hash-table :test 'equal)))
       (sethash "regex" regex-hash regex)
       regex-hash))

(defun parse-if-line (line hash)
  (if (test-for-if line)
      (let* ((regex (get-regex line))
             (regex-hash (make-regex-hash regex)))
                (sethash "patterns" hash (append (gethash "patterns" hash) (list regex-hash)))
                regex-hash)))

(defun parse-inner-if-line (s line hash)
  (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) nil)  #'parse-line hash))
    hash))