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

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.
db4
Björn Lindqvist 2013-10-17 18:14:50 +02:00 committed by Doug Coleman
parent 57a933e330
commit 6421af3401
3 changed files with 139 additions and 234 deletions
basis/io/sockets/secure

147
basis/io/sockets/secure/openssl/openssl.factor
View File

@ -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
io.backend io.encodings.8-bit.latin1 io.encodings.utf8
io.pathnames io.sockets.secure kernel libc locals math
math.order math.parser namespaces openssl openssl.libcrypto
openssl.libssl random sequences splitting unicode.case
io.files ;
assocs byte-arrays classes.struct combinators destructors fry
io.backend io.buffers io.encodings.8-bit.latin1 io.encodings.utf8
io.files io.pathnames io.sockets.secure io.timeouts kernel libc
locals math math.order math.parser namespaces openssl openssl.libssl
openssl.libcrypto random sequences splitting unicode.case ;
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

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

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

108
basis/io/sockets/secure/windows/windows.factor
View File

@ -1,76 +1,19 @@
USING:
accessors
alien alien.c-types alien.data
combinators
fry
io.buffers
io.files
alien
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