/
process.ml
162 lines (141 loc) · 4.18 KB
/
process.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
(* Connect to http://localhost:8080/dump *)
open Lwt.Infix
open Printf
let fin () =
let _ = Sys.command (sprintf "cd %s && git reset HEAD --hard" Config.root) in
Lwt.return_unit
type action = {
message : string;
files : (string list * (unit -> string)) list;
}
type image = { name : string; actions : action list }
let ubuntu =
{
name = "official-images/ubuntu:14.04";
actions =
[
{
message = "Updating source lists";
files =
[
( [ "etc"; "source.list" ],
fun () -> sprintf "deb %d" (Random.int 10) );
];
};
{ message = "grep -v '^#' /etc/apt/sources.list"; files = [] };
{ message = "cat /etc/issue"; files = [] };
];
}
let wordpress =
{
name = "official-images/wordpress:latest";
actions =
[
{
message = "user logging";
files =
[
( [ "wordpress"; "wp-users.php" ],
fun () -> sprintf "<?php ...%d" (Random.int 10) );
];
};
{
message = "configuration updates";
files =
[
( [ "wordpress"; "wp-settings.php" ],
fun () -> sprintf "<?php .. %d" (Random.int 10) );
];
};
];
}
let mysql =
{
name = "local/mysql:5.5.41";
actions =
[
{ message = "Reading table wp_users"; files = [] };
{
message = "Writing table wp_users";
files =
[
( [ "var"; "lib"; "mysql" ],
fun () -> sprintf "X%duYYt" (Random.int 10) );
];
};
{ message = "Reading table wp_posts"; files = [] };
{
message = "Writing table wp_posts";
files =
[
( [ "var"; "lib"; "mysql" ],
fun () -> sprintf "X%dxYYt" (Random.int 10) );
];
};
];
}
let branch image = String.map (function ':' -> '/' | c -> c) image.name
let images = [| (*ubuntu; *) wordpress; mysql |]
module Store = Irmin_unix.Git.FS.KV (Irmin.Contents.String)
let head = Store.Git.Reference.of_string ("refs/heads/" ^ branch images.(0))
let config = Irmin_git.config ~bare:true ~head Config.root
let info image msg () =
let date = Int64.of_float (Unix.gettimeofday ()) in
let author = image.name in
Irmin.Info.v ~date ~author msg
let master = branch images.(0)
let init () =
Config.init ();
Store.Repo.v config >>= fun repo ->
Store.of_branch repo master >>= fun t ->
Store.set_exn t ~info:(info images.(0) "init") [ "0" ] "0" >>= fun () ->
Lwt_list.iter_s
(fun i -> Store.clone ~src:t ~dst:(branch i) >>= fun _ -> Lwt.return_unit)
(Array.to_list images)
let random_array a = a.(Random.int (Array.length a))
let random_list l = random_array (Array.of_list l)
let rec process image =
let id = branch image in
Printf.printf "Processing %s\n%!" id;
let actions = random_list image.actions in
let key, value =
try random_list actions.files
with _ ->
([ "log"; id; "0" ], fun () -> id ^ string_of_int (Random.int 10))
in
Store.Repo.v config >>= fun repo ->
Store.of_branch repo id >>= fun t ->
Store.set_exn t ~info:(info image actions.message) key (value ())
>>= fun () ->
( if Random.int 3 = 0 then
let branch = branch (random_array images) in
if branch <> id then (
Printf.printf "Merging ...%!";
Store.merge_with_branch t
~info:(info image @@ Fmt.strf "Merging with %s" branch)
branch
>>= function
| Ok () ->
Printf.printf "ok!\n%!";
Lwt.return_unit
| Error _ -> Lwt.fail_with "conflict!" )
else Lwt.return_unit
else Lwt.return_unit )
>>= fun () ->
Lwt_unix.sleep (max 0.1 (Random.float 0.3)) >>= fun () -> process image
let rec protect fn x =
Lwt.catch
(fun () -> fn x)
(fun e ->
Printf.eprintf "error: %s" (Printexc.to_string e);
protect fn x)
let rec watchdog () =
Printf.printf "I'm alive!\n%!";
Lwt_unix.sleep 1. >>= fun () -> watchdog ()
let () =
let aux () =
init () >>= fun () ->
Lwt.choose
(watchdog () :: List.map (protect process) (Array.to_list images))
in
Lwt_main.run (aux ())