1# ftpd.tcl -- 2# 3# This file contains Tcl/Tk package to create a ftp daemon. 4# I believe it was originally written by Matt Newman (matt@sensus.org). 5# Modified by Dan Kuchler (kuchler@ajubasolutions.com) to handle 6# more ftp commands and to fix some bugs in the original implementation 7# that was found in the stdtcl module. 8# 9# See the file "license.terms" for information on usage and redistribution 10# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 11# 12# RCS: @(#) $Id: ftpd.tcl,v 1.30 2010/01/20 18:22:42 andreas_kupries Exp $ 13# 14 15# Define the ftpd package version 1.2.5 16 17package require Tcl 8.2 18namespace eval ::ftpd { 19 20 # The listening port. 21 22 variable port 21 23 24 variable contact 25 if {![info exists contact]} { 26 global tcl_platform 27 set contact "$tcl_platform(user)@[info hostname]" 28 } 29 30 variable cwd 31 if {![info exists cwd]} { 32 set cwd "" 33 } 34 35 variable welcome 36 if {![info exists welcome]} { 37 set welcome "[info hostname] FTP server ready." 38 } 39 40 # Global configuration. 41 42 variable cfg 43 if {![info exists cfg]} { 44 array set cfg [list \ 45 closeCmd {} \ 46 authIpCmd {} \ 47 authUsrCmd {::ftpd::anonAuth} \ 48 authFileCmd {::ftpd::fileAuth} \ 49 logCmd {::ftpd::logStderr} \ 50 fsCmd {::ftpd::fsFile::fs} \ 51 xferDoneCmd {}] 52 } 53 54 variable commands 55 if {![info exists commands]} { 56 array set commands [list \ 57 ABOR {ABOR (abort operation)} \ 58 ACCT {(specify account); unimplemented.} \ 59 ALLO {(allocate storage - vacuously); unimplemented.} \ 60 APPE {APPE <sp> file-name} \ 61 CDUP {CDUP (change to parent directory)} \ 62 CWD {CWD [ <sp> directory-name ]} \ 63 DELE {DELE <sp> file-name} \ 64 HELP {HELP [ <sp> <string> ]} \ 65 LIST {LIST [ <sp> path-name ]} \ 66 NLST {NLST [ <sp> path-name ]} \ 67 MAIL {(mail to user); unimplemented.} \ 68 MDTM {MDTM <sp> path-name} \ 69 MKD {MKD <sp> path-name} \ 70 MLFL {(mail file); unimplemented.} \ 71 MODE {(specify transfer mode); unimplemented.} \ 72 MRCP {(mail recipient); unimplemented.} \ 73 MRSQ {(mail recipient scheme question); unimplemented.} \ 74 MSAM {(mail send to terminal and mailbox); unimplemented.} \ 75 MSND {(mail send to terminal); unimplemented.} \ 76 MSOM {(mail send to terminal or mailbox); unimplemented.} \ 77 NOOP {NOOP} \ 78 PASS {PASS <sp> password} \ 79 PASV {(set server in passive mode); unimplemented.} \ 80 PORT {PORT <sp> b0, b1, b2, b3, b4, b5} \ 81 PWD {PWD (return current directory)} \ 82 QUIT {QUIT (terminate service)} \ 83 REIN {REIN (reinitialize server state)} \ 84 REST {(restart command); unimplemented.} \ 85 RETR {RETR <sp> file-name} \ 86 RMD {RMD <sp> path-name} \ 87 RNFR {RNFR <sp> file-name} \ 88 RNTO {RNTO <sp> file-name} \ 89 SIZE {SIZE <sp> path-name} \ 90 SMNT {(structure mount); unimplemented.} \ 91 STOR {STOR <sp> file-name} \ 92 STOU {STOU <sp> file-name} \ 93 STRU {(specify file structure); unimplemented.} \ 94 SYST {SYST (get type of operating system)} \ 95 TYPE {TYPE <sp> [ A | E | I | L ]} \ 96 USER {USER <sp> username} \ 97 XCUP {XCUP (change to parent directory)} \ 98 XCWD {XCWD [ <sp> directory-name ]} \ 99 XMKD {XMKD <sp> path-name} \ 100 XPWD {XPWD (return current directory)} \ 101 XRMD {XRMD <sp> path-name}] 102 } 103 104 variable passwords [list ] 105 106 # Exported procedures 107 108 namespace export config hasCallback logStderr 109 namespace export fileAuth anonAuth unixAuth server accept read 110} 111 112 113# ::ftpd::config -- 114# 115# Configure the configurable parameters of the ftp daemon. 116# 117# Arguments: 118# options - -authIpCmd proc procedure that accepts or rejects an 119# incoming connection. A value of 0 or 120# an error causes the connection to be 121# rejected. There is no default. 122# -authUsrCmd proc procedure that accepts or rejects a 123# login. Defaults to ::ftpd::anonAuth 124# -authFileCmd proc procedure that accepts or rejects 125# access to read or write a certain 126# file or path. Defaults to 127# ::ftpd::userAuth 128# -logCmd proc procedure that logs information from 129# the ftp engine. Default is 130# ::ftpd::logStderr 131# -fsCmd proc procedure to connect the ftp engine 132# to the file system it operates on. 133# Default is ::ftpd::fsFile::fs 134# 135# Results: 136# None. 137# 138# Side Effects: 139# Changes the value of the specified configurables. 140 141proc ::ftpd::config {args} { 142 143 # Processing of global configuration changes. 144 145 package require cmdline 146 147 variable cfg 148 149 # Make default value be the current value so we can call this 150 # command multiple times without resetting already set values 151 152 array set cfg [cmdline::getoptions args [list \ 153 [list closeCmd.arg $cfg(closeCmd) {Callback when a connection is closed.}] \ 154 [list authIpCmd.arg $cfg(authIpCmd) {Callback to authenticate new connections based on the ip-address of the peer. Optional}] \ 155 [list authUsrCmd.arg $cfg(authUsrCmd) {Callback to authenticate new connections based on the user logging in.}] \ 156 [list authFileCmd.arg $cfg(authFileCmd) {Callback to accept or deny a users access to read and write to a specific path or file.}] \ 157 [list logCmd.arg $cfg(logCmd) {Callback for log information generated by the FTP engine.}] \ 158 [list xferDoneCmd.arg $cfg(xferDoneCmd) {Callback for transfer completion notification. Optional}] \ 159 [list fsCmd.arg $cfg(fsCmd) {Callback to connect the engine to the filesystem it operates on.}]]] 160 return 161} 162 163 164# ::ftpd::hasCallback -- 165# 166# Determines whether or not a non-NULL callback has been defined for one 167# of the callback types. 168# 169# Arguments: 170# callbackType - One of authIpCmd, authUsrCmd, logCmd, or fsCmd 171# 172# Results: 173# Returns 1 if a non-NULL callback has been specified for the 174# callbackType that is passed in. 175# 176# Side Effects: 177# None. 178 179proc ::ftpd::hasCallback {callbackType} { 180 variable cfg 181 182 return [expr {[info exists cfg($callbackType)] && [string length $cfg($callbackType)]}] 183} 184 185 186# ::ftpd::logStderr -- 187# 188# Outputs a message with the specified severity to stderr. The default 189# logCmd callback. 190# 191# Arguments: 192# severity - The severity of the error. One of debug, error, 193# or note. 194# text - The error message. 195# 196# Results: 197# None. 198# 199# Side Effects: 200# A message is written to the stderr channel. 201 202proc ::ftpd::logStderr {severity text} { 203 204 # Standard log handler. Prints to stderr. 205 206 puts stderr "\[$severity\] $text" 207 return 208} 209 210 211# ::ftpd::Log -- 212# 213# Used for all ftpd logging. 214# 215# Arguments: 216# severity - The severity of the error. One of debug, error, 217# or note. 218# text - The error message. 219# 220# Results: 221# None. 222# 223# Side Effects: 224# The ftpd logCmd callback is called with the specified severity and 225# text if there is a non-NULL ftpCmd. 226 227proc ::ftpd::Log {severity text} { 228 229 # Central call out to log handlers. 230 231 variable cfg 232 233 if {[hasCallback logCmd]} { 234 set cmd $cfg(logCmd) 235 lappend cmd $severity $text 236 eval $cmd 237 } 238 return 239} 240 241 242# ::ftpd::fileAuth -- 243# 244# Given a username, path, and operation- decides whether or not to accept 245# the attempted read or write operation. 246# 247# Arguments: 248# user - The name of the user that is attempting to 249# connect to the ftpd. 250# path - The path or filename that the user is attempting 251# to read or write. 252# operation - read or write. 253# 254# Results: 255# Returns 0 if it rejects access and 1 if it accepts access. 256# 257# Side Effects: 258# None. 259 260proc ::ftpd::fileAuth {user path operation} { 261 # Standard authentication handler 262 263 if {(![Fs exists $path]) && ([string equal $operation "write"])} { 264 if {[Fs exists [file dirname $path]]} { 265 set path [file dirname $path] 266 } 267 } elseif {(![Fs exists $path]) && ([string equal $operation "read"])} { 268 return 0 269 } 270 271 if {[Fs exists $path]} { 272 set mode [Fs permissions $path] 273 if {([string equal $operation "read"] && (($mode & 00004) > 0)) || \ 274 ([string equal $operation "write"] && (($mode & 00002) > 0))} { 275 return 1 276 } 277 } 278 return 0 279} 280 281# ::ftpd::anonAuth -- 282# 283# Given a username and password, decides whether or not to accept the 284# attempted login. This is the default ftpd authUsrCmd callback. By 285# default it accepts the annonymous user and does some basic checking 286# checking on the form of the password to see if it has the form of an 287# email address. 288# 289# Arguments: 290# user - The name of the user that is attempting to 291# connect to the ftpd. 292# pass - The password of the user that is attempting to 293# connect to the ftpd. 294# 295# Results: 296# Returns 0 if it rejects the login and 1 if it accepts the login. 297# 298# Side Effects: 299# None. 300 301proc ::ftpd::anonAuth {user pass} { 302 # Standard authentication handler 303 # 304 # Accept user 'anonymous' if a password was 305 # provided which is at least similar to an 306 # fully qualified email address. 307 308 if {(![string equal $user anonymous]) && (![string equal $user ftp])} { 309 return 0 310 } 311 312 set pass [split $pass @] 313 if {[llength $pass] != 2} { 314 return 0 315 } 316 317 set domain [split [lindex $pass 1] .] 318 if {[llength $domain] < 2} { 319 return 0 320 } 321 322 return 1 323} 324 325# ::ftpd::unixAuth -- 326# 327# Given a username and password, decides whether or not to accept the 328# attempted login. This is an alternative to the default ftpd 329# authUsrCmd callback. By default it accepts the annonymous user and does 330# some basic checking checking on the form of the password to see if it 331# has the form of an email address. 332# 333# Arguments: 334# user - The name of the user that is attempting to 335# connect to the ftpd. 336# pass - The password of the user that is attempting to 337# connect to the ftpd. 338# 339# Results: 340# Returns 0 if it rejects the login and 1 if it accepts the login. 341# 342# Side Effects: 343# None. 344 345proc ::ftpd::unixAuth {user pass} { 346 347 variable passwords 348 array set password $passwords 349 350 # Standard authentication handler 351 # 352 # Accept user 'anonymous' if a password was 353 # provided which is at least similar to an 354 # fully qualified email address. 355 356 if {([llength $passwords] == 0) && (![catch {package require crypt}])} { 357 foreach file [list /etc/passwd /etc/shadow] { 358 if {([file exists $file]) && ([file readable $file])} { 359 set fh [open $file r] 360 set data [read $fh [file size $file]] 361 foreach line [split $data \n] { 362 foreach {username passwd uid gid dir sh} [split $line :] { 363 if {[string length $passwd] > 2} { 364 set password($username) $passwd 365 } elseif {$passwd == ""} { 366 set password($username) "" 367 } 368 break 369 } 370 } 371 } 372 } 373 set passwords [array get password] 374 } 375 376 ::ftpd::Log debug $passwords 377 378 if {[string equal $user anonymous] || [string equal $user ftp]} { 379 380 set pass [split $pass @] 381 if {[llength $pass] != 2} { 382 return 0 383 } 384 385 set domain [split [lindex $pass 1] .] 386 if {[llength $domain] < 2} { 387 return 0 388 } 389 390 return 1 391 } 392 393 if {[info exists password($user)]} { 394 if {$password($user) == ""} { 395 return 1 396 } 397 if {[string equal $password($user) [::crypt $pass $password($user)]]} { 398 return 1 399 } 400 } 401 402 return 0 403} 404 405# ::ftpd::server -- 406# 407# Creates a server socket at the specified port. 408# 409# Arguments: 410# myaddr - The domain-style name or numerical IP address of 411# the client-side network interface to use for the 412# connection. The name of the user that is 413# attempting to connect to the ftpd. 414# 415# Results: 416# None. 417# 418# Side Effects: 419# A listener is setup on the specified port which will call 420# ::ftpd::accept when it is connected to. 421 422proc ::ftpd::server {{myaddr {}}} { 423 variable port 424 if {[string length $myaddr]} { 425 set f [socket -server ::ftpd::accept -myaddr $myaddr $port] 426 } else { 427 set f [socket -server ::ftpd::accept $port] 428 } 429 set port [lindex [fconfigure $f -sockname] 2] 430 return 431} 432 433# ::ftpd::accept -- 434# 435# Checks if the connecting IP is authorized to connect or not. If not 436# the socket is closed and failure is logged. Otherwise, a welcome is 437# printed out, and a ftpd::Read filevent is placed on the socket. 438# 439# Arguments: 440# sock - The channel for this connection to the ftpd. 441# ipaddr - The client's IP address. 442# client_port - The client's port number. 443# 444# Results: 445# None. 446# 447# Side Effects: 448# Sets up a ftpd::Read fileevent to trigger whenever the channel is 449# readable. Logs an error and closes the connection if the IP is 450# not authorized to connect. 451 452proc ::ftpd::accept {sock ipaddr client_port} { 453 upvar #0 ::ftpd::$sock data 454 variable welcome 455 variable cfg 456 variable cwd 457 variable CurrentSocket 458 459 set CurrentSocket $sock 460 if {[info exists data]} { 461 unset data 462 } 463 464 if {[hasCallback authIpCmd]} { 465 # Call out to authenticate the peer. A return value of 0 or an 466 # error causes the system to reject the connection. Everything 467 # else (with 1 prefered) leads to acceptance. 468 469 set cmd $cfg(authIpCmd) 470 lappend cmd $ipaddr 471 472 set fail [catch {eval $cmd} res] 473 474 if {$fail} { 475 Log error "AuthIp error: $res" 476 } 477 if {$fail || ($res == 0)} { 478 Log note "AuthIp: Access denied to $ipaddr" 479 480 # Now: Close the connection. (Is there a standard response 481 # before closing down to signal the peer that we don't want 482 # to talk to it ? -> read RFC). 483 484 close $sock 485 return 486 } 487 488 # Accept the connection (for now, 'authUsrCmd' may revoke this 489 # decision). 490 } 491 492 array set data [list \ 493 access 0 \ 494 ip $ipaddr \ 495 state command \ 496 buffering line \ 497 cwd "$cwd" \ 498 mode binary \ 499 sock2a "" \ 500 sock2 ""] 501 502 fconfigure $sock -buffering line 503 fileevent $sock readable [list ::ftpd::Read $sock] 504 puts $sock "220 $welcome" 505 506 Log debug "Accept $ipaddr" 507 return 508} 509 510# ::ftpd::Read -- 511# 512# Checks the state of a channel and then reads a command from the 513# channel if it is not at end of file yet. If there is a command named 514# ftpd::command::* where '*' is the all upper case name of the command, 515# then that proc is called to handle the command with the remaining parts 516# of the command that was read from the channel as arguments. 517# 518# Arguments: 519# sock - The channel for this connection to the ftpd. 520# 521# Results: 522# None. 523# 524# Side Effects: 525# Runs the appropriate command depending on the state in the state 526# machine, and the command that is specified. 527 528proc ::ftpd::Read {sock} { 529 upvar #0 ::ftpd::$sock data 530 variable CurrentSocket 531 532 set CurrentSocket $sock 533 if {[eof $sock]} { 534 Finish $sock 535 return 536 } 537 switch -exact -- $data(state) { 538 command { 539 gets $sock command 540 set argument "" 541 if {![regexp {^([^ ]+) (.*)$} $command -> cmd argument]} { 542 if {![regexp {^([^ ]+)$} $command -> cmd]} { 543 # Very bad command syntax. 544 puts $sock "500 Command not understood." 545 return 546 } 547 } 548 set cmd [string toupper $cmd] 549 auto_load ::ftpd::command::$cmd 550 if {($data(access) == 0) && ((![info exists data(user)]) || \ 551 ($data(user) == "")) && (![string equal $cmd "USER"])} { 552 if {[string equal $cmd "PASS"]} { 553 puts $sock "503 Login with USER first." 554 } else { 555 puts $sock "530 Please login with USER and PASS." 556 } 557 } elseif {($data(access) == 0) && (![string equal $cmd "PASS"]) \ 558 && (![string equal $cmd "USER"]) \ 559 && (![string equal $cmd "QUIT"])} { 560 puts $sock "530 Please login with USER and PASS." 561 } elseif {[info command ::ftpd::command::$cmd] != ""} { 562 Log debug $command 563 ::ftpd::command::$cmd $sock $argument 564 catch {flush $sock} 565 } else { 566 Log error "Unknown command: $cmd" 567 puts $sock "500 Unknown command $cmd" 568 } 569 } 570 default { 571 error "Unknown state \"$data(state)\"" 572 } 573 } 574 return 575} 576 577# ::ftpd::Finish -- 578# 579# Closes the socket connection between the ftpd and client. 580# 581# Arguments: 582# sock - The channel for this connection to the ftpd. 583# 584# Results: 585# None. 586# 587# Side Effects: 588# The channel is closed. 589 590proc ::ftpd::Finish {sock} { 591 upvar #0 ::ftpd::$sock data 592 variable cfg 593 594 if {[hasCallback closeCmd]} then { 595 ## 596 ## User specified a close command so invoke it 597 ## 598 uplevel #0 $cfg(closeCmd) 599 } 600 close $sock 601 if {[info exists data]} { 602 unset data 603 } 604 return 605} 606 607# ::ftpd::FinishData -- 608# 609# Closes the data socket connection that is created when the 'PORT' 610# command is recieved. 611# 612# Arguments: 613# sock - The channel for this connection to the ftpd. 614# 615# Results: 616# None. 617# 618# Side Effects: 619# The data channel is closed. 620 621proc ::ftpd::FinishData {sock} { 622 upvar #0 ::ftpd::$sock data 623 catch {close $data(sock2)} 624 set data(sock2) {} 625 return 626} 627 628# ::ftpd::Fs -- 629# 630# The general filesystem command. Used as an intermediary for filesystem 631# access to allow alternate (virtual, etc.) filesystems to be used. The 632# ::ftpd::Fs command will call out to the fsCmd callback with the 633# subcommand and arguments that are passed to it. 634# 635# The fsCmd callback is called in the following ways: 636# 637# <cmd> append <path> 638# <cmd> delete <path> <channel-to-write-to> 639# <cmd> dlist <path> <style> <channel-to-write-dir-list-to> 640# <cmd> exists <path> 641# <cmd> mkdir <path> <channel-to-write-to> 642# <cmd> mtime <path> <channel-to-write-mtime-to> 643# <cmd> permissions <path> 644# <cmd> rename <path> <newpath> <channel-to-write-to> 645# <cmd> retr <path> 646# <cmd> rmdir <path> <channel-to-write-to> 647# <cmd> size <path> <channel-to-write-size-to> 648# <cmd> store <path> 649# 650# Arguments: 651# command - The filesystem command (one of dlist, retr, or 652# store). 'dlist' will list files in a 653# directory, 'retr' will get a channel to 654# to read the specified file from, 'store' 655# will return the channel to write to, and 656# 'mtime' will print the modification time. 657# path - The file name or directory to read, write, or 658# list. 659# args - Additional arguments for filesystem commands. 660# Currently this is used by 'dlist' which 661# has two additional arguments 'style' and 662# 'channel-to-write-dir-list-to'. It is also 663# used by 'size' and 'mtime' which have one 664# additional argument 'channel-to-write-to'. 665# 666# Results: 667# For a 'appe', 'retr', or 'stor' a channel is returned. For 'exists' 668# a 1 is returned if the path exists, and is not a directory. Otherwise 669# a 0 is returned. For 'permissions' the octal file permissions (i.e. 670# the 'file stat' mode) are returned. 671# 672# Side Effects: 673# For 'dlist' a directory listing for the specified path is written to 674# the specified channel. For 'mtime' the modification time is written 675# or an error is thrown. An error is thrown if there is no fsCmd 676# callback configured for the ftpd. 677 678proc ::ftpd::Fs {command path args} { 679 variable cfg 680 681 if {![hasCallback fsCmd]} { 682 error "-fsCmd must not be empty, need a way to access files." 683 } 684 685 return [eval [list $cfg(fsCmd) $command $path] $args] 686} 687 688# Create a namespace to hold one proc for each ftp command (in upper case 689# letters) that is supported by the ftp daemon. The existance of a proc 690# in this namespace is the way that the list of supported commands is 691# determined, and the procs in this namespace are invoked to handle the 692# ftp commands with the same name as the procs. 693 694namespace eval ::ftpd::command { 695 # All commands in this namespace are private, no export. 696} 697 698# ::ftpd::command::ABOR -- 699# 700# Handle the ABOR ftp command. Closes the data socket if it 701# is open, and then prints the appropriate success message. 702# 703# Arguments: 704# sock - The channel for this connection to the ftpd. 705# list - The arguments to the APPE command. 706# 707# Results: 708# None. 709# 710# Side Effects: 711# The data is copied to from the socket data(sock2) to the 712# writable channel to create a file. 713 714proc ::ftpd::command::ABOR {sock list} { 715 716 ::ftpd::FinishData $sock 717 puts $sock "225 ABOR command successful." 718 719 return 720} 721 722# ::ftpd::command::APPE -- 723# 724# Handle the APPE ftp command. Gets a writable channel for the file 725# specified from ::ftpd::Fs and copies the data from data(sock2) to 726# the writable channel. If the filename already exists the data is 727# appended, otherwise the file is created and then written. 728# 729# Arguments: 730# sock - The channel for this connection to the ftpd. 731# list - The arguments to the APPE command. 732# 733# Results: 734# None. 735# 736# Side Effects: 737# The data is copied to from the socket data(sock2) to the 738# writable channel to create a file. 739 740proc ::ftpd::command::APPE {sock filename} { 741 upvar #0 ::ftpd::$sock data 742 743 set path [file join $data(cwd) [string trimleft $filename /]] 744 if {[::ftpd::hasCallback authFileCmd]} { 745 set cmd $::ftpd::cfg(authFileCmd) 746 lappend cmd $data(user) $path write 747 if {[eval $cmd] == 0} { 748 puts $sock "550 $filename: Permission denied" 749 return 750 } 751 } 752 753 # 754 # Patched Mark O'Connor 755 # 756 if {![catch {::ftpd::Fs append $path $data(mode)} f]} { 757 puts $sock "150 Copy Started ($data(mode))" 758 fcopy $data(sock2) $f -command [list ::ftpd::GetDone $sock $data(sock2) $f ""] 759 } else { 760 puts $sock "500 Copy Failed: $path $f" 761 ::ftpd::FinishData $sock 762 } 763 return 764} 765 766# ::ftpd::command::CDUP -- 767# 768# Handle the CDUP ftp command. Change the current working directory to 769# the directory above the current working directory. 770# 771# Arguments: 772# sock - The channel for this connection to the ftpd. 773# list - The arguments to the CDUP command. 774# 775# Results: 776# None. 777# 778# Side Effects: 779# Changes the data(cwd) to the appropriate directory. 780 781proc ::ftpd::command::CDUP {sock list} { 782 upvar #0 ::ftpd::$sock data 783 784 set data(cwd) [file dirname $data(cwd)] 785 puts $sock "200 CDUP command successful." 786 return 787} 788 789# ::ftpd::command::CWD -- 790# 791# Handle the CWD ftp command. Change the current working directory. 792# 793# Arguments: 794# sock - The channel for this connection to the ftpd. 795# list - The arguments to the CWD command. 796# 797# Results: 798# None. 799# 800# Side Effects: 801# Changes the data(cwd) to the appropriate directory. 802 803proc ::ftpd::command::CWD {sock relativepath} { 804 upvar #0 ::ftpd::$sock data 805 806 if {[string equal $relativepath .]} { 807 puts $sock "250 CWD command successful." 808 return 809 } 810 811 if {[string equal $relativepath ..]} { 812 set data(cwd) [file dirname $data(cwd)] 813 puts $sock "250 CWD command successful." 814 return 815 } 816 817 set data(cwd) [file join $data(cwd) $relativepath] 818 puts $sock "250 CWD command successful." 819 return 820} 821 822# ::ftpd::command::DELE -- 823# 824# Handle the DELE ftp command. Delete the specified file. 825# 826# Arguments: 827# sock - The channel for this connection to the ftpd. 828# list - The arguments to the DELE command. 829# 830# Results: 831# None. 832# 833# Side Effects: 834# The specified file is deleted. 835 836proc ::ftpd::command::DELE {sock filename} { 837 upvar #0 ::ftpd::$sock data 838 839 set path [file join $data(cwd) [string trimleft $filename /]] 840 if {[::ftpd::hasCallback authFileCmd]} { 841 set cmd $::ftpd::cfg(authFileCmd) 842 lappend cmd $data(user) $path write 843 if {[eval $cmd] == 0} { 844 puts $sock "550 $filename: Permission denied" 845 return 846 } 847 } 848 849 if {[catch {::ftpd::Fs delete $path $sock} msg]} { 850 puts $sock "500 DELE Failed: $path $msg" 851 } 852 return 853} 854 855# ::ftpd::command::HELP -- 856# 857# Handle the HELP ftp command. Display a list of commands 858# or syntax information about the supported commands. 859# 860# Arguments: 861# sock - The channel for this connection to the ftpd. 862# list - The arguments to the HELP command. 863# 864# Results: 865# None. 866# 867# Side Effects: 868# Displays a helpful message. 869 870proc ::ftpd::command::HELP {sock command} { 871 upvar #0 ::ftpd::$sock data 872 873 if {$command != ""} { 874 set command [string toupper $command] 875 if {![info exists ::ftpd::commands($command)]} { 876 puts $sock "502 Unknown command '$command'." 877 } elseif {[info commands ::ftpd::command::$command] == ""} { 878 puts $sock "214 $command\t$::ftpd::commands($command)" 879 } else { 880 puts $sock "214 Syntax: $::ftpd::commands($command)" 881 } 882 } else { 883 set commandList [lsort [array names ::ftpd::commands]] 884 puts $sock "214-The following commands are recognized (* =>'s unimplemented)." 885 set i 1 886 foreach commandName $commandList { 887 if {[info commands ::ftpd::command::$commandName] == ""} { 888 puts -nonewline $sock [format " %-7s" "${commandName}*"] 889 } else { 890 puts -nonewline $sock [format " %-7s" $commandName] 891 } 892 if {($i % 8) == 0} { 893 puts $sock "" 894 } 895 incr i 896 } 897 incr i -1 898 if {($i % 8) != 0} { 899 puts $sock "" 900 } 901 puts $sock "214 Direct comments to $::ftpd::contact." 902 } 903 904 return 905} 906 907# ::ftpd::command::LIST -- 908# 909# Handle the LIST ftp command. Lists the names of the files in the 910# specified path. 911# 912# Arguments: 913# sock - The channel for this connection to the ftpd. 914# list - The arguments to the LIST command. 915# 916# Results: 917# None. 918# 919# Side Effects: 920# A listing of files is written to the socket. 921 922proc ::ftpd::command::LIST {sock filename} { 923 ::ftpd::List $sock $filename list 924 return 925} 926 927# ::ftpd::command::MDTM -- 928# 929# Handle the MDTM ftp command. Prints the modification time of the 930# specified file to the socket. 931# 932# Arguments: 933# sock - The channel for this connection to the ftpd. 934# list - The arguments to the MDTM command. 935# 936# Results: 937# None. 938# 939# Side Effects: 940# Prints the modification time of the specified file to the socket. 941 942proc ::ftpd::command::MDTM {sock filename} { 943 upvar #0 ::ftpd::$sock data 944 945 set path [file join $data(cwd) [string trimleft $filename /]] 946 if {[catch {::ftpd::Fs mtime $path $sock} msg]} { 947 puts $sock "500 MDTM Failed: $path $msg" 948 ::ftpd::FinishData $sock 949 } 950 return 951} 952 953# ::ftpd::command::MKD -- 954# 955# Handle the MKD ftp command. Create the specified directory. 956# 957# Arguments: 958# sock - The channel for this connection to the ftpd. 959# list - The arguments to the MKD command. 960# 961# Results: 962# None. 963# 964# Side Effects: 965# The directory specified by $path (if it exists) is deleted. 966 967proc ::ftpd::command::MKD {sock filename} { 968 upvar #0 ::ftpd::$sock data 969 970 set path [file join $data(cwd) [string trimleft $filename /]] 971 972 if {[::ftpd::hasCallback authFileCmd]} { 973 set cmd $::ftpd::cfg(authFileCmd) 974 lappend cmd $data(user) $path write 975 if {[eval $cmd] == 0} { 976 puts $sock "550 $filename: Permission denied" 977 return 978 } 979 } 980 981 if {[catch {::ftpd::Fs mkdir $path $sock} f]} { 982 puts $sock "500 MKD Failed: $path $f" 983 } 984 return 985} 986 987# ::ftpd::command::NOOP -- 988# 989# Handle the NOOP ftp command. Do nothing. 990# 991# Arguments: 992# sock - The channel for this connection to the ftpd. 993# list - The arguments to the NOOP command. 994# 995# Results: 996# None. 997# 998# Side Effects: 999# Prints the proper NOOP response. 1000 1001proc ::ftpd::command::NOOP {sock list} { 1002 1003 puts $sock "200 NOOP command successful." 1004 return 1005} 1006 1007# ::ftpd::command::NLST -- 1008# 1009# Handle the NLST ftp command. Lists the full file stat of all of the 1010# files that are in the specified path. 1011# 1012# Arguments: 1013# sock - The channel for this connection to the ftpd. 1014# list - The arguments to the NLST command. 1015# 1016# Results: 1017# None. 1018# 1019# Side Effects: 1020# A listing of file stats is written to the socket. 1021 1022proc ::ftpd::command::NLST {sock filename} { 1023 ::ftpd::List $sock $filename nlst 1024 return 1025} 1026 1027# ::ftpd::command::PASS -- 1028# 1029# Handle the PASS ftp command. Check whether the specified user 1030# and password are allowed to log in (using the authUsrCmd). If 1031# they are allowed to log in, they are allowed to continue. If 1032# not ::ftpd::Log is used to log and error, and an "Access Denied" 1033# error is sent back. 1034# 1035# Arguments: 1036# sock - The channel for this connection to the ftpd. 1037# list - The arguments to the PASS command. 1038# 1039# Results: 1040# None. 1041# 1042# Side Effects: 1043# The user is accepted, or an error is logged and the user/password is 1044# denied.. 1045 1046proc ::ftpd::command::PASS {sock password} { 1047 upvar #0 ::ftpd::$sock data 1048 1049 if {$password == ""} { 1050 puts $sock "530 Please login with USER and PASS." 1051 return 1052 } 1053 set data(pass) $password 1054 1055 ::ftpd::Log debug "pass <$data(pass)>" 1056 1057 if {![::ftpd::hasCallback authUsrCmd]} { 1058 error "-authUsrCmd must not be empty, need a way to authenticate the user." 1059 } 1060 1061 # Call out to authenticate the user. A return value of 0 or an 1062 # error causes the system to reject the connection. Everything 1063 # else (with 1 prefered) leads to acceptance. 1064 1065 set cmd $::ftpd::cfg(authUsrCmd) 1066 lappend cmd $data(user) $data(pass) 1067 1068 set fail [catch {eval $cmd} res] 1069 1070 if {$fail} { 1071 ::ftpd::Log error "AuthUsr error: $res" 1072 } 1073 if {$fail || ($res == 0)} { 1074 ::ftpd::Log note "AuthUsr: Access denied to <$data(user)> <$data(pass)>." 1075 unset data(user) 1076 unset data(pass) 1077 puts $sock "551 Access Denied" 1078 } else { 1079 puts $sock "230 OK" 1080 set data(access) 1 1081 } 1082 return 1083} 1084 1085# ::ftpd::command::PORT -- 1086# 1087# Handle the PORT ftp command. Create a new socket with the specified 1088# paramaters. 1089# 1090# Arguments: 1091# sock - The channel for this connection to the ftpd. 1092# list - The arguments to the PORT command. 1093# 1094# Results: 1095# None. 1096# 1097# Side Effects: 1098# A new socket, data(sock2), is opened. 1099 1100proc ::ftpd::command::PORT {sock numbers} { 1101 upvar #0 ::ftpd::$sock data 1102 set x [split $numbers ,] 1103 1104 ::ftpd::FinishData $sock 1105 1106 set data(sock2) [socket [join [lrange $x 0 3] .] \ 1107 [expr {([lindex $x 4] << 8) | [lindex $x 5]}]] 1108 fconfigure $data(sock2) -translation $data(mode) 1109 puts $sock "200 PORT OK" 1110 return 1111} 1112 1113# ::ftpd::command::PWD -- 1114# 1115# Handle the PWD ftp command. Prints the current working directory to 1116# the socket. 1117# 1118# Arguments: 1119# sock - The channel for this connection to the ftpd. 1120# list - The arguments to the PWD command. 1121# 1122# Results: 1123# None. 1124# 1125# Side Effects: 1126# Prints the current working directory to the socket. 1127 1128proc ::ftpd::command::PWD {sock list} { 1129 upvar #0 ::ftpd::$sock data 1130 ::ftpd::Log debug $data(cwd) 1131 puts $sock "257 \"$data(cwd)\" is current directory." 1132 return 1133} 1134 1135# ::ftpd::command::QUIT -- 1136# 1137# Handle the QUIT ftp command. Closes the socket. 1138# 1139# Arguments: 1140# sock - The channel for this connection to the ftpd. 1141# list - The arguments to the PWD command. 1142# 1143# Results: 1144# None. 1145# 1146# Side Effects: 1147# Closes the connection. 1148 1149proc ::ftpd::command::QUIT {sock list} { 1150 ::ftpd::Log note "Closed $sock" 1151 puts $sock "221 Goodbye." 1152 ::ftpd::Finish $sock 1153 # FRINK: nocheck 1154 #unset ::ftpd::$sock 1155 return 1156} 1157 1158# ::ftpd::command::REIN -- 1159# 1160# Handle the REIN ftp command. This command terminates a USER, flushing 1161# all I/O and account information, except to allow any transfer in 1162# progress to be completed. All parameters are reset to the default 1163# settings and the control connection is left open. 1164# 1165# Arguments: 1166# sock - The channel for this connection to the ftpd. 1167# list - The arguments to the REIN command. 1168# 1169# Results: 1170# None. 1171# 1172# Side Effects: 1173# The file specified by $path (if it exists) is copied to the socket 1174# data(sock2) otherwise a 'Copy Failed' message is output. 1175 1176proc ::ftpd::command::REIN {sock list} { 1177 upvar #0 ::ftpd::$sock data 1178 1179 ::ftpd::FinishData $sock 1180 catch {close $data(sock2a)} 1181 1182 # Reinitialize the user and connection data. 1183 1184 array set data [list \ 1185 access 0 \ 1186 state command \ 1187 buffering line \ 1188 cwd "$::ftpd::cwd" \ 1189 mode binary \ 1190 sock2a "" \ 1191 sock2 ""] 1192 1193 return 1194} 1195 1196# ::ftpd::command::RETR -- 1197# 1198# Handle the RETR ftp command. Gets a readable channel for the file 1199# specified from ::ftpd::Fs and copies the file to second socket 1200# data(sock2). 1201# 1202# Arguments: 1203# sock - The channel for this connection to the ftpd. 1204# list - The arguments to the RETR command. 1205# 1206# Results: 1207# None. 1208# 1209# Side Effects: 1210# The file specified by $path (if it exists) is copied to the socket 1211# data(sock2) otherwise a 'Copy Failed' message is output. 1212 1213proc ::ftpd::command::RETR {sock filename} { 1214 upvar #0 ::ftpd::$sock data 1215 1216 set path [file join $data(cwd) [string trimleft $filename /]] 1217 1218 if {[::ftpd::hasCallback authFileCmd]} { 1219 set cmd $::ftpd::cfg(authFileCmd) 1220 lappend cmd $data(user) $path read 1221 if {[eval $cmd] == 0} { 1222 puts $sock "550 $filename: Permission denied" 1223 return 1224 } 1225 } 1226 1227 # 1228 # Patched Mark O'Connor 1229 # 1230 if {![catch {::ftpd::Fs retr $path $data(mode)} f]} { 1231 puts $sock "150 Copy Started ($data(mode))" 1232 fcopy $f $data(sock2) -command [list ::ftpd::GetDone $sock $data(sock2) $f ""] 1233 } else { 1234 puts $sock "500 Copy Failed: $path $f" 1235 ::ftpd::FinishData $sock 1236 } 1237 return 1238} 1239 1240# ::ftpd::command::RMD -- 1241# 1242# Handle the RMD ftp command. Remove the specified directory. 1243# 1244# Arguments: 1245# sock - The channel for this connection to the ftpd. 1246# list - The arguments to the RMD command. 1247# 1248# Results: 1249# None. 1250# 1251# Side Effects: 1252# The directory specified by $path (if it exists) is deleted. 1253 1254proc ::ftpd::command::RMD {sock filename} { 1255 upvar #0 ::ftpd::$sock data 1256 1257 set path [file join $data(cwd) [string trimleft $filename /]] 1258 1259 if {[::ftpd::hasCallback authFileCmd]} { 1260 set cmd $::ftpd::cfg(authFileCmd) 1261 lappend cmd $data(user) $path write 1262 if {[eval $cmd] == 0} { 1263 puts $sock "550 $filename: Permission denied" 1264 return 1265 } 1266 } 1267 if {[catch {::ftpd::Fs rmdir $path $sock} f]} { 1268 puts $sock "500 RMD Failed: $path $f" 1269 } 1270 return 1271} 1272 1273# ::ftpd::command::RNFR -- 1274# 1275# Handle the RNFR ftp command. Stores the name of the file to rename 1276# from. 1277# 1278# Arguments: 1279# sock - The channel for this connection to the ftpd. 1280# list - The arguments to the RNFR command. 1281# 1282# Results: 1283# None. 1284# 1285# Side Effects: 1286# If the file specified by $path exists, then store the name and request 1287# the next name. 1288 1289proc ::ftpd::command::RNFR {sock filename} { 1290 upvar #0 ::ftpd::$sock data 1291 1292 set path [file join $data(cwd) [string trimleft $filename /]] 1293 1294 if {[file exists $path]} { 1295 if {[::ftpd::hasCallback authFileCmd]} { 1296 set cmd $::ftpd::cfg(authFileCmd) 1297 lappend cmd $data(user) $path write 1298 if {[eval $cmd] == 0} { 1299 puts $sock "550 $filename: Permission denied" 1300 return 1301 } 1302 } 1303 1304 puts $sock "350 File exists, ready for destination name" 1305 set data(renameFrom) $path 1306 } else { 1307 puts $sock "550 $path: No such file or directory." 1308 } 1309 return 1310} 1311 1312# ::ftpd::command::RNTO -- 1313# 1314# Handle the RNTO ftp command. Renames the file specified by 'RNFR' if 1315# one was specified. 1316# 1317# Arguments: 1318# sock - The channel for this connection to the ftpd. 1319# list - The arguments to the RNTO command. 1320# 1321# Results: 1322# None. 1323# 1324# Side Effects: 1325# The specified file is renamed. 1326 1327proc ::ftpd::command::RNTO {sock filename} { 1328 upvar #0 ::ftpd::$sock data 1329 1330 if {$filename == ""} { 1331 puts $sock "500 'RNTO': command not understood." 1332 return 1333 } 1334 1335 set path [file join $data(cwd) [string trimleft $filename /]] 1336 1337 if {![info exists data(renameFrom)]} { 1338 puts $sock "503 Bad sequence of commands." 1339 return 1340 } 1341 if {[::ftpd::hasCallback authFileCmd]} { 1342 set cmd $::ftpd::cfg(authFileCmd) 1343 lappend cmd $data(user) $path write 1344 if {[eval $cmd] == 0} { 1345 puts $sock "550 $filename: Permission denied" 1346 return 1347 } 1348 } 1349 1350 1351 if {![catch {::ftpd::Fs rename $data(renameFrom) $path} msg]} { 1352 unset data(renameFrom) 1353 } else { 1354 unset data(renameFrom) 1355 puts $sock "500 'RNTO': command not understood." 1356 } 1357 return 1358} 1359 1360# ::ftpd::command::SIZE -- 1361# 1362# Handle the SIZE ftp command. Prints the modification time of the 1363# specified file to the socket. 1364# 1365# Arguments: 1366# sock - The channel for this connection to the ftpd. 1367# list - The arguments to the MDTM command. 1368# 1369# Results: 1370# None. 1371# 1372# Side Effects: 1373# Prints the size of the specified file to the socket. 1374 1375proc ::ftpd::command::SIZE {sock filename} { 1376 upvar #0 ::ftpd::$sock data 1377 1378 set path [file join $data(cwd) [string trimleft $filename /]] 1379 if {[catch {::ftpd::Fs size $path $sock} msg]} { 1380 puts $sock "500 SIZE Failed: $path $msg" 1381 ::ftpd::FinishData $sock 1382 } 1383 return 1384} 1385 1386# ::ftpd::command::STOR -- 1387# 1388# Handle the STOR ftp command. Gets a writable channel for the file 1389# specified from ::ftpd::Fs and copies the data from data(sock2) to 1390# the writable channel. 1391# 1392# Arguments: 1393# sock - The channel for this connection to the ftpd. 1394# list - The arguments to the STOR command. 1395# 1396# Results: 1397# None. 1398# 1399# Side Effects: 1400# The data is copied to from the socket data(sock2) to the 1401# writable channel to create a file. 1402 1403proc ::ftpd::command::STOR {sock filename} { 1404 upvar #0 ::ftpd::$sock data 1405 1406 set path [file join $data(cwd) [string trimleft $filename /]] 1407 if {[::ftpd::hasCallback authFileCmd]} { 1408 set cmd $::ftpd::cfg(authFileCmd) 1409 lappend cmd $data(user) $path write 1410 if {[eval $cmd] == 0} { 1411 puts $sock "550 $filename: Permission denied" 1412 return 1413 } 1414 } 1415 1416 # 1417 # Patched Mark O'Connor 1418 # 1419 if {![catch {::ftpd::Fs store $path $data(mode)} f]} { 1420 puts $sock "150 Copy Started ($data(mode))" 1421 fcopy $data(sock2) $f -command [list ::ftpd::GetDone $sock $data(sock2) $f ""] 1422 } else { 1423 puts $sock "500 Copy Failed: $path $f" 1424 ::ftpd::FinishData $sock 1425 } 1426 return 1427} 1428 1429# ::ftpd::command::STOU -- 1430# 1431# Handle the STOR ftp command. Gets a writable channel for the file 1432# specified from ::ftpd::Fs and copies the data from data(sock2) to 1433# the writable channel. 1434# 1435# Arguments: 1436# sock - The channel for this connection to the ftpd. 1437# list - The arguments to the STOU command. 1438# 1439# Results: 1440# None. 1441# 1442# Side Effects: 1443# The data is copied to from the socket data(sock2) to the 1444# writable channel to create a file. 1445 1446proc ::ftpd::command::STOU {sock filename} { 1447 upvar #0 ::ftpd::$sock data 1448 1449 set path [file join $data(cwd) [string trimleft $filename /]] 1450 if {[::ftpd::hasCallback authFileCmd]} { 1451 set cmd $::ftpd::cfg(authFileCmd) 1452 lappend cmd $data(user) $path write 1453 if {[eval $cmd] == 0} { 1454 puts $sock "550 $filename: Permission denied" 1455 return 1456 } 1457 } 1458 1459 set file $path 1460 set i 0 1461 while {[::ftpd::Fs exists $file]} { 1462 set file "$path.$i" 1463 incr i 1464 } 1465 1466 # 1467 # Patched Mark O'Connor 1468 # 1469 if {![catch {::ftpd::Fs store $file $data(mode)} f]} { 1470 puts $sock "150 Copy Started ($data(mode))" 1471 fcopy $data(sock2) $f -command [list ::ftpd::GetDone $sock $data(sock2) $f $file] 1472 } else { 1473 puts $sock "500 Copy Failed: $path $f" 1474 ::ftpd::FinishData $sock 1475 } 1476 return 1477} 1478 1479# ::ftpd::command::SYST -- 1480# 1481# Handle the SYST ftp command. Print the system information. 1482# 1483# Arguments: 1484# sock - The channel for this connection to the ftpd. 1485# list - The arguments to the SYST command. 1486# 1487# Results: 1488# None. 1489# 1490# Side Effects: 1491# Prints the system information. 1492 1493proc ::ftpd::command::SYST {sock list} { 1494 upvar #0 ::ftpd::$sock data 1495 1496 global tcl_platform 1497 1498 if {[string equal $tcl_platform(platform) "unix"]} { 1499 set platform UNIX 1500 } elseif {[string equal $tcl_platform(platform) "windows"]} { 1501 set platform WIN32 1502 } elseif {[string equal $tcl_platform(platform) "macintosh"]} { 1503 set platform MACOS 1504 } else { 1505 set platform UNKNOWN 1506 } 1507 set version [string toupper $tcl_platform(os)] 1508 puts $sock "215 $platform Type: L8 Version: $version" 1509 1510 return 1511} 1512 1513# ::ftpd::command::TYPE -- 1514# 1515# Handle the TYPE ftp command. Sets up the proper translation mode on 1516# the data socket data(sock2) 1517# 1518# Arguments: 1519# sock - The channel for this connection to the ftpd. 1520# list - The arguments to the TYPE command. 1521# 1522# Results: 1523# None. 1524# 1525# Side Effects: 1526# The translation mode of the data channel is changed to the appropriate 1527# mode. 1528 1529proc ::ftpd::command::TYPE {sock type} { 1530 upvar #0 ::ftpd::$sock data 1531 1532 if {[string compare i [string tolower $type]] == 0} { 1533 set data(mode) binary 1534 } else { 1535 set data(mode) auto 1536 } 1537 1538 if {$data(sock2) != {}} { 1539 fconfigure $data(sock2) -translation $data(mode) 1540 } 1541 puts $sock "200 Type set to $type." 1542 return 1543} 1544 1545# ::ftpd::command::USER -- 1546# 1547# Handle the USER ftp command. Store the username, and request a 1548# password. 1549# 1550# Arguments: 1551# sock - The channel for this connection to the ftpd. 1552# list - The arguments to the USER command. 1553# 1554# Results: 1555# None. 1556# 1557# Side Effects: 1558# A message is printed asking for the password. 1559 1560proc ::ftpd::command::USER {sock username} { 1561 upvar #0 ::ftpd::$sock data 1562 1563 if {$username == ""} { 1564 puts $sock "530 Please login with USER and PASS." 1565 return 1566 } 1567 set data(user) $username 1568 puts $sock "331 Password Required" 1569 1570 ::ftpd::Log debug "user <$data(user)>" 1571 return 1572} 1573 1574# ::ftpd::GetDone -- 1575# 1576# The fcopy command callback for both the RETR and STOR calls. Called 1577# after the fcopy completes. 1578# 1579# Arguments: 1580# sock - The channel for this connection to the ftpd. 1581# sock2 - The data socket data(sock2). 1582# f - The file channel. 1583# filename - The name of the unique file (if a unique 1584# transfer was requested), and the empty string 1585# otherwise 1586# bytes - The number of bytes that were copied. 1587# err - Passed if an error occurred during the fcopy. 1588# 1589# Results: 1590# None. 1591# 1592# Side Effects: 1593# The open file channel is closed and a 'complete' message is printed to 1594# the socket. 1595 1596proc ::ftpd::GetDone {sock sock2 f filename bytes {err {}}} { 1597 upvar #0 ::ftpd::$sock data 1598 variable cfg 1599 1600 close $f 1601 FinishData $sock 1602 1603 if {[string length $err]} { 1604 puts $sock "226- $err" 1605 } elseif {$filename == ""} { 1606 puts $sock "226 Transfer complete ($bytes bytes)" 1607 } else { 1608 puts $sock "226 Transfer complete (unique file name: $filename)." 1609 } 1610 if {[hasCallback xferDoneCmd]} then { 1611 catch {$cfg(xferDoneCmd) $sock $sock2 $f $bytes $filename $err} 1612 } 1613 Log debug "GetDone $f $sock2 $bytes bytes filename: $filename" 1614 return 1615} 1616 1617# ::ftpd::List -- 1618# 1619# Handle the NLST and LIST ftp commands. Shared command to do the 1620# actual listing of files. 1621# 1622# Arguments: 1623# sock - The channel for this connection to the ftpd. 1624# filename - The path/filename to list. 1625# style - The type of listing -- nlst or list. 1626# 1627# Results: 1628# None. 1629# 1630# Side Effects: 1631# A listing of file stats is written to the socket. 1632 1633proc ::ftpd::List {sock filename style} { 1634 upvar #0 ::ftpd::$sock data 1635 puts $sock "150 Opening data channel" 1636 1637 set path [file join $data(cwd) $filename] 1638 1639 Fs dlist $path $style $data(sock2) 1640 1641 FinishData $sock 1642 puts $sock "226 Listing complete" 1643 return 1644} 1645 1646# Standard filesystem - Assume the files are held on a standard disk. This 1647# namespace contains the commands to act as the default fsCmd callback for the 1648# ftpd. 1649 1650namespace eval ::ftpd::fsFile { 1651 # Our document root directory 1652 1653 variable docRoot 1654 if {![info exists docRoot]} { 1655 set docRoot / 1656 } 1657 1658 namespace export docRoot fs 1659} 1660 1661# ::ftpd::fsFile::docRoot -- 1662# 1663# Set or query the root of the ftpd file system. If no 'dir' argument 1664# is passed, or if the 'dir' argument is the null string, then the 1665# current docroot is returned. If a non-NULL 'dir' argument is passed 1666# in it is set as the docRoot. 1667# 1668# Arguments: 1669# dir - The directory to set as the ftp docRoot. 1670# (optional. If unspecified, the current docRoot 1671# is returned). 1672# 1673# Results: 1674# None. 1675# 1676# Side Effects: 1677# Sets the docRoot to the specified directory if a directory is 1678# specified. 1679 1680proc ::ftpd::fsFile::docRoot {{dir {}}} { 1681 variable docRoot 1682 if {[string length $dir] == 0} { 1683 return $docRoot 1684 } else { 1685 set docRoot $dir 1686 } 1687 return "" 1688} 1689 1690# ::ftpd::fsFile::fs -- 1691# 1692# Handles the a standard file systems file system requests and is the 1693# default fsCmd callback. 1694# 1695# Arguments: 1696# command - The filesystem command (one of dlist, retr, or 1697# store). 'dlist' will list files in a 1698# directory, 'retr' will get a channel to 1699# to read the specified file from, and 'store' 1700# will return the channel to write to. 1701# path - The file name or directory to read, write or 1702# list. 1703# args - Additional arguments for filesystem commands. 1704# Currently this is used by 'dlist' which 1705# has two additional arguments 'style' and 1706# 'channel-to-write-dir-list-to'. It is also 1707# used by 'size' and 'mtime' which have one 1708# additional argument 'channel-to-write-to'. 1709# 1710# Results: 1711# For a 'appe', 'retr', or 'stor' a channel is returned. For 'exists' a 1 1712# is returned if the path exists, and is not a directory. Otherwise a 1713# 0 is returned. For 'permissions' the octal file permissions (i.e. 1714# the 'file stat' mode) are returned. 1715# 1716# Side Effects: 1717# For 'dlist' a directory listing for the specified path is written to 1718# the specified channel. For 'mtime' the modification time is written 1719# or an error is thrown. An error is thrown if there is no fsCmd 1720# callback configured for the ftpd. 1721 1722proc ::ftpd::fsFile::fs {command path args} { 1723 # append <path> 1724 # delete <path> <channel-to-write-to> 1725 # dlist <path> <style> <channel-to-write-dir-list-to> 1726 # exists <path> 1727 # mkdir <path> <channel-to-write-to> 1728 # mtime <path> <channel-to-write-mtime-to> 1729 # permissions <path> 1730 # rename <path> <newpath> <channel-to-write-to> 1731 # retr <path> 1732 # rmdir <path> <channel-to-write-to> 1733 # size <path> <channel-to-write-size-to> 1734 # store <path> 1735 1736 global tcl_platform 1737 1738 variable docRoot 1739 1740 set path [file join $docRoot $path] 1741 1742 switch -exact -- $command { 1743 append { 1744 # 1745 # Patched Mark O'Connor 1746 # 1747 set fhandle [open $path a] 1748 if {[lindex $args 0] == "binary"} { 1749 fconfigure $fhandle -translation binary -encoding binary 1750 } 1751 return $fhandle 1752 } 1753 retr { 1754 # 1755 # Patched Mark O'Connor 1756 # 1757 set fhandle [open $path r] 1758 if {[lindex $args 0] == "binary"} { 1759 fconfigure $fhandle -translation binary -encoding binary 1760 } 1761 return $fhandle 1762 } 1763 store { 1764 # 1765 # Patched Mark O'Connor 1766 # 1767 set fhandle [open $path w] 1768 if {[lindex $args 0] == "binary"} { 1769 fconfigure $fhandle -translation binary -encoding binary 1770 } 1771 return $fhandle 1772 } 1773 dlist { 1774 foreach {style outchan} $args break 1775 ::ftpd::Log debug "at dlist {$style} {$outchan} {$path}" 1776 #set path [glob -nocomplain $path] 1777 #::ftpd::Log debug "at dlist2 {$style} {$outchan} {$path}" 1778 1779 # Attempt to get a list of all files (even ones that start with .) 1780 1781 if {[file isdirectory $path]} { 1782 set path1 [file join $path *] 1783 set path2 [file join $path .*] 1784 } else { 1785 set path1 $path 1786 set path2 $path 1787 } 1788 1789 # Get a list of all files that match the glob pattern 1790 1791 set fileList [lsort -unique [concat [glob -nocomplain $path1] \ 1792 [glob -nocomplain $path2]]] 1793 1794 ::ftpd::Log debug "File list is {$fileList}" 1795 1796 switch -- $style { 1797 nlst { 1798 ::ftpd::Log debug "In nlist" 1799 foreach f [lsort $fileList] { 1800 if {[string equal [file tail $f] "."] || \ 1801 [string equal [file tail $f] ".."]} { 1802 continue 1803 } 1804 if {[string equal {} $f]} then continue 1805 ::ftpd::Log debug [file tail $f] 1806 puts $outchan [file tail $f] 1807 } 1808 } 1809 list { 1810 # [ 766112 ] report . and .. directories (linux) 1811 # Copied the code from 'nlst' above to handle this. 1812 1813 foreach f [lsort $fileList] { 1814 if {[string equal [file tail $f] "."] || \ 1815 [string equal [file tail $f] ".."]} { 1816 continue 1817 } 1818 file stat $f stat 1819 if {[string equal $tcl_platform(platform) "unix"]} { 1820 set user [file attributes $f -owner] 1821 set group [file attributes $f -group] 1822 } else { 1823 set user owner 1824 set group group 1825 } 1826 puts $outchan [format "%s %3d %s %8s %11s %s %s" \ 1827 [PermBits $f $stat(mode)] $stat(nlink) \ 1828 $user $group $stat(size) \ 1829 [FormDate $stat(mtime)] [file tail $f]] 1830 } 1831 } 1832 default { 1833 error "Unknown list style <$style>" 1834 } 1835 } 1836 } 1837 delete { 1838 foreach {outchan} $args break 1839 1840 if {![file exists $path]} { 1841 puts $outchan "550 $path: No such file or directory." 1842 } elseif {![file isfile $path]} { 1843 puts $outchan "550 $path: File exists." 1844 } else { 1845 file delete $path 1846 puts $outchan "250 DELE command successful." 1847 } 1848 } 1849 exists { 1850 if {[file isdirectory $path]} { 1851 return 0 1852 } else { 1853 return [file exists $path] 1854 } 1855 } 1856 mkdir { 1857 foreach {outchan} $args break 1858 1859 set path [string trimright $path /] 1860 if {[file exists $path]} { 1861 if {[file isdirectory $path]} { 1862 puts $outchan "521 \"$path\" directory exists" 1863 } else { 1864 puts $outchan "521 \"$path\" already exists" 1865 } 1866 } elseif {[file exists [file dirname $path]]} { 1867 file mkdir $path 1868 puts $outchan "257 \"$path\" new directory created." 1869 } else { 1870 puts $outchan "550 $path: No such file or directory." 1871 } 1872 } 1873 mtime { 1874 foreach {outchan} $args break 1875 1876 if {![file exists $path]} { 1877 puts $outchan "550 $path: No such file or directory" 1878 } elseif {![file isfile $path]} { 1879 puts $outchan "550 $path: not a plain file." 1880 } else { 1881 set time [file mtime $path] 1882 puts $outchan [clock format $time -format "213 %Y%m%d%H%M%S"] 1883 } 1884 } 1885 permissions { 1886 file stat $path stat 1887 return $stat(mode) 1888 } 1889 rename { 1890 foreach {newname outchan} $args break 1891 1892 if {![file isdirectory [file dirname $newname]]} { 1893 puts $outchan "550 rename: No such file or directory." 1894 } 1895 file rename $path $newname 1896 puts $sock "250 RNTO command successful." 1897 } 1898 rmdir { 1899 foreach {outchan} $args break 1900 1901 if {![file isdirectory $path]} { 1902 puts $outchan "550 $path: Not a directory." 1903 } elseif {[llength [glob -nocomplain [file join $path *]]] != 0} { 1904 puts $outchan "550 $path: Directory not empty." 1905 } else { 1906 file delete $path 1907 puts $outchan "250 RMD command successful." 1908 } 1909 } 1910 size { 1911 foreach {outchan} $args break 1912 1913 if {![file exists $path]} { 1914 puts $outchan "550 $path: No such file or directory" 1915 } elseif {![file isfile $path]} { 1916 puts $outchan "550 $path: not a plain file." 1917 } else { 1918 puts $outchan "213 [file size $path]" 1919 } 1920 } 1921 default { 1922 error "Unknown command \"$command\"" 1923 } 1924 } 1925 return "" 1926} 1927 1928# ::ftpd::fsFile::PermBits -- 1929# 1930# Returns the file permissions for the specified file. 1931# 1932# Arguments: 1933# file - The file to return the permissions of. 1934# 1935# Results: 1936# The permissions for the specified file are returned. 1937# 1938# Side Effects: 1939# None. 1940 1941proc ::ftpd::fsFile::PermBits {file mode} { 1942 1943 array set s { 1944 0 --- 1 --x 2 -w- 3 -wx 4 r-- 5 r-x 6 rw- 7 rwx 1945 } 1946 1947 set type [file type $file] 1948 if {[string equal $type "file"]} { 1949 set permissions "-" 1950 } else { 1951 set permissions [string index $type 0] 1952 } 1953 foreach j [split [format %03o [expr {$mode&0777}]] {}] { 1954 append permissions $s($j) 1955 } 1956 1957 return $permissions 1958} 1959 1960# ::ftpd::fsFile::FormDate -- 1961# 1962# Returns the file permissions for the specified file. 1963# 1964# Arguments: 1965# seconds - The number of seconds returned by 'file mtime'. 1966# 1967# Results: 1968# A formatted date is returned. 1969# 1970# Side Effects: 1971# None. 1972 1973proc ::ftpd::fsFile::FormDate {seconds} { 1974 1975 set currentTime [clock seconds] 1976 set oldTime [clock scan "6 months ago" -base $currentTime] 1977 if {$seconds <= $oldTime} { 1978 set time [clock format $seconds -format "%Y"] 1979 } else { 1980 set time [clock format $seconds -format "%H:%M"] 1981 } 1982 set day [string trimleft [clock format $seconds -format "%d"] 0] 1983 set month [clock format $seconds -format "%b"] 1984 return [format "%3s %2s %5s" $month $day $time] 1985} 1986 1987# Only provide the package if it has been successfully 1988# sourced into the interpreter. 1989 1990# 1991# Patched Mark O'Connor 1992# 1993package provide ftpd 1.2.5 1994 1995 1996## 1997## Implementation of passive command 1998## 1999proc ::ftpd::command::PASV {sock argument} { 2000 upvar #0 ::ftpd::$sock data 2001 2002 set data(sock2a) [socket -server [list ::ftpd::PasvAccept $sock] 0] 2003 set list1 [fconfigure $sock -sockname] 2004 set ip [lindex $list1 0] 2005 set list2 [fconfigure $data(sock2a) -sockname] 2006 set port [lindex $list2 2] 2007 ::ftpd::Log debug "PASV on {$list1} {$list2} $ip $port" 2008 set ans [split $ip {.}] 2009 lappend ans [expr {($port >> 8) & 0xff}] [expr {$port & 0xff}] 2010 set ans [join $ans {,}] 2011 puts $sock "227 Entering Passive Mode ($ans)." 2012 return 2013} 2014 2015 2016proc ::ftpd::PasvAccept {sock sock2 ip port} { 2017 upvar #0 ::ftpd::$sock data 2018 2019 ::ftpd::Log debug "In Pasv Accept with {$sock} {$sock2} {$ip} {$port}" 2020 ## 2021 ## Verify this is from who it should be 2022 ## 2023 if {![string equal $ip $data(ip)]} then { 2024 ## 2025 ## Nope, so close it and wait some more 2026 ## 2027 close $sock2 2028 return 2029 } 2030 ::ftpd::FinishData $sock 2031 2032 set data(sock2) $sock2 2033 fconfigure $data(sock2) -translation $data(mode) 2034 close $data(sock2a) 2035 set data(sock2a) "" 2036 return 2037} 2038 2039 2040