;; -*- mode: scheme; coding: utf-8 -*-
;; Copyright © 2009, 2010 Göran Weinholt <goran@weinholt.se>
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
#!r6rs

;; Transport Layer Security. RFC5246.

;; The security of TLS in essence works like this: the server sends a
;; list of certificates, each signed by the next. The last certificate
;; is signed by a root certificate which you are supposed to have
;; downloaded from a trusted party. The first certificate contains the
;; server's public key. A few random bytes are generated by both the
;; client and the server. Then the client generates a few random bytes
;; that are called the premaster-secret and it encrypts them against
;; the server's public key. The server decrypts this and both sides
;; now have access to the premaster-secret without anyone being able
;; to read it off the network. Now both sides use all these random
;; numbers to generate the master secret and then use it to generate
;; key material for a symmetric cipher like 3DES. When this is done,
;; all messages have their checksums calculated with something like
;; SHA-1 and then encrypted with the cipher.

;; http://www.ietf.org/dyn/wg/charter/tls-charter.html

;; TODO: go through the implementation pitfalls in the RFC. check all
;; the MUSTs.

(library (weinholt net tls (0 0 20100627))
  (export make-tls-wrapper
          flush-tls-output
          put-tls-record get-tls-record
          put-tls-alert-record
          put-tls-handshake
          put-tls-handshake-client-hello
          put-tls-handshake-certificate
          put-tls-handshake-client-key-exchange
          put-tls-handshake-certificate-verify
          put-tls-change-cipher-spec
          put-tls-handshake-finished
          put-tls-application-data
          tls-conn-remote-certs
          tls-conn-has-unprocessed-data?)
  (import (rnrs)
          (only (srfi :1 lists) last)
          (srfi :19 time)
          (srfi :27 random-bits)
          (weinholt bytevectors)
          (weinholt crypto aes)
          (weinholt crypto arcfour)
          (weinholt crypto des)
          (weinholt crypto dsa)
          (weinholt crypto entropy)
          (weinholt crypto math)        ;TODO: dh
          (weinholt crypto md5)
          (weinholt crypto rsa)
          (weinholt crypto sha-1)
          (weinholt crypto x509)
          (weinholt net buffer)
          (weinholt struct pack)
          (weinholt text base64))

;;; First the utilities

  (define-syntax print
    (syntax-rules ()
      #;
      ((_ . args)
       (begin
         (for-each display (list . args))
         (newline)))
      ((_ . args) (values))))

  (define (bv->string bv)
    (apply string-append
           (map (lambda (b)
                  (if (< b #x10)
                      (string-append "0" (number->string b 16))
                      (number->string b 16)))
                (bytevector->u8-list bv))))

  (define (bytevector-copy* bv start len)
    (let ((ret (make-bytevector len)))
      (bytevector-copy! bv start ret 0 len)
      ret))

  (define (u16be-list->bytevector x)
    (uint-list->bytevector x (endianness big) 2))

  (define (pad-length len blocksize)
    ;; TODO: more than the minimum padding.
    ;; Assumes block sizes are a power of two
    (if (fixnum? blocksize)
        (fxand (fx- len) (fx- blocksize 1))
        0))

;;; Version numbers

  ;; In TLS 1.1 the format of encrypted records changes to include an
  ;; explicit IV for CBC ciphers.

  (define TLS-VERSION-1.2 #x0303)       ;RFC5246 (not yet supported)
  (define TLS-VERSION-1.1 #x0302)       ;RFC4346
  (define TLS-VERSION-1.0 #x0301)       ;RFC2246
  (define SSL-VERSION-3.0 #x0300)       ;not gonna be supported
  (define TLS-VERSION TLS-VERSION-1.1)
  ;; TODO: upgrade to version 1.2. Must first find a server that
  ;; implements it...
  (define tls-client-version-bytevector
    (pack "!S" TLS-VERSION))

;;; A few cipher suites

  (define-record-type cs
    (fields name id kex cipher mac
            key-length iv-size block-size expand-ekey expand-dkey
            mac-length mac-key-length)
    (protocol
     (lambda (p)
       (lambda (name id kex cipher mac)
         (let-values (((key-length iv-size block-size
                                   expand-ekey expand-dkey)
                       (case cipher
                         ((#f)
                          (values 0 0 #f
                                  'no-keys
                                  'no-keys))
                         ((rc4-128)
                          (values 16 0 #f
                                  expand-arcfour-key
                                  expand-arcfour-key))
                         ((tdea)
                          (values 24 8 8
                                  tdea-permute-key
                                  tdea-permute-key))
                         ((aes-128-cbc)
                          (values 16 16 16
                                  expand-aes-key
                                  (lambda (k)
                                    (reverse-aes-schedule
                                     (expand-aes-key k)))))
                         ((aes-256-cbc)
                          (values 32 16 16
                                  expand-aes-key
                                  (lambda (k)
                                    (reverse-aes-schedule
                                     (expand-aes-key k)))))))
                      ((mac-length mac-key-length)
                       (case mac
                         ((#f) (values 0 0))
                         ((md5) (values 16 16))
                         ((sha-1) (values 20 20))
                         ((sha-256) (values 32 32)))))
           (p name id kex cipher mac
              key-length iv-size block-size expand-ekey expand-dkey
              mac-length mac-key-length))))))

  ;; All the supported cipher suites in order of priority. The NULL
  ;; cipher must be first.
  ;; http://www.iana.org/assignments/tls-parameters/tls-parameters.txt
  (define supported-cipher-suites
    (list
     (make-cs 'NULL-WITH-NULL-NULL #x0000 #f #f #f)
     ;; Ephemeral Diffie-Hellman gives Perfect Forward Secrecy.
     ;; (make-cs 'DH-DSS-WITH-AES-128-CBC-SHA #x0030 'dh-dss 'aes-128-cbc 'sha-1)
     ;; (make-cs 'DH-RSA-WITH-AES-128-CBC-SHA #x0031 'dh-rsa 'aes-128-cbc 'sha-1)
     (make-cs 'DHE-DSS-WITH-AES-128-CBC-SHA #x0032 'dhe-dss 'aes-128-cbc 'sha-1)
     (make-cs 'DHE-RSA-WITH-AES-128-CBC-SHA #x0033 'dhe-rsa 'aes-128-cbc 'sha-1)
     ;; (make-cs 'DH-DSS-WITH-AES-256-CBC-SHA #x0036 'dh-dss 'aes-256-cbc 'sha-1)
     ;; (make-cs 'DH-RSA-WITH-AES-256-CBC-SHA #x0037 'dh-rsa 'aes-256-cbc 'sha-1)
     (make-cs 'DHE-DSS-WITH-AES-256-CBC-SHA #x0038 'dhe-dss 'aes-256-cbc 'sha-1)
     (make-cs 'DHE-RSA-WITH-AES-256-CBC-SHA #x0039 'dhe-rsa 'aes-256-cbc 'sha-1)

     ;; TODO: version 1.2:
     ;; (make-cs 'DH-DSS-WITH-AES-128-CBC-SHA256 #x003E 'dh-dss 'aes-128-cbc 'sha-256)
     ;; (make-cs 'DH-RSA-WITH-AES-128-CBC-SHA256 #x003F 'dh-rsa 'aes-128-cbc 'sha-256)
     ;; (make-cs 'DHE-DSS-WITH-AES-128-CBC-SHA256 #x0040 'dhe-dss 'aes-128-cbc 'sha-256)
     ;; (make-cs 'DHE-RSA-WITH-AES-128-CBC-SHA256 #x0067 'dhe-rsa 'aes-128-cbc 'sha-256)
     ;; (make-cs 'DH-DSS-WITH-AES-256-CBC-SHA256 #x0068 'dh-dss 'aes-256-cbc 'sha-256)
     ;; (make-cs 'DH-RSA-WITH-AES-256-CBC-SHA256 #x0069 'dh-rsa 'aes-256-cbc 'sha-256)
     ;; (make-cs 'DHE-DSS-WITH-AES-256-CBC-SHA256 #x006A 'dhe-dss 'aes-256-cbc 'sha-256)
     ;; (make-cs 'DHE-RSA-WITH-AES-256-CBC-SHA256 #x006B 'dhe-rsa 'aes-256-cbc 'sha-256)

     (make-cs 'RSA-WITH-AES-128-CBC-SHA #x002F 'rsa 'aes-128-cbc 'sha-1)
     (make-cs 'RSA-WITH-AES-256-CBC-SHA #x0035 'rsa 'aes-256-cbc 'sha-1)
     (make-cs 'RSA-WITH-RC4-128-SHA #x0005 'rsa 'rc4-128 'sha-1)
     (make-cs 'RSA-WITH-RC4-128-MD5 #x0004 'rsa 'rc4-128 'md5)
     ;; TODO: version 1.2:
     ;; (make-cs 'RSA-WITH-AES-128-CBC-SHA256 #x003C 'rsa 'aes-128-cbc 'sha-256)
     ;; (make-cs 'RSA-WITH-AES-256-CBC-SHA256 #x003D 'rsa 'aes-256-cbc 'sha-256)
     ;; 3DES is last because it's so very slow
     ;; (make-cs 'DH-DSS-WITH-3DES-EDE-CBC-SHA #x000D 'dh-dss 'tdea 'sha-1)
     ;; (make-cs 'DH-RSA-WITH-3DES-EDE-CBC-SHA #x0010 'dh-rsa 'tdea 'sha-1)
     (make-cs 'DHE-DSS-WITH-3DES-EDE-CBC-SHA #x0013 'dhe-dss 'tdea 'sha-1)
     (make-cs 'DHE-RSA-WITH-3DES-EDE-CBC-SHA #x0016 'dhe-rsa 'tdea 'sha-1)
     (make-cs 'RSA-WITH-3DES-EDE-CBC-SHA #x000A 'rsa 'tdea 'sha-1)))

;;;

  (define (check-key-usage conn bitname)
    ;; Return #f if there is a key usage extension and the given bit
    ;; is not set.
    (cond ((certificate-key-usage (last (tls-conn-remote-certs conn)))
           => (lambda (ku) (memq bitname ku)))
          (else #t)))

  (define (tls-prf-sha256 bytes secret label seeds)
    ;; TODO: version 1.2
    (error 'tls-prf-sha256 "not implemented"))

  (define (p-hash hash->bytevector hmac hash-length length secret seeds)
    ;; Expands the secret and seeds to at least `length' bytes, which
    ;; will be rounded to a multiple of the hash-length.
    (define (gen-A i max prev)
      (if (fx=? i max)
          '()
          (let ((a (hash->bytevector (hmac secret prev))))
            (cons prev (gen-A (fx+ i 1) max a)))))
    (bytevector-concatenate
     (map (lambda (a) (hash->bytevector (apply hmac secret a seeds)))
          (gen-A 0
                 (div (+ length (- hash-length 1)) hash-length)
                 (hash->bytevector (apply hmac secret seeds))))))

  (define (tls-prf-md5-sha1 bytes secret label seeds)
    ;; Performs this operation from RFC4346:
    ;; PRF(secret, label, seed) = P_MD5(S1, label + seed) XOR
    ;;                          P_SHA-1(S2, label + seed)
    (let* ((half-length (div (+ (bytevector-length secret) 1) 2))
           (s1 (subbytevector secret 0 half-length))
           (s2 (subbytevector secret half-length))
           (seeds (cons label seeds)))
      (do ((p1 (p-hash md5->bytevector hmac-md5 16 bytes s1 seeds))
           (p2 (p-hash sha-1->bytevector hmac-sha-1 20 bytes s2 seeds))
           (i 0 (fx+ i 1))
           (ret (make-bytevector bytes)))
          ((= i bytes) ret)
        (bytevector-u8-set! ret i (fxxor (bytevector-u8-ref p1 i)
                                         (bytevector-u8-ref p2 i))))))

  (define (tls-conn-prf conn)
    (if (< (tls-conn-version conn) TLS-VERSION-1.2)
        tls-prf-md5-sha1
        tls-prf-sha256))

  (define-record-type tls-conn
    (fields (mutable remote-certs)      ;end-entity is last
            (mutable client-cipher)
            (mutable server-cipher)
            (mutable next-cipher)

            (mutable seq-read)
            (mutable seq-write)
            (mutable version)

            (mutable master-secret)
            (mutable client-random)
            (mutable client-write-mac-secret)
            (mutable client-write-key)
            (mutable client-write-IV)
            (mutable server-random)
            (mutable server-write-mac-secret)
            (mutable server-write-key)
            (mutable server-write-IV)
            ;; Server Diffie-Hellman parameters
            (mutable server-DH-p)
            (mutable server-DH-g)
            (mutable server-DH-Ys)

            (immutable handshakes-md5)
            (immutable handshakes-sha-1)
            (immutable server-name)
            (immutable inbuf)           ;buffer for record input
            (immutable out)             ;output port
            (immutable outb)            ;output buffer
            (immutable hsbuf)))         ;handshake buffer

  ;; Make a new TLS connection state.
  (define (make-tls-wrapper in out server-name)
    (let ((random-source (make-random-source)))
      (random-source-randomize! random-source)
      (make-tls-conn '()
                     (car supported-cipher-suites)
                     (car supported-cipher-suites)
                     (car supported-cipher-suites)

                     0 0
                     TLS-VERSION

                     'no-master-secret-yet
                     'no-client-random
                     'no-client-write-mac-secret-yet
                     'no-client-write-key-yet
                     'no-client-write-IV-yet
                     'no-server-random
                     'no-server-write-mac-secret-yet
                     'no-server-write-key-yet
                     'no-server-write-IV-yet
                     'no-server-DH-params-yet #f #f

                     (make-md5)
                     (make-sha-1)
                     server-name
                     (make-buffer in)
                     out
                     (make-bytevector (+ (expt 2 14) 2048))
                     (make-buffer 'handshakes))))

  (define (close-tls conn)
    ;; TODO: clear the connection state
    (close-port (tls-conn-out conn))
    (close-port (buffer-port (tls-conn-inbuf conn))))

;;; Record protocol

  ;; The record layer receives fragments (that are optionally
  ;; encrypted and/or compressed). These fragments are sent to a
  ;; higher level protocol (change-cipher-spec, alert, handshake or
  ;; application-data). Fragments headed for change-cipher-spec and
  ;; application-data can never be incomplete, so for these protocols
  ;; the normal tls-conn-inbuf is used. Handshakes get their own
  ;; buffer: tls-conn-hsbuf. The alert protocol could possibly contain
  ;; fragments, but is that really something that happens?

  (define TLS-PROTOCOL-CHANGE-CIPHER-SPEC 20)
  (define TLS-PROTOCOL-ALERT 21)
  (define TLS-PROTOCOL-HANDSHAKE 22)
  (define TLS-PROTOCOL-APPLICATION-DATA 23)

  (define (explicit-IV? conn)
    (>= (tls-conn-version conn) TLS-VERSION-1.1))

  (define (flush-tls-output conn)
    (flush-output-port (tls-conn-out conn)))

  (define (put-tls-record conn type data)
    ;; Take a list of data, split it into records and put the records
    ;; on the output port.
    (print ";;; sending a record of type " type)
    (let ((out (tls-conn-out conn))
          (len (bytevectors-length data)))
      (cond ((> len (expt 2 14))
             (error 'put-tls-record "TODO: overlong record" len))
            ((not (cs-cipher (tls-conn-client-cipher conn)))
             (put-bytevector out (pack "!uCSS" type (tls-conn-version conn) len))
             (for-each (lambda (bv) (put-bytevector out bv)) data))
            ;; Pad, MAC and encrypt
            (else
             (let* ((cipher (tls-conn-client-cipher conn))
                    (blocks-len (+ len (cs-mac-length cipher)
                                   (if (cs-block-size cipher) 1 0)))
                    (padding (pad-length blocks-len (cs-block-size cipher)))
                    (padded-len (+ blocks-len padding))
                    (blocks (tls-conn-outb conn)))
               (cond ((explicit-IV? conn)
                      (put-bytevector out (pack "!uCSS" type (tls-conn-version conn)
                                                (+ padded-len (cs-iv-size cipher))))
                      (bytevector-randomize! (tls-conn-client-write-IV conn))
                      (put-bytevector out (tls-conn-client-write-IV conn)))
                     (else
                      (put-bytevector out (pack "!uCSS" type (tls-conn-version conn)
                                                padded-len))))
               (print "#;record-IV " (tls-conn-client-write-IV conn))
               (print "#;outgoing-plaintext " (bv->string
                                               (bytevector-concatenate data)))
               (do ((i len (+ i 1)))
                   ((= i padded-len))
                 (bytevector-u8-set! blocks i padding)) ;pad
               ;; MAC
               (let ((header (pack "!uQCSS" (tls-conn-seq-write conn)
                                   type (tls-conn-version conn) len)))
                 ;; TODO: if the sequence number would exceed 2^64-1, renegotiate.
                 (tls-conn-seq-write-set! conn (+ (tls-conn-seq-write conn) 1))
                 (case (cs-mac cipher)
                   ((sha-1)
                    (sha-1-copy-hash! (apply hmac-sha-1
                                             (tls-conn-client-write-mac-secret conn)
                                             header data)
                                      blocks len))
                   ((md5)
                    (md5-copy-hash! (apply hmac-md5
                                           (tls-conn-client-write-mac-secret conn)
                                           header data)
                                    blocks len))
                   (else
                    (error 'put-tls-record
                           "You forgot to put in the new MAC algorithm!"
                           (cs-mac cipher)))))
               ;; Copy in the plaintext
               (do ((data data (cdr data))
                    (i 0 (+ i (bytevector-length (car data)))))
                   ((null? data))
                 (bytevector-copy! (car data) 0 blocks i (bytevector-length (car data))))
               ;; Encipher
               (case (cs-cipher cipher)
                 ((aes-128-cbc aes-256-cbc)
                  (aes-cbc-encrypt! blocks 0 blocks 0 padded-len
                                    (tls-conn-client-write-key conn)
                                    (tls-conn-client-write-IV conn)))
                 ((rc4-128)
                  (arcfour! blocks 0 blocks 0 padded-len
                            (tls-conn-client-write-key conn)))
                 ((tdea)
                  (tdea-cbc-encipher! blocks
                                      (tls-conn-client-write-key conn)
                                      (tls-conn-client-write-IV conn)
                                      0 padded-len))
                 (else
                  (error 'put-tls-record
                         "You forgot to put in the new cipher algorithm!"
                         (cs-cipher cipher))))
               (print "#;outgoing-ciphertext " (bv->string
                                                (subbytevector blocks 0 padded-len)))
               (put-bytevector out blocks 0 padded-len))))))

  (define (tls-conn-has-unprocessed-data? conn)
    (cond ((and (not (zero? (buffer-length (tls-conn-hsbuf conn))))
                (not (zero? (buffer-top (tls-conn-hsbuf conn)))))
           ;; If the length isn't zero, then there is unprocessed
           ;; data. If the top is zero, then there must've been an
           ;; incomplete handshake sent, and we must read more data
           ;; before anything fun can happen.
           (print ";Handshake protocol has " (buffer-length (tls-conn-hsbuf conn))
                  " bytes unprocessed")
           TLS-PROTOCOL-HANDSHAKE)
          (else #f)))

  (define (get-tls-record conn)
    (buffer-reset! (tls-conn-inbuf conn))
    (cond ((tls-conn-has-unprocessed-data? conn) =>
           (lambda (type)
             (print ";Handling unprocessed data of type " type)
             (handle-fragment conn (tls-conn-inbuf conn) type)))
          ((port-eof? (buffer-port (tls-conn-inbuf conn)))
           (eof-object))
          (else
           (get-tls-record* conn))))

  (define (get-tls-record* conn)
    (let ((b (tls-conn-inbuf conn)))
      (buffer-reset! b)
      (buffer-read! b (format-size "!uCSS"))
      (let-values (((type version len) (unpack "!uCSS" (buffer-data b))))
        (print ";;; record type: " type
               " version: " (number->string version 16)
               " length: " len)
        (when (>= len (+ (expt 2 14) 2048))
          (error 'get-tls-record "The server sent an overlong record"
                 (tls-conn-server-name conn)))
        (buffer-reset! b)
        (buffer-read! b len)
        (decipher-record conn b type len)
        (handle-fragment conn b type))))

  (define (decipher-record conn b type len)
    (let ((cipher (tls-conn-server-cipher conn)))
      (cond ((cs-cipher cipher)
             (print ";Deciphering " (cs-cipher cipher) " encrypted record")
             (print "#;incoming-ciphertext "
                    (bv->string
                     (bytevector-copy* (buffer-data b) (buffer-top b)
                                       len)))
             (when (explicit-IV? conn)
               (bytevector-copy! (buffer-data b) (buffer-top b)
                                 (tls-conn-server-write-IV conn) 0
                                 (cs-iv-size cipher)))
             (case (cs-cipher cipher)
               ((aes-128-cbc aes-256-cbc)
                (aes-cbc-decrypt! (buffer-data b) (buffer-top b)
                                  (buffer-data b) (buffer-top b)
                                  len
                                  (tls-conn-server-write-key conn)
                                  (tls-conn-server-write-IV conn)))
               ((rc4-128)
                (arcfour! (buffer-data b) (buffer-top b)
                          (buffer-data b) (buffer-top b)
                          len
                          (tls-conn-server-write-key conn)))
               ((tdea)
                (tdea-cbc-decipher! (buffer-data b)
                                    (tls-conn-server-write-key conn)
                                    (tls-conn-server-write-IV conn)
                                    (buffer-top b)
                                    len))
               (else
                (error 'decipher-record
                       "You forgot to put in the new cipher algorithm!"
                       (cs-cipher cipher))))
             (print "#;incoming-plaintext "
                    (bv->string
                     (bytevector-copy* (buffer-data b) (buffer-top b)
                                       len)))
             (when (explicit-IV? conn)
               (buffer-seek! b (cs-iv-size cipher)))
             (let ((padding (bytevector-u8-ref (buffer-data b)
                                               (- (buffer-bottom b) 1))))
               ;; FIXME: verify the MAC even if the padding is crazy.
               ;; FIXME: verify the padding characters.
               (when (cs-block-size cipher)
                 (print "#;padding " padding)
                 (buffer-shorten! b (+ padding 1))) ;remove padding
               (let ((mac (subbytevector (buffer-data b) (- (buffer-bottom b)
                                                            (cs-mac-length cipher))
                                         (buffer-bottom b))))
                 (buffer-shorten! b (cs-mac-length cipher)) ;remove mac
                 (let* ((header (pack "!uQCSS" (tls-conn-seq-read conn)
                                      type (tls-conn-version conn)
                                      (buffer-length b)))
                        ;; TODO: MAC the data without consing
                        (data (subbytevector (buffer-data b)
                                             (buffer-top b)
                                             (buffer-bottom b)))
                        (vmac
                         (case (cs-mac cipher)
                           ((sha-1)
                            (sha-1->bytevector
                             (hmac-sha-1 (tls-conn-server-write-mac-secret conn)
                                         header data)))
                           ((md5)
                            (md5->bytevector
                             (hmac-md5 (tls-conn-server-write-mac-secret conn)
                                       header data)))
                           (else
                            (error 'decipher-record
                                   "You forgot to put in the new MAC algorithm!"
                                   (cs-mac cipher))))))
                   (unless (bytevector=? mac vmac)
                     (error 'get-tls-record "bad mac" (tls-conn-server-name conn))))
                 (tls-conn-seq-read-set! conn (+ (tls-conn-seq-read conn) 1))))))))

  (define (handle-fragment conn b type)
    ;; At the start of the buffer b is a plaintext fragment.
    (cond ((= type TLS-PROTOCOL-APPLICATION-DATA)
           (get-tls-application-data conn)) ;never fragmented
          ((= type TLS-PROTOCOL-CHANGE-CIPHER-SPEC)
           (get-tls-change-cipher-spec conn)) ;never fragmented
          ((= type TLS-PROTOCOL-ALERT)  ;FIXME: could be fragmented?
           (get-tls-alert-record conn))
          ((= type TLS-PROTOCOL-HANDSHAKE)
           (buffer-copy! (buffer-data b) (buffer-top b)
                         (tls-conn-hsbuf conn)
                         (buffer-length b))
           (get-tls-handshake-record conn))
          (else
           ;; TODO: send an error
           (close-tls conn)
           (error 'get-tls-record
                  "The server sent an invalid record type" type))))

;;; Alert protocol

  ;; TODO: friendly messages for all these alerts
  (define alert-descriptions
    '((0 . close-notify)
      (10 . unexpected-message)
      (20 . bad-record-mac)
      (21 . decryption-failed-RESERVED) ;never send this
      (22 . record-overflow)
      (30 . decompression-failure)
      (40 . handshake-failure)
      (41 . no-certificate-RESERVED)    ;deprecated
      (42 . bad-certificate)
      (43 . unsupported-certificate)
      (44 . certificate-revoked)
      (45 . certificate-expired)
      (46 . certificate-unknown)
      (47 . illegal-parameter)
      (48 . unknown-ca)
      (49 . access-denied)
      (50 . decode-error)
      (51 . decrypt-error)
      (60 . export-restriction-RESERVED) ;deprecated
      (70 . protocol-version)
      (71 . insufficient-security)
      (80 . internal-error)
      (90 . user-canceled)
      (100 . no-renegotiation)
      (110 . unsupported-extension)))

  (define (get-tls-alert-record conn)
    (let* ((b (tls-conn-inbuf conn))
           (level (read-u8 b 0))
           (description (read-u8 b 1))
           (desc* (or (assq description alert-descriptions)
                      (cons description 'unknown-alert-description))))
      (case level
        ((2)
         (close-tls conn)
         (condition
          (make-error)
          (make-i/o-error)
          (make-i/o-port-error (buffer-port (tls-conn-inbuf conn)))
          (make-message-condition "TLS alert (fatal, so the port has been closed)")
          (make-irritants-condition (list desc*))))
        ((1)
         (condition
          (make-warning)
          (make-i/o-port-error (buffer-port (tls-conn-inbuf conn)))
          (make-message-condition "TLS alert (warning)")
          (make-irritants-condition (list desc*))))
        (else
         ;; TODO: send an error
         (close-tls conn)
         (error 'get-tls-alert-record "Bad alert level sent" level)))))

  (define (put-tls-alert-record conn level description)
    (assert (memv level '(1 2)))
    (put-tls-record conn TLS-PROTOCOL-HANDSHAKE
                    (list (pack "!CC" level description))))

;;; Handshake protocol

  (define TLS-HANDSHAKE-HELLO-REQUEST 0)
  (define TLS-HANDSHAKE-CLIENT-HELLO 1)
  (define TLS-HANDSHAKE-SERVER-HELLO 2)
  (define TLS-HANDSHAKE-CERTIFICATE 11)
  (define TLS-HANDSHAKE-SERVER-KEY-EXCHANGE 12)
  (define TLS-HANDSHAKE-CERTIFICATE-REQUEST 13)
  (define TLS-HANDSHAKE-SERVER-HELLO-DONE 14)
  (define TLS-HANDSHAKE-CERTIFICATE-VERIFY 15)
  (define TLS-HANDSHAKE-CLIENT-KEY-EXCHANGE 16)
  (define TLS-HANDSHAKE-FINISHED 20)

  (define tls-conn-hash-handshake!
    (case-lambda
      ((conn l)
       (for-each (lambda (bv)
                   (tls-conn-hash-handshake! conn bv 0 (bytevector-length bv)))
                 l))
      ((conn bv start count)
       ;; Calculate the hashes of all incoming and outgoing
       ;; handshakes. Used in the FINISH message. TODO: this is
       ;; version-dependent.
       (md5-update! (tls-conn-handshakes-md5 conn) bv start (+ start count))
       (sha-1-update! (tls-conn-handshakes-sha-1 conn) bv start (+ start count)))))

  ;; Extensions (RFC4366) are formatted in this extensive manner.
  ;; http://www.iana.org/assignments/tls-extensiontype-values
  (define TLS-EXTENSION-SERVER-NAME 0)
  (define TLS-EXTENSION-SERVER-NAME-HOSTNAME 0)
  (define (extensions . x)
    (bytevector-concatenate (cons (pack "!S" (bytevectors-length x)) x)))
  (define (extension type data)
    (bytevector-append (pack "!SS" type (bytevector-length data)) data))
  (define (server-name-list names)
    (extension TLS-EXTENSION-SERVER-NAME
               (bytevector-append (pack "!S" (bytevectors-length names))
                                  (bytevector-concatenate names))))
  (define (server-name name)
    (let ((n (string->utf8 name)))
      (bytevector-append (pack "!uCS" TLS-EXTENSION-SERVER-NAME-HOSTNAME
                               (bytevector-length n))
                         n)))

  (define (put-tls-handshake conn type data)
    ;; Takes data from a handshake protocol and passes it to the
    ;; record protocol.
    (let ((bv (make-bytevector 4))
          (len (bytevectors-length data)))
      (bytevector-u32-set! bv 0 (bitwise-ior (bitwise-arithmetic-shift-left type 24)
                                             len)
                           (endianness big))
      (tls-conn-hash-handshake! conn (cons bv data))
      (put-tls-record conn TLS-PROTOCOL-HANDSHAKE (cons bv data))))

  (define (put-tls-handshake-client-hello conn)
    (define session-id '#vu8())
    (define cipher-suites (map cs-id (cdr supported-cipher-suites)))
    (define compression-methods '(0))   ;null compression
    (let ((crandom (make-random-bytevector (+ 4 28))))
      ;; Client time + random bytes
      (bytevector-u32-set! crandom 0
                           (bitwise-and #xffffffff (time-second (current-time)))
                           (endianness big))
      (tls-conn-client-random-set! conn crandom)
      (put-tls-handshake
       conn TLS-HANDSHAKE-CLIENT-HELLO
       (list tls-client-version-bytevector
             crandom
             (pack "C" (bytevector-length session-id))
             session-id
             (u16be-list->bytevector (cons (* 2 (length cipher-suites))
                                           cipher-suites))
             (u8-list->bytevector (cons (length compression-methods)
                                        compression-methods))
             (extensions (server-name-list
                          (list (server-name (tls-conn-server-name conn)))))))))

  ;; `certs' are bytevectors and the last cert is the client's own
  ;; certificate. So the order is the same as for
  ;; tls-conn-remote-certs.
  (define (put-tls-handshake-certificate conn certs)
    (define (put-u24 p n)
      (put-u8 p (bitwise-bit-field n 16 24))
      (put-u8 p (bitwise-bit-field n 8 16))
      (put-u8 p (bitwise-bit-field n 0 8)))
    (let ((certs (or certs '())))
      (let-values (((p extract) (open-bytevector-output-port)))
        (put-u24 p (+ (bytevectors-length certs)
                      (* 3 (length certs))))
        (for-each (lambda (c)
                    (put-u24 p (bytevector-length c))
                    (put-bytevector p c))
                  (reverse certs))
        (put-tls-handshake conn TLS-HANDSHAKE-CERTIFICATE
                           (list (extract))))))

  (define (put-tls-handshake-client-key-exchange conn)
    (case (cs-kex (tls-conn-next-cipher conn))
      ((rsa)
       (put-tls-handshake-client-key-exchange-rsa conn))
      ((dhe-rsa dhe-dss)
       (put-tls-handshake-client-key-exchange-dhe conn))
      (else
       (error 'put-tls-handshake-client-key-exchange
              "You forgot to put in the new key exchange algorithm!"
              (cs-kex (tls-conn-next-cipher conn))))))

  (define (put-tls-handshake-client-key-exchange-rsa conn)
    (print ";Client RSA Key-Exchange")
    (let ((premaster-secret (make-random-bytevector 48)))
      ;; Construct the premaster secret with our version number and 46
      ;; random bytes. Everything hinges on this being unpredictable...
      (bytevector-u16-set! premaster-secret 0 TLS-VERSION (endianness big))
      (generate-keys conn premaster-secret)
      ;; Encrypt the premaster-secret and send it to the remote.
      (unless (check-key-usage conn 'keyEncipherment)
        (close-tls conn)                ;TODO: send an error
        (error 'put-tls-handshake
               "The remote public key does not work for enciphering keys"
               (tls-conn-server-name conn)))
      (let* ((server-key (certificate-public-key
                          (last (tls-conn-remote-certs conn))))
             (keylen (rsa-public-key-byte-length server-key))
             (bv (make-bytevector (+ 2 keylen))))
        (bytevector-u16-set! bv 0 keylen (endianness big))
        (bytevector-uint-set! bv 2
                              (rsa-pkcs1-encrypt premaster-secret server-key)
                              (endianness big) keylen)
        (bytevector-fill! premaster-secret 0)
        (put-tls-handshake conn TLS-HANDSHAKE-CLIENT-KEY-EXCHANGE
                           (list bv)))))

  (define (put-tls-handshake-client-key-exchange-dhe conn)
    (define (make-secret g n bits tries)
      ;;also in net/irc/fish and net/otr, should be in crypto/dh maybe?
      (unless (< tries 1000)
        (error 'make-secret "unable to make a secret"))
      (let* ((y (bytevector->uint (make-random-bytevector (div (+ bits 7) 8))))
             (Y (expt-mod g y n)))
        ;; See RFC 2631. Probably not clever enough.
        (if (and (<= 2 Y (- n 1))
                 (= 1 (expt-mod Y (/ (- n 1) 2) n)))
            (values y Y)
            (make-secret g n bits (+ tries 1)))))

    ;; TODO: if the client certificate contains a D-H key, this
    ;; message must be empty.
    (print ";Client Diffie-Hellman Key-Exchange")
    (print "#;p-length " (bitwise-length (tls-conn-server-DH-p conn)))
    (let-values (((y Yc) (make-secret (tls-conn-server-DH-g conn)
                                      (tls-conn-server-DH-p conn)
                                      (bitwise-length (tls-conn-server-DH-p conn))
                                      42)))
      ;; FIXME: what is the minimum length, etc?
      (let ((Z (uint->bytevector (expt-mod (tls-conn-server-DH-Ys conn)
                                           y
                                           (tls-conn-server-DH-p conn))))
            (Yc* (uint->bytevector Yc)))
        (generate-keys conn Z)
        (bytevector-fill! Z 0)          ;XXX: not effective
        (tls-conn-server-DH-p-set! conn #f)
        (tls-conn-server-DH-g-set! conn #f)
        (tls-conn-server-DH-Ys-set! conn #f)
        ;; Send our public Diffie-Hellman value to the remote
        (print "#;Yc " (bv->string Yc*))
        (put-tls-handshake conn TLS-HANDSHAKE-CLIENT-KEY-EXCHANGE
                           (list (pack "!S" (bytevector-length Yc*))
                                 Yc*)))))

  ;; Generate cryptographical material from the premaster-secret
  (define (generate-keys conn premaster-secret)
    (tls-conn-master-secret-set! conn ((tls-conn-prf conn) 48
                                       premaster-secret
                                       (string->utf8 "master secret")
                                       (list (tls-conn-client-random conn)
                                             (tls-conn-server-random conn))))
    (print ";plaintext premaster secret: " (bv->string premaster-secret))
    (print ";client random: " (bv->string (tls-conn-client-random conn)))
    (print ";server random: " (bv->string (tls-conn-server-random conn)))
    (print ";master secret: " (bv->string (tls-conn-master-secret conn)))
    (let* ((cipher (tls-conn-next-cipher conn))
           (hash-size (cs-mac-length cipher))
           (key-size (cs-key-length cipher))
           (IV-size (cs-iv-size cipher))
           (key-block ((tls-conn-prf conn) (* 2 (+ hash-size key-size IV-size))
                       (tls-conn-master-secret conn)
                       (string->utf8 "key expansion")
                       (list (tls-conn-server-random conn)
                             (tls-conn-client-random conn))))
           (keyp (open-bytevector-input-port key-block)))
      (tls-conn-client-write-mac-secret-set! conn (get-bytevector-n keyp hash-size))
      (tls-conn-server-write-mac-secret-set! conn (get-bytevector-n keyp hash-size))
      (let* ((client-write-key (get-bytevector-n keyp key-size))
             (server-write-key (get-bytevector-n keyp key-size)))
        (tls-conn-client-write-key-set! conn ((cs-expand-ekey cipher) client-write-key))
        (tls-conn-server-write-key-set! conn ((cs-expand-dkey cipher) server-write-key))
        (tls-conn-client-write-IV-set! conn (get-bytevector-n keyp IV-size))
        (tls-conn-server-write-IV-set! conn (get-bytevector-n keyp IV-size))
        (print ";key block: " (bv->string key-block))
        (print ";client-write-mac-secret: "
               (bv->string (tls-conn-client-write-mac-secret conn)))
        (print ";server-write-mac-secret: "
               (bv->string (tls-conn-server-write-mac-secret conn)))
        (print ";client-write-key: " (bv->string client-write-key))
        (print ";server-write-key: " (bv->string server-write-key))
        (print ";client-write-IV: " (bv->string (tls-conn-client-write-IV conn)))
        (print ";server-write-IV: " (bv->string (tls-conn-server-write-IV conn)))
        (bytevector-fill! key-block 0) ;can clear keyp
        (close-port keyp))))

  (define (put-tls-handshake-certificate-verify conn)
    ;; This is the message to prove that the client has the private
    ;; key for the cert it sent.
    (error 'put-tls-handshake-certificate-verify
           "TODO: not yet implemented. client certificates not supported."))

  (define (put-tls-handshake-finished conn)
    ;; PRF(master_secret, finished_label, MD5(handshake_messages) +
    ;;                         SHA-1(handshake_messages)) [0..11];
    (assert (cs-cipher (tls-conn-client-cipher conn)))
    (put-tls-handshake conn TLS-HANDSHAKE-FINISHED
                       (list ((tls-conn-prf conn) 12
                              (tls-conn-master-secret conn)
                              (string->utf8 "client finished")
                              (list (md5->bytevector
                                     (md5-finish (tls-conn-handshakes-md5 conn)))
                                    (sha-1->bytevector
                                     (sha-1-finish (tls-conn-handshakes-sha-1 conn))))))))

  (define (get-tls-handshake-record conn)
    (let* ((b (tls-conn-hsbuf conn))
           (type (read-u8 b 0))
           (length (read-u24 b 1))
           (start (buffer-top b)))
      (define (hash!)
        (tls-conn-hash-handshake! conn
                                  (buffer-data b)
                                  start
                                  (+ 4 length)))
      (define (done!)
        (buffer-top-set! b (+ start 4 length))
        (when (zero? (buffer-length b)) ;end of record?
          (buffer-reset! b)))

      (buffer-seek! b 4)

      (cond ((> length (buffer-length b))
             (print ";Fragmented handshake (" (buffer-length b) " of " length ")")
             (buffer-seek! b -4)
             (get-tls-record* conn))
            ((= type TLS-HANDSHAKE-SERVER-HELLO)
             ;; The server replied (presumably, check this later) to
             ;; the CLIENT-HELLO message.
             (hash!)
             (print ";Server says hello.")
             (tls-conn-version-set! conn (read-u16 b 0))
             (print ";Version " (number->string (tls-conn-version conn) 16))
             (print ";Server time: " (read-u32 b 2))

             (tls-conn-server-random-set! conn
                                          (bytevector-copy*
                                           (buffer-data b)
                                           (+ 2 (buffer-top b))
                                           (+ 4 28)))

             (buffer-seek! b (+ 2 4 28))
             (print ";Session length: "  (read-u8 b 0))
             (buffer-seek! b (+ 1 (read-u8 b 0))) ;skip session

             (let* ((id (read-u16 b 0))
                    (cs (car
                         (memp (lambda (cs) (= (cs-id cs) id))
                               (cdr supported-cipher-suites)))))
               (tls-conn-next-cipher-set! conn cs)
               (print ";Cipher suite: " cs))
             (print ";Compression method: " (read-u8 b 2))
             (done!)
             'handshake-server-hello)

            ((= type TLS-HANDSHAKE-CERTIFICATE)
             (hash!)
             (print ";Server sends certificates")
             (let ((certs-end (+ (buffer-top b) 3 (read-u24 b 0))))
               (buffer-seek! b 3)
               (let lp ((certs '()))
                 (cond ((= certs-end (buffer-top b))
                        (tls-conn-remote-certs-set! conn certs))
                       (else
                        (let* ((cert-len (read-u24 b 0))
                               (cert (certificate-from-bytevector (buffer-data b)
                                                                  (+ 3 (buffer-top b))
                                                                  (+ 3 (buffer-top b)
                                                                     cert-len))))
                          (print ";Cert of length " cert-len)
                          (print        ;cert in PEM format for debugging
                           (call-with-string-output-port
                             (lambda (p)
                               (put-delimited-base64 p "CERTIFICATE"
                                                     (bytevector-copy*
                                                      (buffer-data b)
                                                      (+ 3 (buffer-top b))
                                                      cert-len)))))
                          (buffer-seek! b (+ cert-len 3))
                          (lp (cons cert certs)))))))
             (done!)
             'handshake-certificate)

            ((= type TLS-HANDSHAKE-SERVER-KEY-EXCHANGE)
             (hash!)
             (get-tls-handshake-server-key-exchange conn b length)
             (done!)
             'handshake-server-key-exchange)

            ((= type TLS-HANDSHAKE-SERVER-HELLO-DONE)
             (hash!)
             (done!)
             'handshake-server-hello-done)

            ((= type TLS-HANDSHAKE-CERTIFICATE-REQUEST)
             ;; TODO: parse the request
             (hash!)
             (done!)
             'handshake-certificate-request)

            ((= type TLS-HANDSHAKE-FINISHED)
             ;; If this message is correct, it proves that the server
             ;; could decrypt the pre-master secret, so it has the
             ;; private key for the certificate it sent.
             (unless (bytevector=? (bytevector-copy* (buffer-data b)
                                                     (buffer-top b)
                                                     (buffer-length b))
                                   ((tls-conn-prf conn) 12
                                    (tls-conn-master-secret conn)
                                    (string->utf8 "server finished")
                                    (list (md5->bytevector
                                           (md5-finish
                                            (tls-conn-handshakes-md5 conn)))
                                          (sha-1->bytevector
                                           (sha-1-finish
                                            (tls-conn-handshakes-sha-1 conn))))))
               (error 'get-tls-handshake "Bad verify_data in HANDSHAKE-FINISHED"))
             (hash!)
             (done!)
             (bytevector-fill! (tls-conn-master-secret conn) 0)
             (tls-conn-master-secret-set! conn 'master-secret-forgotten)
             'handshake-finished)

            ((= type TLS-HANDSHAKE-HELLO-REQUEST)
             (hash!)
             (done!)
             'hello-request)

            ;; TODO:
            (else
             (error 'get-tls-handshake-record
                    "an unknown handshake type arrived" type)))))

  (define (get-tls-handshake-server-key-exchange conn b length)
    (define who get-tls-handshake-server-key-exchange)
    ;; The server wants to use DHE key exchange.
    (define (get-int p)
      (bytevector->uint (get-bytevector-n p (get-unpack p "!S"))))
    (print ";Server Key Exchange")
    (case (cs-kex (tls-conn-next-cipher conn))
      ((dhe-dss dhe-rsa)
       (unless (check-key-usage conn 'digitalSignature)
         (close-tls conn)                ;TODO: send an error
         (error who "The remote key cannot make signatures"
                (tls-conn-server-name conn)))
       (let ((msg (open-bytevector-input-port (buffer-data b))))
         (set-port-position! msg (buffer-top b))
         ;; Read ServerDHParams
         (let* ((p (get-int msg)) (g (get-int msg)) (Ys (get-int msg))
                (splen (- (port-position msg) (buffer-top b)))
                (esig (get-bytevector-n msg (get-unpack msg "!S"))))
           (print "#;p " p " #;g " g " #;Ys " Ys
                  " #;esig #x" (bv->string esig))
           (set-port-position! msg (buffer-top b))
           ;; TODO: different in TLS v1.2
           (let* ((tosign (list (tls-conn-client-random conn)
                                (tls-conn-server-random conn)
                                (get-bytevector-n msg splen)))
                  (server-key (certificate-public-key
                               (last (tls-conn-remote-certs conn)))))
             (close-port msg)
             (case (cs-kex (tls-conn-next-cipher conn))
               ((dhe-rsa)               ;RSA
                (let* ((digest (bytevector-append
                                (md5->bytevector (apply md5 tosign))
                                (sha-1->bytevector (apply sha-1 tosign))))
                       (esig (bytevector->uint esig))
                       (dsig (rsa-pkcs1-decrypt-signature esig server-key)))
                  (print "#;digest " (bv->string digest))
                  (print "#;dsig   " (bv->string dsig))
                  (unless (bytevector=? digest dsig)
                    (error who "bad RSA signature" digest dsig))))
               ((dhe-dss)               ;DSA
                (let ((digest (sha-1->bytevector (apply sha-1 tosign)))
                      (r/s (dsa-signature-from-bytevector esig)))
                  (print "#;digest " (bv->string digest))
                  (print "#;r/s " r/s)
                  (unless (apply dsa-verify-signature digest server-key r/s)
                    (error who "bad DSA signature" digest esig)))))
             ;; Ok, so the owner of the key really did send these D-H
             ;; parameters. Now it's safe to use them.
             (tls-conn-server-DH-p-set! conn p)
             (tls-conn-server-DH-g-set! conn g)
             (tls-conn-server-DH-Ys-set! conn Ys)))))
      ((rsa dh_dss dh_rsa) #f)
      (else
       (error who "You forgot to put in the new key exchange algorithm!"
              (cs-kex (tls-conn-next-cipher conn))))))

;;; Change cipher spec protocol

  ;; TODO: RFC 5746

  (define (put-tls-change-cipher-spec conn)
    (put-tls-record conn TLS-PROTOCOL-CHANGE-CIPHER-SPEC '(#vu8(1)))
    (tls-conn-client-cipher-set! conn (tls-conn-next-cipher conn)))

  (define (get-tls-change-cipher-spec conn)
    (cond ((and (= (buffer-length (tls-conn-inbuf conn)) 1)
                (= (read-u8 (tls-conn-inbuf conn) 0) 1)
                (not (cs-cipher (tls-conn-server-cipher conn)))) ;a precaution
           (print ";Switching to encrypted records")
           (tls-conn-server-cipher-set! conn (tls-conn-next-cipher conn))
           'change-cipher-spec)
          (else
           ;; TODO
           (close-tls conn)
           (error 'get-tls-change-cipher-spec
                  "The server sent a bad change-cipher-spec message"))))

;;; Application data protocol

  (define (put-tls-application-data conn data)
    (assert (cs-cipher (tls-conn-client-cipher conn)))
    (put-tls-record conn TLS-PROTOCOL-APPLICATION-DATA
                    (list data)))

  (define (get-tls-application-data conn)
    (assert (cs-cipher (tls-conn-server-cipher conn)))
    (let* ((b (tls-conn-inbuf conn))
           (appdata (bytevector-copy* (buffer-data b)
                                      (buffer-top b)
                                      (buffer-length b))))
      (print "#;application-data " appdata)

      (list 'application-data appdata))))
