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
  (* fetch http header values and map from lowercase plus the special name (request-target) *)
  let hdr (r : Cgi.Request.t) h =
    let toenv = String.map (function
        | '-' -> '_'
        | c -> Char.uppercase_ascii c) in
    let v = match toenv h with
      | "(REQUEST_TARGET)"  -> (String.lowercase_ascii r.request_method) ^ " " ^ Cgi.Request.path_and_query r
      | "CONTENT_LENGTH"
      | "CONTENT_TYPE" as h -> h |> r.raw_string |> Option.value ~default:""
      | h                   -> ("HTTP_" ^ h) |> r.raw_string |> Option.value ~default:"" in
    Some v

  (* 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 te signature, parse the json and dispatch *)
  let post
      ?(blocked = Mapcdb.Cdb "app/var/db/blocked.cdb")
      ~base
      uuid
      now
      ic
      r : Cgi.Response.t' Lwt.t =
    Logr.debug (fun m -> m "%s.%s prepare my actor profile url & key" "Is2s.Inbox" "post");
    let (let*%) = Http.(let*%) in
    let run_delay = 60 in
    let*% si_v = "signature" |> hdr 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   sign    = 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.key_id in
    let   mekey : Http.t_sign_k = mekeyid,Ap.PubKeyPem.sign pk,now in
    (* don't queue it but re-try in case *)
    (* dereferencing tokeyid 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 %s %a" "Is2s.Inbox" "post" Uuidm.pp uuid "get" e Uri.pp okeyid);
                     Http.s502') in
    let*% _ = match blocked |> Mapcdb.find_string_opt (siac.id |> Uri.to_string) with
      | None   -> Ok Http.s403'
      | Some _ -> Http.s403 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*% siacpub = 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 (hdr r) in
    let*% _ = heads
              |> Http.Signature.to_sign_string ~request:None
              |> Cstruct.of_string
              |> Ap.PubKeyPem.verify ~uuid ~key:okeyid ~algo siacpub sign
              |> 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.s400' 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 Http.s403'
      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 = j |> As2_vocab.Activitypub.Decode.obj |> map_er1 "decode ActivityPub object" 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) -> Ap.Note.rcv_create           ~uuid ~base         siac {a with obj}
      | `Update ({ obj = `Note obj; _ } as a) -> Ap.Note.rcv_update           ~uuid ~base         siac {a with obj}
      | `Reject obj                           -> Ap.rcv_reject                ~uuid ~base         siac 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 in
    r
end