Skip to content
This repository
Newer
Older
100644 207 lines (176 sloc) 8.508 kb
4e1fc79d » nrs135
2011-06-21 [feature] Badop_cache: Cloned from Badop_stash.
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 (*
19 @author Louis Gesbert
20 **)
21
666a08e7 » nrs135
2011-06-23 [feature] database: Implemented read cache update on write.
22 module String = Base.String
23 module List = Base.List
24 module Hashtbl = Base.Hashtbl
4e1fc79d » nrs135
2011-06-21 [feature] Badop_cache: Cloned from Badop_stash.
25 module Dialog = Badop_lib.Dialog
666a08e7 » nrs135
2011-06-23 [feature] database: Implemented read cache update on write.
26 module Dialog_aux = Badop_lib.Dialog_aux
4e1fc79d » nrs135
2011-06-21 [feature] Badop_cache: Cloned from Badop_stash.
27 let (@>) = Cps.Ops.(@>)
28 let (|>) = Cps.Ops.(|>)
f77847f4 » nrs135
2011-06-24 [fix] database: Badop_cache path type now from Badop.
29 let sprintf fmt = Printf.sprintf fmt
30 let path_to_string = Badop.Aux.path_to_string
666a08e7 » nrs135
2011-06-23 [feature] database: Implemented read cache update on write.
31
32 module F (Bk: Badop.S) =
33 struct
4e1fc79d » nrs135
2011-06-21 [feature] Badop_cache: Cloned from Badop_stash.
34
35 type database = Bk.database
666a08e7 » nrs135
2011-06-23 [feature] database: Implemented read cache update on write.
36
4e1fc79d » nrs135
2011-06-21 [feature] Badop_cache: Cloned from Badop_stash.
37 type transaction_status = Fresh | Changed | Prepared | Committed | Failed
666a08e7 » nrs135
2011-06-23 [feature] database: Implemented read cache update on write.
38
39 type revision = Bk.revision
40
41 type 'which read_op = ('which,revision) Badop.generic_read_op
42
43 type ans = Badop.Dialog.response Bk.read_op Badop.answer
44
45 type cache_entry =
46 | CacheAnswer of (Dialog.query read_op * ans) list
f77847f4 » nrs135
2011-06-24 [fix] database: Badop_cache path type now from Badop.
47 | CacheLink of Badop.path
666a08e7 » nrs135
2011-06-23 [feature] database: Implemented read cache update on write.
48
4e1fc79d » nrs135
2011-06-21 [feature] Badop_cache: Cloned from Badop_stash.
49 type transaction = { (* Extended transaction (called xtr below) *)
50 db: Bk.database;
51 status: transaction_status;
52 tr: Bk.transaction option;
53 stash: (Badop.path * Dialog.query Bk.write_op) list;
7c00c9ce » nrs135
2011-07-08 [fix] database: Fixed after rebase, added error continuation.
54 errk: exn -> unit;
666a08e7 » nrs135
2011-06-23 [feature] database: Implemented read cache update on write.
55 cache: (Badop.path, cache_entry) Hashtbl.t;
4e1fc79d » nrs135
2011-06-21 [feature] Badop_cache: Cloned from Badop_stash.
56 }
666a08e7 » nrs135
2011-06-23 [feature] database: Implemented read cache update on write.
57
58 type 'which write_op = ('which,transaction,revision) Badop.generic_write_op
4e1fc79d » nrs135
2011-06-21 [feature] Badop_cache: Cloned from Badop_stash.
59
60 let open_database = Bk.open_database
61 let close_database = Bk.close_database
62 let status db k = Bk.status db @> fun st -> Badop.Layer("Cache", st) |> k
63
64 let get_tr xtr k = match xtr.tr with
7c00c9ce » nrs135
2011-07-08 [fix] database: Fixed after rebase, added error continuation.
65 | None -> Bk.Tr.start xtr.db xtr.errk @> k
4e1fc79d » nrs135
2011-06-21 [feature] Badop_cache: Cloned from Badop_stash.
66 | Some tr -> tr |> k
67
68 let flush xtr k = match xtr.stash with
69 | [] -> xtr |> k
70 | l ->
71 get_tr xtr
72 @> fun tr -> Bk.write_list tr (List.rev l)
666a08e7 » nrs135
2011-06-23 [feature] database: Implemented read cache update on write.
73 @> fun tr -> { xtr with tr = Some tr; status = Changed; stash = [] } |> k
74
75 module Tr =
76 struct
4e1fc79d » nrs135
2011-06-21 [feature] Badop_cache: Cloned from Badop_stash.
77
7c00c9ce » nrs135
2011-07-08 [fix] database: Fixed after rebase, added error continuation.
78 let start db errk k =
79 { db = db; tr = None; errk = errk; status = Fresh; stash = []; cache = Hashtbl.create 128; } |> k
666a08e7 » nrs135
2011-06-23 [feature] database: Implemented read cache update on write.
80
7c00c9ce » nrs135
2011-07-08 [fix] database: Fixed after rebase, added error continuation.
81 let start_at_revision db rev errk k =
82 Bk.Tr.start_at_revision db rev errk
83 @> fun tr -> { db = db; tr = Some tr; errk = errk; status = Fresh; stash = []; cache = Hashtbl.create 128; } |> k
666a08e7 » nrs135
2011-06-23 [feature] database: Implemented read cache update on write.
84
4e1fc79d » nrs135
2011-06-21 [feature] Badop_cache: Cloned from Badop_stash.
85 let prepare xtr k =
86 flush xtr
87 @> fun xtr ->
88 match xtr.status with
89 | Changed ->
90 get_tr xtr
91 @> fun tr -> Bk.Tr.prepare tr
666a08e7 » nrs135
2011-06-23 [feature] database: Implemented read cache update on write.
92 @> fun (tr,ok) -> ({ xtr with tr = Some tr; status = if ok then Prepared else Failed}, ok) |> k
4e1fc79d » nrs135
2011-06-21 [feature] Badop_cache: Cloned from Badop_stash.
93 | Fresh | Prepared -> (xtr,true) |> k
94 | Failed | Committed -> (xtr,false) |> k
666a08e7 » nrs135
2011-06-23 [feature] database: Implemented read cache update on write.
95
4e1fc79d » nrs135
2011-06-21 [feature] Badop_cache: Cloned from Badop_stash.
96 let rec commit xtr k =
97 match xtr.status with
98 | Prepared ->
99 assert(xtr.stash = []);
100 get_tr xtr @> fun tr -> Bk.Tr.commit tr @> k
101 | Changed ->
666a08e7 » nrs135
2011-06-23 [feature] database: Implemented read cache update on write.
102 prepare xtr
103 @> fun (xtr,ok) ->
104 if ok
105 then get_tr xtr
106 @> fun tr -> Bk.Tr.commit tr
107 @> k
108 else false |> k
4e1fc79d » nrs135
2011-06-21 [feature] Badop_cache: Cloned from Badop_stash.
109 | Fresh ->
666a08e7 » nrs135
2011-06-23 [feature] database: Implemented read cache update on write.
110 if xtr.stash = []
111 then true |> k
112 else flush xtr
113 @> fun xtr -> commit xtr
114 @> k
4e1fc79d » nrs135
2011-06-21 [feature] Badop_cache: Cloned from Badop_stash.
115 | Committed -> true |> k
116 | Failed -> false |> k
117
118 let abort xtr k =
119 match xtr.status with
120 | Failed | Committed -> () |> k
121 | _ -> match xtr.tr with Some tr -> Bk.Tr.abort tr @> k | None -> () |> k
122
666a08e7 » nrs135
2011-06-23 [feature] database: Implemented read cache update on write.
123 end
4e1fc79d » nrs135
2011-06-21 [feature] Badop_cache: Cloned from Badop_stash.
124
666a08e7 » nrs135
2011-06-23 [feature] database: Implemented read cache update on write.
125 (* For debug, we can get rid of this later... *)
126 let string_of_DLU = function `Data -> "Data" | `Link -> "Link" | `Unset -> "Unset" | _ -> assert false
127 let string_of_time t = Date.rfc1123 (Time.localtime t)
128 let string_of_range (to_string:'a -> string) ((ao,i):'a Badop.range) = sprintf "(%s,%d)" (Option.to_string to_string ao) i
129 let string_of_gro = function
130 | Badop.Stat (Dialog.Query ()) -> "Query(Stat())"
131 | Badop.Stat (Dialog.Response (path, rev_opt, _DLU)) ->
132 sprintf "Response(Stat(%s,%s,%s))"
f77847f4 » nrs135
2011-06-24 [fix] database: Badop_cache path type now from Badop.
133 (path_to_string path) (Option.to_string Bk.Debug.revision_to_string rev_opt) (string_of_DLU _DLU)
666a08e7 » nrs135
2011-06-23 [feature] database: Implemented read cache update on write.
134 | Badop.Contents (Dialog.Query ()) -> "Query(Contents())"
135 | Badop.Contents (Dialog.Response data) -> sprintf "Response(Contents(%s))" (DataImpl.to_string data)
136 | Badop.Children (Dialog.Query key_range) -> sprintf "Query(Children(%s))" (string_of_range Keys.to_string key_range)
137 | Badop.Children (Dialog.Response path_list) ->
f77847f4 » nrs135
2011-06-24 [fix] database: Badop_cache path type now from Badop.
138 sprintf "Response(Children([%s]))" (String.concat_map "; " path_to_string path_list)
666a08e7 » nrs135
2011-06-23 [feature] database: Implemented read cache update on write.
139 | Badop.Revisions (Dialog.Query rev_range) ->
140 sprintf "Query(Children(%s))" (string_of_range Bk.Debug.revision_to_string rev_range)
141 | Badop.Revisions (Dialog.Response rtl) ->
142 sprintf "Response(Children([%s]))"
143 (String.concat_map "; " (fun (r,t) -> sprintf "(%s,%s)" (Bk.Debug.revision_to_string r) (string_of_time t)) rtl)
144 | Badop.Search (Dialog.Query (sl,ir)) ->
145 sprintf "Query(Search([%s],%s))" (String.concat "; " sl) (string_of_range string_of_int ir)
146 | Badop.Search (Dialog.Response kl) -> sprintf "Response(Search([%s]))" (String.concat_map "; " Keys.to_string kl)
147
148 let really_read ans_list xtr path read_op k =
4e1fc79d » nrs135
2011-06-21 [feature] Badop_cache: Cloned from Badop_stash.
149 flush xtr
666a08e7 » nrs135
2011-06-23 [feature] database: Implemented read cache update on write.
150 @> fun xtr -> get_tr xtr
151 @> fun tr -> Badop.Aux.map_read_op ~revision:(fun r k -> r |> k) read_op
152 @> fun bk_read_op -> Bk.read tr path bk_read_op
153 @> fun ans ->
f77847f4 » nrs135
2011-06-24 [fix] database: Badop_cache path type now from Badop.
154 #<If:BADOP_DEBUG$minlevel 10>Logger.debug "CACHING(%s,%s)" (path_to_string path) (string_of_gro read_op)#<End>;
666a08e7 » nrs135
2011-06-23 [feature] database: Implemented read cache update on write.
155 Hashtbl.replace xtr.cache path (CacheAnswer ((read_op,ans)::ans_list));
156 ans |> k
157
158 let rec read xtr path read_op k =
159 match Hashtbl.find_opt xtr.cache path with
160 | Some (CacheAnswer ans_list) ->
161 (match List.assoc_opt read_op ans_list with
162 | Some ans ->
f77847f4 » nrs135
2011-06-24 [fix] database: Badop_cache path type now from Badop.
163 #<If:BADOP_DEBUG$minlevel 10>Logger.debug "CACHED(%s,%s)" (path_to_string path) (string_of_gro read_op)#<End>;
666a08e7 » nrs135
2011-06-23 [feature] database: Implemented read cache update on write.
164 ans |> k
165 | None -> really_read ans_list xtr path read_op k)
166 | Some (CacheLink p) ->
f77847f4 » nrs135
2011-06-24 [fix] database: Badop_cache path type now from Badop.
167 #<If:BADOP_DEBUG$minlevel 10>Logger.debug "FOLLOWING(%s)" (path_to_string p)#<End>;
666a08e7 » nrs135
2011-06-23 [feature] database: Implemented read cache update on write.
168 read xtr p read_op k
169 | None -> really_read [] xtr path read_op k
4e1fc79d » nrs135
2011-06-21 [feature] Badop_cache: Cloned from Badop_stash.
170
171 let write xtr path write_op k =
666a08e7 » nrs135
2011-06-23 [feature] database: Implemented read cache update on write.
172 (* We make some effort to update the read cache but mostly we just stomp on it *)
173 (match write_op with
174 | Badop.Set (Dialog.Query data) ->
175 let gro = Badop.Contents (Dialog_aux.make_unsafe_response data) in
f77847f4 » nrs135
2011-06-24 [fix] database: Badop_cache path type now from Badop.
176 #<If:BADOP_DEBUG$minlevel 10>Logger.debug "UPDATED(%s,%s)" (path_to_string path) (string_of_gro gro)#<End>;
666a08e7 » nrs135
2011-06-23 [feature] database: Implemented read cache update on write.
177 Hashtbl.replace xtr.cache path (CacheAnswer[(Badop.Contents (Dialog_aux.make_unsafe_query ()),`Answer gro)
178 (* Can't add stat here because we can't predict the revision *)])
179 | Badop.Clear (Dialog.Query ()) ->
f77847f4 » nrs135
2011-06-24 [fix] database: Badop_cache path type now from Badop.
180 #<If:BADOP_DEBUG$minlevel 10>Logger.debug "CLEARED(%s)" (path_to_string path)#<End>;
666a08e7 » nrs135
2011-06-23 [feature] database: Implemented read cache update on write.
181 Hashtbl.replace xtr.cache path (CacheAnswer [(Badop.Contents (Dialog_aux.make_unsafe_query ()),`Absent);
182 (Badop.Stat (Dialog_aux.make_unsafe_query ()),`Absent)])
183 | Badop.Link (Dialog.Query p) ->
f77847f4 » nrs135
2011-06-24 [fix] database: Badop_cache path type now from Badop.
184 #<If:BADOP_DEBUG$minlevel 10>Logger.debug "LINKED(%s->%s)" (path_to_string path) (path_to_string p)#<End>;
666a08e7 » nrs135
2011-06-23 [feature] database: Implemented read cache update on write.
185 Hashtbl.replace xtr.cache path (CacheLink p)
186 (*| Badop.Copy (Dialog.Query _) ???*)
187 | _ ->
f77847f4 » nrs135
2011-06-24 [fix] database: Badop_cache path type now from Badop.
188 #<If:BADOP_DEBUG$minlevel 10>Logger.debug "INVALIDATED(%s)" (path_to_string path)#<End>;
666a08e7 » nrs135
2011-06-23 [feature] database: Implemented read cache update on write.
189 Hashtbl.remove xtr.cache path);
4e1fc79d » nrs135
2011-06-21 [feature] Badop_cache: Cloned from Badop_stash.
190 Badop.Aux.map_write_op ~transaction:(fun xtr k -> get_tr xtr @> k) ~revision:(fun r k -> r |> k) write_op
191 (* only for types, no tr in queries *)
192 @> fun bk_write_op ->
193 Badop.Aux.respond_set_transaction write_op { xtr with stash = (path,bk_write_op)::xtr.stash }
194 |> k
195
196 let write_list xtr path_write_op_list k =
197 let wr xtr (path, op) k =
198 write xtr path op @> fun resp -> Badop.Aux.result_transaction resp |> k
199 in
200 Cps.List.fold wr xtr path_write_op_list k
201
202 let node_properties db config k = Bk.node_properties db config @> k
203
204 module Debug = struct
205 let revision_to_string = Bk.Debug.revision_to_string
206 end
207 end
Something went wrong with that request. Please try again.