(declare
 (unit sslsocket)
 (uses srfi-34 posix extras regex tcp ports scheduler atomic)
 (uses library)				; gc
 (fixnum-arithmetic)
 (usual-integrations)
 (no-bound-checks)
 (no-procedure-checks-for-usual-bindings)
 (bound-to-procedure
  string-append string-ref
  write-string flush-output current-error-port
  create-pipe make-internal-pipe process-fork current-process-id duplicate-fileno
  )
 (disable-interrupts)
 (foreign-declare #<<EOF
#include <errno.h>
#ifdef _WIN32
# if _MSC_VER > 1300
# include <winsock2.h>
# include <ws2tcpip.h>
# else
# include <winsock.h>
# endif
/* Beware: winsock2.h must come BEFORE windows.h */
# define socklen_t       int
static WSADATA wsa;
# define fcntl(a, b, c)  0
# define EWOULDBLOCK     0
# define EINPROGRESS     0
# define typecorrect_getsockopt(socket, level, optname, optval, optlen)	\
    getsockopt(socket, level, optname, (char *)optval, optlen)
#else
# include <fcntl.h>
# include <sys/types.h>
# include <sys/socket.h>
# include <sys/time.h>
# include <netinet/in.h>
# include <unistd.h>
# include <netdb.h>
# include <signal.h>
# define closesocket     close
# define INVALID_SOCKET  -1
# define typecorrect_getsockopt getsockopt
#endif

#ifndef SD_RECEIVE
# define SD_RECEIVE      0
# define SD_SEND         1
#endif

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

static char addr_buffer[ 20 ];
EOF
))

(module
 sslsocket
 (
  make-sslmgr
  ssl-close ssl-certificate debug-ssl
  ssl-keep-alive-timeout
  ssl-input-port ssl-output-port
  askemos:run-ssl-server askemos:open-ssl-client
  )

(import scheme foreign
	(except chicken with-exception-handler condition?)
	regex
	srfi-13 (except srfi-18 raise)
	srfi-34 atomic util posix tcp ports extras)

(import (only data-structures identity)) ; Work around strange 4.7.3 chicken? !!!

(define *debug-ssl* #f)

;(define-syntax (if-debug-ssl . body) (values))
;(define-syntax (if-debug-ssl . body) (begin . body))

;(define-macro (if-debug-ssl . body) `(if *debug-ssl* (begin . ,body)))

(define-syntax if-debug-ssl
  (syntax-rules ()
    ((if-debug-ssl body ...)
     (if *debug-ssl* (begin body ...)))))

(define (debug-ssl . flag)
  (if (pair? flag)
      (set! *debug-ssl* (car flag)))
  *debug-ssl*)

(define ssl-keep-alive-timeout
  (let ((t 660))
    (lambda args
      (if (pair? args)
	  (let ((t0 t)) (set! t (car args)) t0)
	  t))))

(define mux-header-type
  (foreign-lambda*
   integer ((scheme-object h))
   "return(((*(u_int32_t *)C_c_string(h))>>24) & 0xFF);"))

(define mux-header-size
  (foreign-lambda*
   integer ((scheme-object h))
   "return((*(u_int32_t *)C_c_string(h)) & 0x3FFFF);"))

(define make-mux-header*
  (foreign-lambda*
   void ((scheme-object o) (integer type) (integer len))
   "char *buf=C_c_string(o);
    *((u_int32_t *) buf) = ((type << 24) & 0xFF000000) + (len & 0x3FFFF);
    return(buf);"))

(define (make-mux-header type len)
  (if (or (fx< type 0) (fx> type #xff))
      (error (format "make-mux-header type out of range ~a" type)))
  (if (or (fx< len 0) (fx> len #x3ffff))
      (error (format "make-mux-header length out of range ~a" len)))
  (let ((s (make-string 4))) (make-mux-header* s type len) s))

(define-record-type <ssl-socket>
  (make-ssl-socket properties peer
		   certificate cert-mux cert-avail
		   plaintext-in plaintext-out
		   mux pid)
  ssl-socket?
  (properties properties set-properties!)
  (peer ssl-peer)
  (certificate certificate-value set-certificate-value!)
  (cert-mux cert-mux)
  (cert-avail cert-avail)
  (plaintext-in ssl-input-port)
  (plaintext-out ssl-output-port)
  (mux mux-out)
  (pid ssl-process set-ssl-process!))

(define (ssl-certificate self)
  (if (eq? (certificate-value self) 'unknown)
      (begin
	(mutex-lock! (cert-mux self))
	(if (eq? (certificate-value self) 'unknown)
	    (begin
	      (mutex-unlock! (cert-mux self) (cert-avail self))
	      (ssl-certificate self))
	    (let ((c (certificate-value self)))
	      (mutex-unlock! (cert-mux self)) c)))
      (certificate-value self)))

(define (set-certificate! self cert)
  (set-certificate-value! self cert)
  (condition-variable-broadcast! (cert-avail self)))

(define $ctl-shutdown (string-append (make-mux-header #xCC 1) "c"))

(define (control-write self packet)
  (if-debug-ssl (format (current-error-port) "*** >>> CONTROL ~s\n" (string-ref packet 4)))
  (write-string packet #f (mux-out self)))

(define (ssl-close self)
  (guard
   (err (else
	 (if-debug-ssl
	  (format (current-error-port) "*** close<ssl-socket> ~a\n" err))))
   (control-write self $ctl-shutdown)
   (flush-output (mux-out self)))
  ;; this should trigger the subprocess to exit
  (guard
   (err (else 
	 (if-debug-ssl
	  (format (current-error-port) "*** close<ssl-socket> (plaintext-out self) ~a\n" err))))
   (close-output-port (ssl-output-port self)))
  (set-ssl-process! self #f)
  #t)

(define (make-mux-output-port mux-output)
  (define (write-chunk s)
    (write-string (make-mux-header #xDD (string-length s)) #f mux-output)
    (write-string s #f mux-output)
    (flush-output mux-output))
  (make-output-port
   (lambda (str)
     (if (< (string-length str) 250000)
        (write-chunk str)
        (let loop ((i 0))
          (let ((j (+ i 250000)))
            (if (>= j (string-length str))
                (write-chunk (substring/shared str i))
                (begin
                  (write-chunk (substring/shared str i j))
                  (loop j)))))))
   (lambda () (close-output-port mux-output))
   (lambda () (flush-output mux-output))))

(define (make-sslmgr cnx peer certinfo)
  (make-sslmgr* cnx peer certinfo #t #f))

(define *sslmgr-executable* "sslmgr")

(define (make-sslmgr* cnx peer certinfo server? pp)
  (receive
   (r0 w0) (create-pipe)
   (receive
    (r1 w1) (create-pipe)
    (receive
     (rpin wpin) (make-internal-pipe)	; pin="Plaintext INput"
     (receive
      (pid mux-out mux-in)
      (let ((pid (begin (gc #f) (process-fork))))
	(if (eqv? pid 0)
	    (guard
	     (ex (else (_exit 1)))
	     (let ((pid (current-process-id)))
	       ;; (sudo! runuser)
	       ;; (file-close cr) (file-close cw)
	       (duplicate-fileno r0 0)
	       (duplicate-fileno w1 1)
	       (if (number? cnx) (duplicate-fileno cnx 3))
	       ;(format (current-error-port) "~a close all ports\n" pid)
	       (close-all-ports-except 0 1 2 3)
	       ;(format (current-error-port) "~a force major gc\n" pid)
	       ;(gc #t)
	       ;(format (current-error-port) "~a run server ~a\n" pid server?)
	       (process-execute
		*sslmgr-executable*
		`("-F"
		  "-t" ,(number->string (ssl-keep-alive-timeout))
		  ,(if server? "-pfdsrv:3"
		       (if (string? cnx) (string-append cnx peer) "-pfdclient:3"))
		  ,@(if *debug-ssl* '("-v") '())
		  . ,certinfo))
	       (_exit 0)))
	    (begin
	      (file-close r0) (file-close w1)
	      (if (number? cnx) (file-close cnx))
	      ;(##sys#file-nonblocking! w0)
	      (receive (in out) (process-io-ports pid r1 w0)
		       (values pid out in)))))
      (let ((ssl (make-ssl-socket
		  '() peer 'unknown
		  (make-mutex peer) (make-condition-variable peer)
		  rpin (make-mux-output-port mux-out)
		  mux-out
		  pid)))
        ;;
        (if pp
            (begin
              (format (current-error-port) "Setting PASSPHRASE = ~s\n" pp)
              (set-properties! ssl `((passphrase . ,pp) . ,(properties ssl)))))
        ;;
        (thread-start!
         (make-thread
          (lambda ()
	    (guard
	     (err (else (if-debug-ssl (display err (current-error-port)))))
	     (let loop ()
	       (let ((l (read-string 4 mux-in)))
		 (if (not (string-null? l));; (not (eof-object? l))
		     (let ((type (mux-header-type l))
			   (len (mux-header-size l)))
		       (let ((data (read-string len mux-in)))
			 (case type
			   ((#xCC)
			    (if-debug-ssl
			     (format (current-error-port) "*** <<< CONTROL ~s\n" data))
			    (process-control-packet ssl data))
			   ((#xDD)
			    (if-debug-ssl (format (current-error-port)
						  "*** <<< DATA [~a] ~a\n"
						  (string-length data) (substring/shared data 0 (min (string-length data) 70))))
			    (if (eq? (certificate-value ssl) 'unknown)
				(set-certificate! ssl #f))
			    (write-string data #f wpin))
			   (else
			    (error (format "Bad framing header type: ~s ~a" type l))))
			 (loop)))))))
            (set-certificate! ssl #f)
	    (set-ssl-process! ssl #f)
            (handle-exceptions ex #f (close-output-port wpin))
            (handle-exceptions ex #f (close-input-port mux-in))
	    (handle-exceptions ex #f (receive (p f s) (process-wait pid) s)))
          (format "ssl[~a].in" r1)))
        ssl))))))

(define control-header
  (let ((match (regexp "^([^[:space:]]+)[[:space:]]*")))
    (lambda (str)
      (let ((result (string-search-positions match str)))
	(if result
	    (values (caar result) (cadar result)
		    (substring str (caadr result) (cadadr result)))
	    (values #f #f ""))))))

(define (process-control-packet ssl data)
  (receive
   (s e tag) (control-header data)
   (cond
    ((string=? tag "peer-cert")
     (let ((cert (substring data e)))
       (set-certificate! ssl (if (string=? cert "-none-") #f cert))))
    ((string=? tag "passwd:private")
     (let ((p (let ((p (assq 'ssl (properties ssl))))
		(and p (cadr p)))))
       (control-write ssl
		      (string-append 
		       (make-mux-header #xCC (+ 1 (string-length p)))
		       "p"
		       p))
       (flush-output-port (mux-out ssl))))
    ((string=? tag "error:")
     (if-debug-ssl
      (format (current-error-port) "***sslmgr ~a\n"
	      (substring data e))))
    ((string=? tag "ssl-err")  ;; ssl_choke
     (if-debug-ssl
      (format (current-error-port) "***sslmgr choke ~a\n"
	      (substring data e))))
    (else
     ;; ignore it for Now...
     'ignored))))

;; -----------------------

(define-foreign-variable errno int "errno")
(define-foreign-variable strerror c-string "strerror(errno)")
(define ##net#accept (foreign-lambda int "accept" int c-pointer c-pointer))
(define ##net#select
  (foreign-lambda* int ((int fd))
    "fd_set in;
     struct timeval tm;
     int rv;
     FD_ZERO(&in);
     FD_SET(fd, &in);
     tm.tv_sec = tm.tv_usec = 0;
     rv = select(fd + 1, &in, NULL, NULL, &tm);
     if(rv > 0) { rv = FD_ISSET(fd, &in) ? 1 : 0; }
     return(rv);") )
(define ##net#getpeername 
  (foreign-lambda* c-string ((int s))
    "struct sockaddr_in sa;"
    "unsigned char *ptr;"
    "unsigned int len = sizeof(struct sockaddr_in);"
    "if(getpeername(s, (struct sockaddr *)&sa, ((unsigned int *)&len)) != 0) return(NULL);"
    "ptr = (unsigned char *)&sa.sin_addr;"
    "sprintf(addr_buffer, \"%d.%d.%d.%d\", ptr[ 0 ], ptr[ 1 ], ptr[ 2 ], ptr[ 3 ]);"
    "return(addr_buffer);") )

(define (tcp-get-next-client tcpl)
  (##sys#check-structure tcpl 'tcp-listener)
  (let ((fd (##sys#slot tcpl 1))
	(tma (identity (tcp-accept-timeout)))) ; Work around strange 4.7.3 chicken? !!!
    (let loop ((nfd (##net#select fd)))
      (cond
	((eq? nfd 1)
	 (let ((fd (##net#accept fd #f #f)))
	   (when (eq? -1 fd)
		 (##sys#update-errno)
		 (##sys#signal-hook 
		  #:network-error 'tcp-accept (##sys#string-append "could not accept from listener - " strerror) 
		  tcpl) )
	   (values fd (##net#getpeername fd))) )
	((eq? nfd 0)
	 (when tma
	       (##sys#thread-block-for-timeout!
		##sys#current-thread
		(fx+ (##sys#scheduler-time) tma) ) )
	 (thread-wait-for-i/o! fd #:input)
	 (when (##sys#slot ##sys#current-thread 13)
	       (##sys#signal-hook
		#:network-error
		'tcp-accept
		"accept operation timed out" fd) )
	 (loop (##net#select fd)) )
	(else
	 (##sys#update-errno)
	 (##sys#signal-hook 
	  #:network-error 'tcp-get-next-client (##sys#string-append "select returned " strerror " on fd " (number->string fd)) 
	  tcpl)))) ) )

(define (askemos:run-ssl-server
         host port certinfo connection-handler exception-handler
         maximum-semaphore capture-handler name)
  (define request-queue (tcp-listen port 4 host))
  (define (exception-handler ex)
    (log-condition (format "run-ssl-server (host ~a port ~a)" host port) ex))
  (define blocking-connections #f)
  (let loop ()
    (handle-exceptions
     ex (exception-handler ex)
     (receive
      (cnx peer) (tcp-get-next-client request-queue)
      (if (and (eqv? (semaphore-value maximum-semaphore) 0) (not blocking-connections))
	  (begin
	    (set! blocking-connections #t)
	    (logerr "W Blocking connections ~a:~a\n" host port)))
      (if maximum-semaphore (semaphore-wait-by! maximum-semaphore 1))
      (if (and blocking-connections (fx> (semaphore-value maximum-semaphore) 0))
	  (set! blocking-connections #f))
      (thread-start!
       (make-thread
	(lambda ()
	  (let ((ssl #f))
	    (guard
	     (ex
	      ((eq? ex 'connection-captured)
	       (if capture-handler
		   (handle-exceptions
		    ex (exception-handler ex)
		    (let ((ssl ssl))
		      (capture-handler
		       (ssl-certificate ssl) (ssl-input-port ssl) (ssl-output-port ssl)
		       (lambda () (and ssl (ssl-process ssl) #t))
		       (lambda dummy
			 (if ssl (let ((s ssl)) (set! ssl #f) (ssl-close s)))))))
		   (if ssl (handle-exceptions ex #f (ssl-close ssl))))
	       (set! ssl #f))
	      (else (exception-handler ex)))
	     (set! ssl (make-sslmgr cnx peer
				    (if host
					`("-i" ,host . ,certinfo)
					certinfo)))
	     (connection-handler (ssl-input-port ssl) (ssl-output-port ssl)
				 peer (ssl-certificate ssl)))
	    (if maximum-semaphore (semaphore-signal-by! maximum-semaphore 1))
	    (if ssl (ssl-close ssl))))
	name))
      (loop)))))

(define socks4a-setup!*
  (foreign-lambda*
   integer ((integer fd) ((const c-string) hf) (integer pf)) #<<EOF
#define BUFLEN 10
  char buffer[BUFLEN+1], *buf=buffer;
  int len = snprintf(buf, BUFLEN + 1,
                     "\x4\x1%c%c00010%s",
                     (char) ((pf & 0xff00) >> 8), /* port MSB */
                     (char) (pf & 0xff), /* port LSB */
                     hf);
  if( len >= BUFLEN ) {
    buf = alloca( len + 1 );
    snprintf(buf, len + 1,
             "\x4\x1%c%c00010%s",
             (char) ((pf & 0xff00) >> 8), /* port MSB */
             (char) (pf & 0xff), /* port LSB */
             hf);
  }
  buf[4]='\0';
  buf[5]='\0';
  buf[6]='\0';
  buf[7]='\1';
  buf[8]='\0';
  if (write( fd, buf, len+1 ) != len+1) return(-1);
  len = read( fd, buf, 8 );
  if( len != 8 || buf[0] != 0 ) return(-2);
  if( buf[1] != (char) 90 ) return(-((int) buf[1]));
  return(0);
#undef BUFLEN
EOF
))

(define (socks4a-setup! fd host port)
  (case (socks4a-setup!* fd host port)
    ((0) #t)
    ((-1) (raise "socks server connect request"))
    ((-2) (raise "socks server connect"))
    ((-91) (raise "request rejected or failed"))
    ((-92) (raise "rejected; server cannot connect to identd on the client"))
    ((-93) (raise "rejected because the client program and identd report different user-ids"))
    (else (raise "unknown code"))))

(define (askemos:open-ssl-client addr ca cert key socks4a verbose)
  (let ((ssl #f))
    (guard
     (ex
      (else
       (if ssl (handle-exceptions ex #f (ssl-close ssl)))
       (raise ex)))
     (set! ssl (make-sslmgr*
		 (if verbose "-pconnect:" "-qpconnect:") addr
		`("-c" ,(or cert (error "No certificate to connect to ~a." addr))
		  "-k" ,key
		  "-t" ,(number->string (ssl-keep-alive-timeout))
		  ,@(if socks4a	`("-s" ,socks4a) '())
		  . ,(if ca
			 (list "-E" "-A" ca "-T" ca)
			 '()))
		#f #f))
     (values (ssl-input-port ssl) (ssl-output-port ssl)
	     (or (ssl-certificate ssl)
		 (if ca (raise 'no-certificate) #f))
	     (lambda () (and ssl (ssl-process ssl) #t))
	     (lambda (c) (when ssl (ssl-close ssl) (set! ssl #f)))))))

) ;; module sslsocket

(import (prefix sslsocket ssl:))

(define make-sslmgr ssl:make-sslmgr)
(define ssl-close ssl:ssl-close)
(define ssl-certificate ssl:ssl-certificate)
(define debug-ssl ssl:debug-ssl)
(define ssl-input-port ssl:ssl-input-port)
(define ssl-output-port ssl:ssl-output-port)
(define askemos:run-ssl-server ssl:askemos:run-ssl-server)
(define askemos:open-ssl-client ssl:askemos:open-ssl-client)
(define ssl-keep-alive-timeout ssl:ssl-keep-alive-timeout)