-
Notifications
You must be signed in to change notification settings - Fork 125
/
bslUtils.ml
112 lines (90 loc) · 4.26 KB
/
bslUtils.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
(*
Copyright © 2011 MLstate
This file is part of OPA.
OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.
OPA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.
You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
(** This module provide some common utils and types for bsl modules : projection, ...*)
(* Field names, used when creating OPA-understandable records.*)
let fnone = ServerLib.static_field_of_name "none"
let fsome = ServerLib.static_field_of_name "some"
let fkey = ServerLib.static_field_of_name "key"
let freq = ServerLib.static_field_of_name "request"
let fcon = ServerLib.static_field_of_name "connexion"
let fdetails = ServerLib.static_field_of_name "details"
let fconstraint = ServerLib.static_field_of_name "constraint"
let fclient = ServerLib.static_field_of_name "client"
let fserver = ServerLib.static_field_of_name "server"
let fnothing = ServerLib.static_field_of_name "nothing"
let fsuccess = ServerLib.static_field_of_name "success"
let ffailure = ServerLib.static_field_of_name "failure"
let ffree = ServerLib.static_field_of_name "free"
let fno_client_calls = ServerLib.static_field_of_name "no_client_calls"
let rnone = ServerLib.make_record (ServerLib.add_field ServerLib.empty_record_constructor (fnone) (ServerLib.make_record ServerLib.empty_record_constructor))
let rsome x = ServerLib.make_record (ServerLib.add_field ServerLib.empty_record_constructor (fsome) x)
let rclient x = ServerLib.make_record (ServerLib.add_field ServerLib.empty_record_constructor (fclient) x)
let rserver x = ServerLib.make_record (ServerLib.add_field ServerLib.empty_record_constructor (fserver) x)
let rnothing = ServerLib.make_record (ServerLib.add_field ServerLib.empty_record_constructor (fnone) (ServerLib.make_record ServerLib.empty_record_constructor))
let rfree = ServerLib.make_record (ServerLib.add_field ServerLib.empty_record_constructor (ffree) (ServerLib.make_record ServerLib.empty_record_constructor))
##opa-type ThreadContext.t
##opa-type ThreadContext.client
##opa-type outcome('a, 'b)
(** Project an ['a -> void] opa function rewrited by cps to an ['a ->
unit] ml function, usefull for [cps-bypass].
['a, continuation(opa[void]) -> void] => ['a -> unit]
@param pk Parent continuation
*)
let proj_cps pk f =
fun x -> f x (QmlCpsServerLib.ccont_ml pk (fun (_:ServerLib.ty_void) -> ()))
let proj_cps0 pk f =
fun () -> f (QmlCpsServerLib.ccont_ml pk (fun (_:ServerLib.ty_void) -> ()))
(** Create an opa thread context *)
(* ThreadContext: Be careful, Thread context is hard coded here. Change it if you change type *)
let create_ctx key request =
let rkey = match key with
| `client client -> rclient client
| `server server -> rserver server
| `nothing -> rnothing in
let rreq = match request with
| None -> rnone
| Some (req, con) ->
let req (*opa HttpRequest.request *) =
ServerLib.make_record (
ServerLib.add_field (
ServerLib.add_field
ServerLib.empty_record_constructor
freq req)
fcon con)
in
rsome req in
let rdetails = rnone in
let rconstraint = rfree in
ServerLib.make_record
(ServerLib.add_field
(ServerLib.add_field
(ServerLib.add_field
(ServerLib.add_field ServerLib.empty_record_constructor (fkey) rkey)
(freq) rreq)
(fdetails) rdetails)
(fconstraint) rconstraint)
let get_serverkey context =
let rkey = ServerLib.unsafe_dot context fkey in
ServerLib.dot rkey fserver
let create_outcome = function
| `success success ->
wrap_opa_outcome
(ServerLib.make_record
(ServerLib.add_field ServerLib.empty_record_constructor
fsuccess success))
| `failure failure ->
wrap_opa_outcome
(ServerLib.make_record
(ServerLib.add_field ServerLib.empty_record_constructor
ffailure failure))