(*
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" } ) )