;;;; simple_list.lisp
 
 (in-package #:simple_list)
 
 ;;; "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)
     `(defmacro ,name (() &body ,body)
        (let ((var ',var) (value-form ',value-form))
          `(let ((,var ,@value-form))
             ,@,body)))))
 

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

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

 (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

           (parse-search (cmd-search *imap-socket* :criteria "(recent unseen)" :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 uid)))

     (mapcar (lambda (x)
               (make-bodystructure
                 (parse-bodystructure

                   (getf x :bodystructure))))
             headers)))

 
 (defun get-raw-message (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)))
 
 (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))))
 
 
 (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 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 (string-to-list-name (email-to-list to)))

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

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