Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 169 lines (148 sloc) 6.971 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
43 type 'which read_op = ('which,revision) Badop.generic_read_op
44
45 type ('which,'transaction) poly_write_op = ('which,'transaction,revision) Badop.generic_write_op
46
47 (* 'transaction is a parameter, because we change it to string when we want to serialise *)
48 type ('which,'transaction) poly_transaction_op =
49 | Read of Badop.path
50 * ('which, Dialog.query read_op, Dialog.response read_op Badop.answer) Dialog.t
51 | Write of Badop.path
52 * ('which,'transaction) poly_write_op
53 | WriteList of ('which, (Badop.path * (Dialog.query,'transaction) poly_write_op) list, 'transaction) Dialog.t
54 | Prepare of ('which, unit, 'transaction * bool) Dialog.t
55 | Commit of ('which, unit, bool) Dialog.t
56 | Abort of ('which, unit, unit) Dialog.t
57
58 type transaction = (* needs rectypes *)
59 ((Host.spoken,transaction) poly_transaction_op, (Host.understood,transaction) poly_transaction_op)
60 Hlnet.channel
61
62 type 'which write_op = ('which,transaction) poly_write_op
63
64 type 'which transaction_op = ('which,transaction) poly_transaction_op
65
66 type 'which database_query =
67 | Transaction of ('which, unit, transaction) Dialog.t
68 | Transaction_at of ('which, revision, transaction) Dialog.t
69 | Status of ('which, unit, Badop.status) Dialog.t
70
71 (* Just maps on transactions *)
72 let map_transaction_op
73 : 'which 'transaction1 'transaction2.
74 ('transaction1 -> 'transaction2) -> ('which,'transaction1) poly_transaction_op
75 -> ('which,'transaction2) poly_transaction_op
76 = fun f op ->
77 let map_write_op
78 : 'which 't1 't2. ('t1 -> 't2) -> ('which,'t1) poly_write_op -> ('which,'t2) poly_write_op
79 = fun f op ->
80 nocps
81 (Badop.Aux.map_write_op ~transaction:(fun tr k -> k (f tr)) ~revision:(fun x k -> k x) op)
82 in
83 match op with
84 | Write (path, write_op) ->
85 Write (path, map_write_op f write_op)
86 | WriteList (dialog) ->
87 let dialog = nocps
88 (Dialog_aux.map_dialog
89 ~query:(fun oplist k -> k (List.map (fun (path,op) -> path, map_write_op f op) oplist))
90 ~response:(fun tr k -> k (f tr))
91 dialog)
92 in
93 WriteList dialog
94 | Prepare dialog ->
95 let dialog = nocps
96 (Dialog_aux.map_dialog ~query:(fun x k -> k x) ~response:(fun (tr,ok) k -> k (f tr, ok)) dialog)
97 in
98 Prepare dialog
99 | Read (path, op) -> Read (path, op)
100 | Commit op -> Commit op
101 | Abort op -> Abort op
102
103 (* We need to expand this functions even if we use marshal internally, because
104 embedded transactions need to be processed through
105 [Hlnet.channel_(un)serialise]. Maybe a map on the operation type to bind
106 'transaction to string and back just for the transmission would be nicer. *)
107 let transaction_op_serialise
108 : 'which transaction_op -> string
109 = fun op ->
110 Marshal.to_string (map_transaction_op Hlnet.serialise_channel op : ('which,string) poly_transaction_op) []
111 let rec transaction_op_unserialise
112 : ('a,'b) Hlnet.channel -> 'which transaction_op Hlnet.stream_unserialise
113 = fun channel s offset ->
114 let unserialise_channel tr =
115 match Hlnet.unserialise_remote_channel transaction_channel_spec channel tr 0
116 with `data (x,_) -> x | _ -> raise Exit
117 in
118 try
119 Hlnet.Aux.map_unserialise (map_transaction_op unserialise_channel) Hlnet.Aux.magic_unserialise
120 s offset
121 with Exit -> `failure "Bad embedded transaction"
122 and transaction_channel_spec
123 : (Host.spoken transaction_op, Host.understood transaction_op) Hlnet.channel_spec
124 = {
125 Hlnet.
126 service = Hlnet.make_service_id ~name:"badop/trans" ~version:1;
127 out_serialise = transaction_op_serialise;
128 in_unserialise = transaction_op_unserialise;
129 }
130
131
132 let database_op_serialise = function
133 | Transaction (Dialog.Query ()) -> "\000"
134 | Transaction (Dialog.Response transaction) -> "\100" ^ Hlnet.serialise_channel transaction
135 | Transaction_at (Dialog.Query rev) -> "\001" ^ Marshal.to_string rev []
136 | Transaction_at (Dialog.Response transaction) -> "\101" ^ Hlnet.serialise_channel transaction
137 | Status (Dialog.Query ()) -> "\002"
138 | Status (Dialog.Response status) -> "\102" ^ Marshal.to_string status []
139 let database_op_unserialise channel s offset = match s.[offset] with
140 | '\000' -> `data (Transaction (Dialog_aux.make_unsafe_query ()), offset + 1)
141 | '\100' ->
142 Hlnet.Aux.map_unserialise (fun tr -> Transaction (Dialog_aux.make_unsafe_response tr))
143 (Hlnet.unserialise_remote_channel transaction_channel_spec channel)
144 s (offset+1)
145 | '\001' ->
146 Hlnet.Aux.map_unserialise
147 (fun (rev:revision) -> Transaction_at (Dialog_aux.make_unsafe_query rev)) Hlnet.Aux.magic_unserialise s (offset+1)
148 | '\101' ->
149 Hlnet.Aux.map_unserialise (fun tr -> Transaction_at (Dialog_aux.make_unsafe_response tr))
150 (Hlnet.unserialise_remote_channel transaction_channel_spec channel)
151 s (offset+1)
152 | '\002' -> `data (Status (Dialog_aux.make_unsafe_query ()), offset + 1)
153 | '\102' ->
154 Hlnet.Aux.map_unserialise (fun st -> Status (Dialog_aux.make_unsafe_response st))
155 (Hlnet.Aux.magic_unserialise)
156 s (offset+1)
157 | _ -> `failure "Bad database message"
158
159 type database = (Host.spoken database_query, Host.understood database_query) Hlnet.channel
160 let database_channel_spec
161 : (Host.spoken database_query, Host.understood database_query) Hlnet.channel_spec
162 = {
163 Hlnet.
164 service = Hlnet.make_service_id ~name:"badop/db" ~version:1;
165 out_serialise = database_op_serialise;
166 in_unserialise = database_op_unserialise;
167 }
168 end
Something went wrong with that request. Please try again.