123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556 |
- (*
- * _ _ ____ _
- * _| || |_/ ___| ___ _ __ _ __ ___ | |
- * |_ .. _\___ \ / _ \ '_ \| '_ \ / _ \| |
- * |_ _|___) | __/ |_) | |_) | (_) |_|
- * |_||_| |____/ \___| .__/| .__/ \___/(_)
- * |_| |_|
- *
- * Personal Social Web.
- *
- * http_test.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/>.
- *)
- open Seppo_lib
- let test_relpa () =
- Http.relpa "a/b/" "a/b/d/e" |> Assrt.equals_string __LOC__ "d/e";
- Http.relpa "a/B/" "a/b/d/e" |> Assrt.equals_string __LOC__ ""
- let test_uri () =
- let base = "https://example.com:443/a/b/c?d=e#f" |> Uri.of_string in
- base |> Uri.path
- |> Assrt.equals_string __LOC__ "/a/b/c";
- "../i.j" |> Uri.of_string |> Http.reso ~base |> Uri.to_string
- |> Assrt.equals_string __LOC__ "https://example.com:443/a/i.j";
- let re = "https://example.com:443/a/b/C/d.e#ff" |> Uri.of_string |> Http.abs_to_rel ~base in
- re |> Uri.to_string |> Assrt.equals_string __LOC__ "C/d.e#ff";
- Uri.make ~path:"." () |> Http.reso ~base:Uri.empty |> Uri.to_string |> Assrt.equals_string __LOC__ ""
- module Request = struct
- let test_uri () =
- let abs' (r : Cgi.Request.t) : Uri.t =
- Uri.make
- ~scheme:r.scheme
- ~host:r.host
- ~port:(int_of_string r.server_port)
- ~path:(r.script_name ^ r.path_info)
- ()
- and r : Cgi.Request.t = {
- content_type = "text/plain";
- content_length = None;
- host = "example.com";
- http_cookie = "";
- path_info = "/shaarli";
- query_string = "post=uhu";
- request_method = "GET";
- remote_addr = "127.0.0.1";
- scheme = "https";
- script_name = "/sub/seppo.cgi";
- server_port = "443";
- raw_string = Sys.getenv_opt
- } in
- r |> abs' |> Uri.to_string |> Assrt.equals_string __LOC__ "https://example.com:443/sub/seppo.cgi/shaarli";
- r |> Cgi.Request.abs |> Uri.of_string |> Uri.to_string |> Assrt.equals_string __LOC__ "https://example.com/sub/seppo.cgi/shaarli?post=uhu";
- r |> Cgi.Request.path_and_query |> Assrt.equals_string __LOC__ "/sub/seppo.cgi/shaarli?post=uhu";
- r |> Cgi.Request.path_and_query |> Uri.of_string |> Uri.to_string |> Assrt.equals_string __LOC__ "/sub/seppo.cgi/shaarli?post=uhu";
- "a" |> Assrt.equals_string __LOC__ "a";
- assert true
- let test_query_string () =
- match "" |> Uri.query_of_encoded with
- | [("",[])] -> ()
- | _ -> "no" |> Assrt.equals_string __LOC__ ""
- end
- module Cookie = struct
- let test_rfc1123 () =
- let s = "Thu, 01 Jan 1970 00:00:00 GMT" in
- Ptime.epoch |> Http.to_rfc1123 |> Assrt.equals_string __LOC__ s;
- assert true
- let test_to_string () =
- let http_only = Some true
- and path = Some "seppo.cgi"
- and same_site = Some `Strict
- and max_age = Some (30. *. 60.)
- and secure = Some true in
- Cookie.to_string ?path ?secure ?http_only ?same_site ("auth_until", "2022-04-08T22:30:07Z")
- |> Assrt.equals_string __LOC__
- "auth_until=2022-04-08T22:30:07Z; Path=seppo.cgi; Secure; HttpOnly; \
- SameSite=Strict";
- Cookie.to_string ?max_age ?path ?secure ?http_only ?same_site ("auth", "yes")
- |> Assrt.equals_string __LOC__
- "auth=yes; Max-Age=1800; Path=seppo.cgi; Secure; HttpOnly; \
- SameSite=Strict";
- assert true
- let test_of_string () =
- let c = Cookie.to_string ("#Seppo!", "foo") in
- c |> Assrt.equals_string __LOC__ "#Seppo!=foo";
- let v = match c |> Cookie.of_string with
- | ("#Seppo!", v) :: [] -> v
- | _ -> assert false
- in
- v |> Assrt.equals_string __LOC__ "foo";
- assert true
- end
- module Form = struct
- let test_of_channel () =
- let ic = "data/cgi_" ^ "2022-04-05T125146.post" |> open_in in
- let fv = ic |> Http.Form.of_channel in
- ic |> close_in;
- (match fv with
- | [ (k0, [ v0 ]); (k1, [ v1 ]); (k2, [ v2 ]); (k3, [ v3 ]) ] ->
- k0 |> Assrt.equals_string __LOC__ "login";
- v0 |> Assrt.equals_string __LOC__ "demo";
- k1 |> Assrt.equals_string __LOC__ "password";
- v1 |> Assrt.equals_string __LOC__ "demodemodemo";
- k2 |> Assrt.equals_string __LOC__ "token";
- v2
- |> Assrt.equals_string __LOC__
- "ff13e7eaf9541ca2ba30fd44e864c3ff014d2bc9";
- k3 |> Assrt.equals_string __LOC__ "returnurl";
- v3
- |> Assrt.equals_string __LOC__ "https://demo.mro.name/shaarligo/o/p/";
- assert true
- | _ -> assert false);
- (* match
- fv
- |> Http.Form.filter_sort_keys
- [ "login"; "password"; "token"; "returnurl" ]
- with
- | [ (k0, [ v0 ]); (k1, [ v1 ]); (k2, [ v2 ]); (k3, [ v3 ]) ] ->
- k0 |> Assrt.equals_string __LOC__ "login";
- v0 |> Assrt.equals_string __LOC__ "demo";
- k1 |> Assrt.equals_string __LOC__ "password";
- v1 |> Assrt.equals_string __LOC__ "demodemodemo";
- k2 |> Assrt.equals_string __LOC__ "returnurl";
- v2
- |> Assrt.equals_string __LOC__ "https://demo.mro.name/shaarligo/o/p/";
- k3 |> Assrt.equals_string __LOC__ "token";
- v3
- |> Assrt.equals_string __LOC__
- "ff13e7eaf9541ca2ba30fd44e864c3ff014d2bc9";
- assert true
- | _ -> assert false *);
- assert true
- let test_to_html () =
- let defs = [
- ("ka", (Ok "va", "text", [("autofocus",""); ("pattern", {|^\S+$|})]));
- ] in
- (match List.assoc_opt "ka" defs with
- | Some (Ok v,_,_) -> v
- | _ -> "foo")
- |> Assrt.equals_string __LOC__ "va";
- assert true
- let test_from_html () =
- let pred ty valu (na,va) =
- Result.bind
- valu
- (fun v ->
- match v with
- | None -> Ok None
- | Some v as vv ->
- match ty,na with
- | _,"pattern" ->
- Logr.debug (fun m -> m " '%s' ~ /%s/" v va);
- Ok vv
- | _ ->
- Logr.debug (fun m -> m " ignored %s='%s'" na va);
- Ok vv)
- in
- let string (name,(ty,preds)) vals =
- let v = Option.bind
- (List.assoc_opt name vals)
- (fun v -> Some (v |> String.concat "")) in
- List.fold_left (pred ty) (Ok v) preds in
- let _validate defs vals =
- Logr.debug (fun m -> m "Form.validate");
- let field init (name,(ty,preds)) =
- match string (name,(ty,preds)) vals with
- | Error _ as inp ->
- (match init with
- | Error a -> Error (inp :: a)
- | Ok a -> Error (inp :: a)
- )
- | Ok _ as inp ->
- (match init with
- | Error a -> Error (inp :: a)
- | Ok a -> Ok (inp :: a)
- )
- in
- List.fold_left field (Ok []) defs
- in
- let def0 = ("ka", ("text", [("autofocus",""); ("pattern", {|^\S+$|})])) in
- let _defs = [ def0; ] in
- let vals = [
- ("ka", ["vb"]);
- ] in
- (* match _validate defs vals with
- | Ok res -> List.assoc_opt "ka" res
- |> Option.value ~default:(Ok None)
- |> Result.get_ok
- |> Option.get
- |> Assrt.equals_string __LOC__ "vb"
- | _ -> assert false); *)
- let ( let* ) = Result.bind in
- let run () =
- let* k = string def0 vals in
- Ok k in
- (match run() with
- | Ok (Some v) -> v |> Assrt.equals_string __LOC__ "vb"
- | _ -> assert true);
- assert true
- let test_from_html1 () =
- let i0 : Http.Form.input = ("k0", "text", [
- ("autofocus", "autofocus");
- ("required", "required");
- ("pattern", {|^[a-z][0-9]+$|});
- ]) in
- let i1 = ("k1", "text", [
- ("required", "required");
- ("minlength", "1");
- ("maxlength", "50");
- ("pattern", {|^v.$|});
- ]) in
- let vals : Http.Form.t = [
- ("k0", ["v0"]);
- ("k1", ["v1"]);
- ] in
- let ( let* ) = Result.bind in
- let run () =
- let* v0 = vals |> Http.Form.string i0 in
- let* v1 = Http.Form.string i1 vals in
- v0 |> Assrt.equals_string __LOC__ "v0";
- v1 |> Assrt.equals_string __LOC__ "v1";
- Ok () in
- (match run() with
- | Error (_,e) -> e |> Assrt.equals_string __LOC__ ""
- | _ -> ())
- end
- module Header = struct
- let test_headers () =
- Logr.info (fun m -> m "http_test.test_headers");
- let h = [ ("A", "a"); ("B", "b") ] @ [ ("C", "c") ]
- |> Cohttp.Header.of_list in
- h |> Cohttp.Header.to_string
- |> Assrt.equals_string __LOC__ "A: a\r\nB: b\r\nC: c\r\n\r\n";
- h |> Cohttp.Header.to_frames
- |> String.concat "\n"
- |> Assrt.equals_string __LOC__ "A: a\nB: b\nC: c";
- Cohttp.Header.get h "a"
- |> Option.value ~default:"-"
- |> Assrt.equals_string __LOC__ "a";
- assert true
- let test_signature () =
- Logr.info (fun m -> m "http_test.test_signature");
- let si = {|keyId="Test",algorithm="rsa-sha256",headers="(request-target) host date",signature="qdx+H7PHHDZgy4y/Ahn9Tny9V3GP6YgBPyUXMmoxWtLbHpUnXS2mg2+SbrQDMCJypxBLSPQR2aAjn7ndmw2iicw3HMbe8VfEdKFYRqzic+efkb3nndiv/x1xSHDJWeSWkx3ButlYSuBskLu6kd9Fswtemr3lgdDEmn04swr2Os0="|} in
- let si = Http.Signature.decode si |> Result.get_ok in
- si |> List.length |> Assrt.equals_int __LOC__ 4;
- assert true
- let test_to_sign_string_basic () =
- let open Cohttp in
- let uri = Uri.of_string "/foo?param=value&pet=dog" in
- let request = Some ("post",uri) in
- [
- ("host", "example.com");
- ("date", "Sun, 05 Jan 2014 21:31:40 GMT");
- ]
- |> Header.of_list
- |> Http.Signature.to_sign_string ~request
- |> Assrt.equals_string __LOC__
- {|(request-target): post /foo?param=value&pet=dog
- host: example.com
- date: Sun, 05 Jan 2014 21:31:40 GMT|};
- assert true
- (*
- * https://datatracker.ietf.org/doc/html/draft-cavage-http-signatures-12#appendix-C.2
- *)
- let test_sign_basic () =
- Logr.info (fun m -> m "http_test.test_sign_basic");
- let pk = match Ap.PubKeyPem.private_of_pem "data/cavage.priv.pem" with
- | Ok pk -> pk
- | _ -> failwith "ouch" in
- let open Cohttp in
- let sig_ = "qdx+H7PHHDZgy4y/Ahn9Tny9V3GP6YgBPyUXMmoxWtLbHpUnXS2mg2+SbrQDMCJypxBLSPQR2aAjn7ndmw2iicw3HMbe8VfEdKFYRqzic+efkb3nndiv/x1xSHDJWeSWkx3ButlYSuBskLu6kd9Fswtemr3lgdDEmn04swr2Os0="
- and uri = Uri.of_string "/foo?param=value&pet=dog"
- and h = [
- ("host", "example.com");
- ("date", "Sun, 05 Jan 2014 21:31:40 GMT");
- ] |> Header.of_list in
- let request = Some("post",uri) in
- let s = h |> Http.Signature.to_sign_string ~request in
- s |> Assrt.equals_string __LOC__
- "(request-target): post /foo?param=value&pet=dog\n\
- host: example.com\n\
- date: Sun, 05 Jan 2014 21:31:40 GMT";
- let al,si = s |> Cstruct.of_string |> Ap.PubKeyPem.sign pk in
- al |> Assrt.equals_string __LOC__ "rsa-sha256";
- si |> Cstruct.to_string |> Base64.encode_exn |> Assrt.equals_string __LOC__ sig_;
- Logr.info (fun m -> m "http_test.test_sign_basic II");
- let pub = "data/cavage.pub.pem" |> File.to_string |> Ap.PubKeyPem.of_pem |> Result.get_ok in
- let uuid = Uuidm.v `V4 in
- (match Ap.PubKeyPem.verify ~uuid ~algo:"rsa-sha256" pub si (s |> Cstruct.of_string) with
- | Error `Msg e -> e |> Assrt.equals_string __LOC__ ""
- | Ok _ -> "ha!" |> Assrt.equals_string __LOC__ "ha!");
- assert true
- (*
- * https://datatracker.ietf.org/doc/html/draft-cavage-http-signatures-12#appendix-C.3
- *)
- let test_sign_all_headers () =
- Logr.info (fun m -> m "http_test.test_sign_all_headers");
- let open Cohttp in
- let h = [
- ("(request-target)", "post /foo?param=value&pet=dog");
- ("(created)", "1402170695");
- ("(expires)", "1402170699");
- ("host", "example.com");
- ("date", "Sun, 05 Jan 2014 21:31:40 GMT");
- ("content-type", "application/json");
- ("digest", "SHA-256=X48E9qOokqqrvdts8nOJRJN3OWDUoyWxBf7kbu9DBPE=");
- ("content-length", "18");
- ] |> Header.of_list in
- h
- |> Header.to_frames
- |> String.concat "\n"
- |> Assrt.equals_string __LOC__
- "(request-target): post /foo?param=value&pet=dog\n\
- (created): 1402170695\n\
- (expires): 1402170699\n\
- host: example.com\n\
- date: Sun, 05 Jan 2014 21:31:40 GMT\n\
- content-type: application/json\n\
- digest: SHA-256=X48E9qOokqqrvdts8nOJRJN3OWDUoyWxBf7kbu9DBPE=\n\
- content-length: 18"
- ;
- let pk = Ap.PubKeyPem.private_of_pem "data/cavage.priv.pem"
- |> Result.get_ok in
- let al,si = h
- |> Header.to_frames
- |> String.concat "\n"
- |> Cstruct.of_string
- |> Ap.PubKeyPem.sign pk
- in
- (* |> Assrt.equals_string __LOC__
- "vSdrb+dS3EceC9bcwHSo4MlyKS59iFIrhgYkz8+oVLEEzmYZZvRs8rgOp+63LEM3v+MFHB32NfpB2bEKBIvB1q52LaEUHFv120V01IL+TAD48XaERZFukWgHoBTLMhYS2Gb51gWxpeIq8knRmPnYePbF5MOkR0Zkly4zKH7s1dE="
- *)
- al |> Assrt.equals_string __LOC__ "rsa-sha256";
- si |> Cstruct.to_string |> Base64.encode_exn |> Assrt.equals_string __LOC__
- "nAkCW0wg9AbbStQRLi8fsS1mPPnA6S5+/0alANcoDFG9hG0bJ8NnMRcB1Sz1eccNMzzLEke7nGXqoiJYZFfT81oaRqh/MNFwQVX4OZvTLZ5xVZQuchRkOSO7b2QX0aFWFOUq6dnwAyliHrp6w3FOxwkGGJPaerw2lOYLdC/Bejk="
- let test_signed_headers () =
- Logr.info (fun m -> m "http_test.test_signed_headers");
- let open Cohttp in
- (* values from
- https://datatracker.ietf.org/doc/html/draft-cavage-http-signatures-12#appendix-C.3
- *)
- let id = Uri.of_string "https://example.com/actor/"
- and dgst = Some "SHA-256=X48E9qOokqqrvdts8nOJRJN3OWDUoyWxBf7kbu9DBPE="
- and date,_,_ = Ptime.of_rfc3339 "2014-01-05T22:31:40+01:00" |> Result.get_ok
- and uri = Uri.of_string "https://example.com/foo?param=value&pet=dog" in
- let key_id = Uri.with_fragment id (Some "main-key")
- and pk = match Ap.PubKeyPem.private_of_pem "data/cavage.priv.pem" with
- | Ok pk -> pk
- | _ -> failwith "ouch" in
- Http.signed_headers (key_id,Ap.PubKeyPem.sign pk,date) dgst uri
- |> Header.to_frames
- |> String.concat "\n"
- |> Assrt.equals_string __LOC__
- "host: example.com\n\
- date: Sun, 05 Jan 2014 21:31:40 GMT\n\
- digest: SHA-256=X48E9qOokqqrvdts8nOJRJN3OWDUoyWxBf7kbu9DBPE=\n\
- signature: \
- keyId=\"https://example.com/actor/#main-key\",\
- algorithm=\"rsa-sha256\",\
- headers=\"(request-target) host date digest\",\
- signature=\"WC34OEWXgO0viIZAu5qnBcKj5nOMlgjs0ASxgJPYX9x1VtKrYRRhAosH7ixFnkJneSHGn8yY9lowNvbdBg+ZsINx6P0e1WyB0YJbwsREYKYpG1sjwS3R3iCXmXf3m+txiCNhFcbbvb0Grq3wbAWGB0VW7ymI6AHixDXFLD5IYl4=\""
- (* https://datatracker.ietf.org/doc/html/rfc7235#appendix-C *)
- let test_parse_auth_params () =
- Logr.info (fun m -> m "http_test.test_parse_auth_param");
- let module P = Http.Signature.P in
- (match {|uhu|} |> Tyre.exec (P.token |> Tyre.compile) with
- | Ok "uhu" -> "super"
- | _ -> "was anderes")
- |> Assrt.equals_string __LOC__ "super";
- (match {|"uhu"|} |> Tyre.exec (P.quoted_string |> Tyre.compile) with
- | Ok "uhu" -> "super"
- | _ -> "was anderes")
- |> Assrt.equals_string __LOC__ "super";
- (match {|uhu="aha"|} |> Tyre.exec (P.auth_param|> Tyre.compile) with
- | Ok ("uhu","aha") -> "super"
- | _ -> "was anderes")
- |> Assrt.equals_string __LOC__ "super";
- (match {|uhu="ah\"a"|} |> Tyre.exec (P.auth_param|> Tyre.compile) with
- | Ok ("uhu",{|ah"a|}) -> "super"
- | _ -> "was anderes")
- |> Assrt.equals_string __LOC__ "super";
- (match {|a="A", b="B"|} |> Tyre.exec (P.list_auth_param|> Tyre.compile) with
- | Ok [("a","A"); ("b","B")] -> "super"
- | _ -> "was anderes")
- |> Assrt.equals_string __LOC__ "super";
- (match {|a="A", nasty="na,s\"ty",b="B"|} |> Tyre.exec (P.list_auth_param|> Tyre.compile) with
- | Ok [("a","A");
- ("nasty",{|na,s"ty|});
- ("b","B")] -> "super"
- | _ -> "was anderes")
- |> Assrt.equals_string __LOC__ "super";
- assert true
- let test_parse_signature () =
- Logr.info (fun m -> m "http_test.test_parse_signature");
- (* https://datatracker.ietf.org/doc/html/draft-cavage-http-signatures-12#section-4.1.1 *)
- let _sihe = {|keyId="rsa-key-1",algorithm="hs2019", created=1402170695, expires=1402170995, headers="(request-target) (created) (expires) host date digest content-length", signature="Base64(RSA-SHA256(signing string))"|}
- |> Http.Signature.decode in
- let _sihe = {|keyId="hmac-key-1",algorithm="hs2019",created=1402170695,headers="(request-target) (created) host digest content-length",signature="Base64(HMAC-SHA512(signing string))"|}
- |> Http.Signature.decode in
- (*
- date='Thu, 29 Jun 2023 09:51:37 GMT' digest='SHA-256=rSBxGz18uv2ZvY9PxjkuKv6ZWR78M/5S2m+yOXrq+ik=' signature='keyId="https://alpaka.social/users/traunstein#main-key",algorithm="rsa-sha256",headers="(request-target) host date digest content-type",signature="JIHBg3VahvgFweniUBfH0QSHOuilcYW313i7H6gptKT/uOSfs5QhADm7LKLZ6q7jZWtQLi4Ge8dhxVeYhGpdU5P3iABn665z3TvuUiwVUO0sGI6yAv+z9wVmFfPLFsTYOB09Fy+yht+E4Z9GOF6C/U79eb/y8QOuj1OJB3L+427IQpnJMuPh5e22LBM1E/eXLbvWyshKqX0n8WZj4qPezzsH21Afn+dUnd2jc2XqUbOpzeFkz45ut0okZAF3686/sQ0sBcloSFfvdB+EuLqZLJSYcnMe3Qe8dUpibgm5+v0XfgLZYPL2P7VpuMXkQB9neRbSCdTWojcABBwUGWV0DA=="'
- *)
- let h = [
- ("date",{|Thu, 29 Jun 2023 09:51:37 GMT|});
- ("digest",{|SHA-256=rSBxGz18uv2ZvY9PxjkuKv6ZWR78M/5S2m+yOXrq+ik=|});
- ("signature",{|keyId="https://alpaka.social/users/traunstein#main-key",algorithm="rsa-sha256",headers="(request-target) host date digest content-type",signature="JIHBg3VahvgFweniUBfH0QSHOuilcYW313i7H6gptKT/uOSfs5QhADm7LKLZ6q7jZWtQLi4Ge8dhxVeYhGpdU5P3iABn665z3TvuUiwVUO0sGI6yAv+z9wVmFfPLFsTYOB09Fy+yht+E4Z9GOF6C/U79eb/y8QOuj1OJB3L+427IQpnJMuPh5e22LBM1E/eXLbvWyshKqX0n8WZj4qPezzsH21Afn+dUnd2jc2XqUbOpzeFkz45ut0okZAF3686/sQ0sBcloSFfvdB+EuLqZLJSYcnMe3Qe8dUpibgm5+v0XfgLZYPL2P7VpuMXkQB9neRbSCdTWojcABBwUGWV0DA=="|});
- ] |> Cohttp.Header.of_list in
- let sh = "signature" |> Cohttp.Header.get h |> Option.value ~default:"-" in
- sh
- |> Assrt.equals_string __LOC__ {|keyId="https://alpaka.social/users/traunstein#main-key",algorithm="rsa-sha256",headers="(request-target) host date digest content-type",signature="JIHBg3VahvgFweniUBfH0QSHOuilcYW313i7H6gptKT/uOSfs5QhADm7LKLZ6q7jZWtQLi4Ge8dhxVeYhGpdU5P3iABn665z3TvuUiwVUO0sGI6yAv+z9wVmFfPLFsTYOB09Fy+yht+E4Z9GOF6C/U79eb/y8QOuj1OJB3L+427IQpnJMuPh5e22LBM1E/eXLbvWyshKqX0n8WZj4qPezzsH21Afn+dUnd2jc2XqUbOpzeFkz45ut0okZAF3686/sQ0sBcloSFfvdB+EuLqZLJSYcnMe3Qe8dUpibgm5+v0XfgLZYPL2P7VpuMXkQB9neRbSCdTWojcABBwUGWV0DA=="|};
- (match sh |> Http.Signature.decode
- (* Http.Signature.decode *) with
- | Ok sh ->
- sh |> List.length |> Assrt.equals_int __LOC__ 4;
- List.assoc_opt "keyId" sh |> Option.value ~default:"-"
- |> Assrt.equals_string __LOC__ "https://alpaka.social/users/traunstein#main-key";
- List.assoc_opt "algorithm" sh |> Option.value ~default:"-"
- |> Assrt.equals_string __LOC__ "rsa-sha256";
- List.assoc_opt "headers" sh |> Option.value ~default:"-"
- |> Assrt.equals_string __LOC__ "(request-target) host date digest content-type";
- List.assoc_opt "signature" sh |> Option.value ~default:"-"
- |> Assrt.equals_string __LOC__ "JIHBg3VahvgFweniUBfH0QSHOuilcYW313i7H6gptKT/uOSfs5QhADm7LKLZ6q7jZWtQLi4Ge8dhxVeYhGpdU5P3iABn665z3TvuUiwVUO0sGI6yAv+z9wVmFfPLFsTYOB09Fy+yht+E4Z9GOF6C/U79eb/y8QOuj1OJB3L+427IQpnJMuPh5e22LBM1E/eXLbvWyshKqX0n8WZj4qPezzsH21Afn+dUnd2jc2XqUbOpzeFkz45ut0okZAF3686/sQ0sBcloSFfvdB+EuLqZLJSYcnMe3Qe8dUpibgm5+v0XfgLZYPL2P7VpuMXkQB9neRbSCdTWojcABBwUGWV0DA=="
- | _ -> "fail" |> Assrt.equals_string __LOC__ "");
- assert true
- let test_verify_basic () =
- Logr.info (fun m -> m "http_test.test_verify_basic");
- let pub = "data/cavage.pub.pem" |> File.to_string |> Ap.PubKeyPem.of_pem |> Result.get_ok in
- let request = Some("post", Uri.of_string "/foo?param=value&pet=dog") in
- let h = [
- ("some", "bogus");
- ("date", {|Sun, 05 Jan 2014 21:31:40 GMT|});
- ("signature", {|keyId="Test",algorithm="rsa-sha256",headers="(request-target) host date",signature="qdx+H7PHHDZgy4y/Ahn9Tny9V3GP6YgBPyUXMmoxWtLbHpUnXS2mg2+SbrQDMCJypxBLSPQR2aAjn7ndmw2iicw3HMbe8VfEdKFYRqzic+efkb3nndiv/x1xSHDJWeSWkx3ButlYSuBskLu6kd9Fswtemr3lgdDEmn04swr2Os0="|});
- ("more", "bogus");
- ("host", {|example.com|});
- ] |> Cohttp.Header.of_list in
- (* fetch http header values and map from lowercase plus the special name (request-target) *)
- let hdr = Cohttp.Header.get h in
- (* take a list of header names and fetch them incl. values. *)
- let hdrs =
- List.fold_left
- (fun init k ->
- (match hdr k with
- | None -> init
- | Some v -> Cohttp.Header.add init k v)
- )
- (Cohttp.Header.init ()) in
- let foo () =
- Logr.debug (fun m -> m "%s.%s get & parse the signature header" "Ap.Inbox" "post");
- let ( let* ) = Result.bind in
- let* si_v = "signature" |> hdr |> Option.to_result ~none:Http.s502' in
- let* si_v = si_v
- |> Http.Signature.decode
- |> Result.map_error
- (function
- | `NoMatch _
- | `ConverterFailure _ ->
- Logr.debug (fun m -> m "%s.%s Signature parsing failure" "Ap.Inbox" "post");
- Http.s502') in
- let* algo = si_v |> List.assoc_opt "algorithm" |> Option.to_result ~none:Http.s502' in
- let* heads = si_v |> List.assoc_opt "headers" |> Option.to_result ~none:Http.s502' in
- let heads = heads |> String.split_on_char ' ' in
- let* keyid = si_v |> List.assoc_opt "keyId" |> Option.to_result ~none:Http.s502' in
- let _keyid = keyid |> Uri.of_string in
- let* sign = si_v |> List.assoc_opt "signature" |> Option.to_result ~none:Http.s502' in
- let sign = sign |> Base64.decode_exn |> Cstruct.of_string in
- Logr.debug (fun m -> m "%s.%s fetch the remote actor profile & key" "Ap.Inbox" "post");
- Logr.debug (fun m -> m "%s.%s get the verified header values, signature algorithm %s" "Ap.Inbox" "post" algo);
- let uuid = Uuidm.v `V4 in
- let heads = heads |> hdrs in
- let* _ = heads
- |> Http.Signature.to_sign_string ~request
- |> Cstruct.of_string
- |> Ap.PubKeyPem.verify ~uuid ~algo pub sign
- |> Result.map_error (fun (`Msg e) ->
- Logr.warn (fun m -> m "%s.%s %s" "Ap.Inbox" "post" e);
- Http.s502') in
- Ok heads
- in
- let v l n = Cohttp.Header.get l n |> Option.value ~default:"?" in
- (match foo () with
- | Error _ -> "aua" |> Assrt.equals_string __LOC__ "-"
- | Ok h->
- h |> Cohttp.Header.to_list |> List.length |> Assrt.equals_int __LOC__ 2;
- "date" |> v h |> Assrt.equals_string __LOC__ "Sun, 05 Jan 2014 21:31:40 GMT";
- "host" |> v h |> Assrt.equals_string __LOC__ "example.com");
- assert true
- end
- let () =
- Logr.info (fun m -> m "http_test");
- Unix.chdir "../../../test/";
- test_relpa ();
- test_uri ();
- Request.test_uri ();
- Request.test_query_string ();
- Cookie.test_rfc1123 ();
- Cookie.test_to_string ();
- Cookie.test_of_string ();
- Form.test_of_channel ();
- Form.test_to_html ();
- Form.test_from_html ();
- Form.test_from_html1 ();
- Header.test_headers ();
- Header.test_signature ();
- Header.test_to_sign_string_basic ();
- Header.test_sign_basic ();
- Header.test_sign_all_headers ();
- Header.test_signed_headers ();
- Header.test_parse_auth_params ();
- Header.test_parse_signature ();
- Header.test_verify_basic ();
- assert true
|