113 lines
3.7 KiB
Plaintext
113 lines
3.7 KiB
Plaintext
;;;;
|
|
;;;; s e c u r i t y . s t k -- Secure environments building
|
|
;;;;
|
|
;;;;
|
|
;;;; Copyright © 1996-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
|
|
;;;;
|
|
;;;; Permission to use, copy, modify, distribute,and license this
|
|
;;;; software and its documentation for any purpose is hereby granted,
|
|
;;;; provided that existing copyright notices are retained in all
|
|
;;;; copies and that this notice is included verbatim in any
|
|
;;;; distributions. No written agreement, license, or royalty fee is
|
|
;;;; required for any of the authorized uses.
|
|
;;;; 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: 3-Sep-1999 19:54 (eg)
|
|
|
|
;; 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")
|