bokbok
Check-in [0c6903729f]
Not logged in

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

Overview
Comment:Tests! Not working yet, though.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:0c6903729fc0edc0afbeaa4992d1aa7be4ad496b
User & Date: alaric 2018-02-28 21:17:47
Context
2020-05-28
15:32
Merge check-in: 16df45c616 user: alaric tags: trunk
2018-02-28
21:17
Tests! Not working yet, though. 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
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to bokbok.scm.

31
32
33
34
35
36
37












38
39
40
41
42
43
44

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








>
>
>
>
>
>
>
>
>
>
>
>







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

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

 ;; FIXME: Log handler exceptions - and call (get-call-chain) for details

 ;; FIXME: Try-again-later responses to requests, caused by a
 ;; configurable concurrent request limit or a special condition
 ;; type. CLient sleeps and retries (sleep time is listed in the
 ;; try-again-later response).

 ;; FIXME: TCP connection handshake to include option to redirect to
 ;; another server IP:port, controlled by the open handlers

 ;; open-connection gets all A records and tries until it gets in

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

Added tests/run.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
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
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
(use bokbok)

(use srfi-18)
(use test)

(define (make-test-client addr user key)
  (let ((callback-max 0)
        (close-count 0)
        (mutex (make-mutex)))
    (values
     ;; get counts closure
     (lambda ()
       (mutex-lock! mutex)
       (let ((cm callback-max)
             (cc close-count))
         (mutex-unlock! mutex)
         (values cm cc)))
     ;; connection object
     (open-connection addr user key
                      (lambda (con request)
                        (match request
                               (("count" numstr)
                                (let ((num (string->number numstr)))
                                  (mutex-lock! mutex)
                                  (when (> num callback-max)
                                        (set! callback-max num))
                                  (mutex-unlock! mutex)))))
                      (lambda (con)
                        (mutex-lock! mutex)
                        (set! close-count (+ close-count 1))
                        (mutex-unlock! mutex))))))

(define (make-test-server addr backlog user->key)
  (let ((total 0)
        (close-count 0)
        (mutex (make-mutex)))
    (values
     ;; get counts closure
     (lambda ()
       (mutex-lock! mutex)
       (let ((t total)
             (cc close-count))
         (mutex-unlock! mutex)
         (values t cc)))
     ;; connection object
     (start-server addr backlog user->key
                   (lambda (con)
                     (mutex-lock! mutex)
                     (let ((total-copy total))
                       (mutex-unlock! mutex)
                       (request! con (list "count"
                                           (number->string total-copy)))))
                   (lambda (con request)
                     (match request
                            (("add" numstr)
                             (let ((num (string->number numstr)))
                               (mutex-lock! mutex)
                               (set! total (+ total num))
                               (let ((total-copy total))
                                 (mutex-unlock! mutex)
                                 (request! con (list "count"
                                                     (number->string total-copy))))))))
                   (lambda (con)
                     (mutex-lock! mutex)
                     (set! close-count (+ close-count 1))
                     (mutex-unlock! mutex))))))

(define (run-test client-addr server-addr backlog encrypt?)
  (receive
   (get-server-counts server)
   (make-test-server server-addr backlog
                     (if encrypt? (lambda (username)
                                    (match username
                                           ("myuser" (passphrase->key "mypassphrase"))
                                           (else #f)))
                         #f))
   (receive
    (get-client-counts client)
    (make-test-client
     client-addr
     (if encrypt? "myuser" #f)
     (if encrypt? (passphrase->key "mypassphrase") #f))

    ;; Send test load: 10 threads sending 1..10 each
    (let ((threads
           (map
            (lambda (thread-number)
              (let ((thread
                     (make-thread
                      (lambda ()
                        (for-each
                         (lambda (idx)
                           (request! client
                                     (list "add" (number->string idx))))
                         (iota 10))))))
                (thread-start! thread)
                thread))
            (iota 10))))

    ;; Wait for them all to finish
      (for-each
       thread-join!
       threads))

    ;; Wait to make sure all callbacks have come back
    (thread-sleep! 1)

    ;; Close client
    (close-connection! client)

    ;; Close server
    (stop-server! server)
    (wait-until-server-stopped server)

    ;; Check everything is as expected
    ;; 450 = number of threads * sum of 1..number of iterations
    ;; = 10 * sum of 1..10
    ;; = 10 * 45
    ;; = 450
    (let-values (((client-total client-closes) (get-client-counts))
                 ((server-total server-closes) (get-server-counts)))
      (test "Client total" 450 client-total)
      (test "Client closes" 0 client-closes)
      (test "Server total" 450 server-total)
      (test "Server closes" 1 server-closes)))))


(run-test '(tcp "localhost" 9988) '(tcp #f 9988) 1 #f)