Merge branch 'master' of factorcode.org:/git/factor
commit
e755471dc7
|
@ -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
|
||||||
|
|
||||||
[ ] [
|
[ ] [
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
||||||
|
|
|
@ -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 ) ;
|
||||||
|
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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" } }
|
||||||
|
|
|
@ -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 ]
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
|
||||||
|
|
|
@ -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" ;
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
||||||
|
|
|
@ -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 )
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
||||||
|
|
|
@ -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 ] }
|
||||||
|
|
|
@ -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 / - ;
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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" }
|
||||||
|
|
|
@ -120,6 +120,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 ) ;
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue