net2o-connect.fs 5.67 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 25 26 27 28 29 30 31 32 33 34 35 36
\ net2o connection setup commands

\ Copyright (C) 2011-2014   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/>.

reply-table $@ inherit-table setup-table

$20 net2o: tmpnest ( $:string -- ) \ nested (temporary encrypted) command
    $> cmdtmpnest ;

: ]nest$  ( -- )  end-cmd cmd>nest $, ;
: ]nest  ( -- )  ]nest$ push-$ push' nest ;
: ]tmpnest ( -- )  end-cmd cmd>tmpnest $, tmpnest ;

+net2o: new-data ( addr addr u -- ) \ create new data mapping
    o 0<> tmp-crypt? and own-crypt? or IF  64>n  n2o:new-data  EXIT  THEN
    64drop 64drop 64drop  un-cmd ;
+net2o: new-code ( addr addr u -- ) \ crate new code mapping
    o 0<> tmp-crypt? and own-crypt? or IF  64>n  n2o:new-code  EXIT  THEN
    64drop 64drop 64drop  un-cmd ;
+net2o: set-cookie ( utimestamp -- ) \ cookie and round trip delay
    own-crypt? IF
	64dup cookie>context?
	IF  >o rdrop  o to connection
bernd's avatar
bernd committed
37
	    ack@ >o ticker 64@ recv-tick 64! rtdelay! o> \ time stamp of arrival
38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68
	    EXIT
	ELSE \ just check if timeout didn't expire
	    ticker 64@ connect-timeout# 64- 64u< 0= ?EXIT
	THEN
    ELSE  64drop  THEN  un-cmd ;

: n2o:create-map
    { 64: addrs ucode udata 64: addrd -- addrd ucode udata addrs }
    addrs lit, addrd lit, ucode ulit, new-code
    addrs ucode n>64 64+ lit, addrd ucode n>64 64+ lit, udata ulit, new-data
    addrd ucode udata addrs ;

+net2o: store-key ( $:string -- ) $> \ store key
    o 0= IF  ." don't store key, o=0: " .nnb F cr un-cmd  EXIT  THEN
    own-crypt? IF
	key( ." store key: o=" o hex. 2dup .nnb F cr )
	2dup do-keypad sec!
	crypto-key sec!
    ELSE  ." don't store key: o=" o hex. .nnb F cr  THEN ;

+net2o: map-request ( addrs ucode udata -- ) \ request mapping
    2*64>n
    nest[
    ?new-mykey ticker 64@ lit, set-cookie
    max-data# umin swap max-code# umin swap
    2dup + n2o:new-map n2o:create-map
    keypad keysize $, store-key  stskc KEYSIZE erase
    ]nest  n2o:create-map  nest-stack $[]# IF  ]tmpnest  THEN
    64drop 2drop 64drop ;

+net2o: set-tick ( uticks -- ) \ adjust time
bernd's avatar
bernd committed
69
    o IF  ack@ .adjust-ticks  ELSE  64drop  THEN ;
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 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124
+net2o: get-tick ( -- ) \ request time adjust
    ticks lit, set-tick ;

net2o-base

\ crypto functions

+net2o: receive-key ( $:key -- ) $> \ receive a key
    crypt( ." Received key: " tmpkey@ .nnb F cr )
    tmp-crypt? IF  net2o:receive-key  ELSE  2drop  THEN ;
+net2o: receive-tmpkey ( $:key -- ) $> \ receive emphemeral key
    net2o:receive-tmpkey ;
+net2o: key-request ( -- ) \ request a key
    crypt( ." Nested key: " tmpkey@ .nnb F cr )
    pkc keysize $, receive-key ;
+net2o: tmpkey-request ( -- ) \ request ephemeral key
    stpkc keysize $, receive-tmpkey nest[ ;
+net2o: keypair ( $:yourkey $:mykey -- ) \ select a pubkey
    $> $> tmp-crypt? IF  2swap net2o:keypair  ELSE  2drop 2drop  THEN ;
+net2o: update-key ( -- ) \ update secrets
    net2o:update-key ;
+net2o: gen-ivs ( $:string -- ) \ generate IVs
    $> ivs-strings receive-ivs ;

\ nat traversal functions

+net2o: punch ( $:string -- ) \ punch NAT traversal hole
    $> net2o:punch ;
+net2o: punch-load, ( $:string -- ) \ use for punch payload: nest it
    $> punch-load $! ;
+net2o: punch-done ( -- ) \ punch received
    o 0<> own-crypt? and IF
	return-addr return-address $10 move  resend0 $off
    THEN ;

: cookie, ( -- )  add-cookie lit, set-cookie ;
: request, ( -- )  next-request ulit, request-done ;

: gen-punch ( -- )
    my-ip$ [: $, punch ;] $[]map ;

: cookie+request ( -- )  nest[ cookie, request, ]nest ;

: gen-punchload ( -- )
    nest[ cookie, punch-done request, ]nest$ punch-load, ;

+net2o: punch? ( -- ) \ Request punch addresses
    gen-punch ;

\ create commands to send back

: all-ivs ( -- ) \ Seed and gen all IVS
    state# rng$ 2dup $, gen-ivs ivs-strings send-ivs ;

+net2o: >time-offset ( n -- ) \ set time offset
bernd's avatar
bernd committed
125
    o IF  ack@ .time-offset 64!  ELSE  64drop  THEN ;
126 127 128
+net2o: context ( -- ) \ make context active
    o IF  context!  ELSE  ." Can't "  THEN  ." establish a context!" F cr ;

bernd's avatar
bernd committed
129
: time-offset! ( -- )  ticks 64dup lit, >time-offset ack@ .time-offset 64! ;
130 131 132 133 134 135 136 137
: reply-key, ( -- )
    nest[ pkc keysize $, dest-pubkey @ IF
	dest-pubkey $@ $, keypair
	dest-pubkey $@ drop skc key-stage2
    ELSE  receive-key  THEN
    update-key all-ivs ;

+net2o: gen-reply ( -- ) \ generate a key request reply reply
bernd's avatar
bernd committed
138
    own-crypt? 0= ?EXIT
139
    [: crypt( ." Reply key: " tmpkey@ .nnb F cr )
140
      reply-key, cookie+request time-offset! context ]tmpnest
141 142 143
      push-cmd ;]  IS expect-reply? ;
+net2o: gen-punch-reply ( -- )  o? \ generate a key request reply reply
    [: crypt( ." Reply key: " tmpkey@ .nnb F cr )
144
      reply-key, gen-punchload gen-punch time-offset! context ]tmpnest
145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165
      push-cmd ;]  IS expect-reply? ;

gen-table $freeze

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-z\-0-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)
     (("[:") (0 . 1) (0 . 1) immediate)
     ((";]") (-1 . 0) (0 . -1) immediate)
    )
End:
[THEN]