(define-module (imap))

(use-modules (rnrs bytevectors))
(use-modules (ice-9 binary-ports))
(use-modules (ice-9 iconv))
(use-modules (ice-9 rdelim))
(use-modules (ice-9 textual-ports))
(use-modules ((rnrs io ports)
              #:prefix rnrs-ports:))
(use-modules (gnutls))

(define current-http-proxy
  (make-parameter (let ((proxy (getenv "http_proxy")))
                    (and (not (equal? proxy ""))
                         proxy))))

(define (tls-wrap port server)
   "Return PORT wrapped in a TLS connection to SERVER.  SERVER must be a DNS
host name without trailing dot."
   (define (log level str)
     (format (current-error-port)
             "gnutls: [~a|~a] ~a" (getpid) level str))

   (let ((session (make-session connection-end/client)))
     ;; Some servers such as 'cloud.github.com' require the client to support
     ;; the 'SERVER NAME' extension.  However, 'set-session-server-name!' is
     ;; not available in older GnuTLS releases.  See
     ;; <http://bugs.gnu.org/18526> for details.
     (set-session-server-name! session server-name-type/dns server)
     (set-session-transport-fd! session (fileno port))
     (set-session-default-priority! session)

     ;; The "%COMPAT" bit allows us to work around firewall issues (info
     ;; "(gnutls) Priority Strings"); see <http://bugs.gnu.org/23311>.
     ;; Explicitly disable SSLv3, which is insecure:
     ;; <https://tools.ietf.org/html/rfc7568>.
     (set-session-priorities! session "NORMAL:%COMPAT:-VERS-SSL3.0")

     (set-session-credentials! session (make-certificate-credentials))

     ;; Uncomment the following lines in case of debugging emergency.
     ;;(set-log-level! 10)
     ;;(set-log-procedure! log)

     (handshake session)
     (let ((record (session-record-port session)))
       (define (read! bv start count)
         (define read-bv (get-bytevector-some record))
         (if (eof-object? read-bv)
             0  ; read! returns 0 on eof-object
             (let ((read-bv-len (bytevector-length read-bv)))
               (bytevector-copy! read-bv 0 bv start (min read-bv-len count))
               (when (< count read-bv-len)
                 (unget-bytevector record bv count (-  read-bv-len count)))
               read-bv-len)))
       (define (write! bv start count)
         (put-bytevector record bv start count)
         (force-output record)
         count)
       (define (get-position)
         (rnrs-ports:port-position record))
       (define (set-position! new-position)
         (rnrs-ports:set-port-position! record new-position))
       (define (close)
         (unless (port-closed? port)
           (close-port port))
         (unless (port-closed? record)
           (close-port record)))
       (setvbuf record 'block)
       (make-custom-binary-input/output-port "gnutls wrapped port"
                                             read!
                                             write!
                                             get-position set-position!
                                             close))))
(define (%connect-to-server host port)
  (let ((addrinfo (car (getaddrinfo host (number->string port)))))
    (let ((port (socket (addrinfo:fam addrinfo)
                        SOCK_STREAM
                        IPPROTO_IP)))
      (connect port (addrinfo:addr addrinfo))
      (tls-wrap port host))))

(define (end-of-command line)
  (string-prefix? "azul" line))

(define (maybe-throw string)
  (unless (string-prefix? "azul OK" string)
    (throw 'imap-error (string-drop string (string-length "azul ")))))

(define-public (imap-connect-to-server host port)
  "Connect to imap server found at HOST on PORT, and return the scheme
port to use to communicate with that server"
  (let ((port (%connect-to-server host port)))
    (pk 'welcome (get-line port))
    port))

(define (get-output port)
  (let loop ((line (string-trim-right (get-line port)))
             (out '()))
    (if (end-of-command line)
        (begin
          (maybe-throw line)
          out)
          (loop (string-trim-right (get-line port)) (cons line out)))))

(define-public (imap-capability port)
  "Return the list of capability"
  (put-string port "azul CAPABILITY\r\n")
  (let ((out (get-output port)))
    (string-split (string-drop (car out) (string-length "* CAPABILITY ")) #\space)))

(define-public (imap-noop port)
  "Does NOOP that is all"
  (put-string port "azul NOOP\r\n")
  (get-output port))

(define-public (imap-logout port)
  "Logout and close the port"
  (put-string port "azul LOGOUT\r\n")
  (get-output port)  ;; why is this useful I don't know
  (close port))

(define-public (imap-login port username password)
  "Login using USERNAME and PASSWORD"
  (format port "azul LOGIN ~s ~s\r\n" username password)
  (get-output port))

(define-public (imap-select port mailbox)
  "Select MAILBOX"
  (format port "azul SELECT ~s\r\n" mailbox)
  (get-output port))

(define-public (imap-create port mailbox)
  "Create MAILBOX"
  (format port "azul CREATE ~s\r\n" mailbox)
  (get-output port))

(define-public (imap-delete port mailbox)
  "Delete MAILBOX"
  (format port "azul DELETE ~s\r\n" mailbox)
  (get-output port))

(define-public (imap-rename port old new)
  "Rename mailbox named OLD to NEW"
  (format port "azul RENAME ~s ~s\r\n" old new)
  (get-output port))

;; (define-public (imap-append port mailbox)
;;   "The APPEND command appends the literal argument as a new message to
;; the end of the specified destination mailbox."
;;   )

(define-public (imap-close port)
  (put-string port "azul CLOSE\r\n")
  (get-output port))

;; (define-public (imap-search port

(define port (imap-connect-to-server "imap.gmail.com" 993))

(pk (imap-capability port))
(pk (imap-noop port))
(pk (imap-login port login password))
(pk (imap-select port "INBOX"))
(pk (imap-logout port))