263 lines
9.6 KiB
OCaml
263 lines
9.6 KiB
OCaml
(*
|
|
when all you can do is type, making things more complicated than a list is hard?
|
|
we need to design this somehow before implementing it
|
|
really the graphical drawing / window management funcitons i think at this point.
|
|
|
|
features:
|
|
- message drafts? more like, if you send too many messages to someone all at once it will hold them so you can respond later and not flood people.......
|
|
- i mean really what you want is an editable stream, so you can stage messages for later
|
|
- because i mean, if this is a bicycle, and you can make it however you want, you can just fuck with the conversation thread with computer assistance instaed of just relying on your memory.
|
|
*)
|
|
|
|
open Lwt
|
|
open Lwt_react
|
|
module F = Fmt
|
|
|
|
module Communicator = struct
|
|
module Message = struct
|
|
type t = {content: string; time: string; mutable seen: bool}
|
|
|
|
let make ?(time = "<ts>") content = {content; time; seen= false}
|
|
end
|
|
|
|
module Channel = struct
|
|
type t = {name: string; content: Message.t list Lwd.var}
|
|
|
|
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)
|
|
|
|
let make name = {name; content= Lwd.var []}
|
|
end
|
|
|
|
module Tree = struct
|
|
open Channel
|
|
open Message
|
|
|
|
type t =
|
|
{ channel: Channel.t
|
|
; subs: t Lwd_table.t
|
|
; focus: Nottui.Focus.handle }
|
|
|
|
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 : 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
|
|
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.Tree.make_top () in
|
|
let _irc =
|
|
Communicator.Irc.connection comm "irc.hackint.org" 6697 "cqcaml"
|
|
["#CQC"] in
|
|
root_actor := std_actor (Communicator.Panel.panel comm)
|
|
|
|
(**
|
|
program starts...
|
|
- spawn connections to servers
|
|
- these connections will populate the Channel.t in a Channel.tree
|
|
|
|
**)
|