359 lines
9.1 KiB
Factor
359 lines
9.1 KiB
Factor
! 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.files.info io.directories
|
|
io.sockets kernel math.parser namespaces make sequences
|
|
ftp io.launcher.unix.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
|
|
io.streams.string math.bitwise tools.files io.pathnames ;
|
|
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 -- )
|
|
[ number>string write ] 2dip 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 ] dip "Switching to " " mode" surround 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 [ 8 bits ] bi@ ;
|
|
|
|
: handle-PWD ( obj -- )
|
|
drop
|
|
257 current-directory get "\"" dup 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 "
|
|
] dip
|
|
[
|
|
file-name
|
|
] [
|
|
file-info size>> number>string
|
|
"(" " bytes)." surround
|
|
] bi " " glue append server-response ;
|
|
|
|
: transfer-incoming-file ( path -- )
|
|
[ 150 ] dip "Opening BINARY mode data connection for " prepend
|
|
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 -- )
|
|
[
|
|
[ 213 ] dip
|
|
tokenized>> second file-info size>>
|
|
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
|
|
221
|
|
expect-connection port>bytes [ number>string ] bi@ "," glue
|
|
"Entering Passive Mode (127,0,0,1," ")" surround
|
|
server-response ;
|
|
|
|
: handle-EPSV ( obj -- )
|
|
drop
|
|
client get command-promise>> [
|
|
"You already have a passive stream" ftp-error
|
|
] [
|
|
229
|
|
expect-connection number>string
|
|
"Entering Extended Passive Mode (|||" "|)" surround
|
|
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
|