(define openssl-3.0.0 #x30000000)

(define ssl-port (make-parameter #f))
(define openssl (make-parameter #f))
(define csr-config-path (make-parameter #f))
(define private-key-path (make-parameter #f))
(define public-key-path (make-parameter #f))

(define (clean-up! path)
  (when path
    (delete-file* path)))

(on-exit
 (lambda ()
   (clean-up! (csr-config-path))
   (clean-up! (private-key-path))
   (clean-up! (public-key-path))))

(define (getenv key #!optional default)
  (or (get-environment-variable key) default))

;;https://gitlab.com/ariSun/myriam/-/blob/54e826226e26ac8a243f6be471bb164cf9d971e4/src/myriam.address.scm#L11-15
(define (unused-port)
  (let* ((listener (tcp-listen 0))
         (port (tcp-listener-port listener)))
    (tcp-close listener)
    port))

(define (create-keys!)
  (call-with-output-file (csr-config-path)
    (lambda (out)
      (display "[dn]
CN=localhost
[req]
distinguished_name = dn
[EXT]
subjectAltName=DNS:localhost
keyUsage=digitalSignature
extendedKeyUsage=serverAuth" out)))
  (system* (format "~a req -x509 -out ~a -keyout ~a -newkey rsa:2048 -nodes -sha256 -subj \"/CN=localhost\" -extensions EXT -config ~a"
                   (qs (openssl))
                   (qs (public-key-path))
                   (qs (private-key-path))
                   (qs (csr-config-path)))))

(define (start-server protocol)
  (parameterize ((server-port (ssl-port)))
    (let ((listener (ssl-listen* port: (ssl-port)
                                 protocol: protocol
                                 certificate: (public-key-path)
                                 private-key: (private-key-path))))
      (accept-loop listener ssl-accept))))

(define (start-client protocol)
  (define (make-http-server-connector)
    (lambda (uri proxy)
      (let ((remote-end (or proxy uri)))
        (case (uri-scheme remote-end)
          ((#f http) (tcp-connect (uri-host remote-end) (uri-port remote-end)))
          ((https) (ssl-connect* hostname: (uri-host remote-end)
                                 port: (uri-port remote-end)
                                 protocol: protocol
                                 sni-name: #t
                                 verify?: #f))
          (else (error "This shouldn't happen"))))))
  (parameterize ((server-connector (make-http-server-connector)))
    (let ((url (format "https://localhost:~a" (ssl-port))))
      (with-input-from-request url #f read-string))))

(openssl (or (getenv "OPENSSL_BINARY" "openssl")))
(csr-config-path (create-temporary-file ".conf"))
(private-key-path (create-temporary-file ".key"))
(public-key-path (create-temporary-file ".pem"))

(vhost-map `((".*" . ,(lambda (continue)
                       (send-response status: 'ok body: "")))))
(create-keys!)

(define-syntax protocol-test
  (syntax-rules ()
    ((_ tester client-protocol server-protocol)
     (let ((random-port (unused-port))
           (label (format "~a -> ~a" client-protocol server-protocol)))
       (parameterize ((ssl-port random-port)
                      (test-server-port random-port))
         (with-test-server
          (lambda ()
            (start-server server-protocol))
          (lambda ()
            (tester label (start-client client-protocol)))))))))

(define (compatible-protocol-test client-protocol server-protocol)
  (protocol-test test-assert client-protocol server-protocol))

(define (incompatible-protocol-test client-protocol server-protocol)
  (protocol-test test-error client-protocol server-protocol))

(test-group "Sanity check for supported protocol versions"
  (test-assert "Minimum supported SSL protocol in supported protocol list"
               (memv ssl-min-protocol supported-ssl-protocols))
  (test-assert "Maximum supported SSL protocol in supported protocol list"
               (memv ssl-max-protocol supported-ssl-protocols))
  (test-assert "TLSv1.2 is in supported protocol list"
               (memv 'tlsv12 supported-ssl-protocols)))

(test-group "Test protocol compatibility for TLSv1.2"
  (compatible-protocol-test 'tlsv12 'tlsv12)
  (compatible-protocol-test (cons 'tlsv12 ssl-max-protocol) 'tlsv12)
  (compatible-protocol-test 'tlsv12 (cons 'tlsv12 ssl-max-protocol)))

(test-group "Test protocol incompatibility between TLSv1.0/1.1 and TLSv1.2"
  ;; TLSv1.0 and TLSv1.1 have been deprecated as of OpenSSL3
  (when (< (openssl-version-number) openssl-3.0.0)
    (when (memv 'tlsv1 supported-ssl-protocols)
      (incompatible-protocol-test 'tlsv1 'tlsv12)
      (incompatible-protocol-test 'tlsv12 'tlsv1))
    (when (memv 'tlsv11 supported-ssl-protocols)
      (incompatible-protocol-test 'tlsv11 'tlsv12)
      (incompatible-protocol-test 'tlsv12 'tlsv11))))

(test-group "Test protocol incompatibility between TLSv1.2 and TLSv1.3"
  (when (memv 'tlsv13 supported-ssl-protocols)
    (incompatible-protocol-test 'tlsv12 'tlsv13)
    (incompatible-protocol-test 'tlsv13 'tlsv12)))