net2o-ip.fs 10.2 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
\ IP address stuff

\ 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/>.

\ IP address stuff

[IFDEF] no-hybrid
    0 0 2Value net2o-sock
[ELSE]
    0 Value net2o-sock
[THEN]
bernd's avatar
bernd committed
25
UValue query-sock
26 27
Variable my-addr[] \ object based hosts
Variable my-addr$ \ string based hosts (with sigs)
bernd's avatar
subme  
bernd committed
28
Variable pub-addr$ \ publicated addresses (with sigs)
29
Variable priv-addr$ \ unpublished addresses (with sigs)
30 31 32 33 34 35

Create fake-ip4  $0000 w, $0000 w, $0000 w, $0000 w, $0000 w, $FFFF w,
\ prefix for IPv4 addresses encoded as IPv6
Create nat64-ip4 $0064 w, $ff9b w, $0000 w, $0000 w, $0000 w, $0000 w,
\ prefix for IPv4 addresses via NAT64

36 37 38
: >alen ( addr u -- alen )
    sockaddr_in6 sockaddr_in4 rot family w@ AF_INET6 = select ;

39 40 41 42 43 44
\ convention:
\ '!' is a key revocation, it contains the new key
\ Tags are kept sorted, so you'll get revocations first, then net2o and IPv6+4
\ Symbolic name may start with '@'+len followed by the name

: default-host ( -- )
45 46 47
    pad $100 gethostname drop pad cstring>sstring config:host$ $!
    config:host$ $@ s" .site" string-suffix? IF
	config:host$ dup $@len 5 - 5 $del
bernd's avatar
bernd committed
48
    THEN
49
    [IFDEF] android 20 [ELSE] 10 [THEN] \ mobile has lower prio
50
    config:prio# ! ;
51 52 53

default-host

54 55
:noname defers 'cold default-host ; is 'cold

56
: .myname ( -- )
57 58
    config:prio# @ IF  '0' emit config:prio# @ emit  THEN
    config:host$ $@len IF  config:host$ $@ dup '@' + emit type  THEN ;
59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104

Create ip6::0 here 16 dup allot erase
: .ip6::0 ( -- )  ip6::0 $10 type ;
: .ip4::0 ( -- )  ip6::0 4 type ;

Create sockaddr" 2 c, $16 allot

: .port ( addr len -- addr' len' )
    ." :" over be-uw@ 0 ['] .r #10 base-execute  2 /string ;
: .net2o ( addr u -- ) dup IF  ." |" xtype  ELSE  2drop  THEN ;
: .ip4b ( addr len -- addr' len' )
    over c@ 0 ['] .r #10 base-execute 1 /string ;
: .ip4a ( addr len -- addr' len' )
    .ip4b ." ." .ip4b ." ." .ip4b ." ." .ip4b ;
: .ip4 ( addr len -- )
    .ip4a .port .net2o ;
User ip6:#
: .ip6w ( addr len -- addr' len' )
    over be-uw@ [: ?dup-IF 0 .r ip6:# off  ELSE  1 ip6:# +! THEN ;] $10 base-execute
    2 /string ;

: .ip6a ( addr len -- addr' len' )
    2dup fake-ip4 12 string-prefix? IF  12 /string .ip4a  EXIT  THEN
    -1 ip6:# !
    '[' 8 0 DO  ip6:# @ 2 < IF  emit  ELSE drop  THEN .ip6w ':'  LOOP
    drop ." ]" ;
: .ip6 ( addr len -- )
    .ip6a .port .net2o ;

: .ip64 ( addr len -- )
    over $10 ip6::0 over str= IF  16 /string  ELSE  .ip6a  THEN
    over   4 ip6::0 over str= IF  4 /string   ELSE  .ip4a  THEN
    .port .net2o ;

: .address ( addr u -- )
    over w@ AF_INET6 =
    IF  drop dup sin6_addr $10 .ip6a 2drop
    ELSE  drop dup sin_addr 4 .ip4a 2drop  THEN
    port 2 .port 2drop ; 

\ NAT traversal stuff: print IP addresses

: skip-symname ( addr u -- addr' u' )
    over c@ '0' = IF  2 safe/string  THEN
    over c@ '?' - 0 max safe/string ;

bernd's avatar
bernd committed
105
Forward .addr$
106

bernd's avatar
bernd committed
107
: .iperr ( addr len -- )
108 109
    connect( [: <info> .time ." connected from: " .addr$ <default> cr ;] $err
    )else( 2drop ) ;
110 111

: ipv4! ( ipv4 sockaddr -- )
112
    ipv6(
113 114 115
    >r    r@ sin6_addr 12 + be-l!
    $FFFF r@ sin6_addr 8 + be-l!
    0     r@ sin6_addr 4 + l!
116 117
    0     r> sin6_addr l!
    )else( sin_addr be-l! ) ;
118 119 120 121 122 123 124 125 126 127 128 129 130 131

: ipv4!nat ( ipv4 sockaddr -- )
    \ nat64 version...
    >r        r@ sin6_addr 12 + be-l!
    0         r@ sin6_addr 8 + l!
    0         r@ sin6_addr 4 + l!
    $0064ff9b r> sin6_addr be-l! ;

: sock-rest ( sockaddr -- addr u ) >r
    AF_INET6 r@ family w!
    0        r@ sin6_flowinfo l!
    0        r@ sin6_scope_id l!
    r> sockaddr_in6 ;

132 133 134 135
: sock-rest4 ( sockaddr -- addr u ) >r
    AF_INET r@ family w!
    r> sockaddr_in4 ;

136
: my-port ( -- port )
137
    ipv6( )else( sockaddr_in4 )else( sockaddr_in6 ) alen !
138 139 140 141
    net2o-sock [IFDEF] no-hybrid drop [THEN] sockaddr1 alen getsockname ?ior
    sockaddr1 port be-uw@ ;

: sock[ ( -- )  query-sock ?EXIT
142 143
    ipv4( ipv6( new-udp-socket46 )else( new-udp-socket ) )else( new-udp-socket6 )
    to query-sock ;
144 145 146 147 148
: ]sock ( -- )  query-sock 0= ?EXIT
    query-sock closesocket 0 to query-sock ?ior ;

: 'sock ( xt -- )  sock[ catch ]sock throw ;

bernd's avatar
bernd committed
149
: fake-ip4? ( addr -- flag ) sin6_addr $C fake-ip4 over str= ;
150
: ?fake-ip4 ( -- addr u )
bernd's avatar
bernd committed
151
    sockaddr1 sin6_addr dup $C fake-ip4 over str= IF  12 + 4  ELSE  $10   THEN ;
152 153 154

29  Constant ESPIPE

155 156 157
: unavail? ( n -- flag )
    0< IF
	errno >r
bernd's avatar
bernd committed
158 159 160 161
	[IFDEF] EPFNOSUPPORT  r@ EPFNOSUPPORT  = [ELSE] 0 [THEN]
	[IFDEF] EAFNOSUPPORT  r@ EAFNOSUPPORT  = or [THEN]
	[IFDEF] EADDRNOTAVAIL r@ EADDRNOTAVAIL = or [THEN]
	[IFDEF] ENETUNREACH   r> ENETUNREACH   = or [ELSE] rdrop [THEN]
162 163 164 165
    ELSE
	false
    THEN ;

166 167 168 169 170 171 172 173
[IFDEF] no-hybrid
    : sock4[ ( -- )  query-sock ?EXIT
	new-udp-socket to query-sock ;
    : ]sock4 ( -- )  query-sock 0= ?EXIT
	query-sock closesocket 0 to query-sock ?ior ;

    : 'sock4 ( xt -- ) sock4[ catch ]sock4 throw ;

174
    : check-ip4 ( ip4addr -- my-ip4addr 4 ) ipv4(
bernd's avatar
bernd committed
175 176 177
	[: sockaddr_in4 alen !  53 sockaddr port be-w!
	  sockaddr sin_addr be-l! query-sock
	  sockaddr sock-rest4 connect
178
	  dup unavail?  IF  drop ip6::0 4  EXIT  THEN  ?ior
179
	  query-sock sockaddr1 alen getsockname
180
	  dup unavail?  IF  drop ip6::0 4  EXIT  THEN  ?ior
181 182
	  sockaddr1 family w@ AF_INET6 =
	  IF  ?fake-ip4  ELSE  sockaddr1 sin_addr 4  THEN
183
	;] 'sock4 )else( 0 ) ;
184
[ELSE]
185 186
    : check-ip4 ( ip4addr -- my-ip4addr 4 ) ipv4(
	[:  ipv6( sockaddr_in6 )else( sockaddr_in4 ) alen !
bernd's avatar
bernd committed
187 188
	    53 sockaddr port be-w!
	    sockaddr ipv4! query-sock
189
	    sockaddr ipv6( sock-rest )else( sock-rest4 ) connect
bernd's avatar
bernd committed
190 191 192 193 194
	    dup unavail?  IF  drop ip6::0 4  EXIT  THEN  ?ior
	    query-sock sockaddr1 alen getsockname
	    dup unavail?  IF  drop ip6::0 4  EXIT  THEN  ?ior
	    sockaddr1 family w@ AF_INET6 =
	    IF  ?fake-ip4  ELSE  sockaddr1 sin_addr 4  THEN
195
	;] 'sock )else( 0 ) ;
196 197 198
[THEN]

$25DDC249 Constant dummy-ipv4 \ this is my net2o ipv4 address
199 200
Create dummy-ipv6 \ this is googles ipv6 address
$2a c, $00 c, $14 c, $50 c, $40 c, $01 c, $08 c, $15 c,
201 202
$0000 w, $0000 w, $0000 w, $00 c, $01 c,
Create local-ipv6
203
$FD c, $00 c, $0000 w, $0000 w, $0000 w, $0000 w, $0000 w, $0000 w, $00 c, $01 c,
204 205 206 207 208 209

0 Value my-port#

: ip6! ( addr1 addr2 -- ) $10 move ;
: ip6? ( addr -- flag )  $10 ip6::0 over str= 0= ;

210
: check-ip6 ( dummy -- ip6addr u ) ipv6(
211 212 213 214
    \G return IPv6 address - if length is 0, not reachable with IPv6
    [:  sockaddr_in6 alen !  53 sockaddr port be-w!
	sockaddr sin6_addr ip6!
	query-sock sockaddr sock-rest connect
215
	dup unavail?  IF  drop ip6::0 $10  EXIT  THEN  ?ior
216
	query-sock sockaddr1 alen getsockname
217
	dup unavail?  IF  drop ip6::0 $10  EXIT  THEN  ?ior
218
	?fake-ip4
219
    ;] 'sock )else( 0 ) ;
220

221
: check-ip64 ( dummy -- ipaddr u ) ipv4(
222
    >r r@ check-ip6 dup IF  rdrop  EXIT  THEN
223
    2drop r> $10 + be-ul@ check-ip4 )else( check-ip6 ) ;
224

bernd's avatar
bernd committed
225 226
: sock-connect? ( addr u -- flag ) query-sock -rot connect 0= ;

bernd's avatar
bernd committed
227
[IFDEF] no-hybrid
bernd's avatar
bernd committed
228 229 230 231 232 233
    : fake6>ip4 ( addr u -- addr u' )
	drop >r
	AF_INET r@ family w!
	r@ sin6_addr $C + l@ r@ sin_addr l!
	r> sockaddr_in4 ;

bernd's avatar
bernd committed
234
    : try-ip ( addr u -- flag )
235
	ipv6(
bernd's avatar
bernd committed
236 237 238
	over fake-ip4? IF
	    fake6>ip4
	    ['] sock-connect? 'sock4
bernd's avatar
bernd committed
239
	ELSE
bernd's avatar
bernd committed
240 241
	    ['] sock-connect? 'sock
	THEN )else( ['] sock-connect? 'sock4 ) ;
bernd's avatar
bernd committed
242 243
[ELSE]
    : try-ip ( addr u -- flag )
bernd's avatar
bernd committed
244
	['] sock-connect? 'sock ;
bernd's avatar
bernd committed
245
[THEN]
246 247 248

: global-ip4 ( -- ip4addr u )  dummy-ipv4 check-ip4 ;
: global-ip6 ( -- ip6addr u )  dummy-ipv6 check-ip6 ;
bernd's avatar
bernd committed
249 250
: local-ip6 ( -- ip6addr u )   local-ipv6 check-ip6
    IF  c@ $FD =  ELSE  drop false  THEN ;
251 252 253 254 255 256 257

\ no-hybrid stuff

[IFDEF] no-hybrid
    0 warnings !@
    : sendto { sock1 sock2 pack u1 flag addr u2 -- size }
	addr family w@ AF_INET6 =
bernd's avatar
bernd committed
258
	IF  addr fake-ip4?
259
	    IF
bernd's avatar
bernd committed
260
		sock2 pack u1 flag addr u2 fake6>ip4 sendto
261 262 263 264 265 266 267 268 269 270 271 272 273
	    ELSE
		sock1 pack u1 flag addr u2 sendto
	    THEN
	ELSE
	    sock2 pack u1 flag addr u2 sendto
	THEN ;
    warnings !
[THEN]

Variable myname

\ new address handling is in net2o-addr.fs, loaded later

bernd's avatar
bernd committed
274
Forward !my-addr ( -- )
275 276 277 278 279 280 281 282 283 284 285 286

\ this looks ok

: && ( flag -- ) ]] dup 0= ?EXIT drop [[ ; immediate compile-only
: &&' ( addr u addr' u' flag -- addr u false / addr u addr' u' )
    ]] 0= IF 2drop false EXIT THEN [[ ; immediate compile-only

: str=?0 ( addr1 u1 addr2 u2 -- flag )
    2dup ip6::0 over str= >r
    2over ip6::0 over str= >r str= r> r> or or ;

: str>merge ( addr1 u1 addr2 u2 -- )
287
    2dup ip6::0 over str= IF  smove  ELSE  2drop 2drop  THEN ;
288 289 290 291

\ insert address for punching

: !temp-addr ( addr u -- ) dup 0<> ind-addr !
292
    temp-addr dup $10 erase  $10 smove ;
293 294

: check-addr1 ( -- addr u flag )
bernd's avatar
bernd committed
295
    sockaddr1 ipv6( sock-rest )else( sock-rest4 ) 2dup try-ip ;
296 297 298

: ping-addr1 ( -- )
    check-addr1 0= IF  2drop  EXIT  THEN
299
    nat( ticks .ticks ."  ping: " 2dup .address cr )
bernd's avatar
bernd committed
300
    2>r net2o-sock ">" 0 2r> sendto drop ;
301

bernd's avatar
bernd committed
302
: pathc+ ( addr u -- addr' u' )
303 304 305 306 307
    BEGIN  dup  WHILE  over c@ $80 < >r 1 /string r>  UNTIL  THEN ;

: .addr-path ( addr -- )
    dup be@ routes #.key dup 0= IF  drop $10 xtype  ELSE
	$@ .address
bernd's avatar
bernd committed
308
	$10 pathc+ 0 -skip dup IF  '|' emit  THEN xtype  THEN ;
309

310 311 312 313 314 315 316 317
\ Create udp socket

4242 Value net2o-port
0    Value net2o-client-port \ client port by default unassigned

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

: net2o-socket ( port -- ) dup >r
bernd's avatar
bernd committed
318 319 320
    ipv6( ipv4( [IFDEF] no-hybrid
    create-udp-server6 [ELSE] create-udp-server46 [THEN]
    )else( create-udp-server6 )
321
    )else( create-udp-server )
322 323 324
    [IFDEF] no-hybrid 0 [THEN] to net2o-sock
    r> ?dup-0=-IF  my-port  THEN to my-port#
    [IFDEF] no-hybrid
bernd's avatar
bernd committed
325
	ipv4( net2o-sock drop my-port# create-udp-server to net2o-sock )
326 327 328
    [THEN]
    !my-addr ;

329 330 331 332 333 334 335 336 337 338 339 340 341 342 343
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]