;;;; openssl.scm
;;;; Bindings to the OpenSSL SSL/TLS library

(module openssl
  (
   ssl-connect
   ssl-make-client-context
   ssl-client-context?
   ssl-listen
   ssl-close
   ssl-port?
   ssl-port->tcp-port
   ssl-listener?
   ssl-listener?
   ssl-listener-port
   ssl-listener-fileno
   ssl-accept-ready?
   ssl-accept
   ssl-handshake-timeout
   ssl-shutdown-timeout
   ssl-load-certificate-chain!
   ssl-load-private-key!
   ssl-set-verify!
   ssl-load-verify-root-certificates!
   ssl-load-suggested-certificate-authorities!)

(import scheme chicken foreign ports)

(declare
 (usual-integrations)
 (no-procedure-checks-for-usual-bindings)
 (bound-to-procedure
   ##sys#update-errno
   ##sys#signal-hook
   ##sys#string-append
   ##sys#tcp-port->fileno
   ##sys#current-thread
   ##sys#size
   ##sys#setslot
   ##sys#check-string
   ##sys#expand-home-path))

(use srfi-18 tcp)

#>
#include <errno.h>
#ifdef _WIN32
  #ifdef _MSC_VER
    #include <winsock2.h>
  #else
    #include <ws2tcpip.h>
  #endif

  #include <openssl/rand.h>
#else
  #define closesocket     close
#endif

#ifdef ECOS
  #include <sys/sockio.h>
#else
  #include <unistd.h>
#endif

#include <openssl/err.h>
#include <openssl/ssl.h>
<#

(foreign-code #<<EOF
ERR_load_crypto_strings();
SSL_load_error_strings();
SSL_library_init();

#ifdef _WIN32
  RAND_screen();
#endif

EOF
)

;;; support routines

(define-foreign-variable strerror c-string "strerror(errno)")

(define ssl-handshake-timeout (make-parameter 120000))
(define ssl-shutdown-timeout (make-parameter 120000))

(define (net-close-socket fd)
  (when ((foreign-lambda bool "closesocket" int) fd)
    (##sys#update-errno)
    (##sys#signal-hook
     network-error: 'net-close-socket
     (##sys#string-append "can not close socket - " strerror)
     fd)))

(define (net-unwrap-tcp-ports tcp-in tcp-out)
  (let ((fd (##sys#tcp-port->fileno tcp-in)))
    (tcp-abandon-port tcp-in)
    (tcp-abandon-port tcp-out)
    fd))

(define (ssl-abort loc sym . args)
  (let ((err ((foreign-lambda unsigned-long "ERR_get_error"))))
    (abort
     (make-composite-condition
      (make-property-condition
       'exn
       'message
       (string-append
	(if sym
	    (symbol->string sym)
	    "error")
	": library="
	(or
	 ((foreign-lambda c-string "ERR_lib_error_string" unsigned-long)
	  err)
	 "<unknown>")
	", function="
	(or
	 ((foreign-lambda c-string "ERR_func_error_string" unsigned-long)
	  err)
	 "<unknown>")
	", reason="
	(or
	 ((foreign-lambda c-string "ERR_reason_error_string" unsigned-long)
	  err)
	 "<unknown>"))
       'location
       loc
       'arguments args)
      (make-property-condition
       'i/o)
      (make-property-condition
       'net)
      (make-property-condition
       'openssl
       'status
       sym)))))

(define ssl-ctx-free (foreign-lambda void "SSL_CTX_free" c-pointer))

(define (ssl-ctx-new protocol server)
  (let ((ctx
	 ((foreign-lambda*
	   c-pointer ((c-pointer method))
	   "SSL_CTX *ctx;"
	   "if ((ctx = SSL_CTX_new((SSL_METHOD *)method)))\n"
	   "  SSL_CTX_set_mode(ctx, SSL_MODE_ENABLE_PARTIAL_WRITE | "
           "                        SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER);\n"
	   "return(ctx);\n")
	  (case protocol
	    ((sslv2-or-v3)
	     (if server
		 ((foreign-lambda c-pointer "SSLv23_server_method"))
		 ((foreign-lambda c-pointer "SSLv23_client_method"))))
	    ((sslv2)
	     (if server
		 ((foreign-lambda c-pointer "SSLv2_server_method"))
		 ((foreign-lambda c-pointer "SSLv2_client_method"))))
	    ((sslv3)
	     (if server
		 ((foreign-lambda c-pointer "SSLv3_server_method"))
		 ((foreign-lambda c-pointer "SSLv3_client_method"))))
	    ((tls)
	     (if server
		 ((foreign-lambda c-pointer "TLSv1_server_method"))
		 ((foreign-lambda c-pointer "TLSv1_client_method"))))
	    (else
	     (abort
	      (make-composite-condition
	       (make-property-condition
		'exn
		'message "invalid SSL/TLS connection protocol"
		'location 'ssl-ctx-new
		'arguments (list protocol))
	       (make-property-condition
		'type))))))))
    (unless ctx (ssl-abort 'ssl-ctx-new #f))
    (set-finalizer! ctx ssl-ctx-free)
    ctx))

(define (ssl-new ctx)
  (cond
   (((foreign-lambda c-pointer "SSL_new" c-pointer) ctx)
    => values)
   (else
    (ssl-abort 'ssl-new #f))))

(define ssl-free (foreign-lambda void "SSL_free" c-pointer))

(define (ssl-result-or-abort loc ssl ret allow-i/o? . args)
  (call-with-current-continuation
   (lambda (q)
     (let ((sym
	    (let ((x ((foreign-lambda int "SSL_get_error" c-pointer int)
                      ssl ret)))
	      (cond
               ((eq? x (foreign-value "SSL_ERROR_NONE" int))
                (q ret))
               ((eq? x (foreign-value "SSL_ERROR_ZERO_RETURN" int))
                'zero-return)
               ((eq? x (foreign-value "SSL_ERROR_WANT_READ" int))
                (if allow-i/o?
                    (q 'want-read)
                    'want-read))
               ((eq? x (foreign-value "SSL_ERROR_WANT_WRITE" int))
                (if allow-i/o?
                    (q 'want-write)
                    'want-write))
               ((eq? x (foreign-value "SSL_ERROR_WANT_CONNECT" int))
		'want-connect)
               ((eq? x (foreign-value "SSL_ERROR_WANT_ACCEPT" int))
                'want-accept)
               ((eq? x (foreign-value "SSL_ERROR_WANT_X509_LOOKUP" int))
                'want-X509-lookup)
               ((eq? x (foreign-value "SSL_ERROR_SYSCALL" int))
                'syscall)
               ((eq? x (foreign-value "SSL_ERROR_SSL" int))
                'ssl)
               (else
                #f)))))
       (apply ssl-abort loc sym args)))))

(define (ssl-set-fd! ssl fd)
  (ssl-result-or-abort
   'ssl-set-fd! ssl
   ((foreign-lambda int "SSL_set_fd" c-pointer int) ssl fd) #f
   fd)
  (void))

(define (ssl-shutdown ssl)
  (let ((ret
	 ((foreign-lambda*
	   scheme-object ((c-pointer ssl))
	   "int ret;\n"
	   "switch (ret = SSL_shutdown((SSL *)ssl)) {\n"
	   "case 0: return(C_SCHEME_FALSE);\n"
	   "case 1: return(C_SCHEME_TRUE);\n"
	   "default: return(C_fix(ret));\n"
	   "}\n") ssl)))
    (if (fixnum? ret)
	(ssl-result-or-abort 'ssl-shutdown ssl ret #t)
	ret)))

(define (ssl-get-char ssl)
  (let ((ret
	 ((foreign-lambda*
	   scheme-object ((c-pointer ssl))
	   "char ch;\n"
	   "int ret;\n"
	   "switch (ret = SSL_read((SSL *)ssl, &ch, 1)) {\n"
	   "case 0: return(C_SCHEME_END_OF_FILE);\n"
	   "case 1: return(C_make_character(ch));\n"
	   "default: return(C_fix(ret));\n"
	   "}\n")
	  ssl)))
    (if (fixnum? ret)
	(ssl-result-or-abort 'ssl-get-char ssl ret #t)
	ret)))

(define (ssl-write ssl buffer offset size)
  (ssl-result-or-abort
   'ssl-write ssl
   ((foreign-lambda*
     int ((c-pointer ssl) (scheme-pointer buf) (int offset) (int size))
     "return(SSL_write((SSL *)ssl, (char *)buf + offset, size));\n")
    ssl buffer offset size)
   #t))

(define (ssl-port? obj)
  (and (port? obj) (eq? (##sys#slot obj 10) 'ssl-socket)))

(define (ssl-port->tcp-port p)
  (if (ssl-port? p)
      (##sys#slot p 11)
      (abort
       (make-composite-condition
        (make-property-condition
         'exn
         'location 'ssl-port->tcp-port
         'message "expected an ssl port, got"
         'arguments (list p))
        (make-property-condition
         'type)))))

(define (ssl-do-handshake ssl)
  (ssl-result-or-abort 'ssl-do-handshake ssl
                       ((foreign-lambda int "SSL_do_handshake" c-pointer) ssl) #t))

(define (ssl-call/timeout loc proc fd timeout timeout-message)
  (let loop ((res (proc)))
    (case res
      ((want-read)
       (when timeout
         (##sys#thread-block-for-timeout!
          ##sys#current-thread (+ (current-milliseconds) timeout)))
       (##sys#thread-block-for-i/o! ##sys#current-thread fd #:input)
       (thread-yield!)
       (if (##sys#slot ##sys#current-thread 13)
           (##sys#signal-hook
            #:network-timeout-error loc timeout-message timeout fd)
           (loop (proc))))
      ((want-write)
       (when timeout
             (##sys#thread-block-for-timeout!
              ##sys#current-thread (+ (current-milliseconds) timeout)))
       (##sys#thread-block-for-i/o! ##sys#current-thread fd #:output)
       (thread-yield!)
       (if (##sys#slot ##sys#current-thread 13)
           (##sys#signal-hook
            #:network-timeout-error loc timeout-message timeout fd)
           (loop (proc))))
      (else res))))

(define (ssl-make-i/o-ports ctx fd ssl tcp-in tcp-out)
  ;; note that the ctx parameter is never used but it is passed in order
  ;; to be present in the closure data of the various port functions
  ;; so it isn't garbage collected before the ports are all gone
  (let ((in-open? #f) (out-open? #f)
        (mutex (make-mutex 'ssl-mutex)))
    (define (startup)
      (dynamic-wind
          (lambda ()
            (mutex-lock! mutex))
          (lambda ()
	   (when (not ssl)
	     (error "SSL socket already closed"))
           (unless (or in-open? out-open?)
             (let ((success? #f))
               (dynamic-wind
                   void
                   (lambda ()
                     (ssl-set-fd! ssl fd)
                     (ssl-call/timeout 'ssl-do-handshake
                                       (lambda () (ssl-do-handshake ssl))
                                       fd (ssl-handshake-timeout)
                                       "SSL handshake operation timed out")
                     (set! in-open? #t)
                     (set! out-open? #t)
                     (set! success? #t))
                   (lambda ()
                     (unless success?
                       (ssl-free ssl)
		       (set! ssl #f)
                       (net-close-socket fd)))))))
          (lambda ()
            (mutex-unlock! mutex))))
    (define (shutdown)
      (unless (or in-open? out-open?)
	(set! ctx #f) ;; ensure that this reference is lost
	(dynamic-wind
	    void
	    (lambda ()
              (ssl-call/timeout 'ssl-shutdown
                                (lambda () (ssl-shutdown ssl))
                                fd (ssl-shutdown-timeout)
                                "SSL shutdown operation timed out"))
	    (lambda ()
	      (ssl-free ssl)
	      (net-close-socket fd)))))
    (let ((data (vector fd))
	  (in
	   (let ((buffer #f))
	     (make-input-port
	      ;; read
	      (lambda ()
                (startup)
		(unless buffer
                  (set! buffer
                        (ssl-call/timeout 'ssl-get-char
                                          (lambda () (ssl-get-char ssl))
                                          fd (tcp-read-timeout)
                                          "SSL read timed out")))
		(if buffer
		    (let ((ch buffer))
		      (set! buffer #f)
		      ch)
		    #!eof))
	      ;; ready?
	      (lambda ()
                (startup)
		(or buffer
		    (let ((ret (ssl-get-char ssl)))
                      (case ret
                        ((want-read want-write)
                         #f)
                        (else
                         (set! buffer ret)
                         #t)))))
	      ;; close
	      (lambda ()
                (startup)
		(set! in-open? #f)
		(shutdown))
	      ;; peek
	      (lambda ()
                (startup)
		(unless buffer
                  (set! buffer (ssl-call/timeout 'ssl-peek-char
                                                 (lambda () (ssl-get-char ssl))
                                                 fd (tcp-read-timeout)
                                                 "SSL read timed out")))
		(if buffer
		    buffer
		    #!eof)))))
	  (out
	   (make-output-port
	    ;; write
	    (lambda (buffer)
              (startup)
              (when (> (##sys#size buffer) 0) ; Undefined behaviour for 0 bytes!
                (let loop ((offset 0) (size (##sys#size buffer)))
                  (let ((ret (ssl-call/timeout
                              'ssl-peek-char
                              (lambda () (ssl-write ssl buffer offset size))
                              fd (tcp-write-timeout) "SSL write timed out")))
                    (when (fx< ret size) ; Partial write
                      (loop (fx+ offset ret) (fx- size ret)))))))
	    ;; close
	    (lambda ()
              (startup)
	      (set! out-open? #f)
	      (shutdown)))))
      (##sys#setslot in 3 "(ssl)")
      (##sys#setslot out 3 "(ssl)")
      (##sys#setslot in 10 'ssl-socket)  ; first "reserved" slot
      (##sys#setslot out 10 'ssl-socket) ; Slot 7 should probably stay 'custom
      (##sys#setslot in 11 tcp-in)       ; second "reserved" slot
      (##sys#setslot out 11 tcp-out)
      (values in out))))

(define (ssl-unwrap-context obj)
  (cond
   ((ssl-client-context? obj)
    (ssl-unwrap-client-context obj))
   ((ssl-listener? obj)
    (ssl-unwrap-listener-context obj))
   (else
    (abort
     (make-composite-condition
      (make-property-condition
       'exn
       'location 'ssl-unwrap-context
       'message "expected an ssl-client-context or ssl-listener, got"
       'arguments (list obj))
      (make-property-condition
       'type))))))

;;; exported routines

;; create SSL client context
(define-record-type ssl-client-context
  (ssl-wrap-client-context context)
  ssl-client-context?
  (context ssl-unwrap-client-context))

(define (ssl-make-client-context #!optional (protocol 'sslv2-or-v3))
  (ssl-wrap-client-context (ssl-ctx-new protocol #f)))

(define ssl-set-connect-state! (foreign-lambda void "SSL_set_connect_state" c-pointer))

;; connect to SSL server
(define (ssl-connect hostname #!optional port (ctx 'sslv2-or-v3))
  (receive (tcp-in tcp-out)
    (tcp-connect hostname port)
    (let* ((fd (net-unwrap-tcp-ports tcp-in tcp-out))
           (ctx
            (if (ssl-client-context? ctx)
                (ssl-unwrap-client-context ctx)
                (ssl-ctx-new ctx #f)))
           (ssl
            (ssl-new ctx)))
      (ssl-set-connect-state! ssl)
      (ssl-make-i/o-ports ctx fd ssl tcp-in tcp-out))))

;; create listener/SSL server context
(define-record-type ssl-listener
  (ssl-wrap-listener context listener)
  ssl-listener?
  (context ssl-unwrap-listener-context)
  (listener ssl-unwrap-listener))

(define (ssl-listen port #!optional (backlog 4) (hostname #f) (ctx 'sslv2-or-v3))
  (ssl-wrap-listener
   (if (ssl-client-context? ctx)
       (ssl-unwrap-client-context ctx)
       (ssl-ctx-new ctx #t))
   (tcp-listen port backlog hostname)))

;; shutdown a SSL server
(define (ssl-close listener)
  (tcp-close (ssl-unwrap-listener listener)))

;; return the port number this listener is operating on
(define (ssl-listener-port listener)
  (tcp-listener-port (ssl-unwrap-listener listener)))

;; get the underlying socket descriptor number for an SSL listener
(define (ssl-listener-fileno listener)
  (tcp-listener-fileno (ssl-unwrap-listener listener)))

;; check whether an incoming connection is pending
(define (ssl-accept-ready? listener)
  (tcp-accept-ready? (ssl-unwrap-listener listener)))

(define ssl-set-accept-state! (foreign-lambda void "SSL_set_accept_state" c-pointer))

;; accept a connection from an SSL listener
(define (ssl-accept listener)
  (receive (tcp-in tcp-out)
    (tcp-accept (ssl-unwrap-listener listener))
   (let* ((fd (net-unwrap-tcp-ports tcp-in tcp-out))
          (ctx (ssl-unwrap-listener-context listener))
          (ssl (ssl-new ctx)))
     (ssl-set-accept-state! ssl)
     (ssl-make-i/o-ports ctx fd ssl tcp-in tcp-out))))

;; load identifying certificate chain into SSL context
(define (ssl-load-certificate-chain! obj pathname)
  (##sys#check-string pathname)
  (unless (eq?
	   ((foreign-lambda
	     int "SSL_CTX_use_certificate_chain_file" c-pointer c-string)
	    (ssl-unwrap-context obj) (##sys#expand-home-path pathname))
	   1)
    (ssl-abort 'ssl-load-certificate-chain! #f pathname)))

;; load the private key for the identifying certificate chain
(define (ssl-load-private-key! obj pathname #!optional (rsa? #t) (asn1? #f))
  (##sys#check-string pathname)
  (unless (eq?
	   ((foreign-lambda*
	     int ((c-pointer ctx) (c-string path) (bool rsa) (bool asn1))
	     "if (rsa)\n"
	     "  return(SSL_CTX_use_RSAPrivateKey_file("
	     "           (SSL_CTX *)ctx, path, "
	     "           (asn1 ? SSL_FILETYPE_ASN1 : SSL_FILETYPE_PEM)));\n"
	     "else\n"
	     "  return(SSL_CTX_use_PrivateKey_file("
	     "           (SSL_CTX *)ctx, path, "
	     "           (asn1 ? SSL_FILETYPE_ASN1 : SSL_FILETYPE_PEM)));\n")
	    (ssl-unwrap-context obj) (##sys#expand-home-path pathname)
	    rsa? asn1?)
	   1)
    (ssl-abort 'ssl-load-private-key! #f pathname rsa? asn1?)))

;; switch verification of peer on or off
(define (ssl-set-verify! obj v)
  ((foreign-lambda*
    void
    ((c-pointer ctx) (bool verify))
    "SSL_CTX_set_verify((SSL_CTX *)ctx,"
    " (verify ? SSL_VERIFY_PEER|SSL_VERIFY_FAIL_IF_NO_PEER_CERT"
    " : SSL_VERIFY_NONE), NULL);\n")
   (ssl-unwrap-context obj) v))

;; load trusted root certificates into SSL context
(define (ssl-load-verify-root-certificates! obj pathname #!optional (dirname #f))
  (if pathname (##sys#check-string pathname))
  (if dirname (##sys#check-string dirname))
  (unless (eq?
	   ((foreign-lambda
	     int "SSL_CTX_load_verify_locations" c-pointer c-string c-string)
	    (ssl-unwrap-context obj)
	    (if pathname (##sys#expand-home-path pathname) #f)
	    (if dirname (##sys#expand-home-path dirname) #f))
	   1)
    (ssl-abort 'ssl-load-verify-root-certificates! #f pathname dirname)))

;; load suggested root certificates into SSL context
(define (ssl-load-suggested-certificate-authorities! obj pathname)
  (##sys#check-string pathname)
  (cond
   (((foreign-lambda c-pointer "SSL_load_client_CA_file" c-string)
     (##sys#expand-home-path pathname))
    => (cut
	(foreign-lambda
	 void "SSL_CTX_set_client_CA_list" c-pointer c-pointer)
	(ssl-unwrap-context obj) <>))
   (else
    (ssl-abort 'ssl-load-suggested-certificate-authorities! #f pathname))))

)