Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 166 lines (142 sloc) 6.747 kb
fccc685 Initial open-source release
MLstate authored
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
22 module Dialog = Badop_lib.Dialog
23 module Dialog_aux = Badop_lib.Dialog_aux
24
25 (** This file defines types used for message exchange between Badop_server and
26 Badop_client. As thus it's shared between the two *)
27
28 (* on non-asynchronous cps function, masquerade the result in the return value to get it back *)
29 let nocps : (('a -> unit) -> unit) -> 'a = fun f ->
30 let (r: unit) = f (fun x -> (Obj.magic x : unit)) in
31 Obj.magic r
32
33 module F
34 (Host : sig
35 type spoken
36 type understood
37 type revision
38 end)
39 =
40 struct
41 type revision = Host.revision
42
114c5ec [enhance] database client/server: much more efficient protocol
Louis Gesbert authored
43 type tr_version = int
44
fccc685 Initial open-source release
MLstate authored
45 type 'which read_op = ('which,revision) Badop.generic_read_op
46
114c5ec [enhance] database client/server: much more efficient protocol
Louis Gesbert authored
47 type 'which internal_write_op = ('which,unit,revision) Badop.generic_write_op
fccc685 Initial open-source release
MLstate authored
48
49 (* 'transaction is a parameter, because we change it to string when we want to serialise *)
114c5ec [enhance] database client/server: much more efficient protocol
Louis Gesbert authored
50 type ('which,'transaction_channel) poly_transaction_op =
fccc685 Initial open-source release
MLstate authored
51 | Read of Badop.path
114c5ec [enhance] database client/server: much more efficient protocol
Louis Gesbert authored
52 * ('which, tr_version * Dialog.query read_op, Dialog.response read_op Badop.answer) Dialog.t
53 | Write of Badop.path * tr_version * 'which internal_write_op
54 | WriteList of tr_version * ('which, (Badop.path * Dialog.query internal_write_op) list, unit) Dialog.t
55 | Prepare of ('which, tr_version, bool) Dialog.t
56 | Commit of ('which, tr_version, bool) Dialog.t
57 | Abort of ('which, tr_version, unit) Dialog.t
58 | Fork of ('which, tr_version, 'transaction_channel) Dialog.t
59
60 type transaction_channel =
61 ((Host.spoken,transaction_channel) poly_transaction_op, (Host.understood,transaction_channel) poly_transaction_op)
fccc685 Initial open-source release
MLstate authored
62 Hlnet.channel
63
114c5ec [enhance] database client/server: much more efficient protocol
Louis Gesbert authored
64 type 'which transaction_op =
65 ('which,transaction_channel) poly_transaction_op
66
67 type transaction = {
68 channel : transaction_channel;
69 version : tr_version;
70 mutable last : bool;
71 }
fccc685 Initial open-source release
MLstate authored
72
114c5ec [enhance] database client/server: much more efficient protocol
Louis Gesbert authored
73 type 'which write_op = ('which,transaction,revision) Badop.generic_write_op
fccc685 Initial open-source release
MLstate authored
74
75 type 'which database_query =
114c5ec [enhance] database client/server: much more efficient protocol
Louis Gesbert authored
76 | Transaction of ('which, unit, transaction_channel) Dialog.t
77 | Transaction_at of ('which, revision, transaction_channel) Dialog.t
fccc685 Initial open-source release
MLstate authored
78 | Status of ('which, unit, Badop.status) Dialog.t
79
114c5ec [enhance] database client/server: much more efficient protocol
Louis Gesbert authored
80
fccc685 Initial open-source release
MLstate authored
81 (* Just maps on transactions *)
82 let map_transaction_op
83 : 'which 'transaction1 'transaction2.
84 ('transaction1 -> 'transaction2) -> ('which,'transaction1) poly_transaction_op
85 -> ('which,'transaction2) poly_transaction_op
86 = fun f op ->
87 match op with
114c5ec [enhance] database client/server: much more efficient protocol
Louis Gesbert authored
88 | Write (path, v, internal_write_op) -> Write (path, v, internal_write_op)
89 | WriteList (v, dialog) -> WriteList (v, dialog)
90 | Prepare dialog -> Prepare dialog
fccc685 Initial open-source release
MLstate authored
91 | Read (path, op) -> Read (path, op)
92 | Commit op -> Commit op
93 | Abort op -> Abort op
114c5ec [enhance] database client/server: much more efficient protocol
Louis Gesbert authored
94 | Fork dialog ->
95 let dialog = nocps
96 (Dialog_aux.map_dialog ~query:(fun x k -> k x) ~response:(fun tr k -> k (f tr)) dialog)
97 in
98 Fork dialog
fccc685 Initial open-source release
MLstate authored
99
100 (* We need to expand this functions even if we use marshal internally, because
101 embedded transactions need to be processed through
102 [Hlnet.channel_(un)serialise]. Maybe a map on the operation type to bind
103 'transaction to string and back just for the transmission would be nicer. *)
104 let transaction_op_serialise
105 : 'which transaction_op -> string
106 = fun op ->
107 Marshal.to_string (map_transaction_op Hlnet.serialise_channel op : ('which,string) poly_transaction_op) []
108 let rec transaction_op_unserialise
109 : ('a,'b) Hlnet.channel -> 'which transaction_op Hlnet.stream_unserialise
110 = fun channel s offset ->
111 let unserialise_channel tr =
112 match Hlnet.unserialise_remote_channel transaction_channel_spec channel tr 0
113 with `data (x,_) -> x | _ -> raise Exit
114 in
115 try
116 Hlnet.Aux.map_unserialise (map_transaction_op unserialise_channel) Hlnet.Aux.magic_unserialise
117 s offset
118 with Exit -> `failure "Bad embedded transaction"
119 and transaction_channel_spec
120 : (Host.spoken transaction_op, Host.understood transaction_op) Hlnet.channel_spec
121 = {
122 Hlnet.
114c5ec [enhance] database client/server: much more efficient protocol
Louis Gesbert authored
123 service = Hlnet.make_service_id ~name:"badop/trans" ~version:2;
fccc685 Initial open-source release
MLstate authored
124 out_serialise = transaction_op_serialise;
125 in_unserialise = transaction_op_unserialise;
126 }
127
128 let database_op_serialise = function
129 | Transaction (Dialog.Query ()) -> "\000"
130 | Transaction (Dialog.Response transaction) -> "\100" ^ Hlnet.serialise_channel transaction
131 | Transaction_at (Dialog.Query rev) -> "\001" ^ Marshal.to_string rev []
132 | Transaction_at (Dialog.Response transaction) -> "\101" ^ Hlnet.serialise_channel transaction
133 | Status (Dialog.Query ()) -> "\002"
134 | Status (Dialog.Response status) -> "\102" ^ Marshal.to_string status []
114c5ec [enhance] database client/server: much more efficient protocol
Louis Gesbert authored
135
fccc685 Initial open-source release
MLstate authored
136 let database_op_unserialise channel s offset = match s.[offset] with
137 | '\000' -> `data (Transaction (Dialog_aux.make_unsafe_query ()), offset + 1)
138 | '\100' ->
139 Hlnet.Aux.map_unserialise (fun tr -> Transaction (Dialog_aux.make_unsafe_response tr))
140 (Hlnet.unserialise_remote_channel transaction_channel_spec channel)
141 s (offset+1)
142 | '\001' ->
143 Hlnet.Aux.map_unserialise
144 (fun (rev:revision) -> Transaction_at (Dialog_aux.make_unsafe_query rev)) Hlnet.Aux.magic_unserialise s (offset+1)
145 | '\101' ->
146 Hlnet.Aux.map_unserialise (fun tr -> Transaction_at (Dialog_aux.make_unsafe_response tr))
147 (Hlnet.unserialise_remote_channel transaction_channel_spec channel)
148 s (offset+1)
149 | '\002' -> `data (Status (Dialog_aux.make_unsafe_query ()), offset + 1)
150 | '\102' ->
151 Hlnet.Aux.map_unserialise (fun st -> Status (Dialog_aux.make_unsafe_response st))
152 (Hlnet.Aux.magic_unserialise)
153 s (offset+1)
154 | _ -> `failure "Bad database message"
155
156 type database = (Host.spoken database_query, Host.understood database_query) Hlnet.channel
157 let database_channel_spec
158 : (Host.spoken database_query, Host.understood database_query) Hlnet.channel_spec
159 = {
160 Hlnet.
114c5ec [enhance] database client/server: much more efficient protocol
Louis Gesbert authored
161 service = Hlnet.make_service_id ~name:"badop/db" ~version:2;
fccc685 Initial open-source release
MLstate authored
162 out_serialise = database_op_serialise;
163 in_unserialise = database_op_unserialise;
164 }
165 end
Something went wrong with that request. Please try again.