steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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
db4
Slava Pestov 2008-11-30 13:46:39 -06:00
parent f55c5d1bd0
commit 4ec8326917
11 changed files with 202 additions and 113 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

85
basis/io/launcher/launcher.factor
View File

@ -183,16 +183,18 @@ M: object run-pipeline-element
: <process-reader*> ( desc encoding -- stream process )
[
>r (pipe) {
[ |dispose drop ]
[
swap >process
[ swap out>> or ] change-stdout
run-detached
]
[ out>> dispose ]
[ in>> <input-port> ]
} cleave r> <decoder> swap
[
(pipe) {
[ |dispose drop ]
[
swap >process
[ swap out>> or ] change-stdout
run-detached
]
[ out>> dispose ]
[ 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 ]
[
swap >process
[ swap in>> or ] change-stdin
run-detached
]
[ in>> dispose ]
[ out>> <output-port> ]
} cleave r> <encoder> swap
[
(pipe) {
[ |dispose drop ]
[
swap >process
[ swap in>> or ] change-stdin
run-detached
]
[ in>> dispose ]
[ 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@ ]
[
rot >process
[ swap in>> or ] change-stdin
[ swap out>> or ] change-stdout
run-detached
]
[ [ out>> dispose ] [ in>> dispose ] bi* ]
[ [ in>> <input-port> ] [ out>> <output-port> ] bi* ]
} 2cleave r> <encoder-duplex> 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>> <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 ] }

28
basis/io/ports/ports.factor
View File

@ -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 [
>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 ;

2
basis/io/servers/connection/connection.factor
View File

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

36
basis/io/sockets/secure/secure-docs.factor
View File

@ -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"

25
basis/io/sockets/secure/secure.factor
View File

@ -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 -- )
<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 ] }

31
basis/io/sockets/sockets.factor
View File

@ -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
[ drop server-port <port> ] [ get-local-address ] 2bi
>>addr r> >>encoding ;
[
[ (server) ] keep
[ drop server-port <port> ] [ get-local-address ] 2bi
>>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 [

16
basis/io/streams/duplex/duplex.factor
View File

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

11
basis/io/unix/launcher/launcher.factor
View File

@ -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' )

11
basis/io/unix/sockets/secure/debug/debug.factor Normal file
View File

@ -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

10
basis/io/unix/sockets/secure/secure-tests.factor
View File

@ -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 -- )
[
[

60
basis/io/unix/sockets/secure/secure.factor
View File

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