Skip to content
This repository
tag: v948
Fetching contributors…

Cannot retrieve contributors at this time

file 182 lines (140 sloc) 7.409 kb
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
(*
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 defin bypasse defined for Hlnet use on opa,
"synchronous" (according cps), and asynchronous (for s2 compatibility)
*)

module C = QmlCpsServerLib
open C.Ops

let (@@) a b = fun x -> a (b x)
let scheduler = BslScheduler.opa

##extern-type endpoint = Hlnet.endpoint
##extern-type [normalize] channel('o, 'i) = ('o, 'i) Hlnet.channel
##extern-type [normalize] channel_spec('o, 'i) = ('o, 'i) Hlnet.channel_spec

##opa-type Hlnet.error


(** Projection of ocaml exn raised by hlnet to an opa record
(Hlnet.error). *)
let hlnetexn_ml_to_opa =
  let disconnected =
    let fdisconnected = ServerLib.static_field_of_name "disconnected" in
    function (e:Hlnet.endpoint) ->
      wrap_opa_hlnet_error (
        ServerLib.make_record
          (ServerLib.add_field ServerLib.empty_record_constructor
             fdisconnected e
          )
      )
  in function
    | Hlnet.Disconnected ep -> disconnected ep
    | e -> failwith (Printf.sprintf "Unknow hlnet exn: %s" (Printexc.to_string e))

##register new_endpoint : string, int -> endpoint
let new_endpoint addr port =
    (Hlnet.Tcp (Unix.inet_addr_of_string addr, port))

##register new_ssl_endpoint : string, int, SSL.secure_type -> endpoint
let new_ssl_endpoint addr port ssl =
    (Hlnet.Ssl (Unix.inet_addr_of_string addr, port, Some ssl))

(* Inspection of endpoint from opa *)
##module EndpointGet
  type ep_flat = { protocol:string; addr:string; port:int }
  let flat = function
    | Hlnet.Tcp (addr, port) ->
      {protocol="tcp";addr=Unix.string_of_inet_addr addr;port=port}
    | Hlnet.Ssl (addr, port, _secure) ->
      {protocol="ssl";addr=Unix.string_of_inet_addr addr;port=port}
(* | Hlnet.Udp (addr, port) ->
{protocol="udp";addr=Unix.string_of_inet_addr addr;port=port} *)

  ##register protocol : endpoint -> string
  let protocol ep = (flat ep).protocol
  ##register addr : endpoint -> string
  let addr ep = (flat ep).addr
  ##register port : endpoint -> int
  let port ep = (flat ep).port
##endmodule


##register make_channel_spec : string, int, ('o -> string), (channel('o,'i), string -> option('i)) -> channel_spec('o,'i)
let make_channel_spec name version serialise unserialise =
  Hlnet.Aux.easy_spec ~name ~version ~serialise ~unserialise

##register[cps-bypass] open_channel: endpoint, channel_spec('o,'i), continuation(channel('o, 'i)) -> void
let open_channel ep spec k =
  let on_disconnect () =
    Logger.error "Can not connect to %s" (Hlnet.endpoint_to_string ep);
    `abort in
  Hlnet.open_channel scheduler ep ~on_disconnect spec @> fun chan -> chan |> k

##register listen: endpoint -> void
let listen = Hlnet.listen scheduler

##register accept: endpoint, channel_spec('o,'i), (channel('o, 'i) -> void) -> void
let accept ep spec ch_hand = Hlnet.accept scheduler ep spec ch_hand

##register refuse: endpoint -> void
let refuse endpoint = Hlnet.refuse scheduler endpoint

##register[cps-bypass] local_endpoint: channel('o, 'i), continuation(endpoint) -> void
let local_endpoint chan k = Hlnet.local_of_channel chan |> k

##register[cps-bypass] remote_endpoint: channel('o, 'i), continuation(endpoint) -> void
let remote_endpoint chan k = Hlnet.remote_of_channel chan |> k

##register send: channel('o, 'i), 'o -> void
let send chan opack = Hlnet.send chan opack

##register[cps-bypass] receive: channel('o, 'i), continuation('i) -> void
let receive chan k =
  Hlnet.receive chan @> fun x -> x |> k

##register[cps-bypass] sendreceive: channel('o, 'i), 'o, continuation('i) -> void
let sendreceive chan opack k =
  Hlnet.sendreceive chan opack @> fun recv -> recv |> k

##register[cps-bypass] sendreceiverr: channel('o, 'i), 'o, continuation(outcome('i, Hlnet.error)) -> void
let sendreceiverr chan opack k =
  Hlnet.sendreceive' chan opack
    (fun e -> BslUtils.create_outcome (`failure (hlnetexn_ml_to_opa e)) |> k)
    (fun r -> BslUtils.create_outcome (`success r) |> k)

##register async_receive: channel('o, 'i), ('i -> void) -> void
let async_receive chan handler =
  Hlnet.receive chan handler

##register async_sendreceive: channel('o, 'i), 'o, ('i -> void) -> void
let async_sendreceive chan x handler =
  Hlnet.sendreceive chan x handler

##register [cps-bypass] setup_receive: channel('o, 'i), ('i, continuation(opa[void]) -> void), continuation(opa[void]) -> void
let setup_receive chan handler k =
  let handler = BslUtils.proj_cps k handler in
  Hlnet.setup_respond chan (fun i _respond -> handler i);
  ServerLib.void |> k

##register [cps-bypass] setup_receive_cps: channel('o, 'i), ('i, continuation(opa[void]) -> void), continuation(opa[void]) -> void
let setup_receive_cps chan handler k =
  let handler = BslUtils.proj_cps k handler in
  Hlnet.setup_respond chan (fun i _respond -> handler i);
  ServerLib.void |> k


##register[cps-bypass] setup_respond: channel('o, 'i), ('i, continuation('o) -> void), continuation(opa[void]) -> void
let setup_respond chan iohand k =
  Hlnet.setup_respond chan
    (fun i respond -> iohand i @> C.cont_ml respond);
         (* do not dup the transaction info in k (no [C.ccont_ml k])
-- but what about the thread context ?? *FIXME* *)
  ServerLib.void |> k

##register close_channel \ `Hlnet.close_channel` : channel('o, 'i) -> void

##register[cps-bypass] dup: channel('o, 'i), channel_spec('o2,'i2), continuation(channel('o2,'i2)) -> void
let dup chan spec k =
  Hlnet.dup chan spec |> k

##register[cps-bypass] respond_on_new_channel : channel('o0,'i0), channel_spec('o,'i), ('i, continuation('o) -> void), continuation(channel('i,'o)) -> void
let respond_on_new_channel chan spec handl k =
  Hlnet.Aux.respond_on_new_channel chan spec
    (fun i fk -> handl i @> C.ccont_ml k fk)
  |> k

##register serialise_channel \ `Hlnet.serialise_channel` : channel('o, 'i) -> string

##register unserialise_remote_channel : channel_spec('o, 'i), channel('o0, 'i0), string -> opa[option(channel('o, 'i))]
let unserialise_remote_channel chan spec s =
  let chanopt = match Hlnet.unserialise_remote_channel chan spec s 0 with
    | `data(chan,_) -> Some chan
    | `needmore _ -> Logger.warning "Unable to deserialise channel: string too short"; None
    | `failure msg -> Logger.warning "Unable to deserialise channel: bad format (%s)" msg; None
  in ServerLib.wrap_option chanopt

##register channel_is_open \ `Hlnet.is_open` : channel('o, 'i) -> bool

##register channel_exists \ `Hlnet.channel_is_listening` : channel('o, 'i) -> bool

##register channel_to_string \ `Hlnet.channel_to_string` : channel('o,'i) -> string

##register default_endpoint \ `Hlnet.default_endpoint` : endpoint

##register remote_of_channel \ `Hlnet.remote_of_channel` : channel('o, 'i) -> endpoint
##register local_of_channel \ `Hlnet.local_of_channel` : channel('o, 'i) -> endpoint
Something went wrong with that request. Please try again.