diff options
Diffstat (limited to 'stdlib/source/library/lux/world')
29 files changed, 5007 insertions, 0 deletions
diff --git a/stdlib/source/library/lux/world/console.lux b/stdlib/source/library/lux/world/console.lux new file mode 100644 index 000000000..41652fdd7 --- /dev/null +++ b/stdlib/source/library/lux/world/console.lux @@ -0,0 +1,159 @@ +(.module: + [library + [lux #* + [ffi (#+ import:)] + ["@" target] + [abstract + [monad (#+ do)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)] + ["." io (#+ IO io)] + [concurrency + ["." promise (#+ Promise)] + ["." atom]]] + [data + ["." text (#+ Char) + ["%" format (#+ format)]]]]]) + +(template [<name>] + [(exception: #export (<name>) + "")] + + [cannot_open] + [cannot_close] + ) + +(interface: #export (Console !) + (: (-> [] (! (Try Char))) + read) + (: (-> [] (! (Try Text))) + read_line) + (: (-> Text (! (Try Any))) + write) + (: (-> [] (! (Try Any))) + close)) + +(def: #export (async console) + (-> (Console IO) (Console Promise)) + (`` (implementation + (~~ (template [<capability>] + [(def: <capability> + (|>> (\ console <capability>) promise.future))] + + [read] + [read_line] + [write] + [close]))))) + +(with_expansions [<jvm> (as_is (import: java/lang/String) + + (import: java/io/Console + ["#::." + (readLine [] #io #try java/lang/String)]) + + (import: java/io/InputStream + ["#::." + (read [] #io #try int)]) + + (import: java/io/PrintStream + ["#::." + (print [java/lang/String] #io #try void)]) + + (import: java/lang/System + ["#::." + (#static console [] #io #? java/io/Console) + (#static in java/io/InputStream) + (#static out java/io/PrintStream)]) + + (def: #export default + (IO (Try (Console IO))) + (do io.monad + [?jvm_console (java/lang/System::console)] + (case ?jvm_console + #.None + (wrap (exception.throw ..cannot_open [])) + + (#.Some jvm_console) + (let [jvm_input (java/lang/System::in) + jvm_output (java/lang/System::out)] + (<| wrap + exception.return + (: (Console IO)) ## TODO: Remove ASAP + (implementation + (def: (read _) + (|> jvm_input + java/io/InputStream::read + (\ (try.with io.monad) map .nat))) + + (def: (read_line _) + (java/io/Console::readLine jvm_console)) + + (def: (write message) + (java/io/PrintStream::print message jvm_output)) + + (def: close + (|>> (exception.throw ..cannot_close) wrap)))))))))] + (for {@.old (as_is <jvm>) + @.jvm (as_is <jvm>)} + (as_is))) + +(def: #export (write_line message console) + (All [!] (-> Text (Console !) (! (Try Any)))) + (\ console write (format message text.new_line))) + +(interface: #export (Mock s) + (: (-> s (Try [s Char])) + on_read) + (: (-> s (Try [s Text])) + on_read_line) + (: (-> Text s (Try s)) + on_write) + (: (-> s (Try s)) + on_close)) + +(def: #export (mock mock init) + (All [s] (-> (Mock s) s (Console IO))) + (let [state (atom.atom init)] + (`` (implementation + (~~ (template [<method> <mock>] + [(def: (<method> _) + (do {! io.monad} + [|state| (atom.read state)] + (case (\ mock <mock> |state|) + (#try.Success [|state| output]) + (do ! + [_ (atom.write |state| state)] + (wrap (#try.Success output))) + + (#try.Failure error) + (wrap (#try.Failure error)))))] + + [read on_read] + [read_line on_read_line] + )) + + (def: (write input) + (do {! io.monad} + [|state| (atom.read state)] + (case (\ mock on_write input |state|) + (#try.Success |state|) + (do ! + [_ (atom.write |state| state)] + (wrap (#try.Success []))) + + (#try.Failure error) + (wrap (#try.Failure error))))) + + (def: (close _) + (do {! io.monad} + [|state| (atom.read state)] + (case (\ mock on_close |state|) + (#try.Success |state|) + (do ! + [_ (atom.write |state| state)] + (wrap (#try.Success []))) + + (#try.Failure error) + (wrap (#try.Failure error))))) + )))) diff --git a/stdlib/source/library/lux/world/db/jdbc.lux b/stdlib/source/library/lux/world/db/jdbc.lux new file mode 100644 index 000000000..5ef233daf --- /dev/null +++ b/stdlib/source/library/lux/world/db/jdbc.lux @@ -0,0 +1,176 @@ +(.module: + [library + [lux (#- and int) + [control + [functor (#+ Functor)] + [apply (#+ Apply)] + [monad (#+ Monad do)] + ["." try (#+ Try)] + ["ex" exception] + [concurrency + ["." promise (#+ Promise) ("#\." monad)]] + [security + ["!" capability (#+ capability:)]]] + [data + ["." product] + [text + ["%" format (#+ format)]]] + ["." io (#+ IO)] + [world + [net (#+ URL)]] + [host (#+ import:)]]] + [// + ["." sql]] + ["." / #_ + ["#." input (#+ Input)] + ["#." output (#+ Output)]]) + +(import: java/lang/String) + +(import: java/sql/ResultSet + (getRow [] #try int) + (next [] #try boolean) + (close [] #io #try void)) + +(import: java/sql/Statement + (#static NO_GENERATED_KEYS int) + (#static RETURN_GENERATED_KEYS int) + (getGeneratedKeys [] #try java/sql/ResultSet) + (close [] #io #try void)) + +(import: java/sql/PreparedStatement + (executeUpdate [] #io #try int) + (executeQuery [] #io #try java/sql/ResultSet)) + +(import: java/sql/Connection + (prepareStatement [java/lang/String int] #try java/sql/PreparedStatement) + (isValid [int] #try boolean) + (close [] #io #try void)) + +(import: java/sql/DriverManager + (#static getConnection [java/lang/String java/lang/String java/lang/String] #io #try java/sql/Connection)) + +(type: #export Credentials + {#url URL + #user Text + #password Text}) + +(type: #export ID Int) + +(type: #export (Statement input) + {#sql sql.Statement + #input (Input input) + #value input}) + +(template [<name> <forge> <output>] + [(capability: #export (<name> ! i) + (<forge> (Statement i) (! (Try <output>))))] + + [Can-Execute can-execute Nat] + [Can-Insert can-insert (List ID)] + ) + +(capability: #export (Can-Query ! i o) + (can-query [(Statement i) (Output o)] (! (Try (List o))))) + +(capability: #export (Can-Close !) + (can-close Any (! (Try Any)))) + +(interface: #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 (Try a))) + (IO (Try a)))) + (do (try.with io.monad) + [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)) + (`` (implementation + (~~ (template [<name> <forge>] + [(def: <name> (<forge> (|>> (!.use (\ db <name>)) promise.future)))] + + [execute can-execute] + [insert can-insert] + [close can-close] + [query can-query]))))) + +(def: #export (connect creds) + (-> Credentials (IO (Try (DB IO)))) + (do (try.with io.monad) + [connection (java/sql/DriverManager::getConnection (get@ #url creds) + (get@ #user creds) + (get@ #password creds))] + (wrap (: (DB IO) + (implementation + (def: execute + (..can-execute + (function (execute statement) + (with-statement statement connection + (function (_ prepared) + (do (try.with io.monad) + [row-count (java/sql/PreparedStatement::executeUpdate prepared)] + (wrap (.nat row-count)))))))) + + (def: insert + (..can-insert + (function (insert statement) + (with-statement statement connection + (function (_ prepared) + (do (try.with io.monad) + [_ (java/sql/PreparedStatement::executeUpdate prepared) + result-set (io.io (java/sql/Statement::getGeneratedKeys prepared))] + (/output.rows /output.long result-set))))))) + + (def: close + (..can-close + (function (close _) + (java/sql/Connection::close connection)))) + + (def: query + (..can-query + (function (query [statement output]) + (with-statement statement connection + (function (_ prepared) + (do (try.with io.monad) + [result-set (java/sql/PreparedStatement::executeQuery prepared)] + (/output.rows output result-set))))))) + ))))) + +(def: #export (with-db creds action) + (All [a] + (-> Credentials + (-> (DB IO) (IO (Try a))) + (IO (Try a)))) + (do (try.with io.monad) + [db (..connect creds) + result (action db) + _ (!.use (\ db close) [])] + (wrap result))) + +(def: #export (with-async-db creds action) + (All [a] + (-> Credentials + (-> (DB Promise) (Promise (Try a))) + (Promise (Try a)))) + (do (try.with promise.monad) + [db (promise.future (..connect creds)) + result (action (..async db)) + _ (promise\wrap (io.run (!.use (\ db close) [])))] + (wrap result))) diff --git a/stdlib/source/library/lux/world/db/jdbc/input.lux b/stdlib/source/library/lux/world/db/jdbc/input.lux new file mode 100644 index 000000000..9c3de1238 --- /dev/null +++ b/stdlib/source/library/lux/world/db/jdbc/input.lux @@ -0,0 +1,107 @@ +(.module: + [library + [lux (#- and int) + [ffi (#+ import:)] + [control + [functor (#+ Contravariant)] + [monad (#+ Monad do)] + ["." try (#+ Try)]] + [time + ["." instant (#+ Instant)]] + ["." io (#+ IO)] + [world + [binary (#+ Binary)]]]]) + +(import: java/lang/String) + +(template [<class>] + [(import: <class> + (new [long]))] + + [java/sql/Date] [java/sql/Time] [java/sql/Timestamp] + ) + +(`` (import: java/sql/PreparedStatement + (~~ (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 [byte]] + + [setDate java/sql/Date] + [setTime java/sql/Time] + [setTimestamp java/sql/Timestamp] + )))) + +(type: #export (Input a) + (-> a [Nat java/sql/PreparedStatement] + (Try [Nat java/sql/PreparedStatement]))) + +(implementation: #export contravariant (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 try.monad + [context (pre left context)] + (post right context)))) + +(def: #export (fail error) + (All [a] (-> Text (Input a))) + (function (_ value [idx context]) + (#try.Failure error))) + +(def: #export empty + (Input Any) + (function (_ value context) + (#try.Success context))) + +(template [<function> <type> <setter>] + [(def: #export <function> + (Input <type>) + (function (_ value [idx statement]) + (do try.monad + [_ (<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] + ) + +(template [<function> <setter> <constructor>] + [(def: #export <function> + (Input Instant) + (function (_ value [idx statement]) + (do try.monad + [_ (<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/library/lux/world/db/jdbc/output.lux b/stdlib/source/library/lux/world/db/jdbc/output.lux new file mode 100644 index 000000000..b172a1ac9 --- /dev/null +++ b/stdlib/source/library/lux/world/db/jdbc/output.lux @@ -0,0 +1,195 @@ +(.module: + [library + [lux (#- and int) + [ffi (#+ import:)] + [control + [functor (#+ Functor)] + [apply (#+ Apply)] + [monad (#+ Monad do)] + ["ex" exception] + ["." try (#+ Try)]] + [time + ["." instant (#+ Instant)]] + ["." io (#+ IO)] + [world + [binary (#+ Binary)]]]]) + +(import: java/lang/String) + +(import: java/util/Date + (getTime [] long)) + +(import: java/sql/Date) +(import: java/sql/Time) +(import: java/sql/Timestamp) + +(`` (import: java/sql/ResultSet + (~~ (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 [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] (Try [Nat a]))) + +(implementation: #export functor + (Functor Output) + + (def: (map f fa) + (function (_ idx+rs) + (case (fa idx+rs) + (#try.Failure error) + (#try.Failure error) + + (#try.Success [idx' value]) + (#try.Success [idx' (f value)]))))) + +(implementation: #export apply + (Apply Output) + + (def: &functor ..functor) + + (def: (apply ff fa) + (function (_ [idx rs]) + (case (ff [idx rs]) + (#try.Success [idx' f]) + (case (fa [idx' rs]) + (#try.Success [idx'' a]) + (#try.Success [idx'' (f a)]) + + (#try.Failure msg) + (#try.Failure msg)) + + (#try.Failure msg) + (#try.Failure msg))))) + +(implementation: #export monad + (Monad Output) + + (def: &functor ..functor) + + (def: (wrap a) + (function (_ [idx rs]) + (#.Some [idx a]))) + + (def: (join mma) + (function (_ [idx rs]) + (case (mma [idx rs]) + (#try.Failure error) + (#try.Failure error) + + (#try.Success [idx' ma]) + (ma [idx' rs]))))) + +(def: #export (fail error) + (All [a] (-> Text (Output a))) + (function (_ [idx result-set]) + (#try.Failure error))) + +(def: #export (and left right) + (All [a b] + (-> (Output a) (Output b) (Output [a b]))) + (do ..monad + [=left left + =right right] + (wrap [=left =right]))) + +(template [<func-name> <method-name> <type>] + [(def: #export <func-name> + (Output <type>) + (function (_ [idx result-set]) + (case (<method-name> [(.int idx)] result-set) + (#try.Failure error) + (#try.Failure error) + + (#try.Success value) + (#try.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] + ) + +(template [<func-name> <method-name>] + [(def: #export <func-name> + (Output Instant) + (function (_ [idx result-set]) + (case (<method-name> [(.int idx)] result-set) + (#try.Failure error) + (#try.Failure error) + + (#try.Success value) + (#try.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 (Try (List a))))) + (case (java/sql/ResultSet::next results) + (#try.Success has-next?) + (if has-next? + (case (output [1 results]) + (#.Some [_ head]) + (do io.monad + [?tail (rows output results)] + (case ?tail + (#try.Success tail) + (wrap (ex.return (#.Cons head tail))) + + (#try.Failure error) + (do io.monad + [temp (java/sql/ResultSet::close results)] + (wrap (do try.monad + [_ temp] + (try.fail error)))))) + + (#try.Failure error) + (do io.monad + [temp (java/sql/ResultSet::close results)] + (wrap (do try.monad + [_ temp] + (try.fail error))))) + (do io.monad + [temp (java/sql/ResultSet::close results)] + (wrap (do try.monad + [_ temp] + (wrap (list)))))) + + (#try.Failure error) + (do io.monad + [temp (java/sql/ResultSet::close results)] + (wrap (do try.monad + [_ temp] + (try.fail error)))) + )) diff --git a/stdlib/source/library/lux/world/db/sql.lux b/stdlib/source/library/lux/world/db/sql.lux new file mode 100644 index 000000000..99f3f027d --- /dev/null +++ b/stdlib/source/library/lux/world/db/sql.lux @@ -0,0 +1,476 @@ +(.module: + [library + [lux (#- Source Definition function and or not type is? int) + [control + [monad (#+ do)]] + [data + [number + ["i" int]] + ["." text ("#\." equivalence) + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor)]]] + [type + abstract]]]) + +(def: parenthesize + (-> Text Text) + (text.enclose ["(" ")"])) + +## Kind +(template [<declaration>] + [(abstract: #export <declaration> Any)] + + [Literal'] + [Column'] + [Placeholder'] + [(Value' kind)] + + [Function'] + + [Condition'] + + [Index'] + + [Table'] + [View'] + [Source'] + [DB'] + + [No-Limit] [With-Limit] + [No-Offset] [With-Offset] + [Order'] + [No-Order] [With-Order] + [No-Group] [With-Group] + [(Query' order group limit offset)] + + [Command'] + + [No-Where] [With-Where] [Without-Where] + [No-Having] [With-Having] [Without-Having] + [(Action' where having kind)] + + [(Schema' kind)] + [Definition'] + [(Statement' kind)] + ) + +(type: #export Alias Text) + +(def: #export no-alias Alias "") + +(abstract: #export (SQL kind) + Text + + ## SQL + (template [<declaration> <kind>] + [(type: #export <declaration> (SQL <kind>))] + + [Literal (Value' Literal')] + [Column (Value' Column')] + [Placeholder (Value' Placeholder')] + [Value (Value' Any)] + + [Function Function'] + [Condition Condition'] + + [Index Index'] + + [Table Table'] + [View View'] + [Source Source'] + [DB DB'] + + [Order Order'] + + [(Schema kind) (Schema' kind)] + + [(Query where having order group limit offset) (Statement' (Action' where having (Query' order group limit offset)))] + [(Command where having) (Statement' (Action' where having Command'))] + [(Action where having kind) (Statement' (Action' where having kind))] + + [Definition (Statement' Definition')] + [Statement (Statement' Any)] + ) + + (def: Base-Query (.type (Query No-Where No-Having No-Order No-Group No-Limit No-Offset))) + (def: Any-Query (.type (Query Any Any Any Any Any Any))) + + (def: #export read + {#.doc (doc "Only use this function for debugging purposes." + "Do not use this function to actually execute SQL code.")} + (-> (SQL Any) Text) + (|>> :representation)) + + (def: #export (sql action) + (-> Statement Text) + (format (:representation action) ";")) + + (def: enumerate + (-> (List (SQL Any)) Text) + (|>> (list\map (|>> :representation)) + (text.join-with ", "))) + + ## Value + (def: #export ? Placeholder (:abstraction "?")) + + (def: literal + (-> Text Literal) + (|>> :abstraction)) + + (def: #export null Literal (..literal "NULL")) + + (def: #export (int value) + (-> Int Literal) + (..literal (if (i.< +0 value) + (%.int value) + (%.nat (.nat value))))) + + (def: #export function + (-> Text Function) + (|>> :abstraction)) + + (def: #export (call function parameters) + (-> Function (List Value) Value) + (:abstraction (format (:representation function) + (..parenthesize (..enumerate parameters))))) + + ## Condition + (template [<name> <sql-op>] + [(def: #export (<name> reference sample) + (-> Value Value Condition) + (:abstraction + (..parenthesize + (format (:representation sample) + " " <sql-op> " " + (:representation reference)))))] + + [= "="] + [<> "<>"] + [is? "IS"] + [> ">"] + [>= ">="] + [< "<"] + [<= "<="] + [like? "LIKE"] + [ilike? "ILIKE"] + ) + + (def: #export (between from to sample) + (-> Value Value Value Condition) + (:abstraction + (..parenthesize + (format (:representation sample) + " BETWEEN " (:representation from) + " AND " (:representation to))))) + + (def: #export (in options value) + (-> (List Value) Value Condition) + (:abstraction + (format (:representation value) + " IN " + (..parenthesize (enumerate options))))) + + (template [<func-name> <sql-op>] + [(def: #export (<func-name> left right) + (-> Condition Condition Condition) + (:abstraction + (format (..parenthesize (:representation left)) + " " <sql-op> " " + (..parenthesize (:representation right)))))] + + [and "AND"] + [or "OR"] + ) + + (template [<name> <type> <sql>] + [(def: #export <name> + (-> <type> Condition) + (|>> :representation ..parenthesize (format <sql> " ") :abstraction))] + + [not Condition "NOT"] + [exists Any-Query "EXISTS"] + ) + + ## Query + (template [<name> <type> <decoration>] + [(def: #export <name> + (-> <type> Source) + (|>> :representation <decoration> :abstraction))] + + [from-table Table (<|)] + [from-view View (<|)] + [from-query Any-Query ..parenthesize] + ) + + (template [<func-name> <op>] + [(def: #export (<func-name> columns source) + (-> (List [Column Alias]) Source Base-Query) + (:abstraction + (format <op> + " " + (case columns + #.Nil + "*" + + _ + (|> columns + (list\map (.function (_ [column alias]) + (if (text\= ..no-alias alias) + (:representation column) + (format (:representation column) " AS " alias)))) + (text.join-with ", "))) + " FROM " (:representation source))))] + + + [select "SELECT"] + [select-distinct "SELECT DISTINCT"] + ) + + (template [<name> <join-text>] + [(def: #export (<name> table condition prev) + (-> Table Condition Base-Query Base-Query) + (:abstraction + (format (:representation prev) + " " <join-text> " " + (:representation table) + " ON " (:representation condition))))] + + [inner-join "INNER JOIN"] + [left-join "LEFT JOIN"] + [right-join "RIGHT JOIN"] + [full-outer-join "FULL OUTER JOIN"] + ) + + (template [<function> <sql-op>] + [(def: #export (<function> left right) + (-> Any-Query Any-Query (Query Without-Where Without-Having No-Order No-Group No-Limit No-Offset)) + (:abstraction + (format (:representation left) + " " <sql-op> " " + (:representation right))))] + + [union "UNION"] + [union-all "UNION ALL"] + [intersect "INTERSECT"] + ) + + (template [<name> <sql> <variables> <input> <output>] + [(def: #export (<name> value query) + (All <variables> + (-> Nat <input> <output>)) + (:abstraction + (format (:representation query) + " " <sql> " " + (%.nat value))))] + + [limit "LIMIT" [where having order group offset] + (Query where having order group No-Limit offset) + (Query where having order group With-Limit offset)] + + [offset "OFFSET" [where having order group limit] + (Query where having order group limit No-Offset) + (Query where having order group limit With-Offset)] + ) + + (template [<name> <sql>] + [(def: #export <name> + Order + (:abstraction <sql>))] + + [ascending "ASC"] + [descending "DESC"] + ) + + (def: #export (order-by pairs query) + (All [where having group limit offset] + (-> (List [Value Order]) + (Query where having No-Order group limit offset) + (Query where having With-Order group limit offset))) + (case pairs + #.Nil + (|> query :representation :abstraction) + + _ + (:abstraction + (format (:representation query) + " ORDER BY " + (|> pairs + (list\map (.function (_ [value order]) + (format (:representation value) " " (:representation order)))) + (text.join-with ", ")))))) + + (def: #export (group-by pairs query) + (All [where having order limit offset] + (-> (List Value) + (Query where having order No-Group limit offset) + (Query where having order With-Group limit offset))) + (case pairs + #.Nil + (|> query :representation :abstraction) + + _ + (:abstraction + (format (:representation query) + " GROUP BY " + (..enumerate pairs))))) + + ## Command + (def: #export (insert table columns rows) + (-> Table (List Column) (List (List Value)) (Command Without-Where Without-Having)) + (:abstraction + (format "INSERT INTO " (:representation table) " " + (..parenthesize (..enumerate columns)) + " VALUES " + (|> rows + (list\map (|>> ..enumerate ..parenthesize)) + (text.join-with ", ")) + ))) + + (def: #export (update table pairs) + (-> Table (List [Column Value]) (Command No-Where No-Having)) + (:abstraction (format "UPDATE " (:representation table) + (case pairs + #.Nil + "" + + _ + (format " SET " (|> pairs + (list\map (.function (_ [column value]) + (format (:representation column) "=" (:representation value)))) + (text.join-with ", "))))))) + + (def: #export delete + (-> Table (Command No-Where No-Having)) + (|>> :representation (format "DELETE FROM ") :abstraction)) + + ## Action + (def: #export (where condition prev) + (All [kind having] + (-> Condition (Action No-Where having kind) (Action With-Where having kind))) + (:abstraction + (format (:representation prev) + " WHERE " + (:representation condition)))) + + (def: #export (having condition prev) + (All [where kind] + (-> Condition (Action where No-Having kind) (Action where With-Having kind))) + (:abstraction + (format (:representation prev) + " HAVING " + (:representation condition)))) + + ## Schema + (def: #export type + (-> Text (Schema Value)) + (|>> :abstraction)) + + (template [<name> <attr>] + [(def: #export (<name> attr) + (-> (Schema Value) (Schema Value)) + (:abstraction + (format (:representation attr) " " <attr>)))] + + [unique "UNIQUE"] + [not-null "NOT NULL"] + [stored "STORED"] + ) + + (def: #export (default value attr) + (-> Value (Schema Value) (Schema Value)) + (:abstraction + (format (:representation attr) " DEFAULT " (:representation value)))) + + (def: #export (define-column name type) + (-> Column (Schema Value) (Schema Column)) + (:abstraction + (format (:representation name) " " (:representation type)))) + + (def: #export (auto-increment offset column) + (-> Int (Schema Column) (Schema Column)) + (:abstraction + (format (:representation column) " AUTO_INCREMENT=" (:representation (..int offset))))) + + (def: #export (create-table or-replace? table columns) + (-> Bit Table (List (Schema Column)) Definition) + (let [command (if or-replace? + "CREATE OR REPLACE TABLE" + "CREATE TABLE IF NOT EXISTS")] + (:abstraction + (format command " " (:representation table) + (..parenthesize (..enumerate columns)))))) + + (def: #export (create-table-as table query) + (-> Table Any-Query Definition) + (:abstraction + (format "CREATE TABLE " (:representation table) " AS " (:representation query)))) + + (template [<name> <sql>] + [(def: #export (<name> table) + (-> Table Definition) + (:abstraction + (format <sql> " TABLE " (:representation table))))] + + [drop "DROP"] + [truncate "TRUNCATE"] + ) + + (def: #export (add-column table column) + (-> Table (Schema Column) Definition) + (:abstraction + (format "ALTER TABLE " (:representation table) " ADD " (:representation column)))) + + (def: #export (drop-column table column) + (-> Table Column Definition) + (:abstraction + (format "ALTER TABLE " (:representation table) " DROP COLUMN " (:representation column)))) + + (template [<name> <type>] + [(def: #export (<name> name) + (-> Text <type>) + (:abstraction name))] + + [column Column] + [table Table] + [view View] + [index Index] + [db DB] + ) + + (template [<name> <type> <sql>] + [(def: #export <name> + (-> <type> Definition) + (|>> :representation (format <sql> " ") :abstraction))] + + [create-db DB "CREATE DATABASE"] + [drop-db DB "DROP DATABASE"] + [drop-view View "DROP VIEW"] + ) + + (template [<name> <sql>] + [(def: #export (<name> view query) + (-> View Any-Query Definition) + (:abstraction + (format <sql> " " (:representation view) " AS " (:representation query))))] + + [create-view "CREATE VIEW"] + [create-or-replace-view "CREATE OR REPLACE VIEW"] + ) + + (def: #export (create-index index table unique? columns) + (-> Index Table Bit (List Column) Definition) + (:abstraction + (format "CREATE " (if unique? "UNIQUE" "") " INDEX " (:representation index) + " ON " (:representation table) " " (..parenthesize (..enumerate columns))))) + + (def: #export (with alias query body) + (All [where having order group limit offset] + (-> Table Any-Query + (Query where having order group limit offset) + (Query where having order group limit offset))) + (:abstraction + (format "WITH " (:representation alias) + " AS " (..parenthesize (:representation query)) + " " (:representation body)))) + ) diff --git a/stdlib/source/library/lux/world/file.lux b/stdlib/source/library/lux/world/file.lux new file mode 100644 index 000000000..7f95b3282 --- /dev/null +++ b/stdlib/source/library/lux/world/file.lux @@ -0,0 +1,1303 @@ +(.module: + [library + [lux #* + ["@" target] + ["." ffi] + [abstract + ["." monad (#+ Monad do)]] + [control + [pipe (#+ case>)] + ["." try (#+ Try) ("#\." functor)] + ["." exception (#+ exception:)] + ["." io (#+ IO) ("#\." functor)] + ["." function] + [concurrency + ["." promise (#+ Promise)] + ["." stm (#+ Var STM)]]] + [data + ["." bit ("#\." equivalence)] + ["." product] + ["." maybe ("#\." functor)] + ["." binary (#+ Binary)] + ["." text ("#\." equivalence) + ["%" format (#+ format)]] + [collection + ["." array (#+ Array)] + ["." list ("#\." functor)] + ["." dictionary (#+ Dictionary)]]] + [macro + ["." template]] + [math + [number + ["i" int] + ["f" frac]]] + [time + ["." instant (#+ Instant)] + ["." duration]]]]) + +(type: #export Path + Text) + +(`` (interface: #export (System !) + (: Text + separator) + + (~~ (template [<name> <output>] + [(: (-> Path (! <output>)) + <name>)] + + [file? Bit] + [directory? Bit] + )) + + (~~ (template [<name> <output>] + [(: (-> Path (! (Try <output>))) + <name>)] + + [make_directory Any] + [directory_files (List Path)] + [sub_directories (List Path)] + + [file_size Nat] + [last_modified Instant] + [can_execute? Bit] + [read Binary] + [delete Any] + )) + + (~~ (template [<name> <input>] + [(: (-> <input> Path (! (Try Any))) + <name>)] + + [modify Instant] + [write Binary] + [append Binary] + [move Path] + )) + )) + +(def: #export (un_nest fs path) + (All [!] (-> (System !) Path (Maybe [Path Text]))) + (let [/ (\ fs separator)] + (case (text.last_index_of / path) + #.None + #.None + + (#.Some last_separator) + (do maybe.monad + [[parent temp] (text.split last_separator path) + [_ child] (text.split (text.size /) temp)] + (wrap [parent child]))))) + +(def: #export (parent fs path) + (All [!] (-> (System !) Path (Maybe Path))) + (|> (..un_nest fs path) + (maybe\map product.left))) + +(def: #export (name fs path) + (All [!] (-> (System !) Path Text)) + (|> (..un_nest fs path) + (maybe\map product.right) + (maybe.default path))) + +(def: #export (async fs) + (-> (System IO) (System Promise)) + (`` (implementation + (def: separator + (\ fs separator)) + + (~~ (template [<name>] + [(def: <name> + (|>> (\ fs <name>) + promise.future))] + + [file?] + [directory?] + + [make_directory] + [directory_files] + [sub_directories] + + [file_size] + [last_modified] + [can_execute?] + [read] + [delete])) + + (~~ (template [<name>] + [(def: (<name> input path) + (promise.future (\ fs <name> input path)))] + + [modify] + [write] + [append] + [move])) + ))) + +(def: #export (nest fs parent child) + (All [!] (-> (System !) Path Text Path)) + (format parent (\ fs separator) child)) + +(template [<name>] + [(exception: #export (<name> {file Path}) + (exception.report + ["Path" file]))] + + [cannot_make_file] + [cannot_find_file] + [cannot_delete] + + [cannot_make_directory] + [cannot_find_directory] + + [cannot_read_all_data] + ) + +(with_expansions [<extra> (as_is (exception: #export (cannot_move {target Path} {source Path}) + (exception.report + ["Source" source] + ["Target" target])))] + (for {@.old (as_is <extra>) + @.jvm (as_is <extra>) + @.lua (as_is <extra>)} + (as_is))) + +(with_expansions [<for_jvm> (as_is (exception: #export (cannot_modify_file {instant Instant} {file Path}) + (exception.report + ["Instant" (%.instant instant)] + ["Path" file])) + + (ffi.import: java/lang/String) + + (`` (ffi.import: java/io/File + ["#::." + (new [java/lang/String]) + (~~ (template [<name>] + [(<name> [] #io #try boolean)] + + [createNewFile] [mkdir] + [delete] + [isFile] [isDirectory] + [canRead] [canWrite] [canExecute])) + + (length [] #io #try long) + (listFiles [] #io #try #? [java/io/File]) + (getAbsolutePath [] #io #try java/lang/String) + (renameTo [java/io/File] #io #try boolean) + (lastModified [] #io #try long) + (setLastModified [long] #io #try boolean) + (#static separator java/lang/String)])) + + (ffi.import: java/lang/AutoCloseable + ["#::." + (close [] #io #try void)]) + + (ffi.import: java/io/OutputStream + ["#::." + (write [[byte]] #io #try void) + (flush [] #io #try void)]) + + (ffi.import: java/io/FileOutputStream + ["#::." + (new [java/io/File boolean] #io #try)]) + + (ffi.import: java/io/InputStream + ["#::." + (read [[byte]] #io #try int)]) + + (ffi.import: java/io/FileInputStream + ["#::." + (new [java/io/File] #io #try)]) + + (`` (implementation: #export default + (System IO) + + (def: separator + (java/io/File::separator)) + + (~~ (template [<name> <method>] + [(def: <name> + (|>> java/io/File::new + <method> + (io\map (|>> (try.default false)))))] + + [file? java/io/File::isFile] + [directory? java/io/File::isDirectory] + )) + + (def: (make_directory path) + (|> path + java/io/File::new + java/io/File::mkdir)) + + (~~ (template [<name> <method>] + [(def: (<name> path) + (do {! (try.with io.monad)} + [?children (java/io/File::listFiles (java/io/File::new path))] + (case ?children + (#.Some children) + (|> children + array.to_list + (monad.filter ! (|>> <method>)) + (\ ! map (monad.map ! (|>> java/io/File::getAbsolutePath))) + (\ ! join)) + + #.None + (\ io.monad wrap (exception.throw ..cannot_find_directory [path])))))] + + [directory_files java/io/File::isFile] + [sub_directories java/io/File::isDirectory] + )) + + (def: file_size + (|>> java/io/File::new + java/io/File::length + (\ (try.with io.monad) map .nat))) + + (def: last_modified + (|>> java/io/File::new + (java/io/File::lastModified) + (\ (try.with io.monad) map (|>> duration.from_millis instant.absolute)))) + + (def: can_execute? + (|>> java/io/File::new + java/io/File::canExecute)) + + (def: (read path) + (do (try.with io.monad) + [#let [file (java/io/File::new path)] + size (java/io/File::length file) + #let [data (binary.create (.nat size))] + stream (java/io/FileInputStream::new file) + bytes_read (java/io/InputStream::read data stream) + _ (java/lang/AutoCloseable::close stream)] + (if (i.= size bytes_read) + (wrap data) + (\ io.monad wrap (exception.throw ..cannot_read_all_data path))))) + + (def: (delete path) + (|> path + java/io/File::new + java/io/File::delete)) + + (def: (modify time_stamp path) + (|> path + java/io/File::new + (java/io/File::setLastModified (|> time_stamp instant.relative duration.to_millis)))) + + (~~ (template [<name> <flag>] + [(def: (<name> data path) + (do (try.with io.monad) + [stream (java/io/FileOutputStream::new (java/io/File::new path) <flag>) + _ (java/io/OutputStream::write data stream) + _ (java/io/OutputStream::flush stream)] + (java/lang/AutoCloseable::close stream)))] + + [write #0] + [append #1] + )) + + (def: (move destination origin) + (|> origin + java/io/File::new + (java/io/File::renameTo (java/io/File::new destination)))) + )))] + (for {@.old (as_is <for_jvm>) + @.jvm (as_is <for_jvm>) + + @.js + (as_is (ffi.import: Buffer + ["#::." + (#static from [Binary] ..Buffer)]) + + (ffi.import: FileDescriptor) + + (ffi.import: Stats + ["#::." + (size ffi.Number) + (mtimeMs ffi.Number) + (isFile [] #io #try ffi.Boolean) + (isDirectory [] #io #try ffi.Boolean)]) + + (ffi.import: FsConstants + ["#::." + (F_OK ffi.Number) + (R_OK ffi.Number) + (W_OK ffi.Number) + (X_OK ffi.Number)]) + + (ffi.import: Fs + ["#::." + (constants FsConstants) + (readFileSync [ffi.String] #io #try Binary) + (appendFileSync [ffi.String Buffer] #io #try Any) + (writeFileSync [ffi.String Buffer] #io #try Any) + (statSync [ffi.String] #io #try Stats) + (accessSync [ffi.String ffi.Number] #io #try Any) + (renameSync [ffi.String ffi.String] #io #try Any) + (utimesSync [ffi.String ffi.Number ffi.Number] #io #try Any) + (unlink [ffi.String] #io #try Any) + (readdirSync [ffi.String] #io #try (Array ffi.String)) + (mkdirSync [ffi.String] #io #try Any) + (rmdirSync [ffi.String] #io #try Any)]) + + (ffi.import: JsPath + ["#::." + (sep ffi.String)]) + + (template [<name> <path>] + [(def: (<name> _) + (-> [] (Maybe (-> ffi.String Any))) + (ffi.constant (-> ffi.String Any) <path>))] + + [normal_require [require]] + [global_require [global require]] + [process_load [global process mainModule constructor _load]] + ) + + (def: (require _) + (-> [] (-> ffi.String Any)) + (case [(normal_require []) (global_require []) (process_load [])] + (^or [(#.Some require) _ _] + [_ (#.Some require) _] + [_ _ (#.Some require)]) + require + + _ + (undefined))) + + (template [<name> <module> <type>] + [(def: (<name> _) + (-> [] <type>) + (:as <type> (..require [] <module>)))] + + [node_fs "fs" ..Fs] + [node_path "path" ..JsPath] + ) + + (`` (implementation: #export default + (System IO) + + (def: separator + (if ffi.on_node_js? + (JsPath::sep (..node_path [])) + "/")) + + (~~ (template [<name> <method>] + [(def: (<name> path) + (do {! io.monad} + [?stats (Fs::statSync [path] (..node_fs []))] + (case ?stats + (#try.Success stats) + (|> stats + (<method> []) + (\ ! map (|>> (try.default false)))) + + (#try.Failure _) + (wrap false))))] + + [file? Stats::isFile] + [directory? Stats::isDirectory] + )) + + (def: (make_directory path) + (let [node_fs (..node_fs [])] + (do io.monad + [outcome (Fs::accessSync [path (|> node_fs Fs::constants FsConstants::F_OK)] node_fs)] + (case outcome + (#try.Success _) + (wrap (exception.throw ..cannot_make_directory [path])) + + (#try.Failure _) + (Fs::mkdirSync [path] node_fs))))) + + (~~ (template [<name> <method>] + [(def: (<name> path) + (do {! (try.with io.monad)} + [#let [node_fs (..node_fs [])] + subs (Fs::readdirSync [path] node_fs)] + (|> subs + array.to_list + (monad.map ! (function (_ sub) + (do ! + [stats (Fs::statSync [sub] node_fs)] + (\ ! map (|>> [sub]) (<method> [] stats))))) + (\ ! map (|>> (list.filter product.right) + (list\map product.left))))))] + + [directory_files Stats::isFile] + [sub_directories Stats::isDirectory] + )) + + (def: (file_size path) + (let [! (try.with io.monad)] + (|> (..node_fs []) + (Fs::statSync [path]) + (\ ! map (|>> Stats::size + f.nat))))) + + (def: (last_modified path) + (let [! (try.with io.monad)] + (|> (..node_fs []) + (Fs::statSync [path]) + (\ ! map (|>> Stats::mtimeMs + f.int + duration.from_millis + instant.absolute))))) + + (def: (can_execute? path) + (let [node_fs (..node_fs [])] + (|> node_fs + (Fs::accessSync [path (|> node_fs Fs::constants FsConstants::X_OK)]) + (io\map (|>> (case> (#try.Success _) + true + + (#try.Failure _) + false) + #try.Success))))) + + (def: (read path) + (Fs::readFileSync [path] (..node_fs []))) + + (def: (delete path) + (do {! (try.with io.monad)} + [#let [node_fs (..node_fs [])] + stats (Fs::statSync [path] node_fs) + verdict (Stats::isFile [] stats)] + (if verdict + (Fs::unlink [path] node_fs) + (Fs::rmdirSync [path] node_fs)))) + + (def: (modify time_stamp path) + (let [when (|> time_stamp instant.relative duration.to_millis i.frac)] + (Fs::utimesSync [path when when] (..node_fs [])))) + + (~~ (template [<name> <method>] + [(def: (<name> data path) + (<method> [path (Buffer::from data)] (..node_fs [])))] + + [write Fs::writeFileSync] + [append Fs::appendFileSync] + )) + + (def: (move destination origin) + (Fs::renameSync [origin destination] (..node_fs []))) + ))) + + @.python + (as_is (type: (Tuple/2 left right) + (primitive "python_tuple[2]" [left right])) + + (ffi.import: PyFile + ["#::." + (read [] #io #try Binary) + (write [Binary] #io #try #? Any) + (close [] #io #try #? Any)]) + + (ffi.import: (open [ffi.String ffi.String] #io #try PyFile)) + (ffi.import: (tuple [[ffi.Integer ffi.Integer]] (Tuple/2 ffi.Integer ffi.Integer))) + + (ffi.import: os + ["#::." + (#static F_OK ffi.Integer) + (#static R_OK ffi.Integer) + (#static W_OK ffi.Integer) + (#static X_OK ffi.Integer) + + (#static mkdir [ffi.String] #io #try #? Any) + (#static access [ffi.String ffi.Integer] #io #try ffi.Boolean) + (#static remove [ffi.String] #io #try #? Any) + (#static rmdir [ffi.String] #io #try #? Any) + (#static rename [ffi.String ffi.String] #io #try #? Any) + (#static utime [ffi.String (Tuple/2 ffi.Integer ffi.Integer)] #io #try #? Any) + (#static listdir [ffi.String] #io #try (Array ffi.String))]) + + (ffi.import: os/path + ["#::." + (#static isfile [ffi.String] #io #try ffi.Boolean) + (#static isdir [ffi.String] #io #try ffi.Boolean) + (#static sep ffi.String) + (#static getsize [ffi.String] #io #try ffi.Integer) + (#static getmtime [ffi.String] #io #try ffi.Float)]) + + (`` (implementation: #export default + (System IO) + + (def: separator + (os/path::sep)) + + (~~ (template [<name> <method>] + [(def: <name> + (|>> <method> + (io\map (|>> (try.default false)))))] + + [file? os/path::isfile] + [directory? os/path::isdir] + )) + + (def: make_directory + os::mkdir) + + (~~ (template [<name> <method>] + [(def: <name> + (let [! (try.with io.monad)] + (|>> os::listdir + (\ ! map (|>> array.to_list + (monad.map ! (function (_ sub) + (\ ! map (|>> [sub]) (<method> [sub])))) + (\ ! map (|>> (list.filter product.right) + (list\map product.left))))) + (\ ! join))))] + + [directory_files os/path::isfile] + [sub_directories os/path::isdir] + )) + + (def: file_size + (|>> os/path::getsize + (\ (try.with io.monad) map .nat))) + + (def: last_modified + (|>> os/path::getmtime + (\ (try.with io.monad) map (|>> f.int + (i.* +1,000) + duration.from_millis + instant.absolute)))) + + (def: (can_execute? path) + (os::access [path (os::X_OK)])) + + (def: (read path) + (do (try.with io.monad) + [file (..open [path "rb"]) + data (PyFile::read [] file) + _ (PyFile::close [] file)] + (wrap data))) + + (def: (delete path) + (do (try.with io.monad) + [? (os/path::isfile [path])] + (if ? + (os::remove [path]) + (os::rmdir [path])))) + + (def: (modify time_stamp path) + (let [when (|> time_stamp instant.relative duration.to_millis (i./ +1,000))] + (os::utime [path (..tuple [when when])]))) + + (~~ (template [<name> <mode>] + [(def: (<name> data path) + (do (try.with io.monad) + [file (..open [path <mode>]) + _ (PyFile::write [data] file)] + (PyFile::close [] file)))] + + [write "w+b"] + [append "ab"] + )) + + (def: (move destination origin) + (os::rename [origin destination])) + ))) + + @.ruby + (as_is (ffi.import: Time #as RubyTime + ["#::." + (#static at [Frac] RubyTime) + (to_f [] Frac)]) + + (ffi.import: Stat #as RubyStat + ["#::." + (executable? [] Bit) + (size Int) + (mtime [] RubyTime)]) + + (ffi.import: File #as RubyFile + ["#::." + (#static SEPARATOR ffi.String) + (#static open [Path ffi.String] #io #try RubyFile) + (#static stat [Path] #io #try RubyStat) + (#static delete [Path] #io #try Int) + (#static file? [Path] #io #try Bit) + (#static directory? [Path] #io #try Bit) + (#static utime [RubyTime RubyTime Path] #io #try Int) + + (read [] #io #try Binary) + (write [Binary] #io #try Int) + (flush [] #io #try #? Any) + (close [] #io #try #? Any)]) + + (ffi.import: Dir #as RubyDir + ["#::." + (#static open [Path] #io #try RubyDir) + + (children [] #io #try (Array Path)) + (close [] #io #try #? Any)]) + + (ffi.import: "fileutils" FileUtils #as RubyFileUtils + ["#::." + (#static move [Path Path] #io #try #? Any) + (#static rmdir [Path] #io #try #? Any) + (#static mkdir [Path] #io #try #? Any)]) + + (def: ruby_separator + Text + (..RubyFile::SEPARATOR)) + + (`` (implementation: #export default + (System IO) + + (def: separator + ..ruby_separator) + + (~~ (template [<name> <test>] + [(def: <name> + (|>> <test> + (io\map (|>> (try.default false)))))] + + [file? RubyFile::file?] + [directory? RubyFile::directory?] + )) + + (def: make_directory + RubyFileUtils::mkdir) + + (~~ (template [<name> <test>] + [(def: (<name> path) + (do {! (try.with io.monad)} + [self (RubyDir::open [path]) + children (RubyDir::children [] self) + output (loop [input (|> children + array.to_list + (list\map (|>> (format path ..ruby_separator)))) + output (: (List ..Path) + (list))] + (case input + #.Nil + (wrap output) + + (#.Cons head tail) + (do ! + [verdict (<test> head)] + (recur tail (if verdict + (#.Cons head output) + output))))) + _ (RubyDir::close [] self)] + (wrap output)))] + + [directory_files RubyFile::file?] + [sub_directories RubyFile::directory?] + )) + + (~~ (template [<name> <pipeline>] + [(def: <name> + (let [! (try.with io.monad)] + (|>> RubyFile::stat + (\ ! map (`` (|>> (~~ (template.splice <pipeline>))))))))] + + [file_size [RubyStat::size .nat]] + [last_modified [(RubyStat::mtime []) + (RubyTime::to_f []) + (f.* +1,000.0) + f.int + duration.from_millis + instant.absolute]] + [can_execute? [(RubyStat::executable? [])]] + )) + + (def: (read path) + (do (try.with io.monad) + [file (RubyFile::open [path "rb"]) + data (RubyFile::read [] file) + _ (RubyFile::close [] file)] + (wrap data))) + + (def: (delete path) + (do (try.with io.monad) + [? (RubyFile::file? path)] + (if ? + (RubyFile::delete [path]) + (RubyFileUtils::rmdir [path])))) + + (def: (modify moment path) + (let [moment (|> moment + instant.relative + duration.to_millis + i.frac + (f./ +1,000.0) + RubyTime::at)] + (RubyFile::utime [moment moment path]))) + + (~~ (template [<mode> <name>] + [(def: (<name> data path) + (do {! (try.with io.monad)} + [file (RubyFile::open [path <mode>]) + data (RubyFile::write [data] file) + _ (RubyFile::flush [] file) + _ (RubyFile::close [] file)] + (wrap [])))] + + ["wb" write] + ["ab" append] + )) + + (def: (move destination origin) + (do (try.with io.monad) + [_ (RubyFileUtils::move [origin destination])] + (wrap []))) + ))) + + ## @.php + ## (as_is (ffi.import: (FILE_APPEND Int)) + ## ## https://www.php.net/manual/en/dir.constants.php + ## (ffi.import: (DIRECTORY_SEPARATOR ffi.String)) + ## ## https://www.php.net/manual/en/function.pack.php + ## ## https://www.php.net/manual/en/function.unpack.php + ## (ffi.import: (unpack [ffi.String ffi.String] Binary)) + ## ## https://www.php.net/manual/en/ref.filesystem.php + ## ## https://www.php.net/manual/en/function.file-get-contents.php + ## (ffi.import: (file_get_contents [Path] #io #try ffi.String)) + ## ## https://www.php.net/manual/en/function.file-put-contents.php + ## (ffi.import: (file_put_contents [Path ffi.String Int] #io #try ffi.Integer)) + ## (ffi.import: (filemtime [Path] #io #try ffi.Integer)) + ## (ffi.import: (filesize [Path] #io #try ffi.Integer)) + ## (ffi.import: (is_executable [Path] #io #try ffi.Boolean)) + ## (ffi.import: (touch [Path ffi.Integer] #io #try ffi.Boolean)) + ## (ffi.import: (rename [Path Path] #io #try ffi.Boolean)) + ## (ffi.import: (unlink [Path] #io #try ffi.Boolean)) + + ## ## https://www.php.net/manual/en/function.rmdir.php + ## (ffi.import: (rmdir [Path] #io #try ffi.Boolean)) + ## ## https://www.php.net/manual/en/function.scandir.php + ## (ffi.import: (scandir [Path] #io #try (Array Path))) + ## ## https://www.php.net/manual/en/function.is-file.php + ## (ffi.import: (is_file [Path] #io #try ffi.Boolean)) + ## ## https://www.php.net/manual/en/function.is-dir.php + ## (ffi.import: (is_dir [Path] #io #try ffi.Boolean)) + ## ## https://www.php.net/manual/en/function.mkdir.php + ## (ffi.import: (mkdir [Path] #io #try ffi.Boolean)) + + ## (def: byte_array_format "C*") + ## (def: default_separator (..DIRECTORY_SEPARATOR)) + + ## (template [<name>] + ## [(exception: #export (<name> {file Path}) + ## (exception.report + ## ["Path" file]))] + + ## [cannot_write_to_file] + ## ) + + ## (`` (implementation: (file path) + ## (-> Path (File IO)) + + ## (~~ (template [<name> <mode>] + ## [(def: (<name> data) + ## (do {! (try.with io.monad)} + ## [outcome (..file_put_contents [path ("php pack" ..byte_array_format data) <mode>])] + ## (if (bit\= false (:as Bit outcome)) + ## (\ io.monad wrap (exception.throw ..cannot_write_to_file [path])) + ## (wrap []))))] + + ## [over_write +0] + ## [append (..FILE_APPEND)] + ## )) + + ## (def: (content _) + ## (do {! (try.with io.monad)} + ## [data (..file_get_contents [path])] + ## (if (bit\= false (:as Bit data)) + ## (\ io.monad wrap (exception.throw ..cannot_find_file [path])) + ## (wrap (..unpack [..byte_array_format data]))))) + + ## (def: path + ## path) + + ## (~~ (template [<name> <ffi> <pipeline>] + ## [(def: (<name> _) + ## (do {! (try.with io.monad)} + ## [value (<ffi> [path])] + ## (if (bit\= false (:as Bit value)) + ## (\ io.monad wrap (exception.throw ..cannot_find_file [path])) + ## (wrap (`` (|> value (~~ (template.splice <pipeline>))))))))] + + ## [size ..filesize [.nat]] + ## [last_modified ..filemtime [(i.* +1,000) duration.from_millis instant.absolute]] + ## )) + + ## (def: (can_execute? _) + ## (..is_executable [path])) + + ## (def: (modify moment) + ## (do {! (try.with io.monad)} + ## [verdict (..touch [path (|> moment instant.relative duration.to_millis (i./ +1,000))])] + ## (if (bit\= false (:as Bit verdict)) + ## (\ io.monad wrap (exception.throw ..cannot_find_file [path])) + ## (wrap [])))) + + ## (def: (move destination) + ## (do {! (try.with io.monad)} + ## [verdict (..rename [path destination])] + ## (if (bit\= false (:as Bit verdict)) + ## (\ io.monad wrap (exception.throw ..cannot_find_file [path])) + ## (wrap (file destination))))) + + ## (def: (delete _) + ## (do (try.with io.monad) + ## [verdict (..unlink [path])] + ## (if (bit\= false (:as Bit verdict)) + ## (\ io.monad wrap (exception.throw ..cannot_find_file [path])) + ## (wrap [])))) + ## )) + + ## (`` (implementation: (directory path) + ## (-> Path (Directory IO)) + + ## (def: scope + ## path) + + ## (~~ (template [<name> <test> <constructor> <capability>] + ## [(def: (<name> _) + ## (do {! (try.with io.monad)} + ## [children (..scandir [path])] + ## (loop [input (|> children + ## array.to_list + ## (list.filter (function (_ child) + ## (not (or (text\= "." child) + ## (text\= ".." child)))))) + ## output (: (List (<capability> IO)) + ## (list))] + ## (case input + ## #.Nil + ## (wrap output) + + ## (#.Cons head tail) + ## (do ! + ## [verdict (<test> head)] + ## (if verdict + ## (recur tail (#.Cons (<constructor> head) output)) + ## (recur tail output)))))))] + + ## [files ..is_file ..file File] + ## [directories ..is_dir directory Directory] + ## )) + + ## (def: (discard _) + ## (do (try.with io.monad) + ## [verdict (..rmdir [path])] + ## (if (bit\= false (:as Bit verdict)) + ## (\ io.monad wrap (exception.throw ..cannot_find_directory [path])) + ## (wrap [])))) + ## )) + + ## (`` (implementation: #export default + ## (System IO) + + ## (~~ (template [<name> <test> <constructor> <exception>] + ## [(def: (<name> path) + ## (do {! (try.with io.monad)} + ## [verdict (<test> path)] + ## (\ io.monad wrap + ## (if verdict + ## (#try.Success (<constructor> path)) + ## (exception.throw <exception> [path])))))] + + ## [file ..is_file ..file ..cannot_find_file] + ## [directory ..is_dir ..directory ..cannot_find_directory] + ## )) + + ## (def: (make_file path) + ## (do {! (try.with io.monad)} + ## [verdict (..touch [path (|> instant.now io.run instant.relative duration.to_millis (i./ +1,000))])] + ## (\ io.monad wrap + ## (if verdict + ## (#try.Success (..file path)) + ## (exception.throw ..cannot_make_file [path]))))) + + ## (def: (make_directory path) + ## (do {! (try.with io.monad)} + ## [verdict (..mkdir path)] + ## (\ io.monad wrap + ## (if verdict + ## (#try.Success (..directory path)) + ## (exception.throw ..cannot_make_directory [path]))))) + + ## (def: separator + ## ..default_separator) + ## )) + ## ) + } + (as_is))) + +(def: #export (exists? monad fs path) + (All [!] (-> (Monad !) (System !) Path (! Bit))) + (do monad + [verdict (\ fs file? path)] + (if verdict + (wrap verdict) + (\ fs directory? path)))) + +(type: Mock_File + {#mock_last_modified Instant + #mock_can_execute Bit + #mock_content Binary}) + +(type: #rec Mock + (Dictionary Text (Either Mock_File Mock))) + +(def: empty_mock + Mock + (dictionary.new text.hash)) + +(def: (retrieve_mock_file! separator path mock) + (-> Text Path Mock (Try [Text Mock_File])) + (loop [directory mock + trail (text.split_all_with separator path)] + (case trail + (#.Cons head tail) + (case (dictionary.get head directory) + #.None + (exception.throw ..cannot_find_file [path]) + + (#.Some node) + (case [node tail] + [(#.Left file) #.Nil] + (#try.Success [head file]) + + [(#.Right sub_directory) (#.Cons _)] + (recur sub_directory tail) + + _ + (exception.throw ..cannot_find_file [path]))) + + #.Nil + (exception.throw ..cannot_find_file [path])))) + +(def: (update_mock_file! / path now content mock) + (-> Text Path Instant Binary Mock (Try Mock)) + (loop [directory mock + trail (text.split_all_with / path)] + (case trail + (#.Cons head tail) + (case (dictionary.get head directory) + #.None + (case tail + #.Nil + (#try.Success (dictionary.put head + (#.Left {#mock_last_modified now + #mock_can_execute false + #mock_content content}) + directory)) + + (#.Cons _) + (exception.throw ..cannot_find_file [path])) + + (#.Some node) + (case [node tail] + [(#.Left file) #.Nil] + (#try.Success (dictionary.put head + (#.Left (|> file + (set@ #mock_last_modified now) + (set@ #mock_content content))) + directory)) + + [(#.Right sub_directory) (#.Cons _)] + (do try.monad + [sub_directory (recur sub_directory tail)] + (wrap (dictionary.put head (#.Right sub_directory) directory))) + + _ + (exception.throw ..cannot_find_file [path]))) + + #.Nil + (exception.throw ..cannot_find_file [path])))) + +(def: (mock_delete! / path mock) + (-> Text Path Mock (Try Mock)) + (loop [directory mock + trail (text.split_all_with / path)] + (case trail + (#.Cons head tail) + (case (dictionary.get head directory) + #.None + (exception.throw ..cannot_delete [path]) + + (#.Some node) + (case tail + #.Nil + (case node + (#.Left file) + (#try.Success (dictionary.remove head directory)) + + (#.Right sub_directory) + (if (dictionary.empty? sub_directory) + (#try.Success (dictionary.remove head directory)) + (exception.throw ..cannot_delete [path]))) + + (#.Cons _) + (case node + (#.Left file) + (exception.throw ..cannot_delete [path]) + + (#.Right sub_directory) + (do try.monad + [sub_directory' (recur sub_directory tail)] + (wrap (dictionary.put head (#.Right sub_directory') directory)))))) + + #.Nil + (exception.throw ..cannot_delete [path])))) + +(def: (try_update! transform var) + (All [a] (-> (-> a (Try a)) (Var a) (STM (Try Any)))) + (do {! stm.monad} + [|var| (stm.read var)] + (case (transform |var|) + (#try.Success |var|) + (do ! + [_ (stm.write |var| var)] + (wrap (#try.Success []))) + + (#try.Failure error) + (wrap (#try.Failure error))))) + +(def: (make_mock_directory! / path mock) + (-> Text Path Mock (Try Mock)) + (loop [directory mock + trail (text.split_all_with / path)] + (case trail + (#.Cons head tail) + (case (dictionary.get head directory) + #.None + (case tail + #.Nil + (#try.Success (dictionary.put head (#.Right ..empty_mock) directory)) + + (#.Cons _) + (exception.throw ..cannot_make_directory [path])) + + (#.Some node) + (case [node tail] + [(#.Right sub_directory) (#.Cons _)] + (do try.monad + [sub_directory (recur sub_directory tail)] + (wrap (dictionary.put head (#.Right sub_directory) directory))) + + _ + (exception.throw ..cannot_make_directory [path]))) + + #.Nil + (exception.throw ..cannot_make_directory [path])))) + +(def: (retrieve_mock_directory! / path mock) + (-> Text Path Mock (Try Mock)) + (loop [directory mock + trail (text.split_all_with / path)] + (case trail + #.Nil + (#try.Success directory) + + (#.Cons head tail) + (case (dictionary.get head directory) + #.None + (exception.throw ..cannot_find_directory [path]) + + (#.Some node) + (case node + (#.Left _) + (exception.throw ..cannot_find_directory [path]) + + (#.Right sub_directory) + (case tail + #.Nil + (#try.Success sub_directory) + + (#.Cons _) + (recur sub_directory tail))))))) + +(def: #export (mock separator) + (-> Text (System Promise)) + (let [store (stm.var ..empty_mock)] + (`` (implementation + (def: separator + separator) + + (~~ (template [<method> <retrieve>] + [(def: (<method> path) + (|> store + stm.read + (\ stm.monad map + (|>> (<retrieve> separator path) + (try\map (function.constant true)) + (try.default false))) + stm.commit))] + + [file? ..retrieve_mock_file!] + [directory? ..retrieve_mock_directory!])) + + (def: (make_directory path) + (stm.commit + (do {! stm.monad} + [|store| (stm.read store)] + (case (..make_mock_directory! separator path |store|) + (#try.Success |store|) + (do ! + [_ (stm.write |store| store)] + (wrap (#try.Success []))) + + (#try.Failure error) + (wrap (#try.Failure error)))))) + + (~~ (template [<method> <tag>] + [(def: (<method> path) + (stm.commit + (do stm.monad + [|store| (stm.read store)] + (wrap (do try.monad + [directory (..retrieve_mock_directory! separator path |store|)] + (wrap (|> directory + dictionary.entries + (list.all (function (_ [node_name node]) + (case node + (<tag> _) + (#.Some (format path separator node_name)) + + _ + #.None))))))))))] + + [directory_files #.Left] + [sub_directories #.Right] + )) + + (def: (file_size path) + (stm.commit + (do stm.monad + [|store| (stm.read store)] + (wrap (|> |store| + (..retrieve_mock_file! separator path) + (try\map (|>> product.right + (get@ #mock_content) + binary.size))))))) + + (def: (last_modified path) + (stm.commit + (do stm.monad + [|store| (stm.read store)] + (wrap (|> |store| + (..retrieve_mock_file! separator path) + (try\map (|>> product.right + (get@ #mock_last_modified)))))))) + + (def: (can_execute? path) + (stm.commit + (do stm.monad + [|store| (stm.read store)] + (wrap (|> |store| + (..retrieve_mock_file! separator path) + (try\map (|>> product.right + (get@ #mock_can_execute)))))))) + + (def: (read path) + (stm.commit + (do stm.monad + [|store| (stm.read store)] + (wrap (|> |store| + (..retrieve_mock_file! separator path) + (try\map (|>> product.right + (get@ #mock_content)))))))) + + (def: (delete path) + (stm.commit + (..try_update! (..mock_delete! separator path) store))) + + (def: (modify now path) + (stm.commit + (..try_update! (function (_ |store|) + (do try.monad + [[name file] (..retrieve_mock_file! separator path |store|)] + (..update_mock_file! separator path now (get@ #mock_content file) |store|))) + store))) + + (def: (write content path) + (do promise.monad + [now (promise.future instant.now)] + (stm.commit + (..try_update! (..update_mock_file! separator path now content) store)))) + + (def: (append content path) + (do promise.monad + [now (promise.future instant.now)] + (stm.commit + (..try_update! (function (_ |store|) + (do try.monad + [[name file] (..retrieve_mock_file! separator path |store|)] + (..update_mock_file! separator path now + (\ binary.monoid compose + (get@ #mock_content file) + content) + |store|))) + store)))) + + (def: (move destination origin) + (stm.commit + (do {! stm.monad} + [|store| (stm.read store)] + (case (do try.monad + [[name file] (..retrieve_mock_file! separator origin |store|) + |store| (..mock_delete! separator origin |store|)] + (..update_mock_file! separator destination (get@ #mock_last_modified file) (get@ #mock_content file) |store|)) + (#try.Success |store|) + (do ! + [_ (stm.write |store| store)] + (wrap (#try.Success []))) + + (#try.Failure error) + (wrap (#try.Failure error)))))) + )))) + +(def: (check_or_make_directory monad fs path) + (All [!] (-> (Monad !) (System !) Path (! (Try Any)))) + (do monad + [? (\ fs directory? path)] + (if ? + (wrap (#try.Success [])) + (\ fs make_directory path)))) + +(def: #export (make_directories monad fs path) + (All [!] (-> (Monad !) (System !) Path (! (Try Any)))) + (let [rooted? (text.starts_with? (\ fs separator) path) + segments (text.split_all_with (\ fs separator) path)] + (case (if rooted? + (list.drop 1 segments) + segments) + #.Nil + (\ monad wrap (exception.throw ..cannot_make_directory [path])) + + (#.Cons head tail) + (case head + "" (\ monad wrap (exception.throw ..cannot_make_directory [path])) + _ (loop [current (if rooted? + (format (\ fs separator) head) + head) + next tail] + (do monad + [? (..check_or_make_directory monad fs current)] + (case ? + (#try.Success _) + (case next + #.Nil + (wrap (#try.Success [])) + + (#.Cons head tail) + (recur (format current (\ fs separator) head) + tail)) + + (#try.Failure error) + (wrap (#try.Failure error))))))))) + +(def: #export (make_file monad fs content path) + (All [!] (-> (Monad !) (System !) Binary Path (! (Try Any)))) + (do monad + [? (\ fs file? path)] + (if ? + (wrap (exception.throw ..cannot_make_file [path])) + (\ fs write content path)))) diff --git a/stdlib/source/library/lux/world/file/watch.lux b/stdlib/source/library/lux/world/file/watch.lux new file mode 100644 index 000000000..df655ed9c --- /dev/null +++ b/stdlib/source/library/lux/world/file/watch.lux @@ -0,0 +1,459 @@ +(.module: + [library + [lux #* + ["@" target] + ["." ffi (#+ import:)] + [abstract + [predicate (#+ Predicate)] + ["." monad (#+ do)]] + [control + ["." io (#+ IO)] + ["." try (#+ Try)] + ["." exception (#+ exception:)] + [concurrency + ["." promise (#+ Promise)] + ["." stm (#+ STM Var)]]] + [data + ["." product] + ["." maybe] + ["." text + ["%" format (#+ format)]] + [collection + ["." dictionary (#+ Dictionary)] + ["." list ("#\." functor monoid fold)] + ["." set] + ["." array]]] + [math + [number + ["n" nat]]] + [time + ["." instant (#+ Instant) ("#\." equivalence)]] + [type + [abstract (#+ abstract: :representation :abstraction)]]]] + ["." //]) + +(abstract: #export Concern + {#create Bit + #modify Bit + #delete Bit} + + (def: none + Concern + (:abstraction + {#create false + #modify false + #delete false})) + + (template [<concern> <predicate> <event> <create> <modify> <delete>] + [(def: #export <concern> + Concern + (:abstraction + {#create <create> + #modify <modify> + #delete <delete>})) + + (def: #export <predicate> + (Predicate Concern) + (|>> :representation (get@ <event>)))] + + [creation creation? #create + true false false] + [modification modification? #modify + false true false] + [deletion deletion? #delete + false false true] + ) + + (def: #export (also left right) + (-> Concern Concern Concern) + (:abstraction + {#create (or (..creation? left) (..creation? right)) + #modify (or (..modification? left) (..modification? right)) + #delete (or (..deletion? left) (..deletion? right))})) + + (def: #export all + Concern + ($_ ..also + ..creation + ..modification + ..deletion + )) + ) + +(interface: #export (Watcher !) + (: (-> Concern //.Path (! (Try Any))) + start) + (: (-> //.Path (! (Try Concern))) + concern) + (: (-> //.Path (! (Try Concern))) + stop) + (: (-> [] (! (Try (List [Concern //.Path])))) + poll)) + +(template [<name>] + [(exception: #export (<name> {path //.Path}) + (exception.report + ["Path" (%.text path)]))] + + [not_being_watched] + [cannot_poll_a_non_existent_directory] + ) + +(type: File_Tracker + (Dictionary //.Path Instant)) + +(type: Directory_Tracker + (Dictionary //.Path [Concern File_Tracker])) + +(def: (update_watch! new_concern path tracker) + (-> Concern //.Path (Var Directory_Tracker) (STM Bit)) + (do {! stm.monad} + [@tracker (stm.read tracker)] + (case (dictionary.get path @tracker) + (#.Some [old_concern last_modified]) + (do ! + [_ (stm.update (dictionary.put path [new_concern last_modified]) tracker)] + (wrap true)) + + #.None + (wrap false)))) + +(def: (file_tracker fs directory) + (-> (//.System Promise) //.Path (Promise (Try File_Tracker))) + (do {! (try.with promise.monad)} + [files (\ fs directory_files directory)] + (monad.fold ! + (function (_ file tracker) + (do ! + [last_modified (\ fs last_modified file)] + (wrap (dictionary.put file last_modified tracker)))) + (: File_Tracker + (dictionary.new text.hash)) + files))) + +(def: (poll_files fs directory) + (-> (//.System Promise) //.Path (Promise (Try (List [//.Path Instant])))) + (do {! (try.with promise.monad)} + [files (\ fs directory_files directory)] + (monad.map ! (function (_ file) + (|> file + (\ fs last_modified) + (\ ! map (|>> [file])))) + files))) + +(def: (poll_directory_changes fs [directory [concern file_tracker]]) + (-> (//.System Promise) [//.Path [Concern File_Tracker]] + (Promise (Try [[//.Path [Concern File_Tracker]] + [(List [//.Path Instant]) + (List [//.Path Instant Instant]) + (List //.Path)]]))) + (do {! (try.with promise.monad)} + [current_files (..poll_files fs directory) + #let [creations (if (..creation? concern) + (list.filter (|>> product.left (dictionary.key? file_tracker) not) + current_files) + (list)) + available (|> current_files + (list\map product.left) + (set.from_list text.hash)) + deletions (if (..deletion? concern) + (|> (dictionary.entries file_tracker) + (list\map product.left) + (list.filter (|>> (set.member? available) not))) + (list)) + modifications (list.all (function (_ [path current_modification]) + (do maybe.monad + [previous_modification (dictionary.get path file_tracker)] + (wrap [path previous_modification current_modification]))) + current_files)]] + (wrap [[directory + [concern + (let [with_deletions (list\fold dictionary.remove file_tracker deletions) + with_creations (list\fold (function (_ [path last_modified] tracker) + (dictionary.put path last_modified tracker)) + with_deletions + creations) + with_modifications (list\fold (function (_ [path previous_modification current_modification] tracker) + (dictionary.put path current_modification tracker)) + with_creations + modifications)] + with_modifications)]] + [creations + modifications + deletions]]))) + +(def: #export (polling fs) + (-> (//.System Promise) (Watcher Promise)) + (let [tracker (: (Var Directory_Tracker) + (stm.var (dictionary.new text.hash)))] + (implementation + (def: (start new_concern path) + (do {! promise.monad} + [exists? (\ fs directory? path)] + (if exists? + (do ! + [updated? (stm.commit (..update_watch! new_concern path tracker))] + (if updated? + (wrap (#try.Success [])) + (do (try.with !) + [file_tracker (..file_tracker fs path)] + (do ! + [_ (stm.commit (stm.update (dictionary.put path [new_concern file_tracker]) tracker))] + (wrap (#try.Success [])))))) + (wrap (exception.throw ..cannot_poll_a_non_existent_directory [path]))))) + (def: (concern path) + (stm.commit + (do stm.monad + [@tracker (stm.read tracker)] + (wrap (case (dictionary.get path @tracker) + (#.Some [concern file_tracker]) + (#try.Success concern) + + #.None + (exception.throw ..not_being_watched [path])))))) + (def: (stop path) + (stm.commit + (do {! stm.monad} + [@tracker (stm.read tracker)] + (case (dictionary.get path @tracker) + (#.Some [concern file_tracker]) + (do ! + [_ (stm.update (dictionary.remove path) tracker)] + (wrap (#try.Success concern))) + + #.None + (wrap (exception.throw ..not_being_watched [path])))))) + (def: (poll _) + (do promise.monad + [@tracker (stm.commit (stm.read tracker))] + (do {! (try.with promise.monad)} + [changes (|> @tracker + dictionary.entries + (monad.map ! (..poll_directory_changes fs))) + _ (do promise.monad + [_ (stm.commit (stm.write (|> changes + (list\map product.left) + (dictionary.from_list text.hash)) + tracker))] + (wrap (#try.Success []))) + #let [[creations modifications deletions] + (list\fold (function (_ [_ [creations modifications deletions]] + [all_creations all_modifications all_deletions]) + [(list\compose creations all_creations) + (list\compose modifications all_modifications) + (list\compose deletions all_deletions)]) + [(list) (list) (list)] + changes)]] + (wrap ($_ list\compose + (list\map (|>> product.left [..creation]) creations) + (|> modifications + (list.filter (function (_ [path previous_modification current_modification]) + (not (instant\= previous_modification current_modification)))) + (list\map (|>> product.left [..modification]))) + (list\map (|>> [..deletion]) deletions) + ))))) + ))) + +(def: #export (mock separator) + (-> Text [(//.System Promise) (Watcher Promise)]) + (let [fs (//.mock separator)] + [fs + (..polling fs)])) + +(with_expansions [<jvm> (as_is (import: java/lang/Object) + + (import: java/lang/String) + + (import: (java/util/List a) + ["#::." + (size [] int) + (get [int] a)]) + + (def: (default_list list) + (All [a] (-> (java/util/List a) (List a))) + (let [size (.nat (java/util/List::size list))] + (loop [idx 0 + output #.Nil] + (if (n.< size idx) + (recur (inc idx) + (#.Cons (java/util/List::get (.int idx) list) + output)) + output)))) + + (import: (java/nio/file/WatchEvent$Kind a)) + + (import: (java/nio/file/WatchEvent a) + ["#::." + (kind [] (java/nio/file/WatchEvent$Kind a))]) + + (import: java/nio/file/Watchable) + + (import: java/nio/file/Path + ["#::." + (register [java/nio/file/WatchService [(java/nio/file/WatchEvent$Kind [? < java/lang/Object])]] #io #try java/nio/file/WatchKey) + (toString [] java/lang/String)]) + + (import: java/nio/file/StandardWatchEventKinds + ["#::." + (#static ENTRY_CREATE (java/nio/file/WatchEvent$Kind java/nio/file/Path)) + (#static ENTRY_MODIFY (java/nio/file/WatchEvent$Kind java/nio/file/Path)) + (#static ENTRY_DELETE (java/nio/file/WatchEvent$Kind java/nio/file/Path))]) + + (def: (default_event_concern event) + (All [a] + (-> (java/nio/file/WatchEvent a) Concern)) + (let [kind (:as (java/nio/file/WatchEvent$Kind java/nio/file/Path) + (java/nio/file/WatchEvent::kind event))] + (cond (is? (java/nio/file/StandardWatchEventKinds::ENTRY_CREATE) + kind) + ..creation + + (is? (java/nio/file/StandardWatchEventKinds::ENTRY_MODIFY) + kind) + ..modification + + (is? (java/nio/file/StandardWatchEventKinds::ENTRY_DELETE) + kind) + ..deletion + + ## else + ..none + ))) + + (import: java/nio/file/WatchKey + ["#::." + (reset [] #io boolean) + (cancel [] #io void) + (watchable [] java/nio/file/Watchable) + (pollEvents [] #io (java/util/List (java/nio/file/WatchEvent ?)))]) + + (def: default_key_concern + (-> java/nio/file/WatchKey (IO Concern)) + (|>> java/nio/file/WatchKey::pollEvents + (\ io.monad map (|>> ..default_list + (list\map default_event_concern) + (list\fold ..also ..none))))) + + (import: java/nio/file/WatchService + ["#::." + (poll [] #io #try #? java/nio/file/WatchKey)]) + + (import: java/nio/file/FileSystem + ["#::." + (newWatchService [] #io #try java/nio/file/WatchService)]) + + (import: java/nio/file/FileSystems + ["#::." + (#static getDefault [] java/nio/file/FileSystem)]) + + (import: java/io/File + ["#::." + (new [java/lang/String]) + (toPath [] java/nio/file/Path)]) + + (type: Watch_Event + (java/nio/file/WatchEvent$Kind java/lang/Object)) + + (def: (default_start watch_events watcher path) + (-> (List Watch_Event) java/nio/file/WatchService //.Path (Promise (Try java/nio/file/WatchKey))) + (let [watch_events' (list\fold (function (_ [index watch_event] watch_events') + (ffi.array_write index watch_event watch_events')) + (ffi.array (java/nio/file/WatchEvent$Kind java/lang/Object) + (list.size watch_events)) + (list.enumeration watch_events))] + (promise.future + (java/nio/file/Path::register watcher + watch_events' + (|> path java/io/File::new java/io/File::toPath))))) + + (def: (default_poll watcher) + (-> java/nio/file/WatchService (IO (Try (List [Concern //.Path])))) + (loop [output (: (List [Concern //.Path]) + (list))] + (do (try.with io.monad) + [?key (java/nio/file/WatchService::poll watcher)] + (case ?key + (#.Some key) + (do {! io.monad} + [valid? (java/nio/file/WatchKey::reset key)] + (if valid? + (do ! + [#let [path (|> key + java/nio/file/WatchKey::watchable + (:as java/nio/file/Path) + java/nio/file/Path::toString + (:as //.Path))] + concern (..default_key_concern key)] + (recur (#.Cons [concern path] + output))) + (recur output))) + + #.None + (wrap output))))) + + (def: (watch_events concern) + (-> Concern (List Watch_Event)) + ($_ list\compose + (if (..creation? concern) + (list (:as Watch_Event (java/nio/file/StandardWatchEventKinds::ENTRY_CREATE))) + (list)) + (if (..modification? concern) + (list (:as Watch_Event (java/nio/file/StandardWatchEventKinds::ENTRY_MODIFY))) + (list)) + (if (..deletion? concern) + (list (:as Watch_Event (java/nio/file/StandardWatchEventKinds::ENTRY_DELETE))) + (list)) + )) + + (def: #export default + (IO (Try (Watcher Promise))) + (do (try.with io.monad) + [watcher (java/nio/file/FileSystem::newWatchService + (java/nio/file/FileSystems::getDefault)) + #let [tracker (stm.var (: (Dictionary //.Path [Concern java/nio/file/WatchKey]) + (dictionary.new text.hash))) + + stop (: (-> //.Path (Promise (Try Concern))) + (function (_ path) + (do {! promise.monad} + [@tracker (stm.commit (stm.read tracker))] + (case (dictionary.get path @tracker) + (#.Some [concern key]) + (do ! + [_ (promise.future + (java/nio/file/WatchKey::cancel key)) + _ (stm.commit (stm.update (dictionary.remove path) tracker))] + (wrap (#try.Success concern))) + + #.None + (wrap (exception.throw ..not_being_watched [path]))))))]] + (wrap (: (Watcher Promise) + (implementation + (def: (start concern path) + (do promise.monad + [?concern (stop path)] + (do (try.with promise.monad) + [key (..default_start (..watch_events (..also (try.default ..none ?concern) + concern)) + watcher + path)] + (do promise.monad + [_ (stm.commit (stm.update (dictionary.put path [concern key]) tracker))] + (wrap (#try.Success [])))))) + (def: (concern path) + (do promise.monad + [@tracker (stm.commit (stm.read tracker))] + (case (dictionary.get path @tracker) + (#.Some [concern key]) + (wrap (#try.Success concern)) + + #.None + (wrap (exception.throw ..not_being_watched [path]))))) + (def: stop stop) + (def: (poll _) + (promise.future (..default_poll watcher))) + ))))) + )] + (for {@.old (as_is <jvm>) + @.jvm (as_is <jvm>)} + (as_is))) diff --git a/stdlib/source/library/lux/world/input/keyboard.lux b/stdlib/source/library/lux/world/input/keyboard.lux new file mode 100644 index 000000000..8c65fe493 --- /dev/null +++ b/stdlib/source/library/lux/world/input/keyboard.lux @@ -0,0 +1,112 @@ +(.module: + [library + [lux #*]]) + +(type: #export Key + Nat) + +(template [<code> <name>] + [(def: #export <name> Key <code>)] + + [00008 back_space] + [00010 enter] + [00016 shift] + [00017 control] + [00018 alt] + [00020 caps_lock] + [00027 escape] + [00032 space] + [00033 page_up] + [00034 page_down] + [00035 end] + [00036 home] + + [00037 left] + [00038 up] + [00039 right] + [00040 down] + + [00065 a] + [00066 b] + [00067 c] + [00068 d] + [00069 e] + [00070 f] + [00071 g] + [00072 h] + [00073 i] + [00074 j] + [00075 k] + [00076 l] + [00077 m] + [00078 n] + [00079 o] + [00080 p] + [00081 q] + [00082 r] + [00083 s] + [00084 t] + [00085 u] + [00086 v] + [00087 w] + [00088 x] + [00089 y] + [00090 z] + + [00096 num_pad_0] + [00097 num_pad_1] + [00098 num_pad_2] + [00099 num_pad_3] + [00100 num_pad_4] + [00101 num_pad_5] + [00102 num_pad_6] + [00103 num_pad_7] + [00104 num_pad_8] + [00105 num_pad_9] + + [00127 delete] + [00144 num_lock] + [00145 scroll_lock] + [00154 print_screen] + [00155 insert] + [00524 windows] + + [00112 f1] + [00113 f2] + [00114 f3] + [00115 f4] + [00116 f5] + [00117 f6] + [00118 f7] + [00119 f8] + [00120 f9] + [00121 f10] + [00122 f11] + [00123 f12] + [61440 f13] + [61441 f14] + [61442 f15] + [61443 f16] + [61444 f17] + [61445 f18] + [61446 f19] + [61447 f20] + [61448 f21] + [61449 f22] + [61450 f23] + [61451 f24] + ) + +(type: #export Press + {#pressed? Bit + #input Key}) + +(template [<bit> <name>] + [(def: #export (<name> key) + (-> Key Press) + {#pressed? <bit> + #input key})] + + [#0 release] + [#1 press] + ) diff --git a/stdlib/source/library/lux/world/net.lux b/stdlib/source/library/lux/world/net.lux new file mode 100644 index 000000000..cea1b4a7d --- /dev/null +++ b/stdlib/source/library/lux/world/net.lux @@ -0,0 +1,13 @@ +(.module: + [library + [lux (#- Location)]]) + +(type: #export Address Text) + +(type: #export Port Nat) + +(type: #export URL Text) + +(type: #export Location + {#address Address + #port Port}) diff --git a/stdlib/source/library/lux/world/net/http.lux b/stdlib/source/library/lux/world/net/http.lux new file mode 100644 index 000000000..8e205e2a0 --- /dev/null +++ b/stdlib/source/library/lux/world/net/http.lux @@ -0,0 +1,80 @@ +(.module: + [library + [lux #* + [control + [try (#+ Try)] + [concurrency + [promise (#+ Promise)] + [frp (#+ Channel)]] + [parser + ["." environment (#+ Environment)]]] + [data + [binary (#+ Binary)]]]] + [// (#+ URL) + [uri (#+ URI)]]) + +(type: #export Version + Text) + +(type: #export Method + #Post + #Get + #Put + #Patch + #Delete + #Head + #Connect + #Options + #Trace) + +(type: #export Port + Nat) + +(type: #export Status + Nat) + +(type: #export Headers + Environment) + +(def: #export empty + Headers + environment.empty) + +(type: #export Header + (-> Headers Headers)) + +(type: #export (Body !) + (-> (Maybe Nat) (! (Try [Nat Binary])))) + +(type: #export Scheme + #HTTP + #HTTPS) + +(type: #export Address + {#port Port + #host Text}) + +(type: #export Identification + {#local Address + #remote Address}) + +(type: #export Protocol + {#version Version + #scheme Scheme}) + +(type: #export Resource + {#method Method + #uri URI}) + +(type: #export (Message !) + {#headers Headers + #body (Body !)}) + +(type: #export (Request !) + [Identification Protocol Resource (Message !)]) + +(type: #export (Response !) + [Status (Message !)]) + +(type: #export (Server !) + (-> (Request !) (! (Response !)))) diff --git a/stdlib/source/library/lux/world/net/http/client.lux b/stdlib/source/library/lux/world/net/http/client.lux new file mode 100644 index 000000000..5a7a93e31 --- /dev/null +++ b/stdlib/source/library/lux/world/net/http/client.lux @@ -0,0 +1,227 @@ +(.module: + [library + [lux #* + ["@" target] + ["." ffi] + [abstract + ["." monad (#+ do)]] + [control + [pipe (#+ case>)] + ["." io (#+ IO)] + ["." try (#+ Try)] + [concurrency + ["." promise (#+ Promise)]]] + [data + ["." binary (#+ Binary)] + ["." maybe ("#\." functor)] + ["." text] + [collection + ["." dictionary]]] + [math + [number + ["n" nat] + ["i" int]]]]] + ["." // + [// (#+ URL)]]) + +(interface: #export (Client !) + (: (-> //.Method URL //.Headers (Maybe Binary) + (! (Try (//.Response !)))) + request)) + +(template [<name> <method>] + [(def: #export (<name> url headers data client) + (All [!] + (-> URL //.Headers (Maybe Binary) (Client !) + (! (Try (//.Response !))))) + (\ client request <method> url headers data))] + + [post #//.Post] + [get #//.Get] + [put #//.Put] + [patch #//.Patch] + [delete #//.Delete] + [head #//.Head] + [connect #//.Connect] + [options #//.Options] + [trace #//.Trace] + ) + +(def: default_buffer_size + (n.* 1,024 1,024)) + +(def: empty_body + [Nat Binary] + [0 (binary.create 0)]) + +(def: (body_of data) + (-> Binary [Nat Binary]) + [(binary.size data) data]) + +(with_expansions [<jvm> (as_is (ffi.import: java/lang/String) + + (ffi.import: java/lang/AutoCloseable + ["#::." + (close [] #io #try void)]) + + (ffi.import: java/io/InputStream) + + (ffi.import: java/io/OutputStream + ["#::." + (flush [] #io #try void) + (write [[byte]] #io #try void)]) + + (ffi.import: java/net/URLConnection + ["#::." + (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) + (getHeaderFieldKey [int] #io #try #? java/lang/String) + (getHeaderField [int] #io #try #? java/lang/String)]) + + (ffi.import: java/net/HttpURLConnection + ["#::." + (setRequestMethod [java/lang/String] #io #try void) + (getResponseCode [] #io #try int)]) + + (ffi.import: java/net/URL + ["#::." + (new [java/lang/String]) + (openConnection [] #io #try java/net/URLConnection)]) + + (ffi.import: java/io/BufferedInputStream + ["#::." + (new [java/io/InputStream]) + (read [[byte] int int] #io #try int)]) + + (def: jvm_method + (-> //.Method Text) + (|>> (case> #//.Post "POST" + #//.Get "GET" + #//.Put "PUT" + #//.Patch "PATCH" + #//.Delete "DELETE" + #//.Head "HEAD" + #//.Connect "CONNECT" + #//.Options "OPTIONS" + #//.Trace "TRACE"))) + + (def: (default_body input) + (-> java/io/BufferedInputStream (//.Body IO)) + (|>> (maybe\map (|>> [true])) + (maybe.default [false ..default_buffer_size]) + (case> [_ 0] + (do (try.with io.monad) + [_ (java/lang/AutoCloseable::close input)] + (wrap ..empty_body)) + + [partial? buffer_size] + (let [buffer (binary.create buffer_size)] + (if partial? + (loop [so_far +0] + (do {! (try.with io.monad)} + [#let [remaining (i.- so_far (.int buffer_size))] + bytes_read (java/io/BufferedInputStream::read buffer so_far remaining input)] + (case bytes_read + -1 (do ! + [_ (java/lang/AutoCloseable::close input)] + (wrap [(.nat so_far) buffer])) + +0 (recur so_far) + _ (if (i.= remaining bytes_read) + (wrap [buffer_size buffer]) + (recur (i.+ bytes_read so_far)))))) + (loop [so_far +0 + output (\ binary.monoid identity)] + (do {! (try.with io.monad)} + [#let [remaining (i.- so_far (.int buffer_size))] + bytes_read (java/io/BufferedInputStream::read buffer so_far remaining input)] + (case bytes_read + -1 (do ! + [_ (java/lang/AutoCloseable::close input)] + (case so_far + +0 (wrap (..body_of output)) + _ (|> buffer + (binary.slice 0 (.nat so_far)) + (\ try.functor map + (|>> (\ binary.monoid compose output) + ..body_of)) + (\ io.monad wrap)))) + +0 (recur so_far output) + _ (if (i.= remaining bytes_read) + (recur +0 + (\ binary.monoid compose output buffer)) + (recur (i.+ bytes_read so_far) + output)))))))))) + + (def: (default_headers connection) + (-> java/net/HttpURLConnection (IO (Try //.Headers))) + (loop [index +0 + headers //.empty] + (do {! (try.with io.monad)} + [?name (java/net/URLConnection::getHeaderFieldKey index connection)] + (case ?name + (#.Some name) + (do ! + [?value (java/net/URLConnection::getHeaderField index connection)] + (recur (inc index) + (dictionary.put name (maybe.default "" ?value) headers))) + + #.None + (wrap headers))))) + + (implementation: #export default + (Client IO) + + (def: (request method url headers data) + (: (IO (Try (//.Response IO))) + (do {! (try.with io.monad)} + [connection (|> url java/net/URL::new java/net/URL::openConnection) + #let [connection (:as java/net/HttpURLConnection connection)] + _ (java/net/HttpURLConnection::setRequestMethod (..jvm_method method) connection) + _ (monad.map ! (function (_ [name value]) + (java/net/URLConnection::setRequestProperty name value connection)) + (dictionary.entries headers)) + _ (case data + (#.Some data) + (do ! + [_ (java/net/URLConnection::setDoOutput true connection) + stream (java/net/URLConnection::getOutputStream connection) + _ (java/io/OutputStream::write data stream) + _ (java/io/OutputStream::flush stream) + _ (java/lang/AutoCloseable::close stream)] + (wrap [])) + + #.None + (wrap [])) + status (java/net/HttpURLConnection::getResponseCode connection) + headers (..default_headers connection) + input (|> connection + java/net/URLConnection::getInputStream + (\ ! map (|>> java/io/BufferedInputStream::new)))] + (wrap [(.nat status) + {#//.headers headers + #//.body (..default_body input)}]))))))] + (for {@.old (as_is <jvm>) + @.jvm (as_is <jvm>)} + (as_is))) + +(implementation: #export (async client) + (-> (Client IO) (Client Promise)) + + (def: (request method url headers data) + (|> (\ client request method url headers data) + promise.future + (\ promise.monad map + (|>> (case> (#try.Success [status message]) + (#try.Success [status (update@ #//.body (: (-> (//.Body IO) (//.Body Promise)) + (function (_ body) + (|>> body promise.future))) + message)]) + + (#try.Failure error) + (#try.Failure error))))))) + +(def: #export headers + (-> (List [Text Text]) //.Headers) + (dictionary.from_list text.hash)) diff --git a/stdlib/source/library/lux/world/net/http/cookie.lux b/stdlib/source/library/lux/world/net/http/cookie.lux new file mode 100644 index 000000000..08a75fecc --- /dev/null +++ b/stdlib/source/library/lux/world/net/http/cookie.lux @@ -0,0 +1,88 @@ +(.module: + [library + [lux #* + [control + [monad (#+ do)] + ["." try (#+ Try)] + ["p" parser ("#\." monad) + ["l" text (#+ Parser)]]] + [data + [number + ["i" int]] + [text + ["%" format (#+ format)]] + [format + ["." context (#+ Context)]] + [collection + ["." dictionary]]] + [time + ["." duration (#+ Duration)]]]] + ["." // (#+ Header) + ["." header]]) + +(type: #export Directive (-> Text Text)) + +(def: (directive extension) + (-> Text Directive) + (function (_ so-far) + (format so-far "; " extension))) + +(def: #export (set name value) + (-> Text Text Header) + (header.add "Set-Cookie" (format name "=" value))) + +(def: #export (max-age duration) + (-> Duration Directive) + (let [seconds (duration.query duration.second duration)] + (..directive (format "Max-Age=" (if (i.< +0 seconds) + (%.int seconds) + (%.nat (.nat seconds))))))) + +(template [<name> <prefix>] + [(def: #export (<name> value) + (-> Text Directive) + (..directive (format <prefix> "=" value)))] + + [domain "Domain"] + [path "Path"] + ) + +(template [<name> <tag>] + [(def: #export <name> + Directive + (..directive <tag>))] + + [secure "Secure"] + [http-only "HttpOnly"] + ) + +(type: #export CSRF-Policy + #Strict + #Lax) + +(def: #export (same-site policy) + (-> CSRF-Policy Directive) + (..directive (format "SameSite=" (case policy + #Strict "Strict" + #Lax "Lax")))) + +(def: (cookie context) + (-> Context (Parser Context)) + (do p.monad + [key (l.slice (l.many! (l.none-of! "="))) + _ (l.this "=") + value (l.slice (l.many! (l.none-of! ";")))] + (wrap (dictionary.put key value context)))) + +(def: (cookies context) + (-> Context (Parser Context)) + ($_ p.either + (do p.monad + [context' (..cookie context) + _ (l.this "; ")] + (cookies context')) + (p\wrap context))) + +(def: #export (get header) + (-> Text (Try Context)) + (l.run header (..cookies context.empty))) diff --git a/stdlib/source/library/lux/world/net/http/header.lux b/stdlib/source/library/lux/world/net/http/header.lux new file mode 100644 index 000000000..e5b1882ad --- /dev/null +++ b/stdlib/source/library/lux/world/net/http/header.lux @@ -0,0 +1,35 @@ +(.module: + [library + [lux #* + [control + [pipe (#+ case>)]] + [data + [text + ["%" format (#+ format)]] + [collection + ["." dictionary (#+ Dictionary)]]]]] + [// (#+ Header) + ["." mime (#+ MIME)] + [// (#+ URL)]]) + +(def: #export (add name value) + (-> Text Text Header) + (dictionary.upsert name "" + (|>> (case> + "" + value + + previous + (format previous "," value))))) + +(def: #export content-length + (-> Nat Header) + (|>> %.nat (..add "Content-Length"))) + +(def: #export content-type + (-> MIME Header) + (|>> mime.name (..add "Content-Type"))) + +(def: #export location + (-> URL Header) + (..add "Location")) diff --git a/stdlib/source/library/lux/world/net/http/mime.lux b/stdlib/source/library/lux/world/net/http/mime.lux new file mode 100644 index 000000000..859b0840e --- /dev/null +++ b/stdlib/source/library/lux/world/net/http/mime.lux @@ -0,0 +1,100 @@ +(.module: + [library + [lux #* + [data + ["." text + ["%" format (#+ format)] + ["." encoding (#+ Encoding)]]] + [type + abstract]]]) + +(abstract: #export MIME + Text + + {#doc "Multipurpose Internet Mail Extensions"} + + (def: #export mime + (-> Text MIME) + (|>> :abstraction)) + + (def: #export name + (-> MIME Text) + (|>> :representation)) + ) + +## https://developer.mozilla.org/en-US/docs/Web/HTTP/Basics_of_HTTP/MIME_types/Complete_list_of_MIME_types +(template [<name> <type>] + [(def: #export <name> MIME (..mime <type>))] + + [aac-audio "audio/aac"] + [abiword "application/x-abiword"] + [avi "video/x-msvideo"] + [amazon-kindle-ebook "application/vnd.amazon.ebook"] + [binary "application/octet-stream"] + [bitmap "image/bmp"] + [bzip "application/x-bzip"] + [bzip2 "application/x-bzip2"] + [c-shell "application/x-csh"] + [css "text/css"] + [csv "text/csv"] + [microsoft-word "application/msword"] + [microsoft-word-openxml "application/vnd.openxmlformats-officedocument.wordprocessingml.document"] + [ms-embedded-opentype-fonts "application/vnd.ms-fontobject"] + [epub "application/epub+zip"] + [ecmascript "application/ecmascript"] + [gif "image/gif"] + [html "text/html"] + [icon "image/x-icon"] + [icalendar "text/calendar"] + [jar "application/java-archive"] + [jpeg "image/jpeg"] + [javascript "application/javascript"] + [json "application/json"] + [midi "audio/midi"] + [mpeg "video/mpeg"] + [apple-installer-package "application/vnd.apple.installer+xml"] + [opendocument-presentation "application/vnd.oasis.opendocument.presentation"] + [opendocument-spreadsheet "application/vnd.oasis.opendocument.spreadsheet"] + [opendocument-text "application/vnd.oasis.opendocument.text"] + [ogg-audio "audio/ogg"] + [ogg-video "video/ogg"] + [ogg "application/ogg"] + [opentype-font "font/otf"] + [png "image/png"] + [pdf "application/pdf"] + [microsoft-powerpoint "application/vnd.ms-powerpoint"] + [microsoft-powerpoint-openxml "application/vnd.openxmlformats-officedocument.presentationml.presentation"] + [rar "application/x-rar-compressed"] + [rtf "application/rtf"] + [bourne-shell "application/x-sh"] + [svg "image/svg+xml"] + [flash "application/x-shockwave-flash"] + [tar "application/x-tar"] + [tiff "image/tiff"] + [typescript "application/typescript"] + [truetype-font "font/ttf"] + [microsoft-visio "application/vnd.visio"] + [wav "audio/wav"] + [webm-audio "audio/webm"] + [webm-video "video/webm"] + [webp "image/webp"] + [woff "font/woff"] + [woff2 "font/woff2"] + [xhtml "application/xhtml+xml"] + [microsoft-excel "application/vnd.ms-excel"] + [microsoft-excel-openxml "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet"] + [xml "application/xml"] + [xul "application/vnd.mozilla.xul+xml"] + [zip "application/zip"] + [!3gpp-audio "audio/3gpp"] + [!3gpp "video/3gpp"] + [!3gpp2-audio "audio/3gpp2"] + [!3gpp2 "video/3gpp2"] + [!7z "application/x-7z-compressed"] + ) + +(def: #export (text encoding) + (-> Encoding MIME) + (..mime (format "text/plain; charset=" text.double-quote (encoding.name encoding) text.double-quote))) + +(def: #export utf-8 MIME (..text encoding.utf-8)) diff --git a/stdlib/source/library/lux/world/net/http/query.lux b/stdlib/source/library/lux/world/net/http/query.lux new file mode 100644 index 000000000..b6b8936b7 --- /dev/null +++ b/stdlib/source/library/lux/world/net/http/query.lux @@ -0,0 +1,65 @@ +(.module: + [library + [lux #* + [control + pipe + [monad (#+ do)] + ["." try (#+ Try)] + ["p" parser + ["l" text (#+ Parser)]]] + [data + [number + ["." nat]] + ["." text + ["%" format (#+ format)]] + [format + ["." context (#+ Context)]] + [collection + ["." dictionary]]]]]) + +(def: component + (Parser Text) + (p.rec + (function (_ component) + (do {! p.monad} + [head (l.some (l.none-of "+%&;"))] + ($_ p.either + (p.after (p.either l.end + (l.this "&")) + (wrap head)) + (do ! + [_ (l.this "+") + tail component] + (wrap (format head " " tail))) + (do ! + [_ (l.this "%") + code (|> (l.exactly 2 l.hexadecimal) + (p.codec nat.hex) + (\ ! map text.from-code)) + tail component] + (wrap (format head code tail)))))))) + +(def: (form context) + (-> Context (Parser Context)) + ($_ p.either + (do p.monad + [_ l.end] + (wrap context)) + (do {! p.monad} + [key (l.some (l.none-of "=&;")) + key (l.local key ..component)] + (p.either (do ! + [_ (l.this "=") + value ..component] + (form (dictionary.put key value context))) + (do ! + [_ ($_ p.or + (l.one-of "&;") + l.end)] + (form (dictionary.put key "" context))))) + ## if invalid form data, just stop parsing... + (\ p.monad wrap context))) + +(def: #export (parameters raw) + (-> Text (Try Context)) + (l.run raw (..form context.empty))) diff --git a/stdlib/source/library/lux/world/net/http/request.lux b/stdlib/source/library/lux/world/net/http/request.lux new file mode 100644 index 000000000..4a6911798 --- /dev/null +++ b/stdlib/source/library/lux/world/net/http/request.lux @@ -0,0 +1,128 @@ +(.module: + [library + [lux #* + [control + pipe + ["." monad (#+ do)] + ["." try (#+ Try)] + [concurrency + ["." promise (#+ Promise)] + ["." frp]] + [parser + ["<.>" json]]] + [data + ["." maybe] + ["." number + ["n" nat]] + ["." text + ["." encoding]] + [format + ["." json (#+ JSON)] + ["." context (#+ Context Property)]] + [collection + ["." list ("#\." functor fold)] + ["." dictionary]]] + [world + ["." binary (#+ Binary)]]]] + ["." // (#+ Body Response Server) + ["#." response] + ["#." query] + ["#." cookie]]) + +(def: (merge inputs) + (-> (List Binary) Binary) + (let [[_ output] (try.assume + (monad.fold try.monad + (function (_ input [offset output]) + (let [amount (binary.size input)] + (\ try.functor map (|>> [(n.+ amount offset)]) + (binary.copy amount 0 input offset output)))) + [0 (|> inputs + (list\map binary.size) + (list\fold n.+ 0) + binary.create)] + inputs))] + output)) + +(def: (read-text-body body) + (-> Body (Promise (Try Text))) + (do promise.monad + [blobs (frp.consume body)] + (wrap (\ encoding.utf8 decode (merge blobs))))) + +(def: failure (//response.bad-request "")) + +(def: #export (json reader server) + (All [a] (-> (<json>.Reader a) (-> a Server) Server)) + (function (_ (^@ request [identification protocol resource message])) + (do promise.monad + [?raw (read-text-body (get@ #//.body message))] + (case (do try.monad + [raw ?raw + content (\ json.codec decode raw)] + (json.run content reader)) + (#try.Success input) + (server input request) + + (#try.Failure error) + (promise.resolved ..failure))))) + +(def: #export (text server) + (-> (-> Text Server) Server) + (function (_ (^@ request [identification protocol resource message])) + (do promise.monad + [?raw (read-text-body (get@ #//.body message))] + (case ?raw + (#try.Success content) + (server content request) + + (#try.Failure error) + (promise.resolved ..failure))))) + +(def: #export (query property server) + (All [a] (-> (Property a) (-> a Server) Server)) + (function (_ [identification protocol resource message]) + (let [full (get@ #//.uri resource) + [uri query] (|> full + (text.split-with "?") + (maybe.default [full ""]))] + (case (do try.monad + [query (//query.parameters query) + input (context.run query property)] + (wrap [[identification protocol (set@ #//.uri uri resource) message] + input])) + (#try.Success [request input]) + (server input request) + + (#try.Failure error) + (promise.resolved ..failure))))) + +(def: #export (form property server) + (All [a] (-> (Property a) (-> a Server) Server)) + (function (_ (^@ request [identification protocol resource message])) + (do promise.monad + [?body (read-text-body (get@ #//.body message))] + (case (do try.monad + [body ?body + form (//query.parameters body)] + (context.run form property)) + (#try.Success input) + (server input request) + + (#try.Failure error) + (promise.resolved ..failure))))) + +(def: #export (cookies property server) + (All [a] (-> (Property a) (-> a Server) Server)) + (function (_ (^@ request [identification protocol resource message])) + (case (do try.monad + [cookies (|> (get@ #//.headers message) + (dictionary.get "Cookie") + (maybe.default "") + //cookie.get)] + (context.run cookies property)) + (#try.Success input) + (server input request) + + (#try.Failure error) + (promise.resolved ..failure)))) diff --git a/stdlib/source/library/lux/world/net/http/response.lux b/stdlib/source/library/lux/world/net/http/response.lux new file mode 100644 index 000000000..0ca825a44 --- /dev/null +++ b/stdlib/source/library/lux/world/net/http/response.lux @@ -0,0 +1,74 @@ +(.module: + [library + [lux (#- static) + [control + [concurrency + ["." promise] + ["." frp ("#\." monad)]]] + [data + ["." text + ["." encoding]] + [format + ["." html] + ["." css (#+ CSS)] + ["." context] + ["." json (#+ JSON) ("#\." codec)]]] + ["." io] + [world + ["." binary (#+ Binary)]]]] + ["." // (#+ Status Body Response Server) + ["." status] + ["." mime (#+ MIME)] + ["." header] + [// (#+ URL)]]) + +(def: #export (static response) + (-> Response Server) + (function (_ request) + (promise.resolved response))) + +(def: #export empty + (-> Status Response) + (let [body (frp\wrap (\ encoding.utf8 encode ""))] + (function (_ status) + [status + {#//.headers (|> context.empty + (header.content-length 0) + (header.content-type mime.utf-8)) + #//.body body}]))) + +(def: #export (temporary-redirect to) + (-> URL Response) + (let [[status message] (..empty status.temporary-redirect)] + [status (update@ #//.headers (header.location to) message)])) + +(def: #export not-found + Response + (..empty status.not-found)) + +(def: #export (content status type data) + (-> Status MIME Binary Response) + [status + {#//.headers (|> context.empty + (header.content-length (binary.size data)) + (header.content-type type)) + #//.body (frp\wrap data)}]) + +(def: #export bad-request + (-> Text Response) + (|>> (\ encoding.utf8 encode) (content status.bad-request mime.utf-8))) + +(def: #export ok + (-> MIME Binary Response) + (content status.ok)) + +(template [<name> <type> <mime> <pre>] + [(def: #export <name> + (-> <type> Response) + (|>> <pre> (\ encoding.utf8 encode) (..ok <mime>)))] + + [text Text mime.utf-8 (<|)] + [html html.Document mime.html html.html] + [css CSS mime.css css.css] + [json JSON mime.json json\encode] + ) diff --git a/stdlib/source/library/lux/world/net/http/route.lux b/stdlib/source/library/lux/world/net/http/route.lux new file mode 100644 index 000000000..456ed9e36 --- /dev/null +++ b/stdlib/source/library/lux/world/net/http/route.lux @@ -0,0 +1,74 @@ +(.module: + [library + [lux (#- or) + [control + [monad (#+ do)] + [concurrency + ["." promise]]] + [data + ["." maybe] + ["." text] + [number + ["n" nat]]]]] + ["." // (#+ URI Server) + ["#." status] + ["#." response]]) + +(template [<scheme> <name>] + [(def: #export (<name> server) + (-> Server Server) + (function (_ (^@ request [identification protocol resource message])) + (case (get@ #//.scheme protocol) + <scheme> + (server request) + + _ + (promise.resolved //response.not-found))))] + + [#//.HTTP http] + [#//.HTTPS https] + ) + +(template [<method> <name>] + [(def: #export (<name> server) + (-> Server Server) + (function (_ (^@ request [identification protocol resource message])) + (case (get@ #//.method resource) + <method> + (server request) + + _ + (promise.resolved //response.not-found))))] + + [#//.Get get] + [#//.Post post] + [#//.Put put] + [#//.Patch patch] + [#//.Delete delete] + [#//.Head head] + [#//.Connect connect] + [#//.Options options] + [#//.Trace trace] + ) + +(def: #export (uri path server) + (-> URI Server Server) + (function (_ [identification protocol resource message]) + (if (text.starts-with? path (get@ #//.uri resource)) + (server [identification + protocol + (update@ #//.uri + (|>> (text.clip' (text.size path)) maybe.assume) + resource) + message]) + (promise.resolved //response.not-found)))) + +(def: #export (or primary alternative) + (-> Server Server Server) + (function (_ request) + (do promise.monad + [response (primary request) + #let [[status message] response]] + (if (n.= //status.not-found status) + (alternative request) + (wrap response))))) diff --git a/stdlib/source/library/lux/world/net/http/status.lux b/stdlib/source/library/lux/world/net/http/status.lux new file mode 100644 index 000000000..fe3f7d90d --- /dev/null +++ b/stdlib/source/library/lux/world/net/http/status.lux @@ -0,0 +1,83 @@ +(.module: + [library + [lux #*]] + [// (#+ Status)]) + +## https://en.wikipedia.org/wiki/List_of_HTTP_status_codes +(template [<status> <name>] + [(def: #export <name> + Status + <status>)] + + ## 1xx Informational response + [100 continue] + [101 switching_protocols] + [102 processing] + [103 early_hints] + + ## 2xx Success + [200 ok] + [201 created] + [202 accepted] + [203 non_authoritative_information] + [204 no_content] + [205 reset_content] + [206 partial_content] + [207 multi_status] + [208 already_reported] + [226 im_used] + + ## 3xx Redirection + [300 multiple_choices] + [301 moved_permanently] + [302 found] + [303 see_other] + [304 not_modified] + [305 use_proxy] + [306 switch_proxy] + [307 temporary_redirect] + [308 permanent_redirect] + + ## 4xx Client errors + [400 bad_request] + [401 unauthorized] + [402 payment_required] + [403 forbidden] + [404 not_found] + [405 method_not_allowed] + [406 not_acceptable] + [407 proxy_authentication_required] + [408 request_timeout] + [409 conflict] + [410 gone] + [411 length_required] + [412 precondition_failed] + [413 payload_too_large] + [414 uri_too_long] + [415 unsupported_media_type] + [416 range_not_satisfiable] + [417 expectation_failed] + [418 im_a_teapot] + [421 misdirected_request] + [422 unprocessable_entity] + [423 locked] + [424 failed_dependency] + [426 upgrade_required] + [428 precondition_required] + [429 too_many_requests] + [431 request_header_fields_too_large] + [451 unavailable_for_legal_reasons] + + ## 5xx Server errors + [500 internal_server_error] + [501 not_implemented] + [502 bad_gateway] + [503 service_unavailable] + [504 gateway_timeout] + [505 http_version_not_supported] + [506 variant_also_negotiates] + [507 insufficient_storage] + [508 loop_detected] + [510 not_extended] + [511 network_authentication_required] + ) diff --git a/stdlib/source/library/lux/world/net/http/version.lux b/stdlib/source/library/lux/world/net/http/version.lux new file mode 100644 index 000000000..2443fda12 --- /dev/null +++ b/stdlib/source/library/lux/world/net/http/version.lux @@ -0,0 +1,13 @@ +(.module: + [library + [lux #*]] + [// (#+ Version)]) + +(template [<name> <version>] + [(def: #export <name> Version <version>)] + + [v0_9 "0.9"] + [v1_0 "1.0"] + [v1_1 "1.1"] + [v2_0 "2.0"] + ) diff --git a/stdlib/source/library/lux/world/net/uri.lux b/stdlib/source/library/lux/world/net/uri.lux new file mode 100644 index 000000000..2c43cbbd3 --- /dev/null +++ b/stdlib/source/library/lux/world/net/uri.lux @@ -0,0 +1,9 @@ +(.module: + [library + [lux #*]]) + +(type: #export URI + Text) + +(def: #export separator + "/") diff --git a/stdlib/source/library/lux/world/output/video/resolution.lux b/stdlib/source/library/lux/world/output/video/resolution.lux new file mode 100644 index 000000000..24f48182c --- /dev/null +++ b/stdlib/source/library/lux/world/output/video/resolution.lux @@ -0,0 +1,47 @@ +(.module: + [library + [lux #* + [abstract + [equivalence (#+ Equivalence)] + [hash (#+ Hash)]] + [data + ["." product]] + [math + [number + ["." nat]]]]]) + +(type: #export Resolution + {#width Nat + #height Nat}) + +(def: #export hash + (Hash Resolution) + (product.hash nat.hash nat.hash)) + +(def: #export equivalence + (Equivalence Resolution) + (\ ..hash &equivalence)) + +## https://en.wikipedia.org/wiki/Display_resolution#Common_display_resolutions +(template [<name> <width> <height>] + [(def: #export <name> + Resolution + {#width <width> + #height <height>})] + + [svga 800 600] + [wsvga 1024 600] + [xga 1024 768] + [xga+ 1152 864] + [wxga/16:9 1280 720] + [wxga/5:3 1280 768] + [wxga/16:10 1280 800] + [sxga 1280 1024] + [wxga+ 1440 900] + [hd+ 1600 900] + [wsxga+ 1680 1050] + [fhd 1920 1080] + [wuxga 1920 1200] + [wqhd 2560 1440] + [uhd-4k 3840 2160] + ) diff --git a/stdlib/source/library/lux/world/program.lux b/stdlib/source/library/lux/world/program.lux new file mode 100644 index 000000000..8c8a0ac05 --- /dev/null +++ b/stdlib/source/library/lux/world/program.lux @@ -0,0 +1,451 @@ +(.module: + [library + [lux #* + ["@" target] + ["." ffi (#+ import:)] + [abstract + ["." monad (#+ Monad do)]] + [control + ["." function] + ["." io (#+ IO)] + ["." try (#+ Try)] + ["." exception (#+ exception:)] + [concurrency + ["." atom] + ["." promise (#+ Promise)]] + [parser + ["." environment (#+ Environment)]]] + [data + ["." bit ("#\." equivalence)] + ["." maybe] + ["." text + ["%" format (#+ format)]] + [collection + ["." array (#+ Array)] + ["." dictionary (#+ Dictionary)] + ["." list ("#\." functor)]]] + ["." macro + ["." template]] + [math + [number + ["i" int]]] + [type + abstract]]] + [// + [file (#+ Path)] + [shell (#+ Exit)]]) + +(exception: #export (unknown_environment_variable {name Text}) + (exception.report + ["Name" (%.text name)])) + +(interface: #export (Program !) + (: (-> Any (! (List Text))) + available_variables) + (: (-> Text (! (Try Text))) + variable) + (: Path + home) + (: Path + directory) + (: (-> Exit (! Nothing)) + exit)) + +(def: #export (environment monad program) + (All [!] (-> (Monad !) (Program !) (! Environment))) + (do {! monad} + [variables (\ program available_variables []) + entries (monad.map ! (function (_ name) + (\ ! map (|>> [name]) (\ program variable name))) + variables)] + (wrap (|> entries + (list.all (function (_ [name value]) + (case value + (#try.Success value) + (#.Some [name value]) + + (#try.Failure _) + #.None))) + (dictionary.from_list text.hash))))) + +(`` (implementation: #export (async program) + (-> (Program IO) (Program Promise)) + + (~~ (template [<method>] + [(def: <method> + (\ program <method>))] + + [home] + [directory] + )) + + (~~ (template [<method>] + [(def: <method> + (|>> (\ program <method>) promise.future))] + + [available_variables] + [variable] + [exit] + )))) + +(def: #export (mock environment home directory) + (-> Environment Path Path (Program IO)) + (let [@dead? (atom.atom false)] + (implementation + (def: available_variables + (function.constant (io.io (dictionary.keys environment)))) + (def: (variable name) + (io.io (case (dictionary.get name environment) + (#.Some value) + (#try.Success value) + + #.None + (exception.throw ..unknown_environment_variable [name])))) + (def: home + home) + (def: directory + directory) + (def: (exit code) + (io.io (error! (%.int code))))))) + +## Do not trust the values of environment variables +## https://wiki.sei.cmu.edu/confluence/display/java/ENV02-J.+Do+not+trust+the+values+of+environment+variables + +(with_expansions [<jvm> (as_is (import: java/lang/String) + + (import: (java/util/Iterator a) + ["#::." + (hasNext [] boolean) + (next [] a)]) + + (import: (java/util/Set a) + ["#::." + (iterator [] (java/util/Iterator a))]) + + (import: (java/util/Map k v) + ["#::." + (keySet [] (java/util/Set k))]) + + (import: java/lang/System + ["#::." + (#static getenv [] (java/util/Map java/lang/String java/lang/String)) + (#static getenv #as resolveEnv [java/lang/String] #io #? java/lang/String) + (#static getProperty [java/lang/String] #? java/lang/String) + (#static exit [int] #io void)]) + + (def: (jvm\\consume iterator) + (All [a] (-> (java/util/Iterator a) (List a))) + (if (java/util/Iterator::hasNext iterator) + (#.Cons (java/util/Iterator::next iterator) + (jvm\\consume iterator)) + #.Nil)) + )] + (for {@.old (as_is <jvm>) + @.jvm (as_is <jvm>) + @.js (as_is (def: default_exit! + (-> Exit (IO Nothing)) + (|>> %.int error! io.io)) + + (import: NodeJs_Process + ["#::." + (exit [ffi.Number] #io Nothing) + (cwd [] #io Path)]) + + (def: (exit_node_js! code) + (-> Exit (IO Nothing)) + (case (ffi.constant ..NodeJs_Process [process]) + (#.Some process) + (NodeJs_Process::exit (i.frac code) process) + + #.None + (..default_exit! code))) + + (import: Browser_Window + ["#::." + (close [] Nothing)]) + + (import: Browser_Location + ["#::." + (reload [] Nothing)]) + + (def: (exit_browser! code) + (-> Exit (IO Nothing)) + (case [(ffi.constant ..Browser_Window [window]) + (ffi.constant ..Browser_Location [location])] + [(#.Some window) (#.Some location)] + (exec + (Browser_Window::close [] window) + (Browser_Location::reload [] location) + (..default_exit! code)) + + [(#.Some window) #.None] + (exec + (Browser_Window::close [] window) + (..default_exit! code)) + + [#.None (#.Some location)] + (exec + (Browser_Location::reload [] location) + (..default_exit! code)) + + [#.None #.None] + (..default_exit! code))) + + (import: Object + ["#::." + (#static entries [Object] (Array (Array ffi.String)))]) + + (import: NodeJs_OS + ["#::." + (homedir [] #io Path)]) + + (template [<name> <path>] + [(def: (<name> _) + (-> [] (Maybe (-> ffi.String Any))) + (ffi.constant (-> ffi.String Any) <path>))] + + [normal_require [require]] + [global_require [global require]] + [process_load [global process mainModule constructor _load]] + ) + + (def: (require _) + (-> [] (-> ffi.String Any)) + (case [(normal_require []) (global_require []) (process_load [])] + (^or [(#.Some require) _ _] + [_ (#.Some require) _] + [_ _ (#.Some require)]) + require + + _ + (undefined)))) + @.python (as_is (import: os + ["#::." + (#static getcwd [] #io ffi.String) + (#static _exit [ffi.Integer] #io Nothing)]) + + (import: os/path + ["#::." + (#static expanduser [ffi.String] #io ffi.String)]) + + (import: os/environ + ["#::." + (#static keys [] #io (Array ffi.String)) + (#static get [ffi.String] #io #? ffi.String)])) + @.lua (as_is (ffi.import: LuaFile + ["#::." + (read [ffi.String] #io #? ffi.String) + (close [] #io ffi.Boolean)]) + + (ffi.import: (io/popen [ffi.String] #io #try #? LuaFile)) + (ffi.import: (os/getenv [ffi.String] #io #? ffi.String)) + (ffi.import: (os/exit [ffi.Integer] #io Nothing)) + + (def: (run_command default command) + (-> Text Text (IO Text)) + (do {! io.monad} + [outcome (io/popen [command])] + (case outcome + (#try.Success outcome) + (case outcome + (#.Some file) + (do ! + [?output (LuaFile::read ["*l"] file) + _ (LuaFile::close [] file)] + (wrap (maybe.default default ?output))) + + #.None + (wrap default)) + + (#try.Failure _) + (wrap default))))) + @.ruby (as_is (ffi.import: Env #as RubyEnv + ["#::." + (#static keys [] (Array Text)) + (#static fetch [Text] #io #? Text)]) + + (ffi.import: "fileutils" FileUtils #as RubyFileUtils + ["#::." + (#static pwd Path)]) + + (ffi.import: Dir #as RubyDir + ["#::." + (#static home Path)]) + + (ffi.import: Kernel #as RubyKernel + ["#::." + (#static exit [Int] #io Nothing)])) + + ## @.php + ## (as_is (ffi.import: (exit [Int] #io Nothing)) + ## ## https://www.php.net/manual/en/function.exit.php + ## (ffi.import: (getcwd [] #io ffi.String)) + ## ## https://www.php.net/manual/en/function.getcwd.php + ## (ffi.import: (getenv #as getenv/1 [ffi.String] #io ffi.String)) + ## (ffi.import: (getenv #as getenv/0 [] #io (Array ffi.String))) + ## ## https://www.php.net/manual/en/function.getenv.php + ## ## https://www.php.net/manual/en/function.array-keys.php + ## (ffi.import: (array_keys [(Array ffi.String)] (Array ffi.String))) + ## ) + + ## @.scheme + ## (as_is (ffi.import: (exit [Int] #io Nothing)) + ## ## https://srfi.schemers.org/srfi-98/srfi-98.html + ## (abstract: Pair Any) + ## (abstract: PList Any) + ## (ffi.import: (get-environment-variables [] #io PList)) + ## (ffi.import: (car [Pair] Text)) + ## (ffi.import: (cdr [Pair] Text)) + ## (ffi.import: (car #as head [PList] Pair)) + ## (ffi.import: (cdr #as tail [PList] PList))) + } + (as_is))) + +(implementation: #export default + (Program IO) + + (def: (available_variables _) + (with_expansions [<jvm> (io.io (|> (java/lang/System::getenv) + java/util/Map::keySet + java/util/Set::iterator + ..jvm\\consume))] + (for {@.old <jvm> + @.jvm <jvm> + @.js (io.io (if ffi.on_node_js? + (case (ffi.constant Object [process env]) + (#.Some process/env) + (|> (Object::entries [process/env]) + array.to_list + (list\map (|>> (array.read 0) maybe.assume))) + + #.None + (list)) + (list))) + @.python (\ io.monad map array.to_list (os/environ::keys [])) + ## Lua offers no way to get all the environment variables available. + @.lua (io.io (list)) + @.ruby (|> (RubyEnv::keys []) + array.to_list + io.io) + ## @.php (do io.monad + ## [environment (..getenv/0 [])] + ## (wrap (|> environment + ## ..array_keys + ## array.to_list + ## (list\map (function (_ variable) + ## [variable ("php array read" (:as Nat variable) environment)])) + ## (dictionary.from_list text.hash)))) + ## @.scheme (do io.monad + ## [input (..get-environment-variables [])] + ## (loop [input input + ## output environment.empty] + ## (if ("scheme object nil?" input) + ## (wrap output) + ## (let [entry (..head input)] + ## (recur (..tail input) + ## (dictionary.put (..car entry) (..cdr entry) output)))))) + }))) + + (def: (variable name) + (template.let [(!fetch <method>) + [(do io.monad + [value (<method> name)] + (wrap (case value + (#.Some value) + (#try.Success value) + + #.None + (exception.throw ..unknown_environment_variable [name]))))]] + (with_expansions [<jvm> (!fetch java/lang/System::resolveEnv)] + (for {@.old <jvm> + @.jvm <jvm> + @.js (io.io (if ffi.on_node_js? + (case (do maybe.monad + [process/env (ffi.constant Object [process env])] + (array.read (:as Nat name) + (:as (Array Text) process/env))) + (#.Some value) + (#try.Success value) + + #.None + (exception.throw ..unknown_environment_variable [name])) + (exception.throw ..unknown_environment_variable [name]))) + @.python (!fetch os/environ::get) + @.lua (!fetch os/getenv) + @.ruby (!fetch RubyEnv::fetch) + })))) + + (def: home + (io.run + (with_expansions [<default> (io.io "~") + <jvm> (io.io (maybe.default "" (java/lang/System::getProperty "user.home")))] + (for {@.old <jvm> + @.jvm <jvm> + @.js (if ffi.on_node_js? + (|> (..require [] "os") + (:as NodeJs_OS) + (NodeJs_OS::homedir [])) + <default>) + @.python (os/path::expanduser ["~"]) + @.lua (..run_command "~" "echo ~") + @.ruby (io.io (RubyDir::home)) + ## @.php (do io.monad + ## [output (..getenv/1 ["HOME"])] + ## (wrap (if (bit\= false (:as Bit output)) + ## "~" + ## output))) + } + ## TODO: Replace dummy implementation. + <default>)))) + + (def: directory + (io.run + (with_expansions [<default> "." + <jvm> (io.io (maybe.default "" (java/lang/System::getProperty "user.dir")))] + (for {@.old <jvm> + @.jvm <jvm> + @.js (if ffi.on_node_js? + (case (ffi.constant ..NodeJs_Process [process]) + (#.Some process) + (NodeJs_Process::cwd [] process) + + #.None + (io.io <default>)) + (io.io <default>)) + @.python (os::getcwd []) + @.lua (do io.monad + [#let [default <default>] + on_windows (..run_command default "cd")] + (if (is? default on_windows) + (..run_command default "pwd") + (wrap on_windows))) + @.ruby (io.io (RubyFileUtils::pwd)) + ## @.php (do io.monad + ## [output (..getcwd [])] + ## (wrap (if (bit\= false (:as Bit output)) + ## "." + ## output))) + } + ## TODO: Replace dummy implementation. + (io.io <default>))))) + + (def: (exit code) + (with_expansions [<jvm> (do io.monad + [_ (java/lang/System::exit code)] + (wrap (undefined)))] + (for {@.old <jvm> + @.jvm <jvm> + @.js (cond ffi.on_node_js? + (..exit_node_js! code) + + ffi.on_browser? + (..exit_browser! code) + + ## else + (..default_exit! code)) + @.python (os::_exit [code]) + @.lua (os/exit [code]) + @.ruby (RubyKernel::exit [code]) + ## @.php (..exit [code]) + ## @.scheme (..exit [code]) + })))) diff --git a/stdlib/source/library/lux/world/service/authentication.lux b/stdlib/source/library/lux/world/service/authentication.lux new file mode 100644 index 000000000..4c66ddc1c --- /dev/null +++ b/stdlib/source/library/lux/world/service/authentication.lux @@ -0,0 +1,25 @@ +(.module: + [library + [lux #* + [control + [try (#+ Try)] + [security + [capability (#+ Capability)]]]]]) + +(type: #export (Can-Register ! account secret value) + (Capability [account secret value] (! (Try Any)))) + +(type: #export (Can-Authenticate ! account secret value) + (Capability [account secret] (! (Try value)))) + +(type: #export (Can-Reset ! account secret) + (Capability [account secret] (! (Try Any)))) + +(type: #export (Can-Forget ! account) + (Capability [account] (! (Try Any)))) + +(type: #export (Service ! account secret value) + {#can-register (Can-Register ! account secret value) + #can-authenticate (Can-Authenticate ! account secret value) + #can-reset (Can-Reset ! account secret) + #can-forget (Can-Forget ! account)}) diff --git a/stdlib/source/library/lux/world/service/crud.lux b/stdlib/source/library/lux/world/service/crud.lux new file mode 100644 index 000000000..bd47744f4 --- /dev/null +++ b/stdlib/source/library/lux/world/service/crud.lux @@ -0,0 +1,33 @@ +(.module: + [library + [lux #* + [control + ["." try (#+ Try)] + [security + ["!" capability (#+ capability:)]]] + [time + ["." instant (#+ Instant)]]]]) + +(type: #export ID Nat) + +(type: #export Time + {#created Instant + #updated Instant}) + +(capability: #export (Can-Create ! entity) + (can-create [Instant entity] (! (Try ID)))) + +(capability: #export (Can-Retrieve ! entity) + (can-retrieve ID (! (Try [Time entity])))) + +(capability: #export (Can-Update ! entity) + (can-update [ID Instant entity] (! (Try Any)))) + +(capability: #export (Can-Delete ! entity) + (can-delete ID (! (Try Any)))) + +(type: #export (CRUD ! entity) + {#can-create (Can-Create ! entity) + #can-retrieve (Can-Retrieve ! entity) + #can-update (Can-Update ! entity) + #can-delete (Can-Delete ! entity)}) diff --git a/stdlib/source/library/lux/world/service/inventory.lux b/stdlib/source/library/lux/world/service/inventory.lux new file mode 100644 index 000000000..b6f023075 --- /dev/null +++ b/stdlib/source/library/lux/world/service/inventory.lux @@ -0,0 +1,31 @@ +(.module: + [library + [lux #* + [control + [try (#+ Try)] + [security + ["!" capability (#+ capability:)]]]]]) + +(type: #export ID Nat) + +(type: #export Ownership + {#owner ID + #property ID}) + +(capability: #export (Can-Own !) + (can-own Ownership (! (Try Any)))) + +(capability: #export (Can-Disown !) + (can-disown Ownership (! (Try Any)))) + +(capability: #export (Can-Check !) + (can-check Ownership (! (Try Bit)))) + +(capability: #export (Can-List-Property !) + (can-list-property ID (! (Try (List ID))))) + +(type: #export (Inventory !) + {#can-own (Can-Own !) + #can-disown (Can-Disown !) + #can-check (Can-Check !) + #can-list-property (Can-List-Property !)}) diff --git a/stdlib/source/library/lux/world/service/journal.lux b/stdlib/source/library/lux/world/service/journal.lux new file mode 100644 index 000000000..ba42af209 --- /dev/null +++ b/stdlib/source/library/lux/world/service/journal.lux @@ -0,0 +1,51 @@ +(.module: + [library + [lux #* + [control + [equivalence (#+ Equivalence)] + [interval (#+ Interval)] + [try (#+ Try)] + [security + ["!" capability (#+ capability:)]]] + [data + ["." text ("#\." equivalence)]] + [time + ["." instant (#+ Instant) ("#\." equivalence)]]]]) + +(type: #export (Entry a) + {#what a + #why Text + #how Text + #who Text + #where Text + #when Instant}) + +(type: #export Range + (Interval Instant)) + +(def: #export (range start end) + (-> Instant Instant Range) + (implementation + (def: &enum instant.enum) + (def: bottom start) + (def: top end))) + +(implementation: #export (equivalence (^open "_\.")) + (All [a] (-> (Equivalence a) (Equivalence (Entry a)))) + (def: (= reference sample) + (and (_\= (get@ #what reference) (get@ #what sample)) + (text\= (get@ #why reference) (get@ #why sample)) + (text\= (get@ #how reference) (get@ #how sample)) + (text\= (get@ #who reference) (get@ #who sample)) + (text\= (get@ #where reference) (get@ #where sample)) + (instant\= (get@ #when reference) (get@ #when sample))))) + +(capability: #export (Can-Write ! a) + (can-write (Entry a) (! (Try Any)))) + +(capability: #export (Can-Read ! a) + (can-read Range (! (Try (List (Entry a)))))) + +(type: #export (Journal ! a) + {#can-write (Can-Write ! a) + #can-read (Can-Read ! a)}) diff --git a/stdlib/source/library/lux/world/service/mail.lux b/stdlib/source/library/lux/world/service/mail.lux new file mode 100644 index 000000000..2b2cc9dd1 --- /dev/null +++ b/stdlib/source/library/lux/world/service/mail.lux @@ -0,0 +1,19 @@ +(.module: + [library + [lux #* + [control + [try (#+ Try)] + [concurrency + [frp (#+ Channel)]] + [security + ["!" capability (#+ capability:)]]]]]) + +(capability: #export (Can-Send ! address message) + (can-send [address message] (! (Try Any)))) + +(capability: #export (Can-Subscribe ! address message) + (can-subscribe [address] (! (Try (Channel message))))) + +(type: #export (Service ! address message) + {#can-send (Can-Send ! address message) + #can-subscribe (Can-Subscribe ! address message)}) diff --git a/stdlib/source/library/lux/world/shell.lux b/stdlib/source/library/lux/world/shell.lux new file mode 100644 index 000000000..52cd3efd4 --- /dev/null +++ b/stdlib/source/library/lux/world/shell.lux @@ -0,0 +1,374 @@ +(.module: + [library + [lux #* + ["@" target] + ["jvm" ffi (#+ import:)] + [abstract + [monad (#+ do)]] + [control + ["." function] + ["." try (#+ Try)] + ["." exception (#+ exception:)] + ["." io (#+ IO)] + [security + ["?" policy (#+ Context Safety Safe)]] + [concurrency + ["." atom (#+ Atom)] + ["." promise (#+ Promise)]] + [parser + [environment (#+ Environment)]]] + [data + ["." product] + ["." text + ["%" format (#+ format)] + [encoding + ["." utf8]]] + [collection + ["." array (#+ Array)] + ["." list ("#\." fold functor)] + ["." dictionary]]] + [math + [number (#+ hex) + ["n" nat]]]]] + [// + [file (#+ Path)]]) + +(type: #export Exit + Int) + +(template [<code> <name>] + [(def: #export <name> + Exit + <code>)] + + [+0 normal] + [+1 error] + ) + +(interface: #export (Process !) + (: (-> [] (! (Try Text))) + read) + (: (-> [] (! (Try Text))) + error) + (: (-> Text (! (Try Any))) + write) + (: (-> [] (! (Try Any))) + destroy) + (: (-> [] (! (Try Exit))) + await)) + +(def: (async_process process) + (-> (Process IO) (Process Promise)) + (`` (implementation + (~~ (template [<method>] + [(def: <method> + (|>> (\ process <method>) + promise.future))] + + [read] + [error] + [write] + [destroy] + [await] + ))))) + +(type: #export Command + Text) + +(type: #export Argument + Text) + +(interface: #export (Shell !) + (: (-> [Environment Path Command (List Argument)] (! (Try (Process !)))) + execute)) + +(def: #export (async shell) + (-> (Shell IO) (Shell Promise)) + (implementation + (def: (execute input) + (promise.future + (do (try.with io.monad) + [process (\ shell execute input)] + (wrap (..async_process process))))))) + +## https://en.wikipedia.org/wiki/Code_injection#Shell_injection +(interface: (Policy ?) + (: (-> Command (Safe Command ?)) + command) + (: (-> Argument (Safe Argument ?)) + argument) + (: (All [a] (-> (Safe a ?) a)) + value)) + +(type: (Sanitizer a) + (-> a a)) + +(type: Replacer + (-> Text Text)) + +(def: (replace bad replacer) + (-> Text Replacer (-> Text Text)) + (text.replace_all bad (replacer bad))) + +(def: sanitize_common_command + (-> Replacer (Sanitizer Command)) + (let [x0A (text.from_code (hex "0A")) + xFF (text.from_code (hex "FF"))] + (function (_ replacer) + (|>> (..replace x0A replacer) + (..replace xFF replacer) + (..replace "\" replacer) + (..replace "&" replacer) + (..replace "#" replacer) + (..replace ";" replacer) + (..replace "`" replacer) + (..replace "|" replacer) + (..replace "*" replacer) + (..replace "?" replacer) + (..replace "~" replacer) + (..replace "^" replacer) + (..replace "$" replacer) + (..replace "<" replacer) (..replace ">" replacer) + (..replace "(" replacer) (..replace ")" replacer) + (..replace "[" replacer) (..replace "]" replacer) + (..replace "{" replacer) (..replace "}" replacer))))) + +(def: (policy sanitize_command sanitize_argument) + (Ex [?] (-> (Sanitizer Command) (Sanitizer Argument) (Policy ?))) + (?.with_policy + (: (Context Safety Policy) + (function (_ (^open "?\.")) + (implementation + (def: command (|>> sanitize_command ?\can_upgrade)) + (def: argument (|>> sanitize_argument ?\can_upgrade)) + (def: value ?\can_downgrade)))))) + +(def: unix_policy + (let [replacer (: Replacer + (|>> (format "\"))) + sanitize_command (: (Sanitizer Command) + (..sanitize_common_command replacer)) + sanitize_argument (: (Sanitizer Argument) + (|>> (..replace "'" replacer) + (text.enclose' "'")))] + (..policy sanitize_command sanitize_argument))) + +(def: windows_policy + (let [replacer (: Replacer + (function.constant " ")) + sanitize_command (: (Sanitizer Command) + (|>> (..sanitize_common_command replacer) + (..replace "%" replacer) + (..replace "!" replacer))) + sanitize_argument (: (Sanitizer Argument) + (|>> (..replace "%" replacer) + (..replace "!" replacer) + (..replace text.double_quote replacer) + (text.enclose' text.double_quote)))] + (..policy sanitize_command sanitize_argument))) + +(with_expansions [<jvm> (as_is (import: java/lang/String + ["#::." + (toLowerCase [] java/lang/String)]) + + (def: (jvm::arguments_array arguments) + (-> (List Argument) (Array java/lang/String)) + (product.right + (list\fold (function (_ argument [idx output]) + [(inc idx) (jvm.array_write idx + (:as java/lang/String argument) + output)]) + [0 (jvm.array java/lang/String (list.size arguments))] + arguments))) + + (import: (java/util/Map k v) + ["#::." + (put [k v] v)]) + + (def: (jvm::load_environment input target) + (-> Environment + (java/util/Map java/lang/String java/lang/String) + (java/util/Map java/lang/String java/lang/String)) + (list\fold (function (_ [key value] target') + (exec (java/util/Map::put (:as java/lang/String key) + (:as java/lang/String value) + target') + target')) + target + (dictionary.entries input))) + + (import: java/io/Reader + ["#::." + (read [] #io #try int)]) + + (import: java/io/BufferedReader + ["#::." + (new [java/io/Reader]) + (readLine [] #io #try #? java/lang/String)]) + + (import: java/io/InputStream) + + (import: java/io/InputStreamReader + ["#::." + (new [java/io/InputStream])]) + + (import: java/io/OutputStream + ["#::." + (write [[byte]] #io #try void)]) + + (import: java/lang/Process + ["#::." + (getInputStream [] #io #try java/io/InputStream) + (getErrorStream [] #io #try java/io/InputStream) + (getOutputStream [] #io #try java/io/OutputStream) + (destroy [] #io #try void) + (waitFor [] #io #try int)]) + + (exception: #export no_more_output) + + (def: (default_process process) + (-> java/lang/Process (IO (Try (Process IO)))) + (do {! (try.with io.monad)} + [jvm_input (java/lang/Process::getInputStream process) + jvm_error (java/lang/Process::getErrorStream process) + jvm_output (java/lang/Process::getOutputStream process) + #let [jvm_input (|> jvm_input + java/io/InputStreamReader::new + java/io/BufferedReader::new) + jvm_error (|> jvm_error + java/io/InputStreamReader::new + java/io/BufferedReader::new)]] + (wrap (: (Process IO) + (`` (implementation + (~~ (template [<name> <stream>] + [(def: (<name> _) + (do ! + [output (java/io/BufferedReader::readLine <stream>)] + (case output + (#.Some output) + (wrap output) + + #.None + (\ io.monad wrap (exception.throw ..no_more_output [])))))] + + [read jvm_input] + [error jvm_error] + )) + (def: (write message) + (java/io/OutputStream::write (\ utf8.codec encode message) jvm_output)) + (~~ (template [<name> <method>] + [(def: (<name> _) + (<method> process))] + + [destroy java/lang/Process::destroy] + [await java/lang/Process::waitFor] + )))))))) + + (import: java/io/File + ["#::." + (new [java/lang/String])]) + + (import: java/lang/ProcessBuilder + ["#::." + (new [[java/lang/String]]) + (environment [] #try (java/util/Map java/lang/String java/lang/String)) + (directory [java/io/File] java/lang/ProcessBuilder) + (start [] #io #try java/lang/Process)]) + + (import: java/lang/System + ["#::." + (#static getProperty [java/lang/String] #io #try java/lang/String)]) + + ## https://en.wikipedia.org/wiki/Code_injection#Shell_injection + (def: windows? + (IO (Try Bit)) + (\ (try.with io.monad) map + (|>> java/lang/String::toLowerCase (text.starts_with? "windows")) + (java/lang/System::getProperty "os.name"))) + + (implementation: #export default + (Shell IO) + + (def: (execute [environment working_directory command arguments]) + (do {! (try.with io.monad)} + [#let [builder (|> (list& command arguments) + ..jvm::arguments_array + java/lang/ProcessBuilder::new + (java/lang/ProcessBuilder::directory (java/io/File::new working_directory)))] + _ (|> builder + java/lang/ProcessBuilder::environment + (\ try.functor map (..jvm::load_environment environment)) + (\ io.monad wrap)) + process (java/lang/ProcessBuilder::start builder)] + (..default_process process)))) + )] + (for {@.old (as_is <jvm>) + @.jvm (as_is <jvm>)} + (as_is))) + +(interface: #export (Mock s) + (: (-> s (Try [s Text])) + on_read) + (: (-> s (Try [s Text])) + on_error) + (: (-> Text s (Try s)) + on_write) + (: (-> s (Try s)) + on_destroy) + (: (-> s (Try [s Exit])) + on_await)) + +(`` (implementation: (mock_process mock state) + (All [s] (-> (Mock s) (Atom s) (Process IO))) + + (~~ (template [<name> <mock>] + [(def: (<name> _) + (do {! io.monad} + [|state| (atom.read state)] + (case (\ mock <mock> |state|) + (#try.Success [|state| output]) + (do ! + [_ (atom.write |state| state)] + (wrap (#try.Success output))) + + (#try.Failure error) + (wrap (#try.Failure error)))))] + + [read on_read] + [error on_error] + [await on_await] + )) + (def: (write message) + (do {! io.monad} + [|state| (atom.read state)] + (case (\ mock on_write message |state|) + (#try.Success |state|) + (do ! + [_ (atom.write |state| state)] + (wrap (#try.Success []))) + + (#try.Failure error) + (wrap (#try.Failure error))))) + (def: (destroy _) + (do {! io.monad} + [|state| (atom.read state)] + (case (\ mock on_destroy |state|) + (#try.Success |state|) + (do ! + [_ (atom.write |state| state)] + (wrap (#try.Success []))) + + (#try.Failure error) + (wrap (#try.Failure error))))))) + +(implementation: #export (mock mock init) + (All [s] + (-> (-> [Environment Path Command (List Argument)] + (Try (Mock s))) + s + (Shell IO))) + + (def: (execute input) + (io.io (do try.monad + [mock (mock input)] + (wrap (..mock_process mock (atom.atom init))))))) |