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 ( -- ) + " <br>" type-cr + et-go-home + " <hr>" type-cr + " <CENTER><IMG SRC=""homelogo.gif""></CENTER>" type-cr + " </BODY>" type-cr + " </HTML>" type-cr + page-mode +; + +\ Collect output from execute ROM command +: collect-data ( xt -- adr len ) + collect( ( xt ) + create-header ( xt ) + create-pre ( xt ) + guarded ( ) + create-endpre ( ) + create-footer ( ) + )collect ( adr len ) +; + +\needs auth-header : auth-header ( -- $ ) " WWW-Authenticate: Basic realm=""OFW"""n"r" ; + +: send-204 ( -- ) + httpd-debug? if ." Sending 204" cr then + ['] 200-header to send-header + ['] banner collect-data send-html + ['] 200-header to send-header +; + +: send-401 ( -- ) + httpd-debug? if ." Sending 401" cr then + ['] 401-header to send-header + ['] send-response-header to (send) + 0 auth-header respond + ['] 200-header to send-header +; + +: send-404 ( -- ) + httpd-debug? if ." Sending 404" cr then + ['] 404-header to send-header + " The ROM cannot supply this information." send-html + ['] 200-header to send-header +; + +\ HTML preprocessing before sending to browser. + +0 0 instance 2value rem$ +0 instance value #data$ +: #data$+ ( -- ) #data$ 1+ to #data$ ; +: find$ ( s$ t$ -- offset find? ) + 2>r ( s$ ) ( R: t$ ) + 0 -rot begin ( offset s$ ) ( R: t$ ) + over 2r@ comp 0= if 2r> 2drop 2drop true exit then + 1 /string ( offset s$' ) ( R: t$ ) + rot 1+ -rot ( offset' s$ ) ( R: t$ ) + dup 0= until 2r> 2drop 2drop false ( offset ) +; +: eval-forth ( -- data$ ... ) + rem$ 7 /string 2dup to rem$ ( adr len ) + " </FORTH>" find$ 0= if ." Missing </FORTH>" abort then ( offset ) + rem$ drop swap ( forth$ ) + rem$ 2 pick 8 + /string to rem$ ( forth$ ) + evaluate ( data$ ... n ) + #data$ + to #data$ ( data$ ... ) +; +: swap-data$ ( data$ ... -- data$' ... n ) + #data$ if + #data$ begin + dup 2* pick over 2* pick 2>r + 1- ?dup 0= + until + #data$ 0 do 2drop loop + #data$ begin + 2r> rot 1- ?dup 0= + until + then #data$ +; +: (preprocess-html) ( data$ -- data$' ... n ) + to rem$ + begin + rem$ " <FORTH>" find$ over ( offset found? offset ) + #data$+ + rem$ drop swap 2>r ( offset found? ) ( R: data$ ) + swap rem$ rot /string to rem$ 2r> ( found? data$ ) + rot if eval-forth then ( data$ ... ) + rem$ nip 0= + until + swap-data$ ( data$ ... n ) +; +: preprocess-html ( url$ data$ -- data$' ... n' ) + preprocess? if ( url$ data$ ) + 0 to #data$ ( url$ data$ ) + 2swap get-type upc ascii H = if ( data$ ) + (preprocess-html) ( data$' ... n ) + else ( data$ ) + 1 ( data$ n ) + then + else ( url$ data$ ) + 2swap 2drop 1 ( data$ n ) + then +; + +: transaction-done ( -- ) + state" T" + persistent? if + url" tdonefw" + " flush-writes" $call-parent + reset-hbuf-ptr + false to in-progress? + else + \ url" tdonerc" + reset-connection + then + state" D" +; + +[ifndef] urls +also forth definitions +vocabulary urls +previous definitions +[then] + +: handle-url ( opt$ url$ -- ) + 2dup ['] urls search-wordlist if ( opt$ url$ xt ) + execute ( data$ .. n type$ ) + respond ( ) + state" H" + exit ( ) + then ( opt$ url$ ) + + 2dup find-drop-in if ( opt$ url$ data$ ) + 2over 2>r ( opt$ url$ data$ ) ( R: url$ ) + 2>r 2>r 2drop 2r> 2r> ( url$ data$ ) ( R: url$ ) + preprocess-html ( data$' n ) ( R: url$ ) + 2r> presume-content-type ( data$ n type$ ) + respond ( ) + exit ( ) + then ( opt$ url$ ) + + 4drop send-404 ( ) +; + +\ Basic HTTP strings all end with "crlf" +: dual-crlf? ( adr -- flag ) 4 - hbuf + " "(0d0a0d0a)" comp 0= ; + +: request-complete? ( -- complete? ) \ Tells us if we have all were going + \ to get. + \ HTTP 0.9 looks like: + \ GET <url> crlf + + \ HTTP 1.0/1.1 looks like: + \ GET <url> HTTP/1.0 crlf ...<a bunch of crlf terminated crud>... crlf + + \ The major difference being that 0.9 is a single line with a single + \ crlf at the end, 1.0 (and higher ) is multi-line (each line terminated + \ by crlf) with an additional crlf at the end of the request. + + \ We need to determine which one we have in the buffer, and if complete, + \ return true so that the request can be processed. We also want to set + \ the response type up here to simple or full depending on 0.9 or 1.x + + hbuf-ptr ( ptr ) \ Save for later + + \ Reset the pointer, then advance it to where HTTP would be if we + \ have HTTP 1.0 request. + + reset-hbuf-ptr ( ptr ) + skip-til-white ( ptr ) + skip-til-white ( ptr ) + + \ Now test the buffer and take action accordingly + + " HTTP" hbuf hbuf-ptr + 4 ( ptr test$ buf$ ) + $= if ( ptr ) \ HTTP 1.x + ['] full-response to (send) + \ Now we have to see if we have all of this request or not + dup dual-crlf? ( ptr flag ) + + \ Now we have to setup to deal with persistent connections. + \ This is a bit of a cheat. We should be looking at the + \ "connection:" field (if it exists) in the incoming URL + \ requset. If it set to "Keep-Alive" then we would set + \ the persistent flag. But so far, *everyone* always sets + \ the Keep-Alive flag. But 1.0 implementations don't work, + \ and 1.1 implementations really want it to. So we just + \ set the persistance based on 1.1ness. + + \ " 1.0" hbuf hbuf-ptr + 5 + 3 $= 0= to persistent? + else \ HTTP 0.9 + \ We have all we are going to get. + ['] simple-response to (send) + true ( ptr true ) + then + + swap to hbuf-ptr ( flag ) \ Restore buffer pointer in case + \ there is more to come. +; + +: b64>6bit ( byte -- 6bit ) + dup ascii A ascii Z between if ascii A - exit then + dup ascii a ascii z between if ascii a - d# 26 + exit then + dup ascii 0 ascii 9 between if ascii 0 - d# 52 + exit then + case + ascii + of 3e endof + ascii / of 3f endof + ( default ) 0 swap + endcase +; + +: b64>ascii ( b64$ -- adr len ) + over dup >r 0 2swap ( adr len b64$ ) ( R: adr ) + bounds ?do ( adr len ) ( R: adr ) + i l@ lbsplit ( adr len b3 b2 b1 b0 ) ( R: adr ) + b64>6bit d# 18 << ( adr len b3 b2 b1 val ) ( R: adr ) + swap b64>6bit d# 12 << or ( adr len b3 b2 val' ) ( R: adr ) + swap b64>6bit d# 6 << or ( adr len b3 val' ) ( R: adr ) + swap b64>6bit or ( adr len val' ) ( R: adr ) + lbsplit drop ( adr len b3 b2 b1 ) ( R: adr ) + 4 pick c! ( adr len b3 b2 ) ( R: adr ) + 3 pick 1+ c! ( adr len b3 ) ( R: adr ) + 2 pick 2 + c! ( adr len ) ( R: adr ) + 3 + swap 3 + swap ( adr' len' ) ( R: adr ) + 4 +loop + dup if \ strip trailing 0's + 3 1 do + over i - c@ 0= if 1- then + loop + then nip ( len' ) + r> swap ( adr len ) +; + +: (authorized?) ( realm$ pwd$ user$ -- authorized? ) + " admin" $= >r " ofw" $= r> and + -rot 2drop +; + +defer authorized? +[ifdef] oem-authorized? + ['] oem-authorized? to authorized? +[else] + ['] (authorized?) to authorized? +[then] + +: extract-auth ( -- realm$ pwd$ user$ ) + begin skip-til-crlf hbuf-adr " "(0d0a)" comp while + hbuf-adr ( adr ) + [char] : skip-til ( adr ) + hbuf-adr over - 1- ( token$ ) + " Authorization" $= if ( ) + skip-til-white ( ) + hbuf-adr ( adr ) + skip-til-white + hbuf-adr over - 1- ( realm$ ) + hbuf-adr ( realm$ adr ) + skip-til-crlf + hbuf-adr over - 2 - ( realm$ base64$ ) + b64>ascii ( realm$ user:pwd$ ) + [char] : left-parse-string ( realm$ pwd$ user$ ) + exit + then + repeat + null$ null$ null$ +; + +: authenticate-request? ( -- authorized? ) + extract-auth ( realm$ pwd$ user$ ) + authorized? +; + +\ Since we serve up the HTML code, we can decide what to support. You +\ can do everything with "GET"s, and do not really need to support +\ POSTs. POSTs are better for security issues, but since this code +\ would not really be executed in the normal case, this should be a +\ minor issue. + +: do-get ( -- ) + request-complete? if + + httpd-debug? if cr hbuf hbuf-ptr type then + + extract-url ( opt$ url$ ) + + httpd-debug? if ( opt$ url$ ) + ." URL: " 2dup type-cr ( opt$ url$ ) + 2over ( opt$ url$ opt$ ) + ?dup if ( opt$ url$ opt$ ) + ." OPT: " type-cr ( opt$ url$ ) + else drop then ( opt$ url$ ) + then ( opt$ url$ ) + + authenticate? if ( opt$ url$ ) + authenticate-request? 0= if ( ) + 4drop ( ) + send-401 + transaction-done + exit + then + then + + handle-url ( ) + + transaction-done + then +; + +: do-post ( -- ) + request-complete? if + httpd-debug? if cr hbuf hbuf-ptr type then + send-204 + transaction-done + then +; + +: handle-buf ( -- ) + " GET" match? if do-get then + " POST" match? if do-post then +; + +false instance value crlf-seen? +: >hbuf ( b -- ) \ Accumulate data, when we get a CRLF pair, go check it + hbuf hbuf-ptr + c! + +hptr + hbuf-ptr 2 >= if + hbuf-ptr hbuf + 2- " "(0d0a)" comp 0= if handle-buf then + then +; + +0 value end-time +d# 5000 constant short-time +d# 30000 constant long-time + +: reset-timer ( -- ) + true to in-progress? + persistent? if long-time else short-time then ( timeout-msecs ) + get-msecs + to end-time +; + +: do-disconnect ( -- ) + httpd-debug? if ." Disconnect reset" cr then + url" discrc" + reset-connection +; +: do-idle ( -- ) + in-progress? if + key-interrupt? if + key? if + key drop + ." HTTPD transaction in progress; interacting " cr + interact + then + then + else + ?bailout + then + + persistent? if exit then + get-msecs end-time - 0> if + httpd-debug? if ." Timeout reset" cr then + url" idlerc" + reset-connection + then +; + +\ Call into the TCP stack, just shovel the data to our collection +\ buffer. The shoveler (>hbuf) will decide when there is enough +\ data to work on. +: httpd-loop ( -- ) + false to in-progress? + begin + connected? 0= if connect reset-timer then + + thbuf /thbuf read case ( -1|-2|actual ) + -1 of do-disconnect endof + -2 of do-idle endof + ( actual ) + reset-timer ( actual ) + thbuf over bounds do i c@ >hbuf loop ( actual ) + endcase + key-interrupt? if key? if key emit exit then then + again +; + + +\ builtin URLs +\ this is essentially demo code + +hex +headers + +\ support for the built-in URLs + +\ Creates return message for setenv +: nice-message ( val$ var$ -- adr len ) + collect( ( val$ var$ ) + create-header ( val$ var$ ) + " ROM Configuration Variable " type ( val$ var$ ) + " <b>" type ( val$ var$ ) + type ( val$ ) + " </b>" type ( val$ ) + " set to " type ( val$ ) + " <b>" type ( val$ ) + type-cr ( ) + " </b>" type ( ) + " <br> <br>" type-cr + create-footer + )collect +; + +\ \ Creates return message for setenv +\ : nice-message1 ( var$ -- adr len ) +\ collect( ( var$ ) +\ create-header ( var$ ) +\ " ROM Configuration Variable " type ( var$ ) +\ " <b>" type ( var$ ) +\ type ( ) +\ " </b>" type ( ) +\ " set to default value" type ( ) +\ " </b>" type ( ) +\ " <br> <br>" type-cr +\ create-footer +\ )collect +\ ; + +\ HTTP strings have a "+" where blanks are suppsed to be. Just whack them. +: fix-blanks ( adr len -- ) + bounds ?do + i c@ [char] + = if bl i c! then + loop +; + +\ HTTP strings mungle up the special characters. Instead of a "/" for +\ example, you get "%2F". This routine looks for the "%" characters, +\ extracts the ascii string after that, converts it to the real hex +\ value and punches it back where the "%" was, then moves everything +\ else to the left by two. +: fixup-string ( adr len -- adr len' ) + 2dup fix-blanks \ First whack the blanks into shape. + dup 3 < if exit then \ Cannot possibly have %xx. + 2dup 2- bounds ?do + i c@ [char] % = if + i 1+ 2 $number 0<> if ." Parsing error" unloop exit then + ( adr len b ) i c! + i 3 + ( adr len src ) + i 1 + ( adr len src dst ) + over 4 pick - ( adr len src dst #ok ) + 3 pick swap - ( adr len src dst len ) + move ( adr len ) + 2- ( adr len' ) + then + loop +; + +also urls definitions + +: stop ( opt$ url$ -- httpd-stuff ) + " abort" to pending-cmd + " Closing remote HTTP server" 1 " text/plain" +; +: reboot ( opt$ url$ -- httpd-stuff ) + " bye" to pending-cmd + " Rebooting remote system" 1 " text/plain" +; + +\ This is really demo code, not ready for primetime. We deal with some +\ special cases with this code example. If a URL comes in as +\ "rom-setconfig-tf", then we go look for some other stuff in the +\ incomming request packet, reformat the whole wad into a "setenv" +\ command and execute it. This "-tf" method looks at the first +\ character of the incoming set string for "t" or "f" and then creates +\ its own "true" or "false" to pass to the setenv command. Helps with +\ people that can't spell. The second special is really a more general +\ case inplementaion. rom-setconfig-string parses out the string that +\ is passed in and sets the environment variable accordingly. Just +\ another way to do it. Demo code after all. If the request URL has +\ "rom-ok" in it, we treat the passed in data as a string that we just +\ pass to the "ok" prompt, returning whatever we get back. Any other +\ request that is prefeaced by "rom-" is assumed to be a method call, so +\ we go look for an XT, then execute it, returning the data. Thus +\ showing four possibilities of how one might interface to the ROM via +\ HTTP. + +: rom-setconfig-tf ( opt$ url$ -- httpd-stuff ) + \ OK, the option string will have what we need in it. We need to + \ extract what we need from it, run the setenv command and return + \ something nice to the user... + 2drop + hbuf swap move ( ) \ Re-use the hbuf XXX this is bad. + reset-hbuf-ptr + [char] = skip-til hbuf-adr ( adr ) + [char] & skip-til hbuf-adr over - 1- ( var$ ) + fixup-string ( var$' ) + [char] = skip-til ( var$' adr ) + hbuf-adr c@ ascii t = if + " true" else " false" ( var$' val$ ) + then + 2swap 4dup ( val$ var$' val$ var$' ) + collect( $setenv )collect ( val$ var$' adr len ) + 2drop ( val$ var$' ) + nice-message 1 " text/html" +; + +: rom-setconfig-string ( opt$ url$ -- httpd-stuff ) + \ OK, the option string will have what we need in it. We need to + \ extract what we need from it, run the setenv command and return + \ something nice to the user... + 2drop + hbuf swap dup >r move ( ) \ Re-use the hbuf + reset-hbuf-ptr + [char] = skip-til hbuf-adr ( adr ) + [char] & skip-til hbuf-adr over - 1- ( var$ ) + fixup-string ( var$' ) + [char] = skip-til ( var$' ) + hbuf-adr ( var$ val-adr ) + hbuf - ( var$ count ) + hbuf r> ( var$ count adr len ) + rot /string ( var$ val$ ) + fixup-string ( var$ val$ ) + 2swap 4dup ( val$ var$' val$ var$' ) + collect( $setenv )collect ( val$ var$' adr len ) + 2drop ( val$ var$' ) + nice-message 1 " text/html" +; + +: rom-setdefault ( opt$ url$ -- httpd-stuff ) + \ OK, the option string will have what we need in it. We need to + \ extract what we need from it, run the set-default command and return + \ something nice to the user... + 2drop + hbuf swap dup >r move ( ) \ Re-use the hbuf + reset-hbuf-ptr + [char] = skip-til hbuf-adr ( adr ) + hbuf - hbuf r> rot /string ( var$ ) + fixup-string 2dup ( var$' var$' ) + collect( + create-header + create-pre + find-option if do-set-default then + (printenv) + create-endpre + create-footer + )collect ( adr len ) + 1 " text/html" +; + +: rom-restart ( opt$ url$ -- ) + \ rom-restart?option_file=url&var=value + 2drop + hbuf swap dup >r move ( ) \ Re-use the hbuf + reset-hbuf-ptr + [char] = skip-til hbuf-adr ( adr ) + [char] & skip-til hbuf-adr over - 1- ( url$ ) + fixup-string ( url$' ) + + 2dup find-drop-in if ( url$ data$ ) + 2over 2>r ( url$ data$ ) ( R: url$ ) + preprocess-html ( data$' n ) + 2r> presume-content-type ( data$ n type$ ) + respond ( ) + transaction-done ( ) + else ( url$ ) + 2drop + then + + hbuf-adr [char] = skip-til ( var ) + hbuf-adr over - 1- ( var$ ) + + hbuf-adr ( var$ val-adr ) + hbuf - ( var$ count ) + hbuf r> ( var$ count adr len ) + rot /string ( var$ val$ ) + fixup-string 2swap ( val$' var$ ) + collect( $setenv )collect 2drop ( ) + + reset-all +; + +\ command?here+.+cr plusses become blanks +\ command?4+5+%2b+.+cr use %2b to get a plus +\ note: the web page encodes the command string before sending it +\ and sends command?command=here+.+cr +: cmdeq ( -- $ ) " command=" ; +: command ( opt$ url$ -- httpd-stuff ) + 2drop + cmdeq 2over sindex 0= if + cmdeq nip /string + then + fixup-string ['] eval collect-data 1 " text/html" +; + +previous definitions +\ LICENSE_BEGIN +\ Copyright (c) 2006 FirmWorks +\ +\ Permission is hereby granted, free of charge, to any person obtaining +\ a copy of this software and associated documentation files (the +\ "Software"), to deal in the Software without restriction, including +\ without limitation the rights to use, copy, modify, merge, publish, +\ distribute, sublicense, and/or sell copies of the Software, and to +\ permit persons to whom the Software is furnished to do so, subject to +\ the following conditions: +\ +\ The above copyright notice and this permission notice shall be +\ included in all copies or substantial portions of the Software. +\ +\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +\ +\ LICENSE_END
Added: ofw/inetv6/icmpecho.fth =================================================================== --- ofw/inetv6/icmpecho.fth (rev 0) +++ ofw/inetv6/icmpecho.fth 2007-08-02 21:37:59 UTC (rev 518) @@ -0,0 +1,70 @@ +\ See license at end of file +purpose: Internet Control Message Protocol version 6 (ICMPv6) echo message handlers + +: exchange-byte ( adr1 adr2 -- ) + over c@ over c@ ( adr1 adr2 byte1 byte2 ) + swap rot ( adr1 byte2 byte1 adr2 ) + c! ( adr1 byte2 ) + swap c! ( ) +; +: exchange-bytes ( adr1 adr2 len -- ) + 0 ?do over i + over i + exchange-byte loop 2drop +; +: exchange-mac ( adr len -- ) + drop dup /e + /e exchange-bytes +; +: exchange-ipsv6 ( adr len -- ) drop 8 + dup /ipv6 + /ipv6 exchange-bytes ; +: change-typev6 ( adr len -- ) drop d# 129 swap xc! ; + +: recompute-icmpv6-checksum ( icmp-adr,len ip-adr,len -- ) + 2swap dup 1 and if ( ip-adr,len icmp-adr,len ) + 2dup + 0 swap c! 1+ ( ip-adr,len icmp-adr,len' ) + then ( ip-adr,len icmp-adr,len' ) + 2swap drop 8 + dup /ipv6 + ( icmp-adr,len ipv6-1 ipv6-2 ) + compute-icmpv6-checksum ( ) +; + +: handle-echo-req ( icmp-adr,len -- ) + \ XXX For now, support simplistic IPv6 header + ICMPv6 echo packet. + 2dup /ipv6-header negate /string ( icmp-adr,len ip-adr,len ) + 2dup /ether-header negate /string ( icmp-adr,len ip-adr,len en-adr,len ) + bootnet-debug if + ." Echo request from: " over /e + .enaddr cr + then + 2dup exchange-mac -drot ( en-adr,len icmp-adr,len ip-adr,len ) + 2dup exchange-ipsv6 ( en-adr,len icmp-adr,len ip-adr,len ) + 2over change-typev6 ( en-adr,len icmp-adr,len ip-adr,len ) + recompute-icmpv6-checksum ( en-adr,len ) + tuck " write" $call-parent ( len actual ) + <> if ." Network transmit error" cr then +; + +: handle-echo-reply ( adr len -- ) 2drop ; + +headers + +\ LICENSE_BEGIN +\ Copyright (c) 2006 FirmWorks +\ +\ Permission is hereby granted, free of charge, to any person obtaining +\ a copy of this software and associated documentation files (the +\ "Software"), to deal in the Software without restriction, including +\ without limitation the rights to use, copy, modify, merge, publish, +\ distribute, sublicense, and/or sell copies of the Software, and to +\ permit persons to whom the Software is furnished to do so, subject to +\ the following conditions: +\ +\ The above copyright notice and this permission notice shall be +\ included in all copies or substantial portions of the Software. +\ +\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +\ +\ LICENSE_END + +
Added: ofw/inetv6/icmperr.fth =================================================================== --- ofw/inetv6/icmperr.fth (rev 0) +++ ofw/inetv6/icmperr.fth 2007-08-02 21:37:59 UTC (rev 518) @@ -0,0 +1,89 @@ +\ See license at end of file +purpose: Internet Control Message Protocol version 6 (ICMPv6) error message handlers + +: .icmpv6-unknown-err ( type -- ) + ." Unknown error message type: " u. +; + +: .icmpv6-dest-err ( -- ) + icmp-code c@ case + 0 of ." No route to destination" endof + 1 of ." Communication with destination administratively prohibited" endof + 2 of ." Beyond scope of source address" endof + 3 of ." Address unreachable" endof + 4 of ." Port unreachable" endof + 5 of ." Source address failed ingress/egress policy" endof + 6 of ." Eject route to destination" endof + ( default ) ." Unknown destination unreachable code: " dup u. + endcase +; + +: .icmpv6-size-err ( -- ) + ." Packet too big. MTU of next hop link is: " icmp-mtu xl@ u. +; + +: .icmpv6-time-err ( -- ) + icmp-code c@ case + 0 of ." Hop limit exceeded in transit" endof + 1 of ." Fragment reassembly time exceeded" endof + ( default ) ." Unknown time exceeded code: " dup u. + endcase +; + +: .icmpv6-arg-err ( -- ) + icmp-code c@ case + 0 of ." Erroneous header field encountered" endof + 1 of ." Unrecognized next header type encountered" endof + 2 of ." Unrecognized IPv6 option encountered" endof + ( default ) ." Unkown parameter problem code: " dup u. + endcase +; + +: .icmpv6-err ( -- ) + ." ICMPv6: " + icmp-type c@ + case + 1 of .icmpv6-dest-err endof + 2 of .icmpv6-size-err endof + 3 of .icmpv6-time-err endof + 4 of .icmpv6-arg-err endof + ( default ) .icmpv6-unknown-err + endcase + cr +; + +: handle-icmpv6-err ( adr len -- ) + over set-struct ( adr len ) + .icmpv6-err ( adr len ) + icmp-code c@ -rot ( code adr len ) + icmp-type c@ -rot ( code type adr len ) + icmpv6-err-callback-xt execute +; + +headers + +\ LICENSE_BEGIN +\ Copyright (c) 2006 FirmWorks +\ +\ Permission is hereby granted, free of charge, to any person obtaining +\ a copy of this software and associated documentation files (the +\ "Software"), to deal in the Software without restriction, including +\ without limitation the rights to use, copy, modify, merge, publish, +\ distribute, sublicense, and/or sell copies of the Software, and to +\ permit persons to whom the Software is furnished to do so, subject to +\ the following conditions: +\ +\ The above copyright notice and this permission notice shall be +\ included in all copies or substantial portions of the Software. +\ +\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +\ +\ LICENSE_END + +
Added: ofw/inetv6/icmpinfo.fth =================================================================== --- ofw/inetv6/icmpinfo.fth (rev 0) +++ ofw/inetv6/icmpinfo.fth 2007-08-02 21:37:59 UTC (rev 518) @@ -0,0 +1,109 @@ +\ See license at end of file +purpose: Internet Control Message Protocol version 6 (ICMPv6) info message handlers + +\ ************************* Multicast Group Management ************************* +: handle-mc-query ( adr len -- ) 2drop ; \ Multicast listener query +: handle-mc-report ( adr len -- ) 2drop ; \ Multicast listener report +: handle-mc-report2 ( adr len -- ) 2drop ; \ Version 2 multicast listener report +: handle-mc-done ( adr len -- ) 2drop ; \ Multicast done + +\ ****************** Neighbor Discovery and Autoconfiguration ****************** +: handle-router-sol ( adr len -- ) 2drop ; \ Router solicitation +: handle-router-ad ( adr len -- ) 2drop ; \ Router advertisement + +: handle-mc-router-ad ( adr len -- ) 2drop ; \ Multicast router advertisement +: handle-mc-router-sol ( adr len -- ) 2drop ; \ Multicast router solicitation +: handle-mc-router-term ( adr len -- ) 2drop ; \ Multicast router termination + +: send-neigh-sol ( -- ) + d# 24 allocate-icmpv6 set-struct \ Dest IPv6 + one option + d# 135 icmp-type xc! + 0 icmp-code xc! + 0 icmp-flags xl! + his-ipv6-addr icmp-data copy-ipv6-addr + h# 101 icmp-data /ipv6 + xw! \ Option type 1 (source mac addr) + \ Length (in 8 octels) + my-en-addr icmp-data /ipv6 + 2 + copy-ipv6-addr + hop-limit >r h# ff to hop-limit \ Save and change hop-limit + the-struct d# 24 2dup send-mc-icmpv6-packet + free-icmpv6 + r> to hop-limit \ Restore hop-limit +; + +: send-neigh-ad ( solicited? -- ) + d# 24 allocate-icmpv6 set-struct \ Dest IPv6 + one option + + d# 136 icmp-type xc! + 0 icmp-code xc! + h# 40 and h# 20 or icmp-flags xl! \ Flags = (un)solicited, override + my-ipv6-addr icmp-data copy-ipv6-addr + h# 201 icmp-data /ipv6 + xw! \ Option type 2 (target mac addr) + \ Length (in 8 octels) + my-en-addr icmp-data /ipv6 + 2 + copy-ipv6-addr + + hop-limit >r h# ff to hop-limit \ Save and change hop-limit + the-struct d# 24 2dup send-icmpv6-packet + free-icmpv6 + r> to hop-limit \ Restore hop-limit +; + +: handle-neigh-sol ( adr len -- ) \ Neighbor solicitation + \ XXX Verify hop limit is 255. + dup d# 24 < if 2drop exit then + bootnet-debug if + ." Neighbor solicitation from MAC: " over d# 26 + .enaddr cr + then + over /icmp-header + my-ipv6-addr ipv6= not if ." Not for me" cr 2drop exit then + 2drop + \ XXX Send Neighbor Advertisement + true send-neigh-ad +; + +: handle-neigh-ad ( adr len -- ) 2drop ; \ Neighbor advertisement + +: handle-inv-neigh-sol ( adr len -- ) 2drop ; \ Inverse neighbor discovery solicitation +: handle-inv-neigh-ad ( adr len -- ) 2drop ; \ Inverse neighbor discovery advertisement + +: handle-redirect-msg ( adr len -- ) 2drop ; \ Redirect message + +: handle-cert-sol ( adr len -- ) 2drop ; \ Certification path solicitation +: handle-cert-ad ( adr len -- ) 2drop ; \ Certification path advertisement + +: handle-router-renum ( adr len -- ) 2drop ; \ Router renumbering + +: handle-info-query ( adr len -- ) 2drop ; \ ICMP node information query +: handle-info ( adr len -- ) 2drop ; \ ICMP node information response + +\ ******************************** Mobile IPv6 ********************************* +: handle-ha-request ( adr len -- ) 2drop ; \ ICMP home agent address discovery request +: handle-ha-reply ( adr len -- ) 2drop ; \ ICMP home agent address discovery reply +: handle-mobile-sol ( adr len -- ) 2drop ; \ ICMP mobile prefix solicitation +: handle-mobile-ad ( adr len -- ) 2drop ; \ ICMP mobile prefix advertisement + +headers + +\ LICENSE_BEGIN +\ Copyright (c) 2006 FirmWorks +\ +\ Permission is hereby granted, free of charge, to any person obtaining +\ a copy of this software and associated documentation files (the +\ "Software"), to deal in the Software without restriction, including +\ without limitation the rights to use, copy, modify, merge, publish, +\ distribute, sublicense, and/or sell copies of the Software, and to +\ permit persons to whom the Software is furnished to do so, subject to +\ the following conditions: +\ +\ The above copyright notice and this permission notice shall be +\ included in all copies or substantial portions of the Software. +\ +\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +\ +\ LICENSE_END + +
Added: ofw/inetv6/icmpv6.fth =================================================================== --- ofw/inetv6/icmpv6.fth (rev 0) +++ ofw/inetv6/icmpv6.fth 2007-08-02 21:37:59 UTC (rev 518) @@ -0,0 +1,136 @@ +\ See license at end of file +purpose: Internet Control Message Protocol version 6 (ICMPv6) + +' 4drop instance value icmpv6-err-callback-xt ( code type adr len -- ) +' 2drop instance value icmpv6-info-callback-xt ( adr len -- ) +: set-icmpv6-err-callback ( xt -- ) to icmpv6-err-callback-xt ; +: set-icmpv6-info-callback ( xt -- ) to icmpv6-info-callback-xt ; + +struct ( ICMP ) + /c sfield icmp-type + /c sfield icmp-code + /w sfield icmp-checksum + 0 sfield icmp-flags + 0 sfield icmp-mtu + /w sfield icmp-id + /w sfield icmp-seq + 0 sfield icmp-data +constant /icmp-header + +0 instance value icmpv6-packet +0 instance value /icmpv6-packet + +: allocate-icmpv6 ( len -- adr ) /icmp-header + allocate-ipv6 ; +: free-icmpv6 ( adr len -- ) /icmp-header + free-ipv6 ; + +variable icmp-temp +: pseudo-hdr-checksum ( len ipv6-1 ipv6-2 -- chksum ) + 0 swap /ipv6 (oc-checksum) ( len ipv6-1 chksum ) + swap /ipv6 (oc-checksum) ( len chksum' ) + swap icmp-temp be-l! ( chksum ) + icmp-temp /l (oc-checksum) ( chksum' ) + IP_HDR_ICMPV6 icmp-temp be-l! ( chksum ) + icmp-temp /l (oc-checksum) ( chksum' ) +; + +: compute-icmpv6-checksum ( adr len ipv6-1 ipv6-2 -- ) + 2>r dup 2r> ( adr len len ipv6-1 ipv6-2 ) + pseudo-hdr-checksum >r ( adr len ) ( R: chksum ) + over set-struct ( adr len ) ( R: chksum ) + 0 icmp-checksum be-w! ( adr len ) ( R: chksum ) \ Zap ICMP checksum + r> -rot oc-checksum ( sum ) + icmp-checksum be-w! ( ) +; + +: send-icmpv6-packet ( adr len -- ) \ len = length of ICMP data (does not include header) + /icmp-header + 2dup his-ipv6-addr my-ipv6-addr compute-icmpv6-checksum + IP_HDR_ICMPV6 send-ipv6-packet +; + +/ipv6 buffer: his-ipv6-temp +: send-mc-icmpv6-packet ( adr len -- ) \ Send to his multicast IPv6 address + his-ipv6-addr his-ipv6-temp copy-ipv6-addr + his-mc-ipv6-addr his-ipv6-addr copy-ipv6-addr + send-icmpv6-packet + his-ipv6-temp his-ipv6-addr copy-ipv6-addr +; + +\ ICMPv6 error handlers (icmp-type: 0-127) +fload ${BP}/ofw/inetv6/icmperr.fth \ Error handling routines + +\ ICMPv6 info handlers (icmp-type: 128-255) +fload ${BP}/ofw/inetv6/icmpecho.fth \ Echo handling routines +fload ${BP}/ofw/inetv6/icmpinfo.fth \ Other info message handling routines + +decimal +: handle-icmpv6-info ( adr len -- ) + over c@ case + 128 of handle-echo-req endof \ Echo request + 129 of handle-echo-reply endof \ Echo reply + 130 of handle-mc-query endof \ Multicast listener query + 131 of handle-mc-report endof \ Multicast listener report + 132 of handle-mc-done endof \ Multicast done + 133 of handle-router-sol endof \ Router solicitation + 134 of handle-router-ad endof \ Router advertisement + 135 of handle-neigh-sol endof \ Neighbor solicitation + 136 of handle-neigh-ad endof \ Neighbor advertisement + 137 of handle-redirect-msg endof \ Redirect message + 138 of handle-router-renum endof \ Router renumbering + 139 of handle-info-query endof \ ICMP node information query + 140 of handle-info endof \ ICMP node information response + 141 of handle-inv-neigh-sol endof \ Inverse neighbor discovery solicitation + 142 of handle-inv-neigh-ad endof \ Inverse neighbor discovery advertisement + 143 of handle-mc-report2 endof \ Version 2 multicast listener report + 144 of handle-ha-request endof \ ICMP home agent address discovery request + 145 of handle-ha-reply endof \ ICMP home agent address discovery reply + 146 of handle-mobile-sol endof \ ICMP mobile prefix solicitation + 147 of handle-mobile-ad endof \ ICMP mobile prefix advertisement + 148 of handle-cert-sol endof \ Certification path solicitation + 149 of handle-cert-ad endof \ Certification path advertisement + 151 of handle-mc-router-ad endof \ Multicast router advertisement + 152 of handle-mc-router-sol endof \ Multicast router solicitation + 153 of handle-mc-router-term endof \ Multicast router termination + ( default ) nip nip + endcase +; + +hex + +: (handle-icmpv6) ( adr len protocol -- ) + IP_HDR_ICMPV6 <> if 2drop exit then \ Not an ICMPv6 packet + dup if \ Nonzero length + \ XXX verify checksum + the-struct >r \ Save the-struct + over c@ h# 80 and if handle-icmpv6-info else handle-icmpv6-err then + r> set-struct \ Restore the-struct + else + 2drop + then +; +' (handle-icmpv6) to handle-icmpv6 + +headers + +\ LICENSE_BEGIN +\ Copyright (c) 2006 FirmWorks +\ +\ Permission is hereby granted, free of charge, to any person obtaining +\ a copy of this software and associated documentation files (the +\ "Software"), to deal in the Software without restriction, including +\ without limitation the rights to use, copy, modify, merge, publish, +\ distribute, sublicense, and/or sell copies of the Software, and to +\ permit persons to whom the Software is furnished to do so, subject to +\ the following conditions: +\ +\ The above copyright notice and this permission notice shall be +\ included in all copies or substantial portions of the Software. +\ +\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +\ +\ LICENSE_END
Added: ofw/inetv6/ip.fth =================================================================== --- ofw/inetv6/ip.fth (rev 0) +++ ofw/inetv6/ip.fth 2007-08-02 21:37:59 UTC (rev 518) @@ -0,0 +1,234 @@ +\ See license at end of file +purpose: Simple Internet Protocol (IP) implementation + + +\ Internet protocol (IP). + +decimal + +4 constant /i \ Bytes per IP address + +: copy-ip-addr ( src dst -- ) /i move ; + +/i buffer: my-ip-addr +/i buffer: subnetmask + +headerless +\ Give the net up to 4 seconds to respond to packets +instance variable timeout-msecs d# 4000 timeout-msecs ! + +struct ( ip-header ) + 1 sfield ip-version \ Actually, this is VVVVLLLL, where LLLL is the + \ header length in 32-bit words. + 1 sfield ip-service + 2 sfield ip-length + 2 sfield ip-id + 2 sfield ip-fragment + 1 sfield ip-ttl + 1 sfield ip-protocol + 2 sfield ip-checksum + /i sfield ip-source-addr + /i sfield ip-dest-addr +\ It is possible to have a variable-length list of options here at the end. +\ Options contain information like source routing lists, return route lists, +\ and error reports. The low nibble of the ip-version byte gives the length +\ of the header including the options. +constant /ip-header + +\ These things hardly ever change, so we make them variables +instance variable ttl d# 123 ttl ! +instance variable ip-sequence +d# 256 buffer: 'domain-name +headers +/i buffer: his-ip-addr +/i buffer: name-server-ip +' 'domain-name " domain-name" chosen-string + +headerless + +decimal +h# 800 constant IP_TYPE + +instance variable total-length + +instance variable bufptr +: -buf, ( c -- ) -1 bufptr +! bufptr @ c! ; + +/i buffer: broadcast-ip-addr + +create def-broadcast-ip h# ff c, h# ff c, h# ff c, h# ff c, +create unknown-ip-addr h# 00 c, h# 00 c, h# 00 c, h# 00 c, + +: ip= ( ip-addr1 ip-addr2 -- flag ) /i comp 0= ; + +: unknown-ip-addr? ( adr-buf -- flag ) unknown-ip-addr ip= ; +: known? ( adr-buf -- flag ) unknown-ip-addr? 0= ; + +\ Offsets 0,1,2 into this array yield default netmasks for classes C,B,A +create default-netmasks d# 255 c, d# 255 c, d# 255 c, 0 c, 0 c, 0 c, + +: default-netmask ( -- 'netmask ) + default-netmasks ( 'netmask-c ) + my-ip-addr known? if ( 'netmask-c ) + my-ip-addr c@ h# 80 and 0= if 2+ exit then ( 'netmask-c ) + my-ip-addr c@ h# 40 and 0= if 1+ exit then ( 'netmask-c ) + then ( 'netmask-c ) +; + +\ either h# ffffffff or h# 0 is broadcast ip addr +: broadcast-ip-addr? ( adr-buf -- flag ) + dup broadcast-ip-addr ip= swap unknown-ip-addr? or +; + +: netmask ( -- 'ip ) + subnetmask unknown-ip-addr? if default-netmask else subnetmask then +; +[ifndef] c@+ +: 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