[Gauche] rfc.pop

GaucheでSMTPを扱うコードは見かけるんですが(Gauche:メール, GaucheでSMTPクライアントを書いてみる(1))、POP3は見たことがなかったので、クライアントライブラリを書きました。多くの手続きはRFC1939の各コマンドに一対一で対応したものですが、call-with-pop3-connectionのようにやや高水準の手続きもあります。

(use rfc.822)
(use rfc.mime)
(use rfc.pop)

;; 各メールのSubjectを表示
(call-with-pop3-connection "pop.example.com"
  (lambda (conn)
    (for-each (lambda (msgnum)
                (let* ([str (pop3-top conn msgnum 0)]
                       [hdrs (call-with-input-string str rfc822-read-headers)])
                  (if-let1 subject (rfc822-header-ref hdrs "subject")
                    (format #t "~d: ~a\n" msgnum (mime-decode-text subject))
                    (format #t "(no subject)\n"))))
              (map car (pop3-list conn))))
  :username "your_username"
  :password "your_password")

残念ながらPOP over SSLには対応していないので、SSLを使うにはstunnelなどのトンネリングツールを使います。以下はちょっと長いですが、スクリプト内からstunnel4を使う例です。信用できる証明書が/etc/ssl/certsにあると仮定しています。

(use file.util)
(use gauche.process :only (run-process))
(use rfc.pop :only (call-with-pop3-connection))
(use srfi-27)

(define (main args)
  (unless (= (length args) 3)
    (format #t "Usage: gosh ~a host port\n" *program-name*)
    (exit 1))
  (let ([host (cadr args)]
        [port (caddr args)])
    (call-with-ssl-connection (string-append host ":" port)
     (lambda (port)
       (call-with-pop3-connection #`"localhost:,port"
         (lambda (conn)
          ;; POP3サーバ接続時のメッセージを表示
           (print (~ conn'greeting))))))))

(define (call-with-ssl-connection host:port proc)
  (define (write-config remote local)
    (current-directory (temporary-directory))
    (receive (out path) (sys-mkstemp "myssl-")
      (let1 pid-path (build-path (temporary-directory) #`",|path|.pid")
        (for-each (^s (display s out) (newline out))
                  (list #`"pid = ,pid-path"
                        "foreground = no"
                        "client = yes"
                        "[pop_over_ssl]"
                        "verify = 2"
                        "CApath = /etc/ssl/certs"
                        #`"connect = ,remote"
                        #`"accept = ,local"))
        (close-output-port out)
        (values path pid-path))))
  (define (cleanup config-path pid-path)
    (sys-kill (string->number (car (file->string-list pid-path))) SIGTERM)
    (remove-files (list config-path pid-path)))

  (let1 local-port (begin (random-source-randomize! default-random-source)
                          (+ 10000 (random-integer 1000)))
    (or (and-let* ([stunnel4 (find-file-in-paths "stunnel4")])
          (receive (config-path pid-path)
            (write-config host:port local-port)
            (if (zero? (sys-fork))
              (run-process `(,stunnel4 ,config-path) :fork #f)
              (dynamic-wind
                (lambda ()
                  (define (try count)
                    (cond [(file-exists? pid-path)]
                          [(> count 10) (error "something wrong")]
                          [else (sys-sleep 1) (try (+ count 1))]))
                  (try 0))
                (lambda () (proc local-port))
                (lambda () (cleanup config-path pid-path))))))
        (error "command not found: stunnel4"))))

インストール

Gauche 0.9.1以降で動きます。

# gauche-package install http://github.com/downloads/teppey/Gauche-rfc-pop/Gauche-rfc-pop-0.1.tgz

もしくは git cloneしてください。

# git clone git://github.com/teppey/Gauche-rfc-pop.git
# cd Gauche-rfc-pop
# ./DIST gen
# ./configure
# make
# make -s check
# make install

現在ではIMAPやWebメールが一般的となりましたが、YahooメールやGmailでもPOP3サーバへのアクセスを提供していますし、もうしばらくはPOP3プロトコルの出番がありそうです。