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