aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--stdlib/source/lux/control/concurrency/actor.lux16
-rw-r--r--stdlib/source/lux/control/region.lux2
-rw-r--r--stdlib/source/lux/control/security/privacy.lux26
-rw-r--r--stdlib/source/test/lux.lux42
-rw-r--r--stdlib/source/test/lux/control.lux28
-rw-r--r--stdlib/source/test/lux/control/concurrency/actor.lux90
-rw-r--r--stdlib/source/test/lux/control/concurrency/atom.lux44
-rw-r--r--stdlib/source/test/lux/control/concurrency/frp.lux92
-rw-r--r--stdlib/source/test/lux/control/region.lux154
-rw-r--r--stdlib/source/test/lux/control/security/integrity.lux80
-rw-r--r--stdlib/source/test/lux/control/security/privacy.lux94
11 files changed, 350 insertions, 318 deletions
diff --git a/stdlib/source/lux/control/concurrency/actor.lux b/stdlib/source/lux/control/concurrency/actor.lux
index 6707a6c4d..397a2fdb4 100644
--- a/stdlib/source/lux/control/concurrency/actor.lux
+++ b/stdlib/source/lux/control/concurrency/actor.lux
@@ -1,12 +1,13 @@
(.module: {#.doc "The actor model of concurrency."}
[lux #*
+ ["." function]
[control monad
["p" parser]
["ex" exception (#+ exception:)]]
- ["." io ("#/." monad)]
+ ["." io (#+ IO io) ("#/." monad)]
[data
["." product]
- ["e" error]
+ ["." error]
[text
format]
[collection
@@ -93,14 +94,14 @@
[[head tail] |mailbox|
?state' (handle head state self)]
(case ?state'
- (#e.Failure error)
+ (#error.Failure error)
(do @
[_ (end error state)]
(let [[_ resolve] (get@ #obituary (:representation self))]
(exec (io.run (resolve [error state (#.Cons head (..obituary tail))]))
(wrap []))))
- (#e.Success state')
+ (#error.Success state')
(recur state' tail))))]
self)))
@@ -167,7 +168,7 @@
(def: #export (<resolve> name)
(-> Name (Meta Name))
- (do io.monad
+ (do macro.monad
[[_ annotations _] (macro.find-def name)]
(case (macro.get-tag-ann (name-of <tag>) annotations)
(#.Some actor-name)
@@ -333,7 +334,7 @@
[current-module macro.current-module-name
actor-name (resolve-actor actor-name)
#let [message-name [current-module (get@ #name signature)]
- g!type (code.identifier (product.both id state-name actor-name))
+ g!type (code.identifier (product.both function.identity state-name actor-name))
g!message (code.local-identifier (get@ #name signature))
g!actor-vars (list/map code.local-identifier actor-vars)
actorC (` ((~ (code.identifier actor-name)) (~+ g!actor-vars)))
@@ -386,5 +387,4 @@
((~' wrap) (~ g!task))
((~' wrap) (task.throw ..dead [(~ (code.text (%name actor-name)))
(~ (code.text (%name message-name)))]))))))))
- ))
- )))
+ )))))
diff --git a/stdlib/source/lux/control/region.lux b/stdlib/source/lux/control/region.lux
index ddd86876b..8e12c7675 100644
--- a/stdlib/source/lux/control/region.lux
+++ b/stdlib/source/lux/control/region.lux
@@ -90,7 +90,7 @@
(All [r] (Apply (Region r m)))))
(def: &functor
- (..functor (get@ #monad.functor Monad<m>)))
+ (..functor (get@ #monad.&functor Monad<m>)))
(def: (apply ff fa)
(function (_ [region cleaners])
diff --git a/stdlib/source/lux/control/security/privacy.lux b/stdlib/source/lux/control/security/privacy.lux
index 51d530673..fe6a70233 100644
--- a/stdlib/source/lux/control/security/privacy.lux
+++ b/stdlib/source/lux/control/security/privacy.lux
@@ -7,7 +7,7 @@
[type
abstract]]
[//
- [capability (#+ Capability)]])
+ ["!" capability (#+ capability:)]])
(abstract: #export (Private value label)
{#.doc (doc "A value that is regarded as 'private'."
@@ -21,27 +21,23 @@
## there to prevent confusing private values from different origins.
value
- (type: #export (Can-Conceal label)
+ (capability: #export (Can-Conceal label value)
{#.doc (doc "Represents the capacity to 'privatize' a value.")}
- (All [value]
- (Capability value
- (Private value label))))
+ (can-conceal value (Private value label)))
- (type: #export (Can-Reveal label)
+ (capability: #export (Can-Reveal label value)
{#.doc (doc "Represents the capacity to 'publicize' a value.")}
- (All [value]
- (Capability (Private value label)
- value)))
+ (can-reveal (Private value label) value))
- (signature: #export (Privilege label)
+ (type: #export (Privilege label)
{#.doc (doc "Represents the privilege to both 'privatize' and 'publicize' a value.")}
- [(Can-Conceal label)
- (Can-Reveal label)])
+ {#can-conceal (Can-Conceal label)
+ #can-reveal (Can-Reveal label)})
(def: Privilege<_>
Privilege
- (structure (def: conceal (|>> :abstraction))
- (def: reveal (|>> :representation))))
+ {#can-conceal (..can-conceal (|>> :abstraction))
+ #can-reveal (..can-reveal (|>> :representation))})
(type: #export (Delegation from to)
{#.doc (doc "Represents the act of delegating privatization capacities.")}
@@ -50,7 +46,7 @@
(def: #export (delegation reveal conceal)
{#.doc (doc "Delegating privatization capacities.")}
(All [from to] (-> (Can-Reveal from) (Can-Conceal to) (Delegation from to)))
- (|>> reveal conceal))
+ (|>> (!.use reveal) (!.use conceal)))
(type: #export (Context scope label)
{#.doc (doc "A computational context with an associated privacy privilege.")}
diff --git a/stdlib/source/test/lux.lux b/stdlib/source/test/lux.lux
index 391526efb..89136bb50 100644
--- a/stdlib/source/test/lux.lux
+++ b/stdlib/source/test/lux.lux
@@ -29,17 +29,20 @@
[tool
[compiler
[phase
- [translation
- [js
- [runtime (#+)]
- [primitive (#+)]
- [structure (#+)]
- [reference (#+)]]
- [scheme
- [runtime (#+)]
- [primitive (#+)]
- [structure (#+)]
- [reference (#+)]]]]]]
+ ## [translation
+ ## [scheme
+ ## [runtime (#+)]
+ ## [primitive (#+)]
+ ## [structure (#+)]
+ ## [reference (#+)]
+ ## [case (#+)]]
+ ## [js
+ ## [runtime (#+)]
+ ## [primitive (#+)]
+ ## [structure (#+)]
+ ## [reference (#+)]
+ ## [case (#+)]]]
+ ]]]
## [control
## ["._" contract]
## ["._" concatenative]
@@ -108,14 +111,7 @@
["/." jvm]]
["/." control]]
## [control
- ## ## [region (#+)]
- ## ## [security
- ## ## [privacy (#+)]
- ## ## [integrity (#+)]]
## [concurrency
- ## [actor (#+)]
- ## [atom (#+)]
- ## [frp (#+)]
## [promise (#+)]
## [stm (#+)]
## ## [semaphore (#+)]
@@ -224,18 +220,12 @@
(do r.monad
[value r.i64]
($_ _.and
- (_.test "'inc' and 'dec' are different."
- (not (n/= (inc value)
- (dec value))))
(_.test "'inc' and 'dec' are opposites."
(and (|> value inc dec (n/= value))
(|> value dec inc (n/= value))))
(_.test "'inc' and 'dec' shift the number by 1."
- (let [shift 1]
- (and (n/= (n/+ shift value)
- (inc value))
- (n/= (n/- shift value)
- (dec value))))))))
+ (and (|> (inc value) (n/- value) (n/= 1))
+ (|> value (n/- (dec value)) (n/= 1)))))))
(def: (check-neighbors has-property? value)
(All [a] (-> (Predicate (I64 a)) (I64 a) Bit))
diff --git a/stdlib/source/test/lux/control.lux b/stdlib/source/test/lux/control.lux
index 97f8c8cf5..70e1dfa1d 100644
--- a/stdlib/source/test/lux/control.lux
+++ b/stdlib/source/test/lux/control.lux
@@ -8,9 +8,30 @@
["/." parser]
["/." pipe]
["/." reader]
+ ["/." region]
["/." state]
["/." thread]
- ["/." writer]])
+ ["/." writer]
+ [concurrency
+ ["/." actor]
+ ["/." atom]
+ ["/." frp]]
+ [security
+ ["/." privacy]
+ ["/." integrity]]])
+
+(def: concurrency
+ Test
+ ($_ _.and
+ /actor.test
+ /atom.test
+ /frp.test))
+
+(def: security
+ Test
+ ($_ _.and
+ /privacy.test
+ /integrity.test))
(def: #export test
Test
@@ -22,6 +43,9 @@
(<| (_.context "/pipe")
/pipe.test)
/reader.test
+ /region.test
/state.test
/thread.test
- /writer.test))
+ /writer.test
+ ..concurrency
+ ..security))
diff --git a/stdlib/source/test/lux/control/concurrency/actor.lux b/stdlib/source/test/lux/control/concurrency/actor.lux
index 791fefec8..dba286b22 100644
--- a/stdlib/source/test/lux/control/concurrency/actor.lux
+++ b/stdlib/source/test/lux/control/concurrency/actor.lux
@@ -1,31 +1,34 @@
(.module:
[lux #*
+ ["_" test (#+ Test)]
["." io (#+ IO io)]
[control
["M" monad (#+ do Monad)]
["ex" exception]
[concurrency
["." promise ("#/." monad)]
- ["T" task]
- ["&" actor (#+ actor: message:)]]]
+ ["T" task]]]
[data
["." error]
[text
- format]]]
- lux/test)
+ format]]
+ [math
+ ["r" random]]]
+ {1
+ ["." / (#+ actor: message:)]})
(actor: Counter
Nat
((handle message state self)
- (do t.monad
+ (do T.monad
[#let [_ (log! "BEFORE")]
output (message state self)
#let [_ (log! "AFTER")]]
(wrap output)))
((stop cause state)
- (promise/wrap (log! (if (ex.match? &.poisoned cause)
+ (promise/wrap (log! (if (ex.match? /.poisoned cause)
(format "Counter was poisoned: " (%n state))
cause)))))
@@ -34,42 +37,45 @@
(let [state' (n/+ increment state)]
(T.return [state' state'])))
-(context: "Actors"
- ($_ seq
- (test "Can check if an actor is alive."
- (io.run (do io.monad
- [counter (new@Counter 0)]
- (wrap (&.alive? counter)))))
+(def: #export test
+ Test
+ (<| (_.context (%name (name-of /.Actor)))
+ ($_ _.and
+ (_.test "Can check if an actor is alive."
+ (io.run (do io.monad
+ [counter (new@Counter 0)]
+ (wrap (/.alive? counter)))))
- (test "Can poison actors."
- (io.run (do io.monad
- [counter (new@Counter 0)
- poisoned? (&.poison counter)]
- (wrap (and poisoned?
- (not (&.alive? counter)))))))
-
- (test "Cannot poison an already dead actor."
- (io.run (do io.monad
- [counter (new@Counter 0)
- first-time (&.poison counter)
- second-time (&.poison counter)]
- (wrap (and first-time
- (not second-time))))))
+ (_.test "Can poison actors."
+ (io.run (do io.monad
+ [counter (new@Counter 0)
+ poisoned? (/.poison counter)]
+ (wrap (and poisoned?
+ (not (/.alive? counter)))))))
+
+ (_.test "Cannot poison an already dead actor."
+ (io.run (do io.monad
+ [counter (new@Counter 0)
+ first-time (/.poison counter)
+ second-time (/.poison counter)]
+ (wrap (and first-time
+ (not second-time))))))
- (wrap (do p.monad
- [result (do t.monad
- [#let [counter (io.run (new@Counter 0))]
- output-1 (count! 1 counter)
- output-2 (count! 1 counter)
- output-3 (count! 1 counter)]
- (wrap (and (n/= 1 output-1)
- (n/= 2 output-2)
- (n/= 3 output-3))))]
- (assert "Can send messages to actors."
- (case result
- (#error.Success outcome)
- outcome
+ (:: r.monad wrap
+ (do promise.monad
+ [result (do T.monad
+ [#let [counter (io.run (new@Counter 0))]
+ output-1 (count! 1 counter)
+ output-2 (count! 1 counter)
+ output-3 (count! 1 counter)]
+ (wrap (and (n/= 1 output-1)
+ (n/= 2 output-2)
+ (n/= 3 output-3))))]
+ (_.assert "Can send messages to actors."
+ (case result
+ (#error.Success outcome)
+ outcome
- (#error.Failure error)
- #0))))
- ))
+ (#error.Failure error)
+ #0))))
+ )))
diff --git a/stdlib/source/test/lux/control/concurrency/atom.lux b/stdlib/source/test/lux/control/concurrency/atom.lux
index 720547e27..2776e4f54 100644
--- a/stdlib/source/test/lux/control/concurrency/atom.lux
+++ b/stdlib/source/test/lux/control/concurrency/atom.lux
@@ -1,34 +1,38 @@
(.module:
[lux #*
+ ["_" test (#+ Test)]
["." io]
[control
- ["M" monad (#+ do Monad)]
- [concurrency
- ["&" atom]]]
+ ["M" monad (#+ do Monad)]]
+ [data
+ [text
+ format]]
[math
["r" random]]]
- lux/test)
+ {1
+ ["." /]})
-(context: "Atoms"
- (<| (times 100)
- (do @
+(def: #export test
+ Test
+ (<| (_.context (%name (name-of /.Atom)))
+ (do r.monad
[value r.nat
swap-value r.nat
set-value r.nat
- #let [box (&.atom value)]]
- ($_ seq
- (test "Can obtain the value of an atom."
- (n/= value (io.run (&.read box))))
+ #let [box (/.atom value)]]
+ ($_ _.and
+ (_.test "Can obtain the value of an atom."
+ (n/= value (io.run (/.read box))))
- (test "Can swap the value of an atom."
- (and (io.run (&.compare-and-swap value swap-value box))
- (n/= swap-value (io.run (&.read box)))))
+ (_.test "Can swap the value of an atom."
+ (and (io.run (/.compare-and-swap value swap-value box))
+ (n/= swap-value (io.run (/.read box)))))
- (test "Can update the value of an atom."
- (exec (io.run (&.update inc box))
- (n/= (inc swap-value) (io.run (&.read box)))))
+ (_.test "Can update the value of an atom."
+ (exec (io.run (/.update inc box))
+ (n/= (inc swap-value) (io.run (/.read box)))))
- (test "Can immediately set the value of an atom."
- (exec (io.run (&.write set-value box))
- (n/= set-value (io.run (&.read box)))))
+ (_.test "Can immediately set the value of an atom."
+ (exec (io.run (/.write set-value box))
+ (n/= set-value (io.run (/.read box)))))
))))
diff --git a/stdlib/source/test/lux/control/concurrency/frp.lux b/stdlib/source/test/lux/control/concurrency/frp.lux
index 7c1552f41..b49a9e649 100644
--- a/stdlib/source/test/lux/control/concurrency/frp.lux
+++ b/stdlib/source/test/lux/control/concurrency/frp.lux
@@ -1,53 +1,59 @@
(.module:
[lux #*
+ ["_" test (#+ Test)]
["." io (#+ IO io)]
[control
- ["." monad (#+ do Monad)]
+ ["." monad (#+ do)]
[concurrency
["." promise ("#/." monad)]
- ["." frp (#+ Channel)]
["." atom (#+ Atom atom)]]]
[data
- ["." number]
+ [number
+ ["." nat]]
[collection
- ["." list]]]]
- lux/test)
+ ["." list ("#/." functor)]]]
+ [math
+ ["r" random]]]
+ {1
+ ["." / (#+ Channel)]})
-(context: "FRP"
- (let [(^open "list/.") (list.equivalence number.equivalence)]
- ($_ seq
- (wrap (do promise.monad
- [output (|> (list +0 +1 +2 +3 +4 +5)
- (frp.sequential 0)
- (frp.filter i/even?)
- frp.consume)]
- (assert "Can filter a channel's elements."
- (list/= (list +0 +2 +4) output))))
-
- (wrap (do promise.monad
- [output (|> (list +0 +1 +2 +3 +4 +5)
- (frp.sequential 0)
- (:: frp.functor map inc)
- frp.consume)]
- (assert "Functor goes over every element in a channel."
- (list/= (list +1 +2 +3 +4 +5 +6)
- output))))
-
- (wrap (do promise.monad
- [output (frp.consume (:: frp.apply apply
- (frp.sequential 0 (list inc))
- (frp.sequential 0 (list +12345))))]
- (assert "Apply works over all channel values."
- (list/= (list +12346)
- output))))
-
- (wrap (do promise.monad
- [output (frp.consume
- (do frp.monad
- [f (frp.from-promise (promise/wrap inc))
- a (frp.from-promise (promise/wrap +12345))]
- (wrap (f a))))]
- (assert "Valid monad."
- (list/= (list +12346)
- output))))
- )))
+(def: #export test
+ Test
+ (let [(^open "list/.") (list.equivalence nat.equivalence)]
+ (do r.monad
+ [inputs (r.list 5 r.nat)
+ sample r.nat]
+ ($_ _.and
+ (wrap (do promise.monad
+ [output (|> inputs
+ (/.sequential 0)
+ (/.filter n/even?)
+ /.consume)]
+ (_.assert "Can filter a channel's elements."
+ (list/= (list.filter n/even? inputs)
+ output))))
+ (wrap (do promise.monad
+ [output (|> inputs
+ (/.sequential 0)
+ (:: /.functor map inc)
+ /.consume)]
+ (_.assert "Functor goes over every element in a channel."
+ (list/= (list/map inc inputs)
+ output))))
+ (wrap (do promise.monad
+ [output (/.consume (:: /.apply apply
+ (/.sequential 0 (list inc))
+ (/.sequential 0 (list sample))))]
+ (_.assert "Apply works over all channel values."
+ (list/= (list (inc sample))
+ output))))
+ (wrap (do promise.monad
+ [output (/.consume
+ (do /.monad
+ [f (/.from-promise (promise/wrap inc))
+ a (/.from-promise (promise/wrap sample))]
+ (wrap (f a))))]
+ (_.assert "Valid monad."
+ (list/= (list (inc sample))
+ output))))
+ ))))
diff --git a/stdlib/source/test/lux/control/region.lux b/stdlib/source/test/lux/control/region.lux
index ff6bdaeaf..091506613 100644
--- a/stdlib/source/test/lux/control/region.lux
+++ b/stdlib/source/test/lux/control/region.lux
@@ -1,17 +1,20 @@
(.module:
[lux #*
+ ["_" test (#+ Test)]
[control
["." monad (#+ do)]
- ["/" region]
["." thread (#+ Thread)]
["ex" exception (#+ exception:)]]
[data
["." error (#+ Error)]
+ [text
+ format]
[collection
["." list]]]
[math
["r" random]]]
- lux/test)
+ {1
+ ["." /]})
(exception: oops)
@@ -29,78 +32,79 @@
[error? #0 #1]
)
-(context: "Regions."
- (<| (times 100)
- (do @
+(def: #export test
+ Test
+ (<| (_.context (%name (name-of /.Region)))
+ (do r.monad
[expected-clean-ups (|> r.nat (:: @ map (|>> (n/% 100) (n/max 1))))]
- ($_ seq
- (test "Clean-up functions are always run when region execution is done."
- (thread.run
- (do thread.monad
- [clean-up-counter (thread.box 0)
- #let [@@ @
- count-clean-up (function (_ value)
- (do @
- [_ (thread.update inc clean-up-counter)]
- (wrap (#error.Success []))))]
- outcome (/.run @
- (do (/.monad @)
- [_ (monad.map @ (/.acquire @@ count-clean-up)
- (list.n/range 1 expected-clean-ups))]
- (wrap [])))
- actual-clean-ups (thread.read clean-up-counter)]
- (wrap (and (success? outcome)
- (n/= expected-clean-ups
- actual-clean-ups))))))
- (test "Can clean-up despite errors."
- (thread.run
- (do thread.monad
- [clean-up-counter (thread.box 0)
- #let [@@ @
- count-clean-up (function (_ value)
- (do @
- [_ (thread.update inc clean-up-counter)]
- (wrap (#error.Success []))))]
- outcome (/.run @
- (do (/.monad @)
- [_ (monad.map @ (/.acquire @@ count-clean-up)
- (list.n/range 1 expected-clean-ups))
- _ (/.throw @@ oops [])]
- (wrap [])))
- actual-clean-ups (thread.read clean-up-counter)]
- (wrap (and (error? outcome)
- (n/= expected-clean-ups
- actual-clean-ups))))))
- (test "Errors can propagate from the cleaners."
- (thread.run
- (do thread.monad
- [clean-up-counter (thread.box 0)
- #let [@@ @
- count-clean-up (function (_ value)
- (do @
- [_ (thread.update inc clean-up-counter)]
- (wrap (: (Error Any) (ex.throw oops [])))))]
- outcome (/.run @
- (do (/.monad @)
- [_ (monad.map @ (/.acquire @@ count-clean-up)
- (list.n/range 1 expected-clean-ups))]
- (wrap [])))
- actual-clean-ups (thread.read clean-up-counter)]
- (wrap (and (or (n/= 0 expected-clean-ups)
- (error? outcome))
- (n/= expected-clean-ups
- actual-clean-ups))))))
- (test "Can lift operations."
- (thread.run
- (do thread.monad
- [clean-up-counter (thread.box 0)
- #let [@@ @]
- outcome (/.run @
- (do (/.monad @)
- [_ (/.lift @@ (thread.write expected-clean-ups clean-up-counter))]
- (wrap [])))
- actual-clean-ups (thread.read clean-up-counter)]
- (wrap (and (success? outcome)
- (n/= expected-clean-ups
- actual-clean-ups))))))
+ ($_ _.and
+ (_.test "Clean-up functions are always run when region execution is done."
+ (thread.run
+ (do thread.monad
+ [clean-up-counter (thread.box 0)
+ #let [@@ @
+ count-clean-up (function (_ value)
+ (do @
+ [_ (thread.update inc clean-up-counter)]
+ (wrap (#error.Success []))))]
+ outcome (/.run @
+ (do (/.monad @)
+ [_ (monad.map @ (/.acquire @@ count-clean-up)
+ (list.n/range 1 expected-clean-ups))]
+ (wrap [])))
+ actual-clean-ups (thread.read clean-up-counter)]
+ (wrap (and (success? outcome)
+ (n/= expected-clean-ups
+ actual-clean-ups))))))
+ (_.test "Can clean-up despite errors."
+ (thread.run
+ (do thread.monad
+ [clean-up-counter (thread.box 0)
+ #let [@@ @
+ count-clean-up (function (_ value)
+ (do @
+ [_ (thread.update inc clean-up-counter)]
+ (wrap (#error.Success []))))]
+ outcome (/.run @
+ (do (/.monad @)
+ [_ (monad.map @ (/.acquire @@ count-clean-up)
+ (list.n/range 1 expected-clean-ups))
+ _ (/.throw @@ oops [])]
+ (wrap [])))
+ actual-clean-ups (thread.read clean-up-counter)]
+ (wrap (and (error? outcome)
+ (n/= expected-clean-ups
+ actual-clean-ups))))))
+ (_.test "Errors can propagate from the cleaners."
+ (thread.run
+ (do thread.monad
+ [clean-up-counter (thread.box 0)
+ #let [@@ @
+ count-clean-up (function (_ value)
+ (do @
+ [_ (thread.update inc clean-up-counter)]
+ (wrap (: (Error Any) (ex.throw oops [])))))]
+ outcome (/.run @
+ (do (/.monad @)
+ [_ (monad.map @ (/.acquire @@ count-clean-up)
+ (list.n/range 1 expected-clean-ups))]
+ (wrap [])))
+ actual-clean-ups (thread.read clean-up-counter)]
+ (wrap (and (or (n/= 0 expected-clean-ups)
+ (error? outcome))
+ (n/= expected-clean-ups
+ actual-clean-ups))))))
+ (_.test "Can lift operations."
+ (thread.run
+ (do thread.monad
+ [clean-up-counter (thread.box 0)
+ #let [@@ @]
+ outcome (/.run @
+ (do (/.monad @)
+ [_ (/.lift @@ (thread.write expected-clean-ups clean-up-counter))]
+ (wrap [])))
+ actual-clean-ups (thread.read clean-up-counter)]
+ (wrap (and (success? outcome)
+ (n/= expected-clean-ups
+ actual-clean-ups))))))
))))
diff --git a/stdlib/source/test/lux/control/security/integrity.lux b/stdlib/source/test/lux/control/security/integrity.lux
index dfd7bf5ea..7998ba83d 100644
--- a/stdlib/source/test/lux/control/security/integrity.lux
+++ b/stdlib/source/test/lux/control/security/integrity.lux
@@ -1,54 +1,54 @@
(.module:
[lux #*
+ ["_" test (#+ Test)]
[control
[hash (#+ Hash)]
[monad (#+ do)]
- [security
- ["@" integrity]]]
+ {[0 #test]
+ [/
+ [".T" functor (#+ Injection Comparison)]
+ [".T" apply]
+ [".T" monad]]}]
[data
["." error]
["." text ("#/." equivalence)
format]]
[math
["r" random]]]
- lux/test)
+ {1
+ ["." / (#+ Dirty)]})
-(context: "Taint."
- (do @
- [raw (r.ascii 10)
- #let [dirty (@.taint raw)]]
- ($_ seq
- (test "Can clean a tainted value by trusting it."
- (text/= raw (@.trust dirty)))
- (test "Can validate a tainted value."
- (case (@.validate (function (_ value)
- (if (|> value text.size (n/> 0))
- (#error.Success value)
- (#error.Failure "Empty text is invalid.")))
- dirty)
- (#error.Success clean)
- (text/= raw clean)
+(def: injection
+ (Injection Dirty)
+ /.taint)
- (#error.Failure error)
- false))
- )))
+(def: comparison
+ (Comparison Dirty)
+ (function (_ == left right)
+ (== (/.trust left)
+ (/.trust right))))
-(context: "Structures."
- (do @
- [#let [duplicate (: (-> Text Text)
- (function (_ raw) (format raw raw)))]
- raw (r.ascii 10)
- #let [check (|>> @.trust (text/= (duplicate raw)))
- (^open "@/.") @.functor
- (^open "@/.") @.apply
- (^open "@/.") @.monad]]
- ($_ seq
- (test "Can use Functor."
- (check (@/map duplicate (@.taint raw))))
- (test "Can use Apply."
- (check (@/apply (@/wrap duplicate) (@.taint raw))))
- (test "Can use Monad."
- (check (do @.monad
- [dirty (@.taint raw)]
- (wrap (duplicate dirty)))))
- )))
+(def: #export test
+ Test
+ (<| (_.context (%name (name-of /.Dirty)))
+ (do r.monad
+ [raw (r.ascii 10)
+ #let [dirty (/.taint raw)]]
+ ($_ _.and
+ (_.test "Can clean a dirty value by trusting it."
+ (text/= raw (/.trust dirty)))
+ (_.test "Can validate a dirty value."
+ (case (/.validate (function (_ value)
+ (if (|> value text.size (n/> 0))
+ (#error.Success value)
+ (#error.Failure "Empty text is invalid.")))
+ dirty)
+ (#error.Success clean)
+ (text/= raw clean)
+
+ (#error.Failure error)
+ false))
+ (functorT.laws ..injection ..comparison /.functor)
+ (applyT.laws ..injection ..comparison /.apply)
+ (monadT.laws ..injection ..comparison /.monad)
+ ))))
diff --git a/stdlib/source/test/lux/control/security/privacy.lux b/stdlib/source/test/lux/control/security/privacy.lux
index 5505433ed..fc229d07b 100644
--- a/stdlib/source/test/lux/control/security/privacy.lux
+++ b/stdlib/source/test/lux/control/security/privacy.lux
@@ -1,16 +1,35 @@
(.module:
[lux #*
+ ["_" test (#+ Test)]
[control
[hash (#+ Hash)]
[monad (#+ do)]
[security
- ["@" privacy (#+ Context Privilege Private with-privacy)]]]
+ ["!" capability]]
+ {[0 #test]
+ [/
+ [".T" functor (#+ Injection Comparison)]
+ [".T" apply]
+ [".T" monad]]}]
[data
["." text ("#/." equivalence)
format]]
[math
["r" random]]]
- lux/test)
+ {1
+ ["." / (#+ Context Can-Conceal Can-Reveal Privilege Private with-privacy)]})
+
+(def: (injection can-conceal)
+ (All [label]
+ (-> (Can-Conceal label) (Injection (All [value] (Private value label)))))
+ (!.use can-conceal))
+
+(def: (comparison can-reveal)
+ (All [label]
+ (-> (Can-Reveal label) (Comparison (All [value] (Private value label)))))
+ (function (_ == left right)
+ (== (!.use can-reveal left)
+ (!.use can-reveal right))))
(type: Password (Private Text))
@@ -32,54 +51,37 @@
(structure
(def: &hash
(structure
- (def: eq
+ (def: &equivalence
(structure (def: (= reference sample)
- (text/= (%/reveal reference)
- (%/reveal sample)))))
+ (text/= (!.use %/can-reveal reference)
+ (!.use %/can-reveal sample)))))
(def: hash
- (|>> %/reveal
+ (|>> (!.use %/can-reveal)
(:: text.hash hash)))))
(def: password
- %/conceal)
-
- (def: privilege privilege))))))
+ (!.use %/can-conceal))
-(context: "Policy labels."
- (do @
- [#let [policy-0 (policy 0)]
- raw-password (r.ascii 10)
- #let [password (:: policy-0 password raw-password)]]
- ($_ seq
- (test "Can work with private values under the same label."
- (and (:: policy-0 = password password)
- (n/= (:: text.hash hash raw-password)
- (:: policy-0 hash password))))
- (let [policy-1 (policy 1)
- delegate (@.delegation (:: policy-0 reveal) (:: policy-1 conceal))]
- (test "Can use delegation to share private values between policies."
- (:: policy-1 = (delegate password) (delegate password))))
- )))
+ (def: privilege
+ privilege))))))
-(context: "Structures."
- (do @
- [#let [duplicate (: (-> Text Text)
- (function (_ raw) (format raw raw)))
- policy-0 (policy 0)]
- raw-password (r.ascii 10)
- #let [password (:: policy-0 password raw-password)]
- #let [check (:: policy-0 =
- (:: policy-0 password (duplicate raw-password)))
- (^open "@/.") @.functor
- (^open "@/.") @.apply
- (^open "@/.") @.monad]]
- ($_ seq
- (test "Can use Functor."
- (check (@/map duplicate password)))
- (test "Can use Apply."
- (check (@/apply (@/wrap duplicate) password)))
- (test "Can use Monad."
- (check (do @.monad
- [raw-password' (:: policy-0 password raw-password)]
- (wrap (duplicate raw-password')))))
- )))
+(def: #export test
+ Test
+ (<| (_.context (%name (name-of /.Private)))
+ (do r.monad
+ [#let [policy-0 (policy [])]
+ raw-password (r.ascii 10)
+ #let [password (:: policy-0 password raw-password)]]
+ ($_ _.and
+ (_.test "Can work with private values under the same label."
+ (and (:: policy-0 = password password)
+ (n/= (:: text.hash hash raw-password)
+ (:: policy-0 hash password))))
+ (let [policy-1 (policy [])
+ delegate (/.delegation (:: policy-0 can-reveal) (:: policy-1 can-conceal))]
+ (_.test "Can use delegation to share private values between policies."
+ (:: policy-1 = (delegate password) (delegate password))))
+ (functorT.laws (..injection (:: policy-0 can-conceal)) (..comparison (:: policy-0 can-reveal)) /.functor)
+ (applyT.laws (..injection (:: policy-0 can-conceal)) (..comparison (:: policy-0 can-reveal)) /.apply)
+ (monadT.laws (..injection (:: policy-0 can-conceal)) (..comparison (:: policy-0 can-reveal)) /.monad)
+ ))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-23 09:58:02 +0000