mirror of
https://github.com/urbit/shrub.git
synced 2024-12-24 03:14:30 +03:00
318 lines
8.3 KiB
Plaintext
318 lines
8.3 KiB
Plaintext
:: %behn, just a timer
|
|
!:
|
|
!? 164
|
|
::
|
|
=, behn
|
|
|= our=ship
|
|
=> |%
|
|
+$ move [p=duct q=(wite note gift)]
|
|
+$ note :: out request $->
|
|
$~ [%b %wait *@da] ::
|
|
$% $: %b :: to self
|
|
$>(%wait task) :: set timer
|
|
== ::
|
|
$: %d :: to %dill
|
|
$>(%flog task:dill) :: log output
|
|
== == ::
|
|
+$ sign
|
|
$~ [%behn %wake ~]
|
|
$% [%behn $>(%wake gift)]
|
|
==
|
|
::
|
|
+$ behn-state
|
|
$: %2
|
|
timers=(tree [key=@da val=(qeu duct)])
|
|
unix-duct=duct
|
|
next-wake=(unit @da)
|
|
drips=drip-manager
|
|
==
|
|
::
|
|
++ timer-map ((ordered-map ,@da ,(qeu duct)) lte)
|
|
::
|
|
+$ drip-manager
|
|
$: count=@ud
|
|
movs=(map @ud vase)
|
|
==
|
|
::
|
|
+$ timer [date=@da =duct]
|
|
--
|
|
::
|
|
=>
|
|
~% %behn ..part ~
|
|
|%
|
|
++ per-event
|
|
=| moves=(list move)
|
|
|= [[now=@da =duct] state=behn-state]
|
|
::
|
|
|%
|
|
::
|
|
+| %helpers
|
|
::
|
|
++ this .
|
|
++ emit |=(m=move this(moves [m moves]))
|
|
++ abet
|
|
^+ [moves state]
|
|
:: moves are statefully pre-flopped to ensure that
|
|
:: any prepended %doze is emitted first
|
|
::
|
|
=. moves (flop moves)
|
|
=/ new=(unit @da) (bind (pry:timer-map timers.state) head)
|
|
:: emit %doze if needed
|
|
::
|
|
=? ..this
|
|
?~ unix-duct.state |
|
|
=/ dif=[old=(unit @da) new=(unit @da)] [next-wake.state new]
|
|
?+ dif ~|([%unpossible dif] !!)
|
|
[~ ~] | :: no-op
|
|
[~ ^] & :: set
|
|
[^ ~] & :: clear
|
|
[^ ^] !=(u.old.dif u.new.dif) :: set if changed
|
|
==
|
|
(emit(next-wake.state new) [unix-duct.state %give %doze new])
|
|
::
|
|
[moves state]
|
|
::
|
|
+| %entry-points
|
|
::
|
|
++ call
|
|
|= [=task error=(unit tang)]
|
|
^+ this
|
|
?: ?& ?=(^ error)
|
|
!?=(%wake -.task)
|
|
==
|
|
:: XX more and better error handling
|
|
::
|
|
~& %behn-crud-not-wake^-.task
|
|
(emit [duct %slip %d %flog %crud -.task u.error])
|
|
::
|
|
?- -.task
|
|
%born this(next-wake.state ~, unix-duct.state duct)
|
|
%drip (drip p.task)
|
|
%huck (emit [duct %give %heck syn.task])
|
|
%rest this(timers.state (unset-timer [p.task duct]))
|
|
%trim this
|
|
%vega this
|
|
%wait this(timers.state (set-timer [p.task duct]))
|
|
%wake (wake(next-wake.state ~) error)
|
|
==
|
|
::
|
|
:: +take-drip: the future is now, %give the deferred move
|
|
::
|
|
++ take-drip
|
|
|= [num=@ud error=(unit tang)]
|
|
^+ this
|
|
=/ drip (~(got by movs.drips.state) num)
|
|
%- emit(movs.drips.state (~(del by movs.drips.state) num))
|
|
=/ card [%give %meta drip]
|
|
?~ error
|
|
[duct card]
|
|
=/ =tang
|
|
(weld u.error `tang`[leaf/"drip failed" ~])
|
|
:: XX should be
|
|
:: [duct %hurl fail/tang card]
|
|
::
|
|
[duct %pass /drip-slog %d %flog %crud %drip-fail tang]
|
|
::
|
|
+| %tasks
|
|
::
|
|
:: +drip: enqueue a future gift (as a vase), %pass ourselves a %wait
|
|
::
|
|
++ drip
|
|
|= vax=vase
|
|
^+ this
|
|
%. [duct %pass /drip/(scot %ud count.drips.state) %b %wait +(now)]
|
|
%= emit
|
|
movs.drips.state (~(put by movs.drips.state) count.drips.state vax)
|
|
count.drips.state +(count.drips.state)
|
|
==
|
|
::
|
|
:: +wake: unix says wake up; process the elapsed timer (or forward error)
|
|
::
|
|
++ wake
|
|
|= error=(unit tang)
|
|
^+ this
|
|
?: =(~ timers.state)
|
|
:: no-op on spurious but innocuous unix wakeups
|
|
::
|
|
~? ?=(^ error) %behn-wake-no-timer^u.error
|
|
this
|
|
=/ [=timer later-timers=_timers.state] pop-timer
|
|
?: (gth date.timer now)
|
|
:: no-op if timer is early, (+abet will reset)
|
|
::
|
|
this
|
|
:: pop the first timer and notify client vane,
|
|
:: forwarding error if present
|
|
::
|
|
:: XX %wake errors should be signaled out-of-band
|
|
:: [duct.timer %hurl goof %give %wake ~]
|
|
::
|
|
(emit(timers.state later-timers) [duct.timer %give %wake error])
|
|
::
|
|
+| %implementation
|
|
::
|
|
:: +pop-timer: dequeue and produce earliest timer
|
|
::
|
|
++ pop-timer
|
|
^+ [*timer timers.state]
|
|
=^ [date=@da dux=(qeu ^duct)] timers.state (pop:timer-map timers.state)
|
|
=^ dut dux ~(get to dux)
|
|
:- [date dut]
|
|
?: =(~ dux)
|
|
timers.state
|
|
(put:timer-map timers.state date dux)
|
|
:: +set-timer: set a timer, maintaining order
|
|
::
|
|
++ set-timer
|
|
~% %set-timer ..part ~
|
|
|= t=timer
|
|
^+ timers.state
|
|
=/ found (find-ducts date.t)
|
|
(put:timer-map timers.state date.t (~(put to found) duct.t))
|
|
:: +find-ducts: get timers at date
|
|
::
|
|
:: TODO: move to +ordered-map
|
|
::
|
|
++ find-ducts
|
|
|= date=@da
|
|
^- (qeu ^duct)
|
|
?~ timers.state ~
|
|
?: =(date key.n.timers.state)
|
|
val.n.timers.state
|
|
?: (lte date key.n.timers.state)
|
|
$(timers.state l.timers.state)
|
|
$(timers.state r.timers.state)
|
|
:: +unset-timer: cancel a timer; if it already expired, no-op
|
|
::
|
|
++ unset-timer
|
|
|= t=timer
|
|
^+ timers.state
|
|
=/ [found=? dux=(qeu ^duct)]
|
|
=/ dux (find-ducts date.t)
|
|
|- ^- [found=? dux=(qeu ^duct)]
|
|
?~ dux |+~
|
|
?: =(duct.t n.dux) &+~(nip to `(qeu ^duct)`dux)
|
|
=^ found-left=? l.dux $(dux l.dux)
|
|
?: found-left &+dux
|
|
=^ found-rite=? r.dux $(dux r.dux)
|
|
[found-rite dux]
|
|
?. found timers.state
|
|
?: =(~ dux)
|
|
+:(del:timer-map timers.state date.t)
|
|
(put:timer-map timers.state date.t dux)
|
|
--
|
|
--
|
|
::
|
|
=| behn-state
|
|
=* state -
|
|
|= [now=@da eny=@uvJ rof=roof]
|
|
=* behn-gate .
|
|
^?
|
|
|%
|
|
:: +call: handle a +task:behn request
|
|
::
|
|
++ call
|
|
~% %behn-call ..part ~
|
|
|= $: hen=duct
|
|
dud=(unit goof)
|
|
wrapped-task=(hobo task)
|
|
==
|
|
^- [(list move) _behn-gate]
|
|
=/ =task ((harden task) wrapped-task)
|
|
=/ event-core (per-event [now hen] state)
|
|
=^ moves state
|
|
abet:(call:event-core task ?~(dud ~ `tang.u.dud))
|
|
[moves behn-gate]
|
|
:: +load: migrate an old state to a new behn version
|
|
::
|
|
++ load
|
|
|= old=behn-state
|
|
^+ behn-gate
|
|
behn-gate(state old)
|
|
:: +scry: view timer state
|
|
::
|
|
:: TODO: not referentially transparent w.r.t. elapsed timers,
|
|
:: which might or might not show up in the product
|
|
::
|
|
++ scry
|
|
^- roon
|
|
|= [lyc=gang car=term bem=beam]
|
|
^- (unit (unit cage))
|
|
=* ren car
|
|
=* why=shop &/p.bem
|
|
=* syd q.bem
|
|
=* lot=coin $/r.bem
|
|
=* tyl s.bem
|
|
::
|
|
::TODO don't special-case whey scry
|
|
::
|
|
?: &(=(ren %$) =(tyl /whey))
|
|
=/ maz=(list mass)
|
|
:~ timers+&+timers.state
|
|
==
|
|
``mass+!>(maz)
|
|
:: only respond for the local identity, %$ desk, current timestamp
|
|
::
|
|
?. ?& =(&+our why)
|
|
=([%$ %da now] lot)
|
|
=(%$ syd)
|
|
==
|
|
~
|
|
:: /bx/debug/timers (list [@da duct]) all timers and their ducts
|
|
:: /bx/timers (list @da) all timer timestamps
|
|
:: /bx/timers/next (unit @da) the very next timer to fire
|
|
:: /bx/timers/[da] (list @da) all timers up to and including da
|
|
::
|
|
?. ?=(%x ren) ~
|
|
?+ tyl [~ ~]
|
|
[%debug %timers ~]
|
|
:^ ~ ~ %noun
|
|
!> ^- (list [@da duct])
|
|
%- zing
|
|
%+ turn (tap:timer-map timers)
|
|
|= [date=@da q=(qeu duct)]
|
|
%+ turn ~(tap to q)
|
|
|=(d=duct [date d])
|
|
::
|
|
[%timers ~]
|
|
:^ ~ ~ %noun
|
|
!> ^- (list @da)
|
|
%- zing
|
|
%+ turn (tap:timer-map timers)
|
|
|= [date=@da q=(qeu duct)]
|
|
(reap ~(wyt in q) date)
|
|
::
|
|
[%timers %next ~]
|
|
:^ ~ ~ %noun
|
|
!> ^- (unit @da)
|
|
(bind (pry:timer-map timers) head)
|
|
::
|
|
[%timers @ ~]
|
|
?~ til=(slaw %da i.t.tyl)
|
|
[~ ~]
|
|
:^ ~ ~ %noun
|
|
!> ^- (list @da)
|
|
=/ tiz=(list [date=@da q=(qeu duct)])
|
|
(tap:timer-map timers)
|
|
|- ^- (list @da)
|
|
?~ tiz ~
|
|
?: (gth date.i.tiz u.til) ~
|
|
%+ weld
|
|
(reap ~(wyt in q.i.tiz) date.i.tiz)
|
|
$(tiz t.tiz)
|
|
==
|
|
::
|
|
++ stay state
|
|
++ take
|
|
|= [tea=wire hen=duct dud=(unit goof) hin=sign]
|
|
^- [(list move) _behn-gate]
|
|
?^ dud
|
|
~|(%behn-take-dud (mean tang.u.dud))
|
|
::
|
|
?> ?=([%drip @ ~] tea)
|
|
=/ event-core (per-event [now hen] state)
|
|
=^ moves state
|
|
abet:(take-drip:event-core (slav %ud i.t.tea) error.hin)
|
|
[moves behn-gate]
|
|
--
|