shrub/pkg/arvo/lib/hood/kiln.hoon
Philip Monk 3efce771d5 kiln: add once flag to |install
It's often useful to |merge a desk, but if you're still getting updates
from your sync source, you may get overwritten in the future.  In this
case, you want to merge and clear the sync source.  With this change,
you can do this with:

```
|install ~ship %desk, =once &
```
2023-01-12 12:38:28 -07:00

1385 lines
40 KiB
Plaintext

/- *hood
/+ strandio
=, clay
=, space:userlib
=, format
=* dude dude:gall
|%
+$ state state-10
+$ state-10 [%10 pith-10]
+$ state-9 [%9 pith-9]
+$ state-8 [%8 pith-9]
+$ state-7 [%7 pith-7]
+$ state-6 [%6 pith-6]
+$ state-5 [%5 pith-5]
+$ state-4 [%4 pith-4]
+$ state-3 [%3 pith-3]
+$ state-2 [%2 pith-2]
+$ state-1 [%1 pith-1]
+$ state-0 [%0 pith-0]
+$ any-state
$~ *state
$% state-10
state-9
state-8
state-7
state-6
state-5
state-4
state-3
state-2
state-1
state-0
==
::
+$ pith-10
$: rem=(map desk per-desk)
nyz=@ud
zyn=(map kiln-sync sync-state)
commit-timer=[way=wire nex=@da tim=@dr mon=term]
:: map desk to the currently ongoing fuse request
:: and the latest version numbers for beaks to
fus=(map desk per-fuse)
:: used for fuses - every time we get a fuse we
:: bump this. used when calculating hashes to
:: ensure they're unique even when the same
:: request is made multiple times.
hxs=(map desk @ud)
==
::
+$ pith-9
$: wef=(unit weft)
rem=(map desk per-desk)
syn=(map kiln-sync let=@ud)
ark=(map desk arak-9)
commit-timer=[way=wire nex=@da tim=@dr mon=term]
:: map desk to the currently ongoing fuse request
:: and the latest version numbers for beaks to
fus=(map desk per-fuse)
:: used for fuses - every time we get a fuse we
:: bump this. used when calculating hashes to
:: ensure they're unique even when the same
:: request is made multiple times.
hxs=(map desk @ud)
==
::
:: $rein-9: diff from desk manifest
::
:: .liv: suspended? if suspended, no agents should run
:: .add: agents not in manifest that should be running
:: .sub: agents in manifest that should not be running
::
+$ rein-9
$: liv=_&
add=(set dude)
sub=(set dude)
==
::
+$ pith-7
$: wef=(unit weft)
rem=(map desk per-desk)
syn=(map kiln-sync let=@ud)
ark=(map desk arak-7)
commit-timer=[way=wire nex=@da tim=@dr mon=term]
:: map desk to the currently ongoing fuse request
:: and the latest version numbers for beaks to
fus=(map desk per-fuse)
:: used for fuses - every time we get a fuse we
:: bump this. used when calculating hashes to
:: ensure they're unique even when the same
:: request is made multiple times.
hxs=(map desk @ud)
==
::
+$ arak-9
$: rail=(unit rail-9)
rein=rein-9
==
::
++ rail-9
$: publisher=(unit ship)
paused=?
=ship
=desk
=aeon
next=(list rung)
==
::
+$ arak-7
$: rail=(unit rail-7)
rein=rein-9
==
::
+$ rail-7
$: paused=?
=ship
=desk
=aeon
next=(list rung)
==
::
+$ pith-6
$: wef=(unit weft)
rem=(map desk per-desk) ::
syn=(map kiln-sync let=@ud) ::
ark=(map desk arak-6) ::
commit-timer=[way=wire nex=@da tim=@dr mon=term] ::
:: map desk to the currently ongoing fuse request
:: and the latest version numbers for beaks to
fus=(map desk per-fuse)
:: used for fuses - every time we get a fuse we
:: bump this. used when calculating hashes to
:: ensure they're unique even when the same
:: request is made multiple times.
hxs=(map desk @ud)
== ::
::
+$ arak-6 [rail=rail-6 next=(list rung) rein=rein-9]
+$ rail-6 [paused=? =ship =desk =aeon]
::
+$ pith-5
$: rem=(map desk per-desk) ::
syn=(map kiln-sync let=@ud) ::
ark=(map desk arak-6) ::
commit-timer=[way=wire nex=@da tim=@dr mon=term] ::
:: map desk to the currently ongoing fuse request
:: and the latest version numbers for beaks to
fus=(map desk per-fuse)
:: used for fuses - every time we get a fuse we
:: bump this. used when calculating hashes to
:: ensure they're unique even when the same
:: request is made multiple times.
hxs=(map desk @ud)
== ::
::
+$ pith-4 ::
$: rem=(map desk per-desk) ::
syn=(map kiln-sync let=@ud) ::
ark=(map desk arak-4) ::
commit-timer=[way=wire nex=@da tim=@dr mon=term] ::
:: map desk to the currently ongoing fuse request
:: and the latest version numbers for beaks to
fus=(map desk per-fuse)
:: used for fuses - every time we get a fuse we
:: bump this. used when calculating hashes to
:: ensure they're unique even when the same
:: request is made multiple times.
hxs=(map desk @ud)
== ::
+$ arak-4
$: =ship
=desk
=aeon
next=(list rung)
rein=rein-9
==
+$ pith-3 ::
$: rem=(map desk per-desk) ::
syn=(map kiln-sync let=@ud) ::
ark=(map desk arak-3) ::
commit-timer=[way=wire nex=@da tim=@dr mon=term] ::
:: map desk to the currently ongoing fuse request
:: and the latest version numbers for beaks to
fus=(map desk per-fuse)
:: used for fuses - every time we get a fuse we
:: bump this. used when calculating hashes to
:: ensure they're unique even when the same
:: request is made multiple times.
hxs=(map desk @ud)
==
+$ arak-3
$: =ship
=desk
=aeon
next=(list rung)
rein=rein-3
==
+$ rein-3
$: add=(set dude)
sub=(set dude)
==
::
+$ pith-2 ::
$: rem=(map desk per-desk) ::
syn=(map kiln-sync let=@ud) ::
ota=(unit [=ship =desk =aeon]) ::
commit-timer=[way=wire nex=@da tim=@dr mon=term] ::
fus=(map desk per-fuse)
hxs=(map desk @ud)
== ::
+$ pith-1 ::
$: rem=(map desk per-desk) ::
syn=(map kiln-sync let=@ud) ::
ota=(unit [=ship =desk =aeon]) ::
commit-timer=[way=wire nex=@da tim=@dr mon=term] ::
== ::
+$ pith-0 ::
$: rem=(map desk per-desk) ::
syn=(map kiln-sync let=@ud) ::
autoload-on=? ::
cur-hoon=@uvI ::
cur-arvo=@uvI ::
cur-zuse=@uvI ::
cur-vanes=(map @tas @uvI) ::
commit-timer=[way=wire nex=@da tim=@dr mon=term] ::
==
+$ per-desk :: per-desk state
$: auto=? :: escalate on failure
gem=?(%this %that germ) :: strategy
her=@p :: from ship
sud=@tas :: from desk
cas=case :: at case
==
+$ per-fuse :: per fuse state
:: map [ship desk] to latest version number we
:: have for them. used for things we're %trak-ing
:: our invariant here is to store the latest version
:: number we've heard of.
$: mox=(map [ship desk] let=@ud)
:: relevant parts of originating request
kf=kiln-fuse-data
==
+$ kiln-commit term ::
+$ kiln-mount ::
$: pax=path ::
pot=term ::
==
+$ kiln-unmount $@(term [knot path]) ::
+$ kiln-sync ::
$: syd=desk :: local desk
her=ship :: foreign ship
sud=desk :: foreign desk
==
+$ kiln-unsync ::
$: syd=desk :: local desk
her=ship :: foreign ship
sud=desk :: foreign desk
==
+$ kiln-merge ::
$@ ~
$: syd=desk ::
ali=ship ::
sud=desk ::
cas=case ::
gim=?(%auto germ) ::
==
+$ fuse-source [who=ship des=desk ver=$@(%trak case)]
:: actual poke
+$ kiln-fuse
$@ ~
$: syd=desk
$@ ~ :: signifies clearing the fuse
$: overwrite=flag :: force overwrite previous fuse
bas=fuse-source
con=(list [fuse-source germ])
==
==
:: state tracked by kiln
+$ kiln-fuse-data
$: syd=desk
bas=fuse-source
con=(list [fuse-source germ])
==
:: Request to list current fuses. ~ means "list all"
::
+$ kiln-fuse-list (unit desk)
--
|= [bowl:gall state]
?> =(src our)
=| moz=(list card:agent:gall)
|%
++ kiln .
++ abet :: resolve
[(flop moz) `state`+<+.$]
::
++ emit
|= card:agent:gall
%_(+> moz [+< moz])
::
++ emil :: return cards
|= (list card:agent:gall)
^+ +>
?~(+< +> $(+< t.+<, +> (emit i.+<)))
:: +fmt: format string for slogging
::
++ fmt
|= mes=tape
[%0 %leaf (weld "kiln: " mes)]
::
++ render
|= [mez=tape sud=desk who=ship syd=desk kid=(unit desk)]
:^ %palm [" " ~ ~ ~] leaf+(weld "kiln: " mez)
:^ leaf+"from {<sud>}" leaf+"on {<who>}" leaf+"to {<syd>}"
?~ kid ~
[leaf+"then {<u.kid>}" ~]
::
++ sources
=/ zyns=(list [[syd=desk her=ship sud=desk] *]) ~(tap by zyn)
=| sources=(map desk [ship desk])
|- ^+ sources
?~ zyns
sources
=. sources (~(put by sources) -.i.zyns)
$(zyns t.zyns)
::
++ on-init
=< abet
~> %slog.(fmt "boot")
::
=+ .^(desks=(set desk) %cd /(scot %p our)//(scot %da now))
=. desks (~(del in desks) %base)
=. desks (~(del in desks) %kids)
::
=/ sop=ship (sein:title our now our)
:: set up base desk
::
=? ..on-init ?=(?(%earl %duke %king) (clan:title our))
abet:init:(apex:(sync %base sop %kids) `%kids)
:: install other desks and make them public
::
=/ dez=(list desk) ~(tap in desks)
|- ^+ ..on-init
?~ dez ..on-init
=. ..on-init
(emit %pass /kiln/init-zest %arvo %c %zest i.dez %live)
=. ..on-init
%- emit
:^ %pass /kiln/permission %arvo
[%c %perm i.dez / %r `[%black ~]]
=/ src (get-publisher our i.dez now)
=? ..on-init &(?=(^ src) !=(our u.src))
abet:init:(sync i.dez u.src i.dez)
$(dez t.dez)
::
++ on-load
=> |%
+$ ota [syd=desk her=ship sud=desk]
--
=| old-ota=(unit ota)
|= [hood-version=@ud old=any-state]
=/ old-version -.old
=* state +<+.$.abet
::
=? old-ota ?=(%0 -.old)
=/ syncs=(list [ota =aeon]) ~(tap by syn.old)
|- ^- (unit ota)
?~ syncs
~
?: &(=([%base %kids] [syd sud]:i.syncs) !=(our her.i.syncs))
`[syd her sud]:i.syncs
$(syncs t.syncs)
::
=? old ?=(%0 -.old)
=? syn.old ?=(^ old-ota) (~(del by syn.old) u.old-ota)
[%3 [rem syn ark=~ commit-timer fus=~ hxs=~]:old]
::
=? old ?=(%1 -.old)
:* %2
rem.old
syn.old
ota.old
commit-timer.old
fus=~
hxs=~
==
::
=? old-ota ?=(%2 -.old)
?~ ota.old ~
`[%base ship desk]:u.ota.old
::
=? old ?=(%2 -.old)
:* %3
rem.old
syn.old
ark=~
commit-timer.old
fus.old
hxs.old
==
::
=? old ?=(%3 -.old)
:- %4
+.old(ark (~(run by ark.old) |=(a=arak-3 a(rein [liv=& rein.a]))))
::
=? old ?=(%4 -.old)
:- %5
=- +.old(ark -)
%- ~(run by ark.old)
|= a=arak-4
^- arak-6
[[paused=| ship desk aeon] next rein]:a
::
=? old ?=(%5 -.old)
[%6 ~ +.old]
::
=? old ?=(%6 -.old)
:- %7
=- +.old(ark -)
%- ~(run by ark.old)
|= a=arak-6
^- arak-7
:_ rein.a
^- (unit rail-7)
`[paused.rail ship.rail desk.rail aeon.rail next]:a
::
=? old ?=(%7 -.old)
:- %8
=- +.old(ark -)
%- ~(gas by *(map desk arak-9))
%+ turn ~(tap by ark.old)
|= [d=desk a=arak-7]
^- [desk arak-9]
:- d
:_ rein.a
?~ rail.a ~
`[(get-publisher our d now) u.rail.a]
::
=? old ?=(%8 -.old)
[%9 +.old]
::
=^ cards-9=(list card:agent:gall) old
?. ?=(%9 -.old)
`old
=/ syn=(set kiln-sync)
%- ~(gas in ~(key by syn.old))
%+ murn ~(tap by ark.old)
|= [=desk =arak-9]
?~ rail.arak-9
~
?: paused.u.rail.arak-9
~
`u=[desk ship.u.rail.arak-9 desk.u.rail.arak-9]
=/ zet=(list [desk zest])
%+ murn ~(tap by ark.old)
|= [=desk =arak-9]
^- (unit [^desk zest])
?: liv.rein.arak-9
`[desk %held]
?~ rail.arak-9
~
?: paused.u.rail.arak-9
~
`[desk %held]
::
:_ [%10 |1.+.old(syn 0, ark ~)]
;: weld
%+ turn zet
|= [=desk =zest]
[%pass /kiln/load-zest %arvo %c %zest desk zest]
::
%+ turn ~(tap in syn)
|= k=kiln-sync
[%pass /kiln/load-sync %agent [our %hood] %poke %kiln-sync !>(k)]
::
=/ ks ~(tap in syn)
|- ^- (list card:agent:gall)
?~ ks
~
?: =(%base syd.i.ks)
:_ ~
:* %pass /kiln/load-kids %agent [our %hood]
%poke %kiln-kids !>([i.ks `%kids])
==
$(ks t.ks)
==
::
?> ?=(%10 -.old)
=. state old
abet:(emil cards-9)
::
++ on-peek
|= =path
^- (unit (unit cage))
?+ path [~ ~]
[%x %kiln %our ~] ``noun+!>(our)
[%x %kiln %lag ~]
``loob+!>(.^(? //(scot %p our)//(scot %da now)/zen/lag))
::
[%x %kiln %base-hash ~]
=/ ver (mergebase-hashes our %base now (~(got by sources) %base))
``noun+!>(?~(ver 0v0 i.ver))
::
[%x %kiln %syncs ~] ``noun+!>(zyn)
[%x %kiln %sources ~] ``noun+!>(sources)
[%x %kiln %pikes ~]
=+ .^(=rock:tire %cx /(scot %p our)//(scot %da now)/tire)
:^ ~ ~ %kiln-pikes
!> ^- pikes
%- ~(rut by rock)
|= [=desk =zest wic=(set weft)]
^- pike
=+ .^(hash=@uv %cz /(scot %p our)/[desk]/(scot %da now))
=/ sync (~(get by sources) desk)
[sync hash zest wic]
==
::
:: +get-germ: select merge strategy into local desk
::
:: If destination desk doesn't exist, need a %init merge. Otherwise,
:: we just want what the remote has, so we use %only-that.
::
++ get-germ
|= =desk
=+ .^(=cass:clay %cw /(scot %p our)/[desk]/(scot %da now))
?- ud.cass
%0 %init
* %only-that
==
::
++ poke
|= [=mark =vase]
?+ mark ~|([%poke-kiln-bad-mark mark] !!)
%kiln-autocommit =;(f (f !<(_+<.f vase)) poke-autocommit)
%kiln-bump =;(f (f !<(_+<.f vase)) poke-bump)
%kiln-cancel =;(f (f !<(_+<.f vase)) poke-cancel)
%kiln-cancel-autocommit =;(f (f !<(_+<.f vase)) poke-cancel-autocommit)
%kiln-commit =;(f (f !<(_+<.f vase)) poke-commit)
%kiln-fuse =;(f (f !<(_+<.f vase)) poke-fuse)
%kiln-fuse-list =;(f (f !<(_+<.f vase)) poke-fuse-list)
%kiln-gall-sear =;(f (f !<(_+<.f vase)) poke-gall-sear)
%kiln-info =;(f (f !<(_+<.f vase)) poke-info)
%kiln-install =;(f (f !<(_+<.f vase)) poke-install)
%kiln-kids =;(f (f !<(_+<.f vase)) poke-kids)
%kiln-label =;(f (f !<(_+<.f vase)) poke-label)
%kiln-merge =;(f (f !<(_+<.f vase)) poke-merge)
%kiln-mount =;(f (f !<(_+<.f vase)) poke-mount)
%kiln-nuke =;(f (f !<(_+<.f vase)) poke-nuke)
%kiln-pause =;(f (f !<(_+<.f vase)) poke-pause)
%kiln-permission =;(f (f !<(_+<.f vase)) poke-permission)
%kiln-revive =;(f (f !<(_+<.f vase)) poke-revive)
%kiln-rein =;(f (f !<(_+<.f vase)) poke-rein)
%kiln-rm =;(f (f !<(_+<.f vase)) poke-rm)
%kiln-schedule =;(f (f !<(_+<.f vase)) poke-schedule)
%kiln-suspend =;(f (f !<(_+<.f vase)) poke-suspend)
%kiln-sync =;(f (f !<(_+<.f vase)) poke-sync)
%kiln-syncs =;(f (f !<(_+<.f vase)) poke-syncs)
%kiln-uninstall =;(f (f !<(_+<.f vase)) poke-uninstall)
%kiln-unmount =;(f (f !<(_+<.f vase)) poke-unmount)
%kiln-unsync =;(f (f !<(_+<.f vase)) poke-unsync)
==
::
++ poke-autocommit
|= [mon=kiln-commit auto=?]
=< abet
=. +>.$ (emit %pass /commit %arvo %c [%dirk mon])
?. auto
+>.$
=/ recur ~s1
=. commit-timer
[/kiln/autocommit (add now recur) recur mon]
(emit %pass way.commit-timer %arvo %b [%wait nex.commit-timer])
::
++ poke-bump
|= ~
=< abet
=+ .^(=rock:tire %cx /(scot %p our)//(scot %da now)/tire)
=/ wic
%+ sort ~(tap by wic:(~(got by rock) %base))
|= [[* a=@ud] [* b=@ud]]
(gth a b)
=. wic (skip wic |=([* a=@ud] (gte a zuse)))
?~ wic
%- (slog 'kiln: %base already up-to-date' ~)
..abet
=/ kel i.wic
%- emil
=/ cards
%+ murn ~(tap by rock)
|= [=desk =zest wic=(set weft)]
?: |(=(%base desk) !?=(%live zest) (~(has in wic) kel))
~
`u=[%pass /kiln/bump/[desk] %arvo %c %zest desk %held]
?~ cards
[%pass /kiln/bump/wick %arvo %c %wick ~]~
cards
::
++ poke-cancel
|= a=@tas
abet:(emit %pass /cancel %arvo %c [%drop a])
::
++ poke-cancel-autocommit
|= ~
abet:(emit %pass way.commit-timer %arvo %b [%rest nex.commit-timer])
::
++ poke-commit
|= [mon=kiln-commit auto=?]
=< abet
=. +>.$ (emit %pass /commit %arvo %c [%dirk mon])
?. auto
+>.$
=/ recur ~s1
=. commit-timer
[/kiln/autocommit (add now recur) recur mon]
(emit %pass way.commit-timer %arvo %b [%wait nex.commit-timer])
::
++ poke-fuse-list
=>
|%
++ format-fuse
|= [into=desk pf=per-fuse]
^- tank
=/ sources=tape
%+ reel
con.kf.pf
|= [[fs=fuse-source g=germ] acc=tape]
^- tape
:(weld " [" (format-fuse-source fs) " " <g> "]" acc)
:- %leaf
;: weld
"|fuse {<into>} "
(format-fuse-source bas.kf.pf)
sources
==
:: +format-fuse-source: fuse source -> beak -> path
::
++ format-fuse-source
|= fs=fuse-source
^- tape
=/ bec=beak [who.fs des.fs ?:(?=([%trak] ver.fs) [%tas %track] ver.fs)]
<(en-beam [bec /])>
--
|= k=kiln-fuse-list
^+ abet
%. abet
?~ k
?~ fus
(slog [leaf+"no ongoing fuses" ~])
%- slog
%+ roll
~(tap by `(map desk per-fuse)`fus)
|= [[syd=desk pf=per-fuse] acc=tang]
^- tang
[(format-fuse syd pf) acc]
=/ pfu=(unit per-fuse) (~(get by fus) u.k)
?~ pfu
(slog [leaf+"no ongoing fuse for {<u.k>}" ~])
(slog [(format-fuse u.k u.pfu) ~])
::
++ poke-fuse
|= k=kiln-fuse
?~ k abet
=/ payload +.k
?~ payload
:: cancelling an ongoing fuse
%- (slog [leaf+"cancelling fuse into {<syd.k>}" ~])
=/ f (fuzz syd.k now)
?~ f
abet
abet:abet:delete:u.f
?: &(!overwrite.payload (~(has by fus) syd.k))
((slog [leaf+"existing fuse into {<syd.k>} - need =overwrite &" ~]) abet)
=. fus (~(put by fus) syd.k [~ [syd.k bas.payload con.payload]])
=/ old-cnt=@ud (~(gut by hxs) syd.k 0)
=. hxs (~(put by hxs) syd.k +(old-cnt))
=/ f (fuzz syd.k now)
?~ f
abet
abet:abet:fuse:u.f
::
++ poke-gall-sear
|= =ship
abet:(emit %pass /kiln %arvo %g %sear ship)
::
++ poke-info
|= [mez=tape tor=(unit toro)]
?~ tor
abet:(spam leaf+mez ~)
abet:(emit:(spam leaf+mez ~) %pass /kiln %arvo %c [%info u.tor])
::
++ poke-install
|= [loc=desk her=ship rem=desk once=?]
=+ .^(=rock:tire %cx /(scot %p our)//(scot %da now)/tire)
=/ =zest
?~ got=(~(get by rock) loc)
%dead
zest.u.got
=. zyn
?~ got=(~(get by sources) loc)
zyn
(~(del by zyn) loc u.got)
=? ..abet ?=(%dead zest)
(emit %pass /kiln/install %arvo %c %zest loc ?:(=(our her) %live %held))
?: (~(has by zyn) loc her rem)
abet:(spam (render "already syncing" loc her rem ~) ~)
?: =([our loc] [her rem])
abet
?: once
abet:abet:(merge:(work loc) her rem da+now %only-that)
=/ sun (sync loc her rem)
~> %slog.(fmt "beginning install into {here:sun}")
=< abet:abet:init
?: =(%base loc)
(apex:sun `%kids)
sun
::
++ poke-kids
|= [hos=kiln-sync nex=(unit desk)]
abet:abet:(apex:(sync hos) nex)
::
++ poke-label
|= [syd=desk lab=@tas aey=(unit aeon)]
=+ pax=/(scot %p our)/[syd]/[lab]
(poke-info "labeled {(spud pax)}" `[syd %| lab aey])
::
++ poke-merge
|= kiln-merge
?~ +< abet
abet:abet:(merge:(work syd) ali sud cas gim)
::
++ poke-mount
|= kiln-mount
=+ bem=(de-beam pax)
?~ bem
=+ "can't mount bad path: {<pax>}"
abet:(spam leaf+- ~)
abet:(emit %pass /mount %arvo %c [%mont pot u.bem])
::
++ poke-nuke
|= [=term desk=?]
=< abet
?. desk
(emit %pass /nuke %arvo %g [%nuke term])
%- emil
%+ turn (get-apps-have our term now)
|=([=dude ?] [%pass /nuke %arvo %g [%nuke dude]])
::
++ poke-pause
|= =desk
?~ got=(~(get by sources) desk)
abet:(spam leaf+"desk not installed: {<desk>}" ~)
(poke-unsync desk u.got)
::
++ poke-permission
|= [syd=desk pax=path pub=?]
=< abet
%- emit
=/ =rite [%r ~ ?:(pub %black %white) ~]
[%pass /kiln/permission %arvo %c [%perm syd pax rite]]
::
++ poke-rein
|= [=desk =rein]
abet:(emit %pass /kiln/rein %arvo %c %rein desk rein)
::
++ poke-revive
|= =desk
abet:(emit %pass /kiln/revive %arvo %c %zest desk %live)
::
++ poke-rm
|= a=path
=+ b=.^(arch %cy a)
?~ fil.b
=+ ~[leaf+"No such file:" leaf+"{<a>}"]
abet:(spam -)
(poke-info "removed" `(fray a))
::
++ poke-schedule
|= [where=path tym=@da eve=@t]
=. where (welp where /sched)
%+ poke-info "scheduled"
=+ old=;;((map @da cord) (fall (file where) ~))
`(foal where %sched !>((~(put by old) tym eve)))
::
++ poke-suspend
|= =desk
abet:(emit %pass /kiln/suspend %arvo %c %zest desk %dead)
::
++ poke-sync
|= hos=kiln-sync
?: (~(has by zyn) hos)
abet:(spam (render "already syncing" [sud her syd ~]:hos) ~)
~> %slog.(fmt "beginning sync into {<syd.hos>} from {<her.hos>}/{<sud.hos>}")
abet:abet:init:(sync hos)
::
++ poke-syncs :: print sync config
|= ~
=< abet %- spam
?: =(0 ~(wyt by zyn))
[%leaf "no syncs configured"]~
%+ turn ~(tap by zyn)
|= [kiln-sync sync-state]
(render "sync configured" sud her syd kid)
::
++ poke-uninstall
|= loc=desk
?~ got=(~(get by sources) loc)
abet:(spam leaf+"desk not installed: {<loc>}" ~)
=. ..on-init (emit %pass /kiln/uninstall %arvo %c %zest loc %dead)
(poke-unsync loc u.got)
::
++ poke-unmount
|= mon=kiln-unmount
?^ mon
=+ bem=(de-beam mon)
?~ bem
=+ "can't unmount bad path: {<mon>}"
abet:(spam leaf+- ~)
abet:(emit %pass /unmount-beam %arvo %c [%ogre [[p q r] s]:u.bem])
abet:(emit %pass /unmount-point %arvo %c [%ogre mon])
::
:: Don't need to cancel anything because new syncs will get a new nonce
::
++ poke-unsync
|= hus=kiln-unsync
?~ got=(~(get by zyn) hus)
abet:(spam (render "not syncing" [sud her syd ~]:hus) ~)
=. zyn (~(del by zyn) hus)
abet:(spam (render "cancelling sync" sud.hus her.hus syd.hus kid.u.got) ~)
:: +peer: handle %watch
::
++ peer
|= =path
?> (team:title our src)
?: =(0 1) abet :: avoid mint-vain
?+ path ~|(kiln-path/path !!)
[%vats ~]
(mean leaf+"kiln: old subscription to /kiln/vats failed" ~)
==
::
++ take-agent
|= [=wire =sign:agent:gall]
?+ wire
?: ?=(%poke-ack -.sign)
~? ?=(^ p.sign) [%kiln-poke-nack u.p.sign]
abet
~|([%kiln-bad-take-agent wire -.sign] !!)
::
[%fancy *]
?> ?=(%poke-ack -.sign)
(take-coup-fancy t.wire p.sign)
::
[%spam *]
?> ?=(%poke-ack -.sign)
(take-coup-spam t.wire p.sign)
::
[%link @ ~]
?> ?=(%poke-ack -.sign)
~> %slog.(fmt "linked {<`@tas`i.t.wire>} to console")
abet
==
::
++ take-arvo
|= [=wire =sign-arvo]
^+ abet
?- wire
[%sync %merg *] abet
[%find-ship *] abet
[%sync *] abet
[%zinc *] (take-sync t.wire sign-arvo)
[%autocommit *] %+ take-wake-autocommit t.wire
?>(?=(%wake +<.sign-arvo) +>.sign-arvo)
[%vats *] abet
[%fuse-request @tas *]
=/ f (fuzz i.t.wire now)
?~ f
abet
abet:abet:(take:u.f t.t.wire sign-arvo)
[%fuse @tas *] ?> ?=(%mere +<.sign-arvo)
=/ syd=desk i.t.wire
?. ?=([%| *] +>.sign-arvo)
?~ p.p.sign-arvo
abet
=/ msg=tape "fuse merge conflict for {<syd>}"
%- (slog [leaf+msg >p.p.sign-arvo< ~])
abet
%- (slog leaf+"failed fuse for {<syd>}" p.p.sign-arvo)
abet
*
?+ +<.sign-arvo
((slog leaf+"kiln: strange card {<+<.sign-arvo wire>}" ~) abet)
%done (done wire +>.sign-arvo)
%mere (take-mere wire +>.sign-arvo)
==
==
++ take |=(way=wire ?>(?=([@ ~] way) (work i.way))) :: general handler
++ done
|= [way=wire saw=(unit error:ames)]
~? ?=(^ saw) [%kiln-nack u.saw]
abet
::
++ take-mere ::
|= [way=wire are=(each (set path) (pair term tang))]
?. ?=([@ ~] way)
abet
abet:abet:(mere:(take way) are)
::
++ take-coup-fancy ::
|= [way=wire saw=(unit tang)]
abet:abet:(coup-fancy:(take way) saw)
::
++ take-coup-spam ::
|= [way=wire saw=(unit tang)]
~? ?=(^ saw) [%kiln-spam-lame u.saw]
abet
::
++ take-wake-autocommit
|= [way=wire error=(unit tang)]
?^ error
%- (slog u.error)
~& %kiln-wake-autocommit-fail
abet
=. nex.commit-timer (add now tim.commit-timer)
=< abet
%- emil
:~ [%pass /commit %arvo %c [%dirk mon.commit-timer]]
[%pass way.commit-timer %arvo %b [%wait nex.commit-timer]]
==
::
::
++ spam
|= mes=(list tank)
((slog mes) ..spam)
:: state machine for fuses
::
++ fuzz
|= [syd=desk now=@da]
=/ pfu=(unit per-fuse) (~(get by fus) syd)
?~ pfu
~
=* kf kf.u.pfu
=* mox mox.u.pfu
=/ should-delete=flag |
%- some
|%
:: finalize
::
++ abet
?: should-delete
..fuzz(fus (~(del by fus) syd))
..fuzz(fus (~(put by fus) syd [mox kf]))
::
++ delete
^+ ..delete
=. should-delete &
..delete
:: queue moves
::
++ blab
|= new=(list card:agent:gall)
^+ +>
+>.$(moz (welp new moz))
:: +make-requests: send requests for each %trak source.
::
++ make-requests
^+ ..abet
=/ movs=(list card:agent:gall)
%+ murn
[[bas.kf *germ] con.kf]
|= [fs=fuse-source germ]
^- (unit card:agent:gall)
?^ ver.fs
:: static source, don't need to track
~
=/ bec=beak (realize-fuse-source fs &)
?> =(who.fs p.bec)
?> =(des.fs q.bec)
=/ hax=@ud (mug [kf (~(got by hxs) syd)])
=/ wir=wire
/kiln/fuse-request/[syd]/(scot %p p.bec)/[q.bec]/(scot %ud hax)
=/ rav=rave [%sing %w r.bec /]
=/ rif=riff [q.bec `rav]
`[%pass wir %arvo %c [%warp who.fs rif]]
:: No need to keep state if all the sources are static
?~ movs
delete
(blab movs)
::
++ send-fuse
^+ ..abet
=/ bas=beak (realize-fuse-source bas.kf |)
=/ con=(list [beak germ])
%+ turn
con.kf
|= [fs=fuse-source g=germ]
[(realize-fuse-source fs |) g]
%- blab
[%pass /kiln/fuse/[syd] %arvo %c [%fuse syd bas con]]~
::
++ fuse
^+ ..abet
send-fuse:make-requests
::
++ take
|= [wir=wire =sign-arvo]
^+ ..fuse
?> =((lent wir) 3)
=/ who=ship (slav %p (snag 0 wir))
=/ src=desk (snag 1 wir)
=/ hax=@ud (slav %ud (snag 2 wir))
?. =(hax (mug [kf (~(got by hxs) syd)]))
:: If the hash in the wire doesn't match the current request
:: this is a response for a previous fuse that we can ignore.
..take
?> ?=([?(%clay %behn) %writ *] sign-arvo)
=/ gif +.sign-arvo
?~ p.gif
%- (slog leaf+"|fuse request failed for {<src>} on <who> - cancelling")
delete
=/ cas=cass:clay !<(cass:clay +.r.u.p.gif)
=. mox (~(put by mox) [who src] ud.cas)
fuse
::
:: utility functions below
::
:: +realize-fuse-source: convert a fuse-source to a
:: fully realized beak.
::
++ realize-fuse-source
|= [fs=fuse-source incr=flag]
^- beak
:+ who.fs
des.fs
?@ ver.fs
(realize-case [who.fs des.fs incr])
`case`ver.fs
::
++ realize-case
|= [who=ship des=desk incr=flag]
^- case
=/ let=(unit @ud) (~(get by mox) [who des])
^- case
?~ let
da+now
:- %ud
?: incr
+(u.let)
u.let
--
::
++ take-sync
|= [=wire =sign-arvo]
?> ?=([@ @ @ *] wire)
=* syd i.wire
=/ her (slav %p i.t.wire)
=* sud i.t.t.wire
?. (~(has by zyn) syd her sud)
abet
abet:abet:(take:(sync syd her sud) t.t.t.wire sign-arvo)
::
++ sync
|= kiln-sync
=/ got (~(get by zyn) syd her sud)
=+ `sync-state`(fall got [(scot %uv nyz) ~ *@ud])
=? nyz ?=(~ got) +(nyz)
|%
++ abet ..sync(zyn (~(put by zyn) [syd her sud] nun kid let))
++ apex |=(nex=(unit desk) ..abet(kid nex))
++ emit |=(card:agent:gall ..abet(kiln (^emit +<)))
++ emil |=((list card:agent:gall) ..abet(kiln (^emil +<)))
++ here "{<syd>} from {<her>}/{<sud>}"
++ ware
|= =wire
[%kiln %zinc syd (scot %p her) sud nun wire]
++ lard
|= [=wire =shed:khan]
(emit %pass (ware wire) %arvo %k %lard %base shed)
++ merg
|= [=wire =desk]
%: emit
%pass (ware wire) %arvo %c
%merg desk her sud
ud+(dec let) (get-germ desk)
==
::
:: (re)Start a sync from scratch by finding what version the source
:: desk is at
::
++ init
^+ ..abet
=. let 0
%+ lard /init
=/ m (strand:rand ,vase)
;< =riot:clay bind:m (warp:strandio her sud ~ %sing %y ud+1 /)
~> %slog.(fmt "activated install into {here}")
;< now=@da bind:m get-time:strandio
;< =riot:clay bind:m (warp:strandio her sud ~ %sing %w da+now /)
?> ?=(^ riot)
=+ !<(=cass:clay q.r.u.riot)
(pure:m !>(ud.cass))
::
:: Listen for the next revision, and download it
::
++ next
^+ ..abet
%+ lard /next
=/ m (strand:rand ,vase)
;< =riot:clay bind:m (warp:strandio her sud ~ %sing %w ud+let /)
~> %slog.(fmt "downloading update for {here}")
;< =riot:clay bind:m (warp:strandio her sud ~ %sing %v ud+let /)
?> ?=(^ riot)
(pure:m !>(%done))
::
:: Main control router
::
:: NB: %next, %main, and %kids are conceptually a single state with a
:: single error handling mechanism (move on to the next version). We
:: cannot combine them into a single lard because when you update
:: main you may update spider, and in that case all active threads
:: are killed, which would stop us from continuing that thread.
:: Instead, we do the merges to syd and kid explicitly.
::
++ take
|= [=wire =sign-arvo]
^+ ..abet
?> ?=([@ @ *] wire)
?. =(nun i.wire)
..abet
?+ i.t.wire
~> %slog.(fmt "sync-bad-take {<wire>}")
..abet
%init
?. =(0 let)
~> %slog.(fmt "sync-bad-stage {<let>} {<wire>}")
..abet
?> ?=(%arow +<.sign-arvo)
?: ?=(%| -.p.sign-arvo)
~> %slog.(fmt "activation failed into {here}; retrying sync")
%- (slog p.p.sign-arvo)
init
:: Now that we know the revision, start main download loop
::
=. let !<(@ud q.p.p.sign-arvo)
next
::
%next
?> ?=(%arow +<.sign-arvo)
?: ?=(%| -.p.sign-arvo)
:: ~> %slog.(fmt "download failed into {here}; retrying sync")
:: %- (slog p.p.sign-arvo)
init
::
~> %slog.(fmt "finished downloading update for {here}")
=. let +(let)
:: If nothing changed, just advance
::
?. (get-remote-diff our syd now [her sud (dec let)])
~> %slog.(fmt "remote is identical to {here}, skipping")
next
:: Else start merging, but also immediately start listening to
:: the next revision. Now, all errors should no-op -- we're
:: already waiting for the next revision.
::
=. ..abet (merg /main syd)
next
::
%main
?> ?=(%mere +<.sign-arvo)
:: This case is maintained by superstition. If you remove it,
:: carefully test that if the source ship is breached, we
:: correctly reset let to 0
::
?: ?=([%| %ali-unavailable *] p.sign-arvo)
=+ "kiln: merge into {here} failed, maybe because sunk; restarting"
%- (slog leaf/- p.p.sign-arvo)
init
?: ?=(%| -.p.sign-arvo)
=+ "kiln: merge into {here} failed, waiting for next revision"
%- (slog leaf/- p.p.sign-arvo)
..abet
~> %slog.(fmt "merge into {<syd>} succeeded")
:: If we have a kids desk parameter, merge into that
::
?~ kid
..abet
~> %slog.(fmt "kids merge into {<kid>}")
(merg /kids u.kid)
::
%kids
?> ?=(%mere +<.sign-arvo)
?~ kid
..abet
:: See %main for this case
::
?: ?=([%| %ali-unavailable *] p.sign-arvo)
=+ "kids merge to {<u.kid>} failed, maybe peer sunk; restarting"
~> %slog.(fmt -)
init
:: Just notify; we've already started listening for the next
:: version
::
?- -.p.sign-arvo
%& ~> %slog.(fmt "kids merge to {<u.kid>} succeeded")
..abet
%| ~> %slog.(fmt "kids merge to {<u.kid>} failed")
%- (slog p.p.sign-arvo)
..abet
==
==
--
::
++ work :: state machine
|= syd=desk
=/ ,per-desk
%+ ~(gut by rem) syd
=+ *per-desk
%_(- cas [%da now])
|%
++ abet :: resolve
..work(rem (~(put by rem) syd auto gem her sud cas))
::
++ blab
|= new=(list card:agent:gall)
^+ +>
+>.$(moz (welp new moz))
::
++ win . :: successful poke
++ lose
^+ .
~| %kiln-work-fail
.
::
++ perform ::
^+ .
?< ?=(%this gem)
?< ?=(%that gem)
(blab [%pass /kiln/[syd] %arvo %c [%merg syd her sud cas gem]] ~)
::
++ fancy-merge :: send to self
|= [syd=desk her=@p sud=desk gem=?(%auto germ)]
^+ +>
=/ =cage [%kiln-merge !>([syd her sud cas gem])]
%- blab :_ ~
[%pass /kiln/fancy/[^syd] %agent [our %hood] %poke cage]
::
++ spam ::|=(tang ((slog +<) ..spam))
|*(* +>(..work (^spam +<)))
++ merge
|= [her=@p sud=@tas cas=case gim=?(%auto germ)]
^+ +>
?. ?=(%auto gim)
perform(auto |, gem gim, her her, cas cas, sud sud)
?: =(0 ud:.^(cass:clay %cw /(scot %p our)/[syd]/(scot %da now)))
=> $(gim %init)
.(auto &)
=> $(gim %fine)
.(auto &)
::
++ coup-fancy
|= saw=(unit tang)
?~ saw
+>
=+ :- "failed to set up conflict resolution scratch space"
"I'm out of ideas"
lose:(spam leaf+-< leaf+-> u.saw)
::
++ mere
|= are=(each (set path) (pair term tang))
^+ +>
?: =(%meld gem)
?: ?=(%& -.are)
?. auto
=+ "merged with strategy {<gem>}"
win:(spam leaf+- ?~(p.are ~ [>`(set path)`p.are< ~]))
:: ~? > =(~ p.are) [%mere-no-conflict syd]
=> .(+>.$ (spam leaf+"mashing conflicts" ~))
=+ tic=(cat 3 syd '-scratch')
=/ notations=(list [path (unit [mark vase])])
%+ turn ~(tap in p.are)
|= =path
=/ =mark -:(flop path)
=/ =dais .^(dais %cb /(scot %p our)/[syd]/(scot cas)/[mark])
=/ base .^(vase %cr (weld /(scot %p our)/[tic]/(scot cas) path))
=/ ali .^(vase %cr (weld /(scot %p her)/[sud]/(scot cas) path))
=/ bob .^(vase %cr (weld /(scot %p our)/[syd]/(scot cas) path))
=/ ali-dif (~(diff dais base) ali)
=/ bob-dif (~(diff dais base) bob)
=/ mash (~(mash dais base) [her sud ali-dif] [our syd bob-dif])
:- path
?~ mash
~
`[mark (~(pact dais base) u.mash)]
=/ [annotated=(list [path *]) unnotated=(list [path *])]
(skid notations |=([* v=*] ?=(^ v)))
=/ tic=desk (cat 3 syd '-scratch')
=/ tan=(list tank)
%- zing
^- (list (list tank))
:~ %- tape-to-tanks
"""
done setting up scratch space in {<[tic]>}
please resolve the following conflicts and run
|merge {<syd>} our {<[tic]>}
"""
%^ tanks-if-any
"annotated conflicts in:" (turn annotated head)
""
%^ tanks-if-any
"unannotated conflicts in:" (turn unnotated head)
"""
some conflicts could not be annotated.
for these, the scratch space contains
the most recent common ancestor of the
conflicting content.
"""
==
=< win
%- blab:(spam tan)
:_ ~
:* %pass /kiln/[syd] %arvo %c
%info
tic %&
%+ murn notations
|= [=path dif=(unit [=mark =vase])]
^- (unit [^path miso])
?~ dif
~
`[path %mut mark.u.dif vase.u.dif]
==
=+ "failed to merge with strategy meld"
lose:(spam leaf+- >p.p.are< q.p.are)
?: ?=(%& -.are)
=+ "merged with strategy {<gem>}"
win:(spam leaf+- ?~(p.are ~ [>`(set path)`p.are< ~]))
?. auto
=+ "failed to merge with strategy {<gem>}"
lose:(spam leaf+- >p.p.are< q.p.are)
?+ gem
(spam leaf+"strange auto" >gem< ~)
::
%init
=+ :- "auto merge failed on strategy %init"
"I'm out of ideas"
lose:(spam leaf+-< leaf+-> [>p.p.are< q.p.are])
::
%fine
?. ?=(%bad-fine-merge p.p.are)
=+ "auto merge failed on strategy %fine"
lose:(spam leaf+- >p.p.are< q.p.are)
=> (spam leaf+"%fine merge failed, trying %meet" ~)
perform(gem %meet)
::
%meet
?. ?=(%meet-conflict p.p.are)
=+ "auto merge failed on strategy %meet"
lose:(spam leaf+- >p.p.are< q.p.are)
=> (spam leaf+"%meet merge failed, trying %mate" ~)
perform(gem %mate)
::
%mate
?. ?=(%mate-conflict p.p.are)
=+ "auto merge failed on strategy %mate"
lose:(spam leaf+- >p.p.are< q.p.are)
=> .(gem %meld)
=+ tic=(cat 3 syd '-scratch')
=> =+ :- "%mate merge failed with conflicts,"
"setting up scratch space at %{(trip tic)}"
[tic=tic (spam leaf+-< leaf+-> q.p.are)]
=. ..mere (fancy-merge tic our syd %init)
=> (spam leaf+"%melding %{(trip sud)} into scratch space" ~)
%- blab :_ ~
?< ?=(%this gem)
?< ?=(%that gem)
=/ note [%merg (cat 3 syd '-scratch') her sud cas gem]
[%pass /kiln/[syd] %arvo %c note]
==
::
++ tape-to-tanks
|= a=tape ^- (list tank)
(scan a (more (just '\0a') (cook |=(a=tape leaf+a) (star prn))))
::
++ tanks-if-any
|= [a=tape b=(list path) c=tape] ^- (list tank)
?: =(~ b) ~
(welp (tape-to-tanks "\0a{c}{a}") >b< ~)
--
--