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
open Lwt.Syntax
module Published = Publish.Published
let ( let** ) = Lwt_result.bind
module OpCollect = struct
type t = No_context
let id = "collect"
let pp f _ = Fmt.string f "collect"
let auto_cancel = false
module Key = struct
type t = Published.t list
let digest t =
t
|> List.sort (fun a b -> String.compare a.Published.service b.service)
|> List.map (fun d -> d.Published.service)
|> String.concat "|"
end
module Value = Current.Unit
let build No_context job roots =
let* () = Current.Job.start ~level:Dangerous job in
let module StringSet = Set.Make (String) in
let deployed_services =
StringSet.of_list (List.map (fun t -> t.Published.service) roots)
in
let perform ~socket =
let** deployments =
Client.Deployments.list ~socket () |> Lwt.map Utils.remap_errors
in
let deployments_to_keep, deployments_to_remove =
List.partition
(fun (deployment : Iptables_daemon_api.Types.DeploymentInfo.t) ->
StringSet.mem deployment.name deployed_services)
deployments
in
Current.Job.log job "Roots:";
List.iter
(fun (deployment : Iptables_daemon_api.Types.DeploymentInfo.t) ->
Current.Job.log job " - %s @%a (%s)" deployment.name Ipaddr.V4.pp
deployment.ip.ip deployment.ip.tag)
deployments_to_keep;
Current.Job.log job "Stage 1: remove unused deployments";
let* () =
Lwt_list.iter_s
(fun (deployment : Iptables_daemon_api.Types.DeploymentInfo.t) ->
Current.Job.log job "- %s" deployment.name;
Client.Deployments.remove ~socket deployment.name |> Lwt.map ignore)
deployments_to_remove
in
let ips_to_keep =
List.map
(fun (d : Iptables_daemon_api.Types.DeploymentInfo.t) ->
Ipaddr.V4.to_string d.ip.ip)
deployments_to_keep
|> StringSet.of_list
in
let** ips =
Client.IpManager.list ~socket () |> Lwt.map Utils.remap_errors
in
let ips_to_remove =
List.filter
(fun (ip : Iptables_daemon_api.Types.Ip.t) ->
not (StringSet.mem (Ipaddr.V4.to_string ip.ip) ips_to_keep))
ips
in
let removed_ips_tags =
List.map (fun ip -> ip.Iptables_daemon_api.Types.Ip.tag) ips_to_remove
|> StringSet.of_list
in
Current.Job.log job "Stage 2: remove unused unikernels";
Current.Job.log job "Live unikernels:";
let ( let** ) = Lwt_result.bind in
let** unikernels = Client.Albatross.list_unikernels () in
let unikernels_to_remove =
List.filter
(fun (name, _) ->
let tag = Vmm_core.Name.to_string name in
Current.Job.log job "- %s" tag;
StringSet.mem tag removed_ips_tags)
unikernels
in
Current.Job.log job "Remove them:";
let* () =
Lwt_list.iter_s
(fun (name, _) ->
Current.Job.log job "- %a" Vmm_core.Name.pp name;
Client.Albatross.destroy_unikernel name |> Lwt.map ignore)
unikernels_to_remove
in
Current.Job.log job "Stage 3: remove unused IPs";
let+ () =
Lwt_list.iter_s
(fun (ip : Iptables_daemon_api.Types.Ip.t) ->
Current.Job.log job "- %s @%a" ip.tag Ipaddr.V4.pp ip.ip;
Client.IpManager.remove ~socket ip.tag |> Lwt.map ignore)
ips_to_remove
in
Ok ()
in
let* socket = Client.connect () in
Lwt.finalize (fun () -> perform ~socket) (fun () -> Client.close socket)
end
module Collect = Current_cache.Make (OpCollect)
let collect deployments =
let open Current.Syntax in
Current.component "collect"
|> let> deployments = deployments in
Collect.get No_context deployments