getting super confused while trying to make generic tree structure operations that map to irmin
This commit is contained in:
cqc
437
irc.ml
437
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 = "<ts>") 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
|
||||
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..." ;
|
||||
add_msg "Connecting..."
|
||||
>>= fun () ->
|
||||
C.connect_by_name ~server ~port ~nick ()
|
||||
>>= fun c ->
|
||||
Lwt_io.printl "connect_by_name returned"
|
||||
>>= fun () -> Lwt.return c )
|
||||
>>= fun c -> Lwt.return c )
|
||||
~f:(fun connection ->
|
||||
add_msg "Connected" ;
|
||||
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_ch chname) ;
|
||||
ignore (make_channel store [server] chname) ;
|
||||
Lwt.return_unit )
|
||||
channels )
|
||||
chs )
|
||||
~callback:(fun _connection result ->
|
||||
match result with
|
||||
| Result.Ok ({M.command= M.Other _; _} as msg) ->
|
||||
add_msg (M.to_string msg) ;
|
||||
Lwt.return_unit
|
||||
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
|
||||
| None -> Channel.add_msg (make_ch target) )
|
||||
(Message.make (F.str "<%s> %s" user data)) ;
|
||||
Lwt.return_unit
|
||||
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) ;
|
||||
Lwt.return_unit
|
||||
| Result.Error e -> Lwt_io.printl e ) ) ;
|
||||
channel
|
||||
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) ->
|
||||
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 (msg : Message.t) ->
|
||||
F.epr "Communicator.Panel.messagelist ch.content=%s@."
|
||||
msg.content ;
|
||||
(fun doc ((year, month, day, hour, sec), content) ->
|
||||
F.epr
|
||||
"Communicator.Panel.messagelist ch.content=%s@."
|
||||
content ;
|
||||
doc
|
||||
^^ P.group
|
||||
( string msg.time ^/^ string " | "
|
||||
^/^ string msg.content )
|
||||
( string
|
||||
(F.str "%s.%s.%s.%s.%s" year month day hour
|
||||
sec )
|
||||
^^ string " | " ^^ string content )
|
||||
^^ P.hardline )
|
||||
P.empty msgs )
|
||||
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) )
|
||||
|
||||
Reference in New Issue
Block a user