Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 240 lines (209 sloc) 7.739 kb
f933817 LGPL licensing
David Sheets authored
1 (*
2 ocaml-facebook - Facebook Platform client API in OCaml
3
4 Copyright (C) <2009> David Sheets <sheets@alum.mit.edu>
5
6 This program is free software; you can redistribute it and/or modify
7 it under the terms of the GNU Library General Public License as
8 published by the Free Software Foundation, version 2.
9
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 GNU Library General Public License for more details.
14
15 You should have received a copy of the GNU Library General Public
16 License along with this program; if not, write to the Free Software
17 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
18 USA
19 *)
20
b7f1726 rough cut
David Sheets authored
21 open Printf
22 open Lwt
23 open Cohttp
24
25 let ($) = Util.Function.($)
26
27 module StrMap = Map.Make(String)
28 module AStrMap = Util.Assoc(StrMap)
29 module MStrMap = Util.Map(StrMap)
30
31 exception Timeout
32 exception Bad_sig
33
34 type application =
35 { app_db : string;
36 app_key : string;
37 app_sec : string;
38 app_domain : string;
39 timeout : float option;
40 mutable seq : int
41 }
42 and user =
43 { uid : int64;
44 user_app : application;
ae2def8 Cookie support
David Sheets authored
45 session : (string * float) option;
b7f1726 rough cut
David Sheets authored
46 added : bool;
47 friends : user list;
48 props : (string * string) list
49 }
50 with orm(
51 unique: user<uid>, application<app_key>;
52 debug: all;
53 dot: "facebook.dot"
54 )
55
56 let facebook_http = "http://api.facebook.com/restserver.php"
57 let facebook_https = "https://api.facebook.com/restserver.php"
58
59 let application ?(timeout=None) dbn key sec domain =
60 lwt db = Util.Database.attach ~rm:false application_init dbn in
61 let save a = let () = application_save db a in a in
62 match application_get ~app_key:(`Eq key) db with
63 | [] -> return (save { app_db = dbn; app_key = key; app_sec = sec;
64 app_domain = domain; timeout = timeout; seq = 0 })
65 | a::_ -> return (save { a with app_db = dbn })
66
67 let generate_sig { app_sec = sec } pmap =
68 let meat = StrMap.fold (fun k v p -> sprintf "%s%s=%s" p k v) pmap "" in
69 Digest.to_hex (Digest.string (meat ^ sec))
70
71 (* validate an assoc of params against a facebook signature *)
72 let validate_params app ?(ns="fb_sig") params =
73 let pref = ns ^ "_" in
74 let prefl = String.length pref in
75 let is_ns_param (k, _) = Util.String.begins pref k in
76 let fbparams, others = List.partition is_ns_param params in
77 let fbparams = List.map (fun (k, v) -> (Util.String.from k prefl, v)) fbparams in
78 let fbm = AStrMap.into_map StrMap.empty fbparams in
79 let check_timeout fbm =
80 let fbtime = MStrMap.findo ["time"] fbm in
81 let now = Unix.time () in
82 match app.timeout, fbtime with
83 | Some tm, Some time when (now -. (float_of_string time)) > tm -> false
84 | Some tm, None -> false
85 | _, _ -> true
86 in
87 let check_sig pmap sign = sign = (generate_sig app pmap) in
88 match AStrMap.findo [ns] others with
89 | Some v ->
90 if check_timeout fbm then
91 if check_sig fbm v then
92 return fbm
93 else fail Bad_sig
94 else fail Timeout
95 | None ->
96 return StrMap.empty
97
98 let load_user app db uid =
99 match user_get ~uid:(`Eq uid) db with
100 | [] -> { uid = uid;
101 user_app = app;
102 session = None;
103 friends = [];
104 added = false;
105 props = []
106 }
107 | u::_ -> u
108
109 let get_user app fbm =
110 let module M = MStrMap in
111 let module O = Util.Option in
112 let (>>=) = O.(>>=) in
113 let return = O.return in
114 let added = (M.findo ["added"] fbm) >>= (return $ ((=) 1) $ int_of_string) in
115 match (M.findo ["user"; "profile_user"; "canvas_user"] fbm)
116 >>= (return $ Int64.of_string) with
117 | Some uid ->
118 let session = M.findo ["session_key"; "profile_session_key"] fbm in
ae2def8 Cookie support
David Sheets authored
119 let expiry = (M.findo ["expires"] fbm) >>= (return $ float_of_string) in
b7f1726 rough cut
David Sheets authored
120 lwt db = Util.Database.attach ~rm:false user_init app.app_db in
121 let user = { load_user app db uid with
122 session = session >>= (fun s ->
123 expiry
124 >>= (return $ fun e -> (s, e)));
125 added = match added with None -> false | Some b -> b
126 } in
127 let save u = let () = user_save db u in u in
128 Lwt.return (Some (save user))
129 | None -> Lwt.return None
130
131 (* Does not look at cookies *)
132 let user app req =
133 let post = Http_request.params_post req in
134 lwt fbp = validate_params app post in
135 if StrMap.is_empty fbp then
ae2def8 Cookie support
David Sheets authored
136 lwt fbg = validate_params app (Http_request.params_get req) in
b7f1726 rough cut
David Sheets authored
137 lwt fbp = validate_params app ~ns:"fb_post_sig" post in
138 let fbm = MStrMap.merge fbg fbp in
ae2def8 Cookie support
David Sheets authored
139 if StrMap.is_empty fbm then
140 let cookies = Http_cookie.extract req in
141 lwt fbc = validate_params app ~ns:app.app_key cookies in
142 get_user app fbc
143 else
144 get_user app fbm
b7f1726 rough cut
David Sheets authored
145 else
146 get_user app fbp
147
ae2def8 Cookie support
David Sheets authored
148 let gen_cookies path user =
149 let make = Http_cookie.make in
150 let serialize = Http_cookie.serialize in
b7f1726 rough cut
David Sheets authored
151 let app = user.user_app in
ae2def8 Cookie support
David Sheets authored
152 let domain = app.app_domain in
153 let cookies = [("user", Int64.to_string user.uid)] in
154 let cookies = match user.session with
b7f1726 rough cut
David Sheets authored
155 | Some (sess_key, expiry) ->
ae2def8 Cookie support
David Sheets authored
156 ("session_key", sess_key) :: ("expires", string_of_float expiry) :: cookies
157 | None -> cookies in
158 let cm = AStrMap.into_map StrMap.empty cookies in
159 let cookies = List.map (fun (n,v) -> (app.app_key ^ "_" ^ n, v)) cookies in
160 let cookies = (app.app_key, generate_sig app cm) :: cookies in
161 match user.session with
162 | Some (_, expiry) ->
163 List.map
164 (fun (n,v) ->
165 serialize (make ~expiry:(`Until expiry) ~path ~domain n v))
166 cookies
167 | None ->
168 List.map
169 (fun (n,v) ->
170 serialize (make ~path ~domain n v))
171 cookies
172
b7f1726 rough cut
David Sheets authored
173 (* QUERIES *)
174
175 let std_params user meth params =
176 let get = [("method", meth);
177 ("api_key", user.user_app.app_key);
178 ("v", "1.0")] in
179 let get = match user.session with None -> get
180 | Some (k, _) -> ("session_key", k) :: get in
181 let post = [("call_id", string_of_int user.user_app.seq);
182 ("format", "JSON")] @ params in
183 let pmap = AStrMap.into_map StrMap.empty (get @ post) in
184 let () = user.user_app.seq <- user.user_app.seq + 1 in
185 (get, ("sig", generate_sig user.user_app pmap) :: post)
186
187 let url_encode = Netencoding.Url.mk_url_encoded_parameters
188
189 module Namespace =
190 struct
191 let rec coerce = function
192 | `D i -> string_of_int i
193 | `S s -> s
194 | `List v -> Json_io.string_of_json (json_of_list v)
195 and json_coerce = function
196 | `D i -> json_of_int i
197 | `S s -> json_of_string s
198 | `List v -> json_of_list v
199 and json_of_int i = Json_type.Int i
200 and json_of_string s = Json_type.String s
201 and json_of_list l = Json_type.Array (List.map json_coerce l)
202
203 let bind_value fn (k, v) = (k, fn v)
204
205 let call_method ns user name params =
206 let params = List.map (bind_value coerce) params in
207 let get, post = std_params user ("facebook." ^ ns ^ "." ^ name) params in
208 let qs = url_encode get in
209 let headers = [("User-Agent", "ocaml-facebook/0.1")] in
210 let body = url_encode post in
211 let url = facebook_http ^ "?" ^ qs in
212 lwt _, jsons = Http_user_agent.post ~headers ~body url in
213 return (Json_io.json_of_string jsons)
214 end
215
216 module Users =
217 struct
218 include Namespace
219 let call user = call_method "users" user
220
221 let loadr json = return json
222
223 let get_info user uids fields =
224 (call user "getInfo" [("uids", `List uids);
225 ("fields", `List fields)]) >>= loadr
226
227 let get_standard_info user uids fields =
228 (call user "getStandardInfo" [("uids", `List uids);
229 ("fields", `List fields)]) >>= loadr
230 end
231
232 module Fql =
233 struct
234 include Namespace
235 let call user = call_method "fql" user
236
237 let query user q = call user "query" [("query", `S q)]
238
239 end
Something went wrong with that request. Please try again.