diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 0bfac74416..54c97bdb0e 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -199,7 +199,7 @@ M: object run-pipeline-element [ swap in>> or ] change-stdin run-detached ] - [ [ in>> close-handle ] [ out>> close-handle ] bi* ] + [ [ out>> close-handle ] [ in>> close-handle ] bi* ] [ [ in>> ] [ out>> ] bi* ] } 2cleave r> ] with-destructors ; diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor index 167f013d32..1075858346 100755 --- a/extra/io/sockets/sockets.factor +++ b/extra/io/sockets/sockets.factor @@ -195,11 +195,11 @@ GENERIC: (server) ( addrspec -- handle sockaddr ) swap >>addr r> >>encoding ; -HOOK: (accept) io-backend ( server -- handle remote ) +GENERIC: (accept) ( server addrspec -- handle remote ) : accept ( server -- client remote ) check-server-port - [ (accept) ] keep + [ dup addr>> (accept) ] keep tuck [ [ dup ] [ encoding>> ] bi* ] [ addr>> parse-sockaddr ] diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index 537f00bfc9..207fdc3cbc 100644 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -11,7 +11,15 @@ IN: io.unix.backend ! I/O tasks GENERIC: handle-fd ( handle -- fd ) -M: integer handle-fd ; +TUPLE: fd fd closed ; + +: ( n -- fd ) f fd boa ; + +M: fd dispose + dup closed>> + [ drop ] [ t >>closed fd>> close-file ] if ; + +M: fd handle-fd fd>> ; ! I/O multiplexers TUPLE: mx fd reads writes ; @@ -66,21 +74,23 @@ SYMBOL: +retry+ ! just try the operation again without blocking SYMBOL: +input+ SYMBOL: +output+ -: wait-for-port ( port event -- ) +: wait-for-fd ( handle event -- ) dup +retry+ eq? [ 2drop ] [ [ - [ - >r - swap handle>> handle-fd - mx get-global - r> { - { +input+ [ add-input-callback ] } - { +output+ [ add-output-callback ] } - } case - ] curry "I/O" suspend drop - ] curry with-timeout pending-error + >r + swap handle-fd + mx get-global + r> { + { +input+ [ add-input-callback ] } + { +output+ [ add-output-callback ] } + } case + ] curry "I/O" suspend 2drop ] if ; +: wait-for-port ( port event -- ) + [ >r dup handle>> r> wait-for-fd ] curry + with-timeout pending-error ; + ! Some general stuff : file-mode OCT: 0666 ; @@ -93,15 +103,16 @@ SYMBOL: +output+ : io-error ( n -- ) 0 < [ (io-error) ] when ; -M: integer init-handle ( fd -- ) +M: fd init-handle ( fd -- ) #! We drop the error code rather than calling io-error, #! since on OS X 10.3, this operation fails from init-io #! when running the Factor.app (presumably because fd 0 and #! 1 are closed). + fd>> [ F_SETFL O_NONBLOCK fcntl drop ] [ F_SETFD FD_CLOEXEC fcntl drop ] bi ; -M: integer close-handle ( fd -- ) close-file ; +M: fd close-handle ( fd -- ) dispose ; ! Readers : eof ( reader -- ) @@ -116,8 +127,8 @@ M: integer close-handle ( fd -- ) close-file ; ! this request GENERIC: refill ( port handle -- event/f ) -M: integer refill - over buffer>> [ buffer-end ] [ buffer-capacity ] bi read +M: fd refill + fd>> over buffer>> [ buffer-end ] [ buffer-capacity ] bi read { { [ dup 0 = ] [ drop eof f ] } { [ dup 0 > ] [ swap buffer>> n>buffer f ] } @@ -133,8 +144,8 @@ M: unix (wait-to-read) ( port -- ) ! Writers GENERIC: drain ( port handle -- event/f ) -M: integer drain - over buffer>> [ buffer@ ] [ buffer-length ] bi write +M: fd drain + fd>> over buffer>> [ buffer@ ] [ buffer-length ] bi write { { [ dup 0 >= ] [ over buffer>> buffer-consume @@ -153,9 +164,9 @@ M: unix io-multiplex ( ms/f -- ) mx get-global wait-for-events ; M: unix (init-stdio) ( -- ) - 0 - 1 - 2 ; + 0 + 1 + 2 ; ! mx io-task for embedding an fd-based mx inside another mx TUPLE: mx-port < port mx ; diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index 9b0057c166..27dcc01889 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -4,12 +4,12 @@ USING: io.backend io.ports io.unix.backend io.files io unix unix.stat unix.time kernel math continuations math.bitfields byte-arrays alien combinators calendar io.encodings.binary accessors sequences strings system -io.files.private ; +io.files.private destructors ; IN: io.unix.files M: unix cwd ( -- path ) - MAXPATHLEN [ ] [ ] bi getcwd + MAXPATHLEN [ ] keep getcwd [ (io-error) ] unless* ; M: unix cd ( path -- ) [ chdir ] unix-system-call drop ; @@ -19,23 +19,26 @@ M: unix cd ( path -- ) [ chdir ] unix-system-call drop ; : open-read ( path -- fd ) O_RDONLY file-mode open-file ; M: unix (file-reader) ( path -- stream ) - open-read ; + open-read ; : write-flags { O_WRONLY O_CREAT O_TRUNC } flags ; inline -: open-write ( path -- fd ) write-flags file-mode open-file ; +: open-write ( path -- fd ) + write-flags file-mode open-file ; M: unix (file-writer) ( path -- stream ) - open-write ; + open-write ; : append-flags { O_WRONLY O_APPEND O_CREAT } flags ; inline : open-append ( path -- fd ) - append-flags file-mode open-file - [ dup 0 SEEK_END lseek io-error ] [ ] [ close-file ] cleanup ; + [ + append-flags file-mode open-file dup close-later + dup 0 SEEK_END lseek io-error + ] with-destructors ; M: unix (file-appender) ( path -- stream ) - open-append ; + open-append ; : touch-mode ( -- n ) { O_WRONLY O_APPEND O_CREAT O_EXCL } flags ; foldable diff --git a/extra/io/unix/launcher/launcher-tests.factor b/extra/io/unix/launcher/launcher-tests.factor index 177c5775dc..49bfc34164 100755 --- a/extra/io/unix/launcher/launcher-tests.factor +++ b/extra/io/unix/launcher/launcher-tests.factor @@ -110,3 +110,5 @@ accessors kernel sequences io.encodings.utf8 ; ] times "append-test" temp-file utf8 file-contents ] unit-test + +[ ] [ "ls" utf8 contents drop ] unit-test diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 405f26d4bc..3b9c8fc7af 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -58,7 +58,7 @@ USE: unix { [ pick string? ] [ redirect-file ] } { [ pick appender? ] [ redirect-file-append ] } { [ pick +closed+ eq? ] [ redirect-closed ] } - { [ pick integer? ] [ >r drop dup reset-fd r> redirect-fd ] } + { [ pick fd? ] [ >r drop fd>> dup reset-fd r> redirect-fd ] } [ >r >r underlying-handle r> r> redirect ] } cond ; diff --git a/extra/io/unix/pipes/pipes.factor b/extra/io/unix/pipes/pipes.factor index dd7ed4a94a..db2c917520 100644 --- a/extra/io/unix/pipes/pipes.factor +++ b/extra/io/unix/pipes/pipes.factor @@ -8,5 +8,5 @@ QUALIFIED: io.pipes M: unix io.pipes:(pipe) ( -- pair ) 2 "int" dup pipe io-error - 2 c-int-array> first2 + 2 c-int-array> first2 [ ] bi@ [ [ init-handle ] bi@ ] [ io.pipes:pipe boa ] 2bi ; diff --git a/extra/io/unix/sockets/secure/secure.factor b/extra/io/unix/sockets/secure/secure.factor index 7e4e8955ae..14cd9fdb6f 100644 --- a/extra/io/unix/sockets/secure/secure.factor +++ b/extra/io/unix/sockets/secure/secure.factor @@ -6,17 +6,16 @@ continuations destructors openssl openssl.libcrypto openssl.libssl io.files io.ports io.unix.backend io.unix.sockets io.encodings.ascii io.buffers io.sockets io.sockets.secure -unix ; +unix system ; IN: io.unix.sockets.secure ! todo: SSL_pending, rehandshake -! do we call write twice, wth 0 bytes at the end? ! check-certificate at some point ! test on windows -M: ssl-handle handle-fd file>> ; +M: ssl-handle handle-fd file>> handle-fd ; -: syscall-error ( port r -- * ) +: syscall-error ( r -- * ) ERR_get_error dup zero? [ drop { @@ -70,10 +69,14 @@ M: ssl-handle drain check-write-response ; ! Client sockets -M: ssl ((client)) ( addrspec -- handle ) - [ addrspec>> ((client)) ] with-destructors ; +: ( fd -- ssl ) + [ fd>> BIO_NOCLOSE BIO_new_socket dup ssl-error ] keep + [ handle>> swap dup SSL_set_bio ] keep ; -M: ssl parse-sockaddr addrspec>> parse-sockaddr ; +M: ssl ((client)) ( addrspec -- handle ) + addrspec>> ((client)) ; + +M: ssl parse-sockaddr addrspec>> parse-sockaddr ; : check-connect-response ( port r -- event ) check-response @@ -85,13 +88,54 @@ M: ssl parse-sockaddr addrspec>> parse-sockaddr ; { SSL_ERROR_SSL [ (ssl-error) ] } } case ; -: do-ssl-connect ( port ssl addrspec -- ) - drop +: do-ssl-connect ( port ssl-handle -- ) 2dup SSL_connect check-connect-response dup - [ nip wait-for-port ] [ 3drop ] if ; + [ >r over r> wait-for-port do-ssl-connect ] [ 3drop ] if ; M: ssl-handle (wait-to-connect) addrspec>> [ >r file>> r> (wait-to-connect) ] - [ >r handle>> r> do-ssl-connect ] - 3bi ; + [ drop handle>> do-ssl-connect ] + [ drop t >>connected 2drop ] + 3tri ; + +M: ssl (server) addrspec>> (server) ; + +: check-accept-response ( handle r -- event ) + over handle>> over SSL_get_error + { + { SSL_ERROR_NONE [ 2drop f ] } + { SSL_ERROR_WANT_READ [ 2drop +input+ ] } + { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] } + { SSL_ERROR_SYSCALL [ syscall-error ] } + { SSL_ERROR_SSL [ (ssl-error) ] } + } case ; + +: do-ssl-accept ( ssl-handle -- ) + dup dup handle>> SSL_accept check-accept-response dup + [ >r dup file>> r> wait-for-fd do-ssl-accept ] [ 2drop ] if ; + +M: ssl (accept) + [ + addrspec>> + (accept) >r + dup close-later + dup close-later + dup do-ssl-accept + r> + ] with-destructors ; + +: check-shutdown-response ( handle r -- event ) + >r handle>> r> SSL_get_error + { + { SSL_ERROR_WANT_READ [ +input+ ] } + { SSL_ERROR_WANT_WRITE [ +output+ ] } + { SSL_ERROR_SYSCALL [ -1 syscall-error ] } + { SSL_ERROR_SSL [ (ssl-error) ] } + } case ; + +M: unix ssl-shutdown + dup connected>> [ + dup dup handle>> SSL_shutdown check-shutdown-response + dup [ dupd wait-for-fd ssl-shutdown ] [ 2drop ] if + ] [ drop ] if ; diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index a04d008a21..127f50d1aa 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -12,69 +12,68 @@ EXCLUDE: io.sockets => accept ; IN: io.unix.sockets -: socket-fd ( domain type -- socket ) - 0 socket - dup io-error - dup close-later - dup init-handle ; +: socket-fd ( domain type -- fd ) + 0 socket dup io-error [ close-later ] [ init-handle ] [ ] tri ; -: sockopt ( fd level opt -- ) - 1 "int" heap-size setsockopt io-error ; +: set-socket-option ( fd level opt -- ) + >r >r handle-fd r> r> 1 "int" heap-size setsockopt io-error ; M: unix addrinfo-error ( n -- ) dup zero? [ drop ] [ gai_strerror throw ] if ; ! Client sockets - TCP and Unix domain : init-client-socket ( fd -- ) - SOL_SOCKET SO_OOBINLINE sockopt ; + SOL_SOCKET SO_OOBINLINE set-socket-option ; : get-socket-name ( fd addrspec -- sockaddr ) - empty-sockaddr/size [ getsockname io-error ] 2keep drop ; + >r handle-fd r> empty-sockaddr/size + [ getsockname io-error ] 2keep drop ; : get-peer-name ( fd addrspec -- sockaddr ) - empty-sockaddr/size [ getpeername io-error ] 2keep drop ; + >r handle-fd r> empty-sockaddr/size + [ getpeername io-error ] 2keep drop ; -M: integer (wait-to-connect) +M: fd (wait-to-connect) >r >r +output+ wait-for-port r> r> get-socket-name ; M: object ((client)) ( addrspec -- fd ) [ protocol-family SOCK_STREAM socket-fd ] [ make-sockaddr/size ] bi - [ 2drop ] [ connect ] 3bi - zero? err_no EINPROGRESS = or + >r >r dup handle-fd r> r> connect zero? err_no EINPROGRESS = or [ dup init-client-socket ] [ (io-error) ] if ; ! Server sockets - TCP and Unix domain : init-server-socket ( fd -- ) - SOL_SOCKET SO_REUSEADDR sockopt ; + SOL_SOCKET SO_REUSEADDR set-socket-option ; : server-socket-fd ( addrspec type -- fd ) >r dup protocol-family r> socket-fd dup init-server-socket - dup rot make-sockaddr/size bind io-error ; + dup handle-fd rot make-sockaddr/size bind io-error ; M: object (server) ( addrspec -- handle sockaddr ) [ [ SOCK_STREAM server-socket-fd - dup 10 listen io-error + dup handle-fd 10 listen io-error dup ] keep get-socket-name ] with-destructors ; -: do-accept ( server -- fd remote ) - [ handle>> ] [ addr>> empty-sockaddr/size ] bi +: do-accept ( server addrspec -- fd remote ) + [ handle>> handle-fd ] [ empty-sockaddr/size ] bi* [ accept ] 2keep drop ; inline -M: unix (accept) ( server -- fd remote ) - dup do-accept +M: object (accept) ( server addrspec -- fd remote ) + 2dup do-accept { - { [ over 0 >= ] [ rot drop ] } + { [ over 0 >= ] [ { [ drop ] [ drop ] [ ] [ ] } spread ] } { [ err_no EINTR = ] [ 2drop (accept) ] } { [ err_no EAGAIN = ] [ 2drop - [ +input+ wait-for-port ] - [ (accept) ] bi + [ drop +input+ wait-for-port ] + [ (accept) ] + 2bi ] } [ (io-error) ] } cond ; @@ -91,7 +90,7 @@ packet-size receive-buffer set-global :: do-receive ( port -- packet sockaddr ) port addr>> empty-sockaddr/size [| sockaddr len | - port handle>> ! s + port handle>> handle-fd ! s receive-buffer get-global ! buf packet-size ! nbytes 0 ! flags @@ -110,7 +109,7 @@ M: unix (receive) ( datagram -- packet sockaddr ) ] if ; :: do-send ( packet sockaddr len socket datagram -- ) - socket packet dup length 0 sockaddr len sendto + socket handle-fd packet dup length 0 sockaddr len sendto 0 < [ err_no EINTR = [ packet sockaddr len socket datagram do-send diff --git a/extra/openssl/libssl/libssl.factor b/extra/openssl/libssl/libssl.factor index d1c53c4b23..5330a815a3 100755 --- a/extra/openssl/libssl/libssl.factor +++ b/extra/openssl/libssl/libssl.factor @@ -118,7 +118,7 @@ FUNCTION: int SSL_write ( ssl-pointer ssl, void* buf, int num ) ; FUNCTION: int SSL_read ( ssl-pointer ssl, void* buf, int num ) ; -FUNCTION: void SSL_shutdown ( ssl-pointer ssl ) ; +FUNCTION: int SSL_shutdown ( ssl-pointer ssl ) ; FUNCTION: void SSL_free ( ssl-pointer ssl ) ; diff --git a/extra/openssl/openssl.factor b/extra/openssl/openssl.factor index 41e413c966..6eb2d0dbda 100755 --- a/extra/openssl/openssl.factor +++ b/extra/openssl/openssl.factor @@ -5,7 +5,7 @@ math.order combinators init alien alien.c-types alien.strings libc continuations destructors debugger inspector locals unicode.case openssl.libcrypto openssl.libssl -io.ports io.files io.encodings.ascii io.sockets.secure ; +io.backend io.ports io.files io.encodings.ascii io.sockets.secure ; IN: openssl ! This code is based on http://www.rtfm.com/openssl-examples/ @@ -120,7 +120,7 @@ M: openssl-context dispose dup handle>> [ SSL_CTX_free ] when* f >>handle drop ; -TUPLE: ssl-handle file handle disposed ; +TUPLE: ssl-handle file handle connected disposed ; ERROR: no-ssl-context ; @@ -132,20 +132,19 @@ M: no-ssl-context summary : ( fd -- ssl ) current-ssl-context handle>> SSL_new dup ssl-error - f ssl-handle boa ; + f f ssl-handle boa ; -: ( fd -- ssl ) - [ BIO_NOCLOSE BIO_new_socket dup ssl-error ] keep - - [ handle>> swap dup SSL_set_bio ] keep ; +M: ssl-handle init-handle file>> init-handle ; -M: ssl-handle init-handle drop ; +HOOK: ssl-shutdown io-backend ( handle -- ) M: ssl-handle close-handle dup disposed>> [ drop ] [ - [ t >>disposed drop ] + t >>disposed + [ ssl-shutdown ] + [ handle>> SSL_free ] [ file>> close-handle ] - [ handle>> SSL_free ] tri + tri ] if ; ERROR: certificate-verify-error result ;