diff --git a/Makefile b/Makefile index 272cd16..d710995 100644 --- a/Makefile +++ b/Makefile @@ -1,6 +1,10 @@ OCAMLMAKEFILE=OCamlMakefile -SOURCES = util.ml api.ml +SOURCES = util.ml api.mli api.ml \ + namespace.mli namespace.ml \ + fql.mli fql.ml \ + users.mli users.ml \ + dashboard.mli dashboard.ml PREDS = camlp4o PACKS = json-tc.syntax lwt.syntax lwt.unix cohttp RESULT = facebook diff --git a/api.ml b/api.ml index c6f756f..0c86e3c 100644 --- a/api.ml +++ b/api.ml @@ -1,7 +1,7 @@ (* ocaml-facebook - Facebook Platform client API in OCaml - Copyright (C) <2009> David Sheets + Copyright (C) <2009-2010> David Sheets This program is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as @@ -52,9 +52,6 @@ and user = type user_table = (int64, user) Hashtbl.t -let facebook_http = "http://api.facebook.com/restserver.php" -let facebook_https = "https://api.facebook.com/restserver.php" - let users : user_table = Hashtbl.create 10 let application ?(timeout=None) ?cpref key sec domain = @@ -169,6 +166,8 @@ let user app req = else get_user app fbp +let uid user = user.uid + let gen_cookies path user = let make = Http_cookie.make in let serialize = Http_cookie.serialize in @@ -199,88 +198,3 @@ let gen_cookies path user = (fun (n,v) -> serialize (make ~path ~domain n v)) cookies - -(* QUERIES *) - -let std_params user meth params = - let get = [("method", meth); - ("api_key", user.user_app.app_key); - ("v", "1.0")] in - let get = match user.session with None -> get - | Some (k, _) -> ("session_key", k) :: get in - let post = [("call_id", string_of_int user.user_app.seq); - ("format", "JSON")] @ params in - let pmap = AStrMap.into_map StrMap.empty (get @ post) in - let () = user.user_app.seq <- user.user_app.seq + 1 in - (get, ("sig", generate_sig user.user_app pmap) :: post) - -let url_encode = Netencoding.Url.mk_url_encoded_parameters - -module Namespace = -struct - let rec coerce = function - | `B f -> Int64.to_string f - | `D i -> string_of_int i - | `S s -> s - | `List v -> Json_io.string_of_json (json_of_list v) - and json_coerce = function - | `B f -> json_of_float f - | `D i -> json_of_int i - | `S s -> json_of_string s - | `List v -> json_of_list v - and json_of_int i = Json_type.Int i - and json_of_float f = Json_type.Float f - and json_of_string s = Json_type.String s - and json_of_list l = Json_type.Array (List.map json_coerce l) - - let bind_value fn (k, v) = (k, fn v) - - let attempt_post headers body url = - let rec post exnlist = function - | 0 -> fail (Facebook_error ("Cannot connect to Facebook", exnlist)) - | n -> begin try_lwt Http_user_agent.post ~headers ~body url with - | e -> post (e::exnlist) (n - 1) - end - in post [] 3 - - let call_method ns user name params = - let params = List.map (bind_value coerce) params in - let get, post = std_params user ("facebook." ^ ns ^ "." ^ name) params in - let qs = url_encode get in - let headers = [("User-Agent", "ocaml-facebook/0.1")] in - let body = url_encode post in - let url = facebook_http ^ "?" ^ qs in - lwt _, jsons = attempt_post headers body url in - return jsons - - let loadr jsons = - return (Json_io.json_of_string jsons) -end - -module Users = -struct - include Namespace - let call user = call_method "users" user - - let get_info user uids fields = - (call user "getInfo" [("uids", `List uids); - ("fields", `List fields)]) >>= loadr - - let get_standard_info user uids fields = - (call user "getStandardInfo" [("uids", `List uids); - ("fields", `List fields)]) >>= loadr - - (* TODO: Really? Mutate the world for a boolean API call?! *) - let is_app_user user = - (call user "isAppUser" [("uid", `B user.uid)]) - >>= (fun r -> let b = r = "true" in - let () = save_user {user with added=b} in return b) -end - -module Fql = -struct - include Namespace - let call user = call_method "fql" user - - let query user q = call user "query" [("query", `S q)] >>= loadr -end diff --git a/api.mli b/api.mli new file mode 100644 index 0000000..4e64d5b --- /dev/null +++ b/api.mli @@ -0,0 +1,36 @@ +exception Facebook_error of string * exn list +exception Facebook_timeout +exception Facebook_bad_sig + +type application = { + app_cookie_prefix : string option; + app_key : string; + app_sec : string; + app_domain : string; + timeout : float option; + mutable seq : int; +} +and user = { + uid : int64; + user_app : application; + time : float; + session : (string * float) option; + added : bool; + friends : user list; + props : (string * string) list; +} + +val application : + ?timeout:float option -> + ?cpref:string -> string -> string -> string -> application Lwt.t + +val generate_sig : application -> string Map.Make(String).t -> string +val validate_params : + application -> + ?ns:string -> (string * string) list -> string Map.Make(String).t Lwt.t + +val load_user : application -> int64 -> user +val save_user : user -> unit +val user : application -> Cohttp.Http_request.request -> user option Lwt.t +val uid : user -> int64 +val gen_cookies : string -> user -> (string * string) list diff --git a/dashboard.ml b/dashboard.ml new file mode 100644 index 0000000..c7d6743 --- /dev/null +++ b/dashboard.ml @@ -0,0 +1,69 @@ +(* + ocaml-facebook - Facebook Platform client API in OCaml + + Copyright (C) <2010> David Sheets + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Library General Public License as + published by the Free Software Foundation, version 2. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 + USA +*) + +open Lwt +open Api +module J = Json_type.Browse + +let call user = Namespace.call_method "dashboard" user + +let tuple_list kfn vfn json = List.fold_left + (fun al -> function + | k::v::[] -> (kfn k, vfn v)::al + | _ -> al) + [] + (J.list J.array json) + +let uid_of_json json = Int64.of_string (J.string json) + +let get_count user = (call user "getCount" [("uid", `B user.uid)]) >|= J.int + +let multi_get_count = function + | [] -> return [] + | (ux::_) as ul -> let uids = `List (List.map (fun u -> `B u.uid) ul) in + (call ux "multiGetCount" [("uids", uids)]) + >|= (tuple_list uid_of_json J.int) + +let set_count user i = + (call user "setCount" [("uid", `B user.uid); ("count", `D i)]) >|= J.bool + +let multi_set_count = function + | [] -> return [] + | (ux::_) as ul -> let uids = `List (List.map (fun u -> `B u.uid) ul) in + (* yes, this method uses 'ids' instead of 'uids' *) + (call ux "multiSetCount" [("ids", uids)]) + >|= (tuple_list uid_of_json J.bool) + +let increment_count user = + (call user "incrementCount" [("uid", `B user.uid)]) >|= J.bool + +let multi_increment_count = function + | [] -> return [] + | (ux::_) as ul -> let uids = `List (List.map (fun u -> `B u.uid) ul) in + (call ux "multiIncrementCount" [("uids", uids)]) + >|= (tuple_list uid_of_json J.bool) + +let decrement_count user = + (call user "decrementCount" [("uid", `B user.uid)]) >|= J.bool + +let multi_decrement_count = function + | [] -> return [] + | (ux::_) as ul -> let uids = `List (List.map (fun u -> `B u.uid) ul) in + (call ux "multiDecrementCount" [("uids", uids)]) + >|= (tuple_list uid_of_json J.bool) diff --git a/dashboard.mli b/dashboard.mli new file mode 100644 index 0000000..1fbdca6 --- /dev/null +++ b/dashboard.mli @@ -0,0 +1,8 @@ +val get_count : Api.user -> int Lwt.t +val multi_get_count : Api.user list -> (int64 * int) list Lwt.t +val set_count : Api.user -> int -> bool Lwt.t +val multi_set_count : Api.user list -> (int64 * bool) list Lwt.t +val increment_count : Api.user -> bool Lwt.t +val multi_increment_count : Api.user list -> (int64 * bool) list Lwt.t +val decrement_count : Api.user -> bool Lwt.t +val multi_decrement_count : Api.user list -> (int64 * bool) list Lwt.t diff --git a/fql.ml b/fql.ml new file mode 100644 index 0000000..d8863f3 --- /dev/null +++ b/fql.ml @@ -0,0 +1,23 @@ +(* + ocaml-facebook - Facebook Platform client API in OCaml + + Copyright (C) <2010> David Sheets + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Library General Public License as + published by the Free Software Foundation, version 2. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 + USA +*) + +let call user = Namespace.call_method "fql" user + +let query user q = call user "query" [("query", `S q)] diff --git a/fql.mli b/fql.mli new file mode 100644 index 0000000..6c4b170 --- /dev/null +++ b/fql.mli @@ -0,0 +1 @@ +val query : Api.user -> string -> Json_type.t Lwt.t diff --git a/namespace.ml b/namespace.ml new file mode 100644 index 0000000..d18176d --- /dev/null +++ b/namespace.ml @@ -0,0 +1,101 @@ +(* + ocaml-facebook - Facebook Platform client API in OCaml + + Copyright (C) <2010> David Sheets + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Library General Public License as + published by the Free Software Foundation, version 2. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 + USA +*) + +open Printf +open Lwt +open Cohttp +open Api + +module StrMap = Map.Make(String) +module AStrMap = Util.Assoc(StrMap) +module MStrMap = Util.Map(StrMap) +module J = Json_type.Browse + +type fb_data = [ `B of int64 + | `D of int + | `F of float + | `S of string + | `List of fb_data list + ] + +let facebook_http = "http://api.facebook.com/restserver.php" +let facebook_https = "https://api.facebook.com/restserver.php" + +let rec coerce = function + | `B l -> Int64.to_string l + | `D i -> string_of_int i + | `F f -> string_of_float f + | `S s -> s + | `List v -> Json_io.string_of_json (json_of_list v) +and json_coerce = function + | `B l -> json_of_string (Int64.to_string l) + | `D i -> json_of_int i + | `F f -> json_of_float f + | `S s -> json_of_string s + | `List v -> json_of_list v +and json_of_int i = Json_type.Int i +and json_of_float f = Json_type.Float f +and json_of_string s = Json_type.String s +and json_of_list l = Json_type.Array (List.map json_coerce l) + +let bind_value fn (k, v) = (k, fn v) + +let std_params user meth params = + let get = [("method", meth); + ("api_key", user.user_app.app_key); + ("v", "1.0")] in + let get = match user.session with None -> get + | Some (k, _) -> ("session_key", k) :: get in + let post = [("call_id", string_of_int user.user_app.seq); + ("format", "JSON")] @ params in + let pmap = AStrMap.into_map StrMap.empty (get @ post) in + let () = user.user_app.seq <- user.user_app.seq + 1 in + (get, ("sig", generate_sig user.user_app pmap) :: post) + +let url_encode = Netencoding.Url.mk_url_encoded_parameters + +let attempt_post headers body url = + let rec post exnlist = function + | 0 -> fail (Facebook_error ("Cannot connect to Facebook", exnlist)) + | n -> begin try_lwt Http_user_agent.post ~headers ~body url with + | e -> post (e::exnlist) (n - 1) + end + in post [] 3 + +let facebook_error meth user params jo = + let code = J.int (List.assoc "error_code" jo) in + let msg = J.string (List.assoc "error_msg" jo) in + fail (Facebook_error (sprintf "Error %d in %s : %s" code meth msg, [])) + +let call_method ns user name params = + let params = List.map (bind_value coerce) params in + let meth = "facebook." ^ ns ^ "." ^ name in + let get, post = std_params user meth params in + let qs = url_encode get in + let headers = [("User-Agent", "ocaml-facebook/0.1")] in + let body = url_encode post in + let url = facebook_http ^ "?" ^ qs in + lwt _, jss = attempt_post headers body url in + let json = Json_io.json_of_string ~recursive:true ~big_int_mode:true jss in + let fberr = try let jo = J.objekt json in if List.mem_assoc "error_response" jo + then Some jo else None + with Json_type.Json_error _ -> None + in match fberr with Some jo -> facebook_error meth user params jo + | None -> return json diff --git a/namespace.mli b/namespace.mli new file mode 100644 index 0000000..fafa605 --- /dev/null +++ b/namespace.mli @@ -0,0 +1,8 @@ +type fb_data = + [ `B of int64 + | `D of int + | `F of float + | `List of fb_data list + | `S of string ] + +val call_method : string -> Api.user -> string -> (string * fb_data) list -> Json_type.t Lwt.t diff --git a/users.ml b/users.ml new file mode 100644 index 0000000..89273ae --- /dev/null +++ b/users.ml @@ -0,0 +1,38 @@ +(* + ocaml-facebook - Facebook Platform client API in OCaml + + Copyright (C) <2010> David Sheets + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Library General Public License as + published by the Free Software Foundation, version 2. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 + USA +*) + +open Lwt +open Api +module J = Json_type.Browse + +let call user = Namespace.call_method "users" user + +let get_info user users fields = call user "getInfo" + [("uids", `List (List.map (fun u -> `B u.uid) users)); + ("fields", `List fields)] + +let get_standard_info user users fields = call user "getStandardInfo" + [("uids", `List (List.map (fun u -> `B u.uid) users)); + ("fields", `List fields)] + +(* TODO: Really? Mutate the world for a boolean API call?! *) +let is_app_user user = + lwt b = (call user "isAppUser" [("uid", `B user.uid)]) >|= J.bool + in save_user {user with added=b}; return b diff --git a/users.mli b/users.mli new file mode 100644 index 0000000..bf9974b --- /dev/null +++ b/users.mli @@ -0,0 +1,5 @@ +val get_info : + Api.user -> Api.user list -> Namespace.fb_data list -> Json_type.t Lwt.t +val get_standard_info : + Api.user -> Api.user list -> Namespace.fb_data list -> Json_type.t Lwt.t +val is_app_user : Api.user -> bool Lwt.t