From 4bbc5c41f4f39d93de4ad513d654c93b8b93145e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 19 Jun 2005 01:15:07 +0000 Subject: [PATCH] fix multiplexer bug --- library/httpd/file-responder.factor | 2 +- library/httpd/httpd.factor | 10 ++-- library/unix/io.factor | 87 +++++++++++++++++++---------- library/unix/sockets.factor | 28 ++++++---- 4 files changed, 79 insertions(+), 48 deletions(-) diff --git a/library/httpd/file-responder.factor b/library/httpd/file-responder.factor index 25350e574b..5a272003c1 100644 --- a/library/httpd/file-responder.factor +++ b/library/httpd/file-responder.factor @@ -38,7 +38,7 @@ stdio streams strings unparser ; : serve-directory ( filename -- ) "/" ?tail [ dup "/index.html" append dup exists? [ - serve-file + nip serve-file ] [ drop list-directory ] ifte diff --git a/library/httpd/httpd.factor b/library/httpd/httpd.factor index b3d7633c7a..5e10608d68 100644 --- a/library/httpd/httpd.factor +++ b/library/httpd/httpd.factor @@ -50,12 +50,10 @@ stdio streams strings threads http sequences ; ] ifte ; : httpd-client ( socket -- ) - [ - dup log-client [ - 60000 stdio get set-timeout - read-line [ parse-request ] when* - ] with-stream - ] try ; + dup log-client [ + 60000 stdio get set-timeout + read-line [ parse-request ] when* + ] with-stream ; : httpd-connection ( socket -- ) "http-server" get accept [ httpd-client ] in-thread drop ; diff --git a/library/unix/io.factor b/library/unix/io.factor index f79f2ed4b7..433b154a2b 100644 --- a/library/unix/io.factor +++ b/library/unix/io.factor @@ -3,7 +3,7 @@ IN: io-internals USING: alien assembler errors generic hashtables kernel kernel-internals lists math sequences streams strings threads -unix-internals vectors ; +unix-internals unparser vectors ; ! We want namespaces::bind to shadow the bind system call from ! unix-internals @@ -13,8 +13,10 @@ USING: namespaces ; : byte-bit ( n alien -- byte bit ) over -5 shift alien-unsigned-4 swap 31 bitand ; +: bit-length ( n -- n ) cell / ceiling ; + : ( n -- array ) - cell / ceiling ; + bit-length ; : bit-nth ( n alien -- ? ) byte-bit 1 swap shift bitand 0 > ; @@ -26,6 +28,11 @@ USING: namespaces ; [ byte-bit set-bit ] 2keep swap -5 shift set-alien-unsigned-4 ; +: clear-bits ( alien len -- ) + bit-length [ + 0 pick pick set-alien-unsigned-cell + ] repeat drop ; + ! Global variables SYMBOL: read-fdset SYMBOL: read-tasks @@ -73,14 +80,22 @@ M: port set-timeout ( timeout port -- ) : >port< dup port-handle swap delegate ; -: pending-error ( reader -- ) port-error throw ; +: pending-error ( port -- ) + dup port-error f rot set-port-error throw ; -: EAGAIN 35 ; +: EAGAIN 11 ; : EINTR 4 ; -: postpone-error ( port -- ) - err_no dup EAGAIN = over EINTR = or - [ 2drop ] [ strerror swap set-port-error ] ifte ; +: defer-error ( port -- ? ) + #! Return t if it is an unrecoverable error. + err_no dup EAGAIN = over EINTR = or [ + 2drop f + ] [ + [ + "Error on fd " % over port-handle unparse % + ": " % strerror % + ] make-string swap set-port-error t + ] ifte ; ! Associates a port with a list of continuations waiting on the ! port to finish I/O @@ -123,18 +138,16 @@ GENERIC: task-container ( task -- vector ) dup io-task-port timeout? [ 2drop t ] [ - io-task-fd swap 2dup bit-nth - >r f -rot set-bit-nth r> + io-task-fd swap bit-nth ] ifte ; -: debug-out 14 getenv fwrite ; - : handle-fdset ( fdset tasks -- ) [ cdr tuck handle-fd? [ handle-fd ] [ drop ] ifte ] hash-each-with ; : init-fdset ( fdset tasks -- ) + >r dup FD_SETSIZE clear-bits r> [ car t swap rot set-bit-nth ] hash-each-with ; : init-fdsets ( -- read write except ) @@ -218,14 +231,18 @@ C: reader ( handle -- reader ) ] ifte t swap set-reader-ready? ; : (refill) ( port -- n ) - >port< tuck dup buffer-end swap buffer-capacity read ; + >port< dup buffer-end swap buffer-capacity read ; -: refill ( port -- ) +: refill ( port -- ? ) + #! Return f if there is a recoverable error dup buffer-length 0 = [ - (refill) - dup 0 >= [ swap n>buffer ] [ drop postpone-error ] ifte + dup (refill) dup 0 >= [ + swap n>buffer t + ] [ + drop defer-error + ] ifte ] [ - drop + drop t ] ifte ; TUPLE: read-line-task ; @@ -234,10 +251,14 @@ C: read-line-task ( port -- task ) [ >r r> set-delegate ] keep ; M: read-line-task do-io-task ( task -- ? ) - io-task-port dup refill dup eof? [ - reader-eof t + io-task-port dup refill [ + dup eof? [ + reader-eof t + ] [ + read-line-step + ] ifte ] [ - read-line-step + drop f ] ifte ; M: read-line-task task-container drop read-tasks get ; @@ -255,9 +276,13 @@ M: reader stream-readln ( stream -- line ) #! read and the line ends with \r\n, the reader stopped #! reading at \r and set the reader-cr flag to true. But we #! must ignore the \n. - dup buffer-length 1 >= over reader-cr and [ - dup buffer-peek CHAR: \n = [ - 1 swap buffer-consume + dup buffer-length 1 >= [ + dup reader-cr [ + dup buffer-peek CHAR: \n = [ + 1 swap buffer-consume + ] [ + drop + ] ifte ] [ drop ] ifte @@ -296,10 +321,14 @@ C: read-task ( count port -- task ) : >read-task< dup read-task-count swap io-task-port ; M: read-task do-io-task ( task -- ? ) - >read-task< dup refill dup eof? [ - nip reader-eof t + >read-task< dup refill [ + dup eof? [ + nip reader-eof t + ] [ + read-step + ] ifte ] [ - read-step + 2drop f ] ifte ; M: read-task task-container drop read-tasks get ; @@ -323,11 +352,11 @@ TUPLE: writer ; C: writer ( fd -- writer ) [ >r buffered-port r> set-delegate ] keep ; -: write-step ( fd buffer -- ) - tuck dup buffer@ swap buffer-length write dup 0 >= [ +: write-step ( port -- ) + dup >port< dup buffer@ swap buffer-length write dup 0 >= [ swap buffer-consume ] [ - drop postpone-error + drop defer-error drop ] ifte ; : can-write? ( len writer -- ? ) @@ -349,7 +378,7 @@ M: write-task do-io-task io-task-port dup buffer-length 0 = over port-error or [ 0 swap buffer-reset t ] [ - >port< write-step f + write-step f ] ifte ; M: write-task task-container drop write-tasks get ; diff --git a/library/unix/sockets.factor b/library/unix/sockets.factor index 0afa69fdc2..34a10a6090 100644 --- a/library/unix/sockets.factor +++ b/library/unix/sockets.factor @@ -4,8 +4,8 @@ ! We need to fiddle with the exact search order here, since ! unix-internals::accept shadows streams::accept. IN: io-internals -USING: errors namespaces streams threads unparser ; -USING: alien generic kernel math unix-internals ; +USING: errors namespaces streams threads unparser alien generic +kernel math unix-internals ; : init-sockaddr ( port -- sockaddr ) @@ -76,6 +76,14 @@ C: accept-task ( port -- task ) : init-socket ( fd -- ) SOL_SOCKET SO_OOBINLINE sockopt ; +: inet-ntoa ( n -- str ) + ntohl [ + dup -24 shift HEX: ff bitand unparse % CHAR: . , + dup -16 shift HEX: ff bitand unparse % CHAR: . , + dup -8 shift HEX: ff bitand unparse % CHAR: . , + HEX: ff bitand unparse % + ] make-string ; + : do-accept ( port sockaddr fd -- ) [ init-socket @@ -86,21 +94,17 @@ C: accept-task ( port -- task ) M: accept-task do-io-task ( task -- ? ) io-task-port over port-handle over "sockaddr-in" c-size accept - dup 0 >= [ do-accept t ] [ 2drop postpone-error f ] ifte ; + dup 0 >= [ + do-accept t + ] [ + 2drop defer-error + ] ifte ; M: accept-task task-container drop read-tasks get ; : wait-to-accept ( server -- ) [ swap add-io-task stop ] callcc0 drop ; -: inet-ntoa ( n -- str ) - ntohl [ - dup -24 shift HEX: ff bitand unparse % CHAR: . , - dup -16 shift HEX: ff bitand unparse % CHAR: . , - dup -8 shift HEX: ff bitand unparse % CHAR: . , - HEX: ff bitand unparse % - ] make-string ; - : ( fd -- stream ) dup f ; @@ -111,4 +115,4 @@ IN: streams : accept ( server -- client ) #! Wait for a client connection. - dup wait-to-accept server-client ; + dup wait-to-accept dup pending-error server-client ;