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:

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