diff --git a/extra/ftp/client/client.factor b/extra/ftp/client/client.factor
index 13cb21d7e4..44ff488a93 100644
--- a/extra/ftp/client/client.factor
+++ b/extra/ftp/client/client.factor
@@ -6,24 +6,6 @@ io.files io.sockets kernel io.streams.duplex math
math.parser sequences splitting namespaces strings fry ftp ;
IN: ftp.client
-TUPLE: ftp-client host port user password mode ;
-
-: <ftp-client> ( host -- ftp-client )
- ftp-client new
- swap >>host
- 21 >>port
- "anonymous" >>user
- "ftp@my.org" >>password ;
-
-TUPLE: ftp-response n strings parsed ;
-
-: <ftp-response> ( -- ftp-response )
- ftp-response new
- V{ } clone >>strings ;
-
-: add-response-line ( ftp-response string -- ftp-response )
- over strings>> push ;
-
: (ftp-response-code) ( str -- n )
3 head string>number ;
diff --git a/extra/ftp/ftp.factor b/extra/ftp/ftp.factor
index 565f5ce2ff..05291d3d5f 100644
--- a/extra/ftp/ftp.factor
+++ b/extra/ftp/ftp.factor
@@ -6,4 +6,22 @@ IN: ftp
SINGLETON: active
SINGLETON: passive
+TUPLE: ftp-client host port user password mode state ;
+
+: <ftp-client> ( host -- ftp-client )
+ ftp-client new
+ swap >>host
+ 21 >>port
+ "anonymous" >>user
+ "ftp@my.org" >>password ;
+
+TUPLE: ftp-response n strings parsed ;
+
+: <ftp-response> ( -- ftp-response )
+ ftp-response new
+ V{ } clone >>strings ;
+
+: add-response-line ( ftp-response string -- ftp-response )
+ over strings>> push ;
+
: ftp-send ( string -- ) write "\r\n" write flush ;
diff --git a/extra/ftp/server/server.factor b/extra/ftp/server/server.factor
index 9165fa08bd..1b9201fb7b 100644
--- a/extra/ftp/server/server.factor
+++ b/extra/ftp/server/server.factor
@@ -1,15 +1,13 @@
USING: accessors combinators io io.encodings.8-bit
-io.server io.sockets kernel sequences ftp
-io.unix.launcher.parser unicode.case ;
+io.files io.server io.sockets kernel math.parser
+namespaces sequences ftp io.unix.launcher.parser
+unicode.case ;
IN: ftp.server
-TUPLE: ftp-server port ;
-
-: <ftp-server> ( -- ftp-server )
- ftp-server new
- 21 >>port ;
+SYMBOL: client
TUPLE: ftp-client-command string tokenized ;
+
: <ftp-client-command> ( -- obj )
ftp-client-command new ;
@@ -17,25 +15,56 @@ TUPLE: ftp-client-command string tokenized ;
<ftp-client-command> readln
[ >>string ] [ tokenize-command >>tokenized ] bi ;
-: server>client ( string -- ftp-client-command )
- ftp-send read-client-command ;
+: 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* ;
-: send-banner ( -- ftp-client-command )
- "220 Welcome to " host-name append server>client ;
+: server-response ( n string -- )
+ <ftp-response>
+ swap add-response-line
+ swap >>n
+ send-response ;
-: handle-client-loop ( ftp-client-command -- )
+: send-banner ( -- )
+ 220 "Welcome to " host-name append server-response ;
+
+: send-PASS-request ( -- )
+ 331 "Please specify the password." server-response ;
+
+: parse-USER ( ftp-client-command -- )
+ tokenized>> second client get swap >>user drop ;
+
+: send-login-response ( -- )
+ ! client get
+ 230 "Login successful" server-response ;
+
+: parse-PASS ( ftp-client-command -- )
+ tokenized>> second client get swap >>password drop ;
+
+: send-quit-response ( ftp-client-command -- )
+ drop 221 "Goodbye." server-response ;
+
+: unimplemented-command ( ftp-client-command -- )
+ 500 "Unimplemented command: " rot string>> append server-response ;
+
+: handle-client-loop ( -- )
<ftp-client-command> readln
- [ >>string ] [ tokenize-command >>tokenized ] bi
- first >upper {
- ! { "USER" [ ] }
- ! { "PASS" [ ] }
+ [ >>string ]
+ [ tokenize-command >>tokenized ] bi
+ dup tokenized>> first >upper {
+ { "USER" [ parse-USER send-PASS-request t ] }
+ { "PASS" [ parse-PASS send-login-response t ] }
! { "ACCT" [ ] }
! { "CWD" [ ] }
! { "CDUP" [ ] }
! { "SMNT" [ ] }
! { "REIN" [ ] }
- ! { "QUIT" [ ] }
+ { "QUIT" [ send-quit-response f ] }
! { "PORT" [ ] }
! { "PASV" [ ] }
@@ -66,10 +95,17 @@ TUPLE: ftp-client-command string tokenized ;
! { "SITE" [ ] }
! { "NOOP" [ ] }
- } case ;
-: handle-client ( -- ftp-response )
+ ! { "EPRT" [ ] }
+ ! { "LPRT" [ ] }
+ ! { "EPSV" [ ] }
+ ! { "LPSV" [ ] }
+ [ drop unimplemented-command t ]
+ } case [ handle-client-loop ] when ;
+
+: handle-client ( -- )
"" [
+ host-name <ftp-client> client set
send-banner handle-client-loop
] with-directory ;
@@ -77,7 +113,8 @@ TUPLE: ftp-client-command string tokenized ;
internet-server "ftp.server"
latin1 [ handle-client ] with-server ;
-: ftpd-main ( -- )
- 2100 ftpd ;
+: ftpd-main ( -- ) 2100 ftpd ;
MAIN: ftpd-main
+
+! sudo tcpdump -i en1 -A -s 10000 tcp port 21