;;;; simple_list.lisp

(in-package #:simple_list)

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