From 15a12b687308275c4778b6b623197d60e42945ed Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ignas=20Vy=C5=A1niauskas?= Date: Fri, 22 Nov 2024 10:44:58 +0200 Subject: [PATCH 1/7] Bump dune to newer version and fix compile warning 3.11 is the latest available on current nixpkgs channel used --- controller/dune-project | 2 +- controller/server/update_client.mli | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/controller/dune-project b/controller/dune-project index a26d6e27..dd91f463 100644 --- a/controller/dune-project +++ b/controller/dune-project @@ -1 +1 @@ -(lang dune 1.6) +(lang dune 3.11) diff --git a/controller/server/update_client.mli b/controller/server/update_client.mli index d870b9fd..8aa25266 100644 --- a/controller/server/update_client.mli +++ b/controller/server/update_client.mli @@ -17,6 +17,6 @@ end val make_deps : ?download_dir:string -> (unit -> Uri.t option Lwt.t) -> Uri.t -> (module UpdateClientDeps) -module Make (DepsI : UpdateClientDeps) : S +module Make (_ : UpdateClientDeps) : S val build_module : Connman.Manager.t -> (module S) From b3f3417482fb22a6487585b691f64a6f43c5ba66 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ignas=20Vy=C5=A1niauskas?= Date: Fri, 22 Nov 2024 11:10:01 +0200 Subject: [PATCH 2/7] Add ocamlformat and set profile --- controller/.ocamlformat | 13 +++++++++++++ controller/shell.nix | 5 ++++- 2 files changed, 17 insertions(+), 1 deletion(-) create mode 100644 controller/.ocamlformat diff --git a/controller/.ocamlformat b/controller/.ocamlformat new file mode 100644 index 00000000..bf3d73d6 --- /dev/null +++ b/controller/.ocamlformat @@ -0,0 +1,13 @@ +version = 0.26.1 + +profile = ocamlformat + +break-infix = wrap-or-vertical +doc-comments = before +field-space = loose +indicate-multiline-delimiters = closing-on-separate-line +space-around-arrays = true +space-around-lists = true +space-around-records = true +space-around-variants = true +type-decl = sparse diff --git a/controller/shell.nix b/controller/shell.nix index 5342dcec..7541fd11 100644 --- a/controller/shell.nix +++ b/controller/shell.nix @@ -12,5 +12,8 @@ pkgs.mkShell { packages = playos-controller.buildInputs ++ playos-controller.nativeBuildInputs - ++ [ pkgs.watchexec ]; + ++ [ + pkgs.watchexec + pkgs.ocamlformat + ]; } From d67590d2cd504ed931e225834746f9e13b3a27fa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ignas=20Vy=C5=A1niauskas?= Date: Thu, 28 Nov 2024 14:04:35 +0200 Subject: [PATCH 3/7] dune fmt ocaml code --- controller/bindings/connman/connman.ml | 1075 +++++++++-------- controller/bindings/connman/connman.mli | 123 +- controller/bindings/connman/dune | 16 +- controller/bindings/curl/curl.ml | 107 +- controller/bindings/curl/curl.mli | 4 +- controller/bindings/curl/dune | 3 +- controller/bindings/locale/dune | 4 +- controller/bindings/locale/locale.mli | 6 +- controller/bindings/rauc/dune | 5 +- controller/bindings/rauc/rauc.ml | 163 +-- controller/bindings/rauc/rauc.mli | 8 +- controller/bindings/screen-settings/dune | 3 +- .../screen-settings/screen_settings.ml | 61 +- .../screen-settings/screen_settings.mli | 4 +- controller/bindings/systemd/dune | 3 +- controller/bindings/systemd/systemd.ml | 710 +++++------ controller/bindings/systemd/systemd.mli | 2 - controller/bindings/timedate/dune | 5 +- controller/bindings/timedate/timedate.ml | 61 +- controller/bindings/timedate/timedate.mli | 16 +- controller/bindings/util/dune | 4 +- controller/bindings/util/util.ml | 66 +- controller/bindings/zerotier/dune | 3 +- controller/bindings/zerotier/zerotier.ml | 24 +- controller/bindings/zerotier/zerotier.mli | 4 +- controller/config/config.ml | 20 +- controller/config/dune | 3 +- controller/dune | 5 +- controller/server/dune | 73 +- controller/server/gui.ml | 572 +++++---- controller/server/gui.mli | 12 +- controller/server/health.ml | 80 +- controller/server/health.mli | 5 +- controller/server/info.ml | 45 +- controller/server/logging.ml | 25 +- controller/server/network.ml | 103 +- controller/server/network.mli | 13 +- controller/server/rauc_service.ml | 48 +- controller/server/rauc_service.mli | 20 +- controller/server/server.ml | 117 +- controller/server/update.ml | 358 +++--- controller/server/update.mli | 49 +- controller/server/update_client.ml | 128 +- controller/server/update_client.mli | 22 +- controller/server/view/changelog_page.ml | 7 +- controller/server/view/changelog_page.mli | 4 +- controller/server/view/common/definition.ml | 16 +- controller/server/view/common/definition.mli | 18 +- controller/server/view/common/icon.ml | 102 +- controller/server/view/common/icon.mli | 9 + controller/server/view/common/page.ml | 177 +-- controller/server/view/common/page.mli | 18 +- controller/server/view/error_page.ml | 18 +- controller/server/view/error_page.mli | 8 +- controller/server/view/info_page.ml | 63 +- controller/server/view/info_page.mli | 4 +- controller/server/view/licensing_page.ml | 65 +- controller/server/view/licensing_page.mli | 3 +- controller/server/view/localization_page.ml | 142 +-- controller/server/view/localization_page.mli | 16 +- .../server/view/network_details_page.ml | 408 ++++--- .../server/view/network_details_page.mli | 4 +- controller/server/view/network_list_page.ml | 147 +-- controller/server/view/network_list_page.mli | 12 +- controller/server/view/status_page.ml | 208 ++-- controller/server/view/status_page.mli | 18 +- controller/tests/server/mocks/dune | 8 +- controller/tests/server/mocks/mock_rauc.ml | 145 +-- .../tests/server/mocks/mock_update_client.ml | 74 +- controller/tests/server/update/dune | 26 +- controller/tests/server/update/helpers.ml | 177 ++- controller/tests/server/update/outcome.ml | 115 +- controller/tests/server/update/scenario.ml | 193 +-- .../update/update_client_mock_server.ml | 182 ++- .../server/update/update_client_tests.ml | 265 ++-- .../tests/server/update/update_prop_tests.ml | 195 ++- .../tests/server/update/update_tests.ml | 364 +++--- 77 files changed, 3845 insertions(+), 3544 deletions(-) diff --git a/controller/bindings/connman/connman.ml b/controller/bindings/connman/connman.ml index dd9ab260..79e1b4dd 100644 --- a/controller/bindings/connman/connman.ml +++ b/controller/bindings/connman/connman.ml @@ -7,33 +7,25 @@ open Protocol_conv_jsonm let log_src = Logs.Src.create "connman" module OBus_proxy = struct - include OBus_proxy - let to_jsonm _ = `String "@opaque" - let of_jsonm_exn _ = failwith "Deserialization is not supported" + include OBus_proxy + + let to_jsonm _ = `String "@opaque" + + let of_jsonm_exn _ = failwith "Deserialization is not supported" end let string_of_obus value = (* Helper to safely get string from OBus_value.V.single *) - try - Some OBus_value.C.(value |> cast_single basic_string) - with - _ -> None + try Some OBus_value.C.(value |> cast_single basic_string) with _ -> None let bool_of_obus value = (* Helper to safely get bool from OBus_value.V.single *) - try - Some OBus_value.C.(value |> cast_single basic_boolean) - with - _ -> None + try Some OBus_value.C.(value |> cast_single basic_boolean) with _ -> None let string_list_of_obus value = - try - OBus_value.C.(value |> cast_single (array basic_string)) - with - _ -> [] + try OBus_value.C.(value |> cast_single (array basic_string)) with _ -> [] -module Technology = -struct +module Technology = struct type type' = | Wifi | Ethernet @@ -42,50 +34,53 @@ struct [@@deriving sexp, protocol ~driver:(module Jsonm)] let type_of_string = function - | "wifi" -> Some Wifi - | "ethernet" -> Some Ethernet - | "bluetooth" -> Some Bluetooth - | "p2p" -> Some P2P - | _ -> None - - type t = { - _proxy: (OBus_proxy.t [@sexp.opaque]) - ; name : string - ; type' : type' - ; powered : bool - ; connected : bool - } [@@deriving sexp, protocol ~driver:(module Jsonm)] + | "wifi" -> + Some Wifi + | "ethernet" -> + Some Ethernet + | "bluetooth" -> + Some Bluetooth + | "p2p" -> + Some P2P + | _ -> + None + + type t = + { _proxy : (OBus_proxy.t[@sexp.opaque]) + ; name : string + ; type' : type' + ; powered : bool + ; connected : bool + } + [@@deriving sexp, protocol ~driver:(module Jsonm)] let set_property proxy ~name ~value = - OBus_method.call - Connman_interfaces.Net_connman_Technology.m_SetProperty proxy (name, value) + OBus_method.call Connman_interfaces.Net_connman_Technology.m_SetProperty + proxy (name, value) let enable t = - set_property t._proxy ~name:"Powered" ~value:(true |> OBus_value.C.(make_single basic_boolean)) + set_property t._proxy ~name:"Powered" + ~value:(true |> OBus_value.C.(make_single basic_boolean)) let disable t = - set_property t._proxy ~name:"Powered" ~value:(false |> OBus_value.C.(make_single basic_boolean)) + set_property t._proxy ~name:"Powered" + ~value:(false |> OBus_value.C.(make_single basic_boolean)) let scan t = - let%lwt () = Logs_lwt.debug ~src:log_src - (fun m -> m "scanning %s" t.name) + let%lwt () = + Logs_lwt.debug ~src:log_src (fun m -> m "scanning %s" t.name) in - OBus_method.call - Connman_interfaces.Net_connman_Technology.m_Scan t._proxy () - + OBus_method.call Connman_interfaces.Net_connman_Technology.m_Scan t._proxy + () end let register_agent proxy ~path = - OBus_method.call - Net_connman_Manager.m_RegisterAgent proxy path + OBus_method.call Net_connman_Manager.m_RegisterAgent proxy path let unregister_agent proxy ~path = - OBus_method.call - Net_connman_Manager.m_UnregisterAgent proxy path - -module Agent = -struct + OBus_method.call Net_connman_Manager.m_UnregisterAgent proxy path +module Agent = struct type input = | None | Passphrase of string @@ -96,79 +91,95 @@ struct (* The errors that are relevant and that the manager is known to actually produce. Defined but unused errors are not included. *) type manager_error = - | InvalidKey - | ConnectFailed - | Blocked - | Unknown of string + | InvalidKey + | ConnectFailed + | Blocked + | Unknown of string type agent_error = - | PassMissing - | MissingRequestedInputs of string list - | BrowserRequested - | UnexpectedFailure of exn + | PassMissing + | MissingRequestedInputs of string list + | BrowserRequested + | UnexpectedFailure of exn type reported_error = - | ManagerError of manager_error - | AgentError of agent_error - - let request_input input service (fields: (string * OBus_value.V.single) list) = - let%lwt () = Logs_lwt.debug ~src:log_src - (fun m -> m "input %s requested from agent for service %s" - (String.concat ", " @@ List.map (fun (k, v) -> - Printf.sprintf "%s: %s" k (OBus_value.V.string_of_single v) - ) fields) + | ManagerError of manager_error + | AgentError of agent_error + + let request_input input service (fields : (string * OBus_value.V.single) list) + = + let%lwt () = + Logs_lwt.debug ~src:log_src (fun m -> + m "input %s requested from agent for service %s" + (String.concat ", " + @@ List.map + (fun (k, v) -> + Printf.sprintf "%s: %s" k (OBus_value.V.string_of_single v) + ) + fields + ) (String.concat "/" service) - ) + ) in - let mandatory_inputs = List.concat_map (fun (k, v) -> - let v_ocaml = OBus_value.C.(cast_single (dict string variant) v) in - let requirement_opt = List.assoc_opt "Requirement" v_ocaml |> - Option.map (OBus_value.C.(cast_single basic_string)) in - match requirement_opt with - | Some "mandatory" -> [k] - | _ -> [] - ) fields + let mandatory_inputs = + List.concat_map + (fun (k, v) -> + let v_ocaml = OBus_value.C.(cast_single (dict string variant) v) in + let requirement_opt = + List.assoc_opt "Requirement" v_ocaml + |> Option.map OBus_value.C.(cast_single basic_string) + in + match requirement_opt with Some "mandatory" -> [ k ] | _ -> [] + ) + fields in match (input, mandatory_inputs) with - | (Passphrase p, [ "Passphrase" ]) -> - return @@ Ok [ "Passphrase", p |> OBus_value.C.(make_single basic_string)] - | (None, [ "Passphrase" ]) -> - let%lwt () = Logs_lwt.err ~src:log_src (fun m -> m - "Passphrase requested from agent, but not available.") - in - return @@ Error PassMissing - | (_, _) -> - (* This case is triggered when manager is requesting - _some_ input(s) (so NOT open networks) and those inputs - involve something additional to (or other than) a passphrase. - *) - let expected_properties_str = - String.concat ", " mandatory_inputs - in - let%lwt () = Logs_lwt.err ~src:log_src (fun m -> m - "Manager is requesting additional missing input(s): %s" - expected_properties_str - ) - in - return @@ Error (MissingRequestedInputs mandatory_inputs) + | Passphrase p, [ "Passphrase" ] -> + return + @@ Ok [ ("Passphrase", p |> OBus_value.C.(make_single basic_string)) ] + | None, [ "Passphrase" ] -> + let%lwt () = + Logs_lwt.err ~src:log_src (fun m -> + m "Passphrase requested from agent, but not available." + ) + in + return @@ Error PassMissing + | _, _ -> + (* This case is triggered when manager is requesting + _some_ input(s) (so NOT open networks) and those inputs + involve something additional to (or other than) a passphrase. + *) + let expected_properties_str = String.concat ", " mandatory_inputs in + let%lwt () = + Logs_lwt.err ~src:log_src (fun m -> + m "Manager is requesting additional missing input(s): %s" + expected_properties_str + ) + in + return @@ Error (MissingRequestedInputs mandatory_inputs) let request_browser input service url = - let%lwt () = Logs_lwt.err ~src:log_src - (fun m -> m "agent requested to open browser to url: %s" url) + let%lwt () = + Logs_lwt.err ~src:log_src (fun m -> + m "agent requested to open browser to url: %s" url + ) in return @@ Error BrowserRequested (* based on `connman_service_error` enum and it's stringified mapping in - error2string: https://git.kernel.org/pub/scm/network/connman/connman.git/tree/src/service.c?h=1.42#n324 *) + error2string: https://git.kernel.org/pub/scm/network/connman/connman.git/tree/src/service.c?h=1.42#n324 *) let manager_error_of_string = function - | "invalid-key" -> InvalidKey - | "connect-failed" -> ConnectFailed + | "invalid-key" -> + InvalidKey + | "connect-failed" -> + ConnectFailed (* although this sounds generic, `blocked` err is only produced by connman when wpa_supplicant reports a wifi deauth with reason code = 6, which is "Class 2 frame received from nonauthenticated station". This seems like a protocol error? *) - | "blocked" -> Blocked -(* + | "blocked" -> + Blocked + (* (* defined, but never produced in connman v1.42 *) | "dhcp-failed" -> DhcpFailed | "out-of-range" -> OutOfRange @@ -178,74 +189,76 @@ struct | "login-failed" -> LoginFailed | "auth-failed" -> AuthFailed *) - | s -> Unknown s + | s -> + Unknown s let agent_error_msg = function - | PassMissing -> - "Password is required for this access point" - | MissingRequestedInputs props -> - Printf.sprintf - "Unsupported protocol: additional inputs are needed: %s" - (String.concat ", " props) - | BrowserRequested -> - "Unsupported protocol: access point requires browser-based authentication" - | UnexpectedFailure exn -> - Printf.sprintf "Unexpected connection failure: %s" (Printexc.to_string exn) + | PassMissing -> + "Password is required for this access point" + | MissingRequestedInputs props -> + Printf.sprintf "Unsupported protocol: additional inputs are needed: %s" + (String.concat ", " props) + | BrowserRequested -> + "Unsupported protocol: access point requires browser-based \ + authentication" + | UnexpectedFailure exn -> + Printf.sprintf "Unexpected connection failure: %s" + (Printexc.to_string exn) let interface on_error = - let wrap_req f = fun obj (x1, x2) -> - let%lwt caught_f = Lwt_result.catch - (fun () -> f (OBus_object.get obj) x1 x2) |> - (Lwt_result.map_error (fun e -> UnexpectedFailure e)) - in - match (Result.join caught_f) with - | Ok a -> Lwt.return a - | Error err -> - let%lwt () = on_error (AgentError err) in - let obus_exn = OBus_error.make - "net.connman.Agent.Error.Canceled" - (agent_error_msg err) - in - Lwt.fail obus_exn - in - Connman_interfaces.Net_connman_Agent.make { - m_ReportError = ( - fun obj (service, msg) -> - let%lwt () = Logs_lwt.err ~src:log_src - (fun m -> m "error reported to agent: %s" msg) + let wrap_req f obj (x1, x2) = + let%lwt caught_f = + Lwt_result.catch (fun () -> f (OBus_object.get obj) x1 x2) + |> Lwt_result.map_error (fun e -> UnexpectedFailure e) + in + match Result.join caught_f with + | Ok a -> + Lwt.return a + | Error err -> + let%lwt () = on_error (AgentError err) in + let obus_exn = + OBus_error.make "net.connman.Agent.Error.Canceled" + (agent_error_msg err) in - on_error (ManagerError (manager_error_of_string msg)) - ); - m_RequestInput = wrap_req request_input; - m_RequestBrowser = wrap_req request_browser; - m_Cancel = (fun obj () -> return_unit); - m_Release = (fun obj () -> return_unit); - } + Lwt.fail obus_exn + in + Connman_interfaces.Net_connman_Agent.make + { m_ReportError = + (fun obj (service, msg) -> + let%lwt () = + Logs_lwt.err ~src:log_src (fun m -> + m "error reported to agent: %s" msg + ) + in + on_error (ManagerError (manager_error_of_string msg)) + ) + ; m_RequestInput = wrap_req request_input + ; m_RequestBrowser = wrap_req request_browser + ; m_Cancel = (fun obj () -> return_unit) + ; m_Release = (fun obj () -> return_unit) + } - let create ~(input:input) on_error = + let create ~(input : input) on_error = let%lwt system_bus = OBus_bus.system () in - let path = [ "net"; "connman"; "agent" - ; Random.int 9999 |> string_of_int ] + let path = + [ "net"; "connman"; "agent"; Random.int 9999 |> string_of_int ] in - let%lwt () = Logs_lwt.debug ~src:log_src - (fun m -> m "creating connman agent at %s" (String.concat "/" path)) + let%lwt () = + Logs_lwt.debug ~src:log_src (fun m -> + m "creating connman agent at %s" (String.concat "/" path) + ) in - let obj = OBus_object.make ~interfaces:[interface on_error] path in + let obj = OBus_object.make ~interfaces:[ interface on_error ] path in let () = OBus_object.attach obj input in let () = OBus_object.export system_bus obj in return (path, obj) - let destroy (agent:t) = - let%lwt () = Logs_lwt.debug ~src:log_src - (fun m -> m "detroying agent") - in - OBus_object.destroy agent - |> return - + let destroy (agent : t) = + let%lwt () = Logs_lwt.debug ~src:log_src (fun m -> m "detroying agent") in + OBus_object.destroy agent |> return end -module Service = -struct +module Service = struct type state = | Idle | Failure @@ -264,272 +277,347 @@ struct | WPS [@@deriving sexp, protocol ~driver:(module Jsonm)] - let supported_security_protocols = [ None; WEP; PSK; ] + let supported_security_protocols = [ None; WEP; PSK ] let string_of_security s = sexp_of_security s |> Sexplib.Sexp.to_string - module IPv4 = - struct - type t = { - method' : string - ; address : string - ; netmask : string - ; gateway : string option - } + module IPv4 = struct + type t = + { method' : string + ; address : string + ; netmask : string + ; gateway : string option + } [@@deriving sexp, protocol ~driver:(module Jsonm)] let of_obus v = (fun () -> - let open OBus_value.C in - let properties = v |> cast_single (dict string variant) in - { method' = properties |> List.assoc "Method" |> cast_single basic_string - ; address = properties |> List.assoc "Address" |> cast_single basic_string - ; netmask = properties |> List.assoc "Netmask" |> cast_single basic_string - ; gateway = properties |> List.assoc_opt "Gateway" |> Option.map (cast_single basic_string) - } + let open OBus_value.C in + let properties = v |> cast_single (dict string variant) in + { method' = + properties |> List.assoc "Method" |> cast_single basic_string + ; address = + properties |> List.assoc "Address" |> cast_single basic_string + ; netmask = + properties |> List.assoc "Netmask" |> cast_single basic_string + ; gateway = + properties + |> List.assoc_opt "Gateway" + |> Option.map (cast_single basic_string) + } ) |> CCResult.guard |> CCResult.to_opt end - module IPv6 = - struct - type t = { - method' : string - ; address : string - ; prefix_length: int - ; gateway : string option - ; privacy : string - } + module IPv6 = struct + type t = + { method' : string + ; address : string + ; prefix_length : int + ; gateway : string option + ; privacy : string + } [@@deriving sexp, protocol ~driver:(module Jsonm)] let of_obus v = (fun () -> - let open OBus_value.C in - let properties = v |> cast_single (dict string variant) in - { method' = properties |> List.assoc "Method" |> cast_single basic_string - ; address = properties |> List.assoc "Address" |> cast_single basic_string - ; prefix_length = properties - |> List.assoc "PrefixLength" - |> cast_single basic_byte - |> int_of_char - ; gateway = properties |> List.assoc_opt "Gateway" |> Option.map (cast_single basic_string) - ; privacy = properties |> List.assoc "Privacy" |> cast_single basic_string - } + let open OBus_value.C in + let properties = v |> cast_single (dict string variant) in + { method' = + properties |> List.assoc "Method" |> cast_single basic_string + ; address = + properties |> List.assoc "Address" |> cast_single basic_string + ; prefix_length = + properties + |> List.assoc "PrefixLength" + |> cast_single basic_byte + |> int_of_char + ; gateway = + properties + |> List.assoc_opt "Gateway" + |> Option.map (cast_single basic_string) + ; privacy = + properties |> List.assoc "Privacy" |> cast_single basic_string + } ) |> CCResult.guard |> CCResult.to_opt end - module Ethernet = - struct - type t = { - method' : string - ; interface : string - ; address : string - ; mtu : int - } + module Ethernet = struct + type t = + { method' : string + ; interface : string + ; address : string + ; mtu : int + } [@@deriving sexp, protocol ~driver:(module Jsonm)] let of_obus v = (fun () -> - let open OBus_value.C in - let properties = v |> cast_single (dict string variant) in - { method' = properties |> List.assoc "Method" |> cast_single basic_string - ; interface = properties |> List.assoc "Interface" |> cast_single basic_string - ; address = properties |> List.assoc "Address" |> cast_single basic_string - ; mtu = properties |> List.assoc "MTU" |> cast_single basic_uint16 - } + let open OBus_value.C in + let properties = v |> cast_single (dict string variant) in + { method' = + properties |> List.assoc "Method" |> cast_single basic_string + ; interface = + properties |> List.assoc "Interface" |> cast_single basic_string + ; address = + properties |> List.assoc "Address" |> cast_single basic_string + ; mtu = properties |> List.assoc "MTU" |> cast_single basic_uint16 + } ) |> CCResult.guard |> CCResult.to_opt end - module Proxy = - struct + module Proxy = struct type credentials = - { user: string - ; password: (string [@sexp.opaque]) + { user : string + ; password : (string[@sexp.opaque]) } - [@@deriving sexp, protocol ~driver:(module Jsonm)] + [@@deriving sexp, protocol ~driver:(module Jsonm)] type t = - { host: string - ; port: int - ; credentials: credentials option - } + { host : string + ; port : int + ; credentials : credentials option + } [@@deriving sexp, protocol ~driver:(module Jsonm)] let make ?user ?password host port = - { host = host - ; port = port + { host + ; port ; credentials = - (match user, password with - | Some "", _ -> None - | Some u, Some p -> Some { user = u; password = p } - | _ -> None) + ( match (user, password) with + | Some "", _ -> + None + | Some u, Some p -> + Some { user = u; password = p } + | _ -> + None + ) } let validate str = let uri = Uri.of_string str in - if Uri.path uri = "" - && Uri.query uri = [] - && Uri.fragment uri = None - then - match Uri.scheme uri, Uri.host uri, Uri.port uri with + if Uri.path uri = "" && Uri.query uri = [] && Uri.fragment uri = None then + match (Uri.scheme uri, Uri.host uri, Uri.port uri) with | Some "http", Some host, Some port -> - Some - { credentials = - (match Uri.user uri, Uri.password uri with - | Some user, Some password -> Some { user = Uri.pct_decode user; password = Uri.pct_decode password } - | _ -> None) - ; host - ; port - } - | _ -> None - else - None + Some + { credentials = + ( match (Uri.user uri, Uri.password uri) with + | Some user, Some password -> + Some + { user = Uri.pct_decode user + ; password = Uri.pct_decode password + } + | _ -> + None + ) + ; host + ; port + } + | _ -> + None + else None let to_uri ~include_userinfo t = let escape_userinfo = Uri.pct_encode ~component:`Userinfo in - let - userinfo = - Option.map - (fun credentials -> escape_userinfo credentials.user ^ ":" ^ escape_userinfo credentials.password) - t.credentials + let userinfo = + Option.map + (fun credentials -> + escape_userinfo credentials.user + ^ ":" + ^ escape_userinfo credentials.password + ) + t.credentials in Uri.empty |> Fun.flip Uri.with_scheme (Some "http") |> Fun.flip Uri.with_host (Some t.host) |> Fun.flip Uri.with_port (Some t.port) - |> (fun uri -> if include_userinfo then Uri.with_userinfo uri userinfo else uri) - + |> fun uri -> + if include_userinfo then Uri.with_userinfo uri userinfo else uri end - type t = { - _proxy : (OBus_proxy.t [@sexp.opaque]) - ; _manager : (OBus_proxy.t [@sexp.opaque]) - ; id : string - ; name : string - ; type' : Technology.type' - ; security: security list - ; state : state - ; strength : int option - ; favorite : bool - ; autoconnect : bool - ; ipv4 : IPv4.t option - ; ipv6 : IPv6.t option - ; ethernet : Ethernet.t - ; proxy : Proxy.t option - ; nameservers : string list - } + type t = + { _proxy : (OBus_proxy.t[@sexp.opaque]) + ; _manager : (OBus_proxy.t[@sexp.opaque]) + ; id : string + ; name : string + ; type' : Technology.type' + ; security : security list + ; state : state + ; strength : int option + ; favorite : bool + ; autoconnect : bool + ; ipv4 : IPv4.t option + ; ipv6 : IPv6.t option + ; ethernet : Ethernet.t + ; proxy : Proxy.t option + ; nameservers : string list + } [@@deriving sexp, protocol ~driver:(module Jsonm)] (* Helper to parse a service from OBus *) - let of_obus manager context (path, properties) = + let of_obus manager context (path, properties) = let state_of_string = function - | "idle" -> Some Idle - | "failure" -> Some Failure - | "association" -> Some Association - | "configuration" -> Some Configuration - | "ready" -> Some Ready - | "disconnect" -> Some Disconnect - | "online" -> Some Online - | _ -> None + | "idle" -> + Some Idle + | "failure" -> + Some Failure + | "association" -> + Some Association + | "configuration" -> + Some Configuration + | "ready" -> + Some Ready + | "disconnect" -> + Some Disconnect + | "online" -> + Some Online + | _ -> + None in let security_of_string = function - | "none" -> Some None - | "psk" -> Some PSK - | "wps" -> Some WPS - | "ieee8021x" -> Some IEEE8021x - | _ -> None + | "none" -> + Some None + | "psk" -> + Some PSK + | "wps" -> + Some WPS + | "ieee8021x" -> + Some IEEE8021x + | _ -> + None in let security_of_obus v = - let str_list = string_list_of_obus v in - List.filter_map security_of_string str_list + let str_list = string_list_of_obus v in + List.filter_map security_of_string str_list in let strength_of_obus v = try OBus_value.C.(v |> cast_single basic_byte) |> int_of_char |> CCOption.return - with - | _ -> None + with _ -> None in let proxy_of_obus v = try - let open OBus_value.C in - let properties = v |> cast_single (dict string variant) in - let proxy_method = properties |> List.assoc "Method" |> cast_single basic_string in - if proxy_method = "manual" then - properties - |> List.assoc "Servers" - |> cast_single (array basic_string) - |> List.hd - |> Proxy.validate - else - None - with - _ -> None + let open OBus_value.C in + let properties = v |> cast_single (dict string variant) in + let proxy_method = + properties |> List.assoc "Method" |> cast_single basic_string + in + if proxy_method = "manual" then + properties + |> List.assoc "Servers" + |> cast_single (array basic_string) + |> List.hd + |> Proxy.validate + else None + with _ -> None in CCOption.( - pure (fun name type' state strength favorite autoconnect ipv4 ipv4_user_config ipv6 ethernet proxy nameservers security -> - { _proxy = OBus_proxy.make ~peer:(OBus_context.sender context) ~path:path + pure + (fun + name + type' + state + strength + favorite + autoconnect + ipv4 + ipv4_user_config + ipv6 + ethernet + proxy + nameservers + security + -> + { _proxy = OBus_proxy.make ~peer:(OBus_context.sender context) ~path ; _manager = manager ; id = path |> CCList.last 1 |> CCList.hd - ; name ; type'; state; strength; favorite; autoconnect - ; ipv4 = (if Option.is_some ipv4_user_config then ipv4_user_config else ipv4) - ; ipv6; ethernet; proxy; nameservers; security - }) + ; name + ; type' + ; state + ; strength + ; favorite + ; autoconnect + ; ipv4 = + ( if Option.is_some ipv4_user_config then ipv4_user_config + else ipv4 + ) + ; ipv6 + ; ethernet + ; proxy + ; nameservers + ; security + } + ) <*> (properties |> List.assoc_opt "Name" >>= string_of_obus) - <*> (properties |> List.assoc_opt "Type" >>= string_of_obus >>= Technology.type_of_string) - <*> (properties |> List.assoc_opt "State" >>= string_of_obus >>= state_of_string) + <*> (properties + |> List.assoc_opt "Type" + >>= string_of_obus + >>= Technology.type_of_string + ) + <*> (properties + |> List.assoc_opt "State" + >>= string_of_obus + >>= state_of_string + ) <*> (properties |> List.assoc_opt "Strength" >>= strength_of_obus |> pure) <*> (properties |> List.assoc_opt "Favorite" >>= bool_of_obus) <*> (properties |> List.assoc_opt "AutoConnect" >>= bool_of_obus) <*> (properties |> List.assoc_opt "IPv4" >>= IPv4.of_obus |> pure) - <*> (properties |> List.assoc_opt "IPv4.Configuration" >>= IPv4.of_obus |> pure) + <*> (properties + |> List.assoc_opt "IPv4.Configuration" + >>= IPv4.of_obus + |> pure + ) <*> (properties |> List.assoc_opt "IPv6" >>= IPv6.of_obus |> pure) <*> (properties |> List.assoc_opt "Ethernet" >>= Ethernet.of_obus) <*> (properties |> List.assoc_opt "Proxy" >>= proxy_of_obus |> pure) - <*> (properties |> List.assoc_opt "Nameservers.Configuration" >|= string_list_of_obus) - <*> (properties |> List.assoc_opt "Security" >|= security_of_obus)) + <*> (properties + |> List.assoc_opt "Nameservers.Configuration" + >|= string_list_of_obus + ) + <*> (properties |> List.assoc_opt "Security" >|= security_of_obus) + ) let is_connected t = - match t.state with - | Ready -> true - | Online -> true - | _ -> false + match t.state with Ready -> true | Online -> true | _ -> false let set_property service ~name ~value = - OBus_method.call - Connman_interfaces.Net_connman_Service.m_SetProperty + OBus_method.call Connman_interfaces.Net_connman_Service.m_SetProperty service._proxy (name, value) let set_direct_proxy service = let dict = OBus_value.C.make_single - (OBus_value.C.(dict string variant)) - [ ("Method", OBus_value.C.(make_single basic_string) "direct") - ] + OBus_value.C.(dict string variant) + [ ("Method", OBus_value.C.(make_single basic_string) "direct") ] in set_property service ~name:"Proxy.Configuration" ~value:dict let set_manual_proxy service proxy = let dict = OBus_value.C.make_single - (OBus_value.C.(dict string variant)) + OBus_value.C.(dict string variant) [ ("Method", OBus_value.C.(make_single basic_string) "manual") - ; ("Servers", OBus_value.C.(make_single (array basic_string)) [Proxy.to_uri ~include_userinfo:true proxy |> Uri.to_string]) + ; ( "Servers" + , OBus_value.C.(make_single (array basic_string)) + [ Proxy.to_uri ~include_userinfo:true proxy |> Uri.to_string ] + ) ] in set_property service ~name:"Proxy.Configuration" ~value:dict - let set_manual_ipv4 service ~address ~netmask ~gateway = let dict = OBus_value.C.make_single - (OBus_value.C.(dict string variant)) + OBus_value.C.(dict string variant) [ ("Method", OBus_value.C.(make_single basic_string) "manual") ; ("Address", OBus_value.C.(make_single basic_string) address) ; ("Netmask", OBus_value.C.(make_single basic_string) netmask) @@ -541,164 +629,170 @@ struct let set_dhcp_ipv4 service = let dict = OBus_value.C.make_single - (OBus_value.C.(dict string variant)) - [("Method", OBus_value.C.(make_single basic_string) "dhcp")] + OBus_value.C.(dict string variant) + [ ("Method", OBus_value.C.(make_single basic_string) "dhcp") ] in set_property service ~name:"IPv4.Configuration" ~value:dict let set_nameservers service nameservers = let config = - OBus_value.C.make_single - (OBus_value.C.(array basic_string)) nameservers + OBus_value.C.make_single OBus_value.C.(array basic_string) nameservers in set_property service ~name:"Nameservers.Configuration" ~value:config - - - let connect ?(input=Agent.None) service = - let is_supported = List.exists + let connect ?(input = Agent.None) service = + let is_supported = + List.exists (fun s -> List.mem s supported_security_protocols) service.security in - let%lwt () = Logs_lwt.debug ~src:log_src - (fun m -> m "connect to service %s" service.id) + let%lwt () = + Logs_lwt.debug ~src:log_src (fun m -> m "connect to service %s" service.id) in - (* Store agent error in a local mutable variable *) let agent_reported_error = ref Option.None in let on_agent_error msg = Lwt.return (agent_reported_error := Some msg) in - (* Create and register an agent that will pass input to ConnMan *) let%lwt agent_path, agent = Agent.create ~input on_agent_error in let%lwt () = register_agent service._manager ~path:agent_path in - let destroy_agent () = (* Cleanup and destroy agent *) let%lwt () = unregister_agent service._manager ~path:agent_path in Agent.destroy agent in - - let%lwt obus_resp = Lwt_result.catch (OBus_method.call - Connman_interfaces.Net_connman_Service.m_Connect - service._proxy) + let%lwt obus_resp = + Lwt_result.catch + (OBus_method.call Connman_interfaces.Net_connman_Service.m_Connect + service._proxy + ) in let%lwt _ = Lwt_result.catch destroy_agent in match (obus_resp, !agent_reported_error) with - | (Ok _, _) -> - Lwt.return () - | (Error _, Some (ManagerError InvalidKey)) -> - Lwt.fail_with "Password is not valid or client is blocked. Please check the password and then try to connect again." - | (Error _, Some (ManagerError ConnectFailed)) -> - Lwt.fail_with "Connection failed for unknown reasons. Please check wireless signal strength and network settings." - | (Error _, Some (ManagerError Blocked)) -> - Lwt.fail_with "Connection failed, deauthenticated by access point." - | (Error exn, Some (ManagerError (Unknown err))) -> - Lwt.fail_with (Printf.sprintf - "Connection failed, unknown error reported by manager: %s - DBus connect exception: %s" err (Printexc.to_string exn) - ) - | (Error exn, Some (AgentError err)) -> - Lwt.fail_with (Printf.sprintf - "Connection failed. %s - DBus connect exception: %s" - (Agent.agent_error_msg err) (Printexc.to_string exn) - ) - | (Error exn, None) when not is_supported -> - Lwt.fail_with (Printf.sprintf - "Connection failed, none of the available authentication protocols are supported. - Available protocols: %s - Supported protocols: %s - " - (String.concat ", " @@ - List.map string_of_security service.security) - (String.concat ", " @@ - List.map string_of_security supported_security_protocols) - ) - | (Error exn, None) when - OBus_error.name exn = "net.connman.Error.InvalidArguments" -> - Lwt.fail_with (Printf.sprintf - "Connection failed due to invalid arguments provided, the authentication protocol used by the access point is most likely unsupported" - ) - | (Error exn, None) -> - Lwt.fail_with (Printf.sprintf - "Connection to network failed. - DBus connect exception: %s" - (Printexc.to_string exn) - ) + | Ok _, _ -> + Lwt.return () + | Error _, Some (ManagerError InvalidKey) -> + Lwt.fail_with + "Password is not valid or client is blocked. Please check the \ + password and then try to connect again." + | Error _, Some (ManagerError ConnectFailed) -> + Lwt.fail_with + "Connection failed for unknown reasons. Please check wireless signal \ + strength and network settings." + | Error _, Some (ManagerError Blocked) -> + Lwt.fail_with "Connection failed, deauthenticated by access point." + | Error exn, Some (ManagerError (Unknown err)) -> + Lwt.fail_with + (Printf.sprintf + "Connection failed, unknown error reported by manager: %s\n\ + \ DBus connect exception: %s" err + (Printexc.to_string exn) + ) + | Error exn, Some (AgentError err) -> + Lwt.fail_with + (Printf.sprintf + "Connection failed. %s\n\ + \ DBus connect exception: %s" + (Agent.agent_error_msg err) + (Printexc.to_string exn) + ) + | Error exn, None when not is_supported -> + Lwt.fail_with + (Printf.sprintf + "Connection failed, none of the available authentication \ + protocols are supported.\n\ + \ Available protocols: %s\n\ + \ Supported protocols: %s\n\ + \ " + (String.concat ", " @@ List.map string_of_security service.security) + (String.concat ", " + @@ List.map string_of_security supported_security_protocols + ) + ) + | Error exn, None + when OBus_error.name exn = "net.connman.Error.InvalidArguments" -> + Lwt.fail_with + (Printf.sprintf + "Connection failed due to invalid arguments provided, the \ + authentication protocol used by the access point is most likely \ + unsupported" + ) + | Error exn, None -> + Lwt.fail_with + (Printf.sprintf + "Connection to network failed.\n\ + \ DBus connect exception: %s" + (Printexc.to_string exn) + ) let disconnect service = - let%lwt () = Logs_lwt.debug ~src:log_src - (fun m -> m "disconnect from service %s" service.id) + let%lwt () = + Logs_lwt.debug ~src:log_src (fun m -> + m "disconnect from service %s" service.id + ) in - OBus_method.call - Connman_interfaces.Net_connman_Service.m_Disconnect + OBus_method.call Connman_interfaces.Net_connman_Service.m_Disconnect service._proxy () let remove service = - let%lwt () = Logs_lwt.debug ~src:log_src - (fun m -> m "remove service %s" service.id) + let%lwt () = + Logs_lwt.debug ~src:log_src (fun m -> m "remove service %s" service.id) in - OBus_method.call - Connman_interfaces.Net_connman_Service.m_Remove + OBus_method.call Connman_interfaces.Net_connman_Service.m_Remove service._proxy () - end -module Manager = -struct +module Manager = struct type t = OBus_proxy.t let connect () = let%lwt system_bus = OBus_bus.system () in let peer = OBus_peer.make ~connection:system_bus ~name:"net.connman" in - OBus_proxy.make ~peer ~path:[] - |> return + OBus_proxy.make ~peer ~path:[] |> return let get_technologies proxy = - let%lwt (context, technologies) = - OBus_method.call_with_context - Net_connman_Manager.m_GetTechnologies proxy () in + let%lwt context, technologies = + OBus_method.call_with_context Net_connman_Manager.m_GetTechnologies proxy + () + in let to_technology (path, properties) : Technology.t option = - CCOption.(pure - (fun name type' powered connected : Technology.t -> - { _proxy = OBus_proxy.make ~peer:(OBus_context.sender context) ~path:path - ; name - ; type' - ; powered - ; connected - }) - <*> (properties |> List.assoc_opt "Name" >>= string_of_obus) - <*> (properties - |> List.assoc_opt "Type" - >>= string_of_obus - >>= Technology.type_of_string) - <*> (properties |> List.assoc_opt "Powered" >>= bool_of_obus) - <*> (properties |> List.assoc_opt "Connected" >>= bool_of_obus) + CCOption.( + pure (fun name type' powered connected : Technology.t -> + { _proxy = OBus_proxy.make ~peer:(OBus_context.sender context) ~path + ; name + ; type' + ; powered + ; connected + } + ) + <*> (properties |> List.assoc_opt "Name" >>= string_of_obus) + <*> (properties + |> List.assoc_opt "Type" + >>= string_of_obus + >>= Technology.type_of_string ) + <*> (properties |> List.assoc_opt "Powered" >>= bool_of_obus) + <*> (properties |> List.assoc_opt "Connected" >>= bool_of_obus) + ) in - technologies - |> CCList.filter_map to_technology - |> return + technologies |> CCList.filter_map to_technology |> return let get_services manager = - let%lwt (context, services) = - OBus_method.call_with_context - Net_connman_Manager.m_GetServices manager () + let%lwt context, services = + OBus_method.call_with_context Net_connman_Manager.m_GetServices manager () in - services - |> CCList.filter_map (Service.of_obus manager context) - |> return + services |> CCList.filter_map (Service.of_obus manager context) |> return let get_services_signal manager = let%lwt initial_services = get_services manager in let%lwt service_changes = OBus_signal.map ignore - (OBus_signal.make - Net_connman_Manager.s_ServicesChanged manager) + (OBus_signal.make Net_connman_Manager.s_ServicesChanged manager) |> OBus_signal.connect >|= Lwt_react.E.map_s (fun () -> get_services manager) in - Lwt_react.S.accum (service_changes |> Lwt_react.E.map (fun x _ -> x)) initial_services + Lwt_react.S.accum + (service_changes |> Lwt_react.E.map (fun x _ -> x)) + initial_services |> return (* Extract the proxy from the default route. @@ -711,49 +805,65 @@ struct List.find_opt (fun s -> s.state = Online || s.state = Ready) services |> Fun.flip Option.bind (fun s -> s.proxy) |> return - end (* Auto generated with obus-gen-client *) -module Net_connman_Clock = -struct +module Net_connman_Clock = struct open Net_connman_Clock - - let get_properties proxy = - OBus_method.call m_GetProperties proxy () + let get_properties proxy = OBus_method.call m_GetProperties proxy () let set_property proxy ~name ~value = OBus_method.call m_SetProperty proxy (name, value) - let property_changed proxy = - OBus_signal.make s_PropertyChanged proxy + let property_changed proxy = OBus_signal.make s_PropertyChanged proxy end -module Net_connman_Manager = -struct +module Net_connman_Manager = struct open Net_connman_Manager - - let get_properties proxy = - OBus_method.call m_GetProperties proxy () + let get_properties proxy = OBus_method.call m_GetProperties proxy () let set_property proxy ~name ~value = OBus_method.call m_SetProperty proxy (name, value) let get_technologies proxy = - let%lwt (context, technologies) = OBus_method.call_with_context m_GetTechnologies proxy () in - let technologies = List.map (fun (x1, x2) -> (OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x1, x2)) technologies in + let%lwt context, technologies = + OBus_method.call_with_context m_GetTechnologies proxy () + in + let technologies = + List.map + (fun (x1, x2) -> + (OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x1, x2) + ) + technologies + in return technologies let get_services proxy = - let%lwt (context, services) = OBus_method.call_with_context m_GetServices proxy () in - let services = List.map (fun (x1, x2) -> (OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x1, x2)) services in + let%lwt context, services = + OBus_method.call_with_context m_GetServices proxy () + in + let services = + List.map + (fun (x1, x2) -> + (OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x1, x2) + ) + services + in return services let get_peers proxy = - let%lwt (context, peers) = OBus_method.call_with_context m_GetPeers proxy () in - let peers = List.map (fun (x1, x2) -> (OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x1, x2)) peers in + let%lwt context, peers = + OBus_method.call_with_context m_GetPeers proxy () + in + let peers = + List.map + (fun (x1, x2) -> + (OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x1, x2) + ) + peers + in return peers let register_agent proxy ~path = @@ -776,8 +886,12 @@ struct let create_session proxy ~settings ~notifier = let notifier = OBus_proxy.path notifier in - let%lwt (context, session) = OBus_method.call_with_context m_CreateSession proxy (settings, notifier) in - let session = OBus_proxy.make ~peer:(OBus_context.sender context) ~path:session in + let%lwt context, session = + OBus_method.call_with_context m_CreateSession proxy (settings, notifier) + in + let session = + OBus_proxy.make ~peer:(OBus_context.sender context) ~path:session + in return session let destroy_session proxy ~session = @@ -785,8 +899,10 @@ struct OBus_method.call m_DestroySession proxy session let request_private_network proxy = - let%lwt (context, (path, settings, socket)) = OBus_method.call_with_context m_RequestPrivateNetwork proxy () in - let path = OBus_proxy.make ~peer:(OBus_context.sender context) ~path:path in + let%lwt context, (path, settings, socket) = + OBus_method.call_with_context m_RequestPrivateNetwork proxy () + in + let path = OBus_proxy.make ~peer:(OBus_context.sender context) ~path in return (path, settings, socket) let release_private_network proxy ~path = @@ -799,59 +915,80 @@ struct let unregister_peer_service proxy ~specification = OBus_method.call m_UnregisterPeerService proxy specification - let property_changed proxy = - OBus_signal.make s_PropertyChanged proxy + let property_changed proxy = OBus_signal.make s_PropertyChanged proxy let technology_added proxy = OBus_signal.map_with_context (fun context (path, properties) -> - let path = OBus_proxy.make ~peer:(OBus_context.sender context) ~path:path in - (path, properties)) + let path = OBus_proxy.make ~peer:(OBus_context.sender context) ~path in + (path, properties) + ) (OBus_signal.make s_TechnologyAdded proxy) let technology_removed proxy = OBus_signal.map_with_context (fun context path -> - let path = OBus_proxy.make ~peer:(OBus_context.sender context) ~path:path in - path) + let path = OBus_proxy.make ~peer:(OBus_context.sender context) ~path in + path + ) (OBus_signal.make s_TechnologyRemoved proxy) let services_changed proxy = OBus_signal.map_with_context (fun context (changed, removed) -> - let changed = List.map (fun (x1, x2) -> (OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x1, x2)) changed in - let removed = List.map (fun path -> OBus_proxy.make ~peer:(OBus_context.sender context) ~path) removed in - (changed, removed)) + let changed = + List.map + (fun (x1, x2) -> + (OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x1, x2) + ) + changed + in + let removed = + List.map + (fun path -> + OBus_proxy.make ~peer:(OBus_context.sender context) ~path + ) + removed + in + (changed, removed) + ) (OBus_signal.make s_ServicesChanged proxy) let peers_changed proxy = OBus_signal.map_with_context (fun context (changed, removed) -> - let changed = List.map (fun (x1, x2) -> (OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x1, x2)) changed in - let removed = List.map (fun path -> OBus_proxy.make ~peer:(OBus_context.sender context) ~path) removed in - (changed, removed)) + let changed = + List.map + (fun (x1, x2) -> + (OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x1, x2) + ) + changed + in + let removed = + List.map + (fun path -> + OBus_proxy.make ~peer:(OBus_context.sender context) ~path + ) + removed + in + (changed, removed) + ) (OBus_signal.make s_PeersChanged proxy) end -module Net_connman_Service = -struct +module Net_connman_Service = struct open Net_connman_Service - let set_property proxy ~name ~value = OBus_method.call m_SetProperty proxy (name, value) - let clear_property proxy ~name = - OBus_method.call m_ClearProperty proxy name + let clear_property proxy ~name = OBus_method.call m_ClearProperty proxy name - let connect proxy = - OBus_method.call m_Connect proxy () + let connect proxy = OBus_method.call m_Connect proxy () - let disconnect proxy = - OBus_method.call m_Disconnect proxy () + let disconnect proxy = OBus_method.call m_Disconnect proxy () - let remove proxy = - OBus_method.call m_Remove proxy () + let remove proxy = OBus_method.call m_Remove proxy () let move_before proxy ~service = let service = OBus_proxy.path service in @@ -861,24 +998,18 @@ struct let service = OBus_proxy.path service in OBus_method.call m_MoveAfter proxy service - let reset_counters proxy = - OBus_method.call m_ResetCounters proxy () + let reset_counters proxy = OBus_method.call m_ResetCounters proxy () - let property_changed proxy = - OBus_signal.make s_PropertyChanged proxy + let property_changed proxy = OBus_signal.make s_PropertyChanged proxy end -module Net_connman_Technology = -struct +module Net_connman_Technology = struct open Net_connman_Technology - let set_property proxy ~name ~value = OBus_method.call m_SetProperty proxy (name, value) - let scan proxy = - OBus_method.call m_Scan proxy () + let scan proxy = OBus_method.call m_Scan proxy () - let property_changed proxy = - OBus_signal.make s_PropertyChanged proxy + let property_changed proxy = OBus_signal.make s_PropertyChanged proxy end diff --git a/controller/bindings/connman/connman.mli b/controller/bindings/connman/connman.mli index 0c252571..e81ec51f 100644 --- a/controller/bindings/connman/connman.mli +++ b/controller/bindings/connman/connman.mli @@ -2,7 +2,6 @@ open Protocol_conv_jsonm (** ConnMan Technology API *) module Technology : sig - (** Type of technology. *) type type' = | Wifi @@ -15,13 +14,14 @@ module Technology : sig Note that not all properties are encoded. *) - type t = { - _proxy: (OBus_proxy.t [@sexp.opaque]) - ; name : string - ; type' : type' - ; powered : bool - ; connected : bool - } [@@deriving sexp, protocol ~driver:(module Jsonm)] + type t = + { _proxy : (OBus_proxy.t[@sexp.opaque]) + ; name : string + ; type' : type' + ; powered : bool + ; connected : bool + } + [@@deriving sexp, protocol ~driver:(module Jsonm)] (** Enable a technology *) val enable : t -> unit Lwt.t @@ -38,21 +38,20 @@ end A D-Bus ConnMan agent is implemented by this module to provide inputs for secured networks. The agent is not started manually, but is automatically created by the [Service.connect] function. *) module Agent : sig - (** Input that the agent may provide to connect to a network. Note that not all possible inputs are supported and thus connecting to some networks is not possible (e.g. WPS). See the ConnMan Agent API documentation for more information. *) type input = - | None (** No input *) - | Passphrase of string (** The passphrase for authentication. For example a WEP key, a PSK passphrase or a passphrase for EAP authentication methods.*) + | None (** No input *) + | Passphrase of string + (** The passphrase for authentication. For example a WEP key, a PSK passphrase or a passphrase for EAP authentication methods.*) [@@deriving sexp, protocol ~driver:(module Jsonm)] end (** ConnMan Service API*) module Service : sig - - (** The service state information. *) + (** The service state information. *) type state = | Idle | Failure @@ -73,53 +72,52 @@ module Service : sig (** IPv4 properties *) module IPv4 : sig - type t = { - method' : string - ; address : string - ; netmask : string - ; gateway : string option - } + type t = + { method' : string + ; address : string + ; netmask : string + ; gateway : string option + } [@@deriving sexp, protocol ~driver:(module Jsonm)] end (** IPv6 properties *) module IPv6 : sig - type t = { - method' : string - ; address : string - ; prefix_length: int - ; gateway : string option - ; privacy : string - } + type t = + { method' : string + ; address : string + ; prefix_length : int + ; gateway : string option + ; privacy : string + } [@@deriving sexp, protocol ~driver:(module Jsonm)] end (** Ethernet properties *) module Ethernet : sig - type t = { - method' : string - ; interface : string - ; address : string - ; mtu : int - } + type t = + { method' : string + ; interface : string + ; address : string + ; mtu : int + } [@@deriving sexp, protocol ~driver:(module Jsonm)] end module Proxy : sig type credentials = - { user: string - ; password: (string [@sexp.opaque]) + { user : string + ; password : (string[@sexp.opaque]) } - [@@deriving sexp, protocol ~driver:(module Jsonm)] + [@@deriving sexp, protocol ~driver:(module Jsonm)] type t = - { host: string - ; port: int - ; credentials: credentials option - } + { host : string + ; port : int + ; credentials : credentials option + } [@@deriving sexp, protocol ~driver:(module Jsonm)] - val validate : string -> t option (** [validate str] returns [t] if [str] is valid. Valid proxies: @@ -132,36 +130,36 @@ module Service : sig - http://127.0.0.1:1234. - http://user:password@host.com:8888.*) + val validate : string -> t option - val make : ?user:string -> ?password:string -> string -> int -> t (** Make a [t] from mandatory and optional components. *) + val make : ?user:string -> ?password:string -> string -> int -> t - val to_uri : include_userinfo:bool -> t -> Uri.t (** [to_uri ~include_userinfo:bool t] returns a URI from [t], including escaped credentials. *) - + val to_uri : include_userinfo:bool -> t -> Uri.t end (** ConnMan Service Note that not all properties are encoded. *) - type t = { - _proxy : (OBus_proxy.t [@sexp.opaque]) - ; _manager: (OBus_proxy.t [@sexp.opaque]) - ; id : string - ; name : string - ; type' : Technology.type' - ; security: security list - ; state : state - ; strength : int option - ; favorite : bool - ; autoconnect : bool - ; ipv4 : IPv4.t option - ; ipv6 : IPv6.t option - ; ethernet : Ethernet.t - ; proxy : Proxy.t option - ; nameservers : string list - } + type t = + { _proxy : (OBus_proxy.t[@sexp.opaque]) + ; _manager : (OBus_proxy.t[@sexp.opaque]) + ; id : string + ; name : string + ; type' : Technology.type' + ; security : security list + ; state : state + ; strength : int option + ; favorite : bool + ; autoconnect : bool + ; ipv4 : IPv4.t option + ; ipv6 : IPv6.t option + ; ethernet : Ethernet.t + ; proxy : Proxy.t option + ; nameservers : string list + } [@@deriving sexp, protocol ~driver:(module Jsonm)] (** Helper to decide if service is connected *) @@ -171,7 +169,8 @@ module Service : sig val set_manual_proxy : t -> Proxy.t -> unit Lwt.t - val set_manual_ipv4 : t -> address:string -> netmask:string -> gateway:string -> unit Lwt.t + val set_manual_ipv4 : + t -> address:string -> netmask:string -> gateway:string -> unit Lwt.t val set_dhcp_ipv4 : t -> unit Lwt.t @@ -186,7 +185,6 @@ module Service : sig can be removed this way. If it is connected, it will be automatically disconnected first.*) val remove : t -> unit Lwt.t - end (** ConnMan Manager API *) @@ -209,5 +207,4 @@ module Manager : sig (** Returns the proxy of the default service, if it has one configured *) val get_default_proxy : t -> Service.Proxy.t option Lwt.t - end diff --git a/controller/bindings/connman/dune b/controller/bindings/connman/dune index 4f26b0aa..f869b9e0 100644 --- a/controller/bindings/connman/dune +++ b/controller/bindings/connman/dune @@ -3,12 +3,20 @@ (library (name connman) (modules connman connman_interfaces) - (libraries obus logs logs.lwt containers sexplib ezjsonm uri - ppx_protocol_conv_jsonm) - (preprocess (pps lwt_ppx ppx_sexp_conv ppx_protocol_conv))) + (libraries + obus + logs + logs.lwt + containers + sexplib + ezjsonm + uri + ppx_protocol_conv_jsonm) + (preprocess + (pps lwt_ppx ppx_sexp_conv ppx_protocol_conv))) (rule (targets connman_interfaces.ml connman_interfaces.mli) - (deps connman_interfaces.xml) + (deps connman_interfaces.xml) (action (run obus-gen-interface -keep-common -o connman_interfaces %{deps}))) diff --git a/controller/bindings/curl/curl.ml b/controller/bindings/curl/curl.ml index c2340ef4..c130f75d 100644 --- a/controller/bindings/curl/curl.ml +++ b/controller/bindings/curl/curl.ml @@ -13,28 +13,21 @@ let pretty_print_error error = match error with | UnsuccessfulStatus (code, body) -> Printf.sprintf "unsuccessful status %d: %s" code body - | UnreadableStatus body -> Printf.sprintf "unreadable status code %s" body - | ProcessExit (n, err) -> - Printf.sprintf "curl error: %s (non-zero exit code %d)" (String.trim err) n - + Printf.sprintf "curl error: %s (non-zero exit code %d)" (String.trim err) + n | ProcessKill n -> Printf.sprintf "curl killed by signal %d" n - | ProcessStop n -> Printf.sprintf "curl stopped by signal %d" n - | UnixError err -> Printf.sprintf "unix error: %s" err - | EndOfFile -> "end of file" - | ChannelClosed err -> Printf.sprintf "channel closed: %s" err - | Exception err -> Printf.sprintf "exception: %s" err @@ -46,10 +39,7 @@ let exec cmd = let stdout_r, stdout_w = Unix.pipe ~cloexec:true () in let stderr_r, stderr_w = Unix.pipe ~cloexec:true () in let%lwt result = - Lwt_process.exec - ~stdout:(`FD_move stdout_w) - ~stderr:(`FD_move stderr_w) - cmd + Lwt_process.exec ~stdout:(`FD_move stdout_w) ~stderr:(`FD_move stderr_w) cmd in let stdout_input = Lwt_io.of_unix_fd ~mode:Lwt_io.input stdout_r in let stderr_input = Lwt_io.of_unix_fd ~mode:Lwt_io.input stderr_r in @@ -60,72 +50,63 @@ let exec cmd = Lwt.return (result, stdout, stderr) let safe_int_of_string str = - try - Some (int_of_string str) - with - Failure _ -> None + try Some (int_of_string str) with Failure _ -> None let http_code_marker = '|' let parse_status_code_and_body str = let open Base.Option in - Base.String.rsplit2 ~on:http_code_marker str >>= fun (body, code_str) -> - safe_int_of_string code_str >>= fun code -> - return (code, body) + Base.String.rsplit2 ~on:http_code_marker str + >>= fun (body, code_str) -> + safe_int_of_string code_str >>= fun code -> return (code, body) let request ?proxy ?(headers = []) ?data ?(options = []) url = let cmd = - "", (* path to Curl executable (uses PATH if empty string) *) - (Array.concat - [ [| "curl"; Uri.to_string url - ; "--silent" - ; "--show-error" - ; "--write-out"; Char.escaped http_code_marker ^ "%{http_code}" - |] - ; (match proxy with - | Some p -> - [| "--proxy" - ; Uri.to_string p - ; "--proxy-anyauth" - |] - | None -> [| |]) - ; (headers - |> List.map (fun (k, v) -> [| "--header"; (k ^ ":" ^ v) |]) - |> Array.concat) - ; (match data with - | Some d -> [| "--data"; d |] - | None -> [| |]) - ; Base.List.to_array options - ]) + ( "" + , (* path to Curl executable (uses PATH if empty string) *) + Array.concat + [ [| "curl" + ; Uri.to_string url + ; "--silent" + ; "--show-error" + ; "--write-out" + ; Char.escaped http_code_marker ^ "%{http_code}" + |] + ; ( match proxy with + | Some p -> + [| "--proxy"; Uri.to_string p; "--proxy-anyauth" |] + | None -> + [||] + ) + ; headers + |> List.map (fun (k, v) -> [| "--header"; k ^ ":" ^ v |]) + |> Array.concat + ; (match data with Some d -> [| "--data"; d |] | None -> [||]) + ; Base.List.to_array options + ] + ) in match%lwt Lwt_result.catch (fun () -> exec cmd) with - | Ok (Unix.WEXITED 0, stdout, _) -> - (match parse_status_code_and_body stdout with + | Ok (Unix.WEXITED 0, stdout, _) -> ( + match parse_status_code_and_body stdout with | Some (code, body) -> - if Cohttp.Code.is_success code then - Lwt.return (RequestSuccess (code, body)) - else - Lwt.return (RequestFailure (UnsuccessfulStatus (code, body))) + if Cohttp.Code.is_success code then + Lwt.return (RequestSuccess (code, body)) + else Lwt.return (RequestFailure (UnsuccessfulStatus (code, body))) | None -> - Lwt.return (RequestFailure (UnreadableStatus stdout))) - + Lwt.return (RequestFailure (UnreadableStatus stdout)) + ) | Ok (Unix.WEXITED n, _, stderr) -> - Lwt.return (RequestFailure (ProcessExit (n, stderr))) - + Lwt.return (RequestFailure (ProcessExit (n, stderr))) | Ok (Unix.WSIGNALED signal, _, _stderr) -> - Lwt.return (RequestFailure (ProcessKill signal)) - + Lwt.return (RequestFailure (ProcessKill signal)) | Ok (Unix.WSTOPPED signal, _, _stderr) -> - Lwt.return (RequestFailure (ProcessStop signal)) - + Lwt.return (RequestFailure (ProcessStop signal)) | Error (Unix.Unix_error (err, _, _)) -> - Lwt.return (RequestFailure (UnixError (Unix.error_message err))) - + Lwt.return (RequestFailure (UnixError (Unix.error_message err))) | Error End_of_file -> - Lwt.return (RequestFailure EndOfFile) - + Lwt.return (RequestFailure EndOfFile) | Error (Lwt_io.Channel_closed err) -> - Lwt.return (RequestFailure (ChannelClosed err)) - + Lwt.return (RequestFailure (ChannelClosed err)) | Error exn -> - Lwt.return (RequestFailure (Exception (Printexc.to_string exn))) + Lwt.return (RequestFailure (Exception (Printexc.to_string exn))) diff --git a/controller/bindings/curl/curl.mli b/controller/bindings/curl/curl.mli index fa3827ef..788ad098 100644 --- a/controller/bindings/curl/curl.mli +++ b/controller/bindings/curl/curl.mli @@ -15,8 +15,8 @@ type result = val pretty_print_error : error -> string -val request - : ?proxy:Uri.t +val request : + ?proxy:Uri.t -> ?headers:(string * string) list -> ?data:string -> ?options:string list diff --git a/controller/bindings/curl/dune b/controller/bindings/curl/dune index c2374931..fc89c493 100644 --- a/controller/bindings/curl/dune +++ b/controller/bindings/curl/dune @@ -2,4 +2,5 @@ (name curl) (modules curl) (libraries cohttp-lwt-unix uri base config) - (preprocess (pps lwt_ppx))) + (preprocess + (pps lwt_ppx))) diff --git a/controller/bindings/locale/dune b/controller/bindings/locale/dune index 4822e3df..7a21e117 100644 --- a/controller/bindings/locale/dune +++ b/controller/bindings/locale/dune @@ -2,5 +2,5 @@ (name locale) (modules locale) (libraries logs logs.lwt cohttp-lwt-unix ezjsonm sexplib util base) - (preprocess (pps lwt_ppx ppx_sexp_conv))) - + (preprocess + (pps lwt_ppx ppx_sexp_conv))) diff --git a/controller/bindings/locale/locale.mli b/controller/bindings/locale/locale.mli index ac983acd..97559ace 100644 --- a/controller/bindings/locale/locale.mli +++ b/controller/bindings/locale/locale.mli @@ -1,5 +1,7 @@ -val get_lang : unit -> (string option) Lwt.t +val get_lang : unit -> string option Lwt.t + val set_lang : string -> unit Lwt.t -val get_keymap : unit -> (string option) Lwt.t +val get_keymap : unit -> string option Lwt.t + val set_keymap : string -> unit Lwt.t diff --git a/controller/bindings/rauc/dune b/controller/bindings/rauc/dune index 416152b3..ff85edb6 100644 --- a/controller/bindings/rauc/dune +++ b/controller/bindings/rauc/dune @@ -4,10 +4,11 @@ (name rauc) (modules rauc rauc_interfaces) (libraries obus logs logs.lwt ezjsonm sexplib) - (preprocess (pps lwt_ppx ppx_sexp_conv))) + (preprocess + (pps lwt_ppx ppx_sexp_conv))) (rule (targets rauc_interfaces.ml rauc_interfaces.mli) - (deps rauc_interfaces.xml) + (deps rauc_interfaces.xml) (action (run obus-gen-interface -keep-common -o rauc_interfaces %{deps}))) diff --git a/controller/bindings/rauc/rauc.ml b/controller/bindings/rauc/rauc.ml index 4a5201c9..a7e4ca30 100644 --- a/controller/bindings/rauc/rauc.ml +++ b/controller/bindings/rauc/rauc.ml @@ -9,30 +9,33 @@ type t = OBus_peer.Private.t let daemon () = let%lwt system_bus = OBus_bus.system () in - let peer = OBus_peer.make ~connection:system_bus ~name:"de.pengutronix.rauc" in + let peer = + OBus_peer.make ~connection:system_bus ~name:"de.pengutronix.rauc" + in return peer -let proxy daemon = - OBus_proxy.make ~peer:daemon ~path:[] +let proxy daemon = OBus_proxy.make ~peer:daemon ~path:[] -module Slot = -struct +module Slot = struct type t = | SystemA | SystemB let of_string = function - | "a" -> SystemA - | "system.a" -> SystemA - | "b" -> SystemB - | "system.b" -> SystemB - | _ -> failwith "Unexpected slot identifier." + | "a" -> + SystemA + | "system.a" -> + SystemA + | "b" -> + SystemB + | "system.b" -> + SystemB + | _ -> + failwith "Unexpected slot identifier." let t_of_string = of_string - let string_of_t = function - | SystemA -> "system.a" - | SystemB -> "system.b" + let string_of_t = function SystemA -> "system.a" | SystemB -> "system.b" type status = { device : string @@ -42,56 +45,44 @@ struct ; installed_timestamp : string } [@@deriving sexp] - end - let get_booted_slot daemon = - OBus_property.make - De_pengutronix_rauc_Installer.p_BootSlot - (proxy daemon) + OBus_property.make De_pengutronix_rauc_Installer.p_BootSlot (proxy daemon) |> OBus_property.get >|= Slot.of_string - let mark_slot daemon slot status = - let%lwt marked, msg = OBus_method.call - De_pengutronix_rauc_Installer.m_Mark - (proxy daemon) + let%lwt marked, msg = + OBus_method.call De_pengutronix_rauc_Installer.m_Mark (proxy daemon) (status, slot |> Slot.string_of_t) in let%lwt () = Logs_lwt.info ~src:log_src (fun m -> m "%s" msg) in - if Slot.of_string marked = slot then - return_unit - else - Lwt.fail_with "Wrong slot marked." - + if Slot.of_string marked = slot then return_unit + else Lwt.fail_with "Wrong slot marked." -let mark_good daemon slot = - mark_slot daemon slot "good" +let mark_good daemon slot = mark_slot daemon slot "good" -let mark_active daemon slot = - mark_slot daemon slot "active" +let mark_active daemon slot = mark_slot daemon slot "active" type status = - { a: Slot.status - ; b: Slot.status + { a : Slot.status + ; b : Slot.status } [@@deriving sexp] -let json_of_status status = - status - |> sexp_of_status - |> Ezjsonm.t_of_sexp +let json_of_status status = status |> sexp_of_status |> Ezjsonm.t_of_sexp (* Helper to decode Slot.status from OBus *) -let slot_status_of_obus - (o:(string * OBus_value.V.single) list) : Slot.status = +let slot_status_of_obus (o : (string * OBus_value.V.single) list) : Slot.status + = let get_string key o = let open OBus_value.V in match List.assoc_opt key o with - | Some (Basic (String s)) -> s - | _ -> failwith (Format.sprintf "could not get string from field %s" key) + | Some (Basic (String s)) -> + s + | _ -> + failwith (Format.sprintf "could not get string from field %s" key) in { device = get_string "device" o ; class' = get_string "class" o @@ -101,9 +92,9 @@ let slot_status_of_obus } let get_status daemon = - let%lwt status_assoc = OBus_method.call De_pengutronix_rauc_Installer.m_GetSlotStatus - (proxy daemon) - () + let%lwt status_assoc = + OBus_method.call De_pengutronix_rauc_Installer.m_GetSlotStatus + (proxy daemon) () in { a = slot_status_of_obus (List.assoc "system.a" status_assoc) ; b = slot_status_of_obus (List.assoc "system.b" status_assoc) @@ -112,10 +103,10 @@ let get_status daemon = let get_primary daemon = try%lwt - (OBus_method.call De_pengutronix_rauc_Installer.m_GetPrimary (proxy daemon) () - >|= Slot.of_string - >>= Lwt.return_some - ) + OBus_method.call De_pengutronix_rauc_Installer.m_GetPrimary (proxy daemon) + () + >|= Slot.of_string + >>= Lwt.return_some with _ -> Lwt.return_none let install daemon source = @@ -123,10 +114,10 @@ let install daemon source = let%lwt completed_e = OBus_signal.map (fun result -> - let result = Int32.to_int result in - result) - (OBus_signal.make - De_pengutronix_rauc_Installer.s_Completed proxy) + let result = Int32.to_int result in + result + ) + (OBus_signal.make De_pengutronix_rauc_Installer.s_Completed proxy) |> OBus_signal.connect in let%lwt () = @@ -134,68 +125,78 @@ let install daemon source = in match%lwt Lwt_react.E.next completed_e with | 0 -> - return_unit + return_unit | exit_code -> - Lwt.fail_with - (Format.sprintf "installing bundle (%s) failed with exit code %d" source exit_code) + Lwt.fail_with + (Format.sprintf "installing bundle (%s) failed with exit code %d" source + exit_code + ) (* Auto generated with obus-gen-client *) module De_pengutronix_rauc_Installer : sig - val install : OBus_proxy.t -> source : string -> unit Lwt.t - val info : OBus_proxy.t -> bundle : string -> (string * string) Lwt.t - val mark : OBus_proxy.t -> state : string -> slot_identifier : string -> (string * string) Lwt.t - val get_slot_status : OBus_proxy.t -> (string * (string * OBus_value.V.single) list) list Lwt.t + val install : OBus_proxy.t -> source:string -> unit Lwt.t + + val info : OBus_proxy.t -> bundle:string -> (string * string) Lwt.t + + val mark : + OBus_proxy.t + -> state:string + -> slot_identifier:string + -> (string * string) Lwt.t + + val get_slot_status : + OBus_proxy.t -> (string * (string * OBus_value.V.single) list) list Lwt.t + val get_primary : OBus_proxy.t -> string Lwt.t + val completed : OBus_proxy.t -> int OBus_signal.t + val operation : OBus_proxy.t -> (string, [ `readable ]) OBus_property.t + val last_error : OBus_proxy.t -> (string, [ `readable ]) OBus_property.t - val progress : OBus_proxy.t -> (int * string * int, [ `readable ]) OBus_property.t + + val progress : + OBus_proxy.t -> (int * string * int, [ `readable ]) OBus_property.t + val compatible : OBus_proxy.t -> (string, [ `readable ]) OBus_property.t + val variant : OBus_proxy.t -> (string, [ `readable ]) OBus_property.t + val boot_slot : OBus_proxy.t -> (string, [ `readable ]) OBus_property.t end = struct open De_pengutronix_rauc_Installer + let install proxy ~source = OBus_method.call m_Install proxy source - let install proxy ~source = - OBus_method.call m_Install proxy source - - let info proxy ~bundle = - OBus_method.call m_Info proxy bundle + let info proxy ~bundle = OBus_method.call m_Info proxy bundle let mark proxy ~state ~slot_identifier = OBus_method.call m_Mark proxy (state, slot_identifier) - let get_slot_status proxy = - OBus_method.call m_GetSlotStatus proxy () + let get_slot_status proxy = OBus_method.call m_GetSlotStatus proxy () - let get_primary proxy = - OBus_method.call m_GetPrimary proxy () + let get_primary proxy = OBus_method.call m_GetPrimary proxy () let completed proxy = OBus_signal.map (fun result -> - let result = Int32.to_int result in - result) + let result = Int32.to_int result in + result + ) (OBus_signal.make s_Completed proxy) - let operation proxy = - OBus_property.make p_Operation proxy + let operation proxy = OBus_property.make p_Operation proxy - let last_error proxy = - OBus_property.make p_LastError proxy + let last_error proxy = OBus_property.make p_LastError proxy let progress proxy = OBus_property.map_r (fun x -> (fun (x1, x2, x3) -> (Int32.to_int x1, x2, Int32.to_int x3)) x) (OBus_property.make p_Progress proxy) - let compatible proxy = - OBus_property.make p_Compatible proxy + let compatible proxy = OBus_property.make p_Compatible proxy - let variant proxy = - OBus_property.make p_Variant proxy + let variant proxy = OBus_property.make p_Variant proxy - let boot_slot proxy = - OBus_property.make p_BootSlot proxy + let boot_slot proxy = OBus_property.make p_BootSlot proxy end diff --git a/controller/bindings/rauc/rauc.mli b/controller/bindings/rauc/rauc.mli index 17b6ace9..b1fcf14c 100644 --- a/controller/bindings/rauc/rauc.mli +++ b/controller/bindings/rauc/rauc.mli @@ -4,7 +4,6 @@ type t = OBus_peer.Private.t val daemon : unit -> t Lwt.t module Slot : sig - type t = | SystemA | SystemB @@ -17,12 +16,11 @@ module Slot : sig { device : string ; class' : string ; state : string - (* Fields that are only available when installed via RAUC (not from installer script)*) + (* Fields that are only available when installed via RAUC (not from installer script)*) ; version : string ; installed_timestamp : string } [@@deriving sexp] - end (** [get_booted_slot rauc] returns the currently booted slot *) @@ -37,8 +35,8 @@ val mark_active : t -> Slot.t -> unit Lwt.t (** Rauc status *) type status = - { a: Slot.status - ; b: Slot.status + { a : Slot.status + ; b : Slot.status } [@@deriving sexp] diff --git a/controller/bindings/screen-settings/dune b/controller/bindings/screen-settings/dune index 63600cac..5c538f6c 100644 --- a/controller/bindings/screen-settings/dune +++ b/controller/bindings/screen-settings/dune @@ -2,4 +2,5 @@ (name screen_settings) (modules screen_settings) (libraries lwt logs logs.fmt logs.lwt lwt.unix util base) - (preprocess (pps lwt_ppx))) + (preprocess + (pps lwt_ppx))) diff --git a/controller/bindings/screen-settings/screen_settings.ml b/controller/bindings/screen-settings/screen_settings.ml index 5ba1f0d7..5b71c0c2 100644 --- a/controller/bindings/screen-settings/screen_settings.ml +++ b/controller/bindings/screen-settings/screen_settings.ml @@ -1,6 +1,7 @@ open Lwt let log_src = Logs.Src.create "screen-scaling" + let settings_file = "/var/lib/gui-localization/screen-scaling" (* Scaling options *) @@ -19,43 +20,45 @@ type scaling = | Native let scaling_of_string = function - | "default" -> Some Default - | "full-hd" -> Some FullHD - | "native" -> Some Native - | _ -> None + | "default" -> + Some Default + | "full-hd" -> + Some FullHD + | "native" -> + Some Native + | _ -> + None let string_of_scaling = function - | Default -> "default" - | FullHD -> "full-hd" - | Native -> "native" + | Default -> + "default" + | FullHD -> + "full-hd" + | Native -> + "native" (* Used for representing options in the UI, ie. in dropdown. *) let label_of_scaling = function - | Default -> "Default" - | FullHD -> "Full HD" - | Native -> "Native" + | Default -> + "Default" + | FullHD -> + "Full HD" + | Native -> + "Native" let set_scaling scaling = match scaling with - | Default -> - Lwt_unix.file_exists settings_file - >>= (fun exists -> - if exists then Lwt_unix.unlink settings_file - else return () - ) - | _ -> - Util.write_to_file log_src settings_file (string_of_scaling scaling) + | Default -> + Lwt_unix.file_exists settings_file + >>= fun exists -> + if exists then Lwt_unix.unlink settings_file else return () + | _ -> + Util.write_to_file log_src settings_file (string_of_scaling scaling) let get_scaling () = Lwt_unix.file_exists settings_file - >>= (fun exists -> - if exists then - Util.read_from_file log_src settings_file - >|= (fun s -> - s - |> scaling_of_string - |> Option.value ~default:Default - ) - else - return Default - ) + >>= fun exists -> + if exists then + Util.read_from_file log_src settings_file + >|= fun s -> s |> scaling_of_string |> Option.value ~default:Default + else return Default diff --git a/controller/bindings/screen-settings/screen_settings.mli b/controller/bindings/screen-settings/screen_settings.mli index 210e7285..003ccd39 100644 --- a/controller/bindings/screen-settings/screen_settings.mli +++ b/controller/bindings/screen-settings/screen_settings.mli @@ -1,12 +1,14 @@ - type scaling = | Default | FullHD | Native val string_of_scaling : scaling -> string + val label_of_scaling : scaling -> string + val scaling_of_string : string -> scaling option val get_scaling : unit -> scaling Lwt.t + val set_scaling : scaling -> unit Lwt.t diff --git a/controller/bindings/systemd/dune b/controller/bindings/systemd/dune index 799a339b..1ade94bd 100644 --- a/controller/bindings/systemd/dune +++ b/controller/bindings/systemd/dune @@ -4,7 +4,8 @@ (name systemd) (modules systemd systemd_interfaces) (libraries obus logs logs.lwt ezjsonm sexplib) - (preprocess (pps lwt_ppx ppx_sexp_conv))) + (preprocess + (pps lwt_ppx ppx_sexp_conv))) (rule (targets systemd_interfaces.ml systemd_interfaces.mli) diff --git a/controller/bindings/systemd/systemd.ml b/controller/bindings/systemd/systemd.ml index 925c4dfa..bdc14b3b 100644 --- a/controller/bindings/systemd/systemd.ml +++ b/controller/bindings/systemd/systemd.ml @@ -2,22 +2,19 @@ open Lwt open Sexplib.Std open Systemd_interfaces -module Unit = -struct +module Unit = struct type t = OBus_proxy.t - end -module Manager = -struct - +module Manager = struct type t = OBus_proxy.t let connect () = let%lwt system_bus = OBus_bus.system () in - let peer = OBus_peer.make ~connection:system_bus ~name:"org.freedesktop.systemd1" in - OBus_proxy.make ~peer ~path:["org"; "freedesktop"; "systemd1"] - |> return + let peer = + OBus_peer.make ~connection:system_bus ~name:"org.freedesktop.systemd1" + in + OBus_proxy.make ~peer ~path:[ "org"; "freedesktop"; "systemd1" ] |> return type system_state = | Initializing @@ -33,29 +30,39 @@ struct let get_system_state proxy = let system_state_of_string s = match s with - | "initializing" -> Initializing - | "starting" -> Starting - | "running" -> Running - | "degraded" -> Degraded - | "maintenance" -> Maintenance - | "stopping" -> Stopping - | "offline" -> Offline - | "unknown" -> Unknown - | _ -> failwith (Format.sprintf "unexpected system state (%s)" s) - in - OBus_property.make - Org_freedesktop_systemd1_Manager.p_SystemState proxy + | "initializing" -> + Initializing + | "starting" -> + Starting + | "running" -> + Running + | "degraded" -> + Degraded + | "maintenance" -> + Maintenance + | "stopping" -> + Stopping + | "offline" -> + Offline + | "unknown" -> + Unknown + | _ -> + failwith (Format.sprintf "unexpected system state (%s)" s) + in + OBus_property.make Org_freedesktop_systemd1_Manager.p_SystemState proxy |> OBus_property.get >|= system_state_of_string let get_unit proxy name = - let%lwt (context, x1) = OBus_method.call_with_context - Org_freedesktop_systemd1_Manager.m_GetUnit proxy name in + let%lwt context, x1 = + OBus_method.call_with_context Org_freedesktop_systemd1_Manager.m_GetUnit + proxy name + in let unit = OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x1 in return unit let restart_unit proxy name = - let%lwt (context, x1) = + let%lwt context, x1 = OBus_method.call_with_context Org_freedesktop_systemd1_Manager.m_RestartUnit proxy (name, "replace") in @@ -65,76 +72,61 @@ struct return_unit let start_unit proxy name = - let%lwt (context, x1) = - OBus_method.call_with_context - Org_freedesktop_systemd1_Manager.m_StartUnit proxy (name, "replace") + let%lwt context, x1 = + OBus_method.call_with_context Org_freedesktop_systemd1_Manager.m_StartUnit + proxy (name, "replace") in return_unit let stop_unit proxy name = - let%lwt (context, x1) = - OBus_method.call_with_context - Org_freedesktop_systemd1_Manager.m_StopUnit proxy (name, "replace") + let%lwt context, x1 = + OBus_method.call_with_context Org_freedesktop_systemd1_Manager.m_StopUnit + proxy (name, "replace") in return_unit - end - (* Auto-generated by obus-gen-client *) -module Org_freedesktop_systemd1_Manager = -struct +module Org_freedesktop_systemd1_Manager = struct open Org_freedesktop_systemd1_Manager + let version proxy = OBus_property.make p_Version proxy - let version proxy = - OBus_property.make p_Version proxy - - let features proxy = - OBus_property.make p_Features proxy + let features proxy = OBus_property.make p_Features proxy - let virtualization proxy = - OBus_property.make p_Virtualization proxy + let virtualization proxy = OBus_property.make p_Virtualization proxy - let architecture proxy = - OBus_property.make p_Architecture proxy + let architecture proxy = OBus_property.make p_Architecture proxy - let tainted proxy = - OBus_property.make p_Tainted proxy + let tainted proxy = OBus_property.make p_Tainted proxy - let firmware_timestamp proxy = - OBus_property.make p_FirmwareTimestamp proxy + let firmware_timestamp proxy = OBus_property.make p_FirmwareTimestamp proxy let firmware_timestamp_monotonic proxy = OBus_property.make p_FirmwareTimestampMonotonic proxy - let loader_timestamp proxy = - OBus_property.make p_LoaderTimestamp proxy + let loader_timestamp proxy = OBus_property.make p_LoaderTimestamp proxy let loader_timestamp_monotonic proxy = OBus_property.make p_LoaderTimestampMonotonic proxy - let kernel_timestamp proxy = - OBus_property.make p_KernelTimestamp proxy + let kernel_timestamp proxy = OBus_property.make p_KernelTimestamp proxy let kernel_timestamp_monotonic proxy = OBus_property.make p_KernelTimestampMonotonic proxy - let init_rdtimestamp proxy = - OBus_property.make p_InitRDTimestamp proxy + let init_rdtimestamp proxy = OBus_property.make p_InitRDTimestamp proxy let init_rdtimestamp_monotonic proxy = OBus_property.make p_InitRDTimestampMonotonic proxy - let userspace_timestamp proxy = - OBus_property.make p_UserspaceTimestamp proxy + let userspace_timestamp proxy = OBus_property.make p_UserspaceTimestamp proxy let userspace_timestamp_monotonic proxy = OBus_property.make p_UserspaceTimestampMonotonic proxy - let finish_timestamp proxy = - OBus_property.make p_FinishTimestamp proxy + let finish_timestamp proxy = OBus_property.make p_FinishTimestamp proxy let finish_timestamp_monotonic proxy = OBus_property.make p_FinishTimestampMonotonic proxy @@ -175,11 +167,9 @@ struct let units_load_finish_timestamp_monotonic proxy = OBus_property.make p_UnitsLoadFinishTimestampMonotonic proxy - let log_level proxy = - OBus_property.make p_LogLevel proxy + let log_level proxy = OBus_property.make p_LogLevel proxy - let log_target proxy = - OBus_property.make p_LogTarget proxy + let log_target proxy = OBus_property.make p_LogTarget proxy let nnames proxy = OBus_property.map_r @@ -206,20 +196,15 @@ struct (fun x -> Int32.to_int x) (OBus_property.make p_NFailedJobs proxy) - let progress proxy = - OBus_property.make p_Progress proxy + let progress proxy = OBus_property.make p_Progress proxy - let environment proxy = - OBus_property.make p_Environment proxy + let environment proxy = OBus_property.make p_Environment proxy - let confirm_spawn proxy = - OBus_property.make p_ConfirmSpawn proxy + let confirm_spawn proxy = OBus_property.make p_ConfirmSpawn proxy - let show_status proxy = - OBus_property.make p_ShowStatus proxy + let show_status proxy = OBus_property.make p_ShowStatus proxy - let unit_path proxy = - OBus_property.make p_UnitPath proxy + let unit_path proxy = OBus_property.make p_UnitPath proxy let default_standard_output proxy = OBus_property.make p_DefaultStandardOutput proxy @@ -233,17 +218,13 @@ struct let shutdown_watchdog_usec proxy = OBus_property.make p_ShutdownWatchdogUSec proxy - let service_watchdogs proxy = - OBus_property.make p_ServiceWatchdogs proxy + let service_watchdogs proxy = OBus_property.make p_ServiceWatchdogs proxy - let control_group proxy = - OBus_property.make p_ControlGroup proxy + let control_group proxy = OBus_property.make p_ControlGroup proxy - let system_state proxy = - OBus_property.make p_SystemState proxy + let system_state proxy = OBus_property.make p_SystemState proxy - let exit_code proxy = - OBus_property.make p_ExitCode proxy + let exit_code proxy = OBus_property.make p_ExitCode proxy let default_timer_accuracy_usec proxy = OBus_property.make p_DefaultTimerAccuracyUSec proxy @@ -254,8 +235,7 @@ struct let default_timeout_stop_usec proxy = OBus_property.make p_DefaultTimeoutStopUSec proxy - let default_restart_usec proxy = - OBus_property.make p_DefaultRestartUSec proxy + let default_restart_usec proxy = OBus_property.make p_DefaultRestartUSec proxy let default_start_limit_interval_usec proxy = OBus_property.make p_DefaultStartLimitIntervalUSec proxy @@ -277,56 +257,46 @@ struct let default_tasks_accounting proxy = OBus_property.make p_DefaultTasksAccounting proxy - let default_limit_cpu proxy = - OBus_property.make p_DefaultLimitCPU proxy + let default_limit_cpu proxy = OBus_property.make p_DefaultLimitCPU proxy let default_limit_cpusoft proxy = OBus_property.make p_DefaultLimitCPUSoft proxy - let default_limit_fsize proxy = - OBus_property.make p_DefaultLimitFSIZE proxy + let default_limit_fsize proxy = OBus_property.make p_DefaultLimitFSIZE proxy let default_limit_fsizesoft proxy = OBus_property.make p_DefaultLimitFSIZESoft proxy - let default_limit_data proxy = - OBus_property.make p_DefaultLimitDATA proxy + let default_limit_data proxy = OBus_property.make p_DefaultLimitDATA proxy let default_limit_datasoft proxy = OBus_property.make p_DefaultLimitDATASoft proxy - let default_limit_stack proxy = - OBus_property.make p_DefaultLimitSTACK proxy + let default_limit_stack proxy = OBus_property.make p_DefaultLimitSTACK proxy let default_limit_stacksoft proxy = OBus_property.make p_DefaultLimitSTACKSoft proxy - let default_limit_core proxy = - OBus_property.make p_DefaultLimitCORE proxy + let default_limit_core proxy = OBus_property.make p_DefaultLimitCORE proxy let default_limit_coresoft proxy = OBus_property.make p_DefaultLimitCORESoft proxy - let default_limit_rss proxy = - OBus_property.make p_DefaultLimitRSS proxy + let default_limit_rss proxy = OBus_property.make p_DefaultLimitRSS proxy let default_limit_rsssoft proxy = OBus_property.make p_DefaultLimitRSSSoft proxy - let default_limit_nofile proxy = - OBus_property.make p_DefaultLimitNOFILE proxy + let default_limit_nofile proxy = OBus_property.make p_DefaultLimitNOFILE proxy let default_limit_nofilesoft proxy = OBus_property.make p_DefaultLimitNOFILESoft proxy - let default_limit_as proxy = - OBus_property.make p_DefaultLimitAS proxy + let default_limit_as proxy = OBus_property.make p_DefaultLimitAS proxy - let default_limit_assoft proxy = - OBus_property.make p_DefaultLimitASSoft proxy + let default_limit_assoft proxy = OBus_property.make p_DefaultLimitASSoft proxy - let default_limit_nproc proxy = - OBus_property.make p_DefaultLimitNPROC proxy + let default_limit_nproc proxy = OBus_property.make p_DefaultLimitNPROC proxy let default_limit_nprocsoft proxy = OBus_property.make p_DefaultLimitNPROCSoft proxy @@ -337,8 +307,7 @@ struct let default_limit_memlocksoft proxy = OBus_property.make p_DefaultLimitMEMLOCKSoft proxy - let default_limit_locks proxy = - OBus_property.make p_DefaultLimitLOCKS proxy + let default_limit_locks proxy = OBus_property.make p_DefaultLimitLOCKS proxy let default_limit_lockssoft proxy = OBus_property.make p_DefaultLimitLOCKSSoft proxy @@ -355,93 +324,110 @@ struct let default_limit_msgqueuesoft proxy = OBus_property.make p_DefaultLimitMSGQUEUESoft proxy - let default_limit_nice proxy = - OBus_property.make p_DefaultLimitNICE proxy + let default_limit_nice proxy = OBus_property.make p_DefaultLimitNICE proxy let default_limit_nicesoft proxy = OBus_property.make p_DefaultLimitNICESoft proxy - let default_limit_rtprio proxy = - OBus_property.make p_DefaultLimitRTPRIO proxy + let default_limit_rtprio proxy = OBus_property.make p_DefaultLimitRTPRIO proxy let default_limit_rtpriosoft proxy = OBus_property.make p_DefaultLimitRTPRIOSoft proxy - let default_limit_rttime proxy = - OBus_property.make p_DefaultLimitRTTIME proxy + let default_limit_rttime proxy = OBus_property.make p_DefaultLimitRTTIME proxy let default_limit_rttimesoft proxy = OBus_property.make p_DefaultLimitRTTIMESoft proxy - let default_tasks_max proxy = - OBus_property.make p_DefaultTasksMax proxy + let default_tasks_max proxy = OBus_property.make p_DefaultTasksMax proxy - let timer_slack_nsec proxy = - OBus_property.make p_TimerSlackNSec proxy + let timer_slack_nsec proxy = OBus_property.make p_TimerSlackNSec proxy let get_unit proxy x1 = - let%lwt (context, x1) = OBus_method.call_with_context m_GetUnit proxy x1 in + let%lwt context, x1 = OBus_method.call_with_context m_GetUnit proxy x1 in let x1 = OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x1 in return x1 let get_unit_by_pid proxy x1 = let x1 = Int32.of_int x1 in - let%lwt (context, x1) = OBus_method.call_with_context m_GetUnitByPID proxy x1 in + let%lwt context, x1 = + OBus_method.call_with_context m_GetUnitByPID proxy x1 + in let x1 = OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x1 in return x1 let get_unit_by_invocation_id proxy x1 = - let%lwt (context, x1) = OBus_method.call_with_context m_GetUnitByInvocationID proxy x1 in + let%lwt context, x1 = + OBus_method.call_with_context m_GetUnitByInvocationID proxy x1 + in let x1 = OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x1 in return x1 let get_unit_by_control_group proxy x1 = - let%lwt (context, x1) = OBus_method.call_with_context m_GetUnitByControlGroup proxy x1 in + let%lwt context, x1 = + OBus_method.call_with_context m_GetUnitByControlGroup proxy x1 + in let x1 = OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x1 in return x1 let load_unit proxy x1 = - let%lwt (context, x1) = OBus_method.call_with_context m_LoadUnit proxy x1 in + let%lwt context, x1 = OBus_method.call_with_context m_LoadUnit proxy x1 in let x1 = OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x1 in return x1 let start_unit proxy x1 x2 = - let%lwt (context, x1) = OBus_method.call_with_context m_StartUnit proxy (x1, x2) in + let%lwt context, x1 = + OBus_method.call_with_context m_StartUnit proxy (x1, x2) + in let x1 = OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x1 in return x1 let start_unit_replace proxy x1 x2 x3 = - let%lwt (context, x1) = OBus_method.call_with_context m_StartUnitReplace proxy (x1, x2, x3) in + let%lwt context, x1 = + OBus_method.call_with_context m_StartUnitReplace proxy (x1, x2, x3) + in let x1 = OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x1 in return x1 let stop_unit proxy x1 x2 = - let%lwt (context, x1) = OBus_method.call_with_context m_StopUnit proxy (x1, x2) in + let%lwt context, x1 = + OBus_method.call_with_context m_StopUnit proxy (x1, x2) + in let x1 = OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x1 in return x1 let reload_unit proxy x1 x2 = - let%lwt (context, x1) = OBus_method.call_with_context m_ReloadUnit proxy (x1, x2) in + let%lwt context, x1 = + OBus_method.call_with_context m_ReloadUnit proxy (x1, x2) + in let x1 = OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x1 in return x1 let restart_unit proxy x1 x2 = - let%lwt (context, x1) = OBus_method.call_with_context m_RestartUnit proxy (x1, x2) in + let%lwt context, x1 = + OBus_method.call_with_context m_RestartUnit proxy (x1, x2) + in let x1 = OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x1 in return x1 let try_restart_unit proxy x1 x2 = - let%lwt (context, x1) = OBus_method.call_with_context m_TryRestartUnit proxy (x1, x2) in + let%lwt context, x1 = + OBus_method.call_with_context m_TryRestartUnit proxy (x1, x2) + in let x1 = OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x1 in return x1 let reload_or_restart_unit proxy x1 x2 = - let%lwt (context, x1) = OBus_method.call_with_context m_ReloadOrRestartUnit proxy (x1, x2) in + let%lwt context, x1 = + OBus_method.call_with_context m_ReloadOrRestartUnit proxy (x1, x2) + in let x1 = OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x1 in return x1 let reload_or_try_restart_unit proxy x1 x2 = - let%lwt (context, x1) = OBus_method.call_with_context m_ReloadOrTryRestartUnit proxy (x1, x2) in + let%lwt context, x1 = + OBus_method.call_with_context m_ReloadOrTryRestartUnit proxy (x1, x2) + in let x1 = OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x1 in return x1 @@ -449,20 +435,19 @@ struct let x3 = Int32.of_int x3 in OBus_method.call m_KillUnit proxy (x1, x2, x3) - let reset_failed_unit proxy x1 = - OBus_method.call m_ResetFailedUnit proxy x1 + let reset_failed_unit proxy x1 = OBus_method.call m_ResetFailedUnit proxy x1 let set_unit_properties proxy x1 x2 x3 = OBus_method.call m_SetUnitProperties proxy (x1, x2, x3) - let ref_unit proxy x1 = - OBus_method.call m_RefUnit proxy x1 + let ref_unit proxy x1 = OBus_method.call m_RefUnit proxy x1 - let unref_unit proxy x1 = - OBus_method.call m_UnrefUnit proxy x1 + let unref_unit proxy x1 = OBus_method.call m_UnrefUnit proxy x1 let start_transient_unit proxy x1 x2 x3 x4 = - let%lwt (context, x1) = OBus_method.call_with_context m_StartTransientUnit proxy (x1, x2, x3, x4) in + let%lwt context, x1 = + OBus_method.call_with_context m_StartTransientUnit proxy (x1, x2, x3, x4) + in let x1 = OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x1 in return x1 @@ -477,104 +462,198 @@ struct let get_job proxy x1 = let x1 = Int32.of_int x1 in - let%lwt (context, x1) = OBus_method.call_with_context m_GetJob proxy x1 in + let%lwt context, x1 = OBus_method.call_with_context m_GetJob proxy x1 in let x1 = OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x1 in return x1 let get_job_after proxy x1 = let x1 = Int32.of_int x1 in - let%lwt (context, x1) = OBus_method.call_with_context m_GetJobAfter proxy x1 in - let x1 = List.map (fun (x1, x2, x3, x4, x5, x6) -> (Int32.to_int x1, x2, x3, x4, OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x5, OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x6)) x1 in + let%lwt context, x1 = + OBus_method.call_with_context m_GetJobAfter proxy x1 + in + let x1 = + List.map + (fun (x1, x2, x3, x4, x5, x6) -> + ( Int32.to_int x1 + , x2 + , x3 + , x4 + , OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x5 + , OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x6 + ) + ) + x1 + in return x1 let get_job_before proxy x1 = let x1 = Int32.of_int x1 in - let%lwt (context, x1) = OBus_method.call_with_context m_GetJobBefore proxy x1 in - let x1 = List.map (fun (x1, x2, x3, x4, x5, x6) -> (Int32.to_int x1, x2, x3, x4, OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x5, OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x6)) x1 in + let%lwt context, x1 = + OBus_method.call_with_context m_GetJobBefore proxy x1 + in + let x1 = + List.map + (fun (x1, x2, x3, x4, x5, x6) -> + ( Int32.to_int x1 + , x2 + , x3 + , x4 + , OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x5 + , OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x6 + ) + ) + x1 + in return x1 let cancel_job proxy x1 = let x1 = Int32.of_int x1 in OBus_method.call m_CancelJob proxy x1 - let clear_jobs proxy = - OBus_method.call m_ClearJobs proxy () + let clear_jobs proxy = OBus_method.call m_ClearJobs proxy () - let reset_failed proxy = - OBus_method.call m_ResetFailed proxy () + let reset_failed proxy = OBus_method.call m_ResetFailed proxy () let list_units proxy = - let%lwt (context, x1) = OBus_method.call_with_context m_ListUnits proxy () in - let x1 = List.map (fun (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10) -> (x1, x2, x3, x4, x5, x6, OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x7, Int32.to_int x8, x9, OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x10)) x1 in + let%lwt context, x1 = OBus_method.call_with_context m_ListUnits proxy () in + let x1 = + List.map + (fun (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10) -> + ( x1 + , x2 + , x3 + , x4 + , x5 + , x6 + , OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x7 + , Int32.to_int x8 + , x9 + , OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x10 + ) + ) + x1 + in return x1 let list_units_filtered proxy x1 = - let%lwt (context, x1) = OBus_method.call_with_context m_ListUnitsFiltered proxy x1 in - let x1 = List.map (fun (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10) -> (x1, x2, x3, x4, x5, x6, OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x7, Int32.to_int x8, x9, OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x10)) x1 in + let%lwt context, x1 = + OBus_method.call_with_context m_ListUnitsFiltered proxy x1 + in + let x1 = + List.map + (fun (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10) -> + ( x1 + , x2 + , x3 + , x4 + , x5 + , x6 + , OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x7 + , Int32.to_int x8 + , x9 + , OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x10 + ) + ) + x1 + in return x1 let list_units_by_patterns proxy x1 x2 = - let%lwt (context, x1) = OBus_method.call_with_context m_ListUnitsByPatterns proxy (x1, x2) in - let x1 = List.map (fun (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10) -> (x1, x2, x3, x4, x5, x6, OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x7, Int32.to_int x8, x9, OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x10)) x1 in + let%lwt context, x1 = + OBus_method.call_with_context m_ListUnitsByPatterns proxy (x1, x2) + in + let x1 = + List.map + (fun (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10) -> + ( x1 + , x2 + , x3 + , x4 + , x5 + , x6 + , OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x7 + , Int32.to_int x8 + , x9 + , OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x10 + ) + ) + x1 + in return x1 let list_units_by_names proxy x1 = - let%lwt (context, x1) = OBus_method.call_with_context m_ListUnitsByNames proxy x1 in - let x1 = List.map (fun (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10) -> (x1, x2, x3, x4, x5, x6, OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x7, Int32.to_int x8, x9, OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x10)) x1 in + let%lwt context, x1 = + OBus_method.call_with_context m_ListUnitsByNames proxy x1 + in + let x1 = + List.map + (fun (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10) -> + ( x1 + , x2 + , x3 + , x4 + , x5 + , x6 + , OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x7 + , Int32.to_int x8 + , x9 + , OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x10 + ) + ) + x1 + in return x1 let list_jobs proxy = - let%lwt (context, x1) = OBus_method.call_with_context m_ListJobs proxy () in - let x1 = List.map (fun (x1, x2, x3, x4, x5, x6) -> (Int32.to_int x1, x2, x3, x4, OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x5, OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x6)) x1 in + let%lwt context, x1 = OBus_method.call_with_context m_ListJobs proxy () in + let x1 = + List.map + (fun (x1, x2, x3, x4, x5, x6) -> + ( Int32.to_int x1 + , x2 + , x3 + , x4 + , OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x5 + , OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x6 + ) + ) + x1 + in return x1 - let subscribe proxy = - OBus_method.call m_Subscribe proxy () + let subscribe proxy = OBus_method.call m_Subscribe proxy () - let unsubscribe proxy = - OBus_method.call m_Unsubscribe proxy () + let unsubscribe proxy = OBus_method.call m_Unsubscribe proxy () - let dump proxy = - OBus_method.call m_Dump proxy () + let dump proxy = OBus_method.call m_Dump proxy () let dump_by_file_descriptor proxy = OBus_method.call m_DumpByFileDescriptor proxy () - let reload proxy = - OBus_method.call m_Reload proxy () + let reload proxy = OBus_method.call m_Reload proxy () - let reexecute proxy = - OBus_method.call m_Reexecute proxy () + let reexecute proxy = OBus_method.call m_Reexecute proxy () - let exit proxy = - OBus_method.call m_Exit proxy () + let exit proxy = OBus_method.call m_Exit proxy () - let reboot proxy = - OBus_method.call m_Reboot proxy () + let reboot proxy = OBus_method.call m_Reboot proxy () - let power_off proxy = - OBus_method.call m_PowerOff proxy () + let power_off proxy = OBus_method.call m_PowerOff proxy () - let halt proxy = - OBus_method.call m_Halt proxy () + let halt proxy = OBus_method.call m_Halt proxy () - let kexec proxy = - OBus_method.call m_KExec proxy () + let kexec proxy = OBus_method.call m_KExec proxy () - let switch_root proxy x1 x2 = - OBus_method.call m_SwitchRoot proxy (x1, x2) + let switch_root proxy x1 x2 = OBus_method.call m_SwitchRoot proxy (x1, x2) - let set_environment proxy x1 = - OBus_method.call m_SetEnvironment proxy x1 + let set_environment proxy x1 = OBus_method.call m_SetEnvironment proxy x1 - let unset_environment proxy x1 = - OBus_method.call m_UnsetEnvironment proxy x1 + let unset_environment proxy x1 = OBus_method.call m_UnsetEnvironment proxy x1 let unset_and_set_environment proxy x1 x2 = OBus_method.call m_UnsetAndSetEnvironment proxy (x1, x2) - let list_unit_files proxy = - OBus_method.call m_ListUnitFiles proxy () + let list_unit_files proxy = OBus_method.call m_ListUnitFiles proxy () let list_unit_files_by_patterns proxy x1 x2 = OBus_method.call m_ListUnitFilesByPatterns proxy (x1, x2) @@ -606,14 +685,12 @@ struct let unmask_unit_files proxy x1 x2 = OBus_method.call m_UnmaskUnitFiles proxy (x1, x2) - let revert_unit_files proxy x1 = - OBus_method.call m_RevertUnitFiles proxy x1 + let revert_unit_files proxy x1 = OBus_method.call m_RevertUnitFiles proxy x1 let set_default_target proxy x1 x2 = OBus_method.call m_SetDefaultTarget proxy (x1, x2) - let get_default_target proxy = - OBus_method.call m_GetDefaultTarget proxy () + let get_default_target proxy = OBus_method.call m_GetDefaultTarget proxy () let preset_all_unit_files proxy x1 x2 x3 = OBus_method.call m_PresetAllUnitFiles proxy (x1, x2, x3) @@ -624,8 +701,7 @@ struct let get_unit_file_links proxy x1 x2 = OBus_method.call m_GetUnitFileLinks proxy (x1, x2) - let set_exit_code proxy x1 = - OBus_method.call m_SetExitCode proxy x1 + let set_exit_code proxy x1 = OBus_method.call m_SetExitCode proxy x1 let lookup_dynamic_user_by_name proxy x1 = let%lwt x1 = OBus_method.call m_LookupDynamicUserByName proxy x1 in @@ -644,149 +720,115 @@ struct let unit_new proxy = OBus_signal.map_with_context (fun context (x1, x2) -> - let x2 = OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x2 in - (x1, x2)) + let x2 = OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x2 in + (x1, x2) + ) (OBus_signal.make s_UnitNew proxy) let unit_removed proxy = OBus_signal.map_with_context (fun context (x1, x2) -> - let x2 = OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x2 in - (x1, x2)) + let x2 = OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x2 in + (x1, x2) + ) (OBus_signal.make s_UnitRemoved proxy) let job_new proxy = OBus_signal.map_with_context (fun context (x1, x2, x3) -> - let x1 = Int32.to_int x1 in - let x2 = OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x2 in - (x1, x2, x3)) + let x1 = Int32.to_int x1 in + let x2 = OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x2 in + (x1, x2, x3) + ) (OBus_signal.make s_JobNew proxy) let job_removed proxy = OBus_signal.map_with_context (fun context (x1, x2, x3, x4) -> - let x1 = Int32.to_int x1 in - let x2 = OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x2 in - (x1, x2, x3, x4)) + let x1 = Int32.to_int x1 in + let x2 = OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x2 in + (x1, x2, x3, x4) + ) (OBus_signal.make s_JobRemoved proxy) - let startup_finished proxy = - OBus_signal.make s_StartupFinished proxy + let startup_finished proxy = OBus_signal.make s_StartupFinished proxy - let unit_files_changed proxy = - OBus_signal.make s_UnitFilesChanged proxy + let unit_files_changed proxy = OBus_signal.make s_UnitFilesChanged proxy - let reloading proxy = - OBus_signal.make s_Reloading proxy + let reloading proxy = OBus_signal.make s_Reloading proxy end -module Org_freedesktop_systemd1_Unit = -struct +module Org_freedesktop_systemd1_Unit = struct open Org_freedesktop_systemd1_Unit + let id proxy = OBus_property.make p_Id proxy - let id proxy = - OBus_property.make p_Id proxy - - let names proxy = - OBus_property.make p_Names proxy + let names proxy = OBus_property.make p_Names proxy - let following proxy = - OBus_property.make p_Following proxy + let following proxy = OBus_property.make p_Following proxy - let requires proxy = - OBus_property.make p_Requires proxy + let requires proxy = OBus_property.make p_Requires proxy - let requisite proxy = - OBus_property.make p_Requisite proxy + let requisite proxy = OBus_property.make p_Requisite proxy - let wants proxy = - OBus_property.make p_Wants proxy + let wants proxy = OBus_property.make p_Wants proxy - let binds_to proxy = - OBus_property.make p_BindsTo proxy + let binds_to proxy = OBus_property.make p_BindsTo proxy - let part_of proxy = - OBus_property.make p_PartOf proxy + let part_of proxy = OBus_property.make p_PartOf proxy - let required_by proxy = - OBus_property.make p_RequiredBy proxy + let required_by proxy = OBus_property.make p_RequiredBy proxy - let requisite_of proxy = - OBus_property.make p_RequisiteOf proxy + let requisite_of proxy = OBus_property.make p_RequisiteOf proxy - let wanted_by proxy = - OBus_property.make p_WantedBy proxy + let wanted_by proxy = OBus_property.make p_WantedBy proxy - let bound_by proxy = - OBus_property.make p_BoundBy proxy + let bound_by proxy = OBus_property.make p_BoundBy proxy - let consists_of proxy = - OBus_property.make p_ConsistsOf proxy + let consists_of proxy = OBus_property.make p_ConsistsOf proxy - let conflicts proxy = - OBus_property.make p_Conflicts proxy + let conflicts proxy = OBus_property.make p_Conflicts proxy - let conflicted_by proxy = - OBus_property.make p_ConflictedBy proxy + let conflicted_by proxy = OBus_property.make p_ConflictedBy proxy - let before proxy = - OBus_property.make p_Before proxy + let before proxy = OBus_property.make p_Before proxy - let after proxy = - OBus_property.make p_After proxy + let after proxy = OBus_property.make p_After proxy - let on_failure proxy = - OBus_property.make p_OnFailure proxy + let on_failure proxy = OBus_property.make p_OnFailure proxy - let triggers proxy = - OBus_property.make p_Triggers proxy + let triggers proxy = OBus_property.make p_Triggers proxy - let triggered_by proxy = - OBus_property.make p_TriggeredBy proxy + let triggered_by proxy = OBus_property.make p_TriggeredBy proxy - let propagates_reload_to proxy = - OBus_property.make p_PropagatesReloadTo proxy + let propagates_reload_to proxy = OBus_property.make p_PropagatesReloadTo proxy let reload_propagated_from proxy = OBus_property.make p_ReloadPropagatedFrom proxy - let joins_namespace_of proxy = - OBus_property.make p_JoinsNamespaceOf proxy + let joins_namespace_of proxy = OBus_property.make p_JoinsNamespaceOf proxy - let requires_mounts_for proxy = - OBus_property.make p_RequiresMountsFor proxy + let requires_mounts_for proxy = OBus_property.make p_RequiresMountsFor proxy - let documentation proxy = - OBus_property.make p_Documentation proxy + let documentation proxy = OBus_property.make p_Documentation proxy - let description proxy = - OBus_property.make p_Description proxy + let description proxy = OBus_property.make p_Description proxy - let load_state proxy = - OBus_property.make p_LoadState proxy + let load_state proxy = OBus_property.make p_LoadState proxy - let active_state proxy = - OBus_property.make p_ActiveState proxy + let active_state proxy = OBus_property.make p_ActiveState proxy - let sub_state proxy = - OBus_property.make p_SubState proxy + let sub_state proxy = OBus_property.make p_SubState proxy - let fragment_path proxy = - OBus_property.make p_FragmentPath proxy + let fragment_path proxy = OBus_property.make p_FragmentPath proxy - let source_path proxy = - OBus_property.make p_SourcePath proxy + let source_path proxy = OBus_property.make p_SourcePath proxy - let drop_in_paths proxy = - OBus_property.make p_DropInPaths proxy + let drop_in_paths proxy = OBus_property.make p_DropInPaths proxy - let unit_file_state proxy = - OBus_property.make p_UnitFileState proxy + let unit_file_state proxy = OBus_property.make p_UnitFileState proxy - let unit_file_preset proxy = - OBus_property.make p_UnitFilePreset proxy + let unit_file_preset proxy = OBus_property.make p_UnitFilePreset proxy let state_change_timestamp proxy = OBus_property.make p_StateChangeTimestamp proxy @@ -818,95 +860,90 @@ struct let inactive_enter_timestamp_monotonic proxy = OBus_property.make p_InactiveEnterTimestampMonotonic proxy - let can_start proxy = - OBus_property.make p_CanStart proxy + let can_start proxy = OBus_property.make p_CanStart proxy - let can_stop proxy = - OBus_property.make p_CanStop proxy + let can_stop proxy = OBus_property.make p_CanStop proxy - let can_reload proxy = - OBus_property.make p_CanReload proxy + let can_reload proxy = OBus_property.make p_CanReload proxy - let can_isolate proxy = - OBus_property.make p_CanIsolate proxy + let can_isolate proxy = OBus_property.make p_CanIsolate proxy let job proxy = OBus_property.map_r_with_context - (fun context x -> (fun (x1, x2) -> (Int32.to_int x1, OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x2)) x) + (fun context x -> + (fun (x1, x2) -> + ( Int32.to_int x1 + , OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x2 + ) + ) + x + ) (OBus_property.make p_Job proxy) - let stop_when_unneeded proxy = - OBus_property.make p_StopWhenUnneeded proxy + let stop_when_unneeded proxy = OBus_property.make p_StopWhenUnneeded proxy - let refuse_manual_start proxy = - OBus_property.make p_RefuseManualStart proxy + let refuse_manual_start proxy = OBus_property.make p_RefuseManualStart proxy - let refuse_manual_stop proxy = - OBus_property.make p_RefuseManualStop proxy + let refuse_manual_stop proxy = OBus_property.make p_RefuseManualStop proxy - let allow_isolate proxy = - OBus_property.make p_AllowIsolate proxy + let allow_isolate proxy = OBus_property.make p_AllowIsolate proxy let default_dependencies proxy = OBus_property.make p_DefaultDependencies proxy - let on_failure_job_mode proxy = - OBus_property.make p_OnFailureJobMode proxy + let on_failure_job_mode proxy = OBus_property.make p_OnFailureJobMode proxy - let ignore_on_isolate proxy = - OBus_property.make p_IgnoreOnIsolate proxy + let ignore_on_isolate proxy = OBus_property.make p_IgnoreOnIsolate proxy - let need_daemon_reload proxy = - OBus_property.make p_NeedDaemonReload proxy + let need_daemon_reload proxy = OBus_property.make p_NeedDaemonReload proxy - let job_timeout_usec proxy = - OBus_property.make p_JobTimeoutUSec proxy + let job_timeout_usec proxy = OBus_property.make p_JobTimeoutUSec proxy let job_running_timeout_usec proxy = OBus_property.make p_JobRunningTimeoutUSec proxy - let job_timeout_action proxy = - OBus_property.make p_JobTimeoutAction proxy + let job_timeout_action proxy = OBus_property.make p_JobTimeoutAction proxy let job_timeout_reboot_argument proxy = OBus_property.make p_JobTimeoutRebootArgument proxy - let condition_result proxy = - OBus_property.make p_ConditionResult proxy + let condition_result proxy = OBus_property.make p_ConditionResult proxy - let assert_result proxy = - OBus_property.make p_AssertResult proxy + let assert_result proxy = OBus_property.make p_AssertResult proxy - let condition_timestamp proxy = - OBus_property.make p_ConditionTimestamp proxy + let condition_timestamp proxy = OBus_property.make p_ConditionTimestamp proxy let condition_timestamp_monotonic proxy = OBus_property.make p_ConditionTimestampMonotonic proxy - let assert_timestamp proxy = - OBus_property.make p_AssertTimestamp proxy + let assert_timestamp proxy = OBus_property.make p_AssertTimestamp proxy let assert_timestamp_monotonic proxy = OBus_property.make p_AssertTimestampMonotonic proxy let conditions proxy = OBus_property.map_r - (fun x -> List.map (fun (x1, x2, x3, x4, x5) -> (x1, x2, x3, x4, Int32.to_int x5)) x) + (fun x -> + List.map + (fun (x1, x2, x3, x4, x5) -> (x1, x2, x3, x4, Int32.to_int x5)) + x + ) (OBus_property.make p_Conditions proxy) let asserts proxy = OBus_property.map_r - (fun x -> List.map (fun (x1, x2, x3, x4, x5) -> (x1, x2, x3, x4, Int32.to_int x5)) x) + (fun x -> + List.map + (fun (x1, x2, x3, x4, x5) -> (x1, x2, x3, x4, Int32.to_int x5)) + x + ) (OBus_property.make p_Asserts proxy) - let load_error proxy = - OBus_property.make p_LoadError proxy + let load_error proxy = OBus_property.make p_LoadError proxy - let transient proxy = - OBus_property.make p_Transient proxy + let transient proxy = OBus_property.make p_Transient proxy - let perpetual proxy = - OBus_property.make p_Perpetual proxy + let perpetual proxy = OBus_property.make p_Perpetual proxy let start_limit_interval_usec proxy = OBus_property.make p_StartLimitIntervalUSec proxy @@ -916,56 +953,54 @@ struct (fun x -> Int32.to_int x) (OBus_property.make p_StartLimitBurst proxy) - let start_limit_action proxy = - OBus_property.make p_StartLimitAction proxy + let start_limit_action proxy = OBus_property.make p_StartLimitAction proxy - let failure_action proxy = - OBus_property.make p_FailureAction proxy + let failure_action proxy = OBus_property.make p_FailureAction proxy - let success_action proxy = - OBus_property.make p_SuccessAction proxy + let success_action proxy = OBus_property.make p_SuccessAction proxy - let reboot_argument proxy = - OBus_property.make p_RebootArgument proxy + let reboot_argument proxy = OBus_property.make p_RebootArgument proxy - let invocation_id proxy = - OBus_property.make p_InvocationID proxy + let invocation_id proxy = OBus_property.make p_InvocationID proxy - let collect_mode proxy = - OBus_property.make p_CollectMode proxy + let collect_mode proxy = OBus_property.make p_CollectMode proxy let start proxy x1 = - let%lwt (context, x1) = OBus_method.call_with_context m_Start proxy x1 in + let%lwt context, x1 = OBus_method.call_with_context m_Start proxy x1 in let x1 = OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x1 in return x1 let stop proxy x1 = - let%lwt (context, x1) = OBus_method.call_with_context m_Stop proxy x1 in + let%lwt context, x1 = OBus_method.call_with_context m_Stop proxy x1 in let x1 = OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x1 in return x1 let reload proxy x1 = - let%lwt (context, x1) = OBus_method.call_with_context m_Reload proxy x1 in + let%lwt context, x1 = OBus_method.call_with_context m_Reload proxy x1 in let x1 = OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x1 in return x1 let restart proxy x1 = - let%lwt (context, x1) = OBus_method.call_with_context m_Restart proxy x1 in + let%lwt context, x1 = OBus_method.call_with_context m_Restart proxy x1 in let x1 = OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x1 in return x1 let try_restart proxy x1 = - let%lwt (context, x1) = OBus_method.call_with_context m_TryRestart proxy x1 in + let%lwt context, x1 = OBus_method.call_with_context m_TryRestart proxy x1 in let x1 = OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x1 in return x1 let reload_or_restart proxy x1 = - let%lwt (context, x1) = OBus_method.call_with_context m_ReloadOrRestart proxy x1 in + let%lwt context, x1 = + OBus_method.call_with_context m_ReloadOrRestart proxy x1 + in let x1 = OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x1 in return x1 let reload_or_try_restart proxy x1 = - let%lwt (context, x1) = OBus_method.call_with_context m_ReloadOrTryRestart proxy x1 in + let%lwt context, x1 = + OBus_method.call_with_context m_ReloadOrTryRestart proxy x1 + in let x1 = OBus_proxy.make ~peer:(OBus_context.sender context) ~path:x1 in return x1 @@ -973,15 +1008,12 @@ struct let x2 = Int32.of_int x2 in OBus_method.call m_Kill proxy (x1, x2) - let reset_failed proxy = - OBus_method.call m_ResetFailed proxy () + let reset_failed proxy = OBus_method.call m_ResetFailed proxy () let set_properties proxy x1 x2 = OBus_method.call m_SetProperties proxy (x1, x2) - let ref proxy = - OBus_method.call m_Ref proxy () + let ref proxy = OBus_method.call m_Ref proxy () - let unref proxy = - OBus_method.call m_Unref proxy () + let unref proxy = OBus_method.call m_Unref proxy () end diff --git a/controller/bindings/systemd/systemd.mli b/controller/bindings/systemd/systemd.mli index 94b782a3..f91b2326 100644 --- a/controller/bindings/systemd/systemd.mli +++ b/controller/bindings/systemd/systemd.mli @@ -5,7 +5,6 @@ module Unit : sig end module Manager : sig - type t (** connect with systemd D-Bus API *) @@ -55,5 +54,4 @@ module Manager : sig *) val stop_unit : t -> string -> unit Lwt.t - end diff --git a/controller/bindings/timedate/dune b/controller/bindings/timedate/dune index 6ad3ef10..01defb5e 100644 --- a/controller/bindings/timedate/dune +++ b/controller/bindings/timedate/dune @@ -4,10 +4,11 @@ (name timedate) (modules timedate timedate_interfaces) (libraries obus logs logs.lwt cohttp-lwt-unix sexplib util base) - (preprocess (pps lwt_ppx ppx_sexp_conv))) + (preprocess + (pps lwt_ppx ppx_sexp_conv))) (rule (targets timedate_interfaces.ml timedate_interfaces.mli) - (deps timedate_interfaces.xml) + (deps timedate_interfaces.xml) (action (run obus-gen-interface -keep-common -o timedate_interfaces %{deps}))) diff --git a/controller/bindings/timedate/timedate.ml b/controller/bindings/timedate/timedate.ml index 2321aacd..a38a62d9 100644 --- a/controller/bindings/timedate/timedate.ml +++ b/controller/bindings/timedate/timedate.ml @@ -19,80 +19,75 @@ let set_timezone timezone = let daemon () = let%lwt system_bus = OBus_bus.system () in - let peer = OBus_peer.make ~connection:system_bus ~name:"org.freedesktop.timedate1" in + let peer = + OBus_peer.make ~connection:system_bus ~name:"org.freedesktop.timedate1" + in return peer let proxy daemon = - OBus_proxy.make ~peer:daemon ~path:["org"; "freedesktop"; "timedate1"] + OBus_proxy.make ~peer:daemon ~path:[ "org"; "freedesktop"; "timedate1" ] let get_active_timezone daemon = let%lwt raw_tz = - OBus_property.make - Org_freedesktop_timedate1.p_Timezone - (proxy daemon) + OBus_property.make Org_freedesktop_timedate1.p_Timezone (proxy daemon) |> OBus_property.get in - if String.length raw_tz = 0 then - None |> return - else - Some raw_tz |> return + if String.length raw_tz = 0 then None |> return else Some raw_tz |> return let get_current_time daemon = - Lwt_process.pread ("", [|"date"; "+%Y-%m-%d %H:%M UTC%z"|]) + Lwt_process.pread ("", [| "date"; "+%Y-%m-%d %H:%M UTC%z" |]) let get_available_timezones daemon = (* Newer versions of systemd add a DBus property for this. *) - Lwt_process.pread_lines ("", [|"timedatectl"; "list-timezones"|]) + Lwt_process.pread_lines ("", [| "timedatectl"; "list-timezones" |]) |> Lwt_stream.to_list - (* Auto generated with obus-gen-client *) module Org_freedesktop_timedate1 : sig val timezone : OBus_proxy.t -> (string, [ `readable ]) OBus_property.t + val local_rtc : OBus_proxy.t -> (bool, [ `readable ]) OBus_property.t + val can_ntp : OBus_proxy.t -> (bool, [ `readable ]) OBus_property.t + val ntp : OBus_proxy.t -> (bool, [ `readable ]) OBus_property.t + val ntpsynchronized : OBus_proxy.t -> (bool, [ `readable ]) OBus_property.t + val time_usec : OBus_proxy.t -> (int64, [ `readable ]) OBus_property.t + val rtctime_usec : OBus_proxy.t -> (int64, [ `readable ]) OBus_property.t + val set_time : OBus_proxy.t -> int64 -> bool -> bool -> unit Lwt.t + val set_timezone : OBus_proxy.t -> string -> bool -> unit Lwt.t + val set_local_rtc : OBus_proxy.t -> bool -> bool -> bool -> unit Lwt.t + val set_ntp : OBus_proxy.t -> bool -> bool -> unit Lwt.t end = struct open Org_freedesktop_timedate1 + let timezone proxy = OBus_property.make p_Timezone proxy - let timezone proxy = - OBus_property.make p_Timezone proxy - - let local_rtc proxy = - OBus_property.make p_LocalRTC proxy + let local_rtc proxy = OBus_property.make p_LocalRTC proxy - let can_ntp proxy = - OBus_property.make p_CanNTP proxy + let can_ntp proxy = OBus_property.make p_CanNTP proxy - let ntp proxy = - OBus_property.make p_NTP proxy + let ntp proxy = OBus_property.make p_NTP proxy - let ntpsynchronized proxy = - OBus_property.make p_NTPSynchronized proxy + let ntpsynchronized proxy = OBus_property.make p_NTPSynchronized proxy - let time_usec proxy = - OBus_property.make p_TimeUSec proxy + let time_usec proxy = OBus_property.make p_TimeUSec proxy - let rtctime_usec proxy = - OBus_property.make p_RTCTimeUSec proxy + let rtctime_usec proxy = OBus_property.make p_RTCTimeUSec proxy - let set_time proxy x1 x2 x3 = - OBus_method.call m_SetTime proxy (x1, x2, x3) + let set_time proxy x1 x2 x3 = OBus_method.call m_SetTime proxy (x1, x2, x3) - let set_timezone proxy x1 x2 = - OBus_method.call m_SetTimezone proxy (x1, x2) + let set_timezone proxy x1 x2 = OBus_method.call m_SetTimezone proxy (x1, x2) let set_local_rtc proxy x1 x2 x3 = OBus_method.call m_SetLocalRTC proxy (x1, x2, x3) - let set_ntp proxy x1 x2 = - OBus_method.call m_SetNTP proxy (x1, x2) + let set_ntp proxy x1 x2 = OBus_method.call m_SetNTP proxy (x1, x2) end diff --git a/controller/bindings/timedate/timedate.mli b/controller/bindings/timedate/timedate.mli index 144dc346..cef5a51f 100644 --- a/controller/bindings/timedate/timedate.mli +++ b/controller/bindings/timedate/timedate.mli @@ -4,30 +4,40 @@ type t = OBus_peer.Private.t val daemon : unit -> t Lwt.t (** [get_available_timezones daemon] returns the available timezones in the system *) -val get_available_timezones : t -> (string list) Lwt.t +val get_available_timezones : t -> string list Lwt.t (** [get_current_time daemon] returns the current formatted timestamp *) val get_current_time : t -> string Lwt.t (** [get_active_timezone daemon] returns the currently active timezone *) -val get_active_timezone : t -> (string option) Lwt.t +val get_active_timezone : t -> string option Lwt.t (** [get_configured_timezone daemon] returns the configured timezone *) -val get_configured_timezone : unit -> (string option) Lwt.t +val get_configured_timezone : unit -> string option Lwt.t (** [set_timezone daemon timezone] sets the timezone *) val set_timezone : string -> unit Lwt.t module Org_freedesktop_timedate1 : sig val timezone : OBus_proxy.t -> (string, [ `readable ]) OBus_property.t + val local_rtc : OBus_proxy.t -> (bool, [ `readable ]) OBus_property.t + val can_ntp : OBus_proxy.t -> (bool, [ `readable ]) OBus_property.t + val ntp : OBus_proxy.t -> (bool, [ `readable ]) OBus_property.t + val ntpsynchronized : OBus_proxy.t -> (bool, [ `readable ]) OBus_property.t + val time_usec : OBus_proxy.t -> (int64, [ `readable ]) OBus_property.t + val rtctime_usec : OBus_proxy.t -> (int64, [ `readable ]) OBus_property.t + val set_time : OBus_proxy.t -> int64 -> bool -> bool -> unit Lwt.t + val set_timezone : OBus_proxy.t -> string -> bool -> unit Lwt.t + val set_local_rtc : OBus_proxy.t -> bool -> bool -> bool -> unit Lwt.t + val set_ntp : OBus_proxy.t -> bool -> bool -> unit Lwt.t end diff --git a/controller/bindings/util/dune b/controller/bindings/util/dune index 48205593..5e487b65 100644 --- a/controller/bindings/util/dune +++ b/controller/bindings/util/dune @@ -2,5 +2,5 @@ (name util) (modules util) (libraries logs logs.lwt cohttp-lwt-unix sexplib fpath) - (preprocess (pps lwt_ppx ppx_sexp_conv))) - + (preprocess + (pps lwt_ppx ppx_sexp_conv))) diff --git a/controller/bindings/util/util.ml b/controller/bindings/util/util.ml index 6a4f64b2..2afa1caf 100644 --- a/controller/bindings/util/util.ml +++ b/controller/bindings/util/util.ml @@ -4,8 +4,7 @@ open Lwt * location. This is not optimal, but works for the moment. *) let resource_path end_path = let open Fpath in - (Sys.argv.(0) |> v |> parent) / ".." / "share" // end_path - |> to_string + (Sys.argv.(0) |> v |> parent) / ".." / "share" // end_path |> to_string let read_from_file log_src path = let%lwt exists = Lwt_unix.file_exists path in @@ -16,49 +15,48 @@ let read_from_file log_src path = let%lwt () = Lwt_io.close in_chan in return contents with - | (Unix.Unix_error (err, _fn, _)) as exn -> - let%lwt () = Logs_lwt.err ~src:log_src - (fun m -> m "failed to read from %s: %s" path (Unix.error_message err)) - in - fail exn + | Unix.Unix_error (err, _fn, _) as exn -> + let%lwt () = + Logs_lwt.err ~src:log_src (fun m -> + m "failed to read from %s: %s" path (Unix.error_message err) + ) + in + fail exn | exn -> - let%lwt () = Logs_lwt.err ~src:log_src - (fun m -> m "failed to read from %s: %s" path (Printexc.to_string exn)) - in - fail exn - else - fail (Failure ("File does not exist: " ^ path)) + let%lwt () = + Logs_lwt.err ~src:log_src (fun m -> + m "failed to read from %s: %s" path (Printexc.to_string exn) + ) + in + fail exn + else fail (Failure ("File does not exist: " ^ path)) let write_to_file log_src path str = try - let%lwt fd = - Lwt_unix.openfile path [ O_WRONLY; O_CREAT; O_TRUNC ] 0o755 - in + let%lwt fd = Lwt_unix.openfile path [ O_WRONLY; O_CREAT; O_TRUNC ] 0o755 in let%lwt _bytes_written = Lwt_unix.write_string fd str 0 (String.length str) in Lwt_unix.close fd with - | (Unix.Unix_error (err, _fn, _)) as exn -> - let%lwt () = Logs_lwt.err ~src:log_src - (fun m -> m "failed to write to %s: %s" path (Unix.error_message err)) - in - fail exn + | Unix.Unix_error (err, _fn, _) as exn -> + let%lwt () = + Logs_lwt.err ~src:log_src (fun m -> + m "failed to write to %s: %s" path (Unix.error_message err) + ) + in + fail exn | exn -> - let%lwt () = Logs_lwt.err ~src:log_src - (fun m -> m "failed to write to %s: %s" path (Printexc.to_string exn)) - in - fail exn + let%lwt () = + Logs_lwt.err ~src:log_src (fun m -> + m "failed to write to %s: %s" path (Printexc.to_string exn) + ) + in + fail exn let run_cmd_no_stdout cmd = - match%lwt - Lwt_process.(exec - ~stdout:`Dev_null - ~stderr:`Keep - ("", cmd) - ) - with + match%lwt Lwt_process.(exec ~stdout:`Dev_null ~stderr:`Keep ("", cmd)) with | Unix.WEXITED 0 -> - return_unit + return_unit | _ -> - Lwt.fail_with (Format.sprintf "%s failed" cmd.(0)) + Lwt.fail_with (Format.sprintf "%s failed" cmd.(0)) diff --git a/controller/bindings/zerotier/dune b/controller/bindings/zerotier/dune index 629250d1..c3e86f9e 100644 --- a/controller/bindings/zerotier/dune +++ b/controller/bindings/zerotier/dune @@ -2,4 +2,5 @@ (name zerotier) (modules zerotier) (libraries logs logs.lwt cohttp-lwt-unix ezjsonm sexplib curl util) - (preprocess (pps lwt_ppx ppx_sexp_conv))) + (preprocess + (pps lwt_ppx ppx_sexp_conv))) diff --git a/controller/bindings/zerotier/zerotier.ml b/controller/bindings/zerotier/zerotier.ml index 1d57f6ba..12f060ad 100644 --- a/controller/bindings/zerotier/zerotier.ml +++ b/controller/bindings/zerotier/zerotier.ml @@ -2,29 +2,19 @@ open Lwt let log_src = Logs.Src.create "zerotier" -let base_url = - Uri.make - ~scheme:"http" - ~host:"localhost" - ~port:9993 - () +let base_url = Uri.make ~scheme:"http" ~host:"localhost" ~port:9993 () let get_authtoken () = - Util.read_from_file - log_src - "/var/lib/zerotier-one/authtoken.secret" + Util.read_from_file log_src "/var/lib/zerotier-one/authtoken.secret" -type status = { - address: string -} +type status = { address : string } let get_status () = - Lwt_result.catch - (fun () -> + Lwt_result.catch (fun () -> let%lwt authtoken = get_authtoken () in match%lwt Curl.request - ~headers:[("X-ZT1-Auth", authtoken)] + ~headers:[ ("X-ZT1-Auth", authtoken) ] (Uri.with_path base_url "status") with | RequestSuccess (_, body) -> @@ -33,7 +23,7 @@ let get_status () = |> get_dict |> List.assoc "address" |> get_string - |> fun address -> return {address} + |> fun address -> return { address } | RequestFailure error -> Lwt.fail_with (Curl.pretty_print_error error) - ) + ) diff --git a/controller/bindings/zerotier/zerotier.mli b/controller/bindings/zerotier/zerotier.mli index 3a3e176f..6ee66d8e 100644 --- a/controller/bindings/zerotier/zerotier.mli +++ b/controller/bindings/zerotier/zerotier.mli @@ -1,5 +1,3 @@ -type status = { - address: string -} +type status = { address : string } val get_status : unit -> (status, exn) Lwt_result.t diff --git a/controller/config/config.ml b/controller/config/config.ml index d424cf38..bc639fd6 100644 --- a/controller/config/config.ml +++ b/controller/config/config.ml @@ -1,18 +1,14 @@ (** Global system configuration set by the build system *) module System = struct - (** Version, set by build system *) - let version = - "@PLAYOS_VERSION@" + (** Version, set by build system *) + let version = "@PLAYOS_VERSION@" - (** URL from where to get updates, set by build system *) - let update_url = - "@PLAYOS_UPDATE_URL@" + (** URL from where to get updates, set by build system *) + let update_url = "@PLAYOS_UPDATE_URL@" - (** URL to which kiosk is pointed *) - let kiosk_url = - "@PLAYOS_KIOSK_URL@" + (** URL to which kiosk is pointed *) + let kiosk_url = "@PLAYOS_KIOSK_URL@" - (** PlayOS bundle name prefix *) - let bundle_name = - "@PLAYOS_BUNDLE_NAME@" + (** PlayOS bundle name prefix *) + let bundle_name = "@PLAYOS_BUNDLE_NAME@" end diff --git a/controller/config/dune b/controller/config/dune index d161267c..5f944c1d 100644 --- a/controller/config/dune +++ b/controller/config/dune @@ -1,4 +1,3 @@ (library (name config) - (modules config) -) + (modules config)) diff --git a/controller/dune b/controller/dune index d5b1e30d..da2d0f04 100644 --- a/controller/dune +++ b/controller/dune @@ -14,4 +14,7 @@ ; Disable missing-record-field-pattern warnings (partial matching), ; because they are kind of useless. ; See https://ocaml.org/manual/4.14/comp.html#ss:warn9 for details. -(env (dev (flags :standard -w -9))) + +(env + (dev + (flags :standard -w -9))) diff --git a/controller/server/dune b/controller/server/dune index 60a48ede..04b2edc5 100644 --- a/controller/server/dune +++ b/controller/server/dune @@ -3,32 +3,68 @@ (executable (name server) (public_name playos-controller) - (modules server info gui health - info_page localization_page status_page error_page - network_list_page network_details_page changelog_page - licensing_page page definition icon) - (libraries update lwt logs logs.fmt logs.lwt fpath cohttp-lwt-unix logging - opium tyxml rauc zerotier connman locale network timedate systemd - semver2 fieldslib screen_settings util ppx_protocol_conv_jsonm) - (preprocess (pps lwt_ppx ppx_sexp_conv ppx_protocol_conv))) + (modules + server + info + gui + health + info_page + localization_page + status_page + error_page + network_list_page + network_details_page + changelog_page + licensing_page + page + definition + icon) + (libraries + update + lwt + logs + logs.fmt + logs.lwt + fpath + cohttp-lwt-unix + logging + opium + tyxml + rauc + zerotier + connman + locale + network + timedate + systemd + semver2 + fieldslib + screen_settings + util + ppx_protocol_conv_jsonm) + (preprocess + (pps lwt_ppx ppx_sexp_conv ppx_protocol_conv))) (library (name update) (modules update) (libraries update_client rauc_service lwt connman rauc curl semver2 config) - (preprocess (pps lwt_ppx ppx_sexp_conv))) + (preprocess + (pps lwt_ppx ppx_sexp_conv))) (library (name update_client) (modules update_client) (libraries lwt connman curl semver2 config) - (preprocess (pps lwt_ppx ppx_sexp_conv))) + (preprocess + (pps lwt_ppx ppx_sexp_conv))) (library (name rauc_service) (modules rauc_service) (libraries lwt rauc) - (preprocess (pps lwt_ppx ppx_sexp_conv))) + (preprocess + (pps lwt_ppx ppx_sexp_conv))) (library (name logging) @@ -38,7 +74,14 @@ (library (name network) (modules network) - (libraries lwt logs.lwt lwt.unix cohttp-lwt-unix connman systemd curl - ppx_protocol_conv_jsonm) - (preprocess (pps lwt_ppx ppx_sexp_conv ppx_protocol_conv))) - + (libraries + lwt + logs.lwt + lwt.unix + cohttp-lwt-unix + connman + systemd + curl + ppx_protocol_conv_jsonm) + (preprocess + (pps lwt_ppx ppx_sexp_conv ppx_protocol_conv))) diff --git a/controller/server/gui.ml b/controller/server/gui.ml index fa908262..01583147 100644 --- a/controller/server/gui.ml +++ b/controller/server/gui.ml @@ -7,7 +7,7 @@ let log_src = Logs.Src.create "gui" (* Middleware that makes static content available *) let static () = let static_dir = Util.resource_path (Fpath.v "static") in - Logs.debug (fun m -> m "static content dir: %s" static_dir); + Logs.debug (fun m -> m "static content dir: %s" static_dir) ; Opium.Middleware.static ~local_path:static_dir ~uri_prefix:"/static" () let page html = @@ -17,20 +17,22 @@ let page html = let resp_json ?code json = let headers = Cohttp.Header.init_with "content-type" "application/json" in - Ezjsonm.value_to_string json - |> Response.of_string_body ?code ~headers + Ezjsonm.value_to_string json |> Response.of_string_body ?code ~headers let header key req = Cohttp.Header.get (Request.headers req) key type 'a timeout_params = - { duration: float - ; on_timeout: unit -> 'a Lwt.t + { duration : float + ; on_timeout : unit -> 'a Lwt.t } let with_timeout { duration; on_timeout } f = [ f () - ; (let%lwt () = Lwt_unix.sleep duration in on_timeout ()) - ] |> Lwt.pick + ; (let%lwt () = Lwt_unix.sleep duration in + on_timeout () + ) + ] + |> Lwt.pick (* Pretty error printing middleware *) let error_handling = @@ -39,24 +41,34 @@ let error_handling = (* Catch any exceptions that previously escaped Lwt *) match%lwt Lwt_result.catch (fun () -> handler req) with | Ok res -> - return res - | Error exn -> - let%lwt () = Logs_lwt.err (fun m -> m "GUI Error: %s" (Printexc.to_string exn)) in - match (header "accept" req) with - | Some "application/json" -> (* for testing *) - Lwt.return @@ resp_json ~code:`Internal_server_error @@ `O [ - ("error", `Bool true); - ("message", `String (Printexc.to_string exn)) - ] - | _ -> - Lwt.return (page (Error_page.html - { message = exn - |> Sexplib.Std.sexp_of_exn - |> Sexplib.Sexp.to_string_hum - ; request = req - |> Request.sexp_of_t - |> Sexplib.Sexp.to_string_hum - })) + return res + | Error exn -> ( + let%lwt () = + Logs_lwt.err (fun m -> m "GUI Error: %s" (Printexc.to_string exn)) + in + match header "accept" req with + | Some "application/json" -> + (* for testing *) + Lwt.return + @@ resp_json ~code:`Internal_server_error + @@ `O + [ ("error", `Bool true) + ; ("message", `String (Printexc.to_string exn)) + ] + | _ -> + Lwt.return + (page + (Error_page.html + { message = + exn + |> Sexplib.Std.sexp_of_exn + |> Sexplib.Sexp.to_string_hum + ; request = + req |> Request.sexp_of_t |> Sexplib.Sexp.to_string_hum + } + ) + ) + ) in Middleware.create ~name:"Error" ~filter @@ -65,8 +77,9 @@ module InfoGui = struct let build app = app |> get "/info" (fun _ -> - let%lwt server_info = Info.get () in - Lwt.return (page (Info_page.html server_info))) + let%lwt server_info = Info.get () in + Lwt.return (page (Info_page.html server_info)) + ) end (** Localization GUI *) @@ -78,120 +91,127 @@ module LocalizationGui = struct let timezone_groups = List.fold_right (fun tz groups -> - let re_spaced = String.map (fun c -> if Char.equal c '_' then ' ' else c) tz in - let group_id, name = match String.split_on_char '/' re_spaced |> List.rev with + let re_spaced = + String.map (fun c -> if Char.equal c '_' then ' ' else c) tz + in + let group_id, name = + match String.split_on_char '/' re_spaced |> List.rev with (* An unscoped entry, e.g. UTC. *) - | [ singleton ] -> singleton, singleton + | [ singleton ] -> + (singleton, singleton) (* A humble entry, likely scoped to continent, e.g. Europe/Amsterdam. *) - | [ name; group_id ] -> group_id, name + | [ name; group_id ] -> + (group_id, name) (* A multi-hierarchical entry, e.g. America/Argentina/Buenos_Aires. *) - | name :: group_sections -> String.concat "/" (List.rev group_sections), name + | name :: group_sections -> + (String.concat "/" (List.rev group_sections), name) (* Not a sensible outcome. *) - | [] -> re_spaced, re_spaced + | [] -> + (re_spaced, re_spaced) in - let prev_entries = match List.assoc_opt group_id groups with - | Some entries -> entries - | None -> [] + let prev_entries = + match List.assoc_opt group_id groups with + | Some entries -> + entries + | None -> + [] in - ( group_id, (tz, name) :: prev_entries) + (group_id, (tz, name) :: prev_entries) :: List.remove_assoc group_id groups ) - all_timezones - [] + all_timezones [] in let%lwt current_lang = Locale.get_lang () in let langs = - [ "cs_CZ.UTF-8", "Czech" - ; "nl_NL.UTF-8", "Dutch" - ; "en_UK.UTF-8", "English (UK)" - ; "en_US.UTF-8", "English (US)" - ; "fi_FI.UTF-8", "Finnish" - ; "fr_FR.UTF-8", "French" - ; "de_DE.UTF-8", "German" - ; "it_IT.UTF-8", "Italian" - ; "pl_PL.UTF-8", "Polish" - ; "es_ES.UTF-8", "Spanish" + [ ("cs_CZ.UTF-8", "Czech") + ; ("nl_NL.UTF-8", "Dutch") + ; ("en_UK.UTF-8", "English (UK)") + ; ("en_US.UTF-8", "English (US)") + ; ("fi_FI.UTF-8", "Finnish") + ; ("fr_FR.UTF-8", "French") + ; ("de_DE.UTF-8", "German") + ; ("it_IT.UTF-8", "Italian") + ; ("pl_PL.UTF-8", "Polish") + ; ("es_ES.UTF-8", "Spanish") ] in let%lwt current_keymap = Locale.get_keymap () in let keymaps = - [ "cz", "Czech" - ; "nl", "Dutch" - ; "gb", "English (UK)" - ; "us", "English (US)" - ; "fi", "Finnish" - ; "fr", "French" - ; "de", "German" - ; "ch", "German (Switzerland)" - ; "it", "Italian" - ; "pl", "Polish" - ; "es", "Spanish" + [ ("cz", "Czech") + ; ("nl", "Dutch") + ; ("gb", "English (UK)") + ; ("us", "English (US)") + ; ("fi", "Finnish") + ; ("fr", "French") + ; ("de", "German") + ; ("ch", "German (Switzerland)") + ; ("it", "Italian") + ; ("pl", "Polish") + ; ("es", "Spanish") ] in - let%lwt current_scaling = Screen_settings.get_scaling () - in - Lwt.return (page (Localization_page.html - { timezone_groups - ; current_timezone - ; langs - ; current_lang - ; keymaps - ; current_keymap - ; current_scaling = current_scaling - })) + let%lwt current_scaling = Screen_settings.get_scaling () in + Lwt.return + (page + (Localization_page.html + { timezone_groups + ; current_timezone + ; langs + ; current_lang + ; keymaps + ; current_keymap + ; current_scaling + } + ) + ) let set_timezone req = let%lwt _td_daemon = Timedate.daemon () in - let%lwt form_data = - urlencoded_pairs_of_body req - in + let%lwt form_data = urlencoded_pairs_of_body req in let%lwt _ = match form_data |> List.assoc_opt "timezone" with | Some [ tz_id ] -> - Timedate.set_timezone tz_id + Timedate.set_timezone tz_id | _ -> - return () + return () in "/localization" |> Uri.of_string |> redirect' let set_lang req = - let%lwt form_data = - urlencoded_pairs_of_body req - in + let%lwt form_data = urlencoded_pairs_of_body req in let%lwt _ = match form_data |> List.assoc_opt "lang" with | Some [ lang ] -> - Locale.set_lang lang + Locale.set_lang lang | _ -> - return () + return () in "/localization" |> Uri.of_string |> redirect' let set_keymap req = - let%lwt form_data = - urlencoded_pairs_of_body req - in + let%lwt form_data = urlencoded_pairs_of_body req in let%lwt _ = match form_data |> List.assoc_opt "keymap" with | Some [ keymap ] -> - Locale.set_keymap keymap + Locale.set_keymap keymap | _ -> - return () + return () in "/localization" |> Uri.of_string |> redirect' let set_scaling req = - let%lwt form_data = - urlencoded_pairs_of_body req - in + let%lwt form_data = urlencoded_pairs_of_body req in let%lwt _ = match form_data |> List.assoc_opt "scaling" with - | Some [ opt ] -> - (match Screen_settings.scaling_of_string opt with - | Some s -> Screen_settings.set_scaling s - | None -> fail_with (Format.sprintf "Unknown screen setting: %s" opt)) + | Some [ opt ] -> ( + match Screen_settings.scaling_of_string opt with + | Some s -> + Screen_settings.set_scaling s + | None -> + fail_with (Format.sprintf "Unknown screen setting: %s" opt) + ) | _ -> - return () + return () in "/localization" |> Uri.of_string |> redirect' @@ -206,48 +226,52 @@ end (** Network configuration GUI *) module NetworkGui = struct - open Connman - let overview ~(connman:Manager.t) req = - + let overview ~(connman : Manager.t) req = let%lwt all_services = Manager.get_services connman in - let%lwt proxy = Manager.get_default_proxy connman in - let%lwt interfaces = Network.Interface.get_all () in - let pp_proxy p = - let uri = p |> Service.Proxy.to_uri ~include_userinfo:false |> Uri.to_string in + let uri = + p |> Service.Proxy.to_uri ~include_userinfo:false |> Uri.to_string + in match p.credentials with - | Some({ user; password }) -> - let password_indication = if password = "" then "" else ", password: *****" in + | Some { user; password } -> + let password_indication = + if password = "" then "" else ", password: *****" + in uri ^ " (user: " ^ user ^ password_indication ^ ")" - | None -> uri + | None -> + uri in - - let params: Network_list_page.params = + let params : Network_list_page.params = { proxy = proxy |> Option.map pp_proxy ; services = all_services - ; interfaces = interfaces + ; interfaces } in - match (header "accept" req) with - | Some "application/json" -> - Lwt.return @@ resp_json @@ Network_list_page.params_to_jsonm params - | _ -> - Lwt.return (page (Network_list_page.html params)) + match header "accept" req with + | Some "application/json" -> + Lwt.return @@ resp_json @@ Network_list_page.params_to_jsonm params + | _ -> + Lwt.return (page (Network_list_page.html params)) (** Internet status **) let internet_status ~connman _ = let%lwt proxy = Manager.get_default_proxy connman in - match%lwt Curl.request ?proxy:(Option.map (Service.Proxy.to_uri ~include_userinfo:true) proxy) (Uri.of_string "http://captive.dividat.com/") with + match%lwt + Curl.request + ?proxy:(Option.map (Service.Proxy.to_uri ~include_userinfo:true) proxy) + (Uri.of_string "http://captive.dividat.com/") + with | RequestSuccess (code, response) -> - `String response - |> respond ?code:(Some (`Code code)) - |> Lwt.return + `String response |> respond ?code:(Some (`Code code)) |> Lwt.return | RequestFailure err -> - `String (Format.sprintf "Error reaching captive portal: %s" (Curl.pretty_print_error err)) + `String + (Format.sprintf "Error reaching captive portal: %s" + (Curl.pretty_print_error err) + ) |> respond ?code:(Some `Service_unavailable) |> Lwt.return @@ -255,8 +279,10 @@ module NetworkGui = struct let with_service ~connman id = let%lwt services = Connman.Manager.get_services connman in match List.find_opt (fun s -> s.Service.id = id) services with - | Some s -> return s - | None -> fail_with (Format.sprintf "Service does not exist (%s)" id) + | Some s -> + return s + | None -> + fail_with (Format.sprintf "Service does not exist (%s)" id) let details ~connman req = let service_id = param req "id" in @@ -268,67 +294,80 @@ module NetworkGui = struct let open Service.Proxy in let non_empty s = if s = "" then None else Some s in let opt_int_of_string s = try Some (int_of_string s) with _ -> None in - match form_data |> List.assoc_opt "proxy_enabled" with | None -> return None - | Some _ -> - let host_input = - form_data |> List.assoc "proxy_host" |> List.hd |> non_empty - in - let port_input = - form_data |> List.assoc "proxy_port" |> List.hd |> opt_int_of_string - in - let user_input = - form_data |> List.assoc "proxy_user" |> List.hd |> non_empty - in - let password_input = - form_data |> List.assoc "proxy_password" |> List.hd |> non_empty - in - let keep_password = - form_data |> List.assoc_opt "keep_password" |> Option.is_some - in - let password = - match (keep_password, current_proxy_opt) with - | (true, Some ({ host; port; credentials = Some { user; password } })) -> - if host_input = Some host && port_input = Some port && user_input = Some user then - (* Proxy configuration wasn't touched, password may be preserved. *) - Ok (Some password) - else - (* Proxy configuration was touched, demand new password to avoid - disclosing to untrusted server. *) - Error "Password needs to be provided when changing proxy configuration." - | (true, _) -> Error "Failure to retrieve proxy password. Please re-submit the form." - | _ -> Ok password_input - in - match host_input, port_input, user_input, password with - (* Configuration without credentials was submitted *) - | Some host, Some port, None, Ok None -> - return (Some (Service.Proxy.make host port)) - (* Configuration with credentials was submitted *) - | Some host, Some port, Some user, Ok password -> - return (Some (Service.Proxy.make ~user:user ~password:(Option.value ~default:"" password) host port)) - (* Configuration without user but with password was submitted *) - | _, _, None, Ok (Some _) -> - fail_with "A user is required if a password is provided" - (* Password retrieval error *) - | _, _, _, Error msg -> - fail_with msg - (* Incomplete server information *) - | _ -> - fail_with "A host and port are required to configure a proxy server" + | Some _ -> ( + let host_input = + form_data |> List.assoc "proxy_host" |> List.hd |> non_empty + in + let port_input = + form_data |> List.assoc "proxy_port" |> List.hd |> opt_int_of_string + in + let user_input = + form_data |> List.assoc "proxy_user" |> List.hd |> non_empty + in + let password_input = + form_data |> List.assoc "proxy_password" |> List.hd |> non_empty + in + let keep_password = + form_data |> List.assoc_opt "keep_password" |> Option.is_some + in + let password = + match (keep_password, current_proxy_opt) with + | true, Some { host; port; credentials = Some { user; password } } -> + if + host_input = Some host + && port_input = Some port + && user_input = Some user + then + (* Proxy configuration wasn't touched, password may be preserved. *) + Ok (Some password) + else + (* Proxy configuration was touched, demand new password to avoid + disclosing to untrusted server. *) + Error + "Password needs to be provided when changing proxy \ + configuration." + | true, _ -> + Error + "Failure to retrieve proxy password. Please re-submit the form." + | _ -> + Ok password_input + in + match (host_input, port_input, user_input, password) with + (* Configuration without credentials was submitted *) + | Some host, Some port, None, Ok None -> + return (Some (Service.Proxy.make host port)) + (* Configuration with credentials was submitted *) + | Some host, Some port, Some user, Ok password -> + return + (Some + (Service.Proxy.make ~user + ~password:(Option.value ~default:"" password) + host port + ) + ) + (* Configuration without user but with password was submitted *) + | _, _, None, Ok (Some _) -> + fail_with "A user is required if a password is provided" + (* Password retrieval error *) + | _, _, _, Error msg -> + fail_with msg + (* Incomplete server information *) + | _ -> + fail_with "A host and port are required to configure a proxy server" + ) (** Set static IP configuration on a service *) let update_static_ip service form_data = - let get_prop s = - form_data - |> List.assoc s - |> List.hd - in + let get_prop s = form_data |> List.assoc s |> List.hd in match form_data |> List.assoc_opt "static_ip_enabled" with | None -> - let%lwt () = Logs_lwt.err ~src:log_src - (fun m -> m "disabling static ip %s" (get_prop "static_ip_address")) + let%lwt () = + Logs_lwt.err ~src:log_src (fun m -> + m "disabling static ip %s" (get_prop "static_ip_address") + ) in let%lwt () = Connman.Service.set_dhcp_ipv4 service in let%lwt () = Connman.Service.set_nameservers service [] in @@ -337,60 +376,61 @@ module NetworkGui = struct let address = get_prop "static_ip_address" in let netmask = get_prop "static_ip_netmask" in let gateway = get_prop "static_ip_gateway" in - let nameservers = get_prop "static_ip_nameservers" |> String.split_on_char ',' |> List.map (String.trim) in - let%lwt () = Connman.Service.set_manual_ipv4 service ~address ~netmask ~gateway in + let nameservers = + get_prop "static_ip_nameservers" + |> String.split_on_char ',' + |> List.map String.trim + in + let%lwt () = + Connman.Service.set_manual_ipv4 service ~address ~netmask ~gateway + in let%lwt () = Connman.Service.set_nameservers service nameservers in return () - (** Connect to a service *) - let connect ~(connman:Connman.Manager.t) req = + let connect ~(connman : Connman.Manager.t) req = let%lwt form_data = urlencoded_pairs_of_body req in let passphrase = match form_data |> List.assoc_opt "passphrase" with | Some [ passphrase ] -> - Connman.Agent.Passphrase passphrase + Connman.Agent.Passphrase passphrase | _ -> - Connman.Agent.None + Connman.Agent.None in let%lwt service = with_service ~connman (param req "id") in - let%lwt () = Connman.Service.connect ~input:passphrase service in redirect' (Uri.of_string "/network") (** Update a service *) - let update ~(connman:Connman.Manager.t) req = + let update ~(connman : Connman.Manager.t) req = let%lwt form_data = urlencoded_pairs_of_body req in let%lwt service = with_service ~connman (param req "id") in - (* Static IP *) let%lwt () = update_static_ip service form_data in - (* Proxy *) let%lwt current_proxy = Manager.get_default_proxy connman in let%lwt () = match%lwt make_proxy current_proxy form_data with - | None -> Connman.Service.set_direct_proxy service - | Some proxy -> Connman.Service.set_manual_proxy service proxy + | None -> + Connman.Service.set_direct_proxy service + | Some proxy -> + Connman.Service.set_manual_proxy service proxy in - (* Grant time for changes to take effect and return to overview *) let%lwt () = Lwt_unix.sleep 0.5 in redirect' (Uri.of_string "/network") (** Remove a service **) - let remove ~(connman:Connman.Manager.t) req = + let remove ~(connman : Connman.Manager.t) req = let%lwt service = with_service ~connman (param req "id") in - (* Clear settings. *) let%lwt () = Connman.Service.set_direct_proxy service in let%lwt () = Connman.Service.set_nameservers service [] in let%lwt () = Connman.Service.set_dhcp_ipv4 service in - let%lwt () = Connman.Service.remove service in redirect' (Uri.of_string "/network") - let build ~(connman:Connman.Manager.t) app = + let build ~(connman : Connman.Manager.t) app = app |> get "/network" (overview ~connman) |> get "/network/:id" (details ~connman) @@ -400,98 +440,92 @@ module NetworkGui = struct |> get "/internet/status" (internet_status ~connman) end - module StatusGui = struct open Status_page - let shutdown () = - Util.run_cmd_no_stdout [|"halt"; "--poweroff"|] + let shutdown () = Util.run_cmd_no_stdout [| "halt"; "--poweroff" |] - let reboot () = - Util.run_cmd_no_stdout [|"reboot"|] + let reboot () = Util.run_cmd_no_stdout [| "reboot" |] let switch_slot rauc target_slot = - let%lwt () = Rauc.mark_active rauc target_slot in - reboot () + let%lwt () = Rauc.mark_active rauc target_slot in + reboot () let factory_reset systemd = - let%lwt () = Logs_lwt.info ~src:log_src (fun m -> - m "Enabling persistent data wipe..." - ) in - let%lwt () = Systemd.Manager.start_unit systemd "playos-wipe-persistent-data.service" in - let%lwt () = Logs_lwt.info ~src:log_src (fun m -> - m "Persistent data wipe is enabled, rebooting." - ) in + let%lwt () = + Logs_lwt.info ~src:log_src (fun m -> m "Enabling persistent data wipe...") + in + let%lwt () = + Systemd.Manager.start_unit systemd "playos-wipe-persistent-data.service" + in + let%lwt () = + Logs_lwt.info ~src:log_src (fun m -> + m "Persistent data wipe is enabled, rebooting." + ) + in reboot () - let get_status ~health_s ~(update_s:Update.state React.signal) ~rauc = - let health_state = health_s |> Lwt_react.S.value in - let update_state = update_s |> Lwt_react.S.value in - let%lwt booted_slot = Rauc.get_booted_slot rauc in - let%lwt rauc = - match update_state.process_state with - (* RAUC status is not meaningful while installing - https://github.com/rauc/rauc/issues/416 - *) - | Update.Installing _ -> - Lwt.return Status_page.Installing - | _ -> - Lwt_result.catch (fun () -> Rauc.get_status rauc) >|= - (Result.fold - ~ok:(fun (s) -> Status_page.Status s) - ~error:(fun (e) -> Status_page.Error (Printexc.to_string e)) - ) - in - { health = health_state - ; update = update_state - ; rauc - ; booted_slot = booted_slot - } |> return - - let exec_and_resp_ok f = (fun req -> - f req - >|= (fun _ -> `String "Ok") - >|= respond - ) + let get_status ~health_s ~(update_s : Update.state React.signal) ~rauc = + let health_state = health_s |> Lwt_react.S.value in + let update_state = update_s |> Lwt_react.S.value in + let%lwt booted_slot = Rauc.get_booted_slot rauc in + let%lwt rauc = + match update_state.process_state with + (* RAUC status is not meaningful while installing + https://github.com/rauc/rauc/issues/416 + *) + | Update.Installing _ -> + Lwt.return Status_page.Installing + | _ -> + Lwt_result.catch (fun () -> Rauc.get_status rauc) + >|= Result.fold + ~ok:(fun s -> Status_page.Status s) + ~error:(fun e -> Status_page.Error (Printexc.to_string e)) + in + { health = health_state; update = update_state; rauc; booted_slot } + |> return + + let exec_and_resp_ok f req = f req >|= (fun _ -> `String "Ok") >|= respond let build ~systemd ~health_s ~update_s ~rauc app = app - |> post "/system/shutdown" (exec_and_resp_ok (fun _ -> - shutdown () - )) - |> post "/system/reboot" (exec_and_resp_ok (fun _ -> - reboot () - )) - |> post "/system/factory-reset" (exec_and_resp_ok (fun _ -> - factory_reset systemd - )) - |> post "/system/switch/:slot" (exec_and_resp_ok (fun req -> - switch_slot rauc (param req "slot" |> Rauc.Slot.t_of_string) - )) + |> post "/system/shutdown" (exec_and_resp_ok (fun _ -> shutdown ())) + |> post "/system/reboot" (exec_and_resp_ok (fun _ -> reboot ())) + |> post "/system/factory-reset" + (exec_and_resp_ok (fun _ -> factory_reset systemd)) + |> post "/system/switch/:slot" + (exec_and_resp_ok (fun req -> + switch_slot rauc (param req "slot" |> Rauc.Slot.t_of_string) + ) + ) |> get "/status" (fun _req -> - let%lwt status = get_status ~update_s ~health_s ~rauc in - Lwt.return (page (Status_page.html status)) - ) + let%lwt status = get_status ~update_s ~health_s ~rauc in + Lwt.return (page (Status_page.html status)) + ) end module ChangelogGui = struct let build app = app |> get "/changelog" (fun _ -> - let%lwt changelog = Util.read_from_file log_src (Util.resource_path (Fpath.v "Changelog.html")) in - Lwt.return (page (Changelog_page.html changelog))) + let%lwt changelog = + Util.read_from_file log_src + (Util.resource_path (Fpath.v "Changelog.html")) + in + Lwt.return (page (Changelog_page.html changelog)) + ) end module LicensingGui = struct let build app = app |> get "/licensing" (fun _ -> - let%lwt p = Licensing_page.html in - Lwt.return (page p)) + let%lwt p = Licensing_page.html in + Lwt.return (page p) + ) end module RemoteMaintenanceGui = struct - let rec wait_until_zerotier_is_on () = match%lwt Zerotier.get_status () with | Ok _ -> @@ -503,29 +537,33 @@ module RemoteMaintenanceGui = struct let build ~systemd app = app |> post "/remote-maintenance/enable" (fun _ -> - let%lwt () = Systemd.Manager.start_unit systemd "zerotierone.service" in - with_timeout - { duration = 2.0 - ; on_timeout = fun () -> - let msg = "Timeout starting remote maintenance service." in - let%lwt () = Logs_lwt.err (fun m -> m "%s" msg) in - fail_with msg - } - wait_until_zerotier_is_on) - + let%lwt () = + Systemd.Manager.start_unit systemd "zerotierone.service" + in + with_timeout + { duration = 2.0 + ; on_timeout = + (fun () -> + let msg = "Timeout starting remote maintenance service." in + let%lwt () = Logs_lwt.err (fun m -> m "%s" msg) in + fail_with msg + ) + } + wait_until_zerotier_is_on + ) |> post "/remote-maintenance/disable" (fun _ -> - let%lwt () = Systemd.Manager.stop_unit systemd "zerotierone.service" in - redirect' (Uri.of_string "/info")) + let%lwt () = + Systemd.Manager.stop_unit systemd "zerotierone.service" + in + redirect' (Uri.of_string "/info") + ) end - let routes ~systemd ~health_s ~update_s ~rauc ~connman app = app |> middleware (static ()) |> middleware error_handling - |> get "/" (fun _ -> "/info" |> Uri.of_string |> redirect') - |> InfoGui.build |> NetworkGui.build ~connman |> LocalizationGui.build diff --git a/controller/server/gui.mli b/controller/server/gui.mli index 6e07f702..9b8bd836 100644 --- a/controller/server/gui.mli +++ b/controller/server/gui.mli @@ -1,8 +1,8 @@ val start : - port : int - -> systemd : Systemd.Manager.t - -> health_s : Health.state Lwt_react.S.t - -> update_s : Update.state Lwt_react.S.t - -> rauc : Rauc.t - -> connman : Connman.Manager.t + port:int + -> systemd:Systemd.Manager.t + -> health_s:Health.state Lwt_react.S.t + -> update_s:Update.state Lwt_react.S.t + -> rauc:Rauc.t + -> connman:Connman.Manager.t -> unit Lwt.t diff --git a/controller/server/health.ml b/controller/server/health.ml index 4b1c1115..f58bf518 100644 --- a/controller/server/health.ml +++ b/controller/server/health.ml @@ -11,63 +11,59 @@ type state = [@@deriving sexp] let rec run ~systemd ~rauc ~set_state = - let set state = set_state state; run ~systemd ~rauc ~set_state state in + let set state = + set_state state ; + run ~systemd ~rauc ~set_state state + in function - | Pending -> - begin + | Pending -> ( (* Wait for 30 seconds *) let%lwt () = Lwt_unix.sleep 30.0 in - let open Systemd in - (* Check what system state as systemd reports *) match%lwt Systemd.Manager.get_system_state systemd with - | Manager.Running -> - (* and set system as good *) - set MarkingAsGood - + (* and set system as good *) + set MarkingAsGood | Manager.Starting -> - (* Systemd is still starting up some stuff. We wait. Systemd will handle job timeout itself and change state in finite time. *) - set Pending - + (* Systemd is still starting up some stuff. We wait. Systemd will handle job timeout itself and change state in finite time. *) + set Pending | system_state -> - (* or bad... *) - Bad (Format.sprintf "system state is %s" + (* or bad... *) + Bad + (Format.sprintf "system state is %s" (system_state - |> Manager.sexp_of_system_state - |> Sexplib.Sexp.to_string_hum - )) - |> set - - end - - | MarkingAsGood -> - (* Mark currently booted slot as "good" *) - begin + |> Manager.sexp_of_system_state + |> Sexplib.Sexp.to_string_hum + ) + ) + |> set + ) + | MarkingAsGood -> ( + (* Mark currently booted slot as "good" *) match%lwt - Lwt_result.catch - (fun () -> - Rauc.get_booted_slot rauc - >>= Rauc.mark_good rauc - ) + Lwt_result.catch (fun () -> + Rauc.get_booted_slot rauc >>= Rauc.mark_good rauc + ) with - | Ok () -> set Good - | Error exn -> set (Bad ("Failed to mark system good: " ^ (Printexc.to_string exn))) - end - + | Ok () -> + set Good + | Error exn -> + set (Bad ("Failed to mark system good: " ^ Printexc.to_string exn)) + ) | Good -> - (* this thread should not terminate, thus create a never ending task. - - TODO: do periodic system checks - *) - Lwt.task () |> fst + (* this thread should not terminate, thus create a never ending task. + TODO: do periodic system checks + *) + Lwt.task () |> fst | Bad msg -> - let%lwt () = Logs_lwt.err ~src:log_src (fun m -> m "system health bad: %s" msg) in - (* TODO: mark system bad and exit *) - set Pending + let%lwt () = + Logs_lwt.err ~src:log_src (fun m -> m "system health bad: %s" msg) + in + (* TODO: mark system bad and exit *) + set Pending let start ~systemd ~rauc = let state_s, set_state = Lwt_react.S.create Pending in - state_s, run ~systemd ~rauc ~set_state Pending + (state_s, run ~systemd ~rauc ~set_state Pending) diff --git a/controller/server/health.mli b/controller/server/health.mli index 54e13f7a..23a21882 100644 --- a/controller/server/health.mli +++ b/controller/server/health.mli @@ -7,6 +7,7 @@ type state = [@@deriving sexp] (** Start system health monitor *) -val start : systemd : Systemd.Manager.t - -> rauc : Rauc.t +val start : + systemd:Systemd.Manager.t + -> rauc:Rauc.t -> state Lwt_react.signal * unit Lwt.t diff --git a/controller/server/info.ml b/controller/server/info.ml index 136e1d2d..6e50d0ca 100644 --- a/controller/server/info.ml +++ b/controller/server/info.ml @@ -3,12 +3,12 @@ open Lwt let log_src = Logs.Src.create "info" type t = - { app: string - ; version: string + { app : string + ; version : string ; update_url : string ; kiosk_url : string - ; machine_id: string - ; zerotier_address: string option + ; machine_id : string + ; zerotier_address : string option ; local_time : string } @@ -17,14 +17,10 @@ include Config.System (** Break up a string into groups of size n *) let rec grouped n s = let l = String.length s in - if n <= 0 then - invalid_arg "Group size must be above 0" - else if l = 0 then - [] - else if l <= n then - [s] - else - List.cons (String.sub s 0 n) (grouped n (String.sub s n (l - n))) + if n <= 0 then invalid_arg "Group size must be above 0" + else if l = 0 then [] + else if l <= n then [ s ] + else List.cons (String.sub s 0 n) (grouped n (String.sub s n (l - n))) let get () = let%lwt machine_id = @@ -33,20 +29,25 @@ let get () = >|= String.concat "-" in let%lwt zerotier_address = - (match%lwt Zerotier.get_status () with - | Ok status -> Some status.address |> return - | Error err -> - let%lwt () = Logs_lwt.err (fun m -> m "Error getting zerotier status: %s" (Printexc.to_string err)) in - return None - ) + match%lwt Zerotier.get_status () with + | Ok status -> + Some status.address |> return + | Error err -> + let%lwt () = + Logs_lwt.err (fun m -> + m "Error getting zerotier status: %s" (Printexc.to_string err) + ) + in + return None in let%lwt timedate_daemon = Timedate.daemon () in let%lwt current_time = Timedate.get_current_time timedate_daemon in let%lwt timezone = - (match%lwt Timedate.get_active_timezone timedate_daemon with - | Some tz -> return tz - | None -> return "No timezone" - ) + match%lwt Timedate.get_active_timezone timedate_daemon with + | Some tz -> + return tz + | None -> + return "No timezone" in let local_time = current_time ^ " (" ^ timezone ^ ")" in { app = "PlayOS Controller" diff --git a/controller/server/logging.ml b/controller/server/logging.ml index f1bec9c3..8b49ed30 100644 --- a/controller/server/logging.ml +++ b/controller/server/logging.ml @@ -7,23 +7,28 @@ let reporter () = let buf_fmt ~like = let b = Buffer.create 512 in - Fmt.with_buffer ~like b, - fun () -> let m = Buffer.contents b in Buffer.reset b; m + ( Fmt.with_buffer ~like b + , fun () -> + let m = Buffer.contents b in + Buffer.reset b ; m + ) in let app, app_flush = buf_fmt ~like:Fmt.stdout in let dst, dst_flush = buf_fmt ~like:Fmt.stderr in let reporter = Logs_fmt.reporter ~app ~dst () in let report src level ~over k msgf = let k () = - let write () = match level with - | Logs.App -> Lwt_io.write Lwt_io.stdout (app_flush ()) - | _ -> Lwt_io.write Lwt_io.stderr (dst_flush ()) + let write () = + match level with + | Logs.App -> + Lwt_io.write Lwt_io.stdout (app_flush ()) + | _ -> + Lwt_io.write Lwt_io.stderr (dst_flush ()) in - let unblock () = over (); Lwt.return_unit in - Lwt.finalize write unblock |> Lwt.ignore_result; + let unblock () = over () ; Lwt.return_unit in + Lwt.finalize write unblock |> Lwt.ignore_result ; k () in - reporter.Logs.report src level ~over:(fun () -> ()) k msgf; + reporter.Logs.report src level ~over:(fun () -> ()) k msgf in - { Logs.report = report } - + { Logs.report } diff --git a/controller/server/network.ml b/controller/server/network.ml index 5c5d97f1..a336812a 100644 --- a/controller/server/network.ml +++ b/controller/server/network.ml @@ -5,71 +5,67 @@ open Protocol_conv_jsonm let log_src = Logs.Src.create "network" let enable_and_scan_wifi_devices ~connman = - Lwt_result.catch - (fun () -> - begin - let open Connman in - (* Get all available technolgies *) - let%lwt technologies = Manager.get_technologies connman in - - (* enable all wifi devices *) - let%lwt () = - technologies - |> List.filter (fun (t:Technology.t) -> - t.type' = Technology.Wifi && not t.powered) - |> List.map (Technology.enable) - |> Lwt.join - in - - (* and start a scan. *) - let%lwt () = - technologies - |> List.filter (fun (t:Technology.t) -> t.type' = Technology.Wifi) - |> List.map (Technology.scan) - |> Lwt.join - in - - return_unit - end + Lwt_result.catch (fun () -> + (let open Connman in + (* Get all available technolgies *) + let%lwt technologies = Manager.get_technologies connman in + (* enable all wifi devices *) + let%lwt () = + technologies + |> List.filter (fun (t : Technology.t) -> + t.type' = Technology.Wifi && not t.powered + ) + |> List.map Technology.enable + |> Lwt.join + in + (* and start a scan. *) + let%lwt () = + technologies + |> List.filter (fun (t : Technology.t) -> t.type' = Technology.Wifi) + |> List.map Technology.scan + |> Lwt.join + in + return_unit + ) (* Add a timeout to scan *) - |> (fun p -> [p; Lwt_unix.timeout 30.0] |> Lwt.pick) - ) - + |> fun p -> [ p; Lwt_unix.timeout 30.0 ] |> Lwt.pick + ) let init ~connman = - let%lwt () = Logs_lwt.info ~src:log_src - (fun m -> m "initializing network connections") in - + let%lwt () = + Logs_lwt.info ~src:log_src (fun m -> m "initializing network connections") + in match%lwt enable_and_scan_wifi_devices ~connman with - | Ok () -> - Lwt_result.return () - + Lwt_result.return () | Error exn -> - let%lwt () = Logs_lwt.warn ~src:log_src - (fun m -> m "enabling and scanning wifi failed: %s, %s" - (OBus_error.name exn) - (Printexc.to_string exn)) - in - Lwt_result.fail exn + let%lwt () = + Logs_lwt.warn ~src:log_src (fun m -> + m "enabling and scanning wifi failed: %s, %s" (OBus_error.name exn) + (Printexc.to_string exn) + ) + in + Lwt_result.fail exn module Interface = struct - type t = - { index: int - ; name: string - ; address: string - ; link_type: string + { index : int + ; name : string + ; address : string + ; link_type : string } [@@deriving sexp, protocol ~driver:(module Jsonm)] let to_json i = - Ezjsonm.(dict [ - "index", i.index |> int - ; "name", i.name |> string - ; "address", i.address |> string - ; "link_type", i.link_type |> string - ] |> value) + Ezjsonm.( + dict + [ ("index", i.index |> int) + ; ("name", i.name |> string) + ; ("address", i.address |> string) + ; ("link_type", i.link_type |> string) + ] + |> value + ) let of_json j = let dict = Ezjsonm.get_dict j in @@ -80,12 +76,11 @@ module Interface = struct } let get_all () = - let command = "/run/current-system/sw/bin/ip", [| "ip"; "-j"; "link" |] in + let command = ("/run/current-system/sw/bin/ip", [| "ip"; "-j"; "link" |]) in let%lwt json = Lwt_process.pread command in json |> Ezjsonm.from_string |> Ezjsonm.value |> Ezjsonm.get_list of_json |> return - end diff --git a/controller/server/network.mli b/controller/server/network.mli index 9613f9b6..08f4db62 100644 --- a/controller/server/network.mli +++ b/controller/server/network.mli @@ -1,17 +1,15 @@ open Protocol_conv_jsonm (** Initialize Network connectivity *) -val init - : connman : Connman.Manager.t - -> (unit,exn) Lwt_result.t +val init : connman:Connman.Manager.t -> (unit, exn) Lwt_result.t module Interface : sig (** Network interface *) type t = - { index: int - ; name: string - ; address: string - ; link_type: string + { index : int + ; name : string + ; address : string + ; link_type : string } [@@deriving sexp, protocol ~driver:(module Jsonm)] @@ -22,5 +20,4 @@ module Interface : sig This uses the Linux `ip` utility. *) val get_all : unit -> t list Lwt.t - end diff --git a/controller/server/rauc_service.ml b/controller/server/rauc_service.ml index 3d2bbe07..c63cea22 100644 --- a/controller/server/rauc_service.ml +++ b/controller/server/rauc_service.ml @@ -1,38 +1,40 @@ module type S = sig - (** [get_status unit] returns current RAUC status *) - val get_status : unit -> Rauc.status Lwt.t + (** [get_status unit] returns current RAUC status *) + val get_status : unit -> Rauc.status Lwt.t - (** [get_booted_slot unit] returns the currently booted slot *) - val get_booted_slot : unit -> Rauc.Slot.t Lwt.t + (** [get_booted_slot unit] returns the currently booted slot *) + val get_booted_slot : unit -> Rauc.Slot.t Lwt.t - (** [mark_good slot] marks the slot [slot] as good *) - val mark_good : Rauc.Slot.t -> unit Lwt.t + (** [mark_good slot] marks the slot [slot] as good *) + val mark_good : Rauc.Slot.t -> unit Lwt.t - (** [get_primary unit] returns current primary slot, if any *) - val get_primary : unit -> Rauc.Slot.t option Lwt.t + (** [get_primary unit] returns current primary slot, if any *) + val get_primary : unit -> Rauc.Slot.t option Lwt.t - (** [install source] install the bundle at path [source] *) - val install : string -> unit Lwt.t + (** [install source] install the bundle at path [source] *) + val install : string -> unit Lwt.t end -module RaucOBus(OBusRef: sig val peer: Rauc.t end): S = struct - let t = OBusRef.peer +module RaucOBus (OBusRef : sig + val peer : Rauc.t +end) : S = struct + let t = OBusRef.peer - let get_status () : Rauc.status Lwt.t = - let () = Printf.printf "%s" "Getting status" in - Rauc.get_status t + let get_status () : Rauc.status Lwt.t = + let () = Printf.printf "%s" "Getting status" in + Rauc.get_status t - let get_booted_slot () : Rauc.Slot.t Lwt.t = - Rauc.get_booted_slot t + let get_booted_slot () : Rauc.Slot.t Lwt.t = Rauc.get_booted_slot t - let mark_good = Rauc.mark_good t + let mark_good = Rauc.mark_good t - let get_primary () : Rauc.Slot.t option Lwt.t = - Rauc.get_primary t + let get_primary () : Rauc.Slot.t option Lwt.t = Rauc.get_primary t - let install : string -> unit Lwt.t = - Rauc.install t + let install : string -> unit Lwt.t = Rauc.install t end let build_module rauc_peer : (module S) = - (module RaucOBus (struct let peer = rauc_peer end)) + (module RaucOBus (struct + let peer = rauc_peer + end) +) diff --git a/controller/server/rauc_service.mli b/controller/server/rauc_service.mli index 2be4d0db..a27615b4 100644 --- a/controller/server/rauc_service.mli +++ b/controller/server/rauc_service.mli @@ -1,18 +1,18 @@ module type S = sig - (** [get_status unit] returns current RAUC status *) - val get_status : unit -> Rauc.status Lwt.t + (** [get_status unit] returns current RAUC status *) + val get_status : unit -> Rauc.status Lwt.t - (** [get_booted_slot unit] returns the currently booted slot *) - val get_booted_slot : unit -> Rauc.Slot.t Lwt.t + (** [get_booted_slot unit] returns the currently booted slot *) + val get_booted_slot : unit -> Rauc.Slot.t Lwt.t - (** [mark_good slot] marks the slot [slot] as good *) - val mark_good : Rauc.Slot.t -> unit Lwt.t + (** [mark_good slot] marks the slot [slot] as good *) + val mark_good : Rauc.Slot.t -> unit Lwt.t - (** [get_primary unit] returns current primary slot, if any *) - val get_primary : unit -> Rauc.Slot.t option Lwt.t + (** [get_primary unit] returns current primary slot, if any *) + val get_primary : unit -> Rauc.Slot.t option Lwt.t - (** [install source] install the bundle at path [source] *) - val install : string -> unit Lwt.t + (** [install source] install the bundle at path [source] *) + val install : string -> unit Lwt.t end val build_module : Rauc.t -> (module S) diff --git a/controller/server/server.ml b/controller/server/server.ml index b9532b68..7f8f8c7c 100644 --- a/controller/server/server.ml +++ b/controller/server/server.ml @@ -1,109 +1,94 @@ open Lwt let main debug port = - Logs.set_reporter (Logging.reporter ()); - - if debug then - Logs.set_level (Some Logs.Debug) - else - Logs.set_level (Some Logs.Info); - + Logs.set_reporter (Logging.reporter ()) ; + if debug then Logs.set_level (Some Logs.Debug) + else Logs.set_level (Some Logs.Info) ; let%lwt server_info = Info.get () in - let%lwt () = - Logs_lwt.info (fun m -> m "PlayOS Controller Daemon (%s)" server_info.version) + Logs_lwt.info (fun m -> + m "PlayOS Controller Daemon (%s)" server_info.version + ) in - (* Connect with systemd *) let%lwt systemd = Systemd.Manager.connect () in - (* Connect with RAUC *) let%lwt rauc = Rauc.daemon () in - let health_s, health_p = Health.start ~systemd ~rauc in - (* Log changes in health state *) let%lwt () = Lwt_react.S.( - map_s (fun state -> Logs_lwt.info (fun m -> m "health: %s" - (state - |> Health.sexp_of_state - |> Sexplib.Sexp.to_string_hum) - )) health_s + map_s + (fun state -> + Logs_lwt.info (fun m -> + m "health: %s" + (state |> Health.sexp_of_state |> Sexplib.Sexp.to_string_hum) + ) + ) + health_s >|= keep ) in - (* Connect with ConnMan *) let%lwt connman = Connman.Manager.connect () in - (* Start the update mechanism *) let update_s, update_p = Update.start ~connman ~rauc in - (* Log changes in update mechanism state *) let%lwt () = Lwt_react.S.( - map_s (fun state -> Logs_lwt.info (fun m -> m "update mechanism: %s" - (state - |> Update.sexp_of_state - |> Sexplib.Sexp.to_string_hum) - )) update_s + map_s + (fun state -> + Logs_lwt.info (fun m -> + m "update mechanism: %s" + (state |> Update.sexp_of_state |> Sexplib.Sexp.to_string_hum) + ) + ) + update_s >|= keep ) in - (* Start the GUI *) - let gui_p = - Gui.start - ~systemd - ~port - ~rauc - ~connman - ~update_s - ~health_s - in - + let gui_p = Gui.start ~systemd ~port ~rauc ~connman ~update_s ~health_s in let%lwt () = (* Initialize Network, parallel to starting server *) - begin - match%lwt Network.init ~connman with - | Ok () -> + ( match%lwt Network.init ~connman with + | Ok () -> return_unit - | Error exn -> - Logs_lwt.warn (fun m -> m "network initialization failed: %s" (Printexc.to_string exn)) - end - - <&> Lwt.pick [ - (* Make sure all threads run forever. *) - gui_p (* GUI *) - ; update_p (* Update mechanism *) - ; health_p (* Health monitoring *) - ] - - + | Error exn -> + Logs_lwt.warn (fun m -> + m "network initialization failed: %s" (Printexc.to_string exn) + ) + ) + <&> Lwt.pick + [ (* Make sure all threads run forever. *) + gui_p (* GUI *) + ; update_p (* Update mechanism *) + ; health_p (* Health monitoring *) + ] in - Logs_lwt.info (fun m -> m "terminating") let () = let open Cmdliner in - let debug_a = Arg.(flag - (info ~doc:"Enable debug output." ["d"; "debug"]) - |> value) + let debug_a = + Arg.(flag (info ~doc:"Enable debug output." [ "d"; "debug" ]) |> value) in - let port_a = Arg.(opt int 3333 - (info ~doc:"Port on which to start gui (http server)." ~docv:"PORT" ["p"; "port"]) - |> value) + let port_a = + Arg.( + opt int 3333 + (info ~doc:"Port on which to start gui (http server)." ~docv:"PORT" + [ "p"; "port" ] + ) + |> value + ) in let main_t = - Term.( - const main - $ debug_a - $ port_a - |> app (const Lwt_main.run) - ) + Term.(const main $ debug_a $ port_a |> app (const Lwt_main.run)) in main_t - |> Cmd.v (Cmd.info ~doc:"PlayOS Controller" ~version:Info.version "playos-controller") + |> Cmd.v + (Cmd.info ~doc:"PlayOS Controller" ~version:Info.version + "playos-controller" + ) |> Cmd.eval |> ignore diff --git a/controller/server/update.ml b/controller/server/update.ml index 005fb599..f00a7925 100644 --- a/controller/server/update.ml +++ b/controller/server/update.ml @@ -7,23 +7,21 @@ let log_src = Logs.Src.create "update" (** Type containing version information *) type version_info = - {(* the latest available version *) - latest : Semver.t - - (* version of currently booted system *) - ; booted : Semver.t - - (* version of inactive system *) + { (* the latest available version *) + latest : Semver.t (* version of currently booted system *) + ; booted : Semver.t (* version of inactive system *) ; inactive : Semver.t } let sexp_of_version_info v = - let open Sexplib in - Sexp.(List [ - List [Atom "latest"; Atom (Semver.to_string v.latest)]; - List [Atom "booted"; Atom (Semver.to_string v.booted)]; - List [Atom "inactive"; Atom (Semver.to_string v.inactive)]; - ]) + let open Sexplib in + Sexp.( + List + [ List [ Atom "latest"; Atom (Semver.to_string v.latest) ] + ; List [ Atom "booted"; Atom (Semver.to_string v.booted) ] + ; List [ Atom "inactive"; Atom (Semver.to_string v.inactive) ] + ] + ) type update_error = | ErrorGettingVersionInfo of string @@ -40,8 +38,7 @@ type system_status = | UpdateError of update_error [@@deriving sexp_of] -type sleep_duration = float (* seconds *) -[@@deriving sexp_of] +type sleep_duration = float (* seconds *) [@@deriving sexp_of] (** State of update mechanism *) type process_state = @@ -51,22 +48,24 @@ type process_state = | Installing of string [@@deriving sexp_of] -type state = { - version_info: version_info option; - system_status: system_status; - process_state: process_state -} +type state = + { version_info : version_info option + ; system_status : system_status + ; process_state : process_state + } [@@deriving sexp_of] -type config = { - error_backoff_duration: sleep_duration; - check_for_updates_interval: sleep_duration; -} +type config = + { error_backoff_duration : sleep_duration + ; check_for_updates_interval : sleep_duration + } module type ServiceDeps = sig - module ClientI: Update_client.S - module RaucI: Rauc_service.S - val config : config + module ClientI : Update_client.S + + module RaucI : Rauc_service.S + + val config : config end module type UpdateService = sig @@ -77,25 +76,23 @@ end let evaluate_version_info current_primary booted_slot version_info = (* Compare latest available version to version booted. *) - let up_to_date_with_latest v = Semver.compare v version_info.latest >=0 in + let up_to_date_with_latest v = Semver.compare v version_info.latest >= 0 in let booted_up_to_date = up_to_date_with_latest version_info.booted in let inactive_up_to_date = up_to_date_with_latest version_info.inactive in - if booted_up_to_date && inactive_up_to_date then - (* Should not happen during the automatic update process (one partition must - always be older than latest upstream), but can happen if e.g. a newer - version is manually installed into one of the slots. *) + (* Should not happen during the automatic update process (one partition must + always be older than latest upstream), but can happen if e.g. a newer + version is manually installed into one of the slots. *) UpToDate else if booted_up_to_date || inactive_up_to_date then match current_primary with | Some primary_slot -> - if booted_up_to_date then - (* Don't care if inactive can be updated. I.e. Only update the inactive - partition once the booted partition is outdated. This results in - always two versions being available on the machine. *) - UpToDate - else - if booted_slot = primary_slot then + if booted_up_to_date then + (* Don't care if inactive can be updated. I.e. Only update the inactive + partition once the booted partition is outdated. This results in + always two versions being available on the machine. *) + UpToDate + else if booted_slot = primary_slot then (* Inactive is up to date while booted is out of date, but booted was specifically selected for boot *) OutOfDateVersionSelected @@ -104,183 +101,182 @@ let evaluate_version_info current_primary booted_slot version_info = primary, we should reboot into the primary *) RebootRequired | None -> - (* All systems bad; suggest reinstallation *) - ReinstallRequired - - else - NeedsUpdate - + (* All systems bad; suggest reinstallation *) + ReinstallRequired + else NeedsUpdate (** Helper to parse semver from string or fail *) let semver_of_string string = - let trimmed_string = String.trim string - in + let trimmed_string = String.trim string in match Semver.of_string trimmed_string with | None -> - failwith - (Format.sprintf "could not parse version (version string: %s)" string) + failwith + (Format.sprintf "could not parse version (version string: %s)" string) | Some version -> - version - -let initial_state = { - version_info = None; - system_status = UpToDate; (* start with assuming a good state *) - process_state = GettingVersionInfo; -} + version -module Make(Deps : ServiceDeps) : UpdateService = struct - open Deps +let initial_state = + { version_info = None + ; system_status = UpToDate + ; (* start with assuming a good state *) + process_state = GettingVersionInfo + } - (** Get version information *) - let get_version_info () = - let%lwt latest = ClientI.get_latest_version () >|= semver_of_string in - let%lwt rauc_status = RaucI.get_status () in +module Make (Deps : ServiceDeps) : UpdateService = struct + open Deps - let system_a_version = rauc_status.a.version |> semver_of_string in - let system_b_version = rauc_status.b.version |> semver_of_string in + (** Get version information *) + let get_version_info () = + let%lwt latest = ClientI.get_latest_version () >|= semver_of_string in + let%lwt rauc_status = RaucI.get_status () in + let system_a_version = rauc_status.a.version |> semver_of_string in + let system_b_version = rauc_status.b.version |> semver_of_string in + match%lwt RaucI.get_booted_slot () with + | SystemA -> + { latest; booted = system_a_version; inactive = system_b_version } + |> return + | SystemB -> + { latest; booted = system_b_version; inactive = system_a_version } + |> return - match%lwt RaucI.get_booted_slot () with - | SystemA -> - { latest = latest - ; booted = system_a_version - ; inactive = system_b_version - } - |> return - | SystemB -> - { latest = latest - ; booted = system_b_version - ; inactive = system_a_version - } - |> return + (* Update mechanism process *) -(* Update mechanism process *) - (** Perform a single state transition from given state + (** Perform a single state transition from given state Note: the action performed depends _only_ on the input state.process_state. *) - let run_step (state:state) : state Lwt.t = - match (state.process_state) with - | GettingVersionInfo -> + let run_step (state : state) : state Lwt.t = + match state.process_state with + | GettingVersionInfo -> ( (* get version information and decide what to do *) - let%lwt resp = Lwt_result.catch (fun () -> - let%lwt slot_primary = RaucI.get_primary () in - let%lwt slot_booted = RaucI.get_booted_slot () in - let%lwt vsn_resp = get_version_info () in - return (slot_primary, slot_booted, vsn_resp) - ) in - (match resp with - | Ok (slot_p, slot_b, version_info) -> - let system_status = evaluate_version_info slot_p slot_b version_info in - let next_proc_state = match system_status with - | NeedsUpdate -> Downloading (Semver.to_string version_info.latest) - | _ -> Sleeping (config.check_for_updates_interval) - in - return { - process_state = next_proc_state; - version_info = Some version_info; - system_status = system_status - } - | Error exn -> - let exn_str = Printexc.to_string exn in - let%lwt () = Logs_lwt.err ~src:log_src - (fun m -> m "failed to get version information: %s" exn_str) - in - return { - process_state = Sleeping (config.error_backoff_duration); - (* unsetting version_info to indicate we are unclear about - current system state *) - version_info = None; - system_status = UpdateError (ErrorGettingVersionInfo exn_str); - } - ) - - | Sleeping duration -> + let%lwt resp = + Lwt_result.catch (fun () -> + let%lwt slot_primary = RaucI.get_primary () in + let%lwt slot_booted = RaucI.get_booted_slot () in + let%lwt vsn_resp = get_version_info () in + return (slot_primary, slot_booted, vsn_resp) + ) + in + match resp with + | Ok (slot_p, slot_b, version_info) -> + let system_status = + evaluate_version_info slot_p slot_b version_info + in + let next_proc_state = + match system_status with + | NeedsUpdate -> + Downloading (Semver.to_string version_info.latest) + | _ -> + Sleeping config.check_for_updates_interval + in + return + { process_state = next_proc_state + ; version_info = Some version_info + ; system_status + } + | Error exn -> + let exn_str = Printexc.to_string exn in + let%lwt () = + Logs_lwt.err ~src:log_src (fun m -> + m "failed to get version information: %s" exn_str + ) + in + return + { process_state = Sleeping config.error_backoff_duration + ; (* unsetting version_info to indicate we are unclear about + current system state *) + version_info = None + ; system_status = UpdateError (ErrorGettingVersionInfo exn_str) + } + ) + | Sleeping duration -> let%lwt () = Lwt_unix.sleep duration in - return {state with process_state = GettingVersionInfo} - - | Downloading version -> + return { state with process_state = GettingVersionInfo } + | Downloading version -> ( (* download latest version *) - (match%lwt Lwt_result.catch (fun () -> ClientI.download version) with - | Ok bundle_path -> - return {state with process_state = Installing bundle_path} - | Error exn -> + match%lwt Lwt_result.catch (fun () -> ClientI.download version) with + | Ok bundle_path -> + return { state with process_state = Installing bundle_path } + | Error exn -> let exn_str = Printexc.to_string exn in - let%lwt () = Logs_lwt.err ~src:log_src - (fun m -> m "failed to download RAUC bundle: %s" exn_str) + let%lwt () = + Logs_lwt.err ~src:log_src (fun m -> + m "failed to download RAUC bundle: %s" exn_str + ) in - return { state with - process_state = Sleeping config.error_backoff_duration; - system_status = UpdateError (ErrorDownloading exn_str); - } - ) - - | Installing bundle_path -> + return + { state with + process_state = Sleeping config.error_backoff_duration + ; system_status = UpdateError (ErrorDownloading exn_str) + } + ) + | Installing bundle_path -> ( (* install bundle via RAUC *) - (match%lwt Lwt_result.catch (fun () -> RaucI.install bundle_path) with - | Ok () -> - let%lwt () = Logs_lwt.info - (fun m -> m "succesfully installed update (%s)" bundle_path) - in - return { state with - (* unsetting version_info, because it is now stale *) - version_info = None; - (* going back to GettingVersionInfo to update version_info *) - process_state = GettingVersionInfo; - } - | Error exn -> - let () = try Sys.remove bundle_path with - | _ -> () - in - let exn_str = Printexc.to_string exn in - let%lwt () = - Logs_lwt.err ~src:log_src - (fun m -> m "failed to install RAUC bundle: %s" exn_str) - in - return { state with - process_state = Sleeping config.error_backoff_duration; - system_status = UpdateError (ErrorInstalling exn_str); - } - ) - - let rec run_rec set_state state = - let%lwt next_state = run_step state in - set_state next_state; - run_rec set_state next_state - - let run set_state = run_rec set_state initial_state + match%lwt Lwt_result.catch (fun () -> RaucI.install bundle_path) with + | Ok () -> + let%lwt () = + Logs_lwt.info (fun m -> + m "succesfully installed update (%s)" bundle_path + ) + in + return + { state with + (* unsetting version_info, because it is now stale *) + version_info = None + ; (* going back to GettingVersionInfo to update version_info *) + process_state = GettingVersionInfo + } + | Error exn -> + let () = try Sys.remove bundle_path with _ -> () in + let exn_str = Printexc.to_string exn in + let%lwt () = + Logs_lwt.err ~src:log_src (fun m -> + m "failed to install RAUC bundle: %s" exn_str + ) + in + return + { state with + process_state = Sleeping config.error_backoff_duration + ; system_status = UpdateError (ErrorInstalling exn_str) + } + ) + + let rec run_rec set_state state = + let%lwt next_state = run_step state in + set_state next_state ; + run_rec set_state next_state + + let run set_state = run_rec set_state initial_state end -let default_config : config = { - error_backoff_duration = 30.0; - check_for_updates_interval = (1. *. 60. *. 60.) -} - -let build_deps ~connman ~(rauc : Rauc.t) : - (module ServiceDeps) Lwt.t = +let default_config : config = + { error_backoff_duration = 30.0 + ; check_for_updates_interval = 1. *. 60. *. 60. + } +let build_deps ~connman ~(rauc : Rauc.t) : (module ServiceDeps) Lwt.t = let config = default_config in let raucI = Rauc_service.build_module rauc in let clientI = Update_client.build_module connman in - let module Deps = struct let config = config + module RaucI = (val raucI) + module ClientI = (val clientI) end in - Lwt.return (module Deps : ServiceDeps) let start ~connman ~(rauc : Rauc.t) = let state_s, set_state = Lwt_react.S.create initial_state in - let () = Logs.info ~src:log_src - (fun m -> m "update URL: %s" Config.System.update_url) in - - let service = begin - let%lwt deps = build_deps ~connman ~rauc in - let module UpdateServiceI = Make(val deps) in - UpdateServiceI.run set_state - end in - + let () = + Logs.info ~src:log_src (fun m -> m "update URL: %s" Config.System.update_url) + in + let service = + let%lwt deps = build_deps ~connman ~rauc in + let module UpdateServiceI = Make ((val deps)) in + UpdateServiceI.run set_state + in let () = Logs.info ~src:log_src (fun m -> m "Started") in (state_s, service) diff --git a/controller/server/update.mli b/controller/server/update.mli index 80e0479e..38bfd9fc 100644 --- a/controller/server/update.mli +++ b/controller/server/update.mli @@ -1,12 +1,8 @@ (** Type containing version information. *) type version_info = - {(* the latest available version *) - latest : Semver.t - - (* version of currently booted system *) - ; booted : Semver.t - - (* version of inactive system *) + { (* the latest available version *) + latest : Semver.t (* version of currently booted system *) + ; booted : Semver.t (* version of inactive system *) ; inactive : Semver.t } [@@deriving sexp_of] @@ -26,8 +22,7 @@ type system_status = | UpdateError of update_error [@@deriving sexp_of] -type sleep_duration = float (* seconds *) -[@@deriving sexp_of] +type sleep_duration = float (* seconds *) [@@deriving sexp_of] (** State of update mechanism *) type process_state = @@ -37,25 +32,26 @@ type process_state = | Installing of string [@@deriving sexp_of] -type state = { - version_info: version_info option; - system_status: system_status; - process_state: process_state -} +type state = + { version_info : version_info option + ; system_status : system_status + ; process_state : process_state + } [@@deriving sexp_of] -type config = { - (* time to sleep in seconds until retrying after a (Curl/HTTP) error *) - error_backoff_duration: sleep_duration; - - (* time to sleep in seconds between checking for available updates *) - check_for_updates_interval: sleep_duration; -} +type config = + { (* time to sleep in seconds until retrying after a (Curl/HTTP) error *) + error_backoff_duration : sleep_duration + ; (* time to sleep in seconds between checking for available updates *) + check_for_updates_interval : sleep_duration + } module type ServiceDeps = sig - module ClientI: Update_client.S - module RaucI: Rauc_service.S - val config : config + module ClientI : Update_client.S + + module RaucI : Rauc_service.S + + val config : config end (* exposed for unit testing purposes *) @@ -72,4 +68,7 @@ module Make (_ : ServiceDeps) : UpdateService (* top-level entrypoint that uses global Config.System and initializes all the dependencies *) -val start : connman:Connman.Manager.t -> rauc:Rauc.t -> state Lwt_react.signal * unit Lwt.t +val start : + connman:Connman.Manager.t + -> rauc:Rauc.t + -> state Lwt_react.signal * unit Lwt.t diff --git a/controller/server/update_client.ml b/controller/server/update_client.ml index 31c84ab2..99f7752e 100644 --- a/controller/server/update_client.ml +++ b/controller/server/update_client.ml @@ -1,84 +1,98 @@ open Lwt module type S = sig - (* download bundle version and return the file system path *) - val download : string -> string Lwt.t + (* download bundle version and return the file system path *) + val download : string -> string Lwt.t - (** Get latest version available *) - val get_latest_version : unit -> string Lwt.t + (** Get latest version available *) + val get_latest_version : unit -> string Lwt.t end module type UpdateClientDeps = sig - val base_url: Uri.t - val download_dir: string - val get_proxy: unit -> Uri.t option Lwt.t + val base_url : Uri.t + + val download_dir : string + + val get_proxy : unit -> Uri.t option Lwt.t end -let make_deps ?(download_dir="/tmp") get_proxy base_url : (module UpdateClientDeps) = (module struct +let make_deps ?(download_dir = "/tmp") get_proxy base_url : + (module UpdateClientDeps) = + (module struct let base_url = base_url + let get_proxy = get_proxy + let download_dir = download_dir -end) + end +) let bundle_name = Config.System.bundle_name -let bundle_file_name version = - Format.sprintf "%s-%s.raucb" bundle_name version +let bundle_file_name version = Format.sprintf "%s-%s.raucb" bundle_name version let ensure_trailing_slash uri = - let u = Uri.to_string uri in - if (String.ends_with ~suffix:"/" @@ u) then - u - else - (u ^ "/") - -module UpdateClient (DepsI: UpdateClientDeps) = struct - let get_proxy = DepsI.get_proxy - let download_dir = DepsI.download_dir - let base_url_with_trailing_slash = ensure_trailing_slash DepsI.base_url - - let download_url version_string = - Format.sprintf "%s%s/%s" base_url_with_trailing_slash version_string (bundle_file_name version_string) - |> - Uri.of_string - - (** Get latest version available *) - let get_latest_version () = - let%lwt proxy = get_proxy () in - let url = Uri.of_string @@ base_url_with_trailing_slash ^ "latest" in - match%lwt Curl.request ?proxy url with - | RequestSuccess (_, body) -> - return body - | RequestFailure error -> - Lwt.fail_with (Printf.sprintf "could not get latest version (%s)" (Curl.pretty_print_error error)) - - (** download RAUC bundle *) - let download version = - let url = download_url version in - let bundle_path = Format.sprintf - "%s/%s" download_dir (bundle_file_name version) - in - let options = - [ "--continue-at"; "-" (* resume download *) - ; "--limit-rate"; "10M" - ; "--output"; bundle_path - ] - in - let%lwt proxy = get_proxy () in - match%lwt Curl.request ?proxy ~options url with - | RequestSuccess _ -> - return bundle_path - | RequestFailure error -> - Lwt.fail_with (Printf.sprintf "could not download RAUC bundle (%s)" (Curl.pretty_print_error error)) + let u = Uri.to_string uri in + if String.ends_with ~suffix:"/" @@ u then u else u ^ "/" + +module UpdateClient (DepsI : UpdateClientDeps) = struct + let get_proxy = DepsI.get_proxy + + let download_dir = DepsI.download_dir + + let base_url_with_trailing_slash = ensure_trailing_slash DepsI.base_url + + let download_url version_string = + Format.sprintf "%s%s/%s" base_url_with_trailing_slash version_string + (bundle_file_name version_string) + |> Uri.of_string + + (** Get latest version available *) + let get_latest_version () = + let%lwt proxy = get_proxy () in + let url = Uri.of_string @@ base_url_with_trailing_slash ^ "latest" in + match%lwt Curl.request ?proxy url with + | RequestSuccess (_, body) -> + return body + | RequestFailure error -> + Lwt.fail_with + (Printf.sprintf "could not get latest version (%s)" + (Curl.pretty_print_error error) + ) + + (** download RAUC bundle *) + let download version = + let url = download_url version in + let bundle_path = + Format.sprintf "%s/%s" download_dir (bundle_file_name version) + in + let options = + [ "--continue-at" + ; "-" (* resume download *) + ; "--limit-rate" + ; "10M" + ; "--output" + ; bundle_path + ] + in + let%lwt proxy = get_proxy () in + match%lwt Curl.request ?proxy ~options url with + | RequestSuccess _ -> + return bundle_path + | RequestFailure error -> + Lwt.fail_with + (Printf.sprintf "could not download RAUC bundle (%s)" + (Curl.pretty_print_error error) + ) end module Make (DepsI : UpdateClientDeps) = UpdateClient (DepsI) let get_proxy_uri connman = Connman.Manager.get_default_proxy connman - >|= Option.map (Connman.Service.Proxy.to_uri ~include_userinfo:true) + >|= Option.map (Connman.Service.Proxy.to_uri ~include_userinfo:true) let build_module connman = let get_proxy () = get_proxy_uri connman in let depsI = make_deps get_proxy (Uri.of_string Config.System.update_url) in - (module UpdateClient (val depsI : UpdateClientDeps) : S) + (module UpdateClient ((val depsI : UpdateClientDeps)) : S) diff --git a/controller/server/update_client.mli b/controller/server/update_client.mli index 8aa25266..a7326058 100644 --- a/controller/server/update_client.mli +++ b/controller/server/update_client.mli @@ -2,20 +2,26 @@ the remote server. *) module type S = sig - (* download bundle version and return the file system path *) - val download : string -> string Lwt.t + (* download bundle version and return the file system path *) + val download : string -> string Lwt.t - (** Get latest version available *) - val get_latest_version : unit -> string Lwt.t + (** Get latest version available *) + val get_latest_version : unit -> string Lwt.t end module type UpdateClientDeps = sig - val base_url: Uri.t - val download_dir: string - val get_proxy: unit -> Uri.t option Lwt.t + val base_url : Uri.t + + val download_dir : string + + val get_proxy : unit -> Uri.t option Lwt.t end -val make_deps : ?download_dir:string -> (unit -> Uri.t option Lwt.t) -> Uri.t -> (module UpdateClientDeps) +val make_deps : + ?download_dir:string + -> (unit -> Uri.t option Lwt.t) + -> Uri.t + -> (module UpdateClientDeps) module Make (_ : UpdateClientDeps) : S diff --git a/controller/server/view/changelog_page.ml b/controller/server/view/changelog_page.ml index 8cbcbbca..6bc1d875 100644 --- a/controller/server/view/changelog_page.ml +++ b/controller/server/view/changelog_page.ml @@ -1,9 +1,6 @@ open Tyxml.Html let html changelog = - Page.html - ~current_page:Page.Changelog + Page.html ~current_page:Page.Changelog ~header:(Page.header_title ~icon:Icon.document [ txt "Changelog" ]) - (div - ~a:[ a_class [ "d-Markdown" ] ] - [ Unsafe.data changelog ]) + (div ~a:[ a_class [ "d-Markdown" ] ] [ Unsafe.data changelog ]) diff --git a/controller/server/view/changelog_page.mli b/controller/server/view/changelog_page.mli index 09ed1802..eae7d1ea 100644 --- a/controller/server/view/changelog_page.mli +++ b/controller/server/view/changelog_page.mli @@ -1,3 +1 @@ -val html : - string - -> [> Html_types.html ] Tyxml.Html.elt +val html : string -> [> Html_types.html ] Tyxml.Html.elt diff --git a/controller/server/view/common/definition.ml b/controller/server/view/common/definition.ml index 02f7ab0d..41c7bed9 100644 --- a/controller/server/view/common/definition.ml +++ b/controller/server/view/common/definition.ml @@ -1,16 +1,14 @@ open Tyxml.Html let list ?a = - dl ~a:( - [ a_class [ "d-Definitions__Definitions" ] ] - @ (Option.value ~default:[] a)) + dl + ~a: + ([ a_class [ "d-Definitions__Definitions" ] ] @ Option.value ~default:[] a) let term ?a = - dt ~a:( - [ a_class [ "d-Definitions__Term" ] ] - @ (Option.value ~default:[] a)) + dt ~a:([ a_class [ "d-Definitions__Term" ] ] @ Option.value ~default:[] a) let description ?a = - dt ~a:( - [ a_class [ "d-Definitions__Description" ] ] - @ (Option.value ~default:[] a)) + dt + ~a: + ([ a_class [ "d-Definitions__Description" ] ] @ Option.value ~default:[] a) diff --git a/controller/server/view/common/definition.mli b/controller/server/view/common/definition.mli index 570131d5..2168d663 100644 --- a/controller/server/view/common/definition.mli +++ b/controller/server/view/common/definition.mli @@ -1,14 +1,14 @@ val list : - ?a:[< Html_types.dl_attrib > `Class ] Tyxml.Html.attrib list -> - [< Html_types.dl_content_fun ] Tyxml.Html.elt Tyxml.Html.list_wrap -> - [> Html_types.dl ] Tyxml.Html.elt + ?a:[< Html_types.dl_attrib > `Class ] Tyxml.Html.attrib list + -> [< Html_types.dl_content_fun ] Tyxml.Html.elt Tyxml.Html.list_wrap + -> [> Html_types.dl ] Tyxml.Html.elt val term : - ?a:[< Html_types.dt_attrib > `Class ] Tyxml.Html.attrib list -> - [< Html_types.dt_content_fun ] Tyxml.Html.elt Tyxml.Html.list_wrap -> - [> Html_types.dt ] Tyxml.Html.elt + ?a:[< Html_types.dt_attrib > `Class ] Tyxml.Html.attrib list + -> [< Html_types.dt_content_fun ] Tyxml.Html.elt Tyxml.Html.list_wrap + -> [> Html_types.dt ] Tyxml.Html.elt val description : - ?a:[< Html_types.dt_attrib > `Class ] Tyxml.Html.attrib list -> - [< Html_types.dt_content_fun ] Tyxml.Html.elt Tyxml.Html.list_wrap -> - [> Html_types.dt ] Tyxml.Html.elt + ?a:[< Html_types.dt_attrib > `Class ] Tyxml.Html.attrib list + -> [< Html_types.dt_content_fun ] Tyxml.Html.elt Tyxml.Html.list_wrap + -> [> Html_types.dt ] Tyxml.Html.elt diff --git a/controller/server/view/common/icon.ml b/controller/server/view/common/icon.ml index ac39d98b..8d36b645 100644 --- a/controller/server/view/common/icon.ml +++ b/controller/server/view/common/icon.ml @@ -4,44 +4,39 @@ open Tyxml.Svg let svg ?a ?stroke_width content = Tyxml.Html.svg - ~a:([ a_viewBox (0., 0., 24., 24.) - ; a_width (24., None) - ; a_height (24., None) - ; a_fill `None - ; a_stroke `CurrentColor - ; a_stroke_width (Option.value ~default:2. stroke_width, None) - ; a_stroke_linecap `Round - ; a_stroke_linejoin `Round - ] @ (Option.value ~default:[] a)) + ~a: + ([ a_viewBox (0., 0., 24., 24.) + ; a_width (24., None) + ; a_height (24., None) + ; a_fill `None + ; a_stroke `CurrentColor + ; a_stroke_width (Option.value ~default:2. stroke_width, None) + ; a_stroke_linecap `Round + ; a_stroke_linejoin `Round + ] + @ Option.value ~default:[] a + ) content let line (x1, y1) (x2, y2) = Tyxml.Svg.line - ~a:[ a_x1 (x1, None) - ; a_y1 (y1, None) - ; a_x2 (x2, None) - ; a_y2 (y2, None) - ] + ~a:[ a_x1 (x1, None); a_y1 (y1, None); a_x2 (x2, None); a_y2 (y2, None) ] [] let circle (x, y) r = - Tyxml.Svg.circle - ~a:[ a_cx (x, None) - ; a_cy (y, None) - ; a_r (r, None) - ] - [] + Tyxml.Svg.circle ~a:[ a_cx (x, None); a_cy (y, None); a_r (r, None) ] [] let rect ?rx ?fill (x1, y1) (x2, y2) = - Tyxml.Svg.rect - ~a:[ a_x (x1, None) + Tyxml.Svg.rect + ~a: + [ a_x (x1, None) ; a_y (y1, None) ; a_width (x2 -. x1, None) ; a_height (y2 -. y1, None) ; a_rx (Option.value ~default:0. rx, None) ; a_fill (`Color (Option.value ~default:"transparent" fill, None)) ] - [] + [] (* Icons *) @@ -62,15 +57,30 @@ let wifi ?strength () = in svg ~a:[ a_class [ "d-WifiSignal--" ^ modifier ] ] - [ path ~a:[ a_class [ "d-WifiSignal__Wave--Outer" ] ; a_d "M1.42 9a16 16 0 0 1 21.16 0" ] [] - ; path ~a:[ a_class [ "d-WifiSignal__Wave--Middle" ] ; a_d "M5 12.55a11 11 0 0 1 14.08 0" ] [] - ; path ~a:[ a_class [ "d-WifiSignal__Wave--Inner" ] ; a_d "M8.53 16.11a6 6 0 0 1 6.95 0" ] [] + [ path + ~a: + [ a_class [ "d-WifiSignal__Wave--Outer" ] + ; a_d "M1.42 9a16 16 0 0 1 21.16 0" + ] + [] + ; path + ~a: + [ a_class [ "d-WifiSignal__Wave--Middle" ] + ; a_d "M5 12.55a11 11 0 0 1 14.08 0" + ] + [] + ; path + ~a: + [ a_class [ "d-WifiSignal__Wave--Inner" ] + ; a_d "M8.53 16.11a6 6 0 0 1 6.95 0" + ] + [] ; line (12., 20.) (12., 20.) ] let ethernet = svg - [ path ~a: [ a_d "M2 2 H22 V18 H18 V22 H6 V18 H2 Z" ] [] + [ path ~a:[ a_d "M2 2 H22 V18 H18 V22 H6 V18 H2 Z" ] [] ; line (6., 6.) (6., 10.) ; line (10., 6.) (10., 10.) ; line (14., 6.) (14., 10.) @@ -81,7 +91,13 @@ let world = svg [ circle (12., 12.) 10. ; line (2., 12.) (22., 12.) - ; path ~a:[ a_d "M12 2a15.3 15.3 0 0 1 4 10 15.3 15.3 0 0 1-4 10 15.3 15.3 0 0 1-4-10 15.3 15.3 0 0 1 4-10z" ] [] + ; path + ~a: + [ a_d + "M12 2a15.3 15.3 0 0 1 4 10 15.3 15.3 0 0 1-4 10 15.3 15.3 0 0 \ + 1-4-10 15.3 15.3 0 0 1 4-10z" + ] + [] ] let power = @@ -116,14 +132,15 @@ let letter = svg ~stroke_width:1. [ rect ~rx:1. ~fill:"black" (2., 2.) (22., 22.) ; text - ~a:[ a_fill (`Color ("white", None)) - ; a_stroke (`Color ("white", None)) - ; a_font_size "16" - ; Unsafe.string_attrib "x" "50%" - ; Unsafe.string_attrib "y" "55%" - ; a_dominant_baseline `Middle - ; a_text_anchor `Middle - ] + ~a: + [ a_fill (`Color ("white", None)) + ; a_stroke (`Color ("white", None)) + ; a_font_size "16" + ; Unsafe.string_attrib "x" "50%" + ; Unsafe.string_attrib "y" "55%" + ; a_dominant_baseline `Middle + ; a_text_anchor `Middle + ] [ txt "A" ] ] @@ -131,11 +148,12 @@ let copyright = svg [ circle (12., 12.) 10. ; text - ~a:[ a_font_size "10" - ; Unsafe.string_attrib "x" "50%" - ; Unsafe.string_attrib "y" "55%" - ; a_dominant_baseline `Middle - ; a_text_anchor `Middle - ] + ~a: + [ a_font_size "10" + ; Unsafe.string_attrib "x" "50%" + ; Unsafe.string_attrib "y" "55%" + ; a_dominant_baseline `Middle + ; a_text_anchor `Middle + ] [ txt "C" ] ] diff --git a/controller/server/view/common/icon.mli b/controller/server/view/common/icon.mli index 8099ff09..9618411c 100644 --- a/controller/server/view/common/icon.mli +++ b/controller/server/view/common/icon.mli @@ -1,10 +1,19 @@ val info : [> Html_types.svg ] Tyxml.Html.elt + val wifi : ?strength:int -> unit -> [> Html_types.svg ] Tyxml.Html.elt + val ethernet : [> Html_types.svg ] Tyxml.Html.elt + val world : [> Html_types.svg ] Tyxml.Html.elt + val power : [> Html_types.svg ] Tyxml.Html.elt + val screen : [> Html_types.svg ] Tyxml.Html.elt + val document : [> Html_types.svg ] Tyxml.Html.elt + val arrow_left : [> Html_types.svg ] Tyxml.Html.elt + val letter : [> Html_types.svg ] Tyxml.Html.elt + val copyright : [> Html_types.svg ] Tyxml.Html.elt diff --git a/controller/server/view/common/page.ml b/controller/server/view/common/page.ml index 7e870129..a077388d 100644 --- a/controller/server/view/common/page.ml +++ b/controller/server/view/common/page.ml @@ -11,33 +11,54 @@ type page = let menu_link page = match page with - | Info -> "/info" - | Network -> "/network" - | Localization -> "/localization" - | SystemStatus -> "/status" - | Changelog -> "/changelog" - | Licensing -> "/licensing" - | Shutdown -> "/system/shutdown" + | Info -> + "/info" + | Network -> + "/network" + | Localization -> + "/localization" + | SystemStatus -> + "/status" + | Changelog -> + "/changelog" + | Licensing -> + "/licensing" + | Shutdown -> + "/system/shutdown" let menu_icon page = match page with - | Info -> Icon.info - | Network -> Icon.world - | Localization -> Icon.letter - | SystemStatus -> Icon.screen - | Changelog -> Icon.document - | Licensing -> Icon.copyright - | Shutdown -> Icon.power + | Info -> + Icon.info + | Network -> + Icon.world + | Localization -> + Icon.letter + | SystemStatus -> + Icon.screen + | Changelog -> + Icon.document + | Licensing -> + Icon.copyright + | Shutdown -> + Icon.power let menu_label page = match page with - | Info -> "Information" - | Network -> "Network" - | Localization -> "Localization & Display" - | SystemStatus -> "System Status" - | Changelog -> "Changelog" - | Licensing -> "Licensing" - | Shutdown -> "Shutdown" + | Info -> + "Information" + | Network -> + "Network" + | Localization -> + "Localization & Display" + | SystemStatus -> + "System Status" + | Changelog -> + "Changelog" + | Licensing -> + "Licensing" + | Shutdown -> + "Shutdown" let menu_item current_page page = let is_active = current_page = Some page in @@ -45,81 +66,91 @@ let menu_item current_page page = "d-Menu__Item" :: (if is_active then [ "d-Menu__Item--Active" ] else []) in a - ~a:( - a_href (menu_link page) :: a_class class_ :: - if is_active then [ a_user_data "focus-active" "" ] else [] - ) - [ menu_icon page - ; txt (menu_label page) - ] + ~a: + (a_href (menu_link page) + :: a_class class_ + :: (if is_active then [ a_user_data "focus-active" "" ] else []) + ) + [ menu_icon page; txt (menu_label page) ] let html ?current_page ?header content = let header = match header with - | Some header -> [ Tyxml.Html.header ~a:[ a_class [ "d-Layout__Header" ] ] [ header ] ] - | None -> [] + | Some header -> + [ Tyxml.Html.header ~a:[ a_class [ "d-Layout__Header" ] ] [ header ] ] + | None -> + [] in html ~a:[ a_lang "en" ] (head - (title (txt "PlayOS Controller")) - [ meta ~a:[ a_charset "utf-8" ] () - ; link ~rel:[`Stylesheet] ~href:"/static/reset.css" () - ; link ~rel:[`Stylesheet] ~href:"/static/style.css" () - ] + (title (txt "PlayOS Controller")) + [ meta ~a:[ a_charset "utf-8" ] () + ; link ~rel:[ `Stylesheet ] ~href:"/static/reset.css" () + ; link ~rel:[ `Stylesheet ] ~href:"/static/style.css" () + ] ) (body - ~a:[ a_class [ "d-Layout" ] ] - (( aside - ~a:[ a_class [ "d-Layout__Aside" ] - ; a_user_data "focus-group" "active" - ] + ~a:[ a_class [ "d-Layout" ] ] + (aside + ~a: + [ a_class [ "d-Layout__Aside" ] + ; a_user_data "focus-group" "active" + ] [ nav - ([ Info; Network; Localization; SystemStatus; Changelog; Licensing ] - |> List.concat_map (fun page -> [ menu_item current_page page; txt " " ])) + ([ Info + ; Network + ; Localization + ; SystemStatus + ; Changelog + ; Licensing + ] + |> List.concat_map (fun page -> + [ menu_item current_page page; txt " " ] + ) + ) ; form - ~a:[ a_action (menu_link Shutdown) - ; a_method `Post - ; a_class [ "d-Layout__Shutdown" ] - ] - [ - button - ~a:[ - a_class [ "d-Menu__Item" ] - ] - [ menu_icon Shutdown - ; txt (menu_label Shutdown) - ] + ~a: + [ a_action (menu_link Shutdown) + ; a_method `Post + ; a_class [ "d-Layout__Shutdown" ] + ] + [ button + ~a:[ a_class [ "d-Menu__Item" ] ] + [ menu_icon Shutdown; txt (menu_label Shutdown) ] ] - ]) - :: header - @ [ main - ~a:[ a_class [ "d-Layout__Main" ] ] - [ content ] - ; script ~a:[ a_src "/static/vendor/focus-shift.js" ] (txt "") - ; script ~a:[ a_src "/static/client.js" ] (txt "") - ]) + ] + :: header + @ [ main ~a:[ a_class [ "d-Layout__Main" ] ] [ content ] + ; script ~a:[ a_src "/static/vendor/focus-shift.js" ] (txt "") + ; script ~a:[ a_src "/static/client.js" ] (txt "") + ] + ) ) let header_title ?back_url ?icon ?right_action content = let back_link = match back_url with - | Some url -> [ a ~a:[ a_class [ "d-Header__BackLink" ] ; a_href url ] [ Icon.arrow_left ] ] - | None -> [] + | Some url -> + [ a + ~a:[ a_class [ "d-Header__BackLink" ]; a_href url ] + [ Icon.arrow_left ] + ] + | None -> + [] in let icon = match icon with - | Some icon -> [ span ~a: [ a_class [ "d-Header__Icon" ] ] [ icon ] ] - | None -> [] + | Some icon -> + [ span ~a:[ a_class [ "d-Header__Icon" ] ] [ icon ] ] + | None -> + [] in let right_action = - match right_action with - | Some right_action -> [ right_action ] - | None -> [] + match right_action with Some right_action -> [ right_action ] | None -> [] in div ~a:[ a_class [ "d-Header__Line" ] ] - ((h1 - ~a:[ a_class [ "d-Header__Title" ] ] - (back_link @ icon @ content)) - :: right_action) + (h1 ~a:[ a_class [ "d-Header__Title" ] ] (back_link @ icon @ content) + :: right_action + ) diff --git a/controller/server/view/common/page.mli b/controller/server/view/common/page.mli index 3403b8da..e5847f00 100644 --- a/controller/server/view/common/page.mli +++ b/controller/server/view/common/page.mli @@ -8,14 +8,14 @@ type page = | Shutdown val html : - ?current_page:page -> - ?header:[< Html_types.header_content_fun ] Tyxml.Html.elt -> - [< Html_types.main_content_fun ] Tyxml.Html.elt -> - [> Html_types.html ] Tyxml.Html.elt + ?current_page:page + -> ?header:[< Html_types.header_content_fun ] Tyxml.Html.elt + -> [< Html_types.main_content_fun ] Tyxml.Html.elt + -> [> Html_types.html ] Tyxml.Html.elt val header_title : - ?back_url:Tyxml.Html.Xml.uri Tyxml.Html.wrap -> - ?icon:[< Html_types.span_content_fun ] Tyxml.Html.elt -> - ?right_action:[< Html_types.div_content_fun > `H1 ] Tyxml.Html.elt -> - [< Html_types.h1_content_fun > `A `Span ] Tyxml.Html.elt list -> - [> Html_types.div ] Tyxml.Html.elt + ?back_url:Tyxml.Html.Xml.uri Tyxml.Html.wrap + -> ?icon:[< Html_types.span_content_fun ] Tyxml.Html.elt + -> ?right_action:[< Html_types.div_content_fun > `H1 ] Tyxml.Html.elt + -> [< Html_types.h1_content_fun > `A `Span ] Tyxml.Html.elt list + -> [> Html_types.div ] Tyxml.Html.elt diff --git a/controller/server/view/error_page.ml b/controller/server/view/error_page.ml index fcdecb51..c779cb4b 100644 --- a/controller/server/view/error_page.ml +++ b/controller/server/view/error_page.ml @@ -1,17 +1,17 @@ open Tyxml.Html type params = - { message: string - ; request: string + { message : string + ; request : string } let html { message; request } = - Page.html + Page.html ~header:(Page.header_title [ txt "Error" ]) (div - [ pre ~a:[ a_class [ "d-Preformatted" ] ] [ txt message ] - ; details - (summary [ txt "Request" ]) - [ pre ~a: [ a_class [ "d-Preformatted" ] ] [ txt request ] - ] - ]) + [ pre ~a:[ a_class [ "d-Preformatted" ] ] [ txt message ] + ; details + (summary [ txt "Request" ]) + [ pre ~a:[ a_class [ "d-Preformatted" ] ] [ txt request ] ] + ] + ) diff --git a/controller/server/view/error_page.mli b/controller/server/view/error_page.mli index be3ed5ed..02f0d4c7 100644 --- a/controller/server/view/error_page.mli +++ b/controller/server/view/error_page.mli @@ -1,8 +1,6 @@ type params = - { message: string - ; request: string + { message : string + ; request : string } -val html : - params - -> [> Html_types.html ] Tyxml.Html.elt +val html : params -> [> Html_types.html ] Tyxml.Html.elt diff --git a/controller/server/view/info_page.ml b/controller/server/view/info_page.ml index dfe837a5..c4ca39f2 100644 --- a/controller/server/view/info_page.ml +++ b/controller/server/view/info_page.ml @@ -3,16 +3,15 @@ open Tyxml.Html let remote_maintenance_form action button_label = form - ~a:[ a_action ("/remote-maintenance/" ^ action) - ; a_method `Post - ; a_class [ "d-Info__RemoteMaintenanceForm" ] - ; Unsafe.string_attrib "is" "disable-after-submit" - ] + ~a: + [ a_action ("/remote-maintenance/" ^ action) + ; a_method `Post + ; a_class [ "d-Info__RemoteMaintenanceForm" ] + ; Unsafe.string_attrib "is" "disable-after-submit" + ] [ input - ~a:[ a_input_type `Submit - ; a_class [ "d-Button" ] - ; a_value button_label - ] + ~a: + [ a_input_type `Submit; a_class [ "d-Button" ]; a_value button_label ] () ] @@ -27,33 +26,33 @@ let remote_maintenance address = | None -> [ div ~a:[ a_class [ "d-Note" ] ] - [ txt "Enabling remote maintenance allows Dividat to access this computer at a distance. For this purpose the computer's public IP address is shared with ZeroTier, a US-based company providing an overlay network." + [ txt + "Enabling remote maintenance allows Dividat to access this \ + computer at a distance. For this purpose the computer's public \ + IP address is shared with ZeroTier, a US-based company \ + providing an overlay network." ] ; remote_maintenance_form "enable" "Enable" ] let html server_info = - Page.html - ~current_page:Page.Info + Page.html ~current_page:Page.Info ~header:(Page.header_title ~icon:Icon.info [ txt "Information" ]) (div - [ Definition.list - [ Definition.term [ txt "Version" ] - ; Definition.description [ txt server_info.version ] - - ; Definition.term [ txt "Update URL" ] - ; Definition.description [ txt server_info.update_url ] - - ; Definition.term [ txt "Kiosk URL" ] - ; Definition.description [ txt server_info.kiosk_url ] - - ; Definition.term [ txt "Machine ID" ] - ; Definition.description [ txt server_info.machine_id ] - - ; Definition.term [ txt "Local time" ] - ; Definition.description [ txt server_info.local_time ] - - ; Definition.term [ txt "Remote maintenance" ] - ; Definition.description (remote_maintenance server_info.zerotier_address) - ] - ]) + [ Definition.list + [ Definition.term [ txt "Version" ] + ; Definition.description [ txt server_info.version ] + ; Definition.term [ txt "Update URL" ] + ; Definition.description [ txt server_info.update_url ] + ; Definition.term [ txt "Kiosk URL" ] + ; Definition.description [ txt server_info.kiosk_url ] + ; Definition.term [ txt "Machine ID" ] + ; Definition.description [ txt server_info.machine_id ] + ; Definition.term [ txt "Local time" ] + ; Definition.description [ txt server_info.local_time ] + ; Definition.term [ txt "Remote maintenance" ] + ; Definition.description + (remote_maintenance server_info.zerotier_address) + ] + ] + ) diff --git a/controller/server/view/info_page.mli b/controller/server/view/info_page.mli index 6fb192fe..6b64ada1 100644 --- a/controller/server/view/info_page.mli +++ b/controller/server/view/info_page.mli @@ -1,3 +1 @@ -val html : - Info.t - -> [> Html_types.html ] Tyxml.Html.elt +val html : Info.t -> [> Html_types.html ] Tyxml.Html.elt diff --git a/controller/server/view/licensing_page.ml b/controller/server/view/licensing_page.ml index e9aeb711..af712e29 100644 --- a/controller/server/view/licensing_page.ml +++ b/controller/server/view/licensing_page.ml @@ -7,9 +7,9 @@ let tool ~name ~license_name ~license_content content = [ h2 ~a:[ a_class [ "d-Title" ] ] [ txt name ] ; div content ; details - ~a:[ a_class [ "d-Licensing__Details" ] ] - (summary [ txt license_name ]) - [ pre ~a: [ a_class [ "d-Preformatted" ] ] [ txt license_content ] ] + ~a:[ a_class [ "d-Licensing__Details" ] ] + (summary [ txt license_name ]) + [ pre ~a:[ a_class [ "d-Preformatted" ] ] [ txt license_content ] ] ] let read_license key = @@ -20,38 +20,29 @@ let html = let%lwt nixpkgs_license = read_license "NIXPKGS" in let%lwt feather_license = read_license "FEATHER" in let%lwt qt6_license = read_license "QT6" in - Lwt.return (Page.html - ~current_page:Page.Licensing - ~header:(Page.header_title - ~icon:Icon.copyright - [ txt "Licensing" ]) - (div - [ tool - ~name:"PlayOS" - ~license_name:"MIT License" - ~license_content:playos_license - [ p - ~a:[ a_class [ "d-Paragraph" ] ] - [ txt "Source code is available at " - ; span (* Using span as we don’t intend the user to leave the current page *) - ~a:[ a_class [ "d-Licensing__Link" ] ] - [ txt "https://github.com/dividat/playos" ] - ; txt ", with instructions to build and modify the software." + Lwt.return + (Page.html ~current_page:Page.Licensing + ~header:(Page.header_title ~icon:Icon.copyright [ txt "Licensing" ]) + (div + [ tool ~name:"PlayOS" ~license_name:"MIT License" + ~license_content:playos_license + [ p + ~a:[ a_class [ "d-Paragraph" ] ] + [ txt "Source code is available at " + ; span + (* Using span as we don’t intend the user to leave the current page *) + ~a:[ a_class [ "d-Licensing__Link" ] ] + [ txt "https://github.com/dividat/playos" ] + ; txt ", with instructions to build and modify the software." + ] + ] + ; tool ~name:"Nixpkgs" ~license_name:"MIT License" + ~license_content:nixpkgs_license [] + ; tool ~name:"Feather" ~license_name:"MIT License" + ~license_content:feather_license [] + ; tool ~name:"Qt6" + ~license_name:"GNU Lesser General Public License v3.0" + ~license_content:qt6_license [] ] - ] - ; tool - ~name:"Nixpkgs" - ~license_name:"MIT License" - ~license_content:nixpkgs_license - [] - ; tool - ~name:"Feather" - ~license_name:"MIT License" - ~license_content:feather_license - [] - ; tool - ~name:"Qt6" - ~license_name:"GNU Lesser General Public License v3.0" - ~license_content:qt6_license - [] - ])) + ) + ) diff --git a/controller/server/view/licensing_page.mli b/controller/server/view/licensing_page.mli index 8044a962..b34fe9cd 100644 --- a/controller/server/view/licensing_page.mli +++ b/controller/server/view/licensing_page.mli @@ -1,2 +1 @@ -val html : - [> Html_types.html ] Tyxml.Html.elt Lwt.t +val html : [> Html_types.html ] Tyxml.Html.elt Lwt.t diff --git a/controller/server/view/localization_page.ml b/controller/server/view/localization_page.ml index 6b27d57a..0b98b109 100644 --- a/controller/server/view/localization_page.ml +++ b/controller/server/view/localization_page.ml @@ -1,60 +1,59 @@ open Tyxml.Html type select_form_params = - { action_url: string - ; legend: string - ; select_name: string - ; placeholder: string option + { action_url : string + ; legend : string + ; select_name : string + ; placeholder : string option } let select_form params options = form - ~a:[ a_action params.action_url - ; a_method `Post - ; a_class [ "d-Localization__Form" ] - ; Unsafe.string_attrib "is" "disable-after-submit" - ] - [ label - ~a:[ a_class [ "d-Localization__Legend" ] ] - [ txt params.legend ] + ~a: + [ a_action params.action_url + ; a_method `Post + ; a_class [ "d-Localization__Form" ] + ; Unsafe.string_attrib "is" "disable-after-submit" + ] + [ label ~a:[ a_class [ "d-Localization__Legend" ] ] [ txt params.legend ] ; select - ~a:[ a_name params.select_name - ; a_class [ "d-Select"; "d-Localization__Select" ] - ; a_required () - ] + ~a: + [ a_name params.select_name + ; a_class [ "d-Select"; "d-Localization__Select" ] + ; a_required () + ] ((params.placeholder - |> Option.map (fun p -> option ~a:[ a_disabled (); a_selected ()] (txt p)) - |> Base.Option.to_list) - @ options) + |> Option.map (fun p -> + option ~a:[ a_disabled (); a_selected () ] (txt p) + ) + |> Base.Option.to_list + ) + @ options + ) ; input - ~a:[ a_input_type `Submit - ; a_class [ "d-Button" ] - ; a_value "Set" - ] + ~a:[ a_input_type `Submit; a_class [ "d-Button" ]; a_value "Set" ] () ] let select_option current_id (id, name) = option - ~a:( - [ a_value id ] - @ (if current_id = Some id then [ a_selected () ] else []) - ) + ~a:([ a_value id ] @ if current_id = Some id then [ a_selected () ] else []) (txt name) let timezone_form timezone_groups current_timezone = let timezone_group (group_id, timezones) = - optgroup ~label:group_id (List.map (select_option current_timezone) timezones) + optgroup ~label:group_id + (List.map (select_option current_timezone) timezones) in select_form { action_url = "/localization/timezone" ; legend = "Timezone" ; select_name = "timezone" ; placeholder = - if Option.is_none current_timezone then - Some "Select your closest timezone…" - else - None + ( if Option.is_none current_timezone then + Some "Select your closest timezone…" + else None + ) } (List.map timezone_group timezone_groups) @@ -64,10 +63,9 @@ let language_form langs current_lang = ; legend = "Language" ; select_name = "lang" ; placeholder = - if Option.is_none current_lang then - Some "Select your language…" - else - None + ( if Option.is_none current_lang then Some "Select your language…" + else None + ) } (List.map (select_option current_lang) langs) @@ -77,47 +75,53 @@ let keyboard_form keymaps current_keymap = ; legend = "Keyboard" ; select_name = "keymap" ; placeholder = - if Option.is_none current_keymap then - Some "Select your keyboard layout…" - else - None + ( if Option.is_none current_keymap then + Some "Select your keyboard layout…" + else None + ) } (List.map (select_option current_keymap) keymaps) let scaling_form current_scaling = [ Screen_settings.Default; Screen_settings.FullHD; Screen_settings.Native ] - |> List.map (fun s -> - select_option - (Some (Screen_settings.string_of_scaling current_scaling)) - (Screen_settings.string_of_scaling s, Screen_settings.label_of_scaling s) - ) - |> select_form - { action_url = "/localization/scaling" - ; legend = "Display resolution" - ; select_name = "scaling" - ; placeholder = None - } + |> List.map (fun s -> + select_option + (Some (Screen_settings.string_of_scaling current_scaling)) + ( Screen_settings.string_of_scaling s + , Screen_settings.label_of_scaling s + ) + ) + |> select_form + { action_url = "/localization/scaling" + ; legend = "Display resolution" + ; select_name = "scaling" + ; placeholder = None + } type params = - { timezone_groups: (string * ((string * string) list)) list - ; current_timezone: string option - ; langs: (string * string) list - ; current_lang: string option - ; keymaps: (string * string) list - ; current_keymap: string option - ; current_scaling: Screen_settings.scaling + { timezone_groups : (string * (string * string) list) list + ; current_timezone : string option + ; langs : (string * string) list + ; current_lang : string option + ; keymaps : (string * string) list + ; current_keymap : string option + ; current_scaling : Screen_settings.scaling } let html params = - Page.html - ~current_page:Page.Localization - ~header:(Page.header_title ~icon:Icon.letter [ txt "Localization & Display" ]) + Page.html ~current_page:Page.Localization + ~header: + (Page.header_title ~icon:Icon.letter [ txt "Localization & Display" ]) (div - [ timezone_form params.timezone_groups params.current_timezone - ; language_form params.langs params.current_lang - ; keyboard_form params.keymaps params.current_keymap - ; scaling_form params.current_scaling - ; aside - ~a:[ a_class [ "d-Localization__Note" ] ] - [ txt "Note that changes to the keyboard, language and display settings require a restart." ] - ]) + [ timezone_form params.timezone_groups params.current_timezone + ; language_form params.langs params.current_lang + ; keyboard_form params.keymaps params.current_keymap + ; scaling_form params.current_scaling + ; aside + ~a:[ a_class [ "d-Localization__Note" ] ] + [ txt + "Note that changes to the keyboard, language and display \ + settings require a restart." + ] + ] + ) diff --git a/controller/server/view/localization_page.mli b/controller/server/view/localization_page.mli index f81fc206..f92de661 100644 --- a/controller/server/view/localization_page.mli +++ b/controller/server/view/localization_page.mli @@ -1,13 +1,11 @@ type params = - { timezone_groups: (string * ((string * string) list)) list - ; current_timezone: string option - ; langs: (string * string) list - ; current_lang: string option - ; keymaps: (string * string) list - ; current_keymap: string option + { timezone_groups : (string * (string * string) list) list + ; current_timezone : string option + ; langs : (string * string) list + ; current_lang : string option + ; keymaps : (string * string) list + ; current_keymap : string option ; current_scaling : Screen_settings.scaling } -val html : - params - -> [> Html_types.html ] Tyxml.Html.elt +val html : params -> [> Html_types.html ] Tyxml.Html.elt diff --git a/controller/server/view/network_details_page.ml b/controller/server/view/network_details_page.ml index 11c4c1f6..e7718125 100644 --- a/controller/server/view/network_details_page.ml +++ b/controller/server/view/network_details_page.ml @@ -1,77 +1,82 @@ open Connman.Service open Tyxml.Html - let proxy_form proxy = let open Proxy in div - [ label + [ label ~a:[ a_class [ "d-Label" ] ] [ txt "Server" ; span [ input - ~a:[ a_input_type `Text - ; a_class [ "d-Input"; "d-Network__Input" ] - ; a_name "proxy_host" - ; a_value - (match proxy with - | Some { host } -> host - | _ -> "" - ) - ; a_placeholder "Host" - ; a_pattern {|[a-zA-Z0-9-]+(\.[a-zA-Z0-9-]+)*|} - ] + ~a: + [ a_input_type `Text + ; a_class [ "d-Input"; "d-Network__Input" ] + ; a_name "proxy_host" + ; a_value (match proxy with Some { host } -> host | _ -> "") + ; a_placeholder "Host" + ; a_pattern {|[a-zA-Z0-9-]+(\.[a-zA-Z0-9-]+)*|} + ] () ; txt ":" ; input - ~a:[ a_input_type `Number - ; a_class [ "d-Input" ] - ; a_name "proxy_port" - ; a_size 10 - ; a_step (Some 1.0) - ; a_value - (match proxy with - | Some { port } -> string_of_int port - | _ -> "" - ) - ; a_placeholder "Port" - ] + ~a: + [ a_input_type `Number + ; a_class [ "d-Input" ] + ; a_name "proxy_port" + ; a_size 10 + ; a_step (Some 1.0) + ; a_value + ( match proxy with + | Some { port } -> + string_of_int port + | _ -> + "" + ) + ; a_placeholder "Port" + ] () ] ] - ; label - ~a:[ a_class [ "d-Label" ] ] - [ txt "Username (optional)" + ; label + ~a:[ a_class [ "d-Label" ] ] + [ txt "Username (optional)" ; input - ~a:[ a_input_type `Text - ; a_class [ "d-Input"; "d-Network__Input" ] - ; a_name "proxy_user" - ; a_value - (match proxy with - | Some { credentials = Some { user } } -> user - | _ -> "" - ) - ] - () + ~a: + [ a_input_type `Text + ; a_class [ "d-Input"; "d-Network__Input" ] + ; a_name "proxy_user" + ; a_value + ( match proxy with + | Some { credentials = Some { user } } -> + user + | _ -> + "" + ) + ] + () ] ; div - ~a:(match proxy with - | Some { credentials = Some { password } } -> - if password <> "" then - [ Unsafe.string_attrib "is" "keep-previous-password" ] - else - [] - | _ -> []) + ~a: + ( match proxy with + | Some { credentials = Some { password } } -> + if password <> "" then + [ Unsafe.string_attrib "is" "keep-previous-password" ] + else [] + | _ -> + [] + ) [ label ~a:[ a_class [ "d-Label" ] ] [ txt "Password (optional)" ; input - ~a:[ a_input_type `Password - ; a_class [ "d-Input"; "d-Network__Input" ] - ; a_name "proxy_password" - ; a_value "" - ; Unsafe.string_attrib "is" "show-password" - ] + ~a: + [ a_input_type `Password + ; a_class [ "d-Input"; "d-Network__Input" ] + ; a_name "proxy_password" + ; a_value "" + ; Unsafe.string_attrib "is" "show-password" + ] () ] ] @@ -80,34 +85,40 @@ let proxy_form proxy = let maybe_elem cond elem = if cond then Some elem else None let not_connected_form service = - let requires_passphrase = service.security <> [ None ] in + let requires_passphrase = service.security <> [ None ] in form - ~a:[ a_action ("/network/" ^ service.id ^ "/connect") + ~a: + [ a_action ("/network/" ^ service.id ^ "/connect") ; a_method `Post ; Unsafe.string_attrib "is" "disable-after-submit" ] - (Option.to_list (maybe_elem requires_passphrase ( - label - ~a:[ a_class [ "d-Label" ] ] - [ txt "Password" - ; input - ~a:[ a_input_type `Password - ; a_class [ "d-Input"; "d-Network__Input" ] - ; a_name "passphrase" - ; Unsafe.string_attrib "is" "show-password" - ] - () - ] - )) @ - [ p + (Option.to_list + (maybe_elem requires_passphrase + (label + ~a:[ a_class [ "d-Label" ] ] + [ txt "Password" + ; input + ~a: + [ a_input_type `Password + ; a_class [ "d-Input"; "d-Network__Input" ] + ; a_name "passphrase" + ; Unsafe.string_attrib "is" "show-password" + ] + () + ] + ) + ) + @ [ p [ input - ~a:[ a_input_type `Submit - ; a_class [ "d-Button" ] - ; a_value "Connect" - ] + ~a: + [ a_input_type `Submit + ; a_class [ "d-Button" ] + ; a_value "Connect" + ] () ] - ]) + ] + ) (* Regex pattern to validate IP addresses * From: https://stackoverflow.com/a/36760050 *) @@ -120,177 +131,186 @@ let multi_ip_address_regex_pattern = let is_static service = service.ipv4 - |> Option.map(fun (ipv4: IPv4.t) -> ipv4.method' = "manual") + |> Option.map (fun (ipv4 : IPv4.t) -> ipv4.method' = "manual") |> Option.value ~default:false let static_ip_form service = let ip_input ~name ~labelTxt ~value ~pattern = - [ label - ~a:[ a_class [ "d-Label" ] ] - [ txt labelTxt - ; input - ~a:[ a_value value - ; a_class [ "d-Input"; "d-Network__Input" ] - ; a_name name - ; a_pattern pattern - ] - () - ] - ] + [ label + ~a:[ a_class [ "d-Label" ] ] + [ txt labelTxt + ; input + ~a: + [ a_value value + ; a_class [ "d-Input"; "d-Network__Input" ] + ; a_name name + ; a_pattern pattern + ] + () + ] + ] in let ipv4_value f = if is_static service then - service.ipv4 |> Option.map (fun (ipv4:IPv4.t) -> f ipv4) |> Option.value ~default:"" - else - "" + service.ipv4 + |> Option.map (fun (ipv4 : IPv4.t) -> f ipv4) + |> Option.value ~default:"" + else "" in div - [ p ~a: [ a_class ["d-Note"] ][ - txt "A valid IP address must be in the form of " + [ p + ~a:[ a_class [ "d-Note" ] ] + [ txt "A valid IP address must be in the form of " ; code ~a:[ a_class [ "d-Code" ] ] [ txt "n.n.n.n" ] ; txt "," ; br () ; txt "where n is a number in the range of 0-255." ] - ; div ( ip_input - ~name:"static_ip_address" - ~labelTxt:"Address" - ~value:(ipv4_value(fun ipv4 -> ipv4.address)) - ~pattern:ip_address_regex_pattern - @ ip_input - ~name:"static_ip_netmask" - ~labelTxt:"Netmask" - ~value:(ipv4_value(fun ipv4 -> ipv4.netmask)) - ~pattern:ip_address_regex_pattern - @ ip_input - ~name:"static_ip_gateway" - ~labelTxt:"Gateway" - ~value:(ipv4_value(fun ipv4 -> ipv4.gateway |> Option.value ~default:"")) - ~pattern:ip_address_regex_pattern - @ ip_input - ~name:"static_ip_nameservers" - ~labelTxt:"Nameservers" - ~value:(if is_static service then String.concat ", " service.nameservers else "") - ~pattern:multi_ip_address_regex_pattern - @ [ p ~a:[a_class ["d-Note"]][ - txt "To set multiple nameservers, use a comma separated list of addresses." - ; br () - ; txt "eg. 1.1.1.1, 9.9.9.9" - ] - ] + ; div + (ip_input ~name:"static_ip_address" ~labelTxt:"Address" + ~value:(ipv4_value (fun ipv4 -> ipv4.address)) + ~pattern:ip_address_regex_pattern + @ ip_input ~name:"static_ip_netmask" ~labelTxt:"Netmask" + ~value:(ipv4_value (fun ipv4 -> ipv4.netmask)) + ~pattern:ip_address_regex_pattern + @ ip_input ~name:"static_ip_gateway" ~labelTxt:"Gateway" + ~value: + (ipv4_value (fun ipv4 -> ipv4.gateway |> Option.value ~default:"")) + ~pattern:ip_address_regex_pattern + @ ip_input ~name:"static_ip_nameservers" ~labelTxt:"Nameservers" + ~value: + ( if is_static service then String.concat ", " service.nameservers + else "" ) - ] + ~pattern:multi_ip_address_regex_pattern + @ [ p + ~a:[ a_class [ "d-Note" ] ] + [ txt + "To set multiple nameservers, use a comma separated list of \ + addresses." + ; br () + ; txt "eg. 1.1.1.1, 9.9.9.9" + ] + ] + ) + ] let checked_input cond attrs = input ~a:(if cond then a_checked () :: attrs else attrs) () let toggle_group ~is_enabled ~legend_text ~toggle_field contents = fieldset - ~a:[ a_class ([ "d-Network__ToggleGroup" ] @ if is_enabled then [ "d-Network__ToggleGroup--Enabled" ] else []) ] - ~legend:( - legend - [ label - ~a:[ a_class [ "d-CheckboxLabel" ] ] - [ checked_input - is_enabled - [ a_class [ "d-Checkbox" ] - ; a_input_type `Checkbox - ; a_name toggle_field - ; a_onclick "this.closest('.d-Network__ToggleGroup').classList.toggle('d-Network__ToggleGroup--Enabled', this.checked)" - ] - ; txt legend_text - ] - ] - ) + ~a: + [ a_class + ([ "d-Network__ToggleGroup" ] + @ if is_enabled then [ "d-Network__ToggleGroup--Enabled" ] else [] + ) + ] + ~legend: + (legend + [ label + ~a:[ a_class [ "d-CheckboxLabel" ] ] + [ checked_input is_enabled + [ a_class [ "d-Checkbox" ] + ; a_input_type `Checkbox + ; a_name toggle_field + ; a_onclick + "this.closest('.d-Network__ToggleGroup').classList.toggle('d-Network__ToggleGroup--Enabled', \ + this.checked)" + ] + ; txt legend_text + ] + ] + ) [ fieldset contents ] let connected_form service = div [ form - ~a:[ a_action ("/network/" ^ service.id ^ "/update") - ; a_method `Post - ; Unsafe.string_attrib "is" "disable-after-submit" - ] - [ toggle_group - ~is_enabled:(Option.is_some service.proxy) - ~legend_text:"HTTP Proxy" - ~toggle_field:"proxy_enabled" + ~a: + [ a_action ("/network/" ^ service.id ^ "/update") + ; a_method `Post + ; Unsafe.string_attrib "is" "disable-after-submit" + ] + [ toggle_group + ~is_enabled:(Option.is_some service.proxy) + ~legend_text:"HTTP Proxy" ~toggle_field:"proxy_enabled" [ proxy_form service.proxy ] - ; toggle_group - ~is_enabled:(is_static service) - ~legend_text:"Static IP" + ; toggle_group ~is_enabled:(is_static service) ~legend_text:"Static IP" ~toggle_field:"static_ip_enabled" [ static_ip_form service ] ; input - ~a:[ a_input_type `Submit - ; a_class [ "d-Button" ] - ; a_value "Update" - ] + ~a: + [ a_input_type `Submit; a_class [ "d-Button" ]; a_value "Update" ] () ] ] let unsupported_notice service = - p ~a: [ a_class ["d-Note"] ][ - txt "Connecting to this network is not possible, because it uses an unsupported authentication protocol." + p + ~a:[ a_class [ "d-Note" ] ] + [ txt + "Connecting to this network is not possible, because it uses an \ + unsupported authentication protocol." ; br () - ; txt @@ Printf.sprintf "Available authentication protocols for this network: %s" - (String.concat ", " (List.map - (fun s -> Sexplib.Sexp.to_string (sexp_of_security s)) - service.security)) + ; txt + @@ Printf.sprintf + "Available authentication protocols for this network: %s" + (String.concat ", " + (List.map + (fun s -> Sexplib.Sexp.to_string (sexp_of_security s)) + service.security + ) + ) ] let html service = let is_service_connected = Connman.Service.is_connected service in let is_service_supported = - List.exists (fun e -> List.mem e service.security) [ PSK; WEP; None ] - || - (service.security = []) (* wired connections have this *) + List.exists (fun e -> List.mem e service.security) [ PSK; WEP; None ] + || service.security = [] + (* wired connections have this *) + in + let is_disconnectable = + is_service_connected && service.type' = Connman.Technology.Wifi in - let is_disconnectable = is_service_connected && service.type' = Connman.Technology.Wifi in let icon = match service.strength with - | Some s -> Icon.wifi ~strength:s () - | None -> Icon.ethernet - in - let properties = service - |> sexp_of_t - |> Sexplib.Sexp.to_string_hum + | Some s -> + Icon.wifi ~strength:s () + | None -> + Icon.ethernet in + let properties = service |> sexp_of_t |> Sexplib.Sexp.to_string_hum in let disconnect_button = form - ~a:[ a_action ("/network/" ^ service.id ^ "/remove") - ; a_method `Post - ; Unsafe.string_attrib "is" "disable-after-submit" - ] + ~a: + [ a_action ("/network/" ^ service.id ^ "/remove") + ; a_method `Post + ; Unsafe.string_attrib "is" "disable-after-submit" + ] [ input - ~a:[ a_input_type `Submit - ; a_class [ "d-Button" ] - ; a_value "Forget" - ] + ~a:[ a_input_type `Submit; a_class [ "d-Button" ]; a_value "Forget" ] () ] in - Page.html - ~current_page:Page.Network - ~header:( - Page.header_title - ~back_url:"/network" - ?right_action:(if is_disconnectable then Some disconnect_button else None) - ~icon - [ txt service.name ]) + Page.html ~current_page:Page.Network + ~header: + (Page.header_title ~back_url:"/network" + ?right_action: + (if is_disconnectable then Some disconnect_button else None) + ~icon + [ txt service.name ] + ) (div - [ if is_service_connected then - connected_form service - else if is_service_supported then - not_connected_form service - else - unsupported_notice service - ; div - ~a:[ a_class [ "d-Network__Properties" ] ] - [ h2 ~a:[ a_class [ "d-Title" ] ] [ txt "Service Details" ] - ; pre - ~a:[ a_class [ "d-Preformatted" ] ] - [ txt properties ] - ] - ]) + [ ( if is_service_connected then connected_form service + else if is_service_supported then not_connected_form service + else unsupported_notice service + ) + ; div + ~a:[ a_class [ "d-Network__Properties" ] ] + [ h2 ~a:[ a_class [ "d-Title" ] ] [ txt "Service Details" ] + ; pre ~a:[ a_class [ "d-Preformatted" ] ] [ txt properties ] + ] + ] + ) diff --git a/controller/server/view/network_details_page.mli b/controller/server/view/network_details_page.mli index 1a9af34b..c1f7e029 100644 --- a/controller/server/view/network_details_page.mli +++ b/controller/server/view/network_details_page.mli @@ -1,3 +1 @@ -val html : - Connman.Service.t - -> [> Html_types.html ] Tyxml.Html.elt +val html : Connman.Service.t -> [> Html_types.html ] Tyxml.Html.elt diff --git a/controller/server/view/network_list_page.ml b/controller/server/view/network_list_page.ml index 012c5ec7..560a28ca 100644 --- a/controller/server/view/network_list_page.ml +++ b/controller/server/view/network_list_page.ml @@ -6,25 +6,29 @@ open Protocol_conv_jsonm let service_item ({ id; name; strength; ipv4 } as service) = let icon = match strength with - | Some s -> Icon.wifi ~strength:s () - | None -> Icon.ethernet + | Some s -> + Icon.wifi ~strength:s () + | None -> + Icon.ethernet in - let - classes = - [ "d-NetworkList__Network" ] - @ if Connman.Service.is_connected service then [ "d-NetworkList__Network--Connected" ] else [] + let classes = + [ "d-NetworkList__Network" ] + @ + if Connman.Service.is_connected service then + [ "d-NetworkList__Network--Connected" ] + else [] in li [ a - ~a:[ a_class classes - ; a_href ("/network/" ^ id) - ] + ~a:[ a_class classes; a_href ("/network/" ^ id) ] [ div [ txt name ] - ; (match ipv4 with + ; ( match ipv4 with | Some ipv4_addr -> - div ~a:[ a_class [ "d-NetworkList__Address" ] ] [ txt (ipv4_addr.address) ] + div + ~a:[ a_class [ "d-NetworkList__Address" ] ] + [ txt ipv4_addr.address ] | None -> - space () + space () ) ; div ~a:[ a_class [ "d-NetworkList__Icon" ] ] [ icon ] ; div ~a:[ a_class [ "d-NetworkList__Chevron" ] ] [ txt "ᐳ" ] @@ -32,69 +36,72 @@ let service_item ({ id; name; strength; ipv4 } as service) = ] type params = - { proxy: string option - ; services: Connman.Service.t list - ; interfaces: Network.Interface.t list + { proxy : string option + ; services : Connman.Service.t list + ; interfaces : Network.Interface.t list } - [@@deriving protocol ~driver:(module Jsonm)] +[@@deriving protocol ~driver:(module Jsonm)] let html { proxy; services; interfaces } = let connected_services, available_services = List.partition Connman.Service.is_connected services in - let interfaces_str = interfaces - |> [%sexp_of: Network.Interface.t list] - |> Sexplib.Sexp.to_string_hum + let interfaces_str = + interfaces + |> [%sexp_of: Network.Interface.t list] + |> Sexplib.Sexp.to_string_hum in - Page.html - ~current_page:Page.Network - ~header:( - Page.header_title - ~icon:Icon.world - ~right_action:(a ~a:[ a_href "/network" ; a_class [ "d-Button" ] ] [ txt "Refresh" ]) - [ txt "Network" ]) + Page.html ~current_page:Page.Network + ~header: + (Page.header_title ~icon:Icon.world + ~right_action: + (a ~a:[ a_href "/network"; a_class [ "d-Button" ] ] [ txt "Refresh" ]) + [ txt "Network" ] + ) (div - [ if List.length connected_services = 0 then - txt "" - else - section - [ ul - ~a:[ a_class [ "d-NetworkList" ]; a_role [ "list" ] ] - (List.map service_item connected_services) - ] - - ; Definition.list ( - (match proxy with - | Some p -> - [ Definition.term [ txt "Proxy" ] - ; Definition.description [ txt p ] - ] - | None -> - [] - ) @ - [ Definition.term [ txt "Internet" ] - ; Definition.description - [ div - ~a:[ a_class [ "d-Spinner" ] - ; Unsafe.string_attrib "is" "internet-status" - ] - [] - ] - ] - ) - - ; section - [ h2 ~a:[ a_class [ "d-Title" ] ] [ txt "Available Networks" ] - ; if List.length available_services = 0 then - p ~a:[ a_class [ "d-Paragraph" ] ] [ txt "No networks available" ] - else - ul - ~a:[ a_class [ "d-NetworkList" ]; a_role [ "list" ] ] - (List.map service_item available_services) - ] - - ; section - [ h2 ~a:[ a_class [ "d-Title" ] ] [ txt "Network Interfaces" ] - ; pre ~a: [ a_class [ "d-Preformatted" ] ] [ txt interfaces_str ] - ] - ]) + [ ( if List.length connected_services = 0 then txt "" + else + section + [ ul + ~a:[ a_class [ "d-NetworkList" ]; a_role [ "list" ] ] + (List.map service_item connected_services) + ] + ) + ; Definition.list + (( match proxy with + | Some p -> + [ Definition.term [ txt "Proxy" ] + ; Definition.description [ txt p ] + ] + | None -> + [] + ) + @ [ Definition.term [ txt "Internet" ] + ; Definition.description + [ div + ~a: + [ a_class [ "d-Spinner" ] + ; Unsafe.string_attrib "is" "internet-status" + ] + [] + ] + ] + ) + ; section + [ h2 ~a:[ a_class [ "d-Title" ] ] [ txt "Available Networks" ] + ; ( if List.length available_services = 0 then + p + ~a:[ a_class [ "d-Paragraph" ] ] + [ txt "No networks available" ] + else + ul + ~a:[ a_class [ "d-NetworkList" ]; a_role [ "list" ] ] + (List.map service_item available_services) + ) + ] + ; section + [ h2 ~a:[ a_class [ "d-Title" ] ] [ txt "Network Interfaces" ] + ; pre ~a:[ a_class [ "d-Preformatted" ] ] [ txt interfaces_str ] + ] + ] + ) diff --git a/controller/server/view/network_list_page.mli b/controller/server/view/network_list_page.mli index 2b58a069..aa81285a 100644 --- a/controller/server/view/network_list_page.mli +++ b/controller/server/view/network_list_page.mli @@ -1,12 +1,10 @@ open Protocol_conv_jsonm type params = - { proxy: string option - ; services: Connman.Service.t list - ; interfaces: Network.Interface.t list + { proxy : string option + ; services : Connman.Service.t list + ; interfaces : Network.Interface.t list } - [@@deriving protocol ~driver:(module Jsonm)] +[@@deriving protocol ~driver:(module Jsonm)] -val html : - params - -> [> Html_types.html ] Tyxml.Html.elt +val html : params -> [> Html_types.html ] Tyxml.Html.elt diff --git a/controller/server/view/status_page.ml b/controller/server/view/status_page.ml index 03b63ed5..2699bc77 100644 --- a/controller/server/view/status_page.ml +++ b/controller/server/view/status_page.ml @@ -2,135 +2,141 @@ open Tyxml.Html open Sexplib.Std type rauc_state = - | Status of Rauc.status - | Installing - | Error of string - [@@deriving sexp] + | Status of Rauc.status + | Installing + | Error of string +[@@deriving sexp] type params = - { health: Health.state - ; update: Update.state - ; rauc: rauc_state - ; booted_slot: Rauc.Slot.t + { health : Health.state + ; update : Update.state + ; rauc : rauc_state + ; booted_slot : Rauc.Slot.t } let definition term description = [ Definition.term [ txt term ] - ; Definition.description [ pre ~a: [ a_class [ "d-Preformatted" ] ] [ txt description ] ] + ; Definition.description + [ pre ~a:[ a_class [ "d-Preformatted" ] ] [ txt description ] ] ] let health_fmt s = s |> Health.sexp_of_state |> Sexplib.Sexp.to_string_hum + let update_fmt s = s |> Update.sexp_of_state |> Sexplib.Sexp.to_string_hum + let rauc_fmt s = s |> sexp_of_rauc_state |> Sexplib.Sexp.to_string_hum + let slot_fmt = Rauc.Slot.string_of_t -let opt_elem opt = Option.value ~default:[] @@ Option.map (fun e -> [e]) opt +let opt_elem opt = Option.value ~default:[] @@ Option.map (fun e -> [ e ]) opt let action_form ?confirm_msg action button_label = form - ~a:[ a_action action - ; a_method `Post - ; a_class [ "d-Status__ActionForm" ] - ] + ~a:[ a_action action; a_method `Post; a_class [ "d-Status__ActionForm" ] ] [ input - ~a:([ a_input_type `Submit - ; a_class [ "d-Button" ] - ; a_value button_label - ] @ (opt_elem (Option.map (fun (m) -> - a_onclick (Format.sprintf "return confirm('%s');" m)) - confirm_msg))) + ~a: + ([ a_input_type `Submit + ; a_class [ "d-Button" ] + ; a_value button_label + ] + @ opt_elem + (Option.map + (fun m -> a_onclick (Format.sprintf "return confirm('%s');" m)) + confirm_msg + ) + ) () ] -let note body = div - ~a:[ a_class [ "d-Note" ] ] - [ txt body ] +let note body = div ~a:[ a_class [ "d-Note" ] ] [ txt body ] let reboot_call = - [ note "A new version of PlayOS has been installed, reboot to switch to the new version." - ; action_form "/system/reboot" "Reboot into updated version" - ] + [ note + "A new version of PlayOS has been installed, reboot to switch to the new \ + version." + ; action_form "/system/reboot" "Reboot into updated version" + ] let switch_to_newer_system_call target_slot = - [ note "This machine has an out of date PlayOS version selected as the - default. You can switch to the new version (requires a reboot)." - ; action_form - ("/system/switch/" ^ (slot_fmt target_slot)) - "Switch to newer version and reboot" - ] + [ note + "This machine has an out of date PlayOS version selected as the\n\ + \ default. You can switch to the new version (requires a \ + reboot)." + ; action_form + ("/system/switch/" ^ slot_fmt target_slot) + "Switch to newer version and reboot" + ] let switch_to_older_system_call target_slot = - [ note "You are running the latest version of PlayOS, but you can still - switch back to the older version (requires a reboot)." - ; action_form - ("/system/switch/" ^ (slot_fmt target_slot)) - "Switch to older version and reboot" - ] - -let reinstall_call target_slot = - [ note "The PlayOS installation appears to be faulty, manual system - reinstallation is recommended. Please contact support. You can - attempt to switch to another system slot (requires reboot)." - ; action_form - ("/system/switch/" ^ (slot_fmt target_slot)) - "Switch to other slot and reboot" - ] + [ note + "You are running the latest version of PlayOS, but you can still\n\ + \ switch back to the older version (requires a reboot)." + ; action_form + ("/system/switch/" ^ slot_fmt target_slot) + "Switch to older version and reboot" + ] + +let reinstall_call target_slot = + [ note + "The PlayOS installation appears to be faulty, manual system\n\ + \ reinstallation is recommended. Please contact support. \ + You can\n\ + \ attempt to switch to another system slot (requires \ + reboot)." + ; action_form + ("/system/switch/" ^ slot_fmt target_slot) + "Switch to other slot and reboot" + ] let factory_reset_call = - let confirm_msg = "This will wipe all configuration and login data. Proceed?" - in - [ note "WARNING: Clears all user data and reboots the machine, resulting in a - fresh install state. Will require to manually reconfigure network, - localization and all other settings. Any active sessions and/or - logins will be expired." - ; action_form ~confirm_msg ("/system/factory-reset") "⚠ Factory Reset" - ] - -let other_slot = let open Rauc.Slot in function - | SystemA -> SystemB - | SystemB -> SystemA - -let suggested_action_of_state (update:Update.state) (rauc:rauc_state) booted_slot = - let target_slot = other_slot booted_slot in - match (update.system_status, rauc) with - | (RebootRequired, _) -> - Some (Definition.description reboot_call) - | (OutOfDateVersionSelected, Status _) -> - Some (Definition.description ( - switch_to_newer_system_call target_slot - )) - | (ReinstallRequired, _) -> - Some (Definition.description ( - reinstall_call target_slot - )) - | (UpToDate, Status _) -> - Option.bind update.version_info (fun {booted; inactive; _} -> - if (booted <> inactive) then - Some (Definition.description ( - switch_to_older_system_call target_slot - )) - else - None - ) - | _ -> - None + let confirm_msg = + "This will wipe all configuration and login data. Proceed?" + in + [ note + "WARNING: Clears all user data and reboots the machine, resulting in a\n\ + \ fresh install state. Will require to manually reconfigure \ + network,\n\ + \ localization and all other settings. Any active sessions \ + and/or\n\ + \ logins will be expired." + ; action_form ~confirm_msg "/system/factory-reset" "⚠ Factory Reset" + ] + +let other_slot = + let open Rauc.Slot in + function SystemA -> SystemB | SystemB -> SystemA + +let suggested_action_of_state (update : Update.state) (rauc : rauc_state) + booted_slot = + let target_slot = other_slot booted_slot in + match (update.system_status, rauc) with + | RebootRequired, _ -> + Some (Definition.description reboot_call) + | OutOfDateVersionSelected, Status _ -> + Some (Definition.description (switch_to_newer_system_call target_slot)) + | ReinstallRequired, _ -> + Some (Definition.description (reinstall_call target_slot)) + | UpToDate, Status _ -> + Option.bind update.version_info (fun { booted; inactive; _ } -> + if booted <> inactive then + Some + (Definition.description (switch_to_older_system_call target_slot)) + else None + ) + | _ -> + None let html { health; booted_slot; update; rauc } = -let opt_action = suggested_action_of_state update rauc booted_slot -in - Page.html - ~current_page:Page.SystemStatus - ~header:(Page.header_title - ~icon:Icon.screen - [ txt "System Status" - ]) + let opt_action = suggested_action_of_state update rauc booted_slot in + Page.html ~current_page:Page.SystemStatus + ~header:(Page.header_title ~icon:Icon.screen [ txt "System Status" ]) (Definition.list - (definition "Health" (health_fmt health) - @ definition "Update State" (update_fmt update) - @ opt_elem opt_action - @ definition "RAUC" (rauc_fmt rauc) - @ [ - Definition.term [txt "Factory reset" ] - ; Definition.description factory_reset_call - ] - )) + (definition "Health" (health_fmt health) + @ definition "Update State" (update_fmt update) + @ opt_elem opt_action + @ definition "RAUC" (rauc_fmt rauc) + @ [ Definition.term [ txt "Factory reset" ] + ; Definition.description factory_reset_call + ] + ) + ) diff --git a/controller/server/view/status_page.mli b/controller/server/view/status_page.mli index 2a8306f9..15ba8762 100644 --- a/controller/server/view/status_page.mli +++ b/controller/server/view/status_page.mli @@ -1,15 +1,13 @@ type rauc_state = - | Status of Rauc.status - | Installing - | Error of string + | Status of Rauc.status + | Installing + | Error of string type params = - { health: Health.state - ; update: Update.state - ; rauc: rauc_state - ; booted_slot: Rauc.Slot.t + { health : Health.state + ; update : Update.state + ; rauc : rauc_state + ; booted_slot : Rauc.Slot.t } -val html : - params - -> [> Html_types.html ] Tyxml.Html.elt +val html : params -> [> Html_types.html ] Tyxml.Html.elt diff --git a/controller/tests/server/mocks/dune b/controller/tests/server/mocks/dune index df5d0da2..4c24e882 100644 --- a/controller/tests/server/mocks/dune +++ b/controller/tests/server/mocks/dune @@ -1,5 +1,5 @@ (library - (name test_mocks) - (libraries update alcotest-lwt str) - (preprocess (pps lwt_ppx)) -) + (name test_mocks) + (libraries update alcotest-lwt str) + (preprocess + (pps lwt_ppx))) diff --git a/controller/tests/server/mocks/mock_rauc.ml b/controller/tests/server/mocks/mock_rauc.ml index 1fd54b03..09eae9d3 100644 --- a/controller/tests/server/mocks/mock_rauc.ml +++ b/controller/tests/server/mocks/mock_rauc.ml @@ -1,107 +1,114 @@ open Rauc -type state = { - mutable rauc_status: Rauc.status; - mutable primary_slot: Slot.t option; - mutable booted_slot: Slot.t; -} +type state = + { mutable rauc_status : Rauc.status + ; mutable primary_slot : Slot.t option + ; mutable booted_slot : Slot.t + } let some_status : Rauc.Slot.status = - { - device = "Device"; - state = "Good"; - class' = "class"; - version = "0.0.0"; - installed_timestamp = "2023-01-01T00:00:00Z"; + { device = "Device" + ; state = "Good" + ; class' = "class" + ; version = "0.0.0" + ; installed_timestamp = "2023-01-01T00:00:00Z" } - - class mock failure_generator = - let return a = - let%lwt should_fail = failure_generator () in - if (should_fail) then - raise (Failure "Random test injected failure!") - else - Lwt.return a - in - object (self) - val state : state = { - rauc_status = { a = some_status; b = some_status }; - primary_slot = None; - booted_slot = Slot.SystemA; - } + let return a = + let%lwt should_fail = failure_generator () in + if should_fail then raise (Failure "Random test injected failure!") + else Lwt.return a + in + object (self) + val state : state = + { rauc_status = { a = some_status; b = some_status } + ; primary_slot = None + ; booted_slot = Slot.SystemA + } method set_status slot status = match slot with - | Slot.SystemA -> state.rauc_status <- { state.rauc_status with a = status } - | Slot.SystemB -> state.rauc_status <- { state.rauc_status with b = status } + | Slot.SystemA -> + state.rauc_status <- { state.rauc_status with a = status } + | Slot.SystemB -> + state.rauc_status <- { state.rauc_status with b = status } method set_version slot version = - self#set_status slot {(self#get_slot_status slot) with version = version} + self#set_status slot { (self#get_slot_status slot) with version } method get_status () = state.rauc_status |> return method get_slot_status slot = match slot with - | Slot.SystemA -> state.rauc_status.a - | Slot.SystemB -> state.rauc_status.b + | Slot.SystemA -> + state.rauc_status.a + | Slot.SystemB -> + state.rauc_status.b method set_primary some_slot = state.primary_slot <- some_slot + method get_primary () = state.primary_slot |> return method set_booted_slot slot = state.booted_slot <- slot + method get_booted_slot () = return state.booted_slot method private extract_version bundle_path = - let regex_str = {|.*-\([0-9]+\.[0-9]+\.[0-9]+.*\)\.raucb|} in - let regex = Str.regexp regex_str in - let m = Str.string_match regex bundle_path 0 in - if m then - Str.matched_group 1 bundle_path - else - Alcotest.fail @@ - "Failed to extract version from bundle_path: " ^ bundle_path + let regex_str = {|.*-\([0-9]+\.[0-9]+\.[0-9]+.*\)\.raucb|} in + let regex = Str.regexp regex_str in + let m = Str.string_match regex bundle_path 0 in + if m then Str.matched_group 1 bundle_path + else + Alcotest.fail @@ "Failed to extract version from bundle_path: " + ^ bundle_path (* A bundle is considered valid if it contains it's own version *) method private check_if_bundle_is_valid (bundle_path : string) vsn : unit = - let ic = In_channel.open_text bundle_path in - let contents = In_channel.input_all ic in - let vsn_regex = Str.regexp_string vsn in - try - let _ = Str.search_forward vsn_regex contents 0 in - () - with | _ -> - failwith @@ - Format.sprintf - "Downloaded bundle does not contain own version string inside [%s]" - vsn + let ic = In_channel.open_text bundle_path in + let contents = In_channel.input_all ic in + let vsn_regex = Str.regexp_string vsn in + try + let _ = Str.search_forward vsn_regex contents 0 in + () + with _ -> + failwith + @@ Format.sprintf + "Downloaded bundle does not contain own version string inside [%s]" + vsn method install (bundle_path : string) : unit Lwt.t = - let vsn = self#extract_version bundle_path in - self#check_if_bundle_is_valid bundle_path vsn; - let%lwt booted_slot = self#get_booted_slot () in - let other_slot = match booted_slot with - | Slot.SystemA -> Slot.SystemB - | Slot.SystemB -> Slot.SystemA - in - (* "install" into non-booted slot *) - let () = self#set_status other_slot {some_status with version = vsn} in - (* Note: UpdateService or RAUC bindings do not explicitly set the - primary, but it is part of RAUC's install process, so we simulate it - here too. *) - let () = self#set_primary (Some other_slot) in - return () + let vsn = self#extract_version bundle_path in + self#check_if_bundle_is_valid bundle_path vsn ; + let%lwt booted_slot = self#get_booted_slot () in + let other_slot = + match booted_slot with + | Slot.SystemA -> + Slot.SystemB + | Slot.SystemB -> + Slot.SystemA + in + (* "install" into non-booted slot *) + let () = self#set_status other_slot { some_status with version = vsn } in + (* Note: UpdateService or RAUC bindings do not explicitly set the + primary, but it is part of RAUC's install process, so we simulate it + here too. *) + let () = self#set_primary (Some other_slot) in + return () method mark_good _ = failwith "Not implemented" - method to_module = (module struct + method to_module = + (module struct let get_status = self#get_status + let get_booted_slot = self#get_booted_slot + let mark_good = self#mark_good - let get_primary = self#get_primary - let install = self#install - end : Rauc_service.S) -end + let get_primary = self#get_primary + let install = self#install + end : Rauc_service.S + ) + end diff --git a/controller/tests/server/mocks/mock_update_client.ml b/controller/tests/server/mocks/mock_update_client.ml index e4d95a33..fc10ea63 100644 --- a/controller/tests/server/mocks/mock_update_client.ml +++ b/controller/tests/server/mocks/mock_update_client.ml @@ -1,54 +1,52 @@ -type state = { - mutable latest_version: string; - mutable available_bundles: (string, string) Hashtbl.t ; - mutable base_url: string; -} +type state = + { mutable latest_version : string + ; mutable available_bundles : (string, string) Hashtbl.t + ; mutable base_url : string + } let test_bundle_name = "TEST_PLAYOS_BUNDLE" class mock failure_generator = - let return a = - let%lwt should_fail = failure_generator () in - if (should_fail) then - raise (Failure "Random test injected failure!") - else - Lwt.return a - in - object (self) - val state = { - latest_version = "0.0.0"; - available_bundles = Hashtbl.create 5; - base_url = Config.System.update_url; - } + let return a = + let%lwt should_fail = failure_generator () in + if should_fail then raise (Failure "Random test injected failure!") + else Lwt.return a + in + object (self) + val state = + { latest_version = "0.0.0" + ; available_bundles = Hashtbl.create 5 + ; base_url = Config.System.update_url + } method add_bundle vsn contents = - Hashtbl.add state.available_bundles vsn contents + Hashtbl.add state.available_bundles vsn contents - method remove_bundle vsn = - Hashtbl.remove state.available_bundles vsn + method remove_bundle vsn = Hashtbl.remove state.available_bundles vsn - method set_latest_version vsn = - state.latest_version <- vsn + method set_latest_version vsn = state.latest_version <- vsn method private gen_stored_bundle_path vsn = - let prefix = test_bundle_name ^ "_" in - let suffix = "-" ^ vsn ^ ".raucb" in - let tmp = Filename.temp_file prefix suffix in - tmp + let prefix = test_bundle_name ^ "_" in + let suffix = "-" ^ vsn ^ ".raucb" in + let tmp = Filename.temp_file prefix suffix in + tmp method download vsn = - let contents = Hashtbl.find state.available_bundles vsn in - let tmp = self#gen_stored_bundle_path vsn in - let oc = open_out tmp in - let () = Printf.fprintf oc "%s\n" contents in - let () = close_out oc in - return tmp + let contents = Hashtbl.find state.available_bundles vsn in + let tmp = self#gen_stored_bundle_path vsn in + let oc = open_out tmp in + let () = Printf.fprintf oc "%s\n" contents in + let () = close_out oc in + return tmp - method get_latest_version () = - return state.latest_version + method get_latest_version () = return state.latest_version - method to_module = (module struct + method to_module = + (module struct let download = self#download + let get_latest_version = self#get_latest_version - end : Update_client.S) -end + end : Update_client.S + ) + end diff --git a/controller/tests/server/update/dune b/controller/tests/server/update/dune index 37d612e2..f893015f 100644 --- a/controller/tests/server/update/dune +++ b/controller/tests/server/update/dune @@ -1,29 +1,31 @@ (library - (name update_test_helpers) - (modules helpers scenario outcome) - (libraries update test_mocks) - (preprocess (pps lwt_ppx ppx_sexp_conv)) -) + (name update_test_helpers) + (modules helpers scenario outcome) + (libraries update test_mocks) + (preprocess + (pps lwt_ppx ppx_sexp_conv))) (test (name update_prop_tests) (libraries update_test_helpers qcheck qcheck-alcotest) (modules update_prop_tests) - (preprocess (pps lwt_ppx ppx_sexp_conv)) -) + (preprocess + (pps lwt_ppx ppx_sexp_conv))) (test (name update_tests) (libraries update_test_helpers) (modules update_tests) - (preprocess (pps lwt_ppx ppx_sexp_conv)) -) + (preprocess + (pps lwt_ppx ppx_sexp_conv))) (test (name update_client_tests) (libraries update_client alcotest alcotest-lwt str cohttp-lwt-unix opium) (modules update_client_tests update_client_mock_server) - (preprocess (pps lwt_ppx ppx_sexp_conv)) -) + (preprocess + (pps lwt_ppx ppx_sexp_conv))) -(env (dev (flags :standard -warn-error -A -w -8-27-32-33))) +(env + (dev + (flags :standard -warn-error -A -w -8-27-32-33))) diff --git a/controller/tests/server/update/helpers.ml b/controller/tests/server/update/helpers.ml index 8e1e1891..7a28e915 100644 --- a/controller/tests/server/update/helpers.ml +++ b/controller/tests/server/update/helpers.ml @@ -2,125 +2,120 @@ open Test_mocks (* === Misc helpers === *) -let other_slot slot = match slot with - | Rauc.Slot.SystemA -> Rauc.Slot.SystemB - | Rauc.Slot.SystemB -> Rauc.Slot.SystemA +let other_slot slot = + match slot with + | Rauc.Slot.SystemA -> + Rauc.Slot.SystemB + | Rauc.Slot.SystemB -> + Rauc.Slot.SystemA let slot_to_string = function - | Rauc.Slot.SystemA -> "SystemA" - | Rauc.Slot.SystemB -> "SystemB" + | Rauc.Slot.SystemA -> + "SystemA" + | Rauc.Slot.SystemB -> + "SystemB" -let version_info_to_string ({latest; booted; inactive}: Update.version_info) = - Format.sprintf "{latest=%s booted=%s inactive=%s}" - (Semver.to_string latest) - (Semver.to_string booted) - (Semver.to_string inactive) +let version_info_to_string ({ latest; booted; inactive } : Update.version_info) + = + Format.sprintf "{latest=%s booted=%s inactive=%s}" (Semver.to_string latest) + (Semver.to_string booted) + (Semver.to_string inactive) let statefmt (state : Update.state) : string = state |> Update.sexp_of_state |> Sexplib.Sexp.to_string_hum (* === Mock init and setup === *) -let default_test_config : Update.config = { - error_backoff_duration = 0.01; - check_for_updates_interval = 0.05; -} +let default_test_config : Update.config = + { error_backoff_duration = 0.01; check_for_updates_interval = 0.05 } -type test_context = { - update_client : Mock_update_client.mock; - rauc : Mock_rauc.mock; - update_service : (module Update.UpdateService) -} +type test_context = + { update_client : Mock_update_client.mock + ; rauc : Mock_rauc.mock + ; update_service : (module Update.UpdateService) + } (* see [init_test_deps] for usage *) -let no_failure_gen = fun () -> Lwt.return false +let no_failure_gen () = Lwt.return false (* Creates fresh instances of UpdateClient, Rauc_service and UpdateService. `failure_gen_*` can be used to specify random fault injection generators, see `update_prop_tests.ml` for usage *) -let init_test_deps - ?(failure_gen_rauc=no_failure_gen) ?(failure_gen_upd=no_failure_gen) - ?(test_config=default_test_config) - () : test_context = - let update_client = new Mock_update_client.mock failure_gen_upd in - let rauc = new Mock_rauc.mock failure_gen_rauc in - let module TestUpdateServiceDeps = struct - module ClientI = (val update_client#to_module) - module RaucI = (val rauc#to_module) - let config = test_config - end in - let module TestUpdateService = Update.Make (TestUpdateServiceDeps) in - { - update_client = update_client; - rauc = rauc; - update_service = (module TestUpdateService) - } - -type system_slot_spec = { - booted_slot: Rauc.Slot.t; - primary_slot: Rauc.Slot.t Option.t; - input_versions: Update.version_info; -} - -let slot_spec_to_string {booted_slot; primary_slot; input_versions} = - Format.sprintf - "booted=%s\tprimary=%s\tvsns%s" - (slot_to_string booted_slot) - (Option.map slot_to_string primary_slot |> Option.value ~default:"-") - (version_info_to_string input_versions) - -let setup_mocks_from_system_slot_spec {rauc; update_client} case = - let {booted_slot; primary_slot; input_versions} = case in - - let booted_version = Semver.to_string input_versions.booted in - let secondary_version = Semver.to_string input_versions.inactive in - let upstream_version = Semver.to_string input_versions.latest in - - let inactive_slot = other_slot booted_slot in - - rauc#set_version booted_slot booted_version; - rauc#set_version inactive_slot secondary_version; - rauc#set_booted_slot booted_slot; - rauc#set_primary primary_slot; - update_client#set_latest_version upstream_version; - () +let init_test_deps ?(failure_gen_rauc = no_failure_gen) + ?(failure_gen_upd = no_failure_gen) ?(test_config = default_test_config) () + : test_context = + let update_client = new Mock_update_client.mock failure_gen_upd in + let rauc = new Mock_rauc.mock failure_gen_rauc in + let module TestUpdateServiceDeps = struct + module ClientI = (val update_client#to_module) + + module RaucI = (val rauc#to_module) + + let config = test_config + end in + let module TestUpdateService = Update.Make (TestUpdateServiceDeps) in + { update_client; rauc; update_service = (module TestUpdateService) } + +type system_slot_spec = + { booted_slot : Rauc.Slot.t + ; primary_slot : Rauc.Slot.t Option.t + ; input_versions : Update.version_info + } + +let slot_spec_to_string { booted_slot; primary_slot; input_versions } = + Format.sprintf "booted=%s\tprimary=%s\tvsns%s" + (slot_to_string booted_slot) + (Option.map slot_to_string primary_slot |> Option.value ~default:"-") + (version_info_to_string input_versions) + +let setup_mocks_from_system_slot_spec { rauc; update_client } case = + let { booted_slot; primary_slot; input_versions } = case in + let booted_version = Semver.to_string input_versions.booted in + let secondary_version = Semver.to_string input_versions.inactive in + let upstream_version = Semver.to_string input_versions.latest in + let inactive_slot = other_slot booted_slot in + rauc#set_version booted_slot booted_version ; + rauc#set_version inactive_slot secondary_version ; + rauc#set_booted_slot booted_slot ; + rauc#set_primary primary_slot ; + update_client#set_latest_version upstream_version ; + () (* === Test data and data generation === *) let v1 = Semver.of_string "1.0.0" |> Option.get + let v2 = Semver.of_string "2.0.0" |> Option.get + let v3 = Semver.of_string "3.0.0" |> Option.get let flatten_tuple (a, (b, c)) = (a, b, c) let product l1 l2 = - List.concat_map - (fun e1 -> List.map (fun e2 -> (e1, e2)) l2) - l1 + List.concat_map (fun e1 -> List.map (fun e2 -> (e1, e2)) l2) l1 + +let product3 l1 l2 l3 = product l1 (product l2 l3) |> List.map flatten_tuple + +let possible_versions = [ v1; v2; v3 ] -let product3 l1 l2 l3 = - product l1 (product l2 l3) |> - List.map flatten_tuple +let possible_booted_slots = [ Rauc.Slot.SystemA; Rauc.Slot.SystemB ] -let possible_versions = [v1; v2; v3] -let possible_booted_slots = [Rauc.Slot.SystemA; Rauc.Slot.SystemB] -let possible_primary_slots = - None :: List.map (Option.some) possible_booted_slots +let possible_primary_slots = None :: List.map Option.some possible_booted_slots -let vsn_triple_to_version_info (latest, booted, inactive) : Update.version_info = { - latest = latest; - booted = booted; - inactive = inactive; -} +let vsn_triple_to_version_info (latest, booted, inactive) : Update.version_info + = + { latest; booted; inactive } let all_possible_slot_spec_combos = - let vsn_triples = product3 possible_versions possible_versions possible_versions in - let combos = product3 vsn_triples possible_booted_slots possible_primary_slots in - List.map (fun (vsns, booted_slot, primary_slot) -> - let vsn_info = vsn_triple_to_version_info vsns in - { - booted_slot = booted_slot; - primary_slot = primary_slot; - input_versions = vsn_info; - }) - combos + let vsn_triples = + product3 possible_versions possible_versions possible_versions + in + let combos = + product3 vsn_triples possible_booted_slots possible_primary_slots + in + List.map + (fun (vsns, booted_slot, primary_slot) -> + let vsn_info = vsn_triple_to_version_info vsns in + { booted_slot; primary_slot; input_versions = vsn_info } + ) + combos diff --git a/controller/tests/server/update/outcome.ml b/controller/tests/server/update/outcome.ml index 6ef48c54..d2cdbc41 100644 --- a/controller/tests/server/update/outcome.ml +++ b/controller/tests/server/update/outcome.ml @@ -3,41 +3,52 @@ *) type expected_outcomes = - | DoNothingOrProduceWarning - | InstallVsn of (Semver.t [@sexp.opaque]) - [@@deriving sexp] + | DoNothingOrProduceWarning + | InstallVsn of (Semver.t[@sexp.opaque]) +[@@deriving sexp] (* Similar to `evaluate_version_info` in `update.ml`, but reduced to only two outcomes: installing the update or not installing the update. *) -let slot_spec_to_outcome ({booted_slot; primary_slot; input_versions} : Helpers.system_slot_spec) = - let booted_is_out_of_date = - (Semver.compare input_versions.booted input_versions.latest) = -1 - in - let inactive_is_out_of_date = - (Semver.compare input_versions.inactive input_versions.latest) = -1 - in - if booted_is_out_of_date && inactive_is_out_of_date then - InstallVsn input_versions.latest - else - DoNothingOrProduceWarning +let slot_spec_to_outcome + ({ booted_slot; primary_slot; input_versions } : Helpers.system_slot_spec) = + let booted_is_out_of_date = + Semver.compare input_versions.booted input_versions.latest = -1 + in + let inactive_is_out_of_date = + Semver.compare input_versions.inactive input_versions.latest = -1 + in + if booted_is_out_of_date && inactive_is_out_of_date then + InstallVsn input_versions.latest + else DoNothingOrProduceWarning (* Checks if the state returned by UpdateService matches the expected outcome as determined by [slot_spec_to_outcome] *) let state_matches_expected_outcome state outcome = - let open Update in - match (outcome, state.system_status, state.process_state) with - | (InstallVsn v1, NeedsUpdate, Downloading v2) -> - (Semver.to_string v1) = v2 && - Option.fold ~none:false ~some:(fun v -> v.latest = v1) state.version_info - | (InstallVsn _, _, _) -> false - | (DoNothingOrProduceWarning, UpdateError (ErrorGettingVersionInfo _), Sleeping _) -> true - | (DoNothingOrProduceWarning, UpToDate, Sleeping _) -> true - | (DoNothingOrProduceWarning, OutOfDateVersionSelected, Sleeping _) -> true - | (DoNothingOrProduceWarning, RebootRequired, Sleeping _) -> true - | (DoNothingOrProduceWarning, ReinstallRequired, Sleeping _) -> true - (* all the other state combos are treated as errors *) - | (DoNothingOrProduceWarning, _, _) -> false + let open Update in + match (outcome, state.system_status, state.process_state) with + | InstallVsn v1, NeedsUpdate, Downloading v2 -> + Semver.to_string v1 = v2 + && Option.fold ~none:false + ~some:(fun v -> v.latest = v1) + state.version_info + | InstallVsn _, _, _ -> + false + | ( DoNothingOrProduceWarning + , UpdateError (ErrorGettingVersionInfo _) + , Sleeping _ ) -> + true + | DoNothingOrProduceWarning, UpToDate, Sleeping _ -> + true + | DoNothingOrProduceWarning, OutOfDateVersionSelected, Sleeping _ -> + true + | DoNothingOrProduceWarning, RebootRequired, Sleeping _ -> + true + | DoNothingOrProduceWarning, ReinstallRequired, Sleeping _ -> + true + (* all the other state combos are treated as errors *) + | DoNothingOrProduceWarning, _, _ -> + false (** Tests if the input UpdateService run with the given [Helpers.system_slot_spec] [case] scenario produces the expected outcome state (defined by @@ -47,29 +58,27 @@ let state_matches_expected_outcome state outcome = combinations lead to the correct install/no-install action. *) let test_slot_spec case = - let expected_outcome = slot_spec_to_outcome case in - let expected_outcome_str = - (sexp_of_expected_outcomes expected_outcome |> Sexplib.Sexp.to_string) - in - let test_case_descr = - Format.sprintf - "%s\t->\t%s" - (Helpers.slot_spec_to_string case) - expected_outcome_str - in - Alcotest_lwt.test_case test_case_descr `Quick (fun _ () -> - let mocks = Helpers.init_test_deps () in - - let () = Helpers.setup_mocks_from_system_slot_spec mocks case in - - let module UpdateServiceI = (val mocks.update_service) in - let%lwt out_state = UpdateServiceI.run_step Update.initial_state in - if state_matches_expected_outcome out_state expected_outcome then - Lwt.return () - else - Alcotest.fail (Format.sprintf - "Reached state [%s] does not match expected outcome [%s]" - (Helpers.statefmt out_state) - expected_outcome_str - ) - ) + let expected_outcome = slot_spec_to_outcome case in + let expected_outcome_str = + sexp_of_expected_outcomes expected_outcome |> Sexplib.Sexp.to_string + in + let test_case_descr = + Format.sprintf "%s\t->\t%s" + (Helpers.slot_spec_to_string case) + expected_outcome_str + in + Alcotest_lwt.test_case test_case_descr `Quick (fun _ () -> + let mocks = Helpers.init_test_deps () in + let () = Helpers.setup_mocks_from_system_slot_spec mocks case in + let module UpdateServiceI = (val mocks.update_service) in + let%lwt out_state = UpdateServiceI.run_step Update.initial_state in + if state_matches_expected_outcome out_state expected_outcome then + Lwt.return () + else + Alcotest.fail + (Format.sprintf + "Reached state [%s] does not match expected outcome [%s]" + (Helpers.statefmt out_state) + expected_outcome_str + ) + ) diff --git a/controller/tests/server/update/scenario.ml b/controller/tests/server/update/scenario.ml index acd6f422..ba3f726a 100644 --- a/controller/tests/server/update/scenario.ml +++ b/controller/tests/server/update/scenario.ml @@ -3,7 +3,9 @@ *) type action_descr = string + type action_check = Update.state -> bool Lwt.t + type mock_update = unit -> unit type scenario_spec = @@ -11,54 +13,56 @@ type scenario_spec = | ActionDone of action_descr * action_check | UpdateMock of mock_update -let specfmt spec = match spec with - | StateReached s -> "StateReached: " ^ (Helpers.statefmt s); - | ActionDone (descr, c) -> "ActionDone: " ^ descr; - | UpdateMock _ -> "UpdateMock: " +let specfmt spec = + match spec with + | StateReached s -> + "StateReached: " ^ Helpers.statefmt s + | ActionDone (descr, c) -> + "ActionDone: " ^ descr + | UpdateMock _ -> + "UpdateMock: " let _WILDCARD_PAT = "<..>" (* string equality, but the magic pattern `<..>` is treated - as a placeholder for any sub-string. The implementation converts the - `expected` string to a regex where the magic pattern is replaced with ".*", - while being careful to `Str.quote` the rest of the string to not accidentally - treat them as regex expressions. + as a placeholder for any sub-string. The implementation converts the + `expected` string to a regex where the magic pattern is replaced with ".*", + while being careful to `Str.quote` the rest of the string to not accidentally + treat them as regex expressions. *) let str_match_with_magic_pat expected actual = - let open Str in - let magic_pattern = regexp_string _WILDCARD_PAT in - let exp_parts = full_split magic_pattern expected in - let exp_regexp = regexp @@ String.concat "" @@ List.map (fun (p) -> - match p with - | Text a -> quote a - | Delim _ -> ".*" - ) exp_parts in - string_match exp_regexp actual 0 - + let open Str in + let magic_pattern = regexp_string _WILDCARD_PAT in + let exp_parts = full_split magic_pattern expected in + let exp_regexp = + regexp + @@ String.concat "" + @@ List.map + (fun p -> match p with Text a -> quote a | Delim _ -> ".*") + exp_parts + in + string_match exp_regexp actual 0 let testable_state = - let state_to_str s = - Update.sexp_of_state s - (* using _hum instead of _mach, because _mach seems to remove - whitespace between atoms in some cases *) - |> Sexplib.Sexp.to_string_hum - (* ignore whitespace differences *) - |> Str.global_replace (Str.regexp_string "\n") "" - |> Str.global_replace (Str.regexp "[ ]+") " " - in - let state_formatter out inp = - Format.fprintf out "%s" (state_to_str inp) - in - let state_eq expected actual = - (expected == actual) || ( - str_match_with_magic_pat - (* Using string repr is a horrible hack, but avoids having to - pattern match on every variant in the state ADT *) - (state_to_str expected) - (state_to_str actual) - ) - in - Alcotest.testable state_formatter state_eq + let state_to_str s = + Update.sexp_of_state s + (* using _hum instead of _mach, because _mach seems to remove + whitespace between atoms in some cases *) + |> Sexplib.Sexp.to_string_hum + (* ignore whitespace differences *) + |> Str.global_replace (Str.regexp_string "\n") "" + |> Str.global_replace (Str.regexp "[ ]+") " " + in + let state_formatter out inp = Format.fprintf out "%s" (state_to_str inp) in + let state_eq expected actual = + expected == actual + || str_match_with_magic_pat + (* Using string repr is a horrible hack, but avoids having to + pattern match on every variant in the state ADT *) + (state_to_str expected) + (state_to_str actual) + in + Alcotest.testable state_formatter state_eq let interpret_spec (state : Update.state) (spec : scenario_spec) = match spec with @@ -67,93 +71,94 @@ let interpret_spec (state : Update.state) (spec : scenario_spec) = | ActionDone (descr, f) -> let%lwt rez = f state in Lwt.return @@ Alcotest.(check bool) (specfmt spec) true rez - | UpdateMock f -> Lwt.return @@ f () + | UpdateMock f -> + Lwt.return @@ f () let is_state_spec s = match s with StateReached _ -> true | _ -> false + let is_mock_spec s = match s with UpdateMock _ -> true | _ -> false let rec lwt_while cond expr = - if (cond ()) then - let%lwt () = expr () in - lwt_while cond expr - else - Lwt.return () + if cond () then + let%lwt () = expr () in + lwt_while cond expr + else Lwt.return () let check_state expected_state_sequence prev_state cur_state = let spec = Queue.pop expected_state_sequence in (* after a callback first spec should always be the next state we expect *) if not (is_state_spec spec) then - failwith @@ "Expected a state spec, but got " ^ specfmt spec ^ " - bad spec?"; - + failwith + @@ "Expected a state spec, but got " + ^ specfmt spec + ^ " - bad spec?" ; (* check if state spec matches the prev_state (i.e. initial state) *) let%lwt () = interpret_spec prev_state spec in - (* progress forward until we either reach the end or we hit a state spec, which means we have to progress the state machine *) lwt_while (fun () -> - (not (Queue.is_empty expected_state_sequence)) - && not (is_state_spec @@ Queue.peek expected_state_sequence)) - + (not (Queue.is_empty expected_state_sequence)) + && not (is_state_spec @@ Queue.peek expected_state_sequence) + ) (fun () -> - let next_spec = Queue.pop expected_state_sequence in - interpret_spec prev_state next_spec + let next_spec = Queue.pop expected_state_sequence in + interpret_spec prev_state next_spec ) let rec consume_mock_specs state_seq cur_state = let next = Queue.peek_opt state_seq in match next with - | Some spec when is_mock_spec spec -> - let _ = Queue.pop state_seq in - let%lwt () = interpret_spec cur_state spec in - consume_mock_specs state_seq cur_state - | _ -> Lwt.return () - -let rec run_test_scenario (test_context: Helpers.test_context) expected_state_sequence cur_state = + | Some spec when is_mock_spec spec -> + let _ = Queue.pop state_seq in + let%lwt () = interpret_spec cur_state spec in + consume_mock_specs state_seq cur_state + | _ -> + Lwt.return () + +let rec run_test_scenario (test_context : Helpers.test_context) + expected_state_sequence cur_state = (* special case for specifying `MockUpdate`'s BEFORE any - `StateReached` spec's to enable initialization of mocks *) + `StateReached` spec's to enable initialization of mocks *) let _ = consume_mock_specs expected_state_sequence cur_state in let module UpdateServiceI = (val test_context.update_service) in - - if not (Queue.is_empty expected_state_sequence) then ( + if not (Queue.is_empty expected_state_sequence) then let%lwt next_state = UpdateServiceI.run_step cur_state in let%lwt () = check_state expected_state_sequence cur_state next_state in - run_test_scenario test_context expected_state_sequence next_state) + run_test_scenario test_context expected_state_sequence next_state else Lwt.return () (* NOTE: this is almost the same as the `Outcome.test_slot_spec, except that it expects only a system state outcome and uses the `run_test_scenario` machinery. *) -let scenario_from_system_spec - ?(booted_slot=Rauc.Slot.SystemA) - ?(primary_slot=(Some Rauc.Slot.SystemA)) - ~(input_versions:Update.version_info) - (expected_system_status:Update.system_status) = - +let scenario_from_system_spec ?(booted_slot = Rauc.Slot.SystemA) + ?(primary_slot = Some Rauc.Slot.SystemA) + ~(input_versions : Update.version_info) + (expected_system_status : Update.system_status) = let init_state = Update.initial_state in - let expected_state: Update.state = { - version_info = Some input_versions; - system_status = expected_system_status; - process_state = Sleeping Helpers.default_test_config.check_for_updates_interval; - } in - + let expected_state : Update.state = + { version_info = Some input_versions + ; system_status = expected_system_status + ; process_state = + Sleeping Helpers.default_test_config.check_for_updates_interval + } + in fun mocks -> - let expected_state_sequence = - [ - UpdateMock (fun () -> - Helpers.setup_mocks_from_system_slot_spec mocks { - booted_slot = booted_slot; - primary_slot = primary_slot; - input_versions = input_versions - } - ); - StateReached Update.initial_state; - StateReached expected_state; - ] - in - (expected_state_sequence, init_state) + let expected_state_sequence = + [ UpdateMock + (fun () -> + Helpers.setup_mocks_from_system_slot_spec mocks + { booted_slot; primary_slot; input_versions } + ) + ; StateReached Update.initial_state + ; StateReached expected_state + ] + in + (expected_state_sequence, init_state) let run scenario_gen = - let test_context = Helpers.init_test_deps () in - let (scenario, init_state) = scenario_gen test_context in - run_test_scenario test_context (Queue.of_seq (List.to_seq scenario)) init_state + let test_context = Helpers.init_test_deps () in + let scenario, init_state = scenario_gen test_context in + run_test_scenario test_context + (Queue.of_seq (List.to_seq scenario)) + init_state diff --git a/controller/tests/server/update/update_client_mock_server.ml b/controller/tests/server/update/update_client_mock_server.ml index 259b0c0a..cd01c3c1 100644 --- a/controller/tests/server/update/update_client_mock_server.ml +++ b/controller/tests/server/update/update_client_mock_server.ml @@ -8,124 +8,108 @@ open Opium.Std (* binds on port 0 and returns (loopback addr, port) pair *) let get_random_available_port () = - let protocol_id = 0 in - let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM protocol_id in - let addr = Unix.ADDR_INET ( - Unix.inet_addr_loopback, - 0 - ) in - let () = Unix.bind sock addr in - let Unix.ADDR_INET (real_addr, real_port) = Unix.getsockname sock in - let () = Unix.close sock in - (Unix.string_of_inet_addr real_addr, real_port) + let protocol_id = 0 in + let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM protocol_id in + let addr = Unix.ADDR_INET (Unix.inet_addr_loopback, 0) in + let () = Unix.bind sock addr in + let (Unix.ADDR_INET (real_addr, real_port)) = Unix.getsockname sock in + let () = Unix.close sock in + (Unix.string_of_inet_addr real_addr, real_port) -type state = { - latest_version: string; - available_bundles: (string, string) Hashtbl.t ; -} +type state = + { latest_version : string + ; available_bundles : (string, string) Hashtbl.t + } -type range = (int Option.t) * (int Option.t) +type range = int Option.t * int Option.t -let mock_server () = object (self) - val mutable state = ref { - latest_version = "0.0.0"; - available_bundles = Hashtbl.create 5 - } +let mock_server () = + object (self) + val mutable state = + ref { latest_version = "0.0.0"; available_bundles = Hashtbl.create 5 } method add_bundle vsn contents = - Hashtbl.add !state.available_bundles vsn contents + Hashtbl.add !state.available_bundles vsn contents method remove_bundle vsn contents = - Hashtbl.remove !state.available_bundles vsn + Hashtbl.remove !state.available_bundles vsn method set_latest_version vsn = - state := {!state with latest_version = vsn} + state := { !state with latest_version = vsn } method private get_latest_handler _req = - let resp = Response.of_string_body - !state.latest_version - in - Lwt.return resp + let resp = Response.of_string_body !state.latest_version in + Lwt.return resp method private extract_range_bytes req : range = - let headers = Request.headers req in - let range = Cohttp.Header.get headers "Range" in - match range with - | Some range_str -> begin - try - let regex = Str.regexp "bytes=\\([0-9]*\\)-\\([0-9]*\\)" in - let m = Str.string_match regex range_str 0 in - let r_str_to_opt s = - if (String.length s > 0) then - Some (int_of_string s) - else - None - in - if (m) then - let range_start = Str.matched_group 1 range_str in - let range_end = Str.matched_group 2 range_str in - (r_str_to_opt range_start, - r_str_to_opt range_end) - else - failwith @@ "Unsupported range string: " ^ range_str - with - | e -> - failwith @@ - "Failed to parse range headers: " ^ (Printexc.to_string e) - end - | None -> (None, None) + let headers = Request.headers req in + let range = Cohttp.Header.get headers "Range" in + match range with + | Some range_str -> ( + try + let regex = Str.regexp "bytes=\\([0-9]*\\)-\\([0-9]*\\)" in + let m = Str.string_match regex range_str 0 in + let r_str_to_opt s = + if String.length s > 0 then Some (int_of_string s) else None + in + if m then + let range_start = Str.matched_group 1 range_str in + let range_end = Str.matched_group 2 range_str in + (r_str_to_opt range_start, r_str_to_opt range_end) + else failwith @@ "Unsupported range string: " ^ range_str + with e -> + failwith @@ "Failed to parse range headers: " ^ Printexc.to_string e + ) + | None -> + (None, None) method private range_resp (range_start, range_end) bundle = - let bundle_bytes = String.to_bytes bundle in - let total = Bytes.length bundle_bytes in - let b_start = Option.value ~default:0 range_start in - let b_end = Option.value ~default:total range_end in - let bytes_trunc = Bytes.sub bundle_bytes b_start (b_end-b_start) in - (bytes_trunc, (b_start, b_end, total)) + let bundle_bytes = String.to_bytes bundle in + let total = Bytes.length bundle_bytes in + let b_start = Option.value ~default:0 range_start in + let b_end = Option.value ~default:total range_end in + let bytes_trunc = Bytes.sub bundle_bytes b_start (b_end - b_start) in + (bytes_trunc, (b_start, b_end, total)) method private download_bundle_handler req = - let vsn = Router.param req "vsn" in - let range = self#extract_range_bytes req in - let bundle = Hashtbl.find_opt !state.available_bundles vsn in - let resp = match bundle with - | Some bund -> begin - match range with - | (None, None) -> Response.of_string_body bund - | _ -> - let (bundle_trunc, (b_start, b_end, b_total)) = - self#range_resp range bund in - let body = bundle_trunc - |> Bytes.to_string - |> Body.of_string - in - let headers = Cohttp.Header.of_list - [( - "Content-Range", - (Format.sprintf - "bytes %d-%d/%d" - b_start b_end b_total - ) - )] - in - Response.create - ~headers - ~body - () - end - | None -> Response.of_string_body ~code:`Not_found - "Bundle version not found" - in - Lwt.return resp + let vsn = Router.param req "vsn" in + let range = self#extract_range_bytes req in + let bundle = Hashtbl.find_opt !state.available_bundles vsn in + let resp = + match bundle with + | Some bund -> ( + match range with + | None, None -> + Response.of_string_body bund + | _ -> + let bundle_trunc, (b_start, b_end, b_total) = + self#range_resp range bund + in + let body = bundle_trunc |> Bytes.to_string |> Body.of_string in + let headers = + Cohttp.Header.of_list + [ ( "Content-Range" + , Format.sprintf "bytes %d-%d/%d" b_start b_end b_total + ) + ] + in + Response.create ~headers ~body () + ) + | None -> + Response.of_string_body ~code:`Not_found "Bundle version not found" + in + Lwt.return resp method run () = - let (addr, port) = get_random_available_port () in + let addr, port = get_random_available_port () in let server_url = Format.sprintf "http://%s:%d/" addr port in - let server = App.empty - |> App.port port - |> App.get "/latest" self#get_latest_handler - |> App.get "/ready" (fun (_) -> Lwt.return @@ Response.create ()) - |> App.get "/:vsn/:bundle" self#download_bundle_handler - |> App.start + let server = + App.empty + |> App.port port + |> App.get "/latest" self#get_latest_handler + |> App.get "/ready" (fun _ -> Lwt.return @@ Response.create ()) + |> App.get "/:vsn/:bundle" self#download_bundle_handler + |> App.start in (server_url, server) -end + end diff --git a/controller/tests/server/update/update_client_tests.ml b/controller/tests/server/update/update_client_tests.ml index de1eaaeb..c4a0725a 100644 --- a/controller/tests/server/update/update_client_tests.ml +++ b/controller/tests/server/update/update_client_tests.ml @@ -9,181 +9,184 @@ using the mock server as a proxy. *) open Update_client + open Update_client_mock_server let setup_log () = - Fmt_tty.setup_std_outputs (); - Logs.set_level @@ Some Logs.Debug; - Logs.set_reporter (Logs_fmt.reporter ()); + Fmt_tty.setup_std_outputs () ; + Logs.set_level @@ Some Logs.Debug ; + Logs.set_reporter (Logs_fmt.reporter ()) ; () type proxy_param = - | NoProxy - | UseMockServer - | Custom of string + | NoProxy + | UseMockServer + | Custom of string (* returns (proxy, server_url) pair *) let process_proxy_spec spec server_url = - match spec with - | NoProxy -> - (None, server_url) - | UseMockServer -> - (* pretend mock server is a proxy, i.e. use an invalid base_url, - and the actual server_url for the proxy *) - ( - (server_url |> Option.some), - (* Note: DO NOT use https here, because curl will attempt - to CONNECT and then this whole setup doesn't work *) - (Uri.of_string "http://some-invalid-url.local/") - ) - | Custom p -> - ( - (p |> Uri.of_string |> Option.some), - server_url - ) + match spec with + | NoProxy -> + (None, server_url) + | UseMockServer -> + (* pretend mock server is a proxy, i.e. use an invalid base_url, + and the actual server_url for the proxy *) + ( server_url |> Option.some + , (* Note: DO NOT use https here, because curl will attempt + to CONNECT and then this whole setup doesn't work *) + Uri.of_string "http://some-invalid-url.local/" + ) + | Custom p -> + (p |> Uri.of_string |> Option.some, server_url) let rec wait_for_mock_server ?(timeout = 0.2) ?(remaining_tries = 3) url = - let status_endpoint = Uri.of_string (url ^ "ready") in - let%lwt rez = Curl.request status_endpoint in - match rez with - | Curl.RequestSuccess _ -> Lwt.return () - | Curl.RequestFailure err -> - let err_msg = (Curl.pretty_print_error err) in - print_endline ("MockServer not up, err was: " ^ err_msg); - if (remaining_tries > 0) then - let%lwt () = Lwt_unix.sleep timeout in - wait_for_mock_server - ~timeout:(timeout *. 2.0) (* exponential backoff *) - ~remaining_tries:(remaining_tries - 1) url - else - let err_msg = "HTTP mock server did not become ready, last error: " ^ (Curl.pretty_print_error err) in - Lwt.fail (Failure err_msg) + let status_endpoint = Uri.of_string (url ^ "ready") in + let%lwt rez = Curl.request status_endpoint in + match rez with + | Curl.RequestSuccess _ -> + Lwt.return () + | Curl.RequestFailure err -> + let err_msg = Curl.pretty_print_error err in + print_endline ("MockServer not up, err was: " ^ err_msg) ; + if remaining_tries > 0 then + let%lwt () = Lwt_unix.sleep timeout in + wait_for_mock_server + ~timeout:(timeout *. 2.0) (* exponential backoff *) + ~remaining_tries:(remaining_tries - 1) url + else + let err_msg = + "HTTP mock server did not become ready, last error: " + ^ Curl.pretty_print_error err + in + Lwt.fail (Failure err_msg) let run_test_case ?(proxy = NoProxy) switch f = - let server = mock_server () in - let (server_url, server_task) = server#run () in - let%lwt () = wait_for_mock_server server_url in - Lwt_switch.add_hook (Some switch) - (fun () -> Lwt.return @@ Lwt.cancel server_task); - let (proxy_url, base_url) = - process_proxy_spec proxy (Uri.of_string server_url) in - let get_proxy () = Lwt.return proxy_url in - let temp_dir = Format.sprintf "%s/upd-client-test-%d" - (Filename.get_temp_dir_name ()) - (Unix.gettimeofday () |> fun x -> (x *. 1000.0) |> int_of_float) - in - let () = Sys.mkdir temp_dir 0o777 in - let module DepsI = (val Update_client.make_deps - ~download_dir:temp_dir get_proxy base_url) in - let module UpdateC = Update_client.Make (DepsI) in - f server (module UpdateC : S) + let server = mock_server () in + let server_url, server_task = server#run () in + let%lwt () = wait_for_mock_server server_url in + Lwt_switch.add_hook (Some switch) (fun () -> + Lwt.return @@ Lwt.cancel server_task + ) ; + let proxy_url, base_url = + process_proxy_spec proxy (Uri.of_string server_url) + in + let get_proxy () = Lwt.return proxy_url in + let temp_dir = + Format.sprintf "%s/upd-client-test-%d" + (Filename.get_temp_dir_name ()) + (Unix.gettimeofday () |> fun x -> x *. 1000.0 |> int_of_float) + in + let () = Sys.mkdir temp_dir 0o777 in + let module DepsI = + (val Update_client.make_deps ~download_dir:temp_dir get_proxy base_url) + in + let module UpdateC = Update_client.Make (DepsI) in + f server (module UpdateC : S) let test_get_version_ok server (module Client : S) = - let expected_version = "1.0.0" in - let () = server#set_latest_version expected_version in - let%lwt vsn = Client.get_latest_version () in - Lwt.return @@ Alcotest.(check string) - "Latest version is fetched" - expected_version - vsn + let expected_version = "1.0.0" in + let () = server#set_latest_version expected_version in + let%lwt vsn = Client.get_latest_version () in + Lwt.return + @@ Alcotest.(check string) "Latest version is fetched" expected_version vsn let read_file file = In_channel.with_open_bin file In_channel.input_all let test_download_bundle_ok server (module Client : S) = - let version = "1.0.0" in - let bundle = "BUNDLE_CONTENTS" in - let () = server#add_bundle version bundle in - let%lwt bundle_path = Client.download version in - Alcotest.(check bool) - "Bundle file is downloaded and saved" - (Sys.file_exists bundle_path) - true; - Alcotest.(check string) - "Bundle contents are correct" - (read_file bundle_path) - bundle; - Lwt.return () + let version = "1.0.0" in + let bundle = "BUNDLE_CONTENTS" in + let () = server#add_bundle version bundle in + let%lwt bundle_path = Client.download version in + Alcotest.(check bool) + "Bundle file is downloaded and saved" + (Sys.file_exists bundle_path) + true ; + Alcotest.(check string) + "Bundle contents are correct" (read_file bundle_path) bundle ; + Lwt.return () (* NOTE: This test checks that the client resumes the download from where it finished, but also it is an example of why naive resuming might not be a great idea.*) let test_resume_bundle_download server (module Client : S) = - let version = "1.0.0" in - let bundle_contents = "BUNDLE_CONTENTS: 123" in - let () = server#add_bundle version bundle_contents in - let%lwt bundle_path = Client.download version in - Alcotest.(check string) - "Bundle contents are only partial" - (read_file bundle_path) - bundle_contents; - - (* NOTE that bundle_contents is not a prefix of bundle_contents_extra ! - This is on purpose: to check that download client does not simply - overwrite the downloaded file, otherwise we would not be testing - whether it really resumes the downloaded. It also illustrates - that curl / HTTP range request do not involve any integrity checking, - bytes are just being appended to the end. - *) - let bundle_contents_extra = "BUNDLE_CONTENTS: 111999" in - let () = server#add_bundle version bundle_contents_extra in - - let%lwt bundle_path = Client.download version in - Alcotest.(check string) - "Bundle contents are resumed, not overwritten" - (read_file bundle_path) - (* NOTE: this is not the same as [bundle_contents_extra], it is only - the last bytes of it beyond the length of [bundle_contents] *) - "BUNDLE_CONTENTS: 123999"; - Lwt.return () + let version = "1.0.0" in + let bundle_contents = "BUNDLE_CONTENTS: 123" in + let () = server#add_bundle version bundle_contents in + let%lwt bundle_path = Client.download version in + Alcotest.(check string) + "Bundle contents are only partial" (read_file bundle_path) bundle_contents ; + (* NOTE that bundle_contents is not a prefix of bundle_contents_extra ! + This is on purpose: to check that download client does not simply + overwrite the downloaded file, otherwise we would not be testing + whether it really resumes the downloaded. It also illustrates + that curl / HTTP range request do not involve any integrity checking, + bytes are just being appended to the end. + *) + let bundle_contents_extra = "BUNDLE_CONTENTS: 111999" in + let () = server#add_bundle version bundle_contents_extra in + let%lwt bundle_path = Client.download version in + Alcotest.(check string) + "Bundle contents are resumed, not overwritten" (read_file bundle_path) + (* NOTE: this is not the same as [bundle_contents_extra], it is only + the last bytes of it beyond the length of [bundle_contents] *) + "BUNDLE_CONTENTS: 123999" ; + Lwt.return () (* invalid proxy URL is set in the `run_test_case` function, see below *) let test_invalid_proxy_fail _ (module Client : S) = Lwt.try_bind Client.get_latest_version (fun _ -> - Alcotest.fail "Get version was supposed to fail due to invalid proxy") + Alcotest.fail "Get version was supposed to fail due to invalid proxy" + ) (function | Failure exn -> Alcotest.(check bool) "Curl raised an exception about invalid proxy" (Str.string_match (Str.regexp ".*Could not resolve proxy.*") exn 0) - true; + true ; Lwt.return () | other_exn -> - Alcotest.fail @@ "Got unexpected exception: " - ^ Printexc.to_string other_exn) + Alcotest.fail + @@ "Got unexpected exception: " + ^ Printexc.to_string other_exn + ) let () = let () = setup_log () in (* All tests cases are run with proxy setup and without to verify it works always *) - let test_cases = [ - ("Get latest version", test_get_version_ok); - ("Download bundle", test_download_bundle_ok); - ("Resume download works", test_resume_bundle_download); - ] in + let test_cases = + [ ("Get latest version", test_get_version_ok) + ; ("Download bundle", test_download_bundle_ok) + ; ("Resume download works", test_resume_bundle_download) + ] + in (* An extra case to check that proxy settings are honored in general *) - let invalid_proxy_case = Alcotest_lwt.test_case - "Invalid proxy specified" `Quick - (fun switch () -> + let invalid_proxy_case = + Alcotest_lwt.test_case "Invalid proxy specified" `Quick (fun switch () -> run_test_case ~proxy:(Custom "http://not-a-proxy.internal") switch - test_invalid_proxy_fail) + test_invalid_proxy_fail + ) in Lwt_main.run @@ Alcotest_lwt.run "Basic tests" - [ - ( "without-proxy", - List.map (fun (name, test_f) -> - Alcotest_lwt.test_case name `Quick - (fun switch () -> run_test_case switch test_f)) - test_cases - ); - ( "with-proxy", - invalid_proxy_case - :: - (List.map (fun (name, test_f) -> - Alcotest_lwt.test_case name `Quick - (fun switch () -> run_test_case ~proxy:UseMockServer switch test_f)) - test_cases - ) - ); + [ ( "without-proxy" + , List.map + (fun (name, test_f) -> + Alcotest_lwt.test_case name `Quick (fun switch () -> + run_test_case switch test_f + ) + ) + test_cases + ) + ; ( "with-proxy" + , invalid_proxy_case + :: List.map + (fun (name, test_f) -> + Alcotest_lwt.test_case name `Quick (fun switch () -> + run_test_case ~proxy:UseMockServer switch test_f + ) + ) + test_cases + ) ] diff --git a/controller/tests/server/update/update_prop_tests.ml b/controller/tests/server/update/update_prop_tests.ml index 7d6f9b37..c8814cb7 100644 --- a/controller/tests/server/update/update_prop_tests.ml +++ b/controller/tests/server/update/update_prop_tests.ml @@ -6,19 +6,14 @@ module Helpers = Update_test_helpers.Helpers On n+1th and subsequent invocations always returns [false]. Thread safe. *) let failure_seq_to_f seq = - let a = Array.of_list seq in - let l = List.length seq in - let c_mvar = Lwt_mvar.create 0 in - fun () -> begin - let%lwt c = Lwt_mvar.take c_mvar in - let v = Array.get a c in - let%lwt () = Lwt_mvar.put c_mvar (c+1) in - if (c < l) then - Lwt.return v - else - Lwt.return false - end - + let a = Array.of_list seq in + let l = List.length seq in + let c_mvar = Lwt_mvar.create 0 in + fun () -> + let%lwt c = Lwt_mvar.take c_mvar in + let v = Array.get a c in + let%lwt () = Lwt_mvar.put c_mvar (c + 1) in + if c < l then Lwt.return v else Lwt.return false (* Configures mocks to randomly fail and tests whether UpdateService gracefully handles them and always goes back to the initial (`GettingVersionInfo`) @@ -34,101 +29,95 @@ let failure_seq_to_f seq = code is mostly "linear" Lwt.binds, so this should not happen in practice. *) let test_random_failure_case = - let max_failures = (QCheck2.Gen.pure 10) in - let rand_failure_sequence_upd_client = - QCheck2.Gen.(list_size max_failures bool) in - let rand_failure_sequence_rauc = - QCheck2.Gen.(list_size max_failures bool) in - let rand_spec = QCheck2.Gen.(no_shrink @@ oneofl Helpers.all_possible_slot_spec_combos) in - let gen = (QCheck2.Gen.triple - rand_failure_sequence_upd_client - rand_failure_sequence_rauc - rand_spec) in - - let print_t (seq_upd, seq_rauc, inp_case) = - let fail_seq_to_str seq = - List.map (function | true -> "x" | false -> "_") seq |> - String.concat "" in - let test_case_descr = Helpers.slot_spec_to_string inp_case in - Format.sprintf - "System setup: %s\n\ - Injected Update Client failures (%d): %s\n\ - Injected RAUC failures (%d): %s\n" - test_case_descr - (List.length @@ List.filter (Fun.id) seq_upd) (fail_seq_to_str seq_upd) - (List.length @@ List.filter (Fun.id) seq_rauc) (fail_seq_to_str seq_rauc) + let max_failures = QCheck2.Gen.pure 10 in + let rand_failure_sequence_upd_client = + QCheck2.Gen.(list_size max_failures bool) + in + let rand_failure_sequence_rauc = QCheck2.Gen.(list_size max_failures bool) in + let rand_spec = + QCheck2.Gen.(no_shrink @@ oneofl Helpers.all_possible_slot_spec_combos) + in + let gen = + QCheck2.Gen.triple rand_failure_sequence_upd_client + rand_failure_sequence_rauc rand_spec + in + let print_t (seq_upd, seq_rauc, inp_case) = + let fail_seq_to_str seq = + List.map (function true -> "x" | false -> "_") seq |> String.concat "" in - let test_check (seq_upd, seq_rauc, inp_case) = - let failure_gen_upd = failure_seq_to_f seq_upd in - let failure_gen_rauc = failure_seq_to_f seq_rauc in - let test_config = { - Update.error_backoff_duration = 0.001; - Update.check_for_updates_interval = 0.002; - } in - let mocks = Helpers.init_test_deps - ~failure_gen_upd - ~failure_gen_rauc - ~test_config - () - in - let () = Helpers.setup_mocks_from_system_slot_spec mocks inp_case in - let module UpdateServiceI = (val mocks.update_service) in - let () = Printexc.record_backtrace true in - let run s = Lwt_main.run @@ Lwt_result.catch - (fun () -> UpdateServiceI.run_step s) in - let state_seq = Queue.create () in - let state_seq_to_str state_seq = - (String.concat " -> " @@ (List.map Helpers.statefmt @@ - List.of_seq (Queue.to_seq state_seq) - )) - in - let rec do_while ?(c=0) loop_lim cur_state = - Queue.push cur_state state_seq; - let out = run cur_state in - match out with - | (Error e) -> - QCheck2.Test.fail_reportf - "Update Service crashed (possibly due to an injected \ - exception), see specified source code line in the \ - backtrace for the callsite which caused the crash:\n\ - Exception: %s\n\ - Backtace: %s\n\ - State sequence: %s -> exception\n" - (Printexc.to_string e) - (Printexc.get_backtrace ()) - (state_seq_to_str state_seq) - - | Ok ({process_state = Update.GettingVersionInfo; _} as state) -> - Queue.push state state_seq; - true - | (Ok state) -> - if (c < loop_lim) then - do_while ~c:(c+1) loop_lim state - else - QCheck2.Test.fail_reportf - "Did not reach GettingVersionInfo \ - in %d iterations, state transitions:\n\ - %s\n" - loop_lim - (state_seq_to_str state_seq) - in - do_while 5 Update.initial_state + let test_case_descr = Helpers.slot_spec_to_string inp_case in + Format.sprintf + "System setup: %s\n\ + Injected Update Client failures (%d): %s\n\ + Injected RAUC failures (%d): %s\n" + test_case_descr + (List.length @@ List.filter Fun.id seq_upd) + (fail_seq_to_str seq_upd) + (List.length @@ List.filter Fun.id seq_rauc) + (fail_seq_to_str seq_rauc) + in + let test_check (seq_upd, seq_rauc, inp_case) = + let failure_gen_upd = failure_seq_to_f seq_upd in + let failure_gen_rauc = failure_seq_to_f seq_rauc in + let test_config = + { Update.error_backoff_duration = 0.001 + ; Update.check_for_updates_interval = 0.002 + } + in + let mocks = + Helpers.init_test_deps ~failure_gen_upd ~failure_gen_rauc ~test_config () + in + let () = Helpers.setup_mocks_from_system_slot_spec mocks inp_case in + let module UpdateServiceI = (val mocks.update_service) in + let () = Printexc.record_backtrace true in + let run s = + Lwt_main.run @@ Lwt_result.catch (fun () -> UpdateServiceI.run_step s) + in + let state_seq = Queue.create () in + let state_seq_to_str state_seq = + String.concat " -> " + @@ List.map Helpers.statefmt + @@ List.of_seq (Queue.to_seq state_seq) + in + let rec do_while ?(c = 0) loop_lim cur_state = + Queue.push cur_state state_seq ; + let out = run cur_state in + match out with + | Error e -> + QCheck2.Test.fail_reportf + "Update Service crashed (possibly due to an injected exception), \ + see specified source code line in the backtrace for the callsite \ + which caused the crash:\n\ + Exception: %s\n\ + Backtace: %s\n\ + State sequence: %s -> exception\n" + (Printexc.to_string e) + (Printexc.get_backtrace ()) + (state_seq_to_str state_seq) + | Ok ({ process_state = Update.GettingVersionInfo; _ } as state) -> + Queue.push state state_seq ; true + | Ok state -> + if c < loop_lim then do_while ~c:(c + 1) loop_lim state + else + QCheck2.Test.fail_reportf + "Did not reach GettingVersionInfo in %d iterations, state \ + transitions:\n\ + %s\n" + loop_lim + (state_seq_to_str state_seq) in - QCheck2.Test.make - ~count:10_000 - ~name:"UpdateService never crashes" - ~print:print_t - gen - test_check + do_while 5 Update.initial_state + in + QCheck2.Test.make ~count:10_000 ~name:"UpdateService never crashes" + ~print:print_t gen test_check let () = let argv_with_verbose = Array.append Sys.argv [| "--verbose" |] in Alcotest.run ~argv:argv_with_verbose ~and_exit:false "UpdateService qcheck/prop tests" - [ - ( "Fault injection test", - [ - QCheck_alcotest.to_alcotest ~verbose:true ~long:true - test_random_failure_case; - ] ); + [ ( "Fault injection test" + , [ QCheck_alcotest.to_alcotest ~verbose:true ~long:true + test_random_failure_case + ] + ) ] diff --git a/controller/tests/server/update/update_tests.ml b/controller/tests/server/update/update_tests.ml index ee34ef4f..10e7c20e 100644 --- a/controller/tests/server/update/update_tests.ml +++ b/controller/tests/server/update/update_tests.ml @@ -3,252 +3,270 @@ open Test_mocks open Update_test_helpers (* Main test scenario: full update process *) -let both_out_of_date ({update_client; rauc}: Helpers.test_context) = +let both_out_of_date ({ update_client; rauc } : Helpers.test_context) = let booted_version = "10.0.0" in let inactive_version = "9.0.0" in let upstream_version = "10.0.2" in - let vsn_info = { - booted = Semver.of_string booted_version |> Option.get; - inactive = Semver.of_string inactive_version |> Option.get; - latest = Semver.of_string upstream_version |> Option.get; - } in + let vsn_info = + { booted = Semver.of_string booted_version |> Option.get + ; inactive = Semver.of_string inactive_version |> Option.get + ; latest = Semver.of_string upstream_version |> Option.get + } + in let expected_bundle_name vsn = - Mock_update_client.test_bundle_name ^ Scenario._WILDCARD_PAT ^ vsn ^ Scenario._WILDCARD_PAT + Mock_update_client.test_bundle_name ^ Scenario._WILDCARD_PAT ^ vsn + ^ Scenario._WILDCARD_PAT + in + let base_expected_state = + { version_info = Some vsn_info + ; system_status = NeedsUpdate + ; process_state = GettingVersionInfo + } in - - let base_expected_state = { - version_info = Some vsn_info; - system_status = NeedsUpdate; - process_state = GettingVersionInfo - } in - let expected_state_sequence = - [ - Scenario.UpdateMock (fun () -> - rauc#set_version SystemA booted_version; - rauc#set_version SystemB inactive_version; - rauc#set_booted_slot SystemA; - - update_client#add_bundle upstream_version - ("BUNDLE_CONTENTS: " ^ upstream_version); - update_client#set_latest_version upstream_version; - ); - Scenario.StateReached Update.initial_state; - Scenario.StateReached {base_expected_state with process_state = Downloading upstream_version}; - Scenario.StateReached {base_expected_state with - process_state = (Installing (Scenario._WILDCARD_PAT ^ expected_bundle_name upstream_version)); - }; - Scenario.ActionDone - ( "bundle was installed into secondary slot", - fun _ -> + [ Scenario.UpdateMock + (fun () -> + rauc#set_version SystemA booted_version ; + rauc#set_version SystemB inactive_version ; + rauc#set_booted_slot SystemA ; + update_client#add_bundle upstream_version + ("BUNDLE_CONTENTS: " ^ upstream_version) ; + update_client#set_latest_version upstream_version + ) + ; Scenario.StateReached Update.initial_state + ; Scenario.StateReached + { base_expected_state with + process_state = Downloading upstream_version + } + ; Scenario.StateReached + { base_expected_state with + process_state = + Installing + (Scenario._WILDCARD_PAT ^ expected_bundle_name upstream_version) + } + ; Scenario.ActionDone + ( "bundle was installed into secondary slot" + , fun _ -> let status = rauc#get_slot_status SystemB in let () = Alcotest.(check string) "Secondary slot has the newly downloaded bundle's version" upstream_version status.version in - Lwt.return true ); - Scenario.StateReached {base_expected_state with - version_info = None; - process_state = GettingVersionInfo; - }; - Scenario.StateReached { - version_info = Some {vsn_info with inactive = vsn_info.latest }; - system_status = RebootRequired; - process_state = Sleeping Helpers.default_test_config.check_for_updates_interval; - }; + Lwt.return true + ) + ; Scenario.StateReached + { base_expected_state with + version_info = None + ; process_state = GettingVersionInfo + } + ; Scenario.StateReached + { version_info = Some { vsn_info with inactive = vsn_info.latest } + ; system_status = RebootRequired + ; process_state = + Sleeping Helpers.default_test_config.check_for_updates_interval + } ] in (expected_state_sequence, Update.initial_state) -let delete_downloaded_bundle_on_err ({update_client; rauc}: Helpers.test_context) = +let delete_downloaded_bundle_on_err + ({ update_client; rauc } : Helpers.test_context) = let inactive_version = "9.0.0" in let booted_version = inactive_version in let upstream_version = "10.0.0" in - - let vsn_info = { - booted = Semver.of_string booted_version |> Option.get; - inactive = Semver.of_string inactive_version |> Option.get; - latest = Semver.of_string upstream_version |> Option.get; - } in - let init_state = { - system_status = NeedsUpdate; - version_info = Some vsn_info; - process_state = Downloading upstream_version; - } in + let vsn_info = + { booted = Semver.of_string booted_version |> Option.get + ; inactive = Semver.of_string inactive_version |> Option.get + ; latest = Semver.of_string upstream_version |> Option.get + } + in + let init_state = + { system_status = NeedsUpdate + ; version_info = Some vsn_info + ; process_state = Downloading upstream_version + } + in let expected_bundle_name vsn = - Mock_update_client.test_bundle_name ^ Scenario._WILDCARD_PAT ^ vsn ^ Scenario._WILDCARD_PAT + Mock_update_client.test_bundle_name ^ Scenario._WILDCARD_PAT ^ vsn + ^ Scenario._WILDCARD_PAT in - let expected_state_sequence = - [ - Scenario.UpdateMock (fun () -> - rauc#set_version SystemB inactive_version; - rauc#set_booted_slot SystemA; - (* bundles that do not contain their own version will be treated - as invalid by mock RAUC *) - update_client#add_bundle upstream_version "CORRUPT_BUNDLE_CONTENTS" - ); - Scenario.StateReached init_state; - Scenario.StateReached {init_state with process_state = - (Installing (Scenario._WILDCARD_PAT ^ expected_bundle_name upstream_version)); - }; - Scenario.ActionDone - ( "bundle was deleted from path due to installation error", - fun ({process_state = Installing path; _}) -> + [ Scenario.UpdateMock + (fun () -> + rauc#set_version SystemB inactive_version ; + rauc#set_booted_slot SystemA ; + (* bundles that do not contain their own version will be treated + as invalid by mock RAUC *) + update_client#add_bundle upstream_version "CORRUPT_BUNDLE_CONTENTS" + ) + ; Scenario.StateReached init_state + ; Scenario.StateReached + { init_state with + process_state = + Installing + (Scenario._WILDCARD_PAT ^ expected_bundle_name upstream_version) + } + ; Scenario.ActionDone + ( "bundle was deleted from path due to installation error" + , fun { process_state = Installing path; _ } -> let status = rauc#get_slot_status SystemB in Alcotest.(check string) - "Inactive slot remains in the same version" - inactive_version status.version; + "Inactive slot remains in the same version" inactive_version + status.version ; Alcotest.(check bool) - "Downloaded corrupt bundle was deleted" - false (Sys.file_exists path); - Lwt.return true ); - Scenario.StateReached {init_state with - process_state = Sleeping Helpers.default_test_config.error_backoff_duration; - system_status = UpdateError (ErrorInstalling Scenario._WILDCARD_PAT); - }; - Scenario.StateReached {init_state with - process_state = GettingVersionInfo; - system_status = UpdateError (ErrorInstalling Scenario._WILDCARD_PAT); - }; + "Downloaded corrupt bundle was deleted" false + (Sys.file_exists path) ; + Lwt.return true + ) + ; Scenario.StateReached + { init_state with + process_state = + Sleeping Helpers.default_test_config.error_backoff_duration + ; system_status = UpdateError (ErrorInstalling Scenario._WILDCARD_PAT) + } + ; Scenario.StateReached + { init_state with + process_state = GettingVersionInfo + ; system_status = UpdateError (ErrorInstalling Scenario._WILDCARD_PAT) + } ] in (expected_state_sequence, init_state) - let sleep_on_get_version_err _ () = let always_fail_gen () = Lwt.return true in - let { update_service ; _}: Helpers.test_context = Helpers.init_test_deps - ~failure_gen_upd:always_fail_gen () + let { update_service; _ } : Helpers.test_context = + Helpers.init_test_deps ~failure_gen_upd:always_fail_gen () in let module UpdateServiceI = (val update_service) in let init_state = Update.initial_state in - let expected_state = { - version_info = None; - system_status = UpdateError (ErrorGettingVersionInfo Scenario._WILDCARD_PAT); - process_state = Sleeping Helpers.default_test_config.error_backoff_duration; - } in + let expected_state = + { version_info = None + ; system_status = + UpdateError (ErrorGettingVersionInfo Scenario._WILDCARD_PAT) + ; process_state = + Sleeping Helpers.default_test_config.error_backoff_duration + } + in let%lwt out_state = UpdateServiceI.run_step init_state in - Lwt.return @@ Alcotest.check Scenario.testable_state - "Output state matches" - expected_state - out_state - + Lwt.return + @@ Alcotest.check Scenario.testable_state "Output state matches" + expected_state out_state let sleep_on_download_err _ () = let always_fail_gen () = Lwt.return true in - let { update_service ; _}: Helpers.test_context = Helpers.init_test_deps - ~failure_gen_upd:always_fail_gen () + let { update_service; _ } : Helpers.test_context = + Helpers.init_test_deps ~failure_gen_upd:always_fail_gen () in let module UpdateServiceI = (val update_service) in - let init_state: Update.state = { - version_info = Some - { latest = Helpers.v2; booted = Helpers.v1; inactive = Helpers.v1; }; - system_status = NeedsUpdate; - process_state = Downloading (Semver.to_string Helpers.v2); - } in - let expected_state = { - version_info = None; - system_status = UpdateError (ErrorDownloading Scenario._WILDCARD_PAT); - process_state = Sleeping Helpers.default_test_config.error_backoff_duration; - } in + let init_state : Update.state = + { version_info = + Some { latest = Helpers.v2; booted = Helpers.v1; inactive = Helpers.v1 } + ; system_status = NeedsUpdate + ; process_state = Downloading (Semver.to_string Helpers.v2) + } + in + let expected_state = + { version_info = None + ; system_status = UpdateError (ErrorDownloading Scenario._WILDCARD_PAT) + ; process_state = + Sleeping Helpers.default_test_config.error_backoff_duration + } + in let%lwt out_state = UpdateServiceI.run_step init_state in - Lwt.return @@ Alcotest.check Scenario.testable_state - "Output state matches" - expected_state - out_state + Lwt.return + @@ Alcotest.check Scenario.testable_state "Output state matches" + expected_state out_state let both_newer_than_upstream = - let input_versions = { - booted = Helpers.v3; - inactive = Helpers.v2; - latest = Helpers.v1; - } in + let input_versions = + { booted = Helpers.v3; inactive = Helpers.v2; latest = Helpers.v1 } + in let expected_state = UpToDate in Scenario.scenario_from_system_spec ~input_versions expected_state let booted_newer_secondary_older = - let input_versions = { - latest = Helpers.v2; - booted = Helpers.v3; - inactive = Helpers.v1; - } in + let input_versions = + { latest = Helpers.v2; booted = Helpers.v3; inactive = Helpers.v1 } + in let expected_state = UpToDate in Scenario.scenario_from_system_spec ~input_versions expected_state let booted_older_secondary_newer = - let input_versions = { - latest = Helpers.v2; - booted = Helpers.v1; - inactive = Helpers.v3; - } in + let input_versions = + { latest = Helpers.v2; booted = Helpers.v1; inactive = Helpers.v3 } + in let expected_state = OutOfDateVersionSelected in Scenario.scenario_from_system_spec ~input_versions expected_state let booted_current_secondary_current = - let input_versions = { - latest = Helpers.v2; - booted = Helpers.v2; - inactive = Helpers.v2; - } in + let input_versions = + { latest = Helpers.v2; booted = Helpers.v2; inactive = Helpers.v2 } + in let expected_state = UpToDate in Scenario.scenario_from_system_spec ~input_versions expected_state let booted_current_secondary_older = - let input_versions = { - latest = Helpers.v2; - booted = Helpers.v2; - inactive = Helpers.v1; - } in + let input_versions = + { latest = Helpers.v2; booted = Helpers.v2; inactive = Helpers.v1 } + in let expected_state = UpToDate in Scenario.scenario_from_system_spec ~input_versions expected_state let booted_older_secondary_current = - let input_versions = { - latest = Helpers.v2; - booted = Helpers.v1; - inactive = Helpers.v2; - } in + let input_versions = + { latest = Helpers.v2; booted = Helpers.v1; inactive = Helpers.v2 } + in let expected_state = OutOfDateVersionSelected in Scenario.scenario_from_system_spec ~input_versions expected_state let () = Lwt_main.run @@ Alcotest_lwt.run "UpdateService tests" - [ - ( "Main cases, booted = primary", - [ - (* BOOTED = PRIMARY in all these *) + [ ( "Main cases, booted = primary" + , [ (* BOOTED = PRIMARY in all these *) Alcotest_lwt.test_case "Both slots out of date -> Update" `Quick - (fun _ () -> Scenario.run both_out_of_date); - Alcotest_lwt.test_case "Both slots newer than upstream -> UpToDate" - `Quick (fun _ () -> Scenario.run both_newer_than_upstream); - Alcotest_lwt.test_case + (fun _ () -> Scenario.run both_out_of_date + ) + ; Alcotest_lwt.test_case "Both slots newer than upstream -> UpToDate" + `Quick (fun _ () -> Scenario.run both_newer_than_upstream + ) + ; Alcotest_lwt.test_case "Booted slot current, inactive older -> UpToDate" `Quick - (fun _ () -> Scenario.run booted_current_secondary_older); - Alcotest_lwt.test_case + (fun _ () -> Scenario.run booted_current_secondary_older + ) + ; Alcotest_lwt.test_case "Booted slot older, inactive current -> UpToDate" `Quick - (fun _ () -> Scenario.run booted_older_secondary_current); - Alcotest_lwt.test_case + (fun _ () -> Scenario.run booted_older_secondary_current + ) + ; Alcotest_lwt.test_case "Booted slot current, inactive current -> UpToDate" `Quick - (fun _ () -> Scenario.run booted_current_secondary_current); - Alcotest_lwt.test_case + (fun _ () -> Scenario.run booted_current_secondary_current + ) + ; Alcotest_lwt.test_case "Booted slot newer, inactive older -> UpToDate" `Quick - (fun _ () -> Scenario.run booted_newer_secondary_older); - Alcotest_lwt.test_case + (fun _ () -> Scenario.run booted_newer_secondary_older + ) + ; Alcotest_lwt.test_case "Booted slot older, inactive newer -> OutOfDateVersionSelected" - `Quick (fun _ () -> Scenario.run booted_older_secondary_newer); - ] ); - ( "Error handling", - [ - Alcotest_lwt.test_case "Delete downloaded bundle on install error" - `Quick (fun _ () -> Scenario.run delete_downloaded_bundle_on_err); - Alcotest_lwt.test_case "Update enters sleep after get version error" - `Quick sleep_on_get_version_err; - Alcotest_lwt.test_case "Update enters sleep after get download error" - `Quick sleep_on_get_version_err; - ] ); - ( "All version/slot combinations", - List.map Outcome.test_slot_spec Helpers.all_possible_slot_spec_combos ); + `Quick (fun _ () -> Scenario.run booted_older_secondary_newer + ) + ] + ) + ; ( "Error handling" + , [ Alcotest_lwt.test_case "Delete downloaded bundle on install error" + `Quick (fun _ () -> Scenario.run delete_downloaded_bundle_on_err + ) + ; Alcotest_lwt.test_case + "Update enters sleep after get version error" `Quick + sleep_on_get_version_err + ; Alcotest_lwt.test_case + "Update enters sleep after get download error" `Quick + sleep_on_get_version_err + ] + ) + ; ( "All version/slot combinations" + , List.map Outcome.test_slot_spec Helpers.all_possible_slot_spec_combos + ) ] From 91c258c388c3985d718baf26fc7c74ca06ea2647 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ignas=20Vy=C5=A1niauskas?= Date: Thu, 28 Nov 2024 14:21:43 +0200 Subject: [PATCH 4/7] Fix some multiline string formatting --- controller/bindings/connman/connman.ml | 15 +++++--------- controller/server/view/status_page.ml | 27 +++++++++++--------------- 2 files changed, 16 insertions(+), 26 deletions(-) diff --git a/controller/bindings/connman/connman.ml b/controller/bindings/connman/connman.ml index 79e1b4dd..d2028b47 100644 --- a/controller/bindings/connman/connman.ml +++ b/controller/bindings/connman/connman.ml @@ -684,14 +684,11 @@ module Service = struct Lwt.fail_with (Printf.sprintf "Connection failed, unknown error reported by manager: %s\n\ - \ DBus connect exception: %s" err - (Printexc.to_string exn) + DBus connect exception: %s" err (Printexc.to_string exn) ) | Error exn, Some (AgentError err) -> Lwt.fail_with - (Printf.sprintf - "Connection failed. %s\n\ - \ DBus connect exception: %s" + (Printf.sprintf "Connection failed. %s\nDBus connect exception: %s" (Agent.agent_error_msg err) (Printexc.to_string exn) ) @@ -700,9 +697,8 @@ module Service = struct (Printf.sprintf "Connection failed, none of the available authentication \ protocols are supported.\n\ - \ Available protocols: %s\n\ - \ Supported protocols: %s\n\ - \ " + Available protocols: %s\n\ + Supported protocols: %s" (String.concat ", " @@ List.map string_of_security service.security) (String.concat ", " @@ List.map string_of_security supported_security_protocols @@ -719,8 +715,7 @@ module Service = struct | Error exn, None -> Lwt.fail_with (Printf.sprintf - "Connection to network failed.\n\ - \ DBus connect exception: %s" + "Connection to network failed.\nDBus connect exception: %s" (Printexc.to_string exn) ) diff --git a/controller/server/view/status_page.ml b/controller/server/view/status_page.ml index 2699bc77..2c42df49 100644 --- a/controller/server/view/status_page.ml +++ b/controller/server/view/status_page.ml @@ -59,9 +59,8 @@ let reboot_call = let switch_to_newer_system_call target_slot = [ note - "This machine has an out of date PlayOS version selected as the\n\ - \ default. You can switch to the new version (requires a \ - reboot)." + "This machine has an out of date PlayOS version selected as the default. \ + You can switch to the new version (requires a reboot)." ; action_form ("/system/switch/" ^ slot_fmt target_slot) "Switch to newer version and reboot" @@ -69,8 +68,8 @@ let switch_to_newer_system_call target_slot = let switch_to_older_system_call target_slot = [ note - "You are running the latest version of PlayOS, but you can still\n\ - \ switch back to the older version (requires a reboot)." + "You are running the latest version of PlayOS, but you can still switch \ + back to the older version (requires a reboot)." ; action_form ("/system/switch/" ^ slot_fmt target_slot) "Switch to older version and reboot" @@ -78,11 +77,9 @@ let switch_to_older_system_call target_slot = let reinstall_call target_slot = [ note - "The PlayOS installation appears to be faulty, manual system\n\ - \ reinstallation is recommended. Please contact support. \ - You can\n\ - \ attempt to switch to another system slot (requires \ - reboot)." + "The PlayOS installation appears to be faulty, manual system \ + reinstallation is recommended. Please contact support. You can attempt \ + to switch to another system slot (requires reboot)." ; action_form ("/system/switch/" ^ slot_fmt target_slot) "Switch to other slot and reboot" @@ -93,12 +90,10 @@ let factory_reset_call = "This will wipe all configuration and login data. Proceed?" in [ note - "WARNING: Clears all user data and reboots the machine, resulting in a\n\ - \ fresh install state. Will require to manually reconfigure \ - network,\n\ - \ localization and all other settings. Any active sessions \ - and/or\n\ - \ logins will be expired." + "WARNING: Clears all user data and reboots the machine, resulting in a \ + fresh install state. Will require to manually reconfigure network, \ + localization and all other settings. Any active sessions and/or logins \ + will be expired." ; action_form ~confirm_msg "/system/factory-reset" "⚠ Factory Reset" ] From 5650c01ed0e364862a8bc4945d75a6c49c18ecf1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ignas=20Vy=C5=A1niauskas?= Date: Fri, 22 Nov 2024 14:43:23 +0200 Subject: [PATCH 5/7] Add .git-blame-ignore-revs --- .git-blame-ignore-revs | 2 ++ 1 file changed, 2 insertions(+) create mode 100644 .git-blame-ignore-revs diff --git a/.git-blame-ignore-revs b/.git-blame-ignore-revs new file mode 100644 index 00000000..b209c124 --- /dev/null +++ b/.git-blame-ignore-revs @@ -0,0 +1,2 @@ +# dune fmt ocaml code +d67590d2cd504ed931e225834746f9e13b3a27fa From 611fcebc964e326e4ec25e4f0655bcb1c29789cd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ignas=20Vy=C5=A1niauskas?= Date: Tue, 26 Nov 2024 14:33:04 +0200 Subject: [PATCH 6/7] Add dune fmt check to CI pipeline --- .github/workflows/test.yml | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index b9c6e41d..81c3f32d 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -93,3 +93,15 @@ jobs: system-features = nixos-test benchmark big-parallel kvm - uses: DeterminateSystems/magic-nix-cache-action@v8 - run: cd controller && nix-shell --run 'bin/test --force --no-buffer' + + ocaml-formatting: + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v4 + - uses: cachix/install-nix-action@v18 + with: + nix_path: nixpkgs=channel:nixos-unstable + extra_nix_config: | + system-features = nixos-test benchmark big-parallel kvm + - uses: DeterminateSystems/magic-nix-cache-action@v8 + - run: cd controller && nix-shell --run 'dune build @fmt' From 9535b671400c968d0e9d2f1136ebf523e9a9d6b1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ignas=20Vy=C5=A1niauskas?= Date: Wed, 27 Nov 2024 10:19:21 +0200 Subject: [PATCH 7/7] Auto-format code in dev-server if AUTO_FORMAT is set --- controller/bin/watch-command | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/controller/bin/watch-command b/controller/bin/watch-command index faadff8e..15c8f84f 100755 --- a/controller/bin/watch-command +++ b/controller/bin/watch-command @@ -1,9 +1,16 @@ #!/usr/bin/env bash set -euo pipefail + +AUTO_FORMAT=${AUTO_FORMAT:-} + cd $(dirname "$0")/.. clear +if [ ! -z "$AUTO_FORMAT" ]; then + dune fmt || true +fi + if bin/build; then bin/stop-server || true