[Toss-devel-svn] SF.net SVN: toss:[1436] trunk/Toss

[<luk...@us...>]

Revision: 1436
          http://toss.svn.sourceforge.net/toss/?rev=1436&view=rev
Author:   lukaszkaiser
Date:     2011-05-12 23:29:43 +0000 (Thu, 12 May 2011)

Log Message:
-----------
Make TossServer handle WebClient requests natively.

Modified Paths:
--------------
    trunk/Toss/Server/DB.ml
    trunk/Toss/Server/DB.mli
    trunk/Toss/Server/ReqHandler.ml
    trunk/Toss/Server/Server.ml
    trunk/Toss/WebClient/Main.js

Modified: trunk/Toss/Server/DB.ml
===================================================================
--- trunk/Toss/Server/DB.ml	2011-05-09 23:43:28 UTC (rev 1435)
+++ trunk/Toss/Server/DB.ml	2011-05-12 23:29:43 UTC (rev 1436)
@@ -8,15 +8,30 @@
 
 let print_rows rs = List.iter (fun r -> print_row r; print_endline "") rs
 
-let get_table dbfile ?(select="") tbl =
+let apply_cmd dbfile select cmd =
   let (rows, wh_s) = (ref [], if select = "" then "" else " where " ^ select) in
-  let select_s = "select * from " ^ tbl ^ wh_s in
+  let select_s = cmd ^ wh_s in
   let db = Sqlite3.db_open dbfile in
   let add_row r = rows := r :: !rows in
   let res = Sqlite3.exec_not_null_no_headers db add_row select_s in
+  let nbr_changed = Sqlite3.changes db in
   ignore (Sqlite3.db_close db);
   match res with
-    | Sqlite3.Rc.OK -> List.rev !rows
+    | Sqlite3.Rc.OK -> (List.rev !rows, nbr_changed)
     | x -> raise (DBError (Sqlite3.Rc.to_string x))
   
+let get_table dbfile ?(select="") tbl =
+  fst (apply_cmd dbfile select ("select * from " ^ tbl))
 
+let count_table dbfile ?(select="") tbl =
+  let (rows, _) = apply_cmd dbfile select ("select count(*) from " ^ tbl) in
+  int_of_string (List.hd rows).(0)
+
+let insert_table dbfile tbl schm vals =
+  let vals_s = String.concat ", " (List.map (fun s -> "'" ^ s ^ "'") vals) in
+  let ins_s = Printf.sprintf "insert into %s(%s) values (%s)" tbl schm vals_s in
+  ignore (apply_cmd dbfile "" ins_s)
+
+let update_table dbfile ?(select="") set_s tbl =
+  snd (apply_cmd dbfile select ("update " ^ tbl ^ " set " ^ set_s))
+  

Modified: trunk/Toss/Server/DB.mli
===================================================================
--- trunk/Toss/Server/DB.mli	2011-05-09 23:43:28 UTC (rev 1435)
+++ trunk/Toss/Server/DB.mli	2011-05-12 23:29:43 UTC (rev 1436)
@@ -5,3 +5,9 @@
 val print_rows : string array list -> unit
 
 val get_table : string -> ?select : string -> string -> string array list
+
+val count_table : string -> ?select : string -> string -> int
+
+val insert_table : string -> string -> string -> string list -> unit
+
+val update_table : string -> ?select : string -> string -> string -> int

Modified: trunk/Toss/Server/ReqHandler.ml
===================================================================
--- trunk/Toss/Server/ReqHandler.ml	2011-05-09 23:43:28 UTC (rev 1435)
+++ trunk/Toss/Server/ReqHandler.ml	2011-05-12 23:29:43 UTC (rev 1436)
@@ -4,6 +4,7 @@
 let set_debug_level i = (debug_level := i;)
 
 
+(* ---------- Basic request type and internal handler ---------- *)
 
 type req_state =
   Formula.real_expr array array option (** heuristic option *)
@@ -145,10 +146,487 @@
     (g_heur, game_modified, state, gdl_transl, playclock), resp
     
 
+(* ------------ Old Python Wrapper Client Functions ------------ *)
 
-(* --------- LINES PARSING AND FULL REQUEST HANDLING ------------ *)
+let client = ref init_state
 
+let lstr l = "[" ^ (String.concat ", " l) ^ "]"
 
+let split_list ?(bound=None) pat s =
+  let r = Str.regexp_string pat in
+  match bound with None-> Str.split r s | Some b-> Str.bounded_split r s b
+
+let split_two pat s = 
+  match split_list ~bound:(Some 2) pat s with
+    | [x; y] -> (x, y)
+    | l -> failwith ("ReqHandler.split_two: " ^ (String.concat "|" l))
+
+let split ?(bound=None) pat s = Array.of_list (split_list ~bound pat s)
+
+let strip pat s = String.concat pat (split_list pat s)
+
+let strip_ws = Aux.strip_spaces
+
+let strip_all patl s =
+  let once str = List.fold_left (fun s p -> strip p s) (strip_ws str) patl in
+  let rec fp str = let ns = once str in if ns = str then ns else fp ns in fp s
+
+let strip_ws_lst s = strip_all ["]"; "["] s
+
+let str_find pat s =
+  try Str.search_forward (Str.regexp_string pat) s 0 with Not_found -> -1
+
+let str_replace pat repl s = Str.global_replace (Str.regexp_string pat) repl s
+
+let client_msg s =
+  let (new_st, res) = req_handle !client
+    (Aux.Left (ArenaParser.parse_request Lexer.lex (Lexing.from_string s))) in
+  client := new_st;
+  strip_ws res
+
+let client_get_state () = client_msg "GET STATE"
+
+let client_get_model () = client_msg "GET MODEL"
+
+let client_set_state state_s = ignore (client_msg ("SET STATE " ^ state_s))
+
+let client_get_cur_loc () = 
+  strip_ws (split "/" (client_msg "GET LOC")).(0)
+
+let client_set_cur_loc i = ignore (client_msg ("SET LOC " ^ i))
+
+let client_get_payoffs () = client_msg "GET PAYOFF"
+
+let client_get_loc_moves i =
+  let msg = client_msg ("GET LOC MOVES " ^ i) in
+  if String.length msg < 1 then [] else
+    let moves = split_list ";" msg in
+    let make_itvl v = 
+      let sep = split ":" v in
+      let d = split "--" sep.(1) in
+      (strip_ws sep.(0), strip_ws d.(0), strip_ws d.(1)) in
+    let make_move m =
+      let gs = split "->" m in
+      let lab = split_list "," gs.(0) in
+      (strip_ws (List.hd lab),
+       List.map (fun v -> make_itvl (strip_ws v)) (List.tl lab),
+       strip_ws gs.(1)) in
+    List.map (fun m -> make_move (strip_ws_lst m)) moves
+
+let client_query rule_nm = 
+  let msg = client_msg ("GET RULE " ^ rule_nm ^ " MODEL") in
+  if str_find "->" msg < 0 then [] else
+    let make_match m_str = 
+      let app_p_assoc dict p = 
+        let p_str = split "->" p in
+        (strip_ws p_str.(0), strip_ws p_str.(1)) :: dict in
+      List.fold_left app_p_assoc [] (split_list "," m_str) in
+    List.map (fun m -> make_match (strip_ws m)) (split_list ";" msg)
+
+let client_apply_rule rule_nm mtch_s time params = 
+  (*let mt_s = String.concat ", " (List.map (fun (l,r)-> l ^": "^ r) mtch) in*)
+  let param_s = String.concat ", " (List.map (fun (p,v)-> p ^": "^ v) params) in
+  let m = client_msg ("SET RULE " ^ rule_nm ^ " MODEL " ^ mtch_s ^ " " ^
+			 time ^ " " ^ param_s) in
+  let add_shift shifts seq =
+    if Array.length seq > 2 then
+      ((seq.(0), seq.(1)), Array.sub seq 2 ((Array.length seq) - 2)) :: shifts
+    else shifts in
+  let add_shift_s sh s = add_shift sh (Array.map strip_ws (split "," s)) in
+  List.fold_left add_shift_s [] (List.map strip_ws (split_list ";" m))
+
+let client_open_from_str s = client_set_state ("#db#" ^ s)
+
+let client_move_str (m, r, e) = 
+  let mstr m = String.concat ", " (List.map (fun (a, b) -> a ^ ": " ^ b) m) in
+  "({" ^ mstr m ^ "}, " ^ r ^ ", " ^ e ^ ")"
+
+let client_cur_moves () =
+  let append_move moves (r, _, endp) = (* FIXME! currently we ignore itvls *)
+    (List.map (fun m -> (m, r, endp)) (client_query r)) @ moves in
+  let cur_loc = client_get_cur_loc () in
+  let moves = List.fold_left append_move [] (client_get_loc_moves cur_loc) in
+  String.concat "; " (List.map client_move_str moves)
+
+let client_get_loc_player i = client_msg ("GET LOC PLAYER " ^ i)
+
+let client_make_move m r endp =
+  let _ = client_apply_rule r m "1.0" [] in
+  client_set_cur_loc endp;
+  client_get_loc_player endp
+
+let client_get_data data_id = 
+  let m = client_msg ("GET DATA " ^ data_id) in
+  if String.length m > 2 && String.sub m 0 3 = "ERR" then "none" else m
+
+let client_set_time tstep t =
+  ignore (client_msg ("SET dynamics " ^ tstep ^ " " ^ t))
+
+let client_get_time () =
+  let m = client_msg "GET dynamics" in
+  let t = Array.map strip_ws (split "/" m) in
+  (t.(0), t.(1))
+
+
+let client_suggest timeout advr =
+  let loc = client_get_cur_loc () in
+  let (ts, t) = client_get_time () in
+  let m = client_msg ("EVAL LOC MOVES " ^ advr ^ ".0 " ^ loc ^ 
+			 " TIMEOUT " ^ timeout ^ " 55500 alpha_beta_ord") in
+  client_set_time ts t;
+  let msg = Array.map strip_ws (split ";" m) in
+  if Array.length msg < 2 then "" else
+    let append_emb emb s =
+      let es = Array.map strip_ws (split ":" s) in
+      (es.(0), es.(1)) :: emb in
+    let emb = List.fold_left append_emb [] (split_list "," msg.(1)) in
+    client_move_str (emb, msg.(0), msg.(3))
+
+
+let client_model_get_elem_val el_id vl =
+  let v = client_msg ("GET FUN MODEL " ^ vl ^ " " ^ el_id) in
+  float_of_string v
+
+let client_model_get_elem_pos el_id =
+  (client_model_get_elem_val el_id "x", client_model_get_elem_val el_id "y")
+
+let client_model_get_elems () =
+  let m = client_msg "GET ALLOF ELEM MODEL " in
+  if String.length m < 1 then [] else List.map strip_ws (split_list ";" m)
+
+
+let client_model_get_dim () =
+  let (posx, posy) = List.split
+    (List.map client_model_get_elem_pos (client_model_get_elems ())) in
+  let mkfl f l = List.fold_left (fun x y -> f x y) (List.hd l) (List.tl l) in
+  let (minl, maxl, suml) = (mkfl min, mkfl max, mkfl (+.)) in
+  let minx, maxx, miny, maxy = minl posx, maxl posx, minl posy, maxl posy in
+  let sumx, sumy, l = suml posx, suml posy, float (List.length posx) in
+  (maxx, minx, maxy, miny, sumx /. l, sumy /. l)
+
+let client_model_get_rel_names_arities () =
+  let mrel = client_msg "GET SIGNATURE REL MODEL " in
+  if String.length mrel < 1 then [] else
+    let rel_of_ps ps = 
+      let p = split ":" (strip_ws ps) in (strip_ws p.(0), strip_ws p.(1)) in
+    let rels = List.map rel_of_ps (split_list "," mrel) in
+    Aux.unique_sorted rels
+
+let client_model_get_rel rel_name =
+  let m = client_msg ("GET ALLOF REL MODEL " ^ rel_name) in
+  let first_br = max (str_find "{" m) (str_find "(" m) in
+  if first_br < 0 then [] else
+    let m_br = String.sub m first_br ((String.length m) - first_br) in
+    let tps = List.map (strip_all ["{";"}";"(";")"]) (split_list ";" m_br) in
+    List.map (fun ts -> List.map strip_ws (split_list "," ts)) tps
+
+let client_model_get_rels_simple () =
+  let sg = client_model_get_rel_names_arities () in
+  let app_rel_tuples tuples (r, _) =
+    (List.map (fun a -> (r, a)) (client_model_get_rel r)) @ tuples in
+  let tuples = List.fold_left app_rel_tuples [] sg in
+  let tp_str (r, a) = "(" ^ r ^ ", " ^ (lstr a) ^ ")" in
+  String.concat "; " (List.map tp_str tuples)
+
+let client_model_get_elems_with_pos () =
+  let m = client_msg "GET ALLOF ELEM MODEL " in
+  if String.length m < 1 then [] else
+    let els = List.map strip_ws (split_list ";" m) in
+    let els_p = List.map (fun e -> (e, client_model_get_elem_pos e)) els in
+    let ep_str (e, (x, y)) = Printf.sprintf "%s ; %f ; %f" e x y in
+    List.map ep_str els_p
+
+let client_get_game_info () =
+  let (x1, x2, y1, y2, mx, my) = client_model_get_dim () in
+  let dim_s = Printf.sprintf "(%f, %f, %f, %f, %f, %f)" x1 x2 y1 y2 mx my in
+  let model_s = lstr (client_model_get_elems_with_pos ()) in
+  let rels_s = client_model_get_rels_simple () in
+  let moves = client_cur_moves () in
+  let moves_s =
+    if String.length moves < 2 then client_get_payoffs () else moves in
+  dim_s ^ "$" ^ model_s ^ "$" ^ rels_s ^ "$" ^ moves_s
+
+
+
+(* ------------ Http Handlers ------------ *)
+
+let http_msg code mimetp cookies s = 
+  let get_tm s = 
+    let t = Unix.gmtime (Unix.gettimeofday() +. s) in
+    let day = match t.Unix.tm_wday with
+      | 0 -> "Sun" | 1 -> "Mon" | 2 -> "Tue" | 3 -> "Wed" | 4 -> "Thu"
+      | 5 -> "Fri" | 6 -> "Sat" | _ -> failwith "no such day" in
+    let mon = match t.Unix.tm_mon with
+      | 0 -> "Jan" | 1 -> "Feb" | 2 -> "Mar" | 3 -> "Apr" | 4 -> "May"
+      | 5 -> "Jun" | 6 -> "Jul" | 7 -> "Aug" | 8 -> "Sep" | 9 -> "Oct"
+      | 10 -> "Nov" | 11 -> "Dec" | _ -> failwith "no such month" in
+    Printf.sprintf "%s, %02i-%s-%04i %02i:%02i:%02i GMT" day t.Unix.tm_mday mon
+      (1900 + t.Unix.tm_year) t.Unix.tm_hour t.Unix.tm_min t.Unix.tm_sec in
+  let ck_str (n, v, expires) = 
+    let c = "Set-Cookie: " ^ n ^ "=" ^ v ^ "; " in
+    match expires with
+      | None -> c ^ "httponly"
+      | Some t -> c ^ "Expires=" ^ (get_tm t) ^ "; httponly" in
+  let cookies_s = String.concat "\n" (List.map ck_str cookies) in
+  "HTTP/1.1 " ^ code ^ "\r\n" ^ 
+    "Content-Type: " ^ mimetp ^ "\r\n" ^
+    (if cookies = [] then "" else cookies_s ^ "\r\n") ^
+    "Content-length: " ^ (string_of_int (String.length s)) ^ "\r\n\r\n" ^ s
+
+let handle_http_get cmd head msg ck =
+  if !debug_level > 1 then (
+    Printf.printf "Http Get Handler\n%s%s\n%!" cmd msg;
+    if ck <> [] then 
+      let ck_strs = List.map (fun (n, v) -> n ^ "=" ^ v) ck in
+      Printf.printf "Cookies: %s\n%!" (String.concat "; " ck_strs);
+  );
+  let fname_in0 = String.sub cmd 5 ((String.index_from cmd 5 ' ') - 5) in
+  let fname_in = if fname_in0 = "" then "index.html" else fname_in0 in
+  let fname = "WebClient/" ^ fname_in in
+  if !debug_level > 1 then Printf.printf "SERVING FILE: %s;\n%!" fname;
+  if Sys.file_exists fname then (
+    let f = open_in fname in
+    let content = Aux.input_file f in
+    close_in f;
+    let tp = match String.sub fname ((String.index fname '.') + 1) 2 with
+      | "ht" -> "text/html charset=utf-8"
+      | "ic" -> "image/x-icon"
+      | "pn" -> "image/png"
+      | "cs" -> "text/css"
+      | "js" -> "text/javascript"
+      | "sv" -> "image/svg+xml"
+      | _ -> "text/html charset=utf-8" in
+    http_msg "200 OK" tp [] content
+  ) else http_msg "404 NOT FOUND" "text/html charset=utf-8" []
+    ("<html>\n<head><title>Toss: Page Not Found</title></head>\n" ^
+	"<body><p>Not found: " ^ fname_in ^ "</p></body>\n</html>")
+
+let handle_http_post cmd head msg ck =
+  let tUID = "toss_id_05174_" in
+  let dbFILE = "/var/www/WebClient/tossdb.sqlite" in
+  let tGAMES = ["Breakthrough"; "Checkers"; "Chess"; "Connect4";
+		"Entanglement"; "Gomoku"; "Pawn-Whopping"; "Tic-Tac-Toe"] in 
+  let get_args s = Array.map (strip_all ["'"]) (split ", " s) in
+  let dbtable select tbl = DB.get_table dbFILE ~select tbl in
+  let passwd_from_db uid =
+    let res = dbtable ("id='" ^ uid ^ "'") "users" in
+    match List.length res with
+      | 0 -> None
+      | x when x > 1 -> failwith ("passwd from db: multiple entries for " ^ uid)
+      | _ -> let r = List.hd res in (* r = (uid,_,_,_,pwd) *) Some (r.(4)) in
+  let get_user_name_surname_mail uid =
+    let res = dbtable ("id='" ^ uid ^ "'") "users" in
+    match List.length res with
+      | 0 -> ("", "", "")
+      | x when x > 1 -> failwith ("get_user_name: multiple entries for " ^ uid)
+      | _ -> let r = List.hd res in (r.(1), r.(2), r.(3)) in
+  let verif_uid () =
+    let (ukey, pkey)= (tUID ^ "username", tUID ^ "passphrase") in
+    if not (List.mem_assoc ukey ck) then "" else
+      if not (List.mem_assoc pkey ck) then "" else
+	let (uid, pwd1) = (List.assoc ukey ck, List.assoc pkey ck) in
+	match passwd_from_db uid with None -> "" | Some pwd2 ->
+	  if pwd1 = pwd2 then uid else "" in
+  let list_plays game pl_id =
+    let or_s = "(player1='" ^ pl_id ^ "' or player2='" ^ pl_id ^ "')" in
+    let plays = dbtable ("game='" ^ game ^ "' and " ^ or_s) "cur_states" in
+    let play_name p = (* p = (pid, g, p1, p2, move, _, _, _, _) *)
+      "/plays/"^ p.(1) ^"_"^ p.(2) ^"_"^ p.(3) ^"_"^ p.(0) ^"_"^ p.(4) in
+    lstr (List.map play_name plays) in
+  let user_plays uid =
+    let (name, _, _) = get_user_name_surname_mail uid in
+    let app_plays plays g = plays ^ "$" ^ (list_plays g uid) in
+    let plays = List.fold_left app_plays "" tGAMES in
+    uid ^ "$" ^ name ^ plays in
+  let get_free_id () = (DB.count_table dbFILE "cur_states") + 1 in
+  let db_cur_insert game p1 p2 pid move toss loc info svg_str =
+    DB.insert_table dbFILE "cur_states"
+      "playid, game, player1, player2, move, toss, loc, info, svg"
+      [pid; game; p1; p2; move; toss; loc; info; svg_str] in
+  let rec get_global_lock () =
+    let select = "locked='false' and tid='" ^ tUID ^ "'" in
+    let i = DB.update_table dbFILE ~select "locked='true'" "lock" in
+    if !debug_level > 1 then print_endline ("Glob lock " ^ (string_of_int i));
+    if i = 1 then () else get_global_lock () in
+  let release_global_lock () =
+    let select = "locked='true' and tid='" ^ tUID ^ "'" in
+    if !debug_level > 1 then print_endline "Glob lock release";
+    ignore (DB.update_table dbFILE ~select "locked='false'" "lock") in
+  let new_play game pl1 pl2 =
+    let toss = (List.hd (dbtable ("game='" ^ game ^ "'") "games")).(1) in
+    client_open_from_str toss;
+    let info = client_get_game_info () in
+    let model = client_get_model () in
+    let loc = client_get_cur_loc () in
+    let move_pl = int_of_string (client_get_loc_player loc) - 1 in
+    get_global_lock ();
+    let pid = string_of_int (get_free_id ()) in
+    db_cur_insert game pl1 pl2 pid (string_of_int move_pl) model loc info "";
+    release_global_lock ();
+    pid ^ "$" ^ info ^ "$" ^ (string_of_int move_pl) in
+  let game_select_s g p1 p2 pid m =
+    "game='" ^ g ^ "' and player1='" ^ p1 ^ "' and player2='" ^ p2 ^
+      "' and playid=" ^ pid ^ " and move=" ^ m in
+  let upd_svg g p1 p2 pid m svg_s =
+    let select = game_select_s g p1 p2 pid m in
+    let _ = DB.update_table dbFILE ~select ("svg='"^ svg_s ^"'") "cur_states" in
+    "" in
+  let db_escape s = str_replace "'" "''" s in
+  let move_play move_tup g p1 p2 pid m =
+    let sel_s = game_select_s g p1 p2 pid m in
+    let old_res= List.hd (dbtable sel_s "cur_states") in
+    let (old_toss, old_loc, old_info, old_svg) =
+      (old_res.(5), old_res.(6), old_res.(7), old_res.(8)) in
+    let game_toss = (List.hd (dbtable ("game='" ^ g ^ "'") "games")).(1) in
+    client_open_from_str (game_toss ^ "\nMODEL " ^ old_toss);
+    client_set_cur_loc old_loc;
+    let (move1a, move2, move3) = move_tup in
+    let move1 = strip_all ["{"; "}"] move1a in
+    let new_pl = int_of_string (client_make_move move1 move2 move3) - 1 in
+    let new_toss = db_escape (client_get_model ()) in
+    let new_info = client_get_game_info () in
+    let new_info_db = db_escape new_info in
+    let cur_upd s = 
+      ignore (DB.update_table dbFILE ~select:sel_s s "cur_states") in
+    cur_upd ("toss='" ^ new_toss ^ "'");
+    cur_upd ("info='" ^ new_info_db ^ "'");
+    cur_upd ("loc='" ^ move3 ^ "'");
+    cur_upd ("move=" ^ (string_of_int new_pl));
+    DB.insert_table dbFILE "old_states"
+      "playid, game, player1, player2, move, toss, loc, info, svg"
+      [pid; g; p1; p2; m; old_toss; old_loc; old_info; old_svg];
+    new_info ^ "$" ^ (string_of_int new_pl) in
+  let suggest time g p1 p2 pid m =
+    let res = List.hd (dbtable (game_select_s g p1 p2 pid m) "cur_states") in
+    let (toss, loc) = (res.(5), res.(6)) in
+    let game_toss = (List.hd (dbtable ("game='" ^ g ^ "'") "games")).(1) in
+    client_open_from_str (game_toss ^ "\nMODEL " ^ toss);
+    client_set_cur_loc loc;
+    let adv_ratio_data = client_get_data "adv_ratio" in
+    let adv_ratio = if adv_ratio_data = "none" then "4" else adv_ratio_data in
+    client_suggest time adv_ratio in
+  let register_user ui =
+    if Array.length ui <> 5 then false else
+      let (uid, name, surname, email, pwd) = 
+	(ui.(0), ui.(1), ui.(2), ui.(3), ui.(4)) in
+      match passwd_from_db uid with Some _ -> false | None ->
+	DB.insert_table dbFILE "users" "id, name, surname, email, passwd"
+	  [uid; name; surname; email; pwd];
+	DB.insert_table dbFILE "friends" "id, fid" [uid; "computer"];
+	true in
+  let login_user uid chk pwd =
+    match passwd_from_db uid with 
+      | None -> ("no such user registered", [])
+      | Some p when p <> pwd -> ("wrong password", [])
+      | Some _ ->
+	let exp = if chk then Some (float (3600 * 1000)) else None in
+	("OK", [(tUID^"username", uid, exp); (tUID^"passphrase", pwd, exp)]) in
+  let list_friends all uid =
+    if all then List.map (fun a -> a.(0)) (dbtable "" "users") else
+      let friends = dbtable ("id='" ^ uid ^ "'") "friends" in
+      List.map (fun a -> a.(1)) friends in
+  let open_db game p1 p2 pid move =
+    let res = dbtable (game_select_s game p1 p2 pid move) "cur_states" in
+    let (move, info) = ((List.hd res).(4), (List.hd res).(7)) in
+    info ^ "$" ^ move in
+  let add_opponent uid oppid =
+    if uid = "" then "You must login first to add opponents." else
+    let (name, _, _) = get_user_name_surname_mail oppid in
+    if name = "" then "No such opponent found among tPlay users." else (
+      DB.insert_table dbFILE "friends" "id, fid" [uid; oppid];
+      "OK"
+    ) in
+  let change_user_data uid udata =
+    if uid = "" then "You must login first to change data." else
+      if Array.length udata <> 3 then "Internal error, data not changed." else
+	let uid_s = "id='" ^ uid ^ "'" in
+	let upd s = ignore (DB.update_table dbFILE ~select:uid_s s "users") in
+	upd ("name='" ^ udata.(0) ^ "'"); 
+	upd ("surname='" ^ udata.(1) ^ "'");
+	upd ("email='" ^ udata.(2) ^ "'");
+	"OK" in
+  if !debug_level > 1 then
+    Printf.printf "POST\n%s\n%s\nCONTENT\n%s\nEND CONTENT\n" cmd head msg;
+  let (tcmd, data) = split_two "#" msg in
+  let resp, new_cookies = match tcmd with
+    | "USERNAME" ->
+      verif_uid (), []
+    | "USERPLAYS" -> 
+      if verif_uid () = "" then "", [] else user_plays (verif_uid ()), []
+    | "REGISTER" ->
+      let ui = split "$" data in
+      if register_user ui then
+        "Registration successful for " ^ ui.(0) ^ ".", []
+      else
+        "Registration failed:\n  username " ^ ui.(0) ^ " already in use." ^
+          "\nPlease choose another username and try again.", []
+    | "LOGIN" ->
+      let ui = split "$" data in
+      if Array.length ui = 3 then (
+        let (resp, new_ck) = login_user ui.(0) (ui.(1) = "true") ui.(2) in
+	if resp = "OK" then (resp, new_ck) else
+	  ("Login failed for " ^ ui.(0) ^ ": " ^ resp, [])
+      ) else "Login: internal error", []
+    | "LOGOUT" ->
+      let c =
+	[(tUID ^ "username", "a", None); (tUID ^ "passphrase", "a", None)] in
+      ("User logged out: " ^ (verif_uid ()), c)
+    | "ADDOPP" ->
+      add_opponent (verif_uid ()) data, []
+    | "GET_NAME" ->
+      let (name, _, _) = get_user_name_surname_mail data in name, []
+    | "GET_SURNAME" ->
+      let (_, surname, _) = get_user_name_surname_mail data in surname, []
+    | "LIST_FRIENDS" ->
+      lstr (list_friends (data = "**") (verif_uid ())), []
+    | "GET_MAIL" ->
+      if verif_uid()="" then "You must login first to get email data.", [] else
+	let (_, _, mail) = get_user_name_surname_mail data in mail, []
+    | "CHANGEUSR" ->
+      change_user_data (verif_uid ()) (split "$" data), []
+    | "LIST_PLAYS" ->
+      let a = get_args data in list_plays a.(0) a.(1), []
+    | "OPEN_DB" ->
+      let a = get_args data in open_db a.(0) a.(1) a.(2) a.(3) a.(4), []
+    | "UPD_SVG" ->
+      let a = Array.map (strip_all ["'"]) (split ~bound:(Some 6) ", " data) in
+      upd_svg a.(0) a.(1) a.(2) a.(3) a.(4) a.(5), []
+    | "NEW_PLAY" ->
+      let a = get_args data in new_play a.(1) a.(2) a.(3), []
+    | "SUGGEST" ->
+      let a = get_args data in suggest a.(1) a.(2) a.(3) a.(4) a.(5) a.(6), []
+    | "MOVE_PLAY" ->
+      let (op_i, cl_i) = (String.index data '(', String.index data ')') in
+      let tp_s = String.sub data (op_i+1) (cl_i - op_i-1) in
+      let args_s = String.sub data (cl_i+2) ((String.length data) - cl_i-2) in
+      let tp_i, tp_l = String.rindex tp_s ',', String.length tp_s in
+      let tp_j = String.rindex_from tp_s (tp_i - 1) ',' in
+      let tp0 = String.sub tp_s 0 tp_j in
+      let tp1 = String.sub tp_s (tp_j+1) (tp_i - tp_j - 1) in
+      let tp2 = String.sub tp_s (tp_i+1) (tp_l - tp_i - 1) in
+      let tp, a = (strip_ws tp0, strip_ws tp1, strip_ws tp2), get_args args_s in
+      move_play tp a.(0) a.(1) a.(2) a.(3) a.(4), []
+    | _ ->
+      "MOD_PYTHON ERROR ; Traceback: Unknown Toss Command! \n " ^ tcmd, [] in
+  http_msg "200 OK" "text/html charset=utf-8" new_cookies resp
+
+
+let handle_http_msg rstate cmd head msg ck =
+  if String.sub cmd 0 5 = "GET /" then
+    rstate, handle_http_get cmd head msg ck
+  else if String.length cmd > 13 && String.sub cmd 0 13 = "POST /Handler" then
+    rstate, handle_http_post cmd head msg ck
+  else try
+	 req_handle rstate 
+	   (Aux.Right (GDLParser.parse_request KIFLexer.lex
+			 (Lexing.from_string msg)))
+    with Parsing.Parse_error | Lexer.Parsing_error _ ->
+      rstate, handle_http_post cmd head msg ck
+
+
+
+(* ------- Full Request Handler (both Html and Generic Toss) ------- *)
+
 let rec read_in_line in_ch =
   let line_in =
     let rec nonempty () =
@@ -166,7 +644,8 @@
   match Aux.input_if_http_message line_in in_ch with
     | Some (head, msg, cookies) ->
       if !debug_level > 0 then Printf.printf "Rcvd: %s\n%!" msg;
-      ("HTTP", Some (Aux.Left (line_in, head, msg, cookies)))
+      let ck = List.map (fun (k, v) -> (strip_ws k, strip_ws v)) cookies in
+      ("HTTP", Some (Aux.Left (line_in, head, msg, ck)))
     | None ->
       if line_in = "COMP" then
 	let res = Marshal.from_channel in_ch in
@@ -181,65 +660,7 @@
 	if !debug_level > 0 then Printf.printf "Rcvd: %s\n%!" line;
 	(line, None)
 
-let http_msg code mimetp cookies s = 
-  let get_tm s = 
-    let t = Unix.gmtime (Unix.gettimeofday() +. s) in
-    let day = match t.Unix.tm_wday with
-      | 0 -> "Sun" | 1 -> "Mon" | 2 -> "Tue" | 3 -> "Wed" | 4 -> "Thu"
-      | 5 -> "Fri" | 6 -> "Sat" | _ -> failwith "no such day" in
-    let mon = match t.Unix.tm_mon with
-      | 0 -> "Jan" | 1 -> "Feb" | 2 -> "Mar" | 3 -> "Apr" | 4 -> "May"
-      | 5 -> "Jun" | 6 -> "Jul" | 7 -> "Aug" | 8 -> "Sep" | 9 -> "Oct"
-      | 10 -> "Nov" | 11 -> "Dec" | _ -> failwith "no such month" in
-    Printf.sprintf "%s, %02i-%s-%04i %02i:%02i:%02i GMT" day t.Unix.tm_mday mon
-      (1900 + t.Unix.tm_year) t.Unix.tm_hour t.Unix.tm_min t.Unix.tm_sec in
-  let ck_str (n, v, expires) = 
-    let c = "Set-Cookie: " ^ n ^ "=" ^ v ^ "; " in
-    match expires with
-      | None -> c ^ "httponly"
-      | Some t -> c ^ "Expires=" ^ (get_tm t) ^ "; httponly" in
-  let cookies_s = String.concat "\n" (List.map ck_str cookies) in
-  "HTTP/1.1 " ^ code ^ "\r\n" ^ 
-    "Content-Type: " ^ mimetp ^ "\r\n" ^
-    (if cookies = [] then "" else cookies_s ^ "\r\n") ^
-    "Content-length: " ^ (string_of_int (String.length s)) ^ "\r\n\r\n" ^ s
 
-let handle_pure_http cmd head msg ck =
-  if !debug_level > 0 then (
-    Printf.printf "Pure Http Handler\n%s%s\n%!" cmd msg;
-    if ck <> [] then 
-      let ck_strs = List.map (fun (n, v) -> n ^ "=" ^ v) ck in
-      Printf.printf "Cookies: %s\n%!" (String.concat "; " ck_strs);
-  );
-  if String.sub cmd 0 5 = "GET /" then (
-    let fname_in0 = String.sub cmd 5 ((String.index_from cmd 5 ' ') - 5) in
-    let fname_in = if fname_in0 = "" then "index.html" else fname_in0 in
-    let fname = "WebClient/" ^ fname_in in
-    if !debug_level > 0 then Printf.printf "SERVING FILE: %s;\n%!" fname;
-    if Sys.file_exists fname then (
-      let f = open_in fname in
-      let content = Aux.input_file f in
-      close_in f;
-      let tp = match String.sub fname ((String.index fname '.') + 1) 2 with
-	| "ht" -> "text/html charset=utf-8"
-	| "ic" -> "image/x-icon"
-	| "pn" -> "image/png"
-	| "cs" -> "text/css"
-	| "js" -> "text/javascript"
-	| "sv" -> "image/svg+xml"
-	| _ -> "text/html charset=utf-8" in
-      http_msg "200 OK" tp [] content
-    ) else http_msg "404 NOT FOUND" "text/html charset=utf-8" []
-      ("<html>\n<head><title>Toss: Page Not Found</title></head>\n" ^
-	  "<body><p>Not found: " ^ fname_in ^ "</p></body>\n</html>")
-  ) else (
-    if !debug_level > 1 then
-      Printf.printf "POST\n%s\n%s\nCONTENT\n%s\nEND CONTENT\n" cmd head msg;
-    http_msg "200 OK" "text/html charset=utf-8" [("post","error", Some 5.)]
-      ("<html>\n<head><title>Errror</title></head>\n" ^
-	  "<body><p>Http POST not functional yet</p></body>\n</html>")
-  )
-
 let full_req_handle rstate in_ch out_ch =
   try
     let time_started = Unix.gettimeofday () in
@@ -258,16 +679,9 @@
 	Marshal.to_channel out_ch res [Marshal.Closures];
 	flush out_ch;
 	rstate
-      | (line, Some (Aux.Left (cmd, head, msg, ck))) when line = "HTTP" -> (
-	report (
-	  try
-	    req_handle rstate 
-	      (Aux.Right (GDLParser.parse_request KIFLexer.lex
-			    (Lexing.from_string msg)))
-	  with Parsing.Parse_error | Lexer.Parsing_error _ ->
-	    rstate, handle_pure_http cmd head msg ck
-	))
-      | (_, Some _) -> failwith "Internal ReqHandler Error!"
+      | (line, Some (Aux.Left (cmd, head, msg, ck))) when line = "HTTP" ->
+	report (handle_http_msg rstate cmd head msg ck)
+      | (_, Some _) -> failwith "Internal ReqHandler Error (full_req_handle)!"
       | (line, None) ->
 	report (req_handle rstate 
 		  (Aux.Left (ArenaParser.parse_request Lexer.lex 

Modified: trunk/Toss/Server/Server.ml
===================================================================
--- trunk/Toss/Server/Server.ml	2011-05-09 23:43:28 UTC (rev 1435)
+++ trunk/Toss/Server/Server.ml	2011-05-12 23:29:43 UTC (rev 1436)
@@ -131,7 +131,6 @@
   let (server, port) = (ref "localhost", ref 8110) in
   let (test_s, test_full) = (ref "# # / $", ref false) in
   let (experiment, e_len, e_d1, e_d2) = (ref false, ref 1, ref 2, ref 2) in
-  let sqltest = ref "" in
   let set_parallel_port p = 
     let (_, s) = !GameTree.parallel_toss in
     GameTree.parallel_toss := (p, s) in
@@ -143,7 +142,6 @@
     ("-vv", Arg.Unit (fun () -> set_debug_level 2), " make Toss very verbose");
     ("-d", Arg.Int (fun i -> set_debug_level i), "Toss server debug log level");
     ("-s", Arg.String (fun s -> (server := s)), " server (default: localhost)");
-    ("-sql", Arg.String (fun s -> (sqltest := s)), " sql testing (temporary)");
     ("-f", Arg.String (fun s -> set_state_from_file s), " open file");
     ("-nm", Arg.Unit (fun () -> Heuristic.use_monotonic := false),
      " monotonicity off");
@@ -188,8 +186,6 @@
     ignore (OUnit.run_test_tt ~verbose (Tests.tests ~full ~dirs ~files ()))
   ) else if !experiment then
     run_test !e_len !e_d1 !e_d2
-  else if !sqltest <> "" then
-    DB.print_rows (DB.get_table "WebClient/tossdb.sqlite" !sqltest)
   else try
 	 start_server req_handle !port !server
     with Aux.Host_not_found ->

Modified: trunk/Toss/WebClient/Main.js
===================================================================
--- trunk/Toss/WebClient/Main.js	2011-05-09 23:43:28 UTC (rev 1435)
+++ trunk/Toss/WebClient/Main.js	2011-05-12 23:29:43 UTC (rev 1436)
@@ -99,7 +99,8 @@
 function show_move (m) {
     var m_act = get_move_elems (m);
     m_act.sort ();
-    var m_rule = m.substring (m.indexOf("},")+4, m.lastIndexOf(',')-1);
+    var m_rule = strip ("'", " ",
+			m.substring (m.indexOf("},")+3, m.lastIndexOf(',')));
     for (var i = 0; i < CUR_ELEMS.length; i++) {
         unhighlight_elem (CUR_ELEMS[i]);
     }


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.