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

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

db4
U-SLAVA-DFB8FF805\Slava 2008-05-19 19:54:07 -05:00
parent 8256fc1b42 f1f5ea3a77
commit fff3f601e3
20 changed files with 302 additions and 152 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
{ $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." } ;

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

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

3
extra/ftp/ftp.factor
View File

@ -7,7 +7,8 @@ IN: ftp
SINGLETON: active
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 new

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

@ -1,19 +1,35 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators io io.encodings.8-bit
io.files io.server io.sockets kernel math.parser
namespaces sequences ftp io.unix.launcher.parser
unicode.case splitting assocs ;
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
concurrency.promises byte-arrays ;
IN: ftp.server
SYMBOL: client
SYMBOL: stream
TUPLE: ftp-command raw tokenized ;
: <ftp-command> ( -- obj )
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 )
<ftp-command> readln
[ >>raw ] [ tokenize-command >>tokenized ] bi ;
@ -32,77 +48,179 @@ TUPLE: ftp-command raw tokenized ;
swap >>n
send-response ;
: ftp-error ( string -- )
500 "Unrecognized command: " rot append server-response ;
: send-banner ( -- )
220 "Welcome to " host-name append server-response ;
: send-PASS-request ( -- )
331 "Please specify the password." server-response ;
: anonymous-only ( -- )
530 "This FTP server is anonymous only." server-response ;
: parse-USER ( ftp-command -- )
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 -- )
: handle-QUIT ( obj -- )
drop 221 "Goodbye." server-response ;
: ftp-error ( string -- )
500 "Unrecognized command: " rot append server-response ;
: handle-USER ( ftp-command -- )
[
tokenized>> second client get swap >>user drop
331 "Please specify the password." server-response
] [
2drop "bad USER" ftp-error
] recover ;
: send-type-error ( -- )
"TYPE is binary only" ftp-error ;
: handle-PASS ( ftp-command -- )
[
tokenized>> second client get swap >>password drop
230 "Login successful" server-response
] [
2drop "PASS error" ftp-error
] recover ;
: send-type-success ( string -- )
200 "Switching to " rot " mode" 3append server-response ;
ERROR: type-error type ;
: parse-TYPE ( obj -- )
tokenized>> second >upper {
{ "IMAGE" [ "Binary" send-type-success ] }
{ "I" [ "Binary" send-type-success ] }
[ drop send-type-error ]
} case ;
: handle-TYPE ( obj -- )
[
tokenized>> second >upper {
{ "IMAGE" [ "Binary" ] }
{ "I" [ "Binary" ] }
[ type-error ]
} 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 ;
! : random-local-inet ( -- spec )
! remote-address get class new 0 >>port ;
! : handle-LIST ( -- )
! random-local-inet ascii <server> ;
: random-local-server ( -- server )
remote-address get class new 0 >>port binary <server> ;
: handle-STOR ( obj -- )
;
[
drop
] [
2drop
] recover ;
! EPRT |2|::1|62138|
! : handle-EPRT ( obj -- )
! 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 ( -- )
150 "Here comes the directory listing." server-response ;
: finish-directory ( -- )
226 "Directory send OK." server-response ;
: send-directory-list ( stream -- )
[ directory-list write ] with-output-stream ;
GENERIC: service-command ( stream obj -- )
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 ;
@ -111,28 +229,30 @@ TUPLE: ftp-command raw tokenized ;
[ >>raw ]
[ tokenize-command >>tokenized ] bi
dup tokenized>> first >upper {
{ "USER" [ parse-USER send-PASS-request t ] }
{ "PASS" [ parse-PASS send-login-response t ] }
{ "USER" [ handle-USER t ] }
{ "PASS" [ handle-PASS t ] }
{ "ACCT" [ drop "ACCT unimplemented" ftp-error t ] }
! { "CWD" [ ] }
{ "CWD" [ handle-CWD t ] }
! { "XCWD" [ ] }
! { "CDUP" [ ] }
! { "SMNT" [ ] }
! { "REIN" [ drop client get reset-ftp-client t ] }
{ "QUIT" [ send-quit-response f ] }
{ "QUIT" [ handle-QUIT f ] }
! { "PORT" [ ] }
! { "PASV" [ ] }
! { "MODE" [ ] }
{ "TYPE" [ parse-TYPE t ] }
{ "TYPE" [ handle-TYPE t ] }
! { "STRU" [ ] }
! { "ALLO" [ ] }
! { "REST" [ ] }
! { "STOR" [ handle-STOR t ] }
! { "STOU" [ ] }
! { "RETR" [ ] }
! { "LIST" [ drop handle-LIST t ] }
{ "RETR" [ handle-RETR t ] }
{ "LIST" [ handle-LIST t ] }
{ "SIZE" [ handle-SIZE t ] }
! { "NLST" [ ] }
! { "APPE" [ ] }
! { "RNFR" [ ] }
@ -140,7 +260,7 @@ TUPLE: ftp-command raw tokenized ;
! { "DELE" [ ] }
! { "RMD" [ ] }
! { "MKD" [ ] }
{ "PWD" [ drop pwd-response t ] }
{ "PWD" [ handle-PWD t ] }
! { "ABOR" [ ] }
! { "SYST" [ drop ] }
@ -150,18 +270,20 @@ TUPLE: ftp-command raw tokenized ;
! { "SITE" [ ] }
! { "NOOP" [ ] }
! { "EPRT" [ handle-eprt ] }
! { "LPRT" [ handle-lprt ] }
! { "EPSV" [ drop handle-epsv t ] }
! { "LPSV" [ drop handle-lpsv t ] }
! { "EPRT" [ handle-EPRT ] }
! { "LPRT" [ handle-LPRT ] }
{ "EPSV" [ handle-EPSV t ] }
! { "LPSV" [ drop handle-LPSV t ] }
[ drop unrecognized-command t ]
} case [ handle-client-loop ] when ;
: handle-client ( -- )
"" [
host-name <ftp-client> client set
send-banner handle-client-loop
] with-directory ;
[
"" [
host-name <ftp-client> client set
send-banner handle-client-loop
] with-directory
] with-destructors ;
: ftpd ( port -- )
internet-server "ftp.server"

2
extra/globs/globs.factor
View File

@ -35,4 +35,4 @@ PRIVATE>
: <glob> 'glob' just parse-1 just ;
: 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
arrays shuffle unicode.case namespaces splitting http
sequences.lib ;
sequences.lib accessors io combinators http.client ;
IN: html.parser.analyzer
: scrape-html ( url -- vector )
http-get parse-html ;
: (find-relative)
[ >r + dup r> ?nth* [ 2drop f f ] unless ] [ 2drop f ] if ;
@ -41,8 +44,8 @@ IN: html.parser.analyzer
: remove-blank-text ( vector -- vector' )
[
dup tag-name text = [
tag-text [ blank? ] all? not
dup name>> text = [
text>> [ blank? ] all? not
] [
drop t
] if
@ -50,49 +53,50 @@ IN: html.parser.analyzer
: trim-text ( vector -- vector' )
[
dup tag-name text = [
[ tag-text [ blank? ] trim ] keep
dup name>> text = [
[ text>> [ blank? ] trim ] keep
[ set-tag-text ] keep
] when
] map ;
: 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 )
[ tag-attributes "class" swap at = ] with filter ;
[ attributes>> "class" swap at = ] with filter ;
: find-by-name ( str vector -- vector )
>r >lower r>
[ tag-name = ] with filter ;
[ name>> = ] with filter ;
: find-first-name ( str vector -- i/f tag/f )
>r >lower r>
[ tag-name = ] with find ;
[ name>> = ] with find ;
: find-matching-close ( str vector -- i/f tag/f )
>r >lower r>
[ [ tag-name = ] keep tag-closing? and ] with find ;
[ [ name>> = ] keep closing?>> and ] with find ;
: find-by-attribute-key ( key vector -- vector )
>r >lower r>
[ tag-attributes at ] with filter
[ attributes>> at ] with filter
sift ;
: find-by-attribute-key-value ( value key vector -- vector )
>r >lower r>
[ tag-attributes at over = ] with filter nip
[ attributes>> at over = ] with filter nip
sift ;
: find-first-attribute-key-value ( value key vector -- i/f tag/f )
>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 )
pick integer? [
rot tail-slice
>r tag-name r>
[ find-matching-close drop 1+ ] keep swap head
>r name>> r>
[ find-matching-close drop dup [ 1+ ] when ] keep
swap [ head ] [ first ] if*
] [
3drop V{ } clone
] if ;
@ -105,31 +109,63 @@ IN: html.parser.analyzer
: find-between-first ( string vector -- vector' )
[ 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-attributes [ "href" swap at ] [ f ] if* ;
attributes>> [ "href" swap at ] [ f ] if* ;
: find-links ( vector -- vector )
[ tag-name "a" = ] filter
[ tag-link ] filter ;
: find-links ( vector -- vector' )
[ [ name>> "a" = ] [ attributes>> "href" swap at ] bi and ]
find-between-all ;
: link. ( vector -- )
[ second text>> write bl ]
[ first tag-link write nl ] bi ;
: 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 )
[ [ tag-name = ] keep tag-closing? not and ] with find-all ;
[ [ name>> = ] keep closing?>> not and ] with find-all ;
: 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 )
"?" 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
] if ;
: read-tag ( -- )
: read-tag ( -- string )
[ get-char CHAR: > = get-char CHAR: < = or ] take-until
get-char CHAR: < = [ next* ] unless ;
@ -135,7 +135,7 @@ SYMBOL: tagstack
(parse-tag) make-tag push-tag
] if ;
: (parse-html) ( tag -- )
: (parse-html) ( -- )
get-next [
parse-text
parse-tag

2
extra/http/http.factor
View File

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

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

@ -62,12 +62,8 @@ HELP: (wait-to-read)
{ $contract "Suspends the current thread until the port's buffer has data available for reading." } ;
HELP: wait-to-read
{ $values { "port" input-port } }
{ $description "If the port's buffer has unread data, returns immediately, otherwise suspends the current thread until some data is available for reading." } ;
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." } ;
{ $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. 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: can-write?
{ $values { "len" "a positive integer" } { "buffer" buffer } { "?" "a boolean" } }

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

@ -25,27 +25,24 @@ TUPLE: buffered-port < port buffer ;
<port>
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 <buffered-port> ;
HOOK: (wait-to-read) io-backend ( port -- )
: wait-to-read ( port -- )
dup buffer>> buffer-empty? [ (wait-to-read) ] [ drop ] if ;
: unless-eof ( port quot -- value )
>r dup buffer>> buffer-empty? over eof>> and
[ f >>eof drop f ] r> if ; inline
: wait-to-read ( port -- eof? )
dup buffer>> buffer-empty? [
dup (wait-to-read) buffer>> buffer-empty?
] [ drop f ] if ;
M: input-port stream-read1
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 )
[ wait-to-read ] keep
[ dupd buffer>> buffer-read ] unless-eof nip ;
dup wait-to-read [ 2drop f ] [ buffer>> buffer-read ] if ;
M: input-port stream-read-partial ( max stream -- byte-array/f )
dup check-disposed

2
extra/io/sockets/sockets-docs.factor
View File

@ -37,7 +37,7 @@ ARTICLE: "network-packet" "Packet-oriented networking"
{ $subsection receive }
"Packet-oriented sockets are closed by calling " { $link dispose } "."
$nl
"Address specifiers have the following interpretation with connection-oriented networking words:"
"Address specifiers have the following interpretation with packet-oriented networking words:"
{ $list
{ { $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" }

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

@ -108,9 +108,6 @@ M: io-timeout summary drop "I/O operation timed out" ;
: io-error ( n -- ) 0 < [ (io-error) ] when ;
! Readers
: eof ( reader -- )
dup buffer>> buffer-empty? [ t >>eof ] when drop ;
: (refill) ( port -- n )
[ handle>> ]
[ buffer>> buffer-end ]
@ -123,8 +120,7 @@ GENERIC: refill ( port handle -- event/f )
M: fd refill
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 EAGAIN = ] [ 2drop +input+ ] }
[ (io-error) ]

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

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

2
extra/io/unix/sockets/secure/secure-tests.factor
View File

@ -72,7 +72,7 @@ concurrency.promises byte-arrays ;
"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
"password" >>password
[
"127.0.0.1" 0 <inet4> <secure> ascii <server> [
dup addr>> addrspec>> port>> "port" get fulfill

4
extra/io/unix/sockets/secure/secure.factor
View File

@ -26,11 +26,11 @@ M: ssl-handle handle-fd file>> handle-fd ;
over handle>> handle>> over SSL_get_error ; inline
! Input ports
: check-read-response ( port r -- event ) USING: namespaces io prettyprint ;
: check-read-response ( port r -- event )
check-response
{
{ 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_WRITE [ 2drop +output+ ] }
{ SSL_ERROR_SYSCALL [ syscall-error ] }

6
extra/io/windows/nt/backend/backend.factor
View File

@ -110,11 +110,7 @@ M: winnt (wait-to-write)
] with-destructors ;
: finish-read ( n port -- )
over zero? [
t >>eof 2drop
] [
[ buffer>> n>buffer ] [ update-file-ptr ] 2bi
] if ;
[ update-file-ptr ] [ buffer>> n>buffer ] 2bi ;
M: winnt (wait-to-read) ( port -- )
[

14
extra/openssl/openssl-tests.factor
View File

@ -1,21 +1,21 @@
USING: io.sockets.secure io.encodings.ascii alien.strings
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/root.pem" >>ca-file
"resource:extra/openssl/test/dh1024.pem" >>dh-file
"password" ascii string>alien >>password
[ ] with-ssl-context
"password" >>password
[ ] with-secure-context
] unit-test
[
<ssl-config>
<secure-config>
"resource:extra/openssl/test/server.pem" >>key-file
"resource:extra/openssl/test/root.pem" >>ca-file
"wrong password" ascii string>alien >>password
[ ] with-ssl-context
"wrong password" >>password
[ ] with-secure-context
] must-fail
] with-variable

6
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
locals unicode.case
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
! This code is based on http://www.rtfm.com/openssl-examples/
@ -68,7 +68,7 @@ TUPLE: openssl-context < secure-context aliens ;
] alien-callback ;
: default-pasword ( ctx -- alien )
[ config>> password>> malloc-byte-array ] [ aliens>> ] bi
[ config>> password>> latin1 malloc-string ] [ aliens>> ] bi
[ push ] [ drop ] 2bi ;
: set-default-password ( ctx -- )
@ -181,7 +181,7 @@ M: ssl-handle dispose*
X509_get_subject_name
NID_commonName 256 <byte-array>
[ 256 X509_NAME_get_text_by_NID ] keep
swap -1 = [ drop f ] [ ascii alien>string ] if ;
swap -1 = [ drop f ] [ latin1 alien>string ] if ;
: check-common-name ( host ssl-handle -- )
SSL_get_peer_certificate common-name 2dup [ >lower ] bi@ =

5
extra/shell/shell.factor
View File

@ -1,7 +1,7 @@
USING: kernel parser words continuations namespaces debugger
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 ;
IN: shell
@ -95,8 +95,7 @@ METHOD: expand { object } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: pipeline-chant ( pipeline-chant -- )
drop "ix: pipelines not supported" print ;
: pipeline-chant ( pipeline-chant -- ) commands>> run-pipeline drop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

2
extra/unix/unix.factor
View File

@ -26,6 +26,8 @@ TYPEDEF: uint socklen_t
: ESRCH 3 ; inline
: EEXIST 17 ; inline
: NGROUPS_MAX 16 ; inline
C-STRUCT: group
{ "char*" "gr_name" }
{ "char*" "gr_passwd" }