eval-return-values branch discussion

[Harag]

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.

1. 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))))))

2. 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))))

3. 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.

+

4. 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:
```lisp
(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

[Harag]

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))))