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
open Lwt.Syntax
let log_src = Logs.Src.create "sihl.container"
module Logs = (val Logs.src_log log_src : Logs.LOG)
exception Exception of string
module Lifecycle = struct
type start = unit -> unit Lwt.t
type stop = unit -> unit Lwt.t
type t =
{ name : string
; dependencies : t list
; start : start
; stop : stop
}
let name lifecycle = lifecycle.name
let create ?(dependencies = []) name ~start ~stop = { name; dependencies; start; stop }
end
module Service = struct
module type Sig = sig
val lifecycle : Lifecycle.t
end
type t =
{ lifecycle : Lifecycle.t
; configuration : Configuration.t
; commands : Command.t list
}
let commands service = service.commands
let configuration service = service.configuration
let create ?(commands = []) ?(configuration = Configuration.empty) lifecycle =
{ lifecycle; configuration; commands }
;;
end
module Map = Map.Make (String)
let collect_all_lifecycles lifecycles =
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
lifecycles
|> List.map collect_lifecycles
|> List.concat
|> List.map (fun lifecycle -> 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.Lifecycle.dependencies |> List.map (fun dep -> dep.Lifecycle.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 "Dependency graph not sortable"))
| Tsort.ErrorCycle remaining_names ->
let msg = String.concat ", " remaining_names in
raise
(Exception
("Cycle detected while starting services. These are the services after the \
cycle: "
^ msg))
;;
let start_services services =
Logs.debug (fun m -> m "Starting Sihl");
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.Lifecycle.name);
let f = lifecycle.start in
let* () = f () in
loop lifecycles
| [] -> Lwt.return ()
in
let* () = loop lifecycles in
Logs.debug (fun m -> m "All services online. Ready for Takeoff!");
Lwt.return lifecycles
;;
let stop_services services =
Logs.debug (fun m -> m "Stopping Sihl");
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.Lifecycle.name);
let f = lifecycle.stop in
let* () = f () in
loop lifecycles
| [] -> Lwt.return ()
in
let* () = loop lifecycles in
Logs.debug (fun m -> m "Stopped Sihl, Good Bye!");
Lwt.return ()
;;