(***********************************************************************)
(*                                                                     *)
(*                           Calves                                    *)
(*                                                                     *)
(*          Francois Rouaix, projet Cristal, INRIA Rocquencourt        *)
(*                                                                     *)
(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
(*  Automatique.  Distributed only by permission.                      *)
(*                                                                     *)
(***********************************************************************)

open Str
(* 
 A simple capability manager, inspired (more or less) by the
 Java(tm) security manager

 The capabilities are given *at load-time* for a bytecode.
  (current_capa, set/reset).
 Any other attempt to get will result in an exception Not_found. 
 Loading of foreign bytecode is in critical section.

 NOTE: about a possible race condition (an active applet calling
       Capabilities.get() during its execution, while we are
       loading another applet and current_capa is Some c

  this race condition may happen only if some toplevel expression
  in the applet being loaded yields to the Tk event loop (because
  otherwise the loading is completely synchronous).

  Suppose this happens.

  The active applet now has a handle to the capabilities (type t) 
  that were granted to the applet being loaded. The only possible
  operation is to require more rights for this new applet. The
  request will correctly appear to the user.

  But since capabilites are stored in the closures of dangerous
  functions at load-time (by functor application), there is no
  way for the active applet to benefit from the rights of the
  applet being loaded.
  (assuming that loading of applets can't be interleaved, which is
   true by virtue of "in_load")

 NOTE: about checking rights
  When checking the rights on a given "ressource description" (e.g.
  a filename or an URL), we must be sure that this ressource cannot
  be modified by the applet between the moment we check it and the
  moment we actually use it.

*)


exception Denied

type mode = Fixed | Extend | Temporary

let string_of_mode = function
    Fixed -> ""
  | Extend -> I18n.sprintf "repeated"
  | Temporary -> I18n.sprintf "temporary"

(* Fixed means that the only rights are the initial rights.
   Extend means that a right may be required, and if granted,
     will be again granted if asked for.
   Temporary means that a right may be granted temporarily, but must be
     granted again if asked for later.
 *)

type right =
   FileR of string			(* read access to files *)
 | FileW of string			(* write acces to files *)
 | DocumentR of string			(* read access to URLs *)
    (* Document read access affects decoders, embedded viewers, as well as
       the general retrieval mechanism *)
 | HTMLDisplay
   (* HTML display machine access *)    


module Rights = Set.Make(struct type t = bool * right
      	       	       	        let compare = compare end)
  (* the flag indicates that regexp matching should be used *)


(* For MMM, the browser private information is the viewer base *)
type browser_private = Document.document_id

type t = {
  mutable mode : mode;
  mutable rights : Rights.t;
  who: string;
  browser_private : browser_private
  }

(* For applets loaded from disk *)
let local_default url instid = {
  mode = Extend;
  rights = 
    List.fold_right Rights.add 
      [true, HTMLDisplay;
       true, DocumentR ".*"]
      Rights.empty;
  who = Url.string_of url;
  browser_private = instid
  }

(* For signed applets *)
let lenient_default url instid = {
  mode = Extend;
  rights = Rights.empty;
  who = Url.string_of url;
  browser_private = instid
  }

(* For unsigned applets, but then, these are inherently unsafe *)
let strict_default url instid = {
  mode = Temporary;
  rights = Rights.empty;
  who = Url.string_of url;
  browser_private = instid
  }

let current_capa = ref None
  (* current capabilities for loaded bytecode *)

(* Call this to init to some value BEFORE loading some bytecode *)
let set h = 
  current_capa := Some h

(* Call this AFTER loading the bytecode. *)
let reset () =
  current_capa := None

let check_FileR capa s =
  let s = Lexpath.remove_dots s in
  try
    Rights.iter (function
      	true, FileR r when string_match (regexp r) s 0 ->  failwith "yes"
      | false, FileR r when r = s ->  failwith "yes"
      | _ -> ())
     capa.rights;
    false
  with
    Failure "yes" -> true

let check_FileW capa s =
  let s = Lexpath.remove_dots s in
  try
    Rights.iter (function
      	true, FileW r when string_match (regexp r) s 0 -> failwith "yes"
      | false, FileW r when r = s -> failwith "yes"
      | _ -> ())
     capa.rights;
    false
  with
    Failure "yes" -> true

(* Do we need to remove ../ here ? *)
let check_DocumentR capa s =
  try
    Rights.iter (function
      	true, DocumentR r when string_match (regexp r) s 0 -> failwith "yes"
      | false, DocumentR r when r = s -> failwith "yes"
      | _ -> ())
     capa.rights;
    false
  with
    Failure "yes" -> true

let check_HTMLDisplay capa _ =
  try
    Rights.iter (function
      	_, HTMLDisplay -> failwith "yes"
      | _ -> ())
     capa.rights;
    false
  with
    Failure "yes" -> true


(* GUI *)
open Tk

let v = Frx_misc.autodef Textvariable.create

(* Ask for a capability
 *  isregexp is true when the applet requires caps during load-time
 *   we then simply popup the question
 *  otherwise we check if it's been granted or ask the user (unless
 *  mode is Fixed)
 *)
type 'a question = {
  check_right: t -> string -> bool;
  make_right : string -> right;
  question_simple: (string -> string -> 'a, unit, string) format;
  question_regexp: (string -> string -> 'a, unit, string) format
  }


type cright =
  CFileR | CFileW | CDocumentR | CHTMLDisplay

let table = [
  CFileR,
  {check_right = check_FileR;
   make_right = (fun s -> FileR s);
   question_simple = "Grant %s read access to the file\n%s";
   question_regexp = "Grant %s read access to files matching\n%s"};
  CFileW,
  {check_right = check_FileW;
   make_right = (fun s -> FileW s);
   question_simple = "Grant %s write access to the file\n%s";
   question_regexp = "Grant %s write access to files matching\n%s"};
  CDocumentR,
  {check_right = check_DocumentR;
   make_right = (fun s -> DocumentR s);
   question_simple = "Grant %s read access to document\n%s";
   question_regexp = "Grant %s read access to documents matching\n%s"};
  CHTMLDisplay,
  {check_right = check_HTMLDisplay;
   make_right = (fun _ -> HTMLDisplay);
   question_simple = "Grant %s access to HTML display machine\n%s";
   question_regexp = "Grant %s access to HTML display machine\n%s"}
  ]

let get_question = function
   FileR s -> s, List.assoc CFileR table
 | FileW s -> s, List.assoc CFileW table
 | DocumentR s -> s, List.assoc CDocumentR table
 | HTMLDisplay -> "", List.assoc CHTMLDisplay table

(* This is the function available for Safe libraries *)
let ask capa r =
  let param, q = get_question r
  and mode = string_of_mode capa.mode in
    if q.check_right capa param then true (* already granted *)
    else begin
      let title = I18n.sprintf "Security check for %s" capa.who in
      let question = I18n.sprintf q.question_simple mode param in
      if Error.choose 
      	(I18n.sprintf "%s\n%s\n" title question)
      then begin (* was granted *)
      	if capa.mode = Extend then
	  capa.rights <- Rights.add (false, q.make_right param) capa.rights;
	true
        end
      else false
   end

let require_capa capa r =
  let param, q = get_question r
  and mode = string_of_mode capa.mode in
  let title = I18n.sprintf "Security Rights asked by %s" capa.who in
  let question = I18n.sprintf q.question_regexp mode param in
  if Error.choose 
    (I18n.sprintf "%s\n%s\n" title question)
  then (* was granted *)
    if capa.mode = Extend then begin
      capa.rights <- 
	  Rights.add (true, q.make_right param) capa.rights;
    true
    end
    else false
  else false

(* we would also need a "security editor" *)


(* This is exported to applets *)


let get () =
  match !current_capa with
    None -> raise Not_found
  | Some h -> h

let whoami () =
  match !current_capa with
    None -> raise Not_found
  | Some h -> h.who

(* another version,
let whoami capa = capa.who 
   could produce incorrect information in the case of the race
   condition described above
 *)

let require capa l =  
  List.fold_right (&&) 
    (List.map (require_capa capa) l)
    true
