fonts and lwd and nottui and more progress towards the irc client
This commit is contained in:
cqc
292
irc.ml
292
irc.ml
@ -14,102 +14,244 @@ open Lwt_react
|
||||
module F = Fmt
|
||||
|
||||
module Communicator = struct
|
||||
type msg = {content: string; time: string; mutable seen: bool}
|
||||
module Message = struct
|
||||
type t = {content: string; time: string; mutable seen: bool}
|
||||
|
||||
let create_msg ?(time = "<ts>") content =
|
||||
{content; time; seen= false}
|
||||
let make ?(time = "<ts>") content = {content; time; seen= false}
|
||||
end
|
||||
|
||||
type channel =
|
||||
{ mutable name: string
|
||||
; mutable content: msg list
|
||||
; mutable recv: msg -> unit }
|
||||
module Channel = struct
|
||||
type t = {name: string; content: Message.t list Lwd.var}
|
||||
|
||||
let add_msg (c : channel) msg = c.content <- msg :: c.content
|
||||
let add_msg (c : t) (msg : Message.t) =
|
||||
F.epr "Channel.add_msg msg.content=\"%s\"@." msg.content ;
|
||||
let cn = Lwd.peek c.content in
|
||||
Lwd.set c.content (msg :: cn)
|
||||
|
||||
type t = {mutable channel: channel; mutable subs: t list}
|
||||
type protocol = Irc | Email | Rss | Mublog
|
||||
let make name = {name; content= Lwd.var []}
|
||||
end
|
||||
|
||||
let make_channel ?(recv = add_msg) name =
|
||||
let c = {name; content= []; recv= (fun _ -> ())} in
|
||||
{c with recv= recv c}
|
||||
module Tree = struct
|
||||
open Channel
|
||||
open Message
|
||||
|
||||
let make () : t =
|
||||
let channel = make_channel "top" in
|
||||
channel.recv (create_msg "Wecome to the Communicator") ;
|
||||
channel.recv (create_msg "Currently only IRC is implemented") ;
|
||||
{channel; subs= []}
|
||||
type t =
|
||||
{ channel: Channel.t
|
||||
; subs: t Lwd_table.t
|
||||
; focus: Nottui.Focus.handle }
|
||||
|
||||
type connection = unit Lwt.t
|
||||
type protocol = Irc | Email | Rss | Mublog | ActivityPub
|
||||
|
||||
let add (comm : t) ch : unit =
|
||||
let c' =
|
||||
{ channel= ch
|
||||
; subs= Lwd_table.make ()
|
||||
; focus= Nottui.Focus.make () } in
|
||||
Lwd_table.append' comm.subs c'
|
||||
|
||||
let make_top () =
|
||||
let channel = Channel.make "communicator-top" in
|
||||
add_msg channel (Message.make "Welcome to the Communicator") ;
|
||||
add_msg channel
|
||||
(Message.make "Currently only IRC is implemented") ;
|
||||
{channel; subs= Lwd_table.make (); focus= Nottui.Focus.make ()}
|
||||
end
|
||||
|
||||
module Irc = struct
|
||||
module C = Irc_client_tls
|
||||
module M = Irc_message
|
||||
|
||||
let connection (c : t) server port nick channels : unit Lwt.t =
|
||||
let add_msg cn str = add_msg cn.channel (create_msg str) in
|
||||
C.reconnect_loop ~after:30
|
||||
~connect:(fun () ->
|
||||
Lwt_io.printl "Connecting..."
|
||||
>>= fun () ->
|
||||
C.connect_by_name ~server ~port ~nick ()
|
||||
>>= fun c ->
|
||||
Lwt_io.printl "connect_by_name returned"
|
||||
>>= fun () -> Lwt.return c )
|
||||
~f:(fun connection ->
|
||||
Lwt_io.printl "Connected"
|
||||
>>= fun () ->
|
||||
Lwt_list.iter_p
|
||||
(fun channel ->
|
||||
let joiner = C.send_join ~connection ~channel in
|
||||
(* make_channel c ~sender:(fun s ->
|
||||
C.send_privmsg ~target:channel ~message:s) channel ; *)
|
||||
joiner )
|
||||
channels )
|
||||
~callback:(fun _connection result ->
|
||||
match result with
|
||||
| Result.Ok ({M.command= M.Other _; _} as msg) ->
|
||||
add_msg c
|
||||
(F.str "Got unknown message: %s\n" (M.to_string msg)) ;
|
||||
Lwt.return_unit
|
||||
| Result.Ok ({M.command= M.PRIVMSG (target, data); _} as msg)
|
||||
->
|
||||
add_msg c
|
||||
(F.str "Got PRIVMSG: target=%s, data=%s; %s\n" target
|
||||
data (M.to_string msg) ) ;
|
||||
Lwt.return_unit
|
||||
| Result.Ok msg ->
|
||||
add_msg c (M.to_string msg) ;
|
||||
Lwt.return_unit
|
||||
| Result.Error e -> Lwt_io.printl e )
|
||||
()
|
||||
let connection (c : Tree.t) server port nick
|
||||
(channels : string list) : Channel.t =
|
||||
let channel =
|
||||
Channel.make ("IRC: " ^ server ^ ":" ^ string_of_int port)
|
||||
in
|
||||
let _c' = Tree.add c channel in
|
||||
let add_msg str = Channel.add_msg channel (Message.make str) in
|
||||
let channel_assoc = ref [] in
|
||||
let make_ch name =
|
||||
let ch = Channel.make name in
|
||||
Tree.add c ch ;
|
||||
channel_assoc := (name, ch) :: !channel_assoc ;
|
||||
ch in
|
||||
Lwt.async
|
||||
(C.reconnect_loop ~after:30
|
||||
~connect:(fun () ->
|
||||
add_msg "Connecting..." ;
|
||||
C.connect_by_name ~server ~port ~nick ()
|
||||
>>= fun c ->
|
||||
Lwt_io.printl "connect_by_name returned"
|
||||
>>= fun () -> Lwt.return c )
|
||||
~f:(fun connection ->
|
||||
add_msg "Connected" ;
|
||||
Lwt_list.iter_p
|
||||
(fun chname ->
|
||||
C.send_join ~connection ~channel:chname
|
||||
>>= fun () ->
|
||||
ignore (make_ch chname) ;
|
||||
Lwt.return_unit )
|
||||
channels )
|
||||
~callback:(fun _connection result ->
|
||||
match result with
|
||||
| Result.Ok ({M.command= M.Other _; _} as msg) ->
|
||||
add_msg (M.to_string msg) ;
|
||||
Lwt.return_unit
|
||||
| Result.Ok
|
||||
{M.command= M.PRIVMSG (target, data); prefix= user}
|
||||
->
|
||||
let user =
|
||||
match user with
|
||||
| Some u -> List.hd (String.split_on_char '!' u)
|
||||
| None -> "unknown" in
|
||||
( match List.assoc_opt target !channel_assoc with
|
||||
| Some ch -> Channel.add_msg ch
|
||||
| None -> Channel.add_msg (make_ch target) )
|
||||
(Message.make (F.str "<%s> %s" user data)) ;
|
||||
Lwt.return_unit
|
||||
| Result.Ok msg ->
|
||||
add_msg (M.to_string msg) ;
|
||||
Lwt.return_unit
|
||||
| Result.Error e -> Lwt_io.printl e ) ) ;
|
||||
channel
|
||||
end
|
||||
|
||||
module Panel = struct
|
||||
let panel (c : t) =
|
||||
let open Panel in
|
||||
let te = Textedit.make "" () in
|
||||
Textedit.panel ~height:20. te
|
||||
>>= fun p ->
|
||||
Lwt.return
|
||||
{ p with
|
||||
act=
|
||||
(fun panel events ->
|
||||
Textedit.clear te ;
|
||||
List.iter
|
||||
(fun m ->
|
||||
Textedit.insert te
|
||||
(F.str "[%s] %s\n" m.time m.content) )
|
||||
c.channel.content ;
|
||||
p.act panel events ) }
|
||||
open Nottui
|
||||
module P = Nottui_pretty
|
||||
|
||||
let string ?attr text = P.ui (Nottui_widgets.string ?attr text)
|
||||
let ( ^^ ) = P.( ^^ )
|
||||
let ( ^/^ ) a b = P.(a ^^ break 1 ^^ b)
|
||||
|
||||
let messagelist (ch : Channel.t) : P.t Lwd.t =
|
||||
Lwd.map (Lwd.get ch.content) ~f:(fun (msgs : Message.t list) ->
|
||||
List.fold_left
|
||||
(fun doc (msg : Message.t) ->
|
||||
F.epr "Communicator.Panel.messagelist ch.content=%s@."
|
||||
msg.content ;
|
||||
doc
|
||||
^^ P.group
|
||||
( string msg.time ^/^ string " | "
|
||||
^/^ string msg.content )
|
||||
^^ P.hardline )
|
||||
P.empty msgs )
|
||||
|
||||
open Nottui_widgets
|
||||
|
||||
(*type focustree =
|
||||
{channel: Channel.t; subs: focustree list; focus: Focus.handle}
|
||||
|
||||
let channeltree (tree : Tree.t) : focustree Lwd.t =
|
||||
let rec fold (tree : Tree.t) : focustree list Lwd.t =
|
||||
Lwd_table.map_reduce
|
||||
(fun _row (tree : Tree.t) ->
|
||||
Lwd.map (fold tree) ~f:(fun (subs : focustree list) ->
|
||||
{ channel= tree.channel
|
||||
; subs
|
||||
; focus= Focus.make () } ))
|
||||
([], fun a b -> List.append a b)
|
||||
tree.subs in
|
||||
let {channel= tree.channel; subs= fold tree; focus= Focus.make ()} *)
|
||||
|
||||
let channelview (tree : Tree.t) : 'a Lwd.t * Channel.t Lwd.var =
|
||||
let channel = Lwd.var tree.channel in
|
||||
let rec fold ?(indent = 0) ?superfocus (tree : Tree.t) :
|
||||
'a Lwd.t =
|
||||
let subfocus = Focus.make () in
|
||||
Lwd.join
|
||||
(Lwd_table.map_reduce
|
||||
(fun row (tree : Tree.t) ->
|
||||
let focus =
|
||||
match superfocus with
|
||||
| Some sf ->
|
||||
Lwd.map2 (Focus.status sf)
|
||||
(Focus.status tree.focus)
|
||||
~f:(fun superfocus' focus' ->
|
||||
if Focus.has_focus superfocus' then
|
||||
F.epr
|
||||
"Focus.has_focus superfocus' = true@." ;
|
||||
Focus.release sf ;
|
||||
Focus.request tree.focus ;
|
||||
focus' )
|
||||
| None -> Focus.status tree.focus in
|
||||
Lwd.map2
|
||||
(Lwd.map focus ~f:(fun focus ->
|
||||
if Focus.has_focus focus then
|
||||
Lwd.set channel tree.channel ;
|
||||
Ui.keyboard_area ~focus
|
||||
(fun key ->
|
||||
match key with
|
||||
| `ASCII 'w', [] -> (
|
||||
match Lwd_table.prev row with
|
||||
| Some r -> (
|
||||
match Lwd_table.get r with
|
||||
| Some r ->
|
||||
Focus.release tree.focus ;
|
||||
Focus.request r.focus ;
|
||||
`Handled
|
||||
| None -> `Unhandled )
|
||||
| None -> `Unhandled )
|
||||
| `ASCII 'a', [] -> (
|
||||
match superfocus with
|
||||
| Some f ->
|
||||
Focus.release tree.focus ;
|
||||
Focus.request f ;
|
||||
`Handled
|
||||
| None -> `Unhandled )
|
||||
| `ASCII 's', [] -> (
|
||||
match Lwd_table.next row with
|
||||
| Some r -> (
|
||||
match Lwd_table.get r with
|
||||
| Some r ->
|
||||
Focus.release tree.focus ;
|
||||
Focus.request r.focus ;
|
||||
`Handled
|
||||
| None -> `Unhandled )
|
||||
| None -> `Unhandled )
|
||||
| `ASCII 'd', [] ->
|
||||
Focus.release tree.focus ;
|
||||
Focus.request subfocus ;
|
||||
`Handled
|
||||
| _ -> `Unhandled )
|
||||
(Ui.join_x
|
||||
(Ui.join_x
|
||||
( if Focus.has_focus focus then
|
||||
string "+"
|
||||
else string "" )
|
||||
(string (String.make indent '-')) )
|
||||
(string Tree.(tree.channel.name)) ) ) )
|
||||
(fold ~indent:(indent + 1) ~superfocus:subfocus tree)
|
||||
~f:(fun parent subs -> Ui.join_y parent subs) )
|
||||
(Lwd_utils.lift_monoid Ui.pack_y)
|
||||
tree.subs ) in
|
||||
(fold tree, channel)
|
||||
|
||||
let messageview (ch : Channel.t Lwd.var) =
|
||||
Panel.Nottui.scroll_area
|
||||
(Lwd.map
|
||||
(Lwd.bind (Lwd.get ch) ~f:messagelist)
|
||||
~f:(P.pretty 200) )
|
||||
|
||||
let commview c =
|
||||
let cv, ch = channelview c in
|
||||
Nottui_widgets.h_pane
|
||||
(Panel.Nottui.scroll_area cv)
|
||||
(messageview ch)
|
||||
|
||||
type view = Channel of (Channel.t * view list) | Cursor of view
|
||||
|
||||
let panel (comm : Tree.t) =
|
||||
let base = Lwd.var Nottui_widgets.empty_lwd in
|
||||
Lwd.set base (commview comm) ;
|
||||
Panel.Nottui.panel (Lwd.join (Lwd.get base)) ()
|
||||
end
|
||||
end
|
||||
|
||||
let _ =
|
||||
let comm = Communicator.make () in
|
||||
let hackint =
|
||||
let comm = Communicator.Tree.make_top () in
|
||||
let _irc =
|
||||
Communicator.Irc.connection comm "irc.hackint.org" 6697 "cqcaml"
|
||||
["#CQC"] in
|
||||
Lwt.async (fun () -> hackint) ;
|
||||
root_actor := std_actor (Communicator.Panel.panel comm)
|
||||
|
||||
(**
|
||||
|
||||
Reference in New Issue
Block a user