(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) (receive (in out)
                       (ssl-connect* hostname: (uri-host remote-end)
                                     port: (uri-port remote-end)
                                     protocol: protocol
                                     sni-name: #t
                                     verify?: #f)
                     (if (and in out) ; Ugly, but necessary
                         (values in out)
                         (error "You forgot to install the openssl egg."))))
          (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-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))

(compatible-protocol-test ssl-min-protocol ssl-min-protocol)
(compatible-protocol-test ssl-max-protocol ssl-max-protocol)
(compatible-protocol-test ssl-min-protocol (cons ssl-min-protocol ssl-max-protocol))
(compatible-protocol-test ssl-max-protocol (cons ssl-min-protocol ssl-max-protocol))
(compatible-protocol-test (cons ssl-min-protocol ssl-max-protocol) 'tlsv11)
(compatible-protocol-test (cons 'tlsv11 ssl-max-protocol) ssl-max-protocol)
(compatible-protocol-test (cons ssl-min-protocol ssl-max-protocol) (cons ssl-min-protocol ssl-max-protocol))
(compatible-protocol-test (cons ssl-min-protocol ssl-max-protocol) (cons 'tlsv11 ssl-max-protocol))
(incompatible-protocol-test ssl-min-protocol ssl-max-protocol)
(incompatible-protocol-test ssl-max-protocol ssl-min-protocol)
(incompatible-protocol-test ssl-min-protocol (cons 'tlsv11 ssl-max-protocol))
(incompatible-protocol-test (cons 'tlsv11 ssl-max-protocol) ssl-min-protocol)