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

intermediate work on ftp, gotta pull..

db4
Doug Coleman 2008-05-14 07:54:13 -05:00
parent df19138327
commit ab070a6839
3 changed files with 123 additions and 43 deletions

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

@ -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 )
[

37
extra/ftp/ftp.factor
View File

@ -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 ;

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

@ -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 ( -- )