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
open Lwt.Syntax
let log_src =
Logs.Src.create
~doc:"Service container that knows how to start and stop services"
"sihl.container"
;;
module Logs = (val Logs.src_log log_src : Logs.LOG)
exception Exception of string
module Lifecycle = struct
type start = Ctx.t -> Ctx.t Lwt.t
type stop = Ctx.t -> 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 -> Map.find_opt name lifecycles |> 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 =
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 ctx = Ctx.create () in
let rec loop ctx lifecycles =
match lifecycles with
| lifecycle :: lifecycles ->
Logs.debug (fun m -> m "Starting service: %s" lifecycle.Lifecycle.name);
let f = lifecycle.start in
let* ctx = f ctx in
loop ctx lifecycles
| [] -> Lwt.return ctx
in
let* ctx = loop ctx lifecycles in
Logs.debug (fun m -> m "All services online. Ready for Takeoff!");
Lwt.return (lifecycles, ctx)
;;
let stop_services ctx 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 ctx in
loop lifecycles
| [] -> Lwt.return ()
in
let* () = loop lifecycles in
Logs.debug (fun m -> m "Stopped Sihl, Good Bye!");
Lwt.return ()
;;