;;; -*- Mode:LISP; Package:FILE-SYSTEM; Readtable:ZL; Base:10 -*-


;;; Copyright LISP Machine, Inc. 1986
;;;   See filename "Copyright.Text" for
;;; licensing and release information.

;; file access control mechanism:
;; Prevent accidental deletion of files and accidental writing to directories.
;;  As RG put it to me, "George, you know that a road to hell can be paved with good intentions,
;;                       but what you might not know is that the first step is usually
;;                       the easiest, certainly the most seductive, and by far the least expensive to avoid."
;;
;;  The point here is that while it is easy to add access control it is not easy to
;;  control the control in a flexible manner. Example: In the case of a loser (uninitiated person)
;;  writing a munged META-DOT file back to the system source you would like to signal an error
;;  that would cause a "Do you really want to mess up the system sources?" to which he can reply
;;  "yes damn it" which also sends mail to the system maintainer. The present QFILE access methods
;;  just dont provide the proper signalling and control channels for that kind of thing.
;;  On the other hand, you dont need to use the file access channels, you can create other connections
;;  at will. e.g. Say a file access is being made from a QFILE server. The access control can
;;  tell what host the request is coming from and what username (and possibly password) was given.
;;  The mechanism is free do something like (CHAOS:OPEN-STREAM <requesting-host> "VERIFY-ACCESS")
;;  and talk to that.
;;
;; So for now, here are some hooks, that we will at least be using to record the patterns
;; of file access.
;;
;; 
;; * Need to handle operations defined in FSACC.
;;

;; Must hack:
;;
;; LOOKUP-FILE. looking at *CURRENT-FILE-OPERATION* to handle
;;              :CHANGE-PROPERTIES, :PROPERTIES, :DELETE, :OPEN,
;;              signal error if access denied.
;; LMFS-COMPLETE-PATH. to return nil if access denied.
;;
;; LMFS-CREATE-DIRECTORY, signal error of access denied.
;;  
;; LOOKUP-FILES. looking at *CURRENT-FILE-OPERATION* to handle
;;                    :EXPUNGE, :DIRECTORY-LIST. signal error.
;;   
;; TOP-LEVEL-DIRECTORIES. looking at *CURRENT-FILE-OPERATION* to handle
;;                        :ALL-DIRECTORIES. signal error.


(DEFVAR *ACCESS-CONTROL* NIL)

;;; *ACCESS-CONTROL* is a function of 5 arguments:
;;    (OPERATION PURPOSE DIRECTORY NAME TYPE VERSION)
;;
;; Operations.
;; :READ-FILE        read an existing file or look at its properties.
;; :WRITE-FILE       change data in an existing file.
;; :CREATE-FILE      create a new file.
;; :COMPLETE         find other file names that are like this one.
;; :CREATE-DIRECTORY create a directory.
;; :LIST             list files that match a pattern.
;;
;; Purposes:
;; :OPEN     
;; :DELETE to delete something.
;;
;;
;; If the operation is allowed then return NIL, if denied then return 
;;  :FILE if something is wrong due to the particular file.
;;  :DIRECTORY if something is wrong due to the directory.
;;  T otherwise.
;;
;; Note: The DIRECTORY NAME TYPE VERSION are that requested, e.g. ("L" "SYS") "FOO" "LISP" :NEWEST
;;       *not* that of the actual file that would be returned or acted upon by the operation.
;;       So to find the exact file you must do the operation yourself.

(DEFUN ACCESS-CONTROL (OPERATION DIRSPEC NAME TYPE VERSION)
  (SETQ DIRSPEC (COND ((TYPEP DIRSPEC 'FILE)
		       (OR (DIRECTORY-FULL-NAME DIRSPEC)
			   :ROOT))
		      ('ELSE
		       (OR DIRSPEC :ROOT))))
  (COND ((NOT *ACCESS-CONTROL*)
	 T)
	('ELSE
	 (LET ((F *ACCESS-CONTROL*)
	       (VALUE))
	   (LET ((*ACCESS-CONTROL* NIL))
	     (SETQ VALUE (FUNCALL F OPERATION
				  *CURRENT-FILE-OPERATION*
				  DIRSPEC
				  NAME
				  TYPE
				  VERSION)))
	   (COND ((EQ OPERATION :COMPLETE)
		  (NOT VALUE))
		 ((EQ VALUE NIL)
		  T)
		 ('ELSE
		  (LM-SIGNAL-ERROR (OR (CADR (ASSQ VALUE '((:FILE INCORRECT-ACCESS-TO-FILE)
							   (:DIRECTORY INCORRECT-ACCESS-TO-DIRECTORY))))
				       'ACCESS-ERROR)
				   (MAKE-PATHNAME :HOST "LM" :DEVICE "DSK"
						  :DIRECTORY DIRSPEC
						  :NAME NAME :TYPE TYPE :VERSION VERSION)
				   NIL
				   NIL *CURRENT-FILE-OPERATION*)))))))


(DEFUN LOOKUP-FILE-ACL (DIRSPEC NAME TYPE VERSION IF-DOES-NOT-EXIST IF-EXISTS REALLY-OPEN DELETED?)
  REALLY-OPEN DELETED?
  ;; IF-DOES-NOT-EXIST = NIL, :ERROR, :CREATE
  ;; IF-EXISTS = NIL, :NEW-VERSION, :SUPERSEDE, :OVERWRITE, :TRUNCATE, :APPEND, :ERROR, :RENAME, :RENAME-AND-DELETE
  ;; perhaps i have oversimplified the operations. the arguments to these function are
  ;; quite hairy however, so it is good to simplify some. What cases are meaningful
  ;; out of the 3*9 = 27 of them?
  ;; Trick: Handle multiple meanings with multiple calls.
  (COND ((MEMQ IF-EXISTS '(:SUPERSEDE :OVERWRITE :TRUNCATE :APPEND :RENAME :RENAME-AND-DELETE))
	 (ACCESS-CONTROL :WRITE-FILE DIRSPEC NAME TYPE VERSION)))
  (COND ((EQ IF-DOES-NOT-EXIST :CREATE)
	 (ACCESS-CONTROL :CREATE-FILE DIRSPEC NAME TYPE VERSION))
	('ELSE
  	 (ACCESS-CONTROL :READ-FILE  DIRSPEC NAME TYPE VERSION))))


(DEFUN COMPLETE-PATH-ACLP (DIR NAME TYPE)
  (ACCESS-CONTROL :COMPLETE DIR NAME TYPE NIL))

(DEFUN CREATE-DIRECTORY-ACL (NAME)
  (ACCESS-CONTROL :CREATE-DIRECTORY NAME NIL NIL NIL))

(DEFUN LOOKUP-FILES-ACL (DIRECTORY NAME TYPE VERSION)
  (ACCESS-CONTROL :LIST DIRECTORY NAME TYPE VERSION))

(DEFUN TOP-LEVEL-DIRECTORIES-ACL ()
  (ACCESS-CONTROL :LIST :ROOT :WILD :WILD :WILD))


;; SOME EXAMPLE ACCESS CONTROL FUNCTIONS.

(DEFUN HACK-PEOPLE-ACCESS (OPERATION PURPOSE DIRECTORY NAME TYPE VERSION)
  OPERATION
  PURPOSE
  (COND ((OR (EQ DIRECTORY :WILD)
	     (EQ NAME :WILD)
	     (EQ TYPE :WILD)
	     (EQ VERSION :WILD))
	 :DIRECTORY)
	('ELSE
	 :FILE)))

(DEFVAR *ACCESS-RECORD* NIL)

(DEFUN SAVE-ACCESS-RECORD (&OPTIONAL FILENAME)
  (LET ((*ACCESS-CONTROL* NIL)
	(S (TIME:PRINT-CURRENT-TIME NIL :YY-MMM-DD))
	(CL  (SI:FIND-READTABLE-NAMED "CL"))
	(UP (FIND-PACKAGE "USER")))
    (WITH-OPEN-FILE (STREAM (OR FILENAME
				(FORMAT NIL "LM:ACCESS-RECORD;~A.LISP#>"
					(SUBSTRING S 0 9)))
			    :DIRECTION :OUTPUT)
      (FORMAT STREAM ";;; -*-MODE:LISP;PACKAGE:USER;READTABLE:CL;BASE:10-*-~%")
      (FORMAT STREAM ";;; ACCESS RECORD FOR ~S ON ~A~%" SI:LOCAL-HOST S)
      (DOLIST (R (NREVERSE (PROG1 *ACCESS-RECORD* (SETQ *ACCESS-RECORD* NIL))))
	(LET ((BASE 10.)
	      (*READTABLE* CL)
	      (*PACKAGE* UP))
	  (PRIN1 R STREAM))
	(TERPRI STREAM)))))

(DEFUN ACCESS-USER-DESCRIPTION ()
  (COND ((AND (BOUNDP 'CONN) (TYPEP CONN 'CHAOS:CONN))
	 ;; SPECIAL VARIABLE BOUND BIND THE FILE SERVER!
	 (LIST USER-ID
	       :CHAOS
	       (OR (SI:GET-HOST-FROM-ADDRESS (CHAOS:FOREIGN-ADDRESS CONN) :CHAOS)
		   (CHAOS:FOREIGN-ADDRESS CONN))))
	('ELSE
	 USER-ID)))

	
(DEFUN RECORD-ACCESS (OPERATION PURPOSE DIRECTORY NAME TYPE VERSION)
  (LET ((RECORD (LIST OPERATION PURPOSE DIRECTORY NAME TYPE VERSION
		      (ACCESS-USER-DESCRIPTION)
		      (TIME:GET-UNIVERSAL-TIME))))
    (WITHOUT-INTERRUPTS
      (PUSH RECORD *ACCESS-RECORD*)))
  NIL)