Ocaml/FAQ/Sockets

open Unix
 
(* Convert human readable form to 32 bit value *)
let packed_ip = inet_addr_of_string "208.146.240.1" in
 
let host = gethostbyname "www.oreilly.com" in
let packed_ip = host.h_addr_list.(0) in
 
(* Convert 32 bit value to ip adress *)
let ip_address = string_of_inet_addr (packed_ip) in
 
(* Create socket object *)
let sock = socket PF_INET SOCK_STREAM 0 in
 
(* Get socketname *)
let saddr = getsockname sock ;;

(* For real applications you should the SMTP module in Ocamlnet. *)
open Unix
 
let sock_send sock str =
            let len = String.length str in
    send sock str 0 len []
 
let sock_recv sock maxlen =
    let str = String.create maxlen in
    let recvlen = recv sock str 0 maxlen [] in
    String.sub str 0 recvlen
 
let client_sock = socket PF_INET SOCK_STREAM 0 in
let hentry = gethostbyname "coltrane" in
connect client_sock (ADDR_INET (hentry.h_addr_list.(0), 25)) ; (* SMTP *)
 
sock_recv client_sock 1024 ;
 
sock_send client_sock "mail from: <pleac@localhost>\n" ;
sock_recv client_sock 1024 ;
 
sock_send client_sock "rcpt to: <erikd@localhost>\n" ;
sock_recv client_sock 1024;
 
sock_send client_sock "data\n" ;
sock_recv client_sock 1024 ;
 
sock_send client_sock "From: Ocaml whiz\nSubject: Ocaml rulez!\n\nYES!\n.\n" ;
sock_recv client_sock 1024 ;
 
close client_sock ;;

(* Writing a TCP Server *)
(* Run this and then telnet <machinename> 1027 *)
 
#load "unix.cma" ;;
open Unix ;;
 
let server_sock = socket PF_INET SOCK_STREAM 0 in
 
(* so we can restart our server quickly *)
setsockopt server_sock SO_REUSEADDR true ;
 
(* build up my socket address *)
let address = (gethostbyname(gethostname())).h_addr_list.(0) in
bind server_sock (ADDR_INET (address, 1029)) ;
 
(* Listen on the socket. Max of 10 incoming connections. *)
listen server_sock 10 ;
 
(* accept and process connections *)
while true do
        let (client_sock, client_addr) = accept server_sock in
        let str = "Hello\n" in
        let len = String.length str in
        let x = send client_sock str 0 len [] in
        shutdown client_sock SHUTDOWN_ALL
        done ;;

#load "unix.cma";;
 
let () =
  let server_in = Unix.in_channel_of_descr server in
  let server_out = Unix.out_channel_of_descr server in
  output_string server_out "What is your name?\n";
  flush server_out;
  let response = input_line server_in in
  print_endline response
 
(*-----------------------------*)
 
let () =
  try
    ignore
      (Unix.send server data_to_send 0 (String.length data_to_send) flags)
  with Unix.Unix_error (e, _, _) ->
    Printf.eprintf "Can't send: %s\n%!"
      (Unix.error_message e);
    exit 1
 
let data_read =
  let data_read = String.create maxlen in
  let data_length =
    try
      Unix.recv server data_read 0 maxlen flags
    with Unix.Unix_error (e, _, _) ->
      Printf.eprintf "Can't receive: %s\n%!"
        (Unix.error_message e);
      exit 1 in
  String.sub data_read 0 data_length
 
(*-----------------------------*)
 
let () =
  let read_from, _, _ =
    Unix.select [from_server; to_client] [] [] timeout in
  List.iter
    (fun socket ->
       (* read the pending data from socket *)
       ())
    read_from
 
(*-----------------------------*)
 
(* Requires OCaml 3.11 or newer. *)
let () =
  try Unix.setsockopt server Unix.TCP_NODELAY true
  with Unix.Unix_error (e, _, _) ->
    Printf.eprintf "Couldn't disable Nagle's algorithm: %s\n%!"
      (Unix.error_message e)
 
(*-----------------------------*)
 
(* Requires OCaml 3.11 or newer. *)
let () =
  try Unix.setsockopt server Unix.TCP_NODELAY false
  with Unix.Unix_error (e, _, _) ->
    Printf.eprintf "Couldn't enable Nagle's algorithm: %s\n%!"
      (Unix.error_message e)

#load "unix.cma";;
 
(* Create a UDP socket. *)
let socket =
  Unix.socket Unix.PF_INET Unix.SOCK_DGRAM
    (Unix.getprotobyname "udp").Unix.p_proto
 
(*-----------------------------*)
 
(* Send a UDP message. *)
let ipaddr = (Unix.gethostbyname hostname).Unix.h_addr_list.(0)
let portaddr = Unix.ADDR_INET (ipaddr, portno)
let len = Unix.sendto socket msg 0 (String.length msg) [] portaddr
 
(*-----------------------------*)
 
(* Receive a UDP message. *)
let msg = String.create maxlen
let len, portaddr = Unix.recvfrom socket msg 0 maxlen []
 
(*-----------------------------*)
 
#!/usr/bin/ocaml
(* clockdrift - compare another system's clock with this one *)
#load "unix.cma";;
 
let secs_of_70_years = 2_208_988_800L
 
let msgbox =
  Unix.socket Unix.PF_INET Unix.SOCK_DGRAM
    (Unix.getprotobyname "udp").Unix.p_proto
 
let him =
  Unix.ADDR_INET ((Unix.gethostbyname
                     (if Array.length Sys.argv > 1
                      then Sys.argv.(1)
                      else "127.1")).Unix.h_addr_list.(0),
                  (Unix.getservbyname "time" "udp").Unix.s_port)
 
let () = ignore (Unix.sendto msgbox "" 0 0 [] him)
 
let ptime = String.create 4
 
let host =
  match Unix.recvfrom msgbox ptime 0 4 [] with
    | _, Unix.ADDR_INET (addr, port) ->
        (Unix.gethostbyaddr addr).Unix.h_name
    | _ -> assert false
 
let delta =
  Int64.to_float
    (Int64.sub
       (Int64.of_string (Printf.sprintf "0x%02x%02x%02x%02x"
                           (int_of_char ptime.[0])
                           (int_of_char ptime.[1])
                           (int_of_char ptime.[2])
                           (int_of_char ptime.[3])))
       secs_of_70_years)
    -. (Unix.time ())
 
let () =
  Printf.printf "Clock on %s is %d seconds ahead of this one.\n"
    host (int_of_float delta)

#load "unix.cma";;
let () =
  begin
    try
      Unix.bind socket (Unix.ADDR_INET (Unix.inet_addr_any, server_port));
    with Unix.Unix_error (e, _, _) ->
      Printf.eprintf "Couldn't be a udp server on port %d: %s\n"
        server_port (Unix.error_message e);
      exit 1
  end;
  let him = String.create max_to_read in
  while true do
    ignore (Unix.recvfrom socket him 0 max_to_read []);
    (* do something *)
  done
 
(*-----------------------------*)
 
#!/usr/bin/ocaml
(* udpqotd - UDP message server *)
#load "unix.cma";;
 
let maxlen = 1024
let portno = 5151
 
let sock =
  Unix.socket Unix.PF_INET Unix.SOCK_DGRAM
    (Unix.getprotobyname "udp").Unix.p_proto
 
let () =
  Unix.bind sock (Unix.ADDR_INET (Unix.inet_addr_any, portno));
  Printf.printf "Awaiting UDP messages on port %d\n%!" portno
 
let oldmsg = ref "This is the starting message."
 
let () =
  let newmsg = String.create maxlen in
  while true do
    let newmsg, hishost, sockaddr =
      match Unix.recvfrom sock newmsg 0 maxlen [] with
        | len, (Unix.ADDR_INET (addr, port) as sockaddr) ->
            String.sub newmsg 0 len,
            (Unix.gethostbyaddr addr).Unix.h_name,
            sockaddr
        | _ -> assert false in
    Printf.printf "Client %s said ``%s''\n%!" hishost newmsg;
    ignore
      (Unix.sendto sock !oldmsg 0 (String.length !oldmsg) [] sockaddr);
    oldmsg := Printf.sprintf "[%s] %s" hishost newmsg
  done
 
(*-----------------------------*)
 
#!/usr/bin/ocaml
(* udpmsg - send a message to the udpqotd server *)
#load "unix.cma";;
 
let maxlen  = 1024
let portno  = 5151
let timeout = 5
 
let server_host, msg =
  match Array.to_list Sys.argv with
    | _ :: head :: tail -> head, String.concat " " tail
    | _ ->
        Printf.eprintf "Usage: %s server_host msg ...\n" Sys.argv.(0);
        exit 1
 
let sock =
  Unix.socket Unix.PF_INET Unix.SOCK_DGRAM
    (Unix.getprotobyname "udp").Unix.p_proto
 
let sockaddr =
  let addr = (Unix.gethostbyname server_host).Unix.h_addr_list.(0) in
  Unix.ADDR_INET (addr, portno)
 
let handle_alarm signal =
  Printf.eprintf "recv from %s timed out after %d seconds.\n"
    server_host timeout;
  exit 1
 
let () =
  ignore (Unix.sendto sock msg 0 (String.length msg) [] sockaddr);
  Sys.set_signal Sys.sigalrm (Sys.Signal_handle handle_alarm);
  ignore (Unix.alarm timeout);
  let msg = String.create maxlen in
  let msg, hishost =
    match Unix.recvfrom sock msg 0 maxlen [] with
      | len, Unix.ADDR_INET (addr, port) ->
          String.sub msg 0 len,
          (Unix.gethostbyaddr addr).Unix.h_name
      | _ -> assert false in
  ignore (Unix.alarm 0);
  Printf.printf "Server %s responded ``%s''\n" hishost msg

#load "unix.cma";;
 
(* Create a Unix domain socket server - you can also use SOCK_STREAM. *)
let server = Unix.socket Unix.PF_UNIX Unix.SOCK_DGRAM 0
let () = try Unix.unlink "/tmp/mysock" with Unix.Unix_error _ -> ()
let () = Unix.bind server (Unix.ADDR_UNIX "/tmp/mysock")
 
(* Create a Unix domain socket client - you can also use SOCK_STREAM. *)
let client = Unix.socket Unix.PF_UNIX Unix.SOCK_DGRAM 0
let () = Unix.connect client (Unix.ADDR_UNIX "/tmp/mysock")

#load "unix.cma";;
 
(* Get the remote IP address. *)
let () =
  let other_end = Unix.getpeername socket in
  let name_info = Unix.getnameinfo other_end [Unix.NI_NUMERICHOST] in
  let ip_address = name_info.Unix.ni_hostname in
  (* ... *)
  ()
 
(*-----------------------------*)
 
(* Attempt to determine the remote host name, with forward and reverse
   DNS lookups to detect spoofing. *)
let () =
  let other_end = Unix.getpeername socket in
  let name_info = Unix.getnameinfo other_end [Unix.NI_NUMERICHOST] in
  let actual_ip = name_info.Unix.ni_hostname in
  let claimed_hostname =
    (Unix.gethostbyaddr (Unix.inet_addr_of_string actual_ip))
      .Unix.h_name in
  let name_lookup = Unix.gethostbyname claimed_hostname in
  let resolved_ips =
    Array.to_list (Array.map
                     Unix.string_of_inet_addr
                     name_lookup.Unix.h_addr_list) in
  (* ... *)
  ()

(*-----------------------------*)
 
(*
** Finding Your Own Name and Address.
** The Unix module to the rescue again.
*)
 
#load "unix.cma" ;;
open Unix ;;
 
let hostname = gethostname () in
Printf.printf "hostname : %s\n" hostname ;;
 
(*-----------------------------*)
 
(*
** Unfortunately there is no easy way of retreiving the
** uname without using Unix.open_process_in.
*)
 
(*-----------------------------*)
 
let hentry = gethostbyname hostname in
let address = hentry.h_addr_list.(0) in
Printf.printf "address : %s\n" (string_of_inet_addr address) ;;
 
let hentry = gethostbyaddr address in
Printf.printf "hostname : %s\n" hentry.h_name ;;

(* Closing a Socket After Forking *)
 
(*-----------------------------*)
shutdown sock SHUTDOWN_RECEIVE ;    (* I/we have stopped reading data *)
shutdown sock SHUTDOWN_SEND ;       (* I/we have stopped writing data *)
shutdown sock SHUTDOWN_ALL ;;       (* I/we have stopped using this socket *)
 
(*-----------------------------*)
(* Using the sock_send and sock_recv functions from above. *)
 
sock_send sock "my request\n" ;    (* send some data *)
shutdown sock SHUTDOWN_SEND ;      (* send eof; no more writing *)
let answer = sock_recv sock 4096 ;; (* but you can still read *)

#!/usr/bin/ocaml
(* biclient - bidirectional forking client *)
#load "unix.cma";;
 
let host, port =
  match Array.to_list Sys.argv with
    | [_; host; port] -> host, int_of_string port
    | _ -> Printf.eprintf "usage: %s host port\n" Sys.argv.(0); exit 1
 
let sockaddr =
  let addr = (Unix.gethostbyname host).Unix.h_addr_list.(0) in
  Unix.ADDR_INET (addr, port)
 
let () =
  let socket = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
  Unix.connect socket sockaddr;
  Printf.eprintf "[Connected to %s:%d]\n%!" host port;
 
  (* split the program into two processes, identical twins *)
  match Unix.fork () with
    | 0 ->
        (* child copies standard input to the socket *)
        let output = Unix.out_channel_of_descr socket in
        while true do
          let line = input_line stdin in
          output_string output line;
          output_string output "\n";
          flush output
        done
    | kidpid ->
        (* parent copies the socket to standard output *)
        let input = Unix.in_channel_of_descr socket in
        try
          while true do
            let line = input_line input in
            output_string stdout line;
            output_string stdout "\n";
            flush stdout
          done
        with End_of_file ->
          Unix.kill kidpid Sys.sigterm
 
let () = exit 0

(* set up the socket SERVER, bind and listen ... *)
#load "unix.cma";;
 
let rec reaper signal =
  try while true do ignore (Unix.waitpid [Unix.WNOHANG] (-1)) done
  with Unix.Unix_error (Unix.ECHILD, _, _) -> ();
  Sys.set_signal Sys.sigchld (Sys.Signal_handle reaper)
 
let () =
  Sys.set_signal Sys.sigchld (Sys.Signal_handle reaper)
 
let () =
  while true do
    try
      let (client, addr) = Unix.accept server in
      let pid = Unix.fork () in
      if pid = 0 then                   (* parent *)
        begin
          Unix.close server;            (* no use to child *)
          (* ... do something *)
          exit 0                        (* child leaves *)
        end
      else
        begin
          Unix.close client             (* no use to parent *)
        end
    with Unix.Unix_error (Unix.EINTR, _, _) -> ()
  done

#!/usr/bin/ocaml
(* preforker - server who forks first *)
#load "unix.cma";;
 
(* global variables *)
let prefork = 5
let max_clients_per_child = 5
module PidSet = Set.Make(struct type t = int let compare = compare end)
let children = ref PidSet.empty
 
(* takes care of dead children *)
let rec reaper _ =
  Sys.set_signal Sys.sigchld (Sys.Signal_handle reaper);
  match Unix.wait ()
  with (pid, _) -> children := PidSet.remove pid !children
 
(* signal handler for SIGINT *)
let rec huntsman _ =
  (* we're going to kill our children *)
  Sys.set_signal Sys.sigchld Sys.Signal_ignore;
  PidSet.iter
    (fun pid ->
       try Unix.kill Sys.sigint pid with Unix.Unix_error _ -> ())
    !children;
  (* clean up with dignity *)
  exit 0
 
let make_new_child server =
  (* block signal for fork *)
  let sigset = [Sys.sigint] in
  ignore (Unix.sigprocmask Unix.SIG_BLOCK sigset);
 
  match Unix.fork () with
    | 0 ->
        (* Child can *not* return from this subroutine. *)
        (* make SIGINT kill us as it did before *)
        Sys.set_signal Sys.sigint Sys.Signal_default;
 
        (* unblock signals *)
        ignore (Unix.sigprocmask Unix.SIG_UNBLOCK sigset);
 
        (* handle connections until we've reached max_clients_per_child *)
        for i = 1 to max_clients_per_child do
          let (client, _) = Unix.accept server in
          (* do something with the connection *)
          ()
        done;
 
        (* tidy up gracefully and finish *)
 
        (* this exit is VERY important, otherwise the child will become
           a producer of more and more children, forking yourself into
           process death. *)
        exit 0
    | pid ->
        (* Parent records the child's birth and returns. *)
        ignore (Unix.sigprocmask Unix.SIG_UNBLOCK sigset);
        children := PidSet.add pid !children
 
let () =
  (* establish SERVER socket, bind and listen. *)
  let server = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
  Unix.setsockopt server Unix.SO_REUSEADDR true;
  Unix.bind server (Unix.ADDR_INET (Unix.inet_addr_any, 6969));
  Unix.listen server 10;
 
  (* Fork off our children. *)
  for i = 1 to prefork do
    make_new_child server
  done;
 
  (* Install signal handlers. *)
  Sys.set_signal Sys.sigchld (Sys.Signal_handle reaper);
  Sys.set_signal Sys.sigint (Sys.Signal_handle huntsman);
 
  (* And maintain the population. *)
  while true do
    (* wait for a signal (i.e., child's death) *)
    Unix.pause ();
    for i = (PidSet.cardinal !children) to (prefork - 1) do
      (* top up the child pool *)
      make_new_child server
    done
  done

#!/usr/bin/ocaml
(* nonforker - server who multiplexes without forking *)
#load "unix.cma";;
 
let port = 1685                         (* change this at will *)
 
(* Listen to port. *)
let server = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0
let () =
  Unix.setsockopt server Unix.SO_REUSEADDR true;
  Unix.bind server (Unix.ADDR_INET (Unix.inet_addr_any, port));
  Unix.listen server 10;
  Unix.set_nonblock server
 
module FDSet =
  Set.Make(struct type t = Unix.file_descr let compare = compare end)
let clients = ref (FDSet.singleton server)
 
(* begin with empty buffers *)
let inbuffer = Hashtbl.create 0
let outbuffer = Hashtbl.create 0
let ready = Hashtbl.create 0
 
let buffer_size = 8192
let buffer = String.make buffer_size '\000'
 
(* handle deals with all pending requests for client *)
let handle client requests =
  (* requests are in ready[client] *)
  (* send output to outbuffer[client] *)
  List.iter
    (fun request ->
       (* request is the text of the request *)
       let data = Printf.sprintf "You said: %s\n" request in
       (* put text of reply into outbuffer[client] *)
       Hashtbl.replace outbuffer client
         (try Hashtbl.find outbuffer client ^ data
          with Not_found -> data))
    requests
 
(* Main loop: check reads/accepts, check writes, check ready to process *)
let () =
  while true do
    (* check for new information on the connections we have *)
 
    let (can_read, _, _) =
      Unix.select (FDSet.elements !clients) [] [] 1.0 in
    List.iter
      (fun client ->
         if client = server
         then
           begin
             (* accept a new connection *)
             let (client, addr) = Unix.accept server in
             clients := FDSet.add client !clients;
             Unix.set_nonblock client
           end
         else
           begin
             (* read data *)
             let chars_read =
               try
                 Some (Unix.read client buffer 0 buffer_size)
               with Unix.Unix_error (error, _, _) ->
                 prerr_endline (Unix.error_message error);
                 None in
 
             match chars_read with
               | None | Some 0 ->
                   (* This would be the end of file, so close the client *)
                   Hashtbl.remove inbuffer client;
                   Hashtbl.remove outbuffer client;
                   Hashtbl.remove ready client;
 
                   clients := FDSet.remove client !clients;
                   Unix.close client
 
               | Some chars_read ->
                   let data = String.sub buffer 0 chars_read in
                   Hashtbl.replace inbuffer client
                     (try Hashtbl.find inbuffer client ^ data
                      with Not_found -> data);
 
                   (* test whether the data in the buffer or the data we *)
                   (* just read means there is a complete request waiting *)
                   (* to be fulfilled.  If there is, set ready[client] *)
                   (* to the requests waiting to be fulfilled. *)
                   try
                     while true do
                       let data = Hashtbl.find inbuffer client in
                       let index = String.index data '\n' in
                       Hashtbl.replace inbuffer client
                         (String.sub data
                            (index + 1)
                            (String.length data - index - 1));
                       Hashtbl.replace ready client
                         ((try Hashtbl.find ready client
                           with Not_found -> [])
                          @ [String.sub data 0 index])
                     done
                   with Not_found -> ()
           end)
      can_read;
 
    (* Any complete requests to process? *)
    Hashtbl.iter handle ready;
    Hashtbl.clear ready;
 
    (* Buffers to flush? *)
    let (_, can_write, _) =
      Unix.select [] (FDSet.elements !clients) [] 1.0 in
    (* Skip client if we have nothing to say *)
    let can_write =
      List.filter (Hashtbl.mem outbuffer) can_write in
    List.iter
      (fun client ->
         let data = Hashtbl.find outbuffer client in
         let chars_written =
           try
             Some (Unix.single_write client data 0 (String.length data))
           with
             | Unix.Unix_error (Unix.EAGAIN, _, _)
             | Unix.Unix_error (Unix.EWOULDBLOCK, _, _) ->
                 prerr_endline "I was told I could write, but I can't.";
                 Some 0
             | Unix.Unix_error (error, _, _) ->
                 prerr_endline (Unix.error_message error);
                 None in
 
         match chars_written with
           | Some chars_written ->
               if chars_written = String.length data
               then Hashtbl.remove outbuffer client
               else Hashtbl.replace outbuffer client
                 (String.sub data chars_written
                    (String.length data - chars_written))
           | None ->
               (* Couldn't write all the data, and it wasn't because *)
               (* it would have blocked.  Shutdown and move on. *)
               Hashtbl.remove inbuffer client;
               Hashtbl.remove outbuffer client;
               Hashtbl.remove ready client;
 
               clients := FDSet.remove client !clients;
               Unix.close client)
      can_write;
 
    let (_, _, has_exception) =
      Unix.select [] [] (FDSet.elements !clients) 0.0 in
    List.iter
      (fun client ->
         (* Deal with out-of-band data here, if you want to. *)
         ())
      has_exception;
  done

#load "unix.cma";;
 
let server =
  Unix.socket Unix.PF_INET Unix.SOCK_STREAM
    (Unix.getprotobyname "tcp").Unix.p_proto
 
let () =
  Unix.setsockopt server Unix.SO_REUSEADDR true;
  Unix.bind server (Unix.ADDR_INET (Unix.inet_addr_any, server_port));
  Unix.listen server 10;
 
  (* accept loop *)
  while true do
    let client, sockaddr = Unix.accept server in
    match Unix.getsockname client with
      | Unix.ADDR_INET (addr, port) ->
          print_endline (Unix.string_of_inet_addr addr)
      | _ -> assert false
  done
 
(*-----------------------------*)
 
#load "unix.cma";;
 
let port = 4269                 (* port to bind to *)
let host = "specific.host.com"  (* virtual host to listen on *)
 
let server =
  Unix.socket Unix.PF_INET Unix.SOCK_STREAM
    (Unix.getprotobyname "tcp").Unix.p_proto
 
let () =
  let addr = (Unix.gethostbyname host).Unix.h_addr_list.(0) in
  Unix.bind server (Unix.ADDR_INET (addr, port));
  Unix.listen server 10;
  while true do
    let client, sockaddr = Unix.accept server in
    (* ... *)
    ()
  done

#load "unix.cma";;
 
let () =
  (* for the paranoid *)
  (* Unix.handle_unix_error Unix.chroot "/var/daemon"; *)
 
  (* fork and let parent exit *)
  let pid = Unix.fork () in
  if pid > 0 then exit 0;
 
  (* create a new session and abandon the controlling process *)
  ignore (Unix.setsid ())
 
(* flag indicating it is time to exit *)
let time_to_die = ref false
 
(* trap fatal signals *)
let () =
  let signal_handler _ = time_to_die := true in
  List.iter
    (fun signal ->
       Sys.set_signal signal (Sys.Signal_handle signal_handler))
    [Sys.sigint; Sys.sigterm; Sys.sighup]
  (* trap or ignore Sys.sigpipe *)
 
(* server loop *)
let () =
  while not !time_to_die do
    (* ... *)
    ()
  done

#load "unix.cma";;
 
let self = "/usr/bin/ocaml"
let args = self :: Array.to_list Sys.argv
 
let phoenix _ =
  (* close all your connections, kill your children, and *)
  (* generally prepare to be reincarnated with dignity. *)
  try
    ignore (Unix.sigprocmask Unix.SIG_UNBLOCK [Sys.sighup]);
    Unix.execv self (Array.of_list args)
  with Unix.Unix_error (e, _, _) ->
    Printf.eprintf "Couldn't restart: %s\n%!"
      (Unix.error_message e)
 
let () =
  Sys.set_signal Sys.sighup (Sys.Signal_handle phoenix)
 
(*-----------------------------*)
 
(* This recipe uses the Ocaml-Syck YAML parser available at:
   http://ocaml-syck.sourceforge.net/ *)
 
#directory "+yaml";;
#load "yaml.cma";;
#load "unix.cma";;
 
let yaml_parser = YamlParser.make ()
 
let config_file = "/usr/local/etc/myprog/server_conf.yaml"
let config = ref (YamlNode.SCALAR ("", ""))
 
let read_config _ =
  let in_channel = open_in config_file in
  let lines = ref [] in
  try
    while true do
      let line = input_line in_channel in
      lines := line :: !lines
    done
  with End_of_file ->
    close_in in_channel;
    config :=
      YamlParser.parse_string yaml_parser
        (String.concat "\n" (List.rev !lines))
 
let () =
  read_config ();
  Sys.set_signal Sys.sighup (Sys.Signal_handle read_config)

Oct  4 11:01:16 pedro sniffer: Connection from 10.0.0.4 to 10.0.0.1:echo
 
(*-----------------------------*)
 
echo stream tcp nowait nobody /usr/bin/ocaml ocaml /path/to/backsniff.ml
 
(*-----------------------------*)
 
(* backsniff - log attempts to connect to particular ports *)
#load "unix.cma";;
 
(* This recipe uses syslog-ocaml, which is available at:
   http://www.cs.cmu.edu/~ecc/software.html *)
#directory "+syslog";;
#load "syslog.cma";;
 
(* identify my port and address *)
let sockname =
  try Unix.getsockname Unix.stdin
  with Unix.Unix_error (e, _, _) ->
    Printf.eprintf "Couldn't identify myself: %s\n%!"
      (Unix.error_message e);
    exit 1
let iaddr, port =
  match sockname with
    | Unix.ADDR_INET (iaddr, port) -> iaddr, port
    | _ -> assert false
let my_address = Unix.string_of_inet_addr iaddr
 
(* get a name for the service *)
let service =
  try (Unix.getservbyport port "tcp").Unix.s_name
  with Not_found -> string_of_int port
 
(* now identify remote address *)
let sockname =
  try Unix.getpeername Unix.stdin
  with Unix.Unix_error (e, _, _) ->
    Printf.eprintf "Couldn't identify other end: %s\n%!"
      (Unix.error_message e);
    exit 1
let iaddr, port =
  match sockname with
    | Unix.ADDR_INET (iaddr, port) -> iaddr, port
    | _ -> assert false
let ex_address = Unix.string_of_inet_addr iaddr
 
(* and log the information *)
let () =
  let log = Syslog.openlog ~flags:[] ~facility:`LOG_DAEMON "sniffer" in
  Syslog.syslog log `LOG_NOTICE
    (Printf.sprintf "Connection from %s to %s:%s\n"
       ex_address my_address service);
  Syslog.closelog log;
  exit 0

#!/usr/bin/ocaml
(* fwdport -- act as proxy forwarder for dedicated services *)
 
#load "str.cma";;
#load "unix.cma";;
 
let children = Hashtbl.create 0    (* hash of outstanding child processes *)
let remote = ref ""                (* whom we connect to on the outside *)
let local = ref ""                 (* where we listen to on the inside *)
let service = ref ""               (* our service name or port number *)
let proxy_server = ref Unix.stdin  (* the socket we accept() from *)
 
(* process command line switches *)
let check_args () =
  Arg.parse
    [
      "-r",       Arg.Set_string remote,  "Remote host";
      "-remote",  Arg.Set_string remote,  "Remote host";
      "-l",       Arg.Set_string local,   "Local interface";
      "-local",   Arg.Set_string local,   "Local interface";
      "-s",       Arg.Set_string service, "Service";
      "-service", Arg.Set_string service, "Service";
    ]
    (fun s ->
       raise (Arg.Bad (Printf.sprintf "unexpected argument `%s'" s)))
    (Printf.sprintf "usage: %s [ -remote host ] [ -local interface ] [ -service service ]" Sys.argv.(0));
  if !remote = ""
  then (prerr_endline "Need remote"; exit 1);
  if !local = "" && !service = ""
  then (prerr_endline "Need local or service"; exit 1);
  if !local = ""
  then local := "localhost"
 
let parse_host host =
  match Str.split (Str.regexp ":") host with
    | [] -> "", ""
    | host :: [] -> host, ""
    | host :: service :: _ -> host, service
 
let resolve_host host =
  try (Unix.gethostbyname host).Unix.h_addr_list.(0)
  with Not_found ->
    Printf.eprintf "Host not found: %s\n" host;
    exit 1
 
let resolve_service service =
  try int_of_string service
  with Failure _ ->
    try (Unix.getservbyname service "tcp").Unix.s_port
    with Not_found ->
      Printf.eprintf "Service not found: %s\n" service;
      exit 1
 
(* begin our server *)
let start_proxy () =
  try
    let proto = (Unix.getprotobyname "tcp").Unix.p_proto in
    let addr, port =
      match parse_host (!local ^ ":" ^ !service) with
        | host, service ->
            (resolve_host host,
             resolve_service service) in
    proxy_server := Unix.socket Unix.PF_INET Unix.SOCK_STREAM proto;
    Unix.setsockopt !proxy_server Unix.SO_REUSEADDR true;
    Unix.bind !proxy_server (Unix.ADDR_INET (addr, port));
    Unix.listen !proxy_server 128;
    Printf.printf "[Proxy server on %s initialized.]\n%!"
      (if !local <> "" then !local else !service)
  with Unix.Unix_error (e, _, _) ->
    Printf.eprintf "Can't create proxy server: %s\n%!"
      (Unix.error_message e);
    exit 1
 
(* helper function to produce a nice string in the form HOST:PORT *)
let peerinfo sock =
  match Unix.getpeername sock with
    | Unix.ADDR_INET (addr, port) ->
        let hostinfo = Unix.gethostbyaddr addr in
        Printf.sprintf "%s:%d" hostinfo.Unix.h_name port
    | _ -> assert false
 
(* somebody just died.  keep harvesting the dead until  *)
(* we run out of them.  check how long they ran. *)
let rec reaper signal =
  begin
    let result =
      try Some (Unix.waitpid [Unix.WNOHANG] (-1))
      with Unix.Unix_error (Unix.ECHILD, _, _) -> None in
    match result with
      | Some (child, status) when Hashtbl.mem children child ->
          let start = Hashtbl.find children child in
          let runtime = Unix.time () -. start in
          Printf.printf "Child %d ran %dm%fs\n%!"
            child
            (int_of_float (runtime /. 60.))
            (mod_float runtime 60.);
          Hashtbl.remove children child;
          reaper signal
      | Some (child, status) ->
          Printf.printf "Bizarre kid %d exited with %s\n%!"
            child
            (match status with
               | Unix.WEXITED code ->
                   "code " ^ string_of_int code
               | Unix.WSTOPPED signal
               | Unix.WSIGNALED signal ->
                   "signal " ^ string_of_int signal);
          reaper signal
      | None -> ()
  end;
  (* If I had to choose between System V and 4.2, I'd resign. *)
  (* --Peter Honeyman *)
  Sys.set_signal Sys.sigchld (Sys.Signal_handle reaper)
 
let service_clients () =
  (* harvest the moribund *)
  Sys.set_signal Sys.sigchld (Sys.Signal_handle reaper);
 
  (* an accepted connection here means someone inside wants out *)
  while true do
    try
      begin
        let local_client = fst (Unix.accept !proxy_server) in
        let lc_info = peerinfo local_client in
        Printf.printf "[Connect from %s]\n%!" lc_info;
 
        let proto = (Unix.getprotobyname "tcp").Unix.p_proto in
        let addr, port =
          match parse_host (!remote ^ ":" ^ !service) with
            | host, service ->
                (resolve_host host,
                 resolve_service service) in
        Printf.printf "[Connecting to %s...%!" !remote;
        let remote_server = Unix.socket Unix.PF_INET Unix.SOCK_STREAM proto in
        Unix.connect remote_server (Unix.ADDR_INET (addr, port));
        Printf.printf "done]\n%!";
 
        let local_in = Unix.in_channel_of_descr local_client in
        let local_out = Unix.out_channel_of_descr local_client in
        let remote_in = Unix.in_channel_of_descr remote_server in
        let remote_out = Unix.out_channel_of_descr remote_server in
 
        match Unix.fork () with
          | 0 ->
              (* at this point, we are the forked child process dedicated *)
              (* to the incoming client.  but we want a twin to make i/o *)
              (* easier. *)
 
              Unix.close !proxy_server;  (* no use to slave *)
 
              (* now each twin sits around and ferries lines of data. *)
              (* see how simple the algorithm is when you can have *)
              (* multiple threads of control? *)
 
              (match Unix.fork () with
                 | 0 ->
                     (* this is the fork's child, the master's grandchild *)
                     (try
                          while true do
                            let line = input_line local_in in
                            Printf.fprintf remote_out "%s\n%!" line
                          done
                      with End_of_file ->
                        (* kill my twin cause we're done *)
                        Unix.kill (Unix.getppid ()) Sys.sigterm)
                 | kidpid ->
                     (* this is the fork's parent, the master's child *)
                     (try
                          while true do
                            let line = input_line remote_in in
                            Printf.fprintf local_out "%s\n%!" line
                          done
                      with End_of_file ->
                        (* kill my twin cause we're done *)
                        Unix.kill kidpid Sys.sigterm));
 
              exit 0  (* whoever's still alive bites it *)
 
          | kidpid ->
              (* remember his start time *)
              Hashtbl.replace children kidpid (Unix.time ());
              Unix.close remote_server;  (* no use to master *)
              Unix.close local_client;   (* likewise *)
      end
    with Unix.Unix_error (Unix.EINTR, "accept", _) -> ()
  done
 
let () =
  check_args ();                (* processing switches *)
  start_proxy ();               (* launch our own server *)
  service_clients ();           (* wait for incoming *)
  prerr_endline "NOT REACHED";  (* you can't get here from there *)
  exit 1