(* SPDX-License-Identifier: LGPL-3.0-only WITH OCaml-LGPL-linking-exception *)

module U64 = Stdint.Uint64
module U32 = Stdint.Uint32

type sid =
  { sid_ident_auth : U64.t (* 6 B *)
  ; sid_sub_auths  : U32.t array (* max. 15 × *)
  }
and sub_auths = U32.t array

let sizeof_ident_auth = 6
let max_ident_auth    = U64.of_string "0x0000_ffff_ffff_ffff"
let sizeof_sub_auth   = 4
let max_subauth_count = 15

let create_unsafe sa ia =
  { sid_ident_auth = ia
  ; sid_sub_auths  = sa }

(* There isn’t much to validate to begin with except for the hard cap on
   the number of subauths. *)
let create ?(sa=[||]) ia =
  if Array.length sa > max_subauth_count then None else
  if U64.compare ia max_ident_auth > 0 then None else
  Some (create_unsafe sa ia)

let get_ident_auth s = s.sid_ident_auth
let get_sub_auths s = s.sid_sub_auths

exception Nope

let equal_sub_auths saa sab =
  try
    Array.iter2
      (fun saa sab -> if U32.compare saa sab <> 0 then raise Nope)
      saa sab;
    true
  with Nope -> false

let equal a b =
  U64.compare a.sid_ident_auth b.sid_ident_auth = 0
  && 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

  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'

  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
      Buffer.add_char b s.[!p'];
      incr p'
    done;
    let nb = Buffer.length b in
    if nb = 0 then
      raise (Invalid_argument
               (Printf.sprintf
                  "Invalid SID [%s]: expected decimal at position %d" s p))
    else
      p + nb,
      f (Buffer.contents b)

  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;
    p + ident_auth_hexlen,
    U64.of_string (Bytes.unsafe_to_string b)

  let ident_auth_decimal s p =
    let p, ia = read_decimal_u64 s p in
    if ia >= ident_auth_hexmin then
      raise
        (Invalid_argument
           (Printf.sprintf
              "input malformed: identifier authority from 2³² on must \
               be hex-encoded (value=%s)"
              (U64.to_string ia))) else
    p, ia

  let read_ident_auth s p =
    let r = String.length s - p in
    if r < ident_auth_hexlen then ident_auth_decimal s p else (* hex can’t fit *)
    match s.[p], s.[p+1] with
      | '0', 'x' ->
        (let p, ia = read_ident_auth_hex s p in
         if ia < ident_auth_hexmin 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
         p, ia)
      | _ -> ident_auth_decimal s p

  (*
   * The spec ([MS-DTYP]):
   *
   *    2.4.2.1: SID= "S-1-" IdentifierAuthority 1*SubAuthority
   *)
  let decode s =
    let n = String.length s in
    if n <= 4 then
      Error
        (Printf.sprintf
           "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;
        let p = 4 in
        let p, ia = read_ident_auth s p in
        if ia > max_ident_auth then
          raise (Invalid_argument
                   (Printf.sprintf
                      "Invalid SID: identifier authority cannot fit 6 B (%s)"
                      (U64.to_string max_ident_auth)));
        let sa = ref [] and p' = ref p in
        while !p' < n - 1 && List.length !sa < max_subauth_count do
          expect_char s '-' !p';
          let np, d =
            try read_decimal_u32 s (!p' + 1)
            with Invalid_argument e ->
              (* Brr, but Stdint’s error messages aren’t overly instructive. *)
              raise (Invalid_argument
                       (Printf.sprintf
                          "Invalid SID: error parsing subauth at position %d, \
                           (err: %s)"
                          (!p' + 1) e))
          in
          sa := d :: !sa;
          p' := np
        done;
        Ok { sid_ident_auth = ia
           ; sid_sub_auths  = Array.of_list (List.rev !sa)
           }
      with Invalid_argument e -> Error e;
    end

  let ident_auth_blank = "0x000000000000"

  let fmt_ident_auth b ia =
    if U64.compare ia ident_auth_hexmin < 0 then
      Buffer.add_string b (U64.to_string ia)
    else begin
      let iax = U64.to_string_hex ia in
      let niax = String.length iax in
      let pad = ident_auth_hexlen - 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)))
    end

  let fmt_sub_auths b sas =
    Array.iter
      (fun sa ->
         Buffer.add_char b '-';
         Buffer.add_string b (U32.to_string sa))
      sas

  let encode s =
    let b = Buffer.create 16 in
    Buffer.add_string b "S-1-";
    fmt_ident_auth b s.sid_ident_auth;
    fmt_sub_auths  b s.sid_sub_auths;
    Buffer.contents b

end (* [module StringFmt] *)

module PacketRep = struct (* [MS-DTYP] 2.4.22 *)

  type endian = Big | Little

  let wordlen        = 4 (* sizeof int *)
  let min_pktrep_len = 1 + 1 + sizeof_ident_auth
  let max_pktrep_len = 1 + 1
                     + sizeof_ident_auth
                     + max_subauth_count * sizeof_sub_auth
  let pktrep_sa_off  = min_pktrep_len

  let encode ?(endian=Little) s =
    let nsa = Array.length s.sid_sub_auths in
    let l = 8 + nsa * sizeof_sub_auth in
    let b = Bytes.create l in
    let o = ref 0 in
    let pushbyte c = char_of_int c |> Bytes.set b !o; incr o in

    assert (0 <= nsa && nsa <= 15);

    pushbyte 1;
    pushbyte nsa;

    let getia n =
      pushbyte (U64.to_int (U64.shift_right s.sid_ident_auth n) land 0xff)
    in (* big endian!, cf. [MS-DTYP] 2.4.1.1 *)
    getia 5; getia 4; getia 3; getia 2; getia 1; getia 0;

    let write_u32 =
      match endian with
        | Big    -> U32.to_bytes_big_endian
        | Little -> U32.to_bytes_little_endian
    in
    Array.iteri
      (fun i sa ->
         let o' = !o + i * wordlen in
         write_u32 sa b o')
      s.sid_sub_auths;
    b

  let decode ?(endian=Little) b =
    let l = Bytes.length b in
    if l < min_pktrep_len || max_pktrep_len < l then
      Error (Printf.sprintf
               "bad input size: expected %d–%d B, got %d B"
               min_pktrep_len max_pktrep_len l) else
    if l mod wordlen <> 0 then
      Error (Printf.sprintf
               "bad input size: not divisible by word length (%d)"
               wordlen) else
    let v = Bytes.get b 0 |> int_of_char in
    if v <> 0x01 then
      Error (Printf.sprintf
               "input malformed: expected SID version=0x01, got 0x%0.2x" v) else
    let nsa = Bytes.get b 1 |> int_of_char in
    if max_subauth_count < nsa then
      Error (Printf.sprintf
               "input malformed: up to %d subAuthority elements permitted, \
                %d specified"
               max_subauth_count nsa) else
    let ia = U64.of_bytes_big_endian b 0 |> U64.logand max_ident_auth in
    let sas = Array.make nsa (U32.zero)
    and read_u32 =
      match endian with
        | Big    -> U32.of_bytes_big_endian
        | Little -> U32.of_bytes_little_endian
    in
    for i = 0 to (nsa - 1) do
      let off = pktrep_sa_off + i * sizeof_sub_auth in
      sas.(i) <- read_u32 b off
    done;
    Ok { sid_ident_auth = ia
       ; sid_sub_auths  = sas
       }

  let from_channel ?(endian=Little) ic =
    try
      let v = input_byte ic in
      if v <> 0x01 then
        Error (Printf.sprintf
                 "input malformed: expected SID version=0x01, got 0x%0.2x" v) else
      let nsa = input_byte ic in
      if max_subauth_count < nsa then
        Error (Printf.sprintf
                 "input malformed: up to %d subAuthority elements permitted, \
                  %d specified"
                 max_subauth_count nsa) else
      let n = sizeof_ident_auth + nsa * sizeof_sub_auth in
      let b = Bytes.make (2 + n) '\x00' in
      Bytes.set b 0 '\x01';
      Bytes.set b 1 (char_of_int nsa);
      really_input ic b 2 n;
      decode ~endian b
    with End_of_file ->
      Error (Printf.sprintf
               "input malformed: unexpected end of file at offset %d \
                parsing SID" (pos_in ic))

  let to_channel ?(endian=Little) oc s =
    encode ~endian s |> output_bytes oc

end (* [module PacketRep] *)

module WellKnown = struct
  let cu = create_unsafe
  let sa = U32.of_int
  let ia = U64.of_int

  (*
   * see also
   * https://docs.microsoft.com/en-us/windows/desktop/secauthz/well-known-sids
   *)
  let null = cu [| U32.zero |] U64.zero
  let everyone = cu [| U32.zero |] U64.one
  let world = everyone

  (* 1-2-… *)
  let local = cu [| U32.zero |] (U64.of_int 2)
  let console_logon = cu [| U32.one |] (U64.of_int 2)

  (* 1-3-… *)
  let creator_owner_id = cu [| U32.zero |] (U64.of_int 3)
  let creator_group_id = cu [| U32.one |] (U64.of_int 3)
  let creator_owner_server = cu [| U32.of_int 2 |] (U64.of_int 3)
  let creator_group_server = cu [| U32.of_int 3 |] (U64.of_int 3)
  let owner_rights = cu [| U32.of_int 4 |] (U64.of_int 3)
  let elite = cu [| U32.of_int 3 ; U32.of_int 3; U32.of_int 7 |] U64.one

  (* 1-5-… *)
  let nt_authority                  = cu [| |]               (U64.of_int 5)
  let dialup                        = cu [| U32.one |]       (U64.of_int 5)
  let network                       = cu [| U32.of_int  2 |] (U64.of_int 5)
  let batch                         = cu [| U32.of_int  3 |] (U64.of_int 5)
  let interactive                   = cu [| U32.of_int  4 |] (U64.of_int 5)
  let logon_id                      = cu [| U32.of_int  5 |] (U64.of_int 5)
  let service                       = cu [| U32.of_int  6 |] (U64.of_int 5)
  let anonymous                     = cu [| U32.of_int  7 |] (U64.of_int 5)
  let proxy                         = cu [| U32.of_int  8 |] (U64.of_int 5)
  let enterprise_domain_controllers = cu [| U32.of_int  9 |] (U64.of_int 5)
  let principal_self                = cu [| U32.of_int 10 |] (U64.of_int 5)
  let authenticated_users           = cu [| U32.of_int 11 |] (U64.of_int 5)
  let restricted_code               = cu [| U32.of_int 12 |] (U64.of_int 5)
  let terminal_server_user          = cu [| U32.of_int 13 |] (U64.of_int 5)
  let remote_interactive_logon      = cu [| U32.of_int 14 |] (U64.of_int 5)
  let this_organisation             = cu [| U32.of_int 15 |] (U64.of_int 5)
  let iusr                          = cu [| U32.of_int 17 |] (U64.of_int 5)
  let local_system                  = cu [| U32.of_int 18 |] (U64.of_int 5)
  let local_service                 = cu [| U32.of_int 19 |] (U64.of_int 5)
  let network_service               = cu [| U32.of_int 20 |] (U64.of_int 5)

  let compounded_authentication = cu [| sa 21; U32.zero; U32.zero; U32.zero; sa 496 |] (ia 5)
  let claims_valid              = cu [| sa 21; U32.zero; U32.zero; U32.zero; sa 497 |] (ia 5)

  let administrator                           machine     = cu [| sa 21; machine; sa 500     |] (ia 5)
  let guest                                   machine     = cu [| sa 21; machine; sa 501     |] (ia 5)
  let krbtgt                                  domain      = cu [| sa 21; domain; sa 502      |] (ia 5)
  let domain_admins                           domain      = cu [| sa 21; domain; sa 512      |] (ia 5)
  let domain_users                            domain      = cu [| sa 21; domain; sa 513      |] (ia 5)
  let domain_guests                           domain      = cu [| sa 21; domain; sa 514      |] (ia 5)
  let domain_computers                        domain      = cu [| sa 21; domain; sa 515      |] (ia 5)
  let domain_domain_controllers               domain      = cu [| sa 21; domain; sa 516      |] (ia 5)
  let cert_publishers                         domain      = cu [| sa 21; domain; sa 517      |] (ia 5)
  let schema_administrators                   root_domain = cu [| sa 21; root_domain; sa 518 |] (ia 5)
  let enterprise_admins                       root_domain = cu [| sa 21; root_domain; sa 519 |] (ia 5)
  let group_policy_creator_owners             domain      = cu [| sa 21; domain; sa 520      |] (ia 5)
  let readonly_domain_controllers             domain      = cu [| sa 21; domain; sa 521      |] (ia 5)
  let cloneable_controllers                   domain      = cu [| sa 21; domain; sa 522      |] (ia 5)
  let protected_users                         domain      = cu [| sa 21; domain; sa 525      |] (ia 5)
  let key_admins                              domain      = cu [| sa 21; domain; sa 526      |] (ia 5)
  let enterprise_key_admins                   domain      = cu [| sa 21; domain; sa 527      |] (ia 5)
  let ras_servers                             domain      = cu [| sa 21; domain; sa 553      |] (ia 5)
  let allowed_rodc_password_replication_group domain      = cu [| sa 21; domain; sa 571      |] (ia 5)
  let denied_rodc_password_replication_group  domain      = cu [| sa 21; domain; sa 572      |] (ia 5)

  let builtin_administrators             = cu [| sa 32; sa 544 |] (ia 5)
  let builtin_users                      = cu [| sa 32; sa 545 |] (ia 5)
  let builtin_guests                     = cu [| sa 32; sa 546 |] (ia 5)
  let power_users                        = cu [| sa 32; sa 547 |] (ia 5)
  let account_operators                  = cu [| sa 32; sa 548 |] (ia 5)
  let server_operators                   = cu [| sa 32; sa 549 |] (ia 5)
  let printer_operators                  = cu [| sa 32; sa 550 |] (ia 5)
  let backup_operators                   = cu [| sa 32; sa 551 |] (ia 5)
  let replicator                         = cu [| sa 32; sa 552 |] (ia 5)
  let alias_prew2kcompacc                = cu [| sa 32; sa 554 |] (ia 5)
  let remote_desktop                     = cu [| sa 32; sa 555 |] (ia 5)
  let network_configuration_ops          = cu [| sa 32; sa 556 |] (ia 5)
  let incoming_forest_trust_builders     = cu [| sa 32; sa 557 |] (ia 5)
  let perfmon_users                      = cu [| sa 32; sa 558 |] (ia 5)
  let perflog_users                      = cu [| sa 32; sa 559 |] (ia 5)
  let windows_authorization_access_group = cu [| sa 32; sa 560 |] (ia 5)
  let terminal_server_license_servers    = cu [| sa 32; sa 561 |] (ia 5)
  let distributed_com_users              = cu [| sa 32; sa 562 |] (ia 5)
  let iis_iusrs                          = cu [| sa 32; sa 568 |] (ia 5)
  let cryptographic_operators            = cu [| sa 32; sa 569 |] (ia 5)
  let event_log_readers                  = cu [| sa 32; sa 573 |] (ia 5)
  let certificate_service_dcom_access    = cu [| sa 32; sa 574 |] (ia 5)
  let rds_remote_access_servers          = cu [| sa 32; sa 575 |] (ia 5)
  let rds_endpoint_servers               = cu [| sa 32; sa 576 |] (ia 5)
  let rds_management_servers             = cu [| sa 32; sa 577 |] (ia 5)
  let hyper_v_admins                     = cu [| sa 32; sa 578 |] (ia 5)
  let access_control_assistance_ops      = cu [| sa 32; sa 579 |] (ia 5)
  let remote_management_users            = cu [| sa 32; sa 580 |] (ia 5)

  let write_restricted_code         = cu [| sa 33        |] (ia 5)
  let ntlm_authentication           = cu [| sa 64; sa 10 |] (ia 5)
  let schannel_authentication       = cu [| sa 64; sa 14 |] (ia 5)
  let digest_authentication         = cu [| sa 64; sa 21 |] (ia 5)
  let this_organization_certificate = cu [| sa 65; sa 1  |] (ia 5)
  let nt_service                    = cu [| sa 80        |] (ia 5)
  let user_mode_drivers             = cu [| sa 84; U32.zero; U32.zero; U32.zero; U32.zero; U32.zero |] (ia 5)
  let local_account                 = cu [| sa 113       |] (ia 5)
  let local_account_and_member_of_administrators_group = cu [| sa 114 |] (ia 5)
  let other_organization            = cu [| sa 1000      |] (ia 5)

  (* 1-15-… *)
  let all_app_packages = cu [| sa 2; U32.one |] (ia 15)

  (* 1-16-… *)
  let ml_untrusted         = cu [| U32.zero |] (ia 16)
  let ml_low               = cu [| sa 4096  |] (ia 16)
  let ml_medium            = cu [| sa 8192  |] (ia 16)
  let ml_medium_plus       = cu [| sa 8448  |] (ia 16)
  let ml_high              = cu [| sa 12288 |] (ia 16)
  let ml_system            = cu [| sa 16384 |] (ia 16)
  let ml_protected_process = cu [| sa 20480 |] (ia 16)
  let ml_secure_process    = cu [| sa 28672 |] (ia 16)

  (* 1-18-… *)
  let authentication_authority_asserted_identity = cu [| U32.one |] (ia 18)
  let service_asserted_identity                  = cu [| sa 2    |] (ia 18)
  let fresh_public_key_identity                  = cu [| sa 3    |] (ia 18)
  let key_trust_identity                         = cu [| sa 4    |] (ia 18)
  let key_property_mfa                           = cu [| sa 5    |] (ia 18)
  let key_property_attestation                   = cu [| sa 6    |] (ia 18)

  module Prefix = struct
    let security_null_sid_authority    ?(sa=[||]) () = create_unsafe sa (U64.of_int 0x00)
    let security_world_sid_authority   ?(sa=[||]) () = create_unsafe sa (U64.of_int 0x01)
    let security_local_sid_authority   ?(sa=[||]) () = create_unsafe sa (U64.of_int 0x02)
    let security_creator_sid_authority ?(sa=[||]) () = create_unsafe sa (U64.of_int 0x03)
    let security_nt_authority          ?(sa=[||]) () = create_unsafe sa (U64.of_int 0x05)
    let security_app_package_authority      ?(sa=[||]) () = create_unsafe sa (U64.of_int 0x0f)
    let security_mandatory_label_authority  ?(sa=[||]) () = create_unsafe sa (U64.of_int 0x10)
    let security_scoped_policy_id_authority ?(sa=[||]) () = create_unsafe sa (U64.of_int 0x11)
    let security_authentication_authority   ?(sa=[||]) () = create_unsafe sa (U64.of_int 0x12)
  end
end

let of_string = StringFmt.decode
let to_string = StringFmt.encode

let of_bytes = PacketRep.decode
let to_bytes = PacketRep.encode

type t = sid