diff --git a/irc.ml b/irc.ml index ab38f3a..a09eb91 100644 --- a/irc.ml +++ b/irc.ml @@ -8,111 +8,194 @@ features: - 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 Human open Lwt open Lwt_react module F = Fmt module Communicator = struct - module Message = struct - type t = {content: string; time: string; mutable seen: bool} + module Istore = struct + include Human.Store - let make ?(time = "") content = {content; time; seen= false} + let from_storeview (sv : storeview) = sv.store + + include Human.Store.Istore + end + + module Message = struct + type t = {time: string list; content: string} + + let make ?(time = Unix.time ()) content = + let tm = Unix.localtime time in + { time= + [ string_of_int tm.tm_year; string_of_int tm.tm_mon + ; string_of_int tm.tm_mday; string_of_int tm.tm_hour ] + ; content } end module Channel = struct - type t = {name: string; content: Message.t list Lwd.var} + type t = {store: Istore.t; path: Istore.key} - 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 (store : Istore.t) ~path ~name = + {store; path= path @ name} - let make name = {name; content= Lwd.var []} + let add_msg {store; path} (msg : Message.t) : unit Lwt.t = + Istore.set_exn store ~info:Irmin.Info.none (path @ msg.time) + msg.content end module Tree = struct - open Channel open Message - type t = - { channel: Channel.t - ; subs: t Lwd_table.t - ; focus: Nottui.Focus.handle } - + type selection = Istore.Key.t + type t = {store: Istore.t; view: Istore.key} 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 contents {store; view} (s : selection) : + Istore.Contents.t option Lwt.t = + Istore.find store (view @ s) - 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 ()} + let make_top ?(view = ["communicator"]) gitpath branchname : + t Lwt.t = + Istore.Repo.v (Irmin_git.config gitpath) + >>= fun repo -> + Istore.of_branch repo branchname + >>= fun store -> + let t = {store; view= []} in + Istore.get_tree store view + >>= fun _tree -> + let view = Istore.Key.v view in + Istore.list store view + >>= fun _viewlist -> + let ch_top = Channel.make store ~path:[] ~name:["top"] in + Channel.add_msg ch_top + (Message.make "Communicator restarting...") + >>= fun () -> + Channel.add_msg ch_top + (Message.make "Currently only IRC is implemented") + >>= fun () -> Lwt.return t + + let add {store; view} ~(name : string list) ~(config : Istore.tree) + : t Lwt.t = + Istore.get_tree store name + >>= fun tree -> + Istore.Tree.remove tree ["_config"] + >>= fun tree -> + Istore.Tree.add_tree tree [] config + >>= fun tree -> + Istore.set_tree_exn ~info:Irmin.Info.none store name tree + >>= fun () -> Lwt.return {store; view} 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 + module Config = struct + type t = Istore.tree + + open Lwt.Infix + + let make_connection Tree.{store; _} server port nick = + let name = F.str "%s@%s:%d" nick server port in + Istore.Tree.add Istore.Tree.empty ["server"] server + >>= fun t' -> + Istore.Tree.add t' ["port"] (string_of_int port) + >>= fun t' -> + Istore.Tree.add t' ["nick"] nick + >>= fun t' -> + Istore.set_tree_exn ~info:Irmin.Info.none store + ["irc"; name; "_config"] + t' + >>= fun _ -> Lwt.return_unit + + let server t : string Lwt.t = Istore.Tree.get t ["server"] + + let port t : int Lwt.t = + Istore.Tree.get t ["port"] >|= fun p -> int_of_string p + + let nick t : string Lwt.t = Istore.Tree.get t ["nick"] + end + + let get_channels ~store ~path = + Istore.list store path + >>= fun c -> Lwt.return (fst (List.split c)) + + let connect ?(path = ["irc"]) ({store; _} : Tree.t) : unit Lwt.t = + (* search for all connections and start them *) + (* also need ot figure out how to preserve custom ordering of items like servers and channels + maybe just a _order file that has the ordering of files listed and hten gets updated etc. *) + let top_channel = + Channel.make store ~path:["irc"] ~name:["top"] in + let _top_msg str = + Channel.add_msg top_channel (Message.make str) in + Istore.list store path + >>= fun servers -> let channel_assoc = ref [] in - let make_ch name = - let ch = Channel.make name in - Tree.add c ch ; + let make_channel store server (name : string) = + let ch = + Channel.make store ~path:(["irc"] @ server) ~name:[name] + in 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 + Channel.add_msg ch + (Message.make (F.str "channel %s created" name)) + >>= fun () -> Lwt.return ch in + Lwt_list.iter_p + (fun (_server, tree) -> + Config.nick tree + >>= fun nick -> + Config.server tree + >>= fun server -> + Config.port tree + >>= fun port -> + let server_channel = + Channel.make store ~path ~name:[server; server] in + let add_msg s = + Channel.add_msg server_channel (Message.make s) in + C.reconnect_loop ~after:30 + ~connect:(fun () -> + add_msg "Connecting..." + >>= fun () -> + C.connect_by_name ~server ~port ~nick () + >>= fun c -> Lwt.return c ) + ~f:(fun connection -> + add_msg "Connected" + >>= fun () -> + get_channels ~store ~path:["irc"; server] + >>= fun chs -> + Lwt_list.iter_p + (fun chname -> + C.send_join ~connection ~channel:chname + >>= fun () -> + ignore (make_channel store [server] chname) ; + Lwt.return_unit ) + chs ) + ~callback:(fun _connection result -> + match result with + | Result.Ok ({M.command= M.Other _; _} as msg) -> + add_msg (M.to_string msg) + | 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 + (Message.make (F.str "<%s> %s" user data)) + | None -> + make_channel store [server] target + >>= fun ch -> + Channel.add_msg ch + (Message.make (F.str "<%s> %s" user data)) ) + | Result.Ok msg -> + add_msg (M.to_string msg) + >>= fun () -> Lwt.return_unit + | Result.Error e -> Lwt_io.printl e ) + () ) + servers end module Panel = struct @@ -122,39 +205,208 @@ module Communicator = struct let string ?attr text = P.ui (Nottui_widgets.string ?attr text) let ( ^^ ) = P.( ^^ ) let ( ^/^ ) a b = P.(a ^^ break 1 ^^ b) + let (messagelist_watch : Istore.watch option ref) = ref None - 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 ) + let messagelist ~store (ch : Channel.t) : P.t Lwd.t Lwt.t = + ( match !messagelist_watch with + | Some w -> Istore.unwatch w + | None -> Lwt.return_unit ) + >>= fun () -> + let mlist' () = + let sl l = + l + >>= fun x -> + Lwt.return (List.sort String.compare (fst (List.split x))) + in + sl (Istore.list store ch.path) + >>= fun years -> + let year = List.hd years in + sl (Istore.list store (ch.path @ [year])) + >>= fun months -> + let month = List.hd months in + sl (Istore.list store (ch.path @ [month])) + >>= fun days -> + let day = List.hd days in + sl (Istore.list store (ch.path @ [day])) + >>= fun hours -> + let hour = List.hd hours in + Istore.list store [year; month; day; hour] + >>= fun mlist -> + Lwt_list.map_p + (fun (second, content) -> + Istore.Tree.get content [] + >>= fun content -> + Lwt.return ((year, month, day, hour, second), content) ) + mlist in + mlist' () + >>= fun mlist -> + let mlist = Lwd.var mlist in + Istore.watch_key store ch.path (function _ -> + mlist' () + >>= fun mlist' -> Lwt.return (Lwd.set mlist mlist') ) + >>= fun watch -> + messagelist_watch := Some watch ; + Lwt.return + (Lwd.map (Lwd.get mlist) ~f:(fun mlist -> + List.fold_left + (fun doc ((year, month, day, hour, sec), content) -> + F.epr + "Communicator.Panel.messagelist ch.content=%s@." + content ; + doc + ^^ P.group + ( string + (F.str "%s.%s.%s.%s.%s" year month day hour + sec ) + ^^ string " | " ^^ string content ) + ^^ P.hardline ) + P.empty mlist ) ) open Nottui_widgets - (*type focustree = - {channel: Channel.t; subs: focustree list; focus: Focus.handle} + module StoreTree = struct + (* the tree structure needs to allow: + - arbitrary traversal from a handle for any node (double linked sufficient?) + - Incremental updates, where the tree/node generation function is only called on updated nodes + - returns a Lwd.var which gets updated anytime the watch is triggered by a change on disk. + *) - 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 ()} *) + type 'a t = + {step: string; mutable super: 'a super; mutable node: 'a node} - let channelview (tree : Tree.t) : 'a Lwd.t * Channel.t Lwd.var = - let channel = Lwd.var tree.channel in + and 'a super = [`Tree of 'a t | `Root] + + and 'a sub = 'a t list + + and 'a node = [`Node of 'a sub | `Contents of 'a] + + let rec mapt ?(super = `Root) ~(f : 'a t -> 'b t -> 'b t) + (a : 'a t) : 'b t = + let this = {a with super; node= `Node []} in + match a with + | {node= `Node subs; _} as aa -> + let rec iter = function + | x :: xs -> mapt ~super:(`Tree this) ~f x :: iter xs + | [] -> [] in + this.node <- `Node (iter subs) ; + f aa this + | {node= `Contents _; _} as aa -> f aa this + + let rec map ?(super = `Root) + ~(f : 'a node -> 'b node -> 'b node) (a : 'a node) : 'b node + = + match a with + | `Node subs as aa -> + let rec iter = function + | ({node; _} as x) :: xs -> + let this = {x with super; node= `Node []} in + this.node <- map ~super:(`Tree this) ~f node ; + this :: iter xs + | [] -> [] in + f aa (`Node (iter subs)) + | `Contents _ as aa -> f aa (`Node []) + + let rec map2 ?(super = `Root) + ~(f : 'a t option -> 'b t option -> 'c t -> 'c t) (a : 'a t) + (b : 'b t) : 'c t = + let this = {a with super; node= `Node []} in + let rec iter2 (a : 'a sub) (b : 'b sub) : 'c sub = + match (a, b) with + | ae :: al, be :: bl -> + map2 ~super:(`Tree this) ~f ae be :: iter2 al bl + | [], be :: bl -> + mapt ~super:(`Tree this) + ~f:(fun x -> f None (Some x)) + be + :: iter2 [] bl + | ae :: al, [] -> + mapt ~super:(`Tree this) + ~f:(fun x -> f (Some x) None) + ae + :: iter2 [] al + | [], [] -> [] in + f (Some a) (Some b) + { this with + node= + ( match (a.node, b.node) with + | `Node nodes_a, `Node nodes_b -> + `Node (iter2 nodes_a nodes_b) + | `Contents _, `Node nodes_b -> `Node (iter2 [] nodes_b) + | `Node nodes_a, `Contents _ -> `Node (iter2 nodes_a []) + | `Contents _, `Contents _ -> `Node [] ) } + + let rec of_istore_tree ?(super = `Root) (tree : Istore.tree) : + 'a node Lwt.t = + Istore.Tree.kind tree [] + >>= fun kind -> + match kind with + | None -> Lwt.return (`Node []) + | Some `Node -> + Istore.Tree.list tree [] + >>= fun nlist -> + Lwt_list.map_p + (fun (step, tree') -> + let t = {step; super; node= `Node []} in + of_istore_tree ~super:(`Tree t) tree' + >>= fun sub -> + t.node <- sub ; + Lwt.return t ) + nlist + >>= fun sub -> Lwt.return (`Node sub) + | Some `Contents -> + Istore.Tree.get tree [] + >>= fun content -> Lwt.return (`Contents content) + + let watch_tree (store : Istore.t) (tree : Istore.tree) + ~(f : string t Irmin.diff -> 'a t) : + (Istore.watch * 'a t Lwd.var) Lwt.t = + of_istore_tree tree + >>= (function + | `Contents _ as node -> + Lwt.return {step= ""; super= `Root; node} + | `Node sub -> + Lwt_list.map_p + (fun t' -> + Lwt.return + (mapt ~f:(fun a _ -> f (`Added a)) t') ) + sub + >>= fun node -> + Lwt.return {step= ""; super= `Root; node= `Node node} + ) + >>= fun t -> + let tree = Lwd.var t in + let aux c = + of_istore_tree (Istore.Commit.tree c) + >>= fun t' -> + Lwd.set tree + (map2 (Lwd.peek tree) + {step= ""; super= `Root; node= t'} + ~f:(fun prev next _ -> + match (prev, next) with + | Some prev, Some next -> f (`Updated (prev, next)) + | Some prev, None -> f (`Removed prev) + | None, Some next -> f (`Added next) + | None, None -> failwith "StoreTree.watch_tree" ) ) ; + Lwt.return_unit in + Istore.watch store (function + | `Added c -> aux c + | `Removed c -> aux c + | `Updated (_, c') -> aux c' ) + >>= fun watch -> Lwt.return (watch, tree) + end + + let channelview ({store; path} : Channel.t) = + Istore.get_tree store path + >>= fun tree -> StoreTree.watch_tree store tree ~f:(function + `Added ({node=`Contents _;_} as t) -> t + | `Removed _ -> + + let _channelview ({store; _} : Tree.t) (channel : Channel.t) = + Fold.tree store ~depth:3 ~path:[] ~f:(function + | Tree (step, tl) -> Tree (step, tl) + | Node (step, content) -> Node (step, content) ) + >>= fun (tree : string Fold.t Lwd.var) -> + let channel = Lwd.var channel in let rec fold ?(indent = 0) ?superfocus (tree : Tree.t) : 'a Lwd.t = let subfocus = Focus.make () in @@ -164,8 +416,7 @@ module Communicator = struct let focus = match superfocus with | Some sf -> - Lwd.map2 (Focus.status sf) - (Focus.status tree.focus) + Lwd.map2 (Focus.status sf) Focus.status ~f:(fun superfocus' focus' -> if Focus.has_focus superfocus' then F.epr @@ -230,7 +481,7 @@ module Communicator = struct Panel.Nottui.scroll_area (Lwd.map (Lwd.bind (Lwd.get ch) ~f:messagelist) - ~f:(P.pretty 200) ) + ~f:(P.pretty 100) ) let commview c = let cv, ch = channelview c in @@ -247,16 +498,16 @@ module Communicator = struct 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 **) +let _ = + Lwt.async (fun () -> + let comm = Communicator.Tree.make_top root_storeview in + Irc.Config.make "irc.hackint.org" 6697 "cqcaml" + >|= fun irc_config -> + let _irc = Communicator.Irc.connection comm irc_config in + root_actor := std_actor (Communicator.Panel.panel comm) )