path: root/desk/app/polls.hoon

/-  *polls
/+  dbug
|%
+$  versioned-state
  $%  state-0
  ==
+$  state-0
  $:  %0
      polls=(map pid poll)
  ==
::
+$  card  card:agent:gall
::
--
%-  agent:dbug
=|  versioned-state
=*  state  -
^-  agent:gall
=<
|_  =bowl:gall
+*  this  .
    hd    ~(. +> bowl)
++  on-fail   |~(* `this)
++  on-leave  |~(* `this)
::
++  on-init
:_  this  `this
++  on-save  !>(state)
++  on-load
|=  old-state=vase
^-  (quip card _this)
=/  prev  !<(versioned-state old-state)  
:-  ~
%=  this  state  prev  ==
++  on-agent
|=  [=wire =sign:agent:gall]
^-  (quip card _this)
|^  
?:  ?=([%tracking-polls @ ~] wire)  
?:  ?=(%kick -.sign)
=/  id  (slaw %ud i.t.wire)  
?~  id  `this
=/  pol  (~(get by polls) [src.bowl u.id])
?~  pol  `this
=/  exp  expiry.u.pol
?:  (gth now.bowl exp)  `this
:_  this  (track-card:hd [src.bowl u.id])^~
?.  ?=(%fact -.sign)  `this
(handle-update (update +.q.cage.sign))
?.  ?=([%poll-watch @ ~] wire)  `this
?:  ?=(%kick -.sign)  :_  this  :_  ~  watch-card:hd
?.  ?=(%fact -.sign)  `this
=/  u=pull-agent:comms  (pull-agent:comms +.q.cage.sign)
?.  ?=(%post -.u)  `this
?.  ?=(%poll +<.u)  `this
(handle-update +>.u)
++  handle-update
|=  u=update
^-  (quip card _this)
:_  %=  this  state
?+  -.u  state
%new-poll  (save-new-poll:hd +.u)
%ded-poll  (save-del-poll:hd p.u)
%old-poll  (handle-poll-update +.u)
==  ==
:_  ~  (ui-card:hd u)
++  handle-poll-update 
|=  [p=poll u=upd]
%=  state  polls
(~(put by polls) [host.p time.p] p)
==
--
++  on-poke
|=  =cage
^-  (quip card _this)
|^
?+  p.cage  `this
%trill  (handle-ui !<(action:ui q.cage))
%noun   (poke-noun !<(* q.cage))
==
++  poke-noun
|=  arg=*
^-  (quip card _this)
?:  ?=([%cli *] arg)  
(handle-terminal +.arg)
(handle-poke arg)
++  handle-terminal
|=  arg=*
^-  (quip card _this)
?.  .=(src.bowl our.bowl)  `this
?+  arg  `this
[%new @]  `this
==
++  handle-poke
|=  arg=*
^-  (quip card _this)
=/  a=action  (action arg)
?-  -.a
%vote  (handle-vote +.a)
%peek  (handle-peek +.a)
%res   (handle-res +.a)
==
++  handle-res
|=  [=pid pr=peek-res]
?.  ?=(%peek-ok -.pr)  :_  this  :_  ~
(ui-card:hd [%peek-res pid pr])
:-  :~  
(ui-card:hd [%peek-res pid pr])
(track-card:hd pid)
==
%=  this  state
=/  nps  (~(put by polls) [host.poll.pr time.poll.pr] poll.pr)
state(polls nps)
==
++  handle-peek
|=  =id
=/  pid  [our.bowl id]
:_  this  :_  ~
=/  pol  (~(get by polls) pid)
:: TODO check lock
=/  pr=peek-res
?~  pol  [%no-poll ~]  :-  %peek-ok
?.  private.u.pol  u.pol
u.pol(votes (mask-votes votes.u.pol))  :: TODO check this when it moves around
(peek-res-card:hd src.bowl pid pr)
++  is-valid
|=  [s=signature hsh=@uvH comment=@t]  ^-  ?
?:  %+  gte  (lent (trip comment))  100  .n
?.  (is-signature-valid:signatures our.bowl s hsh now.bowl)  
~&  >>>  fraudulent-vote-by=src.bowl
.n
?.  .=(src.bowl q.s)
~&  >>>  impersonation-attempt-by=src.bowl
.n  .y
++  handle-vote
|=  [=pid option=@ s=signature comment=@t]
^-  (quip card _this)
?.  (is-valid s (sham [pid option]) comment)  `this
=^  cards  state  (save-new-vote:hd pid option s comment)
[cards this]
++  handle-ui
|=  u=action:ui
^-  (quip card _this)
?.  ?=(%poll -.u)  `this
=/  a=ui-action  +.u
?.  .=(our.bowl src.bowl)  `this
?-  -.a
::  our polls
%propose        (propose +.a)
%cancel         (cancel +.a)
%change-expiry  (change-expiry +.a)
:: other people's
%vote           (go-vote +.a)
%peek           (peek +.a)
==
++  propose
|=  [id=@ text=@t expiry=@da options=(list @t) hidden=? private=? exc=?]
^-  (quip card _this)
=/  hid   ?:  hidden  (some eny.bowl)  ~
=/  =pid  [our.bowl id]
=/  =poll  (new-poll pid text expiry options hid private exc)
:_  this(state (save-new-poll:hd poll))
::  mask the entropy when sending it to people?
=/  =update  [%new-poll poll]
?.  ?=(%hid -.votes.poll)
(spread-cards:hd update)
:-  (wipe-eny-card:hd id expiry)
    (spread-cards:hd update)
++  cancel
|=  =id
^-  (quip card _this)
:_  this(state (save-del-poll:hd [our.bowl id]))
=/  update  [%ded-poll [our.bowl id]]
(spread-cards:hd update)
++  change-expiry
|=  [=id expiry=@da]
^-  (quip card _this)
=/  pol  (~(get by polls) [our.bowl id])
?~  pol  `this
=^  np  state  (save-exp-change u.pol expiry)
:_  this
=/  update  [%old-poll np %expiry-changed expiry]
(spread-cards:hd update)
::
++  go-vote
|=  [=pid option=@ comment=@t]
^-  (quip card _this)
::  we sign and poke the guy
:_  this  :_  ~
=/  s=signature  (sign:signatures our.bowl now.bowl (sham [pid option]))
=/  vot  [option s comment]
=/  =action  [%vote pid vot]
(action-card:hd -.pid action)
++  peek
|=  =pid
=/  a=action  [%peek +.pid]
:_  this
(action-card:hd -.pid a)^~
--
++  on-watch 
|=  =(pole knot)
?+  pole  `this
[%ui ~]  ?>  .=(our.bowl src.bowl)  `this
[%poll-sub id=@ ~]  `this
==
++  on-peek
|=  p=(pole knot)  ^-  (unit (unit cage))
|^
?+  p  ~
[%x %j rest=*]
``[%trill !>([%scry %poll (scry rest.p)])]
[%x %n rest=*]
``[%noun !>((scry rest.p))]
==
++  scry
|=  =(pole knot)  ^-  poll-scry:scry:ui
?+  pole  [%ng ~]
[%poll ship=@ id=@ ~]  
=/  ship  (slav %p ship.pole)
=/  id  (rush id.pole dem)
?~  id  [%ng ~]
=/  p  (~(get by polls) [ship `@da`u.id])
?~  p  [%ng ~]
[%poll u.p]
[%done ~]
=/  d  %+  roll  ~(tap by polls)
|=  [i=[=pid =poll] acc=(set poll)]  
?:  (gte now.bowl expiry.poll.i)  acc 
(~(put in acc) poll.i)
[%done d]
[%cur ~]
=/  d  %+  roll  ~(tap by polls)
|=  [i=[=pid =poll] acc=(set poll)]  
?.  (gte now.bowl expiry.poll.i)  acc 
(~(put in acc) poll.i)
[%cur d]
==
--
++  on-arvo  |~(* `this)
--
|_  =bowl:gall
:::: savers
++  save-new-poll
|=  =poll  ^-  _state
=/  nps  (~(put by polls) [host.poll time.poll] poll)
state(polls nps)
++  save-del-poll
|=  =pid  ^-  _state
=/  np  (~(del by polls) pid)
state(polls np)
++  save-exp-change
|=  [p=poll expiry=@da]  ^-  [poll _state]
=/  np  p(expiry expiry)
=/  nps  (~(put by polls) [host.p time.p] np)
:-  np
state(polls nps)
++  handle-exc-vote
|=  [vot=vote v=excl]  ^-  [upd excl]
=/  crr  (~(get by p.v) q.p.q.vot)
?~  crr  
:_  [%exc (~(put by p.v) q.p.q.vot vot)]
    [%new-vote vot]
?:  .=(p.u.crr p.vot)
:_  [%exc (~(del by p.v) q.p.q.vot)]
    [%vote-canceled q.p.q.vot p.vot]
:_  [%exc (~(put by p.v) q.p.q.vot vot)]
    [%vote-changed q.p.q.vot p.u.crr p.vot]
++  handle-inc-vote
|=  [vot=vote v=incl]  ^-  [upd incl]
=/  crr  (~(get by p.v) p.vot)
?~  crr
=/  b  *(map @p comv)
=/  nc  (~(put by b) q.p.q.vot q.vot)
:-  [%new-vote vot]
[%inc (~(put by p.v) p.vot nc)]
::
?:  (~(has by u.crr) q.p.q.vot)
=/  nc  (~(del by u.crr) q.p.q.vot)
:-  
[%vote-canceled q.p.q.vot p.vot]
[%inc (~(put by p.v) p.vot nc)]
::
=/  nc  (~(put by u.crr) q.p.q.vot q.vot)
:-  [%new-vote vot]
[%inc (~(put by p.v) p.vot nc)]
++  handle-hid-vote
|=  [vot=vote v=hidd]  ^-  [upd hidd]
::  we hash the vote first
=/  hsh  (hash-vote q.p.q.vot eny.v)
::  find 
=/  same-votes  (~(get by p.v) p.vot)
=/  nsv  ?~  same-votes  (sy ~[hsh])  (~(put in u.same-votes) hsh)
::  check our votes at present. could be many (if inc)
=/  zji=(set @)  %+  roll  ~(tap by p.v)
|=  [i=[o=@ud s=(set @uw)] acc=(set @)]
?:  (~(has in s.i) hsh)  (~(put in acc) o.i)  acc
::  if current vote is same as before, means cancelation
?:  (~(has in zji) p.vot)
=/  dlt  (~(del in nsv) hsh)
=/  nm  (~(put by p.v) p.vot dlt)
:_  v(p nm)  [%vote-canceled q.p.q.vot p.vot]
?:  exc.v
::  exclusive and has previous post, must delete the previous one first
=/  ov  -:~(tap in zji)
=/  current-set  (~(got by p.v) ov)  :: mmm
=/  ncr  (~(del in current-set) hsh)
=+  (~(put by p.v) ov ncr)
=/  nm  (~(put by -) p.vot nsv)
:_  v(p nm)
[%vote-changed q.p.q.vot ov p.vot]
::  inclusive and has previous post
=/  nm  (~(put by p.v) p.vot nsv)
:_  v(p nm)
[%new-vote vot]
++  save-new-vote
|=  [=pid vot=vote]  ^-  [(list card) _state]
=/  pol=(unit poll)  (~(get by polls) pid)
?~  pol  `state
?:  (gth now.bowl expiry.u.pol)  `state
=/  v=votes  votes.u.pol
=^  u=upd  v
?-  -.v
%exc  (handle-exc-vote vot v)
%inc  (handle-inc-vote vot v)
%hid  (handle-hid-vote vot v)
==
=/  np=poll  u.pol(votes v)
:-  (spread-cards [%old-poll np u])
state(polls (~(put by polls) pid np))
::  cards
++  watch-card
[%pass /poll-watch/(scot %p our.bowl) %agent [our.bowl %feed-push-hook] %watch /trill-sub]
++  track-card
|=  =pid
[%pass /tracking-polls/(scot %ud id.pid) %agent [ship.pid %trill-polls] %watch /poll-sub/(scot %ud id.pid)]
++  peek-res-card
|=  [target=@p =pid p=peek-res]  ^-  card
[%pass /poll/peek-res %agent [target %trill-polls] %poke [%noun !>([%res pid p])]]
++  action-card
|=  [target=@p =action]  ^-  card
[%pass [%poll -.action ~] %agent [target %trill-polls] %poke [%noun !>(action)]]
++  spread-cards
|=  =update  ^-  (list card)
:~  (spread-card update)
    (ui-card update)
    (fact-card update)
==
++  fact-card
|=  u=update  ^-  card
=/  id  ?-  -.u
%new-poll  time.poll.u
%old-poll  time.p.u
%ded-poll  id.p.u
%peek-res  id.p.u
==
[%give %fact ~[/poll-sub/(scot %ud id)] [%noun !>(u)]]
--