mirror of
https://github.com/urbit/shrub.git
synced 2024-12-19 16:51:42 +03:00
Merge pull request #6693 from urbit/philip/ping
ping: Rewrite to support non-NAT mode
This commit is contained in:
Pyry Kovanen
GitHub
commit
a1bfce1d01
@ -13,129 +13,46 @@
|
||||
=* point point:kale
|
||||
::
|
||||
|%
|
||||
:: How often to ping our sponsor when we might be behind a NAT.
|
||||
::
|
||||
:: NAT timeouts are often pretty short for UDP entries. 5 minutes is
|
||||
:: a common value. We use 25 seconds, same as Wireguard.
|
||||
::
|
||||
++ nat-timeout ~s25
|
||||
::
|
||||
:: How often to check our IP when we know we're not behind a NAT.
|
||||
::
|
||||
++ ip-timeout ~m5
|
||||
::
|
||||
:: Chosen because it's run by Cloudflare, and others I tried were
|
||||
:: inconsistently slow.
|
||||
::
|
||||
++ ip-reflector 'https://icanhazip.com'
|
||||
::
|
||||
+$ card card:agent:gall
|
||||
+$ ship-state
|
||||
$% [%idle ~]
|
||||
[%poking ~]
|
||||
[%http until=@da]
|
||||
[%waiting until=@da]
|
||||
==
|
||||
+$ state-1
|
||||
$: %1
|
||||
ships=(set ship)
|
||||
nonce=@ud
|
||||
$= plan
|
||||
$~ [%nat ~]
|
||||
$% [%nat ~]
|
||||
[%pub ip=(unit @t)]
|
||||
==
|
||||
==
|
||||
--
|
||||
::
|
||||
%- agent:dbug
|
||||
::
|
||||
=| state=[%0 ships=(map ship [=rift =ship-state])]
|
||||
=| state=state-1
|
||||
=> |%
|
||||
:: +print-error: maybe +slog
|
||||
::
|
||||
++ print-error
|
||||
|= [=tape error=(unit tang)]
|
||||
^+ same
|
||||
?~ error same
|
||||
%- (slog leaf+tape u.error) same
|
||||
:: +set-timer: send a card to behn to set a timer
|
||||
::
|
||||
++ set-timer
|
||||
|= [now=@da =ship]
|
||||
^- (quip card _state)
|
||||
=/ s (~(get by ships.state) ship)
|
||||
?~ s
|
||||
`state
|
||||
?. ?=(%poking -.ship-state.u.s)
|
||||
%- (slog leaf+"ping: strange state {<ship s>}" ~)
|
||||
`state
|
||||
:: NAT timeouts are often pretty short for UDP entries. 5
|
||||
:: minutes is a common value. We use 25 seconds, same as Wireguard.
|
||||
::
|
||||
=/ until (add ~s25 now)
|
||||
=. ships.state
|
||||
(~(put by ships.state) ship u.s(ship-state [%waiting until]))
|
||||
:_ state
|
||||
=/ =wire /ping-wait/(scot %p ship)/(scot %da until)
|
||||
[%pass wire %arvo %b %wait `@da`until]~
|
||||
:: +send-ping: poke their %ping app
|
||||
::
|
||||
++ send-ping
|
||||
|= [our=@p now=@da =ship]
|
||||
^- (quip card _state)
|
||||
::
|
||||
?: =(our ship)
|
||||
`state
|
||||
=/ s (~(get by ships.state) ship)
|
||||
?~ s
|
||||
`state
|
||||
?. ?=(%idle -.ship-state.u.s)
|
||||
`state
|
||||
:_ state(ships (~(put by ships.state) ship u.s(ship-state [%poking ~])))
|
||||
[%pass /ping-send/(scot %p ship) %agent [ship %ping] %poke %noun !>(~)]~
|
||||
:: +stop-ping-ship: stop listening to jael if not sponsor or old rift
|
||||
::
|
||||
++ stop-ping-ship
|
||||
|= [our=@p now=@da =ship =old=rift =ship-state]
|
||||
^- (quip card _state)
|
||||
=+ .^(=new=rift %j /(scot %p our)/rift/(scot %da now)/(scot %p ship))
|
||||
:: if nothing's changed about us, don't cancel
|
||||
::
|
||||
?: ?& =(old-rift new-rift)
|
||||
(~(has in (silt (saxo:title our now our))) ship)
|
||||
==
|
||||
`state
|
||||
:: otherwise, kill jael subscription and timer
|
||||
::
|
||||
:_ state(ships (~(del by ships.state) ship))
|
||||
[%pass /jael/(scot %p ship) %arvo %j %nuke (silt ship ~)]~
|
||||
:: +start-ping-ship: start listening to jael updates if not already
|
||||
::
|
||||
:: While %public-keys is idempotent in most senses, it does
|
||||
:: trigger a response, and this function is called on that
|
||||
:: response, so we need a guard to avoid an infinite loop.
|
||||
::
|
||||
++ start-ping-ship
|
||||
|= [our=@p now=@da =ship]
|
||||
^- (quip card _state)
|
||||
::
|
||||
?: (~(has by ships.state) ship)
|
||||
(send-ping our now ship)
|
||||
::
|
||||
;< new-state=_state (rind card state)
|
||||
=+ .^(=rift %j /(scot %p our)/rift/(scot %da now)/(scot %p ship))
|
||||
:_ state(ships (~(put by ships.state) ship rift %idle ~))
|
||||
[%pass /jael/(scot %p ship) %arvo %j %public-keys (silt ship ~)]~
|
||||
=. state new-state
|
||||
::
|
||||
(send-ping our now ship)
|
||||
:: +kick: idempotent operation to make clean start for all pings
|
||||
::
|
||||
++ kick
|
||||
|= [our=@p now=@da]
|
||||
^- (quip card _state)
|
||||
?: =(%czar (clan:title our))
|
||||
`state
|
||||
::
|
||||
=/ old-ships=(list [=ship =rift =ship-state]) ~(tap by ships.state)
|
||||
|- ^- (quip card _state)
|
||||
=* loop $
|
||||
?^ old-ships
|
||||
;< new-state=_state (rind card state)
|
||||
(stop-ping-ship our now i.old-ships)
|
||||
=. state new-state
|
||||
loop(old-ships t.old-ships)
|
||||
::
|
||||
:: NB: !! This includes our own ship, and for moons, this is what
|
||||
:: has caused Jael to fetch our own rift from our parent. This
|
||||
:: role may be taken by Ames's subscription to %public-keys, but
|
||||
:: this must be tested before changing the behavior here.
|
||||
::
|
||||
=/ new-ships (saxo:title our now our)
|
||||
|- ^- (quip card _state)
|
||||
=* loop $
|
||||
?^ new-ships
|
||||
;< new-state=_state (rind card state)
|
||||
(start-ping-ship our now i.new-ships)
|
||||
=. state new-state
|
||||
loop(new-ships t.new-ships)
|
||||
::
|
||||
`state
|
||||
:: +rind: bind for the the writer monad on (quip effect state)
|
||||
:: Bind for the the writer monad on (quip effect state)
|
||||
::
|
||||
++ rind
|
||||
|* [effect=mold state=*]
|
||||
@ -148,6 +65,211 @@
|
||||
=^ effects-2=(list effect) state (fun state)
|
||||
[(weld effects-1 effects-2) state]
|
||||
::
|
||||
++ once
|
||||
|= =cord
|
||||
=(cord (scot %uw nonce.state))
|
||||
::
|
||||
:: Subsystem to keep track of which ships to ping across breaches
|
||||
:: and sponsorship changes
|
||||
::
|
||||
++ ships
|
||||
|%
|
||||
++ rind (^rind card state)
|
||||
++ kick
|
||||
|= [our=@p now=@da]
|
||||
^- (quip card _state)
|
||||
:: ?: =(%czar (clan:title our))
|
||||
:: `state
|
||||
::
|
||||
:: NB: !! This includes our own ship, and for moons, this is
|
||||
:: what has caused Jael to fetch our own rift from our parent.
|
||||
:: This role may be taken by Ames's subscription to
|
||||
:: %public-keys, but this must be tested before changing the
|
||||
:: behavior here.
|
||||
::
|
||||
=/ new-ships (~(gas in *(set ship)) (saxo:title our now our))
|
||||
=/ removed (~(dif in ships.state) new-ships)
|
||||
=/ added (~(dif in new-ships) ships.state)
|
||||
;< new-state=_state rind
|
||||
?~ removed `state
|
||||
[[%pass /jael %arvo %j %nuke removed]~ state]
|
||||
=. state new-state
|
||||
::
|
||||
;< new-state=_state rind
|
||||
?~ added `state
|
||||
[[%pass /jael %arvo %j %public-keys added]~ state]
|
||||
=. state new-state
|
||||
::
|
||||
:: Kick even if ships weren't added or removed
|
||||
::
|
||||
(kick-pings our now new-ships)
|
||||
::
|
||||
:: Kick whenever we get a response. We really care about
|
||||
:: breaches and sponsorship changes.
|
||||
::
|
||||
:: Delay until next event in case of breach, so that ames can
|
||||
:: clear its state.
|
||||
::
|
||||
++ take-jael
|
||||
|= now=@da
|
||||
^- (quip card _state)
|
||||
[[%pass /jael/delay %arvo %b %wait now]~ state]
|
||||
::
|
||||
++ take-delay kick
|
||||
--
|
||||
::
|
||||
:: Starts pinging a new set of `ships`.
|
||||
::
|
||||
++ kick-pings
|
||||
|= [our=@p now=@da ships=(set ship)]
|
||||
^- (quip card _state)
|
||||
=: nonce.state +(nonce.state)
|
||||
ships.state ships
|
||||
==
|
||||
::
|
||||
?: ?=(%nat -.plan.state)
|
||||
(kick:nat our)
|
||||
(kick:pub our now)
|
||||
::
|
||||
:: Subsystem for pinging our sponsors when we might be behind a NAT
|
||||
::
|
||||
:: Ping each ship every 25 seconds to keep the pinhole open.
|
||||
:: This is expensive, but if you don't do it and you are behind a
|
||||
:: NAT, you will stop receiving packets from other ships except
|
||||
:: during the 30 seconds following each packet you send.
|
||||
::
|
||||
++ nat
|
||||
?> ?=(%nat -.plan.state)
|
||||
|%
|
||||
++ rind (^rind card state)
|
||||
++ kick
|
||||
|= our=@p
|
||||
^- (quip card _state)
|
||||
=/ ships ~(tap in ships.state)
|
||||
|- ^- (quip card _state)
|
||||
?~ ships `state
|
||||
?: =(our i.ships) `state
|
||||
;< new-state=_state rind (send-ping i.ships)
|
||||
=. state new-state
|
||||
$(ships t.ships)
|
||||
::
|
||||
++ send-ping
|
||||
|= =ship
|
||||
^- (quip card _state)
|
||||
:_ state
|
||||
=/ wire /nat/(scot %uw nonce.state)/ping/(scot %p ship)
|
||||
[%pass wire %agent [ship %ping] %poke %noun !>(~)]~
|
||||
::
|
||||
++ take-ping
|
||||
|= [now=@da =wire error=(unit tang)]
|
||||
^- (quip card _state)
|
||||
?. ?=([%nat @ %ping @ ~] wire) `state
|
||||
?. (once i.t.wire) `state
|
||||
=/ ship (slav %p i.t.t.t.wire)
|
||||
%- (slog ?~(error ~ ['ping: got nack' >ship< u.error]))
|
||||
:_ state
|
||||
=/ wire /nat/(scot %uw nonce.state)/wait/(scot %p ship)
|
||||
[%pass wire %arvo %b %wait (add nat-timeout now)]~
|
||||
::
|
||||
++ take-wait
|
||||
|= =wire
|
||||
^- (quip card _state)
|
||||
?. ?=([%nat @ %wait @ ~] wire) `state
|
||||
?. (once i.t.wire) `state
|
||||
=/ ship (slav %p i.t.t.t.wire)
|
||||
(send-ping ship)
|
||||
--
|
||||
::
|
||||
:: Subsystem for pinging our sponsors when we know we're not behind a NAT
|
||||
::
|
||||
:: Check our IP address every minute, and only if it changes,
|
||||
:: ping all our sponsors.
|
||||
::
|
||||
++ pub
|
||||
?> ?=(%pub -.plan.state)
|
||||
|%
|
||||
++ rind (^rind card state)
|
||||
++ kick
|
||||
|= [our=@p now=@da]
|
||||
^- (quip card _state)
|
||||
;< new-state=_state rind (send-pings our)
|
||||
=. state new-state
|
||||
::
|
||||
;< new-state=_state rind check-ip
|
||||
=. state new-state
|
||||
::
|
||||
(set-timer now)
|
||||
::
|
||||
++ send-pings
|
||||
|= our=@p
|
||||
^- (quip card _state)
|
||||
:_ state
|
||||
%+ murn ~(tap in ships.state)
|
||||
|= =ship
|
||||
?: =(our ship)
|
||||
~
|
||||
=/ wire /pub/(scot %uw nonce.state)/ping/(scot %p ship)
|
||||
`u=[%pass wire %agent [ship %ping] %poke %noun !>(~)]
|
||||
::
|
||||
++ take-pings
|
||||
|= [=wire error=(unit tang)]
|
||||
^- (quip card _state)
|
||||
?. ?=([%pub @ %ping @ ~] wire) `state
|
||||
?. (once i.t.wire) `state
|
||||
=/ ship (slav %p i.t.t.t.wire)
|
||||
%- (slog ?~(error ~ ['ping: got nack' >ship< u.error]))
|
||||
`state
|
||||
::
|
||||
++ check-ip
|
||||
^- (quip card _state)
|
||||
:_ state
|
||||
=/ wire /pub/(scot %uw nonce.state)/ip
|
||||
=/ =request:http [%'GET' ip-reflector ~ ~]
|
||||
[%pass wire %arvo %i %request request *outbound-config:iris]~
|
||||
::
|
||||
++ take-ip
|
||||
|= [our=@p =wire resp=client-response:iris]
|
||||
^- (quip card _state)
|
||||
?. ?=([%pub @ %ip ~] wire) `state
|
||||
?. (once i.t.wire) `state
|
||||
::
|
||||
?. ?=(%finished -.resp) `state :: will retry in a minute
|
||||
?. ?=(%200 status-code.response-header.resp)
|
||||
=* s status-code.response-header.resp
|
||||
%- (slog leaf+"ping: ip check failed: {<s>}" ~)
|
||||
`state
|
||||
::
|
||||
?~ full-file.resp
|
||||
%- (slog 'ping: ip check body empty' ~)
|
||||
`state
|
||||
::
|
||||
=* body q.data.u.full-file.resp
|
||||
?~ body
|
||||
%- (slog 'ping: ip check body empty' ~)
|
||||
`state
|
||||
::
|
||||
=/ ip (end [3 (dec (met 3 body))] body)
|
||||
?: =(ip.plan.state `ip) `state
|
||||
::
|
||||
=. ip.plan.state `ip
|
||||
(send-pings our)
|
||||
::
|
||||
++ set-timer
|
||||
|= now=@da
|
||||
^- (quip card _state)
|
||||
=/ =wire /pub/(scot %uw nonce.state)/wait
|
||||
[[%pass wire %arvo %b %wait (add ip-timeout now)]~ state]
|
||||
::
|
||||
++ take-wait
|
||||
|= [our=@p now=@da =wire]
|
||||
^- (quip card _state)
|
||||
?. ?=([%pub @ %wait ~] wire) `state
|
||||
?. (once i.t.wire) `state
|
||||
;< new-state=_state rind check-ip
|
||||
=. state new-state
|
||||
::
|
||||
(set-timer now)
|
||||
--
|
||||
--
|
||||
%+ verb |
|
||||
^- agent:gall
|
||||
@ -159,25 +281,47 @@
|
||||
::
|
||||
++ on-init
|
||||
^- [(list card) _this]
|
||||
=^ cards state (kick our.bowl now.bowl)
|
||||
=. plan.state [%nat ~]
|
||||
=^ cards state (kick:ships our.bowl now.bowl)
|
||||
[cards this]
|
||||
::
|
||||
++ on-save !>(state)
|
||||
++ on-load
|
||||
|= old=vase
|
||||
=. state !<(_state old)
|
||||
(on-poke %noun !>(%kick))
|
||||
|= old-vase=vase
|
||||
|^
|
||||
=/ old !<(state-any old-vase)
|
||||
=? old ?=(%0 -.old) (state-0-to-1 old)
|
||||
?> ?=(%1 -.old)
|
||||
=. state old
|
||||
=^ cards state (kick:ships our.bowl now.bowl)
|
||||
[cards this]
|
||||
::
|
||||
+$ state-any $%(state-0 state-1)
|
||||
+$ state-0 [%0 ships=(map ship [=rift =ship-state])]
|
||||
::
|
||||
++ state-0-to-1
|
||||
|= old=state-0
|
||||
^- state-1
|
||||
[%1 ~ 0 %nat ~]
|
||||
--
|
||||
:: +on-poke: positively acknowledge pokes
|
||||
::
|
||||
++ on-poke
|
||||
|= [=mark =vase]
|
||||
?: =(q.vase %kick)
|
||||
=. ships.state
|
||||
%- ~(run by ships.state)
|
||||
|= [=rift =ship-state]
|
||||
[999.999 ship-state]
|
||||
on-init
|
||||
`this
|
||||
?. =(our src):bowl :: don't crash, this is where pings are handled
|
||||
`this
|
||||
::
|
||||
=^ cards state
|
||||
?: =(q.vase %kick) :: NB: ames calls this on %born
|
||||
(kick:ships our.bowl now.bowl)
|
||||
?: =(q.vase %nat)
|
||||
=. plan.state [%nat ~]
|
||||
(kick:ships our.bowl now.bowl)
|
||||
?: =(q.vase %no-nat)
|
||||
=. plan.state [%pub ~]
|
||||
(kick:ships our.bowl now.bowl)
|
||||
`state
|
||||
[cards this]
|
||||
::
|
||||
++ on-watch on-watch:def
|
||||
++ on-leave on-leave:def
|
||||
@ -190,46 +334,56 @@
|
||||
++ on-agent
|
||||
|= [=wire =sign:agent:gall]
|
||||
^- [(list card) _this]
|
||||
?> ?=([%ping-send @ ~] wire)
|
||||
?> ?=(%poke-ack -.sign)
|
||||
::
|
||||
%- (print-error "ping: ack" p.sign)
|
||||
=^ cards state
|
||||
(set-timer now.bowl (slav %p i.t.wire))
|
||||
?+ wire `state
|
||||
[%nat *]
|
||||
?. ?=(%nat -.plan.state) `state
|
||||
?. ?=(%poke-ack -.sign) `state
|
||||
(take-ping:nat now.bowl wire p.sign)
|
||||
::
|
||||
[%pub *]
|
||||
?. ?=(%pub -.plan.state) `state
|
||||
?. ?=(%poke-ack -.sign) `state
|
||||
(take-pings:pub wire p.sign)
|
||||
==
|
||||
[cards this]
|
||||
:: +on-arvo: handle timer firing
|
||||
::
|
||||
++ on-arvo
|
||||
|= [=wire =sign-arvo]
|
||||
^- [(list card) _this]
|
||||
?+ wire !!
|
||||
[%ping-wait @ @ ~]
|
||||
?> ?=(%wake +<.sign-arvo)
|
||||
=/ =ship (slav %p i.t.wire)
|
||||
=/ until=@da (slav %da i.t.t.wire)
|
||||
=/ s (~(get by ships.state) ship)
|
||||
?~ s
|
||||
`this
|
||||
?. =([%waiting until] ship-state.u.s)
|
||||
`this
|
||||
=. ships.state (~(put by ships.state) ship u.s(ship-state [%idle ~]))
|
||||
%- (print-error "ping: wake" error.sign-arvo)
|
||||
=^ cards state
|
||||
(send-ping our.bowl now.bowl ship)
|
||||
[cards this]
|
||||
::
|
||||
[%jael @ ~]
|
||||
:: whenever we get an update from Jael, kick
|
||||
=^ cards state
|
||||
?+ wire `state
|
||||
[%jael %delay ~]
|
||||
?> ?=(%wake +<.sign-arvo)
|
||||
?^ error.sign-arvo
|
||||
%- (slog 'ping: strange jael wake fail!' u.error.sign-arvo)
|
||||
`state
|
||||
(take-delay:ships our.bowl now.bowl)
|
||||
::
|
||||
?> ?=(%public-keys +<.sign-arvo)
|
||||
:_ this
|
||||
[%pass /delay %arvo %b %wait now.bowl]~
|
||||
:: Delayed until next event so that ames can clear its state
|
||||
::
|
||||
[%delay ~]
|
||||
?> ?=(%wake +<.sign-arvo)
|
||||
on-init
|
||||
==
|
||||
[%jael ~]
|
||||
?> ?=(%public-keys +<.sign-arvo)
|
||||
(take-jael:ships now.bowl)
|
||||
::
|
||||
[%nat *]
|
||||
?. ?=(%nat -.plan.state) `state
|
||||
?> ?=(%wake +<.sign-arvo)
|
||||
?^ error.sign-arvo
|
||||
%- (slog 'ping: strange nat wake fail!' u.error.sign-arvo)
|
||||
`state
|
||||
(take-wait:nat wire)
|
||||
::
|
||||
[%pub @ %ip *]
|
||||
?. ?=(%pub -.plan.state) `state
|
||||
?> ?=(%http-response +<.sign-arvo)
|
||||
(take-ip:pub our.bowl wire client-response.sign-arvo)
|
||||
::
|
||||
[%pub @ %wait *]
|
||||
?. ?=(%pub -.plan.state) `state
|
||||
?> ?=(%wake +<.sign-arvo)
|
||||
(take-wait:pub our.bowl now.bowl wire)
|
||||
==
|
||||
[cards this]
|
||||
::
|
||||
++ on-fail on-fail:def
|
||||
--
|
||||
|
||||
@ -1127,6 +1127,9 @@
|
||||
$: %d
|
||||
$>(%flog task:dill)
|
||||
==
|
||||
$: %g
|
||||
$>(%deal task:gall)
|
||||
==
|
||||
$: %j
|
||||
$> $? %private-keys
|
||||
%public-keys
|
||||
@ -1145,6 +1148,9 @@
|
||||
$% $: %behn
|
||||
$>(%wake gift:behn)
|
||||
==
|
||||
$: %gall
|
||||
$>(%unto gift:gall)
|
||||
==
|
||||
$: %jael
|
||||
$> $? %private-keys
|
||||
%public-keys
|
||||
@ -2607,7 +2613,11 @@
|
||||
=< q.q %- need %- need
|
||||
(rof ~ %j `beam`[[our %turf %da now] /])
|
||||
::
|
||||
(emit unix-duct.ames-state %give %turf turfs)
|
||||
=* duct unix-duct.ames-state
|
||||
%- emil
|
||||
:~ [duct %give %turf turfs]
|
||||
[duct %pass /ping %g %deal [our our] %ping %poke %noun !>(%kick)]
|
||||
==
|
||||
:: +on-vega: handle kernel reload
|
||||
::
|
||||
++ on-vega event-core
|
||||
@ -4680,6 +4690,9 @@
|
||||
=/ event-core (ev [now eny rof] duct ames-state)
|
||||
::
|
||||
=^ moves ames-state
|
||||
?: ?=([%gall %unto *] sign)
|
||||
`ames-state
|
||||
::
|
||||
=< abet
|
||||
?- sign
|
||||
[@ %done *] (on-take-done:event-core wire error.sign)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user