sid: sid_test: add conformance mode imitating MS API

Add a conformance handler “Con_MS” to achieve a behavior that
mimicks that of MS’s implementation bug-for-bug.

Aspects of reading and formatting governd by the conformance:

    - Validation of ident auths,
    - validation of subauths,
    - validation of leading zeros in decimal numbers,
    - zero-padding of hex numbers.

3 files changed, 257 insertions, 67 deletions

diff --git a/sid.ml b/sid.ml
index e8bc4ad..17c8124 100644
--- a/sid.ml
+++ b/sid.ml
@@ -11,6 +11,8 @@ and sub_auths = U32.t array
 
 let sizeof_ident_auth = 6
 let max_ident_auth    = U64.of_string "0x0000_ffff_ffff_ffff"
+let ident_auth_hexlen = 14 (* 0x, 12 × hex digit *)
+let ident_auth_hexmin = U64.of_string "0x0001_0000_0000"
 let sizeof_sub_auth   = 4
 let max_subauth_count = 15
 
@@ -44,113 +46,198 @@ let equal a b =
   && Array.length a.sid_sub_auths = Array.length b.sid_sub_auths
   && equal_sub_auths a.sid_sub_auths b.sid_sub_auths
 
-module type Validator = sig
+module Util = struct
+  let expect_char s c p =
+    if s.[p] = c then () else
+    raise
+      (Invalid_argument
+         (Printf.sprintf
+            "Invalid SID [%s]: expected ‘%c’ at position %d, found ‘%c’"
+            s c p s.[p]))
+
+  let is_digit c = '0' <= c && c <= '9'
+
+  let is_xdigit c =
+       '0' <= c && c <= '9'
+    || 'a' <= c && c <= 'f'
+    || 'A' <= c && c <= 'F'
+end
+
+module type Conformance = sig
   val name : string
-  val ia : bool -> U64.t -> bool
-  val sas : U32.t array -> bool
+
+  val parse_hex_ia : string -> int -> U64.t * int
+  (** [parse_hex_ia raw p] read ia from [raw] at position [p] in hexadecimal,
+      return the value and the next position in the string. This only enforces
+      parsing behavior, not the value range. *)
+
+  val valid_decimal : string -> bool
+  (** [valid_decimal s] holds if [s] conforms to the constraints for decimal
+      numbers. Assumes the input already is all decimal digits. *)
+
+  val valid_ia : bool -> U64.t -> bool
+  (** [valid_ia ia] holds if [ia] is a valid identifier authority. *)
+
+  val valid_sas : U32.t array -> bool
+  (** [valid_sas sas] holds if [sas] is a valid array of
+      subauthorities. *)
+
+  val pad_hex_ia : int -> int
+  (** [pad n] return the number of padding zeros to prepend to the hex format
+      ident auth. *)
 end
 
-(** Validate as though the spec in [MS-DTYP] were normative. *)
-module Vtor_strict = struct
+(* Validate and convert as though the spec in [MS-DTYP] were normative. *)
+module Con_strict = struct
   let name = "strict"
 
-  let ident_auth_hexlen = 14 (* 0x, 12 × hex digit *)
-  let ident_auth_hexmin = U64.of_string "0x0001_0000_0000"
+  let parse_hex_ia s p =
+    assert (p <= String.length s - ident_auth_hexlen);
+    let e = p + ident_auth_hexlen - 1 in
+    let b = Bytes.make ident_auth_hexlen '\x2a' in
+    Bytes.set b 0 '0'; (* hex indicator for U64.of_string *)
+    Bytes.set b 1 'x';
+    for i = p + 2 to e do
+      (* assumption: prefix “0x” checked by caller *)
+      if not (Util.is_xdigit s.[i]) then
+        raise (Invalid_argument
+                 (Printf.sprintf
+                    "Invalid SID [%s]: expected hexadecimal digit at \
+                     position %d while parsing ident auth, got ‘%c’"
+                    s i s.[i]))
+    done;
+    Bytes.blit_string s (p+2) b 2 12;
+    U64.of_string (Bytes.unsafe_to_string b),
+    p + ident_auth_hexlen
+
+  (* leading zeros forbidden except for zero itself *)
+  let valid_decimal d =
+    String.length d > 0
+      && (String.length d = 1 || String.get d 0 <> '0')
 
-  let ia hex v =
+  let valid_ia hex v =
     if U64.compare v max_ident_auth > 0 then false else
     if not hex && U64.compare v ident_auth_hexmin >= 0 then false else
     not (hex && U64.compare v ident_auth_hexmin < 0)
 
-  let sas v =
+  let valid_sas v =
+    let nsa = Array.length v in
+    0 < nsa && nsa <= max_subauth_count
+
+  (* zero-pad to exactly twelve hex digits *)
+  let pad_hex_ia niax =
+    ident_auth_hexlen - niax
+end (* [module Con_strict] *)
+
+(* Validate simulating the empirically determined behavior of MS’s own
+   implementation “ConvertStringSidToSidA()”. The error code it returns
+   when rejecting an input is “ERROR_INVALID_SID”.
+
+    input                  | well-formed  parsed  |  round-trip           well-formed
+  -------------------------+----------------------+------------------------------------
+    S-1-0x000000000000-1   | no           yes     |  S-1-0-1              yes
+    S-1-0x0000000000ff-1   | no           yes     |  S-1-255-1            yes
+    S-1-0x0001000000ff-1   | yes          yes     |  S-1-0x1000000FF-1    no
+    S-1-0xffffffffffff-1   | yes          yes     |  S-1-0xFFFFFFFFFFFF-1 yes
+    S-1-0xff00ff00ff-1     | no           yes     |  S-1-0xFF00FF00FF-1   no
+    S-1-0xff00ff00ff00ff-1 | no           no      |  ø                    -
+    S-1-4294967296-1       | no           yes     |  S-1-0x100000000-1    no
+    S-1-01-1               | no           yes     |  S-1-1-1              yes
+    S-1-08-1               | no           yes     |  S-1-8-1              yes
+    S-1-001-1              | no           yes     |  S-1-1-1              yes
+    S-1-1                  | no           no      |  ø                    -
+    S-1-5                  | no           no      |  ø                    -
+
+   The inverse operations were modeled after “ConvertSidToStringSidA()”.
+*)
+module Con_MS = struct
+  let name = "MS"
+
+  let parse_hex_ia s p =
+    assert (String.length s - p - 2 > 0);
+    let e = p + ident_auth_hexlen in
+    let b = Buffer.create ident_auth_hexlen in
+    Buffer.add_string b "0x"; (* hex indicator for U64.of_string *)
+    let i = ref (p + 2) in
+    while !i < min (String.length s) e
+          && Util.is_xdigit s.[!i]
+    do
+      Buffer.add_char b s.[!i];
+      incr i;
+    done;
+    U64.of_string (Buffer.contents b),
+    !i
+
+  (* MS doesn’t care for leading zeros. *)
+  let valid_decimal d =
+    String.length d > 0
+
+  (* MS accepts hex-formatted ias of arbitrary values as long as they
+     fit a u64 *)
+  let valid_ia _hex v = true
+
+  (* Interestingly, subauths behave as specified. *)
+  let valid_sas v =
     let nsa = Array.length v in
     0 < nsa && nsa <= max_subauth_count
-end (* [module Vtor_strict] *)
+
+  (* No leading zeros in the hex output despite the spec mandating this
+     only for decimal formatting. *)
+  let pad_hex_ia _niax =
+    0
+end (* [module Con_strict] *)
 
 module type StringFmt_intf = sig
   val decode : string -> (sid, string) result
   val encode : sid -> string
 end
 
-module MkStringFmt (Vtor : Validator) = struct
-
-  let expect_char s c p =
-    if s.[p] = c then () else
-    raise
-      (Invalid_argument
-         (Printf.sprintf
-            "Invalid SID [%s]: expected ‘%c’ at position %d, found ‘%c’"
-            s c p s.[p]))
-
-  let is_digit c = '0' <= c && c <= '9'
-
-  let is_xdigit c =
-       '0' <= c && c <= '9'
-    || 'a' <= c && c <= 'f'
-    || 'A' <= c && c <= 'F'
+module MkStringFmt (Con : Conformance) = struct
 
   let read_decimal_string f s p =
     let n = String.length s in
     assert (p < n);
     let p' = ref p in
     let b = Buffer.create 16 in
-    while !p' < n && is_digit s.[!p'] do
+    while !p' < n && Util.is_digit s.[!p'] do
       Buffer.add_char b s.[!p'];
       incr p'
     done;
-    let nb = Buffer.length b in
-    if nb = 0 then
+    let d = Buffer.contents b in
+    if not (Con.valid_decimal d) then
       raise (Invalid_argument
                (Printf.sprintf
-                  "Invalid SID [%s]: expected decimal at position %d" s p))
+                  "Invalid SID [%s]: “%s” is not a valid decimal in mode %s"
+                  s d Con.name))
     else
-      p + nb,
-      f (Buffer.contents b)
+      p + String.length d,
+      f d
 
   let read_decimal_u64 = read_decimal_string U64.of_string
   let read_decimal_u32 = read_decimal_string U32.of_string
 
-  let ident_auth_hexlen = 14 (* 0x, 12 × hex digit *)
-  let ident_auth_hexmin = U64.of_string "0x0001_0000_0000"
-
   (* specialized cause only needed for ia *)
   let read_ident_auth_hex s p =
-    assert (p <= String.length s - ident_auth_hexlen);
-    let e = p + ident_auth_hexlen - 1 in
-    let b = Bytes.make ident_auth_hexlen '\x2a' in
-    Bytes.set b 0 '0'; (* hex indicator for U64.of_string *)
-    Bytes.set b 1 'x';
-    for i = p + 2 to e do
-      (* assumption: prefix “0x” checked by caller *)
-      if not (is_xdigit s.[i]) then
-        raise (Invalid_argument
-                 (Printf.sprintf
-                    "Invalid SID [%s]: expected hexadecimal digit at \
-                     position %d while parsing ident auth, got ‘%c’"
-                    s i s.[i]))
-    done;
-    Bytes.blit_string s (p+2) b 2 12;
-    let ia = U64.of_string (Bytes.unsafe_to_string b) in
-    if not (Vtor.ia true ia) then
+    let ia, p' = Con.parse_hex_ia s p in
+    if not (Con.valid_ia true ia) then
       raise
         (Invalid_argument
            (Printf.sprintf
               "input malformed: hex-encoded identifier authority failed \
                “%s” validation (value=%s)"
-              Vtor.name (U64.to_string ia)))
+              Con.name (U64.to_string ia)))
     else
-      p + ident_auth_hexlen,
-      ia
+    p', ia
 
   let ident_auth_decimal s p =
     let p, ia = read_decimal_u64 s p in
-    if not (Vtor.ia false ia) then
+    if not (Con.valid_ia false ia) then
       raise
         (Invalid_argument
            (Printf.sprintf
               "input malformed: decimal identifier authority failed \
                “%s” validation (value=%s)"
-              Vtor.name (U64.to_string ia))) else
+              Con.name (U64.to_string ia))) else
     p, ia
 
   let read_ident_auth s p =
@@ -173,10 +260,10 @@ module MkStringFmt (Vtor : Validator) = struct
            "Invalid SID: ‘%s’ too short to be a SID in string format" s)
     else begin
       try
-        expect_char s 'S' 0;
-        expect_char s '-' 1;
-        expect_char s '1' 2;
-        expect_char s '-' 3;
+        Util.expect_char s 'S' 0;
+        Util.expect_char s '-' 1;
+        Util.expect_char s '1' 2;
+        Util.expect_char s '-' 3;
         let p = 4 in
         let p, ia = read_ident_auth s p in
         let sa = ref [] and p' = ref p in
@@ -198,12 +285,12 @@ module MkStringFmt (Vtor : Validator) = struct
           p' := np
         done;
         let sas = Array.of_list (List.rev !sa) in
-        if not (Vtor.sas sas) then
+        if not (Con.valid_sas sas) then
           Error
             (Printf.sprintf
                "input malformed: subauthority list failed “%s” validation \
                 (count=%n)"
-               Vtor.name (Array.length sas))
+               Con.name (Array.length sas))
         else
           Ok { sid_ident_auth = ia
              ; sid_sub_auths  = sas
@@ -219,7 +306,7 @@ module MkStringFmt (Vtor : Validator) = struct
     else begin
       let iax = U64.to_string_hex ia in
       let niax = String.length iax in
-      let pad = ident_auth_hexlen - niax in
+      let pad = Con.pad_hex_ia niax in
       if pad = 0 then Buffer.add_string b iax else
       (Buffer.add_string b (String.sub ident_auth_blank 0 (2+pad));
        Buffer.add_string b (String.sub iax 2 (niax - 2)))
@@ -241,7 +328,8 @@ module MkStringFmt (Vtor : Validator) = struct
 
 end (* [module MkStringFmt] *)
 
-module StringFmt = MkStringFmt (Vtor_strict)
+module StringFmt = MkStringFmt (Con_strict)
+module MSStringFmt = MkStringFmt (Con_MS)
 
 module PacketRep = struct (* [MS-DTYP] 2.4.22 *)
 
diff --git a/sid.mli b/sid.mli
index e2c94df..a21c5ec 100644
--- a/sid.mli
+++ b/sid.mli
@@ -46,6 +46,17 @@ module StringFmt :
     (** [encode s] convert SID [s] to its string representation. *)
   end
 
+(** Conversions to and from the {e string format syntax} with permissive
+    input validation. *)
+module MSStringFmt :
+  sig
+    val decode : string -> (t, string) result
+    (** [decode b] parse string buffer [b] into a SID. *)
+
+    val encode : t -> string
+    (** [encode s] convert SID [s] to its string representation. *)
+  end
+
 (** Conversion to and from the {e packet representation} (MS-DTYP 2.4.2.2). *)
 module PacketRep :
   sig
diff --git a/sid_test.ml b/sid_test.ml
index 26a125b..b339190 100644
--- a/sid_test.ml
+++ b/sid_test.ml
@@ -255,6 +255,91 @@ let sf_print_iaxx_ok () =
     ~msg:(Printf.sprintf "[%s] ≠ [%s]" (Sid.to_string sid) str)
     (Sid.to_string sid) str
 
+let ms_unwrap_of_string s =
+  match Sid.MSStringFmt.decode s with
+    | Error e ->
+      assert_failure
+        (Printf.sprintf "error parsing assumed well-formed sid [%s]: %s" s e)
+    | Ok r -> r
+
+let mssf_parse_ok () =
+  (* accept well-formed input *)
+  let s = ms_unwrap_of_string "S-1-1-0"
+  and z = Sid.create_unsafe U64.one [| U32.zero |] in
+  assert_bool
+    (Printf.sprintf "[%s] ≠ [%s]" (Sid.to_string s) (Sid.to_string z))
+    (Sid.equal s z);
+  let w = Sid.WellKnown.world in
+  assert_bool
+    (Printf.sprintf "[%s] ≠ [well known: %s]"
+       (Sid.to_string s) (Sid.to_string w))
+    (Sid.equal s w)
+
+let mssf_parse_hex_junk_ok () =
+  (* accept certain kinds of malformed input; note: we expect hex digit
+     to be lowercase *)
+  let samples =
+    [ "S-1-0x000000000000-1"  , false, Some ("S-1-0-1"             , true )
+    ; "S-1-0x0000000000ff-1"  , false, Some ("S-1-255-1"           , true )
+    ; "S-1-0x0001000000ff-1"  , true , Some ("S-1-0x1000000ff-1"   , false)
+    ; "S-1-0xffffffffffff-1"  , true , Some ("S-1-0xffffffffffff-1", true )
+    ; "S-1-0xff00ff00ff-1"    , false, Some ("S-1-0xff00ff00ff-1"  , false)
+    ; "S-1-0xff00ff00ff00ff-1", false, None
+    ; "S-1-4294967296-1"      , false, Some ("S-1-0x100000000-1"   , false)
+    ; "S-1-01-1"              , false, Some ("S-1-1-1"             , true )
+    ; "S-1-08-1"              , false, Some ("S-1-8-1"             , true )
+    ; "S-1-001-1"             , false, Some ("S-1-1-1"             , true )
+    ; "S-1-1"                 , false, None
+    ; "S-1-5"                 , false, None
+    ]
+  in
+  let is_wellformed s =
+    match Sid.StringFmt.decode s with  Ok _ -> true | Error _ -> false in
+  let check (input, inwell, output) =
+    let () =
+      if is_wellformed input then
+        assert_bool
+          (Printf.sprintf "Sid [%s] parsed a-ok despite strict mode" input)
+          inwell
+      else
+        assert_bool
+          (Printf.sprintf "Sid [%s] failed to parse with strict mode" input)
+          (not inwell)
+    in
+    let () =
+      match Sid.MSStringFmt.decode input, output with
+        | Ok s, None ->
+          assert_bool
+            (Printf.sprintf "Sid [%s] unexpectedly parsed a-ok with MS mode"
+               input)
+            false
+        | Ok s, Some (output, outwell) -> (* test round-trip results *)
+          let reenc = Sid.MSStringFmt.encode s in
+          let () =
+            assert_bool
+              (Printf.sprintf "Sid [%s] re-encoded as [%s] failed to match \
+                               expected value of [%s]"
+                 input reenc output)
+              (output = reenc)
+          in (* finally: validate behavior of strict parse against output *)
+          assert_bool
+            (Printf.sprintf "Sid [%s] re-encoded as [%s] unexpectedly \
+                             %s in strict mode"
+               input reenc
+               (if outwell then "failed to parse" else "parsed ok"))
+            (is_wellformed reenc = outwell)
+        | Error _, None -> () (* bad even by MS standards *)
+        | Error e, Some (output, _) ->
+          assert_bool
+            (Printf.sprintf "Sid [%s] failed to parse in MS mode (%s), \
+                             expected [%s] after reconversion"
+               input e output)
+            false
+    in ()
+  in
+  List.iter check samples
+
+
 let pr_encode_null_ok () =
   let x =
     Sid.WellKnown.null
@@ -455,6 +540,11 @@ let string_format_test = "string-format-syntax" >:::
   ; "print-iaxx-ok"         >:: sf_print_iaxx_ok
   ]
 
+let ms_string_format_test = "ms-string-format-syntax" >:::
+  [ "parse-ok"              >:: mssf_parse_ok
+  ; "parse-hex-junk-ok"     >:: mssf_parse_hex_junk_ok
+  ]
+
 let packet_rep_test = "packet-rep" >:::
   [ "encode-null-ok"        >:: pr_encode_null_ok
   ; "encode-all-ok"         >:: pr_encode_all_ok
@@ -476,6 +566,7 @@ let toplevel_test = "toplevel" >:::
 
 let () =
   ignore (run_test_tt_main string_format_test);
-  ignore (run_test_tt_main packet_rep_test   );
-  ignore (run_test_tt_main toplevel_test   )
+  ignore (run_test_tt_main ms_string_format_test);
+  ignore (run_test_tt_main packet_rep_test);
+  ignore (run_test_tt_main toplevel_test)