sid: functorize well-formedness checks

Offload the test for member count and size constraints of sas and ia,
respectively, into a separate validation module. This is a preparatory
step toward adding less rigid parsing modes.

1 files changed, 51 insertions, 25 deletions

diff --git a/sid.ml b/sid.ml
index 4edcf5a..e8bc4ad 100644
--- a/sid.ml
+++ b/sid.ml
@@ -44,7 +44,35 @@ 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 StringFmt = struct
+module type Validator = sig
+  val name : string
+  val ia : bool -> U64.t -> bool
+  val sas : U32.t array -> bool
+end
+
+(** Validate as though the spec in [MS-DTYP] were normative. *)
+module Vtor_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 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 nsa = Array.length v in
+    0 < nsa && nsa <= max_subauth_count
+end (* [module Vtor_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
@@ -103,32 +131,26 @@ module StringFmt = struct
     done;
     Bytes.blit_string s (p+2) b 2 12;
     let ia = U64.of_string (Bytes.unsafe_to_string b) in
-    if ia < ident_auth_hexmin then
+    if not (Vtor.ia true ia) then
       raise
         (Invalid_argument
            (Printf.sprintf
-              "input malformed: identifier authority less than 2³² must \
-               not be hex-encoded (value=%s)"
-              (U64.to_string ia)))
-    else if ia > max_ident_auth then
-      raise (Invalid_argument
-               (Printf.sprintf
-                  "Invalid SID: identifier authority (value=%s) cannot fit \
-                   6 B (%s)"
-                  (U64.to_string ia) (U64.to_string max_ident_auth)))
+              "input malformed: hex-encoded identifier authority failed \
+               “%s” validation (value=%s)"
+              Vtor.name (U64.to_string ia)))
     else
       p + ident_auth_hexlen,
       ia
 
   let ident_auth_decimal s p =
     let p, ia = read_decimal_u64 s p in
-    if ia >= ident_auth_hexmin then
+    if not (Vtor.ia false ia) then
       raise
         (Invalid_argument
            (Printf.sprintf
-              "input malformed: identifier authority from 2³² on must \
-               be hex-encoded (value=%s)"
-              (U64.to_string ia))) else
+              "input malformed: decimal identifier authority failed \
+               “%s” validation (value=%s)"
+              Vtor.name (U64.to_string ia))) else
     p, ia
 
   let read_ident_auth s p =
@@ -157,12 +179,6 @@ module StringFmt = struct
         expect_char s '-' 3;
         let p = 4 in
         let p, ia = read_ident_auth s p in
-        if p = n || s.[p] <> '-' then
-          raise (Invalid_argument
-                   (Printf.sprintf
-                      "Invalid SID: error parsing SID [%s] at position %d, \
-                       grammar mandates at least one subauthority"
-                      s p)) else
         let sa = ref [] and p' = ref p in
         while !p' < n - 1
               && List.length !sa < max_subauth_count
@@ -181,9 +197,17 @@ module StringFmt = struct
           sa := d :: !sa;
           p' := np
         done;
-        Ok { sid_ident_auth = ia
-           ; sid_sub_auths  = Array.of_list (List.rev !sa)
-           }
+        let sas = Array.of_list (List.rev !sa) in
+        if not (Vtor.sas sas) then
+          Error
+            (Printf.sprintf
+               "input malformed: subauthority list failed “%s” validation \
+                (count=%n)"
+               Vtor.name (Array.length sas))
+        else
+          Ok { sid_ident_auth = ia
+             ; sid_sub_auths  = sas
+             }
       with Invalid_argument e -> Error e;
     end
 
@@ -215,7 +239,9 @@ module StringFmt = struct
     fmt_sub_auths  b s.sid_sub_auths;
     Buffer.contents b
 
-end (* [module StringFmt] *)
+end (* [module MkStringFmt] *)
+
+module StringFmt = MkStringFmt (Vtor_strict)
 
 module PacketRep = struct (* [MS-DTYP] 2.4.22 *)