From 45c28190686fc5843ee438bb8ab77c1d17ae5ce0 Mon Sep 17 00:00:00 2001
From: Calvin Rose <calsrose@gmail.com>
Date: Sun, 27 Oct 2019 16:15:41 -0500
Subject: [PATCH] Improve flychecking.

Flychecking will now work correctly with arity checking, and
will better handle imports. Well structured modules should interact
cleanly with the flychecker in a mostly safe manner, but maliciously
crafted modules can execute arbitrary code. As such, the flychecker is
not a good way to validate completely untrusted modules.

We also extend run-context with an :evaluator option to replace
:compile-only. This is more flexible and allows users to create their
own flychecker like functionality.
---
 src/boot/boot.janet       | 14 ++++++++------
 src/core/compile.c        |  1 -
 src/mainclient/init.janet | 17 ++++++++++++++++-
 3 files changed, 24 insertions(+), 8 deletions(-)

diff --git a/src/boot/boot.janet b/src/boot/boot.janet
index 81712f96..6311e487 100644
--- a/src/boot/boot.janet
+++ b/src/boot/boot.janet
@@ -1657,7 +1657,7 @@
   :env - the environment to compile against - default is the current env\n\t
   :source - string path of source for better errors - default is \"<anonymous>\"\n\t
   :on-compile-error - callback when compilation fails - default is bad-compile\n\t
-  :compile-only - only compile the source, do not execute it - default is false\n\t
+  :evaluator - callback that executes thunks. Signature is (evaluator thunk source env where)\n\t
   :on-status - callback when a value is evaluated - default is debug/stacktrace\n\t
   :fiber-flags - what flags to wrap the compilation fiber with. Default is :ia.\n\t
   :expander - an optional function that is called on each top level form before being compiled."
@@ -1669,15 +1669,15 @@
         :on-compile-error on-compile-error
         :on-parse-error on-parse-error
         :fiber-flags guard
-        :compile-only compile-only
+        :evaluator evaluator
         :source where
         :expander expand} opts)
   (default env (fiber/getenv (fiber/current)))
   (default chunks (fn [buf p] (getline "" buf)))
-  (default compile-only false)
   (default onstatus debug/stacktrace)
   (default on-compile-error bad-compile)
   (default on-parse-error bad-parse)
+  (default evaluator (fn evaluate [x &] (x)))
   (default where "<anonymous>")
 
   # Are we done yet?
@@ -1695,7 +1695,7 @@
         (fn []
           (def res (compile source env where))
           (if (= (type res) :function)
-            (unless compile-only (res))
+            (evaluator res source env where)
             (do
               (set good false)
               (def {:error err :line line :column column :fiber errf} res)
@@ -1890,7 +1890,8 @@
   (def {:exit exit-on-error
         :source source
         :env env
-        :compile-only compile-only} (table ;args))
+        :expander expander
+        :evaluator evaluator} (table ;args))
   (def f (if (= (type path) :core/file)
            path
            (file/open path :rb)))
@@ -1913,7 +1914,8 @@
                              (when (not= (fiber/status f) :dead)
                                (debug/stacktrace f x)
                                (if exit-on-error (os/exit 1))))
-                :compile-only compile-only
+                :evaluator evaluator
+                :expander expander
                 :source (or source (if (= f path) "<anonymous>" path))})
   (when (not= f path) (file/close f))
   env)
diff --git a/src/core/compile.c b/src/core/compile.c
index 1929298d..e6b9de64 100644
--- a/src/core/compile.c
+++ b/src/core/compile.c
@@ -454,7 +454,6 @@ static JanetSlot janetc_call(JanetFopts opts, JanetSlot *slots, JanetSlot fun) {
                 break;
                 case JANET_CFUNCTION:
                 case JANET_ABSTRACT:
-                case JANET_NIL:
                     break;
                 case JANET_KEYWORD:
                     if (min_arity == 0) {
diff --git a/src/mainclient/init.janet b/src/mainclient/init.janet
index 4030ca1e..5892aa65 100644
--- a/src/mainclient/init.janet
+++ b/src/mainclient/init.janet
@@ -63,6 +63,21 @@
     (def h (get handlers n))
     (if h (h i) (do (print "unknown flag -" n) ((get handlers "h")))))
 
+  (def- safe-forms {'defn true 'defn- true 'defmacro true 'defmacro- true})
+  (def- importers {'import true 'import* true 'use true 'dofile true 'require true})
+  (defn- evaluator
+    [thunk source env where]
+    (if *compile-only*
+      (when (tuple? source)
+        (cond
+          (safe-forms (source 0)) (thunk)
+          (importers (source 0))
+          (do
+            (let [[l c] (tuple/sourcemap source)
+                  newtup (tuple/setmap (tuple ;source :evaluator evaluator) l c)]
+              ((compile newtup env where))))))
+      (thunk)))
+
   # Process arguments
   (var i 0)
   (def lenargs (length args))
@@ -72,7 +87,7 @@
       (+= i (dohandler (string/slice arg 1 2) i))
       (do
         (set *no-file* false)
-        (dofile arg :prefix "" :exit *exit-on-error* :compile-only *compile-only*)
+        (dofile arg :prefix "" :exit *exit-on-error* :evaluator evaluator)
         (set i lenargs))))
 
   (when (and (not *compile-only*) (or *should-repl* *no-file*))