stk/Lib/security.stk

112 lines
3.7 KiB
Plaintext
Raw Permalink Normal View History

1998-04-10 06:59:06 -04:00
;;;;
;;;; s e c u r i t y . s t k -- Secure environments building
;;;;
;;;;
;;;; Copyright <20> 1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;; Permission to use, copy, and/or distribute this software and its
;;;; documentation for any purpose and without fee is hereby granted, provided
;;;; that both the above copyright notice and this permission notice appear in
;;;; all copies and derived works. Fees for distribution or use of this
;;;; software or derived works may only be charged with express written
;;;; permission of the copyright holder.
;;;; This software is provided ``as is'' without express or implied warranty.
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 11-Nov-1996 20:03
;;;; Last file update: 13-Nov-1996 19:47
;; Security is achieved by the function "set-security-level!". This function
;; sets the desired level of security. Levels are defined as is
;; level 0 -- no control
;; level 1 -- no system + send procedures
;; level 2 -- no eval and environment manipulation
;; level 3 -- no file opening / closing
;; level 4 -- no output port procedures
;; level 5 -- no input port procedures
;;
;; The function "secure-environment" returns an environment with the unsecure
;; function re-defined to an error procedure.
;;;
;;; Exported procedures
;;;
(define set-security-level! #f)
(define security-level #f)
(define secure-environment #f)
;=============================================================================
(let ()
(define current-level 0) ; The current security level
(define cached-environment (global-environment)) ; current secure env
(define security-table (vector ; Security table
;; level 0 -- no control
' ()
;; level 1 -- no system procedure
'(system exit bye quit send)
;; level 2 -- no eval and environment manipulation
'(extend-environment eval global-environment
environment->list procedure-environment eval-hook)
;; level 3 -- no file opening / closing
'(with-output-to-file open-output-file close-output-port
open-file close-port
with-input-from-file open-input-file close-input-port)
;; level-4 -- no output port procedure
'(write display newline write-char
when-port-writable format error flush)
;; level 5 -- no input port procedure
'(read read-char peek-char eof-object? char-ready? load
try-load autoload when-port-readable)))
;;;
;;; Set-security-level!
;;;
(set! set-security-level!
(lambda (n)
; make-invalid-procedure
(define (make-invalid-procedure name)
(lambda args
(security-alert name)))
; security-alert
(define (security-alert name)
(letrec ((find-level (lambda (name lev)
(if (member name (vector-ref security-table lev))
lev
(find-level name (+ lev 1))))))
(error "Security alert: Procedure \"~A\" is unsecure.\nIt is at level ~A and current level security is ~A."
name (find-level name 0) current-level)))
; all-symbols
(define (all-symbols n)
(if (= n 0)
'()
(append (vector-ref security-table n) (all-symbols (- n 1)))))
; make-environment
(define (make-environment)
(let ((bindings (map (lambda (x) (list x (make-invalid-procedure x)))
(all-symbols current-level))))
(eval `(let ,bindings (the-environment)))))
;;
;; Set-security-level! starts here
;;
(unless (= current-level n)
(set! current-level (min n (1- (vector-length security-table))))
(set! cached-environment (make-environment)))))
;;;
;;; security-level
;;;
(set! security-level (lambda () current-level))
;;;
;;; Secure-environment
;;;
(set! secure-environment (lambda () cached-environment))
)
(provide "security")