shrub/pkg/arvo/app/dns-collector.hoon

/-  dns
/+  default-agent
::
::  app types and boilerplate
::
=>  |%
    +$  card  card:agent:gall
    +$  app-state
      $:  %0
          requested=(map ship address:dns)
          completed=(map ship binding:dns)
      ==
    +$  peek-data
      $%  [%requested (list (pair ship address:dns))]
          [%completed (list (pair ship binding:dns))]
      ==
    +$  in-poke-data
      $%  [%dns-address =address:dns]
          [%dns-complete =ship =binding:dns]
          [%noun noun=*]
      ==
    +$  out-peer-data
      $%  [%dns-binding =binding:dns]
          [%dns-request =request:dns]
      ==
    --
|%
++  give-result
  |=  [=the=path =cage]
  ^-  card
  [%give %fact `the-path cage]
--
::
^-  agent:gall
=|  state=app-state
|_  =bowl:gall
+*  this  .
    def   ~(. (default-agent this %|) bowl)
::
++  on-init   on-init:def
++  on-save   !>(state)
++  on-load
  |=  old=vase
  ~&  >  'grand'
  `this(state !<(app-state old))
::
++  on-poke
  |=  [=mark =vase]
  ^-  (quip card _this)
  |^
  ?+  mark  (on-poke:def mark vase)
    %noun          (handle-noun !<(noun vase))
    %dns-address   (handle-dns-address !<(address:dns vase))
    %dns-complete  (handle-dns-complete !<([ship binding:dns] vase))
  ==
  ::
  ++  handle-noun
    |=  noun=*
    ^-  (quip card _this)
    ?:  ?=(%debug noun)
      ~&  bowl=bowl
      ~&  state=state
      `this
    ::
    ~&  %poke-unknown
    `this
  ::
  ++  handle-dns-address
    |=  adr=address:dns
    ^-  (quip card _this)
    =*  who  src.bowl
    =/  rac  (clan:title who)
    ?.  ?=(?(%king %duke) rac)
      ~|  [%dns-collector-bind-invalid who]  !!
    ?:  (reserved:eyre if.adr)
      ~|  [%dns-collector-reserved-address who if.adr]  !!
    ::
    =/  req=(unit address:dns)  (~(get by requested.state) who)
    =/  dun=(unit binding:dns)  (~(get by completed.state) who)
    ?:  &(?=(^ dun) =(adr address.u.dun))
      =.  requested.state  (~(del by requested.state) who)
      :_  this  :_  ~
      (give-result /(scot %p who) %dns-binding !>(u.dun))
    ::
    ?:  &(?=(^ req) =(adr u.req))
      `this
    ::  XX check address?
    =/  =request:dns  [who adr]
    =.  requested.state  (~(put by requested.state) request)
    :_  this  :_  ~
    (give-result /requests %dns-request !>(request))
  ::
  ++  handle-dns-complete
    |=  [who=ship =binding:dns]
    ^-  (quip card _this)
    ::  XX or confirm valid binding?
    ::
    ?.  (team:title [our src]:bowl)
      ~|  %complete-yoself  !!
    =*  adr  address.binding
    =*  tuf  turf.binding
    =/  req=(unit address:dns)  (~(get by requested.state) who)
    ::  ignore established bindings that don't match requested
    ::
    ?:  ?|  ?=(~ req)
            !=(adr u.req)
        ==
      ~&  %unknown-complete
      `this
    =:  requested.state  (~(del by requested.state) who)
        completed.state  (~(put by completed.state) who [adr tuf])
      ==
    :_  this  :_  ~
    (give-result /(scot %p who) %dns-binding !>([adr tuf]))
  --
::
++  on-watch
  |=  =path
  ^-  (quip card _this)
  ?:  ?=([%sole *] path)
    !!
  ?.  ?=([@ ~] path)
    ~|  %invalid-path  !!
  ?:  ?=(%requests i.path)
    =/  requests  ~(tap by requested.state)
    |-  ^-  (quip card _this)
    =*  loop  $
    ?~  requests
      `this
    =/  card  (give-result path %dns-request !>(i.requests))
    =^  cards  this  loop(requests t.requests)
    [[card cards] this]
  ::
  =/  who=(unit @p)  (slaw %p i.path)
  ?~  who
    ~|  %invalid-path  !!
  ?~  dun=(~(get by completed.state) u.who)
    `this
  :_  this  :_  ~
  (give-result path %dns-binding !>(u.dun))
::
++  on-leave  on-leave:def
++  on-peek
  |=  =path
  ^-  (unit (unit cage))
  ?+  path  [~ ~]
      [%x %requested ~]  [~ ~ %requested !>(~(tap by requested.state))]
      [%x %completed ~]  [~ ~ %completed !>(~(tap by completed.state))]
  ==
::
++  on-agent  on-agent:def
++  on-arvo   on-arvo:def
++  on-fail   on-fail:def
--