summaryrefslogtreecommitdiff
path: root/vndbApi.ml
diff options
context:
space:
mode:
authorYorhel <git@yorhel.nl>2010-12-04 14:55:05 +0100
committerYorhel <git@yorhel.nl>2010-12-04 14:55:05 +0100
commit26dee6703f180bd471fca367fb07a7e826be13d8 (patch)
tree4d826b8094acb2c53f3c27d9a71449861645c375 /vndbApi.ml
Initial commit
Diffstat (limited to 'vndbApi.ml')
-rw-r--r--vndbApi.ml160
1 files changed, 160 insertions, 0 deletions
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
+
+