OpenBIOS August 2007

openbios@openbios.org

12 participants
103 discussions

r518 - dev/usb2/device/wlan ofw ofw/inetv6
by svn＠openbios.org 02 Aug '07

02 Aug '07

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@+ +: c@+ ( 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@+ case + + end-option of r> 2drop exit endof \ End (255) + + 0 of endof \ Pad + + 1 of \ Netmask + c@+ + over subnetmask copy-ip-addr + ca+ + endof + + 3 of \ Router + c@+ + over router-ip-addr copy-ip-addr + ca+ + endof + + \ default - skip option + drop c@+ 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@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@++ ( -- char ) hbuf-ptr hbuf@ +hptr ; +: skip-til-white ( -- ) begin hbuf@++ bl = until ; +: skip-til ( char -- ) begin dup hbuf@++ = until drop ; +: skip-til-crlf ( -- ) carret skip-til +hptr ; + +: skip-til-white-or-? ( -- ) + begin hbuf@++ 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 ( -- ) + " " 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$ ) + " " type ( val$ var$ ) + type ( val$ ) + " " type ( val$ ) + " set to " type ( val$ ) + " " type ( val$ ) + type-cr ( ) + " " type ( ) + " " 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$ ) +\ " " type ( var$ ) +\ type ( ) +\ " " type ( ) +\ " set to default value" type ( ) +\ " " type ( ) +\ " " 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@+ +: c@+ ( adr -- adr' b ) dup 1+ swap c@ ; +[then] +: ip-prefix=? ( ip1 ip2 -- flag ) + netmask /i 0 do ( ip1 ip2 nm ) + rot c@+ >r ( ip2 nm ip1' r: b1 ) + rot c@+ >r ( nm ip1' ip2' r: b1 b2 ) + rot c@+ ( 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

1 0

r517 - dev/olpc/spiflash
by svn＠openbios.org 02 Aug '07

02 Aug '07

Author: wmb Date: 2007-08-02 12:32:34 +0200 (Thu, 02 Aug 2007) New Revision: 517 Modified: dev/olpc/spiflash/spiui.fth Log: OLPC trac 2636 - Increase the inter-chunk delay to 200 mS, because 100 mS isn't entirely reliable. Modified: dev/olpc/spiflash/spiui.fth =================================================================== --- dev/olpc/spiflash/spiui.fth 2007-08-02 10:24:38 UTC (rev 516) +++ dev/olpc/spiflash/spiui.fth 2007-08-02 10:32:34 UTC (rev 517) @@ -248,10 +248,9 @@ \ It works around the problem that continuous CPU access to the \ SPI FLASH starves the EC of instruction fetch cycles, often \ causing it to turn off the system. - rom-va flash-buf /flash 0 do rom-va i + flash-buf i + h# 1.0000 lmove - d# 100 ms + d# 200 ms h# 1.0000 +loop \ Replace the manufacturing data block with all FF

1 0

r516 - cpu/x86/pc/olpc
by svn＠openbios.org 02 Aug '07

02 Aug '07

Author: wmb Date: 2007-08-02 12:24:38 +0200 (Thu, 02 Aug 2007) New Revision: 516 Modified: cpu/x86/pc/olpc/versions.fth Log: Version q2c22. Modified: cpu/x86/pc/olpc/versions.fth =================================================================== --- cpu/x86/pc/olpc/versions.fth 2007-08-02 10:23:58 UTC (rev 515) +++ cpu/x86/pc/olpc/versions.fth 2007-08-02 10:24:38 UTC (rev 516) @@ -2,7 +2,7 @@ \ The overall firmware revision macro: FW_MAJOR C -macro: FW_MINOR 21 +macro: FW_MINOR 22 \ The EC microcode macro: EC_VERSION c20

1 0

r515 - dev/olpc/spiflash
by svn＠openbios.org 02 Aug '07

02 Aug '07

Author: wmb Date: 2007-08-02 12:23:58 +0200 (Thu, 02 Aug 2007) New Revision: 515 Modified: dev/olpc/spiflash/spiui.fth Log: SPI FLASH selftest - OLPC trac 2636 - Workaround a hardware design deficiency by throttling access to the SPI FLASH in the /flash selftest method. If the CPU accesses the SPI FLASH too frequently, the EC apparently can't do its instruction fetches, and the system resets. The workaround is to access the SPI FLASH in 64K chunks, waiting 100 mS between chunks. Modified: dev/olpc/spiflash/spiui.fth =================================================================== --- dev/olpc/spiflash/spiui.fth 2007-08-02 05:35:04 UTC (rev 514) +++ dev/olpc/spiflash/spiui.fth 2007-08-02 10:23:58 UTC (rev 515) @@ -243,8 +243,17 @@ 0 value rom-va : selftest ( -- error? ) rom-va 0= if rom-pa /flash root-map-in to rom-va then - rom-va flash-buf /flash move + \ This is a slower version of "rom-va flash-buf /flash lmove" + \ It works around the problem that continuous CPU access to the + \ SPI FLASH starves the EC of instruction fetch cycles, often + \ causing it to turn off the system. + rom-va flash-buf + /flash 0 do + rom-va i + flash-buf i + h# 1.0000 lmove + d# 100 ms + h# 1.0000 +loop + \ Replace the manufacturing data block with all FF flash-buf mfg-data-offset + /flash-block h# ff fill

1 0

r514 - cpu/x86/pc/olpc
by svn＠openbios.org 02 Aug '07

02 Aug '07

Author: wmb Date: 2007-08-02 07:35:04 +0200 (Thu, 02 Aug 2007) New Revision: 514 Modified: cpu/x86/pc/olpc/versions.fth Log: q2c21 Modified: cpu/x86/pc/olpc/versions.fth =================================================================== --- cpu/x86/pc/olpc/versions.fth 2007-08-02 05:26:07 UTC (rev 513) +++ cpu/x86/pc/olpc/versions.fth 2007-08-02 05:35:04 UTC (rev 514) @@ -2,7 +2,7 @@ \ The overall firmware revision macro: FW_MAJOR C -macro: FW_MINOR 20e +macro: FW_MINOR 21 \ The EC microcode macro: EC_VERSION c20

1 0

r513 - dev/olpc/kb3700
by svn＠openbios.org 02 Aug '07

02 Aug '07

Author: wmb Date: 2007-08-02 07:26:07 +0200 (Thu, 02 Aug 2007) New Revision: 513 Modified: dev/olpc/kb3700/battery.fth Log: OLPC watch-battery - OLPC track 2620 - Use EC commands for reading battery status, instead of indexed I/O to EC RAM locations. Modified: dev/olpc/kb3700/battery.fth =================================================================== --- dev/olpc/kb3700/battery.fth 2007-08-01 19:17:30 UTC (rev 512) +++ dev/olpc/kb3700/battery.fth 2007-08-02 05:26:07 UTC (rev 513) @@ -11,16 +11,23 @@ : bat-b@ h# f900 + ec@ ; : bat-w@ dup 1+ bat-b@ swap bat-b@ bwjoin ; : eram-w@ h# f400 + dup 1+ ec@ swap ec@ bwjoin ; -: uvolt@ 0 bat-w@ d# 9760 d# 32 */ ; -: cur@ 2 bat-w@ wextend d# 15625 d# 120 */ ; \ Base unit for temperature is 1/256 degrees C : >degrees-c 7 rshift 1+ 2/ ; \ Round to nearest degree -: pcb-temp 8 bat-w@ >degrees-c ; -: bat-temp 6 bat-w@ >degrees-c ; : .% ( n -- ) .d ." %" ; -: soc h# 10 bat-b@ ; +\ : uvolt@ 0 bat-w@ d# 9760 d# 32 */ ; +\ : cur@ 2 bat-w@ wextend d# 15625 d# 120 */ ; +\ : pcb-temp 8 bat-w@ >degrees-c ; +\ : bat-temp 6 bat-w@ >degrees-c ; +\ : soc h# 10 bat-b@ ; : bat-state h# 11 bat-b@ ; : bat-cause@ h# 70 bat-b@ ; + +: uvolt@ bat-voltage@ d# 9760 d# 32 */ ; +: cur@ bat-current@ wextend d# 15625 d# 120 */ ; +: pcb-temp ambient-temp@ >degrees-c ; +: bat-temp bat-temp@ >degrees-c ; +: soc bat-soc@ ; + string-array bat-causes ( 00) ," " ( 01) ," Bus Stuck at Zero" @@ -50,10 +57,20 @@ ," abnormal: " end-string-array -: .bat-state - bat-state dup bat-states count type - 8 = if .bat-cause then +: .bat-status + bat-status@ + ." AC " dup h# 10 and if ." on " else ." off " then + + dup 1 and if + dup 2 and if ." Battery full " then + dup 4 and if ." Battery low " then + dup 8 and if ." Battery destroyed " then + else + ." No battery" + then + drop ; + : .milli ( -- ) push-decimal dup abs d# 10,000 / <# u# u# [char] . hold u#s swap sign u#> type @@ -65,7 +82,7 @@ uvolt@ .milli ." V " cur@ .milli ." A " bat-temp .d ." C " - .bat-state + .bat-status ." (PCB " pcb-temp .d ." C)" ; : watch-battery ( -- )

1 0

Re: [OpenBIOS] [Qemu-devel] IBM makes AIX 6 beta available for download for everyone
by Blue Swirl 01 Aug '07

01 Aug '07

The correct place for these questions would be the OpenBIOS list (blatantly cross-posted). On 7/30/07, Andreas Färber <andreas.faerber(a)web.de> wrote: > > Am 19.07.2007 um 09:23 schrieb Natalia Portillo: > > > El jue, 19-07-2007 a las 00:46 +0200, Andreas Färber escribió: > >> Am 18.07.2007 um 18:26 schrieb Blue Swirl: > >> > >>>>> It looks like open hack'ware is pretty much stalled, so its hard > >>>>> telling > >>>>> what progress will be made futurewise. > >>>> > >>>> Might it be possible to replace it with OpenBIOS? > >>> > >>> Sure, and as both are GPL useful, code can be shared. But some PPC > >>> developers are needed. It may still be easier to fix the OHW bugs > >>> than > >>> start over anew. > >> > >> Not sure I understand... I thought Open Firmware was based on > >> platform independent Forth code? > >> I'm running on ppc64 and could try to compile something under Linux > >> in case that's the problem. > > Yes, OF is basically a Forth-interpreter. > > Of course this Forth-interpreter is in C and compile to machine > > code :p > > Yes, that is obvious. Not so obvious was what ppc *developers* were > needed for. > I got the other answer afterwards saying that HFS etc. support needed > to be added. > > > > Try to compile OpenBIOS under Linux/PPC (using 32bit compiler, not > > ppc64) and comment us. > > I tried SVN HEAD of both fcode-utils and openbios-devel. > > OpenBIOS supposedly has support for ppc and cross-ppc archs but that > is not true. It currently only has support for cross-ppc (for the old > PearPC emulator it seems). I copied these files as ppc_config.xml and > ppc_rules.xml respectively to get the ppc target, in ppc_rules.xml > changed the tool names to use the standard gcc etc. and was able to > compile okay. Products based on this unmodified configuration were > among others an openbios-pearpc.elf file - I thus changed ppc_rom.bin > in some ppc files to this filename. Launching qemu-system-sparc -boot > d -cdrom /dev/cdrom with a Debian Etch DVD inserted resulted in an > opcode error. My guess thus is that this OpenBIOS file is not suited > for qemu in that configuration? > > Some observations that might be of interest: > - OpenBIOS has support for some (not all) PowerPC processors > according to some Readme > - it specifically mentions ppc/AIX and has some apparent IBM > contributions despite the missing ppc target > - the cross-ppc config mentions HFS and HFSP which I guess refer to > HFS and HFS+ filesystems respectively (HFS was set to false, HFSP to > true) > > Maybe someone can shed some more light on what exactly needs to be > changed config-wise or is missing in OpenBIOS or qemu in order to > boot AIX 6 or any Linux. > > Andreas > >

1 0

r512 - cpu/x86/pc/olpc
by svn＠openbios.org 01 Aug '07

01 Aug '07

Author: rsmith Date: 2007-08-01 21:17:30 +0200 (Wed, 01 Aug 2007) New Revision: 512 Modified: cpu/x86/pc/olpc/versions.fth Log: OLPC: Updater version number to q2c20e Modified: cpu/x86/pc/olpc/versions.fth =================================================================== --- cpu/x86/pc/olpc/versions.fth 2007-08-01 08:32:03 UTC (rev 511) +++ cpu/x86/pc/olpc/versions.fth 2007-08-01 19:17:30 UTC (rev 512) @@ -2,7 +2,7 @@ \ The overall firmware revision macro: FW_MAJOR C -macro: FW_MINOR 21 +macro: FW_MINOR 20e \ The EC microcode macro: EC_VERSION c20

1 0

r511 - cpu/x86/pc/olpc
by svn＠openbios.org 01 Aug '07

01 Aug '07

Author: wmb Date: 2007-08-01 10:32:03 +0200 (Wed, 01 Aug 2007) New Revision: 511 Modified: cpu/x86/pc/olpc/versions.fth Log: Version Q2C21. Modified: cpu/x86/pc/olpc/versions.fth =================================================================== --- cpu/x86/pc/olpc/versions.fth 2007-08-01 08:25:31 UTC (rev 510) +++ cpu/x86/pc/olpc/versions.fth 2007-08-01 08:32:03 UTC (rev 511) @@ -2,7 +2,7 @@ \ The overall firmware revision macro: FW_MAJOR C -macro: FW_MINOR 20 +macro: FW_MINOR 21 \ The EC microcode macro: EC_VERSION c20

1 0

r510 - cpu/x86/pc/olpc dev/olpc/cafenand
by svn＠openbios.org 01 Aug '07

01 Aug '07

Author: wmb Date: 2007-08-01 10:25:31 +0200 (Wed, 01 Aug 2007) New Revision: 510 Modified: cpu/x86/pc/olpc/copynand.fth dev/olpc/cafenand/badblock.fth dev/olpc/cafenand/cafenand.fth Log: OLPC copy-nand - OLPC trac 2614. Made copy-nand abort not only on a CRC mismatch, but also on a NAND write error. Modified: cpu/x86/pc/olpc/copynand.fth =================================================================== --- cpu/x86/pc/olpc/copynand.fth 2007-08-01 03:15:29 UTC (rev 509) +++ cpu/x86/pc/olpc/copynand.fth 2007-08-01 08:25:31 UTC (rev 510) @@ -148,7 +148,8 @@ (cr i . read-image-block i ?check-crc - load-base " copy-block" nandih $call-method + load-base " copy-block" nandih $call-method ( error? ) + " Error writing to NAND FLASH" ?nand-abort loop cr ." Filling with cleanmarkers ..." Modified: dev/olpc/cafenand/badblock.fth =================================================================== --- dev/olpc/cafenand/badblock.fth 2007-08-01 03:15:29 UTC (rev 509) +++ dev/olpc/cafenand/badblock.fth 2007-08-01 08:25:31 UTC (rev 510) @@ -132,7 +132,10 @@ dup if ( signature$ page# ) dup erase-block ( signature$ page# ) bbt over /bbt /page / bounds ?do ( signature$ page# adr ) - dup i write-page ( signature$ page# adr ) + dup i write-page if ( signature$ page# adr ) + ." Error writing Bad Block Table - page# " i .x cr + 3drop unloop exit + then /page + ( signature$ page# adr' ) loop ( signature$ page# adr' ) drop ( signature$ page# ) @@ -253,13 +256,15 @@ over block-bad? if 3drop 0 exit then then - dup >r ( adr page# #pages r: #pages ) - bounds ?do ( adr ) - \ XXX need some error handling - dup i write-page ( adr ) - /page + ( adr' ) - loop ( adr ) - drop r> + over >r dup >r ( adr page# #pages r: page# #pages ) + bounds ?do ( adr r: page# #pages ) + dup i write-page if ( adr r: page# #pages ) + drop r> drop i r> - ( #written ) + unloop exit + then ( adr r: page# #pages ) + /page + ( adr' r: page# #pages ) + loop ( adr r: page# #pages ) + drop r> r> drop ( #pages ) ; : erase-blocks ( page# #pages -- #pages ) @@ -364,12 +369,14 @@ : start-scan ( -- ) pages/eblock negate to scan-page# ; \ Must erase all (wipe) first -: copy-block ( adr -- ) +: copy-block ( adr -- error? ) next-page# pages/eblock bounds ?do ( adr ) - dup i write-page ( adr ) + dup i write-page if ( adr ) + drop true unloop exit ( true ) + then ( adr ) /page + ( adr' ) loop ( adr ) - drop ( ) + drop false ( false ) ; : put-cleanmarkers ( -- ) Modified: dev/olpc/cafenand/cafenand.fth =================================================================== --- dev/olpc/cafenand/cafenand.fth 2007-08-01 03:15:29 UTC (rev 509) +++ dev/olpc/cafenand/cafenand.fth 2007-08-01 08:25:31 UTC (rev 510) @@ -119,7 +119,7 @@ \ : read-id ( -- ) 0 0 set-page read-id-cmd 0 cmd wait-cmd h# 30 cl@ ; : dma-off ( -- ) 0 h# 40 cl! ; -: wait-write-done ( -- ) +: wait-write-done ( -- error? ) 0 ( status ) begin ( status ) drop ( ) @@ -127,7 +127,8 @@ dup h# 40 and ( status flag ) until ( status ) \ If the value is completely 0 I think it means write protect - 1 and if ." NAND write error" cr then + 1 and 0<> ( error? ) + write-disable ; \ Assumes that the range doesn't straddle a page boundary @@ -149,18 +150,17 @@ dma-off set-page dup datalen ( adr len ) chip h# 2000 + swap move ( ) write-cmd h# 0000.0110 cmd wait-cmd ( ) \ No Auto ECC - wait-write-done - write-disable + wait-write-done ( error? ) + drop ; -: pio-write-page ( adr page# -- ) +: pio-write-page ( adr page# -- error? ) write-enable dma-off ( adr page# ) 0 set-page ( adr ) /page h# e + dup datalen ( adr len ) chip h# 2000 + swap move ( ) write-cmd h# 4800.0110 cmd wait-cmd ( ) \ 4000. Auto ECC, 0800. R/S ECC - wait-write-done - write-disable + wait-write-done ( error? ) ; : read-oob ( page# -- adr ) @@ -228,22 +228,21 @@ set-page ( adr len ) dup false dma-setup ( ) write-cmd h# 110 cmd wait-cmd ( ) - wait-write-done ( ) - dma-release ( ) - write-disable ( ) + wait-write-done ( error? ) + dma-release ( error? ) + drop ; -: dma-write-page ( adr page# -- ) \ Size is fixed +: dma-write-page ( adr page# -- error? ) \ Size is fixed write-enable ( adr page# ) 0 set-page ( adr ) h# 800 h# 80e false dma-setup ( ) write-cmd h# 4800.0110 cmd wait-cmd ( ) \ Auto-ECC, RS, write cmd - wait-write-done ( ) + wait-write-done ( error? ) \ dma-release - write-disable ( ) ; -: write-page ( adr page# -- ) dma-write-page ; +: write-page ( adr page# -- error? ) dma-write-page ; : write-bytes ( adr len page# offset -- ) pio-write-raw ; 3 value #erase-adr-bytes \ Chip dependent @@ -251,8 +250,8 @@ write-enable set-erase-page h# 20.0060 0 #erase-adr-bytes >cmd h# 1d0 cmd - wait-write-done - write-disable + wait-write-done ( error? ) + drop ; : read-id ( -- adr ) 8 0 0 h# c420.0090 0 generic-read ;

1 0