+4 -2

src/bin/main.ml

Reviewed

··· 30 30 Eio_posix.run @@ fun env -> 31 31 let cmd_file = Option.map (Eio.Path.( / ) env#fs) cmd_file in 32 32 let dir = state_dir env#fs "shelter" in 33 33 - Main.main config env#fs env#clock env#process_mgr dir cmd_file 33 33 + let stdout = (env#stdout :> Eio.Flow.sink_ty Eio.Flow.sink) in 34 34 + Main.main config ~stdout env#fs env#clock env#process_mgr dir cmd_file 34 35 in 35 36 let t = Term.(const run $ Shelter_main.config_term $ cmd_file) in 36 37 let man = ··· 49 50 Eio_posix.run @@ fun env -> 50 51 let cmd_file = Option.map (Eio.Path.( / ) env#fs) cmd_file in 51 52 let dir = state_dir env#fs "passthrough" in 52 52 - Pass.main config env#fs env#clock env#process_mgr dir cmd_file 53 53 + let stdout = (env#stdout :> Eio.Flow.sink_ty Eio.Flow.sink) in 54 54 + Pass.main config ~stdout env#fs env#clock env#process_mgr dir cmd_file 53 55 in 54 56 let t = Term.(const run $ Shelter_passthrough.config_term $ cmd_file) in 55 57 let info = Cmd.info "passthrough" in

+1

src/lib/engine.ml

Reviewed

··· 27 27 28 28 val run : 29 29 config -> 30 30 + stdout:Eio.Flow.sink_ty Eio.Flow.sink -> 30 31 Eio.Fs.dir_ty Eio.Path.t -> 31 32 _ Eio.Time.clock -> 32 33 Eio_unix.Process.mgr_ty Eio_unix.Process.mgr ->

+1 -1

src/lib/passthrough/shelter_passthrough.ml

Reviewed

··· 37 37 in 38 38 List.iter (fun v -> LNoise.history_add v |> ignore) entries 39 39 40 40 - let run (() : config) _fs clock proc 40 40 + let run (() : config) ~stdout:_ _fs clock proc 41 41 ( ((Shelter.History.Store ((module S), store) : entry Shelter.History.t) as 42 42 full_store), 43 43 () ) (Exec command) =

+7 -5

src/lib/shelter.ml

Reviewed

··· 5 5 module Make (H : History.S) (Engine : Engine.S with type entry = H.t) = struct 6 6 module Store = Irmin_fs_unix.KV.Make (H) 7 7 8 8 - let run config fs clock proc store = 8 8 + let run config ~stdout fs clock proc store = 9 9 let store = History.Store ((module Store), store) in 10 10 let initial_ctx = Engine.init fs proc store in 11 11 let rec loop store ctx exit_code = ··· 14 14 | None -> () 15 15 | Some input -> ( 16 16 let action = Engine.action_of_command input in 17 17 - match Engine.run config fs clock proc (store, ctx) action with 17 17 + match Engine.run config ~stdout fs clock proc (store, ctx) action with 18 18 | Error (Eio.Process.Child_error exit_code) -> 19 19 Fmt.epr "%a\n%!" Eio.Process.pp_status exit_code; 20 20 loop store ctx exit_code ··· 29 29 Eio.Path.load cf |> String.split_on_char '\n' 30 30 |> List.map Engine.action_of_command 31 31 32 32 - let main config fs clock proc directory command_file = 32 32 + let main config ~stdout fs clock proc directory command_file = 33 33 Irmin_fs.run directory @@ fun () -> 34 34 let conf = Irmin_fs.config (Eio.Path.native_exn directory) in 35 35 let repo = Store.Repo.v conf in ··· 42 42 let folder (store, ctx, exit_code) action = 43 43 if exit_code <> `Exited 0 then (store, ctx, exit_code) 44 44 else 45 45 - match Engine.run config fs clock proc (store, ctx) action with 45 45 + match 46 46 + Engine.run config ~stdout fs clock proc (store, ctx) action 47 47 + with 46 48 | Error (Eio.Process.Child_error exit_code) -> 47 49 Fmt.epr "%a\n%!" Eio.Process.pp_status exit_code; 48 50 (store, ctx, exit_code) ··· 59 61 | `Exited n | `Signaled n -> 60 62 Fmt.epr "%a\n%!" Eio.Process.pp_status exit_code; 61 63 exit n) 62 62 - | None -> run config fs clock proc store 64 64 + | None -> run config ~stdout fs clock proc store 63 65 end

+8 -1

src/lib/shelter/dune

Reviewed

··· 1 1 + ; (rule 2 2 + ; (target opentrace) 3 3 + ; (action 4 4 + ; (with-stdout-to opentrace (run echo hello)))) 5 5 + 1 6 (library 2 7 (name shelter_main) 3 8 (public_name shelter.main) 9 9 + (preprocessor_deps 10 10 + (file opentrace)) 4 11 (preprocess 5 5 - (pps ppx_repr)) 12 12 + (pps ppx_repr ppx_blob)) 6 13 (libraries shelter cid void zfs))

src/lib/shelter/opentrace

Reviewed

This is a binary file and will not be displayed.

+85 -41

src/lib/shelter/runc.ml

Reviewed

··· 31 31 ("options", `List (List.map (fun x -> `String x) options)); 32 32 ] 33 33 34 34 + type mount = { ty : [ `Bind ]; src : string; dst : string; readonly : bool } 35 35 + 36 36 + let user_mounts = 37 37 + List.map @@ fun { ty; src; dst; readonly } -> 38 38 + assert (ty = `Bind); 39 39 + let options = [ "bind"; "nosuid"; "nodev" ] in 40 40 + mount ~ty:"bind" ~src dst 41 41 + ~options:(if readonly then "ro" :: options else options) 42 42 + 34 43 let strings xs = `List (List.map (fun x -> `String x) xs) 35 44 let namespace x = `Assoc [ ("type", `String x) ] 36 45 ··· 112 121 network : string list; 113 122 user : int * int; 114 123 env : string list; 124 124 + mounts : mount list; 115 125 entrypoint : string option; 116 126 } 117 127 118 118 - let make { cwd; argv; hostname; network; user; env; entrypoint } ~config_dir 119 119 - ~results_dir : Yojson.Safe.t = 128 128 + let make { cwd; argv; hostname; network; user; env; mounts; entrypoint } 129 129 + ~config_dir ~results_dir : Yojson.Safe.t = 120 130 assert (entrypoint = None); 121 131 let user = 122 132 let uid, gid = user in ··· 161 171 `Assoc 162 172 [ 163 173 ("type", `String "RLIMIT_NOFILE"); 164 164 - ("hard", `Int 1024); 165 165 - ("soft", `Int 1024); 174 174 + ("hard", `Int 10_024); 175 175 + ("soft", `Int 10_024); 176 176 + ]; 177 177 + `Assoc 178 178 + [ 179 179 + ("type", `String "RLIMIT_MEMLOCK"); 180 180 + ("hard", `Int 1_000_000); 181 181 + ("soft", `Int 1_000_000); 166 182 ]; 167 183 ] ); 168 184 ("noNewPrivileges", `Bool false); ··· 180 196 ~options: 181 197 [ (* TODO: copy to others? *) "nosuid"; "noexec"; "nodev" ] 182 198 ~ty:"proc" ~src:"proc" 183 183 - :: mount "/dev" ~ty:"tmpfs" ~src:"tmpfs" 184 184 - ~options:[ "nosuid"; "strictatime"; "mode=755"; "size=65536k" ] 185 185 - :: mount "/dev/pts" ~ty:"devpts" ~src:"devpts" 186 186 - ~options: 187 187 - [ 188 188 - "nosuid"; 189 189 - "noexec"; 190 190 - "newinstance"; 191 191 - "ptmxmode=0666"; 192 192 - "mode=0620"; 193 193 - "gid=5"; 194 194 - (* tty *) 195 195 - ] 196 196 - :: mount 197 197 - "/sys" 198 198 - (* This is how Docker does it. runc's default is a bit different. *) 199 199 - ~ty:"sysfs" ~src:"sysfs" 200 200 - ~options:[ "nosuid"; "noexec"; "nodev"; "ro" ] 201 201 - :: mount "/sys/fs/cgroup" ~ty:"cgroup" ~src:"cgroup" 202 202 - ~options:[ "ro"; "nosuid"; "noexec"; "nodev" ] 203 203 - :: mount "/dev/shm" ~ty:"tmpfs" ~src:"shm" 204 204 - ~options: 205 205 - [ "nosuid"; "noexec"; "nodev"; "mode=1777"; "size=65536k" ] 206 206 - :: mount "/dev/mqueue" ~ty:"mqueue" ~src:"mqueue" 207 207 - ~options:[ "nosuid"; "noexec"; "nodev" ] 208 208 - :: mount "/etc/hosts" ~ty:"bind" ~src:(config_dir // "hosts") 209 209 - ~options:[ "ro"; "rbind"; "rprivate" ] 210 210 - :: 211 211 - (if network = [ "host" ] then 212 212 - [ 213 213 - mount "/etc/resolv.conf" ~ty:"bind" ~src:"/etc/resolv.conf" 214 214 - ~options:[ "ro"; "rbind"; "rprivate" ]; 215 215 - ] 216 216 - else [])) ); 199 199 + :: mount "/dev" ~ty:"tmpfs" ~src:"tmpfs" 200 200 + ~options: 201 201 + [ "nosuid"; "strictatime"; "mode=755"; "size=65536k" ] 202 202 + :: mount "/dev/pts" ~ty:"devpts" ~src:"devpts" 203 203 + ~options: 204 204 + [ 205 205 + "nosuid"; 206 206 + "noexec"; 207 207 + "newinstance"; 208 208 + "ptmxmode=0666"; 209 209 + "mode=0620"; 210 210 + "gid=5"; 211 211 + (* tty *) 212 212 + ] 213 213 + :: mount 214 214 + "/sys" 215 215 + (* This is how Docker does it. runc's default is a bit different. *) 216 216 + ~ty:"sysfs" ~src:"sysfs" 217 217 + ~options:[ "nosuid"; "noexec"; "nodev"; "ro" ] 218 218 + :: mount "/sys/fs/cgroup" ~ty:"cgroup" ~src:"cgroup" 219 219 + ~options:[ "ro"; "nosuid"; "noexec"; "nodev" ] 220 220 + :: mount "/dev/shm" ~ty:"tmpfs" ~src:"shm" 221 221 + ~options: 222 222 + [ "nosuid"; "noexec"; "nodev"; "mode=1777"; "size=65536k" ] 223 223 + :: mount "/dev/mqueue" ~ty:"mqueue" ~src:"mqueue" 224 224 + ~options:[ "nosuid"; "noexec"; "nodev" ] 225 225 + :: mount "/etc/hosts" ~ty:"bind" ~src:(config_dir // "hosts") 226 226 + ~options:[ "ro"; "rbind"; "rprivate" ] 227 227 + :: 228 228 + (if network = [ "host" ] then 229 229 + [ 230 230 + mount "/etc/resolv.conf" ~ty:"bind" ~src:"/etc/resolv.conf" 231 231 + ~options:[ "ro"; "rbind"; "rprivate" ]; 232 232 + ] 233 233 + else []) 234 234 + @ user_mounts mounts) ); 217 235 ( "linux", 218 236 `Assoc 219 237 [ ··· 248 266 249 267 let next_id = ref 0 250 268 251 251 - let spawn ~sw fs proc config dir = 269 269 + let to_other_sink_as_well ~other 270 270 + (Eio.Resource.T (t, handler) : Eio.Flow.sink_ty Eio.Flow.sink) = 271 271 + let module Sink = (val Eio.Resource.get handler Eio.Flow.Pi.Sink) in 272 272 + let copy_buf = Buffer.create 128 in 273 273 + let copy () ~src = 274 274 + Eio.Flow.copy src (Eio.Flow.buffer_sink copy_buf); 275 275 + Eio.Flow.copy_string (Buffer.contents copy_buf) other; 276 276 + Sink.copy t ~src:(Buffer.contents copy_buf |> Eio.Flow.string_source); 277 277 + Buffer.clear copy_buf 278 278 + in 279 279 + let single_write () x = 280 280 + let _ : int = Eio.Flow.single_write other x in 281 281 + Sink.single_write t x 282 282 + in 283 283 + let module T = struct 284 284 + type t = unit 285 285 + 286 286 + let single_write = single_write 287 287 + let copy = copy 288 288 + end in 289 289 + Eio.Resource.T ((), Eio.Flow.Pi.sink (module T)) 290 290 + 291 291 + let spawn ~sw log env config dir = 252 292 let tmp = Filename.temp_dir ~perms:0o700 "shelter-run-" "" in 253 253 - let eio_tmp = Eio.Path.(fs / tmp) in 293 293 + let eio_tmp = Eio.Path.(env#fs / tmp) in 254 294 let json_config = Json_config.make config ~config_dir:tmp ~results_dir:dir in 255 295 Eio.Path.save ~create:(`If_missing 0o644) (eio_tmp / "config.json") 256 296 (Yojson.Safe.pretty_to_string json_config ^ "\n"); ··· 259 299 let id = string_of_int !next_id in 260 300 incr next_id; 261 301 let cmd = [ "runc"; "--root"; "runc"; "run"; id ] in 262 262 - Eio.Process.spawn ~sw proc ~cwd:eio_tmp cmd 302 302 + let stdout = 303 303 + to_other_sink_as_well ~other:env#stdout 304 304 + (log :> Eio.Flow.sink_ty Eio.Flow.sink) 305 305 + in 306 306 + Eio.Process.spawn ~stdout ~sw env#proc ~cwd:eio_tmp cmd 263 307 264 308 (* 265 309 Apache License

+294 -169

src/lib/shelter/shelter_main.ml

Reviewed

··· 11 11 | "R" -> Void.R | "RW" -> Void.RW | _ -> failwith "Malformed Void.mode") 12 12 (function Void.R -> "R" | Void.RW -> "RW") 13 13 14 14 - type t = { 14 14 + type post = { diff : Diff.t; time : int64 } [@@deriving repr] 15 15 + 16 16 + type pre = { 15 17 mode : mode; 16 18 build : Store.Build.t; 17 19 args : string list; 18 18 - time : int64; 19 20 env : string list; 20 21 cwd : string; 21 22 user : int * int; 22 22 - diff : Diff.t; 23 23 } 24 24 [@@deriving repr] 25 25 + (** Needed for execution *) 26 26 + 27 27 + type t = { pre : pre; post : post } [@@deriving repr] 25 28 26 29 let merge = Irmin.Merge.(default (Repr.option t)) 27 30 end ··· 33 36 type entry = History.t 34 37 35 38 type action = 39 39 + (* Change modes *) 36 40 | Set_mode of History.mode 41 41 + (* Fork a new branch from an existing one, 42 42 + or switch to a branch if it exists *) 37 43 | Set_session of string 44 44 + (* Run a command *) 38 45 | Exec of string list 39 39 - | Info 46 46 + (* Undo the last command *) 40 47 | Undo 41 41 - | Fork of string 48 48 + (* Replay the current branch onto another *) 42 49 | Replay of string 50 50 + (* Display info *) 51 51 + | Info of [ `Current | `History ] 52 52 + (* Error state *) 43 53 | Unknown of string list 44 44 - | History 45 54 [@@deriving repr] 46 55 47 56 let split_and_remove_empty s = ··· 51 60 52 61 let shelter_action = function 53 62 | "mode" :: [ "r" ] -> Set_mode R 54 54 - | "mode" :: [ "rw" ] -> Set_mode R 63 63 + | "mode" :: [ "rw" ] -> Set_mode RW 55 64 | "session" :: [ m ] -> Set_session m 56 56 - | "fork" :: [ m ] -> Fork m 57 65 | "replay" :: [ onto ] -> Replay onto 58 58 - | [ "info" ] -> Info 66 66 + | [ "info" ] -> Info `Current 59 67 | [ "undo" ] -> Undo 60 60 - | [ "history" ] -> History 68 68 + | [ "history" ] -> Info `History 61 69 | other -> Unknown other 62 70 63 71 let action_of_command cmd = ··· 69 77 let history_key = [ "history" ] 70 78 let key clock = history_key @ [ string_of_float @@ Eio.Time.now clock ] 71 79 72 72 - let list (H.Store ((module S), store) : entry H.t) = 73 73 - match S.list store history_key with 74 74 - | [] -> [] 75 75 - | xs -> 76 76 - let rec loop acc = function 77 77 - | (s, `Contents (v, _meta)) :: next -> loop ((s, v) :: acc) next 78 78 - | _ :: next -> loop acc next 79 79 - | [] -> List.rev acc 80 80 + let history (H.Store ((module S), store) : entry H.t) = 81 81 + let repo = S.repo store in 82 82 + match S.Head.find store with 83 83 + | None -> [] 84 84 + | Some hd -> 85 85 + let rec linearize c = 86 86 + match S.Commit.parents c |> List.map (S.Commit.of_hash repo) with 87 87 + | [ Some p ] -> c :: linearize p 88 88 + | _ -> [ c ] 80 89 in 81 81 - loop [] (List.map (fun (v, tree) -> (v, S.Tree.to_concrete tree)) xs) 82 82 - |> List.stable_sort (fun (s1, _) (s2, _) -> 83 83 - Float.compare (Float.of_string s1) (Float.of_string s2)) 84 84 - |> List.rev 90 90 + let commits = linearize hd in 91 91 + let get_diff_content t1 t2 = 92 92 + match S.Tree.diff t1 t2 with 93 93 + | [ (_, `Added (c, _)) ] -> c 94 94 + | lst -> 95 95 + let pp_diff = 96 96 + Repr.pp (Irmin.Diff.t (Repr.pair History.t S.metadata_t)) 97 97 + in 98 98 + Fmt.epr "Get diff (%i) content %a%!" (List.length lst) 99 99 + Fmt.(list ~sep:Fmt.comma (Fmt.pair (Repr.pp S.path_t) pp_diff)) 100 100 + lst; 101 101 + invalid_arg "Get diff should only have a single difference." 102 102 + in 103 103 + let hash c = S.Commit.hash c |> S.Hash.to_raw_string in 104 104 + let rec diff_calc = function 105 105 + | [] -> [] 106 106 + | [ x ] -> 107 107 + let diff = get_diff_content (S.Tree.empty ()) (S.Commit.tree x) in 108 108 + [ (hash x, diff) ] 109 109 + | c :: p :: rest -> 110 110 + let diff = get_diff_content (S.Commit.tree p) (S.Commit.tree c) in 111 111 + (hash c, diff) :: diff_calc (p :: rest) 112 112 + in 113 113 + diff_calc commits 85 114 86 115 let with_latest ~default s f = 87 87 - match list s with [] -> default () | hd :: _ -> f hd 116 116 + match history s with [] -> default () | (_, hd) :: _ -> f hd 88 117 89 118 let text c = Fmt.(styled (`Fg c) string) 90 119 ··· 100 129 let repo = S.repo session in 101 130 let heads = List.map (fun b -> (S.Branch.find repo b, b)) branches in 102 131 let head = S.Head.find session in 103 103 - List.assoc_opt head heads 132 132 + let head_hash = 133 133 + Option.map 134 134 + (fun hash -> String.sub (Fmt.str "%a" S.Commit.pp_hash hash) 0 7) 135 135 + head 136 136 + in 137 137 + (head_hash, List.assoc_opt head heads) 104 138 105 139 (* Reset the head of the current session by one commit *) 106 140 let reset_hard ((H.Store ((module S), session) : entry H.t) as s) = ··· 127 161 Ok store 128 162 129 163 (* Fork a new session from an existing one *) 130 130 - let display_history (H.Store ((module S), session) : entry H.t) = 131 131 - let history = S.history ~depth:max_int session in 132 132 - let content c = 133 133 - H.Store ((module S), S.of_commit c) |> list |> List.hd |> snd 134 134 - in 164 164 + let display_history (s : entry H.t) = 135 165 let pp_diff fmt d = 136 166 if d = [] then () else Fmt.pf fmt "\n %a" (Repr.pp Diff.t) d 137 167 in 138 168 let pp_entry fmt (e : entry) = 139 169 Fmt.pf fmt "%-10s %s%a" 140 140 - Fmt.(str "%a" (styled (`Fg `Yellow) uint64_ns_span) e.time) 141 141 - (String.concat " " e.args) pp_diff e.diff 170 170 + Fmt.(str "%a" (styled (`Fg `Yellow) uint64_ns_span) e.post.time) 171 171 + (String.concat " " e.pre.args) 172 172 + pp_diff e.post.diff 142 173 in 143 143 - let linearize = 144 144 - S.History.fold_vertex (fun c v -> content c :: v) history [] |> List.rev 145 145 - in 146 146 - List.iter (fun c -> Fmt.pr "%a\n%!" pp_entry c) linearize 174 174 + let entries = history s |> List.rev in 175 175 + List.iter (fun (_hash, c) -> Fmt.pr "%a\n%!" pp_entry c) entries 147 176 148 177 let prompt status ((H.Store ((module S), _session) : entry H.t) as store) = 149 149 - let sesh = Option.value ~default:"main" (which_branch store) in 178 178 + let head, sesh = which_branch store in 179 179 + let sesh = Option.value ~default:"main" sesh in 150 180 let prompt () = 151 181 Fmt.(styled (`Fg `Yellow) string) Format.str_formatter "shelter> "; 152 182 Format.flush_str_formatter () 153 183 in 154 154 - let pp_sesh fmt sesh = Fmt.pf fmt "[%a]" (text `Green) sesh in 184 184 + let pp_head fmt = function 185 185 + | None -> Fmt.nop fmt () 186 186 + | Some h -> Fmt.pf fmt "#%a" (text `Magenta) h 187 187 + in 188 188 + let pp_sesh fmt sesh = Fmt.pf fmt "[%a%a]" (text `Green) sesh pp_head head in 155 189 let pp_status fmt = function 156 190 | `Exited 0 -> Fmt.nop fmt () 157 191 | `Exited n -> Fmt.pf fmt "%a " (text `Red) (string_of_int n) 158 192 | _ -> Fmt.nop fmt () 159 193 in 160 160 - let prompt_entry (_, (e : entry)) = 194 194 + let prompt_entry (e : entry) = 161 195 Fmt.pf Format.str_formatter "%a%a%a : { mode: %a }> " pp_status status 162 196 (text `Yellow) "shelter" pp_sesh sesh (text `Red) 163 163 - (if e.mode = R then "r" else "rw"); 197 197 + (if e.pre.mode = R then "r" else "rw"); 164 198 Format.flush_str_formatter () 165 199 in 166 200 with_latest store ~default:prompt prompt_entry 167 201 168 168 - type ctx = Store.t 202 202 + type ctx = { store : Store.t; tool_dir : string } 203 203 + 204 204 + let tools = [ ("opentrace", Tools.opentrace) ] 169 205 170 206 let init fs proc s = 171 207 let store = Store.init fs proc "shelter" in 172 208 List.iter 173 173 - (fun (_, { History.args; _ }) -> 209 209 + (fun (_, { History.pre = { History.args; _ }; _ }) -> 174 210 LNoise.history_add (String.concat " " args) |> ignore) 175 175 - (list s); 176 176 - store 211 211 + (history s); 212 212 + let tool_cid = Store.cid (String.concat ":" (List.map snd tools)) in 213 213 + let tools = 214 214 + Store.Run.with_tool store tool_cid @@ fun tool_dir -> 215 215 + Eio.Fiber.List.iter 216 216 + (fun (toolname, content) -> 217 217 + let new_path = Eio.Path.(fs / tool_dir / toolname) in 218 218 + Eio.Path.save ~create:(`If_missing 0o755) new_path content) 219 219 + tools; 220 220 + tool_dir 221 221 + in 222 222 + { store; tool_dir = tools } 177 223 178 178 - let run (config : config) fs clock proc 179 179 - (((H.Store ((module S), store) : entry H.t) as s), ctx) = function 224 224 + let run (config : config) ~stdout fs clock proc 225 225 + (((H.Store ((module S), store) : entry H.t) as s), (ctx : ctx)) = function 180 226 | Set_mode mode -> 181 181 - with_latest ~default:(fun _ -> Ok (s, ctx)) s @@ fun (_, entry) -> 182 182 - commit ~message:"mode change" clock s { entry with mode }; 227 227 + with_latest ~default:(fun _ -> Ok (s, ctx)) s @@ fun entry -> 228 228 + commit ~message:"mode change" clock s 229 229 + { entry with pre = { entry.pre with mode } }; 183 230 Ok (s, ctx) 184 184 - | Set_session m -> 185 185 - with_latest ~default:(fun _ -> Ok (s, ctx)) s @@ fun (_, entry) -> 186 186 - let new_store = S.of_branch (S.repo store) m in 187 187 - let new_full_store = H.Store ((module S), new_store) in 188 188 - commit ~message:"new session" clock new_full_store entry; 189 189 - Ok (new_full_store, ctx) 231 231 + | Set_session m -> ( 232 232 + (* Either set the session if the branch exists or create a new branch 233 233 + from the latest commit of the current branch *) 234 234 + let sessions = sessions s in 235 235 + match List.exists (String.equal m) sessions with 236 236 + | true -> 237 237 + let sesh = S.of_branch (S.repo store) m in 238 238 + Ok (H.Store ((module S), sesh), ctx) 239 239 + | false -> ( 240 240 + match fork s m with 241 241 + | Error err -> 242 242 + Fmt.pr "[fork]: %a\n%!" (text `Red) err; 243 243 + Ok (s, ctx) 244 244 + | Ok store -> Ok (store, ctx))) 190 245 | Unknown args -> 191 246 Fmt.epr "%a: %s\n%!" (text `Red) "Unknown Shelter Action" 192 247 (String.concat " " args); 193 248 Ok (s, ctx) 194 194 - | Info -> 249 249 + | Info `Current -> 195 250 let sessions = sessions s in 196 196 - let sesh = Option.value ~default:"main" (which_branch s) in 197 197 - let history = S.history store in 251 251 + let sesh = Option.value ~default:"main" (snd (which_branch s)) in 252 252 + let history = history s in 198 253 let pp_commit fmt (hash, msg) = 199 254 Fmt.pf fmt "[%a]: %s" (text `Yellow) hash msg 200 255 in 256 256 + let repo = S.repo store in 201 257 let commits = 202 202 - S.History.fold_vertex 203 203 - (fun commit acc -> 258 258 + List.fold_left 259 259 + (fun acc (commit, _) -> 260 260 + let commit = 261 261 + S.Hash.unsafe_of_raw_string commit 262 262 + |> S.Commit.of_hash repo |> Option.get 263 263 + in 204 264 let info = S.Commit.info commit |> S.Info.message in 205 265 let hash = S.Commit.hash commit |> Repr.to_string S.Hash.t in 206 266 (String.sub hash 0 7, info) :: acc) 207 207 - history [] 267 267 + [] history 208 268 in 209 269 let latest = 210 270 with_latest 211 271 ~default:(fun () -> None) 212 272 s 213 213 - (fun (_, e) -> Some (Repr.to_string Store.Build.t e.build)) 273 273 + (fun e -> Some (Repr.to_string Store.Build.t e.pre.build)) 214 274 in 215 275 Fmt.pr "Sessions: %a\nCurrent: %a\nHash: %a\nCommits:@. %a\n%!" 216 276 Fmt.(list ~sep:(Fmt.any ", ") string) ··· 222 282 Ok (s, ctx) 223 283 | Exec [] -> Ok (s, ctx) 224 284 | Undo -> Ok (reset_hard s, ctx) 225 225 - | Fork new_branch -> ( 226 226 - match fork s new_branch with 227 227 - | Error err -> 228 228 - Fmt.pr "[fork]: %a\n%!" (text `Red) err; 229 229 - Ok (s, ctx) 230 230 - | Ok store -> Ok (store, ctx)) 231 285 | Replay _ -> Ok (s, ctx) 232 232 - | History -> 286 286 + | Info `History -> 233 287 display_history s; 234 288 Ok (s, ctx) 235 289 | Exec command -> ( ··· 238 292 ~default:(fun () -> 239 293 History. 240 294 { 241 241 - mode = Void.RW; 242 242 - build = Store.Build.Image config.image; 243 243 - args = command; 244 244 - time = 0L; 245 245 - diff = []; 246 246 - (* TODO: extract with fetch *) 247 247 - env = []; 248 248 - cwd = "/"; 249 249 - user = (0, 0); 295 295 + pre = 296 296 + { 297 297 + mode = Void.RW; 298 298 + build = Store.Build.Image config.image; 299 299 + args = command; 300 300 + (* TODO: extract with fetch *) 301 301 + env = []; 302 302 + cwd = "/"; 303 303 + user = (0, 0); 304 304 + }; 305 305 + post = { diff = []; time = 0L }; 250 306 }) 251 307 s 252 252 - @@ fun (_, e) -> e 308 308 + @@ fun e -> e 253 309 in 254 310 let build, env, (uid, gid) = 255 255 - match entry.build with 311 311 + match entry.pre.build with 256 312 | Store.Build.Image img -> 257 257 - let build, env, user = Store.fetch ctx img in 313 313 + let build, env, user = Store.fetch ctx.store img in 258 314 (build, env, Option.value ~default:(0, 0) user) 259 259 - | Store.Build.Build cid -> (cid, entry.env, entry.user) 315 315 + | Store.Build.Build cid -> (cid, entry.pre.env, entry.pre.user) 316 316 + in 317 317 + let hash_entry = 318 318 + { 319 319 + entry with 320 320 + pre = { entry.pre with build = Build build; args = command }; 321 321 + } 260 322 in 261 261 - let hash_entry = { entry with build = Build build; args = command } in 262 262 - let new_cid = Store.cid (Repr.to_string History.t hash_entry) in 323 323 + (* Store things under History.pre, this makes it possible to rediscover 324 324 + the hash for something purely from the arguments needed to execute something 325 325 + rather than needing, for example, the time it took to execute! *) 326 326 + let new_cid = Store.cid (Repr.to_string History.pre_t hash_entry.pre) in 263 327 let with_rootfs fn = 264 264 - if entry.mode = R then (Store.Run.with_build ctx build fn, []) 265 265 - else Store.Run.with_clone ctx ~src:build new_cid fn 328 328 + if entry.pre.mode = R then (Store.Run.with_build ctx.store build fn, []) 329 329 + else Store.Run.with_clone ctx.store ~src:build new_cid fn 266 330 in 267 331 try 268 332 let new_entry, diff = 269 269 - with_rootfs @@ fun rootfs -> 270 270 - let spawn sw = 271 271 - if config.no_runc then 272 272 - let rootfs = Filename.concat rootfs "rootfs" in 273 273 - let void = 274 274 - Void.empty 275 275 - |> Void.rootfs ~mode:entry.mode rootfs 276 276 - |> Void.cwd entry.cwd 277 277 - (* TODO: Support UIDs |> Void.uid 1000 *) 278 278 - |> Void.exec ~env 279 279 - [ 280 280 - config.shell; 281 281 - "-c"; 282 282 - String.concat " " command ^ " && env > /tmp/shelter-env"; 283 283 - ] 333 333 + with_rootfs @@ function 334 334 + | `Exists path -> 335 335 + (* Copy the stdout log to stdout *) 336 336 + let () = 337 337 + Eio.Path.(with_open_in (fs / (path :> string) / "log")) 338 338 + @@ fun ic -> Eio.Flow.copy ic stdout 284 339 in 285 285 - `Void (Void.spawn ~sw void |> Void.exit_status) 286 286 - else 287 287 - let config = 288 288 - Runc.Json_config. 289 289 - { 290 290 - cwd = entry.cwd; 291 291 - argv = 292 292 - [ 293 293 - config.shell; 294 294 - "-c"; 295 295 - String.concat " " command ^ " && env > /tmp/shelter-env"; 296 296 - ]; 297 297 - hostname = ""; 298 298 - network = []; 299 299 - user = (uid, gid); 300 300 - env = entry.env; 301 301 - entrypoint = None; 302 302 - } 340 340 + let repo = S.repo store in 341 341 + let c = 342 342 + Eio.Path.(load (fs / (path :> string) / "hash")) 343 343 + |> S.Hash.unsafe_of_raw_string |> S.Commit.of_hash repo 344 344 + in 345 345 + Ok (`Reset c) 346 346 + | `Build rootfs -> 347 347 + let spawn sw log = 348 348 + if config.no_runc then 349 349 + let rootfs = Filename.concat rootfs "rootfs" in 350 350 + let void = 351 351 + Void.empty 352 352 + |> Void.rootfs ~mode:entry.pre.mode rootfs 353 353 + |> Void.cwd entry.pre.cwd 354 354 + (* TODO: Support UIDs |> Void.uid 1000 *) 355 355 + |> Void.exec ~env 356 356 + [ 357 357 + config.shell; 358 358 + "-c"; 359 359 + String.concat " " command 360 360 + ^ " && env > /tmp/shelter-env"; 361 361 + ] 362 362 + in 363 363 + `Void (Void.spawn ~sw void |> Void.exit_status) 364 364 + else 365 365 + let tool_mount : Runc.Json_config.mount = 366 366 + { 367 367 + ty = `Bind; 368 368 + src = ctx.tool_dir; 369 369 + dst = "/shelter-tools"; 370 370 + readonly = true; 371 371 + } 372 372 + in 373 373 + let config = 374 374 + Runc.Json_config. 375 375 + { 376 376 + cwd = entry.pre.cwd; 377 377 + argv = 378 378 + [ 379 379 + config.shell; 380 380 + "-c"; 381 381 + String.concat " " command 382 382 + ^ " && env > /tmp/shelter-env"; 383 383 + ]; 384 384 + hostname = ""; 385 385 + network = [ "host" ]; 386 386 + user = (uid, gid); 387 387 + env = entry.pre.env; 388 388 + mounts = [ tool_mount ]; 389 389 + entrypoint = None; 390 390 + } 391 391 + in 392 392 + let env = 393 393 + object 394 394 + method fs = fs 395 395 + method proc = proc 396 396 + method stdout = stdout 397 397 + end 398 398 + in 399 399 + `Runc (Runc.spawn ~sw log env config rootfs) 400 400 + in 401 401 + Switch.run @@ fun sw -> 402 402 + let log = 403 403 + Eio.Path.open_out ~sw ~create:(`If_missing 0o644) 404 404 + Eio.Path.(fs / rootfs / "log") 405 405 + in 406 406 + let res = spawn sw log in 407 407 + let start = Mtime_clock.now () in 408 408 + let res = 409 409 + match res with 410 410 + | `Runc r -> Eio.Process.await r 411 411 + | `Void v -> Void.to_eio_status (Eio.Promise.await v) 412 412 + in 413 413 + let stop = Mtime_clock.now () in 414 414 + let span = Mtime.span start stop in 415 415 + let time = Mtime.Span.to_uint64_ns span in 416 416 + (* Add command to history regardless of exit status *) 417 417 + let _ : (unit, string) result = 418 418 + LNoise.history_add (String.concat " " command) 303 419 in 304 304 - `Runc (Runc.spawn ~sw fs proc config rootfs) 305 305 - in 306 306 - Switch.run @@ fun sw -> 307 307 - let res = spawn sw in 308 308 - let start = Mtime_clock.now () in 309 309 - let res = 310 310 - match res with 311 311 - | `Runc r -> Eio.Process.await r 312 312 - | `Void v -> Void.to_eio_status (Eio.Promise.await v) 313 313 - in 314 314 - let stop = Mtime_clock.now () in 315 315 - let span = Mtime.span start stop in 316 316 - let time = Mtime.Span.to_uint64_ns span in 317 317 - (* Add command to history regardless of exit status *) 318 318 - let _ : (unit, string) result = 319 319 - LNoise.history_add (String.concat " " command) 320 320 - in 321 321 - if res = `Exited 0 then ( 322 322 - (* Extract env *) 323 323 - let env_path = 324 324 - Eio.Path.(fs / rootfs / "rootfs" / "tmp" / "shelter-env") 325 325 - in 326 326 - let env = 327 327 - Eio.Path.(load env_path) 328 328 - |> String.split_on_char '\n' 329 329 - |> List.filter (fun s -> not (String.equal "" s)) 330 330 - in 331 331 - Eio.Path.unlink env_path; 332 332 - let cwd = 333 333 - List.find_map 334 334 - (fun v -> 335 335 - match Astring.String.cut ~sep:"=" v with 336 336 - | Some ("PWD", dir) -> Some dir 337 337 - | _ -> None) 338 338 - env 339 339 - |> Option.value ~default:hash_entry.cwd 340 340 - in 341 341 - if entry.mode = RW then 342 342 - Ok 343 343 - { 344 344 - hash_entry with 345 345 - build = Build new_cid; 346 346 - time; 347 347 - env; 348 348 - cwd; 349 349 - user = (uid, gid); 350 350 - } 351 351 - else Ok { hash_entry with time; cwd; env; user = (uid, gid) }) 352 352 - else Error (Eio.Process.Child_error res) 420 420 + if res = `Exited 0 then ( 421 421 + (* Extract env *) 422 422 + let env_path = 423 423 + Eio.Path.(fs / rootfs / "rootfs" / "tmp" / "shelter-env") 424 424 + in 425 425 + let env = 426 426 + Eio.Path.(load env_path) 427 427 + |> String.split_on_char '\n' 428 428 + |> List.filter (fun s -> not (String.equal "" s)) 429 429 + in 430 430 + Eio.Path.unlink env_path; 431 431 + let cwd = 432 432 + List.find_map 433 433 + (fun v -> 434 434 + match Astring.String.cut ~sep:"=" v with 435 435 + | Some ("PWD", dir) -> Some dir 436 436 + | _ -> None) 437 437 + env 438 438 + |> Option.value ~default:hash_entry.pre.cwd 439 439 + in 440 440 + if entry.pre.mode = RW then 441 441 + Ok 442 442 + (`Entry 443 443 + ( { 444 444 + hash_entry with 445 445 + History.pre = 446 446 + { 447 447 + hash_entry.pre with 448 448 + build = Build new_cid; 449 449 + env; 450 450 + cwd; 451 451 + user = (uid, gid); 452 452 + }; 453 453 + }, 454 454 + rootfs )) 455 455 + else 456 456 + Ok 457 457 + (`Entry 458 458 + ( { 459 459 + pre = 460 460 + { hash_entry.pre with cwd; env; user = (uid, gid) }; 461 461 + post = { hash_entry.post with time }; 462 462 + }, 463 463 + rootfs ))) 464 464 + else Error (Eio.Process.Child_error res) 353 465 in 354 466 match new_entry with 355 467 | Error e -> Error e 356 356 - | Ok entry -> 468 468 + | Ok (`Reset None) -> 469 469 + Fmt.epr "Resetting to existing entry failed...\n%!"; 470 470 + Ok (s, ctx) 471 471 + | Ok (`Reset (Some c)) -> 472 472 + S.Head.set store c; 473 473 + Ok (s, ctx) 474 474 + | Ok (`Entry (entry, path)) -> 357 475 (* Set diff *) 358 358 - let entry = { entry with diff } in 476 476 + let entry = { entry with post = { entry.post with diff } } in 359 477 (* Commit if RW *) 360 360 - if entry.mode = RW then 478 478 + if entry.pre.mode = RW then ( 361 479 commit 362 480 ~message:("exec " ^ String.concat " " command) 363 481 clock s entry; 482 482 + (* Save the commit hash for easy restoring later *) 483 483 + let hash = 484 484 + S.Head.get store |> S.Commit.hash |> S.Hash.to_raw_string 485 485 + in 486 486 + Eio.Path.save ~create:(`If_missing 0o644) 487 487 + Eio.Path.(fs / path / "hash") 488 488 + hash); 364 489 Ok (s, ctx) 365 490 with Eio.Exn.Io (Eio.Process.E e, _) -> Error e)

+6 -3

src/lib/shelter/shelter_main.mli

Reviewed

··· 1 1 module Store = Store 2 2 3 3 module History : sig 4 4 - type t = { 4 4 + type post = { diff : Diff.t; time : int64 } [@@deriving repr] 5 5 + 6 6 + type pre = { 5 7 mode : Void.mode; 6 8 build : Store.Build.t; 7 9 args : string list; 8 8 - time : int64; 9 10 env : string list; 10 11 cwd : string; 11 12 user : int * int; 12 12 - diff : Diff.t; 13 13 } 14 14 [@@deriving repr] 15 15 + (** Needed for execution *) 16 16 + 17 17 + type t = { pre : pre; post : post } [@@deriving repr] 15 18 16 19 include Irmin.Contents.S with type t := t 17 20 end

+19 -5

src/lib/shelter/store.ml

Reviewed

··· 30 30 val builds : string -> dataset 31 31 val build : string -> string -> dataset 32 32 val snapshot : dataset -> snapshot 33 33 + val tools : string -> dataset 34 34 + val tool : string -> string -> dataset 33 35 end = struct 34 36 type dataset = string 35 37 type snapshot = string ··· 38 40 let builds pool : dataset = pool / "builds" 39 41 let build pool path : dataset = builds pool / path 40 42 let snapshot ds = ds ^ "@snappy" 43 43 + let tools pool : dataset = pool / "tools" 44 44 + let tool pool path : dataset = tools pool / path 41 45 end 42 46 43 47 let with_dataset ?(typ = Zfs.Types.filesystem) t dataset f = ··· 78 82 } 79 83 in 80 84 create_and_mount t (Datasets.builds t.pool); 85 85 + create_and_mount t (Datasets.tools t.pool); 81 86 t 82 87 83 88 let snapshot t (snap : Datasets.snapshot) = ··· 160 165 let ds = Datasets.build t.pool (Cid.to_string cid) in 161 166 Fun.protect ~finally:(fun () -> unmount_dataset t ds) @@ fun () -> 162 167 mount_dataset t ds; 168 168 + fn (`Build ("/" ^ (ds :> string))) 169 169 + 170 170 + let with_tool t cid fn = 171 171 + let ds = Datasets.tool t.pool (Cid.to_string cid) in 172 172 + Fun.protect ~finally:(fun () -> unmount_dataset t ds) @@ fun () -> 173 173 + mount_dataset t ds; 163 174 fn ("/" ^ (ds :> string)) 164 175 165 176 let with_clone t ~src new_cid fn = ··· 167 178 let tgt = Datasets.build t.pool (Cid.to_string new_cid) in 168 179 let src_snap = Datasets.snapshot ds in 169 180 let tgt_snap = Datasets.snapshot tgt in 170 170 - clone t src_snap tgt; 171 171 - let v = with_build t new_cid fn in 172 172 - snapshot t tgt_snap; 173 173 - let d = diff t src_snap tgt_snap in 174 174 - (v, d) 181 181 + if Zfs.exists t.zfs (tgt :> string) Zfs.Types.dataset then 182 182 + (fn (`Exists ("/" ^ (tgt :> string))), diff t src_snap tgt_snap) 183 183 + else ( 184 184 + clone t src_snap tgt; 185 185 + let v = with_build t new_cid fn in 186 186 + snapshot t tgt_snap; 187 187 + let d = diff t src_snap tgt_snap in 188 188 + (v, d)) 175 189 end

+1

src/lib/shelter/tools.ml

Reviewed

··· 1 1 + let opentrace = [%blob "./opentrace"]