openbios/openboot/obp/pkg/netinet/dhcp.fth

Branch - branch -master

• Show log

  Commit

• Hash : 1a08f436
  Author :
  Date : 2010-08-25T09:23:17
  

  change to well-formed svn directory structure. git-svn-id: svn://coreboot.org/openboot/trunk@2 4486e004-3823-0410-90c7-fb508cc143bb

Download

• obp/pkg/netinet/dhcp.fth

• \ ========== 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 
  \    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: @(#)dhcp.fth 1.1 04/09/07
  purpose: DHCP support
  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
  
  headerless
  
  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# )
     begin  2dup >  while
        c@++  case
           CD_PAD of                              endof
           CD_END of  r> 3drop false exit         endof
           r@     of  r> drop nip c@++ true exit  endof
           ( default )
           drop c@++ ca+ 0
        endcase
     repeat
     r> 3drop false
  ;
  
  \ 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
        3drop false exit
     then
     >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 )
              case
                 1  of  >dhcp-file  d# 128  endof
                 2  of  >dhcp-sname d# 64   endof
                 3  of  >dhcp-sname d# 192  endof
              endcase				( adr,len )
              r@ (find-dhcp-option)		( optadr,len true | false )
           else					( pkt n )
              2drop false				( false )
           then					( optadr,len true | false )
        else					( pkt,len )
           2drop false				( 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 ) 
     else						( )
        false					( 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 )
           r@ >dhcpopt-data  c!			( ) 
     r>  3 ca+					( adr' ) ( r: )
  ;
  
  \ 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!			( )
     r>  4 ca+					( adr' ) ( r: )
  ;
  
  \ 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: )
     else						( adr code data )
        2drop					( adr' )
     then						( adr' )
  ;
  
  \ 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			( )
     loop								( )
  ;
  
  \ 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. 
  
  : dhcp-init ( -- )
     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 
  \ connection. 
  
  : dhcp-close ( -- )
     dhcp-sndbuf /dhcp-maxmsg  tuck  free-mem		( n )
     dhcp-rcvbuf               over  free-mem		( n )
     chosen-bootreply          swap  free-mem		( )
     dhcp-sockid soclose					( )
  ;
  
  \ 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
  
     r@ DHCP_DECLINE <>  if
        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
     then
  
     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
     then
  
     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-backoff ( -- )
     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 )
     else								( pkt,len )
        2drop 0							( 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
     true
  ;
  
  \ Receive OFFER messages from the server. BOOTP responses must be
  \ accepted as well.
  : 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 )
     else							( pkt len )
        ." Ignoring OFFER with missing DHCP server identifier" cr
        2drop false					( false )
     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 )
        2drop false					( false )
     else							( pkt len )
        true						( pkt len true )
     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 )
        2drop false					( false )
     else							( pkt len )
        true						( pkt len true )
     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 )
     begin                                                ( xt )
        dhcp-timer timer-expired?                         ( xt timed-out? )
     0= while                                             ( xt )
        dup execute  if                                   ( xt pkt len )
           rot drop true exit                             ( pkt len true )
        then                                              ( xt )
     repeat                                               ( xt )
     drop false                                           ( false )
  ;
  
  \ Wait for expected response, retransmitting the sent packet if necessary.
  : dhcp-response-wait ( xt ntries -- pkt len true | false )
     begin                                          	( xt ntries )
        over (dhcp-response-wait)  if                     ( xt ntries pkt len )
           2swap 2drop true exit                          ( pkt len true )
        then                                              ( xt ntries )
        ." Timed out waiting for BOOTP/DHCP reply" cr	( xt ntries )
        1-                                                ( xt ntries' )
     dup 0 u>  while                                      ( xt ntries' )
        retransmit-dhcp-packet  				( xt ntries' )
     repeat                                               ( xt ntries' )
     2drop false                                          ( false )
  ;
  
  \ Wait for a minimum of 10 seconds if restarting the configuration
  \ process after a failure.
  : dhcp-restart ( -- )
     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.
  
  : dhcps-init ( -- )
     random dhcp-xid l!
     my-ip-addr inaddr-any?  if  DHCPS_SELECTING  else  DHCPS_INFORM  then
     dhcp-state !
  ;
  
  \ 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. 
  
  : dhcps-inform ( -- )
     DHCP_INFORM init-dhcp-packet  send-dhcp-packet		( )
     dhcp-timer d# 4000 set-timer					( )
     ['] receive-dhcpinform-response 4  dhcp-response-wait  if	( pkt len )
        store-dhcp-response					( )
        DHCPS_BOUND dhcp-state !					( )
     else
        DHCPS_CONFIGURED dhcp-state !				( )
     then								( )
  ;
  
  \ 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
        2drop 0 exit
     then
  
     d# 5
     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
     then
  
     2 pick  >dhcp-siaddr inaddr-any? 0=  if  d# 10 +  then
     nip nip
  ;
  
  \ 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 )
        3drop exit						( )
     then								( pkt len pts )
     to best-offer-points						( pkt len )
     store-dhcp-response						( )
  ;
  
  \ 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				( )
     then								( )
  ;
  
  \ 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 
  \ REQUESTING state. 
  
  : dhcps-selecting ( -- )
     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
        -1 throw
     then                                                 	( pkt len )
     process-offer                                        	( )
     dhcp-timer d# 4000 set-timer					( )
     begin							( )
        ['] receive-dhcp-offer (dhcp-response-wait)
     while							( pkt len )
        process-offer						( )
     repeat							( )
     process-best-offer						( )
     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 )
           store-dhcp-response					( )
           DHCPS_VERIFYING dhcp-state !				( )
        else							( pkt len )
           2drop  dhcp-restart					( )
        then							( )
     else								( )
        dhcp-restart						( )
     then								( )
  ;
  
  \ 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.
  
  : dhcps-verifying ( -- )
     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-restart
     else
        dhcp-offered-ip my-ip-addr copy-ip-addr
        DHCPS_BOUND dhcp-state !
     then
  ;
  
  \ 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
  \ in the OS. 
  
  : 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
     then								( pkt len )
  
     \ If the package arguments did not specify use of TFTP, and
     \ the DHCP response provides a (TFTP or HTTP) URI, set the
     \ bootfile and exit.
     \
     \ 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				( )
        then							( pkt len $ )
        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 $ )
           then							( pkt len $ )
           bootfile count nip 0=  if				( pkt len $ )
              2dup tftpuri>file bootfile pack drop		( pkt len $ )
           then							( pkt len $ )
           2drop 2drop exit					( )
        then  2drop						( pkt len )
     then								( 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 )
     then								( pkt len )
     tftp-server-ip inaddr-any?  if				( pkt len )
        over >dhcp-siaddr tftp-server-ip copy-ip-addr		( pkt len )
     then								( pkt len )
     2drop							( )
  ;
  
  : dhcps-bound ( -- )
     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 )
        then						( pkt,len )
     then							( 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 )
        then						( pkt,len )
     then							( 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 )
        then						( pkt,len )
     then							( pkt,len )
     2drop						( )
     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
     else
        2drop
     then
  ;
  
  : (do-dhcp) ( -- )
     DHCPS_INIT dhcp-state !
     begin
        dhcp-state @  case
           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
        endcase
     again
  ;
  
  : do-dhcp ( -- )
     dhcp-init					( )
     ['] (do-dhcp) catch				( throw? )
     dhcp-close					( throw? )
     throw					( )
  ;
  
  headers
  

Download