! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs byte-arrays calendar classes combinators
+USING: accessors calendar calendar.format classes combinators
combinators.short-circuit concurrency.promises continuations
-destructors ftp io io.backend io.directories io.encodings
-io.encodings.binary tools.files io.encodings.utf8 io.files
-io.files.info io.pathnames io.servers.connection io.sockets
-io.streams.duplex io.streams.string io.timeouts kernel make math
-math.bitwise math.parser namespaces sequences splitting threads
-unicode.case logging calendar.format strings io.files.links
-io.files.types io.encodings.8-bit.latin1 simple-tokenizer ;
+destructors ftp io io.directories io.encodings
+io.encodings.8-bit.latin1 io.encodings.binary io.encodings.utf8
+io.files io.files.info io.files.types io.pathnames
+io.servers.connection io.sockets io.streams.string io.timeouts
+kernel logging math math.bitwise math.parser namespaces
+sequences simple-tokenizer splitting strings threads
+tools.files unicode.case ;
IN: ftp.server
SYMBOL: server
: directory-change-failed ( -- )
"Failed to change directory." 553 server-response ;
+: make-path-relative? ( path -- ? )
+ {
+ [ absolute-path? ]
+ [ drop server get serving-directory>> ]
+ } 1&& ;
+
+: fixup-relative-path ( string -- string' )
+ dup make-path-relative? [
+ [ server get serving-directory>> ] dip append-path-naive
+ ] when ;
+
: handle-CWD ( obj -- )
tokenized>> 1 swap ?nth [
+ fixup-relative-path
dup can-serve-directory? [
set-current-directory
directory-change-success
<ftp-server> start-server ;
! sudo tcpdump -i en1 -A -s 10000 tcp port 21
+! [2010-09-04T22:07:58-05:00] DEBUG server-response: 500:Unrecognized command: EPRT |2|0:0:0:0:0:0:0:1|59359|
+
[ f ]
} cond ;
+PRIVATE>
+
: absolute-path? ( path -- ? )
{
{ [ dup empty? ] [ f ] }
[ f ]
} cond nip ;
-PRIVATE>
+: append-path-naive ( path1 path2 -- path )
+ [ trim-tail-separators ]
+ [ trim-head-separators ] bi* "/" glue ;
: append-path ( path1 path2 -- path )
{
{ [ over absolute-path? over first path-separator? and ] [
[ 2 head ] dip append
] }
- [
- [ trim-tail-separators ]
- [ trim-head-separators ] bi* "/" glue
- ]
+ [ append-path-naive ]
} cond ;
: prepend-path ( path1 path2 -- path )