[David Easton] ''20 Oct 2004'' - Here is a simple [TFTP] server written purely in [Tcl] but requiring [TclUDP].  It supports octet (binary) and nearly supports netascii (ascii) - see limitations below.

It has been tested by running it on [Windows] (Tcl 8.4.6) and using an [HPUX] 11i tftp client.

'''Limitations:'''
   * '''Security''' - Update tftpd::securityCheckRead and tftpd::securityCheckWrite to add security checking based on hostname or filename.  The default is set to only allow the local machine (127.0.0.1).

   * '''netascii mode''' does not translate end of line characters when receiving - this is because it needs to read the socket in binary mode to determine the number of bytes of data sent, but could do with reading it with -translation auto to automatically translate end of line characters. 'Is there a way to determine how many bytes were read from a socket prior to translation of end-of-line characters?' Another solution would be to send the data through another socket to translate it.

'''See:'''
   * [TFTP Client]
   * [TFTP]

Feel free to fix/improve this and use it however you wish. 

[David Easton] ''21 Oct 2004'' - Updated to make it more resilient following testing with [TFTP Client]

[Craig French] '9 Feb 2005' - (Thanks for a great server David) Fixed error handler tftpd::tftpdReceive to look at the packet data.

[David Easton] '9 Feb 2005' - Thanks Craig, I'm glad it is of use to you.
----
package provide tftpd 1.0
 
 namespace eval tftpd {
 
     package require udp
     
     namespace export tftpd
 
     variable S
     set S(rexmt)    5000 ;# Per-packet timeout (ms)
     set S(timeout) 25000 ;# Total timeout (ms)
     set S(listenPort) 69 ;# TFTPD port
     set S(verbose)  2    ;# Print output (2=high, 1=medium, 0=low)
 }
 
 # Returns: 0 - Passed security check
 #          1 - Failed security check
 proc tftpd::securityCheckRead {host file} {
     verbose 1 "Running security check on sending $file to $host"
     if { $host != "127.0.0.1" } {
         return 1
     } else {
         return 0
     }
 }
 
 # Returns: 0 - Passed security check
 #          1 - Failed security check
 proc tftpd::securityCheckWrite {host file} {
     verbose 1 "Running security check on writing $file from $host"
     if { $host != "127.0.0.1" } {
         return 1
     } else {
         return 0
     }
 }
 
 proc tftpd::verbose {level message} {
     
     variable S
     
     if { $level <= $S(verbose) } {
         puts "$message"
     }
 }
 
 proc tftpd::tftpd {} {
     
     variable S
     
     # Open listening port
     set sock [udp_open $S(listenPort)]
     fconfigure $sock -buffering none -translation binary
     fileevent $sock readable [list tftpd::tftpdReceive $sock]
     
     verbose 1 "Listening on UDP port: [udp_conf $sock -myport], sock: $sock"
 }
 
 proc tftpd::tftpdReceive {sock} {
     
     set pkt [read $sock]
     foreach {host port} [udp_conf $sock -peer] {break}
     
     set type "???"
     # Get packet type from 2nd byte
     binary scan $pkt xc type
     
     verbose 2 "Received type $type packet from $host:$port on port [udp_conf $sock -myport]"
     
     if { $type == 1 || $type == 2 } {
         
         binary scan $pkt xxa* str
         
         if {[regexp {([^\000]+)\000([^\000]+)\000} $str - filename mode]} {
             
             if { $mode != "octet" && $mode != "netascii" } {
                 sendError $sock 0 "Unsupported mode $mode"
             } elseif { $type == 1 } {
                 verbose 2 "<-- RRQ $host:$port (file $filename, mode $mode)"
                 startRead $sock $filename $mode $host $port
             } else {
                 verbose 2 "<-- WRQ $host:$port (file $filename, mode $mode)"
                 startWrite $sock $filename $mode $host $port
             }
         } else {
             verbose 2 "<-- RRQ/WRQ $host:$port (Invalid packet)"
             sendError $sock 0 "Invalid packet format"
         }
     } else {
         verbose 2 "<-- Unexpected type $type $host:$port ([string length $pkt] bytes)"
         sendError $sock 4 "Illegal TFTP operation"
     }
 }
 
 proc tftpd::sockReceive {sock host port} {
     
     variable S
     
     set pkt [read $sock]
     
     # Check that host and port are as expected
     foreach {thishost thisport} [udp_conf $sock -peer] {break}
     if { "$thishost" != "$host" || "$thisport" != "$port" } {        
         sendError $sock 5 "Unknown transfer ID"
         return
     }
     
     cancelTimeout $sock
     set S($sock,timAfterId) [after $S(timeout) [list tftpd::timeout $sock]]
     
     # 1st 2 bytes determine the packet type
     set type ???
     binary scan $pkt xc type
         
     switch -- $type {
         
         1 -
         2 { # Error - should not get RRQ/WRQ here
             verbose2 "RRQ/WRQ received on port [udp_conf $sock -myport]"
             sendError $sock 4 "Illegal TFTP operation"
             closeSock $sock
         }        
         3 { # DATA
             binary scan $pkt xxSa* block data
             set size [string length $data]
             verbose 2 "<-- DATA (block $block, $size bytes)"
             
             if { $block == $S($sock,lastblock) } {
                 # Already received, resend ACK
                 sendAck $sock $block
             } elseif { $block == $S($sock,lastblock) + 1 } {
                 # New data, save to file and send ACK
                 puts -nonewline $S($sock,fid) $data
                 incr S($sock,lastblock)
                 sendAck $sock $block
             } else {
                 # Unexpected block, send error
                 sendError 4 "Illegal TFTP operation, incorrect block number: $block"
             }
             
             # Stop if $size < 512
             if { $size < 512 } {
                 verbose 1 "Receipt of $S($sock,file) complete"
                 closeSock $sock
             }
         }        
         4 { # ACK
             binary scan $pkt xxS block
             verbose 2 "<-- ACK (block $block)"
             # Send the next block of data
             incr block
             sendData $sock $block
         }        
         5 { # ERROR
             binary scan $pkt xxxca* errCode errMsg
             verbose 1 "<-- ERROR ($errCode $errMsg)"
             closeSock $sock
         }
         default {
             verbose 2 "<-- Unknown type ([string length $pkt] bytes) received on port [udp_conf $sock -myport]"
             closeSock $sock
         }
     }
 }
 
 proc tftpd::timeout {sock} {
     
     variable S
     
     if {[info exists S($sock,file)]} {
         verbose 1 "Timed out for file $S($sock,file)"
     } else {
         verbose 1 "Timed out"
     }
     closeSock $sock
 }
 
 proc tftpd::cancelTimeout {sock} {
     
     variable S
     
     catch {after cancel $S($sock,timAfterId)}
     catch {after cancel $S($sock,pktAfterId)}
 }
 
 proc tftpd::closeSock {sock} {
     
     variable S
 
     verbose 2 "Closing port [udp_conf $sock -myport]"
     cancelTimeout $sock
     catch {close $sock}
     catch {close $S($sock,fid)}
     array unset S "$sock,*"
 }
 
 proc tftpd::startRead {sock filename mode host port} {
     
     variable S
     
     if {[securityCheckRead $host $filename]} {
         sendError $sock 2 "Access violation"
     } elseif { ![file exists $filename] } {       
         sendError $sock 1 "File $filename not found"
     } elseif {[catch {open $filename r} fid]} {
         sendError $sock 0 "Error opening file: $fid"
     } else {
 
         verbose 1 "Sending $filename, mode $mode to $host:$port"
 
         if { $mode == "octet" } {
             fconfigure $fid -translation binary -buffersize 512
         }
         
         # Create our new sending port
         set newsock [udp_open]
         udp_conf $newsock $host $port
         fconfigure $newsock -buffering none -translation binary
         
         # Listen for more replies
         fileevent $newsock readable [list tftpd::sockReceive $newsock $host $port]
         
         set S($newsock,fid) $fid
         set S($newsock,file) $filename
         set S($newsock,lastblock) 65025 ;# This is 255*255
         
         set S($newsock,timAfterId) [after $S(timeout) [list tftpd::timeout $newsock]]
         sendData $newsock 1
     }
 }
 
 proc tftpd::startWrite {sock filename mode host port} {
     
     variable S
     
     if {[securityCheckWrite $host $filename]} {
         sendError $sock 2 "Access violation"
     } elseif { [file exists $filename] } {
         sendError $sock 6 "File $filename already exists"
     } elseif {[catch {open $filename w} fid]} {
         sendError $sock 0 "Error opening file: $fid"
     } else {
         
         verbose 1 "Receiving $filename, mode $mode from $host:$port"
         
         if { $mode == "octet" } {
             fconfigure $fid -translation binary -buffersize 512
         }
         
         # Create our new sending port
         set newsock [udp_open]
         udp_conf $newsock $host $port
         fconfigure $newsock -buffering none -translation binary
     
         # Listen for more replies
         fileevent $newsock readable [list tftpd::sockReceive $newsock $host $port]
         
         set S($newsock,fid)  $fid
         set S($newsock,file) $filename
         set S($newsock,lastblock) 0 ;# Record last block received
         
         set S($newsock,timAfterId) [after $S(timeout) [list tftpd::timeout $newsock]]
         sendAck $newsock 0
     }
 }
 
 proc tftpd::sendData {sock block} {
     
     variable S
     
     # See if all block have been sent
     if { $block > $S($sock,lastblock) } {
         verbose 1 "Send $S($sock,file) complete"
         closeSock $sock
         return
     }
     
     # This could be a resend, so seek to correct place in file
     seek $S($sock,fid) [expr {($block - 1) * 512}] start    
     set data [read $S($sock,fid) 512]
     set len [string length $data]
     
     # Mark as last block if less than 512 bytes
     if { $len < 512 } {
         set S($sock,lastblock) $block
     }
 
     verbose 2 "DATA --> (block $block, $len bytes)"
     puts $sock [binary format xcSa* 3 $block $data]
     
     set S($sock,pktAfterId) [after $S(rexmt) [list tftpd::sendData $sock $block]]
 }
 
 proc tftpd::sendAck {sock block} {
     
     variable S
     
     verbose 2 "ACK --> (block $block)"
     puts -nonewline $sock [binary format xcS 4 $block]
     
     set S($sock,pktAfterId) [after $S(rexmt) [list tftpd::sendAck $sock $block]]
 }
 
 proc tftpd::sendError {sock errCode errMsg } {
     
     verbose 1 "ERROR --> ($errCode $errMsg)"
     puts -nonewline $sock [binary format xcxca*x 5 $errCode $errMsg]
 }
 
----

To use it, ensure that TclUDP is available and then:

 package require tftpd
 tftpd::tftpd

----
[Jeff Smith] '3 March 2005' Just gave the server a try, backing up the configuration file from a cisco router. I got part of the file transfered to the server but the router threw some errors. I was wondering if I was running into one of the limitations you mentioned above or am I doing something wrong.

The output from the router is
 Router#copy run tftp
 Address or name of remote host []? 10.8.201.1
 Destination filename [Router-confg]? mttd.cfg
 !
 TFTP: unexpected packet with unknown opcode.!
 TFTP: unexpected packet with unknown opcode..
 TFTP: unexpected packet with unknown opcode.!
 TFTP: unexpected packet with unknown opcode..
 TFTP: unexpected packet with unknown opcode..
 TFTP: unexpected packet with unknown opcode.
 %Error writing tftp://10.8.201.1/mttd.cfg (Write error).
 TFTP: unexpected packet with unknown opcode.!
 Router#

The output from the TFTP server is
 (udp1.0.6) 5 %  tftpd::tftpd
 Listening on UDP port: 69, sock: sock364
 Received type 2 packet from 10.9.181.3:53657 on port 69
 <-- WRQ 10.9.181.3:53657 (file mttd.cfg, mode octet)
 Running security check on writing mttd.cfg from 10.9.181.3
 Receiving mttd.cfg, mode octet from 10.9.181.3:53657
 ACK --> (block 0)
 <-- DATA (block 1, 512 bytes)
 ACK --> (block 1)
 <-- DATA (block 1, 512 bytes)
 ACK --> (block 1)
 <-- DATA (block 2, 512 bytes)
 ACK --> (block 2)
 <-- DATA (block 2, 512 bytes)
 ACK --> (block 2)
 <-- DATA (block 2, 512 bytes)
 ACK --> (block 2)
 <-- DATA (block 2, 512 bytes)
 ACK --> (block 2)
 <-- DATA (block 3, 512 bytes)
 ACK --> (block 3)
 <-- DATA (block 3, 512 bytes)
 ACK --> (block 3)
 <-- DATA (block 3, 512 bytes)
 ACK --> (block 3)
 <-- DATA (block 3, 512 bytes)
 ACK --> (block 3)
 <-- DATA (block 3, 512 bytes)
 ACK --> (block 3)
 <-- DATA (block 3, 0 bytes)
 ACK --> (block 3)
 Receipt of mttd.cfg complete
 Closing port 1357
 (udp1.0.6) 6 % 

[David Easton] ''3 March 2005'' This is not a problem that I'm aware of.  The Cisco router is not recognising many of the ACK messages and so is resending the same data blocks several times.  However, it obviously does sometimes recognise them as sometimes it sends the next data block - weird.  The security is OK as it starts to send the file.  The TFTP server thinks it is in octet mode and so it is not a netascii problem.  All I can think of is to check that the Cisco router thinks it is using octet (binary) mode.  Perhaps someone else will have other ideas.

[Jeff Smith] ''8 March 2005'' I had luck with the Cisco router when I added a "-nonewline" after the "puts" statement in the "sendAck" procedure. 

[David Easton] ''8 March 2005'' I've tested "-nonewline" with the [HPUX] 11i tftp client and that works, so I've added it to the above code in both the "sendAck" and "sendError" procedure.  Thanks for the improvement.
----
[[
[Category Internet] [Category Application]
]]