Rename append-path-naive to append-relative-path, fix bugs to support Firefox FTP...

diff --git a/basis/ftp/server/server.factor b/basis/ftp/server/server.factor
index cc51be823829dad22eaee4261292929b6b893285..8fb0c1604395f07755492398f638a2113f0c9ff0 100644 (file)
--- a/basis/ftp/server/server.factor
+++ b/basis/ftp/server/server.factor
@@ -49,6 +49,17 @@ C: <ftp-disconnect> ftp-disconnect
     [ but-last-slice [ "-" (send-response) ] with each ]
     [ first " " (send-response) ] 2bi ;
 
+: 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-relative-path
+    ] when ;
+
 : server-response ( string n -- )
     2dup number>string swap ":" glue \ server-response DEBUG log-message
     <ftp-response>
@@ -120,9 +131,13 @@ ERROR: type-error type ;
 : port>bytes ( port -- hi lo )
     [ -8 shift ] keep [ 8 bits ] bi@ ;
 
+: display-directory ( -- string )
+    current-directory get server get serving-directory>> swap ?head drop
+    [ "/" ] when-empty ;
+
 : handle-PWD ( obj -- )
     drop
-    current-directory get "\"" dup surround 257 server-response ;
+    display-directory get "\"" dup surround 257 server-response ;
 
 : handle-SYST ( obj -- )
     drop
@@ -167,8 +182,9 @@ GENERIC: handle-passive-command ( stream obj -- )
 M: ftp-list handle-passive-command ( stream obj -- )
     drop
     start-directory [
-        utf8 encode-output
-        [ current-directory get directory. ] with-string-writer string-lines
+        utf8 encode-output [
+            current-directory get directory.
+        ] with-string-writer string-lines
         harvest [ ftp-send ] each
     ] with-output-stream finish-directory ;
 
@@ -225,6 +241,7 @@ M: ftp-disconnect handle-passive-command ( stream obj -- )
 
 : handle-RETR ( obj -- )
     tokenized>> second
+    fixup-relative-path
     dup can-serve-file? [
         <ftp-get> fulfill-client
     ] [
@@ -261,6 +278,7 @@ M: ftp-disconnect handle-passive-command ( stream obj -- )
 
 : handle-MDTM ( obj -- )
     tokenized>> 1 swap ?nth [
+        fixup-relative-path
         dup file-info dup directory? [
             drop not-a-plain-file
         ] [
@@ -281,17 +299,6 @@ 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

diff --git a/core/io/pathnames/pathnames.factor b/core/io/pathnames/pathnames.factor
index a7036e00a42277c40c9ef8740e03c7494714559e..6285fd716a214e5306d4f21689ce2fbe2ef9a26e 100644 (file)
--- a/core/io/pathnames/pathnames.factor
+++ b/core/io/pathnames/pathnames.factor
@@ -87,7 +87,7 @@ PRIVATE>
         [ f ]
     } cond nip ;
 
-: append-path-naive ( path1 path2 -- path )
+: append-relative-path ( path1 path2 -- path )
     [ trim-tail-separators ]
     [ trim-head-separators ] bi* "/" glue ;
 
@@ -105,7 +105,7 @@ PRIVATE>
         { [ over absolute-path? over first path-separator? and ] [
             [ 2 head ] dip append
         ] }
-        [ append-path-naive ]
+        [ append-relative-path ]
     } cond ;
 
 : prepend-path ( path1 path2 -- path )