bokbok
Check-in [986d72288b]
Not logged in

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Tidied up error handling, added separate client and server demos.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:986d72288bc110ca8428ed2a15efec9965aebfd3
User & Date: alaric 2017-12-29 00:32:22
Context
2018-02-28
21:17
Tests! Not working yet, though. Leaf check-in: 0c6903729f user: alaric tags: trunk
2017-12-29
00:32
Tidied up error handling, added separate client and server demos. check-in: 986d72288b user: alaric tags: trunk
2017-12-28
21:12
Added DOWNLOAD.wiki check-in: 410f39f189 user: alaric tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to README.wiki.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21



22
23

24
25
26
27
28
29
30
31


32
33
34
35
36
37
38


39
40


41
42

43


44
45
46

47
48
49

50
51
52
53
54
55

56
57
58
59
60

61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
<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>

<h2>As a client</h2>




<pre>(use bokbok)


;; 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 "myserver" 12345)
             "myuser" (passphrase->key "mypassphrase")
             request-handler close-handler))



(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)</pre>

<h2>As a server</h2>


<pre>(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 ()
           (request! con '("callback" "1"))
           (thread-sleep! 1)
           (request! con '("callback" "2"))
           (thread-sleep! 1)
           (request! con '("callback" "3"))
           (thread-sleep! 1)
           (request! con '("callback" "4")))))
     ;; Return this while the callback thread runs in the background
     (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 user->key
   open-handler request-handler close-handler)

(wait-until-0server-stopped server)</pre>







|












|
>
>
>

<
>

<
<
<
|
<
<

>
>
|
<
<

<
<
<
>
>

<
>
>

<
>

>
>
|
|
<
>
|

|
>

<
|

|
<
>
|
|
|
<

>
|
|
|
|
|

|
|
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<

<
<
<
<
<
<
<
<
<
<
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25

26
27



28


29
30
31
32


33



34
35
36

37
38
39

40
41
42
43
44
45

46
47
48
49
50
51

52
53
54

55
56
57
58

59
60
61
62
63
64
65
66
67
68
69


















70










<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.





























Added bokbok-client.scm.



























































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
(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)

Changes to bokbok-demo.scm.

45
46
47
48
49
50
51
52
53
54





55

56
57
58
59
60
61
62
63

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

(define (run-client! con)
  (expect '(ok ("echo" "hello"))
          (request! con '("hello")))
  (expect '(error ("\"Error raised\" in (#f)"))





          (request! con '("error")))

  (expect '(ok ("did it"  "(ok (\"echo\" \"called you back\"))"))
          (request! con '("callback")))
  (thread-sleep! 10)
#;  (expect '(ok ("ok"))
          (request! con '("kill")))
  (close-connection! con))

(define (run-server! server)







|

|
>
>
>
>
>
|
>
|







45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69

(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)

Added bokbok-server.scm.











































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
(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*)

Changes to bokbok.scm.

2
3
4
5
6
7
8



9
10
11
12
13
14
15
..
31
32
33
34
35
36
37


38
39
40





41
42
43
44


45
46
47
48
49
50
51
..
79
80
81
82
83
84
85

86
87
88
89
90
91
92
...
204
205
206
207
208
209
210

211
212

213
214
215
216
217
218
219
...
238
239
240
241
242
243
244

245
246
247


248
249
250
251
252
253
254
255
256
257
258
259
260
261
262

263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
...
308
309
310
311
312
313
314



315
316
317
318
319
320
321
322
323
...
341
342
343
344
345
346
347
348
349
350
351
352
353
354

355
356
357
358
359
360
361
362
363
364
365
366
367

368
369
370
371
372
373
374
375

376





377






378
379
380
381
382
383
384
...
390
391
392
393
394
395
396

397
398
399
400
401
402
403
 bokbok
 (passphrase->key

  open-connection
  close-connection!
  request!




  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: User data field in a connection

 ;; FIXME: Reduce timeouts to detect gone servers quickly






 ;; FIXME: Auto reconnect on request!

 ;; FIXME: Configurable maximum message size (and use 4 bytes, so it can be >64KiB)



#; (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)

   (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))))

     (mutex-lock! (connection-mutex con))
     (write-packet! (connection-output con) packet)

     (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)

   (mutex-lock! (connection-mutex con))
   (let ((waiter (hash-table-ref/default (connection-waiters con)
                                         id #f)))


     (if waiter
         (begin
           (set-cdr! waiter body)
           (mutex-unlock! (car waiter)))
         (debug "Discarding response to unknown request id:~a" id)))
   (mutex-unlock! (connection-mutex con)))

 (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))))

        (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 (list 'ok body)))
               (("err" id . body)
                (handle-response! con id (list 'error body))))
              ;; 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 (address-information host port)))
              (socket-connect s (addrinfo-address (car ai))#;(inet-address host port))
              (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 flags to suppress 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)

   (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))

     (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

     (cdr waiter)))












 (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-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

           (make-thread
            (lambda ()
              (let loop ()
                (debug "Listener thread calling accept")
                (let* ((cs
                        (socket-accept s))
                       (handler-thread







>
>
>







 







>
>



>
>
>
>
>



|
>
>







 







>







 







>


>







 







>



>
>




|
<









>













|
|
|







 







>
>
>
|
|







 







|
|





>













>








>
|
>
>
>
>
>

>
>
>
>
>
>







 







>







2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
..
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
..
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
...
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
...
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270

271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
...
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
...
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
...
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
 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-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