1 files changed, 81 insertions, 0 deletions
diff --git a/xacml-translation/json_xacml_translator/lib/translator.ml b/xacml-translation/json_xacml_translator/lib/translator.ml
new file mode 100644
index 0000000..13125ab
--- /dev/null
+++ b/xacml-translation/json_xacml_translator/lib/translator.ml
@@ -0,0 +1,81 @@
+open Base
+
+type xml_element = (string * (string * string) list * Xml.xml list)
+
+let rec get_attr (needle : string) : (string * string) list -> string option = function
+  | (k, v) :: xs -> if String.(k = needle) then Some v else get_attr needle xs
+  | _ -> None
+
+let get_exn opt message =
+  match opt with
+  | Some x -> x
+  | _ -> failwith message
+
+let get_attr_exn needle attrs : string =
+  get_exn (get_attr needle attrs) "missing attribute"
+
+let xml_element_of_children (children : Xml.xml list) : xml_element list =
+  List.map children ~f:(function
+      | Element x -> x
+      | _ -> failwith "called on element with non-element children")
+
+let xml_element_of_Xml : Xml.xml -> xml_element = function
+  | Element (elt) -> elt
+  | _ -> failwith "not an element"
+
+(* --- *)
+
+let compile_attribute_value category identifier issuer ((tag_name, attributes, children) : xml_element) =
+  assert String.(tag_name = "AttributeValue");
+  let typ = get_attr_exn "DataType" attributes in
+  match children with
+  | [PCData s] ->
+    (match issuer with
+     | Some issuer ->
+       `Assoc
+         [
+           ("category", `String category);
+           ("identifier", `String identifier);
+           ("issuer", `String issuer);
+           ("value", `Assoc [("kind", `String "primitive");
+                             ("type", `String typ);
+                             ("value", `String s)])
+         ]
+     | _ ->
+       `Assoc
+         [
+           ("category", `String category);
+           ("identifier", `String identifier);
+           ("value", `Assoc [("kind", `String "primitive");
+                             ("type", `String typ);
+                             ("value", `String s)])
+         ])
+    | _ -> failwith "ill-formed attribute value"
+
+let compile_attribute category ((tag_name, attributes, children) : xml_element) =
+  assert String.(tag_name = "Attribute");
+  let identifier = get_attr_exn "AttributeId" attributes in
+  let issuer = get_attr "Issuer" attributes in
+  compile_attribute_value category identifier issuer (List.nth_exn children 0 |> xml_element_of_Xml)
+
+let compile_attributes ((tag_name, attributes, children) : xml_element) : _ =
+  assert String.(tag_name = "Attributes");
+  let category = get_attr_exn "Category" attributes in
+  children
+  |> xml_element_of_children
+  |> List.map ~f:(compile_attribute category)
+  (* |> List.concat *)
+
+let compile_request' : Xml.xml -> _ = function
+  | Element (("Request", _attributes, children)) ->
+    List.map ~f:xml_element_of_Xml children
+    |> List.map ~f:compile_attributes
+    |> List.concat
+  | Element ((tag_name, _, _)) ->
+    failwith (Printf.sprintf "(%s)" tag_name)
+  | PCData s -> failwith s
+
+let compile_request (request : string) : string =
+  let request = Xml.parse_string request in
+  let attributes = compile_request' request in
+  Yojson.Basic.to_string (`List attributes)