<h1>Introduction</h1>

Bokbok is a toolkit for exposing and consuming APIs between processes.

It supports:

  *  TCP or UNIX-domain sockets
  *  Optional encryption and authentication.
  *  Multithreading over a single connection: multiple threads may
     make requests via the same connection, and multiple request handlers can be
     running at once in their own threads.
  *  Connections are symmetrical once established: either side may
     invoke the other side's API at any time, "client" and "server"
     are just a matter of who sat passively waiting for a connection
     and who initiated it.

<h1>Usage</h1>

<pre>$ chicken-install bokbok</pre>

<ul>
<li><a href="bokbok-client.scm">Demo client</a></li>
<li><a href="bokbok-server.scm">Demo server</a></li>
</ul>

<h1>Concepts</h1>

<h2>Creating connections</h2>

A server is created by <tt>start-server</tt>, given an address to bind
to (IPv4 or UNIX socket). When connections come in, an "open handler"
is notified of the new connection.

The server can be asked to terminate with <tt>stop-server!</tt>. You
can block until it's died with <tt>wait-until-server-stopped</tt>.

A client is created by calling <tt>open-connection</tt>, given an
address to connect to, and creates a connection.


<h2>Using connections</h2>

Once connection setup is complete, connections are the same for both
client and server; that distinction is purely a matter of who created
the connection. Both sides can call <tt>request!</tt> to send a
request to the other side or <tt>close-connection!</tt> to close the
connection - and both sides have a request handler and a close handler
ready to handle those cases.


Normally the "client" calls <tt>close-connection!</tt>, but that's
just convention.


<h2>Encryption</h2>


If a username and key (which can be generated from a string by calling
<tt>passphrase->key</tt> is given when <tt>open-connection</tt> is
called, then the connection is opened as an encrypted connection. It
won't work very well if the wrong key for that username is provided,
or the username is unknown on the server.


If a server is started in encrypted mode, a key lookup function must


be provided. When a connection comes in, the username provided by the

client is passed to the key lookup function, which must either return

a key or <tt>#f</tt> if the user is not allowed to connect. If the key


returend matches the one the user provides, the connection will

succeed and be encrypted.










A random session key is actually used for encryption, chosen by the





















client; the user's key is used to encrypt the session key for





transmission to the server, then discarded.

(use bokbok)
(use matchable)

;; Called if server sends us a callback request
(define (request-handler con request)
  (match request
   (("callback" num)
    (printf "Callback received: ~s\n" num)
    '())
   (else (error "Unrecognised callback"))))

;; Called if server closes the connection
(define (close-handler con)
  (void))

(define con (open-connection '(tcp "localhost" 12345)
             #f #f ;; "myuser" (passphrase->key "mypassphrase")
             request-handler close-handler))

(printf "Response is ~s\n" (request! con '("ping" "12345")))

(printf "Response is ~s\n" (request! con '("ping" "12345")))

(printf "Response is ~s\n" (request! con '("asynch")))

;; Wait for asynch responses to all arrive
(thread-sleep! 10)

(close-connection! con)

(define (expect exp actual)
  (unless
   (equal? exp actual)
   (printf "Expected ~s but got ~s\n" exp actual)))

(define (run-client! con)
  (expect '("echo" "hello")
          (request! con '("hello")))
  (expect "\"Error raised\" in (#f)"
          (handle-exceptions
           exn
           (if (remote-error? exn)
               (remote-error-message exn)
               #f)
           (request! con '("error"))
           #f))
  (expect '("did it"  "(\"echo\" \"called you back\")")
          (request! con '("callback")))
  (thread-sleep! 10)
#;  (expect '(ok ("ok"))
          (request! con '("kill")))
  (close-connection! con))

(define (run-server! server)

(use bokbok)
(use matchable)

(define *server* #f)

(define (user->key username)
  (match username
   ("myuser" (passphrase->key "mypassphrase"))
   (else #f)))

(define (open-handler con)
  (printf "CONNECTION from ~a@~s\n"
    (connection-user con)
    (connection-addr con))
  (void))

(define (request-handler con request)
  (match request
    (("ping" string)
     (list "pong" string))
    (("asynch")
     (thread-start!
       (make-thread
        (lambda ()
          (printf "Asynch 1\n")
           (request! con '("callback" "1"))
           (thread-sleep! 1)
           (printf "Asynch 2\n")
           (request! con '("callback" "2"))
           (thread-sleep! 1)
           (printf "Asynch 3\n")
           (request! con '("callback" "3"))
           (thread-sleep! 1)
           (printf "Asynch 4\n")
           (request! con '("callback" "4")))))
     ;; Return this while the callback thread runs in the background
     (printf "Returning from asynch\n")
     (list "ok"))
    (("shutdown-server!")
     (stop-server! *server*))
    (else (error "Unknown request" request))
  ))

(define (close-handler con)
  (printf "DISCONNECTION from ~a@~s\n"
    (connection-user con)
    (connection-addr con))
  (void))

(set! *server* (start-server '(tcp #f 12345) 10 #f #;user->key
   open-handler request-handler close-handler))

(wait-until-server-stopped *server*)

(module
 bokbok
 (passphrase->key

  open-connection
  close-connection!
  request!

  remote-error?
  remote-error-message

  connection?
  connection-user
  connection-addr

  start-server
  stop-server!
  wait-until-server-stopped

 (use socket)
 (use srfi-27)
 (use moa) ;; from srfi-27
 (use entropy-unix) ;; from srfi-27

 ;; FIXME: Accept a hostname for open-connection, and look it up

 ;; FIXME: Support sending creds over a unix-domain socket instead of a username.

 ;; FIXME: User data field in a connection

 ;; FIXME: Reduce timeouts to detect gone servers quickly

 ;; FIXME: Support IPv6

 ;; FIXME: Is the 60s receive timeout OK? Connections can't linger. Is
 ;; that a feature?

 ;; FIXME: Auto reconnect on request!

 ;; FIXME: Configurable maximum message size: client and server both
 ;; declare their intent in the initial handshake, and minimum of both
 ;; is used as the connection message size limit.

#; (define (debug . args)
  (let ((str (apply sprintf args)))
    (printf "DEBUG: ~a\n" str)))

 (define (debug . args)
   (void))

     (write-byte l1 o)
     (write-byte l2 o)
     (write-byte l3 o)
     (write-string p #f o)))

 (define (write-packet! o p)
   (write-packet-no-flush! o p)
   (debug "Flushing packets")
   (flush-output o))

 ;; Join a list of strings into a packet
 (define (join-packet ps)
   (let ((plen (length ps)))
     (when (> plen 255)
           (error "Can't fit more than 255 fields into a packet"))

   (close-handler connection-close-handler)
   (counter connection-counter (setter connection-counter)))

 (define (connection-send! con packet-parts)
   (let ((packet (if (connection-key con)
                     (encrypt (connection-key con) (join-packet packet-parts))
                     (join-packet packet-parts))))
     (debug "MUTEX: send")
     (mutex-lock! (connection-mutex con))
     (write-packet! (connection-output con) packet)
     (debug "MUTEX: !send")
     (mutex-unlock! (connection-mutex con))))

 (define (handle-request! con id body)
   (debug "Handling request id:~a ~s" id body)
   (let ((thread
          (make-thread
           (lambda ()

               (debug "Sending response id:~a ~s" id response)
               (connection-send! con response)))
           `(bokbok-request-thread ,(connection-addr con) ,id))))
     (thread-start! thread)))

 (define (handle-response! con id body)
   (debug "Handling response id:~a ~s" id body)
   (debug "MUTEX: handle-response")
   (mutex-lock! (connection-mutex con))
   (let ((waiter (hash-table-ref/default (connection-waiters con)
                                         id #f)))
     (debug "MUTEX: !handle-response")
     (mutex-unlock! (connection-mutex con))
     (if waiter
         (begin
           (set-cdr! waiter body)
           (mutex-unlock! (car waiter)))
         (debug "Discarding response to unknown request id:~a" id))))


 (define (handle-connection-thread!)
   (let* ((con (thread-specific (current-thread)))
          (session-key (connection-key con)))
     (debug "Session thread starting")
    (let loop ()
      (debug "Session thread waiting for packet")
      ;; We are the only thing that reads from connection-input, so need no mutex!
      (let ((raw-request (read-packet! (connection-input con))))
        (debug "Session thread got ~s" raw-request)
        (if (eof-object? raw-request)
            ;; Terminate loop
            ((connection-close-handler con) con)
            ;; Handle request and loop
            (let* ((request-bytes (if session-key
                                      (decrypt session-key raw-request)
                                      raw-request))
                   (request (split-packet request-bytes)))
              (match
               request
               (("req" id . body)
                (handle-request! con id body))
               (("ok" id . body)
                (handle-response! con id (cons 'ok body)))
               (("err" id error-string)
                (handle-response! con id (cons 'error error-string))))
              ;; Loop for next request
              (loop)))))))

 (define (make-connection addr user socket input output key request-handler close-handler)
   (let ((con
          (make-connection*
           addr user

            ;; UNIX domain
            (let ((s (socket af/unix sock/stream)))
              (socket-connect s (unix-address path))
              s))
           (('tcp host port)
            ;; TCP domain
            (let ((s (socket af/inet sock/stream))
                  (ai (filter
                       (lambda (ai)
                         (eq? (addrinfo-family ai) af/inet))
                       (address-information host port))))
              (socket-connect s (addrinfo-address (car ai)))
              (set! (tcp-no-delay? s) #t)
              s)))))
     (receive
      (input output)
      (parameterize
       ((socket-send-buffer-size 4096)
        (socket-send-size 16384))

            (let ((header (read-string (string-length *header*) input)))
              (debug "Got header bytes: ~s" header)
              (if (string=? header *header*)
                  (make-connection addr #f s input output #f request-handler close-handler)
                  (error "Invalid hello from server" header))))))))

 (define (close-connection! con)
   ;; FIXME: Set a flag in the connection so we quietly discard any further responses from still-running handlers.
   ;; FIXME: Return an error to all pending waiters.
   (thread-terminate! (connection-thread con))
   (close-output-port (connection-output con))
   (close-input-port (connection-input con)))

 (define (request! con packet-parts)
   (debug "MUTEX: request!")
   (mutex-lock! (connection-mutex con))
   (let* ((id (number->string (connection-counter con)))
          (waiter (cons (make-mutex `(bokbok-request-mutex ,(connection-addr con) id))
                        #f)))

     ;; Mutex starts life locked by the connection thread
     (mutex-lock! (car waiter)
                  #f
                  (connection-thread con))

     (hash-table-set! (connection-waiters con) id waiter)
     (set! (connection-counter con)
           (+ (connection-counter con) 1))
     (debug "MUTEX: !request!")
     (mutex-unlock! (connection-mutex con))

     (connection-send! con (cons "req" (cons id packet-parts)))

     ;; Wait for response, when connection thread unlocks the mutex
     (mutex-lock! (car waiter))

     ;; Return response
     (match
      (cdr waiter)
      (('ok . body)
       body)
      (('error . error-string)
       (signal (make-property-condition 'bokbok-remote 'message error-string)))
      (else (error "Invalid response" (cdr waiter))))))

 (define remote-error?
   (condition-predicate 'bokbok-remote))

 (define remote-error-message
   (condition-property-accessor 'bokbok-remote 'message))
 
 (define (start-server bind-addr backlog user->key open-handler request-handler close-handler)
   (let* ((s (match
              bind-addr
              (('unix path)
                 ;; UNIX domain
               (let ((s (socket af/unix sock/stream)))
                 (socket-bind s (unix-address path))
                 (socket-listen s backlog)
                 s))
              (('tcp addr port)
               ;; TCP domain
               (let ((s (socket af/inet sock/stream)))
                 (socket-bind s (inet-address addr port))
                 (set! (so-reuse-address? s) #t)
                 (socket-listen s backlog)
                 s))
              (else (error "Unknown bind address ~s" bind-addr))))
          (tcp? (match bind-addr (('tcp . any) #t) (else #f)))
          (thread
           ;; FIXME: Refactor this monstrosity
           (make-thread
            (lambda ()
              (let loop ()
                (debug "Listener thread calling accept")
                (let* ((cs
                        (socket-accept s))
                       (handler-thread