\ ========== Copyright Header Begin ==========================================
\ Hypervisor Software File: dhcp.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
\ - 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
\ ========== Copyright Header End ============================================
id: @(#)dhcp.fth 1.1 04/09/07
copyright: Copyright 2004 Sun Microsystems, Inc. All Rights Reserved
copyright: Use is subject to license terms.
\ RFC 2131: Dynamic Host Configuration Protocol
\ RFC 2132: DHCP Options and BOOTP Vendor Extensions
\ RFC 1534: Interoperation Between DHCP and BOOTP
fload ${BP}/pkg/netinet/dhcp-h.fth
0 instance value dhcp-sockid
/insock instance buffer: dhcp-srv-addr
/insock instance buffer: dhcp-cli-addr
d# 32 instance buffer: dhcp-classid
/ip-addr instance buffer: dhcp-offered-ip
/ip-addr instance buffer: dhcp-server-id
0 instance value dhcp-sndbuf
instance variable dhcp-sndbuflen
0 instance value dhcp-rcvbuf
0 instance value chosen-bootreply \ Best offer
0 instance value /chosen-bootreply
0 instance value best-offer-points
false instance value bootp-config? \ Is best offer a BOOTREPLY?
/timer instance buffer: dhcp-timer
instance variable dhcp-state \ DHCP FSM state
instance variable dhcp-xid \ Transaction identifier
\ Read a byte and advance the pointer.
: c@++ ( adr -- adr+1 c ) dup ca1+ swap c@ ;
\ Find an option in the specified area of a packet.
: (find-dhcp-option) ( adr len option# -- optadr optlen true | false )
>r over ca+ swap ( end start ) ( r: option# )
CD_END of r> 3drop false exit endof
r@ of r> drop nip c@++ true exit endof
\ Find the specified DHCP option. Options in a DHCP message may extend
\ to the 'sname' and 'file' fields if an 'option overload' option is
\ present in the variable length options field.
: find-dhcp-option ( pkt len option# -- optadr optlen true | false )
2 pick >dhcp-cookie ntohl@ BOOTMAGIC <> if
>r ( pkt,len ) ( r: opt# )
over >dhcp-options over /dhcp-header - ( pkt,len opts,len )
2dup r@ (find-dhcp-option) if ( pkt,len opts,len optadr,len )
2swap 2drop 2swap 2drop true ( optadr,len true )
else ( pkt,len opts,len )
CD_OPTION_OVERLOAD (find-dhcp-option) if ( pkt,len ovloption,len )
drop nip c@ dup 1 3 between if ( pkt ovlopt-value )
1 of >dhcp-file d# 128 endof
2 of >dhcp-sname d# 64 endof
3 of >dhcp-sname d# 192 endof
r@ (find-dhcp-option) ( optadr,len true | false )
then ( optadr,len true | false )
then ( optadr,len true | false )
then ( optadr,len true | false )
r> drop ( optadr,len true | false )
\ Determine if the packet contains a specific option.
: dhcp-option-found? ( pkt len option# -- found? )
find-dhcp-option if 2drop true else false then
\ Find a vendor specific option.
: find-vendor-option ( pkt len vendor-option# -- optadr optlen true | false )
>r ( pkt len ) ( r: opt# )
CD_VENDOR_SPEC find-dhcp-option if ( encap-options,len )
r@ (find-dhcp-option) ( optadr opten true | false )
then ( optadr optlen true | false )
r> drop ( optadr optlen true | false )
\ Add an option with a 8-bit value to the packet
: add-dhcpopt-byte ( adr code byte -- adr' )
rot >r ( code byte ) ( r: adr )
swap r@ >dhcpopt-code c! ( byte )
/c r@ >dhcpopt-len c! ( byte )
\ Add an option with a 16-bit value to the packet
: add-dhcpopt-word ( adr code value -- adr' )
rot >r ( code value ) ( r: adr )
swap r@ >dhcpopt-code c! ( value )
/w r@ >dhcpopt-len c! ( value )
r@ >dhcpopt-data htonw! ( )
\ Add an option encoding a stream of bytes to the packet.
: add-dhcpopt-bytes ( adr code data len -- adr' )
?dup if ( adr code data len )
3 roll >r ( code data len ) ( r: adr )
rot r@ >dhcpopt-code c! ( data len )
dup r@ >dhcpopt-len c! ( data len )
tuck r@ >dhcpopt-data swap move ( len )
r> swap 2+ ca+ ( adr' ) ( r: )
\ Maximum length of the DHCP message we are willing to accept.
: /dhcp-maxmsg ( -- n ) if-mtu@ /udpip-header - ;
\ The vendor class identifier is constructed from the root node's
\ "name" property, with commas (,) replaced with periods (.).
: init-dhcp-vendor-classid ( -- )
" /" " name" get-property decode-string 2swap 2drop ( $ )
dhcp-classid pack count bounds ?do ( )
i c@ ascii , = if ascii . i c! then ( )
\ DHCP initialization. Create a socket, initialize the client and
\ server socket address structures, and bind local address to the
\ socket. Allocate buffers to send/receive/store DHCP packets and
\ determine the vendor class identifier to use.
AF_INET SOCK_DGRAM IPPROTO_UDP socreate to dhcp-sockid ( )
dhcp-cli-addr my-ip-addr IPPORT_BOOTPC insock-init ( )
dhcp-srv-addr inaddr-broadcast IPPORT_BOOTPS insock-init ( )
/dhcp-maxmsg dup alloc-mem to dhcp-sndbuf ( n )
dup alloc-mem to dhcp-rcvbuf ( n )
alloc-mem to chosen-bootreply ( )
dhcp-sockid dhcp-cli-addr /insock sobind ( )
init-dhcp-vendor-classid ( )
\ DHCP state cleanup. Free the DHCP packet buffers and close the
dhcp-sndbuf /dhcp-maxmsg tuck free-mem ( n )
dhcp-rcvbuf over free-mem ( n )
chosen-bootreply swap free-mem ( )
\ Filling in DHCP message options. All DHCP messages include the DHCP
\ message type and the client identifier (if one is in use). DHCP_REQUEST
\ and DHCP_DECLINE messages must fill the DHCP server identifier and the
\ offered IP address. Messages other than DHCP_DECLINE must fill in the
\ DHCP vendor class identifier, the maximum DHCP message size we are
\ willing to accept, and the list of requested parameters. We explicitly
\ request values for subnet mask (Option 1), Router (Option 3), Hostname
\ (Option 12), and Vendor specific information (Option 43).
: add-dhcp-options ( pkt type -- pktlen )
>r dup >dhcp-options ( pkt adr ) ( r: type )
CD_DHCP_TYPE r@ add-dhcpopt-byte
CD_CLIENTID client-id count add-dhcpopt-bytes
CD_CLASSID dhcp-classid count add-dhcpopt-bytes
CD_REQUEST_LIST " "(01 03 0c 2b)" add-dhcpopt-bytes
CD_MAXMSG_SIZE /dhcp-maxmsg add-dhcpopt-word
CD_HOSTNAME hostname count add-dhcpopt-bytes
r> dup DHCP_REQUEST = swap DHCP_DECLINE = or if
CD_SERVER_ID dhcp-server-id /ip-addr add-dhcpopt-bytes
CD_REQ_IPADDR dhcp-offered-ip /ip-addr add-dhcpopt-bytes
CD_END over c! ca1+ swap - ( pktlen )
\ Common code to construct DHCP message to be sent.
: init-dhcp-packet ( type -- )
dhcp-sndbuf dup >r /dhcp-maxmsg erase ( type ) ( r: pkt )
BOOTREQUEST r@ >dhcp-op c!
if-htype@ r@ >dhcp-htype c!
if-addrlen@ r@ >dhcp-hlen c!
if-hwaddr r@ >dhcp-chaddr copy-hw-addr
dhcp-xid @ r@ >dhcp-xid htonl!
my-ip-addr r@ >dhcp-ciaddr copy-ip-addr
BOOTMAGIC r@ >dhcp-cookie htonl!
r> swap add-dhcp-options dhcp-sndbuflen ! ( ) ( r: )
\ Transmit formatted DHCP message.
: send-dhcp-packet ( -- )
dhcp-sockid dhcp-sndbuf dhcp-sndbuflen @ ( sockid pkt len )
DHCP_MIN_PKTLEN max ( sockid pkt len' )
0 dhcp-srv-addr /insock sosendto drop ( )
\ Managing DHCP retransmissions. Use a randomized exponential backoff
\ to determine delay between retransmissions. On retries, the delay is
\ doubled (for a maximum of 64 seconds), and randomized by a random
\ number in the range +/-1.023 seconds.
dhcp-timer clear-timer 2* d# 64000 min ( timeout )
random dup d# 22 rshift swap 0< if negate then + ( timeout' )
dhcp-timer swap set-timer ( )
: retransmit-dhcp-packet ( -- )
send-dhcp-packet dhcp-backoff
\ Determine DHCP packet type. BOOTP packets are tagged as type 0.
: dhcp-packet-type ( pkt len -- type )
over >dhcp-cookie ntohl@ BOOTMAGIC = if ( pkt,len )
CD_DHCP_TYPE find-dhcp-option if drop c@ else 0 then ( type )
\ Receive data arriving on the socket.
: (receive-dhcp-packet) ( -- pkt len )
dhcp-sockid dhcp-rcvbuf tuck /dhcp-maxmsg 0 0 0 sorecvfrom
\ Incoming responses must be BOOTREPLY packets, and the xid should match.
: receive-dhcp-packet ( -- pkt len true | false )
(receive-dhcp-packet) dup 0= if 2drop false exit then
over >dhcp-op c@ BOOTREPLY <> if 2drop false exit then
over >dhcp-xid ntohl@ dhcp-xid @ <> if 2drop false exit then
\ Receive OFFER messages from the server. BOOTP responses must be
: receive-dhcp-offer ( -- pkt len true | false )
receive-dhcp-packet 0= if false exit then ( pkt len )
2dup dhcp-packet-type ( pkt len type )
dup 0= if drop true exit then ( pkt len type )
DHCP_OFFER <> if 2drop false exit then ( pkt len )
2dup CD_SERVER_ID find-dhcp-option if ( pkt len optadr,len )
2drop true ( pkt len true )
." Ignoring OFFER with missing DHCP server identifier" cr
then ( pkt len true | false )
\ Receive an ACK/NAK response from the server.
: receive-dhcp-ack/nak ( -- pkt len true | false )
receive-dhcp-packet 0= if false exit then ( pkt len )
2dup dhcp-packet-type ( pkt len type )
dup DHCP_ACK <> swap DHCP_NAK <> and if ( pkt len )
then ( pkt len true | false )
\ Receive an ACK in response to the INFORM message we sent. Responses
\ from a BOOTP server must be accepted as well.
: receive-dhcpinform-response ( -- pkt len true | false )
receive-dhcp-packet 0= if false exit then ( pkt len )
2dup dhcp-packet-type ( pkt len type )
dup DHCP_ACK <> swap 0<> and if ( pkt len )
then ( pkt len true | false )
\ Stash away a response received from the server.
: store-dhcp-response ( adr len -- )
dup >r chosen-bootreply swap move r> to /chosen-bootreply
\ Wait for the expected response.
: (dhcp-response-wait) ( xt -- pkt len true | false )
dhcp-timer timer-expired? ( xt timed-out? )
dup execute if ( xt pkt len )
rot drop true exit ( pkt len true )
\ Wait for expected response, retransmitting the sent packet if necessary.
: dhcp-response-wait ( xt ntries -- pkt len true | false )
over (dhcp-response-wait) if ( xt ntries pkt len )
2swap 2drop true exit ( pkt len true )
." Timed out waiting for BOOTP/DHCP reply" cr ( xt ntries )
dup 0 u> while ( xt ntries' )
retransmit-dhcp-packet ( xt ntries' )
\ Wait for a minimum of 10 seconds if restarting the configuration
\ process after a failure.
d# 10.000 ms DHCPS_INIT dhcp-state !
\ INIT state processing. Select a random transaction identifier to use
\ in DHCP packets. Move to INFORM state if using an externally configured
\ IP address; else move to SELECTING state.
my-ip-addr inaddr-any? if DHCPS_SELECTING else DHCPS_INFORM then
\ INFORM state processing. Send a DHCPINFORM and wait for a DHCPACK.
\ If a DHCPACK is not received even after 4 retries, enter CONFIGURED
\ state and hope for the best.
DHCP_INFORM init-dhcp-packet send-dhcp-packet ( )
dhcp-timer d# 4000 set-timer ( )
['] receive-dhcpinform-response 4 dhcp-response-wait if ( pkt len )
DHCPS_BOUND dhcp-state ! ( )
DHCPS_CONFIGURED dhcp-state ! ( )
\ Selecting the best DHCPOFFER. We select the best OFFER from the possibly
\ many incoming OFFER messages. OFFERs are evaluated using a points-based
\ system we share with inetboot/wanboot. We prefer DHCP configurations
\ which provide the most configuration information.
: compute-offer-points ( pkt len -- #points )
over >dhcp-cookie ntohl@ BOOTMAGIC <> if
CD_DHCP_TYPE 2over rot dhcp-option-found? if d# 30 + then
CD_VENDOR_SPEC 2over rot dhcp-option-found? if d# 80 + then
CD_SUBNETMASK 2over rot dhcp-option-found? if 1+ then
CD_ROUTER 2over rot dhcp-option-found? if 1+ then
CD_HOSTNAME 2over rot dhcp-option-found? if d# 5 + then
CD_OPTION_OVERLOAD 2over rot dhcp-option-found? 0= if
2 pick >dhcp-sname c@ 0<> if d# 10 + then
2 pick >dhcp-file c@ 0<> if d# 5 + then
2 pick >dhcp-siaddr inaddr-any? 0= if d# 10 + then
\ Process incoming offer and keep track of the best offer received.
: process-offer ( pkt len -- )
2dup compute-offer-points dup best-offer-points <= if ( pkt len pts )
to best-offer-points ( pkt len )
\ Record information from the OFFER we selected.
: process-best-offer ( -- )
chosen-bootreply /chosen-bootreply ( pkt len )
2dup dhcp-packet-type 0= to bootp-config? ( pkt len )
over >dhcp-yiaddr dhcp-offered-ip copy-ip-addr ( pkt len )
CD_SERVER_ID find-dhcp-option if ( opt-adr,len )
drop dhcp-server-id copy-ip-addr ( )
\ SELECTING state processing. Broadcast a DISCOVER and sift through
\ the OFFERs to select the best one. We "collect" OFFERs for a period
\ of 4 seconds after the first OFFER is received. If the best offer
\ is a BOOTP configuration, move to the BOUND state, else move to the
DHCP_DISCOVER init-dhcp-packet send-dhcp-packet ( )
dhcp-timer d# 8000 set-timer ( )
['] receive-dhcp-offer dhcp-max-retries ( xt ntries )
dhcp-response-wait 0= if ( )
." No DHCP response after" dhcp-max-retries .d ." tries" cr
dhcp-timer d# 4000 set-timer ( )
['] receive-dhcp-offer (dhcp-response-wait)
bootp-config? if DHCPS_BOUND else DHCPS_REQUESTING then dhcp-state !
\ REQUESTING state processing. Broadcast a DHCPREQUEST requesting offered
\ parameters from one server (and implicitly declining OFFERS from other
\ servers) and wait for a DHCPACK. On arrival of a DHCPACK, move to the
\ VERIFYING state to perform a check on the offered IP address.
\ If a DHCPNAK is received, or there is no response to the DHCPREQUEST
\ even after 4 retries, restart the initialization process.
: dhcps-requesting ( -- )
DHCP_REQUEST init-dhcp-packet send-dhcp-packet ( )
dhcp-timer d# 4000 set-timer ( )
['] receive-dhcp-ack/nak 4 dhcp-response-wait if ( pkt len )
2dup dhcp-packet-type DHCP_ACK = if ( pkt len )
DHCPS_VERIFYING dhcp-state ! ( )
\ VERIFYING state processing. Issue an ARP request for the offered
\ IP address. If the IP address appears to be in use, send a DHCPDECLINE
\ message to the server and restart the initialization process; else,
\ move to the BOUND state.
dhcp-offered-ip 1 arp-check if
." IP Address " dhcp-offered-ip .ipaddr ." already in use" cr
DHCP_DECLINE init-dhcp-packet send-dhcp-packet
dhcp-offered-ip my-ip-addr copy-ip-addr
\ BOUND state processing. Extract n/w and boot configuration information
\ we care about from the DHCP/BOOTP response. We dont deal with IP
\ address lease times, pushing that responsibility to DHCP modules
: dhcp-set-bootsrv,file ( pkt len -- )
\ Check if boot server and filename are known.
bootfile count is-uri? if 2drop exit then ( pkt len )
bootfile count nip if ( pkt len )
tftp-server-ip inaddr-any? 0= if 2drop exit then
\ If the package arguments did not specify use of TFTP, and
\ the DHCP response provides a (TFTP or HTTP) URI, set the
\ If the package arguments specifies use of TFTP, and the
\ DHCP response provides a TFTP URI, then either the TFTP
\ server or the filename is being overridden. Decode the
\ URI and set those fields appropriately.
\ Else, if TFTP must be used, but a HTTP URL was provided
\ in the DHCP response, ignore the URL specification.
2dup VS_BOOT_URI find-vendor-option if ( pkt len $ )
2dup check-uri$-form ( pkt len $ )
tftp-server-ip inaddr-any? bootfile count nip 0= and if ( pkt len $ )
bootfile pack drop 2drop exit ( )
2dup is-tftp-uri? if ( pkt len $ )
tftp-server-ip inaddr-any? if ( pkt len $ )
2dup tftpuri>srv tftp-server-ip inet-aton drop ( pkt len $ )
bootfile count nip 0= if ( pkt len $ )
2dup tftpuri>file bootfile pack drop ( pkt len $ )
\ Extract TFTP boot information from the standard bootfile
\ and TFTP server fields.
bootfile count nip 0= if ( pkt len )
2dup CD_BOOTFILE_NAME find-dhcp-option 0= if ( pkt len )
over >dhcp-file dup cstrlen ( pkt len $ )
then bootfile pack drop ( pkt len )
tftp-server-ip inaddr-any? if ( pkt len )
over >dhcp-siaddr tftp-server-ip copy-ip-addr ( pkt len )
chosen-bootreply /chosen-bootreply ( pkt,len )
my-netmask inaddr-any? if ( pkt,len )
2dup CD_SUBNETMASK find-dhcp-option if ( pkt,len adr,len )
drop my-netmask copy-ip-addr ( pkt,len )
router-ip inaddr-any? if ( pkt,len )
2dup CD_ROUTER find-dhcp-option if ( pkt,len adr,len )
drop router-ip copy-ip-addr ( pkt,len )
2dup dhcp-set-bootsrv,file ( pkt,len )
http-proxy count nip 0= if ( pkt,len )
2dup VS_HTTP_PROXY find-vendor-option if ( pkt,len proxy$ )
2dup check-htproxy$-form http-proxy pack drop ( pkt,len )
DHCPS_CONFIGURED dhcp-state ! ( )
: "bootp-response" ( -- $ ) " bootp-response" ; \ Space savings
\ CONFIGURED state processing. Publish contents of DHCPACK, if one was
\ received, in /chosen:bootp-response.
: dhcps-configured ( -- )
chosen-bootreply /chosen-bootreply dup if
encode-bytes "bootp-response" set-chosen-property
DHCPS_INIT of dhcps-init endof
DHCPS_INFORM of dhcps-inform endof
DHCPS_SELECTING of dhcps-selecting endof
DHCPS_REQUESTING of dhcps-requesting endof
DHCPS_VERIFYING of dhcps-verifying endof
DHCPS_BOUND of dhcps-bound endof
DHCPS_CONFIGURED of dhcps-configured exit endof
['] (do-dhcp) catch ( throw? )
projects / OpenSPARC-T2-SAM / blob