Working on SSL server sockets

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>> <input-port> ] [ out>> <output-port> ] bi* ]
         } 2cleave r> <encoder-duplex>
     ] with-destructors ;

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 <ports> ] [ encoding>> ] bi* <encoder-duplex> ]
     [ addr>> parse-sockaddr ]

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 ;
+
+: <fd> ( 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
+            swap handle-fd
             mx get-global
             r> {
                 { +input+ [ add-input-callback ] }
                 { +output+ [ add-output-callback ] }
             } case
-            ] curry "I/O" suspend drop
+        ] curry "I/O" suspend 2drop
-        ] curry with-timeout pending-error
     ] 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
+M: fd refill
-    over buffer>> [ buffer-end ] [ buffer-capacity ] bi read
+    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
+M: fd drain
-    over buffer>> [ buffer@ ] [ buffer-length ] bi write
+    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 <input-port>
+    0 <fd> <input-port>
-    1 <output-port>
+    1 <fd> <output-port>
-    2 <output-port> ;
+    2 <fd> <output-port> ;
 
 ! mx io-task for embedding an fd-based mx inside another mx
 TUPLE: mx-port < port mx ;

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 [ <byte-array> ] [ ] bi getcwd
+    MAXPATHLEN [ <byte-array> ] 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 <input-port> ;
+    open-read <fd> <input-port> ;
 
 : 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 <output-port> ;
+    open-write <fd> <output-port> ;
 
 : 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 <output-port> ;
+    open-append <fd> <output-port> ;
 
 : touch-mode ( -- n )
     { O_WRONLY O_APPEND O_CREAT O_EXCL } flags ; foldable

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 <process-stream> contents drop ] unit-test

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 ;
 

extra/io/unix/pipes/pipes.factor

@@ -8,5 +8,5 @@ QUALIFIED: io.pipes
 M: unix io.pipes:(pipe) ( -- pair )
     2 "int" <c-array>
     dup pipe io-error
-    2 c-int-array> first2
+    2 c-int-array> first2 [ <fd> ] bi@
     [ [ init-handle ] bi@ ] [ io.pipes:pipe boa ] 2bi ;

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 )
+: <ssl-socket> ( fd -- ssl )
-    [ addrspec>> ((client)) <ssl-socket> ] with-destructors ;
+    [ fd>> BIO_NOCLOSE BIO_new_socket dup ssl-error ] keep <ssl-handle>
+    [ handle>> swap dup SSL_set_bio ] keep ;
 
-M: ssl parse-sockaddr addrspec>> parse-sockaddr ;
+M: ssl ((client)) ( addrspec -- handle )
+    addrspec>> ((client)) <ssl-socket> ;
+
+M: ssl parse-sockaddr addrspec>> parse-sockaddr <ssl> ;
 
 : 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 -- )
+: do-ssl-connect ( port ssl-handle -- )
-    drop
     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 ]
+    [ drop handle>> do-ssl-connect ]
-    3bi ;
+    [ 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
+        <ssl-socket> 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 ;

extra/io/unix/sockets/sockets.factor

@@ -12,69 +12,68 @@ EXCLUDE: io.sockets => accept ;
 
 IN: io.unix.sockets
 
-: socket-fd ( domain type -- socket )
+: socket-fd ( domain type -- fd )
-    0 socket
+    0 socket dup io-error <fd> [ close-later ] [ init-handle ] [ ] tri ;
-    dup io-error
-    dup close-later
-    dup init-handle ;
 
-: sockopt ( fd level opt -- )
+: set-socket-option ( fd level opt -- )
-    1 <int> "int" heap-size setsockopt io-error ;
+    >r >r handle-fd r> r> 1 <int> "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
+    >r >r dup handle-fd r> r> connect zero? err_no EINPROGRESS = or
-    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 )
+: do-accept ( server addrspec -- fd remote )
-    [ handle>> ] [ addr>> empty-sockaddr/size ] bi
+    [ handle>> handle-fd ] [ empty-sockaddr/size ] bi*
     [ accept ] 2keep drop ; inline
 
-M: unix (accept) ( server -- fd remote )
+M: object (accept) ( server addrspec -- fd remote )
-    dup do-accept
+    2dup do-accept
     {
-        { [ over 0 >= ] [ rot drop ] }
+        { [ over 0 >= ] [ { [ drop ] [ drop ] [ <fd> ] [ ] } spread ] }
         { [ err_no EINTR = ] [ 2drop (accept) ] }
         { [ err_no EAGAIN = ] [
             2drop
-            [ +input+ wait-for-port ]
+            [ drop +input+ wait-for-port ]
-            [ (accept) ] bi
+            [ (accept) ]
+            2bi
         ] }
         [ (io-error) ]
     } cond ;
@@ -91,7 +90,7 @@ packet-size <byte-array> 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

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 ) ;
 

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
 
 : <ssl-handle> ( fd -- ssl )
     current-ssl-context handle>> SSL_new dup ssl-error
-    f ssl-handle boa ;
+    f f ssl-handle boa ;
 
-: <ssl-socket> ( fd -- ssl )
+M: ssl-handle init-handle file>> init-handle ;
-    [ BIO_NOCLOSE BIO_new_socket dup ssl-error ] keep
-    <ssl-handle>
-    [ handle>> swap dup SSL_set_bio ] keep ;
 
-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 ;