Move underlying-handle word from io.launcher to io.ports, add a new underlying-port word

Add a remote-address symbol to io.sockets, with-client binds it, ditto for io.servers.connection
io.sockets.secure now has two new words, send-secure-handshake, accept-secure-handshake, to upgrade existing connections

basis/io/launcher/launcher.factor

@@ -183,16 +183,18 @@ M: object run-pipeline-element
 
 : <process-reader*> ( desc encoding -- stream process )
     [
-        >r (pipe) {
+        [
-            [ |dispose drop ]
+            (pipe) {
-            [
+                [ |dispose drop ]
-                swap >process
+                [
-                    [ swap out>> or ] change-stdout
+                    swap >process
-                run-detached
+                        [ swap out>> or ] change-stdout
-            ]
+                    run-detached
-            [ out>> dispose ]
+                ]
-            [ in>> <input-port> ]
+                [ out>> dispose ]
-        } cleave r> <decoder> swap
+                [ in>> <input-port> ]
+            } cleave
+        ] dip <decoder> swap
     ] with-destructors ;
 
 : <process-reader> ( desc encoding -- stream )
@@ -205,16 +207,18 @@ M: object run-pipeline-element
 
 : <process-writer*> ( desc encoding -- stream process )
     [
-        >r (pipe) {
+        [
-            [ |dispose drop ]
+            (pipe) {
-            [
+                [ |dispose drop ]
-                swap >process
+                [
-                    [ swap in>> or ] change-stdin
+                    swap >process
-                run-detached
+                        [ swap in>> or ] change-stdin
-            ]
+                    run-detached
-            [ in>> dispose ]
+                ]
-            [ out>> <output-port> ]
+                [ in>> dispose ]
-        } cleave r> <encoder> swap
+                [ out>> <output-port> ]
+            } cleave
+        ] dip <encoder> swap
     ] with-destructors ;
 
 : <process-writer> ( desc encoding -- stream )
@@ -227,17 +231,19 @@ M: object run-pipeline-element
 
 : <process-stream*> ( desc encoding -- stream process )
     [
-        >r (pipe) (pipe) {
+        [
-            [ [ |dispose drop ] bi@ ]
+            (pipe) (pipe) {
-            [
+                [ [ |dispose drop ] bi@ ]
-                rot >process
+                [
-                    [ swap in>> or ] change-stdin
+                    rot >process
-                    [ swap out>> or ] change-stdout
+                        [ swap in>> or ] change-stdin
-                run-detached
+                        [ swap out>> or ] change-stdout
-            ]
+                    run-detached
-            [ [ out>> dispose ] [ in>> dispose ] bi* ]
+                ]
-            [ [ in>> <input-port> ] [ out>> <output-port> ] bi* ]
+                [ [ out>> dispose ] [ in>> dispose ] bi* ]
-        } 2cleave r> <encoder-duplex> swap
+                [ [ in>> <input-port> ] [ out>> <output-port> ] bi* ]
+            } 2cleave
+        ] dip <encoder-duplex> swap
     ] with-destructors ;
 
 : <process-stream> ( desc encoding -- stream )
@@ -254,23 +260,6 @@ M: object run-pipeline-element
     f >>handle
     drop ;
 
-GENERIC: underlying-handle ( stream -- handle )
-
-M: port underlying-handle handle>> ;
-
-ERROR: invalid-duplex-stream ;
-
-M: duplex-stream underlying-handle
-    [ in>> underlying-handle ]
-    [ out>> underlying-handle ] bi
-    [ = [ invalid-duplex-stream ] when ] keep ;
-
-M: encoder underlying-handle
-    stream>> underlying-handle ;
-
-M: decoder underlying-handle
-    stream>> underlying-handle ;
-
 {
     { [ os unix? ] [ "io.unix.launcher" require ] }
     { [ os winnt? ] [ "io.windows.nt.launcher" require ] }

basis/io/ports/ports.factor

@@ -46,7 +46,7 @@ M: input-port stream-read1
 
 M: input-port stream-read-partial ( max stream -- byte-array/f )
     dup check-disposed
-    >r 0 max >integer r> read-step ;
+    [ 0 max >integer ] dip read-step ;
 
 : read-loop ( count port accum -- )
     pick over length - dup 0 > [
@@ -61,7 +61,7 @@ M: input-port stream-read-partial ( max stream -- byte-array/f )
 
 M: input-port stream-read
     dup check-disposed
-    >r 0 max >fixnum r>
+    [ 0 max >fixnum ] dip
     2dup read-step dup [
         pick over length > [
             pick <byte-vector>
@@ -76,21 +76,21 @@ M: input-port stream-read
 
 : read-until-loop ( seps port buf -- separator/f )
     2over read-until-step over [
-        >r over push-all r> dup [
+        [ over push-all ] dip dup [
-            >r 3drop r>
+            [ 3drop ] dip
         ] [
             drop read-until-loop
         ] if
     ] [
-        >r 2drop 2drop r>
+        [ 2drop 2drop ] dip
     ] if ;
 
 M: input-port stream-read-until ( seps port -- str/f sep/f )
-    2dup read-until-step dup [ >r 2nip r> ] [
+    2dup read-until-step dup [ [ 2drop ] 2dip ] [
         over [
             drop
             BV{ } like [ read-until-loop ] keep B{ } like swap
-        ] [ >r 2nip r> ] if
+        ] [ [ 2drop ] 2dip ] if
     ] if ;
 
 TUPLE: output-port < buffered-port ;
@@ -114,7 +114,7 @@ M: output-port stream-write
         [ [ stream-write ] curry ] bi
         each
     ] [
-        [ >r length r> wait-to-write ]
+        [ [ length ] dip wait-to-write ]
         [ buffer>> >buffer ] 2bi
     ] if ;
 
@@ -153,6 +153,18 @@ M: port dispose*
         bi
     ] with-destructors ;
 
+GENERIC: underlying-port ( stream -- port )
+
+M: port underlying-port ;
+
+M: encoder underlying-port stream>> underlying-port ;
+
+M: decoder underlying-port stream>> underlying-port ;
+
+GENERIC: underlying-handle ( stream -- handle )
+
+M: object underlying-handle underlying-port handle>> ;
+
 ! Fast-path optimization
 USING: hints strings io.encodings.utf8 io.encodings.ascii
 io.encodings.private ;

basis/io/servers/connection/connection.factor

@@ -39,8 +39,6 @@ ready ;
 : <threaded-server> ( -- threaded-server )
     threaded-server new-threaded-server ;
 
-SYMBOL: remote-address
-
 GENERIC: handle-client* ( threaded-server -- )
 
 <PRIVATE

basis/io/sockets/secure/secure-docs.factor

@@ -1,5 +1,5 @@
+USING: io help.markup help.syntax calendar quotations io.sockets ;
 IN: io.sockets.secure
-USING: help.markup help.syntax calendar quotations io.sockets ;
 
 HELP: secure-socket-timeout
 { $var-description "Timeout for operations not associated with a constructed port instance, such as SSL handshake and shutdown. Represented as a " { $link duration } "." } ;
@@ -99,6 +99,23 @@ $nl
 { $subsection <secure> }
 "Instances of this class can wrap an " { $link inet } ", " { $link inet4 } " or an " { $link inet6 } ", although note that certificate validation is only performed for instances of " { $link inet } " since otherwise the host name is not available." ;
 
+HELP: send-secure-handshake
+{ $contract "Upgrades the socket connection of the current " { $link with-client } " scope to a secure connection and initiates a SSL/TLS handshake." }
+{ $errors "Throws " { $link upgrade-on-non-socket } " or " { $link upgrade-buffers-full } " if used improperly." }
+{ $examples "This word is used by the " { $vocab-link "smtp" } " library to implement SMTP-TLS." } ;
+
+HELP: accept-secure-handshake
+{ $contract "Upgrades the socket connection stored in the " { $link input-stream } " and " { $link output-stream } " variables to a secure connection and waits for an SSL/TLS handshake." }
+{ $errors "Throws " { $link upgrade-on-non-socket } " or " { $link upgrade-buffers-full } " if used improperly." } ;
+
+ARTICLE: "ssl-upgrade" "Upgrading existing connections"
+"Some protocols, such as HTTPS, require that the connection be established as an SSL/TLS connection. Others, such as secure SMTP and POP3 require that the client and server initiate an SSL/TLS handshake upon the client sending a plain-text request. The latter use-case is accomodated by a pair of words."
+$nl
+"Upgrading a connection to a secure socket by initiating an SSL/TLS handshake with the server:"
+{ $subsection send-secure-handshake }
+"Upgrading a connection to a secure socket by waiting for an SSL/TLS handshake from the client:"
+{ $subsection accept-secure-handshake } ;
+
 HELP: premature-close
 { $error-description "Thrown if an SSL connection is closed without the proper " { $snippet "close_notify" } " sequence. This error is never reported for " { $link SSLv2 } " connections because there is no distinction between expected and unexpected connection closure in that case." } ;
 
@@ -106,23 +123,34 @@ HELP: certificate-verify-error
 { $error-description "Thrown if certificate verification failed. The " { $snippet "result" } " slot contains an object identifying the low-level error that occurred." } ;
 
 HELP: common-name-verify-error
-{ $error-description "Thrown during certificate verification if the host name on the certificate does not match the host name the socket was connected to. This indicates a potential man-in-the-middle attack. The " { $snippet "expected" } " and " { $snippet "got" } " slots contain the mismatched host names." } ;
+{ $error-description "Thrown during certificate verification if the host name on the certificate does not match the host name the socket was connected to. This indicates a potential man-in-the-middle attack. The " { $slot "expected" } " and " { $slot "got" } " slots contain the mismatched host names." } ;
+
+HELP: upgrade-on-non-socket
+{ $error-description "Thrown if " { $link send-secure-handshake } " or " { $link accept-secure-handshake } " is called with the " { $link input-stream } " and " { $link output-stream } " variables not set to a socket. This error can also indicate that the connection has already been upgraded to a secure connection." } ;
+
+HELP: upgrade-buffers-full
+{ $error-description "Thrown if " { $link send-secure-handshake } " or " { $link accept-secure-handshake } " is called when there is still data which hasn't been read or written." }
+{ $notes "Clients should ensure to " { $link flush } " their last command to the server before calling " { $link send-secure-handshake } "." } ;
 
 ARTICLE: "ssl-errors" "Secure socket errors"
 "Secure sockets can throw one of several errors in addition to the usual I/O errors:"
 { $subsection premature-close }
 { $subsection certificate-verify-error }
-{ $subsection common-name-verify-error } ;
+{ $subsection common-name-verify-error }
+"The " { $link send-secure-handshake } " word can throw one of two errors:"
+{ $subsection upgrade-on-non-socket }
+{ $subsection upgrade-buffers-full } ;
 
 ARTICLE: "io.sockets.secure" "Secure sockets (SSL, TLS)"
 "The " { $vocab-link "io.sockets.secure" } " vocabulary implements secure, encrypted sockets using the OpenSSL library."
 $nl
-"At present, this vocabulary is only supported on Unix, and not on Windows."
+"At present, this vocabulary only works on Unix, and not on Windows."
 $nl
 "This product includes software developed by the OpenSSL Project for use in the OpenSSL Toolkit (" { $url "http://www.openssl.org/" } "), cryptographic software written by Eric Young (eay@cryptsoft.com) and software written by Tim Hudson (tjh@cryptsoft.com)."
 { $subsection "ssl-config" }
 { $subsection "ssl-contexts" }
 { $subsection "ssl-addresses" }
+{ $subsection "ssl-upgrade" }
 { $subsection "ssl-errors" } ;
 
 ABOUT: "io.sockets.secure"

basis/io/sockets/secure/secure.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel symbols namespaces continuations
-destructors io.sockets sequences summary calendar delegate
+destructors io debugger io.sockets sequences summary calendar
-system vocabs.loader combinators present ;
+delegate system vocabs.loader combinators present ;
 IN: io.sockets.secure
 
 SYMBOL: secure-socket-timeout
@@ -52,10 +52,10 @@ M: secure resolve-host ( secure -- seq )
 
 HOOK: check-certificate secure-socket-backend ( host handle -- )
 
-<PRIVATE
-
 PREDICATE: secure-inet < secure addrspec>> inet? ;
 
+<PRIVATE
+
 M: secure-inet (client)
     [
         [ resolve-host (client) [ |dispose ] dip ] keep
@@ -79,6 +79,23 @@ ERROR: common-name-verify-error expected got ;
 M: common-name-verify-error summary
     drop "Common name verification failed" ;
 
+ERROR: upgrade-on-non-socket ;
+
+M: upgrade-on-non-socket summary
+    drop
+    "send-secure-handshake can only be used if input-stream and" print
+    "output-stream are a socket" ;
+
+ERROR: upgrade-buffers-full ;
+
+M: upgrade-buffers-full summary
+    drop
+    "send-secure-handshake can only be used if buffers are empty" ;
+
+HOOK: send-secure-handshake secure-socket-backend ( -- )
+
+HOOK: accept-secure-handshake secure-socket-backend ( -- )
+
 {
     { [ os unix? ] [ "io.unix.sockets.secure" require ] }
     { [ os windows? ] [ "openssl" require ] }

basis/io/sockets/sockets.factor

@@ -6,7 +6,7 @@ sequences arrays io.encodings io.ports io.streams.duplex
 io.encodings.ascii alien.strings io.binary accessors destructors
 classes debugger byte-arrays system combinators parser
 alien.c-types math.parser splitting grouping math assocs summary
-system vocabs.loader combinators present ;
+system vocabs.loader combinators present fry ;
 IN: io.sockets
 
 << {
@@ -89,7 +89,7 @@ M: inet4 make-sockaddr ( inet -- sockaddr )
     rot inet-pton *uint over set-sockaddr-in-addr ;
 
 M: inet4 parse-sockaddr
-    >r dup sockaddr-in-addr <uint> r> inet-ntop
+    [ dup sockaddr-in-addr <uint> ] dip inet-ntop
     swap sockaddr-in-port ntohs <inet4> ;
 
 TUPLE: inet6 < abstract-inet ;
@@ -144,7 +144,7 @@ M: inet6 make-sockaddr ( inet -- sockaddr )
     rot inet-pton over set-sockaddr-in6-addr ;
 
 M: inet6 parse-sockaddr
-    >r dup sockaddr-in6-addr r> inet-ntop
+    [ dup sockaddr-in6-addr ] dip inet-ntop
     swap sockaddr-in6-port ntohs <inet6> ;
 
 : addrspec-of-family ( af -- addrspec )
@@ -184,7 +184,7 @@ M: object (client) ( remote -- client-in client-out local )
     [
         [ ((client)) ] keep
         [
-            >r <ports> [ |dispose ] bi@ dup r>
+            [ <ports> [ |dispose ] bi@ dup ] dip
             establish-connection
         ]
         [ get-local-address ]
@@ -192,13 +192,19 @@ M: object (client) ( remote -- client-in client-out local )
     ] with-destructors ;
 
 : <client> ( remote encoding -- stream local )
-    >r (client) -rot r> <encoder-duplex> swap ;
+    [ (client) -rot ] dip <encoder-duplex> swap ;
 
 SYMBOL: local-address
 
+SYMBOL: remote-address
+
 : with-client ( remote encoding quot -- )
-    >r <client> [ local-address set ] curry
+    [
-    r> compose with-stream ; inline
+        [
+            over remote-address set
+            <client> local-address set
+        ] dip with-stream
+    ] with-scope ; inline
 
 TUPLE: server-port < port addr encoding ;
 
@@ -209,10 +215,11 @@ TUPLE: server-port < port addr encoding ;
 GENERIC: (server) ( addrspec -- handle )
 
 : <server> ( addrspec encoding -- server )
-    >r
+    [
-    [ (server) ] keep
+        [ (server) ] keep
-    [ drop server-port <port> ] [ get-local-address ] 2bi
+        [ drop server-port <port> ] [ get-local-address ] 2bi
-    >>addr r> >>encoding ;
+        >>addr
+    ] dip >>encoding ;
 
 GENERIC: (accept) ( server addrspec -- handle sockaddr )
 
@@ -281,7 +288,7 @@ C: <inet> inet
     IPPROTO_TCP over set-addrinfo-protocol ;
 
 : fill-in-ports ( addrspecs port -- addrspecs )
-    [ >>port ] curry map ;
+    '[ _ >>port ] map ;
 
 M: inet resolve-host
     [ port>> ] [ host>> ] bi [

basis/io/streams/duplex/duplex.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel continuations destructors io io.encodings
-io.encodings.private io.timeouts debugger summary listener
+io.encodings.private io.timeouts io.ports debugger summary
-accessors delegate delegate.protocols ;
+listener accessors delegate delegate.protocols ;
 IN: io.streams.duplex
 
 TUPLE: duplex-stream in out ;
@@ -30,7 +30,15 @@ M: duplex-stream dispose
     tuck re-encode >r re-decode r> <duplex-stream> ;
 
 : with-stream* ( stream quot -- )
-    >r [ in>> ] [ out>> ] bi r> with-streams* ; inline
+    [ [ in>> ] [ out>> ] bi ] dip with-streams* ; inline
 
 : with-stream ( stream quot -- )
-    >r [ in>> ] [ out>> ] bi r> with-streams ; inline
+    [ [ in>> ] [ out>> ] bi ] dip with-streams ; inline
+
+ERROR: invalid-duplex-stream ;
+
+M: duplex-stream underlying-handle
+    [ in>> underlying-handle ]
+    [ out>> underlying-handle ] bi
+    [ = [ invalid-duplex-stream ] when ] keep ;
+

basis/io/unix/launcher/launcher.factor

@@ -40,14 +40,13 @@ USE: unix
     3drop ;
 
 : redirect-file ( obj mode fd -- )
-    >r >r normalize-path r> file-mode
+    [ [ normalize-path ] dip file-mode open-file ] dip redirect-fd ;
-    open-file r> redirect-fd ;
 
 : redirect-file-append ( obj mode fd -- )
-    >r drop path>> normalize-path open-append r> redirect-fd ;
+    [ drop path>> normalize-path open-append ] dip redirect-fd ;
 
 : redirect-closed ( obj mode fd -- )
-    >r >r drop "/dev/null" r> r> redirect-file ;
+    [ drop "/dev/null" ] 2dip redirect-file ;
 
 : redirect ( obj mode fd -- )
     {
@@ -55,8 +54,8 @@ USE: unix
         { [ pick string? ] [ redirect-file ] }
         { [ pick appender? ] [ redirect-file-append ] }
         { [ pick +closed+ eq? ] [ redirect-closed ] }
-        { [ pick fd? ] [ >r drop fd>> dup reset-fd r> redirect-fd ] }
+        { [ pick fd? ] [ [ drop fd>> dup reset-fd ] dip redirect-fd ] }
-        [ >r >r underlying-handle r> r> redirect ]
+        [ [ underlying-handle ] 2dip redirect ]
     } cond ;
 
 : ?closed ( obj -- obj' )

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

@@ -0,0 +1,11 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors io.sockets.secure kernel ;
+IN: io.unix.sockets.secure.debug
+
+: with-test-context ( quot -- )
+    <secure-config>
+        "resource:basis/openssl/test/server.pem" >>key-file
+        "resource:basis/openssl/test/dh1024.pem" >>dh-file
+        "password" >>password
+    swap with-secure-context ; inline

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

@@ -2,20 +2,14 @@ IN: io.sockets.secure.tests
 USING: accessors kernel namespaces io io.sockets
 io.sockets.secure io.encodings.ascii io.streams.duplex
 io.unix.backend classes words destructors threads tools.test
-concurrency.promises byte-arrays locals calendar io.timeouts ;
+concurrency.promises byte-arrays locals calendar io.timeouts
+io.unix.sockets.secure.debug ;
 
 \ <secure-config> must-infer
 { 1 0 } [ [ ] with-secure-context ] must-infer-as
 
 [ ] [ <promise> "port" set ] unit-test
 
-: with-test-context ( quot -- )
-    <secure-config>
-        "resource:basis/openssl/test/server.pem" >>key-file
-        "resource:basis/openssl/test/dh1024.pem" >>dh-file
-        "password" >>password
-    swap with-secure-context ; inline
-
 :: server-test ( quot -- )
     [
         [

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

@@ -3,10 +3,10 @@
 USING: accessors unix 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.ports
+openssl.libcrypto openssl.libssl io io.files io.ports
 io.unix.backend io.unix.sockets io.encodings.ascii io.buffers
 io.sockets io.sockets.secure io.sockets.secure.openssl
-io.timeouts system summary ;
+io.timeouts system summary fry ;
 IN: io.unix.sockets.secure
 
 M: ssl-handle handle-fd file>> handle-fd ;
@@ -18,9 +18,7 @@ M: ssl-handle handle-fd file>> handle-fd ;
             { -1 [ err_no ECONNRESET = [ premature-close ] [ (io-error) ] if ] }
             { 0 [ premature-close ] }
         } case
-    ] [
+    ] [ nip (ssl-error) ] if ;
-        nip (ssl-error)
-    ] if ;
 
 : check-accept-response ( handle r -- event )
     over handle>> over SSL_get_error
@@ -36,7 +34,7 @@ M: ssl-handle handle-fd file>> handle-fd ;
 
 : 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 ;
+    [ [ dup file>> ] dip wait-for-fd do-ssl-accept ] [ 2drop ] if ;
 
 : maybe-handshake ( ssl-handle -- )
     dup connected>> [ drop ] [
@@ -130,24 +128,23 @@ M: secure (get-local-address) addrspec>> (get-local-address) ;
     [ [ handle>> SSL_get1_session ] dip save-session ]
     2bi ;
 
-: secure-connection ( ssl-handle addrspec -- )
+: secure-connection ( client-out addrspec -- )
-    dup get-session [ resume-session ] [ begin-session ] ?if ;
+    [ 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>>
+    addrspec>> [ establish-connection ] [ secure-connection ] 2bi ;
-    [ establish-connection ]
-    [
-        [ handle>> ] dip
-        [ [ secure-connection ] curry with-timeout ]
-        [ drop t >>connected drop ]
-        2bi
-    ] 2bi ;
 
 M: secure (server) addrspec>> (server) ;
 
 M: secure (accept)
     [
-        addrspec>> (accept) >r |dispose <ssl-socket> r>
+        addrspec>> (accept) [ |dispose <ssl-socket> ] dip
     ] with-destructors ;
 
 : check-shutdown-response ( handle r -- event )
@@ -172,3 +169,32 @@ M: ssl-handle shutdown
     dup connected>> [
         f >>connected [ (shutdown) ] with-timeout
     ] [ drop ] if ;
+
+: check-buffer ( port -- port )
+    dup buffer>> buffer-empty? [ upgrade-buffers-full ] unless ;
+
+: input/output-ports ( -- input output )
+    input-stream output-stream
+    [ get underlying-port check-buffer ] bi@
+    2dup [ handle>> ] bi@ eq? [ upgrade-on-non-socket ] unless ;
+
+: make-input/output-secure ( input output -- )
+    dup handle>> fd? [ upgrade-on-non-socket ] unless
+    [ <ssl-socket> ] change-handle
+    handle>> >>handle drop ;
+
+: (send-secure-handshake) ( output -- )
+    remote-address get [ upgrade-on-non-socket ] unless*
+    secure-connection ;
+
+M: openssl send-secure-handshake
+    input/output-ports
+    [ make-input/output-secure ] keep
+    [ (send-secure-handshake) ] keep
+    remote-address get dup inet? [
+        host>> swap handle>> check-certificate
+    ] [ 2drop ] if ;
+
+M: openssl accept-secure-handshake
+    input/output-ports
+    make-input/output-secure ;