4 Commits 6b93c45885 ... 774b2be7a1

Author SHA1 Message Date
  Marcus Rohrmoser 774b2be7a1 signatures continued. 2 months ago
  Marcus Rohrmoser 64c1bb397b make language mandatory for note.content and note.summary. 2 months ago
  Marcus Rohrmoser 04f2a954ce alcotest, doc, clean. 2 months ago
  Marcus Rohrmoser b63aeeb118 signature cleanup. 2 months ago
10 changed files with 155 additions and 110 deletions
  1. 17 5
      as2_vocab/decode.ml
  2. 1 3
      as2_vocab/encode.ml
  3. 2 4
      as2_vocab/types.ml
  4. 1 1
      chkr/cgi.ml
  5. 43 41
      lib/ap.ml
  6. 15 15
      lib/cgi.ml
  7. 66 30
      lib/http.ml
  8. 3 4
      lib/is2s.ml
  9. 7 7
      lib/iweb.ml
  10. 0 0
      lib/job.ml

+ 17 - 5
as2_vocab/decode.ml

@@ -229,7 +229,7 @@ let person =
       (* raw; *)
       (* raw; *)
     }: Types.person)
     }: Types.person)
 
 
-let note =
+let note ?(lang = "und") =
   let open D in
   let open D in
   let* ()          = field "type" @@ constant ~msg:"expected Note (received %s)" "Note"
   let* ()          = field "type" @@ constant ~msg:"expected Note (received %s)" "Note"
   and* id          = field "id" uri
   and* id          = field "id" uri
@@ -239,21 +239,33 @@ let note =
   and* to_         = field "to" (singleton_or_list uri)
   and* to_         = field "to" (singleton_or_list uri)
   and* in_reply_to = field_or_default "inReplyTo" (singleton_or_list uri) []
   and* in_reply_to = field_or_default "inReplyTo" (singleton_or_list uri) []
   and* cc          = field_or_default "cc" (singleton_or_list uri) []
   and* cc          = field_or_default "cc" (singleton_or_list uri) []
-  and* content     = field "content" string
+  and* content     = field_or_default "content" (nullable string) None
   and* content_map = field_or_default "contentMap" (key_value_pairs string) []
   and* content_map = field_or_default "contentMap" (key_value_pairs string) []
   and* source      = field_opt "source"
   and* source      = field_opt "source"
       (one_of ["string", uri; "multi-encode", field "content" uri])
       (one_of ["string", uri; "multi-encode", field "content" uri])
   and* summary     = field_or_default "summary" (nullable string) None
   and* summary     = field_or_default "summary" (nullable string) None
   and* summary_map = field_or_default "summaryMap" (key_value_pairs string) []
   and* summary_map = field_or_default "summaryMap" (key_value_pairs string) []
-  and* sensitive   = field_or_default "sensitive" (nullable bool) None
+  and* sensitive   = field_or_default "sensitive" bool false
   and* media_type  = field_opt "mediaType" string
   and* media_type  = field_opt "mediaType" string
   and* published   = field_opt "published" rfc3339
   and* published   = field_opt "published" rfc3339
   and* tags        = field_or_default "tag" (list_ignoring_unknown tag) []
   and* tags        = field_or_default "tag" (list_ignoring_unknown tag) []
   and* url         = field_or_default "url" (singleton_or_list uri) []
   and* url         = field_or_default "url" (singleton_or_list uri) []
   (* and* raw = value *) in
   (* and* raw = value *) in
+  let lang,content_map = match content,content_map with
+    | None,[] -> lang,[]
+    | None,((la,_) :: _ as map) -> la,map
+    | Some co,((la,s) :: _ as map) when "" |> String.equal co || s |> String.equal co -> la,map
+    | Some co,map -> lang,(lang,co) :: map
+  in
+  let summary_map = match summary,summary_map with
+    | None,map
+    | Some "",map   -> map
+    | Some co, ((_,s) :: _ as map) when s |> String.equal co -> map
+    | Some co,map -> (lang,co) :: map
+  in
   succeed ({ id; actor; agent; attachment; in_reply_to; to_; cc;
   succeed ({ id; actor; agent; attachment; in_reply_to; to_; cc;
-             sensitive=Option.value ~default:false sensitive;
-             media_type; content; content_map; source; summary; summary_map; tags; published; url(*; raw*) }: Types.note)
+             sensitive;
+             media_type; content_map; source; summary_map; tags; published; url(*; raw*) }: Types.note)
 
 
 let follow =
 let follow =
   let open D in
   let open D in

+ 1 - 3
as2_vocab/encode.ml

@@ -256,7 +256,7 @@ let attachment ~base ({media_type; name; url; type_}: Types.attachment) =
 
 
 let note ?(context = None)
 let note ?(context = None)
     ~base
     ~base
-    ({ id; actor; agent; to_; in_reply_to; cc; media_type; content; content_map; sensitive; source; summary; summary_map;
+    ({ id; actor; agent; to_; in_reply_to; cc; media_type; content_map; sensitive; source; summary_map;
        attachment=att;
        attachment=att;
        published; tags; url(*; raw=_*) }: Types.note) =
        published; tags; url(*; raw=_*) }: Types.note) =
   let content_map = content_map |> List.map (fun (k,v) -> (k,E.string v)) in
   let content_map = content_map |> List.map (fun (k,v) -> (k,E.string v)) in
@@ -270,11 +270,9 @@ let note ?(context = None)
     "cc"         @?. cc         <: jsonld_list (uri ~base);
     "cc"         @?. cc         <: jsonld_list (uri ~base);
     "inReplyTo"  @?. in_reply_to<: jsonld_list (uri ~base);
     "inReplyTo"  @?. in_reply_to<: jsonld_list (uri ~base);
     "mediaType"  @? media_type  <: E.string;
     "mediaType"  @? media_type  <: E.string;
-    "content"    @ content      <: E.string;
     "contentMap" @?. content_map<: E.obj;
     "contentMap" @?. content_map<: E.obj;
     "sensitive"  @ sensitive    <: E.bool;
     "sensitive"  @ sensitive    <: E.bool;
     "source"     @? source      <: uri ~base;
     "source"     @? source      <: uri ~base;
-    "summary"    @? summary     <: E.string;
     "summaryMap" @?. summary_map<: E.obj;
     "summaryMap" @?. summary_map<: E.obj;
     "published"  @? published   <: ptime;
     "published"  @? published   <: ptime;
     "tags"       @?. tags       <: jsonld_list (tag ~base);
     "tags"       @?. tags       <: jsonld_list (tag ~base);

+ 2 - 4
as2_vocab/types.ml

@@ -227,13 +227,11 @@ type note = {
   cc         : uri list;
   cc         : uri list;
   in_reply_to: uri list;
   in_reply_to: uri list;
   media_type : string option; (* https://www.w3.org/TR/activitystreams-vocabulary/#dfn-mediatype *)
   media_type : string option; (* https://www.w3.org/TR/activitystreams-vocabulary/#dfn-mediatype *)
-  content    : string;
   content_map: (string * string) list;
   content_map: (string * string) list;
   published  : Ptime.t option; (* https://www.w3.org/TR/activitystreams-vocabulary/#dfn-published *)
   published  : Ptime.t option; (* https://www.w3.org/TR/activitystreams-vocabulary/#dfn-published *)
-  sensitive  : bool;
+  sensitive  : bool; (* https://github.com/swicg/general/issues/7 *)
   source     : uri option;
   source     : uri option;
-  summary    : string option; (* https://www.w3.org/TR/activitystreams-vocabulary/#dfn-summary *)
-  summary_map: (string * string) list;
+  summary_map: (string * string) list; (* https://www.w3.org/TR/activitystreams-vocabulary/#dfn-summary *)
   tags       : tag list;
   tags       : tag list;
   to_        : uri list;
   to_        : uri list;
   (* https://www.w3.org/TR/activitystreams-vocabulary/#dfn-updated *)
   (* https://www.w3.org/TR/activitystreams-vocabulary/#dfn-updated *)

+ 1 - 1
chkr/cgi.ml

@@ -93,7 +93,7 @@ G6aFKaqQfOXKCyWoUiVknQJAXrlgySFci/2ueKlIE1QqIiLSZ8V8OlpFLRnb1pzI
                |> Cstruct.of_string
                |> Cstruct.of_string
                |> Ap.PubKeyPem.private_of_pem_data
                |> Ap.PubKeyPem.private_of_pem_data
                |> Result.get_ok in
                |> Result.get_ok in
-      Some (Http.Signature.mkey key_id (Ap.PubKeyPem.sign pk) (Ptime_clock.now ()))
+      Some (Http.Signature.mkey key_id pk (Ptime_clock.now ()))
     in
     in
     (match id |> Uri.of_string |> Shell.actor ~key with
     (match id |> Uri.of_string |> Shell.actor ~key with
      | Error e ->
      | Error e ->

+ 43 - 41
lib/ap.ml

@@ -154,37 +154,28 @@ module PubKeyPem = struct
      * https://discuss.ocaml.org/t/tls-signature-with-opam-tls/9399/9?u=mro
      * https://discuss.ocaml.org/t/tls-signature-with-opam-tls/9399/9?u=mro
      * https://mirleft.github.io/ocaml-x509/doc/x509/X509/Private_key/#cryptographic-sign-operation
      * https://mirleft.github.io/ocaml-x509/doc/x509/X509/Private_key/#cryptographic-sign-operation
      *)
      *)
-    ("rsa-sha256",
-     X509.Private_key.sign
-       `SHA256
-       ~scheme:`RSA_PKCS1
-       pk
-       (`Message data)
-     |> Result.get_ok)
+    (Http.Signature.RSA_SHA256.name, Http.Signature.RSA_SHA256.sign pk (`Message data)
+                                     |> Result.get_ok)
 
 
   (** https://datatracker.ietf.org/doc/html/draft-cavage-http-signatures-12#autoid-38
   (** https://datatracker.ietf.org/doc/html/draft-cavage-http-signatures-12#autoid-38
   *)
   *)
-  let verify ~algo ~inbox ~(key : X509.Public_key.t) ~signature data =
-    let data = `Message data 
+  let verify ~algo ~inbox ~key ~signature data =
+    let data = `Message data
     and _ = inbox in
     and _ = inbox in
     match algo with
     match algo with
     | "hs2019" -> (* https://datatracker.ietf.org/doc/html/draft-cavage-http-signatures-12#autoid-38 *)
     | "hs2019" -> (* https://datatracker.ietf.org/doc/html/draft-cavage-http-signatures-12#autoid-38 *)
-      (match X509.Public_key.verify
-               `SHA512
-               ~scheme:`RSA_PSS
+      (match Http.Signature.HS2019.verify
                ~signature
                ~signature
                key
                key
                data with
                data with
       | Error (`Msg "bad signature") ->
       | Error (`Msg "bad signature") ->
         (* gotosocial and unnamed other AP implementations seem to use `SHA256 and `RSA_PKCS1
         (* gotosocial and unnamed other AP implementations seem to use `SHA256 and `RSA_PKCS1
-           while 
+           while
            https://datatracker.ietf.org/doc/html/draft-cavage-http-signatures-12#autoid-38
            https://datatracker.ietf.org/doc/html/draft-cavage-http-signatures-12#autoid-38
            and
            and
            https://datatracker.ietf.org/doc/id/draft-richanna-http-message-signatures-00.html#name-hs2019
            https://datatracker.ietf.org/doc/id/draft-richanna-http-message-signatures-00.html#name-hs2019
            as I understand them recommend `SHA512 and `RSA_PSS. *)
            as I understand them recommend `SHA512 and `RSA_PSS. *)
-        (match X509.Public_key.verify
-                 `SHA256
-                 ~scheme:`RSA_PKCS1
+        (match Http.Signature.RSA_SHA256.verify
                  ~signature
                  ~signature
                  key
                  key
                  data with
                  data with
@@ -194,9 +185,7 @@ module PubKeyPem = struct
         | x -> x)
         | x -> x)
       | x -> x)
       | x -> x)
     | "rsa-sha256" ->
     | "rsa-sha256" ->
-      X509.Public_key.verify
-        `SHA256
-        ~scheme:`RSA_PKCS1
+      Http.Signature.RSA_SHA256.verify
         ~signature
         ~signature
         key
         key
         data
         data
@@ -591,7 +580,7 @@ module Activity = struct
         let body = make_like sndr act_type date post_uri rcpt
         let body = make_like sndr act_type date post_uri rcpt
                    |> As2_vocab.Encode.like ~base
                    |> As2_vocab.Encode.like ~base
                    |> Ezjsonm.value_to_string in
                    |> Ezjsonm.value_to_string in
-        let headers = Http.signed_headers (key,PubKeyPem.sign pk,date) (digest_base64' body) inbx in
+        let headers = Http.signed_headers (key,pk,date) (digest_base64' body) inbx in
         let headers = Http.H.add' headers Http.H.ct_json in
         let headers = Http.H.add' headers Http.H.ct_json in
         let headers = Http.H.add' headers Http.H.acc_app_jlda in
         let headers = Http.H.add' headers Http.H.acc_app_jlda in
         Logr.info (fun m -> m "-> http POST %a" Uri.pp inbx);
         Logr.info (fun m -> m "-> http POST %a" Uri.pp inbx);
@@ -1292,14 +1281,12 @@ module Note = struct
       agent       = None;
       agent       = None;
       attachment  = [];
       attachment  = [];
       cc          = [];
       cc          = [];
-      content     = "";
       content_map = [];
       content_map = [];
       in_reply_to = [];
       in_reply_to = [];
       media_type  = (Some Http.Mime.text_html); (* https://www.w3.org/TR/activitystreams-vocabulary/#dfn-mediatype *)
       media_type  = (Some Http.Mime.text_html); (* https://www.w3.org/TR/activitystreams-vocabulary/#dfn-mediatype *)
       published   = None;
       published   = None;
       sensitive   = false;
       sensitive   = false;
       source      = None;
       source      = None;
-      summary     = None;
       summary_map = [];
       summary_map = [];
       tags        = [];
       tags        = [];
       to_         = [];
       to_         = [];
@@ -1336,25 +1323,24 @@ module Note = struct
       | _ -> None  in
       | _ -> None  in
     (* let Rfc4287.Rfc3066 lang = e.lang  in *)
     (* let Rfc4287.Rfc3066 lang = e.lang  in *)
     let tags = e.categories |> List.fold_left tag [] in
     let tags = e.categories |> List.fold_left tag [] in
-    let summary,content = match e.title,e.content with
-      | "","" -> None,"." (* empty is forbidden *)
-      | t,""  -> None,t
-      | t,c   -> Some t,c in
+    let Rfc4287.Rfc4646 lang = e.lang in
+    let summary_map = [lang,e.title] in
+    let content_map = [lang,e.content] in
     let url = e.links |> List.fold_left (
     let url = e.links |> List.fold_left (
         (* sift those without a rel *)
         (* sift those without a rel *)
         fun i (l : Rfc4287.Link.t) ->
         fun i (l : Rfc4287.Link.t) ->
           match l.rel with
           match l.rel with
           | None   -> l.href :: i
           | None   -> l.href :: i
           | Some _ -> i) [] in
           | Some _ -> i) [] in
-    assert (not (content |> String.equal ""));
+    assert (content_map |> List.length > 0);
     {empty with
     {empty with
      id;
      id;
      actor;
      actor;
+     content_map;
      cc;
      cc;
-     content;
      media_type = Some Http.Mime.text_plain;
      media_type = Some Http.Mime.text_plain;
      published;
      published;
-     summary;
+     summary_map;
      tags;
      tags;
      to_;
      to_;
      url;
      url;
@@ -1371,12 +1357,17 @@ module Note = struct
                          | Some u -> u );
                          | Some u -> u );
                      uri = Some n.actor} in
                      uri = Some n.actor} in
     let a (s,_,_) = s in
     let a (s,_,_) = s in
+    let (lang,cont) = n.content_map |> List.hd in
+    let sum = try let _,s = n.summary_map |> List.hd in
+        Some s
+      with Failure _ -> None
+    in
     {Rfc4287.Entry.empty with
     {Rfc4287.Entry.empty with
      id           = n.id;
      id           = n.id;
      author;
      author;
-     (* @TODO lang *)
-     title        = n.summary |> Option.value ~default:"" |> Html.to_plain |> a;
-     content      = n.content |> Html.to_plain |> a;
+     lang         = Rfc4287.Rfc4646 lang;
+     title        = sum |> Option.value ~default:"" |> Html.to_plain |> a;
+     content      = cont |> Html.to_plain |> a;
      published;
      published;
      updated      = published;
      updated      = published;
      in_reply_to  = n.in_reply_to |> List.map Rfc4287.Inreplyto.make;
      in_reply_to  = n.in_reply_to |> List.map Rfc4287.Inreplyto.make;
@@ -1394,22 +1385,32 @@ module Note = struct
   let html_to_plain _s =
   let html_to_plain _s =
     failwith "not implemented yet."
     failwith "not implemented yet."
 
 
+  let has_content_warning _sum =
+    if true
+    then true
+    else false
+
   (* Mastodon uses the summary as content warning. That's not what the summary intends.
   (* Mastodon uses the summary as content warning. That's not what the summary intends.
      formerly know as pleistocenify *)
      formerly know as pleistocenify *)
   let diluviate (n : As2_vocab.Types.note) =
   let diluviate (n : As2_vocab.Types.note) =
-    let c = match n.summary with
-      | None   -> ""
-      | Some t -> (t |> plain_to_html) ^ "<br/>\n" in
+    let _ = if has_content_warning n.summary_map
+      then ()
+      else ()
+    in
+    let c = match n.summary_map with
+      | []      -> ""
+      | (_,su) :: _ -> (su |> plain_to_html) ^ "<br/>\n" in
     let c = n.url |> List.fold_left (fun i u ->
     let c = n.url |> List.fold_left (fun i u ->
         let s = u |> Uri.to_string in
         let s = u |> Uri.to_string in
         Printf.sprintf "%s<a href='%s'>%s</a><br/>\n" i s s) c in
         Printf.sprintf "%s<a href='%s'>%s</a><br/>\n" i s s) c in
     let c = if c |> String.equal ""
     let c = if c |> String.equal ""
       then c
       then c
-      else (* add an emoty line *) c ^ "<br/>\n" in
-    let c = c ^ (n.content |> plain_to_html) in
+      else c ^ "<br/>\n" in
+    let la,c' = n.content_map |> List.hd in
+    let c = c ^ (c' |> plain_to_html) in
     {n with
     {n with
-     summary = None;
-     content = c;
+     summary_map = [];
+     content_map = [la,c];
      url = [n.id] }
      url = [n.id] }
 
 
   module Create = struct
   module Create = struct
@@ -1427,14 +1428,15 @@ module Note = struct
         obj            = obj;
         obj            = obj;
       }
       }
 
 
+    (** turn an Atom entry into an ActivityPub (Mastodon) Create Note activity. *)
     let to_json ~base n =
     let to_json ~base n =
+      let context = As2_vocab.Constants.ActivityStreams.und in
       n
       n
       |> of_rfc4287
       |> of_rfc4287
       |> diluviate
       |> diluviate
       (* let c = {c with to_ = [id]} in *)
       (* let c = {c with to_ = [id]} in *)
       |> make
       |> make
-      |> As2_vocab.Encode.(create ~base ~context:As2_vocab.Constants.ActivityStreams.und
-                             (note ~base))
+      |> As2_vocab.Encode.(create ~base ~context (note ~base))
   end
   end
 
 
   module Delete = struct
   module Delete = struct

+ 15 - 15
lib/cgi.ml

@@ -151,16 +151,7 @@ module Request = struct
                 | "http"  -> {req with server_port = "80" }
                 | "http"  -> {req with server_port = "80" }
                 | _       -> req ))
                 | _       -> req ))
 
 
-  (** set script and path for a query_string. *)
-  let path_and_query req =
-    (req.script_name ^ req.path_info
-     ^ match req.query_string with
-     | "" -> ""
-     | qs -> "?" ^ qs)
-    |> Uri.of_string
-
-  (** compute scheme, host, port
-      @TODO: handle proxied requests *)
+  (** compute scheme, host, port *)
   let srvr r : Uri.t =
   let srvr r : Uri.t =
     let u = Uri.make
     let u = Uri.make
         ~scheme:r.scheme
         ~scheme:r.scheme
@@ -192,6 +183,14 @@ module Request = struct
     assert (not (b |>  St.is_prefix ~affix:cgi_bin));
     assert (not (b |>  St.is_prefix ~affix:cgi_bin));
     b
     b
 
 
+  (** set script and path for a query_string. *)
+  let path_and_query r =
+    let path = (r.script_name |> script_url) ^ r.path_info in
+    let u = Uri.make ~path () in
+    match r.query_string with
+    | "" -> u
+    | q  -> q |> Uri.query_of_encoded |> Uri.with_query u
+
   let base' script_name srvr : Uri.t =
   let base' script_name srvr : Uri.t =
     assert (srvr |> Uri.path |> String.equal "");
     assert (srvr |> Uri.path |> String.equal "");
     script_name
     script_name
@@ -201,11 +200,12 @@ module Request = struct
   let base r =
   let base r =
     r |> srvr |> base' r.script_name
     r |> srvr |> base' r.script_name
 
 
-  let abs r : string =
-    (Uri.with_path
-       (srvr r)
-       ((r.script_name |> script_url) ^ r.path_info)
-     |> Uri.to_string) ^ "?" ^ r.query_string
+  let abs r : Uri.t =
+    let u = r |> srvr in
+    let u = (r.script_name |> script_url) ^ r.path_info |> Uri.with_path u in
+    match r.query_string with
+    | "" -> u
+    | q  -> q |> Uri.query_of_encoded |> Uri.with_query u
 end
 end
 
 
 module Response = struct
 module Response = struct

+ 66 - 30
lib/http.ml

@@ -198,7 +198,7 @@ let clob_send _ ct clob =
  * https://datatracker.ietf.org/doc/html/draft-cavage-http-signatures-12
  * https://datatracker.ietf.org/doc/html/draft-cavage-http-signatures-12
  * see also https://github.com/Gopiandcode/http_sig_ocaml/blob/254d464c16025e189ceb20190710fe50e9bd8d2b/http_sig.ml#L50
  * see also https://github.com/Gopiandcode/http_sig_ocaml/blob/254d464c16025e189ceb20190710fe50e9bd8d2b/http_sig.ml#L50
  *
  *
- * Another list of k-v-pairs but in diiosyncratic encoding. Different from Cookie.
+ * Another list of k-v-pairs but in idiosyncratic encoding. Different from Cookie.
  *)
  *)
 module Signature = struct
 module Signature = struct
   (* https://datatracker.ietf.org/doc/html/rfc7230#section-3.2.6 *)
   (* https://datatracker.ietf.org/doc/html/rfc7230#section-3.2.6 *)
@@ -279,29 +279,34 @@ module Signature = struct
   let decode = Tyre.exec P.list_auth_param'
   let decode = Tyre.exec P.list_auth_param'
 
 
   (** the header value without escaping e.g. = or "" *)
   (** the header value without escaping e.g. = or "" *)
-  let encode = Tyre.eval P.list_auth_param
+  let encode =
+    (*
+        |> List.fold_left (fun init (k,v) -> Printf.sprintf {|%s="%s"|} k v :: init) []
+        |> Astring.String.concat ~sep:"," in
+        *)
+    Tyre.eval P.list_auth_param
 
 
-  let to_sign_string ~request h =
+  let to_sign_string0 ~request h : string =
     let h = h |> Cohttp.Header.to_frames in
     let h = h |> Cohttp.Header.to_frames in
     (match request with
     (match request with
+     | None -> h
      | Some (meth,uri) ->
      | Some (meth,uri) ->
        let s = Printf.sprintf "(request-target): %s %s"
        let s = Printf.sprintf "(request-target): %s %s"
            (meth |> Cohttp.Code.string_of_method |> String.lowercase_ascii)
            (meth |> Cohttp.Code.string_of_method |> String.lowercase_ascii)
            (uri |> Uri.path_and_query) in
            (uri |> Uri.path_and_query) in
-       s :: h
-     | _ -> h)
+       s :: h)
     |> Astring.String.concat ~sep:"\n"
     |> Astring.String.concat ~sep:"\n"
 
 
-  (** 
+  (**
      - key_id
      - key_id
-     - signing function
+     - pk
      - now *)
      - now *)
-  type t_key = Uri.t * (Cstruct.t-> string * Cstruct.t) * Ptime.t 
+  type t_key = Uri.t * X509.Private_key.t * Ptime.t
 
 
-  let mkey id fu t : t_key = (id,fu,t)
+  let mkey id pk t : t_key = (id,pk,t)
 
 
   (** build the string to sign *)
   (** build the string to sign *)
-  let to_sign_string2
+  let to_sign_string'
       (meth : Cohttp.Code.meth)
       (meth : Cohttp.Code.meth)
       (targ : Uri.t)
       (targ : Uri.t)
       (hdrs : (string * string) list) =
       (hdrs : (string * string) list) =
@@ -318,6 +323,36 @@ module Signature = struct
             :: s in
             :: s in
     n,s
     n,s
 
 
+  let to_sign_string meth targ hdrs =
+    let n,l = to_sign_string' meth targ hdrs in
+    n |> Astring.String.concat ~sep:" "
+    ,
+    l |> Cohttp.Header.of_list
+    |> Cohttp.Header.to_frames
+    |> Astring.String.concat ~sep:"\n"
+
+  (**
+      HTTP signature according https://tools.ietf.org/id/draft-cavage-http-signatures-12.html#rfc.appendix.C
+  *)
+  module RSA_SHA256 = struct
+    let hash   = `SHA256
+    and scheme = `RSA_PKCS1
+    let name   = "rsa-sha256"
+    and sign   = X509.Private_key.sign  hash ~scheme
+    and verify = X509.Public_key.verify hash ~scheme
+  end
+
+  (**
+      HTTP signature according https://tools.ietf.org/id/draft-cavage-http-signatures-12.html#rfc.appendix.C
+  *)
+  module HS2019 = struct
+    let hash   = `SHA512
+    and scheme = `RSA_PSS
+    let name   = "hs2019"
+    and sign   = X509.Private_key.sign  hash ~scheme
+    and verify = X509.Public_key.verify hash ~scheme
+  end
+
   let add
   let add
       (priv : X509.Private_key.t)
       (priv : X509.Private_key.t)
       (meth : Cohttp.Code.meth)
       (meth : Cohttp.Code.meth)
@@ -327,20 +362,17 @@ module Signature = struct
     assert (targ |> Uri.host |> Option.is_some);
     assert (targ |> Uri.host |> Option.is_some);
     assert (hdrs |> List.assoc_opt "host" |> Option.is_some);
     assert (hdrs |> List.assoc_opt "host" |> Option.is_some);
     assert (hdrs |> List.assoc "host" |> Astring.String.equal (targ |> Uri.host_with_default ~default:""));
     assert (hdrs |> List.assoc "host" |> Astring.String.equal (targ |> Uri.host_with_default ~default:""));
-    let n,s = to_sign_string2 meth targ hdrs in
-    let s = s |> Cohttp.Header.of_list |> Cohttp.Header.to_frames |> Astring.String.concat ~sep:"\n" in
-    let n = n |> Astring.String.concat ~sep:" " in
+    let n,s = to_sign_string meth targ hdrs in
     (* build the signature header value *)
     (* build the signature header value *)
-    match `Message (s |> Cstruct.of_string) |> X509.Private_key.sign `SHA256 ~scheme:`RSA_PKCS1 priv with
-    | Error _ as e -> e
-    | Ok s ->
+    match RSA_SHA256.(name,(sign priv (`Message (s |> Cstruct.of_string) ))) with
+    | _,(Error _ as e) -> e
+    | alg,Ok si ->
       let v = [
       let v = [
-        "signature", s |> Cstruct.to_string |> Base64.encode_string;
+        "algorithm",alg;
         "headers"  ,n;
         "headers"  ,n;
-        "algorithm","rsa-sha256";
+        "signature", si |> Cstruct.to_string |> Base64.encode_string;
       ]
       ]
-        |> List.fold_left (fun init (k,v) -> Printf.sprintf {|%s="%s"|} k v :: init) []
-        |> Astring.String.concat ~sep:"," in
+        |> encode in
       Ok ( hdrs @ ["signature",v] )
       Ok ( hdrs @ ["signature",v] )
 end
 end
 
 
@@ -360,7 +392,7 @@ end
 
 
     NOT: https://datatracker.ietf.org/doc/draft-ietf-httpbis-message-signatures/
     NOT: https://datatracker.ietf.org/doc/draft-ietf-httpbis-message-signatures/
 *)
 *)
-let signed_headers (key_id,fkt_sign,date : Signature.t_key) dige uri =
+let signed_headers (key_id,pk,date : Signature.t_key) dige uri =
   let open Cohttp in
   let open Cohttp in
   let hdr = (
   let hdr = (
     ("host", uri |> Uri.host |> Option.value ~default:"-") ::
     ("host", uri |> Uri.host |> Option.value ~default:"-") ::
@@ -378,17 +410,21 @@ let signed_headers (key_id,fkt_sign,date : Signature.t_key) dige uri =
   let tx_ = tx_ |> Cohttp.Header.of_list |> Cohttp.Header.to_frames |> Astring.String.concat ~sep:"\n" in
   let tx_ = tx_ |> Cohttp.Header.of_list |> Cohttp.Header.to_frames |> Astring.String.concat ~sep:"\n" in
   assert (tx_ |> String.equal tx');
   assert (tx_ |> String.equal tx');
   *)
   *)
-  let request = Some (meth,uri) in
-  let tx' = hdr
-            |> Header.of_list
-            |> Signature.to_sign_string ~request in
-  let algo,sgna = tx'
-                  |> Cstruct.of_string
-                  |> fkt_sign in
+  let tx = hdr
+           |> Cohttp.Header.of_list
+           |> Signature.to_sign_string0 ~request:(Some (meth,uri)) in
+  let sgna =
+    Signature.RSA_SHA256.sign
+      pk
+      (`Message (Cstruct.of_string tx))
+    |> Result.get_ok
+    |> Cstruct.to_string
+    |> Base64.encode_exn
+  in
   ["keyId",     key_id |> Uri.to_string ;
   ["keyId",     key_id |> Uri.to_string ;
-   "algorithm", algo ;
+   "algorithm", Signature.RSA_SHA256.name ;
    "headers",   "(request-target) host date" ^ lst ;
    "headers",   "(request-target) host date" ^ lst ;
-   "signature",  sgna |> Cstruct.to_string |> Base64.encode_exn ;
+   "signature",  sgna ;
   ]
   ]
   |> Signature.encode
   |> Signature.encode
      (*
      (*

+ 3 - 4
lib/is2s.ml

@@ -50,7 +50,7 @@ module Inbox = struct
       )
       )
       (Cohttp.Header.init ())
       (Cohttp.Header.init ())
 
 
-  (* Receive the post request, verify te signature, parse the json and dispatch *)
+  (* Receive the post request, verify the signature, parse the json and dispatch *)
   let post
   let post
       ?(blocked = Mapcdb.Cdb "app/var/db/subscribed_to.cdb")
       ?(blocked = Mapcdb.Cdb "app/var/db/subscribed_to.cdb")
       ~base
       ~base
@@ -86,7 +86,7 @@ module Inbox = struct
         Http.s500') in
         Http.s500') in
     let   me      = Uri.make ~path:Ap.proj () |> Http.reso ~base in
     let   me      = Uri.make ~path:Ap.proj () |> Http.reso ~base in
     let   mekeyid = me |> Ap.Person.my_key_id in
     let   mekeyid = me |> Ap.Person.my_key_id in
-    let   mekey = Http.Signature.mkey mekeyid (Ap.PubKeyPem.sign pk) now in
+    let   mekey   = Http.Signature.mkey mekeyid pk now in
     (* don't queue it but re-try in case *)
     (* don't queue it but re-try in case *)
     (* dereferencing okeyid must yield an actor profile document. *)
     (* dereferencing okeyid must yield an actor profile document. *)
     let%lwt siac = Ap.Actor.http_get ~key:(Some mekey) okeyid in
     let%lwt siac = Ap.Actor.http_get ~key:(Some mekey) okeyid in
@@ -110,8 +110,7 @@ module Inbox = struct
     let*% key = Ap.PubKeyPem.of_pem siac.public_key.pem |> map_er0 "parse key" 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 *)
     (* TODO? compare the key to what we knew before from this actor *)
     let heads = heads |> hdrs (hdr r) in
     let heads = heads |> hdrs (hdr r) in
-    let tx = heads
-             |> Http.Signature.to_sign_string ~request:None 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);
     Logr.debug (fun m -> m "%s.%s signature check '%s'" "Is2s.Inbox" "post" tx);
     let*% _ = tx
     let*% _ = tx
               |> Cstruct.of_string
               |> Cstruct.of_string

+ 7 - 7
lib/iweb.ml

@@ -256,8 +256,8 @@ module Login = struct
   module F = Html.Form
   module F = Html.Form
 
 
   let i_tok : F.input = ("token",              "hidden",   [])
   let i_tok : F.input = ("token",              "hidden",   [])
-  let i_uid : F.input = ("login",              "text",     [("required","required")])
-  let i_pwd : F.input = ("password",           "password", [("required","required")])
+  let i_uid : F.input = ("login",              "text",     ["required","required"; "autofocus","autofocus"])
+  let i_pwd : F.input = ("password",           "password", ["required","required"])
   let i_lol : F.input = ("longlastingsession", "checkbox", [])
   let i_lol : F.input = ("longlastingsession", "checkbox", [])
   let i_ret : F.input = ("returnurl",          "hidden",   [])
   let i_ret : F.input = ("returnurl",          "hidden",   [])
   let i_but : F.input = ("Login",              "submit",   [])
   let i_but : F.input = ("Login",              "submit",   [])
@@ -465,7 +465,7 @@ let uid_redir x : (Auth.uid * Cgi.Request.t, Cgi.Response.t) result =
   | (None, (r : Cgi.Request.t)) ->
   | (None, (r : Cgi.Request.t)) ->
     let r302 p =
     let r302 p =
       let path = (r.script_name |> Cgi.Request.script_url) ^ p in
       let path = (r.script_name |> Cgi.Request.script_url) ^ p in
-      let query = ["returnurl", [r |> Cgi.Request.abs] ] in
+      let query = ["returnurl", [r |> Cgi.Request.abs |> Uri.to_string] ] in
       Uri.make ~path ~query () |> Uri.to_string |> Http.s302
       Uri.make ~path ~query () |> Uri.to_string |> Http.s302
     in
     in
     if Auth.(is_setup fn)
     if Auth.(is_setup fn)
@@ -531,7 +531,7 @@ module Actor = struct
           let date = Ptime_clock.now () in
           let date = Ptime_clock.now () in
           let base = base () in
           let base = base () in
           let key_id = Uri.make ~path:Ap.proj () |> Http.reso ~base |> Ap.Person.my_key_id in
           let key_id = Uri.make ~path:Ap.proj () |> Http.reso ~base |> Ap.Person.my_key_id in
-          let key = Some (Http.Signature.mkey key_id (Ap.PubKeyPem.sign pk) date) in
+          let key = Some (Http.Signature.mkey key_id pk date) in
           let%lwt act = u
           let%lwt act = u
                         |> Uri.of_string
                         |> Uri.of_string
                         |> Ap.Actor.http_get ~key in
                         |> Ap.Actor.http_get ~key in
@@ -662,7 +662,7 @@ module Actor = struct
       | `Unsubscribe -> do_unsubscribe ()
       | `Unsubscribe -> do_unsubscribe ()
       | `Unblock     -> do_unblock ()
       | `Unblock     -> do_unblock ()
     in
     in
-    let loc = req |> Cgi.Request.abs |> Uri.of_string in
+    let loc = req |> Cgi.Request.abs in
     let loc = Uri.add_query_param' loc ("id", (todo_id |> Uri.to_string)) in
     let loc = Uri.add_query_param' loc ("id", (todo_id |> Uri.to_string)) in
     Logr.debug (fun m -> m "%s.%s %a 302 back to %a" "Iweb.Actor" "post" Uuidm.pp uuid Uri.pp loc);
     Logr.debug (fun m -> m "%s.%s %a 302 back to %a" "Iweb.Actor" "post" Uuidm.pp uuid Uri.pp loc);
     let%lwt _ = Main.Queue.ping_and_forget ~base ~run_delay_s:60 in
     let%lwt _ = Main.Queue.ping_and_forget ~base ~run_delay_s:60 in
@@ -683,7 +683,7 @@ module Actor = struct
            let date = Ptime_clock.now () in
            let date = Ptime_clock.now () in
            let base = base () in
            let base = base () in
            let key_id = Uri.make ~path:Ap.proj () |> Http.reso ~base |> Ap.Person.my_key_id in
            let key_id = Uri.make ~path:Ap.proj () |> Http.reso ~base |> Ap.Person.my_key_id in
-           let key = Some (Http.Signature.mkey key_id (Ap.PubKeyPem.sign pk) date) in
+           let key = Some (Http.Signature.mkey key_id pk date) in
            let%lwt act =
            let%lwt act =
              u
              u
              |> Uri.of_string
              |> Uri.of_string
@@ -799,7 +799,7 @@ module Http_ = struct
           Logr.err (fun m -> m "%s %s.%s %s" E.e1009 "Iweb.Http_" "get" s);
           Logr.err (fun m -> m "%s %s.%s %s" E.e1009 "Iweb.Http_" "get" s);
           Http.s500') in
           Http.s500') in
       Logr.debug (fun m -> m "%s.%s my keyid %a" "Iweb.Http_" "get" Uri.pp_hum keyid);
       Logr.debug (fun m -> m "%s.%s my keyid %a" "Iweb.Http_" "get" Uri.pp_hum keyid);
-      let key = Some (Http.Signature.mkey keyid (Ap.PubKeyPem.sign pk) now) in
+      let key = Some (Http.Signature.mkey keyid pk now) in
 
 
       let headers = [ Http.H.acc_app_jlda ] |> Cohttp.Header.of_list in
       let headers = [ Http.H.acc_app_jlda ] |> Cohttp.Header.of_list in
       let%lwt p = u
       let%lwt p = u

+ 0 - 0
lib/job.ml


Some files were not shown because too many files changed in this diff