Give email services distinct names

Starting services with equal names causes problems when sorting
dependencies. Rework lifecycles, services and add id. Clean up some
small code parts and fix tests.

Makefile

@@ -93,7 +93,10 @@ sihl: all ## Run the produced executable of the included Sihl app
 
 .PHONY: test
 test: build	## Run unit tests with dune and then all sihl tests
-	SIHL_ENV=test opam exec -- dune test
+	SIHL_ENV=test ./_build/default/sihl/test/core_app.exe
+	SIHL_ENV=test ./_build/default/sihl/test/core_configuration.exe
+	SIHL_ENV=test ./_build/default/sihl/test/core_container.exe
+	SIHL_ENV=test ./_build/default/sihl/test/core_utils.exe
 	SIHL_ENV=test ./_build/default/sihl/test/web.exe
 	SIHL_ENV=test ./_build/default/sihl/test/web_flash.exe
 	SIHL_ENV=test ./_build/default/sihl/test/web_id.exe

sihl-cache/test/postgresql.ml

@@ -1,11 +1,11 @@
 let services =
   [ Sihl.Database.register ()
-  ; Sihl.Database.Migration.MariaDb.register []
+  ; Sihl.Database.Migration.PostgreSql.register []
   ; Sihl_cache.PostgreSql.register ()
   ]
 ;;
 
-module Test = Cache.Make (Sihl_cache.MariaDb)
+module Test = Cache.Make (Sihl_cache.PostgreSql)
 
 let () =
   Sihl.Configuration.read_string "DATABASE_URL_TEST_POSTGRESQL"

sihl-email/src/sihl_email.ml

@@ -392,11 +392,7 @@ module Queued
     else Job.dispatch_all emails
   ;;
 
-  let start () =
-    QueueService.register_jobs [ Sihl.Contract.Queue.hide Job.job ]
-    |> Lwt.map ignore
-  ;;
-
+  let start () = QueueService.register_jobs [ Sihl.Contract.Queue.hide Job.job ]
   let stop () = Lwt.return ()
 
   let lifecycle =

sihl-email/test/email_postgresql.ml

@@ -1,5 +1,5 @@
 let services =
-  [ Sihl.Database.Migration.MariaDb.register []
+  [ Sihl.Database.Migration.PostgreSql.register []
   ; Sihl_email.Template.PostgreSql.register ()
   ; Sihl_email.Smtp.register ()
   ]

sihl-queue/src/sihl_queue.ml

@@ -199,7 +199,7 @@ module Make (Repo : Repo.Sig) : Sihl.Contract.Queue.Sig = struct
     Lwt.return ()
   ;;
 
-  let start () = start_queue () |> Lwt.map ignore
+  let start () = start_queue ()
 
   let stop () =
     registered_jobs := [];

sihl-queue/test/queue_postgresql.ml

@@ -1,7 +1,7 @@
 let services =
   [ Sihl.Schedule.register []
   ; Sihl.Database.register ()
-  ; Sihl.Database.Migration.MariaDb.register []
+  ; Sihl.Database.Migration.PostgreSql.register []
   ; Sihl_queue.PostgreSql.register ()
   ]
 ;;

sihl-token/test/jwt_postgresql.ml

@@ -1,6 +1,6 @@
 let services =
   [ Sihl.Database.register ()
-  ; Sihl.Database.Migration.MariaDb.register []
+  ; Sihl.Database.Migration.PostgreSql.register []
   ; Sihl_token.JwtPostgreSql.register ()
   ]
 ;;

sihl-token/test/postgresql.ml

@@ -1,6 +1,6 @@
 let services =
   [ Sihl.Database.register ()
-  ; Sihl.Database.Migration.MariaDb.register []
+  ; Sihl.Database.Migration.PostgreSql.register []
   ; Sihl_token.PostgreSql.register ()
   ]
 ;;

sihl-user/test/password_reset_postgresql.ml

@@ -4,7 +4,7 @@ module PasswordResetService =
   Sihl_user.Password_reset.MakePostgreSql (TokenService)
 
 let services =
-  [ Sihl.Database.Migration.MariaDb.register []
+  [ Sihl.Database.Migration.PostgreSql.register []
   ; TokenService.register ()
   ; Sihl_user.PostgreSql.register ()
   ; PasswordResetService.register ()

sihl-user/test/user_postgresql.ml

@@ -1,5 +1,5 @@
 let services =
-  [ Sihl.Database.Migration.MariaDb.register []
+  [ Sihl.Database.Migration.PostgreSql.register []
   ; Sihl_user.PostgreSql.register ()
   ]
 ;;

sihl/src/core_command.ml

@@ -8,10 +8,13 @@ type t =
   { name : string
   ; usage : string option
   ; description : string
+  ; dependencies : Core_lifecycle.lifecycle list
   ; fn : string list -> unit option Lwt.t
   }
 
-let make ~name ?help ~description fn = { name; usage = help; description; fn }
+let make ~name ?help ~description ?(dependencies = []) fn =
+  { name; usage = help; description; dependencies; fn }
+;;
 
 let find_command_by_args commands args =
   let ( let* ) = Option.bind in
@@ -79,6 +82,11 @@ let run commands args =
       let start = Mtime_clock.now () in
       Lwt.catch
         (fun () ->
+          let%lwt _ =
+            Lwt_list.iter_s (fun (lifecycle : Core_lifecycle.lifecycle) ->
+                lifecycle.start ())
+            @@ Core_lifecycle.top_sort_lifecycles command.dependencies
+          in
           let%lwt result = command.fn rest_args in
           match result with
           | Some () ->

sihl/src/core_container.ml

@@ -1,165 +1,5 @@
-let log_src = Logs.Src.create "sihl.core.container"
-let () = Printexc.record_backtrace true
+include Core_lifecycle
+module Service = Core_service
 
-module Logs = (val Logs.src_log log_src : Logs.LOG)
-
-exception Exception
-
-type lifecycle =
-  { name : string
-  ; dependencies : unit -> lifecycle list
-  ; start : unit -> unit Lwt.t
-  ; stop : unit -> unit Lwt.t
-  }
-
-let create_lifecycle
-    ?(dependencies = fun () -> [])
-    ?(start = fun () -> Lwt.return ())
-    ?(stop = fun () -> Lwt.return ())
-    name
-  =
-  { name; dependencies; start; stop }
-;;
-
-module Service = struct
-  module type Sig = sig
-    val lifecycle : lifecycle
-  end
-
-  type t =
-    { lifecycle : lifecycle
-    ; configuration : Core_configuration.t
-    ; commands : Core_command.t list
-    ; server : bool
-    }
-
-  let commands service = service.commands
-  let configuration service = service.configuration
-
-  let create
-      ?(commands = [])
-      ?(configuration = Core_configuration.empty)
-      ?(server = false)
-      lifecycle
-    =
-    { lifecycle; configuration; commands; server }
-  ;;
-
-  let server t = t.server
-  let start t = t.lifecycle.start ()
-  let stop t = t.lifecycle.stop ()
-  let name t = t.lifecycle.name
-end
-
-module Map = Map.Make (String)
-
-let collect_all_lifecycles lifecycles =
-  let rec collect_lifecycles lifecycle =
-    match lifecycle.dependencies () with
-    | [] -> [ lifecycle ]
-    | lifecycles ->
-      List.cons
-        lifecycle
-        (lifecycles
-        |> List.map (fun lifecycle -> collect_lifecycles lifecycle)
-        |> List.concat)
-  in
-  lifecycles
-  |> List.map collect_lifecycles
-  |> List.concat
-  |> List.map (fun lifecycle -> lifecycle.name, lifecycle)
-  |> List.to_seq
-  |> Map.of_seq
-;;
-
-let top_sort_lifecycles lifecycles =
-  let lifecycles = collect_all_lifecycles lifecycles in
-  let lifecycle_graph =
-    lifecycles
-    |> Map.to_seq
-    |> List.of_seq
-    |> List.map (fun (name, lifecycle) ->
-           let dependencies =
-             lifecycle.dependencies () |> List.map (fun dep -> dep.name)
-           in
-           name, dependencies)
-  in
-  match Tsort.sort lifecycle_graph with
-  | Tsort.Sorted sorted ->
-    sorted
-    |> List.map (fun name ->
-           match Map.find_opt name lifecycles with
-           | Some l -> l
-           | None ->
-             Logs.err (fun m -> m "Failed to sort lifecycle of: %s" name);
-             raise Exception)
-  | Tsort.ErrorCycle remaining_names ->
-    let msg = String.concat ", " remaining_names in
-    Logs.err (fun m ->
-        m
-          "Cycle detected while starting services. These are the services \
-           after the cycle: %s"
-          msg);
-    raise Exception
-;;
-
-let start_services services =
-  Logs.info (fun m -> m "Starting...");
-  let lifecycles =
-    List.map (fun service -> service.Service.lifecycle) services
-  in
-  let lifecycles = lifecycles |> top_sort_lifecycles in
-  let rec loop lifecycles =
-    match lifecycles with
-    | lifecycle :: lifecycles ->
-      Logs.debug (fun m -> m "Starting service: %s" lifecycle.name);
-      let f = lifecycle.start in
-      let%lwt () = f () in
-      loop lifecycles
-    | [] -> Lwt.return ()
-  in
-  let%lwt () = loop lifecycles in
-  Logs.info (fun m -> m "All services started.");
-  Lwt.return lifecycles
-;;
-
-let stop_services services =
-  Logs.info (fun m -> m "Stopping...");
-  let lifecycles =
-    List.map (fun service -> service.Service.lifecycle) services
-  in
-  let lifecycles = lifecycles |> top_sort_lifecycles in
-  let rec loop lifecycles =
-    match lifecycles with
-    | lifecycle :: lifecycles ->
-      Logs.debug (fun m -> m "Stopping service: %s" lifecycle.name);
-      let f = lifecycle.stop in
-      let%lwt () = f () in
-      loop lifecycles
-    | [] -> Lwt.return ()
-  in
-  let%lwt () = loop lifecycles in
-  Logs.info (fun m -> m "Stopped, Good Bye!");
-  Lwt.return ()
-;;
-
-let unpack name ?default service =
-  match !service, default with
-  | Some service, _ -> service
-  | None, Some default -> default
-  | None, None ->
-    Logs.err (fun m ->
-        m "%s was called before a service implementation was registered" name);
-    Logs.info (fun m ->
-        m
-          "I was not able to find a default implementation either. Please make \
-           sure to provide a implementation using \
-           Sihl.Service.<Service>.register() of %s"
-          name);
-    print_endline
-      "A service was called before it was registered. If you don't see any \
-       other output, this means that you implemented a service facade \
-       incorrectly. No log reporter was configured because this error happens \
-       at module evaluation time";
-    raise Exception
-;;
+let start_services = Core_service.start_services
+let stop_services = Core_service.stop_services

sihl/src/core_lifecycle.ml

@@ -0,0 +1,100 @@
+let log_src = Logs.Src.create "sihl.core.container"
+let () = Printexc.record_backtrace true
+
+module Logs = (val Logs.src_log log_src : Logs.LOG)
+
+exception Exception
+
+(* TODO [aerben rename to t *)
+type lifecycle =
+  { type_name : string
+  ; implementation_name : string
+  ; id : int
+  ; dependencies : unit -> lifecycle list
+  ; start : unit -> unit Lwt.t
+  ; stop : unit -> unit Lwt.t
+  }
+
+let counter = ref 0
+
+let create_lifecycle
+    ?(dependencies = fun () -> [])
+    ?(start = fun () -> Lwt.return ())
+    ?(stop = fun () -> Lwt.return ())
+    ?implementation_name
+    type_name
+  =
+  (* Give all lifecycles unique names *)
+  counter := !counter + 1;
+  let implementation_name =
+    Option.value implementation_name ~default:type_name
+  in
+  { type_name; implementation_name; id = !counter; dependencies; start; stop }
+;;
+
+let human_name lifecycle =
+  Format.asprintf "%s %s" lifecycle.type_name lifecycle.implementation_name
+;;
+
+module Map = Map.Make (Int)
+
+let collect_all_lifecycles lifecycles =
+  let rec collect_lifecycles lifecycle =
+    match lifecycle.dependencies () with
+    | [] -> [ lifecycle ]
+    | lifecycles ->
+      List.cons
+        lifecycle
+        (lifecycles
+        |> List.map (fun lifecycle -> collect_lifecycles lifecycle)
+        |> List.concat)
+  in
+  lifecycles
+  |> List.map collect_lifecycles
+  |> List.concat
+  |> List.map (fun lifecycle -> lifecycle.id, lifecycle)
+  |> List.to_seq
+  |> Map.of_seq
+;;
+
+let top_sort_lifecycles lifecycles =
+  let lifecycles = collect_all_lifecycles lifecycles in
+  let lifecycle_graph =
+    lifecycles
+    |> Map.to_seq
+    |> List.of_seq
+    |> List.map (fun (id, lifecycle) ->
+           let dependencies =
+             lifecycle.dependencies () |> List.map (fun dep -> dep.id)
+           in
+           id, dependencies)
+  in
+  match Tsort.sort lifecycle_graph with
+  | Tsort.Sorted sorted ->
+    sorted
+    |> List.map (fun id ->
+           match Map.find_opt id lifecycles with
+           | Some l -> l
+           | None ->
+             Logs.err (fun m -> m "Failed to sort lifecycles.");
+             raise Exception)
+  | Tsort.ErrorCycle remaining_ids ->
+    let remaining_names =
+      List.map
+        (fun id -> lifecycles |> Map.find_opt id |> Option.map human_name)
+        remaining_ids
+      |> CCList.all_some
+    in
+    let msg = "Cycle detected while starting lifecycles." in
+    let remaining_msg =
+      Option.map
+        (fun r ->
+          Format.asprintf
+            "%s These are the lifecycles after the cycle: %s"
+            msg
+            (String.concat ", " r))
+        remaining_names
+    in
+    Logs.err (fun m -> m "%s" @@ Option.value remaining_msg ~default:msg);
+    raise Exception
+;;