Source file core_container.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
open Lwt.Syntax

exception Exception of string

module Lifecycle = struct
  type t = {
    module_name : string;
    dependencies : t list;
    start : Core_ctx.t -> Core_ctx.t Lwt.t;
    stop : Core_ctx.t -> unit Lwt.t;
  }
  [@@deriving fields]

  let make module_name ?(dependencies = []) start stop =
    { module_name; dependencies; start; stop }
end

module type SERVICE = sig
  val lifecycle : Lifecycle.t
end

let collect_all_lifecycles services =
  let rec collect_lifecycles lifecycle =
    match lifecycle |> Lifecycle.dependencies with
    | [] -> [ lifecycle ]
    | lifecycles ->
        List.cons lifecycle
          ( lifecycles
          |> List.map (fun lifecycle -> collect_lifecycles lifecycle)
          |> List.concat )
  in
  services
  |> List.map (fun (module Service : SERVICE) ->
         Service.lifecycle |> collect_lifecycles)
  |> List.concat
  |> List.map (fun lifecycle -> (Lifecycle.module_name lifecycle, lifecycle))
  |> Base.Map.of_alist_reduce (module Base.String) ~f:(fun _ b -> b)

let top_sort_lifecycles services =
  let lifecycles = collect_all_lifecycles services in
  let lifecycle_graph =
    lifecycles |> Base.Map.to_alist
    |> List.map (fun (name, lifecycle) ->
           let dependencies =
             lifecycle |> Lifecycle.dependencies
             |> List.map Lifecycle.module_name
           in
           (name, dependencies))
  in
  match Tsort.sort lifecycle_graph with
  | Tsort.Sorted sorted ->
      sorted
      |> List.map (fun name -> Base.Map.find lifecycles name |> Option.get)
  | Tsort.ErrorCycle remaining_names ->
      let msg = String.concat ", " remaining_names in
      raise
        (Exception
           ( "CONTAINER: Cycle detected while starting services. These are the \
              services after the cycle: " ^ msg ))

let start_services services =
  print_endline "Starting Sihl...";
  let lifecycles = services |> top_sort_lifecycles in
  let ctx = Core_ctx.empty in
  let rec loop ctx lifecycles =
    match lifecycles with
    | lifecycle :: lifecycles ->
        print_endline ("Start service: " ^ Lifecycle.module_name lifecycle);
        let f = Lifecycle.start lifecycle in
        let* ctx = f ctx in
        loop ctx lifecycles
    | [] -> Lwt.return ctx
  in
  let* ctx = loop ctx lifecycles in
  print_endline "All services online. Ready for Takeoff!";
  Lwt.return (services, ctx)

let stop_services ctx services =
  print_endline "Stopping Sihl...";
  let lifecycles = services |> top_sort_lifecycles in
  let rec loop lifecycles =
    match lifecycles with
    | lifecycle :: lifecycles ->
        print_endline ("Stop service: " ^ Lifecycle.module_name lifecycle);
        let f = Lifecycle.stop lifecycle in
        let* () = f ctx in
        loop lifecycles
    | [] -> Lwt.return ()
  in
  let* () = loop lifecycles in
  print_endline "Stopped Sihl, Good Bye!";
  Lwt.return ()