3 files changed, 468 insertions, 0 deletions
diff --git a/stdlib/source/lux/world/database/jdbc.jvm.lux b/stdlib/source/lux/world/database/jdbc.jvm.lux
new file mode 100644
index 000000000..23370dcc8
--- /dev/null
+++ b/stdlib/source/lux/world/database/jdbc.jvm.lux
@@ -0,0 +1,170 @@
+(.module:
+  [lux (#- and int)
+   [control
+    [functor (#+ Functor)]
+    [apply (#+ Apply)]
+    [monad (#+ Monad do)]
+    ["ex" exception]
+    [concurrency
+     ["." promise (#+ Promise) ("promise/." Monad<Promise>)]]
+    [security
+     [capability (#+ Capability)]]]
+   [data
+    ["." product]
+    ["." error (#+ Error)]
+    ["." number]
+    [text
+     format]
+    [collection
+     [list ("list/." Fold<List>)]]]
+   ["." io (#+ IO)]
+   [world
+    [net (#+ URL)]
+    [database
+     ["." sql]]]
+   [host (#+ import:)]]
+  [/
+   ["/." input (#+ Input)]
+   ["/." output (#+ Output)]])
+
+(import: #long java/sql/ResultSet
+  (getRow [] #try int)
+  (next [] #try boolean)
+  (close [] #io #try void))
+
+(import: #long java/sql/Statement
+  (#static NO_GENERATED_KEYS int)
+  (#static RETURN_GENERATED_KEYS int)
+  (getGeneratedKeys [] #try java/sql/ResultSet)
+  (close [] #io #try void))
+
+(import: #long java/sql/PreparedStatement
+  (executeUpdate [] #io #try int)
+  (executeQuery [] #io #try java/sql/ResultSet))
+
+(import: #long java/sql/Connection
+  (prepareStatement [String int] #try java/sql/PreparedStatement)
+  (isValid [int] #try boolean)
+  (close [] #io #try void))
+
+(import: #long java/sql/DriverManager
+  (#static getConnection [String String String] #io #try java/sql/Connection))
+
+(type: #export Credentials
+  {#url      URL
+   #user     Text
+   #password Text})
+
+(type: #export ID Int)
+
+(def: #export Equivalence<ID> number.Equivalence<Int>)
+
+(type: #export (Statement input)
+  {#sql sql.Statement
+   #input (Input input)
+   #value input})
+
+## DB
+(do-template [<name> <output>]
+  [(type: #export (<name> !)
+     (All [i]
+       (Capability (Statement i) (! (Error <output>)))))]
+
+  [Can-Execute Nat]
+  [Can-Insert  (List ID)]
+  )
+
+(type: #export (Can-Query !)
+  (All [i o]
+    (Capability [(Statement i) (Output o)] (! (Error (List o))))))
+
+(type: #export (Can-Close !)
+  (Capability Any (! (Error Any))))
+
+(signature: #export (DB !)
+  (: (Can-Execute !)
+     execute)
+  (: (Can-Insert !)
+     insert)
+  (: (Can-Query !)
+     query)
+  (: (Can-Close !)
+     close))
+
+(def: (with-statement statement conn action)
+  (All [i a]
+    (-> (Statement i) java/sql/Connection
+        (-> java/sql/PreparedStatement (IO (Error a)))
+        (IO (Error a))))
+  (do (error.ErrorT io.Monad<IO>)
+    [prepared (io.io (java/sql/Connection::prepareStatement (sql.sql (get@ #sql statement))
+                                                            (java/sql/Statement::RETURN_GENERATED_KEYS)
+                                                            conn))
+     _ (io.io ((get@ #input statement) (get@ #value statement) [1 prepared]))
+     result (action prepared)
+     _ (java/sql/Statement::close prepared)]
+    (wrap result)))
+
+(def: #export (async db)
+  (-> (DB IO) (DB Promise))
+  (`` (structure
+       (~~ (do-template [<name>]
+             [(def: <name> (|>> (:: db <name>) promise.future))]
+             
+             [execute] [insert] [close] [query])))))
+
+(def: #export (connect creds)
+  (-> Credentials (IO (Error (DB IO))))
+  (do (error.ErrorT io.Monad<IO>)
+    [connection (java/sql/DriverManager::getConnection (get@ #url creds)
+                                                       (get@ #user creds)
+                                                       (get@ #password creds))]
+    (wrap (: (DB IO)
+             (structure
+              (def: (execute statement)
+                (with-statement statement connection
+                  (function (_ prepared)
+                    (do (error.ErrorT io.Monad<IO>)
+                      [row-count (java/sql/PreparedStatement::executeUpdate prepared)]
+                      (wrap (.nat row-count))))))
+
+              (def: (insert statement)
+                (with-statement statement connection
+                  (function (_ prepared)
+                    (do (error.ErrorT io.Monad<IO>)
+                      [_ (java/sql/PreparedStatement::executeUpdate prepared)
+                       result-set (io.io (java/sql/Statement::getGeneratedKeys prepared))]
+                      (/output.rows /output.long result-set)))))
+
+              (def: (close _)
+                (java/sql/Connection::close connection))
+
+              (def: (query [statement output])
+                (with-statement statement connection
+                  (function (_ prepared)
+                    (do (error.ErrorT io.Monad<IO>)
+                      [result-set (java/sql/PreparedStatement::executeQuery prepared)]
+                      (/output.rows output result-set)))))
+              )))))
+
+(def: #export (with-db creds action)
+  (All [a]
+    (-> Credentials
+        (-> (DB IO) (IO (Error a)))
+        (IO (Error a))))
+  (do (error.ErrorT io.Monad<IO>)
+    [db (..connect creds)
+     result (action db)
+     _ (:: db close [])]
+    (wrap result)))
+
+(def: #export (with-async-db creds action)
+  (All [a]
+    (-> Credentials
+        (-> (DB Promise) (Promise (Error a)))
+        (Promise (Error a))))
+  (do (error.ErrorT promise.Monad<Promise>)
+    [db (promise.future (..connect creds))
+     result (action (..async db))
+     _ (promise/wrap (io.run (:: db close [])))]
+    (wrap result)))
diff --git a/stdlib/source/lux/world/database/jdbc/input.jvm.lux b/stdlib/source/lux/world/database/jdbc/input.jvm.lux
new file mode 100644
index 000000000..d037d4234
--- /dev/null
+++ b/stdlib/source/lux/world/database/jdbc/input.jvm.lux
@@ -0,0 +1,109 @@
+(.module:
+  [lux (#- and int)
+   [control
+    [functor (#+ Contravariant)]
+    [monad (#+ Monad do)]]
+   [data
+    ["." error (#+ Error)]
+    [collection
+     [list ("list/." Fold<List>)]]]
+   [time
+    ["." instant (#+ Instant)]]
+   ["." io (#+ IO)]
+   [world
+    [binary (#+ Binary)]]
+   [host (#+ import:)]])
+
+(import: #long java/lang/String)
+
+(do-template [<class>]
+  [(import: #long <class>
+     (new [long]))]
+
+  [java/sql/Date] [java/sql/Time] [java/sql/Timestamp]
+  )
+
+(`` (import: #long java/sql/PreparedStatement
+      (~~ (do-template [<name> <type>]
+            [(<name> [int <type>] #try void)]
+
+            [setBoolean boolean]
+
+            [setByte byte]
+            [setShort short]
+            [setInt int]
+            [setLong long]
+            
+            [setFloat float]
+            [setDouble double]
+
+            [setString java/lang/String]
+            [setBytes (Array byte)]
+
+            [setDate java/sql/Date]
+            [setTime java/sql/Time]
+            [setTimestamp java/sql/Timestamp]
+            ))))
+
+(type: #export (Input a)
+  (-> a [Nat java/sql/PreparedStatement]
+      (Error [Nat java/sql/PreparedStatement])))
+
+(structure: #export _ (Contravariant Input)
+  (def: (map-1 f fb)
+    (function (fa value circumstance)
+      (fb (f value) circumstance))))
+
+(def: #export (and pre post)
+  (All [l r] (-> (Input l) (Input r) (Input [l r])))
+  (function (_ [left right] context)
+    (do error.Monad<Error>
+      [context (pre left context)]
+      (post right context))))
+
+(def: #export (fail error)
+  (All [a] (-> Text (Input a)))
+  (function (_ value [idx context])
+    (#error.Failure error)))
+
+(def: #export empty
+  (Input Any)
+  (function (_ value context)
+    (#error.Success context)))
+
+(do-template [<function> <type> <setter>]
+  [(def: #export <function>
+     (Input <type>)
+     (function (_ value [idx statement])
+       (do error.Monad<Error>
+         [_ (<setter> (.int idx) value statement)]
+         (wrap [(.inc idx) statement]))))]
+
+  [boolean Bit java/sql/PreparedStatement::setBoolean]
+
+  [byte   Int    java/sql/PreparedStatement::setByte]
+  [short  Int    java/sql/PreparedStatement::setShort]
+  [int    Int    java/sql/PreparedStatement::setInt]
+  [long   Int    java/sql/PreparedStatement::setLong]
+
+  [float  Frac   java/sql/PreparedStatement::setFloat]
+  [double Frac   java/sql/PreparedStatement::setDouble]
+
+  [string Text   java/sql/PreparedStatement::setString]
+  [bytes  Binary java/sql/PreparedStatement::setBytes]
+  )
+
+(do-template [<function> <setter> <constructor>]
+  [(def: #export <function>
+     (Input Instant)
+     (function (_ value [idx statement])
+       (do error.Monad<Error>
+         [_ (<setter> (.int idx)
+                      (<constructor> (instant.to-millis value))
+                      statement)]
+         (wrap [(.inc idx) statement]))))]
+
+  [date       java/sql/PreparedStatement::setDate      java/sql/Date::new]
+  [time       java/sql/PreparedStatement::setTime      java/sql/Time::new]
+  [time-stamp java/sql/PreparedStatement::setTimestamp java/sql/Timestamp::new]
+  )
diff --git a/stdlib/source/lux/world/database/jdbc/output.jvm.lux b/stdlib/source/lux/world/database/jdbc/output.jvm.lux
new file mode 100644
index 000000000..a28a6254e
--- /dev/null
+++ b/stdlib/source/lux/world/database/jdbc/output.jvm.lux
@@ -0,0 +1,189 @@
+(.module:
+  [lux (#- and int)
+   [control
+    [functor (#+ Functor)]
+    [apply (#+ Apply)]
+    [monad (#+ Monad do)]
+    ["ex" exception]]
+   [data
+    ["." error (#+ Error)]]
+   [time
+    ["." instant (#+ Instant)]]
+   ["." io (#+ IO)]
+   [world
+    [binary (#+ Binary)]]
+   [host (#+ import:)]])
+
+(import: #long java/lang/String)
+
+(import: #long java/util/Date
+  (getTime [] long))
+
+(import: #long java/sql/Date)
+(import: #long java/sql/Time)
+(import: #long java/sql/Timestamp)
+
+(`` (import: #long java/sql/ResultSet
+      (~~ (do-template [<method-name> <return-class>]
+            [(<method-name> [int] #try <return-class>)]
+            
+            [getBoolean   boolean]
+            
+            [getByte      byte]
+            [getShort     short]
+            [getInt       int]
+            [getLong      long]
+
+            [getDouble    double]
+            [getFloat     float]
+
+            [getString    java/lang/String]
+            [getBytes     (Array byte)]
+            
+            [getDate      java/sql/Date]
+            [getTime      java/sql/Time]
+            [getTimestamp java/sql/Timestamp]
+            ))
+      (next [] #try boolean)
+      (close [] #io #try void)))
+
+(type: #export (Output a)
+  (-> [Nat java/sql/ResultSet] (Error [Nat a])))
+
+(structure: #export _ (Functor Output)
+  (def: (map f fa)
+    (function (_ idx+rs)
+      (case (fa idx+rs)
+        (#error.Failure error)
+        (#error.Failure error)
+        
+        (#error.Success [idx' value])
+        (#error.Success [idx' (f value)])))))
+
+(structure: #export _ (Apply Output)
+  (def: functor Functor<Output>)
+
+  (def: (apply ff fa)
+    (function (_ [idx rs])
+      (case (ff [idx rs])
+        (#error.Success [idx' f])
+        (case (fa [idx' rs])
+          (#error.Success [idx'' a])
+          (#error.Success [idx'' (f a)])
+
+          (#error.Failure msg)
+          (#error.Failure msg))
+
+        (#error.Failure msg)
+        (#error.Failure msg)))))
+
+(structure: #export _ (Monad Output)
+  (def: functor Functor<Output>)
+
+  (def: (wrap a)
+    (function (_ [idx rs])
+      (#.Some [idx a])))
+  
+  (def: (join mma)
+    (function (_ [idx rs])
+      (case (mma [idx rs])
+        (#error.Failure error)
+        (#error.Failure error)
+        
+        (#error.Success [idx' ma])
+        (ma [idx' rs])))))
+
+(def: #export (fail error)
+  (All [a] (-> Text (Output a)))
+  (function (_ [idx result-set])
+    (#error.Failure error)))
+
+(def: #export (and left right)
+  (All [a b]
+    (-> (Output a) (Output b) (Output [a b])))
+  (do Monad<Output>
+    [=left left
+     =right right]
+    (wrap [=left =right])))
+
+(do-template [<func-name> <method-name> <type>]
+  [(def: #export <func-name>
+     (Output <type>)
+     (function (_ [idx result-set])
+       (case (<method-name> [(.int idx)] result-set)
+         (#error.Failure error)
+         (#error.Failure error)
+
+         (#error.Success value)
+         (#error.Success [(inc idx) value]))))]
+
+  [boolean java/sql/ResultSet::getBoolean Bit]
+
+  [byte    java/sql/ResultSet::getByte    Int]
+  [short   java/sql/ResultSet::getShort   Int]
+  [int     java/sql/ResultSet::getInt     Int]
+  [long    java/sql/ResultSet::getLong    Int]
+
+  [float   java/sql/ResultSet::getFloat   Frac]
+  [double  java/sql/ResultSet::getDouble  Frac]
+
+  [string  java/sql/ResultSet::getString  Text]
+  [bytes   java/sql/ResultSet::getBytes   Binary]
+  )
+
+(do-template [<func-name> <method-name>]
+  [(def: #export <func-name>
+     (Output Instant)
+     (function (_ [idx result-set])
+       (case (<method-name> [(.int idx)] result-set)
+         (#error.Failure error)
+         (#error.Failure error)
+
+         (#error.Success value)
+         (#error.Success [(inc idx)
+                          (instant.from-millis (java/util/Date::getTime value))]))))]
+
+  [date       java/sql/ResultSet::getDate]
+  [time       java/sql/ResultSet::getTime]
+  [time-stamp java/sql/ResultSet::getTimestamp]
+  )
+
+(def: #export (rows output results)
+  (All [a] (-> (Output a) java/sql/ResultSet (IO (Error (List a)))))
+  (case (java/sql/ResultSet::next results)
+    (#error.Success has-next?)
+    (if has-next?
+      (case (output [1 results])
+        (#.Some [_ head])
+        (do io.Monad<IO>
+          [?tail (rows output results)]
+          (case ?tail
+            (#error.Success tail)
+            (wrap (ex.return (#.Cons head tail)))
+
+            (#error.Failure error)
+            (do io.Monad<IO>
+              [temp (java/sql/ResultSet::close results)]
+              (wrap (do error.Monad<Error>
+                      [_ temp]
+                      (error.fail error))))))
+
+        (#error.Failure error)
+        (do io.Monad<IO>
+          [temp (java/sql/ResultSet::close results)]
+          (wrap (do error.Monad<Error>
+                  [_ temp]
+                  (error.fail error)))))
+      (do io.Monad<IO>
+        [temp (java/sql/ResultSet::close results)]
+        (wrap (do error.Monad<Error>
+                [_ temp]
+                (wrap (list))))))
+
+    (#error.Failure error)
+    (do io.Monad<IO>
+      [temp (java/sql/ResultSet::close results)]
+      (wrap (do error.Monad<Error>
+              [_ temp]
+              (error.fail error))))
+    ))