commit 496e512f6f134551dd7f5b42e48cfb7500fd9dfa · patrick.sirref.org/shelter

+20 -1

src/lib/shelter/shelter_main.mli

···

       1
       1
        
       module Store = Store

     

       2
       2
        
       

     

       3
       3
        
       module History : sig

     

       4
       4
       +
         type mode = Void.mode

     

       4
       5
        
         type post = { diff : Diff.t; time : int64 } [@@deriving repr]

     

       5
       6
        
       

     

       6
       7
        
         type pre = {

     
···

       19
       20
        
         include Irmin.Contents.S with type t := t

     

       20
       21
        
       end

     

       21
       22
        
       

     

       22
       22
       -
       include Shelter.Engine.S with type entry = History.t

     

       23
       23
       +
       type action =

     

       24
       24
       +
         (* Change modes *)

     

       25
       25
       +
         | Set_mode of History.mode

     

       26
       26
       +
         (* Fork a new branch from an existing one,

     

       27
       27
       +
            or switch to a branch if it exists *)

     

       28
       28
       +
         | Set_session of string

     

       29
       29
       +
         (* Run a command *)

     

       30
       30
       +
         | Exec of string list

     

       31
       31
       +
         (* Undo the last command *)

     

       32
       32
       +
         | Undo

     

       33
       33
       +
         (* Replay the current branch onto another *)

     

       34
       34
       +
         | Replay of string

     

       35
       35
       +
         (* Display info *)

     

       36
       36
       +
         | Info of [ `Current | `History ]

     

       37
       37
       +
         (* Error state *)

     

       38
       38
       +
         | Unknown of string list

     

       39
       39
       +
       [@@deriving repr]

     

       40
       40
       +
       

     

       41
       41
       +
       include Shelter.Engine.S with type entry = History.t and type action := action

+23 -11

src/lib/shelter/store.ml

···

       94
       94
        
         let exists = Zfs.exists t.zfs (snap :> string) Zfs.Types.snapshot in

     

       95
       95
        
         if not exists then Zfs.snapshot t.zfs (snap :> string) true

     

       96
       96
        
       

     

       97
       97
       +
       let destroy t (d : Datasets.dataset) =

     

       98
       98
       +
         with_dataset t (d :> string) @@ fun ds -> Zfs.destroy ds false

     

       99
       99
       +
       

     

       97
       100
        
       let clone t (snap : Datasets.snapshot) (tgt : Datasets.dataset) =

     

       98
       101
        
         with_dataset ~typ:Zfs.Types.snapshot t (snap :> string) @@ fun src ->

     

       99
       102
        
         Zfs.clone src (tgt :> string)

     
···

       137
       140
        
         let cid = cid image in

     

       138
       141
        
         let cids = cid |> Cid.to_string in

     

       139
       142
        
         let dataset = Datasets.build t.pool cids in

     

       140
       140
       -
         let dir = Eio.Path.(t.fs / ("/" ^ (Datasets.build t.pool cids :> string))) in

     

       141
       141
       -
         create_and_mount t dataset;

     

       142
       142
       -
         let _dir : string = Fetch.get_image ~dir ~proc:t.proc image in

     

       143
       143
       -
         snapshot t (Datasets.snapshot dataset);

     

       144
       143
        
         let username = Fetch.get_user t.proc image in

     

       145
       145
       -
         ( cid,

     

       146
       146
       -
           Fetch.get_env t.proc image,

     

       147
       147
       -
           get_uid_gid ~username Eio.Path.(dir / "rootfs") )

     

       144
       144
       +
         let dir = Eio.Path.(t.fs / ("/" ^ (Datasets.build t.pool cids :> string))) in

     

       145
       145
       +
         if Zfs.exists t.zfs (dataset :> string) Zfs.Types.dataset then

     

       146
       146
       +
           ( cid,

     

       147
       147
       +
             Fetch.get_env t.proc image,

     

       148
       148
       +
             get_uid_gid ~username Eio.Path.(dir / "rootfs") )

     

       149
       149
       +
         else (

     

       150
       150
       +
           create_and_mount t dataset;

     

       151
       151
       +
           let _dir : string = Fetch.get_image ~dir ~proc:t.proc image in

     

       152
       152
       +
           snapshot t (Datasets.snapshot dataset);

     

       153
       153
       +
           ( cid,

     

       154
       154
       +
             Fetch.get_env t.proc image,

     

       155
       155
       +
             get_uid_gid ~username Eio.Path.(dir / "rootfs") ))

     

       148
       156
        
       

     

       149
       157
        
       module Run = struct

     

       150
       158
        
         let with_build t cid fn =

     
···

       193
       201
        
             (fn (`Exists ("/" ^ (tgt :> string))), diff t src_snap tgt_snap output)

     

       194
       202
        
           else (

     

       195
       203
        
             clone t src_snap tgt;

     

       196
       196
       -
             let v = with_build t new_cid fn in

     

       197
       197
       -
             snapshot t tgt_snap;

     

       198
       198
       -
             let d = diff t src_snap tgt_snap output in

     

       199
       199
       -
             (v, d))

     

       204
       204
       +
             match with_build t new_cid fn with

     

       205
       205
       +
             | Error _ as v ->

     

       206
       206
       +
                 destroy t tgt;

     

       207
       207
       +
                 (v, [])

     

       208
       208
       +
             | Ok _ as v ->

     

       209
       209
       +
                 snapshot t tgt_snap;

     

       210
       210
       +
                 let d = diff t src_snap tgt_snap output in

     

       211
       211
       +
                 (v, d))

     

       200
       212
        
       end

+1

vendor/zfs/src/function_description.ml

···

       49
       49
        
             (Types.zfs_handle_t @-> string_opt @-> int @-> returning int)

     

       50
       50
        
       

     

       51
       51
        
         let close = foreign "zfs_close" (Types.zfs_handle_t @-> returning void)

     

       52
       52
       +
         let destroy = foreign "zfs_destroy" (Types.zfs_handle_t @-> bool @-> returning int)

     

       52
       53
        
         let get_type = foreign "zfs_get_type" (Types.zfs_handle_t @-> returning int)

     

       53
       54
        
       

     

       54
       55
        
         module Nvlist = struct

+4

vendor/zfs/src/zfs.ml

···

       94
       94
        
         let i = C.Functions.create handle path type_ (Nvlist.v props) in

     

       95
       95
        
         if i != 0 then failwith "Failed to create" else ()

     

       96
       96
        
       

     

       97
       97
       +
       let destroy handle recurse =

     

       98
       98
       +
         let i = C.Functions.destroy handle recurse in

     

       99
       99
       +
         if i != 0 then invalid_arg "destroy" else ()

     

       100
       100
       +
       

     

       97
       101
        
       let open_ handle path (type_ : Types.t) = C.Functions.open_ handle path type_

     

       98
       102
        
       let close : t -> unit = C.Functions.close

     

       99
       103
        
       let get_type : t -> Types.t = C.Functions.get_type

+3

vendor/zfs/src/zfs.mli

···

       75
       75
        
       val close : t -> unit

     

       76
       76
        
       (** Close a dataset *)

     

       77
       77
        
       

     

       78
       78
       +
       val destroy : t -> bool -> unit

     

       79
       79
       +
       (** Destroy a dataset *)

     

       80
       80
       +
       

     

       78
       81
        
       val exists : Handle.t -> string -> Types.t -> bool

     

       79
       82
        
       (** Check if a dataset of a specific type exists *)

     

       80
       83