diff options
Diffstat (limited to 'stdlib/source/program/aedifex')
| -rw-r--r-- | stdlib/source/program/aedifex/artifact.lux | 16 | ||||
| -rw-r--r-- | stdlib/source/program/aedifex/command/deploy.lux | 118 | ||||
| -rw-r--r-- | stdlib/source/program/aedifex/dependency/resolution.lux | 6 | ||||
| -rw-r--r-- | stdlib/source/program/aedifex/metadata.lux | 12 | ||||
| -rw-r--r-- | stdlib/source/program/aedifex/metadata/artifact.lux | 17 | ||||
| -rw-r--r-- | stdlib/source/program/aedifex/metadata/snapshot.lux | 12 | ||||
| -rw-r--r-- | stdlib/source/program/aedifex/repository.lux | 104 |
7 files changed, 197 insertions, 88 deletions
diff --git a/stdlib/source/program/aedifex/artifact.lux b/stdlib/source/program/aedifex/artifact.lux index a26e70e50..e4fe812f1 100644 --- a/stdlib/source/program/aedifex/artifact.lux +++ b/stdlib/source/program/aedifex/artifact.lux @@ -2,8 +2,9 @@ [lux (#- Name) [abstract [equivalence (#+ Equivalence)] - ["." hash (#+ Hash)]] + [hash (#+ Hash)]] [data + ["." product] ["." text ["%" format (#+ Format)]] [collection @@ -29,7 +30,7 @@ (def: #export hash (Hash Artifact) - ($_ hash.product + ($_ product.hash text.hash text.hash text.hash @@ -61,12 +62,15 @@ ..identity-separator (..identity value))) +(def: #export (directory separator group) + (-> Text Group Text) + (|> group + (text.split-all-with ..group-separator) + (text.join-with separator))) + (def: (address separator artifact) (-> Text Artifact Text) - (let [directory (%.format (|> artifact - (get@ #group) - (text.split-all-with ..group-separator) - (text.join-with separator)) + (let [directory (%.format (..directory separator (get@ #group artifact)) separator (get@ #name artifact) separator diff --git a/stdlib/source/program/aedifex/command/deploy.lux b/stdlib/source/program/aedifex/command/deploy.lux index dbe4a88cb..4e33b145a 100644 --- a/stdlib/source/program/aedifex/command/deploy.lux +++ b/stdlib/source/program/aedifex/command/deploy.lux @@ -3,11 +3,16 @@ [abstract [monad (#+ do)]] [control + [pipe (#+ do>)] + ["." try (#+ Try)] [concurrency - ["." promise (#+ Promise) ("#\." monad)]]] + ["." promise (#+ Promise) ("#\." monad)]] + ["<>" parser + ["<.>" xml]]] [data [binary (#+ Binary)] [text + ["%" format (#+ format)] ["." encoding]] [collection ["." set]] @@ -15,6 +20,8 @@ ["." binary] ["." tar] ["." xml]]] + [time + ["." instant (#+ Instant)]] [world ["." file] ["." console (#+ Console)]]] @@ -24,28 +31,107 @@ ["." // #_ ["#." clean] ["/#" // #_ - [repository (#+ Identity Repository)] [command (#+ Command)] ["/" profile] ["#." action (#+ Action)] ["#." pom] ["#." hash] + ["#." repository (#+ Identity Repository)] + ["#." metadata + ["#/." artifact] + ["#/." snapshot]] ["#." artifact (#+ Artifact) - ["#/." extension (#+ Extension)]]]]) + ["#/." extension (#+ Extension)] + ["#/." type]]]]) + +(def: epoch + Instant + (instant.from-millis +0)) + +(template [<name> <type> <uri> <parser> <default>] + [(def: (<name> repository artifact) + (-> (Repository Promise) Artifact (Promise (Try <type>))) + (do promise.monad + [project (\ repository download (<uri> artifact))] + (case project + (#try.Success project) + (wrap (|> project + (do> try.monad + [(\ encoding.utf8 decode)] + [(\ xml.codec decode)] + [(<xml>.run <parser>)]))) + + (#try.Failure error) + (wrap (#try.Success <default>)))))] + + [read-project-metadata ///metadata/artifact.Metadata ///metadata.project ///metadata/artifact.parser + (let [(^slots [#///artifact.group #///artifact.name #///artifact.version]) artifact] + {#///metadata/artifact.group group + #///metadata/artifact.name name + #///metadata/artifact.versions (list) + #///metadata/artifact.last-updated ..epoch})] + [read-version-metadata ///metadata/snapshot.Metadata ///metadata.version ///metadata/snapshot.parser + (let [(^slots [#///artifact.group #///artifact.name #///artifact.version]) artifact] + {#///metadata/snapshot.group group + #///metadata/snapshot.name name + #///metadata/snapshot.version version + #///metadata/snapshot.versioning {#///metadata/snapshot.time-stamp ..epoch + #///metadata/snapshot.build 0 + #///metadata/snapshot.snapshot (list)}})] + ) + +(def: snapshot-artifacts + (List ///artifact/type.Type) + (list ///artifact/type.pom + (format ///artifact/type.pom ///artifact/extension.sha-1) + (format ///artifact/type.pom ///artifact/extension.md5) + ///artifact/type.lux-library + (format ///artifact/type.lux-library ///artifact/extension.sha-1) + (format ///artifact/type.lux-library ///artifact/extension.md5))) (def: #export (do! console repository fs identity artifact profile) (-> (Console Promise) (Repository Promise) (file.System Promise) Identity Artifact (Command Any)) (let [deploy! (: (-> Extension Binary (Action Any)) - (\ repository upload identity artifact))] - (do {! ///action.monad} - [library (|> profile - (get@ #/.sources) - set.to-list - (export.library fs) - (\ ! map (binary.run tar.writer))) - pom (promise\wrap (///pom.write profile)) - _ (deploy! ///artifact/extension.pom (|> pom (\ xml.codec encode) encoding.to-utf8)) - _ (deploy! ///artifact/extension.lux-library library) - _ (deploy! ///artifact/extension.sha-1 (///hash.data (///hash.sha-1 library))) - _ (deploy! ///artifact/extension.md5 (///hash.data (///hash.md5 library)))] - (console.write-line //clean.success console)))) + (|>> (///repository.uri artifact) + (\ repository upload identity))) + fully-deploy! (: (-> Extension Binary (Action Any)) + (function (_ extension payload) + (do ///action.monad + [_ (deploy! extension payload) + _ (deploy! (format extension ///artifact/extension.sha-1) + (///hash.data (///hash.sha-1 payload))) + _ (deploy! (format extension ///artifact/extension.md5) + (///hash.data (///hash.md5 payload)))] + (wrap [])))) + (^slots [#///artifact.group #///artifact.name #///artifact.version]) artifact] + (do promise.monad + [now (promise.future instant.now)] + (do {! ///action.monad} + [project (..read-project-metadata repository artifact) + snapshot (..read-version-metadata repository artifact) + pom (\ ! map (|>> (\ xml.codec encode) (\ encoding.utf8 encode)) + (promise\wrap (///pom.write profile))) + library (|> profile + (get@ #/.sources) + set.to-list + (export.library fs) + (\ ! map (binary.run tar.writer))) + + _ (fully-deploy! ///artifact/extension.pom pom) + _ (fully-deploy! ///artifact/extension.lux-library library) + _ (|> snapshot + (set@ [#///metadata/snapshot.versioning #///metadata/snapshot.time-stamp] now) + (update@ [#///metadata/snapshot.versioning #///metadata/snapshot.build] inc) + (set@ [#///metadata/snapshot.versioning #///metadata/snapshot.snapshot] ..snapshot-artifacts) + ///metadata/snapshot.write + (\ xml.codec encode) + (\ encoding.utf8 encode) + (\ repository upload identity (///metadata.version artifact))) + _ (|> project + (set@ #///metadata/artifact.versions (list version)) + (set@ #///metadata/artifact.last-updated now) + ///metadata/artifact.write + (\ xml.codec encode) + (\ encoding.utf8 encode) + (\ repository upload identity (///metadata.project artifact)))] + (console.write-line //clean.success console))))) diff --git a/stdlib/source/program/aedifex/dependency/resolution.lux b/stdlib/source/program/aedifex/dependency/resolution.lux index e8b0f2dba..2131495b9 100644 --- a/stdlib/source/program/aedifex/dependency/resolution.lux +++ b/stdlib/source/program/aedifex/dependency/resolution.lux @@ -58,7 +58,7 @@ (Exception [Dependency Text]) (Promise (Try (///hash.Hash h))))) (do (try.with promise.monad) - [actual (\ repository download artifact extension)] + [actual (\ repository download (///repository.uri artifact extension))] (\ promise.monad wrap (do try.monad [output (\ encoding.utf8 decode actual) @@ -72,14 +72,14 @@ (let [[artifact type] dependency extension (///artifact/extension.extension type)] (do (try.with promise.monad) - [library (\ repository download artifact extension) + [library (\ repository download (///repository.uri artifact extension)) sha-1 (..verified-hash dependency library repository artifact ///artifact/extension.sha-1 ///hash.sha-1 ///hash.sha-1-codec ..sha-1-does-not-match) md5 (..verified-hash dependency library repository artifact ///artifact/extension.md5 ///hash.md5 ///hash.md5-codec ..md5-does-not-match) - pom (\ repository download artifact ///artifact/extension.pom)] + pom (\ repository download (///repository.uri artifact ///artifact/extension.pom))] (\ promise.monad wrap (do try.monad [pom (\ encoding.utf8 decode pom) diff --git a/stdlib/source/program/aedifex/metadata.lux b/stdlib/source/program/aedifex/metadata.lux index 937fea4a3..11a792528 100644 --- a/stdlib/source/program/aedifex/metadata.lux +++ b/stdlib/source/program/aedifex/metadata.lux @@ -7,22 +7,22 @@ [file (#+ Path)] [net ["." uri (#+ URI)]]]] - ["." // + [// ["." artifact (#+ Artifact)]]) (def: #export file Path "maven-metadata.xml") -(def: (project separator artifact) +(def: (project' separator artifact) (-> Text Artifact Text) (format (artifact.directory separator (get@ #artifact.group artifact)) separator (get@ #artifact.name artifact))) -(def: (version separator artifact) +(def: (version' separator artifact) (-> Text Artifact Text) - (format (..project separator artifact) + (format (..project' separator artifact) separator (get@ #artifact.version artifact))) @@ -32,6 +32,6 @@ (let [/ uri.separator] (format (<private> / artifact) / ..file)))] - [for-project ..project] - [for-version ..version] + [project ..project'] + [version ..version'] ) diff --git a/stdlib/source/program/aedifex/metadata/artifact.lux b/stdlib/source/program/aedifex/metadata/artifact.lux index 1f8068111..aa7b9abce 100644 --- a/stdlib/source/program/aedifex/metadata/artifact.lux +++ b/stdlib/source/program/aedifex/metadata/artifact.lux @@ -61,6 +61,7 @@ [<group> "groupId"] [<name> "artifactId"] [<version> "version"] + [<versioning> "versioning"] [<versions> "versions"] [<last-updated> "lastUpdated"] [<metadata> "metadata"] @@ -87,8 +88,10 @@ xml.attributes (list (..write-group (get@ #group value)) (..write-name (get@ #name value)) - (..write-versions (get@ #versions value)) - (..write-last-updated (get@ #last-updated value))))) + (#xml.Node ..<versioning> + xml.attributes + (list (..write-versions (get@ #versions value)) + (..write-last-updated (get@ #last-updated value))))))) (def: (sub tag parser) (All [a] (-> xml.Tag (Parser a) (Parser a))) @@ -136,9 +139,13 @@ ($_ <>.and (<xml>.somewhere (..text ..<group>)) (<xml>.somewhere (..text ..<name>)) - (<xml>.somewhere (<| (..sub ..<versions>) - (<>.many (..text ..<version>)))) - (<xml>.somewhere ..last-updated-parser) + (<| (..sub ..<versioning>) + ($_ <>.and + (<| <xml>.somewhere + (..sub ..<versions>) + (<>.many (..text ..<version>))) + (<xml>.somewhere ..last-updated-parser) + )) ))) (def: #export equivalence diff --git a/stdlib/source/program/aedifex/metadata/snapshot.lux b/stdlib/source/program/aedifex/metadata/snapshot.lux index a94ac33c4..1919d06ca 100644 --- a/stdlib/source/program/aedifex/metadata/snapshot.lux +++ b/stdlib/source/program/aedifex/metadata/snapshot.lux @@ -212,7 +212,7 @@ (Parser Build) (<text>.embed (<>.codec n.decimal (<text>.many <text>.decimal)) - (..text ..<timestamp>))) + (..text ..<build-number>))) (exception: #export (time-stamp-mismatch {expected Time-Stamp} {actual Text}) (exception.report @@ -226,7 +226,7 @@ (def: (snapshot-parser expected) (-> Value (Parser Type)) - (<| (..sub ..<snapshot-versions>) + (<| (..sub ..<snapshot-version>) (do <>.monad [#let [[version time-stamp build] expected] updated (<xml>.somewhere (..text ..<updated>)) @@ -243,8 +243,8 @@ (do <>.monad [[time-stamp build] (<| <xml>.somewhere (..sub ..<snapshot>) - (<>.and ..time-stamp-parser - ..build-parser)) + (<>.and (<xml>.somewhere ..time-stamp-parser) + (<xml>.somewhere ..build-parser))) last-updated (<xml>.somewhere ..last-updated-parser) _ (<>.assert (exception.construct ..time-stamp-mismatch [time-stamp (instant-format last-updated)]) (\ instant.equivalence = time-stamp last-updated)) @@ -268,7 +268,7 @@ #version version #versioning versioning})))) -(def: versioning +(def: versioning-equivalence (Equivalence Versioning) ($_ product.equivalence instant.equivalence @@ -282,5 +282,5 @@ text.equivalence text.equivalence text.equivalence - ..versioning + ..versioning-equivalence )) diff --git a/stdlib/source/program/aedifex/repository.lux b/stdlib/source/program/aedifex/repository.lux index 7ec522a10..c351e9d0c 100644 --- a/stdlib/source/program/aedifex/repository.lux +++ b/stdlib/source/program/aedifex/repository.lux @@ -17,9 +17,15 @@ ["." encoding]] [number ["n" nat]]] + [tool + [compiler + ["." version] + ["." language #_ + ["#/." lux #_ + ["#" version]]]]] [world [net (#+ URL) - ["." uri]]]] + ["." uri (#+ URI)]]]] ["." // #_ ["#." artifact (#+ Artifact) ["#/." extension (#+ Extension)]]]) @@ -38,38 +44,36 @@ #password Password}) (signature: #export (Repository !) - (: (-> Artifact Extension (! (Try Binary))) + (: (-> URI (! (Try Binary))) download) - (: (-> Identity Artifact Extension Binary (! (Try Any))) + (: (-> Identity URI Binary (! (Try Any))) upload)) (def: #export (async repository) (-> (Repository IO) (Repository Promise)) (structure - (def: (download artifact extension) - (promise.future (\ repository download artifact extension))) + (def: (download uri) + (promise.future (\ repository download uri))) - (def: (upload identity artifact extension content) - (promise.future (\ repository upload identity artifact extension content))) + (def: (upload identity uri content) + (promise.future (\ repository upload identity uri content))) )) (signature: #export (Simulation s) - (: (-> Artifact Extension s - (Try [s Binary])) + (: (-> URI s (Try [s Binary])) on-download) - (: (-> Identity Artifact Extension Binary s - (Try s)) + (: (-> Identity URI Binary s (Try s)) on-upload)) (def: #export (mock simulation init) (All [s] (-> (Simulation s) s (Repository Promise))) (let [state (stm.var init)] (structure - (def: (download artifact extension) + (def: (download uri) (stm.commit (do {! stm.monad} [|state| (stm.read state)] - (case (\ simulation on-download artifact extension |state|) + (case (\ simulation on-download uri |state|) (#try.Success [|state| output]) (do ! [_ (stm.write |state| state)] @@ -78,11 +82,11 @@ (#try.Failure error) (wrap (#try.Failure error)))))) - (def: (upload identity artifact extension content) + (def: (upload identity uri content) (stm.commit (do {! stm.monad} [|state| (stm.read state)] - (case (\ simulation on-upload identity artifact extension content |state|) + (case (\ simulation on-upload identity uri content |state|) (#try.Success |state|) (do ! [_ (stm.write |state| state)] @@ -98,6 +102,8 @@ ["#::." (close [] #io #try void)]) +(import: java/io/InputStream) + (import: java/io/OutputStream ["#::." (flush [] #io #try void) @@ -107,6 +113,7 @@ ["#::." (setDoOutput [boolean] #io #try void) (setRequestProperty [java/lang/String java/lang/String] #io #try void) + (getInputStream [] #io #try java/io/InputStream) (getOutputStream [] #io #try java/io/OutputStream)]) (import: java/net/HttpURLConnection @@ -117,8 +124,7 @@ (import: java/net/URL ["#::." (new [java/lang/String]) - (openConnection [] #io #try java/net/URLConnection) - (openStream [] #io #try java/io/InputStream)]) + (openConnection [] #io #try java/net/URLConnection)]) (import: java/util/Base64$Encoder ["#::." @@ -128,8 +134,6 @@ ["#::." (#static getEncoder [] java/util/Base64$Encoder)]) -(import: java/io/InputStream) - (import: java/io/BufferedInputStream ["#::." (new [java/io/InputStream]) @@ -141,42 +145,50 @@ (def: (basic-auth user password) (-> User Password Text) - (format "Basic " (java/util/Base64$Encoder::encodeToString (encoding.to-utf8 (format user ":" password)) + (format "Basic " (java/util/Base64$Encoder::encodeToString (\ encoding.utf8 encode (format user ":" password)) (java/util/Base64::getEncoder)))) -(def: (url address artifact extension) - (-> Address Artifact Extension URL) - (format address uri.separator (//artifact.uri artifact) extension)) +(def: #export (uri artifact extension) + (-> Artifact Extension URI) + (format (//artifact.uri artifact) extension)) (def: buffer-size (n.* 512 1,024)) +(def: user-agent + (format "LuxAedifex/" (version.format language/lux.version))) + (structure: #export (remote address) (All [s] (-> Address (Repository IO))) - (def: (download artifact extension) - (let [url (..url address artifact extension)] - (do {! (try.with io.monad)} - [input (|> (java/net/URL::new url) - java/net/URL::openStream - (\ ! map (|>> java/io/BufferedInputStream::new))) - #let [buffer (binary.create ..buffer-size)]] - (loop [output (\ binary.monoid identity)] - (do ! - [bytes-read (java/io/BufferedInputStream::read buffer +0 (.int ..buffer-size) input)] - (case bytes-read - -1 (do ! - [_ (java/lang/AutoCloseable::close input)] - (wrap output)) - _ (if (n.= ..buffer-size bytes-read) - (recur (\ binary.monoid compose output buffer)) - (do ! - [chunk (\ io.monad wrap (binary.slice 0 (.nat bytes-read) buffer))] - (recur (\ binary.monoid compose output chunk)))))))))) - - (def: (upload [user password] artifact extension content) + (def: (download uri) + (do {! (try.with io.monad)} + [connection (|> (format address uri) + java/net/URL::new + java/net/URL::openConnection) + #let [connection (:coerce java/net/HttpURLConnection connection)] + _ (java/net/HttpURLConnection::setRequestMethod "GET" connection) + _ (java/net/URLConnection::setRequestProperty "User-Agent" ..user-agent connection) + input (|> connection + java/net/URLConnection::getInputStream + (\ ! map (|>> java/io/BufferedInputStream::new))) + #let [buffer (binary.create ..buffer-size)]] + (loop [output (\ binary.monoid identity)] + (do ! + [bytes-read (java/io/BufferedInputStream::read buffer +0 (.int ..buffer-size) input)] + (case bytes-read + -1 (do ! + [_ (java/lang/AutoCloseable::close input)] + (wrap output)) + _ (if (n.= ..buffer-size bytes-read) + (recur (\ binary.monoid compose output buffer)) + (do ! + [chunk (\ io.monad wrap (binary.slice 0 (.nat bytes-read) buffer))] + (recur (\ binary.monoid compose output chunk))))))))) + + (def: (upload [user password] uri content) (do (try.with io.monad) - [connection (|> (..url address artifact extension) + [connection (|> (format address uri) java/net/URL::new java/net/URL::openConnection) #let [connection (:coerce java/net/HttpURLConnection connection)] @@ -189,6 +201,6 @@ _ (java/lang/AutoCloseable::close stream) code (java/net/HttpURLConnection::getResponseCode connection)] (case code - +200 (wrap []) + +201 (wrap []) _ (\ io.monad wrap (exception.throw ..deployment-failure [code]))))) ) |