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

open Tk
open Mstring
open Document
open Viewers

let paranoid = ref true  (* selects default capabilities *)

(* This is now available as Dynlink.error_message, but not i18n *)
let dynlinkerror = function
   Dynlink.Not_a_bytecode_file s ->
     I18n.sprintf "Not a bytecode file"
 | Dynlink.Inconsistent_import s ->
     I18n.sprintf "Inconsistent import: %s" s
 | Dynlink.Unavailable_unit s ->
     I18n.sprintf "Unavailable unit: %s " s
 | Dynlink.Unsafe_file ->
     I18n.sprintf "Unsafe file"
 | Dynlink.Linking_error s ->
     I18n.sprintf "Error while linking: %s" s
 | Dynlink.Corrupted_interface s ->
     I18n.sprintf "Corrupted interface"

type applet_callback = Widget.widget -> context -> unit

(* The "foreign" module fake cache *)
type t = {
  module_address : string;		(* the URL of the bytecode *)
  module_info : string list;		(* headers *)
  module_functions : (string, applet_callback) Hashtbl.t
  } 

let mod_cache = (Hashtbl.create 53 : (Url.t, t option) Hashtbl.t)

let get = Hashtbl.find mod_cache
and iter f = Hashtbl.iter f mod_cache
and remove = Hashtbl.remove mod_cache

(* Register queue
   The queue is used to make a separate hashtbl for each loaded bytecode,
   and thus give some "proper" name space to each applet.
 *)

let register_queue = ref (Queue.create())

(* This is the one that we export *)
let register name f =
  Queue.add (name, f) !register_queue

(* Create a hashtable of functions
   This is called after loading the bytecode
 *)
let register_flush () =
  let names = Hashtbl.create 37 in
  try
    while true do
      let (name,f) = Queue.take !register_queue in
        Hashtbl.add names name f
    done;
    names
  with
    Queue.Empty -> names

(* We need to resynchronize applet evaluation : several <EMBED> may 
   use the same SRC bytecode. The navigator will request us to load
   several times the same bytecode. We might also several requests
   to run bytecode.
 *)

let synchro = (Hashtbl.create 37 :
(Url.t, ((string, applet_callback) Hashtbl.t -> unit) Queue.t) Hashtbl.t)

(* add to queue while loading
 *   DO NOT CALL THIS if the bytecode is already loaded
 *   The queue will be flushed whenever the bytecode gets loaded
 *)
let add_pending_applet url data =
  let q,first = 
    try 
      (* we already have a queue of applets waiting for url *)
      Hashtbl.find synchro url,false
    with
      Not_found -> 
      	let q = Queue.create() in
        Hashtbl.add synchro url q;
	q,true
  in
   Queue.add data q; (* Add the applet to the queue *)
   first

(* Evaluate all pending applets for this bytecode *)
let flush_pending_applets url ftable =
  try
    let q = Hashtbl.find synchro url in
      Hashtbl.remove synchro url;
      try
       while true do
         let f = Queue.take q in
	   f ftable
	 done
      with
	Queue.Empty -> ()
  with 
     Not_found -> (* url not in synchro table. Is that an error ? *)
       ()


(* Dynlink is not reentrant + security requires it to be in critical
   section anyway (to protect capabilities)
 *)

let in_load = ref false

(* Loading of local extensions *)
let load_local file = 
  if !in_load then Error.f (I18n.sprintf "Already loading a module")
  else 
   let url = Lexurl.make ("file://"^file) in
   let did = { document_url = url; document_stamp = 0 }
   in begin
    in_load := true;
    Capabilities.set (Capabilities.local_default url did);
    (* prepare the register queue *)
    register_queue := Queue.create();
    try
	Dynlink.loadfile_private file;
	let e = { module_address = Url.string_of url;
		  module_info = [];
		  module_functions = register_flush()
		} in
	Hashtbl.add mod_cache url (Some e);
	Capabilities.reset();
	flush_pending_applets url e.module_functions;
	in_load := false
    with e ->
      Capabilities.reset();
      in_load := false;
      match e with
	Dynlink.Error e -> 
	  Error.f (I18n.sprintf "Failed to load Caml module %s\n%s"
      	       	       	         (Url.string_of url) (dynlinkerror e))
      | e ->
	  Error.f (I18n.sprintf "Failed to load Caml module %s\n%s"
      	       	       	         (Url.string_of url)
      	       	       	       	 (Stringexc.f e))
    end

(* Low-level loading of a foreign bytecode stored in a tmp file
   instid is browser specific
 *)

let unsafe_load doc file instid =
  if !in_load then Error.f (I18n.sprintf "Already loading a module")
  else begin
    let url = doc.document_address in
    in_load := true;
    Capabilities.set 
      ((if !paranoid then Capabilities.strict_default url
       else Capabilities.lenient_default url) instid);
    (* prepare the register queue *)
    register_queue := Queue.create();
    try
	Dynlink.loadfile_private file;
	Msys.rm file;
	let e = { module_address = Url.string_of url;
		  module_info = doc.document_info;
		  module_functions = register_flush()
		} in
	Hashtbl.add mod_cache url (Some e);
	Capabilities.reset();
	flush_pending_applets url e.module_functions;
	in_load := false
    with e ->
      Msys.rm file;
      Capabilities.reset();
      in_load := false;
      match e with
	Dynlink.Error e -> 
	  Error.f (I18n.sprintf "Failed to load Caml module %s\n%s"
      	       	       	         (Url.string_of url) (dynlinkerror e));
	  failwith "dontkeep"
      | e ->
	  Error.f (I18n.sprintf "Failed to load Caml module %s\n%s"
      	       	       	         (Url.string_of url)
      	       	       	       	 (Stringexc.f e));
	  failwith "dontkeep"
    end

let ask url =
  0 = Frx_dialog.f Widget.default_toplevel (gensym "accept")
       "MMM Question"
       (I18n.sprintf  "Unsigned bytecode file %s" (Url.string_of url))
       (Predefined "question") 1
       ["Accept"; "Reject"]

(* Load a foreign bytecode
   dh is passed only to get the headers
 *)
let load doc file id =
  let url = doc.document_address in
  (* do we have it already loaded ? TODO: check last modified *)
  try
    let _ = Hashtbl.find mod_cache url in
      (* then forget it *)
      Msys.rm file
  with
    Not_found ->
     (* actually load it *)
    try
      match lowercase (Http_headers.contenttype doc.document_info) with
	"application/x-caml-applet" -> (* unsigned bytecode *)
	   if ask url then unsafe_load doc file id
	   else failwith "dontkeep"
      | "application/x-caml-signed-applet" -> (* PGP signed bytecode *)
	   begin match Pgp.check (Url.string_of url) file with
	     Some clear ->
	       unsafe_load doc clear id;
	       Msys.rm file
	   | None -> (* was refused or malformed *)
	       failwith "dontkeep"
	   end
      | s -> (* we shouldn't get there anyway *)
	   Error.f (I18n.sprintf "Unexpected MIME type %s for %s"
		    s (Url.string_of url));
	   failwith "dontkeep"
     with
       Failure "dontkeep" ->
	 Msys.rm file;
	 Hashtbl.add mod_cache url None;
	 Error.f (I18n.sprintf "%s was rejected" (Url.string_of url))
