[Toss-devel-svn] SF.net SVN: toss:[1435] trunk/Toss
Status: Beta
Brought to you by:
lukaszkaiser
Menu
▾
▴
[Toss-devel-svn] SF.net SVN: toss:[1435] trunk/Toss
|
From: <luk...@us...> - 2011-05-09 23:43:35
|
Revision: 1435
http://toss.svn.sourceforge.net/toss/?rev=1435&view=rev
Author: lukaszkaiser
Date: 2011-05-09 23:43:28 +0000 (Mon, 09 May 2011)
Log Message:
-----------
WebClient corrections, better http handling in TossServer.
Modified Paths:
--------------
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/GGP/Makefile
trunk/Toss/Server/ReqHandler.ml
trunk/Toss/WebClient/Handler.py
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2011-05-09 01:19:32 UTC (rev 1434)
+++ trunk/Toss/Formula/Aux.ml 2011-05-09 23:43:28 UTC (rev 1435)
@@ -614,21 +614,40 @@
let rec input_http_message file =
let buf = Buffer.create 256 in
- let line = ref "POST / HTTP" in
- let msg_len = ref 0 in
+ let get_pair s =
+ let i, l = String.index s '=', String.length s in
+ (String.sub s 0 i, String.sub s (i+1) (l-i-1)) in
+ let rec get_cookies s =
+ try
+ let i, l = String.index s ';', String.length s in
+ (get_pair (String.sub s 0 i)) :: get_cookies (String.sub s (i+1) (l-i-1))
+ with Not_found -> [] in
+ let line, head, cookies, msg_len = ref "HTTP", ref [], ref [], ref 0 in
while !line <> "" do
line := strip_spaces (input_line file);
+ head := !line :: !head;
let line_len = String.length !line in
- if line_len > 16 && String.sub !line 0 15 = "Content-length:" then (
- msg_len := int_of_string
- (String.sub !line 16 (line_len - 16));
- )
+ if line_len > 6 && String.lowercase (String.sub !line 0 6) = "cookie" then (
+ let start = (String.index !line ' ') + 1 in
+ let ck_str = String.sub !line start (line_len - start) in
+ cookies := get_cookies (ck_str ^ ";") @ !cookies
+ );
+ if line_len > 16 &&
+ String.lowercase (String.sub !line 0 15) = "content-length:" then (
+ msg_len := int_of_string (String.sub !line 16 (line_len - 16));
+ )
done;
Buffer.add_channel buf file !msg_len;
- Buffer.contents buf
+ (String.concat "\n" !head, Buffer.contents buf, !cookies)
+let input_if_http_message line in_ch =
+ let ht1, ht2 = "GET /", "POST /" in
+ let l1, l2, l = String.length ht1, String.length ht2, String.length line in
+ if ((l > l1 && String.sub line 0 l1 = ht1) ||
+ (l > l2 && String.sub line 0 l2 = ht2)) then
+ Some (input_http_message in_ch)
+ else None
-
exception Host_not_found
let get_inet_addr addr_s =
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2011-05-09 01:19:32 UTC (rev 1434)
+++ trunk/Toss/Formula/Aux.mli 2011-05-09 23:43:28 UTC (rev 1435)
@@ -295,10 +295,14 @@
(** Input a file to a string. *)
val input_file : in_channel -> string
-(** Skip the header extracting the [Content-length] field and input the
- content of an HTTP message. *)
-val input_http_message : in_channel -> string
+(** Extracting the [Content-length] field and input the content of
+ an HTTP message. Return the pair: header first, content next. *)
+val input_http_message : in_channel -> string * string * (string * string) list
+(** Input HTTP message if [line] is a http header, ie. "GET /" or "POST /".*)
+val input_if_http_message : string -> in_channel ->
+ (string * string * (string * string) list) option
+
(** Exception used in connections when the host is not found. *)
exception Host_not_found
Modified: trunk/Toss/GGP/Makefile
===================================================================
--- trunk/Toss/GGP/Makefile 2011-05-09 01:19:32 UTC (rev 1434)
+++ trunk/Toss/GGP/Makefile 2011-05-09 23:43:28 UTC (rev 1435)
@@ -26,10 +26,10 @@
make tictactoe.black
make breakthrough.white
make breakthrough.black
- make pawn_whopping.white
- make pawn_whopping.black
- make connect4.white
- make connect4.black
+ #make pawn_whopping.white
+ #make pawn_whopping.black
+ #make connect4.white
+ #make connect4.black
make connect5.white
make connect5.black
Modified: trunk/Toss/Server/ReqHandler.ml
===================================================================
--- trunk/Toss/Server/ReqHandler.ml 2011-05-09 01:19:32 UTC (rev 1434)
+++ trunk/Toss/Server/ReqHandler.ml 2011-05-09 23:43:28 UTC (rev 1435)
@@ -43,56 +43,6 @@
exception Found of int
-let req_of_str s =
- let s_len = String.length s in
- if s_len > 4 && String.sub s 0 4 = "GDL "
- then (
- (* {{{ log entry *)
- if !debug_level > 1 then (
- Printf.printf "req_of_str-GDL:\n%s\n%!" (String.sub s 4 (s_len-4));
- );
- (* }}} *)
- Aux.Right (GDLParser.parse_request KIFLexer.lex
- (Lexing.from_string (String.sub s 4 (s_len-4))))
- )
- else
- Aux.Left (ArenaParser.parse_request Lexer.lex (Lexing.from_string s))
-
-
-let rec read_in_line in_ch =
- let line_in =
- let rec nonempty () =
- let line_in = input_line in_ch in
- if line_in = "" || line_in = "\r" then nonempty ()
- else line_in in
- nonempty () in
- let line_in_len = String.length line_in in
- (* TODO: who needs escaping? *)
- let line_in =
- if line_in.[line_in_len-1] <> '\r' then
- (* String.escaped *) line_in
- else
- (* String.escaped *) (String.sub line_in 0 (line_in_len-1)) in
- let http_beg = "POST / HTTP/" in
- let http_beg_l = String.length http_beg in
- if line_in_len > http_beg_l && String.sub line_in 0 http_beg_l = http_beg
- then
- let msg = Aux.input_http_message in_ch in
- if !debug_level > 0 then Printf.printf "Rcvd: %s\n%!" msg;
- ("GDL " ^ msg, None)
- else if line_in = "COMP" then
- let res = Marshal.from_channel in_ch in
- ("COMP", Some res)
- else
- (* We put endlines, encoded by '$', back into the message.
- TODO: perhaps a "better" solution now that HTTP has one? *)
- let line =
- String.concat "\n"
- (Str.split (Str.regexp "\\$") line_in) in
- if !debug_level > 0 then Printf.printf "Rcvd: %s\n%!" line;
- (line, None)
-
-
let req_handle (g_heur, game_modified, state, gdl_transl, playclock) = function
| Aux.Left (Arena.SuggestLocMoves
(loc, timer, effort, _, _, heuristic, advr)) -> (
@@ -193,30 +143,135 @@
("HTTP/1.0 200 OK\r\nContent-type: text/acl\r\nContent-length: "
^ string_of_int msg_len ^ "\r\n\r\n" ^ mov_msg) in
(g_heur, game_modified, state, gdl_transl, playclock), resp
+
+(* --------- LINES PARSING AND FULL REQUEST HANDLING ------------ *)
+
+let rec read_in_line in_ch =
+ let line_in =
+ let rec nonempty () =
+ let line_in = input_line in_ch in
+ if line_in = "" || line_in = "\r" then nonempty ()
+ else line_in in
+ nonempty () in
+ let line_in_len = String.length line_in in
+ (* TODO: who needs escaping? *)
+ let line_in =
+ if line_in.[line_in_len-1] <> '\r' then
+ (* String.escaped *) line_in
+ else
+ (* String.escaped *) (String.sub line_in 0 (line_in_len-1)) in
+ 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)))
+ | None ->
+ if line_in = "COMP" then
+ let res = Marshal.from_channel in_ch in
+ if !debug_level > 0 then Printf.printf "COMP\n%!";
+ ("COMP", Some (Aux.Right res))
+ else
+ (* We put endlines, encoded by '$', back into the message.
+ TODO: perhaps a "better" solution now that HTTP has one? *)
+ let line =
+ String.concat "\n"
+ (Str.split (Str.regexp "\\$") line_in) in
+ 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
- let (line, marshaled) = read_in_line in_ch in
- if line = "COMP" && marshaled <> None then (
- let (f, x) = Aux.unsome marshaled in
- let res = f x in
- Marshal.to_channel out_ch res [Marshal.Closures];
- flush out_ch;
- rstate
- ) else (
- let req = req_of_str line in
- let new_rstate, resp = req_handle rstate req in
+ let report (new_rstate, resp) =
if !debug_level > 0 then (
Printf.printf "Resp-time: %F\n%!" (Unix.gettimeofday() -. time_started);
- print_endline ("\nRepl: " ^ resp ^ "\n");
- );
+ if !debug_level > 1 || String.length resp < 500 then
+ print_endline ("\nRepl: " ^ resp ^ "\n");
+ );
output_string out_ch (resp ^ "\n");
flush out_ch;
- new_rstate
- )
+ new_rstate in
+ match read_in_line in_ch with
+ | (line, Some (Aux.Right (f, x))) when line = "COMP" ->
+ let res = f x in
+ 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, None) ->
+ report (req_handle rstate
+ (Aux.Left (ArenaParser.parse_request Lexer.lex
+ (Lexing.from_string line))))
with
| Parsing.Parse_error ->
Printf.printf "Toss Server: parse error\n%!";
Modified: trunk/Toss/WebClient/Handler.py
===================================================================
--- trunk/Toss/WebClient/Handler.py 2011-05-09 01:19:32 UTC (rev 1434)
+++ trunk/Toss/WebClient/Handler.py 2011-05-09 23:43:28 UTC (rev 1435)
@@ -20,7 +20,7 @@
def open_toss_server (port):
args = [MakeDB.SERVER_FILE,
- "-nogdl", "-s", "localhost", "-p", str(port)]
+ "-s", "localhost", "-p", str(port)]
server_proc = subprocess.Popen(args)
time.sleep (0.1)
return (port)
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
