From 1260c1ba51c0af13953017f046537f03a96efa79 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 12 May 2008 18:53:22 -0500 Subject: [PATCH] Working on SSL and refactoring related code to make things easier to plug in --- core/alien/c-types/c-types.factor | 2 + core/continuations/continuations.factor | 12 ++- core/debugger/debugger.factor | 2 + extra/db/postgresql/ffi/ffi.factor | 1 - extra/destructors/destructors.factor | 48 +++++----- extra/io/launcher/launcher.factor | 6 +- extra/io/nonblocking/nonblocking-docs.factor | 8 +- extra/io/nonblocking/nonblocking.factor | 14 +-- extra/io/pipes/pipes.factor | 8 +- extra/io/sockets/secure/secure.factor | 16 +++- extra/io/sockets/sockets.factor | 28 ++++-- extra/io/unix/backend/backend.factor | 45 ++++++---- extra/io/unix/epoll/epoll.factor | 4 +- extra/io/unix/files/files.factor | 6 +- extra/io/unix/kqueue/kqueue.factor | 4 +- extra/io/unix/select/select.factor | 12 +-- extra/io/unix/sockets/secure/secure.factor | 95 ++++++++++++++++++++ extra/io/unix/sockets/sockets.factor | 59 ++++++------ extra/io/unix/unix.factor | 15 +++- extra/io/windows/ce/backend/backend.factor | 2 +- extra/io/windows/ce/sockets/sockets.factor | 4 +- extra/io/windows/nt/sockets/sockets.factor | 19 ++-- extra/io/windows/windows.factor | 14 +-- extra/openssl/openssl.factor | 24 +++-- extra/openssl/unix/unix.factor | 11 --- extra/oracle/liboci/liboci.factor | 1 - extra/unix/unix.factor | 1 - extra/windows/types/types.factor | 1 - 28 files changed, 301 insertions(+), 161 deletions(-) create mode 100644 extra/io/unix/sockets/secure/secure.factor delete mode 100644 extra/openssl/unix/unix.factor diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index f67fc78259..44c0112c77 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -382,4 +382,6 @@ M: long-long-type box-return ( type -- ) "double" define-primitive-type os winnt? cpu x86.64? and "longlong" "long" ? "ptrdiff_t" typedef + + "ulong" "size_t" typedef ] with-compilation-unit diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index 78effb043a..8b6cd1ce3a 100755 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -139,10 +139,16 @@ SYMBOL: thread-error-hook over >r compose [ dip rethrow ] curry recover r> call ; inline +ERROR: attempt-all-error ; + : attempt-all ( seq quot -- obj ) - [ - [ [ , f ] compose [ , drop t ] recover ] curry all? - ] { } make peek swap [ rethrow ] when ; inline + over empty? [ + attempt-all-error + ] [ + [ + [ [ , f ] compose [ , drop t ] recover ] curry all? + ] { } make peek swap [ rethrow ] when + ] if ; inline GENERIC: dispose ( object -- ) diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index df7d33f41c..ad74889236 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -298,6 +298,8 @@ M: immutable-slot summary drop "Slot is immutable" ; M: bad-create summary drop "Bad parameters to create" ; +M: attempt-all-error summary drop "Nothing to attempt" ; + ( obj -- newobj ) - f destructor boa ; - : add-error-destructor ( obj -- ) - error-destructors get push ; + error-destructors get push ; : add-always-destructor ( obj -- ) - always-destructors get push ; + always-destructors get push ; : do-always-destructors ( -- ) always-destructors get dispose-each ; @@ -40,19 +27,28 @@ M: destructor dispose [ do-error-destructors ] cleanup ] with-scope ; inline +TUPLE: only-once object destroyed ; + +M: only-once dispose + dup destroyed>> [ drop ] [ + [ object>> dispose ] [ t >>destroyed drop ] bi + ] if ; + +: f only-once boa ; + ! Memory allocations TUPLE: memory-destructor alien ; C: memory-destructor M: memory-destructor dispose ( obj -- ) - memory-destructor-alien free ; + alien>> free ; : free-always ( alien -- ) - add-always-destructor ; + add-always-destructor ; : free-later ( alien -- ) - add-error-destructor ; + add-error-destructor ; ! Handles TUPLE: handle-destructor alien ; @@ -60,13 +56,13 @@ TUPLE: handle-destructor alien ; C: handle-destructor M: handle-destructor dispose ( obj -- ) - handle-destructor-alien close-handle ; + alien>> close-handle ; : close-always ( handle -- ) - add-always-destructor ; + add-always-destructor ; : close-later ( handle -- ) - add-error-destructor ; + add-error-destructor ; ! Sockets TUPLE: socket-destructor alien ; @@ -76,10 +72,10 @@ C: socket-destructor HOOK: destruct-socket io-backend ( obj -- ) M: socket-destructor dispose ( obj -- ) - socket-destructor-alien destruct-socket ; + alien>> destruct-socket ; : close-socket-always ( handle -- ) - add-always-destructor ; + add-always-destructor ; : close-socket-later ( handle -- ) - add-error-destructor ; + add-error-destructor ; diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index e8eb973e34..e28742537d 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -165,7 +165,7 @@ M: object run-pipeline-element run-detached ] [ out>> close-handle ] - [ in>> ] + [ in>> ] } cleave r> ] with-destructors ; @@ -182,7 +182,7 @@ M: object run-pipeline-element run-detached ] [ in>> close-handle ] - [ out>> ] + [ out>> ] } cleave r> ] with-destructors ; @@ -200,7 +200,7 @@ M: object run-pipeline-element run-detached ] [ [ in>> close-handle ] [ out>> close-handle ] bi* ] - [ [ in>> ] [ out>> ] bi* ] + [ [ in>> ] [ out>> ] bi* ] } 2cleave r> ] with-destructors ; diff --git a/extra/io/nonblocking/nonblocking-docs.factor b/extra/io/nonblocking/nonblocking-docs.factor index bd2be34c9d..7a489d8606 100755 --- a/extra/io/nonblocking/nonblocking-docs.factor +++ b/extra/io/nonblocking/nonblocking-docs.factor @@ -11,10 +11,10 @@ $nl { $subsection } "Input ports:" { $subsection input-port } -{ $subsection } +{ $subsection } "Output ports:" { $subsection output-port } -{ $subsection } +{ $subsection } "Global native I/O protocol:" { $subsection io-backend } { $subsection init-io } @@ -62,12 +62,12 @@ HELP: { $description "Creates a new " { $link port } " using the specified native handle and a default-sized I/O buffer." } $low-level-note ; -HELP: +HELP: { $values { "handle" "a native handle identifying an I/O resource" } { "input-port" "a new " { $link input-port } } } { $description "Creates a new " { $link input-port } " using the specified native handle and a default-sized input buffer." } $low-level-note ; -HELP: +HELP: { $values { "handle" "a native handle identifying an I/O resource" } { "output-port" "a new " { $link output-port } } } { $description "Creates a new " { $link output-port } " using the specified native handle and a default-sized input buffer." } $low-level-note ; diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor index 40605347b1..b78cfecbaf 100755 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/nonblocking/nonblocking.factor @@ -3,7 +3,8 @@ USING: math kernel io sequences io.buffers io.timeouts generic byte-vectors system io.encodings math.order io.backend continuations debugger classes byte-arrays namespaces splitting -dlists assocs io.encodings.binary inspector accessors ; +dlists assocs io.encodings.binary inspector accessors +destructors ; IN: io.nonblocking SYMBOL: default-buffer-size @@ -29,16 +30,19 @@ GENERIC: close-handle ( handle -- ) TUPLE: input-port < port ; -: ( handle -- input-port ) +: ( handle -- input-port ) input-port ; TUPLE: output-port < port ; -: ( handle -- output-port ) +: ( handle -- output-port ) output-port ; -: ( read-handle write-handle -- input-port output-port ) - swap [ swap ] [ ] [ dispose drop ] cleanup ; +: ( read-handle write-handle -- input-port output-port ) + [ + [ dup add-error-destructor ] + [ dup add-error-destructor ] bi* + ] with-destructors ; : pending-error ( port -- ) [ f ] change-error drop [ throw ] when* ; diff --git a/extra/io/pipes/pipes.factor b/extra/io/pipes/pipes.factor index 72d27372f3..cae7ef8158 100644 --- a/extra/io/pipes/pipes.factor +++ b/extra/io/pipes/pipes.factor @@ -17,16 +17,16 @@ HOOK: (pipe) io-backend ( -- pipe ) [ >r (pipe) [ add-error-destructor ] - [ in>> ] - [ out>> ] + [ in>> ] + [ out>> ] tri r> ] with-destructors ; dup add-always-destructor ] [ input-stream get ] if* ; -: ?writer [ dup add-always-destructor ] [ output-stream get ] if* ; +: ?reader [ dup add-always-destructor ] [ input-stream get ] if* ; +: ?writer [ dup add-always-destructor ] [ output-stream get ] if* ; GENERIC: run-pipeline-element ( input-fd output-fd obj -- quot ) diff --git a/extra/io/sockets/secure/secure.factor b/extra/io/sockets/secure/secure.factor index f7729233ac..6cd711da81 100644 --- a/extra/io/sockets/secure/secure.factor +++ b/extra/io/sockets/secure/secure.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel symbols namespaces continuations ; +USING: accessors kernel symbols namespaces continuations +io.sockets sequences ; IN: io.sockets.secure SYMBOL: ssl-backend @@ -22,3 +23,16 @@ HOOK: ssl-backend ( config -- context ) [ ] [ [ ssl-context set ] prepose ] bi* with-disposal ] with-scope ; inline + +TUPLE: ssl addrspec ; + +C: ssl + +> inet? ; + +M: ssl-inet (client) + addrspec>> resolve-client-addr [ ] map (client) ; + +PRIVATE> diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor index f835f0beb2..7b0f55cab7 100755 --- a/extra/io/sockets/sockets.factor +++ b/extra/io/sockets/sockets.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: generic kernel io.backend namespaces continuations sequences arrays io.encodings io.nonblocking io.streams.duplex -accessors ; +accessors destructors ; IN: io.sockets TUPLE: local path ; @@ -22,11 +22,21 @@ TUPLE: inet host port ; C: inet -HOOK: ((client)) io-backend ( addrspec -- client-in client-out ) +GENERIC: wait-to-connect ( client-out handle -- ) + +GENERIC: ((client)) ( addrspec -- handle ) GENERIC: (client) ( addrspec -- client-in client-out ) -M: array (client) [ ((client)) 2array ] attempt-all first2 ; -M: object (client) ((client)) ; + +M: array (client) [ (client) 2array ] attempt-all first2 ; + +M: object (client) + [ + ((client)) + dup + 2dup [ add-error-destructor ] bi@ + dup dup handle>> wait-to-connect + ] with-destructors ; : ( addrspec encoding -- stream ) >r (client) r> ; @@ -42,7 +52,7 @@ HOOK: (server) io-backend ( addrspec -- handle ) HOOK: (accept) io-backend ( server -- addrspec handle ) : accept ( server -- client addrspec ) - [ (accept) dup ] [ encoding>> ] bi + [ (accept) dup ] [ encoding>> ] bi swap ; HOOK: io-backend ( addrspec -- datagram ) @@ -55,8 +65,8 @@ HOOK: resolve-host io-backend ( host serv passive? -- seq ) HOOK: host-name io-backend ( -- string ) +: resolve-client-addr ( inet -- seq ) + [ host>> ] [ port>> ] bi f resolve-host ; + M: inet (client) - [ host>> ] [ port>> ] bi f resolve-host - [ empty? [ "Host name lookup failed" throw ] when ] - [ (client) ] - bi ; + resolve-client-addr (client) ; diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index 6e738dc3e8..d4e293b332 100644 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -11,7 +11,11 @@ IN: io.unix.backend ! I/O tasks TUPLE: io-task port callbacks ; -: io-task-fd port>> handle>> ; +GENERIC: handle-fd ( handle -- fd ) + +M: integer handle-fd ; + +: io-task-fd port>> handle>> handle-fd ; : ( port continuation/f class -- task ) new @@ -84,9 +88,10 @@ M: integer init-handle ( fd -- ) M: integer close-handle ( fd -- ) close ; +TUPLE: unix-io-error error port ; + : report-error ( error port -- ) - [ "Error on fd " % dup handle>> # ": " % swap % ] "" make - >>error drop ; + tuck unix-io-error boa >>error drop ; : ignorable-error? ( n -- ? ) [ EAGAIN number= ] [ EINTR number= ] bi or ; @@ -100,7 +105,7 @@ M: integer close-handle ( fd -- ) dup rot unregister-io-task io-task-callbacks [ resume ] each ; -: handle-io-task ( mx task -- ) +: perform-io-task ( mx task -- ) dup do-io-task [ pop-callbacks ] [ 2drop ] if ; : handle-timeout ( port mx assoc -- ) @@ -127,25 +132,25 @@ M: unix cancel-io ( port -- ) [ buffer>> buffer-end ] [ buffer>> buffer-capacity ] tri read ; -: refill ( port -- ? ) +GENERIC: refill ( port handle -- ? ) + +M: integer refill #! Return f if there is a recoverable error + drop dup buffer>> buffer-empty? [ - dup (refill) dup 0 >= [ + dup (refill) dup 0 >= [ swap buffer>> n>buffer t ] [ drop defer-error ] if - ] [ - drop t - ] if ; + ] [ drop t ] if ; TUPLE: read-task < input-task ; -: ( port continuation -- task ) - read-task ; +: ( port continuation -- task ) read-task ; M: read-task do-io-task - io-task-port dup refill + port>> dup dup handle>> refill [ [ reader-eof ] [ drop ] if ] keep ; M: unix (wait-to-read) @@ -153,7 +158,10 @@ M: unix (wait-to-read) pending-error ; ! Writers -: write-step ( port -- ? ) +GENERIC: drain ( port handle -- ? ) + +M: integer drain + drop dup [ handle>> ] [ buffer>> buffer@ ] @@ -164,12 +172,11 @@ M: unix (wait-to-read) TUPLE: write-task < output-task ; -: ( port continuation -- task ) - write-task ; +: ( port continuation -- task ) write-task ; M: write-task do-io-task io-task-port dup [ buffer>> buffer-empty? ] [ port-error ] bi or - [ 0 swap buffer>> buffer-reset t ] [ write-step ] if ; + [ 0 swap buffer>> buffer-reset t ] [ dup handle>> drain ] if ; : add-write-io-task ( port continuation -- ) over handle>> mx get-global writes>> at* @@ -186,9 +193,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/epoll/epoll.factor b/extra/io/unix/epoll/epoll.factor index db1e7086e0..f34a4c7009 100644 --- a/extra/io/unix/epoll/epoll.factor +++ b/extra/io/unix/epoll/epoll.factor @@ -43,10 +43,10 @@ M: epoll-mx unregister-io-task ( task mx -- ) r> epoll_wait dup multiplexer-error ; : epoll-read-task ( mx fd -- ) - over mx-reads at* [ handle-io-task ] [ 2drop ] if ; + over mx-reads at* [ perform-io-task ] [ 2drop ] if ; : epoll-write-task ( mx fd -- ) - over mx-writes at* [ handle-io-task ] [ 2drop ] if ; + over mx-writes at* [ perform-io-task ] [ 2drop ] if ; : handle-event ( mx kevent -- ) epoll-event-fd 2dup epoll-read-task epoll-write-task ; diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index 28e08d4bf2..1259f658d1 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -21,7 +21,7 @@ M: unix cd ( path -- ) O_RDONLY file-mode open dup io-error ; M: unix (file-reader) ( path -- stream ) - open-read ; + open-read ; : write-flags { O_WRONLY O_CREAT O_TRUNC } flags ; inline @@ -29,7 +29,7 @@ M: unix (file-reader) ( path -- stream ) write-flags file-mode open dup io-error ; M: unix (file-writer) ( path -- stream ) - open-write ; + open-write ; : append-flags { O_WRONLY O_APPEND O_CREAT } flags ; inline @@ -38,7 +38,7 @@ M: unix (file-writer) ( path -- stream ) [ dup 0 SEEK_END lseek io-error ] [ ] [ close ] cleanup ; 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/kqueue/kqueue.factor b/extra/io/unix/kqueue/kqueue.factor index ec82a426d3..d329853881 100755 --- a/extra/io/unix/kqueue/kqueue.factor +++ b/extra/io/unix/kqueue/kqueue.factor @@ -57,10 +57,10 @@ M: kqueue-mx unregister-io-task ( task mx -- ) dup multiplexer-error ; :: kevent-read-task ( mx fd kevent -- ) - mx fd mx reads>> at handle-io-task ; + mx fd mx reads>> at perform-io-task ; :: kevent-write-task ( mx fd kevent -- ) - mx fd mx writes>> at handle-io-task ; + mx fd mx writes>> at perform-io-task ; :: kevent-proc-task ( mx pid kevent -- ) pid wait-for-pid diff --git a/extra/io/unix/select/select.factor b/extra/io/unix/select/select.factor index 74b7136823..58b8371d89 100755 --- a/extra/io/unix/select/select.factor +++ b/extra/io/unix/select/select.factor @@ -21,12 +21,12 @@ TUPLE: select-mx < mx read-fdset write-fdset ; : clear-nth ( n seq -- ? ) [ nth ] [ f -rot set-nth ] 2bi ; -: handle-fd ( fd task fdset mx -- ) +: check-fd ( fd task fdset mx -- ) roll munge rot clear-nth - [ swap handle-io-task ] [ 2drop ] if ; + [ swap perform-io-task ] [ 2drop ] if ; -: handle-fdset ( tasks fdset mx -- ) - [ handle-fd ] 2curry assoc-each ; +: check-fdset ( tasks fdset mx -- ) + [ check-fd ] 2curry assoc-each ; : init-fdset ( tasks fdset -- ) [ >r drop t swap munge r> set-nth ] curry assoc-each ; @@ -52,5 +52,5 @@ TUPLE: select-mx < mx read-fdset write-fdset ; M: select-mx wait-for-events ( ms mx -- ) swap >r dup init-fdsets r> dup [ make-timeval ] when select multiplexer-error - dup read-fdset/tasks pick handle-fdset - dup write-fdset/tasks rot handle-fdset ; + dup read-fdset/tasks pick check-fdset + dup write-fdset/tasks rot check-fdset ; diff --git a/extra/io/unix/sockets/secure/secure.factor b/extra/io/unix/sockets/secure/secure.factor new file mode 100644 index 0000000000..86abaf2e65 --- /dev/null +++ b/extra/io/unix/sockets/secure/secure.factor @@ -0,0 +1,95 @@ +! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors byte-arrays kernel debugger sequences namespaces math +math.order combinators init alien alien.c-types alien.strings libc +continuations destructors +openssl openssl.libcrypto openssl.libssl +io.files io.nonblocking io.unix.backend io.unix.sockets +io.encodings.ascii io.buffers io.sockets io.sockets.secure +unix.ffi ; +IN: io.unix.sockets.secure + +! todo: SSL_pending, rehandshake +! do we call write twice, wth 0 bytes at the end? + +M: ssl handle-fd file>> ; + +: syscall-error ( port r -- ) + ERR_get_error dup zero? [ + drop + { + { -1 [ err_no strerror ] } + { 0 [ "Premature EOF" ] } + } case + ] [ + nip (ssl-error-string) + ] if swap report-error ; + +: check-response ( port r -- port r n ) + over handle>> handle>> over SSL_get_error ; inline + +! Input ports +: report-ssl-error ( port r -- ) + drop ssl-error-string swap report-error ; + +: check-read-response ( port r -- ? ) + check-response + { + { SSL_ERROR_NONE [ swap buffer>> n>buffer t ] } + { SSL_ERROR_ZERO_RETURN [ drop reader-eof t ] } + { SSL_ERROR_WANT_READ [ 2drop f ] } + { SSL_ERROR_WANT_WRITE [ 2drop f ] } ! XXX + { SSL_ERROR_SYSCALL [ syscall-error t ] } + { SSL_ERROR_SSL [ report-ssl-error t ] } + } case ; + +M: ssl-handle refill + drop + dup buffer>> buffer-empty? [ + dup + [ handle>> handle>> ] ! ssl + [ buffer>> buffer-end ] ! buf + [ buffer>> buffer-capacity ] tri ! len + SSL_read + check-read-response + ] [ drop t ] if ; + +! Output ports +: check-write-response ( port r -- ? ) + check-response + { + { SSL_ERROR_NONE [ swap buffer>> buffer-consume f ] } + ! { SSL_ERROR_ZERO_RETURN [ drop reader-eof ] } ! XXX + { SSL_ERROR_WANT_READ [ 2drop f ] } ! XXX + { SSL_ERROR_WANT_WRITE [ 2drop f ] } + { SSL_ERROR_SYSCALL [ syscall-error t ] } + { SSL_ERROR_SSL [ report-ssl-error t ] } + } case ; + +M: ssl-handle drain + drop + dup + [ handle>> handle>> ] ! ssl + [ buffer>> buffer@ ] ! buf + [ buffer>> buffer-length ] tri ! len + SSL_write + check-write-response ; + +! Client sockets +M: ssl ((client)) ( addrspec -- handle ) + [ addrspec>> ((client)) ] with-destructors ; + +: check-connect-response ( port r -- ? ) + check-response + { + { SSL_ERROR_NONE [ 2drop t ] } + { SSL_ERROR_WANT_READ [ 2drop f ] } ! XXX + { SSL_ERROR_WANT_WRITE [ 2drop f ] } ! XXX + { SSL_ERROR_SYSCALL [ syscall-error t ] } + { SSL_ERROR_SSL [ report-ssl-error t ] } + } case ; + +M: ssl-handle (wait-to-connect) + handle>> handle>> ! ssl + SSL_connect + check-connect-response ; diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index 71edbc5500..187c65fac7 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -5,22 +5,18 @@ namespaces threads sequences byte-arrays io.nonblocking io.binary io.unix.backend io.streams.duplex io.sockets.impl io.backend io.files io.files.private io.encodings.utf8 math.parser continuations libc combinators system accessors -qualified unix.ffi unix ; +destructors qualified unix.ffi unix ; EXCLUDE: io => read write close ; EXCLUDE: io.sockets => accept ; IN: io.unix.sockets -: pending-init-error ( port -- ) - #! We close it here to avoid a resource leak; callers of - #! don't set up error handlers until after - #! returns (and if they did before, they wouldn't have - #! anything to close!) - dup port-error dup [ swap dispose throw ] [ 2drop ] if ; - : socket-fd ( domain type -- socket ) - 0 socket dup io-error dup init-handle ; + 0 socket + dup io-error + dup close-later + dup init-handle ; : sockopt ( fd level opt -- ) 1 "int" heap-size setsockopt io-error ; @@ -37,25 +33,24 @@ TUPLE: connect-task < output-task ; : ( port continuation -- task ) connect-task ; +GENERIC: (wait-to-connect) ( port handle -- ? ) + +M: integer (wait-to-connect) + f 0 write 0 < [ defer-error ] [ drop t ] if ; + M: connect-task do-io-task - port>> dup handle>> f 0 write - 0 < [ defer-error ] [ drop t ] if ; + port>> dup handle>> (wait-to-connect) ; -: wait-to-connect ( port -- ) - [ add-io-task ] with-port-continuation drop ; +M: integer wait-to-connect ( client-out fd -- ) + drop + [ add-io-task ] with-port-continuation + pending-error ; -M: unix ((client)) ( addrspec -- client-in client-out ) - dup make-sockaddr/size >r >r - protocol-family SOCK_STREAM socket-fd - dup r> r> connect - zero? err_no EINPROGRESS = or [ - dup init-client-socket - dup - dup wait-to-connect - dup pending-init-error - ] [ - dup close (io-error) - ] if ; +M: object ((client)) ( addrspec -- fd ) + [ protocol-family SOCK_STREAM socket-fd ] [ make-sockaddr/size ] bi + [ 2drop ] [ connect ] 3bi + zero? err_no EINPROGRESS = or + [ dup init-client-socket ] [ (io-error) ] if ; ! Server sockets - TCP and Unix domain : init-server-socket ( fd -- ) @@ -83,15 +78,17 @@ M: accept-task do-io-task : wait-to-accept ( server -- ) [ add-io-task ] with-port-continuation drop ; -: server-fd ( addrspec type -- fd ) - >r dup protocol-family r> socket-fd +: server-socket-fd ( addrspec type -- fd ) + >r dup protocol-family r> socket-fd dup init-server-socket dup rot make-sockaddr/size bind zero? [ dup close (io-error) ] unless ; M: unix (server) ( addrspec -- handle ) - SOCK_STREAM server-fd - dup 10 listen zero? [ dup close (io-error) ] unless ; + [ + SOCK_STREAM server-socket-fd + dup 10 listen io-error + ] with-destructors ; M: unix (accept) ( server -- addrspec handle ) #! Wait for a client connection. @@ -102,7 +99,9 @@ M: unix (accept) ( server -- addrspec handle ) ! Datagram sockets - UDP and Unix domain M: unix - [ SOCK_DGRAM server-fd ] keep ; + [ + [ SOCK_DGRAM server-socket-fd ] keep + ] with-destructors ; SYMBOL: receive-buffer diff --git a/extra/io/unix/unix.factor b/extra/io/unix/unix.factor index e8e7135e1a..3a379de78f 100755 --- a/extra/io/unix/unix.factor +++ b/extra/io/unix/unix.factor @@ -1,6 +1,13 @@ -USING: io.unix.backend io.unix.files io.unix.sockets -io.unix.launcher io.unix.mmap io.unix.pipes io.timeouts -io.backend combinators namespaces system vocabs.loader -sequences words init ; +USING: system words sequences vocabs.loader ; + +{ + "io.unix.backend" + "io.unix.files" + "io.unix.sockets" + "io.unix.sockets.secure" + "io.unix.launcher" + "io.unix.mmap" + "io.unix.pipes" +} [ require ] each "io.unix." os word-name append require diff --git a/extra/io/windows/ce/backend/backend.factor b/extra/io/windows/ce/backend/backend.factor index a8ff4c14e3..46564f2aec 100755 --- a/extra/io/windows/ce/backend/backend.factor +++ b/extra/io/windows/ce/backend/backend.factor @@ -46,5 +46,5 @@ M: wince (init-stdio) ( -- ) 1 _getstdfilex _fileno 2 _getstdfilex _fileno ] if [ f ] 3apply - rot -rot [ ] bi@ + [ ] [ ] [ ] tri* ] with-variable ; diff --git a/extra/io/windows/ce/sockets/sockets.factor b/extra/io/windows/ce/sockets/sockets.factor index 0001bb5142..45c10ea258 100755 --- a/extra/io/windows/ce/sockets/sockets.factor +++ b/extra/io/windows/ce/sockets/sockets.factor @@ -32,7 +32,7 @@ M: win32-socket wince-write ( port port-handle -- ) windows.winsock:winsock-error!=0/f ; M: wince (client) ( addrspec -- reader writer ) - do-connect dup ; + do-connect dup ; M: wince (server) ( addrspec -- handle ) windows.winsock:SOCK_STREAM server-fd @@ -52,7 +52,7 @@ M: wince (accept) ( server -- client ) [ windows.winsock:winsock-error ] when ] keep ] keep server-port-addr parse-sockaddr swap - + ] with-timeout ; M: wince ( addrspec -- datagram ) diff --git a/extra/io/windows/nt/sockets/sockets.factor b/extra/io/windows/nt/sockets/sockets.factor index 79e767177d..89e1ea3277 100755 --- a/extra/io/windows/nt/sockets/sockets.factor +++ b/extra/io/windows/nt/sockets/sockets.factor @@ -45,12 +45,16 @@ TUPLE: ConnectEx-args port "stdcall" alien-indirect drop winsock-error-string [ throw ] when* ; -: connect-continuation ( ConnectEx port -- ) - >r ConnectEx-args-lpOverlapped* r> +: connect-continuation ( overlapped port -- ) 2dup save-callback get-overlapped-result drop ; -M: winnt ((client)) ( addrspec -- client-in client-out ) +M: win32-socket wait-to-connect ( client-out handle -- ) + [ overlapped>> swap connect-continuation ] + [ drop pending-error ] + 2bi ; + +M: object ((client)) ( addrspec -- handle ) [ \ ConnectEx-args new over make-sockaddr/size pick init-connect @@ -60,8 +64,7 @@ M: winnt ((client)) ( addrspec -- client-in client-out ) dup ConnectEx-args-s* INADDR_ANY roll bind-socket dup (ConnectEx) - dup ConnectEx-args-s* dup - >r [ connect-continuation ] keep [ pending-error ] keep r> + dup [ ConnectEx-args-s* ] [ ConnectEx-args-lpOverlapped* ] bi ] with-destructors ; TUPLE: AcceptEx-args port @@ -117,7 +120,7 @@ TUPLE: AcceptEx-args port [ extract-remote-host ] keep ! addrspec AcceptEx [ AcceptEx-args-sAcceptSocket* add-completion ] keep - AcceptEx-args-sAcceptSocket* ; + [ AcceptEx-args-sAcceptSocket* ] [ AcceptEx-args-lpOverlapped* ] bi ; M: winnt (accept) ( server -- addrspec handle ) [ @@ -135,7 +138,7 @@ M: winnt (server) ( addrspec -- handle ) [ SOCK_STREAM server-fd dup listen-on-socket dup add-completion - + f ] with-destructors ; M: winnt ( addrspec -- datagram ) @@ -143,7 +146,7 @@ M: winnt ( addrspec -- datagram ) [ SOCK_DGRAM server-fd dup add-completion - + f ] keep ] with-destructors ; diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index 85c448bdbd..c2718c4189 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -123,13 +123,13 @@ C: FileArgs FileArgs-lpOverlapped ; M: windows (file-reader) ( path -- stream ) - open-read ; + open-read ; M: windows (file-writer) ( path -- stream ) - open-write ; + open-write ; M: windows (file-appender) ( path -- stream ) - open-append ; + open-append ; M: windows move-file ( from to -- ) [ normalize-path ] bi@ MoveFile win32-error=0/f ; @@ -151,10 +151,12 @@ M: windows delete-directory ( path -- ) HOOK: WSASocket-flags io-backend ( -- DWORD ) -TUPLE: win32-socket < win32-file ; +TUPLE: win32-socket < win32-file overlapped ; -: ( handle -- win32-socket ) - f win32-file boa ; +: ( handle overlapped -- win32-socket ) + win32-socket new + swap >>overlapped + swap >>handle ; : open-socket ( family type -- socket ) 0 f 0 WSASocket-flags WSASocket dup socket-error ; diff --git a/extra/openssl/openssl.factor b/extra/openssl/openssl.factor index 196ac58695..e745616a8e 100755 --- a/extra/openssl/openssl.factor +++ b/extra/openssl/openssl.factor @@ -19,11 +19,14 @@ M: SSLv23 ssl-method drop SSLv23_method ; M: SSLv3 ssl-method drop SSLv3_method ; M: TLSv1 ssl-method drop TLSv1_method ; -: (ssl-error) ( num -- * ) - ERR_get_error ERR_clear_error f ERR_error_string throw ; +: (ssl-error-string) ( n -- string ) + ERR_clear_error f ERR_error_string ; + +: ssl-error-string ( -- string ) + ERR_get_error ERR_clear_error f ERR_error_string ; : ssl-error ( obj -- ) - { f 0 } member? [ (ssl-error) ] when ; + { f 0 } member? [ ssl-error-string throw ] when ; : init-ssl ( -- ) SSL_library_init ssl-error @@ -114,14 +117,19 @@ M: openssl-context dispose dup handle>> [ SSL_CTX_free ] when* f >>handle drop ; -TUPLE: ssl file handle ; +TUPLE: ssl-handle file handle ; -: ( file -- ssl ) - ssl-context get handle>> SSL_new dup ssl-error ssl boa ; +: ( fd -- ssl ) + ssl-context get handle>> SSL_new dup ssl-error ssl-handle boa ; -M: ssl init-handle drop ; +: ( fd -- ssl ) + [ BIO_NOCLOSE BIO_new_socket dup ssl-error ] keep + + [ handle>> swap dup SSL_set_bio ] keep ; -M: ssl close-handle +M: ssl-handle init-handle drop ; + +M: ssl-handle close-handle [ file>> close-handle ] [ handle>> SSL_free ] bi ; ERROR: certificate-verify-error result ; diff --git a/extra/openssl/unix/unix.factor b/extra/openssl/unix/unix.factor deleted file mode 100644 index d84a46e085..0000000000 --- a/extra/openssl/unix/unix.factor +++ /dev/null @@ -1,11 +0,0 @@ -! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors byte-arrays kernel debugger sequences namespaces math -math.order combinators init alien alien.c-types alien.strings libc -continuations destructors -locals unicode.case -openssl.libcrypto openssl.libssl -io.files io.encodings.ascii io.sockets.secure ; -IN: openssl.unix - - diff --git a/extra/oracle/liboci/liboci.factor b/extra/oracle/liboci/liboci.factor index 7af69a97bb..aa04aef39f 100644 --- a/extra/oracle/liboci/liboci.factor +++ b/extra/oracle/liboci/liboci.factor @@ -124,7 +124,6 @@ TYPEDEF: ushort ub2 TYPEDEF: short sb2 TYPEDEF: uint ub4 TYPEDEF: int sb4 -TYPEDEF: ulong size_t ! =============================================== ! Input data types (ocidfn.h) diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index c68f127226..948fca219e 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -11,7 +11,6 @@ IN: unix TYPEDEF: uint in_addr_t TYPEDEF: uint socklen_t -TYPEDEF: ulong size_t : PROT_NONE 0 ; inline : PROT_READ 1 ; inline diff --git a/extra/windows/types/types.factor b/extra/windows/types/types.factor index 8b4b2d98d2..3fef691741 100644 --- a/extra/windows/types/types.factor +++ b/extra/windows/types/types.factor @@ -198,7 +198,6 @@ TYPEDEF: void* MSGBOXPARAMSA TYPEDEF: void* MSGBOXPARAMSW TYPEDEF: void* LPOVERLAPPED_COMPLETION_ROUTINE -TYPEDEF: int size_t TYPEDEF: size_t socklen_t TYPEDEF: void* WNDPROC