cl-isolated
cl-isolated copied to clipboard
kanru
eval-return-values branch discussion
To make cl-isolated to work better as a scripting engine we need the following changes. I have implemented those changes in the eval-return-values branch.
Please comment.
I might have gone a bit over board with code etc in the discussion but since its the first majour change to cl-isolated in many moons I would like the communication to be clear.
- Easily "allow" an additional set of functionality to be add to an instance of cl-isolate before trying to run/eval code with cl-isolate. Adding additional symbols is not enough we need to be able to add functions and/or even whole packages.
For that to work I need to make a compatibility breaking change.
(defvar *allowed-extra-symbols* nil) needs to be replaced by
(defvar *allowed-isolated-symbols* nil)
(defvar *allowed-isolated-functions* nil)
Functions etc to add functionality to cl-isolated:
(defvar *allowed-packages-symbols* nil)
(defvar *allowed-packages-functions* nil)
(defun set-allowed-symbol (symbol)
(if (fboundp symbol)
(push symbol *allowed-packages-functions*)
(push symbol *allowed-packages-symbols*)))
(defun get-package-symbols (packages &optional excluded-symbols)
(let (symbols)
(dolist (package packages)
(do-external-symbols (s (find-package package))
(unless (find s excluded-symbols :test 'equalp)
(push s symbols))))
symbols))
(defun allow-symbols (symbols)
(dolist (symbol symbols)
(set-allowed-symbol symbol)))
(defun allow-package-symbols (packages &optional excluded-symbols)
(unless *allowed-packages-symbols*
(dolist (package packages)
(do-external-symbols (symbol (find-package package))
(unless (find symbol excluded-symbols :test 'equalp)
(set-allowed-symbol symbol))))))
- We need translate-form to do a touch more checking/validation ie checks before eval
a. Throw an error if something is not allowed by cl-isolate
To not have to loop each time the check needs to be done we need the following convenience function and vars
(defvar *allowed-isolated-symbols* nil)
(defvar *allowed-isolated-functions* nil)
(defun isolated-allowed-symbols ()
(loop :for symbol :being :the :symbol :in (find-package 'isolated-cl)
:when (not (get symbol :isolated-locked))
:do
(if (fboundp symbol)
(push symbol *allowed-isolated-functions*)
(push symbol *allowed-isolated-symbols*))))
b. Differentiate between symbols and functions when translating code and throwing errors.
(defun translate-form (form)
(when (and (consp form)
(circular-tree-p form))
(error 'circular-list))
(let ((cons-count 0))
(labels ((translate (form)
(typecase form
(cons (if (> (incf cons-count) *max-elements*)
(error 'dimension-error)
(cons (translate (car form))
(translate (cdr form)))))
(number form)
(character form)
(pathname form)
(array (if (> (array-total-size form) *max-elements*)
(error 'dimension-error)
(let ((arr (make-array (array-dimensions form)
:element-type
(array-element-type form))))
(dotimes (i (array-total-size arr) arr)
(setf (row-major-aref arr i)
(translate-validate-form
(row-major-aref form i)))))))
(keyword form)
(symbol (if (fboundp form)
(or (find form *allowed-isolated-functions*)
(find form *allowed-packages-functions*)
(error 'undefined-function :name form))
(if (or (find form *allowed-isolated-symbols*)
(find form *allowed-packages-symbols*))
form
(intern (symbol-name form) *env*))))
(t (error 'unsupported-type :type (type-of form))))))
(translate form))))
- Allow code to be passed to cl-isolate that is not in a string but in sexp already. Working with strings is just no fun because you have to deal with " etc when creating the code to be feed to cl-isolated.
- Return/Expose the results of one or more of the sexps in the code fed to cl-isolated.
(isolated-allowed-symbols)
(defun reset ()
(setf isolated-impl::*allowed-isolated-symbols* nil)
(setf isolated-impl::*allowed-isolated-functions* nil)
(setf isolated-impl::*allowed-packages-symbols* nil)
(setf isolated-impl::*allowed-packages-functions* nil)
(isolated-allowed-symbols)
(ignore-errors
(delete-package *env*))
(make-package *env* :use '(#:isolated-cl))
(loop :for name :in '("+" "++" "+++" "*" "**" "***" "/" "//" "///" "-")
:do (eval `(defparameter ,(intern name *env*) nil)))
(loop :for fn :in '(+ - * /)
:for symbol := (intern (symbol-name fn) *env*)
:do (setf (get symbol :isolated-locked) t)
(eval `(defun ,symbol (&rest args)
(apply ',fn args))))
*env*)
(defun read-no-eval (forms &key packages exclude-symbols)
"Returns forms and/or any messages."
(unless (or (find-package *env*) (reset))
(return-from read-no-eval "ISOLATED-PACKAGE-ERROR: Isolated package not found."))
(allow-package-symbols packages exclude-symbols)
(let ((validated-forms)
(msg))
(labels ((sexp-read (sexps)
(let (values)
(if (listp (car sexps))
(dolist (sexp sexps)
(push (translate-form sexp) values))
(push (translate-form sexps) values))
(reverse values)))
(sread (string)
(let (values)
(with-input-from-string (s string)
(loop for sexp = (read s nil)
while sexp
do
(if (listp (car sexp))
(dolist (sexpx sexp)
(push (translate-form sexpx)
values))
(push (translate-form sexp)
values))))
(reverse values))))
(setf validated-forms
(if (stringp forms)
(sread forms)
(sexp-read forms))))
(values validated-forms msg)))
(defun read-eval (forms &key packages exclude-symbols)
"Returns eval values and/or any messages."
(unless (or (find-package *env*) (reset))
(return-from read-eval (values nil "ISOLATED-PACKAGE-ERROR: Isolated package not found.")))
(allow-package-symbols packages exclude-symbols)
(with-isolated-env
(let ((values)
(msg))
(flet ((sexp-read (sexps)
(let (values)
(if (listp (car sexps))
(dolist (sexp sexps)
(push (multiple-value-list
(eval
(translate-form sexp)))
values))
(push (multiple-value-list
(eval
(translate-form sexps)))
values))
(reverse values)))
(sread (string)
(let (values)
(with-input-from-string (s string)
(loop for sexp = (read s nil)
while sexp
do
(multiple-value-list
(if (listp (car sexp))
(dolist (sexpx sexp)
(push (multiple-value-list
(eval
(translate-form sexpx)))
values))
(push (multiple-value-list
(eval
(translate-form sexp)))
values)))))
(reverse values))))
(setf values (if (stringp forms)
(sread forms)
(sexp-read forms))))
(values values msg))))
(defun ssetq (name value)
(setf (symbol-value (find-symbol (string-upcase name) *env*))
value))
(defun read-eval-print (forms &optional (stream *standard-output*))
(unless (or (find-package *env*) (reset))
(msge stream "ISOLATED-PACKAGE-ERROR: Isolated package not found.")
(return-from read-eval-print nil))
(with-isolated-env
(let (form)
(flet ((sexp-read (sexps)
(let (values)
(if (listp (car sexps))
(dolist (sexp sexps)
(push (multiple-value-list
(eval
(translate-form sexp)))
values))
(push (multiple-value-list
(eval
(translate-form sexps)))
values))
(reverse values)))
(sread (string)
(let (values)
(with-input-from-string (s string)
(loop for sexp = (read s nil)
while sexp
do
(multiple-value-list
(if (listp (car sexp))
(dolist (sexpx sexp)
(setf form (translate-form sexpx))
(push (multiple-value-list
(eval
(prog1
form
(ssetq "-" form))))
values))
(progn
(setf form (translate-form sexp))
(push (multiple-value-list
(eval
(prog1
form
(ssetq "-" form))
))
values))))))
(reverse values)))
(muffle (c)
(declare (ignore c))
(when (find-restart 'muffle-warning)
(muffle-warning))))
(let (form values)
(handler-case
(handler-bind ((warning #'muffle))
(setf values (if (stringp forms)
(sread forms)
(sexp-read forms)))
(dolist (value values)
(isolated-print value stream)))
(undefined-function (c)
(msge stream "~A: The function ~A is undefined."
(type-of c) (cell-error-name c)))
(end-of-file (c)
(msge stream "~A" (type-of c)))
(reader-error ()
(msge stream "READER-ERROR"))
(package-error ()
(msge stream "PACKAGE-ERROR"))
(stream-error (c)
(msge stream "~A" (type-of c)))
(storage-condition ()
(msge stream "STORAGE-CONDITION"))
(t (c)
(msge stream "~A: ~A" (type-of c) c)))
(flet ((svalue (string)
(symbol-value (find-symbol string *env*))))
(ssetq "///" (svalue "//"))
(ssetq "//" (svalue "/"))
(ssetq "/" values)
(ssetq "***" (svalue "**"))
(ssetq "**" (svalue "*"))
(ssetq "*" (first values))
(ssetq "+++" (svalue "++"))
(ssetq "++" (svalue "+"))
(ssetq "+" form))))))
nil)
Examples:
(isolated::read-no-eval (list '(princ-to-string '(hello world))
'(princ-to-string '(eish world))))
((PRINC-TO-STRING '(ISOLATED/LOCAL::HELLO ISOLATED/LOCAL::WORLD))
(PRINC-TO-STRING '(ISOLATED/LOCAL::EISH ISOLATED/LOCAL::WORLD)))
NIL
(isolated::read-eval (list '(princ-to-string '(hello world))
'(princ-to-string '(eish world))))
(("(HELLO WORLD)") ("(EISH WORLD)"))
NIL
(isolated::read-eval-print (list '(princ-to-string '(hello world))
'(princ-to-string '(eish world))))
=> "(HELLO WORLD)"
=> "(EISH WORLD)"
NIL
(isolated:read-eval-print "(princ-to-string '(hello world)) (princ-to-string '(eish world))")
=> "(HELLO WORLD)"
=> "(EISH WORLD)"
NIL
Examples Allowing additional functions:
CL-USER> (defun do-eish (eish) eish)
DO-EISH
CL-USER> (isolated:read-eval-print "(do-eish 'eish)")
;; UNDEFINED-FUNCTION: The function DO-EISH is undefined.
CL-USER> (isolated-impl:allow-symbols (list 'do-eish))
CL-USER> (isolated::read-no-eval "(cl-user::do-eish 'cl-user::eish)")
((DO-EISH 'ISOLATED/LOCAL::EISH))
NIL
CL-USER> (isolated-impl:allow-symbols (list 'do-eish 'eish))
CL-USER> (isolated::read-no-eval "(cl-user::do-eish 'cl-user::eish)")
((DO-EISH 'EISH))
NIL
(isolated::read-eval-print "(cl-user::do-eish 'eish)")
=> EISH
NIL
CL-USER> (isolated::read-eval-print "(cl-user::do-eish 'cl-user::eish)")
=> COMMON-LISP-USER::EISH
NIL
I had to tweak translate-form to deal with defun and defmacro. Because we are now keeping more detailed track of which functions are allowed and which are not I have to update the tracking while parsing defun(s). There might be a better way to do it, for instance to move tracking down to isolated-cl and making the macros deal with it but for now the current hack should work for most scenarios.
;; To keep track of functions created by user in the scripts/code
(defparameter *allowed-internal-functions* nil)
;; keeping track of previous form in translate so that I can identify which functions are added in the
;; form submitted
(defparameter *previous-form* nil)
(defun translate-form (form)
(when (and (consp form)
(circular-tree-p form))
(error 'circular-list))
(let ((cons-count 0))
(labels ((translate (form)
(typecase form
(cons (if (> (incf cons-count) *max-elements*)
(error 'dimension-error)
(cons (translate (car form))
(translate (cdr form)))))
(number form)
(character form)
(pathname form)
(array (if (> (array-total-size form) *max-elements*)
(error 'dimension-error)
(let ((arr (make-array (array-dimensions form)
:element-type
(array-element-type form))))
(dotimes (i (array-total-size arr) arr)
(setf (row-major-aref arr i)
(translate-form
(row-major-aref form i)))))))
(keyword form)
(symbol
(when (or (equalp *previous-form* 'isolated-cl::defun)
(equalp *previous-form* 'isolated-cl::defmacro)
(equalp *previous-form* 'cl::defun)
(equalp *previous-form* 'cl::defmacro))
(pushnew form *allowed-internal-functions*))
(let ((final-form
(if (fboundp form)
(or (find form *allowed-isolated-functions*)
(find form *allowed-packages-functions*)
(find form *allowed-internal-functions*)
(or
(and (equalp form 'isolated-cl::defun) form)
(and (equalp form 'isolated-cl::defmacro) form)
(and (equalp form 'cl:defun) form)
(and (equalp form 'cl:defmacro) form))
(error 'undefined-function :name form))
(if (or (find form *allowed-isolated-symbols*)
(find form *allowed-packages-symbols*))
form
(intern (symbol-name form) *env*)))))
(setf *previous-form* final-form)
final-form))
(t (error 'unsupported-type :type (type-of form))))))
(translate form))))