From 617a4337068f9d8eb0a8efc8abdd4ac0de5539c1 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@secrets.local>
Date: Thu, 13 Nov 2008 19:33:29 -0600
Subject: [PATCH] make a variable to set the ftp serving directory. fix
 changing directories so you can't escape the serving directory. requires ls
 vocab now

---
 extra/ftp/client/client.factor |  2 +-
 extra/ftp/ftp.factor           | 32 ++------------------------------
 extra/ftp/server/server.factor | 20 ++++++++++++++++----
 3 files changed, 19 insertions(+), 35 deletions(-)

diff --git a/extra/ftp/client/client.factor b/extra/ftp/client/client.factor
index 8413331c00..9251e1aa55 100644
--- a/extra/ftp/client/client.factor
+++ b/extra/ftp/client/client.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays classes.singleton combinators
 continuations io io.encodings.binary io.encodings.utf8
-io.files io.sockets kernel io.streams.duplex math
+io.files io.sockets kernel io.streams.duplex math ls
 math.parser sequences splitting namespaces strings fry ftp ;
 IN: ftp.client
 
diff --git a/extra/ftp/ftp.factor b/extra/ftp/ftp.factor
index 8f0b48bd4d..e396e36180 100644
--- a/extra/ftp/ftp.factor
+++ b/extra/ftp/ftp.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs combinators io io.files kernel
-math.parser sequences strings ;
+math.parser sequences strings ls ;
 IN: ftp
 
 SINGLETON: active
@@ -32,35 +32,7 @@ TUPLE: ftp-response n strings parsed ;
     over strings>> push ;
 
 : ftp-send ( string -- ) write "\r\n" write flush ;
-
 : ftp-ipv4 1 ; inline
 : ftp-ipv6 2 ; inline
 
-: ch>type ( ch -- type )
-    {
-        { CHAR: d [ +directory+ ] }
-        { CHAR: l [ +symbolic-link+ ] }
-        { CHAR: - [ +regular-file+ ] }
-        [ drop +unknown+ ]
-    } case ;
-
-: type>ch ( type -- string )
-    {   
-        { +directory+ [ CHAR: d ] }
-        { +symbolic-link+ [ CHAR: l ] }
-        { +regular-file+ [ CHAR: - ] }
-        [ drop CHAR: - ]
-    } case ;
-
-: file-info>string ( file-info name -- string )
-    [
-        [
-            [ type>> type>ch 1string ]
-            [ drop "rwx------" append ] bi
-        ]
-        [ size>> number>string 15 CHAR: \s pad-left ] bi
-    ] dip 3array " " join ;
-
-: directory-list ( -- seq )
-    "" directory-files
-    [ [ link-info ] keep file-info>string ] map ;
+: directory-list ( -- seq ) "" ls ;
diff --git a/extra/ftp/server/server.factor b/extra/ftp/server/server.factor
index 170155bd43..969ec17224 100644
--- a/extra/ftp/server/server.factor
+++ b/extra/ftp/server/server.factor
@@ -6,12 +6,16 @@ io.encodings.utf8 io.files io.sockets kernel math.parser
 namespaces make sequences ftp io.unix.launcher.parser
 unicode.case splitting assocs classes io.servers.connection
 destructors calendar io.timeouts io.streams.duplex threads
-continuations math concurrency.promises byte-arrays sequences.lib
-hexdump ;
+continuations math concurrency.promises byte-arrays
+io.backend sequences.lib hexdump ;
 IN: ftp.server
 
 SYMBOL: client
 
+: ftp-server-directory ( -- str )
+    \ ftp-server-directory get-global "resource:temp" or
+    normalize-path ;
+
 TUPLE: ftp-command raw tokenized ;
 
 : <ftp-command> ( -- obj )
@@ -238,10 +242,16 @@ M: ftp-put service-command ( stream obj -- )
 ! : handle-LPRT ( obj -- ) tokenized>> "," split ;
 
 ERROR: not-a-directory ;
+ERROR: no-permissions ;
 
 : handle-CWD ( obj -- )
     [
-        tokenized>> second dup directory? [
+        tokenized>> second dup normalize-path
+        dup ftp-server-directory head? [
+            no-permissions
+        ] unless
+
+        file-info directory? [
             set-current-directory
             250 "Directory successully changed." server-response
         ] [
@@ -256,6 +266,7 @@ ERROR: not-a-directory ;
 
 : handle-client-loop ( -- )
     <ftp-command> readln
+    USE: prettyprint    global [ dup . flush ] bind
     [ >>raw ]
     [ tokenize-command >>tokenized ] bi
     dup tokenized>> first >upper {
@@ -313,7 +324,7 @@ TUPLE: ftp-server < threaded-server ;
 M: ftp-server handle-client* ( server -- )
     drop
     [
-        "" [
+        ftp-server-directory [
             host-name <ftp-client> client set
             send-banner handle-client-loop
         ] with-directory
@@ -323,6 +334,7 @@ M: ftp-server handle-client* ( server -- )
     ftp-server new-threaded-server
         swap >>insecure
         "ftp.server" >>name
+        5 minutes >>timeout
         latin1 >>encoding ;
 
 : ftpd ( port -- )