ilyakooo0/urbit
1
0
Fork 0
mirror of https://github.com/ilyakooo0/urbit.git synced 2024-12-30 10:27:11 +03:00
Code Issues Packages Projects Releases Wiki Activity
3473033492
urbit/pkg/arvo/sys/vane/clay.hoon
fang 3473033492
clay: scry when doing file requests outside %sing 
In +work, we simply want to fetch file data, regardless of what the
overarching request is. (In fact, %sing would likely never hit this path
anyway.)

In order to be able to make the scry request, we track the timestamp of
the commit that contains a blob we're missing, and scry for that %da
revision.

There's two edge cases where we cannot immediately know the timestamp
that are currently assumed broken. Fix soon.
2022-02-17 15:44:16 +01:00

5158 lines
162 KiB
Plaintext
Raw Blame History

:: clay (4c), revision control
!:
:: This is split in three top-level sections: structure definitions, main
:: logic, and arvo interface.
::
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
::
:: 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 zuse.
::
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
|= our=ship
=, clay
=> |%
+$ aeon @ud :: version number
::
:: Recursive structure of a desk's data.
::
:: We keep an ankh only for the current version of local desks. Everywhere
:: else we store it as (map path lobe).
::
+$ ankh :: expanded node
$~ [~ ~]
$: fil=(unit [p=lobe q=cage]) :: file
dir=(map @ta ankh) :: folders
== ::
::
:: 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
$: ank=ankh :: state
let=aeon :: top id
hit=(map aeon tako) :: versions by id
lab=(map @tas aeon) :: labels
mim=(map path mime) :: mime cache
fod=ford-cache :: ford cache
== ::
::
:: Commit state.
::
:: -- `del` is the paths we're deleting.
:: -- `ink` is the insertions of hoon files (short-circuited for
:: bootstrapping).
:: -- `ins` is all the other insertions.
:: -- `dif` is the diffs in `dig` applied to their files.
:: -- `mut` is the diffs between `muc` and the original files.
::
+$ dork :: diff work
$: del=(list path) :: deletes
ink=(list (pair path cage)) :: hoon inserts
ins=(list (pair path cage)) :: inserts
dif=(list (trel path lobe cage)) :: changes
mut=(list (trel path lobe cage)) :: mutations
== ::
::
:: Over-the-wire backfill request
::
+$ fill
$% [%0 =desk =lobe]
==
::
:: Ford cache
::
+$ ford-cache
$: files=(map path [res=vase dez=(set [dir=? =path])])
naves=(map mark [res=vase dez=(set [dir=? =path])])
marks=(map mark [res=dais dez=(set [dir=? =path])])
casts=(map mars [res=vase dez=(set [dir=? =path])])
tubes=(map mars [res=tube dez=(set [dir=? =path])])
==
::
:: Hash of a blob, for lookup in the object store (lat.ran)
::
+$ lobe @uvI :: blob ref
::
:: 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.
::
+$ nako :: subscription state
$: gar=(map aeon tako) :: new ids
let=aeon :: next id
lar=(set yaki) :: new commits
bar=(set plop) :: 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
mon=(map term beam) :: mount points
hez=(unit duct) :: sync duct
cez=(map @ta crew) :: permission groups
pud=(unit [=desk =yoki]) :: pending update
sad=(map ship @da) :: scry known broken
== ::
::
:: Object store.
::
:: Maps of commit hashes to commits and content hashes to content.
::
+$ rang ::
$: hut=(map tako yaki) ::
lat=(map lobe blob) ::
== ::
::
:: 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
== ::
::
:: Active downloads
::
+$ update-state
$: =duct
=rave
scry=(unit @da) :: timeout timer if scry
have=(map lobe blob)
need=(list [when=@da =path =lobe])
nako=(qeu (unit nako))
busy=_|
==
::
:: Result of a subscription
::
+$ sub-result
$% [%blab =mood data=(each cage lobe)]
[%bleb ver=@ud ins=@ud range=(unit (pair aeon aeon))]
[%balk cage=(unit (each cage lobe)) =mood]
[%blas moods=(set mood)]
[%blub ~]
==
::
:: 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.
::
+$ cach (unit (unit (each cage lobe))) :: 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
==
::
+$ move [p=duct q=(wind note gift)] :: local move
+$ note :: out request $->
$~ [%b %wait *@da] ::
$% $: %$ :: to arvo
$>(%what waif) ::
== ::
$: %a :: to %ames
$>(?(%plea %keen %yawn) 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 task:dill) ::
== ::
$: %g :: to %gall
$> $? %deal
%jolt
==
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
%tune :: scry response
== ::
gift:ames ::
== ::
$: %behn ::
$% $>(%wake gift:behn) :: timer activate
$>(%writ gift) :: XX %slip
== == ::
$: %clay ::
$> $? %mere ::
%note ::
%writ ::
== ::
gift ::
== ::
$: %gall
$> $? %onto
%unto
==
gift:gall
==
$: %jael ::
$>(%public-keys gift:jael) ::
== == ::
-- =>
~% %clay-utilities ..part ~
:: %utilities
::
|%
++ scry-timeout-time ~m1
++ scry-retry-time ~h1
:: +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]
-- =>
~% %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]
[+<- +<+>-] :: cache.state
::
++ 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
!.
=> |%
+$ build
$% [%file =path]
[%mark =mark]
[%dais =mark]
[%cast =mars]
[%tube =mars]
[%vale =path]
==
+$ state
$: baked=(map path cage)
cache=ford-cache
stack=(list (set [dir=? =path]))
cycle=(set build)
==
+$ args
$: =ankh
deletes=(set path)
changes=(map path (each page lobe))
file-store=(map lobe blob)
=ford-cache
==
--
|= args
:: nub: internal mutable state for this computation
::
=| nub=state
=. cache.nub ford-cache
|%
:: +pop-stack: pop build stack, copying deps downward
::
++ pop-stack
^- [(set [dir=? =path]) _stack.nub]
=^ top=(set [dir=? =path]) stack.nub stack.nub
=? stack.nub ?=(^ stack.nub)
stack.nub(i (~(uni in i.stack.nub) top))
[top stack.nub]
:: +read-file: retrieve marked, validated file contents at path
::
++ read-file
|= =path
^- [cage state]
~| %error-validating^path
?^ got=(~(get by baked.nub) path)
[u.got nub]
=; [res=cage bun=state]
=. nub bun
=. baked.nub (~(put by baked.nub) path res)
[res nub]
?: (~(has in cycle.nub) vale+path)
~|(cycle+vale+path^stack.nub !!)
=. cycle.nub (~(put in cycle.nub) vale+path)
::~> %slog.0^leaf/"ford: read file {(spud path)}"
?^ change=(~(get by changes) path)
=^ page nub
?: ?=(%& -.u.change)
[p.u.change nub]
~| %ugly-lobe^p.u.change^path
(lobe-to-page p.u.change)
=^ cage nub (validate-page path page)
[cage nub]
?< (~(has in deletes) path)
~| %file-not-found^path
:_(nub (need (~(get an:cloy ankh) path)))
:: +build-nave: build a statically typed mark core
::
++ build-nave
|= mak=mark
^- [vase state]
~| %error-building-mark^mak
?^ got=(~(get by naves.cache.nub) mak)
=? stack.nub ?=(^ stack.nub)
stack.nub(i (~(uni in i.stack.nub) dez.u.got))
[res.u.got nub]
?: (~(has in cycle.nub) mark+mak)
~|(cycle+mark+mak^stack.nub !!)
=. cycle.nub (~(put in cycle.nub) mark+mak)
=. stack.nub [~ stack.nub]
=; res=[=vase nub=state]
=. nub nub.res
=^ top stack.nub pop-stack
=. naves.cache.nub (~(put by naves.cache.nub) mak [vase.res top])
[vase.res nub]
:: ~> %slog.0^leaf/"ford: 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)
:_ nub
^- vase :: vase of nave
%+ slap
(with-faces deg+deg tub+tub but+but cor+cor nave+!>(nave) ~)
!, *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
--
:_ nub
^- vase :: vase of nave
%+ slap (slop (with-face cor+cor) !>(..zuse))
!, *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
?^ got=(~(get by marks.cache.nub) mak)
=? stack.nub ?=(^ stack.nub)
stack.nub(i (~(uni in i.stack.nub) dez.u.got))
[res.u.got nub]
?: (~(has in cycle.nub) dais+mak)
~|(cycle+dais+mak^stack.nub !!)
=. cycle.nub (~(put in cycle.nub) dais+mak)
=. stack.nub [~ stack.nub]
=; res=[=dais nub=state]
=. nub nub.res
=^ top stack.nub pop-stack
=. marks.cache.nub (~(put by marks.cache.nub) mak [dais.res top])
[dais.res nub]
=^ nav=vase nub (build-nave mak)
:: ~> %slog.0^leaf/"ford: make dais {<mak>}"
:_ nub
^- dais
|_ 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 !>(ship.a) !>(desk.a) diff.a)
:(slop !>(ship.b) !>(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]
?: =([%mime %hoon] [a b])
:_(nub !>(|=(m=mime q.q.m)))
?^ got=(~(get by casts.cache.nub) [a b])
=? stack.nub ?=(^ stack.nub)
stack.nub(i (~(uni in i.stack.nub) dez.u.got))
[res.u.got nub]
?: (~(has in cycle.nub) cast+[a b])
~|(cycle+cast+[a b]^stack.nub !!)
=. stack.nub [~ stack.nub]
=; res=[=vase nub=state]
=. nub nub.res
=^ top stack.nub pop-stack
=. casts.cache.nub (~(put by casts.cache.nub) [a b] [vase.res top])
[vase.res nub]
:: try +grow; is there a +grow core with a .b arm?
::
:: ~> %slog.0^leaf/"ford: 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
::
:_ nub
%+ 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))
:_(nub 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)
:_(nub !>(|=(* +<)))
~|(no-cast-from+[a b] !!)
::
++ compose-casts
|= [x=mark y=mark z=mark]
^- [vase state]
=^ uno=vase nub (build-cast x y)
=^ dos=vase nub (build-cast y z)
:_ nub
%+ slap
(with-faces uno+uno dos+dos cork+!>(cork) ~)
!,(*hoon (cork uno dos))
:: +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]
?^ got=(~(get by tubes.cache.nub) [a b])
=? stack.nub ?=(^ stack.nub)
stack.nub(i (~(uni in i.stack.nub) dez.u.got))
[res.u.got nub]
?: (~(has in cycle.nub) tube+[a b])
~|(cycle+tube+[a b]^stack.nub !!)
=. stack.nub [~ stack.nub]
=; res=[=tube nub=state]
=. nub nub.res
=^ top stack.nub pop-stack
=. tubes.cache.nub (~(put by tubes.cache.nub) [a b] [tube.res top])
[tube.res nub]
=^ gat=vase nub (build-cast a b)
:: ~> %slog.0^leaf/"ford: make tube {<a>} -> {<b>}"
:_(nub |=(v=vase (slam gat v)))
::
++ lobe-to-page
|= =lobe
^- [page state]
=/ =blob (~(got by file-store) lobe)
|- ^- [page state]
?- -.blob
%direct [q.blob nub]
%delta
=/ [[=mark =parent=^lobe] diff=page] [q r]:blob
=^ parent-page nub $(blob (~(got by file-store) parent-lobe))
=^ =cage nub (run-pact parent-page diff)
[[p q.q]:cage nub]
==
::
++ 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 -:!>(*@t) q.page])
?: =(%mime p.page)
:_(nub [%mime !>(;;(mime q.page))])
=^ =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)])
=^ 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-pile pile)
res
::
++ build-dependency
|= dep=(each [dir=path fil=path] path)
^- [vase state]
=/ =path
?:(?=(%| -.dep) p.dep fil.p.dep)
~| %error-building^path
?^ got=(~(get by files.cache.nub) path)
=? stack.nub ?=(^ stack.nub)
stack.nub(i (~(uni in i.stack.nub) dez.u.got))
[res.u.got nub]
?: (~(has in cycle.nub) file+path)
~|(cycle+file+path^stack.nub !!)
=. cycle.nub (~(put in cycle.nub) file+path)
=. stack.nub
=- [(sy - ~) stack.nub]
?:(?=(%| -.dep) dep [& dir.p.dep])
:: ~> %slog.0^leaf/"ford: make file {(spud path)}"
=^ cag=cage nub (read-file path)
?> =(%hoon p.cag)
=/ tex=tape (trip !<(@t q.cag))
=/ =pile (parse-pile path tex)
=^ res=vase nub (run-pile pile)
=^ top stack.nub pop-stack
=. files.cache.nub (~(put by files.cache.nub) path [res top])
[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]
=/ fiz=(list @ta)
=/ nuk=(unit _ankh) (~(dug an:cloy ankh) path)
?~ nuk ~
%+ murn
~(tap by dir.u.nuk)
|= [nom=@ta nak=_ankh]
?. ?=([~ [~ *] *] (~(get by dir.nak) %hoon)) ~
`nom
::
=| rez=(map @ta vase)
|-
?~ fiz
[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-pile
|= =pile
=/ sut=vase !>(..zuse)
=^ 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)
=/ res=vase (road |.((slap sut hoon.pile)))
[res 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 in deletes) pux)
$(paz t.paz)
?: (~(has by changes) pux)
pux
?^ (~(get an:cloy ankh) pux)
pux
$(paz t.paz)
--
--
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
:: 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]
:: XX ruf=raft crashes in the compiler
::
=* ruf |3.+6.^$
::
=/ [mow=(list move) hun=(unit duct) rede]
?. =(our her)
:: no duct, foreign +rede or default
::
:+ ?: (~(has by hoy.ruf) her)
~
[hun.rom.ruf %pass /sinks %j %public-keys (silt her ~)]~
~
=/ 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]
:: administrative duct, domestic +rede
::
:+ ~ `hun.rom.ruf
=/ jod (~(gut by dos.rom.ruf) syd *dojo)
[lim=now ref=~ [qyx dom per pew fiz]:jod]
::
=* red=rede ->+
|%
++ 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)
==
::
:: Handle `%sing` requests
::
++ aver
|= [for=(unit ship) mun=mood]
^- [(unit (unit (each cage lobe))) ford-cache]
=+ ezy=?~(ref ~ (~(get by haw.u.ref) mun))
?^ ezy
:_(fod.dom.red `(bind u.ezy |=(a=cage [%& a])))
?: ?=([%s [%ud *] %late *] mun)
:_ fod.dom.red
^- (unit (unit (each cage lobe)))
:^ ~ ~ %&
^- 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)
?~(nao [~ fod.dom.red] (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)))
::
:: Produce either null or a result along a subscription.
::
:: Producing null means subscription has been completed or cancelled.
::
++ balk
|= [hen=duct cay=(unit (each cage lobe)) mun=mood]
^+ +>
?~ cay (blub hen)
(blab hen mun u.cay)
::
:: 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 subscription result.
::
:: Result can be either a direct result (cage) or a lobe of a result. In
:: the latter case we fetch the data at the lobe and produce that.
::
++ blab
|= [hen=duct mun=mood dat=(each cage lobe)]
^+ +>
=^ =cage fod.dom
?: ?=(%& -.dat)
[p.dat fod.dom]
=^ =page fod.dom
%- wrap:fusion
(lobe-to-page:(ford:fusion static-ford-args) p.dat)
=^ =cage fod.dom
%- wrap:fusion
(page-to-cage:(ford:fusion static-ford-args) page)
[cage fod.dom]
=/ gift [%writ ~ [care.mun case.mun syd] path.mun cage]
?: ?=(^ ref)
(emit hen %slip %b %drip !>(gift))
(emit hen %give gift)
::
++ 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
%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))
::
%tas (~(get by lab.dom) p.lok)
%ud ?:((gth p.lok let.dom) ~ [~ p.lok])
==
::
++ blas
|= [hen=duct das=(set mood)]
^+ +>
?> ?=(^ das)
:: translate the case to a date
::
=/ cas [%da (case-to-date case.n.das)]
=/ res
(~(run in `(set mood)`das) |=(m=mood [care.m path.m]))
=/ gift [%wris cas res]
?: ?=(^ ref)
(emit hen %slip %b %drip !>(gift))
(emit hen %give gift)
::
:: Give next step in a subscription.
::
++ bleb
|= [hen=duct ver=@ud ins=@ud hip=(unit (pair aeon aeon))]
^+ +>
%^ blab hen [%w [%ud ins] ~]
:- %&
?~ hip
[%null [%atom %n ~] ~]
[%nako !>((make-nako:ze ver u.hip))]
::
:: Tell subscriber that subscription is done.
::
++ blub
|= hen=duct
?: ?=(^ ref)
(emit hen %slip %b %drip !>([%writ ~]))
(emit hen %give %writ ~)
::
:: Lifts a function so that a single result can be fanned out over a set of
:: subscriber ducts.
::
:: Thus, `((duct-lift func) subs arg)` runs `(func sub arg)` for each `sub`
:: in `subs`.
::
++ duct-lift
|* send=_|=([duct *] ..duct-lift)
|= [a=(set duct) arg=_+<+.send] ^+ ..duct-lift
=+ all=~(tap by a)
|- ^+ ..duct-lift
?~ all ..duct-lift
=. +>.send ..duct-lift
$(all t.all, duct-lift (send i.all arg))
::
++ blub-all (duct-lift |=([a=duct ~] (blub a)))
++ blab-all (duct-lift blab)
++ blas-all (duct-lift blas)
++ balk-all (duct-lift balk)
++ bleb-all (duct-lift bleb)
::
++ static-ford-args [ank.dom ~ ~ lat.ran fod.dom]
::
:: 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])
::
++ send-over-scry
|= [kind=@ta =duct =ship index=@ud =desk =mood]
^- [timeout=@da _..send-over-scry]
=/ =time (add now scry-timeout-time)
=/ =wire /[kind]/(scot %p ship)/[desk]/(scot %ud index)
=/ =path
=, mood
[(cat 3 %c care) (scot %p ship) desk (scot case) path]
:- time
%- emil
:~ [hen %pass wire %a %keen path]
[hen %pass wire %b %wait time]
==
::
++ cancel-scry-timeout
|= [kind=@ta =duct =ship index=@ud =desk time=@da]
=/ =wire /[kind]/(scot %p ship)/[desk]/(scot %ud index)
(emit duct %pass wire %b %rest time)
::
++ 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)
--
::
:: 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
(run-if-future rove.wov |=(@da (bait hen +<)))
|- ^+ +>+.$
=/ =rave (rove-to-rave rove.wov)
=? rave ?=([%sing %v *] rave)
[%many %| [%ud let.dom] case.mood.rave path.mood.rave]
:: if it is a single request, and
:: :ship's remote scry isn't known to be broken,
:: or we learned it was broken more than an hour ago,
::
?: ?& ?=(%sing -.rave)
?| !(~(has by sad) her)
(lth now (add scry-retry-time (~(got by sad) her)))
== ==
:: send request as remote scry
::TODO can be deduplicated with the below?
::
=* inx nix.u.ref
=^ time=@da +>+.$
=< ?>(?=(^ ref) .)
(send-over-scry %warp-index hen her inx syd mood.rave)
%= +>+.$
nix.u.ref +(nix.u.ref)
bom.u.ref (~(put by bom.u.ref) inx [hen rave `time ~ ~ ~ |])
fod.u.ref (~(put by fod.u.ref) hen inx)
==
::
?. (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))
==
==
::
:: 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)
..park
:: 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.
::
:: XX needs to check that head is ancestor of tako
:: XX needs to check tako in rang
:: XX needs to check that commit doesn't have same date
::
++ park
=/ check-sane |
|^
|= [updated=? =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))
==
:: find desk kelvin
::
=/ kel=weft (get-kelvin yoki)
?. |(=(%base syd) =(kel [%zuse zuse]))
~>(%mean.|.(leaf/"clay: bad-kelvin, {<[need=zuse/zuse have=kel]>}") !!)
::
=/ old-yaki
?: =(0 let.dom)
*yaki
(aeon-to-yaki:ze let.dom)
=/ [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 ankh
:: promote and fill in mime cache
::
=/ invalid (~(uni in deletes) ~(key by changes))
?: &(=(%base syd) !updated (~(any in invalid) is-kernel-path))
(sys-update yoki new-data)
::
~? (did-kernel-update invalid) %clay-kernel-updated
=? updated updated (did-kernel-update invalid)
=> ?. updated .
~>(%slog.0^leaf/"clay: rebuilding {<syd>} after kernel update" .)
:: clear caches if zuse reloaded
::
=. fod.dom
?: updated *ford-cache
(promote-ford fod.dom invalid)
=? ank.dom updated *ankh
=? changes updated (changes-for-upgrade q.old-yaki deletes changes)
::
=/ =args:ford:fusion [ank.dom deletes changes lat.ran fod.dom]
::
=^ change-cages ford-cache.args (checkout-changes args changes)
=/ sane-continuation (sane-changes changes change-cages)
=/ new-blobs=(map lobe blob)
%- malt
%+ turn ~(tap by change-cages)
|= [=path =lobe =cage]
[lobe %direct 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
::
:: very important to keep all permanent changes below this point
::
?: &(=([r.old-yaki ~] p.p.yoki) =(data q.old-yaki))
..park
=/ =yaki
?- -.yoki
%& (make-yaki p.p.yoki data now)
%| ?> =(data q.p.yoki)
p.yoki
==
=: 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-blobs) lat.ran)
==
=. file-store.args lat.ran
::
=^ ankh ford-cache.args
(checkout-ankh args deletes change-cages ank.dom)
=/ null (sane-ankh sane-continuation ankh)
=. ankh.args ankh
=. ank.dom ankh
=^ mim ford-cache.args
(checkout-mime args deletes ~(key by changes))
=. mim.dom (apply-changes-to-mim mim.dom mim)
=. fod.dom ford-cache.args
=. ..park (emil (print q.old-yaki data))
wake:(ergo mim)
:: +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)
|
%- ~(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
^- weft
|^ ?- -.yoki
%|
%- lobe-to-weft
~> %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-weft p.fil)
%| (lobe-to-weft p.fil)
==
==
++ lobe-to-weft
|= =lobe
^- weft
=/ =blob (lobe-to-blob:ze lobe)
=/ =page
?- -.blob
%direct q.blob
%delta r.blob
==
(page-to-weft page)
++ page-to-weft
|= =page
^- weft
?+ p.page ~|(clay-bad-kelvin-mark/p.page !!)
%kelvin ;;(weft q.page)
%mime
=+ ;;(=mime q.page)
!<(weft (slap !>(~) (ream q.q.mime)))
==
--
::
:: 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)
::
:: Keep any parts of the ford cache whose dependencies didn't change
::
:: Make sure to invalidate any paths whose '-'s or '/'s could be
:: converted in an import; i.e. /mar, /lib, and /sur hoon files.
::
:: If anything in the kernel other than a vane updated,
:: clear the cache.
::
++ promote-ford
|= [=ford-cache invalid=(set path)]
^+ ford-cache
::
=. invalid
%- ~(gas in invalid)
%- zing
%+ turn ~(tap in invalid)
|= pax=path
^- (list path)
=/ xap=path (flop pax)
?. &(=(%hoon (head xap)) ?=([?(%mar %sur %lib) @ @ *] pax))
~
=- (turn - |=(suf=path [i.pax (snoc suf %hoon)]))
%- segments
%- crip
=/ xup (tail xap) :: lose %hoon extension
=/ pux (tail (flop xup)) :: lose static prefix
%+ turn (tail (spud pux)) :: lose leading '/'
|=(c=@tD `@tD`?:(=('/' c) '-' c)) :: convert '/' to '-'
::
:* ((invalidate path vase) files.ford-cache invalid)
((invalidate mark vase) naves.ford-cache invalid)
((invalidate mark dais) marks.ford-cache invalid)
((invalidate mars vase) casts.ford-cache invalid)
((invalidate mars tube) tubes.ford-cache invalid)
==
::
++ invalidate
|* [key=mold value=mold]
|= [cache=(map key [value dez=(set [dir=? =path])]) invalid=(set path)]
=/ builds=(list [key value dez=(set [dir=? =path])])
~(tap by cache)
|- ^+ cache
?~ builds
~
?: %- ~(any in dez.i.builds)
|= [dir=? =path]
?. dir (~(has in invalid) path)
=+ l=(lent path)
%- ~(any in invalid)
|= i=^path
&(=(path (scag l i)) ?=([@ %hoon ~] (slag l i)))
$(builds t.builds)
(~(put by $(builds t.builds)) i.builds)
::
++ page-to-cord
|= =page
^- @t
?+ p.page ~|([%sys-bad-mark p.page] !!)
%hoon ;;(@t q.page)
%mime q.q:;;(mime q.page)
==
::
++ path-to-hoon
|= [data=(map path (each page lobe)) =path]
(rain path (path-to-cord data path))
::
++ path-to-cord
|= [data=(map path (each page lobe)) =path]
^- @t
=/ datum (~(got by data) path)
?- -.datum
%& (page-to-cord p.datum)
%| (lobe-to-cord p.datum)
==
::
++ lobe-to-cord
|= =lobe
^- @t
=- ?:(?=(%& -<) p.- (of-wain:format p.-))
|- ^- (each @t wain)
=/ =blob (~(got by lat.ran) lobe)
?- -.blob
%direct [%& ;;(@t q.q.blob)]
%delta
:- %|
%+ lurk:differ
=- ?:(?=(%| -<) p.- (to-wain:format p.-))
$(lobe q.q.blob)
;;((urge cord) q.r.blob)
==
::
:: Updated q.yaki
::
++ checkout-changes
|= [=ford=args:ford:fusion changes=(map path (each page lobe))]
^- [(map path [=lobe =cage]) ford-cache]
%+ roll `(list [path (each page lobe)])`~(tap by changes)
|= $: [=path change=(each page lobe)]
[built=(map path [lobe cage]) cache=_ford-cache.ford-args]
==
^+ [built cache]
=. ford-cache.ford-args cache
=^ cage ford-cache.ford-args
:: ~> %slog.[0 leaf/"clay: validating {(spud path)}"]
%- wrap:fusion
(read-file:(ford:fusion ford-args) path)
=/ =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-cache.ford-args]
::
:: Update ankh
::
++ checkout-ankh
|= $: =ford=args:ford:fusion
deletes=(set path)
changes=(map path [lobe cage])
=ankh
==
^+ [ankh ford-cache.ford-args]
:: Delete
::
=. ankh
=/ dels ~(tap in deletes)
|- ^- ^ankh
=* outer-loop $
?~ dels
ankh
=. ankh
|- ^- ^ankh
=* inner-loop $
?~ i.dels
ankh(fil ~)
%= ankh
dir
%+ ~(put by dir.ankh) i.i.dels
%= inner-loop
i.dels t.i.dels
ankh (~(gut by dir.ankh) i.i.dels *^ankh)
==
==
outer-loop(dels t.dels)
:: Add/change
::
=/ cans=(list [=path =lobe =cage]) ~(tap by changes)
|- ^+ [ankh ford-cache.ford-args]
=* outer-loop $
?~ cans
[ankh ford-cache.ford-args]
=^ new-ankh ford-cache.ford-args
|- ^+ [ankh ford-cache.ford-args]
=* inner-loop $
?^ path.i.cans
=^ child-ankh ford-cache.ford-args
%= inner-loop
path.i.cans t.path.i.cans
ankh (~(gut by dir.ankh) i.path.i.cans *^ankh)
==
:- ankh(dir (~(put by dir.ankh) i.path.i.cans child-ankh))
ford-cache.ford-args
[ankh(fil `[lobe.i.cans cage.i.cans]) ford-cache.ford-args]
=. ankh new-ankh
outer-loop(cans t.cans)
::
:: 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
[u.hun %give %note prefix (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 blobs hash to their lobe
::
=/ foo
%- ~(urn by lat.ran)
|= [=lobe =blob]
?: ?=(%delta -.blob)
~
=/ actual-lobe=^lobe `@uv`(page-to-lobe q.blob)
~| [lobe p.blob actual-lobe]
?> &(=(lobe p.blob) =(lobe actual-lobe))
~
:: Assert we calculated the same change-cages w/o cache
::
:: XX 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 [*ankh ~ all-changes lat.ran *ford-cache]
=^ all-change-cages ford-cache.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]
::
++ sane-ankh
|= $: $= cont
(unit [all-changes=(map path [lobe cage]) =ford=args:ford:fusion])
=test=ankh
==
?. check-sane
~
:: Assert all new lobes are reachable.
::
:: Needs to run after dome is updated
::
=/ tak=(unit tako) (~(get by hit.dom) let.dom)
?~ tak
~
=/ =yaki (~(got by hut.ran) u.tak)
=/ files=(list [=path =lobe]) ~(tap by q.yaki)
|- ^+ *sane-ankh
?^ files
?. (~(has by lat.ran) lobe.i.files)
~| missing-lobe=[path lobe]
!!
$(files t.files)
::
:: Assert we can rebuild the ankh
::
?~ cont
~
=+ u.cont
=^ ankh ford-cache.ford-args
(checkout-ankh ford-args ~ all-changes *ankh)
=| =path
|- ^- ~
=* loop $
=/ fil (bind fil.ankh |=([=lobe =cage] [lobe p.cage q.q.cage]))
=/ test (bind fil.ankh |=([=lobe =cage] [lobe p.cage q.q.cage]))
?. =(fil test)
~| [%not-same-file path ?=(~ fil.ankh) ?=(~ fil.test-ankh)]
~| ?~(fil.ankh ~ [[p p.q]:u.fil.ankh `@uv`(page-to-lobe [p q.q]:q.u.fil.ankh)])
~| ?~(fil.test-ankh ~ [[p p.q]:u.fil.test-ankh `@uv`(page-to-lobe [p q.q]:q.u.fil.test-ankh)])
!!
?. =(~(key by dir.ankh) ~(key by dir.test-ankh))
~| [%not-same-children path ~(key by dir.ankh) ~(key by dir.test-ankh)]
!!
=< ~
%+ turn ~(tap by dir.ankh)
|= [=@ta =child=^ankh]
~| sane-ankh=[path ta]
%= loop
path (snoc path ta)
ankh child-ankh
test-ankh (~(got by dir.test-ankh) ta)
==
::
:: 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
?- -.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)
--
--
::
:: 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))
=/ continuation-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 | [%| continuation-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 `continuation-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)
==
%= $
continuation-yaki merged-yaki
merges t.merges
hut.ran (~(put by hut.ran) r.merged-yaki merged-yaki)
lat.rag (~(uni by lat.rag) lat.u.merge-result)
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 !<(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 blob)]
::
++ merge-helper
|= [=ali=ship =ali=desk =germ ali-dome=dome:clay continuation-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)
?~ continuation-yaki
?~ let.dom
~
(~(get by hut.ran) (~(got by hit.dom) let.dom))
continuation-yaki
(merge-by-germ ali-yaki bob-yaki)
::
++ merge-by-germ
|= [=ali=yaki bob-yaki=(unit yaki)]
^- (each (unit merge-result) [term tang])
::
:: 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)
|^
^- (each (unit merge-result) [term tang])
?- 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
leaf+"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
leaf+"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)<
leaf+"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)
~
`[path (diff-lobes lobe u.in-yak)]
::
=/ 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
^- cage
=^ =page fod.dom
%- wrap:fusion
(lobe-to-page:(ford:fusion static-ford-args) lobe)
=^ =cage fod.dom
%- wrap:fusion
(page-to-cage:(ford:fusion static-ford-args) page)
cage
::
++ get-dais
|= =mark
^- dais
=^ =dais fod.dom
%- wrap:fusion
(build-dais:(ford:fusion static-ford-args) mark)
dais
::
:: Diff two files on bob-desk
::
++ diff-lobes
|= [=a=lobe =b=lobe]
^- cage
=/ a-cage (lobe-to-cage a-lobe)
=/ b-cage (lobe-to-cage b-lobe)
?> =(p.a-cage p.b-cage)
=/ =dais (get-dais p.a-cage)
[form:dais (~(diff dais q.a-cage) q.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))
==
^- (each (unit merge-result) [term tang])
=/ 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
!!
=/ =cage (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 -]
=/ 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 blob)] :: new content
%+ roll ~(tap by both-patched)
|= [[pax=path cay=cage] hat=(map path lobe) lat=(map lobe blob)]
=/ =blob [%direct (page-to-lobe [p q.q]:cay) [p q.q]:cay]
:- (~(put by hat) pax p.blob)
?: (~(has by lat) p.blob)
lat
(~(put by lat) p.blob blob)
=/ 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)
==
::
:: Update mime cache
::
++ checkout-mime
|= $: =ford=args:ford:fusion
deletes=(set path)
changes=(set path)
==
^- [(map path (unit mime)) ford-cache]
=/ 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)) ford-cache]
?~ cans
[mim ford-cache.ford-args]
=^ cage ford-cache.ford-args
~| mime-cast-fail+i.cans
(wrap:fusion (cast-path:(ford:fusion ford-args) i.cans %mime))
=^ mim ford-cache.ford-args $(cans t.cans)
[(~(put by mim) i.cans `!<(mime q.cage)) ford-cache.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
|= mim=(map path (unit mime))
^+ ..park
=/ must (must-ergo her syd 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
|= [our=ship syd=desk 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 our) =(q.bem syd) =(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
=. mon (~(put by mon) pot [her syd case] spur)
=/ =yaki (~(got by hut.ran) (~(got by hit.dom) let.dom))
=/ changes (~(run by q.yaki) |=(=lobe |+lobe))
=/ =args:ford:fusion [ank.dom ~ changes lat.ran fod.dom]
=^ mim ford-cache.args
(checkout-mime args ~ ~(key by changes))
=. mim.dom (apply-changes-to-mim mim.dom mim)
=. fod.dom ford-cache.args
(ergo mim)
::
:: 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
%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.
::
++ forget-crew
|= nom=@ta
%= +>
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))
::
:: 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) c [a c])
::
?~ ref
=> .(ref `(unit rind)`ref) :: XX TMI
?: =(~ wos) ..cancel-request :: XX 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) :: XX TMI
=/ sat (~(got by bom.u.ref) u.nux)
=: fod.u.ref (~(del by fod.u.ref) hen)
bom.u.ref (~(del by bom.u.ref) u.nux)
==
:: cancel the request as appropriate
::
?~ scry.sat
%. [hen her u.nux [syd ~]]
send-over-ames(ref `(unit rind)`ref) :: XX TMI
=/ =path
~| [%strange-scried-request rave.sat]
?> ?=(%sing -.rave.sat)
=, mood.rave.sat
[(cat 3 %c care) (scot %p her) syd (scot case) path]
%- emil
:~ [hen %pass / %a %yawn path]
[hen %pass / %b %rest u.scry.sat]
==
::
:: 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) sub-results=(list sub-result)] fod.dom
(try-fill-sub for (rave-to-rove rav))
=. ..start-request (send-sub-results sub-results [hen ~ ~])
?~ new-sub
..start-request
(duce for u.new-sub)
::
::TODO should this try-fill-sub or w/e in case its now in our cache?
++ retry-with-ames
|= inx=@ud
^+ ..retry-with-ames
~| [%strange-retry-no-request her syd inx]
?> ?=(^ ref)
=/ sat=update-state (~(got by bom.u.ref) inx)
=. ..retry-with-ames
=< ?>(?=(^ ref) .)
(send-over-ames hen her inx syd `rave.sat)
=. bom.u.ref (~(put by bom.u.ref) inx sat(scry ~))
..retry-with-ames
::
:: 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 +>.$
=? ..take-foreign-answer ?=(^ scry.u.ruv)
=< ?>(?=(^ ref) .)
(cancel-scry-timeout %warp-index hen her inx syd u.scry.u.ruv)
=/ rav=rave rave.u.ruv
?: ?=(%many -.rav)
abet:(apex:(foreign-update inx) rut)
?~ rut
:: nothing here, so cache that
::
%_ 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)
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 hoon/zuse
::
=/ args %*(static-ford-args . dom dom:(~(got by dos.rom) %base))
(page-to-cage:(ford:fusion args) 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 blob?
::
++ give-backfill
|= =lobe
^+ ..give-backfill
(emit hen %give %boon (~(got by lat.ran) lobe))
::
:: Ingest foreign update, requesting missing blobs 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
:: if the request was done over scry, clear the timeout timer
::
=? ..foreign-update ?=(^ scry.sat)
=< ?>(?=(^ ref) .)
(cancel-scry-timeout %back-index hen her inx syd u.scry.sat)
=. scry.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)
=. need.sat (welp need.sat (missing-blobs nako))
=. nako.sat (~(put to nako.sat) ~ nako)
work
::
++ missing-blobs
|= =nako
=| miss=(set lobe)
^- (list [@da path lobe])
::REVIEW should this get sorted so that we prefer getting files
:: from the latest commit, if there are duplicates?
=/ yakis ~(tap in lar.nako)
|- ^- (list [@da path lobe])
=* yaki-loop $
?~ yakis
~
=/ lobes=(list [=path =lobe]) ~(tap by q.i.yakis)
|- ^- (list [@da path lobe])
=* blob-loop $
?~ lobes
yaki-loop(yakis t.yakis)
=* lobe lobe.i.lobes
?: ?| (~(has by lat.ran) lobe)
(~(has in miss) lobe)
==
blob-loop(lobes t.lobes)
:- [t.i.yakis i.lobes]
blob-loop(lobes t.lobes, miss (~(put in miss) lobe))
::
:: Receive backfill response
::
++ take-backfill
|= =blob
^+ ..abet
?: lost ..abet
=? need.sat
?& ?=(%delta -.blob)
!(~(has by lat.ran) q.q.blob)
!(~(has by have.sat) q.q.blob)
==
::NOTE we have already fallen back to the ames case,
:: (scry responses always come in as %direct blobs)
:: so we do not need the real path here anymore.
::REVIEW right? or is this considered too fragile?
:: actually yeah, we might retry scry later...
::TODO also wouldn't this want to check if lobe was already in need?
[[*@da / q.q.blob] need.sat]
:: We can't put a blob in lat.ran if its parent isn't already
:: there. Unions are in reverse order so we don't overwrite
:: existing blobs.
::
=. ..abet
?: &(?=(%delta -.blob) !(~(has by lat.ran) q.q.blob))
..abet(have.sat (~(uni by (malt [p.blob `^blob`blob] ~)) have.sat))
..abet(lat.ran (~(uni by (malt [p.blob blob] ~)) lat.ran))
work(busy.sat |)
::
:: Fetch next blob
::
++ work
^+ ..abet
?: busy.sat
..abet
|- ^+ ..abet
?: =(~ need.sat)
:: NB: if you change to release nakos as we get enough blobs
:: 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.
::
=. lat.ran (~(uni by have.sat) lat.ran)
|- ^+ ..abet
?: =(~ nako.sat)
..abet
=^ next=(unit nako) nako.sat ~(get to nako.sat)
?~ next
..abet(done &)
=. ..abet (apply-foreign-update u.next)
=. ..foreign-update =<(?>(?=(^ ref) .) wake)
$
?> ?=(^ need.sat)
:: This is what removes an item from `need`. This happens every
:: time we take a backfill response, but it could happen more than
:: once if we somehow got this data in the meantime (maybe from
:: another desk updating concurrently, or a previous update on this
:: same desk).
::
?: ?| (~(has by lat.ran) lobe.i.need.sat)
(~(has by have.sat) lobe.i.need.sat)
==
$(need.sat t.need.sat)
:: Otherwise, fetch the next blob
::
=^ time=(unit @da) ..foreign-update
=< ?>(?=(^ ref) .)
:: if it is a single request, and
:: :ship's remote scry isn't known to be broken,
:: or we learned it was broken more than an hour ago,
::
?: ?| !(~(has by sad) her)
(lth now (add scry-retry-time (~(got by sad) her)))
==
:: make the request over remote scry
::
=/ =mood
[%x da+when path]:i.need.sat
[`- +]:(send-over-scry %back-index hen her inx syd mood)
:: otherwise, request over ames
::
:- ~
=/ =wire /back-index/(scot %p her)/[syd]/(scot %ud inx)
=/ =path [%backfill syd (scot %ud inx) ~]
=/ =fill [%0 syd lobe.i.need.sat]
(emit hen %pass wire %a %plea her %c path fill)
..abet(busy.sat &, scry.sat time)
::
:: When we get a %w foreign update, store this in our state.
::
:: We get the commits and blobs from the nako and add them to our
:: object store, then we update the map of aeons to commits and the
:: latest aeon.
::
++ apply-foreign-update
|= =nako
^+ ..abet
:: hit: updated commit-hashes by @ud case
:: nut: new commit-hash/commit pairs
:: hut: updated commits by hash
:: nat: new blob-hash/blob pairs
:: lat: updated blobs 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)
=/ nat (turn ~(tap in bar.nako) |=(=blob [p.blob blob]))
=/ lat (~(uni by (malt nat)) lat.ran)
:: traverse updated state and sanity check
::
=+ ~| :* %bad-foreign-update
[gar=gar.nako let=let.nako nut=(turn nut head) nat=(turn nat 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)
=+ %+ turn
~(tap by q.yaki)
|= [=path =lobe]
~| [%missing-blob path lobe]
?> (~(has by lat) lobe)
~
?: =(let.nako aeon)
~
$(aeon +(aeon))
:: produce updated state
::
=/ =rave rave:(~(got by bom.u.ref) inx)
?> ?=(%many -.rave)
=: let.dom (max let.nako let.dom)
hit.dom hit
hut.ran hut
lat.ran lat
:: 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
--
::
:: fire function if request is in future
::
++ run-if-future
|= [rov=rove fun=$-(@da _.)]
^+ +>.$
%+ fall
%+ bind
^- (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)
==
fun
+>.$
::
++ 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
==
::
++ send-sub-results
|= [sub-results=(list sub-result) ducts=(set duct)]
^+ ..wake
?~ sub-results
..wake
=. ..wake
?- -.i.sub-results
%blab (blab-all ducts +.i.sub-results)
%bleb (bleb-all ducts +.i.sub-results)
%balk (balk-all ducts +.i.sub-results)
%blas (blas-all ducts +.i.sub-results)
%blub (blub-all ducts +.i.sub-results)
==
$(sub-results t.sub-results)
::
:: Loop through open subscriptions and check if we can fill any of
:: them.
::
++ wake
^+ .
=/ old-subs=(list [=wove ducts=(set duct)]) ~(tap by qyx)
=| new-subs=(list [=wove ducts=(set duct)])
|- ^+ ..wake
?~ old-subs
:: install new subs
::
..wake(qyx (~(gas by *cult) new-subs))
?: =(~ ducts.i.old-subs)
:: drop forgotten roves
::
$(old-subs t.old-subs)
=^ [new-sub=(unit rove) sub-results=(list sub-result)] fod.dom
(try-fill-sub wove.i.old-subs)
=. ..wake (send-sub-results sub-results ducts.i.old-subs)
=. new-subs
?~ new-sub
new-subs
[[[for.wove.i.old-subs u.new-sub] ducts.i.old-subs] new-subs]
$(old-subs t.old-subs)
::
:: Try to fill a subscription
::
++ try-fill-sub
|= [far=(unit [=ship ver=@ud]) rov=rove]
^- [[new-sub=(unit rove) (list sub-result)] ford-cache]
=/ 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
::
:_ fod.dom
:- ~
?~ u.cache-value
[%blub ~]~
[%blab 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 ~] fod.dom]
:: we have the appropriate aeon, so read in the data
::
=^ value=(unit (unit (each cage lobe))) fod.dom
(read-at-aeon:ze for u.aeon mood.rov)
?~ value
:: We don't have the data directly, which is potentially
:: problematical. How can we fetch the data?
::
?: =(0 u.aeon)
~& [%clay-sing-indirect-data-0 `path`[syd '0' path.mood.rov]]
[[~ ~] fod.dom]
~& [%clay-sing-indirect-data desk=syd mood=mood.rov aeon=u.aeon]
[[`rov ~] fod.dom]
:: we have the data, so we produce the results
::
[[~ [%balk u.value mood.rov]~] fod.dom]
::
:: %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)
:: we will either respond or store the maybe updated request.
::
=; [res=(each (map mood (unit (each cage lobe))) rove) fod=ford-cache]
:_ fod
?: ?=(%& -.res)
(respond p.res)
(store p.res)
:: recurse here on next aeon if possible/needed.
::
|- ^- [(each (map mood (unit (each cage lobe))) rove) ford-cache]
:: 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 [|+rov fod.dom]
:: 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 fod.dom
?: (complete old-cach.rov)
[old-cach.rov fod.dom]
(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 [|+rov fod.dom]
:: if new isn't complete, try filling in the gaps.
::
=^ n fod.dom
?: (complete new-cach.rov)
[new-cach.rov fod.dom]
(read-unknown mool.rov(case [%ud u.aeon.rov]) new-cach.rov)
=. new-cach.rov n
?: ?& !(complete old-cach.rov)
(complete new-cach.rov)
==
:_ fod.dom :- %&
%- malt
%+ murn ~(tap in paths.mool.rov)
|= [=care =path]
^- (unit [mood (unit (each cage lobe))])
=/ 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]
:: if they're still not both complete, wait again.
::
?. ?& (complete old-cach.rov)
(complete new-cach.rov)
==
[|+rov fod.dom]
:: both complete, so check if anything has changed
::
=/ changes=(map mood (unit (each cage lobe)))
%+ roll ~(tap by old-cach.rov)
|= $: [[car=care pax=path] old-cach-value=cach]
changes=(map mood (unit (each cage lobe)))
==
=/ new-cach-value=cach (~(got by new-cach.rov) car pax)
?< |(?=(~ old-cach-value) ?=(~ new-cach-value))
=/ new-entry=(unit (pair mood (unit (each cage lobe))))
=/ =mood [car [%ud u.aeon.rov] pax]
?~ u.new-cach-value
:: if new does not exist, always notify
::
`[mood ~]
?~ u.old-cach-value
:: added
::
`[mood `u.u.new-cach-value]
?: (equivalent-data:ze u.u.new-cach-value u.u.old-cach-value)
:: unchanged
::
~
:: changed
::
`[mood `u.u.new-cach-value]
:: 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 [&+changes fod.dom]
$(u.aeon.rov +(u.aeon.rov), new-cach.rov ~)
::
:: check again later
::
++ store
|= rov=rove
^- [new-sub=(unit rove) (list sub-result)]
=/ 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 (each cage lobe)))
^- [new-sub=(unit rove) (list sub-result)]
:- ~
?: ?=(%mult -.vor)
[%blas ~(key by res)]~
?> ?=([* ~ ~] res)
?~ q.n.res
[%blub ~]~
[%blab [p u.q]:n.res]~
::
:: no unknowns
::
++ complete
|= hav=(map (pair care path) cach)
?& ?=(^ hav)
(levy ~(tap by `(map (pair care path) cach)`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 ford-cache]
=? hav ?=(~ hav)
%- malt ^- (list (pair (pair care path) cach))
%+ turn
~(tap in paths.mool)
|= [c=care p=path]
^- [[care path] cach]
[[c p] ~]
|- ^+ [hav fod.dom]
?~ hav [hav fod.dom]
=^ lef fod.dom $(hav l.hav)
=. l.hav lef
=^ rig fod.dom $(hav r.hav)
=. r.hav rig
=/ [[=care =path] =cach] n.hav
?^ cach
[hav fod.dom]
=^ q fod.dom (aver for care case.mool path)
=. q.n.hav q
[hav fod.dom]
--
::
%many
:_ fod.dom
=/ 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)
=/ ver ?~(far %1 ver.u.far)
?~ to-aeon
:: we're in the middle of the range, so produce what we can,
:: but don't end the subscription
::
:: update "from" case to the aeon after now
::
=. from.moat.rov
[%ud +(let.dom)]
:- `rov
=/ new-lobes=(map path lobe)
(lobes-at-path:ze for let.dom path.moat.rov)
?: =(lobes.rov new-lobes)
:: if no changes, don't produce results
::
~
:: else changes, so produce them
::
[%bleb ver let.dom ?:(track.rov ~ `[u.from-aeon let.dom])]~
:: we're past the end of the range, so end subscription
::
:- ~
=/ new-lobes=(map path lobe)
(lobes-at-path:ze for u.to-aeon path.moat.rov)
:: if changed, give subscription result
::
=/ bleb=(list sub-result)
?: =(lobes.rov new-lobes)
~
[%bleb ver +(u.from-aeon) ?:(track.rov ~ `[u.from-aeon u.to-aeon])]~
:: end subscription
::
=/ blub=(list sub-result)
[%blub ~]~
(weld bleb blub)
==
::
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
::
:: 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:
::
:: -- `ank` is the ankh, which is the file data itself. An ankh is both
:: a possible file and a possible directory. An ankh has both:
:: -- `fil`, a possible file, stored as both a cage and its hash
:: -- `dir`, a map of @ta to more ankhs.
:: -- `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), yaki
:: (commit data structure), lobe (content hash), and blob (content).
::
:: XX the following are duplicated from the +state core
::
++ aeon-to-tako ~(got by hit.dom)
++ aeon-to-yaki |=(=aeon (tako-to-yaki (aeon-to-tako aeon)))
++ lobe-to-blob ~(got by lat.ran)
++ tako-to-yaki ~(got by hut.ran)
++ lobe-to-mark
|= a=lobe
=> (lobe-to-blob a)
?- -
%delta p.q
%direct p.q
==
::
:: Checks whether two pieces of data (either cages or lobes) are the same.
::
++ equivalent-data
|= [one=(each cage lobe) two=(each cage lobe)]
^- ?
?: ?=(%& -.one)
?: ?=(%& -.two)
=([p q.q]:p.one [p q.q]:p.two)
=(p.two (page-to-lobe [p q.q]:p.one))
?: ?=(%& -.two)
=(p.one (page-to-lobe [p q.q]:p.two))
=(p.one p.two)
::
:: Gets a map of the data at the given path and all children of it.
::
++ lobes-at-path
|= [for=(unit ship) yon=aeon pax=path]
^- (map path lobe)
?: =(0 yon) ~
:: we use %z for the check because it looks at all child paths.
?. |(?=(~ for) (may-read u.for %z yon pax)) ~
%- malt
%+ skim
%~ tap by
=< q
%- aeon-to-yaki
yon
|= [p=path q=lobe]
?| ?=(~ pax)
?& !?=(~ p)
=(-.pax -.p)
$(p +.p, pax +.pax)
== ==
::
:: 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)
::
:: Get all the lobes that are referenced in `a` except those that are
:: already in `b`.
::
++ new-lobes :: object hash set
|= [b=(set lobe) a=(set tako)] :: that aren't in b
^- (set lobe)
%+ roll ~(tap in a)
|= [tak=tako bar=(set lobe)]
^- (set lobe)
=+ yak=(tako-to-yaki tak)
%+ roll ~(tap by q.yak)
=< .(far bar)
|= [[path lob=lobe] far=(set lobe)]
^- (set lobe)
?~ (~(has in b) lob) :: don't need
far
=+ gar=(lobe-to-blob lob)
?- -.gar
%direct (~(put in far) lob)
%delta (~(put in $(lob q.q.gar)) lob)
==
::
:: Probably can get rid of the cache checks because they happen in
:: ford
::
++ read-a
!.
|= [=aeon =path]
^- [(unit (unit (each cage lobe))) ford-cache]
?. =(aeon let.dom)
~> %slog.0^leaf/"clay: %a unknown aeon {<[syd aeon path]>}"
[~ fod.dom]
=/ cached=(unit [=vase *]) (~(get by files.fod.dom) path)
?^ cached
:_(fod.dom [~ ~ %& %vase !>(vase.u.cached)])
=/ x (read-x aeon path)
?~ x
~> %slog.0^leaf/"clay: %a can't read file at path {<[syd aeon path]>}"
[~ fod.dom]
?~ u.x
~> %slog.0^leaf/"clay: %a no file at path {<[syd aeon path]>}"
[[~ ~] fod.dom]
:: should never happen at current aeon
?: ?=(%| -.u.u.x)
[~ fod.dom]
=^ =vase fod.dom
~_ leaf/"clay: %a build failed {<[syd aeon path]>}"
%- wrap:fusion
(build-file:(ford:fusion static-ford-args) path)
:_(fod.dom [~ ~ %& %vase !>(vase)])
::
++ read-b
!.
|= [=aeon =path]
^- [(unit (unit (each cage lobe))) ford-cache]
?. =(aeon let.dom)
[~ fod.dom]
?. ?=([@ ~] path)
[[~ ~] fod.dom]
=/ cached=(unit [=dais *]) (~(get by marks.fod.dom) i.path)
?^ cached
:_(fod.dom [~ ~ %& %dais !>(dais.u.cached)])
=^ =dais fod.dom
%- wrap:fusion
(build-dais:(ford:fusion static-ford-args) i.path)
:_(fod.dom [~ ~ %& %dais !>(dais)])
::
++ read-c
!.
|= [=aeon =path]
^- [(unit (unit (each cage lobe))) ford-cache]
?. =(aeon let.dom)
[~ fod.dom]
?. ?=([@ @ ~] path)
[[~ ~] fod.dom]
=/ cached=(unit [=tube *]) (~(get by tubes.fod.dom) [i i.t]:path)
?^ cached
:_(fod.dom [~ ~ %& %tube !>(tube.u.cached)])
=^ =tube fod.dom
%- wrap:fusion
(build-tube:(ford:fusion static-ford-args) [i i.t]:path)
:_(fod.dom [~ ~ %& %tube !>(tube)])
::
++ read-e
!.
|= [=aeon =path]
^- [(unit (unit (each cage lobe))) ford-cache]
?. =(aeon let.dom)
[~ fod.dom]
?. ?=([@ ~] path)
[[~ ~] fod.dom]
=/ cached=(unit [=vase *]) (~(get by naves.fod.dom) i.path)
?^ cached
:_(fod.dom [~ ~ %& %nave vase.u.cached])
=^ =vase fod.dom
%- wrap:fusion
(build-nave:(ford:fusion static-ford-args) i.path)
:_(fod.dom [~ ~ %& %nave vase])
::
++ read-f
!.
|= [=aeon =path]
^- [(unit (unit (each cage lobe))) ford-cache]
?. =(aeon let.dom)
[~ fod.dom]
?. ?=([@ @ ~] path)
[[~ ~] fod.dom]
=/ cached=(unit [=vase *]) (~(get by casts.fod.dom) [i i.t]:path)
?^ cached
:_(fod.dom [~ ~ %& %cast vase.u.cached])
=^ =vase fod.dom
%- wrap:fusion
(build-cast:(ford:fusion static-ford-args) [i i.t]:path)
:_(fod.dom [~ ~ %& %cast vase])
::
:: 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 (each cage lobe)))
=- [~ ~ %& %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))
=/ x (read-x yon pax)
?~ x ~
?~ u.x [~ ~]
?> ?=(%& -.u.u.x)
``[p.p.u.u.x !>(q.p.u.u.x)]
:: +read-s: produce yaki or blob for given tako or lobe
::
++ read-s
|= [yon=aeon pax=path]
^- (unit (unit cage))
?. ?=([?(%yaki %blob %hash %cage %open %late %base) * *] pax)
`~
?- i.pax
%yaki
=/ yak=(unit yaki) (~(get by hut.ran) (slav %uv i.t.pax))
?~ yak
~
``yaki+[-:!>(*yaki) u.yak]
::
%blob
=/ bol=(unit blob) (~(get by lat.ran) (slav %uv i.t.pax))
?~ bol
~
``blob+[-:!>(*blob) u.bol]
::
%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)
=^ =page fod.dom
%- wrap:fusion
(lobe-to-page:(ford:fusion static-ford-args) lobe)
=^ =cage fod.dom
%- wrap:fusion
(page-to-cage:(ford:fusion static-ford-args) page)
``cage+[-:!>(*^cage) cage]
::
%open
``open+!>(prelude:(ford:fusion static-ford-args))
::
%late !! :: handled in +aver
%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 (each [%flag (hypo ?)] lobe)))
:: 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.
::
:: For past aeons, we don't give an actual ankh in the dome, but the rest
:: of the data is legit. We also never send the mime cache over the wire.
::
++ read-v
|= [yon=aeon pax=path]
^- (unit (unit [%dome (hypo dome:clay)]))
?: (lth yon let.dom)
:* ~ ~ %dome -:!>(*dome:clay)
^- dome:clay
:* ank=`[[%ank-in-old-v-not-implemented *ankh] ~ ~]
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) [ank 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
|= cas=case
^- (unit (unit (each cage lobe)))
=+ aey=(case-to-aeon cas)
?~ aey ~
=- [~ ~ %& %cass !>(-)]
^- cass
:- u.aey
?: =(0 u.aey) `@da`0
t:(aeon-to-yaki u.aey)
::
:: Get the data at a node.
::
:: If it's in our ankh (current state cache), we can just produce
:: the result. Otherwise, we've got to look up the node at the
:: aeon to get the content hash, use that to find the blob, and use
:: the blob to get the data. We also special-case the hoon mark
:: for bootstrapping purposes.
::
++ read-x
|= [yon=aeon pax=path]
^- (unit (unit (each cage lobe)))
?: =(0 yon)
[~ ~]
=+ tak=(~(get by hit.dom) yon)
?~ tak
~
?: &(?=(~ ref) =(yon let.dom))
:- ~
%+ bind
fil.ank:(descend-path:(zu ank.dom) pax)
|=(a=[p=lobe q=cage] [%& q.a])
=+ yak=(tako-to-yaki u.tak)
=+ lob=(~(get by q.yak) pax)
?~ lob
[~ ~]
=+ mar=(lobe-to-mark u.lob)
:: should convert any lobe to cage
::
?. ?=(%hoon mar)
[~ ~ %| u.lob]
:^ ~ ~ %&
:+ mar [%atom %t ~]
|- ^- @t :: (urge cord) would be faster
=+ bol=(lobe-to-blob u.lob)
?: ?=(%direct -.bol)
;;(@t q.q.bol)
?> ?=(%delta -.bol)
=+ txt=$(u.lob q.q.bol)
?> ?=(%txt-diff p.r.bol)
=+ dif=;;((urge cord) q.r.bol)
=, format
=+ pac=(of-wain (lurk:differ (to-wain (cat 3 txt '\0a')) dif))
?~ pac
''
(end [3 (dec (met 3 pac))] pac)
::
:: 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 -:!>(*@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 (each cage lobe)],
:: 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 (each cage lobe))) ford-cache]
=* fod fod.dom
?. |(?=(~ for) (may-read u.for care.mun yon path.mun))
[~ fod]
:: virtualize to catch and produce deterministic failures
::
!:
=- ?: ?=(%& -<) p.-
%. [[~ ~] fod]
(slog leaf+"clay: read-at-aeon fail {<[desk=syd mun]>}" p.-)
%- mule |.
?- care.mun
%d
:_ fod
:: XX this should only allow reads at the current date
::
?: !=(our her)
[~ ~]
?^ path.mun
~&(%no-cd-path [~ ~])
[~ ~ %& %noun !>(~(key by dos.rom.ruf))]
::
%a (read-a yon path.mun)
%b (read-b yon path.mun)
%c (read-c yon path.mun)
%e (read-e yon path.mun)
%f (read-f yon path.mun)
%p :_(fod (read-p path.mun))
%r :_(fod (bind (read-r yon path.mun) (lift |=(a=cage [%& a]))))
%s :_(fod (bind (read-s yon path.mun) (lift |=(a=cage [%& a]))))
%t :_(fod (bind (read-t yon path.mun) (lift |=(a=cage [%& a]))))
%u :_(fod (read-u yon path.mun))
%v :_(fod (bind (read-v yon path.mun) (lift |=(a=cage [%& a]))))
%w :_(fod (read-w case.mun))
%x :_(fod (read-x yon path.mun))
%y :_(fod (bind (read-y yon path.mun) (lift |=(a=cage [%& a]))))
%z :_(fod (bind (read-z yon path.mun) (lift |=(a=cage [%& a]))))
==
:: Traverse an ankh.
::
++ zu :: filesystem
|= ank=ankh :: filesystem state
=| ram=path :: reverse path into
|%
++ descend :: descend
|= lol=@ta
^+ +>
=+ you=(~(get by dir.ank) lol)
+>.$(ram [lol ram], ank ?~(you [~ ~] u.you))
::
++ descend-path :: descend recursively
|= way=path
^+ +>
?~(way +> $(way t.way, +> (descend i.way)))
--
--
--
--
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
:: 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=%11 :: 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)
::
:: XX 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
?: ?=(^ 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) des.req)
~& [%not-mounted des.req]
[~ ..^$]
[~[[u.hez.ruf %give %dirk des.req]] ..^$]
::
%ogre
?~ hez.ruf
~& %no-sync-duct
[~ ..^$]
=* pot pot.req
?@ pot
?. (~(has by mon.ruf) pot)
~& [%not-mounted pot]
[~ ..^$]
:_ ..^$(mon.ruf (~(del by mon.ruf) pot))
[u.hez.ruf %give %ogre pot]~
:_ %_ ..^$
mon.ruf
%- molt
%+ skip ~(tap by mon.ruf)
(corl (cury test pot) tail)
==
%+ turn
(skim ~(tap by mon.ruf) (corl (cury test pot) tail))
|= [pon=term bem=beam]
[u.hez.ruf %give %ogre pon]
::
%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 ..^$]
::
%perm
=^ mos ruf
=/ den ((de now rof hen ruf) our des.req)
abet:(perm:den pax.req rit.req)
[mos ..^$]
::
%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 ..^$]
::
%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 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
$% [%11 raft-11]
[%10 raft-10]
[%9 raft-9]
[%8 raft-8]
[%7 raft-7]
[%6 raft-6]
==
+$ raft-11 raft
+$ raft-10
$: rom=room
hoy=(map ship rung-10)
ran=rang
mon=(map term beam)
hez=(unit duct)
cez=(map @ta crew)
pud=(unit [=desk =yoki])
dist-upgraded=_|
==
+$ rung-10
$: rus=(map desk rede-10)
==
+$ rede-10
$: lim=@da
ref=(unit rind-10)
qyx=cult
dom=dome
per=regs
pew=regs
fiz=melt
==
+$ 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)
need=(list lobe)
nako=(qeu (unit nako))
busy=_|
==
+$ raft-9
$: rom=room :: domestic
hoy=(map ship rung-10) :: foreign
ran=rang :: hashes
mon=(map term beam) :: mount points
hez=(unit duct) :: sync duct
cez=(map @ta crew) :: permission groups
pud=(unit [=desk =yoki]) :: pending update
== ::
+$ raft-8
$: rom=room-8
hoy=(map ship rung-8)
ran=rang
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
dom=dome-8
per=regs
pew=regs
fiz=melt
==
+$ dome-8
$: ank=ankh
let=aeon
hit=(map aeon tako)
lab=(map @tas aeon)
mim=(map path mime)
fod=ford-cache
fer=* :: reef cache, obsolete
==
+$ rede-8
$: lim=@da
ref=(unit rind-10)
qyx=cult
dom=dome-8
per=regs
pew=regs
fiz=melt
==
+$ raft-7
$: rom=room-7
hoy=(map ship rung-7)
ran=rang
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
dom=dome-8
per=regs
pew=regs
==
+$ rede-7
$: lim=@da
ref=(unit rind-10)
qyx=cult
dom=dome-8
per=regs
pew=regs
==
+$ ford-cache-7 ford-cache
+$ raft-6
$: rom=room-6 :: domestic
hoy=(map ship rung-6) :: foreign
ran=rang :: hashes
mon=(map term beam) :: mount points
hez=(unit duct) :: sync duct
cez=(map @ta crew) :: permission groups
pud=(unit [=desk =yoki]) :: pending update
== ::
+$ room-6 [hun=duct dos=(map desk dojo-6)]
+$ dojo-6
$: qyx=cult :: subscribers
dom=dome-6 :: desk state
per=regs :: read perms per path
pew=regs :: write perms per path
==
+$ dome-6
$: ank=ankh :: state
let=aeon :: top id
hit=(map aeon tako) :: versions by id
lab=(map @tas aeon) :: labels
mim=(map path mime) :: mime cache
fod=ford-cache-6 :: ford cache
fer=* :: reef cache
==
+$ rung-6
$: rus=(map desk rede-6)
==
+$ rede-6
$: lim=@da
ref=(unit rind-10)
qyx=cult
dom=dome-6
per=regs
pew=regs
==
+$ ford-cache-6 * :: discard old cache
--
|= 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)
?> ?=(%11 -.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 *ford-cache-7)
::
hoy
%- ~(run by hoy.raf)
|= =rung-6
%- ~(run by rus.rung-6)
|= =rede-6
rede-6(dom dom.rede-6(fod *ford-cache-7))
==
:: +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]
::
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]
==
:: +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
=/ dom dom.dojo-8
dojo-8(dom [ank.dom let.dom hit.dom lab.dom mim.dom *ford-cache])
::
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 *ford-cache])
==
:: +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: remove dist flag, add scry availability tracker
::
++ raft-10-to-11
|= raf=raft-10
^- raft-11
=- raf(hoy -, dist-upgraded ~)
%- ~(run by hoy.raf)
|= =rung-10
%- ~(run by rus.rung-10)
|= =rede-10
^- rede
=- rede-10(ref -)
?~ ref.rede-10 ~
=- ref.rede-10(bom.u -)
%- ~(run by bom.u.ref.rede-10)
|= update-state-10
^- update-state
::NOTE putting / paths is fine, the path is only used
:: when dealing with scry responses
::TODO but that isn't actually true, is it? we might fall back to
:: scry in the middle, right?
[duct rave ~ have (turn need (corl (lead *@da) (lead /))) nako busy]
--
::
++ scry :: inspect
~/ %clay-scry
^- roon
|= [lyc=gang car=term bem=beam]
^- (unit (unit cage))
=* ren car
=/ why=shop &/p.bem
=* syd q.bem
=/ lot=coin $/r.bem
=* tyl s.bem
::
?. ?=(%& -.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))
=/ 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 ~
?~ u.p.result [~ ~]
:: should convert %| case to cage
::
?: ?=(%& -.u.u.p.result) ``p.u.u.p.result
~
::
:: We clear the ford cache by replacing it with its bunt as a literal.
:: This nests within +ford-cache without reference to +type, +hoon, or
:: anything else in the sample of cache objects. Otherwise we would be
:: contravariant in the those types, which makes them harder to change.
::
++ stay
:- ver
%= ruf
dos.rom
%- ~(run by dos.rom.ruf)
|= =dojo
dojo(fod.dom [~ ~ ~ ~ ~])
::
hoy
%- ~(run by hoy.ruf)
|= =rung
%= rung
rus
%- ~(run by rus.rung)
|= =rede
rede(fod.dom [~ ~ ~ ~ ~])
==
==
::
++ take :: accept response
~/ %clay-take
|= [tea=wire hen=duct dud=(unit goof) hin=sign]
^+ [*(list move) ..^$]
?^ dud
~|(%clay-take-dud (mean tang.u.dud))
?: ?=([%dist *] tea)
?: ?=(%onto +<.hin)
[~ ..^$]
?> ?=(%unto +<.hin)
?> ?=(%poke-ack -.p.hin)
?~ p.p.hin
[~ ..^$]
=+ ((slog 'clay: dist migration 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 i.t.tea)
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 i.t.tea)
abet:(take-fuse:den [ali-ship ali-desk (case +.ali-case)] p.hin)
[mos ..^$]
::
?: ?=([%foreign-warp *] tea)
?> ?=(%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
~| %clay-take-lost^our
:: TODO better error handling
!!
::
?(%boon %tune)
=/ 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
=; res=(unit rand)
=/ den ((de now rof hen ruf) her desk)
abet:(take-foreign-answer:den index res)
?: ?=(%boon +<.hin) ;;((unit rand) payload.hin)
%+ bind data.hin
|= =(cask)
^- rand
::REVIEW this feels a bit dumb, but the alternative
:: is reconstructing it from ref:den instead,
:: which is also weird in its own ways.
=+ (need (de-omen path.hin))
=/ =care ;;(care ?@(vis (rsh 3 vis) car.vis))
[[care r.bem q.bem] s.bem cask]
[mos ..^$]
::
%wake
=/ her=ship (slav %p i.t.tea)
=/ =desk (slav %tas i.t.t.tea)
=/ index=@ud (slav %ud i.t.t.t.tea)
~& [%clay %scry-broken her]
=^ mos ruf
=. sad.ruf (~(put by sad.ruf) her now)
=/ den ((de now rof hen ruf) her desk)
abet:(retry-with-ames:den index)
[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
~| %clay-take-backfill-lost^our
:: TODO better error handling
!!
::
?(%boon %tune)
=/ her=ship (slav %p i.t.tea)
=/ =desk (slav %tas i.t.t.tea)
=/ index=@ud (slav %ud i.t.t.t.tea)
::
=/ =blob
?: ?=(%boon +<.hin) ;;(blob payload.hin)
?~ data.hin ~|(%now-what !!) ::TODO
[%direct (page-to-lobe u.data.hin) u.data.hin]
::
=^ mos ruf
=/ den ((de now rof hen ruf) her desk)
abet:abet:(take-backfill:(foreign-update:den index) blob)
[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
[~ ..^$]
::
%note [[hen %give +.hin]~ ..^$]
%wake
:: TODO: handle behn errors
::
?^ error.hin
[[hen %slip %d %flog %crud %wake u.error.hin]~ ..^$]
::
?. ?=([%tyme @ @ ~] tea)
~& [%clay-strange-timer tea]
[~ ..^$]
=/ 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 !!
%tune !!
%lost !!
%onto !!
%unto !!
%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)
=/ domestic
%+ turn (sort ~(tap by dos.rom.ruf) aor)
|= [=desk =dojo]
:+ desk %|
:~ ankh+&+ank.dom.dojo
mime+&+mim.dom.dojo
ford-files+&+files.fod.dom.dojo
ford-naves+&+naves.fod.dom.dojo
ford-marks+&+marks.fod.dom.dojo
ford-casts+&+casts.fod.dom.dojo
ford-tubes+&+tubes.fod.dom.dojo
==
:~ domestic+|+domestic
foreign+&+hoy.ruf
:+ %object-store %|
:~ commits+&+hut.ran.ruf
blobs+&+lat.ran.ruf
==
==
--
Reference in New Issue View Git Blame Copy Permalink