net2o-socks.fs 6.59 KB
Newer Older
bernd's avatar
bernd committed
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38
\ 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
39
#999999999 Value poll-timeout# \ 1s, don't sleep too long
bernd's avatar
bernd committed
40 41 42 43 44 45
poll-timeout# 0 ptimeout 2!

User socktimeout cell uallot drop

: sock-timeout! ( socket -- )  fileno
    socktimeout 2@
bernd's avatar
bernd committed
46
    ptimeout 2@ >r #1000 / r> 2dup socktimeout 2! d<> IF
bernd's avatar
bernd committed
47 48 49 50 51 52 53 54 55 56 57
	SOL_SOCKET SO_RCVTIMEO socktimeout 2 cells setsockopt THEN
    drop ;

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

: 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
bernd's avatar
bernd committed
58 59
	errno dup EAGAIN =  IF  2drop #0. EXIT  THEN
	#512 + negate throw  THEN
bernd's avatar
bernd committed
60 61 62 63 64 65 66 67 68 69
    inbuf swap  1 packetr +!
    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
bernd's avatar
bernd committed
70
	    errno dup EAGAIN =  IF  2drop #0. EXIT  THEN
bernd's avatar
bernd committed
71 72 73 74 75 76 77 78 79
	THEN
	inbuf swap  1 packetr +!
	recvfrom( ." received from: " sockaddr alen @ .address space dup . cr )
    ;
[THEN]

$00000000 Value droprate#

: %droprate ( -- )
bernd's avatar
bernd committed
80
    ?peekarg 0= IF  EXIT  THEN
bernd's avatar
bernd committed
81
    + 1- c@ '%' <> ?EXIT
bernd's avatar
bernd committed
82
    ?nextarg drop prefix-number IF
bernd's avatar
bernd committed
83 84 85
	1e fmin 0e fmax $FFFFFFFF fm* f>s to droprate#
	." Set drop rate to " droprate# s>f 42949672.96e f/ f. ." %" cr
    THEN ;
bernd's avatar
bernd committed
86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125

: send-a-packet ( addr u -- n ) +calc
    droprate# IF  rng32 droprate# u< IF
	    resend( ." dropping packet" cr )
	    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 -- addr' u' )
    drop >r
    r@ port be-uw@ sockaddr port be-w!
    r> sin_addr be-ul@ sockaddr ipv4!
    sockaddr sock-rest ;
: ?>ipv6 ( addr u -- addr' u' )
    over family w@ AF_INET = IF  ipv4>ipv6  THEN ;
: info@ ( info -- addr u )
    dup ai_addr @ swap ai_addrlen l@ ;
: info>string ( info -- addr u )
    info@ ?>ipv6 ;

0 Value lastaddr
Variable lastn2oaddr

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

bernd's avatar
bernd committed
126
: dns>string ( addr u port hint -- net2o-addr )
bernd's avatar
bernd committed
127
    >r SOCK_DGRAM >hints r> hints ai_family l!
bernd's avatar
bernd committed
128 129 130 131
    get-info info>string ;

: insert-ip* ( addr u port hint -- net2o-addr )
    dns>string insert-address ;
bernd's avatar
bernd committed
132

bernd's avatar
bernd committed
133
: insert-ip ( addr u port -- net2o-addr )  0         insert-ip* ;
bernd's avatar
bernd committed
134 135 136 137 138
: insert-ip4 ( addr u port -- net2o-addr ) PF_INET   insert-ip* ;
: insert-ip6 ( addr u port -- net2o-addr ) PF_INET6  insert-ip* ;

: address>route ( -- n/-1 )
    sockaddr alen @ insert-address ;
bernd's avatar
bernd committed
139 140 141
: route>address ( n -- flag )
    routes #.key dup 0= ?EXIT
    $@ sockaddr swap dup alen ! move true ;
bernd's avatar
bernd committed
142 143 144 145

\ route an incoming packet

: >rpath-len ( rpath -- rpath len )
bernd's avatar
bernd committed
146
    dup 0= IF  0  EXIT  THEN
bernd's avatar
bernd committed
147
    [IFDEF] 64bit
bernd's avatar
bernd committed
148 149
	dup $100000000 u< IF
	    dup $10000 u< IF
bernd's avatar
bernd committed
150
		dup $100 u< 2 +  EXIT
bernd's avatar
bernd committed
151
	    ELSE
bernd's avatar
bernd committed
152
		dup $1000000 u< 4 + EXIT
bernd's avatar
bernd committed
153 154 155
	    THEN
	ELSE
	    dup $1000000000000 u< IF
bernd's avatar
bernd committed
156
		dup $10000000000 u< 6 +  EXIT
bernd's avatar
bernd committed
157
	    ELSE
bernd's avatar
bernd committed
158
		dup $100000000000000 u< 8 +  EXIT
bernd's avatar
bernd committed
159 160
	    THEN
	THEN
bernd's avatar
bernd committed
161
    [ELSE]
bernd's avatar
bernd committed
162
	dup $10000 u< IF
bernd's avatar
bernd committed
163
	    dup $100 u< 2 +  EXIT
bernd's avatar
bernd committed
164
	ELSE
bernd's avatar
bernd committed
165
	    dup $1000000 u< 4 + EXIT
bernd's avatar
bernd committed
166
	THEN
bernd's avatar
bernd committed
167 168 169 170
    [THEN] ;
: >path-len ( path -- path len )
    dup 0= IF  0  EXIT  THEN
    [IFDEF] 64bit
bernd's avatar
bernd committed
171 172
	dup     $00000000FFFFFFFF and IF
	    dup $000000000000FFFF and IF
bernd's avatar
bernd committed
173
		dup $00000000000000FF and 0= 8 +  EXIT
bernd's avatar
bernd committed
174
	    ELSE
bernd's avatar
bernd committed
175
		dup $0000000000FFFFFF and 0= 6 +  EXIT
bernd's avatar
bernd committed
176 177 178
	    THEN
	ELSE
	    dup $0000FFFFFFFFFFFF and IF
bernd's avatar
bernd committed
179
		dup $000000FFFFFFFFFF and 0= 4 +  EXIT
bernd's avatar
bernd committed
180
	    ELSE
bernd's avatar
bernd committed
181
		dup $00FFFFFFFFFFFFFF and 0= 2 +  EXIT
bernd's avatar
bernd committed
182 183
	    THEN
	THEN
bernd's avatar
bernd committed
184
    [ELSE]
bernd's avatar
bernd committed
185 186 187 188 189
	dup     $0000FFFF and IF
	    dup $000000FF and 0= 4 +  EXIT
	ELSE
	    dup $00FFFFFF and 0= 2 +  EXIT
	THEN
bernd's avatar
bernd committed
190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206
    [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 -
bernd's avatar
bernd committed
207
    2dup pathc+ { addr1 u1 addr2 u2 } \ better use locals here
bernd's avatar
bernd committed
208 209 210 211 212 213 214 215
    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
bernd's avatar
bernd committed
216 217
	>r r@ get-dest  route>address  IF  r@ ins-source  THEN
	rdrop false  EXIT  THEN
bernd's avatar
bernd committed
218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237
    2drop true ; \ local packet

: in-check ( -- flag )  address>route -1 <> ;
: out-route ( -- )  0 outbuf packet-route drop ;

0 [IF]
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]