handle file uploads

db4
erg 2008-05-20 11:05:05 -05:00
parent 73352a3437
commit 79b313ff7a
1 changed files with 24 additions and 18 deletions

View File

@ -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" [ ] }