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

Merge branch 'master' into experimental

db4
Alex Chapman 2008-05-20 10:53:35 +10:00
parent 6f08e8606e f1f5ea3a77
commit 3955e646a8
46 changed files with 827 additions and 499 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
core/byte-arrays/byte-arrays-docs.factor
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." } ;

4
core/debugger/debugger.factor
View File

@ -7,7 +7,7 @@ splitting math.parser classes.tuple continuations
continuations.private combinators generic.math continuations.private combinators generic.math
classes.builtin classes compiler.units generic.standard vocabs classes.builtin classes compiler.units generic.standard vocabs
threads threads.private init kernel.private libc io.encodings threads threads.private init kernel.private libc io.encodings
mirrors accessors math.order ; mirrors accessors math.order destructors ;
IN: debugger IN: debugger
GENERIC: error. ( error -- ) GENERIC: error. ( error -- )
@ -300,6 +300,8 @@ M: bad-create summary drop "Bad parameters to create" ;
M: attempt-all-error summary drop "Nothing to attempt" ; M: attempt-all-error summary drop "Nothing to attempt" ;
M: already-disposed summary drop "Attempting to operate on disposed object" ;
<PRIVATE <PRIVATE
: init-debugger ( -- ) : init-debugger ( -- )

2
core/io/files/files-tests.factor
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
[ ] [ [ ] [

10
core/io/io-tests.factor
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

6
core/io/streams/c/c.factor
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 ;

43
extra/builder/benchmark/benchmark.factor
View File

@ -1,43 +0,0 @@
USING: kernel continuations arrays assocs sequences sorting math
io io.styles prettyprint builder.util ;
IN: builder.benchmark
! : passing-benchmarks ( table -- table )
! [ second first2 number? swap number? and ] filter ;
: passing-benchmarks ( table -- table ) [ second number? ] filter ;
! : simplify-table ( table -- table ) [ first2 second 2array ] map ;
: benchmark-difference ( old-table benchmark-result -- result-diff )
first2 >r
tuck swap at
r>
swap -
2array ;
: compare-tables ( old new -- table )
[ passing-benchmarks ] bi@
[ benchmark-difference ] with map ;
: benchmark-deltas ( -- table )
"../benchmarks" "benchmarks" [ eval-file ] bi@
compare-tables
sort-values ;
: benchmark-deltas. ( deltas -- )
standard-table-style
[
[ [ "Benchmark" write ] with-cell [ "Delta (ms)" write ] with-cell ]
with-row
[ [ swap [ write ] with-cell pprint-cell ] with-row ]
assoc-each
]
tabular-output ;
: show-benchmark-deltas ( -- )
[ benchmark-deltas benchmark-deltas. ]
[ drop "Error generating benchmark deltas" . ]
recover ;

15
extra/builder/util/util.factor
View File

@ -41,12 +41,17 @@ DEFER: to-strings
: host-name* ( -- name ) host-name "." split first ; : host-name* ( -- name ) host-name "." split first ;
! : datestamp ( -- string )
! now `{ ,[ dup timestamp-year ]
! ,[ dup timestamp-month ]
! ,[ dup timestamp-day ]
! ,[ dup timestamp-hour ]
! ,[ timestamp-minute ] }
! [ pad-00 ] map "-" join ;
: datestamp ( -- string ) : datestamp ( -- string )
now `{ ,[ dup timestamp-year ] now
,[ dup timestamp-month ] { year>> month>> day>> hour>> minute>> } <arr>
,[ dup timestamp-day ]
,[ dup timestamp-hour ]
,[ timestamp-minute ] }
[ pad-00 ] map "-" join ; [ pad-00 ] map "-" join ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

4
extra/cocoa/application/application-docs.factor
View File

@ -27,8 +27,8 @@ HELP: with-cocoa
{ $description "Sets up an autorelease pool, initializes the " { $snippet "NSApplication" } " singleton, and calls the quotation." } ; { $description "Sets up an autorelease pool, initializes the " { $snippet "NSApplication" } " singleton, and calls the quotation." } ;
HELP: do-event HELP: do-event
{ $values { "app" "an " { $snippet "NSApplication" } } } { $values { "app" "an " { $snippet "NSApplication" } } { "?" "a boolean" } }
{ $description "Processes any pending events in the queue. Does not block." } ; { $description "Processes a pending event in the queue, if any, returning a boolean indicating if there was one. Does not block." } ;
HELP: add-observer HELP: add-observer
{ $values { "observer" "an " { $snippet "NSObject" } } { "selector" string } { "name" "an " { $snippet "NSString" } } { "object" "an " { $snippet "NSObject" } } } { $values { "observer" "an " { $snippet "NSObject" } } { "selector" string } { "name" "an " { $snippet "NSString" } } { "object" "an " { $snippet "NSObject" } } }

18
extra/ftp/client/client.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays classes.singleton combinators USING: accessors arrays classes.singleton combinators
continuations io io.encodings.binary io.encodings.ascii continuations io io.encodings.binary io.encodings.utf8
io.files io.sockets kernel io.streams.duplex math io.files io.sockets kernel io.streams.duplex math
math.parser sequences splitting namespaces strings fry ftp ; math.parser sequences splitting namespaces strings fry ftp ;
IN: ftp.client IN: ftp.client
@ -56,15 +56,17 @@ IN: ftp.client
"|" split 2 tail* first string>number ; "|" split 2 tail* first string>number ;
TUPLE: remote-file TUPLE: remote-file
type permissions links owner group size month day time year name ; type permissions links owner group size month day time year
name target ;
: <remote-file> ( -- remote-file ) remote-file new ; : <remote-file> ( -- remote-file ) remote-file new ;
: parse-permissions ( remote-file str -- remote-file ) : parse-permissions ( remote-file str -- remote-file )
[ first ch>type >>type ] [ rest >>permissions ] bi ; [ first ch>type >>type ] [ rest >>permissions ] bi ;
: parse-list-9 ( lines -- seq ) : parse-list-11 ( lines -- seq )
[ [
11 f pad-right
<remote-file> swap { <remote-file> swap {
[ 0 swap nth parse-permissions ] [ 0 swap nth parse-permissions ]
[ 1 swap nth string>number >>links ] [ 1 swap nth string>number >>links ]
@ -75,6 +77,7 @@ TUPLE: remote-file
[ 6 swap nth >>day ] [ 6 swap nth >>day ]
[ 7 swap nth >>time ] [ 7 swap nth >>time ]
[ 8 swap nth >>name ] [ 8 swap nth >>name ]
[ 10 swap nth >>target ]
} cleave } cleave
] map ; ] map ;
@ -105,7 +108,8 @@ TUPLE: remote-file
dup strings>> dup strings>>
[ " " split harvest ] map [ " " split harvest ] map
dup length { dup length {
{ 9 [ parse-list-9 ] } { 11 [ parse-list-11 ] }
{ 9 [ parse-list-11 ] }
{ 8 [ parse-list-8 ] } { 8 [ parse-list-8 ] }
{ 3 [ parse-list-3 ] } { 3 [ parse-list-3 ] }
[ drop ] [ drop ]
@ -129,7 +133,7 @@ ERROR: ftp-error got expected ;
[ 229 ftp-assert ] [ parse-epsv ] bi ; [ 229 ftp-assert ] [ parse-epsv ] bi ;
: list ( ftp-client -- ftp-response ) : list ( ftp-client -- ftp-response )
host>> open-remote-port <inet> ascii <client> host>> open-remote-port <inet> utf8 <client> drop
ftp-list 150 ftp-assert ftp-list 150 ftp-assert
lines lines
<ftp-response> swap >>strings <ftp-response> swap >>strings
@ -137,14 +141,14 @@ ERROR: ftp-error got expected ;
parse-list ; parse-list ;
: ftp-get ( filename ftp-client -- ftp-response ) : ftp-get ( filename ftp-client -- ftp-response )
host>> open-remote-port <inet> binary <client> host>> open-remote-port <inet> binary <client> drop
swap swap
[ ftp-retr 150 ftp-assert drop ] [ ftp-retr 150 ftp-assert drop ]
[ binary <file-writer> stream-copy ] 2bi [ binary <file-writer> stream-copy ] 2bi
read-response dup 226 ftp-assert ; read-response dup 226 ftp-assert ;
: ftp-connect ( ftp-client -- stream ) : ftp-connect ( ftp-client -- stream )
[ host>> ] [ port>> ] bi <inet> ascii <client> ; [ host>> ] [ port>> ] bi <inet> utf8 <client> drop ;
GENERIC: ftp-download ( path obj -- ) GENERIC: ftp-download ( path obj -- )

3
extra/ftp/ftp.factor
View File

@ -7,7 +7,8 @@ IN: ftp
SINGLETON: active SINGLETON: active
SINGLETON: passive SINGLETON: passive
TUPLE: ftp-client host port user password mode state ; TUPLE: ftp-client host port user password mode state
command-promise ;
: <ftp-client> ( host -- ftp-client ) : <ftp-client> ( host -- ftp-client )
ftp-client new ftp-client new

242
extra/ftp/server/server.factor
View File

@ -1,19 +1,35 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators io io.encodings.8-bit USING: accessors combinators io io.encodings.8-bit
io.files io.server io.sockets kernel math.parser io.encodings io.encodings.binary io.encodings.utf8 io.files
namespaces sequences ftp io.unix.launcher.parser io.server io.sockets kernel math.parser namespaces sequences
unicode.case splitting assocs ; ftp io.unix.launcher.parser unicode.case splitting assocs
classes io.server destructors calendar io.timeouts
io.streams.duplex threads continuations
concurrency.promises byte-arrays ;
IN: ftp.server IN: ftp.server
SYMBOL: client SYMBOL: client
SYMBOL: stream
TUPLE: ftp-command raw tokenized ; TUPLE: ftp-command raw tokenized ;
: <ftp-command> ( -- obj ) : <ftp-command> ( -- obj )
ftp-command new ; ftp-command new ;
TUPLE: ftp-get path ;
: <ftp-get> ( path -- obj )
ftp-get new swap >>path ;
TUPLE: ftp-put path ;
: <ftp-put> ( path -- obj )
ftp-put new swap >>path ;
TUPLE: ftp-list ;
C: <ftp-list> ftp-list
: read-command ( -- ftp-command ) : read-command ( -- ftp-command )
<ftp-command> readln <ftp-command> readln
[ >>raw ] [ tokenize-command >>tokenized ] bi ; [ >>raw ] [ tokenize-command >>tokenized ] bi ;
@ -32,77 +48,179 @@ TUPLE: ftp-command raw tokenized ;
swap >>n swap >>n
send-response ; send-response ;
: ftp-error ( string -- )
500 "Unrecognized command: " rot append server-response ;
: send-banner ( -- ) : send-banner ( -- )
220 "Welcome to " host-name append server-response ; 220 "Welcome to " host-name append server-response ;
: send-PASS-request ( -- )
331 "Please specify the password." server-response ;
: anonymous-only ( -- ) : anonymous-only ( -- )
530 "This FTP server is anonymous only." server-response ; 530 "This FTP server is anonymous only." server-response ;
: parse-USER ( ftp-command -- ) : handle-QUIT ( obj -- )
tokenized>> second client get swap >>user drop ;
: send-login-response ( -- )
! client get
230 "Login successful" server-response ;
: parse-PASS ( ftp-command -- )
tokenized>> second client get swap >>password drop ;
: send-quit-response ( ftp-command -- )
drop 221 "Goodbye." server-response ; drop 221 "Goodbye." server-response ;
: ftp-error ( string -- ) : handle-USER ( ftp-command -- )
500 "Unrecognized command: " rot append server-response ; [
tokenized>> second client get swap >>user drop
331 "Please specify the password." server-response
] [
2drop "bad USER" ftp-error
] recover ;
: send-type-error ( -- ) : handle-PASS ( ftp-command -- )
"TYPE is binary only" ftp-error ; [
tokenized>> second client get swap >>password drop
230 "Login successful" server-response
] [
2drop "PASS error" ftp-error
] recover ;
: send-type-success ( string -- ) ERROR: type-error type ;
200 "Switching to " rot " mode" 3append server-response ;
: parse-TYPE ( obj -- ) : handle-TYPE ( obj -- )
[
tokenized>> second >upper { tokenized>> second >upper {
{ "IMAGE" [ "Binary" send-type-success ] } { "IMAGE" [ "Binary" ] }
{ "I" [ "Binary" send-type-success ] } { "I" [ "Binary" ] }
[ drop send-type-error ] [ type-error ]
} case ; } case
200 "Switching to " rot " mode" 3append server-response
] [
2drop "TYPE is binary only" ftp-error
] recover ;
: pwd-response ( -- ) : handle-PWD ( obj -- )
drop
257 current-directory get "\"" swap "\"" 3append server-response ; 257 current-directory get "\"" swap "\"" 3append server-response ;
! : random-local-inet ( -- spec ) : random-local-server ( -- server )
! remote-address get class new 0 >>port ; remote-address get class new 0 >>port binary <server> ;
! : handle-LIST ( -- )
! random-local-inet ascii <server> ;
: handle-STOR ( obj -- ) : handle-STOR ( obj -- )
; [
drop
] [
2drop
] recover ;
! EPRT |2|::1|62138| ! EPRT |2|::1|62138|
! : handle-EPRT ( obj -- ) ! : handle-EPRT ( obj -- )
! tokenized>> second "|" split harvest ; ! tokenized>> second "|" split harvest ;
! : handle-EPSV ( obj -- )
! 229 "Entering Extended Passive Mode (|||"
! random-local-inet ! get port number>string
! "|)" 3append server-response ;
! LPRT 6,16,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,2,242,186
: handle-LPRT ( obj -- )
tokenized>> "," split ;
: start-directory ( -- ) : start-directory ( -- )
150 "Here comes the directory listing." server-response ; 150 "Here comes the directory listing." server-response ;
: finish-directory ( -- ) : finish-directory ( -- )
226 "Directory send OK." server-response ; 226 "Directory send OK." server-response ;
: send-directory-list ( stream -- ) GENERIC: service-command ( stream obj -- )
[ directory-list write ] with-output-stream ;
M: ftp-list service-command ( stream obj -- )
drop
start-directory
[
utf8 encode-output
directory-list [ ftp-send ] each
] with-output-stream
finish-directory ;
: start-file-transfer ( path -- )
150 "Opening BINARY mode data connection for "
rot
[ file-name ] [
" " swap file-info file-info-size number>string
"(" " bytes)." swapd 3append append
] bi 3append server-response ;
: finish-file-transfer ( -- )
226 "File send OK." server-response ;
M: ftp-get service-command ( stream obj -- )
[
path>>
[ start-file-transfer ]
[ binary <file-reader> swap stream-copy ] bi
finish-file-transfer
] [
3drop "File transfer failed" ftp-error
] recover ;
M: ftp-put service-command ( stream obj -- )
[
path>>
[ start-file-transfer ]
[ binary <file-reader> swap stream-copy ] bi
finish-file-transfer
] [
3drop "File transfer failed" ftp-error
] recover ;
: extended-passive-loop ( server -- )
[
[
|dispose
30 seconds over set-timeout
accept drop &dispose
client get command-promise>>
30 seconds ?promise-timeout
service-command
]
[ client get f >>command-promise drop ]
[ ] cleanup
] with-destructors ;
: if-command-promise ( quot -- )
>r client get command-promise>> r>
[ "Establish an active or passive connection first" ftp-error ] if* ;
: handle-LIST ( obj -- )
drop
[ <ftp-list> swap fulfill ] if-command-promise ;
: handle-SIZE ( obj -- )
[
tokenized>> second file-info size>>
213 swap number>string server-response
] [
2drop
550 "Could not get file size" server-response
] recover ;
: handle-RETR ( obj -- )
[ tokenized>> second <ftp-get> swap fulfill ]
curry if-command-promise ;
: 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
"|)" 3append server-response
] if ;
! LPRT 6,16,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,2,242,186
! : handle-LPRT ( obj -- ) tokenized>> "," split ;
ERROR: not-a-directory ;
: handle-CWD ( obj -- )
[
tokenized>> second dup directory? [
set-current-directory
250 "Directory successully changed." server-response
] [
not-a-directory throw
] if
] [
2drop
550 "Failed to change directory." server-response
] recover ;
: unrecognized-command ( obj -- ) raw>> ftp-error ; : unrecognized-command ( obj -- ) raw>> ftp-error ;
@ -111,28 +229,30 @@ TUPLE: ftp-command raw tokenized ;
[ >>raw ] [ >>raw ]
[ tokenize-command >>tokenized ] bi [ tokenize-command >>tokenized ] bi
dup tokenized>> first >upper { dup tokenized>> first >upper {
{ "USER" [ parse-USER send-PASS-request t ] } { "USER" [ handle-USER t ] }
{ "PASS" [ parse-PASS send-login-response t ] } { "PASS" [ handle-PASS t ] }
{ "ACCT" [ drop "ACCT unimplemented" ftp-error t ] } { "ACCT" [ drop "ACCT unimplemented" ftp-error t ] }
! { "CWD" [ ] } { "CWD" [ handle-CWD t ] }
! { "XCWD" [ ] }
! { "CDUP" [ ] } ! { "CDUP" [ ] }
! { "SMNT" [ ] } ! { "SMNT" [ ] }
! { "REIN" [ drop client get reset-ftp-client t ] } ! { "REIN" [ drop client get reset-ftp-client t ] }
{ "QUIT" [ send-quit-response f ] } { "QUIT" [ handle-QUIT f ] }
! { "PORT" [ ] } ! { "PORT" [ ] }
! { "PASV" [ ] } ! { "PASV" [ ] }
! { "MODE" [ ] } ! { "MODE" [ ] }
{ "TYPE" [ parse-TYPE t ] } { "TYPE" [ handle-TYPE t ] }
! { "STRU" [ ] } ! { "STRU" [ ] }
! { "ALLO" [ ] } ! { "ALLO" [ ] }
! { "REST" [ ] } ! { "REST" [ ] }
! { "STOR" [ handle-STOR t ] } ! { "STOR" [ handle-STOR t ] }
! { "STOU" [ ] } ! { "STOU" [ ] }
! { "RETR" [ ] } { "RETR" [ handle-RETR t ] }
! { "LIST" [ drop handle-LIST t ] } { "LIST" [ handle-LIST t ] }
{ "SIZE" [ handle-SIZE t ] }
! { "NLST" [ ] } ! { "NLST" [ ] }
! { "APPE" [ ] } ! { "APPE" [ ] }
! { "RNFR" [ ] } ! { "RNFR" [ ] }
@ -140,7 +260,7 @@ TUPLE: ftp-command raw tokenized ;
! { "DELE" [ ] } ! { "DELE" [ ] }
! { "RMD" [ ] } ! { "RMD" [ ] }
! { "MKD" [ ] } ! { "MKD" [ ] }
{ "PWD" [ drop pwd-response t ] } { "PWD" [ handle-PWD t ] }
! { "ABOR" [ ] } ! { "ABOR" [ ] }
! { "SYST" [ drop ] } ! { "SYST" [ drop ] }
@ -150,18 +270,20 @@ TUPLE: ftp-command raw tokenized ;
! { "SITE" [ ] } ! { "SITE" [ ] }
! { "NOOP" [ ] } ! { "NOOP" [ ] }
! { "EPRT" [ handle-eprt ] } ! { "EPRT" [ handle-EPRT ] }
! { "LPRT" [ handle-lprt ] } ! { "LPRT" [ handle-LPRT ] }
! { "EPSV" [ drop handle-epsv t ] } { "EPSV" [ handle-EPSV t ] }
! { "LPSV" [ drop handle-lpsv t ] } ! { "LPSV" [ drop handle-LPSV t ] }
[ drop unrecognized-command t ] [ drop unrecognized-command t ]
} case [ handle-client-loop ] when ; } case [ handle-client-loop ] when ;
: handle-client ( -- ) : handle-client ( -- )
[
"" [ "" [
host-name <ftp-client> client set host-name <ftp-client> client set
send-banner handle-client-loop send-banner handle-client-loop
] with-directory ; ] with-directory
] with-destructors ;
: ftpd ( port -- ) : ftpd ( port -- )
internet-server "ftp.server" internet-server "ftp.server"

2
extra/globs/globs.factor
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 ;

98
extra/html/parser/analyzer/analyzer.factor
View File

@ -1,8 +1,11 @@
USING: assocs html.parser kernel math sequences strings ascii USING: assocs html.parser kernel math sequences strings ascii
arrays shuffle unicode.case namespaces splitting http arrays shuffle unicode.case namespaces splitting http
sequences.lib ; sequences.lib accessors io combinators http.client ;
IN: html.parser.analyzer IN: html.parser.analyzer
: scrape-html ( url -- vector )
http-get parse-html ;
: (find-relative) : (find-relative)
[ >r + dup r> ?nth* [ 2drop f f ] unless ] [ 2drop f ] if ; [ >r + dup r> ?nth* [ 2drop f f ] unless ] [ 2drop f ] if ;
@ -41,8 +44,8 @@ IN: html.parser.analyzer
: remove-blank-text ( vector -- vector' ) : remove-blank-text ( vector -- vector' )
[ [
dup tag-name text = [ dup name>> text = [
tag-text [ blank? ] all? not text>> [ blank? ] all? not
] [ ] [
drop t drop t
] if ] if
@ -50,49 +53,50 @@ IN: html.parser.analyzer
: trim-text ( vector -- vector' ) : trim-text ( vector -- vector' )
[ [
dup tag-name text = [ dup name>> text = [
[ tag-text [ blank? ] trim ] keep [ text>> [ blank? ] trim ] keep
[ set-tag-text ] keep [ set-tag-text ] keep
] when ] when
] map ; ] map ;
: find-by-id ( id vector -- vector ) : find-by-id ( id vector -- vector )
[ tag-attributes "id" swap at = ] with filter ; [ attributes>> "id" swap at = ] with filter ;
: find-by-class ( id vector -- vector ) : find-by-class ( id vector -- vector )
[ tag-attributes "class" swap at = ] with filter ; [ attributes>> "class" swap at = ] with filter ;
: find-by-name ( str vector -- vector ) : find-by-name ( str vector -- vector )
>r >lower r> >r >lower r>
[ tag-name = ] with filter ; [ name>> = ] with filter ;
: find-first-name ( str vector -- i/f tag/f ) : find-first-name ( str vector -- i/f tag/f )
>r >lower r> >r >lower r>
[ tag-name = ] with find ; [ name>> = ] with find ;
: find-matching-close ( str vector -- i/f tag/f ) : find-matching-close ( str vector -- i/f tag/f )
>r >lower r> >r >lower r>
[ [ tag-name = ] keep tag-closing? and ] with find ; [ [ name>> = ] keep closing?>> and ] with find ;
: find-by-attribute-key ( key vector -- vector ) : find-by-attribute-key ( key vector -- vector )
>r >lower r> >r >lower r>
[ tag-attributes at ] with filter [ attributes>> at ] with filter
sift ; sift ;
: find-by-attribute-key-value ( value key vector -- vector ) : find-by-attribute-key-value ( value key vector -- vector )
>r >lower r> >r >lower r>
[ tag-attributes at over = ] with filter nip [ attributes>> at over = ] with filter nip
sift ; sift ;
: find-first-attribute-key-value ( value key vector -- i/f tag/f ) : find-first-attribute-key-value ( value key vector -- i/f tag/f )
>r >lower r> >r >lower r>
[ tag-attributes at over = ] with find rot drop ; [ attributes>> at over = ] with find rot drop ;
: find-between* ( i/f tag/f vector -- vector ) : find-between* ( i/f tag/f vector -- vector )
pick integer? [ pick integer? [
rot tail-slice rot tail-slice
>r tag-name r> >r name>> r>
[ find-matching-close drop 1+ ] keep swap head [ find-matching-close drop dup [ 1+ ] when ] keep
swap [ head ] [ first ] if*
] [ ] [
3drop V{ } clone 3drop V{ } clone
] if ; ] if ;
@ -105,31 +109,63 @@ IN: html.parser.analyzer
: find-between-first ( string vector -- vector' ) : find-between-first ( string vector -- vector' )
[ find-first-name ] keep find-between ; [ find-first-name ] keep find-between ;
: find-between-all ( vector quot -- seq )
[ [ [ closing?>> not ] bi and ] curry find-all ] curry
[ [ >r first2 r> find-between* ] curry map ] bi ;
: tag-link ( tag -- link/f ) : tag-link ( tag -- link/f )
tag-attributes [ "href" swap at ] [ f ] if* ; attributes>> [ "href" swap at ] [ f ] if* ;
: find-links ( vector -- vector ) : find-links ( vector -- vector' )
[ tag-name "a" = ] filter [ [ name>> "a" = ] [ attributes>> "href" swap at ] bi and ]
[ tag-link ] filter ; find-between-all ;
: link. ( vector -- )
[ second text>> write bl ]
[ first tag-link write nl ] bi ;
: find-by-text ( seq quot -- tag ) : find-by-text ( seq quot -- tag )
[ dup tag-name text = ] prepose find drop ; [ dup name>> text = ] prepose find drop ;
: find-opening-tags-by-name ( name seq -- seq ) : find-opening-tags-by-name ( name seq -- seq )
[ [ tag-name = ] keep tag-closing? not and ] with find-all ; [ [ name>> = ] keep closing?>> not and ] with find-all ;
: href-contains? ( str tag -- ? ) : href-contains? ( str tag -- ? )
tag-attributes "href" swap at* [ subseq? ] [ 2drop f ] if ; attributes>> "href" swap at* [ subseq? ] [ 2drop f ] if ;
: find-forms ( vector -- vector' )
"form" over find-opening-tags-by-name
over [ >r first2 r> find-between* ] curry map
[ [ name>> { "form" "input" } member? ] filter ] map ;
: find-html-objects ( string vector -- vector' )
find-opening-tags-by-name
over [ >r first2 r> find-between* ] curry map ;
: form-action ( vector -- string )
[ name>> "form" = ] find nip
attributes>> "action" swap at ;
: hidden-form-values ( vector -- strings )
[ attributes>> "type" swap at "hidden" = ] filter ;
: input. ( tag -- )
dup name>> print
attributes>>
[ bl bl bl bl [ write "=" write ] [ write bl ] bi* nl ] assoc-each ;
: form. ( vector -- )
[ closing?>> not ] filter
[
{
{ [ dup name>> "form" = ]
[ "form action: " write attributes>> "action" swap at print
] }
{ [ dup name>> "input" = ] [ input. ] }
[ drop ]
} cond
] each ;
: query>assoc* ( str -- hash ) : query>assoc* ( str -- hash )
"?" split1 nip query>assoc ; "?" split1 nip query>assoc ;
! clear "http://fark.com" http-get parse-html find-links [ "go.pl" swap start ] filter [ "=" split peek ] map
! clear "http://www.sailwx.info/shiptrack/cruiseships.phtml" http-get parse-html remove-blank-text
! "a" over find-opening-tags-by-name
! [ nip "shipposition.phtml?call=GBTT" swap href-contains? ] assoc-filter
! first first 8 + over nth
! tag-attributes "href" swap at query>assoc*
! "lat" over at "lon" rot at

4
extra/html/parser/parser.factor
View File

@ -91,7 +91,7 @@ SYMBOL: tagstack
read-dtd read-dtd
] if ; ] if ;
: read-tag ( -- ) : read-tag ( -- string )
[ get-char CHAR: > = get-char CHAR: < = or ] take-until [ get-char CHAR: > = get-char CHAR: < = or ] take-until
get-char CHAR: < = [ next* ] unless ; get-char CHAR: < = [ next* ] unless ;
@ -135,7 +135,7 @@ SYMBOL: tagstack
(parse-tag) make-tag push-tag (parse-tag) make-tag push-tag
] if ; ] if ;
: (parse-html) ( tag -- ) : (parse-html) ( -- )
get-next [ get-next [
parse-text parse-text
parse-tag parse-tag

8
extra/http/http-tests.factor
View File

@ -176,11 +176,11 @@ test-db [
main-responder set main-responder set
[ 1237 httpd ] "HTTPD test" spawn drop [ 1237 httpd ] "HTTPD test" spawn drop
yield
] with-scope ] with-scope
] unit-test ] unit-test
[ ] [ 100 sleep ] unit-test
[ t ] [ [ t ] [
"resource:extra/http/test/foo.html" ascii file-contents "resource:extra/http/test/foo.html" ascii file-contents
"http://localhost:1237/nested/foo.html" http-get = "http://localhost:1237/nested/foo.html" http-get =
@ -222,7 +222,7 @@ test-db [
] with-scope ] with-scope
] unit-test ] unit-test
[ ] [ 1000 sleep ] unit-test [ ] [ 100 sleep ] unit-test
: 404? [ download-failed? ] [ response>> code>> 404 = ] bi and ; : 404? [ download-failed? ] [ response>> code>> 404 = ] bi and ;
@ -249,7 +249,7 @@ test-db [
] with-scope ] with-scope
] unit-test ] unit-test
[ ] [ 1000 sleep ] unit-test [ ] [ 100 sleep ] unit-test
[ "Hi" ] [ "http://localhost:1237/" http-get ] unit-test [ "Hi" ] [ "http://localhost:1237/" http-get ] unit-test

2
extra/http/http.factor
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 ;

5
extra/io/mmap/mmap-tests.factor
View File

@ -8,8 +8,3 @@ IN: io.mmap.tests
[ 5 ] [ "mmap-test-file.txt" temp-file dup file-info size>> [ length ] with-mapped-file ] unit-test [ 5 ] [ "mmap-test-file.txt" temp-file dup file-info size>> [ length ] with-mapped-file ] unit-test
[ "22345" ] [ "mmap-test-file.txt" temp-file ascii file-contents ] unit-test [ "22345" ] [ "mmap-test-file.txt" temp-file ascii file-contents ] unit-test
[ "mmap-test-file.txt" temp-file delete-file ] ignore-errors [ "mmap-test-file.txt" temp-file delete-file ] ignore-errors
[ ] [ "a" "mmap-grow-test.txt" temp-file ascii set-file-contents ] unit-test
[ 1 ] [ "mmap-grow-test.txt" temp-file file-info size>> ] unit-test
[ ] [ "mmap-grow-test.txt" temp-file 100 [ drop ] with-mapped-file ] unit-test
[ 100 ] [ "mmap-grow-test.txt" temp-file file-info size>> ] unit-test

22
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? [
[ [
@ -89,5 +89,23 @@ os { winnt linux macosx } member? [
] with-monitors ] with-monitors
! Out-of-scope disposal should not fail ! Out-of-scope disposal should not fail
[ "" resource-path t <monitor> ] with-monitors dispose [ ] [ [ "" resource-path f <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

27
extra/io/ports/ports-docs.factor
View File

@ -22,7 +22,6 @@ $nl
{ $subsection init-stdio } { $subsection init-stdio }
{ $subsection io-multiplex } { $subsection io-multiplex }
"Per-port native I/O protocol:" "Per-port native I/O protocol:"
{ $subsection init-handle }
{ $subsection (wait-to-read) } { $subsection (wait-to-read) }
{ $subsection (wait-to-write) } { $subsection (wait-to-write) }
"Additionally, the I/O backend must provide an implementation of the " { $link dispose } " generic word." ; "Additionally, the I/O backend must provide an implementation of the " { $link dispose } " generic word." ;
@ -30,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." } ;
@ -46,10 +37,6 @@ HELP: input-port
HELP: output-port HELP: output-port
{ $class-description "The class of ports implementing the output stream protocol." } ; { $class-description "The class of ports implementing the output stream protocol." } ;
HELP: init-handle
{ $values { "handle" "a native handle identifying an I/O resource" } }
{ $contract "Prepares a native handle for use by the port; called by " { $link <port> } "." } ;
HELP: <port> HELP: <port>
{ $values { "handle" "a native handle identifying an I/O resource" } { "class" class } { "port" "a new " { $link port } } } { $values { "handle" "a native handle identifying an I/O resource" } { "class" class } { "port" "a new " { $link port } } }
{ $description "Creates a new " { $link port } " with no buffer." } { $description "Creates a new " { $link port } " with no buffer." }
@ -70,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" } }

37
extra/io/ports/ports.factor
View File

@ -10,20 +10,14 @@ 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>> ;
M: port set-timeout (>>timeout) ; M: port set-timeout (>>timeout) ;
GENERIC: init-handle ( handle -- )
: <port> ( handle class -- port ) : <port> ( handle class -- port )
new new swap >>handle ; inline
swap dup init-handle >>handle ; inline
: pending-error ( port -- )
[ f ] change-error drop [ throw ] when* ;
TUPLE: buffered-port < port buffer ; TUPLE: buffered-port < port buffer ;
@ -31,27 +25,24 @@ TUPLE: buffered-port < port buffer ;
<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
@ -109,15 +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 -- )
dup check-disposed [ check-disposed ] [ port-flush ] bi ;
[ flush-port ] [ pending-error ] 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 ]

12
extra/io/server/server.factor
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

6
extra/io/sockets/secure/secure-tests.factor
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

60
extra/io/sockets/secure/secure.factor
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" ;

4
extra/io/sockets/sockets-docs.factor
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" }
@ -130,7 +130,7 @@ HELP: <server>
{ $errors "Throws an error if the address is already in use, or if it if the system forbids access." } ; { $errors "Throws an error if the address is already in use, or if it if the system forbids access." } ;
HELP: accept HELP: accept
{ $values { "server" "a handle" } { "client" "a bidirectional stream" } { "addrspec" "an address specifier" } } { $values { "server" "a handle" } { "client" "a bidirectional stream" } { "remote" "an address specifier" } }
{ $description "Waits for a connection to a server socket created by " { $link <server> } ", and outputs a bidirectional stream when the connection has been established. The encoding of this stream is the one that was passed to the server constructor." } { $description "Waits for a connection to a server socket created by " { $link <server> } ", and outputs a bidirectional stream when the connection has been established. The encoding of this stream is the one that was passed to the server constructor." }
{ $errors "Throws an error if the server socket is closed or otherwise is unavailable." } ; { $errors "Throws an error if the server socket is closed or otherwise is unavailable." } ;

26
extra/io/sockets/sockets-tests.factor Normal file → Executable file
View File

@ -1,5 +1,6 @@
IN: io.sockets.tests IN: io.sockets.tests
USING: io.sockets sequences math tools.test ; USING: io.sockets sequences math tools.test namespaces accessors
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
@ -44,3 +45,26 @@ USING: io.sockets sequences math tools.test ;
[ B{ 0 1 0 2 0 0 0 0 0 0 0 0 0 3 0 4 } T{ inet6 } inet-ntop ] unit-test [ B{ 0 1 0 2 0 0 0 0 0 0 0 0 0 3 0 4 } T{ inet6 } inet-ntop ] unit-test
[ t ] [ "localhost" 80 f resolve-host length 1 >= ] unit-test [ t ] [ "localhost" 80 f resolve-host length 1 >= ] unit-test
! Smoke-test UDP
[ ] [ "127.0.0.1" 0 <inet4> <datagram> "datagram1" set ] unit-test
[ ] [ "datagram1" get addr>> "addr1" set ] unit-test
[ f ] [ "addr1" get port>> 0 = ] unit-test
[ ] [ "127.0.0.1" 0 <inet4> <datagram> "datagram2" set ] unit-test
[ ] [ "datagram2" get addr>> "addr2" set ] unit-test
[ f ] [ "addr2" get port>> 0 = ] unit-test
[ ] [ B{ 1 2 3 4 } "addr2" get "datagram1" get send ] unit-test
[ B{ 1 2 3 4 } ] [ "datagram2" get receive "from" set ] unit-test
[ ] [ B{ 4 3 2 1 } "from" get "datagram2" get send ] unit-test
[ B{ 4 3 2 1 } t ] [ "datagram1" get receive "addr2" get = ] unit-test
[ ] [ "datagram1" 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

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

@ -156,6 +156,11 @@ GENERIC: (get-local-address) ( handle remote -- sockaddr )
: get-local-address ( handle remote -- local ) : get-local-address ( handle remote -- local )
[ (get-local-address) ] keep parse-sockaddr ; [ (get-local-address) ] keep parse-sockaddr ;
GENERIC: (get-remote-address) ( handle remote -- sockaddr )
: get-remote-address ( handle local -- remote )
[ (get-remote-address) ] keep parse-sockaddr ;
GENERIC: establish-connection ( client-out remote -- ) GENERIC: establish-connection ( client-out remote -- )
GENERIC: ((client)) ( remote -- handle ) GENERIC: ((client)) ( remote -- handle )
@ -180,7 +185,7 @@ M: object (client) ( remote -- client-in client-out local )
SYMBOL: local-address SYMBOL: local-address
: with-client ( addrspec encoding quot -- ) : with-client ( remote encoding quot -- )
>r <client> [ local-address set ] curry >r <client> [ local-address set ] curry
r> compose with-stream ; inline r> compose with-stream ; inline
@ -198,22 +203,26 @@ GENERIC: (server) ( addrspec -- handle )
[ drop server-port <port> ] [ get-local-address ] 2bi [ drop server-port <port> ] [ get-local-address ] 2bi
>>addr r> >>encoding ; >>addr r> >>encoding ;
GENERIC: (accept) ( server addrspec -- handle ) GENERIC: (accept) ( server addrspec -- handle sockaddr )
: accept ( server -- client remote ) : accept ( server -- client remote )
[ [
dup addr>> dup addr>>
[ (accept) ] keep [ (accept) ] keep
[ drop dup <ports> ] [ get-local-address ] 2bi parse-sockaddr swap
-rot dup <ports>
] keep encoding>> <encoder-duplex> swap ; ] keep encoding>> <encoder-duplex> swap ;
TUPLE: datagram-port < port addr ; TUPLE: datagram-port < port addr ;
HOOK: (datagram) io-backend ( addr -- datagram ) HOOK: (datagram) io-backend ( addr -- datagram )
: <datagram> ( addr -- datagram ) : <datagram> ( addrspec -- datagram )
dup (datagram) datagram-port <port> swap >>addr ; [
[ (datagram) |dispose ] keep
[ drop datagram-port <port> ] [ get-local-address ] 2bi
>>addr
] with-destructors ;
: check-datagram-port ( port -- port ) : check-datagram-port ( port -- port )
dup check-disposed dup check-disposed
@ -221,7 +230,7 @@ HOOK: (datagram) io-backend ( addr -- datagram )
HOOK: (receive) io-backend ( datagram -- packet addrspec ) HOOK: (receive) io-backend ( datagram -- packet addrspec )
: receive ( datagram -- packet sockaddr ) : receive ( datagram -- packet addrspec )
check-datagram-port check-datagram-port
[ (receive) ] [ addr>> ] bi parse-sockaddr ; [ (receive) ] [ addr>> ] bi parse-sockaddr ;
@ -278,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 ;

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

@ -13,7 +13,15 @@ GENERIC: handle-fd ( handle -- fd )
TUPLE: fd fd disposed ; TUPLE: fd fd disposed ;
: <fd> ( n -- fd ) f fd boa ; : <fd> ( n -- fd )
#! We drop the error code rather than calling io-error,
#! since on OS X 10.3, this operation fails from init-io
#! when running the Factor.app (presumably because fd 0 and
#! 1 are closed).
[ F_SETFL O_NONBLOCK fcntl drop ]
[ F_SETFD FD_CLOEXEC fcntl drop ]
[ f fd boa ]
tri ;
M: fd dispose* fd>> close-file ; M: fd dispose* fd>> close-file ;
@ -48,32 +56,24 @@ M: mx remove-output-callbacks writes>> delete-at* drop ;
GENERIC: wait-for-events ( ms mx -- ) GENERIC: wait-for-events ( ms mx -- )
TUPLE: unix-io-error error port ;
: report-error ( error port -- )
tuck unix-io-error boa >>error drop ;
: input-available ( fd mx -- ) : input-available ( fd mx -- )
remove-input-callbacks [ resume ] each ; remove-input-callbacks [ resume ] each ;
: 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 over report-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
@ -82,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 ;
@ -101,19 +107,7 @@ SYMBOL: +output+
: io-error ( n -- ) 0 < [ (io-error) ] when ; : io-error ( n -- ) 0 < [ (io-error) ] when ;
M: fd init-handle ( fd -- )
#! We drop the error code rather than calling io-error,
#! since on OS X 10.3, this operation fails from init-io
#! when running the Factor.app (presumably because fd 0 and
#! 1 are closed).
fd>>
[ F_SETFL O_NONBLOCK fcntl drop ]
[ F_SETFD FD_CLOEXEC fcntl drop ] bi ;
! 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 ]
@ -126,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) ]
@ -153,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 ;
@ -172,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 )

13
extra/io/unix/linux/monitors/monitors.factor
View File

@ -5,7 +5,7 @@ io.files io.buffers io.monitors io.ports io.timeouts
io.unix.backend io.unix.select io.encodings.utf8 io.unix.backend io.unix.select io.encodings.utf8
unix.linux.inotify assocs namespaces threads continuations init unix.linux.inotify assocs namespaces threads continuations init
math math.bitfields sets alien alien.strings alien.c-types math math.bitfields sets alien alien.strings alien.c-types
vocabs.loader accessors system hashtables ; vocabs.loader accessors system hashtables destructors ;
IN: io.unix.linux.monitors IN: io.unix.linux.monitors
SYMBOL: watches SYMBOL: watches
@ -23,9 +23,9 @@ TUPLE: linux-monitor < monitor wd inotify watches disposed ;
: wd>monitor ( wd -- monitor ) watches get at ; : wd>monitor ( wd -- monitor ) watches get at ;
: <inotify> ( -- port/f ) : <inotify> ( -- port/f )
inotify_init dup 0 < [ drop f ] [ <input-port> ] if ; inotify_init dup 0 < [ drop f ] [ <fd> <input-port> ] if ;
: inotify-fd inotify get handle>> ; : inotify-fd inotify get handle>> handle-fd ;
: check-existing ( wd -- ) : check-existing ( wd -- )
watches get key? [ watches get key? [
@ -57,8 +57,10 @@ M: linux (monitor) ( path recursive? mailbox -- monitor )
M: linux-monitor dispose* ( monitor -- ) M: linux-monitor dispose* ( monitor -- )
[ [ wd>> ] [ watches>> ] bi delete-at ] [ [ wd>> ] [ watches>> ] bi delete-at ]
[ [
[ inotify>> handle>> ] [ wd>> ] bi dup inotify>> disposed>> [ drop ] [
[ inotify>> handle>> handle-fd ] [ wd>> ] bi
inotify_rm_watch io-error inotify_rm_watch io-error
] if
] bi ; ] bi ;
: ignore-flags? ( mask -- ? ) : ignore-flags? ( mask -- ? )
@ -108,7 +110,8 @@ M: linux-monitor dispose* ( monitor -- )
] if ; ] if ;
: inotify-read-loop ( port -- ) : inotify-read-loop ( port -- )
dup wait-to-read dup check-disposed
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 ;

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

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

90
extra/io/unix/sockets/secure/secure-tests.factor Normal file
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 ;

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

@ -13,7 +13,7 @@ EXCLUDE: io.sockets => accept ;
IN: io.unix.sockets IN: io.unix.sockets
: socket-fd ( domain type -- fd ) : socket-fd ( domain type -- fd )
0 socket dup io-error <fd> |dispose dup init-handle ; 0 socket dup io-error <fd> |dispose ;
: set-socket-option ( fd level opt -- ) : set-socket-option ( fd level opt -- )
>r >r handle-fd r> r> 1 <int> "int" heap-size setsockopt io-error ; >r >r handle-fd r> r> 1 <int> "int" heap-size setsockopt io-error ;
@ -26,6 +26,10 @@ M: object (get-local-address) ( handle remote -- sockaddr )
>r handle-fd r> empty-sockaddr/size <int> >r handle-fd r> empty-sockaddr/size <int>
[ getsockname io-error ] 2keep drop ; [ getsockname io-error ] 2keep drop ;
M: object (get-remote-address) ( handle local -- sockaddr )
>r handle-fd r> empty-sockaddr/size <int>
[ getpeername io-error ] 2keep drop ;
: init-client-socket ( fd -- ) : init-client-socket ( fd -- )
SOL_SOCKET SO_OOBINLINE set-socket-option ; SOL_SOCKET SO_OOBINLINE set-socket-option ;
@ -66,16 +70,17 @@ M: object (server) ( addrspec -- handle )
dup handle-fd 10 listen io-error dup handle-fd 10 listen io-error
] with-destructors ; ] with-destructors ;
: do-accept ( server addrspec -- fd ) : do-accept ( server addrspec -- fd sockaddr )
[ handle>> handle-fd ] [ empty-sockaddr/size <int> ] bi* accept ; inline [ handle>> handle-fd ] [ empty-sockaddr/size <int> ] bi*
[ accept ] 2keep drop ; inline
M: object (accept) ( server addrspec -- fd ) M: object (accept) ( server addrspec -- fd sockaddr )
2dup do-accept 2dup do-accept
{ {
{ [ dup 0 >= ] [ 2nip <fd> ] } { [ over 0 >= ] [ >r 2nip <fd> r> ] }
{ [ err_no EINTR = ] [ drop (accept) ] } { [ err_no EINTR = ] [ 2drop (accept) ] }
{ [ err_no EAGAIN = ] [ { [ err_no EAGAIN = ] [
drop 2drop
[ drop +input+ wait-for-port ] [ drop +input+ wait-for-port ]
[ (accept) ] [ (accept) ]
2bi 2bi

8
extra/io/windows/mmap/mmap-tests.factor Normal file
View File

@ -0,0 +1,8 @@
USING: io io.mmap io.files kernel tools.test continuations
sequences io.encodings.ascii accessors ;
IN: io.windows.mmap.tests
[ ] [ "a" "mmap-grow-test.txt" temp-file ascii set-file-contents ] unit-test
[ 1 ] [ "mmap-grow-test.txt" temp-file file-info size>> ] unit-test
[ ] [ "mmap-grow-test.txt" temp-file 100 [ [ ] change-each ] with-mapped-file ] unit-test
[ 100 ] [ "mmap-grow-test.txt" temp-file file-info size>> ] unit-test

135
extra/io/windows/nt/backend/backend.factor
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 ;

2
extra/io/windows/nt/monitors/monitors.factor
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 ;

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

@ -82,17 +82,27 @@ TUPLE: AcceptEx-args port
AcceptEx-args >tuple*< AcceptEx drop AcceptEx-args >tuple*< AcceptEx drop
winsock-error-string [ throw ] when* ; winsock-error-string [ throw ] when* ;
M: object (accept) ( server addr -- handle ) : extract-remote-address ( AcceptEx -- sockaddr )
[ {
[ lpOutputBuffer*>> ]
[ dwReceiveDataLength*>> ]
[ dwLocalAddressLength*>> ]
[ dwRemoteAddressLength*>> ]
} cleave
f <void*>
0 <int>
f <void*>
[ 0 <int> GetAcceptExSockaddrs ] keep *void* ;
M: object (accept) ( server addr -- handle sockaddr )
[ [
<AcceptEx-args> <AcceptEx-args>
{ {
[ call-AcceptEx ] [ call-AcceptEx ]
[ wait-for-socket drop ] [ wait-for-socket drop ]
[ sAcceptSocket*>> opened-socket ] [ sAcceptSocket*>> <win32-socket> ]
[ port>> pending-error ] [ extract-remote-address ]
} cleave } cleave
] curry with-timeout
] with-destructors ; ] with-destructors ;
TUPLE: WSARecvFrom-args port TUPLE: WSARecvFrom-args port
@ -121,17 +131,16 @@ TUPLE: WSARecvFrom-args port
WSARecvFrom-args >tuple*< WSARecvFrom socket-error* ; WSARecvFrom-args >tuple*< WSARecvFrom socket-error* ;
: parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr ) : parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr )
[ lpBuffers*>> WSABUF-buf swap memory>byte-array ] [ lpFrom*>> ] bi ; [ lpBuffers*>> WSABUF-buf swap memory>byte-array ]
[ [ lpFrom*>> ] [ lpFromLen*>> *int ] bi memory>byte-array ] bi ;
M: winnt (receive) ( datagram -- packet addrspec ) M: winnt (receive) ( datagram -- packet addrspec )
[ [
<WSARecvFrom-args> <WSARecvFrom-args>
{
[ call-WSARecvFrom ] [ call-WSARecvFrom ]
[ wait-for-socket ] [ wait-for-socket ]
[ port>> pending-error ]
[ parse-WSARecvFrom ] [ parse-WSARecvFrom ]
} cleave tri
] with-destructors ; ] with-destructors ;
TUPLE: WSASendTo-args port TUPLE: WSASendTo-args port
@ -166,6 +175,5 @@ M: winnt (send) ( packet addrspec datagram -- )
<WSASendTo-args> <WSASendTo-args>
[ call-WSASendTo ] [ call-WSASendTo ]
[ wait-for-socket drop ] [ wait-for-socket drop ]
[ port>> pending-error ] bi
tri
] with-destructors ; ] with-destructors ;

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

@ -30,6 +30,10 @@ M: object (get-local-address) ( socket addrspec -- sockaddr )
>r handle>> r> empty-sockaddr/size <int> >r handle>> r> empty-sockaddr/size <int>
[ getsockname socket-error ] 2keep drop ; [ getsockname socket-error ] 2keep drop ;
M: object (get-remote-address) ( socket addrspec -- sockaddr )
>r handle>> r> empty-sockaddr/size <int>
[ getpeername socket-error ] 2keep drop ;
: bind-socket ( win32-socket sockaddr len -- ) : bind-socket ( win32-socket sockaddr len -- )
>r >r handle>> r> r> bind socket-error ; >r >r handle>> r> r> bind socket-error ;

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

@ -24,9 +24,6 @@ TUPLE: win32-file < win32-handle ptr ;
: <win32-file> ( handle -- win32-file ) : <win32-file> ( handle -- win32-file )
win32-file new-win32-handle ; win32-file new-win32-handle ;
M: win32-file init-handle ( handle -- )
drop ;
HOOK: CreateFile-flags io-backend ( DWORD -- DWORD ) HOOK: CreateFile-flags io-backend ( DWORD -- DWORD )
HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f ) HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f )
HOOK: add-completion io-backend ( port -- ) HOOK: add-completion io-backend ( port -- )

4
extra/openal/openal.factor
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 ;

107
extra/openssl/libssl/libssl.factor
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

15
extra/openssl/openssl-tests.factor
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

66
extra/openssl/openssl.factor
View File

@ -5,7 +5,7 @@ math.order combinators init alien alien.c-types alien.strings libc
continuations destructors debugger inspector 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,14 +159,12 @@ 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
f f ssl-handle boa ; f f ssl-handle boa ;
M: ssl-handle init-handle file>> init-handle ;
HOOK: ssl-shutdown io-backend ( handle -- ) HOOK: ssl-shutdown io-backend ( handle -- )
M: ssl-handle dispose* M: ssl-handle dispose*
@ -143,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

4
extra/shell/parser/parser.factor
View File

@ -23,8 +23,8 @@ TUPLE: factor-expr expr ;
pipeline-expr new pipeline-expr new
over [ 1st ] [ 4th [ 1st ] map ] [ 5th ] tri suffix prefix-on >>commands over [ 1st ] [ 4th [ 1st ] map ] [ 5th ] tri suffix prefix-on >>commands
over 2nd >>stdin over 2nd >>stdin
over 5th >>stdout over 6th >>stdout
swap 6th >>background ; swap 7th >>background ;
: ast>single-quoted-expr ( ast -- obj ) : ast>single-quoted-expr ( ast -- obj )
2nd >string single-quoted-expr boa ; 2nd >string single-quoted-expr boa ;

5
extra/shell/shell.factor
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 ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

3
extra/unix/unix.factor
View File

@ -26,6 +26,8 @@ TYPEDEF: uint socklen_t
: ESRCH 3 ; inline : ESRCH 3 ; inline
: EEXIST 17 ; inline : EEXIST 17 ; inline
: NGROUPS_MAX 16 ; inline
C-STRUCT: group C-STRUCT: group
{ "char*" "gr_name" } { "char*" "gr_name" }
{ "char*" "gr_passwd" } { "char*" "gr_passwd" }
@ -120,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 ) ;

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

@ -168,6 +168,7 @@ FUNCTION: int send ( SOCKET s, char* buf, int len, int flags ) ;
FUNCTION: int recv ( SOCKET s, char* buf, int len, int flags ) ; FUNCTION: int recv ( SOCKET s, char* buf, int len, int flags ) ;
FUNCTION: int getsockname ( SOCKET s, sockaddr_in* address, int* addrlen ) ; FUNCTION: int getsockname ( SOCKET s, sockaddr_in* address, int* addrlen ) ;
FUNCTION: int getpeername ( SOCKET s, sockaddr_in* address, int* addrlen ) ;
TYPEDEF: uint SERVICETYPE TYPEDEF: uint SERVICETYPE
TYPEDEF: OVERLAPPED WSAOVERLAPPED TYPEDEF: OVERLAPPED WSAOVERLAPPED