Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

strip out the remote syncing and user code entirely, to simplify the …

…server. it'll return later in a better form..
  • Loading branch information...
commit 0989f7ca0918b339d0dd0fbae290e94448a7d84a 1 parent e5c57e7
Anil Madhavapeddy authored
1  db_thread.ml
@@ -42,7 +42,6 @@ let db_thread () =
42 42 |`Lifedb -> Sql_mirror.do_scan lifedb syncdb throttle_check
43 43 |`Plugins -> Lifedb_plugin.do_scan lifedb'
44 44 |`Tasks -> Lifedb_tasks.do_scan ()
45   - |`Out_tasks -> Lifedb_out_tasks.do_scan ()
46 45 end;
47 46 maybe_signal copt;
48 47 done
2  db_thread_access.ml
@@ -22,7 +22,6 @@ type scan_request = [
22 22 |`Plugins
23 23 |`Lifedb
24 24 |`Tasks
25   - |`Out_tasks
26 25 ]
27 26
28 27 let q = Queue.create ()
@@ -33,7 +32,6 @@ let string_of_scan_request = function
33 32 |`Plugins -> "plugins"
34 33 |`Lifedb -> "lifedb"
35 34 |`Tasks -> "in_tasks"
36   - |`Out_tasks -> "out_tasks"
37 35
38 36 let dump_q () =
39 37 printf "DB Queue: [";
56 lifedb_dispatch.ml
@@ -55,18 +55,6 @@ let dispatch (lifedb : Lifedb_schema.Init.t) (syncdb : Sync_schema.Init.t) env (
55 55 (* not authenticated *)
56 56 |false -> begin
57 57 match cgi#request_method, url_hd with
58   - |`POST, "sync" ->
59   - let username = if List.length url_list < 2 then "unknown" else List.nth url_list 1 in
60   - let arg = mark_post_rpc cgi in
61   - Lifedb_user.dispatch_sync lifedb syncdb cgi username arg
62   - |`PUT arg, "sync" -> begin
63   - match url_list with
64   - |["sync";useruid;"_att";fileuid] ->
65   - Lifedb_user.dispatch syncdb env cgi (`Attachment (arg, useruid, fileuid))
66   - |["sync";useruid;"_entry";fileuid] ->
67   - Lifedb_user.dispatch syncdb env cgi (`Entry (arg, useruid, fileuid))
68   - |_ -> raise (Lifedb_rpc.Resource_not_found "unknown PUT request")
69   - end
70 58 |_ ->
71 59 return_need_auth cgi
72 60 end
@@ -96,21 +84,6 @@ let dispatch (lifedb : Lifedb_schema.Init.t) (syncdb : Sync_schema.Init.t) env (
96 84 |"_all" -> `List
97 85 |name -> `Get name)
98 86
99   - |`POST, "outtask" ->
100   - let arg = mark_post_rpc cgi in
101   - let name = if List.length url_list < 2 then "_unknown" else List.nth url_list 1 in
102   - Lifedb_out_tasks.dispatch cgi (`Create (name,arg))
103   - |`DELETE, "outtask" ->
104   - mark_delete_rpc cgi;
105   - let name = if List.length url_list < 2 then "_unknown" else List.nth url_list 1 in
106   - Lifedb_out_tasks.dispatch cgi (`Destroy name)
107   - |`GET, "outtask" ->
108   - let tasksel = if List.length url_list < 2 then "_all" else List.nth url_list 1 in
109   - mark_get_rpc cgi;
110   - Lifedb_out_tasks.dispatch cgi (match tasksel with
111   - |"_all" -> `List
112   - |name -> `Get name)
113   -
114 87 |`GET, "plugin" ->
115 88 let tasksel = if List.length url_list < 2 then "_all" else List.nth url_list 1 in
116 89 mark_get_rpc cgi;
@@ -141,35 +114,6 @@ let dispatch (lifedb : Lifedb_schema.Init.t) (syncdb : Sync_schema.Init.t) env (
141 114 mark_get_rpc cgi;
142 115 Lifedb_query.dispatch lifedb syncdb env cgi (`Mtype (List.tl url_list))
143 116
144   - |`POST, "user" ->
145   - let arg = mark_post_rpc cgi in
146   - Lifedb_user.dispatch syncdb env cgi (`Create arg)
147   - |`DELETE, "user" ->
148   - mark_delete_rpc cgi;
149   - let name = if List.length url_list < 2 then "unknown" else List.nth url_list 1 in
150   - Lifedb_user.dispatch syncdb env cgi (`Delete name)
151   - |`GET, "user" ->
152   - let usersel = if List.length url_list < 2 then "_all" else List.nth url_list 1 in
153   - mark_get_rpc cgi;
154   - Lifedb_user.dispatch syncdb env cgi (match usersel with
155   - |"_all" -> `List
156   - |name -> `Get name)
157   -
158   - |`POST, "filter" ->
159   - let arg = mark_post_rpc cgi in
160   - let uid = if List.length url_list < 2 then "unknown" else List.nth url_list 1 in
161   - Lifedb_user.dispatch syncdb env cgi (`Create_filter (uid,arg))
162   - |`DELETE, "filter" ->
163   - let uid,name = match url_list with |[_;uid;name] -> uid,name |_ -> "","" in
164   - Lifedb_user.dispatch syncdb env cgi (`Delete_filter (uid,name))
165   - |`GET, "filter" -> begin
166   - mark_get_rpc cgi;
167   - match url_list with
168   - |["filter";useruid] -> Lifedb_user.dispatch syncdb env cgi (`List_filters useruid)
169   - |["filter";useruid;fname] -> Lifedb_user.dispatch syncdb env cgi (`Get_filter (useruid, fname))
170   - |_ -> raise (Resource_not_found "filter")
171   - end
172   -
173 117 |_ -> raise (Invalid_rpc "Unknown request")
174 118 end
175 119
60 lifedb_filter.ml
... ... @@ -1,60 +0,0 @@
1   -(* Copyright (C) 2009 Anil Madhavapeddy <anil@recoil.org>
2   -
3   - This program is free software; you can redistribute it and/or modify
4   - it under the terms of the GNU General Public License as published by
5   - the Free Software Foundation; either version 2 of the License, or
6   - (at your option) any later version.
7   -
8   - This program is distributed in the hope that it will be useful,
9   - but WITHOUT ANY WARRANTY; without even the implied warranty of
10   - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11   - GNU General Public License for more details.
12   -
13   - You should have received a copy of the GNU General Public License along
14   - with this program; if not, write to the Free Software Foundation, Inc.,
15   - 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
16   -*)
17   -
18   -open Utils
19   -open Printf
20   -module LS=Lifedb_schema
21   -module SS=Sync_schema
22   -
23   -(* return the set of uids which the remote user doesnt have *)
24   -let filter_new (user:SS.User.t) es =
25   - let has_uids = (guids_of_blob user#has_guids) @ (guids_of_blob user#sent_guids) in
26   - let f = List.filter (fun e -> not (List.mem e#uid has_uids)) es in
27   - Log.logmod "Filter" "Filtering new entries -> %s (%d orig, %d results)" user#uid (List.length es) (List.length f);
28   - f
29   -
30   -(* return the set of uids which are addressed to the remote user *)
31   -let filter_recipients user es =
32   - let f = List.filter (fun e ->
33   - List.length (
34   - List.find_all (fun s ->
35   - s#name = "email" && s#uid = user#uid
36   - ) e#recipients
37   - ) > 0
38   - ) es in
39   - Log.logmod "Filter" "Filtering entries addressed to -> %s (%d results)" user#uid (List.length f);
40   - f
41   -
42   -(* apply a single filter and return a set of entries *)
43   -let apply_filter lifedb syncdb (user:SS.User.t) (entries:LS.Entry.t list) (filter:SS.Filter_rule.t) =
44   - match filter#body with
45   - |"add *" -> begin
46   - (* no need to preserve incoming uids as this just adds them all to output *)
47   - filter_new user (LS.Entry.get lifedb)
48   - end
49   - |"add * where #remote in recipients" -> begin
50   - filter_recipients user (filter_new user (LS.Entry.get lifedb)) @ entries
51   - end
52   - |_ -> failwith "unknown filter rule"
53   -
54   -(* given a user record, return a list of entries which need to go to the user *)
55   -let apply_filters lifedb syncdb (user:SS.User.t) =
56   - (* by default, we do not send any data to the remote user *)
57   - let entries = [] in
58   - (* retrieve filters in descending zorder to apply *)
59   - let filters = List.sort (fun a b -> compare a#zorder b#zorder) user#filters in
60   - List.fold_left (apply_filter lifedb syncdb user) entries filters
345 lifedb_out_tasks.ml
... ... @@ -1,345 +0,0 @@
1   -(* Copyright (C) 2009 Anil Madhavapeddy <anil@recoil.org>
2   -
3   - This program is free software; you can redistribute it and/or modify
4   - it under the terms of the GNU General Public License as published by
5   - the Free Software Foundation; either version 2 of the License, or
6   - (at your option) any later version.
7   -
8   - This program is distributed in the hope that it will be useful,
9   - but WITHOUT ANY WARRANTY; without even the implied warranty of
10   - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11   - GNU General Public License for more details.
12   -
13   - You should have received a copy of the GNU General Public License along
14   - with this program; if not, write to the Free Software Foundation, Inc.,
15   - 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
16   -*)
17   -
18   -(* Task scheduling *)
19   -
20   -open Printf
21   -open Utils
22   -module LS=Lifedb_schema
23   -module SS=Sync_schema
24   -
25   -exception Task_error of string
26   -exception Internal_task_error of string
27   -
28   -let m = Mutex.create ()
29   -
30   -type task_state = {
31   - cmd: string;
32   - plugin: string;
33   - mtype: string;
34   - cwd: string;
35   - start_time: float;
36   - secret: (string * string) option;
37   - args : string list option;
38   - mutable outfd: Unix.file_descr option;
39   - mutable errfd: Unix.file_descr option;
40   - mutable running: Fork_helper.task;
41   - mutable uids: string list;
42   - mutable files: string list;
43   -}
44   -
45   -let task_list = Hashtbl.create 1
46   -let task_table_limit = 20
47   -let task_poll_period = ref 20.
48   -let task_throttle () = Thread.delay 0.1
49   -
50   -let json_of_task name t : Lifedb.Rpc.Task.out_r =
51   - let secret = match t.secret with |None -> None
52   - |Some (s,u) -> Some (object method service=s method username=u end) in
53   - object
54   - method name=name
55   - method plugin=t.plugin
56   - method pltype=t.mtype
57   - method secret=secret
58   - method args=t.args
59   - method duration=Unix.gettimeofday () -. t.start_time
60   - method pid=Fork_helper.pid_of_task t.running
61   - end
62   -
63   -let string_of_task t =
64   - let running = Fork_helper.string_of_task t.running in
65   - sprintf ": `%s` %s" t.cmd running
66   -
67   -let log_task_table () =
68   - Hashtbl.iter (fun name state ->
69   - Log.logmod "Tasks" "%s: %s" name (string_of_task state)
70   - ) task_list
71   -
72   -let find_task name =
73   - try
74   - Some (Hashtbl.find task_list name)
75   - with
76   - Not_found -> None
77   -
78   -let find_task_by_mtype mtype =
79   - let f = ref None in
80   - Hashtbl.iter (fun n t ->
81   - if t.mtype = mtype then
82   - f := Some (n,t)
83   - ) task_list;
84   - !f
85   -
86   -(* create task descriptor and leave it unstarted *)
87   -let create_task task_name (p:Lifedb.Rpc.Task.out_t) =
88   - assert(not (Mutex.try_lock m));
89   - if Hashtbl.length task_list >= task_table_limit then
90   - raise (Task_error "too many tasks already registered");
91   - if String.contains task_name '.' || (String.contains task_name '/') then
92   - raise (Task_error "task name cant contain . or /");
93   - let pl = match Lifedb_plugin.find_plugin p#plugin with
94   - |None -> raise (Task_error (sprintf "plugin %s not found" p#plugin))
95   - |Some x -> x in
96   - let secret = match p#secret with
97   - |None -> None
98   - |Some s -> Some (s#service, s#username) in
99   - let now_time = Unix.gettimeofday () in
100   - let task = { cmd=pl#cmd; outfd=None; errfd=None; cwd=pl#dir; plugin=pl#name; secret=secret; start_time=now_time; running=(Fork_helper.blank_task ()); args=p#args; uids=[]; files=[]; mtype=p#pltype } in
101   - Hashtbl.add task_list task_name task;
102   - Log.logmod "Tasks" "Created outbound task '%s' %s" task_name (string_of_task task)
103   -
104   -let find_or_create_task name (t:Lifedb.Rpc.Task.out_t) =
105   - match find_task name with
106   - |Some _ -> ()
107   - |None -> create_task name t
108   -
109   -(* close any logging fds, reset fields *)
110   -let reset_task name =
111   - assert(not (Mutex.try_lock m));
112   - let closeopt task = function
113   - |None -> ()
114   - |Some fd ->
115   - let lg = sprintf "[%s] Log closing: %s\n" (current_datetime()) (Fork_helper.string_of_task task.running) in
116   - ignore(Unix.handle_unix_error (Unix.write fd lg 0) (String.length lg));
117   - Unix.handle_unix_error Unix.close fd;
118   - in
119   - match find_task name with
120   - |Some task ->
121   - let time_taken = (Unix.gettimeofday ()) -. task.start_time in
122   - let exit_code = Fork_helper.exit_code_of_task task.running in
123   - Log.push (`Plugin (name, time_taken, exit_code));
124   - closeopt task task.outfd;
125   - closeopt task task.errfd;
126   - task.outfd <- None;
127   - task.errfd <- None;
128   - task.running <- Fork_helper.blank_task ();
129   - task.uids <- [];
130   - task.files <- [];
131   - |None -> ()
132   -
133   -(* remove the task entirely *)
134   -let destroy_task name =
135   - assert(not (Mutex.try_lock m));
136   - match find_task name with
137   - |Some task -> begin
138   - let final_status = Fork_helper.destroy task.running in
139   - reset_task name;
140   - Hashtbl.remove task_list name;
141   - Log.logmod "Tasks" "Outbound task %s destroyed: %s" name
142   - (Fork_helper.string_of_status final_status);
143   - end
144   - |None -> raise (Task_error "task not found")
145   -
146   -(* split up a list of entris into a hashtable of their respective mtypes *)
147   -let partition_entries_into_mtypes lifedb es =
148   - let h = Hashtbl.create 1 in
149   - List.iter (fun e ->
150   - if not (Hashtbl.mem h e#mtype#name) then
151   - Hashtbl.add h e#mtype#name [];
152   - Hashtbl.replace h e#mtype#name (e :: (Hashtbl.find h e#mtype#name))
153   - ) es;
154   - h
155   -
156   -let start_task name =
157   - let t = Hashtbl.find task_list name in
158   - assert(not (Mutex.try_lock m));
159   - let env = match t.secret with
160   - |None -> [||]
161   - |Some (s,u) -> begin
162   - match Lifedb_passwd.lookup_passwd s u with
163   - |Some p -> [| ("LIFEDB_PASSWORD=" ^ p); ("LIFEDB_USERNAME="^u) |]
164   - |None -> Log.logmod "Tasks" "WARNING: unable to find passwd for task '%s'" name; [||]
165   - end in
166   - (* add environment arguments *)
167   - let args = match t.args with None -> [||] | Some a -> Array.of_list a in
168   - let env = Array.append env args in
169   - let logdir = Lifedb_config.Dir.log() in
170   - let logfile = sprintf "%s/%s.log" logdir name in
171   - let errlogfile = sprintf "%s/%s.err" logdir name in
172   - let openfdfn f = Unix.handle_unix_error (Unix.openfile f [ Unix.O_APPEND; Unix.O_CREAT; Unix.O_WRONLY]) 0o600 in
173   - let outfd = openfdfn logfile in
174   - let errfd = openfdfn errlogfile in
175   - let logfn fd s = ignore(Unix.write fd s 0 (String.length s)) in
176   - let tmstr = current_datetime () in
177   - logfn outfd (sprintf "[%s] Stdout log started\n" tmstr);
178   - logfn errfd (sprintf "[%s] Stderr log started\n" tmstr);
179   - let env = Array.append env [| "LIFEDB_SYNC_DIR=out"; (sprintf "LIFEDB_UID_MAP=%s" (Lifedb_config.Dir.uidmap ()));
180   - (sprintf "HOME=%s" (Sys.getenv "HOME"));
181   - (sprintf "USER=%s" (Sys.getenv "USER")) |] in
182   - let cmd =
183   - if Lifedb_config.test_mode () then
184   - sprintf "sleep %d" (Random.int 5 + 3)
185   - else
186   - (* XXX check shell escaping here!! *)
187   - sprintf "%s %s" t.cmd (String.concat " " (List.map String.escaped t.files))
188   - in
189   - let ts = Fork_helper.create cmd env t.cwd (logfn outfd) (logfn errfd) in
190   - Log.logmod "Tasks" "Executing outbound command '%s' (%s)" name cmd;
191   - task_throttle ();
192   - t.running <- ts;
193   - t.outfd <- Some outfd;
194   - t.errfd <- Some errfd
195   -
196   -(* Look for items in the INBOX with a pltype matching an active plugin, and schedule it
197   - if so *)
198   -let task_sweep lifedb syncdb () =
199   - (* for each user, look for entries in the inbox to them *)
200   - List.iter (fun (user:SS.User.t) ->
201   - let es = LS.Entry.get_by_inbox_delivered ~inbox:(Some user#uid) ~delivered:0L lifedb in
202   - match es with
203   - |[] -> ()
204   - |es -> begin
205   - (* constrain es to only 50 entries at a time to avoid overloading output plugin *)
206   - let es = list_max_size 50 es in
207   - (* we have inbox entries, look for a plugin to handle each mtype *)
208   - let h = partition_entries_into_mtypes lifedb es in
209   - Hashtbl.iter (fun mtype_name es ->
210   - (* look for an output task to handle this mtype name *)
211   - match find_task_by_mtype mtype_name with
212   - |None ->
213   - Log.logmod "Task" "Unable to find output task for <- %s : %s" mtype_name user#uid
214   - |Some (name,t) -> begin
215   - match Fork_helper.status_of_task t.running with
216   - |Fork_helper.Not_started ->
217   - (* set the entry UIDs and kick the command off *)
218   - t.uids <- List.map (fun e -> e#uid) es;
219   - t.files <- List.map (fun e -> e#file_name) es;
220   - start_task name
221   - |_ ->
222   - Log.logmod "Task" "Pending INBOX items, but already running %s" name
223   - end
224   - ) h
225   - end
226   - ) (SS.User.get syncdb);
227   - Hashtbl.iter (fun name task ->
228   - let td = string_of_task task in
229   - match Fork_helper.status_of_task task.running with
230   - |Fork_helper.Running pid ->
231   - Log.logmod "Sweep" "%s ... %s" name td
232   - |Fork_helper.Not_started -> ()
233   - |Fork_helper.Done exit_code ->
234   - Log.logmod "Sweep" "%s ... finished %s" name td;
235   - if exit_code = 0 then begin
236   - (* successfully delivered msgs, so mark them in the DB as delivered *)
237   - List.iter (fun uid ->
238   - match LS.Entry.get_by_uid ~uid lifedb with
239   - |[e] ->
240   - Log.logmod "Task" "Successfully delivered: %s" e#file_name;
241   - e#set_delivered 1L;
242   - ignore(e#save)
243   - |_ -> ()
244   - ) task.uids;
245   - end;
246   - reset_task name;
247   - |Fork_helper.Killed signal ->
248   - Log.logmod "Sweep" "%s ... crashed %s" name td;
249   - reset_task name;
250   - ) task_list
251   -
252   -let dispatch cgi = function
253   - |`Create (name,p) ->
254   - let params = Lifedb.Rpc.Task.out_t_of_json (Json_io.json_of_string p) in
255   - with_lock m (fun () ->
256   - match find_task name with
257   - |Some state ->
258   - Lifedb_rpc.return_error cgi `Bad_request "Task already exists" "Use a different id"
259   - |None -> begin
260   - try
261   - create_task name params
262   - with
263   - |Task_error err ->
264   - Lifedb_rpc.return_error cgi `Bad_request "Task error" err
265   - end
266   - )
267   - |`Get name ->
268   - with_lock m (fun () ->
269   - match find_task name with
270   - |Some state ->
271   - cgi#output#output_string (Json_io.string_of_json (Lifedb.Rpc.Task.json_of_out_r (json_of_task name state)))
272   - |None ->
273   - Lifedb_rpc.return_error cgi `Not_found "Task error" "Task not found"
274   - )
275   - |`List ->
276   - with_lock m (fun () ->
277   - let r = Hashtbl.fold (fun name state a -> json_of_task name state :: a) task_list [] in
278   - let res = object method results=List.length r method rows=r end in
279   - cgi#output#output_string (Json_io.string_of_json (Lifedb.Rpc.Task.json_of_out_rs res))
280   - )
281   - |`Destroy name ->
282   - with_lock m (fun () ->
283   - try
284   - destroy_task name
285   - with |Task_error err ->
286   - Lifedb_rpc.return_error cgi `Bad_request "Task error" err
287   - )
288   -
289   -(* task thread which waits on a condition to do a sweep. is signalled regularly
290   - or via a process exiting and delivering a SIGCHLD *)
291   -let c = Condition.create ()
292   -let cm = Mutex.create ()
293   -let task_thread () =
294   - let lifedb = LS.Init.t (Lifedb_config.Dir.lifedb_db ()) in
295   - let syncdb = SS.Init.t (Lifedb_config.Dir.sync_db ()) in
296   - while true do
297   - with_lock cm (fun () ->
298   - Condition.wait c cm;
299   - with_lock m (task_sweep lifedb syncdb);
300   - )
301   - done
302   -
303   -(* thread to kick the sweeping thread regularly to update task status. *)
304   -let task_regular_kick () =
305   - while true do
306   - with_lock cm (fun () ->
307   - Condition.signal c
308   - );
309   - Thread.delay !task_poll_period
310   - done
311   -
312   -(* scan the config directory and spawn tasks *)
313   -let config_file_extension = ".outconf"
314   -let scan_config_file config_file =
315   - Log.logmod "Tasks" "Scanning config file %s" config_file;
316   - let task = Lifedb.Rpc.Task.out_t_of_json (Json_io.load_json config_file) in
317   - let task_name = Filename.chop_suffix (Filename.basename config_file) config_file_extension in
318   - match Lifedb_plugin.find_plugin task#plugin with
319   - |None -> Log.logmod "Tasks" "Plugin '%s' not found for task '%s', skipping it" task#plugin task_name;
320   - |Some _ ->
321   - Log.logmod "Tasks" "Added '%s' (plugin %s)" task_name task#plugin;
322   - let task : Lifedb.Rpc.Task.out_t = object
323   - method plugin=task#plugin
324   - method secret=task#secret
325   - method args=task#args
326   - method pltype=task#pltype
327   - end in
328   - with_lock m (fun () -> find_or_create_task task_name task)
329   -
330   -let do_scan () =
331   - let config_dir = Lifedb_config.Dir.config () in
332   - let dh = Unix.opendir config_dir in
333   - try_final (fun () ->
334   - repeat_until_eof (fun () ->
335   - let next_entry = Unix.readdir dh in
336   - if Filename.check_suffix next_entry config_file_extension then
337   - scan_config_file (Filename.concat config_dir next_entry)
338   - )
339   - ) (fun () -> Unix.closedir dh)
340   -
341   -let init () =
342   - let _ = Thread.create task_thread () in
343   - let _ = Thread.create task_regular_kick () in
344   - Sys.set_signal Sys.sigchld (Sys.Signal_handle (fun _ ->
345   - with_lock cm (fun () -> Condition.signal c)))
17 lifedb_schema_generator.ml
@@ -75,23 +75,6 @@ let sync = make [
75 75 date "mtime";
76 76 ],[], default_opts;
77 77
78   - "filter_rule", [
79   - text "name";
80   - text "body";
81   - integer "zorder";
82   - ],[], default_opts;
83   -
84   - "user", [
85   - text ~flags:[`Unique; `Index] "uid";
86   - text "ip";
87   - integer "port";
88   - text "key";
89   - date "last_sync";
90   - blob "has_guids";
91   - blob "sent_guids";
92   - foreign_many "filter_rule" "filters";
93   - ], [], default_opts;
94   -
95 78 ]
96 79
97 80 let log = make [
351 lifedb_user.ml
... ... @@ -1,351 +0,0 @@
1   -(* Copyright (C) 2009 Anil Madhavapeddy <anil@recoil.org>
2   -
3   - This program is free software; you can redistribute it and/or modify
4   - it under the terms of the GNU General Public License as published by
5   - the Free Software Foundation; either version 2 of the License, or
6   - (at your option) any later version.
7   -
8   - This program is distributed in the hope that it will be useful,
9   - but WITHOUT ANY WARRANTY; without even the implied warranty of
10   - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11   - GNU General Public License for more details.
12   -
13   - You should have received a copy of the GNU General Public License along
14   - with this program; if not, write to the Free Software Foundation, Inc.,
15   - 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
16   -*)
17   -
18   -open Utils
19   -open Printf
20   -open Lifedb
21   -module LS=Lifedb_schema
22   -module SS=Sync_schema
23   -open Http_client.Convenience
24   -
25   -let process fn =
26   - let string_of_chan cin =
27   - let buf = Buffer.create 2048 in
28   - repeat_until_eof (fun () ->
29   - Buffer.add_string buf (cin#input_line ());
30   - );
31   - Buffer.contents buf
32   - in
33   - try
34   - let res = fn () in
35   - let cin = res#response_body#open_value_rd () in
36   - Netchannels.with_in_obj_channel cin (fun cin ->
37   - match res#response_status with
38   - |`Ok -> `Success (string_of_chan cin)
39   - |_ -> `Failure (string_of_chan cin)
40   - )
41   - with
42   - |Http_client.Http_protocol _ -> `Failure "unknown"
43   -
44   -(* send an RPC to a remote user with the specified json string *)
45   -let send_rpc (user:SS.User.t) json =
46   - let uri = sprintf "http://%s:%Lu/sync/%s" user#ip user#port (Lifedb_config.Dir.username ()) in
47   - let post_raw body =
48   - process (fun () ->
49   - http_post_raw_message ~callfn:(fun p ->
50   - let rh = p#request_header `Base in
51   - rh#update_field "content-type" "application/json";
52   - p#set_request_header rh)
53   - uri body
54   - ) in
55   - match post_raw json with
56   - |`Success res -> Log.logmod "RPC" "-> %s: success (res: %s)" user#uid res
57   - |`Failure res -> Log.logmod "RPC" "-> %s: epic fail (res: %s)" user#uid res
58   -
59   -let succ_sent_guids = Hashtbl.create 1
60   -
61   -(* HTTP PUT some content to a remote user *)
62   -let put_rpc syncdb (p:Http_client.pipeline) (user:SS.User.t) (entry:LS.Entry.t) =
63   - let uri = sprintf "http://%s:%Lu/sync/%s/_entry/%s" user#ip user#port (Lifedb_config.Dir.username ()) entry#uid in
64   - let atturi att = sprintf "http://%s:%Lu/sync/%s/_att/%s" user#ip user#port (Lifedb_config.Dir.username ()) (Filename.basename att#file_name) in
65   - let failure = ref false in
66   - (* drop the attachments in first *)
67   - List.iter (fun att ->
68   - let res = process (fun () ->
69   - let sz = (Unix.stat att#file_name).Unix.st_size in
70   - let buf = Buffer.create sz in
71   - let fin = open_in att#file_name in
72   - (try
73   - Buffer.add_channel buf fin sz;
74   - with err ->
75   - close_in fin;
76   - raise err
77   - );
78   - close_in fin;
79   - let http_call = new Http_client.put (atturi att) (Buffer.contents buf) in
80   - let hdr = http_call#request_header `Base in
81   - hdr#update_field "Content-type" att#mime_type;
82   - hdr#update_field "Content-length" (sprintf "%d" sz);
83   - http_call#set_request_header hdr;
84   - p#reset ();
85   - p#add http_call;
86   - p#run ();
87   - http_call
88   - ) in
89   - match res with
90   - |`Success res -> Log.logmod "User" "Success uploading attachment %s" att#file_name
91   - |`Failure res -> Log.logmod "User" "FAILED uploading attachment %s" att#file_name; failure := true
92   - ) entry#atts;
93   - if !failure then
94   - Log.logmod "User" "Had failures uploading attachments, so not doing entry %s" entry#uid
95   - else begin
96   - let fin = open_in entry#file_name in
97   - try_final (fun () ->
98   - let res = process (fun () ->
99   - let buf = Buffer.create 2048 in
100   - repeat_until_eof (fun () -> Buffer.add_string buf (input_line fin));
101   - let json = Buffer.contents buf in
102   - let http_call = new Http_client.put uri json in
103   - let hdr = http_call#request_header `Base in
104   - hdr#update_field "Content-type" "application/json";
105   - hdr#update_field "Content-length" (sprintf "%d" (String.length json));
106   - http_call#set_request_header hdr;
107   - p#reset ();
108   - p#add http_call;
109   - p#run ();
110   - http_call
111   - ) in
112   - match res with
113   - |`Success res -> Log.logmod "Upload" "Success to %s (%s): %s" user#uid entry#file_name res
114   - |`Failure res -> Log.logmod "Upload" "Failure to %s (%s): %s" user#uid entry#file_name res)
115   - (fun () -> close_in fin);
116   - user#set_sent_guids (add_guids_to_blob user#sent_guids [entry#uid]);
117   - Hashtbl.replace succ_sent_guids (user#uid, entry#uid) (Unix.gettimeofday ());
118   - ignore(user#save);
119   - end
120   -
121   -(* Lookup a user UID and apply the function over it *)
122   -let find_user db useruid fn =
123   - match SS.User.get ~uid:(Some useruid) db with
124   - |[user] -> fn user
125   - |_ -> raise (Lifedb_rpc.Resource_not_found "unknown user")
126   -
127   -(* Netchannel convenience function to make sure in/out channels are both cleaned up *)
128   -let with_in_and_out_obj_channel cin cout fn =
129   - Netchannels.with_out_obj_channel cout (fun cout ->
130   - Netchannels.with_in_obj_channel cin (fun cin ->
131   - fn cin cout
132   - )
133   - )
134   -
135   -(* User handling fn, to deal with incoming user create/delete and entry create/delete from
136   - remote sources *)
137   -let dispatch db env cgi = function
138   -|`Create arg -> begin
139   - Log.logmod "DebugUser" "%s" arg;
140   - let u = Rpc.User.t_of_json (Json_io.json_of_string arg) in
141   - match SS.User.get ~uid:(Some u#uid) db with
142   - |[] ->
143   - Log.logmod "DebugUser" "adding ";
144   - let user = SS.User.t ~uid:u#uid ~ip:u#ip ~port:(Int64.of_int u#port) ~key:u#key ~sent_guids:(blob_of_guids []) ~has_guids:(blob_of_guids []) ~filters:[] ~last_sync:0. db in
145   - ignore(user#save);
146   - |[user] ->
147   - Log.logmod "DebugUser" "already exists so edit";
148   - user#set_uid u#uid;
149   - user#set_ip u#ip;
150   - user#set_port (Int64.of_int u#port);
151   - user#set_key u#key;
152   - ignore(user#save);
153   - |_ ->
154   - Lifedb_rpc.return_error cgi `Bad_request "Internal error" "Multiple users found with same uid";
155   -end
156   -|`Delete uid -> begin
157   - find_user db uid (fun user -> user#delete)
158   -end
159   -|`Create_filter (useruid,arg) ->
160   - let f = Rpc.User.filter_of_json (Json_io.json_of_string arg) in
161   - find_user db useruid (fun user ->
162   - (* get existing filter list without the currently created one *)
163   - let f = SS.Filter_rule.t ~name:f#name ~body:f#body ~zorder:(Int64.of_int f#zorder) db in
164   - ignore(f#save);
165   - let fs = f :: (List.filter (fun x -> x#name <> f#name) user#filters) in
166   - user#set_filters fs;
167   - ignore(user#save);
168   - )
169   -|`Delete_filter (useruid,name) ->
170   - find_user db useruid (fun user ->
171   - let pos,neg = List.partition (fun x -> x#name = name) user#filters in
172   - match pos with
173   - |[] -> raise (Lifedb_rpc.Resource_not_found "unknown filter")
174   - |_ -> user#set_filters neg; ignore(user#save)
175   - )
176   -|`Entry (arg, useruid, fileuid) -> begin
177   - find_user db useruid (fun user ->
178   - let entry_dir = String.concat "/" [Lifedb_config.Dir.inbox (); user#uid; "entries"] in
179   - let fname = Filename.concat entry_dir (fileuid ^ ".lifeentry") in
180   - if String.contains fileuid '/' then raise (Lifedb_rpc.Invalid_rpc "bad filename uid");
181   - if Sys.file_exists fname then raise (Lifedb_rpc.Resource_conflict "attachment already exists");
182   - make_dirs entry_dir;
183   - let cout = new Netchannels.output_channel (open_out fname) in
184   - let cin = arg#open_value_rd () in
185   - with_in_and_out_obj_channel cin cout (fun cin cout -> cout#output_channel cin);
186   - Db_thread_access.push `Lifedb;
187   - )
188   -end
189   -|`Attachment (arg,useruid,fileuid) -> begin
190   - find_user db useruid (fun user ->
191   - let att_dir = String.concat "/" [Lifedb_config.Dir.inbox (); user#uid; "_att"] in
192   - let fname = Filename.concat att_dir fileuid in
193   - if String.contains fileuid '/' then raise (Lifedb_rpc.Invalid_rpc "bad filename uid");
194   - make_dirs att_dir;
195   - let cout = new Netchannels.output_channel (open_out fname) in
196   - let cin = arg#open_value_rd () in
197   - with_in_and_out_obj_channel cin cout (fun cin cout -> cout#output_channel cin)
198   - )
199   -end
200   -|`Get useruid -> begin
201   - find_user db useruid (fun user ->
202   - let t = object method uid=user#uid method ip=user#ip method port=Int64.to_int user#port method key=user#key end in
203   - cgi#output#output_string (Json_io.string_of_json (Rpc.User.json_of_t t))
204   - )
205   -end
206   -|`List -> begin
207   - let r = List.map (fun user ->
208   - object method uid=user#uid method ip=user#ip method port=Int64.to_int user#port method key=user#key end) (SS.User.get db) in
209   - let tr = object method results=List.length r method rows=r end in
210   - cgi#output#output_string (Json_io.string_of_json (Rpc.User.json_of_ts tr))
211   -end
212   -|`List_filters useruid -> begin
213   - find_user db useruid (fun user ->
214   - let r = List.map (fun f -> object method name=f#name method body=f#body method zorder=(Int64.to_int f#zorder) end) user#filters in
215   - cgi#output#output_string (Json_io.string_of_json (Rpc.User.json_of_filters (results_of_search r)));
216   - )
217   -end
218   -|`Get_filter (useruid, filtername) -> begin
219   - find_user db useruid (fun user ->
220   - match List.filter (fun f -> f#name = filtername) user#filters with
221   - |[] -> raise (Lifedb_rpc.Resource_not_found ("unknown filter " ^ filtername))
222   - |[f] ->
223   - let r = object method name=f#name method body=f#body method zorder=(Int64.to_int f#zorder) end in
224   - cgi#output#output_string (Json_io.string_of_json (Rpc.User.json_of_filter r))
225   - |_ -> raise (Lifedb_rpc.Invalid_rpc "internal error: multiple filters with same name found")
226   - )
227   -end
228   -
229   -(* upload channel, send it a username/file to upload sequentially *)
230   -let uploadreq = Event.new_channel ()
231   -
232   -(* upload contents on the upload queue to remote hosts via HTTP PUT *)
233   -let upload_thread () =
234   - let lifedb = LS.Init.t (Lifedb_config.Dir.lifedb_db ()) in
235   - let syncdb = SS.Init.t (Lifedb_config.Dir.sync_db ()) in
236   - let p = new Http_client.pipeline in
237   - (*
238   - let set_verbose_pipeline () =
239   - let opt = p#get_options in
240   - p#set_options { opt with
241   - Http_client.verbose_status = true;
242   - verbose_request_header = true;
243   - verbose_response_header = true;
244   - verbose_response_contents = true;
245   - verbose_connection = false
246   - } in
247   - set_verbose_pipeline (); *)
248   - p#set_proxy_from_environment ();
249   - p#reset ();
250   - while true do
251   - let useruid, fileuid = Event.sync (Event.receive uploadreq) in
252   - Log.logmod "Upload" "Upload request for %s to %s" fileuid useruid;
253   - match (SS.User.get ~uid:(Some useruid) syncdb), (LS.Entry.get ~uid:(Some fileuid) lifedb) with
254   - |[user],[entry] -> begin
255   - try
256   - put_rpc syncdb p user entry
257   - with err ->
258   - Log.logmod "Sync" "Encountered error syncing %s->%s: %s" user#uid entry#uid (Printexc.to_string err)
259   - end
260   - |_ -> Log.logmod "Sync" "WARNING: User %s or entry %s not found" useruid fileuid
261   - done
262   -
263   -(* given a user object, synchronize any entries not present on the remote user host,
264   - by adding them to the upload thread. *)
265   -let sync_our_entries_to_user lifedb syncdb user =
266   - Log.logmod "Sync" "Our entries -> %s" user#uid;
267   - let uids = Lifedb_filter.apply_filters lifedb syncdb user in
268   - (* filter out recently sent GUIDs from the memory hash *)
269   - let uids = List.filter (fun e ->
270   - try
271   - let tm = Hashtbl.find succ_sent_guids (user#uid,e#uid) in
272   - Unix.gettimeofday () -. tm > 86400.
273   - with _ -> true
274   - ) uids in
275   - List.iter (fun x -> Log.logmod "Sync" "added upload -> %s: %s" x#uid x#file_name) uids;
276   - List.iter (fun x -> Event.sync (Event.send uploadreq (user#uid, x#uid))) uids
277   -
278   -(* given a user object, send it all the GUIDs we already have to keep it up to date with
279   - what we might need *)
280   -let sync_our_guids_to_user lifedb syncdb user =
281   - Log.logmod "Sync" "Our GUIDS -> %s" user#uid;
282   - let all_guids = LS.Entry.get_uid lifedb in
283   - let json = Rpc.User.json_of_sync (object method guids=all_guids end) in
284   - send_rpc user (Json_io.string_of_json json)
285   -
286   -(* thread to regularly iterate over all users and send off our guids *)
287   -let sync_guids_to_remote_users_thread lifedb syncdb =
288   - let sync_interval = 60. in
289   - let now = Unix.gettimeofday () in
290   - Db_thread_access.throttle_request "sync_guids_to_remote_users" (fun () ->
291   - List.iter (fun user ->
292   - if now -. user#last_sync > sync_interval then begin
293   - sync_our_guids_to_user lifedb syncdb user;
294   - user#set_last_sync (Unix.gettimeofday());
295   - ignore(user#save);
296   - end
297   - ) (SS.User.get syncdb)
298   - )
299   -
300   -(* thread to listen to received syncs from users and look for entries they
301   - need to add to the upload thread *)
302   -let sq = Queue.create ()
303   -let sm = Mutex.create ()
304   -let sc = Condition.create ()
305   -let sync_entries_to_remote_users_thread lifedb syncdb =
306   - with_lock sm (fun () ->
307   - if Queue.is_empty sq then
308   - Condition.wait sc sm;
309   - let useruid = Queue.take sq in
310   - Db_thread_access.throttle_request "sync_entries_to_remote" (fun () ->
311   - find_user syncdb useruid (sync_our_entries_to_user lifedb syncdb)
312   - )
313   - )
314   -
315   -(* received a sync request from another user, so update our has_guids list
316   - * for that user *)
317   -let dispatch_sync lifedb syncdb cgi uid arg =
318   - match SS.User.get ~uid:(Some uid) syncdb with
319   - |[] -> Lifedb_rpc.return_error cgi `Forbidden "Unknown user" ""
320   - |[user] ->
321   - let sync = Rpc.User.sync_of_json (Json_io.json_of_string arg) in
322   - Log.logmod "Sync" "Received GUID update <- %s (%d UIDs)" uid (List.length sync#guids);
323   - user#set_has_guids (blob_of_guids sync#guids);
324   - (* XXX reset the sent guids here? what if remote user has deleted and doesnt want them back *)
325   - user#set_sent_guids (blob_of_guids []);
326   - ignore(user#save);
327   - with_lock sm (fun () ->
328   - Queue.push user#uid sq;
329   - Condition.signal sc;
330   - )
331   - |_ -> assert false
332   -
333   -let thread_with_dbs name fn =
334   - Thread.delay 5.;
335   - let lifedb = LS.Init.t (Lifedb_config.Dir.lifedb_db ()) in
336   - let syncdb = SS.Init.t (Lifedb_config.Dir.sync_db ()) in
337   - while true do
338   - (try
339   - fn lifedb syncdb
340   - with exn ->
341   - Log.logmod "Sync" "Got exception in thread '%s': %s" name (Printexc.to_string exn)
342   - );
343   - Thread.delay 20.
344   - done
345   -
346   -let init () =
347   - let _ = Thread.create (thread_with_dbs "remote_guids") sync_guids_to_remote_users_thread in
348   - let _ = Thread.create (thread_with_dbs "remote_entries") sync_entries_to_remote_users_thread in
349   - let _ = Thread.create upload_thread () in
350   - ()
351   -
5 server.ml
@@ -49,7 +49,6 @@ let _ =
49 49
50 50 (* the task manager thread *)
51 51 Lifedb_tasks.init ();
52   - Lifedb_out_tasks.init ();
53 52
54 53 (* make and display various directories used by the server *)
55 54 List.iter (fun (a,b) ->
@@ -62,10 +61,6 @@ let _ =
62 61 Db_thread.start ();
63 62 Db_thread_access.push `Plugins;
64 63 Db_thread_access.push `Tasks;
65   - Db_thread_access.push `Out_tasks;
66   -
67   - (* start the p2p sync thread *)
68   - Lifedb_user.init ();
69 64
70 65 (* start listening to HTTP connections *)
71 66 Http_server.init ()
399 sync_schema.ml
@@ -228,411 +228,12 @@ module Dircache = struct
228 228
229 229 end
230 230
231   -module Filter_rule = struct
232   - type t = <
233   - id : int64 option;
234   - set_id : int64 option -> unit;
235   - name : string;
236   - set_name : string -> unit;
237   - body : string;
238   - set_body : string -> unit;
239   - zorder : int64;
240   - set_zorder : int64 -> unit;
241   - save: int64; delete: unit
242   - >
243   -
244   - let init db =
245   - let sql = "create table if not exists filter_rule (id integer primary key autoincrement,name text,body text,zorder integer);" in
246   - db_must_ok db (fun () -> Sqlite3.exec db.db sql);
247   - ()
248   -
249   - (* object definition *)
250   - let t ?(id=None) ~name ~body ~zorder db : t = object
251   - (* get functions *)
252   - val mutable _id = id
253   - method id : int64 option = _id
254   - val mutable _name = name
255   - method name : string = _name
256   - val mutable _body = body
257   - method body : string = _body
258   - val mutable _zorder = zorder
259   - method zorder : int64 = _zorder
260   -
261   - (* set functions *)
262   - method set_id v =
263   - _id <- v
264   - method set_name v =
265   - _name <- v
266   - method set_body v =
267   - _body <- v
268   - method set_zorder v =
269   - _zorder <- v
270   -
271   - (* admin functions *)
272   - method delete =
273   - match _id with
274   - |None -> ()
275   - |Some id ->
276   - let sql = "DELETE FROM filter_rule WHERE id=?" in
277   - let stmt = Sqlite3.prepare db.db sql in
278   - db_must_ok db (fun () -> Sqlite3.bind stmt 1 (Sqlite3.Data.INT id));
279   - ignore(step_fold db stmt (fun _ -> ()));
280   - _id <- None
281   -
282   - method save = transaction db (fun () ->
283   - (* insert any foreign-one fields into their table and get id *)
284   - let _curobj_id = match _id with
285   - |None -> (* insert new record *)
286   - let sql = "INSERT INTO filter_rule VALUES(NULL,?,?,?)" in
287   - let stmt = Sqlite3.prepare db.db sql in
288   - db_must_ok db (fun () -> Sqlite3.bind stmt 1 (let v = _name in Sqlite3.Data.TEXT v));
289   - db_must_ok db (fun () -> Sqlite3.bind stmt 2 (let v = _body in Sqlite3.Data.TEXT v));
290   - db_must_ok db (fun () -> Sqlite3.bind stmt 3 (let v = _zorder in Sqlite3.Data.INT v));
291   - db_must_done db (fun () -> Sqlite3.step stmt);
292   - let __id = Sqlite3.last_insert_rowid db.db in
293   - _id <- Some __id;
294   - __id
295   - |Some id -> (* update *)
296   - let sql = "UPDATE filter_rule SET name=?,body=?,zorder=? WHERE id=?" in
297   - let stmt = Sqlite3.prepare db.db sql in
298   - db_must_ok db (fun () -> Sqlite3.bind stmt 1 (let v = _name in Sqlite3.Data.TEXT v));
299   - db_must_ok db (fun () -> Sqlite3.bind stmt 2 (let v = _body in Sqlite3.Data.TEXT v));
300   - db_must_ok db (fun () -> Sqlite3.bind stmt 3 (let v = _zorder in Sqlite3.Data.INT v));
301   - db_must_ok db (fun () -> Sqlite3.bind stmt 4 (Sqlite3.Data.INT id));
302   - db_must_done db (fun () -> Sqlite3.step stmt);
303   - id
304   - in
305   - _curobj_id
306   - )
307   - end
308   -
309   - (* General get function for any of the columns *)
310   - let get ?(id=None) ?(name=None) ?(body=None) ?(zorder=None) ?(custom_where=("",[])) db =
311   - (* assemble the SQL query string *)
312   - let q = "" in
313   - let _first = ref true in
314   - let f () = match !_first with |true -> _first := false; " WHERE " |false -> " AND " in
315   - let q = match id with |None -> q |Some b -> q ^ (f()) ^ "filter_rule.id=?" in
316   - let q = match name with |None -> q |Some b -> q ^ (f()) ^ "filter_rule.name=?" in
317   - let q = match body with |None -> q |Some b -> q ^ (f()) ^ "filter_rule.body=?" in
318   - let q = match zorder with |None -> q |Some b -> q ^ (f()) ^ "filter_rule.zorder=?" in
319   - let q = match custom_where with |"",_ -> q |w,_ -> q ^ (f()) ^ "(" ^ w ^ ")" in
320   - let sql="SELECT filter_rule.id, filter_rule.name, filter_rule.body, filter_rule.zorder FROM filter_rule " ^ q in
321   - let stmt=Sqlite3.prepare db.db sql in
322   - (* bind the position variables to the statement *)
323   - let bindpos = ref 1 in
324   - ignore(match id with |None -> () |Some v ->
325   - db_must_ok db (fun () -> Sqlite3.bind stmt !bindpos (Sqlite3.Data.INT v));
326   - incr bindpos
327   - );
328   - ignore(match name with |None -> () |Some v ->
329   - db_must_ok db (fun () -> Sqlite3.bind stmt !bindpos (Sqlite3.Data.TEXT v));
330   - incr bindpos
331   - );
332   - ignore(match body with |None -> () |Some v ->
333   - db_must_ok db (fun () -> Sqlite3.bind stmt !bindpos (Sqlite3.Data.TEXT v));
334   - incr bindpos
335   - );
336   - ignore(match zorder with |None -> () |Some v ->
337   - db_must_ok db (fun () -> Sqlite3.bind stmt !bindpos (Sqlite3.Data.INT v));
338   - incr bindpos
339   - );
340   - ignore(match custom_where with |_,[] -> () |_,eb ->
341   - List.iter (fun b ->
342   - db_must_ok db (fun () -> Sqlite3.bind stmt !bindpos b);
343   - incr bindpos
344   - ) eb);
345   - (* convert statement into an ocaml object *)
346   - let of_stmt stmt =
347   - t
348   - (* native fields *)
349   - ~id:(
350   - (match Sqlite3.column stmt 0 with
351   - |Sqlite3.Data.NULL -> None
352   - |x -> Some (match x with |Sqlite3.Data.INT i -> i |x -> (try Int64.of_string (Sqlite3.Data.to_string x) with _ -> failwith "error: filter_rule id")))
353   - )
354   - ~name:(
355   - (match Sqlite3.column stmt 1 with
356   - |Sqlite3.Data.NULL -> failwith "null of_stmt"
357   - |x -> Sqlite3.Data.to_string x)
358   - )
359   - ~body:(
360   - (match Sqlite3.column stmt 2 with
361   - |Sqlite3.Data.NULL -> failwith "null of_stmt"
362   - |x -> Sqlite3.Data.to_string x)
363   - )
364   - ~zorder:(
365   - (match Sqlite3.column stmt 3 with
366   - |Sqlite3.Data.NULL -> failwith "null of_stmt"
367   - |x -> match x with |Sqlite3.Data.INT i -> i |x -> (try Int64.of_string (Sqlite3.Data.to_string x) with _ -> failwith "error: filter_rule zorder"))
368   - )
369   - (* foreign fields *)
370   - db
371   - in
372   - (* execute the SQL query *)
373   - step_fold db stmt of_stmt
374   -
375   -end
376   -
377   -module User = struct
378   - type t = <
379   - id : int64 option;
380   - set_id : int64 option -> unit;
381   - uid : string;
382   - set_uid : string -> unit;
383   - ip : string;
384   - set_ip : string -> unit;
385   - port : int64;
386   - set_port : int64 -> unit;
387   - key : string;
388   - set_key : string -> unit;
389   - last_sync : float;
390   - set_last_sync : float -> unit;
391   - has_guids : string;
392   - set_has_guids : string -> unit;
393   - sent_guids : string;
394   - set_sent_guids : string -> unit;
395   - filters : Filter_rule.t list;
396   - set_filters : Filter_rule.t list -> unit;
397   - save: int64; delete: unit
398   - >
399   -
400   - let init db =
401   - let sql = "create table if not exists user (id integer primary key autoincrement,uid text,ip text,port integer,key text,last_sync real,has_guids blob,sent_guids blob);" in
402   - db_must_ok db (fun () -> Sqlite3.exec db.db sql);
403   - let sql = "create table if not exists map_filters_user_filter_rule (user_id integer, filter_rule_id integer, primary key(user_id, filter_rule_id));" in
404   - db_must_ok db (fun () -> Sqlite3.exec db.db sql);
405   - let sql = "CREATE UNIQUE INDEX IF NOT EXISTS user_uid_idx ON user (uid) " in
406   - db_must_ok db (fun () -> Sqlite3.exec db.db sql);
407   - ()
408   -
409   - (* object definition *)
410   - let t ?(id=None) ~uid ~ip ~port ~key ~last_sync ~has_guids ~sent_guids ~filters db : t = object
411   - (* get functions *)
412   - val mutable _id = id
413   - method id : int64 option = _id
414   - val mutable _uid = uid
415   - method uid : string = _uid
416   - val mutable _ip = ip
417   - method ip : string = _ip
418   - val mutable _port = port
419   - method port : int64 = _port
420   - val mutable _key = key
421   - method key : string = _key
422   - val mutable _last_sync = last_sync
423   - method last_sync : float = _last_sync
424   - val mutable _has_guids = has_guids
425   - method has_guids : string = _has_guids
426   - val mutable _sent_guids = sent_guids
427   - method sent_guids : string = _sent_guids
428   - val mutable _filters = filters
429   - method filters : Filter_rule.t list = _filters
430   -
431   - (* set functions *)
432   - method set_id v =
433   - _id <- v
434   - method set_uid v =
435   - _uid <- v
436   - method set_ip v =
437   - _ip <- v
438   - method set_port v =
439   - _port <- v
440   - method set_key v =
441   - _key <- v
442   - method set_last_sync v =
443   - _last_sync <- v
444   - method set_has_guids v =
445   - _has_guids <- v
446   - method set_sent_guids v =
447   - _sent_guids <- v
448   - method set_filters v =
449   - _filters <- v
450   -
451   - (* admin functions *)
452   - method delete =
453   - match _id with
454   - |None -> ()
455   - |Some id ->
456   - let sql = "DELETE FROM user WHERE id=?" in
457   - let stmt = Sqlite3.prepare db.db sql in
458   - db_must_ok db (fun () -> Sqlite3.bind stmt 1 (Sqlite3.Data.INT id));
459   - ignore(step_fold db stmt (fun _ -> ()));
460   - _id <- None
461   -
462   - method save = transaction db (fun () ->
463   - (* insert any foreign-one fields into their table and get id *)
464   - let _curobj_id = match _id with
465   - |None -> (* insert new record *)
466   - let sql = "INSERT INTO user VALUES(NULL,?,?,?,?,?,?,?)" in
467   - let stmt = Sqlite3.prepare db.db sql in
468   - db_must_ok db (fun () -> Sqlite3.bind stmt 1 (let v = _uid in Sqlite3.Data.TEXT v));
469   - db_must_ok db (fun () -> Sqlite3.bind stmt 2 (let v = _ip in Sqlite3.Data.TEXT v));
470   - db_must_ok db (fun () -> Sqlite3.bind stmt 3 (let v = _port in Sqlite3.Data.INT v));
471   - db_must_ok db (fun () -> Sqlite3.bind stmt 4 (let v = _key in Sqlite3.Data.TEXT v));
472   - db_must_ok db (fun () -> Sqlite3.bind stmt 5 (let v = _last_sync in Sqlite3.Data.FLOAT v));
473   - db_must_ok db (fun () -> Sqlite3.bind stmt 6 (let v = _has_guids in Sqlite3.Data.BLOB v));
474   - db_must_ok db (fun () -> Sqlite3.bind stmt 7 (let v = _sent_guids in Sqlite3.Data.BLOB v));
475   - db_must_done db (fun () -> Sqlite3.step stmt);
476   - let __id = Sqlite3.last_insert_rowid db.db in
477   - _id <- Some __id;
478   - __id
479   - |Some id -> (* update *)
480   - let sql = "UPDATE user SET uid=?,ip=?,port=?,key=?,last_sync=?,has_guids=?,sent_guids=? WHERE id=?" in
481   - let stmt = Sqlite3.prepare db.db sql in
482   - db_must_ok db (fun () -> Sqlite3.bind stmt 1 (let v = _uid in Sqlite3.Data.TEXT v));
483   - db_must_ok db (fun () -> Sqlite3.bind stmt 2 (let v = _ip in Sqlite3.Data.TEXT v));
484   - db_must_ok db (fun () -> Sqlite3.bind stmt 3 (let v = _port in Sqlite3.Data.INT v));
485   - db_must_ok db (fun () -> Sqlite3.bind stmt 4 (let v = _key in Sqlite3.Data.TEXT v));
486   - db_must_ok db (fun () -> Sqlite3.bind stmt 5 (let v = _last_sync in Sqlite3.Data.FLOAT v));
487   - db_must_ok db (fun () -> Sqlite3.bind stmt 6 (let v = _has_guids in Sqlite3.Data.BLOB v));
488   - db_must_ok db (fun () -> Sqlite3.bind stmt 7 (let v = _sent_guids in Sqlite3.Data.BLOB v));
489   - db_must_ok db (fun () -> Sqlite3.bind stmt 8 (Sqlite3.Data.INT id));
490   - db_must_done db (fun () -> Sqlite3.step stmt);
491   - id
492   - in
493   - List.iter (fun f ->
494   - let _refobj_id = f#save in
495   - let sql = "INSERT OR IGNORE INTO map_filters_user_filter_rule VALUES(?,?)" in
496   - let stmt = Sqlite3.prepare db.db sql in
497   - db_must_ok db (fun () -> Sqlite3.bind stmt 1 (Sqlite3.Data.INT _curobj_id));
498   - db_must_ok db (fun () -> Sqlite3.bind stmt 2 (Sqlite3.Data.INT _refobj_id));
499   - ignore(step_fold db stmt (fun _ -> ()));
500   - ) _filters;
501   - let ids = String.concat "," (List.map (fun x -> match x#id with |None -> assert false |Some x -> Int64.to_string x) _filters) in
502   - let sql = "DELETE FROM map_filters_user_filter_rule WHERE user_id=? AND (filter_rule_id NOT IN (" ^ ids ^ "))" in
503   - let stmt = Sqlite3.prepare db.db sql in
504   - db_must_ok db (fun () -> Sqlite3.bind stmt 1 (Sqlite3.Data.INT _curobj_id));
505   - ignore(step_fold db stmt (fun _ -> ()));
506   - _curobj_id
507   - )
508   - end
509   -
510   - (* General get function for any of the columns *)
511   - let get ?(id=None) ?(uid=None) ?(ip=None) ?(port=None) ?(key=None) ?(last_sync=None) ?(has_guids=None) ?(sent_guids=None) ?(custom_where=("",[])) db =
512   - (* assemble the SQL query string *)
513   - let q = "" in
514   - let _first = ref true in
515   - let f () = match !_first with |true -> _first := false; " WHERE " |false -> " AND " in
516   - let q = match id with |None -> q |Some b -> q ^ (f()) ^ "user.id=?" in
517   - let q = match uid with |None -> q |Some b -> q ^ (f()) ^ "user.uid=?" in
518   - let q = match ip with |None -> q |Some b -> q ^ (f()) ^ "user.ip=?" in
519   - let q = match port with |None -> q |Some b -> q ^ (f()) ^ "user.port=?" in
520   - let q = match key with |None -> q |Some b -> q ^ (f()) ^ "user.key=?" in
521   - let q = match last_sync with |None -> q |Some b -> q ^ (f()) ^ "user.last_sync=?" in
522   - let q = match has_guids with |None -> q |Some b -> q ^ (f()) ^ "user.has_guids=?" in
523   - let q = match sent_guids with |None -> q |Some b -> q ^ (f()) ^ "user.sent_guids=?" in
524   - let q = match custom_where with |"",_ -> q |w,_ -> q ^ (f()) ^ "(" ^ w ^ ")" in
525   - let sql="SELECT user.id, user.uid, user.ip, user.port, user.key, user.last_sync, user.has_guids, user.sent_guids FROM user " ^ q in
526   - let stmt=Sqlite3.prepare db.db sql in
527   - (* bind the position variables to the statement *)
528   - let bindpos = ref 1 in
529   - ignore(match id with |None -> () |Some v ->
530   - db_must_ok db (fun () -> Sqlite3.bind stmt !bindpos (Sqlite3.Data.INT v));
531   - incr bindpos
532   - );
533   - ignore(match uid with |None -> () |Some v ->