talircd/lib/irc/mode.ml

359 lines
10 KiB
OCaml

open Types
type user = [`i | `o | `w]
type chan_a = [`b]
type chan_b = [`k | `o | `v]
type chan_c = [`l]
type chan_d = [`i | `m | `s | `t | `n]
type chan = [chan_a | chan_b | chan_c | chan_d]
type t = [user | chan]
let to_string = function
| `b -> "b"
| `i -> "i"
| `k -> "k"
| `l -> "l"
| `m -> "m"
| `n -> "n"
| `o -> "o"
| `s -> "s"
| `t -> "t"
| `v -> "v"
| `w -> "w"
let to_char x = (to_string x).[0]
let pp ppf x = Format.pp_print_string ppf (to_string x)
let of_char_user = function
| 'i' -> `i
| 'o' -> `o
| 'w' -> `w
| _ -> invalid_arg "Mode.of_char_user"
let of_char_chan = function
| 'b' -> `b
| 'i' -> `i
| 'k' -> `k
| 'l' -> `l
| 'm' -> `m
| 'n' -> `n
| 'o' -> `o
| 's' -> `s
| 't' -> `t
| 'v' -> `v
| _ -> invalid_arg "Mode.of_char_chan"
let[@warning "+8"] _check_exhaustive (x : chan) =
match x with
| #chan_a -> ()
| #chan_b -> ()
| #chan_c -> ()
| #chan_d -> ()
module Set = struct
type t = int
type elt = [user | chan_d]
let[@inline] singleton = function
| `i -> 1
| `m -> 2
| `n -> 4
| `o -> 8
| `s -> 16
| `t -> 32
| `w -> 64
let empty = 0
let equal = Int.equal
let union = ( lor )
let inter = ( land )
let diff s t = s land Int.lognot t
let mem elt s = s land (singleton elt) <> 0
let add elt s = union s (singleton elt)
let remove elt s = diff s (singleton elt)
let to_string s =
let bs = Bytes.create 7 in
let bit ch elt i =
if mem elt s then (Bytes.set bs i ch; i + 1)
else i
in
let n =
0 |> bit 'i' `i |> bit 'm' `m |> bit 'n' `n |> bit 'o' `o |>
bit 's' `s |> bit 't' `t |> bit 'w' `w
in
Bytes.sub_string bs 0 n
let pp ppf s =
Format.pp_print_string ppf (to_string s)
let of_string s =
let chr = function
| 'i' -> `i | 'm' -> `m | 'n' -> `n | 'o' -> `o
| 's' -> `s | 't' -> `t | 'w' -> `w
| _ -> invalid_arg "Irc.Mode.Set.of_string"
in
String.fold_left (fun s c -> add (chr c) s) empty s
let of_list l =
List.fold_left (fun s m -> add m s) empty l
type change = {
add : t;
rem : t;
}
let pp_change ppf { add; rem } =
if rem = empty then
Format.fprintf ppf "+%a" pp add
else if add = empty then
Format.fprintf ppf "-%a" pp rem
else
Format.fprintf ppf "+%a-%a" pp add pp rem
let no_change = { add = empty; rem = empty }
let change dir m chg =
match dir with
| `add -> { add = add m chg.add; rem = remove m chg.rem }
| `rem -> { add = remove m chg.add; rem = add m chg.rem }
let normalize t { add; rem } =
let add = diff add t in
let rem = inter rem t in
diff (union t add) rem, { add; rem }
end
module Parse = struct
exception Unknown_mode of char
exception Missing_args
let parse_mode_flags f str =
let rec loop dir acc i =
if i >= String.length str then List.rev acc
else match str.[i] with
| '+' -> loop `add acc (i + 1)
| '-' -> loop `rem acc (i + 1)
| ch ->
let mode = try f ch
with Invalid_argument _ ->
raise (Unknown_mode ch)
in
loop dir ((dir, mode) :: acc) (i + 1)
in
loop `add [] 0
type user_modes = Set.change
let no_user_mdoes = Set.no_change
let user_modes str =
let parse ms (dir, m) = Set.change dir m ms in
List.fold_left
parse
no_user_mdoes
(parse_mode_flags of_char_user str)
type 'a set_or_unset = [
| `set of 'a
| `unset
]
type add_or_rem = [
| `add
| `rem
]
type priv = [`o | `v]
type chan_modes = {
chan_modes : Set.change;
chan_key : string set_or_unset option;
chan_limit : int set_or_unset option;
chan_privs : (add_or_rem * priv * name) list;
}
let no_chan_modes = {
chan_modes = Set.no_change;
chan_key = None;
chan_limit = None;
chan_privs = []
}
let chan_modes str args =
let parse (acc, args) (dir, m) = match m, dir, args with
(* Type A: Modes that add or remove an address to or from a list. These modes MUST
always have a parameter when sent from the server to a client. A client MAY issue
this type of mode without an argument to obtain the current contents of the
list. *)
| #chan_a as m, _dir, args ->
begin match m, args with
| `b, [] -> (* TODO: show list *) acc, args
| `b, _ :: args -> (* TODO: add/rem from list *) acc, args
end
(* Type B: Modes that change a setting on a channel. These modes MUST always have a
parameter. *)
| #chan_b as m, dir, args ->
let arg, args = match args with
| [] -> raise Missing_args
| arg :: args -> arg, args
in
begin
try match m, dir, arg with
| `k, `add, k ->
if k = "" then invalid_arg "empty key";
{ acc with chan_key = Some (`set k) }, args
| `k, `rem, _k ->
{ acc with chan_key = Some `unset }, args
| (`o | `v) as priv, dir, nick ->
let chan_privs = (dir, priv, nick) :: acc.chan_privs in
{ acc with chan_privs }, args
with Invalid_argument _ ->
(* ignore invalid args (+k) *)
acc, args
end
(* Type C: Modes that change a setting on a channel. These modes MUST have a
parameter when being set, and MUST NOT have a parameter when being unset. *)
| #chan_c as m, dir, args ->
let arg, args = match dir, args with
| `add, [] -> raise Missing_args
| `add, arg :: args -> `set arg, args
| `rem, args -> `unset, args
in
begin
try match m, arg with
| `l, `set n ->
let n = Option.get (int_of_string_opt n) in
if n <= 0 then invalid_arg "limit <= 0";
{ acc with chan_limit = Some (`set n) }, args
| `l, `unset ->
{ acc with chan_limit = Some `unset }, args
with Invalid_argument _ ->
(* ignore invalid args (+l) *)
acc, args
end
(* Type D: Modes that change a setting on a channel. These modes MUST NOT have a
parameter. *)
| #chan_d as m, dir, args ->
let chan_modes = Set.change dir m acc.chan_modes in
{ acc with chan_modes }, args
in
let modes, _args =
List.fold_left
parse
(no_chan_modes, args)
(parse_mode_flags of_char_chan str)
in
(* chan_privs is built in reverse order *)
{ modes with chan_privs = List.rev modes.chan_privs }
end
let%expect_test _ =
let roundtrip of_char_x m =
match of_char_x (to_char m) with
| m' when m = m' -> ()
| m' -> Printf.printf "fail:%s!=%s\n" (to_string m) (to_string m')
| exception Invalid_argument _ -> Printf.printf "error:%s\n" (to_string m)
in
let roundtrip_user m = roundtrip of_char_user m in
let roundtrip_chan m = roundtrip of_char_chan m in
roundtrip_user `i;
roundtrip_user `w;
roundtrip_chan `i;
roundtrip_chan `k;
roundtrip_chan `l;
roundtrip_chan `m;
roundtrip_chan `n;
roundtrip_chan `o;
roundtrip_chan `s;
roundtrip_chan `t;
let print_set_nl s = Printf.printf "[%s]\n" (Set.to_string s) in
let print_bool_nl b = print_endline (if b then "true" else "false") in
let print_change_nl c = Format.kasprintf print_string "%a\n" Set.pp_change c in
print_set_nl Set.empty; [%expect {| [] |}];
print_set_nl Set.(of_string "i"); [%expect {| [i] |}];
print_set_nl Set.(of_string "no"); [%expect {| [no] |}];
print_set_nl Set.(of_string "sm"); [%expect {| [ms] |}];
print_set_nl Set.(of_string "wi"); [%expect {| [iw] |}];
print_bool_nl Set.(mem `i (of_string "ins")); [%expect "true"];
print_bool_nl Set.(mem `w (of_string "ins")); [%expect "false"];
print_bool_nl Set.(mem `w (of_string "wwww")); [%expect "true"];
print_bool_nl Set.(mem `t (of_string "imnosw")); [%expect "false"];
let print_parse_error f =
try f () |> ignore; print_endline "()"
with Parse.Unknown_mode c -> Printf.printf "unknown mode %c\n" c
| Parse.Missing_args -> Printf.printf "missing args\n"
in
print_change_nl (Parse.user_modes "+iw"); [%expect {| +iw |}];
print_change_nl (Parse.user_modes "iw"); [%expect {| +iw |}];
print_change_nl (Parse.user_modes "-wo"); [%expect {| -ow |}];
print_change_nl (Parse.user_modes "+i-w"); [%expect {| +i-w |}];
print_change_nl (Parse.user_modes "-i+w"); [%expect {| +w-i |}];
print_change_nl (Parse.user_modes "+i-i"); [%expect {| -i |}];
print_change_nl (Parse.user_modes "-o+o"); [%expect {| +o |}];
print_parse_error (fun () -> Parse.user_modes "+I"); [%expect {| unknown mode I |}];
let m, c = Set.normalize (Set.of_string "iw") (Parse.user_modes "-w+io") in
Format.printf "%a -> [%a]\n@." Set.pp_change c Set.pp m;
[%expect {| +o-w -> [io] |}];
let print_chan_modes (m : Parse.chan_modes) =
Format.printf "[%a" Set.pp_change m.chan_modes;
begin match m.chan_limit with
| Some (`set n) -> Format.printf " +l:%d" n
| Some `unset -> Format.printf " -l"
| None -> ()
end;
begin match m.chan_key with
| Some (`set k) -> Format.printf " +k:%S" k
| Some `unset -> Format.printf " -k"
| None -> ()
end;
List.iter
(fun (add_rem, mode, nick) ->
Format.printf " %c%c:%s"
(match add_rem with `add -> '+' | `rem -> '-')
(to_char mode)
nick)
m.chan_privs;
Format.printf "]\n@."
in
print_chan_modes (Parse.chan_modes "+im-nm+s" []);
[%expect {| [+is-mn] |}];
print_chan_modes (Parse.chan_modes "+ls" ["100"]);
[%expect {| [+s +l:100] |}];
print_chan_modes (Parse.chan_modes "+ls" ["-1"]);
[%expect {| [+s] |}];
print_chan_modes (Parse.chan_modes "+l-ik+lt" ["100"; "*"; "200"]);
[%expect {| [+t-i +l:200 -k] |}];
print_chan_modes (Parse.chan_modes "+k-k+k" ["a"; "b"; "c"]);
[%expect {| [+ +k:"c"] |}];
print_parse_error (fun () -> Parse.chan_modes "+k" []);
[%expect {| missing args |}];
print_parse_error (fun () -> Parse.chan_modes "+l" []);
[%expect {| missing args |}];
print_chan_modes (Parse.chan_modes "+o+v" ["aaa"; "bbb"]);
[%expect {| [+ +o:aaa +v:bbb] |}];
print_chan_modes (Parse.chan_modes "+o-v" ["aaa"; "bbb"]);
[%expect {| [+ +o:aaa -v:bbb] |}];