commit 53c86fc6436925699a59d165936c83f980f5b53e
parent 9b173e2b93cc88b06b8fd7f29cd1655edc3df89f
Author: Tomas Hlavaty <tom@logand.com>
Date: Sun, 3 Aug 2014 21:04:19 +0200
tls added
Diffstat:
| A | tls.lisp | | | 709 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
1 file changed, 709 insertions(+), 0 deletions(-)
diff --git a/tls.lisp b/tls.lisp
@@ -0,0 +1,709 @@
+;;; Copyright (C) 2014 Tomas Hlavaty <tom@logand.com>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+
+(defpackage :rw.tls
+ (:use :cl))
+
+(in-package :rw.tls)
+
+;;tshark -i wlp3s0 -V >~/git/cl-rw/tls.log
+;;gnutls-cli wikipedia.org
+
+;; https://en.wikipedia.org/wiki/Transport_Layer_Security
+
+(defun next-u8 (reader)
+ (rw:next-u8 reader))
+
+(defun next-u16 (reader)
+ (rw:next-u16 reader))
+
+(defun next-u24 (reader)
+ (rw:next-u24 reader))
+
+(defun next-u32 (reader)
+ (rw:next-u32 reader))
+
+(defun write-u8 (writer x)
+ (rw:write-u8 writer x))
+
+(defun write-u16 (writer x)
+ (rw:write-u16 writer x))
+
+(defun write-u24 (writer x)
+ (assert (<= 0 x #.(1- (expt 2 24))))
+ (write-u8 writer (ash x -16))
+ (write-u8 writer (logand #xff (ash x -8)))
+ (write-u8 writer (logand #xff x)))
+
+(defun write-u32 (writer x)
+ (rw:write-u32 writer x))
+
+(defun fname (x)
+ (intern (format nil "~a" x)))
+
+(defun mname (x)
+ (intern (format nil "MAKE-~a" x)))
+
+(defun rname (x)
+ (intern (format nil "NEXT-~a" x)))
+
+(defun wname (x)
+ (intern (format nil "WRITE-~a" x)))
+
+(defmacro defenum (name (&key nbits) &body alist)
+ (let ((fname (fname name))
+ (sname (intern (format nil "~a-SYMBOLS" name)))
+ (cname (intern (format nil "~a-CODES" name)))
+ (rname (rname name))
+ (wname (wname name)))
+ `(let* ((alist ',alist)
+ (symbols (mapcar #'car alist))
+ (codes (mapcar #'cdr alist)))
+ (defun ,fname (x)
+ (etypecase x
+ (symbol (cdr (assoc x alist)))
+ (integer (car (rassoc x alist)))))
+ (defun ,sname () symbols)
+ (defun ,cname () codes)
+ (defun ,rname (reader)
+ (let ((z (,fname (, (ecase nbits
+ (8 'rw:next-u8)
+ (16 'rw:next-u16))
+ reader))))
+ (assert z)
+ z))
+ (defun ,wname (writer x)
+ (, (ecase nbits
+ (8 'rw:write-u8)
+ (16 'rw:write-u16))
+ writer
+ (etypecase x
+ (symbol (,fname x))
+ (integer (when (member x codes) x))))))))
+
+(defenum $AlertLevel (:nbits 8)
+ (WARNING . 1)
+ (FATAL . 2))
+
+(defenum $AlertDescription (:nbits 8)
+ (CLOSE_NOTIFY . 0)
+ (UNEXPECTED_MESSAGE . 10)
+ (BAD_RECORD_MAC . 20)
+ (DECRYPTION_FAILED_RESERVED . 21)
+ (RECORD_OVERFLOW . 22)
+ (DECOMPRESSION_FAILURE . 30)
+ (HANDSHAKE_FAILURE . 40)
+ (NO_CERTIFICATE_RESERVED . 41)
+ (BAD_CERTIFICATE . 42)
+ (UNSUPPORTED_CERTIFICATE . 43)
+ (CERTIFICATE_REVOKED . 44)
+ (CERTIFICATE_EXPIRED . 45)
+ (CERTIFICATE_UNKNOWN . 46)
+ (ILLEGAL_PARAMETER . 47)
+ (UNKNOWN_CA . 48)
+ (ACCESS_DENIED . 49)
+ (DECODE_ERROR . 50)
+ (DECRYPT_ERROR . 51)
+ (EXPORT_RESTRICTION_RESERVED . 60)
+ (PROTOCOL_VERSION . 70)
+ (INSUFFICIENT_SECURITY . 71)
+ (INTERNAL_ERROR . 80)
+ (USER_CANCELED . 90)
+ (NO_RENEGOTIATION . 100)
+ (UNSUPPORTED_EXTENSION . 110))
+
+(defenum $CipherSuite (:nbits 16)
+ (TLS_DHE_DSS_WITH_3DES_EDE_CBC_SHA . #X0013)
+ (TLS_DHE_DSS_WITH_AES_128_CBC_SHA . #X0032)
+ (TLS_DHE_DSS_WITH_AES_128_CBC_SHA256 . #X0040)
+ (TLS_DHE_DSS_WITH_AES_128_GCM_SHA256 . #X00A2)
+ (TLS_DHE_DSS_WITH_AES_256_CBC_SHA . #X0038)
+ (TLS_DHE_DSS_WITH_AES_256_CBC_SHA256 . #X006A)
+ (TLS_DHE_DSS_WITH_AES_256_GCM_SHA384 . #X00A3)
+ (TLS_DHE_DSS_WITH_CAMELLIA_128_CBC_SHA . #X0044)
+ (TLS_DHE_DSS_WITH_CAMELLIA_128_CBC_SHA256 . #X00BD)
+ (TLS_DHE_DSS_WITH_CAMELLIA_128_GCM_SHA256 . #XC080)
+ (TLS_DHE_DSS_WITH_CAMELLIA_256_CBC_SHA . #X0087)
+ (TLS_DHE_DSS_WITH_CAMELLIA_256_CBC_SHA256 . #X00C3)
+ (TLS_DHE_DSS_WITH_CAMELLIA_256_GCM_SHA384 . #XC081)
+ (TLS_DHE_DSS_WITH_RC4_128_SHA . #X0066)
+ (TLS_DHE_RSA_WITH_3DES_EDE_CBC_SHA . #X0016)
+ (TLS_DHE_RSA_WITH_AES_128_CBC_SHA . #X0033)
+ (TLS_DHE_RSA_WITH_AES_128_CBC_SHA256 . #X0067)
+ (TLS_DHE_RSA_WITH_AES_128_GCM_SHA256 . #X009E)
+ (TLS_DHE_RSA_WITH_AES_256_CBC_SHA . #X0039)
+ (TLS_DHE_RSA_WITH_AES_256_CBC_SHA256 . #X006B)
+ (TLS_DHE_RSA_WITH_AES_256_GCM_SHA384 . #X009F)
+ (TLS_DHE_RSA_WITH_CAMELLIA_128_CBC_SHA . #X0045)
+ (TLS_DHE_RSA_WITH_CAMELLIA_128_CBC_SHA256 . #X00BE)
+ (TLS_DHE_RSA_WITH_CAMELLIA_128_GCM_SHA256 . #XC07C)
+ (TLS_DHE_RSA_WITH_CAMELLIA_256_CBC_SHA . #X0088)
+ (TLS_DHE_RSA_WITH_CAMELLIA_256_CBC_SHA256 . #X00C4)
+ (TLS_DHE_RSA_WITH_CAMELLIA_256_GCM_SHA384 . #XC07D)
+ (TLS_DH_ANON_WITH_3DES_EDE_CBC_SHA . #X001B)
+ (TLS_DH_ANON_WITH_AES_128_CBC_SHA . #X0034)
+ (TLS_DH_ANON_WITH_AES_128_CBC_SHA256 . #X006C)
+ (TLS_DH_ANON_WITH_AES_256_CBC_SHA . #X003A)
+ (TLS_DH_ANON_WITH_AES_256_CBC_SHA256 . #X006D)
+ (TLS_DH_ANON_WITH_RC4_128_MD5 . #X0018)
+ (TLS_DH_DSS_WITH_3DES_EDE_CBC_SHA . #X000D)
+ (TLS_DH_DSS_WITH_AES_128_CBC_SHA . #X0030)
+ (TLS_DH_DSS_WITH_AES_128_CBC_SHA256 . #X003E)
+ (TLS_DH_DSS_WITH_AES_256_CBC_SHA . #X0036)
+ (TLS_DH_DSS_WITH_AES_256_CBC_SHA256 . #X0068)
+ (TLS_DH_RSA_WITH_3DES_EDE_CBC_SHA . #X0010)
+ (TLS_DH_RSA_WITH_AES_128_CBC_SHA . #X0031)
+ (TLS_DH_RSA_WITH_AES_128_CBC_SHA256 . #X003F)
+ (TLS_DH_RSA_WITH_AES_256_CBC_SHA . #X0037)
+ (TLS_DH_RSA_WITH_AES_256_CBC_SHA256 . #X0069)
+ (TLS_ECDHE_ECDSA_WITH_3DES_EDE_CBC_SHA . #XC008)
+ (TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA . #XC009)
+ (TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA256 . #XC023)
+ (TLS_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256 . #XC02B)
+ (TLS_ECDHE_ECDSA_WITH_AES_256_CBC_SHA . #XC00A)
+ (TLS_ECDHE_ECDSA_WITH_AES_256_CBC_SHA384 . #XC024)
+ (TLS_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384 . #XC02C)
+ (TLS_ECDHE_ECDSA_WITH_CAMELLIA_128_CBC_SHA256 . #XC072)
+ (TLS_ECDHE_ECDSA_WITH_CAMELLIA_128_GCM_SHA256 . #XC086)
+ (TLS_ECDHE_ECDSA_WITH_CAMELLIA_256_CBC_SHA384 . #XC073)
+ (TLS_ECDHE_ECDSA_WITH_CAMELLIA_256_GCM_SHA384 . #XC087)
+ (TLS_ECDHE_ECDSA_WITH_RC4_128_SHA . #XC007)
+ (TLS_ECDHE_RSA_WITH_3DES_EDE_CBC_SHA . #XC012)
+ (TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA . #XC013)
+ (TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA256 . #XC027)
+ (TLS_ECDHE_RSA_WITH_AES_128_GCM_SHA256 . #XC02F)
+ (TLS_ECDHE_RSA_WITH_AES_256_CBC_SHA . #XC014)
+ (TLS_ECDHE_RSA_WITH_AES_256_CBC_SHA384 . #XC028)
+ (TLS_ECDHE_RSA_WITH_AES_256_GCM_SHA384 . #XC030)
+ (TLS_ECDHE_RSA_WITH_CAMELLIA_128_CBC_SHA256 . #XC076)
+ (TLS_ECDHE_RSA_WITH_CAMELLIA_128_GCM_SHA256 . #XC08A)
+ (TLS_ECDHE_RSA_WITH_CAMELLIA_256_CBC_SHA384 . #XC077)
+ (TLS_ECDHE_RSA_WITH_CAMELLIA_256_GCM_SHA384 . #XC08B)
+ (TLS_ECDHE_RSA_WITH_RC4_128_SHA . #XC011)
+ (TLS_NULL_WITH_NULL_NULL . #X0000)
+ (TLS_RSA_WITH_3DES_EDE_CBC_SHA . #X000A)
+ (TLS_RSA_WITH_AES_128_CBC_SHA . #X002F)
+ (TLS_RSA_WITH_AES_128_CBC_SHA256 . #X003C)
+ (TLS_RSA_WITH_AES_128_GCM_SHA256 . #X009C)
+ (TLS_RSA_WITH_AES_256_CBC_SHA . #X0035)
+ (TLS_RSA_WITH_AES_256_CBC_SHA256 . #X003D)
+ (TLS_RSA_WITH_AES_256_GCM_SHA384 . #X009D)
+ (TLS_RSA_WITH_CAMELLIA_128_CBC_SHA . #X0041)
+ (TLS_RSA_WITH_CAMELLIA_128_CBC_SHA256 . #X00BA)
+ (TLS_RSA_WITH_CAMELLIA_128_GCM_SHA256 . #XC07A)
+ (TLS_RSA_WITH_CAMELLIA_256_CBC_SHA . #X0084)
+ (TLS_RSA_WITH_CAMELLIA_256_CBC_SHA256 . #X00C0)
+ (TLS_RSA_WITH_CAMELLIA_256_GCM_SHA384 . #XC07B)
+ (TLS_RSA_WITH_NULL_MD5 . #X0001)
+ (TLS_RSA_WITH_NULL_SHA . #X0002)
+ (TLS_RSA_WITH_NULL_SHA256 . #X003B)
+ (TLS_RSA_WITH_RC4_128_MD5 . #X0004)
+ (TLS_RSA_WITH_RC4_128_SHA . #X0005))
+
+(defenum $ClientCertificateType (:nbits 8)
+ (rsa_sign . 1)
+ (dss_sign . 2)
+ (rsa_fixed_dh . 3)
+ (dss_fixed_dh . 4)
+ (rsa_ephemeral_dh_RESERVED . 5)
+ (dss_ephemeral_dh_RESERVED . 6)
+ (fortezza_dms_RESERVED . 20))
+
+(defenum $CompressionMethod (:nbits 8)
+ (null . 0))
+
+(defenum $ContentType (:nbits 8)
+ (CHANGE_CIPHER_SPEC . 20)
+ (ALERT . 21)
+ (HANDSHAKE . 22)
+ (APPLICATION_DATA . 23))
+
+(defenum $ContentVersion (:nbits 16)
+ (SSL3.0 . #x0300)
+ (TLS1.2 . #x0303))
+
+(defenum $ExtensionType (:nbits 16)
+ (ec_point_formats . #x000b)
+ (elliptic_curves . #x000a)
+ (renegotiation_info . #xff01)
+ (SessionTicket_TLS . #x0023)
+ (server_name . #x0000)
+ (signature_algorithms . #x000d)
+ (status_request . #x0005))
+
+(defenum $HandshakeType (:nbits 8)
+ (HELLO_REQUEST . 0)
+ (CLIENT_HELLO . 1)
+ (SERVER_HELLO . 2)
+ (CERTIFICATE . 11)
+ (SERVER_KEY_EXCHANGE . 12)
+ (CERTIFICATE_REQUEST . 13)
+ (SERVER_HELLO_DONE . 14)
+ (CERTIFICATE_VERIFY . 15)
+ (CLIENT_KEY_EXCHANGE . 16)
+ (FINISHED . 20))
+
+(defenum $HashAlgorith (:nbits 8)
+ (none . 0)
+ (md5 . 1)
+ (sha1 . 2)
+ (sha224 . 3)
+ (sha256 . 4)
+ (sha384 . 5)
+ (sha512 . 6))
+
+(defenum $SignatureAlgorithm (:nbits 8)
+ (anonymous . 0)
+ (rsa . 1)
+ (dsa . 2)
+ (ecdsa . 3))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun PublicValueEncoding ()
+ ;; If the client has sent a certificate which contains a suitable
+ ;; Diffie-Hellman key (for fixed_dh client authentication), then
+ ;; Yc is implicit and does not need to be sent again. In this
+ ;; case, the client key exchange message will be sent, but it MUST
+ ;; be empty.
+ 'implicit)
+
+(defun KeyExchangeAlgorithm ()
+ ;; dhe_dss dhe_rsa dh_anon rsa dh_dss dh_rsa
+ 'dhe_rsa)
+
+;;;;;;;;;;;;;;
+
+(defun aname (struc &optional slot)
+ (intern (format nil "~a-~a" struc slot)))
+
+(defun defun-rname-slot (slot)
+ (destructuring-bind (ty na &key length size min max compute next) slot
+ `(,na
+ , (flet ((r1 ()
+ (if (listp ty)
+ `(ecase ,(cadr ty)
+ ,@(loop
+ for (nm ty) in (cddr ty)
+ collect (if ty
+ `(,nm (,(rname ty) r))
+ `(,nm))))
+ `(,(rname ty) r))))
+ (cond
+ ((or compute next)
+ (assert (eq 'computed ty))
+ (assert (not (or length size min max)))
+ (or compute next))
+ (length
+ `(let ((l (,(rname length) r))
+ (b (make-octet-buffer 100)))
+ ,@(when min `((assert (<= ,min l))))
+ ,@(when max `((assert (<= l ,max))))
+ ,@(when (integerp size) `((assert (= l ,size))))
+ (dotimes (i l)
+ (vector-push-extend (next-u8 r) b))
+ ,(if (eq 'u8 ty)
+ 'b
+ (if size
+ `(let ((r (rw:peek-reader (rw:reader b))))
+ (loop
+ while (rw:peek r)
+ collect ,(r1)))
+ `(let ((r (rw:reader b)))
+ ,(r1))))))
+ (size
+ (assert (eq 'u8 ty))
+ `(loop for i from 0 below ,size collect ,(r1)))
+ (t
+ `(let ((v ,(r1)))
+ ,@(when min `((assert (<= ,min v))))
+ ,@(when max `((assert (<= v ,max))))
+ v)))))))
+
+(defun defun-rname (name slots)
+ `(defun ,(rname name) (r)
+ (let* (,@(mapcar 'defun-rname-slot slots))
+ (,(mname name)
+ ,@(loop
+ for slot in slots
+ appending (let ((na (cadr slot)))
+ (list (intern (symbol-name na) :keyword) na)))))))
+
+(defun defun-wname (name slots)
+ `(defun ,(wname name) (w x)
+ ,@(loop
+ for slot in slots
+ collect
+ (destructuring-bind (ty na &key length size min max compute next) slot
+ (flet ((w1 ()
+ (if (listp ty)
+ (ecase (car ty)
+ (ecase `(ecase (,(aname name (cadr ty)) x)
+ ,@(loop
+ for (nm ty) in (cddr ty)
+ collect
+ (if ty
+ `(,nm (,(wname ty) w v))
+ `(,nm))))))
+ `(,(wname ty) w v))))
+ (cond
+ ((or compute next)
+ (assert (eq 'computed ty))
+ (assert (not (or length size min max)))
+ (when compute
+ `(setf (,(aname name na) x) ,compute)))
+ (length
+ `(let ((v (,(aname name na) x))
+ (b (make-octet-buffer 100)))
+ (let ((w (rw:writer b)))
+ ,(cond
+ (size
+ `(if (listp v)
+ (loop for v in v do ,(w1))
+ (loop for v across v do ,(w1))))
+ (t (w1))))
+ (let ((l (length b)))
+ ,@(when min `((assert (<= ,min l))))
+ ,@(when max `((assert (<= l ,max))))
+ ,@(when (integerp size) `((assert (= l ,size))))
+ (,(wname length) w l))
+ (loop for e across b do (write-u8 w e))))
+ (size
+ (assert (eq 'u8 ty))
+ `(let ((v (,(aname name na) x)))
+ ,@ (when (or min max (integerp size))
+ `((let ((l (length v)))
+ ,@(when min `((assert (<= ,min l))))
+ ,@(when max `((assert (<= l ,max))))
+ ,@(when (integerp size) `((assert (= l ,size)))))))
+ (if (listp v)
+ (loop for v in v do ,(w1))
+ (loop for v across v do ,(w1)))))
+ (t
+ `(let ((v (,(aname name na) x)))
+ ,@(when min `((assert (<= ,min v))))
+ ,@(when max `((assert (<= v ,max))))
+ ,(w1)))))))))
+
+(defmacro defstruc (name () &body slots)
+ `(progn
+ (defstruct ,(fname name) ,@(mapcar #'cadr slots))
+ ,(defun-rname name slots)
+ ,(defun-wname name slots)))
+
+(defstruc $Alert ()
+ ($AlertLevel level)
+ ($AlertDescription description))
+
+#+nil
+(defstruc $ASN.1Cert ()
+ (u8 data :min 0 :max #.(1- (expt 2 24))))
+
+(defstruc %$Certificate ()
+ (u8 #+nil $ASN.1Cert data :length u24 :min 0 :max #.(1- (expt 2 24)))
+ (computed der :next (rw.der:decode (rw:reader data))))
+
+(defstruc $Certificate ()
+ (%$Certificate list :length u24 :min 0 :max #.(1- (expt 2 24)) :size t))
+
+(defstruc $ClientDiffieHellmanPublic ()
+ (computed type :compute (PublicValueEncoding))
+ ((ecase type
+ (implicit)
+ (explicit $dh_Yc))
+ dh_public))
+
+(defstruc $ClientHello ()
+ ($ContentVersion #+nil $ProtocolVersion version)
+ ($Random random)
+ ($SessionID session_id)
+ ($CipherSuite cipher_suites :length u16 :min 2 :max #.(- (expt 2 16) 2) :size t)
+ ($CompressionMethod compression_methods :length u8 :min 1 :max #.(1- (expt 2 8)) :size t)
+ ($Extension extensions :length u16 :min 0 :max #.(1- (expt 2 16)) :size t))
+
+(defstruc $ClientKeyExchange ()
+ (computed type :compute (KeyExchangeAlgorithm))
+ ((ecase type
+ (rsa $EncryptedPreMasterSecret)
+ ((dhe_dss dhe_rsa dh_dss dh_rsa dh_anon) $ClientDiffieHellmanPublic))
+ keys))
+
+(defstruc $dh_Yc ()
+ (u8 data :length u16 :min 1 :max #.(1- (expt 2 16))))
+
+(defstruc $EncryptedPreMasterSecret ()
+ ($PreMasterSecret pubkey_encrypted))
+
+(defstruc $Extension ()
+ ($ExtensionType type)
+ #+nil
+ (ecase type
+ (status_request)
+ (server_name)
+ (renegotiation_info)
+ (SessionTicket_TLS)
+ (elliptic_curves)
+ (ec_point_formats)
+ (signature_algorithms))
+ (u8 data :length u16 :min 0 :max #.(1- (expt 2 16)) :size t))
+
+(defstruc $Handshake ()
+ ($HandshakeType type)
+ ((ecase type
+ (CERTIFICATE $Certificate)
+ (CLIENT_HELLO $ClientHello)
+ (CLIENT_KEY_EXCHANGE $ClientKeyExchange)
+ (SERVER_HELLO $ServerHello)
+ (SERVER_HELLO_DONE)
+ (SERVER_KEY_EXCHANGE #+nil $ServerKeyExchange))
+ data :length u24))
+
+(defstruc $PreMasterSecret ()
+ ($ContentVersion #+nil ProtocolVersion client_version)
+ (u8 random :size 46))
+
+(defstruc $Random ()
+ (u32 gmt_unix_time)
+ (u8 random_bytes :size 28))
+
+(defstruc $Record ()
+ ($ContentType type)
+ (u16 #+nil ContentVersion version)
+ ((ecase type
+ (ALERT $Alert)
+ (HANDSHAKE $Handshake))
+ data :length u16 :min 1 :max 16383)
+ #+nil
+ (u8 data :length u16 :min 1 :max 16383 :size t))
+
+#+nil
+(defstruc $ServerDHParams () ;;;;
+ (u8 dh_p :min 1 :max #.(1- (expt 2 16)) :size t)
+ (u8 dh_g :min 1 :max #.(1- (expt 2 16)) :size t)
+ (u8 dh_Ys :min 1 :max #.(1- (expt 2 16)) :size t))
+
+(defstruc %$ServerDHParams2 ()
+ ($ServerDHParams params)
+ ($signed_params signed_params))
+
+(defstruc $ServerHello ()
+ ($ContentVersion #+nil ProtocolVersion version)
+ ($Random random)
+ ($SessionID session_id)
+ ($CipherSuite cipher_suite)
+ ($CompressionMethod compression_method)
+ ($Extension extensions :length u16 :min 0 :max #.(1- (expt 2 16)) :size t))
+
+#+nil
+(defstruc $ServerKeyExchange ()
+ (u8 data :min 1 :max #.(1- (expt 2 16)) :size t)
+ #+nil
+ ($KeyExchangeAlgorithm type)
+ #+nil
+ ((ecase type
+ (dh_anon $ServerDHParams)
+ ((dhe_dss dhe_rsa) %$ServerDHParams2)
+ ((rsa dh_dss dh_rsa)))
+ data))
+
+(defstruc $SessionID ()
+ (u8 data :length u8 :min 0 :max 32 :size t))
+
+(defstruc $signed_params ()
+ (u8 client_random :size 32)
+ (u8 server_random :size 32)
+ ($ServerDHParams params2))
+
+;; struct {
+;; HashAlgorithm hash
+;; SignatureAlgorithm signature
+;; } SignatureAndHashAlgorithm
+
+;; SignatureAndHashAlgorithm
+;; supported_signature_algorithms<2..2^16-1>
+
+(defun make-octet-buffer (length)
+ (make-array length
+ :element-type '(unsigned-byte 8)
+ :initial-element 0
+ :adjustable t
+ :fill-pointer 0))
+
+(defun random-octets (length)
+ (loop
+ for i from 0 below length
+ collect (random 256)))
+
+(defun universal-time-to-unix (x)
+ (- x #.(encode-universal-time 0 0 0 1 1 1970 0)))
+
+;;(universal-time-to-unix (encode-universal-time 19 22 23 28 7 2014 0)) ;; TODO broken
+
+(defun test ()
+ (let ((b (make-octet-buffer 100)))
+ (write-$Record
+ (rw:writer b)
+ (make-$Record
+ :type 'HANDSHAKE
+ :version ($ContentVersion 'SSL3.0)
+ :data (make-$Handshake
+ :type 'CLIENT_HELLO
+ :data (make-$ClientHello
+ :version 'TLS1.2
+ :random (make-$Random
+ :gmt_unix_time (universal-time-to-unix (get-universal-time))
+ :random_bytes (random-octets 28))
+ :session_id (make-$SessionID #+nil :data #+nil(random-octets 32))
+ :cipher_suites '(TLS_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256
+ TLS_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384
+ TLS_ECDHE_ECDSA_WITH_CAMELLIA_128_GCM_SHA256
+ TLS_ECDHE_ECDSA_WITH_CAMELLIA_256_GCM_SHA384
+ TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA
+ TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA256
+ TLS_ECDHE_ECDSA_WITH_AES_256_CBC_SHA
+ TLS_ECDHE_ECDSA_WITH_AES_256_CBC_SHA384
+ TLS_ECDHE_ECDSA_WITH_CAMELLIA_128_CBC_SHA256
+ TLS_ECDHE_ECDSA_WITH_CAMELLIA_256_CBC_SHA384
+ TLS_ECDHE_ECDSA_WITH_3DES_EDE_CBC_SHA
+ TLS_ECDHE_ECDSA_WITH_RC4_128_SHA
+ TLS_ECDHE_RSA_WITH_AES_128_GCM_SHA256
+ TLS_ECDHE_RSA_WITH_AES_256_GCM_SHA384
+ TLS_ECDHE_RSA_WITH_CAMELLIA_128_GCM_SHA256
+ TLS_ECDHE_RSA_WITH_CAMELLIA_256_GCM_SHA384
+ TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA
+ TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA256
+ TLS_ECDHE_RSA_WITH_AES_256_CBC_SHA
+ TLS_ECDHE_RSA_WITH_AES_256_CBC_SHA384
+ TLS_ECDHE_RSA_WITH_CAMELLIA_128_CBC_SHA256
+ TLS_ECDHE_RSA_WITH_CAMELLIA_256_CBC_SHA384
+ TLS_ECDHE_RSA_WITH_3DES_EDE_CBC_SHA
+ TLS_ECDHE_RSA_WITH_RC4_128_SHA
+ TLS_RSA_WITH_AES_128_GCM_SHA256
+ TLS_RSA_WITH_AES_256_GCM_SHA384
+ TLS_RSA_WITH_CAMELLIA_128_GCM_SHA256
+ TLS_RSA_WITH_CAMELLIA_256_GCM_SHA384
+ TLS_RSA_WITH_AES_128_CBC_SHA
+ TLS_RSA_WITH_AES_128_CBC_SHA256
+ TLS_RSA_WITH_AES_256_CBC_SHA
+ TLS_RSA_WITH_AES_256_CBC_SHA256
+ TLS_RSA_WITH_CAMELLIA_128_CBC_SHA
+ TLS_RSA_WITH_CAMELLIA_128_CBC_SHA256
+ TLS_RSA_WITH_CAMELLIA_256_CBC_SHA
+ TLS_RSA_WITH_CAMELLIA_256_CBC_SHA256
+ TLS_RSA_WITH_3DES_EDE_CBC_SHA
+ TLS_RSA_WITH_RC4_128_SHA
+ TLS_RSA_WITH_RC4_128_MD5
+ TLS_DHE_RSA_WITH_AES_128_GCM_SHA256
+ TLS_DHE_RSA_WITH_AES_256_GCM_SHA384
+ TLS_DHE_RSA_WITH_CAMELLIA_128_GCM_SHA256
+ TLS_DHE_RSA_WITH_CAMELLIA_256_GCM_SHA384
+ TLS_DHE_RSA_WITH_AES_128_CBC_SHA
+ TLS_DHE_RSA_WITH_AES_128_CBC_SHA256
+ TLS_DHE_RSA_WITH_AES_256_CBC_SHA
+ TLS_DHE_RSA_WITH_AES_256_CBC_SHA256
+ TLS_DHE_RSA_WITH_CAMELLIA_128_CBC_SHA
+ TLS_DHE_RSA_WITH_CAMELLIA_128_CBC_SHA256
+ TLS_DHE_RSA_WITH_CAMELLIA_256_CBC_SHA
+ TLS_DHE_RSA_WITH_CAMELLIA_256_CBC_SHA256
+ TLS_DHE_RSA_WITH_3DES_EDE_CBC_SHA
+ TLS_DHE_DSS_WITH_AES_128_GCM_SHA256
+ TLS_DHE_DSS_WITH_AES_256_GCM_SHA384
+ TLS_DHE_DSS_WITH_CAMELLIA_128_GCM_SHA256
+ TLS_DHE_DSS_WITH_CAMELLIA_256_GCM_SHA384
+ TLS_DHE_DSS_WITH_AES_128_CBC_SHA
+ TLS_DHE_DSS_WITH_AES_128_CBC_SHA256
+ TLS_DHE_DSS_WITH_AES_256_CBC_SHA
+ TLS_DHE_DSS_WITH_AES_256_CBC_SHA256
+ TLS_DHE_DSS_WITH_CAMELLIA_128_CBC_SHA
+ TLS_DHE_DSS_WITH_CAMELLIA_128_CBC_SHA256
+ TLS_DHE_DSS_WITH_CAMELLIA_256_CBC_SHA
+ TLS_DHE_DSS_WITH_CAMELLIA_256_CBC_SHA256
+ TLS_DHE_DSS_WITH_3DES_EDE_CBC_SHA
+ TLS_DHE_DSS_WITH_RC4_128_SHA)
+ :compression_methods (list 'null)
+ :extensions (list
+ (make-$Extension :type 'status_request
+ :data '(1 0 0 0 0))
+ (make-$Extension :type 'server_name
+ :data '(0 #x10 0 0 #xd #x77 #x69 #x6b #x69 #x70 #x65 #x64 #x69 #x61 #x2e #x6f #x72 #x67))
+ (make-$Extension :type 'renegotiation_info
+ :data '(0))
+ (make-$Extension :type 'SessionTicket_TLS :data nil)
+ (make-$Extension :type 'elliptic_curves
+ :data '(0 10 0 #x13 0 #x15 0 #x17 0 #x18 0 #x19))
+ (make-$Extension :type 'ec_point_formats
+ :data '(1 0))
+ (make-$Extension :type 'signature_algorithms
+ :data '(0 #x1a 4 1 4 2 4 3 5 1 5 3 6 1 6 3 3 1 3 2 3 3 2 1 2 2 2 3)))))))
+ b))
+
+;;(print (test))
+
+(defun test2 ()
+ (let ((b (make-octet-buffer 100)))
+ (write-$Record
+ (rw:writer b)
+ (make-$Record
+ :type 'HANDSHAKE
+ :version ($ContentVersion 'SSL3.0)
+ :data (make-$Handshake
+ :type 'CLIENT_KEY_EXCHANGE
+ :data (make-$ClientKeyExchange
+ :keys (make-$ClientDiffieHellmanPublic
+ :dh_public nil)))))
+ b))
+
+;;(print (test2))
+
+(let ((saved (test)))
+ (with-open-file (s "/tmp/a"
+ :direction :output
+ :if-exists :supersede
+ :if-does-not-exist :create
+ :element-type '(unsigned-byte 8))
+ (write-sequence saved s))
+ (with-open-file (s "/tmp/a" :element-type '(unsigned-byte 8))
+ (next-$Record (rw:byte-reader s))
+ #+nil(next-$ClientHello (record-reader (rw:byte-reader s)))))
+
+(with-open-stream (s (rw.socket:make-tcp-client-socket "wikipedia.org" 443))
+ (write-sequence (test) s) ;; client hello
+ (finish-output s)
+ (print
+ (list (next-$Record (rw:byte-reader s)) ;; server hello
+ (next-$Record (rw:byte-reader s)) ;; certificate
+ (next-$Record (rw:byte-reader s)) ;; server key exchange
+ (next-$Record (rw:byte-reader s)) ;; server hello done
+ ))
+ ;;TLS_ECDHE_RSA_WITH_AES_128_GCM_SHA256
+ ;; client key exchange
+ (write-sequence (test2) s)
+ ;; change cipher spec
+ ;; multiple handshake messages
+ (finish-output)
+ #+nil
+ (list (next-$Record (rw:byte-reader s)) ;; new session ticket
+ (next-$Record (rw:byte-reader s)) ;; change cipher spec
+ (next-$Record (rw:byte-reader s)) ;; encrypted handshake message
+ )
+ ;; encrypted app data
+ )
