From 4ec8326917d39c6371b7b3b34e3fe7351bf7f5e0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Nov 2008 13:46:39 -0600 Subject: [PATCH] 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 | 85 ++++++++----------- basis/io/ports/ports.factor | 28 ++++-- basis/io/servers/connection/connection.factor | 2 - basis/io/sockets/secure/secure-docs.factor | 36 +++++++- basis/io/sockets/secure/secure.factor | 25 +++++- basis/io/sockets/sockets.factor | 31 ++++--- basis/io/streams/duplex/duplex.factor | 16 +++- basis/io/unix/launcher/launcher.factor | 11 ++- .../io/unix/sockets/secure/debug/debug.factor | 11 +++ .../unix/sockets/secure/secure-tests.factor | 10 +-- basis/io/unix/sockets/secure/secure.factor | 60 +++++++++---- 11 files changed, 202 insertions(+), 113 deletions(-) create mode 100644 basis/io/unix/sockets/secure/debug/debug.factor diff --git a/basis/io/launcher/launcher.factor b/basis/io/launcher/launcher.factor index bdccfc3f57..0ed10e63c3 100644 --- a/basis/io/launcher/launcher.factor +++ b/basis/io/launcher/launcher.factor @@ -183,16 +183,18 @@ M: object run-pipeline-element : ( desc encoding -- stream process ) [ - >r (pipe) { - [ |dispose drop ] - [ - swap >process - [ swap out>> or ] change-stdout - run-detached - ] - [ out>> dispose ] - [ in>> ] - } cleave r> swap + [ + (pipe) { + [ |dispose drop ] + [ + swap >process + [ swap out>> or ] change-stdout + run-detached + ] + [ out>> dispose ] + [ in>> ] + } cleave + ] dip swap ] with-destructors ; : ( desc encoding -- stream ) @@ -205,16 +207,18 @@ M: object run-pipeline-element : ( desc encoding -- stream process ) [ - >r (pipe) { - [ |dispose drop ] - [ - swap >process - [ swap in>> or ] change-stdin - run-detached - ] - [ in>> dispose ] - [ out>> ] - } cleave r> swap + [ + (pipe) { + [ |dispose drop ] + [ + swap >process + [ swap in>> or ] change-stdin + run-detached + ] + [ in>> dispose ] + [ out>> ] + } cleave + ] dip swap ] with-destructors ; : ( desc encoding -- stream ) @@ -227,17 +231,19 @@ M: object run-pipeline-element : ( desc encoding -- stream process ) [ - >r (pipe) (pipe) { - [ [ |dispose drop ] bi@ ] - [ - rot >process - [ swap in>> or ] change-stdin - [ swap out>> or ] change-stdout - run-detached - ] - [ [ out>> dispose ] [ in>> dispose ] bi* ] - [ [ in>> ] [ out>> ] bi* ] - } 2cleave r> swap + [ + (pipe) (pipe) { + [ [ |dispose drop ] bi@ ] + [ + rot >process + [ swap in>> or ] change-stdin + [ swap out>> or ] change-stdout + run-detached + ] + [ [ out>> dispose ] [ in>> dispose ] bi* ] + [ [ in>> ] [ out>> ] bi* ] + } 2cleave + ] dip swap ] with-destructors ; : ( 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 ] } diff --git a/basis/io/ports/ports.factor b/basis/io/ports/ports.factor index 9fb9755d4b..0432fe4a39 100644 --- a/basis/io/ports/ports.factor +++ b/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 @@ -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 [ - >r 3drop r> + [ over push-all ] dip dup [ + [ 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 ; diff --git a/basis/io/servers/connection/connection.factor b/basis/io/servers/connection/connection.factor index 942bdb041d..6c7ff7e0f1 100644 --- a/basis/io/servers/connection/connection.factor +++ b/basis/io/servers/connection/connection.factor @@ -39,8 +39,6 @@ ready ; : ( -- threaded-server ) threaded-server new-threaded-server ; -SYMBOL: remote-address - GENERIC: handle-client* ( threaded-server -- ) } "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" diff --git a/basis/io/sockets/secure/secure.factor b/basis/io/sockets/secure/secure.factor index 42ca727653..e752e7c328 100644 --- a/basis/io/sockets/secure/secure.factor +++ b/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 -system vocabs.loader combinators present ; +destructors io debugger io.sockets sequences summary calendar +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 -- ) -> inet? ; +r dup sockaddr-in-addr r> inet-ntop + [ dup sockaddr-in-addr ] dip inet-ntop swap sockaddr-in-port ntohs ; 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 ; : addrspec-of-family ( af -- addrspec ) @@ -184,7 +184,7 @@ M: object (client) ( remote -- client-in client-out local ) [ [ ((client)) ] keep [ - >r [ |dispose ] bi@ dup r> + [ [ |dispose ] bi@ dup ] dip establish-connection ] [ get-local-address ] @@ -192,13 +192,19 @@ M: object (client) ( remote -- client-in client-out local ) ] with-destructors ; : ( remote encoding -- stream local ) - >r (client) -rot r> swap ; + [ (client) -rot ] dip swap ; SYMBOL: local-address +SYMBOL: remote-address + : with-client ( remote encoding quot -- ) - >r [ local-address set ] curry - r> compose with-stream ; inline + [ + [ + over remote-address set + 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 ) : ( addrspec encoding -- server ) - >r - [ (server) ] keep - [ drop server-port ] [ get-local-address ] 2bi - >>addr r> >>encoding ; + [ + [ (server) ] keep + [ drop server-port ] [ get-local-address ] 2bi + >>addr + ] dip >>encoding ; GENERIC: (accept) ( server addrspec -- handle sockaddr ) @@ -281,7 +288,7 @@ C: 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 [ diff --git a/basis/io/streams/duplex/duplex.factor b/basis/io/streams/duplex/duplex.factor index 6f3be15016..2ba504c653 100644 --- a/basis/io/streams/duplex/duplex.factor +++ b/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 -accessors delegate delegate.protocols ; +io.encodings.private io.timeouts io.ports debugger summary +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> ; : 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 ; + diff --git a/basis/io/unix/launcher/launcher.factor b/basis/io/unix/launcher/launcher.factor index 421e12a92f..7a1cac3ff1 100644 --- a/basis/io/unix/launcher/launcher.factor +++ b/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 - open-file r> redirect-fd ; + [ [ normalize-path ] dip file-mode open-file ] dip 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 ] } - [ >r >r underlying-handle r> r> redirect ] + { [ pick fd? ] [ [ drop fd>> dup reset-fd ] dip redirect-fd ] } + [ [ underlying-handle ] 2dip redirect ] } cond ; : ?closed ( obj -- obj' ) diff --git a/basis/io/unix/sockets/secure/debug/debug.factor b/basis/io/unix/sockets/secure/debug/debug.factor new file mode 100644 index 0000000000..cd5353ea7b --- /dev/null +++ b/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 -- ) + + "resource:basis/openssl/test/server.pem" >>key-file + "resource:basis/openssl/test/dh1024.pem" >>dh-file + "password" >>password + swap with-secure-context ; inline diff --git a/basis/io/unix/sockets/secure/secure-tests.factor b/basis/io/unix/sockets/secure/secure-tests.factor index d2a1649686..0816dd270b 100644 --- a/basis/io/unix/sockets/secure/secure-tests.factor +++ b/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 ; \ must-infer { 1 0 } [ [ ] with-secure-context ] must-infer-as [ ] [ "port" set ] unit-test -: with-test-context ( quot -- ) - - "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 -- ) [ [ diff --git a/basis/io/unix/sockets/secure/secure.factor b/basis/io/unix/sockets/secure/secure.factor index fb5ed93978..a096380b74 100644 --- a/basis/io/unix/sockets/secure/secure.factor +++ b/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 -- ) - dup get-session [ resume-session ] [ begin-session ] ?if ; +: 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 ] - [ - [ handle>> ] dip - [ [ secure-connection ] curry with-timeout ] - [ drop t >>connected drop ] - 2bi - ] 2bi ; + addrspec>> [ establish-connection ] [ secure-connection ] 2bi ; M: secure (server) addrspec>> (server) ; M: secure (accept) [ - addrspec>> (accept) >r |dispose r> + addrspec>> (accept) [ |dispose ] 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 + [ ] 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 ;