1;; -*- scheme -*-
2(add-load-path "./socket")
3(add-load-path "./threads")
4
5#!read-macro=sagittarius/bv-string
6(import (srfi :64 testing)
7	(srfi :13 strings)
8	(rnrs)
9	(srfi :0 cond-expand)
10	(clos user)
11	(sagittarius socket)
12	(sagittarius) ;; for format
13	;; use thread for testing
14	(sagittarius threads)
15	(prefix (binary io) b:)
16	(util bytevector)
17	(util concurrent)
18	(srfi :106))
19
20(define (shutdown&close s)
21  (socket-shutdown s SHUT_RDWR)
22  (socket-close s))
23
24(define echo-server-socket (make-server-socket "5000"))
25(define echo-server-queue (make-shared-queue))
26;; addr is client socket
27(define (server-run)
28  (define stop? #f)
29  (let loop ()
30    (guard (e (else #t))
31      (let ((addr (socket-accept echo-server-socket)))
32	(call-with-socket addr
33	  (lambda (sock)
34	    (let ((p (socket-port sock)))
35	      (call-with-port p
36		(lambda (p)
37		  (let lp2 ((l (b:get-line p)))
38		    (let ((r (bytevector-trim-right l)))
39		      (cond
40		       ((or (eof-object? r) (bytevector=? r #*"end"))
41			(set! stop? #t))
42		       ((bytevector=? r #*"test-end")
43			(put-bytevector p #vu8()))
44		       (else
45			(let ((res (bytevector-append r #*"\r\n")))
46			  ;; wait one sec
47			  (when (bytevector=? r #*"wait") (thread-sleep! 1))
48			  (put-bytevector p res 0 (bytevector-length res))
49			  (when (bytevector=? r #*"push")
50			    (shared-queue-put! echo-server-queue #t))
51			  (lp2 (b:get-line p))))))))))))))
52    (unless stop? (loop))))
53(define server-thread (make-thread server-run))
54
55(test-begin "Sagittarius socket")
56;; start echo server
57(thread-start! server-thread)
58
59(test-error "ai-passive" assertion-violation?
60	    (make-client-socket #f "5000" 0 0 AI_PASSIVE))
61
62(let ((client-socket (make-client-socket "localhost" "5000")))
63  (test-assert "socket?"(socket? client-socket))
64  (test-equal "raw socket-send"
65	      (+ (string-length "push") 2) ;; for \r\n
66	      (socket-send client-socket (string->utf8 "push\r\n") 0))
67  (shared-queue-get! echo-server-queue)
68  ;; these are not documented
69  (test-assert "socket-read-select"
70	       (not (null? (socket-read-select #f client-socket))))
71  (test-assert "socket-write-select"
72	       (not (null? (socket-write-select #f client-socket))))
73  ;; does socket even have error fd?
74  ;; (test-assert "socket-error-select"
75  ;;               (null? (socket-error-select 100 client-socket)))
76
77  ;; fdset
78  ;; `socket-select!`, `socket-select` and fdset related procedures
79  ;; are not documented so may change especially socket doesn't have
80  ;; error side FD so I think it's useless.
81  (let ((fdset (make-fdset)))
82    (test-assert "fdset?" (fdset? fdset))
83    (test-assert "fdset-set! (1)" (fdset-set! fdset client-socket #t))
84    (test-assert "fdset-ref  (1)" (fdset-ref fdset client-socket))
85    (test-assert "fdset-set! (2)" (fdset-set! fdset client-socket #f))
86    (test-assert "fdset-ref  (2)" (not (fdset-ref fdset client-socket)))
87    (test-assert "fdset-set! (3)" (fdset-set! fdset client-socket #t))
88    ;; it's ready already
89    ;; what's good for specifying error fds?
90    (let-values (((n r w e) (socket-select! fdset #f #f #f)))
91      (test-equal "socket-select!" 1 n)
92      (test-assert "socket-select!" (fdset? r))
93      (test-assert "socket-select!" (not w))
94      (test-assert "socket-select!" (not e)))
95
96    (let-values (((n r w e) (socket-select fdset #f #f #f)))
97      (test-equal "socket-select" 1 n)
98      (test-assert "socket-select" (fdset? r))
99      (test-assert "socket-select" (not w))
100      (test-assert "socket-select" (not e)))
101
102    (test-assert "fdset-ref  (3)" (fdset-ref fdset client-socket))
103    (let ((l (list client-socket)))
104      (test-equal "collect-sockets" l (collect-sockets fdset))
105      (test-assert "sockets->fdset" (fdset? (sockets->fdset l)))))
106
107  (test-equal "raw socket-recv"
108	      (string->utf8 "push\r\n")
109	      (socket-recv client-socket (+ (string-length "push") 2) 0))
110
111  (test-equal "raw socket-send (2)"
112	      (+ (string-length "hello") 2) ;; for \r\n
113	      (socket-send client-socket (string->utf8 "hello\r\n") 0))
114  (test-equal "raw socket-recv!"
115	      (+ (string-length "hello") 2)
116	      (let ((bv (make-bytevector (+ (string-length "hello") 2))))
117		(socket-recv! client-socket bv 0
118			      (+ (string-length "hello") 2) 0)))
119
120  ;; make port
121  (let ((port (socket-port client-socket)))
122    (test-assert "port?" (port? port))
123    (test-assert "binary-port?" (binary-port? port))
124    (test-assert "input-port?" (input-port? port))
125    (test-assert "output-port?" (output-port? port))
126
127    (put-bytevector port (string->utf8 "put from port\r\n"))
128    (test-equal "get-bytevector-n"
129		(string->utf8 "put from port\r\n")
130		(get-bytevector-n port
131				  (string-length "put from port\r\n")))
132    ;; textual
133    (let ((text-port (transcoded-port port
134				      (make-transcoder (utf-8-codec)
135						       'crlf))))
136      (put-string text-port "put from text port\r\n")
137      (test-equal "get-line" "put from text port" (get-line text-port))
138      ;; end test
139      (put-string text-port "test-end\r\n")
140      )))
141
142(let ((client-socket (make-client-socket "localhost" "5000")))
143  (socket-nonblocking! client-socket)
144  (test-equal "raw nonblocking socket-send"
145	      (+ (string-length "wait") 2)
146	      (socket-send client-socket (string->utf8 "wait\r\n") 0))
147  (test-equal "raw nonblocking socket-recv"
148	      #f
149	      (socket-recv client-socket (+ (string-length "hello\r\n") 2) 0))
150  (socket-send client-socket (string->utf8 "test-end\r\n") 0)
151  (test-assert "socket-close" (socket-close client-socket))
152  (test-assert "socket-closed? (1)" (socket-closed? client-socket))
153  )
154
155
156;; call #125
157(let* ((client-socket (make-client-socket "localhost" "5000"))
158       (in/out (socket-port client-socket))
159       (msg "hello\n"))
160  (define (ensure-n in n)
161    (let loop ((n n) (r '()))
162      (let ((bv (get-bytevector-n in n)))
163	(if (= (bytevector-length bv) n)
164	    (bytevector-concatenate (reverse! (cons bv r)))
165	    (loop (- n (bytevector-length bv)) (cons bv r))))))
166  (test-assert "with display" (display msg in/out))
167  (test-assert "with format" (format in/out msg))
168  ;; response contains \r
169  (let ((r (ensure-n in/out (+ (* (string-length msg) 2) 2))))
170    ;;(write (utf8->string r)) (newline)
171    (test-equal "result" #*"hello\r\nhello\r\n" r))
172
173  (put-bytevector in/out #*"test-end\r\n")
174  (close-port in/out)
175  ;; socket-port without optional argument closes given socket
176  (test-assert "socket-closed? (2)" (socket-closed? client-socket)))
177
178;; now socket-port creates bidirectional port
179(let ((port (socket-port (make-client-socket "localhost" "5000")))
180      (text "bidirectional port\r\n"))
181  (define recv-thread
182    (make-thread
183     (lambda ()
184       (get-bytevector-n port (string-length text)))))
185  (define send-thread
186    (make-thread
187     (lambda ()
188       (put-bytevector port (string->utf8 text)))))
189  ;; it's not a good test case because it's assuming it works properly.
190  (thread-start! recv-thread)
191  (thread-sleep! 0.1)
192  (thread-start! send-thread)
193  (test-equal "bidirectional port" text
194	      (utf8->string (thread-join! recv-thread)))
195  (put-bytevector port (string->utf8 "end\r\n"))
196  )
197
198(test-assert "wait server ends" (thread-join! server-thread))
199(shutdown&close echo-server-socket)
200
201;; addr info slots
202(let ((info (get-addrinfo "localhost" "5000" (make-hint-addrinfo
203					      :family AF_INET
204					      :socktype SOCK_DGRAM))))
205  (test-assert "sockaddr?" (sockaddr? (addrinfo-sockaddr info)))
206  (let ((s (make-socket AF_INET SOCK_DGRAM)))
207    (test-equal "seocket-sendto" 4
208		(socket-sendto s #vu8(1 2 3 4) (addrinfo-sockaddr info)))))
209
210;; TODO test for socket-recvfrom and socket-recvfrom!
211
212(test-equal "msg-peek"    MSG_PEEK *msg-peek*)
213(test-equal "msg-oob"     MSG_OOB *msg-oob*)
214(test-equal "msg-waitall" MSG_WAITALL *msg-waitall*)
215
216;; blocking retry of get-bytevector-n
217(let ()
218  (define server (make-server-socket "5001"))
219
220  (define t (make-thread
221	     (lambda ()
222	       (let ((s (socket-accept server)))
223		 (socket-send s #vu8(0 1 2 3 4))))))
224  (thread-start! t)
225  (let ()
226    (define client (make-client-socket "localhost" "5001"))
227    (define in (socket-input-port client))
228    (define buf (make-bytevector 10))
229    (test-equal "get-bytevector-n shouldn't block" #vu8(0 1 2 3 4)
230		(get-bytevector-n in 10))
231    (shutdown&close client)
232    (shutdown&close server)))
233
234;; thread-interrupt!
235;; cancelling blocking socket operation in other threads
236(let ()
237  (define server (make-server-socket "5001"))
238  (define t (make-thread
239	      (lambda ()
240		(socket-read-select #f server))))
241  (test-error "not blocked" condition? (thread-interrupt! t))
242  (thread-start! t)
243  (thread-sleep! 1) ;; wait a bit
244  (test-assert "thread-interrupt!" (thread-interrupt! t))
245  (test-equal "result" '() (thread-join! t))
246  (socket-close server))
247
248;; signal related
249;; this test case is only relevant on multi core Linux
250(let ()
251  (define server (make-server-socket "5001"))
252  (define interrupted? #f)
253  (define started? #f)
254  (define t (thread-start!
255	     (make-thread
256	      (lambda ()
257		(set! started? #t)
258		(socket-read-select #f server)
259		(set! interrupted? #t)))))
260  (unless started?
261    (thread-yield!)
262    (thread-sleep! 1))
263  (gc) ;; this uses signal on Linux
264  (test-assert "not interrupted" (not interrupted?))
265  (test-assert "thread-interrupt!" (thread-interrupt! t))
266  (thread-yield!)
267  (thread-sleep! 1)
268  (test-assert "interrupted" interrupted?)
269  (shutdown&close server))
270
271;; ditto
272(let ()
273  (define server (make-server-socket "5001"))
274  (define interrupting? #f)
275  (define accepted #f)
276  (define recieved #f)
277  (define (yield!)
278    (thread-yield!)
279    (thread-sleep! 1))
280  (define (invoke-gc)
281    (gc) ;; this uses signal on Linux
282    (set! interrupting? #t)
283    (thread-interrupt! t) ;; interrupted flag on
284    (yield!))
285  (define t (thread-start!
286	     (make-thread
287	      (lambda ()
288		(let loop ()
289		  (let ((client (socket-accept server)))
290		    (cond (client
291			   (set! accepted #t)
292			   (set! recieved (socket-recv client 1))
293			   (socket-close client)
294			   recieved)
295			  (else
296			   (if interrupting?
297			       (test-assert "socket-accept (interrupt)" #t)
298			       (test-assert "socket-accept (interrupt)" #f))
299			   (loop)))))))))
300  (invoke-gc)
301  (test-assert "not accepted" (not accepted))
302  (let ((client (make-client-socket "localhost" "5001")))
303    (yield!)
304    (test-assert "accepted" accepted)
305    (test-assert "not recieved" (not recieved))
306    (socket-send client #vu8(1))
307    (test-equal "received" #vu8(1) (thread-join! t))
308    (shutdown&close client))
309  (shutdown&close server))
310
311;; call #134, socket-select returns incorrect socket
312(let ()
313  (define server (make-server-socket "5001"))
314  (define vec (make-vector 5))
315  (define server-lock (make-mutex))
316  (define client-lock (make-mutex))
317  (define t
318    (thread-start!
319     (make-thread
320      (lambda ()
321	(mutex-lock! server-lock)
322	(let loop ((i 0))
323	  (unless (= i 5)
324	    (let ((s (socket-accept server)))
325	      (vector-set! vec i s)
326	      (loop (+ i 1)))))
327	;; FIXME we need something nicer
328	(mutex-unlock! server-lock)
329	(mutex-lock! client-lock)
330	(mutex-unlock! client-lock)
331
332	(apply socket-read-select #f (vector->list vec))))))
333  ;; lock it
334  (mutex-lock! client-lock)
335  (let ((s* (map (lambda (i) (make-client-socket "localhost" "5001"))
336		 ;; whatever is fine
337		 '(1 2 3 4 5))))
338    ;; wait until server is done
339    (mutex-lock! server-lock)
340    (mutex-unlock! server-lock)
341    ;; send it (server is waiting for you!)
342    (socket-send (car s*) #vu8(1))
343    (socket-send (car (last-pair s*)) #vu8(1))
344    ;; let server do select
345    (mutex-unlock! client-lock)
346
347    (let ((r (thread-join! t)))
348      (test-equal "socket-select (size)" 2 (length r))
349      (test-equal "socket-select (1)" (vector-ref vec 0) (car r))
350      (test-equal "socket-select (2)" (vector-ref vec 4) (cadr r))
351      (for-each shutdown&close s*)
352      (vector-for-each shutdown&close vec)
353      (shutdown&close server))))
354
355;; condition
356(test-error "&host-not-found" host-not-found-error?
357	    (make-client-socket "localhost" "123456789"))
358(guard (e ((host-not-found-error? e)
359	   (test-assert "localhost" (host-not-found-error-node e))
360	   (test-assert "123456789" (host-not-found-error-service e)))
361	  (else (test-assert "unexpected condition" #f)))
362  (make-client-socket "localhost" "123456789"))
363
364(test-end)
365