495 lines
16 KiB
OCaml
495 lines
16 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
|
|
let base_path = "communicator"
|
|
let topch = "top"
|
|
|
|
module Istore = struct
|
|
include Human.Store
|
|
|
|
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.gettimeofday ()) content =
|
|
let tm = Unix.localtime time in
|
|
{ time=
|
|
List.map string_of_int
|
|
[tm.tm_year + 1900; tm.tm_mon + 1; tm.tm_mday; tm.tm_hour]
|
|
@ [ string_of_float
|
|
( float_of_int (tm.tm_min * tm.tm_sec)
|
|
+. fst (modf time) ) ]
|
|
; content }
|
|
end
|
|
|
|
module Channel = struct
|
|
(* a channels step key may not be blank (i.e. "") *)
|
|
type t = {store: Istore.t; path: Istore.key}
|
|
|
|
let make (store : Istore.t) ~path ~(name : string) =
|
|
Lwt.return {store; path= path @ ["#" ^ name]}
|
|
|
|
let add_msg {store; path} (msg : Message.t) : unit Lwt.t =
|
|
F.epr "add_msg path=[" ;
|
|
F.list ~sep:F.semi F.string F.stderr (path @ msg.time) ;
|
|
F.epr "] content=%s @." msg.content ;
|
|
Istore.set_exn store ~info:Irmin.Info.none (path @ msg.time)
|
|
msg.content
|
|
end
|
|
|
|
module Tree = struct
|
|
open Message
|
|
|
|
type selection = Istore.Key.t
|
|
type t = {store: Istore.t; view: Istore.key}
|
|
|
|
let contents {store; view} (s : selection) :
|
|
Istore.Contents.t option Lwt.t =
|
|
Istore.find store (view @ s)
|
|
|
|
let make_top ?(view = [base_path]) 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
|
|
Channel.make store ~path:view ~name:topch
|
|
>>= fun ch_top ->
|
|
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 Protocol = struct
|
|
type t = Irc | Email | Rss | Mublog | ActivityPub
|
|
|
|
let to_string = function
|
|
| Irc -> ("IRC", "Internet Relay Chat")
|
|
| Email -> ("E-mail", "Electronic Mail")
|
|
| Rss -> ("RSS", "Really Simple Subscriptions???")
|
|
| Mublog -> ("uBlog", "Microblogging (Twitter)")
|
|
| ActivityPub -> ("ActivityPub", "Mastodon, etc.")
|
|
|
|
let id t = fst (to_string t)
|
|
let desc t = snd (to_string t)
|
|
end
|
|
|
|
module Irc = struct
|
|
module C = Irc_client_tls
|
|
module M = Irc_message
|
|
|
|
module Config = struct
|
|
type t = Istore.tree
|
|
|
|
open Lwt.Infix
|
|
|
|
let path = "_config"
|
|
|
|
let make_connection Tree.{store; view} 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.Tree.add t' ["protocol"] (Protocol.id Irc)
|
|
>>= fun t' ->
|
|
F.epr "Creating connection config /%s/%s/@." name path ;
|
|
Istore.set_tree_exn ~info:Irmin.Info.none store
|
|
(view @ [name; path])
|
|
t'
|
|
>>= fun _ -> Lwt.return_unit
|
|
|
|
let server t : string Lwt.t = Istore.Tree.get t [path; "server"]
|
|
|
|
let port t : int Lwt.t =
|
|
Istore.Tree.get t [path; "port"] >|= fun p -> int_of_string p
|
|
|
|
let nick t : string Lwt.t = Istore.Tree.get t [path; "nick"]
|
|
|
|
let protocol t : string option Lwt.t =
|
|
Istore.Tree.find t [path; "protocol"]
|
|
end
|
|
|
|
let get_channels ~store ~path =
|
|
Istore.list store path
|
|
>>= fun c ->
|
|
let rec iter l =
|
|
Lwt_list.filter_map_p
|
|
(fun (s, _) ->
|
|
if String.length s > 1 && String.get s 0 = '#' then
|
|
Lwt.return (Some s)
|
|
else Lwt.return None )
|
|
l in
|
|
iter c
|
|
|
|
let connect ?(path = [base_path]) ({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. *)
|
|
Channel.make store ~path ~name:topch
|
|
>>= fun top_channel ->
|
|
let _top_msg str =
|
|
Channel.add_msg top_channel (Message.make str) in
|
|
let channel_assoc = ref [] in
|
|
let make_channel store path (name : string) =
|
|
Channel.make store ~path ~name
|
|
>>= fun ch ->
|
|
channel_assoc := (name, ch) :: !channel_assoc ;
|
|
Channel.add_msg ch
|
|
(Message.make (F.str "channel %s created" name))
|
|
>>= fun () -> Lwt.return ch in
|
|
Istore.list store path
|
|
>>= fun servers ->
|
|
Lwt_list.filter_p
|
|
(fun (_, tree) ->
|
|
Config.protocol tree
|
|
>|= function Some p -> p = Protocol.id Irc | None -> false
|
|
)
|
|
servers
|
|
(* filter out non-irc protocols, TODO currently relying on this to filter out non-server folders too *)
|
|
>>= fun servers ->
|
|
F.epr "protocols filtered for irc@." ;
|
|
Lwt_list.iter_p
|
|
(fun (name, tree) ->
|
|
F.epr "Irc.connect server=%s @." name ;
|
|
Config.nick tree
|
|
>>= fun nick ->
|
|
Config.server tree
|
|
>>= fun server ->
|
|
Config.port tree
|
|
>>= fun port ->
|
|
Channel.make store ~path:(path @ [name]) ~name:topch
|
|
>>= fun server_channel ->
|
|
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 ->
|
|
F.epr "Irc.connect C.reconnect_loop ~f:(Connected...)@." ;
|
|
add_msg "Connected"
|
|
>>= fun () ->
|
|
get_channels ~store ~path:[name]
|
|
>>= fun chs ->
|
|
Lwt_list.iter_p
|
|
(fun chname ->
|
|
C.send_join ~connection ~channel:chname
|
|
>>= fun () ->
|
|
ignore (make_channel store [name] 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
|
|
open Panel
|
|
open Panel.Ui
|
|
|
|
type viewer =
|
|
{ step: string
|
|
; var: view Lwd.var
|
|
; mutable parent: view
|
|
; mutable node: viewer list }
|
|
|
|
and view = [`Empty | `View of viewer]
|
|
|
|
let add v node =
|
|
( match v with
|
|
| `View v ->
|
|
v.node <- node :: v.node ;
|
|
Lwd.set v.var (`View v)
|
|
| `Empty -> () ) ;
|
|
node.parent <- v ;
|
|
Lwd.set node.var (`View node) ;
|
|
`View node
|
|
|
|
let make step parent node =
|
|
let v = {step; var= Lwd.var `Empty; parent; node} in
|
|
( match parent with
|
|
| `View parent ->
|
|
parent.node <- v :: parent.node ;
|
|
Lwd.set parent.var (`View parent)
|
|
| `Empty -> () ) ;
|
|
let rec iter = function
|
|
| [] -> ()
|
|
| x :: xs ->
|
|
x.parent <- `View v ;
|
|
Lwd.set x.var (`View x) ;
|
|
iter xs in
|
|
iter node ;
|
|
Lwd.set v.var (`View v) ;
|
|
`View v
|
|
|
|
let rec last = function
|
|
| [] -> None
|
|
| [x] -> Some x
|
|
| _ :: xs -> last xs
|
|
|
|
let rec last_def = function
|
|
| [] -> "[]"
|
|
| [x] -> x
|
|
| _ :: xs -> last_def xs
|
|
|
|
let find_node ~step ~view =
|
|
match view with
|
|
| `Empty -> None
|
|
| `View v -> List.find_opt (fun v' -> v'.step = step) v.node
|
|
|
|
let string_of_path path =
|
|
"[" ^ F.str "%a" (F.list ~sep:F.semi F.string) path ^ "]"
|
|
|
|
let remove (v : viewer) =
|
|
Lwd.set v.var `Empty ;
|
|
`Empty
|
|
|
|
let storeview store path =
|
|
Istore.get_tree store path
|
|
>>= fun tree ->
|
|
let update d key (view : view) : view option Lwt.t =
|
|
F.epr "fold ~pre:update key=%s @." (string_of_path key) ;
|
|
Lwt.return
|
|
( match
|
|
( List.rev key
|
|
, find_node
|
|
~step:(Option.value (last key) ~default:"[]")
|
|
~view
|
|
, d )
|
|
with
|
|
| [], None, `Added | [], None, `Updated ->
|
|
Some (make "[]" view [])
|
|
| [], Some v, _ -> Some (`View v)
|
|
| [], None, `Removed -> None
|
|
| _ :: k :: _, _, _ when k.[0] == '#' -> None
|
|
| k :: _, None, `Added | k :: _, None, `Updated ->
|
|
Some (make k view [])
|
|
| _ :: _, None, `Removed -> None
|
|
| _ :: _, Some v, _ -> Some (`View v) ) in
|
|
(* if pre returns None, the children of that node are skipped. *)
|
|
let rec map ?(key = []) ~node tree (acc : view) : view Lwt.t =
|
|
let acc =
|
|
match acc with
|
|
| `Empty -> make (last_def key) acc []
|
|
| v -> v in
|
|
Istore.Tree.list tree []
|
|
>>= fun tree ->
|
|
Lwt_list.iter_s
|
|
(fun (s, t) ->
|
|
let k = key @ [s] in
|
|
node k acc
|
|
>|= function
|
|
| Some a ->
|
|
F.epr "storeview Fold step=%s @." s ;
|
|
ignore (map ~key:k ~node t a)
|
|
| None -> F.epr "storeview None step=%s @." s )
|
|
tree
|
|
>|= fun () -> acc in
|
|
map ~node:(update `Added) tree `Empty
|
|
>>= fun t ->
|
|
let root = Lwd.var t in
|
|
Istore.watch_key store path (fun diff ->
|
|
let d, tree =
|
|
match diff with
|
|
| `Added (_, tree) -> (`Added, tree)
|
|
| `Removed (_, tree) -> (`Removed, tree)
|
|
| `Updated (_, (_, tree)) -> (`Updated, tree) in
|
|
map ~node:(update d) tree t
|
|
>>= fun t' -> Lwd.set root t' ; Lwt.return_unit )
|
|
>>= fun watch -> Lwt.return (watch, root)
|
|
|
|
let channelview (store, path) =
|
|
storeview store path
|
|
>>= fun (_watch, root) ->
|
|
let ui =
|
|
Lwd.join
|
|
(Lwd.map (Lwd.get root) ~f:(function
|
|
| `Empty ->
|
|
failwith "channelview says root Lwd.var is `Empty"
|
|
| `View v ->
|
|
let rec iter ?(indent = 0) (v : viewer) =
|
|
Lwd.bind (Lwd.get v.var) ~f:(function
|
|
| `Empty -> Lwd.return Ui.empty
|
|
| `View v' ->
|
|
let sub =
|
|
Lwd_utils.pack Ui.pack_y
|
|
(List.map
|
|
(iter ~indent:(indent + 1))
|
|
v'.node ) in
|
|
Lwd.map sub ~f:(fun sub ->
|
|
Ui.join_y
|
|
(Ui.string
|
|
( String.make indent '>' ^ " "
|
|
^ v'.step ) )
|
|
sub ) ) in
|
|
iter v ) ) in
|
|
let chs, chs_push = Lwt_stream.create () in
|
|
Channel.make store ~path:[base_path] ~name:topch
|
|
>>= fun ch ->
|
|
chs_push (Some ch) ;
|
|
Lwt.return (chs, ui)
|
|
|
|
let messagelist ({store; path} : Channel.t) mlist :
|
|
Istore.watch Lwt.t =
|
|
let mlist' () =
|
|
Istore.get_tree store path
|
|
>>= fun tree ->
|
|
Istore.Tree.fold ~depth:(`Eq 5)
|
|
~contents:(fun key contents view ->
|
|
match key with
|
|
| [y; m; d; h; s] ->
|
|
Lwt.return (((y, m, d, h, s), contents) :: view)
|
|
| _ ->
|
|
F.epr
|
|
"ERROR: messagelist (fold ~depth:(`Eq 5)) got \
|
|
wrong number of steps@." ;
|
|
Lwt.return view )
|
|
~node:(fun _key _node view ->
|
|
F.epr
|
|
"ERROR: messagelist (fold ~depth:(`Eq 5)) found a \
|
|
node@." ;
|
|
Lwt.return view )
|
|
tree [] in
|
|
mlist' ()
|
|
>>= fun ml ->
|
|
Lwd.set mlist ml ;
|
|
Istore.watch_key store path (fun _ ->
|
|
mlist' ()
|
|
>>= fun mlist' -> Lwt.return (Lwd.set mlist mlist') )
|
|
|
|
let messageview ch =
|
|
let mlist = Lwd.var [(("", "", "", "", ""), "")] in
|
|
let rec update_messagelist watch () =
|
|
Lwt_stream.last_new ch
|
|
>>= fun ch ->
|
|
( match watch with
|
|
| None -> Lwt.return_unit
|
|
| Some w -> Istore.unwatch w )
|
|
>>= fun () ->
|
|
messagelist ch mlist
|
|
>>= fun watch -> update_messagelist (Some watch) () in
|
|
Lwt.async (update_messagelist None) ;
|
|
Lwt.return
|
|
(Lwd.map (Lwd.get mlist) ~f:(fun mlist ->
|
|
scroll
|
|
(List.fold_left
|
|
(fun doc ((year, month, day, hour, sec), content) ->
|
|
F.epr
|
|
"Communicator.Panel.messagelist ch.content=%s@."
|
|
content ;
|
|
doc
|
|
^/^ Ui.string
|
|
(F.str "%s.%s.%s.%s.%s" year month day hour
|
|
sec )
|
|
^^ Ui.string " | " ^^ string content )
|
|
Ui.empty mlist ) ) )
|
|
|
|
let commview (store, path) =
|
|
channelview (store, List.rev (List.tl (List.rev path)))
|
|
>>= fun (ch, cv) ->
|
|
messageview ch
|
|
>>= fun mv ->
|
|
Lwt.return (Lwd.map2 cv mv ~f:(fun c m -> join_x c m))
|
|
|
|
let panel ({store; view} : Tree.t) : (Event.t -> atom Lwt.t) Lwt.t
|
|
=
|
|
commview (store, view) >>= fun cv -> Panel.Ui.panel cv
|
|
end
|
|
end
|
|
|
|
(**
|
|
program starts...
|
|
- spawn connections to servers
|
|
- these connections will populate the Channel.t in a Channel.tree
|
|
|
|
**)
|
|
let _ =
|
|
Lwt.async (fun () ->
|
|
Communicator.Tree.make_top "commstore" "current"
|
|
>>= fun comm ->
|
|
Communicator.Irc.Config.make_connection comm "irc.hackint.org"
|
|
6697 "cqcaml"
|
|
>>= fun () ->
|
|
Lwt.async (fun () -> Communicator.Irc.connect comm) ;
|
|
F.epr
|
|
"root_actor := std_actor (Communicator.Panel.panel comm)@." ;
|
|
Communicator.Panel.panel comm
|
|
>|= fun f ->
|
|
root_actor :=
|
|
std_actor
|
|
(Lwt.return
|
|
Panel.
|
|
{ act=
|
|
(fun _ events ->
|
|
Lwt_list.fold_left_s
|
|
(fun _ ev ->
|
|
f ev
|
|
>>= fun i ->
|
|
Lwt.return (fun s ->
|
|
( s
|
|
, ( Gg.Box2.of_pts Gg.V2.zero (snd i)
|
|
, fst i ) ) ) )
|
|
Display.pane_empty events )
|
|
; subpanels= []
|
|
; tag= "irc" } ) )
|