]> matita.cs.unibo.it Git - helm.git/blob - matitaB/matita/matitadaemon.ml
component "reducibility" updated to new syntax!
[helm.git] / matitaB / matita / matitadaemon.ml
1 open Printf;;
2 open Http_types;;
3
4 exception Emphasized_error of string
5 exception Ambiguous of string
6
7 module Stack = Continuationals.Stack
8
9 let rt_path () = Helm_registry.get "matita.rt_base_dir" 
10
11 let libdir uid = (rt_path ()) ^ "/users/" ^ uid 
12
13 let utf8_length = Netconversion.ustring_length `Enc_utf8
14
15 let mutex = Mutex.create ();;
16
17 let to_be_committed = ref [];;
18
19 let html_of_matita s =
20   let patt1 = Str.regexp "\005" in
21   let patt2 = Str.regexp "\006" in
22   let patt3 = Str.regexp "<" in
23   let patt4 = Str.regexp ">" in
24   let res = Str.global_replace patt4 "&gt;" s in
25   let res = Str.global_replace patt3 "&lt;" res in
26   let res = Str.global_replace patt2 ">" res in
27   let res = Str.global_replace patt1 "<" res in
28   res
29 ;;
30
31 (* adds a user to the commit queue; concurrent instances possible, so we
32  * enclose the update in a CS
33  *)
34 let add_user_for_commit uid =
35   Mutex.lock mutex;
36   to_be_committed := uid::List.filter (fun x -> x <> uid) !to_be_committed;
37   Mutex.unlock mutex;
38 ;;
39
40 let do_global_commit () =
41   prerr_endline ("to be committed: " ^ String.concat " " !to_be_committed);
42   List.fold_left
43     (fun out u ->
44        let ft = MatitaAuthentication.read_ft u in
45
46        (* first we add new files/dirs to the repository *)
47        (* must take the reverse because svn requires the add to be performed in
48           the correct order
49           (otherwise run with --parents option) *)
50        let to_be_added = List.rev (List.map fst  
51          (List.filter (fun (_,flag) -> flag = MatitaFilesystem.MAdd) ft))
52        in
53        prerr_endline ("@@@ ADDING files: " ^ String.concat ", " to_be_added);
54        let out = 
55          try
56            let newout = MatitaFilesystem.add_files u to_be_added in
57            out ^ "\n" ^ newout
58          with
59          | MatitaFilesystem.SvnError outstr -> 
60              prerr_endline ("ADD OF " ^ u ^ "FAILED:" ^ outstr);
61              out
62        in
63
64        (* now we update the local copy (to merge updates from other users) *)
65        let out = try
66          let files,anomalies,(added,conflict,del,upd,merged) = 
67            MatitaFilesystem.update_user u 
68          in
69          let anomalies = String.concat "\n" anomalies in
70          let details = Printf.sprintf 
71            ("%d new files\n"^^
72             "%d deleted files\n"^^
73             "%d updated files\n"^^
74             "%d merged files\n"^^
75             "%d conflicting files\n\n" ^^
76             "Anomalies:\n%s") added del upd merged conflict anomalies
77          in
78          prerr_endline ("update details:\n" ^ details);
79          MatitaAuthentication.set_file_flag u files;
80          out ^ "\n" ^ details 
81          with
82          | MatitaFilesystem.SvnError outstr -> 
83              prerr_endline ("UPDATE OF " ^ u ^ "FAILED:" ^ outstr);
84              out
85        in
86
87        (* we re-read the file table after updating *)
88        let ft = MatitaAuthentication.read_ft u in
89
90        (* finally we perform the real commit *)
91        let modified = (List.map fst
92          (List.filter (fun (_,flag) -> flag = MatitaFilesystem.MModified) ft))
93        in
94        let to_be_committed = to_be_added @ modified
95        in
96        let out = try
97          let newout = MatitaFilesystem.commit u to_be_committed in
98          out ^ "\n" ^ newout
99          with
100          | MatitaFilesystem.SvnError outstr -> 
101              prerr_endline ("COMMIT OF " ^ u ^ "FAILED:" ^ outstr);
102              out
103        in
104
105        (* call stat to get the final status *)
106        let files, anomalies = MatitaFilesystem.stat_user u in
107        let added,not_added = List.fold_left 
108          (fun (a_acc, na_acc) fname ->
109             if List.mem fname (List.map fst files) then
110                a_acc, fname::na_acc
111             else
112                fname::a_acc, na_acc)
113          ([],[]) to_be_added
114        in
115        let committed,not_committed = List.fold_left 
116          (fun (c_acc, nc_acc) fname ->
117             if List.mem fname (List.map fst files) then
118                c_acc, fname::nc_acc
119             else
120                fname::c_acc, nc_acc)
121          ([],[]) modified
122        in
123        let conflicts = List.map fst (List.filter 
124          (fun (_,f) -> f = Some MatitaFilesystem.MConflict) files)
125        in
126        MatitaAuthentication.set_file_flag u
127          (List.map (fun x -> x, Some MatitaFilesystem.MSynchronized) (added@committed));
128        MatitaAuthentication.set_file_flag u files;
129        out ^ "\n\n" ^ (Printf.sprintf
130         ("COMMIT RESULTS for %s\n" ^^
131          "==============\n" ^^
132          "added and committed (%d of %d): %s\n" ^^
133          "modified and committed (%d of %d): %s\n" ^^
134          "not added: %s\n" ^^
135          "not committed: %s\n" ^^
136          "conflicts: %s\n")
137          u (List.length added) (List.length to_be_added) (String.concat ", " added)
138          (List.length committed) (List.length modified) (String.concat ", " committed)
139          (String.concat ", " not_added)
140          (String.concat ", " not_committed) (String.concat ", " conflicts)))
141
142   (* XXX: at the moment, we don't keep track of the order in which users have 
143      scheduled their commits, but we should, otherwise we will get a 
144      "first come, random served" policy *)
145   "" (* (List.rev !to_be_committed) *) (MatitaAuthentication.get_users ())
146 ;;
147
148 (*** from matitaScript.ml ***)
149 (* let only_dust_RE = Pcre.regexp "^(\\s|\n|%%[^\n]*\n)*$" *)
150
151 let eval_statement include_paths (* (buffer : GText.buffer) *) status (* script *)
152  statement
153 =
154   let ast,unparsed_text =
155     match statement with
156     | `Raw text ->
157         (* if Pcre.pmatch ~rex:only_dust_RE text then raise Margin; *)
158         prerr_endline ("raw text = " ^ text);
159         let strm =
160          GrafiteParser.parsable_statement status
161           (Ulexing.from_utf8_string text) in
162         prerr_endline "before get_ast";
163         let ast = MatitaEngine.get_ast status include_paths strm in
164         prerr_endline "after get_ast";
165          ast, text
166     | `Ast (st, text) -> st, text
167   in
168
169   (* do we want to generate a trace? *)
170   let is_auto (l,a) = 
171     not (List.mem_assoc "demod" a || List.mem_assoc "paramod" a ||
172       List.mem_assoc "fast_paramod" a || List.assoc "depth" a = "1" ||
173       l <> None)
174   in
175
176   let get_param a param = 
177      try 
178        Some (param ^ "=" ^ List.assoc param a)
179      with Not_found -> None
180   in
181
182   let floc = match ast with
183   | GrafiteAst.Executable (loc, _)
184   | GrafiteAst.Comment (loc, _) -> loc in
185   
186   let lstart,lend = HExtlib.loc_of_floc floc in 
187   let parsed_text, _parsed_text_len = 
188     HExtlib.utf8_parsed_text unparsed_text (HExtlib.floc_of_loc (0,lend)) in
189   let parsed_text_len = utf8_length parsed_text in
190   let byte_parsed_text_len = String.length parsed_text in
191   let unparsed_txt' = 
192     String.sub unparsed_text byte_parsed_text_len 
193       (String.length unparsed_text - byte_parsed_text_len)
194   in
195   prerr_endline (Printf.sprintf "ustring_sub caso 1: lstart=%d, parsed=%s" lstart parsed_text);
196   let pre = Netconversion.ustring_sub `Enc_utf8  0 lstart parsed_text in
197
198   let mk_univ trace = 
199     let href r = 
200       Printf.sprintf "\005A href=\"%s\"\006%s\005/A\006"
201         (NReference.string_of_reference r) (NCicPp.r2s status true r)
202     in
203     if trace = [] then "{}"
204     else String.concat ", " 
205       (HExtlib.filter_map (function 
206         | NotationPt.NRef r -> Some (href r) 
207         | _ -> None)
208       trace)
209   in
210   
211   match ast with
212   | GrafiteAst.Executable (_,
213       GrafiteAst.NTactic (_,
214         [GrafiteAst.NAuto (_, (l,a as auto_params))])) when is_auto auto_params
215           ->
216           let l = match l with
217           | None -> None
218           | Some (_,l') -> Some (List.map (fun x -> "",0,x) l')
219           in
220           let trace_ref = ref [] in
221           let status = NnAuto.auto_tac ~params:(l,a) ~trace_ref status in
222           let new_parsed_text = pre ^ (Printf.sprintf 
223             "/\005span class='autotactic'\006%s\005span class='autotrace'\006 trace %s\005/span\006\005/span\006/"
224              (String.concat " " 
225                (List.assoc "depth" a::
226                 HExtlib.filter_map (get_param a) ["width";"size"]))
227              (mk_univ !trace_ref))
228           in
229           (status,new_parsed_text, unparsed_txt'),parsed_text_len
230   | _ ->
231       let status = 
232         MatitaEngine.eval_ast ~include_paths ~do_heavy_checks:false status ("",0,ast)
233       in
234       let new_parsed_text = Ulexing.from_utf8_string parsed_text in
235       let interpr = GrafiteDisambiguate.get_interpr status#disambiguate_db in
236       let outstr = ref "" in
237       ignore (SmallLexer.mk_small_printer interpr outstr new_parsed_text);
238       prerr_endline ("baseuri after advance = " ^ status#baseuri);
239       (* prerr_endline ("parser output: " ^ !outstr); *)
240       (status,!outstr, unparsed_txt'),parsed_text_len
241
242 (*let save_moo status = 
243   let script = MatitaScript.current () in
244   let baseuri = status#baseuri in
245   match script#bos, script#eos with
246   | true, _ -> ()
247   | _, true ->
248      GrafiteTypes.Serializer.serialize ~baseuri:(NUri.uri_of_string baseuri)
249       status
250   | _ -> clean_current_baseuri status 
251 ;;*)
252     
253 let sequent_size = ref 40;;
254
255 let include_paths = ref [];;
256
257 (* <metasenv>
258  *   <meta number="...">
259  *     <metaname>...</metaname>
260  *     <goal>...</goal>
261  *   </meta>
262  *
263  *   ...
264  * </metasenv> *)
265 let output_status s =
266   let _,_,metasenv,subst,_ = s#obj in
267   let render_switch = function 
268   | Stack.Open i -> "?" ^ (string_of_int i) 
269   | Stack.Closed i -> "<S>?" ^ (string_of_int i) ^ "</S>"
270   in
271   let int_of_switch = function
272   | Stack.Open i | Stack.Closed i -> i
273   in
274   let sequent = function
275   | Stack.Open i ->
276       let meta = List.assoc i metasenv in
277       snd (ApplyTransformation.ntxt_of_cic_sequent 
278         ~metasenv ~subst ~map_unicode_to_tex:false !sequent_size s (i,meta))
279   | Stack.Closed _ -> "This goal has already been closed."
280   in
281   let render_sequent is_loc acc depth tag (pos,sw) =
282     let metano = int_of_switch sw in
283     let markup = 
284       if is_loc then
285         (match depth, pos with
286          | 0, 0 -> "<span class=\"activegoal\">" ^ (render_switch sw) ^ "</span>"
287          | 0, _ -> 
288             Printf.sprintf "<span class=\"activegoal\">|<SUB>%d</SUB>: %s</span>" pos (render_switch sw)
289          | 1, pos when Stack.head_tag s#stack = `BranchTag ->
290              Printf.sprintf "<span class=\"passivegoal\">|<SUB>%d</SUB> : %s</span>" pos (render_switch sw)
291          | _ -> render_switch sw)
292       else render_switch sw
293     in
294     let markup = 
295       Netencoding.Html.encode ~in_enc:`Enc_utf8 ~prefer_name:false () markup in
296     let markup = "<metaname>" ^ markup ^ "</metaname>" in
297     let sequent =
298       Netencoding.Html.encode ~in_enc:`Enc_utf8 ~prefer_name:false () (sequent sw)
299     in      
300     let txt0 = "<goal>" ^ sequent ^ "</goal>" in
301     "<meta number=\"" ^ (string_of_int metano) ^ "\">" ^ markup ^
302     txt0 ^ "</meta>" ^ acc
303   in
304   "<metasenv>" ^
305     (Stack.fold 
306       ~env:(render_sequent true) ~cont:(render_sequent false) 
307       ~todo:(render_sequent false) "" s#stack) ^
308     "</metasenv>"
309   (* prerr_endline ("sending metasenv:\n" ^ res); res *)
310 ;;
311
312 let heading_nl_RE = Pcre.regexp "^\\s*\n\\s*";;
313
314 let first_line s =
315   let s = Pcre.replace ~rex:heading_nl_RE s in
316   try
317     let nl_pos = String.index s '\n' in
318     String.sub s 0 nl_pos
319   with Not_found -> s
320 ;;
321
322 let read_file fname =
323   let chan = open_in fname in
324   let lines = ref [] in
325   (try
326      while true do
327        lines := input_line chan :: !lines
328      done;
329    with End_of_file -> close_in chan);
330   String.concat "\n" (List.rev !lines)
331 ;;
332
333 let load_index outchan =
334   let s = read_file "index.html" in
335   Http_daemon.respond ~headers:["Content-Type", "text/html"] ~code:(`Code 200) ~body:s outchan
336 ;;
337
338 let load_doc filename outchan =
339   let s = read_file filename in
340   let is_png = 
341     try String.sub filename (String.length filename - 4) 4 = ".png"
342     with Invalid_argument _ -> false
343   in
344   let contenttype = if is_png then "image/png" else "text/html" in
345   Http_daemon.respond ~headers:["Content-Type", contenttype] ~code:(`Code 200) ~body:s outchan
346 ;;
347
348 let retrieve (cgi : Netcgi1_compat.Netcgi_types.cgi_activation) =
349   let cgi = Netcgi1_compat.Netcgi_types.of_compat_activation cgi in
350   let env = cgi#environment in
351   (try 
352     let sid = Uuidm.of_string (Netcgi.Cookie.value (env#cookie "session")) in
353     let sid = HExtlib.unopt sid in
354     let uid = MatitaAuthentication.user_of_session sid in
355     (*
356     cgi # set_header 
357       ~cache:`No_cache 
358       ~content_type:"text/xml; charset=\"utf-8\""
359       ();
360     *)
361     let filename = libdir uid ^ "/" ^ (cgi # argument_value "file") in
362     (* prerr_endline ("reading file " ^ filename); *)
363     let body = 
364      Netencoding.Html.encode ~in_enc:`Enc_utf8 ~prefer_name:false ()
365         (html_of_matita (read_file filename)) in
366      
367      (*   html_of_matita (read_file filename) in *)
368     (* prerr_endline ("sending:\nBEGIN\n" ^ body ^ "\nEND"); *)
369     let body = "<response><file>" ^ body ^ "</file></response>" in
370     let baseuri, incpaths = 
371       try 
372         let root, baseuri, _fname, _tgt = 
373           Librarian.baseuri_of_script ~include_paths:[] filename in 
374         let includes =
375          try
376           Str.split (Str.regexp " ") 
377            (List.assoc "include_paths" (Librarian.load_root_file (root^"/root")))
378          with Not_found -> []
379         in
380         let rc = root :: includes in
381          List.iter (HLog.debug) rc; baseuri, rc
382        with 
383          Librarian.NoRootFor _ | Librarian.FileNotFound _ -> "",[] in
384     include_paths := incpaths;
385     let status = (MatitaAuthentication.get_status sid)#set_baseuri baseuri in
386     let history = [status] in
387     MatitaAuthentication.set_status sid status;
388     MatitaAuthentication.set_history sid history;
389     cgi # set_header 
390       ~cache:`No_cache 
391       ~content_type:"text/xml; charset=\"utf-8\""
392       ();
393     cgi#out_channel#output_string body;
394   with
395   | Not_found _ -> 
396     cgi # set_header
397       ~status:`Internal_server_error
398       ~cache:`No_cache 
399       ~content_type:"text/html; charset=\"utf-8\""
400       ());
401   cgi#out_channel#commit_work()
402 ;;
403
404 let advance0 sid text =
405   let status = MatitaAuthentication.get_status sid in
406   let history = MatitaAuthentication.get_history sid in
407   let status = status#reset_disambiguate_db () in
408   let (st,new_statements,new_unparsed),parsed_len =
409     try
410       eval_statement !include_paths (*buffer*) status (`Raw text)
411     with
412     | HExtlib.Localized (floc,e) as exn ->
413       let x, y = HExtlib.loc_of_floc floc in
414   prerr_endline (Printf.sprintf "ustring_sub caso 2: (%d,%d) parsed=%s" 0 x text);
415       let pre = Netconversion.ustring_sub `Enc_utf8  0 x text in
416   prerr_endline (Printf.sprintf "ustring_sub caso 3: (%d,%d) parsed=%s" x (y-x) text);
417       let err = Netconversion.ustring_sub `Enc_utf8  x (y-x) text in
418   prerr_endline (Printf.sprintf "ustring_sub caso 4: (%d,%d) parsed=%s" y (Netconversion.ustring_length `Enc_utf8 text - y) text);
419       let post = Netconversion.ustring_sub `Enc_utf8 y 
420          (Netconversion.ustring_length `Enc_utf8 text - y) text in
421       let _,title = MatitaExcPp.to_string exn in
422       (* let title = "" in *)
423       let marked = 
424         pre ^ "\005span class=\"error\" title=\"" ^ title ^ "\"\006" ^ err ^ "\005/span\006" ^ post in
425       let marked = Netencoding.Html.encode ~in_enc:`Enc_utf8 ~prefer_name:false 
426       () (html_of_matita marked) in
427       raise (Emphasized_error marked) 
428     | NTacStatus.Error (s,None) as e ->
429         prerr_endline 
430           ("NTacStatus.Error " ^ (Lazy.force s));
431         raise e
432     | NTacStatus.Error (s,Some exc) as e ->
433         prerr_endline 
434           ("NTacStatus.Error " ^ Lazy.force s ^ " -- " ^ (Printexc.to_string exc));
435         raise e
436     | GrafiteDisambiguate.Ambiguous_input (loc,choices) ->
437       let x,y = HExtlib.loc_of_floc loc in
438       let choice_of_alias = function
439        | GrafiteAst.Ident_alias (_,uri) -> uri, None, uri
440        | GrafiteAst.Number_alias (None,desc)
441        | GrafiteAst.Symbol_alias (_,None,desc) -> "cic:/fakeuri.def(1)", Some desc, desc
442        | GrafiteAst.Number_alias (Some uri,desc)
443        | GrafiteAst.Symbol_alias (_,Some uri,desc) -> uri, Some desc, desc
444       in
445       let tag_of_choice (uri,title,desc) =
446         match title with
447         | None -> Printf.sprintf "<choice href=\"%s\">%s</choice>"
448             uri 
449             (Netencoding.Html.encode ~in_enc:`Enc_utf8 ~prefer_name:false () desc)
450         | Some t -> Printf.sprintf "<choice href=\"%s\" title=\"%s\">%s</choice>"
451             uri 
452             (Netencoding.Html.encode ~in_enc:`Enc_utf8 ~prefer_name:false () t)
453             (Netencoding.Html.encode ~in_enc:`Enc_utf8 ~prefer_name:false () desc)
454       in
455       let strchoices = 
456         String.concat "\n" 
457           (List.map (fun x -> tag_of_choice (choice_of_alias x)) choices)
458       in
459       prerr_endline (Printf.sprintf
460         "@@@ Ambiguous input at (%d,%d). Possible choices:\n\n%s\n\n@@@ End."
461           x y strchoices);
462       (*
463       let pre = Netconversion.ustring_sub `Enc_utf8  0 x text in
464       let err = Netconversion.ustring_sub `Enc_utf8  x (y-x) text in
465       let post = Netconversion.ustring_sub `Enc_utf8 y 
466          (Netconversion.ustring_length `Enc_utf8 text - y) text in
467       let title = "Disambiguation Error" in
468       (* let title = "" in *)
469       let marked = 
470         pre ^ "\005span class=\"error\" title=\"" ^ title ^ "\"\006" ^ err ^ "\005/span\006" ^ post in
471       let marked = Netencoding.Html.encode ~in_enc:`Enc_utf8 ~prefer_name:false 
472       () (html_of_matita marked) in
473       *)
474       let strchoices = Printf.sprintf
475         "<ambiguity start=\"%d\" stop=\"%d\">%s</ambiguity>" x y strchoices
476       in raise (Ambiguous strchoices) 
477    (* | End_of_file -> ...          *)
478   in
479   MatitaAuthentication.set_status sid st;
480   MatitaAuthentication.set_history sid (st::history);
481   parsed_len, 
482     Netencoding.Html.encode ~in_enc:`Enc_utf8 ~prefer_name:false 
483       () (html_of_matita new_statements), new_unparsed, st
484
485 let register (cgi : Netcgi1_compat.Netcgi_types.cgi_activation) =
486   let cgi = Netcgi1_compat.Netcgi_types.of_compat_activation cgi in
487   let _env = cgi#environment in
488   
489   assert (cgi#arguments <> []);
490   let uid = cgi#argument_value "userid" in
491   let userpw = cgi#argument_value "password" in
492   (try 
493     MatitaAuthentication.add_user uid userpw;
494 (*    env#set_output_header_field "Location" "/index.html" *)
495     cgi#out_channel#output_string
496      ("<html><head><meta http-equiv=\"refresh\" content=\"2;url=/login.html\">"
497      ^ "</head><body>Redirecting to login page...</body></html>")
498    with
499    | MatitaAuthentication.UsernameCollision _ ->
500       cgi#set_header
501        ~cache:`No_cache 
502        ~content_type:"text/html; charset=\"utf-8\""
503        ();
504      cgi#out_channel#output_string
505       "<html><head></head><body>Error: User id collision!</body></html>"
506    | MatitaFilesystem.SvnError msg ->
507       cgi#set_header
508        ~cache:`No_cache 
509        ~content_type:"text/html; charset=\"utf-8\""
510        ();
511      cgi#out_channel#output_string
512       ("<html><head></head><body><p>Error: Svn checkout failed!<p><p><textarea>"
513        ^ msg ^ "</textarea></p></body></html>"));
514   cgi#out_channel#commit_work()
515 ;;
516
517 let login (cgi : Netcgi1_compat.Netcgi_types.cgi_activation) =
518   let cgi = Netcgi1_compat.Netcgi_types.of_compat_activation cgi in
519   let env = cgi#environment in
520   
521   assert (cgi#arguments <> []);
522   let uid = cgi#argument_value "userid" in
523   let userpw = cgi#argument_value "password" in
524   let pw,_ = MatitaAuthentication.lookup_user uid in
525
526   if pw = userpw then
527    begin
528    let ft = MatitaAuthentication.read_ft uid in
529    let _ = MatitaFilesystem.html_of_library uid ft in
530     let sid = MatitaAuthentication.create_session uid in
531     (* let cookie = Netcgi.Cookie.make "session" (Uuidm.to_string sid) in
532        cgi#set_header ~set_cookies:[cookie] (); *)
533     env#set_output_header_field 
534       "Set-Cookie" ("session=" ^ (Uuidm.to_string sid));
535 (*    env#set_output_header_field "Location" "/index.html" *)
536     cgi#out_channel#output_string
537      ("<html><head><meta http-equiv=\"refresh\" content=\"2;url=/index.html\">"
538      ^ "</head><body>Redirecting to Matita page...</body></html>")
539    end
540   else
541    begin
542     cgi#set_header
543       ~cache:`No_cache 
544       ~content_type:"text/html; charset=\"utf-8\""
545       ();
546     cgi#out_channel#output_string
547       "<html><head></head><body>Authentication error</body></html>"
548    end;
549     
550   cgi#out_channel#commit_work()
551   
552 ;;
553
554 let logout (cgi : Netcgi1_compat.Netcgi_types.cgi_activation) =
555   let cgi = Netcgi1_compat.Netcgi_types.of_compat_activation cgi in
556   let env = cgi#environment in
557   (try 
558     let sid = Uuidm.of_string (Netcgi.Cookie.value (env#cookie "session")) in
559     let sid = HExtlib.unopt sid in
560     MatitaAuthentication.logout_user sid;
561     cgi # set_header 
562       ~cache:`No_cache 
563       ~content_type:"text/html; charset=\"utf-8\""
564       ();
565     let text = read_file (rt_path () ^ "/logout.html") in
566     cgi#out_channel#output_string text
567   with
568   | Not_found _ -> 
569     cgi # set_header
570       ~status:`Internal_server_error
571       ~cache:`No_cache 
572       ~content_type:"text/html; charset=\"utf-8\""
573       ());
574   cgi#out_channel#commit_work()
575 ;;
576
577 exception File_already_exists;;
578
579 let save (cgi : Netcgi1_compat.Netcgi_types.cgi_activation) =
580   let cgi = Netcgi1_compat.Netcgi_types.of_compat_activation cgi in
581   let env = cgi#environment in
582   (try 
583     let sid = Uuidm.of_string (Netcgi.Cookie.value (env#cookie "session")) in
584     let sid = HExtlib.unopt sid in
585     let status = MatitaAuthentication.get_status sid in
586     let uid = MatitaAuthentication.user_of_session sid in
587     assert (cgi#arguments <> []);
588     let locked = cgi#argument_value "locked" in
589     let unlocked = cgi#argument_value "unlocked" in
590     let dir = cgi#argument_value "dir" in
591     let rel_filename = cgi # argument_value "file" in
592     let filename = libdir uid ^ "/" ^ rel_filename in
593     let force = bool_of_string (cgi#argument_value "force") in
594     let already_exists = Sys.file_exists filename in
595
596     if ((not force) && already_exists) then 
597       raise File_already_exists;
598
599     if dir = "true" then
600        Unix.mkdir filename 0o744
601     else 
602      begin
603       let oc = open_out filename in
604       output_string oc (locked ^ unlocked);
605       close_out oc;
606       if MatitaEngine.eos status unlocked then
607        begin
608         (* prerr_endline ("serializing proof objects..."); *)
609         GrafiteTypes.Serializer.serialize 
610           ~baseuri:(NUri.uri_of_string status#baseuri) status;
611         (* prerr_endline ("done."); *)
612        end;
613      end;
614     let old_flag =
615       try 
616         List.assoc rel_filename (MatitaAuthentication.read_ft uid)
617       with Not_found -> MatitaFilesystem.MUnversioned
618     in
619     (if old_flag <> MatitaFilesystem.MConflict &&
620        old_flag <> MatitaFilesystem.MAdd then
621       let newflag = 
622         if already_exists then MatitaFilesystem.MModified
623         else MatitaFilesystem.MAdd
624       in
625       MatitaAuthentication.set_file_flag uid [rel_filename, Some newflag]);
626     cgi # set_header 
627      ~cache:`No_cache 
628      ~content_type:"text/xml; charset=\"utf-8\""
629      ();
630     cgi#out_channel#output_string "<response>ok</response>"
631   with
632   | File_already_exists ->
633       cgi#out_channel#output_string "<response>cancelled</response>"
634   | Sys_error _ -> 
635     cgi # set_header
636       ~status:`Internal_server_error
637       ~cache:`No_cache 
638       ~content_type:"text/xml; charset=\"utf-8\""
639       ()
640   | e ->
641       let estr = Printexc.to_string e in
642       cgi#out_channel#output_string ("<response>" ^ estr ^ "</response>"));
643   cgi#out_channel#commit_work()
644 ;;
645
646 let initiate_commit (cgi : Netcgi1_compat.Netcgi_types.cgi_activation) =
647   let cgi = Netcgi1_compat.Netcgi_types.of_compat_activation cgi in
648   let _env = cgi#environment in
649   (try
650     let out = do_global_commit () in
651     cgi # set_header 
652       ~cache:`No_cache 
653       ~content_type:"text/xml; charset=\"utf-8\""
654       ();
655     cgi#out_channel#output_string "<commit>";
656     cgi#out_channel#output_string "<response>ok</response>";
657     cgi#out_channel#output_string ("<details>" ^ out ^ "</details>");
658     cgi#out_channel#output_string "</commit>"
659   with
660   | Not_found _ -> 
661     cgi # set_header
662       ~status:`Internal_server_error
663       ~cache:`No_cache 
664       ~content_type:"text/xml; charset=\"utf-8\""
665       ());
666   cgi#out_channel#commit_work()
667 ;;
668
669 let svn_update (cgi : Netcgi1_compat.Netcgi_types.cgi_activation) =
670   let cgi = Netcgi1_compat.Netcgi_types.of_compat_activation cgi in
671   let env = cgi#environment in
672   let sid = Uuidm.of_string (Netcgi.Cookie.value (env#cookie "session")) in
673   let sid = HExtlib.unopt sid in
674   let uid = MatitaAuthentication.user_of_session sid in
675   (try
676     let files,anomalies,(added,conflict,del,upd,merged) = 
677       MatitaFilesystem.update_user uid 
678     in
679     let anomalies = String.concat "\n" anomalies in
680     let details = Printf.sprintf 
681       ("%d new files\n"^^
682        "%d deleted files\n"^^
683        "%d updated files\n"^^
684        "%d merged files\n"^^
685        "%d conflicting files\n\n" ^^
686        "Anomalies:\n%s") added del upd merged conflict anomalies
687     in
688     prerr_endline ("update details:\n" ^ details);
689     let details = 
690       Netencoding.Html.encode ~in_enc:`Enc_utf8 ~prefer_name:false () details
691     in
692     MatitaAuthentication.set_file_flag uid files;
693     cgi # set_header 
694       ~cache:`No_cache 
695       ~content_type:"text/xml; charset=\"utf-8\""
696       ();
697     cgi#out_channel#output_string "<update>";
698     cgi#out_channel#output_string "<response>ok</response>";
699     cgi#out_channel#output_string ("<details>" ^ details ^ "</details>");
700     cgi#out_channel#output_string "</update>";
701   with
702   | Not_found _ -> 
703     cgi # set_header
704       ~status:`Internal_server_error
705       ~cache:`No_cache 
706       ~content_type:"text/xml; charset=\"utf-8\""
707       ());
708   cgi#out_channel#commit_work()
709 ;;
710
711 (* returns the length of the executed text and an html representation of the
712  * current metasenv*)
713 let advance (cgi : Netcgi1_compat.Netcgi_types.cgi_activation) =
714   let cgi = Netcgi1_compat.Netcgi_types.of_compat_activation cgi in
715   let env = cgi#environment in
716   (try 
717     let sid = Uuidm.of_string (Netcgi.Cookie.value (env#cookie "session")) in
718     let sid = HExtlib.unopt sid in
719     (*
720     cgi # set_header 
721       ~cache:`No_cache 
722       ~content_type:"text/xml; charset=\"utf-8\""
723       ();
724     *)
725     let text = cgi#argument_value "body" in
726     (* prerr_endline ("body =\n" ^ text); *)
727     let parsed_len, new_parsed, new_unparsed, new_status = advance0 sid text in
728     let txt = output_status new_status in
729     let body = 
730        "<response><parsed length=\"" ^ (string_of_int parsed_len) ^ "\">" ^
731        new_parsed ^ "</parsed>" ^ txt 
732        ^ "</response>"
733     in 
734     (* prerr_endline ("sending advance response:\n" ^ body); *)
735     cgi # set_header 
736       ~cache:`No_cache 
737       ~content_type:"text/xml; charset=\"utf-8\""
738       ();
739     cgi#out_channel#output_string body
740    with
741   | Emphasized_error text ->
742 (* | MultiPassDisambiguator.DisambiguationError (offset,errorll) -> *)
743     let body = "<response><error>" ^ text ^ "</error></response>" in 
744     cgi # set_header 
745       ~cache:`No_cache 
746       ~content_type:"text/xml; charset=\"utf-8\""
747       ();
748     cgi#out_channel#output_string body
749   | Ambiguous text ->
750     let body = "<response>" ^ text ^ "</response>" in 
751     cgi # set_header 
752       ~cache:`No_cache 
753       ~content_type:"text/xml; charset=\"utf-8\""
754       ();
755     cgi#out_channel#output_string body
756   | Not_found _ -> 
757     cgi # set_header
758       ~status:`Internal_server_error
759       ~cache:`No_cache 
760       ~content_type:"text/xml; charset=\"utf-8\""
761       ()
762   );
763   cgi#out_channel#commit_work()
764 ;;
765
766 let gotoBottom (cgi : Netcgi1_compat.Netcgi_types.cgi_activation) =
767   let cgi = Netcgi1_compat.Netcgi_types.of_compat_activation cgi in
768   let env = cgi#environment in
769 (*  (try  *)
770     let sid = Uuidm.of_string (Netcgi.Cookie.value (env#cookie "session")) in
771     let sid = HExtlib.unopt sid in
772     let history = MatitaAuthentication.get_history sid in
773
774     let error_msg = function
775       | Emphasized_error text -> "<localized>" ^ text ^ "</localized>" 
776       | Ambiguous text -> (* <ambiguity> *) text
777       | End_of_file _ -> (* not an error *) ""
778       | e -> (* unmanaged error *)
779           "<error>" ^ 
780           (Netencoding.Html.encode ~in_enc:`Enc_utf8 ~prefer_name:false () 
781             (Printexc.to_string e)) ^ "</error>"
782     in
783
784     let rec aux acc text =
785       try
786         prerr_endline ("evaluating: " ^ first_line text);
787         let plen,new_parsed,new_unparsed,_new_status = advance0 sid text in
788         aux ((plen,new_parsed)::acc) new_unparsed
789       with e -> 
790           let status = MatitaAuthentication.get_status sid in
791           GrafiteTypes.Serializer.serialize 
792             ~baseuri:(NUri.uri_of_string status#baseuri) status;
793           acc, error_msg e
794     in
795     (* 
796     cgi # set_header 
797       ~cache:`No_cache 
798       ~content_type:"text/xml; charset=\"utf-8\""
799       ();
800     *)
801     let text = cgi#argument_value "body" in
802     (* prerr_endline ("body =\n" ^ text); *)
803     let len_parsedlist, err_msg = aux [] text in
804     let status = MatitaAuthentication.get_status sid in
805     let txt = output_status status in
806     let parsed_tag (len,txt) = 
807        "<parsed length=\"" ^ (string_of_int len) ^ "\">" ^ txt ^ "</parsed>"
808     in
809     (* List.rev: the list begins with the older parsed txt *)
810     let body = 
811        "<response>" ^
812        String.concat "" (List.rev (List.map parsed_tag len_parsedlist)) ^
813        txt ^ err_msg ^ "</response>"
814     in
815     (* prerr_endline ("sending goto bottom response:\n" ^ body); *)
816     cgi # set_header 
817       ~cache:`No_cache 
818       ~content_type:"text/xml; charset=\"utf-8\""
819       ();
820     cgi#out_channel#output_string body;
821 (*   with Not_found -> cgi#set_header ~status:`Internal_server_error 
822       ~cache:`No_cache 
823       ~content_type:"text/xml; charset=\"utf-8\"" ()); *)
824   cgi#out_channel#commit_work() 
825 ;;
826
827 let gotoTop (cgi : Netcgi1_compat.Netcgi_types.cgi_activation) =
828   let cgi = Netcgi1_compat.Netcgi_types.of_compat_activation cgi in
829   let env = cgi#environment in
830   prerr_endline "executing goto Top";
831   (try 
832     let sid = Uuidm.of_string (Netcgi.Cookie.value (env#cookie "session")) in
833     let sid = HExtlib.unopt sid in
834     (*
835     cgi # set_header 
836       ~cache:`No_cache 
837       ~content_type:"text/xml; charset=\"utf-8\""
838       ();
839     *)
840     let status = MatitaAuthentication.get_status sid in
841     let uid = MatitaAuthentication.user_of_session sid in
842     let baseuri = status#baseuri in
843     let new_status = new MatitaEngine.status (Some uid) baseuri in
844     prerr_endline "gototop prima della time travel";
845     (* NCicLibrary.time_travel new_status; *)
846     prerr_endline "gototop dopo della time travel";
847     let new_history = [new_status] in 
848     MatitaAuthentication.set_history sid new_history;
849     MatitaAuthentication.set_status sid new_status;
850     (* NCicLibrary.time_travel new_status; *)
851     cgi # set_header 
852       ~cache:`No_cache 
853       ~content_type:"text/xml; charset=\"utf-8\""
854       ();
855     cgi#out_channel#output_string "<response>ok</response>"
856    with _ -> 
857      (cgi#set_header ~status:`Internal_server_error 
858       ~cache:`No_cache 
859       ~content_type:"text/xml; charset=\"utf-8\"" ();
860       cgi#out_channel#output_string "<response>ok</response>"));
861   cgi#out_channel#commit_work() 
862 ;;
863
864 let retract (cgi : Netcgi1_compat.Netcgi_types.cgi_activation) =
865   let cgi = Netcgi1_compat.Netcgi_types.of_compat_activation cgi in
866   let env = cgi#environment in
867   (try  
868     let sid = Uuidm.of_string (Netcgi.Cookie.value (env#cookie "session")) in
869     let sid = HExtlib.unopt sid in
870     (*
871     cgi # set_header 
872       ~cache:`No_cache 
873       ~content_type:"text/xml; charset=\"utf-8\""
874       ();
875     *)
876     let history = MatitaAuthentication.get_history sid in
877     let new_history,new_status =
878        match history with
879          _::(status::_ as history) ->
880           history, status
881       | [_] -> (prerr_endline "singleton";failwith "retract")
882       | _ -> (prerr_endline "nil"; assert false) in
883     prerr_endline ("prima della time travel");
884     NCicLibrary.time_travel new_status;
885     prerr_endline ("dopo della time travel");
886     MatitaAuthentication.set_history sid new_history;
887     MatitaAuthentication.set_status sid new_status;
888     prerr_endline ("baseuri after retract = " ^ new_status#baseuri);
889     let body = output_status new_status in
890     cgi # set_header 
891       ~cache:`No_cache 
892       ~content_type:"text/xml; charset=\"utf-8\""
893       ();
894     cgi#out_channel#output_string body
895    with e -> 
896     prerr_endline ("error in retract: " ^ Printexc.to_string e);
897     cgi#set_header ~status:`Internal_server_error 
898       ~cache:`No_cache 
899       ~content_type:"text/xml; charset=\"utf-8\"" ());
900   cgi#out_channel#commit_work() 
901 ;;
902
903
904 let viewLib (cgi : Netcgi1_compat.Netcgi_types.cgi_activation) =
905   let cgi = Netcgi1_compat.Netcgi_types.of_compat_activation cgi in
906   let env = cgi#environment in
907   
908     let sid = Uuidm.of_string (Netcgi.Cookie.value (env#cookie "session")) in
909     let sid = HExtlib.unopt sid in
910     (*
911     cgi # set_header 
912       ~cache:`No_cache 
913       ~content_type:"text/html; charset=\"utf-8\""
914       ();
915     *)
916     let uid = MatitaAuthentication.user_of_session sid in
917     
918     let ft = MatitaAuthentication.read_ft uid in
919     let html = MatitaFilesystem.html_of_library uid ft in
920     cgi # set_header 
921       ~cache:`No_cache 
922       ~content_type:"text/html; charset=\"utf-8\""
923       ();
924     cgi#out_channel#output_string
925       ((*
926        "<html><head>\n" ^
927        "<title>XML Tree Control</title>\n" ^
928        "<link href=\"treeview/xmlTree.css\" type=\"text/css\" rel=\"stylesheet\">\n" ^
929        "<script src=\"treeview/xmlTree.js\" type=\"text/javascript\"></script>\n" ^
930        "<body>\n" ^ *)
931        html (* ^ "\n</body></html>" *) );
932     
933     let files,anomalies = MatitaFilesystem.stat_user uid in
934     let changed = HExtlib.filter_map 
935       (fun (n,f) -> if (f = Some MatitaFilesystem.MModified) then Some n else None) files
936     in
937     let changed = String.concat "\n" changed in
938     let anomalies = String.concat "\n" anomalies in
939     prerr_endline ("Changed:\n" ^ changed ^ "\n\nAnomalies:\n" ^ anomalies);
940   cgi#out_channel#commit_work()
941   
942 ;;
943
944 let resetLib (cgi : Netcgi1_compat.Netcgi_types.cgi_activation) =
945   let cgi = Netcgi1_compat.Netcgi_types.of_compat_activation cgi in
946   MatitaAuthentication.reset ();
947     cgi # set_header 
948       ~cache:`No_cache 
949       ~content_type:"text/html; charset=\"utf-8\""
950       ();
951     
952     cgi#out_channel#output_string
953       ("<html><head>\n" ^
954        "<title>Matitaweb Reset</title>\n" ^
955        "<body><H1>Reset completed</H1></body></html>");
956     cgi#out_channel#commit_work()
957
958 open Netcgi1_compat.Netcgi_types;;
959
960 (**********************************************************************)
961 (* Create the webserver                                               *)
962 (**********************************************************************)
963
964
965 let start() =
966   let (opt_list, cmdline_cfg) = Netplex_main.args() in
967
968   let use_mt = ref true in
969
970   let opt_list' =
971     [ "-mt", Arg.Set use_mt,
972       "  Use multi-threading instead of multi-processing"
973     ] @ opt_list in
974
975   Arg.parse 
976     opt_list'
977     (fun s -> raise (Arg.Bad ("Don't know what to do with: " ^ s)))
978     "usage: netplex [options]";
979   let parallelizer = 
980     if !use_mt then
981       Netplex_mt.mt()     (* multi-threading *)
982     else
983       Netplex_mp.mp() in  (* multi-processing *)
984 (*
985   let adder =
986     { Nethttpd_services.dyn_handler = (fun _ -> process1);
987       dyn_activation = Nethttpd_services.std_activation `Std_activation_buffered;
988       dyn_uri = None;                 (* not needed *)
989       dyn_translator = (fun _ -> ""); (* not needed *)
990       dyn_accept_all_conditionals = false;
991     } in
992 *)
993   let do_advance =
994     { Nethttpd_services.dyn_handler = (fun _ -> advance);
995       dyn_activation = Nethttpd_services.std_activation `Std_activation_buffered;
996       dyn_uri = None;                 (* not needed *)
997       dyn_translator = (fun _ -> ""); (* not needed *)
998       dyn_accept_all_conditionals = false;
999     } in
1000   let do_retract =
1001     { Nethttpd_services.dyn_handler = (fun _ -> retract);
1002       dyn_activation = Nethttpd_services.std_activation `Std_activation_buffered;
1003       dyn_uri = None;                 (* not needed *)
1004       dyn_translator = (fun _ -> ""); (* not needed *)
1005       dyn_accept_all_conditionals = false;
1006     } in
1007   let goto_bottom =
1008     { Nethttpd_services.dyn_handler = (fun _ -> gotoBottom);
1009       dyn_activation = Nethttpd_services.std_activation `Std_activation_buffered;
1010       dyn_uri = None;                 (* not needed *)
1011       dyn_translator = (fun _ -> ""); (* not needed *)
1012       dyn_accept_all_conditionals = false;
1013     } in
1014   let goto_top =
1015     { Nethttpd_services.dyn_handler = (fun _ -> gotoTop);
1016       dyn_activation = Nethttpd_services.std_activation `Std_activation_buffered;
1017       dyn_uri = None;                 (* not needed *)
1018       dyn_translator = (fun _ -> ""); (* not needed *)
1019       dyn_accept_all_conditionals = false;
1020     } in
1021   let retrieve =
1022     { Nethttpd_services.dyn_handler = (fun _ -> retrieve);
1023       dyn_activation = Nethttpd_services.std_activation `Std_activation_buffered;
1024       dyn_uri = None;                 (* not needed *)
1025       dyn_translator = (fun _ -> ""); (* not needed *)
1026       dyn_accept_all_conditionals = false;
1027     } in
1028   let do_register =
1029     { Nethttpd_services.dyn_handler = (fun _ -> register);
1030       dyn_activation = Nethttpd_services.std_activation `Std_activation_buffered;
1031       dyn_uri = None;                 (* not needed *)
1032       dyn_translator = (fun _ -> ""); (* not needed *)
1033       dyn_accept_all_conditionals = false;
1034     } in
1035   let do_login =
1036     { Nethttpd_services.dyn_handler = (fun _ -> login);
1037       dyn_activation = Nethttpd_services.std_activation `Std_activation_buffered;
1038       dyn_uri = None;                 (* not needed *)
1039       dyn_translator = (fun _ -> ""); (* not needed *)
1040       dyn_accept_all_conditionals = false;
1041     } in
1042   let do_logout =
1043     { Nethttpd_services.dyn_handler = (fun _ -> logout);
1044       dyn_activation = Nethttpd_services.std_activation `Std_activation_buffered;
1045       dyn_uri = None;                 (* not needed *)
1046       dyn_translator = (fun _ -> ""); (* not needed *)
1047       dyn_accept_all_conditionals = false;
1048     } in 
1049   let do_viewlib =
1050     { Nethttpd_services.dyn_handler = (fun _ -> viewLib);
1051       dyn_activation = Nethttpd_services.std_activation `Std_activation_buffered;
1052       dyn_uri = None;                 (* not needed *)
1053       dyn_translator = (fun _ -> ""); (* not needed *)
1054       dyn_accept_all_conditionals = false;
1055     } in 
1056   let do_resetlib =
1057     { Nethttpd_services.dyn_handler = (fun _ -> resetLib);
1058       dyn_activation = Nethttpd_services.std_activation `Std_activation_buffered;
1059       dyn_uri = None;                 (* not needed *)
1060       dyn_translator = (fun _ -> ""); (* not needed *)
1061       dyn_accept_all_conditionals = false;
1062     } in 
1063   let do_save =
1064     { Nethttpd_services.dyn_handler = (fun _ -> save);
1065       dyn_activation = Nethttpd_services.std_activation `Std_activation_buffered;
1066       dyn_uri = None;                 (* not needed *)
1067       dyn_translator = (fun _ -> ""); (* not needed *)
1068       dyn_accept_all_conditionals = false;
1069     } in 
1070   let do_commit =
1071     { Nethttpd_services.dyn_handler = (fun _ -> initiate_commit);
1072       dyn_activation = Nethttpd_services.std_activation `Std_activation_buffered;
1073       dyn_uri = None;                 (* not needed *)
1074       dyn_translator = (fun _ -> ""); (* not needed *)
1075       dyn_accept_all_conditionals = false;
1076     } in 
1077   let do_update =
1078     { Nethttpd_services.dyn_handler = (fun _ -> svn_update);
1079       dyn_activation = Nethttpd_services.std_activation `Std_activation_buffered;
1080       dyn_uri = None;                 (* not needed *)
1081       dyn_translator = (fun _ -> ""); (* not needed *)
1082       dyn_accept_all_conditionals = false;
1083     } in 
1084   
1085   
1086   let nethttpd_factory = 
1087     Nethttpd_plex.nethttpd_factory
1088       ~handlers:[ "advance", do_advance
1089                 ; "retract", do_retract
1090                 ; "bottom", goto_bottom
1091                 ; "top", goto_top
1092                 ; "open", retrieve 
1093                 ; "register", do_register
1094                 ; "login", do_login 
1095                 ; "logout", do_logout 
1096                 ; "reset", do_resetlib
1097                 ; "viewlib", do_viewlib
1098                 ; "save", do_save
1099                 ; "commit", do_commit
1100                 ; "update", do_update]
1101       () in
1102   MatitaInit.initialize_all ();
1103   MatitaAuthentication.deserialize ();
1104   Netplex_main.startup
1105     parallelizer
1106     Netplex_log.logger_factories   (* allow all built-in logging styles *)
1107     Netplex_workload.workload_manager_factories (* ... all ways of workload management *)
1108     [ nethttpd_factory ]           (* make this nethttpd available *)
1109     cmdline_cfg
1110 ;;
1111
1112 Sys.set_signal Sys.sigpipe Sys.Signal_ignore;
1113 start();;