Merge branch 'master' of git://factorcode.org/git/factor
Slava Pestov
commit
8abb2dca15
|
|
@ -27,7 +27,6 @@ IN: ftp.client
|
|||
: ftp-command ( string -- ftp-response )
|
||||
ftp-send read-response ;
|
||||
|
||||
|
||||
: ftp-user ( ftp-client -- ftp-response )
|
||||
user>> "USER " prepend ftp-command ;
|
||||
|
||||
|
|
@ -56,21 +55,13 @@ IN: ftp.client
|
|||
strings>> first
|
||||
"|" split 2 tail* first string>number ;
|
||||
|
||||
: ch>attribute ( ch -- symbol )
|
||||
{
|
||||
{ CHAR: d [ +directory+ ] }
|
||||
{ CHAR: l [ +symbolic-link+ ] }
|
||||
{ CHAR: - [ +regular-file+ ] }
|
||||
[ drop +unknown+ ]
|
||||
} case ;
|
||||
|
||||
TUPLE: remote-file
|
||||
type permissions links owner group size month day time year name ;
|
||||
|
||||
: <remote-file> ( -- remote-file ) remote-file new ;
|
||||
|
||||
: parse-permissions ( remote-file str -- remote-file )
|
||||
[ first ch>attribute >>type ] [ rest >>permissions ] bi ;
|
||||
[ first ch>type >>type ] [ rest >>permissions ] bi ;
|
||||
|
||||
: parse-list-9 ( lines -- seq )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors io kernel math.parser sequences ;
|
||||
USING: accessors arrays assocs combinators io io.files kernel
|
||||
math.parser sequences strings ;
|
||||
IN: ftp
|
||||
|
||||
SINGLETON: active
|
||||
|
|
@ -15,6 +16,11 @@ TUPLE: ftp-client host port user password mode state ;
|
|||
"anonymous" >>user
|
||||
"ftp@my.org" >>password ;
|
||||
|
||||
: reset-ftp-client ( ftp-client -- )
|
||||
f >>user
|
||||
f >>password
|
||||
drop ;
|
||||
|
||||
TUPLE: ftp-response n strings parsed ;
|
||||
|
||||
: <ftp-response> ( -- ftp-response )
|
||||
|
|
@ -25,3 +31,32 @@ TUPLE: ftp-response n strings parsed ;
|
|||
over strings>> push ;
|
||||
|
||||
: ftp-send ( string -- ) write "\r\n" write flush ;
|
||||
|
||||
: ftp-ipv4 1 ; inline
|
||||
: ftp-ipv6 2 ; inline
|
||||
|
||||
|
||||
: ch>type ( ch -- type )
|
||||
{
|
||||
{ CHAR: d [ +directory+ ] }
|
||||
{ CHAR: l [ +symbolic-link+ ] }
|
||||
{ CHAR: - [ +regular-file+ ] }
|
||||
[ drop +unknown+ ]
|
||||
} case ;
|
||||
|
||||
: type>ch ( type -- string )
|
||||
{
|
||||
{ +directory+ [ CHAR: d ] }
|
||||
{ +symbolic-link+ [ CHAR: l ] }
|
||||
{ +regular-file+ [ CHAR: - ] }
|
||||
[ drop CHAR: - ]
|
||||
} case ;
|
||||
|
||||
: file-info>string ( file-info name -- string )
|
||||
>r [ [ type>> type>ch 1string ] [ drop "rwx------" append ] bi ]
|
||||
[ size>> number>string 15 CHAR: \s pad-left ] bi r>
|
||||
3array " " join ;
|
||||
|
||||
: directory-list ( -- seq )
|
||||
"" directory keys
|
||||
[ [ link-info ] keep file-info>string ] map ;
|
||||
|
|
|
|||
|
|
@ -1,27 +1,30 @@
|
|||
! 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 ;
|
||||
unicode.case splitting assocs ;
|
||||
IN: ftp.server
|
||||
|
||||
SYMBOL: client
|
||||
SYMBOL: stream
|
||||
|
||||
TUPLE: ftp-client-command string tokenized ;
|
||||
TUPLE: ftp-command raw tokenized ;
|
||||
|
||||
: <ftp-client-command> ( -- obj )
|
||||
ftp-client-command new ;
|
||||
: <ftp-command> ( -- obj )
|
||||
ftp-command new ;
|
||||
|
||||
: read-client-command ( -- ftp-client-command )
|
||||
<ftp-client-command> readln
|
||||
[ >>string ] [ tokenize-command >>tokenized ] bi ;
|
||||
: read-command ( -- ftp-command )
|
||||
<ftp-command> readln
|
||||
[ >>raw ] [ tokenize-command >>tokenized ] bi ;
|
||||
|
||||
: (send-response) ( n string separator -- )
|
||||
rot number>string write write ftp-send ;
|
||||
|
||||
: send-response ( ftp-response -- )
|
||||
[ n>> ] [ strings>> ] bi
|
||||
2dup
|
||||
but-last-slice [
|
||||
[ number>string write "-" write ] [ ftp-send ] bi*
|
||||
] with each
|
||||
first [ number>string write bl ] [ ftp-send ] bi* ;
|
||||
[ but-last-slice [ "-" (send-response) ] with each ]
|
||||
[ first " " (send-response) ] 2bi ;
|
||||
|
||||
: server-response ( n string -- )
|
||||
<ftp-response>
|
||||
|
|
@ -35,72 +38,123 @@ TUPLE: ftp-client-command string tokenized ;
|
|||
: send-PASS-request ( -- )
|
||||
331 "Please specify the password." server-response ;
|
||||
|
||||
: parse-USER ( ftp-client-command -- )
|
||||
: 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-client-command -- )
|
||||
: parse-PASS ( ftp-command -- )
|
||||
tokenized>> second client get swap >>password drop ;
|
||||
|
||||
: send-quit-response ( ftp-client-command -- )
|
||||
: send-quit-response ( ftp-command -- )
|
||||
drop 221 "Goodbye." server-response ;
|
||||
|
||||
: unimplemented-command ( ftp-client-command -- )
|
||||
500 "Unimplemented command: " rot string>> append server-response ;
|
||||
: ftp-error ( string -- )
|
||||
500 "Unrecognized command: " rot append server-response ;
|
||||
|
||||
: send-type-error ( -- )
|
||||
"TYPE is binary only" ftp-error ;
|
||||
|
||||
: send-type-success ( string -- )
|
||||
200 "Switching to " rot " mode" 3append server-response ;
|
||||
|
||||
: parse-TYPE ( obj -- )
|
||||
tokenized>> second >upper {
|
||||
{ "IMAGE" [ "Binary" send-type-success ] }
|
||||
{ "I" [ "Binary" send-type-success ] }
|
||||
[ drop send-type-error ]
|
||||
} case ;
|
||||
|
||||
: pwd-response ( -- )
|
||||
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> ;
|
||||
|
||||
: handle-STOR ( obj -- )
|
||||
;
|
||||
|
||||
! 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 ;
|
||||
|
||||
: unrecognized-command ( obj -- ) raw>> ftp-error ;
|
||||
|
||||
: handle-client-loop ( -- )
|
||||
<ftp-client-command> readln
|
||||
[ >>string ]
|
||||
<ftp-command> readln
|
||||
[ >>raw ]
|
||||
[ tokenize-command >>tokenized ] bi
|
||||
dup tokenized>> first >upper {
|
||||
{ "USER" [ parse-USER send-PASS-request t ] }
|
||||
{ "PASS" [ parse-PASS send-login-response t ] }
|
||||
! { "ACCT" [ ] }
|
||||
{ "ACCT" [ drop "ACCT unimplemented" ftp-error t ] }
|
||||
! { "CWD" [ ] }
|
||||
! { "CDUP" [ ] }
|
||||
! { "SMNT" [ ] }
|
||||
|
||||
! { "REIN" [ ] }
|
||||
! { "REIN" [ drop client get reset-ftp-client t ] }
|
||||
{ "QUIT" [ send-quit-response f ] }
|
||||
|
||||
! { "PORT" [ ] }
|
||||
! { "PASV" [ ] }
|
||||
! { "MODE" [ ] }
|
||||
! { "TYPE" [ ] }
|
||||
{ "TYPE" [ parse-TYPE t ] }
|
||||
! { "STRU" [ ] }
|
||||
|
||||
! { "ALLO" [ ] }
|
||||
! { "REST" [ ] }
|
||||
! { "STOR" [ ] }
|
||||
! { "STOR" [ handle-STOR t ] }
|
||||
! { "STOU" [ ] }
|
||||
! { "RETR" [ ] }
|
||||
! { "LIST" [ ] }
|
||||
! { "LIST" [ drop handle-LIST t ] }
|
||||
! { "NLST" [ ] }
|
||||
! { "LIST" [ ] }
|
||||
! { "APPE" [ ] }
|
||||
! { "RNFR" [ ] }
|
||||
! { "RNTO" [ ] }
|
||||
! { "DELE" [ ] }
|
||||
! { "RMD" [ ] }
|
||||
! { "MKD" [ ] }
|
||||
! { "PWD" [ ] }
|
||||
{ "PWD" [ drop pwd-response t ] }
|
||||
! { "ABOR" [ ] }
|
||||
|
||||
! { "SYST" [ ] }
|
||||
! { "SYST" [ drop ] }
|
||||
! { "STAT" [ ] }
|
||||
! { "HELP" [ ] }
|
||||
|
||||
! { "SITE" [ ] }
|
||||
! { "NOOP" [ ] }
|
||||
|
||||
! { "EPRT" [ ] }
|
||||
! { "LPRT" [ ] }
|
||||
! { "EPSV" [ ] }
|
||||
! { "LPSV" [ ] }
|
||||
[ drop unimplemented-command t ]
|
||||
! { "EPRT" [ handle-eprt ] }
|
||||
! { "LPRT" [ handle-lprt ] }
|
||||
! { "EPSV" [ drop handle-epsv t ] }
|
||||
! { "LPSV" [ drop handle-lpsv t ] }
|
||||
[ drop unrecognized-command t ]
|
||||
} case [ handle-client-loop ] when ;
|
||||
|
||||
: handle-client ( -- )
|
||||
|
|
|
|||
|
|
@ -8,12 +8,12 @@ IN: io.server
|
|||
|
||||
SYMBOL: servers
|
||||
|
||||
SYMBOL: remote-address
|
||||
|
||||
<PRIVATE
|
||||
|
||||
LOG: accepted-connection NOTICE
|
||||
|
||||
SYMBOL: remote-address
|
||||
|
||||
: with-connection ( client remote quot -- )
|
||||
'[
|
||||
, [ remote-address set ] [ accepted-connection ] bi
|
||||
|
|
|
|||
|
|
@ -68,6 +68,11 @@ SYMBOLS: +read-only+ +hidden+ +system+
|
|||
! [ BY_HANDLE_FILE_INFORMATION-ftCreationTime FILETIME>timestamp ]
|
||||
[ BY_HANDLE_FILE_INFORMATION-ftLastWriteTime FILETIME>timestamp ]
|
||||
! [ BY_HANDLE_FILE_INFORMATION-ftLastAccessTime FILETIME>timestamp ]
|
||||
! [ BY_HANDLE_FILE_INFORMATION-nNumberOfLinks ]
|
||||
! [
|
||||
! [ BY_HANDLE_FILE_INFORMATION-nFileIndexLow ]
|
||||
! [ BY_HANDLE_FILE_INFORMATION-nFileIndexHigh ] bi >64bit
|
||||
! ]
|
||||
} cleave
|
||||
\ file-info boa ;
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue