···
module H = Shelter.History
7
+
let pp_error = Fmt.string
···
| "R" -> Void.R | "RW" -> Void.RW | _ -> failwith "Malformed Void.mode")
(function Void.R -> "R" | Void.RW -> "RW")
18
+
type post = { diff : Diff.t; time : int64 } [@@deriving repr]
29
+
(** Needed for execution *)
31
+
type t = { pre : pre; post : post } [@@deriving repr]
let merge = Irmin.Merge.(default (Repr.option t))
···
| Set_mode of History.mode
45
+
(* Fork a new branch from an existing one,
46
+
or switch to a branch if it exists *)
50
+
(* Undo the last command *)
52
+
(* Replay the current branch onto another *)
55
+
| Info of [ `Current | `History ]
let split_and_remove_empty s =
···
let shelter_action = function
| "mode" :: [ "r" ] -> Set_mode R
54
-
| "mode" :: [ "rw" ] -> Set_mode R
67
+
| "mode" :: [ "rw" ] -> Set_mode RW
| "session" :: [ m ] -> Set_session m
56
-
| "fork" :: [ m ] -> Fork m
| "replay" :: [ onto ] -> Replay onto
58
-
| [ "info" ] -> Info
70
+
| [ "info" ] -> Info `Current
60
-
| [ "history" ] -> History
72
+
| [ "history" ] -> Info `History
let action_of_command cmd =
···
let history_key = [ "history" ]
let key clock = history_key @ [ string_of_float @@ Eio.Time.now clock ]
72
-
let list (H.Store ((module S), store) : entry H.t) =
73
-
match S.list store history_key with
76
-
let rec loop acc = function
77
-
| (s, `Contents (v, _meta)) :: next -> loop ((s, v) :: acc) next
78
-
| _ :: next -> loop acc next
79
-
| [] -> List.rev acc
84
+
let history (H.Store ((module S), store) : entry H.t) =
85
+
let repo = S.repo store in
86
+
match S.Head.find store with
89
+
let rec linearize c =
90
+
match S.Commit.parents c |> List.map (S.Commit.of_hash repo) with
91
+
| [ Some p ] -> c :: linearize p
81
-
loop [] (List.map (fun (v, tree) -> (v, S.Tree.to_concrete tree)) xs)
82
-
|> List.stable_sort (fun (s1, _) (s2, _) ->
83
-
Float.compare (Float.of_string s1) (Float.of_string s2))
94
+
let commits = linearize hd in
95
+
let get_diff_content t1 t2 =
96
+
match S.Tree.diff t1 t2 with
97
+
| [ (_, `Added (c, _)) ] -> c
100
+
Repr.pp (Irmin.Diff.t (Repr.pair History.t S.metadata_t))
102
+
Fmt.epr "Get diff (%i) content %a%!" (List.length lst)
103
+
Fmt.(list ~sep:Fmt.comma (Fmt.pair (Repr.pp S.path_t) pp_diff))
105
+
invalid_arg "Get diff should only have a single difference."
107
+
let hash c = S.Commit.hash c |> S.Hash.to_raw_string in
108
+
let rec diff_calc = function
111
+
let diff = get_diff_content (S.Tree.empty ()) (S.Commit.tree x) in
113
+
| c :: p :: rest ->
114
+
let diff = get_diff_content (S.Commit.tree p) (S.Commit.tree c) in
115
+
(hash c, diff) :: diff_calc (p :: rest)
let with_latest ~default s f =
87
-
match list s with [] -> default () | hd :: _ -> f hd
120
+
match history s with [] -> default () | (_, hd) :: _ -> f hd
let text c = Fmt.(styled (`Fg c) string)
···
let repo = S.repo session in
let heads = List.map (fun b -> (S.Branch.find repo b, b)) branches in
let head = S.Head.find session in
103
-
List.assoc_opt head heads
138
+
(fun hash -> String.sub (Fmt.str "%a" S.Commit.pp_hash hash) 0 7)
141
+
(head_hash, List.assoc_opt head heads)
(* Reset the head of the current session by one commit *)
let reset_hard ((H.Store ((module S), session) : entry H.t) as s) =
···
(* Fork a new session from an existing one *)
130
-
let display_history (H.Store ((module S), session) : entry H.t) =
131
-
let history = S.history ~depth:max_int session in
133
-
H.Store ((module S), S.of_commit c) |> list |> List.hd |> snd
168
+
let display_history (s : entry H.t) =
if d = [] then () else Fmt.pf fmt "\n %a" (Repr.pp Diff.t) d
let pp_entry fmt (e : entry) =
140
-
Fmt.(str "%a" (styled (`Fg `Yellow) uint64_ns_span) e.time)
141
-
(String.concat " " e.args) pp_diff e.diff
174
+
Fmt.(str "%a" (styled (`Fg `Yellow) uint64_ns_span) e.post.time)
175
+
(String.concat " " e.pre.args)
176
+
pp_diff e.post.diff
144
-
S.History.fold_vertex (fun c v -> content c :: v) history [] |> List.rev
146
-
List.iter (fun c -> Fmt.pr "%a\n%!" pp_entry c) linearize
178
+
let entries = history s |> List.rev in
179
+
List.iter (fun (_hash, c) -> Fmt.pr "%a\n%!" pp_entry c) entries
let prompt status ((H.Store ((module S), _session) : entry H.t) as store) =
149
-
let sesh = Option.value ~default:"main" (which_branch store) in
182
+
let head, sesh = which_branch store in
183
+
let sesh = Option.value ~default:"main" sesh in
Fmt.(styled (`Fg `Yellow) string) Format.str_formatter "shelter> ";
Format.flush_str_formatter ()
154
-
let pp_sesh fmt sesh = Fmt.pf fmt "[%a]" (text `Green) sesh in
188
+
let pp_head fmt = function
189
+
| None -> Fmt.nop fmt ()
190
+
| Some h -> Fmt.pf fmt "#%a" (text `Magenta) h
192
+
let pp_sesh fmt sesh = Fmt.pf fmt "[%a%a]" (text `Green) sesh pp_head head in
let pp_status fmt = function
| `Exited 0 -> Fmt.nop fmt ()
| `Exited n -> Fmt.pf fmt "%a " (text `Red) (string_of_int n)
160
-
let prompt_entry (_, (e : entry)) =
198
+
let prompt_entry (e : entry) =
Fmt.pf Format.str_formatter "%a%a%a : { mode: %a }> " pp_status status
(text `Yellow) "shelter" pp_sesh sesh (text `Red)
163
-
(if e.mode = R then "r" else "rw");
201
+
(if e.pre.mode = R then "r" else "rw");
Format.flush_str_formatter ()
with_latest store ~default:prompt prompt_entry
206
+
type ctx = { store : Store.t; tool_dir : string }
208
+
let tools = [ ("opentrace", Tools.opentrace) ]
let store = Store.init fs proc "shelter" in
173
-
(fun (_, { History.args; _ }) ->
213
+
(fun (_, { History.pre = { History.args; _ }; _ }) ->
LNoise.history_add (String.concat " " args) |> ignore)
216
+
let tool_cid = Store.cid (String.concat ":" (List.map snd tools)) in
218
+
Store.Run.with_tool store tool_cid @@ fun tool_dir ->
219
+
Eio.Fiber.List.iter
220
+
(fun (toolname, content) ->
221
+
let new_path = Eio.Path.(fs / tool_dir / toolname) in
222
+
Eio.Path.save ~create:(`If_missing 0o755) new_path content)
226
+
{ store; tool_dir = tools }
230
+
- TODO: pretty confusing that we `entry` to build from and also as the
231
+
thing we are building (e.g. the build field and the args field... *)
232
+
let exec (config : config) ~stdout fs proc
233
+
((H.Store ((module S), _) : entry H.t), (ctx : ctx)) (entry : entry) =
234
+
let build, env, (uid, gid) =
235
+
match entry.pre.build with
236
+
| Store.Build.Image img ->
237
+
let build, env, user = Store.fetch ctx.store img in
238
+
(build, env, Option.value ~default:(0, 0) user)
239
+
| Store.Build.Build cid -> (cid, entry.pre.env, entry.pre.user)
241
+
let command = entry.pre.args in
243
+
{ entry with pre = { entry.pre with build = Build build } }
245
+
(* Store things under History.pre, this makes it possible to rediscover
246
+
the hash for something purely from the arguments needed to execute something
247
+
rather than needing, for example, the time it took to execute!
249
+
Also, combine it with previous build step. *)
251
+
Store.cid (Cid.to_string build ^ Repr.to_string History.pre_t hash_entry.pre)
253
+
let with_rootfs fn =
254
+
if entry.pre.mode = R then (Store.Run.with_build ctx.store build fn, [])
257
+
Eio.Path.(fs / Filename.temp_dir "shelter-diff-" "" / "diff")
259
+
Store.Run.with_clone ctx.store ~src:build new_cid diff_path fn
261
+
with_rootfs @@ function
263
+
(* Copy the stdout log to stdout *)
265
+
Eio.Path.(with_open_in (fs / (path :> string) / "log")) @@ fun ic ->
266
+
Eio.Flow.copy ic stdout
268
+
let c = Eio.Path.(load (fs / (path :> string) / "hash")) in
272
+
if config.no_runc then
273
+
(* Experiment Void Process *)
274
+
let rootfs = Filename.concat rootfs "rootfs" in
277
+
|> Void.rootfs ~mode:entry.pre.mode rootfs
278
+
|> Void.cwd entry.pre.cwd
279
+
(* TODO: Support UIDs |> Void.uid 1000 *)
284
+
String.concat " " command ^ " && env > /tmp/shelter-env";
287
+
`Void (Void.spawn ~sw void |> Void.exit_status)
289
+
let tool_mount : Runc.Json_config.mount =
292
+
src = ctx.tool_dir;
293
+
dst = "/shelter-tools";
300
+
cwd = entry.pre.cwd;
305
+
String.concat " " command ^ " && env > /tmp/shelter-env";
307
+
hostname = "builder";
308
+
network = [ "host" ];
310
+
env = entry.pre.env;
311
+
mounts = [ tool_mount ];
319
+
method stdout = stdout
322
+
`Runc (Runc.spawn ~sw log env config rootfs)
325
+
Switch.run @@ fun sw ->
327
+
Eio.Path.open_out ~sw ~create:(`If_missing 0o644)
328
+
Eio.Path.(fs / rootfs / "log")
330
+
let res = spawn sw log in
331
+
let start = Mtime_clock.now () in
333
+
| `Runc r -> (start, Eio.Process.await r)
334
+
| `Void v -> (start, Void.to_eio_status (Eio.Promise.await v))
336
+
let stop = Mtime_clock.now () in
337
+
let span = Mtime.span start stop in
338
+
let time = Mtime.Span.to_uint64_ns span in
339
+
(* Add command to history regardless of exit status *)
340
+
let _ : (unit, string) result =
341
+
LNoise.history_add (String.concat " " command)
343
+
if res = `Exited 0 then (
346
+
Eio.Path.(fs / rootfs / "rootfs" / "tmp" / "shelter-env")
349
+
Eio.Path.(load env_path)
350
+
|> String.split_on_char '\n'
351
+
|> List.filter (fun s -> not (String.equal "" s))
353
+
Eio.Path.unlink env_path;
357
+
match Astring.String.cut ~sep:"=" v with
358
+
| Some ("PWD", dir) -> Some dir
361
+
|> Option.value ~default:hash_entry.pre.cwd
363
+
if entry.pre.mode = RW then
370
+
hash_entry.pre with
371
+
build = Build new_cid;
382
+
pre = { hash_entry.pre with cwd; env; user = (uid, gid) };
383
+
post = { hash_entry.post with time };
386
+
else Shelter.process_error (Eio.Process.Child_error res)
388
+
let complete_exec ((H.Store ((module S), store) as s : entry H.t), ctx) clock fs
390
+
match new_entry with
391
+
| Error e -> Error e
392
+
| Ok (`Reset c) -> (
394
+
S.Hash.unsafe_of_raw_string c |> S.Commit.of_hash (S.repo store)
397
+
Fmt.epr "Resetting to existing entry failed...\n%!";
400
+
S.Head.set store c;
402
+
| Ok (`Entry (entry, path)) ->
404
+
let entry = History.{ entry with post = { entry.post with diff } } in
406
+
if entry.pre.mode = RW then (
408
+
~message:("exec " ^ String.concat " " entry.pre.args)
410
+
(* Save the commit hash for easy restoring later *)
411
+
let hash = S.Head.get store |> S.Commit.hash |> S.Hash.to_raw_string in
412
+
Eio.Path.save ~create:(`If_missing 0o644)
413
+
Eio.Path.(fs / path / "hash")
417
+
let replay config (H.Store ((module S), s) as store : entry H.t) ctx fs clock
418
+
proc stdout existing_branch =
419
+
let seshes = sessions store in
420
+
if not (List.exists (String.equal existing_branch) seshes) then (
421
+
Fmt.epr "%s does not exist!" existing_branch;
424
+
let repo = S.repo s in
425
+
let onto = S.of_branch repo existing_branch in
426
+
match S.lcas ~n:1 s onto with
427
+
| Error lcas_error ->
428
+
Fmt.epr "Replay LCAS: %a" (Repr.pp S.lca_error_t) lcas_error;
431
+
let all_commits = history store in
432
+
let lcas_hash = S.Commit.hash lcas |> S.Hash.to_raw_string in
433
+
let rec collect = function
435
+
| (x, _) :: _ when String.equal lcas_hash x -> []
436
+
| v :: vs -> v :: collect vs
438
+
let commits_to_apply = collect all_commits in
439
+
match commits_to_apply with
440
+
| [] -> Shelter.shell_error ""
441
+
| (h, first) :: rest ->
442
+
let _, last_other =
443
+
history (H.Store ((module S), onto)) |> List.hd
448
+
pre = { first.pre with build = last_other.pre.build };
451
+
let commits_to_apply = (h, new_first) :: rest in
452
+
(* Now we reset our head to point to the other store's head
453
+
and replay our commits onto it *)
454
+
let other_head = S.Head.get onto in
455
+
S.Head.set s other_head;
458
+
(fun last (_, (entry : entry)) ->
460
+
| Error _ as e -> e
461
+
| Ok (new_store, new_ctx) ->
462
+
let new_entry, diff =
463
+
exec config ~stdout fs proc (new_store, new_ctx) entry
465
+
complete_exec (new_store, new_ctx) clock fs new_entry diff)
466
+
(Ok (H.Store ((module S), s), ctx))
470
+
| _ -> assert false (* Because n = 1 *)
178
-
let run (config : config) fs clock proc
179
-
(((H.Store ((module S), store) : entry H.t) as s), ctx) = function
472
+
let run (config : config) ~stdout fs clock proc
473
+
(((H.Store ((module S), store) : entry H.t) as s), (ctx : ctx)) = function
181
-
with_latest ~default:(fun _ -> Ok (s, ctx)) s @@ fun (_, entry) ->
182
-
commit ~message:"mode change" clock s { entry with mode };
475
+
with_latest ~default:(fun _ -> Ok (s, ctx)) s @@ fun entry ->
476
+
commit ~message:"mode change" clock s
477
+
{ entry with pre = { entry.pre with mode } };
185
-
with_latest ~default:(fun _ -> Ok (s, ctx)) s @@ fun (_, entry) ->
186
-
let new_store = S.of_branch (S.repo store) m in
187
-
let new_full_store = H.Store ((module S), new_store) in
188
-
commit ~message:"new session" clock new_full_store entry;
189
-
Ok (new_full_store, ctx)
479
+
| Set_session m -> (
480
+
(* Either set the session if the branch exists or create a new branch
481
+
from the latest commit of the current branch *)
482
+
let sessions = sessions s in
483
+
match List.exists (String.equal m) sessions with
485
+
let sesh = S.of_branch (S.repo store) m in
486
+
Ok (H.Store ((module S), sesh), ctx)
488
+
match fork s m with
490
+
Fmt.pr "[fork]: %a\n%!" (text `Red) err;
492
+
| Ok store -> Ok (store, ctx)))
191
-
Fmt.epr "%a: %s\n%!" (text `Red) "Unknown Shelter Action"
192
-
(String.concat " " args);
494
+
Fmt.epr "%a" (text `Red) "Unknown Shelter Action\n";
495
+
Shelter.shell_error (String.concat " " args)
let sessions = sessions s in
196
-
let sesh = Option.value ~default:"main" (which_branch s) in
197
-
let history = S.history store in
498
+
let sesh = Option.value ~default:"main" (snd (which_branch s)) in
499
+
let history = history s in
let pp_commit fmt (hash, msg) =
Fmt.pf fmt "[%a]: %s" (text `Yellow) hash msg
503
+
let repo = S.repo store in
202
-
S.History.fold_vertex
506
+
(fun acc (commit, _) ->
508
+
S.Hash.unsafe_of_raw_string commit
509
+
|> S.Commit.of_hash repo |> Option.get
let info = S.Commit.info commit |> S.Info.message in
let hash = S.Commit.hash commit |> Repr.to_string S.Hash.t in
(String.sub hash 0 7, info) :: acc)
~default:(fun () -> None)
213
-
(fun (_, e) -> Some (Repr.to_string Store.Build.t e.build))
520
+
(fun e -> Some (Repr.to_string Store.Build.t e.pre.build))
Fmt.pr "Sessions: %a\nCurrent: %a\nHash: %a\nCommits:@. %a\n%!"
Fmt.(list ~sep:(Fmt.any ", ") string)
···
| Undo -> Ok (reset_hard s, ctx)
225
-
| Fork new_branch -> (
226
-
match fork s new_branch with
228
-
Fmt.pr "[fork]: %a\n%!" (text `Red) err;
230
-
| Ok store -> Ok (store, ctx))
231
-
| Replay _ -> Ok (s, ctx)
532
+
| Replay branch -> replay config s ctx fs clock proc stdout branch
···
242
-
build = Store.Build.Image config.image;
246
-
(* TODO: extract with fetch *)
545
+
build = Store.Build.Image config.image;
547
+
(* TODO: extract with fetch *)
552
+
post = { diff = []; time = 0L };
254
-
let build, env, (uid, gid) =
255
-
match entry.build with
256
-
| Store.Build.Image img ->
257
-
let build, env, user = Store.fetch ctx img in
258
-
(build, env, Option.value ~default:(0, 0) user)
259
-
| Store.Build.Build cid -> (cid, entry.env, entry.user)
261
-
let hash_entry = { entry with build = Build build; args = command } in
262
-
let new_cid = Store.cid (Repr.to_string History.t hash_entry) in
263
-
let with_rootfs fn =
264
-
if entry.mode = R then (Store.Run.with_build ctx build fn, [])
265
-
else Store.Run.with_clone ctx ~src:build new_cid fn
556
+
let entry = { entry with pre = { entry.pre with args = command } } in
268
-
let new_entry, diff =
269
-
with_rootfs @@ fun rootfs ->
271
-
if config.no_runc then
272
-
let rootfs = Filename.concat rootfs "rootfs" in
275
-
|> Void.rootfs ~mode:entry.mode rootfs
276
-
|> Void.cwd entry.cwd
277
-
(* TODO: Support UIDs |> Void.uid 1000 *)
282
-
String.concat " " command ^ " && env > /tmp/shelter-env";
285
-
`Void (Void.spawn ~sw void |> Void.exit_status)
295
-
String.concat " " command ^ " && env > /tmp/shelter-env";
304
-
`Runc (Runc.spawn ~sw fs proc config rootfs)
306
-
Switch.run @@ fun sw ->
307
-
let res = spawn sw in
308
-
let start = Mtime_clock.now () in
311
-
| `Runc r -> Eio.Process.await r
312
-
| `Void v -> Void.to_eio_status (Eio.Promise.await v)
314
-
let stop = Mtime_clock.now () in
315
-
let span = Mtime.span start stop in
316
-
let time = Mtime.Span.to_uint64_ns span in
317
-
(* Add command to history regardless of exit status *)
318
-
let _ : (unit, string) result =
319
-
LNoise.history_add (String.concat " " command)
321
-
if res = `Exited 0 then (
324
-
Eio.Path.(fs / rootfs / "rootfs" / "tmp" / "shelter-env")
327
-
Eio.Path.(load env_path)
328
-
|> String.split_on_char '\n'
329
-
|> List.filter (fun s -> not (String.equal "" s))
331
-
Eio.Path.unlink env_path;
335
-
match Astring.String.cut ~sep:"=" v with
336
-
| Some ("PWD", dir) -> Some dir
339
-
|> Option.value ~default:hash_entry.cwd
341
-
if entry.mode = RW then
345
-
build = Build new_cid;
351
-
else Ok { hash_entry with time; cwd; env; user = (uid, gid) })
352
-
else Error (Eio.Process.Child_error res)
354
-
match new_entry with
355
-
| Error e -> Error e
358
-
let entry = { entry with diff } in
360
-
if entry.mode = RW then
362
-
~message:("exec " ^ String.concat " " command)
365
-
with Eio.Exn.Io (Eio.Process.E e, _) -> Error e)
558
+
let new_entry, diff = exec config ~stdout fs proc (s, ctx) entry in
559
+
complete_exec (s, ctx) clock fs new_entry diff
560
+
with Eio.Exn.Io (Eio.Process.E e, _) -> Shelter.process_error e)
anil.recoil.org