X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;ds=inline;f=matitaB%2Fmatita%2Fmatitadaemon.ml;h=fc8c9684e87534819f855ba1786723c347738e2a;hb=95e3387af669e9a9e30dafd4d096c2741fc9041c;hp=0c0f6cefda58da86b44c768b1d2d6c778d06004d;hpb=e499c2e36d8a39c4749b8e0e34438b49532d15b8;p=helm.git
diff --git a/matitaB/matita/matitadaemon.ml b/matitaB/matita/matitadaemon.ml
index 0c0f6cefd..fc8c9684e 100644
--- a/matitaB/matita/matitadaemon.ml
+++ b/matitaB/matita/matitadaemon.ml
@@ -3,9 +3,11 @@ open Http_types;;
exception Emphasized_error of string
exception Disamb_error of string
+exception Generic_error of string
module Stack = Continuationals.Stack
+let debug = prerr_endline
(* disable for debug *)
let prerr_endline _ = ()
@@ -40,7 +42,7 @@ let add_user_for_commit uid =
Mutex.unlock mutex;
;;
-let do_global_commit () =
+let do_global_commit (* () *) uid =
prerr_endline ("to be committed: " ^ String.concat " " !to_be_committed);
List.fold_left
(fun out u ->
@@ -145,7 +147,11 @@ let do_global_commit () =
(* XXX: at the moment, we don't keep track of the order in which users have
scheduled their commits, but we should, otherwise we will get a
"first come, random served" policy *)
- "" (* (List.rev !to_be_committed) *) (MatitaAuthentication.get_users ())
+ "" (* (List.rev !to_be_committed) *)
+ (* replace [uid] to commit all users:
+ (MatitaAuthentication.get_users ())
+ *)
+ [uid]
;;
(*** from matitaScript.ml ***)
@@ -212,6 +218,26 @@ let eval_statement include_paths (* (buffer : GText.buffer) *) status (* script
in
match ast with
+ | GrafiteAst.Executable (_,
+ GrafiteAst.NCommand (_,
+ GrafiteAst.NObj (loc, astobj,_))) ->
+ let objname = NotationPt.name_of_obj astobj in
+ let status =
+ MatitaEngine.eval_ast ~include_paths ~do_heavy_checks:false status ("",0,ast)
+ in
+ let new_parsed_text = Ulexing.from_utf8_string parsed_text in
+ let interpr = GrafiteDisambiguate.get_interpr status#disambiguate_db in
+ let outstr = ref "" in
+ ignore (SmallLexer.mk_small_printer interpr outstr new_parsed_text);
+ let x, y = HExtlib.loc_of_floc floc in
+ let pre = Netconversion.ustring_sub `Enc_utf8 0 x !outstr in
+ let post = Netconversion.ustring_sub `Enc_utf8 x
+ (Netconversion.ustring_length `Enc_utf8 !outstr - x) !outstr in
+ outstr := Printf.sprintf
+ "%s\005img class=\"anchor\" src=\"icons/tick.png\" id=\"%s\" /\006%s" pre objname post;
+ prerr_endline ("baseuri after advance = " ^ status#baseuri);
+ (* prerr_endline ("parser output: " ^ !outstr); *)
+ (status,!outstr, unparsed_txt'),parsed_text_len
| GrafiteAst.Executable (_,
GrafiteAst.NTactic (_,
[GrafiteAst.NAuto (_, (l,a as auto_params))])) when is_auto auto_params
@@ -348,7 +374,8 @@ let load_doc filename outchan =
Http_daemon.respond ~headers:["Content-Type", contenttype] ~code:(`Code 200) ~body:s outchan
;;
-let retrieve (cgi : Netcgi.cgi_activation) =
+let retrieve (cgi : Netcgi1_compat.Netcgi_types.cgi_activation) =
+ let cgi = Netcgi1_compat.Netcgi_types.of_compat_activation cgi in
let env = cgi#environment in
(try
let sid = Uuidm.of_string (Netcgi.Cookie.value (env#cookie "session")) in
@@ -360,6 +387,7 @@ let retrieve (cgi : Netcgi.cgi_activation) =
~content_type:"text/xml; charset=\"utf-8\""
();
*)
+ let readonly = cgi # argument_value "readonly" in
let filename = libdir uid ^ "/" ^ (cgi # argument_value "file") in
(* prerr_endline ("reading file " ^ filename); *)
let body =
@@ -384,16 +412,23 @@ let retrieve (cgi : Netcgi.cgi_activation) =
with
Librarian.NoRootFor _ | Librarian.FileNotFound _ -> "",[] in
include_paths := incpaths;
- let status = (MatitaAuthentication.get_status sid)#set_baseuri baseuri in
- let history = [status] in
- MatitaAuthentication.set_status sid status;
- MatitaAuthentication.set_history sid history;
+ if readonly <> "true" then
+ (let status = new MatitaEngine.status (Some uid) baseuri in
+ let history = [status] in
+ MatitaAuthentication.set_status sid status;
+ MatitaAuthentication.set_history sid history);
cgi # set_header
~cache:`No_cache
~content_type:"text/xml; charset=\"utf-8\""
();
cgi#out_channel#output_string body;
with
+ | Sys_error _ ->
+ cgi # set_header
+ ~cache:`No_cache
+ ~content_type:"text/xml; charset=\"utf-8\""
+ ();
+ cgi#out_channel#output_string ""
| Not_found _ ->
cgi # set_header
~status:`Internal_server_error
@@ -448,6 +483,8 @@ let advance0 sid text =
let status = status#reset_disambiguate_db () in
let (st,new_statements,new_unparsed),parsed_len =
let rec do_exc = function
+ | MatitaEngine.EnrichedWithStatus (e,_) -> do_exc e
+ | NCicTypeChecker.TypeCheckerFailure s -> raise (Generic_error (Lazy.force s))
| HExtlib.Localized (floc,e) ->
let x, y = HExtlib.loc_of_floc floc in
let pre = Netconversion.ustring_sub `Enc_utf8 0 x text in
@@ -538,13 +575,21 @@ let advance0 sid text =
in raise (Disamb_error strchoices)
| GrafiteDisambiguate.Error l -> raise (Disamb_error (xml_of_disamb_error l))
(* | End_of_file -> ... *)
- | e -> raise e
+ | e ->
+ (* prerr_endline ("matitadaemon *** Unhandled exception " ^ Printexc.to_string e); *)
+ prerr_endline ("matitadaemon *** Unhandled exception " ^ snd (MatitaExcPp.to_string e));
+ raise e
in
try
eval_statement !include_paths (*buffer*) status (`Raw text)
with e -> do_exc e
in
+ debug "BEGIN PRINTGRAMMAR";
+ (*prerr_endline (Print_grammar.ebnf_of_term status);*)
+ (*let kwds = String.concat ", " status#get_kwds in
+ debug ("keywords = " ^ kwds );*)
+ debug "END PRINTGRAMMAR";
MatitaAuthentication.set_status sid st;
MatitaAuthentication.set_history sid (st::history);
(* prerr_endline "previous timestamp";
@@ -555,7 +600,8 @@ let advance0 sid text =
Netencoding.Html.encode ~in_enc:`Enc_utf8 ~prefer_name:false
() (html_of_matita new_statements), new_unparsed, st
-let register (cgi : Netcgi.cgi_activation) =
+let register (cgi : Netcgi1_compat.Netcgi_types.cgi_activation) =
+ let cgi = Netcgi1_compat.Netcgi_types.of_compat_activation cgi in
let _env = cgi#environment in
assert (cgi#arguments <> []);
@@ -587,7 +633,8 @@ let register (cgi : Netcgi.cgi_activation) =
cgi#out_channel#commit_work()
;;
-let login (cgi : Netcgi.cgi_activation) =
+let login (cgi : Netcgi1_compat.Netcgi_types.cgi_activation) =
+ let cgi = Netcgi1_compat.Netcgi_types.of_compat_activation cgi in
let env = cgi#environment in
assert (cgi#arguments <> []);
@@ -617,7 +664,8 @@ let login (cgi : Netcgi.cgi_activation) =
cgi#out_channel#commit_work()
;;
-let logout (cgi : Netcgi.cgi_activation) =
+let logout (cgi : Netcgi1_compat.Netcgi_types.cgi_activation) =
+ let cgi = Netcgi1_compat.Netcgi_types.of_compat_activation cgi in
let env = cgi#environment in
(try
let sid = Uuidm.of_string (Netcgi.Cookie.value (env#cookie "session")) in
@@ -641,7 +689,8 @@ let logout (cgi : Netcgi.cgi_activation) =
exception File_already_exists;;
-let save (cgi : Netcgi.cgi_activation) =
+let save (cgi : Netcgi1_compat.Netcgi_types.cgi_activation) =
+ let cgi = Netcgi1_compat.Netcgi_types.of_compat_activation cgi in
let env = cgi#environment in
(try
let sid = Uuidm.of_string (Netcgi.Cookie.value (env#cookie "session")) in
@@ -694,6 +743,10 @@ let save (cgi : Netcgi.cgi_activation) =
cgi#out_channel#output_string "ok"
with
| File_already_exists ->
+ cgi # set_header
+ ~cache:`No_cache
+ ~content_type:"text/xml; charset=\"utf-8\""
+ ();
cgi#out_channel#output_string "cancelled"
| Sys_error _ ->
cgi # set_header
@@ -702,18 +755,24 @@ let save (cgi : Netcgi.cgi_activation) =
~content_type:"text/xml; charset=\"utf-8\""
()
| e ->
+ cgi # set_header
+ ~cache:`No_cache
+ ~content_type:"text/xml; charset=\"utf-8\""
+ ();
let estr = Printexc.to_string e in
cgi#out_channel#output_string ("" ^ estr ^ ""));
cgi#out_channel#commit_work()
;;
-let initiate_commit (cgi : Netcgi.cgi_activation) =
+let initiate_commit (cgi : Netcgi1_compat.Netcgi_types.cgi_activation) =
+ let cgi = Netcgi1_compat.Netcgi_types.of_compat_activation cgi in
let env = cgi#environment in
(try
let sid = Uuidm.of_string (Netcgi.Cookie.value (env#cookie "session")) in
let sid = HExtlib.unopt sid in
MatitaAuthentication.probe_commit_priv sid;
- let out = do_global_commit () in
+ let uid = MatitaAuthentication.user_of_session sid in
+ let out = do_global_commit (* () *) uid in
cgi # set_header
~cache:`No_cache
~content_type:"text/xml; charset=\"utf-8\""
@@ -723,6 +782,13 @@ let initiate_commit (cgi : Netcgi.cgi_activation) =
cgi#out_channel#output_string ("" ^ out ^ " ");
cgi#out_channel#output_string ""
with
+ | Failure _ ->
+ cgi # set_header
+ ~cache:`No_cache
+ ~content_type:"text/xml; charset=\"utf-8\""
+ ();
+ cgi#out_channel#output_string
+ "no commit privileges"
| Not_found _ ->
cgi # set_header
~status:`Internal_server_error
@@ -732,7 +798,8 @@ let initiate_commit (cgi : Netcgi.cgi_activation) =
cgi#out_channel#commit_work()
;;
-let svn_update (cgi : Netcgi.cgi_activation) =
+let svn_update (cgi : Netcgi1_compat.Netcgi_types.cgi_activation) =
+ let cgi = Netcgi1_compat.Netcgi_types.of_compat_activation cgi in
let env = cgi#environment in
let sid = Uuidm.of_string (Netcgi.Cookie.value (env#cookie "session")) in
let sid = HExtlib.unopt sid in
@@ -765,6 +832,13 @@ let svn_update (cgi : Netcgi.cgi_activation) =
cgi#out_channel#output_string ("" ^ details ^ " ");
cgi#out_channel#output_string "";
with
+ | Failure _ ->
+ cgi # set_header
+ ~cache:`No_cache
+ ~content_type:"text/xml; charset=\"utf-8\""
+ ();
+ cgi#out_channel#output_string
+ "no commit privileges"
| Not_found _ ->
cgi # set_header
~status:`Internal_server_error
@@ -777,8 +851,8 @@ let svn_update (cgi : Netcgi.cgi_activation) =
(* returns the length of the executed text and an html representation of the
* current metasenv*)
(*let advance =*)
-let advance (cgi : Netcgi.cgi_activation) =
- (* let cgi = Netcgi1_compat.Netcgi_types.of_compat_activation cgi in *)
+let advance (cgi : Netcgi1_compat.Netcgi_types.cgi_activation) =
+ let cgi = Netcgi1_compat.Netcgi_types.of_compat_activation cgi in
let env = cgi#environment in
(try
let sid = Uuidm.of_string (Netcgi.Cookie.value (env#cookie "session")) in
@@ -805,9 +879,16 @@ let advance (cgi : Netcgi.cgi_activation) =
();
cgi#out_channel#output_string body
with
+ | Generic_error text ->
+ let body = "" ^ text ^ "" in
+ cgi # set_header
+ ~cache:`No_cache
+ ~content_type:"text/xml; charset=\"utf-8\""
+ ();
+ cgi#out_channel#output_string body
| Emphasized_error text ->
(* | MultiPassDisambiguator.DisambiguationError (offset,errorll) -> *)
- let body = "" ^ text ^ "" in
+ let body = "" ^ text ^ "" in
cgi # set_header
~cache:`No_cache
~content_type:"text/xml; charset=\"utf-8\""
@@ -820,6 +901,13 @@ let advance (cgi : Netcgi.cgi_activation) =
~content_type:"text/xml; charset=\"utf-8\""
();
cgi#out_channel#output_string body
+ | End_of_file _ ->
+ let body = "" in
+ cgi # set_header
+ ~cache:`No_cache
+ ~content_type:"text/xml; charset=\"utf-8\""
+ ();
+ cgi#out_channel#output_string body
| Not_found _ ->
cgi # set_header
~status:`Internal_server_error
@@ -830,7 +918,8 @@ let advance (cgi : Netcgi.cgi_activation) =
cgi#out_channel#commit_work()
;;
-let gotoBottom (cgi : Netcgi.cgi_activation) =
+let gotoBottom (cgi : Netcgi1_compat.Netcgi_types.cgi_activation) =
+ let cgi = Netcgi1_compat.Netcgi_types.of_compat_activation cgi in
let env = cgi#environment in
(* (try *)
let sid = Uuidm.of_string (Netcgi.Cookie.value (env#cookie "session")) in
@@ -890,7 +979,8 @@ let gotoBottom (cgi : Netcgi.cgi_activation) =
cgi#out_channel#commit_work()
;;
-let gotoTop (cgi : Netcgi.cgi_activation) =
+let gotoTop (cgi : Netcgi1_compat.Netcgi_types.cgi_activation) =
+ let cgi = Netcgi1_compat.Netcgi_types.of_compat_activation cgi in
let env = cgi#environment in
prerr_endline "executing goto Top";
(try
@@ -926,7 +1016,8 @@ let gotoTop (cgi : Netcgi.cgi_activation) =
cgi#out_channel#commit_work()
;;
-let retract (cgi : Netcgi.cgi_activation) =
+let retract (cgi : Netcgi1_compat.Netcgi_types.cgi_activation) =
+ let cgi = Netcgi1_compat.Netcgi_types.of_compat_activation cgi in
let env = cgi#environment in
(try
let sid = Uuidm.of_string (Netcgi.Cookie.value (env#cookie "session")) in
@@ -970,7 +1061,8 @@ let retract (cgi : Netcgi.cgi_activation) =
;;
-let viewLib (cgi : Netcgi.cgi_activation) =
+let viewLib (cgi : Netcgi1_compat.Netcgi_types.cgi_activation) =
+ let cgi = Netcgi1_compat.Netcgi_types.of_compat_activation cgi in
let env = cgi#environment in
let sid = Uuidm.of_string (Netcgi.Cookie.value (env#cookie "session")) in
@@ -1009,7 +1101,8 @@ let viewLib (cgi : Netcgi.cgi_activation) =
;;
-let resetLib (cgi : Netcgi.cgi_activation) =
+let resetLib (cgi : Netcgi1_compat.Netcgi_types.cgi_activation) =
+ let cgi = Netcgi1_compat.Netcgi_types.of_compat_activation cgi in
MatitaAuthentication.reset ();
cgi # set_header
~cache:`No_cache