diff --git a/extra/ftp/client/client.factor b/extra/ftp/client/client.factor index 44ff488a93..8ec7366266 100644 --- a/extra/ftp/client/client.factor +++ b/extra/ftp/client/client.factor @@ -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 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 ) [ diff --git a/extra/ftp/ftp.factor b/extra/ftp/ftp.factor index 05291d3d5f..ccdbcd76ea 100644 --- a/extra/ftp/ftp.factor +++ b/extra/ftp/ftp.factor @@ -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 ) @@ -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 ; diff --git a/extra/ftp/server/server.factor b/extra/ftp/server/server.factor index 1b9201fb7b..37c806f1b9 100644 --- a/extra/ftp/server/server.factor +++ b/extra/ftp/server/server.factor @@ -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 ; -: ( -- obj ) - ftp-client-command new ; +: ( -- obj ) + ftp-command new ; -: read-client-command ( -- ftp-client-command ) - readln - [ >>string ] [ tokenize-command >>tokenized ] bi ; +: read-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 -- ) @@ -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 ; + +: 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 ( -- ) - readln - [ >>string ] + 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 ( -- )