From ab070a6839e8735c38e0caa0f5a9b8f0b3632b32 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 14 May 2008 07:54:13 -0500
Subject: [PATCH 1/3] intermediate work on ftp, gotta pull..
---
extra/ftp/client/client.factor | 11 +--
extra/ftp/ftp.factor | 37 ++++++++++-
extra/ftp/server/server.factor | 118 ++++++++++++++++++++++++---------
3 files changed, 123 insertions(+), 43 deletions(-)
diff --git a/extra/ftp/client/client.factor b/extra/ftp/client/client.factor
index 44ff488a93..8ec7366266 100644
--- a/extra/ftp/client/client.factor
+++ b/extra/ftp/client/client.factor
@@ -27,7 +27,6 @@ IN: ftp.client
: ftp-command ( string -- ftp-response )
ftp-send read-response ;
-
: ftp-user ( ftp-client -- ftp-response )
user>> "USER " prepend ftp-command ;
@@ -56,21 +55,13 @@ IN: ftp.client
strings>> first
"|" split 2 tail* first string>number ;
-: ch>attribute ( ch -- symbol )
- {
- { CHAR: d [ +directory+ ] }
- { CHAR: l [ +symbolic-link+ ] }
- { CHAR: - [ +regular-file+ ] }
- [ drop +unknown+ ]
- } case ;
-
TUPLE: remote-file
type permissions links owner group size month day time year name ;
: <remote-file> ( -- remote-file ) remote-file new ;
: parse-permissions ( remote-file str -- remote-file )
- [ first ch>attribute >>type ] [ rest >>permissions ] bi ;
+ [ first ch>type >>type ] [ rest >>permissions ] bi ;
: parse-list-9 ( lines -- seq )
[
diff --git a/extra/ftp/ftp.factor b/extra/ftp/ftp.factor
index 05291d3d5f..ccdbcd76ea 100644
--- a/extra/ftp/ftp.factor
+++ b/extra/ftp/ftp.factor
@@ -1,6 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors io kernel math.parser sequences ;
+USING: accessors arrays assocs combinators io io.files kernel
+math.parser sequences strings ;
IN: ftp
SINGLETON: active
@@ -15,6 +16,11 @@ TUPLE: ftp-client host port user password mode state ;
"anonymous" >>user
"ftp@my.org" >>password ;
+: reset-ftp-client ( ftp-client -- )
+ f >>user
+ f >>password
+ drop ;
+
TUPLE: ftp-response n strings parsed ;
: <ftp-response> ( -- ftp-response )
@@ -25,3 +31,32 @@ 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 )
+ >r [ [ type>> type>ch 1string ] [ drop "rwx------" append ] bi ]
+ [ size>> number>string 15 CHAR: \s pad-left ] bi r>
+ 3array " " join ;
+
+: directory-list ( -- seq )
+ "" directory keys
+ [ [ link-info ] keep file-info>string ] map ;
diff --git a/extra/ftp/server/server.factor b/extra/ftp/server/server.factor
index 1b9201fb7b..37c806f1b9 100644
--- a/extra/ftp/server/server.factor
+++ b/extra/ftp/server/server.factor
@@ -1,27 +1,30 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators io io.encodings.8-bit
io.files io.server io.sockets kernel math.parser
namespaces sequences ftp io.unix.launcher.parser
-unicode.case ;
+unicode.case splitting assocs ;
IN: ftp.server
SYMBOL: client
+SYMBOL: stream
-TUPLE: ftp-client-command string tokenized ;
+TUPLE: ftp-command raw tokenized ;
-: <ftp-client-command> ( -- obj )
- ftp-client-command new ;
+: <ftp-command> ( -- obj )
+ ftp-command new ;
-: read-client-command ( -- ftp-client-command )
- <ftp-client-command> readln
- [ >>string ] [ tokenize-command >>tokenized ] bi ;
+: read-command ( -- ftp-command )
+ <ftp-command> readln
+ [ >>raw ] [ tokenize-command >>tokenized ] bi ;
+
+: (send-response) ( n string separator -- )
+ rot number>string write write ftp-send ;
: send-response ( ftp-response -- )
[ n>> ] [ strings>> ] bi
- 2dup
- but-last-slice [
- [ number>string write "-" write ] [ ftp-send ] bi*
- ] with each
- first [ number>string write bl ] [ ftp-send ] bi* ;
+ [ but-last-slice [ "-" (send-response) ] with each ]
+ [ first " " (send-response) ] 2bi ;
: server-response ( n string -- )
<ftp-response>
@@ -35,72 +38,123 @@ TUPLE: ftp-client-command string tokenized ;
: send-PASS-request ( -- )
331 "Please specify the password." server-response ;
-: parse-USER ( ftp-client-command -- )
+: anonymous-only ( -- )
+ 530 "This FTP server is anonymous only." server-response ;
+
+: parse-USER ( ftp-command -- )
tokenized>> second client get swap >>user drop ;
: send-login-response ( -- )
! client get
230 "Login successful" server-response ;
-: parse-PASS ( ftp-client-command -- )
+: parse-PASS ( ftp-command -- )
tokenized>> second client get swap >>password drop ;
-: send-quit-response ( ftp-client-command -- )
+: send-quit-response ( ftp-command -- )
drop 221 "Goodbye." server-response ;
-: unimplemented-command ( ftp-client-command -- )
- 500 "Unimplemented command: " rot string>> append server-response ;
+: ftp-error ( string -- )
+ 500 "Unrecognized command: " rot append server-response ;
+
+: send-type-error ( -- )
+ "TYPE is binary only" ftp-error ;
+
+: send-type-success ( string -- )
+ 200 "Switching to " rot " mode" 3append server-response ;
+
+: parse-TYPE ( obj -- )
+ tokenized>> second >upper {
+ { "IMAGE" [ "Binary" send-type-success ] }
+ { "I" [ "Binary" send-type-success ] }
+ [ drop send-type-error ]
+ } case ;
+
+: pwd-response ( -- )
+ 257 current-directory get "\"" swap "\"" 3append server-response ;
+
+! : random-local-inet ( -- spec )
+ ! remote-address get class new 0 >>port ;
+
+! : handle-LIST ( -- )
+ ! random-local-inet ascii <server> ;
+
+: handle-STOR ( obj -- )
+ ;
+
+! EPRT |2|::1|62138|
+! : handle-EPRT ( obj -- )
+ ! tokenized>> second "|" split harvest ;
+
+! : handle-EPSV ( obj -- )
+ ! 229 "Entering Extended Passive Mode (|||"
+ ! random-local-inet ! get port number>string
+ ! "|)" 3append server-response ;
+
+! LPRT 6,16,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,2,242,186
+: handle-LPRT ( obj -- )
+ tokenized>> "," split ;
+
+: start-directory ( -- )
+ 150 "Here comes the directory listing." server-response ;
+
+: finish-directory ( -- )
+ 226 "Directory send OK." server-response ;
+
+: send-directory-list ( stream -- )
+ [ directory-list write ] with-output-stream ;
+
+: unrecognized-command ( obj -- ) raw>> ftp-error ;
: handle-client-loop ( -- )
- <ftp-client-command> readln
- [ >>string ]
+ <ftp-command> readln
+ [ >>raw ]
[ tokenize-command >>tokenized ] bi
dup tokenized>> first >upper {
{ "USER" [ parse-USER send-PASS-request t ] }
{ "PASS" [ parse-PASS send-login-response t ] }
- ! { "ACCT" [ ] }
+ { "ACCT" [ drop "ACCT unimplemented" ftp-error t ] }
! { "CWD" [ ] }
! { "CDUP" [ ] }
! { "SMNT" [ ] }
- ! { "REIN" [ ] }
+ ! { "REIN" [ drop client get reset-ftp-client t ] }
{ "QUIT" [ send-quit-response f ] }
! { "PORT" [ ] }
! { "PASV" [ ] }
! { "MODE" [ ] }
- ! { "TYPE" [ ] }
+ { "TYPE" [ parse-TYPE t ] }
! { "STRU" [ ] }
! { "ALLO" [ ] }
! { "REST" [ ] }
- ! { "STOR" [ ] }
+ ! { "STOR" [ handle-STOR t ] }
! { "STOU" [ ] }
! { "RETR" [ ] }
- ! { "LIST" [ ] }
+ ! { "LIST" [ drop handle-LIST t ] }
! { "NLST" [ ] }
- ! { "LIST" [ ] }
! { "APPE" [ ] }
! { "RNFR" [ ] }
! { "RNTO" [ ] }
! { "DELE" [ ] }
! { "RMD" [ ] }
! { "MKD" [ ] }
- ! { "PWD" [ ] }
+ { "PWD" [ drop pwd-response t ] }
! { "ABOR" [ ] }
- ! { "SYST" [ ] }
+ ! { "SYST" [ drop ] }
! { "STAT" [ ] }
! { "HELP" [ ] }
! { "SITE" [ ] }
! { "NOOP" [ ] }
- ! { "EPRT" [ ] }
- ! { "LPRT" [ ] }
- ! { "EPSV" [ ] }
- ! { "LPSV" [ ] }
- [ drop unimplemented-command t ]
+ ! { "EPRT" [ handle-eprt ] }
+ ! { "LPRT" [ handle-lprt ] }
+ ! { "EPSV" [ drop handle-epsv t ] }
+ ! { "LPSV" [ drop handle-lpsv t ] }
+ [ drop unrecognized-command t ]
} case [ handle-client-loop ] when ;
: handle-client ( -- )
From dd9e8a2245ae7d04e28eb0bd699cbf5229de932c Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 14 May 2008 07:54:40 -0500
Subject: [PATCH 2/3] expose some more fields from windows file info
---
extra/io/windows/files/files.factor | 5 +++++
1 file changed, 5 insertions(+)
diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor
index 8a15a57f83..1fd60fe1a5 100755
--- a/extra/io/windows/files/files.factor
+++ b/extra/io/windows/files/files.factor
@@ -68,6 +68,11 @@ SYMBOLS: +read-only+ +hidden+ +system+
! [ BY_HANDLE_FILE_INFORMATION-ftCreationTime FILETIME>timestamp ]
[ BY_HANDLE_FILE_INFORMATION-ftLastWriteTime FILETIME>timestamp ]
! [ BY_HANDLE_FILE_INFORMATION-ftLastAccessTime FILETIME>timestamp ]
+ ! [ BY_HANDLE_FILE_INFORMATION-nNumberOfLinks ]
+ ! [
+ ! [ BY_HANDLE_FILE_INFORMATION-nFileIndexLow ]
+ ! [ BY_HANDLE_FILE_INFORMATION-nFileIndexHigh ] bi >64bit
+ ! ]
} cleave
\ file-info boa ;
From c6ab75e3f53338fd513b0374683dcd4458ebe036 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 14 May 2008 15:43:34 -0500
Subject: [PATCH 3/3] move remote-address to public
---
extra/io/server/server.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor
index 23066114e4..e15e8c0039 100755
--- a/extra/io/server/server.factor
+++ b/extra/io/server/server.factor
@@ -8,12 +8,12 @@ IN: io.server
SYMBOL: servers
+SYMBOL: remote-address
+
<PRIVATE
LOG: accepted-connection NOTICE
-SYMBOL: remote-address
-
: with-connection ( client remote quot -- )
'[
, [ remote-address set ] [ accepted-connection ] bi