Source file machine.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 AS = Rdf.Activitystreams
module AP = Activitypub
module Log = AP.Log

open Lwt.Infix

type AP.E.error +=
| Missing_actor

let string_of_error = function
| Missing_actor -> Some "Missing actor"
| _ -> None

let () = AP.E.register_string_of_error string_of_error

module type Wm = sig
    module Rd = Webmachine.Rd
    include Webmachine.S with type 'a io = 'a Lwt.t
  end

module Wm : Wm = struct
    module Rd = Webmachine.Rd
   (* using Unix.gettimeofday *)
    module UnixClock = struct
      let now = fun () -> int_of_float (Unix.gettimeofday ())
    end
    include Webmachine.Make(AP.Cohttp_tls.IO)(UnixClock)
  end

let mime_xhtml = Ldp.Ct.mime_xhtml
let mime_nquads = AP.Utils.mime_nquads
let mime_jsonld = AP.Utils.mime_jsonld
let mime_jrd_json = AP.Utils.mime_jrd_json

let mime_ap = AP.Utils.mime_ap
let mime_xhtml_charset = Html.mime_xhtml_charset
let mime_html = "text/html"

module MimeSet = Set.Make (struct type t = Ldp.Ct.mime let compare = compare end)

let handled_rdf_mimes = MimeSet.of_list
  [ Ldp.Ct.mime_xmlrdf ;
    Ldp.Ct.mime_turtle ;
    mime_jsonld ;
    mime_ap ;
  ]
let is_handled_rdf_mime mime =
  MimeSet.mem mime handled_rdf_mimes

let error_rd rd title message =
  let body = Html.page ~page_title:title ~contents:[Xtmpl.Rewrite.cdata message] () in
  let body = Xtmpl.Rewrite.to_string body in
  let rd = { rd with Wm.Rd.resp_body = `String body } in
  let rd = Wm.Rd.with_resp_headers
    (fun h -> Cohttp.Header.add h "content-type"
       (Ldp.Ct.to_string mime_xhtml_charset))
      rd
  in
  rd

let request_uri_path_ends_with_slash rd =
  let req_path = Uri.path rd.Wm.Rd.uri in
  let len = String.length req_path in
  len > 0 && String.get req_path (len-1) = '/'

let content_type_of_rd rd =
  let h = rd.Wm.Rd.req_headers in
  match Cohttp.Header.get h "content-type" with
  | None -> Ldp.Ct.ct_turtle
  | Some str -> Ldp.Types.content_type_of_string ~fail:false str

let link_type_of_rd rd =
  let h = rd.Wm.Rd.req_headers in
  match Cohttp.Header.get h "link" with
    None -> None
  | Some str ->
      let links = Iri.parse_http_link str in
      try Some (List.assoc "type" links)
      with Not_found -> None

let rd_set_location rd iri =
  Wm.Rd.with_resp_headers
    (fun h -> Cohttp.Header.replace h "location"
       (Iri.to_uri iri)
    )
    rd

let rd_set_content_type rd ct =
  Wm.Rd.with_resp_headers
    (fun h -> Cohttp.Header.replace h "content_type"
       (Ldp.Ct.to_string ct))
    rd

let graph_of_request document_loader ~body rd iri =
  let g = Rdf.Graph.open_graph iri in
  let ct = content_type_of_rd rd in
  try%lwt
    match ct with
    | _ when Ldp.Ct.has_mime ct Ldp.Ct.mime_turtle ->
        Rdf.Ttl.from_string g body ;
        Lwt.return_ok (g, None)
    | _ when Ldp.Ct.has_mime ct Ldp.Ct.mime_xmlrdf ->
        Rdf.Xml.from_string g body ;
        Lwt.return_ok (g, None)
    | _ when Ldp.Ct.has_mime ct mime_nquads ->
        let ds = Rdf.Ds.mem_dataset g in
        Rdf.Nq.from_string ds body ;
        Lwt.return_ok (ds.default, None)
    | _ when Ldp.Ct.has_mime ct mime_jsonld ||
          Ldp.Ct.has_mime ct mime_ap ->
        let options = Rdf_json_ld.T.options document_loader (* FIXME: pass actor to doc loader *) in
        let json =
          match Rdf_json_ld.J.from_string body with
          | Ok json -> json
          | Error (range, e) ->
              failwith (Rdf_json_ld.J.string_of_error range e)
        in
        let%lwt (ds, root) = Rdf_json_ld.Json_ld.to_rdf options json g in
        Lwt.return_ok (ds.default, root)
    | _ ->
        Lwt.return_error
          (`Msg (Printf.sprintf "Unsupported format: %s" (Ldp.Ct.to_string ct)))
  with e ->
      let msg = match e with
        | Failure msg -> msg
        | e -> Printexc.to_string e
      in
      let msg = Printf.sprintf "Invalid %s: %s\nbody:%s" (Ldp.Ct.to_string ct) msg body in
      Lwt.return_error (`Msg msg)
(*
module Make (Fs:Server_fs.Fs) (Acl:Server_acl.Acl) =
  struct
    let path_to_patch path =
      match Server_fs.kind path with
        `Acl _ | `Meta _ -> Lwt.return path
      | `Dir | `Unknown | `UnknownDir -> Lwt.return (Server_fs.meta_path path)
      | `File ->
          match%lwt Fs.path_mime path with
          | mime when is_handled_rdf_mime mime -> Lwt.return path
          | _ -> Lwt.return (Server_fs.meta_path path)

    let apply_patch path str =
      let query =  Rdf.Sparql.query_from_string str in
      let%lwt graph_path =
        match Server_fs.kind path with
          `Dir | `Unknown | `UnknownDir -> Lwt.return (Server_fs.meta_path path)
        | `File ->
            begin
              match%lwt Fs.path_mime path with
              | mime when is_handled_rdf_mime mime -> Lwt.return path
              | _ -> Lwt.return (Server_fs.meta_path path)
            end
        | _ -> Lwt.return path
      in
      let%lwt graph =
        match%lwt Fs.read_path_graph graph_path with
          None -> Lwt.return (Rdf.Graph.open_graph (Server_fs.iri graph_path))
        | Some g -> Lwt.return g
      in
      match Rdf.Sparql.execute_update ~graph query with
        Rdf.Sparql.Bool b ->
          let%lwt written = Fs.store_path_graph graph_path graph in
          Lwt.return (b && written)
      | _ -> assert false
*)

let write_body rd oc =
  Cohttp_lwt.Body.write_body
    (Lwt_io.write oc) rd.Wm.Rd.req_body

module Make (O:Object.T) (A:Actor.T) =
  struct
    module rec D : Delivery.T = Delivery.Make (O)(A)(PIn)
    and POut : Process.T = Process.Make(O)(A)(Process_out.Make(O)(A)(D))
    and PIn : Process.T = Process.Make(O)(A)(Process_in.Make(O)(A)(POut))

    let conf = O.conf

    let body_of_rd rd =
      let%lwt body = Cohttp_lwt.Body.to_string rd.Wm.Rd.req_body in
      Lwt.return body

    let actor_of_key_id str =
      match Iri.of_string str with
      | iri ->
          let actor = A.get (Iri.with_fragment iri None) in
          let%lwt () = actor#dereference in
          Lwt.return_ok actor
      | exception e ->
          Lwt.return_error (`Msg (Printexc.to_string e))

    class virtual base =
      object(self)
        inherit [Cohttp_lwt.Body.t] Wm.resource

        val mutable iri = None
        method private iri rd =
          match iri with
          | Some i -> i
          | None ->
              let s = Uri.to_string rd.Webmachine.Rd.uri in
              Log.debug(fun m -> m "self#iri: s=%s" s);
              let root_iri = Iri.(with_path conf.root_iri (Absolute [])) in
              let s = Iri.to_string root_iri ^ s in
              let i = Iri.of_string s in
              iri <- Some i ;
              i

        (* we must cache the body, as reading it with Cohttp_lwt.Body.to_string
           may empty it if it is a stream. *)
        val mutable req_body = None
        method private req_body rd =
          match req_body with
          | Some str -> Lwt.return str
          | None ->
              let%lwt str = body_of_rd rd in
              req_body <- Some str ;
              Lwt.return str

        (* the user is the issuer of the query *)
        val mutable user = None
        method private user rd =
          match user with
          | Some u -> Lwt.return u
          | None ->
              let headers = rd.Wm.Rd.req_headers in
              (*Log.debug (fun m -> m "#user headers=%s" (Cohttp.Header.to_string rd.Wm.Rd.req_headers));*)
              let%lwt from_server =
                let iri = self#iri rd in
                let uri = Uri.of_string (Iri.to_uri iri) in
                let req = Cohttp.Request.make
                  ~version:rd.Wm.Rd.version
                    ~meth:rd.Wm.Rd.meth
                    ~headers
                    uri
                in
                let actor = ref None in
                let map_key_id str =
                  match%lwt actor_of_key_id str with
                  | Error e -> Lwt.return_error e
                  | Ok a ->
                      actor := Some a ;
                      match a#public_keypem with
                      | None ->
                          (*let%lwt body = self#req_body rd in
                          Log.info (fun m -> m "fake user's query content: %s" body);*)
                          let msg = Printf.sprintf "No public key for %s" str in
                          Lwt.return_error (`Msg msg)
                      | Some key -> Lwt.return_ok key
                in
                let%lwt body = self#req_body rd in
                match%lwt AP.Http_sign.verify_request ~map_key_id req body with
                | None
                | Some false -> Lwt.return_none
                | Some true -> Lwt.return !actor
              in
              let%lwt u = match from_server with
                | Some actor -> Lwt.return_some (`Server actor)
                | None ->
                    match Cohttp.Header.get headers "authorization" with
                    | None -> Lwt.return_none
                    | Some str ->
                        Log.debug (fun m -> m "authorization in header: %s" str);
                        match AP.Token.auth_token_of_string str with
                        | Error msg ->
                            Log.err (fun m -> m "%s" msg);
                            Lwt.return_none
                        | Ok { actor ; key } ->
                            let iri = A.local_actor_iri actor in
                            let a = A.get iri in
                            let%lwt tokens = A.tokens actor in
                            if List.exists (fun (t:AP.Token.t) -> t.key = key) tokens then
                              Lwt.return_some (`Client a)
                            else
                              (
                               Log.warn (fun m -> m "unknown token %S for %S" key actor);
                               Lwt.return_none
                              )
              in
              user <- Some u ;
              Lwt.return u

        method private actor rd =
          match%lwt self#user rd with
          | Some (`Client a | `Server a) -> Lwt.return_some a
          | None -> Lwt.return_none

        (*method generate_etag rd =
        let accept = Cohttp.Header.get rd.Wm.Rd.req_headers "accept" in
        let%lwt opt = Fs.path_etag ?accept path in
        Wm.continue opt rd*)

        (*method last_modified rd =
          let%lwt opt = Fs.path_last_modified path in
          let%lwt () = Server_log._debug_lwt (fun m ->
               m "Last modified for %s: %s"
                 (Iri.to_string (Server_fs.iri path))
                 (match opt with None -> "" | Some s -> s)
            )
          in
          Wm.continue opt rd
          *)
        method resource_exists rd =
          let (exists, rd) = false, error_rd rd "Not found" "Ressource does not exist" in
          Wm.continue exists rd

        method previously_existed rd = Wm.continue false rd

            (* method options rd : ((string * string) list, 'body) op
               see also https://github.com/solid/solid/issues/45 *)

        val mutable allowed_methods = None

        method known_methods rd =
          Wm.continue
            [ `GET ; `OPTIONS ; `HEAD; `POST ;`PUT ; `DELETE ; `PATCH ]
            rd

        method allowed_methods rd =
          let%lwt mets =
            match allowed_methods with
            | None ->
                let%lwt mets =
                  let o = O.of_iri (self#iri rd) in
                  let%lwt () = o#dereference in
                  let%lwt actor = self#actor rd in
                  let b = O.can_read_object ?actor o in
                  Log.debug (fun m -> m "#allowed_methods iri=%a can_read_object actor=%s: %b"
                     Iri.pp o#iri (match actor with None -> "None" | Some a -> Iri.to_string a#iri)
                       b);
                  match b with
                  | false -> Lwt.return []
                  | true -> Lwt.return [ `GET ; `OPTIONS ; `HEAD ]
                in
                allowed_methods <- Some mets ;
                Lwt.return mets
            | Some l -> Lwt.return l
          in
          Log.debug
            (fun f -> f "Allowed methods: %s"
               (String.concat ", "
                (List.map Cohttp.Code.string_of_method mets)));
          Wm.continue mets rd

        (*method is_authorized rd = Wm.continue `Authorized rd*)
        (*method forbidden rd = Wm.continue false rd *)

        method allow_missing_post rd =
          Wm.continue true rd

        method malformed_request rd =
          Wm.continue false rd

          (** [`POST] requests will call this method. Returning true indicates the
             POST succeeded. *)
        method process_post rd =
          Wm.continue false rd

        (* method delete_resource rd =
        let%lwt deleted = Fs.delete_path path in
        Wm.continue deleted rd*)

        method private to_raw rd path =
          (* FIXME: improve this with a stream body *)
          let%lwt str = Lwt_io.(with_file ~mode:Input path read) in
          let body = `String str in
          let rd = { rd with Wm.Rd.resp_body = body } in
          Wm.continue body rd

        method private virtual graph : Cohttp_lwt.Body.t Webmachine.Rd.t -> Rdf.Graph.graph option Lwt.t

        method private to_graph f rd =
          let%lwt body = match%lwt self#graph rd with
            | None -> Lwt.return ""
            | Some g -> Lwt.return (f g)
          in
          (*Log.debug (fun m -> m "to_graph (%a):\n%s" Iri.pp (self#iri rd) body);*)
          Wm.continue (`String body) rd

        method private to_xmlrdf rd =
          self#to_graph Rdf.Xml.to_string rd
        method private to_ttl rd =
          self#to_graph Rdf.Ttl.to_string rd
        method private to_nquads rd =
          self#to_graph Rdf.Nq.graph_to_string rd
        method private to_jsonld rd =
          let%lwt actor = self#actor rd in
          let f g = O.graph_root_to_jsonld_string ?actor g (Rdf.Term.Iri (self#iri rd)) in
          self#to_graph f rd
        method private to_xhtml rd = Lwt.return []
        method private to_xhtml_ rd =
          let%lwt xmls = self#to_xhtml rd in
          let body = Xtmpl.Rewrite.to_string xmls in
          Wm.continue (`String body) rd

        method finish_request rd =
          let module H = Cohttp.Header in
          let%lwt rd =
            let h = rd.resp_headers in
            let origin =
              match Cohttp.Header.get rd.Wm.Rd.req_headers "origin" with
              | None -> "*"
              | Some str -> str
            in
            let allowed_mets =
              match allowed_methods with
              | None -> ""
              | Some mets ->
                  String.concat ","
                    (List.map Cohttp.Code.string_of_method mets)
            in
            let h = H.add h "Access-Control-Allow-Origin" origin in
            let h = H.add h "Access-Control-Allow-Methods" allowed_mets in
            let h =
              match H.get rd.Wm.Rd.req_headers "access-control-request-headers" with
              | None -> h
              | Some s -> H.add h "Access-Control-Allow-Headers" s
            in
            let h = H.add h "Access-Control-Allow-Credentials" "true" in
            let h = H.add h
              "Access-Control-Expose-Headers"
                "User, Location, Link, Vary, Last-Modified, Content-Length, Accept-Patch, Accept-Post, Allow"
            in
            let h = H.add_unless_exists h "Allow" allowed_mets in
            let%lwt h =
              match%lwt self#user rd with
              | None
              | Some (`Server _) -> Lwt.return h
              | Some (`Client a) ->
                  let h = H.add h "user" (Iri.to_string a#iri) in
                  Lwt.return h
            in
            Lwt.return { rd with resp_headers = h }
          in
          Wm.continue () rd
      end

    class actor =
      object(self)
        inherit base
        val mutable actor_name = None
        val mutable graph = None
        method private actor_name rd =
          match actor_name with
          | Some s -> s
          | None ->
              match Wm.Rd.lookup_path_info "actor" rd with
              | Some s -> actor_name <- Some s; s
              | None -> AP.E.error Missing_actor

        method private graph rd =
          match graph with
          | Some g -> Lwt.return g
          | None ->
              let name = self#actor_name rd in
              let iri = A.local_actor_iri name in
              match%lwt A.local_dereference iri with
              | Ok (g, _) -> graph <- Some (Some g); Lwt.return_some g
              | Error e ->
                  Log.warn (fun m -> m "could not read graph for actor %S: %a" name AP.E.pp e);
                  graph <- Some None;
                  Lwt.return_none

        method resource_exists rd =
          let%lwt (exists, rd) =
            match%lwt self#graph rd with
            | None -> Lwt.return (false, error_rd rd "Not found" "Ressource does not exist")
            | Some _ -> Lwt.return (true, rd)
          in
          Wm.continue exists rd

        method! private to_xhtml rd =
          match%lwt self#graph rd with
          | None -> Lwt.return []
          | Some g ->
              let page_number =
                let i = self#iri rd in
                match Option.map int_of_string (Iri.query_opt i "page") with
                | exception _ -> None
                | x -> x
              in
              let name = self#actor_name rd in
              let iri = A.local_actor_iri name in
              let a = A.get ~g iri in
              Html.page_of_actor ?page_number (module O) (module A) a iri

        method content_types_provided rd =
          let l =
            [
              Ldp.Ct.mime_xmlrdf, self#to_xmlrdf ;
              Ldp.Ct.mime_turtle, self#to_ttl ;
              mime_nquads, self#to_nquads ;
              mime_jsonld, self#to_jsonld ;
              mime_ap, self#to_jsonld ;
              Ldp.Ct.mime_xhtml, self#to_xhtml_ ;
            ]
          in
          let l = List.map (fun (m, f) -> (Ldp.Ct.mime_to_string m, f)) l in
          Wm.continue l rd

        method content_types_accepted rd =
          Wm.continue [] rd
      end

    class object_ =
      object(self)
        inherit base
        val mutable object_ = (None : O.o_ option option)
        method private object_ rd =
          match object_ with
          | Some o -> Lwt.return o
          | None ->
              let iri = self#iri rd in
              Log.debug (fun m -> m "Machine.object_#object iri=%a" Iri.pp iri);
              let%lwt actor = self#actor rd in
              match%lwt O.local_dereference ?actor iri with
              | Ok (g, _) ->
                  let id = Rdf.Term.Iri iri in
                  let o = O.get ?actor ~g id in
                  (* FIXME: check if user has right to see this object *)
                  (* TODO: dereference local objects, except actors *)
                  let o =
                    (* remove bto and bcc fields except if object is attributed to user *)
                    match actor, o#attributed_to with
                     | Some a, Some lo when Rdf.Term.equal a#id (AP.Object.id_of_link_or_object lo) -> o
                     | _ ->
                        AP.Object.remove_bto_bcc g;
                        let g = AP.Utils.graph_keep_only_from
                          ~keep:(fun _ -> true) (*O.is_local_iri*) g id
                        in
                        O.get ?actor ~g id
                  in
                  object_ <- Some (Some o); Lwt.return_some o
              | Error e ->
                  Log.warn (fun m -> m "could not read graph: %a" AP.E.pp e);
                  object_ <- Some None;
                  Lwt.return_none

        method private graph rd =
          match%lwt self#object_ rd with None -> Lwt.return_none | Some o -> Lwt.return o#g

        method resource_exists rd =
          let%lwt (exists, rd) =
            match%lwt self#object_ rd with
            | None -> Lwt.return (false, error_rd rd "Not found" "Ressource does not exist")
            | Some _ -> Lwt.return (true, rd)
          in
          Wm.continue exists rd

        method content_types_provided rd =
          let l =
            [
              Ldp.Ct.mime_xmlrdf, self#to_xmlrdf ;
              Ldp.Ct.mime_turtle, self#to_ttl ;
              mime_nquads, self#to_nquads ;
              mime_jsonld, self#to_jsonld ;
              mime_ap, self#to_jsonld ;
            ]
          in
          let l = List.map (fun (m, f) -> (Ldp.Ct.mime_to_string m, f)) l in
          Wm.continue l rd

        method content_types_accepted rd =
          Wm.continue ["*/*", (fun rd -> Wm.continue true rd)] rd
      end

    class virtual collection =
      object(self)
        inherit object_
        val mutable posted_graph = None
        method private posted_graph rd =
          match posted_graph with
          | Some None -> Lwt.return_none
          | Some x -> Lwt.return x
          | None ->
              let%lwt actor = self#actor rd in
              let%lwt body = self#req_body rd in
              let%lwt res =
                match%lwt graph_of_request (O.jsonld_document_loader ?actor) ~body rd (self#iri rd) with
                | Error (`Msg msg) ->
                    Log.debug (fun m -> m "%s" msg);
                    Lwt.return_none
                | Ok (g,root) ->
                    let root =
                      match root with
                      | None ->
                          (match AP.Object.graph_roots g with
                           | [] ->
                               Log.debug (fun m -> m "no graph root");
                               None
                           | (_ :: _ :: _) as roots ->
                               Log.debug (fun m -> m "graph has more than one root:\n%s\ngraph=%s\nbody=%s"
                                  (String.concat "\n" (List.map Rdf.Term.string_of_term roots))
                                    (Rdf.Ttl.to_string g) body
                               );
                               None
                           | [root] -> Some root
                          )
                      | Some x -> Some (Rdf.Term.Iri x)
                    in
                    match root with
                    | None -> Lwt.return_none
                    | Some root ->
                        let types = Rdf.Graph.iri_objects_of g ~sub:root ~pred:Rdf.Rdf_.type_ in
                        if types = [] then
                          Log.debug (fun m -> m "node %a has no type" Rdf.Term.pp_term root );
                        let%lwt user = self#actor rd in
                        if self#accept_graph ?user g root types then
                          (
                           Lwt.return_some (g, root, types)
                          )
                        else
                          Lwt.return_none
              in
              posted_graph <- Some res;
              Lwt.return res

        method virtual private accept_graph : ?user:AP.Types.actor -> Rdf.Graph.graph -> Rdf.Term.term -> Iri.t list -> bool

        method! malformed_request rd =
          match rd.Wm.Rd.meth with
          | `POST ->
              (match%lwt self#posted_graph rd with
               | None -> Wm.continue true rd
               | Some _ -> Wm.continue false rd
              )
          | _ -> Wm.continue false rd
      end

    class actor_inbox =
      object(self)
        inherit actor as super
        inherit! collection as obj
        method private accept_graph ?user g root types =
          match user with
          | None -> false
          | Some user ->
              (* check that graph is an activity *)
              let b = List.exists AP.Object.is_activity types in
              Log.debug (fun m -> m "#accept_graph %a: %b" Rdf.Term.pp_term root b);
              (* check user is the actor of the activity *)
              match b with
              | false -> false
              | true ->
                  let acti = O.get ~g root in
                  match acti#as_activity#actor with
                  | None -> false
                  | Some lo ->
                      let actor_iri = AP.Types.iri_of_lo lo in
                      Iri.equal user#iri actor_iri

        method! allowed_methods rd =
          let%lwt () =
            let%lwt mets =
              match%lwt self#user rd with
              | None ->
                  Log.debug (fun m ->  m "inbox#allowed_methods for %a: no user" Iri.pp (self#iri rd));
                  Lwt.return []
              | Some u ->
                  let actor_name = self#actor_name rd in
                  let a = A.get (A.local_actor_iri actor_name) in
                  match u with
                  | `Client user ->
                      Log.debug (fun m -> m "client user: %a, actor: %a" Iri.pp user#iri Iri.pp a#iri);
                      if Iri.equal user#iri a#iri then
                        Lwt.return [ `GET ; `OPTIONS ; `HEAD ]
                      else
                        Lwt.return []
                  | `Server user ->
                      Log.debug (fun m -> m "server user: %a, actor: %a" Iri.pp user#iri Iri.pp a#iri);
                      (* depends on activity: accept must be accepted, and follow too *)
                      (* if actor follows user, then user can post;
                         FIXME: also check that user in not blocked by actor
                         FIXME: relax to allow post from users that the actor does not follow *)
                      let%lwt ok =
                        match%lwt self#posted_graph rd with
                        | None -> Lwt.return_false
                        | Some (g, root, type_ :: _) ->
                            Log.debug (fun m -> m "inbox: activity type: %a" Iri.pp type_);
                            (match AP.Types.activity_type_of_iri type_ with
                             | Some `Follow
                             | Some `Accept
                             | Some `Reject -> Lwt.return_true
                             | _ -> A.actor_follows_user ~actor:a ~user:user#iri
                            )
                        | _ -> Lwt.return_false
                      in
                      if ok then
                        Lwt.return [ `POST ]
                      else
                        Lwt.return []
            in
            (*Log.debug (fun m -> m "#allowed_methods for %a: %s" Iri.pp (self#iri rd)
               (String.concat ", "
                (List.map Cohttp.Code.string_of_method mets)));*)
            allowed_methods <- Some mets;
            Lwt.return_unit
          in
          super#allowed_methods rd

        method process_post rd =
          Log.debug (fun m -> m "inbox#process_post");
          match%lwt self#posted_graph rd with
          | None -> Wm.continue false rd
          | Some (g, orig_id,  types) ->
              Log.debug (fun m -> m "inbox#process_post: g.name=%a\ng=%s"
                 Iri.pp (g.Rdf.Graph.name()) (Rdf.Ttl.to_string g));
              let actor = A.get (A.local_actor_iri (self#actor_name rd)) in
              let (id, iri) = AP.Types.gen_id (self#iri rd) in
              (* rename root node of graph with local iri + add id alias *)
              let g = AP.Object.map_graph
                (fun t -> if Rdf.Term.equal t orig_id then id else t) g
              in
              g.add_triple ~sub:id ~pred:AS.id ~obj:orig_id ;
              let acti = O.of_iri ~g iri in
              Log.debug (fun m -> m "inbox#process_post: acti type=%a" Iri.pp acti#type_);
              match%lwt O.local_collection (self#iri rd) with
              | Error (`Msg msg) ->
                  Log.err (fun m -> m "%s" msg);
                  Wm.continue false rd
              | Ok col ->
                  Option.iter (fun g ->
                     Log.debug (fun m -> m "inbox#process_post activity graph: %s" (Rdf.Ttl.to_string g)))
                    acti#g;
                  match%lwt PIn.process ~actor acti#as_activity with
                  | Error (code, `Msg msg) when code / 100 = 4 ->
                      Log.warn (fun m -> m "[%d]Bad request: %s" code msg);
                      Wm.respond  ~body:(Cohttp_lwt.Body.of_string msg) code rd
                  | Error (code, `Msg msg) ->
                      Log.err (fun m -> m "[%d]Internal error: %s" code msg);
                      Wm.respond code rd
                  | Ok false -> Wm.continue true rd
                  | Ok true ->
                      match%lwt col#add_item (Rdf.Term.Iri iri) with
                      | Ok () ->
                          let rd = rd_set_location rd iri in
                          Wm.continue true rd
                      | Error (`Msg msg) ->
                          Log.err (fun m -> m "While adding %a: %s" Iri.pp iri msg);
                          Wm.continue false rd

        initializer
          Log.debug (fun m -> m "inbox resource");
      end

    class actor_outbox =
      object(self)
        inherit actor as super
        inherit! collection as obj
        method private accept_graph ?user _ _ _ = true
        method! allowed_methods rd =
          let%lwt () = match%lwt self#user rd with
           | None -> Lwt.return_unit
           | Some (`Server _) -> Lwt.return_unit
           | Some (`Client user) ->
               let actor_name = self#actor_name rd in
               let a = A.get (A.local_actor_iri actor_name) in
               Log.debug (fun m -> m "client user: %a, actor: %a" Iri.pp user#iri Iri.pp a#iri);
               let mets =
                  let base = [ `GET ; `OPTIONS ; `HEAD ] in
                  if Iri.equal user#iri a#iri then
                    base @ [`POST]
                  else
                    base
                in
                allowed_methods <- Some mets ;
                Lwt.return_unit
          in
          super#allowed_methods rd

        (* FIXME: copy addesses from activity to object then from object to activity,
               as stated here : https://www.w3.org/wiki/ActivityPub/Primer/Copying_addresses_between_Activity_and_object *)
        method private embed_in_create ~id ~iri g root =
          let o = O.get ~g root in
          let _ = AP.Object.copy_addresses ~src:o ~dst:g ~dstid:id in
          g.add_triple ~sub:id ~pred:AS.object_ ~obj:root ;
          g.add_triple ~sub:id ~pred:Rdf.Rdf_.type_ ~obj:(Rdf.Term.Iri AS.c_Create) ;
          O.get ~g id

        method private add_missing_info ~actor (act:AP.Types.activity) =
          let act_g = match act#g with
            | None -> failwith "add_missing_info: no graph for activity"
            | Some g -> g
          in
          act_g.Rdf.Graph.add_triple ~sub:act#id ~pred:AS.actor ~obj:actor#id ;
          let obj =
            match act#object_ with
            | None -> None
            | Some obj ->
                match obj#g with
                | None ->
                    Log.warn (fun m -> m "add_missing_info: no graph for object_");
                    None
                | Some g ->
                    g.Rdf.Graph.add_triple ~sub:obj#id ~pred:AS.attributedTo ~obj:actor#id ;
                    Some (obj, g)
          in
          let () =
            match act#published, obj with
            | None, None ->
                act_g.add_triple ~sub:act#id ~pred:AS.published ~obj:(Rdf.Term.term_of_datetime ())
            | None, Some (obj, obj_g) ->
                (match obj#published with
                 | Some d ->
                     act_g.add_triple ~sub:act#id ~pred:AS.published ~obj:(Rdf.Term.term_of_datetime ~d ())
                 | None ->
                     let d = Rdf.Term.term_of_datetime () in
                     act_g.add_triple ~sub:act#id ~pred:AS.published ~obj:d;
                     obj_g.add_triple ~sub:obj#id ~pred:AS.published ~obj:d
                )
            | Some d, None -> ()
            | Some d, Some (obj, obj_g) ->
                (match obj#published with
                 | Some _ -> ()
                 | None ->
                     obj_g.add_triple ~sub:obj#id ~pred:AS.published ~obj:(Rdf.Term.term_of_datetime ~d ())
                )
          in
          ()

        (* concretly create object in store and return new activity object,
           updated with IRI object. *)
        method private create_object acti rd =
          match acti#as_activity#object_ with
          | None ->
              Log.err (fun m -> m "no object for Create or Add activity");
              Lwt.return (O.of_object acti#as_object)
          | Some obj ->
              match acti#g with
              | None -> failwith "No graph for activity ?!?"
              | Some g ->
                  (* give id to object,
                     rename object's term in a new graph,
                     and create activity object from new graph *)
                  let%lwt g =
                    let (id, iri) =
                      let dir = A.objects_dir (self#actor_name rd) in
                      AP.Types.gen_id (O.iri_of_dir dir)
                    in
                    let g = AP.Object.map_graph
                      (fun t -> if Rdf.Term.equal t obj#id then id else t) g
                    in
                    Lwt.return g
                  in
                  Lwt.return (O.get ~g acti#id)

        (** [`POST] requests will call this method. Returning true indicates the
             POST succeeded. *)
        method process_post rd =
          Log.debug (fun m -> m "outbox#process_post");
          match%lwt self#posted_graph rd with
          | None -> Wm.continue false rd
          | Some (g, root,  types) ->
              Log.debug (fun m -> m "process_post: g.name=%a\ng=%s" Iri.pp (g.Rdf.Graph.name())
                 (Rdf.Ttl.to_string g));
              let actor = A.get (A.local_actor_iri (self#actor_name rd)) in
              let acti, iri =
                let (id, iri) = AP.Types.gen_id (self#iri rd) in
                let g = { g with name = (fun () -> iri) } in
                (*Log.debug (fun m -> m "graph: %s" (Rdf.Ttl.to_string g));*)
                if List.exists AP.Object.is_activity types then
                  let g = AP.Object.map_graph
                    (fun t -> if Rdf.Term.equal t root then id else t)
                      g
                  in
                  O.get ~actor ~g id, iri
                else
                  self#embed_in_create ~id ~iri g root, iri
              in
              self#add_missing_info actor acti#as_activity ;
              let%lwt acti =
                match acti#type_ with
                | iri when Iri.equal iri AS.c_Create || Iri.equal iri AS.c_Add ->
                    self#create_object acti rd
                | _ -> Lwt.return acti
              in
              match%lwt O.local_collection (self#iri rd) with
              | Error (`Msg msg) ->
                  Log.err (fun m -> m "%s" msg);
                  Wm.continue false rd
              | Ok col ->
                  Option.iter (fun g -> Log.debug
                     (fun m -> m "outbox#process_post: activity graph: %s" (Rdf.Ttl.to_string g)))
                    acti#g;
                  match%lwt POut.process ~actor acti#as_activity with
                  | Error (code, `Msg msg) when code / 100 = 4 ->
                      Log.warn (fun m -> m "[%d]Bad request: %s" code msg);
                      Wm.respond ~body:(Cohttp_lwt.Body.of_string msg) code rd
                  | Error (code, `Msg msg) ->
                      Log.err (fun m -> m "[%d]Internal error: %s" code msg);
                      Wm.respond code rd
                  | Ok false -> Wm.continue true rd
                  | Ok true ->
                      match%lwt col#add_item (Rdf.Term.Iri iri) with
                      | Ok () ->
                          let rd = rd_set_location rd iri in
                          Wm.continue true rd
                      | Error (`Msg msg) ->
                          Log.err (fun m -> m "While adding %a: %s" Iri.pp iri msg);
                          Wm.continue false rd

        method content_types_accepted rd =
          match rd.Wm.Rd.meth with
          | `POST ->
              let accepted_ct =
                [
                  Ldp.Ct.mime_xmlrdf ;
                  Ldp.Ct.mime_turtle ;
                  mime_nquads ;
                  mime_jsonld ;
                  mime_ap
                ]
              in
              Wm.continue
                (List.map (fun ct -> (Ldp.Ct.mime_to_string ct, self#process_post)) accepted_ct)
                rd
          | _ -> Wm.continue [] rd

        initializer
          Log.debug (fun m -> m "outbox resource");
      end

    class not_found =
      object(self)
        inherit base
        method private graph rd = Lwt.return_none
        method content_types_accepted rd =
          let iri = self#iri rd in
          Log.debug (fun m -> m "#not_found iri = %s" (Iri.to_string iri)) ;
          Wm.continue [] rd
        method content_types_provided rd =
          let iri = self#iri rd in
          Log.debug (fun m -> m "#not_found iri = %s" (Iri.to_string iri)) ;
          Wm.continue [] rd
        method resource_exists rd =
          let iri = self#iri rd in
          let msg = Printf.sprintf "Ressource %s does not exist" (Iri.to_string iri) in
          Log.debug (fun m -> m "%s" msg);
          let (exists, rd) = false, error_rd rd  "Not found" msg in
          Wm.continue exists rd
      end

    class webfinger =
      object(self)
        inherit base
        method private graph _ = Lwt.return_none
        val mutable resource = (None : (string * AP.Types.actor) option option)
        method private resource rd =
          match resource with
          | Some x -> Lwt.return x
          | None ->
              let s = Uri.to_string rd.Webmachine.Rd.uri in
              let iri = Iri.of_string s in
              match Iri.query_opt iri "resource" with
              | None -> resource <- Some None; Lwt.return_none
              | Some s_res ->
                  let actor_name =
                    try
                      let i = Iri.of_string s_res in
                      match Iri.scheme i with
                      | "acct" ->
                          (match Iri.user i, Iri.host i with
                           | None, _ | _, None -> None
                           | Some u, Some h ->
                               let h = String.lowercase_ascii h in
                               let h2 = Option.value ~default:""
                                 (Option.map String.lowercase_ascii (Iri.host O.conf.root_iri))
                               in
                               if h <> h2 then
                                 None
                               else
                                 Some (s_res, u)
                          )
                      | _ -> None
                    with
                    | _ -> None
                  in
                  match actor_name with
                  | None ->
                      Log.debug (fun m -> m "webfinger: invalid resource %S" s);
                      resource <- Some None;
                      Lwt.return_none
                  | Some (s_res, name) ->
                      Log.debug (fun m -> m "webfinger: querying actor %S" name);
                      let actor_iri = A.local_actor_iri name in
                      let%lwt a =
                        match%lwt A.local_dereference actor_iri with
                        | Ok (g, _) -> Lwt.return_some (s_res, A.get ~g actor_iri)
                        | Error e ->
                            Log.debug (fun m -> m "webfinger: actor %S: %s" name
                               (AP.E.string_of_error e));
                            Lwt.return_none
                      in
                      resource <- Some a;
                      Lwt.return a

        method! resource_exists rd =
          let%lwt (exists, rd) =
            match%lwt self#resource rd with
            | None -> Lwt.return (false, error_rd rd "Not found" "Ressource does not exist")
            | Some _ -> Lwt.return (true, rd)
          in
          Log.debug (fun m -> m "webfinger %a: #resource_exists: %b" Iri.pp (self#iri rd) exists);
          Wm.continue exists rd

        method! allowed_methods rd = Wm.continue [`GET ; `HEAD] rd

        method private to_json rd =
          match%lwt self#resource rd with
            | None -> Wm.continue (`String "Ressource does not exist") rd
            | Some (s_res, a) ->
              let json =
                `Assoc [
                  "subject", `String s_res ;
                  "aliases", `List [ `String (Iri.to_string a#iri) ] ;
                  "links", `List [
                    `Assoc [
                      "rel", `String "self" ;
                      "type", `String "application/activity+json" ;
                      "href", `String (Iri.to_string a#iri) ;
                    ]
                  ]
                ]
              in
              let body = Yojson.Safe.pretty_to_string json in
              Log.debug (fun m -> m "webfinger#to_json: %s" body);
              Wm.continue (`String body) rd

        method content_types_provided rd =
          let l = [ mime_jrd_json, self#to_json ] in
          let l = List.map (fun (m, f) -> (Ldp.Ct.mime_to_string m, f)) l in
          Wm.continue l rd

        method content_types_accepted rd = Wm.continue [] rd

        initializer
          Log.debug (fun m -> m "webfinger query");
      end

    class media =
      object(self)
        inherit base
        val mutable resource = (None : (string * Media.info) option option)
        method private graph rd = Lwt.return_none
        method private resource rd =
          match resource with
          | Some x -> Lwt.return x
          | None ->
              let iri = self#iri rd in
              let%lwt v =
                match O.media_path_of_iri iri with
                | None -> Lwt.return_none
                | Some path ->
                    match%lwt Media.info path with
                    | None -> Lwt.return_none
                    | Some i -> Lwt.return_some (path, i)
              in
              resource <- Some v;
              Lwt.return v

        method! resource_exists rd =
          let%lwt (exists, rd) =
            match%lwt self#resource rd with
            | None -> Lwt.return (false, rd)
            | Some _ -> Lwt.return (true, rd)
          in
          Wm.continue exists rd

        method! allowed_methods rd =
          let mets = [`GET ; `HEAD] in
          let%lwt mets =
            match conf.media_path with
            | None -> Lwt.return mets
            | Some _ ->
                match%lwt self#user rd with
                | Some (`Client _) -> Lwt.return (`POST :: mets)
                | _ -> Lwt.return mets
          in
          Wm.continue mets rd

        method private to_content rd =
          match%lwt self#resource rd with
            | None -> Wm.continue (`String "Ressource does not exist") rd
            | Some (path, i) ->
              match%lwt Media.get path with
              | None -> Wm.continue (`String "") rd
              | Some body -> Wm.continue (`String body) rd

        method private empty_content rd =  Wm.continue (`String "") rd
        method content_types_provided rd =
          let%lwt l =
            match%lwt self#resource rd with
            | None -> Lwt.return ["*/*", self#empty_content]
            | Some (_, i) -> Lwt.return [Ldp.Ct.mime_to_string i.Media.mime, self#to_content ]
          in
          Wm.continue l rd

        method process_post rd =
          Log.debug (fun m -> m "media#process_post");
          let%lwt data = self#req_body rd in
          match%lwt self#user rd with
          | None | Some (`Server _) -> Wm.continue false rd
          | Some (`Client actor) ->
              match O.gen_media_iri () with
              | None -> Wm.continue false rd
              | Some (iri, path) ->
                  let mime = Ldp.Ct.to_mime (content_type_of_rd rd) in
                  match%lwt Media.store_file ~actor:actor#iri ~mime ~path data with
                  | Error e ->
                      Log.err (fun m -> m "While adding %a: %s" Iri.pp iri (Printexc.to_string e));
                      Wm.continue false rd
                  | Ok () ->
                      let rd = rd_set_location rd iri in
                      Wm.continue true rd

        method content_types_accepted rd =
          Wm.continue ["*/*", (fun rd -> Wm.continue true rd)] rd

      end

    let run () =
      let%lwt () = D.init () in
      let webfinger_route = "/.well-known/webfinger" in
      Log.debug (fun m -> m "webfinger route: %s" webfinger_route);
      let route_base = Iri.path_string conf.root_iri in
      let public_route =
        let route = Printf.sprintf "%s%s"
          route_base (Conf.filename_from_root conf O.public_collection_dir)
        in
        Log.debug (fun m -> m "objects route: %s" route);
        route
      in
      let actor_route_ name f_dir =
        let route = Printf.sprintf "%s%s"
          route_base (Conf.filename_from_root conf (f_dir ":actor") )
        in
        Log.debug (fun m -> m "%s route: %s" name route);
        route
      in
      let actors_route = actor_route_ "actors"
        (fun s -> Printf.sprintf "%s/%s" A.actors_dir s)
      in
      let actor_inbox_route = actor_route_ "inbox" A.inbox_dir in
      let actor_outbox_route = actor_route_ "outbox" A.outbox_dir in
      let actor_objects_route = actor_route_ "objects" A.objects_dir in
(*      let objects_route =
        let route = Printf.sprintf "%s%s"
          route_base (Conf.filename_from_root conf O.objects_dir)
        in
        Log.debug (fun m -> m "objects route: %s" route);
        route
      in
*)
      let hidden_routes =
        List.map (fun r -> r, fun () -> new not_found)
          [ actor_route_ "private key" A.priv_key_file ;
            actor_route_ "tokens" A.tokens_file ;
          ]
      in
      let routes = hidden_routes @ [
          webfinger_route, (fun () -> new webfinger) ;
          public_route, (fun () -> new object_) ;
          public_route ^"/*", (fun () -> new object_) ;
          actors_route, (fun () -> new actor) ;
          actor_inbox_route, (fun () -> new actor_inbox );
          actor_outbox_route, (fun () -> new actor_outbox );
          actor_objects_route, (fun () -> new object_);
(*          actors_route ^ "/*/*", (fun () -> new object_) ;*)
          actors_route ^ "/*", (fun () -> new object_) ;
(*          objects_route ^ "/*", (fun () -> new object_) ;*)
(*          "/*", (fun () -> new not_found );*)
        ]
      in
      let%lwt routes =
        match conf.media_path, O.media_root_dir with
        | None, _ | _, None -> Lwt.return routes
        | Some (path,_), Some dir ->
            Log.debug (fun m -> m "media_path=%S, media_dir=%S" path dir);
            let%lwt () = AP.Utils.mkdir dir in
            Lwt.return (routes @ [
               path, (fun () -> new media) ;
               path ^ "/*", (fun () -> new media) ])
      in
      let callback request body =
        (*let s = request.Cohttp.Request.resource in
        Log.debug(fun m -> m "callback request=%s" s);*)
        let open AP.Cohttp_tls in
        try%lwt
          Wm.dispatch' routes ~body ~request
            >|= begin function
              | None        -> (`Not_found, Cohttp.Header.init (), `String "Not found", [])
              | Some result -> result
            end
            >>= fun (status, headers, body, path) ->
              if Cohttp.Code.(not (is_success (code_of_status status))) then
                Log.debug (fun m -> m "Decision path: %s" (String.concat ", " path));
              (* Finally, send the response to the client *)
              Server.respond ~headers ~body ~status ()
        with
        | e ->
            Log.err (fun m -> m "%s\n%s" (Printexc.to_string e) (Printexc.get_backtrace()));
            raise e
      in
      Log.info (fun m -> m "%s: running server on 0.0.0.0:%d"
         (Filename.basename Sys.argv.(0)) O.conf.Conf.https.port);
      Http_tls.server O.conf.Conf.https callback


end