irc message parser/printer

lib/msg/dune

@@ -0,0 +1,4 @@
+(library
+ (name ircd_msg)
+ (inline_tests)
+ (preprocess (pps ppx_expect ppx_deriving.show)))

lib/msg/ircd_msg.ml

@@ -0,0 +1,127 @@
+type t = {
+  prefix : string option;
+  command : string;
+  params : string list;
+  trailing : bool;
+} [@@deriving show { with_path = false }]
+
+let rec is_params_trailing = function
+  | [] -> false
+  | [tr] -> String.contains tr ' '
+  | _ :: tl -> is_params_trailing tl
+
+let make ?prefix ?(always_trailing = false) command params =
+  let trailing = always_trailing || is_params_trailing params in
+  { prefix; command; params; trailing }
+
+let write buf t =
+  Option.iter
+    (fun pre ->
+       Buffer.add_char buf ':';
+       Buffer.add_string buf pre;
+       Buffer.add_char buf ' ')
+    t.prefix;
+  Buffer.add_string buf t.command;
+  let rec add_params = function
+    | [] -> ()
+    | [tr] when t.trailing ->
+      Buffer.add_string buf " :";
+      Buffer.add_string buf tr
+    | hd::tl ->
+      Buffer.add_char buf ' ';
+      Buffer.add_string buf hd;
+      add_params tl
+  in
+  add_params t.params;
+  Buffer.add_string buf "\r\n"
+
+exception Empty_message
+
+let parse str i endp =
+  let startswith f i = if i >= endp then false else f str.[i] in
+  let rec span f i = if startswith f i then span f (i + 1) else i in
+  let cl = function ':' -> true | _ -> false in
+  let sp = function ' ' -> true | _ -> false in
+  let nosp = function ' ' -> false | _ -> true in
+
+  let i, prefix =
+    if startswith cl i then
+      let i_s = i + 1 in
+      let i_e = span nosp i_s in
+      let prefix = String.sub str i_s (i_e - i_s) in
+      i_e, Some prefix
+    else
+      i, None
+  in
+
+  let i, command =
+    let i_s = span sp i in
+    if i_s >= endp then raise_notrace Empty_message;
+    let i_e = span nosp i_s in
+    let command = String.sub str i_s (i_e - i_s) |> String.uppercase_ascii in
+    i_e, command
+  in
+
+  let rec params acc i =
+    let i_s = span sp i in
+    if i_s >= endp then
+      List.rev acc, false
+    else if startswith cl i_s then
+      let i_s = i_s + 1 in
+      let i_e = endp in
+      let trailing = String.sub str i_s (i_e - i_s) in
+      List.rev (trailing :: acc), true
+    else
+      let i_e = span nosp i_s in
+      let param = String.sub str i_s (i_e - i_s) in
+      params (param :: acc) i_e
+  in
+
+  let params, always_trailing = params [] i in
+  make command params ?prefix ~always_trailing 
+
+let parse ?(ofs = 0) ?(len = max_int) str =
+  let endp = ofs + min len (String.length str) in
+  try Some (parse str ofs endp)
+  with Empty_message -> None
+
+;;
+
+let%expect_test _ =
+  let print_msg_nl m =
+    let buf = Buffer.create 64 in
+    write buf m;
+    Printf.printf "%S\n" (Buffer.contents buf)
+  in
+  let print_parsed_msg_nl = function
+    | Some m -> Format.kasprintf print_string "%a\n" pp m
+    | None -> print_endline "empty"
+  in
+
+  make "NICK" ["tali"] |> print_msg_nl;
+  [%expect {| "NICK tali\r\n" |}];
+
+  make "USER" ["milo"; "0"; "*"; "milo"] ~always_trailing:true |> print_msg_nl;
+  [%expect {| "USER milo 0 * :milo\r\n" |}];
+
+  make "001" ["tali"; "Welcome to the IRC Network"] ~prefix:"localhost" |> print_msg_nl;
+  [%expect {| ":localhost 001 tali :Welcome to the IRC Network\r\n" |}];
+
+  parse ":source  usEr  tali  0  *  iitalics" |> print_parsed_msg_nl;
+  [%expect {|
+    { prefix = (Some "source"); command = "USER";
+      params = ["tali"; "0"; "*"; "iitalics"]; trailing = false }
+  |}];
+
+  parse "PRIVMSG #lol :Hello world" |> print_parsed_msg_nl;
+  [%expect {|
+    { prefix = None; command = "PRIVMSG"; params = ["#lol"; "Hello world"];
+      trailing = true }
+  |}];
+
+  parse "    " |> print_parsed_msg_nl;
+  [%expect {| empty |}];
+
+  parse ":source    " |> print_parsed_msg_nl;
+  [%expect {| empty |}];
+  

lib/msg/ircd_msg.mli

@@ -0,0 +1,14 @@
+type t = {
+  prefix : string option;
+  command : string;
+  params : string list;
+  trailing : bool;
+}
+
+val pp : Format.formatter -> t -> unit
+
+val make : ?prefix:string -> ?always_trailing:bool ->
+  string -> string list -> t
+
+val write : Buffer.t -> t -> unit
+val parse : ?ofs:int -> ?len:int -> string -> t option