new file mode 100644

@@ -0,0 +1,2 @@

+.*.sw[a-z]

+

@@ -1,5 +1,6 @@

 ;;;; package.lisp

 (defpackage #:simple_list

-  (:use #:cl))

+  (:use #:cl #:anaphora #:alexandria #:serapeum)

+  (:export :main))

@@ -9,6 +9,7 @@

                #:alexandria

                #:anaphora

                #:serapeum

+               #:ubiquitous

                #:fwoar.lisputils)

   :serial t

   :components ((:file "package")

@@ -4,3 +4,139 @@

 ;;; "simple_list" goes here. Hacks and glory await!

+(defvar *imap-socket*)

+

+(defmacro define-special-variable-wrapper (name var &body value-form)

+  (alexandria:with-gensyms (body)

+    `(defmacro ,name (() &body ,body)

+       (let ((var ',var) (value-form ',value-form))

+         `(let ((,var ,@value-form))

+            ,@,body)))))

+

+(defmacro aprogn (&body body)

+  `(let*

+     ,(loop for el in body

+            collect `(it ,el))

+     it))

+

+(defun get-connection-spec ()

+  (clonsigna:make-imap :host (ubiquitous:value 'imap 'host)

+                       :port (ubiquitous:value 'imap 'port)

+                       :ssl-p (ubiquitous:value 'imap 'ssl-p)))

+

+(define-special-variable-wrapper with-connection *imap-socket* (get-connection-spec))

+

+(defun connect-toplevel ()

+  (setf *imap-socket* (get-connection-spec)))

+

+(defun connect-and-authorize (auth-info)

+  (clonsigna:cmd-connect *imap-socket*)

+  (clonsigna:cmd-login *imap-socket* (car auth-info) (cdr auth-info)))

+

+

+(defun get-mailbox (name)

+  (cmd-select *imap-socket* name)

+  (mapcar #'princ-to-string

+          (alexandria:flatten

+            (parse-thread (cmd-thread *imap-socket* :uid-p t)))))

+

+(defun get-inbox ()

+  (get-mailbox "inbox"))

+

+(defun get-headers (uid)

+  (parse-fetch-fields (cmd-fetch-fields *imap-socket* uid)))

+

+(defun get-bodystructures (uid)

+  (let ((headers (get-headers x)))

+    (mapcar (lambda (x)

+              (make-bodystructure

+                (parse-bodystructure

+                  (getf x :bodystructure)))))))

+

+(defun get-raw-message (uid)

+  (let* ((message (split-sequence #\Newline (car (cmd-fetch-body uid))))

+         (message-without-imap (slice message 0 -1)))

+    (string-join message-without-imap #\Newline)))

+

+(defun get-message (uid)

+  (let* ((bodystructures (get-bodystructures uid))

+         (bodies (flatten (mapcar #'bodystructure-body-list bodystructures)))

+         (sections (flatten (mapcar #'structure-element-section bodies)))

+         (charsets (flatten (mapcar (fw.lu::alambda

+                                      (cadr (structure-element-body-parameters it)))

+                                    bodies))))

+    (parse-fetch-body

+      (car (cmd-fetch-body *imap-socket* uid :section sections :uid-p t))

+      :charset (car charsets))))

+

+(defvar *mailing-list*)

+

+(defun lookup-list (list-name &optional (lookup-table *mailing-list*))

+  (cdr (assoc list-name lookup-table)))

+

+(defun email-to-list (email)

+  (aprogn

+    (car (split-sequence #\@ email :count 1))

+    (car (split-sequence #\- it    :count 1 :from-end t))))

+

+(defun peek-headers (uid)

+  (cmd-fetch *imap-socket* uid

+             :criteria (format nil "(~{~a ~}BODY.PEEK[header.fields (~{~a ~})])"

+                               '(uid flags bodystructure)

+                               '(date from to cc bcc subject message-id in-reply-to references))

+             :uid-p t))

+

+(defun send-to-list (list-name from subject message host auth-info)

+  (destructuring-bind (recipients . other-headers) (lookup-list list-name)

+    (destructuring-bind (user . password) auth-info

+      (apply #'cl-smtp:send-email

+             (list* host

+                    from

+                    recipients

+                    subject

+                    message

+                    :ssl t

+                    :port 587

+                    :authentication `(,user ,password)

+                    other-headers)))))

+

+(defun get-message-envelope-info (uid)

+  (let* ((envelope (car (parse-fetch-fields (peek-headers uid))))

+         (headers (getf envelope :headers))

+         )

+    (values (getf headers :to)               ; To

+            (getf headers :from)             ; From

+            (getf headers :subject)             ; From

+            (getf envelope :flags)           ; Message Flags

+            (getf envelope :bodystructure)   ; Message bodystructure

+            headers                          ; Message headers

+            envelope)))                      ; Envelope info

+

+(defun process-imap-message (uid host auth-info)

+  (multiple-value-bind (to from subject flags) (get-message-envelope-info uid)

+    (unless (member 'seen flags)

+      (let* ((list-name (aprogn (email-to-list to)

+                                (string-upcase it)

+                                (make-keyword it)))

+             (body (get-message uid)))

+        (send-to-list list-name from subject body host auth-info)))))

+

+(defun process-imap-mailbox (name host auth-info)

+  (let ((uids (get-mailbox name)))

+    (mapcar (lambda (x) (process-imap-message x host auth-info)) uids)))

+

+(defun process-inbox (host auth-info)

+  (process-imap-mailbox "inbox" host auth-info))

+

+(define-special-variable-wrapper with-mailing-lists *mailing-list* (ubiquitous:value 'mailing-lists))

+

+(defun main ()

+  (ubiquitous:restore 'simple_list)

+

+  (let ((auth-info (cons (ubiquitous:value 'auth 'user)

+                         (ubiquitous:value 'auth 'password))))  

+    (with-connection ()

+      (with-mailing-lists ()

+        (connect-and-authorize auth-info)

+        (get-inbox)

+        (process-inbox (ubiquitous:value 'imap 'host) auth-info)))))