If ftp clients send a path starting with /, treat it as a path relative to the serving directory. Expose absolute-path? and append-path-naive in io.pathnames to implement this change.

basis/ftp/server/server.factor

@@ -1,14 +1,14 @@
 ! 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
@@ -281,8 +281,20 @@ ERROR: no-directory-permissions ;
 : 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
@@ -350,3 +362,5 @@ M: ftp-server handle-client* ( server -- )
     <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|
+

core/io/pathnames/pathnames.factor

@@ -76,6 +76,8 @@ ERROR: no-parent-directory path ;
         [ f ]
     } cond ;
 
+PRIVATE>
+
 : absolute-path? ( path -- ? )
     {
         { [ dup empty? ] [ f ] }
@@ -85,7 +87,9 @@ ERROR: no-parent-directory path ;
         [ f ]
     } cond nip ;
 
-PRIVATE>
+: append-path-naive ( path1 path2 -- path )
+    [ trim-tail-separators ]
+    [ trim-head-separators ] bi* "/" glue ;
 
 : append-path ( path1 path2 -- path )
     {
@@ -101,10 +105,7 @@ PRIVATE>
         { [ 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 )