commit cd45e2f76a1fb07a52d7e1a04ba538f7e94e60a4 · patrick.sirref.org/shelter

+9 -3

src/bin/main.ml

···

       15
       15
        
         Eio.Path.mkdirs ~exists_ok:true ~perm:0o755 path;

     

       16
       16
        
         path

     

       17
       17
        
       

     

       18
       18
       +
       module Eventloop = struct

     

       19
       19
       +
         let run fn =

     

       20
       20
       +
           Eio_posix.run @@ fun env ->

     

       21
       21
       +
           Lwt_eio.with_event_loop ~clock:env#clock @@ fun _token -> fn env

     

       22
       22
       +
       end

     

       23
       23
       +
       

     

       18
       24
        
       (* Command Line *)

     

       19
       25
        
       open Cmdliner

     

       20
       26
        
       

     
···

       27
       33
        
       

     

       28
       34
        
       let main =

     

       29
       35
        
         let run config cmd_file =

     

       30
       30
       -
           Eio_posix.run @@ fun env ->

     

       36
       36
       +
           Eventloop.run @@ fun env ->

     

       31
       37
        
           let cmd_file = Option.map (Eio.Path.( / ) env#fs) cmd_file in

     

       32
       38
        
           let dir = state_dir env#fs "shelter" in

     

       33
       39
        
           let stdout = (env#stdout :> Eio.Flow.sink_ty Eio.Flow.sink) in

     
···

       47
       53
        
       

     

       48
       54
        
       let passthrough =

     

       49
       55
        
         let run config cmd_file =

     

       50
       50
       -
           Eio_posix.run @@ fun env ->

     

       56
       56
       +
           Eventloop.run @@ fun env ->

     

       51
       57
        
           let cmd_file = Option.map (Eio.Path.( / ) env#fs) cmd_file in

     

       52
       58
        
           let dir = state_dir env#fs "passthrough" in

     

       53
       59
        
           let stdout = (env#stdout :> Eio.Flow.sink_ty Eio.Flow.sink) in

     
···

       59
       65
        
       

     

       60
       66
        
       let extract_commands =

     

       61
       67
        
         let run cmd_file =

     

       62
       62
       -
           Eio_posix.run @@ fun env ->

     

       68
       68
       +
           Eventloop.run @@ fun env ->

     

       63
       69
        
           let cmd_file = Eio.Path.( / ) env#fs (Option.get cmd_file) in

     

       64
       70
        
           Shelter.Script.to_commands cmd_file |> List.iter (Fmt.pr "%s\n")

     

       65
       71
        
         in

+10 -1

src/lib/dune

···

       1
       1
        
       (library

     

       2
       2
        
        (name shelter)

     

       3
       3
        
        (public_name shelter)

     

       4
       4
       -
        (libraries cmdliner irmin-fs.unix eio.unix eio linenoise void repr morbig))

     

       4
       4
       +
        (libraries

     

       5
       5
       +
         cmdliner

     

       6
       6
       +
         irmin-fs.unix

     

       7
       7
       +
         irmin-git.unix

     

       8
       8
       +
         eio.unix

     

       9
       9
       +
         eio

     

       10
       10
       +
         linenoise

     

       11
       11
       +
         void

     

       12
       12
       +
         repr

     

       13
       13
       +
         morbig))

+8 -1

src/lib/engine.ml

···

       17
       17
        
         (** A context that is not persisted, but is passed through each loop of the

     

       18
       18
        
             shell *)

     

       19
       19
        
       

     

       20
       20
       +
         type error

     

       21
       21
       +
         (** Shell specific errors *)

     

       22
       22
       +
       

     

       23
       23
       +
         val pp_error : error Fmt.t

     

       24
       24
       +
       

     

       20
       25
        
         val init :

     

       21
       26
        
           _ Eio.Path.t ->

     

       22
       27
        
           Eio_unix.Process.mgr_ty Eio_unix.Process.mgr ->

     
···

       33
       38
        
           Eio_unix.Process.mgr_ty Eio_unix.Process.mgr ->

     

       34
       39
        
           entry History.t * ctx ->

     

       35
       40
        
           action ->

     

       36
       36
       -
           (entry History.t * ctx, Eio.Process.error) result

     

       41
       41
       +
           ( entry History.t * ctx,

     

       42
       42
       +
             [ `Process of Eio.Process.error | `Shell of error ] )

     

       43
       43
       +
           result

     

       37
       44
        
         (** [run history action] runs the action in [history]. Return a new [history]

     

       38
       45
        
             that can be persisted *)

     

       39
       46

+6 -2

src/lib/passthrough/shelter_passthrough.ml

···

       1
       1
        
       open Eio

     

       2
       2
        
       

     

       3
       3
       +
       type error = string

     

       4
       4
       +
       

     

       5
       5
       +
       let pp_error = Fmt.string

     

       6
       6
       +
       

     

       3
       7
        
       type config = unit

     

       4
       8
        
       

     

       5
       9
        
       let config_term = Cmdliner.Term.const ()

     
···

       56
       60
        
             S.set_exn ~info store (key ()) command;

     

       57
       61
        
             let _ : (unit, string) result = LNoise.history_add command in

     

       58
       62
        
             Ok (full_store, ()))

     

       59
       59
       -
           else Error (Eio.Process.Child_error res)

     

       60
       60
       -
         with Eio.Exn.Io (Eio.Process.E e, _) -> Error e

     

       63
       63
       +
           else Shelter.process_error (Eio.Process.Child_error res)

     

       64
       64
       +
         with Eio.Exn.Io (Eio.Process.E e, _) -> Shelter.process_error e

+16 -7

src/lib/shelter.ml

···

       2
       2
        
       module Engine = Engine

     

       3
       3
        
       module Script = Script

     

       4
       4
        
       

     

       5
       5
       +
       let process_error e = Error (`Process e)

     

       6
       6
       +
       let shell_error e = Error (`Shell e)

     

       7
       7
       +
       

     

       5
       8
        
       module Make (H : History.S) (Engine : Engine.S with type entry = H.t) = struct

     

       6
       6
       -
         module Store = Irmin_fs_unix.KV.Make (H)

     

       9
       9
       +
         module Store = Irmin_git_unix.FS.KV (H)

     

       7
       10
        
       

     

       8
       11
        
         let run config ~stdout fs clock proc store =

     

       9
       12
        
           let store = History.Store ((module Store), store) in

     
···

       15
       18
        
             | Some input -> (

     

       16
       19
        
                 let action = Engine.action_of_command input in

     

       17
       20
        
                 match Engine.run config ~stdout fs clock proc (store, ctx) action with

     

       18
       18
       -
                 | Error (Eio.Process.Child_error exit_code) ->

     

       21
       21
       +
                 | Error (`Process (Eio.Process.Child_error exit_code)) ->

     

       19
       22
        
                     Fmt.epr "%a\n%!" Eio.Process.pp_status exit_code;

     

       20
       23
        
                     loop store ctx exit_code

     

       21
       21
       -
                 | Error (Eio.Process.Executable_not_found m) ->

     

       22
       22
       -
                     Fmt.epr "cshell: excutable not found %s\n%!" m;

     

       24
       24
       +
                 | Error (`Process (Eio.Process.Executable_not_found m)) ->

     

       25
       25
       +
                     Fmt.epr "shelter: excutable not found %s\n%!" m;

     

       23
       26
        
                     loop store ctx (`Exited 127)

     

       27
       27
       +
                 | Error (`Shell e) ->

     

       28
       28
       +
                     Fmt.epr "shelter: %a\n%!" Engine.pp_error e;

     

       29
       29
       +
                     loop store ctx (`Exited 255)

     

       24
       30
        
                 | Ok (store, ctx) -> loop store ctx (`Exited 0))

     

       25
       31
        
           in

     

       26
       32
        
           loop store initial_ctx (`Exited 0)

     
···

       45
       51
        
                   match

     

       46
       52
        
                     Engine.run config ~stdout fs clock proc (store, ctx) action

     

       47
       53
        
                   with

     

       48
       48
       -
                   | Error (Eio.Process.Child_error exit_code) ->

     

       54
       54
       +
                   | Error (`Process (Eio.Process.Child_error exit_code)) ->

     

       49
       55
        
                       Fmt.epr "%a\n%!" Eio.Process.pp_status exit_code;

     

       50
       56
        
                       (store, ctx, exit_code)

     

       51
       51
       -
                   | Error (Eio.Process.Executable_not_found m) ->

     

       52
       52
       -
                       Fmt.epr "cshell: excutable not found %s\n%!" m;

     

       57
       57
       +
                   | Error (`Process (Eio.Process.Executable_not_found m)) ->

     

       58
       58
       +
                       Fmt.epr "shelter: excutable not found %s\n%!" m;

     

       53
       59
        
                       (store, ctx, `Exited 127)

     

       60
       60
       +
                   | Error (`Shell e) ->

     

       61
       61
       +
                       Fmt.epr "shelter: %a\n%!" Engine.pp_error e;

     

       62
       62
       +
                       (store, ctx, `Exited 255)

     

       54
       63
        
                   | Ok (store, ctx) -> (store, ctx, `Exited 0)

     

       55
       64
        
               in

     

       56
       65
        
               let _store, _ctx, exit_code =

+106 -38

src/lib/shelter/shelter_main.ml

···

       2
       2
        
       module Store = Store

     

       3
       3
        
       module H = Shelter.History

     

       4
       4
        
       

     

       5
       5
       +
       type error = string

     

       6
       6
       +
       

     

       7
       7
       +
       let pp_error = Fmt.string

     

       8
       8
       +
       

     

       5
       9
        
       module History = struct

     

       6
       10
        
         type mode = Void.mode

     

       7
       11
        
       

     
···

       221
       225
        
         in

     

       222
       226
        
         { store; tool_dir = tools }

     

       223
       227
        
       

     

       224
       224
       -
       (* Run a command *)

     

       228
       228
       +
       (* Run a command:

     

       229
       229
       +
         

     

       230
       230
       +
          - TODO: pretty confusing that we `entry` to build from and also as the

     

       231
       231
       +
            thing we are building (e.g. the build field and the args field... *)

     

       225
       232
        
       let exec (config : config) ~stdout fs proc

     

       226
       233
        
           ((H.Store ((module S), _) : entry H.t), (ctx : ctx)) (entry : entry) =

     

       227
       234
        
         let build, env, (uid, gid) =

     
···

       236
       243
        
           { entry with pre = { entry.pre with build = Build build } }

     

       237
       244
        
         in

     

       238
       245
        
         (* Store things under History.pre, this makes it possible to rediscover

     

       239
       239
       -
                the hash for something purely from the arguments needed to execute something

     

       240
       240
       -
                rather than needing, for example, the time it took to execute! *)

     

       241
       241
       -
         let new_cid = Store.cid (Repr.to_string History.pre_t hash_entry.pre) in

     

       246
       246
       +
            the hash for something purely from the arguments needed to execute something

     

       247
       247
       +
            rather than needing, for example, the time it took to execute!

     

       248
       248
       +
       

     

       249
       249
       +
            Also, combine it with previous build step. *)

     

       250
       250
       +
         let new_cid =

     

       251
       251
       +
           Store.cid (Cid.to_string build ^ Repr.to_string History.pre_t hash_entry.pre)

     

       252
       252
       +
         in

     

       242
       253
        
         let with_rootfs fn =

     

       243
       254
        
           if entry.pre.mode = R then (Store.Run.with_build ctx.store build fn, [])

     

       244
       255
        
           else Store.Run.with_clone ctx.store ~src:build new_cid fn

     
···

       255
       266
        
         | `Build rootfs ->

     

       256
       267
        
             let spawn sw log =

     

       257
       268
        
               if config.no_runc then

     

       269
       269
       +
                 (* Experiment Void Process *)

     

       258
       270
        
                 let rootfs = Filename.concat rootfs "rootfs" in

     

       259
       271
        
                 let void =

     

       260
       272
        
                   Void.empty

     
···

       367
       379
        
                          post = { hash_entry.post with time };

     

       368
       380
        
                        },

     

       369
       381
        
                        rootfs )))

     

       370
       370
       -
             else Error (Eio.Process.Child_error res)

     

       382
       382
       +
             else Shelter.process_error (Eio.Process.Child_error res)

     

       383
       383
       +
       

     

       384
       384
       +
       let complete_exec ((H.Store ((module S), store) as s : entry H.t), ctx) clock fs

     

       385
       385
       +
           new_entry diff =

     

       386
       386
       +
         match new_entry with

     

       387
       387
       +
         | Error e -> Error e

     

       388
       388
       +
         | Ok (`Reset c) -> (

     

       389
       389
       +
             match

     

       390
       390
       +
               S.Hash.unsafe_of_raw_string c |> S.Commit.of_hash (S.repo store)

     

       391
       391
       +
             with

     

       392
       392
       +
             | None ->

     

       393
       393
       +
                 Fmt.epr "Resetting to existing entry failed...\n%!";

     

       394
       394
       +
                 Ok (s, ctx)

     

       395
       395
       +
             | Some c ->

     

       396
       396
       +
                 S.Head.set store c;

     

       397
       397
       +
                 Ok (s, ctx))

     

       398
       398
       +
         | Ok (`Entry (entry, path)) ->

     

       399
       399
       +
             (* Set diff *)

     

       400
       400
       +
             let entry = History.{ entry with post = { entry.post with diff } } in

     

       401
       401
       +
             (* Commit if RW *)

     

       402
       402
       +
             if entry.pre.mode = RW then (

     

       403
       403
       +
               commit

     

       404
       404
       +
                 ~message:("exec " ^ String.concat " " entry.pre.args)

     

       405
       405
       +
                 clock s entry;

     

       406
       406
       +
               (* Save the commit hash for easy restoring later *)

     

       407
       407
       +
               let hash = S.Head.get store |> S.Commit.hash |> S.Hash.to_raw_string in

     

       408
       408
       +
               Eio.Path.save ~create:(`If_missing 0o644)

     

       409
       409
       +
                 Eio.Path.(fs / path / "hash")

     

       410
       410
       +
                 hash);

     

       411
       411
       +
             Ok (s, ctx)

     

       412
       412
       +
       

     

       413
       413
       +
       let replay config (H.Store ((module S), s) as store : entry H.t) ctx fs clock

     

       414
       414
       +
           proc stdout existing_branch =

     

       415
       415
       +
         let seshes = sessions store in

     

       416
       416
       +
         if not (List.exists (String.equal existing_branch) seshes) then (

     

       417
       417
       +
           Fmt.epr "%s does not exist!" existing_branch;

     

       418
       418
       +
           Ok (store, ctx))

     

       419
       419
       +
         else

     

       420
       420
       +
           let repo = S.repo s in

     

       421
       421
       +
           let onto = S.of_branch repo existing_branch in

     

       422
       422
       +
           match S.lcas ~n:1 s onto with

     

       423
       423
       +
           | Error lcas_error ->

     

       424
       424
       +
               Fmt.epr "Replay LCAS: %a" (Repr.pp S.lca_error_t) lcas_error;

     

       425
       425
       +
               Ok (store, ctx)

     

       426
       426
       +
           | Ok [ lcas ] -> (

     

       427
       427
       +
               let all_commits = history store in

     

       428
       428
       +
               let lcas_hash = S.Commit.hash lcas |> S.Hash.to_raw_string in

     

       429
       429
       +
               let rec collect = function

     

       430
       430
       +
                 | [] -> []

     

       431
       431
       +
                 | (x, _) :: _ when String.equal lcas_hash x -> []

     

       432
       432
       +
                 | v :: vs -> v :: collect vs

     

       433
       433
       +
               in

     

       434
       434
       +
               let commits_to_apply = collect all_commits in

     

       435
       435
       +
               match commits_to_apply with

     

       436
       436
       +
               | [] -> Shelter.shell_error ""

     

       437
       437
       +
               | (h, first) :: rest ->

     

       438
       438
       +
                   let _, last_other =

     

       439
       439
       +
                     history (H.Store ((module S), onto)) |> List.hd

     

       440
       440
       +
                   in

     

       441
       441
       +
                   let new_first =

     

       442
       442
       +
                     {

     

       443
       443
       +
                       first with

     

       444
       444
       +
                       pre = { first.pre with build = last_other.pre.build };

     

       445
       445
       +
                     }

     

       446
       446
       +
                   in

     

       447
       447
       +
                   let commits_to_apply = (h, new_first) :: rest in

     

       448
       448
       +
                   (* Now we reset our head to point to the other store's head

     

       449
       449
       +
                  and replay our commits onto it *)

     

       450
       450
       +
                   let other_head = S.Head.get onto in

     

       451
       451
       +
                   S.Head.set s other_head;

     

       452
       452
       +
                   let res =

     

       453
       453
       +
                     List.fold_left

     

       454
       454
       +
                       (fun last (_, (entry : entry)) ->

     

       455
       455
       +
                         match last with

     

       456
       456
       +
                         | Error _ as e -> e

     

       457
       457
       +
                         | Ok (new_store, new_ctx) ->

     

       458
       458
       +
                             let new_entry, diff =

     

       459
       459
       +
                               exec config ~stdout fs proc (new_store, new_ctx) entry

     

       460
       460
       +
                             in

     

       461
       461
       +
                             complete_exec (new_store, new_ctx) clock fs new_entry diff)

     

       462
       462
       +
                       (Ok (H.Store ((module S), s), ctx))

     

       463
       463
       +
                       commits_to_apply

     

       464
       464
       +
                   in

     

       465
       465
       +
                   res)

     

       466
       466
       +
           | _ -> assert false (* Because n = 1 *)

     

       371
       467
        
       

     

       372
       468
        
       let run (config : config) ~stdout fs clock proc

     

       373
       469
        
           (((H.Store ((module S), store) : entry H.t) as s), (ctx : ctx)) = function

     
···

       391
       487
        
                     Ok (s, ctx)

     

       392
       488
        
                 | Ok store -> Ok (store, ctx)))

     

       393
       489
        
         | Unknown args ->

     

       394
       394
       -
             Fmt.epr "%a: %s\n%!" (text `Red) "Unknown Shelter Action"

     

       395
       395
       -
               (String.concat " " args);

     

       396
       396
       -
             Ok (s, ctx)

     

       490
       490
       +
             Fmt.epr "%a" (text `Red) "Unknown Shelter Action\n";

     

       491
       491
       +
             Shelter.shell_error (String.concat " " args)

     

       397
       492
        
         | Info `Current ->

     

       398
       493
        
             let sessions = sessions s in

     

       399
       494
        
             let sesh = Option.value ~default:"main" (snd (which_branch s)) in

     
···

       430
       525
        
             Ok (s, ctx)

     

       431
       526
        
         | Exec [] -> Ok (s, ctx)

     

       432
       527
        
         | Undo -> Ok (reset_hard s, ctx)

     

       433
       433
       -
         | Replay _ -> Ok (s, ctx)

     

       528
       528
       +
         | Replay branch -> replay config s ctx fs clock proc stdout branch

     

       434
       529
        
         | Info `History ->

     

       435
       530
        
             display_history s;

     

       436
       531
        
             Ok (s, ctx)

     
···

       457
       552
        
             let entry = { entry with pre = { entry.pre with args = command } } in

     

       458
       553
        
             try

     

       459
       554
        
               let new_entry, diff = exec config ~stdout fs proc (s, ctx) entry in

     

       460
       460
       -
               match new_entry with

     

       461
       461
       -
               | Error e -> Error e

     

       462
       462
       -
               | Ok (`Reset c) -> (

     

       463
       463
       -
                   match

     

       464
       464
       -
                     S.Hash.unsafe_of_raw_string c |> S.Commit.of_hash (S.repo store)

     

       465
       465
       -
                   with

     

       466
       466
       -
                   | None ->

     

       467
       467
       -
                       Fmt.epr "Resetting to existing entry failed...\n%!";

     

       468
       468
       -
                       Ok (s, ctx)

     

       469
       469
       -
                   | Some c ->

     

       470
       470
       -
                       S.Head.set store c;

     

       471
       471
       -
                       Ok (s, ctx))

     

       472
       472
       -
               | Ok (`Entry (entry, path)) ->

     

       473
       473
       -
                   (* Set diff *)

     

       474
       474
       -
                   let entry = { entry with post = { entry.post with diff } } in

     

       475
       475
       -
                   (* Commit if RW *)

     

       476
       476
       -
                   if entry.pre.mode = RW then (

     

       477
       477
       -
                     commit

     

       478
       478
       -
                       ~message:("exec " ^ String.concat " " command)

     

       479
       479
       -
                       clock s entry;

     

       480
       480
       -
                     (* Save the commit hash for easy restoring later *)

     

       481
       481
       -
                     let hash =

     

       482
       482
       -
                       S.Head.get store |> S.Commit.hash |> S.Hash.to_raw_string

     

       483
       483
       -
                     in

     

       484
       484
       -
                     Eio.Path.save ~create:(`If_missing 0o644)

     

       485
       485
       -
                       Eio.Path.(fs / path / "hash")

     

       486
       486
       -
                       hash);

     

       487
       487
       -
                   Ok (s, ctx)

     

       488
       488
       -
             with Eio.Exn.Io (Eio.Process.E e, _) -> Error e)

     

       555
       555
       +
               complete_exec (s, ctx) clock fs new_entry diff

     

       556
       556
       +
             with Eio.Exn.Io (Eio.Process.E e, _) -> Shelter.process_error e)