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

Working on SSL server sockets

db4
Slava Pestov 2008-05-14 03:55:33 -05:00
parent 1a835ba2da
commit 8f96e40c1c
11 changed files with 140 additions and 82 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
extra/io/launcher/launcher.factor
View File

@ -199,7 +199,7 @@ M: object run-pipeline-element
[ swap in>> or ] change-stdin
run-detached
]
[ [ in>> close-handle ] [ out>> close-handle ] bi* ]
[ [ out>> close-handle ] [ in>> close-handle ] bi* ]
[ [ in>> <input-port> ] [ out>> <output-port> ] bi* ]
} 2cleave r> <encoder-duplex>
] with-destructors ;

4
extra/io/sockets/sockets.factor
View File

@ -195,11 +195,11 @@ GENERIC: (server) ( addrspec -- handle sockaddr )
swap >>addr
r> >>encoding ;
HOOK: (accept) io-backend ( server -- handle remote )
GENERIC: (accept) ( server addrspec -- handle remote )
: accept ( server -- client remote )
check-server-port
[ (accept) ] keep
[ dup addr>> (accept) ] keep
tuck
[ [ dup <ports> ] [ encoding>> ] bi* <encoder-duplex> ]
[ addr>> parse-sockaddr ]

53
extra/io/unix/backend/backend.factor
View File

@ -11,7 +11,15 @@ IN: io.unix.backend
! I/O tasks
GENERIC: handle-fd ( handle -- fd )
M: integer handle-fd ;
TUPLE: fd fd closed ;
: <fd> ( n -- fd ) f fd boa ;
M: fd dispose
dup closed>>
[ drop ] [ t >>closed fd>> close-file ] if ;
M: fd handle-fd fd>> ;
! I/O multiplexers
TUPLE: mx fd reads writes ;
@ -66,21 +74,23 @@ SYMBOL: +retry+ ! just try the operation again without blocking
SYMBOL: +input+
SYMBOL: +output+
: wait-for-port ( port event -- )
: wait-for-fd ( handle event -- )
dup +retry+ eq? [ 2drop ] [
[
[
>r
swap handle>> handle-fd
mx get-global
r> {
{ +input+ [ add-input-callback ] }
{ +output+ [ add-output-callback ] }
} case
] curry "I/O" suspend drop
] curry with-timeout pending-error
>r
swap handle-fd
mx get-global
r> {
{ +input+ [ add-input-callback ] }
{ +output+ [ add-output-callback ] }
} case
] curry "I/O" suspend 2drop
] if ;
: wait-for-port ( port event -- )
[ >r dup handle>> r> wait-for-fd ] curry
with-timeout pending-error ;
! Some general stuff
: file-mode OCT: 0666 ;
@ -93,15 +103,16 @@ SYMBOL: +output+
: io-error ( n -- ) 0 < [ (io-error) ] when ;
M: integer init-handle ( fd -- )
M: fd init-handle ( fd -- )
#! We drop the error code rather than calling io-error,
#! since on OS X 10.3, this operation fails from init-io
#! when running the Factor.app (presumably because fd 0 and
#! 1 are closed).
fd>>
[ F_SETFL O_NONBLOCK fcntl drop ]
[ F_SETFD FD_CLOEXEC fcntl drop ] bi ;
M: integer close-handle ( fd -- ) close-file ;
M: fd close-handle ( fd -- ) dispose ;
! Readers
: eof ( reader -- )
@ -116,8 +127,8 @@ M: integer close-handle ( fd -- ) close-file ;
! this request
GENERIC: refill ( port handle -- event/f )
M: integer refill
over buffer>> [ buffer-end ] [ buffer-capacity ] bi read
M: fd refill
fd>> over buffer>> [ buffer-end ] [ buffer-capacity ] bi read
{
{ [ dup 0 = ] [ drop eof f ] }
{ [ dup 0 > ] [ swap buffer>> n>buffer f ] }
@ -133,8 +144,8 @@ M: unix (wait-to-read) ( port -- )
! Writers
GENERIC: drain ( port handle -- event/f )
M: integer drain
over buffer>> [ buffer@ ] [ buffer-length ] bi write
M: fd drain
fd>> over buffer>> [ buffer@ ] [ buffer-length ] bi write
{
{ [ dup 0 >= ] [
over buffer>> buffer-consume
@ -153,9 +164,9 @@ M: unix io-multiplex ( ms/f -- )
mx get-global wait-for-events ;
M: unix (init-stdio) ( -- )
0 <input-port>
1 <output-port>
2 <output-port> ;
0 <fd> <input-port>
1 <fd> <output-port>
2 <fd> <output-port> ;
! mx io-task for embedding an fd-based mx inside another mx
TUPLE: mx-port < port mx ;

19
extra/io/unix/files/files.factor
View File

@ -4,12 +4,12 @@ USING: io.backend io.ports io.unix.backend io.files io
unix unix.stat unix.time kernel math continuations
math.bitfields byte-arrays alien combinators calendar
io.encodings.binary accessors sequences strings system
io.files.private ;
io.files.private destructors ;
IN: io.unix.files
M: unix cwd ( -- path )
MAXPATHLEN [ <byte-array> ] [ ] bi getcwd
MAXPATHLEN [ <byte-array> ] keep getcwd
[ (io-error) ] unless* ;
M: unix cd ( path -- ) [ chdir ] unix-system-call drop ;
@ -19,23 +19,26 @@ M: unix cd ( path -- ) [ chdir ] unix-system-call drop ;
: open-read ( path -- fd ) O_RDONLY file-mode open-file ;
M: unix (file-reader) ( path -- stream )
open-read <input-port> ;
open-read <fd> <input-port> ;
: write-flags { O_WRONLY O_CREAT O_TRUNC } flags ; inline
: open-write ( path -- fd ) write-flags file-mode open-file ;
: open-write ( path -- fd )
write-flags file-mode open-file ;
M: unix (file-writer) ( path -- stream )
open-write <output-port> ;
open-write <fd> <output-port> ;
: append-flags { O_WRONLY O_APPEND O_CREAT } flags ; inline
: open-append ( path -- fd )
append-flags file-mode open-file
[ dup 0 SEEK_END lseek io-error ] [ ] [ close-file ] cleanup ;
[
append-flags file-mode open-file dup close-later
dup 0 SEEK_END lseek io-error
] with-destructors ;
M: unix (file-appender) ( path -- stream )
open-append <output-port> ;
open-append <fd> <output-port> ;
: touch-mode ( -- n )
{ O_WRONLY O_APPEND O_CREAT O_EXCL } flags ; foldable

2
extra/io/unix/launcher/launcher-tests.factor
View File

@ -110,3 +110,5 @@ accessors kernel sequences io.encodings.utf8 ;
] times
"append-test" temp-file utf8 file-contents
] unit-test
[ ] [ "ls" utf8 <process-stream> contents drop ] unit-test

2
extra/io/unix/launcher/launcher.factor
View File

@ -58,7 +58,7 @@ USE: unix
{ [ pick string? ] [ redirect-file ] }
{ [ pick appender? ] [ redirect-file-append ] }
{ [ pick +closed+ eq? ] [ redirect-closed ] }
{ [ pick integer? ] [ >r drop dup reset-fd r> redirect-fd ] }
{ [ pick fd? ] [ >r drop fd>> dup reset-fd r> redirect-fd ] }
[ >r >r underlying-handle r> r> redirect ]
} cond ;

2
extra/io/unix/pipes/pipes.factor
View File

@ -8,5 +8,5 @@ QUALIFIED: io.pipes
M: unix io.pipes:(pipe) ( -- pair )
2 "int" <c-array>
dup pipe io-error
2 c-int-array> first2
2 c-int-array> first2 [ <fd> ] bi@
[ [ init-handle ] bi@ ] [ io.pipes:pipe boa ] 2bi ;

68
extra/io/unix/sockets/secure/secure.factor
View File

@ -6,17 +6,16 @@ continuations destructors
openssl openssl.libcrypto openssl.libssl
io.files io.ports io.unix.backend io.unix.sockets
io.encodings.ascii io.buffers io.sockets io.sockets.secure
unix ;
unix system ;
IN: io.unix.sockets.secure
! todo: SSL_pending, rehandshake
! do we call write twice, wth 0 bytes at the end?
! check-certificate at some point
! test on windows
M: ssl-handle handle-fd file>> ;
M: ssl-handle handle-fd file>> handle-fd ;
: syscall-error ( port r -- * )
: syscall-error ( r -- * )
ERR_get_error dup zero? [
drop
{
@ -70,10 +69,14 @@ M: ssl-handle drain
check-write-response ;
! Client sockets
M: ssl ((client)) ( addrspec -- handle )
[ addrspec>> ((client)) <ssl-socket> ] with-destructors ;
: <ssl-socket> ( fd -- ssl )
[ fd>> BIO_NOCLOSE BIO_new_socket dup ssl-error ] keep <ssl-handle>
[ handle>> swap dup SSL_set_bio ] keep ;
M: ssl parse-sockaddr addrspec>> parse-sockaddr ;
M: ssl ((client)) ( addrspec -- handle )
addrspec>> ((client)) <ssl-socket> ;
M: ssl parse-sockaddr addrspec>> parse-sockaddr <ssl> ;
: check-connect-response ( port r -- event )
check-response
@ -85,13 +88,54 @@ M: ssl parse-sockaddr addrspec>> parse-sockaddr ;
{ SSL_ERROR_SSL [ (ssl-error) ] }
} case ;
: do-ssl-connect ( port ssl addrspec -- )
drop
: do-ssl-connect ( port ssl-handle -- )
2dup SSL_connect check-connect-response dup
[ nip wait-for-port ] [ 3drop ] if ;
[ >r over r> wait-for-port do-ssl-connect ] [ 3drop ] if ;
M: ssl-handle (wait-to-connect)
addrspec>>
[ >r file>> r> (wait-to-connect) ]
[ >r handle>> r> do-ssl-connect ]
3bi ;
[ drop handle>> do-ssl-connect ]
[ drop t >>connected 2drop ]
3tri ;
M: ssl (server) addrspec>> (server) ;
: 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_WRITE [ 2drop +output+ ] }
{ SSL_ERROR_SYSCALL [ syscall-error ] }
{ SSL_ERROR_SSL [ (ssl-error) ] }
} case ;
: 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 ;
M: ssl (accept)
[
addrspec>>
(accept) >r
dup close-later
<ssl-socket> dup close-later
dup do-ssl-accept
r>
] with-destructors ;
: check-shutdown-response ( handle r -- event )
>r handle>> r> SSL_get_error
{
{ SSL_ERROR_WANT_READ [ +input+ ] }
{ SSL_ERROR_WANT_WRITE [ +output+ ] }
{ SSL_ERROR_SYSCALL [ -1 syscall-error ] }
{ SSL_ERROR_SSL [ (ssl-error) ] }
} case ;
M: unix ssl-shutdown
dup connected>> [
dup dup handle>> SSL_shutdown check-shutdown-response
dup [ dupd wait-for-fd ssl-shutdown ] [ 2drop ] if
] [ drop ] if ;

49
extra/io/unix/sockets/sockets.factor
View File

@ -12,69 +12,68 @@ EXCLUDE: io.sockets => accept ;
IN: io.unix.sockets
: socket-fd ( domain type -- socket )
0 socket
dup io-error
dup close-later
dup init-handle ;
: socket-fd ( domain type -- fd )
0 socket dup io-error <fd> [ close-later ] [ init-handle ] [ ] tri ;
: sockopt ( fd level opt -- )
1 <int> "int" heap-size setsockopt io-error ;
: set-socket-option ( fd level opt -- )
>r >r handle-fd r> r> 1 <int> "int" heap-size setsockopt io-error ;
M: unix addrinfo-error ( n -- )
dup zero? [ drop ] [ gai_strerror throw ] if ;
! Client sockets - TCP and Unix domain
: init-client-socket ( fd -- )
SOL_SOCKET SO_OOBINLINE sockopt ;
SOL_SOCKET SO_OOBINLINE set-socket-option ;
: get-socket-name ( fd addrspec -- sockaddr )
empty-sockaddr/size [ getsockname io-error ] 2keep drop ;
>r handle-fd r> empty-sockaddr/size
[ getsockname io-error ] 2keep drop ;
: get-peer-name ( fd addrspec -- sockaddr )
empty-sockaddr/size [ getpeername io-error ] 2keep drop ;
>r handle-fd r> empty-sockaddr/size
[ getpeername io-error ] 2keep drop ;
M: integer (wait-to-connect)
M: fd (wait-to-connect)
>r >r +output+ wait-for-port r> r> get-socket-name ;
M: object ((client)) ( addrspec -- fd )
[ protocol-family SOCK_STREAM socket-fd ] [ make-sockaddr/size ] bi
[ 2drop ] [ connect ] 3bi
zero? err_no EINPROGRESS = or
>r >r dup handle-fd r> r> connect zero? err_no EINPROGRESS = or
[ dup init-client-socket ] [ (io-error) ] if ;
! Server sockets - TCP and Unix domain
: init-server-socket ( fd -- )
SOL_SOCKET SO_REUSEADDR sockopt ;
SOL_SOCKET SO_REUSEADDR set-socket-option ;
: server-socket-fd ( addrspec type -- fd )
>r dup protocol-family r> socket-fd
dup init-server-socket
dup rot make-sockaddr/size bind io-error ;
dup handle-fd rot make-sockaddr/size bind io-error ;
M: object (server) ( addrspec -- handle sockaddr )
[
[
SOCK_STREAM server-socket-fd
dup 10 listen io-error
dup handle-fd 10 listen io-error
dup
] keep
get-socket-name
] with-destructors ;
: do-accept ( server -- fd remote )
[ handle>> ] [ addr>> empty-sockaddr/size ] bi
: do-accept ( server addrspec -- fd remote )
[ handle>> handle-fd ] [ empty-sockaddr/size ] bi*
[ accept ] 2keep drop ; inline
M: unix (accept) ( server -- fd remote )
dup do-accept
M: object (accept) ( server addrspec -- fd remote )
2dup do-accept
{
{ [ over 0 >= ] [ rot drop ] }
{ [ over 0 >= ] [ { [ drop ] [ drop ] [ <fd> ] [ ] } spread ] }
{ [ err_no EINTR = ] [ 2drop (accept) ] }
{ [ err_no EAGAIN = ] [
2drop
[ +input+ wait-for-port ]
[ (accept) ] bi
[ drop +input+ wait-for-port ]
[ (accept) ]
2bi
] }
[ (io-error) ]
} cond ;
@ -91,7 +90,7 @@ packet-size <byte-array> receive-buffer set-global
:: do-receive ( port -- packet sockaddr )
port addr>> empty-sockaddr/size [| sockaddr len |
port handle>> ! s
port handle>> handle-fd ! s
receive-buffer get-global ! buf
packet-size ! nbytes
0 ! flags
@ -110,7 +109,7 @@ M: unix (receive) ( datagram -- packet sockaddr )
] if ;
:: do-send ( packet sockaddr len socket datagram -- )
socket packet dup length 0 sockaddr len sendto
socket handle-fd packet dup length 0 sockaddr len sendto
0 < [
err_no EINTR = [
packet sockaddr len socket datagram do-send

2
extra/openssl/libssl/libssl.factor
View File

@ -118,7 +118,7 @@ FUNCTION: int SSL_write ( ssl-pointer ssl, void* buf, int num ) ;
FUNCTION: int SSL_read ( ssl-pointer ssl, void* buf, int num ) ;
FUNCTION: void SSL_shutdown ( ssl-pointer ssl ) ;
FUNCTION: int SSL_shutdown ( ssl-pointer ssl ) ;
FUNCTION: void SSL_free ( ssl-pointer ssl ) ;

19
extra/openssl/openssl.factor
View File

@ -5,7 +5,7 @@ math.order combinators init alien alien.c-types alien.strings libc
continuations destructors debugger inspector
locals unicode.case
openssl.libcrypto openssl.libssl
io.ports io.files io.encodings.ascii io.sockets.secure ;
io.backend io.ports io.files io.encodings.ascii io.sockets.secure ;
IN: openssl
! This code is based on http://www.rtfm.com/openssl-examples/
@ -120,7 +120,7 @@ M: openssl-context dispose
dup handle>> [ SSL_CTX_free ] when* f >>handle
drop ;
TUPLE: ssl-handle file handle disposed ;
TUPLE: ssl-handle file handle connected disposed ;
ERROR: no-ssl-context ;
@ -132,20 +132,19 @@ M: no-ssl-context summary
: <ssl-handle> ( fd -- ssl )
current-ssl-context handle>> SSL_new dup ssl-error
f ssl-handle boa ;
f f ssl-handle boa ;
: <ssl-socket> ( fd -- ssl )
[ BIO_NOCLOSE BIO_new_socket dup ssl-error ] keep
<ssl-handle>
[ handle>> swap dup SSL_set_bio ] keep ;
M: ssl-handle init-handle file>> init-handle ;
M: ssl-handle init-handle drop ;
HOOK: ssl-shutdown io-backend ( handle -- )
M: ssl-handle close-handle
dup disposed>> [ drop ] [
[ t >>disposed drop ]
t >>disposed
[ ssl-shutdown ]
[ handle>> SSL_free ]
[ file>> close-handle ]
[ handle>> SSL_free ] tri
tri
] if ;
ERROR: certificate-verify-error result ;