--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! 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
+math.parser sequences splitting namespaces strings fry ftp
+ftp.client.listing-parser urls ;
+IN: ftp.client
+
+: (ftp-response-code) ( str -- n )
+ 3 head string>number ;
+
+: ftp-response-code ( string -- n/f )
+ dup fourth CHAR: - = [ drop f ] [ (ftp-response-code) ] if ;
+
+: read-response-loop ( ftp-response -- ftp-response )
+ readln
+ [ add-response-line ] [ ftp-response-code ] bi
+ over n>> = [ read-response-loop ] unless ;
+
+: read-response ( -- ftp-response )
+ <ftp-response> readln
+ [ (ftp-response-code) >>n ]
+ [ add-response-line ]
+ [ fourth CHAR: - = ] tri
+ [ read-response-loop ] when ;
+
+ERROR: ftp-error got expected ;
+
+: ftp-assert ( ftp-response n -- )
+ 2dup [ n>> ] dip = [ 2drop ] [ ftp-error ] if ;
+
+: ftp-command ( string -- ftp-response )
+ ftp-send read-response ;
+
+: ftp-user ( url -- ftp-response )
+ username>> "USER " prepend ftp-command ;
+
+: ftp-password ( url -- ftp-response )
+ password>> "PASS " prepend ftp-command ;
+
+: ftp-cwd ( directory -- ftp-response )
+ "CWD " prepend ftp-command ;
+
+: ftp-retr ( filename -- ftp-response )
+ "RETR " prepend ftp-command ;
+
+: ftp-set-binary ( -- ftp-response ) "TYPE I" ftp-command ;
+
+: ftp-pwd ( -- ftp-response ) "PWD" ftp-command ;
+
+: ftp-list ( -- )
+ "LIST" ftp-command 150 ftp-assert ;
+
+: ftp-quit ( -- ftp-response ) "QUIT" ftp-command ;
+
+: ftp-epsv ( -- ftp-response )
+ "EPSV" ftp-command dup 229 ftp-assert ;
+
+: parse-epsv ( ftp-response -- port )
+ strings>> first "|" split 2 tail* first string>number ;
+
+: open-passive-client ( url protocol -- stream )
+ [ host>> ftp-epsv parse-epsv <inet> ] dip <client> drop ;
+
+: list ( url -- ftp-response )
+ utf8 open-passive-client
+ ftp-list
+ lines
+ <ftp-response> swap >>strings
+ read-response 226 ftp-assert
+ parse-list ;
+
+: (ftp-get) ( url path -- )
+ [ binary open-passive-client ] dip
+ [ ftp-retr 150 ftp-assert drop ]
+ [ binary <file-writer> stream-copy ] 2bi
+ read-response 226 ftp-assert ;
+
+: ftp-login ( url -- )
+ read-response 220 ftp-assert
+ [ ftp-user 331 ftp-assert ]
+ [ ftp-password 230 ftp-assert ] bi
+ ftp-set-binary 200 ftp-assert ;
+
+: ftp-connect ( url -- stream )
+ [ host>> ] [ port>> ] bi <inet> utf8 <client> drop ;
+
+: with-ftp-client ( url quot -- )
+ [ [ ftp-connect ] keep ] dip
+ '[ _ [ ftp-login ] _ bi ftp-quit drop ] with-stream ; inline
+
+: ensure-login ( url -- url )
+ dup username>> [
+ "anonymous" >>username
+ "ftp-client" >>password
+ ] unless ;
+
+: >ftp-url ( url -- url' ) >url ensure-port ensure-login ;
+
+: ftp-get ( url -- )
+ >ftp-url [
+ dup path>>
+ [ nip parent-directory ftp-cwd drop ]
+ [ file-name (ftp-get) ] 2bi
+ ] with-ftp-client ;
+
+
+
+
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators io.files kernel math.parser
+sequences splitting ;
+IN: ftp.client.listing-parser
+
+: ch>file-type ( ch -- type )
+ {
+ { CHAR: b [ +block-device+ ] }
+ { CHAR: c [ +character-device+ ] }
+ { CHAR: d [ +directory+ ] }
+ { CHAR: l [ +symbolic-link+ ] }
+ { CHAR: s [ +socket+ ] }
+ { CHAR: p [ +fifo+ ] }
+ { CHAR: - [ +regular-file+ ] }
+ [ drop +unknown+ ]
+ } case ;
+
+: file-type>ch ( type -- string )
+ {
+ { +block-device+ [ CHAR: b ] }
+ { +character-device+ [ CHAR: c ] }
+ { +directory+ [ CHAR: d ] }
+ { +symbolic-link+ [ CHAR: l ] }
+ { +socket+ [ CHAR: s ] }
+ { +fifo+ [ CHAR: p ] }
+ { +regular-file+ [ CHAR: - ] }
+ [ drop CHAR: - ]
+ } case ;
+
+: parse-permissions ( remote-file str -- remote-file )
+ [ first ch>file-type >>type ] [ rest >>permissions ] bi ;
+
+TUPLE: remote-file
+type permissions links owner group size month day time year
+name target ;
+
+: <remote-file> ( -- remote-file ) remote-file new ;
+
+: parse-list-11 ( lines -- seq )
+ [
+ 11 f pad-right
+ <remote-file> swap {
+ [ 0 swap nth parse-permissions ]
+ [ 1 swap nth string>number >>links ]
+ [ 2 swap nth >>owner ]
+ [ 3 swap nth >>group ]
+ [ 4 swap nth string>number >>size ]
+ [ 5 swap nth >>month ]
+ [ 6 swap nth >>day ]
+ [ 7 swap nth >>time ]
+ [ 8 swap nth >>name ]
+ [ 10 swap nth >>target ]
+ } cleave
+ ] map ;
+
+: parse-list-8 ( lines -- seq )
+ [
+ <remote-file> swap {
+ [ 0 swap nth parse-permissions ]
+ [ 1 swap nth string>number >>links ]
+ [ 2 swap nth >>owner ]
+ [ 3 swap nth >>size ]
+ [ 4 swap nth >>month ]
+ [ 5 swap nth >>day ]
+ [ 6 swap nth >>time ]
+ [ 7 swap nth >>name ]
+ } cleave
+ ] map ;
+
+: parse-list-3 ( lines -- seq )
+ [
+ <remote-file> swap {
+ [ 0 swap nth parse-permissions ]
+ [ 1 swap nth string>number >>links ]
+ [ 2 swap nth >>name ]
+ } cleave
+ ] map ;
+
+: parse-list ( ftp-response -- ftp-response )
+ dup strings>>
+ [ " " split harvest ] map
+ dup length {
+ { 11 [ parse-list-11 ] }
+ { 9 [ parse-list-11 ] }
+ { 8 [ parse-list-8 ] }
+ { 3 [ parse-list-3 ] }
+ [ drop ]
+ } case >>parsed ;
--- /dev/null
+! 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 ;
+IN: ftp
+
+SINGLETON: active
+SINGLETON: passive
+
+TUPLE: ftp-response n strings parsed ;
+
+: <ftp-response> ( -- ftp-response )
+ ftp-response new
+ V{ } clone >>strings ;
+
+: add-response-line ( ftp-response string -- ftp-response )
+ over strings>> push ;
+
+: ftp-send ( string -- ) write "\r\n" write flush ;
+: ftp-ipv4 1 ; inline
+: ftp-ipv6 2 ; inline
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators.short-circuit accessors combinators io
+io.encodings.8-bit io.encodings io.encodings.binary
+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
+io.backend tools.hexdump tools.files io.streams.string ;
+IN: ftp.server
+
+TUPLE: ftp-client url mode state command-promise user password ;
+
+: <ftp-client> ( url -- ftp-client )
+ ftp-client new
+ swap >>url ;
+
+SYMBOL: client
+
+: ftp-server-directory ( -- str )
+ \ ftp-server-directory get-global "resource:temp" or
+ normalize-path ;
+
+TUPLE: ftp-command raw tokenized ;
+
+: <ftp-command> ( -- obj )
+ ftp-command new ;
+
+TUPLE: ftp-get path ;
+
+: <ftp-get> ( path -- obj )
+ ftp-get new
+ swap >>path ;
+
+TUPLE: ftp-put path ;
+
+: <ftp-put> ( path -- obj )
+ ftp-put new
+ swap >>path ;
+
+TUPLE: ftp-list ;
+
+C: <ftp-list> ftp-list
+
+: 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
+ [ but-last-slice [ "-" (send-response) ] with each ]
+ [ first " " (send-response) ] 2bi ;
+
+: server-response ( n string -- )
+ <ftp-response>
+ swap add-response-line
+ swap >>n
+ send-response ;
+
+: ftp-error ( string -- )
+ 500 "Unrecognized command: " rot append server-response ;
+
+: send-banner ( -- )
+ 220 "Welcome to " host-name append server-response ;
+
+: anonymous-only ( -- )
+ 530 "This FTP server is anonymous only." server-response ;
+
+: handle-QUIT ( obj -- )
+ drop 221 "Goodbye." server-response ;
+
+: handle-USER ( ftp-command -- )
+ [
+ tokenized>> second client get (>>user)
+ 331 "Please specify the password." server-response
+ ] [
+ 2drop "bad USER" ftp-error
+ ] recover ;
+
+: handle-PASS ( ftp-command -- )
+ [
+ tokenized>> second client get (>>password)
+ 230 "Login successful" server-response
+ ] [
+ 2drop "PASS error" ftp-error
+ ] recover ;
+
+ERROR: type-error type ;
+
+: parse-type ( string -- string' )
+ >upper {
+ { "IMAGE" [ "Binary" ] }
+ { "I" [ "Binary" ] }
+ [ type-error ]
+ } case ;
+
+: handle-TYPE ( obj -- )
+ [
+ tokenized>> second parse-type
+ 200 "Switching to " rot " mode" 3append server-response
+ ] [
+ 2drop "TYPE is binary only" ftp-error
+ ] recover ;
+
+: random-local-server ( -- server )
+ remote-address get class new 0 >>port binary <server> ;
+
+: port>bytes ( port -- hi lo )
+ [ -8 shift ] keep [ HEX: ff bitand ] bi@ ;
+
+: handle-PWD ( obj -- )
+ drop
+ 257 current-directory get "\"" "\"" surround server-response ;
+
+: handle-SYST ( obj -- )
+ drop
+ 215 "UNIX Type: L8" server-response ;
+
+: if-command-promise ( quot -- )
+ [ client get command-promise>> ] dip
+ [ "Establish an active or passive connection first" ftp-error ] if* ;
+
+: handle-STOR ( obj -- )
+ [
+ tokenized>> second
+ [ [ <ftp-put> ] dip fulfill ] if-command-promise
+ ] [
+ 2drop
+ ] recover ;
+
+! EPRT |2|::1|62138|
+! : handle-EPRT ( obj -- )
+ ! tokenized>> second "|" split harvest ;
+
+: start-directory ( -- )
+ 150 "Here comes the directory listing." server-response ;
+
+: finish-directory ( -- )
+ 226 "Directory send OK." server-response ;
+
+GENERIC: service-command ( stream obj -- )
+
+M: ftp-list service-command ( stream obj -- )
+ drop
+ start-directory [
+ utf8 encode-output
+ [ current-directory get directory. ] with-string-writer string-lines
+ harvest [ ftp-send ] each
+ ] with-output-stream
+ finish-directory ;
+
+: transfer-outgoing-file ( path -- )
+ 150 "Opening BINARY mode data connection for "
+ rot
+ [ file-name ] [
+ " " swap file-info size>> number>string
+ "(" " bytes)." surround append
+ ] bi 3append server-response ;
+
+: transfer-incoming-file ( path -- )
+ 150 "Opening BINARY mode data connection for " rot append
+ server-response ;
+
+: finish-file-transfer ( -- )
+ 226 "File send OK." server-response ;
+
+M: ftp-get service-command ( stream obj -- )
+ [
+ path>>
+ [ transfer-outgoing-file ]
+ [ binary <file-reader> swap stream-copy ] bi
+ finish-file-transfer
+ ] [
+ 3drop "File transfer failed" ftp-error
+ ] recover ;
+
+M: ftp-put service-command ( stream obj -- )
+ [
+ path>>
+ [ transfer-incoming-file ]
+ [ binary <file-writer> stream-copy ] bi
+ finish-file-transfer
+ ] [
+ 3drop "File transfer failed" ftp-error
+ ] recover ;
+
+: passive-loop ( server -- )
+ [
+ [
+ |dispose
+ 30 seconds over set-timeout
+ accept drop &dispose
+ client get command-promise>>
+ 30 seconds ?promise-timeout
+ service-command
+ ]
+ [ client get f >>command-promise drop ]
+ [ drop ] cleanup
+ ] with-destructors ;
+
+: handle-LIST ( obj -- )
+ drop
+ [ [ <ftp-list> ] dip fulfill ] if-command-promise ;
+
+: handle-SIZE ( obj -- )
+ [
+ tokenized>> second file-info size>>
+ 213 swap number>string server-response
+ ] [
+ 2drop
+ 550 "Could not get file size" server-response
+ ] recover ;
+
+: handle-RETR ( obj -- )
+ [ tokenized>> second <ftp-get> swap fulfill ]
+ curry if-command-promise ;
+
+: expect-connection ( -- port )
+ random-local-server
+ client get <promise> >>command-promise drop
+ [ [ passive-loop ] curry in-thread ]
+ [ addr>> port>> ] bi ;
+
+: handle-PASV ( obj -- )
+ drop client get passive >>mode drop
+ expect-connection
+ [
+ "Entering Passive Mode (127,0,0,1," %
+ port>bytes [ number>string ] bi@ "," glue %
+ ")" %
+ ] "" make 227 swap server-response ;
+
+: handle-EPSV ( obj -- )
+ drop
+ client get command-promise>> [
+ "You already have a passive stream" ftp-error
+ ] [
+ 229 "Entering Extended Passive Mode (|||"
+ expect-connection number>string
+ "|)" 3append server-response
+ ] if ;
+
+! 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 ;
+
+ERROR: not-a-directory ;
+ERROR: no-permissions ;
+
+: handle-CWD ( obj -- )
+ [
+ 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
+ ] [
+ not-a-directory
+ ] if
+ ] [
+ 2drop
+ 550 "Failed to change directory." server-response
+ ] recover ;
+
+: unrecognized-command ( obj -- ) raw>> ftp-error ;
+
+: handle-client-loop ( -- )
+ <ftp-command> readln
+ USE: prettyprint global [ dup . flush ] bind
+ [ >>raw ]
+ [ tokenize-command >>tokenized ] bi
+ dup tokenized>> first >upper {
+ { "USER" [ handle-USER t ] }
+ { "PASS" [ handle-PASS t ] }
+ { "ACCT" [ drop "ACCT unimplemented" ftp-error t ] }
+ { "CWD" [ handle-CWD t ] }
+ ! { "XCWD" [ ] }
+ ! { "CDUP" [ ] }
+ ! { "SMNT" [ ] }
+
+ ! { "REIN" [ drop client get reset-ftp-client t ] }
+ { "QUIT" [ handle-QUIT f ] }
+
+ ! { "PORT" [ ] } ! TODO
+ { "PASV" [ handle-PASV t ] }
+ ! { "MODE" [ ] }
+ { "TYPE" [ handle-TYPE t ] }
+ ! { "STRU" [ ] }
+
+ ! { "ALLO" [ ] }
+ ! { "REST" [ ] }
+ { "STOR" [ handle-STOR t ] }
+ ! { "STOU" [ ] }
+ { "RETR" [ handle-RETR t ] }
+ { "LIST" [ handle-LIST t ] }
+ { "SIZE" [ handle-SIZE t ] }
+ ! { "NLST" [ ] }
+ ! { "APPE" [ ] }
+ ! { "RNFR" [ ] }
+ ! { "RNTO" [ ] }
+ ! { "DELE" [ handle-DELE t ] }
+ ! { "RMD" [ handle-RMD t ] }
+ ! ! { "XRMD" [ handle-XRMD t ] }
+ ! { "MKD" [ handle-MKD t ] }
+ { "PWD" [ handle-PWD t ] }
+ ! { "ABOR" [ ] }
+
+ { "SYST" [ handle-SYST t ] }
+ ! { "STAT" [ ] }
+ ! { "HELP" [ ] }
+
+ ! { "SITE" [ ] }
+ ! { "NOOP" [ ] }
+
+ ! { "EPRT" [ handle-EPRT ] }
+ ! { "LPRT" [ handle-LPRT ] }
+ { "EPSV" [ handle-EPSV t ] }
+ ! { "LPSV" [ drop handle-LPSV t ] }
+ [ drop unrecognized-command t ]
+ } case [ handle-client-loop ] when ;
+
+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
+ ] with-destructors ;
+
+: <ftp-server> ( port -- server )
+ ftp-server new-threaded-server
+ swap >>insecure
+ "ftp.server" >>name
+ 5 minutes >>timeout
+ latin1 >>encoding ;
+
+: ftpd ( port -- )
+ <ftp-server> start-server ;
+
+: ftpd-main ( -- ) 2100 ftpd ;
+
+MAIN: ftpd-main
+
+! sudo tcpdump -i en1 -A -s 10000 tcp port 21
+++ /dev/null
-Doug Coleman
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! 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
-math.parser sequences splitting namespaces strings fry ftp
-ftp.client.listing-parser urls ;
-IN: ftp.client
-
-: (ftp-response-code) ( str -- n )
- 3 head string>number ;
-
-: ftp-response-code ( string -- n/f )
- dup fourth CHAR: - = [ drop f ] [ (ftp-response-code) ] if ;
-
-: read-response-loop ( ftp-response -- ftp-response )
- readln
- [ add-response-line ] [ ftp-response-code ] bi
- over n>> = [ read-response-loop ] unless ;
-
-: read-response ( -- ftp-response )
- <ftp-response> readln
- [ (ftp-response-code) >>n ]
- [ add-response-line ]
- [ fourth CHAR: - = ] tri
- [ read-response-loop ] when ;
-
-ERROR: ftp-error got expected ;
-
-: ftp-assert ( ftp-response n -- )
- 2dup [ n>> ] dip = [ 2drop ] [ ftp-error ] if ;
-
-: ftp-command ( string -- ftp-response )
- ftp-send read-response ;
-
-: ftp-user ( url -- ftp-response )
- username>> "USER " prepend ftp-command ;
-
-: ftp-password ( url -- ftp-response )
- password>> "PASS " prepend ftp-command ;
-
-: ftp-cwd ( directory -- ftp-response )
- "CWD " prepend ftp-command ;
-
-: ftp-retr ( filename -- ftp-response )
- "RETR " prepend ftp-command ;
-
-: ftp-set-binary ( -- ftp-response ) "TYPE I" ftp-command ;
-
-: ftp-pwd ( -- ftp-response ) "PWD" ftp-command ;
-
-: ftp-list ( -- )
- "LIST" ftp-command 150 ftp-assert ;
-
-: ftp-quit ( -- ftp-response ) "QUIT" ftp-command ;
-
-: ftp-epsv ( -- ftp-response )
- "EPSV" ftp-command dup 229 ftp-assert ;
-
-: parse-epsv ( ftp-response -- port )
- strings>> first "|" split 2 tail* first string>number ;
-
-: open-passive-client ( url protocol -- stream )
- [ host>> ftp-epsv parse-epsv <inet> ] dip <client> drop ;
-
-: list ( url -- ftp-response )
- utf8 open-passive-client
- ftp-list
- lines
- <ftp-response> swap >>strings
- read-response 226 ftp-assert
- parse-list ;
-
-: (ftp-get) ( url path -- )
- [ binary open-passive-client ] dip
- [ ftp-retr 150 ftp-assert drop ]
- [ binary <file-writer> stream-copy ] 2bi
- read-response 226 ftp-assert ;
-
-: ftp-login ( url -- )
- read-response 220 ftp-assert
- [ ftp-user 331 ftp-assert ]
- [ ftp-password 230 ftp-assert ] bi
- ftp-set-binary 200 ftp-assert ;
-
-: ftp-connect ( url -- stream )
- [ host>> ] [ port>> ] bi <inet> utf8 <client> drop ;
-
-: with-ftp-client ( url quot -- )
- [ [ ftp-connect ] keep ] dip
- '[ _ [ ftp-login ] _ bi ftp-quit drop ] with-stream ; inline
-
-: ensure-login ( url -- url )
- dup username>> [
- "anonymous" >>username
- "ftp-client" >>password
- ] unless ;
-
-: >ftp-url ( url -- url' ) >url ensure-port ensure-login ;
-
-: ftp-get ( url -- )
- >ftp-url [
- dup path>>
- [ nip parent-directory ftp-cwd drop ]
- [ file-name (ftp-get) ] 2bi
- ] with-ftp-client ;
-
-
-
-
+++ /dev/null
-Doug Coleman
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators io.files kernel math.parser
-sequences splitting ;
-IN: ftp.client.listing-parser
-
-: ch>file-type ( ch -- type )
- {
- { CHAR: b [ +block-device+ ] }
- { CHAR: c [ +character-device+ ] }
- { CHAR: d [ +directory+ ] }
- { CHAR: l [ +symbolic-link+ ] }
- { CHAR: s [ +socket+ ] }
- { CHAR: p [ +fifo+ ] }
- { CHAR: - [ +regular-file+ ] }
- [ drop +unknown+ ]
- } case ;
-
-: file-type>ch ( type -- string )
- {
- { +block-device+ [ CHAR: b ] }
- { +character-device+ [ CHAR: c ] }
- { +directory+ [ CHAR: d ] }
- { +symbolic-link+ [ CHAR: l ] }
- { +socket+ [ CHAR: s ] }
- { +fifo+ [ CHAR: p ] }
- { +regular-file+ [ CHAR: - ] }
- [ drop CHAR: - ]
- } case ;
-
-: parse-permissions ( remote-file str -- remote-file )
- [ first ch>file-type >>type ] [ rest >>permissions ] bi ;
-
-TUPLE: remote-file
-type permissions links owner group size month day time year
-name target ;
-
-: <remote-file> ( -- remote-file ) remote-file new ;
-
-: parse-list-11 ( lines -- seq )
- [
- 11 f pad-right
- <remote-file> swap {
- [ 0 swap nth parse-permissions ]
- [ 1 swap nth string>number >>links ]
- [ 2 swap nth >>owner ]
- [ 3 swap nth >>group ]
- [ 4 swap nth string>number >>size ]
- [ 5 swap nth >>month ]
- [ 6 swap nth >>day ]
- [ 7 swap nth >>time ]
- [ 8 swap nth >>name ]
- [ 10 swap nth >>target ]
- } cleave
- ] map ;
-
-: parse-list-8 ( lines -- seq )
- [
- <remote-file> swap {
- [ 0 swap nth parse-permissions ]
- [ 1 swap nth string>number >>links ]
- [ 2 swap nth >>owner ]
- [ 3 swap nth >>size ]
- [ 4 swap nth >>month ]
- [ 5 swap nth >>day ]
- [ 6 swap nth >>time ]
- [ 7 swap nth >>name ]
- } cleave
- ] map ;
-
-: parse-list-3 ( lines -- seq )
- [
- <remote-file> swap {
- [ 0 swap nth parse-permissions ]
- [ 1 swap nth string>number >>links ]
- [ 2 swap nth >>name ]
- } cleave
- ] map ;
-
-: parse-list ( ftp-response -- ftp-response )
- dup strings>>
- [ " " split harvest ] map
- dup length {
- { 11 [ parse-list-11 ] }
- { 9 [ parse-list-11 ] }
- { 8 [ parse-list-8 ] }
- { 3 [ parse-list-3 ] }
- [ drop ]
- } case >>parsed ;
+++ /dev/null
-! 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 ;
-IN: ftp
-
-SINGLETON: active
-SINGLETON: passive
-
-TUPLE: ftp-response n strings parsed ;
-
-: <ftp-response> ( -- ftp-response )
- ftp-response new
- V{ } clone >>strings ;
-
-: add-response-line ( ftp-response string -- ftp-response )
- over strings>> push ;
-
-: ftp-send ( string -- ) write "\r\n" write flush ;
-: ftp-ipv4 1 ; inline
-: ftp-ipv6 2 ; inline
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.short-circuit accessors combinators io
-io.encodings.8-bit io.encodings io.encodings.binary
-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
-io.backend tools.hexdump tools.files io.streams.string ;
-IN: ftp.server
-
-TUPLE: ftp-client url mode state command-promise user password ;
-
-: <ftp-client> ( url -- ftp-client )
- ftp-client new
- swap >>url ;
-
-SYMBOL: client
-
-: ftp-server-directory ( -- str )
- \ ftp-server-directory get-global "resource:temp" or
- normalize-path ;
-
-TUPLE: ftp-command raw tokenized ;
-
-: <ftp-command> ( -- obj )
- ftp-command new ;
-
-TUPLE: ftp-get path ;
-
-: <ftp-get> ( path -- obj )
- ftp-get new
- swap >>path ;
-
-TUPLE: ftp-put path ;
-
-: <ftp-put> ( path -- obj )
- ftp-put new
- swap >>path ;
-
-TUPLE: ftp-list ;
-
-C: <ftp-list> ftp-list
-
-: 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
- [ but-last-slice [ "-" (send-response) ] with each ]
- [ first " " (send-response) ] 2bi ;
-
-: server-response ( n string -- )
- <ftp-response>
- swap add-response-line
- swap >>n
- send-response ;
-
-: ftp-error ( string -- )
- 500 "Unrecognized command: " rot append server-response ;
-
-: send-banner ( -- )
- 220 "Welcome to " host-name append server-response ;
-
-: anonymous-only ( -- )
- 530 "This FTP server is anonymous only." server-response ;
-
-: handle-QUIT ( obj -- )
- drop 221 "Goodbye." server-response ;
-
-: handle-USER ( ftp-command -- )
- [
- tokenized>> second client get (>>user)
- 331 "Please specify the password." server-response
- ] [
- 2drop "bad USER" ftp-error
- ] recover ;
-
-: handle-PASS ( ftp-command -- )
- [
- tokenized>> second client get (>>password)
- 230 "Login successful" server-response
- ] [
- 2drop "PASS error" ftp-error
- ] recover ;
-
-ERROR: type-error type ;
-
-: parse-type ( string -- string' )
- >upper {
- { "IMAGE" [ "Binary" ] }
- { "I" [ "Binary" ] }
- [ type-error ]
- } case ;
-
-: handle-TYPE ( obj -- )
- [
- tokenized>> second parse-type
- 200 "Switching to " rot " mode" 3append server-response
- ] [
- 2drop "TYPE is binary only" ftp-error
- ] recover ;
-
-: random-local-server ( -- server )
- remote-address get class new 0 >>port binary <server> ;
-
-: port>bytes ( port -- hi lo )
- [ -8 shift ] keep [ HEX: ff bitand ] bi@ ;
-
-: handle-PWD ( obj -- )
- drop
- 257 current-directory get "\"" "\"" surround server-response ;
-
-: handle-SYST ( obj -- )
- drop
- 215 "UNIX Type: L8" server-response ;
-
-: if-command-promise ( quot -- )
- [ client get command-promise>> ] dip
- [ "Establish an active or passive connection first" ftp-error ] if* ;
-
-: handle-STOR ( obj -- )
- [
- tokenized>> second
- [ [ <ftp-put> ] dip fulfill ] if-command-promise
- ] [
- 2drop
- ] recover ;
-
-! EPRT |2|::1|62138|
-! : handle-EPRT ( obj -- )
- ! tokenized>> second "|" split harvest ;
-
-: start-directory ( -- )
- 150 "Here comes the directory listing." server-response ;
-
-: finish-directory ( -- )
- 226 "Directory send OK." server-response ;
-
-GENERIC: service-command ( stream obj -- )
-
-M: ftp-list service-command ( stream obj -- )
- drop
- start-directory [
- utf8 encode-output
- [ current-directory get directory. ] with-string-writer string-lines
- harvest [ ftp-send ] each
- ] with-output-stream
- finish-directory ;
-
-: transfer-outgoing-file ( path -- )
- 150 "Opening BINARY mode data connection for "
- rot
- [ file-name ] [
- " " swap file-info size>> number>string
- "(" " bytes)." surround append
- ] bi 3append server-response ;
-
-: transfer-incoming-file ( path -- )
- 150 "Opening BINARY mode data connection for " rot append
- server-response ;
-
-: finish-file-transfer ( -- )
- 226 "File send OK." server-response ;
-
-M: ftp-get service-command ( stream obj -- )
- [
- path>>
- [ transfer-outgoing-file ]
- [ binary <file-reader> swap stream-copy ] bi
- finish-file-transfer
- ] [
- 3drop "File transfer failed" ftp-error
- ] recover ;
-
-M: ftp-put service-command ( stream obj -- )
- [
- path>>
- [ transfer-incoming-file ]
- [ binary <file-writer> stream-copy ] bi
- finish-file-transfer
- ] [
- 3drop "File transfer failed" ftp-error
- ] recover ;
-
-: passive-loop ( server -- )
- [
- [
- |dispose
- 30 seconds over set-timeout
- accept drop &dispose
- client get command-promise>>
- 30 seconds ?promise-timeout
- service-command
- ]
- [ client get f >>command-promise drop ]
- [ drop ] cleanup
- ] with-destructors ;
-
-: handle-LIST ( obj -- )
- drop
- [ [ <ftp-list> ] dip fulfill ] if-command-promise ;
-
-: handle-SIZE ( obj -- )
- [
- tokenized>> second file-info size>>
- 213 swap number>string server-response
- ] [
- 2drop
- 550 "Could not get file size" server-response
- ] recover ;
-
-: handle-RETR ( obj -- )
- [ tokenized>> second <ftp-get> swap fulfill ]
- curry if-command-promise ;
-
-: expect-connection ( -- port )
- random-local-server
- client get <promise> >>command-promise drop
- [ [ passive-loop ] curry in-thread ]
- [ addr>> port>> ] bi ;
-
-: handle-PASV ( obj -- )
- drop client get passive >>mode drop
- expect-connection
- [
- "Entering Passive Mode (127,0,0,1," %
- port>bytes [ number>string ] bi@ "," glue %
- ")" %
- ] "" make 227 swap server-response ;
-
-: handle-EPSV ( obj -- )
- drop
- client get command-promise>> [
- "You already have a passive stream" ftp-error
- ] [
- 229 "Entering Extended Passive Mode (|||"
- expect-connection number>string
- "|)" 3append server-response
- ] if ;
-
-! 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 ;
-
-ERROR: not-a-directory ;
-ERROR: no-permissions ;
-
-: handle-CWD ( obj -- )
- [
- 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
- ] [
- not-a-directory
- ] if
- ] [
- 2drop
- 550 "Failed to change directory." server-response
- ] recover ;
-
-: unrecognized-command ( obj -- ) raw>> ftp-error ;
-
-: handle-client-loop ( -- )
- <ftp-command> readln
- USE: prettyprint global [ dup . flush ] bind
- [ >>raw ]
- [ tokenize-command >>tokenized ] bi
- dup tokenized>> first >upper {
- { "USER" [ handle-USER t ] }
- { "PASS" [ handle-PASS t ] }
- { "ACCT" [ drop "ACCT unimplemented" ftp-error t ] }
- { "CWD" [ handle-CWD t ] }
- ! { "XCWD" [ ] }
- ! { "CDUP" [ ] }
- ! { "SMNT" [ ] }
-
- ! { "REIN" [ drop client get reset-ftp-client t ] }
- { "QUIT" [ handle-QUIT f ] }
-
- ! { "PORT" [ ] } ! TODO
- { "PASV" [ handle-PASV t ] }
- ! { "MODE" [ ] }
- { "TYPE" [ handle-TYPE t ] }
- ! { "STRU" [ ] }
-
- ! { "ALLO" [ ] }
- ! { "REST" [ ] }
- { "STOR" [ handle-STOR t ] }
- ! { "STOU" [ ] }
- { "RETR" [ handle-RETR t ] }
- { "LIST" [ handle-LIST t ] }
- { "SIZE" [ handle-SIZE t ] }
- ! { "NLST" [ ] }
- ! { "APPE" [ ] }
- ! { "RNFR" [ ] }
- ! { "RNTO" [ ] }
- ! { "DELE" [ handle-DELE t ] }
- ! { "RMD" [ handle-RMD t ] }
- ! ! { "XRMD" [ handle-XRMD t ] }
- ! { "MKD" [ handle-MKD t ] }
- { "PWD" [ handle-PWD t ] }
- ! { "ABOR" [ ] }
-
- { "SYST" [ handle-SYST t ] }
- ! { "STAT" [ ] }
- ! { "HELP" [ ] }
-
- ! { "SITE" [ ] }
- ! { "NOOP" [ ] }
-
- ! { "EPRT" [ handle-EPRT ] }
- ! { "LPRT" [ handle-LPRT ] }
- { "EPSV" [ handle-EPSV t ] }
- ! { "LPSV" [ drop handle-LPSV t ] }
- [ drop unrecognized-command t ]
- } case [ handle-client-loop ] when ;
-
-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
- ] with-destructors ;
-
-: <ftp-server> ( port -- server )
- ftp-server new-threaded-server
- swap >>insecure
- "ftp.server" >>name
- 5 minutes >>timeout
- latin1 >>encoding ;
-
-: ftpd ( port -- )
- <ftp-server> start-server ;
-
-: ftpd-main ( -- ) 2100 ftpd ;
-
-MAIN: ftpd-main
-
-! sudo tcpdump -i en1 -A -s 10000 tcp port 21
projects / factor.git / commitdiff