From 5cf4efa861075f8276f43a2516f5beacaf610b44 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 2 Jul 2021 03:11:36 -0400 Subject: No longer employing the capabilities model on the lux/world/* modules. Capabilities should be opt-in, but using them in the standard library makes them mandatory.--- stdlib/source/test/aedifex.lux | 2 + stdlib/source/test/aedifex/command/auto.lux | 10 +- stdlib/source/test/aedifex/command/build.lux | 16 +- stdlib/source/test/aedifex/command/clean.lux | 8 +- stdlib/source/test/aedifex/command/deploy.lux | 6 +- stdlib/source/test/aedifex/command/deps.lux | 2 - stdlib/source/test/aedifex/command/install.lux | 4 +- stdlib/source/test/aedifex/command/pom.lux | 8 +- stdlib/source/test/aedifex/command/test.lux | 22 +-- stdlib/source/test/aedifex/command/version.lux | 14 +- .../source/test/aedifex/dependency/deployment.lux | 203 +++++++++++++++++++++ .../source/test/aedifex/dependency/resolution.lux | 120 ++++++------ stdlib/source/test/aedifex/input.lux | 6 +- stdlib/source/test/aedifex/package.lux | 47 +++-- stdlib/source/test/aedifex/repository.lux | 18 +- stdlib/source/test/aedifex/repository/remote.lux | 130 +++++++++++++ stdlib/source/test/lux/control/security/policy.lux | 17 +- stdlib/source/test/lux/world.lux | 4 +- stdlib/source/test/lux/world/console.lux | 16 +- stdlib/source/test/lux/world/file.lux | 6 +- stdlib/source/test/lux/world/file/watch.lux | 12 +- stdlib/source/test/lux/world/net/http/status.lux | 119 ++++++++++++ stdlib/source/test/lux/world/shell.lux | 67 +++---- 23 files changed, 644 insertions(+), 213 deletions(-) create mode 100644 stdlib/source/test/aedifex/dependency/deployment.lux create mode 100644 stdlib/source/test/aedifex/repository/remote.lux create mode 100644 stdlib/source/test/lux/world/net/http/status.lux (limited to 'stdlib/source/test') diff --git a/stdlib/source/test/aedifex.lux b/stdlib/source/test/aedifex.lux index e3c2bd1eb..09ffcd3d8 100644 --- a/stdlib/source/test/aedifex.lux +++ b/stdlib/source/test/aedifex.lux @@ -9,6 +9,7 @@ ["#." cli] ["#." command] ["#." dependency + ["#/." deployment] ["#/." resolution] ["#/." status]] ["#." hash] @@ -27,6 +28,7 @@ Test ($_ _.and /dependency.test + /dependency/deployment.test /dependency/resolution.test /dependency/status.test )) diff --git a/stdlib/source/test/aedifex/command/auto.lux b/stdlib/source/test/aedifex/command/auto.lux index 7ef74d2c0..0808c7d21 100644 --- a/stdlib/source/test/aedifex/command/auto.lux +++ b/stdlib/source/test/aedifex/command/auto.lux @@ -9,9 +9,7 @@ ["." environment (#+ Environment)]] [concurrency ["." atom (#+ Atom)] - ["." promise (#+ Promise)]] - [security - ["!" capability]]] + ["." promise (#+ Promise)]]] [data ["." text ["%" format (#+ format)] @@ -62,7 +60,7 @@ (if (n.= expected_runs actual_runs) (wrap (#try.Failure end_signal)) (do (try.with !) - [_ (!.use (\ dummy_file over_write) (\ utf8.codec encode (%.nat actual_runs)))] + [_ (\ dummy_file over_write (\ utf8.codec encode (%.nat actual_runs)))] (do ! [_ (promise.future (atom.write actual_runs @runs))] (wrap (#try.Success [])))))))])) @@ -99,8 +97,8 @@ ($_ _.and (wrap (do promise.monad [verdict (do ///action.monad - [_ (!.use (\ fs create_directory) [source]) - dummy_file (!.use (\ fs create_file) [dummy_path]) + [_ (\ fs create_directory source) + dummy_file (\ fs create_file dummy_path) #let [[@runs command] (..command expected_runs end_signal dummy_file)] _ (\ watcher poll [])] (do promise.monad diff --git a/stdlib/source/test/aedifex/command/build.lux b/stdlib/source/test/aedifex/command/build.lux index 0e86ef946..9d37ceb00 100644 --- a/stdlib/source/test/aedifex/command/build.lux +++ b/stdlib/source/test/aedifex/command/build.lux @@ -10,9 +10,7 @@ [concurrency ["." promise (#+ Promise)]] [parser - ["." environment]] - [security - ["!" capability]]] + ["." environment]]] [data ["." text ("#\." equivalence)] [collection @@ -42,7 +40,7 @@ (shell.mock (function (_ [actual_environment actual_working_directory actual_command actual_arguments]) (#try.Success - (: (shell.Simulation []) + (: (shell.Mock []) (implementation (def: (on_read state) (exception.throw shell.no_more_output [])) @@ -60,7 +58,7 @@ (shell.mock (function (_ [actual_environment actual_working_directory actual_command actual_arguments]) (#try.Success - (: (shell.Simulation []) + (: (shell.Mock []) (implementation (def: (on_read state) (exception.throw shell.no_more_output [])) @@ -142,8 +140,8 @@ (wrap (do promise.monad [verdict (do ///action.monad [_ (/.do! console (program.async (program.mock environment.empty home working_directory)) fs shell resolution profile) - start (!.use (\ console read_line) []) - end (!.use (\ console read_line) [])] + start (\ console read_line []) + end (\ console read_line [])] (wrap (and (text\= /.start start) (text\= /.success end))))] (_.cover' [/.do! @@ -156,8 +154,8 @@ (wrap (do promise.monad [verdict (do ///action.monad [_ (/.do! console (program.async (program.mock environment.empty home working_directory)) fs (shell.async (..bad_shell [])) resolution profile) - start (!.use (\ console read_line) []) - end (!.use (\ console read_line) [])] + start (\ console read_line []) + end (\ console read_line [])] (wrap (and (text\= /.start start) (text\= /.failure end))))] (_.cover' [/.failure] diff --git a/stdlib/source/test/aedifex/command/clean.lux b/stdlib/source/test/aedifex/command/clean.lux index 705cca7f2..18997e02e 100644 --- a/stdlib/source/test/aedifex/command/clean.lux +++ b/stdlib/source/test/aedifex/command/clean.lux @@ -6,9 +6,7 @@ [control ["." try (#+ Try)] [concurrency - ["." promise (#+ Promise)]] - [security - ["!" capability]]] + ["." promise (#+ Promise)]]] [data [binary (#+ Binary)] ["." product] @@ -55,7 +53,7 @@ (do {! (try.with promise.monad)} [file (: (Promise (Try (File Promise))) (file.get_file promise.monad fs path))] - (!.use (\ file over_write) content))) + (\ file over_write content))) (def: (create_directory! fs path files) (-> (file.System Promise) Path (List [Path Binary]) (Promise (Try Any))) @@ -111,7 +109,7 @@ context_exists!/post (..directory_exists? fs context) target_exists!/post (..assets_exist? fs target_path direct_files) sub_exists!/post (..assets_exist? fs sub_path sub_files) - logging (!.use (\ console read_line) [])] + logging (\ console read_line [])] (wrap (and (and context_exists!/pre context_exists!/post) (and target_exists!/pre diff --git a/stdlib/source/test/aedifex/command/deploy.lux b/stdlib/source/test/aedifex/command/deploy.lux index 7e1bf166e..fd4395935 100644 --- a/stdlib/source/test/aedifex/command/deploy.lux +++ b/stdlib/source/test/aedifex/command/deploy.lux @@ -8,8 +8,6 @@ ["." exception] [concurrency ["." promise (#+ Promise)]] - [security - ["!" capability]] [parser ["." environment (#+ Environment)]]] [data @@ -80,7 +78,7 @@ [#let [console (@version.echo "")] _ (..make_sources! fs (get@ #///.sources profile)) _ (/.do! console repository fs artifact profile)] - (!.use (\ console read_line) []))) + (\ console read_line []))) (def: #export test Test @@ -96,7 +94,7 @@ home (random.ascii/alpha 5) working_directory (random.ascii/alpha 5) - #let [repository (///repository.mock @repository.simulation + #let [repository (///repository.mock @repository.mock @repository.empty) fs (file.mock (\ file.default separator)) program (program.async (program.mock environment.empty home working_directory))]] diff --git a/stdlib/source/test/aedifex/command/deps.lux b/stdlib/source/test/aedifex/command/deps.lux index 2b4898dd3..ecb34437a 100644 --- a/stdlib/source/test/aedifex/command/deps.lux +++ b/stdlib/source/test/aedifex/command/deps.lux @@ -8,8 +8,6 @@ ["." try] [concurrency ["." promise]] - [security - ["!" capability]] [parser ["." environment]]] [data diff --git a/stdlib/source/test/aedifex/command/install.lux b/stdlib/source/test/aedifex/command/install.lux index 8096fc2b2..bb52b3cca 100644 --- a/stdlib/source/test/aedifex/command/install.lux +++ b/stdlib/source/test/aedifex/command/install.lux @@ -8,8 +8,6 @@ ["." exception] [concurrency ["." promise (#+ Promise)]] - [security - ["!" capability]] [parser ["." environment (#+ Environment)]]] [data @@ -70,7 +68,7 @@ [#let [console (@version.echo "")] _ (..make_sources! fs (get@ #///.sources sample)) _ (/.do! console fs (///repository/local.repository program fs) sample)] - (!.use (\ console read_line) []))) + (\ console read_line []))) (def: #export test Test diff --git a/stdlib/source/test/aedifex/command/pom.lux b/stdlib/source/test/aedifex/command/pom.lux index f7f182225..0338bf7c4 100644 --- a/stdlib/source/test/aedifex/command/pom.lux +++ b/stdlib/source/test/aedifex/command/pom.lux @@ -6,9 +6,7 @@ [control ["." try (#+ Try) ("#\." functor)] [concurrency - ["." promise (#+ Promise)]] - [security - ["!" capability]]] + ["." promise (#+ Promise)]]] [data ["." binary] ["." text ("#\." equivalence) @@ -51,11 +49,11 @@ (\ ! wrap)) file (: (Promise (Try (File Promise))) (file.get_file promise.monad fs path)) - actual (!.use (\ file content) []) + actual (\ file content []) logging! (\ ///action.monad map (text\= /.success) - (!.use (\ console read_line) [])) + (\ console read_line [])) #let [expected_path! (text\= ///pom.file path) diff --git a/stdlib/source/test/aedifex/command/test.lux b/stdlib/source/test/aedifex/command/test.lux index cad06aa69..47e2ed2b3 100644 --- a/stdlib/source/test/aedifex/command/test.lux +++ b/stdlib/source/test/aedifex/command/test.lux @@ -9,9 +9,7 @@ [concurrency ["." promise]] [parser - ["." environment]] - [security - ["!" capability]]] + ["." environment]]] [data ["." text ("#\." equivalence)] [collection @@ -65,10 +63,10 @@ (wrap (do promise.monad [verdict (do ///action.monad [_ (/.do! console (program.async (program.mock environment.empty home working_directory)) fs (shell.async (@build.good_shell [])) resolution profile) - build_start (!.use (\ console read_line) []) - build_end (!.use (\ console read_line) []) - test_start (!.use (\ console read_line) []) - test_end (!.use (\ console read_line) [])] + build_start (\ console read_line []) + build_end (\ console read_line []) + test_start (\ console read_line []) + test_end (\ console read_line [])] (wrap (and (and (text\= //build.start build_start) (text\= //build.success build_end)) (and (text\= /.start test_start) @@ -83,7 +81,7 @@ [#let [bad_shell (shell.mock (function (_ [actual_environment actual_working_directory actual_command actual_arguments]) (#try.Success - (: (shell.Simulation []) + (: (shell.Mock []) (implementation (def: (on_read state) (exception.throw shell.no_more_output [])) @@ -99,10 +97,10 @@ shell.error)])))))) [])] _ (/.do! console (program.async (program.mock environment.empty home working_directory)) fs (shell.async bad_shell) resolution profile) - build_start (!.use (\ console read_line) []) - build_end (!.use (\ console read_line) []) - test_start (!.use (\ console read_line) []) - test_end (!.use (\ console read_line) [])] + build_start (\ console read_line []) + build_end (\ console read_line []) + test_start (\ console read_line []) + test_end (\ console read_line [])] (wrap (and (and (text\= //build.start build_start) (text\= //build.success build_end)) (and (text\= /.start test_start) diff --git a/stdlib/source/test/aedifex/command/version.lux b/stdlib/source/test/aedifex/command/version.lux index 079b0fde4..1bbb7f874 100644 --- a/stdlib/source/test/aedifex/command/version.lux +++ b/stdlib/source/test/aedifex/command/version.lux @@ -7,9 +7,7 @@ ["." try] ["." exception (#+ exception:)] [concurrency - ["." promise (#+ Promise)]] - [security - ["!" capability]]] + ["." promise (#+ Promise)]]] [data ["." maybe] ["." text ("#\." equivalence) @@ -23,7 +21,7 @@ ["#/." lux #_ ["#" version]]]]] [world - ["." console (#+ Console Simulation)]]] + ["." console (#+ Console Mock)]]] [/// ["@." profile]] {#program @@ -31,8 +29,8 @@ (exception: #export console_is_closed!) -(implementation: simulation - (Simulation [Bit Text]) +(implementation: mock + (Mock [Bit Text]) (def: (on_read [open? state]) (if open? @@ -61,7 +59,7 @@ (def: #export echo (-> Text (Console Promise)) (|>> [true] - (console.mock ..simulation) + (console.mock ..mock) console.async)) (def: #export test @@ -73,7 +71,7 @@ [#let [console (..echo "")] verdict (do (try.with promise.monad) [_ (/.do! console profile) - logging (!.use (\ console read_line) [])] + logging (\ console read_line [])] (wrap (text\= (version.format language/lux.version) logging)))] (_.cover' [/.do!] diff --git a/stdlib/source/test/aedifex/dependency/deployment.lux b/stdlib/source/test/aedifex/dependency/deployment.lux new file mode 100644 index 000000000..b947e609e --- /dev/null +++ b/stdlib/source/test/aedifex/dependency/deployment.lux @@ -0,0 +1,203 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)] + ["." hash (#+ Hash)]] + [control + ["." io (#+ IO)] + ["." try ("#\." functor)] + [concurrency + ["." atom (#+ Atom)] + ["." promise]]] + [data + ["." product] + ["." maybe ("#\." functor)] + ["." binary (#+ Binary) ("#\." equivalence)] + ["." text + ["%" format (#+ format)]] + [collection + ["." dictionary (#+ Dictionary)] + ["." set] + ["." list ("#\." fold)]]] + [math + ["." random (#+ Random)] + [number + ["n" nat]]] + [world + [net (#+ URL) + ["." uri (#+ URI)] + ["." http #_ + ["#" client] + ["#/." status] + ["@#" /]]]]] + ["$." // + ["#/" // #_ + ["#." package]]] + {#program + ["." / + [// (#+ Dependency) + ["." resolution] + [// + ["." profile] + ["." metadata] + ["." package (#+ Package)] + ["." artifact (#+ Artifact) ("#\." equivalence) + ["#/." type] + ["#/." extension]] + ["." repository + ["." remote]]]]]}) + +(def: good_upload + (@http.Response IO) + [http/status.created + {#@http.headers (http.headers (list)) + #@http.body (function (_ _) + (|> [0 (binary.create 0)] + #try.Success + io.io))}]) + +(type: Cache + (Atom (Dictionary URL Binary))) + +(def: (http cache) + (-> Cache (http.Client IO)) + (implementation + (def: (request method url headers input) + (do io.monad + [_ (: (IO Any) + (case [method input] + [#@http.Put (#.Some input)] + (atom.update (dictionary.put url input) cache) + + _ + (wrap [])))] + (wrap (#try.Success ..good_upload)))))) + +(def: (verify_one expected_deployments address package cache expected_artifact actual_artifact) + (-> Nat URL Package (Dictionary URL Binary) Artifact Artifact Bit) + (let [url (: (-> URI URL) + (|>> (format address))) + library_url (url (format (artifact.uri (get@ #artifact.version expected_artifact) + expected_artifact) + artifact/extension.lux_library)) + pom_url (url (format (artifact.uri (get@ #artifact.version expected_artifact) + expected_artifact) + artifact/extension.pom)) + artifact_metadata_url (url (metadata.remote_artifact_uri expected_artifact)) + project_metadata_url (url (metadata.remote_project_uri expected_artifact)) + + expected_library (|> package + (get@ #package.library) + product.left) + expected_pom (|> package + (get@ #package.pom) + product.right + product.left) + + correct_artifact! + (artifact\= expected_artifact actual_artifact) + + expected_number_of_uploads! + (n.= (n.* expected_deployments 8) + (dictionary.size cache)) + + correct_library_upload! + (and (|> cache + (dictionary.get library_url) + (maybe\map (binary\= expected_library)) + (maybe.default false)) + (dictionary.key? cache (format library_url artifact/extension.sha-1)) + (dictionary.key? cache (format library_url artifact/extension.md5))) + + correct_pom_upload! + (and (|> cache + (dictionary.get pom_url) + (maybe\map (binary\= expected_pom)) + (maybe.default false)) + (dictionary.key? cache (format pom_url artifact/extension.sha-1)) + (dictionary.key? cache (format pom_url artifact/extension.md5))) + + artifact_metadata_upload! + (dictionary.key? cache artifact_metadata_url) + + project_metadata_upload! + (dictionary.key? cache project_metadata_url)] + (and correct_artifact! + expected_number_of_uploads! + correct_library_upload! + correct_pom_upload! + artifact_metadata_upload! + project_metadata_upload!))) + +(def: bundle + (Random [Dependency Artifact Package]) + (do random.monad + [[profile package] $///package.random + #let [artifact (|> profile + (get@ #profile.identity) + maybe.assume) + dependency (: Dependency + [artifact + artifact/type.lux_library])]] + (wrap [dependency artifact package]))) + +(def: #export test + Test + (<| (_.covering /._) + (do {! random.monad} + [address (\ ! map (text.suffix uri.separator) + (random.ascii/upper 10))] + ($_ _.and + (do {! random.monad} + [[dependency expected_artifact package] ..bundle + #let [cache (: Cache + (atom.atom (dictionary.new text.hash))) + http (..http cache) + repository (repository.async (remote.repository http #.None address))]] + (wrap (do promise.monad + [?outcome (/.one repository dependency package) + cache (promise.future (atom.read cache))] + (_.cover' [/.one] + (|> ?outcome + (try\map (verify_one 1 address package cache expected_artifact)) + (try.default false)))))) + (do {! random.monad} + [#let [hash (: (Hash [Dependency Artifact Package]) + (\ hash.functor map (|>> product.right product.left product.left) + text.hash))] + num_bundles (\ ! map (n.% 10) random.nat) + bundles (|> ..bundle + (random.set hash num_bundles) + (\ ! map set.to_list)) + #let [resolution (list\fold (function (_ [dependency expected_artifact package] resolution) + (dictionary.put dependency package resolution)) + resolution.empty + bundles) + cache (: Cache + (atom.atom (dictionary.new text.hash))) + http (..http cache) + repository (repository.async (remote.repository http #.None address))]] + (wrap (do promise.monad + [?outcome (/.all repository resolution) + cache (promise.future (atom.read cache))] + (_.cover' [/.all] + (|> ?outcome + (try\map (function (_ actual_artifacts) + (let [expected_deployments! + (n.= num_bundles (set.size actual_artifacts)) + + every_deployment_was_correct! + (list.every? (function (_ [dependency expected_artifact package]) + (let [deployed! + (set.member? actual_artifacts expected_artifact) + + deployed_correctly! + (verify_one num_bundles address package cache expected_artifact expected_artifact)] + (and deployed! + deployed_correctly!))) + bundles)] + (and expected_deployments! + every_deployment_was_correct!)))) + (try.default false)))))) + )))) diff --git a/stdlib/source/test/aedifex/dependency/resolution.lux b/stdlib/source/test/aedifex/dependency/resolution.lux index ebb32b790..7dcf46d3a 100644 --- a/stdlib/source/test/aedifex/dependency/resolution.lux +++ b/stdlib/source/test/aedifex/dependency/resolution.lux @@ -43,7 +43,7 @@ ["#." artifact (#+ Artifact) ["#/." type] ["#/." extension]] - ["#." repository (#+ Simulation) + ["#." repository (#+ Mock) ["#/." origin]]]]}) (def: random @@ -56,43 +56,7 @@ package /.empty)))) -(def: #export (single artifact package) - (-> Artifact Package (Simulation Any)) - (let [expected (///artifact.uri (get@ #///artifact.version artifact) artifact)] - (implementation - (def: (on_download uri state) - (if (text.contains? expected uri) - (cond (text.ends_with? ///artifact/extension.lux_library uri) - (#try.Success [state (|> package - (get@ #///package.library) - product.left)]) - - (text.ends_with? ///artifact/extension.pom uri) - (#try.Success [state (|> package - (get@ #///package.pom) - product.left - (\ xml.codec encode) - (\ utf8.codec encode))]) - - ## (text.ends_with? ///artifact/extension.sha-1 uri) - ## (#try.Success [state (|> package - ## (get@ #///package.sha-1) - ## (\ ///hash.sha-1_codec encode) - ## (\ utf8.codec encode))]) - - ## (text.ends_with? ///artifact/extension.md5 uri) - ## (#try.Success [state (|> package - ## (get@ #///package.md5) - ## (\ ///hash.md5_codec encode) - ## (\ utf8.codec encode))]) - - ## else - (#try.Failure "NOPE")) - (#try.Failure "NOPE"))) - (def: (on_upload uri binary state) - (#try.Failure "NOPE"))))) - -(def: lux_sha1 +(def: lux_sha-1 Text (format ///artifact/extension.lux_library ///artifact/extension.sha-1)) @@ -100,7 +64,7 @@ Text (format ///artifact/extension.lux_library ///artifact/extension.md5)) -(def: pom_sha1 +(def: pom_sha-1 Text (format ///artifact/extension.pom ///artifact/extension.sha-1)) @@ -108,7 +72,7 @@ Text (format ///artifact/extension.pom ///artifact/extension.md5)) -(def: sha1 +(def: sha-1 (-> Binary Binary) (|>> ///hash.sha-1 (\ ///hash.sha-1_codec encode) @@ -120,8 +84,48 @@ (\ ///hash.md5_codec encode) (\ utf8.codec encode))) +(def: #export (single artifact package) + (-> Artifact Package (Mock Any)) + (let [expected (///artifact.uri (get@ #///artifact.version artifact) artifact)] + (implementation + (def: (on_download uri state) + (if (text.contains? expected uri) + (let [library (: Binary + (|> package + (get@ #///package.library) + product.left)) + pom (: Binary + (|> package + (get@ #///package.pom) + product.left + (\ xml.codec encode) + (\ utf8.codec encode)))] + (cond (text.ends_with? ///artifact/extension.lux_library uri) + (#try.Success [state library]) + + (text.ends_with? ..lux_sha-1 uri) + (#try.Success [state (..sha-1 library)]) + + (text.ends_with? ..lux_md5 uri) + (#try.Success [state (..md5 library)]) + + (text.ends_with? ///artifact/extension.pom uri) + (#try.Success [state pom]) + + (text.ends_with? ..pom_sha-1 uri) + (#try.Success [state (..sha-1 pom)]) + + (text.ends_with? ..pom_md5 uri) + (#try.Success [state (..md5 pom)]) + + ## else + (#try.Failure "NOPE"))) + (#try.Failure "NOPE"))) + (def: (on_upload uri binary state) + (#try.Failure "NOPE"))))) + (def: (bad_sha-1 expected_artifact expected_package dummy_package) - (-> Artifact Package Package (Simulation Any)) + (-> Artifact Package Package (Mock Any)) (implementation (def: (on_download uri state) (if (text.contains? (///artifact.uri (get@ #///artifact.version expected_artifact) expected_artifact) uri) @@ -130,17 +134,17 @@ (get@ #///package.library) product.left)]) - (text.ends_with? lux_sha1 uri) + (text.ends_with? ..lux_sha-1 uri) (#try.Success [state (|> expected_package (get@ #///package.library) product.left - sha1)]) + ..sha-1)]) - (text.ends_with? lux_md5 uri) + (text.ends_with? ..lux_md5 uri) (#try.Success [state (|> expected_package (get@ #///package.library) product.left - md5)]) + ..md5)]) (text.ends_with? ///artifact/extension.pom uri) (#try.Success [state (|> expected_package @@ -149,21 +153,21 @@ (\ xml.codec encode) (\ utf8.codec encode))]) - (text.ends_with? pom_sha1 uri) + (text.ends_with? ..pom_sha-1 uri) (#try.Success [state (|> dummy_package (get@ #///package.pom) product.left (\ xml.codec encode) (\ utf8.codec encode) - sha1)]) + ..sha-1)]) - (text.ends_with? pom_md5 uri) + (text.ends_with? ..pom_md5 uri) (#try.Success [state (|> expected_package (get@ #///package.pom) product.left (\ xml.codec encode) (\ utf8.codec encode) - md5)]) + ..md5)]) ## else (#try.Failure "NOPE")) @@ -172,7 +176,7 @@ (#try.Failure "NOPE")))) (def: (bad_md5 expected_artifact expected_package dummy_package) - (-> Artifact Package Package (Simulation Any)) + (-> Artifact Package Package (Mock Any)) (implementation (def: (on_download uri state) (if (text.contains? (///artifact.uri (get@ #///artifact.version expected_artifact) expected_artifact) uri) @@ -181,17 +185,17 @@ (get@ #///package.library) product.left)]) - (text.ends_with? lux_sha1 uri) + (text.ends_with? ..lux_sha-1 uri) (#try.Success [state (|> expected_package (get@ #///package.library) product.left - sha1)]) + ..sha-1)]) - (text.ends_with? lux_md5 uri) + (text.ends_with? ..lux_md5 uri) (#try.Success [state (|> dummy_package (get@ #///package.library) product.left - md5)]) + ..md5)]) (text.ends_with? ///artifact/extension.pom uri) (#try.Success [state (|> expected_package @@ -200,21 +204,21 @@ (\ xml.codec encode) (\ utf8.codec encode))]) - (text.ends_with? pom_sha1 uri) + (text.ends_with? ..pom_sha-1 uri) (#try.Success [state (|> expected_package (get@ #///package.pom) product.left (\ xml.codec encode) (\ utf8.codec encode) - sha1)]) + ..sha-1)]) - (text.ends_with? pom_md5 uri) + (text.ends_with? ..pom_md5 uri) (#try.Success [state (|> dummy_package (get@ #///package.pom) product.left (\ xml.codec encode) (\ utf8.codec encode) - md5)]) + ..md5)]) ## else (#try.Failure "NOPE")) diff --git a/stdlib/source/test/aedifex/input.lux b/stdlib/source/test/aedifex/input.lux index 86771cf1f..0241b27a9 100644 --- a/stdlib/source/test/aedifex/input.lux +++ b/stdlib/source/test/aedifex/input.lux @@ -6,9 +6,7 @@ [control ["." try (#+ Try)] [concurrency - ["." promise (#+ Promise)]] - [security - ["!" capability]]] + ["." promise (#+ Promise)]]] [data ["." binary] ["." text @@ -58,7 +56,7 @@ //format.profile %.code (\ utf8.codec encode) - (!.use (\ file over_write))) + (\ file over_write)) actual (: (Promise (Try Profile)) (/.read promise.monad fs //.default))] (wrap (\ //.equivalence = diff --git a/stdlib/source/test/aedifex/package.lux b/stdlib/source/test/aedifex/package.lux index 132c51b38..56daf3cad 100644 --- a/stdlib/source/test/aedifex/package.lux +++ b/stdlib/source/test/aedifex/package.lux @@ -26,15 +26,16 @@ [world ["." file]]] [// - ["@." profile] + ["$." profile] [// [lux [data - ["_." binary]]]]] + ["$." binary]]]]] {#program ["." / ["/#" // #_ ["#" profile] + ["#." hash ("#\." equivalence)] ["#." pom] [dependency ["#." status]] @@ -45,13 +46,13 @@ (Random [//.Profile /.Package]) (do {! random.monad} [content_size (\ ! map (n.% 100) random.nat) - content (_binary.random content_size) + content ($binary.random content_size) [profile pom] (random.one (function (_ profile) (try.to_maybe (do try.monad [pom (//pom.write profile)] (wrap [profile pom])))) - @profile.random)] + $profile.random)] (wrap [profile (/.local pom content)]))) (def: #export test @@ -79,19 +80,31 @@ (and (case (get@ #/.origin local) (#//origin.Local "") true _ false) - (and (is? expected_library actual_library) - (case library_status - #//status.Unverified true - _ false)) - (and (is? expected_pom actual_pom) - (|> (do try.monad - [xml_pom (\ utf8.codec decode binary_pom) - decoded_pom (\ xml.codec decode xml_pom)] - (wrap (\ xml.equivalence = actual_pom decoded_pom))) - (try.default false)) - (case pom_status - #//status.Unverified true - _ false))))) + (let [expected_sha1 (//hash.sha-1 expected_library) + expected_md5 (//hash.md5 expected_library)] + (and (is? expected_library actual_library) + (case library_status + (#//status.Verified actual_sha1 expected_md5) + (and (//hash\= expected_sha1 actual_sha1) + (//hash\= expected_md5 expected_md5)) + + _ + false))) + (let [expected_sha1 (//hash.sha-1 binary_pom) + expected_md5 (//hash.md5 binary_pom)] + (and (is? expected_pom actual_pom) + (|> (do try.monad + [xml_pom (\ utf8.codec decode binary_pom) + decoded_pom (\ xml.codec decode xml_pom)] + (wrap (\ xml.equivalence = actual_pom decoded_pom))) + (try.default false)) + (case pom_status + (#//status.Verified actual_sha1 expected_md5) + (and (//hash\= expected_sha1 actual_sha1) + (//hash\= expected_md5 expected_md5)) + + _ + false)))))) (_.cover [/.dependencies] (let [expected (get@ #//.dependencies profile)] (case (/.dependencies package) diff --git a/stdlib/source/test/aedifex/repository.lux b/stdlib/source/test/aedifex/repository.lux index ed32f0ac3..98d869b5b 100644 --- a/stdlib/source/test/aedifex/repository.lux +++ b/stdlib/source/test/aedifex/repository.lux @@ -24,13 +24,14 @@ ["." / #_ ["#." identity] ["#." origin] + ["#." remote] [// ["@." artifact]]] {#spec ["$." /]} {#program ["." / - ["#." remote] + ["." remote] ["/#" // #_ ["#." artifact (#+ Version Artifact) ["#/." extension (#+ Extension)]]]]}) @@ -62,8 +63,8 @@ Version "4.5.6-NO") -(implementation: #export simulation - (/.Simulation Store) +(implementation: #export mock + (/.Mock Store) (def: (on_download uri state) (case (dictionary.get uri state) @@ -83,18 +84,19 @@ Test (<| (_.covering /._) ($_ _.and - (_.for [/.mock /.Simulation] + (_.for [/.mock /.Mock] (do random.monad [_ (wrap [])] ($/.spec (..artifact ..valid_version) (..artifact ..invalid_version) - (/.mock ..simulation + (/.mock ..mock (|> ..empty - (dictionary.put (/remote.uri ..invalid_version - (..artifact ..invalid_version) - //artifact/extension.lux_library) + (dictionary.put (remote.uri ..invalid_version + (..artifact ..invalid_version) + //artifact/extension.lux_library) (binary.create 0))))))) /identity.test /origin.test + /remote.test ))) diff --git a/stdlib/source/test/aedifex/repository/remote.lux b/stdlib/source/test/aedifex/repository/remote.lux new file mode 100644 index 000000000..f488391ce --- /dev/null +++ b/stdlib/source/test/aedifex/repository/remote.lux @@ -0,0 +1,130 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] + [control + ["." io (#+ IO)] + ["." try ("#\." monad)] + ["." exception] + ["." function]] + [data + ["." binary ("#\." equivalence)] + ["." maybe ("#\." functor)] + ["." text ("#\." equivalence) + ["%" format (#+ format)] + [encoding + ["." utf8]]] + [collection + ["." dictionary]]] + [math + ["." random (#+ Random)]] + [world + [net (#+ URL) + ["." http #_ + ["#" client] + ["#/." status] + ["@#" /]]]]] + {#program + ["." / + ["/#" // #_ + ["#." identity]]]}) + +(def: (url_body url) + (-> URL (@http.Body IO)) + (let [url (\ utf8.codec encode url)] + (function (_ _) + (io.io (#try.Success [(binary.size url) url]))))) + +(def: (good_http user password) + (-> //identity.User //identity.Password (http.Client IO)) + (implementation + (def: (request method url headers input) + (with_expansions [ [http/status.bad_request + {#@http.headers (http.headers (list)) + #@http.body (..url_body "")}]] + (<| io.io + #try.Success + (if (|> headers + (dictionary.get "User-Agent") + (maybe\map (is? /.user_agent)) + (maybe.default false)) + (case [method input] + [#@http.Get #.None] + [http/status.ok + {#@http.headers (http.headers (list)) + #@http.body (..url_body url)}] + + [#@http.Put (#.Some input)] + (if (|> headers + (dictionary.get "Authorization") + (maybe\map (text\= (//identity.basic_auth user password))) + (maybe.default false)) + [http/status.created + {#@http.headers (http.headers (list)) + #@http.body (..url_body url)}] + ) + + _ + ) + )))))) + +(def: bad_http + (http.Client IO) + (implementation + (def: (request method url headers input) + (<| io.io + #try.Success + [http/status.bad_request + {#@http.headers (http.headers (list)) + #@http.body (..url_body "")}])))) + +(def: #export test + Test + (<| (_.covering /._) + (do {! random.monad} + [address (random.ascii/upper 10) + uri (random.ascii/lower 10) + + user (random.ascii/lower 10) + password (random.ascii/lower 10) + + content (\ ! map (\ utf8.codec encode) + (random.ascii/lower 10))] + ($_ _.and + (_.cover [/.repository /.user_agent /.Address] + (let [repo (/.repository (..good_http user password) + (#.Some {#//identity.user user + #//identity.password password}) + address)] + (and (|> (\ repo download uri) + io.run + (try\map (\ utf8.codec decode)) + try\join + (try\map (text\= (format address uri))) + (try.default false)) + (|> (\ repo upload uri content) + io.run + (try\map (function.constant true)) + (try.default false))))) + (_.cover [/.upload_failure] + (let [repo (/.repository (..good_http user password) + #.None + address)] + (case (io.run (\ repo upload uri content)) + (#try.Failure error) + (exception.match? /.upload_failure error) + + (#try.Success _) + false))) + (_.cover [/.download_failure] + (let [repo (/.repository ..bad_http + #.None + address)] + (case (io.run (\ repo download uri)) + (#try.Failure error) + (exception.match? /.download_failure error) + + (#try.Success _) + false))) + )))) diff --git a/stdlib/source/test/lux/control/security/policy.lux b/stdlib/source/test/lux/control/security/policy.lux index c4c0657e7..ef0454553 100644 --- a/stdlib/source/test/lux/control/security/policy.lux +++ b/stdlib/source/test/lux/control/security/policy.lux @@ -9,9 +9,6 @@ ["$." functor (#+ Injection Comparison)] ["$." apply] ["$." monad]]}] - [control - [security - ["!" capability]]] [data ["." text ("#\." equivalence)]] [math @@ -24,14 +21,14 @@ (def: (injection can_conceal) (All [label] (-> (Can_Conceal label) (Injection (All [value] (Private value label))))) - (!.use can_conceal)) + 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)))) + (== (can_reveal left) + (can_reveal right)))) (type: Password (Private Text)) @@ -56,14 +53,14 @@ (def: &equivalence (implementation (def: (= reference sample) - (text\= (!.use %\can_downgrade reference) - (!.use %\can_downgrade sample))))) + (text\= (%\can_downgrade reference) + (%\can_downgrade sample))))) (def: hash - (|>> (!.use %\can_downgrade) + (|>> %\can_downgrade (\ text.hash hash))))) (def: password - (!.use %\can_upgrade)) + %\can_upgrade) (def: privilege privilege)))))) diff --git a/stdlib/source/test/lux/world.lux b/stdlib/source/test/lux/world.lux index 47e4ceb27..c5ea26a6f 100644 --- a/stdlib/source/test/lux/world.lux +++ b/stdlib/source/test/lux/world.lux @@ -13,7 +13,8 @@ ["#/." resolution]]] ["#." net #_ ["#/." http #_ - ["#/." client]]]]) + ["#/." client] + ["#/." status]]]]) (def: #export test Test @@ -25,4 +26,5 @@ /input/keyboard.test /output/video/resolution.test /net/http/client.test + /net/http/status.test )) diff --git a/stdlib/source/test/lux/world/console.lux b/stdlib/source/test/lux/world/console.lux index 56e3902f0..b196199fc 100644 --- a/stdlib/source/test/lux/world/console.lux +++ b/stdlib/source/test/lux/world/console.lux @@ -6,9 +6,7 @@ [control ["." io] ["." try (#+ Try)] - ["." exception (#+ exception:)] - [security - ["!" capability]]] + ["." exception (#+ exception:)]] [data ["." text ("#\." equivalence) ["%" format (#+ format)]]] @@ -21,8 +19,8 @@ (exception: dead) -(def: simulation - (/.Simulation [Bit Text]) +(def: mock + (/.Mock [Bit Text]) (implementation (def: (on_read [dead? content]) (do try.monad @@ -53,16 +51,16 @@ Test (<| (_.covering /._) ($_ _.and - (_.for [/.async /.mock /.Simulation] - ($/.spec (io.io (/.async (/.mock ..simulation [false ""]))))) + (_.for [/.async /.mock /.Mock] + ($/.spec (io.io (/.async (/.mock ..mock [false ""]))))) (do random.monad [expected (random.ascii/alpha 10) - #let [console (/.mock ..simulation [false ""])]] + #let [console (/.mock ..mock [false ""])]] (_.cover [/.write_line] (io.run (do io.monad [?_ (/.write_line expected console) - ?actual (!.use (\ console read_line) [])] + ?actual (\ console read_line [])] (wrap (<| (try.default false) (do try.monad [_ ?_ diff --git a/stdlib/source/test/lux/world/file.lux b/stdlib/source/test/lux/world/file.lux index c7f546a1b..8a0c416be 100644 --- a/stdlib/source/test/lux/world/file.lux +++ b/stdlib/source/test/lux/world/file.lux @@ -7,9 +7,7 @@ ["." io (#+ IO)] ["." try (#+ Try)] [concurrency - ["." promise]] - [security - ["!" capability]]] + ["." promise]]] [data ["." binary (#+ Binary)] ["." text] @@ -72,7 +70,7 @@ (def: #export test Test - (<| (_.context (%.name (name_of /._))) + (<| (_.covering /._) (do {! random.monad} [file_size (|> random.nat (\ ! map (|>> (n.% 100) (n.max 10)))) dataL (_binary.random file_size) diff --git a/stdlib/source/test/lux/world/file/watch.lux b/stdlib/source/test/lux/world/file/watch.lux index c0873b41a..9c1b31811 100644 --- a/stdlib/source/test/lux/world/file/watch.lux +++ b/stdlib/source/test/lux/world/file/watch.lux @@ -8,9 +8,7 @@ ["." try] ["." exception] [concurrency - ["." promise]] - [security - ["!" capability]]] + ["." promise]]] [data ["." binary ("#\." equivalence)] ["." text ("#\." equivalence) @@ -106,12 +104,12 @@ data (_binary.random 10)] (wrap (do {! promise.monad} [verdict (do (try.with !) - [_ (!.use (\ fs create_directory) [directory]) + [_ (\ fs create_directory directory) _ (\ watcher start /.all directory) poll/0 (\ watcher poll []) #let [no_events_prior_to_creation! (list.empty? poll/0)] - file (!.use (\ fs create_file) [expected_path]) + file (\ fs create_file expected_path) poll/1 (\ watcher poll []) poll/1' (\ watcher poll []) #let [after_creation! @@ -126,7 +124,7 @@ false) (list.empty? poll/1'))] _ (promise.delay 1 (#try.Success "Delay to make sure the over_write time-stamp always changes.")) - _ (!.use (\ file over_write) data) + _ (\ file over_write data) poll/2 (\ watcher poll []) poll/2' (\ watcher poll []) #let [after_modification! @@ -140,7 +138,7 @@ _ false) (list.empty? poll/2'))] - _ (!.use (\ file delete) []) + _ (\ file delete []) poll/3 (\ watcher poll []) poll/3' (\ watcher poll []) #let [after_deletion! diff --git a/stdlib/source/test/lux/world/net/http/status.lux b/stdlib/source/test/lux/world/net/http/status.lux new file mode 100644 index 000000000..801dc1b43 --- /dev/null +++ b/stdlib/source/test/lux/world/net/http/status.lux @@ -0,0 +1,119 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [data + [collection + ["." list] + ["." set (#+ Set)]]] + [macro + ["." template]] + [math + [number + ["n" nat]]]] + {1 + ["." / + ["/#" //]]}) + +(with_expansions [ (as_is [informational + [/.continue + /.switching_protocols + /.processing + /.early_hints]] + [success + [/.ok + /.created + /.accepted + /.non_authoritative_information + /.no_content + /.reset_content + /.partial_content + /.multi_status + /.already_reported + /.im_used]] + [redirection + [/.multiple_choices + /.moved_permanently + /.found + /.see_other + /.not_modified + /.use_proxy + /.switch_proxy + /.temporary_redirect + /.permanent_redirect]] + [client + [/.bad_request + /.unauthorized + /.payment_required + /.forbidden + /.not_found + /.method_not_allowed + /.not_acceptable + /.proxy_authentication_required + /.request_timeout + /.conflict + /.gone + /.length_required + /.precondition_failed + /.payload_too_large + /.uri_too_long + /.unsupported_media_type + /.range_not_satisfiable + /.expectation_failed + /.im_a_teapot + /.misdirected_request + /.unprocessable_entity + /.locked + /.failed_dependency + /.upgrade_required + /.precondition_required + /.too_many_requests + /.request_header_fields_too_large + /.unavailable_for_legal_reasons]] + [server + [/.internal_server_error + /.not_implemented + /.bad_gateway + /.service_unavailable + /.gateway_timeout + /.http_version_not_supported + /.variant_also_negotiates + /.insufficient_storage + /.loop_detected + /.not_extended + /.network_authentication_required]])] + (def: all + (List //.Status) + (list.concat (`` (list (~~ (template [ ] + [((: (-> Any (List //.Status)) + (function (_ _) + (`` (list (~~ (template.splice )))))) + 123)] + + )))))) + + (def: unique + (Set //.Status) + (set.from_list n.hash ..all)) + + (def: verdict + (n.= (list.size ..all) + (set.size ..unique))) + + (template [ ] + [(def: + Test + (_.cover + ..verdict))] + + ) + + (def: #export test + Test + (<| (_.covering /._) + (`` ($_ _.and + (~~ (template [ ] + [] + + )) + )))) + ) diff --git a/stdlib/source/test/lux/world/shell.lux b/stdlib/source/test/lux/world/shell.lux index 334250a96..64fa47d28 100644 --- a/stdlib/source/test/lux/world/shell.lux +++ b/stdlib/source/test/lux/world/shell.lux @@ -1,7 +1,6 @@ (.module: [lux #* ["_" test (#+ Test)] - ["." debug] [abstract [monad (#+ do)]] [control @@ -10,8 +9,6 @@ ["." io (#+ IO)] [concurrency ["." promise (#+ Promise)]] - [security - ["!" capability]] [parser ["." environment (#+ Environment)]]] [data @@ -32,9 +29,9 @@ (exception: dead) -(def: (simulation [environment working_directory command arguments]) +(def: (mock [environment working_directory command arguments]) (-> [Environment Path /.Command (List /.Argument)] - (/.Simulation Bit)) + (/.Mock Bit)) (implementation (def: (on_read dead?) (if dead? @@ -66,40 +63,28 @@ (def: (io_shell command oops input destruction exit) (-> /.Command Text Text Text /.Exit (/.Shell IO)) (implementation - (def: execute - ((debug.private /.can_execute) - (function (_ [environment working_directory command arguments]) - (io.io - (#try.Success - (: (/.Process IO) - (implementation - (def: read - ((debug.private /.can_read) - (function (_ _) - (io.io (#try.Success command))))) - (def: error - ((debug.private /.can_read) - (function (_ _) - (io.io (#try.Success oops))))) - (def: write - ((debug.private /.can_write) - (function (_ message) - (io.io (#try.Failure message))))) - (def: destroy - ((debug.private /.can_destroy) - (function (_ _) - (io.io (#try.Failure destruction))))) - (def: await - ((debug.private /.can_wait) - (function (_ _) - (io.io (#try.Success exit)))))))))))))) + (def: (execute [environment working_directory command arguments]) + (<| io.io + #try.Success + (: (/.Process IO)) + (implementation + (def: (read _) + (io.io (#try.Success command))) + (def: (error _) + (io.io (#try.Success oops))) + (def: (write message) + (io.io (#try.Failure message))) + (def: (destroy _) + (io.io (#try.Failure destruction))) + (def: (await _) + (io.io (#try.Success exit)))))))) (def: #export test Test (<| (_.covering /._) ($_ _.and - (_.for [/.async /.mock /.Simulation] - ($/.spec (/.async (/.mock (|>> ..simulation #try.Success) + (_.for [/.async /.mock /.Mock] + ($/.spec (/.async (/.mock (|>> ..mock #try.Success) false)))) (_.cover [/.error] (not (i.= /.normal /.error))) @@ -112,11 +97,11 @@ #let [shell (/.async (..io_shell command oops input destruction exit))]] (wrap (do {! promise.monad} [verdict (do (try.with !) - [process (!.use (\ shell execute) [environment.empty "~" command (list)]) - read (!.use (\ process read) []) - error (!.use (\ process error) []) + [process (\ shell execute [environment.empty "~" command (list)]) + read (\ process read []) + error (\ process error []) wrote! (do ! - [write (!.use (\ process write) [input])] + [write (\ process write input)] (wrap (#try.Success (case write (#try.Success _) false @@ -124,19 +109,19 @@ (#try.Failure write) (text\= input write))))) destroyed! (do ! - [destroy (!.use (\ process destroy) [])] + [destroy (\ process destroy [])] (wrap (#try.Success (case destroy (#try.Success _) false (#try.Failure destroy) (text\= destruction destroy))))) - await (!.use (\ process await) [])] + await (\ process await [])] (wrap (and (text\= command read) (text\= oops error) wrote! destroyed! (i.= exit await))))] - (_.cover' [/.Can_Write] + (_.cover' [/.Shell] (try.default false verdict))))) ))) -- cgit v1.2.3