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 +++++++++++++++++++++ 1 file changed, 203 insertions(+) create mode 100644 stdlib/source/test/aedifex/dependency/deployment.lux (limited to 'stdlib/source/test/aedifex/dependency/deployment.lux') 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)))))) + )))) -- cgit v1.2.3