seppo/lib/is2s.ml

(*
 *    _  _   ____                         _  
 *  _| || |_/ ___|  ___ _ __  _ __   ___ | | 
 * |_  ..  _\___ \ / _ \ '_ \| '_ \ / _ \| | 
 * |_      _|___) |  __/ |_) | |_) | (_) |_| 
 *   |_||_| |____/ \___| .__/| .__/ \___/(_) 
 *                     |_|   |_|             
 *
 * Personal Social Web.
 *
 * is2s.ml
 *
 * Copyright (C) The #Seppo contributors. All rights reserved.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * 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, see <http://www.gnu.org/licenses/>.
 *)

(** https://www.w3.org/TR/activitypub/#inbox *)
module Inbox = struct
  (** take a list of header names and fetch them incl. values. *)
  let hdrs hdr =
    List.fold_left
      (fun init k ->
         (match hdr k with
          | None   -> init
          | Some v -> Cohttp.Header.add init k v)
      )
      (Cohttp.Header.init ())

  (** Receive the post request, verify the signature, parse the json and dispatch *)
  let post
      ?(blocked = Mapcdb.Cdb "app/var/db/subscribed_to.cdb")
      ~base
      uuid
      now
      ic
      (r : Cgi.Request.t) : Cgi.Response.t' Lwt.t =
    let (let*%) = Http.(let*%) in
    let run_delay_s = 60 in
    let agent = Cgi.Request.hHTTP_USER_AGENT |> r.raw_string in
    Logr.debug (fun m -> m "%s.%s Host:%s User_Agent:'%s'" "Is2s.Inbox" "post" r.remote_addr (agent |> Option.value ~default:"-"));
    let*% si_v = "signature" |> Cgi.Request.header_get r |> Option.to_result ~none:Http.s422' in
    Logr.debug (fun m -> m "%s.%s %a Signature: %s" "Is2s.Inbox" "post" Uuidm.pp uuid si_v);
    (* Logr.debug (fun m -> m "%s.%s the signature header:\n%s" "Is2s.Inbox" "post" si_v); *)
    let*% si_v = si_v
                 |> Http.Signature.decode
                 |> Result.map_error
                   (function
                     | `NoMatch _
                     | `ConverterFailure _ ->
                       Logr.debug (fun m -> m "%s.%s Signature parsing failure" "Is2s.Inbox" "post");
                       Http.s422') in
    let*% algo    = si_v   |> List.assoc_opt "algorithm" |> Option.to_result ~none:Http.s422' in
    let*% heads   = si_v   |> List.assoc_opt "headers" |> Option.to_result ~none:Http.s422' in
    let   heads   = heads  |> String.split_on_char ' ' in
    let*% okeyid  = si_v   |> List.assoc_opt "keyId" |> Option.to_result ~none:Http.s422' in
    let   okeyid  = okeyid |> Uri.of_string in
    let*% sign    = si_v   |> List.assoc_opt "signature" |> Option.to_result ~none:Http.s422' in
    let   signature    = sign   |> Base64.decode_exn |> Cstruct.of_string in
    let   base    = base () in
    let*% pk      = Ap.PubKeyPem.(private_of_pem pk_pem) |> Result.map_error (fun s ->
        Logr.err (fun m -> m "%s %s.%s %s" E.e1009 "Is2s.Inbox" "post" s);
        Http.s500') in
    let   me      = Uri.make ~path:Ap.proj () |> Http.reso ~base in
    let   mekeyid = me |> Ap.Person.my_key_id in
    let   mekey   = Http.Signature.mkey mekeyid pk now in
    (* don't queue it but re-try in case *)
    (* dereferencing okeyid must yield an actor profile document. *)
    let%lwt siac = Ap.Actor.http_get ~key:(Some mekey) okeyid in
    let*% siac = siac
                 |> Result.map_error (fun e ->
                     Logr.warn (fun m -> m "%s.%s %a %s signed_by:%a %s" "Is2s.Inbox" "post" Uuidm.pp uuid "get" Uri.pp okeyid e);
                     Http.s502' ~body:(e |> Cgi.Response.body ~ee:E.e1048)) in
    let*% _ = match Ap.Following.is_blocked ~cdb:blocked siac.id with
      | As2.No_p_yes.Yes  ->
        Logr.debug (fun m -> m "%s.%s blocked from %a" "Is2s.Inbox" "post" Uri.pp siac.id);
        Http.s403
      | _  -> Ok ()
    in

    assert (not (me |> Uri.equal siac.id));
    let map_er0 msg =
      let mapr (`Msg e) =
        Logr.warn (fun m -> m "%s.%s %s %a %s %a" "Is2s.Inbox" "post" msg Uuidm.pp uuid e Uri.pp okeyid);
        Http.s422' in
      Result.map_error mapr in
    let*% key = Ap.PubKeyPem.of_pem siac.public_key.pem |> map_er0 "parse key" in
    (* TODO? compare the key to what we knew before from this actor *)
    let heads = heads |> hdrs (Cgi.Request.header_get r) in
    let tx = heads |> Http.Signature.to_sign_string0 ~request:None in
    Logr.debug (fun m -> m "%s.%s signature check '%s'" "Is2s.Inbox" "post" tx);
    let*% _ = tx
              |> Cstruct.of_string
              |> Ap.PubKeyPem.verify ~algo ~inbox:siac.inbox ~key ~signature
              |> map_er0 "verify signature" in
    (* now siac is the verified signing actor of this request *)

    let*% dig = Cohttp.Header.get heads "digest" |> Option.to_result ~none:Http.s422' in
    let*% cl = r.content_length |> Option.to_result ~none:Http.s411' in
    let*% cl = if cl <= Ap.content_length_max
      then Ok cl
      else Http.s413 in
    let bo = cl |> really_input_string ic in
    let dig' = Ap.PubKeyPem.digest_base64 bo in
    let*% _ = if dig' |> String.equal dig
      then Ok ()
      else (
        Logr.info (fun m -> m "%s.%s %a digest verification failed" "Is2s.Inbox" "post" Uuidm.pp uuid);
        Logr.debug (fun m -> m "%s.%s expected: %s" "Is2s.Inbox" "post" dig);
        Logr.debug (fun m -> m "%s.%s found   : %s" "Is2s.Inbox" "post" dig');
        Logr.debug (fun m -> m "%s.%s data    : %d {|%s|}" "Is2s.Inbox" "post" cl bo);
        Http.s422) in
    Logr.debug (fun m -> m "%s.%s %a verified body:\n%s" "Is2s.Inbox" "post" Uuidm.pp uuid bo);
    (* we could queue all further processing. *)
    let map_er1 msg =
      let mapr _ =
        Logr.warn (fun m -> m "%s.%s failed to %s %s" "Is2s.Inbox" "post.json" msg bo);
        Http.s422' in
      Result.map_error mapr in
    let*% j = bo |> Ezjsonm.from_string_result |> map_er1 "decode Json" in
    let*% (o : As2_vocab.Types.obj) = j |> As2_vocab.Activitypub.Decode.obj |> map_er1 "decode ActivityPub object" in
    (** gotosocial signing actors are lobotomised without an inbox and need to be replaced with a proper one. *)
    let ensure_inbox (ob : As2_vocab.Types.obj) (ibx : Uri.t) : (Uri.t, Cgi.Response.t) result Lwt.t =
      if ibx |> Uri.equal Uri.empty
      then (match (match ob with
          | `Accept o -> Some o.actor
          | `Create o -> Some o.actor
          | `Follow o -> Some o.actor
          | `Reject o -> Some o.actor
          | `Undo o   -> Some o.actor
          | `Update o -> Some o.actor
          | _ -> None) with
        | None -> Lwt.return (Ok Uri.empty)
        | Some okeyid ->
          let%lwt siac = Ap.Actor.http_get ~key:(Some mekey) okeyid in
          let*% siac = siac
                       |> Result.map_error (fun e ->
                           Logr.warn (fun m -> m "%s.%s %a %s signed_by:%a %s" "Is2s.Inbox" "post" Uuidm.pp uuid "get" Uri.pp okeyid e);
                           Http.s502' ~body:(e |> Cgi.Response.body ~ee:E.e1048)) in
          Logr.debug (fun m -> m "%s.%s replaced empty inbox with %a" "Is2s.Inbox" "post" Uri.pp okeyid);
          Lwt.return (Ok siac.inbox)
        )
      else Lwt.return (Ok ibx)
    in
    let%lwt inbox      = ensure_inbox o siac.inbox in
    let*% inbox        = inbox in
    let reaction_inbox = Some inbox in
    let siac           = {siac with inbox} in
    let key            = mekey in
    let r = match o with
      | `Follow obj                             -> Ap.Followers.snd_accept       ~uuid ~base ~key me siac obj
      | `Undo ({ obj = `Follow obj; _ } as a)   -> Ap.Followers.snd_accept_undo  ~uuid ~base ~key me siac {a with obj}
      | `Accept { obj = `Follow obj; _ }        -> Ap.Following.rcv_accept       ~uuid ~base      me siac obj
      | `Create ({ obj = `Note obj; _ } as a)   ->
        let obj = {obj with agent; reaction_inbox} in
        Ap.Note.rcv_create                                                       ~uuid ~base         siac {a with obj}
      | `Update ({ obj = `Note obj; _ } as a)   ->
        let obj = {obj with agent; reaction_inbox} in
        Ap.Note.rcv_update                                                       ~uuid ~base         siac {a with obj}
      | `Like obj                               -> Ap.Like.rcv_like              ~uuid ~base         siac obj
      | `Undo ({ obj = `Like obj; _ } as a)     -> Ap.Like.rcv_like_undo         ~uuid ~base         siac {a with obj}
      | `Announce obj                           -> Ap.Announce.rcv_announce      ~uuid ~base         siac obj
      | `Undo ({ obj = `Announce obj; _ } as a) -> Ap.Announce.rcv_announce_undo ~uuid ~base         siac {a with obj}
      | `Reject obj                             -> Ap.rcv_reject                 ~uuid ~base         siac obj.obj
      | _ -> (
          Logr.warn (fun m -> m "%s.%s %a fallthrough\n%s" "Is2s.Inbox" "post" Uuidm.pp uuid bo);
          Ap.snd_reject ~uuid ~base ~key me siac j
        ) in
    let%lwt _ = Main.Queue.ping_and_forget ~base ~run_delay_s in
    r
end