17. 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";;

(* 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 *)

(* 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 () =
  (* 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