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