| 1 | \ ========== Copyright Header Begin ========================================== |
| 2 | \ |
| 3 | \ Hypervisor Software File: tftp.fth |
| 4 | \ |
| 5 | \ Copyright (c) 2006 Sun Microsystems, Inc. All Rights Reserved. |
| 6 | \ |
| 7 | \ - Do no alter or remove copyright notices |
| 8 | \ |
| 9 | \ - Redistribution and use of this software in source and binary forms, with |
| 10 | \ or without modification, are permitted provided that the following |
| 11 | \ conditions are met: |
| 12 | \ |
| 13 | \ - Redistribution of source code must retain the above copyright notice, |
| 14 | \ this list of conditions and the following disclaimer. |
| 15 | \ |
| 16 | \ - Redistribution in binary form must reproduce the above copyright notice, |
| 17 | \ this list of conditions and the following disclaimer in the |
| 18 | \ documentation and/or other materials provided with the distribution. |
| 19 | \ |
| 20 | \ Neither the name of Sun Microsystems, Inc. or the names of contributors |
| 21 | \ may be used to endorse or promote products derived from this software |
| 22 | \ without specific prior written permission. |
| 23 | \ |
| 24 | \ This software is provided "AS IS," without a warranty of any kind. |
| 25 | \ ALL EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES, |
| 26 | \ INCLUDING ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A |
| 27 | \ PARTICULAR PURPOSE OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN |
| 28 | \ MICROSYSTEMS, INC. ("SUN") AND ITS LICENSORS SHALL NOT BE LIABLE FOR |
| 29 | \ ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR |
| 30 | \ DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. IN NO EVENT WILL SUN |
| 31 | \ OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, OR |
| 32 | \ FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE |
| 33 | \ DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY, |
| 34 | \ ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF |
| 35 | \ SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. |
| 36 | \ |
| 37 | \ You acknowledge that this software is not designed, licensed or |
| 38 | \ intended for use in the design, construction, operation or maintenance of |
| 39 | \ any nuclear facility. |
| 40 | \ |
| 41 | \ ========== Copyright Header End ============================================ |
| 42 | id: @(#)tftp.fth 2.24 02/08/22 |
| 43 | purpose: Trivial File Transfer Protocol (TFTP) implementation |
| 44 | copyright: Copyright 1990-2002 Sun Microsystems, Inc. All Rights Reserved |
| 45 | copyright: Use is subject to license terms. |
| 46 | |
| 47 | \ Trivial File Transfer Protocol |
| 48 | |
| 49 | decimal |
| 50 | |
| 51 | headerless |
| 52 | |
| 53 | d# 128 instance buffer: tftp-file-buf |
| 54 | instance defer tftp-file |
| 55 | ' tftp-file-buf to tftp-file |
| 56 | |
| 57 | 1 constant rrq-pkt |
| 58 | 2 constant wrq-pkt |
| 59 | 3 constant data-pkt |
| 60 | 4 constant ack-pkt |
| 61 | 5 constant err-pkt |
| 62 | |
| 63 | struct ( tftp packet ) |
| 64 | 2 field >opcode |
| 65 | 0 field >block# |
| 66 | 0 field >filename |
| 67 | 2 field >errorcode |
| 68 | 0 field >errmsg |
| 69 | d# 512 field >data |
| 70 | constant /tftp-packet |
| 71 | |
| 72 | : opcode ( -- ) active-struct@ >opcode ; |
| 73 | : block# ( -- ) active-struct@ >block# ; |
| 74 | : filename ( -- ) active-struct@ >filename ; |
| 75 | : errorcode ( -- ) active-struct@ >errorcode ; |
| 76 | : errmsg ( -- ) active-struct@ >errmsg ; |
| 77 | : data ( -- ) active-struct@ >data ; |
| 78 | |
| 79 | d# 69 constant UP_TFTP |
| 80 | |
| 81 | instance variable sid |
| 82 | instance variable did |
| 83 | instance variable this-block |
| 84 | instance variable #retries |
| 85 | instance variable #packet |
| 86 | |
| 87 | false instance value first-try? |
| 88 | |
| 89 | -1 instance value tftp-retries |
| 90 | |
| 91 | : too-many-tftp-retries? ( -- flag ) \ flag true if too many retries |
| 92 | #retries @ tftp-retries u>= |
| 93 | ; |
| 94 | |
| 95 | : .merror ( -- ) |
| 96 | use-server? use-dhcp @ or if |
| 97 | ." TFTP Error: " errmsg dup cstrlen type |
| 98 | abort |
| 99 | then |
| 100 | UP_TFTP did ! \ Unlock from server |
| 101 | ; |
| 102 | |
| 103 | : $cstrput ( from-adr,len to-adr -- end-adr ) |
| 104 | 3dup swap move ( from-adr,len to-adr ) |
| 105 | swap + nip ( end-adr-1 ) |
| 106 | 0 over c! ( end-adr-1 ) |
| 107 | 1+ |
| 108 | ; |
| 109 | |
| 110 | : setup-request ( file-name-str rrq-pkt/wrq-pkt -- ) |
| 111 | 0 this-block ! |
| 112 | packet-to-send active-struct ! |
| 113 | 1 sid +! |
| 114 | UP_TFTP did ! ( file-name rrq-pkt/wrq-pkt ) |
| 115 | opcode be-w! ( file-name-str ) |
| 116 | filename $cstrput ( mode-adr ) |
| 117 | " octet" rot $cstrput |
| 118 | packet-to-send - #packet ! |
| 119 | ; |
| 120 | |
| 121 | : setup-read-request ( file-name-string -- ) |
| 122 | rrq-pkt setup-request |
| 123 | 1 this-block +! |
| 124 | ; |
| 125 | |
| 126 | : setup-write-request ( file-name-string -- ) |
| 127 | wrq-pkt setup-request |
| 128 | ; |
| 129 | |
| 130 | : setup-ack-packet ( -- ) |
| 131 | packet-to-send active-struct ! |
| 132 | ack-pkt opcode be-w! |
| 133 | this-block @ block# be-w! |
| 134 | 4 #packet ! |
| 135 | 1 this-block +! |
| 136 | ; |
| 137 | |
| 138 | : send-packet ( tftp-adr tftp-len -- #sent ) |
| 139 | did @ his-udp-port ! |
| 140 | sid @ my-udp-port ! |
| 141 | ( tftp-adr tftp-len ) prepare-udp-packet ( len ) |
| 142 | transmit dup 0= if |
| 143 | ." TFTP send failed. Check Ethernet cable and transceiver" cr |
| 144 | then ( #sent ) |
| 145 | d# 4000 set-timeout |
| 146 | ; |
| 147 | |
| 148 | 0 instance value error-packet \ Buffer address |
| 149 | |
| 150 | : send-error-packet ( -- ) |
| 151 | /tftp-packet alloc-mem to error-packet |
| 152 | did @ >r |
| 153 | udp-source-port be-w@ did ! \ set the udp-source-port to the port indicated |
| 154 | \ in the received error packet. |
| 155 | error-packet active-struct ! |
| 156 | err-pkt opcode be-w! |
| 157 | 5 ( Unknown transfer ID ) errorcode be-w! |
| 158 | " Unknown source address" errmsg $cstrput ( end-address ) |
| 159 | error-packet tuck - ( packet-adr len ) |
| 160 | send-packet drop |
| 161 | r> did ! \ restore the previous did |
| 162 | error-packet /tftp-packet free-mem |
| 163 | ; |
| 164 | |
| 165 | : unlock-dest-ip-en-addr ( -- ) |
| 166 | use-server? use-router? use-dhcp @ or or if exit then |
| 167 | broadcast-ip-addr his-ip-addr 4 cmove |
| 168 | broadcast-en-addr his-en-addr 6 cmove |
| 169 | ; |
| 170 | |
| 171 | : lock-dest-ip-en-addr ( -- ) |
| 172 | active-struct @ |
| 173 | dup /ip-header - active-struct ! |
| 174 | ip-source-addr his-ip-addr 4 cmove |
| 175 | /ether-header negate active-struct +! |
| 176 | en-source-addr his-en-addr 6 cmove |
| 177 | active-struct ! |
| 178 | his-ip-addr server-ip-addr 4 cmove |
| 179 | ; |
| 180 | |
| 181 | \ Check source port against destination id. |
| 182 | \ If it mismatches, error unless did is currently 69 |
| 183 | : bad-src-port? ( -- error ) \ assumes active-struct is udp |
| 184 | false |
| 185 | udp-source-port be-w@ did @ <> if |
| 186 | did @ UP_TFTP = if |
| 187 | udp-source-port be-w@ did ! \ Lock onto his port |
| 188 | his-ip-addr broadcast-ip-addr? if |
| 189 | lock-dest-ip-en-addr \ Lock onto dest ip & ether addresses |
| 190 | then |
| 191 | else drop true |
| 192 | then |
| 193 | then |
| 194 | ; |
| 195 | |
| 196 | \ Check block number. Assumes active-struct is tftp. |
| 197 | : bad-block#? ( -- error? ) block# be-w@ this-block @ <> ; |
| 198 | |
| 199 | : send-current-packet ( -- #sent ) packet-to-send #packet @ send-packet ; |
| 200 | |
| 201 | : receive-tftp-packet ( -- [ tftp-pkt-adr tftp-pkt-len ] flag ) |
| 202 | begin |
| 203 | receive-udp-packet 0= if false exit then ( udp-pkt udp-len ) |
| 204 | drop active-struct ! ( ) |
| 205 | udp-dest-port be-w@ sid @ = |
| 206 | until |
| 207 | bad-src-port? if send-error-packet false exit then |
| 208 | active-struct @ /udp-header + ( tftp-pkt-adr ) |
| 209 | udp-length be-w@ /udp-header - ( tftp-pkt-adr tftp-len ) |
| 210 | true |
| 211 | ; |
| 212 | |
| 213 | : receive-data-packet ( -- [ data-adr data-len ] flag ) |
| 214 | begin |
| 215 | receive-tftp-packet 0= if false exit then ( tftp-adr tftp-len ) |
| 216 | over active-struct ! ( tftp-adr tftp-len ) |
| 217 | opcode be-w@ data-pkt <> bad-block#? or |
| 218 | while |
| 219 | opcode be-w@ err-pkt = if .merror then |
| 220 | 2drop |
| 221 | repeat ( tftp-adr tftp-len ) |
| 222 | false is first-try? |
| 223 | nip data swap 4 - true |
| 224 | ; |
| 225 | |
| 226 | : ?try-broadcast ( -- ) |
| 227 | first-try? if |
| 228 | unlock-dest-ip-en-addr |
| 229 | \ Relock the destination port number |
| 230 | d# 69 did ! |
| 231 | \ Give the server to come back up. Delay |
| 232 | \ re-broadcasting to avoid jaming up the net. |
| 233 | #retries @ if 5000 ms then |
| 234 | then |
| 235 | ; |
| 236 | |
| 237 | : get-data-packet ( adr -- adr' more? ) |
| 238 | #retries off |
| 239 | begin |
| 240 | send-current-packet drop |
| 241 | receive-data-packet |
| 242 | 0= while |
| 243 | ?try-broadcast |
| 244 | 1 #retries +! |
| 245 | #retries @ d# 10 /mod drop 0= if |
| 246 | ." Retrying ... Check TFTP server and network setup" cr |
| 247 | then |
| 248 | too-many-tftp-retries? if |
| 249 | ." TFTP retry count exceeded" cr false exit |
| 250 | then |
| 251 | repeat |
| 252 | |
| 253 | \ Copy data from packet to our buffer at addr |
| 254 | >r over r@ cmove ( adr ) |
| 255 | |
| 256 | r@ + ( adr' ) |
| 257 | r> d# 512 = ( adr' more? ) |
| 258 | ; |
| 259 | |
| 260 | : need-router? ( -- flag ) |
| 261 | server-ip-addr be-l@ on-my-net? 0= |
| 262 | ; |
| 263 | |
| 264 | : tftp-init ( -- ) |
| 265 | true is first-try? |
| 266 | packet-to-send 0= if |
| 267 | /tftp-packet alloc-mem to packet-to-send |
| 268 | /udp-pseudo-hdr alloc-mem to udp-pseudo-hdr |
| 269 | then |
| 270 | get-msecs h# 0ffff and sid ! \ "random" number |
| 271 | ; |
| 272 | |
| 273 | : tftp-close ( -- ) |
| 274 | packet-to-send /tftp-packet free-mem |
| 275 | 0 to packet-to-send |
| 276 | udp-pseudo-hdr /udp-pseudo-hdr free-mem |
| 277 | 0 to udp-pseudo-hdr |
| 278 | ; |
| 279 | |
| 280 | headers |
| 281 | : tftpread ( adr file-name -- size ) |
| 282 | tftp-init ( adr file-name ) |
| 283 | reserve-buffer ( adr file-name ) |
| 284 | setup-read-request ( adr ) |
| 285 | dup ( adr adr ) |
| 286 | begin |
| 287 | get-data-packet ( adr adr' more? ) |
| 288 | while |
| 289 | show-progress setup-ack-packet |
| 290 | repeat ( adr adr' ) |
| 291 | \ Send the final acknowledge. Don't send if receive error. |
| 292 | too-many-tftp-retries? 0= if |
| 293 | setup-ack-packet |
| 294 | send-current-packet drop \ ignore errors |
| 295 | then |
| 296 | swap - |
| 297 | release-buffer |
| 298 | tftp-close too-many-tftp-retries? if ." tftp failed" abort then |
| 299 | ; |
| 300 | |
| 301 | headerless |
| 302 | |
| 303 | \ previous definitions |
| 304 | |
| 305 | \ *** New routines for tftpwrite *** |
| 306 | |
| 307 | : receive-ack-packet ( -- [ ack-packet-adr ack-len ] flag ) |
| 308 | \ flag is true if good packet. other entries only if flag true |
| 309 | receive-tftp-packet ( [ tftp-packet-adr tftp-len ] flag ) |
| 310 | 0= if false exit then ( packet-adr len ) |
| 311 | over active-struct ! |
| 312 | |
| 313 | \ Check packet type |
| 314 | opcode be-w@ err-pkt = if .merror 2drop false exit then |
| 315 | opcode be-w@ ack-pkt <> if |
| 316 | ." Got a non-ack packet" 2drop false exit |
| 317 | then |
| 318 | |
| 319 | bad-block#? if 2drop false else nip data swap 4 - true then |
| 320 | ; |
| 321 | |
| 322 | : get-ack-packet ( -- ack-received? ) |
| 323 | #retries off |
| 324 | begin |
| 325 | send-current-packet |
| 326 | receive-ack-packet ( [ ack-packet-adr ack-len ] flag ) |
| 327 | 0= while |
| 328 | 1 #retries +! |
| 329 | |
| 330 | \ XXX we need to be able to retry the whole transaction at a higher |
| 331 | \ level, so we should exit more gracefully than we do here. |
| 332 | |
| 333 | too-many-tftp-retries? if ." receive failed" false exit then |
| 334 | repeat 2drop true |
| 335 | ; |
| 336 | |
| 337 | : setup-data-packet ( adr sizeleft -- adr' sizeleft' done? ) |
| 338 | dup 0< if true exit then |
| 339 | packet-to-send active-struct ! |
| 340 | data-pkt opcode be-w! |
| 341 | 1 this-block +! |
| 342 | this-block @ block# be-w! ( adr sizeleft ) |
| 343 | 2dup d# 512 min ( adr sizeleft adr size<=512 ) |
| 344 | dup 4 + #packet ! |
| 345 | data swap cmove |
| 346 | d# 512 - \ decrease size remaining |
| 347 | swap d# 512 + swap \ adjust addr for remaining data |
| 348 | false |
| 349 | ; |
| 350 | |
| 351 | headers |
| 352 | |
| 353 | : tftpwrite ( adr size file-name -- ) |
| 354 | tftp-init ( adr size ) |
| 355 | reserve-buffer ( adr size ) |
| 356 | setup-write-request ( adr size ) |
| 357 | begin |
| 358 | get-ack-packet if |
| 359 | setup-data-packet ( adr' sizeleft' done? ) |
| 360 | else true \ error exit from loop |
| 361 | then |
| 362 | until 2drop |
| 363 | release-buffer |
| 364 | tftp-close |
| 365 | ; |