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.--- .../source/test/aedifex/dependency/deployment.lux | 203 +++++++++++++++++++++ .../source/test/aedifex/dependency/resolution.lux | 120 ++++++------ 2 files changed, 265 insertions(+), 58 deletions(-) create mode 100644 stdlib/source/test/aedifex/dependency/deployment.lux (limited to 'stdlib/source/test/aedifex/dependency') 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")) -- cgit v1.2.3