io.sockets.secure.*: unification of lots of platform-independent code

Code that is duplicated in the backends moved to
io.sockets.secure.openssl. The wait-for-fd verb used by do-ssl-accept
doesn't have any equivalent on Windows so that needs to be
implemented.

basis/io/sockets/secure/openssl/openssl.factor

@@ -1,12 +1,11 @@
 ! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien alien.c-types alien.data alien.strings
-assocs byte-arrays classes.struct combinators destructors
+assocs byte-arrays classes.struct combinators destructors fry
-io.backend io.encodings.8-bit.latin1 io.encodings.utf8
+io.backend io.buffers io.encodings.8-bit.latin1 io.encodings.utf8
-io.pathnames io.sockets.secure kernel libc locals math
+io.files io.pathnames io.sockets.secure io.timeouts kernel libc
-math.order math.parser namespaces openssl openssl.libcrypto
+locals math math.order math.parser namespaces openssl openssl.libssl
-openssl.libssl random sequences splitting unicode.case
+openssl.libcrypto random sequences splitting unicode.case ;
-io.files ;
 IN: io.sockets.secure.openssl
 
 GENERIC: ssl-method ( symbol -- method )
@@ -161,6 +160,12 @@ SYMBOL: default-secure-context
         ] initialize-alien
     ] unless* ;
 
+: get-session ( addrspec -- session/f )
+    current-secure-context sessions>> at ;
+
+: save-session ( session addrspec -- )
+    current-secure-context sessions>> set-at ;
+
 : <ssl-handle> ( fd -- ssl )
     [
         ssl-handle new-disposable |dispose
@@ -169,6 +174,130 @@ SYMBOL: default-secure-context
         swap >>file
     ] with-destructors ;
 
+: syscall-error ( handle r -- event )
+    nip
+    ERR_get_error [
+        {
+            { -1 [ errno ECONNRESET = [ premature-close ] [ (io-error) ] if ] }
+            ! OpenSSL docs say this it is an error condition for
+            ! a server to not send a close notify, but web
+            ! servers in the wild don't seem to do this, for
+            ! example https://www.google.com.
+            { 0 [ f ] }
+        } case
+    ] [ nip (ssl-error) ] if-zero ;
+
+: check-response ( port r -- port r n )
+    over handle>> handle>> over SSL_get_error ; inline
+
+: 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_ACCEPT [ 2drop +input+ ] }
+        { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
+        { SSL_ERROR_SYSCALL [ syscall-error ] }
+        { SSL_ERROR_ZERO_RETURN [ (ssl-error) ] }
+        { SSL_ERROR_SSL [ (ssl-error) ] }
+    } case ;
+
+! Does this work on windows?
+: do-ssl-accept ( ssl-handle -- )
+    dup dup handle>> SSL_accept check-accept-response dup
+    [
+        [ dup file>> ] dip
+        2drop ! wait-for-fd, todo: figure out wait-for-fd for windows
+        do-ssl-accept
+    ] [ 2drop ] if ;
+
+: maybe-handshake ( ssl-handle -- )
+    dup connected>> [ drop ] [
+        t >>connected
+        [ do-ssl-accept ] with-timeout
+    ] if ;
+
+! Input ports
+: check-read-response ( port r -- event )
+    check-response
+    {
+        { SSL_ERROR_NONE [ swap buffer>> n>buffer f ] }
+        { SSL_ERROR_ZERO_RETURN [ 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 ;
+
+M: ssl-handle refill
+    dup maybe-handshake
+    handle>> ! ssl
+    over buffer>>
+    [ buffer-end ] ! buf
+    [ buffer-capacity ] bi ! len
+    SSL_read
+    check-read-response ;
+
+! Output ports
+: check-write-response ( port r -- event )
+    check-response
+    {
+        { SSL_ERROR_NONE [ swap buffer>> buffer-consume f ] }
+        { SSL_ERROR_WANT_READ [ 2drop +input+ ] }
+        { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
+        { SSL_ERROR_SYSCALL [ syscall-error ] }
+        { SSL_ERROR_SSL [ (ssl-error) ] }
+    } case ;
+
+M: ssl-handle drain
+    dup maybe-handshake
+    handle>> ! ssl
+    over buffer>>
+    [ buffer@ ] ! buf
+    [ buffer-length ] bi ! len
+    SSL_write
+    check-write-response ;
+
+! Connect
+: check-connect-response ( ssl-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-connect ( ssl-handle -- )
+    dup dup handle>> SSL_connect check-connect-response dup
+    [ dupd 2drop do-ssl-connect ] [ 2drop ] if ;
+
+: resume-session ( ssl-handle ssl-session -- )
+    [ [ handle>> ] dip SSL_set_session ssl-error ]
+    [ drop do-ssl-connect ]
+    2bi ;
+
+: begin-session ( ssl-handle addrspec -- )
+    [ drop do-ssl-connect ]
+    [ [ handle>> SSL_get1_session ] dip save-session ]
+    2bi ;
+
+: secure-connection ( client-out addrspec -- )
+    [ handle>> ] dip
+    [
+        '[
+            _ dup get-session
+            [ resume-session ] [ begin-session ] ?if
+        ] with-timeout
+    ] [ drop t >>connected drop ] 2bi ;
+
+M: ssl-handle timeout
+    drop secure-socket-timeout get ;
+
+M: ssl-handle cancel-operation
+    file>> cancel-operation ;
+
 M: ssl-handle dispose*
     [
         ! Free file>> after SSL_free
@@ -218,10 +347,4 @@ M: openssl check-certificate ( host ssl -- )
         2bi
     ] [ 2drop ] if ;
 
-: get-session ( addrspec -- session/f )
-    current-secure-context sessions>> at ;
-
-: save-session ( session addrspec -- )
-    current-secure-context sessions>> set-at ;
-
 openssl secure-socket-backend set-global

basis/io/sockets/secure/unix/unix.factor

@@ -16,91 +16,6 @@ M: openssl ssl-certificate-verification-supported? t ;
 
 M: ssl-handle handle-fd file>> handle-fd ;
 
-: syscall-error ( handle r -- event )
-    nip
-    ERR_get_error [
-        {
-            { -1 [ errno ECONNRESET = [ premature-close ] [ (io-error) ] if ] }
-            ! OpenSSL docs say this it is an error condition for
-            ! a server to not send a close notify, but web
-            ! servers in the wild don't seem to do this, for
-            ! example https://www.google.com.
-            { 0 [ f ] }
-        } case
-    ] [ nip (ssl-error) ] if-zero ;
-
-: 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_ACCEPT [ 2drop +input+ ] }
-        { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
-        { SSL_ERROR_SYSCALL [ syscall-error ] }
-        { SSL_ERROR_ZERO_RETURN [ (ssl-error) ] }
-        { SSL_ERROR_SSL [ (ssl-error) ] }
-    } case ;
-
-: do-ssl-accept ( ssl-handle -- )
-    dup dup handle>> SSL_accept check-accept-response dup
-    [ [ dup file>> ] dip wait-for-fd do-ssl-accept ] [ 2drop ] if ;
-
-: maybe-handshake ( ssl-handle -- )
-    dup connected>> [ drop ] [
-        t >>connected
-        [ do-ssl-accept ] with-timeout
-    ] if ;
-
-: check-response ( port r -- port r n )
-    over handle>> handle>> over SSL_get_error ; inline
-
-! Input ports
-: check-read-response ( port r -- event )
-    check-response
-    {
-        { SSL_ERROR_NONE [ swap buffer>> n>buffer f ] }
-        { SSL_ERROR_ZERO_RETURN [ 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 ;
-
-M: ssl-handle refill
-    dup maybe-handshake
-    handle>> ! ssl
-    over buffer>>
-    [ buffer-end ] ! buf
-    [ buffer-capacity ] bi ! len
-    SSL_read
-    check-read-response ;
-
-! Output ports
-: check-write-response ( port r -- event )
-    check-response
-    {
-        { SSL_ERROR_NONE [ swap buffer>> buffer-consume f ] }
-        { SSL_ERROR_WANT_READ [ 2drop +input+ ] }
-        { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
-        { SSL_ERROR_SYSCALL [ syscall-error ] }
-        { SSL_ERROR_SSL [ (ssl-error) ] }
-    } case ;
-
-M: ssl-handle drain
-    dup maybe-handshake
-    handle>> ! ssl
-    over buffer>>
-    [ buffer@ ] ! buf
-    [ buffer-length ] bi ! len
-    SSL_write
-    check-write-response ;
-
-M: ssl-handle cancel-operation
-    file>> cancel-operation ;
-
-M: ssl-handle timeout
-    drop secure-socket-timeout get ;
-
 ! Client sockets
 : <ssl-socket> ( fd -- ssl )
     [ fd>> BIO_NOCLOSE BIO_new_socket dup ssl-error ] keep <ssl-handle>
@@ -113,39 +28,6 @@ M: secure parse-sockaddr addrspec>> parse-sockaddr <secure> ;
 
 M: secure (get-local-address) addrspec>> (get-local-address) ;
 
-: check-connect-response ( ssl-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-connect ( ssl-handle -- )
-    dup dup handle>> SSL_connect check-connect-response dup
-    [ dupd wait-for-fd do-ssl-connect ] [ 2drop ] if ;
-
-: resume-session ( ssl-handle ssl-session -- )
-    [ [ handle>> ] dip SSL_set_session ssl-error ]
-    [ drop do-ssl-connect ]
-    2bi ;
-
-: begin-session ( ssl-handle addrspec -- )
-    [ drop do-ssl-connect ]
-    [ [ handle>> SSL_get1_session ] dip save-session ]
-    2bi ;
-
-: secure-connection ( client-out addrspec -- )
-    [ handle>> ] dip
-    [
-        '[
-            _ dup get-session
-            [ resume-session ] [ begin-session ] ?if
-        ] with-timeout
-    ] [ drop t >>connected drop ] 2bi ;
-
 M: secure establish-connection ( client-out remote -- )
     addrspec>> [ establish-connection ] [ secure-connection ] 2bi ;
 

basis/io/sockets/secure/windows/windows.factor

@@ -1,76 +1,19 @@
 USING:
     accessors
-    alien alien.c-types alien.data
+    alien
-    combinators
-    fry
-    io.buffers
-    io.files
     io.ports
     io.sockets.private io.sockets.secure io.sockets.secure.openssl
-    io.timeouts
     kernel
-    namespaces
     openssl openssl.libcrypto openssl.libssl ;
 IN: io.sockets.secure.windows
 
-! Most of this vocab is duplicated code from io.sockets.secure.unix so
-! you could probably unify them.
 M: openssl ssl-supported? t ;
 M: openssl ssl-certificate-verification-supported? f ;
 
-: check-response ( port r -- port r n )
-    over handle>> handle>> over SSL_get_error ; inline
-
-: check-read-response ( port r -- event )
-    check-response
-    {
-        { SSL_ERROR_NONE [ swap buffer>> n>buffer f ] }
-        { SSL_ERROR_ZERO_RETURN [ 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 ;
-
-: maybe-handshake ( ssl-handle -- )
-    dup connected>> [ drop ] [
-        t >>connected
-        [ do-ssl-accept ] with-timeout
-    ] if ;
-
-M: ssl-handle refill
-    dup maybe-handshake
-    handle>> ! ssl
-    over buffer>>
-    [ buffer-end ] ! buf
-    [ buffer-capacity ] bi ! len
-    SSL_read
-    check-read-response ;
-
-: check-write-response ( port r -- event )
-    check-response
-    {
-        { SSL_ERROR_NONE [ swap buffer>> buffer-consume f ] }
-        { SSL_ERROR_WANT_READ [ 2drop "input!" ] }
-        { SSL_ERROR_WANT_WRITE [ 2drop "output!" ] }
-        { SSL_ERROR_SYSCALL [ syscall-error ] }
-        { SSL_ERROR_SSL [ (ssl-error) ] }
-    } case ;
-
-M: ssl-handle drain
-    dup maybe-handshake
-    handle>> ! ssl
-    over buffer>>
-    [ buffer@ ] ! buf
-    [ buffer-length ] bi ! len
-    SSL_write
-    check-write-response ;
-
-M: ssl-handle timeout
-    drop secure-socket-timeout get ;
-
 : <ssl-socket> ( winsock -- ssl )
-    [ handle>> alien-address BIO_NOCLOSE BIO_new_socket ] keep <ssl-handle>
+    [
+        handle>> alien-address BIO_NOCLOSE BIO_new_socket dup ssl-error
+    ] keep <ssl-handle>
     [ handle>> swap dup SSL_set_bio ] keep ;
 
 M: secure ((client)) ( addrspec -- handle )
@@ -81,49 +24,6 @@ M: secure (get-local-address) ( handle remote -- sockaddr )
 
 M: secure parse-sockaddr addrspec>> parse-sockaddr <secure> ;
 
-! The error codes needs to be handled properly.
-: check-connect-response ( ssl-handle r -- event )
-    over handle>> over SSL_get_error
-    {
-        { SSL_ERROR_NONE [ 2drop f ] }
-        {
-            SSL_ERROR_WANT_READ
-            [ 2drop "input route" ]
-        }
-        {
-            SSL_ERROR_WANT_WRITE
-            [ 2drop "output route" ]
-        }
-        {
-            SSL_ERROR_SYSCALL
-            [ 2drop "syscall error" ]
-        }
-        { SSL_ERROR_SSL [ (ssl-error) ] }
-    } case ;
-
-: do-ssl-connect ( ssl-handle -- )
-    dup dup handle>> SSL_connect check-connect-response dup
-    [ dupd 2drop do-ssl-connect ] [ 2drop ] if ;
-
-: resume-session ( ssl-handle ssl-session -- )
-    [ [ handle>> ] dip SSL_set_session ssl-error ]
-    [ drop do-ssl-connect ]
-    2bi ;
-
-: begin-session ( ssl-handle addrspec -- )
-    [ drop do-ssl-connect ]
-    [ [ handle>> SSL_get1_session ] dip save-session ]
-    2bi ;
-
-: secure-connection ( client-out addrspec -- )
-    [ handle>> ] dip
-    [
-        '[
-            _ dup get-session
-            [ resume-session ] [ begin-session ] ?if
-        ] with-timeout
-    ] [ drop t >>connected drop ] 2bi ;
-
 M: secure establish-connection ( client-out remote -- )
     [
         [ handle>> file>> <output-port> ] [ addrspec>> ] bi* establish-connection