diff --git a/extra/ftp/server/server.factor b/extra/ftp/server/server.factor index ef20885a5f..cce69dde0f 100644 --- a/extra/ftp/server/server.factor +++ b/extra/ftp/server/server.factor @@ -107,9 +107,14 @@ ERROR: type-error type ; drop 215 "UNIX Type: L8" server-response ; +: if-command-promise ( quot -- ) + >r client get command-promise>> r> + [ "Establish an active or passive connection first" ftp-error ] if* ; + : handle-STOR ( obj -- ) [ - drop + tokenized>> second + [ >r r> fulfill ] if-command-promise ] [ 2drop ] recover ; @@ -122,7 +127,7 @@ ERROR: type-error type ; 150 "Here comes the directory listing." server-response ; : finish-directory ( -- ) - 226 "Directory send OK." server-response ; + 226 "Opening " server-response ; GENERIC: service-command ( stream obj -- ) @@ -135,21 +140,25 @@ M: ftp-list service-command ( stream obj -- ) ] with-output-stream finish-directory ; -: start-file-transfer ( path -- ) +: transfer-outgoing-file ( 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 ; - + +: transfer-incoming-file ( path -- ) + 150 "Opening BINARY mode data connection for " rot append + server-response ; + : finish-file-transfer ( -- ) 226 "File send OK." server-response ; M: ftp-get service-command ( stream obj -- ) [ path>> - [ start-file-transfer ] + [ transfer-outgoing-file ] [ binary swap stream-copy ] bi finish-file-transfer ] [ @@ -159,8 +168,8 @@ M: ftp-get service-command ( stream obj -- ) M: ftp-put service-command ( stream obj -- ) [ path>> - [ start-file-transfer ] - [ binary swap stream-copy ] bi + [ transfer-incoming-file ] + [ binary stream-copy ] bi finish-file-transfer ] [ 3drop "File transfer failed" ftp-error @@ -177,16 +186,12 @@ M: ftp-put service-command ( stream obj -- ) service-command ] [ client get f >>command-promise drop ] - [ ] cleanup + [ 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 - [ swap fulfill ] if-command-promise ; + [ >r r> fulfill ] if-command-promise ; : handle-SIZE ( obj -- ) [ @@ -262,7 +267,7 @@ ERROR: not-a-directory ; ! { "REIN" [ drop client get reset-ftp-client t ] } { "QUIT" [ handle-QUIT f ] } - ! { "PORT" [ ] } + ! { "PORT" [ ] } ! TODO { "PASV" [ handle-PASV t ] } ! { "MODE" [ ] } { "TYPE" [ handle-TYPE t ] } @@ -270,7 +275,7 @@ ERROR: not-a-directory ; ! { "ALLO" [ ] } ! { "REST" [ ] } - ! { "STOR" [ handle-STOR t ] } + { "STOR" [ handle-STOR t ] } ! { "STOU" [ ] } { "RETR" [ handle-RETR t ] } { "LIST" [ handle-LIST t ] } @@ -279,9 +284,10 @@ ERROR: not-a-directory ; ! { "APPE" [ ] } ! { "RNFR" [ ] } ! { "RNTO" [ ] } - ! { "DELE" [ ] } - ! { "RMD" [ ] } - ! { "MKD" [ ] } + ! { "DELE" [ handle-DELE t ] } + ! { "RMD" [ handle-RMD t ] } + ! ! { "XRMD" [ handle-XRMD t ] } + ! { "MKD" [ handle-MKD t ] } { "PWD" [ handle-PWD t ] } ! { "ABOR" [ ] }