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

Working on SSL and refactoring related code to make things easier to plug in

db4
Slava Pestov 2008-05-12 18:53:22 -05:00
parent 195fd87e8f
commit 1260c1ba51
28 changed files with 301 additions and 161 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
core/alien/c-types/c-types.factor
View File

@ -382,4 +382,6 @@ M: long-long-type box-return ( type -- )
"double" define-primitive-type
os winnt? cpu x86.64? and "longlong" "long" ? "ptrdiff_t" typedef
"ulong" "size_t" typedef
] with-compilation-unit

12
core/continuations/continuations.factor
View File

@ -139,10 +139,16 @@ SYMBOL: thread-error-hook
over >r compose [ dip rethrow ] curry
recover r> call ; inline
ERROR: attempt-all-error ;
: attempt-all ( seq quot -- obj )
[
[ [ , f ] compose [ , drop t ] recover ] curry all?
] { } make peek swap [ rethrow ] when ; inline
over empty? [
attempt-all-error
] [
[
[ [ , f ] compose [ , drop t ] recover ] curry all?
] { } make peek swap [ rethrow ] when
] if ; inline
GENERIC: dispose ( object -- )

2
core/debugger/debugger.factor
View File

@ -298,6 +298,8 @@ M: immutable-slot summary drop "Slot is immutable" ;
M: bad-create summary drop "Bad parameters to create" ;
M: attempt-all-error summary drop "Nothing to attempt" ;
<PRIVATE
: init-debugger ( -- )

1
extra/db/postgresql/ffi/ffi.factor
View File

@ -52,7 +52,6 @@ IN: db.postgresql.ffi
: InvalidOid 0 ; inline
TYPEDEF: int size_t
TYPEDEF: int ConnStatusType
TYPEDEF: int ExecStatusType
TYPEDEF: int PostgresPollingStatusType

48
extra/destructors/destructors.factor
View File

@ -1,30 +1,17 @@
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: continuations io.backend io.nonblocking libc kernel
namespaces sequences system vectors ;
USING: accessors continuations io.backend io.nonblocking libc
kernel namespaces sequences system vectors ;
IN: destructors
SYMBOL: error-destructors
SYMBOL: always-destructors
TUPLE: destructor object destroyed? ;
M: destructor dispose
dup destructor-destroyed? [
drop
] [
dup destructor-object dispose
t swap set-destructor-destroyed?
] if ;
: <destructor> ( obj -- newobj )
f destructor boa ;
: add-error-destructor ( obj -- )
<destructor> error-destructors get push ;
error-destructors get push ;
: add-always-destructor ( obj -- )
<destructor> always-destructors get push ;
always-destructors get push ;
: do-always-destructors ( -- )
always-destructors get <reversed> dispose-each ;
@ -40,19 +27,28 @@ M: destructor dispose
[ do-error-destructors ] cleanup
] with-scope ; inline
TUPLE: only-once object destroyed ;
M: only-once dispose
dup destroyed>> [ drop ] [
[ object>> dispose ] [ t >>destroyed drop ] bi
] if ;
: <only-once> f only-once boa ;
! Memory allocations
TUPLE: memory-destructor alien ;
C: <memory-destructor> memory-destructor
M: memory-destructor dispose ( obj -- )
memory-destructor-alien free ;
alien>> free ;
: free-always ( alien -- )
<memory-destructor> add-always-destructor ;
<memory-destructor> <only-once> add-always-destructor ;
: free-later ( alien -- )
<memory-destructor> add-error-destructor ;
<memory-destructor> <only-once> add-error-destructor ;
! Handles
TUPLE: handle-destructor alien ;
@ -60,13 +56,13 @@ TUPLE: handle-destructor alien ;
C: <handle-destructor> handle-destructor
M: handle-destructor dispose ( obj -- )
handle-destructor-alien close-handle ;
alien>> close-handle ;
: close-always ( handle -- )
<handle-destructor> add-always-destructor ;
<handle-destructor> <only-once> add-always-destructor ;
: close-later ( handle -- )
<handle-destructor> add-error-destructor ;
<handle-destructor> <only-once> add-error-destructor ;
! Sockets
TUPLE: socket-destructor alien ;
@ -76,10 +72,10 @@ C: <socket-destructor> socket-destructor
HOOK: destruct-socket io-backend ( obj -- )
M: socket-destructor dispose ( obj -- )
socket-destructor-alien destruct-socket ;
alien>> destruct-socket ;
: close-socket-always ( handle -- )
<socket-destructor> add-always-destructor ;
<socket-destructor> <only-once> add-always-destructor ;
: close-socket-later ( handle -- )
<socket-destructor> add-error-destructor ;
<socket-destructor> <only-once> add-error-destructor ;

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

@ -165,7 +165,7 @@ M: object run-pipeline-element
run-detached
]
[ out>> close-handle ]
[ in>> <reader> ]
[ in>> <input-port> ]
} cleave r> <decoder>
] with-destructors ;
@ -182,7 +182,7 @@ M: object run-pipeline-element
run-detached
]
[ in>> close-handle ]
[ out>> <writer> ]
[ out>> <output-port> ]
} cleave r> <encoder>
] with-destructors ;
@ -200,7 +200,7 @@ M: object run-pipeline-element
run-detached
]
[ [ in>> close-handle ] [ out>> close-handle ] bi* ]
[ [ in>> <reader> ] [ out>> <writer> ] bi* ]
[ [ in>> <input-port> ] [ out>> <output-port> ] bi* ]
} 2cleave r> <encoder-duplex>
] with-destructors ;

8
extra/io/nonblocking/nonblocking-docs.factor
View File

@ -11,10 +11,10 @@ $nl
{ $subsection <buffered-port> }
"Input ports:"
{ $subsection input-port }
{ $subsection <reader> }
{ $subsection <input-port> }
"Output ports:"
{ $subsection output-port }
{ $subsection <writer> }
{ $subsection <output-port> }
"Global native I/O protocol:"
{ $subsection io-backend }
{ $subsection init-io }
@ -62,12 +62,12 @@ HELP: <buffered-port>
{ $description "Creates a new " { $link port } " using the specified native handle and a default-sized I/O buffer." }
$low-level-note ;
HELP: <reader>
HELP: <input-port>
{ $values { "handle" "a native handle identifying an I/O resource" } { "input-port" "a new " { $link input-port } } }
{ $description "Creates a new " { $link input-port } " using the specified native handle and a default-sized input buffer." }
$low-level-note ;
HELP: <writer>
HELP: <output-port>
{ $values { "handle" "a native handle identifying an I/O resource" } { "output-port" "a new " { $link output-port } } }
{ $description "Creates a new " { $link output-port } " using the specified native handle and a default-sized input buffer." }
$low-level-note ;

14
extra/io/nonblocking/nonblocking.factor
View File

@ -3,7 +3,8 @@
USING: math kernel io sequences io.buffers io.timeouts generic
byte-vectors system io.encodings math.order io.backend
continuations debugger classes byte-arrays namespaces splitting
dlists assocs io.encodings.binary inspector accessors ;
dlists assocs io.encodings.binary inspector accessors
destructors ;
IN: io.nonblocking
SYMBOL: default-buffer-size
@ -29,16 +30,19 @@ GENERIC: close-handle ( handle -- )
TUPLE: input-port < port ;
: <reader> ( handle -- input-port )
: <input-port> ( handle -- input-port )
input-port <buffered-port> ;
TUPLE: output-port < port ;
: <writer> ( handle -- output-port )
: <output-port> ( handle -- output-port )
output-port <buffered-port> ;
: <reader&writer> ( read-handle write-handle -- input-port output-port )
swap <reader> [ swap <writer> ] [ ] [ dispose drop ] cleanup ;
: <ports> ( read-handle write-handle -- input-port output-port )
[
[ <input-port> dup add-error-destructor ]
[ <output-port> dup add-error-destructor ] bi*
] with-destructors ;
: pending-error ( port -- )
[ f ] change-error drop [ throw ] when* ;

8
extra/io/pipes/pipes.factor
View File

@ -17,16 +17,16 @@ HOOK: (pipe) io-backend ( -- pipe )
[
>r (pipe)
[ add-error-destructor ]
[ in>> <reader> ]
[ out>> <writer> ]
[ in>> <input-port> ]
[ out>> <output-port> ]
tri
r> <encoder-duplex>
] with-destructors ;
<PRIVATE
: ?reader [ <reader> dup add-always-destructor ] [ input-stream get ] if* ;
: ?writer [ <writer> dup add-always-destructor ] [ output-stream get ] if* ;
: ?reader [ <input-port> dup add-always-destructor ] [ input-stream get ] if* ;
: ?writer [ <output-port> dup add-always-destructor ] [ output-stream get ] if* ;
GENERIC: run-pipeline-element ( input-fd output-fd obj -- quot )

16
extra/io/sockets/secure/secure.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel symbols namespaces continuations ;
USING: accessors kernel symbols namespaces continuations
io.sockets sequences ;
IN: io.sockets.secure
SYMBOL: ssl-backend
@ -22,3 +23,16 @@ HOOK: <ssl-context> ssl-backend ( config -- context )
[ <ssl-context> ] [ [ ssl-context set ] prepose ] bi*
with-disposal
] with-scope ; inline
TUPLE: ssl addrspec ;
C: <ssl> ssl
<PRIVATE
PREDICATE: ssl-inet < ssl addrspec>> inet? ;
M: ssl-inet (client)
addrspec>> resolve-client-addr [ <ssl> ] map (client) ;
PRIVATE>

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

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: generic kernel io.backend namespaces continuations
sequences arrays io.encodings io.nonblocking io.streams.duplex
accessors ;
accessors destructors ;
IN: io.sockets
TUPLE: local path ;
@ -22,11 +22,21 @@ TUPLE: inet host port ;
C: <inet> inet
HOOK: ((client)) io-backend ( addrspec -- client-in client-out )
GENERIC: wait-to-connect ( client-out handle -- )
GENERIC: ((client)) ( addrspec -- handle )
GENERIC: (client) ( addrspec -- client-in client-out )
M: array (client) [ ((client)) 2array ] attempt-all first2 ;
M: object (client) ((client)) ;
M: array (client) [ (client) 2array ] attempt-all first2 ;
M: object (client)
[
((client))
dup <ports>
2dup [ add-error-destructor ] bi@
dup dup handle>> wait-to-connect
] with-destructors ;
: <client> ( addrspec encoding -- stream )
>r (client) r> <encoder-duplex> ;
@ -42,7 +52,7 @@ HOOK: (server) io-backend ( addrspec -- handle )
HOOK: (accept) io-backend ( server -- addrspec handle )
: accept ( server -- client addrspec )
[ (accept) dup <reader&writer> ] [ encoding>> ] bi
[ (accept) dup <ports> ] [ encoding>> ] bi
<encoder-duplex> swap ;
HOOK: <datagram> io-backend ( addrspec -- datagram )
@ -55,8 +65,8 @@ HOOK: resolve-host io-backend ( host serv passive? -- seq )
HOOK: host-name io-backend ( -- string )
: resolve-client-addr ( inet -- seq )
[ host>> ] [ port>> ] bi f resolve-host ;
M: inet (client)
[ host>> ] [ port>> ] bi f resolve-host
[ empty? [ "Host name lookup failed" throw ] when ]
[ (client) ]
bi ;
resolve-client-addr (client) ;

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

@ -11,7 +11,11 @@ IN: io.unix.backend
! I/O tasks
TUPLE: io-task port callbacks ;
: io-task-fd port>> handle>> ;
GENERIC: handle-fd ( handle -- fd )
M: integer handle-fd ;
: io-task-fd port>> handle>> handle-fd ;
: <io-task> ( port continuation/f class -- task )
new
@ -84,9 +88,10 @@ M: integer init-handle ( fd -- )
M: integer close-handle ( fd -- )
close ;
TUPLE: unix-io-error error port ;
: report-error ( error port -- )
[ "Error on fd " % dup handle>> # ": " % swap % ] "" make
>>error drop ;
tuck unix-io-error boa >>error drop ;
: ignorable-error? ( n -- ? )
[ EAGAIN number= ] [ EINTR number= ] bi or ;
@ -100,7 +105,7 @@ M: integer close-handle ( fd -- )
dup rot unregister-io-task
io-task-callbacks [ resume ] each ;
: handle-io-task ( mx task -- )
: perform-io-task ( mx task -- )
dup do-io-task [ pop-callbacks ] [ 2drop ] if ;
: handle-timeout ( port mx assoc -- )
@ -127,25 +132,25 @@ M: unix cancel-io ( port -- )
[ buffer>> buffer-end ]
[ buffer>> buffer-capacity ] tri read ;
: refill ( port -- ? )
GENERIC: refill ( port handle -- ? )
M: integer refill
#! Return f if there is a recoverable error
drop
dup buffer>> buffer-empty? [
dup (refill) dup 0 >= [
dup (refill) dup 0 >= [
swap buffer>> n>buffer t
] [
drop defer-error
] if
] [
drop t
] if ;
] [ drop t ] if ;
TUPLE: read-task < input-task ;
: <read-task> ( port continuation -- task )
read-task <io-task> ;
: <read-task> ( port continuation -- task ) read-task <io-task> ;
M: read-task do-io-task
io-task-port dup refill
port>> dup dup handle>> refill
[ [ reader-eof ] [ drop ] if ] keep ;
M: unix (wait-to-read)
@ -153,7 +158,10 @@ M: unix (wait-to-read)
pending-error ;
! Writers
: write-step ( port -- ? )
GENERIC: drain ( port handle -- ? )
M: integer drain
drop
dup
[ handle>> ]
[ buffer>> buffer@ ]
@ -164,12 +172,11 @@ M: unix (wait-to-read)
TUPLE: write-task < output-task ;
: <write-task> ( port continuation -- task )
write-task <io-task> ;
: <write-task> ( port continuation -- task ) write-task <io-task> ;
M: write-task do-io-task
io-task-port dup [ buffer>> buffer-empty? ] [ port-error ] bi or
[ 0 swap buffer>> buffer-reset t ] [ write-step ] if ;
[ 0 swap buffer>> buffer-reset t ] [ dup handle>> drain ] if ;
: add-write-io-task ( port continuation -- )
over handle>> mx get-global writes>> at*
@ -186,9 +193,9 @@ M: unix io-multiplex ( ms/f -- )
mx get-global wait-for-events ;
M: unix (init-stdio) ( -- )
0 <reader>
1 <writer>
2 <writer> ;
0 <input-port>
1 <output-port>
2 <output-port> ;
! mx io-task for embedding an fd-based mx inside another mx
TUPLE: mx-port < port mx ;

4
extra/io/unix/epoll/epoll.factor
View File

@ -43,10 +43,10 @@ M: epoll-mx unregister-io-task ( task mx -- )
r> epoll_wait dup multiplexer-error ;
: epoll-read-task ( mx fd -- )
over mx-reads at* [ handle-io-task ] [ 2drop ] if ;
over mx-reads at* [ perform-io-task ] [ 2drop ] if ;
: epoll-write-task ( mx fd -- )
over mx-writes at* [ handle-io-task ] [ 2drop ] if ;
over mx-writes at* [ perform-io-task ] [ 2drop ] if ;
: handle-event ( mx kevent -- )
epoll-event-fd 2dup epoll-read-task epoll-write-task ;

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

@ -21,7 +21,7 @@ M: unix cd ( path -- )
O_RDONLY file-mode open dup io-error ;
M: unix (file-reader) ( path -- stream )
open-read <reader> ;
open-read <input-port> ;
: write-flags { O_WRONLY O_CREAT O_TRUNC } flags ; inline
@ -29,7 +29,7 @@ M: unix (file-reader) ( path -- stream )
write-flags file-mode open dup io-error ;
M: unix (file-writer) ( path -- stream )
open-write <writer> ;
open-write <output-port> ;
: append-flags { O_WRONLY O_APPEND O_CREAT } flags ; inline
@ -38,7 +38,7 @@ M: unix (file-writer) ( path -- stream )
[ dup 0 SEEK_END lseek io-error ] [ ] [ close ] cleanup ;
M: unix (file-appender) ( path -- stream )
open-append <writer> ;
open-append <output-port> ;
: touch-mode ( -- n )
{ O_WRONLY O_APPEND O_CREAT O_EXCL } flags ; foldable

4
extra/io/unix/kqueue/kqueue.factor
View File

@ -57,10 +57,10 @@ M: kqueue-mx unregister-io-task ( task mx -- )
dup multiplexer-error ;
:: kevent-read-task ( mx fd kevent -- )
mx fd mx reads>> at handle-io-task ;
mx fd mx reads>> at perform-io-task ;
:: kevent-write-task ( mx fd kevent -- )
mx fd mx writes>> at handle-io-task ;
mx fd mx writes>> at perform-io-task ;
:: kevent-proc-task ( mx pid kevent -- )
pid wait-for-pid

12
extra/io/unix/select/select.factor
View File

@ -21,12 +21,12 @@ TUPLE: select-mx < mx read-fdset write-fdset ;
: clear-nth ( n seq -- ? )
[ nth ] [ f -rot set-nth ] 2bi ;
: handle-fd ( fd task fdset mx -- )
: check-fd ( fd task fdset mx -- )
roll munge rot clear-nth
[ swap handle-io-task ] [ 2drop ] if ;
[ swap perform-io-task ] [ 2drop ] if ;
: handle-fdset ( tasks fdset mx -- )
[ handle-fd ] 2curry assoc-each ;
: check-fdset ( tasks fdset mx -- )
[ check-fd ] 2curry assoc-each ;
: init-fdset ( tasks fdset -- )
[ >r drop t swap munge r> set-nth ] curry assoc-each ;
@ -52,5 +52,5 @@ TUPLE: select-mx < mx read-fdset write-fdset ;
M: select-mx wait-for-events ( ms mx -- )
swap >r dup init-fdsets r> dup [ make-timeval ] when
select multiplexer-error
dup read-fdset/tasks pick handle-fdset
dup write-fdset/tasks rot handle-fdset ;
dup read-fdset/tasks pick check-fdset
dup write-fdset/tasks rot check-fdset ;

95
extra/io/unix/sockets/secure/secure.factor Normal file
View File

@ -0,0 +1,95 @@
! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors 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.nonblocking io.unix.backend io.unix.sockets
io.encodings.ascii io.buffers io.sockets io.sockets.secure
unix.ffi ;
IN: io.unix.sockets.secure
! todo: SSL_pending, rehandshake
! do we call write twice, wth 0 bytes at the end?
M: ssl handle-fd file>> ;
: syscall-error ( port r -- )
ERR_get_error dup zero? [
drop
{
{ -1 [ err_no strerror ] }
{ 0 [ "Premature EOF" ] }
} case
] [
nip (ssl-error-string)
] if swap report-error ;
: check-response ( port r -- port r n )
over handle>> handle>> over SSL_get_error ; inline
! Input ports
: report-ssl-error ( port r -- )
drop ssl-error-string swap report-error ;
: check-read-response ( port r -- ? )
check-response
{
{ SSL_ERROR_NONE [ swap buffer>> n>buffer t ] }
{ SSL_ERROR_ZERO_RETURN [ drop reader-eof t ] }
{ SSL_ERROR_WANT_READ [ 2drop f ] }
{ SSL_ERROR_WANT_WRITE [ 2drop f ] } ! XXX
{ SSL_ERROR_SYSCALL [ syscall-error t ] }
{ SSL_ERROR_SSL [ report-ssl-error t ] }
} case ;
M: ssl-handle refill
drop
dup buffer>> buffer-empty? [
dup
[ handle>> handle>> ] ! ssl
[ buffer>> buffer-end ] ! buf
[ buffer>> buffer-capacity ] tri ! len
SSL_read
check-read-response
] [ drop t ] if ;
! Output ports
: check-write-response ( port r -- ? )
check-response
{
{ SSL_ERROR_NONE [ swap buffer>> buffer-consume f ] }
! { SSL_ERROR_ZERO_RETURN [ drop reader-eof ] } ! XXX
{ SSL_ERROR_WANT_READ [ 2drop f ] } ! XXX
{ SSL_ERROR_WANT_WRITE [ 2drop f ] }
{ SSL_ERROR_SYSCALL [ syscall-error t ] }
{ SSL_ERROR_SSL [ report-ssl-error t ] }
} case ;
M: ssl-handle drain
drop
dup
[ handle>> handle>> ] ! ssl
[ buffer>> buffer@ ] ! buf
[ buffer>> buffer-length ] tri ! len
SSL_write
check-write-response ;
! Client sockets
M: ssl ((client)) ( addrspec -- handle )
[ addrspec>> ((client)) <ssl-socket> ] with-destructors ;
: check-connect-response ( port r -- ? )
check-response
{
{ SSL_ERROR_NONE [ 2drop t ] }
{ SSL_ERROR_WANT_READ [ 2drop f ] } ! XXX
{ SSL_ERROR_WANT_WRITE [ 2drop f ] } ! XXX
{ SSL_ERROR_SYSCALL [ syscall-error t ] }
{ SSL_ERROR_SSL [ report-ssl-error t ] }
} case ;
M: ssl-handle (wait-to-connect)
handle>> handle>> ! ssl
SSL_connect
check-connect-response ;

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

@ -5,22 +5,18 @@ namespaces threads sequences byte-arrays io.nonblocking
io.binary io.unix.backend io.streams.duplex io.sockets.impl
io.backend io.files io.files.private io.encodings.utf8
math.parser continuations libc combinators system accessors
qualified unix.ffi unix ;
destructors qualified unix.ffi unix ;
EXCLUDE: io => read write close ;
EXCLUDE: io.sockets => accept ;
IN: io.unix.sockets
: pending-init-error ( port -- )
#! We close it here to avoid a resource leak; callers of
#! <client> don't set up error handlers until after <client>
#! returns (and if they did before, they wouldn't have
#! anything to close!)
dup port-error dup [ swap dispose throw ] [ 2drop ] if ;
: socket-fd ( domain type -- socket )
0 socket dup io-error dup init-handle ;
0 socket
dup io-error
dup close-later
dup init-handle ;
: sockopt ( fd level opt -- )
1 <int> "int" heap-size setsockopt io-error ;
@ -37,25 +33,24 @@ TUPLE: connect-task < output-task ;
: <connect-task> ( port continuation -- task )
connect-task <io-task> ;
GENERIC: (wait-to-connect) ( port handle -- ? )
M: integer (wait-to-connect)
f 0 write 0 < [ defer-error ] [ drop t ] if ;
M: connect-task do-io-task
port>> dup handle>> f 0 write
0 < [ defer-error ] [ drop t ] if ;
port>> dup handle>> (wait-to-connect) ;
: wait-to-connect ( port -- )
[ <connect-task> add-io-task ] with-port-continuation drop ;
M: integer wait-to-connect ( client-out fd -- )
drop
[ <connect-task> add-io-task ] with-port-continuation
pending-error ;
M: unix ((client)) ( addrspec -- client-in client-out )
dup make-sockaddr/size >r >r
protocol-family SOCK_STREAM socket-fd
dup r> r> connect
zero? err_no EINPROGRESS = or [
dup init-client-socket
dup <reader&writer>
dup wait-to-connect
dup pending-init-error
] [
dup close (io-error)
] if ;
M: object ((client)) ( addrspec -- fd )
[ protocol-family SOCK_STREAM socket-fd ] [ make-sockaddr/size ] bi
[ 2drop ] [ connect ] 3bi
zero? err_no EINPROGRESS = or
[ dup init-client-socket ] [ (io-error) ] if ;
! Server sockets - TCP and Unix domain
: init-server-socket ( fd -- )
@ -83,15 +78,17 @@ M: accept-task do-io-task
: wait-to-accept ( server -- )
[ <accept-task> add-io-task ] with-port-continuation drop ;
: server-fd ( addrspec type -- fd )
>r dup protocol-family r> socket-fd
: server-socket-fd ( addrspec type -- fd )
>r dup protocol-family r> socket-fd
dup init-server-socket
dup rot make-sockaddr/size bind
zero? [ dup close (io-error) ] unless ;
M: unix (server) ( addrspec -- handle )
SOCK_STREAM server-fd
dup 10 listen zero? [ dup close (io-error) ] unless ;
[
SOCK_STREAM server-socket-fd
dup 10 listen io-error
] with-destructors ;
M: unix (accept) ( server -- addrspec handle )
#! Wait for a client connection.
@ -102,7 +99,9 @@ M: unix (accept) ( server -- addrspec handle )
! Datagram sockets - UDP and Unix domain
M: unix <datagram>
[ SOCK_DGRAM server-fd ] keep <datagram-port> ;
[
[ SOCK_DGRAM server-socket-fd ] keep <datagram-port>
] with-destructors ;
SYMBOL: receive-buffer

15
extra/io/unix/unix.factor
View File

@ -1,6 +1,13 @@
USING: io.unix.backend io.unix.files io.unix.sockets
io.unix.launcher io.unix.mmap io.unix.pipes io.timeouts
io.backend combinators namespaces system vocabs.loader
sequences words init ;
USING: system words sequences vocabs.loader ;
{
"io.unix.backend"
"io.unix.files"
"io.unix.sockets"
"io.unix.sockets.secure"
"io.unix.launcher"
"io.unix.mmap"
"io.unix.pipes"
} [ require ] each
"io.unix." os word-name append require

2
extra/io/windows/ce/backend/backend.factor
View File

@ -46,5 +46,5 @@ M: wince (init-stdio) ( -- )
1 _getstdfilex _fileno
2 _getstdfilex _fileno
] if [ f <win32-file> ] 3apply
rot <reader> -rot [ <writer> ] bi@
[ <input-port> ] [ <output-port> ] [ <output-port> ] tri*
] with-variable ;

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

@ -32,7 +32,7 @@ M: win32-socket wince-write ( port port-handle -- )
windows.winsock:winsock-error!=0/f ;
M: wince (client) ( addrspec -- reader writer )
do-connect <win32-socket> dup <reader&writer> ;
do-connect <win32-socket> dup <ports> ;
M: wince (server) ( addrspec -- handle )
windows.winsock:SOCK_STREAM server-fd
@ -52,7 +52,7 @@ M: wince (accept) ( server -- client )
[ windows.winsock:winsock-error ] when
] keep
] keep server-port-addr parse-sockaddr swap
<win32-socket> <reader&writer>
<win32-socket> <ports>
] with-timeout ;
M: wince <datagram> ( addrspec -- datagram )

19
extra/io/windows/nt/sockets/sockets.factor
View File

@ -45,12 +45,16 @@ TUPLE: ConnectEx-args port
"stdcall" alien-indirect drop
winsock-error-string [ throw ] when* ;
: connect-continuation ( ConnectEx port -- )
>r ConnectEx-args-lpOverlapped* r>
: connect-continuation ( overlapped port -- )
2dup save-callback
get-overlapped-result drop ;
M: winnt ((client)) ( addrspec -- client-in client-out )
M: win32-socket wait-to-connect ( client-out handle -- )
[ overlapped>> swap connect-continuation ]
[ drop pending-error ]
2bi ;
M: object ((client)) ( addrspec -- handle )
[
\ ConnectEx-args new
over make-sockaddr/size pick init-connect
@ -60,8 +64,7 @@ M: winnt ((client)) ( addrspec -- client-in client-out )
dup ConnectEx-args-s* INADDR_ANY roll bind-socket
dup (ConnectEx)
dup ConnectEx-args-s* <win32-socket> dup <reader&writer>
>r [ connect-continuation ] keep [ pending-error ] keep r>
dup [ ConnectEx-args-s* ] [ ConnectEx-args-lpOverlapped* ] bi <win32-socket>
] with-destructors ;
TUPLE: AcceptEx-args port
@ -117,7 +120,7 @@ TUPLE: AcceptEx-args port
[ extract-remote-host ] keep
! addrspec AcceptEx
[ AcceptEx-args-sAcceptSocket* add-completion ] keep
AcceptEx-args-sAcceptSocket* <win32-socket> ;
[ AcceptEx-args-sAcceptSocket* ] [ AcceptEx-args-lpOverlapped* ] bi <win32-socket> ;
M: winnt (accept) ( server -- addrspec handle )
[
@ -135,7 +138,7 @@ M: winnt (server) ( addrspec -- handle )
[
SOCK_STREAM server-fd dup listen-on-socket
dup add-completion
<win32-socket>
f <win32-socket>
] with-destructors ;
M: winnt <datagram> ( addrspec -- datagram )
@ -143,7 +146,7 @@ M: winnt <datagram> ( addrspec -- datagram )
[
SOCK_DGRAM server-fd
dup add-completion
<win32-socket>
f <win32-socket>
] keep <datagram-port>
] with-destructors ;

14
extra/io/windows/windows.factor
View File

@ -123,13 +123,13 @@ C: <FileArgs> FileArgs
FileArgs-lpOverlapped ;
M: windows (file-reader) ( path -- stream )
open-read <win32-file> <reader> ;
open-read <win32-file> <input-port> ;
M: windows (file-writer) ( path -- stream )
open-write <win32-file> <writer> ;
open-write <win32-file> <output-port> ;
M: windows (file-appender) ( path -- stream )
open-append <win32-file> <writer> ;
open-append <win32-file> <output-port> ;
M: windows move-file ( from to -- )
[ normalize-path ] bi@ MoveFile win32-error=0/f ;
@ -151,10 +151,12 @@ M: windows delete-directory ( path -- )
HOOK: WSASocket-flags io-backend ( -- DWORD )
TUPLE: win32-socket < win32-file ;
TUPLE: win32-socket < win32-file overlapped ;
: <win32-socket> ( handle -- win32-socket )
f win32-file boa ;
: <win32-socket> ( handle overlapped -- win32-socket )
win32-socket new
swap >>overlapped
swap >>handle ;
: open-socket ( family type -- socket )
0 f 0 WSASocket-flags WSASocket dup socket-error ;

24
extra/openssl/openssl.factor
View File

@ -19,11 +19,14 @@ M: SSLv23 ssl-method drop SSLv23_method ;
M: SSLv3 ssl-method drop SSLv3_method ;
M: TLSv1 ssl-method drop TLSv1_method ;
: (ssl-error) ( num -- * )
ERR_get_error ERR_clear_error f ERR_error_string throw ;
: (ssl-error-string) ( n -- string )
ERR_clear_error f ERR_error_string ;
: ssl-error-string ( -- string )
ERR_get_error ERR_clear_error f ERR_error_string ;
: ssl-error ( obj -- )
{ f 0 } member? [ (ssl-error) ] when ;
{ f 0 } member? [ ssl-error-string throw ] when ;
: init-ssl ( -- )
SSL_library_init ssl-error
@ -114,14 +117,19 @@ M: openssl-context dispose
dup handle>> [ SSL_CTX_free ] when* f >>handle
drop ;
TUPLE: ssl file handle ;
TUPLE: ssl-handle file handle ;
: <ssl> ( file -- ssl )
ssl-context get handle>> SSL_new dup ssl-error ssl boa ;
: <ssl-handle> ( fd -- ssl )
ssl-context get handle>> SSL_new dup ssl-error ssl-handle boa ;
M: ssl init-handle drop ;
: <ssl-socket> ( fd -- ssl )
[ BIO_NOCLOSE BIO_new_socket dup ssl-error ] keep
<ssl-handle>
[ handle>> swap dup SSL_set_bio ] keep ;
M: ssl close-handle
M: ssl-handle init-handle drop ;
M: ssl-handle close-handle
[ file>> close-handle ] [ handle>> SSL_free ] bi ;
ERROR: certificate-verify-error result ;

11
extra/openssl/unix/unix.factor
View File

@ -1,11 +0,0 @@
! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors byte-arrays kernel debugger sequences namespaces math
math.order combinators init alien alien.c-types alien.strings libc
continuations destructors
locals unicode.case
openssl.libcrypto openssl.libssl
io.files io.encodings.ascii io.sockets.secure ;
IN: openssl.unix

1
extra/oracle/liboci/liboci.factor
View File

@ -124,7 +124,6 @@ TYPEDEF: ushort ub2
TYPEDEF: short sb2
TYPEDEF: uint ub4
TYPEDEF: int sb4
TYPEDEF: ulong size_t
! ===============================================
! Input data types (ocidfn.h)

1
extra/unix/unix.factor
View File

@ -11,7 +11,6 @@ IN: unix
TYPEDEF: uint in_addr_t
TYPEDEF: uint socklen_t
TYPEDEF: ulong size_t
: PROT_NONE 0 ; inline
: PROT_READ 1 ; inline

1
extra/windows/types/types.factor
View File

@ -198,7 +198,6 @@ TYPEDEF: void* MSGBOXPARAMSA
TYPEDEF: void* MSGBOXPARAMSW
TYPEDEF: void* LPOVERLAPPED_COMPLETION_ROUTINE
TYPEDEF: int size_t
TYPEDEF: size_t socklen_t
TYPEDEF: void* WNDPROC