diff --git a/Makefile b/Makefile index e7527d7c725..3d0f4498adb 100644 --- a/Makefile +++ b/Makefile @@ -78,7 +78,6 @@ python: $(MAKE) -C scripts/examples/python build doc-json: - dune build --profile=$(PROFILE) ocaml/idl/json_backend/gen_json.exe dune exec --profile=$(PROFILE) -- ocaml/idl/json_backend/gen_json.exe -destdir $(XAPIDOC)/jekyll format: diff --git a/ocaml/idl/json_backend/dune b/ocaml/idl/json_backend/dune index dc25a3bfcd1..58a57eca08a 100644 --- a/ocaml/idl/json_backend/dune +++ b/ocaml/idl/json_backend/dune @@ -6,6 +6,7 @@ xapi-consts xapi-stdext-unix xapi-stdext-std + yojson ) ) diff --git a/ocaml/idl/json_backend/gen_json.ml b/ocaml/idl/json_backend/gen_json.ml index 2084cde3d01..09e529326c3 100644 --- a/ocaml/idl/json_backend/gen_json.ml +++ b/ocaml/idl/json_backend/gen_json.ml @@ -11,13 +11,15 @@ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. *) -(* main.ml *) open Datamodel_types open Datamodel_utils open Dm_api -(* JSON *) +let ( // ) = Filename.concat + +let write_string ~path str = + Xapi_stdext_unix.Unixext.write_string_to_file path str let destdir' = ref "." @@ -32,537 +34,590 @@ let parse_args () = (fun x -> Printf.printf "Ignoring anonymous argument %s" x) "Generates documentation for the datamodel classes. See -help." -let escape_json s = - let len = String.length s in - if len > 0 then ( - let buf = Buffer.create len in - for i = 0 to len - 1 do - match s.[i] with - | '\"' -> - Buffer.add_string buf "\\\"" - | '\\' -> - Buffer.add_string buf "\\\\" - | '\b' -> - Buffer.add_string buf "\\b" - | '\n' -> - Buffer.add_string buf "\\n" - | '\r' -> - Buffer.add_string buf "\\r" - | '\t' -> - Buffer.add_string buf "\\t" - | c -> - Buffer.add_char buf c - done ; - Buffer.contents buf - ) else - "" - -type json = - | JObject of (string * json) list - | JArray of json list - | JString of string - | JNumber of float - | JBoolean of bool - | JEmpty - -let endl n = - if n = 0 then - "" - else - "\n" ^ String.make ((2 * n) - 2) ' ' - -let rec string_of_json n = function - | JObject l -> - endl n - ^ "{ " - ^ String.concat - ("," ^ endl (n + 1)) - (List.map - (fun (s, j) -> "\"" ^ s ^ "\": " ^ string_of_json (n + 2) j) - l +(* Datamodel *) + +module Json : sig + val xenapi : Datamodel_types.obj list -> Yojson.Safe.t + + val release_info : + api_release list -> Datamodel_types.obj list -> Yojson.Safe.t +end = struct + let rec string_of_ty_with_enums ty = + match ty with + | SecretString | String -> + ("string", []) + | Int -> + ("int", []) + | Float -> + ("float", []) + | Bool -> + ("bool", []) + | DateTime -> + ("datetime", []) + | Enum (name, kv) -> + ("enum " ^ name, [(name, kv)]) + | Set ty -> + let s, e = string_of_ty_with_enums ty in + (s ^ " set", e) + | Map (ty1, ty2) -> + let s1, e1 = string_of_ty_with_enums ty1 in + let s2, e2 = string_of_ty_with_enums ty2 in + (Printf.sprintf "(%s -> %s) map" s1 s2, e1 @ e2) + | Ref r -> + (r ^ " ref", []) + | Record r -> + (r ^ " record", []) + | Option ty -> + let s, e = string_of_ty_with_enums ty in + (s ^ " option", e) + + let string_of_qualifier = function + | RW -> + "RW" + | StaticRO -> + "RO/constructor" + | DynamicRO -> + "RO/runtime" + + let rec string_of_default = function + | VString x -> + "\"" ^ x ^ "\"" + | VInt x -> + Int64.to_string x + | VFloat x -> + string_of_float x + | VBool x -> + string_of_bool x + | VDateTime x -> + Date.to_string x + | VEnum x -> + x + | VMap x -> + Printf.sprintf "{%s}" + (String.concat ", " + (List.map + (fun (a, b) -> + Printf.sprintf "%s -> %s" (string_of_default a) + (string_of_default b) + ) + x + ) ) - ^ " }" - | JArray l -> - "[ " - ^ String.concat ", " (List.map (fun j -> string_of_json n j) l) - ^ " ]" - | JString s -> - "\"" ^ escape_json s ^ "\"" - | JNumber n -> - Printf.sprintf "%.4f" n - | JBoolean b -> - if b = true then "true" else "false" - | JEmpty -> - "\"\"" + | VSet x -> + Printf.sprintf "{%s}" (String.concat ", " (List.map string_of_default x)) + | VRef x -> + if x = "" then "Null" else x + | VCustom (_, y) -> + string_of_default y -(* Datamodel *) + let of_lifecycle lc = + `List + (List.map + (fun (t, r, d) -> + `Assoc + [ + ("transition", `String (string_of_lifecycle_transition t)) + ; ("release", `String r) + ; ("description", `String d) + ] + ) + lc + ) -let rec string_of_ty_with_enums ty = - match ty with - | SecretString | String -> - ("string", []) - | Int -> - ("int", []) - | Float -> - ("float", []) - | Bool -> - ("bool", []) - | DateTime -> - ("datetime", []) - | Enum (name, kv) -> - ("enum " ^ name, [(name, kv)]) - | Set ty -> - let s, e = string_of_ty_with_enums ty in - (s ^ " set", e) - | Map (ty1, ty2) -> - let s1, e1 = string_of_ty_with_enums ty1 in - let s2, e2 = string_of_ty_with_enums ty2 in - (Printf.sprintf "(%s -> %s) map" s1 s2, e1 @ e2) - | Ref r -> - (r ^ " ref", []) - | Record r -> - (r ^ " record", []) - | Option ty -> - let s, e = string_of_ty_with_enums ty in - (s ^ " option", e) - -let string_of_qualifier = function - | RW -> - "RW" - | StaticRO -> - "RO/constructor" - | DynamicRO -> - "RO/runtime" - -let rec string_of_default = function - | VString x -> - "\"" ^ x ^ "\"" - | VInt x -> - Int64.to_string x - | VFloat x -> - string_of_float x - | VBool x -> - string_of_bool x - | VDateTime x -> - Date.to_string x - | VEnum x -> - x - | VMap x -> - Printf.sprintf "{%s}" - (String.concat ", " - (List.map - (fun (a, b) -> - Printf.sprintf "%s -> %s" (string_of_default a) - (string_of_default b) - ) - x - ) + let fields_of_obj_with_enums obj = + let rec flatten_contents contents = + List.fold_left + (fun l -> function + | Field f -> + f :: l + | Namespace (_name, contents) -> + flatten_contents contents @ l ) - | VSet x -> - Printf.sprintf "{%s}" (String.concat ", " (List.map string_of_default x)) - | VRef x -> - if x = "" then "Null" else x - | VCustom (_, y) -> - string_of_default y - -let jarray_of_lifecycle lc = - JArray - (List.map - (fun (t, r, d) -> - JObject - [ - ("transition", JString (string_of_lifecycle_transition t)) - ; ("release", JString r) - ; ("description", JString d) - ] - ) - lc - ) - -let fields_of_obj_with_enums obj = - let rec flatten_contents contents = + [] contents + in + let fields = flatten_contents obj.contents in List.fold_left - (fun l -> function - | Field f -> - f :: l - | Namespace (_name, contents) -> - flatten_contents contents @ l + (fun (fields, enums) field -> + let ty, e = string_of_ty_with_enums field.ty in + ( `Assoc + (("name", `String (String.concat "_" field.full_name)) + :: ("description", `String field.field_description) + :: ("type", `String ty) + :: ("qualifier", `String (string_of_qualifier field.qualifier)) + :: ( "tag" + , `String + ( match field.field_doc_tags with + | [] -> + "" + | t :: _ -> + string_of_doc_tag t + ) + ) + :: ("lifecycle", of_lifecycle field.lifecycle) + :: + ( match field.default_value with + | Some d -> + [("default", `String (string_of_default d))] + | None -> + [] + ) + ) + :: fields + , enums @ e + ) ) - [] contents - in - let fields = flatten_contents obj.contents in - List.fold_left - (fun (fields, enums) field -> - let ty, e = string_of_ty_with_enums field.ty in - ( JObject - (("name", JString (String.concat "_" field.full_name)) - :: ("description", JString field.field_description) - :: ("type", JString ty) - :: ("qualifier", JString (string_of_qualifier field.qualifier)) - :: ( "tag" - , JString - ( match field.field_doc_tags with - | [] -> - "" - | t :: _ -> - string_of_doc_tag t - ) - ) - :: ("lifecycle", jarray_of_lifecycle field.lifecycle) - :: - ( match field.default_value with - | Some d -> - [("default", JString (string_of_default d))] - | None -> - [] - ) + ([], []) fields + + let of_result obj msg = + match msg.msg_result with + | None -> + (`List [`String "void"], []) + | Some (t, d) -> + if obj.name = "event" && String.lowercase_ascii msg.msg_name = "from" + then + (`List [`String "an event batch"; `String d], []) + else + let t', enums = string_of_ty_with_enums t in + (`List [`String t'; `String d], enums) + + let of_params ps = + let params, enums = + List.fold_left + (fun (params, enums) p -> + let t, e = string_of_ty_with_enums p.param_type in + ( `Assoc + [ + ("type", `String t) + ; ("name", `String p.param_name) + ; ("doc", `String p.param_doc) + ] + :: params + , enums @ e ) - :: fields - , enums @ e - ) - ) - ([], []) fields - -let jarray_of_result_with_enums obj msg = - match msg.msg_result with - | None -> - (JArray [JString "void"], []) - | Some (t, d) -> - if obj.name = "event" && String.lowercase_ascii msg.msg_name = "from" then - (JArray [JString "an event batch"; JString d], []) - else - let t', enums = string_of_ty_with_enums t in - (JArray [JString t'; JString d], enums) - -let jarray_of_params_with_enums ps = - let params, enums = + ) + ([], []) ps + in + (`List (List.rev params), enums) + + let of_error e = + `Assoc [("name", `String e.err_name); ("doc", `String e.err_doc)] + + let of_roles = function + | None -> + `List [] + | Some rs -> + `List (List.map (fun s -> `String s) rs) + + let session_id = + { + param_type= Ref Datamodel_common._session + ; param_name= "session_id" + ; param_doc= "Reference to a valid session" + ; param_release= Datamodel_common.rio_release + ; param_default= None + } + + let messages_of_obj_with_enums obj = List.fold_left - (fun (params, enums) p -> - let t, e = string_of_ty_with_enums p.param_type in - ( JObject + (fun (msgs, enums) msg -> + let params = + if msg.msg_session then + session_id :: msg.msg_params + else + msg.msg_params + in + let ctor = + if msg.msg_tag = FromObject Make then + let ctor_fields = + List.filter + (function {qualifier= StaticRO | RW; _} -> true | _ -> false) + (fields_of_obj obj) + |> List.map (fun f -> + String.concat "_" f.full_name + ^ if f.default_value = None then "*" else "" + ) + in + Printf.sprintf "\nThe constructor args are: %s (* = non-optional)." + (String.concat ", " ctor_fields) + else + "" + in + let result, enums1 = of_result obj msg in + let params, enums2 = of_params params in + ( `Assoc [ - ("type", JString t) - ; ("name", JString p.param_name) - ; ("doc", JString p.param_doc) + ("name", `String msg.msg_name) + ; ("description", `String (msg.msg_doc ^ ctor)) + ; ("result", result) + ; ("params", params) + ; ("errors", `List (List.map of_error msg.msg_errors)) + ; ("roles", of_roles msg.msg_allowed_roles) + ; ( "tag" + , `String + ( match msg.msg_doc_tags with + | [] -> + "" + | t :: _ -> + string_of_doc_tag t + ) + ) + ; ("lifecycle", of_lifecycle msg.msg_lifecycle) + ; ("implicit", `Bool (msg.msg_tag <> Custom)) ] - :: params - , enums @ e + :: msgs + , enums @ enums1 @ enums2 ) ) - ([], []) ps - in - (JArray (List.rev params), enums) - -let jarray_of_errors es = - JArray - (List.map - (fun e -> - JObject [("name", JString e.err_name); ("doc", JString e.err_doc)] - ) - es - ) - -let jarray_of_roles = function - | None -> - JArray [] - | Some rs -> - JArray (List.map (fun s -> JString s) rs) - -let session_id = - { - param_type= Ref Datamodel_common._session - ; param_name= "session_id" - ; param_doc= "Reference to a valid session" - ; param_release= Datamodel_common.rio_release - ; param_default= None - } - -let messages_of_obj_with_enums obj = - List.fold_left - (fun (msgs, enums) msg -> - let params = - if msg.msg_session then - session_id :: msg.msg_params - else - msg.msg_params - in - let ctor = - if msg.msg_tag = FromObject Make then - let ctor_fields = - List.filter - (function {qualifier= StaticRO | RW; _} -> true | _ -> false) - (fields_of_obj obj) - |> List.map (fun f -> - String.concat "_" f.full_name - ^ if f.default_value = None then "*" else "" - ) - in - Printf.sprintf "\nThe constructor args are: %s (* = non-optional)." - (String.concat ", " ctor_fields) - else - "" - in - let result, enums1 = jarray_of_result_with_enums obj msg in - let params, enums2 = jarray_of_params_with_enums params in - ( JObject - [ - ("name", JString msg.msg_name) - ; ("description", JString (msg.msg_doc ^ ctor)) - ; ("result", result) - ; ("params", params) - ; ("errors", jarray_of_errors msg.msg_errors) - ; ("roles", jarray_of_roles msg.msg_allowed_roles) - ; ( "tag" - , JString - ( match msg.msg_doc_tags with - | [] -> - "" - | t :: _ -> - string_of_doc_tag t - ) - ) - ; ("lifecycle", jarray_of_lifecycle msg.msg_lifecycle) - ; ("implicit", JBoolean (msg.msg_tag <> Custom)) - ] - :: msgs - , enums @ enums1 @ enums2 - ) - ) - ([], []) obj.messages - -let jarray_of_enums enums = - JArray - (List.map - (fun (name, vs) -> - JObject - [ - ("name", JString name) - ; ( "values" - , JArray - (List.map - (fun (v, d) -> - JObject [("name", JString v); ("doc", JString d)] - ) - vs - ) - ) - ] - ) - enums - ) - -let json_of_objs objs = - JArray - (List.map - (fun obj -> - let fields, enums1 = fields_of_obj_with_enums obj in - let messages, enums2 = messages_of_obj_with_enums obj in - let enums = Xapi_stdext_std.Listext.List.setify (enums1 @ enums2) in - let event_snapshot = - if String.lowercase_ascii obj.name = "event" then + ([], []) obj.messages + + let of_enum (name, vs) = + let of_value (v, d) = `Assoc [("name", `String v); ("doc", `String d)] in + `Assoc [("name", `String name); ("values", `List (List.map of_value vs))] + + let xenapi objs = + `List + (List.map + (fun obj -> + let fields, enums1 = fields_of_obj_with_enums obj in + let messages, enums2 = messages_of_obj_with_enums obj in + let enums = Xapi_stdext_std.Listext.List.setify (enums1 @ enums2) in + let event_snapshot = + if String.lowercase_ascii obj.name = "event" then + [ + `Assoc + [ + ("name", `String "snapshot") + ; ( "description" + , `String + "The record of the database object that was added, \ + changed or deleted" + ) + ; ("type", `String "<object record>") + ; ("qualifier", `String (string_of_qualifier DynamicRO)) + ; ("tag", `String "") + ; ("lifecycle", of_lifecycle [(Published, rel_boston, "")]) + ] + ] + else + [] + in + `Assoc [ - JObject - [ - ("name", JString "snapshot") - ; ( "description" - , JString - "The record of the database object that was added, \ - changed or deleted" + ("name", `String obj.name) + ; ("description", `String obj.description) + ; ("fields", `List (event_snapshot @ fields)) + ; ("messages", `List messages) + ; ("enums", `List (List.map of_enum enums)) + ; ("lifecycle", of_lifecycle obj.obj_lifecycle) + ; ( "tag" + , `String + ( match obj.obj_doc_tags with + | [] -> + "" + | t :: _ -> + string_of_doc_tag t ) - ; ("type", JString "<object record>") - ; ("qualifier", JString (string_of_qualifier DynamicRO)) - ; ("tag", JString "") - ; ( "lifecycle" - , jarray_of_lifecycle [(Published, rel_boston, "")] - ) - ] + ) ] - else - [] - in - JObject - [ - ("name", JString obj.name) - ; ("description", JString obj.description) - ; ("fields", JArray (event_snapshot @ fields)) - ; ("messages", JArray messages) - ; ("enums", jarray_of_enums enums) - ; ("lifecycle", jarray_of_lifecycle obj.obj_lifecycle) - ; ( "tag" - , JString - ( match obj.obj_doc_tags with - | [] -> - "" - | t :: _ -> - string_of_doc_tag t - ) - ) - ] - ) - objs - ) + ) + objs + ) -let jobject_of_change (t, n, l, s) = - JObject - [ - ("transition", JString (string_of_lifecycle_transition t ^ " " ^ s)) - ; ("name", JString n) - ; ("log", JString l) - ] + let of_change (t, n, l, s) = + `Assoc + [ + ("transition", `String (string_of_lifecycle_transition t ^ " " ^ s)) + ; ("name", `String n) + ; ("log", `String l) + ] -let compare_changes (a_t, a_n, _, a_k) (b_t, b_n, _, b_k) = - let int_of_transition = function - | Published -> - 0 - | Extended -> - 10 - | Changed -> - 20 - | Deprecated -> - 30 - | Removed -> - 40 - | Prototyped -> - 50 - in - let int_of_kind = function - | "class" -> - 0 - | "field" -> - 1 - | "message" -> - 2 - | _ -> - 3 - in - let cmp = - compare - (int_of_transition a_t + int_of_kind a_k) - (int_of_transition b_t + int_of_kind b_k) - in - if cmp = 0 then - compare a_n b_n - else - cmp - -let releases objs = - let changes_in_release rel = - let search_obj obj = - let changes = - List.filter - (fun (_transition, release, _doc) -> - release = code_name_of_release rel - ) - obj.obj_lifecycle - in - let obj_changes = - List.map - (fun (transition, _release, doc) -> - ( transition - , obj.name - , ( if doc = "" && transition = Published then - obj.description - else - doc - ) - , "class" - ) - ) - changes - in - let changes_for_msg m = + let compare_changes (a_t, a_n, _, a_k) (b_t, b_n, _, b_k) = + let int_of_transition = function + | Published -> + 0 + | Extended -> + 10 + | Changed -> + 20 + | Deprecated -> + 30 + | Removed -> + 40 + | Prototyped -> + 50 + in + let int_of_kind = function + | "class" -> + 0 + | "field" -> + 1 + | "message" -> + 2 + | _ -> + 3 + in + let cmp = + compare + (int_of_transition a_t + int_of_kind a_k) + (int_of_transition b_t + int_of_kind b_k) + in + if cmp = 0 then + compare a_n b_n + else + cmp + + let release_info releases objs = + let changes_in_release rel = + let search_obj obj = let changes = List.filter - (fun (_transition, release, _doc) -> - release = code_name_of_release rel - ) - m.msg_lifecycle + (fun (_, release, _) -> release = code_name_of_release rel) + obj.obj_lifecycle in - List.map - (fun (transition, _release, doc) -> - ( transition - , obj.name ^ "." ^ m.msg_name - , (if doc = "" && transition = Published then m.msg_doc else doc) - , "message" + let obj_changes = + List.map + (fun (transition, _release, doc) -> + ( transition + , obj.name + , ( if doc = "" && transition = Published then + obj.description + else + doc + ) + , "class" + ) ) - ) - changes - in - (* Don't include implicit messages *) - let msgs = List.filter (fun m -> m.msg_tag = Custom) obj.messages in - let msg_changes = - List.fold_left (fun l m -> l @ changes_for_msg m) [] msgs - in - let changes_for_field f = - let changes = - List.filter - (fun (_transition, release, _doc) -> - release = code_name_of_release rel + changes + in + let changes_for_msg m = + let changes = + List.filter + (fun (_transition, release, _doc) -> + release = code_name_of_release rel + ) + m.msg_lifecycle + in + List.map + (fun (transition, _release, doc) -> + ( transition + , obj.name ^ "." ^ m.msg_name + , (if doc = "" && transition = Published then m.msg_doc else doc) + , "message" + ) ) - f.lifecycle + changes in - let field_name = String.concat "_" f.full_name in - List.map - (fun (transition, _release, doc) -> - ( transition - , obj.name ^ "." ^ field_name - , ( if doc = "" && transition = Published then - f.field_description - else - doc + (* Don't include implicit messages *) + let msgs = List.filter (fun m -> m.msg_tag = Custom) obj.messages in + let msg_changes = + List.fold_left (fun l m -> l @ changes_for_msg m) [] msgs + in + let changes_for_field f = + let changes = + List.filter + (fun (_transition, release, _doc) -> + release = code_name_of_release rel + ) + f.lifecycle + in + let field_name = String.concat "_" f.full_name in + List.map + (fun (transition, _release, doc) -> + ( transition + , obj.name ^ "." ^ field_name + , ( if doc = "" && transition = Published then + f.field_description + else + doc + ) + , "field" ) - , "field" ) - ) - changes - in - let rec flatten_contents contents = - List.fold_left - (fun l -> function - | Field f -> - f :: l - | Namespace (_name, contents) -> - flatten_contents contents @ l - ) - [] contents - in - let fields = flatten_contents obj.contents in - let field_changes = - List.fold_left (fun l f -> l @ changes_for_field f) [] fields - in - let event_snapshot_change = - if obj.name = "event" && rel.code_name = Some rel_boston then - [ - ( Published - , "event.snapshot" - , "The record of the database object that was added, changed or \ - deleted" - , "field" + changes + in + let rec flatten_contents contents = + List.fold_left + (fun l -> function + | Field f -> + f :: l + | Namespace (_name, contents) -> + flatten_contents contents @ l ) - ] - else - [] + [] contents + in + let fields = flatten_contents obj.contents in + let field_changes = + List.fold_left (fun l f -> l @ changes_for_field f) [] fields + in + let event_snapshot_change = + if obj.name = "event" && rel.code_name = Some rel_boston then + [ + ( Published + , "event.snapshot" + , "The record of the database object that was added, changed or \ + deleted" + , "field" + ) + ] + else + [] + in + obj_changes @ event_snapshot_change @ field_changes @ msg_changes in - obj_changes @ event_snapshot_change @ field_changes @ msg_changes + `List + (List.concat_map search_obj objs + |> List.sort compare_changes + |> List.map of_change + ) + in + `Assoc + (List.filter_map + (fun rel -> + if rel.code_name <> None then + Some (code_name_of_release rel, changes_in_release rel) + else + None + ) + releases + ) +end + +module Yaml = struct + let release = function + | {code_name= Some x; branding; release_date= Some _; _} -> + Printf.sprintf "%s: %s\n" x branding + | _ -> + "" +end + +type file = {filename: string; contents: string} + +module Md = struct + let release = function + | {release_date= None; _} -> + None + | {code_name= Some x; release_date= y; _} -> + let contents = + String.concat "\n" + [ + "---" + ; "layout: xenapi-release" + ; Printf.sprintf "release: %s" x + ; "release_index: true" + ; "---\n" + ; ( match y with + | Some "" -> + "" + | Some z -> + Printf.sprintf "Released in %s.\n" z + | _ -> + "" + ) + ] + in + Some {filename= Printf.sprintf "%s.md" x; contents} + | _ -> + None + + let cls {name; _} = + let filename = Printf.sprintf "%s.md" (String.lowercase_ascii name) in + let contents = + String.concat "\n" + [ + "---" + ; "layout: xenapi-class" + ; Printf.sprintf "class: %s" name + ; "class_index: true" + ; "---\n" + ] in - JArray - (List.map search_obj objs - |> List.flatten - |> List.sort compare_changes - |> List.map jobject_of_change + Some {filename; contents} +end + +let write_to_dir dir maybe_file = + let write {filename; contents} = + write_string ~path:(dir // filename) contents + in + Option.iter write maybe_file + +module Version = struct + type t = int list + + let rec compare x y = + match (x, y) with + | x :: xs, y :: ys when x = y -> + compare xs ys + | x :: _, y :: _ -> + Int.compare x y + | x :: _, [] when x = 0 -> + 0 + | _ :: _, [] -> + 1 + | [], y :: _ when y = 0 -> + 0 + | [], _ :: _ -> + -1 + | [], [] -> + 0 +end + +module NameSet = Set.Make (String) +module VersionSet = Set.Make (Version) + +let string_of_version = Fmt.(str "%a" (list ~sep:(Fmt.any ".") int)) + +let get_versions_from api = + let classes = Dm_api.objects_of_api api in + let rec from_field = function + | Field fld -> + fld.lifecycle + | Namespace (_, nms) -> + List.concat_map from_field nms + in + let from_message {msg_lifecycle; _} = msg_lifecycle in + let versions_from_class (cls : obj) = + let field_lifecycles = List.concat_map from_field cls.contents in + let message_lifecycles = List.concat_map from_message cls.messages in + List.concat + [cls.Datamodel_types.obj_lifecycle; field_lifecycles; message_lifecycles] + in + let is_named_release name = + List.exists + (fun x -> + match x.code_name with Some n when n = name -> true | _ -> false ) + release_order_full + in + (* now gather versions from the lifecycles *) + let versions = + List.concat_map versions_from_class classes + |> List.to_seq + |> Seq.map (fun (_, version, _) -> version) + |> NameSet.of_seq + |> NameSet.filter (fun x -> not (is_named_release x)) + |> NameSet.to_seq + |> Seq.map (fun v -> String.split_on_char '.' v |> List.map int_of_string) + |> VersionSet.of_seq + |> VersionSet.elements + in + (* now transform the versions to releases, in a free-form way *) + let release_of_version v = + let name = string_of_version v in + { + code_name= Some name + ; version_major= 2 + ; version_minor= 20 + ; release_date= Some "" + ; branding= Printf.sprintf "XAPI %s" name + } in - JObject - (List.map - (fun rel -> (code_name_of_release rel, changes_in_release rel)) - release_order - ) + release_order_full @ List.map release_of_version versions -let _ = +let () = parse_args () ; let destdir = !destdir' in Xapi_stdext_unix.Unixext.mkdir_rec destdir 0o755 ; - let data_dir = Filename.concat destdir "_data" in + let data_dir = destdir // "_data" in Xapi_stdext_unix.Unixext.mkdir_rec data_dir 0o755 ; let api = Datamodel.all_api in (* Add all implicit messages *) @@ -578,67 +633,17 @@ let _ = api in let objs = objects_of_api api in - Xapi_stdext_unix.Unixext.write_string_to_file - (Filename.concat data_dir "xenapi.json") - (objs |> json_of_objs |> string_of_json 0) ; - let release_info = releases objs in - Xapi_stdext_unix.Unixext.write_string_to_file - (Filename.concat data_dir "release_info.json") - (string_of_json 0 release_info) ; - let release_yaml = function - | {release_date= None; _} -> - "" - | {code_name= Some x; branding= y; _} -> - Printf.sprintf "%s: %s\n" x y - | _ -> - "" - in - Xapi_stdext_unix.Unixext.write_string_to_file - (Filename.concat data_dir "releases.yml") - (release_order_full |> List.map release_yaml |> String.concat "") ; - let release_md_dir = Filename.concat destdir "xen-api/releases" in + let releases = get_versions_from api in + Yojson.Safe.to_file (data_dir // "xenapi.json") (Json.xenapi objs) ; + Yojson.Safe.to_file + (data_dir // "release_info.json") + (Json.release_info releases objs) ; + write_string + ~path:(data_dir // "releases.yml") + (List.map Yaml.release releases |> String.concat "") ; + let release_md_dir = destdir // "xen-api/releases" in Xapi_stdext_unix.Unixext.mkdir_rec release_md_dir 0o755 ; - let class_md_dir = Filename.concat destdir "xen-api/classes" in + let class_md_dir = destdir // "xen-api/classes" in Xapi_stdext_unix.Unixext.mkdir_rec class_md_dir 0o755 ; - let release_md = function - | {release_date= None; _} -> - () - | {code_name= Some x; release_date= y; _} -> - [ - "---" - ; "layout: xenapi-release" - ; Printf.sprintf "release: %s" x - ; "release_index: true" - ; "---\n" - ; ( match y with - | Some "" -> - "" - | Some z -> - Printf.sprintf "Released in %s.\n" z - | _ -> - "" - ) - ] - |> String.concat "\n" - |> Xapi_stdext_unix.Unixext.write_string_to_file - (Filename.concat release_md_dir (Printf.sprintf "%s.md" x)) - | _ -> - () - in - release_order_full |> List.iter release_md ; - let class_md = function - | {name; _} -> - [ - "---" - ; "layout: xenapi-class" - ; Printf.sprintf "class: %s" name - ; "class_index: true" - ; "---\n" - ] - |> String.concat "\n" - |> Xapi_stdext_unix.Unixext.write_string_to_file - (Filename.concat class_md_dir - (Printf.sprintf "%s.md" (String.lowercase_ascii name)) - ) - in - objs |> List.iter class_md + List.iter (fun x -> write_to_dir release_md_dir (Md.release x)) releases ; + List.iter (fun x -> write_to_dir class_md_dir (Md.cls x)) objs diff --git a/ocaml/idl/json_backend/gen_json.mli b/ocaml/idl/json_backend/gen_json.mli new file mode 100644 index 00000000000..e69de29bb2d diff --git a/quality-gate.sh b/quality-gate.sh index a8381e1976f..fea968aa1b2 100755 --- a/quality-gate.sh +++ b/quality-gate.sh @@ -6,7 +6,7 @@ list-hd () { N=329 LIST_HD=$(git grep -r --count 'List.hd' -- **/*.ml | cut -d ':' -f 2 | paste -sd+ - | bc) if [ "$LIST_HD" -eq "$N" ]; then - echo "OK counted $LIST_HD usages" + echo "OK counted $LIST_HD List.hd usages" else echo "ERROR expected $N List.hd usages, got $LIST_HD" 1>&2 exit 1 @@ -25,7 +25,7 @@ verify-cert () { } mli-files () { - N=515 + N=514 # do not count ml files from the tests in ocaml/{tests/perftest/quicktest} MLIS=$(git ls-files -- '**/*.mli' | grep -vE "ocaml/tests|ocaml/perftest|ocaml/quicktest" | xargs -I {} sh -c "echo {} | cut -f 1 -d '.'" \;) MLS=$(git ls-files -- '**/*.ml' | grep -vE "ocaml/tests|ocaml/perftest|ocaml/quicktest" | xargs -I {} sh -c "echo {} | cut -f 1 -d '.'" \;)