(* I thought I would try writing an IRC client in OCaml.

   To run, although without exception backtrace support:

    ocaml unix.cma str.cma irc.ml

   To run compiled:

    ocamlopt -g unix.cmxa str.cmxa irc.ml -o irc && ./irc
      
      Why?  Because I want to get to know OCaml better, and because I’m
      unhappy with how running an IRC client written in C exposes me to
      untrusted data spewing into pointer-unsafe code running with my entire
      privileges.

      Plan:

      1. connect to port 6667 (done!)
      2. log in (send NICK somenick and USER username username ircserver) (done!)
      2.25. answer PING messages (done!)
      2.5. unhardcode freenode address (done!)
      3. join a channel (done!)
      4. see messages (done!)
      5. talk:
      5.1: set stdin and socket to nonblocking (done!)
      5.2: select() on stdin and socket to know what to do next (done!)
      5.3: line-buffer input from stdin and socket
      5.4: send text from stdin to socket (done!)
      5.5: query channel (done!)
      6. /msg (done!)
      6.1. Allow aliasing commands (done!)
      6.2. Make aliases work for server commands (done!)
      6.3. Handle exceptions in commands (done!)
      6.4. Set some aliases at startup (done!)
      6.5. Initialize the command map in some kind of non-idiotic way (done!)
      7. store a logfile
      8. flood the logfile between federated hosts (over e.g. ssh) so I can
      connect my UI to an always-connected server using log flooding
      9. get a UI
      *)

module Strmap = Map.Make(String) ;;
type buf_t = string
and client_state = { query: string option;
                     socket: UnixLabels.file_descr;
                     ui: UnixLabels.file_descr;
                     buf: buf_t;
                     outbuf: buf_t;
                     commands: (client_state -> string -> client_state) Strmap.t;
                   } ;;

let dial server port = (
  let s = UnixLabels.socket
    ~domain: UnixLabels.PF_INET
    ~kind: UnixLabels.SOCK_STREAM
    ~protocol: 0 in
  let ip = UnixLabels.gethostbyname server in
  let a = UnixLabels.ADDR_INET (ip.UnixLabels.h_addr_list.(0), port) in
  let () = UnixLabels.connect s ~addr: a in
  s
)
(* If the line begins with the prefix, return what follows *)
and text_after_fold prefix line = (
  let len = String.length prefix in
  if (String.length line >= len)
    && (String.lowercase (Str.first_chars line len) = String.lowercase prefix)
  then
    Some (Str.string_after line len)
  else
    None
)
and strip_newline line = let len = String.length line in
                         if 0 = len then line
                         else
                           if '\n' = line.[len - 1]
                           then String.sub line 0 (len - 1)
                           else line
(* If fd is readable (as indicated by a readables from select), return
   whatever text can be read from it, or None on EOF. *)
and nonblocking_read readables fd buf =
    if List.mem fd readables then
      try begin
        let nbytes = UnixLabels.read fd ~buf: buf ~pos: 0 ~len: (String.length buf)
        in if nbytes = 0 then None else Some (String.sub buf 0 nbytes)
      end
      with Unix.Unix_error (Unix.EAGAIN, "read", _) -> Some ""
    else
      Some ""
and split2 s sep =
  try let sep_loc = String.index s sep
      in (String.sub s 0 sep_loc, Str.string_after s (1 + sep_loc))
  with Not_found -> (s, "")
and enqueue cs line = {cs with outbuf = cs.outbuf ^ line ^ "\r\n"}
in let rec build_table =
     function
       [] -> Strmap.empty
     | (k, v) :: xs -> Strmap.add k v (build_table xs)
and handle_command cs (cmdname, args) = begin
      let cmdname = String.lowercase cmdname in
      if Strmap.mem cmdname cs.commands
      then (Strmap.find cmdname cs.commands) cs args
      else enqueue cs (cmdname ^ " " ^ args)
end
and alias_of cmdname cs args = handle_command cs (cmdname, args) in
let alias cs args =
  let (a, b) = split2 args ' '
  in {cs with commands = Strmap.add a (alias_of b) cs.commands}
in let command_table =
     build_table [ "alias", alias;
                   "def", alias_of "alias";
                   "leave", alias_of "part";
                   "j", alias_of "join";
                   "m", alias_of "msg";
                   "msg", alias_of "privmsg";
                   "privmsg", (fun cs args -> 
                     let (dest, msg) = split2 args ' ' in
                     enqueue cs ("Privmsg " ^ dest ^ " :" ^ msg)
                   );
                   "query", (fun cs dest -> {cs with query = Some dest});
                   "join", (fun cs dest ->
                     enqueue {cs with query = Some dest} ("join :" ^ dest)
                   );
                 ]
and handle_user_input cs line = begin
  let line = strip_newline line
  in match text_after_fold "/" line with
    Some command -> handle_command cs (split2 command ' ')
  | None -> (
    match (cs.query, line) with
      (_, "") -> cs
    | (Some dest, msg) -> enqueue cs ("Privmsg " ^ dest ^ " :" ^ msg)
    | (None, msg) -> let () = print_string ("no destination for message " ^ msg ^ "\n") in
                     cs
  )
end
in let rec interact cs =
  let readables, _, _ = 
    UnixLabels.select ~read: [cs.socket; cs.ui] ~write: [] ~except: [] ~timeout: 60.0
  in match (nonblocking_read readables cs.ui cs.buf,
            nonblocking_read readables cs.socket cs.buf) with
    (None, _) -> ()
  | (_, None) -> ()
  | (Some line, Some result) ->
      let () = print_string result
      (* XXX needs to correctly use linebreaks instead of read() boundaries! *)
      and cs = match text_after_fold "ping " result with
          Some pingstr -> enqueue cs ("PONG " ^ pingstr) (* XXX \r\n\r\n *)
        | None -> cs
      in let cs =
           try handle_user_input cs line
           with exn -> let () = print_string (Printexc.to_string exn) in
                       let () = print_newline () in
                       let () = Printexc.print_backtrace stdout in
                       cs
      in let bytes_written = UnixLabels.write cs.socket
        ~buf: cs.outbuf
        ~pos: 0
        ~len: (String.length cs.outbuf)
      in
      let cs = {cs with outbuf = (String.sub cs.outbuf bytes_written
                                    (String.length cs.outbuf - bytes_written))}
      in let () = flush stdout in
      interact cs
   in
let () = Printexc.record_backtrace true in
let s = dial "irc.freenode.net" 6667 in
let () = UnixLabels.set_nonblock s
and () = UnixLabels.set_nonblock UnixLabels.stdin
and nbuf = String.create 4096 in
(* XXX hardcoded nick, username, host, and realname *)
interact { query = None;
           socket = s;
           ui = UnixLabels.stdin;
           buf = nbuf;
           outbuf = "NICK alnutscrew\r\nUSER kragen kragen irc.freenode.net :kragen\r\n";
           commands = command_table;
         }