unikernel/duniverse/ocaml-dns/test/test_rfc9460.ml

@@ -0,0 +1,663 @@
+
+open Dns
+
+(* a useful reference : https://kalfeher.com/https-records-simple/*)
+
+let n_of_s = Domain_name.of_string_exn
+
+
+let name_map_ok =
+    let module M = struct
+      type t = Name_rr_map.t
+      let pp = Name_rr_map.pp
+      let equal = Name_rr_map.equal
+    end in
+    (module M: Alcotest.TESTABLE with type t = M.t)
+
+let err =
+    let module M = struct
+        type t = [ `Msg of string ]
+        let pp ppf (`Msg s) = Fmt.string ppf s
+        let equal _ _ = true
+    end in
+    (module M: Alcotest.TESTABLE with type t = M.t)
+    
+module Passing = struct
+
+(* 
+From appendix D - test vectors
+
+D.1. AliasMode
+--------------
+
+; AliasMode
+example.com. HTTPS 0 foo.example.com.
+
+\# 19 (
+00 00                                              ; priority
+03 66 6f 6f 07 65 78 61 6d 70 6c 65 03 63 6f 6d 00 ; target
+)
+
+\x00\x00                      # priority
+\x03foo\x07example\x03com\x00 # target
+*)
+
+let alias_mode = {|
+; AliasMode
+example.com. HTTPS 0 foo.example.com.
+|}
+
+let parse_alias_mode () =
+  let rrs =
+    (* let tld = n_of_s "com" in *)
+      let ttl = 3600l in
+    let example = n_of_s "example.com" in
+    let foo_example = n_of_s "foo.example.com" in
+    let https = Https.{
+        svc_priority = 0 ;
+        target_name = Domain_name.host_exn foo_example ;
+        svc_params = [] ;
+      } in
+      let https' = Rr_map.Https_set.singleton https in
+      Name_rr_map.add example Rr_map.Https (ttl,https') Name_rr_map.empty
+  in
+  Alcotest.(check (result name_map_ok err) "alias mode"
+                (Ok rrs)  (Dns_zone.parse alias_mode))
+
+(* 
+
+D.2. ServiceMode
+----------------
+
+; TargetName Is "."
+example.com. SVCB 1 .
+
+\# 3 (
+00 01 ; priority
+00    ; target (root label)
+)
+
+\x00\x01 # priority
+\x00     # target (root label)
+*)
+
+let service_mode = {|
+; TargetName Is "."
+example.com. SVCB 1 .
+|}
+
+(* 
+let parse_service_mode () =
+  let rrs =
+    (* let tld = n_of_s "com" in *)
+      let ttl = 3600l in
+    let example = n_of_s "example.com" in
+    let dot = n_of_s "." in
+    let svcb = Svcb.{
+        svc_priority = 0 ;
+        (* target_name = Domain_name.host_exn dot ; *)
+        target_name = Domain_name. dot ;
+        svc_params = [] ;
+      } in
+      let svcb' = Rr_map.Svcb_set.singleton svcb in
+      Name_rr_map.add example Rr_map.Svcb (ttl,svcb') Name_rr_map.empty
+  in
+  Alcotest.(check (result name_map_ok err) "service mode"
+                (Ok rrs)  (Dns_zone.parse alias_mode))
+ *)
+
+(*
+; Specifies a port
+example.com. SVCB 16 foo.example.com. port=53
+
+\# 25 (
+00 10                                              ; priority
+03 66 6f 6f 07 65 78 61 6d 70 6c 65 03 63 6f 6d 00 ; target
+00 03                                              ; key 3
+00 02                                              ; length 2
+00 35                                              ; value
+)
+
+\x00\x10                      # priority
+\x03foo\x07example\x03com\x00 # target
+\x00\x03                      # key 3
+\x00\x02                      # length 2
+\x00\x35                      # value
+
+*)
+
+let port_specification = {|
+; Specifies a port
+example.com. SVCB 16 foo.example.com. port=53
+|}
+
+let parse_port_specification () =
+  let rrs =
+    (* let tld = n_of_s "com" in *)
+      let ttl = 3600l in
+    let example = n_of_s "example.com" in
+    let foo_example = n_of_s "foo.example.com" in
+    let svcb = Svcb.{
+        svc_priority = 16 ;
+        target_name = Domain_name.host_exn foo_example ;
+        svc_params = [
+          Port 53
+        ] ;
+      } in
+      let svcb' = Rr_map.Svcb_set.singleton svcb in
+      Name_rr_map.add example Rr_map.Svcb (ttl,svcb') Name_rr_map.empty
+  in
+  Alcotest.(check (result name_map_ok err) "port specification"
+                (Ok rrs)  (Dns_zone.parse port_specification))
+
+
+(*
+; A Generic Key and Unquoted Value
+example.com. SVCB 1 foo.example.com. key667=hello
+
+\# 28 (
+00 01                                              ; priority
+03 66 6f 6f 07 65 78 61 6d 70 6c 65 03 63 6f 6d 00 ; target
+02 9b                                              ; key 667
+00 05                                              ; length 5
+68 65 6c 6c 6f                                     ; value
+)
+
+\x00\x01                      # priority
+\x03foo\x07example\x03com\x00 # target
+\x02\x9b                      # key 667
+\x00\x05                      # length 5
+hello                         # value
+*)
+
+let value_unquoted = {|
+; A Generic Key and Unquoted Value
+example.com. SVCB 1 foo.example.com. key667=hello
+|}
+
+let parse_value_unquoted () =
+  let rrs =
+    (* let tld = n_of_s "com" in *)
+      let ttl = 3600l in
+    let example = n_of_s "example.com" in
+    let foo_example = n_of_s "foo.example.com" in
+    let svcb = Svcb.{
+        svc_priority = 1 ;
+        target_name = Domain_name.host_exn foo_example ;
+        svc_params = [
+          Key (667,"hello")
+        ] ;
+      } in
+      let svcb' = Rr_map.Svcb_set.singleton svcb in
+      Name_rr_map.add example Rr_map.Svcb (ttl,svcb') Name_rr_map.empty
+  in
+  Alcotest.(check (result name_map_ok err) "value unquoted"
+                (Ok rrs)  (Dns_zone.parse value_unquoted))
+
+
+
+(*
+; A Generic Key and Quoted Value with a Decimal Escape
+example.com. SVCB 1 foo.example.com. key667="hello\210qoo"
+
+\# 32 (
+00 01                                              ; priority
+03 66 6f 6f 07 65 78 61 6d 70 6c 65 03 63 6f 6d 00 ; target
+02 9b                                              ; key 667
+00 09                                              ; length 9
+68 65 6c 6c 6f d2 71 6f 6f                         ; value
+)
+
+\x00\x01                      # priority
+\x03foo\x07example\x03com\x00 # target
+\x02\x9b                      # key 667
+\x00\x09                      # length 9
+hello\xd2qoo                  # value
+*)
+(* 
+let quoted = {|
+; A Generic Key and Quoted Value with a Decimal Escape
+example.com. SVCB 1 foo.example.com. key667="hello\210qoo"
+|}
+
+let parse_quoted () =
+  let rrs =
+    (* let tld = n_of_s "com" in *)
+      let ttl = 3600l in
+    let example = n_of_s "example.com" in
+    let foo_example = n_of_s "foo.example.com" in
+    let svcb = Svcb.{
+        svc_priority = 1 ;
+        target_name = Domain_name.host_exn foo_example ;
+        svc_params = [
+          Key (667,"hello\\210qoo")
+        ] ;
+      } in
+      let svcb' = Rr_map.Svcb_set.singleton svcb in
+      Name_rr_map.add example Rr_map.Svcb (ttl,svcb') Name_rr_map.empty
+  in
+  Alcotest.(check (result name_map_ok err) "value quoted"
+                (Ok rrs)  (Dns_zone.parse value_unquoted))
+ *)
+
+(*
+; Two Quoted IPv6 Hints
+example.com. SVCB 1 foo.example.com. (
+                  ipv6hint="2001:db8::1,2001:db8::53:1"
+                  )
+
+\# 55 (
+00 01                                              ; priority
+03 66 6f 6f 07 65 78 61 6d 70 6c 65 03 63 6f 6d 00 ; target
+00 06                                              ; key 6
+00 20                                              ; length 32
+20 01 0d b8 00 00 00 00 00 00 00 00 00 00 00 01    ; first address
+20 01 0d b8 00 00 00 00 00 00 00 00 00 53 00 01    ; second address
+)
+
+\x00\x01                             # priority
+\x03foo\x07example\x03com\x00        # target
+\x00\x06                             # key 6
+\x00\x20                             # length 32
+\x20\x01\x0d\xb8\x00\x00\x00\x00
+    \x00\x00\x00\x00\x00\x00\x00\x01 # first address
+\x20\x01\x0d\xb8\x00\x00\x00\x00
+    \x00\x00\x00\x00\x00\x53\x00\x01 # second address
+*)
+
+let quoted_hints = {|
+; Two Quoted IPv6 Hints
+example.com. SVCB 1 foo.example.com. (
+                  ipv6hint="2001:db8::1,2001:db8::53:1"
+                  )
+|}
+
+let parse_quoted_hints () =
+  (* let ip1 = Result.get_ok (Ipaddr.V6.of_string "2001:db8::1") in
+  let ip2 = Result.get_ok (Ipaddr.V6.of_string "2001:db8::53:1") in *)
+  let ip1 = Ipaddr.V6.of_string_exn "2001:db8::1" in
+  let ip2 = Ipaddr.V6.of_string_exn "2001:db8::53:1" in
+  let rrs =
+    (* let tld = n_of_s "com" in *)
+      let ttl = 3600l in
+    let example = n_of_s "example.com" in
+    let foo_example = n_of_s "foo.example.com" in
+    let svcb = Svcb.{
+        svc_priority = 1 ;
+        target_name = Domain_name.host_exn foo_example ;
+        svc_params = [
+          Ipv6_hint [ip1;ip2]
+        ] ;
+      } in
+      let svcb' = Rr_map.Svcb_set.singleton svcb in
+      Name_rr_map.add example Rr_map.Svcb (ttl,svcb') Name_rr_map.empty
+  in
+  Alcotest.(check (result name_map_ok err) "quoted hints"
+                (Ok rrs)  (Dns_zone.parse quoted_hints))
+
+
+
+(*
+; An IPv6 Hint Using the Embedded IPv4 Syntax
+example.com. SVCB 1 example.com. (
+                  ipv6hint="2001:db8:122:344::192.0.2.33"
+                  )
+
+\# 35 (
+00 01                                           ; priority
+07 65 78 61 6d 70 6c 65 03 63 6f 6d 00          ; target
+00 06                                           ; key 6
+00 10                                           ; length 16
+20 01 0d b8 01 22 03 44 00 00 00 00 c0 00 02 21 ; address
+)
+
+\x00\x01                         # priority
+\x07example\x03com\x00           # target
+\x00\x06                         # key 6
+\x00\x10                         # length 16
+\x20\x01\x0d\xb8\x01\x22\x03\x44
+\x00\x00\x00\x00\xc0\x00\x02\x21 # address
+*)
+(* 
+let generic_key_and_quoted_hints = {|
+; An IPv6 Hint Using the Embedded IPv4 Syntax
+example.com. SVCB 1 example.com. (
+                  ipv6hint="2001:db8:122:344::192.0.2.33"
+                  )
+|}
+
+let parse_generic_key_and_quoted_hints () =
+  let ip1 = Result.get_ok (Ipaddr.V6.of_string "2001:db8:122:344") in
+  let ip2 = Result.get_ok (Ipaddr.V4.of_string "192.0.2.33") in
+  let rrs =
+    (* let tld = n_of_s "com" in *)
+      let ttl = 3600l in
+    let example = n_of_s "example.com" in
+    let foo_example = n_of_s "foo.example.com" in
+    let svcb = Svcb.{
+        svc_priority = 1 ;
+        target_name = Domain_name.host_exn foo_example ;
+        svc_params = [
+          Ipv6_hint [ip1;ip2]
+        ] ;
+      } in
+      let svcb' = Rr_map.Svcb_set.singleton svcb in
+      Name_rr_map.add example Rr_map.Svcb (ttl,svcb') Name_rr_map.empty
+  in
+  Alcotest.(check (result name_map_ok err) "generic key and quoted hints"
+                (Ok rrs)  (Dns_zone.parse generic_key_and_quoted_hints))
+ *)
+
+
+(*
+; SvcParamKey Ordering Is Arbitrary in Presentation Format but Sorted in Wire Format
+example.com. SVCB 16 foo.example.org. (
+                  alpn=h2,h3-19 mandatory=ipv4hint,alpn
+                  ipv4hint=192.0.2.1
+                  )
+
+\# 48 (
+00 10                                              ; priority
+03 66 6f 6f 07 65 78 61 6d 70 6c 65 03 6f 72 67 00 ; target
+00 00                                              ; key 0
+00 04                                              ; param length 4
+00 01                                              ; value: key 1
+00 04                                              ; value: key 4
+00 01                                              ; key 1
+00 09                                              ; param length 9
+02                                                 ; alpn length 2
+68 32                                              ; alpn value
+05                                                 ; alpn length 5
+68 33 2d 31 39                                     ; alpn value
+00 04                                              ; key 4
+00 04                                              ; param length 4
+c0 00 02 01                                        ; param value
+)
+
+\x00\x10                      # priority
+\x03foo\x07example\x03org\x00 # target
+\x00\x00                      # key 0
+\x00\x04                      # param length 4
+\x00\x01                      # value: key 1
+\x00\x04                      # value: key 4
+\x00\x01                      # key 1
+\x00\x09                      # param length 9
+\x02                          # alpn length 2
+h2                            # alpn value
+\x05                          # alpn length 5
+h3-19                         # alpn value
+\x00\x04                      # key 4
+\x00\x04                      # param length 4
+\xc0\x00\x02\x01              # param value
+*)
+
+(*
+(
+                  alpn=h2,h3-19 mandatory=ipv4hint,alpn
+                  ipv4hint=192.0.2.1
+                  )
+*)
+
+let svc_param_key_ordering = {|
+; SvcParamKey Ordering Is Arbitrary in Presentation Format but Sorted in Wire Format
+example.com. SVCB 16 foo.example.org. (
+                  alpn=h2,h3-19 mandatory=ipv4hint,alpn
+                  ipv4hint=192.0.2.1
+                  )
+|}
+
+let parse_svc_param_key_ordering () =
+  let ip = Ipaddr.V4.of_string_exn "192.0.2.1" in
+  let rrs =
+    (* let tld = n_of_s "com" in *)
+    let ttl = 3600l in
+    let example = n_of_s "example.com" in
+    let foo_example = n_of_s "foo.example.org" in
+    let svcb = Svcb.{
+        svc_priority = 16 ;
+        target_name = Domain_name.host_exn foo_example ;
+        svc_params = [
+          Mandatory [1;4];
+          Alpn ["h2"; "h3-19"];
+          Ipv4_hint [ip]
+        ] ;
+      } in
+      let svcb' = Rr_map.Svcb_set.singleton svcb in
+      Name_rr_map.add example Rr_map.Svcb (ttl,svcb') Name_rr_map.empty
+  in
+  Alcotest.(check (result name_map_ok err) "svc param key ordering"
+                (Ok rrs)  (Dns_zone.parse svc_param_key_ordering))
+
+                (*
+                
+          Mandatory [1;4];
+          Alpn ["h2"; "h3-19"];
+          Ipv4_hint [ip]
+          
+          *)
+
+(*
+; An "alpn" Value with an Escaped Comma and an Escaped Backslash in Two Presentation Formats
+example.com. SVCB 16 foo.example.org. alpn="f\\\\oo\\,bar,h2"
+example.com. SVCB 16 foo.example.org. alpn=f\\\092oo\092,bar,h2
+
+\# 35 (
+00 10                                              ; priority
+03 66 6f 6f 07 65 78 61 6d 70 6c 65 03 6f 72 67 00 ; target
+00 01                                              ; key 1
+00 0c                                              ; param length 12
+08                                                 ; alpn length 8
+66 5c 6f 6f 2c 62 61 72                            ; alpn value
+02                                                 ; alpn length 2
+68 32                                              ; alpn value
+)
+
+\x00\x10                      # priority
+\x03foo\x07example\x03org\x00 # target
+\x00\x01                      # key 1
+\x00\x0c                      # param length 12
+\x08                          # alpn length 8
+f\oo,bar                      # alpn value
+\x02                          # alpn length 2
+h2                            # alpn value
+*)
+
+let escaped_comma_backslash = {|
+; An "alpn" Value with an Escaped Comma and an Escaped Backslash in Two Presentation Formats
+example.com. SVCB 16 foo.example.org. alpn="f\\\\oo\\,bar,h2"
+example.com. SVCB 16 foo.example.org. alpn=f\\\092oo\092,bar,h2
+|}
+
+
+let parse_escaped_comma_backslash () =
+  let rrs =
+    let ttl = 3600l in
+    let example = n_of_s "example.com" in
+    let foo_example = n_of_s "foo.example.org" in
+    let svcb1 = Svcb.{
+        svc_priority = 16 ;
+        target_name = Domain_name.host_exn foo_example ;
+        svc_params = [
+          Alpn ["\"f\\\\\\\\oo\\\\"; "bar"; "h2\""]
+        ] ;
+      } in
+    let svcb1' = Rr_map.Svcb_set.singleton svcb1 in
+    let svcb2 = Svcb.{
+        svc_priority = 16 ;
+        target_name = Domain_name.host_exn foo_example ;
+        svc_params = [
+          Alpn ["f\\\\\\092oo\\092"; "bar"; "h2"]
+        ] ;
+      } in
+    let svcb2' = Rr_map.Svcb_set.singleton svcb2 in
+    Name_rr_map.(add example Rr_map.Svcb (ttl,svcb2') (singleton example Rr_map.Svcb (ttl,svcb1')));
+  in
+  Alcotest.(check (result name_map_ok err) "escaped comma backslash"
+                (Ok rrs)  (Dns_zone.parse escaped_comma_backslash))
+
+    let tests = [
+        "parse alias mode", `Quick, parse_alias_mode;
+        (* "parse service mode", `Quick, parse_service_mode; *) (* failing on target = '.' *)
+        "parse port specification", `Quick, parse_port_specification;
+        "parse value unquoted", `Quick, parse_value_unquoted;
+        (* "parse quoted", `Quick, parse_quoted; *)
+        "quoted hints", `Quick, parse_quoted_hints;
+        (* "generic key and quoted hints", `Quick, parse_generic_key_and_quoted_hints; *) (* need to implement happy eyeballs v2 synthesis*)
+        "svc param key ordering", `Quick, parse_svc_param_key_ordering;
+        "escaped comma backslash", `Quick, parse_escaped_comma_backslash
+    ]
+
+end
+
+
+module Failing = struct
+(* 
+
+Failure Cases
+-------------
+
+; Multiple Instances of the Same SvcParamKey
+example.com. SVCB 1 foo.example.com. (
+                  key123=abc key123=def
+                  )
+*)
+
+let failure_svc_param_key = {|
+; Multiple Instances of the Same SvcParamKey
+example.com. SVCB 1 foo.example.com. (
+                  key123=abc key123=def
+                  )
+|}
+
+let parse_failure_svc_param_key () =
+  let _rrs =
+    let ttl = 3600l in
+    let example = n_of_s "example.com" in
+    let foo_example = n_of_s "foo.example.com" in
+    let svcb = Svcb.{
+        svc_priority = 1 ;
+        target_name = Domain_name.host_exn foo_example ;
+        svc_params = [
+          Key (123,"abc");
+          Key (123,"def")
+        ]
+      } in
+      let svcb' = Rr_map.Svcb_set.singleton svcb in
+      Name_rr_map.add example Rr_map.Svcb (ttl,svcb') Name_rr_map.empty
+  in
+  Alcotest.(check (result name_map_ok err) "failure svc param key"
+                (Error (`Msg "SVCB : multiple instances of the same SvcParamKey"))  (Dns_zone.parse failure_svc_param_key))
+
+
+(*
+; Missing SvcParamValues That Must Be Non-Empty
+example.com. SVCB 1 foo.example.com. mandatory
+example.com. SVCB 1 foo.example.com. alpn
+example.com. SVCB 1 foo.example.com. port
+example.com. SVCB 1 foo.example.com. ipv4hint
+example.com. SVCB 1 foo.example.com. ipv6hint
+*)
+(* 
+let failure_missing_svc_param_values = {|
+; Missing SvcParamValues That Must Be Non-Empty
+example.com. SVCB 1 foo.example.com. mandatory
+example.com. SVCB 1 foo.example.com. alpn
+example.com. SVCB 1 foo.example.com. port
+example.com. SVCB 1 foo.example.com. ipv4hint
+example.com. SVCB 1 foo.example.com. ipv6hint
+|}
+
+Unable to build the key
+ *)
+
+(*
+; The "no-default-alpn" SvcParamKey Value Must Be Empty
+example.com. SVCB 1 foo.example.com. no-default-alpn=abc
+*)
+(* 
+let failure_no_default_alpn_not_empty = {|
+; The "no-default-alpn" SvcParamKey Value Must Be Empty
+example.com. SVCB 1 foo.example.com. no-default-alpn=abc
+|}
+
+Unable to build the key
+ *)
+
+(*
+; A Mandatory SvcParam Is Missing
+example.com. SVCB 1 foo.example.com. mandatory=key123
+*)
+(* 
+let failure_mandatory_svc_param_missing = {|
+; A Mandatory SvcParam Is Missing
+example.com. SVCB 1 foo.example.com. mandatory=key123
+|}
+
+Unable to build the key
+ *)
+(*
+; The "mandatory" SvcParamKey Must Not Be Included in the Mandatory List
+example.com. SVCB 1 foo.example.com. mandatory=mandatory
+*)
+(* 
+let failure_mandatory_in_mandatory_list = {|
+; The "mandatory" SvcParamKey Must Not Be Included in the Mandatory List
+example.com. SVCB 1 foo.example.com. mandatory=mandatory
+                  )
+|}
+
+Unable to build the key
+ *)
+(*
+; Multiple Instances of the Same SvcParamKey in the Mandatory List
+example.com. SVCB 1 foo.example.com. (
+                  mandatory=key123,key123 key123=abc
+                  )
+*)
+
+let failure_key_repitition_in_mandatory_list = {|
+; Multiple Instances of the Same SvcParamKey in the Mandatory List
+example.com. SVCB 1 foo.example.com. (
+                  mandatory=key123,key123 key123=abc
+                  )
+|}
+
+let parse_key_repitition_in_mandatory_list () =
+  let _rrs =
+    let ttl = 3600l in
+    let example = n_of_s "example.com" in
+    let foo_example = n_of_s "foo.example.com" in
+    let svcb = Svcb.{
+        svc_priority = 1 ;
+        target_name = Domain_name.host_exn foo_example ;
+        svc_params = [
+          Mandatory [123;123];
+          Key (123,"abc")
+        ]
+      } in
+      let svcb' = Rr_map.Svcb_set.singleton svcb in
+      Name_rr_map.add example Rr_map.Svcb (ttl,svcb') Name_rr_map.empty
+  in
+  Alcotest.(check (result name_map_ok err) "failure key repitition in mandatory list"
+          (Error (`Msg ""))  (Dns_zone.parse failure_key_repitition_in_mandatory_list))
+
+
+    let tests = [
+        "failure_svc_param_key", `Quick, parse_failure_svc_param_key;
+        "key repitition in mandatory list", `Quick, parse_key_repitition_in_mandatory_list
+    ]
+
+end
+
+
+let tests = [
+  "rfc9460 passing", Passing.tests ;
+  "rfc9460 failing", Failing.tests
+]
+
+let () =
+  Printexc.record_backtrace true;
+  Logs.set_reporter (Logs_fmt.reporter ());
+  Logs.set_level ~all:true (Some Logs.Debug);
+  Alcotest.run "rfc9460 tests" tests
+