src/TeXmacs/progs/kernel/texmacs/tm-secure.scm

   1
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;;
   4 ;; MODULE      : tm-secure.scm
   5 ;; DESCRIPTION : Secure evaluation of Scheme scripts
   6 ;; COPYRIGHT   : (C) 1999  Joris van der Hoeven
   7 ;;
   8 ;; This software falls under the GNU general public license version 3 or later.
   9 ;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
  10 ;; in the root directory or <http://www.gnu.org/licenses/gpl-3.0.html>.
  11 ;;
  12 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13
  14 (texmacs-module (kernel texmacs tm-secure)
  15   (:use (kernel texmacs tm-define) (kernel texmacs tm-plugins)))
  16
  17 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  18 ;; Primitive secure functions
  19 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  20
  21 (define-public-macro (define-secure-symbols . l)
  22   (for-each (lambda (x) (property-set! x :secure #t '())) l)
  23   '(noop))
  24
  25 (define-secure-symbols
  26   boolean? null? symbol? string? pair? list?
  27   equal? == not
  28   string-length substring string-append
  29   string->list list->string string-ref string-set!
  30   + - * / gcd lcm quotient remainder modulo abs log exp sqrt
  31   car cdr caar cadr cdar cddr
  32   caaar caadr cadar caddr cdaar cdadr cddar cdddr
  33   caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
  34   cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
  35   cons list append length reverse
  36   texmacs-version texmacs-version-release*)
  37
  38 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  39 ;; Secure evaluation
  40 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  41
  42 (define (secure-args? args env)
  43   (if (null? args) #t
  44       (and (secure-expr? (car args) env)
  45            (secure-args? (cdr args) env))))
  46
  47 (define (secure-cond? expr env)
  48   (if (null? args) #t
  49       (and (or (== (caar args) 'else) (secure-expr? (caar args) env))
  50            (secure-expr? (cadar args) env)
  51            (secure-cond? (cdr args) env))))
  52
  53 (define (local-env env l)
  54   (cond ((null? l) env)
  55         ((pair? l) (local-env (assoc-set! env (car l) #t) (cdr l)))
  56         (else (assoc-set! env l #t))))
  57
  58 (define (secure-lambda? expr env)
  59   (secure-args? (cdr expr) (local-env env (car expr))))
  60
  61 (define (secure-quasiquote? args env)
  62   (cond ((npair? args) #t)
  63         ((func? args 'unquote 1) (secure-expr? (cadr args) env))
  64         ((func? args 'unquote-splicing 1) (secure-expr? (cadr args) env))
  65         (else (and (secure-quasiquote? (car args) env)
  66                    (secure-quasiquote? (cdr args) env)))))
  67
  68 (define (secure-expr? expr env)
  69   (cond ((pair? expr)
  70          (let* ((f (car expr))
  71                 (m (drd-ref secure-macros% f)))
  72            (cond (m (m (cdr expr) env))
  73                  ((assoc-ref env f) (secure-args? (cdr expr) env))
  74                  ((== f 'quote) #t)
  75                  ((== f 'quasiquote) (secure-quasiquote? (cdr expr) env))
  76                  ((symbol? f)
  77                   (and (property f :secure)
  78                        (secure-args? (cdr expr) env)))
  79                  (else (secure-args? expr env)))))
  80         ((symbol? expr) #t)
  81         ((number? expr) #t)
  82         ((string? expr) #t)
  83         ((tree? expr) #t)
  84         ((null? expr) #t)
  85         ((boolean? expr) #t)
  86         (else #f)))
  87
  88 (drd-table secure-macros%
  89   (and ,secure-args?)
  90   (begin ,secure-args?)
  91   (cond ,secure-cond?)
  92   (if ,secure-args?)
  93   (lambda ,secure-lambda?)
  94   (or ,secure-args?))
  95
  96 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  97 ;; Interface
  98 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  99
 100 (define-public (secure? expr)
 101   "Test whether it is secure to evaluate the expression @expr"
 102   (or (secure-expr? expr '())
 103       (and (lazy-plugin-force) (secure-expr? expr '()))))