1# ftpd.tcl -- Worlds Smallest FTPD?
2#
3# Copyright (c) 1999 Matt Newman, Jean-Claude Wippler and Equi4 Software.
4
5package require Tcl 8.0	;# Works with all 8.x
6
7# RFC0765, RFC0959
8namespace eval ftpd {
9    variable debug	1
10    variable email	webmaster@[info hostname]
11    variable port	8021
12    variable root	/ftproot
13    variable timeout	600
14    variable version	0.4
15    variable ident	"TclFTPD $version Server"
16}
17package provide ftpd ${::ftpd::version}
18
19proc bgerror msg {
20    tclLog ${::errorInfo}
21}
22proc ftpd::absolute {file} {
23    upvar 1 cb cb
24    # I wish [file normalize] (in VFS) was standard!
25    set sp [file split $file]
26    if {[file pathtype [lindex $sp 0]] == "relative"} {
27	set nfile [eval [list file join $cb(cwd)] $sp]
28	set sp [file split $nfile]
29    }
30    set splen [llength $sp]
31
32    set np {}
33    foreach ele $sp {
34	if {$ele != ".."} {
35	    if {$ele != "."} {
36		lappend np $ele
37	    }
38	    continue
39	}
40	if {[llength $np]> 1} {
41	    set np [lrange $np 0 [expr {[llength $np] - 2}]]
42	}
43    }
44    # Strip ABS leader
45    set np [lrange $np 1 end]
46    if {[llength $np] > 0} {
47	set ret [eval [list file join ${ftpd::root}] $np]
48    } else {
49	set ret ${ftpd::root}
50    }
51    #tclLog "abs: $file => $ret"
52    return $ret
53}
54proc ftpd::relative {file} {
55    set sp [file split $file]
56    set rp [file split ${ftpd::root}]
57    set sp [lrange $sp [llength $rp] end]
58    return [eval file join / $sp]
59}
60proc ftpd::ls {path {short 0}} {
61    if {[file isdirectory $path]} {
62	set ret {}
63	set list [glob -nocomplain [file join $path *] [file join $path .*]]
64	foreach file [lsort -dictionary $list] {
65	    set tail [file tail $file]
66	    if {$tail == "." || $tail == ".."} {continue}
67	    append ret [ls1 $file $short]\n
68	}
69	return $ret
70    } else {
71	return [ls1 $path $short]
72    }
73}
74proc ftpd::ls1 {path {short 0}} {
75    if {$short} {
76	return [file tail $path]
77    }
78    file stat $path sb
79
80    #drwxr-xr-x    3 888      999           21 May 13 19:46 vjscdk
81    return [format {%s %4d %-8s %-8s %7d %s %s} \
82	[fmode sb] $sb(nlink) $sb(uid) $sb(gid) $sb(size) \
83	[clock format $sb(mtime) -format {%b %d %H:%M} -gmt 1] \
84	[file tail $path]]
85}
86
87proc ftpd::fmode arr { # From Richard Suchenwirth
88    upvar 1 $arr sb
89
90    if {$sb(type) == "directory"} { set pfx "d" } else { set pfx "-" }
91
92    set s [format %o [expr $sb(mode)%512]]
93    foreach i {  0   1   2   3   4   5   6   7} \
94	    j {--- --x -w- -wx r-- r-x rw- rwx} {
95	regsub -all $i $s $j s
96    }
97    return $pfx$s
98}
99proc ftpd::type {chan} {
100    upvar #0 ftpd::$chan cb
101
102    if {$cb(type) == "I"} { return ASCII } else { return BINARY }
103}
104proc ftpd::log {msg} {
105    upvar 1 cb cb
106
107    if {[info exists cb(debug)] && $cb(debug)} {
108	tclLog "FTPD: $cb(rhost):$cb(rport): $msg"
109    }
110}
111proc ftpd::reply {chan code data {cont ""}} {
112    upvar #0 ftpd::$chan cb
113
114    if {$cont == ""} {set sep " "} {set sep -}
115
116    log "reply: $code$sep$data"
117
118    puts $chan "$code$sep$data"
119    flush $chan
120
121    after cancel $cb(timer)
122    set cb(timer) [after [expr {$cb(timeout) * 1000}] [list ftpd::timeout $chan]]
123}
124proc ftpd::timeout {chan} {
125    upvar #0 ftpd::$chan cb
126    reply $chan 421 "No Transfer Timeout ($cb(timeout)) closing control channel"
127    finish $chan Timeout
128}
129proc ftpd::CopyDone {chan fd bytes {error ""}} {
130    upvar #0 ftpd::$chan cb
131
132tclLog "CLOSE file $fd"
133    #log "Copied $bytes bytes"
134    close $fd
135    close-data $chan
136
137    reply $chan 226 "Transfer complete."
138}
139proc ftpd::finish {chan {msg EOF}} {
140    upvar #0 ftpd::$chan cb
141
142    log "closing connection ($msg)"
143    catch {after cancel $cb(timer)}
144    close-data $chan
145
146tclLog "CLOSE ctrl $chan"
147    catch {close $chan}
148    catch {unset cb}
149}
150proc ftpd::close-data {chan} {
151    upvar #0 ftpd::$chan cb
152    catch {flush $cb(data)}
153    catch {close $cb(data)}
154tclLog "CLOSE data $cb(data)"
155    catch {close $cb(pasv)}
156tclLog "CLOSE pasv $cb(pasv)"
157    set cb(pasv) ""
158    set cb(data) ""
159}
160proc ftpd::accept {chan ip port} {
161    upvar #0 ftpd::$chan cb
162    # Copy in settings - this will allow us to expand in the
163    # future to tune settings based upon incomming IP or user name etc.
164    set cb(debug) ${ftpd::debug}
165    set cb(root) ${ftpd::root}
166    set cb(email) ${ftpd::email}
167    set cb(timeout) ${ftpd::timeout}
168
169    set cb(cwd) /
170    set cb(offset) 0
171    set cb(type) binary
172    set cb(last) ""
173    set cb(pasv) ""
174    set cb(data) ""
175    set cb(rhost) $ip
176    set cb(rport) $port
177    set cb(chan) $chan
178    set cb(timer) ""
179
180    log "accept control"
181
182    fconfigure $chan -buffering line
183    fileevent $chan readable [list ftpd::handler $chan]
184
185    reply $chan 220 "${ftpd::ident} ([info hostname])"
186}
187proc ftpd::accept/data {chan data ip port} {
188    upvar #0 ftpd::$chan cb
189
190    log "accept data from $ip $port"
191
192    set cb(data) $data
193    fconfigure $cb(data) -translation $cb(type)
194}
195proc ftpd::handler {chan} {
196    upvar #0 ftpd::$chan cb
197
198    set line [gets $chan]
199    if {[eof $chan]} {
200	finish $chan EOF
201	return
202    }
203    log "request: $line"
204
205    set op [string toupper [lindex [split $line] 0]]
206    set arg [string trim [string range $line 4 end]]
207
208    switch -- $op {
209    SYST	{
210		reply $chan 215 "UNIX Type: L8"
211	    }
212    NOOP	{
213		reply $chan 250 "$op command successful."
214	    }
215    USER	{
216		set cb(user) $arg
217		reply $chan 331 "Password required for $cb(user)."
218	    }
219    PASS	{#reply $chan 530 "Login incorrect."
220		reply $chan 230 "User $cb(user) logged in."
221	    }
222    TYPE	{
223		if {$arg == "A"} {
224		    set cb(type) {auto crlf}
225		} else {
226		    set cb(type) binary
227		}
228		if {$cb(data) != ""} {
229		    fconfigure $cb(data) -translation $cb(type)
230		}
231		reply $chan 200 "Type set to $cb(type)."
232	    }
233    PORT	{
234		# PORT IP1,IP2,IP3,IP4,PORT-HI,PORT-LO
235		if {[catch {
236		    regexp {([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+)} \
237			$arg - i1 i2 i3 i4 pHi pLo
238		    set ip $i1.$i2.$i3.$i4
239		    set port [expr {(256 * $pHi) + $pLo}]
240
241		    set cb(data) [socket -async $ip $port]
242tclLog "OPEN data $cb(data)"
243		    fconfigure $cb(data) -translation $cb(type)
244		} err]} {
245		    reply $chan 550 $err
246		} else {
247		    reply $chan 200 "$op command successful."
248		}
249	    }
250    PASV	{# Switch to passive mode (we listen)
251		if {$cb(pasv) != ""} {
252		    # This shouldn't happen
253		    close-data $chan
254		}
255		set cb(pasv) [socket -server [list ftpd::accept/data $chan] \
256				-myaddr [info hostname] 0]
257tclLog "OPEN pasv $cb(pasv)"
258		# XXX - This causes a NS lookup - which sucks
259		set c [fconfigure $cb(pasv) -sockname]
260		set ip [lindex $c 0]
261		set port [lindex $c 2]
262		regexp {([0-9]+).([0-9]+).([0-9]+).([0-9]+)} \
263			$ip - i1 i2 i3 i4
264		set pHi [expr {$port / 256}]
265		set pLo [expr {$port % 256}]
266		reply $chan 227 "Passive mode entered ($i1,$i2,$i3,$i4,$pHi,$pLo)"
267	    }
268    REST	{
269		set cb(offset) $arg
270		reply $chan 350 "Restarting at $cb(offset). Send STORE or RETRIEVE to initiate transfer."
271	    }
272    XCUP	-
273    CDUP	-
274    XCWD	-
275    CWD		{
276		if {$op == "CDUP" || $op == "XCUP"} {
277		    set arg ..
278		}
279		if {[catch {
280		    cd [absolute [file join $cb(cwd) $arg]]
281		} err]} {
282		    reply $chan 550 $err
283		} else {
284		    set cb(cwd) [relative [pwd]]
285		    reply $chan 250 "$op command successful."
286		}
287	    }
288    DELE	{
289		if {[catch {
290		    file delete [absolute $arg]
291		} err]} {
292		    reply $chan 550 $err
293		} else {
294		    reply $chan 257 "\"$arg\" - file successfully removed"
295		}
296	    }
297    MDTM	{
298		if {[catch {
299		    file stat [absolute $arg] sb
300		} err]} {
301		    reply $chan 550 $err
302		} elseif {$sb(type) != "file"} {
303		    reply $chan 550 "$arg: not a plain file."
304		} else {
305		    set ts [clock format $sb(mtime) -format "%Y%m%d%H%M%S" -gmt 1]
306		    reply $chan 213 $ts
307		}
308	    }
309    SIZE	{
310		if {[catch {
311		    file stat [absolute $arg] sb
312		} err]} {
313		    reply $chan 550 $err
314		} elseif {$sb(type) != "file"} {
315		    reply $chan 550 "$arg: no a regular file."
316		} else {
317		    reply $chan 213 $sb(size)
318		}
319	    }
320    XMKD	-
321    MKD		{
322		if {[catch {
323		    file mkdir [absolute $arg]
324		} err]} {
325		    reply $chan 550 $err
326		} else {
327		    reply $chan 257 "\"$arg\" - directory successfully created"
328		}
329	    }
330    XRMD	-
331    RMD		{
332		if {[catch {
333		    file delete [absolute $arg]
334		} err]} {
335		    reply $chan 550 $err
336		} else {
337		    reply $chan 250 "$op command successful."
338		}
339	    }
340    RNFR	{
341		if {[catch {
342		    file stat [absolute $arg] sb
343		} err]} {
344		    reply $chan 550 $err
345		} else {
346		    set cb(from) $arg
347		    reply $chan 350 "File or directory exists, ready for destination name."
348		}
349	    }
350    RNTO	{
351		if {$cb(last) != "RNFR"} {
352		    reply $chan 550 "RNTO must follow RNFR"
353		} elseif {[catch {
354		    file rename [absolute $cb(from)] [absolute $arg]
355		} err]} {
356		    reply $chan 550 $err
357		} else {
358		    reply $chan 200 "$op command successful."
359		}
360	    }
361    NLST	-
362    LIST	{if {$arg == ""} {set arg $cb(cwd)}
363		reply $chan 150 "Opening [type $chan] mode data connection for file list."
364
365		if {$op == "NLST"} {
366		    # 550 No files found
367		    catch {ls [absolute $arg] 1} ret
368		} else {
369		    catch {ls [absolute $arg]} ret
370		}
371		if {[catch {
372		    puts $cb(data) $ret
373		} err]} {
374		    reply $chan 550 "Transfer Aborted: $err"
375		} else {
376		    reply $chan 226 "Transfer complete."
377		}
378		close-data $chan
379	    }
380    STAT	{# List LIST but using the control channel
381		catch {ls [absolute $arg]} ret
382		reply $chan 213 "status of $arg:" cont
383		puts $chan $ret
384		reply $chan 213 "End of Status"
385	    }
386    RETR	{
387		if {[catch {
388		    file stat [absolute $arg] sb
389		    set fd [open [absolute $arg]]
390tclLog "OPEN file $fd"
391		    fconfigure $fd -translation binary
392		    if {$cb(offset) > 0} {
393			seek $fd $cb(offset)
394		    }
395		} err]} {
396		    reply $chan 550 $err
397		    close-data $chan
398		} else {
399		    reply $chan 150 "Opening [type $chan] mode data connection for $arg ($sb(size) bytes)."
400
401		    fcopy $fd $cb(data) -command [list ftpd::CopyDone $chan $fd]
402		}
403	    }
404    APPE	-
405    STOR	{
406		if {$op == "STOR"} { set mode w } else { set mode a+ }
407
408		if {[catch {
409		    set fd [open [absolute $arg] $mode]
410tclLog "OPEN file $fd"
411		    fconfigure $fd -translation binary
412		} err]} {
413		    reply $chan 550 $err
414
415		    close-data $chan
416		} else {
417		    reply $chan 150 "Opening [type $chan] mode data connection for $arg."
418
419		    fcopy $cb(data) $fd -command [list ftpd::CopyDone $chan $fd]
420		}
421	    }
422    XPWD	-
423    PWD		{
424		reply $chan 257 "\"$cb(cwd)\" is current directory."
425	    }
426    QUIT	{
427		reply $chan 221 "Goodbye."
428		finish $chan QUIT
429	    }
430    HELP	{
431		reply $chan 214 "The following commands are recognized (* =>'s unimplemented)." cont
432		puts $chan { USER    PASS    ACCT*   CWD     XCWD    CDUP    XCUP    SMNT*}
433		puts $chan { QUIT    REIN*   PORT    PASV    TYPE    STRU*   MODE*   RETR}
434		puts $chan { STOR    STOU*   APPE    ALLO*   REST    RNFR    RNTO    ABOR}
435		puts $chan { DELE    MDTM    RMD     XRMD    MKD     XMKD    PWD     XPWD}
436		puts $chan { SIZE    LIST    NLST    SITE*   SYST    STAT    HELP    NOOP}
437		reply $chan 214 "Direct comments to $cb(email)."
438	    }
439    default	{#reply $chan 421 "Service not available."
440		reply $chan 500 "$op not supported."
441	    }
442    }
443    set cb(last) $op
444}
445proc ftpd::server {args} {
446    if {[llength $args] == 1} {set args [lindex $args 0]}
447
448    package require opt
449
450    ::tcl::OptProc _ProcessOptions [list \
451	[list -debug	-int	${::ftpd::debug}	{Enable Debug Tracing}] \
452	[list -email	-any	${::ftpd::email}	{FTP Support Email}] \
453	[list -port	-int	${::ftpd::port}		{TCP/IP Port}] \
454	[list -root	-any	${::ftpd::root}		{FTP Root Directory}] \
455	[list -timeout	-int	${::ftpd::timeout}	{FTP Idle TImeout}] \
456    ] {
457	foreach var {debug email port root timeout} {
458	    set ::ftpd::$var [set $var]
459	}
460    }
461    eval _ProcessOptions $args
462
463    # generates error if non-existent
464    file stat ${::ftpd::root} sb
465
466    socket -server ftpd::accept ${::ftpd::port}
467
468    tclLog "Accepting connections on ftp://[info hostname]:${ftpd::port}/"
469    tclLog "FTP Root = ${::ftpd::root}"
470}
471
472set fd [open ftpd.log w]
473proc tclLog msg "puts $fd \$msg;flush $fd;puts stderr \$msg"
474
475ftpd::server $argv
476
477vwait foreever
478exit
479