Source file p11_template.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
type t = P11_attribute.pack list [@@deriving eq, ord, show]

let to_yojson template : Yojson.Safe.t =
  let attributes =
    List.map (fun (P11_attribute.Pack x) -> P11_attribute.to_json x) template
  in
  let flatten_attribute = function
    | `Assoc l -> l
    | _ -> assert false
    (* All attributes are represented using [`Assoc]. *)
  in
  let attributes = List.map flatten_attribute attributes |> List.flatten in
  `Assoc attributes

let of_yojson json =
  let open Ppx_deriving_yojson_runtime in
  match json with
  | `Assoc assoc ->
    let attributes = List.map (fun (a, b) -> `Assoc [(a, b)]) assoc in
    map_bind P11_attribute.pack_of_yojson [] attributes
  | _ -> Error "Ill-formed template"

let rec get : type a. t -> a P11_attribute_type.t -> a option =
 fun template x ->
  match template with
  | [] -> None
  | head :: tail -> (
    match head with
    | P11_attribute.Pack (ty, v) -> (
      match P11_attribute_type.compare' ty x with
      | P11_attribute_type.Equal -> Some v
      | P11_attribute_type.Not_equal _ -> get tail x))

let get_pack template (P11_attribute_type.Pack ty) =
  match get template ty with
  | None -> None
  | Some v -> Some (P11_attribute.Pack (ty, v))

(** [normalize t] returns a normal form for the template [t]. That
    is, a template that is sorted. *)
let normalize (t : t) : t = List.sort P11_attribute.compare_pack t

(** safe mem on templates. *)
let mem elem = List.exists (P11_attribute.equal_pack elem)

(* Operations  *)
let fold = List.fold_right

(* Replace the value of [attribute] in [template] if it already
   exists.  Add [attribute] otherwise. *)
let set_attribute attribute (template : P11_attribute.pack list) =
  let exists = ref false in
  let replace_value old_attribute =
    if P11_attribute.compare_types_pack old_attribute attribute = 0 then (
      exists := true;
      attribute
    ) else
      old_attribute
  in
  let template = List.map replace_value template in
  if !exists then
    template
  else
    attribute :: template

let remove_attribute attribute template =
  List.filter (fun x -> not (P11_attribute.equal_pack x attribute)) template

let remove_attribute_type attribute_type template =
  List.filter
    (fun x ->
      let x = P11_attribute.type_ x in
      not (P11_attribute_type.equal_pack x attribute_type))
    template

let attribute_types template = List.map P11_attribute.type_ template

let union template1 template2 =
  List.fold_left
    (fun template attribute -> set_attribute attribute template)
    template2 (List.rev template1)

let only_attribute_types types template =
  List.fold_left
    (fun template attribute ->
      let type_ = P11_attribute.type_ attribute in
      if List.exists (P11_attribute_type.equal_pack type_) types then
        attribute :: template
      else
        template)
    [] template
  |> List.rev

let except_attribute_types types template =
  List.fold_left
    (fun template attribute ->
      let type_ = P11_attribute.type_ attribute in
      if List.exists (P11_attribute_type.equal_pack type_) types then
        template
      else
        attribute :: template)
    [] template
  |> List.rev

let find_attribute_types types template =
  let rec aux types result =
    match types with
    | [] -> Some (List.rev result)
    | ty :: q -> (
      match get_pack template ty with
      | None -> None
      | Some a -> aux q (a :: result))
  in
  aux types []

let correspond ~source ~tested =
  (* For all the elements of source, check if an element in tested
     correspond. *)
  List.for_all (fun x -> List.exists (P11_attribute.equal_pack x) tested) source

(** For all the elements of source, check if an element in tested
    correspond. Return a tuple with the list of elements from source
    which are expected but not found in tested and a list of elements
    which are found but with a different value.
*)
let diff ~source ~tested =
  let empty = ([], []) in
  List.fold_left
    (fun (missing, different) (P11_attribute.Pack (attribute, a_value) as pack) ->
      match get tested attribute with
      | None ->
        let missing = pack :: missing in
        (missing, different)
      | Some value ->
        let different =
          if a_value = value then
            different
          else
            pack :: different
        in
        (missing, different))
    empty source

let to_string t = to_yojson t |> Yojson.Safe.to_string

let hash t = normalize t |> to_string |> Digest.string

let get_class t = get t P11_attribute_type.CKA_CLASS

let get_key_type t = get t P11_attribute_type.CKA_KEY_TYPE

let get_label t = get t P11_attribute_type.CKA_LABEL