[OpenBIOS] r518 - dev/usb2/device/wlan ofw ofw/inetv6
svn at openbios.org
svn at openbios.org
Thu Aug 2 23:37:59 CEST 2007
Author: lwalter
Date: 2007-08-02 23:37:59 +0200 (Thu, 02 Aug 2007)
New Revision: 518
Added:
ofw/inetv6/
ofw/inetv6/adaptime.fth
ofw/inetv6/arp.fth
ofw/inetv6/attr-ip.fth
ofw/inetv6/attr-ipv6.fth
ofw/inetv6/bootp.fth
ofw/inetv6/config.fth
ofw/inetv6/dhcp.fth
ofw/inetv6/dns.fth
ofw/inetv6/dnsv6.fth
ofw/inetv6/encdec.fth
ofw/inetv6/ethernet.fth
ofw/inetv6/finger.fth
ofw/inetv6/http.fth
ofw/inetv6/httpd.fth
ofw/inetv6/httpdpkg.fth
ofw/inetv6/icmpecho.fth
ofw/inetv6/icmperr.fth
ofw/inetv6/icmpinfo.fth
ofw/inetv6/icmpv6.fth
ofw/inetv6/ip.fth
ofw/inetv6/ipfr.fth
ofw/inetv6/ipfrv6.fth
ofw/inetv6/ippkg.fth
ofw/inetv6/ipv6.fth
ofw/inetv6/loadmail.fth
ofw/inetv6/loadpkg.fth
ofw/inetv6/loadtcp.fth
ofw/inetv6/loadtftp.fth
ofw/inetv6/macaddr.fth
ofw/inetv6/mailbuff.fth
ofw/inetv6/neighdis.fth
ofw/inetv6/netload.fth
ofw/inetv6/netloadv6.fth
ofw/inetv6/occhksum.fth
ofw/inetv6/ping.fth
ofw/inetv6/pingv6.fth
ofw/inetv6/pop3.fth
ofw/inetv6/random.fth
ofw/inetv6/smtp.fth
ofw/inetv6/support.fth
ofw/inetv6/supportv6.fth
ofw/inetv6/tcp.fth
ofw/inetv6/tcpapp.fth
ofw/inetv6/tcpv6.fth
ofw/inetv6/telnet.fth
ofw/inetv6/telnetd.fth
ofw/inetv6/tftp.fth
ofw/inetv6/udp.fth
ofw/inetv6/udpv6.fth
ofw/inetv6/watchnet.fth
Modified:
dev/usb2/device/wlan/usb8388.fth
Log:
Initial checkin of IPv6 networking stack. Local link scope only.
Modified: dev/usb2/device/wlan/usb8388.fth
===================================================================
--- dev/usb2/device/wlan/usb8388.fth 2007-08-02 10:32:34 UTC (rev 517)
+++ dev/usb2/device/wlan/usb8388.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -76,6 +76,11 @@
/mac-adr buffer: target-mac
: target-mac$ ( -- $ ) target-mac /mac-adr ;
+0 value #mc-adr \ Actual number of set multicast addresses
+d# 32 dup constant #max-mc-adr \ Maximum number of multicast addresses
+/mac-adr * dup constant /mc-adrs
+ buffer: mc-adrs \ Buffer of multicast addresses
+
d# 256 buffer: ssid
0 value /ssid
: ssid$ ( -- $ ) ssid /ssid ;
@@ -533,6 +538,26 @@
wait-cmd-resp if exit then
;
+: marvel-get-mc-address ( -- )
+ 4 /mc-adrs + h# 10 ( CMD_MAC_MULTICAST_ADR ) prepare-cmd
+ ACTION_GET +xw
+ 4 /mc-adrs + outbuf-bulk-out if exit then
+ wait-cmd-resp if exit then
+ respbuf >fw-data 2 + le-w@ to #mc-adr
+ respbuf >fw-data 4 + mc-adrs #mc-adr /mac-adr * move
+;
+
+: marvel-set-mc-address ( adr len -- )
+ 4 /mc-adrs + h# 10 ( CMD_MAC_MULTICAST_ADR ) prepare-cmd
+ ACTION_SET +xw
+ dup /mac-adr / dup +xw \ Number of multicast addresses
+ to #mc-adr
+ ( adr len ) 2dup +x$ \ Multicast addresses
+ mc-adrs swap move
+ 4 /mc-adrs + outbuf-bulk-out if exit then
+ wait-cmd-resp if exit then
+;
+
\ =========================================================================
\ Register access
\ =========================================================================
@@ -635,6 +660,16 @@
set-domain-info
enable-11d
;
+
+: enable-multicast ( -- )
+ mac-ctrl h# 20 or to mac-ctrl
+ set-mac-control
+;
+: disable-multicast ( -- )
+ mac-ctrl h# 20 invert and to mac-ctrl
+ set-mac-control
+;
+: set-multicast ( adr len -- ) marvel-set-mc-address enable-multicast ;
headers
\ =========================================================================
Added: ofw/inetv6/adaptime.fth
===================================================================
--- ofw/inetv6/adaptime.fth (rev 0)
+++ ofw/inetv6/adaptime.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,59 @@
+\ See license at end of file
+purpose: Adaptive retry timeouts
+
+d# 200 constant min-timeout
+d# 5000 constant max-timeout
+0 instance value srtt
+0 instance value time0
+d# 4000 instance value next-timeout \ First timeout is 4 seconds
+
+\ Smoothed round-trip-time (srtt) = (ALPHA * old SRTT) + ((1-ALPHA) * RTT)
+\ where alpha in this case is 4/5
+: compute-srtt ( -- )
+ srtt 4 * get-msecs time0 - + 5 / to srtt
+ bootnet-debug 0= if
+ \ If netword debugging is on, don't shorten the timeout, because
+ \ the time to display the debugging messages can exceed the round-trip
+ \ time, thus causing false timeouts.
+ srtt 3 * 2/ min-timeout max max-timeout min to next-timeout
+ then
+;
+
+\ Randomize the timeout by a uniformly-distributed random number in
+\ the range +-63 msecs.
+: randomize ( msecs -- msecs' )
+ random dup h# 3f and swap h# 40 and if negate then +
+;
+
+\ Timeout starts at a value that depends on the smoothed round-trip time,
+\ and doubles on each consecutive missed packet. Successful reception
+\ of a tftp data packet resets it to the (newly-recomputed) starting value.
+
+: update-timeout ( -- )
+ get-msecs to time0
+ next-timeout randomize set-timeout
+ next-timeout 2* max-timeout min to next-timeout
+;
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Added: ofw/inetv6/arp.fth
===================================================================
--- ofw/inetv6/arp.fth (rev 0)
+++ ofw/inetv6/arp.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,302 @@
+\ See license at end of file
+purpose: Address Resolution Protocol (ARP) and Reverse ARP (RARP)
+
+\ Address Resolution Protocol (ARP)
+\ Given the local Ethernet address, finds a server's Ethernet address
+\
+\ Reverse Address Resolution Protocol (RARP)
+\ Given the local Ethernet address, finds corresponding Internet address
+\
+\ These protocols are specific to both Ethernet and Internet, since
+\ their purpose is to relate corresponding addresses from the two
+\ families.
+\
+\ do-arp ( -- )
+\ If his-en-addr contains the broadcast Ethernet address,
+\ performs the ARP protocol and sets his-en-addr to the
+\ responding server's Ethernet address
+\
+\ do-rarp ( -- )
+\ If my-ip-addr contains a broadcast IP address (the first byte is ff),
+\ performs the RARP protocol and sets my-ip-addr to my Internet address,
+\ and his-en-addr and his-ip-addr to the responding server's Ethernet
+\ address and Internet address.
+\
+\ clear-net-addresses ( -- )
+\ Sets his-en-addr and my-ip-addr to the broadcast values so that
+\ ARP and RARP will have to re-acquire them.
+
+decimal
+
+headerless
+h# 806 constant ARP_TYPE
+h# 8035 constant RARP_TYPE
+
+: arp-address-type ( -- type )
+ " arp-address-type" ['] $call-parent catch if ( x x )
+ 2drop 1 ( ARPHRD_ETHER )
+ then ( type )
+;
+
+\ Request structure shared between ARP and RARP
+
+struct ( arp-packet)
+ 2 sfield arp-hw \ set to 1 for ethernet
+ 2 sfield arp-protocol \ set to IP_TYPE
+ 1 sfield arp-hwlen \ set to 6 for ethernet
+ 1 sfield arp-protolen \ set to 4 for IP
+ 2 sfield arp-opcode \ 1 arp req., 2 arp reply, 3 rarp req., 4 rarp reply
+ /e sfield arp-sha \ sender hardware address
+ /i sfield arp-spa \ sender protocol address
+ /e sfield arp-tha \ target hardware address
+ /i sfield arp-tpa \ target protocol address
+constant /arp-packet
+
+/ether-header /arp-packet + constant /ether+arp
+
+0 value arp-packet
+\ Common ARP/RARP request packet constructor
+: send-arp/rarp-packet ( his-ip his-en my-ip my-en req-type en-type -- )
+ >r ( his-ip his-en my-ip my-en req-type r: en-type )
+ /arp-packet allocate-ethernet to arp-packet
+ arp-packet set-struct
+ arp-address-type arp-hw xw!
+ IP_TYPE arp-protocol xw!
+ /e arp-hwlen xc!
+ /i arp-protolen xc!
+ ( ... req-type ) arp-opcode xw!
+ ( ... my-en-addr ) arp-sha copy-en-addr
+ ( ... my-ip-addr ) arp-spa copy-ip-addr
+ ( ... his-en-addr ) arp-tha copy-en-addr
+ ( his-ip-addr ) arp-tpa copy-ip-addr
+
+ the-struct /arp-packet r> broadcast-en-addr send-ethernet-packet
+ arp-packet /arp-packet free-ethernet
+;
+\ The backoff goes as follows (in seconds): 0 1 2 4 8 16 32 1 2 4 8 16 32 ...
+instance variable arp-delay
+
+: arp-backoff ( -- )
+ arp-delay @ ms
+ arp-delay @ d# 1000 max 2*
+ dup d# 32000 > if drop d# 1000 then arp-delay !
+;
+
+: .arp/rarp-timeout ( -- )
+ " Timeout waiting for ARP/RARP packet" diag-type diag-cr
+;
+
+: arpcom ( his-ip his-en my-ip my-en req-type en-type -- ok? )
+ arp-backoff
+ send-arp/rarp-packet
+ timeout-msecs @ set-timeout
+;
+
+: decode-arp-packet ( -- )
+ arp-sha his-en-addr copy-en-addr \ grab his Ethernet address
+;
+
+: use-fixed ( -- addr )
+ use-router? if router-ip-addr else his-ip-addr then
+;
+: sought-ip-addr ( -- ip )
+ \ If we don't know who we are, we don't know our network number, so
+ \ we have to guess.
+ my-ip-addr unknown-ip-addr? if use-fixed exit then
+
+ \ If we are on the same network as the destination host, we send
+ \ directly to him.
+ my-ip-addr his-ip-addr ip-prefix=? if his-ip-addr exit then
+
+ \ Otherwise, we are not on the same net, so we want to send to the
+ \ router, but if we don't have the address of a router, we will
+ \ try to send directly just in case it might work anyway.
+ use-fixed
+;
+
+\ we use router-ip-addr in case of gateway booting.
+\ In fact, the response ethernet address (router's) will be
+\ moved in "his-en-addr". This is correct behavior since the package
+\ uses his-en-addr as destination ethernet address.
+: try-arp ( -- )
+ sought-ip-addr his-en-addr my-ip-addr my-en-addr 1 ARP_TYPE ( params )
+ arpcom
+
+ begin ARP_TYPE receive-ethernet-packet 0= while ( arp-adr,len )
+ drop set-struct ( )
+ arp-tpa my-ip-addr ip= if \ Addressed to me
+ arp-opcode xw@ 2 = if decode-arp-packet exit then \ ARP reply
+ then ( )
+ repeat
+ .arp/rarp-timeout
+;
+
+headers
+
+: do-arp ( -- )
+ sought-ip-addr broadcast-ip-addr? if
+ broadcast-en-addr his-en-addr copy-en-addr exit
+ then
+ bootnet-debug if
+ ." ARP protocol: Getting MAC address for IP address: "
+ his-ip-addr .ipaddr cr
+ then
+ 0 arp-delay !
+
+ \ Loop until we find the destination Ethernet address
+ current-timeout >r
+ begin his-en-addr xw@ h# ffff = while try-arp repeat
+ r> restore-timeout
+
+ bootnet-debug if indent ." Got MAC address: " his-en-addr .enaddr cr then
+;
+
+: (resolve-en-addr) ( 'dest-adr type -- 'en-adr type )
+ dup IP_TYPE = if ( 'ip-adr ip-type )
+ swap dup broadcast-ip-addr? if ( ip-type 'ip-adr )
+ drop ( ip-type )
+ broadcast-en-addr his-en-addr copy-en-addr ( ip-type )
+ else ( ip-type 'ip-adr )
+ his-ip-addr copy-ip-addr ( ip-type )
+ his-en-addr broadcast-en-addr en= if do-arp then ( ip-type )
+ then
+ his-en-addr swap exit
+ then ( 'dest-adr type )
+ nip his-en-addr swap
+;
+\ ' (resolve-en-addr) to resolve-en-addr
+
+headerless
+
+\ Handle incoming arp packets if we know our address
+: arp-response ( adr len type -- )
+ ARP_TYPE <> if 2drop exit then \ Packet type filter
+ /arp-packet < if drop exit then \ Packet length filter
+ set-struct
+ arp-protocol xw@ IP_TYPE <> if exit then \ Type filter
+ arp-opcode xw@ 1 <> if exit then \ Type filter
+ arp-tpa my-ip-addr ip= 0= if exit then \ For somebody else?
+
+ \ All the checks have succeeded, so we can send the reply
+ 2 arp-opcode xw!
+ arp-sha arp-tha copy-en-addr
+ my-en-addr arp-sha copy-en-addr
+ arp-spa arp-tpa copy-ip-addr
+ my-ip-addr arp-spa copy-ip-addr
+
+ the-struct /arp-packet ARP_TYPE arp-tha send-ethernet-packet
+;
+' arp-response is handle-ethernet
+
+\ Reverse Address Resolution Protocol - finds my Internet address
+\ given my Ethernet address.
+
+: decode-rarp-packet ( -- )
+ arp-opcode xw@ 4 <> if exit then
+ arp-sha his-en-addr copy-en-addr \ grab his Ethernet address
+ arp-spa his-ip-addr copy-ip-addr \ grab his IP address
+ arp-tpa my-ip-addr copy-ip-addr \ grab my IP address
+;
+
+: try-rarp ( -- )
+ broadcast-ip-addr my-en-addr broadcast-ip-addr my-en-addr 3 RARP_TYPE
+ arpcom
+
+ begin RARP_TYPE receive-ethernet-packet 0= while ( arp-adr,len )
+ drop set-struct ( )
+ arp-tha my-en-addr en= if \ Addressed to me
+ arp-opcode xw@ 4 = if \ RARP reply
+ decode-rarp-packet exit
+ then
+ then ( )
+ repeat
+ .arp/rarp-timeout
+;
+
+headers
+
+: do-rarp ( -- )
+ 0 arp-delay !
+ bootnet-debug if
+ ." RARP protocol: Getting IP address for MAC address: "
+ my-en-addr .enaddr cr
+ then
+
+ current-timeout >r
+ begin my-ip-addr unknown-ip-addr? while try-rarp repeat
+ r> restore-timeout
+
+ bootnet-debug if indent ." Got IP address: " my-ip-addr .ipaddr cr then
+;
+
+: clear-his-address ( -- )
+ use-router? use-server? or if exit then
+
+ broadcast-ip-addr set-dest-ip
+;
+: clear-my-address ( -- )
+ unknown-ip-addr my-ip-addr copy-ip-addr
+;
+: clear-net-addresses ( -- )
+ clear-his-address
+ clear-my-address
+ unknown-ip-addr name-server-ip copy-ip-addr
+ unknown-ip-addr subnetmask copy-ip-addr
+;
+
+false instance value pp?
+\ Support for point-to-point links
+warning @ warning off
+: open-link ( -- )
+ open-link
+
+ ['] (resolve-en-addr) to resolve-en-addr
+
+ " point-to-point?" ['] $call-parent catch if 2drop exit then
+ ( false | 'his-ip 'my-ip true ) if ( 'his-ip 'my-ip )
+ my-ip-addr copy-ip-addr his-ip-addr copy-ip-addr ( )
+ ['] noop to resolve-en-addr
+ true to pp?
+ then
+
+ " dns-servers" ['] $call-parent catch if ( x x )
+ 2drop ( )
+ else ( false | 'ip1 'ip0 true )
+ if ( 'ip1 'ip0 )
+ dup known? if nip else drop then ( 'ip )
+ name-server-ip copy-ip-addr ( )
+ then
+ then
+
+ " domain-name" ['] $call-parent catch if ( x x )
+ 2drop ( )
+ else ( name$ )
+ 'domain-name place-cstr drop
+ then
+;
+
+: close-link ( -- ) close-link pp? if clear-my-address then ;
+warning !
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Added: ofw/inetv6/attr-ip.fth
===================================================================
--- ofw/inetv6/attr-ip.fth (rev 0)
+++ ofw/inetv6/attr-ip.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,79 @@
+\ See license at end of file
+purpose: Add properties describing the network to /chosen
+
+headerless
+: set-chosen-property ( adr,len prop,len -- )
+ 2dup " /chosen" find-package drop ( ip-adr$ prop$ prop$ phandle )
+ dup >r get-package-property if ( ip-adr$ prop$ )
+ \ Create new property
+ r> 0 package( push-package ( ip-adr$ prop$ )
+ 2>r encode-bytes 2r> property ( )
+ pop-package )package
+ else ( ip-adr$ prop$ xdr,len )
+ \ Replace existing property
+ 2swap 2drop rot drop move ( )
+ r> drop
+ then
+;
+[ifdef] notdef
+: ?set-chosen-string ( value$ name$ -- )
+ 2swap dup if ( name$ value$ )
+ $cstr 1+ 2swap set-chosen-property ( )
+ else ( name$ value$ )
+ 2drop 2drop ( )
+ then
+;
+[then]
+
+: (setup-ip-attr) ( -- ) \ set tftp ip addresses
+ my-ip-addr /i " client-ip" set-chosen-property
+ his-ip-addr /i " server-ip" set-chosen-property
+ router-ip-addr /i " gateway-ip" set-chosen-property
+ netmask /i " netmask-ip" set-chosen-property
+ broadcast-ip-addr /i " broadcast-ip" set-chosen-property
+
+[ifdef] notdef
+ tftp-name " tftp-file" ?set-chosen-string
+ domain-name " domain-name" ?set-chosen-string
+ vendor-options " vendor-options" ?set-chosen-string
+ client-name " client-name" ?set-chosen-string
+[then]
+
+ report-buffer if
+ report-buffer bootp-len encode-bytes " bootp-response"
+ set-chosen-property
+
+ report-buffer /bootp-packet free-mem
+ 0 to report-buffer
+
+ \ h# f0 is offset of the options field with the bootp packet
+ bootp-packet next-option h# f0 + encode-bytes
+ " bootp-request" set-chosen-property
+ then
+;
+
+['] (setup-ip-attr) is setup-ip-attr
+headers
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Added: ofw/inetv6/attr-ipv6.fth
===================================================================
--- ofw/inetv6/attr-ipv6.fth (rev 0)
+++ ofw/inetv6/attr-ipv6.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,57 @@
+\ See license at end of file
+purpose: Add properties describing the IPv6 network to /chosen
+
+headerless
+[ifndef] include-ipv4
+: (setup-ip-attr) ( -- ) ;
+
+: set-chosen-property ( adr,len prop,len -- )
+ 2dup " /chosen" find-package drop ( ip-adr$ prop$ prop$ phandle )
+ dup >r get-package-property if ( ip-adr$ prop$ )
+ \ Create new property
+ r> 0 package( push-package ( ip-adr$ prop$ )
+ 2>r encode-bytes 2r> property ( )
+ pop-package )package
+ else ( ip-adr$ prop$ xdr,len )
+ \ Replace existing property
+ 2swap 2drop rot drop move ( )
+ r> drop
+ then
+;
+[then]
+
+: (setup-ipv6-attr) ( -- ) \ set tftp ip addresses
+ (setup-ip-attr)
+
+ my-ipv6-addr /ipv6 " client-ipv6" set-chosen-property
+ his-ipv6-addr /ipv6 " server-ipv6" set-chosen-property
+ router-ipv6-addr /ipv6 " gateway-ipv6" set-chosen-property
+ my-mc-ipv6-addr /ipv6 " multicast-ipv6" set-chosen-property
+;
+
+['] (setup-ipv6-attr) is setup-ip-attr
+
+headers
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Added: ofw/inetv6/bootp.fth
===================================================================
--- ofw/inetv6/bootp.fth (rev 0)
+++ ofw/inetv6/bootp.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,260 @@
+\ See license at end of file
+purpose: Bootstrap Protocol (BOOTP) (RFC 951) + vendor extensions (RFC 1084)
+
+decimal
+headerless
+struct ( bootp packet )
+ 1 sfield bp-op \ 00 packet type: 1 = request, 2 = reply
+ 1 sfield bp-htype \ 01 hardware addr type
+ 1 sfield bp-hlen \ 02 hardware addr length
+ 1 sfield bp-hops \ 03 gateway hops
+ 4 sfield bp-xid \ 04 transaction ID
+ 2 sfield bp-secs \ 08 seconds since boot began
+ 2 sfield bp-unused \ 0a now "flags" field; see RFC 1542
+ /i sfield bp-ciaddr \ 0c client IP address
+ /i sfield bp-yiaddr \ 10 'your' IP address
+ /i sfield bp-siaddr \ 14 server IP address
+ /i sfield bp-giaddr \ 18 gateway (BOOTP relay agent) IP address
+d# 16 sfield bp-chaddr \ 1c client hardware address
+d# 64 sfield bp-sname \ 2c server host name
+
+d# 128 sfield bp-file \ 6c boot file name
+ 4 sfield bp-vend-magic \ ec vendor-specific area
+dup constant /bootp-fixed
+d# 60 sfield bp-options \ f0 vendor-specific area
+constant /bootp
+
+0 value /bootp-packet
+0 instance value bootp-packet
+
+0 value report-buffer \ Can't use buffer: because DHCP changes the packet size
+
+0 instance value bootp-len \ Actual length of received bootp packet
+
+instance variable start-time
+instance variable xid
+
+d# 32 instance buffer: server-name
+partial-headers
+d# 128 buffer: file-name-buf
+headerless
+d# 128 instance buffer: bootp-name-buf
+
+headers
+' file-name-buf " tftp-file" chosen-string
+headerless
+
+d# 255 constant end-option
+
+[ifndef] c at +
+: c at + ( adr -- adr+1 char ) dup ca1+ swap c@ ;
+[then]
+
+: elapsed-secs ( -- #secs ) get-msecs start-time @ - d# 1000 / ;
+
+\ RFC 1533 magic number 99.130.83.99
+h# 63.82.53.63 constant 1533-magic
+
+: not-1533-magic? ( -- adr,len false | true )
+ bp-vend-magic dup xl@ 1533-magic = if
+ la1+ bootp-len /bootp-fixed - false
+ else
+ drop true
+ then
+;
+
+: do-vendor ( -- )
+ not-1533-magic? if exit then ( adr,len )
+ over ca+ >r ( adr ) ( r: end )
+ begin dup r@ <= while ( adr ) ( r: end )
+ c at + case
+
+ end-option of r> 2drop exit endof \ End (255)
+
+ 0 of endof \ Pad
+
+ 1 of \ Netmask
+ c at +
+ over subnetmask copy-ip-addr
+ ca+
+ endof
+
+ 3 of \ Router
+ c at +
+ over router-ip-addr copy-ip-addr
+ ca+
+ endof
+
+ \ default - skip option
+ drop c at + ca+ 0 ( adr' 0 ) ( r: end )
+
+ endcase ( adr' ) ( r: end )
+ repeat ( adr" ) ( r: end )
+ r> 2drop
+;
+
+: set-cookie ( -- ) " "(63 82 53 63)" bp-vend-magic swap move ;
+
+: prepare-bootp-packet ( -- )
+ bootp-packet set-struct
+ bootp-packet /bootp-packet erase
+ 1 bp-op xc! \ BOOTREQUEST
+ arp-address-type bp-htype xc! \ Hardware address type
+ /e bp-hlen xc! \ Hardware address length
+ xid @ bp-xid xl! \ "Random" transaction ID
+ unknown-ip-addr subnetmask copy-ip-addr
+ unknown-ip-addr my-ip-addr copy-ip-addr
+
+ \ bp-ciaddr should be 0.0.0.0 or a valid unicast address per RFC 1542
+ \ This following clause can't execute in light of the preceding line
+ \ that clears my-ip-addr.
+ my-ip-addr broadcast-ip-addr? 0= if
+ my-ip-addr bp-ciaddr copy-ip-addr
+ then
+
+ my-en-addr bp-chaddr copy-en-addr
+ server-name count bp-sname place-cstr drop
+ file-name-buf cscount bp-file place-cstr drop
+
+ set-cookie
+ end-option bp-options c!
+;
+
+: send-bootp-packet ( size secs -- )
+ bp-secs xw! ( size )
+ bootp-packet swap d# 68 d# 67 send-udp-packet ( )
+;
+
+defer handle-bootp ( -- )
+headers
+: (handle-bootp) ( -- )
+ bootnet-debug if
+ ." (Discarding BOOTP packet with unexpected packet type or transaction id)"
+ cr
+ ." Header: "
+ the-struct /bootp-fixed cdump cr
+ then
+;
+' (handle-bootp) is handle-bootp
+headerless
+
+: get-bootp-reply ( -- timeout? )
+ begin d# 68 receive-udp-packet 0= while ( adr,len src-port )
+ drop to bootp-len set-struct ( )
+
+ bp-xid xl@ xid @ = if
+ bp-op c@ 2 = if
+ bp-chaddr my-en-addr en= if false exit then
+ then
+ then
+ handle-bootp
+ repeat ( )
+ true
+;
+: allocate-bootp ( size -- )
+ allocate-udp is bootp-packet
+
+ get-msecs start-time !
+
+ \ Set "random" transaction ID and random number generator seed
+ my-en-addr 2 + xl@ get-msecs xor dup xid ! rn !
+;
+: free-bootp ( size -- ) bootp-packet swap free-udp ;
+
+\ Sets my-ip-addr, his-ip-addr, bootp-name-buf, netmask, router-ip-addr, etc.
+: extract-bootp-info ( -- )
+ bp-yiaddr my-ip-addr copy-ip-addr
+ bp-siaddr server-ip-addr copy-ip-addr
+
+ server-ip-addr set-dest-ip \ Use the indicated server for TFTP later
+
+ \ We do NOT copy (nor to we even pay attention to) the bp-giaddr field.
+ \ RFC1542 specifies that said field is for the use of BOOTP relay agents,
+ \ not clients.
+
+ do-vendor
+
+ \ Copy the filename as modified by the server back into the filename
+ \ buffer, unless it is empty. We have seen cases where a BOOTP or
+ \ DHCP server has nulled out a file name that was supplied to it.
+ bp-file cscount dup if bootp-name-buf place else 2drop then
+
+ report-buffer 0= if /bootp-packet alloc-mem to report-buffer then
+ the-struct report-buffer bootp-len move
+;
+
+-1 instance value bootp-retries
+
+[ifndef] use-dhcp
+
+h# 7ff constant 2seconds \ About 2 seconds of milliseconds
+h# 3fff constant 16seconds \ About 16 seconds of milliseconds
+
+instance variable rn-mask \ Backoff mask
+
+: first-interval ( -- ) 2seconds rn-mask ! ;
+: random-interval ( -- n )
+ random rn-mask @ and 2seconds max ( number )
+ rn-mask @ 16seconds < if rn-mask @ 2* 1 or rn-mask ! then
+;
+
+0 instance value try#
+
+: do-bootp ( -- )
+ /bootp to /bootp-packet
+
+ /bootp-packet allocate-bootp
+
+ first-interval
+ 0 to try#
+
+ prepare-bootp-packet
+
+ \ At this point, server-ip-addr will usually be 0.0.0.0, but it may
+ \ have been overridden from the command line. 1275 committee members
+ \ have reported that it is necessary to unicast BOOTP requests in some
+ \ circumstances. We don't do this for DHCP though, because DHCP asserts
+ \ that the bp-siaddr field denotes the TFTP server, not the BOOTP server.
+ server-ip-addr bp-siaddr copy-ip-addr
+
+ begin
+ /bootp-packet elapsed-secs send-bootp-packet
+ random-interval set-timeout
+ get-bootp-reply
+ while
+ try# if \ We always have to retry the first time!
+ ." Retrying... Check bootp server and network setup." cr
+ then
+ try# 1+ to try#
+ try# bootp-retries u> abort" Too many BOOTP retries"
+ repeat
+
+ extract-bootp-info
+
+ /bootp-packet free-bootp
+;
+[then]
+headerless
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Added: ofw/inetv6/config.fth
===================================================================
--- ofw/inetv6/config.fth (rev 0)
+++ ofw/inetv6/config.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,7 @@
+purpose: Configuration file for the networking stack
+
+\ At least one of the below must be created.
+\ When both are created, we have a dual networking stack.
+create include-ipv4
+create include-ipv6
+
Added: ofw/inetv6/dhcp.fth
===================================================================
--- ofw/inetv6/dhcp.fth (rev 0)
+++ ofw/inetv6/dhcp.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,708 @@
+\ See license at end of file
+purpose: Dynamic Host Configuration Protocol (DHCP) (RFC 1541)
+
+[ifdef] notdef
+dev /obp-tftp
+[then]
+
+partial-headers
+defer .dhcp-msg ( adr len -- )
+
+: (.dhcp-msg) ( adr len -- ) bootnet-debug if indent type cr else 2drop then ;
+' (.dhcp-msg) to .dhcp-msg
+
+headerless
+defer .discover-error
+: (.discover-error) " DHCP discover failed; restarting" .dhcp-msg ;
+' (.discover-error) to .discover-error
+
+defer .request-error
+: (.request-error) " DHCP request failed; retrying" .dhcp-msg ;
+' (.request-error) to .request-error
+
+d# 308 constant /options-field
+
+/bootp d# 60 - /options-field + constant /dhcp
+
+\ Search for the DHCP option whose tag is "code#", returning its value if found
+: find-option ( code# -- false | adr len true )
+ \ XXX handle options overload
+ bp-options begin ( code# adr )
+ dup c@ dup 0<> swap d# 255 <> and ( code# adr )
+ while ( code# adr )
+ 2dup c@ = if nip 1+ count true exit then ( code# adr )
+ 1+ count + ( code# adr' )
+ repeat ( code# adr )
+ 2drop false
+;
+
+\ For NVT-ASCII data, which might or might not have trailing nulls
+: -nulls ( adr len -- adr len' )
+ dup 0 ?do 2dup + 1- c@ 0<> ?leave 1- loop
+;
+
+\ True if the BOOTP vendor extensions area contains DHCP options
+: dhcp-options? ( -- flag ) bp-vend-magic " "(63 82 53 63)" comp 0= ;
+
+/options-field d# 64 + d# 128 + constant /options-max
+/options-max buffer: options
+
+0 value next-option
+
+\ Initialize the temporary options buffer in preparation for adding options
+: start-options ( -- ) options /options-max erase 0 to next-option ;
+
+\ Add a byte to the temporary options buffer
+: option, ( byte -- )
+ next-option options + c! next-option 1+ to next-option
+;
+
+\ Add to the temporary options buffer an option with code# as the tag and
+\ the value from the memory range adr,len
+: +option ( adr len code# -- )
+ \ 3 is 1 for the code#, 1 for the length byte, and 1 for an END option
+ over 3 + next-option + ( adr len code# new#options )
+ /options-max >= abort" DHCP options buffer overflow" ( adr len code# )
+ option, dup option, bounds ?do i c@ option, loop ( )
+;
+
+\ Copy the temporary options buffer to the outgoing packet
+: copy-options ( -- )
+ end-option option,
+ next-option /options-field > abort" DHCP options overload not supported"
+ set-cookie
+ bp-options /options-field erase
+ options bp-options next-option move
+;
+
+\ Return the DHCP message type
+: dhcp-type ( -- true | message-type false )
+ dhcp-options? 0= if true exit then
+ \ Look for a DHCP message type option
+ d# 53 find-option if drop c@ false else true then
+;
+
+\ Add a "request parameters" option
+\ : request-parameters ( adr len -- ) d# 55 +option ;
+
+\ Display the "message" option from a DHCPNAK message
+: .nak-message ( -- ) d# 56 find-option if -nulls type cr then ;
+
+: root-property ( name$ -- true | value false )
+ ['] root-node get-package-property
+;
+
+\ Add a "vendor class" option if there is an "architecture" property
+\ in the root node
+: set-vendor-class ( -- )
+ " architecture" root-property if exit then ( adr len )
+ get-encoded-string d# 60 +option \ Vendor class identifier option
+;
+
+\ Add a "client identifier" option whose value is the MAC address
+\ XXX we should probably use the root-node system-id property instead,
+\ if its value differs from the mac-address value.
+0 value client-id
+: set-client-id ( -- )
+ " system-id" root-property if exit then ( adr len )
+
+ dup 1+ dup >r alloc-mem to client-id ( adr len r: len' )
+ tuck client-id 1+ swap move ( len )
+ 1 client-id c! ( len )
+ client-id swap 1+ d# 61 +option \ Client identifier option
+ client-id r> free-mem
+;
+
+0 value backoff \ First set to d# 4000, then double up to d# 32,000
+
+\ The spec recommends a 4 second initial timeout, but that appears to be
+\ a bit short in some environments, especially considering that
+\ a) The actual delay is randomized by +- 1 second.
+\ b) Some DHCP servers, when dynamically allocating an IP address, first
+\ test that IP address by issuing an ARP request and waiting a timeout
+\ interval, prior to responding to the DHCPDISCOVER.
+: init-backoff ( -- ) ( d# 4000 ) d# 8000 to backoff ;
+: too-many? ( -- flag ) backoff d# 64,000 >= ;
+
+\ The nominal retry delay interval starts at 4 seconds and doubles each
+\ time, giving up after the retry following the 32 second delay. The
+\ actual delay is the nominal delay randomized by a uniformly-distributed
+\ random number in the range +-1.023 seconds.
+: next-backoff ( -- #ms )
+ random dup h# 3ff and swap h# 400 and if negate then
+ backoff + ( #ms )
+ backoff 2* to backoff
+;
+
+: erase-ip-addr ( adr -- ) /i erase ;
+
+\ This is similar to but not exactly the same as my-ip-addr
+\ The differences have to do with DHCP protocol requirements
+\ about when the BOOTP ciaddr field must be 0.
+/i instance buffer: accepted-ip
+/i instance buffer: offered-ip
+
+: start-dhcp-packet ( dhcptype$ -- )
+ prepare-bootp-packet
+ bp-yiaddr erase-ip-addr
+ bp-siaddr erase-ip-addr
+ bp-giaddr erase-ip-addr
+ accepted-ip bp-ciaddr copy-ip-addr
+ start-options
+ ( adr len ) d# 53 +option \ DHCPTYPE
+ set-client-id
+;
+\ Options common to discover, inform, and request messages
+: other-parameters ( -- )
+ set-vendor-class
+ \ Later: Add requested IP address if we know it
+ \ Later: Add requested IP lease time if we have a preference
+ \ Later: Add parameter request list if we care
+ \ Later: Add maximum message size if we should need to
+;
+: use-ip-broadcast ( -- ) broadcast-ip-addr set-dest-ip ;
+
+0 instance value dhcp-secs
+
+: prepare-discover-packet ( -- )
+ \ Note: It is permissible to unicast this packet if a DHCP server's
+ \ IP address is known; see clause 4.4.4
+ use-ip-broadcast
+
+ elapsed-secs to dhcp-secs
+ " "(01)" start-dhcp-packet \ DHCPDISCOVER
+ other-parameters
+ copy-options
+;
+
+\ Common code for SELECTING, INIT-REBOOT, BOUND, RENEWING, and REBINDING
+: start-request-packet ( -- )
+ \ Note: It is permissible to unicast this packet in either INIT or
+ \ REBOOTING state if a DHCP server's IP address is known; see clause 4.4.4
+ use-ip-broadcast
+
+ " "(03)" start-dhcp-packet \ DHCPREQUEST
+ other-parameters
+;
+
+: send-dhcp-packet ( -- )
+ /bootp-packet dhcp-secs send-bootp-packet
+ next-backoff set-timeout
+;
+
+false instance value bootp-only? \ Set to true if a BOOTP server replies
+
+defer handle-dhcp
+headers
+: (handle-dhcp) ( -- )
+ bootnet-debug if
+ ." (Discarding DHCP packet of unexpected type)" cr
+ ." Packet: " the-struct /bootp cdump cr
+ then
+;
+' (handle-dhcp) is handle-dhcp
+headerless
+
+: receive-dhcp-packet ( accept-mask -- true | dhcp-type false )
+ >r
+ begin
+ get-bootp-reply if r> drop true exit then
+
+ dhcp-type if \ Not a DHCP packet
+ true to bootp-only? \ This flag may be useful for a fallback to BOOTP
+ r> drop 0 false exit
+ else ( dhcp-type )
+ 1 over lshift r@ and if \ We got one of the types we want
+ r> drop false exit ( dhcp-type false )
+ then ( dhcp-type )
+ drop ( ) \ Silently discard other types
+ handle-dhcp ( )
+ then ( )
+ again
+;
+
+defer handle-dhcp-nak
+
+d# 256 buffer: 'root-path
+d# 256 buffer: 'client-name
+d# 256 buffer: 'vendor-options
+headers
+' 'client-name " client-name" chosen-string
+' 'vendor-options " vendor-options" chosen-string
+' 'root-path " root-path" chosen-string
+: domain-name ( -- adr len ) 'domain-name cscount ;
+
+/i buffer: dhcp-server-ip
+: (handle-dhcp-nak) ( -- )
+ bootnet-debug if
+ indent ." (Discarding bogus DHCP NAK packet from server: "
+ dhcp-server-ip .ipaddr ." )" cr
+ then
+;
+' (handle-dhcp-nak) is handle-dhcp-nak
+
+: init-dhcp ( -- )
+ 0 'domain-name c!
+ 0 'root-path c!
+ 0 'client-name c!
+ 0 'vendor-options c!
+ 0 file-name-buf c!
+ unknown-ip-addr name-server-ip copy-ip-addr
+ unknown-ip-addr dhcp-server-ip copy-ip-addr
+;
+
+also forth definitions
+stand-init: DHCP init
+ init-dhcp
+;
+previous definitions
+
+: .dhcp-server ( -- )
+ bootp-only? 0= if
+ ." DHCP server: " dhcp-server-ip .ipaddr cr
+ then
+;
+
+headerless
+
+: .offer ( -- )
+ bootnet-debug if
+ indent ." Received offer of IP address " my-ip-addr .ipaddr
+ ." from "
+ bootp-only? if
+ ." BOOTP server " server-ip-addr
+ else
+ ." DHCP server " dhcp-server-ip
+ then
+ .ipaddr cr
+
+ indent indent ." Boot server IP: " server-ip-addr .ipaddr
+ ." Filename: " bootp-name-buf count type cr
+ subnetmask known? if
+ indent indent ." Netmask: " subnetmask .ipaddr cr
+ then
+ use-router? if
+ indent indent ." BOOTP relay agent: " router-ip-addr .ipaddr cr
+ then
+ then
+;
+
+partial-headers
+\ For now we'll take the first offer we get.
+
+\ The default value of wanted? accepts the first DHCPOFFER that is received
+defer wanted? ( -- flag ) ' true to wanted?
+
+\ This filter rejects offers whose siaddr field is empty, (Microsoft's
+\ DHCP server doesn't fill in siaddr), since we are hosed if we don't know
+\ which server to use.
+
+: (wanted?) ( -- flag )
+ \ If we already know the boot server, we needn't insist on one from DHCP
+ use-server? if true exit then
+ bp-siaddr known? dup 0= if
+ " The DHCP 'siaddr' field is empty" .dhcp-msg
+ then
+;
+' true to wanted? \ By default, we accept all DHCP offers
+\ ' (wanted?) to wanted?
+
+\ Another plausible criterion for choosing a particular offer might be:
+\ If a vendor class identifier is supplied, reject offers that do
+\ not return that identifier, instead waiting for an offer from a
+\ server that explicitly recognizes the vendor class.
+
+: choose-response ( -- timeout? )
+ begin
+ \ Accept DHCPOFFER packets (4 = 1 LSHIFT 2; 2 is the DHCPOFFER type code)
+ 4 receive-dhcp-packet if true exit then ( dhcp-type=2 )
+ drop wanted? if false exit then ( )
+ " Discarding unwanted DHCPOFFER" .dhcp-msg
+ again
+;
+: do-discover ( -- error? )
+ accepted-ip erase-ip-addr
+ prepare-discover-packet
+
+ bootnet-debug if
+ indent ." DHCP Discover: requesting an IP address for "
+ my-en-addr .enaddr cr
+ then
+
+ init-backoff
+ begin
+ send-dhcp-packet
+ \ Enter SELECTING state
+ choose-response ( timeout? )
+ while ( )
+ " Timeout" .dhcp-msg
+
+ \ If too many retries, go to INIT state
+ too-many? if true exit then
+ repeat
+
+ extract-bootp-info
+
+ \ A BOOTP reply essentially takes to directly to BOUND-DONE state
+ bootp-only? if .offer false exit then
+
+ d# 54 find-option 0= abort" Server identifier missing" ( adr len )
+ drop dhcp-server-ip copy-ip-addr
+ .offer
+
+ \ get yiaddr from ack packet for use in subsequent request packet
+ bp-yiaddr offered-ip copy-ip-addr
+
+ false
+;
+
+headerless
+create null-ip-addr 0 c, 0 c, 0 c, 0 c,
+
+: ip-in-use? ( -- error? )
+ \ ARP to see if somebody else has the IP address we were assigned.
+ \ use my-en-addr as sender's hardware address, and 0 as sender's IP
+ \ address, per last paragraph of clause 4.4.1
+
+ my-ip-addr broadcast-en-addr null-ip-addr my-en-addr 1 ARP_TYPE ( params )
+ send-arp/rarp-packet
+
+ \ If we get a response within a short time, that indicates a conflict.
+ d# 200 set-timeout
+ begin ARP_TYPE receive-ethernet-packet 0= while ( arp-adr,len )
+ drop set-struct ( )
+ arp-tha my-ip-addr ip= if \ Addressed to me
+ arp-opcode xw@ 2 = if true exit then \ ARP reply
+ then
+ repeat
+ false
+;
+
+\ Broadcast an ARP reply, announcing our new IP address in order to clear
+\ any stale ARP cache entries out there (see 4.4.1 in the DHCP RFC).
+: arp-notify ( -- )
+ broadcast-ip-addr broadcast-en-addr
+ my-ip-addr my-en-addr 2 ARP_TYPE send-arp/rarp-packet
+;
+
+[ifdef] notdef
+Appropriate responses for request failure:
+ my-ip-address-unknown? 0= if
+ (it is permitted to go to BOUND state if the lease is unexpired)
+ then
+ notify-user retry-at-INIT-state
+[then]
+
+: set-server-id ( -- )
+ dhcp-server-ip /i d# 54 +option \ Server identifier option
+;
+\ Common end options for DHCPREQUEST and DHCPDECLINE packets
+: finish-request/decline ( -- )
+ offered-ip /i d# 50 +option \ Requested IP address option
+ copy-options
+;
+
+: send-decline ( -- )
+ accepted-ip erase-ip-addr
+ 0 to dhcp-secs
+ " "(04)" start-dhcp-packet \ DHCPDECLINE
+ " Duplicate IP address" d# 56 +option \ Message option
+ set-server-id
+ finish-request/decline
+;
+
+partial-headers
+defer parse-vendor ( adr len -- adr len ) ' noop is parse-vendor
+
+headerless
+\ true on top of the stack means that a NAK was received from our chosen
+\ server, in which case the caller will abandon this DHCP attempt.
+\ false on top of the stack means either a timeout or an ACK.
+: receive-ack ( -- true | timeout? false ) \ True if our server NAK'ed
+ begin
+ \ Accept DHCPACK and DHCPNAK packets
+ \ 60 masks bits 5 and 6, 5 is DHCPACK and 6 is DHCPNAK
+
+ \ If receive-dhcp-packet returns true, it's a timeout, so we
+ \ retry at that higher level where the DHCPREQUEST will be resent.
+ h# 60 receive-dhcp-packet if true false exit then ( dhcp-type )
+
+ \ If it's an ACK, we return "false false" so the higher level will
+ \ proceed.
+ 5 = if false false exit then ( )
+
+ \ It was a NAK; our response depends on which server issued it.
+
+ \ XXX this code may need modification if we add
+ \ support for the DHCP INIT-REBOOT state.
+
+ d# 54 find-option if ( )
+ \ If the NAK is from the chosen server, we give up.
+ drop dhcp-server-ip ip= if ( )
+ " Received DHCP NAK from the chosen server!" .dhcp-msg
+ \ XXX clear any remembered IP address
+ \ Return "true" so the higher level will give up.
+ true exit
+ then ( )
+ then ( )
+
+ \ The NAK was from a server that we don't care about,
+ \ so we just ignore it and keep looking.
+ handle-dhcp-nak
+ again
+;
+
+\ If we ever implement persistent IP addresses, we will need to add code to
+\ clear the remembered IP address.
+: (requesting) ( -- error? ) \ Packet must be prepared in advance
+ " Confirming IP address with DHCP Request" .dhcp-msg
+
+ init-backoff
+
+ begin
+ send-dhcp-packet
+ \ Entering REQUESTING or REBOOTING state
+ receive-ack if true exit then ( timeout? )
+ while ( )
+ too-many? if true exit then ( )
+ repeat ( )
+
+ \ We got an ACK
+ \ Entering BOUND state
+ extract-bootp-info
+
+ \ If the BOOTP or DHCP server did not return a filename, and
+ \ the user did not supply one in the package arguments, then
+ \ we return the system architecture name in bootp-name-buf.
+ bootp-name-buf count nip 0= if
+ file-name-buf c@ 0= if
+ " architecture" ['] root-node get-package-property 0= if ( prop$ )
+ get-encoded-string ( name$ )
+ bootp-name-buf place ( )
+ then
+ then
+ then
+
+ d# 6 find-option if drop name-server-ip copy-ip-addr then
+ d# 28 find-option if drop broadcast-ip-addr copy-ip-addr then
+ d# 15 find-option if 'domain-name place-cstr drop then
+ d# 12 find-option if 'client-name place-cstr drop then
+ d# 43 find-option if parse-vendor 'vendor-options place-cstr drop then
+ d# 17 find-option if 'root-path place-cstr drop then
+
+ bootnet-debug if
+ indent ." Received DHCP ACK" cr
+ name-server-ip known? if
+ indent indent ." Name server: " name-server-ip .ipaddr cr
+ then
+ broadcast-ip-addr if
+ indent indent ." IP broadcast: " broadcast-ip-addr (.ipaddr) cr
+ then
+ 'domain-name c@ if
+ indent indent ." Domain: " 'domain-name cscount type cr
+ then
+ 'client-name c@ if
+ indent indent ." My hostname: " 'client-name cscount type cr
+ then
+ 'root-path c@ if
+ indent indent ." Root path: " 'root-path cscount type cr
+ then
+ 'vendor-options c@ if
+ indent indent ." Vendor options: " 'vendor-options cscount type cr
+ then
+ then
+
+ " Using ARP to check if the assigned IP address is free." .dhcp-msg
+
+ ip-in-use? if
+ " Oops, it's already in use; sending DHCP Decline" .dhcp-msg
+
+ send-decline
+ ." The IP address assigned to us by the DHCP server is already in use" cr
+ d# 10,000 ms \ Per clause 3.1.5 in dhcp-09
+ \ Go to INIT state
+ true exit
+ else
+ " Broadcasting ARP reply to announce my IP address" .dhcp-msg
+ \ Broadcast ARP reply, announcing the new IP address
+ arp-notify
+ then
+
+ \ Everything is just fine; we are finished with the protocol for now
+ false
+;
+
+\ True when in the INIT/SELECTING branch of the state machine.
+\ False when in the INIT-REBOOT/REBOOTING branch.
+
+true value unknown-ip?
+
+: requesting ( -- error? )
+ start-request-packet
+ unknown-ip? if set-server-id then
+ finish-request/decline
+ (requesting)
+;
+
+\ XXX the spec calls for a randomized 1-10 second delay prior to obtaining
+\ an IP address via DHCP DISCOVER. We default to not doing this, because
+\ of concerns that it would slow down the booting process. A particular
+\ system can override this by plugging in a non-null implementation of
+\ desync-delay.
+defer desync-delay ' noop is desync-delay
+
+\ XXX currently the presence of a client IP address in the load arguments
+\ causes DHCP to be bypassed. We should probably change that to have it
+\ do a DHCPINFORM.
+
+: do-dhcp ( -- )
+ bootnet-debug if
+ ." DHCP protocol: Getting network addresses and client information" cr
+ then
+ /dhcp to /bootp-packet
+
+ /bootp-packet allocate-bootp
+
+ \ XXX Derive, or pass in as an argument, the initial IP address
+ \ and set unknown-ip? according to its existence or lack thereof.
+
+ false to bootp-only?
+
+ unknown-ip? if desync-delay then \ 1-10 seconds; per 4.4.1
+
+ \ INIT state or INIT-REBOOT state
+
+ begin
+ unknown-ip? if
+ \ INIT state
+ begin do-discover while .discover-error repeat
+ then
+
+ bootp-only? 0=
+ while
+ requesting
+ while
+ .request-error
+ true to unknown-ip?
+ repeat
+ then
+
+ setup-ip-attr
+ /bootp-packet free-bootp
+;
+
+[ifdef] notdef
+BOUND state:
+ Now we have a good IP address
+
+
+
+
+If we already know our IP address via manual configuration:
+ send-inform (actually, INFORM is used only when the client already
+ knows its IP address, and needs only to get the rest
+ of its parameters. If the client got the IP address
+ with the preceding algorithm, it will have already
+ obtained all of its parameters)
+ receive-ack
+
+
+Option packing:
+ options field first - end option must be present if chaining,
+ but pad options are optional
+ file field next - but only if file field is enabled in the options
+ overload option. end option must be present and
+ pad options must be used as necessary to fill the field
+ sname field next - but only if sname field is enabled in the options
+ overload option. end option must be present and
+ pad options must be used as necessary to fill the field
+
+
+client concatenates all options of the same name.
+
+
+backoff: randomized exponential backoff
+ ethernet: 1st retransmission at 4 seconds randomized by a uniformly
+ distributed random number between -1 and 1
+ 2nd retransmission at 8 seconds randomized by -1 to +1
+ 3rd retransmission at 16 seconds randomized by -1 to +1
+ 4th retransmission at 32 seconds randomized by -1 to +1
+ last retransmission at 64 seconds randomized by -1 to +1
+
+How to choose xids to minimize collisions? perhaps hash
+ethernet address and clock value?
+
+Be careful: The server will not automatically extend an extant lease
+when the client requests the address again. If the lease needs to
+be extended, that must be done explicitly. This implies that
+the client probably needs to keep track of its extant lease and
+try to reuse/extend it.
+
+See page 28 for an interesting table.
+
+Note: lease durations need to be converted to absolute expiration
+times by adding to the local clock. It might be better to time
+stamp the acquisition of the lease, so the firmware doesn't have
+to do studly time calculations.
+
+Note: source address field in IP header must be set to 0 before the
+client has obtained its IP address
+
+ my-leased-ip-address-known-and-unexpired? if
+ must not fill-in-ciaddr-field (see end of 3.5 on p.22)
+
+ don't fill in server identifier option (see 4.3.2)
+
+ fill in 'requested-IP address' option
+
+ (okay for client to respond to pings (ICMP echo requests))
+
+ fill in list of specific parameters client is interested in,
+ using "parameter request list" option.
+
+ set 'maximum DHCP message size' option
+
+ for the next REQUEST:
+ if INIT-REBOOT state: (table 4 p33)
+ (broadcast)
+ server identifier must not be filled in
+ set requested IP address with previous-assigned address
+ ciaddr must be 0 per 4.3.2
+
+ if RENEWING state: (table 4 p33)
+ (unicast)
+ server identifier must not be filled in
+ requested IP address must not be filled in
+ ciaddr must be the client's IP address
+
+ if REBINDING state: (table 4 p33)
+ (broadcast)
+ server identifier must not be filled in
+ requested IP address must not be filled in
+ ciaddr must be the client's IP address
+ else
+[then]
+\ XXX Remove now-obsolete bootp code like do-bootp
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Added: ofw/inetv6/dns.fth
===================================================================
--- ofw/inetv6/dns.fth (rev 0)
+++ ofw/inetv6/dns.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,275 @@
+\ See license at end of file
+purpose: Domain name resolver
+
+headerless
+\ struct ( dns header )
+\ /w field >id \ 0 - Number to match questions with answers
+\ /w field >dns-flags \ 2 - q/a:8000 opcode:780 aa:40 tc:20 rd:10 ra:8 rc:f
+\ /w field >qdcount \ 4 - number of following questions
+\ /w field >anscount \ 6 - number of following answer RRs
+\ /w field >nscount \ 8 - number of following name server RRs
+\ /w field >arccount \ a - number of following additional RRs
+\ constant /dns-header
+
+\ DNS question format: QNAME-variable_length, QTYPE(/w), QCLASS(/w)
+\ QTYPE value for "A" (host name) is 1
+\ QCLASS value for "IN" (Internet) is 1
+
+d# 1022 value fw-port#
+
+\ Encode/decode various DNS data types
+: +dnsw ( w -- ) wbsplit +xb +xb ;
+: -dnsw ( -- w ) -xb -xb swap bwjoin ;
+: -dnsl ( -- l ) -dnsw -dnsw swap wljoin ;
+
+\ A label is a dot-less component of a dotted name. In DNS packets,
+\ a label is represented as a length byte followed by the bytes of the string.
+: +dns-label ( adr len -- ) dup +xb bounds ?do i c@ +xb loop ;
+
+\ A name is a full domain name consisting of one or more labels sepearate
+\ by dots. In DNS packets, the dots are not included.
+: +dns-name ( adr len -- )
+ begin dup while
+ [char] . left-parse-string
+ +dns-label
+ repeat
+ 2drop
+ 0 +xb
+;
+: -dnsbytes ( len -- adr len )
+ dup x$ over >r ( len len adr rem-len r: adr )
+ rot /string to x$ ( len r: adr )
+ r> swap ( adr len )
+;
+
+: +np ( adr len byte -- ) >r 2dup + r> swap c! 1+ ;
+
+defer -dns-tail \ Forward reference for mutual recursion
+
+0 instance value dns-header \ Pointer to beginning of DNS header
+
+\ Handle a compressed name tail, which is represented by a 2-byte
+\ offset from the beginning of the DNS header to the beginning of a
+\ previous uncompressed copy of the name tail.
+: do-ptr ( adr len ptr-offset -- adr len' )
+ h# c0 invert and -xb swap bwjoin dns-header + d# 255 ( adr len )
+ x$ 2>r to x$
+ -dns-tail
+ 2r> to x$
+;
+
+\ Handle the next name component, which is either:
+\ a) The end of the name, represented by a 0 byte
+\ b) A label, represented by a length byte (0-31) followed by the string
+\ c) A pointer, represented by pair of bytes "11oooooo oooooooo", where
+\ oooooo oooooooo is a 14-bit offset (see do-ptr)
+: -component ( adr len -- adr len' end? )
+ -xb ?dup 0= if true exit then
+ dup h# c0 and case
+ h# c0 of do-ptr true endof
+ h# 00 of -dnsbytes bounds ?do i c@ +np loop false endof
+ \ the 80 and 40 cases are reserved
+ ( default ) ." Unknown DNS label code" cr true swap
+ endcase
+;
+
+\ Copy the tail of a DNS name from the DNS packet to the buffer adr,len
+: (-dns-tail) ( adr len -- adr len' )
+ -component if exit then
+ begin [char] . +np -component until
+;
+' (-dns-tail) to -dns-tail
+
+\ Extract a domain name from the DNS packet into a local buffer
+d# 256 buffer: dns-name-buf
+: -dns-name ( -- adr len ) dns-name-buf 0 -dns-tail ;
+
+\ Add the host name to the packet and tack on the domain name
+\ if it's not already there
+: +dns-host ( adr len -- )
+ [char] . split-string ( head$ tail$ )
+ dup if \ Already fully-qualified ( head$ tail$ )
+ nip + +dns-name ( )
+ else \ No domain name ( head$ tail$ )
+ 2drop +dns-label ( )
+ domain-name +dns-name ( )
+ then ( )
+;
+
+d# 512 constant /dns-query
+d# 53 constant dns-port#
+0 instance value dns-xid
+
+\ Send a DNS question asking for the IP address for the indicated host
+: send-dns-query ( hostname$ -- )
+ /dns-query allocate-udp >r
+ r@ start-encode
+ next-xid lwsplit drop to dns-xid \ DNS transaction IDs are 16 bits
+ \ Flags=100 means standard query, recursion desired (100)
+ \ ID flags #questions #answers #namesrvrs #additional
+ dns-xid +dnsw h# 100 +dnsw 1 +dnsw 0 +dnsw 0 +dnsw 0 +dnsw
+ +dns-host
+ 1 +dnsw 1 +dnsw
+ x$ fw-port# dns-port# send-udp-packet
+ r> /dns-query free-udp
+;
+defer handle-dns-call ' noop is handle-dns-call
+
+: unexpected-xid ( -- )
+ bootnet-debug if
+ ." (Discarding DNS reply with mismatched transaction ID)" cr
+ then
+;
+
+\ Receive a DNS reply, filtering out stuff that's not for us
+: receive-dns-reply ( xid his-port# my-port# -- error? )
+ begin
+ begin
+ \ Filter out other destination ports
+\ dup receive-udp-packet if ( xid his mine ) \ Timeout
+ dup receive if ( xid his mine ) \ Timeout
+ ." Timeout waiting for DNS reply" cr
+ 3drop true exit
+ then ( xid his mine adr len actual-port# )
+ \ Filter out other source ports
+ 4 pick <> while ( xid his mine adr len )
+ 2drop ( xid his mine )
+ repeat ( xid his mine adr len )
+
+ over to dns-header ( xid his mine )
+ start-decode ( xid his mine )
+
+ \ Filter out other transaction IDs
+ 2 pick -dnsw <> if ( xid his mine )
+ unexpected-xid false ( xid his mine flag )
+ else ( xid his mine )
+ \ Filter out DNS calls
+ -dnsw h# 8000 and 0= if ( xid his mine )
+ handle-dns-call false ( xid his mine false )
+ else ( xid his mine )
+ true ( xid his mine true )
+ then ( xid his mine done? )
+ then ( xid his mine done? )
+ until ( xid his mine )
+ 3drop false ( false )
+;
+
+\ Decode/extract a DNS question section from the DNS packet
+: -dns-question ( -- name$ type class ) -dns-name -dnsw -dnsw ;
+
+\ Discard TTL
+: -data ( -- ) -dnsw -dnsbytes 2drop ;
+: parse-answer ( -- false | 'ip true )
+ -dns-name 2drop
+
+ -dnsw -dnsw wljoin ( class.type )
+ -dnsl drop ( class.type ) \ Discard TTL
+ h# 1.0001 = if ( )
+ -dnsw drop \ Discard RDLENGTH (it better be 4!)
+ x$ drop true ( 'ip true )
+ else ( )
+ -dnsw ( datalen )
+ -dnsbytes 2drop false ( false )
+ then
+;
+
+\ Decode the reply to a DNS "get IP address for host name" query.
+: get-host-addr ( -- 'ip )
+ \ Decoder is pointing at the QDCOUNT field
+
+ -dnsw -dnsw ( #questions #answers )
+ -dnsw drop -dnsw drop \ Discard NSCOUNT and ARCOUNT
+
+ \ Discard echoed questions
+ swap 0 ?do -dns-question 2drop 2drop loop ( #answers )
+
+ 0 ?do parse-answer if unloop exit then loop ( )
+ 4 throw
+;
+
+headers
+\ Return in the buffer 'ip the IP address address for named host.
+\ The host name can be either a simple name (e.g. "pi") or a
+\ fully-qualified domain name (e.g. "pi.firmworks.com").
+: try-resolve ( hostname$ -- 'ip )
+ name-server-ip set-dest-ip ( hostname$ )
+ d# 2000 set-timeout ( hostname$ )
+ send-dns-query ( )
+ dns-xid dns-port# fw-port# receive-dns-reply ( error? )
+ 1 and throw ( )
+ get-host-addr ( answer-ip )
+;
+: (resolve) ( hostname$ -- )
+ bootnet-debug if ( hostname$ )
+ ." Using DNS to find the IP address of " ( hostname$ )
+ 2dup type cr ( hostname$ )
+ then ( hostname$ )
+
+ d# 20 0 do \ Try 20 times at 2 seconds per try
+ 2dup ['] try-resolve catch ?dup if ( hostname$ x x err )
+ nip nip ( hostname$ err )
+ 1 <> if ( hostname$ )
+ bootnet-debug if ( hostname$ )
+ ." Unknown hostname: " 2dup type cr ( hostname )
+ then ( hostname$ )
+ true abort" Unknown hostname"
+ then ( hostname$ )
+ else ( hostname$ 'ip )
+ bootnet-debug if ( hostname$ 'ip )
+ ." Got IP address " dup .ipaddr cr ( hostname$ 'ip )
+ then ( hostname$ 'ip )
+
+ nip nip ( 'ip )
+ unloop exit
+ then ( hostname$ )
+ loop ( hostname$ )
+
+ bootnet-debug if ." No answer to DNS request" cr then ( hostname$ )
+ true abort" DNS: No answer"
+;
+\ : resolve ( 'ip hostname$ -- ) (resolve) swap copy-ip-addr ;
+
+headerless
+: ?bad-ip ( flag -- ) abort" Bad host name or address" ;
+4 buffer: ip-buf
+: $>ip ( adr len -- 'ip )
+ push-decimal
+ ip-buf 4 bounds do
+ [char] . left-parse-string $number ?bad-ip
+ dup d# 256 >= ?bad-ip
+ i c!
+ loop
+ pop-base
+ 2drop
+ ip-buf
+;
+
+headers
+: $set-host ( hostname$ -- )
+ dup 0= ?bad-ip
+ over c@ [char] 0 [char] 9 between if $>ip else (resolve) then
+ set-dest-ip
+;
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Added: ofw/inetv6/dnsv6.fth
===================================================================
--- ofw/inetv6/dnsv6.fth (rev 0)
+++ ofw/inetv6/dnsv6.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,54 @@
+\ See license at end of file
+purpose: Domain name version 6 resolver
+
+headerless
+
+/ipv6 buffer: ipv6-buf
+
+[ifndef] include-ipv4
+: $>ip ( hostname$ -- 'ip ) .ipv4-not-supported ;
+: (resolve) ( hostname$ -- 'ip ) .ipv4-not-supported ;
+: set-dest-ip ( buf -- ) .ipv4-not-supported ;
+: ?bad-ip ( flag -- ) abort" Bad host name or address" ;
+[then]
+
+headers
+: (resolvev6) ( hostname$ -- 'ip ) ;
+
+\ XXX Try (resolve) or (resolve6) first. If fail, try the other one.
+: (resolve) ( hostname$ -- 'ip )
+ use-ipv6? if (resolvev6) true else (resolve) false then
+ dup to use-ipv6?
+ if set-dest-ipv6 else set-dest-ip then
+;
+
+: $set-host ( hostname$ -- )
+ dup 0= ?bad-ip
+ 2dup ['] $>ip catch if 2drop else false to use-ipv6? set-dest-ip 2drop exit then
+ 2dup ipv6-buf ['] $ipv6# catch nip nip not if true to use-ipv6? ipv6-buf set-dest-ipv6 exit then
+ (resolve)
+;
+
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Added: ofw/inetv6/encdec.fth
===================================================================
--- ofw/inetv6/encdec.fth (rev 0)
+++ ofw/inetv6/encdec.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,37 @@
+\ See license at end of file
+purpose: Encode and decode bytes
+
+headerless
+0 0 2value x$
+: start-encode ( adr -- ) 0 to x$ ;
+: start-decode ( adr len -- ) to x$ ;
+: +xb ( byte -- ) x$ + c! x$ 1+ to x$ ;
+: -xb ( -- byte )
+ x$ ( adr len )
+ dup 0<= abort" Premature exhaustion of decoded data"
+ over c@ -rot 1 /string to x$
+;
+headers
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Added: ofw/inetv6/ethernet.fth
===================================================================
--- ofw/inetv6/ethernet.fth (rev 0)
+++ ofw/inetv6/ethernet.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,212 @@
+\ See license at end of file
+purpose: Definitions related to Ethernet headers and addresses
+
+hex
+
+headerless
+d# 1514 constant ethernet-max \ Header (14) + data (1500)
+ \ Checksum (4) not counted
+
+0 instance value (link-mtu) \ max packet size
+0 instance value packet-buffer
+
+\ Determine the Ethernet address for his-ip-addr
+instance defer resolve-en-addr ( 'dest-adr type -- 'en-adr type )
+\ will be set later
+
+: link-mtu ( -- n )
+ (link-mtu) ?dup 0= if
+ " max-frame-size" get-inherited-property if
+ " max-frame-size" my-parent ihandle>phandle find-method if
+ drop " max-frame-size" my-parent $call-method
+ else
+ ethernet-max
+ then
+ else
+ get-encoded-int
+ then
+ dup to (link-mtu)
+ then
+;
+
+: open-link ( -- ) link-mtu alloc-mem to packet-buffer ;
+: close-link ( -- ) packet-buffer link-mtu free-mem ;
+
+6 constant /e
+
+: en= ( adr1 adr2 -- flag ) /e comp 0= ;
+: copy-en-addr ( src dst -- ) /e move ;
+
+/e buffer: my-en-addr
+/e buffer: his-en-addr
+
+: .my-link-addr ( -- ) ." My MAC: " my-en-addr .enaddr ;
+: .his-link-addr ( -- ) ." His MAC: " his-en-addr .enaddr ;
+
+create multicast-en-addr h# 33 c, 33 c, h# ff c, 0 c, 0 c, 0 c,
+create broadcast-en-addr h# ff c, ff c, h# ff c, h# ff c, h# ff c, h# ff c,
+
+decimal
+
+struct ( ether-header )
+ /e sfield en-dest-addr
+ /e sfield en-source-addr
+ 2 sfield en-type
+constant /ether-header
+
+: set-mc-hash ( -- err? )
+ my-ipv6-addr /ipv6 + 3 - multicast-en-addr 3 + 3 move
+ multicast-en-addr /e " set-multicast" ['] $call-parent catch 0= if false exit then
+ 4drop
+ multicast-en-addr /e " $crc" evaluate invert
+ " set-hash" ['] $call-parent catch if 3drop true else false then
+;
+
+: select-ethernet-header ( -- ) packet-buffer set-struct ;
+
+: max-link-payload ( -- n ) link-mtu /ether-header - ;
+
+defer handle-ethernet ( adr len type -- ) ' 3drop is handle-ethernet
+headers
+: (handle-ethernet) ( adr len type -- )
+ ." (Discarding ethernet packet of type " u. ." )" cr
+ 2drop
+;
+headerless
+
+list: ethlist
+listnode
+ /n field >eth-adr \ contents-adr
+ /n field >eth-len \ contents-len
+ 2 field >eth-type
+nodetype: ethnode
+
+0 ethlist !
+0 ethnode !
+0 value eth-type
+
+: free-ethnode ( prev -- adr len )
+ delete-after
+ dup ethnode free-node
+ dup >eth-adr @ swap >eth-len @ ( adr len )
+ 2dup packet-buffer swap move ( adr len )
+ tuck free-mem ( len )
+ packet-buffer swap ( adr len )
+;
+
+decimal
+th 800 constant IP_TYPE
+th 86dd constant IPV6_TYPE
+hex
+
+: ip-type? ( type -- ip-type? ) dup IP_TYPE = swap IPV6_TYPE = or ;
+
+: eth-type=? ( type -- flag )
+ eth-type ip-type? if ip-type? else eth-type = then
+;
+
+: eth-type-find ( node-adr -- flag ) >eth-type w@ eth-type=? ;
+
+: enque ( adr len type -- )
+ -rot dup alloc-mem swap 2dup 2>r move 2r> ( type adr' len )
+ ethnode allocate-node ( type adr len node )
+ dup ethlist last-node insert-after ( type adr len node )
+ tuck >eth-len ! ( type adr node )
+ tuck >eth-adr ! ( type node )
+ >eth-type w! ( )
+;
+
+: dequeue? ( type -- 0 | adr len true )
+ to eth-type
+ ethlist ['] eth-type-find find-node if
+ free-ethnode ( adr len )
+ true ( adr len true )
+ else
+ drop 0
+ then
+;
+
+: (receive-ethernet-packet) ( type -- true | adr len false )
+ begin
+ pause
+ packet-buffer link-mtu " read" $call-parent ( type length|-error )
+ dup 0> if ( type length )
+ select-ethernet-header ( type length )
+ over en-type xw@ = if ( type length )
+ nip /ether-header payload false exit ( adr len false )
+ else ( type length )
+ dup /ether-header payload ( type len adr len )
+ en-type xw@ dup ip-type? if ( type len adr len type )
+ enque ( type len )
+ else ( type len adr len type )
+ handle-ethernet ( type length )
+ then
+ then ( type length )
+ then ( type 0|-error )
+ drop ( type )
+ timeout? ( type flag )
+ until ( type )
+ drop true ( true )
+;
+
+: receive-ethernet-packet ( type -- true | adr len false )
+ dup dequeue? if rot drop false exit then
+ (receive-ethernet-packet)
+;
+
+: send-ethernet-packet ( data-adr data-len type dst-en-addr -- )
+ 2swap swap /ether-header - set-struct -rot ( data-len type dst )
+
+ en-dest-addr copy-en-addr ( data-len type )
+ en-type xw! ( data-len )
+ my-en-addr en-source-addr copy-en-addr ( data-len )
+
+ the-struct swap /ether-header + tuck " write" $call-parent ( len actual )
+ <> if ." Network transmit error" cr then
+;
+
+: lock-link-addr ( -- )
+ the-struct >r select-ethernet-header
+ en-source-addr his-en-addr copy-en-addr
+ r> set-struct
+;
+: allocate-ethernet ( payload-len -- payload-adr )
+ /ether-header + alloc-mem /ether-header +
+;
+: free-ethernet ( payload-adr payload-len -- )
+ /ether-header negate /string free-mem
+;
+
+: unlock-link-addr ( -- ) broadcast-en-addr his-en-addr copy-en-addr ;
+
+: send-link-packet ( packet-adr packet-len [ 'dest-adr ... ] type -- )
+ resolve-en-addr ( packet-adr packet-len 'en-adr type -- )
+ swap send-ethernet-packet
+
+;
+
+headers
+
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Added: ofw/inetv6/finger.fth
===================================================================
--- ofw/inetv6/finger.fth (rev 0)
+++ ofw/inetv6/finger.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,44 @@
+\ See license at end of file
+purpose: "Finger" command, useful mostly for testing
+
+100 buffer: rbuf
+: read-one ( -- n )
+ begin rbuf 100 " read" $call-tcp dup -2 = while drop repeat
+;
+: read-all ( -- )
+ begin read-one dup -1 <> while rbuf swap list repeat drop
+;
+
+: $finger ( name$ host$ -- )
+ d# 79 open-tcp-connection
+ tcp-type " "n" tcp-type read-all
+ close-tcp
+;
+: finger ( "user at host" -- )
+ safe-parse-word
+ [char] @ left-parse-string 2swap ( user$ host$ )
+ $finger
+;
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Added: ofw/inetv6/http.fth
===================================================================
--- ofw/inetv6/http.fth (rev 0)
+++ ofw/inetv6/http.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,308 @@
+\ See license at end of file
+purpose: HTTP package
+
+hex
+
+false instance value debug?
+
+d# 255 instance buffer: pathbuf
+: fix-delims ( $ -- $' )
+ pathbuf pack count ( $' )
+
+ 2dup bounds ?do ( $' )
+ i c@ dup [char] | = swap [char] \ = or if [char] / i c! then
+ loop
+;
+: set-server ( server$ -- )
+ dup if " $set-host" $call-parent else 2drop then
+;
+char / constant delim
+: url-parse ( url$ -- filename$ server$ )
+ \ If the string is shorter than 2 characters, the server portion is null
+ dup 2 < if " " exit then ( url$ )
+
+ \ If the string doesn't start with //, the server portion is null
+ over " //" comp if " " exit then ( url$ )
+
+ 2 /string ( server/filename$ )
+ delim split-string ( server$ filename$ )
+ 2swap ( filename$ server$ )
+;
+
+: close ( -- )
+;
+
+\ false instance value reports?
+
+2variable seek-ptr
+: seek ( d -- error? ) seek-ptr 2@ d<> ;
+: update-ptr ( actual -- actual )
+ dup 0 seek-ptr 2@ d+ seek-ptr 2! ( actual )
+;
+
+: tcp-read ( adr len -- actual ) " read" $call-parent ;
+: wait-read ( adr len -- actual )
+ begin
+ 2dup tcp-read dup -2 = ( adr len actual flag )
+ while ( adr len actual )
+ drop ( adr len )
+ repeat ( adr len actual )
+ nip nip ( actual )
+ update-ptr ( actual )
+;
+
+: read ( adr len -- actual )
+ over + over ( start end next )
+ begin ( start end next )
+ \ Check for end of buffer
+ 2dup = if ( start end next )
+ nip swap - update-ptr exit ( actual )
+ then ( start end next )
+
+ 2dup - ( start end next # )
+ over swap wait-read ( start end next actual )
+
+ dup -1 = if ( start end next -1 )
+ drop ( start end next )
+ nip swap - update-ptr ( actual )
+ \ Return -1 if this is the end and we didn't get any data this pass
+ dup 0= if 1- then ( actual | -1 )
+ exit
+ then ( start end next actual )
+
+ + ( start end next' )
+ again
+;
+
+: load ( adr -- len )
+ dup begin ( adr next-adr )
+ dup h# 800 read dup -1 <> ( adr next-adr )
+ while ( adr next-adr actual )
+ dup 0<= if ( adr next-adr actual )
+ drop ( adr next-adr )
+ else ( adr next-adr actual )
+ + ( adr next-adr' )
+ show-progress ( adr next-adr' )
+ then ( adr next-adr' )
+ repeat ( adr next-adr actual )
+ drop swap - update-ptr ( len )
+;
+
+: parse-port ( server$ -- port# server$' )
+ [char] : left-parse-string ( port$ server$ )
+ 2swap dup if ( server$ port$ )
+ push-decimal $number pop-base ( server$ port# error? )
+ abort" Bad port number" ( server$ port# )
+ else ( server$ port$ )
+ 2drop d# 80 ( server$ port# )
+ then ( server$ port# )
+ -rot ( port# server$ )
+;
+
+: tcp-write ( adr len -- ) " write" $call-parent drop ;
+
+: decode-url ( url$ -- send$ prefix$ port# server$ )
+ fix-delims ( url$' )
+ " http-proxy" not-alias? if ( url$ )
+ url-parse null$ ( filename$ server$ prefix$ )
+ bootnet-debug if ." HTTP Server " 2over type cr then
+ else ( url$ proxy$ )
+ dup 0= if ( url$ proxy$ )
+ 2drop url-parse null$ ( filename$ server$ prefix$ )
+ bootnet-debug if ." HTTP Proxy server " 2over type cr then
+ else ( url$ proxy$ )
+ " http:" ( url$ proxy$ prefix$ )
+ then ( url$ proxy$ prefix$ )
+ then ( send$ server$ prefix$ )
+ 2swap parse-port ( send$ prefix$ port# server$ )
+;
+0 value image-size
+-1 value result-code
+vocabulary http-tags
+
+: parse-line ( adr len -- )
+ save-input 2>r 2>r 2>r -1 set-input
+ push-decimal
+ parse-word ['] http-tags search-wordlist if execute then
+ pop-base
+ 2r> 2r> 2r> restore-input
+;
+
+: read1 ( adr -- ) 1 wait-read -1 = throw ;
+
+1 instance buffer: ch
+: eat-line ( -- )
+ begin ch read1 ch c@ carret = until
+ ch read1
+;
+
+: (get-line) ( adr maxlen -- adr actual )
+ over + over ( start end next )
+ begin ( start end next )
+ \ Check for end of buffer
+ 2dup = if ( start end next )
+ eat-line ( start end next )
+ nip over - exit ( adr len )
+ then ( start end next )
+
+ \ Read the next character
+ dup read1 ( start end next )
+
+ \ Check for end of line
+ dup c@ carret = if ( start end next )
+ dup read1 ( start end next ) \ Eat the LF
+ nip over - exit ( adr len )
+ then ( start end next )
+
+ 1+ ( start end next' )
+ again
+;
+h# 100 instance buffer: line-buffer
+
+: get-line ( -- adr len ) line-buffer h# 100 (get-line) ;
+: skipwhite ( $ -- $' )
+ begin ( $ )
+ dup ( $ len )
+ while ( $ )
+ over c@ dup bl = swap 9 = or ( $ white? )
+ while ( $ )
+ 1 /string ( $' )
+ repeat then ( $' )
+;
+: scanwhite ( $ -- tail$ head$ )
+ " "t" lex if ( tail$ head$ delim )
+ drop ( tail$ head$ )
+ else ( $ )
+ null$ 2swap ( null-tail$ head$ )
+ then ( tail$ head$ )
+;
+
+: get-number ( adr len -- n ) push-decimal $number pop-base throw ;
+: version-bad? ( $ -- flag )
+ 2dup " HTTP/1.0" $= if 2drop false exit then ( $ )
+ 2dup " HTTP/1.1" $= if
+ 2drop false
+ else
+ bootnet-debug if
+ ." HTTP: Bad version: " type cr
+ else 2drop then
+ true
+ then
+;
+: dump-response ( -- )
+ begin get-line dup while type cr repeat
+;
+: check-status-line ( -- )
+ get-line scanwhite ( rem$' head$ )
+ version-bad? ( rem$' error? )
+ abort" HTTP: Bad version line" ( rem$ )
+ skipwhite scanwhite ( rem$ head$ )
+ get-number ( rem$ # )
+ \ XXX should handle 3xx redirects
+ dup d# 200 <> if ( rem$ # )
+ bootnet-debug if ( rem$ # )
+ dup d# 302 = if
+ ." HTTP: Response: " .d type cr ( )
+ dump-response
+ else
+ ." HTTP: Bad response: " .d type cr ( )
+ then
+ then ( | rem$ # )
+ abort ( )
+ else 3drop then ( )
+;
+: parse-header-line ( adr len -- )
+ [char] : left-parse-string ( tail$ head$ )
+ ['] http-tags search-wordlist if ( tail$ xt )
+ execute ( )
+ else ( tail$ )
+ 2drop ( )
+ then ( )
+;
+
+also http-tags definitions
+\ Sample header:
+\ HTTP/1.0 200 OK
+\ Date: Tue, 02 Mar 1999 22:46:34 GMT
+\ Server: Apache/1.1.1
+\ Content-type: text/html
+\ Content-length: 10696
+\ Last-modified: Thu, 11 Feb 1999 01:08:12 GMT
+
+: content-length ( $ -- ) \ [<white>] length
+ skipwhite scanwhite ( tail$ head$ )
+ 2swap 2drop ( head$ )
+ get-number ( size )
+ to image-size
+;
+
+previous definitions
+
+: check-header ( -- )
+ 0. seek-ptr 2!
+ 0 to image-size
+ -1 to result-code
+ check-status-line
+ begin get-line dup while parse-header-line repeat 2drop
+;
+: mount ( $url -- error? )
+ decode-url ( send$ prefix$ port# server$ )
+
+ 2dup set-server ( send$ prefix$ port# server$ )
+ rot ( send$ prefix$ server$ port# )
+
+ bootnet-debug if ." Connecting to port " dup .d cr then
+ " connect" $call-parent 0= if ( send$ prefix$ server$ )
+ 4drop 2drop true exit
+ then ( send$ prefix$ server$ )
+
+ bootnet-debug if ." Connected" cr then
+
+ " GET " tcp-write ( send$ prefix$ server$ )
+ 2swap tcp-write 2swap tcp-write ( server$ )
+ " HTTP/1.1"r"nUser-Agent: FirmWorks/1.1"r"nHost: " tcp-write
+ tcp-write " "r"n"r"n" tcp-write
+
+ " flush-writes" $call-parent
+
+ ['] check-header catch
+;
+
+: open ( -- )
+ my-args dup if
+ bootnet-debug if
+ 2dup ." HTTP: URL is: " type cr
+ then
+ mount 0=
+ bootnet-debug if
+ ." HTTP: "
+ dup if ." Succeded" else ." Failed!" then cr
+ then
+ else
+ 2drop true
+ then
+;
+: size ( -- d ) image-size 0 ;
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Added: ofw/inetv6/httpd.fth
===================================================================
--- ofw/inetv6/httpd.fth (rev 0)
+++ ofw/inetv6/httpd.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,53 @@
+\ See license at end of file
+purpose: HTTP Server command
+
+external
+
+defer httpd-exit-hook ['] noop to httpd-exit-hook
+
+headers
+
+support-package: httpd
+fload ${BP}/ofw/inet/httpdpkg.fth
+end-support-package
+
+\ devalias httpd tcp//httpd
+\ devalias httpd tcp//httpd:verbose,debug
+
+external
+
+: httpd ( -- )
+
+ ['] noop to httpd-exit-hook
+
+ " httpd" open-dev dup 0= abort" Can't open httpd" ( ih ) >r
+ " httpd-loop" r@ ['] $call-method catch if 3drop then
+ r> close-dev
+
+ httpd-exit-hook
+;
+
+headers
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Added: ofw/inetv6/httpdpkg.fth
===================================================================
--- ofw/inetv6/httpdpkg.fth (rev 0)
+++ ofw/inetv6/httpdpkg.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,1002 @@
+\ See license at end of file
+purpose: HTTPD Server package
+
+\ To use this code, be certain that you have an "index.htm"
+\ in the ROM as a dropin along with a "homelogo.gif".
+
+hex
+headers
+
+\needs httpd-port d# 80 constant httpd-port
+
+false value httpd-debug?
+: ?httpd-show ( adr len mask -- )
+ httpd-debug? and if type space else 2drop then
+;
+[ifndef] show"
+: ?show ( adr len -- ) 1 ?httpd-show ;
+: show" ( "str" -- ) postpone " postpone ?show ; immediate
+[then]
+[ifndef] state"
+: ?state ( adr len -- ) 2 ?httpd-show ;
+: state" ( "str" -- ) postpone " postpone ?state ; immediate
+[then]
+[ifndef] url"
+: ?url ( adr len -- ) 4 ?httpd-show ;
+: url" ( "str" -- ) postpone " postpone ?url ; immediate
+[then]
+\needs init-display : init-display ( adr len -- ) 2drop ;
+
+true value key-interrupt?
+" " 2value pending-cmd
+
+0 value hbuf \ Accumulator for incoming data
+h# 800 constant /hbuf
+0 value hbuf-ptr
+
+0 value sbuf \ A temporary string buffer
+h# 40 constant /sbuf
+
+0 value obuf \ A buffer for constructing headers
+h# 800 constant /obuf
+0 value obuf-ptr
+
+\ The TCP stack on NT appears to do a better job of collecting data and
+\ sending it all at once. If our receive buffer is too short, then
+\ Netscape on NT will choke. A value of h# 100 will not work here.
+0 value thbuf \ Intermediate buffer to hold data
+h# 200 constant /thbuf \ from TCP stack
+
+: +hptr ( -- ) hbuf-ptr 1+ to hbuf-ptr ;
+: reset-hbuf-ptr ( -- ) 0 to hbuf-ptr ;
+
+: hbuf@ ( index -- b )
+ hbuf + c@
+;
+
+: hbuf-adr ( -- adr ) hbuf hbuf-ptr + ;
+
+0 instance value verbose?
+0 instance value preprocess?
+0 instance value authenticate?
+
+: parse-args ( -- )
+ my-args
+ begin dup while ( rem$ )
+ ascii , left-parse-string ( rem$' head$ )
+ 2dup " debug" $= if true to httpd-debug? else ( rem$' head$ )
+ 2dup " verbose" $= if true to verbose? else ( rem$' head$ )
+ 2dup " preprocess" $= if true to preprocess? else ( rem$' head$ )
+ 2dup " authenticate" $= if true to authenticate? else ( rem$' head$ )
+ 2dup " nokey" $= if false to key-interrupt? else ( rem$' head$ )
+ then then then then then ( rem$' head$ )
+ 2drop
+ repeat
+ 2drop
+;
+
+: .ipb ( adr -- adr' ) dup 1+ swap c@ (.) type ;
+: .ipaddr ( addr-buff -- )
+ push-decimal
+ 3 0 do .ipb ." ." loop .ipb drop
+ pop-base
+;
+
+false instance value connected?
+: ?bailout ( -- )
+ key-interrupt? if
+ key? if key drop abort then
+ then
+ pending-cmd dup if
+ " " to pending-cmd include-buffer
+ else
+ 2drop
+ then
+;
+: connect ( -- )
+ httpd-debug? if ." Waiting for new connection" cr then
+ state" W"
+ begin
+ ?bailout
+ httpd-port " accept" $call-parent
+ until
+ true to connected?
+ reset-hbuf-ptr \ Clear the buffer for a new connection
+ httpd-debug? if ." Connected" cr then
+ state" C"
+;
+
+: open ( -- flag )
+ parse-args
+
+ " my-ip-addr" $call-parent collect( .ipaddr )collect
+ 2dup init-display
+ verbose? if
+ ." http://"
+ 2dup type
+ cr
+ key-interrupt? if
+ ." Type any key to stop." cr
+ then
+ then
+ 2drop
+
+ /hbuf alloc-mem to hbuf
+ /sbuf alloc-mem to sbuf
+ /thbuf alloc-mem to thbuf
+ /obuf alloc-mem to obuf
+ true
+;
+
+\ in-progress? is true while we are collecting and processing a request.
+\ It is false while we are polling for a new request on a persistent
+\ connection or while there is no open connection.
+false value in-progress?
+
+\ This is a special hack that is used by the Swing Solutions application,
+\ which has some HTTP requests that do not complete until an exernal event
+\ occurs. The requester can abort the request by dropping the TCP
+\ connection, but there are some cases where the TCP drop does not
+\ appear to be propagated to the responder. Executing abort-on-reconnect
+\ marks the current TCP connection so that the receipt of a new connection
+\ request will abort the current one.
+: abort-on-reconnect ( -- ) " abort-on-reconnect" $call-parent ;
+
+: reset-connection ( -- )
+ " disconnect" $call-parent
+ false to connected?
+ false to in-progress?
+;
+
+: close ( -- )
+ hbuf /hbuf free-mem
+ sbuf /sbuf free-mem
+ thbuf /thbuf free-mem
+ obuf /obuf free-mem
+;
+
+: read ( adr len -- actual )
+ " read" $call-parent dup -1 = if
+ connected? if show" HDROP" then
+ false to connected?
+ then
+;
+: write ( adr len -- actual ) " write" $call-parent ;
+
+: match? ( match$ -- match? ) hbuf over $= ;
+
+: (send-all) ( adr len -- )
+ dup 0= if 2drop exit then
+ tuck write 2dup <> if ( len actual )
+ dup -1 = if
+ ." Connection closed prematurely" cr
+ show" HSDROP"
+ else
+ ." Write failure" cr
+ show" HWERR"
+ then
+ then
+ 2drop
+;
+defer send-all ' (send-all) to send-all
+
+: >obuf ( adr len -- )
+ tuck obuf-ptr swap move obuf-ptr + to obuf-ptr
+;
+: init-obuf ( -- )
+ ['] >obuf to send-all
+ obuf to obuf-ptr
+;
+: send-obuf ( -- )
+ ['] (send-all) to send-all
+ obuf obuf-ptr over - send-all
+;
+
+: send-crlf ( -- ) " "r"n" send-all ;
+
+: num>ascii ( n -- $ ) (u.) ;
+
+\ A vrsion of cat that re-uses the same buffer, rather that continually
+\ using alloc-mem to create a new string.
+: $cat2 ( $1 $2 -- $3 )
+ \ First figure final length
+ 2 pick over + >r ( $1 $2 ) ( r: 3len )
+
+ \ Move the first string to buffer, saving length
+ 2swap dup >r sbuf swap move r> ( $2 len ) ( r: 3len )
+
+ \ Now move second string
+ sbuf + swap move ( ) ( r: len )
+
+ \ Now go..
+ sbuf r> ( $3 )
+;
+
+: create-num$ ( len -- num$ )
+ base @ >r decimal ( len ) ( r: base )
+ num>ascii ( num$ )
+ r> base ! ( num$ )
+;
+
+: get-type ( adr len -- c )
+ 0 -rot
+ bounds do
+ i c@ [char] . = if drop i then ( adr )
+ loop
+ 1+ c@
+;
+
+: send-content-type ( type$ -- )
+ " Content-Type: " 2swap $cat2 ( adr len )
+ " "r"n" $cat2 ( adr len' )
+ httpd-debug? if 2dup type then ( adr len' )
+ send-all
+;
+: presume-content-type ( url$ -- type$ )
+ get-type upc ( type-char )
+ case
+ ascii H of " text/html" endof
+ ascii B of " image/bmp" endof
+ ascii G of " image/gif" endof
+ ascii J of " image/jpeg" endof
+ ( default ) >r " text/html" r>
+ endcase
+;
+
+: send-agent ( -- ) " User-Agent: FirmWorks/1.0"r"n" send-all ;
+: 200-header ( -- ) " HTTP/1.0 200 OK"r"n" send-all ;
+: 202-header ( -- ) " HTTP/1.0 202 Accepted"r"n" send-all ;
+: 204-header ( -- ) " HTTP/1.0 204 No Content"r"n" send-all ;
+: 401-header ( -- ) " HTTP/1.0 401 Not Authorized"r"n" send-all ;
+: 404-header ( -- ) " HTTP/1.0 404 Not Found"r"n" send-all ;
+
+defer send-header
+['] 200-header to send-header
+
+false value persistent? \ False means to disconnect after xfers
+
+: send-connection ( -- )
+ persistent? if \ HTTP 1.1 needs to be persistent
+ " Connection: Keep-Alive"r"n" ( adr len )
+ httpd-debug? if 2dup type then ( adr len )
+ send-all ( )
+ then
+;
+
+: count-content ( data$ .. n -- data$ .. n len )
+ 0 over 0 ?do ( data$ .. n len )
+ i 2* 2+ pick + ( data$ .. n len' )
+ loop
+;
+: send-content-length ( data$ .. n -- data$ .. n )
+ count-content ( data$ .. n len )
+ " Content-Length: " ( data$ .. n len adr len )
+ rot create-num$ $cat2 ( data$ .. n adr len' )
+ " "r"n" $cat2 ( data$ .. n adr len'' )
+ httpd-debug? if 2dup type then ( data$ .. n adr len'' )
+ send-all ( data$ .. n )
+;
+
+: send-pieces ( data$ .. n -- )
+ 0 ?do send-all loop
+;
+
+: type-cr ( adr len -- ) type cr ;
+
+\ full-response is what is used to respond to HTTP 1.0 or higher requests.
+: full-response ( data$ .. n type$ -- )
+ httpd-debug? if ." Sending: " 2dup type-cr then
+ init-obuf
+ send-header ( data$ .. n type$ )
+ send-agent ( data$ .. n type$ )
+ send-connection ( data$ .. n type$ )
+ send-content-type ( data$ .. n )
+ send-content-length ( data$ .. n )
+ send-crlf ( data$ .. n ) \ Data separator
+ send-obuf
+ send-pieces ( ) \ Send all segments of the data
+;
+
+\ simple-response is used to respond to HTTP 0.9 requests
+: simple-response ( data$ .. n type$ -- ) 2drop send-pieces ;
+
+: send-response-header ( data$ .. n header$ -- )
+ httpd-debug? if ." Sending: " 2dup type-cr then
+ init-obuf
+ send-header ( data$ .. n header$ )
+ send-all ( data$ .. n )
+ send-crlf ( data$ .. n ) \ Data separator
+ send-obuf
+ send-pieces ( ) \ Send all segments of the data
+;
+
+defer (send)
+['] full-response to (send) \ Default to HTTP 1.0 full-responses for now
+
+: respond ( data$ .. n type$ -- )
+ state" R"
+ connected? 0= if ( data$ .. n type$ )
+ httpd-debug? if ." Discarding response to aborted connection" cr then
+ 2drop 0 ?do 2drop loop
+ exit
+ then
+ (send)
+ state" S"
+;
+
+\ Send a block of preformatted data
+: send-html ( adr len -- ) 1 " text/html" respond ;
+
+: hbuf at ++ ( -- char ) hbuf-ptr hbuf@ +hptr ;
+: skip-til-white ( -- ) begin hbuf at ++ bl = until ;
+: skip-til ( char -- ) begin dup hbuf at ++ = until drop ;
+: skip-til-crlf ( -- ) carret skip-til +hptr ;
+
+: skip-til-white-or-? ( -- )
+ begin hbuf at ++ dup bl = swap [char] ? = or until
+;
+
+: extract-url ( -- option$ url$ ) \ Pull URL $ from incomming request
+ reset-hbuf-ptr ( )
+ skip-til-white ( )
+ hbuf-adr ( start-adr )
+ skip-til-white-or-? ( start-adr )
+ hbuf-adr over - 1- ( start-adr len )
+
+ \ Kill off leading "/" from return
+ dup 1 >= if over c@ [char] / = if 1 /string then then
+
+ dup 0= if ( url$ ) \ But is it real?
+ 2drop 0 0 ( 0 0 )
+ " index.htm" ( 0 0 url$ ) \ Our default
+ exit ( 0 0 url$ ) \ Get out of dodge...
+ then
+
+ hbuf-ptr 1- hbuf@ ascii ? = if \ We have options...
+ hbuf-adr ( url$ opt-adr )
+ skip-til-white ( url$ opt-adr )
+ hbuf-adr over - 1- ( url$ opt-adr opt-len )
+ 2swap ( opt$ url$ )
+ else
+ 0 0 2swap ( 0 0 url$ ) \ No options
+ then
+;
+
+\ Dump preformatted tag into output stream
+: create-pre ( -- ) " <PRE>" type-cr ;
+
+\ Dump end-preformatted tag into output stream
+: create-endpre ( -- ) " </PRE>" type-cr ;
+
+\ Dump a basic HTML header into output stream
+: create-header ( -- )
+ no-page
+ " <HTML>" type-cr
+ " <HEAD>" type-cr
+ " <TITLE>Internet ROM</TITLE>" type-cr
+ " </HEAD>" type-cr
+ " <BODY TEXT=""#000000"" BGCOLOR=""#FFFFFF"" LINK=""#0000FF"" " type-cr
+ " VLINK=""#FF4400"">" type-cr
+ " <hr>" type-cr
+;
+
+\ Dump a link to home into output stream
+: et-go-home ( -- )
+ " <CENTER><A href=""index.htm"" target=""_top"">Back to Main Page</A></CENTER>" type-cr
+;
+
+\ Dump a footer into the output stream
+: create-footer ( -- )
+ " <br>" type-cr
+ et-go-home
+ " <hr>" type-cr
+ " <CENTER><IMG SRC=""homelogo.gif""></CENTER>" type-cr
+ " </BODY>" type-cr
+ " </HTML>" type-cr
+ page-mode
+;
+
+\ Collect output from execute ROM command
+: collect-data ( xt -- adr len )
+ collect( ( xt )
+ create-header ( xt )
+ create-pre ( xt )
+ guarded ( )
+ create-endpre ( )
+ create-footer ( )
+ )collect ( adr len )
+;
+
+\needs auth-header : auth-header ( -- $ ) " WWW-Authenticate: Basic realm=""OFW"""n"r" ;
+
+: send-204 ( -- )
+ httpd-debug? if ." Sending 204" cr then
+ ['] 200-header to send-header
+ ['] banner collect-data send-html
+ ['] 200-header to send-header
+;
+
+: send-401 ( -- )
+ httpd-debug? if ." Sending 401" cr then
+ ['] 401-header to send-header
+ ['] send-response-header to (send)
+ 0 auth-header respond
+ ['] 200-header to send-header
+;
+
+: send-404 ( -- )
+ httpd-debug? if ." Sending 404" cr then
+ ['] 404-header to send-header
+ " The ROM cannot supply this information." send-html
+ ['] 200-header to send-header
+;
+
+\ HTML preprocessing before sending to browser.
+
+0 0 instance 2value rem$
+0 instance value #data$
+: #data$+ ( -- ) #data$ 1+ to #data$ ;
+: find$ ( s$ t$ -- offset find? )
+ 2>r ( s$ ) ( R: t$ )
+ 0 -rot begin ( offset s$ ) ( R: t$ )
+ over 2r@ comp 0= if 2r> 2drop 2drop true exit then
+ 1 /string ( offset s$' ) ( R: t$ )
+ rot 1+ -rot ( offset' s$ ) ( R: t$ )
+ dup 0= until 2r> 2drop 2drop false ( offset )
+;
+: eval-forth ( -- data$ ... )
+ rem$ 7 /string 2dup to rem$ ( adr len )
+ " </FORTH>" find$ 0= if ." Missing </FORTH>" abort then ( offset )
+ rem$ drop swap ( forth$ )
+ rem$ 2 pick 8 + /string to rem$ ( forth$ )
+ evaluate ( data$ ... n )
+ #data$ + to #data$ ( data$ ... )
+;
+: swap-data$ ( data$ ... -- data$' ... n )
+ #data$ if
+ #data$ begin
+ dup 2* pick over 2* pick 2>r
+ 1- ?dup 0=
+ until
+ #data$ 0 do 2drop loop
+ #data$ begin
+ 2r> rot 1- ?dup 0=
+ until
+ then #data$
+;
+: (preprocess-html) ( data$ -- data$' ... n )
+ to rem$
+ begin
+ rem$ " <FORTH>" find$ over ( offset found? offset )
+ #data$+
+ rem$ drop swap 2>r ( offset found? ) ( R: data$ )
+ swap rem$ rot /string to rem$ 2r> ( found? data$ )
+ rot if eval-forth then ( data$ ... )
+ rem$ nip 0=
+ until
+ swap-data$ ( data$ ... n )
+;
+: preprocess-html ( url$ data$ -- data$' ... n' )
+ preprocess? if ( url$ data$ )
+ 0 to #data$ ( url$ data$ )
+ 2swap get-type upc ascii H = if ( data$ )
+ (preprocess-html) ( data$' ... n )
+ else ( data$ )
+ 1 ( data$ n )
+ then
+ else ( url$ data$ )
+ 2swap 2drop 1 ( data$ n )
+ then
+;
+
+: transaction-done ( -- )
+ state" T"
+ persistent? if
+ url" tdonefw"
+ " flush-writes" $call-parent
+ reset-hbuf-ptr
+ false to in-progress?
+ else
+ \ url" tdonerc"
+ reset-connection
+ then
+ state" D"
+;
+
+[ifndef] urls
+also forth definitions
+vocabulary urls
+previous definitions
+[then]
+
+: handle-url ( opt$ url$ -- )
+ 2dup ['] urls search-wordlist if ( opt$ url$ xt )
+ execute ( data$ .. n type$ )
+ respond ( )
+ state" H"
+ exit ( )
+ then ( opt$ url$ )
+
+ 2dup find-drop-in if ( opt$ url$ data$ )
+ 2over 2>r ( opt$ url$ data$ ) ( R: url$ )
+ 2>r 2>r 2drop 2r> 2r> ( url$ data$ ) ( R: url$ )
+ preprocess-html ( data$' n ) ( R: url$ )
+ 2r> presume-content-type ( data$ n type$ )
+ respond ( )
+ exit ( )
+ then ( opt$ url$ )
+
+ 4drop send-404 ( )
+;
+
+\ Basic HTTP strings all end with "crlf"
+: dual-crlf? ( adr -- flag ) 4 - hbuf + " "(0d0a0d0a)" comp 0= ;
+
+: request-complete? ( -- complete? ) \ Tells us if we have all were going
+ \ to get.
+ \ HTTP 0.9 looks like:
+ \ GET <url> crlf
+
+ \ HTTP 1.0/1.1 looks like:
+ \ GET <url> HTTP/1.0 crlf ...<a bunch of crlf terminated crud>... crlf
+
+ \ The major difference being that 0.9 is a single line with a single
+ \ crlf at the end, 1.0 (and higher ) is multi-line (each line terminated
+ \ by crlf) with an additional crlf at the end of the request.
+
+ \ We need to determine which one we have in the buffer, and if complete,
+ \ return true so that the request can be processed. We also want to set
+ \ the response type up here to simple or full depending on 0.9 or 1.x
+
+ hbuf-ptr ( ptr ) \ Save for later
+
+ \ Reset the pointer, then advance it to where HTTP would be if we
+ \ have HTTP 1.0 request.
+
+ reset-hbuf-ptr ( ptr )
+ skip-til-white ( ptr )
+ skip-til-white ( ptr )
+
+ \ Now test the buffer and take action accordingly
+
+ " HTTP" hbuf hbuf-ptr + 4 ( ptr test$ buf$ )
+ $= if ( ptr ) \ HTTP 1.x
+ ['] full-response to (send)
+ \ Now we have to see if we have all of this request or not
+ dup dual-crlf? ( ptr flag )
+
+ \ Now we have to setup to deal with persistent connections.
+ \ This is a bit of a cheat. We should be looking at the
+ \ "connection:" field (if it exists) in the incoming URL
+ \ requset. If it set to "Keep-Alive" then we would set
+ \ the persistent flag. But so far, *everyone* always sets
+ \ the Keep-Alive flag. But 1.0 implementations don't work,
+ \ and 1.1 implementations really want it to. So we just
+ \ set the persistance based on 1.1ness.
+
+ \ " 1.0" hbuf hbuf-ptr + 5 + 3 $= 0= to persistent?
+ else \ HTTP 0.9
+ \ We have all we are going to get.
+ ['] simple-response to (send)
+ true ( ptr true )
+ then
+
+ swap to hbuf-ptr ( flag ) \ Restore buffer pointer in case
+ \ there is more to come.
+;
+
+: b64>6bit ( byte -- 6bit )
+ dup ascii A ascii Z between if ascii A - exit then
+ dup ascii a ascii z between if ascii a - d# 26 + exit then
+ dup ascii 0 ascii 9 between if ascii 0 - d# 52 + exit then
+ case
+ ascii + of 3e endof
+ ascii / of 3f endof
+ ( default ) 0 swap
+ endcase
+;
+
+: b64>ascii ( b64$ -- adr len )
+ over dup >r 0 2swap ( adr len b64$ ) ( R: adr )
+ bounds ?do ( adr len ) ( R: adr )
+ i l@ lbsplit ( adr len b3 b2 b1 b0 ) ( R: adr )
+ b64>6bit d# 18 << ( adr len b3 b2 b1 val ) ( R: adr )
+ swap b64>6bit d# 12 << or ( adr len b3 b2 val' ) ( R: adr )
+ swap b64>6bit d# 6 << or ( adr len b3 val' ) ( R: adr )
+ swap b64>6bit or ( adr len val' ) ( R: adr )
+ lbsplit drop ( adr len b3 b2 b1 ) ( R: adr )
+ 4 pick c! ( adr len b3 b2 ) ( R: adr )
+ 3 pick 1+ c! ( adr len b3 ) ( R: adr )
+ 2 pick 2 + c! ( adr len ) ( R: adr )
+ 3 + swap 3 + swap ( adr' len' ) ( R: adr )
+ 4 +loop
+ dup if \ strip trailing 0's
+ 3 1 do
+ over i - c@ 0= if 1- then
+ loop
+ then nip ( len' )
+ r> swap ( adr len )
+;
+
+: (authorized?) ( realm$ pwd$ user$ -- authorized? )
+ " admin" $= >r " ofw" $= r> and
+ -rot 2drop
+;
+
+defer authorized?
+[ifdef] oem-authorized?
+ ['] oem-authorized? to authorized?
+[else]
+ ['] (authorized?) to authorized?
+[then]
+
+: extract-auth ( -- realm$ pwd$ user$ )
+ begin skip-til-crlf hbuf-adr " "(0d0a)" comp while
+ hbuf-adr ( adr )
+ [char] : skip-til ( adr )
+ hbuf-adr over - 1- ( token$ )
+ " Authorization" $= if ( )
+ skip-til-white ( )
+ hbuf-adr ( adr )
+ skip-til-white
+ hbuf-adr over - 1- ( realm$ )
+ hbuf-adr ( realm$ adr )
+ skip-til-crlf
+ hbuf-adr over - 2 - ( realm$ base64$ )
+ b64>ascii ( realm$ user:pwd$ )
+ [char] : left-parse-string ( realm$ pwd$ user$ )
+ exit
+ then
+ repeat
+ null$ null$ null$
+;
+
+: authenticate-request? ( -- authorized? )
+ extract-auth ( realm$ pwd$ user$ )
+ authorized?
+;
+
+\ Since we serve up the HTML code, we can decide what to support. You
+\ can do everything with "GET"s, and do not really need to support
+\ POSTs. POSTs are better for security issues, but since this code
+\ would not really be executed in the normal case, this should be a
+\ minor issue.
+
+: do-get ( -- )
+ request-complete? if
+
+ httpd-debug? if cr hbuf hbuf-ptr type then
+
+ extract-url ( opt$ url$ )
+
+ httpd-debug? if ( opt$ url$ )
+ ." URL: " 2dup type-cr ( opt$ url$ )
+ 2over ( opt$ url$ opt$ )
+ ?dup if ( opt$ url$ opt$ )
+ ." OPT: " type-cr ( opt$ url$ )
+ else drop then ( opt$ url$ )
+ then ( opt$ url$ )
+
+ authenticate? if ( opt$ url$ )
+ authenticate-request? 0= if ( )
+ 4drop ( )
+ send-401
+ transaction-done
+ exit
+ then
+ then
+
+ handle-url ( )
+
+ transaction-done
+ then
+;
+
+: do-post ( -- )
+ request-complete? if
+ httpd-debug? if cr hbuf hbuf-ptr type then
+ send-204
+ transaction-done
+ then
+;
+
+: handle-buf ( -- )
+ " GET" match? if do-get then
+ " POST" match? if do-post then
+;
+
+false instance value crlf-seen?
+: >hbuf ( b -- ) \ Accumulate data, when we get a CRLF pair, go check it
+ hbuf hbuf-ptr + c!
+ +hptr
+ hbuf-ptr 2 >= if
+ hbuf-ptr hbuf + 2- " "(0d0a)" comp 0= if handle-buf then
+ then
+;
+
+0 value end-time
+d# 5000 constant short-time
+d# 30000 constant long-time
+
+: reset-timer ( -- )
+ true to in-progress?
+ persistent? if long-time else short-time then ( timeout-msecs )
+ get-msecs + to end-time
+;
+
+: do-disconnect ( -- )
+ httpd-debug? if ." Disconnect reset" cr then
+ url" discrc"
+ reset-connection
+;
+: do-idle ( -- )
+ in-progress? if
+ key-interrupt? if
+ key? if
+ key drop
+ ." HTTPD transaction in progress; interacting " cr
+ interact
+ then
+ then
+ else
+ ?bailout
+ then
+
+ persistent? if exit then
+ get-msecs end-time - 0> if
+ httpd-debug? if ." Timeout reset" cr then
+ url" idlerc"
+ reset-connection
+ then
+;
+
+\ Call into the TCP stack, just shovel the data to our collection
+\ buffer. The shoveler (>hbuf) will decide when there is enough
+\ data to work on.
+: httpd-loop ( -- )
+ false to in-progress?
+ begin
+ connected? 0= if connect reset-timer then
+
+ thbuf /thbuf read case ( -1|-2|actual )
+ -1 of do-disconnect endof
+ -2 of do-idle endof
+ ( actual )
+ reset-timer ( actual )
+ thbuf over bounds do i c@ >hbuf loop ( actual )
+ endcase
+ key-interrupt? if key? if key emit exit then then
+ again
+;
+
+
+\ builtin URLs
+\ this is essentially demo code
+
+hex
+headers
+
+\ support for the built-in URLs
+
+\ Creates return message for setenv
+: nice-message ( val$ var$ -- adr len )
+ collect( ( val$ var$ )
+ create-header ( val$ var$ )
+ " ROM Configuration Variable " type ( val$ var$ )
+ " <b>" type ( val$ var$ )
+ type ( val$ )
+ " </b>" type ( val$ )
+ " set to " type ( val$ )
+ " <b>" type ( val$ )
+ type-cr ( )
+ " </b>" type ( )
+ " <br> <br>" type-cr
+ create-footer
+ )collect
+;
+
+\ \ Creates return message for setenv
+\ : nice-message1 ( var$ -- adr len )
+\ collect( ( var$ )
+\ create-header ( var$ )
+\ " ROM Configuration Variable " type ( var$ )
+\ " <b>" type ( var$ )
+\ type ( )
+\ " </b>" type ( )
+\ " set to default value" type ( )
+\ " </b>" type ( )
+\ " <br> <br>" type-cr
+\ create-footer
+\ )collect
+\ ;
+
+\ HTTP strings have a "+" where blanks are suppsed to be. Just whack them.
+: fix-blanks ( adr len -- )
+ bounds ?do
+ i c@ [char] + = if bl i c! then
+ loop
+;
+
+\ HTTP strings mungle up the special characters. Instead of a "/" for
+\ example, you get "%2F". This routine looks for the "%" characters,
+\ extracts the ascii string after that, converts it to the real hex
+\ value and punches it back where the "%" was, then moves everything
+\ else to the left by two.
+: fixup-string ( adr len -- adr len' )
+ 2dup fix-blanks \ First whack the blanks into shape.
+ dup 3 < if exit then \ Cannot possibly have %xx.
+ 2dup 2- bounds ?do
+ i c@ [char] % = if
+ i 1+ 2 $number 0<> if ." Parsing error" unloop exit then
+ ( adr len b ) i c!
+ i 3 + ( adr len src )
+ i 1 + ( adr len src dst )
+ over 4 pick - ( adr len src dst #ok )
+ 3 pick swap - ( adr len src dst len )
+ move ( adr len )
+ 2- ( adr len' )
+ then
+ loop
+;
+
+also urls definitions
+
+: stop ( opt$ url$ -- httpd-stuff )
+ " abort" to pending-cmd
+ " Closing remote HTTP server" 1 " text/plain"
+;
+: reboot ( opt$ url$ -- httpd-stuff )
+ " bye" to pending-cmd
+ " Rebooting remote system" 1 " text/plain"
+;
+
+\ This is really demo code, not ready for primetime. We deal with some
+\ special cases with this code example. If a URL comes in as
+\ "rom-setconfig-tf", then we go look for some other stuff in the
+\ incomming request packet, reformat the whole wad into a "setenv"
+\ command and execute it. This "-tf" method looks at the first
+\ character of the incoming set string for "t" or "f" and then creates
+\ its own "true" or "false" to pass to the setenv command. Helps with
+\ people that can't spell. The second special is really a more general
+\ case inplementaion. rom-setconfig-string parses out the string that
+\ is passed in and sets the environment variable accordingly. Just
+\ another way to do it. Demo code after all. If the request URL has
+\ "rom-ok" in it, we treat the passed in data as a string that we just
+\ pass to the "ok" prompt, returning whatever we get back. Any other
+\ request that is prefeaced by "rom-" is assumed to be a method call, so
+\ we go look for an XT, then execute it, returning the data. Thus
+\ showing four possibilities of how one might interface to the ROM via
+\ HTTP.
+
+: rom-setconfig-tf ( opt$ url$ -- httpd-stuff )
+ \ OK, the option string will have what we need in it. We need to
+ \ extract what we need from it, run the setenv command and return
+ \ something nice to the user...
+ 2drop
+ hbuf swap move ( ) \ Re-use the hbuf XXX this is bad.
+ reset-hbuf-ptr
+ [char] = skip-til hbuf-adr ( adr )
+ [char] & skip-til hbuf-adr over - 1- ( var$ )
+ fixup-string ( var$' )
+ [char] = skip-til ( var$' adr )
+ hbuf-adr c@ ascii t = if
+ " true" else " false" ( var$' val$ )
+ then
+ 2swap 4dup ( val$ var$' val$ var$' )
+ collect( $setenv )collect ( val$ var$' adr len )
+ 2drop ( val$ var$' )
+ nice-message 1 " text/html"
+;
+
+: rom-setconfig-string ( opt$ url$ -- httpd-stuff )
+ \ OK, the option string will have what we need in it. We need to
+ \ extract what we need from it, run the setenv command and return
+ \ something nice to the user...
+ 2drop
+ hbuf swap dup >r move ( ) \ Re-use the hbuf
+ reset-hbuf-ptr
+ [char] = skip-til hbuf-adr ( adr )
+ [char] & skip-til hbuf-adr over - 1- ( var$ )
+ fixup-string ( var$' )
+ [char] = skip-til ( var$' )
+ hbuf-adr ( var$ val-adr )
+ hbuf - ( var$ count )
+ hbuf r> ( var$ count adr len )
+ rot /string ( var$ val$ )
+ fixup-string ( var$ val$ )
+ 2swap 4dup ( val$ var$' val$ var$' )
+ collect( $setenv )collect ( val$ var$' adr len )
+ 2drop ( val$ var$' )
+ nice-message 1 " text/html"
+;
+
+: rom-setdefault ( opt$ url$ -- httpd-stuff )
+ \ OK, the option string will have what we need in it. We need to
+ \ extract what we need from it, run the set-default command and return
+ \ something nice to the user...
+ 2drop
+ hbuf swap dup >r move ( ) \ Re-use the hbuf
+ reset-hbuf-ptr
+ [char] = skip-til hbuf-adr ( adr )
+ hbuf - hbuf r> rot /string ( var$ )
+ fixup-string 2dup ( var$' var$' )
+ collect(
+ create-header
+ create-pre
+ find-option if do-set-default then
+ (printenv)
+ create-endpre
+ create-footer
+ )collect ( adr len )
+ 1 " text/html"
+;
+
+: rom-restart ( opt$ url$ -- )
+ \ rom-restart?option_file=url&var=value
+ 2drop
+ hbuf swap dup >r move ( ) \ Re-use the hbuf
+ reset-hbuf-ptr
+ [char] = skip-til hbuf-adr ( adr )
+ [char] & skip-til hbuf-adr over - 1- ( url$ )
+ fixup-string ( url$' )
+
+ 2dup find-drop-in if ( url$ data$ )
+ 2over 2>r ( url$ data$ ) ( R: url$ )
+ preprocess-html ( data$' n )
+ 2r> presume-content-type ( data$ n type$ )
+ respond ( )
+ transaction-done ( )
+ else ( url$ )
+ 2drop
+ then
+
+ hbuf-adr [char] = skip-til ( var )
+ hbuf-adr over - 1- ( var$ )
+
+ hbuf-adr ( var$ val-adr )
+ hbuf - ( var$ count )
+ hbuf r> ( var$ count adr len )
+ rot /string ( var$ val$ )
+ fixup-string 2swap ( val$' var$ )
+ collect( $setenv )collect 2drop ( )
+
+ reset-all
+;
+
+\ command?here+.+cr plusses become blanks
+\ command?4+5+%2b+.+cr use %2b to get a plus
+\ note: the web page encodes the command string before sending it
+\ and sends command?command=here+.+cr
+: cmdeq ( -- $ ) " command=" ;
+: command ( opt$ url$ -- httpd-stuff )
+ 2drop
+ cmdeq 2over sindex 0= if
+ cmdeq nip /string
+ then
+ fixup-string ['] eval collect-data 1 " text/html"
+;
+
+previous definitions
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Added: ofw/inetv6/icmpecho.fth
===================================================================
--- ofw/inetv6/icmpecho.fth (rev 0)
+++ ofw/inetv6/icmpecho.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,70 @@
+\ See license at end of file
+purpose: Internet Control Message Protocol version 6 (ICMPv6) echo message handlers
+
+: exchange-byte ( adr1 adr2 -- )
+ over c@ over c@ ( adr1 adr2 byte1 byte2 )
+ swap rot ( adr1 byte2 byte1 adr2 )
+ c! ( adr1 byte2 )
+ swap c! ( )
+;
+: exchange-bytes ( adr1 adr2 len -- )
+ 0 ?do over i + over i + exchange-byte loop 2drop
+;
+: exchange-mac ( adr len -- )
+ drop dup /e + /e exchange-bytes
+;
+: exchange-ipsv6 ( adr len -- ) drop 8 + dup /ipv6 + /ipv6 exchange-bytes ;
+: change-typev6 ( adr len -- ) drop d# 129 swap xc! ;
+
+: recompute-icmpv6-checksum ( icmp-adr,len ip-adr,len -- )
+ 2swap dup 1 and if ( ip-adr,len icmp-adr,len )
+ 2dup + 0 swap c! 1+ ( ip-adr,len icmp-adr,len' )
+ then ( ip-adr,len icmp-adr,len' )
+ 2swap drop 8 + dup /ipv6 + ( icmp-adr,len ipv6-1 ipv6-2 )
+ compute-icmpv6-checksum ( )
+;
+
+: handle-echo-req ( icmp-adr,len -- )
+ \ XXX For now, support simplistic IPv6 header + ICMPv6 echo packet.
+ 2dup /ipv6-header negate /string ( icmp-adr,len ip-adr,len )
+ 2dup /ether-header negate /string ( icmp-adr,len ip-adr,len en-adr,len )
+ bootnet-debug if
+ ." Echo request from: " over /e + .enaddr cr
+ then
+ 2dup exchange-mac -drot ( en-adr,len icmp-adr,len ip-adr,len )
+ 2dup exchange-ipsv6 ( en-adr,len icmp-adr,len ip-adr,len )
+ 2over change-typev6 ( en-adr,len icmp-adr,len ip-adr,len )
+ recompute-icmpv6-checksum ( en-adr,len )
+ tuck " write" $call-parent ( len actual )
+ <> if ." Network transmit error" cr then
+;
+
+: handle-echo-reply ( adr len -- ) 2drop ;
+
+headers
+
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
+
+
Added: ofw/inetv6/icmperr.fth
===================================================================
--- ofw/inetv6/icmperr.fth (rev 0)
+++ ofw/inetv6/icmperr.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,89 @@
+\ See license at end of file
+purpose: Internet Control Message Protocol version 6 (ICMPv6) error message handlers
+
+: .icmpv6-unknown-err ( type -- )
+ ." Unknown error message type: " u.
+;
+
+: .icmpv6-dest-err ( -- )
+ icmp-code c@ case
+ 0 of ." No route to destination" endof
+ 1 of ." Communication with destination administratively prohibited" endof
+ 2 of ." Beyond scope of source address" endof
+ 3 of ." Address unreachable" endof
+ 4 of ." Port unreachable" endof
+ 5 of ." Source address failed ingress/egress policy" endof
+ 6 of ." Eject route to destination" endof
+ ( default ) ." Unknown destination unreachable code: " dup u.
+ endcase
+;
+
+: .icmpv6-size-err ( -- )
+ ." Packet too big. MTU of next hop link is: " icmp-mtu xl@ u.
+;
+
+: .icmpv6-time-err ( -- )
+ icmp-code c@ case
+ 0 of ." Hop limit exceeded in transit" endof
+ 1 of ." Fragment reassembly time exceeded" endof
+ ( default ) ." Unknown time exceeded code: " dup u.
+ endcase
+;
+
+: .icmpv6-arg-err ( -- )
+ icmp-code c@ case
+ 0 of ." Erroneous header field encountered" endof
+ 1 of ." Unrecognized next header type encountered" endof
+ 2 of ." Unrecognized IPv6 option encountered" endof
+ ( default ) ." Unkown parameter problem code: " dup u.
+ endcase
+;
+
+: .icmpv6-err ( -- )
+ ." ICMPv6: "
+ icmp-type c@
+ case
+ 1 of .icmpv6-dest-err endof
+ 2 of .icmpv6-size-err endof
+ 3 of .icmpv6-time-err endof
+ 4 of .icmpv6-arg-err endof
+ ( default ) .icmpv6-unknown-err
+ endcase
+ cr
+;
+
+: handle-icmpv6-err ( adr len -- )
+ over set-struct ( adr len )
+ .icmpv6-err ( adr len )
+ icmp-code c@ -rot ( code adr len )
+ icmp-type c@ -rot ( code type adr len )
+ icmpv6-err-callback-xt execute
+;
+
+headers
+
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
+
+
Added: ofw/inetv6/icmpinfo.fth
===================================================================
--- ofw/inetv6/icmpinfo.fth (rev 0)
+++ ofw/inetv6/icmpinfo.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,109 @@
+\ See license at end of file
+purpose: Internet Control Message Protocol version 6 (ICMPv6) info message handlers
+
+\ ************************* Multicast Group Management *************************
+: handle-mc-query ( adr len -- ) 2drop ; \ Multicast listener query
+: handle-mc-report ( adr len -- ) 2drop ; \ Multicast listener report
+: handle-mc-report2 ( adr len -- ) 2drop ; \ Version 2 multicast listener report
+: handle-mc-done ( adr len -- ) 2drop ; \ Multicast done
+
+\ ****************** Neighbor Discovery and Autoconfiguration ******************
+: handle-router-sol ( adr len -- ) 2drop ; \ Router solicitation
+: handle-router-ad ( adr len -- ) 2drop ; \ Router advertisement
+
+: handle-mc-router-ad ( adr len -- ) 2drop ; \ Multicast router advertisement
+: handle-mc-router-sol ( adr len -- ) 2drop ; \ Multicast router solicitation
+: handle-mc-router-term ( adr len -- ) 2drop ; \ Multicast router termination
+
+: send-neigh-sol ( -- )
+ d# 24 allocate-icmpv6 set-struct \ Dest IPv6 + one option
+ d# 135 icmp-type xc!
+ 0 icmp-code xc!
+ 0 icmp-flags xl!
+ his-ipv6-addr icmp-data copy-ipv6-addr
+ h# 101 icmp-data /ipv6 + xw! \ Option type 1 (source mac addr)
+ \ Length (in 8 octels)
+ my-en-addr icmp-data /ipv6 + 2 + copy-ipv6-addr
+ hop-limit >r h# ff to hop-limit \ Save and change hop-limit
+ the-struct d# 24 2dup send-mc-icmpv6-packet
+ free-icmpv6
+ r> to hop-limit \ Restore hop-limit
+;
+
+: send-neigh-ad ( solicited? -- )
+ d# 24 allocate-icmpv6 set-struct \ Dest IPv6 + one option
+
+ d# 136 icmp-type xc!
+ 0 icmp-code xc!
+ h# 40 and h# 20 or icmp-flags xl! \ Flags = (un)solicited, override
+ my-ipv6-addr icmp-data copy-ipv6-addr
+ h# 201 icmp-data /ipv6 + xw! \ Option type 2 (target mac addr)
+ \ Length (in 8 octels)
+ my-en-addr icmp-data /ipv6 + 2 + copy-ipv6-addr
+
+ hop-limit >r h# ff to hop-limit \ Save and change hop-limit
+ the-struct d# 24 2dup send-icmpv6-packet
+ free-icmpv6
+ r> to hop-limit \ Restore hop-limit
+;
+
+: handle-neigh-sol ( adr len -- ) \ Neighbor solicitation
+ \ XXX Verify hop limit is 255.
+ dup d# 24 < if 2drop exit then
+ bootnet-debug if
+ ." Neighbor solicitation from MAC: " over d# 26 + .enaddr cr
+ then
+ over /icmp-header + my-ipv6-addr ipv6= not if ." Not for me" cr 2drop exit then
+ 2drop
+ \ XXX Send Neighbor Advertisement
+ true send-neigh-ad
+;
+
+: handle-neigh-ad ( adr len -- ) 2drop ; \ Neighbor advertisement
+
+: handle-inv-neigh-sol ( adr len -- ) 2drop ; \ Inverse neighbor discovery solicitation
+: handle-inv-neigh-ad ( adr len -- ) 2drop ; \ Inverse neighbor discovery advertisement
+
+: handle-redirect-msg ( adr len -- ) 2drop ; \ Redirect message
+
+: handle-cert-sol ( adr len -- ) 2drop ; \ Certification path solicitation
+: handle-cert-ad ( adr len -- ) 2drop ; \ Certification path advertisement
+
+: handle-router-renum ( adr len -- ) 2drop ; \ Router renumbering
+
+: handle-info-query ( adr len -- ) 2drop ; \ ICMP node information query
+: handle-info ( adr len -- ) 2drop ; \ ICMP node information response
+
+\ ******************************** Mobile IPv6 *********************************
+: handle-ha-request ( adr len -- ) 2drop ; \ ICMP home agent address discovery request
+: handle-ha-reply ( adr len -- ) 2drop ; \ ICMP home agent address discovery reply
+: handle-mobile-sol ( adr len -- ) 2drop ; \ ICMP mobile prefix solicitation
+: handle-mobile-ad ( adr len -- ) 2drop ; \ ICMP mobile prefix advertisement
+
+headers
+
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
+
+
Added: ofw/inetv6/icmpv6.fth
===================================================================
--- ofw/inetv6/icmpv6.fth (rev 0)
+++ ofw/inetv6/icmpv6.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,136 @@
+\ See license at end of file
+purpose: Internet Control Message Protocol version 6 (ICMPv6)
+
+' 4drop instance value icmpv6-err-callback-xt ( code type adr len -- )
+' 2drop instance value icmpv6-info-callback-xt ( adr len -- )
+: set-icmpv6-err-callback ( xt -- ) to icmpv6-err-callback-xt ;
+: set-icmpv6-info-callback ( xt -- ) to icmpv6-info-callback-xt ;
+
+struct ( ICMP )
+ /c sfield icmp-type
+ /c sfield icmp-code
+ /w sfield icmp-checksum
+ 0 sfield icmp-flags
+ 0 sfield icmp-mtu
+ /w sfield icmp-id
+ /w sfield icmp-seq
+ 0 sfield icmp-data
+constant /icmp-header
+
+0 instance value icmpv6-packet
+0 instance value /icmpv6-packet
+
+: allocate-icmpv6 ( len -- adr ) /icmp-header + allocate-ipv6 ;
+: free-icmpv6 ( adr len -- ) /icmp-header + free-ipv6 ;
+
+variable icmp-temp
+: pseudo-hdr-checksum ( len ipv6-1 ipv6-2 -- chksum )
+ 0 swap /ipv6 (oc-checksum) ( len ipv6-1 chksum )
+ swap /ipv6 (oc-checksum) ( len chksum' )
+ swap icmp-temp be-l! ( chksum )
+ icmp-temp /l (oc-checksum) ( chksum' )
+ IP_HDR_ICMPV6 icmp-temp be-l! ( chksum )
+ icmp-temp /l (oc-checksum) ( chksum' )
+;
+
+: compute-icmpv6-checksum ( adr len ipv6-1 ipv6-2 -- )
+ 2>r dup 2r> ( adr len len ipv6-1 ipv6-2 )
+ pseudo-hdr-checksum >r ( adr len ) ( R: chksum )
+ over set-struct ( adr len ) ( R: chksum )
+ 0 icmp-checksum be-w! ( adr len ) ( R: chksum ) \ Zap ICMP checksum
+ r> -rot oc-checksum ( sum )
+ icmp-checksum be-w! ( )
+;
+
+: send-icmpv6-packet ( adr len -- ) \ len = length of ICMP data (does not include header)
+ /icmp-header + 2dup his-ipv6-addr my-ipv6-addr compute-icmpv6-checksum
+ IP_HDR_ICMPV6 send-ipv6-packet
+;
+
+/ipv6 buffer: his-ipv6-temp
+: send-mc-icmpv6-packet ( adr len -- ) \ Send to his multicast IPv6 address
+ his-ipv6-addr his-ipv6-temp copy-ipv6-addr
+ his-mc-ipv6-addr his-ipv6-addr copy-ipv6-addr
+ send-icmpv6-packet
+ his-ipv6-temp his-ipv6-addr copy-ipv6-addr
+;
+
+\ ICMPv6 error handlers (icmp-type: 0-127)
+fload ${BP}/ofw/inetv6/icmperr.fth \ Error handling routines
+
+\ ICMPv6 info handlers (icmp-type: 128-255)
+fload ${BP}/ofw/inetv6/icmpecho.fth \ Echo handling routines
+fload ${BP}/ofw/inetv6/icmpinfo.fth \ Other info message handling routines
+
+decimal
+: handle-icmpv6-info ( adr len -- )
+ over c@ case
+ 128 of handle-echo-req endof \ Echo request
+ 129 of handle-echo-reply endof \ Echo reply
+ 130 of handle-mc-query endof \ Multicast listener query
+ 131 of handle-mc-report endof \ Multicast listener report
+ 132 of handle-mc-done endof \ Multicast done
+ 133 of handle-router-sol endof \ Router solicitation
+ 134 of handle-router-ad endof \ Router advertisement
+ 135 of handle-neigh-sol endof \ Neighbor solicitation
+ 136 of handle-neigh-ad endof \ Neighbor advertisement
+ 137 of handle-redirect-msg endof \ Redirect message
+ 138 of handle-router-renum endof \ Router renumbering
+ 139 of handle-info-query endof \ ICMP node information query
+ 140 of handle-info endof \ ICMP node information response
+ 141 of handle-inv-neigh-sol endof \ Inverse neighbor discovery solicitation
+ 142 of handle-inv-neigh-ad endof \ Inverse neighbor discovery advertisement
+ 143 of handle-mc-report2 endof \ Version 2 multicast listener report
+ 144 of handle-ha-request endof \ ICMP home agent address discovery request
+ 145 of handle-ha-reply endof \ ICMP home agent address discovery reply
+ 146 of handle-mobile-sol endof \ ICMP mobile prefix solicitation
+ 147 of handle-mobile-ad endof \ ICMP mobile prefix advertisement
+ 148 of handle-cert-sol endof \ Certification path solicitation
+ 149 of handle-cert-ad endof \ Certification path advertisement
+ 151 of handle-mc-router-ad endof \ Multicast router advertisement
+ 152 of handle-mc-router-sol endof \ Multicast router solicitation
+ 153 of handle-mc-router-term endof \ Multicast router termination
+ ( default ) nip nip
+ endcase
+;
+
+hex
+
+: (handle-icmpv6) ( adr len protocol -- )
+ IP_HDR_ICMPV6 <> if 2drop exit then \ Not an ICMPv6 packet
+ dup if \ Nonzero length
+ \ XXX verify checksum
+ the-struct >r \ Save the-struct
+ over c@ h# 80 and if handle-icmpv6-info else handle-icmpv6-err then
+ r> set-struct \ Restore the-struct
+ else
+ 2drop
+ then
+;
+' (handle-icmpv6) to handle-icmpv6
+
+headers
+
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Added: ofw/inetv6/ip.fth
===================================================================
--- ofw/inetv6/ip.fth (rev 0)
+++ ofw/inetv6/ip.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,234 @@
+\ See license at end of file
+purpose: Simple Internet Protocol (IP) implementation
+
+
+\ Internet protocol (IP).
+
+decimal
+
+4 constant /i \ Bytes per IP address
+
+: copy-ip-addr ( src dst -- ) /i move ;
+
+/i buffer: my-ip-addr
+/i buffer: subnetmask
+
+headerless
+\ Give the net up to 4 seconds to respond to packets
+instance variable timeout-msecs d# 4000 timeout-msecs !
+
+struct ( ip-header )
+ 1 sfield ip-version \ Actually, this is VVVVLLLL, where LLLL is the
+ \ header length in 32-bit words.
+ 1 sfield ip-service
+ 2 sfield ip-length
+ 2 sfield ip-id
+ 2 sfield ip-fragment
+ 1 sfield ip-ttl
+ 1 sfield ip-protocol
+ 2 sfield ip-checksum
+ /i sfield ip-source-addr
+ /i sfield ip-dest-addr
+\ It is possible to have a variable-length list of options here at the end.
+\ Options contain information like source routing lists, return route lists,
+\ and error reports. The low nibble of the ip-version byte gives the length
+\ of the header including the options.
+constant /ip-header
+
+\ These things hardly ever change, so we make them variables
+instance variable ttl d# 123 ttl !
+instance variable ip-sequence
+d# 256 buffer: 'domain-name
+headers
+/i buffer: his-ip-addr
+/i buffer: name-server-ip
+' 'domain-name " domain-name" chosen-string
+
+headerless
+
+decimal
+h# 800 constant IP_TYPE
+
+instance variable total-length
+
+instance variable bufptr
+: -buf, ( c -- ) -1 bufptr +! bufptr @ c! ;
+
+/i buffer: broadcast-ip-addr
+
+create def-broadcast-ip h# ff c, h# ff c, h# ff c, h# ff c,
+create unknown-ip-addr h# 00 c, h# 00 c, h# 00 c, h# 00 c,
+
+: ip= ( ip-addr1 ip-addr2 -- flag ) /i comp 0= ;
+
+: unknown-ip-addr? ( adr-buf -- flag ) unknown-ip-addr ip= ;
+: known? ( adr-buf -- flag ) unknown-ip-addr? 0= ;
+
+\ Offsets 0,1,2 into this array yield default netmasks for classes C,B,A
+create default-netmasks d# 255 c, d# 255 c, d# 255 c, 0 c, 0 c, 0 c,
+
+: default-netmask ( -- 'netmask )
+ default-netmasks ( 'netmask-c )
+ my-ip-addr known? if ( 'netmask-c )
+ my-ip-addr c@ h# 80 and 0= if 2+ exit then ( 'netmask-c )
+ my-ip-addr c@ h# 40 and 0= if 1+ exit then ( 'netmask-c )
+ then ( 'netmask-c )
+;
+
+\ either h# ffffffff or h# 0 is broadcast ip addr
+: broadcast-ip-addr? ( adr-buf -- flag )
+ dup broadcast-ip-addr ip= swap unknown-ip-addr? or
+;
+
+: netmask ( -- 'ip )
+ subnetmask unknown-ip-addr? if default-netmask else subnetmask then
+;
+[ifndef] c at +
+: c at + ( adr -- adr' b ) dup 1+ swap c@ ;
+[then]
+: ip-prefix=? ( ip1 ip2 -- flag )
+ netmask /i 0 do ( ip1 ip2 nm )
+ rot c at + >r ( ip2 nm ip1' r: b1 )
+ rot c at + >r ( nm ip1' ip2' r: b1 b2 )
+ rot c at + ( ip1' ip2' nm' bn r: b1 b2 )
+ dup r> and swap r> and ( ip1 ip2 nm b2' b1' )
+ <> if 3drop false unloop exit then ( ip1 ip2 nm )
+ loop ( ip1 ip2 nm )
+ 3drop true
+;
+
+/i buffer: router-ip-addr
+: use-router? ( -- flag ) router-ip-addr known? ;
+
+/i buffer: server-ip-addr
+: use-server? ( -- flag ) server-ip-addr known? ;
+
+
+: dec-byte ( n -- ) u#s ascii . hold drop ;
+: (.ipaddr) ( buf -- )
+ push-decimal ( buf )
+ <# dup /i + 1- do i c@ dec-byte -1 +loop 0 u#> 1 /string ( adr len )
+ pop-base
+ type space
+;
+: .ipaddr ( buf -- )
+ dup unknown-ip-addr? if drop ." none" exit then ( buf )
+ dup broadcast-ip-addr? if drop ." broadcast" exit then ( buf )
+ (.ipaddr)
+;
+partial-headers
+: indent ( -- ) bootnet-debug if ." " then ;
+headerless
+: .my-ip-addr ( -- ) ." My IP: " my-ip-addr .ipaddr ;
+: .his-ip-addr ( -- ) ." His IP: " his-ip-addr .ipaddr ;
+
+0 instance value last-ip-packet
+
+headers
+: set-dest-ip ( buf -- )
+ dup his-ip-addr ip= if
+ drop
+ else
+ his-ip-addr copy-ip-addr
+ unlock-link-addr
+ then
+;
+
+: lock-ip-address ( -- )
+ the-struct >r last-ip-packet set-struct
+ \ Don't change his-ip-addr for booting over gateway
+ use-router? if \ booting over a gateway.
+ bootnet-debug if indent ." Using router" cr then
+ else
+ \ In case of direct booting, i.e. booting over specified server
+ \ don't change his addresses
+ use-server? 0= if ip-source-addr set-dest-ip then
+ lock-link-addr
+ then
+ bootnet-debug if indent .his-link-addr .his-ip-addr then
+ r> set-struct
+;
+: unlock-ip-address ( -- )
+ unknown-ip-addr set-dest-ip
+ unknown-ip-addr server-ip-addr copy-ip-addr
+;
+headerless
+
+\ This is a hook for handling IP packets addressed to us that are
+\ of a different type than the expected one. This could be used
+\ to handle "behind the scenes" things like ICMP if necessary.
+defer handle-ip ( adr len protocol -- )
+defer handle-other-ip ( adr len -- )
+headers
+: (handle-ip) ( adr len protocol -- )
+ bootnet-debug if
+ dup ." (Discarding IP packet of protocol " u. ." )" cr
+ then
+ 3drop
+;
+' (handle-ip) is handle-ip
+
+: (handle-other-ip) ( adr len -- )
+ bootnet-debug if
+ ." (Discarding IP packet because of IP address mismatch)" cr
+ then
+ 2drop
+;
+' (handle-other-ip) is handle-other-ip
+headerless
+
+: ip-payload ( len -- adr' len' )
+ drop ip-length xw@ ip-version c@ h# f and /l* payload
+;
+
+: ip-addr-match? ( -- flag )
+ \ If we know the server's IP address (e.g. the user specified one, or
+ \ we chose one from a RARP or BOOTP reply, or we locked onto one that
+ \ responded to a TFTP broadcast), then we silently discard IP packets
+ \ from other hosts.
+ his-ip-addr broadcast-ip-addr? 0= if
+ his-ip-addr ip-source-addr ip= 0= if false exit then
+ then
+
+ \ Accept IP broadcast packets
+ ip-dest-addr broadcast-ip-addr? if true exit then
+
+ \ If we don't know our own IP address yet, we accept every IP packet
+ my-ip-addr unknown-ip-addr? if true exit then
+
+ \ Otherwise, we know our IP address, so we filter out packets addressed
+ \ to other destinations.
+ my-ip-addr ip-dest-addr ip=
+;
+
+: allocate-ip ( payload-len -- payload-adr )
+ /ip-header + allocate-ethernet /ip-header +
+;
+: free-ip ( payload-adr payload-len -- )
+ /ip-header negate /string free-ethernet
+;
+
+headers
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Added: ofw/inetv6/ipfr.fth
===================================================================
--- ofw/inetv6/ipfr.fth (rev 0)
+++ ofw/inetv6/ipfr.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,390 @@
+\ See license at end of file
+purpose: Internet Protocol (IP) fragmentation/reassembly implementation
+
+headers
+: max-ip-payload ( -- n )
+ max-link-payload /ip-header -
+ h# ffff.fff8 and
+;
+
+headerless
+: ihl ( -- len ) ip-version c@ h# f and /l* ;
+
+: (send-ip-packet) ( adr len protocol fragment -- )
+ 3 pick /ip-header - set-struct ( adr len protocol fragment )
+ ( fragment ) ip-fragment xw! ( adr len protocol )
+ ( protocol ) ip-protocol xc! ( adr len )
+ swap drop ( len )
+ h# 45 ip-version xc! ( 45 is ip version 4, length 5 longwords )
+ 0 ip-service xc!
+ ( len ) /ip-header + dup ip-length xw! ( ip-len )
+ ip-sequence @ ip-id xw!
+ ttl @ ip-ttl xc!
+ 0 ip-checksum xw!
+ my-ip-addr ip-source-addr copy-ip-addr
+ his-ip-addr ip-dest-addr copy-ip-addr
+ 0 the-struct /ip-header oc-checksum ip-checksum xw!
+ ( ip-len )
+ the-struct swap ( ip-adr ip-len )
+
+ ip-dest-addr IP_TYPE send-link-packet ( )
+;
+
+0 value oaddr \ original data packet address
+0 value olen \ original data packet length
+0 value oprotocol \ original protocol
+0 value fadr \ fragment address
+
+: send-ip-fragment ( offset -- )
+ >r fadr ( fadr )
+ olen r@ - max-ip-payload min ( fadr flen )
+ 2dup oaddr r@ + -rot move ( fadr flen )
+ oprotocol ( fadr flen protocol )
+ r@ 8 / ( fadr flen protocol fo )
+ r> max-ip-payload + olen < if h# 2000 or then ( fadr flen protocol fo )
+ (send-ip-packet) ( )
+;
+
+: send-ip-packet ( adr len protocol -- )
+ 1 ip-sequence +!
+ over max-ip-payload /mod swap 0> if 1+ then ( adr len protocol #frags )
+ dup 1 = if
+ drop 0 (send-ip-packet)
+ else
+ >r to oprotocol to olen to oaddr r>
+ max-ip-payload allocate-ip to fadr
+ 0 do
+ i max-ip-payload * send-ip-fragment
+ loop
+ fadr max-ip-payload free-ip
+ then
+;
+
+list: iplist
+listnode
+ /n field >ip-dghead \ head of list of datagrams
+ /n field >ip-dgtail \ tail of list of datagrams
+ /n field >ip-timer \ timeout value in ms
+ /n field >ip-len \ total length of original data
+ /n field >ip-dg0 \ pointer to datagram with fragment offset 0
+ /n field >ip-rangelist \ pointer to range info
+ /i field >ip-source-addr
+ /i field >ip-dest-addr
+ 2 field >ip-id
+ 1 field >ip-protocol
+nodetype: ipnode \ list of reassembly in process
+
+0 iplist !
+0 ipnode !
+
+struct
+ /n field >dg-adr
+ /n field >dg-len
+ /n field >dg-next
+constant /dglist
+
+struct
+ /n field >rl-begin
+ /n field >rl-end
+ /n field >rl-next
+ /n field >rl-prev
+constant /rangelist
+
+0 instance value reassembled-adr
+0 instance value reassembled-len \ ihl + data len
+d# 15 d# 1000 * constant tlb \ 15 seconds for initial timer setting
+
+: ip-id=? ( node-adr -- id=? )
+ >r
+ r@ >ip-id xw@ ip-id xw@ = dup if
+ drop r@ >ip-protocol c@ ip-protocol c@ = dup if
+ drop r@ >ip-source-addr ip-source-addr ip= dup if
+ drop r@ >ip-dest-addr ip-dest-addr ip=
+ then then then
+ r> drop
+;
+
+: find-ip? ( -- prev-node this-node | 0 )
+ iplist ['] ip-id=? find-node
+;
+
+: alloc-ip ( last-node -- node )
+ ipnode allocate-node tuck swap insert-after
+ >r
+ 0 r@ >ip-dghead !
+ 0 r@ >ip-dgtail !
+ get-msecs tlb + r@ >ip-timer !
+ 0 r@ >ip-len !
+ 0 r@ >ip-dg0 !
+ 0 r@ >ip-rangelist !
+ ip-source-addr r@ >ip-source-addr copy-ip-addr
+ ip-dest-addr r@ >ip-dest-addr copy-ip-addr
+ ip-id xw@ r@ >ip-id xw!
+ ip-protocol c@ r@ >ip-protocol xc!
+ r>
+;
+
+: save-ip ( node -- )
+ >r
+ ip-length xw@ dup alloc-mem ( len this-dg )
+ 2dup swap the-struct -rot move ( len this-dg )
+ ip-fragment xw@ h# 1fff and 0= if
+ dup r@ >ip-dg0 !
+ then
+ /dglist alloc-mem ( len this-dg this-dglist )
+ tuck >dg-adr ! ( len this-dglist )
+ tuck >dg-len ! ( this-dglist )
+ 0 over >dg-next ! ( this-dglist )
+ r@ >ip-dghead @ 0= if dup r@ >ip-dghead ! then ( this-dglist )
+ r@ >ip-dgtail @ ?dup 0<> if >dg-next over swap ! then ( this-dglist )
+ r> >ip-dgtail ! ( )
+;
+
+: reset-timer ( node -- )
+ >ip-timer dup @ get-msecs ip-ttl c@ d# 1000 * + max swap !
+;
+
+: free-dg ( dg -- )
+ begin ?dup while ( 'dg )
+ dup >dg-adr @ over >dg-len @ free-mem ( 'dg )
+ dup >dg-next @ ( 'dg 'dg-next )
+ swap /dglist free-mem ( 'dg-nest )
+ repeat ( )
+;
+
+: free-rangelist ( rl -- )
+ begin ?dup while ( rl )
+ dup >rl-next @ swap /rangelist free-mem ( rl-next )
+ repeat ( )
+;
+
+: free-ipnode ( prev -- )
+ delete-after
+ dup ipnode free-node
+ dup >ip-dghead @ free-dg
+ >ip-rangelist @ free-rangelist
+;
+
+: free-iplist ( -- )
+ find-ip? if free-ipnode else drop then
+;
+
+: ip-timeout? ( node -- flag )
+ >ip-timer @ get-msecs <=
+;
+
+: process-timeout? ( -- flag )
+ iplist ['] ip-timeout? find-node if free-ipnode true else drop false then
+;
+
+: update-len ( node -- )
+ ip-fragment xw@ h# 2000 and 0= if
+ ip-length xw@ ihl -
+ ip-fragment xw@ h# 1fff and 8 * +
+ swap >ip-len !
+ else
+ drop
+ then
+;
+
+0 value rlb
+0 value rle
+0 value last-rl
+
+: create-rangelist ( -- rl )
+ /rangelist alloc-mem ( rl )
+ rle over >rl-end ! ( rl )
+ rlb over >rl-begin ! ( rl )
+;
+
+: insert-before-rangelist ( node rl -- )
+ create-rangelist >r ( node rl )
+ dup r@ >rl-next ! ( node rl )
+ dup >rl-prev @ dup r@ >rl-prev ! ( node rl rl-prev )
+ ?dup 0<> if >rl-next r@ swap ! then ( node rl )
+ r@ over >rl-prev ! ( node rl )
+ r> -rot ( new node rl )
+ over >ip-rangelist @ = if >ip-rangelist ! else 2drop then
+;
+
+: insert-endof-rangelist ( node rl -- )
+ create-rangelist ( node rl new )
+ 0 over >rl-next ! ( node rl new )
+ 2dup >rl-prev ! ( node rl new )
+ -rot tuck ( new rl node rl )
+ 0= if nip >ip-rangelist ! else drop >rl-next ! then
+;
+
+\ New range = b:e
+\ Current node = x:y
+\ if e<x-1, add node to front and exit
+\ if b>y+1, goto examine next node
+\ if b<x, x=b
+\ if e>y, y=e and exit
+\ if all the nodes have been examined, add node to end and exit
+\
+: (update-rangelist) ( ofs len node -- )
+ -rot over + 1- to rle to rlb ( node )
+ 0 to last-rl ( node )
+ dup >ip-rangelist @ ( node rl )
+ begin ?dup while
+ >r ( node )
+ rle r@ >rl-begin @ 1- < if r> insert-before-rangelist exit then
+ rlb r@ >rl-end @ 1+ <= if ( node )
+ rlb r@ >rl-begin @ < if rlb r@ >rl-begin ! then
+ rle r@ >rl-end @ > if rle r@ >rl-end ! then
+ r> 2drop
+ exit
+ then
+ r@ to last-rl ( node )
+ r> >rl-next @ ( node rl )
+ repeat ( node )
+ last-rl insert-endof-rangelist
+;
+
+: update-rangelist ( node -- )
+ ip-fragment xw@ h# 1fff and 8 * ( node ofs )
+ ip-length xw@ ihl - ( node ofs len )
+ rot (update-rangelist)
+;
+
+: rl-complete? ( rl -- complete? )
+ 0 swap ( 0 rl )
+ begin ( e rl )
+ 2dup >rl-begin @ 1- < ( e rl gap? )
+ if 2drop false exit then ( e rl )
+ dup >rl-end @ rot max swap ( e' rl )
+ >rl-next @ ?dup 0= ( e' rl-next )
+ until ( e' )
+ drop true
+;
+
+: ip-done? ( node -- done? )
+ dup >ip-len @ 0= if
+ drop false
+ else
+ >ip-rangelist @ rl-complete?
+ then
+;
+
+: (reassemble-ip) ( adr dg -- )
+ the-struct >r
+ begin ?dup while ( adr dg )
+ 2dup >dg-adr @ set-struct ( adr dg adr )
+ ip-fragment xw@ h# 1fff and 8 * + ( adr dg ofs )
+ ihl dup ( adr dg ofs ihl ihl )
+ ip-length xw@ swap - ( adr dg ofs ihl len )
+ swap the-struct + -rot move ( adr dg )
+ >dg-next @ ( adr dg-next )
+ repeat ( adr )
+ drop r> set-struct
+ reassembled-len ip-length xw!
+ 0 ip-fragment xw!
+ 0 ip-checksum xw!
+ 0 the-struct ihl oc-checksum ip-checksum xw!
+;
+
+: reassemble-ip ( node -- ip-adr,len )
+ >r
+ r@ >ip-len @ ( dlen )
+ r@ >ip-dg0 @ set-struct ihl tuck + ( ihl rlen )
+ dup to reassembled-len ( ihl rlen )
+ alloc-mem to reassembled-adr ( ihl )
+ r@ >ip-dg0 @ over reassembled-adr swap move ( ihl )
+ reassembled-adr dup set-struct + ( content-adr )
+ r> >ip-dghead @ (reassemble-ip) ( )
+ reassembled-adr reassembled-len ( ip-adr,len )
+ free-iplist
+;
+
+: process-datagram ( node -- false | ip-adr,len true)
+ dup save-ip ( node )
+ dup update-len ( node )
+ dup update-rangelist ( node )
+ dup ip-done? if ( node )
+ reassemble-ip ( ip-adr,len )
+ true ( ip-adr,len true )
+ else ( node )
+ reset-timer ( )
+ false ( false )
+ then
+;
+
+: process-done-ip ( -- )
+ reassembled-len 0> if
+ reassembled-adr reassembled-len free-mem
+ 0 to reassembled-adr 0 to reassembled-len
+ then
+;
+
+: process-ipv4-packet ( adr len type -- [len] flag )
+ rot ( len type adr )
+ dup set-struct to last-ip-packet ( len type )
+ ip-addr-match? if ( len type )
+ ip-protocol c@ = ( len flag )
+ dup 0= if swap ip-payload ip-protocol c@ handle-ip then
+ else ( len type )
+ drop ip-payload handle-other-ip ( )
+ false \ Discard other's packets ( false )
+ then ( [len] flag )
+
+ if ( len )
+ ip-fragment xw@ h# 3fff and 0= if
+ free-iplist
+ true ( true )
+ else
+ drop
+ find-ip? ?dup if nip else alloc-ip then
+ process-datagram
+ if swap to last-ip-packet true else false then
+ then ( flag )
+ else ( )
+ false ( false )
+ then ( [len] flag )
+;
+
+: receive-ip-packet ( type -- true | contents-adr,len false )
+ process-done-ip
+
+ begin ( type )
+ IP_TYPE receive-ethernet-packet ( type [ip-adr,len] flag )
+ if drop process-timeout? drop true exit then
+
+ over ipv4? if
+ 2 pick process-ipv4-packet ( type [len] flag )
+ else
+ false ( type false )
+ then
+
+ ?dup 0= if ( type [len] flag )
+ process-timeout? if drop true exit then
+ false
+ then
+ until ( type len )
+
+ nip ip-payload false ( contents-adr,len false )
+;
+headers
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Added: ofw/inetv6/ipfrv6.fth
===================================================================
--- ofw/inetv6/ipfrv6.fth (rev 0)
+++ ofw/inetv6/ipfrv6.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,205 @@
+\ See license at end of file
+purpose: Internet Protocol version 6 (IPv6) fragmentation/reassembly implementation
+
+headerless
+
+d# 0 constant IP_HDR_HOP \ Hop-by-hop option
+d# 1 constant IP_HDR_ICMPV4 \ Internet control message protocol - IPv4
+d# 2 constant IP_HDR_IGMPV4 \ Internet group management protocol - IPv4
+d# 4 constant IP_HDR_IPV4
+d# 6 constant IP_HDR_TCP
+d# 8 constant IP_HDR_EGP \ Exterior gateway protocol
+d# 9 constant IP_HDR_IGP \ Cisco private interior gateway
+d# 17 constant IP_HDR_UDP
+d# 41 constant IP_HDR_IPV6
+d# 43 constant IP_HDR_ROUTING \ Routing header
+d# 44 constant IP_HDR_FRAGMENT
+d# 45 constant IP_HDR_IDRP \ Interdomain routing protocol
+d# 46 constant IP_HDR_RSVP \ Resource reservation protocol
+d# 47 constant IP_HDR_GRE \ General routing encapsulation
+d# 50 constant IP_HDR_SECURE \ Encrypted security payload
+d# 51 constant IP_HDR_AUTHEN \ Authentication
+d# 58 constant IP_HDR_ICMPV6
+d# 59 constant IP_HDR_NONE \ No next header
+d# 60 constant IP_HDR_DEST \ Destination options
+d# 88 constant IP_HDR_EIGRP
+d# 89 constant IP_HDR_OSPF
+d# 108 constant IP_HDR_COMP \ IP payload compression protocol
+d# 115 constant IP_HDR_L2TP \ Layer 2 tunneling protocol
+d# 132 constant IP_HDR_SCTP \ Stream control transmission protocol
+d# 135 constant IP_HDR_MOBILITY \ Mobile IPV6
+
+struct ( ipv6-frag-header )
+ 1 sfield ipv6-fh-next-hdr
+ 1 sfield ipv6-fh-len
+ 2 sfield ipv6-fh-frag-offset \ OOOO.OOOO.OOOO.OxxM
+ \ Os contain the fragment offset; M=1=more fragments
+ 4 sfield ipv6-fh-frag-id
+ \ Maybe followed by zero or more of headers in following order:
+ \ - Hop-by-Hop Options header
+ \ - Destination Options header (for first destination, plus destinations in the
+ \ Routing header)
+ \ - Routing header
+ \ - Fragment header
+ \ - Authentication header
+ \ - Encapsulating Security Payload header
+ \ - Destionation Options header (for final destination)
+ \ - Upper-Layer header
+constant /ipv6-frag-hdr
+
+instance variable frag-id
+0 instance value hop-limit
+
+headers
+
+\ *********************************************************************************
+\ Send IP packet
+\ *********************************************************************************
+
+[ifndef] include-ipv4
+: send-ip-packet ( adr len protocol -- ) 3drop ;
+[then]
+
+: max-ipv6-payload ( -- n )
+ max-link-payload /ipv6-header -
+ h# ffff.fff8 and
+;
+: max-ipv6-fragment ( -- n )
+ max-link-payload /ipv6-header - /ipv6-frag-hdr -
+ h# ffff.fff8 and
+;
+
+headerless
+: (send-ipv6-packet) ( adr len protocol -- )
+ rot /ipv6-header - set-struct ( len protocol )
+ h# 6000.0000 ipv6-version xl! \ version 6
+ ( protocol ) ipv6-next-hdr xc! ( len )
+ ( len ) dup ipv6-length xw! ( len )
+ hop-limit ipv6-hop-limit xc! ( len )
+ my-ipv6-addr ipv6-source-addr copy-ipv6-addr ( len )
+ his-ipv6-addr ipv6-dest-addr copy-ipv6-addr ( len )
+ /ipv6-header + ( ip-len )
+ the-struct swap ( ip-adr ip-len )
+ ipv6-dest-addr IPV6_TYPE send-link-packet ( )
+;
+
+0 value oaddr \ original data packet address
+0 value olen \ original data packet length
+0 value oprotocol \ original protocol
+0 value fadr \ fragment address
+
+: send-ipv6-fragment ( offset -- )
+ >r fadr ( fadr ) ( R: offset )
+ olen r@ - max-ipv6-fragment min ( fadr flen ) ( R: offset )
+ 2dup oaddr r@ + -rot move ( fadr flen ) ( R: offset )
+ fadr set-struct ( fadr flen ) ( R: offset )
+ oprotocol ipv6-fh-next-hdr xc! \ Next header in fragment header
+ 0 ipv6-fh-len xc! \ Length of header in units of 8 bytes - 1
+ frag-id ipv6-fh-frag-id xl! \ Fragment id
+ dup r@ + olen < 1 and ( fadr flen more? ) ( R: offset )
+ r> 3 << or ipv6-fh-frag-offset xw! ( fadr flen )
+ /ipv6-frag-hdr + ( fadr flen' )
+ IP_HDR_FRAGMENT (send-ipv6-packet) ( )
+;
+
+: send-ipv6-packet ( adr len protocol -- )
+ over max-ipv6-payload <= if
+ (send-ipv6-packet)
+ else
+ 1 frag-id +!
+ over max-ipv6-fragment /mod swap 0> if 1+ then ( adr len protocol #frags )
+ >r to oprotocol to olen to oaddr r> ( #frags )
+ max-ipv6-payload allocate-ipv6 to fadr ( #frags )
+ ( #frags ) 0 do ( )
+ i max-ipv6-fragment * send-ipv6-fragment
+ loop
+ fadr max-ipv6-payload free-ipv6
+ then
+;
+
+: send-ip-packet ( adr len protocol -- )
+ use-ipv6? if send-ipv6-packet else send-ip-packet then
+;
+
+\ *********************************************************************************
+\ Receive IP packet
+\ *********************************************************************************
+
+defer handle-icmpv6 ( contents-adr,len protocol -- ) ' 3drop to handle-icmpv6
+
+[ifndef] include-ipv4
+: process-timeout? ( -- flag ) false ;
+: process-ipv4-packet ( adr len type -- flag )
+ 3drop ." Discarding IPv4 packet" cr false
+;
+: ip-payload ( len -- adr len' ) .ipv4-not-supported ;
+[then]
+
+: process-ipv6-packet ( adr len type -- false | contents-adr,len true )
+ \ XXX Not complete. Need to process additional headers and fragmentation.
+ \ XXX Assume no additional headers for now.
+
+ nip swap ( type adr )
+ dup set-struct to last-ip-packet ( type )
+ ipv6-addr-match? if ( type )
+ ipv6-next-hdr c@ dup >r = dup if ( type=? ) ( R: next-hdr )
+ ipv6-payload rot ( contents-adr,len true ) ( R: next-hdr )
+ then ( false | contents-adr,len true ) ( R: next-hdr )
+ r> IP_HDR_ICMPV6 = if ( false | contents-adr,len true )
+ ipv6-payload IP_HDR_ICMPV6 handle-icmpv6 \ Handle ICMPv6 packets
+ else
+ dup not if ipv6-payload ipv6-next-hdr c@ handle-ipv6 then
+ \ Handle other unexpected packets
+ then ( false | contents-adr,len true )
+ else
+ drop ipv6-payload handle-other-ipv6 \ Handle packets for other address
+ false ( false )
+ then ( false | contents-adr,len true )
+;
+
+: receive-ip-packet ( type -- true | contents-adr,len false )
+ begin
+ use-ipv6? if IPV6_TYPE else IP_TYPE then
+ receive-ethernet-packet ( type [ip-adr,len] flag )
+ if drop process-timeout? drop true exit then
+
+ over ipv4? if
+ 2 pick process-ipv4-packet ( type [len] flag )
+ if ip-payload true else false then ( type [contents-adr,len] flag )
+ else
+ 2 pick process-ipv6-packet ( type [contents-adr,len] flag )
+ then
+
+ ?dup 0= if ( type )
+ process-timeout? if drop true exit then
+ false
+ then
+ until ( type contents-adr,len )
+ rot drop false ( contents-adr,len false )
+;
+
+headers
+
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Added: ofw/inetv6/ippkg.fth
===================================================================
--- ofw/inetv6/ippkg.fth (rev 0)
+++ ofw/inetv6/ippkg.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,112 @@
+\ See license at end of file
+purpose: IP redirector package
+
+dev /packages
+new-device
+" ip" device-name
+
+headerless
+0 value #ip-opens
+0 value we-opened?
+
+: call-tftp: ( "name" -- )
+ create does> body> find-name name>string $call-parent
+;
+
+headers
+: close ( -- )
+ #ip-opens 1- dup 0 max to #ip-opens ( open-level )
+ 0= if
+ we-opened? false to we-opened? if exit then
+ then
+ 0 to my-parent
+;
+
+: open ( -- flag )
+ #ip-opens 1+ to #ip-opens
+
+ obp-tftp-ih if
+ obp-tftp-ih to my-parent
+ true exit
+ then
+
+ " net//obp-tftp:last" open-dev to my-parent ( )
+
+ \ XXX probably should catch this
+ " configure" $call-parent ( )
+
+ true to we-opened?
+ true
+;
+
+call-tftp: send-udp-packet ( adr len src-port dst-port -- )
+call-tftp: receive-udp-packet ( dst-port -- true | adr len src-port false )
+call-tftp: send-ip-packet ( adr len protocol -- )
+call-tftp: receive-ip-packet ( type -- true | adr len false )
+
+[ifdef] include-ipv4
+call-tftp: allocate-udp ( payload-len -- payload-adr )
+call-tftp: free-udp ( payload-adr payload-len -- )
+call-tftp: allocate-ip ( payload-len -- payload-adr )
+call-tftp: free-ip ( payload-adr payload-len -- )
+call-tftp: unlock-ip-address ( -- )
+call-tftp: name-server-ip ( -- 'ip )
+call-tftp: my-ip-addr ( -- 'ip )
+call-tftp: his-ip-addr ( -- 'ip )
+call-tftp: set-dest-ip ( 'ip -- )
+call-tftp: max-ip-payload ( -- n )
+call-tftp: netmask ( -- 'ip )
+[then]
+
+[ifdef] include-ipv6
+call-tftp: use-ipv6? ( -- flag )
+call-tftp: send-ipv6-packet ( adr len protocol -- )
+call-tftp: allocate-udpv6 ( payload-len -- payload-adr )
+call-tftp: free-udpv6 ( payload-adr payload-len -- )
+call-tftp: allocate-ipv6 ( payload-len -- payload-adr )
+call-tftp: free-ipv6 ( payload-adr payload-len -- )
+call-tftp: unlock-ipv6-address ( -- )
+call-tftp: name-server-ipv6 ( -- 'ip )
+call-tftp: my-ipv6-addr ( -- 'ip )
+call-tftp: his-ipv6-addr ( -- 'ip )
+call-tftp: set-dest-ipv6 ( 'ip -- )
+call-tftp: max-ipv6-payload ( -- n )
+call-tftp: prefix-match? ( 'ip1 'ip2 -- flag )
+call-tftp: his-mc-ipv6-addr? ( 'ip -- flag )
+[then]
+
+call-tftp: set-timeout ( #milliseconds -- )
+call-tftp: update-timeout ( -- )
+call-tftp: compute-srtt ( -- )
+call-tftp: domain-name ( -- 'ip )
+call-tftp: next-xid ( -- id )
+call-tftp: $set-host ( hostname$ -- )
+call-tftp: oc-checksum ( n adr len -- n' )
+call-tftp: link-mtu ( -- n )
+
+finish-device
+device-end
+
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Added: ofw/inetv6/ipv6.fth
===================================================================
--- ofw/inetv6/ipv6.fth (rev 0)
+++ ofw/inetv6/ipv6.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,225 @@
+\ See license at end of file
+purpose: Simple Internet Protocol version 6 (IPv6) implementation
+
+
+\ Internet protocol version 6 (IPv6).
+
+decimal
+
+headerless
+
+[ifndef] include-ipv4
+\ Give the net up to 4 seconds to respond to packets
+instance variable timeout-msecs d# 4000 timeout-msecs !
+[then]
+
+struct ( ipv6-header )
+ 4 sfield ipv6-version \ Actually, this is VVVVCCCC.CCCCFFFF.FFFFFFFF.FFFFFFFF
+ \ VVVV is the version
+ \ CCCCCCCC is the traffic class
+ \ FFFF.FFFFFFFF.FFFFFFFF is the flow label
+ 2 sfield ipv6-length
+ 1 sfield ipv6-next-hdr
+ 1 sfield ipv6-hop-limit
+/ipv6 sfield ipv6-source-addr
+/ipv6 sfield ipv6-dest-addr
+ \ There maybe extension headers here.
+constant /ipv6-header
+
+[ifndef] include-ipv4
+d# 256 buffer: 'domain-name
+' 'domain-name " domain-name" chosen-string
+: use-server? ( -- flag ) false ;
+: use-router? ( -- flag ) false ;
+[then]
+
+headers
+0 instance value prefix
+/ipv6 buffer: his-ipv6-addr
+/ipv6 buffer: name-server-ipv6
+
+headerless
+
+\ link-local scope multicast all-nodes address
+create my-mc-ipv6-addr h# ff c, 2 c, 0 w, 0 l, 0 w, 0 c, 1 c, h# ff c, 0 c, 0 c, 0 c,
+create his-mc-ipv6-addr h# ff c, 2 c, 0 w, 0 l, 0 w, 0 c, 1 c, h# ff c, 0 c, 0 c, 0 c,
+create unknown-ipv6-addr h# 00 l, h# 00 l, h# 00 l, h# 00 l,
+
+: ipv6= ( ip-addr1 ip-addr2 -- flag ) /ipv6 comp 0= ;
+
+: unknown-ipv6-addr? ( adr-buf -- flag ) unknown-ipv6-addr ipv6= ;
+: knownv6? ( adr-buf -- flag ) unknown-ipv6-addr? 0= ;
+
+: bits>mask ( bits -- mask )
+ ?dup 0= if 0 exit then
+ 0 swap 0 7 ?do ( mask bits )
+ 1 i << rot or swap ( mask' bits )
+ 1- dup 0= if leave then ( mask bits' )
+ -1 +loop drop ( mask )
+;
+
+: prefix-match? ( ip1 ip2 -- flag )
+ prefix 8 /mod 2over 2 pick ( ip1 ip2 rem quot ip1 ip2 quot )
+ comp 0= if
+ swap bits>mask >r ( ip1 ip2 quot ) ( R: mask )
+ tuck + c@ r@ and ( ip1 quot [ip2+quot]&mask ) ( R: mask )
+ -rot + c@ r> and = ( flag )
+ else
+ 4drop false
+ then
+;
+
+: set-his-mc-ipv6-addr ( -- )
+ his-ipv6-addr /ipv6 + 3 - his-mc-ipv6-addr /ipv6 + 3 - 3 move
+;
+: set-my-mc-ipv6-addr ( -- )
+ my-ipv6-addr /ipv6 + 3 - my-mc-ipv6-addr /ipv6 + 3 - 3 move
+;
+
+: his-mc-ipv6-addr? ( adr-buf -- flag )
+ dup his-mc-ipv6-addr ipv6= swap unknown-ipv6-addr? or
+;
+: my-mc-ipv6-addr? ( adr-buf -- flag )
+ dup my-mc-ipv6-addr ipv6= swap unknown-ipv6-addr? or
+;
+
+/ipv6 buffer: router-ipv6-addr
+: use-routerv6? ( -- flag ) router-ipv6-addr knownv6? ;
+: use-router? ( -- flag )
+ use-ipv6? if use-routerv6? else use-router? then
+;
+
+/ipv6 buffer: server-ipv6-addr
+: use-serverv6? ( -- flag ) server-ipv6-addr knownv6? ;
+: use-server? ( -- flag )
+ use-ipv6? if use-serverv6? else use-server? then
+;
+
+\ Generate his multicast MAC address from his IPv6 address
+: set-his-mc-en ( -- )
+ his-ipv6-addr be-w@ h# fe80 =
+ his-ipv6-addr d# 11 + be-w@ h# fffe = and if
+ multicast-en-addr his-en-addr 3 move
+ his-ipv6-addr d# 13 + his-en-addr 3 + 3 move
+ then
+;
+
+partial-headers
+[ifndef] include-ipv4
+: indent ( -- ) bootnet-debug if ." " then ;
+[then]
+headerless
+: .my-ipv6-addr ( -- ) ." My IP: " my-ipv6-addr .ipv6 ;
+: .his-ipv6-addr ( -- ) ." His IP: " his-ipv6-addr .ipv6 ;
+
+[ifndef] include-ipv4
+0 instance value last-ip-packet
+[then]
+
+headers
+: set-dest-ipv6 ( buf -- )
+ dup his-ipv6-addr ipv6= if
+ drop
+ else
+ his-ipv6-addr copy-ipv6-addr
+ set-his-mc-ipv6-addr
+ unlock-link-addr
+ then
+;
+
+: lock-ipv6-address ( -- )
+ the-struct >r last-ip-packet set-struct
+ \ Don't change his-ipv6-addr for booting over gateway
+ use-routerv6? if \ booting over a gateway.
+ bootnet-debug if indent ." Using router" cr then
+ else
+ \ In case of direct booting, i.e. booting over specified server
+ \ don't change his addresses
+ use-serverv6? 0= if ipv6-source-addr set-dest-ipv6 then
+ lock-link-addr
+ then
+ bootnet-debug if indent .his-link-addr .his-ipv6-addr then
+ r> set-struct
+;
+: unlock-ipv6-address ( -- )
+ unknown-ipv6-addr set-dest-ipv6
+ unknown-ipv6-addr server-ipv6-addr copy-ipv6-addr
+;
+headerless
+
+\ This is a hook for handling IP packets addressed to us that are
+\ of a different type than the expected one. This could be used
+\ to handle "behind the scenes" things like ICMP if necessary.
+defer handle-ipv6 ( adr len protocol -- )
+defer handle-other-ipv6 ( adr len -- )
+headers
+: (handle-ipv6) ( adr len protocol -- )
+ bootnet-debug if
+ dup ." (Discarding IPv6 packet of protocol " u. ." )" cr
+ then
+ 3drop
+;
+' (handle-ipv6) is handle-ipv6
+
+: (handle-other-ipv6) ( adr len -- )
+ bootnet-debug if
+ ." (Discarding IPv6 packet because of IP address mismatch)" cr
+ then
+ 2drop
+;
+' (handle-other-ipv6) is handle-other-ipv6
+headerless
+
+: ipv6-payload ( -- adr len ) the-struct /ipv6-header + ipv6-length xw@ ;
+
+: ipv6-addr-match? ( -- flag )
+ \ If we know the server's IP address (e.g. the user specified one, or
+ \ we chose one from a RARP or BOOTP reply, or we locked onto one that
+ \ responded to a TFTP broadcast), then we silently discard IP packets
+ \ from other hosts.
+ his-ipv6-addr his-mc-ipv6-addr? 0= if
+ his-ipv6-addr ipv6-source-addr ipv6= 0= if false exit then
+ then
+
+ \ Accept IP multicast packets
+ ipv6-dest-addr my-mc-ipv6-addr? if true exit then
+
+ \ If we don't know our own IP address yet, we accept every IP packet
+ my-ipv6-addr unknown-ipv6-addr? if true exit then
+
+ \ Otherwise, we know our IP address, so we filter out packets addressed
+ \ to other destinations.
+ my-ipv6-addr ipv6-dest-addr ipv6=
+;
+
+: allocate-ipv6 ( payload-len -- payload-adr )
+ /ipv6-header + allocate-ethernet /ipv6-header +
+;
+: free-ipv6 ( payload-adr payload-len -- )
+ /ipv6-header negate /string free-ethernet
+;
+
+headers
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Added: ofw/inetv6/loadmail.fth
===================================================================
--- ofw/inetv6/loadmail.fth (rev 0)
+++ ofw/inetv6/loadmail.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,30 @@
+\ See license at end of file
+purpose: Load file for POP3 and SMTP code
+
+fload ${BP}/ofw/inet/mailbuff.fth
+\ fload ${BP}/ofw/inet/pop3.fth
+fload ${BP}/ofw/inet/smtp.fth
+
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Added: ofw/inetv6/loadpkg.fth
===================================================================
--- ofw/inetv6/loadpkg.fth (rev 0)
+++ ofw/inetv6/loadpkg.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,59 @@
+purpose: Interior load file for obp-tftp support package
+
+fload ${BP}/ofw/inetv6/config.fth \ Networking stack configuration
+
+fload ${BP}/ofw/inetv6/support.fth \ Miscellaneous support function
+[ifdef] include-ipv6
+fload ${BP}/ofw/inetv6/supportv6.fth
+[then]
+
+fload ${BP}/ofw/inetv6/ethernet.fth \ Ethernet Address
+fload ${BP}/ofw/inetv6/occhksum.fth \ IP checksum
+
+[ifdef] include-ipv4
+fload ${BP}/ofw/inetv6/ip.fth \ Internet Protocol
+fload ${BP}/ofw/inetv6/ipfr.fth \ IP fragmentation/reassembly
+[then]
+[ifdef] include-ipv6
+fload ${BP}/ofw/inetv6/ipv6.fth
+fload ${BP}/ofw/inetv6/ipfrv6.fth \ IP fragmentation/reassembly
+fload ${BP}/ofw/inetv6/icmpv6.fth \ ICMPv6
+[then]
+
+[ifdef] include-ipv4
+fload ${BP}/ofw/inetv6/arp.fth \ [Reverse] Addr Resolution Protocol
+[then]
+
+[ifdef] include-ipv4
+fload ${BP}/ofw/inetv6/udp.fth \ User Datagram Protocol
+[then]
+[ifdef] include-ipv6
+fload ${BP}/ofw/inetv6/udpv6.fth \ User Datagram Protocol
+[then]
+
+fload ${BP}/ofw/inetv6/random.fth \ Random number generator
+fload ${BP}/ofw/inetv6/adaptime.fth \ Adaptive timeout
+
+[ifdef] include-ipv4
+fload ${BP}/ofw/inetv6/bootp.fth \ Bootp Protocol
+fload ${BP}/ofw/inetv6/dhcp.fth \ Dynamic Host Config. Protocol
+fload ${BP}/ofw/inetv6/tftp.fth \ Trivial File Transfer Protocol
+fload ${BP}/ofw/inetv6/netload.fth \ Network boot loading package
+fload ${BP}/ofw/inetv6/attr-ip.fth \ Save IP info in /chosen
+[then]
+[ifdef] include-ipv6
+\ fload ${BP}/ofw/inetv6/bootpv6.fth \ Bootp Protocol
+\ fload ${BP}/ofw/inetv6/dhcpv6.fth \ Dynamic Host Config. Protocol
+fload ${BP}/ofw/inetv6/tftp.fth \ Trivial File Transfer Protocol
+fload ${BP}/ofw/inetv6/netloadv6.fth \ Network boot loading package
+fload ${BP}/ofw/inetv6/neighdis.fth \ Neighbor discovery
+fload ${BP}/ofw/inetv6/attr-ipv6.fth \ Save IP info in /chosen
+[then]
+
+fload ${BP}/ofw/inetv6/encdec.fth \ Packet encoding/decoding primitives
+[ifdef] include-ipv4
+fload ${BP}/ofw/inetv6/dns.fth \ Domain name resolver (RFC1034/5)
+[then]
+[ifdef] include-ipv6
+fload ${BP}/ofw/inetv6/dnsv6.fth \ Domain name resolver (RFC3596)
+[then]
Added: ofw/inetv6/loadtcp.fth
===================================================================
--- ofw/inetv6/loadtcp.fth (rev 0)
+++ ofw/inetv6/loadtcp.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,75 @@
+\ See license at end of file
+purpose: Load file for TCP extensions
+
+fload ${BP}/ofw/inetv6/config.fth
+
+create ip-redirector
+
+[ifdef] ip-redirector
+fload ${BP}/ofw/inetv6/ippkg.fth
+devalias ip //ip
+[else]
+devalias ip net//obp-tftp:last
+[then]
+
+devalias tcp ip//tcp
+devalias http tcp//http
+devalias httpd tcp//httpd:verbose
+devalias nfs ip//nfs
+
+[ifdef] include-ipv4
+fload ${BP}/ofw/inetv6/ping.fth
+[then]
+[ifdef] include-ipv6
+fload ${BP}/ofw/inetv6/pingv6.fth
+[then]
+
+fload ${BP}/ofw/inetv6/tcpapp.fth
+fload ${BP}/ofw/inetv6/finger.fth
+fload ${BP}/ofw/inetv6/telnet.fth
+fload ${BP}/ofw/inetv6/loadmail.fth
+
+warning @ warning off
+autoload: telnetd defines: telnetd
+warning !
+
+also forth definitions
+" " d# 64 config-string http-proxy
+previous definitions
+
+fload ${BP}/ofw/inetv6/httpd.fth
+
+[ifdef] resident-packages
+support-package: tcp
+[ifdef] include-ipv4
+ fload ${BP}/ofw/inetv6/tcp.fth
+[then]
+[ifdef] include-ipv6
+ fload ${BP}/ofw/inetv6/tcpv6.fth
+[then]
+end-support-package
+[then]
+
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Added: ofw/inetv6/loadtftp.fth
===================================================================
--- ofw/inetv6/loadtftp.fth (rev 0)
+++ ofw/inetv6/loadtftp.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,91 @@
+\ See license at end of file
+purpose: Load file for (TFTP) network booting package
+
+
+\ Load file for Trivial File Transfer Protocol (TFTP) network booting package
+
+headers
+fload ${BP}/ofw/inetv6/macaddr.fth \ MAC address sensing and display
+
+defer show-progress
+\ : show-address ( adr -- adr ) dup (cr . ;
+
+0 value meter-counter
+: -/|\ ( -- adr ) " -/|\" drop ;
+: show-meter ( adr -- adr ) \ show progress by toggle meter
+ meter-counter 1+ dup is meter-counter ( counter )
+ \ one can change frequency of display by changing following number
+ d# 10
+ /mod swap if ( smaller-counter )
+ drop
+ else ( smaller-counter )
+ 4 mod -/|\ + c@ emit 1 backspaces
+ then ( )
+;
+' show-meter is show-progress
+
+headers
+0 value bootnet-debug \ XXX ???? XXX
+: debug-net ( -- ) true to bootnet-debug ;
+: undebug-net ( -- ) false to bootnet-debug ;
+
+0 value udp-checksum?
+d# 100 constant tftp-retries
+
+defer setup-ip-attr
+['] noop is setup-ip-attr \ for proms not requiring ip-addr as properties.
+
+create use-dhcp
+create do-ip-frag-reasm
+
+0 value rpc-xid
+0 value obp-tftp-ih
+
+[ifdef] resident-packages
+dev /packages new-device
+ start-module
+ " obp-tftp" device-name
+ fload ${BP}/ofw/inetv6/loadpkg.fth
+ end-module
+finish-device device-end
+[then]
+
+\ params: debug-net debug-ip debug-udp debug-bootp undebug-net
+: (show-net) ( adr len -- )
+ 0 0 " obp-tftp" $open-package ?dup if
+ dup >r $call-method
+ r> close-package
+ else
+ 2drop
+ then
+;
+: show-net ( -- ) " debug-net" (show-net) ;
+: show-ip ( -- ) " debug-ip" (show-net) ;
+: show-udp ( -- ) " debug-udp" (show-net) ;
+: show-bootp ( -- ) " debug-bootp" (show-net) ;
+
+fload ${BP}/ofw/inetv6/watchnet.fth \ Watch-net command
+
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Added: ofw/inetv6/macaddr.fth
===================================================================
--- ofw/inetv6/macaddr.fth (rev 0)
+++ ofw/inetv6/macaddr.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,48 @@
+\ See license at end of file
+purpose: MAC (Ethernet) address reporting and display functions
+
+headers
+false config-flag local-mac-address?
+: mac-address ( -- adr len )
+ local-mac-address? if
+ " local-mac-address" get-inherited-property 0= if ( adr len )
+ dup 6 = if exit else 2drop then
+ then
+ then
+
+ \ Didn't get a valid "local-mac-address" property, so use the system one
+ system-mac-address ( adr len )
+;
+
+\ Display Ethernet address
+: u.. ( n -- ) (.2) type ;
+: .enaddr ( addr-buff -- )
+ push-hex
+ 5 0 do dup c@ u.. 1+ ." :" loop c@ u..
+ pop-base
+;
+headers
+: .enet-addr ( -- ) system-mac-address drop .enaddr ;
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Added: ofw/inetv6/mailbuff.fth
===================================================================
--- ofw/inetv6/mailbuff.fth (rev 0)
+++ ofw/inetv6/mailbuff.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,169 @@
+\ See license at end of file
+purpose: Common code for POP3 and SMTP buffer management
+
+false value debug-mail?
+
+: debug-mail ( -- ) true to debug-mail? ;
+: no-debug-mail ( -- ) false to debug-mail? ;
+
+0 value mail-buffer
+h# 1000 constant /mail-buffer
+0 value mail-ptr
+
+: >mail-buffer ( adr len -- )
+ dup to mail-ptr
+ mail-buffer swap move
+;
+
+: mail-append ( $ -- )
+ dup mail-ptr + mail-ptr swap to mail-ptr ( $ insert ) \ Set final length
+ mail-buffer + swap ( adr dest len )
+ move ( )
+;
+
+: add-crlf ( -- ) \ Append a CRLF pir into the message buffer
+ h# 0d mail-buffer mail-ptr + c!
+ h# 0a mail-buffer mail-ptr + 1+ c!
+ mail-ptr 2+ to mail-ptr
+;
+
+: ptr+ ( -- ) mail-ptr 1+ to mail-ptr ;
+: buf@ ( index -- b ) mail-buffer + c@ ;
+
+: skip-forward ( -- )
+ begin
+ mail-ptr buf@
+ h# 20 <>
+ while
+ ptr+
+ repeat
+;
+
+: skip-to-non-blank ( -- )
+ begin
+ mail-ptr buf@
+ h# 20 =
+ while
+ ptr+
+ repeat
+;
+
+: set-ptr ( -- ) \ Sets buffer pointer to end of first line
+ 0 to mail-ptr
+ begin
+ mail-ptr buf@ ( t1 )
+ mail-ptr 1+ buf@ ( t1 t2 )
+ h# 0a = swap ( flag t1 )
+ h# 0d = and 0= ( flag' )
+ while
+ ptr+
+ repeat
+;
+
+: get-number ( field -- # ) \ Extract a number from a response
+ \ Responses come back as ascii. This method extracts a number from
+ \ a specified field within the returned data. The response data always
+ \ starts with "+OK" followed by a space, then ascii, then a space, and
+ \ more ascii. When calling this method, do not count the "+OK" as a
+ \ field
+
+ 0 to mail-ptr ( field )
+ 0 do ( )
+ skip-forward \ Move to blank spot
+ skip-to-non-blank \ move to non-blank spot
+ loop
+
+ \ mail-ptr is now pointing at first ascii digit of the number we want.
+ \ The numbers are in decimal format.
+
+ 0 \ Starting value
+ begin
+ mail-buffer mail-ptr + c@ h# 30 h# 39 between
+ while
+ d# 10 *
+ mail-buffer mail-ptr + c@ h# 0f and +
+ mail-ptr 1+ to mail-ptr
+ repeat ( # )
+;
+
+: reply-good? ( expected$ -- ok? )
+ mail-buffer over $=
+;
+
+: allocate-mail-buffer ( -- )
+ /mail-buffer alloc-mem to mail-buffer
+;
+: free-mail-buffer ( -- )
+ mail-buffer /mail-buffer free-mem
+;
+
+d# 50 value #retries
+d# 500 value wait-time
+
+: call-tcp ( ... -- ... ) tcp-ih $call-method ;
+: read-tcp ( adr len -- actual ) " read" call-tcp ;
+: write-tcp ( adr len -- actual ) " write" call-tcp ;
+
+: get-reply ( -- actual )
+ #retries 0 do
+ mail-buffer /mail-buffer read-tcp dup -2 <> if ( read )
+ debug-mail? if mail-buffer over type cr then ( read )
+ unloop exit ( read )
+ else ( read )
+ drop ( )
+ wait-time ms ( )
+ then ( )
+ loop
+ 0 ( 0 )
+;
+
+: send-request ( -- actual ) mail-buffer mail-ptr write-tcp ;
+
+: send ( expected$ -- ok? )
+ add-crlf ( expected$ )
+
+ send-request 0= if ( )
+ 2drop ( )
+ ." Send Failure" cr ( )
+ false ( false )
+ exit ( false )
+ then ( false )
+
+ ( expected$ )
+
+ get-reply 0= if
+ 2drop
+ ." No reply to message" cr
+ false
+ exit
+ then
+
+ ( expected$ ) reply-good? ( ok? )
+;
+
+: missing-var ( adr len -- )
+ ." Missing environment variable: " type cr
+;
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Added: ofw/inetv6/neighdis.fth
===================================================================
--- ofw/inetv6/neighdis.fth (rev 0)
+++ ofw/inetv6/neighdis.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,173 @@
+\ See license at end of file
+purpose: Neighbor Discovery
+
+headerless
+
+" " d# 40 config-string ipv6-dns-server
+" " d# 64 config-string ipv6-domain
+" " d# 40 config-string ipv6-router
+" stateless" d# 40 config-string ipv6-address \ leave room
+\ " dhcp" ' ipv6-address set-config-string-default
+
+[ifndef] include-ipv4
+: configure ( -- ) ;
+[then]
+
+: got-nd-ad? ( adr len -- flag )
+ drop
+ dup c@ d# 136 <> if drop false exit then \ Neighbor advertisement?
+ dup 8 + his-ipv6-addr ipv6= not if drop false exit then \ Check IP address
+ dup 4 + c@ h# 60 and h# 60 <> if drop false exit then \ Solicited, override
+ dup d# 24 + c@ 2 <> if drop false exit then \ Target link address
+ d# 26 + his-en-addr copy-en-addr \ Set his-en-addr
+ true
+;
+
+: do-neighbor-discovery ( -- )
+ bootnet-debug if
+ ." ICMPv6 ND protocol: Getting MAC address for IP address: "
+ his-ipv6-addr .ipv6 cr
+ then
+
+ set-his-mc-en \ Set his multicast link address
+ send-neigh-sol \ Neighbor solicitation
+
+ current-timeout >r
+ timeout-msecs @ set-timeout
+ begin
+ IP_HDR_ICMPV6 receive-ip-packet ?dup 0= if got-nd-ad? then
+ until
+ r> restore-timeout
+
+ bootnet-debug if ." Got MAC address: " his-en-addr .enaddr cr then
+;
+
+: do-discovery ( -- )
+ \ XXX need to do DHCPv6 discovery
+ his-ipv6-addr be-w@ h# fe80 = if do-neighbor-discovery then
+;
+
+: (resolve-en-addrv6) ( 'dest-adr type -- 'en-adr type )
+ dup IP_TYPE = if ( 'ip-adr ip-type )
+[ifdef] include-ipv4
+ swap dup broadcast-ip-addr? if ( ip-type 'ip-adr )
+ drop ( ip-type )
+ broadcast-en-addr his-en-addr copy-en-addr ( ip-type )
+ else ( ip-type 'ip-adr )
+ his-ip-addr copy-ip-addr ( ip-type )
+ his-en-addr broadcast-en-addr en= if do-arp then ( ip-type )
+ then
+ his-en-addr swap
+[then]
+ exit
+ else ( 'dest-adr type )
+ dup IPV6_TYPE = if
+ swap his-ipv6-addr copy-ipv6-addr
+ his-en-addr broadcast-en-addr en= if do-discovery then
+ his-en-addr swap exit
+ then
+ then
+
+ nip his-en-addr swap
+;
+
+: s-all-ipv6 ( -- ) \ See discovery info
+ bootnet-debug if
+ ." Initial configuration: (fixed) " cr
+ indent .my-ipv6-addr cr
+ indent .my-link-addr cr
+ then
+;
+
+: configure-ipv6 ( -- ) \ Get discovery info
+ ['] 4drop to icmpv6-err-callback-xt
+ ['] 2drop to icmpv6-info-callback-xt
+
+ d# 64 to prefix
+ " fe80::259:08ff:feb4:0061" my-ipv6-addr $ipv6#
+ set-my-mc-ipv6-addr
+
+ \ XXX Duplicate address discovery; Router discovery
+ \ ::0 => ff02::1:ffb4:0061 hop-by-hop, multicast listener report
+ \ ::0 => ff02::2 router solicitation
+ \ ::0 => ff02::1:ffb4:0061 DAD, neighbor solicitation with target addr
+ \ Wait for router advertisement, if gotten, continue
+ \ For each prefix in router advertisement, combine prefix with interface id
+ \ Add address to the list of assigned addresses for the interface
+ \ All addresses must be verified with DAD
+ \ fe80::259:08ff:feb4:0061 => ff02::1:ffb4:0061 hop-by-hop, multicast listener report
+;
+
+: configure ( -- )
+ use-ipv6? \ Save IPv6 flag
+ false to use-ipv6? configure
+ to use-ipv6? \ Restore IPv6 flag
+ configure-ipv6
+;
+
+: parse-args ( -- )
+ false to use-bootp?
+ true to use-last?
+;
+
+: close ( -- )
+[ifdef] include-ipv4
+ close
+[else]
+ close-link
+ 0 to obp-tftp-ih
+[then]
+;
+
+\ complete syntax:
+\ net:[bootp]server-ip,filename,client-ip,router-ip, ...
+\ ... #bootp-retries,#tftp-retries
+\ syntax for booting - net[:sipaddr[,[file-name][,[tipaddr][,gipaddr]]]]
+\ syntax for booting over a router (1 hop): net:sipaddr,[file-name],[tipaddr],gipaddr
+\ Note: if user provides gipaddr, user must provide sipaddr
+\ Once use-server? is set, never broadcast tftp.
+
+: open ( -- ok? )
+[ifdef] include-ipv4
+ false to use-ipv6?
+ open 0= if false exit then \ IPv4 open
+[else]
+ open-link
+ parse-args
+ mac-address drop my-en-addr copy-en-addr
+ my-self to obp-tftp-ih
+[then]
+ true to use-ipv6?
+ ['] (resolve-en-addrv6) to resolve-en-addr
+ configure-ipv6
+ set-mc-hash if close false exit then
+ s-all-ipv6
+ setup-ip-attr
+ true
+;
+
+
+headers
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Added: ofw/inetv6/netload.fth
===================================================================
--- ofw/inetv6/netload.fth (rev 0)
+++ ofw/inetv6/netload.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,486 @@
+\ See license at end of file
+purpose: Network loading using TFTP.
+
+\ Network loading using TFTP. Loads either a named file using the "dload"
+\ command, or the default tftpboot file whose name is constructed from
+\ the Internet address (derived from the Ethernet address with RARP)
+\ and the CPU architecture type.
+
+headerless
+: ?ip-error ( flag -- ) abort" Invalid number in IP address" ;
+: decimal-byte ( adr,len -- n )
+ push-decimal ['] safe->number catch pop-base ( n 0 | x x error )
+ ?ip-error ( n )
+ dup d# 255 u> ?ip-error ( n )
+;
+
+\ Parse the text string "ip-str" as a decimal IP address (e.g. 129.144.12.4),
+\ storing it as binary bytes at "buf"
+: $ip# ( ip-str buf -- )
+ dup /i erase ( ip-str buf )
+ /i bounds do ( ip-str )
+ ascii . left-parse-string ( r-str l-str )
+ decimal-byte i c! ( r-str )
+ loop ( r-str )
+ 2drop
+;
+
+: show-router-addr ( -- )
+ bootnet-debug if ." Router IP: = " router-ip-addr .ipaddr cr then
+;
+
+: show-all-en-ip-address ( -- )
+ bootnet-debug if
+ ." Using addresses: " cr
+ indent .my-link-addr .my-ip-addr cr
+ indent .his-link-addr .his-ip-addr cr
+ use-router? if indent show-router-addr then
+ then
+;
+
+d# 32 buffer: tmpname
+
+partial-headers
+\ Construct the file name for the second-stage boot program from
+\ the IP address and the architecture.
+: boot-filename ( -- adr len )
+ file-name-buf cscount dup if exit then ( adr len )
+ 2drop
+ push-hex
+ my-ip-addr be-l@ (.8) 2dup upper ( adr len )
+ pop-base
+ tmpname place
+ cpu-arch dup if " ." tmpname $cat tmpname $cat else 2drop then
+ tmpname count file-name-buf place-cstr drop
+ file-name-buf cscount
+;
+
+headerless
+: parse-field ( adr len -- rem-adr,len first-adr,len )
+ ascii , left-parse-string
+;
+: un-field ( rem$ field$ -- rem$' ) drop -rot + over - ;
+: next-field ( adr len -- rem-adr,len first-adr,len true | rem-adr,len false )
+ dup 0= if false exit then
+ parse-field dup if true else 2drop false then
+;
+: get-into-tftp-buf ( adr len -- )
+ file-name-buf place-cstr ( cstr )
+ \ process file-name to be passed onto tftpread
+ cscount bounds ?do
+ i c@ ascii | = i c@ ascii \ = or if ascii / i c! then
+ loop
+;
+
+: .t/f ( n -- ) if ." true " else ." false " then ;
+
+headers
+
+true instance value use-bootp?
+false instance value use-last?
+false instance value use-nfs?
+
+headerless
+
+: s-all ( -- ) \ see ip-addr/bootp info.
+ bootnet-debug if
+ ." Initial configuration: "
+ use-last? if
+ ." Using the previous configuration" cr
+ exit
+ then
+ use-bootp? if
+ ." Use DHCP/BOOTP to get configuration" cr
+ else
+ cr
+ my-ip-addr known? if
+ indent ." My IP address: " my-ip-addr .ipaddr cr
+ else
+ indent ." Use RARP to get my IP address" cr
+ then
+ use-server? if
+ indent ." Boot server: " server-ip-addr .ipaddr cr
+ then
+ use-router? if
+ indent ." Router: " router-ip-addr .ipaddr cr
+ then
+ then
+ file-name-buf c@ if
+ indent ." Boot filename: " file-name-buf cscount type cr
+ then
+ then
+;
+
+\ When router ip addr is supplied, server's ip addr
+\ must also be supplied by user. So confirm "server" is non-broadcast?
+: init-router ( -- )
+;
+
+: init-ip-addr ( -- )
+ unknown-ip-addr server-ip-addr copy-ip-addr
+ unknown-ip-addr router-ip-addr copy-ip-addr
+ def-broadcast-ip broadcast-ip-addr copy-ip-addr
+ 0 file-name-buf c! 0 server-name c! 0 bootp-name-buf c!
+ clear-net-addresses
+;
+
+\ handle diskless/client's ip address
+: get-client-ip ( rem-str -- rem'-str )
+ next-field if ( rem-str my-ip# )
+ \ move user supplied client ip addr in my-ip-addr
+ my-ip-addr $ip# ( rem-str )
+ false to use-bootp?
+ then ( rem-str )
+;
+: get-router-ip ( rem-str -- rem'-str )
+ next-field if ( rem-str router-ip# )
+ router-ip-addr $ip# ( rem-str )
+ use-router? if
+ use-server? 0= if
+ collect(
+." obp-tftp argument error:" cr
+." If the router is specified, the server must also be specified." cr
+." e.g. boot net:<server-ipaddr>,<file>,<client-ipaddr>,<router-ipaddr>" cr
+ )collect $abort
+ then
+ then
+ then
+;
+
+: get-number ( rem-str -- rem'-str n )
+ next-field if ( rem-str field$ )
+ push-decimal
+ $number if ( rem-str )
+ ." Bad number in network arguments" cr
+ ." Network argument syntax:" cr
+." server-ip,filename,client-ip,router-ip,#bootp-retries,#tftp-retries" cr
+ \ Discard the rest of the arguments because we're probably
+ \ out of sync.
+ drop 0 ( rem-str' )
+ -1 ( rem-str' n )
+ then ( rem-str' n )
+ pop-base ( rem-str' n )
+ else ( rem-str )
+ -1 ( rem-str' n )
+ then ( rem-str' n )
+;
+
+: get-bootp-retries ( rem-str -- rem'-str ) get-number to bootp-retries ;
+: get-tftp-retries ( rem-str -- rem'-str ) get-number to tftp-retries ;
+
+\ The NVRAM variable boot-file's value is passed to first level booter.
+\ It is not the file prom boots first. The name of first level boot file
+\ comes from either command lin, or as a part of "devalias net" or
+\ as part of NVRAM variable boot-device.
+: get-boot-filename ( rem-str -- rem'-str )
+ next-field if ( rem-str file-name-str )
+ \ getting file name from command line
+ get-into-tftp-buf
+ then
+;
+
+: get-server-ip ( rem$ -- rem$' )
+ next-field if ( rem$ field$ )
+ 2dup server-ip-addr ['] $ip# catch if ( rem$ field$ x x x )
+ 3drop un-field ( rem$ )
+ \ Erase possible partial IP address
+ unknown-ip-addr server-ip-addr copy-ip-addr ( rem$ )
+ else ( rem$ field$ )
+ 2drop ( rem$ )
+ then ( rem$ )
+ then ( rem$ )
+;
+
+: tftp-args ( rem$ -- )
+ get-server-ip ( rem$ )
+ get-boot-filename ( rem$' )
+ get-client-ip ( rem$' )
+ get-router-ip ( rem$' )
+ get-bootp-retries ( rem$' )
+ get-tftp-retries ( rem$' )
+ 2drop
+
+ \ If we got our IP address, we don't need BOOTP
+ my-ip-addr known? if false to use-bootp? then
+;
+
+" " d# 15 config-string ip-dns-server
+" 255.255.255.0" d# 15 config-string ip-netmask
+" " d# 64 config-string ip-domain
+" " d# 15 config-string ip-router
+" 255.255.255.255" d# 15 config-string ip-address \ leave room
+\ " dhcp" ' ip-address set-config-string-default
+
+\ OBP-TFTP recommended practice says that bootp is the preferred
+\ protocol. The first field, if present, represents serverip-addr.
+\ Extend the RP to optionally recognize "bootp" or "rarp" to override
+\ the default protocol. If the first field is null, protocol is bootp
+\ and all parameters are retrieved from the server.
+: arg-fields ( arg$ -- )
+ true to use-bootp? ( rem$ ) \ Default
+
+ parse-field ( rem$ field$ )
+
+ \ If the first field is "last" and we already know our IP address, ignore
+ \ all other fields and don't re-initialize all the internal variables
+ 2dup " last" $= if 2drop ( rem$ )
+ my-ip-addr unknown-ip-addr? if ( rem$ )
+ \ If we are supposed to use the last good configuration, but
+ \ there is none, ignore the "last" and handle the rest as if
+ \ "last" were absent.
+ parse-field ( rem$ field$ )
+ else ( rem$ )
+ 2drop ( )
+ true to use-last? ( )
+ false to use-bootp? ( )
+ exit
+ then
+ then ( rem$ field$ )
+
+ \ Otherwise, re-initialize the internal variables
+ init-ip-addr ( rem$ field$ )
+
+ \ If the first field is "nfs", arrange to use NFS for booting and
+ \ restart the parsing for the rest of the fields
+ 2dup " nfs" $= if 2drop ( rem$ )
+ true to use-nfs? ( rem$ )
+ parse-field ( rem$ field$ )
+ then ( rem$ field$ )
+
+ 2dup " rarp" $= if 2drop ( rem$ )
+ false to use-bootp? ( rem$ )
+ else ( rem$ field$ )
+
+ 2dup " bootp" $= >r 2dup " dhcp" $= r> or if ( rem$ field$ )
+ 2drop ( rem$ )
+ else ( rem$ field$' )
+ \ The first field is not one of the special values listed
+ \ above, so restore it to the argument string
+ un-field ( rem$ )
+ then then ( rem$ )
+
+ tftp-args ( )
+;
+
+: parse-args ( -- )
+ my-args dup if ( adr len )
+ bootnet-debug if ." my-args = " 2dup type cr then
+ arg-fields ( )
+ else ( adr len )
+ 2drop ( )
+ init-ip-addr ( )
+ then
+;
+
+headerless
+
+partial-headers
+defer modify-boot-file
+: bootp-modify-file ( -- )
+ bootp-name-buf count nip if \ Override if bootp modified the name
+ bootp-name-buf count file-name-buf place-cstr drop
+ then
+;
+' bootp-modify-file to modify-boot-file
+
+: dhcp-modify-file ( -- )
+ file-name-buf c@ 0= if bootp-modify-file then
+;
+
+headerless
+\ bootp syntax is - boot net:bootp[,[server-ip-addr][,file-name]].
+\ or - boot net:[[server-ip-addr][,file-name]].
+\ Open routine has taken file-name from command line in file-name-buf.
+\ If there was none, bootp will use default
+\ file coming from bootp server (mentioned in bootptab)
+\ Currently the one specified on cmd line overwrites that from bootp reply.
+
+: process-bootp ( -- ) \ handle bootp request
+[ifdef] use-dhcp do-dhcp [else] do-bootp [then]
+ modify-boot-file
+;
+
+: delim? ( char -- flag ) dup [char] / = swap [char] \ = or ;
+d# 128 buffer: nfs-filename
+: nfs-read ( adr filename$ -- len )
+ dup if ( adr filename$ )
+ \ If the name is relative; construct a full pathname
+ over c@ delim? 0= if ( adr filename$ )
+ \ Prepend root path (if present) or "/"
+ 'root-path cscount dup 0= if ( adr filename$ root$ )
+ 2drop " /" ( adr filename$ root$ )
+ then ( adr filename$ )
+ nfs-filename pack ( adr filename$ 'buf )
+
+ \ Insert a "/" after the root path if necessary
+ count + 1- c@ delim? 0= if ( adr filename$ )
+ " /" nfs-filename $cat ( adr filename$ )
+ then ( adr filename$ )
+
+ \ Append the filename
+ nfs-filename $cat nfs-filename count ( adr filename$' )
+ then
+ then
+ bootnet-debug if ." NFS protocol: Reading file: " 2dup type cr then
+ " nfs" $open-package >r r@ 0= if
+ collect(
+ ." NFS open failed." cr
+ [ifdef] .dhcp-server .dhcp-server [then]
+ ." NFS Server: " his-ip-addr .ipaddr cr
+ ." Filename: " nfs-filename count type cr
+ )collect $abort
+ then ( adr r: ih )
+ " load" r@ $call-method ( len )
+ r> close-package
+;
+
+: url? ( filename$ -- flag )
+ " /\" lex if ( rem$ head$ delim )
+ drop 2swap 2drop ( head$ )
+ then ( head$ | filename$ )
+ " :" lex if 5drop true exit then ( head$ )
+ 2drop false ( false )
+;
+char / constant delim
+
+d# 255 instance buffer: pathbuf
+: fix-delims ( adr len -- adr' len' )
+ pathbuf pack count 2dup
+ bounds ?do ( adr len )
+ i c@ [char] / = if [char] \ i c! then
+ loop
+;
+
+: load-url ( adr filename$ -- len )
+ fix-delims
+ 2dup open-dev >r r@ 0= if ( adr filename$ )
+ collect(
+ ." Can't open " type cr
+ [ifdef] .dhcp-server .dhcp-server [then]
+ )collect $abort
+ then ( adr filename$ r: ih )
+ 2drop " load" r@ $call-method ( len )
+ r> close-dev
+;
+
+: read-file ( adr filename$ -- len )
+ 2dup url? if load-url exit then ( adr filename$ )
+
+[ifdef] use-dhcp
+ use-bootp? use-server? 0= and bootp-only? 0= and
+ abort" The DHCP server did not specify a boot server"
+[then]
+
+ use-nfs? if nfs-read else tftpread then
+;
+
+headers
+: next-xid ( -- id ) rpc-xid 1+ dup to rpc-xid ;
+: allocate-packet ( len -- adr ) allocate-udp ;
+: free-packet ( len -- adr ) free-udp ;
+: send ( adr len src-port dst-port -- ) send-udp-packet ;
+: receive ( dst-port -- true | adr len false ) receive-udp-packet ;
+
+: nvram-ip? ( -- flag )
+ ip-address dup if ( adr len )
+ 2dup " dhcp" $= 0= if ( adr len )
+ 2dup " bootp" $= 0= if ( adr len )
+ my-ip-addr ['] $ip# catch 0= if ( )
+ ip-netmask subnetmask ['] $ip# catch if 3drop then
+ \ XXX in the absence of a netmask value, we should determine
+ \ it from my-ip-addr
+ ip-dns-server name-server-ip ['] $ip# catch if 3drop then
+ ip-router router-ip-addr ['] $ip# catch if 3drop then
+ ip-domain dup if 'domain-name place-cstr drop else 2drop then
+ true exit
+ then ( x x x )
+ drop ( x x )
+ unknown-ip-addr my-ip-addr copy-ip-addr ( x x )
+ then then then ( adr len )
+ 2drop false
+;
+
+defer configured ' noop to configured
+: configure ( -- )
+ use-last? if configured exit then
+ use-bootp? if
+ nvram-ip? 0= if process-bootp then
+ else
+ \ Use RARP to find the client's IP address if it was not specified
+ \ in the arguments.
+ my-ip-addr unknown-ip-addr? if
+ \ RARP gives my-ip-addr, his-ip-addr, his-en-addr,
+ \ The default boot file name is derived from my-ip-addr
+ do-rarp
+ else
+ use-server? if
+ bootnet-debug if
+ ." Using the server IP address specified in the arguments." cr
+ then
+ then
+ then
+
+ \ At this point, we know my-ip-addr, and we might know his-ip-addr
+ \ from RARP. However, if a server was specified in the arguments,
+ \ the his-ip-addr value from RARP is not necessarily the same as
+ \ the IP address for the user-specified server, so we override
+ \ his-ip-addr below. (If a server was not specified and we don't know
+ \ his-ip-addr from RARP, then we will broadcast the TFTP request.)
+ use-server? if
+ server-ip-addr set-dest-ip
+ then
+ then
+ show-all-en-ip-address
+ configured
+;
+
+\ complete syntax:
+\ net:[bootp|rarp,]server-ip,filename,client-ip,router-ip, ...
+\ ... #bootp-retries,#tftp-retries
+\ syntax for booting - net[:sipaddr[,[file-name][,[tipaddr][,gipaddr]]]]
+\ syntax for booting over a router (1 hop): net:sipaddr,[file-name],[tipaddr],gipaddr
+\ Note: if user provides gipaddr, user must provide sipaddr
+\ Once use-server? is set, never broadcast tftp.
+
+: open ( -- okay? )
+ open-link
+ parse-args
+ mac-address drop my-en-addr copy-en-addr
+ configure
+ s-all
+ my-self to obp-tftp-ih \ Publish so IP redirector can attach to us
+ true
+;
+
+: close ( -- )
+[ifdef] process-done-ip
+ process-done-ip
+[then]
+ close-link
+ 0 to obp-tftp-ih
+;
+
+: load ( adr -- len ) boot-filename read-file ;
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Added: ofw/inetv6/netloadv6.fth
===================================================================
--- ofw/inetv6/netloadv6.fth (rev 0)
+++ ofw/inetv6/netloadv6.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,143 @@
+\ See license at end of file
+purpose: Network loading using TFTP/IPv6.
+
+\ Network loading using TFTP. Loads either a named file using the "dload"
+\ command, or the default tftpboot file whose name is constructed from
+\ the Internet address (derived from the Neighbor Discovery)
+\ and the CPU architecture type.
+
+[ifndef] include-ipv4
+partial-headers
+d# 128 buffer: file-name-buf
+d# 256 buffer: 'root-path
+d# 32 buffer: tmpname
+false instance value bootp-only?
+
+\ Construct the file name for the second-stage boot program from
+\ the IP address and the architecture.
+: boot-filename ( -- adr len )
+ file-name-buf cscount dup if exit then ( adr len )
+ 2drop
+ push-hex
+ \ XXX Questionable code for IPv6
+ my-ipv6-addr be-l@ (.8) 2dup upper ( adr len )
+ pop-base
+ tmpname place
+ cpu-arch dup if " ." tmpname $cat tmpname $cat else 2drop then
+ tmpname count file-name-buf place-cstr drop
+ file-name-buf cscount
+;
+
+headers
+
+true instance value use-bootp?
+false instance value use-last?
+false instance value use-nfs?
+[then]
+
+headerless
+
+: delim? ( char -- flag ) dup [char] / = swap [char] \ = or ;
+
+d# 128 buffer: nfs-filename
+
+: nfs-read ( adr filename$ -- len )
+ dup if ( adr filename$ )
+ \ If the name is relative; construct a full pathname
+ over c@ delim? 0= if ( adr filename$ )
+ \ Prepend root path (if present) or "/"
+ 'root-path cscount dup 0= if ( adr filename$ root$ )
+ 2drop " /" ( adr filename$ root$ )
+ then ( adr filename$ )
+ nfs-filename pack ( adr filename$ 'buf )
+
+ \ Insert a "/" after the root path if necessary
+ count + 1- c@ delim? 0= if ( adr filename$ )
+ " /" nfs-filename $cat ( adr filename$ )
+ then ( adr filename$ )
+
+ \ Append the filename
+ nfs-filename $cat nfs-filename count ( adr filename$' )
+ then
+ then
+ bootnet-debug if ." NFS protocol: Reading file: " 2dup type cr then
+ " nfs" $open-package >r r@ 0= if
+ collect(
+ ." NFS open failed." cr
+ [ifdef] .dhcp-server .dhcp-server [then]
+ ." NFS Server: " his-ipv6-addr .ipv6 cr
+ ." Filename: " nfs-filename count type cr
+ )collect $abort
+ then ( adr r: ih )
+ " load" r@ $call-method ( len )
+ r> close-package
+;
+
+: url? ( filename$ -- flag )
+ " /\" lex if ( rem$ head$ delim )
+ drop 2swap 2drop ( head$ )
+ then ( head$ | filename$ )
+ " :" lex if 5drop true exit then ( head$ )
+ 2drop false ( false )
+;
+char / constant delim
+
+d# 255 instance buffer: pathbuf
+: fix-delims ( adr len -- adr' len' )
+ pathbuf pack count 2dup
+ bounds ?do ( adr len )
+ i c@ [char] / = if [char] \ i c! then
+ loop
+;
+
+: load-url ( adr filename$ -- len )
+ fix-delims
+ 2dup open-dev >r r@ 0= if ( adr filename$ )
+ collect(
+ ." Can't open " type cr
+ [ifdef] .dhcp-server .dhcp-server [then]
+ )collect $abort
+ then ( adr filename$ r: ih )
+ 2drop " load" r@ $call-method ( len )
+ r> close-dev
+;
+
+: read-file ( adr filename$ -- len )
+ 2dup url? if load-url exit then ( adr filename$ )
+
+[ifdef] use-dhcp
+ use-bootp? use-server? 0= and bootp-only? 0= and
+ abort" The DHCP server did not specify a boot server"
+[then]
+
+ use-nfs? if nfs-read else tftpread then
+;
+
+headers
+: next-xid ( -- id ) rpc-xid 1+ dup to rpc-xid ;
+
+: load ( adr -- len ) boot-filename read-file ;
+
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Added: ofw/inetv6/occhksum.fth
===================================================================
--- ofw/inetv6/occhksum.fth (rev 0)
+++ ofw/inetv6/occhksum.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,70 @@
+\ See license at end of file
+purpose: Internet checksum (one's complement of 16-bit words)
+
+\ The complete checksum calculation consists of:
+\ a) add together all the 16-bit big-endian words in the buffer, with
+\ wrap-around carry (i.e. a carry out of the high bit is added back
+\ in at the low bit).
+\ b) Take the one's complement of the result, preserving only the
+\ least-significant 16 bits.
+\ c) If the result is 0, change it to ffff.
+
+\ The process of computing a checksum for UDP packets involves the
+\ creation of a "pseudo header" containing selected information
+\ from the IP header, and checksumming the combination of that pseudo
+\ header and the UDP packet. To do so, it is convenient to perform
+\ step (a) of the calculation separately on the two pieces (pseudo header
+\ and UDP packet). Thus we factor the checksum calculation code with
+\ a separate primitive "(oc-checksum)" that performs step (a). That
+\ primitive is worth optimizing; steps (b) and (c) are typically not.
+
+headerless
+[ifndef] (oc-checksum)
+\ High-level version, in case an optimized version is not available.
+
+\ This algorithm depends on the assumption that the buffer is
+\ short enough so that we never have a carry out of the high
+\ 16 bit word. Assuming worst case data (all bytes ff), the
+\ buffer would have to be 128K + 3 bytes long for this to happen.
+\ The maximum length of an IP packet is 64K bytes, so we are safe.
+\ This allows us to accumulate the end-around carries in the high
+\ 16-bit word and add them in one operation at the end.
+
+: (oc-checksum) ( accumulator addr count -- checksum )
+ 2dup 2>r bounds do i xw@ + /w +loop ( sum r: adr,len )
+ \ Subtract the extra byte at the end
+ 2r> dup 1 and if + c@ - else 2drop then
+;
+[then]
+
+: oc-checksum ( accumulator addr count -- checksum )
+ (oc-checksum) ( checksum' )
+ lwsplit + lwsplit + ( checksum" )
+ invert h# 0.ffff and ( checksum )
+ \ Return ffff if the checksum is 0
+ ?dup 0= if h# 0.ffff then ( checksum )
+;
+headers
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Added: ofw/inetv6/ping.fth
===================================================================
--- ofw/inetv6/ping.fth (rev 0)
+++ ofw/inetv6/ping.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,273 @@
+\ See license at end of file
+purpose: Ping (ICMP echo) and ping daemon (ICMP echo server)
+
+: (ip-checksum) ( accumulator addr count -- checksum )
+ 2dup 2>r bounds do i be-w@ + /w +loop ( sum r: adr,len )
+ \ Subtract the extra byte at the end
+ 2r> dup 1 and if + c@ - else 2drop then
+;
+
+: ip-checksum ( accumulator addr count -- checksum )
+ (ip-checksum) ( checksum' )
+ lwsplit + lwsplit + ( checksum" )
+ invert h# 0.ffff and ( checksum )
+ \ Return ffff if the checksum is 0
+\ ?dup 0= if h# 0.ffff then ( checksum )
+;
+
+0 value ping-ih
+: open-net ( pathname$ -- )
+ dup 0= if 2drop " net" then ( pathname$' )
+ open-dev to ping-ih
+ ping-ih 0= abort" Can't open network device"
+;
+: close-net ( -- ) ping-ih close-dev ;
+: $call-net ( ? name$ -- ? ) ping-ih $call-method ;
+
+true value first?
+0 value /packet
+d# 1600 constant /packet-max
+/packet-max buffer: packet
+
+: get-packet? ( -- packet? )
+ packet /packet-max " read" $call-net to /packet
+ /packet -1 = if cr ." Packet error" cr false exit then
+ /packet -2 = if false exit then
+ ." ." true
+;
+d# 14 constant /ether-header
+0 value ip-offset
+
+: ip-header ( -- adr ) packet ip-offset + ;
+
+: ip? ( -- flag ) ip-header c@ 4 rshift 4 = ;
+: link-level-ok? ( -- flag )
+ packet c@ 1 and if
+ 0 to ip-offset
+ \ It's either a multicast Ethernet packet or a direct IP packet
+ ip? if true exit then
+ else
+ packet d# 12 + be-w@ h# 800 = if
+ /ether-header to ip-offset
+ ip? if true exit then
+ then
+ then
+ false
+;
+
+: >/ip-header ( ip-header -- len ) c@ h# f and /l* ;
+: ip-payload ( -- adr len )
+ ip-header dup >/ip-header ( ip-adr length )
+ over + ( ip-adr payload-adr )
+ swap dup 2+ be-w@ + ( payload-adr payload-end )
+ over - ( payload-adr payload-len )
+;
+: icmp? ( -- flag ) ip-header 9 + c@ 1 = ;
+: echo? ( -- flag ) ip-payload drop c@ 8 = ;
+: -exit ( flag -- ) 0= if r> drop then ;
+: .ipb ( adr -- adr' ) dup 1+ swap c@ (.) type ;
+: .ipaddr ( addr-buff -- )
+ push-decimal
+ 3 0 do .ipb ." ." loop .ipb drop
+ pop-base
+;
+: .ip ( -- )
+ ." My IP address is "
+ ip-header d# 16 + .ipaddr
+;
+: ping? ( -- flag )
+ false
+ ip? -exit
+ first? if .ip false to first? then
+
+ icmp? -exit
+ echo? -exit
+ 0=
+;
+
+: exchange-byte ( adr1 adr2 -- )
+ over c@ over c@ ( adr1 adr2 byte1 byte2 )
+ swap rot ( adr1 byte2 byte1 adr2 )
+ c! ( adr1 byte2 )
+ swap c! ( )
+;
+: exchange-bytes ( adr1 adr2 len -- )
+ 0 ?do over i + over i + exchange-byte loop 2drop
+;
+: exchange-macs ( -- )
+ ip-offset /ether-header = if
+ packet packet 6 + 6 exchange-bytes
+ then
+;
+: exchange-ips ( -- ) ip-header d# 12 + dup 4 + 4 exchange-bytes ;
+: change-type ( -- ) 0 ip-payload drop c! ;
+: recompute-ip-checksum ( -- )
+ 0 ip-header d# 10 + be-w! \ Zap IP checksum
+ ip-header dup >/ip-header ( adr len )
+ 0 -rot ip-checksum ip-header d# 10 + be-w!
+;
+
+0 instance value the-struct
+: set-struct ( adr -- ) to the-struct ;
+: sfield ( offset size -- new-offset )
+ create over , +
+ does> @ the-struct +
+;
+
+struct ( ICMP )
+ /c sfield icmp-type
+ /c sfield icmp-code
+ /w sfield icmp-checksum
+ /w sfield icmp-id
+ /w sfield icmp-seq
+ 0 sfield icmp-data
+constant /icmp-header
+
+: compute-icmp-checksum ( adr len -- )
+ over set-struct ( adr len' )
+ 0 icmp-checksum be-w! ( adr len ) \ Zap ICMP checksum
+ 0 -rot ip-checksum ( sum )
+ icmp-checksum be-w! ( )
+;
+: recompute-icmp-checksum ( -- )
+ ip-payload dup 1 and if ( adr len )
+ 2dup + 0 swap c! 1+ ( adr len' )
+ then ( adr len' )
+ compute-icmp-checksum ( )
+;
+
+: send-packet ( -- )
+ packet /packet " write" $call-net
+ /packet <> if cr ." Send failed" cr then
+;
+
+: echo-packet ( -- )
+ exchange-macs
+ exchange-ips
+ change-type
+ recompute-ip-checksum
+ recompute-icmp-checksum
+ send-packet
+;
+: ?echo-packet ( -- ) ping? if echo-packet then ;
+: handle-requests ( -- )
+ ." Type any key to quit" cr
+ begin
+ key? if key drop exit then
+ get-packet? if ?echo-packet then
+ again
+;
+
+: $pingd ( pathname$ -- )
+ true to first?
+ open-net handle-requests close-net
+;
+
+: pingd ( "device" -- ) parse-word $pingd ;
+
+d# 64 value ping-size
+d# 512 value /ping-max
+d# 10 value ping-seconds
+d# 1 value #pings
+d# 0 value icmp-sequence#
+d# 1000 value ping-gap
+
+0 value ping-packet
+0 value ping-sent-time
+
+: send-ping ( -- )
+ ping-packet to the-struct
+ get-msecs to ping-sent-time
+
+ ping-seconds d# 1000 * " set-timeout" $call-net
+
+ 8 icmp-type c!
+ 0 icmp-code c!
+ 0 icmp-id be-w!
+ icmp-sequence# dup icmp-seq be-w! 1+ to icmp-sequence#
+ icmp-data ping-size 0 do i icmp-data i + c! loop drop ( )
+
+ the-struct ping-size /icmp-header + 2dup compute-icmp-checksum
+
+ 1 " send-ip-packet" $call-net \ 1 is the ICMP protocol number
+;
+: .ping-data ( -- )
+ get-msecs ping-sent-time - ( ms )
+ ?dup if .d else ." <1 " then ." ms" cr
+;
+
+: reply-okay? ( adr len -- flag )
+ swap set-struct ( len )
+
+ \ Ignore ICMP packets other then echo replies
+ icmp-type c@ if drop false exit then ( len )
+
+ \ Verify the packet length
+ /icmp-header ping-size + 2dup <> if ( len exp )
+ ." Wrong ping reply packet size - expected " ( len exp )
+ .d ." , got " .d cr ( )
+ else ( len exp )
+ 2drop ( )
+ then ( )
+
+ icmp-seq be-w@ icmp-sequence# 1- 2dup <> if ( rseq sseq )
+ ." Sent sequence number " .d ( rseq )
+ ." , received " .d cr ( )
+ else ( rseq sseq )
+ 2drop ( )
+ then ( )
+ true
+;
+: ping-reply? ( -- okay? )
+ begin
+ 1 " receive-ip-packet" $call-net if false exit then ( adr len )
+ reply-okay?
+ until
+ true
+;
+
+: 1ping ( -- )
+ send-ping
+ ping-reply? if .ping-data else ." Timeout" cr then
+;
+: try-pings ( -- )
+ 1ping
+ #pings 1 ?do
+ ping-gap ms
+ 1ping
+ key? if key drop leave then
+ loop
+;
+
+: $ping ( ip$ -- )
+ " net//obp-tftp:last" open-net " $set-host" $call-net
+ /ping-max " allocate-ip" $call-net to ping-packet
+ try-pings
+ ping-packet /ping-max " free-ip" $call-net
+ close-net
+;
+
+: ping ( "host" -- ) safe-parse-word $ping ;
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Added: ofw/inetv6/pingv6.fth
===================================================================
--- ofw/inetv6/pingv6.fth (rev 0)
+++ ofw/inetv6/pingv6.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,164 @@
+\ See license at end of file
+purpose: Ping (ICMP echo) and ping daemon (ICMP echo server)
+
+d# 58 constant ICMPV6_TYPE
+
+[ifndef] ping
+0 value ping-ih
+: open-net ( pathname$ -- )
+ dup 0= if 2drop " net" then ( pathname$' )
+ open-dev to ping-ih
+ ping-ih 0= abort" Can't open network device"
+;
+: close-net ( -- ) ping-ih close-dev ;
+: $call-net ( ? name$ -- ? ) ping-ih $call-method ;
+[then]
+
+\ XXX There may be additional headers.
+d# 40 constant /ipv6-header
+
+[ifndef] ping
+0 instance value the-struct
+: set-struct ( adr -- ) to the-struct ;
+: sfield ( offset size -- new-offset )
+ create over , +
+ does> @ the-struct +
+;
+
+struct ( ICMP )
+ /c sfield icmp-type
+ /c sfield icmp-code
+ /w sfield icmp-checksum
+ /w sfield icmp-id
+ /w sfield icmp-seq
+ 0 sfield icmp-data
+constant /icmp-header
+[then]
+
+: handle-requestsv6 ( -- )
+ ." Type any key to quit" cr
+ begin
+ key? if key drop exit then
+ ICMPV6_TYPE " receive-ip-packet" $call-net 0= if 2drop then
+ again
+;
+
+: $pingd6 ( pathname$ -- )
+ open-net handle-requestsv6 close-net
+;
+
+: pingd6 ( ["device"] -- )
+ parse-word ?dup 0= if drop " net//obp-tftp:last" then
+ $pingd6
+;
+
+[ifndef] ping
+d# 64 value ping-size
+d# 512 value /ping-max
+d# 10 value ping-seconds
+d# 1 value #pings
+d# 0 value icmp-sequence#
+d# 1000 value ping-gap
+
+0 value ping-packet
+0 value ping-sent-time
+[then]
+
+: send-pingv6 ( -- )
+ ping-packet to the-struct
+ get-msecs to ping-sent-time
+
+ ping-seconds d# 1000 * " set-timeout" $call-net
+
+ d# 128 icmp-type c!
+ 0 icmp-code c!
+ 0 icmp-id be-w!
+ icmp-sequence# dup icmp-seq be-w! 1+ to icmp-sequence#
+ icmp-data ping-size 0 do i icmp-data i + c! loop drop ( )
+
+ the-struct ping-size " send-icmpv6-packet" $call-net
+;
+
+[ifndef] ping
+: .ping-data ( -- )
+ get-msecs ping-sent-time - ( ms )
+ ?dup if .d else ." <1 " then ." ms" cr
+;
+[then]
+
+: reply-okayv6? ( adr len -- flag )
+ swap set-struct ( len )
+
+ \ Ignore ICMP packets other then echo replies
+ icmp-type c@ d# 129 <> if drop false exit then ( len )
+
+ \ Verify the packet length
+ /icmp-header ping-size + 2dup <> if ( len exp )
+ ." Wrong ping reply packet size - expected " ( len exp )
+ .d ." , got " .d cr ( )
+ else ( len exp )
+ 2drop ( )
+ then ( )
+
+ icmp-seq be-w@ icmp-sequence# 1- 2dup <> if ( rseq sseq )
+ ." Sent sequence number " .d ( rseq )
+ ." , received " .d cr ( )
+ else ( rseq sseq )
+ 2drop ( )
+ then ( )
+ true
+;
+: ping-replyv6? ( -- okay? )
+ begin
+ ICMPV6_TYPE " receive-ip-packet" $call-net if false exit then ( adr len )
+ reply-okayv6?
+ until
+ true
+;
+
+: 1pingv6 ( -- )
+ send-pingv6
+ ping-replyv6? if .ping-data else ." Timeout" cr then
+;
+: try-pingsv6 ( -- )
+ 1pingv6
+ #pings 1 ?do
+ ping-gap ms
+ 1pingv6
+ key? if key drop leave then
+ loop
+;
+
+: $ping6 ( ip$ -- )
+ " net//obp-tftp:last" open-net " $set-host" $call-net
+ /ping-max " allocate-ipv6" $call-net to ping-packet
+ try-pingsv6
+ ping-packet /ping-max " free-ipv6" $call-net
+ close-net
+;
+
+: ping6 ( "host" -- ) safe-parse-word $ping6 ;
+
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Added: ofw/inetv6/pop3.fth
===================================================================
--- ofw/inetv6/pop3.fth (rev 0)
+++ ofw/inetv6/pop3.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,283 @@
+\ See license at end of file
+purpose: Read your mail from the firmware
+
+\ Connect to a POP3 server and read your mail.
+
+0 value #messages
+
+: open-pop3-connection ( pop-server$ -- ok? )
+ \ The TCP port # for POP3 is d# 110
+ " $set-host" call-tcp
+ d# 110 " connect" call-tcp ( ok? )
+;
+
+: close-pop3-connection ( -- )
+ " disconnect" call-tcp
+;
+
+: close-pop3 ( -- )
+ close-pop3-connection ( )
+ tcp-ih close-dev ( )
+ 0 to tcp-ih ( )
+ free-mail-buffer ( )
+;
+
+
+: verify-pop3 ( -- ok? )
+ get-reply 0= if ( )
+ false exit ( bad )
+ then ( bad )
+ " +OK" reply-good? ( ok? )
+;
+
+: send-one ( $ -- ok? ) >mail-buffer " +OK" send ( ok? ) ;
+: send-two ( $2 $1 -- ok? ) >mail-buffer mail-append " +OK" send ( ok? ) ;
+
+: send-user-name ( -- ok? )
+ " pop-user" $getenv drop ( adr len )
+ " USER " send-two ( ok? )
+;
+: send-password ( -- ok? )
+ " pop-password" $getenv drop ( adr len )
+ " PASS " send-two ( ok? )
+;
+
+: number? ( b -- ascii? )
+ h# 30 h# 39 between if
+ true
+ else
+ false
+ then
+;
+
+h# 8 buffer: pop3-buf
+0 value tbuf-ptr
+
+: +tbuf ( -- ) tbuf-ptr 1+ to tbuf-ptr ;
+
+: >tbuf ( n -- )
+ dup number? 0= if
+ drop
+ 0 pop3-buf tbuf-ptr + c!
+ exit
+ then
+ pop3-buf tbuf-ptr + c!
+ +tbuf
+;
+
+: convert# ( -- # )
+ 0 to tbuf-ptr
+ 0 \ Starting value
+ begin
+ pop3-buf tbuf-ptr + c@ h# 30 h# 39 between
+ while
+ d# 10 *
+ pop3-buf tbuf-ptr + c@ h# 0f and +
+ +pop3-buf
+ repeat ( # )
+;
+
+: get-num ( -- )
+ 0 to pop3-buf-ptr
+ begin
+ begin key? until
+ key dup emit ( key )
+ dup >tbuf ( key )
+ number? 0= ( flag )
+ until
+;
+
+: quit-mail ( -- ok? ) " QUIT" send-one ( ok? ) ;
+: get-status ( -- ok? ) " STAT" send-one ( ok? ) ;
+: flush ( -- ) begin key? while key drop repeat ;
+
+: num>ascii ( n -- $ )
+ (u.)
+;
+
+: (get-msg) ( n$ cmd$ -- count )
+ >mail-buffer
+ mail-append
+ " +OK" send ( ok )
+ 0= if false exit then
+
+ \ Get message text...
+ get-reply ( count )
+;
+: get-msg ( i -- ok? )
+ num>ascii ( n$ )
+ " RETR " ( n$ cmd$ )
+ (get-msg) ( len )
+;
+
+: get-list ( -- )
+ cr
+ #messages 0= if ." You have no messages." cr exit then
+
+ #messages 1+ 1 do
+ i . ." " i get-msg drop set-ptr mail-buffer mail-ptr type cr
+ loop
+ cr
+;
+
+: read-msg ( -- )
+ cr
+ #messages 0= if ." You have no messages." cr exit then
+
+ flush
+ begin
+ ." Enter message number: "
+ get-num cr ( )
+ convert# ( # )
+ dup #messages > if ( #' )
+ drop false ( false )
+ ." Invalid message number. Try again" cr
+ else
+ true ( #' true )
+ then
+ until ( #' )
+
+ #line off
+
+ get-msg ( actual )
+ cr
+ mail-buffer swap list
+ cr
+;
+
+: get-com ( -- b ) begin key? until key dup emit ;
+
+: dialog ( -- )
+ flush
+ begin
+ ." Enter Command (List Read Quit): "
+ get-com ( char )
+ upc dup ( char char )
+ ascii Q <>
+ while ( char )
+ case
+ ascii L of get-list endof
+ ascii R of read-msg endof
+ ascii I of abort endof \ Path to debugging...
+ ( default ) ." Bad input, try again..." cr
+ endcase
+ repeat
+ drop
+ quit-mail drop
+;
+
+: rmail ( -- )
+
+ false
+
+ " pop-server" $getenv if
+ cr
+ ." Missing pop-server environment variable" cr
+ ." Use ""$setenv"" to set the pop-server name:" cr
+ ." "" <servername>"" "" pop-server"" $setenv" cr
+ drop true
+ else 2drop then
+
+ " pop-user" $getenv if
+ cr
+ ." Missing pop-user environment variable" cr
+ ." Use ""$setenv"" to set the pop-user name:" cr
+ ." "" <username>"" "" pop-user"" $setenv" cr
+ drop true
+ else 2drop then
+
+ " pop-password" $getenv if
+ cr
+ ." Missing pop-password environment variable" cr
+ ." Use ""$setenv"" to set the pop-password name:" cr
+ ." "" <password>"" "" pop-password"" $setenv" cr
+ drop true
+ else 2drop then
+
+ if exit then
+
+ debug-mail? if ." Opening TCP stack..." cr then
+
+ " tcp" open-dev to tcp-ih
+ tcp-ih 0= if ." Failed to open tcp stack!" exit then
+
+ allocate-mail-buffer
+
+ " pop-server" $getenv drop open-pop3-connection 0= if
+ close-pop3 exit
+ then
+
+ debug-mail? if ." Connection established" cr then
+
+ verify-pop3 0= if
+ debug-mail? if ." Connection did not verify" cr then
+ close-pop3 exit
+ then
+
+ debug-mail? if ." Sending USER name..." cr then
+ send-user-name if
+ debug-mail? if ." USER accepted" cr then
+ else
+ debug-mail? if ." Bad USER" cr then
+ close-pop3
+ exit
+ then
+
+ debug-mail? if ." Sending password..." cr then
+ send-password if
+ debug-mail? if ." Password accepted" cr then
+ else
+ debug-mail? if ." Bad Password" cr then
+ close-pop3
+ exit
+ then
+
+ debug-mail? if ." Getting status..." cr then
+ 0 to #messages
+ get-status if
+ 1 get-number ( #msgs )
+ to #messages ( )
+ ." You have " #messages .d ." messages." cr
+ else
+ debug-mail? if ." Get status failed" cr then
+ then
+
+ dialog
+
+ close-pop3
+;
+
+: (show-pop3) ( adr len -- )
+ 2dup $getenv if missing-var else
+ 2swap type ." : " type cr
+ then
+;
+
+: show-pop3 ( -- )
+ " pop-server" (show-pop3)
+ " pop-user" (show-pop3)
+ " pop-password" (show-pop3)
+;
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Added: ofw/inetv6/random.fth
===================================================================
--- ofw/inetv6/random.fth (rev 0)
+++ ofw/inetv6/random.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,32 @@
+\ See license at end of file
+purpose: Random number generator (using linear congruence)
+
+instance variable rn \ Random number
+
+: random ( -- n )
+ rn @ d# 1103515245 * d# 12345 + h# 7FFFFFFF and dup rn !
+;
+
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Added: ofw/inetv6/smtp.fth
===================================================================
--- ofw/inetv6/smtp.fth (rev 0)
+++ ofw/inetv6/smtp.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,191 @@
+\ See license at end of file
+purpose: SMTP, Send mail from the firmware.
+
+\ Connect to an SMTP server, send some mail.
+
+: open-smtp-connection ( smtp-server$ -- ok? )
+ \ The TCP port # for SMTP is d# 25
+ " $set-host" call-tcp
+ d# 25 " connect" call-tcp ( ok? )
+;
+
+: close-smtp-connection ( -- )
+ " disconnect" call-tcp
+;
+
+: close-smtp ( -- )
+ close-smtp-connection ( )
+ tcp-ih close-dev ( )
+ 0 to tcp-ih ( )
+ mail-buffer /mail-buffer free-mem ( )
+;
+
+: verify-smtp ( -- ok? )
+ get-reply 0= if ( )
+ false exit ( bad )
+ then ( bad )
+ " 220" reply-good? ( ok? )
+;
+
+: smtp-quit ( -- ok? )
+ " QUIT" >mail-buffer ( )
+ " 221" send ( ok? )
+;
+
+: smtp-rset ( -- ok? )
+ " RSET" >mail-buffer ( )
+ " 250" send ( ok? )
+;
+
+: smtp-hello ( -- ok? )
+ " HELO " >mail-buffer
+ " smtp-my-hostname" $getenv drop mail-append
+ " 250" send ( ok? )
+;
+
+: add-terminator ( -- ) \ Send "crlf . crlf"
+ add-crlf ( )
+ " ." mail-append ( )
+;
+
+: smtp-mail ( -- ok? )
+ " MAIL " >mail-buffer
+ " FROM:" mail-append
+ " smtp-from-path" $getenv drop mail-append
+ " 250" send ( ok? )
+;
+
+: smtp-rcpt ( -- ok? )
+ " RCPT " >mail-buffer
+ " TO:" mail-append
+ " smtp-to-path" $getenv drop mail-append
+ " 250" send ( ok? )
+;
+
+: smtp-data ( adr len -- ok? )
+ " DATA " >mail-buffer ( adr len )
+ " 354" send ( adr len ok? )
+ 0= if ( adr len )
+ debug-mail? if ( adr len )
+ ." Data send failure" cr ( adr len )
+ then ( adr len )
+ 2drop 0 ( 0 )
+ exit ( 0 )
+ then ( 0 )
+
+ >mail-buffer ( )
+ add-terminator ( )
+
+ " 250" send ( ok? )
+;
+
+: sendmail ( adr len -- ok? )
+
+ ?dup 0= if drop false exit then \ no data, no send
+
+ false
+
+ " smtp-server" $getenv if
+ cr
+ ." Missing smtp-server environment variable" cr
+ ." Use ""$setenv"" to set the smtp-server name:" cr
+ ." "" <servername>"" "" smtp-server"" $setenv" cr
+ drop true
+ else 2drop then
+
+ " smtp-from-path" $getenv if
+ cr
+ ." Missing smtp-from-path environment variable" cr
+ ." Use ""$setenv"" to set the smtp-from-path name:" cr
+ ." "" <return-address>"" "" smtp-from-path"" $setenv" cr
+ drop true
+ else 2drop then
+
+ " smtp-to-path" $getenv if
+ cr
+ ." Missing smtp-to-path environment variable" cr
+ ." Use ""$setenv"" to set the smtp-to-path name:" cr
+ ." "" <address>"" "" smtp-to-path"" $setenv" cr
+ drop true
+ else 2drop then
+
+ " smtp-my-hostname" $getenv if
+ cr
+ ." Missing smtp-my-hostname environment variable" cr
+ ." Use ""$setenv"" to set the smtp-my-hostname name:" cr
+ ." "" <hostname>"" "" smtp-my-hostname"" $setenv" cr
+ drop true
+ else 2drop then
+
+ if false exit then ( false ) \ Error out
+
+ debug-mail? if ." Opening TCP stack..." cr then
+
+ " tcp" open-dev to tcp-ih
+ tcp-ih 0= if ." Failed to open tcp stack!" exit then
+
+ allocate-mail-buffer
+
+ " smtp-server" $getenv drop open-smtp-connection 0= if
+ close-smtp exit
+ then
+
+ debug-mail? if ." Connection established" cr then
+
+ verify-smtp 0= if
+ debug-mail? if ." Connection did not verify" cr then
+ close-smtp exit
+ then
+
+ smtp-hello drop ( adr len )
+
+ ( adr len ) smtp-rset 0= if close-smtp false exit then ( 0 )
+ ( adr len ) smtp-mail 0= if close-smtp false exit then ( 0 )
+ ( adr len ) smtp-rcpt 0= if close-smtp false exit then ( 0 )
+ ( adr len ) smtp-data 0= if close-smtp false exit then ( 0 )
+
+ smtp-quit drop ( )
+
+ close-smtp ( )
+ true ( ok )
+;
+
+: test-msg ( -- adr len )
+ " "n"nThis message was brought to you by FirmWorks' SMTP package"r"n"
+;
+
+: (show-smtp) ( adr len -- )
+ 2dup $getenv if missing-var else
+ 2swap type ." : " type cr
+ then
+;
+
+: show-smtp ( -- )
+ " smtp-server" (show-smtp)
+ " smtp-from-path" (show-smtp)
+ " smtp-to-path" (show-smtp)
+ " smtp-my-hostname" (show-smtp)
+;
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Added: ofw/inetv6/support.fth
===================================================================
--- ofw/inetv6/support.fth (rev 0)
+++ ofw/inetv6/support.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,69 @@
+\ See license at end of file
+purpose: Support functions for IP stack
+
+true value friendly? \ True for verbose messages
+
+[ifdef] include-ipv4 false [else] true [then]
+instance value use-ipv6?
+
+0 instance value the-struct
+: set-struct ( adr -- ) to the-struct ;
+: +struct ( offset -- ) the-struct + set-struct ;
+
+: payload ( length header-length -- contents-adr,len )
+ the-struct -rot /string
+;
+
+: sfield ( offset size -- new-offset )
+ create over , +
+ does> @ the-struct +
+;
+
+\ Access to composite data in Internet byte order (big-endian)
+
+alias xc! c!
+alias xw! be-w!
+alias xw@ be-w@
+\ : xw! ( w adr -- ) >r wbsplit r@ c! r> 1+ c! ;
+\ : xw@ ( adr -- w ) dup 1+ c@ swap c@ bwjoin ;
+alias xl! be-l!
+alias xl@ be-l@
+
+instance variable alarmtime
+headers
+: current-timeout ( -- n ) alarmtime @ ;
+: restore-timeout ( n -- ) alarmtime ! ;
+: set-timeout ( interval -- )
+ dup if get-msecs + then alarmtime !
+;
+
+headerless
+
+: timeout? ( -- flag )
+ alarmtime @ if get-msecs alarmtime @ >= else true then
+;
+: ipv4? ( ip-adr -- flag ) 2 - xw@ h# 800 = ;
+
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Added: ofw/inetv6/supportv6.fth
===================================================================
--- ofw/inetv6/supportv6.fth (rev 0)
+++ ofw/inetv6/supportv6.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,149 @@
+\ See license at end of file
+purpose: Internet Protocol version 6 (IPv6) miscellaneous methods
+
+hex
+
+d# 16 constant /ipv6 \ Bytes per IP address
+/ipv6 buffer: my-ipv6-addr
+
+: copy-ipv6-addr ( src dst -- ) /ipv6 move ;
+
+: .ipv6 ( buf -- )
+ push-hex
+ <# dup /ipv6 + 2 - do i be-w@ u#s ascii : hold drop -2 +loop 0 u#> 1 /string
+ pop-base
+ type space
+;
+
+0 value ipv6-ptr
+0 value ipv6-cur-ptr
+0 value ipv6-::-ptr
+: ipv6-end-ptr ( -- adr ) ipv6-ptr /ipv6 + ;
+: ipv6-c! ( n -- ) ipv6-cur-ptr tuck c! ca1+ to ipv6-cur-ptr ;
+: ipv6-w! ( n -- ) ipv6-cur-ptr tuck be-w! wa1+ to ipv6-cur-ptr ;
+: ipv6-end? ( -- flag ) ipv6-cur-ptr ipv6-end-ptr u>= ;
+: ipv4-ok? ( -- flag ) ipv6-end-ptr ipv6-cur-ptr - 4 >= ;
+: decimal-byte ( adr,len -- n )
+ push-decimal ['] safe->number catch pop-base ( n 0 | x x error )
+ throw
+ dup d# 255 u> throw ( n )
+;
+: hex-word ( adr,len -- n )
+ push-hex ['] safe->number catch pop-base ( n 0 | x x error )
+ throw ( n )
+ dup h# ffff u> throw ( n )
+;
+: ($ipv6#) ( ip$ buf -- )
+ 0 to ipv6-::-ptr
+ dup /ipv6 erase
+ dup to ipv6-ptr to ipv6-cur-ptr
+ begin dup while ( ip$ )
+ ascii : left-parse-string ( r$ l$ )
+ ?dup if \ hex-word or decimal ipv4 address
+ ipv6-end? throw
+ 2 pick if \ Not the last field: hex-word
+ hex-word ipv6-w! ( r$ )
+ else \ Last field: hex-word or ipv4 adr
+ ascii . left-parse-string ( r$' l$ )
+ 2 pick if \ Decimal ipv4 address
+ ipv4-ok? not throw
+ decimal-byte ipv6-c!
+ 3 0 do
+ ascii . left-parse-string ( r$ l$ )
+ decimal-byte ipv6-c!
+ loop 2drop ( r$ )
+ else
+ hex-word ipv6-w! 2drop ( r$ )
+ then
+ then
+ else
+ drop ( r$ )
+ ipv6-::-ptr throw
+ then
+ dup if
+ over c@ ascii : = if
+ ipv6-::-ptr throw
+ 1 /string ipv6-cur-ptr to ipv6-::-ptr
+ then
+ then
+ repeat 2drop ( )
+ ipv6-::-ptr if \ :: encountered, insert zeroes
+ ipv6-cur-ptr ipv6-::-ptr - >r \ # of bytes to shift right
+ ipv6-::-ptr ipv6-end-ptr r@ - r@ move \ Shift right
+ ipv6-::-ptr ipv6-end-ptr r> - over - erase \ Zero for ::
+ else
+ ipv6-end? 0= throw
+ then
+;
+
+: $ipv6# ( ip$ buf -- )
+ ['] ($ipv6#) catch abort" Invalid IPv6 address"
+;
+
+: .ipv4-not-supported ( -- )
+ " IPv4 is not supported." $abort
+;
+
+0 [if]
+
+Test cases:
+
+" 2001:0DB8:0000:0000:0202:B3FF:FE1E:8329"
+" 2001:db8:0:0:202:b3ff:fe1e:8329"
+" 2001:db8::202:b3ff:fe1e:8329"
+" 2001:db8::"
+" 2000::"
+" fe80::a00:46ff:fe64:768d"
+" ::"
+" ::1234"
+" ::192.168.0.2"
+" 0:0:0:0:0:0:192.168.0.2"
+" ::c0a8:2"
+
+Erroneous test cases:
+
+" 123::456::789"
+" xyz::"
+" ::xyz"
+" 123::456:xyz"
+" xyz:123::456"
+" 123:::456" \ Error was not caught!
+" 123"
+" 123:456"
+" ::192.xy.1.102"
+" 192.168.1.102"
+" ::192.168.1.2:1234"
+" 0:0:0:0:0:192.168.0.2"
+" 0:0:0:0:0:0:0:192.168.0.2"
+" 0:1:2:3:4:5:6:7:8:9:a:b:c:d:e:f:10:11:12"
+
+load-base $ipv6#
+load-base .ipv6
+
+[then]
+
+headers
+
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Added: ofw/inetv6/tcp.fth
===================================================================
--- ofw/inetv6/tcp.fth (rev 0)
+++ ofw/inetv6/tcp.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,2418 @@
+\ See license at end of file
+purpose: TCP package
+
+hex
+
+[ifndef] show"
+also forth definitions
+: show" [char] " parse 2drop ; immediate
+previous definitions
+[then]
+\ : xh 2dup type space ($header) ; ' xh is $header
+
+false instance value debug?
+false instance value abort-on-reconnect?
+
+\ : ( postpone .( cr ; immediate
+: l+! +! ;
+
+\ : debug" postpone ." postpone cr ; immediate
+: (drop$) skipstr 2drop ;
+: drop$ +level postpone (drop$) ," -level ; immediate
+: debug" debug? if postpone ." postpone cr else postpone drop$ then ; immediate
+
+alias l>n noop
+: ?exit if r> drop then ;
+4 constant /i
+: copy-ip-addr /i move ;
+: oc-checksum ( n adr len -- n' ) " oc-checksum" $call-parent ;
+
+2 constant pr_slowhz
+
+false instance value alive?
+0 instance value the-struct
+
+: sfield ( offset size -- new-offset )
+ create over , +
+ does> @ the-struct +
+;
+
+: set-struct ( adr -- ) to the-struct ;
+: +struct ( offset -- ) the-struct + set-struct ;
+
+
+\ Check:
+\ unsigned comparison
+\ segment wraparound
+
+0 constant closed \ closed
+1 constant listen \ listening for connection
+2 constant syn_sent \ active, have sent syn
+3 constant syn_received \ have send and received syn
+\ states < ESTABLISHED are those where connections not established
+4 constant established \ established
+5 constant close_wait \ rcvd fin, waiting for close
+\ states > CLOSE_WAIT are those where user has closed
+6 constant fin_wait_1 \ have closed, sent fin
+7 constant closing \ closed xchd FIN; await FIN ACK
+8 constant last_ack \ had fin and close; await FIN ACK
+\ states > CLOSE_WAIT && < FIN_WAIT_2 await ACK of FIN
+9 constant fin_wait_2 \ have closed, fin is acked
+d# 10 constant time_wait \ in 2*msl quiet wait after close
+
+struct \ ip-pseudoheader
+ 9 sfield ih_x1
+ 1 sfield ih_pr
+ 2 sfield ih_len
+ /i sfield ih_src
+ /i sfield ih_dst
+constant /pip
+
+struct \ tcphdr
+ /w sfield th_sport \ source port
+ /w sfield th_dport \ destination port
+ /l sfield th_seq \ sequence number
+ /l sfield th_ack \ acknowledgement number
+ /c sfield th_off4 \ Data offset in high nibble
+ /c sfield th_flags
+h# 01 constant fin
+h# 02 constant syn
+h# 04 constant rst
+h# 08 constant th_push
+h# 10 constant ack
+h# 20 constant urg
+ /w sfield th_win \ window
+ /w sfield th_sum \ checksum
+ /w sfield th_urp \ urgent pointer
+constant /tcphdr
+
+: ip-struct ( -- ) /pip negate +struct ;
+: tcp-struct ( -- ) /pip +struct ;
+
+listnode
+ /n field >offset \ Offset into buf of the still-useful data
+ /n field >len \ Length, including out-of-band data
+ /n field >dlen \ Length, excluding out-of-band data
+ /n field >bufadr \ Buffer address
+ /n field >bufsize \ Total length of buffer
+ /l field >seq \ Sequence number
+ /c field >flags \ Flags
+nodetype: tcpqnode
+
+instance variable tcpq \ Linked list of packets to be reassembled
+0 tcpq !
+
+3 constant tcprexmtthresh \ Retransmission threshold
+
+d# 512 constant mssdflt \ Default value for maximum segment size
+3 constant rttdflt
+pr_slowhz rttdflt * constant srttdflt \ assumed RTT if no info
+
+pr_slowhz d# 30 * constant tcptv_msl \ max seg lifetime (hah!)
+
+
+d# 4096 constant mssmax \ Our (arbitrary) maximum value for
+ \ Maximum segment size, to conserve memory
+
+0 value rbuf-adr
+0 value rbuf-len
+0 value rbuf-actual
+: rbuf-space ( -- n ) rbuf-len rbuf-actual - ;
+
+\ State of this TCP
+0 instance value t_flags
+h# 01 constant acknow \ ack peer immediately
+h# 02 constant delack \ ack, but try to delay it
+h# 04 constant nodelay \ don't delay packets to coalesce
+h# 08 constant noopt \ don't use tcp options
+h# 10 constant sentfin \ have sent FIN
+0 [if]
+h# 20 constant req_scale \ have/will request window scaling
+h# 40 constant rcvd_scale \ other side has requested scaling
+[then]
+
+string-array state-names
+ ," CLOSED"
+ ," LISTEN"
+ ," SYN_SENT"
+ ," SYN_RECEIVED"
+ ," ESTABLISHED"
+ ," CLOSE_WAIT"
+ ," FIN_WAIT_1"
+ ," CLOSING"
+ ," LAST_ACK"
+ ," FIN_WAIT_2"
+ ," TIME_WAIT"
+end-string-array
+
+d# 512 instance value t_maxseg \ maximum segment size
+0 instance value ts \ state of this connection
+: set-state ( state -- )
+ to ts
+ debug? if ts state-names count type cr then
+;
+
+\ Timers
+instance variable tcpt_rexmt tcpt_rexmt off
+instance variable tcpt_persist tcpt_persist off
+instance variable tcpt_keep tcpt_keep off
+instance variable tcpt_2msl tcpt_2msl off
+
+: canceltimers ( -- )
+ tcpt_rexmt off
+ tcpt_persist off
+ tcpt_keep off
+ tcpt_2msl off
+;
+0 instance value t_dupacks \ consecutive dup acks recd
+0 instance value t_force \ true if forcing out a byte
+
+\ receive sequence variables
+0 instance value rcv_wnd \ receive window
+0 instance value rcv_nxt \ receive next
+0 instance value rcv_up \ receive urgent pointer
+0 instance value irs \ initial receive sequence number
+
+0 instance value rcv_adv \ advertised window
+
+: .flags ( flags -- )
+ dup fin and if ." FIN " then
+ dup syn and if ." SYN " then
+ dup rst and if ." RST " then
+ dup th_push and if ." PUSH " then
+ dup ack and if ." ACK " then
+ dup urg and if ." URG " then
+ drop
+;
+: .pkt ( flags win ack seq -- )
+ push-hex
+ ." Seq: " th_seq be-l@ 8 u.r
+ ." Ack: " th_ack be-l@ 8 u.r
+ ." Win: " th_win be-w@ 4 u.r
+ ." Len: " ip-struct ih_len be-w@ /tcphdr - 4 u.r tcp-struct
+ ." Flags: " th_flags c@ .flags
+ cr
+ pop-base
+;
+
+
+: +rcv_nxt ( n -- ) rcv_nxt + to rcv_nxt ;
+
+0 value wbuf-start
+0 value wbuf-adr
+0 value wbuf-top
+0 value wbuf-end
+0 value wbuf-threshold
+
+d# 1024 d# 16 * constant /wbuf
+: wbuf-clear ( -- )
+ wbuf-start /wbuf + to wbuf-end
+ wbuf-start dup to wbuf-adr to wbuf-top
+ wbuf-start /wbuf 2/ + to wbuf-threshold
+;
+: wbuf-allocate ( -- )
+ /wbuf alloc-mem to wbuf-start
+ wbuf-clear
+;
+
+: wbuf-actual ( -- n ) wbuf-top wbuf-adr - ;
+: wbuf-avail ( -- n ) wbuf-end wbuf-top - ;
+
+\ Remove n bytes of data from the beginning of the write buffer
+: wbuf-drop ( n -- )
+ wbuf-adr + to wbuf-adr
+ \ If there are enough empty bytes at the beginning to make
+ \ it worthwhile to do so, copy the data down to make more
+ \ space at the end.
+ wbuf-adr wbuf-threshold >= if
+ wbuf-adr wbuf-start wbuf-actual move \ Copy bytes down
+ wbuf-actual wbuf-start + to wbuf-top \ Fix pointers
+ wbuf-start to wbuf-adr
+ then
+;
+
+\ send sequence variables
+0 instance value snd_una \ send unacknowledged
+0 instance value snd_nxt \ send next
+0 instance value snd_up \ send urgent pointer
+0 instance value snd_wl1 \ window update seg seq number
+0 instance value snd_wl2 \ window update seg ack number
+0 instance value snd_wnd \ send window
+1 value iss \ initial send sequence number
+true value first-time? \ Used to prime iss.
+1 value tcp_iss \ initial send sequence number
+
+0 instance value snd_max \ highest sequence number send
+ \ used to recognize retransmits
+
+d# 65535 constant maxwin \ largest value for unscaled window
+d# 12 constant maxrxtshift \ maximum retransmits
+
+d# 120 d# 60 * pr_slowhz *
+ constant keepidle \ time before keepalive probes begin
+
+d# 75 pr_slowhz *
+ constant keepintvl \ time between keepalive probes
+
+d# 75 pr_slowhz *
+ constant keep_init \ initial connect keep alive
+
+0 instance value maxidle
+
+\ congestion control (for slow start, source quench, retransmit after loss)
+maxwin instance value snd_cwnd \ congestion-controlled window
+maxwin instance value snd_ssthresh \ snd_cwnd size threshhold for slow
+ \ start exponential to linear switch
+
+\ transmit timing stuff. See below for scale of srtt and rttvar.
+\ "Variance" is actually smoothed difference.
+ \ Init srtt to 0, so we can tell that we have no
+ \ rtt estimate. Set rttvar so that srtt + 2 * rttvar gives
+ \ reasonable initial retransmit time.
+
+0 instance value t_idle \ inactivity time
+0 instance value t_rtt \ round trip time
+0 instance value t_rtseq \ sequence number being timed
+0 instance value t_srtt \ smoothed round-trip time
+3 pr_slowhz * 2 2+ 1- lshift
+ instance value t_rttvar \ variance in round-trip time
+pr_slowhz instance value t_rttmin \ minimum rtt allowed
+0 instance value max_sndwnd \ largest window peer has offered
+
+\ out-of-band data
+0 instance value t_oobflags \ have some
+ 1 constant havedata
+ 2 constant haddata
+0 instance value t_iobc \ input character
+
+
+0 instance value xmit_buf
+
+\ Information about the current packet
+
+0 value iflags \ Copy of input packet flags
+0 value iseq \ Copy of input packet sequence number
+0 value iack \ Copy of input packet sequence number
+0 value iwin \ Copy of input packet sequence window pointer
+0 value iurp \ Copy of input packet urgent pointer
+0 value ilen \ Copy of input packet length (from IP header)
+0 value ilen-save \ Copy of input packet length (from IP header), unmolested
+
+0 value doff \ Offset to data (after options)
+0 value #oob \ # of urgent data bytes elided
+: idata ( -- adr ) the-struct doff + ;
+: idlen ( -- len ) ilen #oob - ;
+: -ilen ( n -- ) negate ilen + to ilen ;
+
+d# 64 pr_slowhz * constant rexmtmax
+: rexmtval ( -- n ) t_srtt 3 rshift t_rttvar 2 rshift + ;
+
+0 instance value t_rxtshift \ log(2) of rexmt exp. backoff
+rexmtval pr_slowhz max pr_slowhz d# 64 * min
+ instance value t_rxtcur \ current retransmit value
+
+: set-snd_nxt ( n -- ) to snd_nxt ;
+: set-cwnd ( n -- ) to snd_cwnd debug? if ." snd_cwnd set to " snd_cwnd u. cr then ;
+
+: +snd_nxt ( n -- ) snd_nxt + set-snd_nxt ;
+
+alias seq@ be-l@
+alias len@ be-w@
+
+\ Sequence numbers are 32-bit integers that use circular arithmetic
+: s< ( s1 s2 -- flag ) - l>n 0< ;
+: s> ( s1 s2 -- flag ) - l>n 0> ;
+: s<= ( s1 s2 -- flag ) - l>n 0<= ;
+: s>= ( s1 s2 -- flag ) - l>n 0>= ;
+
+: rcvseqinit ( -- ) irs 1+ dup to rcv_adv to rcv_nxt ;
+
+: sendseqinit ( -- )
+ iss dup to snd_up dup to snd_max dup set-snd_nxt to snd_una
+;
+d# 125 d# 1024 * constant issincr \ Increments for iss each second
+
+: his-ip-addr ( -- 'ip ) " his-ip-addr" $call-parent ;
+: my-ip-addr ( -- 'ip ) " my-ip-addr" $call-parent ;
+: $set-host ( $ -- ) " $set-host" $call-parent ;
+: set-dest-ip ( 'ip -- ) " set-dest-ip" $call-parent ;
+: local? ( -- flag )
+ " netmask" $call-parent unaligned-l@ >r
+ my-ip-addr l@ r@ and his-ip-addr l@ r> and =
+;
+
+0 instance value my-tcp-port
+0 instance value his-tcp-port
+/tcphdr /pip + instance buffer: t_template
+: make-template ( -- )
+ t_template set-struct
+ the-struct /tcphdr /pip + erase
+
+ 6 ih_pr c! \ IPPROTO_TCP
+ my-ip-addr ih_src copy-ip-addr
+ his-ip-addr ih_dst copy-ip-addr
+
+ tcp-struct
+
+ my-tcp-port th_sport be-w!
+ his-tcp-port th_dport be-w!
+
+ 5 4 lshift th_off4 c!
+;
+
+: copy-to-rbuf ( adr len -- )
+ tuck rbuf-adr rbuf-actual + swap move ( len )
+ rbuf-actual + to rbuf-actual ( )
+;
+: copy-from-rbuf ( adr len -- len' )
+ rbuf-actual min tuck ( len' adr len' )
+ rbuf-adr -rot move ( len' )
+ dup rbuf-actual = if ( len' )
+ 0 to rbuf-actual ( len' )
+ else ( len' )
+ \ Shuffle the remaining data down in the buffer
+ rbuf-actual over - to rbuf-actual ( len' )
+ rbuf-adr over + rbuf-adr rbuf-actual move ( len' )
+ then ( len' )
+;
+
+\ Reassembly queue management
+
+: release-tcpnode ( prev this -- )
+ \ Release the packet buffer
+ dup >bufsize @ ?dup if ( prev this len )
+ over >bufadr @ swap free-mem ( prev this )
+ then ( prev this )
+ drop delete-after tcpqnode free-node ( )
+;
+
+\ Present data to caller, advancing rcv_nxt through
+\ completed sequence space.
+: present-data ( -- flags )
+ \ Exit if we have no buffer space in which to return data
+ rbuf-len 0= if 0 exit then
+
+ \ Exit if the connection is not up
+ ts established < if 0 exit then
+
+ \ Exit if the queue is empty (i.e. there's no data to present)
+ tcpq >next-node ?dup 0= if 0 exit then ( first-node )
+
+ \ Exit if the data to be returned next has not yet arrived
+ dup >seq l@ rcv_nxt <> if drop 0 exit then ( first-node )
+
+ \ Exit if we're not quite connected
+ \ This can't happen because of the earlier check for ts=established
+\ dup >dlen @ 0<> ts syn_received = and if drop 0 exit then ( node )
+
+ begin ( node )
+ dup >flags c@ fin and swap ( flags node )
+
+ \ Compute the copy length
+ dup >dlen @ rbuf-len min ( flags node len )
+
+ \ Update rcv_nxt in sequence space, which include out-of-band data.
+ \ If len > dlen, the difference represents removed out-of-band data.
+ 2dup over >len @ rot >dlen @ - + +rcv_nxt ( flags node len )
+
+ \ Copy the data into the user buffer
+ over dup >bufadr @ swap >offset @ + ( flags node len adr )
+ over copy-to-rbuf ( flags node len )
+
+ \ "remove" the data from the list node
+ 2dup negate swap 2dup >dlen +! >len +! ( flags node len )
+
+ \ If we haven't consumed all the data in this node, update
+ \ its variables and exit.
+ over >dlen @ if ( flags node len )
+ 2dup swap >seq l+! ( flags node len )
+ 2dup swap >offset +! ( flags node len )
+
+ \ There is no point in continuing, as the user buffer must be
+ \ full (otherwise we would have consumed all the node data).
+ 2drop exit
+ then ( flags node len )
+
+ \ We have used all the node's data, so we can release the node.
+ drop ( flags node )
+
+ \ Release the node and its buffer
+ tcpq swap release-tcpnode ( flags )
+
+ \ If the user buffer is full, we can exit now
+ rbuf-len 0= ?exit ( flags )
+
+ \ Otherwise advance to the next node
+ tcpq >next-node ( flags node )
+ ?dup while ( flags node )
+ nip ( node )
+ repeat ( flags )
+;
+
+
+0 value trim-offset \ "local" variable used for reassembly queue insertion
+
+\ If there is a preceding segment, it may provide some of
+\ our data already. If so, drop the data from the incoming
+\ segment. If it provides all of our data, drop us.
+: ?trim-prev ( prev -- enclosed? )
+ 0 to trim-offset
+ dup tcpq = if drop false exit then ( prev )
+ dup >seq l@ swap >len l@ + iseq - l>n \ Wraparound ( n )
+
+ \ Exit if the segments don't overlap
+ dup 0<= if drop false exit then ( n )
+
+ \ Return true if the new packet is enclosed by the old segment
+ dup ilen >= if drop true exit then ( n )
+
+ \ Otherwise trim the packet.
+ dup to trim-offset ( n )
+ dup iseq + l>n to iseq ( n )
+ -ilen
+;
+: ?trim-nexts ( prev this -- prev this' )
+ begin dup while ( prev node )
+ iseq ilen + over >seq l@ - l>n ( prev node n )
+
+ \ Exit if no overlap
+ dup 0<= if 3drop exit then ( prev node n )
+
+ 2dup swap >len @ < if ( prev node n )
+ \ Partial overlap - trim node and exit
+ 2dup negate swap >len +! ( prev node n )
+ 2dup swap >seq l+! ( prev node n )
+ 2dup swap >offset l+! ( prev node )
+ exit
+ then ( prev node n )
+ \ Complete overlap - discard node ( prev node n )
+ drop ( prev node )
+ 2dup >next-node 2swap ( prev next prev node )
+ release-tcpnode ( prev next )
+ repeat ( prev next )
+;
+: new-node ( -- )
+ tcpqnode allocate-node ( new )
+ 0 over >offset ! ( new )
+ ilen over >len ! ( new )
+ idlen over >dlen ! ( new )
+ iseq over >seq l! ( new )
+ \ XXX this is what BSD does, but it seems to me that it
+ \ should be "iflags" instead of "th_flags c@", because
+ \ it would seem that you want the FIN flag to be trimmed
+ \ if it is outside the receive window.
+ th_flags c@ over >flags c! ( new )
+ idlen over >bufsize ! ( new )
+ idlen if ( new )
+ idlen alloc-mem ( new buf )
+ 2dup swap >bufadr ! ( new buf )
+ idata trim-offset + swap ilen move ( new )
+ then ( new )
+;
+: next-seg ( node-data-adr -- flag ) >seq l@ iseq - 0> ;
+: reassemble ( -- flags )
+ tcpq ['] next-seg find-node ( prev-node this-node|0 )
+ over ?trim-prev if 2drop 0 exit then ( prev this )
+ ?trim-nexts ( prev this )
+
+ \ Create a new fragment queue entry and insert it into place
+ drop new-node ( prev new )
+ swap insert-after ( )
+
+ present-data
+;
+
+\ End of reassembly queue management
+
+\ Assumes active struct is set to the TCP header
+
+\ For now we assume no IP options; the IP layer should probably
+\ strip them for us anyway
+
+: sum-bad? ( adr len -- flag )
+ swap /pip - set-struct ( len )
+ ih_x1 9 erase ( len ) \ Zap unnecessary fields
+ dup ih_len be-w! ( len ) \ Put length field back
+ 0 the-struct rot /pip + oc-checksum h# ffff <>
+;
+
+0 value optp 0 value optlen
+0 value acked
+0 value needoutput
+0 value cantrcvmore?
+
+: set-flag ( bitmask -- ) t_flags or to t_flags ;
+: set-acknow ( -- ) acknow set-flag ;
+: clear-iflag ( flag -- ) iflags swap invert and to iflags ;
+: iflag? ( bitmask -- ) iflags and 0<> ;
+: t_flag? ( bitmask -- ) t_flags and 0<> ;
+: take-data ( -- )
+ ilen +rcv_nxt
+
+ \ Set DELACK for segments received in order, but ack immediately
+ \ when segments are out of order (so fast retransmit can work).
+ idata idlen copy-to-rbuf
+ iflags th_push and if acknow else delack then set-flag
+;
+
+: set-rxtcur ( val limit -- ) max rexmtmax min to t_rxtcur ;
+
+\ Collect new round-trip time estimate
+\ and update averages and current timeout
+: xmit_timer ( rtt -- )
+ 1- ( rtt )
+ t_srtt if ( rtt )
+ \ srtt is stored as fixed point with 3 bits after the
+ \ binary point (i.e., scaled by 8). The following magic
+ \ is equivalent to the smoothing algorithm in rfc793 with
+ \ an alpha of .875 (srtt = rtt/8 + srtt*7/8 in fixed
+ \ point). Adjust rtt to origin 0.
+ dup 2 lshift t_srtt 3 rshift - ( rtt delta )
+ dup t_srtt + 1 max to t_srtt ( rtt delta )
+
+ \ We accumulate a smoothed rtt variance (actually, a
+ \ smoothed mean difference), then set the retransmit
+ \ timer to smoothed rtt + 4 times the smoothed variance.
+ \ rttvar is stored as fixed point with 2 bits after the
+ \ binary point (scaled by 4). The following is
+ \ equivalent to rfc793 smoothing with an alpha of .75
+ \ (rttvar = rttvar*3/4 + |delta| / 4). This replaces
+ \ rfc793's wired-in beta.
+ abs t_rttvar 2 rshift - ( rtt delta' )
+ 1 max to t_rttvar ( rtt )
+ else
+ \ No rtt measurement yet - use the unsmoothed rtt.
+ \ Set the variance to half the rtt (so our first
+ \ retransmit happens at 3*rtt).
+ dup 5 lshift to t_srtt ( rtt ) ( 5 is 3 + 2 )
+ dup 3 lshift to t_rttvar ( rtt )
+ then ( rtt )
+ 0 to t_rtt ( rtt )
+ 0 to t_rxtshift ( rtt )
+
+ \ the retransmit should happen at rtt + 4 * rttvar.
+ \ Because of the way we do the smoothing, srtt and rttvar
+ \ will each average +1/2 tick of bias. When we compute
+ \ the retransmit timer, we want 1/2 tick of rounding and
+ \ 1 extra tick because of +-1/2 tick uncertainty in the
+ \ firing of the timer. The bias will give us exactly the
+ \ 1.5 tick we need. But, because the bias is
+ \ statistical, we have to test that we don't drop below
+ \ the minimum feasible timer (which is 2 ticks).
+
+ 2+ rexmtval set-rxtcur
+;
+
+: ack-una ( -- )
+ iack to snd_una
+ snd_nxt snd_una s< if snd_una set-snd_nxt then
+;
+
+\ Determine a reasonable value for maxseg size.
+\ If the route is known, check route for mtu.
+\ If none, use an mss that can be handled on the outgoing
+\ interface without forcing IP to fragment; if bigger than
+\ an mbuf cluster (MCLBYTES), round down to nearest multiple of MCLBYTES
+\ to utilize large mbufs. If no route is found, route has no mtu,
+\ or the destination isn't local, use a default, hopefully conservative
+\ size (usually 512 or the default IP max size, but no more than the mtu
+\ of the interface), as we can't discover anything about intervening
+\ gateways or networks. We also initialize the congestion/slow start
+\ window to be a single segment if the destination isn't local.
+\ While looking at the routing entry, we also initialize other path-dependent
+\ parameters from pre-set or cached values in the routing entry.
+
+: tcp_mss ( offer -- chosen )
+ \ XXX we probably should try to first determine whether or not we
+ \ know anything about the route, and if not, just return mssdflt
+
+ \ Use link MTU on a LAN, otherwise use a conservative default
+ \ not larger than the link MTU
+
+ " max-ip-payload" $call-parent /tcphdr - ( offer limit )
+ mssmax min ( offer limit )
+ local? 0= if mssdflt min then ( offer limit )
+
+ \ If offer is nonzero, use the computed value, otherwise use the
+ \ smaller of the offer and the computed value.
+ over if over min then ( offer chosen )
+
+ \ But in all cases, use at least 32 bytes
+ d# 32 max ( offer chosen' )
+
+ \ If this results in a smaller segment size than we're currently
+ \ using, or if offer is nonzero, then reduce the current size.
+ dup t_maxseg < rot 0<> or if ( chosen )
+ dup to t_maxseg ( chosen )
+ debug? if ." Maxseg set to " t_maxseg u. cr then
+ then ( chosen )
+
+ \ Set the slow-open window size
+ dup set-cwnd ( chosen )
+;
+
+\ Output code
+
+0 value len
+0 value ourfinisacked?
+
+0 value idle?
+0 value sendalot?
+
+\ Flags used when sending segments in tcp_output.
+\ Basic flags (TH_RST,TH_ACK,TH_SYN,TH_FIN) are totally
+\ determined by state, with the proviso that TH_FIN is sent only
+\ if all data queued for output is included in the segment.
+create outflags
+ rst ack or c, \ 0 closed
+ 0 c, \ 1 listen
+ syn c, \ 2 syn_sent
+ syn ack or c, \ 3 syn_received
+ ack c, \ 4 established
+ ack c, \ 5 close_wait
+ fin ack or c, \ 6 fin_wait_1
+ fin ack or c, \ 7 closing
+ fin ack or c, \ 8 last_ack
+ ack c, \ 9 fin_wait_2
+ ack c, \ 10 time_wait
+
+0 value oflags
+: oflag? ( bitmask -- flag ) oflags and 0<> ;
+: fin-off ( -- ) oflags fin invert and to oflags ;
+
+create backoff
+base @ decimal
+ 1 , 2 , 4 , 8 , 16 , 32 , 64 , 64 , 64 , 64 , 64 , 64 , 64 ,
+base !
+
+pr_slowhz 5 * constant persmin
+pr_slowhz d# 60 * constant persmax
+
+: setpersist ( -- )
+ t_srtt 2 rshift t_rttvar + 1 rshift ( t )
+
+ \ Start/restart persistance timer.
+ backoff t_rxtshift na+ @ * ( t*backoff )
+
+ persmin max persmax min tcpt_persist !
+
+ t_rxtshift 1+ maxrxtshift min to t_rxtshift
+;
+
+0 value win
+0 value offs
+: dont-send? ( -- exit? )
+ false
+
+ \ Sender silly window avoidance. If connection is idle and can send
+ \ all data, a maximum segment, at least a maximum default-size segment
+ \ do it, or are forced, do it; otherwise don't bother.
+ \ If peer's buffer is tiny, then send when window is at least half open.
+ \ If retransmitting (possibly after persist timer forced us
+ \ to send into a small window), then must resend.
+
+ len if
+ len t_maxseg = ?exit
+
+ idle? nodelay t_flag? or len offs + wbuf-actual >= and ?exit
+
+ t_force ?exit
+
+ len max_sndwnd 2/ >= ?exit
+
+ snd_nxt snd_max s< ?exit
+ then
+
+ \ Compare available window to amount of window known to peer (as
+ \ advertised window less next expected input). If the difference
+ \ is at least two max size segments, or at least 50% of the maximum
+ \ possible window, then want to send a window update to peer.
+
+ win 0> if
+ \ "adv" is the amount we can increase the window,
+ \ taking into account that we are limited by MAXWIN
+
+ maxwin win min rcv_adv rcv_nxt - - ( adv )
+ dup t_maxseg 2* >= if drop exit then ( adv )
+
+ 2* rbuf-len >= ?exit ( )
+ then
+
+ \ Send if we owe peer an ACK.
+
+ acknow t_flag? ?exit
+ syn rst or oflag? ?exit
+ snd_up snd_una s> ?exit
+
+ \ If our state indicates that FIN should be sent
+ \ and we have not yet done so, or we're retransmitting the FIN,
+ \ then we need to send.
+
+ fin oflag?
+ sentfin t_flag? 0= snd_nxt snd_una = or and ?exit
+
+ \ TCP window updates are not reliable, rather a polling protocol
+ \ using ``persist'' packets is used to insure receipt of window
+ \ updates. The three ``states'' for the output side are:
+ \ idle not doing retransmits or persists
+ \ persisting to move a small or zero window
+ \ (re)transmitting and thereby not persisting
+ \
+ \ TCPT_PERSIST is set when we are in persist state.
+ \ t_force is set when we are called to send a persist packet.
+ \ TCPT_REXMT is set when we are retransmitting
+ \
+ \ The output side is idle when both timers are zero.
+ \
+ \ If send window is too small, there is data to transmit, and no
+ \ retransmit or persist is pending, then go to persist state.
+ \ If nothing happens soon, send when timer expires:
+ \ if window is nonzero, transmit what we can, otherwise force out a byte.
+
+ wbuf-actual 0<> tcpt_rexmt @ 0= and tcpt_persist @ 0= and if
+ 0 to t_rxtshift
+ setpersist
+ then
+
+ drop true
+;
+
+\ TCP output routine: figure out what should be sent and send it.
+d# 32 buffer: opt
+0 value hdrlen
+
+: make-options ( -- )
+ \ Before ESTABLISHED, force sending of initial options
+ \ unless TCP set not to do any options.
+ \ NOTE: we assume that we have space for the IP/TCP header plus TCP
+ \ options, leaving room for a maximum link header, i.e.
+ \ max_linkhdr + sizeof (struct tcpiphdr) + optlen <= buflen
+
+ 0 to optlen
+ /tcphdr to hdrlen
+ syn oflag? if
+ iss set-snd_nxt
+ noopt t_flag? 0= if
+ 2 opt c! \ tcpopt_maxseg
+ 4 opt 1+ c! \ option length
+ debug? if ." Sending " then
+ 0 tcp_mss opt 2+ be-w! \ option value
+ 4 to optlen
+ then
+ then
+
+ optlen hdrlen + to hdrlen
+
+ \ Adjust data length if insertion of options will
+ \ bump the packet length beyond the t_maxseg length.
+
+ len t_maxseg optlen - > if
+ t_maxseg optlen - to len
+ fin-off
+ true to sendalot?
+ then
+;
+: insert-data ( -- )
+ \ Grab a transmit buffer, attaching a copy of data to
+ \ be transmitted, and initialize the header from
+ \ the template for sends on this connection.
+
+ xmit_buf set-struct
+
+ len if
+ wbuf-adr offs + xmit_buf hdrlen + len move
+
+ \ If we're sending everything we've got, set PUSH.
+ \ (This will keep happy those implementations which only
+ \ give data to the user when a buffer fills or
+ \ a PUSH comes in.)
+
+ offs len + wbuf-actual =
+ len snd_cwnd = or \ Also PUSH when we have a lot
+ if
+ oflags th_push or to oflags
+ then
+ then
+;
+: set-window ( -- )
+ \ Calculate receive window. Don't shrink window,
+ \ but avoid silly window syndrome.
+
+ win rbuf-len 4 / < win t_maxseg < and if 0 to win then
+
+ win maxwin min rcv_adv rcv_nxt - max th_win be-w!
+
+ snd_up snd_nxt s> if
+ snd_up snd_nxt - th_urp be-w!
+ th_flags c@ urg or th_flags c!
+ else
+ \ If no urgent pointer to send, then we pull
+ \ the urgent pointer to the left edge of the send window
+ \ so that it doesn't drift into the send window on sequence
+ \ number wraparound.
+ snd_una to snd_up
+ then
+;
+: set-timers ( -- )
+ \ In transmit state, time the transmission and arrange for
+ \ the retransmit. In persist state, just set snd_max.
+
+ t_force 0= tcpt_persist @ 0= or if
+ snd_nxt ( startseq )
+
+ \ Advance snd_nxt over sequence space of this segment.
+
+ syn oflag? if 1 +snd_nxt then
+ fin oflag? if 1 +snd_nxt sentfin set-flag then
+
+ len +snd_nxt
+
+ snd_nxt snd_max s> if
+ snd_nxt to snd_max
+
+ \ Time this transmission if not a retransmission and
+ \ not currently timing anything.
+ t_rtt 0= if 1 to t_rtt dup to t_rtseq then ( startseq )
+ then
+
+ \ We're done with startseq
+ drop ( )
+
+ \ Set retransmit timer if not currently set,
+ \ and not doing an ack or a keep-alive probe.
+ \ Initial value for retransmit timer is smoothed
+ \ round-trip time + 2 * round-trip time variance.
+ \ Initialize shift counter which is used for backoff
+ \ of retransmit time.
+
+ tcpt_rexmt @ 0= snd_nxt snd_una <> and if
+ t_rxtcur tcpt_rexmt !
+ tcpt_persist @ if tcpt_persist off 0 to t_rxtshift then
+ then
+ else
+ snd_nxt len + snd_max s> if snd_nxt len + to snd_max then
+ then
+;
+
+\ Called only from tcp_output
+: send ( -- )
+ make-options
+
+ insert-data
+
+ t_template xmit_buf /pip - /tcphdr /pip + move \ Copy in header
+
+ \ Fill in fields, remembering maximum advertised
+ \ window for use in delaying messages about window sizes.
+ \ If resending a FIN, be sure not to use a new sequence number.
+
+ fin oflag? sentfin t_flag? and
+ snd_nxt snd_max = and if -1 +snd_nxt then
+
+ \ If we are doing retransmissions, then snd_nxt will not reflect the first
+ \ unsent octet. For ACK only packets, we do not want the sequence number
+ \ of the retransmitted packet, we want the sequence number of the next
+ \ unsent octet. So, if there is no data (and no SYN or FIN), use snd_max
+ \ instead of snd_nxt when filling in iseq. But if we are in persist
+ \ state, snd_max might reflect one byte beyond the right edge of the
+ \ window, so use snd_nxt in that case, since we know we aren't doing a
+ \ retransmission. (retransmit and persist are mutually exclusive...)
+
+ len 0<> syn fin or oflag? or tcpt_persist @ 0<> or if
+ snd_nxt
+ else
+ snd_max
+ then
+ th_seq be-l!
+
+ rcv_nxt th_ack be-l!
+ optlen if
+ opt the-struct /tcphdr + optlen move
+ /tcphdr optlen + 2 rshift 4 lshift th_off4 c!
+ then
+
+ oflags th_flags c!
+
+ set-window
+
+ \ Put TCP length in extended header, and then
+ \ checksum extended header and data.
+
+ ip-struct
+ ih_x1 9 erase
+ /tcphdr optlen + len + ih_len be-w! ( )
+ 0 the-struct hdrlen len + /pip + oc-checksum ( sum )
+ tcp-struct ( sum )
+ th_sum be-w! ( )
+
+ set-timers
+
+ debug? if ." XMT " .pkt then
+
+ \ Send to IP level.
+
+ the-struct hdrlen len + 6 " send-ip-packet" $call-parent \ 6 is IPPROTO_TCP
+
+ \ Data sent (as far as we can tell).
+ \ If this advertises a larger window than any other segment,
+ \ then remember the size of the advertised window.
+ \ Any pending ACK has now been sent.
+
+ win 0> rcv_nxt win + rcv_adv s> and if
+ rcv_nxt win + to rcv_adv
+ then
+ t_flags acknow delack or invert and to t_flags
+;
+
+: tcp_output ( -- )
+ \ Determine length of data that should be transmitted,
+ \ and flags that will be used.
+ \ If there is some data or critical controls (SYN, RST)
+ \ to send, then transmit; otherwise, investigate further.
+
+ snd_max snd_una = to idle?
+ idle? t_idle t_rxtcur >= and if
+ \ We have been idle for "a while" and no acks are expected to clock out
+ \ any data we send -- slow start to get ack "clock" running again.
+ t_maxseg set-cwnd
+ then
+ begin
+ false to sendalot?
+ snd_nxt snd_una - to offs
+ snd_wnd snd_cwnd min to win
+ outflags ts ca+ c@ to oflags
+
+ \ If in persist timeout with window of 0, send 1 byte.
+ \ Otherwise, if window is small but nonzero and timer expired,
+ \ we will send what we can and go to transmit state.
+
+ t_force if
+ win if
+ tcpt_persist off
+ 0 to t_rxtshift
+ else
+ \ If we still have some data to send, then clear the FIN bit.
+ \ Usually this would happen below when it realizes that we
+ \ aren't sending all the data. However, if we have exactly
+ \ 1 byte of unset data, then it won't clear the FIN bit below,
+ \ and if we are in persist state, we wind up sending the packet
+ \ without recording that we sent the FIN bit.
+ \
+ \ We can't just blindly clear the FIN bit, because if we don't
+ \ have any more data to send then the probe will be the FIN itself.
+ off wbuf-actual < if fin-off then
+ 1 to win
+ then
+ then
+
+ win wbuf-actual < if fin-off win else wbuf-actual then ( n )
+ offs - to len
+
+ len 0< if
+ \ If FIN has been sent but not acked, but we haven't been called
+ \ to retransmit, len will be -1. Otherwise, window shrank
+ \ after we sent into it. If window shrank to 0, cancel pending
+ \ retransmit and pull snd_nxt back to (closed) window. We will
+ \ enter persist state below. If the window didn't close completely,
+ \ just wait for an ACK.
+ 0 to len
+ win 0= if tcpt_rexmt off snd_una set-snd_nxt then
+ then
+
+ len t_maxseg > if t_maxseg to len fin-off true to sendalot? then
+
+ rbuf-space to win
+
+ dont-send? ?exit
+
+ send
+ sendalot? 0= until
+;
+
+: fast-path? ( -- flag )
+ \ Header prediction: check for the two common cases
+ \ of a uni-directional data xfer. If the packet has
+ \ no control flags, is in-sequence, the window didn't
+ \ change and we're not retransmitting, it's a
+ \ candidate. If the length is zero and the ack moved
+ \ forward, we're the sender side of the xfer. Just
+ \ free the data acked & wake any higher level process
+ \ that was blocked waiting for space. If the length
+ \ is non-zero and the ack didn't move, we're the
+ \ receiver side. If we're getting packets in-order
+ \ (the reassembly queue is empty), add the data to
+ \ the socket buffer and note that we need a delayed ack.
+
+ ts established = \ Connection up?
+ iflags h# 37 and ack = and \ No control flags?
+ iseq rcv_nxt = and \ In sequence?
+ iwin 0<> and \ Window didn't change?
+ iwin snd_wnd = and \ Window didn't change?
+ snd_nxt snd_max = and if \ Not retransmitting?
+ ilen if
+ \ Incoming data
+
+ iack snd_una = \ in sequence data packet?
+ tcpq >next-node 0= and \ reassembly queue empty?
+ ilen rbuf-space <= and if \ enough space to take it?
+ take-data
+ true exit
+ then
+ false exit
+ then
+
+ \ ACK for outgoing data
+
+ iack snd_una - 0>
+ iack snd_max - 0<= and
+ snd_cwnd snd_wnd >= and
+ t_dupacks tcprexmtthresh < and if
+ \ This is a pure ack for outstanding data
+ t_rtt 0<> iack t_rtseq - 0> and if
+ t_rtt xmit_timer
+ then
+ iack snd_una - to acked
+ \ XXX drop-snd needs to "wakeup" the sender
+ acked wbuf-drop
+ iack to snd_una
+ \ We are now finished with the packet data
+
+ \ If all outstanding data are acked, stop
+ \ retransmit timer, otherwise restart timer
+ \ using current (possibly backed-off) value.
+ \ If process is waiting for space,
+ \ wakeup/selwakeup/signal. If data
+ \ are ready to send, let output
+ \ decide between more output or persist.
+
+ snd_una snd_max = if tcpt_rexmt off else
+ tcpt_persist @ 0= if t_rxtcur tcpt_rexmt ! then then
+
+ wbuf-actual if tcp_output then
+ true exit
+ then
+ false exit
+ then
+
+ false
+;
+
+: get-info ( -- )
+ th_flags c@ to iflags
+ th_seq be-l@ to iseq
+ th_ack be-l@ to iack
+ th_win be-w@ to iwin
+ th_urp be-w@ to iurp
+;
+
+: pull-options ( -- error )
+ \ Handle options
+ th_off4 c@ 4 rshift /l* to doff ( )
+ doff /tcphdr < doff ilen > or if true exit then
+
+ doff -ilen
+ doff /tcphdr - dup to optlen if the-struct /tcphdr + to optp then
+ false
+;
+: update-window ( -- )
+ \ Update window information.
+ \ Don't look at window if no ACK: TAC's send garbage on first SYN.
+ ack iflag? snd_wl1 iseq s< and
+ snd_wl1 iseq = snd_wl2 iack s< and or
+ snd_wl2 iack = iwin snd_wnd > and or if
+ \ keep track of pure window updates
+ \ ilen 0= snd_wl2 iack = and iwin snd_wnd > and if ( +stats ) then
+ iwin to snd_wnd
+ iseq to snd_wl1
+ iack to snd_wl2
+
+ snd_wnd max_sndwnd > if snd_wnd to max_sndwnd then
+ true to needoutput
+ then
+;
+
+\ Move the byte of urgent data out of the in-band data stream,
+\ placing it in t_iobc.
+
+: pulloutofband ( -- )
+ iurp 1- ( off ) \ Offset to OOB byte
+ idata over + ( off adr ) \ Address of OOB byte
+ dup c@ to t_iobc ( off adr ) \ Get OOB byte
+ t_oobflags havedata or to t_oobflags ( off adr ) \ Note its existence
+ dup ca1+ swap rot ( adr+1 adr off ) \ Setup to remove
+ ilen swap - 1- move ( ) \ byte from in-band data
+ #oob 1+ to #oob \ Note elided byte
+;
+
+: do-urgent ( -- )
+ \ Process segments with URG.
+ urg iflag? iurp 0<> and ts time_wait < and if
+ \ This is a kludge, but if we receive and accept
+ \ random urgent pointers, we'll crash in
+ \ soreceive. It's hard to imagine someone
+ \ actually wanting to send this much urgent data.
+
+ iurp rbuf-actual + rbuf-len > if
+ 0 to iurp
+ urg clear-iflag
+ exit
+ then
+
+ \ If this segment advances the known urgent pointer,
+ \ then mark the data stream. This should not happen
+ \ in CLOSE_WAIT, CLOSING, LAST_ACK or TIME_WAIT STATES since
+ \ a FIN has been received from the remote side.
+ \ In these states we ignore the URG.
+ \
+ \ According to RFC961 (Assigned Protocols),
+ \ the urgent pointer points to the last octet
+ \ of urgent data. We continue, however,
+ \ to consider it to indicate the first octet
+ \ of data past the urgent section as the original
+ \ spec states (in one of two places).
+
+ iseq iurp + rcv_up s> if
+ iseq iurp + to rcv_up
+\ rbuf-actual rcv_up rcv_nxt - + 1- to so_oobmark
+ \ XXX if (so_oobmark == 0) so_state |= SS_RCVATMARK;
+ \ XXX sohasoutofband(so);
+ t_oobflags havedata haddata or invert and to t_oobflags
+ then
+
+ \ Remove out of band data so doesn't get presented to user.
+ \ This can happen independent of advancing the URG pointer,
+ \ but if two URG's are pending at once, some out-of-band
+ \ data may creep in... ick.
+
+ iurp ilen u<= if pulloutofband then
+ else
+ \ If no out of band data is expected, pull receive
+ \ urgent pointer along with the receive window.
+ rcv_nxt rcv_up s> if rcv_nxt to rcv_up then
+ then
+;
+: do-data ( -- )
+ \ Process the segment text, merging it into the TCP sequencing queue,
+ \ and arranging for acknowledgment of receipt if necessary.
+ \ This process logically involves adjusting rcv_wnd as data
+ \ is presented to the user (this happens in tcp_usrreq
+ \ case PRU_RCVD). If a FIN has already been received on this
+ \ connection then we just ignore the text.
+
+ ilen 0<> fin iflag? or ts time_wait < and if
+ iseq rcv_nxt =
+ tcpq >next-node 0<> and
+ ts established = and if
+ \ The segment need not be queued for reassembly, because
+ \ this is the next segment and the queue is empty.
+ take-data
+ \ XXX this is what BSD does, but it seems to me that it
+ \ should be "iflags" instead of "th_flags c@", because
+ \ it would seem that you want the FIN flag to be trimmed
+ \ if it is outside the receive window.
+ th_flags c@ fin and to iflags
+ else
+ \ Insert the segment into the reassembly queue
+ reassemble to iflags
+ set-acknow
+ then
+
+ \ Note the amount of data that peer has sent into our
+ \ window, in order to estimate the sender's buffer size.
+
+ \ XXX NetBSD sets this, but then doesn't use the value
+ \ rbuf-len rcv_adv rcv_nxt - - to len
+ else
+ fin clear-iflag
+ then
+
+ \ If FIN is received ACK the FIN and let the user know
+ \ that the connection is closing. Ignore a FIN received before
+ \ the connection is fully established.
+
+ fin iflag? ts established >= and if
+ ts time_wait < if
+ true to cantrcvmore?
+ set-acknow
+ 1 +rcv_nxt \ Advance sequence number past FIN
+ then
+ ts case
+
+ \ In ESTABLISHED STATE enter the CLOSE_WAIT state.
+ established of close_wait set-state endof
+
+ \ If still in FIN_WAIT_1 STATE FIN has not been acked so
+ \ enter the CLOSING state.
+ fin_wait_1 of closing set-state endof
+
+ \ In FIN_WAIT_2 state enter the TIME_WAIT state,
+ \ starting the time-wait timer, turning off the other
+ \ standard timers.
+
+ fin_wait_2 of
+ time_wait set-state
+ canceltimers
+ tcptv_msl 2* tcpt_2msl !
+ \ soisdisconnected
+ endof
+
+ \ In TIME_WAIT state restart the 2 MSL time_wait timer.
+ time_wait of tcptv_msl 2* tcpt_2msl ! endof
+ endcase
+ then
+
+ \ Return any desired output.
+ needoutput acknow t_flag? or if tcp_output then
+;
+: dropafterack ( -- )
+ \ Generate an ACK dropping incoming segment if it occupies
+ \ sequence space, where the ACK reflects our state.
+ rst iflag? ?exit
+ set-acknow
+ tcp_output
+;
+
+\ Called with the-struct set to a TCP header
+: respond ( ack seq flags -- )
+ \ Copy to the transmit area so we can modify it
+ ip-struct
+ the-struct xmit_buf /pip - /tcphdr /pip + move
+ xmit_buf set-struct
+
+ \ Now the-struct points to the copy
+
+ ( ack seq flags )
+ th_flags c! ( ack seq )
+ th_seq be-l! ( ack )
+ th_ack be-l! ( )
+ /tcphdr 2 rshift 4 lshift th_off4 c!
+ rbuf-space th_win be-w!
+ 0 th_urp be-w!
+ 0 th_sum be-w!
+
+ \ Prepare the pseudo-header for checksumming
+ ip-struct
+ ih_x1 9 erase
+ /tcphdr ih_len be-w!
+ 0 the-struct /tcphdr /pip + oc-checksum ( sum )
+ tcp-struct
+ th_sum be-w!
+
+ debug? if ." Xrs " .pkt then
+
+ \ XXX this will always send to our server; it should
+ \ be able to send to anybody.
+ the-struct /tcphdr 6 " send-ip-packet" $call-parent
+\ the-struct /tcphdr 6 dst-ip (send-ip-packet)
+;
+
+: swap-addresses ( -- )
+ ip-struct
+ ih_src unaligned-l@ ih_dst unaligned-l@
+ ih_src unaligned-l! ih_dst unaligned-l!
+
+ tcp-struct
+ th_sport w@ th_dport w@ th_sport w! th_dport w!
+;
+: ip-multicast? ( adr -- flag ) c@ h# f0 and h# e0 = ;
+: multicast-dst? ( -- flag )
+ ip-struct ih_dst tcp-struct ( adr ) ip-multicast?
+;
+/i buffer: tmp-ip
+: dropwithreset ( -- )
+ \ Generate a RST, dropping incoming segment.
+ \ Make ACK acceptable to originator of segment.
+ \ Don't bother to respond if destination was broadcast/multicast.
+
+ rst iflag? ?exit
+
+ \ XXX we also need to reject broadcast source addresses
+\ m_flags bcast mcast or and ?exit
+ multicast-dst? ?exit
+
+ swap-addresses
+ ack iflag? if
+ 0 iack rst
+ else
+ syn iflag? if -1 -ilen then
+ iseq ilen + 0 rst ack or
+ then ( ack seq flags )
+
+ his-ip-addr tmp-ip copy-ip-addr
+ ip-struct ih_dst set-dest-ip tcp-struct
+ respond ( )
+ tmp-ip set-dest-ip
+;
+
+: step6 ( -- )
+ update-window
+ do-urgent
+ do-data
+;
+: trimthenstep6 ( -- )
+ \ Advance iseq to correspond to first data byte.
+ \ If data, trim to stay within window,
+ \ dropping FIN if necessary.
+ iseq 1+ to iseq
+ ilen rcv_wnd > if
+ rcv_wnd to ilen
+ iflags fin invert and to iflags
+ then
+ iseq 1- to snd_wl1
+ iseq to rcv_up
+ step6
+;
+
+\ Close a TCP control block, freeing all space
+: tcp_close ( -- )
+ \ Release reassmbly queue nodes
+ begin tcpq >next-node while tcpq dup >next-node release-tcpnode repeat
+
+ closed set-state
+ false to alive?
+ false to abort-on-reconnect?
+;
+
+\ Drop a TCP connection, reporting the specified error.
+\ If connection is synchronized, then send a RST to peer.
+: tcp_drop ( -- )
+ ts syn_received >= if closed set-state tcp_output then
+ tcp_close
+;
+
+: next-iss ( -- )
+ tcp_iss to iss
+ issincr 2/ tcp_iss + to tcp_iss
+;
+
+: do-syn-sent? ( -- done? )
+ ts syn_sent <> if false exit then
+
+ \ If the state is SYN_SENT:
+ \ if seg contains an ACK, but not for our SYN, drop the input.
+ \ if seg contains a RST, then drop the connection.
+ \ if seg does not contain SYN, then drop it.
+ \ Otherwise this is an acceptable SYN segment
+ \ initialize rcv_nxt and irs
+ \ if seg contains ack then advance snd_una
+ \ if SYN has been acked change to ESTABLISHED else SYN_RCVD state
+ \ arrange for segment to be acked (eventually)
+ \ continue processing rest of data/controls, beginning with URG
+
+ ack iflag? iack iss s<= iack snd_max s> or and if
+ dropwithreset true exit
+ then
+
+ rst iflag? if
+ ack iflag? if
+ debug" Connection refused"
+ tcp_drop
+ then \ Connection refused
+ true exit
+ then
+
+ syn iflag? 0= if true exit then
+
+ ack iflag? if ack-una then
+
+ tcpt_rexmt off
+ iseq to irs
+ rcvseqinit
+ set-acknow
+ ack iflag? snd_una iss s> and if
+ established set-state
+ present-data drop
+ \ if we didn't have to retransmit the SYN,
+ \ use its rtt as our initial srtt & rtt var.
+ t_rtt if t_rtt xmit_timer then
+ else
+ syn_received set-state
+ then
+
+ trimthenstep6 true
+;
+
+
+: ?drop-some ( -- )
+ rcv_nxt iseq - dup 0<= if drop exit then ( #todrop )
+ syn iflag? if
+ syn clear-iflag
+ iseq 1+ to iseq
+ iurp 1 > if
+ iurp 1- to iurp
+ else
+ urg clear-iflag
+ then
+ 1- ( #todrop' )
+ then ( #todrop )
+
+ dup ilen >= if ( #todrop )
+ \ Any valid FIN must be to the left of the
+ \ window. At this point, FIN must be a
+ \ duplicate or out-of-sequence, so drop it.
+ fin clear-iflag
+
+ \ Send ACK to resynchronize, and drop any data,
+ \ but keep on processing for RST or ACK.
+ set-acknow ( #todrop )
+ drop ilen ( #todrop' )
+ then ( #todrop )
+
+ dup doff + to doff ( #todrop )
+ dup iseq + to iseq ( #todrop )
+ dup -ilen ( #todrop )
+ iurp over > if ( #todrop )
+ iurp over - to iurp ( #todrop )
+ else ( #todrop )
+ urg clear-iflag ( #todrop )
+ 0 to iurp ( #todrop )
+ then ( #todrop )
+ drop ( )
+;
+
+: seg-after-win? ( -- done? )
+ \ If segment ends after window, drop trailing data
+ \ (and PUSH and FIN); if nothing left, just ACK.
+
+ iseq ilen + rcv_nxt rcv_wnd + - ( #todrop )
+ dup 0<= if drop false exit then ( #todrop )
+
+ dup ilen >= if ( #todrop )
+ \ If a new connection request is received
+ \ while in TIME_WAIT, drop the old connection
+ \ and start over if the sequence numbers
+ \ are above the previous ones. Otherwise, queue it
+ \ for later processing.
+ syn iflag? if
+ ts time_wait = iseq rcv_nxt s> and if ( #todrop )
+ rcv_nxt issincr + to iss
+ tcp_close
+ \ XXX we need to find some way to get back to findpcb:
+ \ goto findpcb
+ \ XXX this is moot since a new instance of this TCP
+ \ package must be created in order to accept a new
+ \ connection.
+ drop true exit
+ else
+ drop false exit
+ then
+ then ( #todrop )
+
+ \ If window is closed can only take segments at
+ \ window edge, and have to drop data and PUSH from
+ \ incoming segments. Continue processing, but
+ \ remember to ack. Otherwise, drop segment and ack.
+
+ rcv_wnd 0= iseq rcv_nxt = and if ( #todrop )
+ set-acknow
+ else ( #todrop )
+ drop dropafterack true exit
+ then ( #todrop )
+ then ( #todrop )
+
+ \ Drop the extra data from the end of the packet
+ -ilen ( )
+ th_push fin or clear-iflag ( )
+ false
+;
+
+: do-rst ( -- )
+ \ If the RST bit is set examine the state:
+ \ SYN_RECEIVED STATE:
+ \ If passive open, return to LISTEN state.
+ \ If active open, inform user that connection was refused.
+ \ ESTABLISHED, FIN_WAIT_1, FIN_WAIT2, CLOSE_WAIT STATES:
+ \ Inform user that connection was reset, and close tcb.
+ \ CLOSING, LAST_ACK, TIME_WAIT STATES
+ \ Close the tcb.
+
+ ts syn_received = if debug" Connection refused" closed set-state then
+
+ ts established =
+ ts fin_wait_1 = or
+ ts fin_wait_2 = or
+ ts close_wait = or if debug" Connection reset" closed set-state then
+
+ tcp_close
+;
+
+\ Discard from the buffer the transmitted data that was acked
+: release-data ( -- flag )
+ acked wbuf-actual > dup if ( flag )
+ snd_wnd wbuf-actual - to snd_wnd ( flag )
+ wbuf-actual wbuf-drop ( flag )
+ else ( flag )
+ acked wbuf-drop ( flag )
+ snd_wnd acked - to snd_wnd ( flag )
+ then ( flag )
+;
+: do-ack ( -- done? )
+ ts syn_received = if
+ \ In SYN_RECEIVED state if the ack ACKs our SYN then enter
+ \ ESTABLISHED state and continue processing, otherwise
+ \ send an RST.
+ snd_una iack s> iack snd_max s> or if
+ dropwithreset true exit
+ then
+ established set-state
+ present-data drop
+ iseq 1- to snd_wl1
+ then
+
+ \ In ESTABLISHED and subsequent states: drop duplicate ACKs; ACK out
+ \ of range ACKs. If the ack is in the range
+ \ snd_una < iack <= snd_max
+ \ then advance snd_una to iack and drop
+ \ data from the retransmission queue. If this ACK reflects
+ \ more up to date window information we update our window information.
+
+ iack snd_una s<= if
+ ilen 0= iwin snd_wnd = and if
+ \ If we have outstanding data (other than a window probe),
+ \ this is a completely duplicate ack (i.e., window info didn't
+ \ change), the ack is the biggest we've seen, and we've seen
+ \ exactly our rexmt threshhold of them, assume a packet
+ \ has been dropped and retransmit it. Kludge snd_nxt & the
+ \ congestion window so we send only this one packet.
+ \
+ \ We know we're losing at the current window size so do
+ \ congestion avoidance (set ssthresh to half the current window
+ \ and pull our congestion window back to the new ssthresh).
+ \
+ \ Dup acks mean that packets have left the network (they're now
+ \ cached at the receiver) so bump cwnd by the amount in the receiver
+ \ to keep a constant cwnd packets in the network.
+
+ tcpt_rexmt @ 0= iack snd_una <> or if
+ 0 to t_dupacks
+ else t_dupacks 1+ dup to t_dupacks tcprexmtthresh = if
+ snd_nxt ( onxt )
+ snd_wnd snd_cwnd min 2/ t_maxseg / 2 umax ( onxt win )
+ t_maxseg u* to snd_ssthresh ( onxt )
+ tcpt_rexmt off ( onxt )
+ 0 to t_rtt ( onxt )
+ iack set-snd_nxt ( onxt )
+ t_maxseg set-cwnd ( onxt )
+ tcp_output ( onxt )
+ t_maxseg t_dupacks * snd_ssthresh + set-cwnd ( onxt )
+ dup snd_nxt s> if set-snd_nxt else drop then ( )
+ true exit
+ else t_dupacks tcprexmtthresh > if
+ snd_cwnd t_maxseg + set-cwnd
+ tcp_output
+ true exit
+ then then then
+ else
+ 0 to t_dupacks
+ then
+
+ false exit
+ then
+
+ \ If the congestion window was inflated to account
+ \ for the other side's cached packets, retract it.
+
+ t_dupacks tcprexmtthresh >=
+ snd_cwnd snd_ssthresh > and if snd_ssthresh set-cwnd then
+ 0 to t_dupacks
+
+ iack snd_max s> if dropafterack true exit then
+
+ iack snd_una - to acked
+
+ \ If transmit timer is running and timed sequence
+ \ number was acked, update smoothed round trip time.
+ \ Since we now have an rtt measurement, cancel the
+ \ timer backoff (cf., Phil Karn's retransmit alg.).
+ \ Recompute the initial retransmit timer.
+
+ t_rtt 0<> iack t_rtseq s> and if t_rtt xmit_timer then
+
+ \ If all outstanding data is acked, stop retransmit
+ \ timer and remember to restart (more output or persist).
+ \ If there is more data to be acked, restart retransmit
+ \ timer, using current (possibly backed-off) value.
+
+ iack snd_max = if
+ tcpt_rexmt off
+ 1 to needoutput
+ else
+ tcpt_persist @ 0= if t_rxtcur tcpt_rexmt ! then
+ then
+
+ \ When new data is acked, open the congestion window. If the window
+ \ gives us less than ssthresh packets in flight, open exponentially
+ \ (maxseg per packet). Otherwise open linearly: maxseg per window
+ \ (maxseg^2 / cwnd per packet), plus a constant fraction of a packet
+ \ (maxseg/8) to help larger windows open quickly enough.
+ t_maxseg
+ snd_cwnd snd_ssthresh u> if dup u* snd_cwnd / then ( cwnd-increment )
+ snd_cwnd + maxwin min set-cwnd
+
+ release-data to ourfinisacked?
+
+ \ wakeup-sender
+
+ ack-una
+
+ ts case
+
+ \ In FIN_WAIT_1 STATE in addition to the processing
+ \ for the ESTABLISHED state if our FIN is now acknowledged
+ \ then enter FIN_WAIT_2.
+
+ fin_wait_1 of
+ ourfinisacked? if
+ \ If we can't receive any more data, then closing user can proceed.
+ \ Starting the timer is contrary to the specification, but if we
+ \ don't get a FIN we'll hang forever.
+
+ cantrcvmore? if
+ \ XXX false to soisconnected
+ maxidle tcpt_2msl !
+ then
+ fin_wait_2 set-state
+ then
+ endof
+
+ \ In CLOSING STATE in addition to the processing for
+ \ the ESTABLISHED state if the ACK acknowledges our FIN
+ \ then enter the TIME-WAIT state, otherwise ignore
+ \ the segment.
+
+ closing of
+ ourfinisacked? if
+ time_wait set-state
+ canceltimers
+ tcptv_msl 2* tcpt_2msl !
+ then
+ endof
+
+ \ In LAST_ACK, we may still be waiting for data to drain
+ \ and/or to be acked, as well as for the ack of our FIN.
+ \ If our FIN is now acknowledged, delete the TCB,
+ \ enter the closed state and return.
+
+ last_ack of
+ ourfinisacked? if tcp_close true exit then
+ endof
+
+ \ In TIME_WAIT state the only thing that should arrive
+ \ is a retransmission of the remote FIN. Acknowledge
+ \ it and restart the finack timer.
+
+ time_wait of
+ tcptv_msl 2* tcpt_2msl !
+ dropafterack true exit
+ endof
+ endcase
+ false
+;
+
+: optbyte ( adr len -- adr' len' b ) 1- swap dup c@ swap 1+ -rot ;
+: dooptions ( adr len -- )
+ begin dup while ( adr len )
+ optbyte case ( adr' len' option )
+ 0 of 2drop exit endof ( adr len option ) \ EOL
+ 1 of 0 endof ( adr len option ) \ NOP
+ 2 of ( adr len ) \ MAXSEG
+ optbyte 2- ( adr len optlen )
+ iflags syn and if ( adr len optlen )
+ debug? if ." Received " then
+ 2 pick be-w@ tcp_mss drop ( adr len optlen )
+ then ( adr len optlen )
+ endof
+[ifdef] notdef
+ 3 of ( adr len ) \ WINDOW
+ optbyte 2- ( adr len optlen )
+ iflags syn and if ( adr len optlen )
+ rcvd_scale set-flag ( adr len optlen )
+ then ( adr len optlen )
+ endof
+[then]
+ ( default ) >r optbyte 2- r> ( adr len optlen option )
+ endcase ( adr len optlen )
+ /string ( adr' len' )
+ repeat ( adr len )
+ 2drop
+;
+
+: do-listen ( -- )
+ th_dport be-w@ my-tcp-port <> ?exit
+ rst iflag? ?exit
+ ack iflag? if dropwithreset exit then
+ syn iflag? 0= ?exit
+
+ \ XXX we also need to reject broadcast source addresses
+\ m_flags bcast mcast or and ?exit
+ multicast-dst? ?exit
+
+ \ It is tempting to call "lock-ip-address", but that doesn't
+ \ work if the DHCP server has specified a router.
+ ip-struct ih_src set-dest-ip tcp-struct
+
+ th_sport be-w@ to his-tcp-port \ Lock onto his source port
+
+ make-template
+
+ optp optlen dooptions
+ next-iss
+ iseq to irs
+ sendseqinit
+ rcvseqinit
+ set-acknow
+ syn_received set-state
+ keep_init tcpt_keep !
+ trimthenstep6
+;
+
+\ TCP SYN queue methods
+
+list: tcplist
+listnode
+ /n field >tcp-adr
+ /n field >tcp-len
+ 1 field >tcp-deq?
+nodetype: tcpnode
+
+0 tcplist !
+0 tcpnode !
+
+: free-tcpnode ( prev -- )
+ delete-after
+ dup tcpnode free-node
+ dup >tcp-adr @ swap >tcp-len free-mem
+;
+
+: tcp-deq? ( node-adr -- tcp-deq? ) >tcp-deq? c@ ;
+
+: purge-que ( -- )
+ tcplist ['] tcp-deq? find-node if free-tcpnode else drop then
+;
+
+: tcp-any? ( node-adr -- true ) drop true ;
+
+: find-first-node ( -- first-node ) tcplist ['] tcp-any? find-node nip ;
+
+: enque ( adr len -- )
+ dup alloc-mem swap 2dup 2>r move 2r> ( adr' len )
+ tcpnode allocate-node ( adr len node )
+ dup tcplist last-node insert-after ( adr len node )
+ tuck >tcp-len ! ( adr node )
+ tuck >tcp-adr ! ( node )
+ 0 swap >tcp-deq? c! ( )
+;
+
+\ Determines whether a node in the queue matches the packet that
+\ is about to be enqued by comparing their pseudo-IP and TCP headers.
+0 value test-adr
+: duplicate-syn? ( node-adr -- flag )
+ dup tcp-deq? if drop false exit then ( node-adr )
+ >tcp-adr @ test-adr /pip /tcphdr + comp 0= ( flag )
+;
+
+\ Enque an incoming SYN packet unless it is a duplicate of one that
+\ is already in the queue.
+: ?enque ( adr len -- )
+ over to test-adr
+ tcplist ['] duplicate-syn? find-node nip if 2drop else enque then
+;
+
+: dequeue? ( -- 0 | adr len true )
+ purge-que
+ find-first-node dup 0= if exit then \ nothing in queue
+
+ ( node )
+ true over >tcp-deq? c! ( node )
+ dup >tcp-adr @ swap >tcp-len @ true ( adr len true )
+;
+
+: queue-syn ( -- )
+ the-struct /pip - ilen-save /pip + ?enque
+
+ \ If the current connection has been declared to be abortable,
+ \ kill it upon receipt of a new connection request. This is
+ \ a special hack that is used by the Swing Solutions application,
+ \ which has some HTTP requests that do not complete until an
+ \ external event occurs. The requester can abort the request
+ \ by dropping the TCP connection, but there are some cases where
+ \ the TCP drop does not appear to be propagated to the responder.
+
+ abort-on-reconnect? if tcp_drop then
+;
+
+: input ( adr len -- )
+ 2dup sum-bad? if
+ show" TCHKSUM"
+ debug" Bad TCP checksum" 2drop exit
+ then ( adr len )
+ dup to ilen-save to ilen set-struct ( )
+ 0 to #oob
+
+ pull-options ?exit
+
+ get-info
+
+ debug? if ." RCV " .pkt then
+
+\ findpcb:
+
+ \ Here we should do something to ensure that the source port
+ \ matches this one. Perhaps that is handled by the IP layer.
+
+ \ XXX If we get at TCP packet that doesn't match, we should do a
+ \ dropwithreset and exit ...
+
+ \ When we get a packet from a port other than the one we are currently
+ \ talking to, we either queue it for later (if it contains a SYN),
+ \ or discard it.
+ his-tcp-port th_sport be-w@ <> if
+ \ If we are waiting for an incoming connection, we just fall through
+ \ and handle the new connection request farther down.
+ ts listen <> if
+ \ If a SYN is in the window, then we queue it and handle it
+ \ later, after the current transaction finishes.
+ syn iflag? if queue-syn then
+ exit
+ then
+ then
+
+ alive? 0= if dropwithreset exit then
+ ts closed = ?exit
+
+ 0 to t_idle
+ keepidle tcpt_keep !
+
+ ts listen <> if optp optlen dooptions then
+
+ fast-path? ?exit
+
+ \ At this point, we have handled the most common cases;
+ \ It gets complicated from here on out
+
+ \ Calculate amount of space in receive window,
+ \ and then do TCP input processing.
+ \ Receive window is amount of space in rcv queue,
+ \ but not less than advertised window.
+ rcv_adv rcv_nxt - rbuf-space max to rcv_wnd
+
+ ts listen = if do-listen exit then
+
+ do-syn-sent? ?exit
+ ?drop-some
+
+ \ If data is received after closing, RST the other end
+ ts close_wait > ilen 0<> and if tcp_close dropwithreset exit then
+
+ seg-after-win? ?exit
+
+ rst iflag? if do-rst exit then
+
+ \ If a SYN is in the window, then it is queued until the current
+ \ transaction finishes cleanly.
+ syn iflag? if queue-syn then
+
+ \ If the ACK bit is off we drop the segment and return.
+ ack iflag? 0= ?exit
+
+ \ ACK processing
+ do-ack ?exit
+ step6
+;
+
+: ?receive ( -- )
+ \ If the state is listen, check the queue
+ ts listen = if
+ dequeue? if ( adr len ) /pip - swap /pip + swap input exit then
+ then
+ \ Check for a new packet
+ 6 " receive-ip-packet" $call-parent 0= if input then
+;
+
+
+\ We accomplish the creation of a TCP control block by instantiating
+\ this package
+: newtcpcb ( -- ) ;
+
+\ d# 32 is the maximum TCP options size
+/tcphdr d# 32 + mssmax + constant /xmit-max
+
+\ This is basically attach
+: alloc-buffers ( -- )
+ wbuf-allocate
+ d# 1024 d# 16 * to rbuf-len
+ rbuf-len alloc-mem to rbuf-adr
+ 0 to rbuf-actual
+
+ /xmit-max " allocate-ip" $call-parent to xmit_buf
+;
+
+: free-buffers ( -- )
+ wbuf-start /wbuf free-mem
+ rbuf-adr rbuf-len free-mem
+ xmit_buf /xmit-max " free-ip" $call-parent
+;
+
+\ User issued close, and wish to trail through shutdown states:
+\ if never received SYN, just forget it. If got a SYN from peer,
+\ but haven't sent FIN, then go to FIN_WAIT_1 state to send peer a FIN.
+\ If already got a FIN from peer, then almost done; go to LAST_ACK
+\ state. In all other cases, have already sent FIN to peer (e.g.
+\ after PRU_SHUTDOWN), and just have to play tedious game waiting
+\ for peer to send FIN or not respond to keep-alives, etc.
+\ We can let the user exit from the close as soon as the FIN is acked.
+: usrclosed ( -- )
+ ts case \ action next-state
+ closed of tcp_close endof
+ listen of tcp_close endof
+ syn_sent of tcp_close endof
+ syn_received of fin_wait_1 set-state endof
+ established of fin_wait_1 set-state endof
+ close_wait of last_ack set-state endof
+ ( default ) \ Do nothing
+ endcase
+
+
+ alive? ts fin_wait_2 >= and if
+ \ soisdisconnected
+
+ \ If we are in FIN_WAIT_2, we arrived here because the
+ \ application did a shutdown of the send side. Like the
+ \ case of a transition from FIN_WAIT_1 to FIN_WAIT_2 after
+ \ a full close, we start a timer to make sure sockets are
+ \ not left in FIN_WAIT_2 forever.
+ ts fin_wait_2 = if maxidle tcpt_2msl ! then
+ then
+;
+
+\ When a source quench is received, close congestion window
+\ to one segment. We will gradually open it again as we proceed.
+\ XXX we probably have no way to invoke this.
+\ : quench ( -- ) alive? if t_maxseg set-cwnd then ;
+
+\ Fast timeout routine for processing delayed acks
+false instance value do-delack?
+: do-delack ( -- )
+ do-delack? if
+ t_flags delack invert and acknow or to t_flags
+ tcp_output
+ false to do-delack?
+ then
+;
+: delack-tick ( -- ) t_flags delack and 0<> to do-delack? ; \ alarm handler
+
+\ 2 MSL timeout in shutdown went off. If we're closed but
+\ still waiting for peer to close and connection has been idle
+\ too long, or if 2MSL time is up from TIME_WAIT, delete connection
+\ control block. Otherwise, check again in a bit.
+: do-2msl ( -- )
+ debug? if ." 2msl" cr then
+ ts time_wait <> t_idle maxidle <= and if
+ keepintvl tcpt_2msl !
+ else
+ tcp_close
+ then
+;
+
+\ Retransmission timer went off. Message has not
+\ been acked within retransmit interval. Back off
+\ to a longer retransmit interval and retransmit one segment.
+: do-rexmt ( -- )
+ debug? if ." Retransmit" cr then
+ t_rxtshift 1+ dup to t_rxtshift maxrxtshift > if
+ maxrxtshift to t_rxtshift
+ tcp_drop
+ exit
+ then
+ rexmtval backoff t_rxtshift na+ @ * t_rttmin set-rxtcur
+ t_rxtcur tcpt_rexmt !
+
+[ifdef] notdef \ We have no way to try for a better route
+
+ \ If losing, let the lower level know and try for
+ \ a better route. Also, if we backed off this far,
+ \ our srtt estimate is probably bogus. Clobber it
+ \ so we'll take the next rtt measurement as our srtt;
+ \ move the current srtt into rttvar to keep the current
+ \ retransmit times until then.
+
+ if (t_rxtshift > TCP_MAXRXTSHIFT / 4) {
+ in_losing(t_inpcb);
+ t_rttvar += (t_srtt >> TCP_RTT_SHIFT);
+ t_srtt = 0;
+ }
+[then]
+ snd_una set-snd_nxt
+
+ \ If timing a segment in this window, stop the timer.
+ 0 to t_rtt
+
+ \ Close the congestion window down to one segment
+ \ (we'll open it by one segment for each ack we get).
+ \ Since we probably have a window's worth of unacked
+ \ data accumulated, this "slow start" keeps us from
+ \ dumping all that data as back-to-back packets (which
+ \ might overwhelm an intermediate gateway).
+ \
+ \ There are two phases to the opening: Initially we
+ \ open by one mss on each ack. This makes the window
+ \ size increase exponentially with time. If the
+ \ window is larger than the path can handle, this
+ \ exponential growth results in dropped packet(s)
+ \ almost immediately. To get more time between
+ \ drops but still "push" the network to take advantage
+ \ of improving conditions, we switch from exponential
+ \ to linear window opening at some threshhold size.
+ \ For a threshhold, we use half the current window
+ \ size, truncated to a multiple of the mss.
+ \
+ \ (the minimum cwnd that will give us exponential
+ \ growth is 2 mss. We don't allow the threshhold
+ \ to go below this.)
+
+ snd_wnd snd_cwnd min 2/ t_maxseg / 2 max ( win )
+ t_maxseg set-cwnd ( win )
+ t_maxseg * to snd_ssthresh ( )
+ 0 to t_dupacks
+
+ tcp_output
+;
+
+\ Persistance timer into zero window.
+\ Force a byte to be output, if possible.
+: do-persist ( -- )
+ debug? if ." Persist" cr then
+ setpersist
+ true to t_force
+ tcp_output
+ false to t_force
+;
+
+0 instance value keepalive? \ A configuration flag we can set
+
+\ Keep-alive timer went off; send something
+\ or drop connection if idle for too long.
+: do-keep ( -- )
+ debug? if ." Keep" cr then
+ ts established < if tcp_drop exit then
+ keepalive? ts close_wait <= and if
+ t_idle keepidle maxidle + >= if tcp_drop exit then
+
+ \ Send a packet designed to force a response if the peer is up
+ \ and reachable: either an ACK if the connection is still alive,
+ \ or an RST if the peer has closed the connection due to timeout or
+ \ reboot. Using sequence number snd_una-1 causes the transmitted
+ \ zero-length segment to lie outside the receive window; by the
+ \ protocol spec, this requires the correspondent TCP to respond.
+
+ t_template to the-struct rcv_nxt snd_una 1- ack respond
+ keepintvl tcpt_keep !
+ else
+ keepidle tcpt_keep !
+ then
+;
+
+: countdown? ( adr -- expired? )
+ dup @ if ( adr )
+ dup @ 1- ( adr count' )
+ tuck swap ! 0=
+ else
+ drop false
+ then
+;
+
+\ Tcp protocol timeout routine called every 500 ms.
+\ Updates the timers, causing finite state machine actions when they expire.
+
+0 instance value protocol-timer?
+: do-protocol ( -- )
+ protocol-timer? 0= ?exit
+ false to protocol-timer?
+
+ 8 d# 75 * pr_slowhz * to maxidle \ 8 probes at 75-second intervals
+
+ tcpt_rexmt countdown? if do-rexmt then
+ tcpt_persist countdown? if do-persist then
+ tcpt_keep countdown? if do-keep then
+ tcpt_2msl countdown? if do-2msl then
+
+ t_idle 1+ to t_idle
+ t_rtt if t_rtt 1+ to t_rtt then
+;
+: protocol-tick ( -- )
+ alive? to protocol-timer?
+
+ \ XXX If we have multiple simultaneous TCPs, we only want to
+ \ do this in one of them. How?
+ tcp_iss issincr pr_slowhz / + to tcp_iss
+;
+
+\ Initiate connection to peer.
+\ Create a template for use in transmissions on this connection.
+\ Enter SYN_SENT state, and mark socket as connecting.
+\ Start keep-alive timer, and seed output sequence space.
+\ Send initial segment on connection.
+
+: start-connect ( port# -- )
+ to his-tcp-port
+ \ XXX how do we get our local port number???
+
+ make-template
+ syn_sent set-state
+ keep_init tcpt_keep !
+ next-iss
+ sendseqinit
+ tcp_output
+;
+
+\ After a receive, possibly send window update to peer.
+\ XXX - we need to call output after taking the receive data
+\ See: case PRU_RCVD
+
+: tcp-abort ( -- ) tcp_drop ;
+
+\ Get the out-of-band data without consuming it
+: peek-oob ( adr len -- actual )
+ \ XXX check this; there may be some data waiting during a later state
+ ts established <> if 2drop -1 exit then
+
+ t_oobflags havedata and 0= if 2drop -2 exit then
+ 0= if drop 0 exit then
+ t_iobc swap c! 1
+;
+
+\ Get the out-of-band data
+: read-oob ( adr len -- actual )
+ peek-oob ( actual )
+ dup 0> if
+ t_oobflags havedata haddata or xor to t_oobflags
+ then
+;
+
+: poll ( -- )
+ do-delack do-protocol
+ ?receive
+;
+
+: wbuf-set ( adr len -- ) over to wbuf-adr + to wbuf-top ;
+: wbuf-add ( adr len -- #added )
+ wbuf-avail min ( adr #added )
+ dup if ( adr #added )
+ tuck wbuf-top swap move ( #added )
+ dup wbuf-top + to wbuf-top ( #added )
+ else ( adr 0 )
+ nip ( 0 )
+ then ( #added )
+;
+
+: write ( adr len -- actual )
+ tuck begin ( len adr remaining )
+ alive? 0= if 3drop -1 exit then
+ 2dup wbuf-add /string ( len adr' remaining' )
+ dup while ( len adr' remaining' )
+ tcp_output poll ( len adr' remaining' )
+ repeat ( len adr 0 )
+ 2drop ( len )
+;
+
+\ Do a send by putting data in output queue and updating urgent
+\ marker if URG set. Possibly send more data.
+: write-oob ( adr len -- actual )
+ \ According to RFC961 (Assigned Protocols), the urgent pointer points
+ \ to the last octet of urgent data. BSD makes it point to the
+ \ the first octet of data past the urgent section. We follow the RFC.
+ dup 0= if nip exit then
+ dup snd_una + 1- to snd_up ( adr len )
+ true to t_force ( adr len )
+ write ( len|-1 )
+ false to t_force ( len|-1 )
+;
+
+: polls ( n -- ) 0 do poll d# 50 ms loop ;
+
+: connect ( port# -- okay? )
+ true to alive?
+ start-connect
+ begin poll ts established < while
+ debug? if key? if key drop interact then then
+ alive? 0= if false exit then
+ repeat
+ true
+;
+
+\ Other things we may need to do:
+\ in_setsockaddr
+\ in_setpeeraddr
+
+: read ( adr len -- actual )
+ poll ( adr len )
+
+ rbuf-actual if ( adr len )
+ copy-from-rbuf tcp_output exit ( actual )
+ then ( adr len )
+
+ 2drop
+ ts established <> if -1 else -2 tcp_output then
+;
+
+: init-variables ( -- )
+ 0 tcpq !
+ listen set-state
+ 0 to t_flags
+ d# 512 to t_maxseg
+ canceltimers
+ 0 to t_dupacks
+ 0 to t_force
+ 0 to rcv_wnd
+ 0 to rcv_nxt
+ 0 to rcv_up
+ 0 to irs
+
+ 0 to snd_una
+ 0 to snd_nxt
+ 0 to snd_up
+ 0 to snd_wl1
+ 0 to snd_wl2
+ 0 to snd_wnd
+ 0 to iss
+
+ 0 to rcv_adv
+ 0 to snd_max
+ maxwin to snd_cwnd
+ maxwin to snd_ssthresh
+
+ 0 to t_idle
+ 0 to t_rtt
+ 0 to t_rtseq
+ 0 to t_srtt
+ 3 pr_slowhz * 2 2+ 1- lshift to t_rttvar
+ pr_slowhz to t_rttmin
+ 0 to max_sndwnd
+
+ 0 to t_oobflags
+ 0 to t_iobc
+
+ 0 to t_rxtshift
+ rexmtval pr_slowhz set-rxtcur
+
+ false to do-delack?
+ false to keepalive?
+ false to protocol-timer?
+;
+: accept ( port# -- connected? )
+ to my-tcp-port
+ ts closed = if
+ init-variables
+ \ Tell the IP stack to accept packets from anybody
+ " unlock-ip-address" $call-parent
+ then
+ true to alive?
+ poll
+ \ XXX if state is now "closed", we need to return an error code
+ ts established =
+;
+
+: parse-args ( -- )
+ my-args
+ begin dup while ( rem$ )
+ ascii , left-parse-string ( rem$' head$ )
+ 2dup " debug" $= if true to debug? else ( rem$' head$ )
+ 2dup $set-host then ( rem$' head$ )
+ 2drop
+ repeat
+ 2drop
+;
+: open ( -- )
+ parse-args
+
+ first-time? if
+ false to first-time?
+ " next-xid" $call-parent to tcp_iss
+ then
+
+ 0 " set-timeout" $call-parent
+
+ alloc-buffers
+ ['] delack-tick d# 200 alarm
+
+ ['] protocol-tick d# 500 alarm
+
+ h# 555 to my-tcp-port \ XXX
+ true to alive?
+
+ true
+;
+
+d# 5000 constant close-wait-ms
+: drain ( -- )
+ get-msecs close-wait-ms + ( msecs )
+ begin ts time_wait < alive? and while ( msecs )
+ poll ( msecs )
+ get-msecs over - 0>= if drop exit then
+ repeat ( msecs )
+ drop
+;
+
+: flush-writes ( -- )
+ \ If the connection is already down, just blow away any pending data
+ ts closed = if wbuf-clear exit then
+
+ get-msecs
+ begin
+ wbuf-actual 0<> ( start-time flag )
+ get-msecs 2 pick - d# 10000 < ( start-time flag flag )
+ and ( start-time flag' )
+ while ( start-time )
+ tcp_output poll ( start-time )
+ repeat ( start-time )
+ drop ( )
+
+ wbuf-actual 0<> if
+ show" TDROP"
+ debug" TCP Timeout!"
+ wbuf-clear
+ then
+;
+
+\ Close the current TCP connection and wait for the state machine
+\ to make its way through the sequence of termination states.
+: disconnect ( -- )
+ usrclosed
+ flush-writes
+ alive? if tcp_output then
+ drain
+ alive? if tcp_close then
+;
+
+\ external
+: set-nodelay ( -- ) nodelay set-flag ;
+: abort-on-reconnect ( -- ) true to abort-on-reconnect? ;
+: close ( -- )
+ disconnect
+ ['] delack-tick 0 alarm
+ ['] protocol-tick 0 alarm
+ free-buffers
+;
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Added: ofw/inetv6/tcpapp.fth
===================================================================
--- ofw/inetv6/tcpapp.fth (rev 0)
+++ ofw/inetv6/tcpapp.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,52 @@
+\ See license at end of file
+purpose: TCP application convenience words
+
+0 value tcp-ih
+: $call-tcp ( ?? name$ -- ?? ) tcp-ih $call-method ;
+
+: close-tcp ( -- ) tcp-ih close-dev 0 to tcp-ih ;
+: open-tcp ( -- )
+ tcp-ih if exit then
+ " tcp" open-dev to tcp-ih
+ tcp-ih 0= abort" Can't open TCP/IP stack"
+;
+: set-tcp-server ( hostname$ -- )
+ dup if " $set-host" $call-tcp else 2drop then
+;
+: tcp-connect ( port# -- )
+ " connect" $call-tcp 0= abort" Connection refused
+;
+: tcp-disconnect ( -- ) " disconnect" $call-tcp ;
+: open-tcp-connection ( hostname$ port# -- )
+ open-tcp -rot set-tcp-server tcp-connect
+;
+
+: tcp-read ( adr len -- actual ) " read" $call-tcp ;
+: tcp-type ( adr len -- ) " write" $call-tcp drop ;
+
+variable tcp-out
+: tcp-emit ( c -- ) tcp-out c! tcp-out 1 tcp-type ;
+
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Added: ofw/inetv6/tcpv6.fth
===================================================================
--- ofw/inetv6/tcpv6.fth (rev 0)
+++ ofw/inetv6/tcpv6.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,2538 @@
+\ See license at end of file
+purpose: TCPv6 package
+
+hex
+
+true instance value use-ipv6?
+
+[ifndef] show"
+also forth definitions
+: show" [char] " parse 2drop ; immediate
+previous definitions
+[then]
+\ : xh 2dup type space ($header) ; ' xh is $header
+
+[ifndef] include-ipv4
+false instance value debug?
+false instance value abort-on-reconnect?
+
+\ : ( postpone .( cr ; immediate
+: l+! +! ;
+
+\ : debug" postpone ." postpone cr ; immediate
+: (drop$) skipstr 2drop ;
+: drop$ +level postpone (drop$) ," -level ; immediate
+: debug" debug? if postpone ." postpone cr else postpone drop$ then ; immediate
+
+alias l>n noop
+: ?exit if r> drop then ;
+[then]
+
+d# 16 constant /ipv6
+: copy-ipv6-addr /ipv6 move ;
+
+[ifndef] include-ipv4
+: oc-checksum ( n adr len -- n' ) " oc-checksum" $call-parent ;
+
+2 constant pr_slowhz
+
+false instance value alive?
+0 instance value the-struct
+
+: sfield ( offset size -- new-offset )
+ create over , +
+ does> @ the-struct +
+;
+
+: set-struct ( adr -- ) to the-struct ;
+: +struct ( offset -- ) the-struct + set-struct ;
+
+
+\ Check:
+\ unsigned comparison
+\ segment wraparound
+
+0 constant closed \ closed
+1 constant listen \ listening for connection
+2 constant syn_sent \ active, have sent syn
+3 constant syn_received \ have send and received syn
+\ states < ESTABLISHED are those where connections not established
+4 constant established \ established
+5 constant close_wait \ rcvd fin, waiting for close
+\ states > CLOSE_WAIT are those where user has closed
+6 constant fin_wait_1 \ have closed, sent fin
+7 constant closing \ closed xchd FIN; await FIN ACK
+8 constant last_ack \ had fin and close; await FIN ACK
+\ states > CLOSE_WAIT && < FIN_WAIT_2 await ACK of FIN
+9 constant fin_wait_2 \ have closed, fin is acked
+d# 10 constant time_wait \ in 2*msl quiet wait after close
+
+[then]
+
+struct \ ipv6-pseudoheader
+ 2 sfield ihv6_len
+ 2 sfield ihv6_pr
+ /ipv6 sfield ihv6_src
+ /ipv6 sfield ihv6_dst
+constant /pipv6
+
+[ifndef] include-ipv4
+struct \ tcphdr
+ /w sfield th_sport \ source port
+ /w sfield th_dport \ destination port
+ /l sfield th_seq \ sequence number
+ /l sfield th_ack \ acknowledgement number
+ /c sfield th_off4 \ Data offset in high nibble
+ /c sfield th_flags
+h# 01 constant fin
+h# 02 constant syn
+h# 04 constant rst
+h# 08 constant th_push
+h# 10 constant ack
+h# 20 constant urg
+ /w sfield th_win \ window
+ /w sfield th_sum \ checksum
+ /w sfield th_urp \ urgent pointer
+constant /tcphdr
+[then]
+
+: ipv6-struct ( -- ) /pipv6 negate +struct ;
+: tcpv6-struct ( -- ) /pipv6 +struct ;
+
+[ifndef] include-ipv4
+listnode
+ /n field >offset \ Offset into buf of the still-useful data
+ /n field >len \ Length, including out-of-band data
+ /n field >dlen \ Length, excluding out-of-band data
+ /n field >bufadr \ Buffer address
+ /n field >bufsize \ Total length of buffer
+ /l field >seq \ Sequence number
+ /c field >flags \ Flags
+nodetype: tcpqnode
+
+instance variable tcpq \ Linked list of packets to be reassembled
+0 tcpq !
+
+3 constant tcprexmtthresh \ Retransmission threshold
+
+d# 512 constant mssdflt \ Default value for maximum segment size
+3 constant rttdflt
+pr_slowhz rttdflt * constant srttdflt \ assumed RTT if no info
+
+pr_slowhz d# 30 * constant tcptv_msl \ max seg lifetime (hah!)
+
+
+d# 4096 constant mssmax \ Our (arbitrary) maximum value for
+ \ Maximum segment size, to conserve memory
+
+0 value rbuf-adr
+0 value rbuf-len
+0 value rbuf-actual
+: rbuf-space ( -- n ) rbuf-len rbuf-actual - ;
+
+\ State of this TCP
+0 instance value t_flags
+h# 01 constant acknow \ ack peer immediately
+h# 02 constant delack \ ack, but try to delay it
+h# 04 constant nodelay \ don't delay packets to coalesce
+h# 08 constant noopt \ don't use tcp options
+h# 10 constant sentfin \ have sent FIN
+0 [if]
+h# 20 constant req_scale \ have/will request window scaling
+h# 40 constant rcvd_scale \ other side has requested scaling
+[then]
+
+string-array state-names
+ ," CLOSED"
+ ," LISTEN"
+ ," SYN_SENT"
+ ," SYN_RECEIVED"
+ ," ESTABLISHED"
+ ," CLOSE_WAIT"
+ ," FIN_WAIT_1"
+ ," CLOSING"
+ ," LAST_ACK"
+ ," FIN_WAIT_2"
+ ," TIME_WAIT"
+end-string-array
+
+d# 512 instance value t_maxseg \ maximum segment size
+0 instance value ts \ state of this connection
+: set-state ( state -- )
+ to ts
+ debug? if ts state-names count type cr then
+;
+
+\ Timers
+instance variable tcpt_rexmt tcpt_rexmt off
+instance variable tcpt_persist tcpt_persist off
+instance variable tcpt_keep tcpt_keep off
+instance variable tcpt_2msl tcpt_2msl off
+
+: canceltimers ( -- )
+ tcpt_rexmt off
+ tcpt_persist off
+ tcpt_keep off
+ tcpt_2msl off
+;
+0 instance value t_dupacks \ consecutive dup acks recd
+0 instance value t_force \ true if forcing out a byte
+
+\ receive sequence variables
+0 instance value rcv_wnd \ receive window
+0 instance value rcv_nxt \ receive next
+0 instance value rcv_up \ receive urgent pointer
+0 instance value irs \ initial receive sequence number
+
+0 instance value rcv_adv \ advertised window
+
+: .flags ( flags -- )
+ dup fin and if ." FIN " then
+ dup syn and if ." SYN " then
+ dup rst and if ." RST " then
+ dup th_push and if ." PUSH " then
+ dup ack and if ." ACK " then
+ dup urg and if ." URG " then
+ drop
+;
+: .pkt ( flags win ack seq -- ) 4drop ;
+[then]
+
+: .pktv6 ( flags win ack seq -- )
+ push-hex
+ ." Seq: " th_seq be-l@ 8 u.r
+ ." Ack: " th_ack be-l@ 8 u.r
+ ." Win: " th_win be-w@ 4 u.r
+ ." Len: " ipv6-struct ihv6_len be-w@ /tcphdr - 4 u.r tcpv6-struct
+ ." Flags: " th_flags c@ .flags
+ cr
+ pop-base
+;
+: .pkt ( flags win ack seq -- ) use-ipv6? if .pktv6 else .pkt then ;
+
+[ifndef] include-ipv4
+: +rcv_nxt ( n -- ) rcv_nxt + to rcv_nxt ;
+
+0 value wbuf-start
+0 value wbuf-adr
+0 value wbuf-top
+0 value wbuf-end
+0 value wbuf-threshold
+
+d# 1024 d# 16 * constant /wbuf
+: wbuf-clear ( -- )
+ wbuf-start /wbuf + to wbuf-end
+ wbuf-start dup to wbuf-adr to wbuf-top
+ wbuf-start /wbuf 2/ + to wbuf-threshold
+;
+: wbuf-allocate ( -- )
+ /wbuf alloc-mem to wbuf-start
+ wbuf-clear
+;
+
+: wbuf-actual ( -- n ) wbuf-top wbuf-adr - ;
+: wbuf-avail ( -- n ) wbuf-end wbuf-top - ;
+
+\ Remove n bytes of data from the beginning of the write buffer
+: wbuf-drop ( n -- )
+ wbuf-adr + to wbuf-adr
+ \ If there are enough empty bytes at the beginning to make
+ \ it worthwhile to do so, copy the data down to make more
+ \ space at the end.
+ wbuf-adr wbuf-threshold >= if
+ wbuf-adr wbuf-start wbuf-actual move \ Copy bytes down
+ wbuf-actual wbuf-start + to wbuf-top \ Fix pointers
+ wbuf-start to wbuf-adr
+ then
+;
+
+\ send sequence variables
+0 instance value snd_una \ send unacknowledged
+0 instance value snd_nxt \ send next
+0 instance value snd_up \ send urgent pointer
+0 instance value snd_wl1 \ window update seg seq number
+0 instance value snd_wl2 \ window update seg ack number
+0 instance value snd_wnd \ send window
+1 value iss \ initial send sequence number
+true value first-time? \ Used to prime iss.
+1 value tcp_iss \ initial send sequence number
+
+0 instance value snd_max \ highest sequence number send
+ \ used to recognize retransmits
+
+d# 65535 constant maxwin \ largest value for unscaled window
+d# 12 constant maxrxtshift \ maximum retransmits
+
+d# 120 d# 60 * pr_slowhz *
+ constant keepidle \ time before keepalive probes begin
+
+d# 75 pr_slowhz *
+ constant keepintvl \ time between keepalive probes
+
+d# 75 pr_slowhz *
+ constant keep_init \ initial connect keep alive
+
+0 instance value maxidle
+
+\ congestion control (for slow start, source quench, retransmit after loss)
+maxwin instance value snd_cwnd \ congestion-controlled window
+maxwin instance value snd_ssthresh \ snd_cwnd size threshhold for slow
+ \ start exponential to linear switch
+
+\ transmit timing stuff. See below for scale of srtt and rttvar.
+\ "Variance" is actually smoothed difference.
+ \ Init srtt to 0, so we can tell that we have no
+ \ rtt estimate. Set rttvar so that srtt + 2 * rttvar gives
+ \ reasonable initial retransmit time.
+
+0 instance value t_idle \ inactivity time
+0 instance value t_rtt \ round trip time
+0 instance value t_rtseq \ sequence number being timed
+0 instance value t_srtt \ smoothed round-trip time
+3 pr_slowhz * 2 2+ 1- lshift
+ instance value t_rttvar \ variance in round-trip time
+pr_slowhz instance value t_rttmin \ minimum rtt allowed
+0 instance value max_sndwnd \ largest window peer has offered
+
+\ out-of-band data
+0 instance value t_oobflags \ have some
+ 1 constant havedata
+ 2 constant haddata
+0 instance value t_iobc \ input character
+[then]
+
+0 instance value xmit_bufv6
+
+[ifndef] include-ipv4
+\ Information about the current packet
+
+0 value iflags \ Copy of input packet flags
+0 value iseq \ Copy of input packet sequence number
+0 value iack \ Copy of input packet sequence number
+0 value iwin \ Copy of input packet sequence window pointer
+0 value iurp \ Copy of input packet urgent pointer
+0 value ilen \ Copy of input packet length (from IP header)
+0 value ilen-save \ Copy of input packet length (from IP header), unmolested
+
+0 value doff \ Offset to data (after options)
+0 value #oob \ # of urgent data bytes elided
+: idata ( -- adr ) the-struct doff + ;
+: idlen ( -- len ) ilen #oob - ;
+: -ilen ( n -- ) negate ilen + to ilen ;
+
+d# 64 pr_slowhz * constant rexmtmax
+: rexmtval ( -- n ) t_srtt 3 rshift t_rttvar 2 rshift + ;
+
+0 instance value t_rxtshift \ log(2) of rexmt exp. backoff
+rexmtval pr_slowhz max pr_slowhz d# 64 * min
+ instance value t_rxtcur \ current retransmit value
+
+: set-snd_nxt ( n -- ) to snd_nxt ;
+: set-cwnd ( n -- ) to snd_cwnd debug? if ." snd_cwnd set to " snd_cwnd u. cr then ;
+
+: +snd_nxt ( n -- ) snd_nxt + set-snd_nxt ;
+
+alias seq@ be-l@
+alias len@ be-w@
+
+\ Sequence numbers are 32-bit integers that use circular arithmetic
+: s< ( s1 s2 -- flag ) - l>n 0< ;
+: s> ( s1 s2 -- flag ) - l>n 0> ;
+: s<= ( s1 s2 -- flag ) - l>n 0<= ;
+: s>= ( s1 s2 -- flag ) - l>n 0>= ;
+
+: rcvseqinit ( -- ) irs 1+ dup to rcv_adv to rcv_nxt ;
+
+: sendseqinit ( -- )
+ iss dup to snd_up dup to snd_max dup set-snd_nxt to snd_una
+;
+d# 125 d# 1024 * constant issincr \ Increments for iss each second
+
+[then]
+
+: his-ipv6-addr ( -- 'ip ) " his-ipv6-addr" $call-parent ;
+: my-ipv6-addr ( -- 'ip ) " my-ipv6-addr" $call-parent ;
+: $set-host ( $ -- ) " $set-host" $call-parent ;
+: set-dest-ipv6 ( 'ip -- ) " set-dest-ipv6" $call-parent ;
+: local-ipv6? ( -- flag )
+ my-ipv6-addr his-ipv6-addr " prefix-match?" $call-parent
+;
+
+[ifndef] include-ipv4
+0 instance value my-tcp-port
+0 instance value his-tcp-port
+[then]
+
+/tcphdr /pipv6 + instance buffer: tv6_template
+: make-templatev6 ( -- )
+ tv6_template set-struct
+ the-struct /tcphdr /pipv6 + erase
+
+ 6 ihv6_pr be-w! \ IPPROTO_TCP
+ my-ipv6-addr ihv6_src copy-ipv6-addr
+ his-ipv6-addr ihv6_dst copy-ipv6-addr
+
+ tcpv6-struct
+
+ my-tcp-port th_sport be-w!
+ his-tcp-port th_dport be-w!
+
+ 5 4 lshift th_off4 c!
+;
+
+[ifndef] include-ipv4
+: copy-to-rbuf ( adr len -- )
+ tuck rbuf-adr rbuf-actual + swap move ( len )
+ rbuf-actual + to rbuf-actual ( )
+;
+: copy-from-rbuf ( adr len -- len' )
+ rbuf-actual min tuck ( len' adr len' )
+ rbuf-adr -rot move ( len' )
+ dup rbuf-actual = if ( len' )
+ 0 to rbuf-actual ( len' )
+ else ( len' )
+ \ Shuffle the remaining data down in the buffer
+ rbuf-actual over - to rbuf-actual ( len' )
+ rbuf-adr over + rbuf-adr rbuf-actual move ( len' )
+ then ( len' )
+;
+
+\ Reassembly queue management
+
+: release-tcpnode ( prev this -- )
+ \ Release the packet buffer
+ dup >bufsize @ ?dup if ( prev this len )
+ over >bufadr @ swap free-mem ( prev this )
+ then ( prev this )
+ drop delete-after tcpqnode free-node ( )
+;
+
+\ Present data to caller, advancing rcv_nxt through
+\ completed sequence space.
+: present-data ( -- flags )
+ \ Exit if we have no buffer space in which to return data
+ rbuf-len 0= if 0 exit then
+
+ \ Exit if the connection is not up
+ ts established < if 0 exit then
+
+ \ Exit if the queue is empty (i.e. there's no data to present)
+ tcpq >next-node ?dup 0= if 0 exit then ( first-node )
+
+ \ Exit if the data to be returned next has not yet arrived
+ dup >seq l@ rcv_nxt <> if drop 0 exit then ( first-node )
+
+ \ Exit if we're not quite connected
+ \ This can't happen because of the earlier check for ts=established
+\ dup >dlen @ 0<> ts syn_received = and if drop 0 exit then ( node )
+
+ begin ( node )
+ dup >flags c@ fin and swap ( flags node )
+
+ \ Compute the copy length
+ dup >dlen @ rbuf-len min ( flags node len )
+
+ \ Update rcv_nxt in sequence space, which include out-of-band data.
+ \ If len > dlen, the difference represents removed out-of-band data.
+ 2dup over >len @ rot >dlen @ - + +rcv_nxt ( flags node len )
+
+ \ Copy the data into the user buffer
+ over dup >bufadr @ swap >offset @ + ( flags node len adr )
+ over copy-to-rbuf ( flags node len )
+
+ \ "remove" the data from the list node
+ 2dup negate swap 2dup >dlen +! >len +! ( flags node len )
+
+ \ If we haven't consumed all the data in this node, update
+ \ its variables and exit.
+ over >dlen @ if ( flags node len )
+ 2dup swap >seq l+! ( flags node len )
+ 2dup swap >offset +! ( flags node len )
+
+ \ There is no point in continuing, as the user buffer must be
+ \ full (otherwise we would have consumed all the node data).
+ 2drop exit
+ then ( flags node len )
+
+ \ We have used all the node's data, so we can release the node.
+ drop ( flags node )
+
+ \ Release the node and its buffer
+ tcpq swap release-tcpnode ( flags )
+
+ \ If the user buffer is full, we can exit now
+ rbuf-len 0= ?exit ( flags )
+
+ \ Otherwise advance to the next node
+ tcpq >next-node ( flags node )
+ ?dup while ( flags node )
+ nip ( node )
+ repeat ( flags )
+;
+
+
+0 value trim-offset \ "local" variable used for reassembly queue insertion
+
+\ If there is a preceding segment, it may provide some of
+\ our data already. If so, drop the data from the incoming
+\ segment. If it provides all of our data, drop us.
+: ?trim-prev ( prev -- enclosed? )
+ 0 to trim-offset
+ dup tcpq = if drop false exit then ( prev )
+ dup >seq l@ swap >len l@ + iseq - l>n \ Wraparound ( n )
+
+ \ Exit if the segments don't overlap
+ dup 0<= if drop false exit then ( n )
+
+ \ Return true if the new packet is enclosed by the old segment
+ dup ilen >= if drop true exit then ( n )
+
+ \ Otherwise trim the packet.
+ dup to trim-offset ( n )
+ dup iseq + l>n to iseq ( n )
+ -ilen
+;
+: ?trim-nexts ( prev this -- prev this' )
+ begin dup while ( prev node )
+ iseq ilen + over >seq l@ - l>n ( prev node n )
+
+ \ Exit if no overlap
+ dup 0<= if 3drop exit then ( prev node n )
+
+ 2dup swap >len @ < if ( prev node n )
+ \ Partial overlap - trim node and exit
+ 2dup negate swap >len +! ( prev node n )
+ 2dup swap >seq l+! ( prev node n )
+ 2dup swap >offset l+! ( prev node )
+ exit
+ then ( prev node n )
+ \ Complete overlap - discard node ( prev node n )
+ drop ( prev node )
+ 2dup >next-node 2swap ( prev next prev node )
+ release-tcpnode ( prev next )
+ repeat ( prev next )
+;
+: new-node ( -- )
+ tcpqnode allocate-node ( new )
+ 0 over >offset ! ( new )
+ ilen over >len ! ( new )
+ idlen over >dlen ! ( new )
+ iseq over >seq l! ( new )
+ \ XXX this is what BSD does, but it seems to me that it
+ \ should be "iflags" instead of "th_flags c@", because
+ \ it would seem that you want the FIN flag to be trimmed
+ \ if it is outside the receive window.
+ th_flags c@ over >flags c! ( new )
+ idlen over >bufsize ! ( new )
+ idlen if ( new )
+ idlen alloc-mem ( new buf )
+ 2dup swap >bufadr ! ( new buf )
+ idata trim-offset + swap ilen move ( new )
+ then ( new )
+;
+: next-seg ( node-data-adr -- flag ) >seq l@ iseq - 0> ;
+: reassemble ( -- flags )
+ tcpq ['] next-seg find-node ( prev-node this-node|0 )
+ over ?trim-prev if 2drop 0 exit then ( prev this )
+ ?trim-nexts ( prev this )
+
+ \ Create a new fragment queue entry and insert it into place
+ drop new-node ( prev new )
+ swap insert-after ( )
+
+ present-data
+;
+
+[then]
+
+\ End of reassembly queue management
+
+\ Assumes active struct is set to the TCP header
+
+\ For now we assume no IP options; the IP layer should probably
+\ strip them for us anyway
+
+: sumv6-bad? ( adr len -- flag )
+ swap /pipv6 - set-struct ( len )
+ dup ihv6_len be-w! ( len ) \ Put length field back
+ 6 ihv6_pr be-w! ( len ) \ TCP protocol
+ 0 the-struct rot /pipv6 + oc-checksum h# ffff <>
+;
+
+[ifndef] include-ipv4
+0 value optp 0 value optlen
+0 value acked
+0 value needoutput
+0 value cantrcvmore?
+
+: set-flag ( bitmask -- ) t_flags or to t_flags ;
+: set-acknow ( -- ) acknow set-flag ;
+: clear-iflag ( flag -- ) iflags swap invert and to iflags ;
+: iflag? ( bitmask -- ) iflags and 0<> ;
+: t_flag? ( bitmask -- ) t_flags and 0<> ;
+: take-data ( -- )
+ ilen +rcv_nxt
+
+ \ Set DELACK for segments received in order, but ack immediately
+ \ when segments are out of order (so fast retransmit can work).
+ idata idlen copy-to-rbuf
+ iflags th_push and if acknow else delack then set-flag
+;
+
+: set-rxtcur ( val limit -- ) max rexmtmax min to t_rxtcur ;
+
+\ Collect new round-trip time estimate
+\ and update averages and current timeout
+: xmit_timer ( rtt -- )
+ 1- ( rtt )
+ t_srtt if ( rtt )
+ \ srtt is stored as fixed point with 3 bits after the
+ \ binary point (i.e., scaled by 8). The following magic
+ \ is equivalent to the smoothing algorithm in rfc793 with
+ \ an alpha of .875 (srtt = rtt/8 + srtt*7/8 in fixed
+ \ point). Adjust rtt to origin 0.
+ dup 2 lshift t_srtt 3 rshift - ( rtt delta )
+ dup t_srtt + 1 max to t_srtt ( rtt delta )
+
+ \ We accumulate a smoothed rtt variance (actually, a
+ \ smoothed mean difference), then set the retransmit
+ \ timer to smoothed rtt + 4 times the smoothed variance.
+ \ rttvar is stored as fixed point with 2 bits after the
+ \ binary point (scaled by 4). The following is
+ \ equivalent to rfc793 smoothing with an alpha of .75
+ \ (rttvar = rttvar*3/4 + |delta| / 4). This replaces
+ \ rfc793's wired-in beta.
+ abs t_rttvar 2 rshift - ( rtt delta' )
+ 1 max to t_rttvar ( rtt )
+ else
+ \ No rtt measurement yet - use the unsmoothed rtt.
+ \ Set the variance to half the rtt (so our first
+ \ retransmit happens at 3*rtt).
+ dup 5 lshift to t_srtt ( rtt ) ( 5 is 3 + 2 )
+ dup 3 lshift to t_rttvar ( rtt )
+ then ( rtt )
+ 0 to t_rtt ( rtt )
+ 0 to t_rxtshift ( rtt )
+
+ \ the retransmit should happen at rtt + 4 * rttvar.
+ \ Because of the way we do the smoothing, srtt and rttvar
+ \ will each average +1/2 tick of bias. When we compute
+ \ the retransmit timer, we want 1/2 tick of rounding and
+ \ 1 extra tick because of +-1/2 tick uncertainty in the
+ \ firing of the timer. The bias will give us exactly the
+ \ 1.5 tick we need. But, because the bias is
+ \ statistical, we have to test that we don't drop below
+ \ the minimum feasible timer (which is 2 ticks).
+
+ 2+ rexmtval set-rxtcur
+;
+
+: ack-una ( -- )
+ iack to snd_una
+ snd_nxt snd_una s< if snd_una set-snd_nxt then
+;
+[then]
+
+\ Determine a reasonable value for maxseg size.
+\ If the route is known, check route for mtu.
+\ If none, use an mss that can be handled on the outgoing
+\ interface without forcing IP to fragment; if bigger than
+\ an mbuf cluster (MCLBYTES), round down to nearest multiple of MCLBYTES
+\ to utilize large mbufs. If no route is found, route has no mtu,
+\ or the destination isn't local, use a default, hopefully conservative
+\ size (usually 512 or the default IP max size, but no more than the mtu
+\ of the interface), as we can't discover anything about intervening
+\ gateways or networks. We also initialize the congestion/slow start
+\ window to be a single segment if the destination isn't local.
+\ While looking at the routing entry, we also initialize other path-dependent
+\ parameters from pre-set or cached values in the routing entry.
+
+: tcp_mssv6 ( offer -- chosen )
+ \ XXX we probably should try to first determine whether or not we
+ \ know anything about the route, and if not, just return mssdflt
+
+ \ Use link MTU on a LAN, otherwise use a conservative default
+ \ not larger than the link MTU
+
+ " max-ipv6-payload" $call-parent /tcphdr - ( offer limit )
+ mssmax min ( offer limit )
+ local-ipv6? 0= if mssdflt min then ( offer limit )
+
+ \ If offer is nonzero, use the computed value, otherwise use the
+ \ smaller of the offer and the computed value.
+ over if over min then ( offer chosen )
+
+ \ But in all cases, use at least 32 bytes
+ d# 32 max ( offer chosen' )
+
+ \ If this results in a smaller segment size than we're currently
+ \ using, or if offer is nonzero, then reduce the current size.
+ dup t_maxseg < rot 0<> or if ( chosen )
+ dup to t_maxseg ( chosen )
+ debug? if ." Maxseg set to " t_maxseg u. cr then
+ then ( chosen )
+
+ \ Set the slow-open window size
+ dup set-cwnd ( chosen )
+;
+
+[ifndef] include-ipv4
+
+\ Output code
+
+0 value len
+0 value ourfinisacked?
+
+0 value idle?
+0 value sendalot?
+
+\ Flags used when sending segments in tcp_output.
+\ Basic flags (TH_RST,TH_ACK,TH_SYN,TH_FIN) are totally
+\ determined by state, with the proviso that TH_FIN is sent only
+\ if all data queued for output is included in the segment.
+create outflags
+ rst ack or c, \ 0 closed
+ 0 c, \ 1 listen
+ syn c, \ 2 syn_sent
+ syn ack or c, \ 3 syn_received
+ ack c, \ 4 established
+ ack c, \ 5 close_wait
+ fin ack or c, \ 6 fin_wait_1
+ fin ack or c, \ 7 closing
+ fin ack or c, \ 8 last_ack
+ ack c, \ 9 fin_wait_2
+ ack c, \ 10 time_wait
+
+0 value oflags
+: oflag? ( bitmask -- flag ) oflags and 0<> ;
+: fin-off ( -- ) oflags fin invert and to oflags ;
+
+create backoff
+base @ decimal
+ 1 , 2 , 4 , 8 , 16 , 32 , 64 , 64 , 64 , 64 , 64 , 64 , 64 ,
+base !
+
+pr_slowhz 5 * constant persmin
+pr_slowhz d# 60 * constant persmax
+
+: setpersist ( -- )
+ t_srtt 2 rshift t_rttvar + 1 rshift ( t )
+
+ \ Start/restart persistance timer.
+ backoff t_rxtshift na+ @ * ( t*backoff )
+
+ persmin max persmax min tcpt_persist !
+
+ t_rxtshift 1+ maxrxtshift min to t_rxtshift
+;
+
+0 value win
+0 value offs
+: dont-send? ( -- exit? )
+ false
+
+ \ Sender silly window avoidance. If connection is idle and can send
+ \ all data, a maximum segment, at least a maximum default-size segment
+ \ do it, or are forced, do it; otherwise don't bother.
+ \ If peer's buffer is tiny, then send when window is at least half open.
+ \ If retransmitting (possibly after persist timer forced us
+ \ to send into a small window), then must resend.
+
+ len if
+ len t_maxseg = ?exit
+
+ idle? nodelay t_flag? or len offs + wbuf-actual >= and ?exit
+
+ t_force ?exit
+
+ len max_sndwnd 2/ >= ?exit
+
+ snd_nxt snd_max s< ?exit
+ then
+
+ \ Compare available window to amount of window known to peer (as
+ \ advertised window less next expected input). If the difference
+ \ is at least two max size segments, or at least 50% of the maximum
+ \ possible window, then want to send a window update to peer.
+
+ win 0> if
+ \ "adv" is the amount we can increase the window,
+ \ taking into account that we are limited by MAXWIN
+
+ maxwin win min rcv_adv rcv_nxt - - ( adv )
+ dup t_maxseg 2* >= if drop exit then ( adv )
+
+ 2* rbuf-len >= ?exit ( )
+ then
+
+ \ Send if we owe peer an ACK.
+
+ acknow t_flag? ?exit
+ syn rst or oflag? ?exit
+ snd_up snd_una s> ?exit
+
+ \ If our state indicates that FIN should be sent
+ \ and we have not yet done so, or we're retransmitting the FIN,
+ \ then we need to send.
+
+ fin oflag?
+ sentfin t_flag? 0= snd_nxt snd_una = or and ?exit
+
+ \ TCP window updates are not reliable, rather a polling protocol
+ \ using ``persist'' packets is used to insure receipt of window
+ \ updates. The three ``states'' for the output side are:
+ \ idle not doing retransmits or persists
+ \ persisting to move a small or zero window
+ \ (re)transmitting and thereby not persisting
+ \
+ \ TCPT_PERSIST is set when we are in persist state.
+ \ t_force is set when we are called to send a persist packet.
+ \ TCPT_REXMT is set when we are retransmitting
+ \
+ \ The output side is idle when both timers are zero.
+ \
+ \ If send window is too small, there is data to transmit, and no
+ \ retransmit or persist is pending, then go to persist state.
+ \ If nothing happens soon, send when timer expires:
+ \ if window is nonzero, transmit what we can, otherwise force out a byte.
+
+ wbuf-actual 0<> tcpt_rexmt @ 0= and tcpt_persist @ 0= and if
+ 0 to t_rxtshift
+ setpersist
+ then
+
+ drop true
+;
+
+\ TCP output routine: figure out what should be sent and send it.
+d# 32 buffer: opt
+0 value hdrlen
+[then]
+
+: make-optionsv6 ( -- )
+ \ Before ESTABLISHED, force sending of initial options
+ \ unless TCP set not to do any options.
+ \ NOTE: we assume that we have space for the IP/TCP header plus TCP
+ \ options, leaving room for a maximum link header, i.e.
+ \ max_linkhdr + sizeof (struct tcpiphdr) + optlen <= buflen
+
+ 0 to optlen
+ /tcphdr to hdrlen
+ syn oflag? if
+ iss set-snd_nxt
+ noopt t_flag? 0= if
+ 2 opt c! \ tcpopt_maxseg
+ 4 opt 1+ c! \ option length
+ debug? if ." Sending " then
+ 0 tcp_mssv6 opt 2+ be-w! \ option value
+ 4 to optlen
+ then
+ then
+
+ optlen hdrlen + to hdrlen
+
+ \ Adjust data length if insertion of options will
+ \ bump the packet length beyond the t_maxseg length.
+
+ len t_maxseg optlen - > if
+ t_maxseg optlen - to len
+ fin-off
+ true to sendalot?
+ then
+;
+
+: insert-datav6 ( -- )
+ \ Grab a transmit buffer, attaching a copy of data to
+ \ be transmitted, and initialize the header from
+ \ the template for sends on this connection.
+
+ xmit_bufv6 set-struct
+
+ len if
+ wbuf-adr offs + xmit_bufv6 hdrlen + len move
+
+ \ If we're sending everything we've got, set PUSH.
+ \ (This will keep happy those implementations which only
+ \ give data to the user when a buffer fills or
+ \ a PUSH comes in.)
+
+ offs len + wbuf-actual =
+ len snd_cwnd = or \ Also PUSH when we have a lot
+ if
+ oflags th_push or to oflags
+ then
+ then
+;
+
+[ifndef] include-ipv4
+: set-window ( -- )
+ \ Calculate receive window. Don't shrink window,
+ \ but avoid silly window syndrome.
+
+ win rbuf-len 4 / < win t_maxseg < and if 0 to win then
+
+ win maxwin min rcv_adv rcv_nxt - max th_win be-w!
+
+ snd_up snd_nxt s> if
+ snd_up snd_nxt - th_urp be-w!
+ th_flags c@ urg or th_flags c!
+ else
+ \ If no urgent pointer to send, then we pull
+ \ the urgent pointer to the left edge of the send window
+ \ so that it doesn't drift into the send window on sequence
+ \ number wraparound.
+ snd_una to snd_up
+ then
+;
+: set-timers ( -- )
+ \ In transmit state, time the transmission and arrange for
+ \ the retransmit. In persist state, just set snd_max.
+
+ t_force 0= tcpt_persist @ 0= or if
+ snd_nxt ( startseq )
+
+ \ Advance snd_nxt over sequence space of this segment.
+
+ syn oflag? if 1 +snd_nxt then
+ fin oflag? if 1 +snd_nxt sentfin set-flag then
+
+ len +snd_nxt
+
+ snd_nxt snd_max s> if
+ snd_nxt to snd_max
+
+ \ Time this transmission if not a retransmission and
+ \ not currently timing anything.
+ t_rtt 0= if 1 to t_rtt dup to t_rtseq then ( startseq )
+ then
+
+ \ We're done with startseq
+ drop ( )
+
+ \ Set retransmit timer if not currently set,
+ \ and not doing an ack or a keep-alive probe.
+ \ Initial value for retransmit timer is smoothed
+ \ round-trip time + 2 * round-trip time variance.
+ \ Initialize shift counter which is used for backoff
+ \ of retransmit time.
+
+ tcpt_rexmt @ 0= snd_nxt snd_una <> and if
+ t_rxtcur tcpt_rexmt !
+ tcpt_persist @ if tcpt_persist off 0 to t_rxtshift then
+ then
+ else
+ snd_nxt len + snd_max s> if snd_nxt len + to snd_max then
+ then
+;
+: send ( -- ) ;
+[then]
+
+\ Called only from tcp_output
+: sendv6 ( -- )
+ make-optionsv6
+
+ insert-datav6
+
+ tv6_template xmit_bufv6 /pipv6 - /tcphdr /pipv6 + move \ Copy in header
+
+ \ Fill in fields, remembering maximum advertised
+ \ window for use in delaying messages about window sizes.
+ \ If resending a FIN, be sure not to use a new sequence number.
+
+ fin oflag? sentfin t_flag? and
+ snd_nxt snd_max = and if -1 +snd_nxt then
+
+ \ If we are doing retransmissions, then snd_nxt will not reflect the first
+ \ unsent octet. For ACK only packets, we do not want the sequence number
+ \ of the retransmitted packet, we want the sequence number of the next
+ \ unsent octet. So, if there is no data (and no SYN or FIN), use snd_max
+ \ instead of snd_nxt when filling in iseq. But if we are in persist
+ \ state, snd_max might reflect one byte beyond the right edge of the
+ \ window, so use snd_nxt in that case, since we know we aren't doing a
+ \ retransmission. (retransmit and persist are mutually exclusive...)
+
+ len 0<> syn fin or oflag? or tcpt_persist @ 0<> or if
+ snd_nxt
+ else
+ snd_max
+ then
+ th_seq be-l!
+
+ rcv_nxt th_ack be-l!
+ optlen if
+ opt the-struct /tcphdr + optlen move
+ /tcphdr optlen + 2 rshift 4 lshift th_off4 c!
+ then
+
+ oflags th_flags c!
+
+ set-window
+
+ \ Put TCP length in extended header, and then
+ \ checksum extended header and data.
+
+ ipv6-struct
+ 6 ihv6_pr be-w!
+ /tcphdr optlen + len + ihv6_len be-w! ( )
+ 0 the-struct hdrlen len + /pipv6 + oc-checksum ( sum )
+ tcpv6-struct ( sum )
+ th_sum be-w! ( )
+
+ set-timers
+
+ debug? if ." XMT " .pkt then
+
+ \ Send to IP level.
+
+ the-struct hdrlen len + 6 " send-ipv6-packet" $call-parent \ 6 is IPPROTO_TCP
+
+ \ Data sent (as far as we can tell).
+ \ If this advertises a larger window than any other segment,
+ \ then remember the size of the advertised window.
+ \ Any pending ACK has now been sent.
+
+ win 0> rcv_nxt win + rcv_adv s> and if
+ rcv_nxt win + to rcv_adv
+ then
+ t_flags acknow delack or invert and to t_flags
+;
+
+: tcp_outputv6 ( -- )
+ \ Determine length of data that should be transmitted,
+ \ and flags that will be used.
+ \ If there is some data or critical controls (SYN, RST)
+ \ to send, then transmit; otherwise, investigate further.
+
+ snd_max snd_una = to idle?
+ idle? t_idle t_rxtcur >= and if
+ \ We have been idle for "a while" and no acks are expected to clock out
+ \ any data we send -- slow start to get ack "clock" running again.
+ t_maxseg set-cwnd
+ then
+ begin
+ false to sendalot?
+ snd_nxt snd_una - to offs
+ snd_wnd snd_cwnd min to win
+ outflags ts ca+ c@ to oflags
+
+ \ If in persist timeout with window of 0, send 1 byte.
+ \ Otherwise, if window is small but nonzero and timer expired,
+ \ we will send what we can and go to transmit state.
+
+ t_force if
+ win if
+ tcpt_persist off
+ 0 to t_rxtshift
+ else
+ \ If we still have some data to send, then clear the FIN bit.
+ \ Usually this would happen below when it realizes that we
+ \ aren't sending all the data. However, if we have exactly
+ \ 1 byte of unset data, then it won't clear the FIN bit below,
+ \ and if we are in persist state, we wind up sending the packet
+ \ without recording that we sent the FIN bit.
+ \
+ \ We can't just blindly clear the FIN bit, because if we don't
+ \ have any more data to send then the probe will be the FIN itself.
+ off wbuf-actual < if fin-off then
+ 1 to win
+ then
+ then
+
+ win wbuf-actual < if fin-off win else wbuf-actual then ( n )
+ offs - to len
+
+ len 0< if
+ \ If FIN has been sent but not acked, but we haven't been called
+ \ to retransmit, len will be -1. Otherwise, window shrank
+ \ after we sent into it. If window shrank to 0, cancel pending
+ \ retransmit and pull snd_nxt back to (closed) window. We will
+ \ enter persist state below. If the window didn't close completely,
+ \ just wait for an ACK.
+ 0 to len
+ win 0= if tcpt_rexmt off snd_una set-snd_nxt then
+ then
+
+ len t_maxseg > if t_maxseg to len fin-off true to sendalot? then
+
+ rbuf-space to win
+
+ dont-send? ?exit
+
+ sendv6
+ sendalot? 0= until
+;
+
+: fast-pathv6? ( -- flag )
+ \ Header prediction: check for the two common cases
+ \ of a uni-directional data xfer. If the packet has
+ \ no control flags, is in-sequence, the window didn't
+ \ change and we're not retransmitting, it's a
+ \ candidate. If the length is zero and the ack moved
+ \ forward, we're the sender side of the xfer. Just
+ \ free the data acked & wake any higher level process
+ \ that was blocked waiting for space. If the length
+ \ is non-zero and the ack didn't move, we're the
+ \ receiver side. If we're getting packets in-order
+ \ (the reassembly queue is empty), add the data to
+ \ the socket buffer and note that we need a delayed ack.
+
+ ts established = \ Connection up?
+ iflags h# 37 and ack = and \ No control flags?
+ iseq rcv_nxt = and \ In sequence?
+ iwin 0<> and \ Window didn't change?
+ iwin snd_wnd = and \ Window didn't change?
+ snd_nxt snd_max = and if \ Not retransmitting?
+ ilen if
+ \ Incoming data
+
+ iack snd_una = \ in sequence data packet?
+ tcpq >next-node 0= and \ reassembly queue empty?
+ ilen rbuf-space <= and if \ enough space to take it?
+ take-data
+ true exit
+ then
+ false exit
+ then
+
+ \ ACK for outgoing data
+
+ iack snd_una - 0>
+ iack snd_max - 0<= and
+ snd_cwnd snd_wnd >= and
+ t_dupacks tcprexmtthresh < and if
+ \ This is a pure ack for outstanding data
+ t_rtt 0<> iack t_rtseq - 0> and if
+ t_rtt xmit_timer
+ then
+ iack snd_una - to acked
+ \ XXX drop-snd needs to "wakeup" the sender
+ acked wbuf-drop
+ iack to snd_una
+ \ We are now finished with the packet data
+
+ \ If all outstanding data are acked, stop
+ \ retransmit timer, otherwise restart timer
+ \ using current (possibly backed-off) value.
+ \ If process is waiting for space,
+ \ wakeup/selwakeup/signal. If data
+ \ are ready to send, let output
+ \ decide between more output or persist.
+
+ snd_una snd_max = if tcpt_rexmt off else
+ tcpt_persist @ 0= if t_rxtcur tcpt_rexmt ! then then
+
+ wbuf-actual if tcp_outputv6 then
+ true exit
+ then
+ false exit
+ then
+
+ false
+;
+
+[ifndef] include-ipv4
+: get-info ( -- )
+ th_flags c@ to iflags
+ th_seq be-l@ to iseq
+ th_ack be-l@ to iack
+ th_win be-w@ to iwin
+ th_urp be-w@ to iurp
+;
+
+: pull-options ( -- error )
+ \ Handle options
+ th_off4 c@ 4 rshift /l* to doff ( )
+ doff /tcphdr < doff ilen > or if true exit then
+
+ doff -ilen
+ doff /tcphdr - dup to optlen if the-struct /tcphdr + to optp then
+ false
+;
+: update-window ( -- )
+ \ Update window information.
+ \ Don't look at window if no ACK: TAC's send garbage on first SYN.
+ ack iflag? snd_wl1 iseq s< and
+ snd_wl1 iseq = snd_wl2 iack s< and or
+ snd_wl2 iack = iwin snd_wnd > and or if
+ \ keep track of pure window updates
+ \ ilen 0= snd_wl2 iack = and iwin snd_wnd > and if ( +stats ) then
+ iwin to snd_wnd
+ iseq to snd_wl1
+ iack to snd_wl2
+
+ snd_wnd max_sndwnd > if snd_wnd to max_sndwnd then
+ true to needoutput
+ then
+;
+
+\ Move the byte of urgent data out of the in-band data stream,
+\ placing it in t_iobc.
+
+: pulloutofband ( -- )
+ iurp 1- ( off ) \ Offset to OOB byte
+ idata over + ( off adr ) \ Address of OOB byte
+ dup c@ to t_iobc ( off adr ) \ Get OOB byte
+ t_oobflags havedata or to t_oobflags ( off adr ) \ Note its existence
+ dup ca1+ swap rot ( adr+1 adr off ) \ Setup to remove
+ ilen swap - 1- move ( ) \ byte from in-band data
+ #oob 1+ to #oob \ Note elided byte
+;
+
+: do-urgent ( -- )
+ \ Process segments with URG.
+ urg iflag? iurp 0<> and ts time_wait < and if
+ \ This is a kludge, but if we receive and accept
+ \ random urgent pointers, we'll crash in
+ \ soreceive. It's hard to imagine someone
+ \ actually wanting to send this much urgent data.
+
+ iurp rbuf-actual + rbuf-len > if
+ 0 to iurp
+ urg clear-iflag
+ exit
+ then
+
+ \ If this segment advances the known urgent pointer,
+ \ then mark the data stream. This should not happen
+ \ in CLOSE_WAIT, CLOSING, LAST_ACK or TIME_WAIT STATES since
+ \ a FIN has been received from the remote side.
+ \ In these states we ignore the URG.
+ \
+ \ According to RFC961 (Assigned Protocols),
+ \ the urgent pointer points to the last octet
+ \ of urgent data. We continue, however,
+ \ to consider it to indicate the first octet
+ \ of data past the urgent section as the original
+ \ spec states (in one of two places).
+
+ iseq iurp + rcv_up s> if
+ iseq iurp + to rcv_up
+\ rbuf-actual rcv_up rcv_nxt - + 1- to so_oobmark
+ \ XXX if (so_oobmark == 0) so_state |= SS_RCVATMARK;
+ \ XXX sohasoutofband(so);
+ t_oobflags havedata haddata or invert and to t_oobflags
+ then
+
+ \ Remove out of band data so doesn't get presented to user.
+ \ This can happen independent of advancing the URG pointer,
+ \ but if two URG's are pending at once, some out-of-band
+ \ data may creep in... ick.
+
+ iurp ilen u<= if pulloutofband then
+ else
+ \ If no out of band data is expected, pull receive
+ \ urgent pointer along with the receive window.
+ rcv_nxt rcv_up s> if rcv_nxt to rcv_up then
+ then
+;
+[then]
+
+: do-datav6 ( -- )
+ \ Process the segment text, merging it into the TCP sequencing queue,
+ \ and arranging for acknowledgment of receipt if necessary.
+ \ This process logically involves adjusting rcv_wnd as data
+ \ is presented to the user (this happens in tcp_usrreq
+ \ case PRU_RCVD). If a FIN has already been received on this
+ \ connection then we just ignore the text.
+
+ ilen 0<> fin iflag? or ts time_wait < and if
+ iseq rcv_nxt =
+ tcpq >next-node 0<> and
+ ts established = and if
+ \ The segment need not be queued for reassembly, because
+ \ this is the next segment and the queue is empty.
+ take-data
+ \ XXX this is what BSD does, but it seems to me that it
+ \ should be "iflags" instead of "th_flags c@", because
+ \ it would seem that you want the FIN flag to be trimmed
+ \ if it is outside the receive window.
+ th_flags c@ fin and to iflags
+ else
+ \ Insert the segment into the reassembly queue
+ reassemble to iflags
+ set-acknow
+ then
+
+ \ Note the amount of data that peer has sent into our
+ \ window, in order to estimate the sender's buffer size.
+
+ \ XXX NetBSD sets this, but then doesn't use the value
+ \ rbuf-len rcv_adv rcv_nxt - - to len
+ else
+ fin clear-iflag
+ then
+
+ \ If FIN is received ACK the FIN and let the user know
+ \ that the connection is closing. Ignore a FIN received before
+ \ the connection is fully established.
+
+ fin iflag? ts established >= and if
+ ts time_wait < if
+ true to cantrcvmore?
+ set-acknow
+ 1 +rcv_nxt \ Advance sequence number past FIN
+ then
+ ts case
+
+ \ In ESTABLISHED STATE enter the CLOSE_WAIT state.
+ established of close_wait set-state endof
+
+ \ If still in FIN_WAIT_1 STATE FIN has not been acked so
+ \ enter the CLOSING state.
+ fin_wait_1 of closing set-state endof
+
+ \ In FIN_WAIT_2 state enter the TIME_WAIT state,
+ \ starting the time-wait timer, turning off the other
+ \ standard timers.
+
+ fin_wait_2 of
+ time_wait set-state
+ canceltimers
+ tcptv_msl 2* tcpt_2msl !
+ \ soisdisconnected
+ endof
+
+ \ In TIME_WAIT state restart the 2 MSL time_wait timer.
+ time_wait of tcptv_msl 2* tcpt_2msl ! endof
+ endcase
+ then
+
+ \ Return any desired output.
+ needoutput acknow t_flag? or if tcp_outputv6 then
+;
+: dropafterackv6 ( -- )
+ \ Generate an ACK dropping incoming segment if it occupies
+ \ sequence space, where the ACK reflects our state.
+ rst iflag? ?exit
+ set-acknow
+ tcp_outputv6
+;
+
+\ Called with the-struct set to a TCP header
+: respondv6 ( ack seq flags -- )
+ \ Copy to the transmit area so we can modify it
+ ipv6-struct
+ the-struct xmit_bufv6 /pipv6 - /tcphdr /pipv6 + move
+ xmit_bufv6 set-struct
+
+ \ Now the-struct points to the copy
+
+ ( ack seq flags )
+ th_flags c! ( ack seq )
+ th_seq be-l! ( ack )
+ th_ack be-l! ( )
+ /tcphdr 2 rshift 4 lshift th_off4 c!
+ rbuf-space th_win be-w!
+ 0 th_urp be-w!
+ 0 th_sum be-w!
+
+ \ Prepare the pseudo-header for checksumming
+ ipv6-struct
+ 6 ihv6_pr be-w!
+ /tcphdr ihv6_len be-w!
+ 0 the-struct /tcphdr /pipv6 + oc-checksum ( sum )
+ tcpv6-struct
+ th_sum be-w!
+
+ debug? if ." Xrs " .pkt then
+
+ \ XXX this will always send to our server; it should
+ \ be able to send to anybody.
+ the-struct /tcphdr 6 " send-ip-packet" $call-parent
+\ the-struct /tcphdr 6 dst-ip (send-ip-packet)
+;
+
+: swap-addressesv6 ( -- )
+ ipv6-struct
+ ihv6_src unaligned-l@ ihv6_dst unaligned-l@
+ ihv6_src unaligned-l! ihv6_dst unaligned-l!
+
+ tcpv6-struct
+ th_sport w@ th_dport w@ th_sport w! th_dport w!
+;
+: multicast-dstv6? ( -- flag )
+ ipv6-struct ihv6_dst tcpv6-struct ( adr ) " his-mc-ipv6-addr?" $call-parent
+;
+/ipv6 buffer: tmp-ipv6
+: dropwithresetv6 ( -- )
+ \ Generate a RST, dropping incoming segment.
+ \ Make ACK acceptable to originator of segment.
+ \ Don't bother to respond if destination was broadcast/multicast.
+
+ rst iflag? ?exit
+
+ \ XXX we also need to reject broadcast source addresses
+\ m_flags bcast mcast or and ?exit
+ multicast-dstv6? ?exit
+
+ swap-addressesv6
+ ack iflag? if
+ 0 iack rst
+ else
+ syn iflag? if -1 -ilen then
+ iseq ilen + 0 rst ack or
+ then ( ack seq flags )
+
+ his-ipv6-addr tmp-ipv6 copy-ipv6-addr
+ ipv6-struct ihv6_dst set-dest-ipv6 tcpv6-struct
+ respondv6 ( )
+ tmp-ipv6 set-dest-ipv6
+;
+
+: step6v6 ( -- )
+ update-window
+ do-urgent
+ do-datav6
+;
+
+: trimthenstep6v6 ( -- )
+ \ Advance iseq to correspond to first data byte.
+ \ If data, trim to stay within window,
+ \ dropping FIN if necessary.
+ iseq 1+ to iseq
+ ilen rcv_wnd > if
+ rcv_wnd to ilen
+ iflags fin invert and to iflags
+ then
+ iseq 1- to snd_wl1
+ iseq to rcv_up
+ step6v6
+;
+
+\ Close a TCP control block, freeing all space
+: tcp_close ( -- )
+ \ Release reassmbly queue nodes
+ begin tcpq >next-node while tcpq dup >next-node release-tcpnode repeat
+
+ closed set-state
+ false to alive?
+ false to abort-on-reconnect?
+;
+[then]
+
+\ Drop a TCP connection, reporting the specified error.
+\ If connection is synchronized, then send a RST to peer.
+: tcp_drop ( -- )
+ ts syn_received >= if closed set-state tcp_outputv6 then
+ tcp_close
+;
+
+[ifndef] include-ipv4
+: next-iss ( -- )
+ tcp_iss to iss
+ issincr 2/ tcp_iss + to tcp_iss
+;
+[then]
+
+: do-syn-sentv6? ( -- done? )
+ ts syn_sent <> if false exit then
+
+ \ If the state is SYN_SENT:
+ \ if seg contains an ACK, but not for our SYN, drop the input.
+ \ if seg contains a RST, then drop the connection.
+ \ if seg does not contain SYN, then drop it.
+ \ Otherwise this is an acceptable SYN segment
+ \ initialize rcv_nxt and irs
+ \ if seg contains ack then advance snd_una
+ \ if SYN has been acked change to ESTABLISHED else SYN_RCVD state
+ \ arrange for segment to be acked (eventually)
+ \ continue processing rest of data/controls, beginning with URG
+
+ ack iflag? iack iss s<= iack snd_max s> or and if
+ dropwithresetv6 true exit
+ then
+
+ rst iflag? if
+ ack iflag? if
+ debug" Connection refused"
+ tcp_drop
+ then \ Connection refused
+ true exit
+ then
+
+ syn iflag? 0= if true exit then
+
+ ack iflag? if ack-una then
+
+ tcpt_rexmt off
+ iseq to irs
+ rcvseqinit
+ set-acknow
+ ack iflag? snd_una iss s> and if
+ established set-state
+ present-data drop
+ \ if we didn't have to retransmit the SYN,
+ \ use its rtt as our initial srtt & rtt var.
+ t_rtt if t_rtt xmit_timer then
+ else
+ syn_received set-state
+ then
+
+ trimthenstep6v6 true
+;
+
+[ifndef] include-ipv4
+: ?drop-some ( -- )
+ rcv_nxt iseq - dup 0<= if drop exit then ( #todrop )
+ syn iflag? if
+ syn clear-iflag
+ iseq 1+ to iseq
+ iurp 1 > if
+ iurp 1- to iurp
+ else
+ urg clear-iflag
+ then
+ 1- ( #todrop' )
+ then ( #todrop )
+
+ dup ilen >= if ( #todrop )
+ \ Any valid FIN must be to the left of the
+ \ window. At this point, FIN must be a
+ \ duplicate or out-of-sequence, so drop it.
+ fin clear-iflag
+
+ \ Send ACK to resynchronize, and drop any data,
+ \ but keep on processing for RST or ACK.
+ set-acknow ( #todrop )
+ drop ilen ( #todrop' )
+ then ( #todrop )
+
+ dup doff + to doff ( #todrop )
+ dup iseq + to iseq ( #todrop )
+ dup -ilen ( #todrop )
+ iurp over > if ( #todrop )
+ iurp over - to iurp ( #todrop )
+ else ( #todrop )
+ urg clear-iflag ( #todrop )
+ 0 to iurp ( #todrop )
+ then ( #todrop )
+ drop ( )
+;
+[then]
+
+: seg-after-winv6? ( -- done? )
+ \ If segment ends after window, drop trailing data
+ \ (and PUSH and FIN); if nothing left, just ACK.
+
+ iseq ilen + rcv_nxt rcv_wnd + - ( #todrop )
+ dup 0<= if drop false exit then ( #todrop )
+
+ dup ilen >= if ( #todrop )
+ \ If a new connection request is received
+ \ while in TIME_WAIT, drop the old connection
+ \ and start over if the sequence numbers
+ \ are above the previous ones. Otherwise, queue it
+ \ for later processing.
+ syn iflag? if
+ ts time_wait = iseq rcv_nxt s> and if ( #todrop )
+ rcv_nxt issincr + to iss
+ tcp_close
+ \ XXX we need to find some way to get back to findpcb:
+ \ goto findpcb
+ \ XXX this is moot since a new instance of this TCP
+ \ package must be created in order to accept a new
+ \ connection.
+ drop true exit
+ else
+ drop false exit
+ then
+ then ( #todrop )
+
+ \ If window is closed can only take segments at
+ \ window edge, and have to drop data and PUSH from
+ \ incoming segments. Continue processing, but
+ \ remember to ack. Otherwise, drop segment and ack.
+
+ rcv_wnd 0= iseq rcv_nxt = and if ( #todrop )
+ set-acknow
+ else ( #todrop )
+ drop dropafterackv6 true exit
+ then ( #todrop )
+ then ( #todrop )
+
+ \ Drop the extra data from the end of the packet
+ -ilen ( )
+ th_push fin or clear-iflag ( )
+ false
+;
+
+[ifndef] include-ipv4
+: do-rst ( -- )
+ \ If the RST bit is set examine the state:
+ \ SYN_RECEIVED STATE:
+ \ If passive open, return to LISTEN state.
+ \ If active open, inform user that connection was refused.
+ \ ESTABLISHED, FIN_WAIT_1, FIN_WAIT2, CLOSE_WAIT STATES:
+ \ Inform user that connection was reset, and close tcb.
+ \ CLOSING, LAST_ACK, TIME_WAIT STATES
+ \ Close the tcb.
+
+ ts syn_received = if debug" Connection refused" closed set-state then
+
+ ts established =
+ ts fin_wait_1 = or
+ ts fin_wait_2 = or
+ ts close_wait = or if debug" Connection reset" closed set-state then
+
+ tcp_close
+;
+
+\ Discard from the buffer the transmitted data that was acked
+: release-data ( -- flag )
+ acked wbuf-actual > dup if ( flag )
+ snd_wnd wbuf-actual - to snd_wnd ( flag )
+ wbuf-actual wbuf-drop ( flag )
+ else ( flag )
+ acked wbuf-drop ( flag )
+ snd_wnd acked - to snd_wnd ( flag )
+ then ( flag )
+;
+[then]
+
+: do-ackv6 ( -- done? )
+ ts syn_received = if
+ \ In SYN_RECEIVED state if the ack ACKs our SYN then enter
+ \ ESTABLISHED state and continue processing, otherwise
+ \ send an RST.
+ snd_una iack s> iack snd_max s> or if
+ dropwithresetv6 true exit
+ then
+ established set-state
+ present-data drop
+ iseq 1- to snd_wl1
+ then
+
+ \ In ESTABLISHED and subsequent states: drop duplicate ACKs; ACK out
+ \ of range ACKs. If the ack is in the range
+ \ snd_una < iack <= snd_max
+ \ then advance snd_una to iack and drop
+ \ data from the retransmission queue. If this ACK reflects
+ \ more up to date window information we update our window information.
+
+ iack snd_una s<= if
+ ilen 0= iwin snd_wnd = and if
+ \ If we have outstanding data (other than a window probe),
+ \ this is a completely duplicate ack (i.e., window info didn't
+ \ change), the ack is the biggest we've seen, and we've seen
+ \ exactly our rexmt threshhold of them, assume a packet
+ \ has been dropped and retransmit it. Kludge snd_nxt & the
+ \ congestion window so we send only this one packet.
+ \
+ \ We know we're losing at the current window size so do
+ \ congestion avoidance (set ssthresh to half the current window
+ \ and pull our congestion window back to the new ssthresh).
+ \
+ \ Dup acks mean that packets have left the network (they're now
+ \ cached at the receiver) so bump cwnd by the amount in the receiver
+ \ to keep a constant cwnd packets in the network.
+
+ tcpt_rexmt @ 0= iack snd_una <> or if
+ 0 to t_dupacks
+ else t_dupacks 1+ dup to t_dupacks tcprexmtthresh = if
+ snd_nxt ( onxt )
+ snd_wnd snd_cwnd min 2/ t_maxseg / 2 umax ( onxt win )
+ t_maxseg u* to snd_ssthresh ( onxt )
+ tcpt_rexmt off ( onxt )
+ 0 to t_rtt ( onxt )
+ iack set-snd_nxt ( onxt )
+ t_maxseg set-cwnd ( onxt )
+ tcp_outputv6 ( onxt )
+ t_maxseg t_dupacks * snd_ssthresh + set-cwnd ( onxt )
+ dup snd_nxt s> if set-snd_nxt else drop then ( )
+ true exit
+ else t_dupacks tcprexmtthresh > if
+ snd_cwnd t_maxseg + set-cwnd
+ tcp_outputv6
+ true exit
+ then then then
+ else
+ 0 to t_dupacks
+ then
+
+ false exit
+ then
+
+ \ If the congestion window was inflated to account
+ \ for the other side's cached packets, retract it.
+
+ t_dupacks tcprexmtthresh >=
+ snd_cwnd snd_ssthresh > and if snd_ssthresh set-cwnd then
+ 0 to t_dupacks
+
+ iack snd_max s> if dropafterackv6 true exit then
+
+ iack snd_una - to acked
+
+ \ If transmit timer is running and timed sequence
+ \ number was acked, update smoothed round trip time.
+ \ Since we now have an rtt measurement, cancel the
+ \ timer backoff (cf., Phil Karn's retransmit alg.).
+ \ Recompute the initial retransmit timer.
+
+ t_rtt 0<> iack t_rtseq s> and if t_rtt xmit_timer then
+
+ \ If all outstanding data is acked, stop retransmit
+ \ timer and remember to restart (more output or persist).
+ \ If there is more data to be acked, restart retransmit
+ \ timer, using current (possibly backed-off) value.
+
+ iack snd_max = if
+ tcpt_rexmt off
+ 1 to needoutput
+ else
+ tcpt_persist @ 0= if t_rxtcur tcpt_rexmt ! then
+ then
+
+ \ When new data is acked, open the congestion window. If the window
+ \ gives us less than ssthresh packets in flight, open exponentially
+ \ (maxseg per packet). Otherwise open linearly: maxseg per window
+ \ (maxseg^2 / cwnd per packet), plus a constant fraction of a packet
+ \ (maxseg/8) to help larger windows open quickly enough.
+ t_maxseg
+ snd_cwnd snd_ssthresh u> if dup u* snd_cwnd / then ( cwnd-increment )
+ snd_cwnd + maxwin min set-cwnd
+
+ release-data to ourfinisacked?
+
+ \ wakeup-sender
+
+ ack-una
+
+ ts case
+
+ \ In FIN_WAIT_1 STATE in addition to the processing
+ \ for the ESTABLISHED state if our FIN is now acknowledged
+ \ then enter FIN_WAIT_2.
+
+ fin_wait_1 of
+ ourfinisacked? if
+ \ If we can't receive any more data, then closing user can proceed.
+ \ Starting the timer is contrary to the specification, but if we
+ \ don't get a FIN we'll hang forever.
+
+ cantrcvmore? if
+ \ XXX false to soisconnected
+ maxidle tcpt_2msl !
+ then
+ fin_wait_2 set-state
+ then
+ endof
+
+ \ In CLOSING STATE in addition to the processing for
+ \ the ESTABLISHED state if the ACK acknowledges our FIN
+ \ then enter the TIME-WAIT state, otherwise ignore
+ \ the segment.
+
+ closing of
+ ourfinisacked? if
+ time_wait set-state
+ canceltimers
+ tcptv_msl 2* tcpt_2msl !
+ then
+ endof
+
+ \ In LAST_ACK, we may still be waiting for data to drain
+ \ and/or to be acked, as well as for the ack of our FIN.
+ \ If our FIN is now acknowledged, delete the TCB,
+ \ enter the closed state and return.
+
+ last_ack of
+ ourfinisacked? if tcp_close true exit then
+ endof
+
+ \ In TIME_WAIT state the only thing that should arrive
+ \ is a retransmission of the remote FIN. Acknowledge
+ \ it and restart the finack timer.
+
+ time_wait of
+ tcptv_msl 2* tcpt_2msl !
+ dropafterackv6 true exit
+ endof
+ endcase
+ false
+;
+
+[ifndef] include-ipv4
+: optbyte ( adr len -- adr' len' b ) 1- swap dup c@ swap 1+ -rot ;
+[then]
+
+: dooptionsv6 ( adr len -- )
+ begin dup while ( adr len )
+ optbyte case ( adr' len' option )
+ 0 of 2drop exit endof ( adr len option ) \ EOL
+ 1 of 0 endof ( adr len option ) \ NOP
+ 2 of ( adr len ) \ MAXSEG
+ optbyte 2- ( adr len optlen )
+ iflags syn and if ( adr len optlen )
+ debug? if ." Received " then
+ 2 pick be-w@ tcp_mssv6 drop ( adr len optlen )
+ then ( adr len optlen )
+ endof
+[ifdef] notdef
+ 3 of ( adr len ) \ WINDOW
+ optbyte 2- ( adr len optlen )
+ iflags syn and if ( adr len optlen )
+ rcvd_scale set-flag ( adr len optlen )
+ then ( adr len optlen )
+ endof
+[then]
+ ( default ) >r optbyte 2- r> ( adr len optlen option )
+ endcase ( adr len optlen )
+ /string ( adr' len' )
+ repeat ( adr len )
+ 2drop
+;
+
+: do-listenv6 ( -- )
+ th_dport be-w@ my-tcp-port <> ?exit
+ rst iflag? ?exit
+ ack iflag? if dropwithresetv6 exit then
+ syn iflag? 0= ?exit
+
+ \ XXX we also need to reject broadcast source addresses
+\ m_flags bcast mcast or and ?exit
+ multicast-dstv6? ?exit
+
+ \ It is tempting to call "lock-ip-address", but that doesn't
+ \ work if the DHCP server has specified a router.
+ ipv6-struct ihv6_src set-dest-ipv6 tcpv6-struct
+
+ th_sport be-w@ to his-tcp-port \ Lock onto his source port
+
+ make-templatev6
+
+ optp optlen dooptionsv6
+ next-iss
+ iseq to irs
+ sendseqinit
+ rcvseqinit
+ set-acknow
+ syn_received set-state
+ keep_init tcpt_keep !
+ trimthenstep6v6
+;
+
+[ifndef] include-ipv4
+\ TCP SYN queue methods
+
+list: tcplist
+listnode
+ /n field >tcp-adr
+ /n field >tcp-len
+ 1 field >tcp-deq?
+nodetype: tcpnode
+
+0 tcplist !
+0 tcpnode !
+
+: free-tcpnode ( prev -- )
+ delete-after
+ dup tcpnode free-node
+ dup >tcp-adr @ swap >tcp-len free-mem
+;
+
+: tcp-deq? ( node-adr -- tcp-deq? ) >tcp-deq? c@ ;
+
+: purge-que ( -- )
+ tcplist ['] tcp-deq? find-node if free-tcpnode else drop then
+;
+
+: tcp-any? ( node-adr -- true ) drop true ;
+
+: find-first-node ( -- first-node ) tcplist ['] tcp-any? find-node nip ;
+
+: enque ( adr len -- )
+ dup alloc-mem swap 2dup 2>r move 2r> ( adr' len )
+ tcpnode allocate-node ( adr len node )
+ dup tcplist last-node insert-after ( adr len node )
+ tuck >tcp-len ! ( adr node )
+ tuck >tcp-adr ! ( node )
+ 0 swap >tcp-deq? c! ( )
+;
+
+\ Determines whether a node in the queue matches the packet that
+\ is about to be enqued by comparing their pseudo-IP and TCP headers.
+0 value test-adr
+[then]
+
+: duplicate-synv6? ( node-adr -- flag )
+ dup tcp-deq? if drop false exit then ( node-adr )
+ >tcp-adr @ test-adr /pipv6 /tcphdr + comp 0= ( flag )
+;
+
+\ Enque an incoming SYN packet unless it is a duplicate of one that
+\ is already in the queue.
+: ?enquev6 ( adr len -- )
+ over to test-adr
+ tcplist ['] duplicate-synv6? find-node nip if 2drop else enque then
+;
+
+: dequeue? ( -- 0 | adr len true )
+ purge-que
+ find-first-node dup 0= if exit then \ nothing in queue
+
+ ( node )
+ true over >tcp-deq? c! ( node )
+ dup >tcp-adr @ swap >tcp-len @ true ( adr len true )
+;
+
+: queue-synv6 ( -- )
+ the-struct /pipv6 - ilen-save /pipv6 + ?enquev6
+
+ \ If the current connection has been declared to be abortable,
+ \ kill it upon receipt of a new connection request. This is
+ \ a special hack that is used by the Swing Solutions application,
+ \ which has some HTTP requests that do not complete until an
+ \ external event occurs. The requester can abort the request
+ \ by dropping the TCP connection, but there are some cases where
+ \ the TCP drop does not appear to be propagated to the responder.
+
+ abort-on-reconnect? if tcp_drop then
+;
+
+: inputv6 ( adr len -- )
+ 2dup sumv6-bad? if
+ show" TCHKSUM"
+ debug" Bad TCP checksum" 2drop exit
+ then ( adr len )
+ dup to ilen-save to ilen set-struct ( )
+ 0 to #oob
+
+ pull-options ?exit
+
+ get-info
+
+ debug? if ." RCV " .pkt then
+
+\ findpcb:
+
+ \ Here we should do something to ensure that the source port
+ \ matches this one. Perhaps that is handled by the IP layer.
+
+ \ XXX If we get at TCP packet that doesn't match, we should do a
+ \ dropwithreset and exit ...
+
+ \ When we get a packet from a port other than the one we are currently
+ \ talking to, we either queue it for later (if it contains a SYN),
+ \ or discard it.
+ his-tcp-port th_sport be-w@ <> if
+ \ If we are waiting for an incoming connection, we just fall through
+ \ and handle the new connection request farther down.
+ ts listen <> if
+ \ If a SYN is in the window, then we queue it and handle it
+ \ later, after the current transaction finishes.
+ syn iflag? if queue-synv6 then
+ exit
+ then
+ then
+
+ alive? 0= if dropwithresetv6 exit then
+ ts closed = ?exit
+
+ 0 to t_idle
+ keepidle tcpt_keep !
+
+ ts listen <> if optp optlen dooptionsv6 then
+
+ fast-pathv6? ?exit
+
+ \ At this point, we have handled the most common cases;
+ \ It gets complicated from here on out
+
+ \ Calculate amount of space in receive window,
+ \ and then do TCP input processing.
+ \ Receive window is amount of space in rcv queue,
+ \ but not less than advertised window.
+ rcv_adv rcv_nxt - rbuf-space max to rcv_wnd
+
+ ts listen = if do-listenv6 exit then
+
+ do-syn-sentv6? ?exit
+ ?drop-some
+
+ \ If data is received after closing, RST the other end
+ ts close_wait > ilen 0<> and if tcp_close dropwithresetv6 exit then
+
+ seg-after-winv6? ?exit
+
+ rst iflag? if do-rst exit then
+
+ \ If a SYN is in the window, then it is queued until the current
+ \ transaction finishes cleanly.
+ syn iflag? if queue-synv6 then
+
+ \ If the ACK bit is off we drop the segment and return.
+ ack iflag? 0= ?exit
+
+ \ ACK processing
+ do-ackv6 ?exit
+ step6v6
+;
+
+: ?receivev6 ( -- )
+ \ If the state is listen, check the queue
+ ts listen = if
+ dequeue? if ( adr len ) /pipv6 - swap /pipv6 + swap input exit then
+ then
+ \ Check for a new packet
+ 6 " receive-ip-packet" $call-parent 0= if inputv6 then
+;
+
+[ifndef] include-ipv4
+\ We accomplish the creation of a TCP control block by instantiating
+\ this package
+: newtcpcb ( -- ) ;
+
+\ d# 32 is the maximum TCP options size
+/tcphdr d# 32 + mssmax + constant /xmit-max
+
+: alloc-buffers ( -- )
+ wbuf-allocate
+ d# 1024 d# 16 * to rbuf-len
+ rbuf-len alloc-mem to rbuf-adr
+ 0 to rbuf-actual
+;
+: free-buffers ( -- )
+ wbuf-start /wbuf free-mem
+ rbuf-adr rbuf-len free-mem
+;
+[then]
+
+\ This is basically attach
+: alloc-buffersv6 ( -- )
+ /xmit-max " allocate-ipv6" $call-parent to xmit_bufv6
+;
+
+: free-buffersv6 ( -- )
+ free-buffers
+ xmit_bufv6 /xmit-max " free-ipv6" $call-parent
+;
+
+[ifndef] include-ipv4
+\ User issued close, and wish to trail through shutdown states:
+\ if never received SYN, just forget it. If got a SYN from peer,
+\ but haven't sent FIN, then go to FIN_WAIT_1 state to send peer a FIN.
+\ If already got a FIN from peer, then almost done; go to LAST_ACK
+\ state. In all other cases, have already sent FIN to peer (e.g.
+\ after PRU_SHUTDOWN), and just have to play tedious game waiting
+\ for peer to send FIN or not respond to keep-alives, etc.
+\ We can let the user exit from the close as soon as the FIN is acked.
+: usrclosed ( -- )
+ ts case \ action next-state
+ closed of tcp_close endof
+ listen of tcp_close endof
+ syn_sent of tcp_close endof
+ syn_received of fin_wait_1 set-state endof
+ established of fin_wait_1 set-state endof
+ close_wait of last_ack set-state endof
+ ( default ) \ Do nothing
+ endcase
+
+
+ alive? ts fin_wait_2 >= and if
+ \ soisdisconnected
+
+ \ If we are in FIN_WAIT_2, we arrived here because the
+ \ application did a shutdown of the send side. Like the
+ \ case of a transition from FIN_WAIT_1 to FIN_WAIT_2 after
+ \ a full close, we start a timer to make sure sockets are
+ \ not left in FIN_WAIT_2 forever.
+ ts fin_wait_2 = if maxidle tcpt_2msl ! then
+ then
+;
+
+\ When a source quench is received, close congestion window
+\ to one segment. We will gradually open it again as we proceed.
+\ XXX we probably have no way to invoke this.
+\ : quench ( -- ) alive? if t_maxseg set-cwnd then ;
+
+\ Fast timeout routine for processing delayed acks
+false instance value do-delack?
+[then]
+
+: do-delackv6 ( -- )
+ do-delack? if
+ t_flags delack invert and acknow or to t_flags
+ tcp_outputv6
+ false to do-delack?
+ then
+;
+
+[ifndef] include-ipv4
+: delack-tick ( -- ) t_flags delack and 0<> to do-delack? ; \ alarm handler
+
+\ 2 MSL timeout in shutdown went off. If we're closed but
+\ still waiting for peer to close and connection has been idle
+\ too long, or if 2MSL time is up from TIME_WAIT, delete connection
+\ control block. Otherwise, check again in a bit.
+: do-2msl ( -- )
+ debug? if ." 2msl" cr then
+ ts time_wait <> t_idle maxidle <= and if
+ keepintvl tcpt_2msl !
+ else
+ tcp_close
+ then
+;
+[then]
+
+\ Retransmission timer went off. Message has not
+\ been acked within retransmit interval. Back off
+\ to a longer retransmit interval and retransmit one segment.
+: do-rexmtv6 ( -- )
+ debug? if ." Retransmit" cr then
+ t_rxtshift 1+ dup to t_rxtshift maxrxtshift > if
+ maxrxtshift to t_rxtshift
+ tcp_drop
+ exit
+ then
+ rexmtval backoff t_rxtshift na+ @ * t_rttmin set-rxtcur
+ t_rxtcur tcpt_rexmt !
+
+[ifdef] notdef \ We have no way to try for a better route
+
+ \ If losing, let the lower level know and try for
+ \ a better route. Also, if we backed off this far,
+ \ our srtt estimate is probably bogus. Clobber it
+ \ so we'll take the next rtt measurement as our srtt;
+ \ move the current srtt into rttvar to keep the current
+ \ retransmit times until then.
+
+ if (t_rxtshift > TCP_MAXRXTSHIFT / 4) {
+ in_losing(t_inpcb);
+ t_rttvar += (t_srtt >> TCP_RTT_SHIFT);
+ t_srtt = 0;
+ }
+[then]
+ snd_una set-snd_nxt
+
+ \ If timing a segment in this window, stop the timer.
+ 0 to t_rtt
+
+ \ Close the congestion window down to one segment
+ \ (we'll open it by one segment for each ack we get).
+ \ Since we probably have a window's worth of unacked
+ \ data accumulated, this "slow start" keeps us from
+ \ dumping all that data as back-to-back packets (which
+ \ might overwhelm an intermediate gateway).
+ \
+ \ There are two phases to the opening: Initially we
+ \ open by one mss on each ack. This makes the window
+ \ size increase exponentially with time. If the
+ \ window is larger than the path can handle, this
+ \ exponential growth results in dropped packet(s)
+ \ almost immediately. To get more time between
+ \ drops but still "push" the network to take advantage
+ \ of improving conditions, we switch from exponential
+ \ to linear window opening at some threshhold size.
+ \ For a threshhold, we use half the current window
+ \ size, truncated to a multiple of the mss.
+ \
+ \ (the minimum cwnd that will give us exponential
+ \ growth is 2 mss. We don't allow the threshhold
+ \ to go below this.)
+
+ snd_wnd snd_cwnd min 2/ t_maxseg / 2 max ( win )
+ t_maxseg set-cwnd ( win )
+ t_maxseg * to snd_ssthresh ( )
+ 0 to t_dupacks
+
+ tcp_outputv6
+;
+
+\ Persistance timer into zero window.
+\ Force a byte to be output, if possible.
+: do-persistv6 ( -- )
+ debug? if ." Persist" cr then
+ setpersist
+ true to t_force
+ tcp_outputv6
+ false to t_force
+;
+
+[ifndef] include-ipv4
+0 instance value keepalive? \ A configuration flag we can set
+[then]
+
+\ Keep-alive timer went off; send something
+\ or drop connection if idle for too long.
+: do-keepv6 ( -- )
+ debug? if ." Keep" cr then
+ ts established < if tcp_drop exit then
+ keepalive? ts close_wait <= and if
+ t_idle keepidle maxidle + >= if tcp_drop exit then
+
+ \ Send a packet designed to force a response if the peer is up
+ \ and reachable: either an ACK if the connection is still alive,
+ \ or an RST if the peer has closed the connection due to timeout or
+ \ reboot. Using sequence number snd_una-1 causes the transmitted
+ \ zero-length segment to lie outside the receive window; by the
+ \ protocol spec, this requires the correspondent TCP to respond.
+
+ tv6_template to the-struct rcv_nxt snd_una 1- ack respondv6
+ keepintvl tcpt_keep !
+ else
+ keepidle tcpt_keep !
+ then
+;
+
+[ifndef] include-ipv4
+: countdown? ( adr -- expired? )
+ dup @ if ( adr )
+ dup @ 1- ( adr count' )
+ tuck swap ! 0=
+ else
+ drop false
+ then
+;
+
+\ Tcp protocol timeout routine called every 500 ms.
+\ Updates the timers, causing finite state machine actions when they expire.
+
+0 instance value protocol-timer?
+[then]
+
+: do-protocolv6 ( -- )
+ protocol-timer? 0= ?exit
+ false to protocol-timer?
+
+ 8 d# 75 * pr_slowhz * to maxidle \ 8 probes at 75-second intervals
+
+ tcpt_rexmt countdown? if do-rexmtv6 then
+ tcpt_persist countdown? if do-persistv6 then
+ tcpt_keep countdown? if do-keepv6 then
+ tcpt_2msl countdown? if do-2msl then
+
+ t_idle 1+ to t_idle
+ t_rtt if t_rtt 1+ to t_rtt then
+;
+
+[ifndef] include-ipv4
+: protocol-tick ( -- )
+ alive? to protocol-timer?
+
+ \ XXX If we have multiple simultaneous TCPs, we only want to
+ \ do this in one of them. How?
+ tcp_iss issincr pr_slowhz / + to tcp_iss
+;
+[then]
+
+\ Initiate connection to peer.
+\ Create a template for use in transmissions on this connection.
+\ Enter SYN_SENT state, and mark socket as connecting.
+\ Start keep-alive timer, and seed output sequence space.
+\ Send initial segment on connection.
+
+: start-connectv6 ( port# -- )
+ to his-tcp-port
+ \ XXX how do we get our local port number???
+
+ make-templatev6
+ syn_sent set-state
+ keep_init tcpt_keep !
+ next-iss
+ sendseqinit
+ tcp_outputv6
+;
+
+[ifndef] include-ipv4
+\ After a receive, possibly send window update to peer.
+\ XXX - we need to call output after taking the receive data
+\ See: case PRU_RCVD
+
+: tcp-abort ( -- ) tcp_drop ;
+
+\ Get the out-of-band data without consuming it
+: peek-oob ( adr len -- actual )
+ \ XXX check this; there may be some data waiting during a later state
+ ts established <> if 2drop -1 exit then
+
+ t_oobflags havedata and 0= if 2drop -2 exit then
+ 0= if drop 0 exit then
+ t_iobc swap c! 1
+;
+
+\ Get the out-of-band data
+: read-oob ( adr len -- actual )
+ peek-oob ( actual )
+ dup 0> if
+ t_oobflags havedata haddata or xor to t_oobflags
+ then
+;
+[then]
+
+: pollv6 ( -- )
+ do-delackv6 do-protocolv6
+ ?receivev6
+;
+
+[ifndef] include-ipv4
+: wbuf-set ( adr len -- ) over to wbuf-adr + to wbuf-top ;
+: wbuf-add ( adr len -- #added )
+ wbuf-avail min ( adr #added )
+ dup if ( adr #added )
+ tuck wbuf-top swap move ( #added )
+ dup wbuf-top + to wbuf-top ( #added )
+ else ( adr 0 )
+ nip ( 0 )
+ then ( #added )
+;
+: read ( adr len -- actual ) 2drop 0 ;
+: write ( adr len -- actual ) 2drop 0 ;
+: write-oob ( adr len -- actual ) 2drop 0 ;
+: connect ( port# -- okay? ) drop false ;
+[then]
+
+: writev6 ( adr len -- actual )
+ tuck begin ( len adr remaining )
+ alive? 0= if 3drop -1 exit then
+ 2dup wbuf-add /string ( len adr' remaining' )
+ dup while ( len adr' remaining' )
+ tcp_outputv6 pollv6 ( len adr' remaining' )
+ repeat ( len adr 0 )
+ 2drop ( len )
+;
+
+: write ( adr len -- actual )
+ use-ipv6? if writev6 else write then
+;
+
+\ Do a send by putting data in output queue and updating urgent
+\ marker if URG set. Possibly send more data.
+: write-oobv6 ( adr len -- actual )
+ \ According to RFC961 (Assigned Protocols), the urgent pointer points
+ \ to the last octet of urgent data. BSD makes it point to the
+ \ the first octet of data past the urgent section. We follow the RFC.
+ dup 0= if nip exit then
+ dup snd_una + 1- to snd_up ( adr len )
+ true to t_force ( adr len )
+ writev6 ( len|-1 )
+ false to t_force ( len|-1 )
+;
+: write-oob ( adr len -- actual )
+ use-ipv6? if write-oobv6 else write-oob then
+;
+
+: connectv6 ( port# -- okay? )
+ true to alive?
+ start-connectv6
+ begin pollv6 ts established < while
+ debug? if key? if key drop interact then then
+ alive? 0= if false exit then
+ repeat
+ true
+;
+: connect ( port# -- okay? )
+ " use-ipv6?" $call-parent dup to use-ipv6?
+ if connectv6 else connect then
+;
+
+\ Other things we may need to do:
+\ in_setsockaddr
+\ in_setpeeraddr
+
+: readv6 ( adr len -- actual )
+ pollv6 ( adr len )
+
+ rbuf-actual if ( adr len )
+ copy-from-rbuf tcp_outputv6 exit ( actual )
+ then ( adr len )
+
+ 2drop
+ ts established <> if -1 else -2 tcp_outputv6 then
+;
+: read ( adr len -- actual )
+ use-ipv6? if readv6 else read then
+;
+
+[ifndef] include-ipv4
+: init-variables ( -- )
+ 0 tcpq !
+ listen set-state
+ 0 to t_flags
+ d# 512 to t_maxseg
+ canceltimers
+ 0 to t_dupacks
+ 0 to t_force
+ 0 to rcv_wnd
+ 0 to rcv_nxt
+ 0 to rcv_up
+ 0 to irs
+
+ 0 to snd_una
+ 0 to snd_nxt
+ 0 to snd_up
+ 0 to snd_wl1
+ 0 to snd_wl2
+ 0 to snd_wnd
+ 0 to iss
+
+ 0 to rcv_adv
+ 0 to snd_max
+ maxwin to snd_cwnd
+ maxwin to snd_ssthresh
+
+ 0 to t_idle
+ 0 to t_rtt
+ 0 to t_rtseq
+ 0 to t_srtt
+ 3 pr_slowhz * 2 2+ 1- lshift to t_rttvar
+ pr_slowhz to t_rttmin
+ 0 to max_sndwnd
+
+ 0 to t_oobflags
+ 0 to t_iobc
+
+ 0 to t_rxtshift
+ rexmtval pr_slowhz set-rxtcur
+
+ false to do-delack?
+ false to keepalive?
+ false to protocol-timer?
+;
+: accept ( port# -- connected? ) drop false ;
+[then]
+
+: acceptv6 ( port# -- connected? )
+ to my-tcp-port
+ ts closed = if
+ init-variables
+ \ Tell the IP stack to accept packets from anybody
+ " unlock-ipv6-address" $call-parent
+ then
+ true to alive?
+ pollv6
+ \ XXX if state is now "closed", we need to return an error code
+ ts established =
+;
+: accept ( port# -- connected? )
+ use-ipv6? if acceptv6 else accept then
+;
+
+\ XXX new args: ipv4, ipv6
+[ifndef] include-ipv4
+: parse-args ( -- )
+ my-args
+ begin dup while ( rem$ )
+ ascii , left-parse-string ( rem$' head$ )
+ 2dup " debug" $= if true to debug? else ( rem$' head$ )
+ 2dup $set-host then ( rem$' head$ )
+ 2drop
+ repeat
+ 2drop
+;
+[then]
+
+: open ( -- )
+ alloc-buffersv6
+[ifdef] open
+ open
+[else]
+ parse-args
+ alloc-buffers
+
+ first-time? if
+ false to first-time?
+ " next-xid" $call-parent to tcp_iss
+ then
+
+ 0 " set-timeout" $call-parent
+
+ ['] delack-tick d# 200 alarm
+
+ ['] protocol-tick d# 500 alarm
+
+ h# 555 to my-tcp-port \ XXX
+ true to alive?
+
+ true
+[then]
+;
+
+[ifndef] include-ipv4
+d# 5000 constant close-wait-ms
+: drain ( -- ) ;
+: flush-writes ( -- ) ;
+[then]
+
+: drainv6 ( -- )
+ get-msecs close-wait-ms + ( msecs )
+ begin ts time_wait < alive? and while ( msecs )
+ pollv6 ( msecs )
+ get-msecs over - 0>= if drop exit then
+ repeat ( msecs )
+ drop
+;
+
+: flush-writesv6 ( -- )
+ \ If the connection is already down, just blow away any pending data
+ ts closed = if wbuf-clear exit then
+
+ get-msecs
+ begin
+ wbuf-actual 0<> ( start-time flag )
+ get-msecs 2 pick - d# 10000 < ( start-time flag flag )
+ and ( start-time flag' )
+ while ( start-time )
+ tcp_outputv6 pollv6 ( start-time )
+ repeat ( start-time )
+ drop ( )
+
+ wbuf-actual 0<> if
+ show" TDROP"
+ debug" TCP Timeout!"
+ wbuf-clear
+ then
+;
+
+\ Close the current TCP connection and wait for the state machine
+\ to make its way through the sequence of termination states.
+: disconnectv6 ( -- )
+ usrclosed
+ flush-writes
+ flush-writesv6
+ alive? if tcp_outputv6 then
+ drain
+ drainv6
+ alive? if tcp_close then
+;
+
+[ifndef] include-ipv4
+\ external
+: set-nodelay ( -- ) nodelay set-flag ;
+: abort-on-reconnect ( -- ) true to abort-on-reconnect? ;
+[then]
+
+: close ( -- )
+ disconnectv6
+[ifdef] close
+ close
+[else]
+ ['] delack-tick 0 alarm
+ ['] protocol-tick 0 alarm
+[then]
+ free-buffersv6
+;
+
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Added: ofw/inetv6/telnet.fth
===================================================================
--- ofw/inetv6/telnet.fth (rev 0)
+++ ofw/inetv6/telnet.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,140 @@
+\ See license at end of file
+purpose: Telnet client
+
+decimal
+
+\ i/o
+
+0 value telnet-done?
+variable tcp-in
+: tcp-getc ( -- c )
+ tcp-in 1 tcp-read dup 0< if ( err )
+ dup -1 = if true to telnet-done? then ( err )
+ exit
+ then
+ drop tcp-in c@
+;
+
+\ escapes
+
+240 constant #se \ End of subnegotiation parameters
+\ 241 constant #nop \ No operation
+\ 242 constant #synch \ The data stream portion of a Synch
+\ 243 constant #brk \ NVT break character
+\ 244 constant #ip \ Interrupt Process
+\ 245 constant #ao \ Abort output
+\ 246 constant #ayt \ Are You There
+\ 247 constant #ec \ Erase character
+\ 248 constant #el \ Erase Line
+\ 249 constant #ga \ Go ahead
+250 constant #sb \ Suboption negotiation
+251 constant #will
+252 constant #wont
+253 constant #do
+254 constant #dont
+255 constant #iac \ interpret as command
+
+24 constant #term-type
+0 constant #is
+1 constant #send
+
+: send-is ( string option -- )
+ " "(ff fa)" tcp-type tcp-emit 0 tcp-emit tcp-type " "(ff f0)" tcp-type
+;
+
+: tel-sub ( -- )
+ tcp-getc case
+ #term-type of
+ tcp-getc #send = if " vt100" #term-type send-is then
+ endof
+ endcase
+;
+
+: send-option ( option request -- ) #iac tcp-emit tcp-emit tcp-emit ;
+: i-will ( option -- ) #will send-option ;
+: i-wont ( option -- ) #wont send-option ;
+: i-do ( option -- ) #do send-option ;
+: i-dont ( option -- ) #dont send-option ;
+
+: he-will ( option -- ) i-do ; \ offer
+: he-wont ( option -- ) i-dont ; \ offer
+: he-does ( option -- ) \ request
+ dup case
+ #term-type of i-will endof
+ ( default ) i-wont
+ endcase
+;
+: he-dont ( option -- ) i-wont ; \ request
+
+: telnet-command ( command -- )
+ case
+ #se of endof
+\ #nop of endof
+\ #synch of endof
+\ #brk of endof
+\ #ip of endof
+\ #ao of endof
+\ #ayt of endof
+\ #ec of endof
+\ #el of endof
+\ #ga of endof
+ #sb of tel-sub endof
+ #will of tcp-getc he-will endof
+ #wont of tcp-getc he-wont endof
+ #do of tcp-getc he-does endof
+ #dont of tcp-getc he-dont endof
+ endcase
+;
+: telnet1 ( c -- )
+ dup #iac <> if emit exit then drop
+
+ tcp-getc dup #se < if emit exit then ( c )
+
+ telnet-command
+;
+: telnet-out ( -- )
+ d# 80 0 do
+ tcp-getc dup 0< if ( c )
+ drop leave
+ else ( c )
+ telnet1
+ then
+ loop
+;
+: (telnet) ( -- )
+ false to telnet-done?
+ begin telnet-done? 0= while
+ key? if
+ key dup control ] = if drop exit then
+ tcp-emit
+ then
+ telnet-out
+ repeat
+;
+: $telnet ( hostname$ -- ) d# 23 open-tcp-connection (telnet) close-tcp ;
+: telnet ( "hostname" -- ) safe-parse-word $telnet ;
+
+hex
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Added: ofw/inetv6/telnetd.fth
===================================================================
--- ofw/inetv6/telnetd.fth (rev 0)
+++ ofw/inetv6/telnetd.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,245 @@
+\ See license at end of file
+purpose: Telnet server - allows external systems to telnet to the firmware
+
+\ To use this feature, execute "telnetd" on the firmware system, then
+\ use telnet on the remote host to connect to the firmware system.
+\ When done, execute "exit-telnet" or just close the connection.
+
+support-package: telnet
+false value debug-options?
+
+: (read) ( adr len -- actual ) " read" $call-parent ;
+: (write) ( adr len -- actual ) " write" $call-parent ;
+
+\ Discard the first byte in the array by copying the rest down
+: swallow ( rem$ -- rem$' )
+ 1- 2dup over 1+ -rot move
+;
+1 instance buffer: the-byte
+: getbyte ( -- byte )
+ begin
+ the-byte 1 (read) case
+ 1 of the-byte c@ exit endof
+ -1 of abort endof
+ endcase
+ again
+;
+: putbyte ( byte -- ) the-byte c! the-byte 1 (write) drop ;
+: next-cmd-byte ( rem$ -- rem$' char )
+ \ If there is more data in the buffer, return the next byte
+ dup if over c@ >r swallow r> exit then ( rem$ )
+
+ \ Otherwise, get a character from the TCP connection
+ getbyte ( rem$ char )
+;
+
+: show-option ( option command$ dir$ -- option )
+ debug-options? if
+ [ifndef] install-uart-io " install-uart-io" evaluate [then]
+ type space type space dup .d cr
+ console-io
+ else
+ 2drop 2drop
+ then
+;
+: .got ( option command$ -- ) " RCVD" show-option ;
+: .sent ( option command$ -- ) " SENT" show-option ;
+
+
+: send-option ( option request -- ) #iac putbyte putbyte putbyte ;
+: send-will ( option -- ) " WILL" .sent d# 251 send-option ;
+: send-wont ( option -- ) " WONT" .sent d# 252 send-option ;
+: send-do ( option -- ) " DO" .sent d# 253 send-option ;
+: send-dont ( option -- ) " DONT" .sent d# 254 send-option ;
+
+: will ( rem$ -- rem$' )
+ next-cmd-byte " WILL" .got
+ dup case
+ 0 of send-do endof
+
+\ Since we have already sent "do suppressGA", there is no need to re-ack it
+\ 3 of send-do endof \ Suppress go-ahead
+ 3 of drop endof \ Suppress go-ahead
+
+ ( default ) swap send-dont
+ endcase
+;
+
+: wont ( rem$ -- rem$' )
+ next-cmd-byte " WONT " .got
+ drop
+;
+
+: tdo ( rem$ -- rem$' )
+ next-cmd-byte " DO" .got
+ dup case
+ 0 of send-will endof \ Binary transmission
+
+\ Since we have already sent "will echo", there is no need to re-ack it
+\ 1 of send-will endof \ Echo
+ 1 of drop endof
+
+ 3 of send-will endof \ Suppress go-ahead
+ ( default ) swap send-wont
+ endcase
+;
+
+: dont ( rem$ -- rem$' )
+ next-cmd-byte " DONT" .got
+ drop
+;
+
+: subnegotiate ( rem$ -- rem$' )
+ next-cmd-byte " SUBNEGOTIATE" .got
+ \ XXX we should eat everything up to the SE marker;
+ \ on the other hand, we should never get here, because
+ \ we don't express willingness to subnegotiate anything.
+ drop
+;
+
+: reinsert ( rem$ char -- rem$' )
+ >r
+ 2dup over 1+ swap move ( rem$ r: char )
+ r> 2 pick c! 1+ ( rem$' )
+;
+: do-command ( rem$ -- rem$' )
+ swallow \ Discard the IAC itself
+ next-cmd-byte ( rem$ char )
+ case
+\ d# 240 of endof \ end subnegotiation
+\ d# 241 of endof \ nop
+\ d# 242 of endof \ data mark (end urgent)
+ d# 243 of user-abort endof \ break
+ d# 244 of user-abort endof \ interrupt process
+\ d# 245 of endof \ abort-output
+\ d# 246 of endof \ are-you-there?
+ d# 247 of control h reinsert endof \ erase character
+ d# 248 of control u reinsert endof \ erase line
+ d# 249 of endof \ go-ahead
+ d# 250 of subnegotiate endof
+ d# 251 of will endof
+ d# 252 of wont endof
+ d# 253 of tdo endof
+ d# 254 of dont endof
+ #iac of #iac reinsert endof
+ endcase
+;
+
+: process-escapes ( adr len -- len' )
+ over swap ( adr rem$ )
+ begin dup while ( adr rem$ )
+ over c@ #iac = if ( adr rem$ )
+ do-command ( adr rem$' )
+ else ( adr rem$ )
+ 1 /string ( adr rem$' )
+ then ( adr rem$ )
+ repeat ( adr end-adr 0 )
+ drop swap - ( len' )
+;
+: read ( adr len -- actual )
+ over swap (read) ( adr actual )
+ dup 0< if nip exit then ( adr actual )
+ process-escapes ( actual' )
+;
+: write ( adr len -- actual )
+ tuck begin ( len adr len )
+ #iac split-string ( len head$ tail$ )
+ dup while ( len head$ tail$ )
+ 2swap (write) drop ( len tail$ )
+ #iac putbyte ( len tail$ ) \ Send an escape
+ over 1 (write) ( len tail$ ) \ Send the ff in the string
+ 1 /string ( len tail$' ) \ Remove it from the string
+ repeat ( len head$ null$ )
+ 2drop (write) drop ( len )
+;
+
+0 instance value verbose?
+
+: open ( -- flag )
+ my-args " verbose" $= to verbose?
+
+ verbose? if
+ ." telnet://" " my-ip-addr" $call-parent .ipaddr cr
+ then
+
+ begin d# 23 " accept" $call-parent until
+
+ verbose? if ." Connected" cr then
+
+ 3 send-do \ You suppress go-ahead
+ 0 send-do \ Be binary
+ 1 send-will \ I will echo
+
+ get-msecs ( time )
+ begin
+ get-msecs over d# 300 + - 0<
+ while
+ the-byte 1 (read) case ( msecs [byte] )
+ 1 of drop get-msecs the-byte 1 process-escapes drop endof
+ -1 of drop false exit endof
+ endcase
+ repeat
+ drop
+
+ true
+;
+: close ( -- ) ;
+end-support-package
+
+
+0 value old-in
+0 value old-out
+0 value telnet-ih
+
+defer getchar-hook ' = to getchar-hook
+patch getchar-hook = stdin-getchar
+
+: exit-telnet ( -- )
+ telnet-ih close-dev
+ old-out stdout !
+ old-in stdin !
+ ['] = to getchar-hook
+;
+
+: ?telnet-closed ( read-return 1 -- flag )
+ over -1 = if ( -1 1 )
+ exit-telnet ( -1 1 )
+ carret pending-char c! ( 1 1 )
+ ." Connection closed" \ cr
+ 2drop true exit
+ then ( read-return 1 )
+ =
+;
+
+devalias telnetd tcp//telnet:verbose
+
+: telnetd ( -- )
+ " telnetd" open-dev dup 0= abort" Can't open telnet" ( ih )
+ to telnet-ih
+ stdin @ to old-in stdout @ to old-out
+ telnet-ih dup stdin ! stdout !
+ ['] ?telnet-closed to getchar-hook
+;
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Added: ofw/inetv6/tftp.fth
===================================================================
--- ofw/inetv6/tftp.fth (rev 0)
+++ ofw/inetv6/tftp.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,354 @@
+\ See license at end of file
+purpose: Trivial File Transfer Protocol (TFTP) implementation
+
+\ Trivial File Transfer Protocol
+
+decimal
+
+headerless
+
+1 constant rrq-pkt
+2 constant wrq-pkt
+3 constant data-pkt
+4 constant ack-pkt
+5 constant err-pkt
+
+
+struct ( tftp packet )
+ 2 sfield opcode
+ 0 sfield block#
+ 0 sfield filename
+ 2 sfield errorcode
+ 0 sfield errmsg
+ 512 sfield data
+constant /tftp-packet
+
+instance variable sid
+instance variable did
+instance variable this-block
+instance variable #retries
+false instance value first-try?
+
+0 instance value tftp-packet \ Buffer address
+instance variable #packet
+
+[ifndef] include-ipv6
+0 value server-ipv6-addr
+: .ipv6 ( adr -- ) drop ;
+[then]
+[ifndef] include-ipv4
+0 value server-ip-addr
+: .ipaddr ( adr -- ) drop ;
+[then]
+
+
+: too-many-tries? ( -- flag ) \ flag true if too many retries
+ bootnet-debug if
+ #retries @ 3 and 3 = if ." #retries = " #retries @ .d cr then
+ then
+ #retries @ tftp-retries u>=
+;
+
+\ Unlock from the server so we can capture another one
+: .merror ( tftp-adr,len -- tftp-adr,len )
+ \ Unfortunately, we cannot give good error information in the usual
+ \ case where use-server? is false (meaning that we aren't sure which
+ \ server to use). If use-server? is false and the first server we try
+ \ (i.e. the one that responded to the RARP or BOOTP request) doesn't
+ \ have the file, we then try to broadcast the request. We mustn't
+ \ display the error message from the first server because that would
+ \ cause spurious complaints in the case where the subsequent broadcast
+ \ TFTP operation will succeed. However, if the subsequent broadcast
+ \ TFTP attempt fails, we won't get an error response because TFTP
+ \ servers typically return error responses only for unicast requests.
+ use-server? bootnet-debug or if ( tftp-adr,len )
+ collect(
+ ." TFTP error: " errmsg cscount ( tftp-adr,len msg-adr,len )
+ \ Some TFTP implementations neglect to null-terminate the message.
+ 2 pick 4 - min type cr
+ [ifdef] .dhcp-server .dhcp-server [then]
+ ." TFTP Server: "
+ use-ipv6? if
+ server-ipv6-addr .ipv6 cr
+ else
+ server-ip-addr .ipaddr cr
+ then
+ ." Filename: " tftp-packet set-struct filename cscount type cr
+ )collect
+ use-server? if $abort else type then
+ then
+ d# 69 did !
+;
+
+: $cstrput ( from-adr,len to-adr -- end-adr )
+ over >r place-cstr r> + 1+
+;
+
+: setup-request ( filename$ rrq-pkt/wrq-pkt -- )
+ 0 this-block !
+ tftp-packet set-struct
+ 1 sid +!
+ d# 69 did ! ( filename$ rrq-pkt/wrq-pkt )
+ opcode xw! ( filename$ )
+ filename $cstrput ( mode-adr )
+ " octet" rot $cstrput ( end-adr )
+ tftp-packet - #packet !
+;
+
+: setup-read-request ( filename$ -- )
+ rrq-pkt setup-request
+ 1 this-block +!
+;
+
+: setup-write-request ( filename$ -- )
+ wrq-pkt setup-request
+;
+
+: setup-ack-packet ( -- )
+ tftp-packet set-struct
+ ack-pkt opcode xw!
+ this-block @ block# xw!
+ 4 #packet !
+ 1 this-block +!
+;
+
+: send-packet ( tftp-adr tftp-len -- )
+ ( tftp-adr tftp-len ) sid @ did @ send-udp-packet
+;
+
+0 instance value error-packet \ Buffer address
+
+: send-error-packet ( src-port -- )
+ /tftp-packet allocate-udp is error-packet
+ did @ >r
+ ( src-port ) did ! \ set the udp-source-port to the port indicated
+ \ in the received error packet.
+ error-packet set-struct
+ err-pkt opcode xw!
+ 5 ( Unknown transfer ID ) errorcode xw!
+ " Unknown source address" errmsg $cstrput ( end-address )
+ error-packet tuck - ( packet-adr len )
+ send-packet
+ r> did ! \ restore the previous did
+ error-packet /tftp-packet free-udp
+;
+
+\ Check source port against destination id.
+\ If it mismatches, error unless did is currently 69
+: bad-src-port? ( src-port -- error ) \ assumes the-struct is UDP packet
+ dup did @ <> if ( src-port )
+ did @ d# 69 = if \ Lock on to his port ( src-port )
+ did ! ( )
+ bootnet-debug if ." Locking onto TFTP server" cr then
+ lock-udp-address \ Lock onto his addresses ( )
+ else ( src-port )
+ send-error-packet ( )
+ true exit ( true )
+ then ( )
+ else ( src-port )
+ drop ( )
+ then ( )
+ false
+;
+
+\ Check block number. Assumes the-struct is TFTP packet.
+: bad-block#? ( -- error? ) block# xw@ this-block @ <> ;
+
+: send-current-packet ( -- ) tftp-packet #packet @ send-packet ;
+
+defer handle-tftp
+headers
+: (handle-tftp) ( tftp-adr len -- )
+ bootnet-debug if
+ ." Bad TFTP source port; sending TFTP error packet" cr
+ then
+ 2drop
+;
+' (handle-tftp) is handle-tftp
+headerless
+
+: receive-tftp-packet ( -- true | tftp-packet-adr tftp-len false )
+ begin
+ sid @ receive-udp-packet if true exit then ( tftp-adr,len src-port )
+ 2 pick set-struct ( tftp-adr,len src-port )
+ bad-src-port? ( tftp-adr,len flag )
+ while ( tftp-adr,len )
+ \ Shut down lingering TFTP server processes from our old attempts
+ handle-tftp ( )
+ repeat ( tftp-adr,len )
+ false
+;
+
+: receive-data-packet ( -- true | data-adr data-len false )
+ update-timeout
+
+ \ We don't retry at this level because all possible errors here
+ \ cause a resend of the request packet.
+
+ receive-tftp-packet if true exit then ( tftp-adr tftp-len )
+
+ \ Check packet type
+ opcode xw@ err-pkt = if .merror 2drop true exit then
+ opcode xw@ data-pkt <> if ." Got a non-data packet" 2drop true exit then
+ bad-block#? if 2drop true exit then ( tftp-adr tftp-len )
+
+ false is first-try? ( tftp-adr tftp-len )
+ 4 /string false ( data-adr,len false )
+ compute-srtt ( data-adr,len false )
+;
+
+: ?try-broadcast ( -- )
+ first-try? if
+ bootnet-debug if
+ ." Trying a different TFTP server by broadcasting" cr
+ then
+ clear-his-address
+ \ Relock the destination port number
+ d# 69 did !
+ \ Give the server time to come back up. Delay
+ \ re-broadcasting to avoid network congestion.
+ #retries @ if 5000 ms then
+ else
+ bootnet-debug if ." TFTP timeout - retrying" cr then
+ then
+;
+
+: .receive-failed ( -- ) ." Receive failed" cr ;
+
+: get-data-packet ( adr -- adr' more? )
+ #retries off
+ begin
+ opcode xw@ err-pkt <> if \ if this is an error packet, do not resend
+ \ it. The error packet had been sent out
+ \ in receive-tftp-packet already.
+ send-current-packet ( adr )
+ then
+ receive-data-packet ( adr [ data-adr data-len ] flag )
+ while ( adr )
+ ?try-broadcast ( adr )
+ 1 #retries +!
+ too-many-tries? if .receive-failed false exit then
+ repeat ( adr data-adr data-len )
+
+ \ Copy data from packet to our buffer at addr
+ >r over r@ move ( adr )
+
+ r@ + ( adr' )
+ r> d# 512 = ( adr' more? )
+;
+
+: tftp-init ( -- )
+ true is first-try?
+ /tftp-packet allocate-udp is tftp-packet
+
+ \ Use user port numbers to avoid reserved system ports
+ get-msecs h# 0ffff and d# 2048 or sid ! \ "random" number
+;
+: tftp-close ( -- ) tftp-packet /tftp-packet free-udp ;
+
+headers
+: tftpread ( adr filename$ -- size )
+ bootnet-debug if ." TFTP protocol: Reading file: " 2dup type cr then
+ tftp-init ( adr filename$ )
+ setup-read-request ( adr )
+ dup ( adr adr )
+ begin ( adr adr )
+ get-data-packet ( adr adr' more? )
+ while ( adr adr' )
+ show-progress setup-ack-packet
+ repeat ( adr adr' )
+ \ Send the final acknowledge. Don't send if receive error.
+ too-many-tries? 0= if
+ setup-ack-packet
+ send-current-packet
+ then
+ swap -
+ \ set ip addresses, for some proms ( client,server,router)
+ \ By default, setup-ip-attr is a noop.
+ setup-ip-attr
+ too-many-tries? tftp-close abort" tftp failed"
+;
+
+headerless
+
+\ previous definitions
+
+\ *** New routines for tftpwrite ***
+
+: receive-ack-packet ( -- true | ack-packet-adr ack-len false )
+ receive-tftp-packet if true exit then ( tftp-adr,len )
+
+ \ Check packet type
+ opcode xw@ err-pkt = if .merror 2drop true exit then
+ opcode xw@ ack-pkt <> if ." Got a non-ack packet" 2drop true exit then
+ bad-block#? if 2drop true exit then ( tftp-adr,len )
+ 4 /string false ( ack-adr,len false )
+;
+
+: get-ack-packet ( -- ack-received? )
+ #retries off
+ begin
+ send-current-packet
+ receive-ack-packet ( [ ack-packet-adr ack-len ] flag )
+ 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-tries? if .receive-failed false exit then
+ repeat 2drop true
+;
+
+: setup-data-packet ( adr sizeleft -- adr' sizeleft' done? )
+ dup 0< if true exit then
+ tftp-packet set-struct
+ data-pkt opcode xw!
+ 1 this-block +!
+ this-block @ block# xw! ( adr sizeleft )
+ 2dup d# 512 min ( adr sizeleft adr size<=512 )
+ dup 4 + #packet !
+ data swap move
+ d# 512 - \ decrease size remaining
+ swap d# 512 + swap \ adjust addr for remaining data
+ false
+;
+
+\ also forth definitions
+
+headers
+
+: tftpwrite ( adr size filename$ -- )
+ tftp-init ( adr size filename$ )
+ 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
+ tftp-close
+;
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Added: ofw/inetv6/udp.fth
===================================================================
--- ofw/inetv6/udp.fth (rev 0)
+++ ofw/inetv6/udp.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,147 @@
+\ See license at end of file
+purpose: Simple User Datagram Protocol (UDP) implementation
+decimal
+
+headers
+\ udp-checksum? controls checksum calculation
+\ of outgoing UPD Packets
+\ 0 value udp-checksum?
+headerless
+d# 17 constant UDP
+
+instance variable my-udp-port
+instance variable his-udp-port
+
+struct ( udp-header )
+ 2 sfield udp-source-port
+ 2 sfield udp-dest-port
+ 2 sfield udp-length
+ 2 sfield udp-checksum
+constant /udp-header
+
+struct ( udp-pseudo-hdr )
+ /i field udp-src-addr
+ /i field udp-dst-addr
+ 2 field udp-protocol-id
+ 2 field udp-len-copy
+constant /udp-pseudo-hdr
+
+/udp-pseudo-hdr instance buffer: udp-pseudo-hdr
+
+0 instance value udp-len
+
+\ Assumes the-struct is the UDP packet.
+: fill-udp-pseudo-hdr ( -- )
+ /ip-header negate +struct
+ udp-pseudo-hdr ( udp-pseudo-addr )
+ ip-source-addr over udp-src-addr copy-ip-addr ( udp-pseudo-addr )
+ ip-dest-addr over udp-dst-addr copy-ip-addr ( udp-pseudo-addr )
+ UDP over udp-protocol-id xw! ( udp-pseudo-addr )
+ /ip-header +struct ( udp-pseudo-addr )
+ udp-length xw@ swap udp-len-copy xw! ( )
+;
+
+\ Assumes the-struct is the UDP packet.
+: calc-udp-checksum ( -- checksum )
+ fill-udp-pseudo-hdr
+ 0 udp-pseudo-hdr /udp-pseudo-hdr (oc-checksum) ( cksum )
+ 0 udp-checksum xw!
+ the-struct udp-length xw@ oc-checksum
+;
+
+headers
+: send-udp-packet ( data-addr data-len src-port dst-port -- )
+ 2swap swap /udp-header - set-struct -rot ( data-len src-port dst-port )
+ udp-dest-port xw! udp-source-port xw! ( data-len )
+ /udp-header + dup udp-length xw! ( udp-len )
+ 0 udp-checksum xw! ( udp-len )
+
+ udp-checksum? if ( udp-len )
+ calc-udp-checksum udp-checksum xw! ( udp-len )
+ then ( udp-len )
+
+ the-struct swap UDP send-ip-packet ( )
+;
+: allocate-udp ( payload-len -- payload-adr )
+ /udp-header + allocate-ip /udp-header +
+;
+: free-udp ( payload-adr payload-len -- )
+ /udp-header negate /string free-ip
+;
+headerless
+
+: bad-udp-checksum? ( -- bad? )
+ udp-checksum xw@ dup if ( checksum )
+ calc-udp-checksum <> ( bad? )
+ then ( bad? )
+;
+
+: lock-udp-address ( -- ) lock-ip-address ;
+
+defer handle-udp ( adr len src-port dst-port -- )
+defer handle-bad-udp ( adr len src-port -- )
+headers
+: (handle-udp) ( adr len src-port dst-port -- )
+ bootnet-debug if
+ 2dup swap
+ ." (Discarding UDP packet, source port: " u. ." dest port: " u. ." )" cr
+ then
+ 4drop
+;
+' (handle-udp) is handle-udp
+: (handle-bad-udp) ( adr len src-port -- )
+ bootnet-debug if
+ dup
+ ." (Discarding UDP packet with bad checksum, source port: " u. ." )" cr
+ then
+ 3drop
+;
+' (handle-bad-udp) is handle-bad-udp
+headerless
+
+: udp-payload ( len -- adr' len' src-port )
+ drop
+ the-struct udp-length xw@ /udp-header /string udp-source-port xw@
+;
+headers
+: receive-udp-packet ( dst-port -- true | udp-packet-adr,len src-port false )
+ begin ( port )
+ UDP receive-ip-packet if drop true exit then ( port udp-adr,len )
+ swap set-struct ( port len )
+ bad-udp-checksum? if ( port len )
+ udp-payload handle-bad-udp ( port )
+ drop true exit \ Discard garbled packet and retry
+ else ( port len )
+ over udp-dest-port xw@ = if ( port len )
+ true ( port len true )
+ else ( port len )
+ udp-payload udp-dest-port xw@ handle-udp ( port )
+ false ( port false )
+ then ( port [ len ] flag )
+ then ( port [ len ] flag )
+ until ( port len )
+ nip udp-payload false ( adr len port false )
+;
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Added: ofw/inetv6/udpv6.fth
===================================================================
--- ofw/inetv6/udpv6.fth (rev 0)
+++ ofw/inetv6/udpv6.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,167 @@
+\ See license at end of file
+purpose: Simple User Datagram Protocol version 6 (UDP) implementation
+decimal
+
+headerless
+
+[ifndef] include-ipv4
+struct ( udp-header )
+ 2 sfield udp-source-port
+ 2 sfield udp-dest-port
+ 2 sfield udp-length
+ 2 sfield udp-checksum
+constant /udp-header
+
+: clear-his-address ( -- ) ;
+: lock-udp-address ( -- ) ;
+: send-udp-packet ( data-addr data-len src-port dst-port -- ) .ipv4-not-supported ;
+: allocate-udp ( payload-len -- payload-adr ) .ipv4-not-supported ;
+: free-udp ( payload-adr payload-len -- ) .ipv4-not-supported ;
+[then]
+
+struct ( udpv6-pseudo-hdr )
+ /ipv6 field udpv6-src-addr
+ /ipv6 field udpv6-dst-addr
+ 4 field udpv6-len-copy
+ 4 field udpv6-protocol-id
+constant /udpv6-pseudo-hdr
+
+/udpv6-pseudo-hdr instance buffer: udpv6-pseudo-hdr
+
+\ Assumes the-struct is the UDP packet.
+: fill-udpv6-pseudo-hdr ( -- )
+ /ipv6-header negate +struct
+ udpv6-pseudo-hdr ( udp-pseudo-addr )
+ my-ipv6-addr over udpv6-src-addr copy-ipv6-addr ( udp-pseudo-addr )
+ his-ipv6-addr over udpv6-dst-addr copy-ipv6-addr ( udp-pseudo-addr )
+ IP_HDR_UDP over udpv6-protocol-id xl! ( udp-pseudo-addr )
+ /ipv6-header +struct ( udp-pseudo-addr )
+ udp-length xw@ swap udpv6-len-copy xl! ( )
+;
+
+\ Assumes the-struct is the UDP packet.
+: calc-udpv6-checksum ( -- checksum )
+ fill-udpv6-pseudo-hdr
+ 0 udpv6-pseudo-hdr /udpv6-pseudo-hdr (oc-checksum) ( cksum )
+ 0 udp-checksum xw!
+ the-struct udp-length xw@ oc-checksum
+;
+
+headers
+: send-udpv6-packet ( data-addr data-len src-port dst-port -- )
+ 2swap swap /udp-header - set-struct -rot ( data-len src-port dst-port )
+ udp-dest-port xw! udp-source-port xw! ( data-len )
+ /udp-header + dup udp-length xw! ( udp-len )
+ 0 udp-checksum xw! ( udp-len )
+
+ calc-udpv6-checksum udp-checksum xw! ( udp-len )
+
+ the-struct swap IP_HDR_UDP send-ipv6-packet ( )
+;
+: allocate-udpv6 ( payload-len -- payload-adr )
+ /udp-header + allocate-ipv6 /udp-header +
+;
+: free-udpv6 ( payload-adr payload-len -- )
+ /udp-header negate /string free-ipv6
+;
+
+: send-udp-packet ( data-addr data-len src-port dst-port -- )
+ use-ipv6? if send-udpv6-packet else send-udp-packet then
+;
+: allocate-udp ( payload-len -- payload-adr )
+ use-ipv6? if allocate-udpv6 else allocate-udp then
+;
+: free-udp ( payload-adr payload-len -- )
+ use-ipv6? if free-udpv6 else free-udp then
+;
+headerless
+
+: bad-udpv6-checksum? ( -- bad? )
+ udp-checksum xw@ dup if ( checksum )
+ calc-udpv6-checksum <> ( bad? )
+ then ( bad? )
+;
+
+: lock-udpv6-address ( -- ) lock-ipv6-address ;
+: lock-udp-address ( -- )
+ use-ipv6? if lock-udpv6-address else lock-udp-address then
+;
+
+[ifndef] include-ipv4
+defer handle-udp ( adr len src-port dst-port -- )
+defer handle-bad-udp ( adr len src-port -- )
+headers
+: receive-udp-packet ( dst-port -- true ) drop true ;
+: (handle-udp) ( adr len src-port dst-port -- )
+ bootnet-debug if
+ 2dup swap
+ ." (Discarding UDP packet, source port: " u. ." dest port: " u. ." )" cr
+ then
+ 4drop
+;
+' (handle-udp) is handle-udp
+: (handle-bad-udp) ( adr len src-port -- )
+ bootnet-debug if
+ dup
+ ." (Discarding UDP packet with bad checksum, source port: " u. ." )" cr
+ then
+ 3drop
+;
+' (handle-bad-udp) is handle-bad-udp
+
+headerless
+
+: udp-payload ( len -- adr' len' src-port )
+ drop
+ the-struct udp-length xw@ /udp-header /string udp-source-port xw@
+;
+[then]
+
+headers
+: receive-udp-packetv6 ( dst-port -- true | udp-packet-adr,len src-port false )
+ begin ( port )
+ IP_HDR_UDP receive-ip-packet if drop true exit then ( port udp-adr,len )
+ swap set-struct ( port len )
+ bad-udpv6-checksum? if ( port len )
+ udp-payload handle-bad-udp ( port )
+ drop true exit \ Discard garbled packet and retry
+ else ( port len )
+ over udp-dest-port xw@ = if ( port len )
+ true ( port len true )
+ else ( port len )
+ udp-payload udp-dest-port xw@ handle-udp ( port )
+ false ( port false )
+ then ( port [ len ] flag )
+ then ( port [ len ] flag )
+ until ( port len )
+ nip udp-payload false ( adr len port false )
+;
+
+: receive-udp-packet ( dst-port -- true | udp-packet-adr,len src-port false )
+ use-ipv6? if receive-udp-packetv6 else receive-udp-packet then
+;
+
+
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Added: ofw/inetv6/watchnet.fth
===================================================================
--- ofw/inetv6/watchnet.fth (rev 0)
+++ ofw/inetv6/watchnet.fth 2007-08-02 21:37:59 UTC (rev 518)
@@ -0,0 +1,70 @@
+\ See license at end of file
+purpose: watch-net network debugging command
+
+headerless
+0 value net-ih
+0 value max-packet
+0 value packet-buf
+: (watch-net) ( ihandle -- )
+ to net-ih
+ " max-frame-size" net-ih ihandle>phandle get-package-property if ( )
+ d# 2000 ( length )
+ else ( adr len )
+ get-encoded-int ( length )
+ then ( length )
+ to max-packet ( )
+ max-packet alloc-mem to packet-buf
+ ." Watching network traffic." cr
+ ." '.' is a good packet, 'X' is a bad packet. Type any key to stop." cr
+ begin
+ packet-buf max-packet " read" net-ih $call-method case
+ -2 of endof
+ -1 of ." X" endof
+ ." ."
+ endcase
+ key? until key drop cr
+ packet-buf max-packet free-mem
+ net-ih close-dev
+;
+headers
+
+: watch-net ( [ "name" ] -- )
+ parse-word dup 0= if 2drop " net" then ( name )
+
+ 2dup " watch-net" execute-device-method if
+ 2drop
+ else
+ "temp place
+ " :promiscuous" "temp $cat
+ "temp count open-dev
+ dup 0= abort" Can't open network device"
+ (watch-net)
+ then
+;
+
+: watch-net-all ( -- )
+ optional-arg-or-/$ " watch-net" execute-all-methods
+;
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
More information about the OpenBIOS
mailing list