Re: IMAP SSL Connection using Guile

[Amirouche Boubekki <amirouche.boubekki@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 971 bytes --]

On Tue, May 2, 2017 at 9:47 PM Andy Wingo <wingo@pobox.com> wrote:

> On Sun 30 Apr 2017 18:42, Amirouche <amirouche@hypermove.net> writes:
>
> > I am trying to connect to an imap server using SSL but it fails. The
> > program does
> > indeed connect to the remote server, but when I try to read on the
> > port it blocks
> > until the connection is closed by the remote host.
> >
> > Everything works fine using gnutls-cli.
> >
> > The version reported by gnutls-cli is 3.5.8
>
> I believe this was fixed in Guile master:
> 0c102b56e98da39b5a3213bdc567a31ad8ef3e73.  Make appropriate changes to
> your copy of tls-wrap :)
>

Tx! It works!

I have a very basic IMAP implementation (without IDLE extensions (which
would avoid the need to poll the server)) but it miss some "verbs" like
the  ability to look up messages by unique identifier UID. What is missing
is explained in that part https://tools.ietf.org/html/rfc3501#section-6.4.8

Thanks again for taking the time.

[-- Attachment #2: imap.scm --]
[-- Type: text/x-scheme, Size: 5819 bytes --]

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