obp/obp/pkg/dhcp/tftp.fth

\ ========== Copyright Header Begin ==========================================
\
\ Hypervisor Software File: tftp.fth
\
\ Copyright (c) 2006 Sun Microsystems, Inc. All Rights Reserved.
\
\  - Do no alter or remove copyright notices
\
\  - Redistribution and use of this software in source and binary forms, with
\    or without modification, are permitted provided that the following
\    conditions are met:
\
\  - Redistribution of source code must retain the above copyright notice,
\    this list of conditions and the following disclaimer.
\
\  - Redistribution in binary form must reproduce the above copyright notice,
\    this list of conditions and the following disclaimer in the
\    documentation and/or other materials provided with the distribution.
\
\    Neither the name of Sun Microsystems, Inc. or the names of contributors
\ may be used to endorse or promote products derived from this software
\ without specific prior written permission.
\
\     This software is provided "AS IS," without a warranty of any kind.
\ ALL EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES,
\ INCLUDING ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A
\ PARTICULAR PURPOSE OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN
\ MICROSYSTEMS, INC. ("SUN") AND ITS LICENSORS SHALL NOT BE LIABLE FOR
\ ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR
\ DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. IN NO EVENT WILL SUN
\ OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, OR
\ FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE
\ DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY,
\ ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF
\ SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
\
\ You acknowledge that this software is not designed, licensed or
\ intended for use in the design, construction, operation or maintenance of
\ any nuclear facility.
\
\ ========== Copyright Header End ============================================
id: @(#)tftp.fth 2.24 02/08/22
purpose: Trivial File Transfer Protocol (TFTP) implementation
copyright: Copyright 1990-2002 Sun Microsystems, Inc.  All Rights Reserved
copyright: Use is subject to license terms.

\ Trivial File Transfer Protocol

decimal

headerless

d# 128 instance buffer: tftp-file-buf
instance defer tftp-file
' tftp-file-buf to tftp-file

1 constant rrq-pkt
2 constant wrq-pkt
3 constant data-pkt
4 constant ack-pkt
5 constant err-pkt

struct ( tftp packet )
      2 field >opcode
      0 field >block#
      0 field >filename
      2 field >errorcode
      0 field >errmsg
d#  512 field >data
constant /tftp-packet

: opcode    ( -- )  active-struct@ >opcode ;
: block#    ( -- )  active-struct@ >block# ;
: filename  ( -- )  active-struct@ >filename ;
: errorcode ( -- )  active-struct@ >errorcode ;
: errmsg    ( -- )  active-struct@ >errmsg ;
: data      ( -- )  active-struct@ >data ;

d# 69 constant UP_TFTP

instance variable sid
instance variable did
instance variable this-block
instance variable #retries
instance variable #packet

false instance value first-try?

-1 instance value tftp-retries

: too-many-tftp-retries?  ( -- flag )  \ flag true if too many retries
   #retries @  tftp-retries u>=
;

: .merror  ( -- )
   use-server?  use-dhcp @  or  if
     ." TFTP Error: " errmsg dup cstrlen type
     abort
   then
   UP_TFTP did !        \ Unlock from server
;

: $cstrput  ( from-adr,len to-adr -- end-adr )
   3dup swap move   ( from-adr,len to-adr )
   swap +  nip      ( end-adr-1 )
   0 over c!        ( end-adr-1 )
   1+
;

: setup-request  ( file-name-str  rrq-pkt/wrq-pkt -- )
   0 this-block !
   packet-to-send active-struct !
   1 sid +!
   UP_TFTP did !        ( file-name  rrq-pkt/wrq-pkt )
   opcode be-w!    ( file-name-str )
   filename $cstrput ( mode-adr )
   " octet" rot $cstrput
   packet-to-send  -  #packet !
;

: setup-read-request  ( file-name-string -- )
   rrq-pkt setup-request
   1 this-block +!
;

: setup-write-request  ( file-name-string -- )
   wrq-pkt setup-request
;

: setup-ack-packet  ( -- )
   packet-to-send  active-struct !
   ack-pkt opcode be-w!
   this-block @  block#  be-w!
   4 #packet !
   1 this-block +!
;

: send-packet  ( tftp-adr tftp-len -- #sent )
   did @ his-udp-port !
   sid @ my-udp-port !
   ( tftp-adr tftp-len ) prepare-udp-packet ( len )
   transmit dup 0=  if
      ." TFTP send failed. Check Ethernet cable and transceiver" cr
   then                     ( #sent )
   d# 4000 set-timeout
;

0 instance value error-packet        \ Buffer address

: send-error-packet  ( -- )
   /tftp-packet alloc-mem to error-packet
   did @ >r
   udp-source-port be-w@ did !  \ set the udp-source-port to the port indicated
                              \ in the received error packet.
   error-packet  active-struct !
   err-pkt opcode be-w!
   5 ( Unknown transfer ID )  errorcode be-w!
   " Unknown source address" errmsg $cstrput  ( end-address )
   error-packet  tuck  -     ( packet-adr len )
   send-packet  drop
   r>  did !                 \ restore the previous did
   error-packet  /tftp-packet free-mem
;

: unlock-dest-ip-en-addr ( -- )
   use-server?  use-router?  use-dhcp @  or or if  exit  then
   broadcast-ip-addr his-ip-addr 4 cmove
   broadcast-en-addr his-en-addr 6 cmove
;

: lock-dest-ip-en-addr ( -- )
   active-struct @
   dup /ip-header - active-struct !
   ip-source-addr his-ip-addr 4 cmove
   /ether-header negate active-struct +!
   en-source-addr his-en-addr 6 cmove
   active-struct !
   his-ip-addr server-ip-addr 4 cmove
;

\ Check source port against destination id.
\ If it mismatches, error unless did is currently 69
: bad-src-port?  ( -- error )  \ assumes active-struct is udp
   false
   udp-source-port be-w@  did @  <>  if
      did @  UP_TFTP =  if
         udp-source-port be-w@  did !         \ Lock onto his port
         his-ip-addr broadcast-ip-addr?  if
            lock-dest-ip-en-addr              \ Lock onto dest ip & ether addresses
         then
      else  drop true
      then
   then
;

\ Check block number.  Assumes active-struct is tftp.
: bad-block#?  ( -- error? )  block# be-w@  this-block @ <>  ;

: send-current-packet  ( -- #sent )  packet-to-send  #packet @  send-packet  ;

: receive-tftp-packet  ( -- [ tftp-pkt-adr tftp-pkt-len ] flag )
   begin
      receive-udp-packet 0=  if  false exit  then     ( udp-pkt udp-len )
      drop active-struct !                            ( )
      udp-dest-port be-w@  sid @  =
   until
   bad-src-port?  if  send-error-packet false exit  then
   active-struct @ /udp-header +         ( tftp-pkt-adr )
   udp-length be-w@  /udp-header -       ( tftp-pkt-adr tftp-len )
   true
;

: receive-data-packet ( -- [ data-adr data-len ] flag )
   begin
      receive-tftp-packet 0=  if  false exit  then    ( tftp-adr tftp-len )
      over active-struct !                            ( tftp-adr tftp-len )
      opcode be-w@ data-pkt <>  bad-block#?  or
   while
      opcode be-w@ err-pkt =  if  .merror  then
      2drop
   repeat                                              ( tftp-adr tftp-len )
   false is  first-try?
   nip data swap 4 -  true
;

: ?try-broadcast  ( -- )
   first-try?  if
      unlock-dest-ip-en-addr
      \ Relock the destination port number
      d# 69 did !
      \ Give the server to come back up. Delay
      \ re-broadcasting to avoid jaming up the net.
      #retries @  if  5000 ms  then
   then
;

: get-data-packet ( adr -- adr' more? )
   #retries off
   begin
      send-current-packet drop
      receive-data-packet
   0= while
      ?try-broadcast
      1 #retries +!
      #retries @ d# 10 /mod drop 0=  if
         ." Retrying ... Check TFTP server and network setup" cr
      then
      too-many-tftp-retries?  if
         ." TFTP retry count exceeded" cr false exit
      then
   repeat

   \ Copy data from packet to our buffer at addr
   >r over r@ cmove  ( adr )

   r@ +           ( adr' )
   r> d# 512 =    ( adr' more? )
;

: need-router?  ( -- flag )
    server-ip-addr be-l@  on-my-net?  0=
;

: tftp-init  ( -- )
   true is first-try?
   packet-to-send 0=  if
      /tftp-packet alloc-mem to packet-to-send
      /udp-pseudo-hdr alloc-mem to udp-pseudo-hdr
   then
   get-msecs  h# 0ffff and  sid !  \ "random" number
;

: tftp-close  ( -- )
   packet-to-send /tftp-packet free-mem
   0 to packet-to-send
   udp-pseudo-hdr /udp-pseudo-hdr free-mem
   0 to udp-pseudo-hdr
;

headers
: tftpread  ( adr file-name -- size )
   tftp-init            ( adr file-name )
   reserve-buffer       ( adr file-name )
   setup-read-request   ( adr )
   dup                  ( adr adr )
   begin
      get-data-packet   ( adr adr' more? )
   while
      show-progress setup-ack-packet
   repeat               ( adr adr' )
   \ Send the final acknowledge.  Don't send if receive error.
   too-many-tftp-retries? 0= if
      setup-ack-packet
      send-current-packet drop   \ ignore errors
   then
   swap -
   release-buffer
   tftp-close too-many-tftp-retries? if ." tftp failed" abort then
;

headerless

\ previous definitions

\ *** New routines for tftpwrite ***

: receive-ack-packet  ( -- [ ack-packet-adr ack-len ] flag )
        \ flag is true if good packet.  other entries only if flag true
   receive-tftp-packet  ( [ tftp-packet-adr tftp-len ] flag )
   0=  if  false exit  then   ( packet-adr len )
   over active-struct !

   \ Check packet type
   opcode be-w@  err-pkt =  if  .merror 2drop false exit  then
   opcode be-w@  ack-pkt  <>  if
     ." Got a non-ack packet"  2drop false exit
   then

   bad-block#?  if  2drop false   else  nip data swap 4 -  true  then
;

: get-ack-packet  ( -- ack-received? )
   #retries off
   begin
      send-current-packet
      receive-ack-packet   ( [ ack-packet-adr ack-len ] flag )
   0= while
      1 #retries +!

\ XXX we need to be able to retry the whole transaction at a higher
\ level, so we should exit more gracefully than we do here.

      too-many-tftp-retries?  if  ." receive failed" false exit  then
   repeat   2drop true
;

: setup-data-packet  ( adr sizeleft -- adr' sizeleft' done? )
   dup 0<  if true exit then
   packet-to-send active-struct !
   data-pkt opcode be-w!
   1 this-block +!
   this-block @ block# be-w!    ( adr sizeleft )
   2dup  d# 512 min           ( adr sizeleft adr size<=512 )
   dup  4 + #packet !
   data swap cmove
   d# 512 -   \ decrease size remaining
   swap d# 512 + swap   \ adjust addr for remaining data
   false
;

headers

: tftpwrite  ( adr size file-name -- )
   tftp-init             ( adr size )
   reserve-buffer        ( adr size )
   setup-write-request   ( adr size )
   begin
      get-ack-packet if
         setup-data-packet  ( adr' sizeleft' done? )
      else true             \ error exit from loop
      then
   until  2drop
   release-buffer
   tftp-close
;