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 connectionsdb4
parent
f55c5d1bd0
commit
4ec8326917
|
@ -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 ] }
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -39,8 +39,6 @@ ready ;
|
|||
: <threaded-server> ( -- threaded-server )
|
||||
threaded-server new-threaded-server ;
|
||||
|
||||
SYMBOL: remote-address
|
||||
|
||||
GENERIC: handle-client* ( threaded-server -- )
|
||||
|
||||
<PRIVATE
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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 ] }
|
||||
|
|
|
@ -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 [
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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' )
|
||||
|
|
|
@ -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
|
|
@ -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 -- )
|
||||
[
|
||||
[
|
||||
|
|
|
@ -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 ;
|
||||
|
|
Loading…
Reference in New Issue