Merge pull request #173 from yfyf/refactor-update-for-tests

Split Update module into components and add tests

.github/workflows/test.yml

@@ -19,6 +19,7 @@ jobs:
     needs: prepare-matrix
     runs-on: ubuntu-latest
     strategy:
+      fail-fast: false
       matrix:
         file: ${{fromJson(needs.prepare-matrix.outputs.integration_tests)}}
     steps:
@@ -80,3 +81,15 @@ jobs:
     - name: Make magic-nix-cache read-only by removing post-build-hook
       run: sed -i '/post-build-hook = magic-nix-cache-build-hook/d' $HOME/.config/nix/nix.conf
     - run: ./build test-e2e
+
+  ocaml-tests:
+    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 'bin/test --force --no-buffer'

controller/bin/test

@@ -0,0 +1,5 @@
+#!/usr/bin/env bash
+set -euo pipefail
+cd "$(dirname "$0")/.."
+
+dune test "$@"

controller/bindings/curl/curl.ml

@@ -17,8 +17,8 @@ let pretty_print_error error =
   | UnreadableStatus body ->
       Printf.sprintf "unreadable status code %s" body
 
-  | ProcessExit (_, err) ->
-      String.trim err
+  | ProcessExit (n, err) ->
+      Printf.sprintf "curl error: %s (non-zero exit code %d)" (String.trim err) n
 
   | ProcessKill n ->
       Printf.sprintf "curl killed by signal %d" n
@@ -75,7 +75,7 @@ let parse_status_code_and_body str =
 
 let request ?proxy ?(headers = []) ?data ?(options = []) url =
   let cmd =
-    "/run/current-system/sw/bin/curl",
+    "", (* path to Curl executable (uses PATH if empty string) *)
     (Array.concat
       [ [| "curl"; Uri.to_string url
          ; "--silent"

controller/bindings/curl/dune

@@ -1,5 +1,5 @@
 (library
  (name curl)
  (modules curl)
- (libraries cohttp-lwt-unix uri base)
+ (libraries cohttp-lwt-unix uri base config)
  (preprocess (pps lwt_ppx)))

controller/config/config.ml

@@ -0,0 +1,18 @@
+(** Global system configuration set by the build system *)
+module System = struct
+    (** 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 to which kiosk is pointed *)
+    let kiosk_url =
+      "@PLAYOS_KIOSK_URL@"
+
+    (** PlayOS bundle name prefix *)
+    let bundle_name =
+      "@PLAYOS_BUNDLE_NAME@"
+end

controller/config/dune

@@ -0,0 +1,4 @@
+(library
+ (name config)
+ (modules config)
+)

controller/default.nix

@@ -10,23 +10,38 @@ ocamlPackages.buildDunePackage rec {
 
   src = ./.;
 
-  preConfigure = ''
+  preConfigure = let
+    subs = {
+        "@PLAYOS_VERSION@" = version;
+        "@PLAYOS_UPDATE_URL@" = updateUrl;
+        "@PLAYOS_KIOSK_URL@" = kioskUrl;
+        "@PLAYOS_BUNDLE_NAME@" = bundleName;
+    };
+    in
+    ''
     markdown Changelog.md > Changelog.html
 
-    sed -i \
-      -e "s,@PLAYOS_VERSION@,${version},g" \
-      -e "s,@PLAYOS_UPDATE_URL@,${updateUrl},g" \
-      -e "s,@PLAYOS_KIOSK_URL@,${kioskUrl},g" \
-      ./server/info.ml
+    ${lib.strings.toShellVar "subs_arr" subs}
 
-    sed -i \
-      -e "s,@PLAYOS_BUNDLE_NAME@,${bundleName},g" \
-      ./server/update.ml
+    for name in "''${!subs_arr[@]}"; do
+        # check that the specified template variables are used
+        grep -q $name ./config/config.ml || \
+            (echo "$name is missing in ./config/config.ml"; exit 1)
+        sed -i -e "s,$name,''${subs_arr[$name]},g" ./config/config.ml
+    done
+  '';
+
+  postFixup = ''
+    for prog in "$out"/bin/*; do
+        wrapProgram $prog \
+            --prefix PATH ":" ${lib.makeBinPath [ curl ]}
+    done
   '';
 
   useDune2 = true;
 
   nativeBuildInputs = [
+    pkgs.makeWrapper
     discount # Transform Markdown to HTML
     ocamlPackages.obus
   ];
@@ -46,5 +61,9 @@ ocamlPackages.buildDunePackage rec {
     fieldslib
     ppx_protocol_conv
     ppx_protocol_conv_jsonm
+    alcotest
+    alcotest-lwt
+    qcheck
+    qcheck-alcotest
   ];
 }

controller/server/dune

@@ -3,15 +3,33 @@
 (executable
  (name server)
  (public_name playos-controller)
- (modules server update info gui health
+ (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 lwt logs logs.fmt logs.lwt fpath cohttp-lwt-unix logging
+ (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)))
+
+(library
+ (name update_client)
+ (modules update_client)
+ (libraries lwt connman curl semver2 config)
+ (preprocess (pps lwt_ppx ppx_sexp_conv)))
+
+(library
+ (name rauc_service)
+ (modules rauc_service)
+ (libraries lwt rauc)
+ (preprocess (pps lwt_ppx ppx_sexp_conv)))
+
 (library
  (name logging)
  (modules logging)

controller/server/info.ml

@@ -12,17 +12,7 @@ type t =
   ; local_time : string
   }
 
-(** 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 to which kiosk is pointed *)
-let kiosk_url =
-  "@PLAYOS_KIOSK_URL@"
+include Config.System
 
 (** Break up a string into groups of size n *)
 let rec grouped n s =

controller/server/rauc_service.ml

@@ -0,0 +1,38 @@
+module type S = sig
+    (** [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
+
+    (** [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
+
+    (** [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
+
+    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 mark_good = Rauc.mark_good t
+
+    let get_primary () : Rauc.Slot.t option Lwt.t =
+        Rauc.get_primary 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))

controller/server/rauc_service.mli

@@ -0,0 +1,18 @@
+module type S = sig
+    (** [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
+
+    (** [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
+
+    (** [install source] install the bundle at path [source] *)
+    val install : string -> unit Lwt.t
+end
+
+val build_module : Rauc.t -> (module S)

controller/server/server.ml

@@ -38,7 +38,7 @@ let main debug port =
   let%lwt connman = Connman.Manager.connect () in
 
   (* Start the update mechanism *)
-  let update_s, update_p = Update.start ~connman ~rauc ~update_url:Info.update_url in
+  let update_s, update_p = Update.start ~connman ~rauc in
 
   (* Log changes in update mechanism state *)
   let%lwt () =