Merge branch 'master' of git://factorcode.org/git/factor
Bruno Deferrari
commit
bdebbd2537
|
|
@ -6,12 +6,12 @@ ARTICLE: "stream-binary" "Working with binary data"
|
|||
$nl
|
||||
"There are two ways to order the bytes making up an integer; " { $emphasis "little endian" } " byte order outputs the least significant byte first, and the most significant byte last, whereas " { $emphasis "big endian" } " is the other way around."
|
||||
$nl
|
||||
"Consider the hexadecimal integer "{ $snippet "HEX: cafebabe" } ". Big endian byte order yields the following sequence of bytes:"
|
||||
"Consider the hexadecimal integer "{ $snippet "HEX: cafebabe" } ". Little endian byte order yields the following sequence of bytes:"
|
||||
{ $table
|
||||
{ "Byte:" "1" "2" "3" "4" }
|
||||
{ "Value:" { $snippet "be" } { $snippet "ba" } { $snippet "fe" } { $snippet "ca" } }
|
||||
}
|
||||
"Compare this with little endian byte order:"
|
||||
"Compare this with big endian byte order:"
|
||||
{ $table
|
||||
{ "Byte:" "1" "2" "3" "4" }
|
||||
{ "Value:" { $snippet "ca" } { $snippet "fe" } { $snippet "ba" } { $snippet "be" } }
|
||||
|
|
|
|||
|
|
@ -821,8 +821,8 @@ HELP: 3append
|
|||
|
||||
HELP: subseq
|
||||
{ $values { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "seq" sequence } { "subseq" "a new sequence" } }
|
||||
{ $description "Outputs a new sequence consisting of all elements starting from and including " { $snippet "m" } ", and up to but not including " { $snippet "n" } "." }
|
||||
{ $errors "Throws an error if " { $snippet "m" } " or " { $snippet "n" } " is out of bounds." } ;
|
||||
{ $description "Outputs a new sequence consisting of all elements starting from and including " { $snippet "from" } ", and up to but not including " { $snippet "to" } "." }
|
||||
{ $errors "Throws an error if " { $snippet "from" } " or " { $snippet "to" } " is out of bounds." } ;
|
||||
|
||||
HELP: clone-like
|
||||
{ $values { "seq" sequence } { "exemplar" sequence } { "newseq" "a new sequence" } }
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ io.encodings io.encodings.binary io.encodings.utf8 io.files
|
|||
io.server io.sockets kernel math.parser namespaces sequences
|
||||
ftp io.unix.launcher.parser unicode.case splitting assocs
|
||||
classes io.server destructors calendar io.timeouts
|
||||
io.streams.duplex threads continuations
|
||||
io.streams.duplex threads continuations math
|
||||
concurrency.promises byte-arrays ;
|
||||
IN: ftp.server
|
||||
|
||||
|
|
@ -78,24 +78,34 @@ C: <ftp-list> ftp-list
|
|||
|
||||
ERROR: type-error type ;
|
||||
|
||||
: parse-type ( string -- string' )
|
||||
>upper {
|
||||
{ "IMAGE" [ "Binary" ] }
|
||||
{ "I" [ "Binary" ] }
|
||||
[ type-error ]
|
||||
} case ;
|
||||
|
||||
: handle-TYPE ( obj -- )
|
||||
[
|
||||
tokenized>> second >upper {
|
||||
{ "IMAGE" [ "Binary" ] }
|
||||
{ "I" [ "Binary" ] }
|
||||
[ type-error ]
|
||||
} case
|
||||
tokenized>> second parse-type
|
||||
200 "Switching to " rot " mode" 3append server-response
|
||||
] [
|
||||
2drop "TYPE is binary only" ftp-error
|
||||
] recover ;
|
||||
|
||||
: random-local-server ( -- server )
|
||||
remote-address get class new 0 >>port binary <server> ;
|
||||
|
||||
: port>bytes ( port -- hi lo )
|
||||
[ -8 shift ] keep [ HEX: ff bitand ] bi@ ;
|
||||
|
||||
: handle-PWD ( obj -- )
|
||||
drop
|
||||
257 current-directory get "\"" swap "\"" 3append server-response ;
|
||||
|
||||
: random-local-server ( -- server )
|
||||
remote-address get class new 0 >>port binary <server> ;
|
||||
: handle-SYST ( obj -- )
|
||||
drop
|
||||
215 "UNIX Type: L8" server-response ;
|
||||
|
||||
: handle-STOR ( obj -- )
|
||||
[
|
||||
|
|
@ -156,7 +166,7 @@ M: ftp-put service-command ( stream obj -- )
|
|||
3drop "File transfer failed" ftp-error
|
||||
] recover ;
|
||||
|
||||
: extended-passive-loop ( server -- )
|
||||
: passive-loop ( server -- )
|
||||
[
|
||||
[
|
||||
|dispose
|
||||
|
|
@ -191,16 +201,28 @@ M: ftp-put service-command ( stream obj -- )
|
|||
[ tokenized>> second <ftp-get> swap fulfill ]
|
||||
curry if-command-promise ;
|
||||
|
||||
: expect-connection ( -- port )
|
||||
random-local-server
|
||||
client get <promise> >>command-promise drop
|
||||
[ [ passive-loop ] curry in-thread ]
|
||||
[ addr>> port>> ] bi ;
|
||||
|
||||
: handle-PASV ( obj -- )
|
||||
drop client get passive >>mode drop
|
||||
expect-connection
|
||||
[
|
||||
"Entering Passive Mode (127,0,0,1," %
|
||||
port>bytes [ number>string ] bi@ "," swap 3append %
|
||||
")" %
|
||||
] "" make 227 swap server-response ;
|
||||
|
||||
: handle-EPSV ( obj -- )
|
||||
drop
|
||||
client get command-promise>> [
|
||||
"You already have a passive stream" ftp-error
|
||||
] [
|
||||
229 "Entering Extended Passive Mode (|||"
|
||||
random-local-server
|
||||
client get <promise> >>command-promise drop
|
||||
[ [ B extended-passive-loop ] curry in-thread ]
|
||||
[ addr>> port>> number>string ] bi
|
||||
expect-connection number>string
|
||||
"|)" 3append server-response
|
||||
] if ;
|
||||
|
||||
|
|
@ -241,7 +263,7 @@ ERROR: not-a-directory ;
|
|||
{ "QUIT" [ handle-QUIT f ] }
|
||||
|
||||
! { "PORT" [ ] }
|
||||
! { "PASV" [ ] }
|
||||
{ "PASV" [ handle-PASV t ] }
|
||||
! { "MODE" [ ] }
|
||||
{ "TYPE" [ handle-TYPE t ] }
|
||||
! { "STRU" [ ] }
|
||||
|
|
@ -263,7 +285,7 @@ ERROR: not-a-directory ;
|
|||
{ "PWD" [ handle-PWD t ] }
|
||||
! { "ABOR" [ ] }
|
||||
|
||||
! { "SYST" [ drop ] }
|
||||
{ "SYST" [ handle-SYST t ] }
|
||||
! { "STAT" [ ] }
|
||||
! { "HELP" [ ] }
|
||||
|
||||
|
|
|
|||
|
|
@ -2,85 +2,60 @@ 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 ;
|
||||
concurrency.promises byte-arrays locals ;
|
||||
|
||||
\ <secure-config> must-infer
|
||||
{ 1 0 } [ [ ] with-secure-context ] must-infer-as
|
||||
|
||||
[ ] [ <promise> "port" set ] unit-test
|
||||
|
||||
[ ] [
|
||||
: with-test-context
|
||||
<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
|
||||
swap with-secure-context ;
|
||||
|
||||
:: server-test ( quot -- )
|
||||
[
|
||||
<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
|
||||
quot call
|
||||
] curry with-stream
|
||||
] with-disposal
|
||||
] with-secure-context
|
||||
] "SSL server test" spawn drop
|
||||
] unit-test
|
||||
] with-test-context
|
||||
] "SSL server test" spawn drop ;
|
||||
|
||||
[ "secure" ] [
|
||||
: client-test
|
||||
<secure-config> [
|
||||
"127.0.0.1" "port" get ?promise <inet4> <secure> ascii <client> drop contents
|
||||
] with-secure-context
|
||||
] unit-test
|
||||
] with-secure-context ;
|
||||
|
||||
[ ] [ [ class word-name write ] server-test ] unit-test
|
||||
|
||||
[ "secure" ] [ client-test ] 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
|
||||
[ ] [ <promise> "port" set ] 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
|
||||
[ ] [
|
||||
[
|
||||
drop
|
||||
input-stream get stream>> handle>> f >>connected drop
|
||||
"hello" write flush
|
||||
] server-test
|
||||
] unit-test
|
||||
|
||||
[ client-test ] [ 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
|
||||
[ ] [ [ drop ] server-test ] unit-test
|
||||
|
||||
[
|
||||
<secure-config> [
|
||||
|
|
|
|||
|
|
@ -125,12 +125,14 @@ M: secure (accept)
|
|||
{
|
||||
{ 1 [ drop f ] }
|
||||
{ 0 [
|
||||
dup handle>> SSL_want
|
||||
{
|
||||
{ SSL_NOTHING [ dup handle>> SSL_shutdown check-shutdown-response ] }
|
||||
{ SSL_READING [ drop +input+ ] }
|
||||
{ SSL_WRITING [ drop +output+ ] }
|
||||
} case
|
||||
dup handle>> dup f 0 SSL_read 2dup SSL_get_error
|
||||
{
|
||||
{ SSL_ERROR_ZERO_RETURN [ 2drop dup handle>> SSL_shutdown check-shutdown-response ] }
|
||||
{ SSL_ERROR_WANT_READ [ 3drop +input+ ] }
|
||||
{ SSL_ERROR_WANT_WRITE [ 3drop +output+ ] }
|
||||
{ SSL_ERROR_SYSCALL [ syscall-error ] }
|
||||
{ SSL_ERROR_SSL [ (ssl-error) ] }
|
||||
} case
|
||||
] }
|
||||
{ -1 [
|
||||
handle>> -1 SSL_get_error
|
||||
|
|
|
|||
Loading…
Reference in New Issue