-
Notifications
You must be signed in to change notification settings - Fork 125
/
bslDispatcher.ml
241 lines (216 loc) · 9.31 KB
/
bslDispatcher.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
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
(*
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/>.
*)
open Requestdef
open HttpServerCore_parse
open HttpServerTypes
open HttpServerCore
open HttpServer
open Cps.Ops
module Client = BslPingRegister.Client
module Ping = BslPingRegister.M
module WebChannel = BslSession.WebChannel
module JS = JsonTypes
type json = JS.json
let send_txt_response winfo txt =
make_response_modified_since
(Time.now ())
winfo.HttpServerTypes.request
Requestdef.SC_OK
"text/plain; charset=utf-8"
(Http_common.Result txt)
winfo.HttpServerTypes.cont
let send_json_response winfo json =
let txt = Json_utils.to_string json in
send_txt_response winfo txt
let send_error winfo txt =
let txt = #<If:PING_DEBUG> txt #<Else>
let _ = txt in "Unauthorized request"
#<End>
in
make_response ~req:winfo.HttpServerTypes.request Requestdef.SC_Unauthorized
"text/plain"
(Http_common.Result txt)
winfo.HttpServerTypes.cont
let string2json str =
try
Some (Json_utils.from_string str)
with _ -> None
let get_request_params req = Rcontent.get_content req.HttpServerTypes.request_message_body
##register [cps-bypass] complete_dispatcher_cps : \
string, \
(WebInfo.private.native, continuation(opa[void]) -> void), \
continuation(continuation(WebInfo.private.native)) -> \
void
let complete_dispatcher_cps base_url dispatcher k =
let r = Str.regexp (base_url^"/_internal_/\\([0-9]+\\)/+\\(.*\\)") in
let rec aux_complete_dispatcher winfo =
let uri = winfo.HttpServerTypes.request.HttpServerTypes.request_line.HttpServerTypes.request_uri in
(* Get the page number and remove it from winfo *)
let page, uri, winfo =
if (Str.string_match r uri 0) then
let page = Str.matched_group 1 uri in
let uri = Str.matched_group 2 uri in
let winfo = {
winfo with HttpServerTypes.request = {
winfo.HttpServerTypes.request with HttpServerTypes.request_line = {
winfo.HttpServerTypes.request.HttpServerTypes.request_line with
request_uri = Printf.sprintf "%s/_internal_/%s" base_url uri
}
}
} in
(Some page, (`internal uri), winfo)
else
(None, `user, winfo)
in
let cookie = HttpServer.get_cookie winfo.HttpServerTypes.request in
let page =
match page with
| Some str -> int_of_string str
| None -> Random.int 1073741823 in
let key = Client.key cookie page in
let context = BslUtils.create_ctx
(`client (Client.key_to_record key))
(Some (winfo.HttpServerTypes.request, winfo.HttpServerTypes.connection))
in
let cont_with_context =
QmlCpsServerLib.with_thread_context context
(QmlCpsServerLib.cont_ml (fun _ -> ())) in
let need_cpr f =
let str = (get_request_params (winfo.HttpServerTypes.request)) in
(match string2json str with
| Some json -> Some (f cookie page json)
| None ->
send_error winfo
(Printf.sprintf "This request contains a bad formatted json (%s)" str);
None)
in
match uri with
(* Channel urls **********************)
| `internal "chan/register" ->
Option.default ()
(need_cpr
(fun c p r ->
match r with
| JS.Record [("to_register", to_register);
("uri", JS.String uri);
("body", JS.String body)] ->
if not (WebChannel.registers c p to_register) then
send_error winfo "Error on registering"
else
let winfo = {
winfo with
HttpServerTypes.request = {
winfo.HttpServerTypes.request with
request_line = {
winfo.HttpServerTypes.request.request_line with
request_uri = uri
};
request_message_body = (Rcontent.ContentString body)
};
} in
aux_complete_dispatcher winfo
| _ -> send_error winfo "Bad formatted register")
)
| `internal "chan/send" ->
ignore(Ping.update_activity ~is_active:true key);
Option.iter
(fun () -> send_txt_response winfo "")
(need_cpr (fun c p r -> WebChannel.send c p r (Some context)))
| `internal "chan/remove" ->
ignore (need_cpr WebChannel.remove);
send_json_response winfo (JS.Bool true)
| `internal "chan/sharedaddr" ->
BslSession.SharedChannel.addr @>
(function (ip, port) ->
let addr = Unix.string_of_inet_addr ip in
let res = JS.Record [
("addr", JS.String addr);
("port", JS.Int port);
] in
send_json_response winfo res)
(* Ping urls *************************)
| `internal "ping" ->
Option.default ()
(need_cpr
(fun _ _ r ->
match r with
| JS.Int nb ->
Ping.ping key winfo nb
| _ -> send_error winfo "Bad formatted ping"
)
)
| `internal "pang" ->
Option.default ()
(need_cpr
(fun _ _ r ->
match r with
| JS.Record [("ping", JS.Int nb);
("uri", JS.String uri);
("body", JS.String body)] ->
Ping.pang key winfo nb true;
let winfo = {
winfo with
HttpServerTypes.request = {
winfo.HttpServerTypes.request with
request_line = {
winfo.HttpServerTypes.request.request_line with
request_uri = uri
};
request_header = HttpServer.remove_header (Accept_Encoding "") winfo.request.request_header;
request_message_body = (Rcontent.ContentString body)
};
cont =
(fun response ->
match response.HttpServerTypes.body with
| content ->
Ping.return key nb (Rcontent.get_content content))
(*| Http_common.Result str ->
Ping.return key nb str
| _ ->
Logger.error "Unexpected result on panging";
Ping.return key nb "Unexpected result on panging")*)
} in
aux_complete_dispatcher winfo
| JS.Int nb ->
Ping.pang key winfo nb false
| _ -> send_error winfo "Bad formatted pang"
)
)
| `internal str ->
ignore(Ping.update_activity ~is_active:true key);
let get_id = Str.regexp "rpc_return/\\(.*\\)" in
if ((Str.string_match get_id str 0) && ((Str.matched_string str) = str)) then
let id = Str.matched_group 1 str in
if BslRPC.RPC.return id (get_request_params winfo.HttpServerTypes.request) then (
send_json_response winfo (JS.Bool true);
) else (
send_error winfo (Printf.sprintf "Can't return this rpc %s" id);
)
else
BslScheduler.push (fun () -> dispatcher winfo cont_with_context)
(* User urls *************************)
| `user ->
ignore(Ping.update_activity ~is_active:true key);
BslScheduler.push (fun () -> dispatcher winfo cont_with_context)
in QmlCpsServerLib.return k (QmlCpsServerLib.cont_ml aux_complete_dispatcher)
##register complete_dispatcher : string, (WebInfo.private.native -> void), WebInfo.private.native -> void
let complete_dispatcher base_url dispatcher winfo =
let dispatcher a k =
QmlCpsServerLib.return k (dispatcher a) in
let r = ref None in
let k = QmlCpsServerLib.cont_ml (fun x -> r := Some x) in
complete_dispatcher_cps base_url dispatcher k;
match !r with
| None -> failwith ("dispatcher was not computed - Do you use no cps?")
| Some wcont -> QmlCpsServerLib.execute wcont winfo