Merge branch 'master' of git://factorcode.org/git/factor

db4
Doug Coleman 2008-05-19 19:00:20 -05:00
commit f1f5ea3a77
35 changed files with 496 additions and 282 deletions

View File

@ -26,5 +26,6 @@ HELP: <byte-array> ( n -- byte-array )
HELP: >byte-array HELP: >byte-array
{ $values { "seq" "a sequence" } { "byte-array" byte-array } } { $values { "seq" "a sequence" } { "byte-array" byte-array } }
{ $description "Outputs a freshly-allocated byte array whose elements have the same boolean values as a given sequence." } { $description
"Outputs a freshly-allocated byte array whose elements have the same signed byte values as a given sequence." }
{ $errors "Throws an error if the sequence contains elements other than integers." } ; { $errors "Throws an error if the sequence contains elements other than integers." } ;

View File

@ -105,6 +105,8 @@ strings accessors io.encodings.utf8 math destructors ;
[ f ] [ "test-bar.txt" temp-file exists? ] unit-test [ f ] [ "test-bar.txt" temp-file exists? ] unit-test
[ "test-blah" temp-file delete-tree ] ignore-errors
[ ] [ "test-blah" temp-file make-directory ] unit-test [ ] [ "test-blah" temp-file make-directory ] unit-test
[ ] [ [ ] [

View File

@ -1,6 +1,6 @@
USING: arrays io io.files kernel math parser strings system USING: arrays io io.files kernel math parser strings system
tools.test words namespaces io.encodings.8-bit tools.test words namespaces io.encodings.8-bit
io.encodings.binary ; io.encodings.binary sequences ;
IN: io.tests IN: io.tests
[ f ] [ [ f ] [
@ -47,3 +47,11 @@ IN: io.tests
10 [ 65536 read drop ] times 10 [ 65536 read drop ] times
] with-file-reader ] with-file-reader
] unit-test ] unit-test
! Test EOF behavior
[ 10 ] [
image binary [
0 read drop
10 read length
] with-file-reader
] unit-test

View File

@ -10,12 +10,15 @@ TUPLE: c-writer handle disposed ;
: <c-writer> ( handle -- stream ) f c-writer boa ; : <c-writer> ( handle -- stream ) f c-writer boa ;
M: c-writer stream-write1 M: c-writer stream-write1
dup check-disposed
handle>> fputc ; handle>> fputc ;
M: c-writer stream-write M: c-writer stream-write
dup check-disposed
handle>> fwrite ; handle>> fwrite ;
M: c-writer stream-flush M: c-writer stream-flush
dup check-disposed
handle>> fflush ; handle>> fflush ;
M: c-writer dispose* M: c-writer dispose*
@ -26,12 +29,14 @@ TUPLE: c-reader handle disposed ;
: <c-reader> ( handle -- stream ) f c-reader boa ; : <c-reader> ( handle -- stream ) f c-reader boa ;
M: c-reader stream-read M: c-reader stream-read
dup check-disposed
handle>> fread ; handle>> fread ;
M: c-reader stream-read-partial M: c-reader stream-read-partial
stream-read ; stream-read ;
M: c-reader stream-read1 M: c-reader stream-read1
dup check-disposed
handle>> fgetc ; handle>> fgetc ;
: read-until-loop ( stream delim -- ch ) : read-until-loop ( stream delim -- ch )
@ -42,6 +47,7 @@ M: c-reader stream-read1
] if ; ] if ;
M: c-reader stream-read-until M: c-reader stream-read-until
dup check-disposed
[ swap read-until-loop ] B{ } make swap [ swap read-until-loop ] B{ } make swap
over empty? over not and [ 2drop f f ] when ; over empty? over not and [ 2drop f f ] when ;

View File

@ -74,3 +74,17 @@ PRIVATE>
-> locationInWindow f -> convertPoint:fromView: -> locationInWindow f -> convertPoint:fromView:
dup NSPoint-x swap NSPoint-y dup NSPoint-x swap NSPoint-y
r> -> frame NSRect-h swap - 2array ; r> -> frame NSRect-h swap - 2array ;
USE: opengl.gl
USE: alien.syntax
: NSOpenGLCPSwapInterval 222 ;
LIBRARY: OpenGL
TYPEDEF: int CGLError
TYPEDEF: void* CGLContextObj
TYPEDEF: int CGLContextParameter
FUNCTION: CGLError CGLSetParameter ( CGLContextObj ctx, CGLContextParameter pname, GLint* params ) ;

View File

@ -35,4 +35,4 @@ PRIVATE>
: <glob> 'glob' just parse-1 just ; : <glob> 'glob' just parse-1 just ;
: glob-matches? ( input glob -- ? ) : glob-matches? ( input glob -- ? )
>r >lower r> <glob> parse nil? not ; [ >lower ] [ <glob> ] bi* parse nil? not ;

View File

@ -386,7 +386,7 @@ M: object protocol-addr
drop [ host>> ] [ port>> ] bi <inet> ; drop [ host>> ] [ port>> ] bi <inet> ;
M: https protocol-addr M: https protocol-addr
call-next-method <ssl> ; call-next-method <secure> ;
: request-addr ( request -- addr ) : request-addr ( request -- addr )
dup protocol>> protocol-addr ; dup protocol>> protocol-addr ;

19
extra/io/monitors/monitors-tests.factor Normal file → Executable file
View File

@ -1,7 +1,7 @@
IN: io.monitors.tests IN: io.monitors.tests
USING: io.monitors tools.test io.files system sequences USING: io.monitors tools.test io.files system sequences
continuations namespaces concurrency.count-downs kernel io continuations namespaces concurrency.count-downs kernel io
threads calendar prettyprint destructors ; threads calendar prettyprint destructors io.timeouts ;
os { winnt linux macosx } member? [ os { winnt linux macosx } member? [
[ [
@ -91,4 +91,21 @@ os { winnt linux macosx } member? [
! Out-of-scope disposal should not fail ! Out-of-scope disposal should not fail
[ ] [ [ "" resource-path f <monitor> ] with-monitors dispose ] unit-test [ ] [ [ "" resource-path f <monitor> ] with-monitors dispose ] unit-test
[ ] [ [ "" resource-path t <monitor> ] with-monitors dispose ] unit-test [ ] [ [ "" resource-path t <monitor> ] with-monitors dispose ] unit-test
! Timeouts
[
[ ] [ "monitor-timeout-test" temp-file make-directories ] unit-test
! Non-recursive
[ ] [ "monitor-timeout-test" temp-file f <monitor> "m" set ] unit-test
[ ] [ 3 seconds "m" get set-timeout ] unit-test
[ [ t ] [ "m" get next-change 2drop ] [ ] while ] must-fail
[ ] [ "m" get dispose ] unit-test
! Recursive
[ ] [ "monitor-timeout-test" temp-file t <monitor> "m" set ] unit-test
[ ] [ 3 seconds "m" get set-timeout ] unit-test
[ [ t ] [ "m" get next-change 2drop ] [ ] while ] must-fail
[ ] [ "m" get dispose ] unit-test
] with-monitors
] when ] when

View File

@ -29,15 +29,7 @@ $nl
ABOUT: "io.ports" ABOUT: "io.ports"
HELP: port HELP: port
{ $class-description "Instances of this class present a blocking stream interface on top of an underlying non-blocking I/O system, giving the illusion of blocking by yielding the thread which is waiting for input or output." { $class-description "Instances of this class present a blocking stream interface on top of an underlying non-blocking I/O system, giving the illusion of blocking by yielding the thread which is waiting for input or output." } ;
$nl
"Ports have the following slots:"
{ $list
{ { $snippet "handle" } " - a native handle identifying the underlying native resource used by the port" }
{ { $snippet "error" } " - the most recent I/O error, if any. This error is thrown to the waiting thread when " { $link pending-error } " is called by stream operations" }
{ { $snippet "type" } " - a symbol identifying the port's intended purpose" }
{ { $snippet "eof" } " - a flag indicating if the port has reached the end of file while reading" }
} } ;
HELP: input-port HELP: input-port
{ $class-description "The class of ports implementing the input stream protocol." } ; { $class-description "The class of ports implementing the input stream protocol." } ;
@ -65,21 +57,13 @@ HELP: <output-port>
{ $description "Creates a new " { $link output-port } " using the specified native handle and a default-sized input buffer." } { $description "Creates a new " { $link output-port } " using the specified native handle and a default-sized input buffer." }
$low-level-note ; $low-level-note ;
HELP: pending-error
{ $values { "port" port } }
{ $description "If an error occurred while the I/O thread was performing input or output on this port, this error will be thrown to the caller." } ;
HELP: (wait-to-read) HELP: (wait-to-read)
{ $values { "port" input-port } } { $values { "port" input-port } }
{ $contract "Suspends the current thread until the port's buffer has data available for reading." } ; { $contract "Suspends the current thread until the port's buffer has data available for reading." } ;
HELP: wait-to-read HELP: wait-to-read
{ $values { "port" input-port } } { $values { "port" input-port } { "eof?" "a boolean" } }
{ $description "If the port's buffer has unread data, returns immediately, otherwise suspends the current thread until some data is available for reading." } ; { $description "If the port's buffer has unread data, returns immediately, otherwise suspends the current thread until some data is available for reading. If the buffer was empty and no more data could be read, outputs " { $link t } " to indicate end-of-file; otherwise outputs " { $link f } "." } ;
HELP: unless-eof
{ $values { "port" input-port } { "quot" "a quotation with stack effect " { $snippet "( port -- value )" } } { "value" object } }
{ $description "If the port has reached end of file, outputs " { $link f } ", otherwise applies the quotation to the port." } ;
HELP: can-write? HELP: can-write?
{ $values { "len" "a positive integer" } { "buffer" buffer } { "?" "a boolean" } } { $values { "len" "a positive integer" } { "buffer" buffer } { "?" "a boolean" } }

View File

@ -10,7 +10,7 @@ IN: io.ports
SYMBOL: default-buffer-size SYMBOL: default-buffer-size
64 1024 * default-buffer-size set-global 64 1024 * default-buffer-size set-global
TUPLE: port handle error timeout disposed ; TUPLE: port handle timeout disposed ;
M: port timeout timeout>> ; M: port timeout timeout>> ;
@ -19,36 +19,30 @@ M: port set-timeout (>>timeout) ;
: <port> ( handle class -- port ) : <port> ( handle class -- port )
new swap >>handle ; inline new swap >>handle ; inline
: pending-error ( port -- )
[ f ] change-error drop [ throw ] when* ;
TUPLE: buffered-port < port buffer ; TUPLE: buffered-port < port buffer ;
: <buffered-port> ( handle class -- port ) : <buffered-port> ( handle class -- port )
<port> <port>
default-buffer-size get <buffer> >>buffer ; inline default-buffer-size get <buffer> >>buffer ; inline
TUPLE: input-port < buffered-port eof ; TUPLE: input-port < buffered-port ;
: <input-port> ( handle -- input-port ) : <input-port> ( handle -- input-port )
input-port <buffered-port> ; input-port <buffered-port> ;
HOOK: (wait-to-read) io-backend ( port -- ) HOOK: (wait-to-read) io-backend ( port -- )
: wait-to-read ( port -- ) : wait-to-read ( port -- eof? )
dup buffer>> buffer-empty? [ (wait-to-read) ] [ drop ] if ; dup buffer>> buffer-empty? [
dup (wait-to-read) buffer>> buffer-empty?
: unless-eof ( port quot -- value ) ] [ drop f ] if ;
>r dup buffer>> buffer-empty? over eof>> and
[ f >>eof drop f ] r> if ; inline
M: input-port stream-read1 M: input-port stream-read1
dup check-disposed dup check-disposed
dup wait-to-read [ buffer>> buffer-pop ] unless-eof ; dup wait-to-read [ drop f ] [ buffer>> buffer-pop ] if ;
: read-step ( count port -- byte-array/f ) : read-step ( count port -- byte-array/f )
[ wait-to-read ] keep dup wait-to-read [ 2drop f ] [ buffer>> buffer-read ] if ;
[ dupd buffer>> buffer-read ] unless-eof nip ;
M: input-port stream-read-partial ( max stream -- byte-array/f ) M: input-port stream-read-partial ( max stream -- byte-array/f )
dup check-disposed dup check-disposed
@ -106,14 +100,15 @@ M: output-port stream-write
HOOK: (wait-to-write) io-backend ( port -- ) HOOK: (wait-to-write) io-backend ( port -- )
: flush-port ( port -- ) : port-flush ( port -- )
dup buffer>> buffer-empty? [ drop ] [ (wait-to-write) ] if ; dup buffer>> buffer-empty?
[ drop ] [ dup (wait-to-write) port-flush ] if ;
M: output-port stream-flush ( port -- ) M: output-port stream-flush ( port -- )
[ check-disposed ] [ flush-port ] bi ; [ check-disposed ] [ port-flush ] bi ;
M: output-port dispose* M: output-port dispose*
[ flush-port ] [ call-next-method ] bi ; [ port-flush ] [ call-next-method ] bi ;
M: buffered-port dispose* M: buffered-port dispose*
[ call-next-method ] [ call-next-method ]

View File

@ -1,9 +1,10 @@
! Copyright (C) 2003, 2008 Slava Pestov. ! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: io io.sockets io.files io.streams.duplex logging USING: io io.sockets io.sockets.secure io.files
continuations destructors kernel math math.parser namespaces io.streams.duplex logging continuations destructors kernel math
parser sequences strings prettyprint debugger quotations math.parser namespaces parser sequences strings prettyprint
calendar threads concurrency.combinators assocs fry ; debugger quotations calendar threads concurrency.combinators
assocs fry ;
IN: io.server IN: io.server
SYMBOL: servers SYMBOL: servers
@ -41,6 +42,9 @@ PRIVATE>
: internet-server ( port -- seq ) : internet-server ( port -- seq )
f swap t resolve-host ; f swap t resolve-host ;
: secure-server ( port -- seq )
internet-server [ <secure> ] map ;
: with-server ( seq service encoding quot -- ) : with-server ( seq service encoding quot -- )
V{ } clone servers [ V{ } clone servers [
'[ , [ , , server-loop ] with-logging ] parallel-each '[ , [ , , server-loop ] with-logging ] parallel-each

View File

@ -1,5 +1 @@
IN: io.sockets.secure.tests ! No unit tests here, until Windows SSL is implemented
USING: io.sockets.secure tools.test ;
\ <ssl-config> must-infer
{ 1 0 } [ [ ] with-ssl-context ] must-infer-as

View File

@ -1,38 +1,68 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel symbols namespaces continuations USING: accessors kernel symbols namespaces continuations
destructors io.sockets sequences ; destructors io.sockets sequences inspector ;
IN: io.sockets.secure IN: io.sockets.secure
SYMBOL: ssl-backend SYMBOL: secure-socket-backend
SINGLETONS: SSLv2 SSLv23 SSLv3 TLSv1 ; SINGLETONS: SSLv2 SSLv23 SSLv3 TLSv1 ;
TUPLE: ssl-config method key-file ca-file ca-path password ; TUPLE: secure-config
method
key-file password
ca-file ca-path
dh-file
ephemeral-key-bits ;
: <ssl-config> ( -- config ) : <secure-config> ( -- config )
ssl-config new secure-config new
SSLv23 >>method ; SSLv23 >>method
512 >>ephemeral-key-bits ;
TUPLE: ssl-context config handle ; TUPLE: secure-context config handle disposed ;
HOOK: <ssl-context> ssl-backend ( config -- context ) HOOK: <secure-context> secure-socket-backend ( config -- context )
: with-ssl-context ( config quot -- ) : with-secure-context ( config quot -- )
[ [
[ <ssl-context> ] [ [ ssl-context set ] prepose ] bi* [ <secure-context> ] [ [ secure-context set ] prepose ] bi*
with-disposal with-disposal
] with-scope ; inline ] with-scope ; inline
TUPLE: ssl addrspec ; TUPLE: secure addrspec ;
C: <ssl> ssl C: <secure> secure
: resolve-secure-host ( host port passive? -- seq )
resolve-host [ <secure> ] map ;
HOOK: check-certificate secure-socket-backend ( host handle -- )
<PRIVATE <PRIVATE
PREDICATE: ssl-inet < ssl addrspec>> inet? ; PREDICATE: secure-inet < secure addrspec>> inet? ;
M: ssl-inet (client) M: secure-inet (client)
addrspec>> resolve-client-addr [ <ssl> ] map (client) ; [
addrspec>>
[ [ host>> ] [ port>> ] bi f resolve-secure-host (client) >r |dispose r> ] keep
host>> pick handle>> check-certificate
] with-destructors ;
PRIVATE> PRIVATE>
ERROR: premature-close ;
M: premature-close summary
drop "Connection closed prematurely - potential truncation attack" ;
ERROR: certificate-verify-error result ;
M: certificate-verify-error summary
drop "Certificate verification failed" ;
ERROR: common-name-verify-error expected got ;
M: common-name-verify-error summary
drop "Common name verification failed" ;

View File

@ -37,7 +37,7 @@ ARTICLE: "network-packet" "Packet-oriented networking"
{ $subsection receive } { $subsection receive }
"Packet-oriented sockets are closed by calling " { $link dispose } "." "Packet-oriented sockets are closed by calling " { $link dispose } "."
$nl $nl
"Address specifiers have the following interpretation with connection-oriented networking words:" "Address specifiers have the following interpretation with packet-oriented networking words:"
{ $list { $list
{ { $link local } " - Unix domain datagram sockets on Unix systems" } { { $link local } " - Unix domain datagram sockets on Unix systems" }
{ { $link inet4 } " - a TCP/IP connection to an IPv4 address and port number; no name lookup is performed" } { { $link inet4 } " - a TCP/IP connection to an IPv4 address and port number; no name lookup is performed" }

View File

@ -1,6 +1,6 @@
IN: io.sockets.tests IN: io.sockets.tests
USING: io.sockets sequences math tools.test namespaces accessors USING: io.sockets sequences math tools.test namespaces accessors
kernel destructors ; kernel destructors calendar io.timeouts ;
[ B{ 1 2 3 4 } ] [ B{ 1 2 3 4 } ]
[ "1.2.3.4" T{ inet4 } inet-pton ] unit-test [ "1.2.3.4" T{ inet4 } inet-pton ] unit-test
@ -62,3 +62,9 @@ kernel destructors ;
[ ] [ "datagram1" get dispose ] unit-test [ ] [ "datagram1" get dispose ] unit-test
[ ] [ "datagram2" get dispose ] unit-test [ ] [ "datagram2" get dispose ] unit-test
! Test timeouts
[ ] [ "127.0.0.1" 0 <inet4> <datagram> "datagram3" set ] unit-test
[ ] [ 1 seconds "datagram3" get set-timeout ] unit-test
[ "datagram3" get receive ] must-fail

View File

@ -287,11 +287,8 @@ TUPLE: inet host port ;
C: <inet> inet C: <inet> inet
: resolve-client-addr ( inet -- seq )
[ host>> ] [ port>> ] bi f resolve-host ;
M: inet (client) M: inet (client)
resolve-client-addr (client) ; [ host>> ] [ port>> ] bi f resolve-host (client) ;
ERROR: invalid-inet-server addrspec ; ERROR: invalid-inet-server addrspec ;

37
extra/io/unix/backend/backend.factor Normal file → Executable file
View File

@ -62,21 +62,18 @@ GENERIC: wait-for-events ( ms mx -- )
: output-available ( fd mx -- ) : output-available ( fd mx -- )
remove-output-callbacks [ resume ] each ; remove-output-callbacks [ resume ] each ;
TUPLE: io-timeout ;
M: io-timeout summary drop "I/O operation timed out" ;
M: unix cancel-io ( port -- ) M: unix cancel-io ( port -- )
io-timeout new >>error
handle>> handle-fd mx get-global handle>> handle-fd mx get-global
[ input-available ] [ output-available ] 2bi ; [ remove-input-callbacks [ t swap resume-with ] each ]
[ remove-output-callbacks [ t swap resume-with ] each ]
2bi ;
SYMBOL: +retry+ ! just try the operation again without blocking SYMBOL: +retry+ ! just try the operation again without blocking
SYMBOL: +input+ SYMBOL: +input+
SYMBOL: +output+ SYMBOL: +output+
: wait-for-fd ( handle event -- ) : wait-for-fd ( handle event -- timeout? )
dup +retry+ eq? [ 2drop ] [ dup +retry+ eq? [ 2drop f ] [
[ [
>r >r
swap handle-fd swap handle-fd
@ -85,12 +82,18 @@ SYMBOL: +output+
{ +input+ [ add-input-callback ] } { +input+ [ add-input-callback ] }
{ +output+ [ add-output-callback ] } { +output+ [ add-output-callback ] }
} case } case
] curry "I/O" suspend 2drop ] curry "I/O" suspend nip
] if ; ] if ;
ERROR: io-timeout ;
M: io-timeout summary drop "I/O operation timed out" ;
: wait-for-port ( port event -- ) : wait-for-port ( port event -- )
[ >r dup handle>> r> wait-for-fd ] curry [
with-timeout pending-error ; >r handle>> r> wait-for-fd
[ io-timeout ] when
] curry with-timeout ;
! Some general stuff ! Some general stuff
: file-mode OCT: 0666 ; : file-mode OCT: 0666 ;
@ -105,9 +108,6 @@ SYMBOL: +output+
: io-error ( n -- ) 0 < [ (io-error) ] when ; : io-error ( n -- ) 0 < [ (io-error) ] when ;
! Readers ! Readers
: eof ( reader -- )
dup buffer>> buffer-empty? [ t >>eof ] when drop ;
: (refill) ( port -- n ) : (refill) ( port -- n )
[ handle>> ] [ handle>> ]
[ buffer>> buffer-end ] [ buffer>> buffer-end ]
@ -120,8 +120,7 @@ GENERIC: refill ( port handle -- event/f )
M: fd refill M: fd refill
fd>> over buffer>> [ buffer-end ] [ buffer-capacity ] bi read fd>> over buffer>> [ buffer-end ] [ buffer-capacity ] bi read
{ {
{ [ dup 0 = ] [ drop eof f ] } { [ dup 0 >= ] [ swap buffer>> n>buffer f ] }
{ [ dup 0 > ] [ swap buffer>> n>buffer f ] }
{ [ err_no EINTR = ] [ 2drop +retry+ ] } { [ err_no EINTR = ] [ 2drop +retry+ ] }
{ [ err_no EAGAIN = ] [ 2drop +input+ ] } { [ err_no EAGAIN = ] [ 2drop +input+ ] }
[ (io-error) ] [ (io-error) ]
@ -147,8 +146,7 @@ M: fd drain
} cond ; } cond ;
M: unix (wait-to-write) ( port -- ) M: unix (wait-to-write) ( port -- )
dup dup handle>> drain dup dup dup handle>> drain dup [ wait-for-port ] [ 2drop ] if ;
[ dupd wait-for-port (wait-to-write) ] [ 2drop ] if ;
M: unix io-multiplex ( ms/f -- ) M: unix io-multiplex ( ms/f -- )
mx get-global wait-for-events ; mx get-global wait-for-events ;
@ -166,7 +164,8 @@ TUPLE: mx-port < port mx ;
: multiplexer-error ( n -- ) : multiplexer-error ( n -- )
0 < [ 0 < [
err_no [ EAGAIN = ] [ EINTR = ] bi or [ (io-error) ] unless err_no [ EAGAIN = ] [ EINTR = ] bi or
[ (io-error) ] unless
] when ; ] when ;
: ?flag ( n mask symbol -- n ) : ?flag ( n mask symbol -- n )

View File

@ -111,7 +111,7 @@ M: linux-monitor dispose* ( monitor -- )
: inotify-read-loop ( port -- ) : inotify-read-loop ( port -- )
dup check-disposed dup check-disposed
dup wait-to-read dup wait-to-read drop
0 over buffer>> parse-file-notifications 0 over buffer>> parse-file-notifications
0 over buffer>> buffer-reset 0 over buffer>> buffer-reset
inotify-read-loop ; inotify-read-loop ;

View File

@ -0,0 +1,90 @@
IN: io.sockets.secure.tests
USING: accessors kernel namespaces io io.sockets
io.sockets.secure io.encodings.ascii io.streams.duplex
classes words destructors threads tools.test
concurrency.promises byte-arrays ;
\ <secure-config> must-infer
{ 1 0 } [ [ ] with-secure-context ] must-infer-as
[ ] [ <promise> "port" set ] unit-test
[ ] [
[
<secure-config>
"resource:extra/openssl/test/server.pem" >>key-file
"resource:extra/openssl/test/root.pem" >>ca-file
"resource:extra/openssl/test/dh1024.pem" >>dh-file
"password" >byte-array >>password
[
"127.0.0.1" 0 <inet4> <secure> ascii <server> [
dup addr>> addrspec>> port>> "port" get fulfill
accept [
class word-name write
] curry with-stream
] with-disposal
] with-secure-context
] "SSL server test" spawn drop
] unit-test
[ "secure" ] [
<secure-config> [
"127.0.0.1" "port" get ?promise <inet4> <secure> ascii <client> drop contents
] with-secure-context
] unit-test
! Now, see what happens if the server closes the connection prematurely
! [ ] [ <promise> "port" set ] unit-test
!
! [ ] [
! [
! <secure-config>
! "resource:extra/openssl/test/server.pem" >>key-file
! "resource:extra/openssl/test/root.pem" >>ca-file
! "resource:extra/openssl/test/dh1024.pem" >>dh-file
! "password" >byte-array >>password
! [
! "127.0.0.1" 0 <inet4> <secure> ascii <server> [
! dup addr>> addrspec>> port>> "port" get fulfill
! accept drop
! [
! dup in>> stream>> handle>> f >>connected drop
! "hello" over stream-write dup stream-flush
! ] with-disposal
! ] with-disposal
! ] with-secure-context
! ] "SSL server test" spawn drop
! ] unit-test
! [
! <secure-config> [
! "127.0.0.1" "port" get ?promise <inet4> <secure> ascii <client> drop contents
! ] with-secure-context
! ] [ \ premature-close = ] must-fail-with
! Now, try validating the certificate. This should fail because its
! actually an invalid certificate
[ ] [ <promise> "port" set ] unit-test
[ ] [
[
<secure-config>
"resource:extra/openssl/test/server.pem" >>key-file
"resource:extra/openssl/test/root.pem" >>ca-file
"resource:extra/openssl/test/dh1024.pem" >>dh-file
"password" >>password
[
"127.0.0.1" 0 <inet4> <secure> ascii <server> [
dup addr>> addrspec>> port>> "port" get fulfill
accept drop dispose
] with-disposal
] with-secure-context
] "SSL server test" spawn drop
] unit-test
[
<secure-config> [
"localhost" "port" get ?promise <inet> <secure> ascii
<client> drop dispose
] with-secure-context
] [ certificate-verify-error? ] must-fail-with

36
extra/io/unix/sockets/secure/secure.factor Normal file → Executable file
View File

@ -6,7 +6,7 @@ continuations destructors
openssl openssl.libcrypto openssl.libssl openssl openssl.libcrypto openssl.libssl
io.files io.ports io.unix.backend io.unix.sockets io.files io.ports io.unix.backend io.unix.sockets
io.encodings.ascii io.buffers io.sockets io.sockets.secure io.encodings.ascii io.buffers io.sockets io.sockets.secure
unix system ; unix system inspector ;
IN: io.unix.sockets.secure IN: io.unix.sockets.secure
M: ssl-handle handle-fd file>> handle-fd ; M: ssl-handle handle-fd file>> handle-fd ;
@ -16,7 +16,7 @@ M: ssl-handle handle-fd file>> handle-fd ;
drop drop
{ {
{ -1 [ (io-error) ] } { -1 [ (io-error) ] }
{ 0 [ "Premature EOF" throw ] } { 0 [ premature-close ] }
} case } case
] [ ] [
nip (ssl-error) nip (ssl-error)
@ -30,7 +30,7 @@ M: ssl-handle handle-fd file>> handle-fd ;
check-response check-response
{ {
{ SSL_ERROR_NONE [ swap buffer>> n>buffer f ] } { SSL_ERROR_NONE [ swap buffer>> n>buffer f ] }
{ SSL_ERROR_ZERO_RETURN [ drop eof f ] } { SSL_ERROR_ZERO_RETURN [ 2drop f ] }
{ SSL_ERROR_WANT_READ [ 2drop +input+ ] } { SSL_ERROR_WANT_READ [ 2drop +input+ ] }
{ SSL_ERROR_WANT_WRITE [ 2drop +output+ ] } { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
{ SSL_ERROR_SYSCALL [ syscall-error ] } { SSL_ERROR_SYSCALL [ syscall-error ] }
@ -69,12 +69,12 @@ M: ssl-handle drain
[ fd>> BIO_NOCLOSE BIO_new_socket dup ssl-error ] keep <ssl-handle> [ fd>> BIO_NOCLOSE BIO_new_socket dup ssl-error ] keep <ssl-handle>
[ handle>> swap dup SSL_set_bio ] keep ; [ handle>> swap dup SSL_set_bio ] keep ;
M: ssl ((client)) ( addrspec -- handle ) M: secure ((client)) ( addrspec -- handle )
addrspec>> ((client)) <ssl-socket> ; addrspec>> ((client)) <ssl-socket> ;
M: ssl parse-sockaddr addrspec>> parse-sockaddr <ssl> ; M: secure parse-sockaddr addrspec>> parse-sockaddr <secure> ;
M: ssl (get-local-address) addrspec>> (get-local-address) ; M: secure (get-local-address) addrspec>> (get-local-address) ;
: check-connect-response ( port r -- event ) : check-connect-response ( port r -- event )
check-response check-response
@ -91,13 +91,13 @@ M: ssl (get-local-address) addrspec>> (get-local-address) ;
check-connect-response dup check-connect-response dup
[ dupd wait-for-port do-ssl-connect ] [ 2drop ] if ; [ dupd wait-for-port do-ssl-connect ] [ 2drop ] if ;
M: ssl establish-connection ( client-out remote -- ) M: secure establish-connection ( client-out remote -- )
[ addrspec>> establish-connection ] [ addrspec>> establish-connection ]
[ drop do-ssl-connect ] [ drop do-ssl-connect ]
[ drop handle>> t >>connected drop ] [ drop handle>> t >>connected drop ]
2tri ; 2tri ;
M: ssl (server) addrspec>> (server) ; M: secure (server) addrspec>> (server) ;
: check-accept-response ( handle r -- event ) : check-accept-response ( handle r -- event )
over handle>> over SSL_get_error over handle>> over SSL_get_error
@ -111,12 +111,13 @@ M: ssl (server) addrspec>> (server) ;
: do-ssl-accept ( ssl-handle -- ) : do-ssl-accept ( ssl-handle -- )
dup dup handle>> SSL_accept check-accept-response dup dup dup handle>> SSL_accept check-accept-response dup
[ >r dup file>> r> wait-for-fd do-ssl-accept ] [ 2drop ] if ; [ >r dup file>> r> wait-for-fd drop do-ssl-accept ] [ 2drop ] if ;
M: ssl (accept) M: secure (accept)
[ [
addrspec>> (accept) |dispose <ssl-socket> |dispose addrspec>> (accept) >r
dup do-ssl-accept |dispose <ssl-socket> t >>connected |dispose
dup do-ssl-accept r>
] with-destructors ; ] with-destructors ;
: check-shutdown-response ( handle r -- event ) : check-shutdown-response ( handle r -- event )
@ -124,14 +125,15 @@ M: ssl (accept)
{ {
{ 1 [ drop f ] } { 1 [ drop f ] }
{ 0 [ { 0 [
dup SSL_want { dup handle>> SSL_want
{ SSL_NOTHING [ dup SSL_shutdown check-shutdown-response ] } {
{ SSL_NOTHING [ dup handle>> SSL_shutdown check-shutdown-response ] }
{ SSL_READING [ drop +input+ ] } { SSL_READING [ drop +input+ ] }
{ SSL_WRITING [ drop +output+ ] } { SSL_WRITING [ drop +output+ ] }
} case } case
] } ] }
{ -1 [ { -1 [
-1 SSL_get_error handle>> -1 SSL_get_error
{ {
{ SSL_ERROR_WANT_READ [ +input+ ] } { SSL_ERROR_WANT_READ [ +input+ ] }
{ SSL_ERROR_WANT_WRITE [ +output+ ] } { SSL_ERROR_WANT_WRITE [ +output+ ] }
@ -143,6 +145,6 @@ M: ssl (accept)
M: unix ssl-shutdown M: unix ssl-shutdown
dup connected>> [ dup connected>> [
dup handle>> dup SSL_shutdown check-shutdown-response dup dup handle>> SSL_shutdown check-shutdown-response
dup [ dupd wait-for-fd ssl-shutdown ] [ 2drop ] if dup [ dupd wait-for-fd drop ssl-shutdown ] [ 2drop ] if
] [ drop ] if ; ] [ drop ] if ;

View File

@ -8,7 +8,8 @@ accessors locals ;
QUALIFIED: windows.winsock QUALIFIED: windows.winsock
IN: io.windows.nt.backend IN: io.windows.nt.backend
SYMBOL: io-hash ! Global variable with assoc mapping overlapped to threads
SYMBOL: pending-overlapped
TUPLE: io-callback port thread ; TUPLE: io-callback port thread ;
@ -33,62 +34,41 @@ M: winnt add-completion ( win32-handle -- )
handle>> master-completion-port get-global <completion-port> drop ; handle>> master-completion-port get-global <completion-port> drop ;
: eof? ( error -- ? ) : eof? ( error -- ? )
dup ERROR_HANDLE_EOF = swap ERROR_BROKEN_PIPE = or ; [ ERROR_HANDLE_EOF = ] [ ERROR_BROKEN_PIPE = ] bi or ;
: overlapped-error? ( port n -- ? )
zero? [
GetLastError {
{ [ dup expected-io-error? ] [ 2drop t ] }
{ [ dup eof? ] [ drop t >>eof drop f ] }
[ (win32-error-string) throw ]
} cond
] [
drop t
] if ;
: get-overlapped-result ( overlapped port -- bytes-transferred )
dup handle>> handle>> rot 0 <uint>
[ 0 GetOverlappedResult overlapped-error? drop ] keep *uint ;
: save-callback ( overlapped port -- )
[
<io-callback> swap
dup alien? [ "bad overlapped in save-callback" throw ] unless
io-hash get-global set-at
] "I/O" suspend 3drop ;
: twiddle-thumbs ( overlapped port -- bytes-transferred ) : twiddle-thumbs ( overlapped port -- bytes-transferred )
[ save-callback ]
[ get-overlapped-result ]
[ nip pending-error ]
2tri ;
:: wait-for-overlapped ( ms -- overlapped ? )
master-completion-port get-global
0 <int> ! bytes
f <void*> ! key
f <void*> ! overlapped
[ [
ms INFINITE or ! timeout drop
GetQueuedCompletionStatus [ pending-overlapped get-global set-at ] curry "I/O" suspend
] keep *void* swap zero? ; {
{ [ dup integer? ] [ ] }
{ [ dup array? ] [
first dup eof?
[ drop 0 ] [ (win32-error-string) throw ] if
] }
} cond
] with-timeout ;
: lookup-callback ( overlapped -- callback ) :: wait-for-overlapped ( ms -- bytes-transferred overlapped error? )
io-hash get-global delete-at* drop master-completion-port get-global
dup io-callback? [ "no callback in io-hash" throw ] unless ; 0 <int> [ ! bytes
f <void*> ! key
f <void*> [ ! overlapped
ms INFINITE or ! timeout
GetQueuedCompletionStatus zero?
] keep *void*
] keep *int spin ;
: resume-callback ( result overlapped -- )
pending-overlapped get-global delete-at* drop resume-with ;
: handle-overlapped ( timeout -- ? ) : handle-overlapped ( timeout -- ? )
wait-for-overlapped [ wait-for-overlapped [
GetLastError dup expected-io-error? [ 2drop f ] [ >r drop GetLastError
>r lookup-callback [ thread>> ] [ port>> ] bi r> [ 1array ] [ expected-io-error? ] bi
dup eof? [ r> 2drop f ] [ r> resume-callback t ] if
[ drop t >>eof ]
[ (win32-error-string) >>error ] if drop
resume t
] if
] [ ] [
lookup-callback resume-callback t
thread>> resume t
] if ; ] if ;
M: winnt cancel-io M: winnt cancel-io
@ -99,44 +79,43 @@ M: winnt io-multiplex ( ms -- )
M: winnt init-io ( -- ) M: winnt init-io ( -- )
<master-completion-port> master-completion-port set-global <master-completion-port> master-completion-port set-global
H{ } clone io-hash set-global H{ } clone pending-overlapped set-global
windows.winsock:init-winsock ; windows.winsock:init-winsock ;
: file-error? ( n -- eof? )
zero? [
GetLastError {
{ [ dup expected-io-error? ] [ drop f ] }
{ [ dup eof? ] [ drop t ] }
[ (win32-error-string) throw ]
} cond
] [ f ] if ;
: wait-for-file ( FileArgs n port -- n )
swap file-error?
[ 2drop 0 ] [ >r lpOverlapped>> r> twiddle-thumbs ] if ;
: update-file-ptr ( n port -- ) : update-file-ptr ( n port -- )
handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ; handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ;
: finish-flush ( n port -- ) : finish-write ( n port -- )
[ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ; [ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ;
: ((wait-to-write)) ( port -- )
dup make-FileArgs
tuck setup-write WriteFile
dupd overlapped-error? [
>r lpOverlapped>> r>
[ twiddle-thumbs ] keep
[ finish-flush ] keep
dup buffer>> buffer-empty? [ drop ] [ ((wait-to-write)) ] if
] [
2drop
] if ;
M: winnt (wait-to-write) M: winnt (wait-to-write)
[ [ ((wait-to-write)) ] with-timeout ] with-destructors ; [
[ make-FileArgs dup setup-write WriteFile ]
[ wait-for-file ]
[ finish-write ]
tri
] with-destructors ;
: finish-read ( n port -- ) : finish-read ( n port -- )
over zero? [ [ update-file-ptr ] [ buffer>> n>buffer ] 2bi ;
t >>eof 2drop
] [
[ buffer>> n>buffer ] [ update-file-ptr ] 2bi
] if ;
: ((wait-to-read)) ( port -- )
dup make-FileArgs
tuck setup-read ReadFile
dupd overlapped-error? [
>r lpOverlapped>> r>
[ twiddle-thumbs ] [ finish-read ] bi
] [ 2drop ] if ;
M: winnt (wait-to-read) ( port -- ) M: winnt (wait-to-read) ( port -- )
[ [ ((wait-to-read)) ] with-timeout ] with-destructors ; [
[ make-FileArgs dup setup-read ReadFile ]
[ wait-for-file ]
[ finish-read ]
tri
] with-destructors ;

View File

@ -35,7 +35,7 @@ TUPLE: win32-monitor < monitor port ;
(make-overlapped) (make-overlapped)
[ f ReadDirectoryChangesW win32-error=0/f ] keep ; [ f ReadDirectoryChangesW win32-error=0/f ] keep ;
: read-changes ( port -- bytes ) : read-changes ( port -- bytes-transferred )
[ [
[ begin-reading-changes ] [ twiddle-thumbs ] bi [ begin-reading-changes ] [ twiddle-thumbs ] bi
] with-destructors ; ] with-destructors ;

View File

@ -1,6 +1,6 @@
! Copyright (C) 2007 Alex Chapman ! Copyright (C) 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel opengl arrays sequences jamshred.log jamshred.player jamshred.sound jamshred.tunnel math.vectors ; USING: accessors kernel opengl arrays sequences jamshred.log jamshred.player jamshred.sound jamshred.tunnel math math.constants math.vectors ;
IN: jamshred.game IN: jamshred.game
TUPLE: jamshred sounds tunnel players running quit ; TUPLE: jamshred sounds tunnel players running quit ;
@ -29,3 +29,12 @@ TUPLE: jamshred sounds tunnel players running quit ;
: mouse-moved ( x-radians y-radians jamshred -- ) : mouse-moved ( x-radians y-radians jamshred -- )
jamshred-player -rot turn-player ; jamshred-player -rot turn-player ;
: units-per-full-roll ( -- n ) 50 ;
: jamshred-roll ( jamshred n -- )
[ jamshred-player ] dip 2 pi * * units-per-full-roll / roll-player ;
: mouse-scroll-x ( jamshred x -- ) jamshred-roll ;
: mouse-scroll-y ( jamshred y -- )
neg swap jamshred-player change-player-speed ;

View File

@ -51,18 +51,18 @@ IN: jamshred.gl
GL_LIGHT0 glEnable GL_LIGHT0 glEnable
GL_FOG glEnable GL_FOG glEnable
GL_FOG_DENSITY 0.09 glFogf GL_FOG_DENSITY 0.09 glFogf
GL_FRONT GL_AMBIENT_AND_DIFFUSE glColorMaterial
GL_COLOR_MATERIAL glEnable GL_COLOR_MATERIAL glEnable
GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE glColorMaterial GL_LIGHT0 GL_POSITION F{ 0.0 0.0 0.0 1.0 } >c-float-array glLightfv
GL_LIGHT0 GL_POSITION F{ 0.0 0.0 -3.0 1.0 } >c-float-array glLightfv
GL_LIGHT0 GL_AMBIENT F{ 0.2 0.2 0.2 1.0 } >c-float-array glLightfv GL_LIGHT0 GL_AMBIENT F{ 0.2 0.2 0.2 1.0 } >c-float-array glLightfv
GL_LIGHT0 GL_DIFFUSE F{ 1.0 1.0 1.0 1.0 } >c-float-array glLightfv GL_LIGHT0 GL_DIFFUSE F{ 1.0 1.0 1.0 1.0 } >c-float-array glLightfv
GL_LIGHT0 GL_SPECULAR F{ 1.0 1.0 1.0 1.0 } >c-float-array glLightfv ; GL_LIGHT0 GL_SPECULAR F{ 1.0 1.0 1.0 1.0 } >c-float-array glLightfv ;
: player-view ( player -- ) : player-view ( player -- )
[ location>> first3 ] [ location>> ]
[ [ location>> ] [ forward>> ] bi v+ first3 ] [ [ location>> ] [ forward>> ] bi v+ ]
[ up>> first3 ] tri gluLookAt ; [ up>> ] tri gl-look-at ;
: draw-jamshred ( jamshred width height -- ) : draw-jamshred ( jamshred width height -- )
init-graphics jamshred-player dup player-view draw-tunnel ; init-graphics jamshred-player [ player-view ] [ draw-tunnel ] bi ;

View File

@ -21,9 +21,9 @@ M: jamshred-gadget draw-gadget* ( gadget -- )
dup jamshred>> quit>> [ dup jamshred>> quit>> [
drop drop
] [ ] [
dup [ jamshred>> jamshred-update ] [ jamshred>> jamshred-update ]
[ relayout-1 ] bi [ relayout-1 ]
yield jamshred-loop [ yield jamshred-loop ] tri
] if ; ] if ;
: fullscreen ( gadget -- ) : fullscreen ( gadget -- )
@ -45,7 +45,7 @@ M: jamshred-gadget ungraft* ( gadget -- )
<jamshred> >>jamshred drop ; <jamshred> >>jamshred drop ;
: pix>radians ( n m -- theta ) : pix>radians ( n m -- theta )
2 / / pi 2 * * ; / pi 4 * * ; ! 2 / / pi 2 * * ;
: x>radians ( x gadget -- theta ) : x>radians ( x gadget -- theta )
#! translate motion of x pixels to an angle #! translate motion of x pixels to an angle
@ -68,8 +68,9 @@ M: jamshred-gadget ungraft* ( gadget -- )
] 2keep >>last-hand-loc drop ; ] 2keep >>last-hand-loc drop ;
: handle-mouse-scroll ( jamshred-gadget -- ) : handle-mouse-scroll ( jamshred-gadget -- )
jamshred>> jamshred-player scroll-direction get jamshred>> scroll-direction get
second neg swap change-player-speed ; [ first mouse-scroll-x ]
[ second mouse-scroll-y ] 2bi ;
: quit ( gadget -- ) : quit ( gadget -- )
[ no-fullscreen ] [ close-window ] bi ; [ no-fullscreen ] [ close-window ] bi ;
@ -78,6 +79,10 @@ jamshred-gadget H{
{ T{ key-down f f "r" } [ jamshred-restart ] } { T{ key-down f f "r" } [ jamshred-restart ] }
{ T{ key-down f f " " } [ jamshred>> toggle-running ] } { T{ key-down f f " " } [ jamshred>> toggle-running ] }
{ T{ key-down f f "f" } [ find-world toggle-fullscreen ] } { T{ key-down f f "f" } [ find-world toggle-fullscreen ] }
{ T{ key-down f f "UP" } [ jamshred>> jamshred-player 1 swap change-player-speed ] }
{ T{ key-down f f "DOWN" } [ jamshred>> jamshred-player -1 swap change-player-speed ] }
{ T{ key-down f f "LEFT" } [ jamshred>> 1 jamshred-roll ] }
{ T{ key-down f f "RIGHT" } [ jamshred>> -1 jamshred-roll ] }
{ T{ key-down f f "q" } [ quit ] } { T{ key-down f f "q" } [ quit ] }
{ T{ motion } [ handle-mouse-motion ] } { T{ motion } [ handle-mouse-motion ] }
{ T{ mouse-scroll } [ handle-mouse-scroll ] } { T{ mouse-scroll } [ handle-mouse-scroll ] }

View File

@ -29,6 +29,9 @@ C: <oint> oint
: up-pivot ( oint theta -- ) : up-pivot ( oint theta -- )
over up>> rotate-oint ; over up>> rotate-oint ;
: forward-pivot ( oint theta -- )
over forward>> rotate-oint ;
: random-float+- ( n -- m ) : random-float+- ( n -- m )
#! find a random float between -n/2 and n/2 #! find a random float between -n/2 and n/2
dup 10000 * >fixnum random 10000 / swap 2 / - ; dup 10000 * >fixnum random 10000 / swap 2 / - ;

View File

@ -1,6 +1,6 @@
! Copyright (C) 2007 Alex Chapman ! Copyright (C) 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors colors jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel math math.constants math.order math.ranges shuffle sequences system ; USING: accessors colors combinators jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel math math.constants math.order math.ranges shuffle sequences system ;
IN: jamshred.player IN: jamshred.player
TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ; TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ;
@ -16,6 +16,9 @@ TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ;
: turn-player ( player x-radians y-radians -- ) : turn-player ( player x-radians y-radians -- )
>r over r> left-pivot up-pivot ; >r over r> left-pivot up-pivot ;
: roll-player ( player z-radians -- )
forward-pivot ;
: to-tunnel-start ( player -- ) : to-tunnel-start ( player -- )
[ tunnel>> first dup location>> ] [ tunnel>> first dup location>> ]
[ tuck (>>location) (>>nearest-segment) ] bi ; [ tuck (>>location) (>>nearest-segment) ] bi ;
@ -35,6 +38,9 @@ TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ;
: change-player-speed ( inc player -- ) : change-player-speed ( inc player -- )
[ + speed-range clamp-to-range ] change-speed drop ; [ + speed-range clamp-to-range ] change-speed drop ;
: multiply-player-speed ( n player -- )
[ * speed-range clamp-to-range ] change-speed drop ;
: distance-to-move ( player -- distance ) : distance-to-move ( player -- distance )
[ speed>> ] [ last-move>> millis dup >r swap - 1000 / * r> ] [ speed>> ] [ last-move>> millis dup >r swap - 1000 / * r> ]
[ (>>last-move) ] tri ; [ (>>last-move) ] tri ;
@ -43,8 +49,12 @@ DEFER: (move-player)
: ?bounce ( distance-remaining player -- ) : ?bounce ( distance-remaining player -- )
over 0 > [ over 0 > [
[ dup nearest-segment>> bounce ] [ sounds>> bang ] {
[ (move-player) ] tri [ dup nearest-segment>> bounce ]
[ sounds>> bang ]
[ 3/4 swap multiply-player-speed ]
[ (move-player) ]
} cleave
] [ ] [
2drop 2drop
] if ; ] if ;

View File

@ -235,13 +235,13 @@ SYMBOL: init
: init-openal ( -- ) : init-openal ( -- )
init get-global expired? [ init get-global expired? [
f f alutInit drop f f alutInit 0 = [ "Could not initialize OpenAL" throw ] when
1337 <alien> init set-global 1337 <alien> init set-global
] when ; ] when ;
: exit-openal ( -- ) : exit-openal ( -- )
init get-global expired? [ init get-global expired? [
alutExit drop alutExit 0 = [ "Could not close OpenAL" throw ] when
f init set-global f init set-global
] unless ; ] unless ;

View File

@ -154,7 +154,7 @@ MACRO: set-draw-buffers ( buffers -- )
swap glPushAttrib call glPopAttrib ; inline swap glPushAttrib call glPopAttrib ; inline
: gl-look-at ( eye focus up -- ) : gl-look-at ( eye focus up -- )
>r >r first3 r> first3 r> first3 gluLookAt ; [ first3 ] tri@ gluLookAt ;
TUPLE: sprite loc dim dim2 dlist texture ; TUPLE: sprite loc dim dim2 dlist texture ;

View File

@ -5,7 +5,8 @@
! !
! export LD_LIBRARY_PATH=/opt/local/lib ! export LD_LIBRARY_PATH=/opt/local/lib
USING: alien alien.syntax combinators kernel system ; USING: alien alien.syntax combinators kernel system namespaces
assocs parser sequences words quotations ;
IN: openssl.libssl IN: openssl.libssl
@ -176,6 +177,12 @@ FUNCTION: void SSL_CTX_set_tmp_rsa_callback ( ssl-ctx ctx, void* rsa ) ;
FUNCTION: void* BIO_f_ssl ( ) ; FUNCTION: void* BIO_f_ssl ( ) ;
: SSL_CTX_set_tmp_rsa ( ctx rsa -- n )
>r SSL_CTRL_SET_TMP_RSA 0 r> SSL_CTX_ctrl ;
: SSL_CTX_set_tmp_dh ( ctx dh -- n )
>r SSL_CTRL_SET_TMP_DH 0 r> SSL_CTX_ctrl ;
! =============================================== ! ===============================================
! x509.h ! x509.h
! =============================================== ! ===============================================
@ -191,47 +198,63 @@ FUNCTION: X509_NAME* X509_get_subject_name ( X509* a ) ;
! x509_vfy.h ! x509_vfy.h
! =============================================== ! ===============================================
: X509_V_OK 0 ; inline <<
: X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT 2 ; inline
: X509_V_ERR_UNABLE_TO_GET_CRL 3 ; inline SYMBOL: verify-messages
: X509_V_ERR_UNABLE_TO_DECRYPT_CERT_SIGNATURE 4 ; inline
: X509_V_ERR_UNABLE_TO_DECRYPT_CRL_SIGNATURE 5 ; inline H{ } clone verify-messages set-global
: X509_V_ERR_UNABLE_TO_DECODE_ISSUER_PUBLIC_KEY 6 ; inline
: X509_V_ERR_CERT_SIGNATURE_FAILURE 7 ; inline : verify-message ( n -- word ) verify-messages get-global at ;
: X509_V_ERR_CRL_SIGNATURE_FAILURE 8 ; inline
: X509_V_ERR_CERT_NOT_YET_VALID 9 ; inline : X509_V_:
: X509_V_ERR_CERT_HAS_EXPIRED 10 ; inline scan "X509_V_" prepend create-in
: X509_V_ERR_CRL_NOT_YET_VALID 11 ; inline scan-word
: X509_V_ERR_CRL_HAS_EXPIRED 12 ; inline [ 1quotation define-inline ]
: X509_V_ERR_ERROR_IN_CERT_NOT_BEFORE_FIELD 13 ; inline [ verify-messages get set-at ] 2bi ; parsing
: X509_V_ERR_ERROR_IN_CERT_NOT_AFTER_FIELD 14 ; inline
: X509_V_ERR_ERROR_IN_CRL_LAST_UPDATE_FIELD 15 ; inline >>
: X509_V_ERR_ERROR_IN_CRL_NEXT_UPDATE_FIELD 16 ; inline
: X509_V_ERR_OUT_OF_MEM 17 ; inline X509_V_: OK 0
: X509_V_ERR_DEPTH_ZERO_SELF_SIGNED_CERT 18 ; inline X509_V_: ERR_UNABLE_TO_GET_ISSUER_CERT 2
: X509_V_ERR_SELF_SIGNED_CERT_IN_CHAIN 19 ; inline X509_V_: ERR_UNABLE_TO_GET_CRL 3
: X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT_LOCALLY 20 ; inline X509_V_: ERR_UNABLE_TO_DECRYPT_CERT_SIGNATURE 4
: X509_V_ERR_UNABLE_TO_VERIFY_LEAF_SIGNATURE 21 ; inline X509_V_: ERR_UNABLE_TO_DECRYPT_CRL_SIGNATURE 5
: X509_V_ERR_CERT_CHAIN_TOO_LONG 22 ; inline X509_V_: ERR_UNABLE_TO_DECODE_ISSUER_PUBLIC_KEY 6
: X509_V_ERR_CERT_REVOKED 23 ; inline X509_V_: ERR_CERT_SIGNATURE_FAILURE 7
: X509_V_ERR_INVALID_CA 24 ; inline X509_V_: ERR_CRL_SIGNATURE_FAILURE 8
: X509_V_ERR_PATH_LENGTH_EXCEEDED 25 ; inline X509_V_: ERR_CERT_NOT_YET_VALID 9
: X509_V_ERR_INVALID_PURPOSE 26 ; inline X509_V_: ERR_CERT_HAS_EXPIRED 10
: X509_V_ERR_CERT_UNTRUSTED 27 ; inline X509_V_: ERR_CRL_NOT_YET_VALID 11
: X509_V_ERR_CERT_REJECTED 28 ; inline X509_V_: ERR_CRL_HAS_EXPIRED 12
: X509_V_ERR_SUBJECT_ISSUER_MISMATCH 29 ; inline X509_V_: ERR_ERROR_IN_CERT_NOT_BEFORE_FIELD 13
: X509_V_ERR_AKID_SKID_MISMATCH 30 ; inline X509_V_: ERR_ERROR_IN_CERT_NOT_AFTER_FIELD 14
: X509_V_ERR_AKID_ISSUER_SERIAL_MISMATCH 31 ; inline X509_V_: ERR_ERROR_IN_CRL_LAST_UPDATE_FIELD 15
: X509_V_ERR_KEYUSAGE_NO_CERTSIGN 32 ; inline X509_V_: ERR_ERROR_IN_CRL_NEXT_UPDATE_FIELD 16
: X509_V_ERR_UNABLE_TO_GET_CRL_ISSUER 33 ; inline X509_V_: ERR_OUT_OF_MEM 17
: X509_V_ERR_UNHANDLED_CRITICAL_EXTENSION 34 ; inline X509_V_: ERR_DEPTH_ZERO_SELF_SIGNED_CERT 18
: X509_V_ERR_KEYUSAGE_NO_CRL_SIGN 35 ; inline X509_V_: ERR_SELF_SIGNED_CERT_IN_CHAIN 19
: X509_V_ERR_UNHANDLED_CRITICAL_CRL_EXTENSION 36 ; inline X509_V_: ERR_UNABLE_TO_GET_ISSUER_CERT_LOCALLY 20
: X509_V_ERR_INVALID_NON_CA 37 ; inline X509_V_: ERR_UNABLE_TO_VERIFY_LEAF_SIGNATURE 21
: X509_V_ERR_PROXY_PATH_LENGTH_EXCEEDED 38 ; inline X509_V_: ERR_CERT_CHAIN_TOO_LONG 22
: X509_V_ERR_KEYUSAGE_NO_DIGITAL_SIGNATURE 39 ; inline X509_V_: ERR_CERT_REVOKED 23
: X509_V_ERR_PROXY_CERTIFICATES_NOT_ALLOWED 40 ; inline X509_V_: ERR_INVALID_CA 24
: X509_V_ERR_APPLICATION_VERIFICATION 50 ; inline X509_V_: ERR_PATH_LENGTH_EXCEEDED 25
X509_V_: ERR_INVALID_PURPOSE 26
X509_V_: ERR_CERT_UNTRUSTED 27
X509_V_: ERR_CERT_REJECTED 28
X509_V_: ERR_SUBJECT_ISSUER_MISMATCH 29
X509_V_: ERR_AKID_SKID_MISMATCH 30
X509_V_: ERR_AKID_ISSUER_SERIAL_MISMATCH 31
X509_V_: ERR_KEYUSAGE_NO_CERTSIGN 32
X509_V_: ERR_UNABLE_TO_GET_CRL_ISSUER 33
X509_V_: ERR_UNHANDLED_CRITICAL_EXTENSION 34
X509_V_: ERR_KEYUSAGE_NO_CRL_SIGN 35
X509_V_: ERR_UNHANDLED_CRITICAL_CRL_EXTENSION 36
X509_V_: ERR_INVALID_NON_CA 37
X509_V_: ERR_PROXY_PATH_LENGTH_EXCEEDED 38
X509_V_: ERR_KEYUSAGE_NO_DIGITAL_SIGNATURE 39
X509_V_: ERR_PROXY_CERTIFICATES_NOT_ALLOWED 40
X509_V_: ERR_APPLICATION_VERIFICATION 50
! =============================================== ! ===============================================
! obj_mac.h ! obj_mac.h

View File

@ -1,20 +1,21 @@
USING: io.sockets.secure io.encodings.ascii alien.strings USING: io.sockets.secure io.encodings.ascii alien.strings
openssl namespaces accessors tools.test continuations kernel ; openssl namespaces accessors tools.test continuations kernel ;
openssl ssl-backend [ openssl secure-socket-backend [
[ ] [ [ ] [
<ssl-config> <secure-config>
"resource:extra/openssl/test/server.pem" >>key-file "resource:extra/openssl/test/server.pem" >>key-file
"resource:extra/openssl/test/root.pem" >>ca-file "resource:extra/openssl/test/root.pem" >>ca-file
"password" ascii string>alien >>password "resource:extra/openssl/test/dh1024.pem" >>dh-file
[ ] with-ssl-context "password" >>password
[ ] with-secure-context
] unit-test ] unit-test
[ [
<ssl-config> <secure-config>
"resource:extra/openssl/test/server.pem" >>key-file "resource:extra/openssl/test/server.pem" >>key-file
"resource:extra/openssl/test/root.pem" >>ca-file "resource:extra/openssl/test/root.pem" >>ca-file
"wrong password" ascii string>alien >>password "wrong password" >>password
[ ] with-ssl-context [ ] with-secure-context
] must-fail ] must-fail
] with-variable ] with-variable

View File

@ -5,7 +5,7 @@ math.order combinators init alien alien.c-types alien.strings libc
continuations destructors debugger inspector continuations destructors debugger inspector
locals unicode.case locals unicode.case
openssl.libcrypto openssl.libssl openssl.libcrypto openssl.libssl
io.backend io.ports io.files io.encodings.ascii io.sockets.secure ; io.backend io.ports io.files io.encodings.8-bit io.sockets.secure ;
IN: openssl IN: openssl
! This code is based on http://www.rtfm.com/openssl-examples/ ! This code is based on http://www.rtfm.com/openssl-examples/
@ -47,7 +47,7 @@ SYMBOL: ssl-initiazed?
[ f ssl-initiazed? set-global ] "openssl" add-init-hook [ f ssl-initiazed? set-global ] "openssl" add-init-hook
TUPLE: openssl-context < ssl-context aliens ; TUPLE: openssl-context < secure-context aliens ;
: load-certificate-chain ( ctx -- ) : load-certificate-chain ( ctx -- )
dup config>> key-file>> [ dup config>> key-file>> [
@ -68,7 +68,7 @@ TUPLE: openssl-context < ssl-context aliens ;
] alien-callback ; ] alien-callback ;
: default-pasword ( ctx -- alien ) : default-pasword ( ctx -- alien )
[ config>> password>> malloc-byte-array ] [ aliens>> ] bi [ config>> password>> latin1 malloc-string ] [ aliens>> ] bi
[ push ] [ drop ] 2bi ; [ push ] [ drop ] 2bi ;
: set-default-password ( ctx -- ) : set-default-password ( ctx -- )
@ -99,25 +99,57 @@ TUPLE: openssl-context < ssl-context aliens ;
: set-verify-depth ( ctx -- ) : set-verify-depth ( ctx -- )
handle>> 1 SSL_CTX_set_verify_depth ; handle>> 1 SSL_CTX_set_verify_depth ;
M: openssl <ssl-context> ( config -- context ) TUPLE: bio handle disposed ;
: <bio> f bio boa ;
M: bio dispose* handle>> BIO_free ssl-error ;
: <file-bio> ( path -- bio )
normalize-path "r" BIO_new_file dup ssl-error <bio> ;
: load-dh-params ( ctx -- )
dup config>> dh-file>> [
[ handle>> ] [ config>> dh-file>> ] bi <file-bio> &dispose
handle>> f f f PEM_read_bio_DHparams dup ssl-error
SSL_CTX_set_tmp_dh ssl-error
] [ drop ] if ;
TUPLE: rsa handle disposed ;
: <rsa> f rsa boa ;
M: rsa dispose* handle>> RSA_free ;
: generate-eph-rsa-key ( ctx -- )
[ handle>> ]
[
config>> ephemeral-key-bits>> RSA_F4 f f RSA_generate_key
dup ssl-error <rsa> &dispose handle>>
] bi
SSL_CTX_set_tmp_rsa ssl-error ;
M: openssl <secure-context> ( config -- context )
maybe-init-ssl maybe-init-ssl
[ [
dup method>> ssl-method SSL_CTX_new dup method>> ssl-method SSL_CTX_new
dup ssl-error V{ } clone openssl-context boa |dispose dup ssl-error f V{ } clone openssl-context boa |dispose
{ {
[ load-certificate-chain ] [ load-certificate-chain ]
[ set-default-password ] [ set-default-password ]
[ use-private-key-file ] [ use-private-key-file ]
[ load-verify-locations ] [ load-verify-locations ]
[ set-verify-depth ] [ set-verify-depth ]
[ load-dh-params ]
[ generate-eph-rsa-key ]
[ ] [ ]
} cleave } cleave
] with-destructors ; ] with-destructors ;
M: openssl-context dispose M: openssl-context dispose*
dup aliens>> [ free ] each f >>aliens [ aliens>> [ free ] each ]
dup handle>> [ SSL_CTX_free ] when* f >>handle [ handle>> SSL_CTX_free ]
drop ; bi ;
TUPLE: ssl-handle file handle connected disposed ; TUPLE: ssl-handle file handle connected disposed ;
@ -127,7 +159,7 @@ M: no-ssl-context summary
drop "SSL operations must be wrapped in calls to with-ssl-context" ; drop "SSL operations must be wrapped in calls to with-ssl-context" ;
: current-ssl-context ( -- ctx ) : current-ssl-context ( -- ctx )
ssl-context get [ no-ssl-context ] unless* ; secure-context get [ no-ssl-context ] unless* ;
: <ssl-handle> ( fd -- ssl ) : <ssl-handle> ( fd -- ssl )
current-ssl-context handle>> SSL_new dup ssl-error current-ssl-context handle>> SSL_new dup ssl-error
@ -141,28 +173,24 @@ M: ssl-handle dispose*
[ file>> dispose ] [ file>> dispose ]
tri ; tri ;
ERROR: certificate-verify-error result ;
: check-verify-result ( ssl-handle -- ) : check-verify-result ( ssl-handle -- )
SSL_get_verify_result dup X509_V_OK = SSL_get_verify_result dup X509_V_OK =
[ certificate-verify-error ] [ drop ] if ; [ drop ] [ verify-message certificate-verify-error ] if ;
: common-name ( certificate -- host ) : common-name ( certificate -- host )
X509_get_subject_name X509_get_subject_name
NID_commonName 256 <byte-array> NID_commonName 256 <byte-array>
[ 256 X509_NAME_get_text_by_NID ] keep [ 256 X509_NAME_get_text_by_NID ] keep
swap -1 = [ drop f ] [ ascii alien>string ] if ; swap -1 = [ drop f ] [ latin1 alien>string ] if ;
ERROR: common-name-verify-error expected got ;
: check-common-name ( host ssl-handle -- ) : check-common-name ( host ssl-handle -- )
SSL_get_peer_certificate common-name 2dup [ >lower ] bi@ = SSL_get_peer_certificate common-name 2dup [ >lower ] bi@ =
[ 2drop ] [ common-name-verify-error ] if ; [ 2drop ] [ common-name-verify-error ] if ;
: check-certificate ( host ssl -- ) M: openssl check-certificate ( host ssl -- )
handle>> handle>>
[ nip check-verify-result ] [ nip check-verify-result ]
[ check-common-name ] [ check-common-name ]
2bi ; 2bi ;
openssl ssl-backend set-global openssl secure-socket-backend set-global

View File

@ -1,7 +1,7 @@
USING: kernel parser words continuations namespaces debugger USING: kernel parser words continuations namespaces debugger
sequences combinators splitting prettyprint sequences combinators splitting prettyprint
system io io.files io.launcher io.encodings.utf8 sequences.deep system io io.files io.launcher io.encodings.utf8 io.pipes sequences.deep
accessors multi-methods newfx shell.parser ; accessors multi-methods newfx shell.parser ;
IN: shell IN: shell
@ -95,8 +95,7 @@ METHOD: expand { object } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: pipeline-chant ( pipeline-chant -- ) : pipeline-chant ( pipeline-chant -- ) commands>> run-pipeline drop ;
drop "ix: pipelines not supported" print ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

View File

@ -1,10 +1,9 @@
! Copyright (C) 2006, 2008 Slava Pestov ! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays assocs cocoa kernel math cocoa.messages USING: alien alien.c-types arrays assocs cocoa kernel math cocoa.messages
cocoa.subclassing cocoa.classes cocoa.views cocoa.application cocoa.subclassing cocoa.classes cocoa.views cocoa.application
cocoa.pasteboard cocoa.types cocoa.windows sequences ui cocoa.pasteboard cocoa.types cocoa.windows sequences ui ui.gadgets
ui.gadgets ui.gadgets.worlds ui.gestures core-foundation ui.gadgets.worlds ui.gestures core-foundation threads combinators ;
threads combinators ;
IN: ui.cocoa.views IN: ui.cocoa.views
: send-mouse-moved ( view event -- ) : send-mouse-moved ( view event -- )
@ -360,8 +359,14 @@ CLASS: {
] ]
} ; } ;
: sync-refresh-to-screen ( GLView -- )
-> openGLContext -> CGLContextObj NSOpenGLCPSwapInterval 1 <int>
CGLSetParameter drop ;
: <FactorView> ( world -- view ) : <FactorView> ( world -- view )
FactorView over rect-dim <GLView> [ register-window ] keep ; FactorView over rect-dim <GLView>
[ sync-refresh-to-screen ] keep
[ register-window ] keep ;
CLASS: { CLASS: {
{ +superclass+ "NSObject" } { +superclass+ "NSObject" }

View File

@ -122,6 +122,7 @@ FUNCTION: void* mmap ( void* addr, size_t len, int prot, int flags, int fd, off_
FUNCTION: int munmap ( void* addr, size_t len ) ; FUNCTION: int munmap ( void* addr, size_t len ) ;
FUNCTION: uint ntohl ( uint n ) ; FUNCTION: uint ntohl ( uint n ) ;
FUNCTION: ushort ntohs ( ushort n ) ; FUNCTION: ushort ntohs ( ushort n ) ;
FUNCTION: int shutdown ( int fd, int how ) ;
FUNCTION: int open ( char* path, int flags, int prot ) ; FUNCTION: int open ( char* path, int flags, int prot ) ;