From 79b313ff7a243c9fca232b8446b9b7ce500252ac Mon Sep 17 00:00:00 2001
From: erg <erg@erg-desktop.(none)>
Date: Tue, 20 May 2008 11:05:05 -0500
Subject: [PATCH] handle file uploads
---
extra/ftp/server/server.factor | 42 +++++++++++++++++++---------------
1 file changed, 24 insertions(+), 18 deletions(-)
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 <ftp-put> 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 <file-reader> 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 <file-reader> swap stream-copy ] bi
+ [ transfer-incoming-file ]
+ [ binary <file-writer> 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
- [ <ftp-list> swap fulfill ] if-command-promise ;
+ [ >r <ftp-list> 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" [ ] }