Configuration (albatross endpoint and certificates) is on the block d…

…evice now

Still missing: a way to upload (and edit) the configuration

config.ml

@@ -1,6 +1,5 @@
 open Mirage
 
-let data = crunch "keys"
 let assets = crunch "assets"
 
 let mollymawk =
@@ -22,15 +21,10 @@ let mollymawk =
       package "oneffs";
       package "duration";
     ]
-  and runtime_args =
-    [
-      runtime_arg ~pos:__POS__ "Unikernel.K.albatross_server";
-      runtime_arg ~pos:__POS__ "Unikernel.K.port";
-    ]
   in
-  main ~runtime_args ~packages "Unikernel.Main"
-    (random @-> pclock @-> mclock @-> time @-> stackv4v6 @-> kv_ro @-> kv_ro
-   @-> block @-> job)
+  main ~packages "Unikernel.Main"
+    (random @-> pclock @-> mclock @-> time @-> stackv4v6 @-> kv_ro @-> block
+   @-> job)
 
 let block = block_of_file "data"
 
@@ -40,5 +34,5 @@ let () =
       mollymawk $ default_random $ default_posix_clock $ default_monotonic_clock
       $ default_time
       $ generic_stackv4v6 default_network
-      $ data $ assets $ block;
+      $ assets $ block;
     ]

configuration.ml

@@ -0,0 +1,103 @@
+open Utils.Json
+
+let current_version = 1
+
+type t = {
+  certificate : X509.Certificate.t;
+  private_key : X509.Private_key.t;
+  server_ip : Ipaddr.t;
+  server_port : int;
+}
+
+(* this is here to avoid the need for option *)
+let empty () =
+  let key = X509.Private_key.generate `ED25519 in
+  let name = "mollymawk-empty" in
+  let cert =
+    let dn =
+      X509.Distinguished_name.
+        [ Relative_distinguished_name.(singleton (CN name)) ]
+    in
+    let csr = Result.get_ok (X509.Signing_request.create dn key) in
+    let valid_from = Ptime.epoch in
+    let valid_until =
+      Option.get (Ptime.add_span valid_from (Ptime.Span.of_int_s (10 * 60)))
+    in
+    Result.get_ok
+      (X509.Signing_request.sign csr ~valid_from ~valid_until key dn)
+  in
+  {
+    certificate = cert;
+    private_key = key;
+    server_ip = Ipaddr.(V4 V4.any);
+    server_port = 1025;
+  }
+
+let to_json t =
+  `Assoc
+    [
+      ("version", `Int current_version);
+      ( "certificate",
+        `String (Cstruct.to_string (X509.Certificate.encode_pem t.certificate))
+      );
+      ( "private_key",
+        `String (Cstruct.to_string (X509.Private_key.encode_pem t.private_key))
+      );
+      ("server_ip", `String (Ipaddr.to_string t.server_ip));
+      ("server_port", `Int t.server_port);
+    ]
+
+let of_json = function
+  | `Assoc xs -> (
+      match get "version" xs with
+      | None -> Error (`Msg "configuration: couldn't find a version")
+      | Some (`Int v) ->
+          if v = current_version then
+            match
+              ( get "certificate" xs,
+                get "private_key" xs,
+                get "server_name" xs,
+                get "server_port" xs )
+            with
+            | ( Some (`String cert),
+                Some (`String key),
+                Some (`String server_ip),
+                Some (`Int server_port) ) ->
+                let ( let* ) = Result.bind in
+                let* certificate =
+                  X509.Certificate.decode_pem (Cstruct.of_string cert)
+                in
+                let* private_key =
+                  X509.Private_key.decode_pem (Cstruct.of_string key)
+                in
+                let* () =
+                  if
+                    not
+                      (Cstruct.equal
+                         (X509.Public_key.fingerprint
+                            (X509.Certificate.public_key certificate))
+                         (X509.Public_key.fingerprint
+                            (X509.Private_key.public private_key)))
+                  then Error (`Msg "certificate and private key do not match")
+                  else Ok ()
+                in
+                let* server_ip = Ipaddr.of_string server_ip in
+                Ok
+                  {
+                    certificate;
+                    private_key;
+                    server_ip;
+                    server_port;
+                  }
+            | _ ->
+                Error
+                  (`Msg
+                    (Fmt.str "configuration: unexpected types, got %s"
+                       (Yojson.Basic.to_string (`Assoc xs))))
+          else
+            Error
+              (`Msg
+                (Fmt.str "configuration: found version %u, expected %u" v
+                   current_version))
+      | Some _ -> Error (`Msg "configuration: version must be an integer"))
+  | _ -> Error (`Msg "configuration: expected a dictionary")

storage.ml

@@ -1,6 +1,10 @@
 open Utils.Json
 
-type t = { version : int; users : User_model.user list }
+type t = {
+  version : int;
+  users : User_model.user list;
+  configuration : Configuration.t;
+}
 
 let current_version = 1
 
@@ -9,26 +13,32 @@ let t_to_json t =
     [
       ("version", `Int t.version);
       ("users", `List (List.map User_model.user_to_json t.users));
+      ("configuration", Configuration.to_json t.configuration);
     ]
 
 let t_of_json = function
   | `Assoc xs -> (
       let ( let* ) = Result.bind in
-      match (get "version" xs, get "users" xs) with
-      | Some (`Int v), Some (`List xs) ->
+      match (get "version" xs, get "users" xs, get "configuration" xs) with
+      | Some (`Int v), Some (`List users), Some configuration ->
           let* () =
             if v = current_version then Ok ()
-            else Error (`Msg "can't decode version")
+            else
+              Error
+                (`Msg
+                  (Fmt.str "expected version %u, found version %u"
+                     current_version v))
           in
           let* users =
             List.fold_left
               (fun acc js ->
                 let* acc = acc in
                 let* user = User_model.user_of_json js in
                 Ok (user :: acc))
-              (Ok []) xs
+              (Ok []) users
           in
-          Ok { version = v; users }
+          let* configuration = Configuration.of_json configuration in
+          Ok { version = v; users; configuration }
       | _ -> Error (`Msg "invalid data: no version and users field"))
   | _ -> Error (`Msg "invalid data: not an assoc")
 
@@ -54,7 +64,14 @@ module Make (BLOCK : Mirage_block.S) = struct
         in
         let* t = t_of_json json in
         Ok (disk, t)
-    | Ok None -> Ok (disk, { version = current_version; users = [] })
+    | Ok None ->
+        Ok
+          ( disk,
+            {
+              version = current_version;
+              users = [];
+              configuration = Configuration.empty ();
+            } )
     | Error e ->
         error_msgf "error while reading storage: %a" Stored_data.pp_error e
 

unikernel.ml

@@ -10,65 +10,17 @@ let err_to_exit pp = function
       Logs.err (fun m -> m "received error %a" pp e);
       exit Mirage_runtime.argument_error
 
-module K = struct
-  open Cmdliner
-
-  let albatross_server =
-    let doc = Arg.info ~doc:"albatross server IP" [ "albatross-server" ] in
-    Arg.(
-      value
-      & opt Mirage_runtime_network.Arg.ip_address
-          (Ipaddr.of_string_exn "192.168.1.3")
-          doc)
-
-  let port =
-    let doc = Arg.info ~doc:"server port" [ "port" ] in
-    Arg.(value & opt int 1025 doc)
-end
-
 module Main
     (R : Mirage_random.S)
     (P : Mirage_clock.PCLOCK)
     (M : Mirage_clock.MCLOCK)
     (T : Mirage_time.S)
     (S : Tcpip.Stack.V4V6)
-    (KV : Mirage_kv.RO)
     (KV_ASSETS : Mirage_kv.RO)
     (BLOCK : Mirage_block.S) =
 struct
   module Paf = Paf_mirage.Make (S.TCP)
 
-  let retrieve_credentials data =
-    ( KV.get data (Mirage_kv.Key.v "key.pem") >|= err_to_exit KV.pp_error
-    >|= fun key ->
-      err_to_exit pp_msg (X509.Private_key.decode_pem (Cstruct.of_string key))
-    )
-    >>= fun key ->
-    ( KV.get data (Mirage_kv.Key.v "cert.pem") >|= err_to_exit KV.pp_error
-    >|= fun cert ->
-      err_to_exit pp_msg
-        (X509.Certificate.decode_pem_multiple (Cstruct.of_string cert)) )
-    >|= fun certs ->
-    let cert =
-      match certs with
-      | hd :: [] -> hd
-      | [] ->
-          Logs.err (fun m -> m "no certificate found");
-          exit Mirage_runtime.argument_error
-      | _ ->
-          Logs.err (fun m -> m "multiple certificates found");
-          exit Mirage_runtime.argument_error
-    in
-    if
-      not
-        (Cstruct.equal
-           (X509.Public_key.fingerprint (X509.Certificate.public_key cert))
-           (X509.Public_key.fingerprint (X509.Private_key.public key)))
-    then (
-      Logs.err (fun m -> m "certificate and private key do not match");
-      exit Mirage_runtime.argument_error);
-    (key, cert)
-
   let js_contents assets =
     KV_ASSETS.get assets (Mirage_kv.Key.v "main.js") >|= function
     | Error _e -> invalid_arg "JS file could not be loaded"
@@ -694,22 +646,26 @@ struct
           Fmt.(option ~none:(any "unknown") Httpaf.Request.pp_hum)
           request)
 
-  let start _ _ _ _ stack data assets storage host port =
+  let start _ _ _ _ stack assets storage =
     js_contents assets >>= fun js_file ->
     css_contents assets >>= fun css_file ->
     images assets >>= fun imgs ->
     create_html_form assets >>= fun html ->
-    retrieve_credentials data >>= fun (key, cert) ->
     Store.Stored_data.connect storage >>= fun stored_data ->
     Store.read_data stored_data >>= function
     | Error (`Msg msg) -> failwith msg
     | Ok data ->
         let store = ref data in
-        Albatross.init stack host ~port cert key >>= fun albatross ->
+        let c = (snd data).Storage.configuration in
+        Albatross.init stack c.Configuration.server_ip ~port:c.server_port c.certificate c.private_key >>= fun albatross ->
         let port = 8080 in
         Logs.info (fun m ->
             m "Initialise an HTTP server (no HTTPS) on http://127.0.0.1:%u/"
               port);
+        (* TODO we need a web thingy to edit and upload the albatross configuration:
+           ip address, port, certificate, private_key
+           and once updated, we need to (a) dump to the disk (b) update the "albatross" value (and call Albatross.init key)
+        *)
         let request_handler _flow =
           request_handler albatross js_file css_file imgs html store
         in