From 884f3fe92174171c7c8439c737de89122f260053 Mon Sep 17 00:00:00 2001 From: Abdulaziz Ghuloum Date: Sun, 23 Mar 2008 05:02:12 -0400 Subject: [PATCH] Added tcp-server-socket-nonblocking, tcp-accept-connection-nonblocking and register-callback for handling nonblocking servers and connections. --- lab/greeting-server-async.ss | 45 +++++++++++++++++++++++ scheme/ikarus.io.ss | 69 ++++++++++++++++++++++++++++-------- scheme/last-revision | 2 +- scheme/makefile.ss | 5 ++- 4 files changed, 105 insertions(+), 16 deletions(-) create mode 100755 lab/greeting-server-async.ss diff --git a/lab/greeting-server-async.ss b/lab/greeting-server-async.ss new file mode 100755 index 0000000..23ffd98 --- /dev/null +++ b/lab/greeting-server-async.ss @@ -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)) diff --git a/scheme/ikarus.io.ss b/scheme/ikarus.io.ss index 575627a..6196af2 100644 --- a/scheme/ikarus.io.ss +++ b/scheme/ikarus.io.ss @@ -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) @@ -2199,19 +2205,37 @@ (cond [(fx>= sock 0) (make-tcp-server portnum sock)] [else (die 'tcp-server-socket "failed to start server")]))) + + (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 (accept-connection s) - (define who 'accept-connection) + + (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*) ) diff --git a/scheme/last-revision b/scheme/last-revision index 7f21e83..b0bd56f 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1423 +1424 diff --git a/scheme/makefile.ss b/scheme/makefile.ss index f975934..21a2c81 100755 --- a/scheme/makefile.ss +++ b/scheme/makefile.ss @@ -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]