From 8ac980fd3b6d2050edc0e631a00028c1e6c28c73 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 4 Nov 2020 04:04:49 -0400 Subject: Re-named "lux/control/concurrency/process" to "thread". --- stdlib/source/lux/control/concurrency/process.lux | 171 ------- stdlib/source/lux/control/concurrency/promise.lux | 8 +- stdlib/source/lux/control/concurrency/stm.lux | 3 +- stdlib/source/lux/control/concurrency/thread.lux | 171 +++++++ stdlib/source/lux/control/parser/cli.lux | 4 +- stdlib/source/lux/control/security/capability.lux | 7 +- .../source/lux/data/collection/queue/priority.lux | 8 +- stdlib/source/lux/test.lux | 15 +- stdlib/source/lux/world/shell.lux | 516 +++++++++++++++------ stdlib/source/spec/lux/world/shell.lux | 97 ++++ stdlib/source/test/lux/control.lux | 30 +- .../test/lux/control/concurrency/process.lux | 46 -- .../source/test/lux/control/concurrency/thread.lux | 46 ++ stdlib/source/test/lux/control/security/policy.lux | 7 +- .../test/lux/data/collection/queue/priority.lux | 102 ++-- stdlib/source/test/lux/type/check.lux | 8 +- stdlib/source/test/lux/world.lux | 4 +- stdlib/source/test/lux/world/shell.lux | 58 +++ 18 files changed, 863 insertions(+), 438 deletions(-) delete mode 100644 stdlib/source/lux/control/concurrency/process.lux create mode 100644 stdlib/source/lux/control/concurrency/thread.lux create mode 100644 stdlib/source/spec/lux/world/shell.lux delete mode 100644 stdlib/source/test/lux/control/concurrency/process.lux create mode 100644 stdlib/source/test/lux/control/concurrency/thread.lux create mode 100644 stdlib/source/test/lux/world/shell.lux (limited to 'stdlib') diff --git a/stdlib/source/lux/control/concurrency/process.lux b/stdlib/source/lux/control/concurrency/process.lux deleted file mode 100644 index 5e1bf7c3c..000000000 --- a/stdlib/source/lux/control/concurrency/process.lux +++ /dev/null @@ -1,171 +0,0 @@ -(.module: - [lux #* - ["@" target] - ["." host] - [abstract - ["." monad (#+ do)]] - [control - ["ex" exception (#+ exception:)] - ["." io (#+ IO io)]] - [data - [number - ["n" nat]] - [collection - ["." list]]]] - [// - ["." atom (#+ Atom)]]) - -(for {@.old - (as-is (host.import: java/lang/Object) - - (host.import: java/lang/Runtime - (#static getRuntime [] java/lang/Runtime) - (availableProcessors [] int)) - - (host.import: java/lang/Runnable) - - (host.import: java/util/concurrent/TimeUnit - (#enum MILLISECONDS)) - - (host.import: java/util/concurrent/Executor - (execute [java/lang/Runnable] #io void)) - - (host.import: (java/util/concurrent/ScheduledFuture a)) - - (host.import: java/util/concurrent/ScheduledThreadPoolExecutor - (new [int]) - (schedule [java/lang/Runnable long java/util/concurrent/TimeUnit] #io (java/util/concurrent/ScheduledFuture java/lang/Object)))) - - @.jvm - (as-is (host.import: java/lang/Object) - - (host.import: java/lang/Runtime - (#static getRuntime [] java/lang/Runtime) - (availableProcessors [] int)) - - (host.import: java/lang/Runnable) - - (host.import: java/util/concurrent/TimeUnit - (#enum MILLISECONDS)) - - (host.import: java/util/concurrent/Executor - (execute [java/lang/Runnable] #io void)) - - (host.import: (java/util/concurrent/ScheduledFuture a)) - - (host.import: java/util/concurrent/ScheduledThreadPoolExecutor - (new [int]) - (schedule [java/lang/Runnable long java/util/concurrent/TimeUnit] #io (java/util/concurrent/ScheduledFuture java/lang/Object)))) - - @.js - (as-is (host.import: (setTimeout [host.Function host.Number] #io Any)))} - - ## Default - (type: Process - {#creation Nat - #delay Nat - #action (IO Any)}) - ) - -(def: #export parallelism - Nat - (for {@.old - (|> (java/lang/Runtime::getRuntime) - (java/lang/Runtime::availableProcessors) - .nat) - - @.jvm - (|> (java/lang/Runtime::getRuntime) - (java/lang/Runtime::availableProcessors) - .nat)} - - ## Default - 1)) - -(for {@.old - (def: runner - (java/util/concurrent/ScheduledThreadPoolExecutor::new (.int ..parallelism))) - - @.jvm - (def: runner - (java/util/concurrent/ScheduledThreadPoolExecutor::new (.int ..parallelism))) - - @.js - (as-is)} - - ## Default - (def: runner - (Atom (List Process)) - (atom.atom (list)))) - -(def: #export (schedule milli-seconds action) - (-> Nat (IO Any) (IO Any)) - (for {@.old - (let [runnable (host.object [] [java/lang/Runnable] - [] - (java/lang/Runnable [] (run self) void - (io.run action)))] - (case milli-seconds - 0 (java/util/concurrent/Executor::execute runnable runner) - _ (java/util/concurrent/ScheduledThreadPoolExecutor::schedule runnable (.int milli-seconds) java/util/concurrent/TimeUnit::MILLISECONDS - runner))) - - @.jvm - (let [runnable (host.object [] [java/lang/Runnable] - [] - (java/lang/Runnable [] (run self) void - (io.run action)))] - (case milli-seconds - 0 (java/util/concurrent/Executor::execute runnable runner) - _ (java/util/concurrent/ScheduledThreadPoolExecutor::schedule runnable (.int milli-seconds) java/util/concurrent/TimeUnit::MILLISECONDS - runner))) - - @.js - (..setTimeout [(host.closure [] (io.run action)) - (n.frac milli-seconds)])} - - ## Default - (do io.monad - [_ (atom.update (|>> (#.Cons {#creation (.nat ("lux io current-time")) - #delay milli-seconds - #action action})) - ..runner)] - (wrap [])))) - -(for {@.old - (as-is) - - @.jvm - (as-is) - - @.js - (as-is)} - - ## Default - (as-is (exception: #export cannot-continue-running-processes) - - (def: #export (run! _) - (-> Any (IO Any)) - (do {! io.monad} - [processes (atom.read ..runner)] - (case processes - ## And... we're done! - #.Nil - (wrap []) - - _ - (do ! - [#let [now (.nat ("lux io current-time")) - [ready pending] (list.partition (function (_ process) - (|> (get@ #creation process) - (n.+ (get@ #delay process)) - (n.<= now))) - processes)] - swapped? (atom.compare-and-swap processes pending ..runner)] - (if swapped? - (do ! - [_ (monad.map ! (get@ #action) ready)] - (run! [])) - (error! (ex.construct ..cannot-continue-running-processes [])))) - ))) - )) diff --git a/stdlib/source/lux/control/concurrency/promise.lux b/stdlib/source/lux/control/concurrency/promise.lux index 3b6341cf1..017ad67a8 100644 --- a/stdlib/source/lux/control/concurrency/promise.lux +++ b/stdlib/source/lux/control/concurrency/promise.lux @@ -13,7 +13,7 @@ [type abstract]] [// - ["." process] + ["." thread] ["." atom (#+ Atom atom)]]) (abstract: #export (Promise a) @@ -156,19 +156,19 @@ left||right)))) (def: #export (schedule millis-delay computation) - {#.doc (doc "Runs an I/O computation on its own process (after a specified delay)." + {#.doc (doc "Runs an I/O computation on its own thread (after a specified delay)." "Returns a Promise that will eventually host its result.")} (All [a] (-> Nat (IO a) (Promise a))) (let [[!out resolve] (..promise [])] (exec (|> (do io.monad [value computation] (resolve value)) - (process.schedule millis-delay) + (thread.schedule millis-delay) io.run) !out))) (def: #export future - {#.doc (doc "Runs an I/O computation on its own process." + {#.doc (doc "Runs an I/O computation on its own thread." "Returns a Promise that will eventually host its result.")} (All [a] (-> (IO a) (Promise a))) (schedule 0)) diff --git a/stdlib/source/lux/control/concurrency/stm.lux b/stdlib/source/lux/control/concurrency/stm.lux index 259511eb7..d5684cf97 100644 --- a/stdlib/source/lux/control/concurrency/stm.lux +++ b/stdlib/source/lux/control/concurrency/stm.lux @@ -127,8 +127,7 @@ (#.Cons {#var _var #original _original #current _current} - (update-tx-value var value tx'))) - )) + (update-tx-value var value tx'))))) (def: #export (write value var) {#.doc "Writes value to var."} diff --git a/stdlib/source/lux/control/concurrency/thread.lux b/stdlib/source/lux/control/concurrency/thread.lux new file mode 100644 index 000000000..55b635672 --- /dev/null +++ b/stdlib/source/lux/control/concurrency/thread.lux @@ -0,0 +1,171 @@ +(.module: + [lux #* + ["@" target] + ["." host] + [abstract + ["." monad (#+ do)]] + [control + ["ex" exception (#+ exception:)] + ["." io (#+ IO io)]] + [data + [number + ["n" nat]] + [collection + ["." list]]]] + [// + ["." atom (#+ Atom)]]) + +(for {@.old + (as-is (host.import: java/lang/Object) + + (host.import: java/lang/Runtime + (#static getRuntime [] java/lang/Runtime) + (availableProcessors [] int)) + + (host.import: java/lang/Runnable) + + (host.import: java/util/concurrent/TimeUnit + (#enum MILLISECONDS)) + + (host.import: java/util/concurrent/Executor + (execute [java/lang/Runnable] #io void)) + + (host.import: (java/util/concurrent/ScheduledFuture a)) + + (host.import: java/util/concurrent/ScheduledThreadPoolExecutor + (new [int]) + (schedule [java/lang/Runnable long java/util/concurrent/TimeUnit] #io (java/util/concurrent/ScheduledFuture java/lang/Object)))) + + @.jvm + (as-is (host.import: java/lang/Object) + + (host.import: java/lang/Runtime + (#static getRuntime [] java/lang/Runtime) + (availableProcessors [] int)) + + (host.import: java/lang/Runnable) + + (host.import: java/util/concurrent/TimeUnit + (#enum MILLISECONDS)) + + (host.import: java/util/concurrent/Executor + (execute [java/lang/Runnable] #io void)) + + (host.import: (java/util/concurrent/ScheduledFuture a)) + + (host.import: java/util/concurrent/ScheduledThreadPoolExecutor + (new [int]) + (schedule [java/lang/Runnable long java/util/concurrent/TimeUnit] #io (java/util/concurrent/ScheduledFuture java/lang/Object)))) + + @.js + (as-is (host.import: (setTimeout [host.Function host.Number] #io Any)))} + + ## Default + (type: Thread + {#creation Nat + #delay Nat + #action (IO Any)}) + ) + +(def: #export parallelism + Nat + (for {@.old + (|> (java/lang/Runtime::getRuntime) + (java/lang/Runtime::availableProcessors) + .nat) + + @.jvm + (|> (java/lang/Runtime::getRuntime) + (java/lang/Runtime::availableProcessors) + .nat)} + + ## Default + 1)) + +(for {@.old + (def: runner + (java/util/concurrent/ScheduledThreadPoolExecutor::new (.int ..parallelism))) + + @.jvm + (def: runner + (java/util/concurrent/ScheduledThreadPoolExecutor::new (.int ..parallelism))) + + @.js + (as-is)} + + ## Default + (def: runner + (Atom (List Thread)) + (atom.atom (list)))) + +(def: #export (schedule milli-seconds action) + (-> Nat (IO Any) (IO Any)) + (for {@.old + (let [runnable (host.object [] [java/lang/Runnable] + [] + (java/lang/Runnable [] (run self) void + (io.run action)))] + (case milli-seconds + 0 (java/util/concurrent/Executor::execute runnable runner) + _ (java/util/concurrent/ScheduledThreadPoolExecutor::schedule runnable (.int milli-seconds) java/util/concurrent/TimeUnit::MILLISECONDS + runner))) + + @.jvm + (let [runnable (host.object [] [java/lang/Runnable] + [] + (java/lang/Runnable [] (run self) void + (io.run action)))] + (case milli-seconds + 0 (java/util/concurrent/Executor::execute runnable runner) + _ (java/util/concurrent/ScheduledThreadPoolExecutor::schedule runnable (.int milli-seconds) java/util/concurrent/TimeUnit::MILLISECONDS + runner))) + + @.js + (..setTimeout [(host.closure [] (io.run action)) + (n.frac milli-seconds)])} + + ## Default + (do io.monad + [_ (atom.update (|>> (#.Cons {#creation (.nat ("lux io current-time")) + #delay milli-seconds + #action action})) + ..runner)] + (wrap [])))) + +(for {@.old + (as-is) + + @.jvm + (as-is) + + @.js + (as-is)} + + ## Default + (as-is (exception: #export cannot-continue-running-threads) + + (def: #export (run! _) + (-> Any (IO Any)) + (do {! io.monad} + [threads (atom.read ..runner)] + (case threads + ## And... we're done! + #.Nil + (wrap []) + + _ + (do ! + [#let [now (.nat ("lux io current-time")) + [ready pending] (list.partition (function (_ thread) + (|> (get@ #creation thread) + (n.+ (get@ #delay thread)) + (n.<= now))) + threads)] + swapped? (atom.compare-and-swap threads pending ..runner)] + (if swapped? + (do ! + [_ (monad.map ! (get@ #action) ready)] + (run! [])) + (error! (ex.construct ..cannot-continue-running-threads [])))) + ))) + )) diff --git a/stdlib/source/lux/control/parser/cli.lux b/stdlib/source/lux/control/parser/cli.lux index 08e20ca26..0c1910d2f 100644 --- a/stdlib/source/lux/control/parser/cli.lux +++ b/stdlib/source/lux/control/parser/cli.lux @@ -19,7 +19,7 @@ [// ["." io] [concurrency - ["." process]]]]) + ["." thread]]]]) (type: #export (Parser a) {#.doc "A command-line interface parser."} @@ -152,7 +152,7 @@ @.js (list)} (list g!_ - (` ((~! process.run!) [])))))] + (` ((~! thread.run!) [])))))] ((~' wrap) (~ g!output))))] (case args (#Raw args) diff --git a/stdlib/source/lux/control/security/capability.lux b/stdlib/source/lux/control/security/capability.lux index e69493f69..cd9d7b202 100644 --- a/stdlib/source/lux/control/security/capability.lux +++ b/stdlib/source/lux/control/security/capability.lux @@ -12,7 +12,7 @@ [text ["%" format (#+ format)]] [collection - ["." list ("#;." functor)]]] + ["." list ("#@." functor)]]] [type abstract] ["." meta] @@ -55,9 +55,8 @@ (wrap (list (` (type: (~+ (writer.export export)) (~ (writer.declaration declaration)) (~ capability))) - (` (def: (~+ (writer.export export)) - (~ (code.local-identifier forge)) - (All [(~+ (list;map code.local-identifier vars))] + (` (def: (~ (code.local-identifier forge)) + (All [(~+ (list@map code.local-identifier vars))] (-> (-> (~ input) (~ output)) (~ capability))) (~! ..forge))) diff --git a/stdlib/source/lux/data/collection/queue/priority.lux b/stdlib/source/lux/data/collection/queue/priority.lux index 50f6f7de6..555c7b8d3 100644 --- a/stdlib/source/lux/data/collection/queue/priority.lux +++ b/stdlib/source/lux/data/collection/queue/priority.lux @@ -44,7 +44,11 @@ (#finger.Branch _ left right) (n.+ (recur left) (recur right)))))) -(def: #export (member? Equivalence queue member) +(def: #export empty? + (All [a] (-> (Queue a) Bit)) + (|>> ..size (n.= 0))) + +(def: #export (member? equivalence queue member) (All [a] (-> (Equivalence a) (Queue a) a Bit)) (case queue #.None @@ -54,7 +58,7 @@ (loop [node (get@ #finger.node fingers)] (case node (#finger.Leaf _ reference) - (:: Equivalence = reference member) + (:: equivalence = reference member) (#finger.Branch _ left right) (or (recur left) diff --git a/stdlib/source/lux/test.lux b/stdlib/source/lux/test.lux index dd00517d0..2f54866c0 100644 --- a/stdlib/source/lux/test.lux +++ b/stdlib/source/lux/test.lux @@ -69,17 +69,22 @@ (def: separator text.new-line) +(def: #export (and' left right) + {#.doc "Sequencing combinator."} + (-> Assertion Assertion Assertion) + (do promise.monad + [[l-counter l-documentation] left + [r-counter r-documentation] right] + (wrap [(add-counters l-counter r-counter) + (format l-documentation ..separator r-documentation)]))) + (def: #export (and left right) {#.doc "Sequencing combinator."} (-> Test Test Test) (do random.monad [left left right right] - (wrap (do promise.monad - [[l-counter l-documentation] left - [r-counter r-documentation] right] - (wrap [(add-counters l-counter r-counter) - (format l-documentation ..separator r-documentation)]))))) + (wrap (..and' left right)))) (def: context-prefix text.tab) diff --git a/stdlib/source/lux/world/shell.lux b/stdlib/source/lux/world/shell.lux index f9f214562..47215c295 100644 --- a/stdlib/source/lux/world/shell.lux +++ b/stdlib/source/lux/world/shell.lux @@ -1,15 +1,21 @@ (.module: [lux #* - ["." io (#+ IO)] + ["@" target] ["jvm" host (#+ import:)] [abstract - ["." enum]] + [monad (#+ do)]] [control - [monad (#+ do)] - ["." try (#+ Try)]] + ["." function] + ["." try (#+ Try)] + ["." io (#+ IO)] + [security + ["!" capability (#+ capability:)] + ["?" policy (#+ Safety Safe)]] + [concurrency + ["." stm (#+ Var STM)] + ["." promise (#+ Promise) ("#@." monad)]]] [data ["." product] - ["." maybe] [number (#+ hex) ["n" nat]] ["." text @@ -19,146 +25,366 @@ ["." context (#+ Context)]] [collection ["." array (#+ Array)] - ["." list ("#;." fold functor)] - ["." dictionary]]] - [tool - [compiler - ["." host]]] - [world - ["." console (#+ Console)]]]) + ["." list ("#@." fold functor)] + ["." dictionary]]]]) -## https://en.wikipedia.org/wiki/Code_injection#Shell_injection -(def: windows? - (-> Text Bit) - (text.starts-with? "windows")) - -(def: (sanitize-command windows?) - (-> Bit (-> Text Text)) - (let [dangerous (format "\&#;`|*?~<>^()[]{}$" - (text.from-code (hex "0A")) - (text.from-code (hex "FF"))) - dangerous (if windows? - (format dangerous "%!") - dangerous) - indices (enum.range n.enum 0 (dec (text.size dangerous)))] - (function (_ unsafe) - (list;fold (function (_ index safer) - (let [bad (|> dangerous (text.nth index) maybe.assume text.from-code) - good (if windows? - " " - (format "\" bad))] - (text.replace-all bad good safer))) - unsafe - indices)))) - -(def: (sanitize-argument windows?) - (-> Bit (-> Text Text)) - (if windows? - (|>> (text.replace-all "%" " ") - (text.replace-all "!" " ") - (text.replace-all text.double-quote " ") - (text.enclose' text.double-quote)) - (|>> (text.replace-all "'" "\'") - (text.enclose' "'")))) - -(`` (for {(~~ (static host.old)) - (as-is (import: java/lang/String - (toLowerCase [] java/lang/String)) - - (def: (arguments-array arguments) - (-> (List Text) (Array java/lang/String)) - (product.right - (list;fold (function (_ argument [idx output]) - [(inc idx) (jvm.array-write idx argument output)]) - [0 (jvm.array java/lang/String (list.size arguments))] - arguments))) - - (import: (java/util/Map k v) - (put [k v] v)) - - (def: (load-environment input target) - (-> Context - (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 key 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) - (getOutputStream [] #io #try java/io/OutputStream) - (destroy [] #io #try void)) - - (def: (process-console process) - (-> java/lang/Process (IO (Try (Console IO)))) - (do (try.with io.monad) - [jvm-input (java/lang/Process::getInputStream process) - #let [jvm-input (|> jvm-input - java/io/InputStreamReader::new - java/io/BufferedReader::new)] - jvm-output (java/lang/Process::getOutputStream process)] - (wrap (: (Console IO) - (structure - (def: can-read - (console.can-read - (function (_ _) - (|> jvm-input - java/io/Reader::read - (:: (try.with io.monad) map .nat))))) - - (def: can-read-line - (console.can-read - (function (_ _) - (|> jvm-input - java/io/BufferedReader::readLine)))) +(capability: #export (Can-Read !) + (can-read [] (! (Try Text)))) + +(capability: #export (Can-Write !) + (can-write Text (! (Try Any)))) + +(capability: #export (Can-Destroy !) + (can-destroy [] (! (Try Any)))) + +(type: #export Exit + Int) + +(def: #export normal + Exit + +0) + +(capability: #export (Can-Wait !) + (can-wait [] (! (Try Exit)))) + +(signature: #export (Process !) + (: (Can-Read !) + read) + (: (Can-Read !) + error) + (: (Can-Write !) + write) + (: (Can-Destroy !) + destroy) + (: (Can-Wait !) + await)) + +(def: (async-process process) + (-> (Process IO) (Process Promise)) + (`` (structure + (~~ (template [ ] + [(def: + ( + (|>> (!.use (:: process )) + promise.future)))] + + [read ..can-read] + [error ..can-read] + [write ..can-write] + [destroy ..can-destroy] + [await ..can-wait] + ))))) + +(type: #export Environment + Context) + +(type: #export Command + Text) + +(type: #export Argument + Text) + +(capability: #export (Can-Execute !) + (can-execute [Environment Command (List Argument)] (! (Try (Process !))))) + +(signature: #export (Shell !) + (: (Can-Execute !) + execute)) + +(def: #export (async shell) + (-> (Shell IO) (Shell Promise)) + (structure + (def: execute + (..can-execute + (function (_ input) + (promise.future + (do (try.with io.monad) + [process (!.use (:: shell execute) input)] + (wrap (..async-process process))))))))) + +(signature: (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 "?@.")) + (structure + (def: command (|>> sanitize-command (!.use ?@can-upgrade))) + (def: argument (|>> sanitize-argument (!.use ?@can-upgrade))) + (def: value (!.use ?@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 [ (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 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 key value target') + target')) + target + (dictionary.entries input))) - (def: can-write - (console.can-write - (function (_ message) - (|> jvm-output - (java/io/OutputStream::write (encoding.to-utf8 message)))))) + (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) - (def: can-close - (console.can-close - (function (_ _) - (|> process - java/lang/Process::destroy))))))))) - - (import: java/lang/ProcessBuilder - (new [[java/lang/String]]) - (environment [] #io #try (java/util/Map java/lang/String java/lang/String)) - (start [] #io #try java/lang/Process)) - - (import: java/lang/System - (#static getProperty [java/lang/String] #io #try java/lang/String)) - )})) - -(def: #export (execute environment command arguments) - (-> Context Text (List Text) (IO (Try (Console IO)))) - (`` (for {(~~ (static host.old)) - (do {! (try.with io.monad)} - [windows? (:: ! map (|>> java/lang/String::toLowerCase ..windows?) - (java/lang/System::getProperty "os.name")) - #let [builder (java/lang/ProcessBuilder::new (arguments-array (list& (sanitize-command windows? command) - (list;map (sanitize-argument windows?) arguments))))] - environment (:: ! map (load-environment environment) - (java/lang/ProcessBuilder::environment builder)) - process (java/lang/ProcessBuilder::start builder)] - (process-console process))}))) + (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)) + + (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) + (`` (structure + (~~ (template [ ] + [(def: + (..can-read + (function (_ _) + (java/io/BufferedReader::readLine ))))] + + [read jvm-input] + [error jvm-error] + )) + (def: write + (..can-write + (function (_ message) + (|> jvm-output + (java/io/OutputStream::write (encoding.to-utf8 message)))))) + (~~ (template [ ] + [(def: + ( + (function (_ _) + ( process))))] + + [destroy ..can-destroy java/lang/Process::destroy] + [await ..can-wait java/lang/Process::waitFor] + )))))))) + + (import: java/lang/ProcessBuilder + (new [[java/lang/String]]) + (environment [] #io #try (java/util/Map java/lang/String java/lang/String)) + (start [] #io #try java/lang/Process)) + + (import: java/lang/System + (#static getProperty [java/lang/String] #io #try java/lang/String)) + )] + (for {@.old (as-is ) + @.jvm (as-is )})) + +## 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"))) + +(def: (jvm::process-builder policy command arguments) + (All [?] + (-> (Policy ?) (Safe Command ?) (List (Safe Argument ?)) + java/lang/ProcessBuilder)) + (|> (list@map (:: policy value) arguments) + (list& (:: policy value command)) + ..jvm::arguments-array + java/lang/ProcessBuilder::new)) + +(structure: #export default + (Shell IO) + + (def: execute + (..can-execute + (function (_ [environment command arguments]) + (with-expansions [ (as-is (do {! (try.with io.monad)} + [windows? ..windows? + #let [builder (if windows? + (..jvm::process-builder ..windows-policy + (:: ..windows-policy command command) + (list@map (:: ..windows-policy argument) arguments)) + (..jvm::process-builder ..unix-policy + (:: ..unix-policy command command) + (list@map (:: ..unix-policy argument) arguments)))] + _ (:: ! map (..jvm::load-environment environment) + (java/lang/ProcessBuilder::environment builder)) + process (java/lang/ProcessBuilder::start builder)] + (..default-process process)))] + (for {@.old (as-is ) + @.jvm (as-is )})))))) + +(signature: #export (Simulation 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)) + +(`` (structure: (mock-process simulation state) + (All [s] (-> (Simulation s) (Var s) (Process Promise))) + + (~~ (template [ ] + [(def: + ( + (function (_ _) + (stm.commit + (do {! stm.monad} + [|state| (stm.read state)] + (case (:: simulation |state|) + (#try.Success [|state| output]) + (do ! + [_ (stm.write |state| state)] + (wrap (#try.Success output))) + + (#try.Failure error) + (wrap (#try.Failure error))))))))] + + [read ..can-read on-read] + [error ..can-read on-error] + [await ..can-wait on-await] + )) + (def: write + (..can-write + (function (_ message) + (stm.commit + (do {! stm.monad} + [|state| (stm.read state)] + (case (:: simulation on-write message |state|) + (#try.Success |state|) + (do ! + [_ (stm.write |state| state)] + (wrap (#try.Success []))) + + (#try.Failure error) + (wrap (#try.Failure error)))))))) + (def: destroy + (..can-destroy + (function (_ _) + (stm.commit + (do {! stm.monad} + [|state| (stm.read state)] + (case (:: simulation on-destroy |state|) + (#try.Success |state|) + (do ! + [_ (stm.write |state| state)] + (wrap (#try.Success []))) + + (#try.Failure error) + (wrap (#try.Failure error)))))))))) + +(structure: #export (mock simulation init) + (All [s] + (-> (-> [Environment Command (List Argument)] + (Try (Simulation s))) + s + (Shell Promise))) + + (def: execute + (..can-execute + (function (_ input) + (promise@wrap + (do try.monad + [simulation (simulation input)] + (wrap (..mock-process simulation (stm.var init))))))))) diff --git a/stdlib/source/spec/lux/world/shell.lux b/stdlib/source/spec/lux/world/shell.lux new file mode 100644 index 000000000..286cc7ce2 --- /dev/null +++ b/stdlib/source/spec/lux/world/shell.lux @@ -0,0 +1,97 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] + [control + ["." try] + [security + ["!" capability]] + [concurrency + ["." promise (#+ Promise)]]] + [data + ["." product] + ["." text ("#@." equivalence) + ["%" format (#+ format)]] + [number + ["n" nat] + ["i" int]] + [format + ["." context]]] + [math + ["." random]]] + {1 + ["." /]}) + +(template [ ] + [(def: + (-> [/.Environment /.Command (List /.Argument)]) + (|>> list [context.empty ]))] + + [echo! "echo" Text (|>)] + [sleep! "sleep" Nat %.nat] + ) + +(def: (read-test expected process) + (-> Text (/.Process Promise) _.Assertion) + (do promise.monad + [?read (!.use (:: process read) []) + ?await (!.use (:: process await) [])] + ($_ _.and' + (_.claim [/.Can-Read] + (case ?read + (#try.Success actual) + (text@= expected actual) + + (#try.Failure error) + false)) + (_.claim [/.Can-Wait /.Exit /.normal] + (case ?await + (#try.Success exit) + (i.= /.normal exit) + + (#try.Failure error) + false)) + ))) + +(def: (destroy-test process) + (-> (/.Process Promise) _.Assertion) + (do promise.monad + [?destroy (!.use (:: process destroy) []) + ?await (!.use (:: process await) [])] + (_.claim [/.Can-Destroy] + (and (case ?destroy + (#try.Success _) + true + + (#try.Failure error) + false) + (case ?await + (#try.Success _) + false + + (#try.Failure error) + true))))) + +(with-expansions [ (as-is [/.Can-Execute + /.Environment /.Command /.Argument])] + (def: #export (spec shell) + (-> (/.Shell Promise) Test) + (<| (_.with-cover [/.Shell /.Process]) + (do {! random.monad} + [message (random.ascii/alpha 10) + seconds (:: ! map (|>> (n.% 5) (n.+ 5)) random.nat)] + (wrap (do promise.monad + [?echo (!.use (:: shell execute) (..echo! message)) + ?sleep (!.use (:: shell execute) (..sleep! seconds))] + (case [?echo ?sleep] + [(#try.Success echo) (#try.Success sleep)] + ($_ _.and' + (_.claim + true) + (..read-test message echo) + (..destroy-test sleep)) + + _ + (_.claim + false)))))))) diff --git a/stdlib/source/test/lux/control.lux b/stdlib/source/test/lux/control.lux index 50e737e98..14d75527f 100644 --- a/stdlib/source/test/lux/control.lux +++ b/stdlib/source/test/lux/control.lux @@ -3,14 +3,14 @@ ["_" test (#+ Test)]] ["." / #_ ["#." concatenative] - [concurrency - ["#." actor] - ["#." atom] - ["#." frp] - ["#." process] - ["#." promise] - ["#." semaphore] - ["#." stm]] + ["#." concurrency #_ + ["#/." actor] + ["#/." atom] + ["#/." frp] + ["#/." thread] + ["#/." promise] + ["#/." semaphore] + ["#/." stm]] ["#." continuation] ["#." exception] ["#." function @@ -44,13 +44,13 @@ (def: concurrency Test ($_ _.and - /actor.test - /atom.test - /frp.test - /process.test - /promise.test - /semaphore.test - /stm.test + /concurrency/actor.test + /concurrency/atom.test + /concurrency/frp.test + /concurrency/thread.test + /concurrency/promise.test + /concurrency/semaphore.test + /concurrency/stm.test )) (def: function diff --git a/stdlib/source/test/lux/control/concurrency/process.lux b/stdlib/source/test/lux/control/concurrency/process.lux deleted file mode 100644 index 6d59672ca..000000000 --- a/stdlib/source/test/lux/control/concurrency/process.lux +++ /dev/null @@ -1,46 +0,0 @@ -(.module: - [lux #* - ["_" test (#+ Test)] - [abstract - [monad (#+ do)]] - [control - ["." io]] - [data - [number - ["n" nat] - ["i" int]]] - [time - ["." instant (#+ Instant)] - ["." duration]] - [math - ["." random]]] - {1 - ["." / - [// - ["." atom (#+ Atom)] - ["." promise]]]}) - -(def: #export test - Test - (<| (_.covering /._) - (do {! random.monad} - [dummy random.nat - expected random.nat - delay (|> random.nat (:: ! map (n.% 100)))] - ($_ _.and - (_.cover [/.parallelism] - (n.> 0 /.parallelism)) - (wrap (do promise.monad - [reference-time (promise.future instant.now) - #let [box (atom.atom [reference-time dummy])] - _ (promise.future - (/.schedule delay (do io.monad - [execution-time instant.now] - (atom.write [execution-time expected] box)))) - _ (promise.wait delay) - [execution-time actual] (promise.future (atom.read box))] - (_.claim [/.schedule] - (and (i.>= (.int delay) - (duration.to-millis (instant.span reference-time execution-time))) - (n.= expected actual))))) - )))) diff --git a/stdlib/source/test/lux/control/concurrency/thread.lux b/stdlib/source/test/lux/control/concurrency/thread.lux new file mode 100644 index 000000000..6d59672ca --- /dev/null +++ b/stdlib/source/test/lux/control/concurrency/thread.lux @@ -0,0 +1,46 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] + [control + ["." io]] + [data + [number + ["n" nat] + ["i" int]]] + [time + ["." instant (#+ Instant)] + ["." duration]] + [math + ["." random]]] + {1 + ["." / + [// + ["." atom (#+ Atom)] + ["." promise]]]}) + +(def: #export test + Test + (<| (_.covering /._) + (do {! random.monad} + [dummy random.nat + expected random.nat + delay (|> random.nat (:: ! map (n.% 100)))] + ($_ _.and + (_.cover [/.parallelism] + (n.> 0 /.parallelism)) + (wrap (do promise.monad + [reference-time (promise.future instant.now) + #let [box (atom.atom [reference-time dummy])] + _ (promise.future + (/.schedule delay (do io.monad + [execution-time instant.now] + (atom.write [execution-time expected] box)))) + _ (promise.wait delay) + [execution-time actual] (promise.future (atom.read box))] + (_.claim [/.schedule] + (and (i.>= (.int delay) + (duration.to-millis (instant.span reference-time execution-time))) + (n.= expected actual))))) + )))) diff --git a/stdlib/source/test/lux/control/security/policy.lux b/stdlib/source/test/lux/control/security/policy.lux index 4a4f8409a..4885b52eb 100644 --- a/stdlib/source/test/lux/control/security/policy.lux +++ b/stdlib/source/test/lux/control/security/policy.lux @@ -20,7 +20,7 @@ [math ["." random]]] {1 - ["." / (#+ Context Privacy Can-Conceal Can-Reveal Privilege Private with-policy)]}) + ["." / (#+ Context Privacy Can-Conceal Can-Reveal Privilege Private)]}) (def: (injection can-conceal) (All [label] @@ -48,7 +48,7 @@ (def: (policy _) (Ex [%] (-> Any (Policy %))) - (with-policy + (/.with-policy (: (Context Privacy Policy) (function (_ (^@ privilege (^open "%@."))) (structure @@ -72,8 +72,7 @@ Test (<| (_.covering /._) (_.with-cover [/.Policy - /.Can-Upgrade /.Can-Downgrade - /.can-upgrade /.can-downgrade]) + /.Can-Upgrade /.Can-Downgrade]) (do random.monad [#let [policy-0 (policy [])] raw-password (random.ascii 10) diff --git a/stdlib/source/test/lux/data/collection/queue/priority.lux b/stdlib/source/test/lux/data/collection/queue/priority.lux index 555214148..073ce2c8d 100644 --- a/stdlib/source/test/lux/data/collection/queue/priority.lux +++ b/stdlib/source/test/lux/data/collection/queue/priority.lux @@ -1,56 +1,92 @@ (.module: [lux #* - ["%" data/text/format (#+ format)] ["_" test (#+ Test)] [abstract ["." monad (#+ do)]] [data - ["." maybe] + ["." maybe ("#@." functor)] + ["." bit ("#@." equivalence)] [number ["n" nat]]] [math - ["r" random (#+ Random)]]] + ["." random (#+ Random)]]] {1 ["." / (#+ Queue)]}) -(def: #export (queue size) +(def: #export (random size) (-> Nat (Random (Queue Nat))) - (do {! r.monad} - [inputs (r.list size r.nat)] + (do {! random.monad} + [inputs (random.list size random.nat)] (monad.fold ! (function (_ head tail) (do ! - [priority r.nat] + [priority random.nat] (wrap (/.push priority head tail)))) /.empty inputs))) (def: #export test Test - (<| (_.context (%.name (name-of /.Queue))) - (do {! r.monad} - [size (|> r.nat (:: ! map (n.% 100))) - sample (..queue size) - non-member-priority r.nat - non-member (|> r.nat (r.filter (|>> (/.member? n.equivalence sample) not)))] + (<| (_.covering /._) + (_.with-cover [/.Queue]) + (do {! random.monad} + [size (:: ! map (n.% 100) random.nat) + sample (..random size) + non-member-priority random.nat + non-member (random.filter (|>> (/.member? n.equivalence sample) not) + random.nat) + + max-member random.nat + min-member random.nat] ($_ _.and - (_.test "I can query the size of a queue (and empty queues have size 0)." - (n.= size (/.size sample))) - (_.test "Enqueueing and dequeing affects the size of queues." - (and (n.= (inc size) - (/.size (/.push non-member-priority non-member sample))) - (or (n.= 0 (/.size sample)) - (n.= (dec size) - (/.size (/.pop sample)))))) - (_.test "I can query whether an element belongs to a queue." - (and (and (not (/.member? n.equivalence sample non-member)) - (/.member? n.equivalence - (/.push non-member-priority non-member sample) - non-member)) - (or (n.= 0 (/.size sample)) - (and (/.member? n.equivalence - sample - (maybe.assume (/.peek sample))) - (not (/.member? n.equivalence - (/.pop sample) - (maybe.assume (/.peek sample)))))))) + (_.cover [/.size] + (n.= size (/.size sample))) + (_.cover [/.empty?] + (bit@= (n.= 0 (/.size sample)) + (/.empty? sample))) + (_.cover [/.empty] + (/.empty? /.empty)) + (_.cover [/.peek] + (case (/.peek sample) + (#.Some first) + (n.> 0 (/.size sample)) + + #.None + (/.empty? sample))) + (_.cover [/.member?] + (case (/.peek sample) + (#.Some first) + (/.member? n.equivalence sample first) + + #.None + (/.empty? sample))) + (_.cover [/.push] + (let [sample+ (/.push non-member-priority non-member sample)] + (and (not (/.member? n.equivalence sample non-member)) + (n.= (inc (/.size sample)) + (/.size sample+)) + (/.member? n.equivalence sample+ non-member)))) + (_.cover [/.pop] + (let [sample- (/.pop sample)] + (or (and (/.empty? sample) + (/.empty? sample-)) + (n.= (dec (/.size sample)) + (/.size sample-))))) + (_.with-cover [/.Priority] + ($_ _.and + (_.cover [/.max] + (|> /.empty + (/.push /.min min-member) + (/.push /.max max-member) + /.peek + (maybe@map (n.= max-member)) + (maybe.default false))) + (_.cover [/.min] + (|> /.empty + (/.push /.max max-member) + (/.push /.min min-member) + /.pop + /.peek + (maybe@map (n.= min-member)) + (maybe.default false))) + )) )))) diff --git a/stdlib/source/test/lux/type/check.lux b/stdlib/source/test/lux/type/check.lux index ccd44ed89..3936c7a65 100644 --- a/stdlib/source/test/lux/type/check.lux +++ b/stdlib/source/test/lux/type/check.lux @@ -36,7 +36,7 @@ (let [(^open "R@.") r.monad pairG (r.and (type' num-vars) (type' num-vars)) - quantifiedG (r.and (R@wrap (list)) (type' (n.+ 2 num-vars))) + quantifiedG (r.and (R@wrap (list)) (type' (inc num-vars))) random-pair (r.either (r.either (R@map (|>> #.Sum) pairG) (R@map (|>> #.Product) pairG)) (r.either (R@map (|>> #.Function) pairG) @@ -45,7 +45,7 @@ (R@map (|>> #.Ex) r.nat))] (case num-vars 0 random-id - _ (r.either (R@map (|>> (n.% num-vars) #.Parameter) r.nat) + _ (r.either (R@map (|>> (n.% num-vars) (n.* 2) inc #.Parameter) r.nat) random-id))) random-quantified (r.either (R@map (|>> #.UnivQ) quantifiedG) (R@map (|>> #.ExQ) quantifiedG))] @@ -108,7 +108,7 @@ (<| (_.context (%.name (name-of /._))) ($_ _.and (do r.monad - [sample (|> ..type (r.filter valid-type?))] + [sample (r.filter ..valid-type? ..type)] ($_ _.and (_.test "Any is the super-type of everything." (/.checks? Any sample)) @@ -159,7 +159,7 @@ nameL gen-short nameR (|> gen-short (r.filter (|>> (text@= nameL) not))) paramL ..type - paramR (|> ..type (r.filter (|>> (/.checks? paramL) not)))] + paramR (r.filter (|>> (/.checks? paramL) not) ..type)] ($_ _.and (_.test "Primitive types match when they have the same name and the same parameters." (/.checks? (#.Primitive nameL (list paramL)) diff --git a/stdlib/source/test/lux/world.lux b/stdlib/source/test/lux/world.lux index e46eecda3..c5b0ecc59 100644 --- a/stdlib/source/test/lux/world.lux +++ b/stdlib/source/test/lux/world.lux @@ -2,10 +2,12 @@ [lux #* ["_" test (#+ Test)]] ["." / #_ - ["#." file]]) + ["#." file] + ["#." shell]]) (def: #export test Test ($_ _.and /file.test + /shell.test )) diff --git a/stdlib/source/test/lux/world/shell.lux b/stdlib/source/test/lux/world/shell.lux new file mode 100644 index 000000000..f98fc6a17 --- /dev/null +++ b/stdlib/source/test/lux/world/shell.lux @@ -0,0 +1,58 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)]] + [data + [number + ["n" nat] + ["i" int]] + [collection + ["." list]]]] + {1 + ["." /]} + {[1 #spec] + ["$." /]}) + +(exception: dead) + +(def: (simulation [environment command arguments]) + (-> [/.Environment /.Command (List /.Argument)] + (/.Simulation Bit)) + (structure + (def: (on-read dead?) + (if dead? + (exception.throw ..dead []) + (do try.monad + [to-echo (try.from-maybe (list.head arguments))] + (wrap [dead? to-echo])))) + + (def: (on-error dead?) + (if dead? + (exception.throw ..dead []) + (exception.return [dead? ""]))) + + (def: (on-write message dead?) + (if dead? + (exception.throw ..dead []) + (#try.Success dead?))) + + (def: (on-destroy dead?) + (if dead? + (exception.throw ..dead []) + (#try.Success true))) + + (def: (on-await dead?) + (if dead? + (exception.throw ..dead []) + (#try.Success [true /.normal]))))) + +(def: #export test + Test + (<| (_.covering /._) + (_.with-cover [/.mock /.Simulation] + ($/.spec (/.mock (|>> ..simulation #try.Success) + false))))) -- cgit v1.2.3