conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Added tcp-server-socket-nonblocking, tcp-accept-connection-nonblocking 

and register-callback for handling nonblocking servers and connections.
This commit is contained in:
Abdulaziz Ghuloum 2008-03-23 05:02:12 -04:00
parent 0f55361b19
commit 884f3fe921
4 changed files with 105 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
lab/greeting-server-async.ss Executable file
View File

@ -0,0 +1,45 @@
#!/usr/bin/env ikarus --r6rs-script
(import (ikarus))
(define (get-name p)
(list->string
(let f ()
(let ([x (read-char p)])
(cond
[(or (eof-object? x) (char-whitespace? x))
'()]
[else (cons x (f))])))))
(define serve
(case-lambda
[(who port)
(let ([s (tcp-server-socket-nonblocking
(or (string->number port)
(error who "invalid port number" port)))])
(call/cc
(lambda (k)
(with-exception-handler k
(lambda ()
(let f ()
(let-values ([(op ip)
(accept-connection-nonblocking s)])
(let ([op (transcoded-port op (native-transcoder))]
[ip (transcoded-port ip (native-transcoder))])
(register-callback op
(lambda ()
(display "What's your name? " op)
(let ([name (get-name ip)])
(printf "Connection from ~s\n" name)
(fprintf op "Got it, ~a\n" name)
(close-input-port ip)
(close-output-port op))))))
(f))))))
(printf "\nClosing server ...\n")
(close-tcp-server-socket s))]
[(who)
(error who "missing port number")]
[(who . args)
(error who "too many arguments")]))
(apply serve (command-line))

69
scheme/ikarus.io.ss
View File

@ -65,7 +65,10 @@
tcp-connect tcp-connect-nonblocking
udp-connect udp-connect-nonblocking
tcp-server-socket accept-connection close-tcp-server-socket
tcp-server-socket tcp-server-socket-nonblocking
accept-connection accept-connection-nonblocking
close-tcp-server-socket
register-callback
)
@ -120,7 +123,10 @@
process
tcp-connect tcp-connect-nonblocking
udp-connect udp-connect-nonblocking
tcp-server-socket accept-connection close-tcp-server-socket
tcp-server-socket tcp-server-socket-nonblocking
accept-connection accept-connection-nonblocking
close-tcp-server-socket
register-callback
))
(module UNSAFE
@ -258,14 +264,14 @@
(define ($make-custom-binary-port attrs init-size id
read! write! get-position set-position! close buffer-size)
(let ([bv (make-bytevector buffer-size)])
($make-port attrs 0 init-size bv #f id read! write! get-position
set-position! close #f)))
($make-port attrs 0 init-size bv #f id read! write!
#f #f close #f)))
(define ($make-custom-textual-port attrs init-size id
read! write! get-position set-position! close buffer-size)
(let ([bv (make-string buffer-size)])
($make-port attrs 0 init-size bv #t id read! write! get-position
set-position! close #f)))
($make-port attrs 0 init-size bv #t id read! write!
#f #f close #f)))
(define (make-custom-binary-input-port id
read! get-position set-position! close)
@ -2200,18 +2206,36 @@
[(fx>= sock 0) (make-tcp-server portnum sock)]
[else (die 'tcp-server-socket "failed to start server")])))
(define (accept-connection s)
(define who 'accept-connection)
(define (tcp-server-socket-nonblocking portnum)
(let ([s (tcp-server-socket portnum)])
(set-fd-nonblocking (tcp-server-fd s)
'tcp-server-socket-nonblocking
'#f)
s))
(define (do-accept-connection s who blocking?)
(unless (tcp-server? s)
(die who "not a tcp server" s))
(let ([fd (tcp-server-fd s)])
(unless fd
(die who "server is closed" s))
(socket->ports
(foreign-call "ikrt_accept" fd)
'accept-connection
#f
#t)))
(let ([sock (foreign-call "ikrt_accept" fd)])
(cond
[(eq? sock EAGAIN-error-code)
(call/cc
(lambda (k)
(add-io-event fd k 'r)
(process-events)))
(do-accept-connection s who blocking?)]
[else
(socket->ports sock who #f blocking?)]))))
(define (accept-connection s)
(do-accept-connection s 'accept-connection #t))
(define (accept-connection-nonblocking s)
(do-accept-connection s 'accept-connection-nonblocking #f))
(define (close-tcp-server-socket s)
(define who 'close-tcp-server-socket)
@ -2220,11 +2244,28 @@
(let ([fd (tcp-server-fd s)])
(unless fd
(die who "server is closed" s))
;(file-close-proc who fd)
(let ([rv (foreign-call "ikrt_shutdown" fd)])
(when (fx< rv 0)
(die who "failed to shutdown")))))
(define (register-callback what proc)
(define who 'register-callback)
(unless (procedure? proc)
(die who "not a procedure" proc))
(cond
[(output-port? what)
(let ([c ($port-cookie what)])
(unless (fixnum? c) (die who "not a file-based port" what))
(add-io-event c proc 'w))]
[(input-port? what)
(let ([c ($port-cookie what)])
(unless (fixnum? c) (die who "not a file-based port" what))
(add-io-event c proc 'r))]
[(tcp-server? what)
(add-io-event (tcp-server-fd what) proc 'r)]
[else (die who "invalid argument" what)]))
(set-fd-nonblocking 0 'init '*stdin*)
)

2
scheme/last-revision
View File

@ -1 +1 @@
1423
1424

5
scheme/makefile.ss
View File

@ -1398,8 +1398,11 @@
[tcp-connect-nonblocking i]
[udp-connect-nonblocking i]
[tcp-server-socket i]
[close-tcp-server-socket i]
[tcp-server-socket-nonblocking i]
[accept-connection i]
[accept-connection-nonblocking i]
[close-tcp-server-socket i]
[register-callback i]
[&i/o-would-block i]
[make-i/o-would-block-condition i]
[i/o-would-block-condition? i]