diff options
Diffstat (limited to 'desk/app/polls.hoon')
| -rw-r--r-- | desk/app/polls.hoon | 358 |
1 files changed, 358 insertions, 0 deletions
diff --git a/desk/app/polls.hoon b/desk/app/polls.hoon new file mode 100644 index 0000000..433de58 --- /dev/null +++ b/desk/app/polls.hoon @@ -0,0 +1,358 @@ +/- *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)]] +-- + |