2019-02-16 20:04:52 +00:00
(* for tls support replace [Irc_client_lwt] with [Irc_client_tls] *)
2019-02-16 19:21:48 +00:00
open Lwt
open Irccolors
2019-05-19 09:38:55 +00:00
open Connection
module C = Conn ( Irc_client_lwt )
2019-02-16 19:21:48 +00:00
let logf : string -> unit Lwt . t = Lwt_io . printl
let formatf = Printf . sprintf
(* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *)
(* * * Options *)
2019-02-16 20:04:52 +00:00
let host = ref " localhost "
2019-05-16 20:43:36 +00:00
let port = ref 6667
2019-02-16 19:21:48 +00:00
let realname = " :3 "
2019-05-16 20:20:23 +00:00
let botnick = ref " vantabot "
2019-05-19 09:38:55 +00:00
(* let channel = ref "#bots" *)
2019-05-16 20:20:23 +00:00
let username = botnick
2019-02-16 19:21:48 +00:00
let sleeptime = ref 30 .
let countdown = ref 5
2019-05-16 20:43:36 +00:00
let db_file = ref " toke.db "
2019-02-16 19:21:48 +00:00
2019-05-19 09:38:55 +00:00
let smolchannels = [ " #tildetown " ]
2019-05-19 10:24:14 +00:00
let bigchannels = [ " #bots " ]
2019-05-19 09:38:55 +00:00
2019-02-16 19:21:48 +00:00
let options = Arg . align
[ " -host " , Arg . Set_string host , " server host name (default: " ^ ! host ^ " ) "
; " -port " , Arg . Set_int port , " server port (default: " ^ string_of_int ! port ^ " ) "
2019-05-19 09:38:55 +00:00
(* ; "-chan", Arg.Set_string channel, " target channel ( default: " ^ !channel ^ " ) " *)
2019-05-16 20:20:23 +00:00
; " -nick " , Arg . Set_string botnick , " nick prefix (default: " ^ ! botnick ^ " ) "
2019-02-16 20:04:52 +00:00
; " -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 ^ " ) "
2019-05-16 20:43:36 +00:00
; " -db " , Arg . Set_string db_file , " database file, will be created if does not exist (default: " ^ ! db_file ^ " ) "
2019-02-16 19:21:48 +00:00
]
(* * * BUSINESS LOGIC HEH *)
let toke_in_progress = ref false
let tokers = ref []
let push_toker t =
let contents = ! tokers in
let cnd = not ( List . mem t contents ) in
if cnd then tokers := t :: contents ;
cnd
let tokeplz () =
let r = String . concat " " ! tokers in
2019-05-19 09:38:55 +00:00
bold_text ( color_text ~ fg : Green ~ bg : Black " SMOKE NOW " ) ^ r
2019-02-16 19:21:48 +00:00
2019-02-16 20:04:52 +00:00
let inc_tokers_count () =
2019-05-16 20:43:36 +00:00
List . iter ( fun n -> Store . register_nick n ( Store . DB ! db_file ) ) ! tokers
2019-02-16 20:04:52 +00:00
2019-02-16 19:21:48 +00:00
let leaf = [
2019-05-19 22:03:24 +00:00
" W " ;
" WWW " ;
" | " ]
(* let leaf = [
* " W " ;
* " WWW " ;
* " WWW " ;
* " WWWWW " ;
* " W WWWWW W " ;
* " WWW WWWWW WWW " ;
* " WWW WWWWW WWW " ;
* " WWW WWW WWW " ;
* " WWW WWW WWW " ;
* " WWWWWWW " ;
* " WWWW | WWWW " ;
* " | " ;
* " | " ] * )
2019-02-16 19:21:48 +00:00
let show_leaf connection =
2019-05-19 09:38:55 +00:00
leaf | > Lwt_list . iter_s ( fun l ->
2019-05-19 22:03:24 +00:00
C . send_msg connection ~ is_big : false ( bold_text ( color_text ~ fg : Green ~ bg : Black l ) ) )
2019-02-16 19:21:48 +00:00
let start_toke connection =
toke_in_progress := true ;
let rec toker_thread n conn =
if n = 0
then begin
2019-05-19 09:38:55 +00:00
let msg = tokeplz () in
2019-02-16 20:04:52 +00:00
inc_tokers_count () ;
tokers := [] ;
2019-05-19 09:38:55 +00:00
C . send_msg connection ~ is_big : false msg > > = fun () ->
toke_in_progress := false ;
2019-02-16 20:04:52 +00:00
show_leaf connection
2019-02-16 19:21:48 +00:00
end
else begin
2019-05-19 09:38:55 +00:00
C . send_msg connection ~ is_big : true ( color_text ~ bg : Green ~ fg : LightGreen ( formatf " get ready in %i... " n ) )
2019-02-16 19:21:48 +00:00
> > = fun () -> Lwt_unix . sleep 1 .
> > = fun () -> toker_thread ( n - 1 ) conn
end
in
Lwt . async ( fun () ->
let slt = ! sleeptime in
( if slt > 10 .
then Lwt_unix . sleep ( slt -. 10 . ) > > = fun () ->
2019-05-19 09:38:55 +00:00
C . send_msg connection ~ is_big : true
( color_text ~ bg : Black ~ fg : LightGreen " get ready to toke in ~10s " ) > > = fun () ->
2019-02-16 19:21:48 +00:00
Lwt_unix . sleep 10 .
else Lwt_unix . sleep slt ) > > = fun () ->
toker_thread ! countdown connection ) ;
2019-05-19 09:38:55 +00:00
C . send_msg connection ~ is_big : false ( formatf " Toke in progress, type in `!toke' to join. Time to go: ~%.1f secs " ! sleeptime )
2019-02-16 19:21:48 +00:00
let handle_toke who conn =
let is_new = push_toker who in
if ( ! toke_in_progress )
then if is_new
2019-05-19 09:38:55 +00:00
then C . send_msg conn ~ is_big : false ( formatf " %s joins the toke call " who )
2019-02-16 19:21:48 +00:00
else return ()
else start_toke conn
2019-05-19 09:38:55 +00:00
let rollcall who chan conn =
2019-05-16 20:20:23 +00:00
let pref = match who with
None -> " "
| Some n -> n ^ " : " in
2019-05-19 09:38:55 +00:00
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 " )
2019-05-16 20:20:23 +00:00
2019-05-19 09:38:55 +00:00
(* 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 )
2019-02-16 19:21:48 +00:00
2019-05-19 09:38:55 +00:00
(* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *)
2019-02-16 19:21:48 +00:00
let lwt_main () =
2019-05-19 09:38:55 +00:00
C . pls_connect ~ realname : realname ~ username : ! username ~ server : ! host
~ port : ! port ~ nick : ! botnick ~ logf
~ onconnect : ( fun connection ->
init connection ;
Lwt_list . iter_p
( fun c -> C . join_chan connection ~ is_big : false ~ channel : c ) smolchannels
> > = fun () ->
Lwt_list . iter_p
( fun c -> C . join_chan connection ~ is_big : true ~ channel : c ) bigchannels )
2019-02-16 19:21:48 +00:00
let _ =
2019-02-16 20:04:52 +00:00
Arg . parse options ( fun _ -> () ) " <vantabot> [options] \n " ;
2019-02-16 19:21:48 +00:00
Lwt_main . run ( lwt_main () )