(* TODO: - HTML design, logo *) open Netcgi exception Timeout let operating_type = Netcgi.buffered_transactional_optype let cgi = new Netcgi.std_activation ~operating_type () let fatal_error title s = cgi # output # rollback_work(); cgi # set_header ~content_type:"text/html; charset=\"iso-8859-1\"" ~cache:`No_cache (); cgi # output # output_string ("

" ^ title ^ "

"); cgi # output # output_string s; cgi # output # output_string "\n"; cgi # output # commit_work(); cgi # finalize (); exit 0 (* Configuration *) let session_dir = <:symbol> let () = if not (Sys.file_exists session_dir) then try Unix.mkdir session_dir 0o755 with Unix.Unix_error(_,_,_)-> fatal_error "Fatal error" "Cannot create session directory" let timeout = 60 * 5 (* seconds *) let max_sess = 10 (*****************) (* Loading examples *) let example code = try List.assoc code Examples.examples with Not_found -> "" let begin_table = "
" let end_table = "
" let persistant = ref false let session_id = ref "" let (|||) p x = p x; p let (||=) p () = () let html_header p = p " CDuce online prototype

CDuce online prototype

"; if !persistant then p "

You're running the CDuce prototype in session mode: values and types accepted by CDuce when you click 'Submit' will be available for subsequent requests.

" else p ||| "

Sample programs

You can start from one of the predefined examples below or try with you own program...

" ||| Examples.present ||| "
" ||= () let html_form p content = p "

Input

" ; if !persistant then p ||| " " ||= () else p " (The session mode remembers CDuce definitions across requests) "; p "
"; p ||| "

" ||= () let html_footer p = p "
" let () = Random.self_init (); State.close () let session_file sid = Filename.concat session_dir sid let gen_session_id () = string_of_int (Random.bits ()) let check_session_id sid = try ignore (int_of_string sid) with _ -> failwith "Invalid session id" let close_session sid = check_session_id sid; try Unix.unlink (session_file sid) with Unix.Unix_error (_,_,_) -> () let flush_sessions () = let time = Unix.time () -. (float timeout) in let n = ref 0 in let dir = Unix.opendir session_dir in try while true do let f = session_file (Unix.readdir dir) in let st = Unix.stat f in if (st.Unix.st_kind = Unix.S_REG) then if (st.Unix.st_mtime < time) then Unix.unlink f else incr n done; assert false with End_of_file -> Unix.closedir dir; !n let cmds = [ "open", `Open; "close", `Close; "dump", `Dump; "exec", `Exec; "example", `Example; "new", `New; ] let cut p w s = let rec aux i x = if i < String.length s then match s.[i] with | '\n' -> p '\n'; aux (i + 1) 0 | '\r' -> aux (i + 1) 0 | '<' -> let rec tag i = p s.[i]; if (s.[i] = '>') then aux (i + 1) x else tag (i + 1) in tag i | c -> let x = if x = w then (p '\\'; p '\n'; p ':'; 2) else (x + 1) in p c; if c = '&' then let rec ent i = p s.[i]; if (s.[i] = ';') then aux (i + 1) x else ent (i + 1) in ent (i + 1) else aux (i + 1) x in aux 0 0 let main (cgi : Netcgi.std_activation) = let p = cgi # output # output_string in let clicked s = cgi # argument_value s <> "" in try let nb_sessions = flush_sessions () in cgi # set_header (* ~content_type:"text/html; charset=\"iso-8859-1\"" *) (); let cmd = try snd (List.find (fun (x,y) -> clicked x) cmds) with Not_found -> `New in let sid = match cmd with | `Open -> if (nb_sessions >= max_sess) then failwith "Too many open sessions ..."; let sid = gen_session_id () in (* touch the session file ... *) let chan = open_out_bin (session_file sid) in close_out chan; sid | `Close -> close_session (cgi # argument_value "session"); "" | `New -> "" | _ -> cgi # argument_value "session" in session_id := sid; persistant := !session_id <> ""; if !persistant then check_session_id !session_id; let dialog content = html_form p content in let load_state () = if !persistant then try let chan = open_in_bin (session_file !session_id) in if in_channel_length chan > 0 then (let s = Marshal.from_channel chan in State.set s); close_in chan; with Sys_error _ -> fatal_error "Fatal error" "This session has expired ..." in let store_state () = if !persistant then let s = State.get () in let chan = open_out_bin (session_file !session_id) in Marshal.to_channel chan s [ Marshal.Closures ]; close_out chan in let exec src = let v = Location.get_viewport () in let ppf = Html.ppf v and input = Stream.of_string src in Location.push_source (`String src); Location.set_protected true; let ok = Cduce.script ppf ppf input in if ok then Format.fprintf ppf "@\nOk.@\n"; let res = Html.get v in p "

Results

"; 
      cut (cgi # output # output_char) 80 res;  p "
"; dialog (if !persistant then "" else src); if ok then store_state () in let dump src = let ppf = Format.str_formatter in Cduce.dump_env ppf; let res = Format.flush_str_formatter () in p "

Current session environment

"; p ("
" ^ res ^ "
"); dialog src in Location.set_viewport (Html.create true); load_state (); store_state (); (* Just touch the file ... *) html_header p; let prog = cgi # argument_value "prog" in (match cmd with | `Exec -> exec prog | `Open -> dialog prog | `New -> dialog "" | `Dump -> dump prog | `Close -> dialog "" | `Example -> dialog (example (cgi # argument_value "example")) ); p ("

About the prototype

CDuce is under active development; some features may not work properly. The prototype is written in Objective Caml, and uses several OCaml packages: Camlp4, OCamlnet, PXP, wlex.

Webmaster

Prototype version "^ <:symbol> ^", built on "^ <:symbol> ^".

"); html_footer p; cgi # output # commit_work() with exn -> let msg = match exn with | Unix.Unix_error (e,f,arg) -> "System error: " ^ (Unix.error_message e) ^ "; function " ^ f ^ "; argument " ^ arg | Timeout -> "Timeout reached ! This prototype limits computation time ..." | exn -> Printexc.to_string exn in fatal_error "Internal software error!" msg let () = ignore (Unix.alarm 20); Sys.set_signal Sys.sigalrm (Sys.Signal_handle (fun _ -> raise Timeout)); main cgi; cgi # finalize ()