Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 206 lines (180 sloc) 6.619 kb
b7f1726 rough cut
David Sheets authored
1 open Printf
2 open Lwt
3 open Cohttp
4
5 let ($) = Util.Function.($)
6
7 module StrMap = Map.Make(String)
8 module AStrMap = Util.Assoc(StrMap)
9 module MStrMap = Util.Map(StrMap)
10
11 exception Timeout
12 exception Bad_sig
13
14 type application =
15 { app_db : string;
16 app_key : string;
17 app_sec : string;
18 app_domain : string;
19 timeout : float option;
20 mutable seq : int
21 }
22 and user =
23 { uid : int64;
24 user_app : application;
25 session : (string * int32) option;
26 added : bool;
27 friends : user list;
28 props : (string * string) list
29 }
30 with orm(
31 unique: user<uid>, application<app_key>;
32 debug: all;
33 dot: "facebook.dot"
34 )
35
36 let facebook_http = "http://api.facebook.com/restserver.php"
37 let facebook_https = "https://api.facebook.com/restserver.php"
38
39 let application ?(timeout=None) dbn key sec domain =
40 lwt db = Util.Database.attach ~rm:false application_init dbn in
41 let save a = let () = application_save db a in a in
42 match application_get ~app_key:(`Eq key) db with
43 | [] -> return (save { app_db = dbn; app_key = key; app_sec = sec;
44 app_domain = domain; timeout = timeout; seq = 0 })
45 | a::_ -> return (save { a with app_db = dbn })
46
47 let generate_sig { app_sec = sec } pmap =
48 let meat = StrMap.fold (fun k v p -> sprintf "%s%s=%s" p k v) pmap "" in
49 Digest.to_hex (Digest.string (meat ^ sec))
50
51 (* validate an assoc of params against a facebook signature *)
52 let validate_params app ?(ns="fb_sig") params =
53 let pref = ns ^ "_" in
54 let prefl = String.length pref in
55 let is_ns_param (k, _) = Util.String.begins pref k in
56 let fbparams, others = List.partition is_ns_param params in
57 let fbparams = List.map (fun (k, v) -> (Util.String.from k prefl, v)) fbparams in
58 let fbm = AStrMap.into_map StrMap.empty fbparams in
59 let check_timeout fbm =
60 let fbtime = MStrMap.findo ["time"] fbm in
61 let now = Unix.time () in
62 match app.timeout, fbtime with
63 | Some tm, Some time when (now -. (float_of_string time)) > tm -> false
64 | Some tm, None -> false
65 | _, _ -> true
66 in
67 let check_sig pmap sign = sign = (generate_sig app pmap) in
68 match AStrMap.findo [ns] others with
69 | Some v ->
70 if check_timeout fbm then
71 if check_sig fbm v then
72 return fbm
73 else fail Bad_sig
74 else fail Timeout
75 | None ->
76 return StrMap.empty
77
78 let load_user app db uid =
79 match user_get ~uid:(`Eq uid) db with
80 | [] -> { uid = uid;
81 user_app = app;
82 session = None;
83 friends = [];
84 added = false;
85 props = []
86 }
87 | u::_ -> u
88
89 let get_user app fbm =
90 let module M = MStrMap in
91 let module O = Util.Option in
92 let (>>=) = O.(>>=) in
93 let return = O.return in
94 let added = (M.findo ["added"] fbm) >>= (return $ ((=) 1) $ int_of_string) in
95 match (M.findo ["user"; "profile_user"; "canvas_user"] fbm)
96 >>= (return $ Int64.of_string) with
97 | Some uid ->
98 let session = M.findo ["session_key"; "profile_session_key"] fbm in
99 let expiry = (M.findo ["expires"] fbm) >>= (return $ Int32.of_string) in
100 lwt db = Util.Database.attach ~rm:false user_init app.app_db in
101 let user = { load_user app db uid with
102 session = session >>= (fun s ->
103 expiry
104 >>= (return $ fun e -> (s, e)));
105 added = match added with None -> false | Some b -> b
106 } in
107 let save u = let () = user_save db u in u in
108 Lwt.return (Some (save user))
109 | None -> Lwt.return None
110
111 (* Does not look at cookies *)
112 let user app req =
113 let post = Http_request.params_post req in
114 lwt fbp = validate_params app post in
115 if StrMap.is_empty fbp then
116 lwt fbg = validate_params app (Http_request.params_get req) in
117 lwt fbp = validate_params app ~ns:"fb_post_sig" post in
118 let fbm = MStrMap.merge fbg fbp in
119 get_user app fbm
120 else
121 get_user app fbp
122
123 let gen_cookie user =
124 let app = user.user_app in
125 let cookie = [("user", Int64.to_string user.uid)] in
126 let cookie = match user.session with
127 | Some (sess_key, expiry) ->
128 ("session_key", sess_key) :: ("expires", Int32.to_string expiry) :: cookie
129 | None -> cookie in
130 let cm = AStrMap.into_map StrMap.empty cookie in
131 let cookie = List.map (fun (n,v) -> (app.app_key ^ "_" ^ n, v)) cookie in
132 let cookie = match user.session with
133 | Some (_, expiry) -> ("expires", Int32.to_string expiry) :: cookie
134 | None -> cookie in
135 let cookie = [(app.app_key, generate_sig app cm);
136 ("domain", app.app_domain)] @ cookie in
137 String.concat "; " (List.map (fun (n,v) -> n ^ "=" ^ v) cookie)
138
139 (* QUERIES *)
140
141 let std_params user meth params =
142 let get = [("method", meth);
143 ("api_key", user.user_app.app_key);
144 ("v", "1.0")] in
145 let get = match user.session with None -> get
146 | Some (k, _) -> ("session_key", k) :: get in
147 let post = [("call_id", string_of_int user.user_app.seq);
148 ("format", "JSON")] @ params in
149 let pmap = AStrMap.into_map StrMap.empty (get @ post) in
150 let () = user.user_app.seq <- user.user_app.seq + 1 in
151 (get, ("sig", generate_sig user.user_app pmap) :: post)
152
153 let url_encode = Netencoding.Url.mk_url_encoded_parameters
154
155 module Namespace =
156 struct
157 let rec coerce = function
158 | `D i -> string_of_int i
159 | `S s -> s
160 | `List v -> Json_io.string_of_json (json_of_list v)
161 and json_coerce = function
162 | `D i -> json_of_int i
163 | `S s -> json_of_string s
164 | `List v -> json_of_list v
165 and json_of_int i = Json_type.Int i
166 and json_of_string s = Json_type.String s
167 and json_of_list l = Json_type.Array (List.map json_coerce l)
168
169 let bind_value fn (k, v) = (k, fn v)
170
171 let call_method ns user name params =
172 let params = List.map (bind_value coerce) params in
173 let get, post = std_params user ("facebook." ^ ns ^ "." ^ name) params in
174 let qs = url_encode get in
175 let headers = [("User-Agent", "ocaml-facebook/0.1")] in
176 let body = url_encode post in
177 let url = facebook_http ^ "?" ^ qs in
178 lwt _, jsons = Http_user_agent.post ~headers ~body url in
179 return (Json_io.json_of_string jsons)
180 end
181
182 module Users =
183 struct
184 include Namespace
185 let call user = call_method "users" user
186
187 let loadr json = return json
188
189 let get_info user uids fields =
190 (call user "getInfo" [("uids", `List uids);
191 ("fields", `List fields)]) >>= loadr
192
193 let get_standard_info user uids fields =
194 (call user "getStandardInfo" [("uids", `List uids);
195 ("fields", `List fields)]) >>= loadr
196 end
197
198 module Fql =
199 struct
200 include Namespace
201 let call user = call_method "fql" user
202
203 let query user q = call user "query" [("query", `S q)]
204
205 end
Something went wrong with that request. Please try again.