diff --git a/albatross.ml b/albatross.ml index 5337ad4d..d4946544 100644 --- a/albatross.ml +++ b/albatross.ml @@ -1,3 +1,7 @@ +let ( let* ) = Result.bind + +module String_set = Set.Make (String) + module Make (T : Mirage_time.S) (P : Mirage_clock.PCLOCK) (S : Tcpip.Stack.V4V6) = struct module TLS = Tls_mirage.Make (S.TCP) @@ -91,6 +95,130 @@ struct } | Error (`Msg err) -> Error err + let manifest_devices_match ~bridges ~block_devices binary = + let cachet = + let map () ~pos len = + if pos >= String.length binary || len <= 0 then + (Cachet.Bstr.empty :> Cachet.bigstring) + else + let len = min len (max 0 (String.length binary - pos)) in + let b : Cachet.bigstring = + Bigarray.Array1.create Bigarray.char Bigarray.c_layout len + in + for i = 0 to len - 1 do + b.{i} <- binary.[pos + i] + done; + b + in + Cachet.make ~cachesize:8 ~map () + in + let* mft : Solo5_elftool.mft = Solo5_elftool.query_manifest cachet in + let req_bridges = + List.map (fun (name, _, _) -> name) bridges |> String_set.of_list + and req_block_devices = + List.map (fun (name, _, _) -> name) block_devices |> String_set.of_list + and mft_bridges = + List.filter_map + (function Solo5_elftool.Dev_net_basic name -> Some name | _ -> None) + mft.Solo5_elftool.entries + |> String_set.of_list + and mft_block_devices = + List.filter_map + (function Solo5_elftool.Dev_block_basic name -> Some name | _ -> None) + mft.Solo5_elftool.entries + |> String_set.of_list + in + let req_only_bridges = String_set.(diff req_bridges mft_bridges |> elements) + and mft_only_bridges = String_set.(diff mft_bridges req_bridges |> elements) + and req_only_blocks = + String_set.(diff req_block_devices mft_block_devices |> elements) + and mft_only_blocks = + String_set.(diff mft_block_devices req_block_devices |> elements) + in + match + (req_only_bridges, mft_only_bridges, req_only_blocks, mft_only_blocks) + with + | [], [], [], [] -> Ok () + | req_only_bridges, [], [], [] -> + Error + (`Msg + ("Extra network interfaces specified: " + ^ String.concat ", " req_only_bridges + ^ ". Please remove them from the 'network_interfaces' list of \ + your configuration.")) + | [], mft_only_bridges, [], [] -> + Error + (`Msg + ("Missing required network interfaces: " + ^ String.concat ", " mft_only_bridges + ^ ". Please add them to the 'network_interfaces' list of your \ + configuration.")) + | [], [], req_only_blocks, [] -> + Error + (`Msg + ("Extra block devices specified: " + ^ String.concat ", " req_only_blocks + ^ ". Please remove them from the 'block_devices' list of your \ + configuration.")) + | [], [], [], mft_only_blocks -> + Error + (`Msg + ("Missing required block devices: " + ^ String.concat ", " mft_only_blocks + ^ ". Please add them to the 'block_devices' list of your \ + configuration.")) + | req_only_bridges, [], req_only_blocks, [] -> + Error + (`Msg + ("Extra network interfaces: " + ^ String.concat ", " req_only_bridges + ^ " and extra block devices: " + ^ String.concat ", " req_only_blocks + ^ ". Please remove them from the 'network_interfaces' lists and \ + 'block_devices' list of your configuration.")) + | [], mft_only_bridges, [], mft_only_blocks -> + Error + (`Msg + ("Missing network interfaces: " + ^ String.concat ", " mft_only_bridges + ^ " and missing block devices: " + ^ String.concat ", " mft_only_blocks + ^ ". Please add them to the 'network_interfaces' lists and \ + 'block_devices' list of your configuration.")) + | req_only_bridges, [], [], mft_only_blocks -> + Error + (`Msg + ("Extra network interfaces: " + ^ String.concat ", " req_only_bridges + ^ " and missing block devices: " + ^ String.concat ", " mft_only_blocks + ^ ". Please remove the network interfaces from the \ + 'network_interfaces' list and add the block devices to the \ + 'block_devices' list of your configuration.")) + | [], mft_only_bridges, req_only_blocks, [] -> + Error + (`Msg + ("Missing network interfaces: " + ^ String.concat ", " mft_only_bridges + ^ " and extra block devices: " + ^ String.concat ", " req_only_blocks + ^ ". Please add the network interfaces to the \ + 'network_interfaces' list and remove the block devices from \ + the 'block_devices' list of your configuration.")) + | req_only_bridges, mft_only_bridges, req_only_blocks, mft_only_blocks -> + Error + (`Msg + ("Missing network interfaces: " + ^ String.concat ", " req_only_bridges + ^ " and missing block devices: " + ^ String.concat ", " req_only_blocks + ^ " while also having extra network interfaces: " + ^ String.concat ", " mft_only_bridges + ^ " and extra block devices: " + ^ String.concat ", " mft_only_blocks + ^ ". Please update 'network_interfaces' and 'block_devices' \ + accordingly.")) + let key_ids exts pub issuer = let open X509 in let auth = (Some (Public_key.id issuer), General_name.empty, None) in diff --git a/albatross_json.ml b/albatross_json.ml index 4cb1398d..b546f48f 100644 --- a/albatross_json.ml +++ b/albatross_json.ml @@ -1,8 +1,7 @@ open Utils.Json let unikernel_info (unikernel_name, info) = - let typ = function `Solo5 -> `String "solo5" - and fail_behaviour = function + let fail_behaviour = function | `Quit -> `String "quit" | `Restart ex -> let els = @@ -33,33 +32,25 @@ let unikernel_info (unikernel_name, info) = in `List (List.map block bs) and bridges bs = - let bridge (name, dev, mac) = + let bridge (name, dev, _) = let dev = Option.value ~default:name dev in - let mac = - Option.value ~default:(Vmm_core.Name.mac unikernel_name dev) mac - in - `Assoc - [ - ("name", `String name); - ("host_device", `String dev); - ("mac", `String (Macaddr.to_string mac)); - ] + `Assoc [ ("name", `String name); ("host_device", `String dev) ] in `List (List.map bridge bs) and argv args = `List (List.map (fun a -> `String a) (Option.value ~default:[] args)) - and digest d = `String (Ohex.encode d) in + in `Assoc [ - ("name", `String (Vmm_core.Name.to_string unikernel_name)); - ("typ", typ info.Vmm_core.Unikernel.typ); - ("fail_behaviour", fail_behaviour info.fail_behaviour); + ( "name", + `String (Option.value ~default:"" (Vmm_core.Name.name unikernel_name)) + ); + ("fail_behaviour", fail_behaviour info.Vmm_core.Unikernel.fail_behaviour); ("cpuid", cpuid info.cpuid); ("memory", memory info.memory); ("block_devices", block_devices info.block_devices); ("network_interfaces", bridges info.bridges); ("arguments", argv info.argv); - ("digest", digest info.digest); ] let unikernel_infos is = `List (List.map unikernel_info is) diff --git a/assets/main.js b/assets/main.js index 292812ab..e9d67f29 100644 --- a/assets/main.js +++ b/assets/main.js @@ -920,11 +920,59 @@ async function updateToken(value) { buttonLoading(tokenButton, false, "Update Token") } } catch (error) { - postAlert("bg-secondary-300", data.data); + postAlert("bg-secondary-300", error); buttonLoading(tokenButton, false, "Update Token") } } +async function updateUnikernel(job, build, unikernel_name) { + const updateButton = document.getElementById("update-unikernel-button"); + const unikernelArguments = document.getElementById("unikernel-arguments").value; + const argumentsToggle = document.getElementById("arguments-toggle").checked; + const molly_csrf = document.getElementById("molly-csrf").value; + const formAlert = document.getElementById("unikernel-arguments-alert"); + if (argumentsToggle && !unikernelArguments) { + postAlert("bg-secondary-300", "You must give arguments for this build else switch 'Update the configuration for this build' off"); + buttonLoading(updateButton, false, "Proceed to update") + return; + } + try { + buttonLoading(updateButton, true, "Updating...") + const response = await fetch("/api/unikernel/update", { + method: 'POST', + headers: { + "Content-Type": "application/json", + }, + body: JSON.stringify( + { + "job": job, + "build": build, + "unikernel_name": unikernel_name, + "unikernel_arguments": argumentsToggle ? JSON.parse(unikernelArguments) : null, + "molly_csrf": molly_csrf + }) + }) + const data = await response.json(); + if (data.status === 200) { + postAlert("bg-primary-300", "Unikernel updated succesfully"); + setTimeout(() => window.location.reload(), 1000); + buttonLoading(updateButton, false, "Proceed to update") + } else { + postAlert("bg-secondary-300", data.data); + formAlert.classList.remove("hidden", "text-primary-500"); + formAlert.classList.add("text-secondary-500"); + formAlert.textContent = data.data + buttonLoading(updateButton, false, "Proceed to update") + } + } catch (error) { + postAlert("bg-secondary-300", error); + formAlert.classList.remove("hidden", "text-primary-500"); + formAlert.classList.add("text-secondary-500"); + formAlert.textContent = data.data + buttonLoading(updateButton, false, "Proceed to update") + } +} + function isValidName(s) { const length = s.length; if (length === 0 || length >= 64) return false; diff --git a/config.ml b/config.ml index 4b98b9ae..77755d73 100644 --- a/config.ml +++ b/config.ml @@ -23,6 +23,7 @@ let mollymawk = package "duration"; package ~min:"0.2.0" "ohex"; package "http-mirage-client"; + package "solo5-elftool" ~min:"0.4.0"; ] in main ~packages "Unikernel.Main" diff --git a/unikernel.ml b/unikernel.ml index 79d6e13c..b2a4c4fd 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -1204,6 +1204,7 @@ struct ~content: (Unikernel_update .unikernel_update_layout + ~unikernel_name:name (unikernel_name, unikernel) now build_comparison) ~icon:"/images/robur.png" ()) @@ -1240,6 +1241,134 @@ struct ~api_meth:false `Internal_server_error reqd ())))))) + let process_unikernel_update ~unikernel_name ~job ~build + (unikernel_cfg : Vmm_core.Unikernel.config) (user : User_model.user) + albatross http_client reqd = + Builder_web.send_request http_client + ("/job/" ^ job ^ "/build/" ^ build ^ "/main-binary") + >>= function + | Error (`Msg err) -> + Logs.err (fun m -> + m + "builds.robur.coop: Error while fetching the binary of %s with \ + error: %s" + unikernel_name err); + Middleware.http_response reqd ~title:"Error" + ~data: + (`String + ("An error occured while fetching the binary from \ + builds.robur.coop with error " ^ err)) + `Internal_server_error + | Ok image -> ( + match + Albatross.manifest_devices_match ~bridges:unikernel_cfg.bridges + ~block_devices:unikernel_cfg.block_devices image + with + | Error (`Msg err) -> + Middleware.http_response reqd ~title:"Error" + ~data: + (`String + ("An error occured with the unikernel configuration: " ^ err)) + `Bad_request + | Ok () -> ( + let unikernel_config = { unikernel_cfg with image } in + Albatross.query albatross ~domain:user.name ~name:unikernel_name + (`Unikernel_cmd (`Unikernel_force_create unikernel_config)) + >>= function + | Error msg -> + Logs.err (fun m -> + m "albatross-force-create: error querying albatross: %s" msg); + Middleware.http_response reqd ~title:"Error" + ~data: + (`String ("Force create: Error querying albatross: " ^ msg)) + `Internal_server_error + | Ok (_hdr, res) -> ( + match Albatross_json.res res with + | Error (`String err) -> + Middleware.http_response reqd ~title:"Error" + ~data: + (`String + ("albatross force-create: " ^ String.escaped err)) + `Internal_server_error + | Ok res -> + Logs.info (fun m -> + m "%s has been updated succesfully with result: %s" + unikernel_name + (Yojson.Basic.to_string res)); + Middleware.http_response reqd ~title:"Update Successful" + ~data: + (`String + (unikernel_name + ^ " has been updated to the latest build with uuid " + ^ build)) + `OK))) + + let unikernel_update albatross reqd http_client ~json_dict + (user : User_model.user) = + let config_or_none field = function + | None | Some `Null -> Ok None + | Some json -> ( + match Albatross_json.config_of_json (Yojson.Basic.to_string json) with + | Ok cfg -> Ok (Some cfg) + | Error (`Msg err) -> + Error + (`Msg + ("invalid json for " ^ field ^ ": " + ^ Yojson.Basic.to_string json + ^ "failed with: " ^ err))) + in + match + Utils.Json. + ( get "job" json_dict, + get "build" json_dict, + get "unikernel_name" json_dict, + get "unikernel_arguments" json_dict ) + with + | ( Some (`String job), + Some (`String build), + Some (`String unikernel_name), + configuration ) -> ( + match config_or_none "unikernel_arguments" configuration with + | Error (`Msg err) -> + Middleware.http_response reqd + ~title:"Error with Unikernel Arguments Json" + ~data: + (`String ("Could not get the unikernel arguments json: " ^ err)) + `OK + | Ok None -> ( + user_unikernel albatross ~user_name:user.name ~unikernel_name + >>= fun unikernel_info -> + match unikernel_info with + | Error err -> + Middleware.redirect_to_error + ~data: + (`String + ("An error occured while fetching " ^ unikernel_name + ^ " from albatross with error " ^ err)) + ~title:"Albatross Error" ~api_meth:false + `Internal_server_error reqd () + | Ok (n, unikernel) -> ( + match + Albatross_json.( + unikernel_info (n, unikernel) + |> Yojson.Basic.to_string |> config_of_json) + with + | Ok cfg -> + process_unikernel_update ~unikernel_name ~job ~build cfg + user albatross http_client reqd + | Error (`Msg err) -> + Logs.warn (fun m -> m "Couldn't decode data %s" err); + Middleware.http_response reqd ~title:"Error" + ~data:(`String (String.escaped err)) + `Internal_server_error)) + | Ok (Some cfg) -> + process_unikernel_update ~unikernel_name ~job ~build cfg user + albatross http_client reqd) + | _ -> + Middleware.http_response reqd ~title:"Error" + ~data:(`String "Couldn't find job or build in json. Received ") + `Bad_request + let unikernel_destroy ~json_dict albatross reqd (user : User_model.user) = (* TODO use uuid in the future *) match Utils.Json.get "name" json_dict with @@ -2125,6 +2254,11 @@ struct authenticate store reqd (unikernel_prepare_update !albatross store unikernel_name reqd http_client)) + | "/api/unikernel/update" -> + check_meth `POST (fun () -> + authenticate ~check_token:true ~check_csrf:true ~api_meth:true + store reqd + (unikernel_update !albatross reqd http_client)) | _ -> let error = { diff --git a/unikernel_update.ml b/unikernel_update.ml index 2d81774d..54a30544 100644 --- a/unikernel_update.ml +++ b/unikernel_update.ml @@ -1,3 +1,141 @@ +let arg_modal ~unikernel_name + (unikernel : Vmm_core.Name.t * Vmm_core.Unikernel.info) + (build : Builder_web.build) = + Tyxml_html.( + section + [ + p ~a:[ a_id "unikernel-arguments-alert"; a_class [ "my-4 hidden" ] ] []; + div + ~a:[ a_class [ "my-4" ] ] + [ + div + ~a: + [ + a_class [ "my-6" ]; + Unsafe.string_attrib "x-data" "{ changeArgs: false}"; + ] + [ + label + ~a: + [ + a_label_for "arguments-toggle"; + a_class + [ "inline-flex cursor-pointer items-center gap-3" ]; + ] + [ + input + ~a: + [ + a_id "arguments-toggle"; + a_input_type `Checkbox; + a_class [ "peer sr-only" ]; + a_role [ "switch" ]; + Unsafe.string_attrib "x-on:click" + "changeArgs = !changeArgs"; + ] + (); + span + ~a: + [ + a_aria "hidden" [ "true" ]; + a_class + [ + "relative h-6 w-11 after:h-5 after:w-5 \ + peer-checked:after:translate-x-5 rounded-full \ + border border-gray-300 bg-gray-50 \ + after:absolute after:bottom-0 \ + after:left-[0.0625rem] after:top-0 \ + after:my-auto after:rounded-full \ + after:bg-gray-600 after:transition-all \ + after:content-[''] peer-checked:bg-primary-500 \ + peer-checked:after:bg-white peer-focus:outline \ + peer-focus:outline-2 \ + peer-focus:outline-offset-2 \ + peer-focus:outline-gray-800 \ + peer-focus:peer-checked:outline-primary-500 \ + peer-active:outline-offset-0 \ + peer-disabled:cursor-not-allowed \ + peer-disabled:opacity-70 dark:border-gray-700 \ + dark:bg-gray-900 dark:after:bg-gray-300 \ + dark:peer-checked:bg-primary-500 \ + dark:peer-checked:after:bg-white \ + dark:peer-focus:outline-gray-300 \ + dark:peer-focus:peer-checked:outline-primary-500"; + ]; + ] + []; + span + ~a: + [ + a_class + [ + "trancking-wide text-sm font-medium \ + text-gray-600 peer-checked:text-gray-900 \ + peer-disabled:cursor-not-allowed \n\ + \ \ + dark:peer-checked:text-white"; + ]; + ] + [ txt "Update the configuration for this build" ]; + ]; + div + ~a: + [ + Unsafe.string_attrib "x-show" "changeArgs"; + a_class [ "my-4" ]; + ] + [ + small + ~a:[ a_class [ "my-1" ] ] + [ + txt + "Use json syntax to provide arguments for the latest \ + build"; + ]; + textarea + ~a: + [ + a_rows 15; + a_required (); + a_name "arguments"; + a_id "unikernel-arguments"; + a_class + [ + "ring-primary-100 mt-1.5 transition \ + appearance-none block w-full px-3 py-3 \ + rounded-xl shadow-sm border \ + hover:border-primary-200\n\ + \ \ + focus:border-primary-300 bg-primary-50 \ + bg-opacity-0 hover:bg-opacity-50 \ + focus:bg-opacity-50 ring-primary-200 \ + focus:ring-primary-200\n\ + \ \ + focus:ring-[1px] focus:outline-none"; + ]; + ] + (txt + (Albatross_json.unikernel_info unikernel + |> Yojson.Basic.pretty_to_string)); + ]; + ]; + ]; + hr (); + div + ~a:[ a_class [ "my-4" ] ] + [ + Utils.button_component + ~attribs: + [ + a_id "update-unikernel-button"; + a_onclick + ("updateUnikernel('" ^ build.job ^ "','" ^ build.uuid + ^ "','" ^ unikernel_name ^ "')"); + ] + ~content:(txt "Proceed to update") ~btn_type:`Primary_full (); + ]; + ]) + let build_table (build : Builder_web.build) = Tyxml_html.( table @@ -65,6 +203,15 @@ let build_table (build : Builder_web.build) = ~a:[ a_class [ "px-6 py-1 text-sm font-medium text-gray-800" ] ] [ txt (Utils.TimeHelper.string_of_ptime build.finish_time) ]; ]; + tr + [ + td + ~a:[ a_class [ "px-6 py-1 text-sm font-medium text-gray-800" ] ] + [ txt "Has binary" ]; + td + ~a:[ a_class [ "px-6 py-1 text-sm font-medium text-gray-800" ] ] + [ txt (string_of_bool build.main_binary) ]; + ]; tr [ td @@ -258,13 +405,16 @@ let opam_diff_table (diffs : Builder_web.o_diff list) = ]) diffs)) -let unikernel_update_layout unikernel current_time +let unikernel_update_layout ~unikernel_name unikernel current_time (build_comparison : Builder_web.compare) = let u_name, data = unikernel in Tyxml_html.( section ~a:[ a_class [ "col-span-10 p-4 bg-gray-50 my-1" ] ] [ + p + ~a:[ a_id "unikernel-update-form-alert"; a_class [ "my-4 hidden" ] ] + []; div ~a:[ a_id "unikernel-container"; a_class [ "p-4 rounded-md" ] ] [ @@ -300,21 +450,18 @@ let unikernel_update_layout unikernel current_time ~a:[ a_class [ "text-sm" ] ] [ txt (Ohex.encode data.digest) ]; ]; - div - [ - a - ~a: - [ - a_href "/unikernel/update/"; - a_class - [ - "py-2 px-2 rounded hover:bg-primary-800 \ - text-gray-50 focus:outline-none \ - bg-primary-500 font-semibold"; - ]; - ] - [ txt "Update to Latest" ]; - ]; + (if build_comparison.right.main_binary then + Modal_dialog.modal_dialog + ~modal_title:"Unikernel Configuration" + ~button_content:(txt "Update to Latest") + ~content: + (arg_modal ~unikernel_name unikernel + build_comparison.right) + () + else + p + ~a:[ a_class [ "text-secondary-500 font-semibold" ] ] + [ txt "Can't update. No binary in latest build." ]); ]; div ~a:[ a_class [ "grid grid-cols-2 divide-x-2 gap-4" ] ] @@ -432,18 +579,14 @@ let unikernel_update_layout unikernel current_time ]; ]; ]; - div - [ - a - ~a: - [ - a_href "/unikernel/update/"; - a_class - [ - "py-2 px-2 rounded hover:bg-primary-800 text-gray-50 \ - focus:outline-none bg-primary-500 font-semibold"; - ]; - ] - [ txt "Update to Latest" ]; - ]; + (if build_comparison.right.main_binary then + Modal_dialog.modal_dialog ~modal_title:"Unikernel Configuration" + ~button_content:(txt "Update to Latest") + ~content: + (arg_modal ~unikernel_name unikernel build_comparison.right) + () + else + p + ~a:[ a_class [ "text-secondary-500 font-semibold" ] ] + [ txt "Can't update. No binary in latest build." ]); ]) diff --git a/user_model.ml b/user_model.ml index 4b96770d..ac527fc0 100644 --- a/user_model.ml +++ b/user_model.ml @@ -58,13 +58,6 @@ let cookie_to_json (cookie : cookie) = | None -> `Null ); ] -let string_or_none field = function - | None | Some `Null -> Ok None - | Some (`String v) -> Ok (Some v) - | Some json -> - Error - (`Msg ("invalid json for " ^ field ^ ": " ^ Yojson.Basic.to_string json)) - let ( let* ) = Result.bind let cookie_v1_of_json = function @@ -91,7 +84,7 @@ let cookie_v1_of_json = function created_at_str); Ptime.epoch in - let* uuid = string_or_none "uuid" uuid in + let* uuid = Utils.Json.string_or_none "uuid" uuid in Ok { name; @@ -150,8 +143,8 @@ let cookie_of_json = function last_access_str); created_at in - let* uuid = string_or_none "uuid" uuid in - let* user_agent = string_or_none "user-agent" user_agent in + let* uuid = Utils.Json.string_or_none "uuid" uuid in + let* user_agent = Utils.Json.string_or_none "user-agent" user_agent in Ok { name; diff --git a/utils.ml b/utils.ml index 548f69c2..ac963796 100644 --- a/utils.ml +++ b/utils.ml @@ -1,6 +1,14 @@ module Json = struct let get key assoc = Option.map snd (List.find_opt (fun (k, _) -> String.equal k key) assoc) + + let string_or_none field = function + | None | Some `Null -> Ok None + | Some (`String v) -> Ok (Some v) + | Some json -> + Error + (`Msg + ("invalid json for " ^ field ^ ": " ^ Yojson.Basic.to_string json)) end module TimeHelper = struct