Fail if there are jobs registered without any arguments. (#1428)

* Fail if there are jobs registered without any arguments.

This ensures that toplevel expressions in the unikernels are properly evaluated.

Fixes #873 #1426

* address @palainp review comments

* simplify 'Impl.app_has_no_arguments', as proposed by @reynir

* fix app_has_no_arguments again (thx @palainp @reynir)

lib/functoria/impl.ml

@@ -42,6 +42,12 @@ and 'a device = ('a, abstract) Device.t
 
 let abstract t = Abstract t
 
+let app_has_no_arguments = function
+  | App { args = Cons _ ; _ }
+  | Dev { args = Cons _ ; _ } -> false
+  | App _ | Dev _ -> true
+  | If _ -> false
+
 (* Devices *)
 
 let mk_dev ~args ~deps dev = Dev { dev; args; deps }

lib/functoria/impl.mli

@@ -28,6 +28,10 @@ type 'a device = ('a, abstract) Device.t
 val abstract : 'a t -> abstract
 (** [abstract i] is [i] with its type erased. *)
 
+val app_has_no_arguments : 'a t -> bool
+(** [app_has_no_arguments i] is [true] if the argument list is empty and it is
+    an application, [false] otherwise. *)
+
 val pp : 'a t Fmt.t
 (** [pp] is the pretty-printer for module implementations. *)
 

lib/mirage/mirage.ml

@@ -485,6 +485,12 @@ let ( ++ ) acc x =
 
 let register ?(argv = default_argv) ?tracing ?(reporter = default_reporter ())
     ?keys:extra_keys ?packages ?src name jobs =
+  if List.exists Functoria.Impl.app_has_no_arguments jobs then
+    invalid_arg "Your configuration includes a job without arguments. \
+                 Please add a dependency in your config.ml: use \
+                 `let main = Mirage.main \"Unikernel.hello\" (job @-> job) \
+                  register \"hello\" [ main $ noop ]` \
+                 instead of `.. job .. [ main ]`.";
   let first = [ keys argv; backtrace; randomize_hashtables; gc_control ] in
   let reporter = if reporter == no_reporter then None else Some reporter in
   let init = Some first ++ reporter ++ tracing in

test/mirage/help/config.ml

@@ -1,9 +1,9 @@
 open Mirage
 
-let main = main "App" job
+let main = main "App" (job @-> job)
 
 let key =
   let doc = Key.Arg.info ~doc:"How to say hello." [ "hello" ] in
   Key.(create "hello" Arg.(opt string "Hello World!" doc))
 
-let () = register ~keys:[ Key.v key ] "noop" [ main ]
+let () = register ~keys:[ Key.v key ] "noop" [ main $ noop ]

test/mirage/job-no-device/config.ml

@@ -0,0 +1,9 @@
+open Mirage
+
+let main = main "App" job
+
+let key =
+  let doc = Key.Arg.info ~doc:"How to say hello." [ "hello" ] in
+  Key.(create "hello" Arg.(opt string "Hello World!" doc))
+
+let () = register ~keys:[ Key.v key ] ~src:`None "noop" [ main ]

test/mirage/job-no-device/configure.t

@@ -0,0 +1,6 @@
+  $ export MIRAGE_DEFAULT_TARGET=unix
+
+Configure
+  $ ./config.exe configure
+  Fatal error: exception Invalid_argument("Your configuration includes a job without arguments. Please add a dependency in your config.ml: use `let main = Mirage.main \"Unikernel.hello\" (job @-> job) register \"hello\" [ main $ noop ]` instead of `.. job .. [ main ]`.")
+  [2]

test/mirage/job-no-device/dune

@@ -0,0 +1,7 @@
+(executable
+ (name config)
+ (libraries mirage))
+
+(cram
+ (package mirage)
+ (deps config.exe))

test/mirage/query/config.ml

@@ -1,9 +1,9 @@
 open Mirage
 
-let main = main "App" job
+let main = main "App" (job @-> job)
 
 let key =
   let doc = Key.Arg.info ~doc:"How to say hello." [ "hello" ] in
   Key.(create "hello" Arg.(opt string "Hello World!" doc))
 
-let () = register ~keys:[ Key.v key ] ~src:`None "noop" [ main ]
+let () = register ~keys:[ Key.v key ] ~src:`None "noop" [ main $ noop ]

test/mirage/query/config_dash_in_name.ml

@@ -1,9 +1,9 @@
 open Mirage
 
-let main = main "App" job
+let main = main "App" (job @-> job)
 
 let key =
   let doc = Key.Arg.info ~doc:"How to say hello." [ "hello" ] in
   Key.(create "hello" Arg.(opt string "Hello World!" doc))
 
-let () = register ~keys:[ Key.v key ] ~src:`None "noop-functor.v0" [ main ]
+let () = register ~keys:[ Key.v key ] ~src:`None "noop-functor.v0" [ main $ noop ]