scheme-libraries/retropikzel/tls.scm

;; Context
(define-record-type <tls-context>
  (internal-make-tls-context version
                             random-bytes
                             session-id
                             hello-cipher-suite
                             compression-method)
  tls-context?
  (version tls-context-version)
  (random-bytes tls-context-random-bytes)
  (session-id tls-context-session-id)
  (hello-cipher-suite tls-context-hello-cipher-suite)
  (compression-method tls-context-compression-method))

(define make-tls-context
  (lambda options
    (when (not (null? options))
      (error "make-tls-context error: No options are currently supported" options))
    (internal-make-tls-context (tls-version-bytes *tls-1.2*)
                               (get-random-bytes 28)
                               (make-bytevector 32 0)
                               (get-hello-cipher-suite-bytes 'TLS_ECDHE_RSA_WITH_AES_256_CBC_SHA384)
                               (bytevector 0))))


;; Version
;; https://datatracker.ietf.org/doc/html/rfc5246#section-6.2
(define-record-type <tls-version>
  (make-tls-version name major minor bytes)
  tls-version?
  (name tls-version-name)
  (major tls-version-major)
  (minor tls-version-minor)
  (bytes tls-version-bytes))

(define *tls-1.2* (make-tls-version "tls-1.2" 3 3 (bytevector 3 3)))


;; Hello Cipher Suites
(define (get-hello-cipher-suite-bytes name)
  (cond ((equal? name 'TLS_ECDHE_RSA_WITH_AES_256_CBC_SHA384) (bytevector 0 61))
        (else (error "get-hello-cipher-suite-bytes error: Unsupported name" name))))

;; ContentType
(define (get-content-type-bytes name)
  (cond ((equal? name 'ChangeChipherSpec) (bytevector 20))
        ((equal? name 'Alert) (bytevector 21))
        ((equal? name 'Handshake) (bytevector 22))
        ((equal? name 'Application) (bytevector 23))
        ((equal? name 'HeartBeat (bytevector 24)))
        (else (error "get-content-type-bytes error: Unknown name" name))))
(define (get-content-type-name byte)
  (cond ((= byte 20) 'ChangeChipherSpec)
        ((= byte 21) 'Alert)
        ((= byte 22) 'Handshake)
        ((= byte 23) 'Application)
        ((= byte 24) 'HeartBeat)
        (else (error "get-content-type-name error: Unknown byte" byte))))


;; HandshakeType
(define (get-handshake-type-bytes name)
  (cond ((equal? name 'Hellorequest) (bytevector 0))
        ((equal? name 'ClientHello) (bytevector 1))
        ((equal? name 'ServerHello) (bytevector 2))
        ((equal? name 'NewSessionTicket) (bytevector 4))
        ((equal? name 'EncryptedExtensions) (bytevector 8)) ;; TLS 1.3 Only
        ((equal? name 'Certificate) (bytevector 11))
        ((equal? name 'ServerKeyExhange) (bytevector 12))
        ((equal? name 'CertificateRequest) (bytevector 13))
        ((equal? name 'ServerHelloDone) (bytevector 14))
        ((equal? name 'CertificateVerify) (bytevector 15))
        ((equal? name 'ClientKeyExchange) (bytevector 16))
        ((equal? name 'Finished) (bytevector 20))
        (else (error "get-handshake-type-bytes error: Unknown name" name))))

(define-record-type <tls-record>
  (internal-make-tls-record type version length bytes)
  tls-record?
  (type tls-record-type)
  (version tls-record-version)
  (length tls-record-length)
  (bytes tls-record-bytes))

(define (bytes->tls-record bytes)
  (let ((type (get-content-type-name (bytevector-u8-ref bytes 0)))
        (version (bytevector (bytevector-u8-ref bytes 1)
(bytevector-u8-ref bytes 2)))
        )
    (internal-make-tls-record type version #f #f)
  ))


(define (make-tls-record context content-type fragment-bytes)
  (bytevector-append
    (get-content-type-bytes content-type)
    (tls-context-version context)
    (integer->uint16-bytevector (bytevector-length fragment-bytes))
    fragment-bytes))

;; Handshake
(define (make-tls-handshake-client-hello context)
  (make-tls-record context
                   'Handshake
                   (bytevector-append
                     (tls-context-version context)
                     (integer->uint32-bytevector (current-second-integer))
                     (tls-context-random-bytes context)
                     (tls-context-session-id context)
                     (tls-context-hello-cipher-suite context)
                     (tls-context-compression-method context)
                     )))


#;(define (make-tls-record type version message-bytes data)
  (when (not (tls-content-type? type))
    (error "make-tls-record error: type must be be <tls-content-type>" type))
  (when (not (tls-version? version))
    (error "make-tls-record error: version must be <tls-version>" version))
  (when (not (bytevector? message-bytes))
    (error "make-tls-record error: message-bytes must be bytevector" message-bytes))
  (when (> (bytevector-length message-bytes) 16384) ;; length MUST NOT exceed 2^14
    (error "make-tls-record error: message-byte length too big"))
  (let* ((len (bytevector-length message-bytes))
         (bytes (bytevector-append
                  (tls-content-type-bytes type)
                  (tls-version-bytes version)
                  (integer->uint16-bytevector len)
                  ;; TODO: Add MAC (optional)
                  ;; TODO: Add padding (block chiphers only)
                  message-bytes)))
    (internal-make-tls-record type version bytes data)))


#;(define (make-tls-handshake-record type version)
  (when (not (tls-handshake-type? type))
    (error "make-tls-handshake-record error: type must be <tls-handshake-type>" type))
  (when (not (tls-version? version))
    (error "make-tls-handshake-record error: version must be <tls-version>" version))
  (cond
    ;; https://datatracker.ietf.org/doc/html/rfc5246#section-7.4.1.2
    ((equal? type *client-hello*)
     (let* ((message-bytes (bytevector))
            (message-bytes-length (bytevector-length message-bytes))
            (header-bytes (bytevector-append
                            (tls-content-type-bytes *handshake*)
                            (integer->uint24-bytevector message-bytes-length)
                            (integer->uint32-bytevector (current-second-integer))
                            )))
       (make-tls-record *handshake*
                        version
                        message-bytes
                        )))
    (else (error "make-tls-handshake-type error: type not yet supported" type))))

#;(define (tls-handshake reader writer)
  #t)