unisonweb/unison
1
0
Fork 0
mirror of https://github.com/unisonweb/unison.git synced 2024-09-17 13:27:30 +03:00
Code Issues Projects Releases Wiki Activity

Add a builtin for validating code hashes before loading.

Browse Source
This commit is contained in:
Dan Doel 2023-08-10 15:48:28 -04:00
parent db4619afc2
commit 8306ff82a3
15 changed files with 1339 additions and 1236 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
parser-typechecker/src/Unison/Builtin.hs
View File

@ -906,6 +906,9 @@ codeBuiltins =
("Code.validate", list (tuple [termLink, code]) --> io (optionalt failure)),
("Code.lookup", termLink --> io (optionalt code)),
("Code.display", text --> code --> text),
( "Code.validateLinks",
list (tuple [termLink, code])
--> Type.effect () [DD.exceptionType ()] (list termLink)),
("Value.dependencies", value --> list termLink),
("Value.serialize", value --> bytes),
("Value.deserialize", bytes --> eithert text value),

35
parser-typechecker/src/Unison/Runtime/ANF/Rehash.hs
View File

@ -2,19 +2,33 @@
module Unison.Runtime.ANF.Rehash where
import Crypto.Hash
import Data.Bifunctor (bimap, second)
import Data.Bifunctor (bimap, first, second)
import Data.ByteArray (convert)
import Data.ByteString (cons)
import Data.ByteString.Lazy (toChunks)
import Data.Graph as Gr
import Data.List (foldl')
import Data.List (foldl', nub)
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.Text (Text)
import Unison.Hash (fromByteString)
import Unison.Reference as Reference
import Unison.Referent as Referent
import Unison.Runtime.ANF as ANF
import Unison.Runtime.ANF.Serialize as ANF
import Unison.Var (Var)
checkGroupHashes ::
Var v =>
[(Referent, SuperGroup v)] ->
Either (Text, [Referent]) (Either [Referent] [Referent])
checkGroupHashes rgs = case checkMissing rgs of
Left err -> Left err
Right []
| (rrs, _) <- rehashGroups . Map.fromList $ first toReference <$> rgs ->
Right . Right . fmap (Ref . fst) . filter (uncurry (/=)) $ Map.toList rrs
Right ms -> Right (Left $ Ref <$> ms)
rehashGroups ::
Var v =>
Map.Map Reference (SuperGroup v) ->
@ -33,6 +47,23 @@ rehashGroups m = foldl step (Map.empty, Map.empty) sccs
scc = second (overGroupLinks rp) <$> scc0
(rm, sgs) = rehashSCC scc
checkMissing ::
Var v =>
[(Referent, SuperGroup v)] ->
Either (Text, [Referent]) [Reference]
checkMissing (unzip -> (rs, gs)) = do
is <- fmap Set.fromList . traverse f $ rs
pure . nub . foldMap (filter (p is) . groupTermLinks) $ gs
where
f (Ref (DerivedId i)) = pure i
f r@Ref{} =
Left ("loaded code cannot be associated to a builtin link", [r])
f r =
Left ("loaded code cannot be associated to a constructor", [r])
p s (DerivedId i) =
any (\j -> idToHash i == idToHash j) s && not (Set.member i s)
p _ _ = False
rehashSCC
:: Var v

38
parser-typechecker/src/Unison/Runtime/Builtin.hs
View File

@ -140,9 +140,10 @@ import Unison.Builtin qualified as Ty (builtinTypes)
import Unison.Builtin.Decls qualified as Ty
import Unison.Prelude hiding (Text, some)
import Unison.Reference
import Unison.Referent (pattern Ref)
import Unison.Referent (Referent, pattern Ref)
import Unison.Runtime.ANF as ANF
import Unison.Runtime.ANF.Serialize as ANF
import Unison.Runtime.ANF.Rehash (checkGroupHashes)
import Unison.Runtime.Array qualified as PA
import Unison.Runtime.Exception (die)
import Unison.Runtime.Foreign
@ -1435,7 +1436,6 @@ outIoExnNat stack1 stack2 stack3 any fail result =
$ TCon Ty.natRef 0 [stack1]
)
]
outIoExnUnit ::
forall v. (Var v) => v -> v -> v -> v -> v -> v -> ANormal v
outIoExnUnit stack1 stack2 stack3 any fail result =
@ -1454,6 +1454,24 @@ outIoExnBox stack1 stack2 stack3 any fail result =
(1, ([BX], TAbs stack1 $ TVar stack1))
]
outIoExnEBoxBox ::
(Var v) => v -> v -> v -> v -> v -> v -> v -> v -> ANormal v
outIoExnEBoxBox stack1 stack2 stack3 any fail t0 t1 res =
TMatch t0 . MatchSum $
mapFromList
[ exnCase stack1 stack2 stack3 any fail,
( 1,
([UN],)
. TAbs t1
. TMatch t1 . MatchSum $
mapFromList
[ (0, ([BX], TAbs res $ left res)),
(1, ([BX], TAbs res $ right res))
]
)
]
outIoFailBox :: forall v. (Var v) => v -> v -> v -> v -> v -> v -> ANormal v
outIoFailBox stack1 stack2 stack3 any fail result =
TMatch result . MatchSum $
@ -1908,6 +1926,16 @@ boxNatBoxNatNatToExnUnit instr =
where
(a0, a1, a2, a3, a4, ua1, ua3, ua4, result, stack1, stack2, stack3, any, fail) = fresh
-- a ->{Exception} Either b c
boxToExnEBoxBox :: ForeignOp
boxToExnEBoxBox instr =
([BX],)
. TAbs a
. TLetD t0 UN (TFOp instr [a])
$ outIoExnEBoxBox stack1 stack2 stack3 any fail t0 t1 result
where
(a, stack1, stack2, stack3, any, fail, t0, t1, result) = fresh
-- Nat -> Either Failure b
-- natToEFBox :: ForeignOp
-- natToEFBox = inNat arg nat result $ outIoFail stack1 stack2 fail result
@ -2660,6 +2688,12 @@ declareForeigns = do
declareForeign Tracked "Tls.terminate.impl.v3" boxToEF0 . mkForeignTls $
\(tls :: TLS.Context) -> TLS.bye tls
declareForeign Untracked "Code.validateLinks" boxToExnEBoxBox
. mkForeign
$ \(lsgs0 :: [(Referent, SuperGroup Symbol)]) -> do
let f (msg, rs) =
Failure Ty.miscFailureRef (Util.Text.fromText msg) rs
pure . first f $ checkGroupHashes lsgs0
declareForeign Untracked "Code.dependencies" boxDirect
. mkForeign
$ \(sg :: SuperGroup Symbol) ->

2
parser-typechecker/src/Unison/Runtime/Foreign.hs
View File

@ -226,6 +226,8 @@ instance BuiltinForeign Handle where foreignRef = Tagged Ty.fileHandleRef
instance BuiltinForeign ProcessHandle where foreignRef = Tagged Ty.processHandleRef
instance BuiltinForeign Referent where foreignRef = Tagged Ty.termLinkRef
instance BuiltinForeign Socket where foreignRef = Tagged Ty.socketRef
instance BuiltinForeign ThreadId where foreignRef = Tagged Ty.threadIdRef

27
parser-typechecker/src/Unison/Runtime/Foreign/Function.hs
View File

@ -495,10 +495,35 @@ instance {-# OVERLAPPABLE #-} (BuiltinForeign b) => ForeignConvention b where
readForeign = readForeignBuiltin
writeForeign = writeForeignBuiltin
fromUnisonPair :: Closure -> (a, b)
fromUnisonPair (DataC _ _ [] [x,y]) =
(unwrapForeignClosure x, unwrapForeignClosure y)
fromUnisonPair _ = error "fromUnisonPair: invalid closure"
toUnisonPair ::
(BuiltinForeign a, BuiltinForeign b) => (a, b) -> Closure
toUnisonPair (x,y) =
DataC Ty.pairRef 0 [] [Foreign $ wrapBuiltin x, Foreign $ wrapBuiltin y]
unwrapForeignClosure :: Closure -> a
unwrapForeignClosure = unwrapForeign . marshalToForeign
instance {-# OVERLAPPABLE #-} (BuiltinForeign a, BuiltinForeign b) => ForeignConvention [(a, b)] where
readForeign us (i : bs) _ bstk =
(us,bs,)
. fmap fromUnisonPair
. toList
<$> peekOffS bstk i
readForeign _ _ _ _ = foreignCCError "[(a,b)]"
writeForeign ustk bstk l = do
bstk <- bump bstk
(ustk, bstk) <$ pokeS bstk (toUnisonPair <$> Sq.fromList l)
instance {-# OVERLAPPABLE #-} (BuiltinForeign b) => ForeignConvention [b] where
readForeign us (i : bs) _ bstk =
(us,bs,)
. fmap (unwrapForeign . marshalToForeign)
. fmap unwrapForeignClosure
. toList
<$> peekOffS bstk i
readForeign _ _ _ _ = foreignCCError "[b]"

1436
unison-src/transcripts-using-base/all-base-hashes.output.md
View File

File diff suppressed because it is too large Load Diff

915
unison-src/transcripts/alias-many.output.md
View File

File diff suppressed because it is too large Load Diff

2
unison-src/transcripts/builtins-merge.output.md
View File

@ -18,7 +18,7 @@ The `builtins.merge` command adds the known builtins to a `builtin` subnamespace
7. Char (builtin type)
8. Char/ (22 terms, 1 type)
9. Code (builtin type)
10. Code/ (8 terms)
10. Code/ (9 terms)
11. Debug/ (3 terms)
12. Doc (type)
13. Doc/ (6 terms)

4
unison-src/transcripts/emptyCodebase.output.md
View File

@ -23,7 +23,7 @@ Technically, the definitions all exist, but they have no names. `builtins.merge`
.foo> ls
1. builtin/ (449 terms, 70 types)
1. builtin/ (450 terms, 70 types)
```
And for a limited time, you can get even more builtin goodies:
@ -35,7 +35,7 @@ And for a limited time, you can get even more builtin goodies:
.foo> ls
1. builtin/ (621 terms, 88 types)
1. builtin/ (622 terms, 88 types)
```
More typically, you'd start out by pulling `base.

12
unison-src/transcripts/merges.output.md
View File

@ -115,13 +115,13 @@ it's still in the `history` of the parent namespace and can be resurrected at an
Note: The most recent namespace hash is immediately below this
message.
⊙ 1. #sa3li5nog5
⊙ 1. #o24otbg67r
- Deletes:
feature1.y
⊙ 2. #q6lspv9f8d
⊙ 2. #ve08o4q18n
+ Adds / updates:
@ -132,26 +132,26 @@ it's still in the `history` of the parent namespace and can be resurrected at an
Original name New name(s)
feature1.y master.y
⊙ 3. #ptk4oilj4q
⊙ 3. #7ema4sval7
+ Adds / updates:
feature1.y
⊙ 4. #9gg715gost
⊙ 4. #o9rvsua82i
> Moves:
Original name New name
x master.x
⊙ 5. #pvpo0hnijj
⊙ 5. #0f4f0oq3qu
+ Adds / updates:
x
□ 6. #0vd5v3o8ft (start of history)
□ 6. #jduh37nsjd (start of history)
```
To resurrect an old version of a namespace, you can learn its hash via the `history` command, then use `fork #namespacehash .newname`.

28
unison-src/transcripts/move-namespace.output.md
View File

@ -269,7 +269,7 @@ I should be able to move the root into a sub-namespace
.> ls
1. root/ (626 terms, 89 types)
1. root/ (627 terms, 89 types)
.> history
@ -278,13 +278,13 @@ I should be able to move the root into a sub-namespace
□ 1. #7bm586a8jt (start of history)
□ 1. #hudvphc0p2 (start of history)
```
```ucm
.> ls .root.at.path
1. builtin/ (621 terms, 88 types)
1. builtin/ (622 terms, 88 types)
2. existing/ (1 term)
3. happy/ (3 terms, 1 type)
4. history/ (1 term)
@ -294,7 +294,7 @@ I should be able to move the root into a sub-namespace
Note: The most recent namespace hash is immediately below this
message.
⊙ 1. #gnb1l9v7qe
⊙ 1. #tauifjcoos
- Deletes:
@ -305,7 +305,7 @@ I should be able to move the root into a sub-namespace
Original name New name
existing.a.termInA existing.b.termInA
⊙ 2. #8dluhc3eme
⊙ 2. #pq70q3j6gv
+ Adds / updates:
@ -317,26 +317,26 @@ I should be able to move the root into a sub-namespace
happy.b.termInA existing.a.termInA
history.b.termInA existing.a.termInA
⊙ 3. #6htqn8menp
⊙ 3. #8cse7d43l7
+ Adds / updates:
existing.a.termInA existing.b.termInB
⊙ 4. #hfd1mcld2o
⊙ 4. #b9oue7jd63
> Moves:
Original name New name
history.a.termInA history.b.termInA
⊙ 5. #fo83se877g
⊙ 5. #e2jhdphhct
- Deletes:
history.b.termInB
⊙ 6. #c1orlm0qfi
⊙ 6. #kgdsg47m68
+ Adds / updates:
@ -347,13 +347,13 @@ I should be able to move the root into a sub-namespace
Original name New name(s)
happy.b.termInA history.a.termInA
⊙ 7. #tukb79gfj3
⊙ 7. #2ps9eprvsl
+ Adds / updates:
history.a.termInA history.b.termInB
⊙ 8. #vdbqau51tt
⊙ 8. #ve6rr7av44
> Moves:
@ -363,7 +363,7 @@ I should be able to move the root into a sub-namespace
happy.a.T.T2 happy.b.T.T2
happy.a.termInA happy.b.termInA
⊙ 9. #uc0jt9dato
⊙ 9. #r4hg0pthvq
+ Adds / updates:
@ -373,7 +373,7 @@ I should be able to move the root into a sub-namespace
happy.a.T.T
⊙ 10. #7slt2ueav7
⊙ 10. #sc0oshmc6r
+ Adds / updates:
@ -385,7 +385,7 @@ I should be able to move the root into a sub-namespace
⠇
⊙ 11. #679lhq8rae
⊙ 11. #rr2vea72u7
```

33
unison-src/transcripts/name-selection.output.md
View File

@ -1428,61 +1428,64 @@ d = c + 10
Code)]
->{IO} Optional
Failure
513. builtin.io2.validateSandboxed : [Term]
513. builtin.Code.validateLinks : [( Term,
Code)]
->{Exception} [Term]
514. builtin.io2.validateSandboxed : [Term]
-> a
-> Boolean
514. builtin.Value.value : a
515. builtin.Value.value : a
-> Value
515. builtin.io2.IO.process.wait : ProcessHandle
516. builtin.io2.IO.process.wait : ProcessHandle
->{IO} Nat
516. builtin.Debug.watch : Text
517. builtin.Debug.watch : Text
-> a
-> a
517. builtin.Char.Class.whitespace : Class
518. builtin.MutableArray.write : MutableArray
518. builtin.Char.Class.whitespace : Class
519. builtin.MutableArray.write : MutableArray
g a
-> Nat
-> a
->{g,
Exception} ()
519. builtin.io2.Promise.write : Promise
520. builtin.io2.Promise.write : Promise
a
-> a
->{IO} Boolean
520. builtin.Ref.write : Ref g a
521. builtin.Ref.write : Ref g a
-> a
->{g} ()
521. builtin.io2.TVar.write : TVar a
522. builtin.io2.TVar.write : TVar a
-> a
->{STM} ()
522. builtin.MutableByteArray.write16be : MutableByteArray
523. builtin.MutableByteArray.write16be : MutableByteArray
g
-> Nat
-> Nat
->{g,
Exception} ()
523. builtin.MutableByteArray.write32be : MutableByteArray
524. builtin.MutableByteArray.write32be : MutableByteArray
g
-> Nat
-> Nat
->{g,
Exception} ()
524. builtin.MutableByteArray.write64be : MutableByteArray
525. builtin.MutableByteArray.write64be : MutableByteArray
g
-> Nat
-> Nat
->{g,
Exception} ()
525. builtin.MutableByteArray.write8 : MutableByteArray
526. builtin.MutableByteArray.write8 : MutableByteArray
g
-> Nat
-> Nat
->{g,
Exception} ()
526. builtin.Int.xor : Int
527. builtin.Int.xor : Int
-> Int
-> Int
527. builtin.Nat.xor : Nat
528. builtin.Nat.xor : Nat
-> Nat
-> Nat

10
unison-src/transcripts/reflog.output.md
View File

@ -59,17 +59,17 @@ y = 2
most recent, along with the command that got us there. Try:
`fork 2 .old`
`fork #orq12grp91 .old` to make an old namespace
`fork #3svj265l6g .old` to make an old namespace
accessible again,
`reset-root #orq12grp91` to reset the root namespace and
`reset-root #3svj265l6g` to reset the root namespace and
its history to that of the
specified namespace.
When Root Hash Action
1. now #8l32evfkrc add
2. now #orq12grp91 add
3. now #caij5gocub builtins.merge
1. now #poi4ftidsb add
2. now #3svj265l6g add
3. now #imu74ctf2v builtins.merge
4. #sg60bvjo91 history starts here
Tip: Use `diff.namespace 1 7` to compare namespaces between

10
unison-src/transcripts/reset.output.md
View File

@ -26,13 +26,13 @@ a = 5
Note: The most recent namespace hash is immediately below this
message.
⊙ 1. #nj1rfces5b
⊙ 1. #65muh384mp
+ Adds / updates:
a
□ 2. #caij5gocub (start of history)
□ 2. #imu74ctf2v (start of history)
.> reset 2
@ -45,7 +45,7 @@ a = 5
□ 1. #caij5gocub (start of history)
□ 1. #imu74ctf2v (start of history)
```
```unison
@ -79,13 +79,13 @@ foo.a = 5
Note: The most recent namespace hash is immediately below this
message.
⊙ 1. #c0ome1eb6c
⊙ 1. #5upvuiur50
+ Adds / updates:
foo.a
□ 2. #caij5gocub (start of history)
□ 2. #imu74ctf2v (start of history)
.> reset 1 foo

20
unison-src/transcripts/squash.output.md
View File

@ -13,7 +13,7 @@ Let's look at some examples. We'll start with a namespace with just the builtins
□ 1. #5nd39ebhk9 (start of history)
□ 1. #94fai72a7n (start of history)
.> fork builtin builtin2
@ -42,21 +42,21 @@ Now suppose we `fork` a copy of builtin, then rename `Nat.+` to `frobnicate`, th
Note: The most recent namespace hash is immediately below this
message.
⊙ 1. #73ohao25ot
⊙ 1. #i2nla67hnu
> Moves:
Original name New name
Nat.frobnicate Nat.+
⊙ 2. #mrd0kk9f6v
⊙ 2. #l9vlpokkkn
> Moves:
Original name New name
Nat.+ Nat.frobnicate
□ 3. #5nd39ebhk9 (start of history)
□ 3. #94fai72a7n (start of history)
```
If we merge that back into `builtin`, we get that same chain of history:
@ -73,21 +73,21 @@ If we merge that back into `builtin`, we get that same chain of history:
Note: The most recent namespace hash is immediately below this
message.
⊙ 1. #73ohao25ot
⊙ 1. #i2nla67hnu
> Moves:
Original name New name
Nat.frobnicate Nat.+
⊙ 2. #mrd0kk9f6v
⊙ 2. #l9vlpokkkn
> Moves:
Original name New name
Nat.+ Nat.frobnicate
□ 3. #5nd39ebhk9 (start of history)
□ 3. #94fai72a7n (start of history)
```
Let's try again, but using a `merge.squash` (or just `squash`) instead. The history will be unchanged:
@ -108,7 +108,7 @@ Let's try again, but using a `merge.squash` (or just `squash`) instead. The hist
□ 1. #5nd39ebhk9 (start of history)
□ 1. #94fai72a7n (start of history)
```
The churn that happened in `mybuiltin` namespace ended up back in the same spot, so the squash merge of that namespace with our original namespace had no effect.
@ -499,13 +499,13 @@ This checks to see that squashing correctly preserves deletions:
Note: The most recent namespace hash is immediately below this
message.
⊙ 1. #go5ls0mr4j
⊙ 1. #4qp4mmddbv
- Deletes:
Nat.* Nat.+
□ 2. #5nd39ebhk9 (start of history)
□ 2. #94fai72a7n (start of history)
```
Notice that `Nat.+` and `Nat.*` are deleted by the squash, and we see them deleted in one atomic step in the history.