diff options
author | Yorhel <git@yorhel.nl> | 2010-12-04 14:55:05 +0100 |
---|---|---|
committer | Yorhel <git@yorhel.nl> | 2010-12-04 14:55:05 +0100 |
commit | 26dee6703f180bd471fca367fb07a7e826be13d8 (patch) | |
tree | 4d826b8094acb2c53f3c27d9a71449861645c375 |
Initial commit
-rw-r--r-- | .gitignore | 2 | ||||
-rw-r--r-- | COPYING | 20 | ||||
-rw-r--r-- | Makefile | 11 | ||||
-rw-r--r-- | README | 26 | ||||
-rw-r--r-- | gui.ml | 91 | ||||
-rw-r--r-- | json.mll | 266 | ||||
-rw-r--r-- | main.ml | 62 | ||||
-rw-r--r-- | vndbApi.ml | 160 |
8 files changed, 638 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..442898d --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +_build/ +main.native @@ -0,0 +1,20 @@ +Copyright (c) 2010 Yoran Heling + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..aafb003 --- /dev/null +++ b/Makefile @@ -0,0 +1,11 @@ + +run: all + ./main.native + +all: + ocamlbuild -cflags -I,+lablgtk2 -lflags -I,+lablgtk2 -libs unix,str,lablgtk main.native + strip --strip-unneeded main.native + +clean: + ocamlbuild -clean + @@ -0,0 +1,26 @@ +Serika +------ + +DESCRIPTION + + Serika is an experimental GTK+ client of the VNDB.org API. It has currently + no uses other than to serve as an example on how to use the VNDB API and to + test, debug and query the API. + + +REQUIREMENTS + + Run-time: + GTK2 (and possibly some related libraries) + + Compile-time: + OCaml (only tested on 3.12) + LablGTK2 (only tested on 2.14.1) + + +CONTACT + + Yorhel @ #vndb @ irc.synirc.net + http://vndb.org/ + contact@vndb.org + @@ -0,0 +1,91 @@ + +type debuglog_type = [`read | `write | `status] + +class mainwin () = + (* main window layout *) + let g_win = GWindow.window ~wm_name:"Serika" ~wm_class:"serika" ~position:`CENTER () in + let _ = g_win#connect#destroy GMain.Main.quit in + let _ = g_win#set_default_width 640 and _ = g_win#set_default_height 480 in + let g_vbox = GPack.vbox ~packing:g_win#add () in + let g_tabs = GPack.notebook ~packing:g_vbox#add () in + + (* debug tab *) + let g_debug_tbl = GPack.table ~rows:2 ~columns:2 () in + let g_debug_scroll = GBin.scrolled_window ~vpolicy:`ALWAYS ~hpolicy:`AUTOMATIC ~packing:(g_debug_tbl#attach ~left:0 ~top:0 ~right:2 ~expand:`BOTH) () in + let g_debug = GText.view ~editable:false ~wrap_mode:`CHAR ~packing:g_debug_scroll#add () in + let g_debug_cmd = GEdit.entry ~activates_default:true ~packing:(g_debug_tbl#attach ~left:0 ~top:1 ~expand:`X) () in + let g_debug_send = GButton.button ~label:"_Send command" ~use_mnemonic:true ~packing:(g_debug_tbl#attach ~left:1 ~top:1 ~expand:`NONE) () in + let _ = g_tabs#append_page ~tab_label:((GMisc.label ~text:"Debug" ())#coerce) g_debug_tbl#coerce in + let _ = g_debug_cmd#connect#activate (fun () -> ignore (g_debug_send#misc#activate ())) in + + (* status bar *) + let g_status = GMisc.statusbar ~packing:(g_vbox#pack ~expand:false) () in + let g_statuscontext = g_status#new_context ~name:"Meh" in + let g_bandwidth = GMisc.label ~packing:(g_status#pack ~from:`END ~expand:false) ~width:70 ~text:"0.0 kB" () in + let g_cmd_count = GMisc.label ~packing:(g_status#pack ~from:`END ~expand:false) ~width:25 ~text:"0" () in + + (* coloring and marking for the debug textview *) + let _ = g_debug#buffer#create_tag ~name:"read" [`FOREGROUND "#cc6666"] in + let _ = g_debug#buffer#create_tag ~name:"write" [`FOREGROUND "#6666cc"] in + let _ = g_debug#buffer#create_tag ~name:"prefix" [`WEIGHT `LIGHT] in + let _ = g_debug#buffer#create_mark ~name:"end" ~left_gravity:false g_debug#buffer#end_iter in + + (* the object *) + object (self) + val mutable bandwidth = 0 + val mutable cmd_count = 0 + val mutable laststatusmsg = g_statuscontext#push "Welcome to Serika!" + + method show = g_win#show () + + method set_debug_docmd f = + ignore (g_debug_send#connect#clicked (fun () -> + f (g_debug_cmd#text) + )) + + method statusmsg str = + let msg = g_statuscontext#push str in + g_statuscontext#remove laststatusmsg; + laststatusmsg <- msg; + self#add_debuglog `status str + + method add_bandwidth s = + bandwidth <- bandwidth+s; + g_bandwidth#set_text (Printf.sprintf "%.1f kB" ((float bandwidth) /. 1024.0)) + + method incr_cmd_count = + cmd_count <- cmd_count+1; + g_cmd_count#set_text (string_of_int cmd_count) + + method add_debuglog (t : debuglog_type) str = + let tm = Unix.localtime (Unix.time ()) in + let time = Printf.sprintf "[%02d:%02d:%02d] " tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec in + let tags, prefix = match t with + | `read -> (["read"], "< ") + | `write -> (["write"], "> ") + | `status -> ([], "= ") in + let buf = g_debug#buffer in + buf#insert ~iter:buf#end_iter ~tag_names:["prefix"] (time ^ prefix); + buf#insert ~iter:buf#end_iter ~tag_names:tags str; + buf#insert ~iter:buf#end_iter "\n"; + g_debug#scroll_mark_onscreen (`NAME "end") + + method set_throttled sec (cb : (unit -> unit)) = + let togo = ref sec in + g_debug_send#misc#set_sensitive false; + let secfunc () = + togo := !togo - 1; + if !togo < 1 then ( + g_debug_send#misc#set_sensitive true; + cb (); + false + ) else ( + g_statuscontext#flash ~delay:1000 ("Throttled. Waiting " + ^(string_of_int !togo)^" seconds before continuing..."); + true + ) + in + ignore (GMain.Timeout.add ~ms:1000 ~callback:secfunc) + + end + diff --git a/json.mll b/json.mll new file mode 100644 index 0000000..184c1c0 --- /dev/null +++ b/json.mll @@ -0,0 +1,266 @@ +(* Very minimal standard-compliant JSON parser/generator, because the currently + * available JSON libraries for OCaml try to do too much and have too many + * dependencies. + * - The aim of this library is to be small rather than fast. + * - Error detecting is correct. Error reporting, however, is rather minimal. + * (Some portions and ideas of this code were borrowed from yojson) + *) + + + + +(* H E A D E R *) + +{ + +(* Primary JSON data structure. Integers and numbers are left as strings in + * order to avoid losing data to precision or overflows (and int<>string<>float + * conversion really isn't that hard to do in application code) *) +type json = + Object of (string * json) list + | Array of json list + | Bool of bool + | Null + | String of string + | Int of string + | Number of string + +exception JSON_Error +exception JSON_Array_End +exception JSON_Object_End +exception JSON_Incorrect_Type + + +(* Based on common.ml:utf8_of_bytes from yojson, although this one is less efficient *) +let utf8_of_bytes a b c d = + let i = (a lsl 12) lor (b lsl 8) lor (c lsl 4) lor d in + let str = "000" in + if i < 0x80 then ( + str.[0] <- char_of_int i; + String.sub str 0 1 + ) else if i < 0x800 then ( + str.[0] <- char_of_int (0xc0 lor ((i lsr 6) land 0x1f)); + str.[1] <- char_of_int (0x80 lor (i land 0x3f)); + String.sub str 0 2 + ) else ( + str.[0] <- char_of_int (0xe0 lor ((i lsr 12) land 0xf)); + str.[1] <- char_of_int (0x80 lor ((i lsr 6) land 0x3f)); + str.[2] <- char_of_int (0x80 lor (i land 0x3f)); + String.sub str 0 3 + ) + +(* from yojosn -> read.mll:hex *) +let int_of_hex c = + match c with + | '0'..'9' -> int_of_char c - int_of_char '0' + | 'a'..'f' -> int_of_char c - int_of_char 'a' + 10 + | 'A'..'F' -> int_of_char c - int_of_char 'A' + 10 + | _ -> assert false + +(* 0-255 -> \u00(00-ff) (this function isn't the reverse of int_of_hex, but oh well) *) +let hex_of_int i = + let s = "\\u0000" in + let a = i lsr 4 in + let b = i land 0x0f in + s.[4] <- char_of_int ((if a < 10 then int_of_char '0' else int_of_char 'a' - 10) + a); + s.[5] <- char_of_int ((if b < 10 then int_of_char '0' else int_of_char 'a' - 10) + b); + s + + +} + + + + +(* D E F I N I T I O N S *) + +let ws = [' ' '\t' '\n' '\r'] +let digit = ['0'-'9'] +let digit1 = ['1'-'9'] +let integer = '-'? ( digit | ( digit1 digit+ ) ) +let frac = '.' digit+ +let exp = ['e' 'E'] ['+' '-']? +let number = (integer frac) | (integer exp) | (integer frac exp) +let hex = ['0'-'9' 'a'-'f' 'A'-'F'] +let strlit = [^ '\000'-'\031' '"' '\\'] + + + + +(* R U L E S *) + +rule json_val = parse + | ws+ { json_val lexbuf } + | "true" { Bool true } + | "false" { Bool false } + | "null" { Null } + | integer as i { Int i } + | number as n { Number n } + | '"' { String (json_string "" lexbuf) } + | ']' { raise JSON_Array_End } + | '}' { raise JSON_Object_End } + | '[' { + let rec element () = + try ( + json_sep lexbuf; + let v = try json_val lexbuf with JSON_Array_End -> raise JSON_Error in + v :: (element ()) + ) with JSON_Array_End -> [] in + Array ( + try + let v = json_val lexbuf in + v :: (element ()) + with JSON_Array_End -> []) + } + | '{' { + let rec pair () = + try ( + json_sep lexbuf; + let name = try json_val lexbuf with JSON_Object_End -> raise JSON_Error in + let str = match name with + | String x -> x + | _ -> raise JSON_Error + in + json_valsep lexbuf; + let value = try json_val lexbuf with JSON_Object_End -> raise JSON_Error in + (str, value) :: (pair ()) + ) with JSON_Object_End -> [] in + Object ( + try + let name = json_val lexbuf in + let str = match name with + | String x -> x + | _ -> raise JSON_Error + in + json_valsep lexbuf; + let value = try json_val lexbuf with JSON_Object_End -> raise JSON_Error in + (str, value) :: (pair ()) + with JSON_Object_End -> []) + } + | _ + | eof { raise JSON_Error } + +and json_sep = parse + | ',' { () } + | ']' { raise JSON_Array_End } + | '}' { raise JSON_Object_End } + | ws+ { json_sep lexbuf } + | _ + | eof { raise JSON_Error } + +and json_valsep = parse + | ':' { () } + | '}' { raise JSON_Object_End } + | ws+ { json_valsep lexbuf } + | _ + | eof { raise JSON_Error } + +and json_string str = parse + | "\\\"" { json_string (str ^ "\"") lexbuf } + | "\\\\" { json_string (str ^ "\\") lexbuf } + | "\\/" { json_string (str ^ "/") lexbuf } + | "\\b" { json_string (str ^ "\b") lexbuf } + | "\\f" { json_string (str ^ "\x0c") lexbuf } + | "\\n" { json_string (str ^ "\n") lexbuf } + | "\\r" { json_string (str ^ "\r") lexbuf } + | "\\t" { json_string (str ^ "\t") lexbuf } + | "\\u" (hex as a) (hex as b) (hex as c) (hex as d) { + json_string (str ^ (utf8_of_bytes (int_of_hex a) (int_of_hex b) (int_of_hex c) (int_of_hex d))) lexbuf + } + | strlit+ as s { json_string (str ^ s) lexbuf } + | '"' { str } + | _ + | eof { raise JSON_Error } + +and json_string_write out = parse + | "\\" { out "\\\\"; json_string_write out lexbuf } + | "\"" { out "\\\""; json_string_write out lexbuf } + | "\b" { out "\\b"; json_string_write out lexbuf } + | "\x0c" { out "\\f"; json_string_write out lexbuf } + | "\n" { out "\\n"; json_string_write out lexbuf } + | "\r" { out "\\r"; json_string_write out lexbuf } + | "\t" { out "\\t"; json_string_write out lexbuf } + | [^ '\\' '"' '\x00'-'\x1F' '\x7F' ]+ as s { out s; json_string_write out lexbuf } + | [ '\x00'-'\x1F' '\x7F' ] as c { out (hex_of_int (int_of_char c)); json_string_write out lexbuf } + | eof { () } + + + +(* F O O T E R *) + +{ + +let json_of_string str = json_val (Lexing.from_string str) +let json_of_channel ch = json_val (Lexing.from_channel ch) +let json_of_function f = json_val (Lexing.from_function f) + +let json_out_str out str = + out "\""; + json_string_write out (Lexing.from_string str); + out "\"" + +let rec json_gen out obj = + match obj with + | Null -> out "null" + | Bool false -> out "false" + | Bool true -> out "true" + | Int x + | Number x -> out x + | String x -> json_out_str out x + | Array l -> ( + out "["; + let i = ref false in + List.iter (fun x -> + (match !i with true -> out "," | false -> i := true); + json_gen out x + ) l; + out "]" + ) + | Object l -> ( + out "{"; + let i = ref false in + List.iter (fun (n,v) -> + (match !i with true -> out "," | false -> i := true); + json_out_str out n; + out ":"; + json_gen out v + ) l; + out "}" + ) + +let string_of_json obj = + let str = ref "" in + json_gen (fun s -> str := !str ^ s) obj; + !str + + +(* convenience functions *) +let get_string = function | String x -> x | _ -> raise JSON_Incorrect_Type +let get_bool = function | Bool x -> x | _ -> raise JSON_Incorrect_Type +let get_int = function | Int x -> x | _ -> raise JSON_Incorrect_Type +let get_number = function | Number x -> x | _ -> raise JSON_Incorrect_Type +let get_array = function | Array x -> x | _ -> raise JSON_Incorrect_Type +let get_object = function | Object x -> x | _ -> raise JSON_Incorrect_Type +let get_value obj key = + match obj with + | Object l -> let _,v = List.find (fun (n,_) -> n = key) l in v + | _ -> raise JSON_Incorrect_Type + + +} + + + + + +(* Testing stuff... + +#load "_build/json.cmo";; +open Json;; +get_bool;; + +let obj = json_of_string "{\"num\":1,\"more\":false,\"items\":[{\"language\":\"ja\",\"original\":null,\"name\":\"Studi\\u007Fo e.go!\",\"type\":\"co\",\"id\":17}]}";; +string_of_json obj;; + +*) + @@ -0,0 +1,62 @@ + +(* blocking pollfunc, useful for testing the vndbApi outside of GTK * +let pollfunc sock read cb = + let _,_,_ = Unix.select + (if read then [sock] else []) + (if read then [] else [sock]) + [] (-.1.0) in + cb ();; +*) + + +let _ = ignore (GtkMain.Main.init ()) +let win = new Gui.mainwin () +let api = new VndbApi.connection + (fun sock read cb -> + ignore (GMain.Io.add_watch ~cond:[if read then `IN else `OUT] + ~callback:(fun _ -> cb (); false) (Glib.Io.channel_of_descr sock))) + (fun sec cb -> win#set_throttled (sec+5) cb) + + +let debugline sent str = + win#add_debuglog (if sent then `write else `read) str; + (Str.replace_first (Str.regexp "\\(\"password\"[\r\n\t ]*:[\r\n\t ]*\"\\)[^\"]+\"") "\\1<secret>\"" str); + win#add_bandwidth ((String.length str)+1); + if not sent then win#incr_cmd_count + + +let apiconnected ip port = + win#statusmsg ("Connected to " ^ (Unix.string_of_inet_addr ip) ^ ":" ^ (string_of_int port)); + api#login "user" "pass" (fun r -> + match r with + | VndbApi.ROK -> win#statusmsg "Login successful." + | VndbApi.RError ("auth", msg, _) -> win#statusmsg ("Login failed: "^msg) + | _ -> win#statusmsg "Login failed :(" + ) + + +let _ = + win#show; + win#statusmsg "Welcome to the Serika Testing Grounds!"; + + api#set_linefunc (Some debugline); + api#connect apiconnected (fun _ _ msg -> + print_endline ("Connection failed: "^msg); + exit 1 + ); + + win#set_debug_docmd (fun str -> + win#statusmsg "Executing custom command..."; + api#addcmd str (fun r -> + win#statusmsg "Custom command finished."; + match r with + | VndbApi.RError _ -> + win#add_debuglog `status ("Server replied with an error. You may want "^ + "to check http://vndb.org/d11 for information on the available commands "^ + "and error messages.") + | _ -> () + ) + ); + + GMain.Main.main () + diff --git a/vndbApi.ml b/vndbApi.ml new file mode 100644 index 0000000..dac59d0 --- /dev/null +++ b/vndbApi.ml @@ -0,0 +1,160 @@ + +open Unix + + +type reply = + RInvalid of string (* unable to parse reply for some reason (string=raw reply) *) + | ROK + | RResults of (int * bool * Json.json list) (* num, more, items *) + | RError of (string * string * Json.json) (* id, msg, json obj *) + + +class connection + (pollfunc : file_descr -> bool -> (unit -> unit) -> unit) + (waitfunc : int -> (unit -> unit) -> unit) + = object (self) + val mutable s_sock = (None : file_descr option) (* None when disconnected *) + val mutable s_host = "beta.vndb.org" + val mutable s_port = 19534 + val mutable s_addr = (None : inet_addr option) + val mutable linefunc = (None : (bool -> string -> unit) option) + val cmd_queue = (Queue.create () : (string * (reply -> unit)) Queue.t) + val mutable cmd_running = false + + + method get_host = s_host + method set_host h = s_host <- h + method get_port = s_port + method set_port p = s_port <- p + method get_addr = s_addr + method set_linefunc f = linefunc <- f + method connected = match s_sock with None -> false | Some _ -> true + + + method private parsereply str = + try + (* space and newline are always ignored with scanf, so no need to check + * for that. (this parser is rather lazy, and may accept incorrect input) *) + let name, value = + Scanf.sscanf str "%[\r\t] %[a-z] %[\r\t] %[^\004]" (fun _ a _ b -> (a,b)) in + match name with + | "ok" -> ROK + | "error" -> + let obj = Json.json_of_string value in + RError ( + Json.get_string (Json.get_value obj "id"), + Json.get_string (Json.get_value obj "msg"), + obj + ) + | "results" -> + let obj = Json.json_of_string value in + RResults ( + int_of_string (Json.get_int (Json.get_value obj "num")), + Json.get_bool (Json.get_value obj "more"), + Json.get_array (Json.get_value obj "items") + ) + | _ -> raise (Failure "Incorrect reply code") + with _ -> RInvalid str + (* the above try .. throws away any info on why it was invalid. but oh well, + * it's not like the server will send invalid data anytime soon anyway *) + + + method private docmd () = + if (not cmd_running && not (Queue.is_empty cmd_queue) && s_sock <> None) then ( + cmd_running <- true; + let cmd, recvcb = Queue.peek cmd_queue in + let s = match s_sock with None -> assert false | Some x -> x in + let reply = ref "" in + let buf = String.create 8192 in + let finish () = + reply := String.sub !reply 0 (String.rindex !reply '\004'); + (match linefunc with None -> () | Some f -> f false !reply); + let preply = self#parsereply !reply in + match preply with + (* Oops! throttled error, let's wait a few seconds and try again *) + | RError ("throttled", _, obj) -> ( + let wait = match Json.get_value obj "minwait" with + | Json.Int i -> int_of_string i + | Json.Number n -> int_of_float (ceil (float_of_string n)) + | _ -> assert false in + waitfunc wait (fun () -> + cmd_running <- false; + self#docmd () + )) + (* Not throttled, so consider this command as finished *) + | _ -> + ignore (Queue.pop cmd_queue); + self#docmd (); + recvcb preply + in + let rec dorecv () = + let cnt = recv s buf 0 (String.length buf) [] in + reply := !reply ^ (String.sub buf 0 cnt); + match String.contains !reply '\004' with + | true -> finish () + | false -> pollfunc s true dorecv + in + let dosend () = + (* assumes the command can be sent with a single call *) + let _ = send s + (cmd ^ (String.make 1 (char_of_int 4))) + 0 (String.length cmd + 1) [] in + match linefunc with None -> () | Some f -> f true cmd; + pollfunc s true dorecv + in + pollfunc s false dosend + ) + + + method addcmd cmd recvcb = + Queue.push (cmd, recvcb) cmd_queue; + self#docmd () + + + (* TODO: keep monitoring connection after successful connect *) + method connect cf ff = + (* get IP (blocks!) *) + let ip = match s_addr with + | Some x -> x + | None -> (gethostbyname s_host).h_addr_list.(0) in + (* create socket *) + let s = socket PF_INET SOCK_STREAM 0 in + (* and connect *) + let success () = + clear_nonblock s; + s_sock <- Some s; + s_addr <- Some ip; + cf ip s_port in + let failure a b c = + close s; + ff a b c in + set_nonblock s; + try + ignore (connect s (ADDR_INET (ip, s_port))); + (* no error? assume this was a successfull blocking connect *) + success () + (* non-blocking connect, poll for the result *) + with Unix_error (EINPROGRESS, _, _) -> + pollfunc s false (fun () -> + clear_nonblock s; + match getsockopt_error s with + | None -> success () + | Some e -> failure e "connect" (error_message e) + ) + (* blocking connect, but failed *) + | Unix_error (a, b, c) -> failure a b c + + + method login user pass recvcb = + let o = Json.Object [ + ("protocol", Json.Int "1"); + ("client", Json.String "Serika"); + ("clientver", Json.Number "0.1"); + ("username", Json.String user); + ("password", Json.String pass) + ] in + self#addcmd ("login " ^ (Json.string_of_json o)) recvcb + +end + + |