Source file p11_flags.ml

type t = Unsigned.ULong.t
[@@deriving ord]

let equal = Pervasives.(=)

let show = Unsigned.ULong.to_string

let pp fmt n =
  Format.pp_print_string fmt (show n)

let (!) x  = Unsigned.ULong.of_string (Int64.to_string x)

let empty = Unsigned.ULong.zero
let logical_or = Unsigned.ULong.logor
let ( || ) = logical_or
let logical_and = Unsigned.ULong.logand

let get ~(flags: t) ~(flag: t): bool =
  not (equal (logical_and flags flag) empty)

type domain =
  | Info_domain
  | Slot_info_domain
  | Token_info_domain
  | Session_info_domain
  | Mechanism_info_domain
  | Initialize_domain
  | Wait_for_slot_domain
  | OTP_signature_info_domain
  | Any_domain

(* CK_SLOT_INFO *)
let _CKF_TOKEN_PRESENT                  = !0x00000001L
let _CKF_REMOVABLE_DEVICE               = !0x00000002L
let _CKF_HW_SLOT                        = !0x00000004L

(* CK_TOKEN_INFO *)
let _CKF_RNG                            = !0x00000001L
let _CKF_WRITE_PROTECTED                = !0x00000002L
let _CKF_LOGIN_REQUIRED                 = !0x00000004L
let _CKF_USER_PIN_INITIALIZED           = !0x00000008L
let _CKF_RESTORE_KEY_NOT_NEEDED         = !0x00000020L
let _CKF_CLOCK_ON_TOKEN                 = !0x00000040L
let _CKF_PROTECTED_AUTHENTICATION_PATH  = !0x00000100L
let _CKF_DUAL_CRYPTO_OPERATIONS         = !0x00000200L
let _CKF_TOKEN_INITIALIZED              = !0x00000400L
let _CKF_SECONDARY_AUTHENTICATION       = !0x00000800L
let _CKF_USER_PIN_COUNT_LOW             = !0x00010000L
let _CKF_USER_PIN_FINAL_TRY             = !0x00020000L
let _CKF_USER_PIN_LOCKED                = !0x00040000L
let _CKF_USER_PIN_TO_BE_CHANGED         = !0x00080000L
let _CKF_SO_PIN_COUNT_LOW               = !0x00100000L
let _CKF_SO_PIN_FINAL_TRY               = !0x00200000L
let _CKF_SO_PIN_LOCKED                  = !0x00400000L
let _CKF_SO_PIN_TO_BE_CHANGED           = !0x00800000L

(* CK_SESSION_INFO *)
let _CKF_RW_SESSION                     = !0x00000002L
let _CKF_SERIAL_SESSION                 = !0x00000004L

(* The following flag is actually a bit which is present in CKA values
   which consists in an array of attributes. *)
let _CKF_ARRAY_ATTRIBUTE                = !0x40000000L

(* CK_MECHANISM_INFO *)
let _CKF_HW                             = !0x00000001L
let _CKF_ENCRYPT                        = !0x00000100L
let _CKF_DECRYPT                        = !0x00000200L
let _CKF_DIGEST                         = !0x00000400L
let _CKF_SIGN                           = !0x00000800L
let _CKF_SIGN_RECOVER                   = !0x00001000L
let _CKF_VERIFY                         = !0x00002000L
let _CKF_VERIFY_RECOVER                 = !0x00004000L
let _CKF_GENERATE                       = !0x00008000L
let _CKF_GENERATE_KEY_PAIR              = !0x00010000L
let _CKF_WRAP                           = !0x00020000L
let _CKF_UNWRAP                         = !0x00040000L
let _CKF_DERIVE                         = !0x00080000L
let _CKF_EC_F_P                         = !0x00100000L
let _CKF_EC_F_2M                        = !0x00200000L
let _CKF_EC_ECPARAMETERS                = !0x00400000L
let _CKF_EC_NAMEDCURVE                  = !0x00800000L
let _CKF_EC_UNCOMPRESS                  = !0x01000000L
let _CKF_EC_COMPRESS                    = !0x02000000L
let _CKF_EXTENSION                      = !0x80000000L

(* C_Initialize *)
let _CKF_LIBRARY_CANT_CREATE_OS_THREADS = !0x00000001L
let _CKF_OS_LOCKING_OK                  = !0x00000002L

(* C_WaitForSlotEvent *)
let _CKF_DONT_BLOCK                     = !0x00000001L

(* CK_OTP_SIGNATURE_INFO *)
let _CKF_NEXT_OTP                       = !0x00000001L
let _CKF_EXCLUDE_TIME                   = !0x00000002L
let _CKF_EXCLUDE_COUNTER                = !0x00000004L
let _CKF_EXCLUDE_CHALLENGE              = !0x00000008L
let _CKF_EXCLUDE_PIN                    = !0x00000010L
let _CKF_USER_FRIENDLY_OTP              = !0x00000020L

let to_string = Unsigned.ULong.to_string
let of_string = Unsigned.ULong.of_string

let to_json ?pretty (flags:t) =
  match pretty with
    | None ->
      `String (to_string flags)
    | Some pretty ->
      `Assoc
        [ "value", `String (to_string flags)
        ; "string", `String (pretty flags)
        ]

(* for now, just use assoc lists for the mappings as there are not many *)
let pretty_string_mappings =

  (* There are no flags for CK_INFO in v2.20 *)
  let info = [] in

  let slot_info = [
    _CKF_TOKEN_PRESENT, "CKF_TOKEN_PRESENT";
    _CKF_REMOVABLE_DEVICE, "CKF_REMOVABLE_DEVICE";
    _CKF_HW_SLOT, "CKF_HW_SLOT";
  ]
  in

  let token_info = [
    _CKF_RNG, "CKF_RNG";
    _CKF_WRITE_PROTECTED, "CKF_WRITE_PROTECTED";
    _CKF_LOGIN_REQUIRED, "CKF_LOGIN_REQUIRED";
    _CKF_USER_PIN_INITIALIZED, "CKF_USER_PIN_INITIALIZED";
    _CKF_RESTORE_KEY_NOT_NEEDED, "CKF_RESTORE_KEY_NOT_NEEDED";
    _CKF_CLOCK_ON_TOKEN, "CKF_CLOCK_ON_TOKEN";
    _CKF_PROTECTED_AUTHENTICATION_PATH, "CKF_PROTECTED_AUTHENTICATION_PATH";
    _CKF_DUAL_CRYPTO_OPERATIONS, "CKF_DUAL_CRYPTO_OPERATIONS";
    _CKF_TOKEN_INITIALIZED, "CKF_TOKEN_INITIALIZED";
    _CKF_SECONDARY_AUTHENTICATION, "CKF_SECONDARY_AUTHENTICATION";
    _CKF_USER_PIN_COUNT_LOW, "CKF_USER_PIN_COUNT_LOW";
    _CKF_USER_PIN_FINAL_TRY, "CKF_USER_PIN_FINAL_TRY";
    _CKF_USER_PIN_LOCKED, "CKF_USER_PIN_LOCKED";
    _CKF_USER_PIN_TO_BE_CHANGED, "CKF_USER_PIN_TO_BE_CHANGED";
    _CKF_SO_PIN_COUNT_LOW, "CKF_SO_PIN_COUNT_LOW";
    _CKF_SO_PIN_FINAL_TRY, "CKF_SO_PIN_FINAL_TRY";
    _CKF_SO_PIN_LOCKED, "CKF_SO_PIN_LOCKED";
    _CKF_SO_PIN_TO_BE_CHANGED, "CKF_SO_PIN_TO_BE_CHANGED";
  ]
  in

  let session_info = [
    _CKF_RW_SESSION, "CKF_RW_SESSION";
    _CKF_SERIAL_SESSION, "CKF_SERIAL_SESSION";
  ]
  in

  let any = [
    _CKF_ARRAY_ATTRIBUTE, "CKF_ARRAY_ATTRIBUTE";
  ]
  in

  let mechanism_info = [
    _CKF_HW, "CKF_HW";
    _CKF_ENCRYPT, "CKF_ENCRYPT";
    _CKF_DECRYPT, "CKF_DECRYPT";
    _CKF_DIGEST, "CKF_DIGEST";
    _CKF_SIGN, "CKF_SIGN";
    _CKF_SIGN_RECOVER, "CKF_SIGN_RECOVER";
    _CKF_VERIFY, "CKF_VERIFY";
    _CKF_VERIFY_RECOVER, "CKF_VERIFY_RECOVER";
    _CKF_GENERATE, "CKF_GENERATE";
    _CKF_GENERATE_KEY_PAIR, "CKF_GENERATE_KEY_PAIR";
    _CKF_WRAP, "CKF_WRAP";
    _CKF_UNWRAP, "CKF_UNWRAP";
    _CKF_DERIVE, "CKF_DERIVE";
    _CKF_EC_F_P, "CKF_EC_F_P";
    _CKF_EC_F_2M, "CKF_EC_F_2M";
    _CKF_EC_ECPARAMETERS, "CKF_EC_ECPARAMETERS";
    _CKF_EC_NAMEDCURVE, "CKF_EC_NAMEDCURVE";
    _CKF_EC_UNCOMPRESS, "CKF_EC_UNCOMPRESS";
    _CKF_EC_COMPRESS, "CKF_EC_COMPRESS";
    _CKF_EXTENSION, "CKF_EXTENSION";
  ]
  in

  let initialize = [
    _CKF_LIBRARY_CANT_CREATE_OS_THREADS, "CKF_LIBRARY_CANT_CREATE_OS_THREADS";
    _CKF_OS_LOCKING_OK, "CKF_OS_LOCKING_OK";
  ]
  in

  let wait_for_slot = [
    _CKF_DONT_BLOCK, "CKF_DONT_BLOCK";
  ]
  in

  let otp_signature_info = [
    _CKF_NEXT_OTP, "CKF_NEXT_OTP";
    _CKF_EXCLUDE_TIME, "CKF_EXCLUDE_TIME";
    _CKF_EXCLUDE_COUNTER, "CKF_EXCLUDE_COUNTER";
    _CKF_EXCLUDE_CHALLENGE, "CKF_EXCLUDE_CHALLENGE";
    _CKF_EXCLUDE_PIN, "CKF_EXCLUDE_PIN";
    _CKF_USER_FRIENDLY_OTP, "CKF_USER_FRIENDLY_OTP";
  ]
  in

  [
    Info_domain, info;
    Slot_info_domain, slot_info;
    Token_info_domain, token_info;
    Session_info_domain, session_info;
    Mechanism_info_domain, mechanism_info;
    Initialize_domain, initialize;
    Wait_for_slot_domain, wait_for_slot;
    OTP_signature_info_domain, otp_signature_info;
    Any_domain, any;
  ]

let flags_of_domain domain =
  try List.assoc domain pretty_string_mappings
  with Not_found -> []

let split_with_string domain flags : ((t * string) list * t) =
  let expected_flags = flags_of_domain domain in
  let (split_flags, remaining) =
    List.fold_left
      (fun ((expected_flags, remaining_flags) as acc) (flag, str) ->
         if get ~flag ~flags then
           let remaining_flags =
             logical_and
               remaining_flags
               (Unsigned.ULong.lognot flag)
           in
           let expected_flags = (flag, str) :: expected_flags in
           expected_flags, remaining_flags
         else
           acc
      )
      ([], flags)
      expected_flags
  in
  (List.rev split_flags, remaining)

let split domain flags : (t list * t) =
  let (flags, remaining) = split_with_string domain flags in
  (List.map fst flags, remaining)

let to_pretty_strings domain flags =
  let (flags, remaining) = split_with_string domain flags in
  let flags = List.map snd flags in
  if equal remaining empty
  then flags
  else flags @ [Printf.sprintf "0x%Lx" @@ Int64.of_string @@ Unsigned.ULong.to_string remaining]

let to_pretty_string domain flags =
  let flags = to_pretty_strings domain flags in
  match flags with
    | [] -> "(none)"
    | f -> String.concat " | " f

type has_value =
  { value : Yojson.Safe.json
  ; string : string
  }
[@@deriving of_yojson]

let of_yojson json =
  (* We know that [P11_ulong.to_yojson] does not produce [`Assoc]s. *)
  let actual_json = match has_value_of_yojson json with
    | Ok {value; _} -> value
    | Error _ -> json
  in
  P11_ulong.of_yojson actual_json

let to_yojson =
  to_json ?pretty:None