GaucheでSMTPクライアントを書いてみる(2) STARTTLS、AUTH

すっかり忘れていたGaucheでSMTPクライアントを書いてみる(1)の続き。

  • STARTTLS コマンド (SSL/TLSによる通信)
  • AUTH コマンド (クライアント認証)

に対応させた。ただしAUTHコマンドで対応しているのは、AUTH PLAINとAUTH LOGINだけ。
SSL/TLSへの対応には、OpenSSLライブラリとc-wrapperを利用した。OpenSSLライブラリを使ってプログラミング(1)でも書いたけど、c-wrapperが0.6.0よりも前のものだとOpenSSLライブラリのヘッダファイルをうまく処理できないかもしれない。

STARTTLS コマンド

STARTTLSコマンドは、それ以後の通信をSSL/TLSでおこなうようにサーバに伝えるコマンド。拡張機能なので全てのSMTPサーバが対応しているわけではない。
STARTTLSはクライアントとサーバとのやりとりを暗号化させるだけで、その先については関知していない。したがって、メールが別のメールサーバに中継/転送されるような場合、その部分の通信は暗号化されていないと思ったほうがよい。当然、メールボックスに保存されたメールの暗号化やメールボックスからの取り寄せ(POP、IMAP)の暗号化も、STARTTLSの対象外。メールの内容を秘匿したい場合は別の考慮が要る。


SSL/TLSを使わずにSMTPでメールを送信するときの流れは次のような感じだった。

送信                       受信コード
                           220
EHLO 送り手側のドメイン -> 250

MAIL FROM: アドレス     -> 250
RCPT TO: アドレス       -> 250
必要なら RCPT TO: ... を繰り返す。
DATA                    -> 354
メール本文(ヘッダ含む)を送る
(行頭のピリオドはエスケープする)
.                       -> 250
QUIT                    -> 221

SSL/TLSを使う場合は次のようになる。

                           220
EHLO 送り手側のドメイン -> 250
EHLOに対する応答を見て、STARTTLS拡張に対応していることを確認。
STARTTLS                -> 220
SSL/TLSハンドシェイクをおこなう。
ハンドシェイク成功。以下、SSL/TLSの暗号化のもとで通信する。
EHLO 送り手側のドメイン -> 250
MAIL FROM: アドレス     -> 250
以下省略

HTTPSとは違い、接続していきなりSSL/TLSハンドシェイクをするのではない。

AUTH コマンド

AUTHコマンドは、送信側(クライアント側)の認証をおこなうためのコマンド。スパムの送信・中継をおこなうのを防ぐのが主な目的みたい。
拡張機能なので対応していないサーバもある。認証をしないとそもそもメールトランザクションがおこなえないサーバもあれば、認証なしの場合は他のサーバにメールを中継するのは拒否するものもある。いろいろあるみたい。
AUTHで認証する場合、PLAIN、LOGIN、CRAM-MD5、DIGEST-MD5などいくつかの認証方式があって、どれに対応しているかはEHLOコマンドに対する返事で示される。
ここではPLAINとLOGINだけを扱うことにする。これらはどちらもパスワードをそのまま(Base64エンコードしただけで)相手に送って認証をおこなう。なのでたぶん暗号化との併用を前提とした認証方式。AUTH PLAINもSTARTTLSも、どちらもRFC 2595で定められてるみたいだし。

PLAIN による認証

PLAINで認証をおこなう場合、AUTH PLAINの後ろに「\0ユーザid\0パスワード」(または「ユーザid\0ユーザid\0パスワード」)をBase64エンコードしたものをつけてサーバに送る。認証が成功すれば、応答コード235が返ってくる。

AUTH PLAIN \0ユーザid\0パスワード をBase64でエンコードしたもの -> 235
LOGIN による認証

LOGINを用いる場合、相手サーバと

クライアント「AUTH LOGIN」
サーバ「Username:」
クライアント「ユーザid」
サーバ「Password:」
クライアント「********」

のようなやりとりをして認証をおこなう。ただし「Username:」以降の部分は全てBase64エンコードされたものを送受信している。最終的に認証が成功すれば、応答コード235が返ってくる。

AUTH LOGIN                             -> 334 (+「Username:」)
ユーザidをBase64でエンコードしたもの   -> 334 (+「Password:」)
パスワードをBase64でエンコードしたもの -> 235

プログラムの概要

STARTTLSとAUTHに対応させたプログラムの動作はこんな感じにした。

  1. サーバがSTARTTLSに対応していない場合。そのままメールを送る。
  2. 対応しているなら、STARTTLSを送りSSL/TLSで通信する。
  3. 信頼する認証機関の証明書が指定してある場合、サーバの証明書を検証する。検証に失敗したら通信を終える。指定してない場合は検証をおこなわず通信を続ける。
  4. 認証用ユーザ名が指定してあってサーバがAUTHに対応している場合、AUTHコマンドでクライアント認証をおこなう。そうでなければAUTHコマンドは使わない。
設定する項目

設定する項目が多くなった。

  • host: サーバのアドレス(デフォルト: localhost)
  • port: ポート番号(デフォルト: 587)
  • from: 送る側のメールアドレス。適当なアドレスでもメールは送れるみたい。
  • to: 送り相手のメールアドレス。複数指定可。
  • source: 送りたいメール内容を含んでいるファイル。メールヘッダも含んでいること。ヘッダと本文の間は空行を一行入れる。
  • helo-domain: EHLOコマンドで送るサーバ名。実際に存在するサーバかどうかを相手サーバがチェックしている場合があるので、そういう場合に設定する。
  • ca-file: 信頼する認証機関の証明書を含んでいるファイルを指定。
  • ca-path: 信頼する認証機関の証明書を含んだファイルが置かれたディレクトリを指定する。ca-fileとca-pathで指定するファイルとディレクトリの形式は、OpenSSLライブラリを使ってプログラミング(3)の「SSL_CTX_load_verify_locations()の第2引数と第3引数」の辺りで書いたのと同じ形式で。
  • auth-user: クライアント認証で使うユーザid。

コマンドラインで指定すると、こんな感じになる。

gosh smtp_tls_auth.scm --host=some_smtp_server --to=to@foo.bar.baz.com \
--source=sample_mail --ca-path=ca_dir --auth-user=my_id

Gaucheのプログラム

もう少し綺麗にならないものかと思うのだけど。

#!/usr/bin/env gosh
(use gauche.net)
(use gauche.vport) ; <buffered-input-port> <virtual-output-port>
(use gauche.uvector) ; <u8vector>
(use rfc.base64) ; base64-encode-string
(use srfi-1) ; any
(use gauche.parseopt)
(use gauche.termios) ; パスワード入力用
(use c-wrapper)

(c-load "openssl/ssl.h" :libs "-lssl -lcrypto")
(SSL_library_init)

;;; SSL/TLSのための関数群
(define (call-with-ssl-context proc)
  (let1 ctx (SSL_CTX_new (SSLv23_method))
    (SSL_CTX_set_options ctx SSL_OP_NO_SSLv2)
    (proc ctx)
    (SSL_CTX_free ctx)))

(define (call-with-ssl-client-connection ctx socket proc)
  (let* ((ssl (SSL_new ctx))
         (succ-set-fd? (SSL_set_fd ssl (socket-fd socket)))
         (succ-connect? (SSL_connect ssl)))
    (proc ssl)
    (SSL_shutdown ssl)
    (SSL_free ssl)))

(define (make-ssl-input-port ssl)
  (make <buffered-input-port>
    :fill
    (lambda (u8vec)
      (let* ((buf-size (u8vector-length u8vec))
             (buffer (make (c-array <c-char> buf-size)))
             (read-size (SSL_read ssl buffer buf-size))
             (u8buffer (cast <u8vector> buffer)))
        (u8vector-copy! u8vec 0 u8buffer 0 read-size)
        read-size))))

(define (make-ssl-output-port ssl)
  (make <virtual-output-port>
    :putb
    (lambda (b)
      (SSL_write ssl (ptr (cast <c-uchar> b)) 1))))
;;; 1バイトごとにSSL_writeを呼んでいるけど、これで問題ないのかちょっと不安。
;;; virtual-output-portの代わりにbuffered-output-portを使った場合、
;;; 適宜 (flush port) する必要がある。

;;; 一応buffered-output-port版。
(define (make-ssl-buffered-output-port ssl)
  (make <buffered-output-port>
    :flush
    (lambda (u8vec flag)
      (SSL_write ssl (cast <c-ptr> u8vec) (u8vector-length u8vec)))))


;;; 証明書の表示と検証のための関数群
;;; この辺の関数は、OpenSSLライブラリを使ってプログラミング(1)(3)で
;;; 書いたものそのままかちょっと変更しただけ。
(define (print-certificate-chain ssl)
  (define cert-chain (SSL_get_peer_cert_chain ssl))
  (let loop ((cert (sk_X509_shift cert-chain)))
    (when (not (null-ptr? cert))
      (print-subject-and-issuer cert)
      (loop (sk_X509_shift cert-chain))
      (X509_free cert))))

(define (print-subject-and-issuer cert)
  (format #t "\nSubject:~a\n" (name-string (X509_get_subject_name cert)))
  (format #t "Issuer: ~a\n" (name-string (X509_get_issuer_name cert))))

(define (name-string name)
  (define mem (BIO_new (BIO_s_mem)))
  (define p (make (ptr <c-uchar>)))

  (X509_NAME_print_ex mem name 0 XN_FLAG_RFC2253)
  (BIO_write mem "\0" 1)
  (BIO_get_mem_data mem (ptr p))
  (begin0
    (cast <string> p)
    (BIO_free mem)))

(define (verify-certificate ssl)
  (cond ((or (not (peer-certificate-received? ssl))
             (not (peer-certificate-verified? ssl)))
         (print "\nPeer certificate verification failed.")
         (exit 0))
        (else (print "\nPeer certificate verification successful."))))

(define (peer-certificate-received? ssl)
  (let1 cert (SSL_get_peer_certificate ssl)
    (cond ((null-ptr? cert) #f)
          (else (X509_free cert) #t))))

(define (peer-certificate-verified? ssl)
  (zero? (SSL_get_verify_result ssl)))


;;; smtp処理用関数群
;;; 「GaucheでSMTPクライアントを書いてみる(1)」のプログラムに追加・変更
(define (send-mail host port source mail-from mail-tos . options)
  (let-keywords options ((helo-domain (sys-gethostname))
                         (ca-file (make-null-ptr))
                         (ca-path (make-null-ptr))
                         (auth-user #f)
                         (auth-password #f))
    (define socket (make-client-socket 'inet host port))
    (define recipients mail-tos)
    (define verify-certificate? (or (not (null-ptr? ca-file))
                                    (not (null-ptr? ca-path))))

    (call-with-client-socket socket
      (lambda (in out)
        (send-and-receive in out #f 220)
        (let/cc break
          (let1 lines (send-and-receive in out #`"EHLO ,|helo-domain|" 250)
            (when (not (support-starttls? lines))
              (mail-transaction-and-quit source mail-from mail-tos in out)
              (break))

            ;; STARTTLS 対応
            (send-and-receive in out "STARTTLS" 220)
            (call-with-ssl-context (lambda (context)
              (when verify-certificate?
                (SSL_CTX_load_verify_locations context ca-file ca-path))
              (call-with-ssl-client-connection context socket (lambda (ssl)
                (print "Received certificate chain is")
                (print-certificate-chain ssl)
                (cond (verify-certificate? (verify-certificate ssl))
                      (else (print "\nPeer certification not verified")))
                (let ((in  (make-ssl-input-port ssl))
                      (out (make-ssl-output-port ssl)))
                  (let1 lines (send-and-receive in out
                                #`"EHLO ,|helo-domain|" 250)

                    ;; AUTH PLAIN LOGIN 
                    (when (and auth-user auth-password)
                      (cond ((support-auth-plain? lines)
                             (auth-plain in out auth-user auth-password))
                            ((support-auth-login? lines)
                             (auth-login in out auth-user auth-password))))
                    (mail-transaction-and-quit
                      source mail-from mail-tos in out)))))))))))))

(define (auth-plain in out auth-user auth-password)
  (let1 message (base64-encode-string #`"\0,|auth-user|\0,|auth-password|")
    (send-and-receive in out #`"AUTH PLAIN ,|message|" 235)))

(define (auth-login in out auth-user auth-password)
  (send-and-receive in out "AUTH LOGIN" 334)
  (send-and-receive in out (base64-encode-string auth-user) 334)
  (send-and-receive in out (base64-encode-string auth-password) 235))

(define (mail-transaction-and-quit source mail-from mail-tos in out)
  (send-and-receive in out #`"MAIL FROM: <,|mail-from|>" 250)
  (for-each
    (lambda (rcpt)
       (send-and-receive in out #`"RCPT TO: <,|rcpt|>" 250))
    mail-tos)

  (send-and-receive in out "DATA" 354)
  (send-body-of-mail out source)
  (send-and-receive in out "." 250)
  (send-and-receive in out "QUIT" 221))

(define (display-log . args)
  (apply format #t args))

(define (send-and-receive in out command expected-code)
  (when command
    (display-log "\n->~s\n" command)
    (send-line out command))
  (receive (code lines) (receive-response in)
    (display-log "~s<-~s\n" expected-code lines)
    (when (not (= code expected-code))
      (errorf "smtp error: expected-code ~a\n~a -> ~s"
              expected-code command lines))
    lines))

(define (receive-response in)
  (let* ((lines (read-response in))
         (code (get-code lines)))
    (values code lines)))

(define (read-response in)
  (do ((lines '() (cons line lines))
       (line (read-line in) (read-line in)))
      ((not (continuation-line? line))
       (reverse (cons line lines)))
    ;no-body
  ))

(define (get-code lines)
  (string->number (substring (car lines) 0 3)))

(define (continuation-line? line)
  (and (> (string-length line) 3)
       (char=? (string-ref line 3) #\-)))

(define (support? rx lines)
  (any (lambda (line) (rxmatch rx line)) lines))

(define (support-starttls? lines)
  (support? #/STARTTLS/ lines))

(define (support-auth-plain? lines)
  (support? #/AUTH .*PLAIN/ lines))

(define (support-auth-login? lines)
  (support? #/AUTH .*LOGIN/ lines))

(define (send-line out line)
  (display line out)
  (display "\r\n" out))

(define (send-body-of-mail out source)
  (define (send-additional-period-if-need out line)
    (when (and (> (string-size line) 0)
          (char=? #\. (string-ref line 0)))
      (display "." out)))

  (port-for-each
    (lambda (line)
      (send-additional-period-if-need out line)
      (send-line out line))
    (lambda () (read-line source))))

;;; コマンドライン引数の解析など
(define (main args)
  (define mail-tos (list))
  (let-args (cdr args)
      ((host "host=s" "localhost")
       (port "port=i" 587)
       (mail-from "from=s" "from@localhost")
       (#f  "to=s" => (cut push! mail-tos <>))
       (source "source=s" #f)
       (helo-domain "helo-domain=s" '() => (cut list :helo-domain <>))
       (ca-file "ca-file=s" '() => (cut list :ca-file <>))
       (ca-path "ca-path=s" '() => (cut list :ca-path <>))
       (auth-user "auth-user=s" '() => (cut list :auth-user <>)))
    (let ((source
            (cond (source)
                  (else (open-input-string
                          (port->string (standard-input-port))))))
          (auth-password
            (cond ((null? auth-user) '())
                   (else (list :auth-password
                           (get-password "Input AUTH password "))))))
      (call-with-input-file-or-port source (lambda (iport)
        (apply send-mail host port iport mail-from mail-tos
          (append helo-domain ca-file ca-path auth-user auth-password)))))))

(define (call-with-input-file-or-port string-or-port proc)
  (cond ((string? string-or-port)
         (call-with-input-file string-or-port proc))
        (else (proc string-or-port))))

;;; マニュアルgauche.termiosのサンプルプログラムそのまま
(define (get-password prompt)
  (let* ((port (current-input-port))
         (attr (sys-tcgetattr port))
         (lflag (slot-ref attr 'lflag)))
    ;; Show prompt
    (display prompt)
    (flush)
    ;; Turn off echo during reading.
    (dynamic-wind
     (lambda ()
       (slot-set! attr 'lflag (logand lflag (lognot ECHO)))
       (sys-tcsetattr port TCSAFLUSH attr))
     (lambda ()
       (read-line port))
     (lambda ()
       (slot-set! attr 'lflag lflag)
       (sys-tcsetattr port TCSANOW attr)))))