Artifact Content
Not logged in
Home Timeline Files Branches Tags Tickets Wiki Login Impressum Datenschutzerklärung
Check-ins Using Download Hex

Artifact 4a5df34002c0725f7d1e1739799d95b5f6870125:

\ net2o template for new files

\ Copyright (C) 2015   Bernd Paysan

\ This program is free software: you can redistribute it and/or modify
\ it under the terms of the GNU Affero General Public License as published by
\ the Free Software Foundation, either version 3 of the License, or
\ (at your option) any later version.

\ This program is distributed in the hope that it will be useful,
\ but WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
\ GNU Affero General Public License for more details.

\ You should have received a copy of the GNU Affero General Public License
\ along with this program.  If not, see <http://www.gnu.org/licenses/>.

\ generic hooks and user variables

Variable packetr
Variable packets
Variable packetr2 \ double received
Variable packets2 \ double send

: .packets ( -- )
    ." IP packets send/received: " packets ? ." (" packets2 ? ." dupes)/"
    packetr ? ." (" packetr2 ? ." dupes) " cr
    packets off packetr off packets2 off packetr2 off ;

UValue pollfd#  0 to pollfd#

: prep-socks ( -- )
    epiper @ fileno POLLIN  pollfds fds!+ >r
    net2o-sock [IFDEF] no-hybrid swap [THEN] POLLIN  r> fds!+
    [IFDEF] no-hybrid POLLIN swap fds!+ [THEN]
    pollfds - pollfd / to pollfd# ;

User ptimeout  cell uallot drop
#999999999 Value poll-timeout# \ 1s, don't sleep too long
poll-timeout# 0 ptimeout 2!

User socktimeout cell uallot drop

: sock-timeout! ( socket -- )  fileno
    socktimeout 2@
    ptimeout 2@ >r #1000 / r> 2dup socktimeout 2! d<> IF
	SOL_SOCKET SO_RCVTIMEO socktimeout 2 cells setsockopt THEN
    drop ;

0             Constant do-block
MSG_DONTWAIT  Constant don't-block

$00000000 Value rec-droprate#

: ?drop-inc ( addr u -- addr u / 0 0 )
    rec-droprate# IF  rng32 rec-droprate# u< IF
	    resend( ." dropping incoming packet" cr )
	    2drop #0.  THEN  THEN ;

: read-a-packet ( blockage -- addr u / 0 0 )
    >r sockaddr_in alen !
    net2o-sock [IFDEF] no-hybrid drop [THEN]
    inbuf maxpacket r> sockaddr< alen recvfrom
    dup 0< IF
	errno dup EAGAIN =  IF  2drop #0. EXIT  THEN
	#512 + negate throw  THEN
    inbuf swap  1 packetr +!  ?drop-inc
    recvfrom( ." received from: " sockaddr< alen @ .address space dup . cr )
;

[IFDEF] no-hybrid
    : read-a-packet4 ( blockage -- addr u / 0 0 )
	>r sockaddr_in alen !
	net2o-sock nip
	inbuf maxpacket r> sockaddr< alen recvfrom
	dup 0< IF
	    errno dup EAGAIN =  IF  2drop #0. EXIT  THEN
	THEN
	inbuf swap  1 packetr +!  ?drop-inc
	recvfrom( ." received from: " sockaddr< alen @ .address space dup . cr )
    ;
[THEN]

$00000000 Value droprate#

: %droprate ( -- )
    ?peekarg 0= IF  EXIT  THEN
    + 1- c@ '%' <> ?EXIT
    ?nextarg drop prefix-number IF
	4 set-precision
	1e fmin -1e fmax $FFFFFFFF fm* f>d
	0< IF  negate to rec-droprate#
	    [: ." Set rec drop rate to "
	      rec-droprate# s>f 42949672.96e f/ f. ." %" cr ;] do-debug
	ELSE
	    to droprate#
	    [: ." Set drop rate to "
	      droprate# s>f 42949672.96e f/ f. ." %" cr ;] do-debug
	THEN
    THEN ;

: send-a-packet ( addr u -- n ) +calc
    droprate# IF  rng32 droprate# u< IF
	    resend( ." dropping packet" cr )
	    1 packets +! 2drop 0  EXIT  THEN  THEN
    2>r net2o-sock 2r> 0 sockaddr> alen @ sendto +send 1 packets +!
    sendto( ." send to: " sockaddr> alen @ .address space dup . cr ) ;

\ clients routing table

: init-route ( -- )  s" " routes# hash@ $! ; \ field 0 is me, myself

: ipv4>ipv6 ( addr u dest -- addr' u' )
    >r drop
    dup port be-uw@ swap sin_addr be-ul@
    r@ ipv4! r@ port be-w! r> sock-rest ;
: ?>ipv6 ( addr u -- addr' u' )
    over family w@ AF_INET = IF  sockaddr> ipv4>ipv6  THEN ;
: ?<ipv6 ( addr u -- addr' u' )
    over family w@ AF_INET = IF  sockaddr< ipv4>ipv6  THEN ;
: info@ ( info -- addr u )
    dup ai_addr @ swap ai_addrlen l@ ;
: info>string ( info -- addr u )
    info@ ?>ipv6 ;

: -$split ( addr u char -- addr1 u1 addr2 u2 ) \ gforth-string string-split
    \G divides a string into two, with one char as separator (e.g. '?'
    \G for arguments in an HTML query)
    >r 2dup r> -scan dup >r dup IF  1-  THEN
    2swap r> /string ;
: ping ( "addr:port" -- )
    net2o-sock ">" 0
    parse-name ':' -$split s>unumber? 2drop >r
    over c@ '[' = negate /string 2dup + 1- c@ ']' = +
    r> SOCK_DGRAM >hints 0 hints ai_family l!
    get-info dup >r info@ sendto
    r> freeaddrinfo ?ior ;

UValue lastaddr#
User lastn2oaddr

: insert-address ( addr u -- net2o-addr ) ?<ipv6
    address( ." Insert address " 2dup .address cr )
    lastaddr# IF  2dup lastaddr# $@ str=
	IF  2drop lastn2oaddr @ EXIT  THEN
    THEN
    2dup routes# #key dup -1 = IF
	drop s" " 2over routes# #!
	routes# #key
    ELSE
	nip nip
    THEN
    dup lastn2oaddr !
    last# to lastaddr# ;

: dns>string ( addr u port hint -- info net2o-addr u )
    >r SOCK_DGRAM >hints r> hints ai_family l!
    get-info dup info>string ;

: insert-ip* ( addr u port hint -- net2o-addr )
    dns>string rot >r insert-address r> freeaddrinfo ;

: insert-ip ( addr u port -- net2o-addr )  0         insert-ip* ;
: insert-ip4 ( addr u port -- net2o-addr ) PF_INET   insert-ip* ;
: insert-ip6 ( addr u port -- net2o-addr ) PF_INET6  insert-ip* ;

: route>address ( n -- flag )
    routes# #.key dup 0= ?EXIT
    $@ sockaddr> over alen ! sockaddr_in smove true ;

\ query if we have a DNS64 environment

Variable net2o-ipv4 "ipv4.net2o.de" net2o-ipv4 $!

: dns64? ( -- flag )
    net2o-ipv4 $@ net2o-port get-info info@
    sockaddr_in6 = over family w@ AF_INET6 = IF
	sin6_addr $C nat64-ip4 over str=
    ELSE  drop false  THEN ;

\ route an incoming packet

: >rpath-len ( rpath -- rpath len )
    dup 0= IF  0  EXIT  THEN
    [IFDEF] 64bit
	dup $100000000 u< IF
	    dup $10000 u< IF
		dup $100 u< 2 +  EXIT
	    ELSE
		dup $1000000 u< 4 + EXIT
	    THEN
	ELSE
	    dup $1000000000000 u< IF
		dup $10000000000 u< 6 +  EXIT
	    ELSE
		dup $100000000000000 u< 8 +  EXIT
	    THEN
	THEN
    [ELSE]
	dup $10000 u< IF
	    dup $100 u< 2 +  EXIT
	ELSE
	    dup $1000000 u< 4 + EXIT
	THEN
    [THEN] ;
: >path-len ( path -- path len )
    dup 0= IF  0  EXIT  THEN
    [IFDEF] 64bit
	dup     $00000000FFFFFFFF and IF
	    dup $000000000000FFFF and IF
		dup $00000000000000FF and 0= 8 +  EXIT
	    ELSE
		dup $0000000000FFFFFF and 0= 6 +  EXIT
	    THEN
	ELSE
	    dup $0000FFFFFFFFFFFF and IF
		dup $000000FFFFFFFFFF and 0= 4 +  EXIT
	    ELSE
		dup $00FFFFFFFFFFFFFF and 0= 2 +  EXIT
	    THEN
	THEN
    [ELSE]
	dup     $0000FFFF and IF
	    dup $000000FF and 0= 4 +  EXIT
	ELSE
	    dup $00FFFFFF and 0= 2 +  EXIT
	THEN
    [THEN] ;

: <0string ( endaddr -- addr u )
    $11 1 DO  1- dup c@ WHILE  LOOP  $10  ELSE  I  UNLOOP  THEN ;

: ins-source ( addr packet -- )
    destination >r reverse
    dup >rpath-len { w^ rpath rplen } rpath be!
    r@ $10 + <0string
    over rplen - swap move
    rpath cell+ rplen - r> $10 + rplen - rplen move ;
: ins-dest ( n2oaddr destaddr -- )
    >r dup >path-len { w^ path plen } path be!
    r@ cstring>sstring over plen + swap move
    path r> plen move ;
: skip-dest ( addr -- )
    $10 2dup 0 scan nip -
    2dup pathc+ { addr1 u1 addr2 u2 } \ better use locals here
    addr2 addr1 u2 move
    addr1 u1 u2 /string erase ;

: get-dest ( packet -- addr )  destination dup be@ swap skip-dest ;
: route? ( packet -- flag )  destination c@  ;

: packet-route ( orig-addr addr -- flag )
    dup route?  IF
	>r r@ get-dest  route>address  IF  r@ ins-source  ELSE  drop  THEN
	rdrop false  EXIT  THEN
    2drop true ; \ local packet

: out-route ( -- )  0 outbuf packet-route drop ;

\\\
Local Variables:
forth-local-words:
    (
     (("net2o:" "+net2o:") definition-starter (font-lock-keyword-face . 1)
      "[ \t\n]" t name (font-lock-function-name-face . 3))
     ("[a-z0-9]+(" immediate (font-lock-comment-face . 1)
      ")" nil comment (font-lock-comment-face . 1))
    )
forth-local-indent-words:
    (
     (("net2o:" "+net2o:") (0 . 2) (0 . 2) non-immediate)
    )
End:
[THEN]
Fossil 2.9 [c9eb81a550] 2019-08-28 10:41:56