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
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
open Lwt.Syntax

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

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* () = f () in
      loop lifecycles
    | [] -> Lwt.return ()
  in
  let* () = 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* () = f () in
      loop lifecycles
    | [] -> Lwt.return ()
  in
  let* () = 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
;;