Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 158 lines (119 sloc) 6.521 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 (* This module defin bypasse defined for Hlnet use on opa,
19 "synchronous" (according cps), and asynchronous (for s2 compatibility)
20 *)
21
22 module C = QmlCpsServerLib
23 open C.Ops
24
25 let (@@) a b = fun x -> a (b x)
26 let scheduler = BslScheduler.opa
27
28 ##extern-type endpoint = Hlnet.endpoint
29 ##extern-type [normalize] channel('o, 'i) = ('o, 'i) Hlnet.channel
30 ##extern-type [normalize] channel_spec('o, 'i) = ('o, 'i) Hlnet.channel_spec
31
32 ##register new_endpoint : string, int -> endpoint
33 let new_endpoint addr port =
34 (Hlnet.Tcp (Unix.inet_addr_of_string addr, port))
35
36 ##register new_ssl_endpoint : string, int, SSL.secure_type -> endpoint
37 let new_ssl_endpoint addr port ssl =
38 (Hlnet.Ssl (Unix.inet_addr_of_string addr, port, Some ssl))
39
40 (* Inspection of endpoint from opa *)
41 ##module EndpointGet
42 type ep_flat = { protocol:string; addr:string; port:int }
43 let flat = function
44 | Hlnet.Tcp (addr, port) ->
45 {protocol="tcp";addr=Unix.string_of_inet_addr addr;port=port}
46 | Hlnet.Ssl (addr, port, _secure) ->
47 {protocol="ssl";addr=Unix.string_of_inet_addr addr;port=port}
48 (* | Hlnet.Udp (addr, port) ->
49 {protocol="udp";addr=Unix.string_of_inet_addr addr;port=port} *)
50
51 ##register protocol : endpoint -> string
52 let protocol ep = (flat ep).protocol
53 ##register addr : endpoint -> string
54 let addr ep = (flat ep).addr
55 ##register port : endpoint -> int
56 let port ep = (flat ep).port
57 ##endmodule
58
59
60 ##register make_channel_spec : string, int, ('o -> string), (channel('o,'i), string -> option('i)) -> channel_spec('o,'i)
61 let make_channel_spec name version serialise unserialise =
62 Hlnet.Aux.easy_spec ~name ~version ~serialise ~unserialise
63
64 ##register[cps-bypass] open_channel: endpoint, channel_spec('o,'i), continuation(channel('o, 'i)) -> void
65 let open_channel ep spec k =
66 let on_disconnect () =
67 Logger.error "Can not connect to %s" (Hlnet.endpoint_to_string ep);
68 `abort in
69 Hlnet.open_channel scheduler ep ~on_disconnect spec @> fun chan -> chan |> k
70
71 ##register listen: endpoint -> void
72 let listen = Hlnet.listen scheduler
73
74 ##register accept: endpoint, channel_spec('o,'i), (channel('o, 'i) -> void) -> void
75 let accept ep spec ch_hand = Hlnet.accept scheduler ep spec ch_hand
76
77 ##register refuse: endpoint -> void
78 let refuse endpoint = Hlnet.refuse scheduler endpoint
79
80 ##register[cps-bypass] local_endpoint: channel('o, 'i), continuation(endpoint) -> void
81 let local_endpoint chan k = Hlnet.local_of_channel chan |> k
82
83 ##register[cps-bypass] remote_endpoint: channel('o, 'i), continuation(endpoint) -> void
84 let remote_endpoint chan k = Hlnet.remote_of_channel chan |> k
85
86 ##register send: channel('o, 'i), 'o -> void
87 let send chan opack = Hlnet.send chan opack
88
89 ##register[cps-bypass] receive: channel('o, 'i), continuation('i) -> void
90 let receive chan k =
91 Hlnet.receive chan @> fun x -> x |> k
92
93 ##register[cps-bypass] sendreceive: channel('o, 'i), 'o, continuation('i) -> void
94 let sendreceive chan opack k =
95 Hlnet.sendreceive chan opack @> fun recv -> recv |> k
96
97 ##register async_receive: channel('o, 'i), ('i -> void) -> void
98 let async_receive chan handler =
99 Hlnet.receive chan handler
100
101 ##register async_sendreceive: channel('o, 'i), 'o, ('i -> void) -> void
102 let async_sendreceive chan x handler =
103 Hlnet.sendreceive chan x handler
104
105 ##register [cps-bypass] setup_receive: channel('o, 'i), ('i, continuation(opa[void]) -> void), continuation(opa[void]) -> void
106 let setup_receive chan handler k =
107 let handler = BslUtils.proj_cps k handler in
108 Hlnet.setup_respond chan (fun i _respond -> handler i);
109 ServerLib.void |> k
110
111 ##register [cps-bypass] setup_receive_cps: channel('o, 'i), ('i, continuation(opa[void]) -> void), continuation(opa[void]) -> void
112 let setup_receive_cps chan handler k =
113 let handler = BslUtils.proj_cps k handler in
114 Hlnet.setup_respond chan (fun i _respond -> handler i);
115 ServerLib.void |> k
116
117
118 ##register[cps-bypass] setup_respond: channel('o, 'i), ('i, continuation('o) -> void), continuation(opa[void]) -> void
119 let setup_respond chan iohand k =
120 Hlnet.setup_respond chan
121 (fun i respond -> iohand i @> C.cont_ml respond);
122 (* do not dup the transaction info in k (no [C.ccont_ml k])
123 -- but what about the thread context ?? *FIXME* *)
124 ServerLib.void |> k
125
126 ##register close_channel \ `Hlnet.close_channel` : channel('o, 'i) -> void
127
128 ##register[cps-bypass] dup: channel('o, 'i), channel_spec('o2,'i2), continuation(channel('o2,'i2)) -> void
129 let dup chan spec k =
130 Hlnet.dup chan spec |> k
131
132 ##register[cps-bypass] respond_on_new_channel : channel('o0,'i0), channel_spec('o,'i), ('i, continuation('o) -> void), continuation(channel('i,'o)) -> void
133 let respond_on_new_channel chan spec handl k =
134 Hlnet.Aux.respond_on_new_channel chan spec
135 (fun i fk -> handl i @> C.ccont_ml k fk)
136 |> k
137
138 ##register serialise_channel \ `Hlnet.serialise_channel` : channel('o, 'i) -> string
139
140 ##register unserialise_remote_channel : channel_spec('o, 'i), channel('o0, 'i0), string -> opa[option(channel('o, 'i))]
141 let unserialise_remote_channel chan spec s =
142 let chanopt = match Hlnet.unserialise_remote_channel chan spec s 0 with
143 | `data(chan,_) -> Some chan
144 | `needmore _ -> Logger.warning "Unable to deserialise channel: string too short"; None
145 | `failure msg -> Logger.warning "Unable to deserialise channel: bad format (%s)" msg; None
146 in ServerLib.wrap_option chanopt
147
148 ##register channel_is_open \ `Hlnet.is_open` : channel('o, 'i) -> bool
149
150 ##register channel_exists \ `Hlnet.channel_is_listening` : channel('o, 'i) -> bool
151
152 ##register channel_to_string \ `Hlnet.channel_to_string` : channel('o,'i) -> string
153
154 ##register default_endpoint \ `Hlnet.default_endpoint` : endpoint
155
156 ##register remote_of_channel \ `Hlnet.remote_of_channel` : channel('o, 'i) -> endpoint
157 ##register local_of_channel \ `Hlnet.local_of_channel` : channel('o, 'i) -> endpoint
Something went wrong with that request. Please try again.