steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
extra/ftp/server/server.factor
View File

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