Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 201 lines (178 sloc) 6.608 kb
f933817 LGPL licensing
David Sheets authored
1 (*
2 ocaml-facebook - Facebook Platform client API in OCaml
3
8a95315 @dsheets Reorganization of API modules, protection of interfaces
authored
4 Copyright (C) <2009-2010> David Sheets <sheets@alum.mit.edu>
f933817 LGPL licensing
David Sheets authored
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
7eeff09 @dsheets Added retry loop for Facebook client queries with new wrapped exception
authored
31 exception Facebook_error of string * exn list
32 exception Facebook_timeout
33 exception Facebook_bad_sig
b7f1726 rough cut
David Sheets authored
34
35 type application =
2103162 Cleaned up state, fixed time-out bugs, added more cookie support, added ...
David Sheets authored
36 { app_cookie_prefix : string option;
b7f1726 rough cut
David Sheets authored
37 app_key : string;
38 app_sec : string;
39 app_domain : string;
40 timeout : float option;
41 mutable seq : int
42 }
43 and user =
44 { uid : int64;
45 user_app : application;
2103162 Cleaned up state, fixed time-out bugs, added more cookie support, added ...
David Sheets authored
46 time : float;
ae2def8 Cookie support
David Sheets authored
47 session : (string * float) option;
b7f1726 rough cut
David Sheets authored
48 added : bool;
49 friends : user list;
50 props : (string * string) list
51 }
2103162 Cleaned up state, fixed time-out bugs, added more cookie support, added ...
David Sheets authored
52
53 type user_table = (int64, user) Hashtbl.t
b7f1726 rough cut
David Sheets authored
54
2103162 Cleaned up state, fixed time-out bugs, added more cookie support, added ...
David Sheets authored
55 let users : user_table = Hashtbl.create 10
56
57 let application ?(timeout=None) ?cpref key sec domain =
58 return { app_cookie_prefix = cpref; app_key = key; app_sec = sec;
59 app_domain = domain; timeout = timeout; seq = 0 }
b7f1726 rough cut
David Sheets authored
60
61 let generate_sig { app_sec = sec } pmap =
62 let meat = StrMap.fold (fun k v p -> sprintf "%s%s=%s" p k v) pmap "" in
63 Digest.to_hex (Digest.string (meat ^ sec))
64
65 (* validate an assoc of params against a facebook signature *)
66 let validate_params app ?(ns="fb_sig") params =
67 let pref = ns ^ "_" in
68 let prefl = String.length pref in
69 let is_ns_param (k, _) = Util.String.begins pref k in
70 let fbparams, others = List.partition is_ns_param params in
71 let fbparams = List.map (fun (k, v) -> (Util.String.from k prefl, v)) fbparams in
72 let fbm = AStrMap.into_map StrMap.empty fbparams in
73 let check_timeout fbm =
74 let fbtime = MStrMap.findo ["time"] fbm in
2103162 Cleaned up state, fixed time-out bugs, added more cookie support, added ...
David Sheets authored
75 let now = Unix.time ()
76 in (match MStrMap.findo ["expires"] fbm with
77 | None -> true
78 | Some expiry when (float_of_string expiry) -. now > 0. -> true
79 | _ -> false)
80 || (match app.timeout, fbtime with
81 | Some tm, Some time when (now -. (float_of_string time)) > tm -> false
82 | Some tm, None -> false
83 | _, _ -> true)
b7f1726 rough cut
David Sheets authored
84 in
85 let check_sig pmap sign = sign = (generate_sig app pmap) in
86 match AStrMap.findo [ns] others with
87 | Some v ->
88 if check_timeout fbm then
89 if check_sig fbm v then
90 return fbm
7eeff09 @dsheets Added retry loop for Facebook client queries with new wrapped exception
authored
91 else fail Facebook_bad_sig
92 else fail Facebook_timeout
b7f1726 rough cut
David Sheets authored
93 | None ->
94 return StrMap.empty
95
2103162 Cleaned up state, fixed time-out bugs, added more cookie support, added ...
David Sheets authored
96 let string_of_time f = Int64.to_string (Int64.of_float f)
97
98 let get_uido app fbm =
99 let (>>=) = Util.Option.(>>=) in
100 let return = Util.Option.return in
101 (MStrMap.findo ["user"; "profile_user"; "canvas_user"] fbm)
102 >>= (return $ Int64.of_string)
103
104 let load_user app uid =
105 try Hashtbl.find users uid
106 with Not_found -> { uid=uid; user_app=app; session=None;
107 friends=[]; added=false; props=[]; time=0. }
108
109 let save_user user = Hashtbl.replace users user.uid user
b7f1726 rough cut
David Sheets authored
110
111 let get_user app fbm =
112 let module M = MStrMap in
113 let module O = Util.Option in
114 let (>>=) = O.(>>=) in
115 let return = O.return in
2103162 Cleaned up state, fixed time-out bugs, added more cookie support, added ...
David Sheets authored
116 let time = (M.findo ["time"] fbm) >>= (return $ float_of_string) in
b7f1726 rough cut
David Sheets authored
117 let added = (M.findo ["added"] fbm) >>= (return $ ((=) 1) $ int_of_string) in
2103162 Cleaned up state, fixed time-out bugs, added more cookie support, added ...
David Sheets authored
118 match get_uido app fbm with
119 | Some uid ->
120 let session = M.findo ["session_key"; "profile_session_key"] fbm in
121 let expiry = (M.findo ["expires"] fbm) >>= (return $ float_of_string) in
122 let user = load_user app uid in
123 let user = { user with
124 session = session >>= (fun s ->
125 expiry
126 >>= (return $ fun e -> (s, e)));
127 added = begin match added with
128 | Some b -> b
129 | None -> user.added end;
130 time = begin match time with
131 | Some t -> t
132 | None -> user.time end
133 } in
134 let () = save_user user in
135 Lwt.return (Some user)
136 | None -> Lwt.return None
b7f1726 rough cut
David Sheets authored
137
138 let user app req =
139 let post = Http_request.params_post req in
140 lwt fbp = validate_params app post in
141 if StrMap.is_empty fbp then
ae2def8 Cookie support
David Sheets authored
142 lwt fbg = validate_params app (Http_request.params_get req) in
2103162 Cleaned up state, fixed time-out bugs, added more cookie support, added ...
David Sheets authored
143 (* Ignore GET params if the time is old (user nav) *)
144 lwt fbg = match MStrMap.findo ["time"] fbg with
145 | Some time ->
146 begin match get_uido app fbg with
147 | Some uid -> if (load_user app uid).time > (float_of_string time)
148 then return StrMap.empty
149 else return fbg
150 | None -> return fbg
151 end
152 | None -> return fbg in
b7f1726 rough cut
David Sheets authored
153 lwt fbp = validate_params app ~ns:"fb_post_sig" post in
154 let fbm = MStrMap.merge fbg fbp in
ae2def8 Cookie support
David Sheets authored
155 if StrMap.is_empty fbm then
156 let cookies = Http_cookie.extract req in
2103162 Cleaned up state, fixed time-out bugs, added more cookie support, added ...
David Sheets authored
157 lwt fbc = validate_params app ~ns:app.app_key cookies
158 in match app.app_cookie_prefix with
159 | None -> get_user app fbc
160 | Some p -> if StrMap.is_empty fbc
161 then (validate_params app ~ns:(p ^ "_" ^ app.app_key) cookies)
162 >>= (get_user app)
163 else get_user app fbc
164 else
ae2def8 Cookie support
David Sheets authored
165 get_user app fbm
b7f1726 rough cut
David Sheets authored
166 else
167 get_user app fbp
168
8a95315 @dsheets Reorganization of API modules, protection of interfaces
authored
169 let uid user = user.uid
170
ae2def8 Cookie support
David Sheets authored
171 let gen_cookies path user =
172 let make = Http_cookie.make in
173 let serialize = Http_cookie.serialize in
b7f1726 rough cut
David Sheets authored
174 let app = user.user_app in
ae2def8 Cookie support
David Sheets authored
175 let domain = app.app_domain in
2103162 Cleaned up state, fixed time-out bugs, added more cookie support, added ...
David Sheets authored
176 let cookies = [("user", Int64.to_string user.uid);
177 ("time", string_of_time (Unix.time ()))] in
ae2def8 Cookie support
David Sheets authored
178 let cm = AStrMap.into_map StrMap.empty cookies in
2103162 Cleaned up state, fixed time-out bugs, added more cookie support, added ...
David Sheets authored
179 let prefix = match app.app_cookie_prefix with
180 | None -> app.app_key
181 | Some p -> p ^ "_" ^ app.app_key in
182 let cookies = List.map (fun (n,v) -> (prefix ^ "_" ^ n, v)) cookies in
183 let cookies = (prefix, generate_sig app cm) :: cookies in
184 match user.session, app.timeout with
185 | Some (_, expiry), _ ->
ae2def8 Cookie support
David Sheets authored
186 List.map
187 (fun (n,v) ->
188 serialize (make ~expiry:(`Until expiry) ~path ~domain n v))
189 cookies
2103162 Cleaned up state, fixed time-out bugs, added more cookie support, added ...
David Sheets authored
190 | None, Some tm ->
191 List.map
192 (fun (n,v) ->
193 serialize (make ~expiry:(`Age [`Second (truncate tm)])
194 ~path ~domain n v))
195 cookies
196 | None, None ->
ae2def8 Cookie support
David Sheets authored
197 List.map
198 (fun (n,v) ->
199 serialize (make ~path ~domain n v))
200 cookies
Something went wrong with that request. Please try again.