Skip to content
This repository
tag: v1304
Fetching contributors…

Cannot retrieve contributors at this time

file 203 lines (168 sloc) 6.83 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 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203
(*
Copyright © 2011 MLstate

This file is part of OPA.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
*)

module NA = NetAddr
type secure_mode =
  | Unsecured
  | Secured of SslAS.secure_type

type socket_type = TCP | UDP

type port_spec = {
  addr : Unix.inet_addr;
  port : int;
  prot : NetAddr.protocol;
  stype : Connection.socket_type
}

type port = {
  conn_incoming :
    SslAS.secure_response -> Scheduler.connection_info -> unit;
  conn_terminating : unit -> unit;
  secure_mode : secure_mode;
  port_spec : port_spec
}

type socket = Unix.file_descr

let _SUSPICIOUS_ mess =
  Logger.debug "!!!\nSUSPICIOUS %s\n!!!!" mess;
  ()

exception Unknown_machine of string

let inet_addr_of_name machine =
  try (Unix.gethostbyname machine).Unix.h_addr_list.(0)
  with Unix.Unix_error _ | Not_found -> try Unix.inet_addr_of_string machine
  with Unix.Unix_error _ | Failure _ -> raise (Unknown_machine machine)

let addr_of_ipv4 (ip1, ip2, ip3, ip4) =
  Unix.inet_addr_of_string (Printf.sprintf "%d.%d.%d.%d" ip1 ip2 ip3 ip4)

let string_of_ipv4 (ip1, ip2, ip3, ip4) =
  Printf.sprintf "%d.%d.%d.%d" ip1 ip2 ip3 ip4

let name_of_addr addr =
  try (Unix.gethostbyaddr addr).Unix.h_name
  with Not_found -> Unix.string_of_inet_addr addr

let make_port_spec ?(socket_type = TCP) ~protocol addr port =
  let stype =
    match socket_type with
    | TCP -> Connection.TCP
    | UDP -> Connection.UDP
  in
  { addr = addr
  ; port = port
  ; prot = protocol
  ; stype = stype
  }

let get_port p = p.port

let get_addr p = p.addr

let get_socket_type p =
  match p.stype with
  | Connection.TCP -> TCP
  | Connection.UDP -> UDP


(* == LISTEN == *)

let listen_port port_spec = Connection.listen ~socket_type:port_spec.stype (Unix.ADDR_INET (port_spec.addr, port_spec.port))

  (* Only used by a normal connection (listen_normal),
but listen_ssl uses listen_normal *)
let new_client_UNIX sched _conn (server_fun: Scheduler.connection_info -> unit) conn () =
  try
    let sock = Scheduler.get_connection_fd conn in
    let client_sock, host = Connection.accept sock in
    let addr = NA.mk_tcp
      ~protocol:(NA.get_protocol conn.Scheduler.addr)
      ~fd:client_sock ~addr:host
    in
    let conn = Scheduler.make_connection sched addr in
    server_fun conn
  with Connection.Error -> ()

(* let rec new_client_WINDOWS sched _unused_conn (server_fun: Scheduler.connection_info -> unit) (\*sock*\) conn () = *)
(* try *)
(* (\* listen for other clients *\) *)
(* (\* let _id = Iocp.async_accept sock in *\) *)
(* (\* _SUSPICIOUS_ "What is that self#new_clien callback IN the new_client method ????" ; *\) *)
(* let callback () = () *)
(* (\* new_client_WINDOWS conn server_fun sock () *\) *)
(* in *)
(* ignore(Scheduler.listen sched conn (\* TODO ~async_id:id *\) callback); *)
(* let sd = Iocp.get_socket() in *)
(* let host = Unix.inet_addr_loopback in (\*FIXME*\) *)
(* let conn = Scheduler.make_connection sched (Scheduler.Normal (sd, host)) in *)
(* server_fun conn *)
(* with Connection.Error -> () *)
(* (\* Unix.Unix_error _ as e -> *\) *)
(* (\* Logger.warning "Net.server: can't accept connection (%s)" (Printexc.to_string e) *\) *)


let new_client_WINDOWS sched _conn (server_fun: Scheduler.connection_info -> unit) conn () =
  try
    let sock = Scheduler.get_connection_fd conn in
    let client_sock, host = Connection.accept sock in
    let addr = NA.mk_tcp
      ~protocol:(NA.get_protocol conn.Scheduler.addr)
      ~fd:client_sock ~addr:host
    in
    let conn = Scheduler.make_connection sched addr in
    server_fun conn
  with Connection.Error -> ()

let new_client = Mlstate_platform.platform_dependent ~unix:new_client_UNIX ~windows:new_client_WINDOWS ()

let listen_normal sched conn server_fun =
  Scheduler.listen sched conn (new_client sched conn server_fun conn)
(* platform_dependent *)
(* ~unix:(fun ()-> Scheduler.listen sched conn (new_client sched conn server_fun conn)) *)
(* ~windows:(fun ()-> *)
(* let _id = Iocp.async_accept sock in *)
(* Scheduler.listen (\* TODO ~async_id:id *\) sched conn (new_client sched conn server_fun conn)) () () *)


(* == Public functions == *)

let listen sched port_spec secure_mode ?socket_flags server_fun =
  let socket = Connection.listen ~socket_type:port_spec.stype ?socket_flags (Unix.ADDR_INET (port_spec.addr, port_spec.port)) in
  let addr = NA.mk_tcp ~protocol:port_spec.prot
    ~fd:socket ~addr:Unix.inet_addr_loopback
  in
  let conn = Scheduler.make_connection sched addr in
  let listen_key =
    match secure_mode with
    | Unsecured ->
        listen_normal sched conn (server_fun SslAS.UnsecuredRes)
    | Secured params ->
        listen_normal sched conn (SslAS.get_listen_callback sched params server_fun)
  in
  (fun () ->
     Scheduler.abort sched listen_key;
     Scheduler.remove_connection sched conn
  )

let connect sched port_spec secure_mode ?socket_flags ?err_cont cont =
  let sockaddr = Unix.ADDR_INET (port_spec.addr, port_spec.port) in
  let sock = Connection.connect ?socket_flags sockaddr in
  let addr = NA.mk_tcp ~protocol:port_spec.prot
    ~fd:sock ~addr:port_spec.addr
  in
  let conn = Scheduler.make_connection sched addr in
  let err_cont e =
    Scheduler.remove_connection sched conn;
    match err_cont with
    | Some f -> f e
    | None -> ()
  in
  match secure_mode with
  | Unsecured -> Scheduler.connect sched conn (fun () -> cont conn) ~err_cont
  | Secured ssl_params ->
      let normal_cont () = SslAS.connect sched conn ssl_params ~err_cont cont in
      (* Wait for normal connect to be done *)
      Scheduler.connect sched conn normal_cont ~err_cont

let secure_mode_from_params certificate verify_params =
  match certificate, verify_params with
  | Some _, _
  | _, Some _ -> Secured (certificate, verify_params)
  | _ -> Unsecured


let loop sched =
  (* Printexc.record_backtrace true; (\* for get_backtrace below *\) *)
  Sys.catch_break true; (* turn on handlig of Ctrl-c in async *)
  let loop = ref true in
  while !loop do
    try
      loop := Scheduler.wait sched ~block:true
    with
      | Sys.Break -> loop := false
      | Failure "Interrupted system call" -> loop := false
      | e -> Logger.log_error "%s" (Printexc.to_string e)
  done
Something went wrong with that request. Please try again.