#!chezscheme
(library (socket ssl-ffi)
  (export ssl-ctx-new
          ssl-ctx-free
          tls-server-method
          ssl-ctx-use-certificate-file
          ssl-ctx-use-certificate-chain-file
          ssl-ctx-use-private-key-file
          ssl-filetype-pem
          ssl-new
          ssl-set-fd
          ssl-accept
          ssl-read
          ssl-write
          ssl-free
          bio-free
          bio-free-all
          bio-read
          bio-write
          bio-should-retry
          ssl-ctx-new
          ssl-ctx-load-verify-locations
          ssl-set-mode
          ssl-mode-auto-retry
          bio-set-conn-hostname
          bio-do-connect
          bio-get-ssl
          bio-new-ssl-connect
          tls-client-method
          )
  (import (chezscheme))
  ;; according to the man page, everything is automatically initialised, so this should not be needed...
  ;; (define (openssl-init-ssl opts settings)
  ;;   ((foreign-procedure "OPENSSL_init_ssl" (unsigned-64 void*) int) opts 0))
  (define-ftype %ssl (struct))
  (define-ftype %ssl_ctx (struct))
  (define-ftype %bio (struct))
  (define-ftype %ssl_method (struct))
  (define-ftype %ssl_cipher (struct))
  (define-ftype %x509 (struct))
  (define (err-load-bio-strings)
    ((foreign-procedure "ERR_load_BIO_strings" () int)))
  (define (bio-new-connect host-and-port)
    ((foreign-procedure "BIO_new_connect" (string) (* %bio)) host-and-port))
  (define (bio-new-socket sock close-flag)
    ((foreign-procedure "BIO_new_socket" (int int) (* %bio)) sock close-flag))
  (define (bio-new-accept host-and-port)
    ((foreign-procedure "BIO_new_accept" (string) (* %bio)) host-and-port))
  (define (bio-do-connect b)
    (bio-do-handshake b))
  (define (bio-do-accept b)
    (bio-do-handshake b))
  (define null 0)
  (define bio-c-do-state-machine 101)
  (define (bio-do-handshake b)
    (bio-ctrl b bio-c-do-state-machine 0 null))
  (define (bio-ctrl bp cmd larg parg)
    ((foreign-procedure "BIO_ctrl" ((* %bio) int long void*) long)
     bp cmd larg parg))
  (define (bio-ctrl/string bp cmd larg parg)
    ((foreign-procedure "BIO_ctrl" ((* %bio) int long string) long)
     bp cmd larg parg))
  (define (bio-free bio)
    ((foreign-procedure "BIO_free" ((* %bio)) int)
     bio))
  (define (bio-free-all bio)
    ((foreign-procedure "BIO_free_all" ((* %bio)) void)
     bio))
  (define (bio-read b bv offset length)
    ;; (let ((res (with-interrupts-disabled
    ;;             (let ((p (#%$object-address bv (+ (foreign-sizeof 'ptr) 1 offset))))
    ;;               ((foreign-procedure "BIO_read" ((* %bio) void* int) int)
    ;;                b p length)))))
    ;;   res)
    (let ((res (begin
                 (lock-object bv)
                 (let* ((p (#%$object-address bv (+ (foreign-sizeof 'ptr) 1 offset)))
                        (r ((foreign-procedure __collect_safe "BIO_read" ((* %bio) void* int) int)
                            b p length)))
                   (unlock-object bv)
                   r))))
      res))
  (define (bio-write b bv offset length)
    (with-interrupts-disabled
     (let ((p (#%$object-address bv (+ (foreign-sizeof 'ptr) 1 offset))))
       ((foreign-procedure __collect_safe "BIO_write" ((* %bio) void* int) int)
        b p length))))
  (define (bio-puts b string)
    ((foreign-procedure "BIO_puts" ((* %bio) string) int)
     b string))
  (define (ssl-ctx-new ssl-method)
    ((foreign-procedure "SSL_CTX_new" ((* %ssl_method)) (* %ssl_ctx))
     ssl-method))
  (define (ssl-ctx-free ctx)
    ((foreign-procedure "SSL_CTX_free" ((* %ssl_ctx)) void)
     ctx))
  (define (tls-client-method)
    ((foreign-procedure "TLS_client_method" () (* %ssl_method))))
  (define (tls-server-method)
    ((foreign-procedure "TLS_server_method" () (* %ssl_method))))
  (define (ssl-ctx-load-verify-locations ctx ca-file ca-path)
    (= 1 ((foreign-procedure "SSL_CTX_load_verify_locations" ((* %ssl_ctx) string string) int)
          ctx ca-file ca-path)))
  (define (bio-new-ssl-connect ctx)
    ((foreign-procedure "BIO_new_ssl_connect" ((* %ssl_ctx)) (* %bio))
     ctx))
  (define bio-c-get-ssl 110)
  (define (bio-get-ssl bio)
    (let ((ssl (foreign-alloc (foreign-sizeof 'void*))))
      (bio-ctrl bio bio-c-get-ssl 0 ssl)
      (make-ftype-pointer %ssl (foreign-ref 'void* 0 ssl))))
  (define (ssl-ctrl ssl cmd larg parg)
    ((foreign-procedure "SSL_ctrl" ((* %ssl) int long void*) long)
     ssl cmd larg parg))
  (define (ssl-set-mode ssl mode)
    (ssl-ctrl ssl ssl-ctrl-mode mode 0))
  (define ssl-ctrl-mode 33)
  (define ssl-mode-auto-retry #x4)
  (define bio-c-set-connect 100)
  (define (bio-set-conn-hostname bio host-and-port)
    (bio-ctrl/string bio bio-c-set-connect 0 host-and-port))
  (define (ssl-get-verify-result ssl)
    ((foreign-procedure "SSL_get_verify_result" ((* %ssl)) long)
     ssl))
  (define (err-get-error)
    ((foreign-procedure "ERR_get_error" () unsigned-long)))
  (define (err-reason-error-string errno)
    ((foreign-procedure "ERR_reason_error_string" (unsigned-long) string)
     errno))
  (define (ssl-get-peer-certificate ssl)
    ((foreign-procedure "SSL_get_peer_certificate" ((* %ssl)) (* %x509))
     ssl))
  (define (x509-free x509)
    ((foreign-procedure "X509_free" (void*) void)
     x509))
  (define (x509-verify-cert-error-string errno)
    ((foreign-procedure "X509_verify_cert_error_string" (long) string) errno))
  (define (ssl-get-version ssl)
    ((foreign-procedure "SSL_get_version" ((* %ssl)) string) ssl))
  (define (ssl-version ssl)
    ((foreign-procedure "SSL_version" ((* %ssl)) int) ssl))
  (define (ssl-client-version ssl)
    ((foreign-procedure "SSL_client_version" ((* %ssl)) int) ssl))
  (define (ssl-get-current-cipher ssl)
    ((foreign-procedure "SSL_get_current_cipher" ((* %ssl)) (* %ssl_cipher)) ssl))
  (define (ssl-cipher-get-version cipher)
    ((foreign-procedure "SSL_CIPHER_get_version" ((* %ssl_cipher)) string) cipher))
  (define (ssl-cipher-get-name cipher)
    ((foreign-procedure "SSL_CIPHER_get_name" ((* %ssl_cipher)) string) cipher))
  (define bio-flags-should-retry #x08)
  (define (bio-should-retry bio)
    (not (zero? (bio-test-flags bio bio-flags-should-retry))))
  (define (bio-test-flags bio flag)
    ((foreign-procedure "BIO_test_flags" ((* %bio) int) int)
     bio flag))
  (define ssl-filetype-pem 1)
  (define (ssl-ctx-use-certificate-file ctx file type)
    (let ((res ((foreign-procedure "SSL_CTX_use_certificate_file" ((* %ssl_ctx) string int) int)
                ctx file type)))
      (if (not (= 1 res))
          (error 'ssl-ctx-use-certificate-file "Error using certificate file" file (err-reason-error-string (err-get-error)))
          #t)))
  (define (ssl-ctx-use-certificate-chain-file ctx file)
    (let ((res ((foreign-procedure "SSL_CTX_use_certificate_chain_file" ((* %ssl_ctx) string) int)
                ctx file)))
      (if (not (= 1 res))
          (error 'ssl-ctx-use-certificate-chain-file "Error using certificate chain file" file (err-reason-error-string (err-get-error)))
          #t)))
  (define (ssl-ctx-use-private-key-file ctx file type)
    (let ((res ((foreign-procedure "SSL_CTX_use_PrivateKey_file" ((* %ssl_ctx) string int) int)
                ctx file type)))
      (if (not (= 1 res))
          (error 'ssl-ctx-use-private-key-file "Error using private key file" file (err-reason-error-string (err-get-error)))
          #t)))
  (define (ssl-set-fd ssl fd)
    ((foreign-procedure "SSL_set_fd" ((* %ssl) int) int)
     ssl fd))
  (define (ssl-accept ssl)
    (let ((res ((foreign-procedure "SSL_accept" ((* %ssl)) int)
                ssl)))
      (if (negative? res)
          (error 'ssl- "Error ssl accepting" (err-reason-error-string (err-get-error)))
          #t)))
  (define (ssl-write ssl bv)
    ((foreign-procedure "SSL_write" ((* %ssl) u8* int) int)
     ssl bv (bytevector-length bv)))
  (define (ssl-read ssl n)
    (let ((bv (make-bytevector n 0)))
      ((foreign-procedure "SSL_read" ((* %ssl) u8* int) int)
       ssl bv (bytevector-length bv))))
  (define (ssl-free ssl)
    ((foreign-procedure "SSL_free" ((* %ssl)) void) ssl))
  (define (ssl-new ctx)
    ((foreign-procedure "SSL_new" ((* %ssl_ctx)) (* %ssl)) ctx))
  (define (ssl-ctx-set-cipher-list ctx str)
    ((foreign-procedure "SSL_CTX_set_cipher_list" ((* %ssl_ctx) string) int) ctx str))
  (define (ssl-set-cipher-list ctx str)
    ((foreign-procedure "SSL_set_cipher_list" ((* %ssl) string) int) ctx str))
  (define (ssl-ctx-set-timeout ctx timeout)
    ((foreign-procedure "SSL_CTX_set_timeout" ((* %ssl_ctx) long) long)
     ctx timeout))
  (define (ssl-ctx-get-timeout ctx)
    ((foreign-procedure "SSL_CTX_get_timeout" ((* %ssl_ctx)) long)
     ctx))
  (define (openssl-version-num)
    ((foreign-procedure "OpenSSL_version_num" () unsigned-long)))
  (define openssl-version
    (case-lambda (()
                  (openssl-version 'version))
                 ((type)
                  (let ((t (case type
                             ((version) 0)
                             ((cflags) 1)
                             ((built-on) 2)
                             ((platform) 3)
                             ((dir) 4)
                             ((engines-dir) 5)
                             (else (error 'openssl-version "Unknown openssl version type" type)))))
                    ((foreign-procedure "OpenSSL_version" (int) string)
                     t)))))
  (load-shared-object "libssl.so")

;;;; tests
  ;; (define (check-err)
  ;;   (let ((e (err-reason-error-string (err-get-error))))
  ;;     (when e
  ;;       (display "Error: ")
  ;;       (display e)
  ;;       (newline))))

  ;; (define (test-ssl host port)
  ;;   (define ctx (ssl-ctx-new (tls-client-method)))
  ;;   (check-err)
  ;;   (display "loading certs: ") (display (ssl-ctx-load-verify-locations ctx "/etc/ssl/certs/ca-certificates.crt" #f)) (newline)
  ;;   (check-err)
  ;;   (let* ((bio (bio-new-ssl-connect ctx))
  ;;          (ssl (bio-get-ssl bio)))
  ;;     (check-err)
  ;;     (ssl-set-mode ssl ssl-mode-auto-retry)
  ;;     (check-err)
  ;;     (bio-set-conn-hostname bio (format "~a:~a" host port))
  ;;     (check-err)
  ;;     (bio-do-connect bio)
  ;;     (check-err)
  ;;     (let ((cert (ssl-get-peer-certificate ssl)))
  ;;       (if (zero? cert)
  ;;           (display "no certificate\n")
  ;;           (begin (display "cert received\n")
  ;;                  (x509-free cert))))
  ;;     (display "verify result: ") (display (x509-verify-cert-error-string (ssl-get-verify-result ssl))) (newline)
  ;;     (display "SSL version: ") (display (ssl-get-version ssl)) (newline)
  ;;     (let ((c (ssl-get-current-cipher ssl)))
  ;;       (display "Cipher: ") (display (ssl-cipher-get-name c)) (display " ") (display (ssl-cipher-get-version c)) (newline))
  ;;     (ssl-ctx-free ctx)
  ;;     (check-err)
  ;;     (bio-puts bio (format "GET / HTTP/1.1\r\nHost: ~a\r\nConnection: close\r\n\r\n" host))
  ;;     (check-err)
  ;;     (let ((in (make-bytevector 1024 0)))
  ;;       (bio-read bio in 1024))))

  ;; (define (test-no-ssl host port)
  ;;   (define bio (bio-new-connect (format "~a:~a" host port)))
  ;;   (bio-do-connect bio)
  ;;   (bio-puts bio (format "GET / HTTP/1.1\r\nHost: ~a\r\nConnection: close\r\n\r\n" host))
  ;;   (bio-read bio 1024))

  ;; (define (test-ssl-server port)
  ;;   (let ((ctx (ssl-ctx-new (tls-server-method))))
  ;;     (ssl-ctx-use-certificate-file ctx "/path/to/crt" ssl-filetype-pem)
  ;;     (ssl-ctx-use-private-key-file ctx "/path/to/key" ssl-filetype-pem)
  ;;     (let ((s (let ((sock (socket 'inet 'stream 'ip))) ;; (if blocking? '(stream) '(stream non-blocking))
  ;;                (bind sock (alloc-%sockaddr-in port +inaddr-any+))
  ;;                (listen sock 1)
  ;;                sock)))
  ;;       (let loop ((client (accept4 s #f '())))
  ;;         (display "client connected...") (newline)
  ;;         (close client)
  ;;         (loop)))))
  )
