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

fix load error in ftp, refactor

db4
Doug Coleman 2008-12-16 01:50:25 -06:00
parent 70155c5bdb
commit b8406f709e
1 changed files with 25 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

46
basis/ftp/server/server.factor
View File

@ -8,7 +8,7 @@ sequences ftp io.launcher.unix.parser unicode.case splitting
assocs classes io.servers.connection destructors calendar assocs classes io.servers.connection destructors calendar
io.timeouts io.streams.duplex threads continuations math io.timeouts io.streams.duplex threads continuations math
concurrency.promises byte-arrays io.backend tools.hexdump concurrency.promises byte-arrays io.backend tools.hexdump
tools.files io.streams.string ; tools.files io.streams.string math.bitwise ;
IN: ftp.server IN: ftp.server
TUPLE: ftp-client url mode state command-promise user password ; TUPLE: ftp-client url mode state command-promise user password ;
@ -49,7 +49,7 @@ C: <ftp-list> ftp-list
[ >>raw ] [ tokenize-command >>tokenized ] bi ; [ >>raw ] [ tokenize-command >>tokenized ] bi ;
: (send-response) ( n string separator -- ) : (send-response) ( n string separator -- )
rot number>string write write ftp-send ; [ number>string write ] 2dip write ftp-send ;
: send-response ( ftp-response -- ) : send-response ( ftp-response -- )
[ n>> ] [ strings>> ] bi [ n>> ] [ strings>> ] bi
@ -102,7 +102,7 @@ ERROR: type-error type ;
: handle-TYPE ( obj -- ) : handle-TYPE ( obj -- )
[ [
tokenized>> second parse-type tokenized>> second parse-type
200 "Switching to " rot " mode" 3append server-response [ 200 ] dip "Switching to " " mode" surround server-response
] [ ] [
2drop "TYPE is binary only" ftp-error 2drop "TYPE is binary only" ftp-error
] recover ; ] recover ;
@ -111,11 +111,11 @@ ERROR: type-error type ;
remote-address get class new 0 >>port binary <server> ; remote-address get class new 0 >>port binary <server> ;
: port>bytes ( port -- hi lo ) : port>bytes ( port -- hi lo )
[ -8 shift ] keep [ HEX: ff bitand ] bi@ ; [ -8 shift ] keep [ 8 bits ] bi@ ;
: handle-PWD ( obj -- ) : handle-PWD ( obj -- )
drop drop
257 current-directory get "\"" "\"" surround server-response ; 257 current-directory get "\"" dup surround server-response ;
: handle-SYST ( obj -- ) : handle-SYST ( obj -- )
drop drop
@ -155,15 +155,19 @@ M: ftp-list service-command ( stream obj -- )
finish-directory ; finish-directory ;
: transfer-outgoing-file ( path -- ) : transfer-outgoing-file ( path -- )
150 "Opening BINARY mode data connection for " [
rot 150
[ file-name ] [ "Opening BINARY mode data connection for "
" " swap file-info size>> number>string ] dip
"(" " bytes)." surround append [
] bi 3append server-response ; file-name
] [
file-info size>> number>string
"(" " bytes)." surround
] bi " " glue append server-response ;
: transfer-incoming-file ( path -- ) : transfer-incoming-file ( path -- )
150 "Opening BINARY mode data connection for " rot append [ 150 ] dip "Opening BINARY mode data connection for " prepend
server-response ; server-response ;
: finish-file-transfer ( -- ) : finish-file-transfer ( -- )
@ -209,8 +213,9 @@ M: ftp-put service-command ( stream obj -- )
: handle-SIZE ( obj -- ) : handle-SIZE ( obj -- )
[ [
[ 213 ] dip
tokenized>> second file-info size>> tokenized>> second file-info size>>
213 swap number>string server-response number>string server-response
] [ ] [
2drop 2drop
550 "Could not get file size" server-response 550 "Could not get file size" server-response
@ -228,21 +233,20 @@ M: ftp-put service-command ( stream obj -- )
: handle-PASV ( obj -- ) : handle-PASV ( obj -- )
drop client get passive >>mode drop drop client get passive >>mode drop
expect-connection 221
[ expect-connection port>bytes [ number>string ] bi@ "," glue
"Entering Passive Mode (127,0,0,1," % "Entering Passive Mode (127,0,0,1," ")" surround
port>bytes [ number>string ] bi@ "," glue % server-response ;
")" %
] "" make 227 swap server-response ;
: handle-EPSV ( obj -- ) : handle-EPSV ( obj -- )
drop drop
client get command-promise>> [ client get command-promise>> [
"You already have a passive stream" ftp-error "You already have a passive stream" ftp-error
] [ ] [
229 "Entering Extended Passive Mode (|||" 229
expect-connection number>string expect-connection number>string
"|)" 3append server-response "Entering Extended Passive Mode (|||" "|)" surround
server-response
] if ; ] if ;
! LPRT 6,16,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,2,242,186 ! LPRT 6,16,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,2,242,186