More optimizations to the Lux syntax parser.

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])))))
   )