186 lines
8.8 KiB
Scheme
186 lines
8.8 KiB
Scheme
;; If you hacking on this you best read the spec
|
|
;; https://datatracker.ietf.org/doc/html/rfc5246
|
|
|
|
(define versions '((tls-1.0 . #u8(3 1)) (tls-1.2 . #u8(3 3))))
|
|
(define cipher-suites
|
|
;; First is the default
|
|
'((TLS_RSA_WITH_AES_256_CBC_SHA . #u8(0 #x35))))
|
|
|
|
(define (make-tls-record version content-type fragment-bytes)
|
|
(let ((length-bytes (bytevector 0 0)))
|
|
(bytevector-uint-set! length-bytes 0 (bytevector-length fragment-bytes) 'big 2)
|
|
(bytevector-append
|
|
(bytevector (cdr (assoc content-type content-types)))
|
|
(cdr (assoc version versions))
|
|
length-bytes
|
|
fragment-bytes)))
|
|
|
|
(define (make-client-hello version random-bytes session-id cipher-suites)
|
|
;; https://datatracker.ietf.org/doc/html/rfc5246#section-7.4.1.2
|
|
(let* ((cipher-suites-length-bytes
|
|
(integer->bytevector (bytevector-length cipher-suites) 'big 2))
|
|
(content-bytes
|
|
(bytevector-append (cdr (assoc version versions))
|
|
random-bytes
|
|
session-id
|
|
cipher-suites-length-bytes
|
|
cipher-suites
|
|
(bytevector 1 0)
|
|
(bytevector 0 0)))
|
|
(content-length-bytes
|
|
(let ((bytes (bytevector 0 0 0)))
|
|
(bytevector-uint-set!
|
|
bytes 0 (bytevector-length content-bytes) 'big 3)
|
|
bytes)))
|
|
;; https://tls12.xargs.org/#client-hello
|
|
;; Interestingly the version is 3.1 (TLS 1.0) instead of the expected "3,3"
|
|
;; (TLS 1.2). Looking through the golang crypto/tls library we find the following comment:
|
|
;; // Some TLS servers fail if the record version is
|
|
;; // greater than TLS 1.0 for the initial ClientHello.
|
|
(make-tls-record 'tls-1.0
|
|
'handshake
|
|
(bytevector-append
|
|
(bytevector (cdr (assoc 'client_hello handshake-types)))
|
|
content-length-bytes
|
|
content-bytes))))
|
|
|
|
(define (read-tls-record receiver)
|
|
(let* ((type-byte (receiver 1))
|
|
(type (cdr (assoc (bytevector-u8-ref type-byte 0) types-content)))
|
|
(version (receiver 2))
|
|
(len-bytes (receiver 2))
|
|
(len (bytevector-uint-ref len-bytes 0 'big 2))
|
|
(bytes (receiver len)))
|
|
(display "HERE: type-byte ")
|
|
(write type-byte)
|
|
(newline)
|
|
(display "HERE: type ")
|
|
(write type)
|
|
(newline)
|
|
(display "HERE: version ")
|
|
(write version)
|
|
(newline)
|
|
(display "HERE: len-bytes ")
|
|
(write len-bytes)
|
|
(newline)
|
|
(display "HERE: len ")
|
|
(write len)
|
|
(newline)
|
|
;(display "HERE: bytes ")
|
|
;(write bytes)
|
|
;(newline)
|
|
(cond
|
|
;; https://datatracker.ietf.org/doc/html/rfc5246#section-7.2
|
|
((equal? type 'alert)
|
|
(if (= (bytevector-u8-ref bytes 0) 2) ;; Fatal
|
|
(error "TLS Alert: " (cdr (assoc (bytevector-u8-ref bytes 1) types-alert)))
|
|
(warn (cdr (assoc (bytevector-u8-ref bytes 1) types-alert)))))
|
|
((equal? type 'handshake)
|
|
(let ((type (cdr (assoc (bytevector-u8-ref bytes 0) types-handshake))))
|
|
(cond
|
|
;; https://datatracker.ietf.org/doc/html/rfc5246#section-7.4.1.3
|
|
((equal? type 'server_hello)
|
|
(let ((session-id-length (bytevector-u8-ref bytes 38)))
|
|
`(server_hello
|
|
(type . ,(bytevector-copy bytes 0 1))
|
|
(size . ,(bytevector-uint-ref bytes 1 'big 3))
|
|
(version . ,(bytevector-copy bytes 4 6))
|
|
(server-random . ,(bytevector-copy bytes 6 38))
|
|
(session-id-length ,session-id-length)
|
|
(session-id . ,(if (= session-id-length 0)
|
|
(bytevector)
|
|
(bytevector-copy bytes 39 (+ 39 session-id-length))))
|
|
(cipher-suite .
|
|
,(bytevector-copy bytes
|
|
(+ 39 session-id-length)
|
|
(+ 39 session-id-length 2)))
|
|
(compression . ,(bytevector-copy bytes
|
|
(+ 39 session-id-length 2)
|
|
(+ 39 session-id-length 3))))))
|
|
;; https://datatracker.ietf.org/doc/html/rfc5246#section-7.4.2
|
|
;; https://tls12.xargs.org/certificate.html#server-certificate-detail/annotated
|
|
((equal? type 'certificate)
|
|
(let* ((one 1)
|
|
(ASN.1-length1 (bytevector-u8-ref bytes 11))
|
|
(ASN.1-length2 (bytevector-u8-ref bytes (+ 14 ASN.1-length1)))
|
|
(certificate-length (bytevector-uint-ref bytes 7 'big 3))
|
|
)
|
|
`(certificate
|
|
(handshake-message-len . ,(bytevector-copy bytes 1 4))
|
|
(handshake-message-len . ,(bytevector-uint-ref bytes 1 'big 3))
|
|
(certificates-len . ,(bytevector-copy bytes 4 7))
|
|
(certificates-len . ,(bytevector-uint-ref bytes 4 'big 3))
|
|
(certificate-len . ,(bytevector-copy bytes 7 10))
|
|
(certificate-len . ,(bytevector-uint-ref bytes 7 'big 3))
|
|
(certificate ,(read-certificates bytes 10))
|
|
#;(test ,(bytevector-copy bytes
|
|
10
|
|
64
|
|
))
|
|
;(certificate-length . ,(bytevector-copy bytes 7 10))
|
|
;(certificate-length . ,(bytevector-uint-ref bytes 7 'big 3))
|
|
;(certificates-sequence-tag . ,(bytevector-u8-ref bytes 10))
|
|
;(certificates-sequence-len . ,(bytevector-uint-ref bytes 11 'big 3))
|
|
;(certificates ,(read-certificates bytes 10 (bytevector-length bytes) '()))
|
|
#;(test ,(bytevector-copy bytes
|
|
(+ 10 2 130 2 21)
|
|
(+ 10 2 130 2 21 512)
|
|
))
|
|
;(ASN.1-tag1 . ,(bytevector-u8-ref bytes 10))
|
|
;(ASN.1-length1 . ,(bytevector-u8-ref bytes 11))
|
|
;(ASN.1-length . ,(bytevector-uint-ref bytes 11 'big 3))
|
|
;(ASN.1-length2 . ,ASN.1-length2)
|
|
;(certificate-bytes1 . ,(bytevector-copy bytes 12 (+ 12 ASN.1-length1 1)))
|
|
#;(certificate-bytes2 . ,(bytevector-copy bytes
|
|
(+ 12 ASN.1-length1 1)
|
|
(+ 12 ASN.1-length1 1 ASN.1-length2)))
|
|
#;(test . ,(bytevector-copy bytes
|
|
(+ 12 ASN.1-length1 1 ASN.1-length2)
|
|
(+ 12 ASN.1-length1 1 ASN.1-length2 64)))
|
|
;(bytes-len ,(bytevector-length bytes))
|
|
#;(certificates . ,(read-certificates bytes
|
|
10
|
|
(bytevector-length bytes)
|
|
'()))
|
|
|
|
|
|
|
|
;(version . ,(bytevector-u8-ref bytes 4))
|
|
;; https://datatracker.ietf.org/doc/html/rfc5280#section-4.1.2.2
|
|
;(serial-number . ,(bytevector-u8-ref bytes 5))
|
|
;; https://datatracker.ietf.org/doc/html/rfc5280#section-4.1.2.3
|
|
;(signature . ,(bytevector-u8-ref bytes 6))
|
|
))
|
|
)))))))
|
|
|
|
(define (tls-client-handshake sender receiver . options)
|
|
(let* ((version 'tls-1.2) ;; Default, and currently only one
|
|
;; No unix time as first four bytes of random-bytes
|
|
;; https://datatracker.ietf.org/doc/html/draft-mathewson-no-gmtunixtime-00
|
|
(random-bytes (get-random-bytes 32))
|
|
(session-id (bytevector 0))
|
|
(client-hello (make-client-hello version
|
|
random-bytes
|
|
session-id
|
|
(cdr (car cipher-suites)))))
|
|
(display "HERE: client-hello ")
|
|
(write client-hello)
|
|
(newline)
|
|
(sender client-hello)
|
|
(let ((server-hello (read-tls-record receiver)))
|
|
(when (not (equal? (car server-hello) 'server_hello))
|
|
(error "tls error: Unexpected response from server, expected server_hello"
|
|
server-hello))
|
|
(let ((server-version-bytes (cdr (assoc 'version (cdr server-hello))))
|
|
(client-version-bytes (cdr (assoc version versions))))
|
|
(when (not (equal? client-version-bytes server-version-bytes))
|
|
(error "tls error: Client server version mismatch"
|
|
client-version-bytes
|
|
server-version-bytes))
|
|
(write server-hello)
|
|
(newline)
|
|
(let ((certificate (read-tls-record receiver)))
|
|
(write certificate)
|
|
(newline)
|
|
)))))
|