@@ -1,2 +1,3 @@

 .*.sw[a-z]

+simple_list

@@ -1 +1 @@

-This is the stub README.txt for the "simple_list" project.

+A simple mailing list platform

deleted file mode 100755

Binary files a/simple_list and /dev/null differ

@@ -10,7 +10,8 @@

                #:anaphora

                #:serapeum

                #:ubiquitous

-               #:fwoar.lisputils)

+               #:fwoar.lisputils

+               #:manardb)

   :serial t

   :components ((:file "package")

                (:file "simple_list")))

@@ -5,6 +5,33 @@

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

 (defvar *imap-socket*)

+(defvar *mailing-list*)

+

+(defclass <mailing-list> ()

+  ((name :initform nil :initarg :name :accessor ml-name)

+   (emails :initform nil :initarg :name :accessor ml-emails)))

+

+(manardb:defmmclass <persistent-mailing-list> ()

+  ((name :initform nil :initarg :name :accessor ml-name)

+   (emails :initform nil :initarg :emails :accessor ml-emails)) )

+

+(defmethod print-object ((obj <persistent-mailing-list>) s)

+  (print-unreadable-object (obj s :type t :identity t)

+    (format s "~a with ~d emails" (ml-name obj) (length (ml-emails obj)))))

+

+(defun make-mailing-list (name &optional persistent)

+  (aprog1 (make-instance '<persistent-mailing-list>)

+    (setf (slot-value it 'name)

+          (make-keyword

+            (ctypecase name

+              (string (string-to-list-name name))

+              (symbol name))))))

+

+(defmacro aprogn (&body body)

+  `(let*

+     ,(loop for el in body

+            collect `(it ,el))

+     it))

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

   (alexandria:with-gensyms (body)

@@ -13,48 +40,55 @@

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

             ,@,body)))))

-(defmacro aprogn (&body body)

-  `(let*

-     ,(loop for el in body

-            collect `(it ,el))

-     it))

+(eval-when (:compile-toplevel :load-toplevel :execute)

+  (defun get-connection-spec ()

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

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

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

-(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))

+(define-special-variable-wrapper with-mailing-lists *mailing-list*

+  ((manardb:retrieve-all-instances '<persistent-mailing-list>))

+  )

-(defun connect-toplevel ()

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

+(defmacro insert-imap-socket (&body body)

+  (list* 'progn

+         (loop for cmd in body

+               collect (list* (car cmd) '*imap-socket* (cdr cmd)))))

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

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

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

+(defmacro with-authorized-connection ((auth-info)  &body body)

+  `(with-connection ()

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

+     ,@body))

+

+(defun connect-toplevel ()

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

 (defun get-mailbox (name)

   (cmd-select *imap-socket* name)

   (mapcar #'princ-to-string

-          (alexandria:flatten

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

+          (parse-search (cmd-search *imap-socket* :criteria "(recent unseen)" :uid-p t))))

-(defun get-inbox ()

-  (get-mailbox "inbox"))

+(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)))

+  (let ((headers (get-headers uid)))

     (mapcar (lambda (x)

               (make-bodystructure

                 (parse-bodystructure

-                  (getf x :bodystructure)))))))

+                  (getf x :bodystructure))))

+            headers)))

 (defun get-raw-message (uid)

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

+  (let* ((message (split-sequence #\Newline (car (cmd-fetch-body *imap-socket* uid :uid-p t))))

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

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

@@ -62,14 +96,13 @@

   (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

+         (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)))

@@ -112,12 +145,15 @@

             headers                          ; Message headers

             envelope)))                      ; Envelope info

+(defun string-to-list-name (name-string)

+  (aprogn name-string

+          (string-upcase it)

+          (make-keyword it)))

+

 (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)))

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

              (body (get-message uid)))

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

@@ -128,15 +164,48 @@

 (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 ()

+(defun get-auth-info ()

+  (cons (ubiquitous:value 'auth 'user)

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

+

+(define-condition simple-list-error () ()

+  (:documentation "The base condition for exceptions thrown by this utility"))

+

+(define-condition no-such-list (simple-list-error)

+  ((list-name :initarg :name :accessor ml-name))

+  (:report (lambda (c s) (format s "No list named ~a" (ml-name c)))))

+

+(defgeneric add-email (mailing-list email)

+  (:method :around (mailing-list email)

+   (let ((result (call-next-method)))

+     (typecase mailing-list

+       (symbol result)

+       (t mailing-list))))

+

+  (:method ((mailing-list <persistent-mailing-list>) email)

+   (with-slots (emails) mailing-list

+     (unless (member email emails :test #'equalp)

+       (push email emails))))

+

+  (:method ((list-name symbol) email)

+   (let ((lists (remove-if-not

+                  (fw.lu:alambda (eq list-name (ml-name it)))

+                  (manardb:retrieve-all-instances '<persistent-mailing-list>))))

+     (if-let ((mailing-list (car lists)))

+       (add-email mailing-list email)

+       (error 'no-such-list :name list-name)))))

+

+(defun add-email-to-list (list-name email)

+  (restart-case

+    (add-email list-name email)

+    (make-list () (add-email (make-mailing-list list-name) email))))

+

+(defun main (&optional argv)

   (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)))))

+  (let ((auth-info (get-auth-info))

+        (host-name (ubiquitous:value 'imap 'host)))  

+    (with-mailing-lists ()

+      (format t "Connecting to server ~a" host-name)

+      (with-authorized-connection (auth-info)

+        (setf +debug+ t)

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