bokbok
Check-in [38a1436a2f]
Not logged in

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

Overview
Comment:Sorted out address representation properly
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:38a1436a2fde31ebb001bb0e3ccbe2bb1e085f94
User & Date: alaric 2017-12-28 17:44:48
Context
2017-12-28
18:03
Started documentation check-in: 44dd02f4c3 user: alaric tags: trunk
17:44
Sorted out address representation properly check-in: 38a1436a2f user: alaric tags: trunk
16:24
Initial version, supporting plaintext and encrypted TCP and unix-domain sockets check-in: f815e815bf user: alaric tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to bokbok-demo.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
..
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
(use bokbok)
(use matchable)

(define *server* #f)

(define (open-handler con)
  (printf "OPEN from ~a @ ~a:~a\n"
          (connection-user con)
          (connection-host con)
          (connection-port con)))

(define (close-handler con)
  (printf "CLOSE from ~a @ ~a:~a\n"
          (connection-user con)
          (connection-host con)
          (connection-port con)))

(define (request-handler con request)
  (printf "REQUEST from ~a @ ~a:~a: ~s\n"
          (connection-user con)
          (connection-host con)
          (connection-port con)
          request)

  (match request
         (("error")
          (error "Error raised"))
         (("callback")
          (let ((response
................................................................................
              (begin
                (stop-server! *server*)
                (list "ok"))
              (error "I'm not a server")))
         (else
          (cons "echo" request))))






(define (run-client! con)
  (printf "> ")
  (let ((req (read)))
    (if (eof-object? req)








        (close-connection! con)
        (begin
         (printf
          "Reply: ~s\n"
          (request! con req))
         (run-client! con)))))

(define (run-server! server)
  (set! *server* server)
  (printf "Running server...\n")
  (wait-until-server-stopped server))

(match
 (command-line-arguments)
 (("client" "unix" path)
  (run-client! (open-connection path #f #f #f request-handler close-handler)))
 (("client" "unix" path user pass)
  (run-client! (open-connection path #f user (passphrase->key pass) request-handler close-handler)))

 (("server" "unix" path)
  (run-server! (start-server path #f 10 #f open-handler request-handler close-handler)))
 (("server" "unix" path pass)
  (run-server! (start-server path #f 10 (lambda _ (passphrase->key pass)) open-handler request-handler close-handler)))

 (("client" "tcp" addr port)
  (run-client! (open-connection addr (string->number port) #f #f request-handler close-handler)))
 (("client" "tcp" addr port user pass)
  (run-client! (open-connection addr (string->number port) user (passphrase->key pass) request-handler close-handler)))

 (("server" "tcp" port)
  (run-server! (start-server #f (string->number port) 10 #f open-handler request-handler close-handler)))
 (("server" "tcp" port pass)
  (run-server! (start-server #f (string->number port) 10 (lambda _ (passphrase->key pass)) open-handler request-handler close-handler)))

 (else
  (printf "Imagine a comprehensive usage screen here!\n")))






|

|
<


|

|
<


|

|
<







 







>
>
>
>
>

<
<
<
>
>
>
>
>
>
>
>
|
<
<
<
<
<









|

|


|

|


|

|


|

|



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
..
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
(use bokbok)
(use matchable)

(define *server* #f)

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


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


(define (request-handler con request)
  (printf "REQUEST from ~a @ ~s: ~s\n"
          (connection-user con)
          (connection-addr con)

          request)

  (match request
         (("error")
          (error "Error raised"))
         (("callback")
          (let ((response
................................................................................
              (begin
                (stop-server! *server*)
                (list "ok"))
              (error "I'm not a server")))
         (else
          (cons "echo" request))))

(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")))
#;  (expect '(ok ("ok"))
          (request! con '("kill")))
  (close-connection! con))






(define (run-server! server)
  (set! *server* server)
  (printf "Running server...\n")
  (wait-until-server-stopped server))

(match
 (command-line-arguments)
 (("client" "unix" path)
  (run-client! (open-connection `(unix ,path) #f #f request-handler close-handler)))
 (("client" "unix" path user pass)
  (run-client! (open-connection `(unix ,path) user (passphrase->key pass) request-handler close-handler)))

 (("server" "unix" path)
  (run-server! (start-server `(unix ,path) 10 #f open-handler request-handler close-handler)))
 (("server" "unix" path pass)
  (run-server! (start-server `(unix ,path) 10 (lambda _ (passphrase->key pass)) open-handler request-handler close-handler)))

 (("client" "tcp" addr port)
  (run-client! (open-connection `(tcp ,addr ,(string->number port)) #f #f request-handler close-handler)))
 (("client" "tcp" addr port user pass)
  (run-client! (open-connection `(tcp ,addr ,(string->number port)) user (passphrase->key pass) request-handler close-handler)))

 (("server" "tcp" port)
  (run-server! (start-server `(tcp #f ,(string->number port)) 10 #f open-handler request-handler close-handler)))
 (("server" "tcp" port pass)
  (run-server! (start-server `(tcp #f ,(string->number port)) 10 (lambda _ (passphrase->key pass)) open-handler request-handler close-handler)))

 (else
  (printf "Imagine a comprehensive usage screen here!\n")))

Changes to bokbok.scm.

4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
..
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
...
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
...
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
...
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
304
305
306
307


308
309
310
311

312
313
314


315
316
317
318
319
320
321
322
323
...
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
...
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
420
421
422
423
...
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
...
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473

  open-connection
  close-connection!
  request!

  connection?
  connection-user
  connection-host
  connection-port

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

 (import chicken scheme)
................................................................................

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

 (define *header* "BOKBOKBOK")

 (define (read-packet! i)
   (let ((l1 (read-byte i)))
     (if (eof-object? l1)
................................................................................
          (nonce-u8vector (blob->u8vector/shared (string->blob nonce)))
          (plaintext ((cdr key) c-wo-n nonce-u8vector)))
     (if plaintext
         plaintext
         (error "Invalid cyphertext"))))

 (define-record-type connection
   (make-connection* host port user
                    socket input output
                    key
                    mutex
                    thread
                    waiters
                    request-handler
                    close-handler
                    counter)
   connection?
   (host connection-host)
   (port connection-port)
   (user connection-user)
   (socket connection-socket)
   (input connection-input)
   (output connection-output)
   (key connection-key)
   (mutex connection-mutex)
   (thread connection-thread)
................................................................................
                     (append
                      (list "ok" id)
                      ((connection-request-handler con)
                       con
                       body)))))
               (debug "Sending response id:~a ~s" id response)
               (connection-send! con response)))
           `(bokbok-request-thread ,(connection-host con) ,(connection-port 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)))
................................................................................
               (("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 host port user socket input output key request-handler close-handler)
   (let ((con
          (make-connection*
           host port user
           socket input output
           key
           (make-mutex `(bokbok-connection-mutex ,host ,port))
           (make-thread handle-connection-thread!
                        `(bokbok-connection-thread ,host ,port))
           (make-hash-table)
           request-handler
           close-handler
           0)))

     (thread-specific-set!
      (connection-thread con)
      con)
     (thread-start!
      (connection-thread con))
     con))

 (define (open-connection host port username key request-handler close-handler)
   (let ((s
          (if (not port)


              ;; UNIX domain
              (let ((s (socket af/unix sock/stream)))
                (socket-connect s (unix-address host))
                s)

              ;; TCP domain
              (let ((s (socket af/inet sock/stream)))
                (socket-connect s (inet-address host port))


                (set! (tcp-no-delay? s) #t)
                s))))
     (receive
      (input output)
      (parameterize
       ((socket-send-buffer-size 4096)
        (socket-send-size 16384))
       (socket-i/o-ports s))
      (if (and username key)
................................................................................
             (debug "Client writing username and session key")
             (write-packet-no-flush! output username)
             (write-packet! output (encrypt key session-key-bytes))
             (debug "Client waiting for header")
             (let ((header (read-string (string-length *header*) input)))
               (debug "Got header bytes: ~s" header)
               (if (string=? header *header*)
                   (make-connection host port username s input output session-key request-handler close-handler)
                   (error "Invalid hello from server" header)))))
          (begin ;; Plaintext connection
            (debug "Client waiting for header")
            (let ((header (read-string (string-length *header*) input)))
              (debug "Got header bytes: ~s" header)
              (if (string=? header *header*)
                  (make-connection host port #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-host con) ,(connection-port con) id))
                        #f)))

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

................................................................................

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

     ;; Return response
     (cdr waiter)))

 (define (start-server bind-addr bind-port backlog user->key open-handler request-handler close-handler)
   (let* ((s (if (not bind-port)


                 ;; UNIX domain
                 (let ((s (socket af/unix sock/stream)))
                   (socket-bind s (unix-address bind-addr))
                   (socket-listen s backlog)
                   s)

                 ;; TCP domain
                 (let ((s (socket af/inet sock/stream)))
                   (socket-bind s (inet-address bind-addr bind-port))
                   (set! (so-reuse-address? s) #t)
                   (socket-listen s backlog)
                   s)))


          (thread
           (make-thread
            (lambda ()
              (let loop ()
                (debug "Listener thread calling accept")
                (let* ((cs
                        (socket-accept s))
                       (handler-thread
                        (make-thread
                         (lambda ()
                           ;; Connection setup handler thread
                           ;; Hands over to connection thread when make-connection is called
                           (when bind-port
                                 (set! (tcp-no-delay? cs) #t))
                           (receive
                            (input output)
                            (parameterize
                             ((socket-send-buffer-size 4096)
                              (socket-send-size 16384))
                             (socket-i/o-ports cs))
                            (let* ((peer (socket-peer-name cs))
                                   (host (if bind-port
                                             (sockaddr-address peer)
                                             #f))
                                   (port (if bind-port
                                             (sockaddr-port peer)
                                             #f)))
                              (debug "Handshake thread started for ~a:~a" host port)
                              (if user->key
                                  ;; Encrypted connection
                                  (let* ((user-name (read-packet! input))
                                         (encrypted-session-key (read-packet! input)))
                                    (if (and (not (eof-object? user-name))
                                             (not (eof-object? encrypted-session-key)))
                                        (let ((user-key (user->key user-name)))
................................................................................
                                                (if session-key
                                                    (begin
                                                      (debug "Writing header")
                                                      (write-string *header* #f output)
                                                      (flush-output output)
                                                      (open-handler
                                                       (make-connection
                                                        host port user-name
                                                        cs input output
                                                        session-key
                                                        request-handler close-handler)))
                                                    (begin
                                                      (debug "Rejecting connection due to invalid session key")
                                                      (close-output-port output)
                                                      (close-input-port input))))
................................................................................
                                  ;; Plaintext connection
                                  (begin
                                    (debug "Writing header")
                                    (write-string *header* #f output)
                                    (flush-output output)
                                    (open-handler
                                     (make-connection
                                      host port #f
                                      cs input output
                                      #f
                                      request-handler close-handler))))))
                           cs)
                         `(bokbok-connection-handler ,bind-addr ,bind-port))))
                  (debug "Listener thread starting handshake thread")
                  (thread-start! handler-thread)
                  (loop))))
            `(bokbok-listen-handler ,bind-addr ,bind-port))))
     (thread-specific-set! thread s)
     (thread-start! thread)
     thread))

 (define (stop-server! server)
   (thread-terminate! server))








|
<







 







|



|







 







|









|
<







 







|







 







|


|


|

|












|

|
>
>
|
|
|
|
>
|
|
<
>
>
|
|







 







|






|












|







 







|
|
>
>

|
|
|
|
>
|
|
|
|
|
|
>
>












|








|
|
<
<
|
<
|







 







|







 







|




|



|







4
5
6
7
8
9
10
11

12
13
14
15
16
17
18
..
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
...
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194

195
196
197
198
199
200
201
...
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
...
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
304
305
306
307
308
309
310
311
312
313
314

315
316
317
318
319
320
321
322
323
324
325
...
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
...
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

420
421
422
423
424
425
426
427
...
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
...
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477

  open-connection
  close-connection!
  request!

  connection?
  connection-user
  connection-addr


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

 (import chicken scheme)
................................................................................

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

 (define *header* "BOKBOKBOK")

 (define (read-packet! i)
   (let ((l1 (read-byte i)))
     (if (eof-object? l1)
................................................................................
          (nonce-u8vector (blob->u8vector/shared (string->blob nonce)))
          (plaintext ((cdr key) c-wo-n nonce-u8vector)))
     (if plaintext
         plaintext
         (error "Invalid cyphertext"))))

 (define-record-type connection
   (make-connection* addr user
                    socket input output
                    key
                    mutex
                    thread
                    waiters
                    request-handler
                    close-handler
                    counter)
   connection?
   (addr connection-addr)

   (user connection-user)
   (socket connection-socket)
   (input connection-input)
   (output connection-output)
   (key connection-key)
   (mutex connection-mutex)
   (thread connection-thread)
................................................................................
                     (append
                      (list "ok" id)
                      ((connection-request-handler con)
                       con
                       body)))))
               (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)))
................................................................................
               (("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
           socket input output
           key
           (make-mutex `(bokbok-connection-mutex ,addr))
           (make-thread handle-connection-thread!
                        `(bokbok-connection-thread ,addr))
           (make-hash-table)
           request-handler
           close-handler
           0)))

     (thread-specific-set!
      (connection-thread con)
      con)
     (thread-start!
      (connection-thread con))
     con))

 (define (open-connection addr username key request-handler close-handler)
   (let ((s
          (match
           addr
           (('unix path)
            ;; 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))
       (socket-i/o-ports s))
      (if (and username key)
................................................................................
             (debug "Client writing username and session key")
             (write-packet-no-flush! output username)
             (write-packet! output (encrypt key session-key-bytes))
             (debug "Client waiting for header")
             (let ((header (read-string (string-length *header*) input)))
               (debug "Got header bytes: ~s" header)
               (if (string=? header *header*)
                   (make-connection addr username s input output session-key request-handler close-handler)
                   (error "Invalid hello from server" header)))))
          (begin ;; Plaintext connection
            (debug "Client waiting for header")
            (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))

................................................................................

     ;; 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-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
           (make-thread
            (lambda ()
              (let loop ()
                (debug "Listener thread calling accept")
                (let* ((cs
                        (socket-accept s))
                       (handler-thread
                        (make-thread
                         (lambda ()
                           ;; Connection setup handler thread
                           ;; Hands over to connection thread when make-connection is called
                           (when tcp?
                                 (set! (tcp-no-delay? cs) #t))
                           (receive
                            (input output)
                            (parameterize
                             ((socket-send-buffer-size 4096)
                              (socket-send-size 16384))
                             (socket-i/o-ports cs))
                            (let* ((peer (socket-peer-name cs))
                                   (peer-addr (if tcp?
                                                  (list 'tcp (sockaddr-address peer) (sockaddr-port peer))


                                                  '(unix (sockaddr-path peer)))))

                              (debug "Handshake thread started for ~s" peer-addr)
                              (if user->key
                                  ;; Encrypted connection
                                  (let* ((user-name (read-packet! input))
                                         (encrypted-session-key (read-packet! input)))
                                    (if (and (not (eof-object? user-name))
                                             (not (eof-object? encrypted-session-key)))
                                        (let ((user-key (user->key user-name)))
................................................................................
                                                (if session-key
                                                    (begin
                                                      (debug "Writing header")
                                                      (write-string *header* #f output)
                                                      (flush-output output)
                                                      (open-handler
                                                       (make-connection
                                                        peer-addr user-name
                                                        cs input output
                                                        session-key
                                                        request-handler close-handler)))
                                                    (begin
                                                      (debug "Rejecting connection due to invalid session key")
                                                      (close-output-port output)
                                                      (close-input-port input))))
................................................................................
                                  ;; Plaintext connection
                                  (begin
                                    (debug "Writing header")
                                    (write-string *header* #f output)
                                    (flush-output output)
                                    (open-handler
                                     (make-connection
                                      peer-addr #f
                                      cs input output
                                      #f
                                      request-handler close-handler))))))
                           cs)
                         `(bokbok-handshake-handler ,bind-addr))))
                  (debug "Listener thread starting handshake thread")
                  (thread-start! handler-thread)
                  (loop))))
            `(bokbok-listen-handler ,bind-addr))))
     (thread-specific-set! thread s)
     (thread-start! thread)
     thread))

 (define (stop-server! server)
   (thread-terminate! server))