rewrite the connections functions and restructure the code LOL
This commit is contained in:
parent
c69e245edf
commit
33974047be
4
Makefile
4
Makefile
|
@ -1,9 +1,9 @@
|
||||||
SOURCES = irccolors.ml store.ml vantabot.ml
|
SOURCES = irccolors.ml store.ml connection.ml vantabot.ml
|
||||||
RESULT = vantabot
|
RESULT = vantabot
|
||||||
PACKS = lwt,irc-client,irc-client-lwt,irc-client-tls,dokeysto
|
PACKS = lwt,irc-client,irc-client-lwt,irc-client-tls,dokeysto
|
||||||
THREADS = yes
|
THREADS = yes
|
||||||
UNIX = yes
|
UNIX = yes
|
||||||
|
|
||||||
all: byte-code native-code
|
all: native-code
|
||||||
|
|
||||||
-include OCamlMakefile
|
-include OCamlMakefile
|
||||||
|
|
|
@ -0,0 +1,96 @@
|
||||||
|
open Irc_client
|
||||||
|
open Lwt
|
||||||
|
|
||||||
|
let formatf = Printf.sprintf
|
||||||
|
|
||||||
|
(** We distinguish between "big channels" (allowed to spam) and "smol channels" (shouldn't spam).
|
||||||
|
Thanks to nilaky for the terminology. *)
|
||||||
|
module Conn (C: CLIENT with type 'a Io.t = 'a Lwt.t) = struct
|
||||||
|
type t = C.connection_t
|
||||||
|
|
||||||
|
let smolchannels = ref []
|
||||||
|
let bigchannels = ref []
|
||||||
|
|
||||||
|
let send_msg (connection : t) ~is_big ?channel (m : string) =
|
||||||
|
let open Lwt_list in
|
||||||
|
let f c =
|
||||||
|
C.send_privmsg ~connection ~target:c ~message:m
|
||||||
|
in
|
||||||
|
let channels = match channel with
|
||||||
|
| None -> if is_big then !bigchannels else !bigchannels @ !smolchannels
|
||||||
|
| Some c -> if is_big && not (List.mem c !bigchannels) then [] else [c]
|
||||||
|
in
|
||||||
|
iter_s f channels
|
||||||
|
|
||||||
|
let insert_channel c is_big =
|
||||||
|
let r = (if is_big then bigchannels else smolchannels) in
|
||||||
|
if List.mem c !r then ()
|
||||||
|
else r := c::!r
|
||||||
|
|
||||||
|
let join_chan (connection : t) ~is_big ~channel =
|
||||||
|
C.send_join ~connection ~channel >>= fun () ->
|
||||||
|
return (insert_channel channel is_big)
|
||||||
|
|
||||||
|
let callbacks = ref []
|
||||||
|
|
||||||
|
let nick_of_irc_message imsg =
|
||||||
|
let open Irc_message in
|
||||||
|
match imsg.prefix with
|
||||||
|
| None -> ""
|
||||||
|
| Some wh ->
|
||||||
|
match String.split_on_char '!' wh with
|
||||||
|
| a::_ -> a
|
||||||
|
| [] -> ""
|
||||||
|
let register_callback ~prefix ~callback =
|
||||||
|
callbacks := (prefix,callback)::!callbacks
|
||||||
|
|
||||||
|
let get_command botnick msg pref =
|
||||||
|
let nl = String.length botnick in
|
||||||
|
let n = String.length pref in
|
||||||
|
let k = nl + 2 + n in
|
||||||
|
if String.get msg 0 = '!' then
|
||||||
|
(* If it's a command starting with "!" *)
|
||||||
|
let msg = String.sub msg 1 (String.length msg - 1) in
|
||||||
|
if String.length msg >= n then
|
||||||
|
Some (String.sub msg n (String.length msg - n))
|
||||||
|
else None
|
||||||
|
else if String.length msg >= k &&
|
||||||
|
String.sub msg 0 k = (botnick ^ ": " ^ pref) then
|
||||||
|
(* If someone is asking the bot directly, e.g.
|
||||||
|
vantabot: rollcall *)
|
||||||
|
Some (String.sub msg k (String.length msg - k))
|
||||||
|
else None
|
||||||
|
|
||||||
|
let callback_loop logf botnick connection result =
|
||||||
|
let open Irc_message in
|
||||||
|
match result with
|
||||||
|
| Result.Error e -> logf (formatf "Error parsing a message: %s" e)
|
||||||
|
| Result.Ok imsg ->
|
||||||
|
match imsg.command with
|
||||||
|
| PRIVMSG (target, msg) ->
|
||||||
|
if (List.mem target !bigchannels || List.mem target !smolchannels)
|
||||||
|
then
|
||||||
|
Lwt_list.iter_s
|
||||||
|
(fun (p,cb) ->
|
||||||
|
match get_command botnick msg p with
|
||||||
|
| None -> return ()
|
||||||
|
| Some rest ->
|
||||||
|
cb connection (nick_of_irc_message imsg) target rest)
|
||||||
|
!callbacks
|
||||||
|
else return ()
|
||||||
|
| _ -> return ()
|
||||||
|
|
||||||
|
|
||||||
|
let pls_connect ~realname ~username ~server ~port ~nick ~logf ~onconnect =
|
||||||
|
C.set_log logf;
|
||||||
|
C.reconnect_loop
|
||||||
|
~after:30
|
||||||
|
~connect:(fun () ->
|
||||||
|
logf "Connecting..." >>= fun () ->
|
||||||
|
C.connect_by_name ~realname ~username ~server ~port ~nick ())
|
||||||
|
~f:(fun connection ->
|
||||||
|
logf "Connected." >>= fun () -> onconnect connection)
|
||||||
|
~callback:(callback_loop logf nick)
|
||||||
|
()
|
||||||
|
|
||||||
|
end
|
|
@ -0,0 +1,38 @@
|
||||||
|
open Irc_client
|
||||||
|
open Lwt
|
||||||
|
|
||||||
|
(** We distinguish between "big channels" (allowed to spam) and "smol channels" (shouldn't spam).
|
||||||
|
Thanks to nilaky for the terminology. *)
|
||||||
|
module Conn (C: CLIENT with type 'a Io.t = 'a Lwt.t) : sig
|
||||||
|
type t = C.connection_t
|
||||||
|
|
||||||
|
val smolchannels : string list ref
|
||||||
|
val bigchannels : string list ref
|
||||||
|
|
||||||
|
val send_msg : t -> is_big:bool -> ?channel:string -> string -> unit Lwt.t
|
||||||
|
(** Send a message to all the channels associated with the connection.
|
||||||
|
set `is_big` (default: false) if the message is for `big channels` only.
|
||||||
|
If `channel` is specified then send to that channel only. *)
|
||||||
|
|
||||||
|
val join_chan : t -> is_big:bool -> channel:string -> unit Lwt.t
|
||||||
|
(** Join a channel with and add it to the list. `is_big` default to false. *)
|
||||||
|
|
||||||
|
val register_callback :
|
||||||
|
prefix:string ->
|
||||||
|
callback:(t -> string -> string -> string -> unit Lwt.t) ->
|
||||||
|
unit
|
||||||
|
(** Register a callback for the prefix "!<prefix>". The arguments for
|
||||||
|
the callback are: connection nick (possible empty), channel, the rest of the
|
||||||
|
message. *)
|
||||||
|
|
||||||
|
val pls_connect :
|
||||||
|
realname:string ->
|
||||||
|
username:string ->
|
||||||
|
server:string ->
|
||||||
|
port:int ->
|
||||||
|
nick:string ->
|
||||||
|
logf:(string -> unit Lwt.t) ->
|
||||||
|
onconnect:(t -> unit Lwt.t) ->
|
||||||
|
unit Lwt.t
|
||||||
|
|
||||||
|
end
|
110
vantabot.ml
110
vantabot.ml
|
@ -1,7 +1,8 @@
|
||||||
(* for tls support replace [Irc_client_lwt] with [Irc_client_tls] *)
|
(* for tls support replace [Irc_client_lwt] with [Irc_client_tls] *)
|
||||||
open Lwt
|
open Lwt
|
||||||
open Irccolors
|
open Irccolors
|
||||||
module C = Irc_client_lwt
|
open Connection
|
||||||
|
module C = Conn(Irc_client_lwt)
|
||||||
|
|
||||||
let logf : string -> unit Lwt.t = Lwt_io.printl
|
let logf : string -> unit Lwt.t = Lwt_io.printl
|
||||||
let formatf = Printf.sprintf
|
let formatf = Printf.sprintf
|
||||||
|
@ -13,24 +14,25 @@ let host = ref "localhost"
|
||||||
let port = ref 6667
|
let port = ref 6667
|
||||||
let realname = ":3"
|
let realname = ":3"
|
||||||
let botnick = ref "vantabot"
|
let botnick = ref "vantabot"
|
||||||
let channel = ref "#bots"
|
(* let channel = ref "#bots" *)
|
||||||
let username = botnick
|
let username = botnick
|
||||||
let sleeptime = ref 30.
|
let sleeptime = ref 30.
|
||||||
let countdown = ref 5
|
let countdown = ref 5
|
||||||
let db_file = ref "toke.db"
|
let db_file = ref "toke.db"
|
||||||
|
|
||||||
|
let smolchannels = ["#tildetown"]
|
||||||
|
let bigchannels = ["#bots";"#aaa"]
|
||||||
|
|
||||||
let options = Arg.align
|
let options = Arg.align
|
||||||
[ "-host", Arg.Set_string host, " server host name (default: " ^ !host ^ ")"
|
[ "-host", Arg.Set_string host, " server host name (default: " ^ !host ^ ")"
|
||||||
; "-port", Arg.Set_int port, " server port (default: " ^ string_of_int !port ^ ")"
|
; "-port", Arg.Set_int port, " server port (default: " ^ string_of_int !port ^ ")"
|
||||||
; "-chan", Arg.Set_string channel, " target channel (default: " ^ !channel ^ ")"
|
(* ; "-chan", Arg.Set_string channel, " target channel (default: " ^ !channel ^ ")" *)
|
||||||
; "-nick", Arg.Set_string botnick, " nick prefix (default: " ^ !botnick ^ ")"
|
; "-nick", Arg.Set_string botnick, " nick prefix (default: " ^ !botnick ^ ")"
|
||||||
; "-sleeptime", Arg.Set_float sleeptime, " time period for joining the toke call, in seconds (default: " ^ string_of_float !sleeptime ^ ")"
|
; "-sleeptime", Arg.Set_float sleeptime, " time period for joining the toke call, in seconds (default: " ^ string_of_float !sleeptime ^ ")"
|
||||||
; "-countdown", Arg.Set_int countdown, " countdown, in seconds (default: " ^ string_of_int !countdown ^ ")"
|
; "-countdown", Arg.Set_int countdown, " countdown, in seconds (default: " ^ string_of_int !countdown ^ ")"
|
||||||
; "-db", Arg.Set_string db_file, " database file, will be created if does not exist (default: " ^ !db_file ^ ")"
|
; "-db", Arg.Set_string db_file, " database file, will be created if does not exist (default: " ^ !db_file ^ ")"
|
||||||
]
|
]
|
||||||
|
|
||||||
let sendmsg connection m = C.send_privmsg ~connection ~target:!channel ~message:(color_text ~fg:Green ~bg:Black m)
|
|
||||||
|
|
||||||
(** * BUSINESS LOGIC HEH *)
|
(** * BUSINESS LOGIC HEH *)
|
||||||
|
|
||||||
let toke_in_progress = ref false
|
let toke_in_progress = ref false
|
||||||
|
@ -44,7 +46,7 @@ let push_toker t =
|
||||||
|
|
||||||
let tokeplz () =
|
let tokeplz () =
|
||||||
let r = String.concat " " !tokers in
|
let r = String.concat " " !tokers in
|
||||||
"SMOKE NOW " ^ r
|
bold_text (color_text ~fg:Green ~bg:Black "SMOKE NOW ") ^ r
|
||||||
|
|
||||||
let inc_tokers_count () =
|
let inc_tokers_count () =
|
||||||
List.iter (fun n -> Store.register_nick n (Store.DB !db_file)) !tokers
|
List.iter (fun n -> Store.register_nick n (Store.DB !db_file)) !tokers
|
||||||
|
@ -60,29 +62,29 @@ let leaf = [
|
||||||
" WWW WWWWW WWW ";
|
" WWW WWWWW WWW ";
|
||||||
" WWW WWW WWW ";
|
" WWW WWW WWW ";
|
||||||
" WWW WWW WWW ";
|
" WWW WWW WWW ";
|
||||||
" WWWWWWW ";
|
" WWWWWWW ";
|
||||||
" WWWW | WWWW ";
|
" WWWW | WWWW ";
|
||||||
" | ";
|
" | ";
|
||||||
" | "]
|
" | "]
|
||||||
|
|
||||||
let show_leaf connection =
|
let show_leaf connection =
|
||||||
leaf |> Lwt_list.iter_s (fun l -> sendmsg connection l)
|
leaf |> Lwt_list.iter_s (fun l ->
|
||||||
|
C.send_msg connection ~is_big:true (bold_text (color_text ~fg:Green ~bg:Black l)))
|
||||||
|
|
||||||
let start_toke connection =
|
let start_toke connection =
|
||||||
toke_in_progress := true;
|
toke_in_progress := true;
|
||||||
let rec toker_thread n conn =
|
let rec toker_thread n conn =
|
||||||
if n = 0
|
if n = 0
|
||||||
then begin
|
then begin
|
||||||
let msg = tokeplz () in
|
let msg = tokeplz () in
|
||||||
inc_tokers_count ();
|
inc_tokers_count ();
|
||||||
tokers := [];
|
tokers := [];
|
||||||
sendmsg connection msg
|
C.send_msg connection ~is_big:false msg >>= fun () ->
|
||||||
>>= fun () ->
|
toke_in_progress := false;
|
||||||
toke_in_progress := false;
|
|
||||||
show_leaf connection
|
show_leaf connection
|
||||||
end
|
end
|
||||||
else begin
|
else begin
|
||||||
sendmsg connection (color_text ~bg:Black ~fg:White (formatf "ready in %i..." n))
|
C.send_msg connection ~is_big:true (color_text ~bg:Green ~fg:LightGreen (formatf "get ready in %i..." n))
|
||||||
>>= fun () -> Lwt_unix.sleep 1.
|
>>= fun () -> Lwt_unix.sleep 1.
|
||||||
>>= fun () -> toker_thread (n-1) conn
|
>>= fun () -> toker_thread (n-1) conn
|
||||||
end
|
end
|
||||||
|
@ -91,84 +93,46 @@ let start_toke connection =
|
||||||
let slt = !sleeptime in
|
let slt = !sleeptime in
|
||||||
(if slt > 10.
|
(if slt > 10.
|
||||||
then Lwt_unix.sleep (slt-.10.) >>= fun () ->
|
then Lwt_unix.sleep (slt-.10.) >>= fun () ->
|
||||||
sendmsg connection (color_text ~bg:Black ~fg:LightGreen "toke in ~10s") >>= fun () ->
|
C.send_msg connection ~is_big:true
|
||||||
|
(color_text ~bg:Black ~fg:LightGreen "get ready to toke in ~10s") >>= fun () ->
|
||||||
Lwt_unix.sleep 10.
|
Lwt_unix.sleep 10.
|
||||||
else Lwt_unix.sleep slt) >>= fun () ->
|
else Lwt_unix.sleep slt) >>= fun () ->
|
||||||
toker_thread !countdown connection);
|
toker_thread !countdown connection);
|
||||||
sendmsg connection (formatf "Toke in progress, type in `!toke' to join. Time to go: ~%.1f secs" !sleeptime)
|
C.send_msg connection ~is_big:false (formatf "Toke in progress, type in `!toke' to join. Time to go: ~%.1f secs" !sleeptime)
|
||||||
|
|
||||||
let handle_toke who conn =
|
let handle_toke who conn =
|
||||||
let is_new = push_toker who in
|
let is_new = push_toker who in
|
||||||
if (!toke_in_progress)
|
if (!toke_in_progress)
|
||||||
then if is_new
|
then if is_new
|
||||||
then sendmsg conn (formatf "%s joins the toke call" who)
|
then C.send_msg conn ~is_big:false (formatf "%s joins the toke call" who)
|
||||||
else return ()
|
else return ()
|
||||||
else start_toke conn
|
else start_toke conn
|
||||||
|
|
||||||
let rollcall ?who conn =
|
let rollcall who chan conn =
|
||||||
let pref = match who with
|
let pref = match who with
|
||||||
None -> ""
|
None -> ""
|
||||||
| Some n -> n ^ ": " in
|
| Some n -> n ^ ": " in
|
||||||
sendmsg conn (pref ^ "vantabot is a bot for synchronized toking. See <https://tildegit.org/epicmorphism/vantabot>. TL;DR: the only command is !toke")
|
C.send_msg conn ~channel:chan ~is_big:false (pref ^ "vantabot is a bot for synchronized toking. See <https://tildegit.org/epicmorphism/vantabot>. TL;DR: the only command is !toke")
|
||||||
|
|
||||||
|
(* Register all the commands *)
|
||||||
|
let init conn =
|
||||||
|
C.register_callback "rollcall" (fun conn who chan _ ->
|
||||||
|
rollcall (if who = "" then None else Some who) chan conn);
|
||||||
|
C.register_callback "toke" (fun conn who _ _ ->
|
||||||
|
handle_toke (if who = "" then "<lain>" else who) conn)
|
||||||
|
|
||||||
(***********************************)
|
(***********************************)
|
||||||
(** * IRC connection handling code *)
|
|
||||||
|
|
||||||
|
|
||||||
let new_channel ~connection ~channel =
|
|
||||||
C.send_join ~connection ~channel
|
|
||||||
>>= fun () -> C.send_privmsg ~connection ~target:channel
|
|
||||||
~message:(bold_text (color_text ~fg:Green ~bg:Black ".420."))
|
|
||||||
|
|
||||||
let nick_of_irc_message imsg =
|
|
||||||
let open Irc_message in
|
|
||||||
match imsg.prefix with
|
|
||||||
| None -> None
|
|
||||||
| Some wh ->
|
|
||||||
match String.split_on_char '!' wh with
|
|
||||||
| a::_ -> Some a
|
|
||||||
| [] -> None
|
|
||||||
|
|
||||||
|
|
||||||
let callback connection result =
|
|
||||||
let open Irc_message in
|
|
||||||
match result with
|
|
||||||
| Result.Error e -> logf (formatf "[callback] Error parsing a message: %s" e)
|
|
||||||
| Result.Ok imsg ->
|
|
||||||
logf (to_string imsg) >>= fun () ->
|
|
||||||
(match imsg.command with
|
|
||||||
| PRIVMSG (target, msg) ->
|
|
||||||
if target = !channel && String.length msg > 4 then
|
|
||||||
(* INITIATE OR JOIN THE TOKE *)
|
|
||||||
if String.sub msg 0 5 = "!toke" then
|
|
||||||
match nick_of_irc_message imsg with
|
|
||||||
| None -> return ()
|
|
||||||
| Some wh -> handle_toke wh connection
|
|
||||||
(* RESPOND TO ROLLCALL *)
|
|
||||||
else if msg = (!botnick) ^ ": rollcall" then
|
|
||||||
match nick_of_irc_message imsg with
|
|
||||||
| None -> return ()
|
|
||||||
| Some wh -> rollcall ~who:wh connection
|
|
||||||
else if msg = "!rollcall" then
|
|
||||||
rollcall connection
|
|
||||||
else return ()
|
|
||||||
else return ()
|
|
||||||
| _ -> return ())
|
|
||||||
|
|
||||||
|
|
||||||
let lwt_main () =
|
let lwt_main () =
|
||||||
C.set_log logf;
|
C.pls_connect ~realname:realname ~username:!username ~server:!host
|
||||||
C.reconnect_loop
|
~port:!port ~nick:!botnick ~logf
|
||||||
~after:30
|
~onconnect:(fun connection ->
|
||||||
~connect:(fun () ->
|
init connection;
|
||||||
logf "Connecting..."
|
Lwt_list.iter_p
|
||||||
>>= fun () -> C.connect_by_name ~realname:realname ~username:!username ~server:!host ~port:!port ~nick:!botnick ()
|
(fun c -> C.join_chan connection ~is_big:false ~channel:c) smolchannels
|
||||||
)
|
>>= fun () ->
|
||||||
~f:(fun connection ->
|
Lwt_list.iter_p
|
||||||
logf "Connected"
|
(fun c -> C.join_chan connection ~is_big:true ~channel:c) bigchannels)
|
||||||
>>= fun () -> new_channel connection !channel)
|
|
||||||
~callback
|
|
||||||
()
|
|
||||||
|
|
||||||
let _ =
|
let _ =
|
||||||
Arg.parse options (fun _ -> ()) "<vantabot> [options]\n";
|
Arg.parse options (fun _ -> ()) "<vantabot> [options]\n";
|
||||||
|
|
Loading…
Reference in New Issue