Artifact 4a5df34002c0725f7d1e1739799d95b5f6870125:
- File socks.fs — part of check-in [856357a817] at 2019-07-08 18:32:39 on branch trunk — Fix problem with insert-address (user: bernd size: 7994)
\ 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]