[OpenSPARC-T2-SAM] / obp / obp / pkg / netinet / 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 1.2 05/03/25
purpose: TFTP support
copyright: Copyright 2005 Sun Microsystems, Inc.  All Rights Reserved
copyright: Use is subject to license terms.

\ RFC  906: Bootstrap loading using TFTP
\ RFC 1350: The TFTP Protocol

fload ${BP}/pkg/netinet/tftp-h.fth

headerless

0        instance value     tftp-sockid
/timer   instance buffer:   tftp-timer
/insock  instance buffer:   tftp-cli-addr
/insock  instance buffer:   tftp-srv-addr
/insock  instance buffer:   tftp-from-addr
         instance variable  tftp-from-len
0        instance value     tftp-sndbuf
         instance variable  tftp-sndbuflen
0        instance value     tftp-rcvbuf
         instance variable  tftp-nextblk#
0        instance value     tftp-retries

: tftp-init ( siaddr -- )
   tftp-cli-addr my-ip-addr 0            insock-init		( ipaddr )
   tftp-srv-addr swap       IPPORT_TFTP  insock-init		( )

   /tftp-packet alloc-mem  to tftp-sndbuf			( )
   /tftp-packet alloc-mem  to tftp-rcvbuf			( )

   AF_INET SOCK_DGRAM IPPROTO_UDP socreate to tftp-sockid	( )
   tftp-sockid tftp-cli-addr /insock  sobind 			( )
;

: tftp-close ( -- )
   tftp-sndbuf /tftp-packet free-mem
   tftp-rcvbuf /tftp-packet free-mem
   tftp-sockid soclose
;

\ Send a packet to the TFTP server
: tftp-send-packet ( -- )
   tftp-sockid tftp-sndbuf tftp-sndbuflen @ 0 tftp-srv-addr /insock
   sosendto 0<  if
      ." TFTP: Could not send to "
      tftp-srv-addr .insock  tftp-sockid .soerror  -1 throw
   then
;

\ Send a TFTP read request 
: tftp-send-rrq ( mode$ file$ -- )
   tftp-sndbuf >r				( mode$ file$ ) ( r: pkt )
   TFTP_RRQ  r@ >tftp-opcode  htonw!		( mode$ file$ )
             r@ >tftp-file    $cstrput		( mode$ adr )
                              $cstrput		( adr' )
   r> - tftp-sndbuflen !			( ) ( r: )
   1 tftp-nextblk# !				( )
   tftp-send-packet				( )
;

\ Format and send a TFTP ack packet. 
: tftp-send-ack ( block# -- )
   tftp-sndbuf					( block# pkt )
   TFTP_ACK over >tftp-opcode    htonw!		( block# pkt )
                 >tftp-block#    htonw!		( )
   /tftp-header  tftp-sndbuflen  !		( )
   tftp-send-packet				( )
;

\ Format a TFTP ERROR packet and send it to the specified endpoint. Used
\ to reject connections once a connection to a TFTP server has been
\ established.

: tftp-send-error ( insock -- )
   /tftp-packet alloc-mem  swap >r			( pkt ) ( r: insock )
   TFTP_ERROR  over >tftp-opcode   htonw!		( pkt )
   5           over >tftp-errcode  htonw!		( pkt )
   " Unknown transfer ID"				( pkt $ )
               2 pick >tftp-data   $cstrput		( pkt pktend )
   over tuck -						( pkt pkt len )
   tftp-sockid -rot 0 r> /insock sosendto drop		( pkt ) ( r: )
   /tftp-packet free-mem				( )
;

\ Managing timeouts and retransmissions. Use a simple exponential backoff 
\ strategy (with a maximum timeout of 32 seconds) between retries. Abort 
\ the file transfer if the maximum number of retries has been exceeded.

: tftp-retransmit-packet ( -- )
   tftp-retries tftp-max-retries u> if			( )
      ." TFTP: Transfer timed out"  -1 throw
   then							( )
   tftp-retries 1+  dup to tftp-retries			( n )
   d# 10 mod 0=  if					( )
      ." Timed out waiting for TFTP reply" cr		( )
   then							( )
   tftp-send-packet					( )
;

: tftp-backoff ( -- )
   tftp-timer  dup clear-timer 2* d# 32000 min  set-timer
;

\ Process incoming TFTP packets addressed to our port. If this is an
\ ERROR packet, we accept the error only if the we know the TFTP
\ server's address and the error is on this connection.

: (tftp-receive-packet) ( -- pkt len )
   tftp-sockid tftp-rcvbuf tuck /tftp-packet 0 tftp-from-addr tftp-from-len
   sorecvfrom
;

: tftp-receive-packet ( -- pkt len true | false )
   (tftp-receive-packet) dup 0= if 2drop false exit then
   over >tftp-opcode ntohw@  TFTP_ERROR =  if		( pkt len )
      tftp-srv-addr >sin-addr dup ip=broadcast? if	( pkt len ipaddr )
         3drop false exit				( false )
      then						( pkt len ipaddr )
      tftp-from-addr >sin-addr ip<>  if			( pkt len )
         2drop false exit				( false )
      then						( pkt len )
      drop >tftp-errmsg cscount				( error$ )
      ." TFTP Error: " type cr  -1 throw		( )
   then							( pkt len )
   true							( pkt len true )
;

\ Processing TFTP DATA packets. If this is the first response, register
\ the server's IP address and port number (TID). Once a connection has
\ been established, other connections are rejected by returning an 
\ ERROR packet.
 
: (tftp-receive-data) ( -- pkt len true | false )
   tftp-receive-packet 0=  if  false exit  then		( pkt len )
   over >tftp-opcode ntohw@  TFTP_DATA <>  if		( pkt len )
      2drop false exit					( false )
   then							( pkt len )
   tftp-srv-addr dup >sin-port ntohw@ IPPORT_TFTP = if	( pkt len srvaddr )
      tftp-from-addr insock>addr,port insock-init true	( pkt len true )
   else							( pkt len srvaddr )
      tftp-from-addr insock=  if			( pkt len )
         true						( pkt len true )
      else						( pkt len )
         tftp-from-addr tftp-send-error  2drop false	( false )
      then						( pkt len true | false )
   then							( pkt len true | false )
;

: tftp-receive-data ( -- pkt len true | false )
   (tftp-receive-data)  if			( pkt len )
      over >tftp-block# ntohw@  dup >r		( pkt len blk ) ( r: blk )
      tftp-nextblk# @ =  if			( pkt len )
         1 tftp-nextblk# +!  true		( pkt len true )
      else					( pkt len )
         2drop false				( false )
      then					( pkt len true | false )
      r> tftp-send-ack				( pkt len true | false ) ( r: )
   else						( )
      false					( false )
   then						( pkt len true | false )
;

\ Wait for a DATA packet to arrive.
: (tftp-read-data) ( -- data datalen true | false )
   begin  tftp-timer timer-expired? 0=  while		( )
      tftp-receive-data if				( pkt len )
         /tftp-header encapsulated-data true exit	( data datalen true )
      then						( )
   repeat  false					( false )
;

\ Copy TFTP segment data to memory and check if there's more data to come.
: tftp-read-data ( adr -- adr' more? )
   tftp-timer d# 4000 set-timer				( adr )
   begin  (tftp-read-data) 0=  while			( adr )
      tftp-retransmit-packet  tftp-backoff		( adr )
   repeat						( adr data datalen )
   >r  over r@ move  r@ ca+  r> TFTP_SEGSIZE =		( adr' more? )
;

: tftp-read ( adr filename$ -- size )
   " octet" 2swap tftp-send-rrq				( adr )
   dup  begin  tftp-read-data  while			( adr adr' )
      show-progress					( adr adr' )
   repeat  swap -					( size )
;

: tftp-load ( adr filename$ siaddr -- size )
   tftp-init						( adr filename$ )
   ['] tftp-read catch  if				( adr filename$ )
      tftp-close  -1 throw
   then							( size )
   tftp-close						( size )
;

headers
Commit	Line	Data
920dae64 AT	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 1.2 05/03/25
	43	purpose: TFTP support
	44	copyright: Copyright 2005 Sun Microsystems, Inc. All Rights Reserved
	45	copyright: Use is subject to license terms.
	46
	47	\ RFC 906: Bootstrap loading using TFTP
	48	\ RFC 1350: The TFTP Protocol
	49
	50	fload ${BP}/pkg/netinet/tftp-h.fth
	51
	52	headerless
	53
	54	0 instance value tftp-sockid
	55	/timer instance buffer: tftp-timer
	56	/insock instance buffer: tftp-cli-addr
	57	/insock instance buffer: tftp-srv-addr
	58	/insock instance buffer: tftp-from-addr
	59	instance variable tftp-from-len
	60	0 instance value tftp-sndbuf
	61	instance variable tftp-sndbuflen
	62	0 instance value tftp-rcvbuf
	63	instance variable tftp-nextblk#
	64	0 instance value tftp-retries
65
66	: tftp-init ( siaddr -- )
67	tftp-cli-addr my-ip-addr 0 insock-init ( ipaddr )
68	tftp-srv-addr swap IPPORT_TFTP insock-init ( )
69
70	/tftp-packet alloc-mem to tftp-sndbuf ( )
71	/tftp-packet alloc-mem to tftp-rcvbuf ( )
72
73	AF_INET SOCK_DGRAM IPPROTO_UDP socreate to tftp-sockid ( )
74	tftp-sockid tftp-cli-addr /insock sobind ( )
75	;
76
77	: tftp-close ( -- )
78	tftp-sndbuf /tftp-packet free-mem
79	tftp-rcvbuf /tftp-packet free-mem
80	tftp-sockid soclose
81	;
82
83	\ Send a packet to the TFTP server
84	: tftp-send-packet ( -- )
85	tftp-sockid tftp-sndbuf tftp-sndbuflen @ 0 tftp-srv-addr /insock
86	sosendto 0< if
87	." TFTP: Could not send to "
88	tftp-srv-addr .insock tftp-sockid .soerror -1 throw
89	then
90	;
91
92	\ Send a TFTP read request
93	: tftp-send-rrq ( mode$ file$ -- )
94	tftp-sndbuf >r ( mode$ file$ ) ( r: pkt )
95	TFTP_RRQ r@ >tftp-opcode htonw! ( mode$ file$ )
96	r@ >tftp-file $cstrput ( mode$ adr )
97	$cstrput ( adr' )
98	r> - tftp-sndbuflen ! ( ) ( r: )
99	1 tftp-nextblk# ! ( )
100	tftp-send-packet ( )
101	;
102
103	\ Format and send a TFTP ack packet.
104	: tftp-send-ack ( block# -- )
105	tftp-sndbuf ( block# pkt )
106	TFTP_ACK over >tftp-opcode htonw! ( block# pkt )
107	>tftp-block# htonw! ( )
108	/tftp-header tftp-sndbuflen ! ( )
109	tftp-send-packet ( )
110	;
111
112	\ Format a TFTP ERROR packet and send it to the specified endpoint. Used
113	\ to reject connections once a connection to a TFTP server has been
114	\ established.
115
116	: tftp-send-error ( insock -- )
117	/tftp-packet alloc-mem swap >r ( pkt ) ( r: insock )
118	TFTP_ERROR over >tftp-opcode htonw! ( pkt )
119	5 over >tftp-errcode htonw! ( pkt )
120	" Unknown transfer ID" ( pkt $ )
121	2 pick >tftp-data $cstrput ( pkt pktend )
122	over tuck - ( pkt pkt len )
123	tftp-sockid -rot 0 r> /insock sosendto drop ( pkt ) ( r: )
124	/tftp-packet free-mem ( )
125	;
126
127	\ Managing timeouts and retransmissions. Use a simple exponential backoff
128	\ strategy (with a maximum timeout of 32 seconds) between retries. Abort
129	\ the file transfer if the maximum number of retries has been exceeded.
130
131	: tftp-retransmit-packet ( -- )
132	tftp-retries tftp-max-retries u> if ( )
133	." TFTP: Transfer timed out" -1 throw
134	then ( )
135	tftp-retries 1+ dup to tftp-retries ( n )
136	d# 10 mod 0= if ( )
137	." Timed out waiting for TFTP reply" cr ( )
138	then ( )
139	tftp-send-packet ( )
140	;
141
142	: tftp-backoff ( -- )
143	tftp-timer dup clear-timer 2* d# 32000 min set-timer
144	;
145
146	\ Process incoming TFTP packets addressed to our port. If this is an
147	\ ERROR packet, we accept the error only if the we know the TFTP
148	\ server's address and the error is on this connection.
149
150	: (tftp-receive-packet) ( -- pkt len )
151	tftp-sockid tftp-rcvbuf tuck /tftp-packet 0 tftp-from-addr tftp-from-len
152	sorecvfrom
153	;
154
155	: tftp-receive-packet ( -- pkt len true \| false )
156	(tftp-receive-packet) dup 0= if 2drop false exit then
157	over >tftp-opcode ntohw@ TFTP_ERROR = if ( pkt len )
158	tftp-srv-addr >sin-addr dup ip=broadcast? if ( pkt len ipaddr )
159	3drop false exit ( false )
160	then ( pkt len ipaddr )
161	tftp-from-addr >sin-addr ip<> if ( pkt len )
162	2drop false exit ( false )
163	then ( pkt len )
164	drop >tftp-errmsg cscount ( error$ )
165	." TFTP Error: " type cr -1 throw ( )
166	then ( pkt len )
167	true ( pkt len true )
168	;
169
170	\ Processing TFTP DATA packets. If this is the first response, register
171	\ the server's IP address and port number (TID). Once a connection has
172	\ been established, other connections are rejected by returning an
173	\ ERROR packet.
174
175	: (tftp-receive-data) ( -- pkt len true \| false )
176	tftp-receive-packet 0= if false exit then ( pkt len )
177	over >tftp-opcode ntohw@ TFTP_DATA <> if ( pkt len )
178	2drop false exit ( false )
179	then ( pkt len )
180	tftp-srv-addr dup >sin-port ntohw@ IPPORT_TFTP = if ( pkt len srvaddr )
181	tftp-from-addr insock>addr,port insock-init true ( pkt len true )
182	else ( pkt len srvaddr )
183	tftp-from-addr insock= if ( pkt len )
184	true ( pkt len true )
185	else ( pkt len )
186	tftp-from-addr tftp-send-error 2drop false ( false )
187	then ( pkt len true \| false )
188	then ( pkt len true \| false )
189	;
190
191	: tftp-receive-data ( -- pkt len true \| false )
192	(tftp-receive-data) if ( pkt len )
193	over >tftp-block# ntohw@ dup >r ( pkt len blk ) ( r: blk )
194	tftp-nextblk# @ = if ( pkt len )
195	1 tftp-nextblk# +! true ( pkt len true )
196	else ( pkt len )
197	2drop false ( false )
198	then ( pkt len true \| false )
199	r> tftp-send-ack ( pkt len true \| false ) ( r: )
200	else ( )
201	false ( false )
202	then ( pkt len true \| false )
203	;
204
205	\ Wait for a DATA packet to arrive.
206	: (tftp-read-data) ( -- data datalen true \| false )
207	begin tftp-timer timer-expired? 0= while ( )
208	tftp-receive-data if ( pkt len )
209	/tftp-header encapsulated-data true exit ( data datalen true )
210	then ( )
211	repeat false ( false )
212	;
213
214	\ Copy TFTP segment data to memory and check if there's more data to come.
215	: tftp-read-data ( adr -- adr' more? )
216	tftp-timer d# 4000 set-timer ( adr )
217	begin (tftp-read-data) 0= while ( adr )
218	tftp-retransmit-packet tftp-backoff ( adr )
219	repeat ( adr data datalen )
220	>r over r@ move r@ ca+ r> TFTP_SEGSIZE = ( adr' more? )
221	;
222
223	: tftp-read ( adr filename$ -- size )
224	" octet" 2swap tftp-send-rrq ( adr )
225	dup begin tftp-read-data while ( adr adr' )
226	show-progress ( adr adr' )
227	repeat swap - ( size )
228	;
229
230	: tftp-load ( adr filename$ siaddr -- size )
231	tftp-init ( adr filename$ )
232	['] tftp-read catch if ( adr filename$ )
233	tftp-close -1 throw
234	then ( size )
235	tftp-close ( size )
236	;
237
238	headers