(* Copyright (c) 2010-2011 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. *) 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 *) type user = Anonymous | User of (string * string) 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 mutable disconnectfunc = (None : (unit -> 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; s_addr <- None method get_port = s_port method set_port p = s_port <- p method get_addr = s_addr method set_linefunc f = linefunc <- f method set_disconnectfunc f = disconnectfunc <- 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); cmd_running <- false; self#docmd (); recvcb preply in let rec dorecv () = let cnt = recv s buf 0 (String.length buf) [] in if cnt == 0 then self#disconnect else ( 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 cnt = send s (cmd ^ (String.make 1 (char_of_int 4))) 0 (String.length cmd + 1) [] in if cnt == 0 then self#disconnect else ( 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 disconnect = (* we'll have to clear the comamnd queue when disconnected, since we need to * be able to issue the login command the first thing after a reconnect... * It might be an idea to either special-case the login command or call all * registered callback functions with an error. * Behaviour is currently undefined when disconnect is called while a * command is being handled. *) Queue.clear cmd_queue; cmd_running <- false; match s_sock with None -> () | Some s -> close s; s_sock <- None; match disconnectfunc with None -> () | Some f -> f () method login user recvcb = let cr = match user with | Anonymous -> [] | User (n, p) -> [ ("username", Json.String n); ("password", Json.String p) ] in let o = Json.Object (cr @ [ ("protocol", Json.Int "1"); ("client", Json.String "Serika"); ("clientver", Json.Number "0.1") ]) in self#addcmd ("login " ^ (Json.string_of_json o)) recvcb end