urbit/shrub
1
1
Fork 0
mirror of https://github.com/urbit/shrub.git synced 2024-12-19 16:51:42 +03:00
Code Issues Packages Projects Releases Wiki Activity
f2d3a64d9c
shrub/pkg/arvo/sys/vane/clay.hoon
fang f2d3a64d9c
clay: add /cs/===/bloc scry for all desk blobs 
Lets you retrieve all blobs from the blob store that are in use by the
desk, both presently and in all its history.
2023-01-23 20:39:18 +01:00

6218 lines
185 KiB
Plaintext
Raw Blame History

:: clay (4c), revision control
::
:: The way to understand Clay is to take it section-by-section:
::
:: - Data structures. You *must* start here; make sure you understand
:: the entire contents of +raft.
::
:: - Individual reads. +aver is the entry point, follow it through
:: +read-at-aeon to understand each kind of read.
::
:: - Subscriptions. +wake is the center of this mechanism; nothing
:: else responds to subscriptions. +wake has no arguments, which means
:: every subscription response happens when something in Clay's *state*
:: has changed. No edge-triggered responses.
::
:: - Receiving foreign data. For individual requests, this is
:: +take-foreign-answer. For sync requests (%many, which is %sing %v
:: for a foreign desk), this is +foreign-update.
::
:: - Ford. +ford builds hoon files and gives files their types.
:: Read +build-file for the first, and +read-file is the second.
::
:: - Writing to a desk. Every write to a desk goes through +park, read
:: it thoroughly.
::
:: - Merges. Control flow starts at +start-merge, then +merge, but
:: everything is scaffolding for +merge-by-germ, which is the ideal of
:: a merge function: it takes two commits and a merge strategy and
:: produces a new commit.
::
:: - Tombstoning. This is in +tomb.
::
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
::
:: We use a system of "invariant footnotes", where nonlocal invariants
:: are tagged with notes to construct a distributed argument that the
:: invariant is maintained. For example, see [wake].
::
:: Each one should be described somewhere, and then it should be
:: referenced any time it's touched. For example, any code which might
:: fill a subscription should be tagged with [wake], and if +wake is
:: not called by the end of that function, the function itself should
:: be tagged with [wake].
::
:: The tagged code should constitute an argument that the invariant is
:: maintained everywhere. While this is vulnerable to omission ("I
:: forgot that X could fill a subscription", it provides a good minimum
:: bar.
::
:: Tag the specific line of code which affects the invariant. You do
:: not need to tag every function in a call stack if the invariant is
:: guaranteed to be maintained by the time the function returns.
::
:: Some invariant references get tagged with whether they "open" or
:: "close" the invariant. For example, adding a commit to the dome
:: "opens" the [wake] invariant, while calling +wake closes it. When
:: an invariant opens, you should be able to scan down and find why it
:: closes in each possible flow of control. For wake, these are
:: labeled like this:
::
:: open: [wake] <
:: close: [wake] >
:: open and almost immediately close: [wake] <>
::
:: This system is best used for nonlocal invariants and is not
:: necessary when a function can guarantee its own invariants. For
:: example, consider a set alongside a @ud representing its size.
:: There is an invariant that any time you add or remove an item from
:: the set you must update its size. If you're operating on these
:: directly, it could be beneficial to tag each line of code which
:: might modify the set and make it clear where the size is modified.
::
:: Sometimes code can be restructured so that many fewer tags are
:: needed. In the above example, if the set is modified in many
:: places, it may be worth factoring out set+size into a data structure
:: with its own arms for put, del, uni, int, etc. Then the invariant
:: only needs to be maintained within that data structure, and call
:: sites do not need to be tagged.
::
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
::
:: Here are the structures. `++raft` is the formal arvo state. It's
:: also worth noting that many of the clay-related structures are
:: defined in lull.
::
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
=/ bud
^~
=/ zuse !>(..zuse)
:* zuse=zuse
nave=(slap zuse !,(*hoon nave:clay))
cork=(slap zuse !,(*hoon cork))
same=(slap zuse !,(*hoon same))
mime=(slap zuse !,(*hoon mime))
cass=(slap zuse !,(*hoon cass:clay))
==
::
|= our=ship
=, clay
=> |%
+$ aeon @ud :: version number
::
:: Part of ++mery, representing the set of changes between the mergebase and
:: one of the desks being merged.
::
:: -- `new` is the set of files in the new desk and not in the mergebase.
:: -- `cal` is the set of changes in the new desk from the mergebase except
:: for any that are also in the other new desk.
:: -- `can` is the set of changes in the new desk from the mergebase and that
:: are also in the other new desk (potential conflicts).
:: -- `old` is the set of files in the mergebase and not in the new desk.
::
+$ cane
$: new=(map path lobe)
cal=(map path lobe)
can=(map path cage)
old=(map path ~)
==
::
:: Type of request.
::
:: %d produces a set of desks, %p gets file permissions, %t gets all paths
:: with the specified prefix, %u checks for existence, %v produces a ++dome
:: of all desk data, %w gets @ud and @da variants for the given case, %x
:: gets file contents, %y gets a directory listing, and %z gets a recursive
:: hash of the file contents and children.
::
:: ++ care ?(%d %p %t %u %v %w %x %y %z)
::
:: Keeps track of subscribers.
::
:: A map of requests to a set of all the subscribers who should be notified
:: when the request is filled/updated.
::
+$ cult (jug wove duct)
::
:: State for ongoing %fuse merges. `con` maintains the ordering,
:: `sto` stores the data needed to merge, and `bas` is the base
:: beak for the merge.
::
+$ melt [bas=beak con=(list [beak germ]) sto=(map beak (unit dome:clay))]
::
:: Domestic desk state.
::
:: Includes subscriber list, dome (desk content), possible commit state (for
:: local changes), possible merge state (for incoming merges), and permissions.
::
+$ dojo
$: qyx=cult :: subscribers
dom=dome :: desk state
per=regs :: read perms per path
pew=regs :: write perms per path
fiz=melt :: state for mega merges
==
::
:: Desk state.
::
:: Includes a checked-out ankh with current content, most recent version, map
:: of all version numbers to commit hashes (commits are in hut.rang), and map
:: of labels to version numbers.
::
:: `mim` is a cache of the content in the directories that are mounted
:: to unix. Often, we convert to/from mime without anything really
:: having changed; this lets us short-circuit that in some cases.
:: Whenever you give an `%ergo`, you must update this.
::
+$ dome
$: let=aeon :: top id
hit=(map aeon tako) :: versions by id
lab=(map @tas aeon) :: labels
tom=(map tako norm) :: tomb policies
nor=norm :: default policy
mim=(map path mime) :: mime cache
fod=flue :: ford cache
wic=(map weft yoki) :: commit-in-waiting
liv=zest :: running agents
ren=rein :: force agents on/off
== ::
::
:: Over-the-wire backfill request/response
::
+$ fill
$% [%0 =desk =lobe]
[%1 =desk =lobe]
==
::
+$ fell
$% [%direct p=lobe q=page]
[%delta p=lobe q=[p=mark q=lobe] r=page]
[%dead p=lobe ~]
[%1 peg=(unit page)]
==
::
:: Global ford cache
::
:: Refcount includes references from other items in the cache, and
:: from spills in each desk
::
:: This is optimized for minimizing the number of rebuilds, and given
:: that, minimizing the amount of memory used. It is relatively slow
:: to lookup, because generating a cache key can be fairly slow (for
:: files, it requires parsing; for tubes, it even requires building
:: the marks).
::
+$ flow (map leak [refs=@ud =soak])
::
:: Per-desk ford cache
::
:: Spill is the set of "roots" we have into the global ford cache.
:: We add a root for everything referenced directly or indirectly on
:: a desk, then invalidate them on commit only if their dependencies
:: change.
::
:: Sprig is a fast-lookup index over the global ford cache. The only
:: goal is to make cache hits fast.
::
+$ flue [spill=(set leak) sprig=(map mist [=leak =soak])]
::
:: Ford build without content.
::
+$ mist
$% [%file =path]
[%nave =mark]
[%dais =mark]
[%cast =mars]
[%tube =mars]
[%vale =path]
[%arch =path]
==
::
:: Ford build with content.
::
+$ pour
$% [%file =path]
[%nave =mark]
[%dais =mark]
[%cast =mars]
[%tube =mars]
:: leafs
::
[%vale =path =lobe]
[%arch =path =(map path lobe)]
==
::
:: Ford result.
::
+$ soak
$% [%cage =cage]
[%vase =vase]
[%arch dir=(map @ta vase)]
[%dais =dais]
[%tube =tube]
==
::
:: Ford cache key
::
:: This includes all build inputs, including transitive dependencies,
:: recursively.
::
+$ leak
$~ [*pour ~]
$: =pour
deps=(set leak)
==
::
:: New desk data.
::
:: Sent to other ships to update them about a particular desk.
:: Includes a map of all new aeons to hashes of their commits, the most
:: recent aeon, and sets of all new commits and data. `bar` is always
:: empty now because we expect you to request any data you don't have
:: yet
::
+$ nako :: subscription state
$: gar=(map aeon tako) :: new ids
let=aeon :: next id
lar=(set yaki) :: new commits
bar=~ :: new content
== ::
::
::
:: Formal vane state.
::
:: -- `rom` is our domestic state.
:: -- `hoy` is a collection of foreign ships where we know something about
:: their clay.
:: -- `ran` is the object store.
:: -- `mon` is a collection of mount points (mount point name to urbit
:: location).
:: -- `hez` is the unix duct that %ergo's should be sent to.
:: -- `cez` is a collection of named permission groups.
:: -- `pud` is an update that's waiting on a kernel upgrade
::
+$ raft :: filesystem
$: rom=room :: domestic
hoy=(map ship rung) :: foreign
ran=rang :: hashes
fad=flow :: ford cache
mon=(map term beam) :: mount points
hez=(unit duct) :: sync duct
cez=(map @ta crew) :: permission groups
tyr=(set duct) :: app subs
tur=rock:tire :: last tire
pud=(unit [=desk =yoki]) :: pending update
bug=[veb=@ mas=@] :: verbosity
== ::
::
:: Unvalidated response to a request.
::
:: Like a +$rant, but with a page of data rather than a cage of it.
::
+$ rand :: unvalidated rant
$: p=[p=care q=case r=@tas] :: clade release book
q=path :: spur
r=page :: data
== ::
::
:: Generic desk state.
::
:: -- `lim` is the most recent date we're confident we have all the
:: information for. For local desks, this is always `now`. For foreign
:: desks, this is the last time we got a full update from the foreign
:: urbit.
:: -- `ref` is a possible request manager. For local desks, this is null.
:: For foreign desks, this keeps track of all pending foreign requests
:: plus a cache of the responses to previous requests.
:: -- `qyx` is the set of subscriptions, with listening ducts. These
:: subscriptions exist only until they've been filled.
:: -- `dom` is the actual state of the filetree. Since this is used almost
:: exclusively in `++ze`, we describe it there.
::
+$ rede :: universal project
$: lim=@da :: complete to
ref=(unit rind) :: outgoing requests
qyx=cult :: subscribers
dom=dome :: revision state
per=regs :: read perms per path
pew=regs :: write perms per path
fiz=melt :: domestic mega merges
== ::
::
:: Foreign request manager.
::
:: When we send a request to a foreign ship, we keep track of it in here. This
:: includes a request counter, a map of request numbers to requests, a reverse
:: map of requesters to request numbers, a simple cache of common %sing
:: requests, and a possible nako if we've received data from the other ship and
:: are in the process of validating it.
::
+$ rind :: request manager
$: nix=@ud :: request index
bom=(map @ud update-state) :: outstanding
fod=(map duct @ud) :: current requests
haw=(map mood (unit cage)) :: simple cache
== ::
::
+$ bill (list dude:gall)
::
:: Active downloads
::
+$ update-state
$: =duct
=rave
need=(list lobe)
nako=(qeu (unit nako))
busy=_|
==
::
:: Domestic ship.
::
:: `hun` is the duct to dill, and `dos` is a collection of our desks.
::
+$ room :: fs per ship
$: hun=duct :: terminal duct
dos=(map desk dojo) :: native desk
== ::
::
:: Stored request.
::
:: Like a +$rave but with caches of current versions for %next and %many.
:: Generally used when we store a request in our state somewhere.
::
:: TODO: remove lobes from %many
::
+$ cach (unit (unit cage)) :: cached result
+$ wove [for=(unit [=ship ver=@ud]) =rove] :: stored source + req
+$ rove :: stored request
$% [%sing =mood] :: single request
[%next =mood aeon=(unit aeon) =cach] :: next version of one
$: %mult :: next version of any
=mool :: original request
aeon=(unit aeon) :: checking for change
old-cach=(map [=care =path] cach) :: old version
new-cach=(map [=care =path] cach) :: new version
== ::
[%many track=? =moat lobes=(map path lobe)] :: change range
== ::
::
:: Foreign desk data.
::
+$ rung
$: rus=(map desk rede) :: neighbor desks
==
::
+$ card (wind note gift) :: local card
+$ move [p=duct q=card] :: local move
+$ note :: out request $->
$~ [%b %wait *@da] ::
$% $: %$ :: to arvo
$>(%what waif) ::
== ::
$: %a :: to %ames
$>(%plea task:ames) ::
== ::
$: %b :: to %behn
$> $? %drip ::
%rest ::
%wait ::
== ::
task:behn ::
== ::
$: %c :: to %clay
$> $? %info :: internal edit
%merg :: merge desks
%fuse :: merge many
%park ::
%perm ::
%pork ::
%warp ::
%werp ::
== ::
task ::
== ::
$: %d :: to %dill
$> $? %flog ::
%text ::
== ::
task:dill ::
== ::
$: %g :: to %gall
$> $? %deal
%jolt
%load
==
task:gall
== ::
$: %j :: by %jael
$>(%public-keys task:jael) ::
== == ::
+$ riot (unit rant) :: response+complete
+$ sign :: in result $<-
$~ [%behn %wake ~] ::
$% $: %ames ::
$> $? %boon :: response
%done :: (n)ack
%lost :: lost boon
== ::
gift:ames ::
== ::
$: %behn ::
$% $>(%wake gift:behn) :: timer activate
$>(%writ gift) ::
== == ::
$: %clay ::
$> $? %mere ::
%writ ::
%wris ::
== ::
gift ::
== ::
$: %gall
$> $? %unto
==
gift:gall
==
$: %jael ::
$>(%public-keys gift:jael) ::
== == ::
-- =>
~% %clay-utilities ..part ~
:: %utilities
::
|%
:: +sort-by-head: sorts alphabetically using the head of each element
::
++ sort-by-head
|=([a=(pair path *) b=(pair path *)] (aor p.a p.b))
::
:: By convention: paf == (weld pax pat)
::
++ mode-to-commit
|= [hat=(map path lobe) pax=path all=? mod=mode]
^- [deletes=(set path) changes=(map path cage)]
=/ deletes
%- silt
%+ turn
^- (list path)
%+ weld
^- (list path)
%+ murn mod
|= [pat=path mim=(unit mime)]
^- (unit path)
?^ mim
~
`pat
^- (list path)
?. all
~
=+ mad=(malt mod)
=+ len=(lent pax)
=/ descendants=(list path)
%+ turn
%+ skim ~(tap by hat)
|= [paf=path lob=lobe]
=(pax (scag len paf))
|= [paf=path lob=lobe]
(slag len paf)
%+ skim
descendants
|= pat=path
(~(has by mad) pat)
|= pat=path
(weld pax pat)
::
=/ changes
%- malt
%+ murn mod
|= [pat=path mim=(unit mime)]
^- (unit [path cage])
?~ mim
~
`[(weld pax pat) %mime !>(u.mim)]
::
[deletes changes]
::
++ pour-to-mist
|= =pour
^- mist
?+ -.pour pour
%vale [%vale path.pour]
%arch [%arch path.pour]
==
::
++ fell-to-page
|= =fell
^- (unit page)
?- -.fell
%dead ~
%direct `q.fell
%delta ~
%1 peg.fell
==
::
++ rave-to-rove
|= rav=rave
^- rove
?- -.rav
%sing rav
%next [- mood ~ ~]:rav
%mult [- mool ~ ~ ~]:rav
%many [- track moat ~]:rav
==
::
++ rove-to-rave
|= rov=rove
^- rave
?- -.rov
%sing rov
%next [- mood]:rov
%mult [- mool]:rov
%many [- track moat]:rov
==
-- =>
~% %clay + ~
|%
:: Printable form of a wove; useful for debugging
::
++ print-wove
|= =wove
:- for.wove
?- -.rove.wove
%sing [%sing mood.rove.wove]
%next [%next [mood aeon]:rove.wove]
%mult [%mult [mool aeon]:rove.wove]
%many [%many [track moat]:rove.wove]
==
::
:: Printable form of a cult; useful for debugging
::
++ print-cult
|= =cult
%+ turn ~(tap by cult)
|= [=wove ducts=(set duct)]
[ducts (print-wove wove)]
::
++ fusion
|%
:: +wrap: external wrapper
::
++ wrap
|* [* state:ford]
[+<- +<+< +<+>-] :: [result cache.state flue]
::
++ with-face |=([face=@tas =vase] vase(p [%face face p.vase]))
++ with-faces
=| res=(unit vase)
|= vaz=(list [face=@tas =vase])
^- vase
?~ vaz (need res)
=/ faz (with-face i.vaz)
=. res `?~(res faz (slop faz u.res))
$(vaz t.vaz)
::
++ ford
!.
=> |%
+$ state
$: cache=flow
flue
cycle=(set mist)
drain=(map mist leak)
stack=(list (set leak))
==
+$ args
$: files=(map path (each page lobe))
file-store=(map lobe page)
verb=@
cache=flow
flue
==
--
|= args
:: nub: internal mutable state for this computation
::
=| nub=state
=. cache.nub cache
=. spill.nub spill
=. sprig.nub sprig
|%
:: +read-file: retrieve marked, validated file contents at path
::
++ read-file
|= =path
^- [cage state]
~| %error-validating^path
%- soak-cage
%+ gain-sprig vale+path |.
=. stack.nub [~ stack.nub]
?: (~(has in cycle.nub) vale+path)
~|(cycle+vale+path^cycle.nub !!)
=. cycle.nub (~(put in cycle.nub) vale+path)
%+ gain-leak vale+path
|= nob=state
=. nub nob
%- (trace 1 |.("read file {(spud path)}"))
=/ file
~| %file-not-found^path
(~(got by files) path)
=/ page
?: ?=(%& -.file)
p.file
~| %tombstoned-file^path^p.file
(~(got by file-store) p.file)
=^ =cage nub (validate-page path page)
[[%cage cage] nub]
::
:: +build-nave: build a statically typed mark core
::
++ build-nave
|= mak=mark
^- [vase state]
~| %error-building-mark^mak
%- soak-vase
%+ gain-sprig nave+mak |.
=. stack.nub [~ stack.nub]
?: (~(has in cycle.nub) nave+mak)
~|(cycle+nave+mak^cycle.nub !!)
=. cycle.nub (~(put in cycle.nub) nave+mak)
%- (trace 1 |.("make mark {<mak>}"))
=^ cor=vase nub (build-fit %mar mak)
=/ gad=vase (slap cor limb/%grad)
?@ q.gad
=+ !<(mok=mark gad)
=^ deg=vase nub ^$(mak mok)
=^ tub=vase nub (build-cast mak mok)
=^ but=vase nub (build-cast mok mak)
%+ gain-leak nave+mak
|= nob=state
=. nub nob
:_ nub :- %vase
^- vase :: vase of nave
%+ slap
(with-faces deg+deg tub+tub but+but cor+cor nave+nave.bud ~)
!, *hoon
=/ typ _+<.cor
=/ dif _*diff:deg
^- (nave typ dif)
|%
++ diff
|= [old=typ new=typ]
^- dif
(diff:deg (tub old) (tub new))
++ form form:deg
++ join join:deg
++ mash mash:deg
++ pact
|= [v=typ d=dif]
^- typ
(but (pact:deg (tub v) d))
++ vale noun:grab:cor
--
%+ gain-leak nave+mak
|= nob=state
=. nub nob
:_ nub :- %vase
^- vase :: vase of nave
%+ slap (slop (with-face cor+cor) zuse.bud)
!, *hoon
=/ typ _+<.cor
=/ dif _*diff:grad:cor
^- (nave:clay typ dif)
|%
++ diff |=([old=typ new=typ] (diff:~(grad cor old) new))
++ form form:grad:cor
++ join
|= [a=dif b=dif]
^- (unit (unit dif))
?: =(a b)
~
`(join:grad:cor a b)
++ mash
|= [a=[=ship =desk =dif] b=[=ship =desk =dif]]
^- (unit dif)
?: =(dif.a dif.b)
~
`(mash:grad:cor a b)
++ pact |=([v=typ d=dif] (pact:~(grad cor v) d))
++ vale noun:grab:cor
--
:: +build-dais: build a dynamically typed mark definition
::
++ build-dais
|= mak=mark
^- [dais state]
~| %error-building-dais^mak
%- soak-dais
%+ gain-sprig dais+mak |.
=. stack.nub [~ stack.nub]
?: (~(has in cycle.nub) dais+mak)
~|(cycle+dais+mak^cycle.nub !!)
=. cycle.nub (~(put in cycle.nub) dais+mak)
=^ nav=vase nub (build-nave mak)
%+ gain-leak dais+mak
|= nob=state
=. nub nob
%- (trace 1 |.("make dais {<mak>}"))
:_ nub :- %dais
^- dais
=> [nav=nav ..zuse]
|_ sam=vase
++ diff
|= new=vase
(slam (slap nav limb/%diff) (slop sam new))
++ form !<(mark (slap nav limb/%form))
++ join
|= [a=vase b=vase]
^- (unit (unit vase))
=/ res=vase (slam (slap nav limb/%join) (slop a b))
?~ q.res ~
?~ +.q.res [~ ~]
``(slap res !,(*hoon ?>(?=([~ ~ *] .) u.u)))
++ mash
|= [a=[=ship =desk diff=vase] b=[=ship =desk diff=vase]]
^- (unit vase)
=/ res=vase
%+ slam (slap nav limb/%mash)
%+ slop
:(slop [[%atom %p ~] ship.a] [[%atom %tas ~] desk.a] diff.a)
:(slop [[%atom %p ~] ship.b] [[%atom %tas ~] desk.b] diff.b)
?~ q.res
~
`(slap res !,(*hoon ?>((^ .) u)))
++ pact
|= diff=vase
(slam (slap nav limb/%pact) (slop sam diff))
++ vale
|: noun=q:(slap nav !,(*hoon *vale))
(slam (slap nav limb/%vale) noun/noun)
--
:: +build-cast: produce gate to convert mark .a to, statically typed
::
++ build-cast
|= [a=mark b=mark]
^- [vase state]
~| error-building-cast+[a b]
%- soak-vase
%+ gain-sprig cast+a^b |.
=. stack.nub [~ stack.nub]
?: (~(has in cycle.nub) cast+[a b])
~|(cycle+cast+[a b]^cycle.nub !!)
?: =([%mime %hoon] [a b])
:_(nub [%vase =>(..zuse !>(|=(m=mime q.q.m)))])
:: try +grow; is there a +grow core with a .b arm?
::
%- (trace 1 |.("make cast {<a>} -> {<b>}"))
=^ old=vase nub (build-fit %mar a)
?: =/ ram (mule |.((slap old !,(*hoon grow))))
?: ?=(%| -.ram) %.n
=/ lab (mule |.((slob b p.p.ram)))
?: ?=(%| -.lab) %.n
p.lab
:: +grow core has .b arm; use that
::
%+ gain-leak cast+a^b
|= nob=state
=. nub nob
:_ nub :- %vase
%+ slap (with-faces cor+old ~)
^- hoon
:+ %brcl !,(*hoon v=+<.cor)
:+ %tsgl limb/b
!,(*hoon ~(grow cor v))
:: try direct +grab
::
=^ new=vase nub (build-fit %mar b)
=/ rab (mule |.((slap new tsgl/[limb/a limb/%grab])))
?: &(?=(%& -.rab) ?=(^ q.p.rab))
%+ gain-leak cast+a^b
|= nob=state
=. nub nob
:_(nub vase+p.rab)
:: try +jump
::
=/ jum (mule |.((slap old tsgl/[limb/b limb/%jump])))
?: ?=(%& -.jum)
(compose-casts a !<(mark p.jum) b)
?: ?=(%& -.rab)
(compose-casts a !<(mark p.rab) b)
?: ?=(%noun b)
%+ gain-leak cast+a^b
|= nob=state
=. nub nob
:_(nub vase+same.bud)
~|(no-cast-from+[a b] !!)
::
++ compose-casts
|= [x=mark y=mark z=mark]
^- [soak state]
=^ uno=vase nub (build-cast x y)
=^ dos=vase nub (build-cast y z)
%+ gain-leak cast+x^z
|= nob=state
=. nub nob
:_ nub :- %vase
%+ slap
(with-faces uno+uno dos+dos ~)
!,(*hoon |=(_+<.uno (dos (uno +<))))
:: +build-tube: produce a $tube mark conversion gate from .a to .b
::
++ build-tube
|= [a=mark b=mark]
^- [tube state]
~| error-building-tube+[a b]
%- soak-tube
%+ gain-sprig tube+a^b |.
=. stack.nub [~ stack.nub]
?: (~(has in cycle.nub) tube+[a b])
~|(cycle+tube+[a b]^cycle.nub !!)
=^ gat=vase nub (build-cast a b)
%+ gain-leak tube+a^b
|= nob=state
=. nub nob
%- (trace 1 |.("make tube {<a>} -> {<b>}"))
:_(nub [%tube =>([gat=gat ..zuse] |=(v=vase (slam gat v)))])
::
++ validate-page
|= [=path =page]
^- [cage state]
~| validate-page-fail+path^from+p.page
=/ mak=mark (head (flop path))
?: =(mak p.page)
(page-to-cage page)
=^ [mark vax=vase] nub (page-to-cage page)
=^ =tube nub (build-tube p.page mak)
:_(nub [mak (tube vax)])
::
++ page-to-cage
|= =page
^- [cage state]
?: =(%hoon p.page)
:_(nub [%hoon [%atom %t ~] q.page])
?: =(%mime p.page)
:_(nub [%mime =>([;;(mime q.page) ..zuse] !>(-))])
=^ =dais nub (build-dais p.page)
:_(nub [p.page (vale:dais q.page)])
::
++ cast-path
|= [=path mak=mark]
^- [cage state]
=/ mok (head (flop path))
~| error-casting-path+[path mok mak]
=^ cag=cage nub (read-file path)
?: =(mok mak)
[cag nub]
=^ =tube nub (build-tube mok mak)
~| error-running-cast+[path mok mak]
:_(nub [mak (tube q.cag)])
::
++ run-pact
|= [old=page diff=page]
^- [cage state]
?: ?=(%hoon p.old)
=/ txt=wain (to-wain:format ;;(@t q.old))
=+ ;;(dif=(urge cord) q.diff)
=/ new=@t (of-wain:format (lurk:differ txt dif))
:_(nub [%hoon =>([new ..zuse] !>(-))])
=^ dys=dais nub (build-dais p.old)
=^ syd=dais nub (build-dais p.diff)
:_(nub [p.old (~(pact dys (vale:dys q.old)) (vale:syd q.diff))])
::
++ prelude
|= =path
^- vase
=^ cag=cage nub (read-file path)
?> =(%hoon p.cag)
=/ tex=tape (trip !<(@t q.cag))
=/ =pile (parse-pile path tex)
=. hoon.pile !,(*hoon .)
=^ res=vase nub (run-prelude pile)
res
::
++ build-dependency
|= dep=(each [dir=path fil=path] path)
^- [vase state]
=/ =path
?:(?=(%| -.dep) p.dep fil.p.dep)
~| %error-building^path
%- soak-vase
%+ gain-sprig file+path |.
=. stack.nub [~ stack.nub]
%- (trace 1 |.("make file {(spud path)}"))
?: (~(has in cycle.nub) file+path)
~|(cycle+file+path^cycle.nub !!)
=. cycle.nub (~(put in cycle.nub) file+path)
=^ cag=cage nub (read-file path)
?> =(%hoon p.cag)
=/ tex=tape (trip !<(@t q.cag))
=/ =pile (parse-pile path tex)
=^ sut=vase nub (run-prelude pile)
%+ gain-leak file+path
|= nob=state
=. nub nob
=/ res=vase (slap sut hoon.pile)
[[%vase res] nub]
::
++ build-file
|= =path
(build-dependency |+path)
:: +build-directory: builds files in top level of a directory
::
:: this excludes files directly at /path/hoon,
:: instead only including files in the unix-style directory at /path,
:: such as /path/file/hoon, but not /path/more/file/hoon.
::
++ build-directory
|= =path
^- [(map @ta vase) state]
%- soak-arch
%+ gain-sprig arch+path |.
=. stack.nub [~ stack.nub]
%+ gain-leak arch+path
|= nob=state
=. nub nob
=/ fiz=(list @ta)
=/ len (lent path)
%+ murn ~(tap by files)
|= [pax=^path *]
^- (unit @ta)
?. =(path (scag len pax))
~
=/ pat (slag len pax)
?: ?=([@ %hoon ~] pat)
`i.pat
~
::
=| rez=(map @ta vase)
|-
?~ fiz
[[%arch rez] nub]
=* nom=@ta i.fiz
=/ pax=^path (weld path nom %hoon ~)
=^ res nub (build-dependency &+[path pax])
$(fiz t.fiz, rez (~(put by rez) nom res))
::
++ run-prelude
|= =pile
=/ sut=vase zuse.bud
=^ sut=vase nub (run-tauts sut %sur sur.pile)
=^ sut=vase nub (run-tauts sut %lib lib.pile)
=^ sut=vase nub (run-raw sut raw.pile)
=^ sut=vase nub (run-raz sut raz.pile)
=^ sut=vase nub (run-maz sut maz.pile)
=^ sut=vase nub (run-caz sut caz.pile)
=^ sut=vase nub (run-bar sut bar.pile)
[sut nub]
::
++ parse-pile
|= [pax=path tex=tape]
^- pile
=/ [=hair res=(unit [=pile =nail])] ((pile-rule pax) [1 1] tex)
?^ res pile.u.res
%- mean %- flop
=/ lyn p.hair
=/ col q.hair
:~ leaf+"syntax error at [{<lyn>} {<col>}] in {<pax>}"
leaf+(trip (snag (dec lyn) (to-wain:format (crip tex))))
leaf+(runt [(dec col) '-'] "^")
==
::
++ pile-rule
|= pax=path
%- full
%+ ifix
:_ gay
:: parse optional /? and ignore
::
;~(plug gay (punt ;~(plug fas wut gap dem gap)))
|^
;~ plug
%+ cook (bake zing (list (list taut)))
%+ rune hep
(most ;~(plug com gaw) taut-rule)
::
%+ cook (bake zing (list (list taut)))
%+ rune lus
(most ;~(plug com gaw) taut-rule)
::
%+ rune tis
;~(plug sym ;~(pfix gap stap))
::
%+ rune sig
;~((glue gap) sym wyde:vast stap)
::
%+ rune cen
;~(plug sym ;~(pfix gap ;~(pfix cen sym)))
::
%+ rune buc
;~ (glue gap)
sym
;~(pfix cen sym)
;~(pfix cen sym)
==
::
%+ rune tar
;~ (glue gap)
sym
;~(pfix cen sym)
;~(pfix stap)
==
::
%+ stag %tssg
(most gap tall:(vang & pax))
==
::
++ pant
|* fel=^rule
;~(pose fel (easy ~))
::
++ mast
|* [bus=^rule fel=^rule]
;~(sfix (more bus fel) bus)
::
++ rune
|* [bus=^rule fel=^rule]
%- pant
%+ mast gap
;~(pfix fas bus gap fel)
--
::
++ taut-rule
%+ cook |=(taut +<)
;~ pose
(stag ~ ;~(pfix tar sym))
;~(plug (stag ~ sym) ;~(pfix tis sym))
(cook |=(a=term [`a a]) sym)
==
::
++ run-tauts
|= [sut=vase wer=?(%lib %sur) taz=(list taut)]
^- [vase state]
?~ taz [sut nub]
=^ pin=vase nub (build-fit wer pax.i.taz)
=? p.pin ?=(^ face.i.taz) [%face u.face.i.taz p.pin]
$(sut (slop pin sut), taz t.taz)
::
++ run-raw
|= [sut=vase raw=(list [face=term =path])]
^- [vase state]
?~ raw [sut nub]
=^ pin=vase nub (build-file (snoc path.i.raw %hoon))
=. p.pin [%face face.i.raw p.pin]
$(sut (slop pin sut), raw t.raw)
::
++ run-raz
|= [sut=vase raz=(list [face=term =spec =path])]
^- [vase state]
?~ raz [sut nub]
=^ res=(map @ta vase) nub
(build-directory path.i.raz)
=; pin=vase
=. p.pin [%face face.i.raz p.pin]
$(sut (slop pin sut), raz t.raz)
::
=/ =type (~(play ut p.sut) [%kttr spec.i.raz])
:: ensure results nest in the specified type,
:: and produce a homogenous map containing that type.
::
:- %- ~(play ut p.sut)
[%kttr %make [%wing ~[%map]] ~[[%base %atom %ta] spec.i.raz]]
|-
?~ res ~
?. (~(nest ut type) | p.q.n.res)
~| [%nest-fail path.i.raz p.n.res]
!!
:- [p.n.res q.q.n.res]
[$(res l.res) $(res r.res)]
::
++ run-maz
|= [sut=vase maz=(list [face=term =mark])]
^- [vase state]
?~ maz [sut nub]
=^ pin=vase nub (build-nave mark.i.maz)
=. p.pin [%face face.i.maz p.pin]
$(sut (slop pin sut), maz t.maz)
::
++ run-caz
|= [sut=vase caz=(list [face=term =mars])]
^- [vase state]
?~ caz [sut nub]
=^ pin=vase nub (build-cast mars.i.caz)
=. p.pin [%face face.i.caz p.pin]
$(sut (slop pin sut), caz t.caz)
::
++ run-bar
|= [sut=vase bar=(list [face=term =mark =path])]
^- [vase state]
?~ bar [sut nub]
=^ =cage nub (cast-path [path mark]:i.bar)
=. p.q.cage [%face face.i.bar p.q.cage]
$(sut (slop q.cage sut), bar t.bar)
::
:: +build-fit: build file at path, maybe converting '-'s to '/'s in path
::
++ build-fit
|= [pre=@tas pax=@tas]
^- [vase state]
(build-file (fit-path pre pax))
::
:: +fit-path: find path, maybe converting '-'s to '/'s
::
:: Try '-' before '/', applied left-to-right through the path,
:: e.g. 'a-foo/bar' takes precedence over 'a/foo-bar'.
::
++ fit-path
|= [pre=@tas pax=@tas]
^- path
=/ paz (segments pax)
|- ^- path
?~ paz
~_(leaf/"clay: no files match /{(trip pre)}/{(trip pax)}/hoon" !!)
=/ pux=path pre^(snoc i.paz %hoon)
?: (~(has by files) pux)
pux
$(paz t.paz)
::
++ all-fits
|= [=term suf=term]
^- (list path)
%+ turn (segments suf)
|= seg=path
[term (snoc seg %hoon)]
::
:: Gets a map of the data at the given path and all children of it.
::
:: i.e. +dip:of for a map, except doesn't shorten paths
::
++ dip-hat
|= pax=path
^- (map path (each page lobe))
%- malt
%+ skim ~(tap by files)
|= [p=path *]
?| ?=(~ pax)
?& !?=(~ p)
=(-.pax -.p)
$(p +.p, pax +.pax)
== ==
::
++ trace
|= [pri=@ print=(trap tape)]
(^trace verb pri print)
::
++ mist-to-pour
|= =mist
^- pour
?+ -.mist mist
%vale
:+ %vale path.mist
~| %file-not-found-mist^path.mist
=/ lob (~(got by files) path.mist)
?- -.lob
%& (page-to-lobe p.lob)
%| p.lob
==
::
%arch
=/ dip (dip-hat path.mist)
:+ %arch path.mist
%- ~(run by dip)
|= file=(each page lobe)
?- -.file
%& (page-to-lobe p.file)
%| p.file
==
==
::
++ soak-cage |=([s=soak n=state] ?>(?=(%cage -.s) [cage.s n]))
++ soak-vase |=([s=soak n=state] ?>(?=(%vase -.s) [vase.s n]))
++ soak-dais |=([s=soak n=state] ?>(?=(%dais -.s) [dais.s n]))
++ soak-tube |=([s=soak n=state] ?>(?=(%tube -.s) [tube.s n]))
++ soak-arch |=([s=soak n=state] ?>(?=(%arch -.s) [dir.s n]))
::
++ gain-sprig
|= [=mist next=(trap [soak state])]
^- [soak state]
?~ got=(~(get by sprig.nub) mist)
$:next
=? stack.nub ?=(^ stack.nub)
stack.nub(i (~(put in i.stack.nub) leak.u.got))
[soak.u.got nub]
::
++ gain-leak
|= [=mist next=$-(state [soak state])]
^- [soak state]
=^ top=(set leak) stack.nub stack.nub
=/ =leak [(mist-to-pour mist) top]
=. cycle.nub (~(del in cycle.nub) mist)
=? stack.nub ?=(^ stack.nub)
stack.nub(i (~(put in i.stack.nub) leak))
=/ spilt (~(has in spill.nub) leak)
=^ =soak nub
?^ got=(~(get by cache.nub) leak)
%- %+ trace 3 |.
=/ refs ?:(spilt 0 1)
%+ welp "cache {<pour.leak>}: adding {<refs>}, "
"giving {<(add refs refs.u.got)>}"
=? cache.nub !spilt
(~(put by cache.nub) leak [+(refs.u.got) soak.u.got])
[soak.u.got nub]
%- (trace 2 |.("cache {<pour.leak>}: creating"))
=^ =soak nub (next nub)
=. cache.nub (~(put by cache.nub) leak [1 soak])
:: If we're creating a cache entry, add refs to our dependencies
::
=/ deps ~(tap in deps.leak)
|-
?~ deps
[soak nub]
=/ got (~(got by cache.nub) i.deps)
%- %+ trace 3 |.
%+ welp "cache {<pour.leak>} for {<pour.i.deps>}"
": bumping to ref {<refs.got>}"
=. cache.nub (~(put by cache.nub) i.deps got(refs +(refs.got)))
$(deps t.deps)
?: spilt
[soak nub]
%- (trace 3 |.("spilt {<mist>}"))
=: spill.nub (~(put in spill.nub) leak)
sprig.nub (~(put by sprig.nub) mist leak soak)
==
[soak nub]
--
::
++ lose-leak
|= [verb=@ fad=flow =leak]
^- flow
?~ got=(~(get by fad) leak)
%- (trace verb 0 |.("lose missing leak {<leak>}"))
fad
?: (lth 1 refs.u.got)
%- (trace verb 3 |.("cache {<pour.leak>}: decrementing from {<refs.u.got>}"))
=. fad (~(put by fad) leak u.got(refs (dec refs.u.got)))
fad
=+ ?. =(0 refs.u.got) ~
((trace verb 0 |.("lose zero leak {<leak>}")) ~)
%- (trace verb 2 |.("cache {<pour.leak>}: freeing"))
=. fad (~(del by fad) leak)
=/ leaks ~(tap in deps.leak)
|- ^- flow
?~ leaks
fad
=. fad ^$(leak i.leaks)
$(leaks t.leaks)
::
++ lose-leaks
|= [verb=@ fad=flow leaks=(set leak)]
^- flow
=/ leaks ~(tap in leaks)
|-
?~ leaks
fad
$(fad (lose-leak verb fad i.leaks), leaks t.leaks)
::
++ trace
|= [verb=@ pri=@ print=(trap tape)]
?: (lth verb pri)
same
(slog leaf+"ford: {(print)}" ~)
--
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
:: section 4cA, filesystem logic
::
:: This core contains the main logic of clay. Besides `++ze`, this directly
:: contains the logic for commiting new revisions (local urbits), managing
:: and notifying subscribers (reactivity), and pulling and validating content
:: (remote urbits).
::
:: The state includes:
::
:: -- local urbit `our`
:: -- current time `now`
:: -- current duct `hen`
:: -- scry handler `ski`
:: -- all vane state `++raft` (rarely used, except for the object store)
:: -- target urbit `her`
:: -- target desk `syd`
::
:: For local desks, `our` == `her` is one of the urbits on our pier. For
:: foreign desks, `her` is the urbit the desk is on and `our` is the local
:: urbit that's managing the relationship with the foreign urbit. Don't mix
:: up those two, or there will be wailing and gnashing of teeth.
::
:: While setting up `++de`, we check if `our` == `her`. If so, we get
:: the desk information from `dos.rom`. Otherwise, we get the rung from
:: `hoy` and get the desk information from `rus` in there. In either case,
:: we normalize the desk information to a `++rede`, which is all the
:: desk-specific data that we utilize in `++de`. Because it's effectively
:: a part of the `++de` state, let's look at what we've got:
::
:: -- `lim` is the most recent date we're confident we have all the
:: information for. For local desks, this is always `now`. For foreign
:: desks, this is the last time we got a full update from the foreign
:: urbit.
:: -- `ref` is a possible request manager. For local desks, this is null.
:: For foreign desks, this keeps track of all pending foreign requests
:: plus a cache of the responses to previous requests.
:: -- `qyx` is the set of subscriptions, with listening ducts. These
:: subscriptions exist only until they've been filled.
:: -- `dom` is the actual state of the filetree. Since this is used almost
:: exclusively in `++ze`, we describe it there.
::
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
++ de :: per desk
|= [now=@da rof=roof hen=duct raft]
|= [her=ship syd=desk]
:: NB: ruf=raft crashes in the compiler
::
=* ruf |3.+6.^$
=| [mow=(list move) hun=(unit duct) rede]
=* red=rede ->+
=< apex
|%
++ abet :: resolve
^- [(list move) raft]
:- (flop mow)
?. =(our her)
:: save foreign +rede
::
=/ run (~(gut by hoy.ruf) her *rung)
=/ rug (~(put by rus.run) syd red)
ruf(hoy (~(put by hoy.ruf) her run(rus rug)))
:: save domestic +room
::
%= ruf
hun.rom (need hun)
dos.rom (~(put by dos.rom.ruf) syd [qyx dom per pew fiz]:red)
==
::
++ apex
^+ ..park
?. =(our her)
:: no duct, foreign +rede or default
::
=. mow
?: (~(has by hoy.ruf) her)
~
[hun.rom.ruf %pass /sinks %j %public-keys (silt her ~)]~
=. hun ~
=. |2.+6.park
=/ rus rus:(~(gut by hoy.ruf) her *rung)
%+ ~(gut by rus) syd
[lim=~2000.1.1 ref=`*rind qyx=~ dom=*dome per=~ pew=~ fiz=*melt]
..park
:: administrative duct, domestic +rede
::
=. mow ~
=. hun `hun.rom.ruf
=. |2.+6.park
=/ jod (~(gut by dos.rom.ruf) syd *dojo)
[lim=now ref=*(unit rind) [qyx dom per pew fiz]:jod]
..park
::
:: Handle `%sing` requests
::
++ aver
|= [for=(unit ship) mun=mood]
^- [(unit (unit cage)) _..park]
=+ ezy=?~(ref ~ (~(get by haw.u.ref) mun))
?^ ezy
[`u.ezy ..park]
?: ?=([%s [%ud *] %late *] mun)
:_ ..park
^- (unit (unit cage))
:+ ~ ~
^- cage
:- %cass
?~ let.dom
!>([0 *@da])
!>([let.dom t:(~(got by hut.ran) (~(got by hit.dom) let.dom))])
=+ nao=(case-to-aeon case.mun)
?: ?=([%s case %case ~] mun)
:: case existence check
[``[%flag !>(!=(~ nao))] ..park]
?~(nao [~ ..park] (read-at-aeon:ze for u.nao mun))
::
:: Queue a move.
::
++ emit
|= mof=move
%_(+> mow [mof mow])
::
:: Queue a list of moves
::
++ emil
|= mof=(list move)
%_(+> mow (weld (flop mof) mow))
::
:: Queue a list of moves, to be emitted before the rest
::
++ lime
|= mof=(list move)
%_(+> mow (weld mow (flop mof)))
::
:: Set timer.
::
++ bait
|= [hen=duct tym=@da]
(emit hen %pass /tyme/(scot %p her)/[syd] %b %wait tym)
::
:: Cancel timer.
::
++ best
|= [hen=duct tym=@da]
(emit hen %pass /tyme/(scot %p her)/[syd] %b %rest tym)
::
:: Give %writ, or slip a drip if foreign desk
::
++ writ
|= res=(unit [=mood =cage])
^- card
=/ =riot
?~ res
~
`[[care.mood case.mood syd] path.mood cage]:[u.res syd=syd]
?~ ref
[%give %writ riot]
[%slip %b %drip !>([%writ riot])]
::
++ case-to-date
|= =case
^- @da
:: if the case is already a date, use it.
::
?: ?=([%da *] case)
p.case
:: translate other cases to dates
::
=/ aey (case-to-aeon-before lim case)
?~ aey `@da`0
?: =(0 u.aey) `@da`0
t:(aeon-to-yaki:ze u.aey)
::
++ case-to-aeon (cury case-to-aeon-before lim)
::
:: Reduce a case to an aeon (version number)
::
:: We produce null if we can't yet reduce the case for whatever
:: resaon (usually either the time or aeon hasn't happened yet or
:: the label hasn't been created).
::
++ case-to-aeon-before
|= [lim=@da lok=case]
^- (unit aeon)
?- -.lok
%tas (~(get by lab.dom) p.lok)
%ud ?:((gth p.lok let.dom) ~ [~ p.lok])
%da
?: (gth p.lok lim) ~
|- ^- (unit aeon)
?: =(0 let.dom) [~ 0] :: avoid underflow
?: %+ gte p.lok
=< t
~| [%letdom let=let.dom hit=hit.dom hut=~(key by hut.ran)]
~| [%getdom (~(get by hit.dom) let.dom)]
%- aeon-to-yaki:ze
let.dom
[~ let.dom]
$(let.dom (dec let.dom))
==
::
:: Create a ford appropriate for the aeon
::
:: Don't forget to call +aeon-flow!
::
++ aeon-ford
|= yon=aeon
%- ford:fusion
=/ files (~(run by q:(aeon-to-yaki:ze yon)) |=(=lobe |+lobe))
[files lat.ran veb.bug fad ?:(=(yon let.dom) fod.dom [~ ~])]
:: Produce ford cache appropriate for the aeon
::
++ aeon-flow
|* [yon=aeon res=* fud=flow fod=flue]
:- res
^+ ..park
?: &(?=(~ ref) =(let.dom yon))
..park(fad fud, fod.dom fod)
:: if in the past, don't update ford cache, since any results have
:: no roots
::
..park
:: Transfer a request to another ship's clay.
::
++ send-over-ames
|= [=duct =ship index=@ud =riff]
^+ +>
::
=/ =desk p.riff
=/ =wire /warp-index/(scot %p ship)/(scot %tas desk)/(scot %ud index)
=/ =path [%question desk (scot %ud index) ~]
(emit duct %pass wire %a %plea ship %c path `riff-any`[%1 riff])
::
++ foreign-capable
|= =rave
|^
?- -.rave
%many &
%sing (good-care care.mood.rave)
%next (good-care care.mood.rave)
%mult
%- ~(all in paths.mool.rave)
|= [=care =path]
(good-care care)
==
::
++ good-care
|= =care
(~(has in ^~((silt `(list ^care)`~[%u %w %x %y %z]))) care)
--
::
:: Build and send agents to gall
::
:: Must be called at the end of a commit, but only while Clay is in a
:: fully-consistent state (eg not in the middle of a kelvin upgrade).
::
++ goad
^+ ..park
=^ moves-1 ruf abet
=^ moves-2 ruf abet:goad:(lu now rof hen ruf)
=. ..park apex
(emil (weld moves-1 moves-2))
::
:: Notify subscribers of changes to tire
::
:: Must be called any time tire could have changed, unless you called
:: goad (which calls tare internally).
::
++ tare
^+ ..park
=^ moves-1 ruf abet
=^ moves-2 ruf abet:tare:(lu now rof hen ruf)
=. ..park apex
(emil (weld moves-1 moves-2))
::
:: Create a request that cannot be filled immediately.
::
:: If it's a local request, we just put in in `qyx`, setting a timer if it's
:: waiting for a particular time. If it's a foreign request, we add it to
:: our request manager (ref, which is a ++rind) and make the request to the
:: foreign ship.
::
++ duce :: produce request
|= wov=wove
^+ +>
=. wov (dedupe wov)
=. qyx (~(put ju qyx) wov hen)
?~ ref
:: [wake] at @da must check if subscription was fulfilled
::
(run-if-future rove.wov |=(@da (bait hen +<)))
|- ^+ +>+.$
=/ =rave (rove-to-rave rove.wov)
=. rave
?. ?=([%sing %v *] rave) rave
[%many %| [%ud let.dom] case.mood.rave path.mood.rave]
::
?. (foreign-capable rave)
~|([%clay-bad-foreign-request-care rave] !!)
::
=+ inx=nix.u.ref
=. +>+.$
=< ?>(?=(^ ref) .)
(send-over-ames hen her inx syd `rave)
%= +>+.$
nix.u.ref +(nix.u.ref)
bom.u.ref (~(put by bom.u.ref) inx [hen rave ~ ~ |])
fod.u.ref (~(put by fod.u.ref) hen inx)
==
::
:: If a similar request exists, switch to the existing request.
::
:: "Similar" requests are those %next and %many requests which are the same
:: up to starting case, but we're already after the starting case. This
:: stacks later requests for something onto the same request so that they
:: all get filled at once.
::
++ dedupe :: find existing alias
|= wov=wove
^- wove
=; won=(unit wove) (fall won wov)
=* rov rove.wov
?- -.rov
%sing ~
%next
=+ aey=(case-to-aeon case.mood.rov)
?~ aey ~
%- ~(rep in ~(key by qyx))
|= [haw=wove res=(unit wove)]
?^ res res
?. =(for.wov for.haw) ~
=* hav rove.haw
=- ?:(- `haw ~)
?& ?=(%next -.hav)
=(mood.hav mood.rov(case case.mood.hav))
::
:: only a match if this request is before
:: or at our starting case.
=+ hay=(case-to-aeon case.mood.hav)
?~(hay | (lte u.hay u.aey))
==
::
%mult
=+ aey=(case-to-aeon case.mool.rov)
?~ aey ~
%- ~(rep in ~(key by qyx))
|= [haw=wove res=(unit wove)]
?^ res res
?. =(for.wov for.haw) ~
=* hav rove.haw
=- ?:(- `haw ~)
?& ?=(%mult -.hav)
=(mool.hav mool.rov(case case.mool.hav))
::
:: only a match if this request is before
:: or at our starting case, and it has been
:: tested at least that far.
=+ hay=(case-to-aeon case.mool.hav)
?& ?=(^ hay)
(lte u.hay u.aey)
?=(^ aeon.hav)
(gte u.aeon.hav u.aey)
==
==
::
%many
=+ aey=(case-to-aeon from.moat.rov)
?~ aey ~
%- ~(rep in ~(key by qyx))
|= [haw=wove res=(unit wove)]
?^ res res
?. =(for.wov for.haw) ~
=* hav rove.haw
=- ?:(- `haw ~)
?& ?=(%many -.hav)
=(hav rov(from.moat from.moat.hav))
::
:: only a match if this request is before
:: or at our starting case.
=+ hay=(case-to-aeon from.moat.hav)
?~(hay | (lte u.hay u.aey))
==
==
::
++ set-norm
|= =norm
=. nor.dom norm
..park
::
++ set-worn
|= [=tako =norm]
?: &(=(our her) =(tako (aeon-to-tako:ze let.dom)))
(mean leaf+"clay: can't set norm for current commit in {<syd>}" ~)
=. tom.dom (~(put by tom.dom) tako norm)
..park
::
:: Attach label to aeon
::
++ label
|= [bel=@tas aey=(unit aeon)]
^+ ..park
=/ yon ?~(aey let.dom u.aey)
=/ yen (~(get by lab.dom) bel) :: existing aeon?
:: no existing aeon is bound to this label
::
?~ yen
=. lab.dom (~(put by lab.dom) bel yon) :: [wake] <>
wake
:: an aeon is bound to this label,
:: but it is the same as the existing one, so we no-op
::
?: =(u.yen yon)
~& "clay: tried to rebind existing label {<bel>} to equivalent aeon {<yon>}"
..park
:: an existing aeon bound to the label
:: that is distinct from the requested one.
:: rewriting would violate referential transparency
::
~| %tried-to-rewrite-existing-label
~| "requested aeon: {<yon>}, existing aeon: {<u.yen>}"
!!
::
:: Porcelain commit
::
++ info
|= [deletes=(set path) changes=(map path cage)]
^+ ..park
?: =(0 let.dom)
?> ?=(~ deletes)
=/ data=(map path (each page lobe))
(~(run by changes) |=(=cage &+[p q.q]:cage))
(park | & &+[~ data] *rang)
::
=/ parent-tako=tako (aeon-to-tako:ze let.dom)
=/ data=(map path (each page lobe))
=/ parent-yaki (tako-to-yaki:ze parent-tako)
=/ after-deletes
%- ~(dif by q.parent-yaki)
(malt (turn ~(tap in deletes) |=(=path [path *lobe])))
=/ after=(map path (each page lobe))
(~(run by after-deletes) |=(=lobe |+lobe))
%- ~(uni by after)
^- (map path (each page lobe))
(~(run by changes) |=(=cage &+[p q.q]:cage))
::
=/ =yuki [~[parent-tako] data]
(park | & &+yuki *rang)
::
:: Unix commit
::
++ into
|= [pax=path all=? mod=(list [pax=path mim=(unit mime)])]
^+ ..park
:: filter out unchanged, cached %mime values
::
=. mod
%+ skip mod
|= [pax=path mim=(unit mime)]
?~ mim
|
?~ mum=(~(get by mim.dom) pax)
|
:: TODO: check mimetype
::
=(q.u.mim q.u.mum)
=/ =yaki
?: =(0 let.dom)
*yaki
(~(got by hut.ran) (~(got by hit.dom) let.dom))
(info (mode-to-commit q.yaki pax all mod))
::
:: Plumbing commit
::
:: Guaranteed to finish in one event.
::
:: updated: whether we've already completed sys upgrade
:: goat: whether we should call +goad at the end. Only false
:: during kelvin upgrade so that all commits can happen before
:: the +goad.
:: yoki: new commit
:: rang: any additional objects referenced
::
:: [goad] < if goat is false, then the caller is responsible to
:: call +goad.
::
:: TODO: needs to check tako in rang
::
++ park
=/ check-sane |
|^
|= [updated=? goat=? =yoki =rang]
^+ ..park
=: hut.ran (~(uni by hut.rang) hut.ran)
lat.ran (~(uni by lat.rang) lat.ran)
==
=/ new-data=(map path (each page lobe))
?- -.yoki
%& q.p.yoki
%| (~(run by q.p.yoki) |=(=lobe |+lobe))
==
?. %- ~(all in new-data) :: use +all:in so we get the key
|= [=path tum=(each page lobe)]
?: |(?=(%& -.tum) (~(has by lat.ran) p.tum))
&
=- (mean leaf/- ~)
"clay: commit failed, file tombstoned: {<path>} {<`@uv`p.tum>}"
!!
:: find desk kelvin
::
=/ kel=(set weft) (waft-to-wefts (get-kelvin yoki))
?. ?| (~(has in kel) zuse+zuse) :: kelvin match
?& !=(%base syd) :: best-effort compat
%- ~(any in kel)
|= =weft
&(=(%zuse lal.weft) (gth num.weft zuse))
==
?& =(%base syd) :: ready to upgrade
%+ levy ~(tap by tore:(lu now rof hen ruf))
|= [=desk =zest wic=(set weft)]
?| =(%base desk)
!?=(%live zest)
!=(~ (~(int in wic) kel))
==
==
==
?: (~(all in kel) |=(=weft (gth num.weft zuse)))
%- (slog leaf+"clay: old-kelvin, {<[need=zuse/zuse have=kel]>}" ~)
..park
=. wic.dom :: [tare] <
%+ roll ~(tap in kel)
|: [weft=*weft wic=wic.dom]
(~(put by wic) weft yoki)
=? ..park !?=(%base syd) wick :: [wick]
%- (slog leaf+"clay: wait-for-kelvin, {<[need=zuse/zuse have=kel]>}" ~)
tare :: [tare] >
=. wic.dom (~(del by wic.dom) zuse+zuse)
::
=/ old-yaki
?: =(0 let.dom)
*yaki
(aeon-to-yaki:ze let.dom)
=/ old-kel=(set weft)
?: =(0 let.dom)
[zuse+zuse ~ ~]
(waft-to-wefts (get-kelvin %| old-yaki))
=/ [deletes=(set path) changes=(map path (each page lobe))]
(get-changes q.old-yaki new-data)
~| [from=let.dom deletes=deletes changes=~(key by changes)]
::
:: promote ford cache
:: promote and fill in mime cache
::
=/ invalid (~(uni in deletes) ~(key by changes))
:: if /sys updated in %base, defer to arvo and return early
::
?: &(=(%base syd) !updated (~(any in invalid) is-kernel-path))
(sys-update yoki new-data)
:: after this point, there must be no early return except if it's a
:: complete no-op. any error conditions must crash. since we're
:: changing state, we may need to call +wake, +goad, etc, which
:: happens at the end of the function.
::
:: [wick] if this commit added compatibility to a future kelvin,
:: then we might have unblocked a kelvin upgrade.
::
:: or, if *this* is a kelvin upgrade, it's possible that another
:: kelvin upgrade will immediately be ready. for example, this
:: could be the case if all desks but one are ready for the next
:: two kelvins, and then that desk is suspended or receives a
:: commit with compatiblity with both kelvins.
::
:: in any of these cases, we finish the current commit but call
:: +wick so that we try to execute the kelvin upgrade afterward.
:: we want this commit to persist even if the subsequent kelvin
:: upgrade fails.
::
=. ..park wick
=. wic.dom :: [tare] <
%+ roll ~(tap in kel)
|: [weft=*weft wic=wic.dom]
?: (gte num.weft zuse)
wic
(~(put by wic) weft yoki)
::
=+ ?. (did-kernel-update invalid) ~
((slog 'clay: kernel updated' ~) ~)
=? updated updated (did-kernel-update invalid)
=> ?. updated .
~>(%slog.0^leaf/"clay: rebuilding {<syd>} after kernel update" .)
:: clear caches if zuse reloaded
::
=/ old-fod fod.dom
=. fod.dom
?: updated [~ ~]
(promote-ford fod.dom invalid)
=. fad
(lose-leaks:fusion veb.bug fad (~(dif in spill.old-fod) spill.fod.dom))
=? changes updated (changes-for-upgrade q.old-yaki deletes changes)
::
=/ files
=/ original=(map path (each page lobe))
(~(run by q.old-yaki) |=(=lobe |+lobe))
%- ~(dif by (~(uni by original) changes))
%- ~(gas by *(map path (each page lobe)))
(turn ~(tap in deletes) |=(=path [path |+*lobe]))
=/ =args:ford:fusion [files lat.ran veb.bug fad fod.dom]
::
=^ change-cages args (checkout-changes args changes)
=/ sane-continuation (sane-changes changes change-cages)
=/ new-pages=(map lobe page)
%- malt
%+ turn ~(tap by change-cages)
|= [=path =lobe =cage]
[lobe [p q.q]:cage]
=/ data=(map path lobe)
%- ~(urn by new-data)
|= [=path value=(each page lobe)]
?- -.value
%| p.value
%& lobe:(~(got by change-cages) path)
==
:: if we didn't change the data and it's not a merge commit, abort
::
?: &(=([r.old-yaki ~] p.p.yoki) =(data q.old-yaki))
:: [tare] > if no changes, then commits-in-waiting could not have
:: changed.
::
..park
=/ =yaki
?- -.yoki
%& (make-yaki p.p.yoki data now)
%| ?> =(data q.p.yoki)
p.yoki
==
:: [wake] < [ergo] < [goad] <
::
=: let.dom +(let.dom)
hit.dom (~(put by hit.dom) +(let.dom) r.yaki)
hut.ran (~(put by hut.ran) r.yaki yaki)
lat.ran (~(uni by new-pages) lat.ran)
==
=. file-store.args lat.ran
::
=/ mem (want-mime 0)
=/ res=[mum=(map path (unit mime)) mim=_mim.dom args=_args]
?. mem [~ ~ args]
=^ mum args (checkout-mime args deletes ~(key by changes))
[mum (apply-changes-to-mim mim.dom mum) args]
=. mim.dom mim.res
=. args args.res
::
=. fod.dom [spill sprig]:args
=. fad cache.args
=. ..park (emil (print q.old-yaki data))
:: if upgrading kelvin and there's a commit-in-waiting, use that
::
=? ..park &(=(%base syd) !=(old-kel kel))
=/ desks=(list [=desk =dojo]) ~(tap by dos.rom)
=^ moves-1 ruf abet
=| moves-2=(list move)
|- ^+ ..park
?~ desks
=. ..park apex
(emil (weld moves-1 moves-2))
?. ?=(%live liv.dom.dojo.i.desks)
$(desks t.desks)
?: ?=(%base desk.i.desks)
$(desks t.desks)
?~ wat=(~(get by wic.dom.dojo.i.desks) zuse+zuse)
(mean (cat 3 'clay: missing commit-in-waiting on ' desk.i.desks) ~)
=/ den ((de now rof hen ruf) our desk.i.desks)
:: [goad] < call without goading so that we apply all the commits
:: before trying to compile all desks to send to gall.
::
=^ moves-3 ruf abet:(park:den | | u.wat *^rang)
=. moves-2 (weld moves-2 moves-3)
$(desks t.desks)
:: tell gall to try to run agents if %held
::
:: [goad] > if goat or desk not running. %held uses park-held to
:: defer the goad into a new event, to attempt to revive the desk.
:: Note that %base will always be %live.
::
=. ..park
?- liv.dom
%held (emit hen %pass /park-held/[syd] %b %wait now)
%dead ..park
%live ?:(goat goad ..park)
==
:: notify unix and subscribers
::
=? ..park mem (ergo 0 mum.res) :: [ergo] >
wake:tare :: [wake] > [tare] >
::
:: +is-kernel-path: should changing .pax cause a kernel or vane reload?
::
++ is-kernel-path |=(pax=path ?=([%sys *] pax))
::
++ did-kernel-update
|= invalid=(set path)
?. |(=(%base syd) &(=(%home syd)))
|
%- ~(any in invalid)
|=(p=path &((is-kernel-path p) !?=([%sys %vane *] p)))
::
:: +get-kelvin: read the desk's kernel version from /sys/kelvin
::
++ get-kelvin
|= =yoki
^- waft
|^ ?- -.yoki
%|
%- lobe-to-waft
~> %mean.(cat 3 'clay: missing /sys/kelvin on ' syd)
~| ~(key by q.p.yoki)
(~(got by q.p.yoki) /sys/kelvin)
::
%&
=/ fil=(each page lobe)
~> %mean.(cat 3 'clay: missing /sys/kelvin on ' syd)
~| ~(key by q.p.yoki)
(~(got by q.p.yoki) /sys/kelvin)
?- -.fil
%& (page-to-waft p.fil)
%| (lobe-to-waft p.fil)
==
==
::
++ lobe-to-waft
|= =lobe
^- waft
=/ peg=(unit page) (~(get by lat.ran) lobe)
?~ peg ~|([%sys-kelvin-tombstoned syd] !!)
(page-to-waft u.peg)
::
++ page-to-waft
|= =page
^- waft
?+ p.page ~|(clay-bad-kelvin-mark/p.page !!)
%kelvin ;;(waft q.page)
%mime (cord-to-waft q.q:;;(mime q.page))
==
--
::
:: Find which files changed or were deleted
::
++ get-changes
|= [old=(map path lobe) new=(map path (each page lobe))]
^- [deletes=(set path) changes=(map path (each page lobe))]
=/ old=(map path (each page lobe))
(~(run by old) |=(=lobe |+lobe))
:* %- silt ^- (list path)
%+ murn ~(tap by (~(uni by old) new))
|= [=path *]
^- (unit ^path)
=/ a (~(get by new) path)
=/ b (~(get by old) path)
?: |(=(a b) !=(~ a))
~
`path
::
%- malt ^- (list [path (each page lobe)])
%+ murn ~(tap by (~(uni by old) new))
|= [=path *]
^- (unit [^path (each page lobe)])
=/ a (~(get by new) path)
=/ b (~(get by old) path)
?: |(=(a b) ?=(~ a))
~
`[path u.a]
==
:: Find all files for full desk rebuild
::
++ changes-for-upgrade
|= $: old=(map path lobe)
deletes=(set path)
changes=(map path (each page lobe))
==
^+ changes
=. old
%+ roll ~(tap in deletes)
|= [pax=path old=_old]
(~(del by old) pax)
=/ pre=_changes (~(run by old) |=(lob=lobe |+lob))
(~(uni by pre) changes)
::
++ promote-ford
|= [fod=flue invalid=(set path)]
^- flue
=/ old=(list leak) ~(tap in spill.fod)
=| new=flue
|- ^- flue
?~ old
new
=/ invalid
|- ^- ?
?| ?+ -.pour.i.old %|
%vale (~(has in invalid) path.pour.i.old)
%arch
:: TODO: overly conservative, should be only direct hoon
:: children
::
=/ len (lent path.pour.i.old)
%- ~(any in invalid)
|= =path
=(path.pour.i.old (scag len path))
==
::
=/ deps ~(tap in deps.i.old)
|- ^- ?
?~ deps
%|
?| ^$(i.old i.deps)
$(deps t.deps)
==
==
=? new !invalid
:- (~(put in spill.new) i.old)
=/ =mist (pour-to-mist pour.i.old)
?~ got=(~(get by sprig.fod) mist)
sprig.new
(~(put by sprig.new) mist u.got)
$(old t.old)
::
++ page-to-cord
|= =page
^- @t
?+ p.page ~|([%sys-bad-mark p.page] !!)
%hoon ;;(@t q.page)
%mime q.q:;;(mime q.page)
==
::
++ lobe-to-cord
|= =lobe
^- @t
=/ peg=(unit page) (~(get by lat.ran) lobe)
?~ peg
~|([%lobe-to-cord-tombstoned syd lobe] !!)
;;(@t q.u.peg)
::
:: Updated q.yaki
::
++ checkout-changes
|= [=ford=args:ford:fusion changes=(map path (each page lobe))]
^- [(map path [=lobe =cage]) args:ford:fusion]
%+ roll `(list [path (each page lobe)])`~(tap by changes)
|= $: [=path change=(each page lobe)]
[built=(map path [lobe cage]) cache=_ford-args]
==
^+ [built ford-args]
=. ford-args cache
=/ [=cage fud=flow fod=flue]
:: ~> %slog.[0 leaf/"clay: validating {(spud path)}"]
%- wrap:fusion
(read-file:(ford:fusion ford-args) path)
=. cache.ford-args fud
=. spill.ford-args spill.fod
=. sprig.ford-args sprig.fod
=/ =lobe
?- -.change
%| p.change
:: Don't use p.change.i.cans because that's before casting to
:: the correct mark.
::
%& (page-to-lobe [p q.q]:cage)
==
[(~(put by built) path [lobe cage]) ford-args]
::
:: Print notification to console
::
++ print
|= [old=(map path lobe) new=(map path lobe)]
^- (list move)
=/ [deletes=(set path) upserts=(map path (each page lobe))]
(get-changes old (~(run by new) |=(=lobe |+lobe)))
=/ upsert-set ~(key by upserts)
=/ old-set ~(key by old)
=/ changes=(set path) (~(int in upsert-set) old-set)
=/ additions=(set path) (~(dif in upsert-set) old-set)
?~ hun
~
?: (lte let.dom 1)
~
|^
;: weld
(paths-to-notes '-' deletes)
(paths-to-notes ':' changes)
(paths-to-notes '+' additions)
==
::
++ paths-to-notes
|= [prefix=@tD paths=(set path)]
%+ turn ~(tap in paths)
|= =path
^- move
[u.hun %pass /note %d %text prefix ' ' ~(ram re (path-to-tank path))]
::
++ path-to-tank
|= =path
=/ pre=^path ~[(scot %p our) syd (scot %ud let.dom)]
:+ %rose ["/" "/" ~]
%+ turn (weld pre path)
|= a=cord
^- tank
?: ((sane %ta) a)
[%leaf (trip a)]
[%leaf (dash:us (trip a) '\'' ~)]
--
::
:: Check sanity
::
++ sane-changes
|= $: changes=(map path (each page lobe))
change-cages=(map path [lobe cage])
==
^- (unit [(map path [lobe cage]) args:ford:fusion])
?. check-sane
~
=/ tak=(unit tako) (~(get by hit.dom) let.dom)
?~ tak
~
=/ =yaki (~(got by hut.ran) u.tak)
:: Assert all pages hash to their lobe
::
=/ foo
%- ~(urn by lat.ran)
|= [=lobe =page]
=/ actual-lobe=^lobe `@uv`(page-to-lobe page)
~| [%bad-lobe have=lobe need=actual-lobe]
?> =(lobe actual-lobe)
~
:: Assert we calculated the same change-cages w/o cache
::
:: ? remove deletes
::
=/ all-changes=(map path (each page lobe))
=/ original=(map path (each page lobe))
(~(run by q.yaki) |=(=lobe |+lobe))
(~(uni by original) changes)
=/ =args:ford:fusion [all-changes lat.ran veb.bug ~ ~ ~]
=^ all-change-cages args (checkout-changes args all-changes)
=/ ccs=(list [=path =lobe =cage]) ~(tap by change-cages)
|- ^+ *sane-changes
?^ ccs
?. =(`[lobe cage]:i.ccs (~(get by all-change-cages) path.i.ccs))
~| not-same-cages+path.i.ccs
!!
$(ccs t.ccs)
`[all-change-cages args]
::
:: Delay current update until sys update is complete
::
++ sys-update
|= $: =yoki
data=(map path (each page lobe))
==
^+ ..park
?> =(~ pud)
=. pud `[syd yoki]
|^ %. [hen %slip %c %pork ~]
emit:(pass-what files)
::
++ files
^- (list (pair path (cask)))
%+ murn
~(tap by data)
|= [pax=path dat=(each page lobe)]
^- (unit (pair path (cask)))
=/ xap (flop pax)
?> ?=(^ xap)
?. ?=(%hoon i.xap) ~
:^ ~ (flop t.xap) %hoon
~| [pax=pax p.dat]
?- -.dat
%& (page-to-cord p.dat)
%| (lobe-to-cord p.dat)
==
::
++ pass-what
|= fil=(list (pair path (cask)))
^+ ..park
(emit hen %pass /what %$ what/fil)
--
--
::
:: [goad] Try to revive desk, but if it fails crash the event.
::
++ take-park-held
|= err=(unit tang)
^+ ..park
?^ err
((slog leaf+"clay: desk {<syd>} failed to unsuspend" u.err) ..park)
=. liv.dom %live
goad
::
:: We always say we're merging from 'ali' to 'bob'. The basic steps,
:: not all of which are always needed, are:
::
:: -- fetch ali's desk, async in case it's remote
:: -- diff ali's desk against the mergebase
:: -- diff bob's desk against the mergebase
:: -- merge the diffs
:: -- commit
::
++ start-merge
|= [=ali=ship =ali=desk =case =germ]
^+ ..start-merge
=/ =wire /merge/[syd]/(scot %p ali-ship)/[ali-desk]/[germ]
(emit hen %pass wire %c %warp ali-ship ali-desk `[%sing %v case /])
::
++ make-melt
|= [bas=beak con=(list [beak germ])]
^- melt
:+ bas con
%- ~(gas by *(map beak (unit dome:clay)))
:- [bas *(unit dome:clay)]
(turn con |=(a=[beak germ] [-.a *(unit dome:clay)]))
::
++ start-fuse
|= [bas=beak con=(list [beak germ])]
^+ ..start-fuse
=/ moves=(list move)
%+ turn
[[bas *germ] con]
|= [bec=beak germ]
^- move
=/ wir=wire /fuse/[syd]/(scot %p p.bec)/[q.bec]/(scot r.bec)
[hen %pass wir %c %warp p.bec q.bec `[%sing %v r.bec /]]
::
:: We also want to clear the state (fiz) associated with this
:: merge and print a warning if it's non trivial i.e. we're
:: starting a new fuse before the previous one terminated.
::
=/ err=tang
?~ con.fiz
~
=/ discarded=tang
%+ turn
~(tap in sto.fiz)
|= [k=beak v=(unit dome:clay)]
^- tank
=/ received=tape ?~(v "missing" "received")
leaf+"{<(en-beam k ~)>} {received}"
:_ discarded
leaf+"fusing into {<syd>} from {<bas>} {<con>} - overwriting prior fuse"
=. fiz (make-melt bas con)
((slog err) (emil moves))
::
++ take-fuse
|^
::
|= [bec=beak =riot]
^+ ..take-fuse
?~ riot
::
:: By setting fiz to *melt the merge is aborted - any further
:: responses we get for the merge will cause take-fuse to crash
::
=. fiz *melt
=/ msg=tape <(en-beam bec ~)>
((slog [leaf+"clay: fuse failed, missing {msg}"]~) ..take-fuse)
?. (~(has by sto.fiz) bec)
=/ msg=tape <(en-beam bec ~)>
((slog [leaf+"clay: got strange fuse response {<msg>}"]~) ..take-fuse)
=. fiz
:+ bas.fiz con.fiz
(~(put by sto.fiz) bec `!<(dome:clay q.r.u.riot))
=/ all-done=flag
%- ~(all by sto.fiz)
|= res=(unit dome:clay)
^- flag
!=(res ~)
?. all-done
..take-fuse
=| rag=rang
=/ clean-state ..take-fuse
=/ initial-dome=dome:clay (need (~(got by sto.fiz) bas.fiz))
=/ next-yaki=yaki
(~(got by hut.ran) (~(got by hit.initial-dome) let.initial-dome))
=/ parents=(list tako) ~[(~(got by hit.initial-dome) let.initial-dome)]
=/ merges con.fiz
|-
^+ ..take-fuse
?~ merges
=. ..take-fuse (done-fuse clean-state %& ~)
(park | & [%| next-yaki(p (flop parents))] rag)
=/ [bec=beak g=germ] i.merges
=/ ali-dom=dome:clay (need (~(got by sto.fiz) bec))
=/ result (merge-helper p.bec q.bec g ali-dom `next-yaki)
?- -.result
%|
=/ failing-merge=tape "{<bec>} {<g>}"
(done-fuse clean-state %| %fuse-merge-failed leaf+failing-merge p.result)
::
%&
=/ merge-result=(unit merge-result) +.result
?~ merge-result
::
:: This merge was a no-op, just continue
::
$(merges t.merges)
?^ conflicts.u.merge-result
::
:: If there are merge conflicts send the error and abort the merge
::
(done-fuse clean-state %& conflicts.u.merge-result)
=/ merged-yaki=yaki
?- -.new.u.merge-result
%| +.new.u.merge-result
%&
::
:: Convert the yuki to yaki
::
=/ yuk=yuki +.new.u.merge-result
=/ lobes=(map path lobe)
%- ~(run by q.yuk)
|= val=(each page lobe)
^- lobe
?- -.val
%& (page-to-lobe +.val)
%| +.val
==
(make-yaki p.yuk lobes now)
==
%= $
next-yaki merged-yaki
merges t.merges
hut.ran (~(put by hut.ran) r.merged-yaki merged-yaki)
lat.rag (~(uni by lat.u.merge-result) lat.rag)
lat.ran (~(uni by lat.u.merge-result) lat.ran)
parents [(~(got by hit.ali-dom) let.ali-dom) parents]
==
==
:: +done-fuse: restore state after a fuse is attempted, whether it
:: succeeds or fails.
::
++ done-fuse
|= [to-restore=_..take-fuse result=(each (set path) (pair term tang))]
^+ ..take-fuse
=. fiz.to-restore *melt
(done:to-restore result)
--
::
++ done
|= result=(each (set path) (pair term tang))
^+ ..merge
(emit hen %give %mere result)
::
++ merge
|= [=ali=ship =ali=desk =germ =riot]
^+ ..merge
?~ riot
(done %| %ali-unavailable ~[>[ali-ship ali-desk germ]<])
=/ ali-dome=dome:clay
?: &(?=(@ -.q.q.r.u.riot) !=(~ -.q.q.r.u.riot))
!<(dome:clay q.r.u.riot)
+:!<([* dome:clay] q.r.u.riot)
=/ result=(each (unit merge-result) (pair term tang))
(merge-helper ali-ship ali-desk germ ali-dome ~)
?- -.result
%| (done %| +.result)
%&
=/ mr=(unit merge-result) +.result
?~ mr
(done %& ~)
=. ..merge (done %& conflicts.u.mr)
(park | & new.u.mr ~ lat.u.mr)
==
::
+$ merge-result [conflicts=(set path) new=yoki lat=(map lobe page)]
::
++ merge-helper
|= [=ali=ship =ali=desk =germ ali-dome=dome:clay next-yaki=(unit yaki)]
^- (each (unit merge-result) [term tang])
|^
^- (each (unit merge-result) [term tang])
=/ ali-yaki=yaki (~(got by hut.ran) (~(got by hit.ali-dome) let.ali-dome))
=/ bob-yaki=(unit yaki)
?~ next-yaki
?~ let.dom
~
(~(get by hut.ran) (~(got by hit.dom) let.dom))
next-yaki
=/ res (mule |.((merge-by-germ ali-yaki bob-yaki)))
?- -.res
%& &+p.res
%| |+merge-failed+p.res
==
::
++ merge-by-germ
|= [=ali=yaki bob-yaki=(unit yaki)]
^- (unit merge-result)
::
:: If this is an %init merge, we set the ali's commit to be
:: bob's.
::
?: ?=(%init germ)
?> ?=(~ bob-yaki)
`[conflicts=~ new=|+ali-yaki lat=~]
::
=/ bob-yaki (need bob-yaki)
|^
^- (unit merge-result)
?- germ
::
:: If this is a %only-this merge, we check to see if ali's and bob's
:: commits are the same, in which case we're done.
:: Otherwise, we create a new commit with bob's data plus ali and
:: bob as parents.
::
%only-this
?: =(r.ali-yaki r.bob-yaki)
~
:* ~
conflicts=~
new=&+[[r.bob-yaki r.ali-yaki ~] (to-yuki q.bob-yaki)]
lat=~
==
::
:: If this is a %only-that merge, we check to see if ali's and bob's
:: commits are the same, in which case we're done. Otherwise, we
:: create a new commit with ali's data plus ali and bob as
:: parents.
::
%only-that
?: =(r.ali-yaki r.bob-yaki)
~
:* ~
conflicts=~
new=&+[[r.bob-yaki r.ali-yaki ~] (to-yuki q.ali-yaki)]
lat=~
==
::
:: Create a merge commit with exactly the contents of the
:: destination desk except take any files from the source commit
:: which are not in the destination desk.
::
%take-this
?: =(r.ali-yaki r.bob-yaki)
~
=/ new-data (~(uni by q.ali-yaki) q.bob-yaki)
:* ~
conflicts=~
new=&+[[r.bob-yaki r.ali-yaki ~] (to-yuki new-data)]
lat=~
==
::
:: Create a merge commit with exactly the contents of the source
:: commit except preserve any files from the destination desk
:: which are not in the source commit.
::
%take-that
?: =(r.ali-yaki r.bob-yaki)
~
=/ new-data (~(uni by q.bob-yaki) q.ali-yaki)
:* ~
conflicts=~
new=&+[[r.bob-yaki r.ali-yaki ~] (to-yuki new-data)]
lat=~
==
::
:: If this is a %fine merge, we check to see if ali's and bob's
:: commits are the same, in which case we're done. Otherwise, we
:: check to see if ali's commit is in the ancestry of bob's, in
:: which case we're done. Otherwise, we check to see if bob's
:: commit is in the ancestry of ali's. If not, this is not a
:: fast-forward merge, so we error out. If it is, we add ali's
:: commit to bob's desk and checkout.
::
%fine
?: =(r.ali-yaki r.bob-yaki)
~
?: (~(has in (reachable-takos:ze r.bob-yaki)) r.ali-yaki)
~
?. (~(has in (reachable-takos:ze r.ali-yaki)) r.bob-yaki)
~_ %bad-fine-merge
~| "tried fast-forward but is not ancestor or descendant"
!!
`[conflicts=~ new=|+ali-yaki lat=~]
::
?(%meet %mate %meld %meet-this %meet-that)
?: =(r.ali-yaki r.bob-yaki)
~
?: (~(has in (reachable-takos:ze r.bob-yaki)) r.ali-yaki)
~
?: (~(has in (reachable-takos:ze r.ali-yaki)) r.bob-yaki)
$(germ %fine)
=/ merge-points (find-merge-points ali-yaki bob-yaki)
?~ merge-points
~_ %merge-no-merge-base
~| "consider a %this or %that merge to get a mergebase"
!!
=/ merge-point=yaki n.merge-points
?: ?=(?(%mate %meld) germ)
=/ ali-diffs=cane (diff-base ali-yaki bob-yaki merge-point)
=/ bob-diffs=cane (diff-base bob-yaki ali-yaki merge-point)
=/ bof=(map path (unit cage))
(merge-conflicts can.ali-diffs can.bob-diffs)
(build ali-yaki bob-yaki merge-point ali-diffs bob-diffs bof)
=/ ali-diffs=cane (calc-diffs ali-yaki merge-point)
=/ bob-diffs=cane (calc-diffs bob-yaki merge-point)
=/ both-diffs=(map path *)
%- %~ int by
%- ~(uni by `(map path *)`new.ali-diffs)
%- ~(uni by `(map path *)`cal.ali-diffs)
%- ~(uni by `(map path *)`can.ali-diffs)
`(map path *)`old.ali-diffs
%- ~(uni by `(map path *)`new.bob-diffs)
%- ~(uni by `(map path *)`cal.bob-diffs)
%- ~(uni by `(map path *)`can.bob-diffs)
`(map path *)`old.bob-diffs
?: &(?=(%meet germ) !=(~ both-diffs))
~_ %meet-conflict
~| [~(key by both-diffs) "consider a %mate merge"]
!!
=/ both-done=(map path lobe)
|^
?- germ
%meet ~
%meet-this (resolve (~(uni by new.bob-diffs) cal.bob-diffs))
%meet-that (resolve (~(uni by new.ali-diffs) cal.ali-diffs))
==
++ resolve
|= news=(map path lobe)
%- malt ^- (list [path lobe])
%+ murn ~(tap by both-diffs)
|= [=path *]
^- (unit [^path lobe])
=/ new (~(get by news) path)
?~ new
~
`[path u.new]
--
::
=/ deleted
%- ~(dif by (~(uni by old.ali-diffs) old.bob-diffs))
(~(run by both-done) |=(* ~))
=/ not-deleted=(map path lobe)
%+ roll ~(tap by deleted)
=< .(not-deleted q.merge-point)
|= [[pax=path ~] not-deleted=(map path lobe)]
(~(del by not-deleted) pax)
=/ hat=(map path lobe)
%- ~(uni by not-deleted)
%- ~(uni by new.ali-diffs)
%- ~(uni by new.bob-diffs)
%- ~(uni by cal.ali-diffs)
cal.bob-diffs
:* ~
conflicts=~
new=&+[[r.bob-yaki r.ali-yaki ~] (to-yuki hat)]
lat=~
==
==
::
++ to-yuki
|= m=(map path lobe)
^- (map path (each page lobe))
(~(run by m) |=(=lobe |+lobe))
::
:: The set of changes between the mergebase and one of the desks
:: being merged
::
:: -- `new` is the set of files in the new desk and not in the
:: mergebase.
:: -- `cal` is the set of changes in the new desk from the
:: mergebase except for any that are also in the other new desk.
:: -- `can` is the set of changes in the new desk from the
:: mergebase that are also in the other new desk (potential
:: conflicts).
:: -- `old` is the set of files in the mergebase and not in the
:: new desk.
::
+$ cane
$: new=(map path lobe)
cal=(map path lobe)
can=(map path cage)
old=(map path ~)
==
::
:: Calculate cane knowing there are no files changed by both
:: desks
::
++ calc-diffs
|= [hed=yaki bas=yaki]
^- cane
:* %- molt
%+ skip ~(tap by q.hed)
|= [pax=path lob=lobe]
(~(has by q.bas) pax)
::
%- molt
%+ skip ~(tap by q.hed)
|= [pax=path lob=lobe]
=+ (~(get by q.bas) pax)
|(=(~ -) =([~ lob] -))
::
~
::
%- malt ^- (list [path ~])
%+ murn ~(tap by q.bas)
|= [pax=path lob=lobe]
^- (unit (pair path ~))
?. =(~ (~(get by q.hed) pax))
~
`[pax ~]
==
::
:: Diff yak against bas where different from yuk
::
++ diff-base
|= [yak=yaki yuk=yaki bas=yaki]
^- cane
=/ new=(map path lobe)
%- malt
%+ skip ~(tap by q.yak)
|= [=path =lobe]
(~(has by q.bas) path)
::
=/ cal=(map path lobe)
%- malt ^- (list [path lobe])
%+ murn ~(tap by q.bas)
|= [pax=path lob=lobe]
^- (unit (pair path lobe))
=+ a=(~(get by q.yak) pax)
=+ b=(~(get by q.yuk) pax)
?. ?& ?=(^ a)
!=([~ lob] a)
=([~ lob] b)
==
~
`[pax +.a]
::
=/ can=(map path cage)
%- malt
%+ murn ~(tap by q.bas)
|= [=path =lobe]
^- (unit [^path cage])
=/ in-yak (~(get by q.yak) path)
?~ in-yak
~
?: =(lobe u.in-yak)
~
=/ in-yuk (~(get by q.yuk) path)
?~ in-yuk
~
?: =(lobe u.in-yuk)
~
?: =(u.in-yak u.in-yuk)
~
=/ cug=(unit cage) (diff-lobes lobe u.in-yak)
?~ cug
~_ %tombstoned-mergebase
~| path
~| "consider a 2-way merge such as %only-this or %only-that"
!!
`[path u.cug]
::
=/ old=(map path ~)
%- malt ^- (list [path ~])
%+ murn ~(tap by q.bas)
|= [pax=path lob=lobe]
?. =(~ (~(get by q.yak) pax))
~
(some pax ~)
::
[new cal can old]
::
:: These can/should save their caches
::
++ lobe-to-cage
|= =lobe
^- (unit cage)
=/ peg=(unit page) (~(get by lat.ran) lobe)
?~ peg
~
=/ [=cage *]
%- wrap:fusion
(page-to-cage:(aeon-ford let.dom) u.peg)
`cage
::
++ get-dais
|= =mark
^- dais
=/ [=dais *]
%- wrap:fusion
(build-dais:(aeon-ford let.dom) mark)
dais
::
:: Diff two files on bob-desk
::
++ diff-lobes
|= [=a=lobe =b=lobe]
^- (unit cage)
=/ a-cage (lobe-to-cage a-lobe)
=/ b-cage (lobe-to-cage b-lobe)
?: |(?=(~ a-cage) ?=(~ b-cage))
~
?> =(p.u.a-cage p.u.b-cage)
=/ =dais (get-dais p.u.a-cage)
`[form:dais (~(diff dais q.u.a-cage) q.u.b-cage)]
::
:: Merge diffs that are on the same file.
::
++ merge-conflicts
|= [ali-conflicts=(map path cage) bob-conflicts=(map path cage)]
^- (map path (unit cage))
%- ~(urn by (~(int by ali-conflicts) bob-conflicts))
|= [=path *]
^- (unit cage)
=/ cal=cage (~(got by ali-conflicts) path)
=/ cob=cage (~(got by bob-conflicts) path)
=/ =mark
=+ (slag (dec (lent path)) path)
?~(- %$ i.-)
=/ =dais (get-dais mark)
=/ res=(unit (unit vase)) (~(join dais *vale:dais) q.cal q.cob)
?~ res
`[form:dais q.cob]
?~ u.res
~
`[form:dais u.u.res]
::
:: Apply the patches in bof to get the new merged content.
::
:: Gather all the changes between ali's and bob's commits and the
:: mergebase. This is similar to the %meet of ++merge, except
:: where they touch the same file, we use the merged versions.
::
++ build
|= $: ali=yaki
bob=yaki
bas=yaki
dal=cane
dob=cane
bof=(map path (unit cage))
==
^- (unit merge-result)
=/ both-patched=(map path cage)
%- malt
%+ murn ~(tap by bof)
|= [=path cay=(unit cage)]
^- (unit [^path cage])
?~ cay
~
:+ ~ path
=+ (~(get by q.bas) path)
?~ -
~| %mate-strange-diff-no-base
!!
:: +need ok because we would have crashed in +diff-base
::
=/ =cage ~|([%build-need path] (need (lobe-to-cage u.-)))
=/ =dais (get-dais p.cage)
?> =(p.u.cay form.dais)
:- p.cage
(~(pact dais q.cage) q.u.cay)
=/ con=(map path *) :: 2-change conflict
%- molt
%+ skim ~(tap by bof)
|=([pax=path cay=(unit cage)] ?=(~ cay))
=/ cab=(map path lobe) :: conflict base
%- ~(urn by con)
|= [pax=path *]
(~(got by q.bas) pax)
=. con :: change+del conflict
%- ~(uni by con)
%- malt ^- (list [path *])
%+ skim ~(tap by old.dal)
|= [pax=path ~]
?: (~(has by new.dob) pax)
~| %strange-add-and-del
!!
(~(has by can.dob) pax)
=. con :: change+del conflict
%- ~(uni by con)
%- malt ^- (list [path *])
%+ skim ~(tap by old.dob)
|= [pax=path ~]
?: (~(has by new.dal) pax)
~| %strange-del-and-add
!!
(~(has by can.dal) pax)
=. con :: add+add conflict
%- ~(uni by con)
%- malt ^- (list [path *])
%+ skip ~(tap by (~(int by new.dal) new.dob))
|= [pax=path *]
=((~(got by new.dal) pax) (~(got by new.dob) pax))
?: &(?=(%mate germ) ?=(^ con))
=+ (turn ~(tap by `(map path *)`con) |=([path *] >[+<-]<))
~_ %mate-conflict
~| (turn ~(tap by `(map path *)`con) |=([path *] +<-))
!!
=/ old=(map path lobe) :: oldies but goodies
%+ roll ~(tap by (~(uni by old.dal) old.dob))
=< .(old q.bob)
|= [[pax=path ~] old=(map path lobe)]
(~(del by old) pax)
=/ [hot=(map path lobe) lat=(map lobe page)] :: new content
%+ roll ~(tap by both-patched)
|= [[pax=path cay=cage] hat=(map path lobe) lat=(map lobe page)]
=/ =page [p q.q]:cay
=/ =lobe (page-to-lobe page)
:- (~(put by hat) pax lobe)
?: (~(has by lat) lobe)
lat
(~(uni by (malt [lobe page] ~)) lat)
=/ hat=(map path lobe) :: all the content
%- ~(uni by old)
%- ~(uni by new.dal)
%- ~(uni by new.dob)
%- ~(uni by cal.dal)
%- ~(uni by cal.dob)
%- ~(uni by hot)
cab
=/ del=(map path ?)
(~(run by (~(uni by old.dal) old.dob)) |=(~ %|))
=/ new &+[[r.bob r.ali ~] (~(run by hat) |=(=lobe |+lobe))]
:* ~
(silt (turn ~(tap by con) head))
new
lat
==
--
--
::
:: Find the most recent common ancestor(s).
::
:: For performance, this depends on +reachable-takos being
:: memoized.
::
++ find-merge-points
|= [=ali=yaki =bob=yaki]
^- (set yaki)
:: Loop through ancestors breadth-first, lazily generating ancestry
::
=/ ali-takos (reachable-takos:ze r.ali-yaki)
:: Tako worklist
::
=/ takos=(qeu tako) [r.bob-yaki ~ ~]
:: Mergebase candidates. Have proven they're common ancestors, but
:: not that they're a most recent
::
=| bases=(set tako)
:: Takos we've already checked or are in our worklist
::
=| done=(set tako)
|- ^- (set yaki)
=* outer-loop $
:: If we've finished our worklist, convert to yakis and return
::
?: =(~ takos)
(silt (turn ~(tap in bases) ~(got by hut.ran)))
=^ =tako takos ~(get to takos)
=. done (~(put in done) tako)
:: If this is a common ancestor, stop recursing through our
:: parentage. Check if it's comparable to any existing candidate.
::
?: (~(has in ali-takos) tako)
=/ base-list ~(tap in bases)
|- ^- (set yaki)
=* bases-loop $
?~ base-list
:: Proven it's not an ancestor of any previous candidate.
:: Remove all ancestors of new candidate and add it to the
:: candidate list.
::
=. bases
=/ new-reachable (reachable-takos:ze tako)
(~(put in (~(dif in bases) new-reachable)) tako)
outer-loop
:: If it's an ancestor of another candidate, this is not most
:: recent, so skip and try next in worklist.
::
=/ base-reachable (reachable-takos:ze i.base-list)
?: (~(has in base-reachable) tako)
outer-loop
bases-loop(base-list t.base-list)
:: Append parents to list and recurse
::
=/ bob-yaki (~(got by hut.ran) tako)
=/ new-candidates (skip p.bob-yaki ~(has in done))
%_ outer-loop
done (~(gas in done) new-candidates)
takos (~(gas to takos) new-candidates)
==
::
++ want-mime
|= yon=aeon
%- ~(any by mon)
|= =beam
&(=(p.beam her) =(q.beam syd) =(r.beam ud+yon))
::
:: Update mime cache
::
++ checkout-mime
|= $: =ford=args:ford:fusion
deletes=(set path)
changes=(set path)
==
^- [(map path (unit mime)) args:ford:fusion]
=/ mim=(map path (unit mime))
=/ dels=(list path) ~(tap by deletes)
|- ^- (map path (unit mime))
?~ dels
~
(~(put by $(dels t.dels)) i.dels ~)
=/ cans=(list path) ~(tap by changes)
|- ^- [(map path (unit mime)) args:ford:fusion]
?~ cans
[mim ford-args]
=/ [=cage fud=flow fod=flue]
~| mime-cast-fail+i.cans
(wrap:fusion (cast-path:(ford:fusion ford-args) i.cans %mime))
=. cache.ford-args fud
=. spill.ford-args spill.fod
=. sprig.ford-args sprig.fod
=^ mim ford-args $(cans t.cans)
[(~(put by mim) i.cans `!<(mime q.cage)) ford-args]
::
:: Add or remove entries to the mime cache
::
++ apply-changes-to-mim
|= [mim=(map path mime) changes=(map path (unit mime))]
^- (map path mime)
=/ changes-l=(list [pax=path change=(unit mime)])
~(tap by changes)
|- ^- (map path mime)
?~ changes-l
mim
?~ change.i.changes-l
$(changes-l t.changes-l, mim (~(del by mim) pax.i.changes-l))
$(changes-l t.changes-l, mim (~(put by mim) [pax u.change]:i.changes-l))
::
:: Emit update to unix sync
::
:: [ergo] Must be called any time the set of files changes that must
:: be mirrored to unix. +want-mime may optionally be used to cheaply
:: check if a version of a desk is mirrored to unix (and so +ergo
:: must be called).
::
++ ergo
|= [yon=aeon mim=(map path (unit mime))]
^+ ..park
=/ must (must-ergo yon mon (turn ~(tap by mim) head))
%- emil
%+ turn ~(tap by must)
|= [pot=term len=@ud pak=(set path)]
:* (need hez) %give %ergo pot
%+ turn ~(tap in pak)
|= pax=path
[(slag len pax) (~(got by mim) pax)]
==
::
:: Output is a map of mount points to {length-of-mounted-path set-of-paths}.
::
++ must-ergo
|= [yon=aeon mon=(map term beam) can=(list path)]
^- (map term (pair @ud (set path)))
%- malt ^- (list (trel term @ud (set path)))
%+ murn ~(tap by mon)
|= [nam=term bem=beam]
^- (unit (trel term @ud (set path)))
=- ?~(- ~ `[nam (lent s.bem) (silt `(list path)`-)])
%+ skim can
|= pax=path
&(=(p.bem her) =(q.bem syd) =(r.bem ud+yon) =(s.bem (scag (lent s.bem) pax)))
::
:: Mount a beam to unix
::
++ mount
|= [pot=term =case =spur]
^+ ..mount
=/ old-mon (~(get by mon) pot)
?^ old-mon
%- (slog >%already-mounted< >u.old-mon< ~)
..mount
=/ yon (case-to-aeon case)
?~ yon
%- (slog >%unknown-case< >[her syd case spur]< ~)
..mount
=/ for-yon ?:(=(let.dom u.yon) 0 u.yon)
=. mon :: [ergo]
(~(put by mon) pot [her syd ud+for-yon] spur)
=/ =yaki (~(got by hut.ran) (~(got by hit.dom) u.yon))
=/ files (~(run by q.yaki) |=(=lobe |+lobe))
=/ =args:ford:fusion
[files lat.ran veb.bug fad ?:(=(yon let.dom) fod.dom [~ ~])]
=^ mim args
(checkout-mime args ~ ~(key by files))
=. mim.dom (apply-changes-to-mim mim.dom mim)
(ergo for-yon mim)
::
:: Unmount a beam
::
++ unmount
|= [pot=term =case =spur]
^+ ..unmount
?> ?=(^ hez.ruf)
=. mon (~(del by mon) pot) :: [ergo]
=? mim.dom !(want-mime 0) ~
(emit u.hez.ruf %give %ogre pot)
::
:: Set permissions for a node.
::
++ perm
|= [pax=path rit=rite]
^+ +>
=/ mis=(set @ta)
%+ roll
=- ~(tap in -)
?- -.rit
%r who:(fall red.rit *rule)
%w who:(fall wit.rit *rule)
%rw (~(uni in who:(fall red.rit *rule)) who:(fall wit.rit *rule))
==
|= [w=whom s=(set @ta)]
?: |(?=(%& -.w) (~(has by cez) p.w)) s
(~(put in s) p.w)
?^ mis
:: TODO remove this nasty hack
::
?. ?=([[%a *] *] hen)
+>.$
=- (emit hen %give %done `[%perm-fail [%leaf "No such group(s): {-}"]~])
%+ roll ~(tap in `(set @ta)`mis)
|= [g=@ta t=tape]
?~ t (trip g)
:(weld t ", " (trip g))
:: TODO remove this nasty hack
::
=< ?. ?=([[%a *] *] hen)
.
(emit hen %give %done ~)
::
?- -.rit :: [wake] <>
%r wake(per (put-perm per pax red.rit))
%w wake(pew (put-perm pew pax wit.rit))
%rw wake(per (put-perm per pax red.rit), pew (put-perm pew pax wit.rit))
==
::
++ put-perm
|= [pes=regs pax=path new=(unit rule)]
?~ new (~(del by pes) pax)
(~(put by pes) pax u.new)
::
:: Remove a group from all rules.
::
:: [wake] <
::
++ forget-crew
|= nom=@ta
%= +> :: [wake] < +call
per (forget-crew-in nom per)
pew (forget-crew-in nom pew)
==
::
++ forget-crew-in
|= [nom=@ta pes=regs]
%- ~(run by pes)
|= r=rule
r(who (~(del in who.r) |+nom))
::
++ set-rein :: [goad] <
|= [ren=(map dude:gall ?)]
^+ ..park
..park(ren.dom ren)
::
++ set-zest :: [goad] <
|= liv=zest
=? liv =(%base syd) %live
..park(liv.dom liv)
::
++ rise :: [goad] <
|= [=dude:gall on=(unit ?)]
?< =(%base syd)
%_ ..park
ren.dom
?~ on
(~(del by ren.dom) dude)
(~(put by ren.dom) dude u.on)
==
::
++ stay
|= ver=(unit weft)
^+ ..park
=. wic.dom :: [tare] <>
?~ ver
~
(~(del by wic.dom) u.ver)
tare
::
:: Try to apply highest-versioned %base commit-in-waiting
::
:: [wick] Must be called whenever we might have unblocked a kelvin
:: upgrade. This is move-order agnostic because it defers the
:: upgrade into a new event.
::
++ wick
^+ ..park
(emit hen %pass /wick %b %wait now)
::
++ take-wick
|= err=(unit tang)
^+ ..park
?^ err
((slog leaf+"clay: failed to upgrade kelvin (wick)" u.err) ..park)
?> ?=(%base syd)
=/ wis=(list [weft =yoki])
%+ sort ~(tap by wic.dom)
|= [a=[weft yoki] b=[weft yoki]]
(gth num.a num.b)
=. wis (skip wis |=([[* a=@ud] *] (gte a zuse)))
?~ wis :: Every commit bottoms out here ?
..park
(park | & yoki.i.wis *rang)
::
:: Cancel a request.
::
:: For local requests, we just remove it from `qyx`. For foreign requests,
:: we remove it from `ref` and tell the foreign ship to cancel as well.
::
++ cancel-request :: release request
^+ ..cancel-request
=^ wos=(list wove) qyx
:_ (~(run by qyx) |=(a=(set duct) (~(del in a) hen)))
%- ~(rep by qyx)
|= [[a=wove b=(set duct)] c=(list wove)]
?:((~(has in b) hen) [a c] c)
::
?~ ref
=> .(ref `(unit rind)`ref)
?: =(~ wos) ..cancel-request :: TODO handle?
|- ^+ ..cancel-request
?~ wos ..cancel-request
=. ..cancel-request (run-if-future rove.i.wos |=(@da (best hen +<)))
$(wos t.wos)
::
?~ nux=(~(get by fod.u.ref) hen)
..cancel-request(ref `(unit rind)`ref)
=: fod.u.ref (~(del by fod.u.ref) hen)
bom.u.ref (~(del by bom.u.ref) u.nux)
==
%. [hen her u.nux [syd ~]]
send-over-ames(ref `(unit rind)`ref)
::
:: Handles a request.
::
:: `%sing` requests are handled by ++aver. `%next` requests are handled by
:: running ++aver at the given case, and then subsequent cases until we find
:: a case where the two results aren't equivalent. If it hasn't happened
:: yet, we wait. `%many` requests are handled by producing as much as we can
:: and then waiting if the subscription range extends into the future.
::
++ start-request
|= [for=(unit [ship @ud]) rav=rave]
^+ ..start-request
?: &(?=(^ for) !(foreign-capable rav))
~& [%bad-foreign-request-care from=for rav]
..start-request
=^ [new-sub=(unit rove) cards=(list card)] ..start-request
(try-fill-sub for (rave-to-rove rav))
=. ..start-request (send-cards cards [hen ~ ~])
?~ new-sub
..start-request
(duce for u.new-sub)
::
:: Called when a foreign ship answers one of our requests.
::
:: If it's a `%many` request, process in +take-foreign-update
::
:: After updating ref (our request manager), we handle %x, %w, and %y
:: responses. For %x, we call ++validate-x to validate the type of
:: the response. For %y, we coerce the result to an arch.
::
++ take-foreign-answer :: external change
|= [inx=@ud rut=(unit rand)]
^+ +>
?> ?=(^ ref)
=+ ruv=(~(get by bom.u.ref) inx)
?~ ruv +>.$
=/ rav=rave rave.u.ruv
?: ?=(%many -.rav)
abet:(apex:(foreign-update inx) rut)
?~ rut
:: nothing here, so cache that
::
%_ wake :: [wake] <>
haw.u.ref
?. ?=(%sing -.rav) haw.u.ref
(~(put by haw.u.ref) mood.rav ~)
==
|^
=/ result=(unit cage) (validate u.rut)
=/ =mood [p.p q.p q]:u.rut
=: haw.u.ref (~(put by haw.u.ref) mood result) :: [wake] <>
bom.u.ref (~(del by bom.u.ref) inx)
fod.u.ref (~(del by fod.u.ref) hen)
==
wake
:: something here, so validate
::
++ validate
|= =rand
^- (unit cage)
?- p.p.rand
%a ~| %no-big-ford-builds-across-network-for-now !!
%b ~| %i-guess-you-ought-to-build-your-own-marks !!
%c ~| %casts-should-be-compiled-on-your-own-ship !!
%d ~| %totally-temporary-error-please-replace-me !!
%e ~| %yes-naves-also-shouldnt-cross-the-network !!
%f ~| %even-static-casts-should-be-built-locally !!
%p ~| %requesting-foreign-permissions-is-invalid !!
%r ~| %no-cages-please-they-are-just-way-too-big !!
%s ~| %please-dont-get-your-takos-over-a-network !!
%t ~| %requesting-foreign-directory-is-vaporware !!
%v ~| %weird-shouldnt-get-v-request-from-network !!
%u `(validate-u r.rand)
%w `(validate-w r.rand)
%x (validate-x [p.p q.p q r]:rand)
%y `[p.r.rand !>(;;(arch q.r.rand))]
%z `(validate-z r.rand)
==
::
:: Make sure the incoming data is a %u response
::
++ validate-u
|= =page
^- cage
?> ?=(%flag p.page)
:- p.page
!> ;;(? q.page)
::
:: Make sure the incoming data is a %w response
::
++ validate-w
|= =page
^- cage
:- p.page
?+ p.page ~| %strange-w-over-nextwork !!
%cass !>(;;(cass q.page))
%null [[%atom %n ~] ~]
%nako !>(~|([%molding [&1 &2 &3]:q.page] ;;(nako q.page)))
==
::
:: Make sure that incoming data is of the mark it claims to be.
::
++ validate-x
|= [car=care cas=case pax=path peg=page]
^- (unit cage)
=/ vale-result
%- mule |.
%- wrap:fusion
:: Use %base's marks to validate, so we don't have to build the
:: foreign marks
::
=/ base-dome dom:(~(got by dos.rom) %base)
=/ f (%*(. aeon-ford dom base-dome) let.base-dome)
(page-to-cage:f peg)
?: ?=(%| -.vale-result)
%- (slog >%validate-x-failed< p.vale-result)
~
`-.p.vale-result
::
:: Make sure the incoming data is a %z response
::
++ validate-z
|= =page
^- cage
?> ?=(%uvi p.page)
:- p.page
!> ;;(@uvI q.page)
--
::
:: Respond to backfill request
::
:: Maybe should verify the requester is allowed to access this lobe?
::
++ give-backfill
|= [ver=?(%0 %1) =lobe]
^+ ..give-backfill
=/ peg=(unit page) (~(get by lat.ran) lobe)
=/ res
?- ver
%0 ?~(peg [%1 ~] [%direct lobe u.peg])
%1 [%1 peg]
==
(emit hen %give %boon res)
::
:: Ingest foreign update, requesting missing lobes if necessary
::
++ foreign-update
|= inx=@ud
?> ?=(^ ref)
=/ [sat=update-state lost=?]
=/ ruv (~(get by bom.u.ref) inx)
?~ ruv
~& [%clay-foreign-update-lost her syd inx]
[*update-state &]
[u.ruv |]
=/ done=? |
=. hen duct.sat
|%
++ abet
^+ ..foreign-update
?: lost
..foreign-update
?: done
=: bom.u.ref (~(del by bom.u.ref) inx)
fod.u.ref (~(del by fod.u.ref) hen)
==
=<(?>(?=(^ ref) .) wake)
=. bom.u.ref (~(put by bom.u.ref) inx sat)
..foreign-update
::
++ apex
|= rut=(unit rand)
^+ ..abet
?: lost ..abet
?~ rut
=. nako.sat (~(put to nako.sat) ~)
work
?> ?=(%nako p.r.u.rut)
=/ nako ;;(nako q.r.u.rut)
=/ missing (missing-lobes nako)
:: must be appended because we delete off front
::
=. need.sat (welp need.sat ~(tap in missing))
=. nako.sat (~(put to nako.sat) ~ nako)
work
::
++ missing-lobes
|= =nako
^- (set lobe)
=| missing=(set lobe)
=/ let-tako (~(got by gar.nako) let.nako)
=/ yakis ~(tap in lar.nako)
|- ^- (set lobe)
=* yaki-loop $
?~ yakis
missing
=/ =norm
:: Always try to fetch the entire last commit, because often we
:: want to merge from it.
::
?: =(let-tako r.i.yakis)
*norm:clay
(~(gut by tom.dom) r.i.yakis nor.dom)
=/ lobes=(list [=path =lobe]) ~(tap by q.i.yakis)
|- ^- (set lobe)
=* lobe-loop $
?~ lobes
yaki-loop(yakis t.yakis)
=? missing
?& !(~(has by lat.ran) lobe.i.lobes)
!=([~ %|] +:(~(fit of norm) path.i.lobes))
==
(~(put in missing) lobe.i.lobes)
lobe-loop(lobes t.lobes)
::
:: Receive backfill response
::
++ take-backfill
|= =fell
^+ ..abet
?: lost ..abet
=? need.sat ?=(^ need.sat) t.need.sat
=. ..park =>((take-fell fell) ?>(?=(^ ref) .))
work(busy.sat |)
::
:: Fetch next lobe
::
++ work
^+ ..abet
?: busy.sat
..abet
|- ^+ ..abet
?~ need.sat
:: NB: if you change to release nakos as we get enough lobes
:: for them instead of all at the end, you *must* store the
:: `lim` that should be applied after the nako is complete and
:: not use the one in the rave, since that will apply to the
:: end of subscription.
::
|- ^+ ..abet
?: =(~ nako.sat)
..abet
=^ next=(unit nako) nako.sat ~(get to nako.sat)
?~ next
..abet(done &)
=. ..abet =>((apply-foreign-update u.next) ?>(?=(~ need.sat) .))
=. ..foreign-update =<(?>(?=(^ ref) .) wake) :: [wake] >
$
:: This used to be what always removed an item from `need`. Now,
:: we remove in +take-backfill, but in the meantime we could have
:: received the next data from elsewhere (such as another desk
:: updating). Additionally, this is needed for backward
:: compatibility with old /backfill wires.
::
?: (~(has by lat.ran) i.need.sat)
$(need.sat t.need.sat)
(fetch i.need.sat)
::
++ fetch
|= =lobe
^+ ..abet
:: TODO: upgrade to %1 when most ships have upgaded
::
=/ =fill [%0 syd lobe]
=/ =wire /back-index/(scot %p her)/[syd]/(scot %ud inx)
=/ =path [%backfill syd (scot %ud inx) ~]
=. ..foreign-update
=< ?>(?=(^ ref) .)
(emit hen %pass wire %a %plea her %c path fill)
..abet(busy.sat &)
::
:: When we get a %w foreign update, store this in our state.
::
:: We get the commits from the nako and add them to our object
:: store, then we update the map of aeons to commits and the latest
:: aeon.
::
:: [wake] <
::
++ apply-foreign-update
|= =nako
^+ ..abet
:: hit: updated commit-hashes by @ud case
:: nut: new commit-hash/commit pairs
:: hut: updated commits by hash
::
=/ hit (~(uni by hit.dom) gar.nako)
=/ nut (turn ~(tap in lar.nako) |=(=yaki [r.yaki yaki]))
=/ hut (~(uni by (malt nut)) hut.ran)
:: traverse updated state and sanity check
::
=+ ~| :* %bad-foreign-update
[gar=gar.nako let=let.nako nut=(turn nut head)]
[hitdom=hit.dom letdom=let.dom]
==
?: =(0 let.nako)
~
=/ =aeon 1
|- ^- ~
=/ =tako
~| [%missing-aeon aeon] (~(got by hit) aeon)
=/ =yaki
~| [%missing-tako tako] (~(got by hut) tako)
?: =(let.nako aeon)
~
$(aeon +(aeon))
:: produce updated state
::
=/ =rave rave:(~(got by bom.u.ref) inx)
?> ?=(%many -.rave)
:: [ergo] We do not call +ergo here, but if we wanted to support
:: keeping a foreign mounted desk up-to-date, this would open
:: that invariant.
::
:: [goad] Same for +goad -- if we supported running agents off
:: foreign desks at an up-to-date revision, we would need to call
:: +goad here.
::
=: let.dom (max let.nako let.dom) :: [wake] < +work
hit.dom hit
hut.ran hut
:: Is this correct? Seeems like it should only go to `to` if
:: we've gotten all the way to the end. Leaving this
:: behavior unchanged for now, but I believe it's wrong.
::
lim ?.(?=(%da -.to.moat.rave) lim p.to.moat.rave)
==
..abet
--
::
++ seek
|= =cash
^+ ..park
?> ?=(^ ref)
=/ =tako
?: ?=(%tako -.cash)
p.cash
(aeon-to-tako:ze (need (case-to-aeon cash)))
=/ =yaki (tako-to-yaki:ze tako)
=/ lobes=(list lobe)
%+ murn ~(tap by q.yaki)
|= [=path =lobe]
?: (~(has by lat.ran) lobe)
~
`lobe
%- emil
%+ turn lobes
|= =lobe
:: TODO: upgrade to %1 when most ships have upgaded
::
=/ =fill [%0 syd lobe]
=/ =wire /seek/(scot %p her)/[syd]
=/ =path [%backfill syd ~]
[hen %pass wire %a %plea her %c path fill]
::
++ take-fell
|= =fell
^+ ..park
?> ?=(^ ref)
=/ peg=(unit page) (fell-to-page fell)
=? lat.ran ?=(^ peg)
(~(uni by (malt [(page-to-lobe u.peg) u.peg] ~)) lat.ran)
..park
::
:: fire function if request is in future
::
++ run-if-future
|= [rov=rove fun=$-(@da _.)]
^+ +>.$
=/ date=(unit @da)
?- -.rov
%sing
?. ?=(%da -.case.mood.rov) ~
`p.case.mood.rov
::
%next ~
%mult ~
%many
%^ hunt lth
?. ?=(%da -.from.moat.rov) ~
?. (lth now p.from.moat.rov) ~
[~ p.from.moat.rov]
?. ?=(%da -.to.moat.rov) ~
`(max now p.to.moat.rov)
==
?~ date
+>.$
(fun u.date)
::
++ send-cards
|= [cards=(list card) ducts=(set duct)]
^+ ..park
%- emil
%- zing
%+ turn cards
|= =card
%+ turn ~(tap by ducts)
|= =duct
[duct card]
::
:: Loop through open subscriptions and check if we can fill any of
:: them.
::
:: [wake] This must be called any time something might have changed
:: which fills a subscription or changes the set of subscriptions.
::
:: It is safe to call this multiple times, because it updates the
:: subscription state to reflect that it's responded. Usually this
:: means deleting the subscription, but %many can respond multiple
:: times.
::
:: One way of describing this invariant is that if you called +wake
:: on every desk at the end of every +call/+take, it would always
:: no-op.
::
++ wake
^+ .
=/ subs=(list [=wove ducts=(set duct)]) ~(tap by qyx)
=| qux=cult
|- ^+ ..wake
?~ subs
..wake(qyx qux)
?: =(~ ducts.i.subs)
$(subs t.subs)
=^ [new-sub=(unit rove) cards=(list card)] ..park
(try-fill-sub wove.i.subs)
=. ..wake (send-cards cards ducts.i.subs)
=? qux ?=(^ new-sub)
=/ =wove [for.wove.i.subs u.new-sub]
%+ ~(put by qux) wove
(~(uni in ducts.i.subs) (~(get ju qux) wove))
$(subs t.subs)
::
:: Try to fill a subscription
::
++ try-fill-sub
|= [far=(unit [=ship ver=@ud]) rov=rove]
^- [[(unit rove) (list card)] _..park]
=/ for=(unit ship) ?~(far ~ `ship.u.far)
?- -.rov
%sing
=/ cache-value=(unit (unit cage))
?~(ref ~ (~(get by haw.u.ref) mood.rov))
?^ cache-value
:: if we have a result in our cache, produce it
::
:_ ..park :- ~ :_ ~
(writ ?~(u.cache-value ~ `[mood.rov u.u.cache-value]))
:: else, check to see if rove is for an aeon we know
::
=/ aeon=(unit aeon) (case-to-aeon case.mood.rov)
?~ aeon
[[`rov ~] ..park]
:: we have the appropriate aeon, so read in the data
::
=^ value=(unit (unit cage)) ..park
(read-at-aeon:ze for u.aeon mood.rov)
?~ value
:: we don't have the data directly. how can we fetch it?
::
?: =(0 u.aeon)
~& [%clay-sing-indirect-data-0 `path`[syd '0' path.mood.rov]]
[[~ ~] ..park]
~& [%clay-sing-indirect-data desk=syd mood=mood.rov aeon=u.aeon]
[[`rov ~] ..park]
:: we have the data, so produce the results
::
:_ ..park :- ~ :_ ~
%- writ
?~ u.value
~
`[mood.rov u.u.value]
::
:: %next is just %mult with one path, so we pretend %next = %mult here.
::
?(%next %mult)
:: because %mult requests need to wait on multiple files for each
:: revision that needs to be checked for changes, we keep two
:: cache maps. {old} is the revision at {(dec aeon)}, {new} is
:: the revision at {aeon}. if we have no {aeon} yet, that means
:: it was still unknown last time we checked.
::
=* vor rov
|^
=/ rov=rove
?: ?=(%mult -.vor) vor
:* %mult
[case [[care path] ~ ~]]:mood.vor
aeon.vor
[[[care.mood.vor path.mood.vor] cach.vor] ~ ~]
~
==
?> ?=(%mult -.rov)
:: recurse here on next aeon if possible/needed.
::
|-
:: if we don't have an aeon yet, see if we have one now.
::
?~ aeon.rov
=/ aeon=(unit aeon) (case-to-aeon case.mool.rov)
:: if we still don't, wait.
::
?~ aeon [(store rov) ..park]
:: if we do, update the request and retry.
::
$(aeon.rov `+(u.aeon), old-cach.rov ~, new-cach.rov ~)
:: if old isn't complete, try filling in the gaps.
::
=^ o ..park
?: (complete old-cach.rov)
[old-cach.rov ..park]
(read-unknown mool.rov(case [%ud (dec u.aeon.rov)]) old-cach.rov)
=. old-cach.rov o
:: if the next aeon we want to compare is in the future, wait again.
::
=/ next-aeon=(unit aeon) (case-to-aeon [%ud u.aeon.rov])
?~ next-aeon [(store rov) ..park]
:: if new isn't complete, try filling in the gaps.
::
=^ n ..park
?: (complete new-cach.rov)
[new-cach.rov ..park]
(read-unknown mool.rov(case [%ud u.aeon.rov]) new-cach.rov)
=. new-cach.rov n
:: if new still isn't complete, wait again.
::
?. (complete new-cach.rov)
[(store rov) ..park]
:: if old not complete, give a result (possible false positive).
::
?: !(complete old-cach.rov)
:_ ..park
%- respond
%- malt
%+ murn ~(tap in paths.mool.rov)
|= [=care =path]
^- (unit [mood (unit cage)])
=/ cached (~(get by new-cach.rov) [care path])
?. ?=([~ ~ *] cached)
%- (slog 'clay: strange new-cache' >[care path cached]< ~)
~
`u=[[care [%ud let.dom] path] u.u.cached]
:: both complete, so check if anything has changed
::
=/ changes=(map mood (unit cage))
%+ roll ~(tap by old-cach.rov)
|= $: [[car=care pax=path] old-cach=cach]
changes=(map mood (unit cage))
==
=/ new-cach=cach (~(got by new-cach.rov) car pax)
?< |(?=(~ old-cach) ?=(~ new-cach))
=/ new-entry=(unit (pair mood (unit cage)))
=/ =mood [car [%ud u.aeon.rov] pax]
?~ u.new-cach
:: if new does not exist, always notify
::
`[mood ~]
?~ u.old-cach
:: added
::
`[mood `u.u.new-cach]
?: =([p q.q]:u.u.new-cach [p q.q]:u.u.old-cach)
:: unchanged
::
~
:: changed
::
`[mood `u.u.new-cach]
:: if changed, save the change
::
?~ new-entry
changes
(~(put by changes) u.new-entry)
:: if there are any changes, send response. if none, move on to
:: next aeon.
::
?^ changes [(respond changes) ..park]
$(u.aeon.rov +(u.aeon.rov), new-cach.rov ~)
::
:: check again later
::
++ store
|= rov=rove
^- [(unit rove) (list card)]
=/ new-rove=rove
?> ?=(%mult -.rov)
?: ?=(%mult -.vor) rov
?> ?=([* ~ ~] old-cach.rov)
=* one n.old-cach.rov
[%next [care.p.one case.mool.rov path.p.one] aeon.rov q.one]
[`new-rove ~]
::
:: send changes
::
++ respond
|= res=(map mood (unit cage))
^- [(unit rove) (list card)]
:- ~
?: ?=(%mult -.vor)
:_ ~
=/ moods ~(key by res)
=/ cas
?> ?=(^ moods)
[%da (case-to-date case.n.moods)]
=/ res
(~(run in moods) |=(m=mood [care.m path.m]))
=/ gift [%wris cas res]
?: ?=(^ ref)
[%slip %b %drip !>(gift)]
[%give gift]
?> ?=([* ~ ~] res)
:_ ~
%- writ
?~ q.n.res
~
`[p u.q]:n.res
::
:: no unknowns
::
++ complete
|= hav=(map (pair care path) cach)
?& !=(~ hav)
(levy ~(tap by hav) know)
==
::
:: know about file in cach
::
++ know |=([(pair care path) c=cach] ?=(^ c))
::
:: fill in the blanks
::
++ read-unknown
|= [=mool hav=(map (pair care path) cach)]
^- [_hav _..park]
=? hav ?=(~ hav)
%- malt ^- (list (pair (pair care path) cach))
%+ turn
~(tap in paths.mool)
|= [c=care p=path]
^- [[care path] cach]
[[c p] ~]
|- ^+ [hav ..park]
?~ hav [hav ..park]
=^ lef ..park $(hav l.hav)
=. l.hav lef
=^ rig ..park $(hav r.hav)
=. r.hav rig
=/ [[=care =path] =cach] n.hav
?^ cach
[hav ..park]
=^ q ..park (aver for care case.mool path)
=. q.n.hav q
[hav ..park]
--
::
%many
:_ ..park
=/ from-aeon (case-to-aeon from.moat.rov)
?~ from-aeon
:: haven't entered the relevant range, so do nothing
::
[`rov ~]
=/ to-aeon (case-to-aeon to.moat.rov)
:: TODO: shouldn't skip if tracking
::
=/ up-to ?~(to-aeon let.dom u.to-aeon)
=/ ver ?~(far %1 ver.u.far)
=. from.moat.rov [%ud +(let.dom)]
=/ =card
=/ =cage
?: track.rov
[%null [%atom %n ~] ~]
[%nako !>((make-nako:ze ver u.from-aeon up-to))]
(writ ~ [%w ud+let.dom /] cage)
?~ to-aeon
:: we're in the middle of the range, so produce what we can,
:: but don't end the subscription
::
[`rov card ~]
:: we're past the end of the range, so end subscription
::
[~ [card (writ ~) ~]]
==
::
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
::
:: This core has no additional state, and the distinction exists purely for
:: documentation. The overarching theme is that `++de` directly contains
:: logic for metadata about the desk, while `++ze` is composed primarily
:: of helper functions for manipulating the desk state (`++dome`) itself.
:: Functions include:
::
:: -- converting between cases, commit hashes, commits, content hashes,
:: and content
:: -- creating commits and content and adding them to the tree
:: -- finding which data needs to be sent over the network to keep the
:: other urbit up-to-date
:: -- reading from the file tree through different `++care` options
:: -- the `++me` core for merging.
::
:: The dome is composed of the following:
::
:: -- `let` is the number of the most recent revision.
:: -- `hit` is a map of revision numbers to commit hashes.
:: -- `lab` is a map of labels to revision numbers.
::
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
::
::
:: Other utility functions
::
++ ze
|%
:: These convert between aeon (version number), tako (commit hash),
:: and yaki (commit data structure)
::
++ aeon-to-tako ~(got by hit.dom)
++ aeon-to-yaki |=(=aeon (tako-to-yaki (aeon-to-tako aeon)))
++ tako-to-yaki ~(got by hut.ran)
::
:: Creates a nako of all the changes between a and b.
::
++ make-nako
|= [ver=@ud a=aeon b=aeon]
^- nako
:+ ?> (lte b let.dom)
|-
?: =(b let.dom)
hit.dom
:: del everything after b
$(hit.dom (~(del by hit.dom) let.dom), let.dom (dec let.dom))
b
?: =(0 b)
[~ ~]
=/ excludes=(set tako)
=| acc=(set tako)
=/ lower=@ud 1
|-
:: a should be excluded, so wait until we're past it
?: (gte lower +(a))
acc
=/ res=(set tako) (reachable-takos (~(got by hit.dom) lower))
$(acc (~(uni in acc) res), lower +(lower))
=/ includes=(set tako)
=| acc=(set tako)
=/ upper=@ud b
|-
?: (lte upper a)
acc
=/ res=(set tako) (reachable-takos (~(got by hit.dom) upper))
$(acc (~(uni in acc) res), upper (dec upper))
[(~(run in (~(dif in includes) excludes)) tako-to-yaki) ~]
:: Traverse parentage and find all ancestor hashes
::
++ reachable-takos :: reachable
|= p=tako
^- (set tako)
~+
=| s=(set tako)
|- ^- (set tako)
=. s (~(put in s) p)
=+ y=(tako-to-yaki p)
|- ^- (set tako)
?~ p.y
s
?: (~(has in s) i.p.y)
$(p.y t.p.y)
=. s ^$(p i.p.y)
$(p.y t.p.y)
::
++ read-a
!.
|= [=aeon =path]
^- [(unit (unit cage)) _..park]
=^ =vase ..park
~_ leaf/"clay: %a build failed {<[syd aeon path]>}"
%+ aeon-flow aeon
%- wrap:fusion
(build-file:(aeon-ford aeon) path)
:_(..park [~ ~ %vase !>(vase)])
::
++ read-b
!.
|= [=aeon =path]
^- [(unit (unit cage)) _..park]
?. ?=([@ ~] path)
[[~ ~] ..park]
=^ =dais ..park
%+ aeon-flow aeon
%- wrap:fusion
(build-dais:(aeon-ford aeon) i.path)
:_(..park [~ ~ %dais !>(dais)])
::
++ read-c
!.
|= [=aeon =path]
^- [(unit (unit cage)) _..park]
?. ?=([@ @ ~] path)
[[~ ~] ..park]
=^ =tube ..park
%+ aeon-flow aeon
%- wrap:fusion
(build-tube:(aeon-ford aeon) [i i.t]:path)
:_(..park [~ ~ %tube !>(tube)])
::
++ read-e
!.
|= [=aeon =path]
^- [(unit (unit cage)) _..park]
?. ?=([@ ~] path)
[[~ ~] ..park]
=^ =vase ..park
%+ aeon-flow aeon
%- wrap:fusion
(build-nave:(aeon-ford aeon) i.path)
:_(..park [~ ~ %nave vase])
::
++ read-f
!.
|= [=aeon =path]
^- [(unit (unit cage)) _..park]
?. ?=([@ @ ~] path)
[[~ ~] ..park]
=^ =vase ..park
%+ aeon-flow aeon
%- wrap:fusion
(build-cast:(aeon-ford aeon) [i i.t]:path)
:_(..park [~ ~ %cast vase])
::
:: TODO move to +read-buc
::
++ read-d
!.
|= [=aeon =path]
^- (unit (unit cage))
?. =(our her)
[~ ~]
?^ path
~&(%no-cd-path [~ ~])
[~ ~ %noun !>(~(key by dos.rom.ruf))]
::
:: Gets the permissions that apply to a particular node.
::
:: If the node has no permissions of its own, we use its parent's.
:: If no permissions have been set for the entire tree above the node,
:: we default to fully private (empty whitelist).
::
++ read-p
|= pax=path
^- (unit (unit cage))
=- [~ ~ %noun !>(-)]
:- (read-p-in pax per.red)
(read-p-in pax pew.red)
::
++ read-p-in
|= [pax=path pes=regs]
^- dict
=/ rul=(unit rule) (~(get by pes) pax)
?^ rul
:+ pax mod.u.rul
%- ~(rep in who.u.rul)
|= [w=whom out=(pair (set ship) (map @ta crew))]
?: ?=([%& @p] w)
[(~(put in p.out) +.w) q.out]
=/ cru=(unit crew) (~(get by cez.ruf) +.w)
?~ cru out
[p.out (~(put by q.out) +.w u.cru)]
?~ pax [/ %white ~ ~]
$(pax (scag (dec (lent pax)) `path`pax))
::
++ may-read
|= [who=ship car=care yon=aeon pax=path]
^- ?
?+ car
(allowed-by who pax per.red)
::
%p
=(who our)
::
?(%y %z)
=+ tak=(~(get by hit.dom) yon)
?~ tak |
=+ yak=(tako-to-yaki u.tak)
=+ len=(lent pax)
=- (levy ~(tap in -) |=(p=path (allowed-by who p per.red)))
%+ roll ~(tap in (~(del in ~(key by q.yak)) pax))
|= [p=path s=(set path)]
?. =(pax (scag len p)) s
%- ~(put in s)
?: ?=(%z car) p
(scag +(len) p)
==
::
++ may-write
|= [w=ship p=path]
(allowed-by w p pew.red)
::
++ allowed-by
|= [who=ship pax=path pes=regs]
^- ?
=/ rul=real rul:(read-p-in pax pes)
=/ in-list/?
?| (~(has in p.who.rul) who)
::
%- ~(rep by q.who.rul)
|= [[@ta cru=crew] out=_|]
?: out &
(~(has in cru) who)
==
?: =(%black mod.rul)
!in-list
in-list
:: +content-hash: get hash of contents (%cz hash)
::
++ content-hash
|= [=yaki pax=path]
^- @uvI
=+ len=(lent pax)
=/ descendants=(list (pair path lobe))
%+ turn
%+ skim ~(tap by (~(del by q.yaki) pax))
|= [paf=path lob=lobe]
=(pax (scag len paf))
|= [paf=path lob=lobe]
[(slag len paf) lob]
=+ us=(~(get by q.yaki) pax)
?: &(?=(~ descendants) ?=(~ us))
*@uvI
%+ roll
^- (list (pair path lobe))
[[~ ?~(us *lobe u.us)] descendants]
|=([[path lobe] @uvI] (shax (jam +<)))
:: +read-r: %x wrapped in a vase
::
++ read-r
|= [yon=aeon pax=path]
^- [(unit (unit cage)) _..park]
=^ x ..park (read-x yon pax)
:_ ..park
?~ x ~
?~ u.x [~ ~]
``[p.u.u.x !>(q.u.u.x)]
:: +read-s: produce miscellaneous
::
++ read-s
|= [yon=aeon pax=path]
^- (unit (unit cage))
?: ?=([%bloc ~] pax)
:^ ~ ~ %noun
:- -:!>(*(map lobe blob))
^- (map lobe blob)
%- %~ rep in
%- reachable-takos
(~(got by hit.dom) let.dom)
|= [t=tako o=(map lobe blob)]
%- ~(gas by o)
%+ turn
~(val by q:(~(got by hut.ran) t))
|=(l=lobe [l (~(got by lat.ran) l)])
?. ?=([@ * *] pax)
`~
?+ i.pax `~
%tako
=/ tak=(unit tako) (~(get by hit.dom) yon)
?~ tak
~
``tako+[-:!>(*tako) u.tak]
::
%yaki
=/ yak=(unit yaki) (~(get by hut.ran) (slav %uv i.t.pax))
?~ yak
~
``yaki+[-:!>(*yaki) u.yak]
::
%blob
=/ peg=(unit page) (~(get by lat.ran) (slav %uv i.t.pax))
?~ peg
~
``blob+[-:!>(*page) u.peg]
::
%hash
=/ yak=(unit yaki) (~(get by hut.ran) (slav %uv i.t.pax))
?~ yak
~
``uvi+[-:!>(*@uvI) (content-hash u.yak /)]
::
%cage
:: should save ford cache
::
=/ =lobe (slav %uv i.t.pax)
=/ peg=(unit page) (~(get by lat.ran) lobe)
?~ peg
~
=/ [=cage *]
%- wrap:fusion
(page-to-cage:(aeon-ford yon) u.peg)
``cage+[-:!>(*^cage) cage]
::
%open ``open+!>(prelude:(aeon-ford yon))
%late !! :: handled in +aver
%case !! :: handled in +aver
%base-tako
:: TODO this ignores the given beak
:: maybe move to +aver?
?> ?=(^ t.t.pax)
:^ ~ ~ %uvs !>
^- (list @uv)
=/ tako-a (slav %uv i.t.pax)
=/ tako-b (slav %uv i.t.t.pax)
=/ yaki-a (~(got by hut.ran) tako-a)
=/ yaki-b (~(got by hut.ran) tako-b)
%+ turn ~(tap in (find-merge-points yaki-a yaki-b))
|= =yaki
r.yaki
::
%base
?> ?=(^ t.t.pax)
:^ ~ ~ %uvs !>
^- (list @uv)
=/ him (slav %p i.t.pax)
=/ other dom:((de now rof hen ruf) him i.t.t.pax)
?: =(0 let.other)
~
=/ our-yaki (~(got by hut.ran) (~(got by hit.dom) yon))
=/ other-yaki (~(got by hut.ran) (~(got by hit.other) let.other))
%+ turn ~(tap in (find-merge-points other-yaki our-yaki))
|= =yaki
r.yaki
==
:: +read-t: produce the list of paths within a yaki with :pax as prefix
::
++ read-t
|= [yon=aeon pax=path]
^- (unit (unit [%file-list (hypo (list path))]))
:: if asked for version 0, produce an empty list of files
::
?: =(0 yon)
``[%file-list -:!>(*(list path)) *(list path)]
:: if asked for a future version, we don't have an answer
::
?~ tak=(~(get by hit.dom) yon)
~
:: look up the yaki snapshot based on the version
::
=/ yak=yaki (tako-to-yaki u.tak)
:: calculate the path length once outside the loop
::
=/ path-length (lent pax)
::
:^ ~ ~ %file-list
:- -:!>(*(list path))
^- (list path)
:: sort the matching paths alphabetically
::
=- (sort - aor)
:: traverse the filesystem, filtering for paths with :pax as prefix
::
%+ skim ~(tap in ~(key by q.yak))
|=(paf=path =(pax (scag path-length paf)))
::
:: Checks for existence of a node at an aeon.
::
:: This checks for existence of content at the node, and does *not* look
:: at any of its children.
::
++ read-u
|= [yon=aeon pax=path]
^- (unit (unit [%flag (hypo ?)]))
:: if asked for version 0, that never exists, so always give false
::
?: =(0 yon)
``[%flag -:!>(*?) |]
:: if asked for a future version, we don't have an answer
::
?~ tak=(~(get by hit.dom) yon)
~
:: look up the yaki snapshot based on the version
::
=/ yak=yaki (tako-to-yaki u.tak)
:: produce the result based on whether or not there's a file at :pax
::
``[%flag -:!>(*?) (~(has by q.yak) pax)]
::
:: Gets the dome (desk state) at a particular aeon.
::
++ read-v
|= [yon=aeon pax=path]
^- (unit (unit [%dome (hypo dome:clay)]))
?: (lth yon let.dom)
:* ~ ~ %dome -:!>(*dome:clay)
^- dome:clay
:* let=yon
hit=(molt (skim ~(tap by hit.dom) |=([p=@ud *] (lte p yon))))
lab=(molt (skim ~(tap by lab.dom) |=([* p=@ud] (lte p yon))))
== ==
?: (gth yon let.dom)
~
``[%dome -:!>(*dome:clay) [let hit lab]:dom]
::
:: Gets all cases refering to the same revision as the given case.
::
:: For the %da case, we give just the canonical timestamp of the revision.
::
++ read-w
|= yon=aeon
^- (unit (unit cage))
=- [~ ~ %cass !>(-)]
^- cass
:- yon
?: =(0 yon) `@da`0
t:(aeon-to-yaki yon)
::
:: Get the data at a node.
::
:: Use ford to read the file. Note this special-cases the hoon
:: mark for bootstrapping purposes.
::
++ read-x
|= [yon=aeon pax=path]
^- [(unit (unit cage)) _..park]
?: =(0 yon)
[[~ ~] ..park]
=+ tak=(~(get by hit.dom) yon)
?~ tak
[~ ..park]
=+ yak=(tako-to-yaki u.tak)
=+ lob=(~(get by q.yak) pax)
?~ lob
[[~ ~] ..park]
=/ peg=(unit page) (~(get by lat.ran) u.lob)
:: if tombstoned, nothing to return
::
?~ peg
[~ ..park]
:: should convert any lobe to cage
::
=^ =cage ..park
%+ aeon-flow yon
%- wrap:fusion
(page-to-cage:(aeon-ford yon) u.peg)
[``cage ..park]
::
:: Gets an arch (directory listing) at a node.
::
++ read-y
|= [yon=aeon pax=path]
^- (unit (unit [%arch (hypo arch)]))
?: =(0 yon)
``[%arch -:!>(*arch) *arch]
=+ tak=(~(get by hit.dom) yon)
?~ tak
~
=+ yak=(tako-to-yaki u.tak)
=+ len=(lent pax)
:^ ~ ~ %arch
:: ~& cy+pax
:- -:!>(*arch)
^- arch
:- (~(get by q.yak) pax)
^- (map knot ~)
%- molt ^- (list (pair knot ~))
%+ turn
^- (list (pair path lobe))
%+ skim ~(tap by (~(del by q.yak) pax))
|= [paf=path lob=lobe]
=(pax (scag len paf))
|= [paf=path lob=lobe]
=+ pat=(slag len paf)
[?>(?=(^ pat) i.pat) ~]
::
:: Gets a recursive hash of a node and all its children.
::
++ read-z
|= [yon=aeon pax=path]
^- (unit (unit [%uvi (hypo @uvI)]))
?: =(0 yon)
``uvi+[-:!>(*@uvI) *@uvI]
=+ tak=(~(get by hit.dom) yon)
?~ tak
~
[~ ~ %uvi [%atom %'uvI' ~] (content-hash (tako-to-yaki u.tak) pax)]
::
:: Get a value at an aeon.
::
:: Value can be either null, meaning we don't have it yet, [null null],
:: meaning we know it doesn't exist, or [null null cage],
:: meaning we either have the value directly or a content hash of the
:: value.
::
++ read-at-aeon :: read-at-aeon:ze
|= [for=(unit ship) yon=aeon mun=mood] :: seek and read
^- [(unit (unit cage)) _..park]
?. |(?=(~ for) (may-read u.for care.mun yon path.mun))
[~ ..park]
:: virtualize to catch and produce deterministic failures
::
|^ =/ res (mule |.(read))
?: ?=(%& -.res) p.res
%. [[~ ~] ..park]
(slog leaf+"clay: read-at-aeon fail {<[desk=syd mun]>}" p.res)
::
++ read
^- [(unit (unit cage)) _..park]
?- care.mun
%a (read-a yon path.mun)
%b (read-b yon path.mun)
%c (read-c yon path.mun)
%d [(read-d yon path.mun) ..park]
%e (read-e yon path.mun)
%f (read-f yon path.mun)
%p [(read-p path.mun) ..park]
%r (read-r yon path.mun)
%s [(read-s yon path.mun) ..park]
%t [(read-t yon path.mun) ..park]
%u [(read-u yon path.mun) ..park]
%v [(read-v yon path.mun) ..park]
%w [(read-w yon) ..park]
%x (read-x yon path.mun)
%y [(read-y yon path.mun) ..park]
%z [(read-z yon path.mun) ..park]
==
--
--
--
:: userspace agent management
::
++ lu
|= [now=@da rof=roof hen=duct raft]
=* ruf |3.+<.$
=| mow=(list move)
|%
++ abet
^- [(list move) raft]
[(flop mow) ruf]
::
++ emit
|= mof=move
%_(+> mow [mof mow])
::
++ emil
|= mof=(list move)
%_(+> mow (weld (flop mof) mow))
:: +ford: init ford
::
++ ford
|= [her=ship syd=desk yon=(unit aeon)]
=/ den ((de now rof hen ruf) her syd)
(aeon-ford:den ?~(yon let.dom:den u.yon))
:: +wrap: save ford cache
::
++ wrap
|* [her=ship syd=desk yon=(unit aeon) res=* =state:ford:fusion]
=^ moves ruf
=/ den ((de now rof hen ruf) her syd)
abet:+:(aeon-flow:den ?~(yon let.dom:den u.yon) res cache.state &2.state)
[res (emil moves)]
::
++ trace
|= [pri=@ print=(trap tape)]
?: (lth veb.bug pri)
same
(slog leaf+"goad: {(print)}" ~)
:: +goad: emit %load move for all desks, applying $rein's
::
:: [goad] Must be called any time the set of running agents changes.
:: This is whenever an agent is started, stopped, or updated.
::
:: This is not move-order agnostic -- you must be careful of
:: reentrancy as long as arvo's move order is depth-first.
::
:: [tare] >
::
++ goad
^+ ..abet
=^ sat=(list [=desk =bill]) ..abet
=/ desks=(list desk) ~(tap in ~(key by dos.rom))
|- ^- [(list [desk bill]) _..abet]
?~ desks
[~ ..abet]
=/ den ((de now rof hen ruf) our i.desks)
?. =(%live liv.dom.den)
%- (trace 2 |.("{<i.desks>} is not live"))
$(desks t.desks)
=^ res den (aver:den ~ %x da+now /desk/bill)
=. ruf +:abet:den
?. ?=([~ ~ *] res)
$(desks t.desks)
=/ bill ~| [%building-bill i.desks] !<(bill q.u.u.res)
=/ rid (override bill ren.dom.den)
%- %+ trace 2 |.
"{<i.desks>} has bill {<bill>} and rein {<ren.dom.den>}, so {<rid>}"
=^ sats ..abet $(desks t.desks)
[[[i.desks rid] sats] ..abet]
::
=. sat (apply-precedence sat)
=+ ?: (lth veb.bug 1) ~
%. ~ %- slog
%+ turn sat
|= [=desk =bill]
leaf+"goad: output: {<desk>}: {<bill>}"
=^ agents ..abet (build-agents sat)
:: TODO: enable if we can reduce memory usage
::
:: =. ..abet
:: (build-marks (turn (skip sat |=([desk =bill] =(bill ~))) head))
::
=. ..abet tare :: [tare] >
(emit hen %pass /lu/load %g %load agents)
:: +override: apply rein to bill
::
++ override
|= [duz=bill ren=(map dude:gall ?)]
^- bill
=. duz
%+ skip duz
|= =dude:gall
=(`| (~(get by ren) dude))
::
=/ dus (sy duz)
=. duz
%+ weld duz
%+ murn ~(tap by ren)
|= [=dude:gall on=?]
?: &(?=(%& on) !(~(has in dus) dude))
`u=dude
~
duz
:: +apply-precedence: resolve conflicts between $bill's
::
:: policy is to crash if multiple desks are trying to run the same
:: agent.
::
++ apply-precedence
|= sat=(list [=desk =bill])
^+ sat
:: sort desks in alphabetical order with %base first
::
=. sat (sort sat sort-desks)
:: for each desk
::
=| done=(set dude:gall)
|- ^+ sat
?~ sat
~
:: for each agent
::
=/ bil bill.i.sat
=^ this done
|- ^- [bill (set dude:gall)]
?~ bil
[~ done]
::
?: (~(has in done) i.bil)
~> %mean.(cat 3 'clay: cannot run app from two desks: %' i.bil)
!!
=. done (~(put in done) i.bil)
=^ next done $(bil t.bil)
[[i.bil next] done]
[[desk.i.sat this] $(sat t.sat)]
::
++ sort-desks
|= [a=[=desk *] b=[=desk *]]
^- ?
?: =(%base desk.a) &
?: =(%base desk.b) |
(aor desk.a desk.b)
:: build-file for each dude
::
++ build-agents
|= sat=(list [=desk =bill])
^- [load:gall _..abet]
=| lad=load:gall
|- ^- [load:gall _..abet]
?~ sat
[lad ..abet]
=/ f (ford our desk.i.sat ~)
=^ new=load:gall ..abet
%- wrap :^ our desk.i.sat ~
|- ^- [load:gall state:ford:fusion]
?~ bill.i.sat
[~ nub.f]
=^ =vase nub.f (build-file:f /app/[i.bill.i.sat]/hoon)
=/ agent ~| [%building-app bill.i.sat] !<(agent:gall vase)
=^ lid nub.f $(bill.i.sat t.bill.i.sat)
[[[i.bill.i.sat [our desk.i.sat da+now] agent] lid] nub.f]
=. lad (weld lad new)
$(sat t.sat)
:: build-dais for each mark
::
++ build-marks
|= desks=(list desk)
^+ ..abet
?~ desks
..abet
=/ f (ford our i.desks ~)
=^ null ..abet
%- wrap :^ our i.desks ~
=^ marks=(list mark) nub.f
=/ pax=path /
|- ^- [(list mark) _nub.f]
=/ den ((de now rof hen ruf) our i.desks)
=^ res den (aver:den ~ %y da+now mar+pax)
?. ?=([~ ~ *] res)
[~ nub.f]
=/ arch ~| [%building-arch i.desks] !<(arch q.u.u.res)
=/ m1=(list mark)
?. ?& ?=(^ fil.arch)
?=(^ pax)
=(/hoon (slag (dec (lent pax)) `path`pax))
==
~
:_ ~
?~ t.pax
''
|- ^- mark
?~ t.t.pax
i.pax
(rap 3 i.pax '-' $(pax t.pax) ~)
::
=^ m2 nub.f
|- ^- [(list mark) _nub.f]
?~ dir.arch
[~ nub.f]
=^ n1 nub.f ^$(pax (weld pax /[p.n.dir.arch]))
=^ n2 nub.f $(dir.arch l.dir.arch)
=^ n3 nub.f $(dir.arch r.dir.arch)
[:(weld n1 n2 n3) nub.f]
[(weld m1 m2) nub.f]
::
|- ^- [~ state:ford:fusion]
?~ marks
[~ nub.f]
=^ =dais nub.f (build-dais:f i.marks)
$(marks t.marks)
$(desks t.desks)
::
++ tore
^- rock:tire
%- ~(run by dos.rom)
|= =dojo
[liv.dom.dojo ~(key by wic.dom.dojo)]
::
:: [tare] Must be called any time the zest or commits-in-waiting
:: might have changed for a desk. +goad calls this uncondtionally,
:: but if you're not calling +goad, you may need to call this.
::
++ tare
?: =(~ tyr)
..abet
=/ tor tore
=/ waves=(list wave:tire) (walk:tire tur tor)
?~ waves
..abet
=. tur tor
%- emil
%- zing
%+ turn ~(tap in tyr)
|= =duct
^- (list move)
%+ turn waves
|= =wave:tire
^- move
[duct %give %tire %| wave]
--
--
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
:: section 4cA, filesystem vane
::
:: This is the arvo interface vane. Our formal state is a `++raft`, which
:: has five components:
::
:: -- `rom` is the state for all local desks.
:: -- `hoy` is the state for all foreign desks.
:: -- `ran` is the global, hash-addressed object store.
:: -- `mon` is the set of mount points in unix.
:: -- `hez` is the duct to the unix sync.
::
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
=| :: instrument state
$: ver=%13 :: vane version
ruf=raft :: revision tree
== ::
|= [now=@da eny=@uvJ rof=roof] :: current invocation
~% %clay-top ..part ~
|% ::
++ call :: handle request
~/ %clay-call
|= $: hen=duct
dud=(unit goof)
wrapped-task=(hobo task)
==
^- [(list move) _..^$]
::
=/ req=task ((harden task) wrapped-task)
::
:: TODO handle error notifications
::
?^ dud
[[[hen %slip %d %flog %crud [-.req tang.u.dud]] ~] ..^$]
::
?- -.req
%boat
:_ ..^$
[hen %give %hill (turn ~(tap by mon.ruf) head)]~
::
%cred
=. cez.ruf
?~ cew.req (~(del by cez.ruf) nom.req)
(~(put by cez.ruf) nom.req cew.req)
:: wake all desks, a request may have been affected.
=| mos=(list move)
=/ des ~(tap in ~(key by dos.rom.ruf))
|-
?~ des [[[hen %give %done ~] mos] ..^^$]
=/ den ((de now rof hen ruf) our i.des)
=^ mor ruf
=< abet:wake :: [wake] >
?: ?=(^ cew.req) den
(forget-crew:den nom.req)
$(des t.des, mos (weld mos mor))
::
%crew
[[hen %give %cruz cez.ruf]~ ..^$]
::
%crow
=/ des ~(tap by dos.rom.ruf)
=| rus=(map desk [r=regs w=regs])
|^
?~ des [[hen %give %croz rus]~ ..^^$]
=+ per=(filter-rules per.q.i.des)
=+ pew=(filter-rules pew.q.i.des)
=? rus |(?=(^ per) ?=(^ pew))
(~(put by rus) p.i.des per pew)
$(des t.des)
::
++ filter-rules
|= pes=regs
^+ pes
=- (~(gas in *regs) -)
%+ skim ~(tap by pes)
|= [p=path r=rule]
(~(has in who.r) |+nom.req)
--
::
%drop
~& %clay-idle
[~ ..^$]
::
%info
?: ?=(%| -.dit.req)
=/ bel=@tas p.dit.req
=/ aey=(unit aeon) q.dit.req
=^ mos ruf
=/ den ((de now rof hen ruf) our des.req)
abet:(label:den bel aey)
[mos ..^$]
=/ [deletes=(set path) changes=(map path cage)]
=/ =soba p.dit.req
=| deletes=(set path)
=| changes=(map path cage)
|- ^+ [deletes changes]
?~ soba
[deletes changes]
?- -.q.i.soba
%del $(soba t.soba, deletes (~(put in deletes) p.i.soba))
%ins $(soba t.soba, changes (~(put by changes) [p p.q]:i.soba))
%mut $(soba t.soba, changes (~(put by changes) [p p.q]:i.soba))
%dif ~|(%dif-not-implemented !!)
==
=^ mos ruf
=/ den ((de now rof hen ruf) our des.req)
abet:(info:den deletes changes)
[mos ..^$]
::
%init
[~ ..^$(hun.rom.ruf hen)]
::
%into
=. hez.ruf `hen
=+ bem=(~(get by mon.ruf) des.req)
?: &(?=(~ bem) !=(%$ des.req))
~|([%bad-mount-point-from-unix des.req] !!)
=/ bem=beam
?^ bem
u.bem
[[our %base %ud 1] ~] :: TODO: remove this fallback?
=/ dos (~(get by dos.rom.ruf) q.bem)
?~ dos
!! :: fire next in queue
=^ mos ruf
=/ den ((de now rof hen ruf) our q.bem)
abet:(into:den s.bem all.req fis.req)
[mos ..^$]
::
%merg :: direct state up
?: =(%$ des.req)
~&(%merg-no-desk !!)
=^ mos ruf
=/ den ((de now rof hen ruf) our des.req)
abet:(start-merge:den her.req dem.req cas.req how.req)
[mos ..^$]
::
%fuse
?: =(%$ des.req)
~&(%fuse-no-desk !!)
=^ mos ruf
=/ den ((de now rof hen ruf) our des.req)
abet:(start-fuse:den bas.req con.req)
[mos ..^$]
::
%mont
=. hez.ruf ?^(hez.ruf hez.ruf `[[%$ %sync ~] ~])
=^ mos ruf
=/ den ((de now rof hen ruf) p.bem.req q.bem.req)
abet:(mount:den pot.req r.bem.req s.bem.req)
[mos ..^$]
::
%dirk
?~ hez.ruf
~& %no-sync-duct
[~ ..^$]
?. (~(has by mon.ruf) pot.req)
~& [%not-mounted pot.req]
[~ ..^$]
[~[[u.hez.ruf %give %dirk pot.req]] ..^$]
::
%ogre
?: =(~ hez.ruf)
~& %no-sync-duct
[~ ..^$]
=* pot pot.req
=/ bem=(list [pot=term beam])
?@ pot
?~ got=(~(get by mon.ruf) pot)
~& [%not-mounted pot]
~
[pot u.got]~
%+ skim ~(tap by mon.ruf)
|= [=term =beam]
=(pot beam)
|- ^- [(list move) _..^^$]
?~ bem
[~ ..^^$]
=^ moves-1 ruf
=/ den ((de now rof hen ruf) p.i.bem q.i.bem)
abet:(unmount:den pot.i.bem r.i.bem s.i.bem)
=^ moves-2 ..^^$ $(bem t.bem)
[(weld moves-1 moves-2) ..^^$]
::
%park
=^ mos ruf
=/ den ((de now rof hen ruf) our des.req)
abet:(park:den | & [yok ran]:req)
[mos ..^$]
::
%pork
=/ [syd=desk =yoki] (need pud.ruf)
=. pud.ruf ~
=^ mos ruf
=/ den ((de now rof hen ruf) our syd)
abet:(park:den & & yoki *rang)
[mos ..^$]
::
%prep
[~ ..^$(lat.ran.ruf (~(uni by lat.req) lat.ran.ruf))]
::
%perm
=^ mos ruf
=/ den ((de now rof hen ruf) our des.req)
abet:(perm:den pax.req rit.req)
[mos ..^$]
::
%rein
=^ m1 ruf
=/ den ((de now rof hen ruf) our des.req)
abet:(set-rein:den ren.req)
=^ m2 ruf abet:goad:(lu now rof hen ruf) :: [goad] >
[(weld m1 m2) ..^$]
::
%stir
?+ arg.req ~|(%strange-stir !!)
[%verb @] [~ ..^$(veb.bug.ruf +.arg.req)]
[%mass @] [~ ..^$(mas.bug.ruf +.arg.req)]
[%goad ~]
=^ mos ruf abet:goad:(lu now rof hen ruf)
[mos ..^$]
::
[%rise =desk =dude:gall on=(unit ?)]
=^ m1 ruf
=/ den ((de now rof hen ruf) our desk.arg.req)
abet:(rise:den dude.arg.req on.arg.req)
=^ m2 ruf abet:goad:(lu now rof hen ruf) :: [goad] <
[(weld m1 m2) ..^$]
::
[%stay =desk ver=(unit weft)]
=^ moves ruf
=/ den ((de now rof hen ruf) our desk.arg.req)
abet:(stay:den ver.arg.req)
[moves ..^$]
::
[%trim ~]
=: fad.ruf *flow
dos.rom.ruf
%- ~(run by dos.rom.ruf)
|= =dojo
dojo(fod.dom *flue)
::
hoy.ruf
%- ~(run by hoy.ruf)
|= =rung
%= rung
rus
%- ~(run by rus.rung)
|= =rede
rede(fod.dom *flue)
==
==
[~ ..^$]
==
::
%tire
?~ p.req
=. tyr.ruf (~(del in tyr.ruf) hen)
`..^$
=. tyr.ruf (~(put in tyr.ruf) hen)
:_ ..^$
[hen %give %tire %& tore:(lu now rof hen ruf)]~
::
%tomb (tomb-clue:tomb hen clue.req)
%trim [~ ..^$]
%vega
:: wake all desks, then send pending notifications
::
=^ wake-moves ..^$
=/ desks=(list [=ship =desk])
%+ welp
(turn ~(tap by dos.rom.ruf) |=([=desk *] [our desk]))
%- zing
%+ turn ~(tap by hoy.ruf)
|= [=ship =rung]
%+ turn ~(tap by rus.rung)
|= [=desk *]
[ship desk]
|- ^+ [*(list move) ..^^$]
?~ desks
[~ ..^^$]
=^ moves-1 ..^^$ $(desks t.desks)
=^ moves-2 ruf abet:wake:((de now rof hen ruf) [ship desk]:i.desks)
[(weld moves-1 moves-2) ..^^$]
[wake-moves ..^$]
::
?(%warp %werp)
:: capture whether this read is on behalf of another ship
:: for permissions enforcement
::
=^ for req
?: ?=(%warp -.req)
[~ req]
:: ?: =(our who.req)
:: [~ [%warp wer.req rif.req]]
:- ?:(=(our who.req) ~ `[who.req -.rif.req])
[%warp wer.req riff.rif.req]
::
?> ?=(%warp -.req)
=* rif rif.req
=^ mos ruf
=/ den ((de now rof hen ruf) wer.req p.rif)
=< abet
?~ q.rif
cancel-request:den
(start-request:den for u.q.rif)
[mos ..^$]
::
%wick
=^ mos ruf
=/ den ((de now rof hen ruf) our %base)
abet:wick:den :: [wick]
[mos ..^$]
::
%zest
=^ m1 ruf
=/ den ((de now rof hen ruf) our des.req)
:: [wick] could be suspending the last blocking desk
::
abet:wick:(set-zest:den liv.req)
=^ m2 ruf abet:goad:(lu now rof hen ruf)
[(weld m1 m2) ..^$]
::
%plea
=* her ship.req
=* pax path.plea.req
=* res payload.plea.req
::
?: ?=([%backfill *] pax)
=+ ;;(=fill res)
=^ mos ruf
=/ den ((de now rof hen ruf) our desk.fill)
abet:(give-backfill:den -.fill lobe.fill)
[[[hen %give %done ~] mos] ..^$]
?> ?=([%question *] pax)
=+ ryf=;;(riff-any res)
:_ ..^$
:~ [hen %give %done ~]
=/ =wire
[%foreign-warp (scot %p her) t.pax]
[hen %pass wire %c %werp her our ryf]
==
==
::
++ load
=> |%
+$ raft-any
$% [%13 raft-13]
[%12 raft-12]
[%11 raft-11]
[%10 raft-10]
[%9 raft-9]
[%8 raft-8]
[%7 raft-7]
[%6 raft-6]
==
+$ raft-13 raft
+$ raft-12
$: rom=room-11
hoy=(map ship rung-11)
ran=rang
fad=flow
mon=(map term beam)
hez=(unit duct)
cez=(map @ta crew)
pud=(unit [=desk =yoki])
bug=[veb=@ mas=@]
==
+$ raft-11
$: rom=room-11
hoy=(map ship rung-11)
ran=rang
fad=flow
mon=(map term beam)
hez=(unit duct)
cez=(map @ta crew)
pud=(unit [=desk =yoki])
==
+$ room-11
$: hun=duct
dos=(map desk dojo-11)
==
+$ dojo-11
$: qyx=cult
dom=dome-11
per=regs
pew=regs
fiz=melt
==
+$ dome-11
$: let=aeon
hit=(map aeon tako)
lab=(map @tas aeon)
tom=(map tako norm)
nor=norm
mim=(map path mime)
fod=flue
==
+$ rung-11
$: rus=(map desk rede-11)
==
+$ rede-11
$: lim=@da
ref=(unit rind)
qyx=cult
dom=dome-11
per=regs
pew=regs
fiz=melt
==
+$ raft-10
$: rom=room-10
hoy=(map ship rung-10)
ran=rang-10
mon=(map term beam)
hez=(unit duct)
cez=(map @ta crew)
pud=(unit [=desk =yoki])
dist-upgraded=_|
==
+$ rang-10
$: hut=(map tako yaki)
lat=(map lobe blob-10)
==
+$ blob-10
$% [%delta p=lobe q=[p=mark q=lobe] r=page]
[%direct p=lobe q=page]
[%dead p=lobe ~]
==
+$ room-10
$: hun=duct
dos=(map desk dojo-10)
==
+$ dojo-10
$: qyx=cult-10
dom=dome-10
per=regs
pew=regs
fiz=melt-10
==
+$ dome-10
$: ank=ankh-10
let=aeon
hit=(map aeon tako)
lab=(map @tas aeon)
mim=(map path mime)
fod=*
==
+$ ankh-10 (axal [p=lobe q=cage])
+$ rung-10
$: rus=(map desk rede-10)
==
+$ rede-10
$: lim=@da
ref=(unit rind-10)
qyx=cult-10
dom=dome-10
per=regs
pew=regs
fiz=melt-10
==
+$ rind-10
$: nix=@ud
bom=(map @ud update-state-10)
fod=(map duct @ud)
haw=(map mood (unit cage))
==
+$ update-state-10
$: =duct
=rave
have=(map lobe blob-10)
need=(list lobe)
nako=(qeu (unit nako-10))
busy=_|
==
+$ nako-10
$: gar=(map aeon tako)
let=aeon
lar=(set yaki)
bar=(set blob-10)
==
+$ melt-10
[bas=beak con=(list [beak germ]) sto=(map beak (unit dome-clay-10))]
+$ dome-clay-10
$: ank=ankh-10
let=@ud
hit=(map @ud tako)
lab=(map @tas @ud)
==
+$ cult-10 (jug wove-10 duct)
+$ wove-10 [for=(unit [=ship ver=@ud]) =rove-10]
+$ rove-10
$% [%sing =mood]
[%next =mood aeon=(unit aeon) =cach-10]
$: %mult
=mool
aeon=(unit aeon)
old-cach=(map [=care =path] cach-10)
new-cach=(map [=care =path] cach-10)
==
[%many track=? =moat lobes=(map path lobe)]
==
+$ cach-10 (unit (unit (each cage lobe)))
+$ raft-9
$: rom=room-10
hoy=(map ship rung-10)
ran=rang-10
mon=(map term beam)
hez=(unit duct)
cez=(map @ta crew)
pud=(unit [=desk =yoki])
==
+$ raft-8
$: rom=room-8
hoy=(map ship rung-8)
ran=rang-10
mon=(map term beam)
hez=(unit duct)
cez=(map @ta crew)
pud=(unit [=desk =yoki])
==
+$ room-8
$: hun=duct
dos=(map desk dojo-8)
==
+$ rung-8
$: rus=(map desk rede-8)
==
+$ dojo-8
$: qyx=cult-10
dom=dome-8
per=regs
pew=regs
fiz=melt-10
==
+$ dome-8
$: ank=ankh-10
let=aeon
hit=(map aeon tako)
lab=(map @tas aeon)
mim=(map path mime)
fod=*
fer=* :: reef cache, obsolete
==
+$ rede-8
$: lim=@da
ref=(unit rind-10)
qyx=cult-10
dom=dome-8
per=regs
pew=regs
fiz=melt-10
==
+$ raft-7
$: rom=room-7
hoy=(map ship rung-7)
ran=rang-10
mon=(map term beam)
hez=(unit duct)
cez=(map @ta crew)
pud=(unit [=desk =yoki])
==
+$ room-7
$: hun=duct
dos=(map desk dojo-7)
==
+$ rung-7
$: rus=(map desk rede-7)
==
+$ dojo-7
$: qyx=cult-10
dom=dome-8
per=regs
pew=regs
==
+$ rede-7
$: lim=@da
ref=(unit rind-10)
qyx=cult-10
dom=dome-8
per=regs
pew=regs
==
+$ raft-6
$: rom=room-6
hoy=(map ship rung-6)
ran=rang-10
mon=(map term beam)
hez=(unit duct)
cez=(map @ta crew)
pud=(unit [=desk =yoki])
== ::
+$ room-6 [hun=duct dos=(map desk dojo-6)]
+$ dojo-6
$: qyx=cult-10
dom=dome-6
per=regs
pew=regs
==
+$ dome-6
$: ank=ankh-10
let=aeon
hit=(map aeon tako)
lab=(map @tas aeon)
mim=(map path mime)
fod=*
fer=*
==
+$ rung-6
$: rus=(map desk rede-6)
==
+$ rede-6
$: lim=@da
ref=(unit rind-10)
qyx=cult-10
dom=dome-6
per=regs
pew=regs
==
--
|= old=raft-any
|^
=? old ?=(%6 -.old) 7+(raft-6-to-7 +.old)
=? old ?=(%7 -.old) 8+(raft-7-to-8 +.old)
=? old ?=(%8 -.old) 9+(raft-8-to-9 +.old)
=? old ?=(%9 -.old) 10+(raft-9-to-10 +.old)
=? old ?=(%10 -.old) 11+(raft-10-to-11 +.old)
=? old ?=(%11 -.old) 12+(raft-11-to-12 +.old)
=? old ?=(%12 -.old) 13+(raft-12-to-13 +.old)
?> ?=(%13 -.old)
..^^$(ruf +.old)
:: +raft-6-to-7: delete stale ford caches (they could all be invalid)
::
++ raft-6-to-7
|= raf=raft-6
^- raft-7
%= raf
dos.rom
%- ~(run by dos.rom.raf)
|= doj=dojo-6
^- dojo-7
doj(fod.dom **)
::
hoy
%- ~(run by hoy.raf)
|= =rung-6
%- ~(run by rus.rung-6)
|= =rede-6
rede-6(dom dom.rede-6(fod **))
==
:: +raft-7-to-8: create bunted melts in each dojo/rede
::
++ raft-7-to-8
|= raf=raft-7
^- raft-8
%= raf
dos.rom
%- ~(run by dos.rom.raf)
|= doj=dojo-7
^- dojo-8
[qyx.doj dom.doj per.doj pew.doj *melt-10]
::
hoy
%- ~(run by hoy.raf)
|= =rung-7
%- ~(run by rus.rung-7)
|= r=rede-7
^- rede-8
[lim.r ref.r qyx.r dom.r per.r pew.r *melt-10]
==
:: +raft-8-to-9: remove reef cache
::
++ raft-8-to-9
|= raf=raft-8
^- raft-9
%= raf
dos.rom
%- ~(run by dos.rom.raf)
|= =dojo-8
^- dojo-10
=/ dom dom.dojo-8
dojo-8(dom [ank.dom let.dom hit.dom lab.dom mim.dom *flow])
::
hoy
%- ~(run by hoy.raf)
|= =rung-8
%- ~(run by rus.rung-8)
|= =rede-8
^- rede-10
=/ dom dom.rede-8
rede-8(dom [ank.dom let.dom hit.dom lab.dom mim.dom *flow])
==
:: +raft-9-to-10: add .dist-upgraded
::
++ raft-9-to-10
|= raf=raft-9
^- raft-10
raf(pud [pud.raf dist-upgraded=|])
::
:: +raft-10-to-11:
::
:: add tom and nor to dome
:: remove parent-mark from delta blobs
:: change blobs to pages
:: remove have from update-state
:: remove bar from nako
:: remove ankh
:: set cases in mon to ud+0
:: add fad
:: change fod type in dom
::
::
++ raft-10-to-11
|= raf=raft-10
|^
^- raft-11
%= raf
dos.rom
%- ~(run by dos.rom.raf)
|= =dojo-10
^- dojo-11
%= dojo-10
fiz *melt
qyx (cult-10-to-cult qyx.dojo-10)
dom
:* let.dom.dojo-10
hit.dom.dojo-10
lab.dom.dojo-10
~
*norm
mim.dom.dojo-10
~
~
==
==
::
hoy
%- ~(run by hoy.raf)
|= =rung-10
%- ~(run by rus.rung-10)
|= =rede-10
^- rede-11
%= rede-10
fiz *melt
qyx (cult-10-to-cult qyx.rede-10)
dom
:* let.dom.rede-10
hit.dom.rede-10
lab.dom.rede-10
~
*norm
mim.dom.rede-10
~
~
==
::
ref
?~ ref.rede-10
~
%= ref.rede-10
bom.u
%- ~(run by bom.u.ref.rede-10)
|= =update-state-10
%= update-state-10
|2
%= |3.update-state-10
nako
%- ~(gas to *(qeu (unit nako)))
%+ turn ~(tap to nako.update-state-10)
|= nak=(unit nako-10)
?~ nak ~
`u.nak(bar ~)
==
==
==
==
::
lat.ran
%- ~(gas by *(map lobe page))
%+ murn ~(tap by lat.ran.raf)
|= [=lobe =blob-10]
^- (unit [^lobe page])
?- -.blob-10
%delta ((slog 'clay: tombstoning delta!' ~) ~)
%dead ~
%direct `[lobe q.blob-10]
==
::
|3
:- *flow
%= |3.raf
mon (~(run by mon.raf) |=(=beam beam(r ud+0)))
|3 pud.raf
==
==
::
++ cult-10-to-cult
|= qyx=cult-10
^- cult
=/ qux=(list [=wove-10 ducts=(set duct)]) ~(tap by qyx)
%- malt
|- ^- (list [wove (set duct)])
?~ qux
~
:_ $(qux t.qux)
%= i.qux
rove-10.wove-10
?- -.rove-10.wove-10.i.qux
%sing rove-10.wove-10.i.qux
%many rove-10.wove-10.i.qux
%next
%= rove-10.wove-10.i.qux
cach-10 (cach-10-to-cach cach-10.rove-10.wove-10.i.qux)
==
::
%mult
%= rove-10.wove-10.i.qux
old-cach (caches-10-to-caches old-cach.rove-10.wove-10.i.qux)
new-cach (caches-10-to-caches new-cach.rove-10.wove-10.i.qux)
==
==
==
::
++ cach-10-to-cach
|= =cach-10
^- cach
?~ cach-10
~
?~ u.cach-10
[~ ~]
?- -.u.u.cach-10
%& ``p.u.u.cach-10
%| ~
==
::
++ caches-10-to-caches
|= caches-10=(map [=care =path] cach-10)
^- (map [=care =path] cach)
(~(run by caches-10) cach-10-to-cach)
--
:: +raft-11-to-12: add bug
::
++ raft-11-to-12
|= raf=raft-11
^- raft-12
raf(pud [pud.raf 0 0])
:: +raft-12-to-13:
::
:: add .liv and .ren to $dome's
:: add .tyr and .tur to $raft
::
++ raft-12-to-13
|= raf=raft-12
|^ ^- raft-13
:: turn on %base desk :: TODO handle other desks somehow
:: :: maybe have kiln send one-time list of desks
::
=; rof
rof(dos.rom (~(jab by dos.rom.rof) %base |=(d=dojo d(liv.dom %live))))
^- raft-13
%= raf
dos.rom (~(run by dos.rom.raf) dojo-11-to-13)
hoy (~(run by hoy.raf) rung-11-to-13)
|6 [&7.raf ~ ~ |7.raf]
==
::
++ dojo-11-to-13
|= doj=dojo-11
^- dojo
doj(dom (dome-11-to-13 dom.doj))
::
++ rung-11-to-13
|= rug=rung-11
^- rung
rug(rus (~(run by rus.rug) rede-11-to-13))
::
++ rede-11-to-13
|= red=rede-11
^- rede
red(dom (dome-11-to-13 dom.red))
::
++ dome-11-to-13
|= dom=dome-11
^- dome
dom(fod [fod.dom ~ liv=%dead ren=~])
--
--
::
++ scry :: inspect
~/ %clay-scry
^- roon
|= [lyc=gang car=term bem=beam]
^- (unit (unit cage))
=* scry-loop $
|^
=* ren car
=/ why=shop &/p.bem
=* syd q.bem
=/ lot=coin $/r.bem
=* tyl s.bem
::
?. ?=(%& -.why) ~
=* his p.why
?: &(=(ren %$) =(tyl /whey))
``mass+!>(whey)
:: ~& scry+[ren `path`[(scot %p his) syd ~(rent co lot) tyl]]
:: =- ~& %scry-done -
=+ luk=?.(?=(%$ -.lot) ~ ((soft case) p.lot))
?~ luk [~ ~]
?: =(%$ ren)
[~ ~]
=+ run=((soft care) ren)
?~ run [~ ~]
::TODO if it ever gets filled properly, pass in the full fur.
::
=/ for=(unit ship) ?~(lyc ~ ?~(u.lyc ~ `n.u.lyc))
?: &(=(our his) =(%x ren) =(%$ syd) =([%da now] u.luk))
(read-buc u.run tyl)
=/ den ((de now rof [/scryduct ~] ruf) his syd)
=/ result (mule |.(-:(aver:den for u.run u.luk tyl)))
?: ?=(%| -.result)
%- (slog >%clay-scry-fail< p.result)
~
p.result
::
++ read-buc
|= [=care =path]
^- (unit (unit cage))
?~ path
~
?+ i.path ~
%sweep ``[%sweep !>(sweep)]
%rang ``[%rang !>(ran.ruf)]
%tomb ``[%flag !>((tomb t.path))]
%domes domes
%tire ``[%tire !>(tore:(lu now rof *duct ruf))]
%tyre ``[%tyre !>(tyr.ruf)]
==
::
++ domes
=/ domes
%- ~(gas by *cone)
%+ turn ~(tap by dos.rom.ruf)
|= [=desk =dojo]
[[our desk] [[let hit lab] tom nor liv ren]:dom.dojo]
=. domes
%- ~(uni by domes)
%- ~(gas by *cone)
^- (list [[ship desk] foam])
%- zing
^- (list (list [[ship desk] foam]))
%+ turn ~(tap by hoy.ruf)
|= [=ship =rung]
^- (list [[^ship desk] foam])
%+ turn ~(tap by rus.rung)
|= [=desk =rede]
[[ship desk] [[let hit lab] tom nor liv ren]:dom.rede]
``[%domes !>(`cone`domes)]
::
:: True if file is accessible
::
++ tomb
|= =path
^- ?
=/ bem (de-beam path)
?~ bem %|
=/ cay scry-loop(car %y, bem u.bem)
?~ cay %|
?~ u.cay %|
=+ !<(=arch q.u.u.cay)
?~ fil.arch %|
(~(has by lat.ran.ruf) u.fil.arch)
::
:: Check for refcount errors
::
++ sweep
^- (list [need=@ud have=@ud leak])
=/ marked=(map leak [need=@ud have=@ud])
(~(run by fad.ruf) |=([refs=@ud *] [0 refs]))
=. marked
=/ items=(list [=leak *]) ~(tap by fad.ruf)
|- ^+ marked
?~ items
marked
=/ deps ~(tap in deps.leak.i.items)
|- ^+ marked
?~ deps
^$(items t.items)
=. marked
%+ ~(put by marked) i.deps
=/ gut (~(gut by marked) i.deps [0 0])
[+(-.gut) +.gut]
$(deps t.deps)
::
=/ spills=(list (set leak))
%+ welp
%+ turn ~(tap by dos.rom.ruf)
|= [* =dojo]
spill.fod.dom.dojo
%- zing
%+ turn ~(tap by hoy.ruf)
|= [* =rung]
%+ turn ~(tap by rus.rung)
|= [* =rede]
spill.fod.dom.rede
::
=. marked
|-
?~ spills
marked
=/ leaks ~(tap in i.spills)
|-
?~ leaks
^$(spills t.spills)
=. marked
%+ ~(put by marked) i.leaks
=/ gut (~(gut by marked) i.leaks [0 0])
[+(-.gut) +.gut]
$(leaks t.leaks)
::
%+ murn ~(tap by marked)
|= [=leak need=@ud have=@ud]
?: =(need have)
~
`u=[need have leak]
--
::
:: We clear the ford cache by replacing it with its bunt as a literal,
:: with its singleton type. This nests within +flow and +flue without
:: reference to +type, +hoon, or anything else in the sample of cache
:: objects. Otherwise we would be contravariant in those types, which
:: makes them harder to change.
::
++ stay
=/ flu [~ ~]
=+ `flue`flu
=/ flo ~
=+ `flow`flo
:- ver
%= ruf
fad flo
dos.rom
%- ~(run by dos.rom.ruf)
|= =dojo
dojo(fod.dom flu)
::
hoy
%- ~(run by hoy.ruf)
|= =rung
%= rung
rus
%- ~(run by rus.rung)
|= =rede
rede(fod.dom flu)
==
==
::
++ take :: accept response
~/ %clay-take
|= [tea=wire hen=duct dud=(unit goof) hin=sign]
^+ [*(list move) ..^$]
?^ dud
~|(%clay-take-dud (mean tang.u.dud))
?: ?=([%lu %load *] tea)
?> ?=(%unto +<.hin)
?> ?=(%poke-ack -.p.hin)
?~ p.p.hin
[~ ..^$]
=+ ((slog 'clay: reloading agents failed' u.p.p.hin) ~)
!!
::
?: ?=([%merge @ @ @ @ ~] tea)
?> ?=(%writ +<.hin)
=* syd i.t.tea
=/ ali-ship (slav %p i.t.t.tea)
=* ali-desk i.t.t.t.tea
=/ germ (germ i.t.t.t.t.tea)
=^ mos ruf
=/ den ((de now rof hen ruf) our syd)
abet:(merge:den ali-ship ali-desk germ p.hin)
[mos ..^$]
::
?: ?=([%fuse @ @ @ @ ~] tea)
?> ?=(%writ +<.hin)
=* syd i.t.tea
=/ ali-ship=@p (slav %p i.t.t.tea)
=* ali-desk=desk i.t.t.t.tea
=/ ali-case (rash i.t.t.t.t.tea nuck:so)
?> ?=([%$ *] ali-case)
=^ mos ruf
=/ den ((de now rof hen ruf) our syd)
abet:(take-fuse:den [ali-ship ali-desk (case +.ali-case)] p.hin)
[mos ..^$]
::
?: ?=([%park-held @ ~] tea)
?> ?=(%wake +<.hin)
=* syd i.t.tea
=^ mos ruf
=/ den ((de now rof hen ruf) our syd)
abet:(take-park-held:den error.hin)
[mos ..^$]
::
?: ?=([%wick ~] tea)
?> ?=(%wake +<.hin)
=^ mos ruf
=/ den ((de now rof hen ruf) our %base)
abet:(take-wick:den error.hin)
[mos ..^$]
::
?: ?=([%foreign-warp *] tea)
?: ?=(%wris +<.hin) ~& %dropping-wris `..^$
?> ?=(%writ +<.hin)
:_ ..^$
[hen %give %boon `(unit rand)`(bind `riot`p.hin rant-to-rand)]~
::
?: ?=([%warp-index @ @ @ ~] tea)
?+ +<.hin ~| %clay-warp-index-strange !!
%done
?~ error.hin
[~ ..^$]
:: TODO better error handling
::
~& %clay-take-warp-index-error^our^tea^tag.u.error.hin
%- (slog tang.u.error.hin)
[~ ..^$]
::
%lost
%- (slog leaf+"clay: lost warp from {<tea>}" ~)
[~ ..^$]
::
%boon
=+ ;; res=(unit rand) payload.hin
::
=/ her=ship (slav %p i.t.tea)
=/ =desk (slav %tas i.t.t.tea)
=/ index=@ud (slav %ud i.t.t.t.tea)
::
=^ mos ruf
=/ den ((de now rof hen ruf) her desk)
abet:(take-foreign-answer:den index res)
[mos ..^$]
==
::
?: ?=([%back-index @ @ @ *] tea)
?+ +<.hin ~| %clay-backfill-index-strange !!
%done
?~ error.hin
[~ ..^$]
:: TODO better error handling
::
~& %clay-take-backfill-index-error^our^tea^tag.u.error.hin
%- (slog tang.u.error.hin)
[~ ..^$]
::
%lost
%- (slog leaf+"clay: lost backfill from {<tea>}" ~)
[~ ..^$]
::
%boon
=+ ;; =fell payload.hin
::
=/ her=ship (slav %p i.t.tea)
=/ =desk (slav %tas i.t.t.tea)
=/ index=@ud (slav %ud i.t.t.t.tea)
::
=^ mos ruf
=/ den ((de now rof hen ruf) her desk)
abet:abet:(take-backfill:(foreign-update:den index) fell)
[mos ..^$]
==
::
?: ?=([%seek @ @ ~] tea)
?+ +<.hin ~| %clay-seek-strange !!
%done
?~ error.hin
[~ ..^$]
%- (slog leaf+"clay: seek nack from {<tea>}" u.error.hin)
[~ ..^$]
::
%lost
%- (slog leaf+"clay: lost boon from {<tea>}" ~)
[~ ..^$]
::
%boon
=+ ;; =fell payload.hin
::
=/ her=ship (slav %p i.t.tea)
=/ =desk (slav %tas i.t.t.tea)
=^ mos ruf
=/ den ((de now rof hen ruf) her desk)
abet:(take-fell:den fell)
[mos ..^$]
==
::
?: ?=([%sinks ~] tea)
?> ?=(%public-keys +<.hin)
?. ?=(%breach -.public-keys-result.hin)
[~ ..^$]
=/ who who.public-keys-result.hin
?: =(our who)
[~ ..^$]
:: Cancel subscriptions
::
=/ foreign-desk=(unit rung)
(~(get by hoy.ruf) who)
?~ foreign-desk
[~ ..^$]
=/ cancel-ducts=(list duct)
%- zing ^- (list (list duct))
%+ turn ~(tap by rus.u.foreign-desk)
|= [=desk =rede]
^- (list duct) %- zing ^- (list (list duct))
%+ turn ~(tap by qyx.rede)
|= [=wove ducts=(set duct)]
:: ~& [%sunk-wove desk (print-wove wove) ducts]
~(tap in ducts)
=/ cancel-moves=(list move)
%+ turn cancel-ducts
|=(=duct [duct %slip %b %drip !>([%writ ~])])
:: delete local state of foreign desk
::
=. hoy.ruf (~(del by hoy.ruf) who)
[cancel-moves ..^$]
::
?- -.+.hin
%public-keys ~|([%public-keys-raw tea] !!)
::
%mere
?: ?=(%& -.p.+.hin)
~& 'initial merge succeeded'
[~ ..^$]
~> %slog.
:^ 0 %rose [" " "[" "]"]
:^ leaf+"initial merge failed"
leaf+"my most sincere apologies"
>p.p.p.+.hin<
q.p.p.+.hin
[~ ..^$]
::
%wake
:: TODO: handle behn errors
::
?^ error.hin
[[hen %slip %d %flog %crud %wake u.error.hin]~ ..^$]
::
?. ?=([%tyme @ @ ~] tea)
~& [%clay-strange-timer tea]
[~ ..^$]
:: [wake] when requested time passes, call +wake
::
=/ her (slav %p i.t.tea)
=/ syd (slav %tas i.t.t.tea)
=^ mos ruf
=/ den ((de now rof hen ruf) her syd)
abet:wake:den
[mos ..^$]
::
:: handled in the wire dispatcher
::
%boon !!
%lost !!
%unto !!
%wris ~& %strange-wris !!
%writ
%- (slog leaf+"clay: strange writ (expected on upgrade to Fusion)" ~)
[~ ..^$]
::
%done
?~ error=error.hin
[~ ..^$]
%- (slog >%clay-lost< >tag.u.error< tang.u.error)
[~ ..^$]
==
::
++ rant-to-rand
|= rant
^- rand
[p q [p q.q]:r]
:: +whey: produce memory usage report
::
++ whey
^- (list mass)
?: (gth mas.bug.ruf 0)
=/ domestic
%+ turn (sort ~(tap by dos.rom.ruf) aor)
|= [=desk =dojo]
:+ desk %|
:~ mime+&+mim.dom.dojo
flue+&+fod.dom.dojo
dojo+&+dojo
==
:~ :+ %object-store %|
:~ commits+&+hut.ran.ruf
:+ %pages %|
%+ turn ~(tap by lat.ran.ruf)
|= [=lobe =page]
[(scot %uv lobe) %& page]
==
domestic+|+domestic
foreign+&+hoy.ruf
ford-cache+&+fad.ruf
==
=/ domestic
%+ turn (sort ~(tap by dos.rom.ruf) aor)
|= [=desk =dojo]
:+ desk %|
:~ mime+&+mim.dom.dojo
flue+&+fod.dom.dojo
dojo+&+dojo
==
:~ :+ %object-store %|
:~ commits+&+hut.ran.ruf
pages+&+lat.ran.ruf
==
domestic+|+domestic
foreign+&+hoy.ruf
ford-cache+&+fad.ruf
==
::
++ tomb
|%
:: +tomb-clue: safely remove objects
::
++ tomb-clue
|= [=duct =clue]
^- [(list move) _..^$]
?- -.clue
%lobe `(tomb-lobe lobe.clue &)
%all
=/ lobes=(list [=lobe =page]) ~(tap by lat.ran.ruf)
|-
?~ lobes
`..^^$
=. ..^^$ (tomb-lobe lobe.i.lobes &)
$(lobes t.lobes)
::
%pick pick
%norm
=^ mos ruf
=/ den ((de now rof duct ruf) ship.clue desk.clue)
abet:(set-norm:den norm.clue)
[mos ..^$]
::
%worn
=^ mos ruf
=/ den ((de now rof duct ruf) ship.clue desk.clue)
abet:(set-worn:den tako.clue norm.clue)
[mos ..^$]
::
%seek
=^ mos ruf
=/ den ((de now rof duct ruf) ship.clue desk.clue)
abet:(seek:den cash.clue)
[mos ..^$]
==
:: +tomb-lobe: remove specific lobe
::
++ tomb-lobe
|= [lob=lobe veb=?]
^+ ..^$
=/ peg=(unit page) (~(get by lat.ran.ruf) lob)
?~ peg
(noop veb leaf+"clay: file already tombstoned" ~)
::
=/ used=(unit beam)
=/ desks=(list [=desk =dojo]) ~(tap by dos.rom.ruf)
|-
=* desk-loop $
?~ desks
~
?: =(0 let.dom.dojo.i.desks)
desk-loop(desks t.desks)
=/ =yaki
%- ~(got by hut.ran.ruf)
%- ~(got by hit.dom.dojo.i.desks)
let.dom.dojo.i.desks
=/ paths=(list [=path =lobe]) ~(tap by q.yaki)
|-
=* path-loop $
?~ paths
desk-loop(desks t.desks)
?: =(lob lobe.i.paths)
`[[our desk.i.desks ud+let.dom.dojo.i.desks] path.i.paths]
path-loop(paths t.paths)
::
?^ used
(noop veb leaf+"clay: file used in {<(en-beam u.used)>}" ~)
::
=. lat.ran.ruf (~(del by lat.ran.ruf) lob)
(noop veb leaf+"clay: file successfully tombstoned" ~)
::
++ noop
|= [veb=? =tang]
?. veb
..^$
((slog tang) ..^$)
::
++ draw-raft
^- (set [norm yaki])
=/ room-yakis
=/ rooms=(list [=desk =dojo]) ~(tap by dos.rom.ruf)
|- ^- (set [norm yaki])
?~ rooms
~
(~(uni in $(rooms t.rooms)) (draw-dome %& dom.dojo.i.rooms))
=/ rung-yakis
=/ rungs=(list [=ship =rung]) ~(tap by hoy.ruf)
|- ^- (set [norm yaki])
?~ rungs
~
%- ~(uni in $(rungs t.rungs))
=/ redes=(list [=desk =rede]) ~(tap by rus.rung.i.rungs)
|- ^- (set [norm yaki])
?~ redes
~
(~(uni in $(redes t.redes)) (draw-dome %| dom.rede.i.redes))
(~(uni in room-yakis) rung-yakis)
::
++ draw-dome
|= [domestic=? =dome]
^- (set [norm yaki])
=/ =aeon 1
|- ^- (set [norm yaki])
?: (lth let.dome aeon)
~
=/ =tako (~(got by hit.dome) aeon)
=/ yakis=(set [norm yaki])
?. &(=(let.dome aeon) domestic)
~
[[*norm (~(got by hut.ran.ruf) tako)] ~ ~]
%- ~(uni in yakis)
%- ~(uni in (draw-tako tom.dome nor.dome tako))
$(aeon +(aeon))
::
++ draw-tako
|= [tom=(map tako norm) nor=norm =tako]
^- (set [norm yaki])
~+
=/ =norm (~(gut by tom) tako nor)
=/ =yaki (~(got by hut.ran.ruf) tako)
=/ takos
|- ^- (set [^norm ^yaki])
?~ p.yaki
~
(~(uni in $(p.yaki t.p.yaki)) ^$(tako i.p.yaki))
(~(put in takos) norm yaki)
::
:: +pick: copying gc based on norms
::
++ pick
=| lat=(map lobe page)
=| sen=(set [norm (map path lobe)])
|^
=. ..pick-raft pick-raft
=. lat.ran.ruf lat
`..^$
::
++ pick-raft
^+ ..pick-raft
=/ yakis=(list [=norm =yaki]) ~(tap in draw-raft)
|- ^+ ..pick-raft
?~ yakis
..pick-raft
:: ~& > [%picking [norm r.yaki]:i.yakis]
$(yakis t.yakis, ..pick-raft (pick-yaki i.yakis))
::
:: NB: recurring tree-wise with the `sen` cache provides
:: approximately a 100x speedup on a mainnet moon in 4/2022
::
++ pick-yaki
|= [=norm =yaki]
^+ ..pick-raft
|- ^+ ..pick-raft
?~ q.yaki
..pick-raft
?: (~(has in sen) norm q.yaki)
..pick-raft
=. sen (~(put in sen) norm q.yaki)
=/ peg=(unit page) (~(get by lat.ran.ruf) q.n.q.yaki)
:: ~& >> [%picking-lobe ?=(^ peg) +:(~(fit of norm) p.n.q.yaki) n.q.yaki]
=? lat &(?=(^ peg) !=([~ %|] +:(~(fit of norm) p.n.q.yaki)))
(~(uni by `(map lobe page)`[[q.n.q.yaki u.peg] ~ ~]) lat)
=. ..pick-raft $(q.yaki l.q.yaki)
$(q.yaki r.q.yaki)
--
--
--
Reference in New Issue View Git Blame Copy Permalink