Source file w.ml

(*********************************************************************************)
(*                OCaml-ActivityPub                                              *)
(*                                                                               *)
(*    Copyright (C) 2023-2024 INRIA All rights reserved.                         *)
(*    Author: Maxence Guesdon, INRIA Saclay                                      *)
(*                                                                               *)
(*    This program is free software; you can redistribute it and/or modify       *)
(*    it under the terms of the GNU Lesser General Public License version        *)
(*    3 as published by the Free Software Foundation.                            *)
(*                                                                               *)
(*    This program is distributed in the hope that it will be useful,            *)
(*    but WITHOUT ANY WARRANTY; without even the implied warranty of             *)
(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the              *)
(*    GNU General Public License for more details.                               *)
(*                                                                               *)
(*    You should have received a copy of the GNU General Public License          *)
(*    along with this program; if not, write to the Free Software                *)
(*    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA                   *)
(*    02111-1307  USA                                                            *)
(*                                                                               *)
(*    Contact: maxence.guesdon@inria.fr                                          *)
(*                                                                               *)
(*********************************************************************************)

(** *)

module L = Log
open Stk

module AP = Activitypub
module AS = Rdf.Activitypub
open Activitypub_client

module Log = L

type actions = {
    announce : Iri.t -> (Iri.t option, AP.E.error) result Lwt.t ;
    delete : Iri.t -> (Iri.t option, AP.E.error) result Lwt.t ;
    dislike : Iri.t -> (Iri.t option, AP.E.error) result Lwt.t ;
    like : Iri.t -> (Iri.t option, AP.E.error) result Lwt.t ;
    open_actor : Iri.t -> unit ;
    open_link : Iri.t -> unit;
    reply_to : AP.Types.object_ -> unit Lwt.t ;
    undo : Iri.t -> (Iri.t option, AP.E.error) result Lwt.t ;
    group_box : AP.Types.actor -> unit Pack.box option ;
  }

type AP.E.error +=
| Message of string

let () = AP.E.register_string_of_error
  (function Message msg -> Some msg | _ -> None)

let my_async =
  let handler e = Log.err (fun m -> m "Async: %s" (Printexc.to_string e)) in
  fun f ->
    let f () = try%lwt f() with e -> handler e; Lwt.return_unit in
    Lwt.dont_wait f handler

let activity_box_class = "activity"
let authored_box_class = "authored"
let authored_title_box_class = "author_title"
let authored_content_box_class = "authored_content"
let actor_name_class = "actor_name"
let activity_date_class = "activity_date"
let textlabel_class = "textlabel"
let textlink_class = "textlink"
let link_class = "link"
let collection_box_class = "collection_box"

let activities_css =
  let l =
    [
      AS.c_Accept, "fill: true; bg_color: darkseagreen" ;
      AS.c_Announce, "fill: true; bg_color: azure" ;
      AS.c_Delete, "visible: false; font_size: 12; fg_color: #ccccccff" ;
      AS.c_Follow, "fill: true; bg_color: lavenderblush" ;
      AS.c_Like, "fill: true; bg_color: lemonchiffon" ;
      AS.c_Note, "font_size: 12; font_family: \"DejaVu Serif\"" ;
      AS.c_Reject, "fill: true; bg_color: tomato" ;
      AS.c_Undo, "visible: false; font_size: 12; fg_color: #ccccccff" ;
    ]
  in
  String.concat "\n"
    (List.map (fun (iri, css) ->
        Printf.sprintf "box[class~=%S] { %s }" (Iri.to_string iri) css)
     l)

let css = {css|
   box.activity {
     border_color: grey;
     border_width: 0 0 1 0;
     padding: 6 6 6 0;
   }
   box.activity button {
       border_width: 0 ;
   }
   box.activity button label {
     fg_color_selected: var(--fg-color-selected);
     fg_color_hover: var(--fg-color-hover);
   }
   box.authored {
     hfill: true;
   }
   box.authored box.title {
       valign: 0;
       padding: 0 2 1 2;
   }
   label.activity_date {
     italic: true;
     font_size: 12;
     margin: 0 4 0 10;
   }
   label.link, label.textlink, label.actor_name {
     fg_color: cornflowerblue;
   }
   label.textlabel, label.textlink { margin: 0; padding: 0; }
   label.author_name { font_size: 12; bold: true; margin: 0; }
   box.collection { fill: true; bg_color: white }

   paned.actor_tab { handle_positions: 15%; }
   table.actor_profile {
     padding: 2;
     row_inter_padding: 2 ;
     column_inter_padding: 2 ;
     image.actor_icon { margin: 3 ;}
     label.actor_name { bold: true; font_size: 18; padding: 3;}
     button { border_color: lightgrey; fill: true; bg_color: darkseagreen }
   }
   .warning { fill: true; bg_color: orange; }
   label.follows_you { font_size: 12; fg_color: grey; italic:true ;}
   button.close { padding_left: 2;
     border_width: 0;
   }
   button.accept { padding_left: 2;
     border_width: 1;
     bg_color: orange; fill:true;
   }
   notebook bin.tab *[widget] {
     box { padding: 0; }
     label { padding: 0; }
   }
   flex.xhtml {
     flex.xhtml_ul {
       padding_right: 4;
     }
   }
  |css}

let css = Printf.sprintf "%s\n%s" css activities_css

let stk_extension = "activitypub"

let init =
  let init_done = ref false in
  fun () ->
    if not !init_done then
      (
       init_done := true ;
       Stk.Font.add_fallback_font 0x1F600 0x1F1FC "Noto Color Emoji";
       (*print_endline css;*)
       Stk.Theme.add_css_to_extension ~body:css stk_extension
       (*let (_,t) = Stk.Theme.current_theme () in
       Log.warn (fun m -> m "W.init: current_theme=\n%a"
          Css.pp_string_css (Stk.Theme.statements t))*)
      )

let class_of_object_type act =
  match Iri.to_string act#type_ with
  | "" -> None
  | str -> Some str

let link ?(classes=[]) ?onclick ?text ?pack iri =
  let classes = link_class :: classes in
  let text = match text with None -> Iri.to_string iri | Some str -> str in
  let label = Text.label ~classes ~text ?pack () in
  let () = match onclick with
    | None -> ()
    | Some f ->
        ignore(label#connect Widget.Clicked (fun _ -> f iri ; false));
  in
  label

let split_blank_re = Re.(compile (rep1 blank))
let split_nl_re = Re.(compile (char '\n'))

let mk_text_content_flex ?(classes=[]) ?name ?props ?pack () =
  Flex.flex
    ~classes:("xhtml"::classes) ?name ?props
    ~wrap:true ~wrap_on_break:true
    ~orientation:Props.Horizontal
    ?pack ()

class text_content ?open_link ?classes ?name ?props ?pack () =
  let box = mk_text_content_flex ?classes ?name ?props ?pack () in
  let rec insert_tokens ?iri (box:unit Flex.flex) = function
  | [] -> ()
  | (`Text text) :: q ->
      let () =
        match Re.split_full split_nl_re text with
        | [] -> ()
        | [`Text text] ->
            (*Log.info (fun m -> m "insert: str=%S" str);*)
            let _ =
              let pack = box#pack in
              match iri with
              | None -> Text.label ~classes:[textlabel_class] ~text ~pack ()
              | Some iri -> link ?onclick:open_link ~classes:[textlink_class] ~text ~pack iri
            in
            ()
        | tokens -> insert_tokens ?iri box tokens
      in
      insert_tokens box ?iri q
  | (`Delim g) :: q ->
      if Re.Group.get g 0 = "\n" then
        ignore(box#pack_break ())
      else
        ignore(box#pack_space ());
      insert_tokens ?iri box q
  in
  let rec insert_xml ?iri flex = function
  | Xtmpl.Xml.C _ | PI _ -> ()
  | D cdata ->
      let tokens = Re.split_full split_blank_re cdata.text in
      (*Log.debug (fun m -> m "tokens=%s"
         (String.concat ", " (List.map (function `Text s -> s | `Delim _ -> "[ ]") tokens)));*)
      insert_tokens ?iri flex tokens
  | E node ->
      match String.lowercase_ascii (snd node.name) with
      | "p" | "br" | "div" ->
          (match flex#children_widgets with [] -> () | _ -> ignore(flex#pack_break ()));
          List.iter (insert_xml ?iri flex) node.subs ;
      | "ul" ->
          (match flex#children_widgets with [] -> () | _ -> ignore(flex#pack_break ()));
          let flex = mk_text_content_flex ~classes:["xhtml_ul"] ~pack:flex#pack () in
          List.iter
            (function
             | Xtmpl.Xml.E node when String.lowercase_ascii (snd node.name) = "li" ->
                 let _bullet = Text.label ~text:"• " ~pack: flex#pack () in
                 List.iter (insert_xml ?iri flex) node.subs;
                 ignore(flex#pack_break ())
             | _ -> ()
            )
            node.subs;
      | "a" ->
          let iri =
            match Xtmpl.Xml.get_att node.atts ("","href") with
           | None -> iri
           | Some (s,_) -> try Some (Iri.of_string s) with _ -> iri
          in
          List.iter (insert_xml ?iri flex) node.subs
      | _ -> List.iter (insert_xml ?iri flex) node.subs
  in
  let set_text text =
    let xmls =
      try Xtmpl.Xml.(from_string
         ~param: { default_parse_param with
           ignore_unclosed=true; self_closing=SSet.singleton "br" }
           text)
      with _ -> [Xtmpl.Xml.cdata text]
    in
    box#unpack_all ~destroy:true;
    List.iter (insert_xml box) xmls;
    (*Log.info (fun m -> m "%s: %a" box#me Widget.pp_widget_tree box#wtree);*)
  in
  object(self)
    method box = box
    method set_text = set_text
    method coerce = box#coerce
  end

let box_accept actions (module A : Actor.T) act =
  let box = Pack.hbox () in
  let _label = Text.label ~text:"Accepted: " ~pack:(box#pack ~hexpand:0) () in
  let%lwt () = match act#object_ with
    | None -> Lwt.return ()
    | Some o ->
        let%lwt () = o#dereference in
        let act_type = o#type_ in
        let () =
          let text =
            match AP.Types.activity_type_of_iri act_type, Iri.fragment act_type  with
            | None, _ | _, None -> None
            | Some _, frag -> frag
          in
          let _ = link ?text ~pack:(box#pack ~hexpand:0) o#iri in
          ()
        in
        Lwt.return ()
  in
  Lwt.return box

let text_content_of_obj actions ?pack o =
  let textw = new text_content ~open_link:actions.open_link ?pack () in
  let%lwt () =
    try
      let%lwt () = o#dereference in
      textw#set_text (AP.Types.object_content o);
      Lwt.return_unit
    with e -> Log.err (fun m -> m "%s" (Printexc.to_string e)); Lwt.return_unit
  in
  Lwt.return textw

let image_box (module A:Actor.T) ?width ?height ?pack iri =
  let ct =
    match Ldp.Ct.of_string "*/*" with
    | Ok ct -> ct
    | Error e -> failwith "bad ct */*"
  in
  match%lwt A.O.H.get_non_rdf ~accept:[ct] iri with
  | Ok (_,image) ->
      (*Log.debug (fun m -> m "adding author icon %a" Iri.pp iri);*)
      let%lwt i = Icache.image ?height ?pack image in
      (* set width after height so that ratio is done according to width *)
      Option.iter i#set_width width ;
      Lwt.return_some i
  | Error e ->
      Log.err (fun m -> m "%s" (Ldp.Http.string_of_query_error e)) ;
      Lwt.return_none
  | exception (Unix.Unix_error (e,s1,s2)) ->
      let msg = Printf.sprintf "%s: %s %s" (Unix.error_message e) s1 s2 in
      Log.err (fun m -> m "%s" msg);
      Lwt.return_none

let attachment_box actions a ?pack lo =
  let (lk, iri) =
    match lo with
    | `L lk -> lk, lk#href
    | `O o -> o#as_link, o#iri
  in
  let image_iri =
    match lk#media_type with
    | Some (Ldp.Ct.Image,_) -> Some iri
    | Some ct ->
        Log.warn (fun m -> m "attachment_box ct=%s" (Ldp.Ct.mime_to_string ct));
        None
    | _ ->
        Log.warn (fun m -> m "attachment_box ct=None");
        None
  in
  match image_iri with
  | None ->
      let name = Option.value ~default:"No name" lk#name in
      let textw = new text_content ~open_link:actions.open_link ?pack () in
      textw#set_text name ;
      Lwt.return_some textw#coerce
  | Some iri ->
      let width = min 400 (Option.value ~default:400 lk#width) in
      let height = min 500 (Option.value ~default:300 lk#height) in
      let %lwt ib = image_box a ~width ~height ?pack iri in
      Lwt.return (Option.map (fun ib -> ib#coerce) ib)

let attachments_box actions (module A:Actor.T) ~pack o =
  let%lwt () = o#dereference in
  match o#attachment with
  | [] ->
      Log.info (fun m -> m "%a: no attachment" Iri.pp o#iri);
      Lwt.return_none
  | l ->
      Log.info (fun m -> m "%a: %d attachments" Iri.pp o#iri (List.length l));
      let b = Flex.hflex ~pack ~wrap:true () in
      let%lwt _ = Lwt_list.fold_left_s
        (fun acc lo ->
           (*prerr_endline(Printf.sprintf "%s: attachement %s\n%s"
              (Iri.to_string o#iri) (Iri.to_string (AP.Types.iri_of_lo lo))
              (match o#g with None -> "None" | Some g -> Rdf.Ttl.to_string g)
              );*)
           match%lwt attachment_box actions (module A) ~pack:b#pack lo with
           | None -> Lwt.return acc
           | Some ib -> b#pack_space (); Lwt.return (ib :: acc)
        ) [] l
      in
      Lwt.return_some b

let label_string_of_activity acti =
  match AP.Types.activity_type_of_iri acti#type_ with
  | None -> Lwt.return ""
  | Some t ->
      let sp fmt = Printf.sprintf fmt in
      let%lwt obj =
        match acti#object_ with
        | None -> Lwt.return ""
        | Some o ->
            let%lwt () = o#dereference in
            match Utils.string_of_object_type o#type_ with
            | "" -> Lwt.return ""
            | str -> Lwt.return (sp " a %s" str)
      in
      let target_to, target_from = match acti#target with
        | None -> "", ""
        | Some lo ->
            let iri = Iri.to_string (AP.Types.iri_of_lo lo) in
            sp " to %s" iri, sp " from %s" iri
      in
      let origin = match acti#origin with
        | None -> ""
        | Some lo ->
            let iri = Iri.to_string (AP.Types.iri_of_lo lo) in
            sp " from %s" iri
      in
      let s = match t with
        | `Accept -> sp "accepted%s" obj
        | `Add -> sp "added%s%s" obj target_to
        | `Announce -> sp "shared%s" obj
        | `Arrive -> sp "arrived%s" target_to
        | `Block -> sp "blocked%s" obj
        | `Create -> sp "created%s" obj
        | `Delete -> sp "deleted%s" obj
        | `Dislike -> sp "disliked%s" obj
        | `Flag -> sp "flagged%s" obj
        | `Follow -> sp "followed%s" obj
        | `Ignore -> sp "ignored%s" obj
        | `Invite -> sp "invited%s%s" obj target_to
        | `Join -> sp "joined%s" obj
        | `Leave -> sp "left%s" obj
        | `Like -> sp "liked%s" obj
        | `Listen -> sp "listened%s" obj
        | `Move -> sp "moved%s%s%s" obj origin target_to
        | `Offer -> sp "offered%s" obj
        | `Question -> sp "asked a question"
        | `Read -> sp "read%s" obj
        | `Reject -> sp "rejected%s" obj
        | `Remove -> sp "removed%s%s" obj target_from
        | `TentativeAccept -> sp "attempted to accept%s" obj
        | `TentativeReject -> sp "attempted to reject%s" obj
        | `Travel -> sp "is traveling%s%s" origin target_to
        | `Undo -> sp "undoed%s" obj
        | `Update -> sp "updated%s" obj
        | `View -> sp "viewed%s" obj
      in
      Lwt.return s

let author_image_width = 48
let author_image_height = 48

let authored_box actions (module A : Actor.T) author acti =
  init();
  let%lwt () = author#dereference in
  let box = Pack.hbox ~classes:[authored_box_class] () in
  let%lwt () =
    match author#icon with
    | li :: _ ->
        (
         let iri = AP.Types.iri_of_li li in
         let%lwt _ = image_box (module A)
           ~width:author_image_width ~height:author_image_height
             ~pack:(box#pack ~hexpand:0) iri
         in
         Lwt.return_unit
        )
    | _ ->
        Log.debug (fun m -> m "no icon for %a" Iri.pp author#iri);
        Lwt.return_unit
  in
  let cbox = Pack.vbox ~classes:[authored_content_box_class] ~pack:box#pack () in
  let title_box = Pack.hbox ~classes:[authored_title_box_class] ~pack:(cbox#pack ~vexpand:0) () in
  let _label_name = link ~classes:[actor_name_class]
    ~onclick:actions.open_actor ~text:(AP.Types.actor_name author)
      ~pack:(title_box#pack ~hexpand:0) author#iri
  in
  let%lwt () =
    match%lwt label_string_of_activity acti with
    | "" -> Lwt.return_unit
    | text ->
        let _ = Text.label
          ~text ~pack:(title_box#pack ~hexpand:0) ()
        in
        Lwt.return_unit
  in
  Lwt.return (box, cbox, title_box)

type box_fun = actions ->
  (module Actor.T) -> ?pack:(Widget.widget -> unit) -> AP.Types.object_ -> Widget.widget Lwt.t
let box_fun_of_object_type : box_fun Iri.Map.t ref = ref Iri.Map.empty
let register_object_box_type iri f =
  box_fun_of_object_type := Iri.Map.add iri f !box_fun_of_object_type

let note_box actions (module A : Actor.T) ?pack o =
  let classes = match class_of_object_type o with None -> [] | Some s -> [s] in
  let box = Pack.vbox ~classes ?pack () in
  let _ = text_content_of_obj actions ~pack:box#pack o in
  let%lwt _ = attachments_box actions (module A) ~pack:box#pack o in
  Lwt.return box#coerce

let () = register_object_box_type AS.c_Note note_box

let link_box actions (module A : Actor.T) ?pack o =
  let%lwt () = o#dereference in
  let l = o#as_link in
  let text = Iri.to_string l#href in
  let onclick = actions.open_link in
  Lwt.return (link ~onclick ~text ?pack l#href)#coerce

let () = register_object_box_type AS.c_Link link_box

let object_box actions a ?pack = function
| None -> Lwt.return (Text.label ~text:"No object" ?pack ())#coerce
| Some o ->
    let%lwt () = o#dereference in
    match Iri.Map.find_opt o#type_ !box_fun_of_object_type with
    | Some f -> f actions a ?pack o
    | None ->
        Log.warn (fun m -> m "No fun to create box for type %a; displaying link %a"
           Iri.pp o#type_ Rdf.Term.pp_term o#id);
        let text = Iri.to_string o#iri in
        let onclick = actions.open_link in
        Lwt.return (link ~onclick ~text ?pack o#iri)#coerce

let box_create ?(update=false) actions (module A : Actor.T) act =
  let box = Pack.vbox () in
  if update then ignore (Text.label ~text:"(*)" ~pack:(box#pack ~vexpand:0) ());
  let%lwt _ = object_box actions (module A) ~pack:box#pack act#object_ in
  Lwt.return box

let box_update actions a act = box_create ~update:true actions a act

let box_other act =
  let classes = match class_of_object_type act with None -> [] | Some c -> [c] in
  let box = Pack.hbox ~classes () in
  let () =
    let act_type = act#type_ in
    match AP.Types.activity_type_of_iri act_type, Iri.fragment act_type  with
    | None, _ | _, None -> ()
    | Some _, text -> ignore(Text.label ?text ~pack:(box#pack ~hexpand:0) ())
  in
  let () = match act#object_ with
    | None -> ()
    | Some o -> ignore(link ~pack:(box#pack ~hexpand:0) o#iri)
  in
  Lwt.return box

let box_follow actions (module A : Actor.T) act =
  let classes = match class_of_object_type act with None -> [] | Some c -> [c] in
  let box = Pack.hbox ~classes () in
  match act#actor with
  | None -> Lwt.return box
  | Some follower ->
      let follower = A.get (AP.Types.iri_of_lo follower) in
      let%lwt () = follower#dereference in
      let%lwt me = A.actor () in
      let%lwt l = me#following_list in
      let _follower_link = link ~onclick:actions.open_actor
        ~text:(AP.Types.actor_name follower)
        ~pack:(box#pack ~hexpand:0) follower#iri
      in
      match act#object_ with
      | None -> Lwt.return box
      | Some followed ->
          let followed = A.get followed#iri in
          let%lwt () =
            if Iri.equal me#iri followed#iri then
              (
               if List.exists (Iri.equal follower#iri) l then
                 ignore(Text.label ~text:"follows you" ~pack:box#pack())
               else
                 (
                  let lab = Text.label ~text:"wants to follow you"
                    ~pack:(box#pack ~hexpand:0) ()
                  in
                  let (b, _) = Button.text_button ~classes:["accept"] ~text:"Accept"
                    ~pack:(box#pack ~hexpand:0) ()
                  in
                  let _ = b#connect Widget.Activated
                    (fun () -> my_async (fun () ->
                          Log.warn (fun m -> m "accepting");
                          match%lwt me#accept act with
                          | Ok _ -> box#unpack b#coerce;
                              lab#set_text "follows you";
                          Lwt.return_unit
                          | Error e ->
                              lab#set_text (AP.E.string_of_error e);
                              Lwt.return_unit
                       ))
                  in
                  ()
                 );
               Lwt.return_unit
              )
            else
              (
               ignore(Text.label ~text:"follows" ~pack:(box#pack ~hexpand:0) ());
               let%lwt () = followed#dereference in
               ignore(link ~onclick:actions.open_actor
                ~text:(AP.Types.actor_name followed)
                  ~pack:(box#pack ~hexpand:0) followed#iri);
               Lwt.return_unit
              )
          in
          Lwt.return box

let rec object_of_activity o =
  let%lwt () = o#dereference in
  match AP.Types.activity_type_of_iri o#type_ with
  | None -> Lwt.return_some o
  | Some _ ->
      match o#as_activity#object_ with
      | None -> Lwt.return_none
      | Some o -> object_of_activity o

let announce_object actions o =
  match%lwt object_of_activity o with
  | None -> Lwt.return_none
  | Some o ->
      match%lwt actions.announce o#iri with
      | Error e -> Log.err (fun m -> m "announcing %a: %a"
             Iri.pp o#iri AP.E.pp e);
          Lwt.return_none
      | Ok iri -> Lwt.return_some iri

let like_object actions o =
  match%lwt object_of_activity o with
  | None -> Lwt.return_none
  | Some o ->
      match%lwt actions.like o#iri with
      | Error e -> Log.err (fun m -> m "liking %a: %a"
             Iri.pp o#iri AP.E.pp e);
          Lwt.return_none
      | Ok iri -> Lwt.return_some iri

let dislike_object actions o =
  match%lwt object_of_activity o with
  | None -> Lwt.return_none
  | Some o ->
      match%lwt actions.dislike o#iri with
      | Error e -> Log.err (fun m -> m "disliking %a: %a"
             Iri.pp o#iri AP.E.pp e);
          Lwt.return_none
      | Ok iri -> Lwt.return_some iri

let undo_activity actions o =
   match%lwt actions.undo o#iri with
  | Error e -> Log.err (fun m -> m "undoing %a: %a"
         Iri.pp o#iri AP.E.pp e);
      Lwt.return_none
  | Ok iri -> Lwt.return_some iri

let delete_object_of actions o =
  match o#object_ with
  | None -> Lwt.return_none
  | Some obj ->
      match%lwt actions.delete obj#iri with
      | Error e -> Log.err (fun m -> m "deleting %a: %a"
             Iri.pp obj#iri AP.E.pp e);
          Lwt.return_none
      | Ok iri -> Lwt.return_some iri

let reply_to actions o =
  match%lwt object_of_activity o with
  | None -> Lwt.return_unit
  | Some o -> actions.reply_to o

let activity_menu actor actions act =
  let bbar = Pack.hbox () in
  let (b_reply,_) = Button.text_button
    ~text:"↩" ~pack:(bbar#pack ~hexpand:0) ()
  in
  ignore(b_reply#connect Widget.Activated
   (fun () -> my_async
      (fun () -> reply_to actions act#as_object)));
  let (b_like,l_like) = Button.text_button
    ~text:"★" ~pack:(bbar#pack ~hexpand:0) ()
  in
  ignore(b_like#connect Widget.Activated
   (fun () -> my_async
      (fun () ->
         match%lwt like_object actions act#as_object with
         | None -> Lwt.return_unit
         | Some _ -> l_like#set_selected true; Lwt.return_unit
      )));
  let (b_dislike,l_dislike) = Button.text_button
    ~text:"☇" ~pack:(bbar#pack ~hexpand:0) ()
  in
  ignore(b_dislike#connect Widget.Activated
   (fun () -> my_async
      (fun () ->
         match%lwt dislike_object actions act#as_object with
         | None -> Lwt.return_unit
         | Some _ -> l_dislike#set_selected true; Lwt.return_unit
      )));

  let (b_announce,l_announce) = Button.text_button
      ~text:"↻" ~pack:(bbar#pack ~hexpand:0) ()
  in
  ignore(b_announce#connect Widget.Activated
   (fun () -> my_async
      (fun () ->
         match%lwt announce_object actions act#as_object with
         | None -> Lwt.return_unit
         | Some _ -> l_announce#set_selected true; Lwt.return_unit
      )));
  let () =
    match act#actor with
    | None -> ()
    | Some lo when not (Iri.equal (AP.Types.iri_of_lo lo) actor#iri) -> ()
    | _ ->
        match AP.Types.activity_type_of_iri act#type_ with
        | Some (`Announce | `Dislike | `Follow | `Like) ->
            let (b_undo,l_undo) = Button.text_button
                ~text:"✕" ~pack:(bbar#pack ~hexpand:0) ()
            in
            ignore(b_undo#connect Widget.Activated
             (fun () -> my_async
                (fun () ->
                   match%lwt undo_activity actions act#as_object with
                   | None -> Lwt.return_unit
                   | Some _ -> l_undo#set_selected true; Lwt.return_unit
                )));
        | Some `Create ->
            let (b_delete,l_delete) = Button.text_button
                ~text:"✕" ~pack:(bbar#pack ~hexpand:0) ()
            in
            ignore(b_delete#connect Widget.Activated
             (fun () -> my_async
                (fun () ->
                   match%lwt delete_object_of actions act with
                   | None -> Lwt.return_unit
                   | Some _ -> l_delete#set_selected true; Lwt.return_unit
                )));
        | _ -> ()
  in
  let label = Text.label ~text:"..." ~pack:(bbar#pack ~hexpand:0)  () in

  let popup () =
    ()
  in
  ignore(label#connect Widget.Clicked
   (fun _ ->
      Log.info (fun m -> m "link: %a" Iri.pp act#iri) ;
      prerr_endline (Printf.sprintf "Activity: %s\nObject: %s"
       (Iri.to_string act#iri)
         (match act#object_ with
          | None -> "None"
          | Some o -> Iri.to_string o#iri)
      );
      Log.info (fun m -> m "%a: %a" Iri.pp act#iri AP.Object.pp act);
      my_async (fun () ->
         match act#object_ with
         | None -> Lwt.return_unit
         | Some o ->
             let%lwt () = o#dereference in
             Log.info (fun m -> m "%a: %a" Iri.pp o#iri AP.Object.pp o);
             Lwt.return_unit
      );
      popup () ;
      false));
  bbar#coerce

let pack_object_info actor actions (tbox: unit Pack.box) (o:AP.Types.object_) =
  Option.iter (fun date ->
     let _ = Text.label ~classes:[activity_date_class]
       ~text:(Utils.date_to_since date.Rdf.Term.stamp)
         ~pack:(tbox#pack ~hexpand:0) ()
     in
     ()
  )
    o#published;
  let menu = activity_menu actor actions o#as_activity in
  tbox#pack ~hexpand:0 menu#coerce;
  ()

let box_announce actions (module A : Actor.T) act =
  match act#object_ with
  | None -> Lwt.return (Pack.vbox ())
  | Some o ->
      let%lwt () = o#dereference in
      let%lwt (box, cbox, tbox) =
        let at =
          match o#attributed_to, act#actor with
          | Some at, Some ac when AP.Types.(Iri.equal (iri_of_lo at) (iri_of_lo ac)) -> None
          | x, _ -> x
        in
        match at with
        | Some at ->
            let at = A.get (AP.Types.iri_of_lo at) in
            authored_box actions (module A) at o#as_activity
        | None ->
            let box = Pack.vbox () in
            let tbox = Pack.hbox ~pack:(box#pack ~vexpand:0) () in
            let cbox = Pack.vbox ~pack:box#pack () in
            Lwt.return (box, cbox, tbox)
      in
      let%lwt actor = A.actor () in
      pack_object_info actor actions tbox o ;
      let%lwt b = object_box actions (module A) (Some o) in
      cbox#pack b#coerce ;
      Lwt.return box

let box_of_activity actions ?after (module A : Actor.T) act =
  init();
  let abox = Pack.vbox ~classes:[activity_box_class] () in
  (*let _ = abox#connect Widget.Clicked
    (fun _ -> Log.info (fun m -> m "%a" Widget.pp_widget_tree abox#wtree); false)
  in*)
  let f () =
    let%lwt () = act#dereference in
    let () = Option.iter abox#add_class (class_of_object_type act) in
    (match after with None -> () | Some f -> f abox#coerce);
    match AP.Types.activity_type_of_iri act#type_ with
    | None -> Lwt.return_unit
    | Some at ->
        let%lwt b =
          match at with
          | `Accept -> box_accept actions (module A) act
          | `Add -> box_other act
          | `Announce
          | `Like | `Dislike -> box_announce actions (module A) act
          | `Follow -> box_follow actions (module A) act
          | `Block -> box_other act
          | `Create -> box_create actions (module A) act
          | `Update -> box_update actions (module A) act
          | _ -> box_other act
        in
        let%lwt b =
          match act#actor with
          | None ->
              Log.debug (fun m -> m "no actor for %a" Iri.pp act#iri) ;
              Lwt.return b
          | Some actor ->
              let actor = A.get (AP.Types.iri_of_lo actor) in
              let%lwt (vbox,cbox,tbox) = authored_box actions (module A) actor act in
              cbox#pack b#coerce;
              let%lwt me = A.actor () in
              pack_object_info me actions tbox act#as_object ;
              Lwt.return vbox
        in
        abox#pack b#coerce ;
        Lwt.return_unit
  in
  my_async f;
  abox

let box_of_lo actions ?after (module A : Actor.T) = function
| `L l ->
    let box = Pack.vbox () in
    Log.debug (fun m -> m "box_of_lo: link %a" Iri.pp l#href);
    let _link = link ?text:l#name ~pack:box#pack l#href in
    (match after with None -> () | Some f -> f box#coerce);
    box
| `O act ->
    Log.debug (fun m -> m "box_of_lo: object %a" Iri.pp act#iri);
    let act = A.O.get ?g:act#g act#id in
    box_of_activity actions ?after (module A) act#as_activity

let follow_collection actions ?(page_size=20) ?(check_delay=10.) (module A : Actor.T)
  (box:unit Pack.box) (scr:Bin.scrollbox) col =
  let bnext = Button.button ~pack:(box#pack ~vexpand:0) () in
  let end_label = Text.label ~text:"Next items" ~pack:bnext#set_child () in
  prerr_endline (Printf.sprintf "col#iri = %s" (Iri.to_string col#iri));
  let%lwt () = col#dereference in
  let head = ref None in
  let%lwt items = col#items in
  let add_item ?(new_=false) ~pos lo =
    (* we must access props after they have been set in
       box_of_lo, because they are set after querying the activity
       but here we want to insert box at the right position.
       This is the condition to load items in parallel withoud
       adding more boxes. *)
    let after = if new_ then
        Some (fun (b:Widget.widget) ->
           let bg_color = b#bg_color in
           let fill = b#fill in
           b#set_fill true;
           b#set_bg_color Color.yellow ;
           ignore(b#connect ~count:1 Widget.Mouse_motion
            (fun _ ->
               b#set_bg_color ~delay:0.5 bg_color;
               b#set_fill ~delay:0.5 fill;
               false)
           )
        )
      else None
    in
    let b = box_of_lo actions ?after (module A) lo in
    let%lwt box =
      let%lwt author =
        let o = A.O.of_iri (AP.Types.iri_of_lo lo) in
        let%lwt () = o#dereference in
        Lwt.return o#as_activity#actor
      in
      match author with
      | None -> Lwt.return box
      | Some (`L _) -> Lwt.return box
      | Some (`O obj) ->
          let author = A.get obj#iri in
          let%lwt () = author#dereference in
          if Iri.equal author#type_ AS.c_Group then
            match actions.group_box author#as_actor with
            | None -> Lwt.return box
            | Some b -> Lwt.return b
          else
            Lwt.return box
    in
    box#pack ~pos b#coerce;
    Lwt.return_unit
  in
  let rec retrieve ?(n=0) () =
    if n >= page_size then
      Lwt.return_unit
    else
      (
       match%lwt Lwt_stream.get items with
       | None -> end_label#set_text "End"; Lwt.return_unit
       | Some lo ->
           (match !head with None -> head := Some (AP.Types.iri_of_lo lo) | _ -> ());
           let%lwt () = add_item ~pos:(-1) lo in
           retrieve ~n:(n+1) ()
      )
  in
  let%lwt () = retrieve () in
  let (stream_new, stop) = A.O.collection_next_items ?after: !head col in
  let retrieve_new () =
    Lwt_stream.iter_s (add_item ~new_:true ~pos:0) stream_new
  in
  let t = retrieve_new () in
  let _ = box#connect Widget.Destroy
    (fun _ -> Lwt.cancel t ; stop (); true)
  in
  my_async (fun () -> t);
  let _ = scr#connect Bin.VScrolled
    (fun () ->
       let (_,stop) = scr#vscroll_range in
       if stop >= 1. then my_async (retrieve ?n:None)
    )
  in
  let _ = bnext#connect Widget.Activated (fun _ -> my_async (retrieve ?n:None)) in
  Lwt.return_unit

let collection_box actions (module A : Actor.T) iri =
  init() ;
  let box = Pack.vbox ~classes:[collection_box_class] () in
  let scr = Bin.scrollbox ~pack:(box#pack ~hfill:true) () in
  let () = scr#set_vscrollbar_covers_child false in
  let () = scr#set_vscrollbar_policy `AUTOMATIC in
  let () = scr#set_hscrollbar_policy `NOSCROLL in
  let items_box = Pack.vbox ~pack:scr#set_child () in
  Log.debug (fun m -> m "collection box props: %a\nitems box props: %a"
     Props.pp box#props Props.pp items_box#props);
  my_async (fun () -> follow_collection actions (module A) items_box scr iri) ;
  Lwt.return box

let ct_of_file filename =
  let mt = Magic_mime.lookup filename in
  match Ldp.Ct.of_string mt with
  | Ok ct -> Some ct
  | _ -> None

class attachment_box a ?pack filename =
  let ct = ct_of_file filename in
  object(self)
    val mutable widget = (None: Widget.widget option)
    val mutable width = None
    val mutable height = None
    method box = widget
    method width = width
    method height = height
    method ct = ct
    method document =
      let module A = (val a : Actor.T) in
      let%lwt actor = A.actor () in
      match actor#upload_file with
      | None ->
          Lwt.return_error (Message "Actor cannot upload files (check your configuration)")
      | Some upload ->
          match%lwt upload ?ct filename with
          | Ok iri ->
              let o =
                Object.document (module A.O) (*?name*)
                ?height ?width
                  ?media_type:ct
                  iri
              in
              Lwt.return_ok o
          | Error e -> Lwt.return_error e

    initializer
      match Option.map Ldp.Ct.to_mime ct with
      | Some (Ldp.Ct.Image, _) ->
          let i = Image.image ~file:filename () in
          (match i#image_size with
           | None -> ()
           | Some (w,h) -> width <- Some w; height <- Some h);
          i#set_width 150; i#set_height 100;
          Option.iter (fun f -> f i#coerce) pack;
          widget <- Some i#coerce
      | _ ->
          let name = Filename.basename filename in
          let l = Text.label ~text:name ?pack () in
          widget <- Some l#coerce

  end

class attachments_box a ?pack () =
  let box : unit Pack.box = Pack.vbox ?pack () in
  object(self)
    val mutable docs = ([]:attachment_box list)
    method box = box
    method get : AP.Types.object_ list Lwt.t =
      let f box acc =
        match%lwt box#document with
        | Ok o -> Lwt.return (o :: acc)
        | Error e ->
            Log.err (fun m -> m "%a" AP.E.pp e);
            Lwt.return acc
      in
      Lwt_list.fold_right_s f docs []

    method add_file file =
      let w = new attachment_box a ~pack:(box#pack ~vexpand:0) file in
      docs <- docs @ [w];
      false


  end

let attachments_box a ?pack () = new attachments_box a ?pack ()

type visibility = [`Public | `Followers | `Cited | `None]
type Widget.wdata +=
| Visiblity of visibility

class type create_box =
  object
    method actor : (module Actor.T)
    method attachments : attachments_box
    method coerce : Widget.widget
    method get_text : string
    method visibility : visibility
  end

let create_box ?(in_reply_to=[]) ?(attachements=true) actor =
  let paned = Pack.hpaned () in
  let box = Pack.vbox ~pack:paned#pack () in
  let (b_preview,_) = Button.text_button ~text:"Preview" () in
  let frame_preview = Frame.frame ~label:b_preview#coerce ~pack:paned#pack () in
  let html_preview =
    let scr = Bin.scrollbox ~pack:frame_preview#set_child () in
    new text_content ~pack:scr#set_child ()
  in
  let scr = Bin.scrollbox ~pack:box#pack () in
  let tv = Textview.textview ~pack:scr#set_child () in
  tv#set_tagtheme "terminal" ;
  let get_html () =
    try
      let doc = Omd.of_string (tv#text()) in
      Ok (Omd.to_html doc)
    with e ->
        Error (`Msg (Printexc.to_string e))
  in
  let on_preview () =
    match get_html () with
    | Error (`Msg msg) -> html_preview#set_text msg
    | Ok html -> html_preview#set_text html
  in
  ignore (b_preview#connect Widget.Activated on_preview);
  let wf_atts = Frame.frame ~pack:(box#pack ~vexpand:0)
    ~label:(Text.label ~text:"Attachments" ())#coerce ()
  in
  let att_box = attachments_box actor ~pack:wf_atts#set_child () in
  let on_file_drop (ev:Widget.drop_ev) = att_box#add_file ev.text in
  let bbox = Pack.hbox ~pack:(box#pack ~vexpand:0) () in
  let group = Button.group () in
  let mk_b v text =
    ignore(Button.text_radiobutton ~wdata:(Visiblity v)
     ~group ~text ~pack:bbox#pack ())
  in
  mk_b `Public "Public";
  mk_b `Followers "Followers only";
  mk_b `Cited "Cited actors only";
  mk_b `None "None";
  let o : create_box =
    (object
       method actor = actor
       method attachments = att_box
       method coerce = paned#coerce
       method get_text =
         match get_html () with
         | Error _ -> tv#text ()
         | Ok html -> html
       method visibility = match group#wdata with
         | Some (Visiblity v) -> v
         | _ -> `None

     initializer
         ignore(wf_atts#connect Widget.File_dropped on_file_drop);
         let mentions = (* FIXME: prefill reply with @mentions *) "" in
         tv#insert mentions
     end)
  in
  Lwt.return o

let actor_profile_box actions a actor =
  let module A = (val a : Actor.T) in
  let%lwt me = A.actor () in
  let%lwt () = actor#dereference in
  let box = Pack.vbox ~classes:["actor_profile"] () in
  let head_box = Pack.hbox ~pack:(box#pack ~vexpand:0) () in
  let%lwt () =
    let%lwt w =
      match actor#icon with
      | li :: _ ->
          (
           let iri = AP.Types.iri_of_li li in
           match%lwt image_box a
             ~width:author_image_width ~height:author_image_height
               iri
           with
           | Some i -> i#add_class "actor_icon" ; Lwt.return i#coerce
           | None -> Lwt.return (Text.label ~text:""())#coerce
        )
      | _ ->
          Log.debug (fun m -> m "no icon for %a" Iri.pp actor#iri);
          Lwt.return (Text.label ~text:"" ())#coerce
    in
    head_box#pack ~vexpand:0 ~hexpand:0 w;
    Lwt.return_unit
  in
  let box_name = Pack.vbox ~pack:(head_box#pack ~vexpand:0 ~vfill:false) () in
  let _lab_name = Text.label ~classes:[actor_name_class]
    ~text:(AP.Types.actor_name actor)
      ~pack:(box_name#pack ~vexpand:0) ()
  in
  let%lwt () =
    let%lwt l = me#followers_list in
    if List.exists (Iri.equal actor#iri) l then
      ignore (Text.label ~classes:["follows_you"] ~text:"Follows you"
       ~pack:(box_name#pack ~vexpand:0) ());
    Lwt.return_unit
  in
  let%lwt followed =
    let%lwt l = me#following_list in
    Log.warn (fun m -> m "Following of %a: %s" Iri.pp me#iri
       (String.concat "\n" (List.map Iri.to_string l)));
    Lwt.return (List.exists (Iri.equal actor#iri) l)
  in
  let _b_follow, _lab_follow =
    let text, classes, cb =
      if followed then
        "Unfollow (not implemented yet)", ["warning"], (fun () -> ())
      else
        "Follow", [],
        (fun () -> Lwt.async
           (fun () -> let%lwt _  = me#follow actor#iri in Lwt.return_unit))
    in
    let (button, label) =
      Button.text_button ~text ~classes ~pack:(box_name#pack ~hexpand:(-1) ~vexpand:0) ()
    in
    ignore(button#connect Widget.Activated cb);
    (button, label)
  in
  let () =
    match actor#summary with
    | None -> ()
    | Some text ->
        let scr = Bin.scrollbox ~pack:box#pack () in
        let t = new text_content ~open_link:actions.open_link ~classes:["profile_summary"]
          ~pack:scr#set_child ()
        in
        t#set_text text
  in
  Lwt.return box