diff options
Diffstat (limited to '')
| -rw-r--r-- | stdlib/source/lux/control/concurrency/actor.lux | 16 | ||||
| -rw-r--r-- | stdlib/source/lux/control/region.lux | 2 | ||||
| -rw-r--r-- | stdlib/source/lux/control/security/privacy.lux | 26 | ||||
| -rw-r--r-- | stdlib/source/test/lux.lux | 42 | ||||
| -rw-r--r-- | stdlib/source/test/lux/control.lux | 28 | ||||
| -rw-r--r-- | stdlib/source/test/lux/control/concurrency/actor.lux | 90 | ||||
| -rw-r--r-- | stdlib/source/test/lux/control/concurrency/atom.lux | 44 | ||||
| -rw-r--r-- | stdlib/source/test/lux/control/concurrency/frp.lux | 92 | ||||
| -rw-r--r-- | stdlib/source/test/lux/control/region.lux | 154 | ||||
| -rw-r--r-- | stdlib/source/test/lux/control/security/integrity.lux | 80 | ||||
| -rw-r--r-- | stdlib/source/test/lux/control/security/privacy.lux | 94 |
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) + )))) |