Ocaml/FAQ/Internet Services

#load "unix.cma";;
 
let () =
  try
    let addresses = Unix.gethostbyname name in
    let addresses =
      Array.map Unix.string_of_inet_addr addresses.Unix.h_addr_list in
    (* addresses is an array of IP addresses *)
    Array.iter print_endline addresses
  with Not_found ->
    Printf.printf "Can't resolve %s\n" name
 
(*-----------------------------*)
 
let () =
  try
    let host = Unix.gethostbyaddr (Unix.inet_addr_of_string address) in
    let name = host.Unix.h_name in
    (* name is the hostname ("www.perl.com") *)
    print_endline name
  with Not_found ->
    Printf.printf "Can't resolve %s\n" address
 
(*-----------------------------*)
 
let () =
  try
    let host = Unix.gethostbyaddr (Unix.inet_addr_of_string address) in
    let name = host.Unix.h_name in
    try
      let addresses = Unix.gethostbyname name in
      let addresses =
        Array.map Unix.string_of_inet_addr addresses.Unix.h_addr_list in
      Array.iter print_endline addresses;
      let found = List.mem address (Array.to_list addresses) in
      print_endline (if found then "found" else "not found")
    with Not_found ->
      Printf.printf "Can't look up %s\n" name
  with Not_found ->
    Printf.printf "Can't look up %s\n" address
 
(*-----------------------------*)
 
#!/usr/bin/ocaml
(* mxhost - find mx exchangers for a host *)
 
(* Though there is an experimental new DNS resolver for OCaml called
   Netdns, it does not yet support resolving MX records. For now, we'll
   use Net::DNS through perl4caml until a better solution is available.
*)
#directory "+perl";;
#load "perl4caml.cma";;
let _ = Perl.eval "use Net::DNS"
 
let host = Sys.argv.(1)
let res = Perl.call_class_method "Net::DNS::Resolver" "new" []
let mx = Perl.call_array ~fn:"mx" [res; Perl.sv_of_string host]
let () =
  if mx = [] then
    Printf.eprintf "Can't find MX records for %s (%s)\n"
      host (Perl.string_of_sv (Perl.call_method res "errorstring" []))
 
let () =
  List.iter
    (fun record ->
       let preference = Perl.call_method record "preference" [] in
       let exchange = Perl.call_method record "exchange" [] in
       Printf.printf "%s %s\n"
         (Perl.string_of_sv preference)
         (Perl.string_of_sv exchange))
    mx
 
(*-----------------------------*)
 
#!/usr/bin/ocaml
(* hostaddrs - canonize name and show addresses *)
#load "unix.cma";;
let name = Sys.argv.(1)
let hent = Unix.gethostbyname name
let () =
  Printf.printf "%s => %s\n"
    hent.Unix.h_name    (* in case different *)
    (String.concat " "
       (Array.to_list
          (Array.map
             Unix.string_of_inet_addr
             hent.Unix.h_addr_list)))

(* The Netclient package from Ocamlnet provides an event-driven
   FTP client. This client does not currently support uploading.
 
   Ocamlnet is available here:
   http://projects.camlcity.org/projects/ocamlnet.html
 
   This recipe assumes it has been installed with findlib. *)
 
#use "topfind";;
#require "netclient";;
 
(* Create an FTP client instance. *)
let ftp = new Ftp_client.ftp_client ()
 
(* Build and execute a chain of FTP methods. *)
let () =
  ftp#add (new Ftp_client.connect_method ~host:"127.0.0.1" ());
  ftp#add (new Ftp_client.login_method
             ~user:"anonymous"
             ~get_password:(fun () -> "user@example.com")
             ~get_account:(fun () -> "anonymous") ());
  ftp#add (new Ftp_client.walk_method (`Dir "/pub"));
  let ch = new Netchannels.output_channel (open_out "output.txt") in
  ftp#add (new Ftp_client.get_method
             ~file:(`Verbatim "index.txt")
             ~representation:`Image
             ~store:(fun _ -> `File_structure ch) ());
  ftp#run ()
 
(*-----------------------------*)
 
(* If an error occurs, it will be exposed by the "state" property. *)
let () =
  match ftp#state with
    | `Error (Ftp_client.FTP_error (Unix.Unix_error (e, _, _))) ->
        Printf.eprintf "Error: %s\n%!"
          (Unix.error_message e)
    | _ -> ()
 
(*-----------------------------*)
 
(* To determine the current working directory, send invoke the `PWD
   command and inspect the result in a callback. *)
let () =
  ftp#add (new Ftp_client.invoke_method
             ~command:`PWD
             ~process_result:(fun state (code, message) ->
                                Printf.printf
                                  "I'm in the directory %s\n%!"
                                  message) ())
 
(*-----------------------------*)
 
(* Use mkdir_method and rmdir_method to make and remove directories from
   the remote server. Use the optional ~onerror argument to specify an
   error handler. *)
let () =
  ftp#add
    ~onerror:(fun e ->
                Printf.eprintf "Can't create /ocaml: %s\n%!"
                  (Printexc.to_string e))
    (new Ftp_client.mkdir_method (`Verbatim "/pub/ocaml"))
 
(*-----------------------------*)
 
(* Use a list_method to get a list of files in a remote directory. *)
let () =
  let buffer = Buffer.create 256 in
  let ch = new Netchannels.output_buffer buffer in
  ftp#add
    ~onsuccess:(fun () -> print_endline (Buffer.contents buffer))
    ~onerror:(fun e ->
                Printf.eprintf "Can't get a list of files in /pub: %s\n%!"
                  (Printexc.to_string e))
    (new Ftp_client.list_method
       ~dir:(`Verbatim "/pub")
       ~representation:`Image
       ~store:(fun _ -> `File_structure ch) ())
 
(*-----------------------------*)
 
(* Use `QUIT followed by ftp#abort to close the connection and exit
   the event loop. *)
let () =
  ftp#add (new Ftp_client.invoke_method
             ~command:`QUIT
             ~process_result:(fun _ _ -> ftp#abort ()) ())

(* Use Netsendmail, part of the Netstring package that comes with
   Ocamlnet, to send mail through a command-line mailer program. *)
 
#use "topfind";;
#require "netstring";;
 
let () =
  Netsendmail.sendmail
    ~mailer:"/usr/sbin/sendmail"  (* defaults to "/usr/lib/sendmail" *)
    (Netsendmail.compose
       ~from_addr:(from_name, from_address)
       ~to_addrs:[(to_name, to_address)]
       ~subject:subject
       body)
 
(*-----------------------------*)
 
(* You can also open a pipe directly to sendmail. *)
 
#load "unix.cma";;
 
let () =
  let sendmail =
    Unix.open_process_out "/usr/lib/sendmail -oi -t -odq" in
  output_string sendmail "\
From: User Originating Mail <me@host>
To: Final Destination <you@otherhost>
Subject: A relevant subject line
 
Body of the message goes here, in as many lines as you like.
";
  ignore (Unix.close_process_out sendmail)

(* There is no NNTP library available for OCaml. With a little
   preparation, we can easily use the one that comes with Perl
   using perl4caml (http://merjis.com/developers/perl4caml) *)
 
#directory "+perl";;
#load "perl4caml.cma";;
 
module NNTP = struct
  open Perl
  let _ = eval "use Net::NNTP"
 
  (* Returned by "list" method so that newsgroups stay sorted. *)
  module GroupMap = Map.Make(String)
 
  (* Wrapper for Net::NNTP class. *)
  class nntp host =
    let nntp =
      call_class_method "Net::NNTP" "new" [sv_of_string host] in
 
    (* Raise a Failure exception if we couldn't connect. *)
    let () =
      if sv_is_undef nntp
      then failwith (string_of_sv (eval "$!")) in
 
    (* Helper function to transform nullable string arrays to OCaml. *)
    let maybe_string_list sv =
      if sv_is_undef sv
      then raise Not_found
      else List.map string_of_sv (list_of_av (deref_array sv)) in
 
  object (self)
    val nntp = nntp
 
    method group name =
      match call_method_array nntp "group" [sv_of_string name] with
        | [narticles; first; last; name] ->
            (int_of_sv narticles, int_of_sv first,
             int_of_sv last, string_of_sv name)
        | _ -> raise Not_found
 
    method head msgid =
      maybe_string_list (call_method nntp "head" [sv_of_int msgid])
 
    method body msgid =
      maybe_string_list (call_method nntp "body" [sv_of_int msgid])
 
    method article msgid =
      maybe_string_list (call_method nntp "article" [sv_of_int msgid])
 
    method postok () =
      bool_of_sv (call_method nntp "postok" [])
 
    method post lines =
      let lines = List.map sv_of_string lines in
      if (sv_is_undef (call_method nntp "post" lines))
      then failwith (string_of_sv (eval "$!"))
 
    method list () =
      let hv = deref_hash (call_method nntp "list" []) in
      let map = ref GroupMap.empty in
      List.iter
        (fun (name, info) ->
           map :=
             GroupMap.add
               name
               (match list_of_av (deref_array info) with
                  | [last; first; flags] ->
                      (int_of_sv last, int_of_sv first,
                       string_of_sv flags)
                  | _ -> assert false)
               !map)
        (assoc_of_hv hv);
      !map
 
    method quit () =
      ignore (call_method nntp "quit" [])
  end
end
 
(*-----------------------------*)
 
(* Connect to an NNTP server by creating an "nntp" object. *)
let server =
  try new NNTP.nntp "news.west.cox.net"
  with Failure s ->
    Printf.eprintf "Can't connect to news server: %s\n" s;
    exit 1
 
(*-----------------------------*)
 
(* Select a newsgroup and retrieve its stats. *)
let (narticles, first, last, name) =
  try server#group "misc.test"
  with Not_found ->
    Printf.eprintf "Can't select misc.test\n";
    exit 1
 
(*-----------------------------*)
 
(* Get the headers from the last article. *)
let headers =
  try server#head last
  with Not_found ->
    Printf.eprintf "Can't get headers from article %d in %s\n"
      last name;
    exit 1
 
(*-----------------------------*)
 
(* Get the body from the last article. *)
let body =
  try server#head last
  with Not_found ->
    Printf.eprintf "Can't get body from article %d in %s\n"
      last name;
    exit 1
 
(*-----------------------------*)
 
(* Get the headers and body from the last article. *)
let article =
  try server#head last
  with Not_found ->
    Printf.eprintf "Can't get article from article %d in %s\n"
      last name;
    exit 1
 
(*-----------------------------*)
 
(* Determine if posting is allowed with this server. *)
let () =
  if not (server#postok ())
  then Printf.eprintf "Server didn't tell me I could post.\n"
 
(*-----------------------------*)
 
(* Post a message. *)
let () =
  begin
    try server#post lines
    with Failure s ->
      Printf.eprintf "Can't post: %s\n" s;
      exit 1
  end
 
(*-----------------------------*)
 
(* Get the complete list of newsgroups. *)
let () =
  let groupmap = server#list () in
  NNTP.GroupMap.iter
    (fun group (last, first, flags) ->
       if flags = "y"
       then (* I can post to [group] *) ())
    groupmap

(* Use Netpop, which is part of Ocamlnet. *)
#use "topfind";;
#require "pop";;
 
(* To create a Netpop client, you need to look up the server address
   and build a network connection first. Netpop uses wrappers called
   Netchannels to abstract the input and output channels. *)
let inet_addr =
  (Unix.gethostbyname mail_server).Unix.h_addr_list.(0)
let addr = Unix.ADDR_INET (inet_addr, Netpop.tcp_port)
let ic, oc = Unix.open_connection addr
let pop =
  new Netpop.client
    (new Netchannels.input_channel ic)
    (new Netchannels.output_channel oc)
let () =
  pop#user username;
  pop#pass password
 
(* Messages are retreived as a hashtable from message IDs to tuples,
   each tuple containing the message size in bytes and a string of
   server-specific extension data. *)
let messages = pop#list ()
let () =
  Hashtbl.iter
    (fun msgid (size, ext) ->
       let message = pop#retr msgid in
       (* message is a Netchannels.in_obj_channel *)
       pop#dele msgid)
    messages
 
(*-----------------------------*)
 
(* Use pop#apop instead of pop#user/pop#pass to avoid sending passwords
   in plaintext across the network. *)
let () = pop#apop username password
 
(*-----------------------------*)
 
(* Get a message by number and print it to the console. *)
let () =
  Printf.printf "Retrieving %d : %!" msgnum;
  try
    let message = pop#retr msgnum in
    print_newline ();
    print_endline
      (Netchannels.string_of_in_obj_channel message)
  with Netpop.Err_status e ->
    Printf.printf "failed (%s)\n%!" e
 
(*-----------------------------*)
 
(* Gracefully tear down the connection. *)
let () =
  pop#quit ();
  Unix.shutdown_connection ic;
  close_out oc

(* To simulate a Telnet client with OCaml, you can use the
   Telnet_client module from Ocamlnet's "netclient" package.
 
   This module is written in an asynchronous style, so you
   will need to create event handlers to process the Telnet
   events that occur: data, end of file, timeout, and the
   sending and receiving of options (also known as "do",
   "don't", "will", and "won't". *)
 
#use "topfind";;
#require "netclient";;
 
open Telnet_client
 
(* This class wraps the Telnet session for convenience in
   defining event handlers and chaining them together. *)
class session ~host ~port ~username ~password ~prompt ~timeout =
object (self)
  (* Telnet_client.telnet_session instance to wrap. *)
  val telnet = new telnet_session
 
  (* Initial on-data handler, which will be redefined later. *)
  val mutable process = fun _ -> ()
 
  (* Initialize the Telnet session. *)
  initializer
    telnet#set_connection (Telnet_connect (host, port));
    telnet#set_options {connection_timeout=timeout;
                        verbose_connection=false;
                        verbose_input=false;
                        verbose_output=false};
    telnet#set_callback self#on_input;
    telnet#set_exception_handler self#on_exception;
    telnet#attach ();
    process <- self#start
 
  (* Build an input callback that checks for a regular
     expression match in the input and calls a callback
     function if the match is positive. *)
  method waitfor pat cb =
    let rex = Pcre.regexp pat in
    fun data -> if Pcre.pmatch ~rex data then cb data
 
  (* Enqueue a line of data and flush the output queue. *)
  method write data =
    Queue.add (Telnet_data data) telnet#output_queue;
    Queue.add (Telnet_data "\n") telnet#output_queue;
    telnet#update ()
 
  (* Handle first input: wait for a login prompt and then
     invoke self#send_username to send the username. *)
  method start =
    self#waitfor "ogin:" self#send_username
 
  (* Send the username and wait for the password prompt. *)
  method send_username data =
    self#write username;
    process <- self#waitfor "assword:" self#send_password
 
  (* Send the password and wait to see if we succeeded. *)
  method send_password data =
    self#write password;
    process <- self#verify_login
 
  (* Determine if the login was a success or a failure.
     Abort with an exception on failure; call self#logged_in
     on success. *)
  method verify_login data =
    if Pcre.pmatch ~pat:"incorrect" data
    then failwith "Login failed"
    else if Pcre.pmatch ~pat:"^\\s*$" data
    then () (* ignore blank lines *)
    else self#logged_in data
 
  (* Logged in successfully. Wait for a prompt if necessary
     and call self#run_ls to send the first command. *)
  method logged_in data =
    process <- self#waitfor prompt self#run_ls;
    self#waitfor prompt self#run_ls data
 
  (* Do a directory listing and wait for results. *)
  method run_ls data =
    self#write "/bin/ls -1";
    process <- self#gather_files
 
  (* This variable will buffer the results of the "ls" command. *)
  val mutable files = ""
 
  (* Buffer the filenames printed out from the "ls" command and
     print them out once we get a prompt. *)
  method gather_files data =
    if Pcre.pmatch ~pat:prompt data
    then
      begin
        files <- Pcre.replace ~pat:"^/bin/ls -1\\s*" files;
        Printf.printf
          "Files: %s\n%!"
          (String.concat ", "
             (Pcre.split ~pat:"\\s+" files));
        self#run_top data
      end
    else files <- files ^ data
 
  (* Run another command until we get a prompt and then call
     self#close to close the connection. *)
  method run_top data =
    self#write "top -n1 -b";
    process <- self#waitfor prompt self#close
 
  (* Close the connection by sending an EOF. *)
  method close data =
    Queue.add Telnet_eof telnet#output_queue
 
  (* When we receive an EOF, exit the program. *)
  method on_eof () =
    prerr_endline "EOF";
    exit 0
 
  (* If a timeout event is received, exit with an error code. *)
  method on_timeout () =
    prerr_endline "Timeout";
    exit 1
 
  (* Print any thrown exceptions to standard error. *)
  method on_exception exn =
    prerr_endline (Printexc.to_string exn)
 
  (* This is the main error handler, which dispatches on
     Telnet_client events. *)
  method on_input got_synch =
    while not (Queue.is_empty telnet#input_queue) do
      let tc = Queue.take telnet#input_queue in
      match tc with
        | Telnet_data data -> process data
            | Telnet_eof -> self#on_eof ()
            | Telnet_timeout -> self#on_timeout ()
        | Telnet_will _
        | Telnet_wont _
        | Telnet_do _
        | Telnet_dont _ ->
            (* The telnet_session handles these events.
               Calling this method is necessary. *)
            telnet#process_option_command tc
            | _ -> ()
    done
 
  (* Run the Telnet session by calling the "run" method on
     the underling telnet_session instance. *)
  method run = telnet#run
end
 
(* Create an instance of our custom session class. *)
let session =
  new session
    ~host:"localhost"
    ~port:23
    ~username:"test"
    ~password:"pleac"
    ~prompt:"\\$ $"
    ~timeout:10.
 
(* Start the session. *)
let () = session#run ()

#!/usr/bin/ocaml
(* ping - send and receive ICMP echo packets *)
 
(* There do not appear to be any libraries available for pinging
   servers from OCaml, ICMP or otherwise. In this recipe, we will
   make a diversion from the Perl recipe, which simply determines
   if a host is up, and instead write a lookalike for the "ping"
   shell command. We might as well, if we're going to all the
   trouble of building ICMP packets directly. *)
 
(* Import Unix and enable threads using findlib for convenience. *)
#use "topfind";;
#require "unix";;
#thread;;
 
(* The Packet module defines a data type and operations for building,
   parsing, and checking the integrity of ICMP packets. *)
module Packet = struct
  exception Invalid_length of int
  exception Invalid_checksum of int * int
 
  (* type' and code define the ICMP message type. An echo message
     has type'=8, code=0, and an echo reply has type'=0, code=0.
     The id is a unique identifier for the current process to help
     distinguish between replies for other processes. seq is the
     sequence number, which is usually incremented with each message.
     data is the message body whose contents depend on the type of
     message. *)
  type t = { type' : int;
             code : int;
             id : int;
             seq : int;
             data : string }
 
  (* Define a convenience function for constructing packets. *)
  let make ?(type'=8) ?(code=0) ~id ~seq data =
    {type'=type'; code=code; id=id; seq=seq; data=data}
 
  (* Calculate a checksum for a message by adding its contents, two
     bytes at a time, folding the high order bits into the low order
     bits, and taking the logical complement. The result will be an
     int with 16-bit precision. *)
  let checksum s =
    let num_bytes = String.length s in
    let num_shorts = num_bytes / 2 in
    let rec sum_shorts i sum =
      if i < num_shorts then
        let short = Int32.of_int (int_of_char s.[i * 2] lsl 8
                                  + int_of_char s.[i * 2 + 1]) in
        sum_shorts (i + 1) (Int32.add sum short)
      else sum in
    let sum = sum_shorts 0 0l in
    let sum =
      if num_bytes mod 2 = 1 then
        Int32.add sum
          (Int32.of_int (int_of_char s.[num_bytes - 1] lsl 8))
      else sum in
    let sum =
      Int32.add
        (Int32.shift_right sum 16)
        (Int32.logand sum 0xffffl) in
    Int32.to_int
      (Int32.logand
         (Int32.lognot (Int32.add (Int32.shift_right sum 16) sum))
         0xffffl)
 
  (* Convert a packet to a string that can be sent over a socket. *)
  let to_string {type'=type'; code=code; id=id; seq=seq; data=data} =
    let b = Buffer.create 20 in
    Buffer.add_char b (char_of_int type');
    Buffer.add_char b (char_of_int code);
    Buffer.add_char b '\000';  (* checksum hi *)
    Buffer.add_char b '\000';  (* checksum lo *)
    Buffer.add_char b (char_of_int (id lsr 8 land 0xff));
    Buffer.add_char b (char_of_int (id land 0xff));
    Buffer.add_char b (char_of_int (seq lsr 8 land 0xff));
    Buffer.add_char b (char_of_int (seq land 0xff));
    Buffer.add_string b data;
    let packet = Buffer.contents b in
    let sum = checksum packet in
    packet.[2] <- char_of_int (sum lsr 8 land 0xff);
    packet.[3] <- char_of_int (sum land 0xff);
    packet
 
  (* Parse a string into a packet structure. If the string is less than
     8 bytes long, an Invalid_length exception will be raised. If the
     checksum does not match the contents, an Invalid_checksum
     exception will be raised. *)
  let of_string s =
    if String.length s < 8 then raise (Invalid_length (String.length s));
    let s' = String.copy s in
    s'.[2] <- '\000';
    s'.[3] <- '\000';
    let sum = int_of_char s.[2] lsl 8 + int_of_char s.[3] in
    let sum' = checksum s' in
    if sum <> sum' then raise (Invalid_checksum (sum, sum'));
    {type'=int_of_char s.[0];
     code=int_of_char s.[1];
     id=int_of_char s.[4] lsl 8 + int_of_char s.[5];
     seq=int_of_char s.[6] lsl 8 + int_of_char s.[7];
     data=String.sub s 8 (String.length s - 8)}
end
 
(* Define a data structure for the message body of our echo requests. *)
type payload = { timestamp : float; data : string }
 
(* Send a single ICMP echo request to the given socket and address. *)
let ping socket sockaddr id seq =
  let payload =
    Marshal.to_string {timestamp=Unix.gettimeofday ();
                       data="abcdefghijklmnopqrstuvwxyz0123456"} [] in
  let message = Packet.to_string (Packet.make ~id ~seq payload) in
  ignore
    (Unix.sendto socket message 0 (String.length message) [] sockaddr)
 
(* Loop forever waiting for echo replies, printing them to the
   console along with their hostname, IP, and round-trip time. *)
let pong socket id =
  let buffer = String.make 256 '\000' in
  while true do
    let length, sockaddr =
      Unix.recvfrom socket buffer 0 (String.length buffer) [] in
    let response =
      Packet.of_string (String.sub buffer 20 (length - 20)) in
    match sockaddr, response with
      | Unix.ADDR_INET (addr, port),
        {Packet.type'=0; code=0; id=id'; seq=seq; data=data}
          when id = id' ->
          let host_entry = Unix.gethostbyaddr addr in
          let payload = Marshal.from_string data 0 in
          Printf.printf
            "%d bytes from %s (%s): icmp_seq=%d time=%.3f ms\n%!"
            (String.length data)
            host_entry.Unix.h_name
            (Unix.string_of_inet_addr addr)
            seq
            ((Unix.gettimeofday () -. payload.timestamp) *. 1000.)
      | _ -> ()
  done
 
(* Read hostname from command line. *)
let host =
  if Array.length Sys.argv <> 2
  then (Printf.eprintf "Usage: %s host\n" Sys.argv.(0); exit 1)
  else Sys.argv.(1)
 
(* Use DNS to find the IP address and canonical name. *)
let name, addr =
  try
    let h = Unix.gethostbyname host in
    h.Unix.h_name, h.Unix.h_addr_list.(0)
  with Not_found ->
    Printf.eprintf "%s: unknown host %s\n" Sys.argv.(0) host;
    exit 2
 
(* Make sure we are running as root, since this is required to
   open a socket with SOCK_RAW and send ICMP packets. *)
let () =
  if Unix.getuid () <> 0
  then (Printf.eprintf "%s: icmp ping requires root privilege\n"
          Sys.argv.(0);
        exit 3)
 
(* Start the ping loop. *)
let () =
  Printf.printf "PING %s (%s)\n" name (Unix.string_of_inet_addr addr);
 
  (* Build a socket and destination address. *)
  let proto = (Unix.getprotobyname "icmp").Unix.p_proto in
  let socket = Unix.socket Unix.PF_INET Unix.SOCK_RAW proto in
  let sockaddr = Unix.ADDR_INET (addr, 0) in
 
  (* Use the PID as the ID for packets, and create a counter for
     the sequence number. *)
  let id = Unix.getpid () in
  let seq = ref 0 in
 
  (* Start a background thread to print the echo replies. *)
  ignore (Thread.create (pong socket) id);
 
  (* Loop forever sending echo requests and sleeping. *)
  while true do
    incr seq;
    ping socket sockaddr id !seq;
    Unix.sleep 1
  done

(* WHOIS servers depend on the TLD, and their output formats are
   informal, inconsistent, and completely different from server
   to server. This makes a general solution very large and ad-hoc.
   The Net::Whois package, on which the original Perl recipe was
   based, no longer works since WHOIS servers started redirecting
   to other servers for most of the information.
 
   Since no libraries are available for this task, we will do a
   WHOIS lookup manually using sockets. This example shows how to
   perform a WHOIS lookup for the "sourceforge.net" domain, and
   probably will not work without modification for domains under
   any other TLD. *)
 
#load "unix.cma";;
#load "str.cma";;
 
let domain_name = "sourceforge.net"
let whois_server = "whois.internic.net"
let service = Unix.getservbyname "whois" "tcp"
 
let ltrim =
  let re = Str.regexp "^[ \r\n\t\x00\x0B]*" in
  Str.global_replace re ""
 
let () =
  (* Connect to the parent server to find the redirect. *)
 
  let host = Unix.gethostbyname whois_server in
  let socket_in, socket_out =
    Unix.open_connection
      (Unix.ADDR_INET (host.Unix.h_addr_list.(0),
                       service.Unix.s_port)) in
 
  output_string socket_out domain_name;
  output_string socket_out "\n";
  flush socket_out;
 
  let whois_redirect_regexp = Str.regexp "Whois Server: \\(.*\\)" in
  let whois_redirect = ref "" in
 
  begin
    try
      while true do
        let line = ltrim (input_line socket_in) in
        if Str.string_match whois_redirect_regexp line 0
        then whois_redirect := Str.matched_group 1 line
      done
    with End_of_file ->
      Unix.shutdown_connection socket_in
  end;
 
  if !whois_redirect = ""
  then failwith "Couldn't find WHOIS redirect";
 
  (* Connect to the real server and get the WHOIS data. *)
 
  let host = Unix.gethostbyname !whois_redirect in
  let socket_in, socket_out =
    Unix.open_connection
      (Unix.ADDR_INET (host.Unix.h_addr_list.(0),
                       service.Unix.s_port)) in
 
  output_string socket_out domain_name;
  output_string socket_out "\n";
  flush socket_out;
 
  let domain_name_regexp = Str.regexp "Domain name: \\(.*\\)" in
  let domain_name = ref "" in
 
  let registrant_regexp = Str.regexp "Registrant:" in
  let registrant_name = ref "" in
  let registrant_address = ref [] in
  let registrant_country = ref "" in
 
  let contact_regexp = Str.regexp "\\(.*\\) Contact:" in
  let contacts = ref [] in
 
  begin
    try
      while true do
        let line = ltrim (input_line socket_in) in
        if Str.string_match domain_name_regexp line 0
        then domain_name := Str.matched_group 1 line
        else if Str.string_match registrant_regexp line 0
        then
          begin
            (* Read registrant data. *)
            registrant_name := ltrim (input_line socket_in);
            let finished = ref false in
            while not !finished do
              let line = ltrim (input_line socket_in) in
              if String.length line > 2
              then registrant_address := !registrant_address @ [line]
              else if String.length line = 2
              then registrant_country := line
              else finished := true
            done
          end
        else if Str.string_match contact_regexp line 0
        then
          begin
            (* Read contact data. *)
            let contact_type = Str.matched_group 1 line in
            let contact_info = ref [] in
            for i = 1 to 6 do
              let line = ltrim (input_line socket_in) in
              contact_info := !contact_info @ [line]
            done;
            contacts := (contact_type, !contact_info) :: !contacts
          end
      done
    with End_of_file ->
      Unix.shutdown_connection socket_in
  end;
 
  (* Display the results. *)
 
  Printf.printf "The domain is called %s\n" !domain_name;
  Printf.printf "Mail for %s should be sent to:\n" !registrant_name;
  List.iter (Printf.printf "\t%s\n") !registrant_address;
  Printf.printf "\t%s\n" !registrant_country;
 
  if !contacts = []
  then Printf.printf "No contact information.\n"
  else
    begin
      Printf.printf "Contacts:\n";
      List.iter
        (fun (contact_type, contact_info) ->
           Printf.printf "  %s\n" contact_type;
           List.iter (Printf.printf "    %s\n") contact_info)
        !contacts
    end

#!/usr/bin/ocaml
(* expn -- convince smtp to divulge an alias expansion *)
 
#use "topfind";;                        (* Findlib *)
#require "str";;                        (* Stdlib *)
#require "unix";;                       (* Stdlib *)
#require "perl";;                       (* Perl4caml *)
#require "smtp";;                       (* Ocamlnet *)
let _ = Perl.eval "use Net::DNS"        (* Net::DNS *)
 
let selfname = Unix.gethostname ()
 
let () =
  if Array.length Sys.argv < 2
  then (Printf.eprintf "usage: %s address@host ...\n" Sys.argv.(0);
        exit 1)
 
let () =
  List.iter
    (fun combo ->
       let name, host =
         match Str.bounded_split (Str.regexp "@") combo 2 with
           | [] -> "", ""
           | [name] -> name, "localhost"
           | [name; host] -> name, host
           | _ -> assert false in
       let hosts =
         Perl.call_array ~fn:"mx" [Perl.sv_of_string host] in
       let hosts =
         List.map (fun mx -> Perl.call_method mx "exchange" []) hosts in
       let hosts =
         if hosts = [] then [Perl.sv_of_string host] else hosts in
       List.iter
         (fun host ->
            let host = Perl.string_of_sv host in
            Printf.printf "Expanding %s at %s (%s): %!"
              name host combo;
            let inet_addr =
              (Unix.gethostbyname host).Unix.h_addr_list.(0) in
            let addr = Unix.ADDR_INET (inet_addr, Netsmtp.tcp_port) in
            try
              let ic, oc = Unix.open_connection addr in
              let smtp =
                new Netsmtp.client
                  (new Netchannels.input_channel ic)
                  (new Netchannels.output_channel oc) in
              ignore (smtp#helo ~host:selfname ());
              print_endline
                (match smtp#expn name with
                   | None -> "None"
                   | Some results -> String.concat ", " results);
              smtp#quit ();
              Unix.shutdown_connection ic;
              close_out oc
            with Unix.Unix_error (Unix.ECONNREFUSED, _, _) ->
              Printf.eprintf "cannot connect to %s\n" host)
         hosts)
    (List.tl (Array.to_list Sys.argv))