Source file http_sign.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                                          *)
(*                                                                               *)
(*********************************************************************************)

(** Implementation of HTTP signatures. *)

(* RFC for Http-signatures: https://datatracker.ietf.org/doc/html/draft-cavage-http-signatures-08 *)

type E.error +=
| Signing_error of string

let () = E.register_string_of_error
  (function
   | Signing_error msg ->
       Some (Printf.sprintf "Signing error: %s" msg)
   | _ -> None)

type signature_spec =
  { algorithm : string ;
    key_id : string ;
    signed_headers : string list ;
    signature : string ; (* signature not in base64 *)
    created : int option ;
    expires : int option;
  }

let string_of_signature_spec s =
  Printf.sprintf "keyId=%S,algorithm=%S%s%s,headers=%S,signature=%S"
    s.key_id s.algorithm
    (match s.created with None -> "" | Some n -> Printf.sprintf ",created=%d" n)
    (match s.expires with None -> "" | Some n -> Printf.sprintf ",expires=%d" n)
    (String.concat " " s.signed_headers)
    (Base64.encode_string s.signature)

(**/**)

let sign_string (privkey: X509.Private_key.t) str =
  match X509.Private_key.sign `SHA256 ~scheme:`RSA_PKCS1 privkey
     (`Message str)
  with
  | Ok cs -> cs
  | Error (`Msg msg) -> E.error (Signing_error msg)

let req_headers headers = Smap.of_list (Cohttp.Header.to_list headers)

let sha256 str =
  let hash = Cryptokit.Hash.sha256 () in
  hash#add_string str ;
  let str = hash#result in
  hash#wipe ;
  str

let body_digest body =
  let hash = sha256 body in
  let b64 = Base64.encode_string hash in
(*  let hexa = let h = Cryptokit.Hexa.encode () in
    h#put_string hash;
    h#finish;
    h#get_string
  in
  Log.debug (fun m-> m "BODY DIGEST: hexa(hash)=%S, b64 encoded=%S" hexa b64);
  let oc = open_out "/tmp/body" in
  output_string oc body;
  close_out oc ;*)
  Printf.sprintf "SHA-256=%s" b64

let unquote_string str =
    let len = String.length str in
    if len <= 0 then str
    else
      match String.get str 0 with
      | '"' ->
          if len > 1 && String.get str (len - 1) = '"' then
            String.sub str 1 (len - 2)
          else
            String.sub str 1 (len - 1)
      | _ -> str

let header_list_of_string =
  let f str acc =
    match str with
    | "" -> acc
    | str -> str :: acc
  in
  fun str -> List.fold_right f (String.split_on_char ' ' str) []

let default_signed_headers =
  [ "(request-target)" ; "host" ; "date" ; "digest" ; "content-length"]

let key_value_of_string str =
  match String.index_opt str '=' with
  | None -> None
  | Some p ->
      let len = String.length str in
      let k = String.sub str 0 p in
      let v = String.sub str (p+1) (len - p - 1) in
      Some (k, unquote_string v)

let signature_spec_of_string str =
  let l = String.split_on_char ',' str in
  let l = List.filter_map key_value_of_string l in
  let map = Smap.of_list l in
  let get fd = Option.value ~default:"" (Smap.find_opt fd map) in
  let algorithm = get "algorithm" in
  let key_id = get "keyId" in
  let signed_headers = header_list_of_string (get "headers") in
  let signature = get "signature" in
  let created = Option.map int_of_string (Smap.find_opt "created" map) in
  let expires = Option.map int_of_string (Smap.find_opt "expires" map) in
  (*Log.debug (fun m -> m "signature(b64)=%s" signature);
  Log.debug (fun m -> m "keyId=%s" key_id);*)
  match Base64.decode signature with
  | Error (`Msg msg) -> Log.warn (fun m -> m "%s" msg); None
  | Ok signature ->
      Some { algorithm ; key_id ; signed_headers ; signature ; created ; expires }

let build_signing_string ~fail_on_missing_header
  ~meth ~path ~sig_spec ~headers ~body_digest =
  let lines = List.map
    (function
     | "(request-target)" as x ->
         let meth = String.lowercase_ascii (Cohttp.Code.string_of_method meth) in
         Printf.sprintf "%s: %s %s" x meth path
     | "(created)" as x ->
         let n = match sig_spec.created with
           | None ->
               let msg = Printf.sprintf "Missing header %S to build signing string" x in
               E.error (Signing_error msg)
           | Some n -> n
         in
         Printf.sprintf "%s: %d" x n
     | "(expires)" as x ->
         let n = match sig_spec.expires with
           | None ->
               let msg = Printf.sprintf "Missing header %S to build signing string" x in
               E.error (Signing_error msg)

           | Some n -> n
         in
         Printf.sprintf "%s: %d" x n
     | "digest" -> Printf.sprintf "digest: %s" body_digest
     | header ->
         let v = match Cohttp.Header.get headers header with
           | None when fail_on_missing_header ->
               let msg = Printf.sprintf "Missing header %S to build signing string" header in
               E.error (Signing_error msg)
           | None -> ""
           | Some str -> str
         in
         Printf.sprintf "%s: %s" header v
    )
      sig_spec.signed_headers
  in
  let ss = String.concat "\n" lines in
  (*Log.debug (fun m -> m "signing_string: %s" ss);*)
  ss

let verify_signature ?map_key_id ~signing_string ~sig_spec () =
  let key_id = sig_spec.key_id in
  (*Log.debug (fun m -> m "verify signature for keyId %S" key_id);*)
  let%lwt pub_key =
    match map_key_id with
    | None -> Lwt.return (X509.Public_key.decode_pem key_id)
    | Some f -> f key_id
  in
  let%lwt result =
    match sig_spec.algorithm with
    | "rsa-sha256" | "hs2019"->
        (match pub_key with
         | Ok pub_key ->
             (*Log.debug (fun m -> m "pub_key: %S"
                (Cstruct.to_string (X509.Public_key.encode_pem pub_key)));*)
             let res = X509.Public_key.verify `SHA256 ~scheme:`RSA_PKCS1
               ~signature:sig_spec.signature
               pub_key (`Message signing_string)
             in
             Lwt.return res
         | Error e -> Lwt.return_error e
        )
    | algo ->
        Lwt.return_error (`Msg (Printf.sprintf "Unsupported algo %S in signature" algo))
  in
  match result with
  | Error (`Msg msg) ->
      Log.warn (fun m -> m "%s (signature_spec=%s)"
         msg (string_of_signature_spec sig_spec));
      Lwt.return_false
  | Ok _ ->
      Lwt.return_true

(**/**)

let verify_request ?map_key_id req body =
  match Cohttp.(Header.get req.Request.headers "signature") with
  | None -> Lwt.return_none
  | Some str ->
      match signature_spec_of_string str with
      | None -> Lwt.return_none
      | Some sig_spec ->
          (* force host to x-forward-host if present, in case we're
             behind a proxy which changed the hostname *)
          let headers =
            let open Cohttp in
            let h = req.Request.headers in
            match Header.get h "x-forwarded-host" with
            | None -> h
            | Some host -> Header.replace h "host" host
          in
          let meth = req.Cohttp.Request.meth in
          let path = req.Cohttp.Request.resource in
          let body_digest = body_digest body in
          let signing_string =
            build_signing_string ~fail_on_missing_header:false
              ~meth ~path ~sig_spec
              ~headers ~body_digest
          in
          let%lwt res = verify_signature ?map_key_id ~signing_string ~sig_spec () in
          Lwt.return_some res

(**/**)

let path_of_iri iri =
  let query_kv =
    let kv = Iri.query_kv iri in
    if Iri.KV.is_empty kv then None else Some kv
  in
  let iri = Iri.iri ~path:(Iri.path iri) ?query_kv () in
  Iri.to_string iri

(**/**)

let add_signature_header meth iri headers (spec, sign_fun) body =
(*  let headers =
    let l = Cohttp.(Header.to_list query_headers) in
    let l = List.map (fun (k,v) -> (String.lowercase_ascii k, v)) l in
    Smap.of_list l
  in
*)
  let get = Cohttp.Header.get in
  let headers =
    match get headers "date" with
    | Some _ -> headers
    | None ->
        Cohttp.Header.add headers "Date"
          (Utils.ptime_to_utc_string (Utils.ptime_now()))
  in
  let headers =
    match get headers "host" with
    | Some _ -> headers
    | None ->
        match Iri.host iri with
        | None -> headers
        | Some h ->
            Log.info (fun m -> m "adding host %S to headers signature" h);
            Cohttp.Header.add headers "Host" h
  in
  let headers =
    match get headers "content-length" with
    | Some _ -> headers
    | None -> Cohttp.Header.add headers "Content-length"
          (string_of_int (String.length body))
  in
  let body_digest = body_digest body in
  let headers =
    match get headers "digest" with
    | Some _ -> headers
    | None -> Cohttp.Header.add headers "Digest" body_digest
  in
  let signing_string =
    build_signing_string ~fail_on_missing_header:true
      ~meth ~path:(path_of_iri iri)
      ~sig_spec:spec ~headers ~body_digest
  in
  let sig_spec = { spec with signature = sign_fun signing_string } in
  Cohttp.Header.add headers "Signature" (string_of_signature_spec sig_spec)

let rsa256_signing ?(signed_headers=default_signed_headers)
  (pub_key:X509.Public_key.t) (priv_key : X509.Private_key.t) =
  let created = Stdlib.truncate (Ptime.to_float_s (Utils.ptime_now())) in
  let expires = created + 60 in
  let key_id = X509.Public_key.encode_pem pub_key in
  let spec =
    { key_id ; algorithm = "rsa-sha256" ;
      signed_headers ; signature = "" ;
      created = Some created ; expires = Some expires ;
    }
  in
  let f_sign str =
    match X509.Private_key.sign `SHA256 ~scheme:`RSA_PKCS1 priv_key
      (`Message str)
    with
    | Error (`Msg msg) -> E.error (Signing_error msg)
    | Ok str -> str
  in
  (spec, f_sign)


let rsa256_signing_with_actor ?(signed_headers=default_signed_headers)
  (actor:Iri.t) (priv_key : X509.Private_key.t) =
  let created = Stdlib.truncate (Ptime.to_float_s (Utils.ptime_now())) in
  let expires = created + 60 in
  let key_id = Iri.to_string actor in
  let spec =
    { key_id ; algorithm = "rsa-sha256" ;
      signed_headers ; signature = "" ;
      created = Some created ; expires = Some expires ;
    }
  in
  let f_sign str =
    match X509.Private_key.sign `SHA256 ~scheme:`RSA_PKCS1 priv_key
      (`Message str)
    with
    | Error (`Msg msg) -> E.error (Signing_error msg)
    | Ok str -> str
  in
  (spec, f_sign)


(**/**)

let test () =
  Log.debug (fun m -> m "Testing http-signing");
  let pub_key_pem = "-----BEGIN PUBLIC KEY-----
MIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQDCFENGw33yGihy92pDjZQhl0C3
6rPJj+CvfSC8+q28hxA161QFNUd13wuCTUcq0Qd2qsBe/2hFyc2DCJJg0h1L78+6
Z4UMR7EOcpfdUE9Hf3m/hs+FUR45uBJeDK1HSFHD8bHKD6kv8FPGfJTotc+2xjJw
oYi+1hqp1fIekaxsyQIDAQAB
-----END PUBLIC KEY-----"
  in
  let priv_key_pem = "-----BEGIN RSA PRIVATE KEY-----
MIICXgIBAAKBgQDCFENGw33yGihy92pDjZQhl0C36rPJj+CvfSC8+q28hxA161QF
NUd13wuCTUcq0Qd2qsBe/2hFyc2DCJJg0h1L78+6Z4UMR7EOcpfdUE9Hf3m/hs+F
UR45uBJeDK1HSFHD8bHKD6kv8FPGfJTotc+2xjJwoYi+1hqp1fIekaxsyQIDAQAB
AoGBAJR8ZkCUvx5kzv+utdl7T5MnordT1TvoXXJGXK7ZZ+UuvMNUCdN2QPc4sBiA
QWvLw1cSKt5DsKZ8UETpYPy8pPYnnDEz2dDYiaew9+xEpubyeW2oH4Zx71wqBtOK
kqwrXa/pzdpiucRRjk6vE6YY7EBBs/g7uanVpGibOVAEsqH1AkEA7DkjVH28WDUg
f1nqvfn2Kj6CT7nIcE3jGJsZZ7zlZmBmHFDONMLUrXR/Zm3pR5m0tCmBqa5RK95u
412jt1dPIwJBANJT3v8pnkth48bQo/fKel6uEYyboRtA5/uHuHkZ6FQF7OUkGogc
mSJluOdc5t6hI1VsLn0QZEjQZMEOWr+wKSMCQQCC4kXJEsHAve77oP6HtG/IiEn7
kpyUXRNvFsDE0czpJJBvL/aRFUJxuRK91jhjC68sA7NsKMGg5OXb5I5Jj36xAkEA
gIT7aFOYBFwGgQAQkWNKLvySgKbAZRTeLBacpHMuQdl1DfdntvAyqpAZ0lY0RKmW
G6aFKaqQfOXKCyWoUiVknQJAXrlgySFci/2ueKlIE1QqIiLSZ8V8OlpFLRnb1pzI
7U1yQXnTAEFYM560yJlzUpOb1V4cScGd365tiSMvxLOvTA==
-----END RSA PRIVATE KEY-----"
  in
  let pub_key =
    match X509.Public_key.decode_pem pub_key_pem with
    | Error (`Msg msg) -> failwith msg
    | Ok k -> k
  in
  let priv_key =
    match X509.Private_key.decode_pem priv_key_pem with
    | Error (`Msg msg) -> failwith msg
    | Ok k -> k
  in
  let signing = rsa256_signing
    ~signed_headers: ["(request-target)" ; "host" ; "date"]
    pub_key priv_key
  in
  let headers = Cohttp.Header.init_with "date" "Sun, 05 Jan 2014 21:31:40 GMT" in
  let h = add_signature_header `POST
    (Iri.of_string "https://example.com//foo?param=value&pet=dog")
      headers signing ""
  in
  Log.debug (fun m -> m "TEST headers: %s" (Cohttp.Header.to_string h));
  let expected_signature = "qdx+H7PHHDZgy4y/Ahn9Tny9V3GP6YgBPyUXMmoxWtLbHpUnXS2mg2+SbrQDMCJypxBLSPQR2aAjn7ndmw2iicw3HMbe8VfEdKFYRqzic+efkb3nndiv/x1xSHDJWeSWkx3ButlYSuBskLu6kd9Fswtemr3lgdDEmn04swr2Os0="
  in
  match Cohttp.Header.get h "signature" with
  | None -> assert false
  | Some str ->
      match signature_spec_of_string str with
      | None -> assert false
      | Some s ->
          match Base64.encode s.signature with
          | Error (`Msg msg) -> Log.err (fun m -> m "%s" msg); assert false
          | Ok s ->
              Log.debug (fun m -> m "signature = %S" s);
              assert (s = expected_signature);
              Log.debug (fun m -> m "Http-signing ok")