···
| "R" -> Void.R | "RW" -> Void.RW | _ -> failwith "Malformed Void.mode")
(function Void.R -> "R" | Void.RW -> "RW")
14
+
type post = { diff : Diff.t; time : int64 } [@@deriving repr]
25
+
(** Needed for execution *)
27
+
type t = { pre : pre; post : post } [@@deriving repr]
let merge = Irmin.Merge.(default (Repr.option t))
···
| Set_mode of History.mode
41
+
(* Fork a new branch from an existing one,
42
+
or switch to a branch if it exists *)
46
+
(* Undo the last command *)
48
+
(* Replay the current branch onto another *)
51
+
| 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
63
+
| "mode" :: [ "rw" ] -> Set_mode RW
| "session" :: [ m ] -> Set_session m
56
-
| "fork" :: [ m ] -> Fork m
| "replay" :: [ onto ] -> Replay onto
58
-
| [ "info" ] -> Info
66
+
| [ "info" ] -> Info `Current
60
-
| [ "history" ] -> History
68
+
| [ "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
80
+
let history (H.Store ((module S), store) : entry H.t) =
81
+
let repo = S.repo store in
82
+
match S.Head.find store with
85
+
let rec linearize c =
86
+
match S.Commit.parents c |> List.map (S.Commit.of_hash repo) with
87
+
| [ 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))
90
+
let commits = linearize hd in
91
+
let get_diff_content t1 t2 =
92
+
match S.Tree.diff t1 t2 with
93
+
| [ (_, `Added (c, _)) ] -> c
96
+
Repr.pp (Irmin.Diff.t (Repr.pair History.t S.metadata_t))
98
+
Fmt.epr "Get diff (%i) content %a%!" (List.length lst)
99
+
Fmt.(list ~sep:Fmt.comma (Fmt.pair (Repr.pp S.path_t) pp_diff))
101
+
invalid_arg "Get diff should only have a single difference."
103
+
let hash c = S.Commit.hash c |> S.Hash.to_raw_string in
104
+
let rec diff_calc = function
107
+
let diff = get_diff_content (S.Tree.empty ()) (S.Commit.tree x) in
109
+
| c :: p :: rest ->
110
+
let diff = get_diff_content (S.Commit.tree p) (S.Commit.tree c) in
111
+
(hash c, diff) :: diff_calc (p :: rest)
let with_latest ~default s f =
87
-
match list s with [] -> default () | hd :: _ -> f hd
116
+
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
134
+
(fun hash -> String.sub (Fmt.str "%a" S.Commit.pp_hash hash) 0 7)
137
+
(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
164
+
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
170
+
Fmt.(str "%a" (styled (`Fg `Yellow) uint64_ns_span) e.post.time)
171
+
(String.concat " " e.pre.args)
172
+
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
174
+
let entries = history s |> List.rev in
175
+
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
178
+
let head, sesh = which_branch store in
179
+
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
184
+
let pp_head fmt = function
185
+
| None -> Fmt.nop fmt ()
186
+
| Some h -> Fmt.pf fmt "#%a" (text `Magenta) h
188
+
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)) =
194
+
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");
197
+
(if e.pre.mode = R then "r" else "rw");
Format.flush_str_formatter ()
with_latest store ~default:prompt prompt_entry
202
+
type ctx = { store : Store.t; tool_dir : string }
204
+
let tools = [ ("opentrace", Tools.opentrace) ]
let store = Store.init fs proc "shelter" in
173
-
(fun (_, { History.args; _ }) ->
209
+
(fun (_, { History.pre = { History.args; _ }; _ }) ->
LNoise.history_add (String.concat " " args) |> ignore)
212
+
let tool_cid = Store.cid (String.concat ":" (List.map snd tools)) in
214
+
Store.Run.with_tool store tool_cid @@ fun tool_dir ->
215
+
Eio.Fiber.List.iter
216
+
(fun (toolname, content) ->
217
+
let new_path = Eio.Path.(fs / tool_dir / toolname) in
218
+
Eio.Path.save ~create:(`If_missing 0o755) new_path content)
222
+
{ store; tool_dir = tools }
178
-
let run (config : config) fs clock proc
179
-
(((H.Store ((module S), store) : entry H.t) as s), ctx) = function
224
+
let run (config : config) ~stdout fs clock proc
225
+
(((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 };
227
+
with_latest ~default:(fun _ -> Ok (s, ctx)) s @@ fun entry ->
228
+
commit ~message:"mode change" clock s
229
+
{ 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)
231
+
| Set_session m -> (
232
+
(* Either set the session if the branch exists or create a new branch
233
+
from the latest commit of the current branch *)
234
+
let sessions = sessions s in
235
+
match List.exists (String.equal m) sessions with
237
+
let sesh = S.of_branch (S.repo store) m in
238
+
Ok (H.Store ((module S), sesh), ctx)
240
+
match fork s m with
242
+
Fmt.pr "[fork]: %a\n%!" (text `Red) err;
244
+
| Ok store -> Ok (store, ctx)))
Fmt.epr "%a: %s\n%!" (text `Red) "Unknown Shelter Action"
(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
251
+
let sesh = Option.value ~default:"main" (snd (which_branch s)) in
252
+
let history = history s in
let pp_commit fmt (hash, msg) =
Fmt.pf fmt "[%a]: %s" (text `Yellow) hash msg
256
+
let repo = S.repo store in
202
-
S.History.fold_vertex
259
+
(fun acc (commit, _) ->
261
+
S.Hash.unsafe_of_raw_string commit
262
+
|> 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))
273
+
(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))
| Replay _ -> Ok (s, ctx)
···
242
-
build = Store.Build.Image config.image;
246
-
(* TODO: extract with fetch *)
298
+
build = Store.Build.Image config.image;
300
+
(* TODO: extract with fetch *)
305
+
post = { diff = []; time = 0L };
let build, env, (uid, gid) =
255
-
match entry.build with
311
+
match entry.pre.build with
| Store.Build.Image img ->
257
-
let build, env, user = Store.fetch ctx img in
313
+
let build, env, user = Store.fetch ctx.store img in
(build, env, Option.value ~default:(0, 0) user)
259
-
| Store.Build.Build cid -> (cid, entry.env, entry.user)
315
+
| Store.Build.Build cid -> (cid, entry.pre.env, entry.pre.user)
320
+
pre = { entry.pre with build = Build build; args = command };
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
323
+
(* Store things under History.pre, this makes it possible to rediscover
324
+
the hash for something purely from the arguments needed to execute something
325
+
rather than needing, for example, the time it took to execute! *)
326
+
let new_cid = Store.cid (Repr.to_string History.pre_t hash_entry.pre) in
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
328
+
if entry.pre.mode = R then (Store.Run.with_build ctx.store build fn, [])
329
+
else Store.Run.with_clone ctx.store ~src:build new_cid fn
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";
333
+
with_rootfs @@ function
335
+
(* Copy the stdout log to stdout *)
337
+
Eio.Path.(with_open_in (fs / (path :> string) / "log"))
338
+
@@ fun ic -> Eio.Flow.copy ic stdout
285
-
`Void (Void.spawn ~sw void |> Void.exit_status)
295
-
String.concat " " command ^ " && env > /tmp/shelter-env";
340
+
let repo = S.repo store in
342
+
Eio.Path.(load (fs / (path :> string) / "hash"))
343
+
|> S.Hash.unsafe_of_raw_string |> S.Commit.of_hash repo
348
+
if config.no_runc then
349
+
let rootfs = Filename.concat rootfs "rootfs" in
352
+
|> Void.rootfs ~mode:entry.pre.mode rootfs
353
+
|> Void.cwd entry.pre.cwd
354
+
(* TODO: Support UIDs |> Void.uid 1000 *)
359
+
String.concat " " command
360
+
^ " && env > /tmp/shelter-env";
363
+
`Void (Void.spawn ~sw void |> Void.exit_status)
365
+
let tool_mount : Runc.Json_config.mount =
368
+
src = ctx.tool_dir;
369
+
dst = "/shelter-tools";
376
+
cwd = entry.pre.cwd;
381
+
String.concat " " command
382
+
^ " && env > /tmp/shelter-env";
385
+
network = [ "host" ];
387
+
env = entry.pre.env;
388
+
mounts = [ tool_mount ];
396
+
method stdout = stdout
399
+
`Runc (Runc.spawn ~sw log env config rootfs)
401
+
Switch.run @@ fun sw ->
403
+
Eio.Path.open_out ~sw ~create:(`If_missing 0o644)
404
+
Eio.Path.(fs / rootfs / "log")
406
+
let res = spawn sw log in
407
+
let start = Mtime_clock.now () in
410
+
| `Runc r -> Eio.Process.await r
411
+
| `Void v -> Void.to_eio_status (Eio.Promise.await v)
413
+
let stop = Mtime_clock.now () in
414
+
let span = Mtime.span start stop in
415
+
let time = Mtime.Span.to_uint64_ns span in
416
+
(* Add command to history regardless of exit status *)
417
+
let _ : (unit, string) result =
418
+
LNoise.history_add (String.concat " " command)
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)
420
+
if res = `Exited 0 then (
423
+
Eio.Path.(fs / rootfs / "rootfs" / "tmp" / "shelter-env")
426
+
Eio.Path.(load env_path)
427
+
|> String.split_on_char '\n'
428
+
|> List.filter (fun s -> not (String.equal "" s))
430
+
Eio.Path.unlink env_path;
434
+
match Astring.String.cut ~sep:"=" v with
435
+
| Some ("PWD", dir) -> Some dir
438
+
|> Option.value ~default:hash_entry.pre.cwd
440
+
if entry.pre.mode = RW then
447
+
hash_entry.pre with
448
+
build = Build new_cid;
460
+
{ hash_entry.pre with cwd; env; user = (uid, gid) };
461
+
post = { hash_entry.post with time };
464
+
else Error (Eio.Process.Child_error res)
468
+
| Ok (`Reset None) ->
469
+
Fmt.epr "Resetting to existing entry failed...\n%!";
471
+
| Ok (`Reset (Some c)) ->
472
+
S.Head.set store c;
474
+
| Ok (`Entry (entry, path)) ->
358
-
let entry = { entry with diff } in
476
+
let entry = { entry with post = { entry.post with diff } } in
360
-
if entry.mode = RW then
478
+
if entry.pre.mode = RW then (
~message:("exec " ^ String.concat " " command)
482
+
(* Save the commit hash for easy restoring later *)
484
+
S.Head.get store |> S.Commit.hash |> S.Hash.to_raw_string
486
+
Eio.Path.save ~create:(`If_missing 0o644)
487
+
Eio.Path.(fs / path / "hash")
with Eio.Exn.Io (Eio.Process.E e, _) -> Error e)
anil.recoil.org