summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.gitignore2
-rw-r--r--COPYING20
-rw-r--r--Makefile11
-rw-r--r--README26
-rw-r--r--gui.ml91
-rw-r--r--json.mll266
-rw-r--r--main.ml62
-rw-r--r--vndbApi.ml160
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
diff --git a/COPYING b/COPYING
new file mode 100644
index 0000000..4c931dd
--- /dev/null
+++ b/COPYING
@@ -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
+
diff --git a/README b/README
new file mode 100644
index 0000000..d581ab1
--- /dev/null
+++ b/README
@@ -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
+
diff --git a/gui.ml b/gui.ml
new file mode 100644
index 0000000..97063eb
--- /dev/null
+++ b/gui.ml
@@ -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;;
+
+*)
+
diff --git a/main.ml b/main.ml
new file mode 100644
index 0000000..6bb5313
--- /dev/null
+++ b/main.ml
@@ -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
+
+