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
|
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)
|
