-
Notifications
You must be signed in to change notification settings - Fork 0
/
managed.ml
203 lines (163 loc) · 6.58 KB
/
managed.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
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
open Batteries
open Printf
module C = Config
(* true to not run commands, just debug them. *)
let debug = false
let safe_find pred list =
try List.find pred list
with Not_found ->
eprintf "Host not present in config file\n";
exit 1
let command name =
match (Maps.StringMap.find name Config.commands)#get with
| None -> failwith ("Unable to find command for " ^ name)
| Some x -> x
(* Shell's 'to_file' truncates on append, despite the good intentions
(it's just wrong). Open a file for writing (it'll have to be closed
manually). *)
let append_out name =
Unix.openfile name [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_APPEND ] 0o644
class fs_manager pool host fs =
object (self)
val reg_dest = fs.C.fs_base
(* TODO: Make the mirror optional. *)
val mirror = Option.map (fun m -> m ^ "/" ^ fs.C.fs_volume) host.C.host_mirror
val pool = pool
val surelog = Config.surelog#get
val rsynclog = Config.rsynclog#get
method sure_path = reg_dest
method setup_check_paths =
if not (Sys.is_directory reg_dest) then
failwith (sprintf "Backup base directory doesn't exist '%s'" reg_dest);
Option.may (fun mirror ->
if not (Sys.is_directory mirror) then
failwith (sprintf "Mirror dir '%s' doesn't exist" mirror))
mirror;
Pool_util.with_pool pool (fun _ -> ())
method teardown_check_paths = ()
method setup_start_snapshot = ()
method teardown_start_snapshot = ()
method setup_mount_snapshot = ()
method teardown_mount_snapshot = ()
method setup_run_clean =
self#run ~chdir:(self#sure_path) fs.C.fs_clean [self#sure_path]
method teardown_run_clean = ()
method setup_sure_update =
self#run ~chdir:(self#sure_path) (command "gosure") ["update"]
method teardown_sure_update = ()
method setup_sure_write =
self#banner surelog "sure" self#sure_path;
self#run ~chdir:(self#sure_path) ~log:surelog (command "gosure") ["signoff"]
method teardown_sure_write = ()
method setup_rsync =
Option.may (fun mirror ->
self#banner rsynclog "rsync" self#sure_path;
self#run ~log:rsynclog (command "rsync") ["-aiHX"; "--delete";
self#sure_path ^ "/"; mirror])
mirror
method teardown_rsync = ()
method setup_dump =
Log.infof "Dumping fs=%s host=%s" fs.C.fs_volume host.C.host_host;
if not debug then
Backup.dump pool self#sure_path ["fs=" ^ fs.C.fs_volume;
"host=" ^ host.C.host_host]
method teardown_dump = ()
method run ?chdir ?log program args =
let place = match chdir with
| None -> ""
| Some dir -> " in '" ^ dir ^ "'" in
Log.infof "Run command: '%s' %a%s" program (List.print String.print) args place;
let (log, close) = match log with
| None -> (None, fun () -> ())
| Some name ->
let fd = append_out name in
(Some (Shell.to_fd fd), fun () -> Unix.close fd) in
if not debug then begin
let cmd = Shell.cmd ?chdir:chdir program args in
Shell.call ?stdout:log [cmd]
end;
close ()
method banner fname task dest =
let now = Unix.time () in
let nd = Netdate.create ~localzone:true now in
let now_fmt = Netdate.format ~fmt:"%Y-%m-%d_%H:%M" nd in
let line = sprintf "--- %s of %s (%s) on %s ---\n" task fs.C.fs_volume dest now_fmt in
let header = String.make (String.length line - 1) '-' ^ "\n" in
let write fd =
output_string fd header;
output_string fd line;
output_string fd header in
File.with_file_out ~mode:[`append;`create;`text] fname write
end
class lvm_manager pool host fs is_xfs =
let vg_name = match fs.C.fs_vg with
| Some v -> v
| None -> failwith (sprintf "lvm fs needs 'vg' field: '%s'" fs.C.fs_volume) in
object (self)
inherit fs_manager pool host fs as super
val snap_dest = "/mnt/snap/" ^ fs.C.fs_volume
val snap_vol = "/dev/" ^ vg_name ^ "/" ^ fs.C.fs_volume ^ ".snap"
method! sure_path = snap_dest
method! setup_check_paths =
super#setup_check_paths;
if not (Sys.is_directory snap_dest) then
failwith (sprintf "Snapshot destination doesn't exist '%s'" snap_dest)
method! setup_start_snapshot =
self#run (command "lvcreate") ["-L"; "5g"; "-n"; fs.C.fs_volume ^ ".snap";
"-s"; "/dev/" ^ vg_name ^ "/" ^ fs.C.fs_volume]
method! teardown_start_snapshot =
self#run (command "lvremove") ["-f"; snap_vol]
method! setup_mount_snapshot =
let uuid = if is_xfs then ["-o"; "nouuid"] else [] in
self#run (command "mount") (uuid @ [snap_vol; snap_dest])
method! teardown_mount_snapshot =
self#run (command "umount") [snap_dest]
method! setup_sure_write =
super#setup_sure_write;
self#run (command "cp") ["-p"; snap_dest ^ "/2sure.dat.gz";
reg_dest ^ "/2sure.dat.gz"]
end
let make_manager pool host fs = match fs.C.fs_style with
| "plain" -> new fs_manager pool host fs
| "xfs-lvm" -> new lvm_manager pool host fs true
| "ext4-lvm" -> new lvm_manager pool host fs false
| style -> failwith ("Unknown management style: " ^ style)
let make_steps obj = ([
("check paths", (fun () -> obj#setup_check_paths), (fun () -> obj#teardown_check_paths));
("start snapshot", (fun () -> obj#setup_start_snapshot), (fun () -> obj#teardown_start_snapshot));
("mount snapshot", (fun () -> obj#setup_mount_snapshot), (fun () -> obj#teardown_mount_snapshot));
("run clean", (fun () -> obj#setup_run_clean), (fun () -> obj#teardown_run_clean));
("sure update", (fun () -> obj#setup_sure_update), (fun () -> obj#teardown_sure_update));
("sure write", (fun () -> obj#setup_sure_write), (fun () -> obj#teardown_sure_write));
("rsync", (fun () -> obj#setup_rsync), (fun () -> obj#teardown_rsync));
("dump", (fun () -> obj#setup_dump), (fun () -> obj#teardown_dump));
] : (string * (unit -> unit) * (unit -> unit)) list)
let get_step_name = function
| ((name, _, _)::_) -> name
| [] -> "???"
let log_rotate () =
let rotate name =
if (Sys.file_exists name) then
Sys.rename name (name ^ ".bak") in
rotate (Config.surelog#get);
rotate (Config.rsynclog#get)
let managed pool host =
(* Lookup the host. *)
let hosts = Config.hosts#get in
let host = safe_find (fun h -> host = h.C.host_host) hosts in
let managers = List.map (make_manager pool host) host.C.host_fs in
let all_steps = List.transpose (List.map make_steps managers) in
let cleanup = ref [] in
let step1 fss =
let name = get_step_name fss in
Log.infof "*** setup %s ***" name;
let step2 (_name, setup, teardown) =
setup ();
cleanup := (fun () -> teardown ()) :: !cleanup
in
List.iter step2 fss in
log_rotate ();
finally (fun () ->
Log.info "*** Teardown ***";
List.iter (fun x -> x ()) !cleanup)
(List.iter step1) all_steps